From fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4 Mon Sep 17 00:00:00 2001 From: Joseph Hunkeler Date: Wed, 8 Jul 2015 20:46:52 -0400 Subject: Initial commit --- sys/INDEX | 3884 ++++++++++++++++++++++++++ sys/NAMES | 3884 ++++++++++++++++++++++++++ sys/README | 27 + sys/_sys.hd | 5 + sys/clio/README | 98 + sys/clio/clcache.x | 490 ++++ sys/clio/clclose.x | 16 + sys/clio/clcmd.x | 35 + sys/clio/clcmdw.x | 28 + sys/clio/clcpset.x | 11 + sys/clio/clepset.x | 48 + sys/clio/clgcur.x | 110 + sys/clio/clgetb.x | 23 + sys/clio/clgetc.x | 23 + sys/clio/clgetd.x | 23 + sys/clio/clgeti.x | 16 + sys/clio/clgetl.x | 16 + sys/clio/clgetr.x | 16 + sys/clio/clgets.x | 16 + sys/clio/clgetx.x | 23 + sys/clio/clgfil.x | 144 + sys/clio/clgkey.x | 67 + sys/clio/clglpb.x | 23 + sys/clio/clglpc.x | 23 + sys/clio/clglpd.x | 24 + sys/clio/clglpi.x | 18 + sys/clio/clglpl.x | 19 + sys/clio/clglpr.x | 20 + sys/clio/clglps.x | 19 + sys/clio/clglpx.x | 23 + sys/clio/clglstr.x | 21 + sys/clio/clgpset.x | 19 + sys/clio/clgpseta.x | 18 + sys/clio/clgpsetb.x | 17 + sys/clio/clgpsetc.x | 17 + sys/clio/clgpsetd.x | 17 + sys/clio/clgpseti.x | 17 + sys/clio/clgpsetl.x | 17 + sys/clio/clgpsetr.x | 17 + sys/clio/clgpsets.x | 17 + sys/clio/clgpsetx.x | 17 + sys/clio/clgstr.x | 21 + sys/clio/clgwrd.x | 33 + sys/clio/clio.com | 18 + sys/clio/cllpset.x | 17 + sys/clio/clopen.x | 124 + sys/clio/clopset.x | 18 + sys/clio/clppset.x | 18 + sys/clio/clppseta.x | 17 + sys/clio/clppsetb.x | 17 + sys/clio/clppsetc.x | 17 + sys/clio/clppsetd.x | 17 + sys/clio/clppseti.x | 17 + sys/clio/clppsetl.x | 17 + sys/clio/clppsetr.x | 17 + sys/clio/clppsets.x | 17 + sys/clio/clppsetx.x | 17 + sys/clio/clpset.h | 12 + sys/clio/clpsetnm.x | 25 + sys/clio/clpstr.x | 26 + sys/clio/clputb.x | 30 + sys/clio/clputc.x | 36 + sys/clio/clputd.x | 30 + sys/clio/clputi.x | 64 + sys/clio/clputr.x | 18 + sys/clio/clputx.x | 30 + sys/clio/clreqpar.x | 25 + sys/clio/clseti.x | 23 + sys/clio/clstati.x | 25 + sys/clio/doc/clio.hd | 40 + sys/clio/doc/clio.men | 16 + sys/clio/gexfls.x | 58 + sys/clio/mkpkg | 75 + sys/clio/rdukey.x | 209 ++ sys/clio/zfiocl.x | 317 +++ sys/dbio/README | 3 + sys/dbio/db2.doc | 674 +++++ sys/dbio/db2.hlp | 612 ++++ sys/dbio/doc/dbio.hlp | 413 +++ sys/dbio/new/coords | 73 + sys/dbio/new/dbio.con | 202 ++ sys/dbio/new/dbio.hlp | 3202 +++++++++++++++++++++ sys/dbio/new/dbio.hlp.1 | 346 +++ sys/dbio/new/dbki.hlp | Bin 0 -> 6401 bytes sys/dbio/new/ddl | 125 + sys/dbio/new/schema | 307 +++ sys/dbio/new/spie.ms | 17 + sys/etc/README | 4 + sys/etc/brktime.x | 79 + sys/etc/btoi.x | 14 + sys/etc/clktime.x | 16 + sys/etc/cnvdate.x | 52 + sys/etc/cnvtime.x | 31 + sys/etc/cputime.x | 14 + sys/etc/doc/Proc.hlp | 22 + sys/etc/doc/error.hlp | 51 + sys/etc/doc/etc.hd | 29 + sys/etc/doc/etc.men | 24 + sys/etc/doc/psio.doc | 275 ++ sys/etc/dtmcnv.x | 482 ++++ sys/etc/envgetb.x | 32 + sys/etc/envgetd.x | 27 + sys/etc/envgeti.x | 26 + sys/etc/envgetr.x | 18 + sys/etc/envgets.x | 62 + sys/etc/envindir.x | 31 + sys/etc/envinit.x | 27 + sys/etc/environ.com | 8 + sys/etc/environ.h | 28 + sys/etc/environ.x | 315 +++ sys/etc/envlist.x | 25 + sys/etc/envnext.x | 53 + sys/etc/envreset.x | 66 + sys/etc/envscan.x | 149 + sys/etc/erract.x | 93 + sys/etc/errcode.x | 18 + sys/etc/errget.x | 21 + sys/etc/error.com | 7 + sys/etc/error.x | 60 + sys/etc/gen/miireadd.x | 50 + sys/etc/gen/miireadi.x | 50 + sys/etc/gen/miireadl.x | 50 + sys/etc/gen/miireadr.x | 50 + sys/etc/gen/miireads.x | 50 + sys/etc/gen/miiwrited.x | 28 + sys/etc/gen/miiwritei.x | 28 + sys/etc/gen/miiwritel.x | 28 + sys/etc/gen/miiwriter.x | 28 + sys/etc/gen/miiwrites.x | 28 + sys/etc/gen/mkpkg | 30 + sys/etc/gen/nmireadb.x | 50 + sys/etc/gen/nmireadd.x | 50 + sys/etc/gen/nmireadi.x | 50 + sys/etc/gen/nmireadl.x | 50 + sys/etc/gen/nmireadr.x | 50 + sys/etc/gen/nmireads.x | 50 + sys/etc/gen/nmiwriteb.x | 28 + sys/etc/gen/nmiwrited.x | 28 + sys/etc/gen/nmiwritei.x | 28 + sys/etc/gen/nmiwritel.x | 28 + sys/etc/gen/nmiwriter.x | 28 + sys/etc/gen/nmiwrites.x | 28 + sys/etc/gethost.x | 13 + sys/etc/getpid.x | 12 + sys/etc/getuid.x | 24 + sys/etc/gmtcnv.x | 35 + sys/etc/gqsort.x | 84 + sys/etc/intr.x | 54 + sys/etc/itob.x | 14 + sys/etc/lineoff.x | 113 + sys/etc/locpr.x | 14 + sys/etc/locva.x | 13 + sys/etc/lpopen.x | 118 + sys/etc/maideh.x | 76 + sys/etc/main.x | 908 ++++++ sys/etc/miiread.gx | 50 + sys/etc/miireadc.x | 50 + sys/etc/miiwrite.gx | 28 + sys/etc/miiwritec.x | 28 + sys/etc/mkpkg | 125 + sys/etc/nmiread.gx | 50 + sys/etc/nmireadb.x | 32 + sys/etc/nmireadc.x | 50 + sys/etc/nmiwrite.gx | 28 + sys/etc/nmiwriteb.x | 21 + sys/etc/nmiwritec.x | 28 + sys/etc/onentry.x | 65 + sys/etc/onerror.x | 96 + sys/etc/onexit.x | 88 + sys/etc/oscmd.x | 116 + sys/etc/pagefiles.x | 1140 ++++++++ sys/etc/prc.com | 27 + sys/etc/prchdir.x | 21 + sys/etc/prclcpr.x | 33 + sys/etc/prcldpr.x | 47 + sys/etc/prclose.x | 32 + sys/etc/prd.com | 8 + sys/etc/prdone.x | 26 + sys/etc/prenvfree.x | 36 + sys/etc/prenvset.x | 24 + sys/etc/prfilbuf.x | 38 + sys/etc/prfindpr.x | 20 + sys/etc/prgline.x | 204 ++ sys/etc/prgredir.x | 19 + sys/etc/prkill.x | 42 + sys/etc/propcpr.x | 201 ++ sys/etc/propdpr.x | 68 + sys/etc/propen.x | 67 + sys/etc/proscmd.x | 32 + sys/etc/prpsio.x | 484 ++++ sys/etc/prpsload.x | 30 + sys/etc/prredir.x | 32 + sys/etc/prseti.x | 51 + sys/etc/prsignal.x | 27 + sys/etc/prstati.x | 49 + sys/etc/prupdate.x | 61 + sys/etc/psioisxt.x | 58 + sys/etc/psioxfer.x | 33 + sys/etc/qsort.x | 81 + sys/etc/sttyco.x | 519 ++++ sys/etc/syserr.x | 49 + sys/etc/sysid.x | 57 + sys/etc/syspanic.x | 17 + sys/etc/sysptime.x | 84 + sys/etc/tsleep.x | 13 + sys/etc/ttopen.x | 96 + sys/etc/urlget.x | 384 +++ sys/etc/votable.x | 304 ++ sys/etc/xalloc.x | 197 ++ sys/etc/xerfmt.x | 96 + sys/etc/xerpop.x | 55 + sys/etc/xerpue.x | 32 + sys/etc/xerreset.x | 19 + sys/etc/xerstmt.x | 66 + sys/etc/xerverify.x | 21 + sys/etc/xgdevlist.x | 49 + sys/etc/xisatty.x | 38 + sys/etc/xmjbuf.x | 20 + sys/etc/xttysize.x | 51 + sys/etc/xwhen.x | 13 + sys/etc/zzdebug.x | 404 +++ sys/fio/README | 10 + sys/fio/access.x | 58 + sys/fio/aread.x | 24 + sys/fio/areadb.x | 83 + sys/fio/await.x | 56 + sys/fio/awaitb.x | 39 + sys/fio/awrite.x | 24 + sys/fio/awriteb.x | 90 + sys/fio/close.x | 70 + sys/fio/delete.x | 110 + sys/fio/deletefg.x | 37 + sys/fio/diropen.x | 289 ++ sys/fio/doc/fio.hd | 54 + sys/fio/doc/fio.hlp | 1912 +++++++++++++ sys/fio/doc/fio.men | 50 + sys/fio/doc/vfn.hlp | 1028 +++++++ sys/fio/falloc.x | 73 + sys/fio/fcache.x | 733 +++++ sys/fio/fcanpb.x | 39 + sys/fio/fchdir.x | 57 + sys/fio/fclobber.x | 42 + sys/fio/fcopy.x | 83 + sys/fio/fdebug.x | 163 ++ sys/fio/fdevbf.x | 37 + sys/fio/fdevblk.x | 42 + sys/fio/fdevtx.x | 39 + sys/fio/fdirname.x | 46 + sys/fio/fexbuf.x | 46 + sys/fio/ffault.x | 127 + sys/fio/ffilbf.x | 37 + sys/fio/ffilsz.x | 54 + sys/fio/fflsbf.x | 27 + sys/fio/fgdevpar.x | 88 + sys/fio/fgetfd.x | 135 + sys/fio/filbuf.x | 113 + sys/fio/filerr.x | 16 + sys/fio/filopn.x | 164 ++ sys/fio/finfo.x | 46 + sys/fio/finit.x | 70 + sys/fio/fioclean.x | 130 + sys/fio/flsbuf.x | 69 + sys/fio/flush.x | 59 + sys/fio/fmapfn.x | 47 + sys/fio/fmkbfs.x | 61 + sys/fio/fmkcopy.x | 92 + sys/fio/fmkdir.x | 60 + sys/fio/fmkpbbuf.x | 34 + sys/fio/fnextn.x | 21 + sys/fio/fnldir.x | 22 + sys/fio/fnroot.x | 21 + sys/fio/fntgfn.x | 1004 +++++++ sys/fio/fnullfile.x | 38 + sys/fio/fopnbf.x | 16 + sys/fio/fopntx.x | 16 + sys/fio/fowner.x | 20 + sys/fio/fpathname.x | 38 + sys/fio/fputtx.x | 22 + sys/fio/freadp.x | 55 + sys/fio/fredir.x | 62 + sys/fio/frename.x | 122 + sys/fio/frmbfs.x | 38 + sys/fio/frmdir.x | 48 + sys/fio/frtnfd.x | 19 + sys/fio/fseti.x | 403 +++ sys/fio/fsfopen.x | 82 + sys/fio/fstati.x | 147 + sys/fio/fstatl.x | 31 + sys/fio/fstats.x | 29 + sys/fio/fstdfile.x | 37 + sys/fio/fstrfp.x | 27 + sys/fio/fsvtfn.x | 81 + sys/fio/fswapfd.x | 37 + sys/fio/fsymlink.x | 53 + sys/fio/funlink.x | 33 + sys/fio/futime.x | 34 + sys/fio/fwatio.x | 50 + sys/fio/fwritep.x | 63 + sys/fio/fwtacc.x | 120 + sys/fio/getc.x | 27 + sys/fio/getchar.x | 12 + sys/fio/getci.x | 27 + sys/fio/getline.x | 85 + sys/fio/getlline.x | 42 + sys/fio/glongline.x | 73 + sys/fio/isdir.x | 73 + sys/fio/mkpkg | 123 + sys/fio/mktemp.x | 48 + sys/fio/mmap.inc | 8 + sys/fio/ndopen.x | 94 + sys/fio/note.x | 29 + sys/fio/nowhite.x | 35 + sys/fio/nullfile.x | 251 ++ sys/fio/open.x | 99 + sys/fio/osfnlock.x | 417 +++ sys/fio/poll.x | 250 ++ sys/fio/protect.x | 61 + sys/fio/putc.x | 38 + sys/fio/putcc.x | 25 + sys/fio/putci.x | 26 + sys/fio/putline.x | 101 + sys/fio/read.x | 62 + sys/fio/rename.x | 38 + sys/fio/reopen.x | 55 + sys/fio/seek.x | 69 + sys/fio/stropen.x | 151 + sys/fio/ungetc.x | 69 + sys/fio/ungetci.x | 69 + sys/fio/ungetline.x | 75 + sys/fio/unread.x | 65 + sys/fio/vfnmap.x | 899 ++++++ sys/fio/vfntrans.x | 937 +++++++ sys/fio/write.x | 40 + sys/fio/xerputc.x | 37 + sys/fio/zfiott.com | 35 + sys/fio/zfiott.x | 1256 +++++++++ sys/fio/zzdebug.x | 625 +++++ sys/fmio/README | 339 +++ sys/fmio/fmaccess.x | 15 + sys/fmio/fmclose.x | 51 + sys/fmio/fmcopy.x | 37 + sys/fmio/fmcopyo.x | 63 + sys/fmio/fmdebug.x | 182 ++ sys/fmio/fmdelete.x | 11 + sys/fmio/fmfcache.x | 395 +++ sys/fmio/fmfopen.x | 30 + sys/fmio/fmio.h | 97 + sys/fmio/fmiobind.x | 61 + sys/fmio/fmioerr.x | 20 + sys/fmio/fmioextnd.x | 82 + sys/fmio/fmiopost.x | 20 + sys/fmio/fmiorhdr.x | 147 + sys/fmio/fmiosbuf.x | 56 + sys/fmio/fmiotick.x | 17 + sys/fmio/fmlfard.x | 29 + sys/fmio/fmlfawr.x | 35 + sys/fmio/fmlfawt.x | 18 + sys/fmio/fmlfbrd.x | 89 + sys/fmio/fmlfbwr.x | 109 + sys/fmio/fmlfbwt.x | 32 + sys/fmio/fmlfcls.x | 27 + sys/fmio/fmlfcopy.x | 118 + sys/fmio/fmlfdel.x | 29 + sys/fmio/fmlfname.x | 45 + sys/fmio/fmlfopen.x | 89 + sys/fmio/fmlfparse.x | 45 + sys/fmio/fmlfstat.h | 10 + sys/fmio/fmlfstat.x | 31 + sys/fmio/fmlfstt.x | 38 + sys/fmio/fmlfundel.x | 28 + sys/fmio/fmnextlf.x | 48 + sys/fmio/fmopen.x | 67 + sys/fmio/fmrebuild.x | 26 + sys/fmio/fmrename.x | 11 + sys/fmio/fmset.h | 24 + sys/fmio/fmseti.x | 39 + sys/fmio/fmstati.x | 36 + sys/fmio/fmsync.x | 169 ++ sys/fmio/mkpkg | 52 + sys/fmio/zzdebug.x | 303 ++ sys/fmtio/README | 6 + sys/fmtio/cctoc.x | 67 + sys/fmtio/chdeposit.x | 17 + sys/fmtio/chfetch.x | 16 + sys/fmtio/chrlwr.x | 16 + sys/fmtio/chrupr.x | 16 + sys/fmtio/clprintf.x | 17 + sys/fmtio/clscan.x | 32 + sys/fmtio/ctocc.x | 64 + sys/fmtio/ctod.x | 154 ++ sys/fmtio/ctoi.x | 48 + sys/fmtio/ctol.x | 52 + sys/fmtio/ctor.x | 34 + sys/fmtio/ctotok.x | 167 ++ sys/fmtio/ctowrd.x | 83 + sys/fmtio/ctox.x | 48 + sys/fmtio/doc/evexpr.hlp | 147 + sys/fmtio/doc/fmtio.hd | 77 + sys/fmtio/doc/fmtio.men | 59 + sys/fmtio/doc/lexnum.hlp | 303 ++ sys/fmtio/dtcscl.x | 35 + sys/fmtio/dtoc.x | 129 + sys/fmtio/dtoc3.x | 285 ++ sys/fmtio/eprintf.x | 14 + sys/fmtio/escchars.inc | 5 + sys/fmtio/evexpr.com | 7 + sys/fmtio/evexpr.x | 1477 ++++++++++ sys/fmtio/evexpr.y | 1087 ++++++++ sys/fmtio/evvexpr.com | 12 + sys/fmtio/evvexpr.gy | 2680 ++++++++++++++++++ sys/fmtio/evvexpr.x | 5050 ++++++++++++++++++++++++++++++++++ sys/fmtio/evvexpr.y | 4644 +++++++++++++++++++++++++++++++ sys/fmtio/fmt.com | 17 + sys/fmtio/fmterr.x | 25 + sys/fmtio/fmtinit.x | 23 + sys/fmtio/fmtread.x | 23 + sys/fmtio/fmtsetcol.x | 28 + sys/fmtio/fmtstr.x | 49 + sys/fmtio/fpradv.x | 76 + sys/fmtio/fprfmt.x | 180 ++ sys/fmtio/fprintf.x | 14 + sys/fmtio/fprntf.x | 40 + sys/fmtio/fscan.x | 30 + sys/fmtio/gargb.x | 33 + sys/fmtio/gargc.x | 19 + sys/fmtio/gargd.x | 20 + sys/fmtio/gargi.x | 20 + sys/fmtio/gargl.x | 20 + sys/fmtio/gargr.x | 17 + sys/fmtio/gargrad.x | 20 + sys/fmtio/gargs.x | 20 + sys/fmtio/gargstr.x | 24 + sys/fmtio/gargtok.x | 18 + sys/fmtio/gargwrd.x | 22 + sys/fmtio/gargx.x | 19 + sys/fmtio/gctod.x | 81 + sys/fmtio/gctol.x | 78 + sys/fmtio/gctox.x | 81 + sys/fmtio/gltoc.x | 82 + sys/fmtio/gstrcat.x | 26 + sys/fmtio/gstrcpy.x | 19 + sys/fmtio/itoc.x | 53 + sys/fmtio/lexdata.inc | 28 + sys/fmtio/lexnum.x | 190 ++ sys/fmtio/ltoc.x | 17 + sys/fmtio/mkpkg | 125 + sys/fmtio/nscan.x | 12 + sys/fmtio/parg.x | 283 ++ sys/fmtio/pargb.x | 16 + sys/fmtio/pargstr.x | 26 + sys/fmtio/pargx.x | 57 + sys/fmtio/patmatch.x | 568 ++++ sys/fmtio/printf.x | 13 + sys/fmtio/resetscan.x | 14 + sys/fmtio/scan.com | 10 + sys/fmtio/scanc.x | 14 + sys/fmtio/sprintf.x | 19 + sys/fmtio/sscan.x | 24 + sys/fmtio/strcat.x | 12 + sys/fmtio/strcmp.x | 17 + sys/fmtio/strcpy.x | 18 + sys/fmtio/strdic.x | 73 + sys/fmtio/streq.x | 16 + sys/fmtio/strge.x | 16 + sys/fmtio/strgt.x | 16 + sys/fmtio/stridx.x | 17 + sys/fmtio/stridxs.x | 43 + sys/fmtio/strldx.x | 20 + sys/fmtio/strldxs.x | 46 + sys/fmtio/strle.x | 16 + sys/fmtio/strlen.x | 14 + sys/fmtio/strlt.x | 16 + sys/fmtio/strlwr.x | 18 + sys/fmtio/strmac.x | 86 + sys/fmtio/strmatch.x | 136 + sys/fmtio/strncmp.x | 20 + sys/fmtio/strne.x | 16 + sys/fmtio/strsearch.x | 55 + sys/fmtio/strsrt.x | 73 + sys/fmtio/strtbl.x | 81 + sys/fmtio/strupr.x | 18 + sys/fmtio/tokdata.inc | 32 + sys/fmtio/xevgettok.x | 208 ++ sys/fmtio/xtoc.x | 39 + sys/fmtio/xvvgettok.x | 234 ++ sys/fmtio/zzdebug.x | 319 +++ sys/gio/README | 6 + sys/gio/aelogd.x | 16 + sys/gio/aelogr.x | 16 + sys/gio/calcomp/README | 34 + sys/gio/calcomp/ccp.com | 38 + sys/gio/calcomp/ccp.h | 92 + sys/gio/calcomp/ccpclear.x | 29 + sys/gio/calcomp/ccpclose.x | 22 + sys/gio/calcomp/ccpclws.x | 17 + sys/gio/calcomp/ccpcolor.x | 36 + sys/gio/calcomp/ccpcseg.x | 207 ++ sys/gio/calcomp/ccpdrawch.x | 233 ++ sys/gio/calcomp/ccpdseg.x | 208 ++ sys/gio/calcomp/ccpescape.x | 65 + sys/gio/calcomp/ccpfa.x | 16 + sys/gio/calcomp/ccpfaset.x | 18 + sys/gio/calcomp/ccpfont.x | 34 + sys/gio/calcomp/ccpinit.x | 165 ++ sys/gio/calcomp/ccpltype.x | 27 + sys/gio/calcomp/ccplwidth.x | 32 + sys/gio/calcomp/ccpopen.x | 77 + sys/gio/calcomp/ccpopenws.x | 87 + sys/gio/calcomp/ccppl.x | 105 + sys/gio/calcomp/ccpplset.x | 20 + sys/gio/calcomp/ccppm.x | 73 + sys/gio/calcomp/ccppmset.x | 19 + sys/gio/calcomp/ccpreset.x | 48 + sys/gio/calcomp/ccptx.x | 463 ++++ sys/gio/calcomp/ccptxset.x | 29 + sys/gio/calcomp/doc/ccpspecs.hlp | 384 +++ sys/gio/calcomp/font.com | 207 ++ sys/gio/calcomp/font.h | 29 + sys/gio/calcomp/mkpkg | 52 + sys/gio/calcomp/rptheta4.x | 37 + sys/gio/calcomp/t_calcomp.x | 125 + sys/gio/calcomp/vttest.par | 10 + sys/gio/calcomp/vttest.x | 608 ++++ sys/gio/calcomp/x_calcomp.x | 3 + sys/gio/cursor/README | 9 + sys/gio/cursor/doc/cursor.hlp | 194 ++ sys/gio/cursor/doc/giotr.notes | 330 +++ sys/gio/cursor/giotr.x | 183 ++ sys/gio/cursor/grc.h | 20 + sys/gio/cursor/grcaxes.x | 402 +++ sys/gio/cursor/grcclose.x | 42 + sys/gio/cursor/grccmd.x | 533 ++++ sys/gio/cursor/grcinit.x | 32 + sys/gio/cursor/grcopen.x | 105 + sys/gio/cursor/grcpl.x | 69 + sys/gio/cursor/grcread.x | 60 + sys/gio/cursor/grcredraw.x | 21 + sys/gio/cursor/grcscr.x | 49 + sys/gio/cursor/grcstatus.x | 49 + sys/gio/cursor/grctext.x | 57 + sys/gio/cursor/grcwarn.x | 27 + sys/gio/cursor/grcwcs.x | 282 ++ sys/gio/cursor/grcwrite.x | 66 + sys/gio/cursor/gtr.com | 25 + sys/gio/cursor/gtr.h | 51 + sys/gio/cursor/gtrbackup.x | 74 + sys/gio/cursor/gtrconn.x | 78 + sys/gio/cursor/gtrctrl.x | 122 + sys/gio/cursor/gtrdelete.x | 45 + sys/gio/cursor/gtrdiscon.x | 66 + sys/gio/cursor/gtrfetch.x | 48 + sys/gio/cursor/gtrframe.x | 41 + sys/gio/cursor/gtrgflush.x | 45 + sys/gio/cursor/gtrgtran.x | 28 + sys/gio/cursor/gtrgtty.x | 20 + sys/gio/cursor/gtrinit.x | 136 + sys/gio/cursor/gtropenws.x | 206 ++ sys/gio/cursor/gtrpage.x | 30 + sys/gio/cursor/gtrptran.x | 74 + sys/gio/cursor/gtrrcur.x | 32 + sys/gio/cursor/gtrredraw.x | 48 + sys/gio/cursor/gtrreset.x | 53 + sys/gio/cursor/gtrset.x | 28 + sys/gio/cursor/gtrstatus.x | 100 + sys/gio/cursor/gtrtrunc.x | 39 + sys/gio/cursor/gtrundo.x | 76 + sys/gio/cursor/gtrwaitp.x | 94 + sys/gio/cursor/gtrwcur.x | 19 + sys/gio/cursor/gtrwritep.x | 68 + sys/gio/cursor/gtrwsclip.x | 144 + sys/gio/cursor/gtrwstran.x | 490 ++++ sys/gio/cursor/mkpkg | 57 + sys/gio/cursor/prpsinit.x | 15 + sys/gio/cursor/rcursor.x | 692 +++++ sys/gio/doc/gio.hlp | 3498 +++++++++++++++++++++++ sys/gio/elogd.x | 27 + sys/gio/elogr.x | 27 + sys/gio/fonts/README | 42 + sys/gio/fonts/font.com | 746 +++++ sys/gio/fonts/greek.com | 501 ++++ sys/gio/fonts/greekc.txt | 96 + sys/gio/fonts/mkfont.c | 199 ++ sys/gio/fpequald.x | 41 + sys/gio/fpequalr.x | 41 + sys/gio/fpfixd.x | 43 + sys/gio/fpfixr.x | 43 + sys/gio/fpndgr.x | 21 + sys/gio/fpnormd.x | 40 + sys/gio/fpnormr.x | 40 + sys/gio/gactivate.x | 72 + sys/gio/gadraw.x | 284 ++ sys/gio/gamove.x | 27 + sys/gio/gascale.x | 62 + sys/gio/gcancel.x | 32 + sys/gio/gclear.x | 20 + sys/gio/gclose.x | 45 + sys/gio/gctran.x | 138 + sys/gio/gcurpos.x | 41 + sys/gio/gdeact.x | 28 + sys/gio/gescape.x | 19 + sys/gio/gfill.x | 30 + sys/gio/gflush.x | 18 + sys/gio/gframe.x | 18 + sys/gio/gfrinit.x | 26 + sys/gio/ggcell.x | 55 + sys/gio/ggcur.x | 37 + sys/gio/ggetb.x | 18 + sys/gio/ggeti.x | 17 + sys/gio/ggetr.x | 17 + sys/gio/ggets.x | 22 + sys/gio/ggscale.x | 64 + sys/gio/ggview.x | 21 + sys/gio/ggwind.x | 22 + sys/gio/gim/README | 215 ++ sys/gio/gim/gimcpras.x | 56 + sys/gio/gim/gimcrras.x | 26 + sys/gio/gim/gimderas.x | 17 + sys/gio/gim/gimdsmap.x | 21 + sys/gio/gim/gimenmap.x | 21 + sys/gio/gim/gimfcmap.x | 17 + sys/gio/gim/gimfmap.x | 17 + sys/gio/gim/gimgetmap.x | 85 + sys/gio/gim/gimimap.x | 13 + sys/gio/gim/gimlcmap.x | 51 + sys/gio/gim/gimqras.x | 46 + sys/gio/gim/gimrasini.x | 14 + sys/gio/gim/gimrcmap.x | 68 + sys/gio/gim/gimref.x | 18 + sys/gio/gim/gimrefpix.x | 38 + sys/gio/gim/gimriomap.x | 56 + sys/gio/gim/gimrpix.x | 62 + sys/gio/gim/gimsetmap.x | 80 + sys/gio/gim/gimsetpix.x | 41 + sys/gio/gim/gimsetras.x | 28 + sys/gio/gim/gimwcmap.x | 42 + sys/gio/gim/gimwiomap.x | 37 + sys/gio/gim/gimwpix.x | 47 + sys/gio/gim/mkpkg | 32 + sys/gio/gki/README | 84 + sys/gio/gki/gki.com | 8 + sys/gio/gki/gkicancel.x | 28 + sys/gio/gki/gkiclear.x | 28 + sys/gio/gki/gkiclose.x | 65 + sys/gio/gki/gkideact.x | 42 + sys/gio/gki/gkieof.x | 23 + sys/gio/gki/gkiesc.x | 40 + sys/gio/gki/gkiexe.x | 178 ++ sys/gio/gki/gkifa.x | 37 + sys/gio/gki/gkifaset.x | 35 + sys/gio/gki/gkifetch.x | 80 + sys/gio/gki/gkifflush.x | 24 + sys/gio/gki/gkiflush.x | 40 + sys/gio/gki/gkigca.x | 87 + sys/gio/gki/gkigcur.x | 106 + sys/gio/gki/gkigetwcs.x | 44 + sys/gio/gki/gkiinit.x | 22 + sys/gio/gki/gkiinline.x | 23 + sys/gio/gki/gkikern.x | 30 + sys/gio/gki/gkiopen.x | 67 + sys/gio/gki/gkipca.x | 47 + sys/gio/gki/gkipl.x | 37 + sys/gio/gki/gkiplset.x | 37 + sys/gio/gki/gkipm.x | 37 + sys/gio/gki/gkipmset.x | 37 + sys/gio/gki/gkiprint.x | 820 ++++++ sys/gio/gki/gkirca.x | 30 + sys/gio/gki/gkircval.x | 51 + sys/gio/gki/gkireact.x | 42 + sys/gio/gki/gkiredir.x | 34 + sys/gio/gki/gkiscur.x | 37 + sys/gio/gki/gkisetwcs.x | 46 + sys/gio/gki/gkititle.x | 51 + sys/gio/gki/gkitx.x | 57 + sys/gio/gki/gkitxset.x | 51 + sys/gio/gki/gkiwesc.x | 59 + sys/gio/gki/gkiwrite.x | 26 + sys/gio/gki/gkptxparg.x | 47 + sys/gio/gki/mkpkg | 46 + sys/gio/gki/zzdebug.x | 44 + sys/gio/gks/README | 50 + sys/gio/gks/gacwk.x | 20 + sys/gio/gks/gca.x | 36 + sys/gio/gks/gcas.x | 46 + sys/gio/gks/gclks.x | 9 + sys/gio/gks/gclrwk.x | 19 + sys/gio/gks/gclwk.x | 14 + sys/gio/gks/gdawk.x | 32 + sys/gio/gks/gfa.x | 22 + sys/gio/gks/gks.com | 10 + sys/gio/gks/gks.h | 40 + sys/gio/gks/gopks.x | 24 + sys/gio/gks/gopwk.x | 23 + sys/gio/gks/gpl.x | 20 + sys/gio/gks/gpm.x | 25 + sys/gio/gks/gqasf.x | 18 + sys/gio/gks/gqchh.x | 39 + sys/gio/gks/gqchup.x | 39 + sys/gio/gks/gqclip.x | 40 + sys/gio/gks/gqcntn.x | 30 + sys/gio/gks/gqmk.x | 31 + sys/gio/gks/gqnt.x | 70 + sys/gio/gks/gqopwk.x | 56 + sys/gio/gks/gqplci.x | 30 + sys/gio/gks/gqpmci.x | 30 + sys/gio/gks/gqpmi.x | 17 + sys/gio/gks/gqtxal.x | 65 + sys/gio/gks/gqtxci.x | 30 + sys/gio/gks/gqtxp.x | 45 + sys/gio/gks/gqwks.x | 21 + sys/gio/gks/gsasf.x | 30 + sys/gio/gks/gsaw.x | 37 + sys/gio/gks/gschh.x | 26 + sys/gio/gks/gschup.x | 23 + sys/gio/gks/gsclip.x | 13 + sys/gio/gks/gscr.x | 17 + sys/gio/gks/gselnt.x | 13 + sys/gio/gks/gsfaci.x | 16 + sys/gio/gks/gsfais.x | 28 + sys/gio/gks/gslwsc.x | 16 + sys/gio/gks/gsmk.x | 29 + sys/gio/gks/gsmksc.x | 16 + sys/gio/gks/gsplci.x | 14 + sys/gio/gks/gspmci.x | 14 + sys/gio/gks/gspmi.x | 14 + sys/gio/gks/gstxal.x | 43 + sys/gio/gks/gstxci.x | 18 + sys/gio/gks/gstxp.x | 25 + sys/gio/gks/gsvp.x | 30 + sys/gio/gks/gswn.x | 29 + sys/gio/gks/gtx.f | 16 + sys/gio/gks/gxgtx.x | 22 + sys/gio/gks/mkpkg | 58 + sys/gio/glabax/README | 1 + sys/gio/glabax/glabax.h | 46 + sys/gio/glabax/glabax.x | 264 ++ sys/gio/glabax/glbencode.x | 66 + sys/gio/glabax/glbfind.x | 339 +++ sys/gio/glabax/glbgrid.x | 54 + sys/gio/glabax/glbgtick.x | 252 ++ sys/gio/glabax/glblabel.x | 84 + sys/gio/glabax/glbloglab.x | 139 + sys/gio/glabax/glbsetax.x | 130 + sys/gio/glabax/glbsetup.x | 51 + sys/gio/glabax/glbsview.x | 117 + sys/gio/glabax/glbticlen.x | 42 + sys/gio/glabax/glbtitle.x | 76 + sys/gio/glabax/glbverify.x | 36 + sys/gio/glabax/mkpkg | 22 + sys/gio/gline.x | 14 + sys/gio/gmark.x | 55 + sys/gio/gmftitle.x | 17 + sys/gio/gmprintf.x | 27 + sys/gio/gmsg.x | 232 ++ sys/gio/gopen.x | 187 ++ sys/gio/gpagefile.x | 29 + sys/gio/gpcell.x | 77 + sys/gio/gpl.com | 20 + sys/gio/gplcache.x | 101 + sys/gio/gplcancel.x | 13 + sys/gio/gplflush.x | 51 + sys/gio/gpline.x | 18 + sys/gio/gploto.x | 23 + sys/gio/gplotv.x | 22 + sys/gio/gplreset.x | 27 + sys/gio/gplstype.x | 25 + sys/gio/gpmark.x | 28 + sys/gio/gqverify.x | 32 + sys/gio/grdraw.x | 24 + sys/gio/grdwcs.x | 106 + sys/gio/greact.x | 32 + sys/gio/greset.x | 238 ++ sys/gio/grmove.x | 23 + sys/gio/grscale.x | 63 + sys/gio/gscan.x | 11 + sys/gio/gscur.x | 18 + sys/gio/gseti.x | 15 + sys/gio/gsetr.x | 276 ++ sys/gio/gsets.x | 32 + sys/gio/gstati.x | 16 + sys/gio/gstatr.x | 215 ++ sys/gio/gstats.x | 35 + sys/gio/gsview.x | 25 + sys/gio/gswind.x | 30 + sys/gio/gtext.x | 77 + sys/gio/gtick.gx | 192 ++ sys/gio/gtickr.x | 192 ++ sys/gio/gtxset.x | 144 + sys/gio/gumark.x | 108 + sys/gio/gvline.x | 23 + sys/gio/gvmark.x | 35 + sys/gio/imdkern/README | 85 + sys/gio/imdkern/font.com | 207 ++ sys/gio/imdkern/font.h | 29 + sys/gio/imdkern/idk.com | 50 + sys/gio/imdkern/idk.x | 509 ++++ sys/gio/imdkern/imd.com | 18 + sys/gio/imdkern/imd.h | 77 + sys/gio/imdkern/imdcancel.x | 16 + sys/gio/imdkern/imdclear.x | 55 + sys/gio/imdkern/imdclose.x | 37 + sys/gio/imdkern/imdclws.x | 22 + sys/gio/imdkern/imdcolor.x | 20 + sys/gio/imdkern/imddrawch.x | 70 + sys/gio/imdkern/imdescape.x | 13 + sys/gio/imdkern/imdfa.x | 16 + sys/gio/imdkern/imdfaset.x | 18 + sys/gio/imdkern/imdflush.x | 14 + sys/gio/imdkern/imdfont.x | 32 + sys/gio/imdkern/imdgcell.x | 14 + sys/gio/imdkern/imdinit.x | 162 ++ sys/gio/imdkern/imdline.x | 31 + sys/gio/imdkern/imdopen.x | 81 + sys/gio/imdkern/imdopenws.x | 98 + sys/gio/imdkern/imdpcell.x | 195 ++ sys/gio/imdkern/imdpl.x | 183 ++ sys/gio/imdkern/imdplset.x | 20 + sys/gio/imdkern/imdpm.x | 56 + sys/gio/imdkern/imdpmset.x | 19 + sys/gio/imdkern/imdreset.x | 50 + sys/gio/imdkern/imdtx.x | 430 +++ sys/gio/imdkern/imdtxset.x | 29 + sys/gio/imdkern/ltype.dat | 28 + sys/gio/imdkern/mkpkg | 50 + sys/gio/imdkern/t_imdkern.x | 89 + sys/gio/imdkern/x_imdkern.x | 3 + sys/gio/markers.inc | 71 + sys/gio/mkpkg | 140 + sys/gio/ncarutil/README | 219 ++ sys/gio/ncarutil/autograph/README | 46 + sys/gio/ncarutil/autograph/agaxis.f | 1851 +++++++++++++ sys/gio/ncarutil/autograph/agback.f | 152 + sys/gio/ncarutil/autograph/agbnch.f | 35 + sys/gio/ncarutil/autograph/agchax.f | 41 + sys/gio/ncarutil/autograph/agchcu.f | 44 + sys/gio/ncarutil/autograph/agchil.f | 36 + sys/gio/ncarutil/autograph/agchnl.f | 65 + sys/gio/ncarutil/autograph/agctcs.f | 79 + sys/gio/ncarutil/autograph/agctko.f | 150 + sys/gio/ncarutil/autograph/agcurv.f | 149 + sys/gio/ncarutil/autograph/agdash.f | 69 + sys/gio/ncarutil/autograph/agdflt.bd | 414 +++ sys/gio/ncarutil/autograph/agdflt.f | 690 +++++ sys/gio/ncarutil/autograph/agdlch.f | 60 + sys/gio/ncarutil/autograph/agdshn.f | 34 + sys/gio/ncarutil/autograph/agexax.f | 415 +++ sys/gio/ncarutil/autograph/agexus.f | 89 + sys/gio/ncarutil/autograph/agezsu.f | 104 + sys/gio/ncarutil/autograph/agfpbn.f | 37 + sys/gio/ncarutil/autograph/agftol.f | 119 + sys/gio/ncarutil/autograph/aggetc.f | 51 + sys/gio/ncarutil/autograph/aggetf.f | 28 + sys/gio/ncarutil/autograph/aggeti.f | 28 + sys/gio/ncarutil/autograph/aggetp.f | 104 + sys/gio/ncarutil/autograph/aggtch.f | 78 + sys/gio/ncarutil/autograph/aginit.f | 113 + sys/gio/ncarutil/autograph/agkurv.f | 145 + sys/gio/ncarutil/autograph/aglbls.f | 616 +++++ sys/gio/ncarutil/autograph/agmaxi.f | 60 + sys/gio/ncarutil/autograph/agmini.f | 60 + sys/gio/ncarutil/autograph/agnumb.f | 491 ++++ sys/gio/ncarutil/autograph/agppid.f | 65 + sys/gio/ncarutil/autograph/agpwrt.f | 31 + sys/gio/ncarutil/autograph/agqurv.f | 322 +++ sys/gio/ncarutil/autograph/agrpch.f | 86 + sys/gio/ncarutil/autograph/agrstr.f | 88 + sys/gio/ncarutil/autograph/agsave.f | 93 + sys/gio/ncarutil/autograph/agscan.f | 628 +++++ sys/gio/ncarutil/autograph/agsetc.f | 100 + sys/gio/ncarutil/autograph/agsetf.f | 28 + sys/gio/ncarutil/autograph/agseti.f | 28 + sys/gio/ncarutil/autograph/agsetp.f | 447 +++ sys/gio/ncarutil/autograph/agsrch.f | 96 + sys/gio/ncarutil/autograph/agstch.f | 124 + sys/gio/ncarutil/autograph/agstup.f | 543 ++++ sys/gio/ncarutil/autograph/agutol.f | 49 + sys/gio/ncarutil/autograph/anotat.f | 63 + sys/gio/ncarutil/autograph/displa.f | 33 + sys/gio/ncarutil/autograph/ezmxy.f | 67 + sys/gio/ncarutil/autograph/ezmy.f | 65 + sys/gio/ncarutil/autograph/ezxy.f | 57 + sys/gio/ncarutil/autograph/ezy.f | 57 + sys/gio/ncarutil/autograph/idiot.f | 64 + sys/gio/ncarutil/autograph/mkpkg | 62 + sys/gio/ncarutil/autograph/pstr.x | 14 + sys/gio/ncarutil/conbd.f | 111 + sys/gio/ncarutil/conbdn.f | 342 +++ sys/gio/ncarutil/conlib/README | 3 + sys/gio/ncarutil/conlib/concal.f | 340 +++ sys/gio/ncarutil/conlib/concld.f | 314 +++ sys/gio/ncarutil/conlib/concls.f | 177 ++ sys/gio/ncarutil/conlib/concom.f | 78 + sys/gio/ncarutil/conlib/condet.f | 128 + sys/gio/ncarutil/conlib/condrw.f | 253 ++ sys/gio/ncarutil/conlib/condsd.f | 54 + sys/gio/ncarutil/conlib/conecd.f | 178 ++ sys/gio/ncarutil/conlib/congen.f | 454 +++ sys/gio/ncarutil/conlib/conint.f | 147 + sys/gio/ncarutil/conlib/conlcm.f | 65 + sys/gio/ncarutil/conlib/conlin.f | 68 + sys/gio/ncarutil/conlib/conloc.f | 256 ++ sys/gio/ncarutil/conlib/conlod.f | 194 ++ sys/gio/ncarutil/conlib/conop1.f | 465 ++++ sys/gio/ncarutil/conlib/conop2.f | 316 +++ sys/gio/ncarutil/conlib/conop3.f | 266 ++ sys/gio/ncarutil/conlib/conop4.f | 197 ++ sys/gio/ncarutil/conlib/conot2.f | 178 ++ sys/gio/ncarutil/conlib/conout.f | 350 +++ sys/gio/ncarutil/conlib/conpdv.f | 118 + sys/gio/ncarutil/conlib/conreo.f | 129 + sys/gio/ncarutil/conlib/consld.f | 165 ++ sys/gio/ncarutil/conlib/conssd.f | 61 + sys/gio/ncarutil/conlib/constp.f | 135 + sys/gio/ncarutil/conlib/contlk.f | 98 + sys/gio/ncarutil/conlib/contng.f | 432 +++ sys/gio/ncarutil/conlib/conxch.f | 67 + sys/gio/ncarutil/conlib/mkpkg | 37 + sys/gio/ncarutil/conran.f | 1976 +++++++++++++ sys/gio/ncarutil/conrec.f | 1313 +++++++++ sys/gio/ncarutil/dashbd.f | 143 + sys/gio/ncarutil/dashsmth.f | 1224 ++++++++ sys/gio/ncarutil/ezmap.f | 4598 +++++++++++++++++++++++++++++++ sys/gio/ncarutil/gridal.f | 1583 +++++++++++ sys/gio/ncarutil/gridt.f | 65 + sys/gio/ncarutil/hafton.f | 830 ++++++ sys/gio/ncarutil/hfinit.f | 229 ++ sys/gio/ncarutil/isosrb.f | 98 + sys/gio/ncarutil/isosrf.f | 1696 ++++++++++++ sys/gio/ncarutil/kurv.f | 451 +++ sys/gio/ncarutil/mkpkg | 51 + sys/gio/ncarutil/pwrity.f | 604 ++++ sys/gio/ncarutil/pwrzi.f | 732 +++++ sys/gio/ncarutil/pwrzs.f | 772 ++++++ sys/gio/ncarutil/pwrzt.f | 731 +++++ sys/gio/ncarutil/srfabd.f | 89 + sys/gio/ncarutil/srface.f | 1347 +++++++++ sys/gio/ncarutil/strmln.f | 957 +++++++ sys/gio/ncarutil/sysint/README | 2 + sys/gio/ncarutil/sysint/fencode.x | 80 + sys/gio/ncarutil/sysint/fulib.x | 29 + sys/gio/ncarutil/sysint/gbytes.x | 30 + sys/gio/ncarutil/sysint/ishift.x | 55 + sys/gio/ncarutil/sysint/mkpkg | 16 + sys/gio/ncarutil/sysint/sbytes.x | 40 + sys/gio/ncarutil/sysint/spps.f | 1797 ++++++++++++ sys/gio/ncarutil/sysint/support.f | 581 ++++ sys/gio/ncarutil/tests/README | 2 + sys/gio/ncarutil/tests/auto10t.f | 262 ++ sys/gio/ncarutil/tests/autograph.x | 33 + sys/gio/ncarutil/tests/autographt.f | 186 ++ sys/gio/ncarutil/tests/conran.x | 37 + sys/gio/ncarutil/tests/conrant.f | 97 + sys/gio/ncarutil/tests/conraq.x | 35 + sys/gio/ncarutil/tests/conraqt.f | 139 + sys/gio/ncarutil/tests/conras.x | 35 + sys/gio/ncarutil/tests/conrast.f | 147 + sys/gio/ncarutil/tests/conrcqckt.f | 114 + sys/gio/ncarutil/tests/conrcsmtht.f | 122 + sys/gio/ncarutil/tests/conrcsprt.f | 110 + sys/gio/ncarutil/tests/conrec.x | 35 + sys/gio/ncarutil/tests/conrect.f | 118 + sys/gio/ncarutil/tests/dashchar.x | 32 + sys/gio/ncarutil/tests/dashchart.f | 145 + sys/gio/ncarutil/tests/dashlinet.f | 138 + sys/gio/ncarutil/tests/dashsmth.x | 32 + sys/gio/ncarutil/tests/dashsmtht.f | 144 + sys/gio/ncarutil/tests/dashsuprt.f | 151 + sys/gio/ncarutil/tests/ezconrec.x | 35 + sys/gio/ncarutil/tests/ezhafton.x | 30 + sys/gio/ncarutil/tests/ezhaftont.f | 123 + sys/gio/ncarutil/tests/ezisosrf.x | 32 + sys/gio/ncarutil/tests/ezmapg.x | 32 + sys/gio/ncarutil/tests/ezmapgt.f | 318 +++ sys/gio/ncarutil/tests/ezmapt.f | 300 ++ sys/gio/ncarutil/tests/ezsurface.x | 32 + sys/gio/ncarutil/tests/ezvelvect.x | 32 + sys/gio/ncarutil/tests/ezytst.x | 39 + sys/gio/ncarutil/tests/hafton.x | 30 + sys/gio/ncarutil/tests/haftont.f | 123 + sys/gio/ncarutil/tests/isosrf.x | 32 + sys/gio/ncarutil/tests/isosrfhrt.f | 165 ++ sys/gio/ncarutil/tests/isosrft.f | 137 + sys/gio/ncarutil/tests/mkpkg | 65 + sys/gio/ncarutil/tests/oldauto.x | 41 + sys/gio/ncarutil/tests/oldautot.f | 833 ++++++ sys/gio/ncarutil/tests/preal.x | 12 + sys/gio/ncarutil/tests/pwrity.x | 32 + sys/gio/ncarutil/tests/pwrityt.f | 90 + sys/gio/ncarutil/tests/pwrzit.f | 132 + sys/gio/ncarutil/tests/pwrzs.x | 32 + sys/gio/ncarutil/tests/pwrzst.f | 127 + sys/gio/ncarutil/tests/pwrztt.f | 116 + sys/gio/ncarutil/tests/srf.com | 4 + sys/gio/ncarutil/tests/srfacet.f | 150 + sys/gio/ncarutil/tests/srftest.x | 68 + sys/gio/ncarutil/tests/srftestd.x | 29 + sys/gio/ncarutil/tests/strmln.x | 32 + sys/gio/ncarutil/tests/strmlnt.f | 101 + sys/gio/ncarutil/tests/surface.x | 32 + sys/gio/ncarutil/tests/threed.x | 32 + sys/gio/ncarutil/tests/threed2.x | 32 + sys/gio/ncarutil/tests/threed2t.f | 26 + sys/gio/ncarutil/tests/threedt.f | 129 + sys/gio/ncarutil/tests/velvctt.f | 126 + sys/gio/ncarutil/tests/velvect.x | 32 + sys/gio/ncarutil/tests/x_ncartest.x | 24 + sys/gio/ncarutil/threbd.f | 56 + sys/gio/ncarutil/threed.f | 826 ++++++ sys/gio/ncarutil/veldat.f | 67 + sys/gio/ncarutil/velvct.f | 821 ++++++ sys/gio/nspp/README | 9 + sys/gio/nspp/mkpkg | 11 + sys/gio/nspp/portlib/README | 28 + sys/gio/nspp/portlib/axes.f | 6 + sys/gio/nspp/portlib/curve.f | 41 + sys/gio/nspp/portlib/dashln.f | 5 + sys/gio/nspp/portlib/fl2int.f | 31 + sys/gio/nspp/portlib/flash1.f | 42 + sys/gio/nspp/portlib/flash2.f | 71 + sys/gio/nspp/portlib/flash3.f | 70 + sys/gio/nspp/portlib/flash4.f | 46 + sys/gio/nspp/portlib/flush.f | 22 + sys/gio/nspp/portlib/flushb.f | 41 + sys/gio/nspp/portlib/frame.f | 70 + sys/gio/nspp/portlib/frstpt.f | 30 + sys/gio/nspp/portlib/getopt.f | 37 + sys/gio/nspp/portlib/getset.f | 28 + sys/gio/nspp/portlib/getsi.f | 21 + sys/gio/nspp/portlib/grid.f | 4 + sys/gio/nspp/portlib/gridal.f | 218 ++ sys/gio/nspp/portlib/gridl.f | 4 + sys/gio/nspp/portlib/halfax.f | 4 + sys/gio/nspp/portlib/jlm2.f | 7 + sys/gio/nspp/portlib/justfy.f | 14 + sys/gio/nspp/portlib/labmod.f | 53 + sys/gio/nspp/portlib/line.f | 32 + sys/gio/nspp/portlib/mkpkg | 56 + sys/gio/nspp/portlib/mxmy.f | 21 + sys/gio/nspp/portlib/option.f | 8 + sys/gio/nspp/portlib/optn.f | 99 + sys/gio/nspp/portlib/perim.f | 4 + sys/gio/nspp/portlib/periml.f | 4 + sys/gio/nspp/portlib/plotit.f | 23 + sys/gio/nspp/portlib/point.f | 43 + sys/gio/nspp/portlib/points.f | 57 + sys/gio/nspp/portlib/porgn.f | 27 + sys/gio/nspp/portlib/preout.f | 116 + sys/gio/nspp/portlib/pscale.f | 21 + sys/gio/nspp/portlib/psym.f | 27 + sys/gio/nspp/portlib/put42.f | 60 + sys/gio/nspp/portlib/putins.f | 59 + sys/gio/nspp/portlib/pwrit.f | 95 + sys/gio/nspp/portlib/pwrt.f | 12 + sys/gio/nspp/portlib/set.f | 140 + sys/gio/nspp/portlib/seti.f | 37 + sys/gio/nspp/portlib/tick4.f | 30 + sys/gio/nspp/portlib/ticks.f | 4 + sys/gio/nspp/portlib/trans.f | 52 + sys/gio/nspp/portlib/vector.f | 27 + sys/gio/nspp/portlib/z8zpbd.f | 6 + sys/gio/nspp/portlib/z8zpii.f | 362 +++ sys/gio/nspp/sysint/README | 1 + sys/gio/nspp/sysint/encd.f | 78 + sys/gio/nspp/sysint/encode.f | 15 + sys/gio/nspp/sysint/erprt77.f | 441 +++ sys/gio/nspp/sysint/fencode.x | 79 + sys/gio/nspp/sysint/fulib.x | 29 + sys/gio/nspp/sysint/intt.x | 16 + sys/gio/nspp/sysint/ishift.x | 55 + sys/gio/nspp/sysint/loc.x | 23 + sys/gio/nspp/sysint/mcswap.x | 17 + sys/gio/nspp/sysint/mkpkg | 24 + sys/gio/nspp/sysint/ncgchr.x | 22 + sys/gio/nspp/sysint/ncpchr.x | 20 + sys/gio/nspp/sysint/nspp.com | 40 + sys/gio/nspp/sysint/packum.x | 43 + sys/gio/nspp/sysint/perror.x | 9 + sys/gio/nspp/sysint/q8qst4.f | 24 + sys/gio/nspp/sysint/uliber.f | 14 + sys/gio/nsppkern/README | 399 +++ sys/gio/nsppkern/font.com | 207 ++ sys/gio/nsppkern/font.h | 29 + sys/gio/nsppkern/gkt.com | 17 + sys/gio/nsppkern/gkt.h | 75 + sys/gio/nsppkern/gktcancel.x | 27 + sys/gio/nsppkern/gktclear.x | 60 + sys/gio/nsppkern/gktclose.x | 35 + sys/gio/nsppkern/gktclws.x | 17 + sys/gio/nsppkern/gktcolor.x | 33 + sys/gio/nsppkern/gktdrawch.x | 68 + sys/gio/nsppkern/gktescape.x | 13 + sys/gio/nsppkern/gktfa.x | 16 + sys/gio/nsppkern/gktfaset.x | 18 + sys/gio/nsppkern/gktflush.x | 15 + sys/gio/nsppkern/gktfont.x | 38 + sys/gio/nsppkern/gktgcell.x | 14 + sys/gio/nsppkern/gktinit.x | 194 ++ sys/gio/nsppkern/gktline.x | 30 + sys/gio/nsppkern/gktmfopen.x | 45 + sys/gio/nsppkern/gktopen.x | 77 + sys/gio/nsppkern/gktopenws.x | 104 + sys/gio/nsppkern/gktpcell.x | 383 +++ sys/gio/nsppkern/gktpl.x | 64 + sys/gio/nsppkern/gktplset.x | 20 + sys/gio/nsppkern/gktpm.x | 64 + sys/gio/nsppkern/gktpmset.x | 19 + sys/gio/nsppkern/gktreset.x | 59 + sys/gio/nsppkern/gkttx.x | 428 +++ sys/gio/nsppkern/gkttxset.x | 29 + sys/gio/nsppkern/mkpkg | 56 + sys/gio/nsppkern/nspp.com | 40 + sys/gio/nsppkern/pixel0.f | 58 + sys/gio/nsppkern/pixels.f | 74 + sys/gio/nsppkern/t_nsppkern.x | 67 + sys/gio/nsppkern/tran16.f | 64 + sys/gio/nsppkern/writeb.x | 40 + sys/gio/nsppkern/x_nsppkern.x | 3 + sys/gio/nsppkern/zzdebug.x | 472 ++++ sys/gio/sgikern/README | 12 + sys/gio/sgikern/font.com | 746 +++++ sys/gio/sgikern/font.h | 29 + sys/gio/sgikern/greek.com | 501 ++++ sys/gio/sgikern/ltype.dat | 28 + sys/gio/sgikern/mkpkg | 53 + sys/gio/sgikern/sgi.com | 17 + sys/gio/sgikern/sgi.h | 76 + sys/gio/sgikern/sgicancel.x | 16 + sys/gio/sgikern/sgiclear.x | 54 + sys/gio/sgikern/sgiclose.x | 30 + sys/gio/sgikern/sgiclws.x | 17 + sys/gio/sgikern/sgicolor.x | 20 + sys/gio/sgikern/sgidrawch.x | 84 + sys/gio/sgikern/sgiescape.x | 13 + sys/gio/sgikern/sgifa.x | 20 + sys/gio/sgikern/sgifaset.x | 18 + sys/gio/sgikern/sgiflush.x | 14 + sys/gio/sgikern/sgifont.x | 42 + sys/gio/sgikern/sgigcell.x | 14 + sys/gio/sgikern/sgiinit.x | 162 ++ sys/gio/sgikern/sgiline.x | 31 + sys/gio/sgikern/sgiopen.x | 77 + sys/gio/sgikern/sgiopenws.x | 98 + sys/gio/sgikern/sgipcell.x | 195 ++ sys/gio/sgikern/sgipl.x | 183 ++ sys/gio/sgikern/sgiplset.x | 20 + sys/gio/sgikern/sgipm.x | 56 + sys/gio/sgikern/sgipmset.x | 19 + sys/gio/sgikern/sgireset.x | 50 + sys/gio/sgikern/sgitx.x | 459 +++ sys/gio/sgikern/sgitxset.x | 29 + sys/gio/sgikern/sgk.com | 49 + sys/gio/sgikern/sgk.h | 7 + sys/gio/sgikern/sgk.x | 853 ++++++ sys/gio/sgikern/t_sgideco.x | 106 + sys/gio/sgikern/t_sgikern.x | 67 + sys/gio/sgikern/x_sgikern.x | 5 + sys/gio/stdgraph/README | 77 + sys/gio/stdgraph/font.com | 207 ++ sys/gio/stdgraph/font.h | 29 + sys/gio/stdgraph/mkpkg | 80 + sys/gio/stdgraph/stdgraph.com | 46 + sys/gio/stdgraph/stdgraph.h | 98 + sys/gio/stdgraph/stgcancel.x | 16 + sys/gio/stdgraph/stgclear.x | 16 + sys/gio/stdgraph/stgclose.x | 47 + sys/gio/stdgraph/stgclws.x | 28 + sys/gio/stdgraph/stgctrl.x | 82 + sys/gio/stdgraph/stgdeact.x | 54 + sys/gio/stdgraph/stgdraw.x | 27 + sys/gio/stdgraph/stgdrawch.x | 144 + sys/gio/stdgraph/stgencode.x | 539 ++++ sys/gio/stdgraph/stgescape.x | 99 + sys/gio/stdgraph/stgfa.x | 115 + sys/gio/stdgraph/stgfaset.x | 18 + sys/gio/stdgraph/stgfilter.x | 165 ++ sys/gio/stdgraph/stgflush.x | 14 + sys/gio/stdgraph/stggcell.x | 15 + sys/gio/stdgraph/stggcur.x | 52 + sys/gio/stdgraph/stggdisab.x | 17 + sys/gio/stdgraph/stggenab.x | 17 + sys/gio/stdgraph/stggim.x | 919 +++++++ sys/gio/stdgraph/stggrstr.x | 16 + sys/gio/stdgraph/stginit.x | 193 ++ sys/gio/stdgraph/stglkcur.x | 18 + sys/gio/stdgraph/stgmove.x | 27 + sys/gio/stdgraph/stgonerr.x | 17 + sys/gio/stdgraph/stgonint.x | 21 + sys/gio/stdgraph/stgopen.x | 103 + sys/gio/stdgraph/stgopenws.x | 220 ++ sys/gio/stdgraph/stgoutput.x | 28 + sys/gio/stdgraph/stgoutstr.x | 30 + sys/gio/stdgraph/stgpcell.x | 85 + sys/gio/stdgraph/stgpl.x | 126 + sys/gio/stdgraph/stgplset.x | 20 + sys/gio/stdgraph/stgpm.x | 118 + sys/gio/stdgraph/stgpmset.x | 19 + sys/gio/stdgraph/stgrcur.x | 425 +++ sys/gio/stdgraph/stgreact.x | 41 + sys/gio/stdgraph/stgres.x | 85 + sys/gio/stdgraph/stgreset.x | 54 + sys/gio/stdgraph/stgrtty.x | 137 + sys/gio/stdgraph/stgscur.x | 36 + sys/gio/stdgraph/stgtx.x | 528 ++++ sys/gio/stdgraph/stgtxqual.x | 17 + sys/gio/stdgraph/stgtxset.x | 34 + sys/gio/stdgraph/stgtxsize.x | 31 + sys/gio/stdgraph/stgunkown.x | 14 + sys/gio/stdgraph/stgwtty.x | 118 + sys/gio/stdgraph/t_gkideco.x | 63 + sys/gio/stdgraph/t_showcap.x | 210 ++ sys/gio/stdgraph/t_stdgraph.x | 110 + sys/gio/stdgraph/x_stdgraph.x | 5 + sys/gio/stdgraph/zzdebug.x | 37 + sys/gio/wcstogki.x | 61 + sys/gio/zzdebug.x | 392 +++ sys/gty/README | 8 + sys/gty/gty.h | 26 + sys/gty/gtycaps.x | 13 + sys/gty/gtyclose.x | 11 + sys/gty/gtygetb.x | 15 + sys/gty/gtygeti.x | 27 + sys/gty/gtygetr.x | 41 + sys/gty/gtygets.x | 70 + sys/gty/gtyindex.x | 167 ++ sys/gty/gtyopen.x | 305 ++ sys/gty/mkpkg | 29 + sys/gty/zzdebug.x | 26 + sys/imfort/README | 98 + sys/imfort/bfio.x | 496 ++++ sys/imfort/clargs.x | 232 ++ sys/imfort/db/README | 120 + sys/imfort/db/idb.h | 22 + sys/imfort/db/idbfind.x | 124 + sys/imfort/db/idbgstr.x | 78 + sys/imfort/db/idbkwlu.x | 52 + sys/imfort/db/idbnaxis.x | 32 + sys/imfort/db/idbpstr.x | 96 + sys/imfort/db/imaccf.x | 18 + sys/imfort/db/imaddb.x | 20 + sys/imfort/db/imaddd.x | 20 + sys/imfort/db/imaddf.x | 76 + sys/imfort/db/imaddi.x | 20 + sys/imfort/db/imaddl.x | 20 + sys/imfort/db/imaddr.x | 20 + sys/imfort/db/imadds.x | 20 + sys/imfort/db/imastr.x | 18 + sys/imfort/db/imdelf.x | 44 + sys/imfort/db/imgatr.x | 51 + sys/imfort/db/imgetb.x | 20 + sys/imfort/db/imgetc.x | 13 + sys/imfort/db/imgetd.x | 32 + sys/imfort/db/imgeti.x | 19 + sys/imfort/db/imgetl.x | 19 + sys/imfort/db/imgetr.x | 19 + sys/imfort/db/imgets.x | 19 + sys/imfort/db/imgftype.x | 76 + sys/imfort/db/imgnfn.x | 338 +++ sys/imfort/db/imgstr.x | 41 + sys/imfort/db/impstr.x | 72 + sys/imfort/db/imputb.x | 20 + sys/imfort/db/imputd.x | 37 + sys/imfort/db/imputi.x | 18 + sys/imfort/db/imputl.x | 23 + sys/imfort/db/imputr.x | 18 + sys/imfort/db/imputs.x | 18 + sys/imfort/db/mkpkg | 42 + sys/imfort/doc/TODO | 3 + sys/imfort/doc/bfaloc.hlp | 32 + sys/imfort/doc/bfbsiz.hlp | 22 + sys/imfort/doc/bfchan.hlp | 27 + sys/imfort/doc/bfclos.hlp | 27 + sys/imfort/doc/bfflsh.hlp | 26 + sys/imfort/doc/bffsiz.hlp | 24 + sys/imfort/doc/bfopen.hlp | 32 + sys/imfort/doc/bfread.hlp | 31 + sys/imfort/doc/bfwrit.hlp | 38 + sys/imfort/doc/clarg.hlp | 42 + sys/imfort/doc/clnarg.hlp | 24 + sys/imfort/doc/clrawc.hlp | 35 + sys/imfort/doc/imacck.hlp | 27 + sys/imfort/doc/imaddk.hlp | 55 + sys/imfort/doc/imakw.hlp | 50 + sys/imfort/doc/imclos.hlp | 39 + sys/imfort/doc/imcrea.hlp | 55 + sys/imfort/doc/imdele.hlp | 29 + sys/imfort/doc/imdelk.hlp | 36 + sys/imfort/doc/imemsg.hlp | 31 + sys/imfort/doc/imflsh.hlp | 39 + sys/imfort/doc/imfort.hd | 44 + sys/imfort/doc/imfort.ms | 1711 ++++++++++++ sys/imfort/doc/imfort.toc | 54 + sys/imfort/doc/imgkw.hlp | 41 + sys/imfort/doc/imgl.hlp | 48 + sys/imfort/doc/imgs.hlp | 54 + sys/imfort/doc/imgsiz.hlp | 51 + sys/imfort/doc/imhcpy.hlp | 30 + sys/imfort/doc/imokwl.hlp | 65 + sys/imfort/doc/imopen.hlp | 35 + sys/imfort/doc/imopnc.hlp | 49 + sys/imfort/doc/impixf.hlp | 53 + sys/imfort/doc/impkw.hlp | 51 + sys/imfort/doc/impl.hlp | 49 + sys/imfort/doc/imps.hlp | 54 + sys/imfort/doc/imrnam.hlp | 35 + sys/imfort/doc/imtypk.hlp | 33 + sys/imfort/imacck.x | 30 + sys/imfort/imaddk.x | 35 + sys/imfort/imakwb.x | 35 + sys/imfort/imakwc.x | 37 + sys/imfort/imakwd.x | 35 + sys/imfort/imakwi.x | 35 + sys/imfort/imakwr.x | 35 + sys/imfort/imclos.x | 36 + sys/imfort/imcrea.x | 20 + sys/imfort/imcrex.x | 170 ++ sys/imfort/imdele.x | 21 + sys/imfort/imdelk.x | 30 + sys/imfort/imdelx.x | 76 + sys/imfort/imemsg.x | 168 ++ sys/imfort/imfdir.x | 110 + sys/imfort/imfgpfn.x | 59 + sys/imfort/imflsh.x | 33 + sys/imfort/imfmkpfn.x | 137 + sys/imfort/imfort.h | 65 + sys/imfort/imfparse.x | 71 + sys/imfort/imftrans.x | 30 + sys/imfort/imfupdhdr.x | 21 + sys/imfort/imgkwb.x | 30 + sys/imfort/imgkwc.x | 33 + sys/imfort/imgkwd.x | 30 + sys/imfort/imgkwi.x | 29 + sys/imfort/imgkwr.x | 30 + sys/imfort/imgl1r.x | 42 + sys/imfort/imgl1s.x | 44 + sys/imfort/imgl2r.x | 50 + sys/imfort/imgl2s.x | 52 + sys/imfort/imgl3r.x | 56 + sys/imfort/imgl3s.x | 58 + sys/imfort/imgs1r.x | 54 + sys/imfort/imgs1s.x | 50 + sys/imfort/imgs2r.x | 65 + sys/imfort/imgs2s.x | 61 + sys/imfort/imgs3r.x | 72 + sys/imfort/imgs3s.x | 68 + sys/imfort/imgsiz.x | 27 + sys/imfort/imhcpy.x | 49 + sys/imfort/imhv1.h | 75 + sys/imfort/imhv2.h | 43 + sys/imfort/imioff.x | 89 + sys/imfort/imokwl.x | 99 + sys/imfort/imopen.x | 18 + sys/imfort/imopnc.x | 49 + sys/imfort/imopnx.x | 126 + sys/imfort/impixf.x | 51 + sys/imfort/impkwb.x | 31 + sys/imfort/impkwc.x | 33 + sys/imfort/impkwd.x | 31 + sys/imfort/impkwi.x | 31 + sys/imfort/impkwr.x | 31 + sys/imfort/impl1r.x | 59 + sys/imfort/impl1s.x | 42 + sys/imfort/impl2r.x | 69 + sys/imfort/impl2s.x | 50 + sys/imfort/impl3r.x | 75 + sys/imfort/impl3s.x | 56 + sys/imfort/imps1r.x | 73 + sys/imfort/imps1s.x | 47 + sys/imfort/imps2r.x | 84 + sys/imfort/imps2s.x | 58 + sys/imfort/imps3r.x | 91 + sys/imfort/imps3s.x | 65 + sys/imfort/imrdhdr.x | 200 ++ sys/imfort/imrnam.x | 144 + sys/imfort/imswap.x | 30 + sys/imfort/imtypk.x | 33 + sys/imfort/imwpix.x | 53 + sys/imfort/imwrhdr.x | 256 ++ sys/imfort/mii.x | 314 +++ sys/imfort/mkpkg | 85 + sys/imfort/oif.h | 16 + sys/imfort/tasks/README | 20 + sys/imfort/tasks/args.f | 33 + sys/imfort/tasks/hello.f | 6 + sys/imfort/tasks/imcopy.f | 81 + sys/imfort/tasks/imdel.f | 29 + sys/imfort/tasks/imren.f | 36 + sys/imfort/tasks/keyw.f | 116 + sys/imfort/tasks/minmax.f | 56 + sys/imfort/tasks/mkim.f | 75 + sys/imfort/tasks/pcube.f | 108 + sys/imfort/tasks/phead.f | 155 ++ sys/imfort/tasks/planck.f | 59 + sys/imfort/tasks/readim.f | 53 + sys/imfort/tasks/tasks.unix | 18 + sys/imfort/tasks/tasks.vms | 17 + sys/imio/README | 210 ++ sys/imio/db/README | 105 + sys/imio/db/idb.h | 24 + sys/imio/db/idbcard.x | 134 + sys/imio/db/idbfind.x | 145 + sys/imio/db/idbfstr.x | 40 + sys/imio/db/idbgstr.x | 85 + sys/imio/db/idbkwlu.x | 51 + sys/imio/db/idbpstr.x | 101 + sys/imio/db/imaccf.x | 18 + sys/imio/db/imaddb.x | 19 + sys/imio/db/imaddd.x | 19 + sys/imio/db/imaddf.x | 96 + sys/imio/db/imaddi.x | 19 + sys/imio/db/imaddl.x | 19 + sys/imio/db/imaddr.x | 19 + sys/imio/db/imadds.x | 19 + sys/imio/db/imastr.x | 19 + sys/imio/db/imdelf.x | 44 + sys/imio/db/imgetb.x | 22 + sys/imio/db/imgetc.x | 13 + sys/imio/db/imgetd.x | 32 + sys/imio/db/imgeti.x | 19 + sys/imio/db/imgetl.x | 19 + sys/imio/db/imgetr.x | 19 + sys/imio/db/imgets.x | 19 + sys/imio/db/imgftype.x | 71 + sys/imio/db/imgnfn.x | 339 +++ sys/imio/db/imgstr.x | 52 + sys/imio/db/impstr.x | 120 + sys/imio/db/imputb.x | 20 + sys/imio/db/imputd.x | 38 + sys/imio/db/imputh.x | 161 ++ sys/imio/db/imputi.x | 21 + sys/imio/db/imputl.x | 21 + sys/imio/db/imputr.x | 24 + sys/imio/db/imputs.x | 21 + sys/imio/db/imrenf.x | 44 + sys/imio/db/mkpkg | 44 + sys/imio/dbc/README | 29 + sys/imio/dbc/idbc.h | 27 + sys/imio/dbc/imakbc.x | 20 + sys/imio/dbc/imakbci.x | 23 + sys/imio/dbc/imakdc.x | 20 + sys/imio/dbc/imakdci.x | 23 + sys/imio/dbc/imakic.x | 20 + sys/imio/dbc/imakici.x | 23 + sys/imio/dbc/imaklc.x | 20 + sys/imio/dbc/imaklci.x | 23 + sys/imio/dbc/imakrc.x | 20 + sys/imio/dbc/imakrci.x | 23 + sys/imio/dbc/imaksc.x | 20 + sys/imio/dbc/imaksci.x | 23 + sys/imio/dbc/imastrc.x | 20 + sys/imio/dbc/imastrci.x | 23 + sys/imio/dbc/imdrmcom.x | 96 + sys/imio/dbc/imgcom.x | 66 + sys/imio/dbc/iminfi.x | 111 + sys/imio/dbc/impcom.x | 97 + sys/imio/dbc/impkbc.x | 21 + sys/imio/dbc/impkdc.x | 39 + sys/imio/dbc/impkic.x | 22 + sys/imio/dbc/impklc.x | 22 + sys/imio/dbc/impkrc.x | 25 + sys/imio/dbc/impksc.x | 22 + sys/imio/dbc/impstrc.x | 117 + sys/imio/dbc/imputextf.x | 185 ++ sys/imio/dbc/imputhi.x | 113 + sys/imio/dbc/mkpkg | 36 + sys/imio/doc/IMH.hlp | 219 ++ sys/imio/doc/Notes | 177 ++ sys/imio/doc/bench.ms | 73 + sys/imio/doc/imfort.doc | 72 + sys/imio/doc/imio.2.ms | 331 +++ sys/imio/doc/imio.doc | 232 ++ sys/imio/doc/imio.hlp | 1185 ++++++++ sys/imio/doc/imio.ms | 295 ++ sys/imio/iki/README | 383 +++ sys/imio/iki/fxf/Notes | 81 + sys/imio/iki/fxf/README | 5 + sys/imio/iki/fxf/fxf.h | 172 ++ sys/imio/iki/fxf/fxfaccess.x | 59 + sys/imio/iki/fxf/fxfaddpar.x | 51 + sys/imio/iki/fxf/fxfcache.com | 24 + sys/imio/iki/fxf/fxfclose.x | 42 + sys/imio/iki/fxf/fxfcopy.x | 34 + sys/imio/iki/fxf/fxfctype.x | 72 + sys/imio/iki/fxf/fxfdelete.x | 74 + sys/imio/iki/fxf/fxfencode.x | 348 +++ sys/imio/iki/fxf/fxfexpandh.x | 375 +++ sys/imio/iki/fxf/fxfget.x | 182 ++ sys/imio/iki/fxf/fxfhextn.x | 39 + sys/imio/iki/fxf/fxfksection.x | 475 ++++ sys/imio/iki/fxf/fxfmkcard.x | 35 + sys/imio/iki/fxf/fxfnull.x | 14 + sys/imio/iki/fxf/fxfopen.x | 1014 +++++++ sys/imio/iki/fxf/fxfopix.x | 746 +++++ sys/imio/iki/fxf/fxfpak.x | 58 + sys/imio/iki/fxf/fxfplread.x | 160 ++ sys/imio/iki/fxf/fxfplwrite.x | 418 +++ sys/imio/iki/fxf/fxfrcard.x | 35 + sys/imio/iki/fxf/fxfrdhdr.x | 176 ++ sys/imio/iki/fxf/fxfrename.x | 53 + sys/imio/iki/fxf/fxfrfits.x | 1322 +++++++++ sys/imio/iki/fxf/fxfupdhdr.x | 1478 ++++++++++ sys/imio/iki/fxf/fxfupk.x | 155 ++ sys/imio/iki/fxf/mkpkg | 42 + sys/imio/iki/fxf/zfiofxf.x | 546 ++++ sys/imio/iki/iki.com | 10 + sys/imio/iki/iki.h | 35 + sys/imio/iki/ikiaccess.x | 128 + sys/imio/iki/ikiclose.x | 24 + sys/imio/iki/ikicopy.x | 62 + sys/imio/iki/ikidelete.x | 41 + sys/imio/iki/ikiextn.x | 372 +++ sys/imio/iki/ikiinit.x | 58 + sys/imio/iki/ikildd.x | 38 + sys/imio/iki/ikimkfn.x | 26 + sys/imio/iki/ikiopen.x | 153 + sys/imio/iki/ikiopix.x | 23 + sys/imio/iki/ikiparse.x | 85 + sys/imio/iki/ikirename.x | 74 + sys/imio/iki/ikiupdhdr.x | 22 + sys/imio/iki/mkpkg | 28 + sys/imio/iki/oif/README | 1 + sys/imio/iki/oif/imhv1.h | 75 + sys/imio/iki/oif/imhv2.h | 43 + sys/imio/iki/oif/mkpkg | 21 + sys/imio/iki/oif/oif.h | 15 + sys/imio/iki/oif/oifaccess.x | 51 + sys/imio/iki/oif/oifclose.x | 36 + sys/imio/iki/oif/oifcopy.x | 32 + sys/imio/iki/oif/oifdelete.x | 53 + sys/imio/iki/oif/oifgpfn.x | 60 + sys/imio/iki/oif/oifmkpfn.x | 118 + sys/imio/iki/oif/oifopen.x | 137 + sys/imio/iki/oif/oifopix.x | 103 + sys/imio/iki/oif/oifrdhdr.x | 196 ++ sys/imio/iki/oif/oifrename.x | 102 + sys/imio/iki/oif/oifupdhdr.x | 34 + sys/imio/iki/oif/oifwrhdr.x | 233 ++ sys/imio/iki/plf/README | 5 + sys/imio/iki/plf/mkpkg | 17 + sys/imio/iki/plf/plf.h | 4 + sys/imio/iki/plf/plfaccess.x | 44 + sys/imio/iki/plf/plfclose.x | 21 + sys/imio/iki/plf/plfcopy.x | 38 + sys/imio/iki/plf/plfdelete.x | 29 + sys/imio/iki/plf/plfnull.x | 9 + sys/imio/iki/plf/plfopen.x | 90 + sys/imio/iki/plf/plfrename.x | 37 + sys/imio/iki/plf/plfupdhdr.x | 33 + sys/imio/iki/qpf/README | 2 + sys/imio/iki/qpf/mkpkg | 22 + sys/imio/iki/qpf/qpf.h | 20 + sys/imio/iki/qpf/qpfaccess.x | 44 + sys/imio/iki/qpf/qpfclose.x | 29 + sys/imio/iki/qpf/qpfcopy.x | 39 + sys/imio/iki/qpf/qpfcopypar.x | 117 + sys/imio/iki/qpf/qpfdelete.x | 29 + sys/imio/iki/qpf/qpfopen.x | 165 ++ sys/imio/iki/qpf/qpfopix.x | 55 + sys/imio/iki/qpf/qpfrename.x | 37 + sys/imio/iki/qpf/qpfupdhdr.x | 13 + sys/imio/iki/qpf/qpfwattr.x | 191 ++ sys/imio/iki/qpf/qpfwfilter.x | 53 + sys/imio/iki/qpf/zfioqp.x | 189 ++ sys/imio/iki/stf/README | 300 ++ sys/imio/iki/stf/mkpkg | 36 + sys/imio/iki/stf/stf.h | 77 + sys/imio/iki/stf/stfaccess.x | 58 + sys/imio/iki/stf/stfaddpar.x | 94 + sys/imio/iki/stf/stfclose.x | 32 + sys/imio/iki/stf/stfcopy.x | 43 + sys/imio/iki/stf/stfcopyf.x | 92 + sys/imio/iki/stf/stfctype.x | 85 + sys/imio/iki/stf/stfdelete.x | 40 + sys/imio/iki/stf/stfget.x | 97 + sys/imio/iki/stf/stfhextn.x | 39 + sys/imio/iki/stf/stfiwcs.x | 60 + sys/imio/iki/stf/stfmerge.x | 105 + sys/imio/iki/stf/stfmkpfn.x | 28 + sys/imio/iki/stf/stfnewim.x | 146 + sys/imio/iki/stf/stfopen.x | 225 ++ sys/imio/iki/stf/stfopix.x | 202 ++ sys/imio/iki/stf/stfordgpb.x | 64 + sys/imio/iki/stf/stfrdhdr.x | 186 ++ sys/imio/iki/stf/stfreblk.x | 65 + sys/imio/iki/stf/stfrename.x | 49 + sys/imio/iki/stf/stfrfits.x | 266 ++ sys/imio/iki/stf/stfrgpb.x | 179 ++ sys/imio/iki/stf/stfupdhdr.x | 60 + sys/imio/iki/stf/stfwfits.x | 147 + sys/imio/iki/stf/stfwgpb.x | 174 ++ sys/imio/imaccess.x | 66 + sys/imio/imaflp.x | 70 + sys/imio/imaplv.x | 30 + sys/imio/imbln1.x | 21 + sys/imio/imbln2.x | 26 + sys/imio/imbln3.x | 27 + sys/imio/imbtran.x | 65 + sys/imio/imcopy.x | 14 + sys/imio/imcssz.x | 69 + sys/imio/imdelete.x | 57 + sys/imio/imdmap.x | 110 + sys/imio/imerr.x | 13 + sys/imio/imfls.gx | 34 + sys/imio/imflsh.x | 60 + sys/imio/imflush.x | 19 + sys/imio/imgclust.x | 24 + sys/imio/imggs.gx | 21 + sys/imio/imggsc.x | 105 + sys/imio/imgibf.x | 65 + sys/imio/imgimage.x | 40 + sys/imio/imgl1.gx | 35 + sys/imio/imgl2.gx | 47 + sys/imio/imgl3.gx | 51 + sys/imio/imgnl.gx | 29 + sys/imio/imgnln.x | 105 + sys/imio/imgobf.x | 62 + sys/imio/imgs1.gx | 18 + sys/imio/imgs2.gx | 26 + sys/imio/imgs3.gx | 29 + sys/imio/imgsect.x | 23 + sys/imio/iminie.x | 23 + sys/imio/imioff.x | 114 + sys/imio/imisec.x | 227 ++ sys/imio/imloop.x | 30 + sys/imio/immaky.x | 90 + sys/imio/immap.x | 18 + sys/imio/immapz.x | 189 ++ sys/imio/imnote.x | 30 + sys/imio/imopsf.x | 140 + sys/imio/impak.gx | 46 + sys/imio/imparse.x | 155 ++ sys/imio/impgs.gx | 33 + sys/imio/impl1.gx | 34 + sys/imio/impl2.gx | 47 + sys/imio/impl3.gx | 51 + sys/imio/impmhdr.x | 331 +++ sys/imio/impmlne1.x | 18 + sys/imio/impmlne2.x | 21 + sys/imio/impmlne3.x | 23 + sys/imio/impmlnev.x | 17 + sys/imio/impmmap.x | 92 + sys/imio/impmmapo.x | 62 + sys/imio/impmopen.x | 99 + sys/imio/impmsne1.x | 16 + sys/imio/impmsne2.x | 21 + sys/imio/impmsne3.x | 22 + sys/imio/impmsnev.x | 19 + sys/imio/impnl.gx | 31 + sys/imio/impnln.x | 109 + sys/imio/imps1.gx | 20 + sys/imio/imps2.gx | 26 + sys/imio/imps3.gx | 29 + sys/imio/imrbpx.x | 129 + sys/imio/imrdpx.x | 112 + sys/imio/imrename.x | 13 + sys/imio/imrmbufs.x | 31 + sys/imio/imsamp.x | 61 + sys/imio/imsetbuf.x | 117 + sys/imio/imseti.x | 90 + sys/imio/imsetr.x | 25 + sys/imio/imsinb.x | 53 + sys/imio/imsslv.x | 41 + sys/imio/imstati.x | 51 + sys/imio/imstatr.x | 29 + sys/imio/imstats.x | 24 + sys/imio/imt.x | 305 ++ sys/imio/imt/README | 280 ++ sys/imio/imt/fxf.h | 172 ++ sys/imio/imt/imt.x | 342 +++ sys/imio/imt/imx.h | 28 + sys/imio/imt/imx.x | 242 ++ sys/imio/imt/imxbreakout.x | 233 ++ sys/imio/imt/imxescape.x | 74 + sys/imio/imt/imxexpand.x | 1287 +++++++++ sys/imio/imt/imxexpr.x | 222 ++ sys/imio/imt/imxftype.x | 119 + sys/imio/imt/imxparse.x | 203 ++ sys/imio/imt/imxpreproc.x | 539 ++++ sys/imio/imt/mkpkg | 24 + sys/imio/imt/t_urlget.x | 94 + sys/imio/imt/zzdebug.x | 227 ++ sys/imio/imunmap.x | 61 + sys/imio/imupk.gx | 34 + sys/imio/imwbpx.x | 97 + sys/imio/imwrite.x | 57 + sys/imio/imwrpx.x | 139 + sys/imio/mkpkg | 106 + sys/imio/tf/imflsd.x | 34 + sys/imio/tf/imflsi.x | 34 + sys/imio/tf/imflsl.x | 34 + sys/imio/tf/imflsr.x | 34 + sys/imio/tf/imflss.x | 34 + sys/imio/tf/imflsx.x | 34 + sys/imio/tf/imggsd.x | 21 + sys/imio/tf/imggsi.x | 21 + sys/imio/tf/imggsl.x | 21 + sys/imio/tf/imggsr.x | 21 + sys/imio/tf/imggss.x | 21 + sys/imio/tf/imggsx.x | 21 + sys/imio/tf/imgl1d.x | 35 + sys/imio/tf/imgl1i.x | 35 + sys/imio/tf/imgl1l.x | 35 + sys/imio/tf/imgl1r.x | 35 + sys/imio/tf/imgl1s.x | 35 + sys/imio/tf/imgl1x.x | 35 + sys/imio/tf/imgl2d.x | 47 + sys/imio/tf/imgl2i.x | 47 + sys/imio/tf/imgl2l.x | 47 + sys/imio/tf/imgl2r.x | 47 + sys/imio/tf/imgl2s.x | 47 + sys/imio/tf/imgl2x.x | 47 + sys/imio/tf/imgl3d.x | 51 + sys/imio/tf/imgl3i.x | 51 + sys/imio/tf/imgl3l.x | 51 + sys/imio/tf/imgl3r.x | 51 + sys/imio/tf/imgl3s.x | 51 + sys/imio/tf/imgl3x.x | 51 + sys/imio/tf/imgnld.x | 29 + sys/imio/tf/imgnli.x | 29 + sys/imio/tf/imgnll.x | 29 + sys/imio/tf/imgnlr.x | 29 + sys/imio/tf/imgnls.x | 29 + sys/imio/tf/imgnlx.x | 29 + sys/imio/tf/imgs1d.x | 18 + sys/imio/tf/imgs1i.x | 18 + sys/imio/tf/imgs1l.x | 18 + sys/imio/tf/imgs1r.x | 18 + sys/imio/tf/imgs1s.x | 18 + sys/imio/tf/imgs1x.x | 18 + sys/imio/tf/imgs2d.x | 26 + sys/imio/tf/imgs2i.x | 26 + sys/imio/tf/imgs2l.x | 26 + sys/imio/tf/imgs2r.x | 26 + sys/imio/tf/imgs2s.x | 26 + sys/imio/tf/imgs2x.x | 26 + sys/imio/tf/imgs3d.x | 29 + sys/imio/tf/imgs3i.x | 29 + sys/imio/tf/imgs3l.x | 29 + sys/imio/tf/imgs3r.x | 29 + sys/imio/tf/imgs3s.x | 29 + sys/imio/tf/imgs3x.x | 29 + sys/imio/tf/impakd.x | 46 + sys/imio/tf/impaki.x | 46 + sys/imio/tf/impakl.x | 46 + sys/imio/tf/impakr.x | 46 + sys/imio/tf/impaks.x | 46 + sys/imio/tf/impakx.x | 46 + sys/imio/tf/impgsd.x | 33 + sys/imio/tf/impgsi.x | 33 + sys/imio/tf/impgsl.x | 33 + sys/imio/tf/impgsr.x | 33 + sys/imio/tf/impgss.x | 33 + sys/imio/tf/impgsx.x | 33 + sys/imio/tf/impl1d.x | 34 + sys/imio/tf/impl1i.x | 34 + sys/imio/tf/impl1l.x | 34 + sys/imio/tf/impl1r.x | 34 + sys/imio/tf/impl1s.x | 34 + sys/imio/tf/impl1x.x | 34 + sys/imio/tf/impl2d.x | 47 + sys/imio/tf/impl2i.x | 47 + sys/imio/tf/impl2l.x | 47 + sys/imio/tf/impl2r.x | 47 + sys/imio/tf/impl2s.x | 47 + sys/imio/tf/impl2x.x | 47 + sys/imio/tf/impl3d.x | 51 + sys/imio/tf/impl3i.x | 51 + sys/imio/tf/impl3l.x | 51 + sys/imio/tf/impl3r.x | 51 + sys/imio/tf/impl3s.x | 51 + sys/imio/tf/impl3x.x | 51 + sys/imio/tf/impnld.x | 31 + sys/imio/tf/impnli.x | 31 + sys/imio/tf/impnll.x | 31 + sys/imio/tf/impnlr.x | 31 + sys/imio/tf/impnls.x | 31 + sys/imio/tf/impnlx.x | 31 + sys/imio/tf/imps1d.x | 20 + sys/imio/tf/imps1i.x | 20 + sys/imio/tf/imps1l.x | 20 + sys/imio/tf/imps1r.x | 20 + sys/imio/tf/imps1s.x | 20 + sys/imio/tf/imps1x.x | 20 + sys/imio/tf/imps2d.x | 26 + sys/imio/tf/imps2i.x | 26 + sys/imio/tf/imps2l.x | 26 + sys/imio/tf/imps2r.x | 26 + sys/imio/tf/imps2s.x | 26 + sys/imio/tf/imps2x.x | 26 + sys/imio/tf/imps3d.x | 29 + sys/imio/tf/imps3i.x | 29 + sys/imio/tf/imps3l.x | 29 + sys/imio/tf/imps3r.x | 29 + sys/imio/tf/imps3s.x | 29 + sys/imio/tf/imps3x.x | 29 + sys/imio/tf/imupkd.x | 34 + sys/imio/tf/imupki.x | 34 + sys/imio/tf/imupkl.x | 34 + sys/imio/tf/imupkr.x | 34 + sys/imio/tf/imupks.x | 34 + sys/imio/tf/imupkx.x | 34 + sys/imio/tf/mkpkg | 123 + sys/imio/zzdebug.x | 24 + sys/ki/README | 648 +++++ sys/ki/irafks.x | 1590 +++++++++++ sys/ki/kbzard.x | 60 + sys/ki/kbzawr.x | 47 + sys/ki/kbzawt.x | 43 + sys/ki/kbzcls.x | 37 + sys/ki/kbzopn.x | 30 + sys/ki/kbzstt.x | 48 + sys/ki/kclcpr.x | 50 + sys/ki/kcldir.x | 44 + sys/ki/kcldpr.x | 44 + sys/ki/kdvall.x | 32 + sys/ki/kdvown.x | 37 + sys/ki/kfacss.x | 35 + sys/ki/kfaloc.x | 33 + sys/ki/kfchdr.x | 61 + sys/ki/kfdele.x | 30 + sys/ki/kfgcwd.x | 54 + sys/ki/kfinfo.x | 42 + sys/ki/kfiobf.x | 110 + sys/ki/kfiogd.x | 110 + sys/ki/kfiolp.x | 110 + sys/ki/kfiopl.x | 110 + sys/ki/kfiopr.x | 106 + sys/ki/kfiosf.x | 112 + sys/ki/kfiotx.x | 157 ++ sys/ki/kfioty.x | 138 + sys/ki/kfmkcp.x | 136 + sys/ki/kfmkdr.x | 30 + sys/ki/kfpath.x | 56 + sys/ki/kfprot.x | 33 + sys/ki/kfrmdr.x | 30 + sys/ki/kfrnam.x | 61 + sys/ki/kfsubd.x | 52 + sys/ki/kfutim.x | 38 + sys/ki/kfxdir.x | 76 + sys/ki/kgfdir.x | 124 + sys/ki/ki.h | 139 + sys/ki/kichan.com | 8 + sys/ki/kiconnect.x | 115 + sys/ki/kiencode.x | 64 + sys/ki/kienvreset.x | 69 + sys/ki/kierror.x | 66 + sys/ki/kiextnode.x | 50 + sys/ki/kifchan.x | 32 + sys/ki/kifmapfn.x | 38 + sys/ki/kifndnode.x | 40 + sys/ki/kigchan.x | 38 + sys/ki/kighost.x | 156 ++ sys/ki/kignode.x | 111 + sys/ki/kii.com | 15 + sys/ki/kiinit.x | 67 + sys/ki/kilnode.x | 41 + sys/ki/kimapchan.x | 44 + sys/ki/kimapname.x | 38 + sys/ki/kinode.com | 18 + sys/ki/kintpr.x | 36 + sys/ki/kiopenks.x | 133 + sys/ki/kireceive.x | 71 + sys/ki/kisend.x | 33 + sys/ki/kisendrcv.x | 20 + sys/ki/kishownet.x | 69 + sys/ki/kixnode.x | 31 + sys/ki/kopcpr.x | 47 + sys/ki/kopdir.x | 50 + sys/ki/kopdpr.x | 59 + sys/ki/koscmd.x | 108 + sys/ki/ksaread.x | 21 + sys/ki/ksawait.x | 24 + sys/ki/ksawrite.x | 21 + sys/ki/ktzcls.x | 38 + sys/ki/ktzfls.x | 33 + sys/ki/ktzget.x | 106 + sys/ki/ktznot.x | 74 + sys/ki/ktzopn.x | 52 + sys/ki/ktzput.x | 125 + sys/ki/ktzsek.x | 50 + sys/ki/ktzstt.x | 32 + sys/ki/kzclmt.x | 45 + sys/ki/kzopmt.x | 90 + sys/ki/kzrdmt.x | 63 + sys/ki/kzrwmt.x | 63 + sys/ki/kzstmt.x | 21 + sys/ki/kzwrmt.x | 49 + sys/ki/kzwtmt.x | 26 + sys/ki/mkpkg | 107 + sys/ki/zzdebug.x | 120 + sys/ki/zzrdks.c | 29 + sys/libc/Libc.hlp | 559 ++++ sys/libc/README | 208 ++ sys/libc/atof.c | 24 + sys/libc/atoi.c | 48 + sys/libc/atol.c | 49 + sys/libc/caccess.c | 22 + sys/libc/calloc.c | 27 + sys/libc/callocate.c | 80 + sys/libc/cclktime.c | 35 + sys/libc/cclose.c | 23 + sys/libc/ccnvdate.c | 25 + sys/libc/ccnvtime.c | 25 + sys/libc/cdelete.c | 20 + sys/libc/cenvget.c | 143 + sys/libc/cenvlist.c | 32 + sys/libc/cenvmark.c | 54 + sys/libc/cenvscan.c | 32 + sys/libc/cerract.c | 21 + sys/libc/cerrcode.c | 15 + sys/libc/cerrget.c | 27 + sys/libc/cerror.c | 20 + sys/libc/cfchdir.c | 19 + sys/libc/cfilbuf.c | 36 + sys/libc/cfinfo.c | 30 + sys/libc/cflsbuf.c | 43 + sys/libc/cflush.c | 20 + sys/libc/cfmapfn.c | 36 + sys/libc/cfmkdir.c | 20 + sys/libc/cfnextn.c | 26 + sys/libc/cfnldir.c | 26 + sys/libc/cfnroot.c | 25 + sys/libc/cfpath.c | 34 + sys/libc/cfredir.c | 46 + sys/libc/cfseti.c | 22 + sys/libc/cfstati.c | 21 + sys/libc/cgetpid.c | 15 + sys/libc/cgetuid.c | 24 + sys/libc/cgflush.c | 20 + sys/libc/cimaccess.c | 28 + sys/libc/cimdrcur.c | 39 + sys/libc/ckimapc.c | 28 + sys/libc/clexnum.c | 54 + sys/libc/cmktemp.c | 27 + sys/libc/cndopen.c | 25 + sys/libc/cnote.c | 29 + sys/libc/copen.c | 26 + sys/libc/coscmd.c | 33 + sys/libc/cpoll.c | 150 + sys/libc/cprcon.c | 198 ++ sys/libc/cprdet.c | 109 + sys/libc/cprintf.c | 53 + sys/libc/crcursor.c | 28 + sys/libc/crdukey.c | 28 + sys/libc/cread.c | 70 + sys/libc/crename.c | 26 + sys/libc/creopen.c | 27 + sys/libc/csalloc.c | 80 + sys/libc/cseek.c | 42 + sys/libc/csppstr.c | 31 + sys/libc/cstropen.c | 26 + sys/libc/cstrpak.c | 35 + sys/libc/cstrupk.c | 41 + sys/libc/ctsleep.c | 18 + sys/libc/cttset.c | 88 + sys/libc/cttycdes.c | 19 + sys/libc/cttyclear.c | 21 + sys/libc/cttyclln.c | 22 + sys/libc/cttyctrl.c | 27 + sys/libc/cttygetb.c | 24 + sys/libc/cttygeti.c | 23 + sys/libc/cttygetr.c | 22 + sys/libc/cttygets.c | 34 + sys/libc/cttygoto.c | 23 + sys/libc/cttyinit.c | 22 + sys/libc/cttyodes.c | 89 + sys/libc/cttyputl.c | 28 + sys/libc/cttyputs.c | 29 + sys/libc/cttyseti.c | 22 + sys/libc/cttyso.c | 23 + sys/libc/cttystati.c | 21 + sys/libc/ctype.c | 31 + sys/libc/cungetc.c | 28 + sys/libc/cungetl.c | 31 + sys/libc/cvfnbrk.c | 30 + sys/libc/cwmsec.c | 20 + sys/libc/cwrite.c | 51 + sys/libc/cxgmes.c | 29 + sys/libc/cxonerr.c | 19 + sys/libc/cxttysize.c | 25 + sys/libc/cxwhen.c | 63 + sys/libc/eprintf.c | 25 + sys/libc/fclose.c | 23 + sys/libc/fdopen.c | 76 + sys/libc/fflush.c | 24 + sys/libc/fgetc.c | 19 + sys/libc/fgets.c | 43 + sys/libc/fopen.c | 61 + sys/libc/fputc.c | 20 + sys/libc/fputs.c | 22 + sys/libc/fread.c | 55 + sys/libc/freadline.c | 34 + sys/libc/free.c | 22 + sys/libc/freopen.c | 56 + sys/libc/fseek.c | 93 + sys/libc/ftell.c | 21 + sys/libc/fwrite.c | 36 + sys/libc/gets.c | 34 + sys/libc/getw.c | 28 + sys/libc/index.c | 26 + sys/libc/isatty.c | 20 + sys/libc/libc_proto.h | 326 +++ sys/libc/malloc.c | 24 + sys/libc/mathf.f | 75 + sys/libc/mkpkg | 168 ++ sys/libc/mktemp.c | 24 + sys/libc/perror.c | 36 + sys/libc/printf.c | 245 ++ sys/libc/puts.c | 25 + sys/libc/putw.c | 27 + sys/libc/qsort.c | 221 ++ sys/libc/realloc.c | 28 + sys/libc/rewind.c | 19 + sys/libc/rindex.c | 27 + sys/libc/scanf.c | 558 ++++ sys/libc/setbuf.c | 68 + sys/libc/spf.c | 65 + sys/libc/sprintf.c | 58 + sys/libc/stgio.c | 60 + sys/libc/strcat.c | 24 + sys/libc/strcmp.c | 22 + sys/libc/strcpy.c | 21 + sys/libc/strdup.c | 22 + sys/libc/strlen.c | 21 + sys/libc/strncat.c | 26 + sys/libc/strncmp.c | 22 + sys/libc/strncpy.c | 27 + sys/libc/system.c | 26 + sys/libc/ungetc.c | 29 + sys/libc/zzdebug.x | 7 + sys/libc/zztest.c | 98 + sys/memdbg/README | 107 + sys/memdbg/begmem.x | 65 + sys/memdbg/calloc.x | 20 + sys/memdbg/coerce.x | 25 + sys/memdbg/kmalloc.x | 24 + sys/memdbg/krealloc.x | 118 + sys/memdbg/malloc.x | 42 + sys/memdbg/malloc1.x | 92 + sys/memdbg/memdbg.com | 4 + sys/memdbg/memlog.c | 175 ++ sys/memdbg/mfree.x | 31 + sys/memdbg/mgdptr.x | 33 + sys/memdbg/mgtfwa.x | 27 + sys/memdbg/mkpkg | 27 + sys/memdbg/msvfwa.x | 23 + sys/memdbg/realloc.x | 25 + sys/memdbg/salloc.x | 164 ++ sys/memdbg/sizeof.x | 12 + sys/memdbg/vmalloc.x | 31 + sys/memdbg/zrtadr.c | 14 + sys/memdbg/zzdebug.x | 190 ++ sys/memio/README | 1 + sys/memio/begmem.x | 65 + sys/memio/calloc.x | 20 + sys/memio/coerce.x | 25 + sys/memio/doc/memio.hlp | 308 +++ sys/memio/kmalloc.x | 21 + sys/memio/krealloc.x | 103 + sys/memio/malloc.x | 24 + sys/memio/malloc1.x | 84 + sys/memio/mfree.x | 27 + sys/memio/mgdptr.x | 34 + sys/memio/mgtfwa.x | 27 + sys/memio/mkpkg | 24 + sys/memio/msvfwa.x | 23 + sys/memio/realloc.x | 22 + sys/memio/salloc.x | 155 ++ sys/memio/sizeof.x | 12 + sys/memio/vmalloc.x | 28 + sys/memio/zzdebug.c | 366 +++ sys/memio/zzdebug.x | 86 + sys/mkpkg | 274 ++ sys/mtio/README | 45 + sys/mtio/doc/mtio.hlp | 814 ++++++ sys/mtio/doc/newdriver.notes | 517 ++++ sys/mtio/mkpkg | 48 + sys/mtio/mtalloc.x | 64 + sys/mtio/mtcache.com | 9 + sys/mtio/mtcache.x | 199 ++ sys/mtio/mtcap.x | 36 + sys/mtio/mtclean.x | 110 + sys/mtio/mtdealloc.x | 35 + sys/mtio/mtdevall.x | 30 + sys/mtio/mtencode.x | 44 + sys/mtio/mtfile.x | 24 + sys/mtio/mtfname.x | 29 + sys/mtio/mtglock.x | 47 + sys/mtio/mtgtyopen.x | 129 + sys/mtio/mtio.com | 9 + sys/mtio/mtio.h | 42 + sys/mtio/mtlocknam.x | 40 + sys/mtio/mtneedf.x | 26 + sys/mtio/mtopen.x | 188 ++ sys/mtio/mtparse.x | 126 + sys/mtio/mtpos.x | 39 + sys/mtio/mtrdlock.x | 93 + sys/mtio/mtrewind.x | 41 + sys/mtio/mtskip.x | 31 + sys/mtio/mtstatus.x | 34 + sys/mtio/mtupdlock.x | 188 ++ sys/mtio/zardmt.x | 22 + sys/mtio/zawrmt.x | 21 + sys/mtio/zawtmt.x | 30 + sys/mtio/zclsmt.x | 55 + sys/mtio/zopnmt.x | 58 + sys/mtio/zsttmt.x | 21 + sys/mtio/zzdebug.x | 357 +++ sys/mwcs/MWCS.hlp | 1026 +++++++ sys/mwcs/README | 47 + sys/mwcs/gen/mkpkg | 29 + sys/mwcs/gen/mwc1trand.x | 24 + sys/mwcs/gen/mwc1tranr.x | 24 + sys/mwcs/gen/mwc2trand.x | 38 + sys/mwcs/gen/mwc2tranr.x | 38 + sys/mwcs/gen/mwctrand.x | 97 + sys/mwcs/gen/mwctranr.x | 97 + sys/mwcs/gen/mwgctrand.x | 44 + sys/mwcs/gen/mwgctranr.x | 44 + sys/mwcs/gen/mwltrand.x | 26 + sys/mwcs/gen/mwltranr.x | 26 + sys/mwcs/gen/mwmmuld.x | 21 + sys/mwcs/gen/mwmmulr.x | 21 + sys/mwcs/gen/mwv1trand.x | 32 + sys/mwcs/gen/mwv1tranr.x | 32 + sys/mwcs/gen/mwv2trand.x | 49 + sys/mwcs/gen/mwv2tranr.x | 49 + sys/mwcs/gen/mwvmuld.x | 20 + sys/mwcs/gen/mwvmulr.x | 20 + sys/mwcs/gen/mwvtrand.x | 18 + sys/mwcs/gen/mwvtranr.x | 18 + sys/mwcs/imwcs.h | 67 + sys/mwcs/iwcfits.x | 18 + sys/mwcs/iwctype.x | 126 + sys/mwcs/iwewcs.x | 336 +++ sys/mwcs/iwfind.x | 34 + sys/mwcs/iwgbfits.x | 90 + sys/mwcs/iwparray.x | 53 + sys/mwcs/iwpstr.x | 80 + sys/mwcs/iwrfits.x | 167 ++ sys/mwcs/iwsaxmap.x | 117 + sys/mwcs/mkpkg | 120 + sys/mwcs/mwallocd.x | 39 + sys/mwcs/mwallocs.x | 42 + sys/mwcs/mwc1tran.gx | 26 + sys/mwcs/mwc2tran.gx | 38 + sys/mwcs/mwclose.x | 36 + sys/mwcs/mwcs.com | 8 + sys/mwcs/mwcs.h | 152 + sys/mwcs/mwctfree.x | 44 + sys/mwcs/mwctran.gx | 99 + sys/mwcs/mwfindsys.x | 28 + sys/mwcs/mwflookup.x | 31 + sys/mwcs/mwgaxlist.x | 42 + sys/mwcs/mwgaxmap.x | 31 + sys/mwcs/mwgctran.gx | 44 + sys/mwcs/mwgltermd.x | 37 + sys/mwcs/mwgltermr.x | 37 + sys/mwcs/mwgsys.x | 18 + sys/mwcs/mwgwattrs.x | 58 + sys/mwcs/mwgwsampd.x | 34 + sys/mwcs/mwgwsampr.x | 34 + sys/mwcs/mwgwtermd.x | 49 + sys/mwcs/mwgwtermr.x | 49 + sys/mwcs/mwinvertd.x | 40 + sys/mwcs/mwinvertr.x | 42 + sys/mwcs/mwload.x | 124 + sys/mwcs/mwloadim.x | 198 ++ sys/mwcs/mwltran.gx | 26 + sys/mwcs/mwlu.x | 143 + sys/mwcs/mwmkidmd.x | 18 + sys/mwcs/mwmkidmr.x | 18 + sys/mwcs/mwmmul.gx | 23 + sys/mwcs/mwnewcopy.x | 129 + sys/mwcs/mwnewsys.x | 41 + sys/mwcs/mwopen.x | 81 + sys/mwcs/mwopenim.x | 21 + sys/mwcs/mwrefstr.x | 55 + sys/mwcs/mwrotate.x | 71 + sys/mwcs/mwsave.x | 90 + sys/mwcs/mwsaveim.x | 394 +++ sys/mwcs/mwsaxmap.x | 52 + sys/mwcs/mwscale.x | 49 + sys/mwcs/mwsctran.x | 410 +++ sys/mwcs/mwsdefwcs.x | 43 + sys/mwcs/mwseti.x | 26 + sys/mwcs/mwshift.x | 47 + sys/mwcs/mwshow.x | 152 + sys/mwcs/mwsltermd.x | 34 + sys/mwcs/mwsltermr.x | 40 + sys/mwcs/mwssys.x | 28 + sys/mwcs/mwstati.x | 36 + sys/mwcs/mwsv.h | 41 + sys/mwcs/mwswattrs.x | 57 + sys/mwcs/mwswsampd.x | 36 + sys/mwcs/mwswsampr.x | 36 + sys/mwcs/mwswtermd.x | 47 + sys/mwcs/mwswtermr.x | 49 + sys/mwcs/mwswtype.x | 131 + sys/mwcs/mwtransd.x | 117 + sys/mwcs/mwtransr.x | 30 + sys/mwcs/mwv1tran.gx | 34 + sys/mwcs/mwv2tran.gx | 49 + sys/mwcs/mwvmul.gx | 22 + sys/mwcs/mwvtran.gx | 20 + sys/mwcs/wfait.x | 463 ++++ sys/mwcs/wfarc.x | 166 ++ sys/mwcs/wfcar.x | 437 +++ sys/mwcs/wfcsc.x | 624 +++++ sys/mwcs/wfdecaxis.x | 51 + sys/mwcs/wfgls.x | 442 +++ sys/mwcs/wfgsurfit.x | 575 ++++ sys/mwcs/wfinit.x | 140 + sys/mwcs/wfmer.x | 446 +++ sys/mwcs/wfmol.x | 518 ++++ sys/mwcs/wfmspec.x | 578 ++++ sys/mwcs/wfpar.x | 458 +++ sys/mwcs/wfpco.x | 518 ++++ sys/mwcs/wfqsc.x | 758 +++++ sys/mwcs/wfsamp.x | 233 ++ sys/mwcs/wfsin.x | 150 + sys/mwcs/wfstg.x | 327 +++ sys/mwcs/wftan.x | 145 + sys/mwcs/wftnx.x | 439 +++ sys/mwcs/wftpv.x | 556 ++++ sys/mwcs/wftsc.x | 563 ++++ sys/mwcs/wfzea.x | 324 +++ sys/mwcs/wfzpn.x | 600 ++++ sys/mwcs/wfzpx.x | 654 +++++ sys/mwcs/zzdebug.x | 507 ++++ sys/nmemio/README | 1 + sys/nmemio/begmem.x | 65 + sys/nmemio/calloc.x | 20 + sys/nmemio/coerce.x | 25 + sys/nmemio/doc/memio.hlp | 308 +++ sys/nmemio/kmalloc.x | 21 + sys/nmemio/krealloc.x | 110 + sys/nmemio/main.x | 893 ++++++ sys/nmemio/malloc.x | 24 + sys/nmemio/malloc1.x | 130 + sys/nmemio/merror.x | 18 + sys/nmemio/mfini.x | 57 + sys/nmemio/mfree.x | 118 + sys/nmemio/mgc.x | 222 ++ sys/nmemio/mgdptr.x | 33 + sys/nmemio/mgtfwa.x | 27 + sys/nmemio/mgtlwl.x | 18 + sys/nmemio/minit.x | 127 + sys/nmemio/mkpkg | 31 + sys/nmemio/msvfwa.x | 55 + sys/nmemio/nmemio.com | 26 + sys/nmemio/realloc.x | 22 + sys/nmemio/salloc.x | 155 ++ sys/nmemio/sizeof.x | 12 + sys/nmemio/vmalloc.x | 28 + sys/nmemio/zz.x | 11 + sys/nmemio/zzdebug.x | 86 + sys/nmemio/zzfoo.gx | 587 ++++ sys/nmemio/zzfoo.x | 908 ++++++ sys/osb/README | 4 + sys/osb/_proto | 77 + sys/osb/abs.c | 13 + sys/osb/achtb.gc | 32 + sys/osb/achtbb.c | 24 + sys/osb/achtbc.c | 24 + sys/osb/achtbd.c | 24 + sys/osb/achtbi.c | 24 + sys/osb/achtbl.c | 24 + sys/osb/achtbr.c | 24 + sys/osb/achtbs.c | 24 + sys/osb/achtbu.c | 24 + sys/osb/achtbx.c | 24 + sys/osb/achtcb.c | 24 + sys/osb/achtcu.c | 29 + sys/osb/achtdb.c | 24 + sys/osb/achtdu.c | 29 + sys/osb/achtib.c | 24 + sys/osb/achtiu.c | 29 + sys/osb/achtlb.c | 24 + sys/osb/achtlu.c | 29 + sys/osb/achtrb.c | 24 + sys/osb/achtru.c | 29 + sys/osb/achtsb.c | 24 + sys/osb/achtsu.c | 29 + sys/osb/achtu.gc | 37 + sys/osb/achtub.c | 29 + sys/osb/achtuc.c | 29 + sys/osb/achtud.c | 29 + sys/osb/achtui.c | 29 + sys/osb/achtul.c | 29 + sys/osb/achtur.c | 29 + sys/osb/achtus.c | 29 + sys/osb/achtuu.c | 29 + sys/osb/achtux.c | 29 + sys/osb/achtxb.c | 24 + sys/osb/achtxu.c | 29 + sys/osb/achtzb.gc | 32 + sys/osb/achtzu.gc | 37 + sys/osb/aclrb.c | 18 + sys/osb/and.c | 32 + sys/osb/bitfields.c | 70 + sys/osb/bitmov.x | 30 + sys/osb/bswap2.c | 38 + sys/osb/bswap2.f | 20 + sys/osb/bswap4.c | 46 + sys/osb/bswap4.f | 29 + sys/osb/bswap8.c | 54 + sys/osb/bytmov.c | 1 + sys/osb/bytmov.f | 27 + sys/osb/chrpak.c | 28 + sys/osb/chrpak.f | 13 + sys/osb/chrupk.c | 32 + sys/osb/chrupk.f | 13 + sys/osb/d1mach.f | 1 + sys/osb/f77pak.f | 32 + sys/osb/f77upk.f | 26 + sys/osb/i1mach.f | 1 + sys/osb/i32to64.c | 42 + sys/osb/i64to32.c | 98 + sys/osb/iand32.c | 12 + sys/osb/ieee.gx | 391 +++ sys/osb/ieeed.x | 356 +++ sys/osb/ieeer.x | 345 +++ sys/osb/imul32.c | 24 + sys/osb/ipak16.c | 20 + sys/osb/ipak32.c | 23 + sys/osb/iscl32.c | 31 + sys/osb/iscl64.c | 31 + sys/osb/iupk16.c | 21 + sys/osb/iupk32.c | 23 + sys/osb/miilen.x | 18 + sys/osb/miinelem.x | 20 + sys/osb/miipak.x | 57 + sys/osb/miipak16.x | 39 + sys/osb/miipak32.x | 67 + sys/osb/miipak8.x | 34 + sys/osb/miipakd.x | 42 + sys/osb/miipakr.x | 42 + sys/osb/miipksize.x | 17 + sys/osb/miiupk.x | 29 + sys/osb/miiupk16.x | 21 + sys/osb/miiupk32.x | 50 + sys/osb/miiupk8.x | 15 + sys/osb/miiupkd.x | 19 + sys/osb/miiupkr.x | 19 + sys/osb/mkpkg | 167 ++ sys/osb/nmilen.x | 18 + sys/osb/nminelem.x | 20 + sys/osb/nmipak.x | 57 + sys/osb/nmipak16.x | 36 + sys/osb/nmipak32.x | 51 + sys/osb/nmipak8.x | 34 + sys/osb/nmipakd.x | 42 + sys/osb/nmipakr.x | 42 + sys/osb/nmipksize.x | 17 + sys/osb/nmiupk.x | 29 + sys/osb/nmiupk16.x | 17 + sys/osb/nmiupk32.x | 28 + sys/osb/nmiupk8.x | 15 + sys/osb/nmiupkd.x | 19 + sys/osb/nmiupkr.x | 19 + sys/osb/not.c | 32 + sys/osb/or.c | 32 + sys/osb/r1mach.f | 1 + sys/osb/shift.c | 49 + sys/osb/strpak.c | 31 + sys/osb/strpak.f | 29 + sys/osb/strsum.c | 100 + sys/osb/strupk.c | 39 + sys/osb/strupk.f | 39 + sys/osb/urand.x | 55 + sys/osb/xor.x | 36 + sys/osb/zzdebug.x | 45 + sys/osb/zzeps.f | 114 + sys/osb/zzeps2.f | 110 + sys/plio/PLIO.hlp | 1341 +++++++++ sys/plio/README | 288 ++ sys/plio/mkpkg | 94 + sys/plio/placcess.x | 59 + sys/plio/plalloc.x | 39 + sys/plio/plascii.x | 66 + sys/plio/plbox.h | 10 + sys/plio/plbox.x | 37 + sys/plio/plcircle.h | 10 + sys/plio/plcircle.x | 43 + sys/plio/plclear.x | 32 + sys/plio/plclose.x | 26 + sys/plio/plcmpress.x | 90 + sys/plio/plcompare.x | 35 + sys/plio/plcreate.x | 22 + sys/plio/pldbgout.x | 47 + sys/plio/pldebug.x | 218 ++ sys/plio/plempty.x | 25 + sys/plio/plemptyline.x | 14 + sys/plio/plglls.x | 39 + sys/plio/plglp.gx | 38 + sys/plio/plglr.gx | 44 + sys/plio/plgplane.x | 15 + sys/plio/plgsize.x | 26 + sys/plio/pll2p.gx | 105 + sys/plio/pll2r.gx | 117 + sys/plio/pllen.x | 14 + sys/plio/plleq.x | 44 + sys/plio/plline.x | 66 + sys/plio/pllinene.x | 17 + sys/plio/pllnext.x | 61 + sys/plio/plload.x | 83 + sys/plio/plloadf.x | 67 + sys/plio/plloadim.x | 99 + sys/plio/plloop.x | 31 + sys/plio/pllpr.x | 111 + sys/plio/pllrop.x | 271 ++ sys/plio/pllseg.h | 56 + sys/plio/pllsten.x | 289 ++ sys/plio/plnewcopy.x | 30 + sys/plio/plopen.x | 30 + sys/plio/plp2l.gx | 126 + sys/plio/plp2r.gx | 71 + sys/plio/plplls.x | 35 + sys/plio/plplp.gx | 41 + sys/plio/plplr.gx | 41 + sys/plio/plpoint.x | 62 + sys/plio/plpolygon.h | 16 + sys/plio/plpolygon.x | 71 + sys/plio/plprop.gx | 177 ++ sys/plio/plr2l.gx | 130 + sys/plio/plr2p.gx | 74 + sys/plio/plregrop.x | 76 + sys/plio/plreq.gx | 27 + sys/plio/plrio.x | 350 +++ sys/plio/plrop.x | 93 + sys/plio/plrpr.gx | 56 + sys/plio/plrrop.gx | 195 ++ sys/plio/plrseg.h | 58 + sys/plio/plsave.x | 86 + sys/plio/plsavef.x | 59 + sys/plio/plsaveim.x | 122 + sys/plio/plsectnc.x | 113 + sys/plio/plsectne.x | 101 + sys/plio/plseti.x | 28 + sys/plio/plsplane.x | 15 + sys/plio/plssize.x | 64 + sys/plio/plsslv.x | 25 + sys/plio/plstati.x | 31 + sys/plio/plsten.x | 92 + sys/plio/plubox.x | 45 + sys/plio/plucircle.x | 54 + sys/plio/plupdate.x | 158 ++ sys/plio/plupolygon.x | 223 ++ sys/plio/plvalid.x | 22 + sys/plio/tf/mkpkg | 51 + sys/plio/tf/plglpi.x | 38 + sys/plio/tf/plglpl.x | 38 + sys/plio/tf/plglps.x | 38 + sys/plio/tf/plglri.x | 44 + sys/plio/tf/plglrl.x | 44 + sys/plio/tf/plglrs.x | 44 + sys/plio/tf/pll2pi.x | 105 + sys/plio/tf/pll2pl.x | 105 + sys/plio/tf/pll2ps.x | 105 + sys/plio/tf/pll2ri.x | 117 + sys/plio/tf/pll2rl.x | 117 + sys/plio/tf/pll2rs.x | 117 + sys/plio/tf/plp2li.x | 126 + sys/plio/tf/plp2ll.x | 126 + sys/plio/tf/plp2ls.x | 126 + sys/plio/tf/plp2ri.x | 71 + sys/plio/tf/plp2rl.x | 71 + sys/plio/tf/plp2rs.x | 71 + sys/plio/tf/plplpi.x | 41 + sys/plio/tf/plplpl.x | 41 + sys/plio/tf/plplps.x | 41 + sys/plio/tf/plplri.x | 41 + sys/plio/tf/plplrl.x | 41 + sys/plio/tf/plplrs.x | 41 + sys/plio/tf/plpropi.x | 177 ++ sys/plio/tf/plpropl.x | 177 ++ sys/plio/tf/plprops.x | 177 ++ sys/plio/tf/plr2li.x | 130 + sys/plio/tf/plr2ll.x | 130 + sys/plio/tf/plr2ls.x | 130 + sys/plio/tf/plr2pi.x | 74 + sys/plio/tf/plr2pl.x | 74 + sys/plio/tf/plr2ps.x | 74 + sys/plio/tf/plreqi.x | 27 + sys/plio/tf/plreql.x | 27 + sys/plio/tf/plreqs.x | 27 + sys/plio/tf/plrpri.x | 56 + sys/plio/tf/plrprl.x | 56 + sys/plio/tf/plrprs.x | 56 + sys/plio/tf/plrropi.x | 195 ++ sys/plio/tf/plrropl.x | 195 ++ sys/plio/tf/plrrops.x | 195 ++ sys/plio/zzdebug.x | 1442 ++++++++++ sys/plio/zzlib.x | 64 + sys/plio/zzsum.x | 50 + sys/pmio/README | 284 ++ sys/pmio/mio.h | 56 + sys/pmio/mioclose.x | 18 + sys/pmio/miogl.gx | 103 + sys/pmio/mioopen.x | 31 + sys/pmio/mioopeno.x | 30 + sys/pmio/miopl.gx | 102 + sys/pmio/mioseti.x | 30 + sys/pmio/miosrange.x | 33 + sys/pmio/miostati.x | 27 + sys/pmio/mkpkg | 68 + sys/pmio/plprop.gx | 177 ++ sys/pmio/pmaccess.x | 24 + sys/pmio/pmascii.x | 27 + sys/pmio/pmbox.x | 34 + sys/pmio/pmcircle.x | 37 + sys/pmio/pmclear.x | 28 + sys/pmio/pmempty.x | 27 + sys/pmio/pmglls.x | 78 + sys/pmio/pmglp.gx | 69 + sys/pmio/pmglr.gx | 85 + sys/pmio/pmio.com | 5 + sys/pmio/pmline.x | 36 + sys/pmio/pmlinene.x | 28 + sys/pmio/pmnewmask.x | 28 + sys/pmio/pmplls.x | 103 + sys/pmio/pmplp.gx | 34 + sys/pmio/pmplr.gx | 34 + sys/pmio/pmpoint.x | 31 + sys/pmio/pmpolygon.x | 42 + sys/pmio/pmrio.x | 128 + sys/pmio/pmrop.x | 74 + sys/pmio/pmsectnc.x | 35 + sys/pmio/pmsectne.x | 32 + sys/pmio/pmseti.x | 30 + sys/pmio/pmsplane.x | 22 + sys/pmio/pmstati.x | 32 + sys/pmio/pmsten.x | 77 + sys/pmio/tf/miogld.x | 103 + sys/pmio/tf/miogli.x | 103 + sys/pmio/tf/miogll.x | 103 + sys/pmio/tf/mioglr.x | 103 + sys/pmio/tf/miogls.x | 103 + sys/pmio/tf/mioglx.x | 103 + sys/pmio/tf/miopld.x | 102 + sys/pmio/tf/miopli.x | 102 + sys/pmio/tf/miopll.x | 102 + sys/pmio/tf/mioplr.x | 102 + sys/pmio/tf/miopls.x | 102 + sys/pmio/tf/mioplx.x | 102 + sys/pmio/tf/mkpkg | 33 + sys/pmio/tf/pmglpi.x | 69 + sys/pmio/tf/pmglpl.x | 69 + sys/pmio/tf/pmglps.x | 69 + sys/pmio/tf/pmglri.x | 81 + sys/pmio/tf/pmglrl.x | 81 + sys/pmio/tf/pmglrs.x | 81 + sys/pmio/tf/pmplpi.x | 34 + sys/pmio/tf/pmplpl.x | 34 + sys/pmio/tf/pmplps.x | 34 + sys/pmio/tf/pmplri.x | 34 + sys/pmio/tf/pmplrl.x | 34 + sys/pmio/tf/pmplrs.x | 34 + sys/pmio/zzdebug.x | 217 ++ sys/pmio/zzinterp.x | 1142 ++++++++ sys/psio/README | 339 +++ sys/psio/font.com | 68 + sys/psio/mkpkg | 29 + sys/psio/psbreak.x | 80 + sys/psio/pscenter.x | 36 + sys/psio/psclose.x | 27 + sys/psio/psdeposit.x | 94 + sys/psio/psfont.x | 145 + sys/psio/psio.h | 90 + sys/psio/psjustify.x | 48 + sys/psio/psopen.x | 107 + sys/psio/psoutput.x | 199 ++ sys/psio/pspos.x | 63 + sys/psio/psprolog.x | 189 ++ sys/psio/pssetup.x | 132 + sys/psio/pswidth.x | 76 + sys/psio/zzdebug.x | 77 + sys/qpoe/QPDEFS | 60 + sys/qpoe/QPOE.hlp | 1201 ++++++++ sys/qpoe/README | 323 +++ sys/qpoe/gen/mkpkg | 47 + sys/qpoe/gen/qpaddb.x | 29 + sys/qpoe/gen/qpaddc.x | 29 + sys/qpoe/gen/qpaddd.x | 29 + sys/qpoe/gen/qpaddi.x | 29 + sys/qpoe/gen/qpaddl.x | 29 + sys/qpoe/gen/qpaddr.x | 29 + sys/qpoe/gen/qpadds.x | 29 + sys/qpoe/gen/qpaddx.x | 29 + sys/qpoe/gen/qpexattrld.x | 127 + sys/qpoe/gen/qpexattrli.x | 127 + sys/qpoe/gen/qpexattrlr.x | 127 + sys/qpoe/gen/qpexcoded.x | 370 +++ sys/qpoe/gen/qpexcodei.x | 423 +++ sys/qpoe/gen/qpexcoder.x | 368 +++ sys/qpoe/gen/qpexparsed.x | 372 +++ sys/qpoe/gen/qpexparsei.x | 363 +++ sys/qpoe/gen/qpexparser.x | 372 +++ sys/qpoe/gen/qpexsubd.x | 63 + sys/qpoe/gen/qpexsubi.x | 63 + sys/qpoe/gen/qpexsubr.x | 63 + sys/qpoe/gen/qpgetc.x | 63 + sys/qpoe/gen/qpgetd.x | 63 + sys/qpoe/gen/qpgeti.x | 63 + sys/qpoe/gen/qpgetl.x | 63 + sys/qpoe/gen/qpgetr.x | 63 + sys/qpoe/gen/qpgets.x | 63 + sys/qpoe/gen/qpiogetev.x | 1968 +++++++++++++ sys/qpoe/gen/qpiorpixi.x | 150 + sys/qpoe/gen/qpiorpixs.x | 150 + sys/qpoe/gen/qpputc.x | 74 + sys/qpoe/gen/qpputd.x | 74 + sys/qpoe/gen/qpputi.x | 74 + sys/qpoe/gen/qpputl.x | 74 + sys/qpoe/gen/qpputr.x | 74 + sys/qpoe/gen/qpputs.x | 74 + sys/qpoe/gen/qprlmerged.x | 134 + sys/qpoe/gen/qprlmergei.x | 134 + sys/qpoe/gen/qprlmerger.x | 134 + sys/qpoe/mkpkg | 133 + sys/qpoe/qpaccess.x | 26 + sys/qpoe/qpaccessf.x | 24 + sys/qpoe/qpadd.gx | 29 + sys/qpoe/qpaddf.x | 173 ++ sys/qpoe/qpastr.x | 35 + sys/qpoe/qpbind.x | 48 + sys/qpoe/qpclose.x | 26 + sys/qpoe/qpcopy.x | 28 + sys/qpoe/qpcopyf.x | 48 + sys/qpoe/qpctod.x | 34 + sys/qpoe/qpctoi.x | 34 + sys/qpoe/qpdelete.x | 20 + sys/qpoe/qpdeletef.x | 35 + sys/qpoe/qpdsym.x | 56 + sys/qpoe/qpdtype.x | 57 + sys/qpoe/qpelsize.x | 20 + sys/qpoe/qpex.h | 164 ++ sys/qpoe/qpexattrl.gx | 127 + sys/qpoe/qpexclose.x | 25 + sys/qpoe/qpexcode.gx | 484 ++++ sys/qpoe/qpexdata.x | 210 ++ sys/qpoe/qpexdebug.x | 441 +++ sys/qpoe/qpexdel.x | 58 + sys/qpoe/qpexeval.x | 362 +++ sys/qpoe/qpexgetat.x | 61 + sys/qpoe/qpexgetfil.x | 50 + sys/qpoe/qpexmodfil.x | 247 ++ sys/qpoe/qpexopen.x | 67 + sys/qpoe/qpexpand.x | 60 + sys/qpoe/qpexparse.gx | 410 +++ sys/qpoe/qpexsub.gx | 67 + sys/qpoe/qpget.gx | 67 + sys/qpoe/qpgetb.x | 26 + sys/qpoe/qpgettok.x | 687 +++++ sys/qpoe/qpgetx.x | 26 + sys/qpoe/qpgmsym.x | 76 + sys/qpoe/qpgnfn.x | 240 ++ sys/qpoe/qpgpar.x | 101 + sys/qpoe/qpgpsym.x | 90 + sys/qpoe/qpgstr.x | 42 + sys/qpoe/qpinherit.x | 57 + sys/qpoe/qpio.h | 140 + sys/qpoe/qpioclose.x | 49 + sys/qpoe/qpiogetev.gx | 467 ++++ sys/qpoe/qpiogetfil.x | 123 + sys/qpoe/qpiogetrg.x | 19 + sys/qpoe/qpiolmask.x | 119 + sys/qpoe/qpiolwcs.x | 50 + sys/qpoe/qpiomkidx.x | 299 ++ sys/qpoe/qpioopen.x | 392 +++ sys/qpoe/qpioparse.x | 374 +++ sys/qpoe/qpioputev.x | 104 + sys/qpoe/qpiorb.x | 44 + sys/qpoe/qpiorpix.gx | 86 + sys/qpoe/qpiosetfil.x | 59 + sys/qpoe/qpioseti.x | 90 + sys/qpoe/qpiosetr.x | 30 + sys/qpoe/qpiosetrg.x | 34 + sys/qpoe/qpiostati.x | 84 + sys/qpoe/qpiostatr.x | 29 + sys/qpoe/qpiosync.x | 78 + sys/qpoe/qpiowb.x | 131 + sys/qpoe/qplenf.x | 26 + sys/qpoe/qploadwcs.x | 38 + sys/qpoe/qpmacro.x | 832 ++++++ sys/qpoe/qpmkfname.x | 23 + sys/qpoe/qpoe.h | 115 + sys/qpoe/qpopen.x | 132 + sys/qpoe/qpparse.x | 70 + sys/qpoe/qpparsefl.x | 149 + sys/qpoe/qppclose.x | 27 + sys/qpoe/qppopen.x | 62 + sys/qpoe/qpppar.x | 136 + sys/qpoe/qppstr.x | 47 + sys/qpoe/qpput.gx | 74 + sys/qpoe/qpputb.x | 31 + sys/qpoe/qpputx.x | 31 + sys/qpoe/qpqueryf.x | 91 + sys/qpoe/qpread.x | 80 + sys/qpoe/qprebuild.x | 21 + sys/qpoe/qprename.x | 25 + sys/qpoe/qprenamef.x | 48 + sys/qpoe/qprlmerge.gx | 134 + sys/qpoe/qpsavewcs.x | 35 + sys/qpoe/qpseti.x | 62 + sys/qpoe/qpsetr.x | 24 + sys/qpoe/qpsizeof.x | 46 + sys/qpoe/qpstati.x | 76 + sys/qpoe/qpstatr.x | 29 + sys/qpoe/qpsync.x | 51 + sys/qpoe/qpwrite.x | 79 + sys/qpoe/zzdebug.x | 1696 ++++++++++++ sys/symtab/README | 126 + sys/symtab/mkpkg | 30 + sys/symtab/stalloc.x | 33 + sys/symtab/stclose.x | 16 + sys/symtab/stenter.x | 59 + sys/symtab/stfind.x | 74 + sys/symtab/stfindall.x | 81 + sys/symtab/stfree.x | 44 + sys/symtab/sthash.x | 37 + sys/symtab/sthead.x | 17 + sys/symtab/stinfo.x | 142 + sys/symtab/stmark.x | 25 + sys/symtab/stname.x | 15 + sys/symtab/stnext.x | 26 + sys/symtab/stnsym.x | 23 + sys/symtab/stopen.x | 60 + sys/symtab/stpstr.x | 45 + sys/symtab/strefsbuf.x | 14 + sys/symtab/strefstab.x | 14 + sys/symtab/strestore.x | 69 + sys/symtab/stsave.x | 41 + sys/symtab/stsize.x | 21 + sys/symtab/stsqueeze.x | 25 + sys/symtab/symtab.h | 54 + sys/symtab/zzdebug.x | 283 ++ sys/sys.hd | 60 + sys/sys.men | 14 + sys/tty/README | 29 + sys/tty/doc/tty.hlp | 485 ++++ sys/tty/gttyload.x | 38 + sys/tty/mkpkg | 52 + sys/tty/tty.h | 51 + sys/tty/ttycaps.x | 13 + sys/tty/ttycdes.x | 11 + sys/tty/ttyclear.x | 31 + sys/tty/ttyclln.x | 32 + sys/tty/ttyclose.x | 11 + sys/tty/ttyctrl.x | 31 + sys/tty/ttydelay.x | 31 + sys/tty/ttydevnm.x | 41 + sys/tty/ttygdes.x | 148 + sys/tty/ttygetb.x | 15 + sys/tty/ttygeti.x | 27 + sys/tty/ttygetr.x | 41 + sys/tty/ttygets.x | 73 + sys/tty/ttygoto.x | 78 + sys/tty/ttygsize.x | 115 + sys/tty/ttyindex.x | 167 ++ sys/tty/ttyinit.x | 46 + sys/tty/ttyload.x | 44 + sys/tty/ttyodes.x | 183 ++ sys/tty/ttyopen.x | 299 ++ sys/tty/ttyputl.x | 322 +++ sys/tty/ttyputs.x | 15 + sys/tty/ttyread.x | 102 + sys/tty/ttyseti.x | 36 + sys/tty/ttyso.x | 32 + sys/tty/ttystati.x | 37 + sys/tty/ttysubi.x | 194 ++ sys/tty/ttywrite.x | 60 + sys/tty/x_mkttydata.x | 367 +++ sys/tty/zzdebug.x | 184 ++ sys/vops/README | 10 + sys/vops/aabs.gx | 13 + sys/vops/aadd.gx | 13 + sys/vops/aaddk.gx | 15 + sys/vops/aand.gx | 23 + sys/vops/aandk.gx | 26 + sys/vops/aavg.gx | 20 + sys/vops/abav.gx | 46 + sys/vops/abeq.gx | 19 + sys/vops/abeqk.gx | 31 + sys/vops/abge.gx | 23 + sys/vops/abgek.gx | 45 + sys/vops/abgt.gx | 23 + sys/vops/abgtk.gx | 45 + sys/vops/able.gx | 23 + sys/vops/ablek.gx | 45 + sys/vops/ablt.gx | 23 + sys/vops/abltk.gx | 45 + sys/vops/abne.gx | 19 + sys/vops/abnek.gx | 31 + sys/vops/abor.gx | 23 + sys/vops/abork.gx | 26 + sys/vops/absu.gx | 41 + sys/vops/acht.gx | 36 + sys/vops/achtgen/acht.x | 32 + sys/vops/achtgen/achtb.x | 34 + sys/vops/achtgen/achtc.x | 34 + sys/vops/achtgen/achtd.x | 34 + sys/vops/achtgen/achti.x | 34 + sys/vops/achtgen/achtl.x | 34 + sys/vops/achtgen/achtr.x | 34 + sys/vops/achtgen/achts.x | 34 + sys/vops/achtgen/achtu.x | 34 + sys/vops/achtgen/achtx.x | 34 + sys/vops/achtgen/mkpkg | 25 + sys/vops/acjgx.x | 14 + sys/vops/aclr.gx | 13 + sys/vops/acnv.gx | 54 + sys/vops/acnvr.gx | 55 + sys/vops/adiv.gx | 14 + sys/vops/adivk.gx | 16 + sys/vops/adot.gx | 28 + sys/vops/advz.gx | 54 + sys/vops/aexp.gx | 13 + sys/vops/aexpk.gx | 15 + sys/vops/afftrr.x | 34 + sys/vops/afftrx.x | 33 + sys/vops/afftxr.x | 27 + sys/vops/afftxx.x | 39 + sys/vops/aglt.gx | 48 + sys/vops/ahgm.gx | 39 + sys/vops/ahiv.gx | 35 + sys/vops/aiftrr.x | 36 + sys/vops/aiftrx.x | 31 + sys/vops/aiftxr.x | 27 + sys/vops/aiftxx.x | 45 + sys/vops/aimg.gx | 14 + sys/vops/ak/aabsd.x | 13 + sys/vops/ak/aabsi.x | 13 + sys/vops/ak/aabsl.x | 13 + sys/vops/ak/aabsr.x | 13 + sys/vops/ak/aabss.x | 13 + sys/vops/ak/aabsx.x | 13 + sys/vops/ak/aaddd.x | 13 + sys/vops/ak/aaddi.x | 13 + sys/vops/ak/aaddkd.x | 15 + sys/vops/ak/aaddki.x | 15 + sys/vops/ak/aaddkl.x | 15 + sys/vops/ak/aaddkr.x | 15 + sys/vops/ak/aaddks.x | 15 + sys/vops/ak/aaddkx.x | 15 + sys/vops/ak/aaddl.x | 13 + sys/vops/ak/aaddr.x | 13 + sys/vops/ak/aadds.x | 13 + sys/vops/ak/aaddx.x | 13 + sys/vops/ak/aandi.x | 15 + sys/vops/ak/aandki.x | 18 + sys/vops/ak/aandkl.x | 18 + sys/vops/ak/aandks.x | 18 + sys/vops/ak/aandl.x | 15 + sys/vops/ak/aands.x | 15 + sys/vops/ak/aavgd.x | 16 + sys/vops/ak/aavgi.x | 16 + sys/vops/ak/aavgl.x | 16 + sys/vops/ak/aavgr.x | 16 + sys/vops/ak/aavgs.x | 16 + sys/vops/ak/aavgx.x | 16 + sys/vops/ak/abavd.x | 36 + sys/vops/ak/abavi.x | 36 + sys/vops/ak/abavl.x | 36 + sys/vops/ak/abavr.x | 36 + sys/vops/ak/abavs.x | 36 + sys/vops/ak/abavx.x | 36 + sys/vops/ak/abeqc.x | 19 + sys/vops/ak/abeqd.x | 19 + sys/vops/ak/abeqi.x | 19 + sys/vops/ak/abeqkc.x | 31 + sys/vops/ak/abeqkd.x | 31 + sys/vops/ak/abeqki.x | 31 + sys/vops/ak/abeqkl.x | 31 + sys/vops/ak/abeqkr.x | 31 + sys/vops/ak/abeqks.x | 31 + sys/vops/ak/abeqkx.x | 31 + sys/vops/ak/abeql.x | 19 + sys/vops/ak/abeqr.x | 19 + sys/vops/ak/abeqs.x | 19 + sys/vops/ak/abeqx.x | 19 + sys/vops/ak/abgec.x | 19 + sys/vops/ak/abged.x | 19 + sys/vops/ak/abgei.x | 19 + sys/vops/ak/abgekc.x | 31 + sys/vops/ak/abgekd.x | 31 + sys/vops/ak/abgeki.x | 31 + sys/vops/ak/abgekl.x | 31 + sys/vops/ak/abgekr.x | 31 + sys/vops/ak/abgeks.x | 31 + sys/vops/ak/abgekx.x | 29 + sys/vops/ak/abgel.x | 19 + sys/vops/ak/abger.x | 19 + sys/vops/ak/abges.x | 19 + sys/vops/ak/abgex.x | 19 + sys/vops/ak/abgtc.x | 19 + sys/vops/ak/abgtd.x | 19 + sys/vops/ak/abgti.x | 19 + sys/vops/ak/abgtkc.x | 31 + sys/vops/ak/abgtkd.x | 31 + sys/vops/ak/abgtki.x | 31 + sys/vops/ak/abgtkl.x | 31 + sys/vops/ak/abgtkr.x | 31 + sys/vops/ak/abgtks.x | 31 + sys/vops/ak/abgtkx.x | 33 + sys/vops/ak/abgtl.x | 19 + sys/vops/ak/abgtr.x | 19 + sys/vops/ak/abgts.x | 19 + sys/vops/ak/abgtx.x | 19 + sys/vops/ak/ablec.x | 19 + sys/vops/ak/abled.x | 19 + sys/vops/ak/ablei.x | 19 + sys/vops/ak/ablekc.x | 31 + sys/vops/ak/ablekd.x | 31 + sys/vops/ak/ableki.x | 31 + sys/vops/ak/ablekl.x | 31 + sys/vops/ak/ablekr.x | 31 + sys/vops/ak/ableks.x | 31 + sys/vops/ak/ablekx.x | 33 + sys/vops/ak/ablel.x | 19 + sys/vops/ak/abler.x | 19 + sys/vops/ak/ables.x | 19 + sys/vops/ak/ablex.x | 19 + sys/vops/ak/abltc.x | 19 + sys/vops/ak/abltd.x | 19 + sys/vops/ak/ablti.x | 19 + sys/vops/ak/abltkc.x | 31 + sys/vops/ak/abltkd.x | 31 + sys/vops/ak/abltki.x | 31 + sys/vops/ak/abltkl.x | 31 + sys/vops/ak/abltkr.x | 31 + sys/vops/ak/abltks.x | 31 + sys/vops/ak/abltkx.x | 29 + sys/vops/ak/abltl.x | 19 + sys/vops/ak/abltr.x | 19 + sys/vops/ak/ablts.x | 19 + sys/vops/ak/abltx.x | 19 + sys/vops/ak/abnec.x | 19 + sys/vops/ak/abned.x | 19 + sys/vops/ak/abnei.x | 19 + sys/vops/ak/abnekc.x | 31 + sys/vops/ak/abnekd.x | 31 + sys/vops/ak/abneki.x | 31 + sys/vops/ak/abnekl.x | 31 + sys/vops/ak/abnekr.x | 31 + sys/vops/ak/abneks.x | 31 + sys/vops/ak/abnekx.x | 31 + sys/vops/ak/abnel.x | 19 + sys/vops/ak/abner.x | 19 + sys/vops/ak/abnes.x | 19 + sys/vops/ak/abnex.x | 19 + sys/vops/ak/abori.x | 15 + sys/vops/ak/aborki.x | 18 + sys/vops/ak/aborkl.x | 18 + sys/vops/ak/aborks.x | 18 + sys/vops/ak/aborl.x | 15 + sys/vops/ak/abors.x | 15 + sys/vops/ak/absud.x | 35 + sys/vops/ak/absui.x | 35 + sys/vops/ak/absul.x | 35 + sys/vops/ak/absur.x | 35 + sys/vops/ak/absus.x | 35 + sys/vops/ak/achtcc.x | 15 + sys/vops/ak/achtcd.x | 17 + sys/vops/ak/achtci.x | 17 + sys/vops/ak/achtcl.x | 17 + sys/vops/ak/achtcr.x | 17 + sys/vops/ak/achtcs.x | 17 + sys/vops/ak/achtcx.x | 17 + sys/vops/ak/achtdc.x | 17 + sys/vops/ak/achtdd.x | 15 + sys/vops/ak/achtdi.x | 17 + sys/vops/ak/achtdl.x | 17 + sys/vops/ak/achtdr.x | 17 + sys/vops/ak/achtds.x | 17 + sys/vops/ak/achtdx.x | 17 + sys/vops/ak/achtic.x | 17 + sys/vops/ak/achtid.x | 17 + sys/vops/ak/achtii.x | 15 + sys/vops/ak/achtil.x | 17 + sys/vops/ak/achtir.x | 17 + sys/vops/ak/achtis.x | 17 + sys/vops/ak/achtix.x | 17 + sys/vops/ak/achtlc.x | 17 + sys/vops/ak/achtld.x | 17 + sys/vops/ak/achtli.x | 17 + sys/vops/ak/achtll.x | 15 + sys/vops/ak/achtlr.x | 17 + sys/vops/ak/achtls.x | 17 + sys/vops/ak/achtlx.x | 17 + sys/vops/ak/achtrc.x | 17 + sys/vops/ak/achtrd.x | 17 + sys/vops/ak/achtri.x | 17 + sys/vops/ak/achtrl.x | 17 + sys/vops/ak/achtrr.x | 15 + sys/vops/ak/achtrs.x | 17 + sys/vops/ak/achtrx.x | 17 + sys/vops/ak/achtsc.x | 17 + sys/vops/ak/achtsd.x | 17 + sys/vops/ak/achtsi.x | 17 + sys/vops/ak/achtsl.x | 17 + sys/vops/ak/achtsr.x | 17 + sys/vops/ak/achtss.x | 15 + sys/vops/ak/achtsx.x | 17 + sys/vops/ak/achtxc.x | 17 + sys/vops/ak/achtxd.x | 17 + sys/vops/ak/achtxi.x | 17 + sys/vops/ak/achtxl.x | 17 + sys/vops/ak/achtxr.x | 17 + sys/vops/ak/achtxs.x | 17 + sys/vops/ak/achtxx.x | 15 + sys/vops/ak/acjgx.x | 14 + sys/vops/ak/aclrc.x | 13 + sys/vops/ak/aclrd.x | 13 + sys/vops/ak/aclri.x | 13 + sys/vops/ak/aclrl.x | 13 + sys/vops/ak/aclrr.x | 13 + sys/vops/ak/aclrs.x | 13 + sys/vops/ak/aclrx.x | 13 + sys/vops/ak/acnvd.x | 54 + sys/vops/ak/acnvi.x | 54 + sys/vops/ak/acnvl.x | 54 + sys/vops/ak/acnvr.x | 54 + sys/vops/ak/acnvrd.x | 55 + sys/vops/ak/acnvri.x | 55 + sys/vops/ak/acnvrl.x | 55 + sys/vops/ak/acnvrr.x | 55 + sys/vops/ak/acnvrs.x | 55 + sys/vops/ak/acnvs.x | 54 + sys/vops/ak/adivd.x | 14 + sys/vops/ak/adivi.x | 14 + sys/vops/ak/adivkd.x | 16 + sys/vops/ak/adivki.x | 16 + sys/vops/ak/adivkl.x | 16 + sys/vops/ak/adivkr.x | 16 + sys/vops/ak/adivks.x | 16 + sys/vops/ak/adivkx.x | 16 + sys/vops/ak/adivl.x | 14 + sys/vops/ak/adivr.x | 14 + sys/vops/ak/adivs.x | 14 + sys/vops/ak/adivx.x | 14 + sys/vops/ak/adotd.x | 20 + sys/vops/ak/adoti.x | 20 + sys/vops/ak/adotl.x | 20 + sys/vops/ak/adotr.x | 20 + sys/vops/ak/adots.x | 20 + sys/vops/ak/adotx.x | 20 + sys/vops/ak/advzd.x | 41 + sys/vops/ak/advzi.x | 33 + sys/vops/ak/advzl.x | 33 + sys/vops/ak/advzr.x | 41 + sys/vops/ak/advzs.x | 33 + sys/vops/ak/advzx.x | 33 + sys/vops/ak/aexpd.x | 13 + sys/vops/ak/aexpi.x | 13 + sys/vops/ak/aexpkd.x | 15 + sys/vops/ak/aexpki.x | 15 + sys/vops/ak/aexpkl.x | 15 + sys/vops/ak/aexpkr.x | 15 + sys/vops/ak/aexpks.x | 15 + sys/vops/ak/aexpkx.x | 15 + sys/vops/ak/aexpl.x | 13 + sys/vops/ak/aexpr.x | 13 + sys/vops/ak/aexps.x | 13 + sys/vops/ak/aexpx.x | 13 + sys/vops/ak/afftrr.x | 34 + sys/vops/ak/afftrx.x | 33 + sys/vops/ak/afftxr.x | 27 + sys/vops/ak/afftxx.x | 39 + sys/vops/ak/agltc.x | 29 + sys/vops/ak/agltd.x | 29 + sys/vops/ak/aglti.x | 29 + sys/vops/ak/agltl.x | 29 + sys/vops/ak/agltr.x | 29 + sys/vops/ak/aglts.x | 29 + sys/vops/ak/agltx.x | 32 + sys/vops/ak/ahgmc.x | 39 + sys/vops/ak/ahgmd.x | 39 + sys/vops/ak/ahgmi.x | 39 + sys/vops/ak/ahgml.x | 39 + sys/vops/ak/ahgmr.x | 39 + sys/vops/ak/ahgms.x | 39 + sys/vops/ak/ahivc.x | 22 + sys/vops/ak/ahivd.x | 22 + sys/vops/ak/ahivi.x | 22 + sys/vops/ak/ahivl.x | 22 + sys/vops/ak/ahivr.x | 22 + sys/vops/ak/ahivs.x | 22 + sys/vops/ak/ahivx.x | 26 + sys/vops/ak/aiftrr.x | 36 + sys/vops/ak/aiftrx.x | 31 + sys/vops/ak/aiftxr.x | 27 + sys/vops/ak/aiftxx.x | 45 + sys/vops/ak/aimgd.x | 14 + sys/vops/ak/aimgi.x | 14 + sys/vops/ak/aimgl.x | 14 + sys/vops/ak/aimgr.x | 14 + sys/vops/ak/aimgs.x | 14 + sys/vops/ak/mkpkg | 276 ++ sys/vops/alan.gx | 19 + sys/vops/alank.gx | 19 + sys/vops/alim.gx | 28 + sys/vops/alln.gx | 33 + sys/vops/alog.gx | 34 + sys/vops/alor.gx | 19 + sys/vops/alork.gx | 19 + sys/vops/alov.gx | 35 + sys/vops/alta.gx | 19 + sys/vops/altm.gx | 19 + sys/vops/altr.gx | 20 + sys/vops/alui.gx | 30 + sys/vops/alut.gx | 22 + sys/vops/amag.gx | 19 + sys/vops/amap.gx | 42 + sys/vops/amax.gx | 20 + sys/vops/amaxk.gx | 29 + sys/vops/amed.gx | 72 + sys/vops/amed3.gx | 30 + sys/vops/amed4.gx | 41 + sys/vops/amed5.gx | 55 + sys/vops/amgs.gx | 13 + sys/vops/amin.gx | 20 + sys/vops/amink.gx | 29 + sys/vops/amod.gx | 13 + sys/vops/amodk.gx | 15 + sys/vops/amov.gx | 26 + sys/vops/amovk.gx | 14 + sys/vops/amul.gx | 13 + sys/vops/amulk.gx | 15 + sys/vops/aneg.gx | 13 + sys/vops/anot.gx | 23 + sys/vops/apkx.gx | 20 + sys/vops/apol.gx | 25 + sys/vops/apow.gx | 14 + sys/vops/apowk.gx | 34 + sys/vops/arav.gx | 52 + sys/vops/arcp.gx | 24 + sys/vops/arcz.gx | 60 + sys/vops/argt.gx | 28 + sys/vops/arlt.gx | 27 + sys/vops/asel.gx | 21 + sys/vops/aselk.gx | 21 + sys/vops/asok.gx | 77 + sys/vops/asqr.gx | 31 + sys/vops/asrt.gx | 77 + sys/vops/assq.gx | 26 + sys/vops/asub.gx | 13 + sys/vops/asubk.gx | 15 + sys/vops/asum.gx | 32 + sys/vops/aupx.gx | 23 + sys/vops/aveq.gx | 18 + sys/vops/awsu.gx | 20 + sys/vops/awvg.gx | 83 + sys/vops/axor.gx | 23 + sys/vops/axork.gx | 25 + sys/vops/doc/vops.hlp | 260 ++ sys/vops/fftr.f | 689 +++++ sys/vops/fftx.f | 277 ++ sys/vops/lz/alani.x | 19 + sys/vops/lz/alanki.x | 19 + sys/vops/lz/alankl.x | 19 + sys/vops/lz/alanks.x | 19 + sys/vops/lz/alanl.x | 19 + sys/vops/lz/alans.x | 19 + sys/vops/lz/alimc.x | 21 + sys/vops/lz/alimd.x | 21 + sys/vops/lz/alimi.x | 21 + sys/vops/lz/aliml.x | 21 + sys/vops/lz/alimr.x | 21 + sys/vops/lz/alims.x | 21 + sys/vops/lz/alimx.x | 21 + sys/vops/lz/allnd.x | 23 + sys/vops/lz/allni.x | 23 + sys/vops/lz/allnl.x | 23 + sys/vops/lz/allnr.x | 23 + sys/vops/lz/allns.x | 23 + sys/vops/lz/allnx.x | 23 + sys/vops/lz/alogd.x | 24 + sys/vops/lz/alogi.x | 24 + sys/vops/lz/alogl.x | 24 + sys/vops/lz/alogr.x | 24 + sys/vops/lz/alogs.x | 24 + sys/vops/lz/alogx.x | 24 + sys/vops/lz/alori.x | 19 + sys/vops/lz/alorki.x | 19 + sys/vops/lz/alorkl.x | 19 + sys/vops/lz/alorks.x | 19 + sys/vops/lz/alorl.x | 19 + sys/vops/lz/alors.x | 19 + sys/vops/lz/alovc.x | 22 + sys/vops/lz/alovd.x | 22 + sys/vops/lz/alovi.x | 22 + sys/vops/lz/alovl.x | 22 + sys/vops/lz/alovr.x | 22 + sys/vops/lz/alovs.x | 22 + sys/vops/lz/alovx.x | 26 + sys/vops/lz/altad.x | 15 + sys/vops/lz/altai.x | 15 + sys/vops/lz/altal.x | 15 + sys/vops/lz/altar.x | 15 + sys/vops/lz/altas.x | 15 + sys/vops/lz/altax.x | 15 + sys/vops/lz/altmd.x | 15 + sys/vops/lz/altmi.x | 15 + sys/vops/lz/altml.x | 15 + sys/vops/lz/altmr.x | 15 + sys/vops/lz/altms.x | 15 + sys/vops/lz/altmx.x | 15 + sys/vops/lz/altrd.x | 16 + sys/vops/lz/altri.x | 16 + sys/vops/lz/altrl.x | 16 + sys/vops/lz/altrr.x | 16 + sys/vops/lz/altrs.x | 16 + sys/vops/lz/altrx.x | 16 + sys/vops/lz/aluid.x | 30 + sys/vops/lz/aluii.x | 30 + sys/vops/lz/aluil.x | 30 + sys/vops/lz/aluir.x | 30 + sys/vops/lz/aluis.x | 30 + sys/vops/lz/alutc.x | 18 + sys/vops/lz/alutd.x | 18 + sys/vops/lz/aluti.x | 18 + sys/vops/lz/alutl.x | 18 + sys/vops/lz/alutr.x | 18 + sys/vops/lz/aluts.x | 18 + sys/vops/lz/amagd.x | 13 + sys/vops/lz/amagi.x | 13 + sys/vops/lz/amagl.x | 13 + sys/vops/lz/amagr.x | 13 + sys/vops/lz/amags.x | 13 + sys/vops/lz/amagx.x | 13 + sys/vops/lz/amapd.x | 30 + sys/vops/lz/amapi.x | 30 + sys/vops/lz/amapl.x | 30 + sys/vops/lz/amapr.x | 30 + sys/vops/lz/amaps.x | 30 + sys/vops/lz/amaxc.x | 13 + sys/vops/lz/amaxd.x | 13 + sys/vops/lz/amaxi.x | 13 + sys/vops/lz/amaxkc.x | 16 + sys/vops/lz/amaxkd.x | 16 + sys/vops/lz/amaxki.x | 16 + sys/vops/lz/amaxkl.x | 16 + sys/vops/lz/amaxkr.x | 16 + sys/vops/lz/amaxks.x | 16 + sys/vops/lz/amaxkx.x | 21 + sys/vops/lz/amaxl.x | 13 + sys/vops/lz/amaxr.x | 13 + sys/vops/lz/amaxs.x | 13 + sys/vops/lz/amaxx.x | 16 + sys/vops/lz/amed3c.x | 30 + sys/vops/lz/amed3d.x | 30 + sys/vops/lz/amed3i.x | 30 + sys/vops/lz/amed3l.x | 30 + sys/vops/lz/amed3r.x | 30 + sys/vops/lz/amed3s.x | 30 + sys/vops/lz/amed4c.x | 41 + sys/vops/lz/amed4d.x | 41 + sys/vops/lz/amed4i.x | 41 + sys/vops/lz/amed4l.x | 41 + sys/vops/lz/amed4r.x | 41 + sys/vops/lz/amed4s.x | 41 + sys/vops/lz/amed5c.x | 55 + sys/vops/lz/amed5d.x | 55 + sys/vops/lz/amed5i.x | 55 + sys/vops/lz/amed5l.x | 55 + sys/vops/lz/amed5r.x | 55 + sys/vops/lz/amed5s.x | 55 + sys/vops/lz/amedc.x | 48 + sys/vops/lz/amedd.x | 48 + sys/vops/lz/amedi.x | 48 + sys/vops/lz/amedl.x | 48 + sys/vops/lz/amedr.x | 48 + sys/vops/lz/ameds.x | 48 + sys/vops/lz/amedx.x | 52 + sys/vops/lz/amgsd.x | 13 + sys/vops/lz/amgsi.x | 13 + sys/vops/lz/amgsl.x | 13 + sys/vops/lz/amgsr.x | 13 + sys/vops/lz/amgss.x | 13 + sys/vops/lz/amgsx.x | 13 + sys/vops/lz/aminc.x | 13 + sys/vops/lz/amind.x | 13 + sys/vops/lz/amini.x | 13 + sys/vops/lz/aminkc.x | 16 + sys/vops/lz/aminkd.x | 16 + sys/vops/lz/aminki.x | 16 + sys/vops/lz/aminkl.x | 16 + sys/vops/lz/aminkr.x | 16 + sys/vops/lz/aminks.x | 16 + sys/vops/lz/aminkx.x | 21 + sys/vops/lz/aminl.x | 13 + sys/vops/lz/aminr.x | 13 + sys/vops/lz/amins.x | 13 + sys/vops/lz/aminx.x | 16 + sys/vops/lz/amodd.x | 13 + sys/vops/lz/amodi.x | 13 + sys/vops/lz/amodkd.x | 15 + sys/vops/lz/amodki.x | 15 + sys/vops/lz/amodkl.x | 15 + sys/vops/lz/amodkr.x | 15 + sys/vops/lz/amodks.x | 15 + sys/vops/lz/amodl.x | 13 + sys/vops/lz/amodr.x | 13 + sys/vops/lz/amods.x | 13 + sys/vops/lz/amovc.x | 26 + sys/vops/lz/amovd.x | 26 + sys/vops/lz/amovi.x | 26 + sys/vops/lz/amovkc.x | 14 + sys/vops/lz/amovkd.x | 14 + sys/vops/lz/amovki.x | 14 + sys/vops/lz/amovkl.x | 14 + sys/vops/lz/amovkr.x | 14 + sys/vops/lz/amovks.x | 14 + sys/vops/lz/amovkx.x | 14 + sys/vops/lz/amovl.x | 26 + sys/vops/lz/amovr.x | 26 + sys/vops/lz/amovs.x | 26 + sys/vops/lz/amovx.x | 26 + sys/vops/lz/amuld.x | 13 + sys/vops/lz/amuli.x | 13 + sys/vops/lz/amulkd.x | 15 + sys/vops/lz/amulki.x | 15 + sys/vops/lz/amulkl.x | 15 + sys/vops/lz/amulkr.x | 15 + sys/vops/lz/amulks.x | 15 + sys/vops/lz/amulkx.x | 15 + sys/vops/lz/amull.x | 13 + sys/vops/lz/amulr.x | 13 + sys/vops/lz/amuls.x | 13 + sys/vops/lz/amulx.x | 13 + sys/vops/lz/anegd.x | 13 + sys/vops/lz/anegi.x | 13 + sys/vops/lz/anegl.x | 13 + sys/vops/lz/anegr.x | 13 + sys/vops/lz/anegs.x | 13 + sys/vops/lz/anegx.x | 13 + sys/vops/lz/anoti.x | 15 + sys/vops/lz/anotl.x | 15 + sys/vops/lz/anots.x | 15 + sys/vops/lz/apkxd.x | 16 + sys/vops/lz/apkxi.x | 16 + sys/vops/lz/apkxl.x | 16 + sys/vops/lz/apkxr.x | 16 + sys/vops/lz/apkxs.x | 16 + sys/vops/lz/apkxx.x | 16 + sys/vops/lz/apold.x | 25 + sys/vops/lz/apolr.x | 25 + sys/vops/lz/apowd.x | 14 + sys/vops/lz/apowi.x | 14 + sys/vops/lz/apowkd.x | 34 + sys/vops/lz/apowki.x | 34 + sys/vops/lz/apowkl.x | 34 + sys/vops/lz/apowkr.x | 34 + sys/vops/lz/apowks.x | 34 + sys/vops/lz/apowkx.x | 34 + sys/vops/lz/apowl.x | 14 + sys/vops/lz/apowr.x | 14 + sys/vops/lz/apows.x | 14 + sys/vops/lz/apowx.x | 14 + sys/vops/lz/aravd.x | 44 + sys/vops/lz/aravi.x | 44 + sys/vops/lz/aravl.x | 44 + sys/vops/lz/aravr.x | 44 + sys/vops/lz/aravs.x | 44 + sys/vops/lz/aravx.x | 44 + sys/vops/lz/arcpd.x | 24 + sys/vops/lz/arcpi.x | 24 + sys/vops/lz/arcpl.x | 24 + sys/vops/lz/arcpr.x | 24 + sys/vops/lz/arcps.x | 24 + sys/vops/lz/arcpx.x | 24 + sys/vops/lz/arczd.x | 47 + sys/vops/lz/arczi.x | 39 + sys/vops/lz/arczl.x | 39 + sys/vops/lz/arczr.x | 47 + sys/vops/lz/arczs.x | 39 + sys/vops/lz/arczx.x | 39 + sys/vops/lz/argtd.x | 18 + sys/vops/lz/argti.x | 18 + sys/vops/lz/argtl.x | 18 + sys/vops/lz/argtr.x | 18 + sys/vops/lz/argts.x | 18 + sys/vops/lz/argtx.x | 20 + sys/vops/lz/arltd.x | 17 + sys/vops/lz/arlti.x | 17 + sys/vops/lz/arltl.x | 17 + sys/vops/lz/arltr.x | 17 + sys/vops/lz/arlts.x | 17 + sys/vops/lz/arltx.x | 19 + sys/vops/lz/aselc.x | 21 + sys/vops/lz/aseld.x | 21 + sys/vops/lz/aseli.x | 21 + sys/vops/lz/aselkc.x | 21 + sys/vops/lz/aselkd.x | 21 + sys/vops/lz/aselki.x | 21 + sys/vops/lz/aselkl.x | 21 + sys/vops/lz/aselkr.x | 21 + sys/vops/lz/aselks.x | 21 + sys/vops/lz/aselkx.x | 21 + sys/vops/lz/asell.x | 21 + sys/vops/lz/aselr.x | 21 + sys/vops/lz/asels.x | 21 + sys/vops/lz/aselx.x | 21 + sys/vops/lz/asokc.x | 63 + sys/vops/lz/asokd.x | 63 + sys/vops/lz/asoki.x | 63 + sys/vops/lz/asokl.x | 63 + sys/vops/lz/asokr.x | 63 + sys/vops/lz/asoks.x | 63 + sys/vops/lz/asokx.x | 65 + sys/vops/lz/asqrd.x | 23 + sys/vops/lz/asqri.x | 23 + sys/vops/lz/asqrl.x | 23 + sys/vops/lz/asqrr.x | 23 + sys/vops/lz/asqrs.x | 23 + sys/vops/lz/asqrx.x | 20 + sys/vops/lz/asrtc.x | 69 + sys/vops/lz/asrtd.x | 69 + sys/vops/lz/asrti.x | 69 + sys/vops/lz/asrtl.x | 69 + sys/vops/lz/asrtr.x | 69 + sys/vops/lz/asrts.x | 69 + sys/vops/lz/asrtx.x | 69 + sys/vops/lz/assqd.x | 18 + sys/vops/lz/assqi.x | 18 + sys/vops/lz/assql.x | 18 + sys/vops/lz/assqr.x | 18 + sys/vops/lz/assqs.x | 18 + sys/vops/lz/assqx.x | 18 + sys/vops/lz/asubd.x | 13 + sys/vops/lz/asubi.x | 13 + sys/vops/lz/asubkd.x | 15 + sys/vops/lz/asubki.x | 15 + sys/vops/lz/asubkl.x | 15 + sys/vops/lz/asubkr.x | 15 + sys/vops/lz/asubks.x | 15 + sys/vops/lz/asubkx.x | 15 + sys/vops/lz/asubl.x | 13 + sys/vops/lz/asubr.x | 13 + sys/vops/lz/asubs.x | 13 + sys/vops/lz/asubx.x | 13 + sys/vops/lz/asumd.x | 20 + sys/vops/lz/asumi.x | 20 + sys/vops/lz/asuml.x | 20 + sys/vops/lz/asumr.x | 20 + sys/vops/lz/asums.x | 20 + sys/vops/lz/asumx.x | 20 + sys/vops/lz/aupxd.x | 18 + sys/vops/lz/aupxi.x | 18 + sys/vops/lz/aupxl.x | 18 + sys/vops/lz/aupxr.x | 18 + sys/vops/lz/aupxs.x | 18 + sys/vops/lz/aupxx.x | 18 + sys/vops/lz/aveqc.x | 18 + sys/vops/lz/aveqd.x | 18 + sys/vops/lz/aveqi.x | 18 + sys/vops/lz/aveql.x | 18 + sys/vops/lz/aveqr.x | 18 + sys/vops/lz/aveqs.x | 18 + sys/vops/lz/aveqx.x | 18 + sys/vops/lz/awsud.x | 14 + sys/vops/lz/awsui.x | 14 + sys/vops/lz/awsul.x | 14 + sys/vops/lz/awsur.x | 14 + sys/vops/lz/awsus.x | 14 + sys/vops/lz/awsux.x | 14 + sys/vops/lz/awvgd.x | 62 + sys/vops/lz/awvgi.x | 62 + sys/vops/lz/awvgl.x | 62 + sys/vops/lz/awvgr.x | 62 + sys/vops/lz/awvgs.x | 62 + sys/vops/lz/awvgx.x | 62 + sys/vops/lz/axori.x | 15 + sys/vops/lz/axorki.x | 17 + sys/vops/lz/axorkl.x | 17 + sys/vops/lz/axorks.x | 17 + sys/vops/lz/axorl.x | 15 + sys/vops/lz/axors.x | 15 + sys/vops/lz/mkpkg | 330 +++ sys/vops/mkpkg | 150 + sys/vops/vops.calls | 106 + sys/vops/vops.men | 94 + sys/vops/vops.syn | 96 + sys/vops/zzdebug.x | 29 + 3484 files changed, 319469 insertions(+) create mode 100644 sys/INDEX create mode 100644 sys/NAMES create mode 100644 sys/README create mode 100644 sys/_sys.hd create mode 100644 sys/clio/README create mode 100644 sys/clio/clcache.x create mode 100644 sys/clio/clclose.x create mode 100644 sys/clio/clcmd.x create mode 100644 sys/clio/clcmdw.x create mode 100644 sys/clio/clcpset.x create mode 100644 sys/clio/clepset.x create mode 100644 sys/clio/clgcur.x create mode 100644 sys/clio/clgetb.x create mode 100644 sys/clio/clgetc.x create mode 100644 sys/clio/clgetd.x create mode 100644 sys/clio/clgeti.x create mode 100644 sys/clio/clgetl.x create mode 100644 sys/clio/clgetr.x create mode 100644 sys/clio/clgets.x create mode 100644 sys/clio/clgetx.x create mode 100644 sys/clio/clgfil.x create mode 100644 sys/clio/clgkey.x create mode 100644 sys/clio/clglpb.x create mode 100644 sys/clio/clglpc.x create mode 100644 sys/clio/clglpd.x create mode 100644 sys/clio/clglpi.x create mode 100644 sys/clio/clglpl.x create mode 100644 sys/clio/clglpr.x create mode 100644 sys/clio/clglps.x create mode 100644 sys/clio/clglpx.x create mode 100644 sys/clio/clglstr.x create mode 100644 sys/clio/clgpset.x create mode 100644 sys/clio/clgpseta.x create mode 100644 sys/clio/clgpsetb.x create mode 100644 sys/clio/clgpsetc.x create mode 100644 sys/clio/clgpsetd.x create mode 100644 sys/clio/clgpseti.x create mode 100644 sys/clio/clgpsetl.x create mode 100644 sys/clio/clgpsetr.x create mode 100644 sys/clio/clgpsets.x create mode 100644 sys/clio/clgpsetx.x create mode 100644 sys/clio/clgstr.x create mode 100644 sys/clio/clgwrd.x create mode 100644 sys/clio/clio.com create mode 100644 sys/clio/cllpset.x create mode 100644 sys/clio/clopen.x create mode 100644 sys/clio/clopset.x create mode 100644 sys/clio/clppset.x create mode 100644 sys/clio/clppseta.x create mode 100644 sys/clio/clppsetb.x create mode 100644 sys/clio/clppsetc.x create mode 100644 sys/clio/clppsetd.x create mode 100644 sys/clio/clppseti.x create mode 100644 sys/clio/clppsetl.x create mode 100644 sys/clio/clppsetr.x create mode 100644 sys/clio/clppsets.x create mode 100644 sys/clio/clppsetx.x create mode 100644 sys/clio/clpset.h create mode 100644 sys/clio/clpsetnm.x create mode 100644 sys/clio/clpstr.x create mode 100644 sys/clio/clputb.x create mode 100644 sys/clio/clputc.x create mode 100644 sys/clio/clputd.x create mode 100644 sys/clio/clputi.x create mode 100644 sys/clio/clputr.x create mode 100644 sys/clio/clputx.x create mode 100644 sys/clio/clreqpar.x create mode 100644 sys/clio/clseti.x create mode 100644 sys/clio/clstati.x create mode 100644 sys/clio/doc/clio.hd create mode 100644 sys/clio/doc/clio.men create mode 100644 sys/clio/gexfls.x create mode 100644 sys/clio/mkpkg create mode 100644 sys/clio/rdukey.x create mode 100644 sys/clio/zfiocl.x create mode 100644 sys/dbio/README create mode 100644 sys/dbio/db2.doc create mode 100644 sys/dbio/db2.hlp create mode 100644 sys/dbio/doc/dbio.hlp create mode 100644 sys/dbio/new/coords create mode 100644 sys/dbio/new/dbio.con create mode 100644 sys/dbio/new/dbio.hlp create mode 100644 sys/dbio/new/dbio.hlp.1 create mode 100644 sys/dbio/new/dbki.hlp create mode 100644 sys/dbio/new/ddl create mode 100644 sys/dbio/new/schema create mode 100644 sys/dbio/new/spie.ms create mode 100644 sys/etc/README create mode 100644 sys/etc/brktime.x create mode 100644 sys/etc/btoi.x create mode 100644 sys/etc/clktime.x create mode 100644 sys/etc/cnvdate.x create mode 100644 sys/etc/cnvtime.x create mode 100644 sys/etc/cputime.x create mode 100644 sys/etc/doc/Proc.hlp create mode 100644 sys/etc/doc/error.hlp create mode 100644 sys/etc/doc/etc.hd create mode 100644 sys/etc/doc/etc.men create mode 100644 sys/etc/doc/psio.doc create mode 100644 sys/etc/dtmcnv.x create mode 100644 sys/etc/envgetb.x create mode 100644 sys/etc/envgetd.x create mode 100644 sys/etc/envgeti.x create mode 100644 sys/etc/envgetr.x create mode 100644 sys/etc/envgets.x create mode 100644 sys/etc/envindir.x create mode 100644 sys/etc/envinit.x create mode 100644 sys/etc/environ.com create mode 100644 sys/etc/environ.h create mode 100644 sys/etc/environ.x create mode 100644 sys/etc/envlist.x create mode 100644 sys/etc/envnext.x create mode 100644 sys/etc/envreset.x create mode 100644 sys/etc/envscan.x create mode 100644 sys/etc/erract.x create mode 100644 sys/etc/errcode.x create mode 100644 sys/etc/errget.x create mode 100644 sys/etc/error.com create mode 100644 sys/etc/error.x create mode 100644 sys/etc/gen/miireadd.x create mode 100644 sys/etc/gen/miireadi.x create mode 100644 sys/etc/gen/miireadl.x create mode 100644 sys/etc/gen/miireadr.x create mode 100644 sys/etc/gen/miireads.x create mode 100644 sys/etc/gen/miiwrited.x create mode 100644 sys/etc/gen/miiwritei.x create mode 100644 sys/etc/gen/miiwritel.x create mode 100644 sys/etc/gen/miiwriter.x create mode 100644 sys/etc/gen/miiwrites.x create mode 100644 sys/etc/gen/mkpkg create mode 100644 sys/etc/gen/nmireadb.x create mode 100644 sys/etc/gen/nmireadd.x create mode 100644 sys/etc/gen/nmireadi.x create mode 100644 sys/etc/gen/nmireadl.x create mode 100644 sys/etc/gen/nmireadr.x create mode 100644 sys/etc/gen/nmireads.x create mode 100644 sys/etc/gen/nmiwriteb.x create mode 100644 sys/etc/gen/nmiwrited.x create mode 100644 sys/etc/gen/nmiwritei.x create mode 100644 sys/etc/gen/nmiwritel.x create mode 100644 sys/etc/gen/nmiwriter.x create mode 100644 sys/etc/gen/nmiwrites.x create mode 100644 sys/etc/gethost.x create mode 100644 sys/etc/getpid.x create mode 100644 sys/etc/getuid.x create mode 100644 sys/etc/gmtcnv.x create mode 100644 sys/etc/gqsort.x create mode 100644 sys/etc/intr.x create mode 100644 sys/etc/itob.x create mode 100644 sys/etc/lineoff.x create mode 100644 sys/etc/locpr.x create mode 100644 sys/etc/locva.x create mode 100644 sys/etc/lpopen.x create mode 100644 sys/etc/maideh.x create mode 100644 sys/etc/main.x create mode 100644 sys/etc/miiread.gx create mode 100644 sys/etc/miireadc.x create mode 100644 sys/etc/miiwrite.gx create mode 100644 sys/etc/miiwritec.x create mode 100644 sys/etc/mkpkg create mode 100644 sys/etc/nmiread.gx create mode 100644 sys/etc/nmireadb.x create mode 100644 sys/etc/nmireadc.x create mode 100644 sys/etc/nmiwrite.gx create mode 100644 sys/etc/nmiwriteb.x create mode 100644 sys/etc/nmiwritec.x create mode 100644 sys/etc/onentry.x create mode 100644 sys/etc/onerror.x create mode 100644 sys/etc/onexit.x create mode 100644 sys/etc/oscmd.x create mode 100644 sys/etc/pagefiles.x create mode 100644 sys/etc/prc.com create mode 100644 sys/etc/prchdir.x create mode 100644 sys/etc/prclcpr.x create mode 100644 sys/etc/prcldpr.x create mode 100644 sys/etc/prclose.x create mode 100644 sys/etc/prd.com create mode 100644 sys/etc/prdone.x create mode 100644 sys/etc/prenvfree.x create mode 100644 sys/etc/prenvset.x create mode 100644 sys/etc/prfilbuf.x create mode 100644 sys/etc/prfindpr.x create mode 100644 sys/etc/prgline.x create mode 100644 sys/etc/prgredir.x create mode 100644 sys/etc/prkill.x create mode 100644 sys/etc/propcpr.x create mode 100644 sys/etc/propdpr.x create mode 100644 sys/etc/propen.x create mode 100644 sys/etc/proscmd.x create mode 100644 sys/etc/prpsio.x create mode 100644 sys/etc/prpsload.x create mode 100644 sys/etc/prredir.x create mode 100644 sys/etc/prseti.x create mode 100644 sys/etc/prsignal.x create mode 100644 sys/etc/prstati.x create mode 100644 sys/etc/prupdate.x create mode 100644 sys/etc/psioisxt.x create mode 100644 sys/etc/psioxfer.x create mode 100644 sys/etc/qsort.x create mode 100644 sys/etc/sttyco.x create mode 100644 sys/etc/syserr.x create mode 100644 sys/etc/sysid.x create mode 100644 sys/etc/syspanic.x create mode 100644 sys/etc/sysptime.x create mode 100644 sys/etc/tsleep.x create mode 100644 sys/etc/ttopen.x create mode 100644 sys/etc/urlget.x create mode 100644 sys/etc/votable.x create mode 100644 sys/etc/xalloc.x create mode 100644 sys/etc/xerfmt.x create mode 100644 sys/etc/xerpop.x create mode 100644 sys/etc/xerpue.x create mode 100644 sys/etc/xerreset.x create mode 100644 sys/etc/xerstmt.x create mode 100644 sys/etc/xerverify.x create mode 100644 sys/etc/xgdevlist.x create mode 100644 sys/etc/xisatty.x create mode 100644 sys/etc/xmjbuf.x create mode 100644 sys/etc/xttysize.x create mode 100644 sys/etc/xwhen.x create mode 100644 sys/etc/zzdebug.x create mode 100644 sys/fio/README create mode 100644 sys/fio/access.x create mode 100644 sys/fio/aread.x create mode 100644 sys/fio/areadb.x create mode 100644 sys/fio/await.x create mode 100644 sys/fio/awaitb.x create mode 100644 sys/fio/awrite.x create mode 100644 sys/fio/awriteb.x create mode 100644 sys/fio/close.x create mode 100644 sys/fio/delete.x create mode 100644 sys/fio/deletefg.x create mode 100644 sys/fio/diropen.x create mode 100644 sys/fio/doc/fio.hd create mode 100644 sys/fio/doc/fio.hlp create mode 100644 sys/fio/doc/fio.men create mode 100644 sys/fio/doc/vfn.hlp create mode 100644 sys/fio/falloc.x create mode 100644 sys/fio/fcache.x create mode 100644 sys/fio/fcanpb.x create mode 100644 sys/fio/fchdir.x create mode 100644 sys/fio/fclobber.x create mode 100644 sys/fio/fcopy.x create mode 100644 sys/fio/fdebug.x create mode 100644 sys/fio/fdevbf.x create mode 100644 sys/fio/fdevblk.x create mode 100644 sys/fio/fdevtx.x create mode 100644 sys/fio/fdirname.x create mode 100644 sys/fio/fexbuf.x create mode 100644 sys/fio/ffault.x create mode 100644 sys/fio/ffilbf.x create mode 100644 sys/fio/ffilsz.x create mode 100644 sys/fio/fflsbf.x create mode 100644 sys/fio/fgdevpar.x create mode 100644 sys/fio/fgetfd.x create mode 100644 sys/fio/filbuf.x create mode 100644 sys/fio/filerr.x create mode 100644 sys/fio/filopn.x create mode 100644 sys/fio/finfo.x create mode 100644 sys/fio/finit.x create mode 100644 sys/fio/fioclean.x create mode 100644 sys/fio/flsbuf.x create mode 100644 sys/fio/flush.x create mode 100644 sys/fio/fmapfn.x create mode 100644 sys/fio/fmkbfs.x create mode 100644 sys/fio/fmkcopy.x create mode 100644 sys/fio/fmkdir.x create mode 100644 sys/fio/fmkpbbuf.x create mode 100644 sys/fio/fnextn.x create mode 100644 sys/fio/fnldir.x create mode 100644 sys/fio/fnroot.x create mode 100644 sys/fio/fntgfn.x create mode 100644 sys/fio/fnullfile.x create mode 100644 sys/fio/fopnbf.x create mode 100644 sys/fio/fopntx.x create mode 100644 sys/fio/fowner.x create mode 100644 sys/fio/fpathname.x create mode 100644 sys/fio/fputtx.x create mode 100644 sys/fio/freadp.x create mode 100644 sys/fio/fredir.x create mode 100644 sys/fio/frename.x create mode 100644 sys/fio/frmbfs.x create mode 100644 sys/fio/frmdir.x create mode 100644 sys/fio/frtnfd.x create mode 100644 sys/fio/fseti.x create mode 100644 sys/fio/fsfopen.x create mode 100644 sys/fio/fstati.x create mode 100644 sys/fio/fstatl.x create mode 100644 sys/fio/fstats.x create mode 100644 sys/fio/fstdfile.x create mode 100644 sys/fio/fstrfp.x create mode 100644 sys/fio/fsvtfn.x create mode 100644 sys/fio/fswapfd.x create mode 100644 sys/fio/fsymlink.x create mode 100644 sys/fio/funlink.x create mode 100644 sys/fio/futime.x create mode 100644 sys/fio/fwatio.x create mode 100644 sys/fio/fwritep.x create mode 100644 sys/fio/fwtacc.x create mode 100644 sys/fio/getc.x create mode 100644 sys/fio/getchar.x create mode 100644 sys/fio/getci.x create mode 100644 sys/fio/getline.x create mode 100644 sys/fio/getlline.x create mode 100644 sys/fio/glongline.x create mode 100644 sys/fio/isdir.x create mode 100644 sys/fio/mkpkg create mode 100644 sys/fio/mktemp.x create mode 100644 sys/fio/mmap.inc create mode 100644 sys/fio/ndopen.x create mode 100644 sys/fio/note.x create mode 100644 sys/fio/nowhite.x create mode 100644 sys/fio/nullfile.x create mode 100644 sys/fio/open.x create mode 100644 sys/fio/osfnlock.x create mode 100644 sys/fio/poll.x create mode 100644 sys/fio/protect.x create mode 100644 sys/fio/putc.x create mode 100644 sys/fio/putcc.x create mode 100644 sys/fio/putci.x create mode 100644 sys/fio/putline.x create mode 100644 sys/fio/read.x create mode 100644 sys/fio/rename.x create mode 100644 sys/fio/reopen.x create mode 100644 sys/fio/seek.x create mode 100644 sys/fio/stropen.x create mode 100644 sys/fio/ungetc.x create mode 100644 sys/fio/ungetci.x create mode 100644 sys/fio/ungetline.x create mode 100644 sys/fio/unread.x create mode 100644 sys/fio/vfnmap.x create mode 100644 sys/fio/vfntrans.x create mode 100644 sys/fio/write.x create mode 100644 sys/fio/xerputc.x create mode 100644 sys/fio/zfiott.com create mode 100644 sys/fio/zfiott.x create mode 100644 sys/fio/zzdebug.x create mode 100644 sys/fmio/README create mode 100644 sys/fmio/fmaccess.x create mode 100644 sys/fmio/fmclose.x create mode 100644 sys/fmio/fmcopy.x create mode 100644 sys/fmio/fmcopyo.x create mode 100644 sys/fmio/fmdebug.x create mode 100644 sys/fmio/fmdelete.x create mode 100644 sys/fmio/fmfcache.x create mode 100644 sys/fmio/fmfopen.x create mode 100644 sys/fmio/fmio.h create mode 100644 sys/fmio/fmiobind.x create mode 100644 sys/fmio/fmioerr.x create mode 100644 sys/fmio/fmioextnd.x create mode 100644 sys/fmio/fmiopost.x create mode 100644 sys/fmio/fmiorhdr.x create mode 100644 sys/fmio/fmiosbuf.x create mode 100644 sys/fmio/fmiotick.x create mode 100644 sys/fmio/fmlfard.x create mode 100644 sys/fmio/fmlfawr.x create mode 100644 sys/fmio/fmlfawt.x create mode 100644 sys/fmio/fmlfbrd.x create mode 100644 sys/fmio/fmlfbwr.x create mode 100644 sys/fmio/fmlfbwt.x create mode 100644 sys/fmio/fmlfcls.x create mode 100644 sys/fmio/fmlfcopy.x create mode 100644 sys/fmio/fmlfdel.x create mode 100644 sys/fmio/fmlfname.x create mode 100644 sys/fmio/fmlfopen.x create mode 100644 sys/fmio/fmlfparse.x create mode 100644 sys/fmio/fmlfstat.h create mode 100644 sys/fmio/fmlfstat.x create mode 100644 sys/fmio/fmlfstt.x create mode 100644 sys/fmio/fmlfundel.x create mode 100644 sys/fmio/fmnextlf.x create mode 100644 sys/fmio/fmopen.x create mode 100644 sys/fmio/fmrebuild.x create mode 100644 sys/fmio/fmrename.x create mode 100644 sys/fmio/fmset.h create mode 100644 sys/fmio/fmseti.x create mode 100644 sys/fmio/fmstati.x create mode 100644 sys/fmio/fmsync.x create mode 100644 sys/fmio/mkpkg create mode 100644 sys/fmio/zzdebug.x create mode 100644 sys/fmtio/README create mode 100644 sys/fmtio/cctoc.x create mode 100644 sys/fmtio/chdeposit.x create mode 100644 sys/fmtio/chfetch.x create mode 100644 sys/fmtio/chrlwr.x create mode 100644 sys/fmtio/chrupr.x create mode 100644 sys/fmtio/clprintf.x create mode 100644 sys/fmtio/clscan.x create mode 100644 sys/fmtio/ctocc.x create mode 100644 sys/fmtio/ctod.x create mode 100644 sys/fmtio/ctoi.x create mode 100644 sys/fmtio/ctol.x create mode 100644 sys/fmtio/ctor.x create mode 100644 sys/fmtio/ctotok.x create mode 100644 sys/fmtio/ctowrd.x create mode 100644 sys/fmtio/ctox.x create mode 100644 sys/fmtio/doc/evexpr.hlp create mode 100644 sys/fmtio/doc/fmtio.hd create mode 100644 sys/fmtio/doc/fmtio.men create mode 100644 sys/fmtio/doc/lexnum.hlp create mode 100644 sys/fmtio/dtcscl.x create mode 100644 sys/fmtio/dtoc.x create mode 100644 sys/fmtio/dtoc3.x create mode 100644 sys/fmtio/eprintf.x create mode 100644 sys/fmtio/escchars.inc create mode 100644 sys/fmtio/evexpr.com create mode 100644 sys/fmtio/evexpr.x create mode 100644 sys/fmtio/evexpr.y create mode 100644 sys/fmtio/evvexpr.com create mode 100644 sys/fmtio/evvexpr.gy create mode 100644 sys/fmtio/evvexpr.x create mode 100644 sys/fmtio/evvexpr.y create mode 100644 sys/fmtio/fmt.com create mode 100644 sys/fmtio/fmterr.x create mode 100644 sys/fmtio/fmtinit.x create mode 100644 sys/fmtio/fmtread.x create mode 100644 sys/fmtio/fmtsetcol.x create mode 100644 sys/fmtio/fmtstr.x create mode 100644 sys/fmtio/fpradv.x create mode 100644 sys/fmtio/fprfmt.x create mode 100644 sys/fmtio/fprintf.x create mode 100644 sys/fmtio/fprntf.x create mode 100644 sys/fmtio/fscan.x create mode 100644 sys/fmtio/gargb.x create mode 100644 sys/fmtio/gargc.x create mode 100644 sys/fmtio/gargd.x create mode 100644 sys/fmtio/gargi.x create mode 100644 sys/fmtio/gargl.x create mode 100644 sys/fmtio/gargr.x create mode 100644 sys/fmtio/gargrad.x create mode 100644 sys/fmtio/gargs.x create mode 100644 sys/fmtio/gargstr.x create mode 100644 sys/fmtio/gargtok.x create mode 100644 sys/fmtio/gargwrd.x create mode 100644 sys/fmtio/gargx.x create mode 100644 sys/fmtio/gctod.x create mode 100644 sys/fmtio/gctol.x create mode 100644 sys/fmtio/gctox.x create mode 100644 sys/fmtio/gltoc.x create mode 100644 sys/fmtio/gstrcat.x create mode 100644 sys/fmtio/gstrcpy.x create mode 100644 sys/fmtio/itoc.x create mode 100644 sys/fmtio/lexdata.inc create mode 100644 sys/fmtio/lexnum.x create mode 100644 sys/fmtio/ltoc.x create mode 100644 sys/fmtio/mkpkg create mode 100644 sys/fmtio/nscan.x create mode 100644 sys/fmtio/parg.x create mode 100644 sys/fmtio/pargb.x create mode 100644 sys/fmtio/pargstr.x create mode 100644 sys/fmtio/pargx.x create mode 100644 sys/fmtio/patmatch.x create mode 100644 sys/fmtio/printf.x create mode 100644 sys/fmtio/resetscan.x create mode 100644 sys/fmtio/scan.com create mode 100644 sys/fmtio/scanc.x create mode 100644 sys/fmtio/sprintf.x create mode 100644 sys/fmtio/sscan.x create mode 100644 sys/fmtio/strcat.x create mode 100644 sys/fmtio/strcmp.x create mode 100644 sys/fmtio/strcpy.x create mode 100644 sys/fmtio/strdic.x create mode 100644 sys/fmtio/streq.x create mode 100644 sys/fmtio/strge.x create mode 100644 sys/fmtio/strgt.x create mode 100644 sys/fmtio/stridx.x create mode 100644 sys/fmtio/stridxs.x create mode 100644 sys/fmtio/strldx.x create mode 100644 sys/fmtio/strldxs.x create mode 100644 sys/fmtio/strle.x create mode 100644 sys/fmtio/strlen.x create mode 100644 sys/fmtio/strlt.x create mode 100644 sys/fmtio/strlwr.x create mode 100644 sys/fmtio/strmac.x create mode 100644 sys/fmtio/strmatch.x create mode 100644 sys/fmtio/strncmp.x create mode 100644 sys/fmtio/strne.x create mode 100644 sys/fmtio/strsearch.x create mode 100644 sys/fmtio/strsrt.x create mode 100644 sys/fmtio/strtbl.x create mode 100644 sys/fmtio/strupr.x create mode 100644 sys/fmtio/tokdata.inc create mode 100644 sys/fmtio/xevgettok.x create mode 100644 sys/fmtio/xtoc.x create mode 100644 sys/fmtio/xvvgettok.x create mode 100644 sys/fmtio/zzdebug.x create mode 100644 sys/gio/README create mode 100644 sys/gio/aelogd.x create mode 100644 sys/gio/aelogr.x create mode 100644 sys/gio/calcomp/README create mode 100644 sys/gio/calcomp/ccp.com create mode 100644 sys/gio/calcomp/ccp.h create mode 100644 sys/gio/calcomp/ccpclear.x create mode 100644 sys/gio/calcomp/ccpclose.x create mode 100644 sys/gio/calcomp/ccpclws.x create mode 100644 sys/gio/calcomp/ccpcolor.x create mode 100644 sys/gio/calcomp/ccpcseg.x create mode 100644 sys/gio/calcomp/ccpdrawch.x create mode 100644 sys/gio/calcomp/ccpdseg.x create mode 100644 sys/gio/calcomp/ccpescape.x create mode 100644 sys/gio/calcomp/ccpfa.x create mode 100644 sys/gio/calcomp/ccpfaset.x create mode 100644 sys/gio/calcomp/ccpfont.x create mode 100644 sys/gio/calcomp/ccpinit.x create mode 100644 sys/gio/calcomp/ccpltype.x create mode 100644 sys/gio/calcomp/ccplwidth.x create mode 100644 sys/gio/calcomp/ccpopen.x create mode 100644 sys/gio/calcomp/ccpopenws.x create mode 100644 sys/gio/calcomp/ccppl.x create mode 100644 sys/gio/calcomp/ccpplset.x create mode 100644 sys/gio/calcomp/ccppm.x create mode 100644 sys/gio/calcomp/ccppmset.x create mode 100644 sys/gio/calcomp/ccpreset.x create mode 100644 sys/gio/calcomp/ccptx.x create mode 100644 sys/gio/calcomp/ccptxset.x create mode 100644 sys/gio/calcomp/doc/ccpspecs.hlp create mode 100644 sys/gio/calcomp/font.com create mode 100644 sys/gio/calcomp/font.h create mode 100644 sys/gio/calcomp/mkpkg create mode 100644 sys/gio/calcomp/rptheta4.x create mode 100644 sys/gio/calcomp/t_calcomp.x create mode 100644 sys/gio/calcomp/vttest.par create mode 100644 sys/gio/calcomp/vttest.x create mode 100644 sys/gio/calcomp/x_calcomp.x create mode 100644 sys/gio/cursor/README create mode 100644 sys/gio/cursor/doc/cursor.hlp create mode 100644 sys/gio/cursor/doc/giotr.notes create mode 100644 sys/gio/cursor/giotr.x create mode 100644 sys/gio/cursor/grc.h create mode 100644 sys/gio/cursor/grcaxes.x create mode 100644 sys/gio/cursor/grcclose.x create mode 100644 sys/gio/cursor/grccmd.x create mode 100644 sys/gio/cursor/grcinit.x create mode 100644 sys/gio/cursor/grcopen.x create mode 100644 sys/gio/cursor/grcpl.x create mode 100644 sys/gio/cursor/grcread.x create mode 100644 sys/gio/cursor/grcredraw.x create mode 100644 sys/gio/cursor/grcscr.x create mode 100644 sys/gio/cursor/grcstatus.x create mode 100644 sys/gio/cursor/grctext.x create mode 100644 sys/gio/cursor/grcwarn.x create mode 100644 sys/gio/cursor/grcwcs.x create mode 100644 sys/gio/cursor/grcwrite.x create mode 100644 sys/gio/cursor/gtr.com create mode 100644 sys/gio/cursor/gtr.h create mode 100644 sys/gio/cursor/gtrbackup.x create mode 100644 sys/gio/cursor/gtrconn.x create mode 100644 sys/gio/cursor/gtrctrl.x create mode 100644 sys/gio/cursor/gtrdelete.x create mode 100644 sys/gio/cursor/gtrdiscon.x create mode 100644 sys/gio/cursor/gtrfetch.x create mode 100644 sys/gio/cursor/gtrframe.x create mode 100644 sys/gio/cursor/gtrgflush.x create mode 100644 sys/gio/cursor/gtrgtran.x create mode 100644 sys/gio/cursor/gtrgtty.x create mode 100644 sys/gio/cursor/gtrinit.x create mode 100644 sys/gio/cursor/gtropenws.x create mode 100644 sys/gio/cursor/gtrpage.x create mode 100644 sys/gio/cursor/gtrptran.x create mode 100644 sys/gio/cursor/gtrrcur.x create mode 100644 sys/gio/cursor/gtrredraw.x create mode 100644 sys/gio/cursor/gtrreset.x create mode 100644 sys/gio/cursor/gtrset.x create mode 100644 sys/gio/cursor/gtrstatus.x create mode 100644 sys/gio/cursor/gtrtrunc.x create mode 100644 sys/gio/cursor/gtrundo.x create mode 100644 sys/gio/cursor/gtrwaitp.x create mode 100644 sys/gio/cursor/gtrwcur.x create mode 100644 sys/gio/cursor/gtrwritep.x create mode 100644 sys/gio/cursor/gtrwsclip.x create mode 100644 sys/gio/cursor/gtrwstran.x create mode 100644 sys/gio/cursor/mkpkg create mode 100644 sys/gio/cursor/prpsinit.x create mode 100644 sys/gio/cursor/rcursor.x create mode 100644 sys/gio/doc/gio.hlp create mode 100644 sys/gio/elogd.x create mode 100644 sys/gio/elogr.x create mode 100644 sys/gio/fonts/README create mode 100644 sys/gio/fonts/font.com create mode 100644 sys/gio/fonts/greek.com create mode 100644 sys/gio/fonts/greekc.txt create mode 100644 sys/gio/fonts/mkfont.c create mode 100644 sys/gio/fpequald.x create mode 100644 sys/gio/fpequalr.x create mode 100644 sys/gio/fpfixd.x create mode 100644 sys/gio/fpfixr.x create mode 100644 sys/gio/fpndgr.x create mode 100644 sys/gio/fpnormd.x create mode 100644 sys/gio/fpnormr.x create mode 100644 sys/gio/gactivate.x create mode 100644 sys/gio/gadraw.x create mode 100644 sys/gio/gamove.x create mode 100644 sys/gio/gascale.x create mode 100644 sys/gio/gcancel.x create mode 100644 sys/gio/gclear.x create mode 100644 sys/gio/gclose.x create mode 100644 sys/gio/gctran.x create mode 100644 sys/gio/gcurpos.x create mode 100644 sys/gio/gdeact.x create mode 100644 sys/gio/gescape.x create mode 100644 sys/gio/gfill.x create mode 100644 sys/gio/gflush.x create mode 100644 sys/gio/gframe.x create mode 100644 sys/gio/gfrinit.x create mode 100644 sys/gio/ggcell.x create mode 100644 sys/gio/ggcur.x create mode 100644 sys/gio/ggetb.x create mode 100644 sys/gio/ggeti.x create mode 100644 sys/gio/ggetr.x create mode 100644 sys/gio/ggets.x create mode 100644 sys/gio/ggscale.x create mode 100644 sys/gio/ggview.x create mode 100644 sys/gio/ggwind.x create mode 100644 sys/gio/gim/README create mode 100644 sys/gio/gim/gimcpras.x create mode 100644 sys/gio/gim/gimcrras.x create mode 100644 sys/gio/gim/gimderas.x create mode 100644 sys/gio/gim/gimdsmap.x create mode 100644 sys/gio/gim/gimenmap.x create mode 100644 sys/gio/gim/gimfcmap.x create mode 100644 sys/gio/gim/gimfmap.x create mode 100644 sys/gio/gim/gimgetmap.x create mode 100644 sys/gio/gim/gimimap.x create mode 100644 sys/gio/gim/gimlcmap.x create mode 100644 sys/gio/gim/gimqras.x create mode 100644 sys/gio/gim/gimrasini.x create mode 100644 sys/gio/gim/gimrcmap.x create mode 100644 sys/gio/gim/gimref.x create mode 100644 sys/gio/gim/gimrefpix.x create mode 100644 sys/gio/gim/gimriomap.x create mode 100644 sys/gio/gim/gimrpix.x create mode 100644 sys/gio/gim/gimsetmap.x create mode 100644 sys/gio/gim/gimsetpix.x create mode 100644 sys/gio/gim/gimsetras.x create mode 100644 sys/gio/gim/gimwcmap.x create mode 100644 sys/gio/gim/gimwiomap.x create mode 100644 sys/gio/gim/gimwpix.x create mode 100644 sys/gio/gim/mkpkg create mode 100644 sys/gio/gki/README create mode 100644 sys/gio/gki/gki.com create mode 100644 sys/gio/gki/gkicancel.x create mode 100644 sys/gio/gki/gkiclear.x create mode 100644 sys/gio/gki/gkiclose.x create mode 100644 sys/gio/gki/gkideact.x create mode 100644 sys/gio/gki/gkieof.x create mode 100644 sys/gio/gki/gkiesc.x create mode 100644 sys/gio/gki/gkiexe.x create mode 100644 sys/gio/gki/gkifa.x create mode 100644 sys/gio/gki/gkifaset.x create mode 100644 sys/gio/gki/gkifetch.x create mode 100644 sys/gio/gki/gkifflush.x create mode 100644 sys/gio/gki/gkiflush.x create mode 100644 sys/gio/gki/gkigca.x create mode 100644 sys/gio/gki/gkigcur.x create mode 100644 sys/gio/gki/gkigetwcs.x create mode 100644 sys/gio/gki/gkiinit.x create mode 100644 sys/gio/gki/gkiinline.x create mode 100644 sys/gio/gki/gkikern.x create mode 100644 sys/gio/gki/gkiopen.x create mode 100644 sys/gio/gki/gkipca.x create mode 100644 sys/gio/gki/gkipl.x create mode 100644 sys/gio/gki/gkiplset.x create mode 100644 sys/gio/gki/gkipm.x create mode 100644 sys/gio/gki/gkipmset.x create mode 100644 sys/gio/gki/gkiprint.x create mode 100644 sys/gio/gki/gkirca.x create mode 100644 sys/gio/gki/gkircval.x create mode 100644 sys/gio/gki/gkireact.x create mode 100644 sys/gio/gki/gkiredir.x create mode 100644 sys/gio/gki/gkiscur.x create mode 100644 sys/gio/gki/gkisetwcs.x create mode 100644 sys/gio/gki/gkititle.x create mode 100644 sys/gio/gki/gkitx.x create mode 100644 sys/gio/gki/gkitxset.x create mode 100644 sys/gio/gki/gkiwesc.x create mode 100644 sys/gio/gki/gkiwrite.x create mode 100644 sys/gio/gki/gkptxparg.x create mode 100644 sys/gio/gki/mkpkg create mode 100644 sys/gio/gki/zzdebug.x create mode 100644 sys/gio/gks/README create mode 100644 sys/gio/gks/gacwk.x create mode 100644 sys/gio/gks/gca.x create mode 100644 sys/gio/gks/gcas.x create mode 100644 sys/gio/gks/gclks.x create mode 100644 sys/gio/gks/gclrwk.x create mode 100644 sys/gio/gks/gclwk.x create mode 100644 sys/gio/gks/gdawk.x create mode 100644 sys/gio/gks/gfa.x create mode 100644 sys/gio/gks/gks.com create mode 100644 sys/gio/gks/gks.h create mode 100644 sys/gio/gks/gopks.x create mode 100644 sys/gio/gks/gopwk.x create mode 100644 sys/gio/gks/gpl.x create mode 100644 sys/gio/gks/gpm.x create mode 100644 sys/gio/gks/gqasf.x create mode 100644 sys/gio/gks/gqchh.x create mode 100644 sys/gio/gks/gqchup.x create mode 100644 sys/gio/gks/gqclip.x create mode 100644 sys/gio/gks/gqcntn.x create mode 100644 sys/gio/gks/gqmk.x create mode 100644 sys/gio/gks/gqnt.x create mode 100644 sys/gio/gks/gqopwk.x create mode 100644 sys/gio/gks/gqplci.x create mode 100644 sys/gio/gks/gqpmci.x create mode 100644 sys/gio/gks/gqpmi.x create mode 100644 sys/gio/gks/gqtxal.x create mode 100644 sys/gio/gks/gqtxci.x create mode 100644 sys/gio/gks/gqtxp.x create mode 100644 sys/gio/gks/gqwks.x create mode 100644 sys/gio/gks/gsasf.x create mode 100644 sys/gio/gks/gsaw.x create mode 100644 sys/gio/gks/gschh.x create mode 100644 sys/gio/gks/gschup.x create mode 100644 sys/gio/gks/gsclip.x create mode 100644 sys/gio/gks/gscr.x create mode 100644 sys/gio/gks/gselnt.x create mode 100644 sys/gio/gks/gsfaci.x create mode 100644 sys/gio/gks/gsfais.x create mode 100644 sys/gio/gks/gslwsc.x create mode 100644 sys/gio/gks/gsmk.x create mode 100644 sys/gio/gks/gsmksc.x create mode 100644 sys/gio/gks/gsplci.x create mode 100644 sys/gio/gks/gspmci.x create mode 100644 sys/gio/gks/gspmi.x create mode 100644 sys/gio/gks/gstxal.x create mode 100644 sys/gio/gks/gstxci.x create mode 100644 sys/gio/gks/gstxp.x create mode 100644 sys/gio/gks/gsvp.x create mode 100644 sys/gio/gks/gswn.x create mode 100644 sys/gio/gks/gtx.f create mode 100644 sys/gio/gks/gxgtx.x create mode 100644 sys/gio/gks/mkpkg create mode 100644 sys/gio/glabax/README create mode 100644 sys/gio/glabax/glabax.h create mode 100644 sys/gio/glabax/glabax.x create mode 100644 sys/gio/glabax/glbencode.x create mode 100644 sys/gio/glabax/glbfind.x create mode 100644 sys/gio/glabax/glbgrid.x create mode 100644 sys/gio/glabax/glbgtick.x create mode 100644 sys/gio/glabax/glblabel.x create mode 100644 sys/gio/glabax/glbloglab.x create mode 100644 sys/gio/glabax/glbsetax.x create mode 100644 sys/gio/glabax/glbsetup.x create mode 100644 sys/gio/glabax/glbsview.x create mode 100644 sys/gio/glabax/glbticlen.x create mode 100644 sys/gio/glabax/glbtitle.x create mode 100644 sys/gio/glabax/glbverify.x create mode 100644 sys/gio/glabax/mkpkg create mode 100644 sys/gio/gline.x create mode 100644 sys/gio/gmark.x create mode 100644 sys/gio/gmftitle.x create mode 100644 sys/gio/gmprintf.x create mode 100644 sys/gio/gmsg.x create mode 100644 sys/gio/gopen.x create mode 100644 sys/gio/gpagefile.x create mode 100644 sys/gio/gpcell.x create mode 100644 sys/gio/gpl.com create mode 100644 sys/gio/gplcache.x create mode 100644 sys/gio/gplcancel.x create mode 100644 sys/gio/gplflush.x create mode 100644 sys/gio/gpline.x create mode 100644 sys/gio/gploto.x create mode 100644 sys/gio/gplotv.x create mode 100644 sys/gio/gplreset.x create mode 100644 sys/gio/gplstype.x create mode 100644 sys/gio/gpmark.x create mode 100644 sys/gio/gqverify.x create mode 100644 sys/gio/grdraw.x create mode 100644 sys/gio/grdwcs.x create mode 100644 sys/gio/greact.x create mode 100644 sys/gio/greset.x create mode 100644 sys/gio/grmove.x create mode 100644 sys/gio/grscale.x create mode 100644 sys/gio/gscan.x create mode 100644 sys/gio/gscur.x create mode 100644 sys/gio/gseti.x create mode 100644 sys/gio/gsetr.x create mode 100644 sys/gio/gsets.x create mode 100644 sys/gio/gstati.x create mode 100644 sys/gio/gstatr.x create mode 100644 sys/gio/gstats.x create mode 100644 sys/gio/gsview.x create mode 100644 sys/gio/gswind.x create mode 100644 sys/gio/gtext.x create mode 100644 sys/gio/gtick.gx create mode 100644 sys/gio/gtickr.x create mode 100644 sys/gio/gtxset.x create mode 100644 sys/gio/gumark.x create mode 100644 sys/gio/gvline.x create mode 100644 sys/gio/gvmark.x create mode 100644 sys/gio/imdkern/README create mode 100644 sys/gio/imdkern/font.com create mode 100644 sys/gio/imdkern/font.h create mode 100644 sys/gio/imdkern/idk.com create mode 100644 sys/gio/imdkern/idk.x create mode 100644 sys/gio/imdkern/imd.com create mode 100644 sys/gio/imdkern/imd.h create mode 100644 sys/gio/imdkern/imdcancel.x create mode 100644 sys/gio/imdkern/imdclear.x create mode 100644 sys/gio/imdkern/imdclose.x create mode 100644 sys/gio/imdkern/imdclws.x create mode 100644 sys/gio/imdkern/imdcolor.x create mode 100644 sys/gio/imdkern/imddrawch.x create mode 100644 sys/gio/imdkern/imdescape.x create mode 100644 sys/gio/imdkern/imdfa.x create mode 100644 sys/gio/imdkern/imdfaset.x create mode 100644 sys/gio/imdkern/imdflush.x create mode 100644 sys/gio/imdkern/imdfont.x create mode 100644 sys/gio/imdkern/imdgcell.x create mode 100644 sys/gio/imdkern/imdinit.x create mode 100644 sys/gio/imdkern/imdline.x create mode 100644 sys/gio/imdkern/imdopen.x create mode 100644 sys/gio/imdkern/imdopenws.x create mode 100644 sys/gio/imdkern/imdpcell.x create mode 100644 sys/gio/imdkern/imdpl.x create mode 100644 sys/gio/imdkern/imdplset.x create mode 100644 sys/gio/imdkern/imdpm.x create mode 100644 sys/gio/imdkern/imdpmset.x create mode 100644 sys/gio/imdkern/imdreset.x create mode 100644 sys/gio/imdkern/imdtx.x create mode 100644 sys/gio/imdkern/imdtxset.x create mode 100644 sys/gio/imdkern/ltype.dat create mode 100644 sys/gio/imdkern/mkpkg create mode 100644 sys/gio/imdkern/t_imdkern.x create mode 100644 sys/gio/imdkern/x_imdkern.x create mode 100644 sys/gio/markers.inc create mode 100644 sys/gio/mkpkg create mode 100644 sys/gio/ncarutil/README create mode 100644 sys/gio/ncarutil/autograph/README create mode 100644 sys/gio/ncarutil/autograph/agaxis.f create mode 100644 sys/gio/ncarutil/autograph/agback.f create mode 100644 sys/gio/ncarutil/autograph/agbnch.f create mode 100644 sys/gio/ncarutil/autograph/agchax.f create mode 100644 sys/gio/ncarutil/autograph/agchcu.f create mode 100644 sys/gio/ncarutil/autograph/agchil.f create mode 100644 sys/gio/ncarutil/autograph/agchnl.f create mode 100644 sys/gio/ncarutil/autograph/agctcs.f create mode 100644 sys/gio/ncarutil/autograph/agctko.f create mode 100644 sys/gio/ncarutil/autograph/agcurv.f create mode 100644 sys/gio/ncarutil/autograph/agdash.f create mode 100644 sys/gio/ncarutil/autograph/agdflt.bd create mode 100644 sys/gio/ncarutil/autograph/agdflt.f create mode 100644 sys/gio/ncarutil/autograph/agdlch.f create mode 100644 sys/gio/ncarutil/autograph/agdshn.f create mode 100644 sys/gio/ncarutil/autograph/agexax.f create mode 100644 sys/gio/ncarutil/autograph/agexus.f create mode 100644 sys/gio/ncarutil/autograph/agezsu.f create mode 100644 sys/gio/ncarutil/autograph/agfpbn.f create mode 100644 sys/gio/ncarutil/autograph/agftol.f create mode 100644 sys/gio/ncarutil/autograph/aggetc.f create mode 100644 sys/gio/ncarutil/autograph/aggetf.f create mode 100644 sys/gio/ncarutil/autograph/aggeti.f create mode 100644 sys/gio/ncarutil/autograph/aggetp.f create mode 100644 sys/gio/ncarutil/autograph/aggtch.f create mode 100644 sys/gio/ncarutil/autograph/aginit.f create mode 100644 sys/gio/ncarutil/autograph/agkurv.f create mode 100644 sys/gio/ncarutil/autograph/aglbls.f create mode 100644 sys/gio/ncarutil/autograph/agmaxi.f create mode 100644 sys/gio/ncarutil/autograph/agmini.f create mode 100644 sys/gio/ncarutil/autograph/agnumb.f create mode 100644 sys/gio/ncarutil/autograph/agppid.f create mode 100644 sys/gio/ncarutil/autograph/agpwrt.f create mode 100644 sys/gio/ncarutil/autograph/agqurv.f create mode 100644 sys/gio/ncarutil/autograph/agrpch.f create mode 100644 sys/gio/ncarutil/autograph/agrstr.f create mode 100644 sys/gio/ncarutil/autograph/agsave.f create mode 100644 sys/gio/ncarutil/autograph/agscan.f create mode 100644 sys/gio/ncarutil/autograph/agsetc.f create mode 100644 sys/gio/ncarutil/autograph/agsetf.f create mode 100644 sys/gio/ncarutil/autograph/agseti.f create mode 100644 sys/gio/ncarutil/autograph/agsetp.f create mode 100644 sys/gio/ncarutil/autograph/agsrch.f create mode 100644 sys/gio/ncarutil/autograph/agstch.f create mode 100644 sys/gio/ncarutil/autograph/agstup.f create mode 100644 sys/gio/ncarutil/autograph/agutol.f create mode 100644 sys/gio/ncarutil/autograph/anotat.f create mode 100644 sys/gio/ncarutil/autograph/displa.f create mode 100644 sys/gio/ncarutil/autograph/ezmxy.f create mode 100644 sys/gio/ncarutil/autograph/ezmy.f create mode 100644 sys/gio/ncarutil/autograph/ezxy.f create mode 100644 sys/gio/ncarutil/autograph/ezy.f create mode 100644 sys/gio/ncarutil/autograph/idiot.f create mode 100644 sys/gio/ncarutil/autograph/mkpkg create mode 100644 sys/gio/ncarutil/autograph/pstr.x create mode 100644 sys/gio/ncarutil/conbd.f create mode 100644 sys/gio/ncarutil/conbdn.f create mode 100644 sys/gio/ncarutil/conlib/README create mode 100644 sys/gio/ncarutil/conlib/concal.f create mode 100644 sys/gio/ncarutil/conlib/concld.f create mode 100644 sys/gio/ncarutil/conlib/concls.f create mode 100644 sys/gio/ncarutil/conlib/concom.f create mode 100644 sys/gio/ncarutil/conlib/condet.f create mode 100644 sys/gio/ncarutil/conlib/condrw.f create mode 100644 sys/gio/ncarutil/conlib/condsd.f create mode 100644 sys/gio/ncarutil/conlib/conecd.f create mode 100644 sys/gio/ncarutil/conlib/congen.f create mode 100644 sys/gio/ncarutil/conlib/conint.f create mode 100644 sys/gio/ncarutil/conlib/conlcm.f create mode 100644 sys/gio/ncarutil/conlib/conlin.f create mode 100644 sys/gio/ncarutil/conlib/conloc.f create mode 100644 sys/gio/ncarutil/conlib/conlod.f create mode 100644 sys/gio/ncarutil/conlib/conop1.f create mode 100644 sys/gio/ncarutil/conlib/conop2.f create mode 100644 sys/gio/ncarutil/conlib/conop3.f create mode 100644 sys/gio/ncarutil/conlib/conop4.f create mode 100644 sys/gio/ncarutil/conlib/conot2.f create mode 100644 sys/gio/ncarutil/conlib/conout.f create mode 100644 sys/gio/ncarutil/conlib/conpdv.f create mode 100644 sys/gio/ncarutil/conlib/conreo.f create mode 100644 sys/gio/ncarutil/conlib/consld.f create mode 100644 sys/gio/ncarutil/conlib/conssd.f create mode 100644 sys/gio/ncarutil/conlib/constp.f create mode 100644 sys/gio/ncarutil/conlib/contlk.f create mode 100644 sys/gio/ncarutil/conlib/contng.f create mode 100644 sys/gio/ncarutil/conlib/conxch.f create mode 100644 sys/gio/ncarutil/conlib/mkpkg create mode 100644 sys/gio/ncarutil/conran.f create mode 100644 sys/gio/ncarutil/conrec.f create mode 100644 sys/gio/ncarutil/dashbd.f create mode 100644 sys/gio/ncarutil/dashsmth.f create mode 100644 sys/gio/ncarutil/ezmap.f create mode 100644 sys/gio/ncarutil/gridal.f create mode 100644 sys/gio/ncarutil/gridt.f create mode 100644 sys/gio/ncarutil/hafton.f create mode 100644 sys/gio/ncarutil/hfinit.f create mode 100644 sys/gio/ncarutil/isosrb.f create mode 100644 sys/gio/ncarutil/isosrf.f create mode 100644 sys/gio/ncarutil/kurv.f create mode 100644 sys/gio/ncarutil/mkpkg create mode 100644 sys/gio/ncarutil/pwrity.f create mode 100644 sys/gio/ncarutil/pwrzi.f create mode 100644 sys/gio/ncarutil/pwrzs.f create mode 100644 sys/gio/ncarutil/pwrzt.f create mode 100644 sys/gio/ncarutil/srfabd.f create mode 100644 sys/gio/ncarutil/srface.f create mode 100644 sys/gio/ncarutil/strmln.f create mode 100644 sys/gio/ncarutil/sysint/README create mode 100644 sys/gio/ncarutil/sysint/fencode.x create mode 100644 sys/gio/ncarutil/sysint/fulib.x create mode 100644 sys/gio/ncarutil/sysint/gbytes.x create mode 100644 sys/gio/ncarutil/sysint/ishift.x create mode 100644 sys/gio/ncarutil/sysint/mkpkg create mode 100644 sys/gio/ncarutil/sysint/sbytes.x create mode 100644 sys/gio/ncarutil/sysint/spps.f create mode 100644 sys/gio/ncarutil/sysint/support.f create mode 100644 sys/gio/ncarutil/tests/README create mode 100644 sys/gio/ncarutil/tests/auto10t.f create mode 100644 sys/gio/ncarutil/tests/autograph.x create mode 100644 sys/gio/ncarutil/tests/autographt.f create mode 100644 sys/gio/ncarutil/tests/conran.x create mode 100644 sys/gio/ncarutil/tests/conrant.f create mode 100644 sys/gio/ncarutil/tests/conraq.x create mode 100644 sys/gio/ncarutil/tests/conraqt.f create mode 100644 sys/gio/ncarutil/tests/conras.x create mode 100644 sys/gio/ncarutil/tests/conrast.f create mode 100644 sys/gio/ncarutil/tests/conrcqckt.f create mode 100644 sys/gio/ncarutil/tests/conrcsmtht.f create mode 100644 sys/gio/ncarutil/tests/conrcsprt.f create mode 100644 sys/gio/ncarutil/tests/conrec.x create mode 100644 sys/gio/ncarutil/tests/conrect.f create mode 100644 sys/gio/ncarutil/tests/dashchar.x create mode 100644 sys/gio/ncarutil/tests/dashchart.f create mode 100644 sys/gio/ncarutil/tests/dashlinet.f create mode 100644 sys/gio/ncarutil/tests/dashsmth.x create mode 100644 sys/gio/ncarutil/tests/dashsmtht.f create mode 100644 sys/gio/ncarutil/tests/dashsuprt.f create mode 100644 sys/gio/ncarutil/tests/ezconrec.x create mode 100644 sys/gio/ncarutil/tests/ezhafton.x create mode 100644 sys/gio/ncarutil/tests/ezhaftont.f create mode 100644 sys/gio/ncarutil/tests/ezisosrf.x create mode 100644 sys/gio/ncarutil/tests/ezmapg.x create mode 100644 sys/gio/ncarutil/tests/ezmapgt.f create mode 100644 sys/gio/ncarutil/tests/ezmapt.f create mode 100644 sys/gio/ncarutil/tests/ezsurface.x create mode 100644 sys/gio/ncarutil/tests/ezvelvect.x create mode 100644 sys/gio/ncarutil/tests/ezytst.x create mode 100644 sys/gio/ncarutil/tests/hafton.x create mode 100644 sys/gio/ncarutil/tests/haftont.f create mode 100644 sys/gio/ncarutil/tests/isosrf.x create mode 100644 sys/gio/ncarutil/tests/isosrfhrt.f create mode 100644 sys/gio/ncarutil/tests/isosrft.f create mode 100644 sys/gio/ncarutil/tests/mkpkg create mode 100644 sys/gio/ncarutil/tests/oldauto.x create mode 100644 sys/gio/ncarutil/tests/oldautot.f create mode 100644 sys/gio/ncarutil/tests/preal.x create mode 100644 sys/gio/ncarutil/tests/pwrity.x create mode 100644 sys/gio/ncarutil/tests/pwrityt.f create mode 100644 sys/gio/ncarutil/tests/pwrzit.f create mode 100644 sys/gio/ncarutil/tests/pwrzs.x create mode 100644 sys/gio/ncarutil/tests/pwrzst.f create mode 100644 sys/gio/ncarutil/tests/pwrztt.f create mode 100644 sys/gio/ncarutil/tests/srf.com create mode 100644 sys/gio/ncarutil/tests/srfacet.f create mode 100644 sys/gio/ncarutil/tests/srftest.x create mode 100644 sys/gio/ncarutil/tests/srftestd.x create mode 100644 sys/gio/ncarutil/tests/strmln.x create mode 100644 sys/gio/ncarutil/tests/strmlnt.f create mode 100644 sys/gio/ncarutil/tests/surface.x create mode 100644 sys/gio/ncarutil/tests/threed.x create mode 100644 sys/gio/ncarutil/tests/threed2.x create mode 100644 sys/gio/ncarutil/tests/threed2t.f create mode 100644 sys/gio/ncarutil/tests/threedt.f create mode 100644 sys/gio/ncarutil/tests/velvctt.f create mode 100644 sys/gio/ncarutil/tests/velvect.x create mode 100644 sys/gio/ncarutil/tests/x_ncartest.x create mode 100644 sys/gio/ncarutil/threbd.f create mode 100644 sys/gio/ncarutil/threed.f create mode 100644 sys/gio/ncarutil/veldat.f create mode 100644 sys/gio/ncarutil/velvct.f create mode 100644 sys/gio/nspp/README create mode 100644 sys/gio/nspp/mkpkg create mode 100644 sys/gio/nspp/portlib/README create mode 100644 sys/gio/nspp/portlib/axes.f create mode 100644 sys/gio/nspp/portlib/curve.f create mode 100644 sys/gio/nspp/portlib/dashln.f create mode 100644 sys/gio/nspp/portlib/fl2int.f create mode 100644 sys/gio/nspp/portlib/flash1.f create mode 100644 sys/gio/nspp/portlib/flash2.f create mode 100644 sys/gio/nspp/portlib/flash3.f create mode 100644 sys/gio/nspp/portlib/flash4.f create mode 100644 sys/gio/nspp/portlib/flush.f create mode 100644 sys/gio/nspp/portlib/flushb.f create mode 100644 sys/gio/nspp/portlib/frame.f create mode 100644 sys/gio/nspp/portlib/frstpt.f create mode 100644 sys/gio/nspp/portlib/getopt.f create mode 100644 sys/gio/nspp/portlib/getset.f create mode 100644 sys/gio/nspp/portlib/getsi.f create mode 100644 sys/gio/nspp/portlib/grid.f create mode 100644 sys/gio/nspp/portlib/gridal.f create mode 100644 sys/gio/nspp/portlib/gridl.f create mode 100644 sys/gio/nspp/portlib/halfax.f create mode 100644 sys/gio/nspp/portlib/jlm2.f create mode 100644 sys/gio/nspp/portlib/justfy.f create mode 100644 sys/gio/nspp/portlib/labmod.f create mode 100644 sys/gio/nspp/portlib/line.f create mode 100644 sys/gio/nspp/portlib/mkpkg create mode 100644 sys/gio/nspp/portlib/mxmy.f create mode 100644 sys/gio/nspp/portlib/option.f create mode 100644 sys/gio/nspp/portlib/optn.f create mode 100644 sys/gio/nspp/portlib/perim.f create mode 100644 sys/gio/nspp/portlib/periml.f create mode 100644 sys/gio/nspp/portlib/plotit.f create mode 100644 sys/gio/nspp/portlib/point.f create mode 100644 sys/gio/nspp/portlib/points.f create mode 100644 sys/gio/nspp/portlib/porgn.f create mode 100644 sys/gio/nspp/portlib/preout.f create mode 100644 sys/gio/nspp/portlib/pscale.f create mode 100644 sys/gio/nspp/portlib/psym.f create mode 100644 sys/gio/nspp/portlib/put42.f create mode 100644 sys/gio/nspp/portlib/putins.f create mode 100644 sys/gio/nspp/portlib/pwrit.f create mode 100644 sys/gio/nspp/portlib/pwrt.f create mode 100644 sys/gio/nspp/portlib/set.f create mode 100644 sys/gio/nspp/portlib/seti.f create mode 100644 sys/gio/nspp/portlib/tick4.f create mode 100644 sys/gio/nspp/portlib/ticks.f create mode 100644 sys/gio/nspp/portlib/trans.f create mode 100644 sys/gio/nspp/portlib/vector.f create mode 100644 sys/gio/nspp/portlib/z8zpbd.f create mode 100644 sys/gio/nspp/portlib/z8zpii.f create mode 100644 sys/gio/nspp/sysint/README create mode 100644 sys/gio/nspp/sysint/encd.f create mode 100644 sys/gio/nspp/sysint/encode.f create mode 100644 sys/gio/nspp/sysint/erprt77.f create mode 100644 sys/gio/nspp/sysint/fencode.x create mode 100644 sys/gio/nspp/sysint/fulib.x create mode 100644 sys/gio/nspp/sysint/intt.x create mode 100644 sys/gio/nspp/sysint/ishift.x create mode 100644 sys/gio/nspp/sysint/loc.x create mode 100644 sys/gio/nspp/sysint/mcswap.x create mode 100644 sys/gio/nspp/sysint/mkpkg create mode 100644 sys/gio/nspp/sysint/ncgchr.x create mode 100644 sys/gio/nspp/sysint/ncpchr.x create mode 100644 sys/gio/nspp/sysint/nspp.com create mode 100644 sys/gio/nspp/sysint/packum.x create mode 100644 sys/gio/nspp/sysint/perror.x create mode 100644 sys/gio/nspp/sysint/q8qst4.f create mode 100644 sys/gio/nspp/sysint/uliber.f create mode 100644 sys/gio/nsppkern/README create mode 100644 sys/gio/nsppkern/font.com create mode 100644 sys/gio/nsppkern/font.h create mode 100644 sys/gio/nsppkern/gkt.com create mode 100644 sys/gio/nsppkern/gkt.h create mode 100644 sys/gio/nsppkern/gktcancel.x create mode 100644 sys/gio/nsppkern/gktclear.x create mode 100644 sys/gio/nsppkern/gktclose.x create mode 100644 sys/gio/nsppkern/gktclws.x create mode 100644 sys/gio/nsppkern/gktcolor.x create mode 100644 sys/gio/nsppkern/gktdrawch.x create mode 100644 sys/gio/nsppkern/gktescape.x create mode 100644 sys/gio/nsppkern/gktfa.x create mode 100644 sys/gio/nsppkern/gktfaset.x create mode 100644 sys/gio/nsppkern/gktflush.x create mode 100644 sys/gio/nsppkern/gktfont.x create mode 100644 sys/gio/nsppkern/gktgcell.x create mode 100644 sys/gio/nsppkern/gktinit.x create mode 100644 sys/gio/nsppkern/gktline.x create mode 100644 sys/gio/nsppkern/gktmfopen.x create mode 100644 sys/gio/nsppkern/gktopen.x create mode 100644 sys/gio/nsppkern/gktopenws.x create mode 100644 sys/gio/nsppkern/gktpcell.x create mode 100644 sys/gio/nsppkern/gktpl.x create mode 100644 sys/gio/nsppkern/gktplset.x create mode 100644 sys/gio/nsppkern/gktpm.x create mode 100644 sys/gio/nsppkern/gktpmset.x create mode 100644 sys/gio/nsppkern/gktreset.x create mode 100644 sys/gio/nsppkern/gkttx.x create mode 100644 sys/gio/nsppkern/gkttxset.x create mode 100644 sys/gio/nsppkern/mkpkg create mode 100644 sys/gio/nsppkern/nspp.com create mode 100644 sys/gio/nsppkern/pixel0.f create mode 100644 sys/gio/nsppkern/pixels.f create mode 100644 sys/gio/nsppkern/t_nsppkern.x create mode 100644 sys/gio/nsppkern/tran16.f create mode 100644 sys/gio/nsppkern/writeb.x create mode 100644 sys/gio/nsppkern/x_nsppkern.x create mode 100644 sys/gio/nsppkern/zzdebug.x create mode 100644 sys/gio/sgikern/README create mode 100644 sys/gio/sgikern/font.com create mode 100644 sys/gio/sgikern/font.h create mode 100644 sys/gio/sgikern/greek.com create mode 100644 sys/gio/sgikern/ltype.dat create mode 100644 sys/gio/sgikern/mkpkg create mode 100644 sys/gio/sgikern/sgi.com create mode 100644 sys/gio/sgikern/sgi.h create mode 100644 sys/gio/sgikern/sgicancel.x create mode 100644 sys/gio/sgikern/sgiclear.x create mode 100644 sys/gio/sgikern/sgiclose.x create mode 100644 sys/gio/sgikern/sgiclws.x create mode 100644 sys/gio/sgikern/sgicolor.x create mode 100644 sys/gio/sgikern/sgidrawch.x create mode 100644 sys/gio/sgikern/sgiescape.x create mode 100644 sys/gio/sgikern/sgifa.x create mode 100644 sys/gio/sgikern/sgifaset.x create mode 100644 sys/gio/sgikern/sgiflush.x create mode 100644 sys/gio/sgikern/sgifont.x create mode 100644 sys/gio/sgikern/sgigcell.x create mode 100644 sys/gio/sgikern/sgiinit.x create mode 100644 sys/gio/sgikern/sgiline.x create mode 100644 sys/gio/sgikern/sgiopen.x create mode 100644 sys/gio/sgikern/sgiopenws.x create mode 100644 sys/gio/sgikern/sgipcell.x create mode 100644 sys/gio/sgikern/sgipl.x create mode 100644 sys/gio/sgikern/sgiplset.x create mode 100644 sys/gio/sgikern/sgipm.x create mode 100644 sys/gio/sgikern/sgipmset.x create mode 100644 sys/gio/sgikern/sgireset.x create mode 100644 sys/gio/sgikern/sgitx.x create mode 100644 sys/gio/sgikern/sgitxset.x create mode 100644 sys/gio/sgikern/sgk.com create mode 100644 sys/gio/sgikern/sgk.h create mode 100644 sys/gio/sgikern/sgk.x create mode 100644 sys/gio/sgikern/t_sgideco.x create mode 100644 sys/gio/sgikern/t_sgikern.x create mode 100644 sys/gio/sgikern/x_sgikern.x create mode 100644 sys/gio/stdgraph/README create mode 100644 sys/gio/stdgraph/font.com create mode 100644 sys/gio/stdgraph/font.h create mode 100644 sys/gio/stdgraph/mkpkg create mode 100644 sys/gio/stdgraph/stdgraph.com create mode 100644 sys/gio/stdgraph/stdgraph.h create mode 100644 sys/gio/stdgraph/stgcancel.x create mode 100644 sys/gio/stdgraph/stgclear.x create mode 100644 sys/gio/stdgraph/stgclose.x create mode 100644 sys/gio/stdgraph/stgclws.x create mode 100644 sys/gio/stdgraph/stgctrl.x create mode 100644 sys/gio/stdgraph/stgdeact.x create mode 100644 sys/gio/stdgraph/stgdraw.x create mode 100644 sys/gio/stdgraph/stgdrawch.x create mode 100644 sys/gio/stdgraph/stgencode.x create mode 100644 sys/gio/stdgraph/stgescape.x create mode 100644 sys/gio/stdgraph/stgfa.x create mode 100644 sys/gio/stdgraph/stgfaset.x create mode 100644 sys/gio/stdgraph/stgfilter.x create mode 100644 sys/gio/stdgraph/stgflush.x create mode 100644 sys/gio/stdgraph/stggcell.x create mode 100644 sys/gio/stdgraph/stggcur.x create mode 100644 sys/gio/stdgraph/stggdisab.x create mode 100644 sys/gio/stdgraph/stggenab.x create mode 100644 sys/gio/stdgraph/stggim.x create mode 100644 sys/gio/stdgraph/stggrstr.x create mode 100644 sys/gio/stdgraph/stginit.x create mode 100644 sys/gio/stdgraph/stglkcur.x create mode 100644 sys/gio/stdgraph/stgmove.x create mode 100644 sys/gio/stdgraph/stgonerr.x create mode 100644 sys/gio/stdgraph/stgonint.x create mode 100644 sys/gio/stdgraph/stgopen.x create mode 100644 sys/gio/stdgraph/stgopenws.x create mode 100644 sys/gio/stdgraph/stgoutput.x create mode 100644 sys/gio/stdgraph/stgoutstr.x create mode 100644 sys/gio/stdgraph/stgpcell.x create mode 100644 sys/gio/stdgraph/stgpl.x create mode 100644 sys/gio/stdgraph/stgplset.x create mode 100644 sys/gio/stdgraph/stgpm.x create mode 100644 sys/gio/stdgraph/stgpmset.x create mode 100644 sys/gio/stdgraph/stgrcur.x create mode 100644 sys/gio/stdgraph/stgreact.x create mode 100644 sys/gio/stdgraph/stgres.x create mode 100644 sys/gio/stdgraph/stgreset.x create mode 100644 sys/gio/stdgraph/stgrtty.x create mode 100644 sys/gio/stdgraph/stgscur.x create mode 100644 sys/gio/stdgraph/stgtx.x create mode 100644 sys/gio/stdgraph/stgtxqual.x create mode 100644 sys/gio/stdgraph/stgtxset.x create mode 100644 sys/gio/stdgraph/stgtxsize.x create mode 100644 sys/gio/stdgraph/stgunkown.x create mode 100644 sys/gio/stdgraph/stgwtty.x create mode 100644 sys/gio/stdgraph/t_gkideco.x create mode 100644 sys/gio/stdgraph/t_showcap.x create mode 100644 sys/gio/stdgraph/t_stdgraph.x create mode 100644 sys/gio/stdgraph/x_stdgraph.x create mode 100644 sys/gio/stdgraph/zzdebug.x create mode 100644 sys/gio/wcstogki.x create mode 100644 sys/gio/zzdebug.x create mode 100644 sys/gty/README create mode 100644 sys/gty/gty.h create mode 100644 sys/gty/gtycaps.x create mode 100644 sys/gty/gtyclose.x create mode 100644 sys/gty/gtygetb.x create mode 100644 sys/gty/gtygeti.x create mode 100644 sys/gty/gtygetr.x create mode 100644 sys/gty/gtygets.x create mode 100644 sys/gty/gtyindex.x create mode 100644 sys/gty/gtyopen.x create mode 100644 sys/gty/mkpkg create mode 100644 sys/gty/zzdebug.x create mode 100644 sys/imfort/README create mode 100644 sys/imfort/bfio.x create mode 100644 sys/imfort/clargs.x create mode 100644 sys/imfort/db/README create mode 100644 sys/imfort/db/idb.h create mode 100644 sys/imfort/db/idbfind.x create mode 100644 sys/imfort/db/idbgstr.x create mode 100644 sys/imfort/db/idbkwlu.x create mode 100644 sys/imfort/db/idbnaxis.x create mode 100644 sys/imfort/db/idbpstr.x create mode 100644 sys/imfort/db/imaccf.x create mode 100644 sys/imfort/db/imaddb.x create mode 100644 sys/imfort/db/imaddd.x create mode 100644 sys/imfort/db/imaddf.x create mode 100644 sys/imfort/db/imaddi.x create mode 100644 sys/imfort/db/imaddl.x create mode 100644 sys/imfort/db/imaddr.x create mode 100644 sys/imfort/db/imadds.x create mode 100644 sys/imfort/db/imastr.x create mode 100644 sys/imfort/db/imdelf.x create mode 100644 sys/imfort/db/imgatr.x create mode 100644 sys/imfort/db/imgetb.x create mode 100644 sys/imfort/db/imgetc.x create mode 100644 sys/imfort/db/imgetd.x create mode 100644 sys/imfort/db/imgeti.x create mode 100644 sys/imfort/db/imgetl.x create mode 100644 sys/imfort/db/imgetr.x create mode 100644 sys/imfort/db/imgets.x create mode 100644 sys/imfort/db/imgftype.x create mode 100644 sys/imfort/db/imgnfn.x create mode 100644 sys/imfort/db/imgstr.x create mode 100644 sys/imfort/db/impstr.x create mode 100644 sys/imfort/db/imputb.x create mode 100644 sys/imfort/db/imputd.x create mode 100644 sys/imfort/db/imputi.x create mode 100644 sys/imfort/db/imputl.x create mode 100644 sys/imfort/db/imputr.x create mode 100644 sys/imfort/db/imputs.x create mode 100644 sys/imfort/db/mkpkg create mode 100644 sys/imfort/doc/TODO create mode 100644 sys/imfort/doc/bfaloc.hlp create mode 100644 sys/imfort/doc/bfbsiz.hlp create mode 100644 sys/imfort/doc/bfchan.hlp create mode 100644 sys/imfort/doc/bfclos.hlp create mode 100644 sys/imfort/doc/bfflsh.hlp create mode 100644 sys/imfort/doc/bffsiz.hlp create mode 100644 sys/imfort/doc/bfopen.hlp create mode 100644 sys/imfort/doc/bfread.hlp create mode 100644 sys/imfort/doc/bfwrit.hlp create mode 100644 sys/imfort/doc/clarg.hlp create mode 100644 sys/imfort/doc/clnarg.hlp create mode 100644 sys/imfort/doc/clrawc.hlp create mode 100644 sys/imfort/doc/imacck.hlp create mode 100644 sys/imfort/doc/imaddk.hlp create mode 100644 sys/imfort/doc/imakw.hlp create mode 100644 sys/imfort/doc/imclos.hlp create mode 100644 sys/imfort/doc/imcrea.hlp create mode 100644 sys/imfort/doc/imdele.hlp create mode 100644 sys/imfort/doc/imdelk.hlp create mode 100644 sys/imfort/doc/imemsg.hlp create mode 100644 sys/imfort/doc/imflsh.hlp create mode 100644 sys/imfort/doc/imfort.hd create mode 100644 sys/imfort/doc/imfort.ms create mode 100644 sys/imfort/doc/imfort.toc create mode 100644 sys/imfort/doc/imgkw.hlp create mode 100644 sys/imfort/doc/imgl.hlp create mode 100644 sys/imfort/doc/imgs.hlp create mode 100644 sys/imfort/doc/imgsiz.hlp create mode 100644 sys/imfort/doc/imhcpy.hlp create mode 100644 sys/imfort/doc/imokwl.hlp create mode 100644 sys/imfort/doc/imopen.hlp create mode 100644 sys/imfort/doc/imopnc.hlp create mode 100644 sys/imfort/doc/impixf.hlp create mode 100644 sys/imfort/doc/impkw.hlp create mode 100644 sys/imfort/doc/impl.hlp create mode 100644 sys/imfort/doc/imps.hlp create mode 100644 sys/imfort/doc/imrnam.hlp create mode 100644 sys/imfort/doc/imtypk.hlp create mode 100644 sys/imfort/imacck.x create mode 100644 sys/imfort/imaddk.x create mode 100644 sys/imfort/imakwb.x create mode 100644 sys/imfort/imakwc.x create mode 100644 sys/imfort/imakwd.x create mode 100644 sys/imfort/imakwi.x create mode 100644 sys/imfort/imakwr.x create mode 100644 sys/imfort/imclos.x create mode 100644 sys/imfort/imcrea.x create mode 100644 sys/imfort/imcrex.x create mode 100644 sys/imfort/imdele.x create mode 100644 sys/imfort/imdelk.x create mode 100644 sys/imfort/imdelx.x create mode 100644 sys/imfort/imemsg.x create mode 100644 sys/imfort/imfdir.x create mode 100644 sys/imfort/imfgpfn.x create mode 100644 sys/imfort/imflsh.x create mode 100644 sys/imfort/imfmkpfn.x create mode 100644 sys/imfort/imfort.h create mode 100644 sys/imfort/imfparse.x create mode 100644 sys/imfort/imftrans.x create mode 100644 sys/imfort/imfupdhdr.x create mode 100644 sys/imfort/imgkwb.x create mode 100644 sys/imfort/imgkwc.x create mode 100644 sys/imfort/imgkwd.x create mode 100644 sys/imfort/imgkwi.x create mode 100644 sys/imfort/imgkwr.x create mode 100644 sys/imfort/imgl1r.x create mode 100644 sys/imfort/imgl1s.x create mode 100644 sys/imfort/imgl2r.x create mode 100644 sys/imfort/imgl2s.x create mode 100644 sys/imfort/imgl3r.x create mode 100644 sys/imfort/imgl3s.x create mode 100644 sys/imfort/imgs1r.x create mode 100644 sys/imfort/imgs1s.x create mode 100644 sys/imfort/imgs2r.x create mode 100644 sys/imfort/imgs2s.x create mode 100644 sys/imfort/imgs3r.x create mode 100644 sys/imfort/imgs3s.x create mode 100644 sys/imfort/imgsiz.x create mode 100644 sys/imfort/imhcpy.x create mode 100644 sys/imfort/imhv1.h create mode 100644 sys/imfort/imhv2.h create mode 100644 sys/imfort/imioff.x create mode 100644 sys/imfort/imokwl.x create mode 100644 sys/imfort/imopen.x create mode 100644 sys/imfort/imopnc.x create mode 100644 sys/imfort/imopnx.x create mode 100644 sys/imfort/impixf.x create mode 100644 sys/imfort/impkwb.x create mode 100644 sys/imfort/impkwc.x create mode 100644 sys/imfort/impkwd.x create mode 100644 sys/imfort/impkwi.x create mode 100644 sys/imfort/impkwr.x create mode 100644 sys/imfort/impl1r.x create mode 100644 sys/imfort/impl1s.x create mode 100644 sys/imfort/impl2r.x create mode 100644 sys/imfort/impl2s.x create mode 100644 sys/imfort/impl3r.x create mode 100644 sys/imfort/impl3s.x create mode 100644 sys/imfort/imps1r.x create mode 100644 sys/imfort/imps1s.x create mode 100644 sys/imfort/imps2r.x create mode 100644 sys/imfort/imps2s.x create mode 100644 sys/imfort/imps3r.x create mode 100644 sys/imfort/imps3s.x create mode 100644 sys/imfort/imrdhdr.x create mode 100644 sys/imfort/imrnam.x create mode 100644 sys/imfort/imswap.x create mode 100644 sys/imfort/imtypk.x create mode 100644 sys/imfort/imwpix.x create mode 100644 sys/imfort/imwrhdr.x create mode 100644 sys/imfort/mii.x create mode 100644 sys/imfort/mkpkg create mode 100644 sys/imfort/oif.h create mode 100644 sys/imfort/tasks/README create mode 100644 sys/imfort/tasks/args.f create mode 100644 sys/imfort/tasks/hello.f create mode 100644 sys/imfort/tasks/imcopy.f create mode 100644 sys/imfort/tasks/imdel.f create mode 100644 sys/imfort/tasks/imren.f create mode 100644 sys/imfort/tasks/keyw.f create mode 100644 sys/imfort/tasks/minmax.f create mode 100644 sys/imfort/tasks/mkim.f create mode 100644 sys/imfort/tasks/pcube.f create mode 100644 sys/imfort/tasks/phead.f create mode 100644 sys/imfort/tasks/planck.f create mode 100644 sys/imfort/tasks/readim.f create mode 100644 sys/imfort/tasks/tasks.unix create mode 100644 sys/imfort/tasks/tasks.vms create mode 100644 sys/imio/README create mode 100644 sys/imio/db/README create mode 100644 sys/imio/db/idb.h create mode 100644 sys/imio/db/idbcard.x create mode 100644 sys/imio/db/idbfind.x create mode 100644 sys/imio/db/idbfstr.x create mode 100644 sys/imio/db/idbgstr.x create mode 100644 sys/imio/db/idbkwlu.x create mode 100644 sys/imio/db/idbpstr.x create mode 100644 sys/imio/db/imaccf.x create mode 100644 sys/imio/db/imaddb.x create mode 100644 sys/imio/db/imaddd.x create mode 100644 sys/imio/db/imaddf.x create mode 100644 sys/imio/db/imaddi.x create mode 100644 sys/imio/db/imaddl.x create mode 100644 sys/imio/db/imaddr.x create mode 100644 sys/imio/db/imadds.x create mode 100644 sys/imio/db/imastr.x create mode 100644 sys/imio/db/imdelf.x create mode 100644 sys/imio/db/imgetb.x create mode 100644 sys/imio/db/imgetc.x create mode 100644 sys/imio/db/imgetd.x create mode 100644 sys/imio/db/imgeti.x create mode 100644 sys/imio/db/imgetl.x create mode 100644 sys/imio/db/imgetr.x create mode 100644 sys/imio/db/imgets.x create mode 100644 sys/imio/db/imgftype.x create mode 100644 sys/imio/db/imgnfn.x create mode 100644 sys/imio/db/imgstr.x create mode 100644 sys/imio/db/impstr.x create mode 100644 sys/imio/db/imputb.x create mode 100644 sys/imio/db/imputd.x create mode 100644 sys/imio/db/imputh.x create mode 100644 sys/imio/db/imputi.x create mode 100644 sys/imio/db/imputl.x create mode 100644 sys/imio/db/imputr.x create mode 100644 sys/imio/db/imputs.x create mode 100644 sys/imio/db/imrenf.x create mode 100644 sys/imio/db/mkpkg create mode 100644 sys/imio/dbc/README create mode 100644 sys/imio/dbc/idbc.h create mode 100644 sys/imio/dbc/imakbc.x create mode 100644 sys/imio/dbc/imakbci.x create mode 100644 sys/imio/dbc/imakdc.x create mode 100644 sys/imio/dbc/imakdci.x create mode 100644 sys/imio/dbc/imakic.x create mode 100644 sys/imio/dbc/imakici.x create mode 100644 sys/imio/dbc/imaklc.x create mode 100644 sys/imio/dbc/imaklci.x create mode 100644 sys/imio/dbc/imakrc.x create mode 100644 sys/imio/dbc/imakrci.x create mode 100644 sys/imio/dbc/imaksc.x create mode 100644 sys/imio/dbc/imaksci.x create mode 100644 sys/imio/dbc/imastrc.x create mode 100644 sys/imio/dbc/imastrci.x create mode 100644 sys/imio/dbc/imdrmcom.x create mode 100644 sys/imio/dbc/imgcom.x create mode 100644 sys/imio/dbc/iminfi.x create mode 100644 sys/imio/dbc/impcom.x create mode 100644 sys/imio/dbc/impkbc.x create mode 100644 sys/imio/dbc/impkdc.x create mode 100644 sys/imio/dbc/impkic.x create mode 100644 sys/imio/dbc/impklc.x create mode 100644 sys/imio/dbc/impkrc.x create mode 100644 sys/imio/dbc/impksc.x create mode 100644 sys/imio/dbc/impstrc.x create mode 100644 sys/imio/dbc/imputextf.x create mode 100644 sys/imio/dbc/imputhi.x create mode 100644 sys/imio/dbc/mkpkg create mode 100644 sys/imio/doc/IMH.hlp create mode 100644 sys/imio/doc/Notes create mode 100644 sys/imio/doc/bench.ms create mode 100644 sys/imio/doc/imfort.doc create mode 100644 sys/imio/doc/imio.2.ms create mode 100644 sys/imio/doc/imio.doc create mode 100644 sys/imio/doc/imio.hlp create mode 100644 sys/imio/doc/imio.ms create mode 100644 sys/imio/iki/README create mode 100644 sys/imio/iki/fxf/Notes create mode 100644 sys/imio/iki/fxf/README create mode 100644 sys/imio/iki/fxf/fxf.h create mode 100644 sys/imio/iki/fxf/fxfaccess.x create mode 100644 sys/imio/iki/fxf/fxfaddpar.x create mode 100644 sys/imio/iki/fxf/fxfcache.com create mode 100644 sys/imio/iki/fxf/fxfclose.x create mode 100644 sys/imio/iki/fxf/fxfcopy.x create mode 100644 sys/imio/iki/fxf/fxfctype.x create mode 100644 sys/imio/iki/fxf/fxfdelete.x create mode 100644 sys/imio/iki/fxf/fxfencode.x create mode 100644 sys/imio/iki/fxf/fxfexpandh.x create mode 100644 sys/imio/iki/fxf/fxfget.x create mode 100644 sys/imio/iki/fxf/fxfhextn.x create mode 100644 sys/imio/iki/fxf/fxfksection.x create mode 100644 sys/imio/iki/fxf/fxfmkcard.x create mode 100644 sys/imio/iki/fxf/fxfnull.x create mode 100644 sys/imio/iki/fxf/fxfopen.x create mode 100644 sys/imio/iki/fxf/fxfopix.x create mode 100644 sys/imio/iki/fxf/fxfpak.x create mode 100644 sys/imio/iki/fxf/fxfplread.x create mode 100644 sys/imio/iki/fxf/fxfplwrite.x create mode 100644 sys/imio/iki/fxf/fxfrcard.x create mode 100644 sys/imio/iki/fxf/fxfrdhdr.x create mode 100644 sys/imio/iki/fxf/fxfrename.x create mode 100644 sys/imio/iki/fxf/fxfrfits.x create mode 100644 sys/imio/iki/fxf/fxfupdhdr.x create mode 100644 sys/imio/iki/fxf/fxfupk.x create mode 100644 sys/imio/iki/fxf/mkpkg create mode 100644 sys/imio/iki/fxf/zfiofxf.x create mode 100644 sys/imio/iki/iki.com create mode 100644 sys/imio/iki/iki.h create mode 100644 sys/imio/iki/ikiaccess.x create mode 100644 sys/imio/iki/ikiclose.x create mode 100644 sys/imio/iki/ikicopy.x create mode 100644 sys/imio/iki/ikidelete.x create mode 100644 sys/imio/iki/ikiextn.x create mode 100644 sys/imio/iki/ikiinit.x create mode 100644 sys/imio/iki/ikildd.x create mode 100644 sys/imio/iki/ikimkfn.x create mode 100644 sys/imio/iki/ikiopen.x create mode 100644 sys/imio/iki/ikiopix.x create mode 100644 sys/imio/iki/ikiparse.x create mode 100644 sys/imio/iki/ikirename.x create mode 100644 sys/imio/iki/ikiupdhdr.x create mode 100644 sys/imio/iki/mkpkg create mode 100644 sys/imio/iki/oif/README create mode 100644 sys/imio/iki/oif/imhv1.h create mode 100644 sys/imio/iki/oif/imhv2.h create mode 100644 sys/imio/iki/oif/mkpkg create mode 100644 sys/imio/iki/oif/oif.h create mode 100644 sys/imio/iki/oif/oifaccess.x create mode 100644 sys/imio/iki/oif/oifclose.x create mode 100644 sys/imio/iki/oif/oifcopy.x create mode 100644 sys/imio/iki/oif/oifdelete.x create mode 100644 sys/imio/iki/oif/oifgpfn.x create mode 100644 sys/imio/iki/oif/oifmkpfn.x create mode 100644 sys/imio/iki/oif/oifopen.x create mode 100644 sys/imio/iki/oif/oifopix.x create mode 100644 sys/imio/iki/oif/oifrdhdr.x create mode 100644 sys/imio/iki/oif/oifrename.x create mode 100644 sys/imio/iki/oif/oifupdhdr.x create mode 100644 sys/imio/iki/oif/oifwrhdr.x create mode 100644 sys/imio/iki/plf/README create mode 100644 sys/imio/iki/plf/mkpkg create mode 100644 sys/imio/iki/plf/plf.h create mode 100644 sys/imio/iki/plf/plfaccess.x create mode 100644 sys/imio/iki/plf/plfclose.x create mode 100644 sys/imio/iki/plf/plfcopy.x create mode 100644 sys/imio/iki/plf/plfdelete.x create mode 100644 sys/imio/iki/plf/plfnull.x create mode 100644 sys/imio/iki/plf/plfopen.x create mode 100644 sys/imio/iki/plf/plfrename.x create mode 100644 sys/imio/iki/plf/plfupdhdr.x create mode 100644 sys/imio/iki/qpf/README create mode 100644 sys/imio/iki/qpf/mkpkg create mode 100644 sys/imio/iki/qpf/qpf.h create mode 100644 sys/imio/iki/qpf/qpfaccess.x create mode 100644 sys/imio/iki/qpf/qpfclose.x create mode 100644 sys/imio/iki/qpf/qpfcopy.x create mode 100644 sys/imio/iki/qpf/qpfcopypar.x create mode 100644 sys/imio/iki/qpf/qpfdelete.x create mode 100644 sys/imio/iki/qpf/qpfopen.x create mode 100644 sys/imio/iki/qpf/qpfopix.x create mode 100644 sys/imio/iki/qpf/qpfrename.x create mode 100644 sys/imio/iki/qpf/qpfupdhdr.x create mode 100644 sys/imio/iki/qpf/qpfwattr.x create mode 100644 sys/imio/iki/qpf/qpfwfilter.x create mode 100644 sys/imio/iki/qpf/zfioqp.x create mode 100644 sys/imio/iki/stf/README create mode 100644 sys/imio/iki/stf/mkpkg create mode 100644 sys/imio/iki/stf/stf.h create mode 100644 sys/imio/iki/stf/stfaccess.x create mode 100644 sys/imio/iki/stf/stfaddpar.x create mode 100644 sys/imio/iki/stf/stfclose.x create mode 100644 sys/imio/iki/stf/stfcopy.x create mode 100644 sys/imio/iki/stf/stfcopyf.x create mode 100644 sys/imio/iki/stf/stfctype.x create mode 100644 sys/imio/iki/stf/stfdelete.x create mode 100644 sys/imio/iki/stf/stfget.x create mode 100644 sys/imio/iki/stf/stfhextn.x create mode 100644 sys/imio/iki/stf/stfiwcs.x create mode 100644 sys/imio/iki/stf/stfmerge.x create mode 100644 sys/imio/iki/stf/stfmkpfn.x create mode 100644 sys/imio/iki/stf/stfnewim.x create mode 100644 sys/imio/iki/stf/stfopen.x create mode 100644 sys/imio/iki/stf/stfopix.x create mode 100644 sys/imio/iki/stf/stfordgpb.x create mode 100644 sys/imio/iki/stf/stfrdhdr.x create mode 100644 sys/imio/iki/stf/stfreblk.x create mode 100644 sys/imio/iki/stf/stfrename.x create mode 100644 sys/imio/iki/stf/stfrfits.x create mode 100644 sys/imio/iki/stf/stfrgpb.x create mode 100644 sys/imio/iki/stf/stfupdhdr.x create mode 100644 sys/imio/iki/stf/stfwfits.x create mode 100644 sys/imio/iki/stf/stfwgpb.x create mode 100644 sys/imio/imaccess.x create mode 100644 sys/imio/imaflp.x create mode 100644 sys/imio/imaplv.x create mode 100644 sys/imio/imbln1.x create mode 100644 sys/imio/imbln2.x create mode 100644 sys/imio/imbln3.x create mode 100644 sys/imio/imbtran.x create mode 100644 sys/imio/imcopy.x create mode 100644 sys/imio/imcssz.x create mode 100644 sys/imio/imdelete.x create mode 100644 sys/imio/imdmap.x create mode 100644 sys/imio/imerr.x create mode 100644 sys/imio/imfls.gx create mode 100644 sys/imio/imflsh.x create mode 100644 sys/imio/imflush.x create mode 100644 sys/imio/imgclust.x create mode 100644 sys/imio/imggs.gx create mode 100644 sys/imio/imggsc.x create mode 100644 sys/imio/imgibf.x create mode 100644 sys/imio/imgimage.x create mode 100644 sys/imio/imgl1.gx create mode 100644 sys/imio/imgl2.gx create mode 100644 sys/imio/imgl3.gx create mode 100644 sys/imio/imgnl.gx create mode 100644 sys/imio/imgnln.x create mode 100644 sys/imio/imgobf.x create mode 100644 sys/imio/imgs1.gx create mode 100644 sys/imio/imgs2.gx create mode 100644 sys/imio/imgs3.gx create mode 100644 sys/imio/imgsect.x create mode 100644 sys/imio/iminie.x create mode 100644 sys/imio/imioff.x create mode 100644 sys/imio/imisec.x create mode 100644 sys/imio/imloop.x create mode 100644 sys/imio/immaky.x create mode 100644 sys/imio/immap.x create mode 100644 sys/imio/immapz.x create mode 100644 sys/imio/imnote.x create mode 100644 sys/imio/imopsf.x create mode 100644 sys/imio/impak.gx create mode 100644 sys/imio/imparse.x create mode 100644 sys/imio/impgs.gx create mode 100644 sys/imio/impl1.gx create mode 100644 sys/imio/impl2.gx create mode 100644 sys/imio/impl3.gx create mode 100644 sys/imio/impmhdr.x create mode 100644 sys/imio/impmlne1.x create mode 100644 sys/imio/impmlne2.x create mode 100644 sys/imio/impmlne3.x create mode 100644 sys/imio/impmlnev.x create mode 100644 sys/imio/impmmap.x create mode 100644 sys/imio/impmmapo.x create mode 100644 sys/imio/impmopen.x create mode 100644 sys/imio/impmsne1.x create mode 100644 sys/imio/impmsne2.x create mode 100644 sys/imio/impmsne3.x create mode 100644 sys/imio/impmsnev.x create mode 100644 sys/imio/impnl.gx create mode 100644 sys/imio/impnln.x create mode 100644 sys/imio/imps1.gx create mode 100644 sys/imio/imps2.gx create mode 100644 sys/imio/imps3.gx create mode 100644 sys/imio/imrbpx.x create mode 100644 sys/imio/imrdpx.x create mode 100644 sys/imio/imrename.x create mode 100644 sys/imio/imrmbufs.x create mode 100644 sys/imio/imsamp.x create mode 100644 sys/imio/imsetbuf.x create mode 100644 sys/imio/imseti.x create mode 100644 sys/imio/imsetr.x create mode 100644 sys/imio/imsinb.x create mode 100644 sys/imio/imsslv.x create mode 100644 sys/imio/imstati.x create mode 100644 sys/imio/imstatr.x create mode 100644 sys/imio/imstats.x create mode 100644 sys/imio/imt.x create mode 100644 sys/imio/imt/README create mode 100644 sys/imio/imt/fxf.h create mode 100644 sys/imio/imt/imt.x create mode 100644 sys/imio/imt/imx.h create mode 100644 sys/imio/imt/imx.x create mode 100644 sys/imio/imt/imxbreakout.x create mode 100644 sys/imio/imt/imxescape.x create mode 100644 sys/imio/imt/imxexpand.x create mode 100644 sys/imio/imt/imxexpr.x create mode 100644 sys/imio/imt/imxftype.x create mode 100644 sys/imio/imt/imxparse.x create mode 100644 sys/imio/imt/imxpreproc.x create mode 100644 sys/imio/imt/mkpkg create mode 100644 sys/imio/imt/t_urlget.x create mode 100644 sys/imio/imt/zzdebug.x create mode 100644 sys/imio/imunmap.x create mode 100644 sys/imio/imupk.gx create mode 100644 sys/imio/imwbpx.x create mode 100644 sys/imio/imwrite.x create mode 100644 sys/imio/imwrpx.x create mode 100644 sys/imio/mkpkg create mode 100644 sys/imio/tf/imflsd.x create mode 100644 sys/imio/tf/imflsi.x create mode 100644 sys/imio/tf/imflsl.x create mode 100644 sys/imio/tf/imflsr.x create mode 100644 sys/imio/tf/imflss.x create mode 100644 sys/imio/tf/imflsx.x create mode 100644 sys/imio/tf/imggsd.x create mode 100644 sys/imio/tf/imggsi.x create mode 100644 sys/imio/tf/imggsl.x create mode 100644 sys/imio/tf/imggsr.x create mode 100644 sys/imio/tf/imggss.x create mode 100644 sys/imio/tf/imggsx.x create mode 100644 sys/imio/tf/imgl1d.x create mode 100644 sys/imio/tf/imgl1i.x create mode 100644 sys/imio/tf/imgl1l.x create mode 100644 sys/imio/tf/imgl1r.x create mode 100644 sys/imio/tf/imgl1s.x create mode 100644 sys/imio/tf/imgl1x.x create mode 100644 sys/imio/tf/imgl2d.x create mode 100644 sys/imio/tf/imgl2i.x create mode 100644 sys/imio/tf/imgl2l.x create mode 100644 sys/imio/tf/imgl2r.x create mode 100644 sys/imio/tf/imgl2s.x create mode 100644 sys/imio/tf/imgl2x.x create mode 100644 sys/imio/tf/imgl3d.x create mode 100644 sys/imio/tf/imgl3i.x create mode 100644 sys/imio/tf/imgl3l.x create mode 100644 sys/imio/tf/imgl3r.x create mode 100644 sys/imio/tf/imgl3s.x create mode 100644 sys/imio/tf/imgl3x.x create mode 100644 sys/imio/tf/imgnld.x create mode 100644 sys/imio/tf/imgnli.x create mode 100644 sys/imio/tf/imgnll.x create mode 100644 sys/imio/tf/imgnlr.x create mode 100644 sys/imio/tf/imgnls.x create mode 100644 sys/imio/tf/imgnlx.x create mode 100644 sys/imio/tf/imgs1d.x create mode 100644 sys/imio/tf/imgs1i.x create mode 100644 sys/imio/tf/imgs1l.x create mode 100644 sys/imio/tf/imgs1r.x create mode 100644 sys/imio/tf/imgs1s.x create mode 100644 sys/imio/tf/imgs1x.x create mode 100644 sys/imio/tf/imgs2d.x create mode 100644 sys/imio/tf/imgs2i.x create mode 100644 sys/imio/tf/imgs2l.x create mode 100644 sys/imio/tf/imgs2r.x create mode 100644 sys/imio/tf/imgs2s.x create mode 100644 sys/imio/tf/imgs2x.x create mode 100644 sys/imio/tf/imgs3d.x create mode 100644 sys/imio/tf/imgs3i.x create mode 100644 sys/imio/tf/imgs3l.x create mode 100644 sys/imio/tf/imgs3r.x create mode 100644 sys/imio/tf/imgs3s.x create mode 100644 sys/imio/tf/imgs3x.x create mode 100644 sys/imio/tf/impakd.x create mode 100644 sys/imio/tf/impaki.x create mode 100644 sys/imio/tf/impakl.x create mode 100644 sys/imio/tf/impakr.x create mode 100644 sys/imio/tf/impaks.x create mode 100644 sys/imio/tf/impakx.x create mode 100644 sys/imio/tf/impgsd.x create mode 100644 sys/imio/tf/impgsi.x create mode 100644 sys/imio/tf/impgsl.x create mode 100644 sys/imio/tf/impgsr.x create mode 100644 sys/imio/tf/impgss.x create mode 100644 sys/imio/tf/impgsx.x create mode 100644 sys/imio/tf/impl1d.x create mode 100644 sys/imio/tf/impl1i.x create mode 100644 sys/imio/tf/impl1l.x create mode 100644 sys/imio/tf/impl1r.x create mode 100644 sys/imio/tf/impl1s.x create mode 100644 sys/imio/tf/impl1x.x create mode 100644 sys/imio/tf/impl2d.x create mode 100644 sys/imio/tf/impl2i.x create mode 100644 sys/imio/tf/impl2l.x create mode 100644 sys/imio/tf/impl2r.x create mode 100644 sys/imio/tf/impl2s.x create mode 100644 sys/imio/tf/impl2x.x create mode 100644 sys/imio/tf/impl3d.x create mode 100644 sys/imio/tf/impl3i.x create mode 100644 sys/imio/tf/impl3l.x create mode 100644 sys/imio/tf/impl3r.x create mode 100644 sys/imio/tf/impl3s.x create mode 100644 sys/imio/tf/impl3x.x create mode 100644 sys/imio/tf/impnld.x create mode 100644 sys/imio/tf/impnli.x create mode 100644 sys/imio/tf/impnll.x create mode 100644 sys/imio/tf/impnlr.x create mode 100644 sys/imio/tf/impnls.x create mode 100644 sys/imio/tf/impnlx.x create mode 100644 sys/imio/tf/imps1d.x create mode 100644 sys/imio/tf/imps1i.x create mode 100644 sys/imio/tf/imps1l.x create mode 100644 sys/imio/tf/imps1r.x create mode 100644 sys/imio/tf/imps1s.x create mode 100644 sys/imio/tf/imps1x.x create mode 100644 sys/imio/tf/imps2d.x create mode 100644 sys/imio/tf/imps2i.x create mode 100644 sys/imio/tf/imps2l.x create mode 100644 sys/imio/tf/imps2r.x create mode 100644 sys/imio/tf/imps2s.x create mode 100644 sys/imio/tf/imps2x.x create mode 100644 sys/imio/tf/imps3d.x create mode 100644 sys/imio/tf/imps3i.x create mode 100644 sys/imio/tf/imps3l.x create mode 100644 sys/imio/tf/imps3r.x create mode 100644 sys/imio/tf/imps3s.x create mode 100644 sys/imio/tf/imps3x.x create mode 100644 sys/imio/tf/imupkd.x create mode 100644 sys/imio/tf/imupki.x create mode 100644 sys/imio/tf/imupkl.x create mode 100644 sys/imio/tf/imupkr.x create mode 100644 sys/imio/tf/imupks.x create mode 100644 sys/imio/tf/imupkx.x create mode 100644 sys/imio/tf/mkpkg create mode 100644 sys/imio/zzdebug.x create mode 100644 sys/ki/README create mode 100644 sys/ki/irafks.x create mode 100644 sys/ki/kbzard.x create mode 100644 sys/ki/kbzawr.x create mode 100644 sys/ki/kbzawt.x create mode 100644 sys/ki/kbzcls.x create mode 100644 sys/ki/kbzopn.x create mode 100644 sys/ki/kbzstt.x create mode 100644 sys/ki/kclcpr.x create mode 100644 sys/ki/kcldir.x create mode 100644 sys/ki/kcldpr.x create mode 100644 sys/ki/kdvall.x create mode 100644 sys/ki/kdvown.x create mode 100644 sys/ki/kfacss.x create mode 100644 sys/ki/kfaloc.x create mode 100644 sys/ki/kfchdr.x create mode 100644 sys/ki/kfdele.x create mode 100644 sys/ki/kfgcwd.x create mode 100644 sys/ki/kfinfo.x create mode 100644 sys/ki/kfiobf.x create mode 100644 sys/ki/kfiogd.x create mode 100644 sys/ki/kfiolp.x create mode 100644 sys/ki/kfiopl.x create mode 100644 sys/ki/kfiopr.x create mode 100644 sys/ki/kfiosf.x create mode 100644 sys/ki/kfiotx.x create mode 100644 sys/ki/kfioty.x create mode 100644 sys/ki/kfmkcp.x create mode 100644 sys/ki/kfmkdr.x create mode 100644 sys/ki/kfpath.x create mode 100644 sys/ki/kfprot.x create mode 100644 sys/ki/kfrmdr.x create mode 100644 sys/ki/kfrnam.x create mode 100644 sys/ki/kfsubd.x create mode 100644 sys/ki/kfutim.x create mode 100644 sys/ki/kfxdir.x create mode 100644 sys/ki/kgfdir.x create mode 100644 sys/ki/ki.h create mode 100644 sys/ki/kichan.com create mode 100644 sys/ki/kiconnect.x create mode 100644 sys/ki/kiencode.x create mode 100644 sys/ki/kienvreset.x create mode 100644 sys/ki/kierror.x create mode 100644 sys/ki/kiextnode.x create mode 100644 sys/ki/kifchan.x create mode 100644 sys/ki/kifmapfn.x create mode 100644 sys/ki/kifndnode.x create mode 100644 sys/ki/kigchan.x create mode 100644 sys/ki/kighost.x create mode 100644 sys/ki/kignode.x create mode 100644 sys/ki/kii.com create mode 100644 sys/ki/kiinit.x create mode 100644 sys/ki/kilnode.x create mode 100644 sys/ki/kimapchan.x create mode 100644 sys/ki/kimapname.x create mode 100644 sys/ki/kinode.com create mode 100644 sys/ki/kintpr.x create mode 100644 sys/ki/kiopenks.x create mode 100644 sys/ki/kireceive.x create mode 100644 sys/ki/kisend.x create mode 100644 sys/ki/kisendrcv.x create mode 100644 sys/ki/kishownet.x create mode 100644 sys/ki/kixnode.x create mode 100644 sys/ki/kopcpr.x create mode 100644 sys/ki/kopdir.x create mode 100644 sys/ki/kopdpr.x create mode 100644 sys/ki/koscmd.x create mode 100644 sys/ki/ksaread.x create mode 100644 sys/ki/ksawait.x create mode 100644 sys/ki/ksawrite.x create mode 100644 sys/ki/ktzcls.x create mode 100644 sys/ki/ktzfls.x create mode 100644 sys/ki/ktzget.x create mode 100644 sys/ki/ktznot.x create mode 100644 sys/ki/ktzopn.x create mode 100644 sys/ki/ktzput.x create mode 100644 sys/ki/ktzsek.x create mode 100644 sys/ki/ktzstt.x create mode 100644 sys/ki/kzclmt.x create mode 100644 sys/ki/kzopmt.x create mode 100644 sys/ki/kzrdmt.x create mode 100644 sys/ki/kzrwmt.x create mode 100644 sys/ki/kzstmt.x create mode 100644 sys/ki/kzwrmt.x create mode 100644 sys/ki/kzwtmt.x create mode 100644 sys/ki/mkpkg create mode 100644 sys/ki/zzdebug.x create mode 100644 sys/ki/zzrdks.c create mode 100644 sys/libc/Libc.hlp create mode 100644 sys/libc/README create mode 100644 sys/libc/atof.c create mode 100644 sys/libc/atoi.c create mode 100644 sys/libc/atol.c create mode 100644 sys/libc/caccess.c create mode 100644 sys/libc/calloc.c create mode 100644 sys/libc/callocate.c create mode 100644 sys/libc/cclktime.c create mode 100644 sys/libc/cclose.c create mode 100644 sys/libc/ccnvdate.c create mode 100644 sys/libc/ccnvtime.c create mode 100644 sys/libc/cdelete.c create mode 100644 sys/libc/cenvget.c create mode 100644 sys/libc/cenvlist.c create mode 100644 sys/libc/cenvmark.c create mode 100644 sys/libc/cenvscan.c create mode 100644 sys/libc/cerract.c create mode 100644 sys/libc/cerrcode.c create mode 100644 sys/libc/cerrget.c create mode 100644 sys/libc/cerror.c create mode 100644 sys/libc/cfchdir.c create mode 100644 sys/libc/cfilbuf.c create mode 100644 sys/libc/cfinfo.c create mode 100644 sys/libc/cflsbuf.c create mode 100644 sys/libc/cflush.c create mode 100644 sys/libc/cfmapfn.c create mode 100644 sys/libc/cfmkdir.c create mode 100644 sys/libc/cfnextn.c create mode 100644 sys/libc/cfnldir.c create mode 100644 sys/libc/cfnroot.c create mode 100644 sys/libc/cfpath.c create mode 100644 sys/libc/cfredir.c create mode 100644 sys/libc/cfseti.c create mode 100644 sys/libc/cfstati.c create mode 100644 sys/libc/cgetpid.c create mode 100644 sys/libc/cgetuid.c create mode 100644 sys/libc/cgflush.c create mode 100644 sys/libc/cimaccess.c create mode 100644 sys/libc/cimdrcur.c create mode 100644 sys/libc/ckimapc.c create mode 100644 sys/libc/clexnum.c create mode 100644 sys/libc/cmktemp.c create mode 100644 sys/libc/cndopen.c create mode 100644 sys/libc/cnote.c create mode 100644 sys/libc/copen.c create mode 100644 sys/libc/coscmd.c create mode 100644 sys/libc/cpoll.c create mode 100644 sys/libc/cprcon.c create mode 100644 sys/libc/cprdet.c create mode 100644 sys/libc/cprintf.c create mode 100644 sys/libc/crcursor.c create mode 100644 sys/libc/crdukey.c create mode 100644 sys/libc/cread.c create mode 100644 sys/libc/crename.c create mode 100644 sys/libc/creopen.c create mode 100644 sys/libc/csalloc.c create mode 100644 sys/libc/cseek.c create mode 100644 sys/libc/csppstr.c create mode 100644 sys/libc/cstropen.c create mode 100644 sys/libc/cstrpak.c create mode 100644 sys/libc/cstrupk.c create mode 100644 sys/libc/ctsleep.c create mode 100644 sys/libc/cttset.c create mode 100644 sys/libc/cttycdes.c create mode 100644 sys/libc/cttyclear.c create mode 100644 sys/libc/cttyclln.c create mode 100644 sys/libc/cttyctrl.c create mode 100644 sys/libc/cttygetb.c create mode 100644 sys/libc/cttygeti.c create mode 100644 sys/libc/cttygetr.c create mode 100644 sys/libc/cttygets.c create mode 100644 sys/libc/cttygoto.c create mode 100644 sys/libc/cttyinit.c create mode 100644 sys/libc/cttyodes.c create mode 100644 sys/libc/cttyputl.c create mode 100644 sys/libc/cttyputs.c create mode 100644 sys/libc/cttyseti.c create mode 100644 sys/libc/cttyso.c create mode 100644 sys/libc/cttystati.c create mode 100644 sys/libc/ctype.c create mode 100644 sys/libc/cungetc.c create mode 100644 sys/libc/cungetl.c create mode 100644 sys/libc/cvfnbrk.c create mode 100644 sys/libc/cwmsec.c create mode 100644 sys/libc/cwrite.c create mode 100644 sys/libc/cxgmes.c create mode 100644 sys/libc/cxonerr.c create mode 100644 sys/libc/cxttysize.c create mode 100644 sys/libc/cxwhen.c create mode 100644 sys/libc/eprintf.c create mode 100644 sys/libc/fclose.c create mode 100644 sys/libc/fdopen.c create mode 100644 sys/libc/fflush.c create mode 100644 sys/libc/fgetc.c create mode 100644 sys/libc/fgets.c create mode 100644 sys/libc/fopen.c create mode 100644 sys/libc/fputc.c create mode 100644 sys/libc/fputs.c create mode 100644 sys/libc/fread.c create mode 100644 sys/libc/freadline.c create mode 100644 sys/libc/free.c create mode 100644 sys/libc/freopen.c create mode 100644 sys/libc/fseek.c create mode 100644 sys/libc/ftell.c create mode 100644 sys/libc/fwrite.c create mode 100644 sys/libc/gets.c create mode 100644 sys/libc/getw.c create mode 100644 sys/libc/index.c create mode 100644 sys/libc/isatty.c create mode 100644 sys/libc/libc_proto.h create mode 100644 sys/libc/malloc.c create mode 100644 sys/libc/mathf.f create mode 100644 sys/libc/mkpkg create mode 100644 sys/libc/mktemp.c create mode 100644 sys/libc/perror.c create mode 100644 sys/libc/printf.c create mode 100644 sys/libc/puts.c create mode 100644 sys/libc/putw.c create mode 100644 sys/libc/qsort.c create mode 100644 sys/libc/realloc.c create mode 100644 sys/libc/rewind.c create mode 100644 sys/libc/rindex.c create mode 100644 sys/libc/scanf.c create mode 100644 sys/libc/setbuf.c create mode 100644 sys/libc/spf.c create mode 100644 sys/libc/sprintf.c create mode 100644 sys/libc/stgio.c create mode 100644 sys/libc/strcat.c create mode 100644 sys/libc/strcmp.c create mode 100644 sys/libc/strcpy.c create mode 100644 sys/libc/strdup.c create mode 100644 sys/libc/strlen.c create mode 100644 sys/libc/strncat.c create mode 100644 sys/libc/strncmp.c create mode 100644 sys/libc/strncpy.c create mode 100644 sys/libc/system.c create mode 100644 sys/libc/ungetc.c create mode 100644 sys/libc/zzdebug.x create mode 100644 sys/libc/zztest.c create mode 100644 sys/memdbg/README create mode 100644 sys/memdbg/begmem.x create mode 100644 sys/memdbg/calloc.x create mode 100644 sys/memdbg/coerce.x create mode 100644 sys/memdbg/kmalloc.x create mode 100644 sys/memdbg/krealloc.x create mode 100644 sys/memdbg/malloc.x create mode 100644 sys/memdbg/malloc1.x create mode 100644 sys/memdbg/memdbg.com create mode 100644 sys/memdbg/memlog.c create mode 100644 sys/memdbg/mfree.x create mode 100644 sys/memdbg/mgdptr.x create mode 100644 sys/memdbg/mgtfwa.x create mode 100644 sys/memdbg/mkpkg create mode 100644 sys/memdbg/msvfwa.x create mode 100644 sys/memdbg/realloc.x create mode 100644 sys/memdbg/salloc.x create mode 100644 sys/memdbg/sizeof.x create mode 100644 sys/memdbg/vmalloc.x create mode 100644 sys/memdbg/zrtadr.c create mode 100644 sys/memdbg/zzdebug.x create mode 100644 sys/memio/README create mode 100644 sys/memio/begmem.x create mode 100644 sys/memio/calloc.x create mode 100644 sys/memio/coerce.x create mode 100644 sys/memio/doc/memio.hlp create mode 100644 sys/memio/kmalloc.x create mode 100644 sys/memio/krealloc.x create mode 100644 sys/memio/malloc.x create mode 100644 sys/memio/malloc1.x create mode 100644 sys/memio/mfree.x create mode 100644 sys/memio/mgdptr.x create mode 100644 sys/memio/mgtfwa.x create mode 100644 sys/memio/mkpkg create mode 100644 sys/memio/msvfwa.x create mode 100644 sys/memio/realloc.x create mode 100644 sys/memio/salloc.x create mode 100644 sys/memio/sizeof.x create mode 100644 sys/memio/vmalloc.x create mode 100644 sys/memio/zzdebug.c create mode 100644 sys/memio/zzdebug.x create mode 100644 sys/mkpkg create mode 100644 sys/mtio/README create mode 100644 sys/mtio/doc/mtio.hlp create mode 100644 sys/mtio/doc/newdriver.notes create mode 100644 sys/mtio/mkpkg create mode 100644 sys/mtio/mtalloc.x create mode 100644 sys/mtio/mtcache.com create mode 100644 sys/mtio/mtcache.x create mode 100644 sys/mtio/mtcap.x create mode 100644 sys/mtio/mtclean.x create mode 100644 sys/mtio/mtdealloc.x create mode 100644 sys/mtio/mtdevall.x create mode 100644 sys/mtio/mtencode.x create mode 100644 sys/mtio/mtfile.x create mode 100644 sys/mtio/mtfname.x create mode 100644 sys/mtio/mtglock.x create mode 100644 sys/mtio/mtgtyopen.x create mode 100644 sys/mtio/mtio.com create mode 100644 sys/mtio/mtio.h create mode 100644 sys/mtio/mtlocknam.x create mode 100644 sys/mtio/mtneedf.x create mode 100644 sys/mtio/mtopen.x create mode 100644 sys/mtio/mtparse.x create mode 100644 sys/mtio/mtpos.x create mode 100644 sys/mtio/mtrdlock.x create mode 100644 sys/mtio/mtrewind.x create mode 100644 sys/mtio/mtskip.x create mode 100644 sys/mtio/mtstatus.x create mode 100644 sys/mtio/mtupdlock.x create mode 100644 sys/mtio/zardmt.x create mode 100644 sys/mtio/zawrmt.x create mode 100644 sys/mtio/zawtmt.x create mode 100644 sys/mtio/zclsmt.x create mode 100644 sys/mtio/zopnmt.x create mode 100644 sys/mtio/zsttmt.x create mode 100644 sys/mtio/zzdebug.x create mode 100644 sys/mwcs/MWCS.hlp create mode 100644 sys/mwcs/README create mode 100644 sys/mwcs/gen/mkpkg create mode 100644 sys/mwcs/gen/mwc1trand.x create mode 100644 sys/mwcs/gen/mwc1tranr.x create mode 100644 sys/mwcs/gen/mwc2trand.x create mode 100644 sys/mwcs/gen/mwc2tranr.x create mode 100644 sys/mwcs/gen/mwctrand.x create mode 100644 sys/mwcs/gen/mwctranr.x create mode 100644 sys/mwcs/gen/mwgctrand.x create mode 100644 sys/mwcs/gen/mwgctranr.x create mode 100644 sys/mwcs/gen/mwltrand.x create mode 100644 sys/mwcs/gen/mwltranr.x create mode 100644 sys/mwcs/gen/mwmmuld.x create mode 100644 sys/mwcs/gen/mwmmulr.x create mode 100644 sys/mwcs/gen/mwv1trand.x create mode 100644 sys/mwcs/gen/mwv1tranr.x create mode 100644 sys/mwcs/gen/mwv2trand.x create mode 100644 sys/mwcs/gen/mwv2tranr.x create mode 100644 sys/mwcs/gen/mwvmuld.x create mode 100644 sys/mwcs/gen/mwvmulr.x create mode 100644 sys/mwcs/gen/mwvtrand.x create mode 100644 sys/mwcs/gen/mwvtranr.x create mode 100644 sys/mwcs/imwcs.h create mode 100644 sys/mwcs/iwcfits.x create mode 100644 sys/mwcs/iwctype.x create mode 100644 sys/mwcs/iwewcs.x create mode 100644 sys/mwcs/iwfind.x create mode 100644 sys/mwcs/iwgbfits.x create mode 100644 sys/mwcs/iwparray.x create mode 100644 sys/mwcs/iwpstr.x create mode 100644 sys/mwcs/iwrfits.x create mode 100644 sys/mwcs/iwsaxmap.x create mode 100644 sys/mwcs/mkpkg create mode 100644 sys/mwcs/mwallocd.x create mode 100644 sys/mwcs/mwallocs.x create mode 100644 sys/mwcs/mwc1tran.gx create mode 100644 sys/mwcs/mwc2tran.gx create mode 100644 sys/mwcs/mwclose.x create mode 100644 sys/mwcs/mwcs.com create mode 100644 sys/mwcs/mwcs.h create mode 100644 sys/mwcs/mwctfree.x create mode 100644 sys/mwcs/mwctran.gx create mode 100644 sys/mwcs/mwfindsys.x create mode 100644 sys/mwcs/mwflookup.x create mode 100644 sys/mwcs/mwgaxlist.x create mode 100644 sys/mwcs/mwgaxmap.x create mode 100644 sys/mwcs/mwgctran.gx create mode 100644 sys/mwcs/mwgltermd.x create mode 100644 sys/mwcs/mwgltermr.x create mode 100644 sys/mwcs/mwgsys.x create mode 100644 sys/mwcs/mwgwattrs.x create mode 100644 sys/mwcs/mwgwsampd.x create mode 100644 sys/mwcs/mwgwsampr.x create mode 100644 sys/mwcs/mwgwtermd.x create mode 100644 sys/mwcs/mwgwtermr.x create mode 100644 sys/mwcs/mwinvertd.x create mode 100644 sys/mwcs/mwinvertr.x create mode 100644 sys/mwcs/mwload.x create mode 100644 sys/mwcs/mwloadim.x create mode 100644 sys/mwcs/mwltran.gx create mode 100644 sys/mwcs/mwlu.x create mode 100644 sys/mwcs/mwmkidmd.x create mode 100644 sys/mwcs/mwmkidmr.x create mode 100644 sys/mwcs/mwmmul.gx create mode 100644 sys/mwcs/mwnewcopy.x create mode 100644 sys/mwcs/mwnewsys.x create mode 100644 sys/mwcs/mwopen.x create mode 100644 sys/mwcs/mwopenim.x create mode 100644 sys/mwcs/mwrefstr.x create mode 100644 sys/mwcs/mwrotate.x create mode 100644 sys/mwcs/mwsave.x create mode 100644 sys/mwcs/mwsaveim.x create mode 100644 sys/mwcs/mwsaxmap.x create mode 100644 sys/mwcs/mwscale.x create mode 100644 sys/mwcs/mwsctran.x create mode 100644 sys/mwcs/mwsdefwcs.x create mode 100644 sys/mwcs/mwseti.x create mode 100644 sys/mwcs/mwshift.x create mode 100644 sys/mwcs/mwshow.x create mode 100644 sys/mwcs/mwsltermd.x create mode 100644 sys/mwcs/mwsltermr.x create mode 100644 sys/mwcs/mwssys.x create mode 100644 sys/mwcs/mwstati.x create mode 100644 sys/mwcs/mwsv.h create mode 100644 sys/mwcs/mwswattrs.x create mode 100644 sys/mwcs/mwswsampd.x create mode 100644 sys/mwcs/mwswsampr.x create mode 100644 sys/mwcs/mwswtermd.x create mode 100644 sys/mwcs/mwswtermr.x create mode 100644 sys/mwcs/mwswtype.x create mode 100644 sys/mwcs/mwtransd.x create mode 100644 sys/mwcs/mwtransr.x create mode 100644 sys/mwcs/mwv1tran.gx create mode 100644 sys/mwcs/mwv2tran.gx create mode 100644 sys/mwcs/mwvmul.gx create mode 100644 sys/mwcs/mwvtran.gx create mode 100644 sys/mwcs/wfait.x create mode 100644 sys/mwcs/wfarc.x create mode 100644 sys/mwcs/wfcar.x create mode 100644 sys/mwcs/wfcsc.x create mode 100644 sys/mwcs/wfdecaxis.x create mode 100644 sys/mwcs/wfgls.x create mode 100644 sys/mwcs/wfgsurfit.x create mode 100644 sys/mwcs/wfinit.x create mode 100644 sys/mwcs/wfmer.x create mode 100644 sys/mwcs/wfmol.x create mode 100644 sys/mwcs/wfmspec.x create mode 100644 sys/mwcs/wfpar.x create mode 100644 sys/mwcs/wfpco.x create mode 100644 sys/mwcs/wfqsc.x create mode 100644 sys/mwcs/wfsamp.x create mode 100644 sys/mwcs/wfsin.x create mode 100644 sys/mwcs/wfstg.x create mode 100644 sys/mwcs/wftan.x create mode 100644 sys/mwcs/wftnx.x create mode 100644 sys/mwcs/wftpv.x create mode 100644 sys/mwcs/wftsc.x create mode 100644 sys/mwcs/wfzea.x create mode 100644 sys/mwcs/wfzpn.x create mode 100644 sys/mwcs/wfzpx.x create mode 100644 sys/mwcs/zzdebug.x create mode 100644 sys/nmemio/README create mode 100644 sys/nmemio/begmem.x create mode 100644 sys/nmemio/calloc.x create mode 100644 sys/nmemio/coerce.x create mode 100644 sys/nmemio/doc/memio.hlp create mode 100644 sys/nmemio/kmalloc.x create mode 100644 sys/nmemio/krealloc.x create mode 100644 sys/nmemio/main.x create mode 100644 sys/nmemio/malloc.x create mode 100644 sys/nmemio/malloc1.x create mode 100644 sys/nmemio/merror.x create mode 100644 sys/nmemio/mfini.x create mode 100644 sys/nmemio/mfree.x create mode 100644 sys/nmemio/mgc.x create mode 100644 sys/nmemio/mgdptr.x create mode 100644 sys/nmemio/mgtfwa.x create mode 100644 sys/nmemio/mgtlwl.x create mode 100644 sys/nmemio/minit.x create mode 100644 sys/nmemio/mkpkg create mode 100644 sys/nmemio/msvfwa.x create mode 100644 sys/nmemio/nmemio.com create mode 100644 sys/nmemio/realloc.x create mode 100644 sys/nmemio/salloc.x create mode 100644 sys/nmemio/sizeof.x create mode 100644 sys/nmemio/vmalloc.x create mode 100644 sys/nmemio/zz.x create mode 100644 sys/nmemio/zzdebug.x create mode 100644 sys/nmemio/zzfoo.gx create mode 100644 sys/nmemio/zzfoo.x create mode 100644 sys/osb/README create mode 100644 sys/osb/_proto create mode 100644 sys/osb/abs.c create mode 100644 sys/osb/achtb.gc create mode 100644 sys/osb/achtbb.c create mode 100644 sys/osb/achtbc.c create mode 100644 sys/osb/achtbd.c create mode 100644 sys/osb/achtbi.c create mode 100644 sys/osb/achtbl.c create mode 100644 sys/osb/achtbr.c create mode 100644 sys/osb/achtbs.c create mode 100644 sys/osb/achtbu.c create mode 100644 sys/osb/achtbx.c create mode 100644 sys/osb/achtcb.c create mode 100644 sys/osb/achtcu.c create mode 100644 sys/osb/achtdb.c create mode 100644 sys/osb/achtdu.c create mode 100644 sys/osb/achtib.c create mode 100644 sys/osb/achtiu.c create mode 100644 sys/osb/achtlb.c create mode 100644 sys/osb/achtlu.c create mode 100644 sys/osb/achtrb.c create mode 100644 sys/osb/achtru.c create mode 100644 sys/osb/achtsb.c create mode 100644 sys/osb/achtsu.c create mode 100644 sys/osb/achtu.gc create mode 100644 sys/osb/achtub.c create mode 100644 sys/osb/achtuc.c create mode 100644 sys/osb/achtud.c create mode 100644 sys/osb/achtui.c create mode 100644 sys/osb/achtul.c create mode 100644 sys/osb/achtur.c create mode 100644 sys/osb/achtus.c create mode 100644 sys/osb/achtuu.c create mode 100644 sys/osb/achtux.c create mode 100644 sys/osb/achtxb.c create mode 100644 sys/osb/achtxu.c create mode 100644 sys/osb/achtzb.gc create mode 100644 sys/osb/achtzu.gc create mode 100644 sys/osb/aclrb.c create mode 100644 sys/osb/and.c create mode 100644 sys/osb/bitfields.c create mode 100644 sys/osb/bitmov.x create mode 100644 sys/osb/bswap2.c create mode 100644 sys/osb/bswap2.f create mode 100644 sys/osb/bswap4.c create mode 100644 sys/osb/bswap4.f create mode 100644 sys/osb/bswap8.c create mode 120000 sys/osb/bytmov.c create mode 100644 sys/osb/bytmov.f create mode 100644 sys/osb/chrpak.c create mode 100644 sys/osb/chrpak.f create mode 100644 sys/osb/chrupk.c create mode 100644 sys/osb/chrupk.f create mode 120000 sys/osb/d1mach.f create mode 100644 sys/osb/f77pak.f create mode 100644 sys/osb/f77upk.f create mode 120000 sys/osb/i1mach.f create mode 100644 sys/osb/i32to64.c create mode 100644 sys/osb/i64to32.c create mode 100644 sys/osb/iand32.c create mode 100644 sys/osb/ieee.gx create mode 100644 sys/osb/ieeed.x create mode 100644 sys/osb/ieeer.x create mode 100644 sys/osb/imul32.c create mode 100644 sys/osb/ipak16.c create mode 100644 sys/osb/ipak32.c create mode 100644 sys/osb/iscl32.c create mode 100644 sys/osb/iscl64.c create mode 100644 sys/osb/iupk16.c create mode 100644 sys/osb/iupk32.c create mode 100644 sys/osb/miilen.x create mode 100644 sys/osb/miinelem.x create mode 100644 sys/osb/miipak.x create mode 100644 sys/osb/miipak16.x create mode 100644 sys/osb/miipak32.x create mode 100644 sys/osb/miipak8.x create mode 100644 sys/osb/miipakd.x create mode 100644 sys/osb/miipakr.x create mode 100644 sys/osb/miipksize.x create mode 100644 sys/osb/miiupk.x create mode 100644 sys/osb/miiupk16.x create mode 100644 sys/osb/miiupk32.x create mode 100644 sys/osb/miiupk8.x create mode 100644 sys/osb/miiupkd.x create mode 100644 sys/osb/miiupkr.x create mode 100644 sys/osb/mkpkg create mode 100644 sys/osb/nmilen.x create mode 100644 sys/osb/nminelem.x create mode 100644 sys/osb/nmipak.x create mode 100644 sys/osb/nmipak16.x create mode 100644 sys/osb/nmipak32.x create mode 100644 sys/osb/nmipak8.x create mode 100644 sys/osb/nmipakd.x create mode 100644 sys/osb/nmipakr.x create mode 100644 sys/osb/nmipksize.x create mode 100644 sys/osb/nmiupk.x create mode 100644 sys/osb/nmiupk16.x create mode 100644 sys/osb/nmiupk32.x create mode 100644 sys/osb/nmiupk8.x create mode 100644 sys/osb/nmiupkd.x create mode 100644 sys/osb/nmiupkr.x create mode 100644 sys/osb/not.c create mode 100644 sys/osb/or.c create mode 120000 sys/osb/r1mach.f create mode 100644 sys/osb/shift.c create mode 100644 sys/osb/strpak.c create mode 100644 sys/osb/strpak.f create mode 100644 sys/osb/strsum.c create mode 100644 sys/osb/strupk.c create mode 100644 sys/osb/strupk.f create mode 100644 sys/osb/urand.x create mode 100644 sys/osb/xor.x create mode 100644 sys/osb/zzdebug.x create mode 100644 sys/osb/zzeps.f create mode 100644 sys/osb/zzeps2.f create mode 100644 sys/plio/PLIO.hlp create mode 100644 sys/plio/README create mode 100644 sys/plio/mkpkg create mode 100644 sys/plio/placcess.x create mode 100644 sys/plio/plalloc.x create mode 100644 sys/plio/plascii.x create mode 100644 sys/plio/plbox.h create mode 100644 sys/plio/plbox.x create mode 100644 sys/plio/plcircle.h create mode 100644 sys/plio/plcircle.x create mode 100644 sys/plio/plclear.x create mode 100644 sys/plio/plclose.x create mode 100644 sys/plio/plcmpress.x create mode 100644 sys/plio/plcompare.x create mode 100644 sys/plio/plcreate.x create mode 100644 sys/plio/pldbgout.x create mode 100644 sys/plio/pldebug.x create mode 100644 sys/plio/plempty.x create mode 100644 sys/plio/plemptyline.x create mode 100644 sys/plio/plglls.x create mode 100644 sys/plio/plglp.gx create mode 100644 sys/plio/plglr.gx create mode 100644 sys/plio/plgplane.x create mode 100644 sys/plio/plgsize.x create mode 100644 sys/plio/pll2p.gx create mode 100644 sys/plio/pll2r.gx create mode 100644 sys/plio/pllen.x create mode 100644 sys/plio/plleq.x create mode 100644 sys/plio/plline.x create mode 100644 sys/plio/pllinene.x create mode 100644 sys/plio/pllnext.x create mode 100644 sys/plio/plload.x create mode 100644 sys/plio/plloadf.x create mode 100644 sys/plio/plloadim.x create mode 100644 sys/plio/plloop.x create mode 100644 sys/plio/pllpr.x create mode 100644 sys/plio/pllrop.x create mode 100644 sys/plio/pllseg.h create mode 100644 sys/plio/pllsten.x create mode 100644 sys/plio/plnewcopy.x create mode 100644 sys/plio/plopen.x create mode 100644 sys/plio/plp2l.gx create mode 100644 sys/plio/plp2r.gx create mode 100644 sys/plio/plplls.x create mode 100644 sys/plio/plplp.gx create mode 100644 sys/plio/plplr.gx create mode 100644 sys/plio/plpoint.x create mode 100644 sys/plio/plpolygon.h create mode 100644 sys/plio/plpolygon.x create mode 100644 sys/plio/plprop.gx create mode 100644 sys/plio/plr2l.gx create mode 100644 sys/plio/plr2p.gx create mode 100644 sys/plio/plregrop.x create mode 100644 sys/plio/plreq.gx create mode 100644 sys/plio/plrio.x create mode 100644 sys/plio/plrop.x create mode 100644 sys/plio/plrpr.gx create mode 100644 sys/plio/plrrop.gx create mode 100644 sys/plio/plrseg.h create mode 100644 sys/plio/plsave.x create mode 100644 sys/plio/plsavef.x create mode 100644 sys/plio/plsaveim.x create mode 100644 sys/plio/plsectnc.x create mode 100644 sys/plio/plsectne.x create mode 100644 sys/plio/plseti.x create mode 100644 sys/plio/plsplane.x create mode 100644 sys/plio/plssize.x create mode 100644 sys/plio/plsslv.x create mode 100644 sys/plio/plstati.x create mode 100644 sys/plio/plsten.x create mode 100644 sys/plio/plubox.x create mode 100644 sys/plio/plucircle.x create mode 100644 sys/plio/plupdate.x create mode 100644 sys/plio/plupolygon.x create mode 100644 sys/plio/plvalid.x create mode 100644 sys/plio/tf/mkpkg create mode 100644 sys/plio/tf/plglpi.x create mode 100644 sys/plio/tf/plglpl.x create mode 100644 sys/plio/tf/plglps.x create mode 100644 sys/plio/tf/plglri.x create mode 100644 sys/plio/tf/plglrl.x create mode 100644 sys/plio/tf/plglrs.x create mode 100644 sys/plio/tf/pll2pi.x create mode 100644 sys/plio/tf/pll2pl.x create mode 100644 sys/plio/tf/pll2ps.x create mode 100644 sys/plio/tf/pll2ri.x create mode 100644 sys/plio/tf/pll2rl.x create mode 100644 sys/plio/tf/pll2rs.x create mode 100644 sys/plio/tf/plp2li.x create mode 100644 sys/plio/tf/plp2ll.x create mode 100644 sys/plio/tf/plp2ls.x create mode 100644 sys/plio/tf/plp2ri.x create mode 100644 sys/plio/tf/plp2rl.x create mode 100644 sys/plio/tf/plp2rs.x create mode 100644 sys/plio/tf/plplpi.x create mode 100644 sys/plio/tf/plplpl.x create mode 100644 sys/plio/tf/plplps.x create mode 100644 sys/plio/tf/plplri.x create mode 100644 sys/plio/tf/plplrl.x create mode 100644 sys/plio/tf/plplrs.x create mode 100644 sys/plio/tf/plpropi.x create mode 100644 sys/plio/tf/plpropl.x create mode 100644 sys/plio/tf/plprops.x create mode 100644 sys/plio/tf/plr2li.x create mode 100644 sys/plio/tf/plr2ll.x create mode 100644 sys/plio/tf/plr2ls.x create mode 100644 sys/plio/tf/plr2pi.x create mode 100644 sys/plio/tf/plr2pl.x create mode 100644 sys/plio/tf/plr2ps.x create mode 100644 sys/plio/tf/plreqi.x create mode 100644 sys/plio/tf/plreql.x create mode 100644 sys/plio/tf/plreqs.x create mode 100644 sys/plio/tf/plrpri.x create mode 100644 sys/plio/tf/plrprl.x create mode 100644 sys/plio/tf/plrprs.x create mode 100644 sys/plio/tf/plrropi.x create mode 100644 sys/plio/tf/plrropl.x create mode 100644 sys/plio/tf/plrrops.x create mode 100644 sys/plio/zzdebug.x create mode 100644 sys/plio/zzlib.x create mode 100644 sys/plio/zzsum.x create mode 100644 sys/pmio/README create mode 100644 sys/pmio/mio.h create mode 100644 sys/pmio/mioclose.x create mode 100644 sys/pmio/miogl.gx create mode 100644 sys/pmio/mioopen.x create mode 100644 sys/pmio/mioopeno.x create mode 100644 sys/pmio/miopl.gx create mode 100644 sys/pmio/mioseti.x create mode 100644 sys/pmio/miosrange.x create mode 100644 sys/pmio/miostati.x create mode 100644 sys/pmio/mkpkg create mode 100644 sys/pmio/plprop.gx create mode 100644 sys/pmio/pmaccess.x create mode 100644 sys/pmio/pmascii.x create mode 100644 sys/pmio/pmbox.x create mode 100644 sys/pmio/pmcircle.x create mode 100644 sys/pmio/pmclear.x create mode 100644 sys/pmio/pmempty.x create mode 100644 sys/pmio/pmglls.x create mode 100644 sys/pmio/pmglp.gx create mode 100644 sys/pmio/pmglr.gx create mode 100644 sys/pmio/pmio.com create mode 100644 sys/pmio/pmline.x create mode 100644 sys/pmio/pmlinene.x create mode 100644 sys/pmio/pmnewmask.x create mode 100644 sys/pmio/pmplls.x create mode 100644 sys/pmio/pmplp.gx create mode 100644 sys/pmio/pmplr.gx create mode 100644 sys/pmio/pmpoint.x create mode 100644 sys/pmio/pmpolygon.x create mode 100644 sys/pmio/pmrio.x create mode 100644 sys/pmio/pmrop.x create mode 100644 sys/pmio/pmsectnc.x create mode 100644 sys/pmio/pmsectne.x create mode 100644 sys/pmio/pmseti.x create mode 100644 sys/pmio/pmsplane.x create mode 100644 sys/pmio/pmstati.x create mode 100644 sys/pmio/pmsten.x create mode 100644 sys/pmio/tf/miogld.x create mode 100644 sys/pmio/tf/miogli.x create mode 100644 sys/pmio/tf/miogll.x create mode 100644 sys/pmio/tf/mioglr.x create mode 100644 sys/pmio/tf/miogls.x create mode 100644 sys/pmio/tf/mioglx.x create mode 100644 sys/pmio/tf/miopld.x create mode 100644 sys/pmio/tf/miopli.x create mode 100644 sys/pmio/tf/miopll.x create mode 100644 sys/pmio/tf/mioplr.x create mode 100644 sys/pmio/tf/miopls.x create mode 100644 sys/pmio/tf/mioplx.x create mode 100644 sys/pmio/tf/mkpkg create mode 100644 sys/pmio/tf/pmglpi.x create mode 100644 sys/pmio/tf/pmglpl.x create mode 100644 sys/pmio/tf/pmglps.x create mode 100644 sys/pmio/tf/pmglri.x create mode 100644 sys/pmio/tf/pmglrl.x create mode 100644 sys/pmio/tf/pmglrs.x create mode 100644 sys/pmio/tf/pmplpi.x create mode 100644 sys/pmio/tf/pmplpl.x create mode 100644 sys/pmio/tf/pmplps.x create mode 100644 sys/pmio/tf/pmplri.x create mode 100644 sys/pmio/tf/pmplrl.x create mode 100644 sys/pmio/tf/pmplrs.x create mode 100644 sys/pmio/zzdebug.x create mode 100644 sys/pmio/zzinterp.x create mode 100644 sys/psio/README create mode 100644 sys/psio/font.com create mode 100644 sys/psio/mkpkg create mode 100644 sys/psio/psbreak.x create mode 100644 sys/psio/pscenter.x create mode 100644 sys/psio/psclose.x create mode 100644 sys/psio/psdeposit.x create mode 100644 sys/psio/psfont.x create mode 100644 sys/psio/psio.h create mode 100644 sys/psio/psjustify.x create mode 100644 sys/psio/psopen.x create mode 100644 sys/psio/psoutput.x create mode 100644 sys/psio/pspos.x create mode 100644 sys/psio/psprolog.x create mode 100644 sys/psio/pssetup.x create mode 100644 sys/psio/pswidth.x create mode 100644 sys/psio/zzdebug.x create mode 100644 sys/qpoe/QPDEFS create mode 100644 sys/qpoe/QPOE.hlp create mode 100644 sys/qpoe/README create mode 100644 sys/qpoe/gen/mkpkg create mode 100644 sys/qpoe/gen/qpaddb.x create mode 100644 sys/qpoe/gen/qpaddc.x create mode 100644 sys/qpoe/gen/qpaddd.x create mode 100644 sys/qpoe/gen/qpaddi.x create mode 100644 sys/qpoe/gen/qpaddl.x create mode 100644 sys/qpoe/gen/qpaddr.x create mode 100644 sys/qpoe/gen/qpadds.x create mode 100644 sys/qpoe/gen/qpaddx.x create mode 100644 sys/qpoe/gen/qpexattrld.x create mode 100644 sys/qpoe/gen/qpexattrli.x create mode 100644 sys/qpoe/gen/qpexattrlr.x create mode 100644 sys/qpoe/gen/qpexcoded.x create mode 100644 sys/qpoe/gen/qpexcodei.x create mode 100644 sys/qpoe/gen/qpexcoder.x create mode 100644 sys/qpoe/gen/qpexparsed.x create mode 100644 sys/qpoe/gen/qpexparsei.x create mode 100644 sys/qpoe/gen/qpexparser.x create mode 100644 sys/qpoe/gen/qpexsubd.x create mode 100644 sys/qpoe/gen/qpexsubi.x create mode 100644 sys/qpoe/gen/qpexsubr.x create mode 100644 sys/qpoe/gen/qpgetc.x create mode 100644 sys/qpoe/gen/qpgetd.x create mode 100644 sys/qpoe/gen/qpgeti.x create mode 100644 sys/qpoe/gen/qpgetl.x create mode 100644 sys/qpoe/gen/qpgetr.x create mode 100644 sys/qpoe/gen/qpgets.x create mode 100644 sys/qpoe/gen/qpiogetev.x create mode 100644 sys/qpoe/gen/qpiorpixi.x create mode 100644 sys/qpoe/gen/qpiorpixs.x create mode 100644 sys/qpoe/gen/qpputc.x create mode 100644 sys/qpoe/gen/qpputd.x create mode 100644 sys/qpoe/gen/qpputi.x create mode 100644 sys/qpoe/gen/qpputl.x create mode 100644 sys/qpoe/gen/qpputr.x create mode 100644 sys/qpoe/gen/qpputs.x create mode 100644 sys/qpoe/gen/qprlmerged.x create mode 100644 sys/qpoe/gen/qprlmergei.x create mode 100644 sys/qpoe/gen/qprlmerger.x create mode 100644 sys/qpoe/mkpkg create mode 100644 sys/qpoe/qpaccess.x create mode 100644 sys/qpoe/qpaccessf.x create mode 100644 sys/qpoe/qpadd.gx create mode 100644 sys/qpoe/qpaddf.x create mode 100644 sys/qpoe/qpastr.x create mode 100644 sys/qpoe/qpbind.x create mode 100644 sys/qpoe/qpclose.x create mode 100644 sys/qpoe/qpcopy.x create mode 100644 sys/qpoe/qpcopyf.x create mode 100644 sys/qpoe/qpctod.x create mode 100644 sys/qpoe/qpctoi.x create mode 100644 sys/qpoe/qpdelete.x create mode 100644 sys/qpoe/qpdeletef.x create mode 100644 sys/qpoe/qpdsym.x create mode 100644 sys/qpoe/qpdtype.x create mode 100644 sys/qpoe/qpelsize.x create mode 100644 sys/qpoe/qpex.h create mode 100644 sys/qpoe/qpexattrl.gx create mode 100644 sys/qpoe/qpexclose.x create mode 100644 sys/qpoe/qpexcode.gx create mode 100644 sys/qpoe/qpexdata.x create mode 100644 sys/qpoe/qpexdebug.x create mode 100644 sys/qpoe/qpexdel.x create mode 100644 sys/qpoe/qpexeval.x create mode 100644 sys/qpoe/qpexgetat.x create mode 100644 sys/qpoe/qpexgetfil.x create mode 100644 sys/qpoe/qpexmodfil.x create mode 100644 sys/qpoe/qpexopen.x create mode 100644 sys/qpoe/qpexpand.x create mode 100644 sys/qpoe/qpexparse.gx create mode 100644 sys/qpoe/qpexsub.gx create mode 100644 sys/qpoe/qpget.gx create mode 100644 sys/qpoe/qpgetb.x create mode 100644 sys/qpoe/qpgettok.x create mode 100644 sys/qpoe/qpgetx.x create mode 100644 sys/qpoe/qpgmsym.x create mode 100644 sys/qpoe/qpgnfn.x create mode 100644 sys/qpoe/qpgpar.x create mode 100644 sys/qpoe/qpgpsym.x create mode 100644 sys/qpoe/qpgstr.x create mode 100644 sys/qpoe/qpinherit.x create mode 100644 sys/qpoe/qpio.h create mode 100644 sys/qpoe/qpioclose.x create mode 100644 sys/qpoe/qpiogetev.gx create mode 100644 sys/qpoe/qpiogetfil.x create mode 100644 sys/qpoe/qpiogetrg.x create mode 100644 sys/qpoe/qpiolmask.x create mode 100644 sys/qpoe/qpiolwcs.x create mode 100644 sys/qpoe/qpiomkidx.x create mode 100644 sys/qpoe/qpioopen.x create mode 100644 sys/qpoe/qpioparse.x create mode 100644 sys/qpoe/qpioputev.x create mode 100644 sys/qpoe/qpiorb.x create mode 100644 sys/qpoe/qpiorpix.gx create mode 100644 sys/qpoe/qpiosetfil.x create mode 100644 sys/qpoe/qpioseti.x create mode 100644 sys/qpoe/qpiosetr.x create mode 100644 sys/qpoe/qpiosetrg.x create mode 100644 sys/qpoe/qpiostati.x create mode 100644 sys/qpoe/qpiostatr.x create mode 100644 sys/qpoe/qpiosync.x create mode 100644 sys/qpoe/qpiowb.x create mode 100644 sys/qpoe/qplenf.x create mode 100644 sys/qpoe/qploadwcs.x create mode 100644 sys/qpoe/qpmacro.x create mode 100644 sys/qpoe/qpmkfname.x create mode 100644 sys/qpoe/qpoe.h create mode 100644 sys/qpoe/qpopen.x create mode 100644 sys/qpoe/qpparse.x create mode 100644 sys/qpoe/qpparsefl.x create mode 100644 sys/qpoe/qppclose.x create mode 100644 sys/qpoe/qppopen.x create mode 100644 sys/qpoe/qpppar.x create mode 100644 sys/qpoe/qppstr.x create mode 100644 sys/qpoe/qpput.gx create mode 100644 sys/qpoe/qpputb.x create mode 100644 sys/qpoe/qpputx.x create mode 100644 sys/qpoe/qpqueryf.x create mode 100644 sys/qpoe/qpread.x create mode 100644 sys/qpoe/qprebuild.x create mode 100644 sys/qpoe/qprename.x create mode 100644 sys/qpoe/qprenamef.x create mode 100644 sys/qpoe/qprlmerge.gx create mode 100644 sys/qpoe/qpsavewcs.x create mode 100644 sys/qpoe/qpseti.x create mode 100644 sys/qpoe/qpsetr.x create mode 100644 sys/qpoe/qpsizeof.x create mode 100644 sys/qpoe/qpstati.x create mode 100644 sys/qpoe/qpstatr.x create mode 100644 sys/qpoe/qpsync.x create mode 100644 sys/qpoe/qpwrite.x create mode 100644 sys/qpoe/zzdebug.x create mode 100644 sys/symtab/README create mode 100644 sys/symtab/mkpkg create mode 100644 sys/symtab/stalloc.x create mode 100644 sys/symtab/stclose.x create mode 100644 sys/symtab/stenter.x create mode 100644 sys/symtab/stfind.x create mode 100644 sys/symtab/stfindall.x create mode 100644 sys/symtab/stfree.x create mode 100644 sys/symtab/sthash.x create mode 100644 sys/symtab/sthead.x create mode 100644 sys/symtab/stinfo.x create mode 100644 sys/symtab/stmark.x create mode 100644 sys/symtab/stname.x create mode 100644 sys/symtab/stnext.x create mode 100644 sys/symtab/stnsym.x create mode 100644 sys/symtab/stopen.x create mode 100644 sys/symtab/stpstr.x create mode 100644 sys/symtab/strefsbuf.x create mode 100644 sys/symtab/strefstab.x create mode 100644 sys/symtab/strestore.x create mode 100644 sys/symtab/stsave.x create mode 100644 sys/symtab/stsize.x create mode 100644 sys/symtab/stsqueeze.x create mode 100644 sys/symtab/symtab.h create mode 100644 sys/symtab/zzdebug.x create mode 100644 sys/sys.hd create mode 100644 sys/sys.men create mode 100644 sys/tty/README create mode 100644 sys/tty/doc/tty.hlp create mode 100644 sys/tty/gttyload.x create mode 100644 sys/tty/mkpkg create mode 100644 sys/tty/tty.h create mode 100644 sys/tty/ttycaps.x create mode 100644 sys/tty/ttycdes.x create mode 100644 sys/tty/ttyclear.x create mode 100644 sys/tty/ttyclln.x create mode 100644 sys/tty/ttyclose.x create mode 100644 sys/tty/ttyctrl.x create mode 100644 sys/tty/ttydelay.x create mode 100644 sys/tty/ttydevnm.x create mode 100644 sys/tty/ttygdes.x create mode 100644 sys/tty/ttygetb.x create mode 100644 sys/tty/ttygeti.x create mode 100644 sys/tty/ttygetr.x create mode 100644 sys/tty/ttygets.x create mode 100644 sys/tty/ttygoto.x create mode 100644 sys/tty/ttygsize.x create mode 100644 sys/tty/ttyindex.x create mode 100644 sys/tty/ttyinit.x create mode 100644 sys/tty/ttyload.x create mode 100644 sys/tty/ttyodes.x create mode 100644 sys/tty/ttyopen.x create mode 100644 sys/tty/ttyputl.x create mode 100644 sys/tty/ttyputs.x create mode 100644 sys/tty/ttyread.x create mode 100644 sys/tty/ttyseti.x create mode 100644 sys/tty/ttyso.x create mode 100644 sys/tty/ttystati.x create mode 100644 sys/tty/ttysubi.x create mode 100644 sys/tty/ttywrite.x create mode 100644 sys/tty/x_mkttydata.x create mode 100644 sys/tty/zzdebug.x create mode 100644 sys/vops/README create mode 100644 sys/vops/aabs.gx create mode 100644 sys/vops/aadd.gx create mode 100644 sys/vops/aaddk.gx create mode 100644 sys/vops/aand.gx create mode 100644 sys/vops/aandk.gx create mode 100644 sys/vops/aavg.gx create mode 100644 sys/vops/abav.gx create mode 100644 sys/vops/abeq.gx create mode 100644 sys/vops/abeqk.gx create mode 100644 sys/vops/abge.gx create mode 100644 sys/vops/abgek.gx create mode 100644 sys/vops/abgt.gx create mode 100644 sys/vops/abgtk.gx create mode 100644 sys/vops/able.gx create mode 100644 sys/vops/ablek.gx create mode 100644 sys/vops/ablt.gx create mode 100644 sys/vops/abltk.gx create mode 100644 sys/vops/abne.gx create mode 100644 sys/vops/abnek.gx create mode 100644 sys/vops/abor.gx create mode 100644 sys/vops/abork.gx create mode 100644 sys/vops/absu.gx create mode 100644 sys/vops/acht.gx create mode 100644 sys/vops/achtgen/acht.x create mode 100644 sys/vops/achtgen/achtb.x create mode 100644 sys/vops/achtgen/achtc.x create mode 100644 sys/vops/achtgen/achtd.x create mode 100644 sys/vops/achtgen/achti.x create mode 100644 sys/vops/achtgen/achtl.x create mode 100644 sys/vops/achtgen/achtr.x create mode 100644 sys/vops/achtgen/achts.x create mode 100644 sys/vops/achtgen/achtu.x create mode 100644 sys/vops/achtgen/achtx.x create mode 100644 sys/vops/achtgen/mkpkg create mode 100644 sys/vops/acjgx.x create mode 100644 sys/vops/aclr.gx create mode 100644 sys/vops/acnv.gx create mode 100644 sys/vops/acnvr.gx create mode 100644 sys/vops/adiv.gx create mode 100644 sys/vops/adivk.gx create mode 100644 sys/vops/adot.gx create mode 100644 sys/vops/advz.gx create mode 100644 sys/vops/aexp.gx create mode 100644 sys/vops/aexpk.gx create mode 100644 sys/vops/afftrr.x create mode 100644 sys/vops/afftrx.x create mode 100644 sys/vops/afftxr.x create mode 100644 sys/vops/afftxx.x create mode 100644 sys/vops/aglt.gx create mode 100644 sys/vops/ahgm.gx create mode 100644 sys/vops/ahiv.gx create mode 100644 sys/vops/aiftrr.x create mode 100644 sys/vops/aiftrx.x create mode 100644 sys/vops/aiftxr.x create mode 100644 sys/vops/aiftxx.x create mode 100644 sys/vops/aimg.gx create mode 100644 sys/vops/ak/aabsd.x create mode 100644 sys/vops/ak/aabsi.x create mode 100644 sys/vops/ak/aabsl.x create mode 100644 sys/vops/ak/aabsr.x create mode 100644 sys/vops/ak/aabss.x create mode 100644 sys/vops/ak/aabsx.x create mode 100644 sys/vops/ak/aaddd.x create mode 100644 sys/vops/ak/aaddi.x create mode 100644 sys/vops/ak/aaddkd.x create mode 100644 sys/vops/ak/aaddki.x create mode 100644 sys/vops/ak/aaddkl.x create mode 100644 sys/vops/ak/aaddkr.x create mode 100644 sys/vops/ak/aaddks.x create mode 100644 sys/vops/ak/aaddkx.x create mode 100644 sys/vops/ak/aaddl.x create mode 100644 sys/vops/ak/aaddr.x create mode 100644 sys/vops/ak/aadds.x create mode 100644 sys/vops/ak/aaddx.x create mode 100644 sys/vops/ak/aandi.x create mode 100644 sys/vops/ak/aandki.x create mode 100644 sys/vops/ak/aandkl.x create mode 100644 sys/vops/ak/aandks.x create mode 100644 sys/vops/ak/aandl.x create mode 100644 sys/vops/ak/aands.x create mode 100644 sys/vops/ak/aavgd.x create mode 100644 sys/vops/ak/aavgi.x create mode 100644 sys/vops/ak/aavgl.x create mode 100644 sys/vops/ak/aavgr.x create mode 100644 sys/vops/ak/aavgs.x create mode 100644 sys/vops/ak/aavgx.x create mode 100644 sys/vops/ak/abavd.x create mode 100644 sys/vops/ak/abavi.x create mode 100644 sys/vops/ak/abavl.x create mode 100644 sys/vops/ak/abavr.x create mode 100644 sys/vops/ak/abavs.x create mode 100644 sys/vops/ak/abavx.x create mode 100644 sys/vops/ak/abeqc.x create mode 100644 sys/vops/ak/abeqd.x create mode 100644 sys/vops/ak/abeqi.x create mode 100644 sys/vops/ak/abeqkc.x create mode 100644 sys/vops/ak/abeqkd.x create mode 100644 sys/vops/ak/abeqki.x create mode 100644 sys/vops/ak/abeqkl.x create mode 100644 sys/vops/ak/abeqkr.x create mode 100644 sys/vops/ak/abeqks.x create mode 100644 sys/vops/ak/abeqkx.x create mode 100644 sys/vops/ak/abeql.x create mode 100644 sys/vops/ak/abeqr.x create mode 100644 sys/vops/ak/abeqs.x create mode 100644 sys/vops/ak/abeqx.x create mode 100644 sys/vops/ak/abgec.x create mode 100644 sys/vops/ak/abged.x create mode 100644 sys/vops/ak/abgei.x create mode 100644 sys/vops/ak/abgekc.x create mode 100644 sys/vops/ak/abgekd.x create mode 100644 sys/vops/ak/abgeki.x create mode 100644 sys/vops/ak/abgekl.x create mode 100644 sys/vops/ak/abgekr.x create mode 100644 sys/vops/ak/abgeks.x create mode 100644 sys/vops/ak/abgekx.x create mode 100644 sys/vops/ak/abgel.x create mode 100644 sys/vops/ak/abger.x create mode 100644 sys/vops/ak/abges.x create mode 100644 sys/vops/ak/abgex.x create mode 100644 sys/vops/ak/abgtc.x create mode 100644 sys/vops/ak/abgtd.x create mode 100644 sys/vops/ak/abgti.x create mode 100644 sys/vops/ak/abgtkc.x create mode 100644 sys/vops/ak/abgtkd.x create mode 100644 sys/vops/ak/abgtki.x create mode 100644 sys/vops/ak/abgtkl.x create mode 100644 sys/vops/ak/abgtkr.x create mode 100644 sys/vops/ak/abgtks.x create mode 100644 sys/vops/ak/abgtkx.x create mode 100644 sys/vops/ak/abgtl.x create mode 100644 sys/vops/ak/abgtr.x create mode 100644 sys/vops/ak/abgts.x create mode 100644 sys/vops/ak/abgtx.x create mode 100644 sys/vops/ak/ablec.x create mode 100644 sys/vops/ak/abled.x create mode 100644 sys/vops/ak/ablei.x create mode 100644 sys/vops/ak/ablekc.x create mode 100644 sys/vops/ak/ablekd.x create mode 100644 sys/vops/ak/ableki.x create mode 100644 sys/vops/ak/ablekl.x create mode 100644 sys/vops/ak/ablekr.x create mode 100644 sys/vops/ak/ableks.x create mode 100644 sys/vops/ak/ablekx.x create mode 100644 sys/vops/ak/ablel.x create mode 100644 sys/vops/ak/abler.x create mode 100644 sys/vops/ak/ables.x create mode 100644 sys/vops/ak/ablex.x create mode 100644 sys/vops/ak/abltc.x create mode 100644 sys/vops/ak/abltd.x create mode 100644 sys/vops/ak/ablti.x create mode 100644 sys/vops/ak/abltkc.x create mode 100644 sys/vops/ak/abltkd.x create mode 100644 sys/vops/ak/abltki.x create mode 100644 sys/vops/ak/abltkl.x create mode 100644 sys/vops/ak/abltkr.x create mode 100644 sys/vops/ak/abltks.x create mode 100644 sys/vops/ak/abltkx.x create mode 100644 sys/vops/ak/abltl.x create mode 100644 sys/vops/ak/abltr.x create mode 100644 sys/vops/ak/ablts.x create mode 100644 sys/vops/ak/abltx.x create mode 100644 sys/vops/ak/abnec.x create mode 100644 sys/vops/ak/abned.x create mode 100644 sys/vops/ak/abnei.x create mode 100644 sys/vops/ak/abnekc.x create mode 100644 sys/vops/ak/abnekd.x create mode 100644 sys/vops/ak/abneki.x create mode 100644 sys/vops/ak/abnekl.x create mode 100644 sys/vops/ak/abnekr.x create mode 100644 sys/vops/ak/abneks.x create mode 100644 sys/vops/ak/abnekx.x create mode 100644 sys/vops/ak/abnel.x create mode 100644 sys/vops/ak/abner.x create mode 100644 sys/vops/ak/abnes.x create mode 100644 sys/vops/ak/abnex.x create mode 100644 sys/vops/ak/abori.x create mode 100644 sys/vops/ak/aborki.x create mode 100644 sys/vops/ak/aborkl.x create mode 100644 sys/vops/ak/aborks.x create mode 100644 sys/vops/ak/aborl.x create mode 100644 sys/vops/ak/abors.x create mode 100644 sys/vops/ak/absud.x create mode 100644 sys/vops/ak/absui.x create mode 100644 sys/vops/ak/absul.x create mode 100644 sys/vops/ak/absur.x create mode 100644 sys/vops/ak/absus.x create mode 100644 sys/vops/ak/achtcc.x create mode 100644 sys/vops/ak/achtcd.x create mode 100644 sys/vops/ak/achtci.x create mode 100644 sys/vops/ak/achtcl.x create mode 100644 sys/vops/ak/achtcr.x create mode 100644 sys/vops/ak/achtcs.x create mode 100644 sys/vops/ak/achtcx.x create mode 100644 sys/vops/ak/achtdc.x create mode 100644 sys/vops/ak/achtdd.x create mode 100644 sys/vops/ak/achtdi.x create mode 100644 sys/vops/ak/achtdl.x create mode 100644 sys/vops/ak/achtdr.x create mode 100644 sys/vops/ak/achtds.x create mode 100644 sys/vops/ak/achtdx.x create mode 100644 sys/vops/ak/achtic.x create mode 100644 sys/vops/ak/achtid.x create mode 100644 sys/vops/ak/achtii.x create mode 100644 sys/vops/ak/achtil.x create mode 100644 sys/vops/ak/achtir.x create mode 100644 sys/vops/ak/achtis.x create mode 100644 sys/vops/ak/achtix.x create mode 100644 sys/vops/ak/achtlc.x create mode 100644 sys/vops/ak/achtld.x create mode 100644 sys/vops/ak/achtli.x create mode 100644 sys/vops/ak/achtll.x create mode 100644 sys/vops/ak/achtlr.x create mode 100644 sys/vops/ak/achtls.x create mode 100644 sys/vops/ak/achtlx.x create mode 100644 sys/vops/ak/achtrc.x create mode 100644 sys/vops/ak/achtrd.x create mode 100644 sys/vops/ak/achtri.x create mode 100644 sys/vops/ak/achtrl.x create mode 100644 sys/vops/ak/achtrr.x create mode 100644 sys/vops/ak/achtrs.x create mode 100644 sys/vops/ak/achtrx.x create mode 100644 sys/vops/ak/achtsc.x create mode 100644 sys/vops/ak/achtsd.x create mode 100644 sys/vops/ak/achtsi.x create mode 100644 sys/vops/ak/achtsl.x create mode 100644 sys/vops/ak/achtsr.x create mode 100644 sys/vops/ak/achtss.x create mode 100644 sys/vops/ak/achtsx.x create mode 100644 sys/vops/ak/achtxc.x create mode 100644 sys/vops/ak/achtxd.x create mode 100644 sys/vops/ak/achtxi.x create mode 100644 sys/vops/ak/achtxl.x create mode 100644 sys/vops/ak/achtxr.x create mode 100644 sys/vops/ak/achtxs.x create mode 100644 sys/vops/ak/achtxx.x create mode 100644 sys/vops/ak/acjgx.x create mode 100644 sys/vops/ak/aclrc.x create mode 100644 sys/vops/ak/aclrd.x create mode 100644 sys/vops/ak/aclri.x create mode 100644 sys/vops/ak/aclrl.x create mode 100644 sys/vops/ak/aclrr.x create mode 100644 sys/vops/ak/aclrs.x create mode 100644 sys/vops/ak/aclrx.x create mode 100644 sys/vops/ak/acnvd.x create mode 100644 sys/vops/ak/acnvi.x create mode 100644 sys/vops/ak/acnvl.x create mode 100644 sys/vops/ak/acnvr.x create mode 100644 sys/vops/ak/acnvrd.x create mode 100644 sys/vops/ak/acnvri.x create mode 100644 sys/vops/ak/acnvrl.x create mode 100644 sys/vops/ak/acnvrr.x create mode 100644 sys/vops/ak/acnvrs.x create mode 100644 sys/vops/ak/acnvs.x create mode 100644 sys/vops/ak/adivd.x create mode 100644 sys/vops/ak/adivi.x create mode 100644 sys/vops/ak/adivkd.x create mode 100644 sys/vops/ak/adivki.x create mode 100644 sys/vops/ak/adivkl.x create mode 100644 sys/vops/ak/adivkr.x create mode 100644 sys/vops/ak/adivks.x create mode 100644 sys/vops/ak/adivkx.x create mode 100644 sys/vops/ak/adivl.x create mode 100644 sys/vops/ak/adivr.x create mode 100644 sys/vops/ak/adivs.x create mode 100644 sys/vops/ak/adivx.x create mode 100644 sys/vops/ak/adotd.x create mode 100644 sys/vops/ak/adoti.x create mode 100644 sys/vops/ak/adotl.x create mode 100644 sys/vops/ak/adotr.x create mode 100644 sys/vops/ak/adots.x create mode 100644 sys/vops/ak/adotx.x create mode 100644 sys/vops/ak/advzd.x create mode 100644 sys/vops/ak/advzi.x create mode 100644 sys/vops/ak/advzl.x create mode 100644 sys/vops/ak/advzr.x create mode 100644 sys/vops/ak/advzs.x create mode 100644 sys/vops/ak/advzx.x create mode 100644 sys/vops/ak/aexpd.x create mode 100644 sys/vops/ak/aexpi.x create mode 100644 sys/vops/ak/aexpkd.x create mode 100644 sys/vops/ak/aexpki.x create mode 100644 sys/vops/ak/aexpkl.x create mode 100644 sys/vops/ak/aexpkr.x create mode 100644 sys/vops/ak/aexpks.x create mode 100644 sys/vops/ak/aexpkx.x create mode 100644 sys/vops/ak/aexpl.x create mode 100644 sys/vops/ak/aexpr.x create mode 100644 sys/vops/ak/aexps.x create mode 100644 sys/vops/ak/aexpx.x create mode 100644 sys/vops/ak/afftrr.x create mode 100644 sys/vops/ak/afftrx.x create mode 100644 sys/vops/ak/afftxr.x create mode 100644 sys/vops/ak/afftxx.x create mode 100644 sys/vops/ak/agltc.x create mode 100644 sys/vops/ak/agltd.x create mode 100644 sys/vops/ak/aglti.x create mode 100644 sys/vops/ak/agltl.x create mode 100644 sys/vops/ak/agltr.x create mode 100644 sys/vops/ak/aglts.x create mode 100644 sys/vops/ak/agltx.x create mode 100644 sys/vops/ak/ahgmc.x create mode 100644 sys/vops/ak/ahgmd.x create mode 100644 sys/vops/ak/ahgmi.x create mode 100644 sys/vops/ak/ahgml.x create mode 100644 sys/vops/ak/ahgmr.x create mode 100644 sys/vops/ak/ahgms.x create mode 100644 sys/vops/ak/ahivc.x create mode 100644 sys/vops/ak/ahivd.x create mode 100644 sys/vops/ak/ahivi.x create mode 100644 sys/vops/ak/ahivl.x create mode 100644 sys/vops/ak/ahivr.x create mode 100644 sys/vops/ak/ahivs.x create mode 100644 sys/vops/ak/ahivx.x create mode 100644 sys/vops/ak/aiftrr.x create mode 100644 sys/vops/ak/aiftrx.x create mode 100644 sys/vops/ak/aiftxr.x create mode 100644 sys/vops/ak/aiftxx.x create mode 100644 sys/vops/ak/aimgd.x create mode 100644 sys/vops/ak/aimgi.x create mode 100644 sys/vops/ak/aimgl.x create mode 100644 sys/vops/ak/aimgr.x create mode 100644 sys/vops/ak/aimgs.x create mode 100644 sys/vops/ak/mkpkg create mode 100644 sys/vops/alan.gx create mode 100644 sys/vops/alank.gx create mode 100644 sys/vops/alim.gx create mode 100644 sys/vops/alln.gx create mode 100644 sys/vops/alog.gx create mode 100644 sys/vops/alor.gx create mode 100644 sys/vops/alork.gx create mode 100644 sys/vops/alov.gx create mode 100644 sys/vops/alta.gx create mode 100644 sys/vops/altm.gx create mode 100644 sys/vops/altr.gx create mode 100644 sys/vops/alui.gx create mode 100644 sys/vops/alut.gx create mode 100644 sys/vops/amag.gx create mode 100644 sys/vops/amap.gx create mode 100644 sys/vops/amax.gx create mode 100644 sys/vops/amaxk.gx create mode 100644 sys/vops/amed.gx create mode 100644 sys/vops/amed3.gx create mode 100644 sys/vops/amed4.gx create mode 100644 sys/vops/amed5.gx create mode 100644 sys/vops/amgs.gx create mode 100644 sys/vops/amin.gx create mode 100644 sys/vops/amink.gx create mode 100644 sys/vops/amod.gx create mode 100644 sys/vops/amodk.gx create mode 100644 sys/vops/amov.gx create mode 100644 sys/vops/amovk.gx create mode 100644 sys/vops/amul.gx create mode 100644 sys/vops/amulk.gx create mode 100644 sys/vops/aneg.gx create mode 100644 sys/vops/anot.gx create mode 100644 sys/vops/apkx.gx create mode 100644 sys/vops/apol.gx create mode 100644 sys/vops/apow.gx create mode 100644 sys/vops/apowk.gx create mode 100644 sys/vops/arav.gx create mode 100644 sys/vops/arcp.gx create mode 100644 sys/vops/arcz.gx create mode 100644 sys/vops/argt.gx create mode 100644 sys/vops/arlt.gx create mode 100644 sys/vops/asel.gx create mode 100644 sys/vops/aselk.gx create mode 100644 sys/vops/asok.gx create mode 100644 sys/vops/asqr.gx create mode 100644 sys/vops/asrt.gx create mode 100644 sys/vops/assq.gx create mode 100644 sys/vops/asub.gx create mode 100644 sys/vops/asubk.gx create mode 100644 sys/vops/asum.gx create mode 100644 sys/vops/aupx.gx create mode 100644 sys/vops/aveq.gx create mode 100644 sys/vops/awsu.gx create mode 100644 sys/vops/awvg.gx create mode 100644 sys/vops/axor.gx create mode 100644 sys/vops/axork.gx create mode 100644 sys/vops/doc/vops.hlp create mode 100644 sys/vops/fftr.f create mode 100644 sys/vops/fftx.f create mode 100644 sys/vops/lz/alani.x create mode 100644 sys/vops/lz/alanki.x create mode 100644 sys/vops/lz/alankl.x create mode 100644 sys/vops/lz/alanks.x create mode 100644 sys/vops/lz/alanl.x create mode 100644 sys/vops/lz/alans.x create mode 100644 sys/vops/lz/alimc.x create mode 100644 sys/vops/lz/alimd.x create mode 100644 sys/vops/lz/alimi.x create mode 100644 sys/vops/lz/aliml.x create mode 100644 sys/vops/lz/alimr.x create mode 100644 sys/vops/lz/alims.x create mode 100644 sys/vops/lz/alimx.x create mode 100644 sys/vops/lz/allnd.x create mode 100644 sys/vops/lz/allni.x create mode 100644 sys/vops/lz/allnl.x create mode 100644 sys/vops/lz/allnr.x create mode 100644 sys/vops/lz/allns.x create mode 100644 sys/vops/lz/allnx.x create mode 100644 sys/vops/lz/alogd.x create mode 100644 sys/vops/lz/alogi.x create mode 100644 sys/vops/lz/alogl.x create mode 100644 sys/vops/lz/alogr.x create mode 100644 sys/vops/lz/alogs.x create mode 100644 sys/vops/lz/alogx.x create mode 100644 sys/vops/lz/alori.x create mode 100644 sys/vops/lz/alorki.x create mode 100644 sys/vops/lz/alorkl.x create mode 100644 sys/vops/lz/alorks.x create mode 100644 sys/vops/lz/alorl.x create mode 100644 sys/vops/lz/alors.x create mode 100644 sys/vops/lz/alovc.x create mode 100644 sys/vops/lz/alovd.x create mode 100644 sys/vops/lz/alovi.x create mode 100644 sys/vops/lz/alovl.x create mode 100644 sys/vops/lz/alovr.x create mode 100644 sys/vops/lz/alovs.x create mode 100644 sys/vops/lz/alovx.x create mode 100644 sys/vops/lz/altad.x create mode 100644 sys/vops/lz/altai.x create mode 100644 sys/vops/lz/altal.x create mode 100644 sys/vops/lz/altar.x create mode 100644 sys/vops/lz/altas.x create mode 100644 sys/vops/lz/altax.x create mode 100644 sys/vops/lz/altmd.x create mode 100644 sys/vops/lz/altmi.x create mode 100644 sys/vops/lz/altml.x create mode 100644 sys/vops/lz/altmr.x create mode 100644 sys/vops/lz/altms.x create mode 100644 sys/vops/lz/altmx.x create mode 100644 sys/vops/lz/altrd.x create mode 100644 sys/vops/lz/altri.x create mode 100644 sys/vops/lz/altrl.x create mode 100644 sys/vops/lz/altrr.x create mode 100644 sys/vops/lz/altrs.x create mode 100644 sys/vops/lz/altrx.x create mode 100644 sys/vops/lz/aluid.x create mode 100644 sys/vops/lz/aluii.x create mode 100644 sys/vops/lz/aluil.x create mode 100644 sys/vops/lz/aluir.x create mode 100644 sys/vops/lz/aluis.x create mode 100644 sys/vops/lz/alutc.x create mode 100644 sys/vops/lz/alutd.x create mode 100644 sys/vops/lz/aluti.x create mode 100644 sys/vops/lz/alutl.x create mode 100644 sys/vops/lz/alutr.x create mode 100644 sys/vops/lz/aluts.x create mode 100644 sys/vops/lz/amagd.x create mode 100644 sys/vops/lz/amagi.x create mode 100644 sys/vops/lz/amagl.x create mode 100644 sys/vops/lz/amagr.x create mode 100644 sys/vops/lz/amags.x create mode 100644 sys/vops/lz/amagx.x create mode 100644 sys/vops/lz/amapd.x create mode 100644 sys/vops/lz/amapi.x create mode 100644 sys/vops/lz/amapl.x create mode 100644 sys/vops/lz/amapr.x create mode 100644 sys/vops/lz/amaps.x create mode 100644 sys/vops/lz/amaxc.x create mode 100644 sys/vops/lz/amaxd.x create mode 100644 sys/vops/lz/amaxi.x create mode 100644 sys/vops/lz/amaxkc.x create mode 100644 sys/vops/lz/amaxkd.x create mode 100644 sys/vops/lz/amaxki.x create mode 100644 sys/vops/lz/amaxkl.x create mode 100644 sys/vops/lz/amaxkr.x create mode 100644 sys/vops/lz/amaxks.x create mode 100644 sys/vops/lz/amaxkx.x create mode 100644 sys/vops/lz/amaxl.x create mode 100644 sys/vops/lz/amaxr.x create mode 100644 sys/vops/lz/amaxs.x create mode 100644 sys/vops/lz/amaxx.x create mode 100644 sys/vops/lz/amed3c.x create mode 100644 sys/vops/lz/amed3d.x create mode 100644 sys/vops/lz/amed3i.x create mode 100644 sys/vops/lz/amed3l.x create mode 100644 sys/vops/lz/amed3r.x create mode 100644 sys/vops/lz/amed3s.x create mode 100644 sys/vops/lz/amed4c.x create mode 100644 sys/vops/lz/amed4d.x create mode 100644 sys/vops/lz/amed4i.x create mode 100644 sys/vops/lz/amed4l.x create mode 100644 sys/vops/lz/amed4r.x create mode 100644 sys/vops/lz/amed4s.x create mode 100644 sys/vops/lz/amed5c.x create mode 100644 sys/vops/lz/amed5d.x create mode 100644 sys/vops/lz/amed5i.x create mode 100644 sys/vops/lz/amed5l.x create mode 100644 sys/vops/lz/amed5r.x create mode 100644 sys/vops/lz/amed5s.x create mode 100644 sys/vops/lz/amedc.x create mode 100644 sys/vops/lz/amedd.x create mode 100644 sys/vops/lz/amedi.x create mode 100644 sys/vops/lz/amedl.x create mode 100644 sys/vops/lz/amedr.x create mode 100644 sys/vops/lz/ameds.x create mode 100644 sys/vops/lz/amedx.x create mode 100644 sys/vops/lz/amgsd.x create mode 100644 sys/vops/lz/amgsi.x create mode 100644 sys/vops/lz/amgsl.x create mode 100644 sys/vops/lz/amgsr.x create mode 100644 sys/vops/lz/amgss.x create mode 100644 sys/vops/lz/amgsx.x create mode 100644 sys/vops/lz/aminc.x create mode 100644 sys/vops/lz/amind.x create mode 100644 sys/vops/lz/amini.x create mode 100644 sys/vops/lz/aminkc.x create mode 100644 sys/vops/lz/aminkd.x create mode 100644 sys/vops/lz/aminki.x create mode 100644 sys/vops/lz/aminkl.x create mode 100644 sys/vops/lz/aminkr.x create mode 100644 sys/vops/lz/aminks.x create mode 100644 sys/vops/lz/aminkx.x create mode 100644 sys/vops/lz/aminl.x create mode 100644 sys/vops/lz/aminr.x create mode 100644 sys/vops/lz/amins.x create mode 100644 sys/vops/lz/aminx.x create mode 100644 sys/vops/lz/amodd.x create mode 100644 sys/vops/lz/amodi.x create mode 100644 sys/vops/lz/amodkd.x create mode 100644 sys/vops/lz/amodki.x create mode 100644 sys/vops/lz/amodkl.x create mode 100644 sys/vops/lz/amodkr.x create mode 100644 sys/vops/lz/amodks.x create mode 100644 sys/vops/lz/amodl.x create mode 100644 sys/vops/lz/amodr.x create mode 100644 sys/vops/lz/amods.x create mode 100644 sys/vops/lz/amovc.x create mode 100644 sys/vops/lz/amovd.x create mode 100644 sys/vops/lz/amovi.x create mode 100644 sys/vops/lz/amovkc.x create mode 100644 sys/vops/lz/amovkd.x create mode 100644 sys/vops/lz/amovki.x create mode 100644 sys/vops/lz/amovkl.x create mode 100644 sys/vops/lz/amovkr.x create mode 100644 sys/vops/lz/amovks.x create mode 100644 sys/vops/lz/amovkx.x create mode 100644 sys/vops/lz/amovl.x create mode 100644 sys/vops/lz/amovr.x create mode 100644 sys/vops/lz/amovs.x create mode 100644 sys/vops/lz/amovx.x create mode 100644 sys/vops/lz/amuld.x create mode 100644 sys/vops/lz/amuli.x create mode 100644 sys/vops/lz/amulkd.x create mode 100644 sys/vops/lz/amulki.x create mode 100644 sys/vops/lz/amulkl.x create mode 100644 sys/vops/lz/amulkr.x create mode 100644 sys/vops/lz/amulks.x create mode 100644 sys/vops/lz/amulkx.x create mode 100644 sys/vops/lz/amull.x create mode 100644 sys/vops/lz/amulr.x create mode 100644 sys/vops/lz/amuls.x create mode 100644 sys/vops/lz/amulx.x create mode 100644 sys/vops/lz/anegd.x create mode 100644 sys/vops/lz/anegi.x create mode 100644 sys/vops/lz/anegl.x create mode 100644 sys/vops/lz/anegr.x create mode 100644 sys/vops/lz/anegs.x create mode 100644 sys/vops/lz/anegx.x create mode 100644 sys/vops/lz/anoti.x create mode 100644 sys/vops/lz/anotl.x create mode 100644 sys/vops/lz/anots.x create mode 100644 sys/vops/lz/apkxd.x create mode 100644 sys/vops/lz/apkxi.x create mode 100644 sys/vops/lz/apkxl.x create mode 100644 sys/vops/lz/apkxr.x create mode 100644 sys/vops/lz/apkxs.x create mode 100644 sys/vops/lz/apkxx.x create mode 100644 sys/vops/lz/apold.x create mode 100644 sys/vops/lz/apolr.x create mode 100644 sys/vops/lz/apowd.x create mode 100644 sys/vops/lz/apowi.x create mode 100644 sys/vops/lz/apowkd.x create mode 100644 sys/vops/lz/apowki.x create mode 100644 sys/vops/lz/apowkl.x create mode 100644 sys/vops/lz/apowkr.x create mode 100644 sys/vops/lz/apowks.x create mode 100644 sys/vops/lz/apowkx.x create mode 100644 sys/vops/lz/apowl.x create mode 100644 sys/vops/lz/apowr.x create mode 100644 sys/vops/lz/apows.x create mode 100644 sys/vops/lz/apowx.x create mode 100644 sys/vops/lz/aravd.x create mode 100644 sys/vops/lz/aravi.x create mode 100644 sys/vops/lz/aravl.x create mode 100644 sys/vops/lz/aravr.x create mode 100644 sys/vops/lz/aravs.x create mode 100644 sys/vops/lz/aravx.x create mode 100644 sys/vops/lz/arcpd.x create mode 100644 sys/vops/lz/arcpi.x create mode 100644 sys/vops/lz/arcpl.x create mode 100644 sys/vops/lz/arcpr.x create mode 100644 sys/vops/lz/arcps.x create mode 100644 sys/vops/lz/arcpx.x create mode 100644 sys/vops/lz/arczd.x create mode 100644 sys/vops/lz/arczi.x create mode 100644 sys/vops/lz/arczl.x create mode 100644 sys/vops/lz/arczr.x create mode 100644 sys/vops/lz/arczs.x create mode 100644 sys/vops/lz/arczx.x create mode 100644 sys/vops/lz/argtd.x create mode 100644 sys/vops/lz/argti.x create mode 100644 sys/vops/lz/argtl.x create mode 100644 sys/vops/lz/argtr.x create mode 100644 sys/vops/lz/argts.x create mode 100644 sys/vops/lz/argtx.x create mode 100644 sys/vops/lz/arltd.x create mode 100644 sys/vops/lz/arlti.x create mode 100644 sys/vops/lz/arltl.x create mode 100644 sys/vops/lz/arltr.x create mode 100644 sys/vops/lz/arlts.x create mode 100644 sys/vops/lz/arltx.x create mode 100644 sys/vops/lz/aselc.x create mode 100644 sys/vops/lz/aseld.x create mode 100644 sys/vops/lz/aseli.x create mode 100644 sys/vops/lz/aselkc.x create mode 100644 sys/vops/lz/aselkd.x create mode 100644 sys/vops/lz/aselki.x create mode 100644 sys/vops/lz/aselkl.x create mode 100644 sys/vops/lz/aselkr.x create mode 100644 sys/vops/lz/aselks.x create mode 100644 sys/vops/lz/aselkx.x create mode 100644 sys/vops/lz/asell.x create mode 100644 sys/vops/lz/aselr.x create mode 100644 sys/vops/lz/asels.x create mode 100644 sys/vops/lz/aselx.x create mode 100644 sys/vops/lz/asokc.x create mode 100644 sys/vops/lz/asokd.x create mode 100644 sys/vops/lz/asoki.x create mode 100644 sys/vops/lz/asokl.x create mode 100644 sys/vops/lz/asokr.x create mode 100644 sys/vops/lz/asoks.x create mode 100644 sys/vops/lz/asokx.x create mode 100644 sys/vops/lz/asqrd.x create mode 100644 sys/vops/lz/asqri.x create mode 100644 sys/vops/lz/asqrl.x create mode 100644 sys/vops/lz/asqrr.x create mode 100644 sys/vops/lz/asqrs.x create mode 100644 sys/vops/lz/asqrx.x create mode 100644 sys/vops/lz/asrtc.x create mode 100644 sys/vops/lz/asrtd.x create mode 100644 sys/vops/lz/asrti.x create mode 100644 sys/vops/lz/asrtl.x create mode 100644 sys/vops/lz/asrtr.x create mode 100644 sys/vops/lz/asrts.x create mode 100644 sys/vops/lz/asrtx.x create mode 100644 sys/vops/lz/assqd.x create mode 100644 sys/vops/lz/assqi.x create mode 100644 sys/vops/lz/assql.x create mode 100644 sys/vops/lz/assqr.x create mode 100644 sys/vops/lz/assqs.x create mode 100644 sys/vops/lz/assqx.x create mode 100644 sys/vops/lz/asubd.x create mode 100644 sys/vops/lz/asubi.x create mode 100644 sys/vops/lz/asubkd.x create mode 100644 sys/vops/lz/asubki.x create mode 100644 sys/vops/lz/asubkl.x create mode 100644 sys/vops/lz/asubkr.x create mode 100644 sys/vops/lz/asubks.x create mode 100644 sys/vops/lz/asubkx.x create mode 100644 sys/vops/lz/asubl.x create mode 100644 sys/vops/lz/asubr.x create mode 100644 sys/vops/lz/asubs.x create mode 100644 sys/vops/lz/asubx.x create mode 100644 sys/vops/lz/asumd.x create mode 100644 sys/vops/lz/asumi.x create mode 100644 sys/vops/lz/asuml.x create mode 100644 sys/vops/lz/asumr.x create mode 100644 sys/vops/lz/asums.x create mode 100644 sys/vops/lz/asumx.x create mode 100644 sys/vops/lz/aupxd.x create mode 100644 sys/vops/lz/aupxi.x create mode 100644 sys/vops/lz/aupxl.x create mode 100644 sys/vops/lz/aupxr.x create mode 100644 sys/vops/lz/aupxs.x create mode 100644 sys/vops/lz/aupxx.x create mode 100644 sys/vops/lz/aveqc.x create mode 100644 sys/vops/lz/aveqd.x create mode 100644 sys/vops/lz/aveqi.x create mode 100644 sys/vops/lz/aveql.x create mode 100644 sys/vops/lz/aveqr.x create mode 100644 sys/vops/lz/aveqs.x create mode 100644 sys/vops/lz/aveqx.x create mode 100644 sys/vops/lz/awsud.x create mode 100644 sys/vops/lz/awsui.x create mode 100644 sys/vops/lz/awsul.x create mode 100644 sys/vops/lz/awsur.x create mode 100644 sys/vops/lz/awsus.x create mode 100644 sys/vops/lz/awsux.x create mode 100644 sys/vops/lz/awvgd.x create mode 100644 sys/vops/lz/awvgi.x create mode 100644 sys/vops/lz/awvgl.x create mode 100644 sys/vops/lz/awvgr.x create mode 100644 sys/vops/lz/awvgs.x create mode 100644 sys/vops/lz/awvgx.x create mode 100644 sys/vops/lz/axori.x create mode 100644 sys/vops/lz/axorki.x create mode 100644 sys/vops/lz/axorkl.x create mode 100644 sys/vops/lz/axorks.x create mode 100644 sys/vops/lz/axorl.x create mode 100644 sys/vops/lz/axors.x create mode 100644 sys/vops/lz/mkpkg create mode 100644 sys/vops/mkpkg create mode 100644 sys/vops/vops.calls create mode 100644 sys/vops/vops.men create mode 100644 sys/vops/vops.syn create mode 100644 sys/vops/zzdebug.x (limited to 'sys') diff --git a/sys/INDEX b/sys/INDEX new file mode 100644 index 00000000..1ef83979 --- /dev/null +++ b/sys/INDEX @@ -0,0 +1,3884 @@ +VLIBINIT 1 ../unix/os/zshlib.c void VLIBINIT() +ZARDBF 3 ../unix/os/zfiobf.c ZARDBF (chan, buf, maxbytes, offset) +ZARDKS 14 ../unix/os/zfioks.c ZARDKS (chan, buf, totbytes, loffset) +ZARDLP 3 ../unix/os/zfiolp.c ZARDLP (chan, buf, maxbytes, offset) +ZARDND 9 ../unix/os/zfiond.c ZARDND (chan, buf, maxbytes, offset) +ZARDPL 3 ../unix/os/zfiopl.c ZARDPL (chan, buf, maxbytes, offset) +ZARDPR 4 ../unix/os/zfiopr.c ZARDPR (chan, buf, maxbytes, loffset) +ZARDSF 2 ../unix/os/zfiosf.c ZARDSF (chan, buf, maxbytes, offset) +ZAWRBF 3 ../unix/os/zfiobf.c ZAWRBF (chan, buf, nbytes, offset) +ZAWRKS 15 ../unix/os/zfioks.c ZAWRKS (chan, buf, totbytes, loffset) +ZAWRLP 4 ../unix/os/zfiolp.c ZAWRLP (chan, buf, nbytes, offset) +ZAWRND 10 ../unix/os/zfiond.c ZAWRND (chan, buf, nbytes, offset) +ZAWRPL 3 ../unix/os/zfiopl.c ZAWRPL (chan, buf, nbytes, offset) +ZAWRPR 6 ../unix/os/zfiopr.c ZAWRPR (chan, buf, nbytes, loffset) +ZAWRSF 2 ../unix/os/zfiosf.c ZAWRSF (chan, buf, nbytes, offset) +ZAWSET 1 ../unix/os/zawset.c ZAWSET (best_size, new_size, old_size, max_size) +ZAWTBF 4 ../unix/os/zfiobf.c ZAWTBF (fd, status) +ZAWTKS 16 ../unix/os/zfioks.c ZAWTKS (chan, status) +ZAWTLP 4 ../unix/os/zfiolp.c ZAWTLP (chan, status) +ZAWTND 10 ../unix/os/zfiond.c ZAWTND (fd, status) +ZAWTPL 4 ../unix/os/zfiopl.c ZAWTPL (chan, status) +ZAWTPR 7 ../unix/os/zfiopr.c ZAWTPR (chan, status) +ZAWTSF 2 ../unix/os/zfiosf.c ZAWTSF (fd, status) +ZCALL0 1 ../unix/os/zcall.c ZCALL0 (proc) +ZCALL1 1 ../unix/os/zcall.c ZCALL1 (proc, arg1) +ZCALL2 1 ../unix/os/zcall.c ZCALL2 (proc, arg1, arg2) +ZCALL3 1 ../unix/os/zcall.c ZCALL3 (proc, arg1, arg2, arg3) +ZCALL4 1 ../unix/os/zcall.c ZCALL4 (proc, arg1, arg2, arg3, arg4) +ZCALL5 1 ../unix/os/zcall.c ZCALL5 (proc, arg1, arg2, arg3, arg4, arg5) +ZCALL6 1 ../unix/os/zcall.c ZCALL6 (proc, arg1, arg2, arg3, arg4, arg5, arg6) +ZCALL7 2 ../unix/os/zcall.c ZCALL7 (proc, arg1, arg2, arg3, arg4, arg5, arg6, / +ZCALL8 2 ../unix/os/zcall.c ZCALL8 (proc, arg1, arg2, arg3, arg4, arg5, arg6, / +ZCALL9 2 ../unix/os/zcall.c ZCALL9 (proc, arg1, arg2, arg3, arg4, arg5, arg6, / +ZCALLA 2 ../unix/os/zcall.c ZCALLA (proc, arg1, arg2, arg3, arg4, arg5, arg6, / +ZCLCPR 3 ../unix/os/zfiopr.c ZCLCPR (pid, exit_status) +ZCLDIR 3 ../unix/os/zopdir.c ZCLDIR (chan, status) +ZCLDPR 3 ../unix/os/zopdpr.c ZCLDPR (jobcode, killflag, exit_status) +ZCLSBF 3 ../unix/os/zfiobf.c ZCLSBF (fd, status) +ZCLSKS 13 ../unix/os/zfioks.c ZCLSKS (chan, status) +ZCLSLP 2 ../unix/os/zfiolp.c ZCLSLP (chan, status) +ZCLSND 8 ../unix/os/zfiond.c ZCLSND (fd, status) +ZCLSPL 2 ../unix/os/zfiopl.c ZCLSPL (chan, status) +ZCLSSF 1 ../unix/os/zfiosf.c ZCLSSF (fd, status) +ZCLSTX 4 ../unix/os/zfiotx.c ZCLSTX (fd, status) +ZCLSTY 1 ../unix/os/zfioty.c ZCLSTY (fd, status) +ZDOJMP 1 ../unix/os/zdojmp.c ZDOJMP (jmpbuf, status) +ZDVALL 1 ../unix/os/zalloc.c ZDVALL (aliases, allflg, status) +ZDVOWN 2 ../unix/os/zalloc.c ZDVOWN (device, owner, maxch, status) +ZFACSS 1 ../unix/os/zfacss.c ZFACSS (fname, mode, type, status) +ZFALOC 1 ../unix/os/zfaloc.c ZFALOC (fname, nbytes, status) +ZFCHDR 1 ../unix/os/zfchdr.c ZFCHDR (newdir, status) +ZFDELE 1 ../unix/os/zfdele.c ZFDELE (fname, status) +ZFGCWD 1 ../unix/os/zfgcwd.c ZFGCWD (outstr, maxch, status) +ZFINFO 1 ../unix/os/zfinfo.c ZFINFO (fname, finfo_struct, status) +ZFLSTX 5 ../unix/os/zfiotx.c ZFLSTX (fd, status) +ZFLSTY 1 ../unix/os/zfioty.c ZFLSTY (fd, status) +ZFMKCP 1 ../unix/os/zfmkcp.c ZFMKCP (osfn, new_osfn, status) +ZFMKDR 1 ../unix/os/zfmkdr.c ZFMKDR (newdir, status) +ZFNBRK 1 ../unix/os/zfnbrk.c ZFNBRK (vfn, uroot_offset, uextn_offset) +ZFPATH 1 ../unix/os/zfpath.c ZFPATH (osfn, pathname, maxch, nchars) +ZFPROT 1 ../unix/os/zfprot.c ZFPROT (fname, action, status) +ZFRNAM 1 ../unix/os/zfrnam.c ZFRNAM (oldname, newname, status) +ZFSUBD 1 ../unix/os/zfsubd.c ZFSUBD (osdir, maxch, subdir, nchars) +ZFUNC0 1 ../unix/os/zfunc.c ZFUNC0 (proc) +ZFUNC1 1 ../unix/os/zfunc.c ZFUNC1 (proc, arg1) +ZFUNC2 1 ../unix/os/zfunc.c ZFUNC2 (proc, arg1, arg2) +ZFUNC3 1 ../unix/os/zfunc.c ZFUNC3 (proc, arg1, arg2, arg3) +ZFUNC4 1 ../unix/os/zfunc.c ZFUNC4 (proc, arg1, arg2, arg3, arg4) +ZFUNC5 1 ../unix/os/zfunc.c ZFUNC5 (proc, arg1, arg2, arg3, arg4, arg5) +ZFUNC6 2 ../unix/os/zfunc.c ZFUNC6 (proc, arg1, arg2, arg3, arg4, arg5, arg6) +ZFUNC7 2 ../unix/os/zfunc.c ZFUNC7 (proc, arg1, arg2, arg3, arg4, arg5, arg6, / +ZFUNC8 2 ../unix/os/zfunc.c ZFUNC8 (proc, arg1, arg2, arg3, arg4, arg5, arg6, / +ZFUNC9 2 ../unix/os/zfunc.c ZFUNC9 (proc, arg1, arg2, arg3, arg4, arg5, arg6, / +ZFUNCA 2 ../unix/os/zfunc.c ZFUNCA (proc, arg1, arg2, arg3, arg4, arg5, arg6, / +ZFXDIR 1 ../unix/os/zfxdir.c ZFXDIR (osfn, osdir, maxch, nchars) +ZGCMDL 1 ../unix/os/zgcmdl.c ZGCMDL (cmd, maxch, status) +ZGETTX 5 ../unix/os/zfiotx.c ZGETTX (fd, buf, maxchars, status) +ZGETTY 2 ../unix/os/zfioty.c ZGETTY (fd, buf, maxchars, status) +ZGFDIR 3 ../unix/os/zopdir.c ZGFDIR (chan, outstr, maxch, status) +ZGHOST 1 ../unix/os/zghost.c ZGHOST (outstr, maxch) +ZGTENV 1 ../unix/os/zgtenv.c ZGTENV (envvar, outstr, maxch, status) +ZGTIME 1 ../unix/os/zgtime.c ZGTIME (clock_time, cpu_time) +ZGTPID 1 ../unix/os/zgtpid.c ZGTPID (pid) +ZINTPR 1 ../unix/os/zintpr.c ZINTPR (pid, exception, status) +ZLOCPR 1 ../unix/os/zlocpr.c ZLOCPR (proc, o_epa) +ZLOCVA 1 ../unix/os/zlocva.c ZLOCVA (variable, location) +ZMALOC 1 ../unix/os/zmaloc.c ZMALOC (buf, nbytes, status) +ZMFREE 1 ../unix/os/zmfree.c ZMFREE (buf, status) +ZNOTTX 8 ../unix/os/zfiotx.c ZNOTTX (fd, offset) +ZNOTTY 2 ../unix/os/zfioty.c ZNOTTY (fd, offset) +ZOPCPR 1 ../unix/os/zfiopr.c ZOPCPR (osfn, inchan, outchan, pid) +ZOPDIR 1 ../unix/os/zopdir.c ZOPDIR (fname, chan) +ZOPDPR 1 ../unix/os/zopdpr.c ZOPDPR (osfn, bkgfile, queue, jobcode) +ZOPNBF 1 ../unix/os/zfiobf.c ZOPNBF (osfn, mode, chan) +ZOPNKS 3 ../unix/os/zfioks.c ZOPNKS (x_server, mode, chan) +ZOPNLP 2 ../unix/os/zfiolp.c ZOPNLP (printer, mode, chan) +ZOPNND 2 ../unix/os/zfiond.c ZOPNND (pk_osfn, mode, chan) +ZOPNPL 2 ../unix/os/zfiopl.c ZOPNPL (plotter, mode, chan) +ZOPNSF 1 ../unix/os/zfiosf.c ZOPNSF (osfn, mode, chan) +ZOPNTX 2 ../unix/os/zfiotx.c ZOPNTX (osfn, mode, chan) +ZOPNTY 1 ../unix/os/zfioty.c ZOPNTY (osfn, mode, chan) +ZOSCMD 1 ../unix/os/zoscmd.c ZOSCMD (oscmd, stdin_file, stdout_file, stderr_fil/ +ZPANIC 1 ../unix/os/zpanic.c ZPANIC (errcode, errmsg) +ZPUTTX 8 ../unix/os/zfiotx.c ZPUTTX (fd, buf, nchars, status) +ZPUTTY 2 ../unix/os/zfioty.c ZPUTTY (fd, buf, nchars, status) +ZRALOC 1 ../unix/os/zraloc.c ZRALOC (buf, nbytes, status) +ZSEKTX 9 ../unix/os/zfiotx.c ZSEKTX (fd, znottx_offset, status) +ZSEKTY 2 ../unix/os/zfioty.c ZSEKTY (fd, znotty_offset, status) +ZSTTBF 4 ../unix/os/zfiobf.c ZSTTBF (fd, param, lvalue) +ZSTTKS 16 ../unix/os/zfioks.c ZSTTKS (chan, param, lvalue) +ZSTTLP 4 ../unix/os/zfiolp.c ZSTTLP (chan, param, lvalue) +ZSTTND 10 ../unix/os/zfiond.c ZSTTND (fd, param, lvalue) +ZSTTPL 4 ../unix/os/zfiopl.c ZSTTPL (chan, param, lvalue) +ZSTTPR 7 ../unix/os/zfiopr.c ZSTTPR (chan, param, lvalue) +ZSTTSF 2 ../unix/os/zfiosf.c ZSTTSF (fd, param, lvalue) +ZSTTTX 10 ../unix/os/zfiotx.c ZSTTTX (fd, param, value) +ZSTTTY 2 ../unix/os/zfioty.c ZSTTTY (fd, param, value) +ZWMSEC 1 ../unix/os/zwmsec.c ZWMSEC (msec) +ZXGMES 6 ../unix/os/zxwhen.c ZXGMES (os_exception, errmsg, maxch) +ZXWHEN 3 ../unix/os/zxwhen.c ZXWHEN (sig_code, epa, old_epa) +ZZCLMT 8 ../unix/os/zfiomt.c ZZCLMT (chan, devpos, o_status) +ZZOPMT 6 ../unix/os/zfiomt.c ZZOPMT (device, acmode, devcap, devpos, newfile, c/ +ZZRDMT 10 ../unix/os/zfiomt.c ZZRDMT (chan, buf, maxbytes, offset) +ZZRWMT 14 ../unix/os/zfiomt.c ZZRWMT (device, devcap, o_status) +ZZSETK 1 ../unix/os/zzsetk.c ZZSETK (ospn, osbfn, prtype, isatty, in, out) +ZZSTMT 14 ../unix/os/zfiomt.c ZZSTMT (chan, param, lvalue) +ZZSTOP 9 ../unix/os/zzstrt.c ZZSTOP() +ZZSTRT 2 ../unix/os/zzstrt.c ZZSTRT() +ZZWRMT 12 ../unix/os/zfiomt.c ZZWRMT (chan, buf, nbytes, offset) +ZZWTMT 12 ../unix/os/zfiomt.c ZZWTMT (chan, devpos, o_status) +_ev_loadcache 3 ../unix/os/zgtenv.c _ev_loadcache (fname) +_ev_scaniraf 2 ../unix/os/zgtenv.c _ev_scaniraf (envvar) +_ev_streq 4 ../unix/os/zgtenv.c _ev_streq (s1, s2, n) +_getfile 4 ../unix/os/zopdir.c _getfile (dir, outstr, maxch) +_u_fmode 5 ../unix/os/zfiobf.c _u_fmode (mode) +aabs 5 ./vops/aabs.gx procedure aabs$t (a, b, npix) +aabsd 5 ./vops/ak/aabsd.x procedure aabsd (a, b, npix) +aabsi 5 ./vops/ak/aabsi.x procedure aabsi (a, b, npix) +aabsl 5 ./vops/ak/aabsl.x procedure aabsl (a, b, npix) +aabsr 5 ./vops/ak/aabsr.x procedure aabsr (a, b, npix) +aabss 5 ./vops/ak/aabss.x procedure aabss (a, b, npix) +aabsx 5 ./vops/ak/aabsx.x procedure aabsx (a, b, npix) +aadd 5 ./vops/aadd.gx procedure aadd$t (a, b, c, npix) +aaddd 5 ./vops/ak/aaddd.x procedure aaddd (a, b, c, npix) +aaddi 5 ./vops/ak/aaddi.x procedure aaddi (a, b, c, npix) +aaddk 5 ./vops/aaddk.gx procedure aaddk$t (a, b, c, npix) +aaddkd 5 ./vops/ak/aaddkd.x procedure aaddkd (a, b, c, npix) +aaddki 5 ./vops/ak/aaddki.x procedure aaddki (a, b, c, npix) +aaddkl 5 ./vops/ak/aaddkl.x procedure aaddkl (a, b, c, npix) +aaddkr 5 ./vops/ak/aaddkr.x procedure aaddkr (a, b, c, npix) +aaddks 5 ./vops/ak/aaddks.x procedure aaddks (a, b, c, npix) +aaddkx 5 ./vops/ak/aaddkx.x procedure aaddkx (a, b, c, npix) +aaddl 5 ./vops/ak/aaddl.x procedure aaddl (a, b, c, npix) +aaddr 5 ./vops/ak/aaddr.x procedure aaddr (a, b, c, npix) +aadds 5 ./vops/ak/aadds.x procedure aadds (a, b, c, npix) +aaddx 5 ./vops/ak/aaddx.x procedure aaddx (a, b, c, npix) +aand 5 ./vops/aand.gx procedure aand$t (a, b, c, npix) +aandi 5 ./vops/ak/aandi.x procedure aandi (a, b, c, npix) +aandk 6 ./vops/aandk.gx procedure aandk$t (a, b, c, npix) +aandki 6 ./vops/ak/aandki.x procedure aandki (a, b, c, npix) +aandkl 6 ./vops/ak/aandkl.x procedure aandkl (a, b, c, npix) +aandks 6 ./vops/ak/aandks.x procedure aandks (a, b, c, npix) +aandl 5 ./vops/ak/aandl.x procedure aandl (a, b, c, npix) +aands 5 ./vops/ak/aands.x procedure aands (a, b, c, npix) +aavg 6 ./vops/aavg.gx procedure aavg$t (a, npix, mean, sigma) +aavgd 6 ./vops/ak/aavgd.x procedure aavgd (a, npix, mean, sigma) +aavgi 6 ./vops/ak/aavgi.x procedure aavgi (a, npix, mean, sigma) +aavgl 6 ./vops/ak/aavgl.x procedure aavgl (a, npix, mean, sigma) +aavgr 6 ./vops/ak/aavgr.x procedure aavgr (a, npix, mean, sigma) +aavgs 6 ./vops/ak/aavgs.x procedure aavgs (a, npix, mean, sigma) +aavgx 6 ./vops/ak/aavgx.x procedure aavgx (a, npix, mean, sigma) +abav 7 ./vops/abav.gx procedure abav$t (a, b, nblocks, npix_per_block) +abavd 7 ./vops/ak/abavd.x procedure abavd (a, b, nblocks, npix_per_block) +abavi 7 ./vops/ak/abavi.x procedure abavi (a, b, nblocks, npix_per_block) +abavl 7 ./vops/ak/abavl.x procedure abavl (a, b, nblocks, npix_per_block) +abavr 7 ./vops/ak/abavr.x procedure abavr (a, b, nblocks, npix_per_block) +abavs 7 ./vops/ak/abavs.x procedure abavs (a, b, nblocks, npix_per_block) +abavx 7 ./vops/ak/abavx.x procedure abavx (a, b, nblocks, npix_per_block) +abeq 6 ./vops/abeq.gx procedure abeq$t (a, b, c, npix) +abeqc 6 ./vops/ak/abeqc.x procedure abeqc (a, b, c, npix) +abeqd 6 ./vops/ak/abeqd.x procedure abeqd (a, b, c, npix) +abeqi 6 ./vops/ak/abeqi.x procedure abeqi (a, b, c, npix) +abeqk 6 ./vops/abeqk.gx procedure abeqk$t (a, b, c, npix) +abeqkc 6 ./vops/ak/abeqkc.x procedure abeqkc (a, b, c, npix) +abeqkd 6 ./vops/ak/abeqkd.x procedure abeqkd (a, b, c, npix) +abeqki 6 ./vops/ak/abeqki.x procedure abeqki (a, b, c, npix) +abeqkl 6 ./vops/ak/abeqkl.x procedure abeqkl (a, b, c, npix) +abeqkr 6 ./vops/ak/abeqkr.x procedure abeqkr (a, b, c, npix) +abeqks 6 ./vops/ak/abeqks.x procedure abeqks (a, b, c, npix) +abeqkx 6 ./vops/ak/abeqkx.x procedure abeqkx (a, b, c, npix) +abeql 6 ./vops/ak/abeql.x procedure abeql (a, b, c, npix) +abeqr 6 ./vops/ak/abeqr.x procedure abeqr (a, b, c, npix) +abeqs 6 ./vops/ak/abeqs.x procedure abeqs (a, b, c, npix) +abeqx 6 ./vops/ak/abeqx.x procedure abeqx (a, b, c, npix) +abge 6 ./vops/abge.gx procedure abge$t (a, b, c, npix) +abgec 6 ./vops/ak/abgec.x procedure abgec (a, b, c, npix) +abged 6 ./vops/ak/abged.x procedure abged (a, b, c, npix) +abgei 6 ./vops/ak/abgei.x procedure abgei (a, b, c, npix) +abgek 6 ./vops/abgek.gx procedure abgek$t (a, b, c, npix) +abgekc 6 ./vops/ak/abgekc.x procedure abgekc (a, b, c, npix) +abgekd 6 ./vops/ak/abgekd.x procedure abgekd (a, b, c, npix) +abgeki 6 ./vops/ak/abgeki.x procedure abgeki (a, b, c, npix) +abgekl 6 ./vops/ak/abgekl.x procedure abgekl (a, b, c, npix) +abgekr 6 ./vops/ak/abgekr.x procedure abgekr (a, b, c, npix) +abgeks 6 ./vops/ak/abgeks.x procedure abgeks (a, b, c, npix) +abgekx 6 ./vops/ak/abgekx.x procedure abgekx (a, b, c, npix) +abgel 6 ./vops/ak/abgel.x procedure abgel (a, b, c, npix) +abger 6 ./vops/ak/abger.x procedure abger (a, b, c, npix) +abges 6 ./vops/ak/abges.x procedure abges (a, b, c, npix) +abgex 6 ./vops/ak/abgex.x procedure abgex (a, b, c, npix) +abgt 6 ./vops/abgt.gx procedure abgt$t (a, b, c, npix) +abgtc 6 ./vops/ak/abgtc.x procedure abgtc (a, b, c, npix) +abgtd 6 ./vops/ak/abgtd.x procedure abgtd (a, b, c, npix) +abgti 6 ./vops/ak/abgti.x procedure abgti (a, b, c, npix) +abgtk 6 ./vops/abgtk.gx procedure abgtk$t (a, b, c, npix) +abgtkc 6 ./vops/ak/abgtkc.x procedure abgtkc (a, b, c, npix) +abgtkd 6 ./vops/ak/abgtkd.x procedure abgtkd (a, b, c, npix) +abgtki 6 ./vops/ak/abgtki.x procedure abgtki (a, b, c, npix) +abgtkl 6 ./vops/ak/abgtkl.x procedure abgtkl (a, b, c, npix) +abgtkr 6 ./vops/ak/abgtkr.x procedure abgtkr (a, b, c, npix) +abgtks 6 ./vops/ak/abgtks.x procedure abgtks (a, b, c, npix) +abgtkx 6 ./vops/ak/abgtkx.x procedure abgtkx (a, b, c, npix) +abgtl 6 ./vops/ak/abgtl.x procedure abgtl (a, b, c, npix) +abgtr 6 ./vops/ak/abgtr.x procedure abgtr (a, b, c, npix) +abgts 6 ./vops/ak/abgts.x procedure abgts (a, b, c, npix) +abgtx 6 ./vops/ak/abgtx.x procedure abgtx (a, b, c, npix) +able 6 ./vops/able.gx procedure able$t (a, b, c, npix) +ablec 6 ./vops/ak/ablec.x procedure ablec (a, b, c, npix) +abled 6 ./vops/ak/abled.x procedure abled (a, b, c, npix) +ablei 6 ./vops/ak/ablei.x procedure ablei (a, b, c, npix) +ablek 6 ./vops/ablek.gx procedure ablek$t (a, b, c, npix) +ablekc 6 ./vops/ak/ablekc.x procedure ablekc (a, b, c, npix) +ablekd 6 ./vops/ak/ablekd.x procedure ablekd (a, b, c, npix) +ableki 6 ./vops/ak/ableki.x procedure ableki (a, b, c, npix) +ablekl 6 ./vops/ak/ablekl.x procedure ablekl (a, b, c, npix) +ablekr 6 ./vops/ak/ablekr.x procedure ablekr (a, b, c, npix) +ableks 6 ./vops/ak/ableks.x procedure ableks (a, b, c, npix) +ablekx 6 ./vops/ak/ablekx.x procedure ablekx (a, b, c, npix) +ablel 6 ./vops/ak/ablel.x procedure ablel (a, b, c, npix) +abler 6 ./vops/ak/abler.x procedure abler (a, b, c, npix) +ables 6 ./vops/ak/ables.x procedure ables (a, b, c, npix) +ablex 6 ./vops/ak/ablex.x procedure ablex (a, b, c, npix) +ablt 6 ./vops/ablt.gx procedure ablt$t (a, b, c, npix) +abltc 6 ./vops/ak/abltc.x procedure abltc (a, b, c, npix) +abltd 6 ./vops/ak/abltd.x procedure abltd (a, b, c, npix) +ablti 6 ./vops/ak/ablti.x procedure ablti (a, b, c, npix) +abltk 6 ./vops/abltk.gx procedure abltk$t (a, b, c, npix) +abltkc 6 ./vops/ak/abltkc.x procedure abltkc (a, b, c, npix) +abltkd 6 ./vops/ak/abltkd.x procedure abltkd (a, b, c, npix) +abltki 6 ./vops/ak/abltki.x procedure abltki (a, b, c, npix) +abltkl 6 ./vops/ak/abltkl.x procedure abltkl (a, b, c, npix) +abltkr 6 ./vops/ak/abltkr.x procedure abltkr (a, b, c, npix) +abltks 6 ./vops/ak/abltks.x procedure abltks (a, b, c, npix) +abltkx 6 ./vops/ak/abltkx.x procedure abltkx (a, b, c, npix) +abltl 6 ./vops/ak/abltl.x procedure abltl (a, b, c, npix) +abltr 6 ./vops/ak/abltr.x procedure abltr (a, b, c, npix) +ablts 6 ./vops/ak/ablts.x procedure ablts (a, b, c, npix) +abltx 6 ./vops/ak/abltx.x procedure abltx (a, b, c, npix) +abne 6 ./vops/abne.gx procedure abne$t (a, b, c, npix) +abnec 6 ./vops/ak/abnec.x procedure abnec (a, b, c, npix) +abned 6 ./vops/ak/abned.x procedure abned (a, b, c, npix) +abnei 6 ./vops/ak/abnei.x procedure abnei (a, b, c, npix) +abnek 6 ./vops/abnek.gx procedure abnek$t (a, b, c, npix) +abnekc 6 ./vops/ak/abnekc.x procedure abnekc (a, b, c, npix) +abnekd 6 ./vops/ak/abnekd.x procedure abnekd (a, b, c, npix) +abneki 6 ./vops/ak/abneki.x procedure abneki (a, b, c, npix) +abnekl 6 ./vops/ak/abnekl.x procedure abnekl (a, b, c, npix) +abnekr 6 ./vops/ak/abnekr.x procedure abnekr (a, b, c, npix) +abneks 6 ./vops/ak/abneks.x procedure abneks (a, b, c, npix) +abnekx 6 ./vops/ak/abnekx.x procedure abnekx (a, b, c, npix) +abnel 6 ./vops/ak/abnel.x procedure abnel (a, b, c, npix) +abner 6 ./vops/ak/abner.x procedure abner (a, b, c, npix) +abnes 6 ./vops/ak/abnes.x procedure abnes (a, b, c, npix) +abnex 6 ./vops/ak/abnex.x procedure abnex (a, b, c, npix) +abor 5 ./vops/abor.gx procedure abor$t (a, b, c, npix) +abori 5 ./vops/ak/abori.x procedure abori (a, b, c, npix) +abork 6 ./vops/abork.gx procedure abork$t (a, b, c, npix) +aborki 6 ./vops/ak/aborki.x procedure aborki (a, b, c, npix) +aborkl 6 ./vops/ak/aborkl.x procedure aborkl (a, b, c, npix) +aborks 6 ./vops/ak/aborks.x procedure aborks (a, b, c, npix) +aborl 5 ./vops/ak/aborl.x procedure aborl (a, b, c, npix) +abors 5 ./vops/ak/abors.x procedure abors (a, b, c, npix) +absu 7 ./vops/absu.gx procedure absu$t (a, b, nblocks, npix_per_block) +absud 7 ./vops/ak/absud.x procedure absud (a, b, nblocks, npix_per_block) +absui 7 ./vops/ak/absui.x procedure absui (a, b, nblocks, npix_per_block) +absul 7 ./vops/ak/absul.x procedure absul (a, b, nblocks, npix_per_block) +absur 7 ./vops/ak/absur.x procedure absur (a, b, nblocks, npix_per_block) +absus 7 ./vops/ak/absus.x procedure absus (a, b, nblocks, npix_per_block) +access 13 ./fio/access.x int procedure access (fname, mode, type) +acht 6 ./vops/achtgen/acht.x procedure acht (a, b, nelem, ty_a, ty_b) +acht 7 ./vops/acht.gx procedure acht$t$$t (a, b, npix) +achtb 6 ./vops/achtgen/achtb.x procedure achtb (a, b, nelem, ty_b) +achtc 6 ./vops/achtgen/achtc.x procedure achtc (a, b, nelem, ty_b) +achtcc 7 ./vops/ak/achtcc.x procedure achtcc (a, b, npix) +achtcd 7 ./vops/ak/achtcd.x procedure achtcd (a, b, npix) +achtci 7 ./vops/ak/achtci.x procedure achtci (a, b, npix) +achtcl 7 ./vops/ak/achtcl.x procedure achtcl (a, b, npix) +achtcr 7 ./vops/ak/achtcr.x procedure achtcr (a, b, npix) +achtcs 7 ./vops/ak/achtcs.x procedure achtcs (a, b, npix) +achtcx 7 ./vops/ak/achtcx.x procedure achtcx (a, b, npix) +achtd 6 ./vops/achtgen/achtd.x procedure achtd (a, b, nelem, ty_b) +achtdc 7 ./vops/ak/achtdc.x procedure achtdc (a, b, npix) +achtdd 7 ./vops/ak/achtdd.x procedure achtdd (a, b, npix) +achtdi 7 ./vops/ak/achtdi.x procedure achtdi (a, b, npix) +achtdl 7 ./vops/ak/achtdl.x procedure achtdl (a, b, npix) +achtdr 7 ./vops/ak/achtdr.x procedure achtdr (a, b, npix) +achtds 7 ./vops/ak/achtds.x procedure achtds (a, b, npix) +achtdx 7 ./vops/ak/achtdx.x procedure achtdx (a, b, npix) +achti 6 ./vops/achtgen/achti.x procedure achti (a, b, nelem, ty_b) +achtic 7 ./vops/ak/achtic.x procedure achtic (a, b, npix) +achtid 7 ./vops/ak/achtid.x procedure achtid (a, b, npix) +achtii 7 ./vops/ak/achtii.x procedure achtii (a, b, npix) +achtil 7 ./vops/ak/achtil.x procedure achtil (a, b, npix) +achtir 7 ./vops/ak/achtir.x procedure achtir (a, b, npix) +achtis 7 ./vops/ak/achtis.x procedure achtis (a, b, npix) +achtix 7 ./vops/ak/achtix.x procedure achtix (a, b, npix) +achtl 6 ./vops/achtgen/achtl.x procedure achtl (a, b, nelem, ty_b) +achtlc 7 ./vops/ak/achtlc.x procedure achtlc (a, b, npix) +achtld 7 ./vops/ak/achtld.x procedure achtld (a, b, npix) +achtli 7 ./vops/ak/achtli.x procedure achtli (a, b, npix) +achtll 7 ./vops/ak/achtll.x procedure achtll (a, b, npix) +achtlr 7 ./vops/ak/achtlr.x procedure achtlr (a, b, npix) +achtls 7 ./vops/ak/achtls.x procedure achtls (a, b, npix) +achtlx 7 ./vops/ak/achtlx.x procedure achtlx (a, b, npix) +achtr 6 ./vops/achtgen/achtr.x procedure achtr (a, b, nelem, ty_b) +achtrc 7 ./vops/ak/achtrc.x procedure achtrc (a, b, npix) +achtrd 7 ./vops/ak/achtrd.x procedure achtrd (a, b, npix) +achtri 7 ./vops/ak/achtri.x procedure achtri (a, b, npix) +achtrl 7 ./vops/ak/achtrl.x procedure achtrl (a, b, npix) +achtrr 7 ./vops/ak/achtrr.x procedure achtrr (a, b, npix) +achtrs 7 ./vops/ak/achtrs.x procedure achtrs (a, b, npix) +achtrx 7 ./vops/ak/achtrx.x procedure achtrx (a, b, npix) +achts 6 ./vops/achtgen/achts.x procedure achts (a, b, nelem, ty_b) +achtsc 7 ./vops/ak/achtsc.x procedure achtsc (a, b, npix) +achtsd 7 ./vops/ak/achtsd.x procedure achtsd (a, b, npix) +achtsi 7 ./vops/ak/achtsi.x procedure achtsi (a, b, npix) +achtsl 7 ./vops/ak/achtsl.x procedure achtsl (a, b, npix) +achtsr 7 ./vops/ak/achtsr.x procedure achtsr (a, b, npix) +achtss 7 ./vops/ak/achtss.x procedure achtss (a, b, npix) +achtsx 7 ./vops/ak/achtsx.x procedure achtsx (a, b, npix) +achtu 6 ./vops/achtgen/achtu.x procedure achtu (a, b, nelem, ty_b) +achtx 6 ./vops/achtgen/achtx.x procedure achtx (a, b, nelem, ty_b) +achtxc 7 ./vops/ak/achtxc.x procedure achtxc (a, b, npix) +achtxd 7 ./vops/ak/achtxd.x procedure achtxd (a, b, npix) +achtxi 7 ./vops/ak/achtxi.x procedure achtxi (a, b, npix) +achtxl 7 ./vops/ak/achtxl.x procedure achtxl (a, b, npix) +achtxr 7 ./vops/ak/achtxr.x procedure achtxr (a, b, npix) +achtxs 7 ./vops/ak/achtxs.x procedure achtxs (a, b, npix) +achtxx 7 ./vops/ak/achtxx.x procedure achtxx (a, b, npix) +acjgx 5 ./vops/acjgx.x procedure acjgx (a, b, npix) +acjgx 5 ./vops/ak/acjgx.x procedure acjgx (a, b, npix) +aclr 5 ./vops/aclr.gx procedure aclr$t (a, npix) +aclrc 5 ./vops/ak/aclrc.x procedure aclrc (a, npix) +aclrd 5 ./vops/ak/aclrd.x procedure aclrd (a, npix) +aclri 5 ./vops/ak/aclri.x procedure aclri (a, npix) +aclrl 5 ./vops/ak/aclrl.x procedure aclrl (a, npix) +aclrr 5 ./vops/ak/aclrr.x procedure aclrr (a, npix) +aclrs 5 ./vops/ak/aclrs.x procedure aclrs (a, npix) +aclrx 5 ./vops/ak/aclrx.x procedure aclrx (a, npix) +acnv 18 ./vops/acnv.gx procedure acnv$t (in, out, npix, kernel, knpix) +acnvd 18 ./vops/ak/acnvd.x procedure acnvd (in, out, npix, kernel, knpix) +acnvi 18 ./vops/ak/acnvi.x procedure acnvi (in, out, npix, kernel, knpix) +acnvl 18 ./vops/ak/acnvl.x procedure acnvl (in, out, npix, kernel, knpix) +acnvr 18 ./vops/ak/acnvr.x procedure acnvr (in, out, npix, kernel, knpix) +acnvr 19 ./vops/acnvr.gx procedure acnvr$t (in, out, npix, kernel, knpix) +acnvrd 19 ./vops/ak/acnvrd.x procedure acnvrd (in, out, npix, kernel, knpix) +acnvri 19 ./vops/ak/acnvri.x procedure acnvri (in, out, npix, kernel, knpix) +acnvrl 19 ./vops/ak/acnvrl.x procedure acnvrl (in, out, npix, kernel, knpix) +acnvrr 19 ./vops/ak/acnvrr.x procedure acnvrr (in, out, npix, kernel, knpix) +acnvrs 19 ./vops/ak/acnvrs.x procedure acnvrs (in, out, npix, kernel, knpix) +acnvs 18 ./vops/ak/acnvs.x procedure acnvs (in, out, npix, kernel, knpix) +adiv 6 ./vops/adiv.gx procedure adiv$t (a, b, c, npix) +adivd 6 ./vops/ak/adivd.x procedure adivd (a, b, c, npix) +adivi 6 ./vops/ak/adivi.x procedure adivi (a, b, c, npix) +adivk 6 ./vops/adivk.gx procedure adivk$t (a, b, c, npix) +adivkd 6 ./vops/ak/adivkd.x procedure adivkd (a, b, c, npix) +adivki 6 ./vops/ak/adivki.x procedure adivki (a, b, c, npix) +adivkl 6 ./vops/ak/adivkl.x procedure adivkl (a, b, c, npix) +adivkr 6 ./vops/ak/adivkr.x procedure adivkr (a, b, c, npix) +adivks 6 ./vops/ak/adivks.x procedure adivks (a, b, c, npix) +adivkx 6 ./vops/ak/adivkx.x procedure adivkx (a, b, c, npix) +adivl 6 ./vops/ak/adivl.x procedure adivl (a, b, c, npix) +adivr 6 ./vops/ak/adivr.x procedure adivr (a, b, c, npix) +adivs 6 ./vops/ak/adivs.x procedure adivs (a, b, c, npix) +adivx 6 ./vops/ak/adivx.x procedure adivx (a, b, c, npix) +adjust 347 ./gio/nsppkern/gktpcell.x procedure adjust ( lower, upper, res) +adot 7 ./vops/adot.gx double procedure adot$t (a, b, npix) +adot 9 ./vops/adot.gx real procedure adot$t (a, b, npix) +adotd 6 ./vops/ak/adotd.x double procedure adotd (a, b, npix) +adoti 6 ./vops/ak/adoti.x real procedure adoti (a, b, npix) +adotl 6 ./vops/ak/adotl.x double procedure adotl (a, b, npix) +adotr 6 ./vops/ak/adotr.x real procedure adotr (a, b, npix) +adots 6 ./vops/ak/adots.x real procedure adots (a, b, npix) +adotx 6 ./vops/ak/adotx.x real procedure adotx (a, b, npix) +advz 13 ./vops/advz.gx procedure advz$t (a, b, c, npix, errfcn) +advzd 13 ./vops/ak/advzd.x procedure advzd (a, b, c, npix, errfcn) +advzi 13 ./vops/ak/advzi.x procedure advzi (a, b, c, npix, errfcn) +advzl 13 ./vops/ak/advzl.x procedure advzl (a, b, c, npix, errfcn) +advzr 13 ./vops/ak/advzr.x procedure advzr (a, b, c, npix, errfcn) +advzs 13 ./vops/ak/advzs.x procedure advzs (a, b, c, npix, errfcn) +advzx 13 ./vops/ak/advzx.x procedure advzx (a, b, c, npix, errfcn) +aelogd 5 ./gio/aelogd.x double procedure aelogd (x) +aelogr 5 ./gio/aelogr.x real procedure aelogr (x) +aexp 5 ./vops/aexp.gx procedure aexp$t (a, b, c, npix) +aexpd 5 ./vops/ak/aexpd.x procedure aexpd (a, b, c, npix) +aexpi 5 ./vops/ak/aexpi.x procedure aexpi (a, b, c, npix) +aexpk 5 ./vops/aexpk.gx procedure aexpk$t (a, b, c, npix) +aexpkd 5 ./vops/ak/aexpkd.x procedure aexpkd (a, b, c, npix) +aexpki 5 ./vops/ak/aexpki.x procedure aexpki (a, b, c, npix) +aexpkl 5 ./vops/ak/aexpkl.x procedure aexpkl (a, b, c, npix) +aexpkr 5 ./vops/ak/aexpkr.x procedure aexpkr (a, b, c, npix) +aexpks 5 ./vops/ak/aexpks.x procedure aexpks (a, b, c, npix) +aexpkx 5 ./vops/ak/aexpkx.x procedure aexpkx (a, b, c, npix) +aexpl 5 ./vops/ak/aexpl.x procedure aexpl (a, b, c, npix) +aexpr 5 ./vops/ak/aexpr.x procedure aexpr (a, b, c, npix) +aexps 5 ./vops/ak/aexps.x procedure aexps (a, b, c, npix) +aexpx 5 ./vops/ak/aexpx.x procedure aexpx (a, b, c, npix) +afftrr 10 ./vops/afftrr.x procedure afftrr (sr, si, fr, fi, npix) +afftrr 10 ./vops/ak/afftrr.x procedure afftrr (sr, si, fr, fi, npix) +afftrx 18 ./vops/afftrx.x procedure afftrx (a, b, npix) +afftrx 18 ./vops/ak/afftrx.x procedure afftrx (a, b, npix) +afftxr 9 ./vops/afftxr.x procedure afftxr (sr, si, fr, fi, npix) +afftxr 9 ./vops/ak/afftxr.x procedure afftxr (sr, si, fr, fi, npix) +afftxx 9 ./vops/afftxx.x procedure afftxx (a, b, npix) +afftxx 9 ./vops/ak/afftxx.x procedure afftxx (a, b, npix) +aglt 8 ./vops/aglt.gx procedure aglt$t (a, b, npix, low, high, kmul, kadd, nrange) +agltc 8 ./vops/ak/agltc.x procedure agltc (a, b, npix, low, high, kmul, kadd, nrange) +agltd 8 ./vops/ak/agltd.x procedure agltd (a, b, npix, low, high, kmul, kadd, nrange) +aglti 8 ./vops/ak/aglti.x procedure aglti (a, b, npix, low, high, kmul, kadd, nrange) +agltl 8 ./vops/ak/agltl.x procedure agltl (a, b, npix, low, high, kmul, kadd, nrange) +agltr 8 ./vops/ak/agltr.x procedure agltr (a, b, npix, low, high, kmul, kadd, nrange) +aglts 8 ./vops/ak/aglts.x procedure aglts (a, b, npix, low, high, kmul, kadd, nrange) +agltx 8 ./vops/ak/agltx.x procedure agltx (a, b, npix, low, high, kmul, kadd, nrange) +ahgm 8 ./vops/ahgm.gx procedure ahgm$t (data, npix, hgm, nbins, z1, z2) +ahgmc 8 ./vops/ak/ahgmc.x procedure ahgmc (data, npix, hgm, nbins, z1, z2) +ahgmd 8 ./vops/ak/ahgmd.x procedure ahgmd (data, npix, hgm, nbins, z1, z2) +ahgmi 8 ./vops/ak/ahgmi.x procedure ahgmi (data, npix, hgm, nbins, z1, z2) +ahgml 8 ./vops/ak/ahgml.x procedure ahgml (data, npix, hgm, nbins, z1, z2) +ahgmr 8 ./vops/ak/ahgmr.x procedure ahgmr (data, npix, hgm, nbins, z1, z2) +ahgms 8 ./vops/ak/ahgms.x procedure ahgms (data, npix, hgm, nbins, z1, z2) +ahiv 5 ./vops/ahiv.gx PIXEL procedure ahiv$t (a, npix) +ahivc 5 ./vops/ak/ahivc.x char procedure ahivc (a, npix) +ahivd 5 ./vops/ak/ahivd.x double procedure ahivd (a, npix) +ahivi 5 ./vops/ak/ahivi.x int procedure ahivi (a, npix) +ahivl 5 ./vops/ak/ahivl.x long procedure ahivl (a, npix) +ahivr 5 ./vops/ak/ahivr.x real procedure ahivr (a, npix) +ahivs 5 ./vops/ak/ahivs.x short procedure ahivs (a, npix) +ahivx 5 ./vops/ak/ahivx.x complex procedure ahivx (a, npix) +aiftrr 10 ./vops/aiftrr.x procedure aiftrr (fr, fi, sr, si, npix) +aiftrr 10 ./vops/ak/aiftrr.x procedure aiftrr (fr, fi, sr, si, npix) +aiftrx 16 ./vops/aiftrx.x procedure aiftrx (a, b, npix) +aiftrx 16 ./vops/ak/aiftrx.x procedure aiftrx (a, b, npix) +aiftxr 9 ./vops/aiftxr.x procedure aiftxr (fr, fi, sr, si, npix) +aiftxr 9 ./vops/ak/aiftxr.x procedure aiftxr (fr, fi, sr, si, npix) +aiftxx 16 ./vops/aiftxx.x procedure aiftxx (a, b, npix) +aiftxx 16 ./vops/ak/aiftxx.x procedure aiftxx (a, b, npix) +aimg 5 ./vops/aimg.gx procedure aimg$t (a, b, npix) +aimgd 5 ./vops/ak/aimgd.x procedure aimgd (a, b, npix) +aimgi 5 ./vops/ak/aimgi.x procedure aimgi (a, b, npix) +aimgl 5 ./vops/ak/aimgl.x procedure aimgl (a, b, npix) +aimgr 5 ./vops/ak/aimgr.x procedure aimgr (a, b, npix) +aimgs 5 ./vops/ak/aimgs.x procedure aimgs (a, b, npix) +alim 5 ./vops/alim.gx procedure alim$t (a, npix, minval, maxval) +alimc 5 ./vops/lz/alimc.x procedure alimc (a, npix, minval, maxval) +alimd 5 ./vops/lz/alimd.x procedure alimd (a, npix, minval, maxval) +alimi 5 ./vops/lz/alimi.x procedure alimi (a, npix, minval, maxval) +aliml 5 ./vops/lz/aliml.x procedure aliml (a, npix, minval, maxval) +alimr 5 ./vops/lz/alimr.x procedure alimr (a, npix, minval, maxval) +alims 5 ./vops/lz/alims.x procedure alims (a, npix, minval, maxval) +alimx 5 ./vops/lz/alimx.x procedure alimx (a, npix, minval, maxval) +alln 7 ./vops/alln.gx procedure alln$t (a, b, npix, errfcn) +allnd 7 ./vops/lz/allnd.x procedure allnd (a, b, npix, errfcn) +allni 7 ./vops/lz/allni.x procedure allni (a, b, npix, errfcn) +allnl 7 ./vops/lz/allnl.x procedure allnl (a, b, npix, errfcn) +allnr 7 ./vops/lz/allnr.x procedure allnr (a, b, npix, errfcn) +allns 7 ./vops/lz/allns.x procedure allns (a, b, npix, errfcn) +allnx 7 ./vops/lz/allnx.x procedure allnx (a, b, npix, errfcn) +alloc 2 ../unix/os/alloc.c alloc (argv, statonly) +alog 7 ./vops/alog.gx procedure alog$t (a, b, npix, errfcn) +alogd 7 ./vops/lz/alogd.x procedure alogd (a, b, npix, errfcn) +alogi 7 ./vops/lz/alogi.x procedure alogi (a, b, npix, errfcn) +alogl 7 ./vops/lz/alogl.x procedure alogl (a, b, npix, errfcn) +alogr 7 ./vops/lz/alogr.x procedure alogr (a, b, npix, errfcn) +alogs 7 ./vops/lz/alogs.x procedure alogs (a, b, npix, errfcn) +alogx 7 ./vops/lz/alogx.x procedure alogx (a, b, npix, errfcn) +alov 5 ./vops/alov.gx PIXEL procedure alov$t (a, npix) +alovc 5 ./vops/lz/alovc.x char procedure alovc (a, npix) +alovd 5 ./vops/lz/alovd.x double procedure alovd (a, npix) +alovi 5 ./vops/lz/alovi.x int procedure alovi (a, npix) +alovl 5 ./vops/lz/alovl.x long procedure alovl (a, npix) +alovr 5 ./vops/lz/alovr.x real procedure alovr (a, npix) +alovs 5 ./vops/lz/alovs.x short procedure alovs (a, npix) +alovx 5 ./vops/lz/alovx.x complex procedure alovx (a, npix) +alta 6 ./vops/alta.gx procedure alta$t (a, b, npix, k1, k2) +altad 6 ./vops/lz/altad.x procedure altad (a, b, npix, k1, k2) +altai 6 ./vops/lz/altai.x procedure altai (a, b, npix, k1, k2) +altal 6 ./vops/lz/altal.x procedure altal (a, b, npix, k1, k2) +altar 6 ./vops/lz/altar.x procedure altar (a, b, npix, k1, k2) +altas 6 ./vops/lz/altas.x procedure altas (a, b, npix, k1, k2) +altax 6 ./vops/lz/altax.x procedure altax (a, b, npix, k1, k2) +altm 6 ./vops/altm.gx procedure altm$t (a, b, npix, k1, k2) +altmd 6 ./vops/lz/altmd.x procedure altmd (a, b, npix, k1, k2) +altmi 6 ./vops/lz/altmi.x procedure altmi (a, b, npix, k1, k2) +altml 6 ./vops/lz/altml.x procedure altml (a, b, npix, k1, k2) +altmr 6 ./vops/lz/altmr.x procedure altmr (a, b, npix, k1, k2) +altms 6 ./vops/lz/altms.x procedure altms (a, b, npix, k1, k2) +altmx 6 ./vops/lz/altmx.x procedure altmx (a, b, npix, k1, k2) +altr 7 ./vops/altr.gx procedure altr$t (a, b, npix, k1, k2, k3) +altrd 7 ./vops/lz/altrd.x procedure altrd (a, b, npix, k1, k2, k3) +altri 7 ./vops/lz/altri.x procedure altri (a, b, npix, k1, k2, k3) +altrl 7 ./vops/lz/altrl.x procedure altrl (a, b, npix, k1, k2, k3) +altrr 7 ./vops/lz/altrr.x procedure altrr (a, b, npix, k1, k2, k3) +altrs 7 ./vops/lz/altrs.x procedure altrs (a, b, npix, k1, k2, k3) +altrx 7 ./vops/lz/altrx.x procedure altrx (a, b, npix, k1, k2, k3) +alui 12 ./vops/alui.gx procedure alui$t (a, b, x, npix) +aluid 12 ./vops/lz/aluid.x procedure aluid (a, b, x, npix) +aluii 12 ./vops/lz/aluii.x procedure aluii (a, b, x, npix) +aluil 12 ./vops/lz/aluil.x procedure aluil (a, b, x, npix) +aluir 12 ./vops/lz/aluir.x procedure aluir (a, b, x, npix) +aluis 12 ./vops/lz/aluis.x procedure aluis (a, b, x, npix) +alut 7 ./vops/alut.gx procedure alut$t (a, b, npix, lut) +alutc 7 ./vops/lz/alutc.x procedure alutc (a, b, npix, lut) +alutd 7 ./vops/lz/alutd.x procedure alutd (a, b, npix, lut) +aluti 7 ./vops/lz/aluti.x procedure aluti (a, b, npix, lut) +alutl 7 ./vops/lz/alutl.x procedure alutl (a, b, npix, lut) +alutr 7 ./vops/lz/alutr.x procedure alutr (a, b, npix, lut) +aluts 7 ./vops/lz/aluts.x procedure aluts (a, b, npix, lut) +amag 5 ./vops/amag.gx procedure amag$t (a, b, c, npix) +amagd 5 ./vops/lz/amagd.x procedure amagd (a, b, c, npix) +amagi 5 ./vops/lz/amagi.x procedure amagi (a, b, c, npix) +amagl 5 ./vops/lz/amagl.x procedure amagl (a, b, c, npix) +amagr 5 ./vops/lz/amagr.x procedure amagr (a, b, c, npix) +amags 5 ./vops/lz/amags.x procedure amags (a, b, c, npix) +amagx 5 ./vops/lz/amagx.x procedure amagx (a, b, c, npix) +amap 7 ./vops/amap.gx procedure amap$t (a, b, npix, a1, a2, b1, b2) +amapd 7 ./vops/lz/amapd.x procedure amapd (a, b, npix, a1, a2, b1, b2) +amapi 7 ./vops/lz/amapi.x procedure amapi (a, b, npix, a1, a2, b1, b2) +amapl 7 ./vops/lz/amapl.x procedure amapl (a, b, npix, a1, a2, b1, b2) +amapr 7 ./vops/lz/amapr.x procedure amapr (a, b, npix, a1, a2, b1, b2) +amaps 7 ./vops/lz/amaps.x procedure amaps (a, b, npix, a1, a2, b1, b2) +amax 5 ./vops/amax.gx procedure amax$t (a, b, c, npix) +amaxc 5 ./vops/lz/amaxc.x procedure amaxc (a, b, c, npix) +amaxd 5 ./vops/lz/amaxd.x procedure amaxd (a, b, c, npix) +amaxi 5 ./vops/lz/amaxi.x procedure amaxi (a, b, c, npix) +amaxk 5 ./vops/amaxk.gx procedure amaxk$t (a, b, c, npix) +amaxkc 5 ./vops/lz/amaxkc.x procedure amaxkc (a, b, c, npix) +amaxkd 5 ./vops/lz/amaxkd.x procedure amaxkd (a, b, c, npix) +amaxki 5 ./vops/lz/amaxki.x procedure amaxki (a, b, c, npix) +amaxkl 5 ./vops/lz/amaxkl.x procedure amaxkl (a, b, c, npix) +amaxkr 5 ./vops/lz/amaxkr.x procedure amaxkr (a, b, c, npix) +amaxks 5 ./vops/lz/amaxks.x procedure amaxks (a, b, c, npix) +amaxkx 5 ./vops/lz/amaxkx.x procedure amaxkx (a, b, c, npix) +amaxl 5 ./vops/lz/amaxl.x procedure amaxl (a, b, c, npix) +amaxr 5 ./vops/lz/amaxr.x procedure amaxr (a, b, c, npix) +amaxs 5 ./vops/lz/amaxs.x procedure amaxs (a, b, c, npix) +amaxx 5 ./vops/lz/amaxx.x procedure amaxx (a, b, c, npix) +amed 8 ./vops/amed.gx PIXEL procedure amed$t (a, npix) +amed3 6 ./vops/amed3.gx procedure amed3$t (a, b, c, m, npix) +amed3c 6 ./vops/lz/amed3c.x procedure amed3c (a, b, c, m, npix) +amed3d 6 ./vops/lz/amed3d.x procedure amed3d (a, b, c, m, npix) +amed3i 6 ./vops/lz/amed3i.x procedure amed3i (a, b, c, m, npix) +amed3l 6 ./vops/lz/amed3l.x procedure amed3l (a, b, c, m, npix) +amed3r 6 ./vops/lz/amed3r.x procedure amed3r (a, b, c, m, npix) +amed3s 6 ./vops/lz/amed3s.x procedure amed3s (a, b, c, m, npix) +amed4 8 ./vops/amed4.gx procedure amed4$t (a, b, c, d, m, npix) +amed4c 8 ./vops/lz/amed4c.x procedure amed4c (a, b, c, d, m, npix) +amed4d 8 ./vops/lz/amed4d.x procedure amed4d (a, b, c, d, m, npix) +amed4i 8 ./vops/lz/amed4i.x procedure amed4i (a, b, c, d, m, npix) +amed4l 8 ./vops/lz/amed4l.x procedure amed4l (a, b, c, d, m, npix) +amed4r 8 ./vops/lz/amed4r.x procedure amed4r (a, b, c, d, m, npix) +amed4s 8 ./vops/lz/amed4s.x procedure amed4s (a, b, c, d, m, npix) +amed5 7 ./vops/amed5.gx procedure amed5$t (a, b, c, d, e, m, npix) +amed5c 7 ./vops/lz/amed5c.x procedure amed5c (a, b, c, d, e, m, npix) +amed5d 7 ./vops/lz/amed5d.x procedure amed5d (a, b, c, d, e, m, npix) +amed5i 7 ./vops/lz/amed5i.x procedure amed5i (a, b, c, d, e, m, npix) +amed5l 7 ./vops/lz/amed5l.x procedure amed5l (a, b, c, d, e, m, npix) +amed5r 7 ./vops/lz/amed5r.x procedure amed5r (a, b, c, d, e, m, npix) +amed5s 7 ./vops/lz/amed5s.x procedure amed5s (a, b, c, d, e, m, npix) +amedc 8 ./vops/lz/amedc.x char procedure amedc (a, npix) +amedd 8 ./vops/lz/amedd.x double procedure amedd (a, npix) +amedi 8 ./vops/lz/amedi.x int procedure amedi (a, npix) +amedl 8 ./vops/lz/amedl.x long procedure amedl (a, npix) +amedr 8 ./vops/lz/amedr.x real procedure amedr (a, npix) +ameds 8 ./vops/lz/ameds.x short procedure ameds (a, npix) +amedx 8 ./vops/lz/amedx.x complex procedure amedx (a, npix) +amgs 5 ./vops/amgs.gx procedure amgs$t (a, b, c, npix) +amgsd 5 ./vops/lz/amgsd.x procedure amgsd (a, b, c, npix) +amgsi 5 ./vops/lz/amgsi.x procedure amgsi (a, b, c, npix) +amgsl 5 ./vops/lz/amgsl.x procedure amgsl (a, b, c, npix) +amgsr 5 ./vops/lz/amgsr.x procedure amgsr (a, b, c, npix) +amgss 5 ./vops/lz/amgss.x procedure amgss (a, b, c, npix) +amgsx 5 ./vops/lz/amgsx.x procedure amgsx (a, b, c, npix) +amin 5 ./vops/amin.gx procedure amin$t (a, b, c, npix) +aminc 5 ./vops/lz/aminc.x procedure aminc (a, b, c, npix) +amind 5 ./vops/lz/amind.x procedure amind (a, b, c, npix) +amini 5 ./vops/lz/amini.x procedure amini (a, b, c, npix) +amink 5 ./vops/amink.gx procedure amink$t (a, b, c, npix) +aminkc 5 ./vops/lz/aminkc.x procedure aminkc (a, b, c, npix) +aminkd 5 ./vops/lz/aminkd.x procedure aminkd (a, b, c, npix) +aminki 5 ./vops/lz/aminki.x procedure aminki (a, b, c, npix) +aminkl 5 ./vops/lz/aminkl.x procedure aminkl (a, b, c, npix) +aminkr 5 ./vops/lz/aminkr.x procedure aminkr (a, b, c, npix) +aminks 5 ./vops/lz/aminks.x procedure aminks (a, b, c, npix) +aminkx 5 ./vops/lz/aminkx.x procedure aminkx (a, b, c, npix) +aminl 5 ./vops/lz/aminl.x procedure aminl (a, b, c, npix) +aminr 5 ./vops/lz/aminr.x procedure aminr (a, b, c, npix) +amins 5 ./vops/lz/amins.x procedure amins (a, b, c, npix) +aminx 5 ./vops/lz/aminx.x procedure aminx (a, b, c, npix) +amod 5 ./vops/amod.gx procedure amod$t (a, b, c, npix) +amodd 5 ./vops/lz/amodd.x procedure amodd (a, b, c, npix) +amodi 5 ./vops/lz/amodi.x procedure amodi (a, b, c, npix) +amodk 5 ./vops/amodk.gx procedure amodk$t (a, b, c, npix) +amodkd 5 ./vops/lz/amodkd.x procedure amodkd (a, b, c, npix) +amodki 5 ./vops/lz/amodki.x procedure amodki (a, b, c, npix) +amodkl 5 ./vops/lz/amodkl.x procedure amodkl (a, b, c, npix) +amodkr 5 ./vops/lz/amodkr.x procedure amodkr (a, b, c, npix) +amodks 5 ./vops/lz/amodks.x procedure amodks (a, b, c, npix) +amodl 5 ./vops/lz/amodl.x procedure amodl (a, b, c, npix) +amodr 5 ./vops/lz/amodr.x procedure amodr (a, b, c, npix) +amods 5 ./vops/lz/amods.x procedure amods (a, b, c, npix) +amov 7 ./vops/amov.gx procedure amov$t (a, b, npix) +amovc 7 ./vops/lz/amovc.x procedure amovc (a, b, npix) +amovd 7 ./vops/lz/amovd.x procedure amovd (a, b, npix) +amovi 7 ./vops/lz/amovi.x procedure amovi (a, b, npix) +amovk 5 ./vops/amovk.gx procedure amovk$t (a, b, npix) +amovkc 5 ./vops/lz/amovkc.x procedure amovkc (a, b, npix) +amovkd 5 ./vops/lz/amovkd.x procedure amovkd (a, b, npix) +amovki 5 ./vops/lz/amovki.x procedure amovki (a, b, npix) +amovkl 5 ./vops/lz/amovkl.x procedure amovkl (a, b, npix) +amovkr 5 ./vops/lz/amovkr.x procedure amovkr (a, b, npix) +amovks 5 ./vops/lz/amovks.x procedure amovks (a, b, npix) +amovkx 5 ./vops/lz/amovkx.x procedure amovkx (a, b, npix) +amovl 7 ./vops/lz/amovl.x procedure amovl (a, b, npix) +amovr 7 ./vops/lz/amovr.x procedure amovr (a, b, npix) +amovs 7 ./vops/lz/amovs.x procedure amovs (a, b, npix) +amovx 7 ./vops/lz/amovx.x procedure amovx (a, b, npix) +amul 5 ./vops/amul.gx procedure amul$t (a, b, c, npix) +amuld 5 ./vops/lz/amuld.x procedure amuld (a, b, c, npix) +amuli 5 ./vops/lz/amuli.x procedure amuli (a, b, c, npix) +amulk 5 ./vops/amulk.gx procedure amulk$t (a, b, c, npix) +amulkd 5 ./vops/lz/amulkd.x procedure amulkd (a, b, c, npix) +amulki 5 ./vops/lz/amulki.x procedure amulki (a, b, c, npix) +amulkl 5 ./vops/lz/amulkl.x procedure amulkl (a, b, c, npix) +amulkr 5 ./vops/lz/amulkr.x procedure amulkr (a, b, c, npix) +amulks 5 ./vops/lz/amulks.x procedure amulks (a, b, c, npix) +amulkx 5 ./vops/lz/amulkx.x procedure amulkx (a, b, c, npix) +amull 5 ./vops/lz/amull.x procedure amull (a, b, c, npix) +amulr 5 ./vops/lz/amulr.x procedure amulr (a, b, c, npix) +amuls 5 ./vops/lz/amuls.x procedure amuls (a, b, c, npix) +amulx 5 ./vops/lz/amulx.x procedure amulx (a, b, c, npix) +aneg 5 ./vops/aneg.gx procedure aneg$t (a, b, npix) +anegd 5 ./vops/lz/anegd.x procedure anegd (a, b, npix) +anegi 5 ./vops/lz/anegi.x procedure anegi (a, b, npix) +anegl 5 ./vops/lz/anegl.x procedure anegl (a, b, npix) +anegr 5 ./vops/lz/anegr.x procedure anegr (a, b, npix) +anegs 5 ./vops/lz/anegs.x procedure anegs (a, b, npix) +anegx 5 ./vops/lz/anegx.x procedure anegx (a, b, npix) +anot 5 ./vops/anot.gx procedure anot$t (a, b, npix) +anoti 5 ./vops/lz/anoti.x procedure anoti (a, b, npix) +anotl 5 ./vops/lz/anotl.x procedure anotl (a, b, npix) +anots 5 ./vops/lz/anots.x procedure anots (a, b, npix) +apkx 6 ./vops/apkx.gx procedure apkx$t (a, b, c, npix) +apkxd 6 ./vops/lz/apkxd.x procedure apkxd (a, b, c, npix) +apkxi 6 ./vops/lz/apkxi.x procedure apkxi (a, b, c, npix) +apkxl 6 ./vops/lz/apkxl.x procedure apkxl (a, b, c, npix) +apkxr 6 ./vops/lz/apkxr.x procedure apkxr (a, b, c, npix) +apkxs 6 ./vops/lz/apkxs.x procedure apkxs (a, b, c, npix) +apkxx 6 ./vops/lz/apkxx.x procedure apkxx (a, b, c, npix) +apol 6 ./vops/apol.gx PIXEL procedure apol$t (x, coeff, ncoeff) +apold 6 ./vops/lz/apold.x double procedure apold (x, coeff, ncoeff) +apolr 6 ./vops/lz/apolr.x real procedure apolr (x, coeff, ncoeff) +apow 5 ./vops/apow.gx procedure apow$t (a, b, c, npix) +apowd 5 ./vops/lz/apowd.x procedure apowd (a, b, c, npix) +apowi 5 ./vops/lz/apowi.x procedure apowi (a, b, c, npix) +apowk 5 ./vops/apowk.gx procedure apowk$t (a, b, c, npix) +apowkd 5 ./vops/lz/apowkd.x procedure apowkd (a, b, c, npix) +apowki 5 ./vops/lz/apowki.x procedure apowki (a, b, c, npix) +apowkl 5 ./vops/lz/apowkl.x procedure apowkl (a, b, c, npix) +apowkr 5 ./vops/lz/apowkr.x procedure apowkr (a, b, c, npix) +apowks 5 ./vops/lz/apowks.x procedure apowks (a, b, c, npix) +apowkx 5 ./vops/lz/apowkx.x procedure apowkx (a, b, c, npix) +apowl 5 ./vops/lz/apowl.x procedure apowl (a, b, c, npix) +apowr 5 ./vops/lz/apowr.x procedure apowr (a, b, c, npix) +apows 5 ./vops/lz/apows.x procedure apows (a, b, c, npix) +apowx 5 ./vops/lz/apowx.x procedure apowx (a, b, c, npix) +arav 12 ./vops/arav.gx int procedure arav$t (a, npix, mean, sigma, ksig) +aravd 12 ./vops/lz/aravd.x int procedure aravd (a, npix, mean, sigma, ksig) +aravi 12 ./vops/lz/aravi.x int procedure aravi (a, npix, mean, sigma, ksig) +aravl 12 ./vops/lz/aravl.x int procedure aravl (a, npix, mean, sigma, ksig) +aravr 12 ./vops/lz/aravr.x int procedure aravr (a, npix, mean, sigma, ksig) +aravs 12 ./vops/lz/aravs.x int procedure aravs (a, npix, mean, sigma, ksig) +aravx 12 ./vops/lz/aravx.x int procedure aravx (a, npix, mean, sigma, ksig) +arcp 6 ./vops/arcp.gx procedure arcp$t (a, b, c, npix) +arcpd 6 ./vops/lz/arcpd.x procedure arcpd (a, b, c, npix) +arcpi 6 ./vops/lz/arcpi.x procedure arcpi (a, b, c, npix) +arcpl 6 ./vops/lz/arcpl.x procedure arcpl (a, b, c, npix) +arcpr 6 ./vops/lz/arcpr.x procedure arcpr (a, b, c, npix) +arcps 6 ./vops/lz/arcps.x procedure arcps (a, b, c, npix) +arcpx 6 ./vops/lz/arcpx.x procedure arcpx (a, b, c, npix) +arcz 13 ./vops/arcz.gx procedure arcz$t (a, b, c, npix, errfcn) +arczd 13 ./vops/lz/arczd.x procedure arczd (a, b, c, npix, errfcn) +arczi 13 ./vops/lz/arczi.x procedure arczi (a, b, c, npix, errfcn) +arczl 13 ./vops/lz/arczl.x procedure arczl (a, b, c, npix, errfcn) +arczr 13 ./vops/lz/arczr.x procedure arczr (a, b, c, npix, errfcn) +arczs 13 ./vops/lz/arczs.x procedure arczs (a, b, c, npix, errfcn) +arczx 13 ./vops/lz/arczx.x procedure arczx (a, b, c, npix, errfcn) +aread 9 ./fio/aread.x procedure aread (fd, buffer, maxchars, char_offset) +areadb 12 ./fio/areadb.x procedure areadb (fd, buffer, maxbytes, byte_offset) +argt 6 ./vops/argt.gx procedure argt$t (a, npix, ceil, newval) +argtd 6 ./vops/lz/argtd.x procedure argtd (a, npix, ceil, newval) +argti 6 ./vops/lz/argti.x procedure argti (a, npix, ceil, newval) +argtl 6 ./vops/lz/argtl.x procedure argtl (a, npix, ceil, newval) +argtr 6 ./vops/lz/argtr.x procedure argtr (a, npix, ceil, newval) +argts 6 ./vops/lz/argts.x procedure argts (a, npix, ceil, newval) +argtx 6 ./vops/lz/argtx.x procedure argtx (a, npix, ceil, newval) +arlt 5 ./vops/arlt.gx procedure arlt$t (a, npix, floor, newval) +arltd 5 ./vops/lz/arltd.x procedure arltd (a, npix, floor, newval) +arlti 5 ./vops/lz/arlti.x procedure arlti (a, npix, floor, newval) +arltl 5 ./vops/lz/arltl.x procedure arltl (a, npix, floor, newval) +arltr 5 ./vops/lz/arltr.x procedure arltr (a, npix, floor, newval) +arlts 5 ./vops/lz/arlts.x procedure arlts (a, npix, floor, newval) +arltx 5 ./vops/lz/arltx.x procedure arltx (a, npix, floor, newval) +asel 8 ./vops/asel.gx procedure asel$t (a, b, c, sel, npix) +aselc 8 ./vops/lz/aselc.x procedure aselc (a, b, c, sel, npix) +aseld 8 ./vops/lz/aseld.x procedure aseld (a, b, c, sel, npix) +aseli 8 ./vops/lz/aseli.x procedure aseli (a, b, c, sel, npix) +aselk 8 ./vops/aselk.gx procedure aselk$t (a, b, c, sel, npix) +aselkc 8 ./vops/lz/aselkc.x procedure aselkc (a, b, c, sel, npix) +aselkd 8 ./vops/lz/aselkd.x procedure aselkd (a, b, c, sel, npix) +aselki 8 ./vops/lz/aselki.x procedure aselki (a, b, c, sel, npix) +aselkl 8 ./vops/lz/aselkl.x procedure aselkl (a, b, c, sel, npix) +aselkr 8 ./vops/lz/aselkr.x procedure aselkr (a, b, c, sel, npix) +aselks 8 ./vops/lz/aselks.x procedure aselks (a, b, c, sel, npix) +aselkx 8 ./vops/lz/aselkx.x procedure aselkx (a, b, c, sel, npix) +asell 8 ./vops/lz/asell.x procedure asell (a, b, c, sel, npix) +aselr 8 ./vops/lz/aselr.x procedure aselr (a, b, c, sel, npix) +asels 8 ./vops/lz/asels.x procedure asels (a, b, c, sel, npix) +aselx 8 ./vops/lz/aselx.x procedure aselx (a, b, c, sel, npix) +asok 18 ./vops/asok.gx PIXEL procedure asok$t (a, npix, ksel) +asokc 18 ./vops/lz/asokc.x char procedure asokc (a, npix, ksel) +asokd 18 ./vops/lz/asokd.x double procedure asokd (a, npix, ksel) +asoki 18 ./vops/lz/asoki.x int procedure asoki (a, npix, ksel) +asokl 18 ./vops/lz/asokl.x long procedure asokl (a, npix, ksel) +asokr 18 ./vops/lz/asokr.x real procedure asokr (a, npix, ksel) +asoks 18 ./vops/lz/asoks.x short procedure asoks (a, npix, ksel) +asokx 18 ./vops/lz/asokx.x complex procedure asokx (a, npix, ksel) +asqr 6 ./vops/asqr.gx procedure asqr$t (a, b, npix, errfcn) +asqrd 6 ./vops/lz/asqrd.x procedure asqrd (a, b, npix, errfcn) +asqri 6 ./vops/lz/asqri.x procedure asqri (a, b, npix, errfcn) +asqrl 6 ./vops/lz/asqrl.x procedure asqrl (a, b, npix, errfcn) +asqrr 6 ./vops/lz/asqrr.x procedure asqrr (a, b, npix, errfcn) +asqrs 6 ./vops/lz/asqrs.x procedure asqrs (a, b, npix, errfcn) +asqrx 6 ./vops/lz/asqrx.x procedure asqrx (a, b, npix, errfcn) +asrt 8 ./vops/asrt.gx procedure asrt$t (a, b, npix) +asrtc 8 ./vops/lz/asrtc.x procedure asrtc (a, b, npix) +asrtd 8 ./vops/lz/asrtd.x procedure asrtd (a, b, npix) +asrti 8 ./vops/lz/asrti.x procedure asrti (a, b, npix) +asrtl 8 ./vops/lz/asrtl.x procedure asrtl (a, b, npix) +asrtr 8 ./vops/lz/asrtr.x procedure asrtr (a, b, npix) +asrts 8 ./vops/lz/asrts.x procedure asrts (a, b, npix) +asrtx 8 ./vops/lz/asrtx.x procedure asrtx (a, b, npix) +assq 6 ./vops/assq.gx real procedure assq$t (a, npix) +assq 9 ./vops/assq.gx double procedure assq$t (a, npix) +assq 12 ./vops/assq.gx PIXEL procedure assq$t (a, npix) +assqd 5 ./vops/lz/assqd.x double procedure assqd (a, npix) +assqi 5 ./vops/lz/assqi.x real procedure assqi (a, npix) +assql 5 ./vops/lz/assql.x double procedure assql (a, npix) +assqr 5 ./vops/lz/assqr.x real procedure assqr (a, npix) +assqs 5 ./vops/lz/assqs.x real procedure assqs (a, npix) +assqx 5 ./vops/lz/assqx.x complex procedure assqx (a, npix) +asub 5 ./vops/asub.gx procedure asub$t (a, b, c, npix) +asubd 5 ./vops/lz/asubd.x procedure asubd (a, b, c, npix) +asubi 5 ./vops/lz/asubi.x procedure asubi (a, b, c, npix) +asubk 5 ./vops/asubk.gx procedure asubk$t (a, b, c, npix) +asubkd 5 ./vops/lz/asubkd.x procedure asubkd (a, b, c, npix) +asubki 5 ./vops/lz/asubki.x procedure asubki (a, b, c, npix) +asubkl 5 ./vops/lz/asubkl.x procedure asubkl (a, b, c, npix) +asubkr 5 ./vops/lz/asubkr.x procedure asubkr (a, b, c, npix) +asubks 5 ./vops/lz/asubks.x procedure asubks (a, b, c, npix) +asubkx 5 ./vops/lz/asubkx.x procedure asubkx (a, b, c, npix) +asubl 5 ./vops/lz/asubl.x procedure asubl (a, b, c, npix) +asubr 5 ./vops/lz/asubr.x procedure asubr (a, b, c, npix) +asubs 5 ./vops/lz/asubs.x procedure asubs (a, b, c, npix) +asubx 5 ./vops/lz/asubx.x procedure asubx (a, b, c, npix) +asum 7 ./vops/asum.gx real procedure asum$t (a, npix) +asum 9 ./vops/asum.gx double procedure asum$t (a, npix) +asum 11 ./vops/asum.gx PIXEL procedure asum$t (a, npix) +asumd 6 ./vops/lz/asumd.x double procedure asumd (a, npix) +asumi 6 ./vops/lz/asumi.x real procedure asumi (a, npix) +asuml 6 ./vops/lz/asuml.x double procedure asuml (a, npix) +asumr 6 ./vops/lz/asumr.x real procedure asumr (a, npix) +asums 6 ./vops/lz/asums.x real procedure asums (a, npix) +asumx 6 ./vops/lz/asumx.x complex procedure asumx (a, npix) +atof 1 ./libc/atof.c atof (str) +atoi 1 ./libc/atoi.c atoi (str) +atol 1 ./libc/atol.c atol (str) +aupx 6 ./vops/aupx.gx procedure aupx$t (a, b, c, npix) +aupxd 6 ./vops/lz/aupxd.x procedure aupxd (a, b, c, npix) +aupxi 6 ./vops/lz/aupxi.x procedure aupxi (a, b, c, npix) +aupxl 6 ./vops/lz/aupxl.x procedure aupxl (a, b, c, npix) +aupxr 6 ./vops/lz/aupxr.x procedure aupxr (a, b, c, npix) +aupxs 6 ./vops/lz/aupxs.x procedure aupxs (a, b, c, npix) +aupxx 6 ./vops/lz/aupxx.x procedure aupxx (a, b, c, npix) +aveq 5 ./vops/aveq.gx bool procedure aveq$t (a, b, npix) +aveqc 5 ./vops/lz/aveqc.x bool procedure aveqc (a, b, npix) +aveqd 5 ./vops/lz/aveqd.x bool procedure aveqd (a, b, npix) +aveqi 5 ./vops/lz/aveqi.x bool procedure aveqi (a, b, npix) +aveql 5 ./vops/lz/aveql.x bool procedure aveql (a, b, npix) +aveqr 5 ./vops/lz/aveqr.x bool procedure aveqr (a, b, npix) +aveqs 5 ./vops/lz/aveqs.x bool procedure aveqs (a, b, npix) +aveqx 5 ./vops/lz/aveqx.x bool procedure aveqx (a, b, npix) +await 12 ./fio/await.x int procedure await (fd) +awaitb 11 ./fio/awaitb.x int procedure awaitb (fd) +awrite 9 ./fio/awrite.x procedure awrite (fd, buffer, nchars, char_offset) +awriteb 12 ./fio/awriteb.x procedure awriteb (fd, buffer, nbytes, byte_offset) +awsu 5 ./vops/awsu.gx procedure awsu$t (a, b, c, npix, k1, k2) +awsud 5 ./vops/lz/awsud.x procedure awsud (a, b, c, npix, k1, k2) +awsui 5 ./vops/lz/awsui.x procedure awsui (a, b, c, npix, k1, k2) +awsul 5 ./vops/lz/awsul.x procedure awsul (a, b, c, npix, k1, k2) +awsur 5 ./vops/lz/awsur.x procedure awsur (a, b, c, npix, k1, k2) +awsus 5 ./vops/lz/awsus.x procedure awsus (a, b, c, npix, k1, k2) +awsux 5 ./vops/lz/awsux.x procedure awsux (a, b, c, npix, k1, k2) +awvg 9 ./vops/awvg.gx int procedure awvg$t (a, npix, mean, sigma, lcut, hcut) +awvgd 9 ./vops/lz/awvgd.x int procedure awvgd (a, npix, mean, sigma, lcut, hcut) +awvgi 9 ./vops/lz/awvgi.x int procedure awvgi (a, npix, mean, sigma, lcut, hcut) +awvgl 9 ./vops/lz/awvgl.x int procedure awvgl (a, npix, mean, sigma, lcut, hcut) +awvgr 9 ./vops/lz/awvgr.x int procedure awvgr (a, npix, mean, sigma, lcut, hcut) +awvgs 9 ./vops/lz/awvgs.x int procedure awvgs (a, npix, mean, sigma, lcut, hcut) +awvgx 9 ./vops/lz/awvgx.x int procedure awvgx (a, npix, mean, sigma, lcut, hcut) +axor 5 ./vops/axor.gx procedure axor$t (a, b, c, npix) +axori 5 ./vops/lz/axori.x procedure axori (a, b, c, npix) +axork 5 ./vops/axork.gx procedure axork$t (a, b, c, npix) +axorki 5 ./vops/lz/axorki.x procedure axorki (a, b, c, npix) +axorkl 5 ./vops/lz/axorkl.x procedure axorkl (a, b, c, npix) +axorks 5 ./vops/lz/axorks.x procedure axorks (a, b, c, npix) +axorl 5 ./vops/lz/axorl.x procedure axorl (a, b, c, npix) +axors 5 ./vops/lz/axors.x procedure axors (a, b, c, npix) +balls 243 ./gio/zzdebug.x procedure balls() +begmem 38 ./memdbg/begmem.x int procedure begmem (best_size, old_size, max_size) +begmem 38 ./memio/begmem.x int procedure begmem (best_size, old_size, max_size) +bfalcx 178 ./imfort/bfio.x procedure bfalcx (fname, nchars, status) +bfaloc 88 ./imfort/bfio.x procedure bfaloc (fname, nchars, status) +bfbsiz 194 ./imfort/bfio.x int procedure bfbsiz (fp) +bfchan 221 ./imfort/bfio.x int procedure bfchan (fp) +bfclos 157 ./imfort/bfio.x procedure bfclos (fp, status) +bffill 409 ./imfort/bfio.x int procedure bffill (fp, offset, nchars, rwflag) +bfflsh 453 ./imfort/bfio.x int procedure bfflsh (fp) +bffsiz 205 ./imfort/bfio.x int procedure bffsiz (fp) +bfmode 479 ./imfort/bfio.x int procedure bfmode (acmode) +bfopen 71 ./imfort/bfio.x int procedure bfopen (fname, acmode, advice) +bfopnx 105 ./imfort/bfio.x pointer procedure bfopnx (fname, acmode, advice) +bfread 233 ./imfort/bfio.x int procedure bfread (fp, buf, nchars, offset) +bfrseq 338 ./imfort/bfio.x int procedure bfrseq (fp, buf, nchars) +bfseek 381 ./imfort/bfio.x int procedure bfseek (fp, offset) +bfwrit 287 ./imfort/bfio.x int procedure bfwrit (fp, buf, nchars, offset) +bfwseq 359 ./imfort/bfio.x int procedure bfwseq (fp, buf, nchars) +bitmov 7 ./osb/bitmov.x procedure bitmov (a, a_off, b, b_off, nbits) +blockit 318 ./gio/nsppkern/gktpcell.x procedure blockit( from, to, count, factor) +brktime 14 ./etc/brktime.x procedure brktime (ltime, tm) +btoi 5 ./etc/btoi.x int procedure btoi (boolean_value) +c_access 1 ./libc/caccess.c c_access (fname, mode, type) +c_allocate 1 ./libc/callocate.c c_allocate (device) +c_clktime 1 ./libc/cclktime.c c_clktime (reftime) +c_close 1 ./libc/cclose.c c_close (fd) +c_cnvdate 1 ./libc/ccnvdate.c c_cnvdate (clktime, outstr, maxch) +c_cnvtime 1 ./libc/ccnvtime.c c_cnvtime (clktime, outstr, maxch) +c_cputime 1 ./libc/cclktime.c c_cputime (reftime) +c_deallocate 1 ./libc/callocate.c c_deallocate (device, rewind) +c_delete 1 ./libc/cdelete.c c_delete (fname) +c_devowner 1 ./libc/callocate.c c_devowner (device, owner, maxch) +c_devstatus 1 ./libc/callocate.c c_devstatus (device, out) +c_envfind 2 ./libc/cenvget.c c_envfind (var, outstr, maxch) +c_envfree 1 ./libc/cenvmark.c c_envfree (envp, userfcn) +c_envgetb 2 ./libc/cenvget.c c_envgetb (var) +c_envgeti 2 ./libc/cenvget.c c_envgeti (var) +c_envgets 1 ./libc/cenvget.c c_envgets (var, outstr, maxch) +c_envlist 1 ./libc/cenvlist.c c_envlist (fd, prefix, show_redefs) +c_envmark 1 ./libc/cenvmark.c c_envmark (envp) +c_envputs 2 ./libc/cenvget.c c_envputs (var, value) +c_envreset 2 ./libc/cenvget.c c_envreset (var, value) +c_envscan 1 ./libc/cenvscan.c c_envscan (input_source) +c_erract 1 ./libc/cerract.c c_erract (action) +c_errcode 1 ./libc/cerrcode.c c_errcode() +c_errget 1 ./libc/cerrget.c c_errget (outstr, maxch) +c_error 1 ./libc/cerror.c c_error (errcode, errmsg) +c_fchdir 1 ./libc/cfchdir.c c_fchdir (newdir) +c_filbuf 1 ./libc/cfilbuf.c c_filbuf (fp) +c_finfo 1 ./libc/cfinfo.c c_finfo (fname, fi) +c_flsbuf 1 ./libc/cflsbuf.c c_flsbuf (ch, fp) +c_flush 1 ./libc/cflush.c c_flush (fd) +c_fmapfn 1 ./libc/cfmapfn.c c_fmapfn (vfn, osfn, maxch) +c_fmkdir 1 ./libc/cfmkdir.c c_fmkdir (newdir) +c_fnextn 1 ./libc/cfnextn.c c_fnextn (vfn, extn, maxch) +c_fnldir 1 ./libc/cfnldir.c c_fnldir (vfn, ldir, maxch) +c_fnroot 1 ./libc/cfnroot.c c_fnroot (vfn, root, maxch) +c_fpathname 1 ./libc/cfpath.c c_fpathname (vfn, osfn, maxch) +c_fprintf 1 ./libc/cprintf.c c_fprintf (fd, format) +c_fredir 1 ./libc/cfredir.c c_fredir (fd, fname, mode, type) +c_fseti 1 ./libc/cfseti.c c_fseti (fd, param, value) +c_fstati 1 ./libc/cfstati.c c_fstati (fd, param) +c_getpid 1 ./libc/cgetpid.c c_getpid() +c_getuid 1 ./libc/cgetuid.c c_getuid (outstr, maxch) +c_gflush 1 ./libc/cgflush.c c_gflush (stream) +c_imaccess 1 ./libc/cimaccess.c c_imaccess (imname, mode) +c_imdrcur 1 ./libc/cimdrcur.c c_imdrcur (device, x, y, wcs, key, strval, maxch, / +c_kimapchan 1 ./libc/ckimapc.c c_kimapchan (chan, nodename, maxch) +c_lexnum 1 ./libc/clexnum.c c_lexnum (str, toklen) +c_mktemp 1 ./libc/cmktemp.c c_mktemp (root, temp_filename, maxch) +c_note 1 ./libc/cnote.c c_note (fd) +c_open 1 ./libc/copen.c c_open (fname, mode, type) +c_oscmd 1 ./libc/coscmd.c c_oscmd (cmd, infile, outfile, errfile) +c_pargb 1 ./libc/cprintf.c c_pargb (ival) +c_pargc 1 ./libc/cprintf.c c_pargc (ival) +c_pargd 1 ./libc/cprintf.c c_pargd (dval) +c_pargi 1 ./libc/cprintf.c c_pargi (ival) +c_pargl 1 ./libc/cprintf.c c_pargl (lval) +c_pargr 1 ./libc/cprintf.c c_pargr (rval) +c_pargs 1 ./libc/cprintf.c c_pargs (sval) +c_pargstr 1 ./libc/cprintf.c c_pargstr (strval) +c_prchdir 3 ./libc/cprcon.c c_prchdir (pid, newdir) +c_prcldpr 1 ./libc/cprdet.c c_prcldpr (job) +c_prclose 2 ./libc/cprcon.c c_prclose (pid) +c_prdone 2 ./libc/cprdet.c c_prdone (job) +c_prenvfree 1 ./libc/cenvmark.c c_prenvfree (pid, envp) +c_prenvset 3 ./libc/cprcon.c c_prenvset (pid, envvar, value) +c_printf 1 ./libc/cprintf.c c_printf (format) +c_prkill 2 ./libc/cprdet.c c_prkill (job) +c_propdpr 1 ./libc/cprdet.c c_propdpr (process, bkgfile, bkgmsg) +c_propen 1 ./libc/cprcon.c c_propen (process, in, out) +c_prredir 3 ./libc/cprcon.c c_prredir (pid, stream, new_fd) +c_prsignal 2 ./libc/cprcon.c c_prsignal (pid, signal) +c_prstati 2 ./libc/cprcon.c c_prstati (pid, param) +c_rcursor 1 ./libc/crcursor.c c_rcursor (fd, outstr, maxch) +c_rdukey 1 ./libc/crdukey.c c_rdukey (obuf, maxch) +c_read 1 ./libc/cread.c c_read (fd, buf, maxbytes) +c_rename 1 ./libc/crename.c c_rename (old_fname, new_fname) +c_salloc 1 ./libc/csalloc.c c_salloc (nbytes) +c_seek 1 ./libc/cseek.c c_seek (fd, offset) +c_sfree 2 ./libc/csalloc.c c_sfree (sp) +c_smark 1 ./libc/csalloc.c c_smark (sp) +c_sppstr 1 ./libc/csppstr.c c_sppstr (str) +c_stggetline 1 ./libc/stgio.c c_stggetline (fd, buf) +c_stgputline 1 ./libc/stgio.c c_stgputline (fd, buf) +c_stropen 1 ./libc/cstropen.c c_stropen (obuf, maxch, mode) +c_strpak 1 ./libc/cstrpak.c c_strpak (sppstr, cstr, maxch) +c_strupk 1 ./libc/cstrupk.c c_strupk (str, outstr, maxch) +c_sttyco 1 ./libc/cttset.c c_sttyco (args, ttin, ttout, outfd) +c_tsleep 1 ./libc/ctsleep.c c_tsleep (nseconds) +c_ttseti 1 ./libc/cttset.c c_ttseti (fd, param, value) +c_ttsets 1 ./libc/cttset.c c_ttsets (fd, param, value) +c_ttstati 1 ./libc/cttset.c c_ttstati (fd, param) +c_ttstats 1 ./libc/cttset.c c_ttstats (fd, param, outstr, maxch) +c_ttycdes 1 ./libc/cttycdes.c c_ttycdes (tty) +c_ttyclear 1 ./libc/cttyclear.c c_ttyclear (fd, tty) +c_ttyclearln 1 ./libc/cttyclln.c c_ttyclearln (fd, tty) +c_ttyctrl 1 ./libc/cttyctrl.c c_ttyctrl (fd, tty, cap, afflncnt) +c_ttygetb 1 ./libc/cttygetb.c c_ttygetb (tty, cap) +c_ttygeti 1 ./libc/cttygeti.c c_ttygeti (tty, cap) +c_ttygetr 1 ./libc/cttygetr.c c_ttygetr (tty, cap) +c_ttygets 1 ./libc/cttygets.c c_ttygets (tty, cap, outstr, maxch) +c_ttygoto 1 ./libc/cttygoto.c c_ttygoto (fd, tty, col, line) +c_ttyinit 1 ./libc/cttyinit.c c_ttyinit (fd, tty) +c_ttyodes 2 ./libc/cttyodes.c c_ttyodes (ttyname) +c_ttyputline 1 ./libc/cttyputl.c c_ttyputline (fd, tty, line, map_cc) +c_ttyputs 1 ./libc/cttyputs.c c_ttyputs (fd, tty, cap, afflncnt) +c_ttyseti 1 ./libc/cttyseti.c c_ttyseti (tty, param, value) +c_ttyso 1 ./libc/cttyso.c c_ttyso (fd, tty, onoff) +c_ttystati 1 ./libc/cttystati.c c_ttystati (tty, param) +c_ungetc 1 ./libc/cungetc.c c_ungetc (fd, ch) +c_ungetline 1 ./libc/cungetl.c c_ungetline (fd, str) +c_vfnbrk 1 ./libc/cvfnbrk.c c_vfnbrk (vfn, root, extn) +c_wmsec 1 ./libc/cwmsec.c c_wmsec (msec) +c_write 1 ./libc/cwrite.c c_write (fd, buf, nbytes) +c_xgmes 1 ./libc/cxgmes.c c_xgmes (oscode, oserrmsg, maxch) +c_xonerr 1 ./libc/cxonerr.c c_xonerr (errcode) +c_xttysize 1 ./libc/cxttysize.c c_xttysize (ncols, nlines) +c_xwhen 1 ./libc/cxwhen.c c_xwhen (exception, new_handler, old_handler) +calcmarker 140 ./gio/calcomp/vttest.x procedure calcmarker (x, y, marktype, p, npts) +calloc 1 ./libc/calloc.c calloc (nelems, elsize) +calloc 5 ./memdbg/calloc.x procedure calloc (ubufp, buflen, dtype) +calloc 5 ./memio/calloc.x procedure calloc (ubufp, buflen, dtype) +ccp_calcseg 14 ./gio/calcomp/ccpcseg.x procedure ccp_calcseg (p, npts, ltype, curpl_pt, segsize, xseg,yseg, nsegpts) +ccp_clear 10 ./gio/calcomp/ccpclear.x procedure ccp_clear (dummy) +ccp_close 7 ./gio/calcomp/ccpclose.x procedure ccp_close() +ccp_closews 8 ./gio/calcomp/ccpclws.x procedure ccp_closews (devname, n) +ccp_color 14 ./gio/calcomp/ccpcolor.x procedure ccp_color(index) +ccp_drawchar 20 ./gio/calcomp/ccpdrawch.x procedure ccp_drawchar (ch, x, y, xsize, ysize, orien, font, quality) +ccp_drawseg 15 ./gio/calcomp/ccpdseg.x procedure ccp_drawseg (xseg, yseg, nsegpts, lwidth) +ccp_escape 9 ./gio/calcomp/ccpescape.x procedure ccp_escape (fn, instruction, nwords) +ccp_faset 8 ./gio/calcomp/ccpfaset.x procedure ccp_faset (gki) +ccp_fillarea 7 ./gio/calcomp/ccpfa.x procedure ccp_fillarea (p, npts) +ccp_font 13 ./gio/calcomp/ccpfont.x procedure ccp_font (font) +ccp_init 13 ./gio/calcomp/ccpinit.x procedure ccp_init (tty, devname) +ccp_linetype 8 ./gio/calcomp/ccpltype.x procedure ccp_linetype (index) +ccp_lwidth 13 ./gio/calcomp/ccplwidth.x procedure ccp_lwidth (index) +ccp_open 11 ./gio/calcomp/ccpopen.x procedure ccp_open (devname, dd) +ccp_openws 13 ./gio/calcomp/ccpopenws.x procedure ccp_openws (devname, n, mode) +ccp_plset 9 ./gio/calcomp/ccpplset.x procedure ccp_plset (gki) +ccp_pmset 8 ./gio/calcomp/ccppmset.x procedure ccp_pmset (gki) +ccp_polyline 12 ./gio/calcomp/ccppl.x procedure ccp_polyline (p, npts) +ccp_polymarker 12 ./gio/calcomp/ccppm.x procedure ccp_polymarker (p, npts) +ccp_reset 12 ./gio/calcomp/ccpreset.x procedure ccp_reset() +ccp_text 20 ./gio/calcomp/ccptx.x procedure ccp_text (xc, yc, text, n) +ccp_txset 9 ./gio/calcomp/ccptxset.x procedure ccp_txset (gki) +cctoc 18 ./fmtio/cctoc.x int procedure cctoc (str, ip, cval) +ccx_addsegpt 189 ./gio/calcomp/ccpcseg.x procedure ccx_addsegpt (x,y, xseg,yseg, cursegpt,segsize) +ccx_dash 94 ./gio/calcomp/ccpcseg.x procedure ccx_dash (p, npts, curpl_pt, curseglen, cursegpt, segsize, +ccx_gap 145 ./gio/calcomp/ccpcseg.x procedure ccx_gap (p, npts, curpl_pt, curseglen, matchlen, lastp_x,lastp_y) +ccx_interpoly 121 ./gio/calcomp/ccpdrawch.x procedure ccx_interpoly (x, y, npts, quality) +ccx_intersymbol 190 ./gio/calcomp/ccpdrawch.x procedure ccx_intersymbol (x,y, xsize,ysize, ch, orien) +ccx_offsets 171 ./gio/calcomp/ccpdseg.x procedure ccx_offsets (p1x,p1y, p2x,p2y, p3x,p3y, delx,dely) +ccx_parameters 283 ./gio/calcomp/ccptx.x procedure ccx_parameters (xc, yc, totlen, x0, y0, dx, dy, polytext, orien) +ccx_segment 223 ./gio/calcomp/ccptx.x int procedure ccx_segment (text, n, out, start_font) +chdeposit 6 ./fmtio/chdeposit.x procedure chdeposit (ch, str, maxch, op) +checksum 421 ./fio/zzdebug.x int procedure checksum (buf, nchars) +chfetch 5 ./fmtio/chfetch.x char procedure chfetch (str, ip, ch) +chk_prot 2 ../unix/os/zfprot.c chk_prot (fname, link_name) +chrlwr 7 ./fmtio/chrlwr.x char procedure chrlwr (ch) +chrupr 7 ./fmtio/chrupr.x char procedure chrupr (ch) +cl_initargs 156 ./imfort/clargs.x procedure cl_initargs (ier) +cl_psio_request 272 ./clio/zfiocl.x int procedure cl_psio_request (cmd, arg1, arg2) +clargc 36 ./imfort/clargs.x procedure clargc (argno, outstr, ier) +clargd 100 ./imfort/clargs.x procedure clargd (argno, dval, ier) +clargi 64 ./imfort/clargs.x procedure clargi (argno, ival, ier) +clargr 82 ./imfort/clargs.x procedure clargr (argno, rval, ier) +clc_compress 447 ./clio/clcache.x procedure clc_compress () +clc_enter 152 ./clio/clcache.x procedure clc_enter (param, value) +clc_fetch 229 ./clio/clcache.x int procedure clc_fetch (param, outstr, maxch) +clc_find 265 ./clio/clcache.x pointer procedure clc_find (param, outstr, maxch) +clc_free 127 ./clio/clcache.x procedure clc_free (marker) +clc_init 72 ./clio/clcache.x procedure clc_init() +clc_list 383 ./clio/clcache.x procedure clc_list (fd, pset, format) +clc_mark 114 ./clio/clcache.x procedure clc_mark (marker) +clc_newtask 97 ./clio/clcache.x procedure clc_newtask (taskname) +clc_scan 333 ./clio/clcache.x procedure clc_scan (cmd) +clclose 8 ./clio/clclose.x procedure clclose () +clcmd 16 ./clio/clcmd.x procedure clcmd (cmd) +clcmdw 8 ./clio/clcmdw.x procedure clcmdw (cmd) +clcpset 5 ./clio/clcpset.x procedure clcpset (pp) +clepset 10 ./clio/clepset.x procedure clepset (pp) +clgcur 22 ./clio/clgcur.x int procedure clgcur (param, wx, wy, wcs, key, strval, maxch) +clgetb 7 ./clio/clgetb.x bool procedure clgetb (param) +clgetc 7 ./clio/clgetc.x char procedure clgetc (param) +clgetd 7 ./clio/clgetd.x double procedure clgetd (param) +clgeti 5 ./clio/clgeti.x int procedure clgeti (param) +clgetl 5 ./clio/clgetl.x long procedure clgetl (param) +clgetr 5 ./clio/clgetr.x real procedure clgetr (param) +clgets 5 ./clio/clgets.x short procedure clgets (param) +clgetx 7 ./clio/clgetx.x complex procedure clgetx (param) +clgfil 113 ./clio/clgfil.x int procedure clgfil (list, fname, maxch) +clgkey 9 ./clio/clgkey.x int procedure clgkey (param, key, strval, maxch) +clglpb 7 ./clio/clglpb.x int procedure clglpb (param, bval) +clglpc 7 ./clio/clglpc.x int procedure clglpc (param, cval) +clglpd 8 ./clio/clglpd.x int procedure clglpd (param, dval) +clglpi 5 ./clio/clglpi.x int procedure clglpi (param, ival) +clglpl 5 ./clio/clglpl.x int procedure clglpl (param, lval) +clglpr 6 ./clio/clglpr.x int procedure clglpr (param, rval) +clglps 5 ./clio/clglps.x int procedure clglps (param, sval) +clglpx 7 ./clio/clglpx.x int procedure clglpx (param, xval) +clglstr 5 ./clio/clglstr.x int procedure clglstr (param, outstr, maxch) +clgpset 8 ./clio/clgpset.x procedure clgpset (pp, pname, outstr, maxch) +clgpseta 7 ./clio/clgpseta.x procedure clgpseta (pp, pname, outstr, maxch) +clgpsetb 7 ./clio/clgpsetb.x bool procedure clgpsetb (pp, parname) +clgpsetc 7 ./clio/clgpsetc.x char procedure clgpsetc (pp, parname) +clgpsetd 7 ./clio/clgpsetd.x double procedure clgpsetd (pp, parname) +clgpseti 7 ./clio/clgpseti.x int procedure clgpseti (pp, parname) +clgpsetl 7 ./clio/clgpsetl.x long procedure clgpsetl (pp, parname) +clgpsetr 7 ./clio/clgpsetr.x real procedure clgpsetr (pp, parname) +clgpsets 7 ./clio/clgpsets.x short procedure clgpsets (pp, parname) +clgpsetx 7 ./clio/clgpsetx.x complex procedure clgpsetx (pp, parname) +clgstr 7 ./clio/clgstr.x procedure clgstr (param, outstr, maxch) +clgwrd 11 ./clio/clgwrd.x int procedure clgwrd (param, keyword, maxchar, dictionary) +clktime 8 ./etc/clktime.x long procedure clktime (old_time) +cllpset 8 ./clio/cllpset.x procedure cllpset (pp, fd, format) +clnarg 133 ./imfort/clargs.x procedure clnarg (nargs) +clopen 15 ./clio/clopen.x procedure clopen (stdin_chan, stdout_chan, stderr_chan, device, devtype) +clopset 7 ./clio/clopset.x pointer procedure clopset (pset) +close 10 ./fio/close.x procedure close (fd_arg) +clpcls 127 ./clio/clgfil.x procedure clpcls (list) +clplen 101 ./clio/clgfil.x int procedure clplen (list) +clpopni 26 ./clio/clgfil.x int procedure clpopni (param) +clpopns 54 ./clio/clgfil.x int procedure clpopns (param) +clpopnu 78 ./clio/clgfil.x int procedure clpopnu (param) +clppset 8 ./clio/clppset.x procedure clppset (pp, pname, sval) +clppseta 7 ./clio/clppseta.x procedure clppseta (pp, pname, sval) +clppsetb 7 ./clio/clppsetb.x procedure clppsetb (pp, parname, bval) +clppsetc 7 ./clio/clppsetc.x procedure clppsetc (pp, parname, cval) +clppsetd 7 ./clio/clppsetd.x procedure clppsetd (pp, parname, dval) +clppseti 7 ./clio/clppseti.x procedure clppseti (pp, parname, ival) +clppsetl 7 ./clio/clppsetl.x procedure clppsetl (pp, parname, lval) +clppsetr 7 ./clio/clppsetr.x procedure clppsetr (pp, parname, rval) +clppsets 7 ./clio/clppsets.x procedure clppsets (pp, parname, sval) +clppsetx 7 ./clio/clppsetx.x procedure clppsetx (pp, parname, xval) +clprew 138 ./clio/clgfil.x procedure clprew (list) +clprintf 9 ./fmtio/clprintf.x procedure clprintf (param, format_string) +clpset_parname 8 ./clio/clpsetnm.x pointer procedure clpset_parname (pp, parname) +clpstr 5 ./clio/clpstr.x procedure clpstr (param, value) +clputb 5 ./clio/clputb.x procedure clputb (param, bval) +clputc 7 ./clio/clputc.x procedure clputc (param, cval) +clputd 5 ./clio/clputd.x procedure clputd (param, dval) +clputi 5 ./clio/clputi.x procedure clputi (param, value) +clputl 39 ./clio/clputi.x procedure clputl (param, lval) +clputr 5 ./clio/clputr.x procedure clputr (param, rval) +clputs 22 ./clio/clputi.x procedure clputs (param, value) +clputx 5 ./clio/clputx.x procedure clputx (param, xval) +clrawc 210 ./imfort/clargs.x procedure clrawc (outstr, ier) +clreqpar 7 ./clio/clreqpar.x procedure clreqpar (param) +clscan 5 ./fmtio/clscan.x int procedure clscan (param) +clseti 10 ./clio/clseti.x procedure clseti (parameter, value) +clstati 11 ./clio/clstati.x int procedure clstati (parameter) +cnvdate 14 ./etc/cnvdate.x procedure cnvdate (ltime, outstr, maxch) +cnvtime 13 ./etc/cnvtime.x procedure cnvtime (ltime, outstr, maxch) +coerce 6 ./memdbg/coerce.x pointer procedure coerce (ptr, type1, type2) +coerce 6 ./memio/coerce.x pointer procedure coerce (ptr, type1, type2) +conv_test 1081 ./pmio/zzinterp.x procedure conv_test (pm_1, pm_2, fd, opcode) +conv_test 1333 ./plio/zzdebug.x procedure conv_test (pl_1, pl_2, fd, opcode) +cputime 6 ./etc/cputime.x long procedure cputime (old_cputime) +ctocc 17 ./fmtio/ctocc.x int procedure ctocc (ch, outstr, maxch) +ctod 44 ./fmtio/ctod.x int procedure ctod (str, ip, dval) +ctoi 7 ./fmtio/ctoi.x int procedure ctoi (str, ip, ival) +ctol 7 ./fmtio/ctol.x int procedure ctol (str, ip, lval) +ctor 9 ./fmtio/ctor.x int procedure ctor (str, ip, rval) +ctotok 90 ./fmtio/ctotok.x int procedure ctotok (str, ip, outstr, maxch) +ctowrd 11 ./fmtio/ctowrd.x int procedure ctowrd (str, ip, outstr, maxch) +ctox 9 ./fmtio/ctox.x int procedure ctox (str, ip, xval) +d_compar 4 ../unix/os/zopdir.c d_compar (a, b) +d_qsort 5 ../unix/os/zopdir.c d_qsort (base, n, size, compar) +d_qst 6 ../unix/os/zopdir.c d_qst (base, max) +dbgmsg 20 ../unix/os/zfioks.c dbgmsg (msg) +dbgmsg1 20 ../unix/os/zfioks.c dbgmsg1 (fmt, arg) +dbgmsg2 20 ../unix/os/zfioks.c dbgmsg2 (fmt, arg1, arg2) +dbgmsg3 20 ../unix/os/zfioks.c dbgmsg3 (fmt, arg1, arg2, arg3) +dbgmsg4 21 ../unix/os/zfioks.c dbgmsg4 (fmt, arg1, arg2, arg3, arg4) +dealloc 3 ../unix/os/alloc.c dealloc (argv) +delete 16 ./fio/delete.x procedure delete (fname) +deletefg 12 ./fio/deletefg.x procedure deletefg (fname, versions, subfiles) +diropen 19 ./fio/diropen.x int procedure diropen (fname, mode) +dtcscl 6 ./fmtio/dtcscl.x procedure dtcscl (v, e, sense) +dtoc 10 ./fmtio/dtoc.x int procedure dtoc (dval, outstr, maxch, decpl, a_fmt, width) +dtoc3 36 ./fmtio/dtoc3.x int procedure dtoc3 (val, out, maxch, decpl, a_fmt, width) +dump_chars 151 ./tty/zzdebug.x procedure dump_chars (fd, str) +elogd 16 ./gio/elogd.x double procedure elogd (x) +elogr 16 ./gio/elogr.x real procedure elogr (x) +env_first 9 ./etc/envnext.x pointer procedure env_first (valp) +env_init 9 ./etc/envinit.x procedure env_init() +env_next 29 ./etc/envnext.x pointer procedure env_next (last_el, valp, show_redefines) +envdebug 141 ./etc/zzdebug.x procedure envdebug (fd) +envfind 69 ./etc/environ.x int procedure envfind (key, value, maxch) +envfree 241 ./etc/environ.x int procedure envfree (old_top, userfcn) +envget 1 ./libc/cenvget.c envget (var) +envgetb 8 ./etc/envgetb.x bool procedure envgetb (varname) +envgetd 10 ./etc/envgetd.x double procedure envgetd (varname) +envgeti 10 ./etc/envgeti.x int procedure envgeti (varname) +envgetr 7 ./etc/envgetr.x real procedure envgetr (varname) +envgets 13 ./etc/envgets.x int procedure envgets (key, value, maxch) +envindir 8 ./etc/envindir.x procedure envindir (envvar, outstr, maxch) +envlist 10 ./etc/envlist.x procedure envlist (fd, prefix, print_redefined_variables) +envmark 224 ./etc/environ.x procedure envmark (old_top) +envputs 132 ./etc/environ.x int procedure envputs (key, value) +envreset 16 ./etc/envreset.x procedure envreset (key, value) +envscan 20 ./etc/envscan.x int procedure envscan (cmd) +eprintf 1 ./libc/eprintf.c eprintf (va_alist) +eprintf 7 ./fmtio/eprintf.x procedure eprintf (format_string) +erract 36 ./etc/erract.x procedure erract (severity) +errcode 12 ./etc/errcode.x int procedure errcode() +errget 12 ./etc/errget.x int procedure errget (outstr, maxch) +error 10 ./etc/error.x procedure error (error_code, message) +evexpr 61 ./fmtio/evexpr.x pointer procedure evexpr (expr, getop_epa, ufcn_epa) +evvexpr 159 ./fmtio/evvexpr.x pointer procedure evvexpr (expr, getop, getop_data, ufcn, ufcn_data, flags) +evvfree 218 ./fmtio/evvexpr.x procedure evvfree (o) +ex_handler 5 ../unix/os/zxwhen.c ex_handler (unix_signal, info, ucp) +fakepc 295 ./gio/nsppkern/gktpcell.x procedure fakepc (indata, outdata, nx, scale) +falloc 15 ./fio/falloc.x procedure falloc (fname, file_size) +fatal 32 ./etc/error.x procedure fatal (error_code, message) +fcanpb 11 ./fio/fcanpb.x procedure fcanpb (fd) +fchdir 8 ./fio/fchdir.x procedure fchdir (newdir) +fcldir 124 ./fio/diropen.x procedure fcldir (channel, status) +fclobber 12 ./fio/fclobber.x procedure fclobber (fname) +fclose 1 ./libc/fclose.c fclose (fp) +fcopy 15 ./fio/fcopy.x procedure fcopy (oldfile, newfile) +fcopyo 57 ./fio/fcopy.x procedure fcopyo (in, out) +fdebug 9 ./fio/fdebug.x procedure fdebug (out, fd1_arg, fd2_arg) +fdevbf 10 ./fio/fdevbf.x procedure fdevbf (zard, zawr, zawt, zstt, zcls) +fdevblk 10 ./fio/fdevblk.x int procedure fdevblk (path) +fdevtx 10 ./fio/fdevtx.x procedure fdevtx (zget, zput, zfls, zstt, zcls, zsek, znot) +fdirname 10 ./fio/fdirname.x procedure fdirname (vfn, path, maxch) +fdopen 1 ./libc/fdopen.c fdopen (fd, mode) +fencd 16 ./gio/ncarutil/sysint/fencode.x procedure fencd (nchars, f_format, spp_outstr, rval) +fencd 16 ./gio/nspp/sysint/fencode.x procedure fencd (nchars, f_format, spp_outstr, rval) +fexbuf 16 ./fio/fexbuf.x procedure fexbuf (fd) +ffault 14 ./fio/ffault.x int procedure ffault (fd, file_offset, nreserve, rwflag) +ffilbf 8 ./fio/ffilbf.x procedure ffilbf (fd, bp, bufsize, buffer_offset) +ffilsz 11 ./fio/ffilsz.x long procedure ffilsz (fd) +ffldir 224 ./fio/diropen.x procedure ffldir (chan, status) +fflsbf 10 ./fio/fflsbf.x procedure fflsbf (fd, bp, maxchars, buffer_offset) +fflush 1 ./libc/fflush.c fflush (fp) +fgdev0 65 ./fio/fgdevpar.x long procedure fgdev0 (ffp, what) +fgdev_param 33 ./fio/fgdevpar.x procedure fgdev_param (fd) +fgetc 1 ./libc/fgetc.c fgetc (fp) +fgetfd 11 ./fio/fgetfd.x int procedure fgetfd (filename, mode, type) +fgets 1 ./libc/fgets.c fgets (buf, maxch, fp) +fgtdir 153 ./fio/diropen.x procedure fgtdir (chan, outline, maxch, status) +filbuf 12 ./fio/filbuf.x int procedure filbuf (fd) +filerr 9 ./fio/filerr.x procedure filerr (fname, errcode) +filopn 21 ./fio/filopn.x int procedure filopn (fname, mode, type, zopen_proc, device) +findsfs 3 ../unix/os/alloc.c findsfs (argv) +finfo 28 ./fio/finfo.x int procedure finfo (fname, ostruct) +finit 14 ./fio/finit.x procedure finit() +fio_cleanup 15 ./fio/fioclean.x procedure fio_cleanup (status) +fio_qflush 110 ./fio/fioclean.x procedure fio_qflush (fd, status) +fixmem 58 ./memdbg/begmem.x procedure fixmem (old_size) +fixmem 58 ./memio/begmem.x procedure fixmem (old_size) +flsbuf 17 ./fio/flsbuf.x procedure flsbuf (fd, nreserve) +flush 9 ./fio/flush.x procedure flush (fd) +fm_access 6 ./fmio/fmaccess.x int procedure fm_access (dfname, mode) +fm_close 10 ./fmio/fmclose.x procedure fm_close (fm) +fm_copy 9 ./fmio/fmcopy.x procedure fm_copy (dfname, newname) +fm_copyo 12 ./fmio/fmcopyo.x procedure fm_copyo (old, new) +fm_debug 15 ./fmio/fmdebug.x procedure fm_debug (fm, out, what) +fm_delete 5 ./fmio/fmdelete.x procedure fm_delete (dfname) +fm_fcdebug 268 ./fmio/fmfcache.x procedure fm_fcdebug (fm, out, what) +fm_fcfree 346 ./fmio/fmfcache.x procedure fm_fcfree (fm) +fm_fcinit 323 ./fmio/fmfcache.x procedure fm_fcinit (fm, cachesize) +fm_fcsync 376 ./fmio/fmfcache.x procedure fm_fcsync (fm) +fm_findlf 246 ./fmio/fmfcache.x pointer procedure fm_findlf (fc, lfile) +fm_fopen 6 ./fmio/fmfopen.x int procedure fm_fopen (fm, lfile, mode, type) +fm_getfd 53 ./fmio/fmfcache.x int procedure fm_getfd (fm, lfile, mode, type) +fm_lfaread 10 ./fmio/fmlfard.x procedure fm_lfaread (lf, buf, maxbytes, offset) +fm_lfawait 8 ./fmio/fmlfawt.x procedure fm_lfawait (lf, status) +fm_lfawrite 10 ./fmio/fmlfawr.x procedure fm_lfawrite (lf, buf, nbytes, offset) +fm_lfbinread 14 ./fmio/fmlfbrd.x procedure fm_lfbinread (lf, buf, maxbytes, offset) +fm_lfbinwait 8 ./fmio/fmlfbwt.x procedure fm_lfbinwait (lf, status) +fm_lfbinwrite 15 ./fmio/fmlfbwr.x procedure fm_lfbinwrite (lf, buf, nbytes, offset) +fm_lfclose 9 ./fmio/fmlfcls.x procedure fm_lfclose (lf, status) +fm_lfcopy 10 ./fmio/fmlfcopy.x procedure fm_lfcopy (old, o_lfile, new, n_lfile) +fm_lfdelete 8 ./fmio/fmlfdel.x procedure fm_lfdelete (fm, lfile) +fm_lfname 15 ./fmio/fmlfname.x procedure fm_lfname (fm, lfile, type, lfname, maxch) +fm_lfopen 9 ./fmio/fmlfopen.x procedure fm_lfopen (pk_lfname, mode, chan) +fm_lfparse 12 ./fmio/fmlfparse.x int procedure fm_lfparse (lfname, fm, lfile, type) +fm_lfstat 8 ./fmio/fmlfstat.x int procedure fm_lfstat (fm, lfile, statbuf) +fm_lfstati 10 ./fmio/fmlfstt.x procedure fm_lfstati (lf, param, lvalue) +fm_lfundelete 8 ./fmio/fmlfundel.x procedure fm_lfundelete (fm, lfile) +fm_locked 230 ./fmio/fmfcache.x bool procedure fm_locked (fm, lfile) +fm_lockout 178 ./fmio/fmfcache.x procedure fm_lockout (fm, lfile) +fm_nextlfile 10 ./fmio/fmnextlf.x int procedure fm_nextlfile (fm) +fm_open 12 ./fmio/fmopen.x pointer procedure fm_open (fname, mode) +fm_rebuild 8 ./fmio/fmrebuild.x procedure fm_rebuild (dfname) +fm_rename 5 ./fmio/fmrename.x procedure fm_rename (old, new) +fm_retfd 149 ./fmio/fmfcache.x procedure fm_retfd (fm, lfile) +fm_seti 8 ./fmio/fmseti.x procedure fm_seti (fm, param, value) +fm_stati 8 ./fmio/fmstati.x int procedure fm_stati (fm, param) +fm_sync 13 ./fmio/fmsync.x procedure fm_sync (fm) +fm_unlock 214 ./fmio/fmfcache.x procedure fm_unlock (fm, lfile) +fmapfn 12 ./fio/fmapfn.x procedure fmapfn (vfn, osfn, maxch) +fmio_bind 9 ./fmio/fmiobind.x procedure fmio_bind (fm) +fmio_errchk 8 ./fmio/fmioerr.x procedure fmio_errchk (fm) +fmio_extend 13 ./fmio/fmioextnd.x int procedure fmio_extend (fm, lfile, npages) +fmio_posterr 8 ./fmio/fmiopost.x procedure fmio_posterr (fm, errcode, opstr) +fmio_readheader 11 ./fmio/fmiorhdr.x procedure fmio_readheader (fm) +fmio_setbuf 12 ./fmio/fmiosbuf.x procedure fmio_setbuf (fm) +fmio_tick 8 ./fmio/fmiotick.x procedure fmio_tick (fm) +fmkbfs 10 ./fio/fmkbfs.x procedure fmkbfs (fd) +fmkcopy 17 ./fio/fmkcopy.x procedure fmkcopy (oldfile, newfile) +fmkdir 10 ./fio/fmkdir.x procedure fmkdir (newdir) +fmkpbbuf 9 ./fio/fmkpbbuf.x procedure fmkpbbuf (fd) +fmt_err 6 ./fmtio/fmterr.x procedure fmt_err (preamble, format, index) +fmt_init 10 ./fmtio/fmtinit.x procedure fmt_init (ftype) +fmt_read 10 ./fmtio/fmtread.x procedure fmt_read() +fmt_setcol 11 ./fmtio/fmtsetcol.x procedure fmt_setcol (ch, col) +fmtstr 10 ./fmtio/fmtstr.x procedure fmtstr (fd, str, col, fill_char, left_justify, maxch, width) +fnextn 8 ./fio/fnextn.x int procedure fnextn (vfn, outstr, maxch) +fnldir 12 ./fio/fnldir.x int procedure fnldir (vfn, outstr, maxch) +fnroot 9 ./fio/fnroot.x int procedure fnroot (vfn, outstr, maxch) +fnt_edit 414 ./fio/fntgfn.x int procedure fnt_edit (in, out, editp, nedit, patbuf) +fnt_getpat 577 ./fio/fntgfn.x int procedure fnt_getpat (template, ix, patp, npat, sbuf, maxch) +fnt_mkpat 345 ./fio/fntgfn.x procedure fnt_mkpat (pat, patstr, maxch, ep, nedit) +fnt_open_list 851 ./fio/fntgfn.x int procedure fnt_open_list (str, patstr, maxch, fname, ldir, ftype) +fnt_read_template 746 ./fio/fntgfn.x int procedure fnt_read_template (pp, outstr, maxch, token) +fntcls 955 ./fio/fntgfn.x procedure fntcls (pp) +fntclsb 525 ./fio/fntgfn.x procedure fntclsb (list) +fntdir 280 ./fio/diropen.x procedure fntdir (chan, offset) +fntgfn 641 ./fio/fntgfn.x int procedure fntgfn (pp, outstr, maxch) +fntgfnb 469 ./fio/fntgfn.x int procedure fntgfnb (list, fname, maxch) +fntlenb 556 ./fio/fntgfn.x int procedure fntlenb (list) +fntopn 930 ./fio/fntgfn.x pointer procedure fntopn (template) +fntopnb 100 ./fio/fntgfn.x int procedure fntopnb (template, sort) +fntrewb 541 ./fio/fntgfn.x procedure fntrewb (list) +fntrfnb 499 ./fio/fntgfn.x int procedure fntrfnb (list, index, fname, maxch) +fnullfile 5 ./fio/fnullfile.x bool procedure fnullfile (fname) +fopdir 87 ./fio/diropen.x procedure fopdir (osfn, mode, channel) +fopen 1 ./libc/fopen.c fopen (fname, modestr) +fopnbf 6 ./fio/fopnbf.x int procedure fopnbf (fname, mode, zopn, zard, zawr, zawa, zstt, zcls) +fopntx 6 ./fio/fopntx.x int procedure fopntx (fname,mode,zopn,zget,zput,zfls,zstt,zcls,zsek,znot) +fowner 8 ./fio/fowner.x procedure fowner (fname, owner, maxch) +fp_equald 12 ./gio/fpequald.x bool procedure fp_equald (x, y) +fp_equalr 12 ./gio/fpequalr.x bool procedure fp_equalr (x, y) +fp_fixd 18 ./gio/fpfixd.x double procedure fp_fixd (x) +fp_fixr 18 ./gio/fpfixr.x real procedure fp_fixr (x) +fp_nondegenr 8 ./gio/fpndgr.x bool procedure fp_nondegenr (x1, x2) +fp_normd 8 ./gio/fpnormd.x procedure fp_normd (x, normx, expon) +fp_normr 8 ./gio/fpnormr.x procedure fp_normr (x, normx, expon) +fpathname 13 ./fio/fpathname.x procedure fpathname (vfn, output_pathname, maxchars) +fpradv 13 ./fmtio/fpradv.x procedure fpradv() +fprfmt 44 ./fmtio/fprfmt.x int procedure fprfmt (ival) +fprintf 1 ./libc/printf.c fprintf (va_alist) +fprintf 7 ./fmtio/fprintf.x procedure fprintf (fd, format_string) +fprntf 9 ./fmtio/fprntf.x procedure fprntf (new_fd, format_string, file_type) +fptdir 211 ./fio/diropen.x procedure fptdir (chan, line, nchars, status) +fputc 1 ./libc/fputc.c fputc (ch, fp) +fputs 1 ./libc/fputs.c fputs (str, fp) +fputtx 9 ./fio/fputtx.x procedure fputtx (fd, buf, nchars, status) +fread 1 ./libc/fread.c fread (bp, szelem, nelem, fp) +freadp 16 ./fio/freadp.x pointer procedure freadp (fd, offset, nchars) +fredir 18 ./fio/fredir.x procedure fredir (fd, fname, mode, type) +frediro 53 ./fio/fredir.x procedure frediro (fd, newfd) +free 1 ./libc/free.c free (buf) +frename 17 ./fio/frename.x procedure frename (oldfname, newfname) +freopen 1 ./libc/freopen.c freopen (fname, modestr, fp) +frmbfs 9 ./fio/frmbfs.x procedure frmbfs (fd) +frmtmp 63 ./fio/fsvtfn.x procedure frmtmp() +frtnfd 8 ./fio/frtnfd.x procedure frtnfd (fd) +fscan 5 ./fmtio/fscan.x int procedure fscan (fd) +fscanf 2 ./libc/scanf.c fscanf (va_alist) +fseek 1 ./libc/fseek.c fseek (fp, offset, mode) +fset_env 389 ./fio/fseti.x procedure fset_env (envvar, value) +fsetfd 33 ./fio/fgetfd.x int procedure fsetfd (fd, filename, mode, type) +fseti 20 ./fio/fseti.x procedure fseti (fd, param, value) +fsf_getfname 73 ./fio/fsfopen.x procedure fsf_getfname (fname, fsf_file, maxch) +fsfdelete 36 ./fio/fsfopen.x procedure fsfdelete (fname) +fsfopen 11 ./fio/fsfopen.x int procedure fsfopen (fname, mode) +fskdir 262 ./fio/diropen.x procedure fskdir (chan, offset, status) +fstati 12 ./fio/fstati.x int procedure fstati (fd, what) +fstatl 11 ./fio/fstatl.x long procedure fstatl (fd, what) +fstats 10 ./fio/fstats.x procedure fstats (fd, what, outstr, maxch) +fstdfile 6 ./fio/fstdfile.x int procedure fstdfile (fname, ofd) +fstdir 236 ./fio/diropen.x procedure fstdir (chan, param, lvalue) +fstrfp 11 ./fio/fstrfp.x procedure fstrfp (newfp) +fsvtfn 12 ./fio/fsvtfn.x procedure fsvtfn (fname) +fswapfd 20 ./fio/fswapfd.x procedure fswapfd (fd1, fd2) +ftell 1 ./libc/ftell.c ftell (fp) +fulib 7 ./gio/ncarutil/sysint/fulib.x procedure fulib (errcode, upkmsg, msglen) +fulib 7 ./gio/nspp/sysint/fulib.x procedure fulib (errcode, upkmsg, msglen) +fwatio 10 ./fio/fwatio.x procedure fwatio (fd) +fwrite 1 ./libc/fwrite.c fwrite (bp, szelem, nelem, fp) +fwritep 23 ./fio/fwritep.x pointer procedure fwritep (fd, offset, nchars) +fwtacc 19 ./fio/fwtacc.x procedure fwtacc (fd, fname) +fxf_access 9 ./imio/iki/fxf/fxfaccess.x procedure fxf_access (kernel, root, extn, acmode, status) +fxf_accum_bufp 1062 ./imio/iki/fxf/fxfrfits.x procedure fxf_accum_bufp (line, tpt, nbkw, nbl) +fxf_accum_buft 1101 ./imio/iki/fxf/fxfrfits.x procedure fxf_accum_buft (line, tst, nsb) +fxf_addpar 11 ./imio/iki/fxf/fxfaddpar.x procedure fxf_addpar (im, pname, dtype, pval) +fxf_akwb 219 ./imio/iki/fxf/fxfencode.x procedure fxf_akwb (keyword, value, comment, pn) +fxf_akwc 200 ./imio/iki/fxf/fxfencode.x procedure fxf_akwc (keyword, value, len, comment, pn) +fxf_akwd 292 ./imio/iki/fxf/fxfencode.x procedure fxf_akwd (keyword, value, comment, precision, pn) +fxf_akwi 243 ./imio/iki/fxf/fxfencode.x procedure fxf_akwi (keyword, value, comment, pn) +fxf_akwr 267 ./imio/iki/fxf/fxfencode.x procedure fxf_akwr (keyword, value, comment, precision, pn) +fxf_alloc 322 ./imio/iki/fxf/fxfopen.x procedure fxf_alloc (fit) +fxf_altmd 95 ./imio/iki/fxf/fxfupk.x procedure fxf_altmd (a, b, npix, bscale, bzero) +fxf_altmr 78 ./imio/iki/fxf/fxfupk.x procedure fxf_altmr (a, b, npix, bscale, bzero) +fxf_altmu 116 ./imio/iki/fxf/fxfupk.x procedure fxf_altmu (a, b, npix) +fxf_blank_lines 1129 ./imio/iki/fxf/fxfrfits.x procedure fxf_blank_lines (nbl, po) +fxf_byte_short 281 ./imio/iki/fxf/fxfopix.x procedure fxf_byte_short (im, fname) +fxf_check_dup_extnv507 ./imio/iki/fxf/fxfopen.x int procedure fxf_check_dup_extnv (im, group) +fxf_check_group 759 ./imio/iki/fxf/fxfopen.x procedure fxf_check_group (im, ksection, acmode, group, ksinh) +fxf_check_old_name561 ./imio/iki/fxf/fxfopen.x procedure fxf_check_old_name (im) +fxf_chk_ndim 784 ./imio/iki/fxf/fxfopix.x procedure fxf_chk_ndim(im) +fxf_close 12 ./imio/iki/fxf/fxfclose.x procedure fxf_close (im, status) +fxf_copy 8 ./imio/iki/fxf/fxfcopy.x procedure fxf_copy (kernel, oroot, oextn, nroot, nextn, status) +fxf_ctype 9 ./imio/iki/fxf/fxfctype.x int procedure fxf_ctype (card, index) +fxf_date2limtime 877 ./imio/iki/fxf/fxfrfits.x procedure fxf_date2limtime (str, limtime) +fxf_delete 11 ./imio/iki/fxf/fxfdelete.x procedure fxf_delete (kernel, root, extn, status) +fxf_discard_keyw 698 ./imio/iki/fxf/fxfopix.x procedure fxf_discard_keyw (im) +fxf_dummy_header 446 ./imio/iki/fxf/fxfopen.x procedure fxf_dummy_header (im, status) +fxf_encode_axis 127 ./imio/iki/fxf/fxfencode.x procedure fxf_encode_axis (root, keyword, axisno) +fxf_encode_date 177 ./imio/iki/fxf/fxfencode.x procedure fxf_encode_date (datestr, szdate) +fxf_encodeb 31 ./imio/iki/fxf/fxfencode.x procedure fxf_encodeb (keyword, param, card, comment) +fxf_encodec 143 ./imio/iki/fxf/fxfencode.x procedure fxf_encodec (keyword, param, maxch, card, comment) +fxf_encoded 108 ./imio/iki/fxf/fxfencode.x procedure fxf_encoded (keyword, param, card, comment, precision) +fxf_encodei 55 ./imio/iki/fxf/fxfencode.x procedure fxf_encodei (keyword, param, card, comment) +fxf_encodel 72 ./imio/iki/fxf/fxfencode.x procedure fxf_encodel (keyword, param, card, comment) +fxf_encoder 89 ./imio/iki/fxf/fxfencode.x procedure fxf_encoder (keyword, param, card, comment, precision) +fxf_extnv_error 455 ./imio/iki/fxf/fxfrfits.x int procedure fxf_extnv_error (fit, ig, extn, extv) +fxf_falloc 754 ./imio/iki/fxf/fxfopix.x procedure fxf_falloc (fname, size) +fxf_fclobber 659 ./imio/iki/fxf/fxfopen.x procedure fxf_fclobber (file) +fxf_filter_keyw 729 ./imio/iki/fxf/fxfopix.x procedure fxf_filter_keyw (im, key) +fxf_form_messg 1168 ./imio/iki/fxf/fxfrfits.x procedure fxf_form_messg (fit, messg) +fxf_fpl_equald 156 ./imio/iki/fxf/fxfrdhdr.x bool procedure fxf_fpl_equald (x, y, it) +fxf_gaccess 694 ./imio/iki/fxf/fxfopen.x procedure fxf_gaccess (im, fsec) +fxf_getb 73 ./imio/iki/fxf/fxfget.x procedure fxf_getb (card, bval) +fxf_getcmt 116 ./imio/iki/fxf/fxfget.x procedure fxf_getcmt (card, comment, maxch) +fxf_getd 55 ./imio/iki/fxf/fxfget.x procedure fxf_getd (card, dval) +fxf_gethdrextn 10 ./imio/iki/fxf/fxfhextn.x procedure fxf_gethdrextn (im, o_im, acmode, outstr, maxch) +fxf_geti 19 ./imio/iki/fxf/fxfget.x procedure fxf_geti (card, ival) +fxf_getr 37 ./imio/iki/fxf/fxfget.x procedure fxf_getr (card, rval) +fxf_gltm 150 ./imio/iki/fxf/fxfget.x procedure fxf_gltm (time, date, limtime) +fxf_gstr 92 ./imio/iki/fxf/fxfget.x procedure fxf_gstr (card, outstr, maxch) +fxf_hdr_offset 255 ./imio/iki/fxf/fxfupdhdr.x int procedure fxf_hdr_offset (group, fit, pfd, acmode) +fxf_header_diff 288 ./imio/iki/fxf/fxfupdhdr.x procedure fxf_header_diff (im, group, acmode, hdr_off, diff, ualen) +fxf_header_size 200 ./imio/iki/fxf/fxfopix.x int procedure fxf_header_size (im) +fxf_init 344 ./imio/iki/fxf/fxfopen.x procedure fxf_init() +fxf_is_blank 1150 ./imio/iki/fxf/fxfrfits.x bool procedure fxf_is_blank (line) +fxf_ks_errors 410 ./imio/iki/fxf/fxfksection.x procedure fxf_ks_errors (fit, acmode) +fxf_ks_gvalue 197 ./imio/iki/fxf/fxfksection.x procedure fxf_ks_gvalue (param, ksection, ip, fit) +fxf_ks_lex 130 ./imio/iki/fxf/fxfksection.x int procedure fxf_ks_lex (outstr) +fxf_ks_pm 375 ./imio/iki/fxf/fxfksection.x procedure fxf_ks_pm (pm, param, fit) +fxf_ks_val 259 ./imio/iki/fxf/fxfksection.x procedure fxf_ks_val (outstr, param, fit) +fxf_ksection 42 ./imio/iki/fxf/fxfksection.x procedure fxf_ksection (ksection, fit, group) +fxf_ksinit 448 ./imio/iki/fxf/fxfksection.x procedure fxf_ksinit (fit) +fxf_load_header 598 ./imio/iki/fxf/fxfrfits.x procedure fxf_load_header (in, fit, spool, nrec1440, datalen) +fxf_make_adj_copy 793 ./imio/iki/fxf/fxfupdhdr.x procedure fxf_make_adj_copy (in_fd, out_fd, hdr_off, pixoff, chars_ua) +fxf_make_card 6 ./imio/iki/fxf/fxfmkcard.x procedure fxf_make_card (instr, ip, card, col_out, maxcols, delim) +fxf_mandatory_cards461 ./imio/iki/fxf/fxfopix.x procedure fxf_mandatory_cards (im, nheader_cards) +fxf_match_str 916 ./imio/iki/fxf/fxfrfits.x procedure fxf_match_str (pat, plines, str, slines, merge, po) +fxf_merge_w_ua 754 ./imio/iki/fxf/fxfrfits.x procedure fxf_merge_w_ua (im, userh, fitslen) +fxf_null 8 ./imio/iki/fxf/fxfnull.x procedure fxf_null() +fxf_open 14 ./imio/iki/fxf/fxfopen.x procedure fxf_open (kernel, im, o_im, root, extn, ksection, group, gc_arg, +fxf_opix 16 ./imio/iki/fxf/fxfopix.x procedure fxf_opix (im, status) +fxf_over_delete 913 ./imio/iki/fxf/fxfupdhdr.x procedure fxf_over_delete (im) +fxf_overwrite_unit549 ./imio/iki/fxf/fxfopix.x procedure fxf_overwrite_unit (fit, im) +fxf_pak_data 12 ./imio/iki/fxf/fxfpak.x procedure fxf_pak_data (ibuf, obuf, npix, pixtype) +fxf_prhdr 370 ./imio/iki/fxf/fxfopen.x procedure fxf_prhdr (im, group) +fxf_read_card 8 ./imio/iki/fxf/fxfrcard.x int procedure fxf_read_card (fd, ibuf, obuf, ncards) +fxf_read_xtn 280 ./imio/iki/fxf/fxfrfits.x procedure fxf_read_xtn (im, cfit, igroup, hoff, poff, extn, extv) +fxf_reblock 597 ./imio/iki/fxf/fxfopen.x procedure fxf_reblock (im) +fxf_ren_tmp 889 ./imio/iki/fxf/fxfupdhdr.x procedure fxf_ren_tmp (in, out) +fxf_rename 10 ./imio/iki/fxf/fxfrename.x procedure fxf_rename (kernel, oroot, oextn, nroot, nextn, status) +fxf_rfitshdr 25 ./imio/iki/fxf/fxfrfits.x procedure fxf_rfitshdr (im, group, poff) +fxf_rheader 13 ./imio/iki/fxf/fxfrdhdr.x procedure fxf_rheader (im, group, acmode) +fxf_set_cache_time844 ./imio/iki/fxf/fxfupdhdr.x procedure fxf_set_cache_time (im) +fxf_setbitpix 763 ./imio/iki/fxf/fxfupdhdr.x procedure fxf_setbitpix (im, fit) +fxf_skip_xtn 506 ./imio/iki/fxf/fxfrfits.x procedure fxf_skip_xtn (im, group, cfit, hoff, poff, extn, extv, spool) +fxf_strcmp_lwr 849 ./imio/iki/fxf/fxfrfits.x int procedure fxf_strcmp_lwr (s1, s2) +fxf_totpix 678 ./imio/iki/fxf/fxfopix.x int procedure fxf_totpix (im) +fxf_ua_card 716 ./imio/iki/fxf/fxfupdhdr.x int procedure fxf_ua_card (fit, im, up, card) +fxf_unpack_data 20 ./imio/iki/fxf/fxfupk.x procedure fxf_unpack_data (cbuf, npix, pixtype, bscale, bzero) +fxf_update_extend 951 ./imio/iki/fxf/fxfupdhdr.x procedure fxf_update_extend (im) +fxf_updhdr 27 ./imio/iki/fxf/fxfupdhdr.x procedure fxf_updhdr (im, status) +fxf_write_blanks 421 ./imio/iki/fxf/fxfopix.x procedure fxf_write_blanks (fd, size) +fxf_write_header 482 ./imio/iki/fxf/fxfupdhdr.x procedure fxf_write_header (im, fit, hdr_fd, diff) +fxfzcl 62 ./imio/iki/fxf/zfiofxf.x procedure fxfzcl (chan, status) +fxfzop 19 ./imio/iki/fxf/zfiofxf.x procedure fxfzop (pkfn, mode, status) +fxfzrd 82 ./imio/iki/fxf/zfiofxf.x procedure fxfzrd (chan, obuf, nbytes, boffset) +fxfzst 279 ./imio/iki/fxf/zfiofxf.x procedure fxfzst (chan, param, value) +fxfzwr 168 ./imio/iki/fxf/zfiofxf.x procedure fxfzwr (chan, ibuf, nbytes, boffset) +fxfzwt 264 ./imio/iki/fxf/zfiofxf.x procedure fxfzwt (chan, status) +g_ttyload 159 ./tty/ttygdes.x int procedure g_ttyload (fname, device, outstr, maxch) +gactivate 12 ./gio/gactivate.x procedure gactivate (gp, flags) +gacwk 7 ./gio/gks/gacwk.x procedure gacwk (wkid) +gadraw 20 ./gio/gadraw.x procedure gadraw (gp, wx, wy) +gamove 9 ./gio/gamove.x procedure gamove (gp, x, y) +gargb 8 ./fmtio/gargb.x procedure gargb (bval) +gargc 5 ./fmtio/gargc.x procedure gargc (cval) +gargd 6 ./fmtio/gargd.x procedure gargd (dval) +gargi 7 ./fmtio/gargi.x procedure gargi (ival) +gargl 7 ./fmtio/gargl.x procedure gargl (lval) +gargr 6 ./fmtio/gargr.x procedure gargr (rval) +gargrad 6 ./fmtio/gargrad.x procedure gargrad (lval, radix) +gargs 7 ./fmtio/gargs.x procedure gargs (sval) +gargstr 5 ./fmtio/gargstr.x procedure gargstr (outstr, maxch) +gargtok 5 ./fmtio/gargtok.x procedure gargtok (token, outstr, maxch) +gargwrd 6 ./fmtio/gargwrd.x procedure gargwrd (outstr, maxch) +gargx 5 ./fmtio/gargx.x procedure gargx (xval) +gascale 11 ./gio/gascale.x procedure gascale (gp, v, npts, axis) +gax_draw 292 ./gio/cursor/grcaxes.x procedure gax_draw (wx, wy) +gax_findticks 181 ./gio/cursor/grcaxes.x procedure gax_findticks (w, wx1,wx2,wy1,wy2, x1,dx,xt, y1,dy,yt) +gax_flush 353 ./gio/cursor/grcaxes.x procedure gax_flush (stream) +gax_ndc 249 ./gio/cursor/grcaxes.x procedure gax_ndc (wx, wy, sx, sy) +gax_start 338 ./gio/cursor/grcaxes.x procedure gax_start (wx, wy) +gax_text 368 ./gio/cursor/grcaxes.x procedure gax_text (stream, sx, sy, text, hjustify, vjustify) +gax_tick 312 ./gio/cursor/grcaxes.x procedure gax_tick (dx, dy) +gbytes 15 ./gio/ncarutil/sysint/gbytes.x procedure gbytes (bufin, bufout, index, size, skip, count) +gca 9 ./gio/gks/gca.x procedure gca (px, py, qx, qy, dimx, dimy, ncs, nrs, dx, dy, colia) +gcancel 21 ./gio/gcancel.x procedure gcancel (gp) +gcas 9 ./gio/gks/gcas.x procedure gcas (px, py, qx, qy, dimx, dimy, ncs, nrs, dx, dy, colia) +gclear 11 ./gio/gclear.x procedure gclear (gp) +gclks 5 ./gio/gks/gclks.x procedure gclks () +gclose 10 ./gio/gclose.x procedure gclose (gp) +gclrwk 7 ./gio/gks/gclrwk.x procedure gclrwk (wkid, cofl) +gclwk 7 ./gio/gks/gclwk.x procedure gclwk (wkid) +gctod 16 ./fmtio/gctod.x int procedure gctod (str, ip, odval) +gctol 22 ./fmtio/gctol.x int procedure gctol (str, ip, lval, radix) +gctox 16 ./fmtio/gctox.x int procedure gctox (str, ip, oxval) +gctran 14 ./gio/gctran.x procedure gctran (gp, x1,y1, x2,y2, wcs_a, wcs_b) +gcurpos 10 ./gio/gcurpos.x procedure gcurpos (gp, x, y) +gdawk 7 ./gio/gks/gdawk.x procedure gdawk (wkid) +gdeactivate 12 ./gio/gdeact.x procedure gdeactivate (gp, flags) +gdrwch 235 ./gio/nsppkern/zzdebug.x procedure gdrwch (gp, x, y, ch, xsize, ysize) +gescape 9 ./gio/gescape.x procedure gescape (gp, fn, instruction, nwords) +get_processtable 1 ../unix/os/getproc.c get_processtable (kmem, o_nproc) +get_timezone 1 ../unix/os/gmttolst.c get_timezone() +getc 8 ./fio/getc.x char procedure getc (fd, ch) +getchar 5 ./fio/getchar.x char procedure getchar (ch) +getci 8 ./fio/getci.x int procedure getci (fd, ch) +gethost 5 ./etc/gethost.x procedure gethost (outstr, maxch) +getline 15 ./fio/getline.x int procedure getline (fd, linebuf) +getlline 9 ./fio/getlline.x int procedure getlline (fd, obuf, maxch) +getlongline 10 ./fio/glongline.x int procedure getlongline (fd, obuf, maxch, linenum) +getpid 5 ./etc/getpid.x int procedure getpid() +gets 1 ./libc/gets.c gets (buf) +getstr 11 ../unix/os/zfiond.c getstr (ipp, obuf, maxch) +gettok 6 ../unix/os/tape.c gettok() +getuid 7 ./etc/getuid.x procedure getuid (user_name, maxch) +getw 1 ./libc/getw.c getw (fp) +gexfls 10 ./clio/gexfls.x procedure gexfls() +gexfls_clear 48 ./clio/gexfls.x procedure gexfls_clear (stream) +gexfls_set 28 ./clio/gexfls.x procedure gexfls_set (stream, gp_value, epa_gflush) +gfa 9 ./gio/gks/gfa.x procedure gfa (n, px, py) +gfill 8 ./gio/gfill.x procedure gfill (gp, x, y, npts, style) +gflush 11 ./gio/gflush.x procedure gflush (gp) +gframe 9 ./gio/gframe.x procedure gframe (gp) +gfrinit 9 ./gio/gfrinit.x procedure gfrinit (gp) +ggcell 13 ./gio/ggcell.x procedure ggcell (gp, m, nx, ny, x1, y1, x2, y2) +ggcur 14 ./gio/ggcur.x int procedure ggcur (gp, cn, key, sx, sy, raster, rx, ry) +ggetb 10 ./gio/ggetb.x bool procedure ggetb (gp, cap) +ggeti 9 ./gio/ggeti.x int procedure ggeti (gp, cap) +ggetr 9 ./gio/ggetr.x real procedure ggetr (gp, cap) +ggets 12 ./gio/ggets.x int procedure ggets (gp, cap, outstr, maxch) +ggscale 10 ./gio/ggscale.x procedure ggscale (gp, x, y, dx, dy) +ggview 7 ./gio/ggview.x procedure ggview (gp, x1, x2, y1, y2) +ggwind 7 ./gio/ggwind.x procedure ggwind (gp, x1, x2, y1, y2) +gim_copyraster 10 ./gio/gim/gimcpras.x procedure gim_copyraster (gp, rop, src,st,sx,sy,sw,sh, dst,dt,dx,dy,dw,dh) +gim_createraster 7 ./gio/gim/gimcrras.x procedure gim_createraster (gp, raster, type, width, height, depth) +gim_destroyraster 7 ./gio/gim/gimderas.x procedure gim_destroyraster (gp, raster) +gim_disablemapping 9 ./gio/gim/gimdsmap.x procedure gim_disablemapping (gp, mapping, erase) +gim_enablemapping 9 ./gio/gim/gimenmap.x procedure gim_enablemapping (gp, mapping, refresh) +gim_freecolormap 7 ./gio/gim/gimfcmap.x procedure gim_freecolormap (gp, colormap) +gim_freemapping 7 ./gio/gim/gimfmap.x procedure gim_freemapping (gp, mapping) +gim_getmapping 14 ./gio/gim/gimgetmap.x int procedure gim_getmapping (gp, mapping, rop, +gim_initmappings 7 ./gio/gim/gimimap.x procedure gim_initmappings (gp) +gim_iomapread 10 ./gio/gim/gimriomap.x procedure gim_iomapread (gp, iomap, first, nelem) +gim_iomapwrite 12 ./gio/gim/gimwiomap.x procedure gim_iomapwrite (gp, iomap, first, nelem) +gim_loadcolormap 26 ./gio/gim/gimlcmap.x procedure gim_loadcolormap (gp, colormap, offset, slope) +gim_queryraster 12 ./gio/gim/gimqras.x int procedure gim_queryraster (gp, raster, type, width, height, depth) +gim_rasterinit 8 ./gio/gim/gimrasini.x procedure gim_rasterinit (gp) +gim_readcolormap 12 ./gio/gim/gimrcmap.x int procedure gim_readcolormap (gp, colormap, first, maxelem, r, g, b) +gim_readpixels 11 ./gio/gim/gimrpix.x procedure gim_readpixels (gp, raster, data, nbits, x1, y1, nx, ny) +gim_refreshmapping 8 ./gio/gim/gimref.x procedure gim_refreshmapping (gp, mapping) +gim_refreshpix 11 ./gio/gim/gimrefpix.x procedure gim_refreshpix (gp, raster, ct, x1, y1, width, height) +gim_setmapping 20 ./gio/gim/gimsetmap.x procedure gim_setmapping (gp, mapping, rop, +gim_setpix 10 ./gio/gim/gimsetpix.x procedure gim_setpix (gp, raster, ct, x1, y1, width, height, color, rop) +gim_setraster 18 ./gio/gim/gimsetras.x procedure gim_setraster (gp, raster) +gim_writecolormap 8 ./gio/gim/gimwcmap.x procedure gim_writecolormap (gp, colormap, first, nelem, r, g, b) +gim_writepixels 9 ./gio/gim/gimwpix.x procedure gim_writepixels (gp, raster, data, nbits, x1, y1, nx, ny) +giotr 23 ./gio/cursor/giotr.x procedure giotr (stream) +giotr_onint 173 ./gio/cursor/giotr.x procedure giotr_onint (vex, next_handler) +gki_cancel 12 ./gio/gki/gkicancel.x procedure gki_cancel (fd) +gki_clear 12 ./gio/gki/gkiclear.x procedure gki_clear (fd) +gki_closews 14 ./gio/gki/gkiclose.x procedure gki_closews (fd, device) +gki_deactivatews 13 ./gio/gki/gkideact.x procedure gki_deactivatews (fd, flags) +gki_eof 12 ./gio/gki/gkieof.x procedure gki_eof (fd) +gki_escape 15 ./gio/gki/gkiesc.x procedure gki_escape (fd, fn, instruction, nwords) +gki_execute 14 ./gio/gki/gkiexe.x procedure gki_execute (gki, dd) +gki_faset 15 ./gio/gki/gkifaset.x procedure gki_faset (fd, ap) +gki_fetch_next_instruction 22 ./gio/gki/gkifetch.x int procedure gki_fetch_next_instruction (fd, instruction) +gki_fflush 11 ./gio/gki/gkifflush.x procedure gki_fflush (fd) +gki_fillarea 14 ./gio/gki/gkifa.x procedure gki_fillarea (fd, points, npts) +gki_flush 13 ./gio/gki/gkiflush.x procedure gki_flush (fd) +gki_getcellarray 19 ./gio/gki/gkigca.x procedure gki_getcellarray (fd, m, nx, ny, x1,y1, x2,y2) +gki_getcursor 42 ./gio/gki/gkigcur.x procedure gki_getcursor (fd, cursor, cn, key, sx, sy, raster, rx, ry) +gki_getwcs 15 ./gio/gki/gkigetwcs.x procedure gki_getwcs (fd, wcs, len_wcs) +gki_init 12 ./gio/gki/gkiinit.x procedure gki_init (stream) +gki_inline_kernel 14 ./gio/gki/gkiinline.x procedure gki_inline_kernel (stream, dd) +gki_mftitle 14 ./gio/gki/gkititle.x procedure gki_mftitle (fd, title) +gki_openws 15 ./gio/gki/gkiopen.x procedure gki_openws (fd, device, mode) +gki_plset 16 ./gio/gki/gkiplset.x procedure gki_plset (fd, ap) +gki_pmset 16 ./gio/gki/gkipmset.x procedure gki_pmset (fd, ap) +gki_polyline 14 ./gio/gki/gkipl.x procedure gki_polyline (fd, points, npts) +gki_polymarker 14 ./gio/gki/gkipm.x procedure gki_polymarker (fd, points, npts) +gki_putcellarray 17 ./gio/gki/gkipca.x procedure gki_putcellarray (fd, m, nx, ny, x1,y1, x2,y2) +gki_reactivatews 13 ./gio/gki/gkireact.x procedure gki_reactivatews (fd, flags) +gki_redir 14 ./gio/gki/gkiredir.x procedure gki_redir (stream, fd, old_fd, old_type) +gki_retcellarray 15 ./gio/gki/gkirca.x procedure gki_retcellarray (fd, m, np) +gki_retcursorvalue 29 ./gio/gki/gkircval.x procedure gki_retcursorvalue (fd, cn, key, sx, sy, raster, rx, ry) +gki_setcursor 14 ./gio/gki/gkiscur.x procedure gki_setcursor (fd, x, y, cursor) +gki_setwcs 16 ./gio/gki/gkisetwcs.x procedure gki_setwcs (fd, wcs, len_wcs) +gki_subkernel 19 ./gio/gki/gkikern.x procedure gki_subkernel (stream, pid, prpsio_epa) +gki_text 15 ./gio/gki/gkitx.x procedure gki_text (fd, x, y, text) +gki_txset 24 ./gio/gki/gkitxset.x procedure gki_txset (fd, ap) +gki_wescape 19 ./gio/gki/gkiwesc.x procedure gki_wescape (fd, fn, hdr, hdrlen, data, datalen) +gki_write 12 ./gio/gki/gkiwrite.x procedure gki_write (fd, gki) +gkp_cancel 283 ./gio/gki/gkiprint.x procedure gkp_cancel (dummy) +gkp_clear 270 ./gio/gki/gkiprint.x procedure gkp_clear (dummy) +gkp_close 133 ./gio/gki/gkiprint.x procedure gkp_close() +gkp_closews 191 ./gio/gki/gkiprint.x procedure gkp_closews (devname, n) +gkp_deactivatews 230 ./gio/gki/gkiprint.x procedure gkp_deactivatews (flags) +gkp_dump 799 ./gio/gki/gkiprint.x procedure gkp_dump (fd, data, nwords) +gkp_escape 597 ./gio/gki/gkiprint.x procedure gkp_escape (fn, instruction, nwords) +gkp_faset 557 ./gio/gki/gkiprint.x procedure gkp_faset (gki) +gkp_fillarea 341 ./gio/gki/gkiprint.x procedure gkp_fillarea (p, npts) +gkp_flush 297 ./gio/gki/gkiprint.x procedure gkp_flush (dummy) +gkp_getcellarray 429 ./gio/gki/gkiprint.x procedure gkp_getcellarray (nx, ny, x1,y1, x2,y2) +gkp_getcursor 502 ./gio/gki/gkiprint.x procedure gkp_getcursor (cursor) +gkp_getwcs 673 ./gio/gki/gkiprint.x procedure gkp_getwcs (wcs, nwords) +gkp_grstream 142 ./gio/gki/gkiprint.x procedure gkp_grstream (graphics_stream) +gkp_install 79 ./gio/gki/gkiprint.x procedure gkp_install (dd, out_fd, verbose_output, use_gkiunits) +gkp_mftitle 246 ./gio/gki/gkiprint.x procedure gkp_mftitle (title, n) +gkp_openws 155 ./gio/gki/gkiprint.x procedure gkp_openws (devname, n, mode) +gkp_plset 525 ./gio/gki/gkiprint.x procedure gkp_plset (gki) +gkp_pmset 541 ./gio/gki/gkiprint.x procedure gkp_pmset (gki) +gkp_polyline 311 ./gio/gki/gkiprint.x procedure gkp_polyline (p, npts) +gkp_polymarker 326 ./gio/gki/gkiprint.x procedure gkp_polymarker (p, npts) +gkp_pstat 704 ./gio/gki/gkiprint.x procedure gkp_pstat (fd, p, npts, label, verbose, gkiunits) +gkp_putcellarray 392 ./gio/gki/gkiprint.x procedure gkp_putcellarray (m, nx, ny, x1,y1, x2,y2) +gkp_reactivatews 216 ./gio/gki/gkiprint.x procedure gkp_reactivatews (flags) +gkp_setcursor 478 ./gio/gki/gkiprint.x procedure gkp_setcursor (x, y, cursor) +gkp_setwcs 618 ./gio/gki/gkiprint.x procedure gkp_setwcs (wcs, nwords) +gkp_text 356 ./gio/gki/gkiprint.x procedure gkp_text (x, y, text, n) +gkp_txparg 8 ./gio/gki/gkptxparg.x procedure gkp_txparg (code) +gkp_txset 572 ./gio/gki/gkiprint.x procedure gkp_txset (gki) +gkp_unknown 689 ./gio/gki/gkiprint.x procedure gkp_unknown (gki) +gkt_cancel 8 ./gio/nsppkern/gktcancel.x procedure gkt_cancel (dummy) +gkt_clear 10 ./gio/nsppkern/gktclear.x procedure gkt_clear (dummy) +gkt_close 8 ./gio/nsppkern/gktclose.x procedure gkt_close() +gkt_closews 9 ./gio/nsppkern/gktclws.x procedure gkt_closews (devname, n) +gkt_color 15 ./gio/nsppkern/gktcolor.x procedure gkt_color(index) +gkt_drawchar 15 ./gio/nsppkern/gktdrawch.x procedure gkt_drawchar (ch, x, y, xsize, ysize, orien, font) +gkt_escape 6 ./gio/nsppkern/gktescape.x procedure gkt_escape (fn, instruction, nwords) +gkt_faset 8 ./gio/nsppkern/gktfaset.x procedure gkt_faset (gki) +gkt_fillarea 7 ./gio/nsppkern/gktfa.x procedure gkt_fillarea (p, npts) +gkt_flush 7 ./gio/nsppkern/gktflush.x procedure gkt_flush (dummy) +gkt_font 13 ./gio/nsppkern/gktfont.x procedure gkt_font (font) +gkt_getcellarray 6 ./gio/nsppkern/gktgcell.x procedure gkt_getcellarray (nx, ny, x1,y1, x2,y2) +gkt_gstring 151 ./gio/nsppkern/gktinit.x pointer procedure gkt_gstring (cap) +gkt_init 13 ./gio/nsppkern/gktinit.x procedure gkt_init (tty, devname) +gkt_linetype 8 ./gio/nsppkern/gktline.x procedure gkt_linetype (index) +gkt_mfopen 16 ./gio/nsppkern/gktmfopen.x int procedure gkt_mfopen (tty, mode) +gkt_open 12 ./gio/nsppkern/gktopen.x procedure gkt_open (devname, dd) +gkt_openws 13 ./gio/nsppkern/gktopenws.x procedure gkt_openws (devname, n, mode) +gkt_plset 9 ./gio/nsppkern/gktplset.x procedure gkt_plset (gki) +gkt_pmset 8 ./gio/nsppkern/gktpmset.x procedure gkt_pmset (gki) +gkt_polyline 11 ./gio/nsppkern/gktpl.x procedure gkt_polyline (p, npts) +gkt_polymarker 13 ./gio/nsppkern/gktpm.x procedure gkt_polymarker (p, npts) +gkt_putcellarray 14 ./gio/nsppkern/gktpcell.x procedure gkt_putcellarray (m, nc, nr, ax1,ay1, ax2,ay2) +gkt_reset 12 ./gio/nsppkern/gktreset.x procedure gkt_reset() +gkt_text 20 ./gio/nsppkern/gkttx.x procedure gkt_text (xc, yc, text, n) +gkt_txset 9 ./gio/nsppkern/gkttxset.x procedure gkt_txset (gki) +glabax 14 ./gio/glabax/glabax.x procedure glabax (gp, title, xlabel, ylabel) +glb_drawgrid 11 ./gio/glabax/glbgrid.x procedure glb_drawgrid (gp, ax1, ax2) +glb_encode 14 ./gio/glabax/glbencode.x procedure glb_encode (x, out, maxch, format, step) +glb_eq 245 ./gio/glabax/glbgtick.x bool procedure glb_eq (a, b) +glb_find_ticks 19 ./gio/glabax/glbfind.x procedure glb_find_ticks (gp, ap, ax1, ax2, angle) +glb_gettick 50 ./gio/glabax/glbgtick.x int procedure glb_gettick (gp, ax, x, y, major_tick) +glb_label_axis 15 ./gio/glabax/glblabel.x procedure glb_label_axis (gp, ax, xlabel, ylabel) +glb_loglab 16 ./gio/glabax/glbloglab.x procedure glb_loglab (gp, sx, sy, val, fmt, scaling) +glb_minorstep 307 ./gio/glabax/glbfind.x real procedure glb_minorstep (x1, x2, nminor) +glb_plot_title 13 ./gio/glabax/glbtitle.x procedure glb_plot_title (gp, title, ntitlelines) +glb_set_axes 10 ./gio/glabax/glbsetax.x procedure glb_set_axes (gp, ap, ax1, ax2, angle) +glb_set_viewport 13 ./gio/glabax/glbsview.x procedure glb_set_viewport (gp, ntitlelines, xlabel, ylabel) +glb_setup 10 ./gio/glabax/glbsetup.x procedure glb_setup (gp, axes, ntitlelines, xlabel, ylabel) +glb_ticklen 16 ./gio/glabax/glbticlen.x real procedure glb_ticklen (gp, ax, ndc_length) +glb_verify_log_scaling 13 ./gio/glabax/glbverify.x procedure glb_verify_log_scaling (gp) +gline 5 ./gio/gline.x procedure gline (gp, x1, y1, x2, y2) +gltoc 14 ./fmtio/gltoc.x int procedure gltoc (lval, outstr, maxch, base) +gmark 16 ./gio/gmark.x procedure gmark (gp, x, y, marktype, xsize, ysize) +gmftitle 9 ./gio/gmftitle.x procedure gmftitle (gp, mftitle) +gmprintf 8 ./gio/gmprintf.x procedure gmprintf (gp, object, format) +gmsg 33 ./gio/gmsg.x procedure gmsg (gp, object, message) +gmsgb 73 ./gio/gmsg.x procedure gmsgb (gp, object, value) +gmsgc 89 ./gio/gmsg.x procedure gmsgc (gp, object, value) +gmsgd 196 ./gio/gmsg.x procedure gmsgd (gp, object, value) +gmsgi 129 ./gio/gmsg.x procedure gmsgi (gp, object, value) +gmsgl 152 ./gio/gmsg.x procedure gmsgl (gp, object, value) +gmsgr 173 ./gio/gmsg.x procedure gmsgr (gp, object, value) +gmsgs 106 ./gio/gmsg.x procedure gmsgs (gp, object, value) +gmsgx 217 ./gio/gmsg.x procedure gmsgx (gp, object, value) +gmt_to_lst 1 ../unix/os/gmttolst.c gmt_to_lst (gmt) +gopen 177 ./gio/gopen.x pointer procedure gopen (device, mode, fd) +gopenui 19 ./gio/gopen.x pointer procedure gopenui (device, mode, uifname, fd) +gopks 9 ./gio/gks/gopks.x procedure gopks (errfil) +gopwk 7 ./gio/gks/gopwk.x procedure gopwk (wkid, conid, wtype) +gpagefile 11 ./gio/gpagefile.x procedure gpagefile (gp, fname, prompt) +gpatmake 313 ./fmtio/patmatch.x int procedure gpatmake (patstr, from, delim, patbuf, sz_pat) +gpatmatch 64 ./fmtio/patmatch.x int procedure gpatmatch (str, pat, first_char, last_char) +gpcell 35 ./gio/gpcell.x procedure gpcell (gp, m, nx, ny, x1, y1, x2, y2) +gpl 7 ./gio/gks/gpl.x procedure gpl (n, px, py) +gpl_cache 11 ./gio/gplcache.x procedure gpl_cache (gp) +gpl_cancel 7 ./gio/gplcancel.x procedure gpl_cancel() +gpl_clipb 224 ./gio/gadraw.x procedure gpl_clipb (pen, mx, my) +gpl_clipl 168 ./gio/gadraw.x procedure gpl_clipl (pen, mx, my) +gpl_clipr 196 ./gio/gadraw.x procedure gpl_clipr (pen, mx, my) +gpl_clipt 256 ./gio/gadraw.x procedure gpl_clipt (pen, mx, my) +gpl_flush 11 ./gio/gplflush.x procedure gpl_flush() +gpl_reset 10 ./gio/gplreset.x procedure gpl_reset() +gpl_settype 8 ./gio/gplstype.x procedure gpl_settype (gp, type) +gpl_wcstogki 13 ./gio/wcstogki.x procedure gpl_wcstogki (gp, wx, wy, mx, my) +gpline 7 ./gio/gpline.x procedure gpline (gp, x, y, npts) +gploto 9 ./gio/gploto.x procedure gploto (gp, v, npts, x1, x2, title) +gplotv 7 ./gio/gplotv.x procedure gplotv (v, npts, x1, x2, title) +gpm 9 ./gio/gks/gpm.x procedure gpm (n, px, py) +gpmark 10 ./gio/gpmark.x procedure gpmark (gp, x, y, npts, marktype, xsize, ysize) +gpt_clipb 380 ./gio/cursor/gtrwstran.x procedure gpt_clipb (pen, mx, my) +gpt_clipl 320 ./gio/cursor/gtrwstran.x procedure gpt_clipl (pen, mx, my) +gpt_clipr 350 ./gio/cursor/gtrwstran.x procedure gpt_clipr (pen, mx, my) +gpt_clipt 414 ./gio/cursor/gtrwstran.x procedure gpt_clipt (pen, mx, my) +gpt_firstpt 266 ./gio/cursor/gtrwstran.x int procedure gpt_firstpt (gki, ip, last_ip) +gpt_flush 451 ./gio/cursor/gtrwstran.x procedure gpt_flush() +gqasf 7 ./gio/gks/gqasf.x procedure gqasf (ierror, lasf) +gqchh 8 ./gio/gks/gqchh.x procedure gqchh (ierror, chh) +gqchup 8 ./gio/gks/gqchup.x procedure gqchup (ierror, chupx, chupy) +gqclip 8 ./gio/gks/gqclip.x procedure gqclip (errind, iclip, iar) +gqcntn 8 ./gio/gks/gqcntn.x procedure gqcntn (errind, cntr) +gqmk 9 ./gio/gks/gqmk.x procedure gqmk (ierr, mtype) +gqnt 10 ./gio/gks/gqnt.x procedure gqnt (ntnr, errind, window, vport) +gqopwk 10 ./gio/gks/gqopwk.x procedure gqopwk (n, errind, ol, wkid) +gqplci 8 ./gio/gks/gqplci.x procedure gqplci (errind, coli) +gqpmci 8 ./gio/gks/gqpmci.x procedure gqpmci (errind, coli) +gqpmi 8 ./gio/gks/gqpmi.x procedure gqpmi (errind, index) +gqsort 22 ./etc/gqsort.x procedure gqsort (x, nelem, compare, arg) +gqtxal 8 ./gio/gks/gqtxal.x procedure gqtxal (ierror, txalh, txalv) +gqtxci 8 ./gio/gks/gqtxci.x procedure gqtxci (ierror, coli) +gqtxp 8 ./gio/gks/gqtxp.x procedure gqtxp (ierror, path) +gqverify 10 ./gio/gqverify.x int procedure gqverify() +gqwks 8 ./gio/gks/gqwks.x procedure gqwks (wkid, errind, state) +grc_axes 20 ./gio/cursor/grcaxes.x procedure grc_axes (stream, sx, sy, raster, rx, ry) +grc_boolval 369 ./gio/cursor/grccmd.x int procedure grc_boolval (opstr, ip) +grc_close 14 ./gio/cursor/grcclose.x procedure grc_close (fd, rc) +grc_command 45 ./gio/cursor/grccmd.x int procedure grc_command (rc, stream, sx, sy, raster, rx, ry, opstr) +grc_cursor 443 ./gio/cursor/rcursor.x int procedure grc_cursor (rc, stream, key, x, y, raster, rx, ry, ppos) +grc_init 9 ./gio/cursor/grcinit.x procedure grc_init (rc, stream) +grc_keys 423 ./gio/cursor/grccmd.x procedure grc_keys (rc, opstr, ip, onoff) +grc_mapkey 571 ./gio/cursor/rcursor.x int procedure grc_mapkey (rc, key, nukey) +grc_message 649 ./gio/cursor/rcursor.x procedure grc_message (stream, message) +grc_ndctoscr 35 ./gio/cursor/grcscr.x procedure grc_ndctoscr (mx, my, sx, sy) +grc_ndctowcs 167 ./gio/cursor/grcwcs.x procedure grc_ndctowcs (ct, mx, my, wx, wy) +grc_open 12 ./gio/cursor/grcopen.x pointer procedure grc_open (device, mode, stream, rc) +grc_pcursor 662 ./gio/cursor/rcursor.x procedure grc_pcursor (stream, sx, sy, raster, rx, ry) +grc_polyline 13 ./gio/cursor/grcpl.x procedure grc_polyline (stream, v, npts) +grc_read 10 ./gio/cursor/grcread.x procedure grc_read (tr, stream, fname) +grc_readtty 614 ./gio/cursor/rcursor.x int procedure grc_readtty (stream, prompt, obuf, maxch) +grc_realval 398 ./gio/cursor/grccmd.x real procedure grc_realval (opstr, ip) +grc_redraw 9 ./gio/cursor/grcredraw.x procedure grc_redraw (rc, stream, sx, sy, raster, rx, ry) +grc_restorecurpos 597 ./gio/cursor/rcursor.x procedure grc_restorecurpos (stream, x, y) +grc_scrtondc 15 ./gio/cursor/grcscr.x procedure grc_scrtondc (sx, sy, mx, my) +grc_scrtowcs 14 ./gio/cursor/grcwcs.x procedure grc_scrtowcs (stream, sx, sy, raster, rx, ry, wx, wy, wcs) +grc_selectwcs 208 ./gio/cursor/grcwcs.x int procedure grc_selectwcs (tr, raster, mx, my) +grc_settran 70 ./gio/cursor/grcwcs.x procedure grc_settran (w, ct) +grc_status 11 ./gio/cursor/grcstatus.x procedure grc_status (fd, rc) +grc_text 12 ./gio/cursor/grctext.x procedure grc_text (stream, x, y, text) +grc_viewport 488 ./gio/cursor/grccmd.x procedure grc_viewport (tr, stream, sx, sy, raster, rx, ry, opstr, ip) +grc_warn 6 ./gio/cursor/grcwarn.x procedure grc_warn (fd) +grc_wcstondc 130 ./gio/cursor/grcwcs.x procedure grc_wcstondc (ct, wx, wy, mx, my) +grc_word 343 ./gio/cursor/grccmd.x procedure grc_word (opstr, ip, outstr, maxch) +grc_write 12 ./gio/cursor/grcwrite.x procedure grc_write (tr, stream, fname, clobber, fullframe) +grdraw 8 ./gio/grdraw.x procedure grdraw (gp, x, y) +grdwcs 51 ./gio/grdwcs.x int procedure grdwcs (devname, wcs, len_wcs) +greactivate 10 ./gio/greact.x procedure greactivate (gp, flags) +greset 10 ./gio/greset.x procedure greset (gp, flags) +grmove 8 ./gio/grmove.x procedure grmove (gp, x, y) +grscale 11 ./gio/grscale.x procedure grscale (gp, v, npts, axis) +gsasf 21 ./gio/gks/gsasf.x procedure gsasf (lasf) +gsawi 8 ./gio/gks/gsaw.x procedure gsawi (param, value) +gsawr 24 ./gio/gks/gsaw.x procedure gsawr (param, value) +gscan 5 ./gio/gscan.x procedure gscan (gp, command) +gschh 8 ./gio/gks/gschh.x procedure gschh (chh) +gschup 7 ./gio/gks/gschup.x procedure gschup (chux, chuy) +gsclip 7 ./gio/gks/gsclip.x procedure gsclip (iclip) +gscr 8 ./gio/gks/gscr.x procedure gscr (wkstation, color_index, rgb) +gscur 8 ./gio/gscur.x procedure gscur (gp, x, y) +gselnt 7 ./gio/gks/gselnt.x procedure gselnt (wcs) +gseti 7 ./gio/gseti.x procedure gseti (gp, param, value) +gsetr 11 ./gio/gsetr.x procedure gsetr (gp, param, rval) +gsets 9 ./gio/gsets.x procedure gsets (gp, param, value) +gsfaci 8 ./gio/gks/gsfaci.x procedure gsfaci (index) +gsfais 9 ./gio/gks/gsfais.x procedure gsfais (ints) +gslwsc 8 ./gio/gks/gslwsc.x procedure gslwsc (width) +gsmk 9 ./gio/gks/gsmk.x procedure gsmk (mtype) +gsmksc 8 ./gio/gks/gsmksc.x procedure gsmksc (width) +gsplci 8 ./gio/gks/gsplci.x procedure gsplci (coli) +gspmci 8 ./gio/gks/gspmci.x procedure gspmci (coli) +gspmi 8 ./gio/gks/gspmi.x procedure gspmi (index) +gst_set_attribute_i247 ./gio/gsetr.x procedure gst_set_attribute_i (new_value, value, state) +gst_set_attribute_r264 ./gio/gsetr.x procedure gst_set_attribute_r (new_value, value, state) +gstati 7 ./gio/gstati.x int procedure gstati (gp, param) +gstatr 11 ./gio/gstatr.x real procedure gstatr (gp, param) +gstats 9 ./gio/gstats.x int procedure gstats (gp, param, outstr, maxch) +gstrcat 5 ./fmtio/gstrcat.x int procedure gstrcat (str, outstr, maxch) +gstrcpy 5 ./fmtio/gstrcpy.x int procedure gstrcpy (s1, s2, maxch) +gstrmatch 40 ./fmtio/strmatch.x int procedure gstrmatch (str, pat, first_char, last_char) +gstxal 8 ./gio/gks/gstxal.x procedure gstxal (txalh, txalv) +gstxci 9 ./gio/gks/gstxci.x procedure gstxci (coli) +gstxp 8 ./gio/gks/gstxp.x procedure gstxp (txp) +gsview 7 ./gio/gsview.x procedure gsview (gp, x1, x2, y1, y2) +gsvp 9 ./gio/gks/gsvp.x procedure gsvp (wcs, x1, x2, y1, y2) +gswind 7 ./gio/gswind.x procedure gswind (gp, x1, x2, y1, y2) +gswn 9 ./gio/gks/gswn.x procedure gswn (wcs, x1, x2, y1, y2) +gt_distance 163 ./gio/gtick.gx PIXEL procedure gt_distance (x, step, nearest_tick) +gt_distance 163 ./gio/gtickr.x real procedure gt_distance (x, step, nearest_tick) +gt_linearity 139 ./gio/gtick.gx PIXEL procedure gt_linearity (x1, x2) +gt_linearity 139 ./gio/gtickr.x real procedure gt_linearity (x1, x2) +gt_ndigits 115 ./gio/gtick.gx int procedure gt_ndigits (x1, x2, step) +gt_ndigits 115 ./gio/gtickr.x int procedure gt_ndigits (x1, x2, step) +gtext 13 ./gio/gtext.x procedure gtext (gp, x, y, text, format) +gtick 17 ./gio/gtick.gx procedure gtick$t (x1, x2, rough_nticks, logflag, x_tick1, step) +gtickr 17 ./gio/gtickr.x procedure gtickr (x1, x2, rough_nticks, logflag, x_tick1, step) +gtr_backup 12 ./gio/cursor/gtrbackup.x procedure gtr_backup (stream) +gtr_cliptoplane 93 ./gio/cursor/gtrwsclip.x int procedure gtr_cliptoplane (p1, p2, npts, index, s, ref) +gtr_connect 20 ./gio/cursor/gtrconn.x int procedure gtr_connect (kernfname, taskname, devname, stream, in, out) +gtr_control 18 ./gio/cursor/gtrctrl.x procedure gtr_control (stream, gki, source_pid) +gtr_ctran 118 ./gio/cursor/gtrwstran.x procedure gtr_ctran (mx, my, sx, sy) +gtr_delete 10 ./gio/cursor/gtrdelete.x procedure gtr_delete (tr, gki) +gtr_disconnect 14 ./gio/cursor/gtrdiscon.x procedure gtr_disconnect (pid, in, out, stream) +gtr_fetch_next_instruction 14 ./gio/cursor/gtrfetch.x int procedure gtr_fetch_next_instruction (tr, gki) +gtr_frame 14 ./gio/cursor/gtrframe.x procedure gtr_frame (tr, gki, stream) +gtr_gflush 13 ./gio/cursor/gtrgflush.x procedure gtr_gflush (stream) +gtr_gtran 9 ./gio/cursor/gtrgtran.x procedure gtr_gtran (fd, x1, x2, y1, y2) +gtr_gtty 9 ./gio/cursor/gtrgtty.x pointer procedure gtr_gtty (stream) +gtr_init 13 ./gio/cursor/gtrinit.x pointer procedure gtr_init (stream) +gtr_memusage 42 ./gio/cursor/gtrstatus.x procedure gtr_memusage (fd, stream, name) +gtr_openws 21 ./gio/cursor/gtropenws.x procedure gtr_openws (devspec, mode, stream, source_pid) +gtr_page 12 ./gio/cursor/gtrpage.x procedure gtr_page (fd, stream) +gtr_polyclip 9 ./gio/cursor/gtrwsclip.x int procedure gtr_polyclip (pv, npts, x1, x2, y1, y2) +gtr_polytran 136 ./gio/cursor/gtrwstran.x procedure gtr_polytran (gki) +gtr_ptran 12 ./gio/cursor/gtrptran.x procedure gtr_ptran (stream, x1, x2, y1, y2) +gtr_readcursor 10 ./gio/cursor/gtrrcur.x int procedure gtr_readcursor (fd, key, sx, sy, raster, rx, ry) +gtr_redraw 9 ./gio/cursor/gtrredraw.x procedure gtr_redraw (stream) +gtr_reset 10 ./gio/cursor/gtrreset.x procedure gtr_reset (status) +gtr_status 13 ./gio/cursor/gtrstatus.x procedure gtr_status (fd) +gtr_truncate 13 ./gio/cursor/gtrtrunc.x procedure gtr_truncate (tr, gki) +gtr_undo 11 ./gio/cursor/gtrundo.x procedure gtr_undo (stream) +gtr_waitpage 14 ./gio/cursor/gtrwaitp.x procedure gtr_waitpage (fd, stream) +gtr_writecursor 7 ./gio/cursor/gtrwcur.x procedure gtr_writecursor (fd, x, y) +gtr_writep 21 ./gio/cursor/gtrwritep.x pointer procedure gtr_writep (fd, nchars) +gtr_wstran 23 ./gio/cursor/gtrwstran.x procedure gtr_wstran (gki) +gtrset 11 ./gio/cursor/gtrset.x procedure gtrset (fd, x1, x2, y1, y2) +gtxset 12 ./gio/gtxset.x procedure gtxset (tx, format, ip) +gty_binsearch 119 ./gty/gtyindex.x int procedure gty_binsearch (capcode, t_capcode, ncaps) +gty_encode_capability161 ./gty/gtyindex.x int procedure gty_encode_capability (cap) +gty_extract_alias 282 ./gty/gtyopen.x int procedure gty_extract_alias (str, ip, outstr, maxch) +gty_fetch_entry 143 ./gty/gtyopen.x procedure gty_fetch_entry (fd, device, tty) +gty_find_capability 85 ./gty/gtyindex.x int procedure gty_find_capability (tty, cap, ip) +gty_index_caps 15 ./gty/gtyindex.x procedure gty_index_caps (tty, t_capcode, t_capindex, ncaps) +gty_scan_termcap_file 75 ./gty/gtyopen.x procedure gty_scan_termcap_file (tty, termcap_file, devname) +gtycaps 7 ./gty/gtycaps.x pointer procedure gtycaps (gty) +gtyclose 5 ./gty/gtyclose.x procedure gtyclose (tty) +gtygetb 6 ./gty/gtygetb.x bool procedure gtygetb (tty, cap) +gtygeti 7 ./gty/gtygeti.x int procedure gtygeti (tty, cap) +gtygetr 9 ./gty/gtygetr.x real procedure gtygetr (tty, cap) +gtygets 20 ./gty/gtygets.x int procedure gtygets (tty, cap, outstr, maxch) +gtyopen 14 ./gty/gtyopen.x pointer procedure gtyopen (termcap_file, device, ufields) +gumark 12 ./gio/gumark.x procedure gumark (gp, x, y, npts, xcen, ycen, xsize, ysize, fill) +gvline 6 ./gio/gvline.x procedure gvline (gp, v, npts, x1, x2) +gvmark 11 ./gio/gvmark.x procedure gvmark (gp, v, npts, x1, x2, marktype, xsize, ysize) +gwcs_mkfilename 84 ./gio/grdwcs.x procedure gwcs_mkfilename (devname, fname, maxch) +gwrwcs 21 ./gio/grdwcs.x procedure gwrwcs (devname, wcs, len_wcs) +gxgtx 9 ./gio/gks/gxgtx.x procedure gxgtx (px, py, chars) +iand 36 ./gio/ncarutil/sysint/ishift.x int procedure iand (a, b) +iand 36 ./gio/nspp/sysint/ishift.x int procedure iand (a, b) +idb_close 128 ./imio/db/idbcard.x procedure idb_close (idb) +idb_filstr 12 ./imio/db/idbfstr.x int procedure idb_filstr (s1, s2, maxch) +idb_findrecord 11 ./imfort/db/idbfind.x int procedure idb_findrecord (im, key, rp) +idb_findrecord 11 ./imio/db/idbfind.x int procedure idb_findrecord (im, key, rp) +idb_getstring 14 ./imfort/db/idbgstr.x int procedure idb_getstring (im, key, outstr, maxch) +idb_getstring 14 ./imio/db/idbgstr.x int procedure idb_getstring (im, key, outstr, maxch) +idb_kwlookup 9 ./imio/db/idbkwlu.x int procedure idb_kwlookup (key) +idb_kwlookup 10 ./imfort/db/idbkwlu.x int procedure idb_kwlookup (key) +idb_naxis 8 ./imfort/db/idbnaxis.x int procedure idb_naxis (keyw, axnum) +idb_nextcard 87 ./imio/db/idbcard.x int procedure idb_nextcard (idb, recptr) +idb_open 38 ./imio/db/idbcard.x pointer procedure idb_open (im, ualen) +idb_putstring 15 ./imfort/db/idbpstr.x int procedure idb_putstring (im, key, strval) +idb_putstring 15 ./imio/db/idbpstr.x int procedure idb_putstring (im, key, strval) +idk_close 181 ./gio/imdkern/idk.x procedure idk_close (fd) +idk_draw 315 ./gio/imdkern/idk.x procedure idk_draw (fd, a_x, a_y) +idk_flush 203 ./gio/imdkern/idk.x procedure idk_flush (fd) +idk_frame 218 ./gio/imdkern/idk.x procedure idk_frame (fd) +idk_linewidth 491 ./gio/imdkern/idk.x procedure idk_linewidth (fd, width) +idk_move 292 ./gio/imdkern/idk.x procedure idk_move (fd, x, y) +idk_open 63 ./gio/imdkern/idk.x int procedure idk_open (a_frame, a_color, tty) +idk_vector 393 ./gio/imdkern/idk.x procedure idk_vector (a_x1, a_y1, a_x2, a_y2) +ieegmap 306 ./osb/ieee.gx procedure ieegmap$t (inval, outval) +ieegmapd 287 ./osb/ieeed.x procedure ieegmapd (inval, outval) +ieegmapr 287 ./osb/ieeer.x procedure ieegmapr (inval, outval) +ieegnan 246 ./osb/ieee.gx procedure ieegnan$t (x) +ieegnand 227 ./osb/ieeed.x procedure ieegnand (x) +ieegnanr 227 ./osb/ieeer.x procedure ieegnanr (x) +ieemap 293 ./osb/ieee.gx procedure ieemap$t (inval, outval) +ieemapd 274 ./osb/ieeed.x procedure ieemapd (inval, outval) +ieemapr 274 ./osb/ieeer.x procedure ieemapr (inval, outval) +ieepak 165 ./osb/ieee.gx procedure ieepak$t (x) +ieepakd 152 ./osb/ieeed.x procedure ieepakd (x) +ieepakr 152 ./osb/ieeer.x procedure ieepakr (x) +ieesmap 331 ./osb/ieee.gx procedure ieesmap$t (inval, outval) +ieesmapd 312 ./osb/ieeed.x procedure ieesmapd (inval, outval) +ieesmapr 312 ./osb/ieeer.x procedure ieesmapr (inval, outval) +ieesnan 229 ./osb/ieee.gx procedure ieesnan$t (x) +ieesnand 210 ./osb/ieeed.x procedure ieesnand (x) +ieesnanr 210 ./osb/ieeer.x procedure ieesnanr (x) +ieestat 262 ./osb/ieee.gx procedure ieestat$t (o_nin, o_nout) +ieestatd 243 ./osb/ieeed.x procedure ieestatd (o_nin, o_nout) +ieestatr 243 ./osb/ieeer.x procedure ieestatr (o_nin, o_nout) +ieeupk 186 ./osb/ieee.gx procedure ieeupk$t (x) +ieeupkd 173 ./osb/ieeed.x procedure ieeupkd (x) +ieeupkr 173 ./osb/ieeer.x procedure ieeupkr (x) +ieevpak 67 ./osb/ieee.gx procedure ieevpak$t (native, ieee, nelem) +ieevpakd 60 ./osb/ieeed.x procedure ieevpakd (native, ieee, nelem) +ieevpakr 60 ./osb/ieeer.x procedure ieevpakr (native, ieee, nelem) +ieevupk 102 ./osb/ieee.gx procedure ieevupk$t (ieee, native, nelem) +ieevupkd 95 ./osb/ieeed.x procedure ieevupkd (ieee, native, nelem) +ieevupkr 95 ./osb/ieeer.x procedure ieevupkr (ieee, native, nelem) +ieezstat 279 ./osb/ieee.gx procedure ieezstat$t () +ieezstatd 260 ./osb/ieeed.x procedure ieezstatd () +ieezstatr 260 ./osb/ieeer.x procedure ieezstatr () +iki_access 14 ./imio/iki/ikiaccess.x int procedure iki_access (image, root, extn, acmode) +iki_close 12 ./imio/iki/ikiclose.x procedure iki_close (im) +iki_copy 11 ./imio/iki/ikicopy.x procedure iki_copy (old, new) +iki_debug 331 ./imio/iki/ikiextn.x procedure iki_debug (str, fd, flags) +iki_delete 8 ./imio/iki/ikidelete.x procedure iki_delete (image) +iki_extninit 32 ./imio/iki/ikiextn.x int procedure iki_extninit (env_imtype, def_imtype, env_imextn, def_imextn) +iki_getextn 244 ./imio/iki/ikiextn.x int procedure iki_getextn (kernel, index, extn, maxch) +iki_getfield 291 ./imio/iki/ikiextn.x int procedure iki_getfield (ip, outstr, maxch, delim) +iki_getpar 271 ./imio/iki/ikiextn.x int procedure iki_getpar (param) +iki_init 9 ./imio/iki/ikiinit.x procedure iki_init() +iki_lddriver 10 ./imio/iki/ikildd.x procedure iki_lddriver (kname, ex_open, ex_close, ex_opix, ex_updhdr, +iki_mkfname 8 ./imio/iki/ikimkfn.x procedure iki_mkfname (root, extn, fname, maxch) +iki_open 15 ./imio/iki/ikiopen.x procedure iki_open (n_im, image, ksection, cl_index, cl_size, acmode, o_im) +iki_opix 12 ./imio/iki/ikiopix.x procedure iki_opix (im) +iki_parse 9 ./imio/iki/ikiparse.x procedure iki_parse (image, root, extn) +iki_rename 8 ./imio/iki/ikirename.x procedure iki_rename (old, new) +iki_updhdr 10 ./imio/iki/ikiupdhdr.x procedure iki_updhdr (im) +iki_validextn 219 ./imio/iki/ikiextn.x int procedure iki_validextn (kernel, extn) +im_ctranset 126 ./imio/imisec.x procedure im_ctranset (imdes, dim, x1_arg, x2_arg, step) +im_decode_subscript161 ./imio/imisec.x procedure im_decode_subscript (section, ip, x1, x2, step) +im_init_newimage 8 ./imio/iminie.x procedure im_init_newimage (im, len_imhdr) +im_make_newcopy 13 ./imio/immaky.x procedure im_make_newcopy (im, o_im) +im_pmldhdr 157 ./imio/impmhdr.x procedure im_pmldhdr (im, bp) +im_pmlne1 8 ./imio/impmlne1.x bool procedure im_pmlne1 (im) +im_pmlne2 8 ./imio/impmlne2.x bool procedure im_pmlne2 (im, lineno) +im_pmlne3 8 ./imio/impmlne3.x bool procedure im_pmlne3 (im, lineno, bandno) +im_pmlnev 8 ./imio/impmlnev.x bool procedure im_pmlnev (im, v) +im_pmmap 17 ./imio/impmmap.x pointer procedure im_pmmap (mask, mode, ref_im) +im_pmmapo 14 ./imio/impmmapo.x pointer procedure im_pmmapo (pl, ref_im) +im_pmopen 16 ./imio/impmopen.x pointer procedure im_pmopen (mask, mode, title, maxch, ref_im) +im_pmsne1 7 ./imio/impmsne1.x bool procedure im_pmsne1 (im, x1, x2) +im_pmsne2 7 ./imio/impmsne2.x bool procedure im_pmsne2 (im, x1, x2, y1, y2) +im_pmsne3 7 ./imio/impmsne3.x bool procedure im_pmsne3 (im, x1,x2, y1,y2, z1,z2) +im_pmsnev 8 ./imio/impmsnev.x bool procedure im_pmsnev (im, vs, ve, ndim) +im_pmsvhdr 45 ./imio/impmhdr.x int procedure im_pmsvhdr (im, bp, sz_buf) +im_seterrim 151 ./imfort/imemsg.x procedure im_seterrim (ier, im) +im_seterrop 133 ./imfort/imemsg.x procedure im_seterrop (ier, opname) +imaccess 7 ./imio/imaccess.x int procedure imaccess (image, acmode) +imaccf 6 ./imfort/db/imaccf.x int procedure imaccf (im, key) +imaccf 6 ./imio/db/imaccf.x int procedure imaccf (im, key) +imacck 8 ./imfort/imacck.x procedure imacck (im, key, ier) +imaddb 6 ./imfort/db/imaddb.x procedure imaddb (im, key, value, comment) +imaddb 6 ./imio/db/imaddb.x procedure imaddb (im, key, value) +imaddd 6 ./imfort/db/imaddd.x procedure imaddd (im, key, value, comment) +imaddd 6 ./imio/db/imaddd.x procedure imaddd (im, key, value) +imaddf 11 ./imfort/db/imaddf.x procedure imaddf (im, key, datatype, comment) +imaddf 12 ./imio/db/imaddf.x procedure imaddf (im, key, datatype) +imaddi 6 ./imfort/db/imaddi.x procedure imaddi (im, key, value, comment) +imaddi 6 ./imio/db/imaddi.x procedure imaddi (im, key, value) +imaddk 7 ./imfort/imaddk.x procedure imaddk (im, keyw, dtype, comm, ier) +imaddl 6 ./imfort/db/imaddl.x procedure imaddl (im, key, value, comment) +imaddl 6 ./imio/db/imaddl.x procedure imaddl (im, key, value) +imaddr 6 ./imfort/db/imaddr.x procedure imaddr (im, key, value, comment) +imaddr 6 ./imio/db/imaddr.x procedure imaddr (im, key, value) +imadds 6 ./imfort/db/imadds.x procedure imadds (im, key, value, comment) +imadds 6 ./imio/db/imadds.x procedure imadds (im, key, value) +imaflp 7 ./imio/imaflp.x procedure imaflp (a, npix, sz_pixel) +imakwb 7 ./imfort/imakwb.x procedure imakwb (im, keyw, bval, comm, ier) +imakwc 7 ./imfort/imakwc.x procedure imakwc (im, keyw, sval, comm, ier) +imakwd 7 ./imfort/imakwd.x procedure imakwd (im, keyw, dval, comm, ier) +imakwi 7 ./imfort/imakwi.x procedure imakwi (im, keyw, ival, comm, ier) +imakwr 7 ./imfort/imakwr.x procedure imakwr (im, keyw, rval, comm, ier) +imalign 103 ./imio/imioff.x procedure imalign (offset, blksize) +imaplv 9 ./imio/imaplv.x procedure imaplv (im, lv, pv, ndim) +imastr 6 ./imfort/db/imastr.x procedure imastr (im, key, value, comment) +imastr 6 ./imio/db/imastr.x procedure imastr (im, key, value) +imbln1 10 ./imio/imbln1.x procedure imbln1 (imdes, nx) +imbln2 10 ./imio/imbln2.x procedure imbln2 (imdes, nx, ny) +imbln3 10 ./imio/imbln3.x procedure imbln3 (imdes, nx, ny, nz) +imbtran 11 ./imio/imbtran.x procedure imbtran (im, v1, v2, ndim) +imcfnl 85 ./imfort/db/imgnfn.x procedure imcfnl (fn) +imcfnl 85 ./imio/db/imgnfn.x procedure imcfnl (fn) +imckwl 88 ./imfort/imokwl.x procedure imckwl (kwl, ier) +imclos 9 ./imfort/imclos.x procedure imclos (im, ier) +imcopy 6 ./imio/imcopy.x procedure imcopy (old, new) +imcrea 6 ./imfort/imcrea.x procedure imcrea (f77nam, axlen, naxis, pixtype, ier) +imcrex 15 ./imfort/imcrex.x procedure imcrex (image, axlen, naxis, pixtype, ier) +imcssz 13 ./imio/imcssz.x long procedure imcssz (im, vs, ve, ndim, dtype, npix, rwflag) +imd_bcell 39 ./gio/imdkern/imdpcell.x procedure imd_bcell (m, nx, ny, ax1,ay1, ax2,ay2) +imd_cancel 7 ./gio/imdkern/imdcancel.x procedure imd_cancel (dummy) +imd_clear 10 ./gio/imdkern/imdclear.x procedure imd_clear (dummy) +imd_close 8 ./gio/imdkern/imdclose.x procedure imd_close() +imd_closews 9 ./gio/imdkern/imdclws.x procedure imd_closews (devname, n) +imd_color 7 ./gio/imdkern/imdcolor.x procedure imd_color (index) +imd_dashline 78 ./gio/imdkern/imdpl.x procedure imd_dashline (g_out, p, npts, ltype) +imd_drawchar 15 ./gio/imdkern/imddrawch.x procedure imd_drawchar (ch, x, y, xsize, ysize, orien, font) +imd_escape 6 ./gio/imdkern/imdescape.x procedure imd_escape (fn, instruction, nwords) +imd_faset 8 ./gio/imdkern/imdfaset.x procedure imd_faset (gki) +imd_fillarea 7 ./gio/imdkern/imdfa.x procedure imd_fillarea (p, npts) +imd_flush 7 ./gio/imdkern/imdflush.x procedure imd_flush (dummy) +imd_font 13 ./gio/imdkern/imdfont.x procedure imd_font (font) +imd_getcellarray 6 ./gio/imdkern/imdgcell.x procedure imd_getcellarray (nx, ny, x1,y1, x2,y2) +imd_getseg 149 ./gio/imdkern/imdpl.x int procedure imd_getseg (maxlen, penup, ltype) +imd_gstring 141 ./gio/imdkern/imdinit.x pointer procedure imd_gstring (cap) +imd_init 13 ./gio/imdkern/imdinit.x procedure imd_init (tty, devname) +imd_linetype 8 ./gio/imdkern/imdline.x procedure imd_linetype (index) +imd_mcell 122 ./gio/imdkern/imdpcell.x procedure imd_mcell (m, nx, ny, ax1,ay1, ax2,ay2) +imd_opendev 12 ./gio/imdkern/imdopen.x procedure imd_opendev (devname, frame, color, dd) +imd_openws 13 ./gio/imdkern/imdopenws.x procedure imd_openws (devname, n, mode) +imd_plset 9 ./gio/imdkern/imdplset.x procedure imd_plset (gki) +imd_pmset 8 ./gio/imdkern/imdpmset.x procedure imd_pmset (gki) +imd_polyline 17 ./gio/imdkern/imdpl.x procedure imd_polyline (p, npts) +imd_polymarker 9 ./gio/imdkern/imdpm.x procedure imd_polymarker (p, npts) +imd_putcellarray 16 ./gio/imdkern/imdpcell.x procedure imd_putcellarray (m, nx, ny, ax1,ay1, ax2,ay2) +imd_reset 12 ./gio/imdkern/imdreset.x procedure imd_reset() +imd_text 20 ./gio/imdkern/imdtx.x procedure imd_text (xc, yc, text, n) +imd_txset 9 ./gio/imdkern/imdtxset.x procedure imd_txset (gki) +imdele 6 ./imfort/imdele.x procedure imdele (image, ier) +imdelete 5 ./imio/imdelete.x procedure imdelete (image) +imdelf 10 ./imfort/db/imdelf.x procedure imdelf (im, key) +imdelf 10 ./imio/db/imdelf.x procedure imdelf (im, key) +imdelk 7 ./imfort/imdelk.x procedure imdelk (im, keyw, ier) +imdelx 10 ./imfort/imdelx.x procedure imdelx (image, ier) +imdinit 82 ./imfort/imfdir.x procedure imdinit() +imdmap 16 ./imio/imdmap.x pointer procedure imdmap (device, access_mode, imdopen) +imemsg 11 ./imfort/imemsg.x procedure imemsg (ier, errmsg) +imerr 6 ./imio/imerr.x procedure imerr (image_name, errcode) +imf_align 80 ./imfort/imioff.x procedure imf_align (offset, blksize) +imf_gpixfname 7 ./imfort/imfgpfn.x procedure imf_gpixfname (pixfile, hdrfile, path, maxch) +imf_initoffsets 12 ./imfort/imioff.x procedure imf_initoffsets (im, dev_block_size) +imf_mkpixfname 12 ./imfort/imfmkpfn.x procedure imf_mkpixfname (im, pixfile, maxch, ier) +imf_parse 9 ./imfort/imfparse.x procedure imf_parse (image, root, extn) +imf_trans 13 ./imfort/imftrans.x procedure imf_trans (fname, root, extn) +imf_updhdr 9 ./imfort/imfupdhdr.x procedure imf_updhdr (im, status) +imflpl 57 ./imio/imaflp.x procedure imflpl (a, npix) +imflps 39 ./imio/imaflp.x procedure imflps (a, npix) +imfls 10 ./imio/imfls.gx procedure imfls$t (imdes) +imflsd 10 ./imio/tf/imflsd.x procedure imflsd (imdes) +imflsh 8 ./imfort/imflsh.x procedure imflsh (im, ier) +imflsh 14 ./imio/imflsh.x procedure imflsh (im, bp, vs, ve, ndim) +imflsi 10 ./imio/tf/imflsi.x procedure imflsi (imdes) +imflsl 10 ./imio/tf/imflsl.x procedure imflsl (imdes) +imflsr 10 ./imio/tf/imflsr.x procedure imflsr (imdes) +imflss 10 ./imio/tf/imflss.x procedure imflss (imdes) +imflsx 10 ./imio/tf/imflsx.x procedure imflsx (imdes) +imflush 10 ./imio/imflush.x procedure imflush (imdes) +imfn_putkey 306 ./imfort/db/imgnfn.x procedure imfn_putkey (key, strp, nstr, nextch, sbuf) +imfn_putkey 307 ./imio/db/imgnfn.x procedure imfn_putkey (key, strp, nstr, nextch, sbuf) +imfn_stdkeys 247 ./imio/db/imgnfn.x procedure imfn_stdkeys (im, patcode, strp, nstr, nextch, sbuf) +imfn_stdkeys 249 ./imfort/db/imgnfn.x procedure imfn_stdkeys (im, patcode, strp, nstr, nextch, sbuf) +imgatr 11 ./imfort/db/imgatr.x procedure imgatr (im, key, dtype, comm, maxch) +imgcluster 6 ./imio/imgclust.x procedure imgcluster (imspec, cluster, maxch) +imgdir 35 ./imfort/imfdir.x procedure imgdir (dir) +imgdirx 65 ./imfort/imfdir.x int procedure imgdirx (dir, maxch) +imgetb 8 ./imfort/db/imgetb.x bool procedure imgetb (im, key) +imgetb 9 ./imio/db/imgetb.x bool procedure imgetb (im, key) +imgetc 5 ./imfort/db/imgetc.x char procedure imgetc (im, key) +imgetc 5 ./imio/db/imgetc.x char procedure imgetc (im, key) +imgetd 10 ./imfort/db/imgetd.x double procedure imgetd (im, key) +imgetd 10 ./imio/db/imgetd.x double procedure imgetd (im, key) +imgeti 5 ./imfort/db/imgeti.x int procedure imgeti (im, key) +imgeti 5 ./imio/db/imgeti.x int procedure imgeti (im, key) +imgetl 5 ./imfort/db/imgetl.x long procedure imgetl (im, key) +imgetl 5 ./imio/db/imgetl.x long procedure imgetl (im, key) +imgetr 5 ./imfort/db/imgetr.x real procedure imgetr (im, key) +imgetr 5 ./imio/db/imgetr.x real procedure imgetr (im, key) +imgets 5 ./imfort/db/imgets.x short procedure imgets (im, key) +imgets 5 ./imio/db/imgets.x short procedure imgets (im, key) +imgftype 11 ./imfort/db/imgftype.x int procedure imgftype (im, key) +imgftype 11 ./imio/db/imgftype.x int procedure imgftype (im, key) +imggs 7 ./imio/imggs.gx pointer procedure imggs$t (imdes, vs, ve, ndim) +imggsc 15 ./imio/imggsc.x pointer procedure imggsc (im, vs, ve, ndim, dtype, totpix) +imggsd 7 ./imio/tf/imggsd.x pointer procedure imggsd (imdes, vs, ve, ndim) +imggsi 7 ./imio/tf/imggsi.x pointer procedure imggsi (imdes, vs, ve, ndim) +imggsl 7 ./imio/tf/imggsl.x pointer procedure imggsl (imdes, vs, ve, ndim) +imggsr 7 ./imio/tf/imggsr.x pointer procedure imggsr (imdes, vs, ve, ndim) +imggss 7 ./imio/tf/imggss.x pointer procedure imggss (imdes, vs, ve, ndim) +imggsx 7 ./imio/tf/imggsx.x pointer procedure imggsx (imdes, vs, ve, ndim) +imgibf 8 ./imio/imgibf.x pointer procedure imgibf (im, vs, ve, ndim, dtype) +imgimage 6 ./imio/imgimage.x procedure imgimage (imspec, image, maxch) +imgkwb 7 ./imfort/imgkwb.x procedure imgkwb (im, keyw, bval, ier) +imgkwc 8 ./imfort/imgkwc.x procedure imgkwc (im, keyw, sval, ier) +imgkwd 7 ./imfort/imgkwd.x procedure imgkwd (im, keyw, dval, ier) +imgkwi 7 ./imfort/imgkwi.x procedure imgkwi (im, keyw, ival, ier) +imgkwr 7 ./imfort/imgkwr.x procedure imgkwr (im, keyw, rval, ier) +imgl1 11 ./imio/imgl1.gx pointer procedure imgl1$t (im) +imgl1d 11 ./imio/tf/imgl1d.x pointer procedure imgl1d (im) +imgl1i 11 ./imio/tf/imgl1i.x pointer procedure imgl1i (im) +imgl1l 11 ./imio/tf/imgl1l.x pointer procedure imgl1l (im) +imgl1r 10 ./imfort/imgl1r.x procedure imgl1r (im, buf, ier) +imgl1r 11 ./imio/tf/imgl1r.x pointer procedure imgl1r (im) +imgl1s 9 ./imfort/imgl1s.x procedure imgl1s (im, buf, ier) +imgl1s 11 ./imio/tf/imgl1s.x pointer procedure imgl1s (im) +imgl1x 11 ./imio/tf/imgl1x.x pointer procedure imgl1x (im) +imgl2 12 ./imio/imgl2.gx pointer procedure imgl2$t (im, linenum) +imgl2d 12 ./imio/tf/imgl2d.x pointer procedure imgl2d (im, linenum) +imgl2i 12 ./imio/tf/imgl2i.x pointer procedure imgl2i (im, linenum) +imgl2l 12 ./imio/tf/imgl2l.x pointer procedure imgl2l (im, linenum) +imgl2r 10 ./imfort/imgl2r.x procedure imgl2r (im, buf, lineno, ier) +imgl2r 12 ./imio/tf/imgl2r.x pointer procedure imgl2r (im, linenum) +imgl2s 9 ./imfort/imgl2s.x procedure imgl2s (im, buf, lineno, ier) +imgl2s 12 ./imio/tf/imgl2s.x pointer procedure imgl2s (im, linenum) +imgl2x 12 ./imio/tf/imgl2x.x pointer procedure imgl2x (im, linenum) +imgl3 12 ./imio/imgl3.gx pointer procedure imgl3$t (im, line, band) +imgl3d 12 ./imio/tf/imgl3d.x pointer procedure imgl3d (im, line, band) +imgl3i 12 ./imio/tf/imgl3i.x pointer procedure imgl3i (im, line, band) +imgl3l 12 ./imio/tf/imgl3l.x pointer procedure imgl3l (im, line, band) +imgl3r 10 ./imfort/imgl3r.x procedure imgl3r (im, buf, lineno, bandno, ier) +imgl3r 12 ./imio/tf/imgl3r.x pointer procedure imgl3r (im, line, band) +imgl3s 9 ./imfort/imgl3s.x procedure imgl3s (im, buf, lineno, bandno, ier) +imgl3s 12 ./imio/tf/imgl3s.x pointer procedure imgl3s (im, line, band) +imgl3x 12 ./imio/tf/imgl3x.x pointer procedure imgl3x (im, line, band) +imgnfn 37 ./imfort/db/imgnfn.x int procedure imgnfn (fn, outstr, maxch) +imgnfn 37 ./imio/db/imgnfn.x int procedure imgnfn (fn, outstr, maxch) +imgnkw 54 ./imfort/imokwl.x procedure imgnkw (kwl, outstr, ier) +imgnl 11 ./imio/imgnl.gx int procedure imgnl$t (imdes, lineptr, v) +imgnld 11 ./imio/tf/imgnld.x int procedure imgnld (imdes, lineptr, v) +imgnli 11 ./imio/tf/imgnli.x int procedure imgnli (imdes, lineptr, v) +imgnll 11 ./imio/tf/imgnll.x int procedure imgnll (imdes, lineptr, v) +imgnln 13 ./imio/imgnln.x int procedure imgnln (im, lineptr, v, dtype) +imgnlr 11 ./imio/tf/imgnlr.x int procedure imgnlr (imdes, lineptr, v) +imgnls 11 ./imio/tf/imgnls.x int procedure imgnls (imdes, lineptr, v) +imgnlx 11 ./imio/tf/imgnlx.x int procedure imgnlx (imdes, lineptr, v) +imgobf 8 ./imio/imgobf.x pointer procedure imgobf (im, vs, ve, ndim, dtype) +imgs1 7 ./imio/imgs1.gx pointer procedure imgs1$t (im, x1, x2) +imgs1d 7 ./imio/tf/imgs1d.x pointer procedure imgs1d (im, x1, x2) +imgs1i 7 ./imio/tf/imgs1i.x pointer procedure imgs1i (im, x1, x2) +imgs1l 7 ./imio/tf/imgs1l.x pointer procedure imgs1l (im, x1, x2) +imgs1r 7 ./imio/tf/imgs1r.x pointer procedure imgs1r (im, x1, x2) +imgs1r 10 ./imfort/imgs1r.x procedure imgs1r (im, buf, i1, i2, ier) +imgs1s 7 ./imio/tf/imgs1s.x pointer procedure imgs1s (im, x1, x2) +imgs1s 10 ./imfort/imgs1s.x procedure imgs1s (im, buf, i1, i2, ier) +imgs1x 7 ./imio/tf/imgs1x.x pointer procedure imgs1x (im, x1, x2) +imgs2 7 ./imio/imgs2.gx pointer procedure imgs2$t (im, x1, x2, y1, y2) +imgs2d 7 ./imio/tf/imgs2d.x pointer procedure imgs2d (im, x1, x2, y1, y2) +imgs2i 7 ./imio/tf/imgs2i.x pointer procedure imgs2i (im, x1, x2, y1, y2) +imgs2l 7 ./imio/tf/imgs2l.x pointer procedure imgs2l (im, x1, x2, y1, y2) +imgs2r 7 ./imio/tf/imgs2r.x pointer procedure imgs2r (im, x1, x2, y1, y2) +imgs2r 10 ./imfort/imgs2r.x procedure imgs2r (im, buf, i1, i2, j1, j2, ier) +imgs2s 7 ./imio/tf/imgs2s.x pointer procedure imgs2s (im, x1, x2, y1, y2) +imgs2s 10 ./imfort/imgs2s.x procedure imgs2s (im, buf, i1, i2, j1, j2, ier) +imgs2x 7 ./imio/tf/imgs2x.x pointer procedure imgs2x (im, x1, x2, y1, y2) +imgs3 7 ./imio/imgs3.gx pointer procedure imgs3$t (im, x1, x2, y1, y2, z1, z2) +imgs3d 7 ./imio/tf/imgs3d.x pointer procedure imgs3d (im, x1, x2, y1, y2, z1, z2) +imgs3i 7 ./imio/tf/imgs3i.x pointer procedure imgs3i (im, x1, x2, y1, y2, z1, z2) +imgs3l 7 ./imio/tf/imgs3l.x pointer procedure imgs3l (im, x1, x2, y1, y2, z1, z2) +imgs3r 7 ./imio/tf/imgs3r.x pointer procedure imgs3r (im, x1, x2, y1, y2, z1, z2) +imgs3r 10 ./imfort/imgs3r.x procedure imgs3r (im, buf, i1, i2, j1, j2, k1, k2, ier) +imgs3s 7 ./imio/tf/imgs3s.x pointer procedure imgs3s (im, x1, x2, y1, y2, z1, z2) +imgs3s 10 ./imfort/imgs3s.x procedure imgs3s (im, buf, i1, i2, j1, j2, k1, k2, ier) +imgs3x 7 ./imio/tf/imgs3x.x pointer procedure imgs3x (im, x1, x2, y1, y2, z1, z2) +imgsection 5 ./imio/imgsect.x procedure imgsection (imspec, section, maxch) +imgsiz 8 ./imfort/imgsiz.x procedure imgsiz (im, axlen, naxis, pixtype, ier) +imgstr 11 ./imfort/db/imgstr.x procedure imgstr (im, key, outstr, maxch) +imgstr 11 ./imio/db/imgstr.x procedure imgstr (im, key, outstr, maxch) +imhcpy 9 ./imfort/imhcpy.x procedure imhcpy (o_im, n_im, ier) +imioff 12 ./imio/imioff.x procedure imioff (im, pixoff, compress, devblksz) +imisec 42 ./imio/imisec.x procedure imisec (imdes, section) +imloop 9 ./imio/imloop.x int procedure imloop (v, vs, ve, vinc, ndim) +immap 6 ./imio/immap.x pointer procedure immap (imspec, acmode, hdr_arg) +immapz 11 ./imio/immapz.x pointer procedure immapz (imspec, acmode, hdr_arg) +imnote 9 ./imio/imnote.x long procedure imnote (im, v) +imofnl 98 ./imfort/db/imgnfn.x pointer procedure imofnl (im, template, sort) +imofnl 98 ./imio/db/imgnfn.x pointer procedure imofnl (im, template, sort) +imofnls 58 ./imfort/db/imgnfn.x pointer procedure imofnls (im, template) +imofnls 58 ./imio/db/imgnfn.x pointer procedure imofnls (im, template) +imofnlu 71 ./imfort/db/imgnfn.x pointer procedure imofnlu (im, template) +imofnlu 71 ./imio/db/imgnfn.x pointer procedure imofnlu (im, template) +imokwl 21 ./imfort/imokwl.x procedure imokwl (im, patstr, sortit, kwl, ier) +imopen 5 ./imfort/imopen.x procedure imopen (f77nam, acmode, im, ier) +imopnc 11 ./imfort/imopnc.x procedure imopnc (nimage, o_im, n_im, ier) +imopnx 13 ./imfort/imopnx.x procedure imopnx (image, acmode, im, ier) +imopsf 15 ./imio/imopsf.x procedure imopsf (im) +impak 6 ./imio/impak.gx procedure impak$t (a, b, npix, dtype) +impakd 6 ./imio/tf/impakd.x procedure impakd (a, b, npix, dtype) +impaki 6 ./imio/tf/impaki.x procedure impaki (a, b, npix, dtype) +impakl 6 ./imio/tf/impakl.x procedure impakl (a, b, npix, dtype) +impakr 6 ./imio/tf/impakr.x procedure impakr (a, b, npix, dtype) +impaks 6 ./imio/tf/impaks.x procedure impaks (a, b, npix, dtype) +impakx 6 ./imio/tf/impakx.x procedure impakx (a, b, npix, dtype) +imparse 20 ./imio/imparse.x procedure imparse (imspec, cluster, sz_cluster, ksection, sz_ksection, +impgs 8 ./imio/impgs.gx pointer procedure impgs$t (imdes, vs, ve, ndim) +impgsd 8 ./imio/tf/impgsd.x pointer procedure impgsd (imdes, vs, ve, ndim) +impgsi 8 ./imio/tf/impgsi.x pointer procedure impgsi (imdes, vs, ve, ndim) +impgsl 8 ./imio/tf/impgsl.x pointer procedure impgsl (imdes, vs, ve, ndim) +impgsr 8 ./imio/tf/impgsr.x pointer procedure impgsr (imdes, vs, ve, ndim) +impgss 8 ./imio/tf/impgss.x pointer procedure impgss (imdes, vs, ve, ndim) +impgsx 8 ./imio/tf/impgsx.x pointer procedure impgsx (imdes, vs, ve, ndim) +impixf 19 ./imfort/impixf.x procedure impixf (im, pixfd, pixfil, pixoff, szline, ier) +impkwb 7 ./imfort/impkwb.x procedure impkwb (im, keyw, bval, ier) +impkwc 7 ./imfort/impkwc.x procedure impkwc (im, keyw, sval, ier) +impkwd 7 ./imfort/impkwd.x procedure impkwd (im, keyw, dval, ier) +impkwi 7 ./imfort/impkwi.x procedure impkwi (im, keyw, ival, ier) +impkwr 7 ./imfort/impkwr.x procedure impkwr (im, keyw, rval, ier) +impl1 11 ./imio/impl1.gx pointer procedure impl1$t (im) +impl1d 11 ./imio/tf/impl1d.x pointer procedure impl1d (im) +impl1i 11 ./imio/tf/impl1i.x pointer procedure impl1i (im) +impl1l 11 ./imio/tf/impl1l.x pointer procedure impl1l (im) +impl1r 10 ./imfort/impl1r.x procedure impl1r (im, buf, ier) +impl1r 11 ./imio/tf/impl1r.x pointer procedure impl1r (im) +impl1s 10 ./imfort/impl1s.x procedure impl1s (im, buf, ier) +impl1s 11 ./imio/tf/impl1s.x pointer procedure impl1s (im) +impl1x 11 ./imio/tf/impl1x.x pointer procedure impl1x (im) +impl2 12 ./imio/impl2.gx pointer procedure impl2$t (im, linenum) +impl2d 12 ./imio/tf/impl2d.x pointer procedure impl2d (im, linenum) +impl2i 12 ./imio/tf/impl2i.x pointer procedure impl2i (im, linenum) +impl2l 12 ./imio/tf/impl2l.x pointer procedure impl2l (im, linenum) +impl2r 10 ./imfort/impl2r.x procedure impl2r (im, buf, lineno, ier) +impl2r 12 ./imio/tf/impl2r.x pointer procedure impl2r (im, linenum) +impl2s 10 ./imfort/impl2s.x procedure impl2s (im, buf, lineno, ier) +impl2s 12 ./imio/tf/impl2s.x pointer procedure impl2s (im, linenum) +impl2x 12 ./imio/tf/impl2x.x pointer procedure impl2x (im, linenum) +impl3 12 ./imio/impl3.gx pointer procedure impl3$t (im, line, band) +impl3d 12 ./imio/tf/impl3d.x pointer procedure impl3d (im, line, band) +impl3i 12 ./imio/tf/impl3i.x pointer procedure impl3i (im, line, band) +impl3l 12 ./imio/tf/impl3l.x pointer procedure impl3l (im, line, band) +impl3r 10 ./imfort/impl3r.x procedure impl3r (im, buf, lineno, bandno, ier) +impl3r 12 ./imio/tf/impl3r.x pointer procedure impl3r (im, line, band) +impl3s 10 ./imfort/impl3s.x procedure impl3s (im, buf, lineno, bandno, ier) +impl3s 12 ./imio/tf/impl3s.x pointer procedure impl3s (im, line, band) +impl3x 12 ./imio/tf/impl3x.x pointer procedure impl3x (im, line, band) +impnl 12 ./imio/impnl.gx int procedure impnl$t (imdes, lineptr, v) +impnld 12 ./imio/tf/impnld.x int procedure impnld (imdes, lineptr, v) +impnli 12 ./imio/tf/impnli.x int procedure impnli (imdes, lineptr, v) +impnll 12 ./imio/tf/impnll.x int procedure impnll (imdes, lineptr, v) +impnln 13 ./imio/impnln.x int procedure impnln (im, lineptr, v, dtype) +impnlr 12 ./imio/tf/impnlr.x int procedure impnlr (imdes, lineptr, v) +impnls 12 ./imio/tf/impnls.x int procedure impnls (imdes, lineptr, v) +impnlx 12 ./imio/tf/impnlx.x int procedure impnlx (imdes, lineptr, v) +imps1 7 ./imio/imps1.gx pointer procedure imps1$t (im, x1, x2) +imps1d 7 ./imio/tf/imps1d.x pointer procedure imps1d (im, x1, x2) +imps1i 7 ./imio/tf/imps1i.x pointer procedure imps1i (im, x1, x2) +imps1l 7 ./imio/tf/imps1l.x pointer procedure imps1l (im, x1, x2) +imps1r 7 ./imio/tf/imps1r.x pointer procedure imps1r (im, x1, x2) +imps1r 10 ./imfort/imps1r.x procedure imps1r (im, buf, i1, i2, ier) +imps1s 7 ./imio/tf/imps1s.x pointer procedure imps1s (im, x1, x2) +imps1s 10 ./imfort/imps1s.x procedure imps1s (im, buf, i1, i2, ier) +imps1x 7 ./imio/tf/imps1x.x pointer procedure imps1x (im, x1, x2) +imps2 7 ./imio/imps2.gx pointer procedure imps2$t (im, x1, x2, y1, y2) +imps2d 7 ./imio/tf/imps2d.x pointer procedure imps2d (im, x1, x2, y1, y2) +imps2i 7 ./imio/tf/imps2i.x pointer procedure imps2i (im, x1, x2, y1, y2) +imps2l 7 ./imio/tf/imps2l.x pointer procedure imps2l (im, x1, x2, y1, y2) +imps2r 7 ./imio/tf/imps2r.x pointer procedure imps2r (im, x1, x2, y1, y2) +imps2r 10 ./imfort/imps2r.x procedure imps2r (im, buf, i1, i2, j1, j2, ier) +imps2s 7 ./imio/tf/imps2s.x pointer procedure imps2s (im, x1, x2, y1, y2) +imps2s 10 ./imfort/imps2s.x procedure imps2s (im, buf, i1, i2, j1, j2, ier) +imps2x 7 ./imio/tf/imps2x.x pointer procedure imps2x (im, x1, x2, y1, y2) +imps3 7 ./imio/imps3.gx pointer procedure imps3$t (im, x1, x2, y1, y2, z1, z2) +imps3d 7 ./imio/tf/imps3d.x pointer procedure imps3d (im, x1, x2, y1, y2, z1, z2) +imps3i 7 ./imio/tf/imps3i.x pointer procedure imps3i (im, x1, x2, y1, y2, z1, z2) +imps3l 7 ./imio/tf/imps3l.x pointer procedure imps3l (im, x1, x2, y1, y2, z1, z2) +imps3r 7 ./imio/tf/imps3r.x pointer procedure imps3r (im, x1, x2, y1, y2, z1, z2) +imps3r 10 ./imfort/imps3r.x procedure imps3r (im, buf, i1, i2, j1, j2, k1, k2, ier) +imps3s 7 ./imio/tf/imps3s.x pointer procedure imps3s (im, x1, x2, y1, y2, z1, z2) +imps3s 10 ./imfort/imps3s.x procedure imps3s (im, buf, i1, i2, j1, j2, k1, k2, ier) +imps3x 7 ./imio/tf/imps3x.x pointer procedure imps3x (im, x1, x2, y1, y2, z1, z2) +impstr 15 ./imfort/db/impstr.x procedure impstr (im, key, value) +impstr 15 ./imio/db/impstr.x procedure impstr (im, key, value) +imputb 5 ./imfort/db/imputb.x procedure imputb (im, key, bval) +imputb 5 ./imio/db/imputb.x procedure imputb (im, key, bval) +imputd 7 ./imfort/db/imputd.x procedure imputd (im, key, dval) +imputd 7 ./imio/db/imputd.x procedure imputd (im, key, dval) +imputh 19 ./imio/db/imputh.x procedure imputh (im, key, text) +imputi 5 ./imfort/db/imputi.x procedure imputi (im, key, ival) +imputi 5 ./imio/db/imputi.x procedure imputi (im, key, ival) +imputl 5 ./imfort/db/imputl.x procedure imputl (im, key, lval) +imputl 5 ./imio/db/imputl.x procedure imputl (im, key, lval) +imputr 5 ./imfort/db/imputr.x procedure imputr (im, key, rval) +imputr 7 ./imio/db/imputr.x procedure imputr (im, key, rval) +imputs 5 ./imfort/db/imputs.x procedure imputs (im, key, sval) +imputs 5 ./imio/db/imputs.x procedure imputs (im, key, value) +imrbpx 16 ./imio/imrbpx.x procedure imrbpx (im, obuf, totpix, v, vinc) +imrdhdr 14 ./imfort/imrdhdr.x int procedure imrdhdr (fp, im, uchars, htype) +imrdpx 15 ./imio/imrdpx.x procedure imrdpx (im, obuf, npix, v, xstep) +imrename 5 ./imio/imrename.x procedure imrename (old, new) +imrmbufs 7 ./imio/imrmbufs.x procedure imrmbufs (im) +imrnam 11 ./imfort/imrnam.x procedure imrnam (oimage, nimage, ier) +imsamp 5 ./imio/imsamp.x procedure imsamp (a, b, npix, sz_pixel, step) +imsdir 20 ./imfort/imfdir.x procedure imsdir (dir) +imsdirx 50 ./imfort/imfdir.x procedure imsdirx (dir) +imsetbuf 15 ./imio/imsetbuf.x procedure imsetbuf (fd, im) +imseti 14 ./imio/imseti.x procedure imseti (im, param, value) +imsetr 12 ./imio/imsetr.x procedure imsetr (im, param, value) +imsinb 10 ./imio/imsinb.x int procedure imsinb (im, vs, ve, ndim) +imsmpl 50 ./imio/imsamp.x procedure imsmpl (a, b, npix, step) +imsmps 34 ./imio/imsamp.x procedure imsmps (a, b, npix, step) +imsslv 11 ./imio/imsslv.x procedure imsslv (im, vs, ve, v, vinc, npix) +imstati 10 ./imio/imstati.x int procedure imstati (im, option) +imstatr 9 ./imio/imstatr.x real procedure imstatr (im, param) +imstats 10 ./imio/imstats.x procedure imstats (im, option, outstr, maxch) +imswap 9 ./imfort/imswap.x procedure imswap (im, buf, nchars) +imt_mapname 270 ./imio/imt.x int procedure imt_mapname (fnt, outstr, maxch) +imtclose 258 ./imio/imt.x procedure imtclose (imt) +imtgetim 175 ./imio/imt.x int procedure imtgetim (imt, outstr, maxch) +imtlen 235 ./imio/imt.x int procedure imtlen (imt) +imtopen 73 ./imio/imt.x pointer procedure imtopen (template) +imtopenp 46 ./imio/imt.x pointer procedure imtopenp (param) +imtrew 247 ./imio/imt.x procedure imtrew (imt) +imtrgetim 205 ./imio/imt.x int procedure imtrgetim (imt, index, outstr, maxch) +imtypk 7 ./imfort/imtypk.x procedure imtypk (im, keyw, dtype, comm, ier) +imunmap 10 ./imio/imunmap.x procedure imunmap (im) +imupk 6 ./imio/imupk.gx procedure imupk$t (a, b, npix, dtype) +imupkd 6 ./imio/tf/imupkd.x procedure imupkd (a, b, npix, dtype) +imupki 6 ./imio/tf/imupki.x procedure imupki (a, b, npix, dtype) +imupkl 6 ./imio/tf/imupkl.x procedure imupkl (a, b, npix, dtype) +imupkr 6 ./imio/tf/imupkr.x procedure imupkr (a, b, npix, dtype) +imupks 6 ./imio/tf/imupks.x procedure imupks (a, b, npix, dtype) +imupkx 6 ./imio/tf/imupkx.x procedure imupkx (a, b, npix, dtype) +imwbpx 15 ./imio/imwbpx.x procedure imwbpx (im, ibuf, totpix, v, vinc) +imwpix 11 ./imfort/imwpix.x int procedure imwpix (im, buf, nchars, offset, inplace) +imwrhdr 12 ./imfort/imwrhdr.x int procedure imwrhdr (fp, im, htype) +imwrite 12 ./imio/imwrite.x procedure imwrite (imdes, buf, nchars, offset) +imwrpx 12 ./imio/imwrpx.x procedure imwrpx (im, buf, npix, v, xstep) +index 1 ./libc/index.c index (str, ch) +intr_disable 11 ./etc/intr.x procedure intr_disable() +intr_enable 28 ./etc/intr.x procedure intr_enable() +intr_reset 46 ./etc/intr.x procedure intr_reset() +intt 10 ./gio/nspp/sysint/intt.x bool procedure intt (value) +ior 48 ./gio/ncarutil/sysint/ishift.x int procedure ior (a, b) +ior 48 ./gio/nspp/sysint/ishift.x int procedure ior (a, b) +iraf_main 126 ./etc/main.x int procedure iraf_main (a_cmd, a_inchan, a_outchan, a_errchan, +irafpath 1 ../unix/os/irafpath.c irafpath (fname) +isatty 1 ./libc/isatty.c isatty (fd) +ishift 7 ./gio/ncarutil/sysint/ishift.x int procedure ishift (in_word, n) +ishift 7 ./gio/nspp/sysint/ishift.x int procedure ishift (in_word, n) +itob 5 ./etc/itob.x bool procedure itob (integer_value) +itoc 9 ./fmtio/itoc.x int procedure itoc (ival, str, maxch) +iw_cardtype 10 ./mwcs/iwctype.x int procedure iw_cardtype (card, type, axis, index) +iw_cfits 8 ./mwcs/iwcfits.x procedure iw_cfits (iw) +iw_enterwcs 15 ./mwcs/iwewcs.x procedure iw_enterwcs (mw, iw, ndim) +iw_findcard 9 ./mwcs/iwfind.x pointer procedure iw_findcard (iw, type, axis, index) +iw_gbigfits 15 ./mwcs/iwgbfits.x pointer procedure iw_gbigfits (iw, ctype, axis) +iw_putarray 9 ./mwcs/iwparray.x procedure iw_putarray (iw, new, old, ndim, kw_format, kw_type, kw_index) +iw_putstr 9 ./mwcs/iwpstr.x procedure iw_putstr (fd, iw, axis, ctype, fmt1, fmt2, max_index) +iw_rfits 18 ./mwcs/iwrfits.x pointer procedure iw_rfits (mw, im, mode) +iw_setaxmap 11 ./mwcs/iwsaxmap.x procedure iw_setaxmap (mw, im) +kardbf 52 ./ki/kfiobf.x procedure kardbf (chan, buf, max_bytes, offset) +kardgd 52 ./ki/kfiogd.x procedure kardgd (chan, buf, max_bytes, offset) +kardlp 52 ./ki/kfiolp.x procedure kardlp (chan, buf, max_bytes, offset) +kardpl 52 ./ki/kfiopl.x procedure kardpl (chan, buf, max_bytes, offset) +kardpr 48 ./ki/kfiopr.x procedure kardpr (chan, buf, max_bytes, offset) +kardsf 51 ./ki/kfiosf.x procedure kardsf (chan, buf, max_bytes, offset) +kawrbf 68 ./ki/kfiobf.x procedure kawrbf (chan, buf, nbytes, offset) +kawrgd 68 ./ki/kfiogd.x procedure kawrgd (chan, buf, nbytes, offset) +kawrlp 68 ./ki/kfiolp.x procedure kawrlp (chan, buf, nbytes, offset) +kawrpl 68 ./ki/kfiopl.x procedure kawrpl (chan, buf, nbytes, offset) +kawrpr 64 ./ki/kfiopr.x procedure kawrpr (chan, buf, nbytes, offset) +kawrsf 67 ./ki/kfiosf.x procedure kawrsf (chan, buf, nbytes, offset) +kawtbf 84 ./ki/kfiobf.x procedure kawtbf (chan, status) +kawtgd 84 ./ki/kfiogd.x procedure kawtgd (chan, status) +kawtlp 84 ./ki/kfiolp.x procedure kawtlp (chan, status) +kawtpl 84 ./ki/kfiopl.x procedure kawtpl (chan, status) +kawtpr 80 ./ki/kfiopr.x procedure kawtpr (chan, status) +kawtsf 83 ./ki/kfiosf.x procedure kawtsf (chan, status) +kb_zard 16 ./ki/kbzard.x procedure kb_zard (device, chan, obuf, max_bytes, loffset) +kb_zawr 10 ./ki/kbzawr.x procedure kb_zawr (device, chan, ibuf, nbytes, loffset) +kb_zawt 33 ./ki/kbzawt.x procedure kb_zawt (device, chan, status) +kb_zcls 10 ./ki/kbzcls.x procedure kb_zcls (device, chan, status) +kb_zopn 9 ./ki/kbzopn.x procedure kb_zopn (device, osfn, mode, chan) +kb_zstt 11 ./ki/kbzstt.x procedure kb_zstt (device, chan, what, lvalue) +kclcpr 9 ./ki/kclcpr.x procedure kclcpr (pid, exit_status) +kcldir 9 ./ki/kcldir.x procedure kcldir (chan, status) +kcldpr 9 ./ki/kcldpr.x procedure kcldpr (jobcode, killflag, exit_status) +kclsbf 31 ./ki/kfiobf.x procedure kclsbf (chan, status) +kclsgd 31 ./ki/kfiogd.x procedure kclsgd (chan, status) +kclslp 31 ./ki/kfiolp.x procedure kclslp (chan, status) +kclspl 31 ./ki/kfiopl.x procedure kclspl (chan, status) +kclssf 30 ./ki/kfiosf.x procedure kclssf (chan, status) +kclstx 33 ./ki/kfiotx.x procedure kclstx (chan, status) +kclsty 32 ./ki/kfioty.x procedure kclsty (chan, status) +kdvall 8 ./ki/kdvall.x procedure kdvall (device, allflag, status) +kdvown 9 ./ki/kdvown.x procedure kdvown (device, owner, maxch, status) +kernel_panic 2 ../unix/os/zpanic.c kernel_panic (errmsg) +kfacss 8 ./ki/kfacss.x procedure kfacss (osfn, mode, type, status) +kfaloc 8 ./ki/kfaloc.x procedure kfaloc (osfn, nbytes, status) +kfchdr 11 ./ki/kfchdr.x procedure kfchdr (dirname, status) +kfdele 8 ./ki/kfdele.x procedure kfdele (osfn, status) +kfgcwd 10 ./ki/kfgcwd.x procedure kfgcwd (outstr, maxch, nchars) +kfinfo 9 ./ki/kfinfo.x procedure kfinfo (osfn, fi, status) +kflstx 84 ./ki/kfiotx.x procedure kflstx (chan, status) +kflsty 83 ./ki/kfioty.x procedure kflsty (chan, status) +kfmkcp 13 ./ki/kfmkcp.x procedure kfmkcp (old_osfn, new_osfn, status) +kfmkdr 8 ./ki/kfmkdr.x procedure kfmkdr (osfn, status) +kfpath 9 ./ki/kfpath.x procedure kfpath (vfn, osfn, maxch, nchars) +kfprot 8 ./ki/kfprot.x procedure kfprot (osfn, protflag, status) +kfrnam 9 ./ki/kfrnam.x procedure kfrnam (old_osfn, new_osfn, status) +kfsubd 13 ./ki/kfsubd.x procedure kfsubd (osdir, maxch, subdir, nchars) +kfxdir 18 ./ki/kfxdir.x procedure kfxdir (vfn, osdir, maxch, nchars) +kgettx 54 ./ki/kfiotx.x procedure kgettx (chan, text, maxch, status) +kgetty 53 ./ki/kfioty.x procedure kgetty (chan, text, maxch, status) +kgfdir 11 ./ki/kgfdir.x procedure kgfdir (chan, osfn, maxch, status) +ki_connect 23 ./ki/kiconnect.x int procedure ki_connect (rname) +ki_decode 35 ./ki/kiencode.x long procedure ki_decode (str, nchars) +ki_encode 6 ./ki/kiencode.x procedure ki_encode (data, str, nchars) +ki_envreset 10 ./ki/kienvreset.x procedure ki_envreset (name, value) +ki_error 22 ./ki/kierror.x procedure ki_error (server) +ki_extnode 15 ./ki/kiextnode.x int procedure ki_extnode (resource, nodename, maxch, nchars) +ki_findnode 8 ./ki/kifndnode.x int procedure ki_findnode (alias) +ki_flushtx 66 ./ki/ktzput.x procedure ki_flushtx (device, chan, status) +ki_fmapfn 15 ./ki/kifmapfn.x procedure ki_fmapfn (vfn, pkosfn, maxch) +ki_freechan 12 ./ki/kifchan.x procedure ki_freechan (chan) +ki_getchan 10 ./ki/kigchan.x int procedure ki_getchan (server, oschan) +ki_gethosts 11 ./ki/kighost.x int procedure ki_gethosts() +ki_gnode 14 ./ki/kignode.x int procedure ki_gnode (rname, outstr, delim) +ki_init 15 ./ki/kiinit.x procedure ki_init (inchan, outchan, errchan, device, devtype) +ki_localnode 7 ./ki/kilnode.x int procedure ki_localnode (node) +ki_mapchan 12 ./ki/kimapchan.x int procedure ki_mapchan (chan, nodename, maxch) +ki_mapname 19 ./ki/kimapname.x int procedure ki_mapname (name, newname, maxch) +ki_openks 13 ./ki/kiopenks.x int procedure ki_openks (node) +ki_receive 13 ./ki/kireceive.x int procedure ki_receive (server, opcode, subcode) +ki_send 9 ./ki/kisend.x int procedure ki_send (server, opcode, subcode) +ki_sendrcv 7 ./ki/kisendrcv.x int procedure ki_sendrcv (server, opcode, subcode) +ki_shownet 7 ./ki/kishownet.x procedure ki_shownet (fd) +ki_xnode 10 ./ki/kixnode.x procedure ki_xnode (r1, r2, maxch) +kintpr 9 ./ki/kintpr.x procedure kintpr (pid, vex, status) +kmalloc 8 ./memdbg/kmalloc.x int procedure kmalloc (ubufp, nelems, dtype) +kmalloc 8 ./memio/kmalloc.x int procedure kmalloc (ubufp, nelems, dtype) +knottx 113 ./ki/kfiotx.x procedure knottx (chan, loffset) +knotty 112 ./ki/kfioty.x procedure knotty (chan, loffset) +kopcpr 9 ./ki/kopcpr.x procedure kopcpr (process, inchan, outchan, pid) +kopdir 10 ./ki/kopdir.x procedure kopdir (osfn, chan) +kopdpr 8 ./ki/kopdpr.x procedure kopdpr (process, bkgfile, bkgmsg, jobcode) +kopnbf 9 ./ki/kfiobf.x procedure kopnbf (osfn, mode, chan) +kopngd 9 ./ki/kfiogd.x procedure kopngd (osfn, mode, chan) +kopnlp 9 ./ki/kfiolp.x procedure kopnlp (osfn, mode, chan) +kopnpl 9 ./ki/kfiopl.x procedure kopnpl (osfn, mode, chan) +kopnsf 11 ./ki/kfiosf.x procedure kopnsf (osfn, mode, chan) +kopntx 10 ./ki/kfiotx.x procedure kopntx (osfn, mode, chan) +kopnty 9 ./ki/kfioty.x procedure kopnty (osfn, mode, chan) +koscmd 13 ./ki/koscmd.x procedure koscmd (oscmd, stdin_file, stdout_file, stderr_file, status) +kputtx 69 ./ki/kfiotx.x procedure kputtx (chan, text, nchars, status) +kputty 68 ./ki/kfioty.x procedure kputty (chan, text, nchars, status) +krealloc 26 ./memdbg/krealloc.x int procedure krealloc (ptr, a_nelems, a_dtype) +krealloc 26 ./memio/krealloc.x int procedure krealloc (ptr, a_nelems, a_dtype) +ks_aread 9 ./ki/ksaread.x procedure ks_aread (server, buf, maxbytes) +ks_await 9 ./ki/ksawait.x procedure ks_await (server, status) +ks_awrite 9 ./ki/ksawrite.x procedure ks_awrite (server, buf, nbytes) +ks_error 1229 ./ki/irafks.x procedure ks_error (errcode, errmsg) +ks_fmapfn 1413 ./ki/irafks.x procedure ks_fmapfn (vfn, osfn, maxch) +ks_geti 19 ../unix/os/zfioks.c ks_geti (fd) +ks_getlogin 22 ../unix/os/zfioks.c ks_getlogin (hostname, loginname, password, ks) +ks_getpass 30 ../unix/os/zfioks.c ks_getpass (user, host) +ks_getresvport 17 ../unix/os/zfioks.c ks_getresvport (alport) +ks_getword 28 ../unix/os/zfioks.c ks_getword (ipp, obuf) +ks_loadbf 1251 ./ki/irafks.x procedure ks_loadbf (bfdd) +ks_loadtx 1316 ./ki/irafks.x procedure ks_loadtx (txdd) +ks_onsig 16 ../unix/os/zfioks.c ks_onsig (sig, arg1, arg2) +ks_puti 18 ../unix/os/zfioks.c ks_puti (fd, ival) +ks_receive 1384 ./ki/irafks.x int procedure ks_receive (server) +ks_rexecport 18 ../unix/os/zfioks.c ks_rexecport() +ks_rhosts 25 ../unix/os/zfioks.c ks_rhosts (filename) +ks_send 1351 ./ki/irafks.x int procedure ks_send (server, opcode, subcode) +ks_socket 17 ../unix/os/zfioks.c ks_socket (host, addr, port, mode) +ks_sysname 25 ../unix/os/zfioks.c ks_sysname (filename, pathname) +ks_username 25 ../unix/os/zfioks.c ks_username (filename, pathname, username) +ks_whosts 28 ../unix/os/zfioks.c ks_whosts (hp, filename) +ks_zfiobf 642 ./ki/irafks.x procedure ks_zfiobf (in, out, iobuf, len_iobuf, bfdd) +ks_zfiomt 1046 ./ki/irafks.x procedure ks_zfiomt (in, out, iobuf, len_iobuf) +ks_zfiotx 847 ./ki/irafks.x procedure ks_zfiotx (in, out, iobuf, len_iobuf, txdd) +ksektx 98 ./ki/kfiotx.x procedure ksektx (chan, loffset, status) +ksekty 97 ./ki/kfioty.x procedure ksekty (chan, loffset, status) +kserver 149 ./ki/irafks.x procedure kserver (in, out, buflen) +ksttbf 98 ./ki/kfiobf.x procedure ksttbf (chan, what, lvalue) +ksttgd 98 ./ki/kfiogd.x procedure ksttgd (chan, what, lvalue) +ksttlp 98 ./ki/kfiolp.x procedure ksttlp (chan, what, lvalue) +ksttpl 98 ./ki/kfiopl.x procedure ksttpl (chan, what, lvalue) +ksttpr 94 ./ki/kfiopr.x procedure ksttpr (chan, what, lvalue) +ksttsf 97 ./ki/kfiosf.x procedure ksttsf (chan, what, lvalue) +kstttx 127 ./ki/kfiotx.x procedure kstttx (chan, what, lvalue) +ksttty 126 ./ki/kfioty.x procedure ksttty (chan, what, lvalue) +kt_zcls 10 ./ki/ktzcls.x procedure kt_zcls (device, chan, status) +kt_zfls 10 ./ki/ktzfls.x procedure kt_zfls (device, chan, status) +kt_zget 10 ./ki/ktzget.x procedure kt_zget (device, chan, obuf, maxch, status) +kt_znot 10 ./ki/ktznot.x procedure kt_znot (device, chan, loffset) +kt_zopn 10 ./ki/ktzopn.x procedure kt_zopn (device, osfn, mode, chan) +kt_zput 11 ./ki/ktzput.x procedure kt_zput (device, chan, ibuf, nchars, status) +kt_zsek 10 ./ki/ktzsek.x procedure kt_zsek (device, chan, loffset, status) +kt_zstt 10 ./ki/ktzstt.x procedure kt_zstt (device, chan, what, lvalue) +kzclmt 10 ./ki/kzclmt.x procedure kzclmt (chan, devpos, status) +kzopmt 10 ./ki/kzopmt.x procedure kzopmt (device, mode, devcap, devpos, newfile, chan) +kzrdmt 10 ./ki/kzrdmt.x procedure kzrdmt (chan, obuf, max_bytes, offset) +kzrwmt 10 ./ki/kzrwmt.x procedure kzrwmt (drive, devcap, status) +kzstmt 8 ./ki/kzstmt.x procedure kzstmt (chan, what, lvalue) +kzwrmt 9 ./ki/kzwrmt.x procedure kzwrmt (chan, buf, nbytes, offset) +kzwtmt 9 ./ki/kzwtmt.x procedure kzwtmt (chan, devpos, status) +lexnum 64 ./fmtio/lexnum.x int procedure lexnum (str, ip_start, nchars) +lno_close 48 ./etc/lineoff.x procedure lno_close (lp) +lno_fetch 89 ./etc/lineoff.x int procedure lno_fetch (lp, line, loffset, ltag) +lno_open 26 ./etc/lineoff.x pointer procedure lno_open (maxlines) +lno_save 62 ./etc/lineoff.x procedure lno_save (lp, line, loffset, ltag) +loci 13 ./gio/nspp/sysint/loc.x int procedure loci (x) +locpr 6 ./etc/locpr.x int procedure locpr (proc) +locva 5 ./etc/locva.x int procedure locva (variable) +loggedin 4 ../unix/os/alloc.c loggedin (uid) +lp_zaread 53 ./etc/lpopen.x procedure lp_zaread (chan, buf, maxbytes, offset) +lp_zawait 109 ./etc/lpopen.x procedure lp_zawait (chan, nbytes) +lp_zawrite 83 ./etc/lpopen.x procedure lp_zawrite (chan, buf, nbytes, offset) +lpopen 19 ./etc/lpopen.x int procedure lpopen (device, mode, type) +ltoc 8 ./fmtio/ltoc.x int procedure ltoc (lval, outstr, maxch) +ma_ideh 12 ./etc/maideh.x procedure ma_ideh() +malloc 1 ./libc/malloc.c malloc (nbytes) +malloc 10 ./memdbg/malloc.x procedure malloc (ubufp, nelems, dtype) +malloc 10 ./memio/malloc.x procedure malloc (ubufp, nelems, dtype) +malloc1 58 ./memdbg/malloc1.x int procedure malloc1 (output_pointer, nelems, dtype, sz_align, fwa_align) +malloc1 58 ./memio/malloc1.x int procedure malloc1 (output_pointer, nelems, dtype, sz_align, fwa_align) +mcswap 5 ./gio/nspp/sysint/mcswap.x procedure mcswap (a, npix) +memchk 503 ./mwcs/zzdebug.x procedure memchk() +mfree 10 ./memdbg/mfree.x procedure mfree (ptr, dtype) +mfree 10 ./memio/mfree.x procedure mfree (ptr, dtype) +mgdptr 8 ./memdbg/mgdptr.x pointer procedure mgdptr (fwa, dtype, sz_align, fwa_align) +mgdptr 8 ./memio/mgdptr.x pointer procedure mgdptr (fwa, dtype, sz_align, fwa_align) +mgtfwa 11 ./memdbg/mgtfwa.x int procedure mgtfwa (ptr, dtype) +mgtfwa 11 ./memio/mgtfwa.x int procedure mgtfwa (ptr, dtype) +miilen 10 ./osb/miilen.x int procedure miilen (nelems, mii_datatype) +miinelem 10 ./osb/miinelem.x int procedure miinelem (nchars, mii_type) +miipak 36 ./osb/miipak.x procedure miipak (spp, mii, nelems, spp_datatype, mii_datatype) +miipak16 8 ./osb/miipak16.x procedure miipak16 (spp, mii, nelems, spp_datatype) +miipak32 8 ./osb/miipak32.x procedure miipak32 (spp, mii, nelems, spp_datatype) +miipak8 6 ./osb/miipak8.x procedure miipak8 (spp, mii, nelems, spp_datatype) +miipakd 8 ./osb/miipakd.x procedure miipakd (spp, mii, nelems, spp_datatype) +miipakr 8 ./osb/miipakr.x procedure miipakr (spp, mii, nelems, spp_datatype) +miipksize 10 ./osb/miipksize.x int procedure miipksize (nelems, mii_type) +miirdc 246 ./imfort/mii.x int procedure miirdc (fp, spp, maxchars) +miirdi 24 ./imfort/mii.x int procedure miirdi (fp, spp, maxelem) +miirdl 69 ./imfort/mii.x int procedure miirdl (fp, spp, maxelem) +miirdr 114 ./imfort/mii.x int procedure miirdr (fp, spp, maxelem) +miiread 8 ./etc/miiread.gx int procedure miiread$t (fd, spp, maxelem) +miireadc 8 ./etc/miireadc.x int procedure miireadc (fd, spp, maxchars) +miireadd 8 ./etc/gen/miireadd.x int procedure miireadd (fd, spp, maxelem) +miireadi 8 ./etc/gen/miireadi.x int procedure miireadi (fd, spp, maxelem) +miireadl 8 ./etc/gen/miireadl.x int procedure miireadl (fd, spp, maxelem) +miireadr 8 ./etc/gen/miireadr.x int procedure miireadr (fd, spp, maxelem) +miireads 8 ./etc/gen/miireads.x int procedure miireads (fd, spp, maxelem) +miiupk 8 ./osb/miiupk.x procedure miiupk (mii, spp, nelems, mii_datatype, spp_datatype) +miiupk16 8 ./osb/miiupk16.x procedure miiupk16 (mii, spp, nelems, spp_datatype) +miiupk32 8 ./osb/miiupk32.x procedure miiupk32 (mii, spp, nelems, spp_datatype) +miiupk8 6 ./osb/miiupk8.x procedure miiupk8 (mii, spp, nelems, spp_datatype) +miiupkd 8 ./osb/miiupkd.x procedure miiupkd (mii, spp, nelems, spp_datatype) +miiupkr 8 ./osb/miiupkr.x procedure miiupkr (mii, spp, nelems, spp_datatype) +miiwrc 291 ./imfort/mii.x int procedure miiwrc (fp, spp, nchars) +miiwri 159 ./imfort/mii.x int procedure miiwri (fp, spp, nelem) +miiwrite 8 ./etc/miiwrite.gx procedure miiwrite$t (fd, spp, nelem) +miiwritec 8 ./etc/miiwritec.x procedure miiwritec (fd, spp, nchars) +miiwrited 8 ./etc/gen/miiwrited.x procedure miiwrited (fd, spp, nelem) +miiwritei 8 ./etc/gen/miiwritei.x procedure miiwritei (fd, spp, nelem) +miiwritel 8 ./etc/gen/miiwritel.x procedure miiwritel (fd, spp, nelem) +miiwriter 8 ./etc/gen/miiwriter.x procedure miiwriter (fd, spp, nelem) +miiwrites 8 ./etc/gen/miiwrites.x procedure miiwrites (fd, spp, nelem) +miiwrl 188 ./imfort/mii.x int procedure miiwrl (fp, spp, nelem) +miiwrr 217 ./imfort/mii.x int procedure miiwrr (fp, spp, nelem) +mio_close 8 ./pmio/mioclose.x procedure mio_close (mp) +mio_glseg 21 ./pmio/miogl.gx int procedure mio_glseg$t (mp, ptr, mval, v, npix) +mio_glsegd 21 ./pmio/tf/miogld.x int procedure mio_glsegd (mp, ptr, mval, v, npix) +mio_glsegi 21 ./pmio/tf/miogli.x int procedure mio_glsegi (mp, ptr, mval, v, npix) +mio_glsegl 21 ./pmio/tf/miogll.x int procedure mio_glsegl (mp, ptr, mval, v, npix) +mio_glsegr 21 ./pmio/tf/mioglr.x int procedure mio_glsegr (mp, ptr, mval, v, npix) +mio_glsegs 21 ./pmio/tf/miogls.x int procedure mio_glsegs (mp, ptr, mval, v, npix) +mio_glsegx 21 ./pmio/tf/mioglx.x int procedure mio_glsegx (mp, ptr, mval, v, npix) +mio_open 10 ./pmio/mioopen.x pointer procedure mio_open (mask, flags, im) +mio_openo 9 ./pmio/mioopeno.x pointer procedure mio_openo (pm, im) +mio_plseg 21 ./pmio/miopl.gx int procedure mio_plseg$t (mp, ptr, mval, v, npix) +mio_plsegd 21 ./pmio/tf/miopld.x int procedure mio_plsegd (mp, ptr, mval, v, npix) +mio_plsegi 21 ./pmio/tf/miopli.x int procedure mio_plsegi (mp, ptr, mval, v, npix) +mio_plsegl 21 ./pmio/tf/miopll.x int procedure mio_plsegl (mp, ptr, mval, v, npix) +mio_plsegr 21 ./pmio/tf/mioplr.x int procedure mio_plsegr (mp, ptr, mval, v, npix) +mio_plsegs 21 ./pmio/tf/miopls.x int procedure mio_plsegs (mp, ptr, mval, v, npix) +mio_plsegx 21 ./pmio/tf/mioplx.x int procedure mio_plsegx (mp, ptr, mval, v, npix) +mio_seti 8 ./pmio/mioseti.x procedure mio_seti (mp, param, value) +mio_setrange 9 ./pmio/miosrange.x procedure mio_setrange (mp, vs, ve, ndim) +mio_stati 8 ./pmio/miostati.x int procedure mio_stati (mp, param) +mktemp 1 ./libc/mktemp.c mktemp (template) +mktemp 17 ./fio/mktemp.x procedure mktemp (seed, temp_file, maxchars) +mp_getd 912 ./qpoe/zzdebug.x double procedure mp_getd (buf, boffset, dtype) +mp_geti 876 ./qpoe/zzdebug.x int procedure mp_geti (buf, boffset, dtype) +msvfwa 7 ./memdbg/msvfwa.x pointer procedure msvfwa (fwa, dtype, sz_align, fwa_align) +msvfwa 7 ./memio/msvfwa.x pointer procedure msvfwa (fwa, dtype, sz_align, fwa_align) +mt_clrcache 186 ./mtio/mtcache.x procedure mt_clrcache() +mt_devallocated 10 ./mtio/mtdevall.x int procedure mt_devallocated (iodev) +mt_examine 246 ./mtio/zzdebug.x int procedure mt_examine (out, mtfile) +mt_getpos 48 ./mtio/mtcache.x procedure mt_getpos (mtname, mt) +mt_glock 14 ./mtio/mtglock.x procedure mt_glock (mtname, lockfile, maxch) +mt_gtyopen 26 ./mtio/mtgtyopen.x pointer procedure mt_gtyopen (device, ufields) +mt_lockname 16 ./mtio/mtlocknam.x procedure mt_lockname (device, lockfile, maxch) +mt_putline 164 ./mtio/mtupdlock.x procedure mt_putline (fd, text) +mt_read_lockfile 11 ./mtio/mtrdlock.x procedure mt_read_lockfile (mtname, mt) +mt_savekeyword 144 ./mtio/mtupdlock.x procedure mt_savekeyword (fd, keyword, value) +mt_savepos 78 ./mtio/mtcache.x procedure mt_savepos (mt) +mt_skip_record 8 ./mtio/mtskip.x int procedure mt_skip_record (fd, nrecords) +mt_sync 133 ./mtio/mtcache.x procedure mt_sync (status) +mt_update_lockfile 14 ./mtio/mtupdlock.x procedure mt_update_lockfile (mt) +mtallocate 12 ./mtio/mtalloc.x procedure mtallocate (mtname) +mtcap 10 ./mtio/mtcap.x pointer procedure mtcap (mtname) +mtclean 20 ./mtio/mtclean.x procedure mtclean (level, stale, out) +mtdeallocate 11 ./mtio/mtdealloc.x procedure mtdeallocate (mtname, rewind_tape) +mtencode 7 ./mtio/mtencode.x procedure mtencode (outstr, maxch, device, fileno, recno, attrl) +mtfile 9 ./mtio/mtfile.x int procedure mtfile (fname) +mtfname 8 ./mtio/mtfname.x procedure mtfname (mtname, fileno, outstr, maxch) +mtneedfileno 8 ./mtio/mtneedf.x int procedure mtneedfileno (mtname) +mtop 6 ../unix/os/tape.c mtop (op, count) +mtopen 47 ./mtio/mtopen.x int procedure mtopen (mtname, acmode, bufsize) +mtparse 35 ./mtio/mtparse.x procedure mtparse (mtname, device, sz_device, file, record, attrl, sz_attrl) +mtposition 9 ./mtio/mtpos.x procedure mtposition (mtname, file, record) +mtrewind 13 ./mtio/mtrewind.x procedure mtrewind (mtname, initcache) +mtstatus 6 ./mtio/mtstatus.x procedure mtstatus (out, mtname) +mw_allocd 10 ./mwcs/mwallocd.x int procedure mw_allocd (mw, nelem) +mw_allocs 12 ./mwcs/mwallocs.x int procedure mw_allocs (mw, nchars) +mw_axtran 82 ./mwcs/mwtransd.x procedure mw_axtran (o_ltm,o_ltv, n_ltm,n_ltv, pdim, ltm,ltv, ax, ndim) +mw_c1tran 7 ./mwcs/mwc1tran.gx PIXEL procedure mw_c1tran$t (a_ct, x) +mw_c1trand 5 ./mwcs/gen/mwc1trand.x double procedure mw_c1trand (a_ct, x) +mw_c1tranr 5 ./mwcs/gen/mwc1tranr.x real procedure mw_c1tranr (a_ct, x) +mw_c2tran 7 ./mwcs/mwc2tran.gx procedure mw_c2tran$t (a_ct, x1,y1, x2,y2) +mw_c2trand 5 ./mwcs/gen/mwc2trand.x procedure mw_c2trand (a_ct, x1,y1, x2,y2) +mw_c2tranr 5 ./mwcs/gen/mwc2tranr.x procedure mw_c2tranr (a_ct, x1,y1, x2,y2) +mw_close 12 ./mwcs/mwclose.x procedure mw_close (mw) +mw_copyd 85 ./mwcs/mwnewcopy.x int procedure mw_copyd (mw, o_mw, o_off, nelem) +mw_copys 112 ./mwcs/mwnewcopy.x int procedure mw_copys (mw, o_mw, o_off) +mw_ctfree 10 ./mwcs/mwctfree.x procedure mw_ctfree (ct) +mw_ctran 8 ./mwcs/mwctran.gx procedure mw_ctran$t (a_ct, p1, p2, ndim) +mw_ctrand 6 ./mwcs/gen/mwctrand.x procedure mw_ctrand (a_ct, p1, p2, ndim) +mw_ctranr 6 ./mwcs/gen/mwctranr.x procedure mw_ctranr (a_ct, p1, p2, ndim) +mw_findsys 8 ./mwcs/mwfindsys.x pointer procedure mw_findsys (mw, system) +mw_flookup 10 ./mwcs/mwflookup.x int procedure mw_flookup (mw, fnname) +mw_gaxlist 9 ./mwcs/mwgaxlist.x procedure mw_gaxlist (mw, axbits, axis, naxes) +mw_gaxmap 11 ./mwcs/mwgaxmap.x procedure mw_gaxmap (mw, axno, axval, ndim) +mw_gctran 17 ./mwcs/mwgctran.gx int procedure mw_gctran$t (a_ct, o_ltm, o_ltv, axtype1, axtype2, maxdim) +mw_gctrand 17 ./mwcs/gen/mwgctrand.x int procedure mw_gctrand (a_ct, o_ltm, o_ltv, axtype1, axtype2, maxdim) +mw_gctranr 17 ./mwcs/gen/mwgctranr.x int procedure mw_gctranr (a_ct, o_ltm, o_ltv, axtype1, axtype2, maxdim) +mw_gltermd 8 ./mwcs/mwgltermd.x procedure mw_gltermd (mw, ltm, ltv, ndim) +mw_gltermr 8 ./mwcs/mwgltermr.x procedure mw_gltermr (mw, ltm, ltv, ndim) +mw_gsystem 7 ./mwcs/mwgsys.x procedure mw_gsystem (mw, outstr, maxch) +mw_gwattrs 10 ./mwcs/mwgwattrs.x procedure mw_gwattrs (mw, axis, attribute, valstr, maxch) +mw_gwsampd 8 ./mwcs/mwgwsampd.x procedure mw_gwsampd (mw, axis, pv, wv, npts) +mw_gwsampr 8 ./mwcs/mwgwsampr.x procedure mw_gwsampr (mw, axis, pv, wv, npts) +mw_gwtermd 10 ./mwcs/mwgwtermd.x procedure mw_gwtermd (mw, r, w, cd, ndim) +mw_gwtermr 10 ./mwcs/mwgwtermr.x procedure mw_gwtermr (mw, r, w, cd, ndim) +mw_invertd 6 ./mwcs/mwinvertd.x procedure mw_invertd (o_ltm, n_ltm, ndim) +mw_invertr 6 ./mwcs/mwinvertr.x procedure mw_invertr (o_ltm, n_ltm, ndim) +mw_load 13 ./mwcs/mwload.x procedure mw_load (mw, bp) +mw_loadim 12 ./mwcs/mwloadim.x procedure mw_loadim (mw, im) +mw_ltran 6 ./mwcs/mwltran.gx procedure mw_ltran$t (p1, p2, ltm, ltv, ndim) +mw_ltrand 4 ./mwcs/gen/mwltrand.x procedure mw_ltrand (p1, p2, ltm, ltv, ndim) +mw_ltranr 4 ./mwcs/gen/mwltranr.x procedure mw_ltranr (p1, p2, ltm, ltv, ndim) +mw_lubacksub 105 ./mwcs/mwlu.x procedure mw_lubacksub (a, ix, b, ndim) +mw_ludecompose 18 ./mwcs/mwlu.x procedure mw_ludecompose (a, ix, ndim) +mw_mkidmd 5 ./mwcs/mwmkidmd.x procedure mw_mkidmd (ltm, ndim) +mw_mkidmr 5 ./mwcs/mwmkidmr.x procedure mw_mkidmr (ltm, ndim) +mw_mmul 5 ./mwcs/mwmmul.gx procedure mw_mmul$t (a, b, c, ndim) +mw_mmuld 3 ./mwcs/gen/mwmmuld.x procedure mw_mmuld (a, b, c, ndim) +mw_mmulr 3 ./mwcs/gen/mwmmulr.x procedure mw_mmulr (a, b, c, ndim) +mw_newcopy 9 ./mwcs/mwnewcopy.x pointer procedure mw_newcopy (o_mw) +mw_newsystem 10 ./mwcs/mwnewsys.x procedure mw_newsystem (mw, system, ndim) +mw_open 11 ./mwcs/mwopen.x pointer procedure mw_open (bufptr, ndim) +mw_openim 9 ./mwcs/mwopenim.x pointer procedure mw_openim (im) +mw_refstr 11 ./mwcs/mwrefstr.x int procedure mw_refstr (mw, str) +mw_rotate 16 ./mwcs/mwrotate.x procedure mw_rotate (mw, theta, center, axbits) +mw_save 12 ./mwcs/mwsave.x int procedure mw_save (o_mw, bp, buflen) +mw_saveim 23 ./mwcs/mwsaveim.x procedure mw_saveim (mw, im) +mw_saxmap 12 ./mwcs/mwsaxmap.x procedure mw_saxmap (mw, axno, axval, ndim) +mw_scale 8 ./mwcs/mwscale.x procedure mw_scale (mw, scale, axbits) +mw_sctran 30 ./mwcs/mwsctran.x pointer procedure mw_sctran (mw, system1, system2, axbits) +mw_sdefwcs 10 ./mwcs/mwsdefwcs.x procedure mw_sdefwcs (mw) +mw_seti 9 ./mwcs/mwseti.x procedure mw_seti (mw, param, value) +mw_shift 8 ./mwcs/mwshift.x procedure mw_shift (mw, shift, axbits) +mw_show 8 ./mwcs/mwshow.x procedure mw_show (mw, fd, what) +mw_sltermd 9 ./mwcs/mwsltermd.x procedure mw_sltermd (mw, ltm, ltv, ndim) +mw_sltermr 13 ./mwcs/mwsltermr.x procedure mw_sltermr (mw, ltm, ltv, ndim) +mw_ssystem 8 ./mwcs/mwssys.x procedure mw_ssystem (mw, system) +mw_stati 10 ./mwcs/mwstati.x int procedure mw_stati (mw, param) +mw_swattrs 10 ./mwcs/mwswattrs.x procedure mw_swattrs (mw, axis, attribute, valstr) +mw_swsampd 8 ./mwcs/mwswsampd.x procedure mw_swsampd (mw, axis, pv, wv, npts) +mw_swsampr 8 ./mwcs/mwswsampr.x procedure mw_swsampr (mw, axis, pv, wv, npts) +mw_swtermd 10 ./mwcs/mwswtermd.x procedure mw_swtermd (mw, r, w, cd, ndim) +mw_swtermr 10 ./mwcs/mwswtermr.x procedure mw_swtermr (mw, r, w, cd, ndim) +mw_swtype 27 ./mwcs/mwswtype.x procedure mw_swtype (mw, axis, naxes, wtype, wattr) +mw_translated 19 ./mwcs/mwtransd.x procedure mw_translated (mw, ltv_1, ltm, ltv_2, ndim) +mw_translater 6 ./mwcs/mwtransr.x procedure mw_translater (mw, ltv_1, ltm, ltv_2, ndim) +mw_v1tran 7 ./mwcs/mwv1tran.gx procedure mw_v1tran$t (a_ct, x1, x2, npts) +mw_v1trand 5 ./mwcs/gen/mwv1trand.x procedure mw_v1trand (a_ct, x1, x2, npts) +mw_v1tranr 5 ./mwcs/gen/mwv1tranr.x procedure mw_v1tranr (a_ct, x1, x2, npts) +mw_v2tran 7 ./mwcs/mwv2tran.gx procedure mw_v2tran$t (a_ct, x1,y1, x2,y2, npts) +mw_v2trand 5 ./mwcs/gen/mwv2trand.x procedure mw_v2trand (a_ct, x1,y1, x2,y2, npts) +mw_v2tranr 5 ./mwcs/gen/mwv2tranr.x procedure mw_v2tranr (a_ct, x1,y1, x2,y2, npts) +mw_vmul 5 ./mwcs/mwvmul.gx procedure mw_vmul$t (a, b, c, ndim) +mw_vmuld 3 ./mwcs/gen/mwvmuld.x procedure mw_vmuld (a, b, c, ndim) +mw_vmulr 3 ./mwcs/gen/mwvmulr.x procedure mw_vmulr (a, b, c, ndim) +mw_vtran 6 ./mwcs/mwvtran.gx procedure mw_vtran$t (ct, v1, v2, ndim, npts) +mw_vtrand 4 ./mwcs/gen/mwvtrand.x procedure mw_vtrand (ct, v1, v2, ndim, npts) +mw_vtranr 4 ./mwcs/gen/mwvtranr.x procedure mw_vtranr (ct, v1, v2, ndim, npts) +napmsx 2 ../unix/os/zwmsec.c napmsx() +ncgchr 6 ./gio/nspp/sysint/ncgchr.x procedure ncgchr (ichars, len_ichars, index, char_value) +ncpchr 6 ./gio/nspp/sysint/ncpchr.x procedure ncpchr (ichars, len_ichars, index, char_value) +ndopen 52 ./fio/ndopen.x int procedure ndopen (fname, mode) +newpen 358 ./gio/calcomp/vttest.x procedure newpen (whichpen) +nextcmd 6 ../unix/os/tape.c nextcmd (in) +note 13 ./fio/note.x long procedure note (fd) +nowhite 8 ./fio/nowhite.x int procedure nowhite (in, out, maxch) +nscan 6 ./fmtio/nscan.x int procedure nscan() +oif_access 8 ./imio/iki/oif/oifaccess.x procedure oif_access (kernel, root, extn, acmode, status) +oif_close 13 ./imio/iki/oif/oifclose.x procedure oif_close (im, status) +oif_copy 8 ./imio/iki/oif/oifcopy.x procedure oif_copy (kernel, old_root, old_extn, new_root, new_extn, status) +oif_delete 10 ./imio/iki/oif/oifdelete.x procedure oif_delete (kernel, root, extn, status) +oif_gpixfname 8 ./imio/iki/oif/oifgpfn.x procedure oif_gpixfname (pixfile, hdrfile, path, maxch) +oif_mkpixfname 13 ./imio/iki/oif/oifmkpfn.x procedure oif_mkpixfname (im, pixfile, maxch) +oif_open 12 ./imio/iki/oif/oifopen.x procedure oif_open (kernel, im, o_im, root, extn, ksection, cl_index, cl_size, acmode, status) +oif_opix 24 ./imio/iki/oif/oifopix.x procedure oif_opix (im, status) +oif_rdhdr 14 ./imio/iki/oif/oifrdhdr.x int procedure oif_rdhdr (fd, im, uchars, htype) +oif_rename 11 ./imio/iki/oif/oifrename.x procedure oif_rename (kernel, old_root, old_extn, new_root, new_extn, status) +oif_trim 219 ./imio/iki/oif/oifwrhdr.x procedure oif_trim (s, nchars) +oif_trim 245 ./imfort/imwrhdr.x procedure oif_trim (s, nchars) +oif_updhdr 11 ./imio/iki/oif/oifupdhdr.x procedure oif_updhdr (im, status) +oif_wrhdr 13 ./imio/iki/oif/oifwrhdr.x procedure oif_wrhdr (fd, im, htype) +onentry 29 ./etc/onentry.x int procedure onentry (prtype, bkgfile, cmd) +onentry 61 ./ki/irafks.x int procedure onentry (prtype, bkgfile, cmd) +onerror 12 ./etc/onerror.x procedure onerror (user_proc) +onerror_remove 52 ./etc/onerror.x procedure onerror_remove (user_proc) +onexit 10 ./etc/onexit.x procedure onexit (user_proc) +onexit_remote 49 ./etc/onexit.x procedure onexit_remote (user_proc) +onint 2 ./libc/zztest.c onint (code, old_handler) +onint 1228 ./plio/zzdebug.x procedure onint (signal, next_handler) +open 11 ./fio/open.x int procedure open (fname, mode, type) +oscmd 13 ./etc/oscmd.x int procedure oscmd (cmd, infile, outfile, errfile) +osfn_initlock 273 ./fio/osfnlock.x procedure osfn_initlock (osfn) +osfn_lock 63 ./fio/osfnlock.x long procedure osfn_lock (osfn) +osfn_mkfnames 307 ./fio/osfnlock.x procedure osfn_mkfnames (osfn, lockfile, timelock1, timelock2, maxch) +osfn_pkfname 357 ./fio/osfnlock.x procedure osfn_pkfname (spp_osfn, host_osfn, maxch) +osfn_rmlock 240 ./fio/osfnlock.x procedure osfn_rmlock (osfn) +osfn_timeleft 155 ./fio/osfnlock.x int procedure osfn_timeleft (osfn, time) +osfn_unlock 204 ./fio/osfnlock.x int procedure osfn_unlock (osfn, time) +output 8 ../unix/os/tape.c output (text) +packum 11 ./gio/nspp/sysint/packum.x procedure packum (a, npix, bp) +pagefile 93 ./etc/pagefiles.x procedure pagefile (fname, prompt) +pagefiles 69 ./etc/pagefiles.x procedure pagefiles (files) +pargb 7 ./fmtio/pargb.x procedure pargb (bval) +pargc 32 ./fmtio/parg.x procedure pargc (cval) +pargd 21 ./fmtio/parg.x procedure pargd (dval) +pargg 110 ./fmtio/parg.x procedure pargg (value, dtype) +pargi 61 ./fmtio/parg.x procedure pargi (ival) +pargl 77 ./fmtio/parg.x procedure pargl (lval) +pargr 93 ./fmtio/parg.x procedure pargr (rval) +pargs 45 ./fmtio/parg.x procedure pargs (sval) +pargstr 7 ./fmtio/pargstr.x procedure pargstr (str) +pargx 11 ./fmtio/pargx.x procedure pargx (xval) +parse_args 1250 ./plio/zzdebug.x procedure parse_args (args, ip) +parse_args 999 ./pmio/zzinterp.x procedure parse_args (args, ip) +pat_amatch 125 ./fmtio/patmatch.x int procedure pat_amatch (str, from, pat) +pat_filset 514 ./fmtio/patmatch.x procedure pat_filset (delim, patstr, ip, patbuf, sz_pat, op) +pat_getccl 448 ./fmtio/patmatch.x int procedure pat_getccl (patstr, patbuf, sz_pat, ip, op) +pat_gsize 169 ./fmtio/patmatch.x int procedure pat_gsize (pat, n) +pat_locate 277 ./fmtio/patmatch.x int procedure pat_locate (ch, pat, offset) +pat_omatch 196 ./fmtio/patmatch.x int procedure pat_omatch (str, ip, pat, pp) +pat_stclos 480 ./fmtio/patmatch.x int procedure pat_stclos (patbuf, sz_pat, op, last_op, last_closure) +patindex 101 ./fmtio/patmatch.x int procedure patindex (pat, n) +patmake 299 ./fmtio/patmatch.x int procedure patmake (str, pat, sz_pat) +patmatch 46 ./fmtio/patmatch.x int procedure patmatch (str, pat) +perror 1 ./libc/perror.c perror (prefix) +perror 5 ./gio/nspp/sysint/perror.x procedure perror() +pg_getcmd 1009 ./etc/pagefiles.x int procedure pg_getcmd (tty, fname, nchars, totchars, lineno, fileno, nfiles) +pg_getline 979 ./etc/pagefiles.x int procedure pg_getline (fd, lbuf) +pg_getstr 1093 ./etc/pagefiles.x procedure pg_getstr (strval, maxch) +pg_pagefile 237 ./etc/pagefiles.x int procedure pg_pagefile (tty, fname, newfname, u_prompt, clear_screen, +pg_peekcmd 1129 ./etc/pagefiles.x int procedure pg_peekcmd() +pg_pushcmd 1109 ./etc/pagefiles.x procedure pg_pushcmd (cmd) +pg_setprompt 962 ./etc/pagefiles.x procedure pg_setprompt (prompt, u_prompt, fname) +phelp 8 ../unix/os/tape.c phelp() +pl_access 11 ./plio/placcess.x int procedure pl_access (pl, v) +pl_alloc 9 ./plio/plalloc.x int procedure pl_alloc (pl, nwords) +pl_asciidump 10 ./plio/plascii.x procedure pl_asciidump (pl, vs, ve, outfd) +pl_box 18 ./plio/plbox.x procedure pl_box (pl, x1,y1, x2,y2, rop) +pl_chkfree 8 ./plio/zzlib.x procedure pl_chkfree (pl, msg) +pl_circle 20 ./plio/plcircle.x procedure pl_circle (pl, x, y, radius, rop) +pl_clear 9 ./plio/plclear.x procedure pl_clear (pl) +pl_close 10 ./plio/plclose.x procedure pl_close (pl) +pl_compare 10 ./plio/plcompare.x int procedure pl_compare (pl_1, pl_2, outfd) +pl_compress 10 ./plio/plcmpress.x procedure pl_compress (pl) +pl_create 7 ./plio/plcreate.x pointer procedure pl_create (naxes, axlen, depth) +pl_debug 17 ./plio/pldebug.x procedure pl_debug (pl, fd, width, what) +pl_debugout 7 ./plio/pldbgout.x procedure pl_debugout (fd, buf, col, firstcol, maxcol) +pl_empty 7 ./plio/plempty.x bool procedure pl_empty (pl) +pl_getplane 8 ./plio/plgplane.x procedure pl_getplane (pl, v) +pl_glls 8 ./plio/plglls.x procedure pl_glls (pl, v, ll_dst, ll_depth, npix, rop) +pl_glp 8 ./plio/plglp.gx procedure pl_glp$t (pl, v, px_dst, px_depth, npix, rop) +pl_glpi 8 ./plio/tf/plglpi.x procedure pl_glpi (pl, v, px_dst, px_depth, npix, rop) +pl_glpl 8 ./plio/tf/plglpl.x procedure pl_glpl (pl, v, px_dst, px_depth, npix, rop) +pl_glps 8 ./plio/tf/plglps.x procedure pl_glps (pl, v, px_dst, px_depth, npix, rop) +pl_glr 9 ./plio/plglr.gx procedure pl_glr$t (pl, v, rl_dst, rl_depth, npix, rop) +pl_glri 9 ./plio/tf/plglri.x procedure pl_glri (pl, v, rl_dst, rl_depth, npix, rop) +pl_glrl 9 ./plio/tf/plglrl.x procedure pl_glrl (pl, v, rl_dst, rl_depth, npix, rop) +pl_glrs 9 ./plio/tf/plglrs.x procedure pl_glrs (pl, v, rl_dst, rl_depth, npix, rop) +pl_gsize 8 ./plio/plgsize.x procedure pl_gsize (pl, naxes, axlen, depth) +pl_l2p 8 ./plio/pll2p.gx int procedure pl_l2p$t (ll_src, xs, px_dst, npix) +pl_l2pi 8 ./plio/tf/pll2pi.x int procedure pl_l2pi (ll_src, xs, px_dst, npix) +pl_l2pl 8 ./plio/tf/pll2pl.x int procedure pl_l2pl (ll_src, xs, px_dst, npix) +pl_l2ps 8 ./plio/tf/pll2ps.x int procedure pl_l2ps (ll_src, xs, px_dst, npix) +pl_l2r 9 ./plio/pll2r.gx int procedure pl_l2r$t (ll_src, xs, rl, npix) +pl_l2ri 9 ./plio/tf/pll2ri.x int procedure pl_l2ri (ll_src, xs, rl, npix) +pl_l2rl 9 ./plio/tf/pll2rl.x int procedure pl_l2rl (ll_src, xs, rl, npix) +pl_l2rs 9 ./plio/tf/pll2rs.x int procedure pl_l2rs (ll_src, xs, rl, npix) +pl_line 12 ./plio/plline.x procedure pl_line (pl, x1, y1, x2, y2, width, rop) +pl_linenotempty 8 ./plio/pllinene.x bool procedure pl_linenotempty (pl, v) +pl_linerop 13 ./plio/pllrop.x procedure pl_linerop (ll_src, xs, src_maxval, +pl_linestencil 12 ./plio/pllsten.x procedure pl_linestencil (ll_src,xs,src_maxval, ll_dst,ds,dst_maxval, +pl_load 12 ./plio/plload.x procedure pl_load (pl, bp) +pl_loadf 11 ./plio/plloadf.x procedure pl_loadf (pl, mask, title, maxch) +pl_loadim 10 ./plio/plloadim.x procedure pl_loadim (pl, imname) +pl_newcopy 9 ./plio/plnewcopy.x pointer procedure pl_newcopy (old_pl) +pl_open 10 ./plio/plopen.x pointer procedure pl_open (smp) +pl_p2l 8 ./plio/plp2l.gx int procedure pl_p2l$t (px_src, xs, ll_dst, npix) +pl_p2li 8 ./plio/tf/plp2li.x int procedure pl_p2li (px_src, xs, ll_dst, npix) +pl_p2ll 8 ./plio/tf/plp2ll.x int procedure pl_p2ll (px_src, xs, ll_dst, npix) +pl_p2ls 8 ./plio/tf/plp2ls.x int procedure pl_p2ls (px_src, xs, ll_dst, npix) +pl_p2r 9 ./plio/plp2r.gx int procedure pl_p2r$t (px_src, xs, rl, npix) +pl_p2ri 9 ./plio/tf/plp2ri.x int procedure pl_p2ri (px_src, xs, rl, npix) +pl_p2rl 9 ./plio/tf/plp2rl.x int procedure pl_p2rl (px_src, xs, rl, npix) +pl_p2rs 9 ./plio/tf/plp2rs.x int procedure pl_p2rs (px_src, xs, rl, npix) +pl_pixrop 8 ./plio/plprop.gx procedure pl_pixrop$t (px_src,xs,src_maxval, px_dst,ds,dst_maxval, npix, rop) +pl_pixrop 8 ./pmio/plprop.gx procedure pl_pixrop$t (px_src,xs,src_maxval, px_dst,ds,dst_maxval, npix, rop) +pl_pixropi 8 ./plio/tf/plpropi.x procedure pl_pixropi (px_src,xs,src_maxval, px_dst,ds,dst_maxval, npix, rop) +pl_pixropl 8 ./plio/tf/plpropl.x procedure pl_pixropl (px_src,xs,src_maxval, px_dst,ds,dst_maxval, npix, rop) +pl_pixrops 8 ./plio/tf/plprops.x procedure pl_pixrops (px_src,xs,src_maxval, px_dst,ds,dst_maxval, npix, rop) +pl_plls 8 ./plio/plplls.x procedure pl_plls (pl, v, ll_src, ll_depth, npix, rop) +pl_plp 8 ./plio/plplp.gx procedure pl_plp$t (pl, v, px_src, px_depth, npix, rop) +pl_plpi 8 ./plio/tf/plplpi.x procedure pl_plpi (pl, v, px_src, px_depth, npix, rop) +pl_plpl 8 ./plio/tf/plplpl.x procedure pl_plpl (pl, v, px_src, px_depth, npix, rop) +pl_plps 8 ./plio/tf/plplps.x procedure pl_plps (pl, v, px_src, px_depth, npix, rop) +pl_plr 8 ./plio/plplr.gx procedure pl_plr$t (pl, v, rl_src, rl_depth, npix, rop) +pl_plri 8 ./plio/tf/plplri.x procedure pl_plri (pl, v, rl_src, rl_depth, npix, rop) +pl_plrl 8 ./plio/tf/plplrl.x procedure pl_plrl (pl, v, rl_src, rl_depth, npix, rop) +pl_plrs 8 ./plio/tf/plplrs.x procedure pl_plrs (pl, v, rl_src, rl_depth, npix, rop) +pl_point 11 ./plio/plpoint.x procedure pl_point (pl, x, y, rop) +pl_polygon 26 ./plio/plpolygon.x procedure pl_polygon (pl, x, y, npts, rop) +pl_r2l 9 ./plio/plr2l.gx int procedure pl_r2l$t (rl_src, xs, ll_dst, npix) +pl_r2li 9 ./plio/tf/plr2li.x int procedure pl_r2li (rl_src, xs, ll_dst, npix) +pl_r2ll 9 ./plio/tf/plr2ll.x int procedure pl_r2ll (rl_src, xs, ll_dst, npix) +pl_r2ls 9 ./plio/tf/plr2ls.x int procedure pl_r2ls (rl_src, xs, ll_dst, npix) +pl_r2p 9 ./plio/plr2p.gx int procedure pl_r2p$t (rl_src, xs, px_dst, npix) +pl_r2pi 9 ./plio/tf/plr2pi.x int procedure pl_r2pi (rl_src, xs, px_dst, npix) +pl_r2pl 9 ./plio/tf/plr2pl.x int procedure pl_r2pl (rl_src, xs, px_dst, npix) +pl_r2ps 9 ./plio/tf/plr2ps.x int procedure pl_r2ps (rl_src, xs, px_dst, npix) +pl_rangerop 13 ./plio/plrrop.gx procedure pl_rangerop$t (rl_src, xs, src_maxval, +pl_rangeropi 13 ./plio/tf/plrropi.x procedure pl_rangeropi (rl_src, xs, src_maxval, +pl_rangeropl 13 ./plio/tf/plrropl.x procedure pl_rangeropl (rl_src, xs, src_maxval, +pl_rangerops 13 ./plio/tf/plrrops.x procedure pl_rangerops (rl_src, xs, src_maxval, +pl_regionrop 24 ./plio/plregrop.x procedure pl_regionrop (pl, ufcn, ufd, y1, y2, rop) +pl_rop 20 ./plio/plrop.x procedure pl_rop (pl_src, vs_src, pl_dst, vs_dst, vn, rop) +pl_save 18 ./plio/plsave.x int procedure pl_save (pl, bp, buflen, flags) +pl_savef 10 ./plio/plsavef.x procedure pl_savef (pl, fname, title, flags) +pl_saveim 11 ./plio/plsaveim.x procedure pl_saveim (pl, imname, flags) +pl_sectnotconst 11 ./plio/plsectnc.x bool procedure pl_sectnotconst (pl_src, v1, v2, ndim, mval) +pl_sectnotempty 9 ./plio/plsectne.x bool procedure pl_sectnotempty (pl_src, v1, v2, ndim) +pl_seti 8 ./plio/plseti.x procedure pl_seti (pl, param, value) +pl_setplane 8 ./plio/plsplane.x procedure pl_setplane (pl, v) +pl_ssize 9 ./plio/plssize.x procedure pl_ssize (pl, naxes, axlen, depth) +pl_stati 8 ./plio/plstati.x int procedure pl_stati (pl, param) +pl_stencil 11 ./plio/plsten.x procedure pl_stencil (pl_src, vs_src, pl_dst, vs_dst, pl_stn, vs_stn, vn, rop) +pl_ubox 48 ./plio/plbox.x bool procedure pl_ubox (ufd, y, rl_reg, xs, npix) +pl_ucircle 54 ./plio/plcircle.x bool procedure pl_ucircle (ufd, y, rl_reg, xs, npix) +pl_update 36 ./plio/plupdate.x procedure pl_update (pl, v, ll) +pl_upolygon 90 ./plio/plpolygon.x bool procedure pl_upolygon (ufd, line, rl_reg, xs, npix) +plf_access 8 ./imio/iki/plf/plfaccess.x procedure plf_access (kernel, root, extn, acmode, status) +plf_close 9 ./imio/iki/plf/plfclose.x procedure plf_close (im, status) +plf_copy 9 ./imio/iki/plf/plfcopy.x procedure plf_copy (kernel, old_root, old_extn, new_root, new_extn, status) +plf_delete 7 ./imio/iki/plf/plfdelete.x procedure plf_delete (kernel, root, extn, status) +plf_null 5 ./imio/iki/plf/plfnull.x procedure plf_null() +plf_open 12 ./imio/iki/plf/plfopen.x procedure plf_open (kernel, im, o_im, +plf_rename 8 ./imio/iki/plf/plfrename.x procedure plf_rename (kernel, old_root, old_extn, new_root, new_extn, status) +plf_updhdr 9 ./imio/iki/plf/plfupdhdr.x procedure plf_updhdr (im, status) +pll_const 75 ./plio/plsectnc.x bool procedure pll_const (ll_src, xs, npix, mval) +pll_empty 60 ./plio/plsectne.x bool procedure pll_empty (ll_src, xs, npix) +pll_equal 7 ./plio/plleq.x bool procedure pll_equal (l1, l2) +pll_nextseg 9 ./plio/pllnext.x procedure pll_nextseg (ll, ld) +pll_prints 7 ./plio/pllpr.x procedure pll_prints (ll, fd, label, firstcol, maxcols) +plloop 9 ./plio/plloop.x int procedure plloop (v, vs, ve, ndim) +plot 326 ./gio/calcomp/vttest.x procedure plot (x, y, pencode) +plot1 12 ./gio/zzdebug.x procedure plot1() +plot2 39 ./gio/zzdebug.x procedure plot2() +plot3 85 ./gio/zzdebug.x procedure plot3() +plot4 118 ./gio/zzdebug.x procedure plot4() +plot5 151 ./gio/zzdebug.x procedure plot5() +plot6 180 ./gio/zzdebug.x procedure plot6() +plot7 209 ./gio/zzdebug.x procedure plot7() +plot8 336 ./gio/zzdebug.x procedure plot8() +plots 347 ./gio/calcomp/vttest.x procedure plots (dum1, dum2, ldev) +plr_close 342 ./plio/plrio.x procedure plr_close (plr) +plr_equal 7 ./plio/plreq.gx bool procedure plr_equal$t (r1, r2) +plr_equali 7 ./plio/tf/plreqi.x bool procedure plr_equali (r1, r2) +plr_equall 7 ./plio/tf/plreql.x bool procedure plr_equall (r1, r2) +plr_equals 7 ./plio/tf/plreqs.x bool procedure plr_equals (r1, r2) +plr_getlut 295 ./plio/plrio.x procedure plr_getlut (plr, bufp, xsize,ysize, xblock,yblock) +plr_getpix 249 ./plio/plrio.x int procedure plr_getpix (plr, i, j) +plr_open 69 ./plio/plrio.x pointer procedure plr_open (pl, plane, buflimit) +plr_print 8 ./plio/plrpr.gx procedure plr_print$t (rl, fd, label, firstcol, maxcol) +plr_printi 8 ./plio/tf/plrpri.x procedure plr_printi (rl, fd, label, firstcol, maxcol) +plr_printl 8 ./plio/tf/plrprl.x procedure plr_printl (rl, fd, label, firstcol, maxcol) +plr_prints 8 ./plio/tf/plrprs.x procedure plr_prints (rl, fd, label, firstcol, maxcol) +plr_setrect 313 ./plio/plrio.x procedure plr_setrect (plr, x1,y1, x2,y2) +plsslv 10 ./plio/plsslv.x procedure plsslv (pl, vs, vn, v, ve) +plterm 177 ./mwcs/zzdebug.x procedure plterm (mw, ltm, ltv, ndim) +plvalid 8 ./plio/plvalid.x procedure plvalid (pl) +pm_access 10 ./pmio/pmaccess.x int procedure pm_access (pl, v) +pm_asciidump 10 ./pmio/pmascii.x procedure pm_asciidump (pl, vs, ve, outfd) +pm_box 10 ./pmio/pmbox.x procedure pm_box (pl, x1,y1, x2,y2, rop) +pm_circle 13 ./pmio/pmcircle.x procedure pm_circle (pl, x, y, radius, rop) +pm_clear 11 ./pmio/pmclear.x procedure pm_clear (pl) +pm_empty 9 ./pmio/pmempty.x bool procedure pm_empty (pl) +pm_glls 10 ./pmio/pmglls.x procedure pm_glls (pl, v, ll_dst, ll_depth, npix, rop) +pm_glp 9 ./pmio/pmglp.gx procedure pm_glp$t (pl, v, px_dst, px_depth, npix, rop) +pm_glpi 9 ./pmio/tf/pmglpi.x procedure pm_glpi (pl, v, px_dst, px_depth, npix, rop) +pm_glpl 9 ./pmio/tf/pmglpl.x procedure pm_glpl (pl, v, px_dst, px_depth, npix, rop) +pm_glps 9 ./pmio/tf/pmglps.x procedure pm_glps (pl, v, px_dst, px_depth, npix, rop) +pm_glr 13 ./pmio/pmglr.gx procedure pm_glr$t (pl, v, rl_dst, rl_depth, npix, rop) +pm_glri 13 ./pmio/tf/pmglri.x procedure pm_glri (pl, v, rl_dst, rl_depth, npix, rop) +pm_glrl 13 ./pmio/tf/pmglrl.x procedure pm_glrl (pl, v, rl_dst, rl_depth, npix, rop) +pm_glrs 13 ./pmio/tf/pmglrs.x procedure pm_glrs (pl, v, rl_dst, rl_depth, npix, rop) +pm_line 11 ./pmio/pmline.x procedure pm_line (pl, x1, y1, x2, y2, width, rop) +pm_linenotempty 9 ./pmio/pmlinene.x bool procedure pm_linenotempty (pl, v) +pm_newmask 11 ./pmio/pmnewmask.x pointer procedure pm_newmask (ref_im, depth) +pm_plls 9 ./pmio/pmplls.x procedure pm_plls (pl, v, ll_raw, ll_depth, npix, rop) +pm_plp 9 ./pmio/pmplp.gx procedure pm_plp$t (pl, v, px_src, px_depth, npix, rop) +pm_plpi 9 ./pmio/tf/pmplpi.x procedure pm_plpi (pl, v, px_src, px_depth, npix, rop) +pm_plpl 9 ./pmio/tf/pmplpl.x procedure pm_plpl (pl, v, px_src, px_depth, npix, rop) +pm_plps 9 ./pmio/tf/pmplps.x procedure pm_plps (pl, v, px_src, px_depth, npix, rop) +pm_plr 9 ./pmio/pmplr.gx procedure pm_plr$t (pl, v, rl_src, rl_depth, npix, rop) +pm_plri 9 ./pmio/tf/pmplri.x procedure pm_plri (pl, v, rl_src, rl_depth, npix, rop) +pm_plrl 9 ./pmio/tf/pmplrl.x procedure pm_plrl (pl, v, rl_src, rl_depth, npix, rop) +pm_plrs 9 ./pmio/tf/pmplrs.x procedure pm_plrs (pl, v, rl_src, rl_depth, npix, rop) +pm_point 11 ./pmio/pmpoint.x procedure pm_point (pl, x, y, rop) +pm_polygon 11 ./pmio/pmpolygon.x procedure pm_polygon (pl, x, y, npts, rop) +pm_rop 20 ./pmio/pmrop.x procedure pm_rop (pm_src, vs_src, pm_dst, vs_dst, vn, rop) +pm_sectnotconst 10 ./pmio/pmsectnc.x bool procedure pm_sectnotconst (pl, vs, ve, ndim, mval) +pm_sectnotempty 8 ./pmio/pmsectne.x bool procedure pm_sectnotempty (pl, vs, ve, ndim) +pm_seti 9 ./pmio/pmseti.x procedure pm_seti (pl, param, value) +pm_setplane 9 ./pmio/pmsplane.x procedure pm_setplane (pl, v) +pm_stencil 11 ./pmio/pmsten.x procedure pm_stencil (pm_src, vs_src, pm_dst, vs_dst, pm_stn, vs_stn, vn, rop) +pmr_close 122 ./pmio/pmrio.x procedure pmr_close (pmr) +pmr_getpix 71 ./pmio/pmrio.x int procedure pmr_getpix (pmr, i, j) +pmr_open 49 ./pmio/pmrio.x pointer procedure pmr_open (pl, plane, buflimit) +pmr_setrect 94 ./pmio/pmrio.x procedure pmr_setrect (pmr, x1,y1, x2,y2) +pow2 179 ./gio/nsppkern/gktinit.x int procedure pow2 (num) +pr_dummy_open 116 ./etc/propcpr.x procedure pr_dummy_open (osfn, mode, chan) +pr_enter 1 ../unix/os/prwait.c pr_enter (pid, inchan, outchan) +pr_findpid 3 ../unix/os/prwait.c pr_findpid (pid) +pr_findproc 8 ./etc/prfindpr.x int procedure pr_findproc (pid) +pr_getipc 2 ../unix/os/prwait.c pr_getipc (pid, inchan, outchan) +pr_getredir 7 ./etc/prgredir.x int procedure pr_getredir (pid, stream) +pr_onint 3 ../unix/os/zoscmd.c pr_onint (usig, hwcode, scp) +pr_onipc 171 ./etc/propcpr.x procedure pr_onipc (vex, next_handler) +pr_psio 45 ./etc/prpsio.x int procedure pr_psio (pid, fd, rwflag) +pr_release 3 ../unix/os/prwait.c pr_release (pid) +pr_wait 1 ../unix/os/prwait.c pr_wait (pid) +pr_zclspr 140 ./etc/propcpr.x procedure pr_zclspr (chan, status) +prchdir 6 ./etc/prchdir.x procedure prchdir (pid, newdir) +prclcpr 12 ./etc/prclcpr.x int procedure prclcpr (pid) +prcldpr 16 ./etc/prcldpr.x int procedure prcldpr (job) +prclose 14 ./etc/prclose.x int procedure prclose (pid) +prdone 12 ./etc/prdone.x int procedure prdone (job) +preal 3 ./gio/ncarutil/tests/preal.x procedure preal (tval, rval) +prenvfree 7 ./etc/prenvfree.x int procedure prenvfree (pid, marker) +prenvset 6 ./etc/prenvset.x procedure prenvset (pid, envvar, valuestr) +prfilbuf 11 ./etc/prfilbuf.x int procedure prfilbuf (fd) +prgetline 19 ./etc/prgline.x int procedure prgetline (fd, lbuf) +print_help 1095 ./pmio/zzinterp.x procedure print_help (fd) +print_help 1347 ./plio/zzdebug.x procedure print_help (fd) +printf 1 ./libc/printf.c printf (va_alist) +printf 7 ./fmtio/printf.x procedure printf (format_string) +prkill 15 ./etc/prkill.x procedure prkill (job) +prompt 7 ../unix/os/tape.c prompt() +propcpr 17 ./etc/propcpr.x int procedure propcpr (process, in, out) +propdpr 16 ./etc/propdpr.x int procedure propdpr (process, bkgfile, bkgmsg) +propen 18 ./etc/propen.x int procedure propen (process, in, out) +proscmd 8 ./etc/proscmd.x procedure proscmd (pr, cmd) +protect 13 ./fio/protect.x int procedure protect (fname, action) +prpsinit 6 ./gio/cursor/prpsinit.x procedure prpsinit() +prpsload 11 ./etc/prpsload.x procedure prpsload (giotr, control, gflush, writep, readtty, writetty) +prredir 15 ./etc/prredir.x procedure prredir (pid, stream, new_fd) +prseti 9 ./etc/prseti.x procedure prseti (pid, param, value) +prsignal 10 ./etc/prsignal.x procedure prsignal (pid, signal) +prstati 9 ./etc/prstati.x int procedure prstati (pid, param) +prupdate 14 ./etc/prupdate.x procedure prupdate (pid, message, flushout) +prv_reset 26 ./etc/prenvfree.x procedure prv_reset (name, value) +psio_isxmit 19 ./etc/psioisxt.x int procedure psio_isxmit (lbuf, pseudofile, nchars) +psio_xfer 11 ./etc/psioxfer.x procedure psio_xfer (fd, buf, nchars) +pstatus 7 ../unix/os/tape.c pstatus() +pstr 7 ./gio/ncarutil/autograph/pstr.x procedure pstr (spp_string) +psym 240 ./symtab/zzdebug.x procedure psym (stp, sym) +putc 8 ./fio/putc.x procedure putc (fd, ch) +putcc 10 ./fio/putcc.x procedure putcc (fd, ch) +putchar 32 ./fio/putc.x procedure putchar (ch) +putci 8 ./fio/putci.x procedure putci (fd, ch) +putline 14 ./fio/putline.x procedure putline (fd, linebuf) +puts 1 ./libc/puts.c puts (str) +putw 1 ./libc/putw.c putw (word, fp) +qm_access 134 ./qpoe/qpmacro.x pointer procedure qm_access() +qm_getc 726 ./qpoe/qpmacro.x int procedure qm_getc (fd, ch) +qm_scan 313 ./qpoe/qpmacro.x procedure qm_scan (qm, fname, flags) +qm_scano 357 ./qpoe/qpmacro.x procedure qm_scano (qm, fd, flags) +qm_setdefaults 612 ./qpoe/qpmacro.x procedure qm_setdefaults (qm, qp) +qm_setpar 659 ./qpoe/qpmacro.x int procedure qm_setpar (userval, defval) +qm_setparam 520 ./qpoe/qpmacro.x procedure qm_setparam (qm, param, valstr) +qm_symtab 301 ./qpoe/qpmacro.x pointer procedure qm_symtab (qm) +qm_upddefaults 678 ./qpoe/qpmacro.x procedure qm_upddefaults (qm, qp) +qp_access 8 ./qpoe/qpaccess.x int procedure qp_access (poefile, mode) +qp_accessf 9 ./qpoe/qpaccessf.x int procedure qp_accessf (qp, param) +qp_add 11 ./qpoe/qpadd.gx procedure qp_add$t (qp, param, value, comment) +qp_addb 11 ./qpoe/gen/qpaddb.x procedure qp_addb (qp, param, value, comment) +qp_addc 11 ./qpoe/gen/qpaddc.x procedure qp_addc (qp, param, value, comment) +qp_addd 11 ./qpoe/gen/qpaddd.x procedure qp_addd (qp, param, value, comment) +qp_addf 13 ./qpoe/qpaddf.x procedure qp_addf (qp, param, datatype, maxelem, comment, flags) +qp_addi 11 ./qpoe/gen/qpaddi.x procedure qp_addi (qp, param, value, comment) +qp_addl 11 ./qpoe/gen/qpaddl.x procedure qp_addl (qp, param, value, comment) +qp_addr 11 ./qpoe/gen/qpaddr.x procedure qp_addr (qp, param, value, comment) +qp_adds 11 ./qpoe/gen/qpadds.x procedure qp_adds (qp, param, value, comment) +qp_addx 11 ./qpoe/gen/qpaddx.x procedure qp_addx (qp, param, value, comment) +qp_arglist 621 ./qpoe/qpgettok.x int procedure qp_arglist (gt, argbuf, maxch) +qp_astr 12 ./qpoe/qpastr.x procedure qp_astr (qp, param, value, comment) +qp_bind 9 ./qpoe/qpbind.x procedure qp_bind (qp) +qp_cfnl 232 ./qpoe/qpgnfn.x procedure qp_cfnl (fl) +qp_close 7 ./qpoe/qpclose.x procedure qp_close (qp) +qp_closetext 584 ./qpoe/qpgettok.x procedure qp_closetext (gt) +qp_copy 9 ./qpoe/qpcopy.x procedure qp_copy (o_poefile, n_poefile) +qp_copyf 11 ./qpoe/qpcopyf.x procedure qp_copyf (o_qp, o_param, n_qp, n_param) +qp_ctod 9 ./qpoe/qpctod.x int procedure qp_ctod (str, ip, dval) +qp_ctoi 12 ./qpoe/qpctoi.x int procedure qp_ctoi (str, ip, ival) +qp_delete 7 ./qpoe/qpdelete.x procedure qp_delete (poefile) +qp_deletef 10 ./qpoe/qpdeletef.x procedure qp_deletef (qp, param) +qp_dsym 7 ./qpoe/qpdsym.x procedure qp_dsym (qp, out) +qp_dtype 13 ./qpoe/qpdtype.x int procedure qp_dtype (qp, datatype, dsym) +qp_elementsize 7 ./qpoe/qpelsize.x int procedure qp_elementsize (qp, datatype, reftype) +qp_expandtext 11 ./qpoe/qpexpand.x int procedure qp_expandtext (qp, s1, s2, maxch) +qp_flushpar 109 ./qpoe/qpppar.x procedure qp_flushpar (qp) +qp_get 11 ./qpoe/qpget.gx PIXEL procedure qp_get$t (qp, param) +qp_getb 9 ./qpoe/qpgetb.x bool procedure qp_getb (qp, param) +qp_getc 11 ./qpoe/gen/qpgetc.x char procedure qp_getc (qp, param) +qp_getd 11 ./qpoe/gen/qpgetd.x double procedure qp_getd (qp, param) +qp_geti 11 ./qpoe/gen/qpgeti.x int procedure qp_geti (qp, param) +qp_getl 11 ./qpoe/gen/qpgetl.x long procedure qp_getl (qp, param) +qp_getparam 14 ./qpoe/qpgpar.x int procedure qp_getparam (qp, param, o_pp) +qp_getr 11 ./qpoe/gen/qpgetr.x real procedure qp_getr (qp, param) +qp_gets 11 ./qpoe/gen/qpgets.x short procedure qp_gets (qp, param) +qp_gettok 122 ./qpoe/qpgettok.x int procedure qp_gettok (gt, tokbuf, maxch) +qp_getx 9 ./qpoe/qpgetx.x complex procedure qp_getx (qp, param) +qp_gmsym 14 ./qpoe/qpgmsym.x pointer procedure qp_gmsym (qp, macro, textp) +qp_gnfn 178 ./qpoe/qpgnfn.x int procedure qp_gnfn (fl, outstr, maxch) +qp_gpsym 13 ./qpoe/qpgpsym.x pointer procedure qp_gpsym (qp, param) +qp_gstr 8 ./qpoe/qpgstr.x int procedure qp_gstr (qp, param, outstr, maxch) +qp_inherit 9 ./qpoe/qpinherit.x procedure qp_inherit (n_qp, o_qp, out) +qp_lenf 9 ./qpoe/qplenf.x int procedure qp_lenf (qp, param) +qp_lenfnl 202 ./qpoe/qpgnfn.x int procedure qp_lenfnl (fl) +qp_lessthan 118 ./qpoe/qprlmerge.gx bool procedure qp_lessthan$t (x, y) +qp_lessthand 118 ./qpoe/gen/qpexmerged.x bool procedure qp_lessthand (x, y) +qp_lessthand 118 ./qpoe/gen/qprlmerged.x bool procedure qp_lessthand (x, y) +qp_lessthani 118 ./qpoe/gen/qpexmergei.x bool procedure qp_lessthani (x, y) +qp_lessthani 118 ./qpoe/gen/qprlmergei.x bool procedure qp_lessthani (x, y) +qp_lessthanr 118 ./qpoe/gen/qpexmerger.x bool procedure qp_lessthanr (x, y) +qp_lessthanr 118 ./qpoe/gen/qprlmerger.x bool procedure qp_lessthanr (x, y) +qp_loadwcs 12 ./qpoe/qploadwcs.x pointer procedure qp_loadwcs (qp) +qp_maxval 100 ./qpoe/qprlmerge.gx PIXEL procedure qp_maxval$t (x, y) +qp_maxvald 100 ./qpoe/gen/qpexmerged.x double procedure qp_maxvald (x, y) +qp_maxvald 100 ./qpoe/gen/qprlmerged.x double procedure qp_maxvald (x, y) +qp_maxvali 100 ./qpoe/gen/qpexmergei.x int procedure qp_maxvali (x, y) +qp_maxvali 100 ./qpoe/gen/qprlmergei.x int procedure qp_maxvali (x, y) +qp_maxvalr 100 ./qpoe/gen/qpexmerger.x real procedure qp_maxvalr (x, y) +qp_maxvalr 100 ./qpoe/gen/qprlmerger.x real procedure qp_maxvalr (x, y) +qp_minval 82 ./qpoe/qprlmerge.gx PIXEL procedure qp_minval$t (x, y) +qp_minvald 82 ./qpoe/gen/qpexmerged.x double procedure qp_minvald (x, y) +qp_minvald 82 ./qpoe/gen/qprlmerged.x double procedure qp_minvald (x, y) +qp_minvali 82 ./qpoe/gen/qpexmergei.x int procedure qp_minvali (x, y) +qp_minvali 82 ./qpoe/gen/qprlmergei.x int procedure qp_minvali (x, y) +qp_minvalr 82 ./qpoe/gen/qpexmerger.x real procedure qp_minvalr (x, y) +qp_minvalr 82 ./qpoe/gen/qprlmerger.x real procedure qp_minvalr (x, y) +qp_mkfname 8 ./qpoe/qpmkfname.x procedure qp_mkfname (poefile, extn, fname, maxch) +qp_nexttok 535 ./qpoe/qpgettok.x int procedure qp_nexttok (gt) +qp_ofnl 67 ./qpoe/qpgnfn.x pointer procedure qp_ofnl (qp, template, sort) +qp_ofnls 39 ./qpoe/qpgnfn.x pointer procedure qp_ofnls (qp, template) +qp_ofnlu 53 ./qpoe/qpgnfn.x pointer procedure qp_ofnlu (qp, template) +qp_open 14 ./qpoe/qpopen.x pointer procedure qp_open (poefile, mode, o_qp) +qp_opentext 90 ./qpoe/qpgettok.x pointer procedure qp_opentext (qp, text) +qp_parse 12 ./qpoe/qpparse.x procedure qp_parse (qpspec, root, sz_root, filter, sz_filter) +qp_parsefl 20 ./qpoe/qpparsefl.x int procedure qp_parsefl (qp, fieldlist, dd) +qp_pclose 9 ./qpoe/qppclose.x procedure qp_pclose (fd) +qp_popen 18 ./qpoe/qppopen.x int procedure qp_popen (qp, param, mode, type) +qp_pstr 8 ./qpoe/qppstr.x procedure qp_pstr (qp, param, strval) +qp_put 11 ./qpoe/qpput.gx procedure qp_put$t (qp, param, value) +qp_putb 9 ./qpoe/qpputb.x procedure qp_putb (qp, param, value) +qp_putc 11 ./qpoe/gen/qpputc.x procedure qp_putc (qp, param, value) +qp_putd 11 ./qpoe/gen/qpputd.x procedure qp_putd (qp, param, value) +qp_puti 11 ./qpoe/gen/qpputi.x procedure qp_puti (qp, param, value) +qp_putl 11 ./qpoe/gen/qpputl.x procedure qp_putl (qp, param, value) +qp_putparam 14 ./qpoe/qpppar.x int procedure qp_putparam (qp, param, o_pp) +qp_putr 11 ./qpoe/gen/qpputr.x procedure qp_putr (qp, param, value) +qp_puts 11 ./qpoe/gen/qpputs.x procedure qp_puts (qp, param, value) +qp_putx 9 ./qpoe/qpputx.x procedure qp_putx (qp, param, value) +qp_queryf 11 ./qpoe/qpqueryf.x int procedure qp_queryf (qp, param, datatype, maxelem, comment, flags) +qp_rawtok 389 ./qpoe/qpgettok.x int procedure qp_rawtok (gt, outstr, maxch) +qp_read 11 ./qpoe/qpread.x int procedure qp_read (qp, param, buf, maxelem, first, datatype) +qp_rebuild 8 ./qpoe/qprebuild.x procedure qp_rebuild (poefile) +qp_rename 7 ./qpoe/qprename.x procedure qp_rename (o_poefile, n_poefile) +qp_renamef 9 ./qpoe/qprenamef.x procedure qp_renamef (qp, param, newname) +qp_rlmerge 10 ./qpoe/qprlmerge.gx int procedure qp_rlmerge$t (os,oe,olen, xs,xe,nx, ys,ye,ny) +qp_rlmerged 10 ./qpoe/gen/qpexmerged.x int procedure qp_rlmerged (os,oe,olen, xs,xe,nx, ys,ye,ny) +qp_rlmerged 10 ./qpoe/gen/qprlmerged.x int procedure qp_rlmerged (os,oe,olen, xs,xe,nx, ys,ye,ny) +qp_rlmergei 10 ./qpoe/gen/qpexmergei.x int procedure qp_rlmergei (os,oe,olen, xs,xe,nx, ys,ye,ny) +qp_rlmergei 10 ./qpoe/gen/qprlmergei.x int procedure qp_rlmergei (os,oe,olen, xs,xe,nx, ys,ye,ny) +qp_rlmerger 10 ./qpoe/gen/qpexmerger.x int procedure qp_rlmerger (os,oe,olen, xs,xe,nx, ys,ye,ny) +qp_rlmerger 10 ./qpoe/gen/qprlmerger.x int procedure qp_rlmerger (os,oe,olen, xs,xe,nx, ys,ye,ny) +qp_savewcs 6 ./qpoe/qpsavewcs.x procedure qp_savewcs (qp, mw) +qp_seekfnl 213 ./qpoe/qpgnfn.x procedure qp_seekfnl (fl, pos) +qp_seti 8 ./qpoe/qpseti.x procedure qp_seti (qp, param, value) +qp_sizeof 11 ./qpoe/qpsizeof.x int procedure qp_sizeof (qp, dtype, dsym, reftype) +qp_stati 8 ./qpoe/qpstati.x int procedure qp_stati (qp, param) +qp_sync 7 ./qpoe/qpsync.x procedure qp_sync (qp) +qp_ungettok 350 ./qpoe/qpgettok.x procedure qp_ungettok (gt, tokbuf) +qp_write 11 ./qpoe/qpwrite.x procedure qp_write (qp, param, buf, nelem, first, datatype) +qpex_attrl 24 ./qpoe/qpexattrl.gx int procedure qpex_attrl$t (ex, attribute, xs, xe, xlen) +qpex_attrld 24 ./qpoe/gen/qpexattrld.x int procedure qpex_attrld (ex, attribute, xs, xe, xlen) +qpex_attrli 24 ./qpoe/gen/qpexattrli.x int procedure qpex_attrli (ex, attribute, xs, xe, xlen) +qpex_attrlr 24 ./qpoe/gen/qpexattrlr.x int procedure qpex_attrlr (ex, attribute, xs, xe, xlen) +qpex_close 8 ./qpoe/qpexclose.x procedure qpex_close (ex) +qpex_codegen 11 ./qpoe/qpexcode.gx int procedure qpex_codegen$t (ex, atname, assignop, expr, offset, dtype) +qpex_codegend 11 ./qpoe/gen/qpexcoded.x int procedure qpex_codegend (ex, atname, assignop, expr, offset, dtype) +qpex_codegeni 11 ./qpoe/gen/qpexcodei.x int procedure qpex_codegeni (ex, atname, assignop, expr, offset, dtype) +qpex_codegenr 11 ./qpoe/gen/qpexcoder.x int procedure qpex_codegenr (ex, atname, assignop, expr, offset, dtype) +qpex_dballoc 188 ./qpoe/qpexdata.x pointer procedure qpex_dballoc (ex, nelem, dtype) +qpex_dbpstr 141 ./qpoe/qpexdata.x pointer procedure qpex_dbpstr (ex, strval) +qpex_debug 15 ./qpoe/qpexdebug.x procedure qpex_debug (ex, out, what) +qpex_delete 11 ./qpoe/qpexdel.x procedure qpex_delete (ex, et_last, offset, dtype) +qpex_evaluate 21 ./qpoe/qpexeval.x int procedure qpex_evaluate (ex, i_ev, o_ev, nev) +qpex_free 63 ./qpoe/qpexdata.x procedure qpex_free (ex, pb_save, db_save) +qpex_getattribute 16 ./qpoe/qpexgetat.x int procedure qpex_getattribute (ex, attribute, outstr, maxch) +qpex_getfilter 10 ./qpoe/qpexgetfil.x int procedure qpex_getfilter (ex, outstr, maxch) +qpex_mark 50 ./qpoe/qpexdata.x procedure qpex_mark (ex, pb_save, db_save) +qpex_modfilter 47 ./qpoe/qpexmodfil.x int procedure qpex_modfilter (ex, exprlist) +qpex_open 14 ./qpoe/qpexopen.x pointer procedure qpex_open (qp, expr) +qpex_parse 103 ./qpoe/qpexparse.gx int procedure qpex_parse$t (expr, xs, xe, xlen) +qpex_parsed 103 ./qpoe/gen/qpexparsed.x int procedure qpex_parsed (expr, xs, xe, xlen) +qpex_parsei 103 ./qpoe/gen/qpexparsei.x int procedure qpex_parsei (expr, xs, xe, xlen) +qpex_parser 103 ./qpoe/gen/qpexparser.x int procedure qpex_parser (expr, xs, xe, xlen) +qpex_pbpin 115 ./qpoe/qpexdata.x procedure qpex_pbpin (ex, opcode, arg1, arg2, arg3) +qpex_pbpos 104 ./qpoe/qpexdata.x pointer procedure qpex_pbpos (ex) +qpex_refd 168 ./qpoe/qpexdata.x int procedure qpex_refd (ex, value) +qpex_sublist 10 ./qpoe/qpexsub.gx int procedure qpex_sublist$t (x1, x2, xs,xe,nranges,ip, o_xs,o_xe) +qpex_sublistd 10 ./qpoe/gen/qpexsubd.x int procedure qpex_sublistd (x1, x2, xs,xe,nranges,ip, o_xs,o_xe) +qpex_sublisti 10 ./qpoe/gen/qpexsubi.x int procedure qpex_sublisti (x1, x2, xs,xe,nranges,ip, o_xs,o_xe) +qpex_sublistr 10 ./qpoe/gen/qpexsubr.x int procedure qpex_sublistr (x1, x2, xs,xe,nranges,ip, o_xs,o_xe) +qpf_access 8 ./imio/iki/qpf/qpfaccess.x procedure qpf_access (kernel, root, extn, acmode, status) +qpf_close 9 ./imio/iki/qpf/qpfclose.x procedure qpf_close (im, status) +qpf_copy 9 ./imio/iki/qpf/qpfcopy.x procedure qpf_copy (kernel, old_root, old_extn, new_root, new_extn, status) +qpf_copyparams 12 ./imio/iki/qpf/qpfcopypar.x procedure qpf_copyparams (im, qp) +qpf_delete 7 ./imio/iki/qpf/qpfdelete.x procedure qpf_delete (kernel, root, extn, status) +qpf_open 14 ./imio/iki/qpf/qpfopen.x procedure qpf_open (kernel, im, o_im, +qpf_opix 12 ./imio/iki/qpf/qpfopix.x procedure qpf_opix (im, status) +qpf_rename 8 ./imio/iki/qpf/qpfrename.x procedure qpf_rename (kernel, old_root, old_extn, new_root, new_extn, status) +qpf_updhdr 6 ./imio/iki/qpf/qpfupdhdr.x procedure qpf_updhdr (im, status) +qpf_wattr 30 ./imio/iki/qpf/qpfwattr.x procedure qpf_wattr (qpf, im) +qpf_wfilter 7 ./imio/iki/qpf/qpfwfilter.x procedure qpf_wfilter (qpf, im) +qpfzcl 53 ./imio/iki/qpf/zfioqp.x procedure qpfzcl (chan, status) +qpfzop 21 ./imio/iki/qpf/zfioqp.x procedure qpfzop (pkfn, mode, status) +qpfzrd 67 ./imio/iki/qpf/zfioqp.x procedure qpfzrd (chan, obuf, nbytes, boffset) +qpfzst 155 ./imio/iki/qpf/zfioqp.x procedure qpfzst (chan, param, value) +qpfzwr 122 ./imio/iki/qpf/zfioqp.x procedure qpfzwr (chan, ibuf, nbytes, boffset) +qpfzwt 140 ./imio/iki/qpf/zfioqp.x procedure qpfzwt (chan, status) +qpio_close 8 ./qpoe/qpioclose.x procedure qpio_close (io) +qpio_getevents 21 ./qpoe/qpiogetev.x int procedure qpio_getevents (io, o_ev, maskval, maxev, o_nev) +qpio_getfilter 13 ./qpoe/qpiogetfil.x int procedure qpio_getfilter (io, outstr, maxch) +qpio_getrange 8 ./qpoe/qpiogetrg.x int procedure qpio_getrange (io, vs, ve, maxdim) +qpio_loadmask 14 ./qpoe/qpiolmask.x procedure qpio_loadmask (io, mask, merge) +qpio_loadwcs 9 ./qpoe/qpiolwcs.x pointer procedure qpio_loadwcs (io) +qpio_mkindex 20 ./qpoe/qpiomkidx.x procedure qpio_mkindex (io, key) +qpio_open 18 ./qpoe/qpioopen.x pointer procedure qpio_open (qp, paramex, mode) +qpio_parse 18 ./qpoe/qpioparse.x int procedure qpio_parse (io, expr, filter, sz_filter, mask, sz_mask) +qpio_putevents 14 ./qpoe/qpioputev.x procedure qpio_putevents (io, i_ev, nevents) +qpio_rbucket 8 ./qpoe/qpiorb.x int procedure qpio_rbucket (io, evi) +qpio_readpix 13 ./qpoe/qpiorpix.gx int procedure qpio_readpix$t (io, obuf, vs, ve, ndim, xblock, yblock) +qpio_readpixi 13 ./qpoe/gen/qpiorpixi.x int procedure qpio_readpixi (io, obuf, vs, ve, ndim, xblock, yblock) +qpio_readpixs 13 ./qpoe/gen/qpiorpixs.x int procedure qpio_readpixs (io, obuf, vs, ve, ndim, xblock, yblock) +qpio_setfilter 14 ./qpoe/qpiosetfil.x procedure qpio_setfilter (io, expr) +qpio_seti 12 ./qpoe/qpioseti.x procedure qpio_seti (io, param, value) +qpio_setrange 9 ./qpoe/qpiosetrg.x procedure qpio_setrange (io, vs, ve, ndim) +qpio_stati 8 ./qpoe/qpiostati.x int procedure qpio_stati (io, param) +qpio_sync 14 ./qpoe/qpiosync.x procedure qpio_sync (io) +qpio_wbucket 14 ./qpoe/qpiowb.x procedure qpio_wbucket (io, evi) +qsort 1 ./libc/qsort.c qsort (base, n, size, compar) +qsort 20 ./etc/qsort.x procedure qsort (x, nelem, compare) +qst 2 ./libc/qsort.c qst (base, maxval) +rcursor 47 ./gio/cursor/rcursor.x int procedure rcursor (stream, outstr, maxch) +rddata 187 ./gio/calcomp/vttest.x procedure rddata (fname, x, y, npts) +rdukey 19 ./clio/rdukey.x int procedure rdukey (keystr, maxch) +read 14 ./fio/read.x int procedure read (fd, buffer, maxchars) +ready 9 ../unix/os/zzstrt.c ready() +realloc 1 ./libc/realloc.c realloc (buf, newsize) +realloc 9 ./memdbg/realloc.x procedure realloc (ubufp, nelems, dtype) +realloc 9 ./memio/realloc.x procedure realloc (ubufp, nelems, dtype) +rename 10 ./fio/rename.x procedure rename (oldname, newname) +reopen 15 ./fio/reopen.x int procedure reopen (fd, mode) +reset_scan 6 ./fmtio/resetscan.x procedure reset_scan() +restoretx 265 ./gio/nsppkern/gktpcell.x procedure restoretx (savep, txp) +rewind 1 ./libc/rewind.c rewind (fp) +rindex 1 ./libc/rindex.c rindex (str, ch) +rptheta4 12 ./gio/calcomp/rptheta4.x real procedure rptheta4 (p1x, p1y, p2x, p2y) +rptheta4 297 ./gio/calcomp/vttest.x real procedure rptheta4 (p1x, p1y, p2x, p2y) +salloc 25 ./memdbg/salloc.x procedure salloc (output_pointer, nelem, datatype) +salloc 25 ./memio/salloc.x procedure salloc (output_pointer, nelem, datatype) +savetx 225 ./gio/nsppkern/gktpcell.x procedure savetx (savep, txp) +sbit 12 ./osb/zzdebug.x procedure sbit() +sbytes 19 ./gio/ncarutil/sysint/sbytes.x procedure sbytes (bufout, bufin, index, size, skip, count) +scan 24 ./fmtio/fscan.x int procedure scan() +scanc 5 ./fmtio/scanc.x procedure scanc (cval) +scanf 1 ./libc/scanf.c scanf (va_alist) +scanfile 202 ./symtab/zzdebug.x procedure scanfile (fname, stp) +seek 15 ./fio/seek.x procedure seek (fd, offset) +setbuf 1 ./libc/setbuf.c setbuf (fp, buf) +setbuffer 1 ./libc/setbuf.c setbuffer (fp, buf, size) +setlinebuf 1 ./libc/setbuf.c setlinebuf (fp) +sfree 95 ./memio/salloc.x procedure sfree (old_sp) +sfree 99 ./memdbg/salloc.x procedure sfree (old_sp) +sgc_dump 188 ./gio/stdgraph/t_showcap.x procedure sgc_dump (fd, data, nchars) +sgch_draw 117 ./gio/stdgraph/stgdrawch.x procedure sgch_draw (mx, my) +sgch_flush 132 ./gio/stdgraph/stgdrawch.x procedure sgch_flush() +sgch_move 100 ./gio/stdgraph/stgdrawch.x procedure sgch_move (mx, my) +sge_execute 198 ./gio/stdgraph/stgencode.x int procedure sge_execute (program, memory, registers) +sge_printf 484 ./gio/stdgraph/stgencode.x procedure sge_printf (number, memory, iop, top, program, pc) +sge_spoolesc 84 ./gio/stdgraph/stgescape.x procedure sge_spoolesc (tr, gki, fn, instruction, bp, buftop, delete_fcn) +sge_wsenable 62 ./gio/stdgraph/stgescape.x bool procedure sge_wsenable () +sge_wstran 41 ./gio/stdgraph/stgescape.x procedure sge_wstran (fn, instruction, x1,y1, x2,y2) +sgf_getchar 135 ./gio/stdgraph/stgfilter.x int procedure sgf_getchar (fd, svbuf, sp, buf, ip, maxch, nchars) +sgf_post_filter 17 ./gio/stdgraph/stgfilter.x procedure sgf_post_filter (fd) +sgf_ttyfilter 37 ./gio/stdgraph/stgfilter.x procedure sgf_ttyfilter (fd, buf, maxch, status) +sgi_bcell 39 ./gio/sgikern/sgipcell.x procedure sgi_bcell (m, nx, ny, ax1,ay1, ax2,ay2) +sgi_cancel 7 ./gio/sgikern/sgicancel.x procedure sgi_cancel (dummy) +sgi_clear 10 ./gio/sgikern/sgiclear.x procedure sgi_clear (dummy) +sgi_close 8 ./gio/sgikern/sgiclose.x procedure sgi_close() +sgi_closews 9 ./gio/sgikern/sgiclws.x procedure sgi_closews (devname, n) +sgi_color 7 ./gio/sgikern/sgicolor.x procedure sgi_color (index) +sgi_dashline 78 ./gio/sgikern/sgipl.x procedure sgi_dashline (g_out, p, npts, ltype) +sgi_drawchar 15 ./gio/sgikern/sgidrawch.x int procedure sgi_drawchar (ch, x, y, xsize, ysize, orien, font) +sgi_escape 6 ./gio/sgikern/sgiescape.x procedure sgi_escape (fn, instruction, nwords) +sgi_faset 8 ./gio/sgikern/sgifaset.x procedure sgi_faset (gki) +sgi_fillarea 7 ./gio/sgikern/sgifa.x procedure sgi_fillarea (p, npts) +sgi_flush 7 ./gio/sgikern/sgiflush.x procedure sgi_flush (dummy) +sgi_font 13 ./gio/sgikern/sgifont.x procedure sgi_font (font) +sgi_getcellarray 6 ./gio/sgikern/sgigcell.x procedure sgi_getcellarray (nx, ny, x1,y1, x2,y2) +sgi_getseg 149 ./gio/sgikern/sgipl.x int procedure sgi_getseg (maxlen, penup, ltype) +sgi_gstring 141 ./gio/sgikern/sgiinit.x pointer procedure sgi_gstring (cap) +sgi_init 13 ./gio/sgikern/sgiinit.x procedure sgi_init (tty, devname) +sgi_linetype 8 ./gio/sgikern/sgiline.x procedure sgi_linetype (index) +sgi_mcell 122 ./gio/sgikern/sgipcell.x procedure sgi_mcell (m, nx, ny, ax1,ay1, ax2,ay2) +sgi_open 12 ./gio/sgikern/sgiopen.x procedure sgi_open (devname, dd) +sgi_openws 13 ./gio/sgikern/sgiopenws.x procedure sgi_openws (devname, n, mode) +sgi_plset 9 ./gio/sgikern/sgiplset.x procedure sgi_plset (gki) +sgi_pmset 8 ./gio/sgikern/sgipmset.x procedure sgi_pmset (gki) +sgi_polyline 17 ./gio/sgikern/sgipl.x procedure sgi_polyline (p, npts) +sgi_polymarker 9 ./gio/sgikern/sgipm.x procedure sgi_polymarker (p, npts) +sgi_putcellarray 16 ./gio/sgikern/sgipcell.x procedure sgi_putcellarray (m, nx, ny, ax1,ay1, ax2,ay2) +sgi_reset 12 ./gio/sgikern/sgireset.x procedure sgi_reset() +sgi_text 21 ./gio/sgikern/sgitx.x procedure sgi_text (xc, yc, text, n) +sgi_txset 9 ./gio/sgikern/sgitxset.x procedure sgi_txset (gki) +sgk_close 409 ./gio/sgikern/sgk.x procedure sgk_close (fd) +sgk_draw 587 ./gio/sgikern/sgk.x procedure sgk_draw (fd, a_x, a_y) +sgk_flush 470 ./gio/sgikern/sgk.x procedure sgk_flush (fd) +sgk_frame 490 ./gio/sgikern/sgk.x procedure sgk_frame (fd) +sgk_linewidth 805 ./gio/sgikern/sgk.x procedure sgk_linewidth (fd, width) +sgk_mkfname 841 ./gio/sgikern/sgk.x procedure sgk_mkfname (root, num, outstr, maxch) +sgk_move 536 ./gio/sgikern/sgk.x procedure sgk_move (fd, x, y) +sgk_open 144 ./gio/sgikern/sgk.x int procedure sgk_open (device, tty) +sgk_vector 707 ./gio/sgikern/sgk.x procedure sgk_vector (a_x1, a_y1, a_x2, a_y2) +sgm_execute 27 ./gio/stdgraph/stggim.x bool procedure sgm_execute (fn, gim, nwords) +sgm_getmapping 744 ./gio/stdgraph/stggim.x procedure sgm_getmapping (gim) +sgm_iomapread 680 ./gio/stdgraph/stggim.x procedure sgm_iomapread (gim) +sgm_iomapwrite 641 ./gio/stdgraph/stggim.x procedure sgm_iomapwrite (gim) +sgm_output 761 ./gio/stdgraph/stggim.x procedure sgm_output (cap, gim, nargs) +sgm_query 797 ./gio/stdgraph/stggim.x procedure sgm_query (query_cap, gim, nargs, retval_cap, retval, nout) +sgm_queryraster 429 ./gio/stdgraph/stggim.x procedure sgm_queryraster (gim) +sgm_readcmap 577 ./gio/stdgraph/stggim.x procedure sgm_readcmap (gim) +sgm_readpixels 481 ./gio/stdgraph/stggim.x procedure sgm_readpixels (gim) +sgm_spoolesc 330 ./gio/stdgraph/stggim.x bool procedure sgm_spoolesc (tr, gki, fn, gim, bp, buftop, delete_fcn) +sgm_winsize 408 ./gio/stdgraph/stggim.x procedure sgm_winsize (width, height) +sgm_writecmap 540 ./gio/stdgraph/stggim.x procedure sgm_writecmap (gim) +sgm_writepixels 445 ./gio/stdgraph/stggim.x procedure sgm_writepixels (gim) +sgm_wsenable 311 ./gio/stdgraph/stggim.x bool procedure sgm_wsenable (enable) +sgm_wstran 102 ./gio/stdgraph/stggim.x bool procedure sgm_wstran (fn, gim, rx1,ry1, rx2,ry2) +sizeof 5 ./memdbg/sizeof.x int procedure sizeof (dtype) +sizeof 5 ./memio/sizeof.x int procedure sizeof (dtype) +smark 72 ./memdbg/salloc.x procedure smark (old_sp) +smark 72 ./memio/salloc.x procedure smark (old_sp) +spf_close 1 ./libc/spf.c spf_close (fd) +spf_open 1 ./libc/spf.c spf_open (buf, maxch) +sprintf 1 ./libc/sprintf.c sprintf (va_alist) +sprintf 8 ./fmtio/sprintf.x procedure sprintf (outstr, maxch, format_string) +srf_test 3 ./gio/ncarutil/tests/srftest.x procedure srf_test() +sscan 7 ./fmtio/sscan.x procedure sscan (str) +sscanf 2 ./libc/scanf.c sscanf (va_alist) +stalloc 8 ./symtab/stalloc.x int procedure stalloc (stp, blklen) +stclose 7 ./symtab/stclose.x procedure stclose (stp) +stenter 10 ./symtab/stenter.x pointer procedure stenter (stp, key, u_symlen) +stf_access 8 ./imio/iki/stf/stfaccess.x procedure stf_access (kernel, root, extn, acmode, status) +stf_addpar 12 ./imio/iki/stf/stfaddpar.x procedure stf_addpar (im, pname, dtype, plen, pval, pno) +stf_close 12 ./imio/iki/stf/stfclose.x procedure stf_close (im, status) +stf_copy 9 ./imio/iki/stf/stfcopy.x procedure stf_copy (kernel, oroot, oextn, nroot, nextn, status) +stf_copyfits 11 ./imio/iki/stf/stfcopyf.x procedure stf_copyfits (stf, spool, gpb, user) +stf_ctype 9 ./imio/iki/stf/stfctype.x int procedure stf_ctype (card, index) +stf_delete 10 ./imio/iki/stf/stfdelete.x procedure stf_delete (kernel, root, extn, status) +stf_getb 26 ./imio/iki/stf/stfget.x procedure stf_getb (card, bval) +stf_getcmt 69 ./imio/iki/stf/stfget.x procedure stf_getcmt (card, comment, maxch) +stf_gethdrextn 10 ./imio/iki/stf/stfhextn.x procedure stf_gethdrextn (im, o_im, acmode, outstr, maxch) +stf_geti 8 ./imio/iki/stf/stfget.x procedure stf_geti (card, ival) +stf_gets 45 ./imio/iki/stf/stfget.x procedure stf_gets (card, outstr, maxch) +stf_initwcs 7 ./imio/iki/stf/stfiwcs.x procedure stf_initwcs (im) +stf_mergegpb 19 ./imio/iki/stf/stfmerge.x procedure stf_mergegpb (n_im, o_im) +stf_mkpixfname 10 ./imio/iki/stf/stfmkpfn.x procedure stf_mkpixfname (hdr_root, hdr_extn, pixfname, maxch) +stf_newimage 15 ./imio/iki/stf/stfnewim.x procedure stf_newimage (im) +stf_open 11 ./imio/iki/stf/stfopen.x procedure stf_open (kernel, im, o_im, +stf_opix 25 ./imio/iki/stf/stfopix.x procedure stf_opix (im, status) +stf_ordergpb 11 ./imio/iki/stf/stfordgpb.x procedure stf_ordergpb (o_stf, n_stf) +stf_rdheader 16 ./imio/iki/stf/stfrdhdr.x procedure stf_rdheader (im, group, acmode) +stf_reblock 10 ./imio/iki/stf/stfreblk.x procedure stf_reblock (im) +stf_rfitshdr 38 ./imio/iki/stf/stfrfits.x procedure stf_rfitshdr (im, fits, fitslen) +stf_rgpb 17 ./imio/iki/stf/stfrgpb.x procedure stf_rgpb (im, group, acmode, datamin, datamax) +stf_rname 12 ./imio/iki/stf/stfrename.x procedure stf_rname (kernel, oroot, oextn, nroot, nextn, status) +stf_updhdr 10 ./imio/iki/stf/stfupdhdr.x procedure stf_updhdr (im, status) +stf_wfitshdr 14 ./imio/iki/stf/stfwfits.x procedure stf_wfitshdr (im) +stf_wgpb 16 ./imio/iki/stf/stfwgpb.x procedure stf_wgpb (im, group, datamin, datamax) +stfind 12 ./symtab/stfind.x pointer procedure stfind (stp, key) +stfindall 10 ./symtab/stfindall.x int procedure stfindall (stp, key, symbols, max_symbols) +stfree 9 ./symtab/stfree.x procedure stfree (stp, marker) +stg_cancel 8 ./gio/stdgraph/stgcancel.x procedure stg_cancel (dummy) +stg_clear 8 ./gio/stdgraph/stgclear.x procedure stg_clear (dummy) +stg_close 10 ./gio/stdgraph/stgclose.x procedure stg_close() +stg_closews 9 ./gio/stdgraph/stgclws.x procedure stg_closews (devname, n) +stg_ctrl 11 ./gio/stdgraph/stgctrl.x procedure stg_ctrl (cap) +stg_ctrl1 42 ./gio/stdgraph/stgctrl.x procedure stg_ctrl1 (cap, arg1) +stg_ctrl2 56 ./gio/stdgraph/stgctrl.x procedure stg_ctrl2 (cap, arg1, arg2) +stg_ctrl3 71 ./gio/stdgraph/stgctrl.x procedure stg_ctrl3 (cap, arg1, arg2, arg3) +stg_deactivatews 12 ./gio/stdgraph/stgdeact.x procedure stg_deactivatews (flags) +stg_draw 8 ./gio/stdgraph/stgdraw.x procedure stg_draw (x, y) +stg_drawchar 16 ./gio/stdgraph/stgdrawch.x procedure stg_drawchar (ch, x, y, xsize, ysize, orien, font) +stg_encode 97 ./gio/stdgraph/stgencode.x int procedure stg_encode (program, memory, registers) +stg_escape 21 ./gio/stdgraph/stgescape.x procedure stg_escape (fn, instruction, nwords) +stg_faset 8 ./gio/stdgraph/stgfaset.x procedure stg_faset (gki) +stg_fillarea 9 ./gio/stdgraph/stgfa.x procedure stg_fillarea (p, npts) +stg_flush 7 ./gio/stdgraph/stgflush.x procedure stg_flush (dummy) +stg_gdisab 7 ./gio/stdgraph/stggdisab.x procedure stg_gdisab() +stg_genab 7 ./gio/stdgraph/stggenab.x procedure stg_genab() +stg_getcellarray 6 ./gio/stdgraph/stggcell.x procedure stg_getcellarray (nx, ny, x1,y1, x2,y2) +stg_getcursor 8 ./gio/stdgraph/stggcur.x procedure stg_getcursor (cursor) +stg_getline 115 ./gio/stdgraph/stgrtty.x int procedure stg_getline (fd, obuf) +stg_grstream 9 ./gio/stdgraph/stggrstr.x procedure stg_grstream (stream) +stg_gstring 172 ./gio/stdgraph/stginit.x pointer procedure stg_gstring (cap) +stg_init 14 ./gio/stdgraph/stginit.x procedure stg_init (tty, devname) +stg_lockcursor 11 ./gio/stdgraph/stglkcur.x procedure stg_lockcursor (new_cursor) +stg_move 8 ./gio/stdgraph/stgmove.x procedure stg_move (x, y) +stg_msglen 130 ./gio/stdgraph/stgrtty.x int procedure stg_msglen (fd) +stg_onerror 9 ./gio/stdgraph/stgonerr.x procedure stg_onerror (errcode) +stg_onint 11 ./gio/stdgraph/stgonint.x procedure stg_onint (vex, next_handler) +stg_open 13 ./gio/stdgraph/stgopen.x procedure stg_open (devname, dd, in, out, xres, yres, hardchar) +stg_openws 15 ./gio/stdgraph/stgopenws.x procedure stg_openws (devname, n, mode) +stg_output2 8 ./gio/stdgraph/stgoutput.x procedure stg_output2 (fd, program, arg1, arg2) +stg_outstr 8 ./gio/stdgraph/stgoutstr.x procedure stg_outstr (cap, strval) +stg_plset 9 ./gio/stdgraph/stgplset.x procedure stg_plset (gki) +stg_pmset 8 ./gio/stdgraph/stgpmset.x procedure stg_pmset (gki) +stg_polyline 10 ./gio/stdgraph/stgpl.x procedure stg_polyline (p, npts) +stg_polymarker 12 ./gio/stdgraph/stgpm.x procedure stg_polymarker (p, npts) +stg_putcellarray 15 ./gio/stdgraph/stgpcell.x procedure stg_putcellarray (m, nx, ny, ax1,ay1, ax2,ay2) +stg_putline 110 ./gio/stdgraph/stgwtty.x procedure stg_putline (fd, text) +stg_rdcursor 216 ./gio/stdgraph/stgrcur.x procedure stg_rdcursor (tty, cursor, output_rc, cn, key, sx,sy, raster, rx,ry) +stg_reactivatews 9 ./gio/stdgraph/stgreact.x procedure stg_reactivatews (flags) +stg_readcursor 56 ./gio/stdgraph/stgrcur.x procedure stg_readcursor (cursor, cn, key, sx, sy, raster, rx, ry) +stg_readtty 17 ./gio/stdgraph/stgrtty.x int procedure stg_readtty (fd, obuf, maxch) +stg_reset 11 ./gio/stdgraph/stgreset.x procedure stg_reset() +stg_resolution 12 ./gio/stdgraph/stgres.x procedure stg_resolution (xres, yres) +stg_setcursor 7 ./gio/stdgraph/stgscur.x procedure stg_setcursor (x, y, cursor) +stg_text 19 ./gio/stdgraph/stgtx.x procedure stg_text (xc, yc, text, n) +stg_txquality 10 ./gio/stdgraph/stgtxqual.x procedure stg_txquality (quality) +stg_txset 9 ./gio/stdgraph/stgtxset.x procedure stg_txset (gki) +stg_txsize 9 ./gio/stdgraph/stgtxsize.x int procedure stg_txsize (pksize) +stg_unknown 6 ./gio/stdgraph/stgunkown.x procedure stg_unknown (gki) +stg_writetty 31 ./gio/stdgraph/stgwtty.x procedure stg_writetty (fd, text, nchars) +sthash 15 ./symtab/sthash.x int procedure sthash (key, modulus) +sthead 8 ./symtab/sthead.x pointer procedure sthead (stp) +stinfo 8 ./symtab/stinfo.x procedure stinfo (stp, fd, verbose) +stk_mkseg 129 ./memio/salloc.x procedure stk_mkseg (cur_seg, sp, segment_size) +stk_mkseg 138 ./memdbg/salloc.x procedure stk_mkseg (cur_seg, sp, segment_size) +stmark 11 ./symtab/stmark.x procedure stmark (stp, marker) +stname 8 ./symtab/stname.x pointer procedure stname (stp, sym) +stnext 10 ./symtab/stnext.x pointer procedure stnext (stp, sym) +stnsymbols 9 ./symtab/stnsym.x int procedure stnsymbols (stp, marker) +stopen 14 ./symtab/stopen.x pointer procedure stopen (name, len_index, len_stab, sz_sbuf) +stpstr 13 ./symtab/stpstr.x int procedure stpstr (stp, str, minchars) +strcat 1 ./libc/strcat.c strcat (s1, s2) +strcat 5 ./fmtio/strcat.x procedure strcat (str, outstr, maxch) +strclose 88 ./fio/stropen.x procedure strclose (fd) +strcmp 1 ./libc/strcmp.c strcmp (s1, s2) +strcmp 6 ./fmtio/strcmp.x int procedure strcmp (s1, s2) +strcpy 1 ./libc/strcpy.c strcpy (s1, s2) +strcpy 5 ./fmtio/strcpy.x procedure strcpy (s1, s2, maxch) +strdic 13 ./fmtio/strdic.x int procedure strdic (in_str, out_str, maxchars, dict) +strefsbuf 7 ./symtab/strefsbuf.x pointer procedure strefsbuf (stp, offset) +strefstab 7 ./symtab/strefstab.x pointer procedure strefstab (stp, offset) +streq 5 ./fmtio/streq.x bool procedure streq (s1, s2) +strestore 15 ./symtab/strestore.x pointer procedure strestore (fd) +strge 5 ./fmtio/strge.x bool procedure strge (s1, s2) +strgetmode 144 ./fio/stropen.x int procedure strgetmode (fd) +strgt 5 ./fmtio/strgt.x bool procedure strgt (s1, s2) +stridx 6 ./fmtio/stridx.x int procedure stridx (ch, str) +stridxs 9 ./fmtio/stridxs.x int procedure stridxs (set, str) +strldx 6 ./fmtio/strldx.x int procedure strldx (ch, str) +strldxs 9 ./fmtio/strldxs.x int procedure strldxs (set, str) +strle 5 ./fmtio/strle.x bool procedure strle (s1, s2) +strlen 1 ./libc/strlen.c strlen (s) +strlen 5 ./fmtio/strlen.x int procedure strlen (str) +strlt 5 ./fmtio/strlt.x bool procedure strlt (s1, s2) +strlwr 7 ./fmtio/strlwr.x procedure strlwr (a) +strmac 22 ./fmtio/strmac.x int procedure strmac (macro, argstr, outstr, maxch) +strmatch 26 ./fmtio/strmatch.x int procedure strmatch (str, pat) +strncat 1 ./libc/strncat.c strncat (s1, s2, n) +strncmp 1 ./libc/strncmp.c strncmp (s1, s2, n) +strncmp 6 ./fmtio/strncmp.x int procedure strncmp (s1, s2, n) +strncpy 1 ./libc/strncpy.c strncpy (s1, s2, n) +strne 5 ./fmtio/strne.x bool procedure strne (s1, s2) +stropen 22 ./fio/stropen.x int procedure stropen (str, maxch, mode) +strse1 41 ./fmtio/strsearch.x bool procedure strse1 (str, patstr, patlen) +strsearch 8 ./fmtio/strsearch.x int procedure strsearch (str, patstr) +strsetmode 125 ./fio/stropen.x procedure strsetmode (fd, mode) +strsrt 9 ./fmtio/strsrt.x procedure strsrt (x, sb, nstr) +strtbl 10 ./fmtio/strtbl.x procedure strtbl (fd, buf, strp, nstr, first_col, last_col, maxch, ncol) +strupr 7 ./fmtio/strupr.x procedure strupr (str) +stsave 12 ./symtab/stsave.x procedure stsave (stp, fd) +stsize 9 ./symtab/stsize.x int procedure stsize (stp) +stsqueeze 9 ./symtab/stsqueeze.x procedure stsqueeze (stp) +stty_envreset 292 ./etc/sttyco.x procedure stty_envreset (envvar, value) +stty_getarg 456 ./etc/sttyco.x int procedure stty_getarg (args, ip, keyw, maxkc, value, maxvc, defact, yesno) +stty_newterm 209 ./etc/sttyco.x procedure stty_newterm (ttin, ttout, terminal) +stty_setsize 247 ./etc/sttyco.x procedure stty_setsize (ttin, ttout, tty) +stty_showterm 307 ./etc/sttyco.x procedure stty_showterm (ttin, ttout, fd, all) +stty_ttyinit 273 ./etc/sttyco.x procedure stty_ttyinit (ttin, ttout, terminal) +sttyco 89 ./etc/sttyco.x procedure sttyco (args, ttin, ttout, outfd) +stx_chars 481 ./gio/stdgraph/stgtx.x procedure stx_chars (tx, ch, cw, hwsz, hard, orien) +stx_parameters 258 ./gio/nsppkern/gkttx.x procedure stx_parameters (xc, yc, totlen, x0, y0, dx, dy, polytext, orien) +stx_parameters 260 ./gio/imdkern/imdtx.x procedure stx_parameters (xc, yc, totlen, x0, y0, dx, dy, polytext, orien) +stx_parameters 281 ./gio/stdgraph/stgtx.x procedure stx_parameters (xc, yc, totlen, x0, y0, dx, dy, polytext, orien) +stx_parameters 283 ./gio/sgikern/sgitx.x procedure stx_parameters (xc, yc, totlen, totwidth, x0, y0, dx, dy, polytext, +stx_segment 198 ./gio/nsppkern/gkttx.x int procedure stx_segment (text, n, out, start_font) +stx_segment 200 ./gio/imdkern/imdtx.x int procedure stx_segment (text, n, out, start_font) +stx_segment 203 ./gio/sgikern/sgitx.x int procedure stx_segment (text, n, out, start_font, cw, totwidth) +stx_segment 221 ./gio/stdgraph/stgtx.x int procedure stx_segment (text, n, out, start_font) +symbol 369 ./gio/calcomp/vttest.x procedure symbol (xp, yp, size, ch, orien, nchar) +sys_getcommand 435 ./etc/main.x int procedure sys_getcommand (fd, cmd, taskname, arglist_offset, timeit, prtype) +sys_getpars 590 ./etc/main.x procedure sys_getpars (fname) +sys_gstrarg 818 ./etc/main.x procedure sys_gstrarg (args, ip, outstr, maxch) +sys_mtime 13 ./etc/sysptime.x procedure sys_mtime (save_time) +sys_panic 6 ./etc/syspanic.x procedure sys_panic (errcode, errmsg) +sys_paramset 631 ./etc/main.x procedure sys_paramset (args, ip) +sys_ptime 25 ./etc/sysptime.x procedure sys_ptime (fd, opstr, save_time) +sys_redirect 701 ./etc/main.x procedure sys_redirect (args, ip) +sys_scanarglist 516 ./etc/main.x procedure sys_scanarglist (cmdin, i_args) +syserr 8 ./etc/syserr.x procedure syserr (errcode) +syserrs 25 ./etc/syserr.x procedure syserrs (errcode, user_string) +sysid 15 ./etc/sysid.x procedure sysid (outstr, maxch) +system 1 ./libc/system.c system (cmd) +t_allocate 47 ./mtio/zzdebug.x procedure t_allocate() +t_autograph 11 ./gio/ncarutil/tests/autograph.x procedure t_autograph() +t_bfappend 152 ./fio/zzdebug.x procedure t_bfappend() +t_calcomp 14 ./gio/calcomp/t_calcomp.x procedure t_calcomp() +t_cap 47 ./tty/zzdebug.x procedure t_cap() +t_clear 1581 ./qpoe/zzdebug.x procedure t_clear() +t_client 277 ./fio/zzdebug.x procedure t_client() +t_cmp 223 ./fmtio/zzdebug.x procedure t_cmp() +t_comp 226 ./qpoe/zzdebug.x procedure t_comp() +t_conran 10 ./gio/ncarutil/tests/conran.x procedure t_conran () +t_conraq 10 ./gio/ncarutil/tests/conraq.x procedure t_conraq () +t_conras 10 ./gio/ncarutil/tests/conras.x procedure t_conras () +t_conrec 10 ./gio/ncarutil/tests/conrec.x procedure t_conrec () +t_copy 188 ./fmio/zzdebug.x procedure t_copy() +t_countpoe 1023 ./qpoe/zzdebug.x procedure t_countpoe() +t_create 24 ./fmio/zzdebug.x procedure t_create() +t_ctowrd 303 ./fmtio/zzdebug.x procedure t_ctowrd() +t_dashchar 7 ./gio/ncarutil/tests/dashchar.x procedure t_dashchar() +t_dashsmth 7 ./gio/ncarutil/tests/dashsmth.x procedure t_dashsmth() +t_daytime 323 ./fio/zzdebug.x procedure t_daytime() +t_deallocate 82 ./mtio/zzdebug.x procedure t_deallocate() +t_debug 131 ./etc/zzdebug.x procedure t_debug() +t_dump 7 ./gty/zzdebug.x procedure t_dump() +t_dumpevl 481 ./qpoe/zzdebug.x procedure t_dumpevl() +t_edit 228 ./etc/zzdebug.x procedure t_edit() +t_efont 358 ./gio/nsppkern/zzdebug.x procedure t_efont() +t_encode 98 ./ki/zzdebug.x procedure t_encode() +t_enter 52 ./fmio/zzdebug.x procedure t_enter() +t_eq 103 ./fmtio/zzdebug.x procedure t_eq() +t_expand 270 ./qpoe/zzdebug.x procedure t_expand() +t_extract 83 ./fmio/zzdebug.x procedure t_extract() +t_ezconrec 10 ./gio/ncarutil/tests/ezconrec.x procedure t_ezconrec () +t_ezisos 10 ./gio/ncarutil/tests/ezisosrf.x procedure t_ezisos() +t_ezmapg 10 ./gio/ncarutil/tests/ezmapg.x procedure t_ezmapg() +t_ezsurface 10 ./gio/ncarutil/tests/ezsurface.x procedure t_ezsurface() +t_ezvelvect 10 ./gio/ncarutil/tests/ezvelvect.x procedure t_ezvelvect() +t_ezytst 13 ./gio/ncarutil/tests/ezytst.x procedure t_ezytst() +t_fcache 233 ./fmio/zzdebug.x procedure t_fcache() +t_find 18 ./tty/zzdebug.x procedure t_find() +t_float 485 ./mwcs/zzdebug.x procedure t_float() +t_fnl 111 ./fio/zzdebug.x procedure t_fnl() +t_font 330 ./gio/nsppkern/zzdebug.x procedure t_font() +t_free 116 ./etc/zzdebug.x procedure t_free() +t_ge 203 ./fmtio/zzdebug.x procedure t_ge() +t_get 52 ./etc/zzdebug.x procedure t_get() +t_ggcur 12 ./gio/gki/zzdebug.x procedure t_ggcur() +t_gkidecode 9 ./gio/stdgraph/t_gkideco.x procedure t_gkidecode() +t_grey 95 ./gio/nsppkern/zzdebug.x procedure t_grey() +t_grid 25 ./gio/nsppkern/zzdebug.x procedure t_grid () +t_gt 183 ./fmtio/zzdebug.x procedure t_gt() +t_hlist 431 ./qpoe/zzdebug.x procedure t_hlist() +t_http 368 ./fio/zzdebug.x procedure t_http() +t_imdkern 9 ./gio/imdkern/t_imdkern.x procedure t_imdkern() +t_imt 7 ./imio/zzdebug.x procedure t_imt() +t_imtest 204 ./mwcs/zzdebug.x procedure t_imtest() +t_init 110 ./tty/zzdebug.x procedure t_init() +t_inv 332 ./mwcs/zzdebug.x procedure t_inv() +t_irafks 54 ./ki/irafks.x procedure t_irafks() +t_isosrf 10 ./gio/ncarutil/tests/isosrf.x procedure t_isosrf() +t_le 163 ./fmtio/zzdebug.x procedure t_le() +t_lex 65 ./fmtio/zzdebug.x procedure t_lex() +t_list 89 ./etc/zzdebug.x procedure t_list() +t_load 453 ./mwcs/zzdebug.x procedure t_load() +t_lt 143 ./fmtio/zzdebug.x procedure t_lt() +t_many 205 ./fio/zzdebug.x procedure t_many() +t_mark 102 ./etc/zzdebug.x procedure t_mark() +t_mat 263 ./fmtio/zzdebug.x procedure t_mat() +t_memchk 16 ./memdbg/zzdebug.x procedure t_memchk() +t_mergei 1460 ./qpoe/zzdebug.x procedure t_mergei() +t_mio 150 ./pmio/zzdebug.x procedure t_mio() +t_mkfile 119 ./fmio/zzdebug.x procedure t_mkfile() +t_mkmask 18 ./pmio/zzdebug.x procedure t_mkmask() +t_mkpoe 715 ./qpoe/zzdebug.x procedure t_mkpoe() +t_mkttydata 64 ./tty/x_mkttydata.x procedure t_mkttydata() +t_mpp 30 ./fio/zzdebug.x procedure t_mpp() +t_mtcopy 313 ./mtio/zzdebug.x procedure t_mtcopy() +t_mtexamine 215 ./mtio/zzdebug.x procedure t_mtexamine() +t_mtposition 153 ./mtio/zzdebug.x procedure t_mtposition() +t_ncmp 243 ./fmtio/zzdebug.x procedure t_ncmp() +t_ne 123 ./fmtio/zzdebug.x procedure t_ne() +t_newcopy 390 ./qpoe/zzdebug.x procedure t_newcopy() +t_nsppkern 9 ./gio/nsppkern/t_nsppkern.x procedure t_nsppkern() +t_oldauto 11 ./gio/ncarutil/tests/oldauto.x procedure t_oldauto() +t_parsei 47 ./qpoe/zzdebug.x procedure t_parsei() +t_parser 106 ./qpoe/zzdebug.x procedure t_parser() +t_pbb 79 ./fio/zzdebug.x procedure t_pbb() +t_plotpoe 1304 ./qpoe/zzdebug.x procedure t_plotpoe() +t_pltest 131 ./plio/zzdebug.x procedure t_pltest() +t_pmtest 116 ./pmio/zzinterp.x procedure t_pmtest() +t_przs 7 ./gio/ncarutil/tests/pwrzs.x procedure t_przs() +t_put 75 ./etc/zzdebug.x procedure t_put() +t_pwrity 7 ./gio/ncarutil/tests/pwrity.x procedure t_pwrity() +t_qpparse 145 ./qpoe/zzdebug.x procedure t_qpparse() +t_realloc 35 ./memio/zzdebug.x procedure t_realloc() +t_realloc 139 ./memdbg/zzdebug.x procedure t_realloc() +t_rebuild 202 ./fmio/zzdebug.x procedure t_rebuild() +t_recio 310 ./qpoe/zzdebug.x procedure t_recio() +t_rewind 348 ./mtio/zzdebug.x procedure t_rewind() +t_rexec 14 ./ki/zzdebug.x procedure t_rexec() +t_rread 69 ./ki/zzdebug.x procedure t_rread() +t_rtype 47 ./ki/zzdebug.x procedure t_rtype() +t_save 386 ./mwcs/zzdebug.x procedure t_save() +t_script 1392 ./plio/zzdebug.x procedure t_script() +t_seefont 194 ./gio/nsppkern/zzdebug.x procedure t_seefont() +t_server 238 ./fio/zzdebug.x procedure t_server() +t_setfilt 1419 ./qpoe/zzdebug.x procedure t_setfilt() +t_setmask 1439 ./qpoe/zzdebug.x procedure t_setmask() +t_setwcs 1399 ./qpoe/zzdebug.x procedure t_setwcs() +t_sgidecode 13 ./gio/sgikern/t_sgideco.x procedure t_sgidecode() +t_sgikern 9 ./gio/sgikern/t_sgikern.x procedure t_sgikern() +t_show 171 ./fmio/zzdebug.x procedure t_show() +t_showcap 13 ./gio/stdgraph/t_showcap.x procedure t_showcap() +t_simple 21 ./mwcs/zzdebug.x procedure t_simple() +t_slio 5 ./gio/stdgraph/zzdebug.x procedure t_slio() +t_spawn 174 ./etc/zzdebug.x procedure t_spawn() +t_spool 169 ./fio/zzdebug.x procedure t_spool() +t_srch 283 ./fmtio/zzdebug.x procedure t_srch() +t_srftest 9 ./gio/ncarutil/tests/srftestd.x procedure t_srftest() +t_status 119 ./mtio/zzdebug.x procedure t_status() +t_stdgraph 12 ./gio/stdgraph/t_stdgraph.x procedure t_stdgraph() +t_strmln 10 ./gio/ncarutil/tests/strmln.x procedure t_strmln() +t_sum 9 ./plio/zzsum.x procedure t_sum() +t_sum 1364 ./qpoe/zzdebug.x procedure t_sum() +t_surface 10 ./gio/ncarutil/tests/surface.x procedure t_surface() +t_sym 24 ./symtab/zzdebug.x procedure t_sym() +t_syms 416 ./qpoe/zzdebug.x procedure t_syms() +t_testpoe 951 ./qpoe/zzdebug.x procedure t_testpoe() +t_text 142 ./gio/nsppkern/zzdebug.x procedure t_text() +t_tfilter 1107 ./qpoe/zzdebug.x procedure t_tfilter() +t_threed 10 ./gio/ncarutil/tests/threed.x procedure t_threed() +t_threed2 10 ./gio/ncarutil/tests/threed2.x procedure t_threed2() +t_tokens 164 ./qpoe/zzdebug.x procedure t_tokens() +t_tty 342 ./etc/zzdebug.x procedure t_tty() +t_txo 130 ./fio/zzdebug.x procedure t_txo() +t_txup 276 ./gio/nsppkern/zzdebug.x procedure t_txup() +t_type 148 ./fmio/zzdebug.x procedure t_type() +t_unget 58 ./fio/zzdebug.x procedure t_unget() +t_velvect 10 ./gio/ncarutil/tests/velvect.x procedure t_velvect() +t_vttest 22 ./gio/calcomp/vttest.x procedure t_vttest () +t_wcs 68 ./mwcs/zzdebug.x procedure t_wcs() +t_wtestfile 170 ./mtio/zzdebug.x procedure t_wtestfile() +tc_dummy_ttyload 357 ./tty/x_mkttydata.x int procedure tc_dummy_ttyload (termcap_file, devname, outstr, maxch) +tc_init_datac 318 ./tty/x_mkttydata.x procedure tc_init_datac (fd, varname, str, nchars) +tc_init_datai 275 ./tty/x_mkttydata.x procedure tc_init_datai (fd, varname, array, npix) +tc_putstr 181 ./tty/x_mkttydata.x int procedure tc_putstr (tc, str) +tc_write_data_declarations215 ./tty/x_mkttydata.x procedure tc_write_data_declarations (fd, tc, termcap_file) +tcopy_ 1 ./libc/zztest.c tcopy_() +testtext 393 ./gio/calcomp/vttest.x procedure testtext (gp, fname) +testxset 469 ./gio/calcomp/vttest.x procedure testxset (format) +tgettk_ 2 ./libc/zztest.c tgettk_() +thello_ 1 ./libc/zztest.c thello_() +ticks 301 ./gio/zzdebug.x procedure ticks() +to_short 120 ./gio/calcomp/vttest.x procedure to_short (x, y, npts, p) +tprint_ 1 ./libc/zztest.c tprint_() +tscan_ 1 ./libc/zztest.c tscan_() +tsleep 6 ./etc/tsleep.x procedure tsleep (seconds) +ttopen 10 ./etc/ttopen.x int procedure ttopen (terminal, mode) +ttseti 28 ./etc/ttopen.x procedure ttseti (fd, param, value) +ttsets 64 ./etc/ttopen.x procedure ttsets (fd, param, svalue) +ttstati 45 ./etc/ttopen.x int procedure ttstati (fd, param) +ttstats 81 ./etc/ttopen.x int procedure ttstats (fd, param, outstr, maxch) +tty_binsearch 122 ./tty/ttyindex.x int procedure tty_binsearch (capcode, t_capcode, ncaps) +tty_break_line 293 ./tty/ttyputl.x procedure tty_break_line (fd, tty, ostrike, op, so_type, so_seen) +tty_continue 14 ../unix/os/zfiotx.c tty_continue (sig, code, scp) +tty_encode_capability161 ./tty/ttyindex.x int procedure tty_encode_capability (cap) +tty_extract_alias 276 ./tty/ttyopen.x int procedure tty_extract_alias (str, ip, outstr, maxch) +tty_fetch_entry 139 ./tty/ttyopen.x procedure tty_fetch_entry (fd, device, tty) +tty_find_capability 88 ./tty/ttyindex.x int procedure tty_find_capability (tty, cap, ip) +tty_index_caps 18 ./tty/ttyindex.x procedure tty_index_caps (tty, t_capcode, t_capindex, ncaps) +tty_onsig 13 ../unix/os/zfiotx.c tty_onsig (sig, code, scp) +tty_rawon 11 ../unix/os/zfiotx.c tty_rawon (port, flags) +tty_reset 12 ../unix/os/zfiotx.c tty_reset (port) +tty_scan_termcap_file 71 ./tty/ttyopen.x procedure tty_scan_termcap_file (tty, termcap_file, devname) +tty_stop 13 ../unix/os/zfiotx.c tty_stop (sig, code, scp) +ttycaps 7 ./tty/ttycaps.x pointer procedure ttycaps (tty) +ttycdes 5 ./tty/ttycdes.x procedure ttycdes (tty) +ttyclear 8 ./tty/ttyclear.x procedure ttyclear (fd, tty) +ttyclearln 10 ./tty/ttyclln.x procedure ttyclearln (fd, tty) +ttyclose 5 ./tty/ttyclose.x procedure ttyclose (tty) +ttyctrl 8 ./tty/ttyctrl.x int procedure ttyctrl (fd, tty, cap, afflncnt) +ttydelay 9 ./tty/ttydelay.x procedure ttydelay (fd, tty, delay) +ttydevname 13 ./tty/ttydevnm.x procedure ttydevname (device, ldevice, maxch) +ttygdes 23 ./tty/ttygdes.x pointer procedure ttygdes (ttyname) +ttygetb 6 ./tty/ttygetb.x bool procedure ttygetb (tty, cap) +ttygeti 7 ./tty/ttygeti.x int procedure ttygeti (tty, cap) +ttygetr 9 ./tty/ttygetr.x real procedure ttygetr (tty, cap) +ttygets 23 ./tty/ttygets.x int procedure ttygets (tty, cap, outstr, maxch) +ttygoto 11 ./tty/ttygoto.x procedure ttygoto (fd, tty, col, line) +ttygputline 134 ./tty/ttyputl.x procedure ttygputline (fd, tty, text, map_cc) +ttygsize 16 ./tty/ttygsize.x procedure ttygsize (in, out, tty, width, height) +ttyinit 16 ./tty/ttyinit.x procedure ttyinit (fd, tty) +ttyload 15 ./tty/ttyload.x int procedure ttyload (fname, device, outstr, maxch) +ttyodes 33 ./tty/ttyodes.x pointer procedure ttyodes (ttyname) +ttyopen 13 ./tty/ttyopen.x pointer procedure ttyopen (termcap_file, device, ttyload) +ttyputline 36 ./tty/ttyputl.x procedure ttyputline (fd, tty, text, map_cc) +ttyputs 5 ./tty/ttyputs.x procedure ttyputs (fd, tty, ctrlstr, afflncnt) +ttyread 18 ./tty/ttyread.x int procedure ttyread (fd, tty, outbuf, maxch, patbuf, timeout) +ttyseti 11 ./tty/ttyseti.x procedure ttyseti (tty, parameter, value) +ttyso 5 ./tty/ttyso.x procedure ttyso (fd, tty, onflag) +ttystati 10 ./tty/ttystati.x int procedure ttystati (tty, parameter) +ttysubi 53 ./tty/ttysubi.x int procedure ttysubi (ctrlstr, outstr, maxch, coords, ncoords) +ttywrite 18 ./tty/ttywrite.x procedure ttywrite (fd, tty, ctrlstr, nchars, afflncnt) +u_allocstat 3 ../unix/os/zalloc.c u_allocstat (aliases) +u_crackformat 4 ./libc/scanf.c u_crackformat (format, fmt) +u_doarg 3 ./libc/printf.c u_doarg (fp, formspec, argp, prec, varprec, dtype)/ +u_doprnt 2 ./libc/printf.c u_doprnt (format, argp, fp) +u_doscan 3 ./libc/scanf.c u_doscan (in, format, argp) +u_scannum 5 ./libc/scanf.c u_scannum (in, argp, fmt, eofflag) +u_scanstr 8 ./libc/scanf.c u_scanstr (in, argp, fmt, eofflag) +u_setucc 7 ./libc/scanf.c u_setucc (format, fmt) +uid_executing 1 ../unix/os/getproc.c uid_executing (uid) +uio_bwrite 14 ../unix/os/zfiotx.c uio_bwrite (fp, buf, nbytes) +ungetc 1 ./libc/ungetc.c ungetc (ch, fp) +ungetc 20 ./fio/ungetc.x procedure ungetc (fd, ch) +ungetci 20 ./fio/ungetci.x procedure ungetci (fd, ch) +ungetline 19 ./fio/ungetline.x procedure ungetline (fd, str) +unread 14 ./fio/unread.x procedure unread (fd, buf, nchars) +urand 16 ./osb/urand.x real procedure urand (lseed) +vdm 374 ./gio/zzdebug.x procedure vdm() +vfn_decode 578 ./fio/vfntrans.x int procedure vfn_decode (osfn, ip, outstr, maxch) +vfn_encode 324 ./fio/vfntrans.x procedure vfn_encode (vfn, ip, root, lenroot, extn, lenextn) +vfn_enter 787 ./fio/vfnmap.x int procedure vfn_enter (vfd, osfn, maxch) +vfn_expand_ldir 141 ./fio/vfntrans.x procedure vfn_expand_ldir (vfn, outstr, maxch) +vfn_getosfn 870 ./fio/vfnmap.x int procedure vfn_getosfn (vfd, vfn, osfn, maxch) +vfn_is_hidden_file868 ./fio/vfntrans.x int procedure vfn_is_hidden_file (fname) +vfn_map_extension 678 ./fio/vfntrans.x procedure vfn_map_extension (iraf_extn, os_extn, maxch) +vfn_squeeze 842 ./fio/vfntrans.x procedure vfn_squeeze (root, outstr, maxch) +vfn_translate 50 ./fio/vfntrans.x procedure vfn_translate (rawvfn, osdir, lenosdir, root, lenroot, extn, lenextn) +vfn_unmap_extension733 ./fio/vfntrans.x procedure vfn_unmap_extension (os_extn, iraf_extn, maxch) +vfnadd 295 ./fio/vfnmap.x int procedure vfnadd (vfd, osfn, maxch) +vfnclose 502 ./fio/vfnmap.x procedure vfnclose (vfd, update_enable) +vfndel 332 ./fio/vfnmap.x int procedure vfndel (vfd, osfn, maxch) +vfnmap 211 ./fio/vfnmap.x int procedure vfnmap (vfd, osfn, maxch) +vfnmapu 231 ./fio/vfnmap.x int procedure vfnmapu (vfd, osfn, maxch) +vfnopen 134 ./fio/vfnmap.x pointer procedure vfnopen (vfn, mode) +vfnunmap 417 ./fio/vfnmap.x int procedure vfnunmap (vfd, osfn, vfn, maxch) +vmalloc 14 ./memdbg/vmalloc.x procedure vmalloc (ubufp, nelems, dtype) +vmalloc 14 ./memio/vmalloc.x procedure vmalloc (ubufp, nelems, dtype) +vvfn_checksum 603 ./fio/vfnmap.x int procedure vvfn_checksum (a, nchars) +vvfn_escape 555 ./fio/vfntrans.x procedure vvfn_escape (ch, outbuf, op, maxch) +vvfn_init_extnmap 793 ./fio/vfntrans.x procedure vvfn_init_extnmap (map, iraf, os, nextn, max_extn) +vvfn_init_reserved_extns908 ./fio/vfntrans.x procedure vvfn_init_reserved_extns (ex, extn, max_extn, nextn) +vvfn_readmapfile 621 ./fio/vfnmap.x procedure vvfn_readmapfile (vfd) +wf_ait_fwd 286 ./mwcs/wfait.x procedure wf_ait_fwd (fc, p, w) +wf_ait_init 55 ./mwcs/wfait.x procedure wf_ait_init (fc, dir) +wf_ait_inv 395 ./mwcs/wfait.x procedure wf_ait_inv (fc, w, p) +wf_arc_fwd 70 ./mwcs/wfarc.x procedure wf_arc_fwd (fc, p, w) +wf_arc_init 35 ./mwcs/wfarc.x procedure wf_arc_init (fc, dir) +wf_arc_inv 129 ./mwcs/wfarc.x procedure wf_arc_inv (fc, w, p) +wf_car_fwd 281 ./mwcs/wfcar.x procedure wf_car_fwd (fc, p, w) +wf_car_init 53 ./mwcs/wfcar.x procedure wf_car_init (fc, dir) +wf_car_inv 372 ./mwcs/wfcar.x procedure wf_car_inv (fc, w, p) +wf_csc_fwd 282 ./mwcs/wfcsc.x procedure wf_csc_fwd (fc, p, w) +wf_csc_init 51 ./mwcs/wfcsc.x procedure wf_csc_init (fc, dir) +wf_csc_inv 450 ./mwcs/wfcsc.x procedure wf_csc_inv (fc, w, p) +wf_decaxis 9 ./mwcs/wfdecaxis.x procedure wf_decaxis (fc, ira, idec) +wf_fnload 96 ./mwcs/wfinit.x procedure wf_fnload (name, flags, init, destroy, fwd, inv) +wf_gls_fwd 280 ./mwcs/wfgls.x procedure wf_gls_fwd (fc, p, w) +wf_gls_init 53 ./mwcs/wfgls.x procedure wf_gls_init (fc, dir) +wf_gls_inv 375 ./mwcs/wfgls.x procedure wf_gls_inv (fc, w, p) +wf_init 12 ./mwcs/wfinit.x procedure wf_init() +wf_mer_fwd 285 ./mwcs/wfmer.x procedure wf_mer_fwd (fc, p, w) +wf_mer_init 53 ./mwcs/wfmer.x procedure wf_mer_init (fc, dir) +wf_mer_inv 376 ./mwcs/wfmer.x procedure wf_mer_inv (fc, w, p) +wf_mol_fwd 286 ./mwcs/wfmol.x procedure wf_mol_fwd (fc, p, w) +wf_mol_init 56 ./mwcs/wfmol.x procedure wf_mol_init (fc, dir) +wf_mol_inv 421 ./mwcs/wfmol.x procedure wf_mol_inv (fc, w, p) +wf_msp_coeff 336 ./mwcs/wfmspec.x procedure wf_msp_coeff (atval, coeff, xmin, xmax) +wf_msp_destroy 233 ./mwcs/wfmspec.x procedure wf_msp_destroy (fc) +wf_msp_eval 405 ./mwcs/wfmspec.x double procedure wf_msp_eval (coeff, xin) +wf_msp_evali 508 ./mwcs/wfmspec.x double procedure wf_msp_evali (coeff, y, x, dydx) +wf_msp_fwd 257 ./mwcs/wfmspec.x procedure wf_msp_fwd (fc, in, out) +wf_msp_init 95 ./mwcs/wfmspec.x procedure wf_msp_init (fc, dir) +wf_msp_inv 292 ./mwcs/wfmspec.x procedure wf_msp_inv (fc, in, out) +wf_par_fwd 284 ./mwcs/wfpar.x procedure wf_par_fwd (fc, p, w) +wf_par_init 54 ./mwcs/wfpar.x procedure wf_par_init (fc, dir) +wf_par_inv 391 ./mwcs/wfpar.x procedure wf_par_inv (fc, w, p) +wf_pco_fwd 287 ./mwcs/wfpco.x procedure wf_pco_fwd (fc, p, w) +wf_pco_init 55 ./mwcs/wfpco.x procedure wf_pco_init (fc, dir) +wf_pco_inv 442 ./mwcs/wfpco.x procedure wf_pco_inv (fc, w, p) +wf_qsc_fwd 283 ./mwcs/wfqsc.x procedure wf_qsc_fwd (fc, p, w) +wf_qsc_init 53 ./mwcs/wfqsc.x procedure wf_qsc_init (fc, dir) +wf_qsc_inv 527 ./mwcs/wfqsc.x procedure wf_qsc_inv (fc, w, p) +wf_sin_fwd 70 ./mwcs/wfsin.x procedure wf_sin_fwd (fc, p, w) +wf_sin_init 35 ./mwcs/wfsin.x procedure wf_sin_init (fc, dir) +wf_sin_inv 122 ./mwcs/wfsin.x procedure wf_sin_inv (fc, w, p) +wf_smp_binsearch 180 ./mwcs/wfsamp.x int procedure wf_smp_binsearch (x, v, npts) +wf_smp_ctran 98 ./mwcs/wfsamp.x procedure wf_smp_ctran (fc, a_x, a_y) +wf_smp_init 36 ./mwcs/wfsamp.x procedure wf_smp_init (fc, dir) +wf_stg_fwd 161 ./mwcs/wfstg.x procedure wf_stg_fwd (fc, p, w) +wf_stg_init 50 ./mwcs/wfstg.x procedure wf_stg_init (fc, dir) +wf_stg_inv 256 ./mwcs/wfstg.x procedure wf_stg_inv (fc, w, p) +wf_tan_fwd 69 ./mwcs/wftan.x procedure wf_tan_fwd (fc, p, w) +wf_tan_init 34 ./mwcs/wftan.x procedure wf_tan_init (fc, dir) +wf_tan_inv 116 ./mwcs/wftan.x procedure wf_tan_inv (fc, w, p) +wf_tsc_fwd 281 ./mwcs/wftsc.x procedure wf_tsc_fwd (fc, p, w) +wf_tsc_init 53 ./mwcs/wftsc.x procedure wf_tsc_init (fc, dir) +wf_tsc_inv 411 ./mwcs/wftsc.x procedure wf_tsc_inv (fc, w, p) +wf_zea_fwd 160 ./mwcs/wfzea.x procedure wf_zea_fwd (fc, p, w) +wf_zea_init 48 ./mwcs/wfzea.x procedure wf_zea_init (fc, dir) +wf_zea_inv 259 ./mwcs/wfzea.x procedure wf_zea_inv (fc, w, p) +write 11 ./fio/write.x procedure write (fd, buffer, maxchars) +writeb 18 ./gio/nsppkern/writeb.x procedure writeb (metacode_buffer, buflen, mbunit) +xallocate 38 ./etc/xalloc.x int procedure xallocate (device) +xdeallocate 74 ./etc/xalloc.x int procedure xdeallocate (device, rewind) +xdevowner 166 ./etc/xalloc.x int procedure xdevowner (device, owner, maxch) +xdevstatus 124 ./etc/xalloc.x procedure xdevstatus (device, out) +xer_fmterrmsg 11 ./etc/xerfmt.x procedure xer_fmterrmsg (errmsg, outstr, maxch) +xer_putline 12 ./etc/xerpue.x procedure xer_putline (fd, text) +xer_reset 9 ./etc/xerreset.x procedure xer_reset() +xer_send_error_statement_to_cl 19 ./etc/xerstmt.x procedure xer_send_error_statement_to_cl (errcode) +xer_verify 10 ./etc/xerverify.x procedure xer_verify() +xeract 44 ./etc/error.x procedure xeract (error_code, message, severity) +xerpop 25 ./etc/xerpop.x bool procedure xerpop() +xerpopi 41 ./etc/xerpop.x int procedure xerpopi() +xerpsh 10 ./etc/xerpop.x procedure xerpsh() +xerpstr 58 ./etc/xerstmt.x procedure xerpstr (str) +xerputc 13 ./fio/xerputc.x procedure xerputc (ch) +xev_addarg 783 ./fmtio/evexpr.x procedure xev_addarg (arg, arglist, out) +xev_binop 184 ./fmtio/evexpr.x procedure xev_binop (opcode, in1, in2, out) +xev_boolop 278 ./fmtio/evexpr.x procedure xev_boolop (opcode, in1, in2, out) +xev_callfcn 484 ./fmtio/evexpr.x procedure xev_callfcn (fcn, args, nargs, out) +xev_error 855 ./fmtio/evexpr.x procedure xev_error (errmsg) +xev_error1 811 ./fmtio/evexpr.x procedure xev_error1 (fmt, arg) +xev_error2 832 ./fmtio/evexpr.x procedure xev_error2 (fmt, arg1, arg2) +xev_freeop 1089 ./fmtio/evexpr.x procedure xev_freeop (o) +xev_gettok 868 ./fmtio/evexpr.x int procedure xev_gettok (ip, out) +xev_initop 1043 ./fmtio/evexpr.x procedure xev_initop (o, o_len, o_type) +xev_makeop 1058 ./fmtio/evexpr.x procedure xev_makeop (o, o_len, o_type) +xev_newtype 429 ./fmtio/evexpr.x int procedure xev_newtype (type1, type2) +xev_patmatch 389 ./fmtio/evexpr.x int procedure xev_patmatch (str, pat) +xev_quest 459 ./fmtio/evexpr.x procedure xev_quest (cond, trueop, falseop, out) +xev_startarglist 758 ./fmtio/evexpr.x procedure xev_startarglist (arg, out) +xev_unop 138 ./fmtio/evexpr.x procedure xev_unop (opcode, in, out) +xgdevlist 17 ./etc/xgdevlist.x int procedure xgdevlist (device, outstr, maxch, onedev) +xisatty 8 ./etc/xisatty.x int procedure xisatty (fd) +xmjbuf 8 ./etc/xmjbuf.x procedure xmjbuf (bp) +xonerror 74 ./etc/onerror.x procedure xonerror (status) +xonexit 72 ./etc/onexit.x procedure xonexit (exit_code) +xori 5 ./osb/xor.x int procedure xori (a, b) +xorl 29 ./osb/xor.x long procedure xorl (a, b) +xors 17 ./osb/xor.x short procedure xors (a, b) +xpagefiles 115 ./etc/pagefiles.x procedure xpagefiles (files, device, prompt, first_page, clear_screen, map_cc) +xstdexh 32 ./etc/maideh.x procedure xstdexh (exception, next_handler) +xtoc 6 ./fmtio/xtoc.x int procedure xtoc (xval, outstr, maxch, decpl, fmt, width) +xttysize 14 ./etc/xttysize.x procedure xttysize (width, height) +xvv_addarg 3793 ./fmtio/evvexpr.x procedure xvv_addarg (arg, arglist, out) +xvv_binop 389 ./fmtio/evvexpr.x procedure xvv_binop (opcode, in1, in2, out) +xvv_boolop 960 ./fmtio/evvexpr.x procedure xvv_boolop (opcode, in1, in2, out) +xvv_callfcn 1846 ./fmtio/evvexpr.x procedure xvv_callfcn (fcn, args, nargs, out) +xvv_chtype 4072 ./fmtio/evvexpr.x procedure xvv_chtype (o1, o2, dtype) +xvv_error 3867 ./fmtio/evvexpr.x procedure xvv_error (errmsg) +xvv_error1 3821 ./fmtio/evvexpr.x procedure xvv_error1 (fmt, arg) +xvv_error2 3843 ./fmtio/evvexpr.x procedure xvv_error2 (fmt, arg1, arg2) +xvv_freeop 4382 ./fmtio/evvexpr.x procedure xvv_freeop (o) +xvv_gettok 3880 ./fmtio/evvexpr.x int procedure xvv_gettok (ip, out) +xvv_initop 4327 ./fmtio/evvexpr.x procedure xvv_initop (o, o_len, o_type) +xvv_loadsymbols 4411 ./fmtio/evvexpr.x pointer procedure xvv_loadsymbols (s) +xvv_makeop 4342 ./fmtio/evvexpr.x procedure xvv_makeop (o, o_len, o_type) +xvv_newtype 1509 ./fmtio/evvexpr.x int procedure xvv_newtype (type1, type2) +xvv_nulld 4482 ./fmtio/evvexpr.x double procedure xvv_nulld (ignore) +xvv_nulli 4464 ./fmtio/evvexpr.x int procedure xvv_nulli (ignore) +xvv_nulll 4470 ./fmtio/evvexpr.x long procedure xvv_nulll (ignore) +xvv_nullr 4476 ./fmtio/evvexpr.x real procedure xvv_nullr (ignore) +xvv_nulls 4458 ./fmtio/evvexpr.x short procedure xvv_nulls (ignore) +xvv_patmatch 1469 ./fmtio/evvexpr.x int procedure xvv_patmatch (str, pat) +xvv_quest 1545 ./fmtio/evvexpr.x procedure xvv_quest (cond, in1, in2, out) +xvv_startarglist 3769 ./fmtio/evvexpr.x procedure xvv_startarglist (arg, out) +xvv_unop 265 ./fmtio/evvexpr.x procedure xvv_unop (opcode, in, out) +xwhen 5 ./etc/xwhen.x procedure xwhen (signal, handler, old_handler) +yyparse 1134 ./fmtio/evexpr.x int procedure yyparse (fd, yydebug, yylex) +yyparse 4521 ./fmtio/evvexpr.x int procedure yyparse (fd, yydebug, yylex) +zardmt 10 ./mtio/zardmt.x procedure zardmt (mtchan, buf, maxbytes, offset) +zardnu 121 ./fio/nullfile.x procedure zardnu (chan, buf, maxbytes, loffset) +zardps 124 ./clio/zfiocl.x procedure zardps (ps, buf, maxbytes, offset) +zawrmt 10 ./mtio/zawrmt.x procedure zawrmt (mtchan, buf, nbytes, offset) +zawrnu 136 ./fio/nullfile.x procedure zawrnu (chan, buf, nbytes, loffset) +zawrps 202 ./clio/zfiocl.x procedure zawrps (ps, buf, nbytes, offset) +zawtmt 10 ./mtio/zawtmt.x procedure zawtmt (mtchan, status) +zawtnu 151 ./fio/nullfile.x procedure zawtnu (chan, status) +zawtps 237 ./clio/zfiocl.x procedure zawtps (ps, status) +zclsmt 17 ./mtio/zclsmt.x procedure zclsmt (mtchan, status) +zclsnu 72 ./fio/nullfile.x procedure zclsnu (chan, status) +zclsps 88 ./clio/zfiocl.x procedure zclsps (chan, status) +zclstt 1209 ./fio/zfiott.x procedure zclstt (fd, status) +zflsnu 203 ./fio/nullfile.x procedure zflsnu (chan, status) +zflstt 1221 ./fio/zfiott.x procedure zflstt (fd, status) +zgetnu 169 ./fio/nullfile.x procedure zgetnu (chan, buf, maxch, status) +zgettt 47 ./fio/zfiott.x procedure zgettt (fd, buf, maxch, status) +zmtbsf 24 ../unix/os/zfiomt.c zmtbsf (fd, nfiles) +zmtbsr 25 ../unix/os/zfiomt.c zmtbsr (fd, nrecords) +zmtclose 17 ../unix/os/zfiomt.c zmtclose (fd) +zmtdbg 28 ../unix/os/zfiomt.c zmtdbg (mp, msg) +zmtdbg1 28 ../unix/os/zfiomt.c zmtdbg1 (mp, fmt, arg) +zmtdbg2 29 ../unix/os/zfiomt.c zmtdbg2 (mp, fmt, arg1, arg2) +zmtdbg3 29 ../unix/os/zfiomt.c zmtdbg3 (mp, fmt, arg1, arg2, arg3) +zmtdbg4 29 ../unix/os/zfiomt.c zmtdbg4 (mp, fmt, arg1, arg2, arg3, arg4) +zmtdbg5 29 ../unix/os/zfiomt.c zmtdbg5 (mp, fmt, arg1, arg2, arg3, arg4, arg5) +zmtdbgclose 28 ../unix/os/zfiomt.c zmtdbgclose (mp) +zmtdbgopen 26 ../unix/os/zfiomt.c zmtdbgopen (mp) +zmtdesc 17 ../unix/os/zfiomt.c zmtdesc (device, acmode, devcap, devpos) +zmtfls 28 ../unix/os/zfiomt.c zmtfls (mp) +zmtfpos 20 ../unix/os/zfiomt.c zmtfpos (mp, newfile) +zmtfree 20 ../unix/os/zfiomt.c zmtfree (mp) +zmtfsf 24 ../unix/os/zfiomt.c zmtfsf (fd, nfiles) +zmtfsr 24 ../unix/os/zfiomt.c zmtfsr (fd, nrecords) +zmtgetfd 15 ../unix/os/zfiomt.c zmtgetfd (mp) +zmtopen 16 ../unix/os/zfiomt.c zmtopen (dev, u_acmode) +zmtrew 23 ../unix/os/zfiomt.c zmtrew (fd) +znotnu 237 ./fio/nullfile.x procedure znotnu (chan, loffset) +znottt 1249 ./fio/zfiott.x procedure znottt (fd, offset) +zopnmt 11 ./mtio/zopnmt.x procedure zopnmt (iodev, acmode, mtchan) +zopnnu 26 ./fio/nullfile.x procedure zopnnu (osfn, mode, chan) +zopntt 1196 ./fio/zfiott.x procedure zopntt (osfn, mode, chan) +zputnu 186 ./fio/nullfile.x procedure zputnu (chan, buf, nchars, status) +zputtt 176 ./fio/zfiott.x procedure zputtt (fd, buf, nchars, status) +zseknu 220 ./fio/nullfile.x procedure zseknu (chan, loffset, status) +zsektt 1235 ./fio/zfiott.x procedure zsektt (fd, offset, status) +zsestt 1129 ./fio/zfiott.x procedure zsestt (fd, param, svalue) +zsettt 972 ./fio/zfiott.x procedure zsettt (chan, param, value) +zststt 1159 ./fio/zfiott.x procedure zststt (fd, param, outstr, maxch, nchars) +zsttmt 11 ./mtio/zsttmt.x procedure zsttmt (mtchan, what, lvalue) +zsttnu 93 ./fio/nullfile.x procedure zsttnu (chan, param, lvalue) +zsttps 252 ./clio/zfiocl.x procedure zsttps (ps, what, lvalue) +zstttt 1074 ./fio/zfiott.x procedure zstttt (fd, param, lvalue) +ztt_getchar 850 ./fio/zfiott.x int procedure ztt_getchar (chan, ch) +ztt_getlog 537 ./fio/zfiott.x procedure ztt_getlog (chan, obuf, maxch, nchars) +ztt_logdev 422 ./fio/zfiott.x procedure ztt_logdev (chan) +ztt_logio 238 ./fio/zfiott.x procedure ztt_logio (inflag, outflag) +ztt_lowercase 882 ./fio/zfiott.x int procedure ztt_lowercase (in, out, nchars) +ztt_pboff 400 ./fio/zfiott.x procedure ztt_pboff (errcode) +ztt_playback 335 ./fio/zfiott.x procedure ztt_playback (flag) +ztt_putlog 462 ./fio/zfiott.x procedure ztt_putlog (chan, dstr, nchars) +ztt_query 667 ./fio/zfiott.x int procedure ztt_query (logtext, nchars, dtext, maxch, sz_dtext) +ztt_ttyput 954 ./fio/zfiott.x procedure ztt_ttyput (message) +ztt_uppercase 934 ./fio/zfiott.x procedure ztt_uppercase (in, out, nchars) +zz_help 266 ./symtab/zzdebug.x procedure zz_help (fd) diff --git a/sys/NAMES b/sys/NAMES new file mode 100644 index 00000000..084bddf0 --- /dev/null +++ b/sys/NAMES @@ -0,0 +1,3884 @@ +_ev_loadcache _ev_loadcache +_ev_scaniraf _ev_scaniraf +_ev_streq _ev_streq +_getfile _getfile +_u_fmode _u_fmode +aabs aabs +aabsd aabsd +aabsi aabsi +aabsl aabsl +aabsr aabsr +aabss aabss +aabsx aabsx +aadd aadd +aaddd aaddd +aaddi aaddi +aaddk aaddk +aaddkd aaddkd +aaddki aaddki +aaddkl aaddkl +aaddkr aaddkr +aaddks aaddks +aaddkx aaddkx +aaddl aaddl +aaddr aaddr +aadds aadds +aaddx aaddx +aand aand +aandi aandi +aandk aandk +aandki aandki +aandkl aandkl +aandks aandks +aandl aandl +aands aands +aavg aavg +aavgd aavgd +aavgi aavgi +aavgl aavgl +aavgr aavgr +aavgs aavgs +aavgx aavgx +abav abav +abavd abavd +abavi abavi +abavl abavl +abavr abavr +abavs abavs +abavx abavx +abeq abeq +abeqc abeqc +abeqd abeqd +abeqi abeqi +abeqk abeqk +abeqkc abeqkc +abeqkd abeqkd +abeqki abeqki +abeqkl abeqkl +abeqkr abeqkr +abeqks abeqks +abeqkx abeqkx +abeql abeql +abeqr abeqr +abeqs abeqs +abeqx abeqx +abge abge +abgec abgec +abged abged +abgei abgei +abgek abgek +abgekc abgekc +abgekd abgekd +abgeki abgeki +abgekl abgekl +abgekr abgekr +abgeks abgeks +abgekx abgekx +abgel abgel +abger abger +abges abges +abgex abgex +abgt abgt +abgtc abgtc +abgtd abgtd +abgti abgti +abgtk abgtk +abgtkc abgtkc +abgtkd abgtkd +abgtki abgtki +abgtkl abgtkl +abgtkr abgtkr +abgtks abgtks +abgtkx abgtkx +abgtl abgtl +abgtr abgtr +abgts abgts +abgtx abgtx +able able +ablec ablec +abled abled +ablei ablei +ablek ablek +ablekc ablekc +ablekd ablekd +ableki ableki +ablekl ablekl +ablekr ablekr +ableks ableks +ablekx ablekx +ablel ablel +abler abler +ables ables +ablex ablex +ablt ablt +abltc abltc +abltd abltd +ablti ablti +abltk abltk +abltkc abltkc +abltkd abltkd +abltki abltki +abltkl abltkl +abltkr abltkr +abltks abltks +abltkx abltkx +abltl abltl +abltr abltr +ablts ablts +abltx abltx +abne abne +abnec abnec +abned abned +abnei abnei +abnek abnek +abnekc abnekc +abnekd abnekd +abneki abneki +abnekl abnekl +abnekr abnekr +abneks abneks +abnekx abnekx +abnel abnel +abner abner +abnes abnes +abnex abnex +abor abor +abori abori +abork abork +aborki aborki +aborkl aborkl +aborks aborks +aborl aborl +abors abors +absu absu +absud absud +absui absui +absul absul +absur absur +absus absus +acht acht +acht acht +achtb achtb +achtc achtc +achtcc achtcc +achtcd achtcd +achtci achtci +achtcl achtcl +achtcr achtcr +achtcs achtcs +achtcx achtcx +achtd achtd +achtdc achtdc +achtdd achtdd +achtdi achtdi +achtdl achtdl +achtdr achtdr +achtds achtds +achtdx achtdx +achti achti +achtic achtic +achtid achtid +achtii achtii +achtil achtil +achtir achtir +achtis achtis +achtix achtix +achtl achtl +achtlc achtlc +achtld achtld +achtli achtli +achtll achtll +achtlr achtlr +achtls achtls +achtlx achtlx +achtr achtr +achtrc achtrc +achtrd achtrd +achtri achtri +achtrl achtrl +achtrr achtrr +achtrs achtrs +achtrx achtrx +achts achts +achtsc achtsc +achtsd achtsd +achtsi achtsi +achtsl achtsl +achtsr achtsr +achtss achtss +achtsx achtsx +achtu achtu +achtx achtx +achtxc achtxc +achtxd achtxd +achtxi achtxi +achtxl achtxl +achtxr achtxr +achtxs achtxs +achtxx achtxx +acjgx acjgx +acjgx acjgx +aclr aclr +aclrc aclrc +aclrd aclrd +aclri aclri +aclrl aclrl +aclrr aclrr +aclrs aclrs +aclrx aclrx +acnv acnv +acnvd acnvd +acnvi acnvi +acnvl acnvl +acnvr acnvr +acnvr acnvr +acnvrd acnvrd +acnvri acnvri +acnvrl acnvrl +acnvrr acnvrr +acnvrs acnvrs +acnvs acnvs +adiv adiv +adivd adivd +adivi adivi +adivk adivk +adivkd adivkd +adivki adivki +adivkl adivkl +adivkr adivkr +adivks adivks +adivkx adivkx +adivl adivl +adivr adivr +adivs adivs +adivx adivx +adjust adjust +adot adot +adot adot +adotd adotd +adoti adoti +adotl adotl +adotr adotr +adots adots +adotx adotx +advz advz +advzd advzd +advzi advzi +advzl advzl +advzr advzr +advzs advzs +advzx advzx +aelogd aelogd +aelogr aelogr +aexp aexp +aexpd aexpd +aexpi aexpi +aexpk aexpk +aexpkd aexpkd +aexpki aexpki +aexpkl aexpkl +aexpkr aexpkr +aexpks aexpks +aexpkx aexpkx +aexpl aexpl +aexpr aexpr +aexps aexps +aexpx aexpx +afftrr afftrr +afftrr afftrr +afftrx afftrx +afftrx afftrx +afftxr afftxr +afftxr afftxr +afftxx afftxx +afftxx afftxx +aglt aglt +agltc agltc +agltd agltd +aglti aglti +agltl agltl +agltr agltr +aglts aglts +agltx agltx +ahgm ahgm +ahgmc ahgmc +ahgmd ahgmd +ahgmi ahgmi +ahgml ahgml +ahgmr ahgmr +ahgms ahgms +ahiv ahiv +ahivc ahivc +ahivd ahivd +ahivi ahivi +ahivl ahivl +ahivr ahivr +ahivs ahivs +ahivx ahivx +aiftrr aiftrr +aiftrr aiftrr +aiftrx aiftrx +aiftrx aiftrx +aiftxr aiftxr +aiftxr aiftxr +aiftxx aiftxx +aiftxx aiftxx +aimg aimg +aimgd aimgd +aimgi aimgi +aimgl aimgl +aimgr aimgr +aimgs aimgs +alim alim +alimc alimc +alimd alimd +alimi alimi +aliml aliml +alimr alimr +alims alims +alimx alimx +alln alln +allnd allnd +allni allni +allnl allnl +allnr allnr +allns allns +allnx allnx +alloc alloc +alog alog +alogd alogd +alogi alogi +alogl alogl +alogr alogr +alogs alogs +alogx alogx +alov alov +alovc alovc +alovd alovd +alovi alovi +alovl alovl +alovr alovr +alovs alovs +alovx alovx +alta alta +altad altad +altai altai +altal altal +altar altar +altas altas +altax altax +altm altm +altmd altmd +altmi altmi +altml altml +altmr altmr +altms altms +altmx altmx +altr altr +altrd altrd +altri altri +altrl altrl +altrr altrr +altrs altrs +altrx altrx +alui alui +aluid aluid +aluii aluii +aluil aluil +aluir aluir +aluis aluis +alut alut +alutc alutc +alutd alutd +aluti aluti +alutl alutl +alutr alutr +aluts aluts +amag amag +amagd amagd +amagi amagi +amagl amagl +amagr amagr +amags amags +amagx amagx +amap amap +amapd amapd +amapi amapi +amapl amapl +amapr amapr +amaps amaps +amax amax +amaxc amaxc +amaxd amaxd +amaxi amaxi +amaxk amaxk +amaxkc amaxkc +amaxkd amaxkd +amaxki amaxki +amaxkl amaxkl +amaxkr amaxkr +amaxks amaxks +amaxkx amaxkx +amaxl amaxl +amaxr amaxr +amaxs amaxs +amaxx amaxx +amed amed +amed3 amed3 +amed3c amed3c +amed3d amed3d +amed3i amed3i +amed3l amed3l +amed3r amed3r +amed3s amed3s +amed4 amed4 +amed4c amed4c +amed4d amed4d +amed4i amed4i +amed4l amed4l +amed4r amed4r +amed4s amed4s +amed5 amed5 +amed5c amed5c +amed5d amed5d +amed5i amed5i +amed5l amed5l +amed5r amed5r +amed5s amed5s +amedc amedc +amedd amedd +amedi amedi +amedl amedl +amedr amedr +ameds ameds +amedx amedx +amgs amgs +amgsd amgsd +amgsi amgsi +amgsl amgsl +amgsr amgsr +amgss amgss +amgsx amgsx +amin amin +aminc aminc +amind amind +amini amini +amink amink +aminkc aminkc +aminkd aminkd +aminki aminki +aminkl aminkl +aminkr aminkr +aminks aminks +aminkx aminkx +aminl aminl +aminr aminr +amins amins +aminx aminx +amod amod +amodd amodd +amodi amodi +amodk amodk +amodkd amodkd +amodki amodki +amodkl amodkl +amodkr amodkr +amodks amodks +amodl amodl +amodr amodr +amods amods +amov amov +amovc amovc +amovd amovd +amovi amovi +amovk amovk +amovkc amovkc +amovkd amovkd +amovki amovki +amovkl amovkl +amovkr amovkr +amovks amovks +amovkx amovkx +amovl amovl +amovr amovr +amovs amovs +amovx amovx +amul amul +amuld amuld +amuli amuli +amulk amulk +amulkd amulkd +amulki amulki +amulkl amulkl +amulkr amulkr +amulks amulks +amulkx amulkx +amull amull +amulr amulr +amuls amuls +amulx amulx +aneg aneg +anegd anegd +anegi anegi +anegl anegl +anegr anegr +anegs anegs +anegx anegx +anot anot +anoti anoti +anotl anotl +anots anots +apkx apkx +apkxd apkxd +apkxi apkxi +apkxl apkxl +apkxr apkxr +apkxs apkxs +apkxx apkxx +apol apol +apold apold +apolr apolr +apow apow +apowd apowd +apowi apowi +apowk apowk +apowkd apowkd +apowki apowki +apowkl apowkl +apowkr apowkr +apowks apowks +apowkx apowkx +apowl apowl +apowr apowr +apows apows +apowx apowx +arav arav +aravd aravd +aravi aravi +aravl aravl +aravr aravr +aravs aravs +aravx aravx +arcp arcp +arcpd arcpd +arcpi arcpi +arcpl arcpl +arcpr arcpr +arcps arcps +arcpx arcpx +arcz arcz +arczd arczd +arczi arczi +arczl arczl +arczr arczr +arczs arczs +arczx arczx +aread aread +areadb areadb +argt argt +argtd argtd +argti argti +argtl argtl +argtr argtr +argts argts +argtx argtx +arlt arlt +arltd arltd +arlti arlti +arltl arltl +arltr arltr +arlts arlts +arltx arltx +asel asel +aselc aselc +aseld aseld +aseli aseli +aselk aselk +aselkc aselkc +aselkd aselkd +aselki aselki +aselkl aselkl +aselkr aselkr +aselks aselks +aselkx aselkx +asell asell +aselr aselr +asels asels +aselx aselx +asok asok +asokc asokc +asokd asokd +asoki asoki +asokl asokl +asokr asokr +asoks asoks +asokx asokx +asqr asqr +asqrd asqrd +asqri asqri +asqrl asqrl +asqrr asqrr +asqrs asqrs +asqrx asqrx +asrt asrt +asrtc asrtc +asrtd asrtd +asrti asrti +asrtl asrtl +asrtr asrtr +asrts asrts +asrtx asrtx +assq assq +assq assq +assq assq +assqd assqd +assqi assqi +assql assql +assqr assqr +assqs assqs +assqx assqx +asub asub +asubd asubd +asubi asubi +asubk asubk +asubkd asubkd +asubki asubki +asubkl asubkl +asubkr asubkr +asubks asubks +asubkx asubkx +asubl asubl +asubr asubr +asubs asubs +asubx asubx +asum asum +asum asum +asum asum +asumd asumd +asumi asumi +asuml asuml +asumr asumr +asums asums +asumx asumx +aupx aupx +aupxd aupxd +aupxi aupxi +aupxl aupxl +aupxr aupxr +aupxs aupxs +aupxx aupxx +aveq aveq +aveqc aveqc +aveqd aveqd +aveqi aveqi +aveql aveql +aveqr aveqr +aveqs aveqs +aveqx aveqx +await await +awaitb awaitb +awritb awriteb +awrite awrite +awsu awsu +awsud awsud +awsui awsui +awsul awsul +awsur awsur +awsus awsus +awsux awsux +awvg awvg +awvgd awvgd +awvgi awvgi +awvgl awvgl +awvgr awvgr +awvgs awvgs +awvgx awvgx +axor axor +axori axori +axork axork +axorki axorki +axorkl axorkl +axorks axorks +axorl axorl +axors axors +balls balls +begmem begmem +begmem begmem +bfalcx bfalcx +bfaloc bfaloc +bfbsiz bfbsiz +bfchan bfchan +bfclos bfclos +bffill bffill +bfflsh bfflsh +bffsiz bffsiz +bfmode bfmode +bfopen bfopen +bfopnx bfopnx +bfread bfread +bfrseq bfrseq +bfseek bfseek +bfwrit bfwrit +bfwseq bfwseq +bitmov bitmov +blockt blockit +brktie brktime +btoi btoi +c_access c_access +c_allocate c_allocate +c_clktime c_clktime +c_close c_close +c_cnvdate c_cnvdate +c_cnvtime c_cnvtime +c_cputime c_cputime +c_deallocate c_deallocate +c_delete c_delete +c_devowner c_devowner +c_devstatus c_devstatus +c_envfind c_envfind +c_envfree c_envfree +c_envgb c_envgetb +c_envgi c_envgeti +c_envgs c_envgets +c_envlist c_envlist +c_envmark c_envmark +c_envputs c_envputs +c_envreset c_envreset +c_envscan c_envscan +c_erract c_erract +c_errcode c_errcode +c_errget c_errget +c_error c_error +c_fchdir c_fchdir +c_filbuf c_filbuf +c_finfo c_finfo +c_flsbuf c_flsbuf +c_flush c_flush +c_fmapfn c_fmapfn +c_fmkdir c_fmkdir +c_fnextn c_fnextn +c_fnldir c_fnldir +c_fnroot c_fnroot +c_fpathname c_fpathname +c_fprintf c_fprintf +c_fredir c_fredir +c_fseti c_fseti +c_fstati c_fstati +c_getpid c_getpid +c_getuid c_getuid +c_gflush c_gflush +c_imaccess c_imaccess +c_imdrcur c_imdrcur +c_kimapchan c_kimapchan +c_lexnum c_lexnum +c_mktemp c_mktemp +c_note c_note +c_open c_open +c_oscmd c_oscmd +c_pargb c_pargb +c_pargc c_pargc +c_pargd c_pargd +c_pargi c_pargi +c_pargl c_pargl +c_pargr c_pargr +c_pargs c_pargs +c_pargstr c_pargstr +c_prchdir c_prchdir +c_prcldpr c_prcldpr +c_prclose c_prclose +c_prdone c_prdone +c_prenvfree c_prenvfree +c_prenvset c_prenvset +c_printf c_printf +c_prkill c_prkill +c_propdpr c_propdpr +c_propen c_propen +c_prredir c_prredir +c_prsignal c_prsignal +c_prstati c_prstati +c_rcursor c_rcursor +c_rdukey c_rdukey +c_read c_read +c_rename c_rename +c_salloc c_salloc +c_seek c_seek +c_sfree c_sfree +c_smark c_smark +c_sppstr c_sppstr +c_stggetline c_stggetline +c_stgputline c_stgputline +c_stropen c_stropen +c_strpak c_strpak +c_strupk c_strupk +c_sttyco c_sttyco +c_tsleep c_tsleep +c_ttseti c_ttseti +c_ttsets c_ttsets +c_ttstati c_ttstati +c_ttstats c_ttstats +c_ttycdes c_ttycdes +c_ttycn c_ttyclearln +c_ttycr c_ttyclear +c_ttyctrl c_ttyctrl +c_ttygb c_ttygetb +c_ttygi c_ttygeti +c_ttygoto c_ttygoto +c_ttygr c_ttygetr +c_ttygs c_ttygets +c_ttyinit c_ttyinit +c_ttyodes c_ttyodes +c_ttype c_ttyputline +c_ttyps c_ttyputs +c_ttyseti c_ttyseti +c_ttyso c_ttyso +c_ttystati c_ttystati +c_ungetc c_ungetc +c_ungetline c_ungetline +c_vfnbrk c_vfnbrk +c_wmsec c_wmsec +c_write c_write +c_xgmes c_xgmes +c_xonerr c_xonerr +c_xttysize c_xttysize +c_xwhen c_xwhen +calcmr calcmarker +ccpcag ccp_calcseg +ccpcle ccp_close +ccpclr ccp_clear +ccpcls ccp_closews +ccpcor ccp_color +ccpdrg ccp_drawseg +ccpdrr ccp_drawchar +ccpese ccp_escape +ccpfat ccp_faset +ccpfia ccp_fillarea +ccpfot ccp_font +ccpint ccp_init +ccplie ccp_linetype +ccplwh ccp_lwidth +ccpopn ccp_open +ccpops ccp_openws +ccpplt ccp_plset +ccppmt ccp_pmset +ccppoe ccp_polyline +ccppor ccp_polymarker +ccpret ccp_reset +ccptet ccp_text +ccptxt ccp_txset +cctoc cctoc +ccxadt ccx_addsegpt +ccxdah ccx_dash +ccxgap ccx_gap +ccxinl ccx_intersymbol +ccxiny ccx_interpoly +ccxofs ccx_offsets +ccxpas ccx_parameters +ccxset ccx_segment +chdept chdeposit +checkm checksum +chfeth chfetch +chk_prot chk_prot +chrlwr chrlwr +chrupr chrupr +clargc clargc +clargd clargd +clargi clargi +clargr clargr +clccos clc_compress +clcenr clc_enter +clcfeh clc_fetch +clcfid clc_find +clcfre clc_free +clcint clc_init +clclit clc_list +clcloe clclose +clcmak clc_mark +clcmd clcmd +clcmdw clcmdw +clcnek clc_newtask +clcpst clcpset +clcscn clc_scan +clepst clepset +clgcur clgcur +clgetb clgetb +clgetc clgetc +clgetd clgetd +clgeti clgeti +clgetl clgetl +clgetr clgetr +clgets clgets +clgetx clgetx +clgfil clgfil +clgkey clgkey +clglpb clglpb +clglpc clglpc +clglpd clglpd +clglpi clglpi +clglpl clglpl +clglpr clglpr +clglps clglps +clglpx clglpx +clglsr clglstr +clgpsa clgpseta +clgpsb clgpsetb +clgpsc clgpsetc +clgpsd clgpsetd +clgpsi clgpseti +clgpsl clgpsetl +clgpsr clgpsetr +clgpss clgpsets +clgpst clgpset +clgpsx clgpsetx +clgstr clgstr +clgwrd clgwrd +clinis cl_initargs +clktie clktime +cllpst cllpset +clnarg clnarg +clopen clopen +clopst clopset +clpcls clpcls +clplen clplen +clpopi clpopni +clpops clpopns +clpopu clpopnu +clppsa clppseta +clppsb clppsetb +clppsc clppsetc +clppsd clppsetd +clppsi clppseti +clppsl clppsetl +clppsr clppsetr +clppss clppsets +clppst clppset +clppsx clppsetx +clprew clprew +clprif clprintf +clpsee clpset_parname +clpsit cl_psio_request +clpstr clpstr +clputb clputb +clputc clputc +clputd clputd +clputi clputi +clputl clputl +clputr clputr +clputs clputs +clputx clputx +clrawc clrawc +clreqr clreqpar +clscan clscan +clseti clseti +clstai clstati +cnvdae cnvdate +cnvtie cnvtime +coerce coerce +coerce coerce +convtt conv_test +convtt conv_test +cputie cputime +ctocc ctocc +ctod ctod +ctoi ctoi +ctol ctol +ctor ctor +ctotok ctotok +ctowrd ctowrd +ctox ctox +d_compar d_compar +d_qsort d_qsort +d_qst d_qst +dbgmsg dbgmsg +dbgmsg1 dbgmsg1 +dbgmsg2 dbgmsg2 +dbgmsg3 dbgmsg3 +dbgmsg4 dbgmsg4 +dealloc dealloc +deletg deletefg +diropn diropen +dtcscl dtcscl +dtoc dtoc +dtoc3 dtoc3 +dumpcs dump_chars +elogd elogd +elogr elogr +envdeg envdebug +envfid envfind +envfit env_first +envfre envfree +envgeb envgetb +envged envgetd +envgei envgeti +envger envgetr +envges envgets +envinr envindir +envint env_init +envlit envlist +envmak envmark +envnet env_next +envpus envputs +envret envreset +envscn envscan +eprinf eprintf +erract erract +errcoe errcode +errget errget +evexpr evexpr +evvexr evvexpr +evvfre evvfree +ex_handler ex_handler +fakepc fakepc +falloc falloc +fcanpb fcanpb +fcldir fcldir +fclobr fclobber +fcopy fcopy +fcopyo fcopyo +fdebug fdebug +fdevbf fdevbf +fdevbk fdevblk +fdevtx fdevtx +fdirne fdirname +fencd fencd +fencd fencd +fexbuf fexbuf +ffault ffault +ffilbf ffilbf +ffilsz ffilsz +ffldir ffldir +fflsbf fflsbf +fgdev0 fgdev0 +fgdevm fgdev_param +fgetfd fgetfd +fgtdir fgtdir +filbuf filbuf +filerr filerr +filopn filopn +findsfs findsfs +finfo finfo +finit finit +fioclp fio_cleanup +fioqfh fio_qflush +fixmem fixmem +fixmem fixmem +flsbuf flsbuf +fmaccs fm_access +fmapfn fmapfn +fmcloe fm_close +fmcopo fm_copyo +fmcopy fm_copy +fmdebg fm_debug +fmdele fm_delete +fmfcdg fm_fcdebug +fmfcfe fm_fcfree +fmfcit fm_fcinit +fmfcsc fm_fcsync +fmfinf fm_findlf +fmfopn fm_fopen +fmgetd fm_getfd +fmiobd fmio_bind +fmioed fmio_extend +fmioek fmio_errchk +fmiopr fmio_posterr +fmiorr fmio_readheader +fmiosf fmio_setbuf +fmiotk fmio_tick +fmkbfs fmkbfs +fmkcoy fmkcopy +fmkdir fmkdir +fmkpbf fmkpbbuf +fmlfad fm_lfaread +fmlfae fm_lfawrite +fmlfat fm_lfawait +fmlfbd fm_lfbinread +fmlfbe fm_lfbinwrite +fmlfbt fm_lfbinwait +fmlfce fm_lfclose +fmlfcy fm_lfcopy +fmlfde fm_lfdelete +fmlfne fm_lfname +fmlfon fm_lfopen +fmlfpe fm_lfparse +fmlfsi fm_lfstati +fmlfst fm_lfstat +fmlfue fm_lfundelete +fmlocd fm_locked +fmloct fm_lockout +fmnexe fm_nextlfile +fmopen fm_open +fmrebd fm_rebuild +fmrene fm_rename +fmretd fm_retfd +fmseti fm_seti +fmstai fm_stati +fmsync fm_sync +fmterr fmt_err +fmtint fmt_init +fmtred fmt_read +fmtsel fmt_setcol +fmtstr fmtstr +fmunlk fm_unlock +fnextn fnextn +fnldir fnldir +fnroot fnroot +fntclb fntclsb +fntcls fntcls +fntdir fntdir +fntedt fnt_edit +fntget fnt_getpat +fntgfb fntgfnb +fntgfn fntgfn +fntleb fntlenb +fntmkt fnt_mkpat +fntopb fntopnb +fntopn fntopn +fntopt fnt_open_list +fntreb fntrewb +fntree fnt_read_template +fntrfb fntrfnb +fnulle fnullfile +fopdir fopdir +fopnbf fopnbf +fopntx fopntx +fowner fowner +fpathe fpathname +fpequd fp_equald +fpequr fp_equalr +fpfixd fp_fixd +fpfixr fp_fixr +fpnonr fp_nondegenr +fpnord fp_normd +fpnorr fp_normr +fpradv fpradv +fprfmt fprfmt +fprinf fprintf +fprntf fprntf +fptdir fptdir +fputtx fputtx +freadp freadp +fredio frediro +fredir fredir +frenae frename +frmbfs frmbfs +frmtmp frmtmp +frtnfd frtnfd +fsetev fset_env +fsetfd fsetfd +fseti fseti +fsfdee fsfdelete +fsfgee fsf_getfname +fsfopn fsfopen +fskdir fskdir +fstati fstati +fstatl fstatl +fstats fstats +fstdfe fstdfile +fstdir fstdir +fstrfp fstrfp +fsvtfn fsvtfn +fswapd fswapfd +fulib fulib +fulib fulib +fwatio fwatio +fwritp fwritep +fwtacc fwtacc +fxfacp fxf_accum_bufp +fxfacs fxf_access +fxfact fxf_accum_buft +fxfadr fxf_addpar +fxfakb fxf_akwb +fxfakc fxf_akwc +fxfakd fxf_akwd +fxfaki fxf_akwi +fxfakr fxf_akwr +fxfalc fxf_alloc +fxfald fxf_altmd +fxfalr fxf_altmr +fxfalu fxf_altmu +fxfbls fxf_blank_lines +fxfbyt fxf_byte_short +fxfche fxf_check_old_name561 +fxfchm fxf_chk_ndim +fxfchp fxf_check_group +fxfchv fxf_check_dup_extnv507 +fxfcle fxf_close +fxfcoy fxf_copy +fxfcte fxf_ctype +fxfdae fxf_date2limtime +fxfdee fxf_delete +fxfdiw fxf_discard_keyw +fxfdur fxf_dummy_header +fxfenb fxf_encodeb +fxfenc fxf_encodec +fxfend fxf_encoded +fxfene fxf_encode_date +fxfeni fxf_encodei +fxfenl fxf_encodel +fxfenr fxf_encoder +fxfens fxf_encode_axis +fxfexr fxf_extnv_error +fxffac fxf_falloc +fxffcr fxf_fclobber +fxffiw fxf_filter_keyw +fxffog fxf_form_messg +fxffpd fxf_fpl_equald +fxfgas fxf_gaccess +fxfgeb fxf_getb +fxfged fxf_getd +fxfgei fxf_geti +fxfgen fxf_gethdrextn +fxfger fxf_getr +fxfget fxf_getcmt +fxfglm fxf_gltm +fxfgsr fxf_gstr +fxfhdt fxf_hdr_offset +fxfhee fxf_header_size +fxfhef fxf_header_diff +fxfint fxf_init +fxfisk fxf_is_blank +fxfkse fxf_ks_gvalue +fxfksl fxf_ks_val +fxfksm fxf_ks_pm +fxfksn fxf_ksection +fxfkss fxf_ks_errors +fxfkst fxf_ksinit +fxfksx fxf_ks_lex +fxflor fxf_load_header +fxfmad fxf_make_card +fxfmar fxf_match_str +fxfmas fxf_mandatory_cards461 +fxfmay fxf_make_adj_copy +fxfmea fxf_merge_w_ua +fxfnul fxf_null +fxfopn fxf_open +fxfopx fxf_opix +fxfove fxf_over_delete +fxfovt fxf_overwrite_unit549 +fxfpaa fxf_pak_data +fxfprr fxf_prhdr +fxfred fxf_read_card +fxfree fxf_rename +fxfrek fxf_reblock +fxfren fxf_read_xtn +fxfrep fxf_ren_tmp +fxfrfr fxf_rfitshdr +fxfrhr fxf_rheader +fxfsee fxf_set_cache_time844 +fxfsex fxf_setbitpix +fxfskn fxf_skip_xtn +fxfstr fxf_strcmp_lwr +fxftox fxf_totpix +fxfuad fxf_ua_card +fxfuna fxf_unpack_data +fxfupd fxf_update_extend +fxfupr fxf_updhdr +fxfwrr fxf_write_header +fxfwrs fxf_write_blanks +fxfzcl fxfzcl +fxfzop fxfzop +fxfzrd fxfzrd +fxfzst fxfzst +fxfzwr fxfzwr +fxfzwt fxfzwt +gactie gactivate +gacwk gacwk +gadraw gadraw +gamove gamove +gargb gargb +gargc gargc +gargd gargd +gargi gargi +gargl gargl +gargr gargr +gargrd gargrad +gargs gargs +gargsr gargstr +gargtk gargtok +gargwd gargwrd +gargx gargx +gascae gascale +gaxdrw gax_draw +gaxfis gax_findticks +gaxflh gax_flush +gaxndc gax_ndc +gaxstt gax_start +gaxtet gax_text +gaxtik gax_tick +gbytes gbytes +gca gca +gcancl gcancel +gcas gcas +gclear gclear +gclks gclks +gclose gclose +gclrwk gclrwk +gclwk gclwk +gctod gctod +gctol gctol +gctox gctox +gctran gctran +gcurps gcurpos +gdawk gdawk +gdeace gdeactivate +gdrwch gdrwch +gescae gescape +get_processtable get_processtable +get_timezone get_timezone +getci getci +gethot gethost +getlie getline +getlle getlline +getloe getlongline +getstr getstr +gettok gettok +gexflr gexfls_clear +gexfls gexfls +gexflt gexfls_set +gfa gfa +gfill gfill +gflush gflush +gframe gframe +gfrint gfrinit +ggcell ggcell +ggcur ggcur +ggetb ggetb +ggeti ggeti +ggetr ggetr +ggets ggets +ggscae ggscale +ggview ggview +ggwind ggwind +gimcor gim_copyraster +gimcrr gim_createraster +gimder gim_destroyraster +gimdig gim_disablemapping +gimeng gim_enablemapping +gimfrg gim_freemapping +gimfrp gim_freecolormap +gimgeg gim_getmapping +gimins gim_initmappings +gimiod gim_iomapread +gimioe gim_iomapwrite +gimlop gim_loadcolormap +gimqur gim_queryraster +gimrat gim_rasterinit +gimreg gim_refreshmapping +gimrep gim_readcolormap +gimres gim_readpixels +gimrex gim_refreshpix +gimseg gim_setmapping +gimser gim_setraster +gimsex gim_setpix +gimwrp gim_writecolormap +gimwrs gim_writepixels +giotr giotr +giotrt giotr_onint +gkical gki_cancel +gkiclr gki_clear +gkicls gki_closews +gkides gki_deactivatews +gkieof gki_eof +gkiese gki_escape +gkiexe gki_execute +gkifat gki_faset +gkifen gki_fetch_next_instruction +gkiffh gki_fflush +gkifia gki_fillarea +gkiflh gki_flush +gkiger gki_getcursor +gkiges gki_getwcs +gkigey gki_getcellarray +gkiinl gki_inline_kernel +gkiint gki_init +gkimfe gki_mftitle +gkiops gki_openws +gkiplt gki_plset +gkipmt gki_pmset +gkipoe gki_polyline +gkipor gki_polymarker +gkipuy gki_putcellarray +gkiree gki_retcursorvalue +gkirer gki_redir +gkires gki_reactivatews +gkirey gki_retcellarray +gkiser gki_setcursor +gkises gki_setwcs +gkisul gki_subkernel +gkitet gki_text +gkitxt gki_txset +gkiwee gki_wescape +gkiwre gki_write +gkpcal gkp_cancel +gkpcle gkp_close +gkpclr gkp_clear +gkpcls gkp_closews +gkpdes gkp_deactivatews +gkpdup gkp_dump +gkpese gkp_escape +gkpfat gkp_faset +gkpfia gkp_fillarea +gkpflh gkp_flush +gkpger gkp_getcursor +gkpges gkp_getwcs +gkpgey gkp_getcellarray +gkpgrm gkp_grstream +gkpinl gkp_install +gkpmfe gkp_mftitle +gkpops gkp_openws +gkpplt gkp_plset +gkppmt gkp_pmset +gkppoe gkp_polyline +gkppor gkp_polymarker +gkppst gkp_pstat +gkppuy gkp_putcellarray +gkpres gkp_reactivatews +gkpser gkp_setcursor +gkpses gkp_setwcs +gkptet gkp_text +gkptxg gkp_txparg +gkptxt gkp_txset +gkpunn gkp_unknown +gktcal gkt_cancel +gktcle gkt_close +gktclr gkt_clear +gktcls gkt_closews +gktcor gkt_color +gktdrr gkt_drawchar +gktese gkt_escape +gktfat gkt_faset +gktfia gkt_fillarea +gktflh gkt_flush +gktfot gkt_font +gktgey gkt_getcellarray +gktgsg gkt_gstring +gktint gkt_init +gktlie gkt_linetype +gktmfn gkt_mfopen +gktopn gkt_open +gktops gkt_openws +gktplt gkt_plset +gktpmt gkt_pmset +gktpoe gkt_polyline +gktpor gkt_polymarker +gktpuy gkt_putcellarray +gktret gkt_reset +gkttet gkt_text +gkttxt gkt_txset +glabax glabax +glbdrd glb_drawgrid +glbene glb_encode +glbeq glb_eq +glbfis glb_find_ticks +glbgek glb_gettick +glblas glb_label_axis +glblob glb_loglab +glbmip glb_minorstep +glbple glb_plot_title +glbsep glb_setup +glbses glb_set_axes +glbset glb_set_viewport +glbtin glb_ticklen +glbveg glb_verify_log_scaling +gline gline +gltoc gltoc +gmark gmark +gmftie gmftitle +gmprif gmprintf +gmsg gmsg +gmsgb gmsgb +gmsgc gmsgc +gmsgd gmsgd +gmsgi gmsgi +gmsgl gmsgl +gmsgr gmsgr +gmsgs gmsgs +gmsgx gmsgx +gmt_to_lst gmt_to_lst +gopen gopen +gopeni gopenui +gopks gopks +gopwk gopwk +gpagee gpagefile +gpatme gpatmake +gpatmh gpatmatch +gpcell gpcell +gpl gpl +gplcae gpl_cache +gplcal gpl_cancel +gplclb gpl_clipb +gplcll gpl_clipl +gplclr gpl_clipr +gplclt gpl_clipt +gplflh gpl_flush +gpline gpline +gploto gploto +gplotv gplotv +gplret gpl_reset +gplsee gpl_settype +gplwci gpl_wcstogki +gpm gpm +gpmark gpmark +gptclb gpt_clipb +gptcll gpt_clipl +gptclr gpt_clipr +gptclt gpt_clipt +gptfit gpt_firstpt +gptflh gpt_flush +gqasf gqasf +gqchh gqchh +gqchup gqchup +gqclip gqclip +gqcntn gqcntn +gqmk gqmk +gqnt gqnt +gqopwk gqopwk +gqplci gqplci +gqpmci gqpmci +gqpmi gqpmi +gqsort gqsort +gqtxal gqtxal +gqtxci gqtxci +gqtxp gqtxp +gqvery gqverify +gqwks gqwks +grcaxs grc_axes +grcbol grc_boolval +grccle grc_close +grccod grc_command +grccur grc_cursor +grcint grc_init +grckes grc_keys +grcmay grc_mapkey +grcmee grc_message +grcndr grc_ndctoscr +grcnds grc_ndctowcs +grcopn grc_open +grcpcr grc_pcursor +grcpoe grc_polyline +grcred grc_read +grcrel grc_realval +grcres grc_restorecurpos +grcrew grc_redraw +grcrey grc_readtty +grcscc grc_scrtondc +grcscs grc_scrtowcs +grcsen grc_settran +grcses grc_selectwcs +grcsts grc_status +grctet grc_text +grcvit grc_viewport +grcwan grc_warn +grcwcc grc_wcstondc +grcwod grc_word +grcwre grc_write +grdraw grdraw +grdwcs grdwcs +greace greactivate +greset greset +grmove grmove +grscae grscale +gsasf gsasf +gsawi gsawi +gsawr gsawr +gscan gscan +gschh gschh +gschup gschup +gsclip gsclip +gscr gscr +gscur gscur +gselnt gselnt +gseti gseti +gsetr gsetr +gsets gsets +gsfaci gsfaci +gsfais gsfais +gslwsc gslwsc +gsmk gsmk +gsmksc gsmksc +gsplci gsplci +gspmci gspmci +gspmi gspmi +gstati gstati +gstatr gstatr +gstats gstats +gstrct gstrcat +gstrcy gstrcpy +gstrmh gstrmatch +gstsei gst_set_attribute_i247 +gstser gst_set_attribute_r264 +gstxal gstxal +gstxci gstxci +gstxp gstxp +gsview gsview +gsvp gsvp +gswind gswind +gswn gswn +gtdise gt_distance +gtdise gt_distance +gtext gtext +gtick gtick +gtickr gtickr +gtliny gt_linearity +gtliny gt_linearity +gtndis gt_ndigits +gtndis gt_ndigits +gtrbap gtr_backup +gtrcle gtr_cliptoplane +gtrcol gtr_control +gtrcot gtr_connect +gtrctn gtr_ctran +gtrdee gtr_delete +gtrdit gtr_disconnect +gtrfen gtr_fetch_next_instruction +gtrfre gtr_frame +gtrgfh gtr_gflush +gtrgtn gtr_gtran +gtrgty gtr_gtty +gtrint gtr_init +gtrmee gtr_memusage +gtrops gtr_openws +gtrpae gtr_page +gtrpon gtr_polytran +gtrpop gtr_polyclip +gtrptn gtr_ptran +gtrrer gtr_readcursor +gtrret gtr_reset +gtrrew gtr_redraw +gtrset gtrset +gtrsts gtr_status +gtrtre gtr_truncate +gtruno gtr_undo +gtrwae gtr_waitpage +gtrwrp gtr_writep +gtrwrr gtr_writecursor +gtrwsn gtr_wstran +gttyld g_ttyload +gtxset gtxset +gtybih gty_binsearch +gtycas gtycaps +gtycle gtyclose +gtyeny gty_encode_capability161 +gtyexs gty_extract_alias +gtyfey gty_fetch_entry +gtyfiy gty_find_capability +gtygeb gtygetb +gtygei gtygeti +gtyger gtygetr +gtyges gtygets +gtyins gty_index_caps +gtyopn gtyopen +gtysce gty_scan_termcap_file +gumark gumark +gvline gvline +gvmark gvmark +gwcsme gwcs_mkfilename +gwrwcs gwrwcs +gxgtx gxgtx +iand iand +iand iand +idbcle idb_close +idbfid idb_findrecord +idbfid idb_findrecord +idbfir idb_filstr +idbgeg idb_getstring +idbgeg idb_getstring +idbkwp idb_kwlookup +idbkwp idb_kwlookup +idbnas idb_naxis +idbned idb_nextcard +idbopn idb_open +idbpug idb_putstring +idbpug idb_putstring +idkcle idk_close +idkdrw idk_draw +idkflh idk_flush +idkfre idk_frame +idklih idk_linewidth +idkmoe idk_move +idkopn idk_open +idkver idk_vector +ieegmd ieegmapd +ieegmp ieegmap +ieegmr ieegmapr +ieegnd ieegnand +ieegnn ieegnan +ieegnr ieegnanr +ieemad ieemapd +ieemap ieemap +ieemar ieemapr +ieepad ieepakd +ieepak ieepak +ieepar ieepakr +ieesmd ieesmapd +ieesmp ieesmap +ieesmr ieesmapr +ieesnd ieesnand +ieesnn ieesnan +ieesnr ieesnanr +ieestd ieestatd +ieestr ieestatr +ieestt ieestat +ieeupd ieeupkd +ieeupk ieeupk +ieeupr ieeupkr +ieevpd ieevpakd +ieevpk ieevpak +ieevpr ieevpakr +ieevud ieevupkd +ieevuk ieevupk +ieevur ieevupkr +ieezsd ieezstatd +ieezsr ieezstatr +ieezst ieezstat +ikiacs iki_access +ikicle iki_close +ikicoy iki_copy +ikidee iki_delete +ikideg iki_debug +ikiext iki_extninit +ikiged iki_getfield +ikigen iki_getextn +ikiger iki_getpar +ikiint iki_init +ikildr iki_lddriver +ikimke iki_mkfname +ikiopn iki_open +ikiopx iki_opix +ikipae iki_parse +ikiree iki_rename +ikiupr iki_updhdr +ikivan iki_validextn +imaccf imaccf +imaccf imaccf +imacck imacck +imaccs imaccess +imaddb imaddb +imaddb imaddb +imaddd imaddd +imaddd imaddd +imaddf imaddf +imaddf imaddf +imaddi imaddi +imaddi imaddi +imaddk imaddk +imaddl imaddl +imaddl imaddl +imaddr imaddr +imaddr imaddr +imadds imadds +imadds imadds +imaflp imaflp +imakwb imakwb +imakwc imakwc +imakwd imakwd +imakwi imakwi +imakwr imakwr +imalin imalign +imaplv imaplv +imastr imastr +imastr imastr +imbln1 imbln1 +imbln2 imbln2 +imbln3 imbln3 +imbtrn imbtran +imcfnl imcfnl +imcfnl imcfnl +imckwl imckwl +imclos imclos +imcopy imcopy +imcrea imcrea +imcrex imcrex +imcssz imcssz +imctrt im_ctranset +imdbcl imd_bcell +imdcal imd_cancel +imdcle imd_close +imdclr imd_clear +imdcls imd_closews +imdcor imd_color +imddae imd_dashline +imddrr imd_drawchar +imdect im_decode_subscript161 +imdele imdele +imdele imdelete +imdelf imdelf +imdelf imdelf +imdelk imdelk +imdelx imdelx +imdese imd_escape +imdfat imd_faset +imdfia imd_fillarea +imdflh imd_flush +imdfot imd_font +imdgeg imd_getseg +imdgey imd_getcellarray +imdgsg imd_gstring +imdint imd_init +imdint imdinit +imdlie imd_linetype +imdmap imdmap +imdmcl imd_mcell +imdops imd_openws +imdopv imd_opendev +imdplt imd_plset +imdpmt imd_pmset +imdpoe imd_polyline +imdpor imd_polymarker +imdpuy imd_putcellarray +imdret imd_reset +imdtet imd_text +imdtxt imd_txset +imemsg imemsg +imerr imerr +imfaln imf_align +imfgpe imf_gpixfname +imfins imf_initoffsets +imflpl imflpl +imflps imflps +imfls imfls +imflsd imflsd +imflsh imflsh +imflsh imflsh +imflsi imflsi +imflsl imflsl +imflsr imflsr +imflss imflss +imflsx imflsx +imfluh imflush +imfmke imf_mkpixfname +imfnpy imfn_putkey +imfnpy imfn_putkey +imfnss imfn_stdkeys +imfnss imfn_stdkeys +imfpae imf_parse +imftrs imf_trans +imfupr imf_updhdr +imgatr imgatr +imgclr imgcluster +imgdir imgdir +imgdix imgdirx +imgetb imgetb +imgetb imgetb +imgetc imgetc +imgetc imgetc +imgetd imgetd +imgetd imgetd +imgeti imgeti +imgeti imgeti +imgetl imgetl +imgetl imgetl +imgetr imgetr +imgetr imgetr +imgets imgets +imgets imgets +imgfte imgftype +imgfte imgftype +imggs imggs +imggsc imggsc +imggsd imggsd +imggsi imggsi +imggsl imggsl +imggsr imggsr +imggss imggss +imggsx imggsx +imgibf imgibf +imgime imgimage +imgkwb imgkwb +imgkwc imgkwc +imgkwd imgkwd +imgkwi imgkwi +imgkwr imgkwr +imgl1 imgl1 +imgl1d imgl1d +imgl1i imgl1i +imgl1l imgl1l +imgl1r imgl1r +imgl1r imgl1r +imgl1s imgl1s +imgl1s imgl1s +imgl1x imgl1x +imgl2 imgl2 +imgl2d imgl2d +imgl2i imgl2i +imgl2l imgl2l +imgl2r imgl2r +imgl2r imgl2r +imgl2s imgl2s +imgl2s imgl2s +imgl2x imgl2x +imgl3 imgl3 +imgl3d imgl3d +imgl3i imgl3i +imgl3l imgl3l +imgl3r imgl3r +imgl3r imgl3r +imgl3s imgl3s +imgl3s imgl3s +imgl3x imgl3x +imgnfn imgnfn +imgnfn imgnfn +imgnkw imgnkw +imgnl imgnl +imgnld imgnld +imgnli imgnli +imgnll imgnll +imgnln imgnln +imgnlr imgnlr +imgnls imgnls +imgnlx imgnlx +imgobf imgobf +imgs1 imgs1 +imgs1d imgs1d +imgs1i imgs1i +imgs1l imgs1l +imgs1r imgs1r +imgs1r imgs1r +imgs1s imgs1s +imgs1s imgs1s +imgs1x imgs1x +imgs2 imgs2 +imgs2d imgs2d +imgs2i imgs2i +imgs2l imgs2l +imgs2r imgs2r +imgs2r imgs2r +imgs2s imgs2s +imgs2s imgs2s +imgs2x imgs2x +imgs3 imgs3 +imgs3d imgs3d +imgs3i imgs3i +imgs3l imgs3l +imgs3r imgs3r +imgs3r imgs3r +imgs3s imgs3s +imgs3s imgs3s +imgs3x imgs3x +imgsen imgsection +imgsiz imgsiz +imgstr imgstr +imgstr imgstr +imhcpy imhcpy +iminie im_init_newimage +imioff imioff +imisec imisec +imloop imloop +immaky im_make_newcopy +immap immap +immapz immapz +imnote imnote +imofnl imofnl +imofnl imofnl +imofns imofnls +imofns imofnls +imofnu imofnlu +imofnu imofnlu +imokwl imokwl +imopen imopen +imopnc imopnc +imopnx imopnx +imopsf imopsf +impak impak +impakd impakd +impaki impaki +impakl impakl +impakr impakr +impaks impaks +impakx impakx +impare imparse +impgs impgs +impgsd impgsd +impgsi impgsi +impgsl impgsl +impgsr impgsr +impgss impgss +impgsx impgsx +impixf impixf +impkwb impkwb +impkwc impkwc +impkwd impkwd +impkwi impkwi +impkwr impkwr +impl1 impl1 +impl1d impl1d +impl1i impl1i +impl1l impl1l +impl1r impl1r +impl1r impl1r +impl1s impl1s +impl1s impl1s +impl1x impl1x +impl2 impl2 +impl2d impl2d +impl2i impl2i +impl2l impl2l +impl2r impl2r +impl2r impl2r +impl2s impl2s +impl2s impl2s +impl2x impl2x +impl3 impl3 +impl3d impl3d +impl3i impl3i +impl3l impl3l +impl3r impl3r +impl3r impl3r +impl3s impl3s +impl3s impl3s +impl3x impl3x +impml1 im_pmlne1 +impml2 im_pmlne2 +impml3 im_pmlne3 +impmlr im_pmldhdr +impmlv im_pmlnev +impmmo im_pmmapo +impmmp im_pmmap +impmon im_pmopen +impms1 im_pmsne1 +impms2 im_pmsne2 +impms3 im_pmsne3 +impmsr im_pmsvhdr +impmsv im_pmsnev +impnl impnl +impnld impnld +impnli impnli +impnll impnll +impnln impnln +impnlr impnlr +impnls impnls +impnlx impnlx +imps1 imps1 +imps1d imps1d +imps1i imps1i +imps1l imps1l +imps1r imps1r +imps1r imps1r +imps1s imps1s +imps1s imps1s +imps1x imps1x +imps2 imps2 +imps2d imps2d +imps2i imps2i +imps2l imps2l +imps2r imps2r +imps2r imps2r +imps2s imps2s +imps2s imps2s +imps2x imps2x +imps3 imps3 +imps3d imps3d +imps3i imps3i +imps3l imps3l +imps3r imps3r +imps3r imps3r +imps3s imps3s +imps3s imps3s +imps3x imps3x +impstr impstr +impstr impstr +imputb imputb +imputb imputb +imputd imputd +imputd imputd +imputh imputh +imputi imputi +imputi imputi +imputl imputl +imputl imputl +imputr imputr +imputr imputr +imputs imputs +imputs imputs +imrbpx imrbpx +imrdhr imrdhdr +imrdpx imrdpx +imrene imrename +imrmbs imrmbufs +imrnam imrnam +imsamp imsamp +imsdir imsdir +imsdix imsdirx +imsetf imsetbuf +imseti imseti +imsetm im_seterrim +imsetp im_seterrop +imsetr imsetr +imsinb imsinb +imsmpl imsmpl +imsmps imsmps +imsslv imsslv +imstai imstati +imstar imstatr +imstas imstats +imswap imswap +imtcle imtclose +imtgem imtgetim +imtlen imtlen +imtmae imt_mapname +imtopn imtopen +imtopp imtopenp +imtrew imtrew +imtrgm imtrgetim +imtypk imtypk +imunmp imunmap +imupk imupk +imupkd imupkd +imupki imupki +imupkl imupkl +imupkr imupkr +imupks imupks +imupkx imupkx +imwbpx imwbpx +imwpix imwpix +imwrhr imwrhdr +imwrie imwrite +imwrpx imwrpx +intrde intr_disable +intree intr_enable +intrrt intr_reset +intt intt +ior ior +ior ior +irafmn iraf_main +irafpath irafpath +ishift ishift +ishift ishift +itob itob +itoc itoc +iwcare iw_cardtype +iwcfis iw_cfits +iwents iw_enterwcs +iwfind iw_findcard +iwgbis iw_gbigfits +iwputr iw_putstr +iwputy iw_putarray +iwrfis iw_rfits +iwsetp iw_setaxmap +kardbf kardbf +kardgd kardgd +kardlp kardlp +kardpl kardpl +kardpr kardpr +kardsf kardsf +kawrbf kawrbf +kawrgd kawrgd +kawrlp kawrlp +kawrpl kawrpl +kawrpr kawrpr +kawrsf kawrsf +kawtbf kawtbf +kawtgd kawtgd +kawtlp kawtlp +kawtpl kawtpl +kawtpr kawtpr +kawtsf kawtsf +kbzard kb_zard +kbzawr kb_zawr +kbzawt kb_zawt +kbzcls kb_zcls +kbzopn kb_zopn +kbzstt kb_zstt +kclcpr kclcpr +kcldir kcldir +kcldpr kcldpr +kclsbf kclsbf +kclsgd kclsgd +kclslp kclslp +kclspl kclspl +kclssf kclssf +kclstx kclstx +kclsty kclsty +kdvall kdvall +kdvown kdvown +kernel_panic kernel_panic +kfacss kfacss +kfaloc kfaloc +kfchdr kfchdr +kfdele kfdele +kfgcwd kfgcwd +kfinfo kfinfo +kflstx kflstx +kflsty kflsty +kfmkcp kfmkcp +kfmkdr kfmkdr +kfpath kfpath +kfprot kfprot +kfrnam kfrnam +kfsubd kfsubd +kfxdir kfxdir +kgettx kgettx +kgetty kgetty +kgfdir kgfdir +kicont ki_connect +kidece ki_decode +kience ki_encode +kienvt ki_envreset +kierrr ki_error +kiexte ki_extnode +kifine ki_findnode +kiflux ki_flushtx +kifman ki_fmapfn +kifren ki_freechan +kigetn ki_getchan +kigets ki_gethosts +kignoe ki_gnode +kiinit ki_init +kiloce ki_localnode +kimape ki_mapname +kimapn ki_mapchan +kintpr kintpr +kiopes ki_openks +kirece ki_receive +kisend ki_send +kisenv ki_sendrcv +kishot ki_shownet +kixnoe ki_xnode +kmallc kmalloc +kmallc kmalloc +knottx knottx +knotty knotty +kopcpr kopcpr +kopdir kopdir +kopdpr kopdpr +kopnbf kopnbf +kopngd kopngd +kopnlp kopnlp +kopnpl kopnpl +kopnsf kopnsf +kopntx kopntx +kopnty kopnty +koscmd koscmd +kputtx kputtx +kputty kputty +krealc krealloc +krealc krealloc +ks_geti ks_geti +ks_getlogin ks_getlogin +ks_getpass ks_getpass +ks_getresvport ks_getresvport +ks_getword ks_getword +ks_onsig ks_onsig +ks_puti ks_puti +ks_rexecport ks_rexecport +ks_rhosts ks_rhosts +ks_socket ks_socket +ks_sysname ks_sysname +ks_username ks_username +ks_whosts ks_whosts +ksared ks_aread +ksawat ks_await +ksawre ks_awrite +ksektx ksektx +ksekty ksekty +kserrr ks_error +kservr kserver +ksfman ks_fmapfn +ksloaf ks_loadbf +ksloax ks_loadtx +ksrece ks_receive +kssend ks_send +ksttbf ksttbf +ksttgd ksttgd +ksttlp ksttlp +ksttpl ksttpl +ksttpr ksttpr +ksttsf ksttsf +kstttx kstttx +ksttty ksttty +kszfif ks_zfiobf +kszfit ks_zfiomt +kszfix ks_zfiotx +ktzcls kt_zcls +ktzfls kt_zfls +ktzget kt_zget +ktznot kt_znot +ktzopn kt_zopn +ktzput kt_zput +ktzsek kt_zsek +ktzstt kt_zstt +kzclmt kzclmt +kzopmt kzopmt +kzrdmt kzrdmt +kzrwmt kzrwmt +kzstmt kzstmt +kzwrmt kzwrmt +kzwtmt kzwtmt +lexnum lexnum +lnocle lno_close +lnofeh lno_fetch +lnoopn lno_open +lnosae lno_save +loci loci +locpr locpr +locva locva +loggedin loggedin +lpopen lpopen +lpzard lp_zaread +lpzawe lp_zawrite +lpzawt lp_zawait +ltoc ltoc +maideh ma_ideh +mallo1 malloc1 +mallo1 malloc1 +mcswap mcswap +memchk memchk +mgdptr mgdptr +mgdptr mgdptr +mgtfwa mgtfwa +mgtfwa mgtfwa +miilen miilen +miinem miinelem +miipa2 miipak32 +miipa6 miipak16 +miipa8 miipak8 +miipad miipakd +miipak miipak +miipar miipakr +miipke miipksize +miirdc miirdc +miirdi miirdi +miirdl miirdl +miirdr miirdr +miirec miireadc +miired miiread +miired miireadd +miirei miireadi +miirel miireadl +miirer miireadr +miires miireads +miiup2 miiupk32 +miiup6 miiupk16 +miiup8 miiupk8 +miiupd miiupkd +miiupk miiupk +miiupr miiupkr +miiwrc miiwrc +miiwrc miiwritec +miiwrd miiwrited +miiwre miiwrite +miiwri miiwri +miiwri miiwritei +miiwrl miiwritel +miiwrl miiwrl +miiwrr miiwriter +miiwrr miiwrr +miiwrs miiwrites +miocle mio_close +miogld mio_glsegd +mioglg mio_glseg +miogli mio_glsegi +miogll mio_glsegl +mioglr mio_glsegr +miogls mio_glsegs +mioglx mio_glsegx +mioopn mio_open +mioopo mio_openo +miopld mio_plsegd +mioplg mio_plseg +miopli mio_plsegi +miopll mio_plsegl +mioplr mio_plsegr +miopls mio_plsegs +mioplx mio_plsegx +miosee mio_setrange +miosei mio_seti +miosti mio_stati +mpgetd mp_getd +mpgeti mp_geti +msvfwa msvfwa +msvfwa msvfwa +mtalle mtallocate +mtcap mtcap +mtclen mtclean +mtclre mt_clrcache +mtdeae mtdeallocate +mtdevd mt_devallocated +mtence mtencode +mtexae mt_examine +mtfile mtfile +mtfnae mtfname +mtgets mt_getpos +mtglok mt_glock +mtgtyn mt_gtyopen +mtloce mt_lockname +mtneeo mtneedfileno +mtop mtop +mtopen mtopen +mtpare mtparse +mtposn mtposition +mtpute mt_putline +mtreae mt_read_lockfile +mtrewd mtrewind +mtsavd mt_savekeyword +mtsavs mt_savepos +mtskid mt_skip_record +mtstas mtstatus +mtsync mt_sync +mtupde mt_update_lockfile +mwalld mw_allocd +mwalls mw_allocs +mwaxtn mw_axtran +mwc1td mw_c1trand +mwc1tn mw_c1tran +mwc1tr mw_c1tranr +mwc2td mw_c2trand +mwc2tn mw_c2tran +mwc2tr mw_c2tranr +mwcloe mw_close +mwcopd mw_copyd +mwcops mw_copys +mwctfe mw_ctfree +mwctrd mw_ctrand +mwctrn mw_ctran +mwctrr mw_ctranr +mwfins mw_findsys +mwflop mw_flookup +mwgaxp mw_gaxmap +mwgaxt mw_gaxlist +mwgctd mw_gctrand +mwgctn mw_gctran +mwgctr mw_gctranr +mwgltd mw_gltermd +mwgltr mw_gltermr +mwgsym mw_gsystem +mwgwas mw_gwattrs +mwgwsd mw_gwsampd +mwgwsr mw_gwsampr +mwgwtd mw_gwtermd +mwgwtr mw_gwtermr +mwinvd mw_invertd +mwinvr mw_invertr +mwload mw_load +mwloam mw_loadim +mwltrd mw_ltrand +mwltrn mw_ltran +mwltrr mw_ltranr +mwlubb mw_lubacksub +mwlude mw_ludecompose +mwmkid mw_mkidmd +mwmkir mw_mkidmr +mwmmud mw_mmuld +mwmmul mw_mmul +mwmmur mw_mmulr +mwnewm mw_newsystem +mwnewy mw_newcopy +mwopem mw_openim +mwopen mw_open +mwrefr mw_refstr +mwrote mw_rotate +mwsave mw_save +mwsavm mw_saveim +mwsaxp mw_saxmap +mwscae mw_scale +mwsctn mw_sctran +mwsdes mw_sdefwcs +mwseti mw_seti +mwshit mw_shift +mwshow mw_show +mwsltd mw_sltermd +mwsltr mw_sltermr +mwssym mw_ssystem +mwstai mw_stati +mwswas mw_swattrs +mwswsd mw_swsampd +mwswsr mw_swsampr +mwswtd mw_swtermd +mwswte mw_swtype +mwswtr mw_swtermr +mwtrad mw_translated +mwtrar mw_translater +mwv1td mw_v1trand +mwv1tn mw_v1tran +mwv1tr mw_v1tranr +mwv2td mw_v2trand +mwv2tn mw_v2tran +mwv2tr mw_v2tranr +mwvmud mw_vmuld +mwvmul mw_vmul +mwvmur mw_vmulr +mwvtrd mw_vtrand +mwvtrn mw_vtran +mwvtrr mw_vtranr +napmsx napmsx +ncgchr ncgchr +ncpchr ncpchr +ndopen ndopen +newpen newpen +nextcmd nextcmd +nowhie nowhite +nscan nscan +oifacs oif_access +oifcle oif_close +oifcoy oif_copy +oifdee oif_delete +oifgpe oif_gpixfname +oifmke oif_mkpixfname +oifopn oif_open +oifopx oif_opix +oifrdr oif_rdhdr +oifree oif_rename +oiftrm oif_trim +oiftrm oif_trim +oifupr oif_updhdr +oifwrr oif_wrhdr +onenty onentry +onenty onentry +onerre onerror_remove +onerrr onerror +onexie onexit_remote +onexit onexit +onint onint +onint onint +oscmd oscmd +osfnik osfn_initlock +osfnlk osfn_lock +osfnms osfn_mkfnames +osfnpe osfn_pkfname +osfnrk osfn_rmlock +osfntt osfn_timeleft +osfnuk osfn_unlock +output output +packum packum +pagefe pagefile +pagefs pagefiles +pargb pargb +pargc pargc +pargd pargd +pargg pargg +pargi pargi +pargl pargl +pargr pargr +pargs pargs +pargsr pargstr +pargx pargx +parses parse_args +parses parse_args +patamh pat_amatch +patfit pat_filset +patgel pat_getccl +patgse pat_gsize +patinx patindex +patloe pat_locate +patmae patmake +patmah patmatch +patomh pat_omatch +patsts pat_stclos +perror perror +pggetd pg_getcmd +pggete pg_getline +pggetr pg_getstr +pgpage pg_pagefile +pgpeed pg_peekcmd +pgpusd pg_pushcmd +pgsett pg_setprompt +phelp phelp +placcs pl_access +plallc pl_alloc +plascp pl_asciidump +plbox pl_box +plchke pl_chkfree +plcire pl_circle +plcler pl_clear +plcloe pl_close +plcome pl_compare +plcoms pl_compress +plcree pl_create +pldebg pl_debug +pldebt pl_debugout +plempy pl_empty +plfacs plf_access +plfcle plf_close +plfcoy plf_copy +plfdee plf_delete +plfnul plf_null +plfopn plf_open +plfree plf_rename +plfupr plf_updhdr +plgete pl_getplane +plglls pl_glls +plglp pl_glp +plglpi pl_glpi +plglpl pl_glpl +plglps pl_glps +plglr pl_glr +plglri pl_glri +plglrl pl_glrl +plglrs pl_glrs +plgsie pl_gsize +pll2p pl_l2p +pll2pi pl_l2pi +pll2pl pl_l2pl +pll2ps pl_l2ps +pll2r pl_l2r +pll2ri pl_l2ri +pll2rl pl_l2rl +pll2rs pl_l2rs +pllcot pll_const +pllemy pll_empty +plleql pll_equal +plline pl_line +pllinl pl_linestencil +pllinp pl_linerop +plliny pl_linenotempty +pllneg pll_nextseg +plload pl_load +plloaf pl_loadf +plloam pl_loadim +plloop plloop +pllprs pll_prints +plnewy pl_newcopy +plopen pl_open +plot plot +plot1 plot1 +plot2 plot2 +plot3 plot3 +plot4 plot4 +plot5 plot5 +plot6 plot6 +plot7 plot7 +plot8 plot8 +plots plots +plp2l pl_p2l +plp2li pl_p2li +plp2ll pl_p2ll +plp2ls pl_p2ls +plp2r pl_p2r +plp2ri pl_p2ri +plp2rl pl_p2rl +plp2rs pl_p2rs +plpixi pl_pixropi +plpixl pl_pixropl +plpixp pl_pixrop +plpixp pl_pixrop +plpixs pl_pixrops +plplls pl_plls +plplp pl_plp +plplpi pl_plpi +plplpl pl_plpl +plplps pl_plps +plplr pl_plr +plplri pl_plri +plplrl pl_plrl +plplrs pl_plrs +plpoit pl_point +plpoln pl_polygon +plr2l pl_r2l +plr2li pl_r2li +plr2ll pl_r2ll +plr2ls pl_r2ls +plr2p pl_r2p +plr2pi pl_r2pi +plr2pl pl_r2pl +plr2ps pl_r2ps +plrani pl_rangeropi +plranl pl_rangeropl +plranp pl_rangerop +plrans pl_rangerops +plrcle plr_close +plregp pl_regionrop +plreqi plr_equali +plreql plr_equal +plreql plr_equall +plreqs plr_equals +plrget plr_getlut +plrgex plr_getpix +plrop pl_rop +plropn plr_open +plrpri plr_printi +plrprl plr_printl +plrprs plr_prints +plrprt plr_print +plrset plr_setrect +plsave pl_save +plsavf pl_savef +plsavm pl_saveim +plsect pl_sectnotconst +plsecy pl_sectnotempty +plsete pl_setplane +plseti pl_seti +plssie pl_ssize +plsslv plsslv +plstai pl_stati +plstel pl_stencil +plterm plterm +plubox pl_ubox +plucie pl_ucircle +plupde pl_update +plupon pl_upolygon +plvald plvalid +pmaccs pm_access +pmascp pm_asciidump +pmbox pm_box +pmcire pm_circle +pmcler pm_clear +pmempy pm_empty +pmglls pm_glls +pmglp pm_glp +pmglpi pm_glpi +pmglpl pm_glpl +pmglps pm_glps +pmglr pm_glr +pmglri pm_glri +pmglrl pm_glrl +pmglrs pm_glrs +pmline pm_line +pmliny pm_linenotempty +pmnewk pm_newmask +pmplls pm_plls +pmplp pm_plp +pmplpi pm_plpi +pmplpl pm_plpl +pmplps pm_plps +pmplr pm_plr +pmplri pm_plri +pmplrl pm_plrl +pmplrs pm_plrs +pmpoit pm_point +pmpoln pm_polygon +pmrcle pmr_close +pmrgex pmr_getpix +pmrop pm_rop +pmropn pmr_open +pmrset pmr_setrect +pmsect pm_sectnotconst +pmsecy pm_sectnotempty +pmsete pm_setplane +pmseti pm_seti +pmstel pm_stencil +pow2 pow2 +pr_enter pr_enter +pr_findpid pr_findpid +pr_getipc pr_getipc +pr_onint pr_onint +pr_release pr_release +pr_wait pr_wait +prchdr prchdir +prclcr prclcpr +prcldr prcldpr +prcloe prclose +prdone prdone +prdumn pr_dummy_open +preal preal +prenve prenvfree +prenvt prenvset +prfilf prfilbuf +prfinc pr_findproc +prgete prgetline +prgetr pr_getredir +printp print_help +printp print_help +prkill prkill +prompt prompt +pronic pr_onipc +propcr propcpr +propdr propdpr +propen propen +proscd proscmd +protet protect +prpsio pr_psio +prpsit prpsinit +prpsld prpsload +prredr prredir +prseti prseti +prsigl prsignal +prstai prstati +prupde prupdate +prvret prv_reset +przclr pr_zclspr +psioit psio_isxmit +psioxr psio_xfer +pstatus pstatus +pstr pstr +psym psym +putcc putcc +putci putci +putlie putline +qmaccs qm_access +qmgetc qm_getc +qmscan qm_scan +qmscao qm_scano +qmsetm qm_setparam +qmsetr qm_setpar +qmsets qm_setdefaults +qmsymb qm_symtab +qmupds qm_upddefaults +qpaccf qp_accessf +qpaccs qp_access +qpadd qp_add +qpaddb qp_addb +qpaddc qp_addc +qpaddd qp_addd +qpaddf qp_addf +qpaddi qp_addi +qpaddl qp_addl +qpaddr qp_addr +qpadds qp_adds +qpaddx qp_addx +qpargt qp_arglist +qpastr qp_astr +qpbind qp_bind +qpcfnl qp_cfnl +qpcloe qp_close +qpclot qp_closetext +qpcopf qp_copyf +qpcopy qp_copy +qpctod qp_ctod +qpctoi qp_ctoi +qpdele qp_delete +qpdelf qp_deletef +qpdsym qp_dsym +qpdtye qp_dtype +qpelee qp_elementsize +qpexad qpex_attrld +qpexai qpex_attrli +qpexal qpex_attrl +qpexar qpex_attrlr +qpexcd qpex_codegend +qpexce qpex_close +qpexci qpex_codegeni +qpexcn qpex_codegen +qpexcr qpex_codegenr +qpexdc qpex_dballoc +qpexde qpex_delete +qpexdg qpex_debug +qpexdr qpex_dbpstr +qpexee qpex_evaluate +qpexfe qpex_free +qpexge qpex_getattribute +qpexgr qpex_getfilter +qpexmk qpex_mark +qpexmr qpex_modfilter +qpexon qpex_open +qpexpd qpex_parsed +qpexpe qpex_parse +qpexpi qpex_parsei +qpexpn qpex_pbpin +qpexpr qpex_parser +qpexps qpex_pbpos +qpexpt qp_expandtext +qpexrd qpex_refd +qpexsd qpex_sublistd +qpexsi qpex_sublisti +qpexsr qpex_sublistr +qpexst qpex_sublist +qpfacs qpf_access +qpfcle qpf_close +qpfcos qpf_copyparams +qpfcoy qpf_copy +qpfdee qpf_delete +qpflur qp_flushpar +qpfopn qpf_open +qpfopx qpf_opix +qpfree qpf_rename +qpfupr qpf_updhdr +qpfwar qpf_wattr +qpfwfr qpf_wfilter +qpfzcl qpfzcl +qpfzop qpfzop +qpfzrd qpfzrd +qpfzst qpfzst +qpfzwr qpfzwr +qpfzwt qpfzwt +qpget qp_get +qpgetb qp_getb +qpgetc qp_getc +qpgetd qp_getd +qpgeti qp_geti +qpgetk qp_gettok +qpgetl qp_getl +qpgetm qp_getparam +qpgetr qp_getr +qpgets qp_gets +qpgetx qp_getx +qpgmsm qp_gmsym +qpgnfn qp_gnfn +qpgpsm qp_gpsym +qpgstr qp_gstr +qpinht qp_inherit +qpioce qpio_close +qpioge qpio_getrange +qpiogr qpio_getfilter +qpiogs qpio_getevents +qpiolk qpio_loadmask +qpiols qpio_loadwcs +qpiomx qpio_mkindex +qpioon qpio_open +qpiope qpio_parse +qpiops qpio_putevents +qpiori qpio_readpixi +qpiors qpio_readpixs +qpiort qpio_rbucket +qpiorx qpio_readpix +qpiosc qpio_sync +qpiose qpio_setrange +qpiosi qpio_seti +qpiosi qpio_stati +qpiosr qpio_setfilter +qpiowt qpio_wbucket +qplenf qp_lenf +qplenl qp_lenfnl +qplesd qp_lessthand +qplesd qp_lessthand +qplesi qp_lessthani +qplesi qp_lessthani +qplesn qp_lessthan +qplesr qp_lessthanr +qplesr qp_lessthanr +qploas qp_loadwcs +qpmaxd qp_maxvald +qpmaxd qp_maxvald +qpmaxi qp_maxvali +qpmaxi qp_maxvali +qpmaxl qp_maxval +qpmaxr qp_maxvalr +qpmaxr qp_maxvalr +qpmind qp_minvald +qpmind qp_minvald +qpmini qp_minvali +qpmini qp_minvali +qpminl qp_minval +qpminr qp_minvalr +qpminr qp_minvalr +qpmkfe qp_mkfname +qpnexk qp_nexttok +qpofnl qp_ofnl +qpofns qp_ofnls +qpofnu qp_ofnlu +qpopen qp_open +qpopet qp_opentext +qppare qp_parse +qpparl qp_parsefl +qppcle qp_pclose +qppopn qp_popen +qppstr qp_pstr +qpput qp_put +qpputb qp_putb +qpputc qp_putc +qpputd qp_putd +qpputi qp_puti +qpputl qp_putl +qpputm qp_putparam +qpputr qp_putr +qpputs qp_puts +qpputx qp_putx +qpquef qp_queryf +qprawk qp_rawtok +qpread qp_read +qprebd qp_rebuild +qprene qp_rename +qprenf qp_renamef +qprlmd qp_rlmerged +qprlmd qp_rlmerged +qprlme qp_rlmerge +qprlmi qp_rlmergei +qprlmi qp_rlmergei +qprlmr qp_rlmerger +qprlmr qp_rlmerger +qpsavs qp_savewcs +qpseel qp_seekfnl +qpseti qp_seti +qpsizf qp_sizeof +qpstai qp_stati +qpsync qp_sync +qpungk qp_ungettok +qpwrie qp_write +qst qst +rcursr rcursor +rddata rddata +rdukey rdukey +ready ready +reopen reopen +resetn reset_scan +restox restoretx +rpthe4 rptheta4 +rpthe4 rptheta4 +salloc salloc +salloc salloc +savetx savetx +sbit sbit +sbytes sbytes +scanc scanc +scanfe scanfile +sfree sfree +sfree sfree +sgcdup sgc_dump +sgchdw sgch_draw +sgchfh sgch_flush +sgchme sgch_move +sgeexe sge_execute +sgeprf sge_printf +sgespc sge_spoolesc +sgewse sge_wsenable +sgewsn sge_wstran +sgfger sgf_getchar +sgfpor sgf_post_filter +sgfttr sgf_ttyfilter +sgibcl sgi_bcell +sgical sgi_cancel +sgicle sgi_close +sgiclr sgi_clear +sgicls sgi_closews +sgicor sgi_color +sgidae sgi_dashline +sgidrr sgi_drawchar +sgiese sgi_escape +sgifat sgi_faset +sgifia sgi_fillarea +sgiflh sgi_flush +sgifot sgi_font +sgigeg sgi_getseg +sgigey sgi_getcellarray +sgigsg sgi_gstring +sgiint sgi_init +sgilie sgi_linetype +sgimcl sgi_mcell +sgiopn sgi_open +sgiops sgi_openws +sgiplt sgi_plset +sgipmt sgi_pmset +sgipoe sgi_polyline +sgipor sgi_polymarker +sgipuy sgi_putcellarray +sgiret sgi_reset +sgitet sgi_text +sgitxt sgi_txset +sgkcle sgk_close +sgkdrw sgk_draw +sgkflh sgk_flush +sgkfre sgk_frame +sgklih sgk_linewidth +sgkmke sgk_mkfname +sgkmoe sgk_move +sgkopn sgk_open +sgkver sgk_vector +sgmexe sgm_execute +sgmgeg sgm_getmapping +sgmiod sgm_iomapread +sgmioe sgm_iomapwrite +sgmout sgm_output +sgmqur sgm_queryraster +sgmquy sgm_query +sgmrep sgm_readcmap +sgmres sgm_readpixels +sgmspc sgm_spoolesc +sgmwie sgm_winsize +sgmwrp sgm_writecmap +sgmwrs sgm_writepixels +sgmwse sgm_wsenable +sgmwsn sgm_wstran +smark smark +smark smark +spf_close spf_close +spf_open spf_open +sprinf sprintf +srftet srf_test +sscan sscan +stallc stalloc +stcloe stclose +stentr stenter +stfacs stf_access +stfadr stf_addpar +stfcle stf_close +stfcos stf_copyfits +stfcoy stf_copy +stfcte stf_ctype +stfdee stf_delete +stfgeb stf_getb +stfgei stf_geti +stfgen stf_gethdrextn +stfges stf_gets +stfget stf_getcmt +stfind stfind +stfinl stfindall +stfins stf_initwcs +stfmeb stf_mergegpb +stfmke stf_mkpixfname +stfnee stf_newimage +stfopn stf_open +stfopx stf_opix +stforb stf_ordergpb +stfrdr stf_rdheader +stfree stfree +stfrek stf_reblock +stfrfr stf_rfitshdr +stfrgb stf_rgpb +stfrne stf_rname +stfupr stf_updhdr +stfwfr stf_wfitshdr +stfwgb stf_wgpb +stgcal stg_cancel +stgcle stg_close +stgclr stg_clear +stgcls stg_closews +stgct1 stg_ctrl1 +stgct2 stg_ctrl2 +stgct3 stg_ctrl3 +stgctl stg_ctrl +stgdes stg_deactivatews +stgdrr stg_drawchar +stgdrw stg_draw +stgene stg_encode +stgese stg_escape +stgfat stg_faset +stgfia stg_fillarea +stgflh stg_flush +stggdb stg_gdisab +stggeb stg_genab +stggee stg_getline +stgger stg_getcursor +stggey stg_getcellarray +stggrm stg_grstream +stggsg stg_gstring +stgint stg_init +stglor stg_lockcursor +stgmoe stg_move +stgmsn stg_msglen +stgonr stg_onerror +stgont stg_onint +stgopn stg_open +stgops stg_openws +stgou2 stg_output2 +stgour stg_outstr +stgplt stg_plset +stgpmt stg_pmset +stgpoe stg_polyline +stgpor stg_polymarker +stgpue stg_putline +stgpuy stg_putcellarray +stgrdr stg_rdcursor +stgren stg_resolution +stgrer stg_readcursor +stgres stg_reactivatews +stgret stg_reset +stgrey stg_readtty +stgser stg_setcursor +stgtet stg_text +stgtxe stg_txsize +stgtxt stg_txset +stgtxy stg_txquality +stgunn stg_unknown +stgwry stg_writetty +sthash sthash +sthead sthead +stinfo stinfo +stkmkg stk_mkseg +stkmkg stk_mkseg +stmark stmark +stname stname +stnext stnext +stnsys stnsymbols +stopen stopen +stpstr stpstr +strcle strclose +strdic strdic +strefb strefstab +streff strefsbuf +streq streq +strese strestore +strge strge +strgee strgetmode +strgt strgt +strids stridxs +stridx stridx +strlds strldxs +strldx strldx +strle strle +strlt strlt +strlwr strlwr +strmac strmac +strmah strmatch +strncp strncmp +strne strne +stropn stropen +strse1 strse1 +strsee strsetmode +strseh strsearch +strsrt strsrt +strtbl strtbl +strupr strupr +stsave stsave +stsize stsize +stsque stsqueeze +sttyco sttyco +sttyet stty_envreset +sttygg stty_getarg +sttynm stty_newterm +sttyse stty_setsize +sttysm stty_showterm +sttytt stty_ttyinit +stxchs stx_chars +stxpas stx_parameters +stxpas stx_parameters +stxpas stx_parameters +stxpas stx_parameters +stxset stx_segment +stxset stx_segment +stxset stx_segment +stxset stx_segment +symbol symbol +syserr syserr +sysers syserrs +sysged sys_getcommand +sysges sys_getpars +sysgsg sys_gstrarg +sysid sysid +sysmte sys_mtime +syspac sys_panic +syspat sys_paramset +syspte sys_ptime +sysret sys_redirect +syssct sys_scanarglist +talloe t_allocate +tautoh t_autograph +tbfapd t_bfappend +tcalcp t_calcomp +tcap t_cap +tcdumd tc_dummy_ttyload +tcinic tc_init_datac +tcinii tc_init_datai +tclear t_clear +tcliet t_client +tcmp t_cmp +tcomp t_comp +tconrc t_conrec +tconrn t_conran +tconrq t_conraq +tconrs t_conras +tcopy t_copy +tcopy tcopy_ +tcoune t_countpoe +tcputr tc_putstr +tcreae t_create +tctowd t_ctowrd +tcwris tc_write_data_declarations215 +tdashh t_dashsmth +tdashr t_dashchar +tdayte t_daytime +tdeale t_deallocate +tdebug t_debug +tdump t_dump +tdumpl t_dumpevl +tedit t_edit +tefont t_efont +tencoe t_encode +tenter t_enter +teq t_eq +testtt testtext +testxt testxset +texpad t_expand +textrt t_extract +tezcoc t_ezconrec +teziss t_ezisos +tezmag t_ezmapg +tezsue t_ezsurface +tezvet t_ezvelvect +tezytt t_ezytst +tfcace t_fcache +tfind t_find +tfloat t_float +tfnl t_fnl +tfont t_font +tfree t_free +tge t_ge +tget t_get +tgettk tgettk_ +tggcur t_ggcur +tgkide t_gkidecode +tgrey t_grey +tgrid t_grid +tgt t_gt +thello thello_ +thlist t_hlist +thttp t_http +ticks ticks +timdkn t_imdkern +timt t_imt +timtet t_imtest +tinit t_init +tinv t_inv +tirafs t_irafks +tisosf t_isosrf +tle t_le +tlex t_lex +tlist t_list +tload t_load +tlt t_lt +tmany t_many +tmark t_mark +tmat t_mat +tmemck t_memchk +tmergi t_mergei +tmio t_mio +tmkfie t_mkfile +tmkmak t_mkmask +tmkpoe t_mkpoe +tmktta t_mkttydata +tmpp t_mpp +tmtcoy t_mtcopy +tmtexe t_mtexamine +tmtpon t_mtposition +tncmp t_ncmp +tne t_ne +tnewcy t_newcopy +tnsppn t_nsppkern +toldao t_oldauto +toshot to_short +tparsi t_parsei +tparsr t_parser +tpbb t_pbb +tplote t_plotpoe +tpltet t_pltest +tpmtet t_pmtest +tprint tprint_ +tprzs t_przs +tput t_put +tpwriy t_pwrity +tqppae t_qpparse +trealc t_realloc +trealc t_realloc +trebud t_rebuild +trecio t_recio +trewid t_rewind +trexec t_rexec +trread t_rread +trtype t_rtype +tsave t_save +tscan tscan_ +tscrit t_script +tseeft t_seefont +tservr t_server +tsetft t_setfilt +tsetmk t_setmask +tsetws t_setwcs +tsgide t_sgidecode +tsgikn t_sgikern +tshow t_show +tshowp t_showcap +tsimpe t_simple +tsleep tsleep +tslio t_slio +tspawn t_spawn +tspool t_spool +tsrch t_srch +tsrftt t_srftest +tstats t_status +tstdgh t_stdgraph +tstrmn t_strmln +tsum t_sum +tsum t_sum +tsurfe t_surface +tsym t_sym +tsyms t_syms +tteste t_testpoe +ttext t_text +ttfilr t_tfilter +tthre2 t_threed2 +tthred t_threed +ttokes t_tokens +ttopen ttopen +ttseti ttseti +ttsets ttsets +ttstai ttstati +ttstas ttstats +ttty t_tty +ttxo t_txo +ttxup t_txup +tty_continue tty_continue +tty_onsig tty_onsig +tty_rawon tty_rawon +tty_reset tty_reset +tty_stop tty_stop +ttybih tty_binsearch +ttybre tty_break_line +ttycas ttycaps +ttycds ttycdes +ttycle ttyclose +ttycln ttyclearln +ttyclr ttyclear +ttyctl ttyctrl +ttydee ttydevname +ttydey ttydelay +ttyeny tty_encode_capability161 +ttyexs tty_extract_alias +ttyfey tty_fetch_entry +ttyfiy tty_find_capability +ttygds ttygdes +ttygeb ttygetb +ttygei ttygeti +ttyger ttygetr +ttyges ttygets +ttygoo ttygoto +ttygpe ttygputline +ttygse ttygsize +ttyins tty_index_caps +ttyint ttyinit +ttylod ttyload +ttyods ttyodes +ttyopn ttyopen +ttype t_type +ttypue ttyputline +ttypus ttyputs +ttyred ttyread +ttysce tty_scan_termcap_file +ttysei ttyseti +ttyso ttyso +ttysti ttystati +ttysui ttysubi +ttywre ttywrite +tunget t_unget +tvelvt t_velvect +tvttet t_vttest +twcs t_wcs +twtese t_wtestfile +u_allocstat u_allocstat +u_atof atof +u_atoi atoi +u_atol atol +u_calloc calloc +u_crackformat u_crackformat +u_doarg u_doarg +u_doprnt u_doprnt +u_doscan u_doscan +u_envget envget +u_eprintf eprintf +u_fclose fclose +u_fdopen fdopen +u_fflush fflush +u_fgetc fgetc +u_fgets fgets +u_fopen fopen +u_fprintf fprintf +u_fputc fputc +u_fputs fputs +u_fread fread +u_free free +u_freopen freopen +u_fscanf fscanf +u_fseek fseek +u_ftell ftell +u_fwrite fwrite +u_gets gets +u_getw getw +u_index index +u_isatty isatty +u_malloc malloc +u_mktemp mktemp +u_perror perror +u_printf printf +u_puts puts +u_putw putw +u_qsort qsort +u_realloc realloc +u_rewind rewind +u_rindex rindex +u_scanf scanf +u_scannum u_scannum +u_scanstr u_scanstr +u_setbuf setbuf +u_setfbf setbuffer +u_setlinebuf setlinebuf +u_setucc u_setucc +u_sprintf sprintf +u_sscanf sscanf +u_strcat strcat +u_strcmp strcmp +u_strcpy strcpy +u_strlen strlen +u_strnp strncmp +u_strnt strncat +u_strny strncpy +u_system system +u_ungetc ungetc +uid_executing uid_executing +uio_bwrite uio_bwrite +ungete ungetline +ungeti ungetci +unread unread +urand urand +vdm vdm +vfnadd vfnadd +vfncle vfnclose +vfndee vfn_decode +vfndel vfndel +vfnene vfn_encode +vfnenr vfn_enter +vfnexr vfn_expand_ldir +vfngen vfn_getosfn +vfnise vfn_is_hidden_file868 +vfnman vfn_map_extension +vfnmap vfnmap +vfnmau vfnmapu +vfnopn vfnopen +vfnsqe vfn_squeeze +vfntre vfn_translate +vfnunn vfn_unmap_extension733 +vfnunp vfnunmap +vlibinit VLIBINIT +vmallc vmalloc +vmallc vmalloc +vvfncm vvfn_checksum +vvfnee vvfn_escape +vvfnip vvfn_init_extnmap +vvfnis vvfn_init_reserved_extns908 +vvfnre vvfn_readmapfile +wfaitd wf_ait_fwd +wfaitt wf_ait_init +wfaitv wf_ait_inv +wfarcd wf_arc_fwd +wfarct wf_arc_init +wfarcv wf_arc_inv +wfcard wf_car_fwd +wfcart wf_car_init +wfcarv wf_car_inv +wfcscd wf_csc_fwd +wfcsct wf_csc_init +wfcscv wf_csc_inv +wfdecs wf_decaxis +wffnld wf_fnload +wfglsd wf_gls_fwd +wfglst wf_gls_init +wfglsv wf_gls_inv +wfinit wf_init +wfmerd wf_mer_fwd +wfmert wf_mer_init +wfmerv wf_mer_inv +wfmold wf_mol_fwd +wfmolt wf_mol_init +wfmolv wf_mol_inv +wfmspd wf_msp_fwd +wfmspf wf_msp_coeff +wfmspi wf_msp_evali +wfmspl wf_msp_eval +wfmspt wf_msp_init +wfmspv wf_msp_inv +wfmspy wf_msp_destroy +wfpard wf_par_fwd +wfpart wf_par_init +wfparv wf_par_inv +wfpcod wf_pco_fwd +wfpcot wf_pco_init +wfpcov wf_pco_inv +wfqscd wf_qsc_fwd +wfqsct wf_qsc_init +wfqscv wf_qsc_inv +wfsind wf_sin_fwd +wfsint wf_sin_init +wfsinv wf_sin_inv +wfsmph wf_smp_binsearch +wfsmpn wf_smp_ctran +wfsmpt wf_smp_init +wfstgd wf_stg_fwd +wfstgt wf_stg_init +wfstgv wf_stg_inv +wftand wf_tan_fwd +wftant wf_tan_init +wftanv wf_tan_inv +wftscd wf_tsc_fwd +wftsct wf_tsc_init +wftscv wf_tsc_inv +wfzead wf_zea_fwd +wfzeat wf_zea_init +wfzeav wf_zea_inv +writeb writeb +xalloe xallocate +xcallc calloc +xcallc calloc +xdeale xdeallocate +xdevor xdevowner +xdevss xdevstatus +xeract xeract +xerfmg xer_fmterrmsg +xerpoi xerpopi +xerpop xerpop +xerpsh xerpsh +xerpsr xerpstr +xerpuc xerputc +xerpue xer_putline +xerret xer_reset +xerror error +xersel xer_send_error_statement_to_cl +xervey xer_verify +xevadg xev_addarg +xevbip xev_binop +xevbop xev_boolop +xevcan xev_callfcn +xever1 xev_error1 +xever2 xev_error2 +xeverr xev_error +xevfrp xev_freeop +xevgek xev_gettok +xevinp xev_initop +xevmap xev_makeop +xevnee xev_newtype +xevpah xev_patmatch +xevqut xev_quest +xevstt xev_startarglist +xevunp xev_unop +xfaccs access +xfatal fatal +xfchdr fchdir +xfcloe close +xfdele delete +xffluh flush +xfgetc getc +xfgetr getchar +xfnote note +xfopen open +xfputc putc +xfputr putchar +xfread read +xfrnam rename +xfscan fscan +xfseek seek +xfungc ungetc +xfwrie write +xgdevt xgdevlist +xgtpid getpid +xgtuid getuid +xisaty xisatty +xmallc malloc +xmallc malloc +xmfree mfree +xmfree mfree +xmjbuf xmjbuf +xmktep mktemp +xonerr xonerror +xonext xonexit +xori xori +xorl xorl +xors xors +xpages xpagefiles +xprinf printf +xqsort qsort +xrealc realloc +xrealc realloc +xsizef sizeof +xsizef sizeof +xstdeh xstdexh +xstrcp strcmp +xstrct strcat +xstrcy strcpy +xstrln strlen +xtoc xtoc +xttyse xttysize +xvvadg xvv_addarg +xvvbip xvv_binop +xvvbop xvv_boolop +xvvcan xvv_callfcn +xvvche xvv_chtype +xvver1 xvv_error1 +xvver2 xvv_error2 +xvverr xvv_error +xvvfrp xvv_freeop +xvvgek xvv_gettok +xvvinp xvv_initop +xvvlos xvv_loadsymbols +xvvmap xvv_makeop +xvvnee xvv_newtype +xvvnud xvv_nulld +xvvnui xvv_nulli +xvvnul xvv_nulll +xvvnur xvv_nullr +xvvnus xvv_nulls +xvvpah xvv_patmatch +xvvqut xvv_quest +xvvstt xvv_startarglist +xvvunp xvv_unop +xwhen xwhen +xxscan scan +yypare yyparse +yypare yyparse +zardbf ZARDBF +zardks ZARDKS +zardlp ZARDLP +zardmt zardmt +zardnd ZARDND +zardnu zardnu +zardpl ZARDPL +zardpr ZARDPR +zardps zardps +zardsf ZARDSF +zawrbf ZAWRBF +zawrks ZAWRKS +zawrlp ZAWRLP +zawrmt zawrmt +zawrnd ZAWRND +zawrnu zawrnu +zawrpl ZAWRPL +zawrpr ZAWRPR +zawrps zawrps +zawrsf ZAWRSF +zawset ZAWSET +zawtbf ZAWTBF +zawtks ZAWTKS +zawtlp ZAWTLP +zawtmt zawtmt +zawtnd ZAWTND +zawtnu zawtnu +zawtpl ZAWTPL +zawtpr ZAWTPR +zawtps zawtps +zawtsf ZAWTSF +zcall0 ZCALL0 +zcall1 ZCALL1 +zcall2 ZCALL2 +zcall3 ZCALL3 +zcall4 ZCALL4 +zcall5 ZCALL5 +zcall6 ZCALL6 +zcall7 ZCALL7 +zcall8 ZCALL8 +zcall9 ZCALL9 +zcalla ZCALLA +zclcpr ZCLCPR +zcldir ZCLDIR +zcldpr ZCLDPR +zclsbf ZCLSBF +zclsks ZCLSKS +zclslp ZCLSLP +zclsmt zclsmt +zclsnd ZCLSND +zclsnu zclsnu +zclspl ZCLSPL +zclsps zclsps +zclssf ZCLSSF +zclstt zclstt +zclstx ZCLSTX +zclsty ZCLSTY +zdojmp ZDOJMP +zdvall ZDVALL +zdvown ZDVOWN +zfacss ZFACSS +zfaloc ZFALOC +zfchdr ZFCHDR +zfdele ZFDELE +zfgcwd ZFGCWD +zfinfo ZFINFO +zflsnu zflsnu +zflstt zflstt +zflstx ZFLSTX +zflsty ZFLSTY +zfmkcp ZFMKCP +zfmkdr ZFMKDR +zfnbrk ZFNBRK +zfpath ZFPATH +zfprot ZFPROT +zfrnam ZFRNAM +zfsubd ZFSUBD +zfunc0 ZFUNC0 +zfunc1 ZFUNC1 +zfunc2 ZFUNC2 +zfunc3 ZFUNC3 +zfunc4 ZFUNC4 +zfunc5 ZFUNC5 +zfunc6 ZFUNC6 +zfunc7 ZFUNC7 +zfunc8 ZFUNC8 +zfunc9 ZFUNC9 +zfunca ZFUNCA +zfxdir ZFXDIR +zgcmdl ZGCMDL +zgetnu zgetnu +zgettt zgettt +zgettx ZGETTX +zgetty ZGETTY +zgfdir ZGFDIR +zghost ZGHOST +zgtenv ZGTENV +zgtime ZGTIME +zgtpid ZGTPID +zintpr ZINTPR +zlocpr ZLOCPR +zlocva ZLOCVA +zmaloc ZMALOC +zmfree ZMFREE +zmtbsf zmtbsf +zmtbsr zmtbsr +zmtclose zmtclose +zmtdbg zmtdbg +zmtdbg1 zmtdbg1 +zmtdbg2 zmtdbg2 +zmtdbg3 zmtdbg3 +zmtdbg4 zmtdbg4 +zmtdbg5 zmtdbg5 +zmtdbgclose zmtdbgclose +zmtdbgopen zmtdbgopen +zmtdesc zmtdesc +zmtfls zmtfls +zmtfpos zmtfpos +zmtfree zmtfree +zmtfsf zmtfsf +zmtfsr zmtfsr +zmtgetfd zmtgetfd +zmtopen zmtopen +zmtrew zmtrew +znotnu znotnu +znottt znottt +znottx ZNOTTX +znotty ZNOTTY +zopcpr ZOPCPR +zopdir ZOPDIR +zopdpr ZOPDPR +zopnbf ZOPNBF +zopnks ZOPNKS +zopnlp ZOPNLP +zopnmt zopnmt +zopnnd ZOPNND +zopnnu zopnnu +zopnpl ZOPNPL +zopnsf ZOPNSF +zopntt zopntt +zopntx ZOPNTX +zopnty ZOPNTY +zoscmd ZOSCMD +zpanic ZPANIC +zputnu zputnu +zputtt zputtt +zputtx ZPUTTX +zputty ZPUTTY +zraloc ZRALOC +zseknu zseknu +zsektt zsektt +zsektx ZSEKTX +zsekty ZSEKTY +zsestt zsestt +zsettt zsettt +zststt zststt +zsttbf ZSTTBF +zsttks ZSTTKS +zsttlp ZSTTLP +zsttmt zsttmt +zsttnd ZSTTND +zsttnu zsttnu +zsttpl ZSTTPL +zsttpr ZSTTPR +zsttps zsttps +zsttsf ZSTTSF +zstttt zstttt +zstttx ZSTTTX +zsttty ZSTTTY +zttgeg ztt_getlog +zttger ztt_getchar +zttloe ztt_lowercase +zttloo ztt_logio +zttlov ztt_logdev +zttpbf ztt_pboff +zttplk ztt_playback +zttpug ztt_putlog +zttquy ztt_query +zttttt ztt_ttyput +zttupe ztt_uppercase +zwmsec ZWMSEC +zxgmes ZXGMES +zxwhen ZXWHEN +zzclmt ZZCLMT +zzhelp zz_help +zzopmt ZZOPMT +zzrdmt ZZRDMT +zzrwmt ZZRWMT +zzsetk ZZSETK +zzstmt ZZSTMT +zzstop ZZSTOP +zzstrt ZZSTRT +zzwrmt ZZWRMT +zzwtmt ZZWTMT diff --git a/sys/README b/sys/README new file mode 100644 index 00000000..52391e06 --- /dev/null +++ b/sys/README @@ -0,0 +1,27 @@ +These directories contain the source and libraries for the IRAF system, i.e., +the system interface or "virtual operating system" (VOS) and the machine +independent i/o libraries comprising the program interface. To rebuild the +VOS merely run "mkpkg" after bringing up the bootstrap utilities and libraries +in host$. To relink the system executables after an important modification +to the VOS, type "mkpkg update". + + clio command language i/o + dbio database i/o + etc miscellanous system modules + fio file i/o + flib contains nop.x, used to list modules for libmain.o + fmtio formatted i/o + gio graphics i/o + imio image i/o + ki kernel inteface (networking) + memio memory i/o + mkpkg descriptor file for the MKPKG utility + mtio magnetic tape i/o + osb bit and byte primitives + spool record of the last sysgen + vops vector operators + +For example: + + mkpkg >& spool & make or update the VOS libraries + mkpkg update update the system executables diff --git a/sys/_sys.hd b/sys/_sys.hd new file mode 100644 index 00000000..4179b770 --- /dev/null +++ b/sys/_sys.hd @@ -0,0 +1,5 @@ +# Root help directory for the SYS branch of the help database. + +sys sys = sys$README, + hlp = sys$sys.men, + pkg = sys$sys.hd diff --git a/sys/clio/README b/sys/clio/README new file mode 100644 index 00000000..757b5550 --- /dev/null +++ b/sys/clio/README @@ -0,0 +1,98 @@ +CLIO - Command Language I/O. + +This is the interface between IRAF applications and the IRAF command +language. To an application, the CL appears to be a database managing named +"psets" (parameter sets) containing parameters. CLIO is used by the +application to read and write these parameters. The parameter sets are +predefined at the CL level rather than being dynamically defined by the +application. + + +EXTERNAL ROUTINES + + clseti (clio-param, value) + value = clstati (clio-param) + + value = clget[bcsilrdx] (param) + clput[bcsilrdx] (param, value) + clgstr (param, outstr, maxch) + clpstr (param, value) + nelem|EOF = clgl[bcsilrdx] (param, value) + nchars|EOF = clglstr (param, outstr, maxch) + + key|EOF = clgcur (param, wx, wy, wcs, key, strval, maxch) + nitems = clgkey (param, key, strval, maxch) + kwindex = clgwrd (param, keyword, maxchar, dictionary) + + pp = clopset (pset) + clcpset (pp) + pval = clgpset[bcsilrdx] (pp, param) + clppset[bcsilrdx] (pp, param, pval) + clgpseta (pp, pname, outstr, maxch) + clppseta (pp, pname, sval) + cllpset (pp, fd, format) + clepset (pp) + + +OBSOLETE ROUTINES + + list = clpopn[isu] (param) + clpcls (list) + clprew (list) + nelem = clplen (list) + nchars = clgfil (list, fname, maxch) + + clgpset (pp, pname, outstr, maxch) + clppset (pp, pname, sval) + + +RESTRICTED ROUTINES + + clcmd (cmd) + clcmdw (cmd) + + clopen (stdin, stdout, stderr, device, devtype) + zclsps (chan, status) + zardps (ps, buf, maxbytes, offset) + zawrps (ps, buf, nbytes, offset) + zawtps (ps, status) + zsttps (ps, what, lvalue) + + clc_init () + clc_compress () + clc_free (marker) + clc_mark (marker) + clc_newtask (taskname) + clc_enter (param, value) + nchars = clc_fetch (param, outstr, maxch) + sym = clc_find (param, outstr, maxch) + clc_list (fd, pset, format) + clc_scan (cmd) + + gexfls () + gexfls_set (stream, gp_value, epa_gflush) + gexfls_clear (stream) + + +INTERNAL ROUTINES + + key|EOF = rdukey (keystr, maxch) + charp = clpset_parname (pp, parname) + status = cl_psio_request (cmd, arg1, arg2) + clreqpar (param) + + +INTERFACE PARAMETERS + + # clstati parameters (read only). + CL_PRTYPE # parent process type (see below) + CL_PCACHE # symtab descriptor of param cache + + # Process type codes. + PR_CONNECTED # connected subprocess + PR_DETACHED # detached subprocess + PR_HOST # subprocess spawned by host + + # Process interpreter mode codes (used by ONENTRY and the iraf main). + PR_NOEXIT # run interpreter in Iraf Main + PR_EXIT # skip interpreter, shutdown process diff --git a/sys/clio/clcache.x b/sys/clio/clcache.x new file mode 100644 index 00000000..2d6df333 --- /dev/null +++ b/sys/clio/clcache.x @@ -0,0 +1,490 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +.help clcache +.nf ___________________________________________________________________________ +CLCACHE -- A package for cacheing the values of static parameters, i.e., +parameters with values fixed at task invocation time. + +The purpose of this package is to improve the runtime performance of the +parameter passing mechanism. The runtime semantics of the CLIO interface are +not affected. Transmission of the static parameters during task invocation +can save many runtime context switches, saving seconds of clock time when +running tasks which have many (dozens of) parameters. + + + clc_init () # initialize the cache + clc_compress () # rebuild the cache + clc_newtask (taskname) # set name of root pset + clc_mark (sp) # mark cache status + clc_free (sp) # free to last mark + + clc_enter (param, value) # cache a parameter + nchars = clc_fetch (param, out, maxch) # fetch cached parameter + symp = clc_find (param, out, maxch) # find cached parameter + + clc_scan (cmd) # scan a param=value stmt + clc_list (fd, pset, format) # list params to a file + +The cache is initialized by the IRAF main with CLC_INIT during process +startup and whenever a new task is run. Parameter value pairs are entered +into the cache with CLC_ENTER during processing of the command line. +Runtime get parameter requests from the task are satisfied from the cache if +possible, querying the CL only if the cached value cannot be found. Note +that query mode and list type parameters are never cached since they do not +have static values. + +A task can be called either with named parameters or with unnamed, positional +parameters. In the latter case the parameters are passed as "$1", "$2", etc. +If we receive one or more numbered parameters they will be entered into the +symbol table in the usual way but a list of offsets of the positional +arguments will be saved in the clio common. Subsequent runtime parameter +requests will be satisfied by trying to find the parameter by name in the +symbol table, returning the next positional argument if the named parameter +cannot be found. This is the mechanism used by the CL to satisfy requests +for parameters from a task which has no parameter file. + +The values of all parameters are saved in the cache in string format. Since +all parameters come from the CL in string format this makes for an easy +interface to the high level CLIO code. The internal storage format for the +cache is a SYMTAB hash table, simplifying the implementation and providing +optimal performance. There is no fixed limit on the size of the cache. +.endhelp _____________________________________________________________________ + +# SYMTAB default allocation parameters (non-limiting). +define LEN_INDEX 128 # nbuckets in symtab hash index +define LEN_STAB 512 # initial symbol table size +define SZ_SBUF 2048 # initial string buffer size + + +# Symbol table structure (not much to it). + +define LEN_SYMSTRUCT 1 +define SYM_VALUE Memi[$1] # sbuf offset of value string + + +# CLC_INIT -- Initialize the parameter cache. Called during process +# startup. May be called repeatedly to reinitialize the cache. + +procedure clc_init() + +pointer stopen() +bool first_time +data first_time /true/ +include "clio.com" +errchk stopen + +begin + if (first_time) { + cl_stp = stopen ("clcache", LEN_INDEX, LEN_STAB, SZ_SBUF) + first_time = false + } else + call stfree (cl_stp, cl_stmark) + + call stmark (cl_stp, cl_stmark) + call aclri (cl_posarg, MAX_POSARGS) + cl_nposargs = 0 + cl_nextarg = 1 +end + + +# CLC_NEWTASK -- Set the name of the task whose parameters are to be +# entered into the cache (the taskname is the root pset). + +procedure clc_newtask (taskname) + +char taskname[ARB] # name of the task being run + +int gstrcpy() +include "clio.com" + +begin + cl_psetop = gstrcpy (taskname, cl_psetname, SZ_PSETNAMEBUF) + 2 + cl_psetindex[1] = 1 + cl_npsets = 1 +end + + +# CLC_MARK -- Mark storage in the cache for subsequent restoration by +# clc_free. + +procedure clc_mark (marker) + +pointer marker # receives marked position +include "clio.com" + +begin + call stmark (cl_stp, marker) +end + + +# CLC_FREE -- Free storage in the cache back to the marked position. Any +# positional arguments are lost. + +procedure clc_free (marker) + +pointer marker # marked position +include "clio.com" + +begin + call stfree (cl_stp, marker) + cl_nposargs = 0 + cl_nextarg = 1 + call aclri (cl_posarg, MAX_POSARGS) +end + + +# CLC_ENTER -- Enter a parameter-value pair into the cache. If the parameter +# is an unnamed positional parameter ($N) it is entered in the usual way +# with name $N, but its symtab pointer is also saved in the positional argument +# list. It is safe to save the pointer rather than the index because tasks +# which do not have pfiles never have more than a few arguments, hence the +# symtab will not be reallocated during entry. +# +# If the parameter name is of the form psetname.paramname, extract the pset +# name and add it to the list of pset names for the task. The order in which +# the pset names are defined will be the order in which they are later searched +# when satifying ambiguous references (where the psetname is not specified). + +procedure clc_enter (param, value) + +char param[ARB] # parameter name +char value[ARB] # parameter value string + +pointer sym +int off, ch, pp, op, ip, n +bool streq() +pointer stenter() +int stpstr(), ctoi() +errchk stenter, syserrs +include "clio.com" + +begin + sym = stenter (cl_stp, param, LEN_SYMSTRUCT) + SYM_VALUE(sym) = stpstr (cl_stp, value, 0) + + if (param[1] == '$') { + # Positional argument (no pfile/pset). + + ip = 2 + if (ctoi (param, ip, n) > 0) { + n = max(1, min(MAX_POSARGS, n)) + cl_posarg[n] = sym + cl_nposargs = max (cl_nposargs, n) + } + + } else { + # Check if the parameter name includes the psetname prefix, + # and if so, append the pset name to the pset name list if + # not already there. + + pp = cl_psetop + op = pp + + # Extract psetname. + do ip = 1, SZ_PNAME { + ch = param[ip] + if (ch == EOS) { + return # no psetname given + } else if (ch == '.') { + cl_psetname[op] = EOS + break + } else { + cl_psetname[op] = ch + op = op + 1 + } + } + + # If pset already in list we are done. + ch = param[1] + do ip = cl_npsets, 1, -1 { + off = cl_psetindex[ip] + if (cl_psetname[off] == ch) + if (streq (cl_psetname[pp], cl_psetname[off])) + return + } + + # Pset not found, so enter new pset name into list. + cl_npsets = cl_npsets + 1 + if (cl_npsets > MAX_PSETS) + call syserrs (SYS_CLNPSETS, cl_psetname[pp]) + + cl_psetindex[cl_npsets] = pp + cl_psetop = op + 1 + if (cl_psetop > SZ_PSETNAMEBUF) + call syserrs (SYS_CLPSETOOS, cl_psetname[pp]) + } +end + + +# CLC_FETCH -- Search the CL parameter cache for the named parameter and +# return its value if found. If the parameter is not found and there are +# positional arguments, return the value of the next positional argument. +# The number of characters in the output string is returned as the function +# value if the parameter is found, else ERR is returned. + +int procedure clc_fetch (param, outstr, maxch) + +char param[ARB] # parameter to be fetched +char outstr[maxch] # receives value string of parameter +int maxch + +pointer sym, vp +int gstrcpy() +pointer strefsbuf(), clc_find() +include "clio.com" + +begin + # Search the symbol table for the named parameter. + sym = clc_find (param, outstr, maxch) + + # If the named parameter could not be found using the given name or + # in any pset in the table, use the next positional argument if there + # is one. + + while (sym == NULL) + if (cl_nextarg <= cl_nposargs) { + sym = cl_posarg[cl_nextarg] + cl_nextarg = cl_nextarg + 1 + } else { + outstr[1] = EOS + return (ERR) + } + + vp = strefsbuf (cl_stp, SYM_VALUE(sym)) + return (gstrcpy (Memc[vp], outstr, maxch)) +end + + +# CLC_FIND -- Search the CL parameter cache for the named parameter and +# return its symtab pointer and full name if found. + +pointer procedure clc_find (param, outstr, maxch) + +char param[ARB] # parameter to be fetched +char outstr[maxch] # receives full name of parameter +int maxch + +pointer sym +int op, ip, ch, i +pointer stfind() +include "clio.com" + +begin + # Look first for the named parameter, and if that is not found, + # search each pset for the named parameter, i.e., prepend the name + # of each pset to produce a name of the form "pset.param", and + # look that up in the symbol table. The first entry in the pset + # name list is the name of the task itself. + + sym = stfind (cl_stp, param) + if (sym == NULL) { + do i = 1, cl_npsets { + op = 1 + + # Start with pset name. + do ip = cl_psetindex[i], SZ_PSETNAMEBUF { + ch = cl_psetname[ip] + if (ch == EOS) + break + else { + cl_pname[op] = ch + op = op + 1 + } + } + + # Add dot delimiter. + cl_pname[op] = '.' + op = op + 1 + + # Lastly add the parameter name. + do ip = 1, SZ_FNAME { + ch = param[ip] + if (ch == EOS) + break + else { + cl_pname[op] = ch + op = op + 1 + } + } + + # Look it up in the symbol table. + cl_pname[op] = EOS + sym = stfind (cl_stp, cl_pname) + if (sym != NULL) + break + } + } else + call strcpy (param, cl_pname, SZ_FNAME) + + if (sym != NULL) + call strcpy (cl_pname, outstr, maxch) + + return (sym) +end + + +# CLC_SCAN -- Extract the param and value substrings from a param=value +# statement and enter them into the CL parameter cache. + +procedure clc_scan (cmd) + +char cmd[ARB] #I command to be scanned + +int ip +pointer sp, param, value, op, nchars +int stridx(), ctowrd() + +begin + call smark (sp) + call salloc (param, SZ_FNAME, TY_CHAR) + call salloc (value, SZ_COMMAND, TY_CHAR) + + # Skip any leading whitespace. + for (ip=1; IS_WHITE(cmd[ip]); ip=ip+1) + ; + + # Do nothing if blank line or comment. + if (cmd[ip] == EOS || cmd[ip] == '\n' || cmd[ip] == '#') { + call sfree (sp) + return + } + + # Extract the param field. + op = param + while (IS_ALNUM (cmd[ip]) || stridx (cmd[ip], "_.$") > 0) { + Memc[op] = cmd[ip] + op = op + 1 + ip = ip + 1 + } + Memc[op] = EOS + + # Advance past the assignment operator. + while (IS_WHITE (cmd[ip]) || cmd[ip] == '=') + ip = ip + 1 + + # Get the value string. + nchars = ctowrd (cmd, ip, Memc[value], SZ_COMMAND) + + # Enter the param=value pair into the CL parameter cache. + call clc_enter (Memc[param], Memc[value]) + + call sfree (sp) +end + + +# CLC_LIST -- List the parameters in the named pset to an output file using +# a caller supplied format. If no pset is specified the entire contents of +# the parameter cache are output. A sample format is "set %s = \"%s\"\n". + +procedure clc_list (fd, pset, format) + +int fd #I output file +char pset[ARB] #I pset to be listed, or EOS for full cache +char format[ARB] #I output format - one %s each for param,value + +int nsyms, i +pointer sp, syms, sympset, ip, op, sym, np + +bool strne() +pointer sthead(), stnext(), stname(), strefsbuf() +include "clio.com" + +begin + # Count the number of parameters. + nsyms = 0 + for (sym=sthead(cl_stp); sym != NULL; sym=stnext(cl_stp,sym)) + nsyms = nsyms + 1 + + call smark (sp) + call salloc (syms, nsyms, TY_POINTER) + call salloc (sympset, SZ_FNAME, TY_CHAR) + + # Get a reversed list of symbol pointers. + op = syms + nsyms - 1 + for (sym=sthead(cl_stp); sym != NULL; sym=stnext(cl_stp,sym)) { + Memi[op] = sym + op = op - 1 + } + + # Output the list. + do i = 1, nsyms { + sym = Memi[syms+i-1] + np = stname (cl_stp, sym) + + # Check the pset name if the user named a specific pset. + if (pset[1] != EOS) { + # Get the pset name of the parameter. + op = sympset + for (ip=np; Memc[ip] != EOS && Memc[ip] != '.'; ip=ip+1) { + Memc[op] = Memc[ip] + op = op + 1 + } + Memc[op] = EOS + + # Skip if the wrong pset. + if (strne (Memc[sympset], pset)) + next + } + + call fprintf (fd, format) + call pargstr (Memc[np]) + call pargstr (Memc[strefsbuf(cl_stp,SYM_VALUE(sym))]) + } + + call sfree (sp) +end + + +# CLC_COMPRESS -- Compress the parameter cache. Since every parameter +# modification results in a new parameter entry (redef), the symbol table +# can grow quite large if there are many clput type parameter accesses. +# This operator rebuilds the parameter cache eliminating all old entries. + +procedure clc_compress () + +pointer n_st, o_st +pointer sym, newsym, np, vp + +int stpstr() +pointer strefsbuf(), stopen(), stname() +pointer sthead(), stnext(), stfind(), stenter() +errchk stopen, stenter, stpstr +include "clio.com" + +begin + n_st = stopen ("clcache", LEN_INDEX, LEN_STAB, SZ_SBUF) + o_st = cl_stp + + # Copy the symbol table, saving only the most recent entry for + # each symbol. + + for (sym=sthead(o_st); sym != NULL; sym=stnext(o_st,sym)) { + np = stname (o_st, sym) + if (stfind (n_st, Memc[np]) == NULL) { + vp = strefsbuf (o_st, SYM_VALUE(sym)) + newsym = stenter (n_st, Memc[np], LEN_SYMSTRUCT) + SYM_VALUE(newsym) = stpstr (n_st, Memc[vp], 0) + } + } + + # Copy back the saved symbols. The "push/pop" way in which we use + # the temporary symbol table to save the symbols automatically + # preserves the original symbol table ordering. + + call stfree (o_st, cl_stmark) + call stmark (o_st, cl_stmark) + + for (sym=sthead(n_st); sym != NULL; sym=stnext(n_st,sym)) { + np = stname (n_st, sym) + vp = strefsbuf (n_st, SYM_VALUE(sym)) + newsym = stenter (o_st, Memc[np], LEN_SYMSTRUCT) + SYM_VALUE(newsym) = stpstr (o_st, Memc[vp], 0) + } + + call stclose (n_st) + call stsqueeze (o_st) +end diff --git a/sys/clio/clclose.x b/sys/clio/clclose.x new file mode 100644 index 00000000..7d2b6cbf --- /dev/null +++ b/sys/clio/clclose.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# CLCLOSE -- "Close" the CL files (shut down CLIO). Called by the IRAF Main +# upon process shutdown. + +procedure clclose () + +int fd + +begin + # Remove buffers for the standard streams. + do fd = 1, FIRST_FD-1 + call frmbfs (fd) +end diff --git a/sys/clio/clcmd.x b/sys/clio/clcmd.x new file mode 100644 index 00000000..99e21340 --- /dev/null +++ b/sys/clio/clcmd.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# CLCMD -- Send a command line to the CL. Virtually any general command +# may be sent to the CL, providing a great deal of high level power at the +# compiled task level. Sending an explicit command to the CL, however, +# requires that the task have detailed knowledge of the capabilities of +# the CL and of the syntax of the command language. This means that the task +# is very dependent on the CL and may no longer work if the CL is modified, +# or if there is more than one version of the CL in use in a system. For +# this reason CLCMD should only be used where it is truely necessary, +# usually only in system utilities (for example, in a task like MAKE). + +procedure clcmd (cmd) + +char cmd[ARB] + +int junk +int oscmd(), clstati() +errchk syserr + +begin + if (cmd[1] == '!') + junk = oscmd (cmd[2], "", "", "") + else if (clstati (CL_PRTYPE) != PR_CONNECTED) + call syserr (SYS_CLCMDNC) + else { + call flush (STDOUT) + call putline (CLOUT, cmd) + call putci (CLOUT, '\n') + call flush (CLOUT) + } +end diff --git a/sys/clio/clcmdw.x b/sys/clio/clcmdw.x new file mode 100644 index 00000000..ca8dfc4c --- /dev/null +++ b/sys/clio/clcmdw.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# CLCMDW -- Send a command line to the CL and wait for completion. + +procedure clcmdw (cmd) + +char cmd[ARB] +char junkstr[1] + +int junk +int oscmd(), clstati() +errchk syserr + +begin + if (cmd[1] == '!') + junk = oscmd (cmd[2], "", "", "") + else if (clstati (CL_PRTYPE) != PR_CONNECTED) + call syserr (SYS_CLCMDNC) + else { + call flush (STDOUT) + call putline (CLOUT, cmd) + call putci (CLOUT, '\n') + call clgstr ("cl.version", junkstr, 1) # wait for completion + } +end diff --git a/sys/clio/clcpset.x b/sys/clio/clcpset.x new file mode 100644 index 00000000..c6200b66 --- /dev/null +++ b/sys/clio/clcpset.x @@ -0,0 +1,11 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CLCPSET -- Close a pset. + +procedure clcpset (pp) + +pointer pp # pset descriptor + +begin + call mfree (pp, TY_STRUCT) +end diff --git a/sys/clio/clepset.x b/sys/clio/clepset.x new file mode 100644 index 00000000..df0dce03 --- /dev/null +++ b/sys/clio/clepset.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "clpset.h" + +# CLEPSET -- Edit a pset. What exactly this operation implies depends +# upon the CL. To the application, it means any external operation which +# can modify the pset. + +procedure clepset (pp) + +pointer pp #I pset descriptor + +pointer sp, lbuf +bool streq() +int getlline() +errchk flush, getlline, clc_scan + +begin + call smark (sp) + call salloc (lbuf, SZ_COMMAND, TY_CHAR) + + # Edit pset and dump edited version back to CLIN. It is not + # necessary to write the pset to the CL before editing as the + # cache is "write-through" and any clputs will already have + # updated the CL version of the pset as well as the cache version. + + call flush (STDOUT) + call fprintf (CLOUT, "eparam %s; dparam %s > %s\n") + call pargstr (PS_PSETNAME(pp)) + call pargstr (PS_PSETNAME(pp)) + call pargstr (IPCOUT) + call flush (CLOUT) + + # Parse the new "param = value" statements returned by dparam and + # update the parameter cache. + + while (getlline (CLIN, Memc[lbuf], SZ_COMMAND) != EOF) + if (streq (Memc[lbuf], IPCDONEMSG)) + break + else + call clc_scan (Memc[lbuf]) + + # Delete the old parameter entries. + call clc_compress() + + call sfree (sp) +end diff --git a/sys/clio/clgcur.x b/sys/clio/clgcur.x new file mode 100644 index 00000000..7ceeb868 --- /dev/null +++ b/sys/clio/clgcur.x @@ -0,0 +1,110 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# CLGCUR -- Return the next cursor value from a list structured cursor type +# parameter. The format of a cursor value is as follows: +# +# X Y WCS KEY [SVAL] +# +# X,Y x and y cursor coordinates +# WCS wcs in which cursor coordinates are given +# KEY key(stroke) value associated with cursor read +# SVAL optional string associated with given key +# +# All fields need not be given, and extra fields may be supplied and will be +# either ignored or returned in SVAL. The X-Y-WCS fields may be omitted +# (in which case the input is KEY-[SVAL]), causing INDEF INDEF 0 KEY SVAL to be +# returned, exactly as if the INDEF INDEF 0 had been typed in. The number of +# fields read is returned as the function value; EOF is returned when the end +# of the cursor list is reached. + +int procedure clgcur (param, wx, wy, wcs, key, strval, maxch) + +char param[ARB] # parameter to be read +real wx, wy # cursor coordinates +int wcs # wcs to which coordinates belong +int key # keystroke value of cursor event +char strval[ARB] # string value, if any +int maxch + +char ch +pointer sp, buf, ip +int nitems, op, delim +int ctor(), ctoi(), cctoc(), clglstr(), stridx() +define quit_ 91 + +begin + call smark (sp) + call salloc (buf, SZ_LINE + maxch, TY_CHAR) + + # Flush any buffered text or graphics output. + call flush (STDERR) + call flush (STDOUT) + call gexfls() + + # Read the cursor. + if (clglstr (param, Memc[buf], SZ_LINE + maxch) == EOF) { + call sfree (sp) + return (EOF) + } + + ip = buf + nitems = 0 + while (IS_WHITE (Memc[ip])) + ip = ip + 1 + + if (IS_PRINT(Memc[ip]) && stridx (Memc[ip], "+-.0123456789") == 0) { + # The X-Y-WCS fields have been omitted; supply default values. + wx = INDEF + wy = INDEF + wcs = 0 + nitems = 3 + + } else { + # Decode the X-Y-WCS fields. + if (ctor (Memc, ip, wx) == 0) + goto quit_ + nitems = nitems + 1 + if (ctor (Memc, ip, wy) == 0) + goto quit_ + nitems = nitems + 1 + if (ctoi (Memc, ip, wcs) == 0) + goto quit_ + nitems = nitems + 1 + } + + # Get the KEY field. + if (cctoc (Memc, ip, ch) == 0) + goto quit_ + key = ch + nitems = nitems + 1 + + # Get the optional SVAL field. + while (IS_WHITE (Memc[ip])) + ip = ip + 1 + + if (Memc[ip] != '\n' && Memc[ip] != EOS) { + # Check for a quoted string. + if (Memc[ip] == '"' || Memc[ip] == '\'') { + delim = Memc[ip] + ip = ip + 1 + } else + delim = 0 + + # Extract the string value. + op = 1 + while (op <= maxch && Memc[ip] != '\n' && Memc[ip] != EOS && + Memc[ip] != delim) { + strval[op] = Memc[ip] + op = op + 1 + ip = ip + 1 + } + strval[op] = EOS + nitems = nitems + 1 + } + +quit_ + call sfree (sp) + return (nitems) +end diff --git a/sys/clio/clgetb.x b/sys/clio/clgetb.x new file mode 100644 index 00000000..4e75ec31 --- /dev/null +++ b/sys/clio/clgetb.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# CLGETB -- Get a boolean parameter from the CL. + +bool procedure clgetb (param) + +char param[ARB] +bool bval +int clscan(), nscan() + +begin + if (clscan (param) == EOF) + call syserrs (SYS_CLEOFNLP, param) + else { + call gargb (bval) + if (nscan() != 1) + call syserrs (SYS_CLNOTBOOL, param) + } + + return (bval) +end diff --git a/sys/clio/clgetc.x b/sys/clio/clgetc.x new file mode 100644 index 00000000..36259ec4 --- /dev/null +++ b/sys/clio/clgetc.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# CLGETC -- Get a character constant from the CL. + +char procedure clgetc (param) + +char param[ARB] +char cval +int clscan(), nscan() + +begin + if (clscan (param) == EOF) + call syserrs (SYS_CLEOFNLP, param) + else { + call gargc (cval) + if (nscan() != 1) + call syserrs (SYS_CLNOTCC, param) + } + + return (cval) +end diff --git a/sys/clio/clgetd.x b/sys/clio/clgetd.x new file mode 100644 index 00000000..12657a74 --- /dev/null +++ b/sys/clio/clgetd.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# CLGETD -- Get a double precision floating parameter from the CL. + +double procedure clgetd (param) + +char param[ARB] +double dval +int clscan(), nscan() + +begin + if (clscan (param) == EOF) + call syserrs (SYS_CLEOFNLP, param) + else { + call gargd (dval) + if (nscan() != 1) + call syserrs (SYS_CLNOTNUM, param) + } + + return (dval) +end diff --git a/sys/clio/clgeti.x b/sys/clio/clgeti.x new file mode 100644 index 00000000..eb3c0019 --- /dev/null +++ b/sys/clio/clgeti.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CLGETI -- Get an integer valued parameter from the CL. + +int procedure clgeti (param) + +char param[ARB] +double dval, clgetd() + +begin + dval = clgetd (param) + if (IS_INDEFD (dval)) + return (INDEFI) + else + return (int(dval)) +end diff --git a/sys/clio/clgetl.x b/sys/clio/clgetl.x new file mode 100644 index 00000000..90a64d40 --- /dev/null +++ b/sys/clio/clgetl.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CLGETL -- Get a long integer parameter from the CL. + +long procedure clgetl (param) + +char param[ARB] +double dval, clgetd() + +begin + dval = clgetd (param) + if (IS_INDEFD (dval)) + return (INDEFL) + else + return (long(dval)) +end diff --git a/sys/clio/clgetr.x b/sys/clio/clgetr.x new file mode 100644 index 00000000..e8fb0a4b --- /dev/null +++ b/sys/clio/clgetr.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CLGETR -- Get a single precision floating parameter from the CL. + +real procedure clgetr (param) + +char param[ARB] +double dval, clgetd() + +begin + dval = clgetd (param) + if (IS_INDEFD (dval)) + return (INDEFR) + else + return (real(dval)) +end diff --git a/sys/clio/clgets.x b/sys/clio/clgets.x new file mode 100644 index 00000000..4cc00ab7 --- /dev/null +++ b/sys/clio/clgets.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CLGETS -- Get a short integer valued parameter from the CL. + +short procedure clgets (param) + +char param[ARB] +double dval, clgetd() + +begin + dval = clgetd (param) + if (IS_INDEFD (dval)) + return (INDEFS) + else + return (short(dval)) +end diff --git a/sys/clio/clgetx.x b/sys/clio/clgetx.x new file mode 100644 index 00000000..68e2b068 --- /dev/null +++ b/sys/clio/clgetx.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# CLGETX -- Get a complex parameter from the CL. + +complex procedure clgetx (param) + +char param[ARB] +complex xval +int clscan(), nscan() + +begin + if (clscan (param) == EOF) + call syserrs (SYS_CLEOFNLP, param) + else { + call gargx (xval) + if (nscan() != 1) + call syserrs (SYS_CLNOTNUM, param) + } + + return (xval) +end diff --git a/sys/clio/clgfil.x b/sys/clio/clgfil.x new file mode 100644 index 00000000..62d40dd1 --- /dev/null +++ b/sys/clio/clgfil.x @@ -0,0 +1,144 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help clpopn[isu], clplen, clgfil, clpcls +.nf ___________________________________________________________________________ +Expand a filename template given as the string value of a CL parameter. + + clpopni - open a sorted input list or open list "STDIN" + clpopns - open a sorted list + clpopnu - open an unsorted list + clpcls - close a list + clplen - get number of filenames in list + clgfil - get next filename from list + clprew - rewind the list + +The CLPOPNI procedure creates a dummy list containing the single filename +"STDIN" if the standard input is redirected. +.endhelp ______________________________________________________________________ + + +# CLPOPNI -- Open an input list (sorted list of input files). If the standard +# input has been redirected, create a dummy list containing the single file +# name "STDIN", and do not try to access the template parameter. + +int procedure clpopni (param) + +char param[ARB] # CL filename template parameter +int sort +pointer sp, template, list +int fntopnb(), fstati() + +begin + call smark (sp) + call salloc (template, SZ_COMMAND, TY_CHAR) + + sort = YES + + if (fstati (STDIN, F_REDIR) == YES) + list = fntopnb ("STDIN", sort) + else { + call clgstr (param, Memc[template], SZ_COMMAND) + list = fntopnb (Memc[template], sort) + } + + call sfree (sp) + return (list) +end + + +# CLPOPNS -- Open a sorted list (sorted list of files, not associated with any +# particular byte stream). + +int procedure clpopns (param) + +char param[ARB] # CL filename template parameter +int sort +pointer sp, template, list +int fntopnb() + +begin + call smark (sp) + call salloc (template, SZ_COMMAND, TY_CHAR) + + sort = YES + + call clgstr (param, Memc[template], SZ_COMMAND) + list = fntopnb (Memc[template], sort) + + call sfree (sp) + return (list) +end + + +# CLPOPNU -- Open an unsorted list (unsorted list of files, not associated +# with any particular stream). + +int procedure clpopnu (param) + +char param[ARB] # CL filename template parameter +int sort +pointer sp, template, list +int fntopnb() + +begin + call smark (sp) + call salloc (template, SZ_COMMAND, TY_CHAR) + + sort = NO + + call clgstr (param, Memc[template], SZ_COMMAND) + list = fntopnb (Memc[template], sort) + + call sfree (sp) + return (list) +end + + +# CLPLEN -- Return the number of file names in the list. + +int procedure clplen (list) + +pointer list +int fntlenb() + +begin + return (fntlenb (list)) +end + + +# CLGFIL -- Return the next filename from the list. + +int procedure clgfil (list, fname, maxch) + +int list # list descriptor +char fname[ARB] # output string +int maxch +int fntgfnb() + +begin + return (fntgfnb (list, fname, maxch)) +end + + +# CLPCLS -- Close a filename list and return all storage. + +procedure clpcls (list) + +int list # list descriptor + +begin + call fntclsb (list) +end + + +# GLPREW -- Rewind the filename list. + +procedure clprew (list) + +int list # list descriptor + +begin + call fntrewb (list) +end diff --git a/sys/clio/clgkey.x b/sys/clio/clgkey.x new file mode 100644 index 00000000..c631076e --- /dev/null +++ b/sys/clio/clgkey.x @@ -0,0 +1,67 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# CLGKEY -- Return the next keystroke value from a list structured `ukey' type +# parameter. + +int procedure clgkey (param, key, strval, maxch) + +char param[ARB] # parameter to be read +int key # keystroke value of cursor event +char strval[ARB] # string value, if any +int maxch + +char ch +int nitems, op +pointer sp, buf, ip +int cctoc(), clglstr() +int clstati(), rdukey() +define quit_ 91 + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + # Flush any buffered text output. + call flush (STDERR) + call flush (STDOUT) + + # Read the keyboard in raw mode. + if (clstati (CL_PRTYPE) == PR_CONNECTED) { + if (clglstr (param, Memc[buf], SZ_LINE) == EOF) { + call sfree (sp) + return (EOF) + } + } else { + if (rdukey (Memc[buf], SZ_LINE) == EOF) { + call sfree (sp) + return (EOF) + } + } + + ip = buf + nitems = 0 + if (cctoc (Memc, ip, ch) == 0) + goto quit_ + key = ch + nitems = nitems + 1 + + while (IS_WHITE (Memc[ip])) + ip = ip + 1 + if (Memc[ip] != '\n' && Memc[ip] != EOS) { + op = 1 + while (op <= maxch && Memc[ip] != '\n' && Memc[ip] != EOS) { + strval[op] = Memc[ip] + op = op + 1 + ip = ip + 1 + } + strval[op] = EOS + nitems = nitems + 1 + } + +quit_ + call sfree (sp) + return (nitems) +end diff --git a/sys/clio/clglpb.x b/sys/clio/clglpb.x new file mode 100644 index 00000000..313e630b --- /dev/null +++ b/sys/clio/clglpb.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# CLGLPB -- Get a list structured boolean parameter from the CL. + +int procedure clglpb (param, bval) + +char param[ARB] +bool bval +int clscan(), nscan() + +begin + if (clscan (param) == EOF) + return (EOF) + else { + call gargb (bval) + if (nscan() != 1) + call syserrs (SYS_CLNOTBOOL, param) + } + + return (1) +end diff --git a/sys/clio/clglpc.x b/sys/clio/clglpc.x new file mode 100644 index 00000000..ad28f906 --- /dev/null +++ b/sys/clio/clglpc.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# CLGLPC -- Get a list structured character constant parameter from the CL. + +int procedure clglpc (param, cval) + +char param[ARB] +char cval +int clscan(), nscan() + +begin + if (clscan (param) == EOF) + return (EOF) + else { + call gargc (cval) + if (nscan() != 1) + call syserrs (SYS_CLNOTCC, param) + } + + return (1) +end diff --git a/sys/clio/clglpd.x b/sys/clio/clglpd.x new file mode 100644 index 00000000..e9064790 --- /dev/null +++ b/sys/clio/clglpd.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# CLGLPD -- Get a list structured double precision floating parameter from +# the CL. + +int procedure clglpd (param, dval) + +char param[ARB] +double dval +int clscan(), nscan() + +begin + if (clscan (param) == EOF) + return (EOF) + else { + call gargd (dval) + if (nscan() != 1) + call syserrs (SYS_CLNOTNUM, param) + } + + return (1) +end diff --git a/sys/clio/clglpi.x b/sys/clio/clglpi.x new file mode 100644 index 00000000..3b3d6800 --- /dev/null +++ b/sys/clio/clglpi.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CLGLPI -- Get a list structured integer valued parameter from the CL. + +int procedure clglpi (param, ival) + +char param[ARB] +int ival, stat, clglpd() +double dval + +begin + stat = clglpd (param, dval) + if (IS_INDEFD (dval)) + ival = INDEFI + else + ival = int (dval) + return (stat) +end diff --git a/sys/clio/clglpl.x b/sys/clio/clglpl.x new file mode 100644 index 00000000..f486092b --- /dev/null +++ b/sys/clio/clglpl.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CLGLPL -- Get a list structured long integer valued parameter from the CL. + +int procedure clglpl (param, lval) + +char param[ARB] +long lval +int stat, clglpd() +double dval + +begin + stat = clglpd (param, dval) + if (IS_INDEFD (dval)) + lval = INDEFL + else + lval = long (dval) + return (stat) +end diff --git a/sys/clio/clglpr.x b/sys/clio/clglpr.x new file mode 100644 index 00000000..2572041c --- /dev/null +++ b/sys/clio/clglpr.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CLGLPR -- Get a list structured single precision floating valued parameter +# from the CL. + +int procedure clglpr (param, rval) + +char param[ARB] +real rval +int stat, clglpd() +double dval + +begin + stat = clglpd (param, dval) + if (IS_INDEFD (dval)) + rval = INDEFR + else + rval = real (dval) + return (stat) +end diff --git a/sys/clio/clglps.x b/sys/clio/clglps.x new file mode 100644 index 00000000..d7179eb3 --- /dev/null +++ b/sys/clio/clglps.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CLGLPS -- Get a list structured short integer valued parameter from the CL. + +int procedure clglps (param, sval) + +char param[ARB] +short sval +int stat, clglpd() +double dval + +begin + stat = clglpd (param, dval) + if (IS_INDEFD (dval)) + sval = INDEFS + else + sval = short (dval) + return (stat) +end diff --git a/sys/clio/clglpx.x b/sys/clio/clglpx.x new file mode 100644 index 00000000..04e597d1 --- /dev/null +++ b/sys/clio/clglpx.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# CLGLPX -- Get a list structured complex parameter from the CL. + +int procedure clglpx (param, xval) + +char param[ARB] +complex xval +int clscan(), nscan() + +begin + if (clscan (param) == EOF) + return (EOF) + else { + call gargx (xval) + if (nscan() != 1) + call syserrs (SYS_CLNOTNUM, param) + } + + return (1) +end diff --git a/sys/clio/clglstr.x b/sys/clio/clglstr.x new file mode 100644 index 00000000..f60b58c9 --- /dev/null +++ b/sys/clio/clglstr.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CLGLSTR -- Get a list structured string parameter from the CL. + +int procedure clglstr (param, outstr, maxch) + +char param[ARB], outstr[maxch] +int maxch +int clscan(), nscan(), strlen() + +begin + if (clscan (param) == EOF) + return (EOF) + else { + call gargstr (outstr, maxch) + if (nscan() != 1) + outstr[1] = EOS + } + + return (strlen (outstr)) +end diff --git a/sys/clio/clgpset.x b/sys/clio/clgpset.x new file mode 100644 index 00000000..a8dd1d85 --- /dev/null +++ b/sys/clio/clgpset.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "clpset.h" + +# CLGPSET -- Get the string value of the named pset parameter. +# [OBSOLETE ROUTINE - see clgpseta.x] + +procedure clgpset (pp, pname, outstr, maxch) + +pointer pp # pset descriptor +char pname[ARB] # parameter name +char outstr[maxch] # output string +int maxch # max chars out + +pointer clpset_parname() + +begin + call clgstr (PARNAME(pp,pname), outstr, maxch) +end diff --git a/sys/clio/clgpseta.x b/sys/clio/clgpseta.x new file mode 100644 index 00000000..277165d1 --- /dev/null +++ b/sys/clio/clgpseta.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "clpset.h" + +# CLGPSETA -- Get the string value of the named pset parameter. + +procedure clgpseta (pp, pname, outstr, maxch) + +pointer pp # pset descriptor +char pname[ARB] # parameter name +char outstr[maxch] # output string +int maxch # max chars out + +pointer clpset_parname() + +begin + call clgstr (PARNAME(pp,pname), outstr, maxch) +end diff --git a/sys/clio/clgpsetb.x b/sys/clio/clgpsetb.x new file mode 100644 index 00000000..651f5306 --- /dev/null +++ b/sys/clio/clgpsetb.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "clpset.h" + +# CLGPSETB -- Get the boolean value of a pset parameter. + +bool procedure clgpsetb (pp, parname) + +pointer pp # pset descriptor +char parname[ARB] # parameter name + +pointer clpset_parname() +bool clgetb() + +begin + return (clgetb (PARNAME(pp,parname))) +end diff --git a/sys/clio/clgpsetc.x b/sys/clio/clgpsetc.x new file mode 100644 index 00000000..fe54715e --- /dev/null +++ b/sys/clio/clgpsetc.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "clpset.h" + +# CLGPSETC -- Get the char value of a pset parameter. + +char procedure clgpsetc (pp, parname) + +pointer pp # pset descriptor +char parname[ARB] # parameter name + +pointer clpset_parname() +char clgetc() + +begin + return (clgetc (PARNAME(pp,parname))) +end diff --git a/sys/clio/clgpsetd.x b/sys/clio/clgpsetd.x new file mode 100644 index 00000000..dfd39372 --- /dev/null +++ b/sys/clio/clgpsetd.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "clpset.h" + +# CLGPSETD -- Get the double value of a pset parameter. + +double procedure clgpsetd (pp, parname) + +pointer pp # pset descriptor +char parname[ARB] # parameter name + +pointer clpset_parname() +double clgetd() + +begin + return (clgetd (PARNAME(pp,parname))) +end diff --git a/sys/clio/clgpseti.x b/sys/clio/clgpseti.x new file mode 100644 index 00000000..c39d102b --- /dev/null +++ b/sys/clio/clgpseti.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "clpset.h" + +# CLGPSETI -- Get the int value of a pset parameter. + +int procedure clgpseti (pp, parname) + +pointer pp # pset descriptor +char parname[ARB] # parameter name + +pointer clpset_parname() +int clgeti() + +begin + return (clgeti (PARNAME(pp,parname))) +end diff --git a/sys/clio/clgpsetl.x b/sys/clio/clgpsetl.x new file mode 100644 index 00000000..374f0851 --- /dev/null +++ b/sys/clio/clgpsetl.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "clpset.h" + +# CLGPSETL -- Get the long integer value of a pset parameter. + +long procedure clgpsetl (pp, parname) + +pointer pp # pset descriptor +char parname[ARB] # parameter name + +pointer clpset_parname() +long clgetl() + +begin + return (clgetl (PARNAME(pp,parname))) +end diff --git a/sys/clio/clgpsetr.x b/sys/clio/clgpsetr.x new file mode 100644 index 00000000..598a2c42 --- /dev/null +++ b/sys/clio/clgpsetr.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "clpset.h" + +# CLGPSETR -- Get the real value of a pset parameter. + +real procedure clgpsetr (pp, parname) + +pointer pp # pset descriptor +char parname[ARB] # parameter name + +pointer clpset_parname() +real clgetr() + +begin + return (clgetr (PARNAME(pp,parname))) +end diff --git a/sys/clio/clgpsets.x b/sys/clio/clgpsets.x new file mode 100644 index 00000000..9210a8b2 --- /dev/null +++ b/sys/clio/clgpsets.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "clpset.h" + +# CLGPSETS -- Get the short integer value of a pset parameter. + +short procedure clgpsets (pp, parname) + +pointer pp # pset descriptor +char parname[ARB] # parameter name + +pointer clpset_parname() +short clgets() + +begin + return (clgets (PARNAME(pp,parname))) +end diff --git a/sys/clio/clgpsetx.x b/sys/clio/clgpsetx.x new file mode 100644 index 00000000..b20fda29 --- /dev/null +++ b/sys/clio/clgpsetx.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "clpset.h" + +# CLGPSETX -- Get the complex value of a pset parameter. + +complex procedure clgpsetx (pp, parname) + +pointer pp # pset descriptor +char parname[ARB] # parameter name + +pointer clpset_parname() +complex clgetx() + +begin + return (clgetx (PARNAME(pp,parname))) +end diff --git a/sys/clio/clgstr.x b/sys/clio/clgstr.x new file mode 100644 index 00000000..c8ec9ebd --- /dev/null +++ b/sys/clio/clgstr.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# CLGSTR -- Get a string parameter from the CL. + +procedure clgstr (param, outstr, maxch) + +char param[ARB], outstr[maxch] +int maxch +int clscan(), nscan() + +begin + if (clscan (param) == EOF) + call syserr (SYS_CLEOFNLP) + else { + call gargstr (outstr, maxch) + if (nscan() != 1) + outstr[1] = EOS + } +end diff --git a/sys/clio/clgwrd.x b/sys/clio/clgwrd.x new file mode 100644 index 00000000..0dd6ee49 --- /dev/null +++ b/sys/clio/clgwrd.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# CLGWRD -- Get a keyword parameter from the CL, and match it against +# a dictionary of legal keywords. Any unambiguous abbreviation is +# accepted. The full keyword string is returned in keyword, and the +# word index of the keyword in the dictionary is returned as the function +# value. + +int procedure clgwrd (param, keyword, maxchar, dictionary) + +char param[ARB] # CL parameter string +char keyword[ARB] # String matched in dictionary +int maxchar # Maximum size of str +char dictionary[ARB] # Dictionary string + +pointer sp, abbrev +int kwindex, strdic() + +begin + call smark (sp) + call salloc (abbrev, SZ_FNAME, TY_CHAR) + + call clgstr (param, Memc[abbrev], maxchar) + kwindex = strdic (Memc[abbrev], keyword, maxchar, dictionary) + + if (kwindex <= 0) + call syserrs (SYS_CLGWRD, Memc[abbrev]) + + call sfree (sp) + return (kwindex) +end diff --git a/sys/clio/clio.com b/sys/clio/clio.com new file mode 100644 index 00000000..78567dd0 --- /dev/null +++ b/sys/clio/clio.com @@ -0,0 +1,18 @@ +# CLIO parameters. + +int cl_prtype # parent process type +pointer cl_stp # clcache symbol table pointer +int cl_stmark # stmark value for initial table +int cl_nposargs # number of $1, $2 type task parameters +int cl_nextarg # index into posarg list +pointer cl_posarg[MAX_POSARGS] # symtab offsets of positional args +int ps_status[MAX_PSEUDOFILES] # for pseudofile drivers +int cl_npsets # number of psets for task (>= 1) +int cl_psetop # next char in pset name buffer +int cl_psetindex[MAX_PSETS] # index of pset names (1 = taskname) +char cl_psetname[SZ_PSETNAMEBUF] # char storage for pset names +char cl_pname[SZ_PNAME] # handy buffer for param names + +common /clio_com/ cl_prtype, cl_stp, cl_stmark, cl_nposargs, cl_nextarg, + cl_posarg, ps_status, cl_npsets, cl_psetop, cl_psetindex, cl_psetname, + cl_pname diff --git a/sys/clio/cllpset.x b/sys/clio/cllpset.x new file mode 100644 index 00000000..aa06a57a --- /dev/null +++ b/sys/clio/cllpset.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "clpset.h" + +# CLLPSET -- List a pset. Each param,value pair is written to the output +# file using the caller supplied format, e.g., "set %s = \"%s\"\n". + +procedure cllpset (pp, fd, format) + +pointer pp #I pset descriptor +int fd #I output file +char format[ARB] #I format, one %s each for param, value + +begin + call clc_compress() + call clc_list (fd, PS_PSETNAME(pp), format) +end diff --git a/sys/clio/clopen.x b/sys/clio/clopen.x new file mode 100644 index 00000000..a83bb753 --- /dev/null +++ b/sys/clio/clopen.x @@ -0,0 +1,124 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# CLOPEN -- "Open" the CL files (initialize CLIO). Called by the IRAF Main +# upon process startup. The CL device may be either the CL process, +# communicating with the current process via intertask communications +# (via ZARDCL, ZAWRCL), or a text file or terminal. "Open" the files CLIN +# and CLOUT, and the standard pseudofiles STDIN, STDOUT, STDERR, STDGRAPH, +# STDIMAGE, STDPLOT, and PSIOCTRL. + +procedure clopen (stdin_chan, stdout_chan, stderr_chan, device, devtype) + +int stdin_chan # OS channel for the process standard input +int stdout_chan # OS channel for the process standard output +int stderr_chan # OS channel for the standard error output +int device # zlocpr EPA of the driver read routine +int devtype # device type (text or binary) + +int fd, psmode, chan, devepa +int fsetfd(), locpr() +extern zardps(), zardnu(), zgetty(), zgettt() + +begin + if (devtype == BINARY_FILE) + psmode = WRITE_ONLY + else + psmode = APPEND + + # Allocate and initialize the standard (predefined) file descriptors. + # FSETFD performs only the standard initialization. The remainder + # of the code initializes the device dependent parameters. + + fd = fsetfd (CLIN, "CLIN", READ_ONLY, devtype) + fd = fsetfd (CLOUT, "CLOUT", psmode, devtype) + fd = fsetfd (STDIN, "STDIN", READ_ONLY, devtype) + fd = fsetfd (STDOUT, "STDOUT", psmode, devtype) + fd = fsetfd (STDERR, "STDERR", psmode, devtype) + fd = fsetfd (STDGRAPH, "STDGRAPH", READ_WRITE, BINARY_FILE) + fd = fsetfd (STDIMAGE, "STDIMAGE", READ_WRITE, BINARY_FILE) + fd = fsetfd (STDPLOT, "STDPLOT", READ_WRITE, BINARY_FILE) + fd = fsetfd (PSIOCTRL, "PSIOCTRL", READ_WRITE, BINARY_FILE) + + # Set the entry point addresses of the device Z-routines for each + # of the special files. If the process channels are text files + # (character files or a terminal) the pseudofiles are connected to + # real files (no multiplexing). Graphics i/o is connected to the + # null file if the process channels are textual, hence graphics + # output is discarded (unless redirected) when a task is run stand + # alone. If the device we are passed is the kernel terminal driver + # TY, connect the VOS logical terminal driver TT instead. + + if (device == locpr (zgetty)) { + devepa = locpr (zgettt) + call zsettt (stdin_chan, TT_KINCHAN, stdin_chan) + call zsettt (stdout_chan, TT_KOUTCHAN, stdout_chan) + } else + devepa = device + + call fseti (CLIN, F_DEVICE, devepa) + call fseti (CLOUT, F_DEVICE, devepa) + + if (devtype == TEXT_FILE) { + # Set device drivers for the textual pseudofiles. + do fd = STDIN, STDERR + call fseti (fd, F_DEVICE, devepa) + + # Connect the graphics streams to the null file. + do fd = STDGRAPH, PSIOCTRL + call fseti (fd, F_DEVICE, locpr(zardnu)) + + } else { + # Connect the pseudofiles to the pseudofile driver. + do fd = STDIN, PSIOCTRL + call fseti (fd, F_DEVICE, locpr(zardps)) + } + + # Associate a device channel with the two IPC streams and with each + # pseudofile. + + call fseti (CLIN, F_CHANNEL, stdin_chan) + call fseti (CLOUT, F_CHANNEL, stdout_chan) + + if (devtype == TEXT_FILE) { + call fseti (STDIN, F_CHANNEL, stdin_chan) + call fseti (STDOUT, F_CHANNEL, stdout_chan) + call fseti (STDERR, F_CHANNEL, stdout_chan) + + # Open a null file on each graphics stream. + do fd = STDGRAPH, PSIOCTRL { + call zopnnu ("", READ_WRITE, chan) + call fseti (fd, F_CHANNEL, chan) + } + + } else { + # The channel code for a pseudofile is used for the pseudofile code, + # since the actual i/o is always on channels CLIN and CLOUT. + + do fd = STDIN, PSIOCTRL + call fseti (fd, F_CHANNEL, fd) + } + + call fseti (STDERR, F_FLUSHNL, YES) # flush error messages + # call fseti (CLOUT, F_FLUSHNL, YES) # flush CL commands + + # Get device block size, and the minimum optimal buffer size for + # efficient sequential i/o. + + do fd = CLIN, PSIOCTRL # device parameters + call fgdev_param (fd) + + # Seek is needed to set the proper logical offset for each file, + # as well as to seek to the end of a text file if no CL. + + call seek (CLIN, BOFL) + call seek (CLOUT, EOFL) + call seek (STDIN, BOFL) + + do fd = STDOUT, PSIOCTRL + call seek (fd, EOFL) +end diff --git a/sys/clio/clopset.x b/sys/clio/clopset.x new file mode 100644 index 00000000..f06ae0b9 --- /dev/null +++ b/sys/clio/clopset.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "clpset.h" + +# CLOPSET -- Open a named pset. + +pointer procedure clopset (pset) + +char pset[ARB] # pset name (name of CL pset parameter) +pointer pp +errchk malloc + +begin + call malloc (pp, LEN_PSETDES, TY_STRUCT) + call strcpy (pset, PS_PSETNAME(pp), SZ_PSPSETNAME) + + return (pp) +end diff --git a/sys/clio/clppset.x b/sys/clio/clppset.x new file mode 100644 index 00000000..b5d2691f --- /dev/null +++ b/sys/clio/clppset.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "clpset.h" + +# CLPPSET -- Set the string value of the named pset parameter. +# [OBSOLETE ROUTINE - see clppseta.x] + +procedure clppset (pp, pname, sval) + +pointer pp # pset descriptor +char pname[ARB] # parameter name +char sval[ARB] # string value of parameter + +pointer clpset_parname() + +begin + call clpstr (PARNAME(pp,pname), sval) +end diff --git a/sys/clio/clppseta.x b/sys/clio/clppseta.x new file mode 100644 index 00000000..4fad477c --- /dev/null +++ b/sys/clio/clppseta.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "clpset.h" + +# CLPPSETA -- Set the string value of the named pset parameter. + +procedure clppseta (pp, pname, sval) + +pointer pp # pset descriptor +char pname[ARB] # parameter name +char sval[ARB] # string value of parameter + +pointer clpset_parname() + +begin + call clpstr (PARNAME(pp,pname), sval) +end diff --git a/sys/clio/clppsetb.x b/sys/clio/clppsetb.x new file mode 100644 index 00000000..5ada363f --- /dev/null +++ b/sys/clio/clppsetb.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "clpset.h" + +# CLPPSETB -- Set the boolean value of a pset parameter. + +procedure clppsetb (pp, parname, bval) + +pointer pp # pset descriptor +char parname[ARB] # parameter name +bool bval # new value of parameter + +pointer clpset_parname() + +begin + call clputb (PARNAME(pp,parname), bval) +end diff --git a/sys/clio/clppsetc.x b/sys/clio/clppsetc.x new file mode 100644 index 00000000..46ebcf22 --- /dev/null +++ b/sys/clio/clppsetc.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "clpset.h" + +# CLPPSETC -- Set the char value of a pset parameter. + +procedure clppsetc (pp, parname, cval) + +pointer pp # pset descriptor +char parname[ARB] # parameter name +char cval # new value of parameter + +pointer clpset_parname() + +begin + call clputc (PARNAME(pp,parname), cval) +end diff --git a/sys/clio/clppsetd.x b/sys/clio/clppsetd.x new file mode 100644 index 00000000..b7fd3376 --- /dev/null +++ b/sys/clio/clppsetd.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "clpset.h" + +# CLPPSETD -- Set the double value of a pset parameter. + +procedure clppsetd (pp, parname, dval) + +pointer pp # pset descriptor +char parname[ARB] # parameter name +double dval # new value of parameter + +pointer clpset_parname() + +begin + call clputd (PARNAME(pp,parname), dval) +end diff --git a/sys/clio/clppseti.x b/sys/clio/clppseti.x new file mode 100644 index 00000000..6cb06daf --- /dev/null +++ b/sys/clio/clppseti.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "clpset.h" + +# CLPPSETI -- Set the integer value of a pset parameter. + +procedure clppseti (pp, parname, ival) + +pointer pp # pset descriptor +char parname[ARB] # parameter name +int ival # new value of parameter + +pointer clpset_parname() + +begin + call clputi (PARNAME(pp,parname), ival) +end diff --git a/sys/clio/clppsetl.x b/sys/clio/clppsetl.x new file mode 100644 index 00000000..23ebae92 --- /dev/null +++ b/sys/clio/clppsetl.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "clpset.h" + +# CLPPSETL -- Set the long integer value of a pset parameter. + +procedure clppsetl (pp, parname, lval) + +pointer pp # pset descriptor +char parname[ARB] # parameter name +long lval # new value of parameter + +pointer clpset_parname() + +begin + call clputl (PARNAME(pp,parname), lval) +end diff --git a/sys/clio/clppsetr.x b/sys/clio/clppsetr.x new file mode 100644 index 00000000..b917549d --- /dev/null +++ b/sys/clio/clppsetr.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "clpset.h" + +# CLPPSETR -- Set the real value of a pset parameter. + +procedure clppsetr (pp, parname, rval) + +pointer pp # pset descriptor +char parname[ARB] # parameter name +real rval # new value of parameter + +pointer clpset_parname() + +begin + call clputr (PARNAME(pp,parname), rval) +end diff --git a/sys/clio/clppsets.x b/sys/clio/clppsets.x new file mode 100644 index 00000000..ef48bfb3 --- /dev/null +++ b/sys/clio/clppsets.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "clpset.h" + +# CLPPSETS -- Set the short integer value of a pset parameter. + +procedure clppsets (pp, parname, sval) + +pointer pp # pset descriptor +char parname[ARB] # parameter name +short sval # new value of parameter + +pointer clpset_parname() + +begin + call clputs (PARNAME(pp,parname), sval) +end diff --git a/sys/clio/clppsetx.x b/sys/clio/clppsetx.x new file mode 100644 index 00000000..64815812 --- /dev/null +++ b/sys/clio/clppsetx.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "clpset.h" + +# CLPPSETX -- Set the complex value of a pset parameter. + +procedure clppsetx (pp, parname, xval) + +pointer pp # pset descriptor +char parname[ARB] # parameter name +complex xval # new value of parameter + +pointer clpset_parname() + +begin + call clputx (PARNAME(pp,parname), xval) +end diff --git a/sys/clio/clpset.h b/sys/clio/clpset.h new file mode 100644 index 00000000..df52e366 --- /dev/null +++ b/sys/clio/clpset.h @@ -0,0 +1,12 @@ +# CLPSET.H -- CL pset access package header file. + +define SZ_PSPSETNAME 31 +define SZ_PSPARNAME 63 + +define LEN_PSETDES 96 +define PS_PSETNAMEP P2C($1) # pset name pointer +define PS_PSETNAME Memc[P2C($1)] # pset name +define PS_PARNAMEP (P2C($1)+SZ_PSPSETNAME+1) # pointer to tempbuf +define PS_PARNAME Memc[P2C($1)+SZ_PSPSETNAME+1] # temp buffer + +define PARNAME Memc[clpset_parname($1,$2)] diff --git a/sys/clio/clpsetnm.x b/sys/clio/clpsetnm.x new file mode 100644 index 00000000..6854d94b --- /dev/null +++ b/sys/clio/clpsetnm.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "clpset.h" + +# CLPSET_PARNAME -- Return a pointer to the full name (pset.parname) of a +# parameter in the referenced pset. + +pointer procedure clpset_parname (pp, parname) + +pointer pp # pset descriptor +char parname[ARB] # name of parameter in pset + +pointer op +int gstrcpy() + +begin + op = PS_PARNAMEP(pp) + if (Memc[PS_PSETNAMEP(pp)] != EOS) { + op = op + gstrcpy (PS_PSETNAME(pp), Memc[op], SZ_PSPARNAME) + Memc[op] = '.'; op = op + 1 + } + call strcpy (parname, Memc[op], SZ_PSPARNAME-(op-PS_PARNAMEP(pp))) + + return (PS_PARNAMEP(pp)) +end diff --git a/sys/clio/clpstr.x b/sys/clio/clpstr.x new file mode 100644 index 00000000..d040fe5d --- /dev/null +++ b/sys/clio/clpstr.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CLPSTR -- Put a string type parameter to the CL. + +procedure clpstr (param, value) + +char param[ARB] # param name +char value[ARB] # new value + +pointer sp, pname +pointer clc_find() + +begin + call smark (sp) + call salloc (pname, SZ_FNAME, TY_CHAR) + + call fprintf (CLOUT, "%s=\"%s\"\n") + call pargstr (param) + call pargstr (value) + + # If the parameter is in the cache, update the cached value as well. + if (clc_find (param, Memc[pname], SZ_FNAME) != NULL) + call clc_enter (Memc[pname], value) + + call sfree (sp) +end diff --git a/sys/clio/clputb.x b/sys/clio/clputb.x new file mode 100644 index 00000000..dcc99ad8 --- /dev/null +++ b/sys/clio/clputb.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CLPUTB -- Put a boolean valued parameter to the CL. + +procedure clputb (param, bval) + +char param[ARB] +bool bval + +pointer sp, value, pname +pointer clc_find() + +begin + call smark (sp) + call salloc (value, SZ_FNAME, TY_CHAR) + call salloc (pname, SZ_FNAME, TY_CHAR) + + # Update the parameter in the CL. + call sprintf (Memc[value], SZ_FNAME, "%b") + call pargb (bval) + call fprintf (CLOUT, "%s = %s\n") + call pargstr (param) + call pargstr (Memc[value]) + + # If the parameter is in the cache, update the cached value as well. + if (clc_find (param, Memc[pname], SZ_FNAME) != NULL) + call clc_enter (Memc[pname], Memc[value]) + + call sfree (sp) +end diff --git a/sys/clio/clputc.x b/sys/clio/clputc.x new file mode 100644 index 00000000..333160fe --- /dev/null +++ b/sys/clio/clputc.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# CLPUTC -- Put a character constant type parameter to the CL. + +procedure clputc (param, cval) + +char param[ARB] +char cval + +pointer sp, value, pname +pointer clc_find() + +begin + call smark (sp) + call salloc (value, SZ_FNAME, TY_CHAR) + call salloc (pname, SZ_FNAME, TY_CHAR) + + # Character constants are stored as strings in the CL. Add single + # quotes about the character value to deimit the string. The + # character may be represented as a single character or as an escape + # sequence. + + call sprintf (Memc[value], SZ_FNAME, "'%c'") + call pargc (cval) + call fprintf (CLOUT, "%s = %s\n") + call pargstr (param) + call pargstr (Memc[value]) + + # If the parameter is in the cache, update the cached value as well. + if (clc_find (param, Memc[pname], SZ_FNAME) != NULL) + call clc_enter (Memc[pname], Memc[value]) + + call sfree (sp) +end diff --git a/sys/clio/clputd.x b/sys/clio/clputd.x new file mode 100644 index 00000000..71403bd9 --- /dev/null +++ b/sys/clio/clputd.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CLPUTD -- Put a double precision parameter to the CL. + +procedure clputd (param, dval) + +char param[ARB] +double dval + +pointer sp, value, pname +pointer clc_find() + +begin + call smark (sp) + call salloc (value, SZ_FNAME, TY_CHAR) + call salloc (pname, SZ_FNAME, TY_CHAR) + + # Update the parameter in the CL. + call sprintf (Memc[value], SZ_FNAME, "%g") + call pargd (dval) + call fprintf (CLOUT, "%s = %s\n") + call pargstr (param) + call pargstr (Memc[value]) + + # If the parameter is in the cache, update the cached value as well. + if (clc_find (param, Memc[pname], SZ_FNAME) != NULL) + call clc_enter (Memc[pname], Memc[value]) + + call sfree (sp) +end diff --git a/sys/clio/clputi.x b/sys/clio/clputi.x new file mode 100644 index 00000000..d7c9fc29 --- /dev/null +++ b/sys/clio/clputi.x @@ -0,0 +1,64 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CLPUTI -- Set a CL parameter of type integer. + +procedure clputi (param, value) + +char param[ARB] # parameter to be set +int value # new value +long lval + +begin + lval = value + if (IS_INDEFI (value)) + lval = INDEFL + + call clputl (param, lval) +end + + +# CLPUTS -- Set a CL parameter of type short. + +procedure clputs (param, value) + +char param[ARB] # parameter to be set +short value # new value +long lval + +begin + lval = value + if (IS_INDEFS (value)) + lval = INDEFL + + call clputl (param, lval) +end + + +# CLPUTL -- Put a long integer parameter to the CL. + +procedure clputl (param, lval) + +char param[ARB] +long lval + +pointer sp, value, pname +pointer clc_find() + +begin + call smark (sp) + call salloc (value, SZ_FNAME, TY_CHAR) + call salloc (pname, SZ_FNAME, TY_CHAR) + + # Update the parameter in the CL. + call sprintf (Memc[value], SZ_FNAME, "%d") + call pargl (lval) + call fprintf (CLOUT, "%s = %s\n") + call pargstr (param) + call pargstr (Memc[value]) + + # If the parameter is in the cache, update the cached value as well. + if (clc_find (param, Memc[pname], SZ_FNAME) != NULL) + call clc_enter (Memc[pname], Memc[value]) + + call sfree (sp) +end diff --git a/sys/clio/clputr.x b/sys/clio/clputr.x new file mode 100644 index 00000000..4ee37caf --- /dev/null +++ b/sys/clio/clputr.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CLPUTR -- Put a real valued parameter to the CL. + +procedure clputr (param, rval) + +char param[ARB] +real rval +double dval + +begin + if (IS_INDEFR(rval)) + dval = INDEFD + else + dval = rval + + call clputd (param, dval) +end diff --git a/sys/clio/clputx.x b/sys/clio/clputx.x new file mode 100644 index 00000000..7bbe66e7 --- /dev/null +++ b/sys/clio/clputx.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CLPUTX -- Put a complex type parameter to the CL. + +procedure clputx (param, xval) + +char param[ARB] +complex xval + +pointer sp, value, pname +pointer clc_find() + +begin + call smark (sp) + call salloc (value, SZ_FNAME, TY_CHAR) + call salloc (pname, SZ_FNAME, TY_CHAR) + + # Update the parameter in the CL. + call sprintf (Memc[value], SZ_FNAME, "%z") + call pargx (xval) + call fprintf (CLOUT, "%s = %s\n") + call pargstr (param) + call pargstr (Memc[value]) + + # If the parameter is in the cache, update the cached value as well. + if (clc_find (param, Memc[pname], SZ_FNAME) != NULL) + call clc_enter (Memc[pname], Memc[value]) + + call sfree (sp) +end diff --git a/sys/clio/clreqpar.x b/sys/clio/clreqpar.x new file mode 100644 index 00000000..9817c0bf --- /dev/null +++ b/sys/clio/clreqpar.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# CLREQPAR -- Request a parameter from the CL. + +procedure clreqpar (param) + +char param[ARB] +int clstati() + +begin + call flush (STDOUT) + + if (clstati (CL_PRTYPE) == PR_CONNECTED) { + call putline (CLOUT, "=") + call putline (CLOUT, param) + call putline (CLOUT, "\n") + } else { + call putline (CLOUT, param) + call putline (CLOUT, ": ") + } + + call flush (CLOUT) +end diff --git a/sys/clio/clseti.x b/sys/clio/clseti.x new file mode 100644 index 00000000..c676fb19 --- /dev/null +++ b/sys/clio/clseti.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# CLSETI -- Set a CLIO option of type integer. Called by the IRAF Main +# upon process startup to set the CL_PRTYPE flag. + +procedure clseti (parameter, value) + +int parameter # CLIO parameter being queried +int value # value of parameter (output) +include "clio.com" + +begin + switch (parameter) { + case CL_PRTYPE: + cl_prtype = value + default: + call syserrs (SYS_CLSETUKNPAR, "clseti") + } +end diff --git a/sys/clio/clstati.x b/sys/clio/clstati.x new file mode 100644 index 00000000..05ea76bb --- /dev/null +++ b/sys/clio/clstati.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# CLSTATI -- Get the value of an integer CLIO parameter. Currently there is +# only one CLIO parameter, the process type of the parent (connected, detached, +# or host). + +int procedure clstati (parameter) + +int parameter +include "clio.com" + +begin + switch (parameter) { + case CL_PRTYPE: + return (cl_prtype) + case CL_PCACHE: + return (cl_stp) + default: + call syserrs (SYS_CLSTATUS, "clstati") + } +end diff --git a/sys/clio/doc/clio.hd b/sys/clio/doc/clio.hd new file mode 100644 index 00000000..4b5b00f2 --- /dev/null +++ b/sys/clio/doc/clio.hd @@ -0,0 +1,40 @@ +# Help directory for the CLIO (command language i/o) system package. + +$clio = "sys$clio/" + +clcmd hlp = clcmd.hlp, src = clio$clcmd.x +clgetb hlp = clget.hlp, src = clio$clgetb.x +clgetc hlp = clget.hlp, src = clio$clgetc.x +clgetd hlp = clget.hlp, src = clio$clgetd.x +clgeti hlp = clget.hlp, src = clio$clgeti.x +clgetl hlp = clget.hlp, src = clio$clgetl.x +clgetr hlp = clget.hlp, src = clio$clgetr.x +clgets hlp = clget.hlp, src = clio$clgets.x +clgetx hlp = clget.hlp, src = clio$clgetx.x +clgfil hlp = clgfil.hlp, src = clio$clgfil.x +clglpb hlp = clglp.hlp, src = clio$clglpb.x +clglpc hlp = clglp.hlp, src = clio$clglpc.x +clglpd hlp = clglp.hlp, src = clio$clglpd.x +clglpi hlp = clglp.hlp, src = clio$clglpi.x +clglpl hlp = clglp.hlp, src = clio$clglpl.x +clglpr hlp = clglp.hlp, src = clio$clglpr.x +clglps hlp = clglp.hlp, src = clio$clglps.x +clglpx hlp = clglp.hlp, src = clio$clglpx.x +clglstr hlp = clglp.hlp, src = clio$clglstr.x +clgstr hlp = clget.hlp, src = clio$clgstr.x +clgwrd hlp = clget.hlp, src = clio$clgwrd.x +clpcls hlp = clgfil.hlp, src = clio$clgfil.x +clplen hlp = clgfil.hlp, src = clio$clgfil.x +clpopni hlp = clgfil.hlp, src = clio$clgfil.x +clpopns hlp = clgfil.hlp, src = clio$clgfil.x +clpopnu hlp = clgfil.hlp, src = clio$clgfil.x +clprew hlp = clgfil.hlp, src = clio$clgfil.x +clpstr hlp = clput.hlp, src = clio$clpstr.x +clputb hlp = clput.hlp, src = clio$clputb.x +clputc hlp = clput.hlp, src = clio$clputc.x +clputd hlp = clput.hlp, src = clio$clputd.x +clputi hlp = clput.hlp, src = clio$clputi.x +clputr hlp = clput.hlp, src = clio$clputr.x +clputx hlp = clput.hlp, src = clio$clputx.x +clseti hlp = clseti.hlp, src = clio$clseti.x +clstati hlp = clstati.hlp, src = clio$clstati.x diff --git a/sys/clio/doc/clio.men b/sys/clio/doc/clio.men new file mode 100644 index 00000000..f7f24059 --- /dev/null +++ b/sys/clio/doc/clio.men @@ -0,0 +1,16 @@ + clcmd - Send a command to the CL (restricted) +clget[bcsilrdx] - Get the value of a CL parameter + clpopni - Open a sorted input filename template + clpopns - Open a sorted filename template or namelist + clpopnu - Open an unsorted filename template or namelist + clplen - Number of elements in a list opened with clpopn[isu] + clgfil - Get a file from a list opened with clpopn[isu] + clpcls - Close a list opened with clpopn[isu] +clglp[bcsilrdx] - Get the next value from a list-structured CL parameter + clglstr - Get the next value from a string list-structured CL parameter + clgstr - Get the value of a CL string type parameter + clgwrd - Get the first word from a string valued CL parameter + clpstr - Set the value of a string valued CL parameter +clput[bcsilrdx] - Set the value of a CL parameter + clseti - Set the value of a CLIO parameter + clstati - Get the value of a CLIO parameter diff --git a/sys/clio/gexfls.x b/sys/clio/gexfls.x new file mode 100644 index 00000000..5eadf759 --- /dev/null +++ b/sys/clio/gexfls.x @@ -0,0 +1,58 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GEXFLS -- Externally callable procedure for flushing graphics output. +# Called by the CLIO procedure CLGCUR to flush graphics output prior to +# a cursor read. The main complication is that since CLGCUR is part of +# the CLIO package and may be used in a program that does not generate +# any graphics, we do not want to directly reference any GIO procedures +# since this would force the linker to load much of GIO. + +procedure gexfls() + +int gflush +pointer gp[2] +common /gxflcm/ gp, gflush + +begin + if (gflush != NULL) { + if (gp[1] != NULL) + call zcall1 (gflush, gp[1]) + if (gp[2] != NULL) + call zcall1 (gflush, gp[2]) + } +end + + +# GEXFLS_SET -- Set pointers to the gflush procedure for a stream. + +procedure gexfls_set (stream, gp_value, epa_gflush) + +int stream # graphics stream +pointer gp_value # graphics descriptor +int epa_gflush # EPA of the gflush procedure + +int gflush +pointer gp[2] +common /gxflcm/ gp, gflush + +begin + if (stream == STDGRAPH || stream == STDIMAGE) { + gp[stream-STDGRAPH+1] = gp_value + gflush = epa_gflush + } +end + + +# GEXFLS_CLEAR -- Clear the pointer to the gflush procedure for a stream. + +procedure gexfls_clear (stream) + +int stream # graphics stream +int gflush +pointer gp[2] +common /gxflcm/ gp, gflush + +begin + if (stream == STDGRAPH || stream == STDIMAGE) + gp[stream-STDGRAPH+1] = NULL +end diff --git a/sys/clio/mkpkg b/sys/clio/mkpkg new file mode 100644 index 00000000..69aca042 --- /dev/null +++ b/sys/clio/mkpkg @@ -0,0 +1,75 @@ +# CLIO portion of the system library. + +$checkout libsys.a lib$ +$update libsys.a +$checkin libsys.a lib$ +$exit + +libsys.a: + clcache.x clio.com + clclose.x + clcmd.x + clcmdw.x + clcpset.x + clepset.x clpset.h + clgcur.x + clgetb.x + clgetc.x + clgetd.x + clgeti.x + clgetl.x + clgetr.x + clgets.x + clgetx.x + clgfil.x + clgkey.x + clglpb.x + clglpc.x + clglpd.x + clglpi.x + clglpl.x + clglpr.x + clglps.x + clglpx.x + clglstr.x + clgpset.x clpset.h + clgpseta.x clpset.h + clgpsetb.x clpset.h + clgpsetc.x clpset.h + clgpsetd.x clpset.h + clgpseti.x clpset.h + clgpsetl.x clpset.h + clgpsetr.x clpset.h + clgpsets.x clpset.h + clgpsetx.x clpset.h + clgstr.x + clgwrd.x + cllpset.x clpset.h + clopen.x + clopset.x clpset.h + clppset.x clpset.h + clppseta.x clpset.h + clppsetb.x clpset.h + clppsetc.x clpset.h + clppsetd.x clpset.h + clppseti.x clpset.h + clppsetl.x clpset.h + clppsetr.x clpset.h + clppsets.x clpset.h + clppsetx.x clpset.h + clpsetnm.x clpset.h + clpstr.x + clputb.x + clputc.x + clputd.x + clputi.x + clputr.x + clputx.x + clreqpar.x + clseti.x clio.com + clstati.x clio.com + gexfls.x + rdukey.x + zfiocl.x clio.com \ + + ; diff --git a/sys/clio/rdukey.x b/sys/clio/rdukey.x new file mode 100644 index 00000000..5dc44801 --- /dev/null +++ b/sys/clio/rdukey.x @@ -0,0 +1,209 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# RD_UKEY -- Read a user keystroke from the terminal. The "ukey" object is +# either a single key, or the : key plus associated string value. +# The value of a ukey parameter is returned as a string (as for rcursor) +# and is normally fetched by an applications program with CLGKEY. The +# format of the command string is +# +# ch strval +# +# where the `strval' is present only if CH=:, i.e., the command is a colon +# escape. Control keys are encoded as octal codes of the form \NNN. + +int procedure rdukey (keystr, maxch) + +char keystr[ARB] # receives keystroke command string +int maxch # max chars out + +int junk, ch +int delay, key, tty +pointer sp, buf, ip, op +bool rawmode_set, ucasein_set +bool playback_set, pbverify_set + +pointer ttyodes() +int fstati(), ttstati(), envgets(), getci() +define again_ 91 +define done_ 92 +errchk ttyodes, syserrs + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + call flush (STDERR) + call flush (STDOUT) + + # Note whether playback mode is in effect, and set raw mode if it + # is not already set. + + rawmode_set = (fstati (STDIN, F_RAW) == YES) + playback_set = (ttstati (STDIN, TT_PLAYBACK) == YES) + pbverify_set = (ttstati (STDIN, TT_PBVERIFY) == YES) + ucasein_set = (ttstati (STDIN, TT_UCASEIN) == YES) + + if (!rawmode_set) + call fseti (STDIN, F_RAW, YES) + if (playback_set) { + delay = ttstati (STDIN, TT_PBDELAY) + call ttseti (STDIN, TT_PBDELAY, 0) + } + + # Get keystroke. + tty = NULL +again_ + if (getci (STDIN, key) == EOF) + goto done_ + + if (tty == NULL && (key == ':' || playback_set)) { + junk = envgets ("terminal", Memc[buf], SZ_LINE) + tty = ttyodes (Memc[buf]) + if (tty == ERR) { + if (!rawmode_set) + call fseti (STDIN, F_RAW, NO) + call syserrs (SYS_TTYDEVNF, Memc[buf]) + } + } + + # If colon escape, clear the current line and read the string value. + # The read is performed in raw mode to avoid a line feed and scroll + # when the CR is typed. + + if (key == ':') { + call ttyclearln (STDOUT, tty) + call ttyputline (STDOUT, tty, "\r:", NO) + call flush (STDOUT) + + for (op=buf; getci (STDIN, ch) != EOF; ) { + if (ch == '\177' || ch == '\010') { + if (op > buf) { + op = op - 1 + Memc[op] = EOS + call ttyclearln (STDOUT, tty) + call ttyputline (STDOUT, tty, "\r:", NO) + call ttyputline (STDOUT, tty, Memc[buf], NO) + call flush (STDOUT) + } + } else if (ch == '\003') { + call ttyclearln (STDOUT, tty) + goto again_ + } else if (ch == '\n' || ch == '\r' || (op - buf) >= SZ_LINE) { + break + } else { + call putci (STDOUT, ch) + call flush (STDOUT) + if (ucasein_set && IS_UPPER(ch)) + Memc[op] = TO_LOWER(ch) + else + Memc[op] = ch + op = op + 1 + } + } + + Memc[op] = '\n'; op=op+1 + Memc[op] = EOS + + call flush (STDOUT) + + } else { + Memc[buf] = EOS + if (ucasein_set && IS_UPPER(key)) + key = TO_LOWER(key) + } + +done_ + # When we get here the key character has been set and the string + # value, if any, is in buf. If in playback mode with verify + # enabled, wait for the user to type a key before continuing. + + if (playback_set) { + call ttseti (STDIN, TT_PASSTHRU, YES) + + if (key != ':') { + if (!pbverify_set) + call zwmsec (delay) + call ttyso (STDOUT, tty, YES) + if (key > ' ') + call printf (" [key=%c]") + else + call printf (" [key=\\%o]") + call pargi (key) + call ttyso (STDOUT, tty, NO) + call flush (STDOUT) + } + + if (pbverify_set) { + # Read directly from user terminal in passthru mode. + while (getci (STDIN, ch) != EOF) + if (ch == ' ') { + break + } else if (ch == 'q' || ch == '\003') { + call putline (STDOUT, "\r[playback mode terminated]") + call flush (STDOUT) + call zwmsec (500) + call ttseti (STDIN, TT_PLAYBACK, NO) + break + } else if (ch == 'g') { + call ttseti (STDIN, TT_PBVERIFY, NO) + break + } else { + call ttyclearln (STDOUT, tty) + call ttyso (STDOUT, tty, YES) + call putline (STDOUT, + "\r[space=continue,q=quit,g=noverify]") + call ttyso (STDOUT, tty, NO) + call flush (STDOUT) + } + } else + call zwmsec (delay) + + call ttseti (STDIN, TT_PASSTHRU, NO) + call ttseti (STDIN, TT_PBDELAY, delay) + } + + if (tty != NULL) { + call ttyclearln (STDOUT, tty) + call ttycdes (tty) + } + + if (!rawmode_set) + call fseti (STDIN, F_RAW, NO) + + if (key == EOF || key == '\032' || key == '\004') { + call strcpy ("EOF\n", keystr, maxch) + call sfree (sp) + return (EOF) + + } else { + op = 1 + if (key > ' ') { + keystr[op] = key; op=op+1 + } else if (maxch >= 4) { + keystr[op] = '\\'; op=op+1 + keystr[op] = '0'; op=op+1 + keystr[op] = key / 8 + '0'; op=op+1 + keystr[op] = mod(key,8) + '0'; op=op+1 + } + + if (Memc[buf] != EOS && maxch > 1) { + keystr[op] = ' '; op=op+1 + for (ip=buf; op < maxch && Memc[ip] != EOS; ip=ip+1) { + keystr[op] = Memc[ip] + op = op + 1 + } + } + + # The return string value must be newline delimited. + keystr[op] = '\n'; op=op+1 + keystr[op] = EOS + + call sfree (sp) + return (op - 1) + } +end diff --git a/sys/clio/zfiocl.x b/sys/clio/zfiocl.x new file mode 100644 index 00000000..dde60fc9 --- /dev/null +++ b/sys/clio/zfiocl.x @@ -0,0 +1,317 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include + +define SZ_NUMSTR 8 + +.help zfiocl +.nf __________________________________________________________________________ +ZFIOCL -- FIO z-routines (machine independent) for pseudofile i/o. The STDIN, +STDOUT, STDERR, and STDGRAPH streams are implemented as "pseudofiles" when a +process is run as a connected subprocess communicating with the parent process +via the IPC facilities. In such a configuration the standard i/o streams +(opened by the system [clopen] at process startup) are as follows: + + fd name description + + 1 CLIN IPC input from the parent [low level] + 2 CLOUT IPC output to the parent [low level] + 3 STDIN standard input + 4 STDOUT standard output + 5 STDERR standard error output + 6 STDGRAPH standard graphics output + 7 STDIMAGE standard greyscal output + 8 STDPLOT stdgraph plotter output + 9 PSIOCTRL pseudofile i/o control + +The CLIN and CLOUT streams are the FIO equivalents of the IPC channels, i.e., +they are connected to physical host i/o channels. The standard i/o streams +are multiplexed over the IPC channels by a packet passing protocol to the +parent process, which redirects each stream to an FIO file (which may in turn +be a pseudofile or a regular file). + +During execution of the child the parent has its command input switched to +the CLOUT stream of the child, and the child commands the parent. Commands +are sent over the IPC channels as an SPP text stream, i.e., unpacked ASCII +lines delimited by the newline character. Pseudofile data is sent as a +binary block preceded by a command to the parent to read so many chars from +the channel and pass it on to the indicated actual file. Typical output to +CLOUT might be as follows: + + param1 = + param2 = + xmit(4,34) + [34 chars of data] + +This example consists of three independent commands to the parent. The first +two are parameter requests and each is followed by a read from CLIN to get +the parameter value (which is returned in ASCII and is limited to a single +line). Syncronization occurs on the read. The binary data block in the +third command (XMIT) may contain arbitrary binary data, i.e., pseudofile +i/o is not limited to text. In the example shown the 34 chars of data will +be copied to the file associated by the parent with the STDOUT stream of +the child. The association of pseudofile codes at the IPC level with FIO +file descriptor codes is simple: the pseudofile codes are the same as the +fd codes. + +Although it is not relevant to a discussion of the pseudofile drivers, perhaps +we should mention what happens to these streams when a process is run stand +alone, i.e., no IPC channels. When a process is run stand-alone (prtype == +PR_HOST) CLIN, CLOUT, and the pseudofiles are connected to standard i/o +channels of the process as follows: + + CLIN,STDIN -> process_stdin + CLOUT,STDOUT -> process_stdout + STDERR -> process_stderr + STDGRAPH,etc. -> null file + +The standard i/o streams are normally limited to text data in stand alone +mode, since the process channels are normally connected to a terminal. Any +standard i/o stream may be redirected on the IRAF Main command line to +either a text or binary file, regardless of the process type (connected, +detached, or host). + +This file contains the FIO device drivers for each pseudofile. The device +codes are SI, SO, SE, and SG. ZARDBF, ZAWRBF, ZAWTBF, and ZSTTBF entry +points are supplied for each device. +.endhelp _____________________________________________________________________ + + +# ZCLSPS -- Dummy close procedure for all pseudofile streams. + +procedure zclsps (chan, status) + +int chan +int status + +begin + status = ERR +end + + +# ZARDPS -- "Asynchronous" read primitive for a pseudofile. The read is +# initiated by sending the following command to the parent: +# +# xfer(ps,maxchars)\n +# +# where "ps" is the pseudofile code (3=STDIN, etc.) and "maxchars" is the +# maximum number of chars to be returned. The parent responds with the actual +# number of chars to be sent, followed by newline, followed by the block of +# data, i.e.: +# +# CLOUT CLIN +# xfer(3,512)\n +# 40\n +# [40 chars of data] +# +# The parent responds by writing to the child's CLIN. +# +# NOTE1 -- Since this is a device driver (effectively a kernel procedure despite +# the machine independence) only low level procedures may be used, else a +# recursive call may result. +# NOTE2 -- There are some subtleties inherent in all this which are not obvious +# at first glance. Since CLIN and STDIN both read from the same IPC, some care +# is required to ensure that one stream does not steal messages intended for +# the other. Fortunately this is not our concern here, but rather that of the +# high level code. + +procedure zardps (ps, buf, maxbytes, offset) + +int ps # pseudofile +char buf[ARB] # buffer to receive data +int maxbytes, maxchars # capacity of buffer +long offset # ignored at present + +char numstr[SZ_NUMSTR] +int nbytes, nchars, ndigits, ip, clin_chan, raw_mode +int ctoi(), cl_psio_request(), fstati() +include "clio.com" +define ioerr_ 91 + +begin + if (ps == STDOUT || ps == STDERR) + goto ioerr_ + clin_chan = fstati (CLIN, F_CHANNEL) + raw_mode = fstati (ps, F_RAW) + + # Send the XFER command to the parent. If raw mode is in effect on + # the pseudofile, request only a single char. + + if (raw_mode == YES) + maxchars = 1 + else + maxchars = maxbytes / SZB_CHAR + + if (cl_psio_request ("xfer", ps, maxchars) == ERR) + goto ioerr_ + + # Get the number of chars to be read. + call zardpr (clin_chan, numstr, SZ_NUMSTR * SZB_CHAR, offset) + call zawtpr (clin_chan, nbytes) + + if (nbytes < 0) + goto ioerr_ + else + ndigits = nbytes / SZB_CHAR + + # Decode count of chars in data block, a simple positive integer + # constant followed by a newline. The case of a single digit + # (nchars < 10) is optimized. + + if (ndigits == 0) + nchars = 0 + else if (ndigits == 1) + nchars = TO_INTEG (numstr[1]) + else { + numstr[ndigits+1] = EOS + ip = 1 + if (ctoi (numstr, ip, nchars) <= 0) + goto ioerr_ + } + + # Read the data. + nbytes = nchars * SZB_CHAR + if (nchars == 0) + ps_status[ps] = 0 # EOF + else { + call zardpr (clin_chan, buf, nbytes, offset) + call zawtpr (clin_chan, ps_status[ps]) + } + return +ioerr_ + ps_status[ps] = ERR + return +end + + +# ZAWRPS -- Write primitive for a pseudofile. The write is initiated by +# sending the following command to the CL: +# +# xmit(ps,nchars)\n +# +# where "ps" is the pseudofile number, and "nchars" is the number of chars +# of binary data to be read from CLOUT and copied to the file connected to +# pseudofile "ps" by the parent. + +procedure zawrps (ps, buf, nbytes, offset) + +int ps # pseudofile +char buf[ARB] # buffer to receive data +int nbytes # capacity of buffer +long offset # ignored at present + +int nchars, clout_chan +int cl_psio_request(), fstati() +include "clio.com" +define ioerr_ 91 + +begin + if (ps == STDIN) + goto ioerr_ + clout_chan = fstati (CLOUT, F_CHANNEL) + + # Send the XMIT command to the parent. + nchars = nbytes / SZB_CHAR + if (cl_psio_request ("xmit", ps, nchars) == ERR) + goto ioerr_ + + # Send the data block. + call zawrpr (clout_chan, buf, nbytes, offset) + call zawtpr (clout_chan, ps_status[ps]) + return +ioerr_ + ps_status[ps] = ERR + return +end + + +# ZAWTPS -- Wait for i/o to a pseudofile (required by the FIO interface, +# though pseudofile i/o is not really asynchronous). + +procedure zawtps (ps, status) + +int ps # pseudofile code +int status # nbytes transferred in last packed (output) +include "clio.com" + +begin + status = ps_status[ps] +end + + +# ZSTTPS -- Channel status of a pseudofile. With the exception of the optimal +# buffer size for STDERR we default to the IPC status parameters, since i/o +# is ultimately over IPC channels to the parent process. + +procedure zsttps (ps, what, lvalue) + +int ps # pseudofile +int what # status parameter requested +long lvalue # output value (long) + +int fstati() + +begin + if (ps == STDERR && what == FSTT_OPTBUFSIZE) + lvalue = SZ_LINE * SZB_CHAR + else + call zsttpr (fstati(CLIN,F_CHANNEL), what, lvalue) +end + + +# CL_PSIO_REQUEST -- Output "cmd(arg1,arg2)\n" to CLOUT. Called by CL_ZARDPS +# and CL_ZAWRPS to send the XMIT and XFER commands to the CL, when writing to +# or reading from a pseudofile. + +int procedure cl_psio_request (cmd, arg1, arg2) + +char cmd[ARB] # e.g. "xmit" or "xfer" +int arg1, arg2 # integer arguments + +int ip, status, clout_chan +pointer obuf, sp, op +long offset +int itoc(), fstati() +define output {Memc[op]=$1;op=op+1} + +begin + call smark (sp) + call salloc (obuf, SZ_PATHNAME, TY_CHAR) + + clout_chan = fstati (CLOUT, F_CHANNEL) + + op = obuf + for (ip=1; cmd[ip] != EOS; ip=ip+1) + output (cmd[ip]) + + # Encode argument list. Arguments are assumed to always be + # nonnegative. Optimized for simple single digit numbers. + + output ('(') + if (arg1 < 10) + output (TO_DIGIT (arg1)) + else + op = op + itoc (arg1, Memc[op], SZ_PATHNAME-(op-obuf)) + + output (',') + + if (arg2 < 10) + output (TO_DIGIT (arg2)) + else + op = op + itoc (arg2, Memc[op], SZ_PATHNAME-(op-obuf)) + + output (')') + output ('\n') + + call zawrpr (clout_chan, Memc[obuf], (op-obuf) * SZB_CHAR, offset) + call zawtpr (clout_chan, status) + + call sfree (sp) + return (status) +end diff --git a/sys/dbio/README b/sys/dbio/README new file mode 100644 index 00000000..d5411a74 --- /dev/null +++ b/sys/dbio/README @@ -0,0 +1,3 @@ + +This directory shall contain the sources for the iraf database package. +See the discussion in the crib sheet for more information on DBIO. diff --git a/sys/dbio/db2.doc b/sys/dbio/db2.doc new file mode 100644 index 00000000..66a38c41 --- /dev/null +++ b/sys/dbio/db2.doc @@ -0,0 +1,674 @@ +DBIO (Nov84) Database I/O Design DBIO (Nov84) + + + + IRAF DATABASE I/O + Doug Tody + November 1984 + + + + + +1. INTRODUCTION + + The IRAF database i/o package (DBIO) is a library of SPP callable +procedures used to create, modify, and access IRAF database files. All +access to these database files shall be indirectly or directly via the +DBIO interface. DBIO shall be implemented using IRAF file i/o and +memory management facilities, hence the package will be compact and +portable. The separate CL level package DBMS shall be provided for +interactive database access and for procedural access to the database +from within CL scripts. The DBMS tasks will access the database via +DBIO. + +Virtually all runtime IRAF datafiles not maintained in text form shall +be maintained under DBIO, hence it is essential that the interface be +both efficient and compact. In particular, bulk data (images) and +large catalogs shall be maintained under DBIO. The requirement for +flexibility in defining and accessing IRAF image headers necessitates +quite a sophisticated interface. Catalog storage is required primarily +for module intercommunication and output of the results of the larger +IRAF applications packages, but will also be useful for accessing +astronomical catalogs prepared outside IRAF (e.g., the SAO star +catalog). In short, virtually all IRAF applications packages are +expected to make use of DBIO; many will depend upon it heavily. + +The relationship of the DBIO and DBMS packages to each other and to the +related standard IRAF interfaces is shown in Figure 1.1. + + + DBMS + DBIO + FIO + MEMIO + (kernel) + (datafiles) + + (cl) | (vos) | (host) + + + + Fig 1.1 Major Interfaces + + +While images will be maintained under DBIO, access to the pixels will +continue to be provided by the IMIO interface. IMIO is a higher level +interface which will use DBIO to maintain the image header. Pixel + + + -1- + DBIO (Nov84) Database I/O Design DBIO (Nov84) + + + +storage will be either in a separate pixel storage file or in the +database file itself (as a one dimensional array), depending on the +size of the image. A system defined thresold value will determine +which type of storage is used. The relationship of IMIO to DBIO is +shown in Figure 1.2. + + + IMAGES + IMIO + DBIO + FIO + MEMIO + + (cl) | (vos) + + + Fig 1.2 Relationship of Database and Image I/O + + + +2. REQUIREMENTS + + The requirements for the DBIO interface are driven by its intended +usage for image and catalog storage. It is arguable whether the same +interface should be used for both types of data, but development of an +interface such as DBIO with all the associated DBMS utilities is +expensive, hence we would prefer to have to develop only one such +interface. Furthermore, it is desirable for the user to only have to +learn one such interface. The primary functional and performance +requirements which DBIO must meet are the following (in no particular +order). + + + [1] DBIO shall provide a high degree of data independence, i.e., a + program shall be able to access a data structure maintained + under DBIO without detailed knowledge of its contents. + + [2] A DBIO datafile shall be self describing and self contained, + i.e., it shall be possible to examine the structure and + contents of a DBIO datafile without prior knowledge of its + structure or contents. + + [3] DBIO shall be able to deal efficiently with records containing + up to N fields and with data groups containing up to M records, + where N and M are at least sysgen configurable and are order of + magnitude N=10**2 and M=10**6. + + [4] The time required to access an image header under DBIO must be + comparable to the time currently required for the equivalent + operation under IMIO. + + + + + + -2- + DBIO (Nov84) Database I/O Design DBIO (Nov84) + + + + [5] It shall be possible for an image header maintained under DBIO + to contain application or user defined fields in addition to + the standard fields required by IMIO. + + [6] It shall be possible to dynamically add new fields to an + existing image header (or to any DBIO record). + + [7] It shall be possible to group similar records together in the + database and to perform global operations upon all or part of + the records in a group. + + [8] It shall be possible for a field of a record to be a + one-dimensional array of any of the primitive types. + + [9] Variant records (records containing variable size fields) shall + be supported, ideally without penalizing efficient access to + databases which do not contain such records. + + [A] It shall be possible to copy a record without knowledge of its + contents. + + [B] It shall be possible to merge (join) two records containing + disjoint sets of fields. + + [C] It shall be possible to update a record in place. + + [D] It shall be possible to simultaneously access (retrieve, + update, or insert) multiple records from the same data group. + + +To summarize, the primary requirements are data independence, efficient +access to both large and small databases, and flexibility in the +contents of the database. + + + +3. CONCEPTUAL DESIGN + + The DBIO database faciltities shall be based upon the relational +model. The relational model is preferred due to its simplicity (to the +user) and due to the demonstrable fact that relational databases can +efficiently handle large amounts of data. In the relational model the +database appears to be nothing more than a set of TABLES, with no +builtin connections between separate tables. The operations defined +upon these tables are based upon the relational algebra, which is in +turn based upon set theory. The major advantages claimed for +relational databases are the simplicity of the concept of a database as +a collection of tables, and the predictability of the relational +operators due to their being based on a formal theoretical model. + +None of the requirements listed in section 2 state that DBIO must +implement a relational database. Most of our needs can be met by +structuring our data according to the relational data model (i.e., as + + + -3- + DBIO (Nov84) Database I/O Design DBIO (Nov84) + + + +tables), and providing a good SELECT operator for retrieving records +from the database. If a semirelational database is sufficient to meet +our requirements then most likely that is what will be built (at least +initially; the relational operators are very attractive for data +analysis). DBIO is not expected to be competitive with any commercial +relational database; to try to make it so would probably compromise the +requirement that the interface be compact. On the other hand, the +database requirements of IRAF are similar enough to those addressed by +commercial databases that we would be foolish not to try to make use of +some of the same technology. + + + FORMAL RELATIONAL TERM INFORMAL EQUIVALENTS + + relation table + tuple record, row + attribute field, column + domain datatype + primary key record id + + +A DBIO DATABASE shall consist of one or more RELATIONS (tables). Each +relation shall contain zero or more RECORDS (rows of the table). Each +record shall contain one or more FIELDS (columns of the table). All +records in a relation shall share the same set of fields, but all of +the fields in a record need not have been assigned values. When a new +ATTRIBUTE (column) is added to an existing relation a default valued +field is added to each current and future record in the relation. + +Each attribute is defined upon a particular DOMAIN, e.g., the set of +all nonnegative integer values less than or equal to 100. It shall be +possible to specify minimum and maximum values for integer and real +attributes and to enumerate the permissible values of a string type +attribute. It shall be possible to specify a default value for an +attribute. If no default value is given INDEF is assumed. One +dimensional arrays shall be supported as attribute types; these will be +treated as atomic datatypes by the relational operators. Array valued +attributes shall be either fixed in size (the most efficient form) or +variant. There need be no special character string datatype since one +dimensional arrays of type character are supported. + +Each relation shall be implemented as a separate file. If the relations +comprising a database are stored in a directory then the directory can +be thought of as the database. Public databases will be stored in well +known public (write protected) directories, private databases in user +directories. The logical directory name of each public database will be +the name of the database. Physical storage for a database need not +necessarily be allocated locally, i.e., a database may be centrally +located and remotely accessed if the host computer is part of a local +area network. + +Locking shall be at the level of entire relations rather than at the +record level, at least in the initial implementation. There shall be + + + -4- + DBIO (Nov84) Database I/O Design DBIO (Nov84) + + + +no support for indices in the initial implementation except possibly +for the primary key. It should be possible to add either or both of +these features to a future implementation without changing the basic +DBIO interface. Modifications to the internal data structures used in +database files will likely be necessary when adding such a major +feature, making a save and restore operation necessary for each +database file to convert it to the new format. The save format chosen +(e.g. FITS table) should be independent of the internal format used at +a particular time on a particular host machine. + +Images shall be stored in the database as individual records. All +image records shall share a common subset of attributes. Related +images (image records) may be grouped together to form relations. The +IRAF image operators shall support operations upon relations (sets of +images) much as the IRAF file operators support operations upon sets of +files. + +A unary image operator shall take as input a relation (set of one or +more images), inserting the processed images into the output relation. +A binary image operator shall take as input either two relations or a +relation and a record, inserting the processed images into the output +relation. In all cases the output relation can be an input relation as +well. The input relation will be defined either by a list or by +selection using a theta-join (operationally similar to a filename +template). + + + +3.1 RELATIONAL OPERATORS + + DBIO shall support two basic types of database operations: +operations upon relations and operations upon records. The basic +relational operators are the following. All of these operators produce +as output a new relation. + + + create + Create a new base relation (physical relation as stored on + disk) by specifying an initial set of attributes and the + (file)name for the new relation. Attributes and domains may be + specified via a data definition file or by reference to an + existing relation. A primary key (limited to a single + attribute) should be identified. The new relation initially + contains no records. + + drop + Delete a (possibly nonempty) base relation and any associated + indices. + + alter + Add a new attribute or attributes to an existing base relation. + Attributes may be specified explicitly or by reference to + another relation. + + + -5- + DBIO (Nov84) Database I/O Design DBIO (Nov84) + + + + select + Create a new relation by selecting records from one or more + existing base relations. Input consists of an algebraic + expression defining the output relation in terms of the input + relations (usage will be similar to filename templates). The + output relation need not have the same set of attributes as the + input relations. The SELECT operator shall ultimately implement + all the basic operations of the relational algebra, i.e., + select, project, join, and the set operations. At a minimum, + selection and projection are required in the initial + interface. The output of SELECT is not a named relation (base + relation), but is instead intended to be accessed by the record + level operators discussed in the next section. + + edit + Edit a relation. An interactive screen editor is entered + allowing the user to add, delete, or modify tuples (not + required in the initial version of the interface). Field + values are verified upon input. + + sort + Make the storage order of the records in a relation agree with + the order defined by the primary key (the index associated with + the primary key is always sorted but index order need not agree + with storage order). In general, retrieval on a sorted + relation is more efficient than on an unsorted relation. + Sorting also eliminates deadspace left by record deletion or by + updates involving variant records. + + +Additional nonalgebraic operators are required for examining the +structure and contents of relations, returning the number of records or +attributes in a relation, and determining whether a given relation +exists. + +The SELECT operator is the primary user interface to DBIO. Since most +of the relational power of DBIO is bound up in the SELECT operator and +since SELECT will be driven by an algebraic expression (character +string) there is considerable scope for future enhancement of DBIO +without affecting existing code. + + + +3.2 RECORD (TUPLE) LEVEL OPERATORS + + While the user should see primarily operations on entire relations, +record level processing is necessary at the program level to permit +data entry and implementation of special operators. The basic record +level operators are the following. + + + + + + + -6- + DBIO (Nov84) Database I/O Design DBIO (Nov84) + + + + retrieve + Retrieve the next record from the relation defined by SELECT. + While the tuples in a relation theoretically form an unordered + set, tuples will normally be returned in either storage order + or in the sort order of the primary key. Although all fields + of a retrieved record are accessible, an application will + typically have knowledge of only a few fields. + + update + Rewrite the (possibly modified) current record. The updated + record is written back into the base table from which it was + read. Not all records produced by SELECT can be updated. + + insert + Insert a new record into an output relation. The output + relation may be an input relation as well. Records added to an + output relation which is also an input relation do not become + candidates for selection until another SELECT occurs. A + retrieve followed by an insert copies a record without + knowledge of its contents. A retrieve followed by modification + of selected fields followed by an insert copies all unmodified + fields of the record. The attributes of the input and output + relations need not match; unmatched output attributes take on + their default values and unmatched input attributes are + discarded. INSERT returns a pointer to the output record, + allowing insertions of null records to be followed by + initialization of the fields of the new record. + + delete + Delete the current record. + + +Additional operators are required to close or open a relation for record +level access and to count the number of records in a relation. + + + +3.2.1 CONSTRUCTING SPECIAL RELATIONAL OPERATORS + + The record level operations may be combined with SELECT in compiled +programs to implement arbitrary operations upon entire relations. The +basic scenario is as follows: + + + [1] The set of records to be operated upon, defined by the SELECT + operator, is opened as an unordered set (list) of records to be + processed. + + [2] The "next" record in the relation is accessed with RETRIEVE. + + + + + + + -7- + DBIO (Nov84) Database I/O Design DBIO (Nov84) + + + + [3] The application reads or modifies a subset of the fields of the + record, updating modified records or inserting the record in + the output relation. + + [4] Steps [2] and [3] are repeated until the entire relation has + been processed. + + +Examples of such operators are conversion to and from DBIO and LIST file +formats, column extraction, mimimum or maximum of an attribute (domain +algebra), and all of the DBMS and IMAGES operators. + + + +3.3 FIELD (ATTRIBUTE) LEVEL OPERATORS + + Substantial processing of the contents of a database is possible +without ever accessing the individual fields of a record. If field +level access is required the record must first be retrieved or +inserted. Field level access requires knowledge of the names of the +attributes of the parent relation, but not their exact datatypes. +Automatic type conversion occurs when field values are queried or set. + + + get + Get the value of the named scalar or vector field (typed). + + put + Put the value of the named scalar or vector field (typed). + + read + Read the named fields into an SPP data structure, given the + name, datatype, and length (if vector) of each field in the + output structure. There must be an attribute in the parent + relation for each field in the output structure. + + write + Copy an SPP data structure into the named fields of a record, + given the name, datatype, and length (if vector) of each field + in the input structure. There must be an attribute in the + parent relation for each field in the input structure. + + access + Determine whether a relation has the named attribute. + + + +3.4 STORAGE STRUCTURES + + The DBIO storage structures are the data structures used by DBIO to +maintain relations in physical storage. The primary design goals are +simplicity and efficiency in time and space. Most actual relations are +expected to fall into three classes: + + + -8- + DBIO (Nov84) Database I/O Design DBIO (Nov84) + + + + [1] Relations containing only a single record, e.g., an image + stored alone in a relation. + + [2] Relations containing several dozen or several hundred records, + e.g., a collection of spectra from an observing run. + + [3] Large relations containing 10**5 or 10**6 records, e.g., the + output of an analysis program or an astronomical catalog. + + +Updates and insertions are generally random access operations; retrieval +based on the values of several attributes requires efficient sequential +access. Efficient random access for relations [2] and [3] requires use +of an index. Efficient sequential access requires that records be +accessible in storage order without reference to the index, i.e., that +records be chained in storage order. Efficient field access where a +record contains several dozen attributes requires something better than +a linear search over the attribute list. + +The use of an index shall be limited initially to a single index for +the primary key. The primary key will be restricted to a single +attribute, with the application defining the attribute to be used (in +practice few attributes are usable as keys). The index will be a +standard B+ tree, with one exception: the root block of the tree will +be maintained in dedicated storage in the datafile. If and only if a +relation grows so large that it overflows the root block will a +separate index file be allocated for the index. This will eliminate +most of the overhead associated with the index for small relations. + +Efficient sequential access will be provided in either of two ways: via +the index in index order or via the records themselves in storage order, +depending on the operation being performed. If an external index is +used the leaves will be chained to permit efficient sequential access +in index order. If the relation also happens to be sorted in index +order then this mode of access will be very efficient. Link +information will also be stored directly in the records to permit +efficient sequential access when it is not necessary or possible to use +the index. + +Assuming that there is at most one index associated with a relation, at +most two files will be required to implement the relation. The relation +itself will have the file extension ".db". The index file, if any, will +have the extension ".dbi". The root name of both files will be the +name of the relation. + +The datafile header structure will probably have to be maintained in +binary if we are to keep the overhead of datafile access to acceptable +levels for small relations. Careful design of the basic header +structure should make most future refinements to the header possible +without modification of existing databases. The revision number of +DBIO used to create the datafile will be saved in the header to make at +least detection of obsolete headers possible. + + + + -9- + DBIO (Nov84) Database I/O Design DBIO (Nov84) + + + +3.4.1 STRUCTURE OF A BINARY RELATION + + Putting all this together we come up with the following structure +for a binary relation: + + + BOF + relation header -+ + magic | + dbio revision number | + creation date | + relation name | + number of attributes |- fixed size header + primary key | + record size | + domain list | + attribute list | + miscellaneous | + string buffer | + root block of index -+ + record 1 + physical record length (offset to next record) + logical record length (implies number of attributes set) + field storage + + record 2 + ... + record N + EOF + + +Vector valued fields with a fixed upper size will be stored directly in +the record, prefixed by the length of the actual vector (which may vary +from record to record). Storage for variant fields will be allocated +outside the record, placing only a pointer to the data vector and byte +count in the record itself. Variant records are thus reduced to fixed +size records, simplifying record access and making sequential access +more efficient. + +Records will change size only when a new attribute is added to an +existing relation, followed by assignment into a record written when +there were fewer attributes. If the new record will not fit into the +physical slot already allocated, the record is written at EOF and the +original record is deleted. Deletion of a record is achieved by +setting the logical record length to zero. Storage is not reclaimed +until a sort occurs, hence recovery of deleted records is possible. + +To minimize buffer space and memory to memory copies when accessing a +relation it is desirable to work directly out of the FIO buffers. To +make this possible records will not be permitted to straddle logical +block boundaries. A file block will typically contain several records +followed by a gap. The gap may be used to accomodate record expansion +without moving a record to EOF. The size of a file block is fixed when + + + -10- + DBIO (Nov84) Database I/O Design DBIO (Nov84) + + + +the relation is created. + + + +3.4.2 THE ATTRIBUTE LIST + + Efficient lookup of attribute names suggests maintenance of a hash +table in the datafile header. There will be a fixed upper limit on the +number of attributes permitted in a single relation (but not on the +number of records). Placing an upper limit on the number of attributes +simplifies the software considerably and permits use of a fixed size +header, making it possible to read or update the entire header in one +disk access. There will also be an upper limit on the number of +domains, but the domain list is not searched very often hence a linear +search will do. + +All information about the decomposition of a record into fields, other +than the logical length of vector valued fields, is given by the +attribute list. Records contain only data with no embedded structural +information other than the length of the vector fields. New attributes +are added to a relation by appending to the attribute list. Existing +records are not affected. By comparing the logical length of a record +to the offset for a particular field we can tell whether storage has +been allocated for that field in the record. + +Domains are used to limit the range of values a field can take on in an +assignment, and to flag attribute comparisons which are likely to be +erroneous (e.g. order comparison of a pixel coordinate and a +wavelength). The domains "bool", "char", "short", etc. are +predefined. The following information must be stored for each user +defined domain: + + + name may be same as attribute name + datatype bool, char, short, etc. + physical vector length 0=variant, 1=scalar, N=vector + default default value, INDEF if not given + minimum mimimum value (ints and reals) + maximum maximum value (ints and reals) + enumval enumerated values (strings) + + +The following information is required to describe each attribute. The +attribute list is maintained separately from the hash table of attribute +names and can be used to regenerate the hash table of attribute names if +necessary. + + + name no embedded whitespace + domain index into domain table + offset offset in record + + + + + -11- + DBIO (Nov84) Database I/O Design DBIO (Nov84) + + + +All strings will will be stored in a fixed size string buffer in the +header area; it is the index of the string which is stored in the +domain and attribute lists. This eliminates the need to place an upper +limit on the size of domain names and enumerated value lists and makes +it possible for a single attribute name string to be referenced in both +the attribute list and the attribute hash table. + + + +4. SPECIFICATIONS diff --git a/sys/dbio/db2.hlp b/sys/dbio/db2.hlp new file mode 100644 index 00000000..ffe3b74c --- /dev/null +++ b/sys/dbio/db2.hlp @@ -0,0 +1,612 @@ +.help dbio Nov84 "Database I/O Design" +.ce +\fBIRAF Database I/O\fR +.ce +Doug Tody +.ce +November 1984 +.sp 3 +.nh +Introduction + + The IRAF database i/o package (DBIO) is a library of SPP callable +procedures used to create, modify, and access IRAF database files. +All access to these database files shall be indirectly or directly via the +DBIO interface. DBIO shall be implemented using IRAF file i/o and memory +management facilities, hence the package will be compact and portable. +The separate CL level package DBMS shall be provided for interactive database +access and for procedural access to the database from within CL scripts. +The DBMS tasks will access the database via DBIO. + +Virtually all runtime IRAF datafiles not maintained in text form shall be +maintained under DBIO, hence it is essential that the interface be both +efficient and compact. In particular, bulk data (images) and large catalogs +shall be maintained under DBIO. The requirement for flexibility in defining +and accessing IRAF image headers necessitates quite a sophisticated interface. +Catalog storage is required primarily for module intercommunication and +output of the results of the larger IRAF applications packages, but will also +be useful for accessing astronomical catalogs prepared outside IRAF (e.g., +the SAO star catalog). In short, virtually all IRAF applications packages +are expected to make use of DBIO; many will depend upon it heavily. + +The relationship of the DBIO and DBMS packages to each other and to the +related standard IRAF interfaces is shown in Figure 1.1. + + +.ks +.nf + DBMS + DBIO + FIO + MEMIO + (kernel) + (datafiles) + + (cl) | (vos) | (host) + + + +.fi +.ce +Fig 1.1 Major Interfaces +.ke + + +While images will be maintained under DBIO, access to the pixels will +continue to be provided by the IMIO interface. IMIO is a higher level interface +which will use DBIO to maintain the image header. Pixel storage will be either +in a separate pixel storage file or in the database file itself (as a one +dimensional array), depending on the size of the image. +A system defined thresold value will determine which type of storage is used. +The relationship of IMIO to DBIO is shown in Figure 1.2. + + +.ks +.nf + IMAGES + IMIO + DBIO + FIO + MEMIO + + (cl) | (vos) + + +.fi +.ce +Fig 1.2 Relationship of Database and Image I/O +.ke + +.nh +Requirements + + The requirements for the DBIO interface are driven by its intended usage +for image and catalog storage. It is arguable whether the same interface +should be used for both types of data, but development of an interface such +as DBIO with all the associated DBMS utilities is expensive, hence we would +prefer to have to develop only one such interface. Furthermore, it is desirable +for the user to only have to learn one such interface. The primary functional +and performance requirements which DBIO must meet are the following (in no +particular order). + +.ls +.ls [1] +DBIO shall provide a high degree of data independence, i.e., a program +shall be able to access a data structure maintained under DBIO without +detailed knowledge of its contents. +.le +.ls [2] +A DBIO datafile shall be self describing and self contained, i.e., it shall +be possible to examine the structure and contents of a DBIO datafile without +prior knowledge of its structure or contents. +.le +.ls [3] +DBIO shall be able to deal efficiently with records containing up to N fields +and with data groups containing up to M records, where N and M are at least +sysgen configurable and are order of magnitude N=10**2 and M=10**6. +.le +.ls [4] +The time required to access an image header under DBIO must be comparable +to the time currently required for the equivalent operation under IMIO. +.le +.ls [5] +It shall be possible for an image header maintained under DBIO to contain +application or user defined fields in addition to the standard fields +required by IMIO. +.le +.ls [6] +It shall be possible to dynamically add new fields to an existing image header +(or to any DBIO record). +.le +.ls [7] +It shall be possible to group similar records together in the database +and to perform global operations upon all or part of the records in a +group. +.le +.ls [8] +It shall be possible for a field of a record to be a one-dimensional array +of any of the primitive types. +.le +.ls [9] +Variant records (records containing variable size fields) shall be supported, +ideally without penalizing efficient access to databases which do not contain +such records. +.le +.ls [A] +It shall be possible to copy a record without knowledge of its contents. +.le +.ls [B] +It shall be possible to merge (join) two records containing disjoint sets of +fields. +.le +.ls [C] +It shall be possible to update a record in place. +.le +.ls [D] +It shall be possible to simultaneously access (retrieve, update, or insert) +multiple records from the same data group. +.le +.le + + +To summarize, the primary requirements are data independence, efficient access +to both large and small databases, and flexibility in the contents of the +database. + +.nh +Conceptual Design + + The DBIO database facilities shall be based upon the relational model. +The relational model is preferred due to its simplicity (to the user) +and due to the demonstrable fact that relational databases can efficiently +handle large amounts of data. In the relational model the database appears +to be nothing more than a set of \fBtables\fR, with no builtin connections +between separate tables. The operations defined upon these tables are based +upon the relational algebra, which is in turn based upon set theory. +The major advantages claimed for relational databases are the simplicity +of the concept of a database as a collection of tables, and the predictability +of the relational operators due to their being based on a formal theoretical +model. + +None of the requirements listed in section 2 state that DBIO must implement +a relational database. Most of our needs can be met by structuring our data +according to the relational data model (i.e., as tables), and providing a +good \fBselect\fR operator for retrieving records from the database. If a +semirelational database is sufficient to meet our requirements then most +likely that is what will be built (at least initially; the relational operators +are very attractive for data analysis). DBIO is not expected to be competitive +with any commercial relational database; to try to make it so would probably +compromise the requirement that the interface be compact. +On the other hand, the database requirements of IRAF are similar enough to +those addressed by commercial databases that we would be foolish not to try +to make use of some of the same technology. + + +.ks +.nf + \fBformal relational term\fR \fBinformal equivalents\fR + + relation table + tuple record, row + attribute field, column + domain datatype + primary key record id +.fi +.ke + + +A DBIO \fBdatabase\fR shall consist of one or more \fBrelations\fR (tables). +Each relation shall contain zero or more \fBrecords\fR (rows of the table). +Each record shall contain one or more \fBfields\fR (columns of the table). +All records in a relation shall share the same set of fields, +but all of the fields in a record need not have been assigned values. +When a new \fBattribute\fR (column) is added to an existing relation a default +valued field is added to each current and future record in the relation. + +Each attribute is defined upon a particular \fBdomain\fR, e.g., the set of +all nonnegative integer values less than or equal to 100. It shall be possible +to specify minimum and maximum values for integer and real attributes +and to enumerate the permissible values of a string type attribute. +It shall be possible to specify a default value for an attribute. +If no default value is given INDEF is assumed. +One dimensional arrays shall be supported as attribute types; these will be +treated as atomic datatypes by the relational operators. Array valued +attributes shall be either fixed in size (the most efficient form) or variant. +There need be no special character string datatype since one dimensional +arrays of type character are supported. + +Each relation shall be implemented as a separate file. If the relations +comprising a database are stored in a directory then the directory can +be thought of as the database. Public databases will be stored in well +known public (write protected) directories, private databases in user +directories. The logical directory name of each public database will be +the name of the database. Physical storage for a database need not necessarily +be allocated locally, i.e., a database may be centrally located and remotely +accessed if the host computer is part of a local area network. + +Locking shall be at the level of entire relations rather than at the record +level, at least in the initial implementation. There shall be no support for +indices in the initial implementation except possibly for the primary key. +It should be possible to add either or both of these features to a future +implementation without changing the basic DBIO interface. Modifications to +the internal data structures used in database files will likely be necessary +when adding such a major feature, making a save and restore operation +necessary for each database file to convert it to the new format. +The save format chosen (e.g. FITS table) should be independent of the +internal format used at a particular time on a particular host machine. + +Images shall be stored in the database as individual records. +All image records shall share a common subset of attributes. +Related images (image records) may be grouped together to form relations. +The IRAF image operators shall support operations upon relations +(sets of images) much as the IRAF file operators support operations upon +sets of files. + +A unary image operator shall take as input a relation (set of one or more +images), inserting the processed images into the output relation. +A binary image operator shall take as input either two relations or a +relation and a record, inserting the processed images into the output +relation. In all cases the output relation can be an input relation as +well. The input relation will be defined either by a list or by selection +using a theta-join (operationally similar to a filename template). + +.nh 2 +Relational Operators + + DBIO shall support two basic types of database operations: operations upon +relations and operations upon records. The basic relational operators +are the following. All of these operators produce as output a new relation. + +.ls +.ls create +Create a new base relation (physical relation as stored on disk) by specifying +an initial set of attributes and the (file)name for the new relation. +Attributes and domains may be specified via a data definition file or by +reference to an existing relation. +A primary key (limited to a single attribute) should be identified. +The new relation initially contains no records. +.le +.ls drop +Delete a (possibly nonempty) base relation and any associated indices. +.le +.ls alter +Add a new attribute or attributes to an existing base relation. +Attributes may be specified explicitly or by reference to another relation. +.le +.ls select +Create a new relation by selecting records from one or more existing base +relations. Input consists of an algebraic expression defining the output +relation in terms of the input relations (usage will be similar to filename +templates). The output relation need not have the same set of attributes as +the input relations. The \fIselect\fR operator shall ultimately implement +all the basic operations of the relational algebra, i.e., select, project, +join, and the set operations. At a minimum, selection and projection are +required in the initial interface. The output of \fBselect\fR is not a +named relation (base relation), but is instead intended to be accessed +by the record level operators discussed in the next section. +.le +.ls edit +Edit a relation. An interactive screen editor is entered allowing the user +to add, delete, or modify tuples (not required in the initial version of +the interface). Field values are verified upon input. +.le +.ls sort +Make the storage order of the records in a relation agree with the order +defined by the primary key (the index associated with the primary key is +always sorted but index order need not agree with storage order). +In general, retrieval on a sorted relation is more efficient than on an +unsorted relation. Sorting also eliminates deadspace left by record +deletion or by updates involving variant records. +.le +.le + + +Additional nonalgebraic operators are required for examining the structure +and contents of relations, returning the number of records or attributes in +a relation, and determining whether a given relation exists. + +The \fIselect\fR operator is the primary user interface to DBIO. +Since most of the relational power of DBIO is bound up in the \fIselect\fR +operator and since \fIselect\fR will be driven by an algebraic expression +(character string) there is considerable scope for future enhancement +of DBIO without affecting existing code. + +.nh 2 +Record (Tuple) Level Operators + + While the user should see primarily operations on entire relations, +record level processing is necessary at the program level to permit +data entry and implementation of special operators. The basic record +level operators are the following. + +.ls +.ls retrieve +Retrieve the next record from the relation defined by \fBselect\fR. +While the tuples in a relation theoretically form an unordered set, +tuples will normally be returned in either storage order or in the sort +order of the primary key. Although all fields of a retrieved record are +accessible, an application will typically have knowledge of only a few fields. +.le +.ls update +Rewrite the (possibly modified) current record. The updated record is +written back into the base table from which it was read. Not all records +produced by \fBselect\fR can be updated. +.le +.ls insert +Insert a new record into an output relation. The output relation may be an +input relation as well. Records added to an output relation which is also +an input relation do not become candidates for selection until another +\fBselect\fR occurs. A retrieve followed by an insert copies a record without +knowledge of its contents. A retrieve followed by modification of selected +fields followed by an insert copies all unmodified fields of the record. +The attributes of the input and output relations need not match; unmatched +output attributes take on their default values and unmatched input attributes +are discarded. \fBInsert\fR returns a pointer to the output record, +allowing insertions of null records to be followed by initialization of +the fields of the new record. +.le +.ls delete +Delete the current record. +.le +.le + + +Additional operators are required to close or open a relation for record +level access and to count the number of records in a relation. + +.nh 3 +Constructing Special Relational Operators + + The record level operations may be combined with \fBselect\fR in compiled +programs to implement arbitrary operations upon entire relations. +The basic scenario is as follows: + +.ls +.ls [1] +The set of records to be operated upon, defined by the \fBselect\fR +operator, is opened as an unordered set (list) of records to be processed. +.le +.ls [2] +The "next" record in the relation is accessed with \fBretrieve\fR. +.le +.ls [3] +The application reads or modifies a subset of the fields of the record, +updating modified records or inserting the record in the output relation. +.le +.ls [4] +Steps [2] and [3] are repeated until the entire relation has been processed. +.le +.le + + +Examples of such operators are conversion to and from DBIO and LIST file +formats, column extraction, mimimum or maximum of an attribute (domain +algebra), and all of the DBMS and IMAGES operators. + +.nh 2 +Field (Attribute) Level Operators + + Substantial processing of the contents of a database is possible without +ever accessing the individual fields of a record. If field level access is +required the record must first be retrieved or inserted. Field level access +requires knowledge of the names of the attributes of the parent relation, +but not their exact datatypes. Automatic type conversion occurs when field +values are queried or set. + +.ls +.ls get +.sp +Get the value of the named scalar or vector field (typed). +.le +.ls put +.sp +Put the value of the named scalar or vector field (typed). +.le +.ls read +Read the named fields into an SPP data structure, given the name, datatype, +and length (if vector) of each field in the output structure. +There must be an attribute in the parent relation for each field in the +output structure. +.le +.ls write +Copy an SPP data structure into the named fields of a record, given the +name, datatype, and length (if vector) of each field in the input structure. +There must be an attribute in the parent relation for each field in the +input structure. +.le +.ls access +Determine whether a relation has the named attribute. +.le +.le + +.nh 2 +Storage Structures + + The DBIO storage structures are the data structures used by DBIO to +maintain relations in physical storage. The primary design goals are +simplicity and efficiency in time and space. Most actual relations are +expected to fall into three classes: + +.ls +.ls [1] +Relations containing only a single record, e.g., an image stored alone +in a relation. +.le +.ls [2] +Relations containing several dozen or several hundred records, e.g., +a collection of spectra from an observing run. +.le +.ls [3] +Large relations containing 10**5 or 10**6 records, e.g., the output of an +analysis program or an astronomical catalog. +.le +.le + + +Updates and insertions are generally random access operations; retrieval +based on the values of several attributes requires efficient sequential +access. Efficient random access for relations [2] and [3] requires use +of an index. Efficient sequential access requires that records be +accessible in storage order without reference to the index, i.e., that +records be chained in storage order. Efficient field access where a +record contains several dozen attributes requires something better than +a linear search over the attribute list. + +The use of an index shall be limited initially to a single index for +the primary key. The primary key will be restricted to a single attribute, +with the application defining the attribute to be used (in practice few +attributes are usable as keys). +The index will be a standard B+ tree, with one exception: the root block +of the tree will be maintained in dedicated storage in the datafile. +If and only if a relation grows so large that it overflows the root block +will a separate index file be allocated for the index. This will eliminate +most of the overhead associated with the index for small relations. + +Efficient sequential access will be provided in either of two ways: via the +index in index order or via the records themselves in storage order, +depending on the operation being performed. If an external index is used +the leaves will be chained to permit efficient sequential access in index +order. If the relation also happens to be sorted in index order then this +mode of access will be very efficient. Link information will also be stored +directly in the records to permit efficient sequential access when it is +not necessary or possible to use the index. + +Assuming that there is at most one index associated with a relation, +at most two files will be required to implement the relation. The relation +itself will have the file extension ".db". The index file, if any, will +have the extension ".dbi". The root name of both files will be the name of +the relation. + +The datafile header structure will probably have to be maintained in binary +if we are to keep the overhead of datafile access to acceptable levels for +small relations. Careful design of the basic header structure should +make most future refinements to the header possible without modification of +existing databases. The revision number of DBIO used to create the datafile +will be saved in the header to make at least detection of obsolete headers +possible. + +.nh 3 +Structure of a Binary Relation + + Putting all this together we come up with the following structure for +a binary relation: + + +.ks +.nf + BOF + relation header -+ + magic | + dbio revision number | + creation date | + relation name | + number of attributes |- fixed size header + primary key | + record size | + domain list | + attribute list | + miscellaneous | + string buffer | + root block of index -+ + record 1 + physical record length (offset to next record) + logical record length (implies number of attributes set) + field storage + + record 2 + ... + record N + EOF +.fi +.ke + + +Vector valued fields with a fixed upper size will be stored directly in the +record, prefixed by the length of the actual vector (which may vary from +record to record). +Storage for variant fields will be allocated outside the record, placing only +a pointer to the data vector and byte count in the record itself. +Variant records are thus reduced to fixed size records, +simplifying record access and making sequential access more efficient. + +Records will change size only when a new attribute is added to an existing +relation, followed by assignment into a record written when there were +fewer attributes. If the new record will not fit into the physical slot +already allocated, the record is written at EOF and the original record +is deleted. Deletion of a record is achieved by setting the logical record +length to zero. Storage is not reclaimed until a sort occurs, hence +recovery of deleted records is possible. + +To minimize buffer space and memory to memory copies when accessing a +relation it is desirable to work directly out of the FIO buffers. +To make this possible records will not be permitted to straddle logical +block boundaries. A file block will typically contain several records +followed by a gap. The gap may be used to accommodate record expansion +without moving a record to EOF. The size of a file block is fixed when +the relation is created. + +.nh 3 +The Attribute List + + Efficient lookup of attribute names suggests maintenance of a hash table +in the datafile header. There will be a fixed upper limit on the number of +attributes permitted in a single relation (but not on the number of records). +Placing an upper limit on the number of attributes simplifies the software +considerably and permits use of a fixed size header, making it possible to +read or update the entire header in one disk access. There will also be an +upper limit on the number of domains, but the domain list is not searched +very often hence a linear search will do. + +All information about the decomposition of a record into fields, other than +the logical length of vector valued fields, is given by the attribute list. +Records contain only data with no embedded structural information other than +the length of the vector fields. New attributes are added to a relation by +appending to the attribute list. Existing records are not affected. +By comparing the logical length of a record to the offset for a particular +field we can tell whether storage has been allocated for that field in the +record. + +Domains are used to limit the range of values a field can take on in an +assignment, and to flag attribute comparisons which are likely to be erroneous +(e.g. order comparison of a pixel coordinate and a wavelength). The domains +"bool", "char", "short", etc. are predefined. The following information +must be stored for each user defined domain: + + +.ks +.nf + name may be same as attribute name + datatype bool, char, short, etc. + physical vector length 0=variant, 1=scalar, N=vector + default default value, INDEF if not given + minimum mimimum value (ints and reals) + maximum maximum value (ints and reals) + enumval enumerated values (strings) +.fi +.ke + + +The following information is required to describe each attribute. +The attribute list is maintained separately from the hash table of attribute +names and can be used to regenerate the hash table of attribute names if +necessary. + + +.ks +.nf + name no embedded whitespace + domain index into domain table + offset offset in record +.fi +.ke + + +All strings will be stored in a fixed size string buffer in the header +area; it is the index of the string which is stored in the domain and +attribute lists. This eliminates the need to place an upper limit on the +size of domain names and enumerated value lists and makes it possible +for a single attribute name string to be referenced in both the attribute +list and the attribute hash table. + +.nh +Specifications diff --git a/sys/dbio/doc/dbio.hlp b/sys/dbio/doc/dbio.hlp new file mode 100644 index 00000000..4f163415 --- /dev/null +++ b/sys/dbio/doc/dbio.hlp @@ -0,0 +1,413 @@ +.help dbio Oct83 "Database I/O Specifications" +.ce +Specifications of the IRAF DBIO Interface +.ce +Doug Tody +.ce +October 1983 +.ce +(revised November 1983) + +.sh +1. Introduction + + The IRAF database i/o interface (DBIO) shall provide a limited but +highly extensible and efficient database capability for IRAF. DBIO datafiles +will be used in IRAF to implement image headers and to store the output +from analysis programs. The simple structure of a DBIO datafile, and the +self describing nature of the datafile, should make it easy to address the +problems of developing a query language, providing a CL interface, and +transporting datafiles between machines. + +.sh +2. Database Structure: the Data Dictionary + + An IRAF datafile, database file, or "data dictionary" is a set of +records, each of which must have a unique name within the dictionary, +but which may be defined in any time order and stored in the datafile +in any sequential order. Each record in the data dictionary has the +following external attributes: + +.ls 4 +.ls 12 name +The name of the record: an SPP style identifier, not to exceed 28 +characters in length. The name must be unique within the dictionary. +.le +.ls aliases +A record may be known by several names, i.e., several distinct dictionary +entries may actually point to the same physical record. The concept is +similar to the "link" attribute of the UNIX file system. The number +of aliases or links is immediately available, but determination of the +actual names of all the aliases requires a search of the entire dictionary. +.le +.ls datatype +One of the eight primitive datatypes ("bcsilrdx"), or a user defined, +fixed format structure, made up of primitive-type fields. In the case +of a structure, the structure is defined by a C-style structure declaration +given as a char type record elsewhere in the dictionary. The "datatype" +field of a record is one of the strings "b", "c", "s", etc. for the +primitive types, or the name of the record defining the structure. +.le +.ls value +The value of the dictionary entry is stored in the datafile in binary form +and is allocated a fixed amount of storage per record element. +.le +.ls length +Each record in the dictionary is potentially an array. The length field +gives the number of elements of type "datatype" forming the record. +New elements may be added by writing to "record_name[*]". +.le +.le + + +The values of these attributes are available via ordinary DBIO read +requests (but writing is not allowed). Each record in the dictionary +automatically has the following (user accessible) fields associated with it: + + +.ks +.nf + r_type char[28] ("b", "c",.. or record name) + r_nlinks long (initially 1) + r_len long (initially 1) + r_ctime long time of record creation + r_mtime long time of last modify +.fi +.ke + + +Thus, to determine the number of elements in a record, one would make the +following function call: + + nelements = dbgeti (db, "record_name.r_len") + + +.sh +2.1 Records and Fields + + The most complicated reference to an entry in the data dictionary occurs +when a record is structured and both the record and field of the record are +arrays. In such a case, a reference will have the form: + +.nf + "record[i].field[j]" most complex db reference +.fi + +Such a reference defines a unique physical offset in the datafile. +Any DBIO i/o transfer which does not involve an illegal type conversion +may take place at that offset. Normally, however, if the field is an array, +the entire array will be transferred in a single read or write request. +In that case the datafile offset would be specified as follows: + + "record[i].field" + +.sh +3. Basic I/O Procedures + + The basic i/o procedures are patterned after FIO and CLIO, with the +addition of a string type field ("reference") defining the offset in the +datafile at which the transfer is to take place. Sample reference fields +are given in the previous section. In most cases, the reference field +is merely the name of the record or field to be accessed, i.e., "im.ndim", +"im.pixtype", and so on. The "dbset" and "dbstat" procedures are used +to set or inspect DBIO parameters affecting the operation of DBIO itself, +and do not perform i/o on a datafile. + + +.ks +.nf + db = dbopen (file_name, access_mode) + dbclose (db) + + dbset[ils] (db, parameter, value) + val = dbstat[ils] (db, parameter) + + val = dbget[bcsilrdx] (db, reference) + dbput[bcsilrdx] (db, reference, value) + + dbgstr (db, reference, outstr, maxch) + dbpstr (db, reference, string) + + nelems = dbread[csilrdx] (db, reference, buf, maxelems) + dbwrite[csilrdx] (db, reference, buf, nelems) +.fi +.ke + + +A new, empty database is created by opening with access mode NEW_FILE. +The get and put calls are functionally equivalent to those used by +the CL interface, down to the "." syntax used to reference fields. +The read and write calls are complicated by the need to be ignorant +about the actual datatype of a record. Hence we have added a type +suffix, with the implication that automatic type conversion will take +place if reasonable. This also eliminates the need to convert to and +from chars in the fourth argument, and avoids the need for a 7**2 type +conversion matrix. + + +.sh +4. Other DBIO Procedures + + A number of special purpose routines are provided for adding and +deleting dictionary entries, making links to create aliases, searching +a dictionary of unknown content, and so on. The calls are summarized +below: + + +.ks +.nf + stat = dbnextname (db, previous, outstr, maxch) + y/n = dbaccess (db, record_name, datatypes) + + dbenter (db, record_name, type, nreserve) + dblink (db, alias, existing_record) + dbunlink (db, record_name) +.fi +.ke + + +The semantics of these routines are explained in more detail below: + +.ls 4 +.ls 12 dbnextname +Returns the name of the next dictionary entry. If the value of the "previous" +argument is the null string, the name of the first dictionary entry is returned. +EOF is returned when the dictionary has been exhausted. +.le +.ls dbaccess +Returns YES if the named record exists and has one of the indicated datatypes. +The datatype string may consist of any of the following: (1) one or more +primitive type characters specifying the acceptable types, (2) the name of +a structure definition record, or (3) the null string, in which case only +the existence of the record is tested. +.le +.ls dbenter +Used to make a new entry in the dictionary. The "type" field is the name +of one of the primitive datatypes ("b", "c", etc.), or in the case of a +structure, the name of the record defining the structure. The "nreserve" +field specifies the number of elements of storage to be initially allocated +(more elements can always be added later). If nreserve is zero, no storage +is allocated, and a read error will result if an attempt is made to read +the record before it has been written. Storage allocated by dbenter is +initialized to zero. +.le +.ls dblink +Enter an alias for an existing entry. +.le +.ls dbunlink +Remove an alias from the dictionary. When the last link is gone, +the record is physically deleted and storage may be reclaimed. +.le +.le + + +.sh +5. Database Access from the CL + + The self describing nature of a datafile, as well as its relatively +simple structure, will make development of CL callable database query +utilities easy. It shall be possible to access the contents of a datafile +from a CL script almost as easily as one currently accesses the contents +of a parameter file. The main difference is that a separate process must be +spawned to access the database, but this process may contain any number of +database access primitives, and will sit in the CL process cache if frequently +used. The "onexit" call and F_KEEP FIO option in the program interface allow +the query task to keep one or more database files open for quick access, +until the CL disconnects the process. + +The ability to access the contents of a database from a CL script is crucial +if we are to be able to have data independent applications package modules. +The intention is that CL callable applications modules will not be written +for any particular instrument, but will be quite general. At the top level, +however, we would like to have a "canned" program which knows a lot about +an instrument, and which calls the more general package routines, passing +instrument specific parameters. + +This top level routine should be a CL script to provide maximum +flexibility to the scientist using the system at the CL level. Use of a +script is also required if modules from different packages are to be called +from a single high level module (anything else would imply poorly +structured code). +This requires that we be able to store arbitrary information in +image headers, and that this information be available in CL scripts. +DBIO will provide such a capability. + + + In addition to access from CL scripts, we will need interactive access +to datafiles at the CL level. The DBIO interface makes it easy to +provide such an interface. The following functions should be provided: +.ls 4 +.ls o +List the contents of a datafile, much as one would list the contents of +a directory. Thus, there should be a short mode (record name only), and +a long mode (including type, length, nlinks, date of last modify, etc.). +A one name per line mode would be useful for creating lists. Pattern +matching would be useful for selecting subsets. +.le +.ls o +List the contents of a record or list of records. List the elements of +an array, possibly for further processing by the LISTS package. In the +case of a record which is an array of structures, print the values of +selected fields as a table for further processing by the LISTS utilities. +And so on. +.le +.ls o +Edit a record. +.le +.ls o +Delete a record. +.le +.ls o +Copy a record or set of records, possibly between two different datafiles. +.le +.ls o +Copy an array element or range of array elements, possibly between two +different records or two different records in different datafiles. +.le +.ls o +Compress a datafile. DBIO probably will not reclaim storage online. +A separate compress operation will be required to reclaim storage in +heavily edited datafiles, and to consolidate fragmented arrays. +.le +.ls o +And more I'm sure. +.le +.le + +.sh +6. DBIO and Imagefiles + + As noted earlier, DBIO will be used to implement the IRAF image header +structure. An IRAF imagefile is composed of two parts: the image header +structure, and the pixel storage file. Only the name of the pixel storage +file for an image will be kept in the image header; the pixel storage file +is always a separate file, which indeed usually resides on a different +filesystem. The pixel storage file is often far larger than the image +header, though the reverse may be true in the case of small one dimensional +spectra or other small images. The DBIO format image header file is +usually not very large and will normally reside in the user's directory +system. The pixel storage file is created and managed by IMIO transparently +to the user and to DBIO. + + +.ks +.nf + applications program + + + + IMIO + + + + DBIO + + + + FIO + + + Structure of a program which accesses images +.fi +.ke + + +It shall be possible for an single datafile to contain any number of +image header structures. The standard image header shall be implemented +as a regular DBIO structured record, defined in a structure declaration +file in the system library directory "lib$". + +.sh +7. Transportability + + The datafile is a essential part of the IRAF, and it is essential that +we be able to transport datafiles between machines. The self describing +nature of datafiles makes this straightforward, provided programmers do +not store structures in the database in binary. Binary arrays, however, +are fine, since they are completely defined. + +A datafile must be transformed into a machine independent form for transport +between machines. The independence of the records in a datafile, and the simple +structure of a record, should make transmission of a datafile in tabular +form (ASCII card image) straightforward. We shall use the tables extension +to FITS to transport DBIO datafiles. A simple unstructured record can +be represented in the form 'keyword = value' (with some loss of information), +while a structured record can be represented as a FITS table, given the +restriction of the fields of a record to the primitive types. + +.sh +8. Implementation Strategies + + Each data dictionary shall consist of a single random access file, the +"datafile". The dictionary shall be indexed by a B-tree containing the +28 character packed name of each record and a 4 byte integer giving the offset +of either the next block in the B-tree, or of the "inode" structure describing +the record, for a total of 32 bytes per index entry. If a record has several +aliases, each will have a separate entry in the index and all will point to +the same inode structure. The size of a B-tree block shall be variable (but +fixed for a given datafile), and in the case of a typical image header, shall +be chosen large enough so that the index for the entire image header can be +contained in a single B-tree block. The entries within an index block shall +be maintained in sorted order and entries shall be located by a binary search. + +Each physical record or array of records in the datafile shall be described +by a unique binary inode structure. The inode structure shall define the +number of links to the record, the datatype, size, and length of the record, +the dates of creation and last modify, the offset of the record in the +datafile (or the offset of the index block in the case of an array of records), +and so on. The inode structures shall be stored in the datafile as a +contiguous array of records; the inode array may be stored at any offset in +the datafile. Overflow of the inode array will be handled by moving the +array to the end of the file and doubling its size. + +New records shall be added to the datafile by appending to the end of the file. +No attempt shall be made to align records on block boundaries within the +datafile. When a record is deleted space will not be reclaimed, i.e., +deletion will leave an invisible 'hole' in the datafile (a utility will be +available for compacting fragmented datafiles). Array structured records +shall in general be stored noncontiguously in the datafile, though +DBIO will try to avoid excessive fragmentation. The locations of the sections +of a large array of records shall be described by a separately allocated index +block. + +DBIO will probably make use of the IRAF file i/o (FIO) buffer cache feature to +access the datafile. FIO permits both the number and size of the buffers +used to access a file to be set by the caller at file open time. +Furthermore, the FIO "reopen" call can be used to establish independent +buffer caches for the index and inode blocks and for the data records, +so that heavy data array accesses do not flush out the index blocks, even +though both are stored in the same file. Given the sophisticated buffering +capabilities of FIO, DBIO need only make FIO seek and read/write calls to access +both inode and record data, explicitly buffering only the B-tree index block +currently being searched. + +On a virtual machine a single FIO buffer the size of the entire datafile can +be allocated and mapped onto the file, to take advantage of virtual memory +without compromising transportability. DBIO would still use FIO seek, read, +and write calls to access the file, but no FIO buffer faults would occur +unless the file were extended. The current FIO interface does not provide +this feature but it can easily be added in the future without modification +to the FIO interface, if it is proved that there is anything to be gained. + +By carefully configuring the buffer cache for a file, it should be possible +to keep the B-tree index block and inode array for a moderate size datafile +buffered most of the time, limiting the number of disk accesses required to +access a small record to much less than one on the average, without limiting +the ability of DBIO to access very large dictionaries. For example, given +a dictionary of one million entries and a B-tree block size of 128 entries +(4 KB), only 4 disk accesses would be required to access a primitive record +in the worst case (no buffer hits). Very small datafiles, i.e. most image +headers, would be completely buffered all of the time. + +The B-tree index scheme, while very efficient for random record access, +is also well suited to sequential accesses ("dbnextname()" calls). A +straightforward dictionary copy operation using dbnextname, which steps +through the records of a dictionary in alphabetical order, would +automatically transpose the dictionary into the most efficient form for +future alphabetical or clustered accesses, reclaiming storage and +consolidating fragmented arrays in the process. + +The DBIO package, like FIO and IMIO, will dynamically allocate all buffer +space needed to access a datafile at runtime. The number of datafiles +which can be simultaneously accessed by a single program is limited primarily +by the maximum number of open files permitted a process by the OS. diff --git a/sys/dbio/new/coords b/sys/dbio/new/coords new file mode 100644 index 00000000..803ef3c7 --- /dev/null +++ b/sys/dbio/new/coords @@ -0,0 +1,73 @@ +.nh 4 +World Coordinates + + In general, an image may simultaneously have any number of world coordinate +systems associated with it. It would be quite awkward to try to store an +arbitrary number of WCS descriptors in the image header, so a separate WCS +relation is used instead. If world coordinates are not used no overhead is +incurred. + +Maintenance of the WCS descriptor, transformations of the WCS itself (e.g., +when an image changes spatially), and coordinate transformations using the WCS +are all managed by the WCS package. This will be a general purpose package +usable not only in IMIO but also in GIO and other places. IMIO will be +responsible for copying the WCS records for an image when a new image is +created, as well as for correcting the WCS for the effects of subsampling, +etc. when a section of an image is mapped. + +The WCS package will include support for both linear and nonlinear coordinate +systems. Each WCS is described by a mapping from pixel space to WCS space +consisting of a general nonlinear transformation followed by a linear +transformation. Either or both of the transformations may be unitary if +desired, e.g., the simple linear transformation is supported as a special case. +.ls 4 +.ls 12 image +The name (value of the \fIimage\fR key in the image header) of the image +for which the WCS is defined. +.le +.ls nlnterm +A flag specifying whether the WCS includes a nonlinear term. +.le +.ls invterm +A flag specifying whether the WCS includes an inverse nonlinear term. +If a forward nonlinear transformation is defined but no inverse transformation +is given, coordinate transformations from WCS space to pixel space may be +inefficient or impossible. +.le +.ls linterm +A flag specifying whether the WCS includes a linear term. +.le +.ls fwdtran +The interpreter program for the forward nonlinear transformation. +.le +.ls invtran +The interpreter program for the inverse nonlinear transformation. +.le +.ls lintran +A floating point array describing the linear transformation. +.le +.le + + +Nonlinear transformations are described by small user supplied \fIprograms\fR +written in a simple RPN language entered as a variable length character string. +The RPN language will include builtin intrinsic functions for all the standard +trigonometric and hyperbolic functions, plus builtin functions for the common +nonlinear transformations as well. The advantage of this scheme is that the +standard transformations are supported very efficiently without sacrificing +generality. Even nonstandard nonlinear functions can be computed quite +efficiently since the runtime overhead of an RPN interpreter can be made quite +small compared to the time required to evaluate the trigonometric and other +functions typically used in a nonlinear function. + +Implementation of the WCS as a nonlinear function plus a linear function +makes it trivial for IMIO to automatically update the WCS when a linear +transformation is applied to the image (the nonlinear term of the WCS will +not be affected by a linear transformation of the image). +Implementation of the nonlinear term as a program encoded as a character +string permits modification of the nonlinear term by \fIconcatentation\fR +of another nonlinear function, also represented as a character string. +In other words, the final mapping is given by successive application of +a series of nonlinear transformations, followed by the linear transformation. +Hence the WCS may be updated to reflect a subsequent linear or nonlinear +transformation of the image, regardless of the nature of the original WCS. diff --git a/sys/dbio/new/dbio.con b/sys/dbio/new/dbio.con new file mode 100644 index 00000000..9adc7d6c --- /dev/null +++ b/sys/dbio/new/dbio.con @@ -0,0 +1,202 @@ + IRAF Database I/O Design + Contents + + + +1. PREFACE + + 1.1 Scope of this Document + 1.2 Relationship to Previous Documents + + +2. INTRODUCTION + + 2.1 The Database Subsystem + 2.2 Major Subsystems + 2.3 Related Subsystems + + +3. REQUIREMENTS + + 3.1 General Requirements + 3.1.1 Portability + 3.1.2 Efficiency + 3.1.3 Code Size + 3.1.4 Use of Proprietary Software + + 3.2 Special Requirements + 3.2.1 Catalog Storage + 3.2.2 Image Storage + 3.2.3 Intermodule Communication + 3.2.4 Data Archiving + + 3.3 Other Requirements + 3.3.1 Concurrency + 3.3.2 Recovery + 3.3.3 Data Independence + 3.3.4 Host Database Interface + + +4. CONCEPTUAL DESIGN + + 4.1 Terminology + 4.2 System Architecture + + 4.3 The DBMS Package + 4.3.1 Overview + 4.3.2 Procedural Interface + 4.3.2.1 General Operators + 4.3.2.2 Form Based Data Entry and Retrieval + 4.3.2.3 List Interface + 4.3.2.4 FITS Table Interface + 4.3.2.5 Graphics Interface + 4.3.3 Command Language Interface + 4.3.4 Record Selection Syntax + 4.3.5 Query Language + 4.3.5.1 Query Language Functions + 4.3.5.2 Language Syntax + 4.3.5.3 Sample Queries + 4.3.6 DB Kernel Operators + 4.3.6.1 Dataset Copy and Load + 4.3.6.2 Rebuild Dataset + 4.3.6.3 Mount Foreign Dataset + 4.3.6.4 Crash Recovery + + 4.4 The IMIO Interface + 4.4.1 Overview + 4.4.2 Logical Schema + 4.4.2.1 Standard Fields + 4.4.2.2 History Text + 4.4.2.3 World Coordinates + 4.4.2.4 Histogram + 4.4.2.5 Bad Pixel List + 4.4.2.6 Region Mask + 4.4.3 Group Data + 4.4.4 Image I/O + 4.4.4.1 Image Templates + 4.4.4.2 Image Pixel Access + 4.4.4.3 Image Database Interface (IDBI) + 4.4.5 Summary of IMIO Data Structures + + 4.5 The DBIO Interface + 4.5.1 Overview + 4.5.2 Comparison of DBIO and Commercial Databases + 4.5.3 Query Language Interface + 4.5.4 Logical Schema + 4.5.4.1 Databases + 4.5.4.2 System Tables + 4.5.4.3 The System Catalog + 4.5.4.4 Relations + 4.5.4.5 Attributes + 4.5.4.6 Domains + 4.5.4.7 Groups + 4.5.4.8 Views + 4.5.4.9 Null Values + 4.5.5 Data Definition Language + 4.5.6 Record Select/Project Expressions + 4.5.6.1 Introduction + 4.5.6.2 Basic Syntax + 4.5.6.3 Examples + 4.5.6.4 Evaluation + 4.5.7 Operators + 4.5.7.1 General Operators + 4.5.7.2 Record Level Access + 4.5.7.3 Field Level Access + 4.5.7.4 Variable Length Fields + 4.5.7.5 IMIO Support + 4.5.8 Constructing Special Relational Operators + 4.5.9 Storage Structures + + 4.6 The DBKI Interface (DB Kernel Interface) + 4.6.1 Overview + 4.6.1.1 Default Kernel + 4.6.1.2 Host Database Interface + 4.6.1.3 Network Support + 4.6.2 Logical Schema + 4.6.2.1 System Tables + 4.6.2.2 User Tables + 4.6.2.3 Indexes + 4.6.2.4 Record Structure + 4.6.2 Database Management Operators + 4.6.2.1 Database Creation and Deletion + 4.6.2.2 Database Access + 4.6.2.3 Table Creation and Deletion + 4.6.2.4 Index Creation and Deletion + 4.6.3 Record Access Methods + 4.6.3.1 Direct Access via an Index + 4.6.3.2 Direct Access via the Record ID + 4.6.3.3 Sequential Access + 4.6.4 Record Access Operators + 4.6.4.1 Fetch + 4.6.4.2 Update + 4.6.4.3 Insert + 4.6.4.4 Delete + 4.6.4.5 Variable Length Fields + + 4.7 The DBK (IRAF DB Kernel) + 4.7.1 Overview + 4.7.2 Storage Structures + 4.7.2.1 Database + 4.7.2.2 System Catalog + 4.7.2.3 Table Storage + 4.7.3 The Control Interval + 4.7.3.1 Introduction + 4.7.3.2 Shared Intervals + 4.7.3.3 Private Intervals + 4.7.3.4 Record Insertion and Update + 4.7.3.5 Record Deletion + 4.7.3.6 Adding New Fields + 4.7.3.7 Array Storage + 4.7.3.8 Rebuilding a Dataset + 4.7.4 Indexes + 4.7.4.1 Nonindexed Tables + 4.7.4.2 Primary Index + 4.7.4.3 Secondary Indexes + 4.7.4.4 Key Compression + 4.7.5 Host Database Interface (HDBI) + 4.7.6 Concurrency + 4.7.7 Backup and Transport + 4.7.8 Accounting Services + 4.7.9 Crash Recovery + + +5. SPECIFICATIONS + + 5.1 DBMS Package + 5.1.1 Overview + 5.1.2 Module Specifications + + 5.2 IMIO Interface + 5.2.1 Overview + 5.2.2 Examples + 5.2.3 Module Specifications + 5.2.3.1 Image Header Access + 5.2.3.2 History Text + 5.2.3.3 World Coordinates + 5.2.3.4 Bad Pixel List + 5.2.3.5 Region Mask + 5.2.3.6 Pixel Access + 5.2.4 Storage Structures + 5.2.4.1 IRAF Runtime Format + 5.2.4.2 Archival Format + 5.2.4.3 Other Formats + + 5.3 DBIO (DataBase I/O interface) + 5.3.1 Overview + 5.3.2 Examples + 5.3.3 Module Specifications + + 5.4 DBKI (DB Kernel Interface) + 5.4.1 Overview + 5.4.3 Module Specifications + + 5.5. DBK (IRAF DB Kernel) + 5.5.1 Overview + 5.5.2 Storage Structures + 5.5.3 Error Recovery + 5.5.4 Concurrency + +6. SUMMARY + +Glossary +Index diff --git a/sys/dbio/new/dbio.hlp b/sys/dbio/new/dbio.hlp new file mode 100644 index 00000000..d5d9c77f --- /dev/null +++ b/sys/dbio/new/dbio.hlp @@ -0,0 +1,3202 @@ +.help dbss Sep85 "Design of the IRAF Database Subsystem" +.ce +\fBDesign of the IRAF Database Subsystem\fR +.ce +Doug Tody +.ce +September 1985 +.sp 2 + +.nh +Preface + + The primary purpose of this document is to define the interfaces comprising +the IRAF database i/o subsystem to the point where they can be built rapidly +and efficiently, with confidence that major changes will not be required after +implementation begins. The document also serves to inform all interested +parties of what is planned while there is still time to change the design. +A change which can easily be made to the design prior to implementation may +become prohibitively expensive as implementation proceeds. After implementation +is completed and the new subsystem has been in use for several months the basic +interfaces will be frozen and the opportunity for change will have passed. + +The description of the database subsystem presented in this document should +be considered to be no more than a close approximation to the system which +will actually be built. The specifications of the interface can be expected +to change in detail as the implementation proceeds. Any code which is written +according to the interface specifications presented in this document may have +to modified slightly before system testing with the final interfaces can +proceed. + +.nh 2 +Scope of this Document + + The scope of this document is the conceptual design and specification of +all IRAF packages and i/o interfaces directly involved with either user or +program access to binary data maintained in mass storage. Versions of some +of the interfaces described are already in use; when this is the case it will +be noted in the text. + +This document is neither a user's guide nor a reference manual. The reader +is assumed to be familiar with both database technology and with the IRAF +system. In particular, the reader should be familiar with the concept of the +IRAF VOS (virtual operating system), with the features of the IMIO (image i/o), +FIO (file i/o), and OS (host system interface) interfaces, as well as with the +architecture of the network interface. + +.nh 2 +Relationship to Previous Documents + + This document supercedes the document "IRAF Database I/O", November 1984. +Most of the concepts presented in that document are still valid but have been +expanded upon greatly in the present document. The scope of the original +document was limited to the DBIO interface alone, whereas the scope of the +present document has been expanded to encompass all subsystems or packages +directly involved with binary data access. This expansion in the scope of +the project was necessary to meet our primary goal of completing and freezing +the program interface, of which DBIO is only a small part. Furthermore, it +is difficult to have confidence in the design of a single subsystem without +working out the details of all closely related or dependent subsystems. + +In addition to expanding the scope of the database design project to cover +more interfaces, the requirements which the database subsystem must meet have +been expanded since the original conceptual design was done. In particular +it has become clear that data format conversions are prohibitively expensive +for our increasingly large datasets. Conversions such as those between FITS +and internal format (for an image), or between FITS table and internal format +(for a database) are too expensive to be performed routinely. Data which is +archived in a machine independent format should not have to be reformatted +to be accessed by the online system. The archival format may vary from site +to site and it should be possible to read the different formats without +reformatting the data. Large datasets should not have to be reformatted to +be moved between machines with incompatible binary data formats. + +A change such as this in the requirements for an interface can have a major +impact on the design of the final interface. It is essential that all such +requirements be identified and dealt with in the design before implementation +begins. + +.nh +Introduction + + In this section we introduce the database subsystem and summarize the +reasons why we need such a system. We then introduce the major components +of the database subsystem and briefly mention some related subsystems. + +.nh 2 +The Database Subsystem + + The database subsystem (DBSS) is conceived as a single comprehensive system +to be used to manage and access all binary (non textfile) data accessed by IRAF +programs. Simple applications are perhaps most easily and flexibly dealt with +using text files for the storage of data, descriptors, and control information. +As the amount of data to be processed grows or as the data structures to be +accessed grow in complexity, however, the text file approach becomes seriously +inefficient and cumbersome. Converting the text files to binary files makes +processing more efficient but does little to address the problems of complex +data structures. Efficient access to complex data structures requires complex +and expensive software. Developing such software specially for each and every +application is prohibitively expensive in a large system; hence the need for +a general purpose database system becomes clear. + +Use of a single central database system has significant additional advantages. +A standard user interface can be used to examine, edit, list, copy, etc., all +data maintained under the database system. Many technical problems may be +addressed in a general purpose system that would be too expensive to address +in a particular application, e.g., the problems of storing variable size data +elements, of dynamically and randomly updating a dataset, of byte packing to +conserve storage, of maintaining indexes so that a record may be found +efficiently in a large dataset, of providing data independence so that storage +formats may be changed without need to change the program accessing the data, +and of transport of binary datasets between incompatible machines. All of +these are examples of problems which are \fInot\fR adequately addressed by the +current IRAF i/o interfaces nor by the applications programs which use them. + +.nh 2 +Major Subsystems + + The major subsystems comprising the IRAF DBSS are depicted in Figure 1. +At the highest level are the CL (command language) packages, each of which +consists of a set of user callable tasks. The IMAGES package (consisting +of general image processing operators) is shown for completeness but since +there are many such packages in the system they are not considered part of +the DBSS and will not be discussed further here. +The DBMS (database management) package is the user interface to the DBSS, +and some day will possibly be the largest part of the DBSS in terms of number +of lines of code. + +In the center of the figure we see the VOS (virtual operating system) packages +IMIO, DBIO and FIO. FIO (file i/o) is the standard IRAF file interface and +will not be discussed further here. IMIO (image i/o) and DBIO (database i/o) +are the two major i/o interfaces in the DBSS and are the topic of much of the +rest of this document. IMIO and DBIO are the two parts of the DBSS of interest +to applications programmers; these interfaces are implemented as libraries of +subroutines to be called directly by the applications program. IMIO and FIO +are existing interfaces. + +At the bottom of the figure is the DB Kernel. The DB Kernel is the component +of the DBSS which physically accesses the data in mass storage (via FIO). +The DB Kernel is called only by DBIO and hence is invisible to both the user +and the applications programmer. There is a lot more to the DB Kernel than +is evident from the figure, and indeed the DB Kernel will be the subject of +another figure when we discuss the system architecture in section 4.2. + + +.ks +.nf + DBMS IMAGES(etc) (CL) + \ / + \ / --------- + \ / + \ IMIO + \ / \ + \ / \ + \/ \ (VOS) + DBIO FIO + | + | + | --------- + | + | + (DB Kernel) (VOS or Host System) + +.fi +.ce +Figure 1. Major Components of the Database Subsystem +.ke + + +With the exception of certain optional subsystems to be outlined later, +the entire DBSS is machine independent and portable. The IRAF system may +be ported to a new machine without any knowledge whatsoever of the +architecture or functioning of the DBSS. + +.nh 2 +Related Subsystems + + Several additional IRAF subsystems or packages are of interest from the +standpoint of the DBSS. These are the PLOT package, the graphics interface +GIO, and the LISTS package. + +The PLOT package is a CL level package consisting of general plotting +utilities. In general PLOT tasks can accept input in a number of standard +formats, e.g., \fBlist\fR (text file) format and \fBimagefile\fR format. +The DBSS will provide an additional standard format which should perhaps be +directly accessible by the PLOT tasks. Even if this is not done a very +general plotting capability will automatically be provided by "piping" the +list format output of a DBMS task to a PLOT task. Additional graphics +capabilities will be provided as built in functions in the DBMS +\fBquery language\fR, which will access GIO directly to make plots. +The query language graphics facilities will be faster and more convenient +to use but less extensive and less sophisticated than those provided by PLOT. + +The LISTS package is interesting because the facilities provided and operations +performed resemble those provided by the DBMS package in many respects. +The principle difference between the two packages is that the LISTS package +operates on arbitrary text files whereas the DBMS package operates only +upon DBIO format binary files. The textual output of \fIany\fR IRAF or +non-IRAF program may serve as input to a LISTS operator, as may any ordinary +text file, e.g., the source files for a program or package. A typical LISTS +database is a directory full of source files or documentation; LISTS can also +operate on tables of numbers but the former application is perhaps more +common. Using LISTS it is possible to conveniently and rapidly perform +operations (evaluate queries) which would be cumbersome or impossible to +perform with a conventional database system such as DBMS. On the other hand, +the LISTS operators would be hopelessly inefficient for the types of +applications for which DBMS is designed. + +.nh +Requirements + + Requirements define the problem to be solved by a software system. +There are two types of requirements, non-functional requirements, i.e., +restrictions or constraints, and functional requirements, i.e., the functions +which the system must perform. Since nearly all IRAF science software will +be heavily dependent on the DBSS, the requirements for this subsystem are as +strict as those for any subsystem in IRAF. + +.nh 2 +General Requirements + + The general requirements which the DBSS must satisfy primarily take the +form of constraints or restrictions. These requirements are common to +all mainline IRAF system software. Note that these requirements are \fInot\fR +automatically enforced for all system software. If a particular subsystem is +prototype or optional (not required for the normal functioning of IRAF) then +these requirements can be relaxed. In particular, certain parts of the DBSS +(e.g, the host database interface) are optional and are not subject +to the same constraints as the mainline software. The primary functional +requirements discussed in section 3.2, however, must be met by software which +satisfies all of the general requirements discussed here. + +.nh 3 +Portability + + All software in the DBMS, IMIO, and DBIO interfaces and in the DB kernel +must be fully portable under IRAF. To meet this requirement the software +must be written in the IRAF SPP language using only the facilities provided +by the IRAF VOS. In particular, this rules out complicated record locking +schemes in the DB kernel, as well as any type of centralized database server +which relies on process control, IPC, or signal handling facilities not +provided by the IRAF VOS. For most processes the requirement is even more +strict, i.e., ordinary IRAF processes are not permitted to rely upon the VOS +process control or IPC facilities for their normal functioning (the IPC +connection to the CL is an exception since it is not required to run an +IRAF process standalone). + +.nh 3 +Efficiency + + The database interface must be efficient, particularly when used for +image access and intermodule communication. There are as many ways to +measure the efficiency of an interface as there are applications for the +interface, and we cannot address them all here. The dimensions of the +efficiency matrix we are concerned with here are the cpu time consumed +during execution, the clock time consumed during execution, e.g, the number +of file opens and disk seeks or required, and the disk space consumed for +table storage. Where necessary efficient cpu utilization will be achieved +at the expense of memory requirements for code and buffers. + +A simple and well defined efficiency requirement is that the cpu and clock +time required to access the pixels of an image stored in the database from +a "cold start" (no open files) must not noticeably exceed that required +by the old IMIO interface. The efficiency of the new interface for the +case when many images are to be accessed is expected to be a major improvement +over that provided by the old IMIO interface, since the old interface +stores each image in two separate files, whereas the new interface will +be capable of storing the entire contents of many (small) images in a single +file. The amount of disk space required for image header storage is also +expected to decrease by a large factor when multiple images are stored +in a single physical file. + +.nh 3 +Code Size + + We have already established that a process must directly access the +database in mass storage to meet our portability and efficiency requirements. +This type of access requires that the necessary IMIO, DBIO and DB Kernel +routines be linked into each process requiring database access. Minimizing +the amount of text space used by the database code is desirable to minimize +disk and memory requirements and process spawn time, but is not critical +since memory is cheap and plentiful and is likely to become even cheaper +and more plentiful in the future. Furthermore, the multitask nature of +IRAF processes allows the text segment used by the database code to be shared +by many tasks, saving both disk and memory. + +The main problem remaining today with large text segments seems to be the +process spawn time; loading the text segment by demand paging in a virtual +memory environment can be quite slow. The fault here seems to lie more with +the operating system than with IRAF, and probably the solution will require +tuning either the IRAF system interface or the operating system itself. + +Taking all these factors into account it would seem that typical memory +requirements for the executable database code (not including data buffers) +in the range 50 to 100 Kb would be acceptable, with 50 Kb being a reasonable +goal. This would make the database interface the largest i/o interface in +IRAF but that seems inevitable considering the complexity of the problem to +be solved. + +.nh 3 +Use of Proprietary Software + + A mainline IRAF interface, i.e., any interface required for the normal +operation of the system, must belong to IRAF and must be distributed with +the IRAF system at no additional charge and with no licensing restrictions. +The source code must be part of the system and is subject to strict +configuration control by the IRAF group, i.e., the IRAF group is responsible +for the software and must control it. This rules out the use of a commercial +database system for any essential part of the DBSS, but does not rule out +IRAF access to a commercial database system provided such access is optional, +i.e., not required for the operation of the standard applications packages. +The host database interface provided by the DB kernel is an example of such +an interface. + +.nh 2 +Special Requirements + + In this section we present the functional requirements of the DBSS. +The major applications for which the DBSS in intended are described and +the desirable characteristics of the DBSS for each application are outlined. +The major applications thus far identified are catalog storage, image storage, +intermodule communication, and data archiving. + +.nh 3 +Catalog Storage + + The catalog storage application is probably the closest thing in IRAF to a +conventional database application. A catalog is a set of records, each of +which describes a single object. Each record consists of a set of fields +of various datatypes describing the attributes of the object. A record is +produced by numerical analysis of the object represented as a region of a +digital array. All records have the same structure, i.e., set of fields; +often the records are all the same size (but not necessarily). A large catalog +might contain several hundred thousand records. Examples of such catalogs are +the SAO star catalog, the IRAS point source catalog, and the catalogs produced +by analysis programs such as FOCAS (a faint object detection and classification +program) and RICHFLD (a digital stellar photometry program). Many similar +examples can be identified. + +Generation of such a catalog by an analysis program is typically a cpu bound +batch operation requiring many hours of computer time for a large catalog. +Once the catalog has been generated there are typically numerous questions of +scientific interest which can be answered using the data in the catalog. +It is highly desirable that this phase of the analysis be interactive and +spontaneous, as one question will often lead to another in an unpredictable +fashion. A general purpose analysis capability is required which will permit +the scientist to pose arbitrary queries of arbitrary complexity, to be answered +by the system in a few seconds (or minutes for large problems), with the answer +taking the form of a number or name, set or table of numbers or names, plot, +subcatalog, etc. + +Examples of such queries are given below. Clearly, the set of all possible +queries of this type is infinite, even assuming a limited number of operators +operating on a single catalog. The set of potentially interesting queries +is equally large. +.ls 4 +.ls [1] +Find all objects of type "pqr" for which X is in the range A to B and +Z is less than 10. +.le +.ls [2] +Compute the mean and standard deviation of attribute X for all objects +in the set [1]. +.le +.ls [3] +Compute and plot (X-Y) for all objects in set [1]. +.le +.ls [4] +Plot a circle of size (log2(Z-3.2) * 100) at the position (X,Y) of all objects +in set [1]. +.le +.ls [5] +Print the values of the attributes OBJ, X, Y, and Z of all objects for which +X is in the range A to B and Y is greater than 30. +.le +.le + + +In the past queries such as these have all too often been answered by writing +a program to answer each query, or worse, by wading though a listing of the +program output and manually computing the result or manually plotting points +on a graph. + +Given the preceding description of the catalog storage application, we can +make the following observations about the application of the DBSS to catalog +storage. +.ls +.ls o +A catalog is typically written once and then read many times. +.le +.ls o +Both public and private catalogs are common. +.le +.ls o +Catalog records are infrequently updated or are not updated at all once the +original entry has been made in the catalog. +.le +.ls o +Catalog records are rarely if ever deleted. +.le +.ls o +Catalogs can be very large, making efficient storage structures important +in order to minimize disk storage requirements. +.le +.ls o +Since catalogs can be very large, indexing facilities are required for +efficient record retrieval and for the efficient evaluation of queries. +.le +.ls o +A general purpose interactive query capability is required for the user to +effectively make use of the data in a catalog. +.le +.le + + +In DBSS terminology a user catalog will often be referred to as a \fBtable\fR +to avoid confusion with the use of the DBSS term \fBcatalog\fR which refers +to the system table which lists the contents of a database. + +.nh 3 +Image Storage + + A primary requirement for the DBSS, if not \fIthe\fR primary requirement, +is that the DBSS be suitable for the storage of bulk data or \fBimages\fR. +An image consists of two parts: an \fIimage header\fR describing the image, +and a multidimensional array of \fBpixels\fR. The pixel array is sometimes +small and sometimes very large indeed. For efficiency and other reasons the +actual pixel array is not required to be stored in the database. Even if the +pixels are stored directly in the database they are not expected to be used +in queries. + +We can make the following observations about the use of the DBSS for image +storage. The reader concerned about how all this might map into the storage +structures provided by a relational database should assume that the image +header is stored as a single large, variable size record (tuple), whereas +a group of images is stored as one or more tables (relations). If the images +are large assume the pixels are be stored outside the DBSS in a file, storing +only the name of the file in the header record. +.ls +.ls o +Images tend to be grouped into sets that have some logical meaning to the user, +e.g., "nite1", "nite2", "raw", "reduced", etc. Each group typically contains +dozens or hundreds of images (enough to require use of an index for efficient +retrieval). +.le +.ls o +Within a group the individual images are often referred to by a unique ordinal +number which is automatically assigned by some program (e.g., "nite1.10", +"nite1.11", etc). +.le +.ls o +Image databases tend to be private databases, created and accessed by a +single user. +.le +.ls o +The size of the pixel segment of an image varies enormously, e.g., from +1 kilobyte to 8 megabytes, even 40 megabytes in some cases. +.le +.ls o +Small pixel segments are most efficiently stored directly in the image header +to minimize the number of file opens and disk seeks required to access the +pixels once the header has been accessed (as well as to minimize file clutter). +.le +.ls o +Large pixel segments are most efficiently stored separately from the image +headers to increase clustering and speed sequential searches of a group of +headers. +.le +.ls o +It is occasionally desirable to store either the image header or the pixel +segment on a special, non file-structured device. +.le +.ls o +The image header logically consists of a closed set of standard attributes +common to all images, plus an open set of attributes peculiar to the data +or to the type of analysis being performed on the data. +.le +.ls o +The operations performed on images are often functions which produce a +modified version of the input image(s) as a new output image. It is desirable +for most header information to be automatically preserved in such a mapping. +For this to happen automatically without the DBSS requiring knowledge of +the contents of a header, it is necessary that the header be a single object +to the DBSS, i.e., a single record in some table, rather than a set of +related records in several tables. +.le +.ls o +Since the image header needs to be maintained as a single record and since +the header may contain an unpredictable number of application or data specific +attributes, image headers can be quite large. +.le +.ls o +Not all image header attributes are simple scalar values or even fixed size +arrays. Variable size attributes, i.e., arrays, are common in image headers. +Examples of such attributes are the bad pixel list, history text, and world +coordinate system (more on this in a later section). +.le +.ls o +Image header attributes often form logical groupings, e.g., several logically +related attributes may be required to define the bad pixel list or the world +coordinate system. +.le +.ls o +The image header structure is often dynamically updated and may change in +size when updated. +.le +.ls o +It is often necessary to add new attributes to an existing image header. +.le +.ls o +Images are often selectively deleted. Any subordinate files logically +associated with the image should be automatically deleted when the image +header is deleted. If this is not possible under the DBSS then the DBSS +should forbid deletion of the image header unless special action is taken +to remove delete protection. +.le +.ls o +For historical or other reasons, a given site will often maintain images +in several different and completely incompatible formats. It is desirable +for the DBSS to be capable of directly accessing images maintained in a foreign +format without a format conversion, even if only limited (e.g., read only) +access is possible. +.le +.le + + +In summary, images are characterized by a header with a highly variable set +of fields, some of which may vary in size during the lifetime of the image. +New fields may be added to the image header at any time. Array valued fields +are common and fields tend to form logical groupings. The image header is +best maintained as a single structure under the DBSS. Image headers can be +quite large. The pixel segment of an image can be extremely large and may +be best maintained outside the DBSS. Since many existing image archives exist, +each with its own unique format, it is desirable for the DBSS to be capable +of accessing multiple storage formats. + +Storage of the pixel segment or any other portion of an image in a separate +file outside the DBSS causes problems which must be dealt with at some level +in the system, if not by the DBSS. In particular, problems occur if the user +tries to backup, restore, copy, rename, or delete any portion of an image using +a host system utility. These problems are minimized if all logically related +data is kept in a single data directory, allowing the database as a whole to +be moved or backed up with host system utilities. All pathnames should be +defined relative to the data directory to permit relocation of the database +to a different directory. Ideally all binary datafiles in the database should +be maintained in a machine independent format to permit movement of the +database between different machines without reformatting the entire database. + +.nh 3 +Intermodule Communication + + A large applications package consists of many separate tasks or programs. +These tasks are best defined and understood in terms of their operation on a +central package database. For example, one task might fit some function to +an image, leaving a record describing the fit in the database. A second task +might take this record as input and use it to control a transformation on +the original image. Additional operators implementing a range of algorithms +or optimized for a discrete set of cases are easily added, each relying upon +the central database for intermodule communication. + +This application of the DBSS is a fairly conventional database application +except that array valued attributes and logical groupings of attributes are +common. For example, assume that a polynomial has been fitted to a data +vector and we wish to record the fit in the database. A typical set of +attributes describing a polynomial fit are shown below. + + +.ks +.nf + image_name char*30 # name of source image + nfeatures int # number of features fitted + features.x real*4[*] # x values of the features + features.y real*4[*] # y values of the features + curve.type char*10 # curve type + curve.ncoeff int # number of coefficients + curve.coeff real*4[*] # coefficients +.fi +.ke + + +The data structure shown records the positions (X) and world coordinates (Y) +of the data features to which the curve was fitted, plus the coefficients of +the fitted curve itself. There is no way of predicting the number of features +hence the X and Y arrays are variable length. Since the fitted curve might +be a spline or some other piecewise function rather than a simple polynomial, +there is likewise no reasonable way to place an upper limit on the amount of +storage required to store the fitted curve. This type of record is common in +scientific applications. + +We can now make the following observations regarding the use of the DBSS for +intermodule communication. +.ls +.ls o +The number of fields in a record tends to be small, but array valued fields +of variable size are common hence the physical size of a record may be large. +.le +.ls o +A large table might contain several hundred records in typical applications, +requiring the use of an index for efficient retrieval. +.le +.ls o +Record access is usually random rather than sequential. +.le +.ls o +Random record updates will be rare in some applications, but common in others. +.le +.ls o +Records will often change in size when updated. +.le +.ls o +Selective record deletion is rare, occurring mostly during cleanup following +an error. +.le +.ls o +New fields are rarely, if ever, added to existing records. The record structure +is usually determined by the programmer rather than by the user and tends to +be well defined. +.le +.ls o +This type of database is typically a private database created and used by a +single user to process a specific dataset with a specific applications package. +.le +.le + + +Application specific information may sometimes be stored directly in the header +of the image being analyzed, but more often will be stored in one or more +separate tables, recording the name of the image analyzed in the new record +as a backpointer, as in the example. Hence a typical scientific database +might consist of several tables containing the input images, several tables +containing intermodule records of various types, and one or more tables +containing either reduced images or catalog records, depending on whether a +reduction or analysis operation was performed. + +.nh 3 +Data Archiving + + Data archiving refers to the long term storage of raw or reduced data. +Data archiving is important for the following reasons. +.ls +.ls o +Archiving is currently necessary just to \fItransport\fR data from the +telescope to the site where reduction and analysis takes place. +.le +.ls o +Permanently archiving the raw (or pre-reduced) data is necessary in case +an error in the reduction process is later discovered, making it necessary +for the observer to repeat the reductions. +.le +.ls o +Archiving of the reduced data is desirable to save computer and human time +in case the analysis phase has to be repeated, or in case additional analysis +is later discovered to be necessary. +.le +.ls o +Archived data could conceivably be of considerable value to future researchers +who, given access to such data, might not have to make observations of their +own, or who might be able to use the archived data to augment or plan their +own observations. +.le +.ls o +Archived data could be invaluable for future projects studying the variability +of an object or objects over a period of years. +.le +.le + + +Ideally data should be archived as it is taken at the telescope, possibly +performing some simple pipeline reductions before archiving takes place. +Subsequent reduction and analysis using the archived data should be possible +without the format conversion (e.g., FITS to IRAF) currently required. +This conversion wastes cpu time and disk space as well as user time. +The problem is already serious and is expected to grow by an order of +magnitude in the next several years as digital detectors grow in size and +are used more frequently. + +Archival data consists of the digital data itself (the pixels) plus information +describing the object, the observer, how the data was taken, when and where +the data was taken, and so on. This is just the type of information assumed +to be present in an IRAF image. In addition one would expect the archive to +contain one or more \fBmaster catalogs\fR containing exhaustive information +describing the observations but no data. + +Since a permanent digital data archive can be expected to be around for many +years and to be read on many types of machines, data images should be archived +in a machine independent format; this format would almost certainly be FITS. +It is also desirable, though not essential, that the master catalogs be +readable on a variety of machines and hence be maintained and distributed in +a machine independent format. The ideal storage medium for archiving and +transporting large amounts of digital data appears to be the optical disk. + +Archival data and catalog access via the DBSS differs from conventional image +and catalog access only in the storage format, which is assumed to be machine +independent, and in the storage medium, which is assumed to be an archival +medium such as the optical disk. Direct access to a database on optical +disk requires that the DBSS be able to read the machine independent format +directly. + +To achieve acceptable performance for direct access it is necessary that +the storage medium be randomly accessible (unlike, say, a magnetic or optical +tape) and that the hardware seek time and transfer rate be comparable to those +provided by magnetic disk technology. Note that current optical disk readers +often do not have fast seek times, and that those that do have fast seek times +generally have a lower storage density than sequential devices due to the gaps +between sectors. Even if a device is not fast enough to be used directly it +is still possible to eliminate the expensive format conversion and do only a +disk to disk copy, accessing the machine independent format on magnetic disk. + +There is no requirement that the IRAF DBSS be used to support data archiving, +but the DBSS \fIis\fR required to be able to access the data in an archive. +Accessing the master catalogs as well seems reasonable since such a catalog +is no different than those described in sections 3.2.1. and 3.2.3; IRAF will +have the capability to maintain, access, and query such a catalog without +developing any additional software. + +The main obstacle likely to limit the success of data archiving may well be +the difficulty involved in gaining access to the archive. If the master +catalogs were maintained on magnetic disk but released periodically in +optical disk format for astronomers to refer to at their home institutions, +access would be much easier (and probably more frequent) than if all the +astronomers in the country were required to access a single distant computer +via modem. Telephone access by sites not on the continent would probably +be too expensive or problematic to be feasible. + +.nh 2 +Other Requirements + + In earlier sections we have discussed the principle constraints and +primary requirements for the DBSS. Several other requirements or +non-requirements deserve mention. + +.nh 3 +Concurrency + + All of the applications identified thus far require either read-only access +to a public database or read-write access to a private database. +The DBSS is therefore not required to support simultaneous updating by many +users of a single centralized database, with all the overhead and complication +associated with record locking, deadlock avoidance and detection, and so on. +The only exception occurs when a single user has several concurrent processes +requiring simultaneous update access to the user's private database. It appears +that this case can be addressed adequately by distributing the database in +several datasets and using host system file locking to lock the datasets, +a technique discussed further in a later section. + +.nh 3 +Recovery + + If a database update is aborted for some reason a dataset can be corrupted, +possibly preventing further access to the dataset. The DBSS should of course +protect datasets from corruption in normal circumstances, but it is always +possible for a hardware or software error (e.g., disk overflow or reboot) to +cause a dataset to be corrupted. Some mechanism is required for recovering a +database that has been corrupted. The minimum requirement is that the DBSS, +when asked to access a corrupted dataset, detect that the dataset has been +corrupted and abort, after which the user runs a recovery task to rebuild the +dataset minus the corrupted records. + +.nh 3 +Data Independence + + Data independence is a fundamental property inherent in virtually all +database systems. One of the major reasons one uses a database system is to +provide data independence. Data independence is so fundamental that we will +not discuss it further here. Suffice it so say that the DBSS must provide +a high degree of data independence, allowing applications programs to function +without detailed knowledge of the structure or contents of the database they +are accessing, and allowing databases to change significantly without +affecting the programs which access them. + +.nh 3 +Host Database Interface + + The host database interface (HDBI) makes it possible for the DBSS to +interface to a host database system. The ability to interface to a host +database system is not a primary requirement for the DBSS but is a highly +desirable one for many of the same reasons that direct access to archival data +is important. The problems of accessing a HDB and of accessing an archive +maintained in non-DBSS format are similar and might perhaps be addressed +by a single interface. + +.nh +Conceptual Design + + In this section we develop the design of the various subsystems comprising +the DBSS at the conceptual level, without bothering with the details of specific +language bindings or with the details of implementation. We start by defining +some important terms and then describe the system architecture. Lastly we +describe each of the major subsystems in turn, starting at the highest level +and working down. + +.nh 2 +Terminology + + The DBSS is an implementation of a \fBrelational database\fR. A relational +database views data as a collection of \fBtables\fR. Each table has a fixed +set of named columns and may contain any number of rows of data. The rows +of a table are often referred to as \fBrecords\fR. A record consists of a set +of named \fBfields\fR. The fields of a record are the columns of the table +containing the record. + +We shall use this informal terminology when discussing the contents of a +physical database. When discussing the \fIstructure\fR of a database we shall +use the formal relational terms relation, tuple, attribute, and so on. +The correspondence between the formal relational terms and their informal +equivalents is given in the table below. + + +.ks +.nf + \fBformal relational term\fR \fBinformal equivalents\fR + + relation table + tuple record, row + attribute field, column + primary key unique identifier + domain pool of legal values +.fi +.ke + + +A \fBrelation\fR is a set of like tuples. A \fBtuple\fR is a set of +\fBattributes\fR, each of which is defined upon a specific domain. +A \fBdomain\fR is an abstract type which defines the legal values an +attribute may take on (e.g., "posint" or "color"). The tuples of a relation +must be unique within the containing relation. The \fBprimary key\fR is +a subset of the attributes of a relation which is sufficient to uniquely +identify any tuple in the relation (often a single attribute serves as +the primary key). + +The relational data model was chosen for the DBSS because it is the simplest +conceptual data model which meets our requirements. Other possibilites +considered were the \fBhierarchical\fR model, in which data is organized in +a tree structure, and the \fBnetwork\fR model, in which data is organized in +a potentially recursive graph structure. Virtually all new database systems +implemented since the mid-seventies have been based on the relational model +and most database research today is in support of the relational model (the +remainder goes to the new fifth-generation technology, not to the old data +models). + +The term "relational" in "relational database" comes from the \fBrelational +algebra\fR, a branch of mathematics based on set theory which defines a +fundamental and mathematically complete set of operations upon relations +(tables). The relational algebra is fundamental to the DBMS query language +(section 4.3) but can be safely ignored in the rest of the DBSS. The reader +is referred to any introductory database text for a discussion of the relational +algebra and other database technotrivia. The classic introductory database +text is \fI"An Introduction to Database Systems"\fR, Volume 1 (Fourth Edition, +1986) by C. J. Date. + +.nh 2 +System Architecture + + The system architecture of the DBSS is depicted in Figure 2. The parts +of the figure above the "DBKI" have already been discussed in section 2.2. +The remainder of the figure is what has been referred to previously as the +DB kernel. + +The primary function of DBIO is record access (retrieval, update, insertion, +and deletion) based on evaluation of a \fBselect\fR statement input as a string. +DBIO can also process symbolic definitions of relations and other database +objects so that new tables may be created. DBIO does not implement any +relational operators more complex than select; the more complex relational +operations are left to the DBMS query language to minimize the size and +complexity of DBIO. + +The basic concept underlying the design of the lower level portions of the DBSS +is that the DB kernel provides the \fBaccess method\fR for efficiently accessing +records in mass storage, while DBIO takes care of all higher level functions. +In particular, DBIO implements all functions required to access the contents +of a record, while the DB kernel is responsible for storage allocation and for +the maintenance and use of indexes, but has no knowledge of the actual contents +of a record (the HDBI is an exception to this rule as we shall see later). + +The database kernel interface (DBKI) provides a layer of indirection between +DBIO and the underlying database kernel (DBK). The DBKI can support a number +of different kernels, much the way FIO can support a number of different device +drivers. The DBKI also provides network access to a remote database, using +the existing IRAF kernel interface (KI) to communicate with a DBKI on the +remote node. Two standard database kernels are provided. + +The primary DBK (at the right in the figure) maintains and accesses DBSS +binary datasets; this is the most efficient kernel and probably the only +kernel which will fully implement the semantic actions of the DBKI. +The second DBK (at the left in the figure) supports the host database +interface (HDBI) and is used to access archival data, any foreign image +formats, and the host database system (HDB), if any. Specialized HDBI +drivers are required to access foreign image formats or to interface to +an HDB. + + +.ks +.nf + DBMS IMAGES(etc) (CL) + \ / + \ / --------- + \ / + \ IMIO + \ / \ + \ / \ + \/ \ + DBIO FIO (VOS) + | + | + | + DBKI + | + +------+------+-------+ + | | | + DBK DBK (KI) + | | | + | | | + HDBI | | + | | | + +----+----+ | | --------- + | | | | + | | | | + [archive] [HDB] [dataset] | + | + | (host system) + - + (LAN) + - + | + | --------- + | + (Kernel-Server) + | + | + DBKI (VOS) + | + +---+---+ + | | + DBK DBK + + +.fi +.ce +Figure 2. \fBDatabase Subsystem Architecture\fR +.ke + + +.nh 2 +The DBMS Package +.nh 3 +Overview + + The user interfaces with a database in either of two ways. The first way +is via the tasks in an applications package, which perform highly specialized +operations upon objects stored in the database, e.g., to reduce a certain kind +of data. The second way is via the database management package (DBMS), which +gives the user direct access to any dataset (but not to large pixel arrays +stored outside the DBSS). The DBMS provides an assortment of general purpose +operators which may be used regardless of the type of data stored in the +database and regardless of the applications program which originally created +the structures stored in the database. + +The DBMS package consists of an assortment of simple procedural operators +(conventional CL callable parameter driven tasks), a screen editor for tables, +and the query language, a large program which talks directly to the terminal +and which has its own special syntax. Lastly there is a subpackage containing +tasks useful only for datasets maintained by the primary DBK, i.e., a package +of relatively low level tasks for things like crash recovery and examining +the contents of physical datasets. + +.nh 3 +Procedural Interface + + The DBMS procedural interface provides a number of the most commonly +performed database operations in the form of CL callable tasks, allowing +these simple operations to be performed without the overhead involved in +entering the query language. Extensive database manipulations are best +performed from within the query language, but if the primary concern of +the user is data reduction in some package other than DBMS the procedural +operators will be more convenient and less obtrusive. + +.nh 4 +General Operators + + DBMS tasks are required to implement the following general database +management operations. Detailed specifications for the actual tasks are +given later. +.ls +.ls \fBchdb\fR newdb +Change the default database. To minimize typing the DBSS provides a +"default database" paradigm analogous to the default directory of FIO. +Note that there need be no obvious connection between database objects +and files since multiple tables may be stored in a single physical file, +and the physical database may reside on an optical disk or worse may be +an HDB. Therefore the FIO "directory" cannot be used to examine the +contents of a database. The default database may be set independently +of the current directory. +.le +.ls \fBpcatalog\fR [database] +Print the catalog of the named database. The catalog is a system table +containing one entry for every table in the database; it is analogous +to a FIO directory. Since the catalog is a table it can be examined like +any other table, but a special task is provided since the print catalog +operation is so common. If no argument is given the catalog of the default +database is printed. +.le +.ls \fBptable\fR spe +Print the contents of the specified relation in list form on the standard +output. The operand \fIspe\fR is a general select expression defining +a new table as a projection of some subset of the records in a set of one or +more named tables. The simplest select expression is the name of a single +table, in which case all fields of all records in the table will be printed. +More generally, one might print all fields of a single table, selected fields +of a single table (projection), all fields of selected records of a single +table (selection), or selected fields of selected records from one or more +tables (selection plus projection). +.le +.ls \fBrcopy\fR spe output_table +Copy (insert) the records specified by the general select expression +\fIspe\fR into the named \fIoutput_table\fR. If the named output table +does not exist a new one will be created. If the attributes of the output +table are different than those of the input table the proper action of +this operator is not obvious and has not yet been defined. +.le +.ls \fBrmove\fR spe output_table +Move (insert) the relation specified by the general select expression +\fIspe\fR into the named \fIoutput_table\fR. If the named output table +does not exist a new one will be created. The original records are deleted. +This operator is used to generate the union of two or more tables. +.le +.ls \fBrdelete\fR spe +Delete the records specified by the general select expression \fIspe\fR. +Note that this operator deletes records from tables, not the tables themselves. +.le +.ls \fBmkdb\fR newdb [ddl_file] +Create a new, empty database \fInewdb\fR. If a data definition file +\fIddl_file\fR is named it will be scanned and any domain, relation, etc. +definitions therein entered into the new database. +.le +.ls \fBmktable\fR table relation +Create a new, empty table \fItable\fR of type \fIrelation\fR. The parameter +\fIrelation\fR may be the name of a DDL file, the name of an existing base +table, or any general record select/project expression. +.le +.ls \fBmkview\fR table relation +Create a new virtual table (view) defined in terms of one or more existing +base tables by the operand \fIrelation\fR, which is the same as for the +task \fImktable\fR. Operationally, \fBmkview\fR is much like \fBrcopy\fR, +except that it is considerably faster and the new table does not physically +store any data. The new view-table behaves like any other table in most +operations (except some types of updates). Note that the new table may +reference tuples in several different base tables. A view-table may +subsequently be converted into a base table with \fBrcopy\fR. Views are +discussed in more detail in section 4.5. +.le +.ls \fBmkindex\fR table fields +Make a new index on the named base table over the listed fields. +.le +.ls \fBrmtable\fR table +Drop (delete, remove) the named base table (or view) and any indexes defined +on the table. +.le +.ls \fBrmindex\fR table fields +Drop (delete, remove) the index defined over the listed fields on the named +base table. +.le +.ls \fBrmdb\fR [database] +Destroy the named database. Unless explicitly overridden \fBrmdb\fR will +refuse to delete a database until all tables therein have been dropped. +.le +.le + + +Several terms were introduced in the discussion above which have not yet been +defined. A \fBbase table\fR is a physical table (instance of a defined +relation), unlike a \fBview\fR which is a virtual table defined via selection +and projection over one or more base tables or other views. Both types of +objects behave equivalently in most operations. +A \fBdata definition language\fR (DDL) is a language syntax used to define +database objects. + +.nh 4 +Forms Based Data Entry and Retrieval + + Many of the records typically stored in a database are too large to be +printed in list format on a single line. Some form of multiline output is +necessary; this multiline representation is called a \fBform\fR. The full +terminal screen is used to display a form, e.g. with the fields labeled +in reverse video and the field values in normal video. Records are viewed +one at a time. + +Data entry via a form is an interactive process similar to editing a file with +a screen editor. The form is displayed, possibly with default values for the +fields, and the user types in new values for the fields. Editor commands are +provided for positioning the cursor to the field to be edited and for editing +within a field. The DBSS verifies each value as it is entered using the range +information supplied with the domain definition for that field. +Additional checks may be made before the new record is inserted into the +output table, e.g., the DBSS may verify that values have been entered for +all fields which do not permit null values. +.ls +.ls \fBetable\fR spe +Call up the forms editor to edit a set of records. The operand \fIspe\fR +may be any general select expression. +.le +.ls \fBpform\fR spe +Print a set of records on the standard output, using the forms generator to +generate a nice self documenting format. +.le +.le + + +The \fBforms editor\fR (etable) may be used to display or edit existing records +as well as to enter new ones. It is desirable for the forms editor to be able +to move backward as well as forward in a table, as well as to move randomly +to a record satisfying a predicate, i.e., search through the table for a +record. This makes the forms editor a powerful tool for browsing through a +database. If the predicate for a search is specified by entering values or +boolean expressions into the fields contributing to the predicate then we have +a query-by-form utility, which has been reported in the literature to be very +popular with users (since one does not have to remember a syntax and typing +is minimized). + +A variation on the forms editor is \fBpform\fR, used to output records in +"forms" format. This will be most useful for large records or for cases where +one is more interested in studying individual records than in comparing +different records. The alternative to forms output is list or tabular format +output. This form of output is more concise and can be used as input to the +\fBlists\fR operators, but may be harder to read and may overflow the output +line. List format output is discussed further in the next section. + +By default the format of a form is determined automatically by a +\fBforms generator\fR using information given in the DDL when the database +was created. The domain definition capability of the DDL includes provisions +for specifying the default output format for a field as well as the field label. +In most cases this will be sufficient information for the forms generator to +generate an esthetically acceptable form. If desired the user or programmer can +modify this form or create a new form from scratch, and the forms generator +will use the customized form rather than create one of its own. + +The CL \fBeparam\fR parameter file editor is an example of a simple forms +editor. The main differences between \fBeparam\fR and \fBetable\fR are the +forms generator and the browsing capability. + +.nh 4 +List Interface + + The \fBlist\fR is one of the standard IRAF data structures. A list is +an ascii table wherein the standard record delimiter is the newline and the +standard field delimiter is whitespace. Comment lines and blank lines are +ignored within lists; double comment lines ("## ...") may optionally be used +to label the columns of a list. By default, non-DBMS lists are free format; +strings must be quoted if they contain one of the field delimiter characters. +The field and record delimiter characters may be changed if necessary, e.g., +to permit multiline records. Fixed format lists are available as an option +and are often required to interface to external (non-IRAF) programs. + +The primary advantages of the list or tabular format for printed tables are +the following. +.ls +.ls [1] +The list or tabular format is the most concise form of printed output. +The eye can rapidly scan up and down a column to compare the values of +the same field in a set of records. +.le +.ls [2] +DBMS list output may be used as input to the tasks in the \fBlists\fR, +\fBplot\fR, and other packages. Using the pipe syntax, tasks which +communicate via lists may be connected together to perform arbitrarily +complex operations. +.le +.ls [3] +List format output is the defacto standard format for the interchange of +tabular data (e.g., DBSS tables) amongst different computers and programs. +A list (usually the fixed format variety) may be written onto a cardimage +tape for export, and conversely, a list read from a cardimage tape may be +used to enter a table into a DBSS database. +.le +.le + + +The most common use for list format output will probably be to print tables. +When a table is too wide to fit on a line the user will learn to use +\fBprojection\fR to print only the fields of interest. The default format +for DBMS lists will be fixed format, using the format information provided +in the DDL specification to set the default output format. Fixed format +is best for DBMS lists since it forces the field values to line up in nice +orderly columns, which are easier for a human to read (fixed format is easier +and more efficient for a computer to read as well, if not to write). +The type of format used will be recorded in the list header and a +\fBlist interface\fR will be provided so that all list processing programs +can access lists equivalently regardless of their format. + +As mentioned above, the list interface can be used to import and export tables. +In particular, an astronomical catalog distributed on card image tape can be +read directly into a DBSS table once a format descriptor has been prepared +and the DDL for the new table has been written and used to create an empty +table ready to receive the data. After only a few minutes of setup a user can +have a catalog entered into the database and be getting final results using +the query language interface! +.ls +.ls \fBrtable\fR listfile output_table +The list \fIlistfile\fR is scanned, inserting successive records from the +list into the named output table. A new output table is created if one does +not already exist. The format of the list is taken from the list header +if there is one, otherwise the format specification is provided by the user +in a separate file. +.le +.ls \fBptable\fR spe +Print the contents of the relation \fIspe\fR in list form on the standard +output. The operand \fIspe\fR may be any general select/project expression. +.le +.le + + +The \fBptable\fR operator (introduced in section 4.3.2.1) is used to generate +list output. The inverse operation is provided by \fBrtable\fR. + +.nh 4 +FITS Table Interface + + The FITS table format is a standard format for the transport of tabular +data. The idea is very similar to the cardimage format discussed in the last +section except that the FITS table standard includes a table header used to +define the format of the encoded table, hence the user does not have to +prepare a format descriptor to read a FITS table. The FITS reader and writer +programs are part of the \fBdataio\fR package. + +.nh 4 +Graphics Interface + + All of the \fBplot\fR package graphics facilities are available for plotting +DBMS data via the \fBlist\fR interface discussed in section 4.3.2.3. List +format output may also be used to generate output to drive external (non-IRAF) +graphics packages. Plotting facilities are also available via a direct +interface within the query language; this latter interface is the most efficient +and will be the most suitable for most graphics applications. See section +2.3 for additional comments on the graphics interface. + +.nh 3 +Command Language Interface + + All of the DBMS tasks are CL callable and hence part of the command language +interface to the DBSS. For example, a CL script task may implement arbitrary +relational operators using \fBptable\fR to copy a table into a list, \fBfscan\fR +and \fBprint\fR to read the list and format the modified list, and finally +\fBrtable\fR to insert the output list into a table. The query language may +also be called from within a CL script to process commands passed on the +command line, via the standard input, or via a temporary file. + +Additional operators are required for randomly accessing records without the +use of a list; suitable operators are shown below. +.ls +.ls \fBdbgets\fR record fields +The named fields of the indicated record are returned as a free format string +suitable for decoding into individual fields with \fBfscan\fR. +.le +.ls \fBdbputs\fR record fields values +The named fields of the indicated record are set to the values given in the +free format value string. +.le +.le + + +More sophisticated table and record access facilities are conceivable but +cannot profitably be implemented until an enhanced CL becomes available. + +.nh 3 +Record Selection Syntax + + As we have seen, many of the DBMS operators employ a general record +selection syntax to specify the set of records to be operated upon. +The selection syntax will include a list of tables and optionally a +predicate (boolean expression) to be evaluated for each record in the +listed tables to determine if the record is to be included in the final +selection set. In the simplest case a single table is named with no +predicate in which case the selection set consists of all records in the +named table. Parsing and evaluation of the record selection expression +is performed entirely by the DBIO interface hence we defer detailed +discussion of selection syntax to the sections describing DBIO. + +.nh 3 +Query Language + + In most database systems the \fBquery language\fR is the primary user +interface, both for the end-user interactively entering adhoc queries, and for +the programmer entering queries via the host language interface. The major +reasons for this are outlined below. +.ls +.ls [1] +A query language interface is much more powerful than a "task" or subroutine +based interface such as that described in section 4.3.2. A query language +can evaluate queries much more complex than the simple "select" operation +implemented by DBIO and made available to the user in tasks such as +\fBptable\fR and \fBrcopy\fR. +.le +.ls [2] +A query language is much more efficient than a task interface for repeated +queries. Information about a database may be cached between queries and +files may remain open between queries. Complex queries may be executed as +a series of simpler queries, cacheing the intermediate results in memory. +Graphs may be generated directly from the data without encoding, writing, +reading, decoding, and deleting an intermediate list. +.le +.ls [3] +A query language can perform many functions via a single interface, reducing +the amount of code to be written and supported, as well as simplifying the +user interface. For example, a query language can be used to globally +update (edit) tables, as well as to evaluate queries on the database. +Lacking a query language, such an editing operation would have to be +implemented with a separate task which would no doubt have its own special +syntax for the user to remember (e.g, the \fBhedit\fR task in the \fBimages\fR +package). +.le +.le + + +Unlike most commercial database systems, the DBSS is not built around the +query language. The heart of the IRAF DBSS is the DBIO interface, which is +little more than a glorified record access interface. The query language +is a high level applications task built upon DBIO, GIO, and the other interfaces +constituting the IRAF VOS. This permits us to delay implementation of the +query language until after the DBSS is in use and our primary requirements have +been met, and then implement the query language as an experimental prototype. +Like all data analysis software, the query language is not required to meet +our primary requirements (data acquisition and reduction), rather it is needed +to do interesting things with our data once it has been reduced. + +.nh 4 +Query Language Functions + + The query language is a prominent part of the user interface and is +often used interactively directly by the user, but may also be called +noninteractively from within CL scripts and by SPP programs. The major +functions performed by the query language are as follows. +.ls +.ls [1] +The database management operations, i.e., create/destroy database, +create/drop table or index, sort table, alter table (add new attribute), +and so on. +.le +.ls [2] +The relational operations, i.e., select, project, join, and divide +(the latter is rarely implemented). These are the operations most used +to evaluate queries on the database. +.le +.ls [3] +The traditional set operations, i.e., union, intersection, difference, +and cartesian product. +.le +.ls [4] +The editing operations, i.e, selective record update and delete. +.le +.ls [5] +Operations on the columns of tables. Compute the sum, average, minimum, +maximum, etc. of the values in a column of a table. These operations +are also required for queries. +.le +.ls [6] +Tabular and graphical output. The result of any query may be printed or +plotted in a variety of ways, without need to repeat the query. +.le +.le + + +The most important function performed by the query language is of course the +interactive evaluation of queries, i.e., questions about the data in the +database. It is beyond the scope of this document to try to give the reader +a detailed understanding of how a query language is used to evaluate queries. + +.nh 4 +Language Syntax + + The great flexibility of a query language derives from the fact that it is +syntax rather than parameter driven. The syntax of the DBMS query language +has not yet been defined. In choosing a language syntax there are a several +possible courses of action: [1] implement a standard syntax, [2] extend a +standard syntax, or [3] develop a new syntax, e.g., as a variation on some +existing syntax. + +The problem with rigorously implementing a standard syntax is that all query +languages currently in wide use were developed for commercial applications, +e.g., for banking, inventory, accounting, customer mailing lists, etc. +Experimental query languages are currently under development for CAD +applications, analysis of Landsat imagery, and other applications similar +to ours, but these are all research projects at the present time. +The basic characteristics desirable in a query language intended for scientific +data reduction and analysis seem little different than those provided by a query +language intended for commercial applications, hence the most practical +approach is probably to start with some existing query language syntax and +modify or extend it as necessary for our type of data. + +There is no standard query language for relational databases. +The closest thing to a standard is SQL, a language originally developed by +IBM for System-R (one of the first relational database systems, actually an +experimental prototype), and still in use in the latest IBM product, DB2. +This language has since been used in many relational products by many companies. +SQL is the latest in a series of relational query languages from IBM; earlier +languages include SQUARE and SEQUEL. The second most widely used relational +query language appears to be QUEL, the query language used in both educational +and commercial INGRES. + +Both SQL and QUEL are examples of the so-called "calculus" query languages. +The other major type of query language is the "algebraic" query language +(excluding the forms and menu based query languages which are not syntax +driven). Examples of algebraic languages are ISBL (PRTV, Todd 1976), +TABLET (U. Mass.), ASTRID (Gray 1979), and ML (Li 1984). +These algebraic languages have all been implemented and used, but nowhere +near as widely as SQL and QUEL. + +It is interesting to note that ASTRID and ML were developed by researchers +active in the area of logic languages. In particular, the ML (Mathematics-Like) +query language was implemented in Prolog and some of the character of Prolog +shows through in the syntax of the language. There is a close connection +between the relational algebra and the predicate calculus (upon which the +logic languages are based) which is currently being actively explored. +One of the most promising areas of application for the logic languages +(upon which the so-called "fifth generation" technology is based) is in +database applications and query languages in particular. + +There appears to be no compelling reason for the current dominance of the +calculus type query language, other than the fact that is what IBM decided +to use in System-R. Anything that can be done in a calculus language can +also be done in an algebraic language and vice versa. + +The primary difference between the two languages is that the calculus languages +want the user to express a complex query as a single large statement, +whereas the algebraic languages encourage the user to execute a complex +query as a series of simpler queries, storing the intermediate results as +snapshots or views (either language can be used either way, but the orientation +of the two languages is as stated). For simple queries there is little +difference between the two languages, although the calculus languages are +perhaps more readable (more English-like) while the algebraic languages are +more concise and have a more mathematical character. + +The orientation of the calculus languages towards doing everything in a single +statement provides more scope for optimization than if the equivalent query is +executed as a series of simpler queries; this is often cited as one of the +major advantages of the calculus languages. The procedural nature of the +algebraic languages does not permit the type of global optimizations employed +in the calculus languages, but this approach is perhaps more user-friendly +since the individual steps are easy to understand, and one gets to examine +the intermediate results to figure out what to do next. Since a complex query +is executed incrementally, intermediate results can be recomputed without +starting over from scratch. It is possible that, taking user error and lack +of forethought into account, the less efficient algebraic languages might end +up using less computer time than the super efficient calculus languages for +comparable queries. + +A further advantage of the algebraic language in a scientific environment is +that there is more of a distinction between executing a query and printing +the results of the query than in a calculus language. The intermediate results +of a complex query in an algebraic language are named relations (snapshots +or views); an extra print command must be entered to examine the intermediate +result. This is an advantage if the query language provides a variety of ways +to examine the result of a query, e.g., as a printed table or as some type +of plot. + +.nh 4 +Sample Queries + + At this point several examples of actual queries, however simple they may +be, should help us to visualize what a query language is like. Several +examples of typical scientific queries were given (in English) in section 3.2.1. +For the convenience of the reader these are duplicated here, followed by actual +examples in the query languages SQL, QUEL, ASTRID, and ML. It should be noted +that these are all examples of very simple queries and these examples do little +to demonstrate the power of a fully relational query language. +.ls +.ls [1] +Find all objects of type "pqr" for which X is in the range A to B and +Z is less than 10. +.le +.ls [2] +Compute the mean and standard deviation of attribute X for all objects +in the set [1]. +.le +.ls [3] +Compute and plot (X-Y) for all objects in set [1]. +.le +.ls [4] +Plot a circle of size (log2(Z-3.2) * 100) at the position (X,Y) of all objects +in set [1]. +.le +.ls [5] +Print the values of the attributes OBJ, X, Y, and Z of all objects of type +"pqr" for which X is in the range A to B and Y is greater than 30. +.le +.le + + +It should not be difficult for the imaginative reader to make up similar +queries for a particular astronomical catalog or data archive. +For example (I can't resist), "find all objects for which B-V exceeds X", +"find all recorded observations of object X", "find all observing runs on +telescope X in which astronomer Y participated during the years 1975 to +1985", "compute the number of cloudy nights in August during the years +1985 to 1990", and so on. The possibilities are endless. + +Query [5] is an example of a simple select/project query. This query is +shown below in the different query languages. Note that whitespace may be +redistributed in each query as desired; in particular, the entire query may +be entered on a single line if desired. Keywords are shown in upper case +and data names or values in lower case. The object "table" is the table +from which records are to be selected, "pqr" is the desired value of the +field "type" of table "table", and "x", "y", and "z" are numeric fields of +the table. + + +.ks +.nf +SQL: + + SELECT obj, x, y, z + FROM table + WHERE type = 'pqr' + AND x >= 10 + AND x <= 20 + AND z > 30; +.fi +.ke + + +.ks +.nf +QUEL: + + RANGE OF t IS table + RETRIEVE (t.obj, t.x, t.y, t.z) + WHERE t.type = 'pqr' + AND t.x >= 10 + AND t.y <= 20 + AND t.z > 30 +.fi +.ke + + +.ks +.nf +ASTRID (mnemonic form): + + table + SELECTED_ON [ + type = 'pqr' + AND x >= 10 + AND x <= 20 + AND z > 30 + ] PROJECTED_TO + obj, x, y, z +.fi +.ke + + +.ks +.nf +ASTRID (mathematical form): + + table ;[ type = 'pqr' AND x >= 10 AND x <= 20 AND z < 10 ] % + obj, x, y, z +.fi +.ke + + +.ks +.nf +ASTRID (alternate query showing use of intermediates): + + a := table ;[ type = 'pqr' AND z > 30 ] + b := a ;[ x >= 10 AND x <= 20 ] + b % obj,x,y,z +.fi +.ke + + +.ks +.nf +ML (Li/Prolog): + + table : type=pqr, x >= 10, x <= 20, z < 10 [obj,x,y,z] +.fi +.ke + + +Note that in ASTRID and ML selection and projection are implemented as +operators or qualifiers modifying the relation on the left. To print all +fields of all records of a table one need only enter the name of the table. +The logic language nature of such queries is evident if one thinks of the +query as a predicate or true/false assertion. Given such an assertion (query), +the query processor tries to prove the assertion true by finding all tuples +satisfying the predicate, using the set of rules given (the database). + +For simple queries such as these it makes little difference what query language +is used; many users would probably prefer the SQL or QUEL syntax for these +simple queries because of the English like syntax. To seriously evaluate the +differences between the different languages more complex queries must be tried, +but such an exercise is beyond the scope of the present document. + +As a final example we present, without supporting explanation, an example +of a more complex query in SQL (from Date, 1986). This example is based +upon a "suppliers-parts-projects" database, consisting of four tables: +suppliers (S), parts (P), projects (J), and number of parts supplied to +a specified project by a specified supplier (SPJ), with fields 'supplier +number' (S#), 'part number' (P#) and 'project number' (J#). The names +SPJX and SPJY are aliases for SPJ. This example is rather contrived and +the data is not interesting, but it should serve to illustrate the use of +SQL for complex queries. + + +.ks +.nf +Query: Get part numbers for parts supplied to all projects in London. + + SELECT DISTINCT p# + FROM spj spjx + WHERE NOT EXISTS + ( SELECT * + FROM j + WHERE city = 'london' + AND NOT EXISTS + ( SELECT * + FROM spj spjy + WHERE spjy.p# = spjx.p# + AND spjy.j# = j.j# )); +.fi +.ke + + +The nesting shown in this example is characteristic of the calculus languages +when used to evaluate complex queries. Each SELECT implicitly returns an +intermediate relation used as input to the next higher level subquery. + +.nh 3 +DB Kernel Operators + + All DBMS operators described up to this point have been general purpose +operators with no knowledge of the form in which data is stored internally. +Additional operators are required in support of the standard IRAF DB kernels. +These will be implemented as CL callable tasks in a subpackage off DBMS. + +.nh 4 +Dataset Copy and Load + + Since our intention is to store the database in a machine independent +format, special operators are not required to backup, reload, or copy dataset +files. The binary file copy facilities provided by IRAF or the host system +may be used to backup, reload, or copy dataset files. + +.nh 4 +Rebuild Dataset + + Over a period of time a dataset which is subjected to heavy updating +may become disordered internally, reducing the efficiency of a most record +access operations. A utility task is required to efficiently rebuild such +datasets. The same result can probably be achieved by an \fIrcopy\fR +operation but a lower level operator may be more efficient. + +.nh 4 +Mount Foreign Dataset + + Before a foreign dataset (archive or local format imagefile) can be +accessed it must be \fImounted\fR, i.e., the DBSS must be informed of the +existence and type of the dataset. The details of the mount operation are +kernel dependent; ideally the mount operation will consist of little more +than examining the structure of the foreign dataset and making appropriate +entries in the system catalog. + +.nh 4 +Crash Recovery + + A utility is required for recovering datasets which have been corrupted +as a result of a hardware or software failure. There should be sufficient +redundancy in the internal data structures of a dataset to permit automated +recovery. The recover operation is similar to a rebuild so perhaps the +same task can be used for both operations. + +.nh 2 +The IMIO Interface +.nh 3 +Overview + + The Image I/O (IMIO) interface is an existing subroutine interface used +to maintain and access bulk data arrays (images). The IMIO interface is built +upon the DBIO interface, using DBIO to maintain and access the image headers +and sometimes to access the stored data (the pixels) as well. For reasons of +efficiency IMIO directly accesses the bulk data array when large images are +involved. + +Most of the material presented in this section on the image header is new. +The pixel access facilities provided by the existing IMIO interface will +remain essentially unchanged, but the image header facilities provided by +the current interface are quite limited and badly need to be extended. +The existing header facilities provide support for the major physical image +attributes (dimensionality, length of each axis, pixel datatype, etc.) plus +a limited facility for storing user defined attributes. The main changes +in the new interface will be excellent support for history records, world +coordinates, histograms, a bad pixel list, and image masks. In addition +the new interface will provide improved support for user defined attributes, +and greatly improved efficiency when accessing large groups of images. +The storage structures will be more localized, hopefully causing less +confusion for the user. + +In this section we first discuss the components of an image, concentrating +primarily on the different parts of the image header, which is quite a +complex structure. We then discuss briefly the (mostly existing) facilities +for header and pixel access. Lastly we discuss the storage structures +normally used to maintain images in mass storage. + +.nh 3 +Logical Schema + + Images are stored as records in one or more tables in a database. More +precisely, the main part of an image header is a record (row) in some table +in a database. In general some of the other tables in a database will contain +auxiliary information describing the image. Some of these auxiliary tables +are maintained by IMIO and will be discussed in this section. Other tables +will be created by the applications programs used to reduce the image data. + +As far as the DBSS is concerned, the pixel segment of an image is a pretty +minor item, a single array type attribute in the image header. Since the +size of this array can vary enormously from one image to the next some +strategic questions arise concerning where to store the data. In general, +small pixel segments will be stored directly in the image header, while large +pixel segments will be stored in a separate file from that used to store +the header records. + +The major components of an image (as far as IMIO is concerned) are summarized +below. More detailed information on each component is given in the following +sections. +.ls +.ls Standard Header Fields +An image header is a record in a relation initially of type "image". +The standard header fields include all attributes necessary to describe +the physical characteristics of the image, i.e., all attributes necessary +to access the pixels. +.le +.ls History +History records for all images in a database are stored in a separate history +relation in time sequence. +.le +.ls World Coordinates +An image may have any number of world coordinate systems associated with it. +These are stored in a separate world coordinate system relation. +.le +.ls Histogram +An image may have any number of histograms associated with it. +Histograms for all images in a database are stored in a separate histogram +relation in time sequence. +.le +.ls Pixel Segment +The pixel segment is stored in the image header, at least from the point of +view of the logical schema. +.le +.ls Bad Pixel List +The bad pixel list, a variable length integer array, is required to physically +describe the image hence is stored in the image header. +.le +.ls Region Mask +An image may have any number of region masks associated with it. Region masks +for all images in a database are stored in a separate mask relation. A given +region mask may be associated with any number of different images. +.le +.le + + +In summary, the \fBimage header\fR contains the standard header fields, +the pixels, the bad pixel list, and any user defined fields the user wishes +to store directly in the header. All other information describing an image +is stored in external non-image relations, of which there may be any number. +Note that the auxiliary tables (world coordinates, histograms, etc.) are not +considered part of the image header. + +.nh 4 +Standard Header Fields + + The standard header fields are those fields required to describe the +physical attributes of the image, plus those fields required to physically +access the image pixels. The standard header fields are summarized below. +These fields necessarily reflect the current capabilities of IMIO. Since +the DBSS provides data independence, however, new fields may be added in +the future to support future versions of IMIO without rendering old images +unreadable. +.ls +.ls 12 image +An integer value automatically assigned by IMIO when the image is created +which uniquely identifies the image within the containing table. This field +is used as the primary key in \fIimage\fR type relations. +.le +.ls naxis +Number of axes, i.e., the dimensionality of the image. +.le +.ls naxis[1-4] +A group of 4 attributes, i.e., \fInaxis1\fR through \fInaxis4\fR, +each specifying the length of the associated image axis in pixels. +Axis 1 is an image line, 2 is a column, 3 is a band, and so on. +If \fInaxis\fR is greater than four additional axis length attributes +are required. If \fInaxis\fR is less than four the extra fields are +set to one. Distinct attributes are used rather than an array so that +the image dimensions will appear in printed output, to simplify the use +of the dimension attributes in queries, and to make the image header +more FITS-like. +.le +.ls linelen +The physical length of axis one (a line of the image) in pixels. Image lines +are often aligned on disk block boundaries (stored in an integral number of +disk blocks) for greater i/o efficiency. If \fIlinelen\fR is the same as +\fInaxis1\fR the image is said to be stored in compressed format. +.le +.ls pixtype +A string valued attribute identifying the datatype of the pixels as stored +on disk. The possible values of this attribute are discussed in detail below. +.le +.ls bitpix +The number of bits per pixel. +.le +.ls pixels +The pixel segment. +.le +.ls nbadpix +The number of bad pixels in the image. +.le +.ls badpix +The bad pixel list. This is effectively a boolean image stored in compressed +form as a variable length integer array. The bad pixel list is maintained by +the pixel list package, a subpackage of IMIO, also used to maintain region +masks. +.le +.ls datamin +The minimum pixel value. This field is automatically invalidated (set to a +value greater than \fIdatamax\fR) whenever the image is modified, unless +explicitly updated by the caller. +.le +.ls datamax +The maximum pixel value. This field is automatically invalidated (set to a +value less than \fIdatamin\fR) whenever the image is modified, unless +explicitly updated by the caller. +.le +.ls title +The image title, a one line character string identifying the image, +for annotating plots and other forms of output. +.le +.le + + +The possible values of the \fIpixtype\fR field are shown below. The format +of the value string is "type.host", where \fItype\fR is the logical datatype +and \fIhost\fR is the host machine encoding used to represent that datatype. + + +.ks +.nf + TYPE DESCRIPTION MAPS TO + + byte.m unsigned byte ( 8 bits) short.spp + ushort.m unsigned word (16 bits) long.spp + + short.m short integer, signed short.spp + long.m long integer, signed long.spp + real.m single precision floating real.spp + double.m double precision floating double.spp + complex.m (real,real) complex.spp +.fi +.ke + + +Note that the first character of each keyword is sufficient to uniquely +identify the datatype. The ".m" suffix identifies the "machine" to which +the datatype refers. When new images are written \fIm\fR will usually be +the name of the host machine. When images written on a different machine +are read on the local host there is no guarantee that the i/o system will +recognize the formats for the named machine, but at least the format will +be uniquely defined. Some possible values for \fIm\fR are shown below. + + +.ks +.nf + dbk DBK (database kernel) mip-format + mip machine independent (MII integer, + IEEE floating) + sun SUN formats (same as mip?) + vax DEC Vax data formats + mvs DG MV-series data formats +.fi +.ke + + +The DBK format is used when the pixels are stored directly in the image header, +since only the DBK binary formats are supported in DBK binary datafiles. +The standard i/o system will be support at least the MIP, DBK, SUN (=MIP), +and VAX formats. If the storage format is not the host system format +conversion to and from the corresponding SPP (host) format will occur at the +level of the FIO interface to avoid an N-squared type conversion matrix in +IMIO, i.e., IMIO will see only the SPP datatypes. + +Examples of possible \fIpixtype\fR values are "short.vax", i.e., a 16 bit signed +twos-complement byte-swapped integer format, and "real.mip", the 32 bit IEEE +single precision floating point format. + +.nh 4 +History Text + + The intent of the \fIhistory\fR relation is to record all events which +modify the image data in a dataset, i.e., all operations which create, delete, +or modify images. The attributes of the history relation are shown below. +Records are added to the history table in time sequence. Each record logically +contains one line of history text. +.ls 4 +.ls 12 time +The date and time of the event. This value of this field is automatically +set by IMIO when the history record is inserted. +.le +.ls parent +The name of the parent image in the case of an image creation event, +or the name of the affected image in the case of an image modification +event affecting a single image. +.le +.ls child +The name of the child or newly created image in the case of an image creation +event. This field is not used if only a single image is involved in an event. +.le +.ls event +The history text, i.e., a one line description of the event. The suggested +format is a task or procedure call naming the task or procedure which modified +the image and listing its arguments. +.le +.le + + +.ks +.nf +Example: + + TIME PARENT CHILD EVENT + + Sep 23 20:24 nite1[12] -- imshift (1.5, -3.4) + Sep 23 20:30 nite1[10] nite1[15] + Sep 23 20:30 nite1[11] nite1[15] + Sep 23 20:30 nite1[15] -- nite1[10] - nite1[11] +.fi +.ke + + +The principal reason for collecting all history text together in a single +relation rather than storing it scattered about in string attributes in the +image headers is to permit use of the DBMS facilities to pose queries on the +history of the dataset. Secondary reasons are the completeness of the history +record thus provided for the dataset as a whole, and increased efficiency, +both in the amount of storage required and in the time required to record an +event (in particular, the time required to create a new image). Note also that +the history relation may be used to record events affecting dataset objects +other than images. + +The history of any particular image is easily recovered by printing the values +of the \fItext\fR field of all records with a particular value of the +\fIimage\fR key. The parents or children of any image are easily traced +using the information in the history relation. The history of the dataset +as a whole is given by printing all history records in time sequence. +History information is not lost when intermediate images are deleted unless +deletes are explicitly performed upon the history relation. + +.nh 4 +World Coordinates + + In general, an image may simultaneously have any number of world coordinate +systems (WCS) associated with it. It would be quite awkward to try to store an +arbitrary number of WCS descriptors in the image header, so a separate WCS +relation is used instead. If world coordinates are not used no overhead is +incurred. + +Maintenance of the WCS descriptor, transformation of the WCS itself (e.g., +when an image changes spatially), and coordinate transformations using the WCS +are all managed by a dedicated package, also called WCS. The WCS package +is a general purpose package usable not only in IMIO but also in GIO and +other places. IMIO will be responsible for copying the WCS records for an +image when a new image is created, as well as for correcting the WCS for the +effects of subsampling, coordinate flip, etc. when a section of an image is +mapped. + +A general solution to the WCS problem requires that the WCS package support +both linear and nonlinear coordinate systems. The problem is further +complicated by the variable number of dimensions in an image. In general +the number of possible types of nonlinear coordinate systems is unlimited. +Our solution to this difficult problem is as follows. +.ls 4 +.ls o +Each image axis is associated with a one or two dimensional mapping function. +.le +.ls o +Each mapping function consists of a general linear transformation followed +by a general nonlinear transformation. Either transformation may be unitary +(may be omitted) if desired. +.le +.ls o +The linear transformation for an axis consists of some combination of a shift, +scale change, rotation, and axis flip. +.le +.ls o +The nonlinear transformation for an axis consists of a numerical approximation +to the underlying nonlinear analytic function. A one dimensional function is +approximated by a curve x=f(a) and a two dimensional function is approximated +by a surface x=f(a,b), where X, A, and B may be any of the image axes. +A choice of approximating functions is provided, e.g., chebyshev or legendre +polynomial, piecewise cubic spline, or piecewise linear. +.le +.ls o +The polynomial functions will often provide the simplest solution for well +behaved coordinate transformations. The piecewise functions (spline and linear) +may be used to model any slowly varying analytic function represented in +cartesian coordinates. The piecewise functions \fIinterpolate\fR the original +analytic function on a regular grid, approximating the function between grid +points with a first or third order polynomial. The approximation may be made +arbitrarily good by sampling on a finer grid, trading table space for increased +precision. +.le +.ls o +For many nonlinear functions, especially those defined in terms of the +transcendental functions, the fitted curve or surface will be quicker to +evaluate than the original function, i.e., the approximation will be more +efficient (evaluation of a bicubic spline is not cheap, however, requiring +computation of a linear combination of sixteen coefficients for each output +point). +.le +.ls o +The nonlinear transformation will define the mapping from pixel coordinates +to world coordinates. The inverse transformation will be computed by numerical +inversion (iterative search). This technique may be too inefficient for some +applications. +.le +.le + + +For example, the WCS for a three dimensional image might consist of a bivariate +Nth order chebyshev polynomial mapping X and Y to RA and DEC via gnomic +projection, plus a univariate piecewise linear function mapping each discrete +image band (Z) to a wavelength value. If the image were subsequently shifted, +rotated, magnified, block averaged, etc., or sampled via an image section, +a linear term would be added to the WCS record of each axis affected by the +transformation. + +A WCS is represented by a \fIset\fR of records in the WCS relation. One record +is required for each axis mapped by the transformation. The attributes of the +WCS relation are described below. The records forming a given WCS all share +the same value of the \fIwcs\fR field. +.ls +.ls 12 wcs +The world coordinate system number, a unique integer code assigned by the WCS +package when the WCS is added to the database. +.le +.ls image +The name of the image with which the WCS is associated. +If a WCS is to be associated with more +than one image retrieval must be via the \fIwcs\fR number rather than the +\fIimage\fR name field. +.le +.ls type +A keyword supplied by the application identifying the type of coordinate +system defined by the WCS. This attribute is used in combination with the +\fIimage\fR attribute for keyword based retrieval in cases where an image +may have multiple world coordinate systems. +.le +.ls axis +The image axis mapped by the transformation stored in this record. The X +axis is number 1, Y is number 2, and so on. +.le +.ls axin1 +The first input axis (independent variable in the transformation). +.le +.ls axin2 +The second input axis, set to zero in the case of a univariate transformation. +.le +.ls axout +The number of the input axis (1 or 2) to be used for world coordinate output, +in the case where there is only the linear term but there are two input axes +(in which case the linear term produces a pair of world coordinate values). +.le +.ls linflg +A flag indicating whether the linear term is present in the transformation. +.le +.ls nlnflg +A flag indicating whether the nonlinear term is present in the transformation. +.le +.ls p1,p2 +Linear transformation: origin in pixel space for input axes 1, 2. +.le +.ls w1,w2 +Linear transformation: origin in world space for input axes 1, 2. +.le +.ls s1,s2 +Linear transformation: Scale factor DW/DP for input axes 1, 2. +.le +.ls rot +Linear transformation: Rotation angle in degrees counterclockwise from the +X axis. +.le +.ls cvdat +The curve or surface descriptor for the nonlinear term. The internal format +of this descriptor is controlled by the relevant math package. +This is a variable length array of type real. +.le +.ls label +Axis label for plots. +.le +.ls format +Tick label format for plots, e.g., "0.2h" specifies HMS format in a variable +field width with two decimal places in the seconds field. +.le +.le + + +As noted earlier, the full transformation for an axis involves a linear +transformation followed by a nonlinear transformation. The linear term +is defined in terms of the WCS attributes \fIp1, p2\fR, etc. as shown below. +The variables X and Y are the input values of the axes \fIaxin1\fR and +\fIaxin2\fR, which need not correspond to the X and Y axes of the image. + + +.ks +.nf + x' = (x - p1) * s1 + y' = (y - p2) * s2 + + x" = x' * cos(rot) + y' * sin(rot) + y" = y' * cos(rot) - x' * sin(rot) + + u = x" + w1 + v = y" + w2 +.fi +.ke + + +The output variables U and V are then used as input to the nonlinear mapping, +producing the world coordinate value W for the specified image axis \fIaxis\fR +as output. + + w = eval (cvdat, u, v) + +The mappings for the special cases [1] no linear transformation, +[2] no nonlinear transformation, and [3] univariate rather than bivariate +transformation, are easily derived from the full transformation shown above. +Note that if there is no nonlinear term the linear term produces world +coordinates as output, otherwise the intermediate values (U,V) are in +pixel coordinates. Note also that if there is no nonlinear term but there +are two input axes (as in the case of a rotation), attribute \fIaxout\fR +must be set to indicate whether U or V is to be returned as the output world +coordinate. + +.nh 4 +Image Histogram + + Histogram records are stored in a separate histogram relation outside +the image header. An image may have any number of histograms associated +with it, each defined for a different section of the image. A given image +section may have multiple associated histogram records differing in time, +number of sampling bins, etc., although normally recomputation of the +histogram for a given section will result in a record update rather than an +insertion. A subpackage within IMIO is responsible for the computation of +histogram records. Histogram records are not propagated when an image is +copied. Modifications to an image made subsequent to computation of a +histogram record may invalidate or obsolete the histogram. +.ls 4 +.ls 12 image +The name of the image or image section to which the histogram record +applies. +.le +.ls time +The date and time when the histogram was computed. +.le +.ls z1 +The pixel value associated with the first bin of the histogram. +.le +.ls z2 +The pixel value associated with the last bin of the histogram. +.le +.ls npix +The total number of pixels used to compute the histogram. +.le +.ls nbins +The number of bins in the histogram. +.le +.ls bins +The histogram itself, i.e., an array giving the number of pixels in each +intensity range. +.le +.le + + +The histogram limits Z1 and Z2 will normally correspond to the minimum and +maximum pixel values in the image section to which the histogram applies. + +.nh 4 +Bad Pixel List + + The bad pixel list records the positions of all bad pixels in an image. +A "bad" pixel is a pixel which has an invalid value and which therefore should +not be used for image analysis. As far as IMIO is concerned a pixel is either +good or bad; if an application wishes to assign a fractional weight to +individual pixels then a second weight image must be associated with the +data image by the applications program. + +Images tend to have few or no bad pixels. When bad pixels are present they +are often grouped into bad regions. This makes it possible to use data +compression techniques to efficiently represent the set of bad pixels, +which is conceptually a simple boolean mask image. + +The bad pixel list is represented in the image header as a variable length +integer array (the runtime structure is slightly more complex). +This integer array consists of a set of lists. Each list in the set lists +the bad pixels in a particular image line. Each linelist consists of a record +length field and a line number field, followed by the bad pixel list for that +line. The bad pixel list is a series of either column numbers or ranges of +column numbers. Single columns are represented in the list as positive +integers; ranges are indicated by a negative second value. + + +.ks +.nf + 15 2 512 512 + 6 23 4 8 15 -18 44 + 4 72 23 -29 35 +.fi +.ke + + +An example of a bad pixel list describing a total of 15 bad pixels is shown +above. The first line is the pixel list header which records the total list +length (15 ints), the number of dimensions (2), and the sizes of each dimension +(512, 512). There follow a set of variable length line list records. +Two such lists are shown in the example, one for line 23 and one for line 72. +On line 23 columns 4, 8, 15 though 18, and 44 are all bad. Note that each +linelist contains only a line number since the list is two dimensional; +in general an N dimensional image requires N-1 subscripts after the record +length field, starting with the line number and proceeding to higher dimensions +to the right. + +Even though IMIO provides a bad pixel list capability, many applications will +not want to bother to check for bad pixels. In general, pointwise image +operators which produce a new image as output will not need to check for bad +pixels. Non-pointwise image operators, e.g., filtering opertors, may or may +not wish to check for bad pixels (in principle they should use kernel collapse +to ignore bad pixels). Analysis programs, i.e., programs which produce +database records as output rather than create new images, will usually check +for and ignore bad pixels. + +To avoid machine traps when running the pointwise image operators, all bad +pixels must have reasonable values, even if these values have to be set +artificially when the data is archived. IMAGES SHOULD NOT BE ARCHIVED WITH +MAGIC IN-PLACE VALUES FOR THE BAD PIXELS (as in FITS) since this forces the +system to conditionally test the value of every pixel when the image is read, +an unnecessary operation which is quite expensive for large images. +The simplicity of the reserved value scheme does not warrant such an expense. +Note that the reverse operation, i.e., flagging the bad pixels by setting +them to a magic value, can be carried out very efficiently by the reader +program given a bad pixel list. + +For maximum efficiency those operators which have to deal with bad pixels may +provide two separate data paths internally, one for data which contains no +bad pixels and one for data containing some bad pixels. The path to be taken +would be chosen dynamically as each image line is input, using the bad pixel +list to determine which lines contain bad pixels. Alternatively a program +may elect to have the bad pixels flagged upon input by assignment of a magic +value. The two-path approach is the most desirable one for simple operators. +The magic value approach is often simplest for the more complex applications +where duplicating the code to provide two data paths would be costly and the +operation is already so expensive that the conditional test is not important. + +All operations and queries on bad pixel lists are via a general pixel list +package which is used by IMIO for the bad pixel list but which may be used +for any other type of pixel list as well. The pixel list package provides +operators for creating new lists, adding and deleting pixels and ranges of +pixels from a list, merging lists, and so on. + +.nh 4 +Region Mask + + A region mask is a pixel list which defines some subset of the pixels in +an image. Region masks are used to define the region or regions of an image +to be operated upon. Region masks are stored in a separate mask relation. +A mask is a type of pixel list and the standard pixel list package is used +to maintain and access the mask. Any number of different region masks may be +associated with an image, and a given region mask may be used in operations +upon any number of different images. +.ls 4 +.ls 12 mask +The mask number, a unique integer code assigned by the pixel list package +when the mask is added to the database. +.le +.ls image +The image or image section associated with the mask, if any. +.le +.ls type +The logical type of the mask, a keyword supplied by the applications program +when the mask is created. +.le +.ls naxis +The number of axes in the mask image. +.le +.ls naxis[1-4] +The length of each image axis in pixels. If \fInaxis\fR is greater than 4 +additional axis length attributes must be provided. +.le +.ls npix +The total number of pixels in the subset defined by the mask. +.le +.ls pixels +The mask itself, a variable length integer array. +.le +.le + + +Examples of the use of region masks include specifying the regions to be +used in a surface fit to a two dimensional image, or specifying the regions +to be used to correlate two or more images for image registration. +A variety of utility tasks will be provided in the \fIimages\fR package for +creating mask images, interactively and otherwise. For example, it will +be possible to display an image and use the image cursor to mark the regions +interactively. + +.nh 3 +Group Data + + The group data format associates a set of keyword = value type +\fBgroup header\fR parameters with a group of images. All of the images in +a group should have the same size, number of dimensions, and datatype; +this is required for images to be in group format even though it is not +physically required by the database system. All of the images in a group +share the parameters in the group header. In addition, each image in a +group has its own private set of parameters (attributes), stored in the +image header for that image. + +The images forming a group are stored in the database as a named base table +of type \fIimage\fR. The name of the base table must be the same as the name +of the group. Each group is stored in a separate table. The group headers +for all groups in the database are stored in a separate \fIgroups\fR table. +The attributes of the \fIgroups\fR relation are described below. +.ls 4 +.ls 12 group +The name of the group (\fIimage\fR table) to which this record belongs. +.le +.ls keyword +The name of the group parameter represented by the current record. +The keyword name should be FITS compatible, i.e., the name must not exceed +eight characters in length. +.le +.ls value +The value of the group parameter represented by the current record, encoded +FITS style as a character string not to exceed 20 characters in length. +.le +.ls comment +An optional comment string, not to exceed 49 characters in length. +.le +.le + + +Group format is provided primarily for the STScI/SDAS applications, which +require data to be in group format. The format is however useful for any +application which must associate an arbitrary set of \fIglobal\fR parameters +with a group of images. Note that the member images in a group may be +accessed independently like any other IRAF image since each image has a +standard image header. The primary physical attributes will be identical +in all images in the group, but these attributes must still be present in +each image header. For the SDAS group format the \fInaxis\fR, \fInaxisN\fR, +and \fIbitpix\fR parameters are duplicated in the group header. + +.nh 3 +Image I/O + + In this section we describe the facilities available for accessing +image headers and image data. The discussion will be limited to those +aspects of IMIO relevant to a discussion of the DBSS. The image i/o (IMIO) +interface and the image database interface (IDBI) are existing interfaces +which are more properly described in detail elsewhere. + +.nh 4 +Image Templates + + Most IRAF image operators are set up to operate on a group of images, +rather than a single image. Membership in such a group is determined at +runtime by a so-called \fIimage template\fR which may select any subset +of the images in the database, i.e., and subset of images from any subset +of \fIimage\fR type base tables. This type of group should not be confused +with the \fIgroup format\fR discussed in the last section. The image template +is normally entered by the user on the command line and is dynamically +converted into a list of images by expansion of the template on the current +contents of the database. + +Given an image template the IRAF applications program calls an IMIO routine +to "open" the template. Successive calls to a get image name routine are made +to operate upon the individual images in the group. When all images have been +processed the template is closed. + +The images in a group defined by an image template must exist by definition +when the template is expanded, hence the named images must either be input +images or the operation must update or delete the named images. If an +output image is to be produced for each input image the user must supply the +name of the table into which the new images are to be inserted. This is +exactly the same type of operation performed by the DBMS operators, and in +fact most image operators are relational operators, i.e., they take a +relation as input and produce a new relation as output. Note that the user +is required to supply only the name of the output table, not the names of +the individual images. The output table may be one of the input tables if +desired. + +An image template is syntactically equivalent to a DBIO record selection +expression with one exception: each image name may optionally be modified +by appending an \fIimage section\fR to specify the subset of the pixels in +the image to be operated upon. An example of an image section string is +"[*,100]"; this references column 100 of the associated image. The image +section syntax is discussed in detail in the \fICL User's Guide\fR. + +Since the image template syntax is nearly identical to the general DBIO record +selection syntax the reader is referred to the discussion of the latter syntax +presented in section 4.5.6 for further details. The new DBIO syntax is largely +upwards compatible with the image template syntax currently in use. + +.nh 4 +Image Pixel Access + + IMIO provides quite sophisticated pixel access facilities which it is +beyond the scope of the present document to discuss in detail. Complete +data independence is provided, i.e., the applications program in general +need not know the actual dimensionality, size, datatype, or storage mode +of the image, what format the image is stored in, or even what device or +machine the image resides on. This is not to say that the application is +forbidden from knowing these things, since more efficient i/o is possible +if there is a match between the logical and physical views of the data. + +Pixel access via IMIO is via the FIO interface. The DBSS is charged with +management of the pixel storage file (if any) and with setting up the +FIO interface so that IMIO can access the pixels. Both buffered and virtual +memory mapped access is supported; which is actually used is transparent to +the user. The types of i/o operations provided are "get", "put", and "update". +The objects upon which i/o may be performed are image lines, image columns, +N-dimensional subrasters, and pixel lists. + +New in the DBIO based version of IMIO are update mode and column and pixel +list i/o, plus direct access via virtual memory mapping using the static file +driver. + +.nh 4 +Image Database Interface (IDBI) + + The image database interface is a simple keyword based interface to the +(non array valued) fields of the standard image header. The IDBI isolates +the image oriented applications program from the method used to store the +header, i.e., programs which access the header via the IDBI don't care whether +the header is implemented upon DBIO or some other record i/o interface. +In particular, the IDBI is an existing interface which is \fInot\fR currently +implemented upon DBIO, but which will be converted to use DBIO when it becomes +available. Programs which currently use the IDBI should require few if any +changes when DBIO is installed. + +The philosophy of isolating the applications program using IMIO from the +underlying interfaces is followed in all the subpackages forming the IMIO +interface. Additional IMIO subpackages are provided for appending history +records, creating and reading histograms, and so on. + +.nh 3 +Summary of IMIO Data Structures + + As we have seen, an image is represented as a record in a table in some +database. The image record consists of a set of standard fields, a set of +user defined fields, and the pixel segment, or at least sufficient information +to locate and access the pixel segment if it is stored externally. +An image database may contain a number of other tables; these are summarized +below. + + +.ks +.nf + Image storage (a set of tables named by the user) + groups Header records for group format data + histograms Histograms of images or image sections + history Image history records + masks Region masks + wcs World coordinate systems +.fi +.ke + + +Any number of additional application specific tables may be present in an +actual database. The names of the application and user defined tables must +not conflict with the reserved table names shown above (or with the names of +the DBIO system tables discussed in the next section). The pixel segment of +an image and possibly the image header may be stored in a non-DBSS format +accessed via the HDBI. All the other tables are stored in the standard DBSS +format. + +.nh 2 +The DBIO Interface +.nh 3 +Overview + + The database i/o (DBIO) interface is the interface by which all compiled +programs directly or indirectly access data maintained by the DBSS. DBIO is +primarily a high level record manager interface. DBIO defines the logical +structure of a database and directly implements most of the operations +possible upon the objects in a database. + +The major functions of DBIO are to translate a record select/project expression +into a series of physical record accesses, and to provide the applications +program with access to the contents of the specified records. DBIO hides the +the physical structure and contents of the stored records from the applications +program; providing data independence is one of the major concerns of DBIO. +DBIO is not directly concerned with the physical storage of tables and records +in mass storage, nor with the methods used to physically access such objects. +The latter operations, i.e., the \fIaccess method\fR, are provided by a database +kernel (DBK). + +We first review the philosophy underlying the design of DBIO, and discuss +how DBIO differs from most commercial database systems. Next we describe +the logical structure of a database and introduce the objects making up a +database. The method used to define an actual database is described, +followed by a description of the methods used to access the contents of a +database. Lastly we describe the mapping of a DBIO database into physical +files. + +.nh 3 +Comparision of DBIO and Commercial Databases + + The design of the DBIO interface is based on a thorough study of existing +database systems (most especially System-R, DB2 and INGRES). It was clear from +the beginning that these systems were not ideally suited to our application, +even if the proprietary and portability issues were ignored. Eventually the +differences between these commercial database systems and the system we need +became clear. The differences are due to a change in focus and emphasis as +much as to the obvious differences between scientific and commercial +applications, and are summarized below. +.ls 4 +.ls o +The commercial systems are not sufficiently flexible in the types of data that +can be stored. In particular these systems do not in general support variable +length arrays of arbitrary datatype; most do not support even static arrays. +Only a few systems allow new attributes to be added to existing tables. +Most systems talk about domains but few implement them. We need both array +storage and the ability to dynamically add new attributes, and it appears that +domains will be quite useful as well. +.le +.ls o +Most commercial systems emphasize the query language, which forms the basis +for the host language interface as well as the user interface. The query +language is the focus of these systems. In our case the DBSS is embedded +within IRAF as one of many subsystems. While we do need query language +facilities at the user level, we do not need such sophisticated facilities +at the DBIO level and would rather do without the attendant complexity and +overhead. +.le +.ls o +Commercial database systems are designed for use in a multiuser transaction +processing environment. Many users may simultaneously be performing update +and revtrieval operations upon a single centralized database. The financial +success of the company may well depend upon the integrity of the database. +Downtime can be very expensive. + +In contrast we anticipate having many independent databases. These will be +of two kinds: public and private. The public databases will virtually always be +accessed read only and the entire database can be locked for exclusive access +if it should ever need updating. Only the private databases are subject to +heavy updating; concurrent access is required for background jobs but the +granularity of locking can be fairly coarse. If a database should become +corrupted it can be fixed at leisure or even regenerated from scratch without +causing great hardship. Concurrency, integrity, and recovery are therefore +less important for our applications than in a commercial environment. +.le +.ls o +Most commercial database systems (with the exception of the UNIX based INGRES) +are quite machine, device, and host system dependent. In our case portability +of both the software and the data is a primary concern. The requirement that +we be able to archive data in a machine independent format and read it on a +variety of machines seems to be an unusual one. +.le +.le + + +In summary, we need a simple interface which provides flexibility in the way +in which data can be stored, and which supports complex, dynamic data structures +containing variable length arrays of any datatype and size. The commercial +database systems do not provide enough flexibility in the types of data +structures they can support, nor do they provide enough flexibility in storage +formats. On the other hand, the commercial systems provide a more sophisticated +host language interface than we need. DBIO should therefore emphasize flexible +data structures but avoid a complex syntax and all the problems that come with +such. Concurrency and integrity are important but are not the major concerns +they would be in a commercial system. + +.nh 3 +Query Language Interface + + We noted in the last section that DBIO should be a simple record manager +type interface rather than an embedded query language type interface. This +approach should yield the simplest interface meeting our primary requirements. +Nonetheless a host language interface to the query language is possible and +can be added in the future without compromising the present DBIO interface +design. + +The query language will be implemented as a conventional CL callable task in +the DBMS package. Command input to the query language will be interactively +via the terminal (the usual case), or noninteractively via a string type +command line argument or via a file. Any compiled program can send commands +to the query language (or to any CL task) using the CLIO \fBclcmd\fR procedure. +Hence a crude but usable HLI query language interface will exist as soon as +a query language becomes available. A true high level embedded query language +interface could be built using the same interface internally, but this should +be left to some future compiled version of SPP rather than attempted with the +current preprocessor. We have no immediate plans to build such an embedded +query language interface but there is nothing in the current design to hinder +such a project should it someday prove worthwhile. + +.nh 3 +Logical Schema + + In this section we present the logical schema of a DBIO database. +A DBIO database consists of a set of \fBsystem tables\fR and a set of +\fBuser tables\fR. The system tables define the structure of the database +and its contents; the user tables contain user data. All tables are instances +of named \fBrelations\fR or \fBviews\fR. Relations and views are ordered +collections of \fBattributes\fR or \fBgroups\fR of attributes. Each attribute +is defined upon some particular \fBdomain\fR. The structure of the objects +in a database is defined at runtime by processing a specification written in +the \fBdata definition language\fR. + +.nh 4 +Databases + + A DBIO database is a collection of named tables. All databases include +a standard set of \fBsystem tables\fR defining the structure and contents +of the database. Any number of user or application defined tables may also +be present in the database. The most important system table is the database +\fIcatalog\fR which includes a record describing each user or system table +in the database. + +Conceptually a database is similar to a directory containing files. The catalog +corresponds to the directory and the tables correspond to the files. +A database is however a different type of object; there need be no obvious +connection between the objects in a database and the physical directories and +files used to store a database, e.g., several tables might be stored in one +file, one table might be stored in many files, the tables might be stored on +a special device and not in files at all, and so on. + +In general the mapping of tables into physical objects is hidden from the user +and is not important. The only exception to this is the association of a +database with a specific FIO directory. The mapping between databases and +directories is one to one, i.e., a directory may contain only one database, +and a database is contained in a single directory. An entire database can +be physically moved, copied, backed up, or restored by merely performing a +binary copy of the contents of the directory. DBIO dynamically generates all +file names relative to the database directory, hence moving a database to +a different directory is harmless. + +To hide the database directory from the user DBIO supports the concept of a +\fBcurrent database\fR in much the way that FIO supports the concept of a +current directory. Tables are normally referenced by name, e.g., "ptable masks" +without explicitly naming the database (i.e., directory) in which the table +resides. The current database is maintained independently of the current +directory, allowing the user to change directories without affecting the +current database. This is particularly useful when accessing public databases +(maintained in a write protected directory) or when accessing databases which +reside on a remote node. To list the contents of the current database the +user must type "pcat" rather than "dir". The current database defaults to +the current directory until the user explicitly sets the current database +with the \fBchdb\fR command. + +Databases are referred to by the filename of the database directory. +The IRAF system will provide a "master catalog" of public databases, +consisting of little more than a set of CL environment definitions assigning +logical names to the database directories. Whenever possible logical names +should be used rather than pathnames to hide the pathname of the database. + +.nh 4 +System Tables + + The structure and contents of a DBIO database are described by the same +table mechanism used to maintain user data. DBIO automatically maintains +the system tables, which are normally protected from writing by the user +(the system tables can be manually updated like any other table in a desperate +situation). Since the system tables are ordinary tables, they can be +inspected, queried, etc., using the same utilities used to access the user +data tables. The system tables are summarized below. +.ls 4 +.ls 12 syscat +The database catalog. +Contains an entry (record) for every table or view in the database. +.le +.ls sysatt +The attribute list table. +Contains an entry for every attribute in every table in the database. +.le +.ls sysddt +The domain descriptor table. +Contains an entry for every defined domain in the database. Any number of +attributes may share the same domain. +.le +.ls sysidt +The index descriptor table. +Contains an entry for every primary or secondary index in the database. +.le +.le + + +The system tables are visible to the user, i.e., they appear in the database +catalog. Like the user tables, the system tables are themselves described by +entries in the database catalog, attribute list table, and domain descriptor +table. + +.nh 4 +The System Catalog + + The \fBsystem catalog\fR is effectively a "table of contents" for the +database. The fields of the catalog relation \fBsyscat\fR are as follows. +.ls 4 +.ls 12 table +The name of the user or system table described by the current record. +Table names may contain any combination of the alphanumeric characters, +underscore, or period and must not exceed 32 characters in length. +.le +.ls relid +The table identifier. A unique integer code by which the table is referred +to internally. +.le +.ls type +Identifies the type of table, e.g., base table or view. +.le +.ls ncols +The number of columns (attributes) in the table. +.le +.ls nrows +The number of rows (records, tuples) in the table. +.le +.ls rsize +The size of a record in bytes, not including array storage. +.le +.ls tsize +An estimate of the total number of bytes of storage currently in use by the +table, including array storage. +.le +.ls ctime +The date and time when the table was created. +.le +.ls mtime +The date and time when the table was last modified. +.le +.ls flags +A small integer containing flag bits used internally by DBIO. +These include the protection bits for the table. Initially only write +protection and delete protection will be supported (for everyone). +Additional protections are of course provided by the file system. +A flag bit is also used to indicate that the table has one or more +indexes, to avoid an unnecessary search of the \fBsysidx\fR table when +accessing an unindexed table. +.le +.le + + +Only a subset of these fields will be of interest to the user in ordinary +catalog listings. The \fBpcatalog\fR task will by default print only the +most interesting fields. Any of the other DBMS output tasks may be used +to inspect the catalog in detail. + +.nh 4 +Relations + + A \fBrelation\fR is an ordered set of named attributes, each of which is +defined upon some specific domain. A \fBbase table\fR is a named instance +of some relation. A base table is a real object like a file; a base table +appears in the catalog and consumes storage on disk. The term "table" is +more general, and is normally used to refer to any object which can be +accessed like a base table. + +A DBIO relation is defined by a set of records describing the attributes +of the relation. The attribute lists of all relations are stored in the +\fBsysatt\fR table, described in the next section. + +.nh 4 +Attributes + + An \fBattribute\fR of a relation is a datum which describes some aspect +of the object described by the relation. Each attribute is defined by a +record in the \fBsysatt\fR table, the fields of which are described below. +The attribute descriptor table, while visible to the user if they wish to +examine the structure of the database in detail, is primarily an internal +table used by DBIO to define the structure of a record. +.ls 4 +.ls 12 name +The name of the attribute described by the current record. +Attribute names may contain any combination of the alphanumeric characters +or underscore and must not exceed 16 characters in length. +.le +.ls attid +The attribute identifier. A unique integer code by which the attribute is +referred to internally. The \fIattid\fR is unique within the relation to +which the attribute belongs, and defines the ordering of attributes within +the relation. +.le +.ls relid +The relation identifier of the table to which this attribute belongs. +.le +.ls domid +The domain identifier of the domain to which this attribute belongs. +.le +.ls dtype +A single character identifying the atomic datatype of this attribute. +Note that domain information is not used for most runtime record accesses. +.le +.ls prec +The precision of the atomic datatype of this attribute, i.e., the number +of bytes of storage per element. +.le +.ls count +The number of elements of type \fIdtype\fR in the attribute. If this value +is one the attribute is a scalar. Zero implies a variable length array +and N denotes a static array of N elements. +.le +.ls offset +The offset of the field in bytes from the start of the record. +.le +.ls width +The width of the field in bytes. All fields occupy a fixed amount of space +in a record. In the case of variable length arrays fields \fBoffset\fR and +\fBwidth\fR refer to the array descriptor. +.le +.le + + +In summary, the attribute list defines the physical structure of a record +as stored in mass storage. DBIO is responsible for encoding and decoding +records as well as for all access to the fields of records. A record is +encoded as a byte stream in a machine independent format. The physical +representation of a record is discussed further in a later section describing +the DBIO storage structures. + +.nh 4 +Domains + + A domain is a restricted implementation of an abstract datatype. +Simple examples are the atomic datatypes char, integer, real, etc.; no doubt +these will be the most commonly used domains. A more interesting example is +the \fItime\fR domain. Times are stored in DBIO as attributes defined upon +the \fItime\fR domain. The atomic datatype of a time attribute is a four byte +integer; the value is the long integer value returned by the IRAF system +procedure \fBclktime\fR. Integer time values are convenient for time domain +arithmetic, but are not good for printed output. The definition of the +\fItime\fR domain therefore includes a specification for the output format +which will cause time attributes to be printed as a formatted date/time string. + +Domains are used to verify input and to format output, hence there is no +domain related overhead during record retrieval. The only exception to +this rule occurs when returning the value of an uninitialized attribute, +in which case the default value must be fetched from the domain descriptor. + +Domains may be defined either globally for the entire database or locally for +a specific table. Attributes in any table may be defined upon a global domain. +The system table \fBsysddt\fR defines all global and local domains. +The attributes of this table are outlined below. +.ls 4 +.ls 12 name +The name of the domain described by the current record. +Domain names may contain any combination of the alphanumeric characters +or underscore and must not exceed 16 characters in length. +.le +.ls domid +The domain identifier. A unique integer code by which the domain is referred +to internally. The \fIdomid\fR is unique within the table for which the domain +is defined. +.le +.ls relid +The relation identifier of the table to which this domain belongs. +This is set to zero if the domain is defined globally. +.le +.ls grpid +The group identifier of the group to which this domain belongs. +This is set to zero if the domain does not belong to a special group. +A negative value indicates that the named domain is itself a group +(groups are discussed in the next section). +.le +.ls dtype +A single character identifying the atomic datatype upon which the domain +is defined. +.le +.ls prec +The precision of the atomic datatype of this domain, i.e., the number +of bytes of storage per element. +.le +.ls defval +The default value for attributes defined upon this domain (a byte string of +length \fIprec\fR bytes). If no default value is specified DBIO will assume +that null values are not permitted for attributes defined upon this domain. +.le +.ls minval +The minimum value permitted. This attribute is used only for integer or real +valued domains. +.le +.ls maxval +The maximum value permitted. This attribute is used only for integer or real +valued domains. +.le +.ls enumval +If the domain is string valued with a fixed number of permissible value strings, +the legal values may be enumerated in this string valued field. +.le +.ls units +The units label for attributes defined upon this domain. +.le +.ls format +The default output format for printed output. All SPP formats are supported +(e.g., including HMS, HM, octal, etc.) plus some special DBMS formats, e.g., +the time format. +.le +.ls width +The field width in characters for printed output. +.le +.le + + +Note that the \fIunits\fR and \fIformat\fR fields and the four "*val" fields +are stored as variable length character arrays, hence there is no fixed limit +on the sizes of these strings. Use of a variable length field also minimizes +storage requirements and makes it easy to test for an uninitialized value. +Only fixed length string fields and scalar valued numeric fields may be used +in indexes and selection predicates, however. + +A number of global domains are predefined by DBIO. These are summarized +in the table below. + + +.ks +.nf + NAME DTYPE PREC DEFVAL + + byte u 1 0 + char c arb nullstr + short i 2 INDEFS + int i 4 INDEFI + long i 4 INDEFL + real r 4 INDEFR + double r 8 INDEFD + time i 4 0 +.fi +.ke + + +The predefined global domains, as well as all user defined domains, are defined +in terms of the four DBK variable precision atomic datatypes. These are the +following: + + +.ks +.nf + NAME DTYPE PREC DESCRIPTION + + char c >=1 character + uint u 1-4 unsigned integer + int i 1-4 signed integer + real r 2-8 floating point +.fi +.ke + + +DBIO stores records with the field values encoded in the machine independent +variable precision DBK data format. The precision of an atomic datatype is +specified by an integer N, the number of bytes of storage to be reserved for +the value. The permissible precisions for each DBK datatype are shown in +the preceding table. The actual encoding used is designed to simplify the +semantics of the DBK and is not any standard format. The DBK binary encoding +will be described in a later section. + +.nh 4 +Groups + + A \fBgroup\fR is a logical grouping of several related attributes. +A group is much like a relation except that a group is a type of domain +and may be used as such to define the attributes of relations. Since groups +are similar to relations groups are defined in the \fBsysatt\fR table +(groups do not however appear in the system catalog). Each member of a +group is an attribute defined upon some domain; nesting of groups is permitted. + +Groups are expanded when a relation is defined, hence the runtime system +need not be aware of groups. Expansion of a group produces a set of ordinary +attributes wherein each attribute name consists of the group name glued +to the member name with a period, e.g., the resolved attributes "cv.ncoeff" +and "cv.type" are the result of expansion of a two-member group attribute +named "cv". + +The main purposes of the group construct are to simplify data definition and +to give the forms generator additional information for structuring formatted +output. Groups provide a simple capability for structuring data within a table. +Whenever the same grouping of attributes occurs in several tables the group +mechanism should be used to ensure that all instances of the group are +defined equivalently. + +.nh 4 +Views + + A \fBview\fR is a virtual table defined in terms of one or more base +tables or other views via a record select/project expression. Views provide +different ways of looking at the same data; the view mechanism can be very +useful when working with large, complex base tables (it saves typing). +Views allow the user to focus on just the data that interests them and ignore +the rest. The view mechansism also significantly increases the amount of data +independence provided by DBIO, since a base table can be made to look +differently to different applications programs without physically modifying +the table or producing several copies of the same table. This capability can +be invaluable when the tables involved are very large or cannot be modified +for some reason. + +A view provides a "window" into one or more base tables. The window is +dynamic in the sense that changes to the underlying base tables are immediately +visible through the window. This is because a view does not contain any data +itself, but is rather a \fIdefinition\fR via record selection and projection +of a new table in terms of existing tables. For example, consider the +following imaginary select/project expression (SPE): + + data1 [x >= 10 and x <= 20] % obj, x, y + +This defines a new table with attributes \fIobj\fR, \fIx\fR, and \fIy\fR +consisting of all records of table \fIdata1\fR for which X is in the range +10 to 20. We could use the SPE shown to copy the named fields of the +selected records to produce a new base table, e.g. \fId1x\fR. +The view mechanism allows us to define table \fId1x\fR as a view-table, +storing only the SPE shown. When the view-table \fId1x\fR is subsequently +queried DBIO will \fImerge\fR the SPE supplied in the new query with that +stored in the view, returning only records which satisfy both selection +expressions. This works because the output of an SPE is a table and can +therefore be used as input to another SPE, i.e., two or more selection +expressions can be combined to form a more complex expression. + +A view appears to the user (or to a program) as a table, behaving equivalently +to a base table in most operations. View-tables appear in the catalog and +can be created and deleted much like ordinary tables. + +.nh 4 +Null Values + + Null valued attributes are possible in any database system; they are +guaranteed to occur when the system permits new attributes to be dynamically +added to existing, nonempty base tables. DBIO deals with null values by +the default value mechanism mentioned earlier in the discussion of domains. +When the value of an uninitialized attribute is referenced DBIO automatically +supplies the user specified default value of the attribute. The defaulting +mechanism supports three cases; these are summarized below. +.ls 4 +.ls o +If null values are not permitted for the referenced attribute DBIO will +return an error condition. This case is indicated by the absence of a +default value. +.le +.ls o +Indefinite (or any special value) may be returned as the default value if +desired, allowing the calling program to test for a null value. +.le +.ls o +A valid default value may be returned, with no checking for null values +occurring in the calling program. +.le +.le + + +Testing for null values in predicates is possible only if the default value +is something recognizable like INDEF, and is handled by the conventional +equality operator. Indefinites are propagated in expressions by the usual +rules, i.e., the result of any arithmetic expression containing an indefinite +is indefinite, order comparison where an operand is indefinite is illegal, +and equality or inequality comparison is legal and is well defined. + +.nh 3 +Data Definition Language + + The data definition language (DDL) is used to define the objects in a +database, e.g., during table creation. The function of the DBIO table +creation procedure is to add tuples to the system tables to define a new +table and all attributes, groups, and domains used in the table. The data +definition tuples can come from either of two sources: [1] they can be +copied in compiled form from an existing table, or [2] they can be +generated by compilation of a DDL source specification. + +In appearance DDL looks much like a series of structure declarations such +as one finds in most modern compiled languages. DDL text may be entered +either via a string buffer in the argument list (no file access required) +or via a text file named in the argument list to the table creation procedure. + +The DDL syntax has not yet been defined. An example of what a DDL declaration +for the IMIO \fImasks\fR relation might look like is shown below. The syntax +shown is a generalization of the SPP+ syntax for a structure declaration with +a touch of the CL thrown in. If a relation is defined only in terms of the +predefined domains or atomic datatypes and has no primary key, etc., then the +declaration would look very much like an SPP+ (or C) structure declaration. + + +.ks +.nf + relation masks { + u2 mask { width=6 } + c64 image { defval="", format="%20.20s", width=21 } + c15 type { defval="generic" } + byte naxis + long naxis1, naxis2, naxis3, naxis4 + long npix + i2 pixels[] + } where { + key = mask+image+type + comment = "image region masks" + } +.fi +.ke + + +The declaration shown identifies the primary key for the relation and gives +a comment describing the relation, then declares the attributes of the +relation. In this example all domains are either local and are declared +implicitly, or they are global and are predefined. For example, DBIO will +automatically create a domain named "type" belonging to the relation "masks" +for the attribute named "type". DBIO is assumed to provide default values +for the attributes of each domain (e.g., "format", "width", etc.) not +specified explicitly in the declaration. It should be possible to keep +the DDL syntax simple enough that a LALR parser does not have to be used, +reducing text memory requirements and the time required to process the DDL, +and improving error diagnostics. + +.nh 3 +Record Select/Project Expressions + + Most programs using DBIO will be relational operators, taking a table +as input, performing some operation or transformation upon the table, and +either updating the table or producing a new table as output. DBIO record +select/project expressions (SPE) are used to define the input table. +By using an SPE one can define the input table to be any subset of the +fields (projection) of any subset of the records (selection) of any set of +base tables or views (set union). + +The general form of a select/project expression is shown below. The syntax +is patterned after the algebraic languages and even happens to be upward +compatible with the existing IMIO image template syntax. + + +.ks +.nf + tables [pred] [upred] % fields + +where + + tables Is a comma delimited list of tables. + + , Is the set union operator (in the tables and + fields lists). + + [ Is the selection operator. + + pred Is a predicate, i.e., a boolean condition. + The simplest predicate is a constant or + list of constants, specifying a set of + possible values for the primary key. + + upred Is a user predicate, passed back to the + calling program appended to the record + name but not used by DBIO. This feature + is used to implement image sections. + + % Is the projection operator. + + fields Is a comma delimited list of \fIexpressions\fR + defined upon the attributes of the input + relation, defining the attributes of the + output relation. +.fi +.ke + + +All components of an SPE are optional except \fItables\fR; the simplest +SPE is the name of a single table. Some simple examples follow. + +.nh 4 +Examples + + Print all fields of table \fInite1\fR. The table \fInite1\fR is an image +table containing several images with primary keys 1, 2, 3, and so on. + + cl> ptable nite1 + +Print selected fields of table \fInite1\fR. + + cl> ptable nite1%image,title + +Plot line 200 of image 2 in table \fInite1\fR. + + cl> graph nite1[2][*,200] + +Print image statistics on the indicated images in table \fInite1\fR. +The example shows a predicate specifying images 1, 3, and 5 through 12, +not an image section. + + cl> imstat nite1[1,3,5:12] + +Print the names and number of bad pixels in tables \fInite1\fR and \fIm87\fR +for all images that have any bad pixels. + + cl> ptable "nite1,m87 [nbadpix > 0] % image, nbadpix" + + +The tables in an SPE may be general select/project expressions, not just the +names of base tables or views as in the examples. In other words, SPEs +may be nested, using parenthesis around the inner SPE if necessary to indicate +the order of evaluation. As noted earlier in the discussion of views, +the ability of SPEs to nest is used to implement views. Nesting may also +be used to perform selection or projection upon the individual input tables. +For example, the SPE used in the following command specifies the union of +selected records from tables \fInite1\fR and \fInite2\fR. + + cl> imstat nite1[1,8,21:23],nite2[9] + +.nh 3 +Operators diff --git a/sys/dbio/new/dbio.hlp.1 b/sys/dbio/new/dbio.hlp.1 new file mode 100644 index 00000000..202b4488 --- /dev/null +++ b/sys/dbio/new/dbio.hlp.1 @@ -0,0 +1,346 @@ +.help dbio Jul85 "Database I/O Design" +.ce +\fBIRAF Database I/O\fR +.ce +Conceptual Design +.ce +Doug Tody +.ce +July 1985 +.sp 3 +.nh +Introduction + The DBIO (database i/o) interface is a library of SPP callable procedures +used to access data structures maintained in mass storage. While DBIO is at +the heart of the IRAF database subsystem, it is only a part of that subsystem. +Other major components of the database subsystem include the IMIO interface +(image i/o), a higher level interface used to access bulk data maintained +in part under DBIO, and the DBMS package (data base management system), a CL +level package providing the user with direct access to any database maintained +under DBIO. Additional structure is found beneath DBIO; this is for the most +part invisible to both the programmer and the user but is of fundamental +importance to the design, as we shall see later. +.ks +.nf + DBMS (cl) + \ --------- + \ IMIO + \ / \ + \ / \ + \/ \ (vos) + DBIO FIO + | + | --------- + | + (DB kernel) (vos or host) +.fi +.ce +Figure 1. Major Interfaces +.ke + +.nh +Requirements + The requirements for the DBIO interface are driven by its intended usage +for image and catalog storage. It is arguable whether the same interface +should be used for both types of data, but development of an interface such +as DBIO with all the associated DBMS utilities is expensive, hence we would +prefer to have to develop only one such interface. Furthermore, it is desirable +for the user to only have to learn one such interface. The primary functional +and performance requirements which DBIO must meet are the following (in no +particular order). +.ls +.ls [1] +DBIO shall provide a high degree of data independence, i.e., a program +shall be able to access a data structure maintained under DBIO without +detailed knowledge of its contents. +.le +.ls [2] +A DBIO datafile shall be self describing and self contained, i.e., it shall +be possible to examine the structure and contents of a DBIO datafile without +prior knowledge of its structure or contents. +.le +.ls [3] +DBIO shall be able to deal efficiently with records containing up to N fields +and with data groups containing up to M records, where N and M are at least +sysgen configurable and are order of magnitude N=10**2 and M=10**6. +.le +.ls [4] +The time required to access an image header under DBIO must be comparable +to the time currently required for the equivalent operation under IMIO. +.le +.ls [5] +It shall be possible for an image header maintained under DBIO to contain +application or user defined fields in addition to the standard fields +required by IMIO. +.le +.ls [6] +It shall be possible to dynamically add new fields to an existing image header +(or to any DBIO record). +.le +.ls [7] +It shall be possible to group similar records together in the database +and to perform global operations upon all or part of the records in a +group. +.le +.ls [8] +It shall be possible for a field of a record to be a one-dimensional array +of any of the primitive types. +.le +.ls [9] +Variant records (records containing variable size fields) shall be supported, +ideally without penalizing efficient access to databases which do not contain +such records. +.le +.ls [A] +It shall be possible to copy a record without knowledge of its contents. +.le +.ls [B] +It shall be possible to merge (join) two records containing disjoint sets of +fields. +.le +.ls [C] +It shall be possible to update a record in place. +.le +.ls [D] +It shall be possible to simultaneously access (retrieve, update, or insert) +multiple records from the same data group. +.le +.le +To summarize, the primary requirements are data independence, efficient access +to both large and small databases, and flexibility in the contents of the +database. +.nh +Conceptual Design + + The DBIO database faciltities shall be based upon the relational model. +The relational model is preferred due to its simplicity (to the user) +and due to the demonstrable fact that relational databases can efficiently +handle large amounts of data. In the relational model the database appears +to be nothing more than a set of \fBtables\fR, with no builtin connections +between separate tables. The operations defined upon these tables are based +upon the relational algebra, which is in turn based upon set theory. +The major advantages claimed for relational databases are the simplicity +of the concept of a database as a collection of tables, and the predictability +of the relational operators due to their being based on a formal theoretical +model. +None of the requirements listed in section 2 state that DBIO must implement +a relational database. Most of our needs can be met by structuring our data +according to the relational data model (i.e., as tables), and providing a +good \fBselect\fR operator for retrieving records from the database. If a +semirelational database is sufficient to meet our requirements then most +likely that is what will be built (at least initially; the relational operators +are very attractive for data analysis). DBIO is not expected to be competitive +with any commercial relational database; to try to make it so would probably +compromise the requirement that the interface be compact. +On the other hand, the database requirements of IRAF are similar enough to +those addressed by commercial databases that we would be foolish not to try +to make use of some of the same technology. +.ks +.nf + \fBformal relational term\fR \fBinformal equivalents\fR + relation table + tuple record, row + attribute field, column + domain datatype + primary key record id +.fi +.ke +A DBIO \fBdatabase\fR shall consist of one or more \fBrelations\fR (tables). +Each relation shall contain zero or more \fBrecords\fR (rows of the table). +Each record shall contain one or more \fBfields\fR (columns of the table). +All records in a relation shall share the same set of fields, +but all of the fields in a record need not have been assigned values. +When a new \fBattribute\fR (column) is added to an existing relation a default +valued field is added to each current and future record in the relation. +Each attribute is defined upon a particular \fBdomain\fR, e.g., the set of +all nonnegative integer values less than or equal to 100. It shall be possible +to specify minimum and maximum values for integer and real attributes +and to enumerate the permissible values of a string type attribute. +It shall be possible to specify a default value for an attribute. +If no default value is given INDEF is assumed. +One dimensional arrays shall be supported as attribute types; these will be +treated as atomic datatypes by the relational operators. Array valued +attributes shall be either fixed in size (the most efficient form) or variant. +There need be no special character string datatype since one dimensional +arrays of type character are supported. +Each relation shall be implemented as a separate file. If the relations +comprising a database are stored in a directory then the directory can +be thought of as the database. Public databases will be stored in well +known public (write protected) directories, private databases in user +directories. The logical directory name of each public database will be +the name of the database. Physical storage for a database need not necessarily +be allocated locally, i.e., a database may be centrally located and remotely +accessed if the host computer is part of a local area network. +Locking shall be at the level of entire relations rather than at the record +level, at least in the initial implementation. There shall be no support for +indices in the initial implementation except possibly for the primary key. +It should be possible to add either or both of these features to a future +implementation without changing the basic DBIO interface. Modifications to +the internal data structures used in database files will likely be necessary +when adding such a major feature, making a save and restore operation +necessary for each database file to convert it to the new format. +The save format chosen (e.g. FITS table) should be independent of the +internal format used at a particular time on a particular host machine. +Images shall be stored in the database as individual records. +All image records shall share a common subset of attributes. +Related images (image records) may be grouped together to form relations. +The IRAF image operators shall support operations upon relations +(sets of images) much as the IRAF file operators support operations upon +sets of files. +A unary image operator shall take as input a relation (set of one or more +images), inserting the processed images into the output relation. +A binary image operator shall take as input either two relations or a +relation and a record, inserting the processed images into the output +relation. In all cases the output relation can be an input relation as +well. The input relation will be defined either by a list or by selection +using a theta-join (operationally similar to a filename template). +.nh 2 +Relational Operators + DBIO shall support two basic types of database operations: operations upon +relations and operations upon records. The basic relational operators +are the following. All of these operators produce as output a new relation. +.ls +.ls create +Create a new base relation (physical relation as stored on disk) by specifying +an initial set of attributes and the (file)name for the new relation. +Attributes and domains may be specified via a data definition file or by +reference to an existing relation. +A primary key (limited to a single attribute) should be identified. +The new relation initially contains no records. +.le +.ls drop +Delete a (possibly nonempty) base relation and any associated indices. +.le +.ls alter +Add a new attribute or attributes to an existing base relation. +Attributes may be specified explicitly or by reference to another relation. +.le +.ls select +Create a new relation by selecting records from one or more existing base +relations. Input consists of an algebraic expression defining the output +relation in terms of the input relations (usage will be similar to filename +templates). The output relation need not have the same set of attributes as +the input relations. The \fIselect\fR operator shall ultimately implement +all the basic operations of the relational algebra, i.e., select, project, +join, and the set operations. At a minimum, selection and projection are +required in the initial interface. The output of \fBselect\fR is not a +named relation (base relation), but is instead intended to be accessed +by the record level operators discussed in the next section. +.le +.ls edit +Edit a relation. An interactive screen editor is entered allowing the user +to add, delete, or modify tuples (not required in the initial version of +the interface). Field values are verified upon input. +.le +.ls sort +Make the storage order of the records in a relation agree with the order +defined by the primary key (the index associated with the primary key is +always sorted but index order need not agree with storage order). +In general, retrieval on a sorted relation is more efficient than on an +unsorted relation. Sorting also eliminates deadspace left by record +deletion or by updates involving variant records. +.le +.le +Additional nonalgebraic operators are required for examining the structure +and contents of relations, returning the number of records or attributes in +a relation, and determining whether a given relation exists. +The \fIselect\fR operator is the primary user interface to DBIO. +Since most of the relational power of DBIO is bound up in the \fIselect\fR +operator and since \fIselect\fR will be driven by an algebraic expression +(character string) there is considerable scope for future enhancement +of DBIO without affecting existing code. +.nh 2 +Record (Tuple) Level Operators + While the user should see primarily operations on entire relations, +record level processing is necessary at the program level to permit +data entry and implementation of special operators. The basic record +level operators are the following. +.ls +.ls retrieve +Retrieve the next record from the relation defined by \fBselect\fR. +While the tuples in a relation theoretically form an unordered set, +tuples will normally be returned in either storage order or in the sort +order of the primary key. Although all fields of a retrieved record are +accessible, an application will typically have knowledge of only a few fields. +.le +.ls update +Rewrite the (possibly modified) current record. The updated record is +written back into the base table from which it was read. Not all records +produced by \fBselect\fR can be updated. +.le +.ls insert +Insert a new record into an output relation. The output relation may be an +input relation as well. Records added to an output relation which is also +an input relation do not become candidates for selection until another +\fBselect\fR occurs. A retrieve followed by an insert copies a record without +knowledge of its contents. A retrieve followed by modification of selected +fields followed by an insert copies all unmodified fields of the record. +The attributes of the input and output relations need not match; unmatched +output attributes take on their default values and unmatched input attributes +are discarded. \fBInsert\fR returns a pointer to the output record, +allowing insertions of null records to be followed by initialization of +the fields of the new record. +.le +.ls delete +Delete the current record. +.le +.le +Additional operators are required to close or open a relation for record +level access and to count the number of records in a relation. +.nh 3 +Constructing Special Relational Operators + The record level operations may be combined with \fBselect\fR in compiled +programs to implement arbitrary operations upon entire relations. +The basic scenario is as follows: +.ls +.ls [1] +The set of records to be operated upon, defined by the \fBselect\fR +operator, is opened as an unordered set (list) of records to be processed. +.le +.ls [2] +The "next" record in the relation is accessed with \fBretrieve\fR. +.le +.ls [3] +The application reads or modifies a subset of the fields of the record, +updating modified records or inserting the record in the output relation. +.le +.ls [4] +Steps [2] and [3] are repeated until the entire relation has been processed. +.le +.le +Examples of such operators are conversion to and from DBIO and LIST file +formats, column extraction, mimimum or maximum of an attribute (domain +algebra), and all of the DBMS and IMAGES operators. +.nh 2 +Field (Attribute) Level Operators + Substantial processing of the contents of a database is possible without +ever accessing the individual fields of a record. If field level access is +required the record must first be retrieved or inserted. Field level access +requires knowledge of the names of the attributes of the parent relation, +but not their exact datatypes. Automatic type conversion occurs when field +values are queried or set. +.ls +.ls get +.sp +Get the value of the named scalar or vector field (typed). +.le +.ls put +.sp +Put the value of the named scalar or vector field (typed). +.le +.ls read +Read the named fields into an SPP data structure, given the name, datatype, +and length (if vector) of each field in the output structure. +There must be an attribute in the parent relation for each field in the +output structure. +.le +.ls write +Copy an SPP data structure into the named fields of a record, given the +name, datatype, and length (if vector) of each field in the input structure. +There must be an attribute in the parent relation for each field in the +input structure. +.le +.ls access +Determine whether a relation has the named attribute. +.le +.le diff --git a/sys/dbio/new/dbki.hlp b/sys/dbio/new/dbki.hlp new file mode 100644 index 00000000..a825f6ef Binary files /dev/null and b/sys/dbio/new/dbki.hlp differ diff --git a/sys/dbio/new/ddl b/sys/dbio/new/ddl new file mode 100644 index 00000000..8c1256b7 --- /dev/null +++ b/sys/dbio/new/ddl @@ -0,0 +1,125 @@ +1. Data Definition Language + + Used to define relations and domains. + Table driven. + + +1.1 Domains + + Domains are used to save storage, format output, and verify input, as well +as to document the structure of a database. DBIO does not use domain +information to verify the legality of predicates. + + + attributes of a domain: + + name domain name + type atomic type + default default value (none, indef, actual) + minimum minimum value permitted + maximum maximum value permitted + enumval list of legal values + units units label + format default output format + + + predefined (atomic) domains: + + bool + byte*N + char*N + int*N + real*N + +The precision of an atomic domain is specified by N, the number of bytes of +storage to be reserved for the value. N may be any integer value greater +than or equal to N=1 for byte, char, and int, or N=2 for real. The byte +datatype is an unsigned (positive) integer. The floating point datatype +has a one byte (8 bit) base 2 exponent. For example, char*1 is a signed +byte, byte*2 is an unsigned 16 bit integer, and real*2 is a 16 bit floating +point number. + + +1.2 Groups + + A group is an aggregate of two or more domains or other groups. Groups +as well as domains may be used to define the attributes of a relation. +Repeating groups, i.e., arrays of groups, are not allowed (a finite number +of named instances of a group may however be declared within a single relation). + + + attributes of a group: + + name group name as used in relation declarations + nelements number of elements (attributes) in group + elements set of elements (see below) + + + attributes of each group element: + + name attribute name + domain domain on which attribute is defined + naxis number of axes if array valued + naxisN length of each axis if array valued + label column label for output tables + + +1.3 Relations + + A relation declaration consists of a list of the attributes forming the +relation. An attribute is a named instance of an atomic domain, user defined +domain, or group. Any group, including nested groups, may be decomposed +into a set of named instances of domains, each of which is defined upon an +atomic datatype, hence a relation declaration is decomposable into a linear +list of atomic fields. The relation is the logical unit of storage in a +database. A base table is an named instance of some relation. + + + attributes of a relation: + + name name of the relation + nattributes number of attributes + atr_list list of attributes (see below) + primary_key + title + + + attributes of each attribute of a relation: + + name attribute name + domain domain on which attribute is defined + naxis number of axes if array valued + naxisN length of each axis if array valued + label column label for output tables + + +The atomic attributes of a relation may be either scalar or array valued. +The array valued attributes may be either static (the amount of storage is +set in the relation declaration) or dynamic (a variable amount of storage +is allocated at runtime). Array valued attributes may not be used as +predicates in queries. + + +1.4 Views + + A view is a logical relation defined upon one or more base tables, i.e., +instances of named relations. The role views perform in a database is similar +to that performed by base tables, but views do not in themselves occupy any +storage. The purpose of a view is to permit the appearance of the database +to be changed to suit the needs of a variety of applications, without having +to physically change the database itself. As a trivial example, a view may +be used to provide aliases for the names of the attributes of a relation. + + + attributes of a view: + + name name of the view + nattributes number of attributes + atr_list list of attributes (see below) + + + attributes of each attribute of a view: + + name attribute name + mapping name of the table and attribute to which this + view attribute is mapped diff --git a/sys/dbio/new/schema b/sys/dbio/new/schema new file mode 100644 index 00000000..ef99ac1b --- /dev/null +++ b/sys/dbio/new/schema @@ -0,0 +1,307 @@ +1. Database Schema + + A logical database consists of a standard set of system tables describing +the database, plus any number of user data tables. The system tables are the +following: + + + syscat System catalog. Lists all base tables, views, groups, + and relations in the database. The names of all tables, + relations, views, and groups must be distinct. Note + that the catalog does not list the attributes composing + a particular base table, relation, view, or group. + + REL_atl Attribute list table. Descriptor table for the table, + relation, view, or group REL. Lists the attributes + comprising REL. One such table is required for each + relation, view, or group defined in the database. + + sysddt Domain descriptor table. Describes all user defined + domains used in the database. Note that the scope of + a domain definition is the entire database, not one + relation. + + sysidt Index descriptor table. Lists all of the indexes in + the database. + + sysadt Alias descriptor table. Defines aliases for the names + of tables or attributes. + + +In addition to the standard tables, a table is required for each relation, +view, or group listing the attributes (fields) comprising the relation, view, +or group. A base table which is an instance of a named relation is described +by the table defining the relation. If a given base table has been altered +since its creation, e.g., by the addition of new attributes, then a separate +table is required listing the attributes of the altered base table. In effect, +a new relation type is automatically defined by the database system listing the +attributes of the altered base table. + +Like the user tables, the system tables are themselves described by attribute +list tables stored in the database. The database system need only know the +structure of an attribute list table to decipher the structure of the rest of +the database. A single access method can be used to access all database +structures (excluding the indexes, which are probably not stored as tables). + + +2. Storage Structures + + A database is maintained in a single random access binary file. This one +file contains all user tables and indexes and all system tables. A single +file is used to minimize the number of file opens and disk accesses required +to access a record from a "cold start", i.e., after process startup. Use of +a single file also simplifies bookeeping for the user, minimizes directory +clutter, and aids in database backup and transport. For clarity we shall +refer to this database file as a "datafile". A datafile is a DBIO format +binary file with the extension ".db". + +What the user perceives as a database is one or more datafiles plus any +logically associated non-database files. While database tasks may +simultaneously access several databases, access will be much more efficient +when multiple records are accessed in a single datafile than when a single +record is accessed in multiple datafiles. + + +2.1 Database Design + + When designing a database the user or applications programmer must consider +the following issues: + + [1] The logical structure of the database must be defined, i.e., the + organization of the data into tables. While in many cases this is + trivial, e.g., when there is only one type of table, in general this + area of database design is nontrivial and will require the services + of a database expert familiar with the relational algebra, + normalization, the entity/relationship model, etc. + + [2] The clustering of tables into datafiles must be defined. Related + tables which are fairly static should normally be placed in the same + datafile. Tables which change a lot or which may be used for a short + time and then deleted may be best placed in separate datafiles. + If the database is to be accessed simultaneously by multiple processes, + e.g., when running background jobs, then it may be necessary to place + the input tables in read only datafiles and the output tables in + separate private access datafiles to permit concurrent access (DBIO + does not support record level locking). + + [3] The type and number of indexes required for each table must be defined. + Most tables will require some sort of index for efficient retrieval. + Maintenance of an index slows insertion, hence output tables may be + better off without an index; indexes can be added later when the time + comes to read the table. The type of index (linear, hash, or B-tree) + must be defined, and the keys used in the index must be listed. + + [4] Large text or binary files which are logically associated with the + database may be implemented as physically separate, non-database files, + saving only the name of the file in the database, or as variable length + attributes, storing the data in the database itself. Large files may + be more efficiently accessed when stored outside the database, while + small files consume less storage and are more efficiently accessed when + stored in a datafile. Storing a file outside the database complicates + database management and transport. + + +3. DBIO + + DBIO is the host language interface to the database system. The interface +is a procedural rather than query oriented interface; the query facilities +provided by DBIO are limited to select/project. DBIO is designed to be fast and +compact and hence is little more than an access method. A process typically +has direct access to a database via a high bandwidth binary file i/o interface. + +Although we will not discuss it further here, we note that a compiled +application which requires query level access to a database can send queries +to the DBMS query language via the CL, using CLCMD (the query language resides +in a separate process). This is much the same technique as is used in +commercial database packages. A formal DBIO query language interface will be +defined when the query language is itself defined. + + +3.1 Database Management Functions + + DBIO provides a range of functions for database management, i.e., operations +on the database as a whole as opposed to the access functions, used for +retrieval, update, insertion, etc. The database management functions are +summarized below. + + + open database + close database + create database initially empty + delete database + change database (change default working database) + + create table from DDL; from compiled DDT, ALT + drop table + alter table + sort table + + create view + drop view + + create index + drop index + + +A database must be opened or created before any other operations can be +performed on the database (excluding delete). Several databases may be +open simultaneously. New tables are created by any of several methods, +i.e., from a written specification in the Data Definition Language (DDL), +by inheriting the attributes of an existing table, or by successive alter +table operations, adding a new attribute to the table definition in each call. + + +3.2 Data Access Functions + + A program accesses the database record by record via a "cursor". A cursor +is a pointer into a virtual table defined by evaluating a select/project +statement upon a database. This virtual table, or "selection set", consists of +a set of record ids referencing actual records in one or more base tables. +The individual records are not physically accessed by DBIO until a fetch, +update, insert, or delete operation is performed by the applications program +upon the record currently pointed to by the cursor. + + +3.2.1 Record Level Access Functions + + The record access functions allow a program to read and write entire records +in one operation. For the sake of data independence the program must first +define the exact format of the logical record to be read or written; this +format may differ from the physical record format in the number, order, and +datatype of the fields to be accessed. The names of the fields in the logical +record must however match those in the physical record (unless aliased), +and not all datatype conversions are legal. + + + open cursor + close cursor + length cursor + next cursor element + + fetch record + update record + insert record + delete record + + get/put scalar field (typed) + get/put vector field (typed) + + +Logical records are passed between DBIO and the calling program in the form +of a binary data structure via a pointer to the structure. Storage for the +structure is allocated by the calling program. Only fixed size fields may be +passed in this manner; variable size fields are represented in the static +structure by an integer count of the current number of elements in the field. +A separate call is required to read or write the contents of a variable length +field. + +The dynamically allocated binary structure format is flexible and efficient +and will be the most suitable format for most applications. A character string +format is also supported wherein the successive fields are encoded into +successive ranges of columns. This format is useful for data entry and +forms generation, as well as for communication with foreign languages (e.g., +Fortran) which do not provide the data structuring facilities necessary for +binary record transmission. + +The functions of the individual record level access operators are discussed +in more detail below. + + + fetch Read the physical record currently pointed to by the cursor + into an internal holding area in DBIO. Return the fields of + the specified logical record to the calling program. If no + logical record was specified the only function is to copy the + physical record into the DBIO holding area. + + modify Update the internal copy of the physical record from the fields + of the logical record passed as an argument, but do not update + the physical input record. + + update Update the internal copy of the physical record from the fields + of the logical record passed as an argument, then update the + physical record in mass storage. Mass storage will be updated + only if the local copy of the record has been modified. + + insert Update the internal copy of the physical record from the fields + of the logical record passed as an argument, then insert the + physical record into the specified output table. The record + currently in the holding area is used regardless of its origin, + hence an explicit fetch is required to copy a record. + + delete The record currently pointed to by the cursor is deleted. + + +For example, to perform a select/project operation on a database one could +open a cursor on the selection set defined by the indicated select/project +statement (passed as a character string), then FETCH and print successive +records until EOF is reached on the cursor. To perform some operation on +the elements of a selection set, producing a new table as output, one might +FETCH each element, use and possibly modify the binary data structure returned +by the FETCH, and then INSERT the modified record into the output table. + +When performing an UPDATE operation on the tuples of a selection set defined +over multiple input tables, the tuples in separate input tables need not all +have the same set of attributes. INSERTion into an output table, however, +requires that the new output tuples be union compatible with the existing +tuples in the output table, or the mismatched attributes in the output tuples +will be either lost or created with null values. If the output table is a new +table the attribute list of the new table may be defined to be either the +union or intersection of the attribute lists of all tables in the selection +set used as input. + + +3.2.2 Field Level Access Functions + + The record level access functions can be cumbersome when only one or two +of the fields in a record are to be accessed. The fields of a record may be +accessed individually by typed GET and PUT procedures (e.g., DBGETI, DBPUTI) +after copying the record in question into the DBIO holding area with FETCH. + + +3.3 DBKI + + The DataBase Kernel Interface (DBKI) is the interface between DBIO and +one or more DataBase Kernels (DBK). The DBKI supports multiple database +kernels, each of which may support multiple storage formats. The DBKI does +not itself provide any database functionality, rather it provides a level +of indirection between DBIO and the actual DBK used for a given dataset. +The syntax and semantics of the procedures forming the DBKI interface are +those required of a DBK, i.e., there is a one-to-one mapping between DBKI +procedures and DBK procedures. + +A DBIO call to a DBKI procedure will normally be passed on to a DBK procedure +resident in the same process, providing maximum performance. If the DBK is +especially large, e.g., when the DBK is a host database system, it may reside +in a separate process with the DBK procedures in the local process serving +only as an i/o interface. On a system configured with network support DBKI +will also provide the capability to access a DBK resident on a remote node. +In all cases when a remote DBK is accessed, the interprocess or network +interface occurs at the level of the DBKI. Placing the interface at the +DBKI level, rather than at the FIO z-routine level, provides a high bandwidth +between the DBK and mass storage, greatly increasing performance since only +selected records need be passed over the network interface. + + +3.4 DBK + + A DBIO database kernel (DBK) provides a "record manager" type interface, +similar to the popular ISAM and VSAM interfaces developed by IBM (the actual +access method used is based on the DB2 access method which is a variation on +VSAM). The DBK is responsible for the storage and retrieval of records from +tables, and for the maintainance and use of any indexes maintained upon such +tables. The DBK is also responsible for arbitrating database access among +concurrent processes (e.g., record locking, if provided), for error recovery, +crash recovery, backup, and so on. All data access via DBIO is routed through +a DBK. In no case does DBIO bypass the DBK to directly access mass storage. + +The DBK does not have any knowledge of the contents of a record (an exception +occurs if the DBK is actually an interface to a host database system). +To the DBK a record is a byte string. Encoding and decoding of records is +performed by DBIO. The actual encoding used is machine independent and space +efficient (byte packed). Numeric fields are encoded in such a way that a +generic comparison procedure may be used for order comparisons of all fields +regardless of their datatype. This greatly simplifies both the evaluation of +predicates (e.g., in a select) and the maintenance of indexes. The use of a +machine independent encoding provides equivalent database semantics on all +machines and transparent network access without redundant encode/decode, +as well as making it trivial to transport databases between machines. diff --git a/sys/dbio/new/spie.ms b/sys/dbio/new/spie.ms new file mode 100644 index 00000000..ce380b70 --- /dev/null +++ b/sys/dbio/new/spie.ms @@ -0,0 +1,17 @@ +.TL +The IRAF Data Reduction and Analysis System +.AU +Doug Tody +.AI +National Optical Astronomy Observatories +Central Computer Services +IRAF Group +.PP +.ls 2 +The Interactive Reduction and Analysis Facility (IRAF) is a general purpose +data reduction and analysis system that has been under development by the +National Optical Astronomy Observatories (NOAO) for the past several years +and which is now in use within NOAO, at the Space Telescope Science Institute, +and at several other sites on several different computers and operating systems. +The philosophy and design goals of the IRAF system are discussed and the +facilities provided by the current system are summarized. diff --git a/sys/etc/README b/sys/etc/README new file mode 100644 index 00000000..6a1ebe0a --- /dev/null +++ b/sys/etc/README @@ -0,0 +1,4 @@ +This directory contains miscellaneous parts of the IRAF system code. +These include the error handling facilities, the IRAF Main and associated +routines (the default exception handler, and ONEXIT), environment access +facilities, and time conversion facilities. diff --git a/sys/etc/brktime.x b/sys/etc/brktime.x new file mode 100644 index 00000000..dbd94a7c --- /dev/null +++ b/sys/etc/brktime.x @@ -0,0 +1,79 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +define SECONDS_PER_DAY 86400 +define SECONDS_PER_HOUR 3600 +define SECONDS_PER_MINUTE 60 +define MONDAY 2 + +# BRKTIME -- Break a long integer time (such as returned by GETTIME or FINFO) +# into the fields of the structure defined in . The procedure is +# valid from 00:00:00 01-Jan-1980 to 23:23:59 28-Feb-2100. + +procedure brktime (ltime, tm) + +long ltime # seconds since 00:00:00 01-Jan-1980 +int tm[LEN_TMSTRUCT] # broken down time (output struct) + +long temp # working variable +long seconds # seconds in current day +long days # whole days since Monday 00-Jan-1980 +int nights # whole days since 00-Jan of current year + +int year # year counter +int days_per_year # days per year + +int month # month counter +int days_per_month[12] # days per month +data days_per_month/31,0,31,30,31,30,31,31,30,31,30,31/ + +begin + seconds = mod (ltime, SECONDS_PER_DAY) + days = ltime / SECONDS_PER_DAY + 1 + + # Break hours, minutes, seconds. + + TM_HOUR(tm) = seconds / SECONDS_PER_HOUR + temp = seconds - TM_HOUR(tm) * SECONDS_PER_HOUR + TM_MIN(tm) = temp / SECONDS_PER_MINUTE + TM_SEC(tm) = temp - TM_MIN(tm) * SECONDS_PER_MINUTE + + # Break day of week. + + TM_WDAY(tm) = mod (days + MONDAY, 7) + if (TM_WDAY(tm) == 0) + TM_WDAY(tm) = 7 + + # Break year, day of year. + + temp = 0 # whole days since 00-Jan-1980 on last day of last year + year = 1980 + days_per_year = 366 + while (days > temp + days_per_year) { + temp = temp + days_per_year + year = year + 1 + if (mod (year, 4) == 0) + days_per_year = 366 + else + days_per_year = 365 + } + TM_YEAR(tm) = year + TM_YDAY(tm) = days - temp + + # Break month, day of month. + + nights = TM_YDAY(tm) + if (mod (TM_YEAR(tm), 4) == 0) + days_per_month[2] = 29 + else + days_per_month[2] = 28 + temp = 0 # whole days since 00-Jan on last day of last month + month = 1 + while (nights > temp + days_per_month[month]) { + temp = temp + days_per_month[month] + month = month + 1 + } + TM_MONTH(tm) = month + TM_MDAY(tm) = nights - temp +end diff --git a/sys/etc/btoi.x b/sys/etc/btoi.x new file mode 100644 index 00000000..468ba352 --- /dev/null +++ b/sys/etc/btoi.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# BTOI -- Convert boolean to integer. + +int procedure btoi (boolean_value) + +bool boolean_value + +begin + if (boolean_value) + return (YES) + else + return (NO) +end diff --git a/sys/etc/clktime.x b/sys/etc/clktime.x new file mode 100644 index 00000000..84155919 --- /dev/null +++ b/sys/etc/clktime.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CLKTIME -- Get the current clock time (local standard time) in units +# of seconds since 00:00:00 01-Jan-80. This can be broken down into days, +# hours, seconds, etc. with BRKTIME, or printed as a date/time string with +# CNVTIME. + +long procedure clktime (old_time) + +long old_time, new_time +long cpu_time + +begin + call zgtime (new_time, cpu_time) + return (new_time - old_time) +end diff --git a/sys/etc/cnvdate.x b/sys/etc/cnvdate.x new file mode 100644 index 00000000..7e2cd4e9 --- /dev/null +++ b/sys/etc/cnvdate.x @@ -0,0 +1,52 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +define SZ_WEEKDAY 3 +define SZ_MONTH 3 + +# CNVDATE -- Convert a time in integer seconds since midnight on Jan 1, 1980 +# into a short string such as "May 15 18:24". The length of the output +# string is given by the parameter SZ_DATE in . Note that CNVTIME +# is also available if a longer, more informative string is desired. + +procedure cnvdate (ltime, outstr, maxch) + +long ltime # seconds since 00:00:00 01-Jan-1980 +char outstr[ARB] +int maxch + +long one_year_ago +int fd, tm[LEN_TMSTRUCT] + +long clktime() +int stropen() +string month "JanFebMarAprMayJunJulAugSepOctNovDec" +data one_year_ago /0/ +errchk stropen + +begin + if (one_year_ago == 0) + one_year_ago = clktime (0) - 3600 * 24 * (365 - 31) + + call brktime (ltime, tm) + fd = stropen (outstr, maxch, NEW_FILE) + + call fprintf (fd, "%3.3s %2d ") + call pargstr (month [(TM_MONTH(tm) - 1) * SZ_MONTH + 1]) + call pargi (TM_MDAY(tm)) + + # If time is recent (within the past year), print the time of day, + # otherwise print the year. + + if (ltime > one_year_ago) { + call fprintf (fd, "%2d:%02d") + call pargi (TM_HOUR(tm)) + call pargi (TM_MIN(tm)) + } else { + call fprintf (fd, "%5d") + call pargi (TM_YEAR(tm)) + } + + call strclose (fd) +end diff --git a/sys/etc/cnvtime.x b/sys/etc/cnvtime.x new file mode 100644 index 00000000..372daf03 --- /dev/null +++ b/sys/etc/cnvtime.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +define SZ_WEEKDAY 3 +define SZ_MONTH 3 + +# CNVTIME -- Convert a time in integer seconds since midnight on Jan 1, 1980 +# into a string, i.e., "Mon 16:30:05 17-Mar-2001". The maximum length of the +# output string is given by the parameter SZ_TIME in . + +procedure cnvtime (ltime, outstr, maxch) + +long ltime # seconds since 00:00:00 01-Jan-1980 +char outstr[ARB] +int maxch +int tm[LEN_TMSTRUCT] # broken down time structure +string weekday "SunMonTueWedThuFriSat" +string month "JanFebMarAprMayJunJulAugSepOctNovDec" + +begin + call brktime (ltime, tm) + call sprintf (outstr, maxch, "%3.3s %02d:%02d:%02d %02d-%3.3s-%04d") + call pargstr (weekday [(TM_WDAY(tm) - 1) * SZ_WEEKDAY + 1]) + call pargi (TM_HOUR(tm)) + call pargi (TM_MIN(tm)) + call pargi (TM_SEC(tm)) + call pargi (TM_MDAY(tm)) + call pargstr (month [(TM_MONTH(tm) - 1) * SZ_MONTH + 1]) + call pargi (TM_YEAR(tm)) +end diff --git a/sys/etc/cputime.x b/sys/etc/cputime.x new file mode 100644 index 00000000..b56b7280 --- /dev/null +++ b/sys/etc/cputime.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CPUTIME -- Return the difference between the current cpu time consumed +# and the argument, in long integer milliseconds. + +long procedure cputime (old_cputime) + +long old_cputime, new_cputime +long clk_time + +begin + call zgtime (clk_time, new_cputime) + return (new_cputime - old_cputime) +end diff --git a/sys/etc/doc/Proc.hlp b/sys/etc/doc/Proc.hlp new file mode 100644 index 00000000..023a5316 --- /dev/null +++ b/sys/etc/doc/Proc.hlp @@ -0,0 +1,22 @@ + Process Control + +Connected Subprocesses + + pid = propen (process, in, out) + stat = prclose (pid) + stat = prgetline (in, lbuf) + prredir (pid, stream, new_fd) + prsignal (pid, signal) + prupdate (message) + + pid = propcpr (process, in, out) + stat = prclcpr (pid) + + + +Detached Processes + + job = propdpr (process, bkgfile) + stat = prcldpr (job) + y/n = prdone (job) + prkill (job) diff --git a/sys/etc/doc/error.hlp b/sys/etc/doc/error.hlp new file mode 100644 index 00000000..7776093f --- /dev/null +++ b/sys/etc/doc/error.hlp @@ -0,0 +1,51 @@ + +.help error, fatal, errchk, erract, iferr 2 "Error Handling Strategy" +.sh +ERROR HANDLING + + A recoverable error condition is asserted with ERROR. An irrecoverable +error condition is asserted with FATAL. Error recovery is implemented +using the IFERR and IFNOERR statements in the preprocessor language. +ERRACT may be called in an IFERR statement to cause a warning to be issued, +or to cause a particular error action to be taken. ERRCODE returns either +OK or the integer code of the posted error. + +Language support includes the IFERR and IFNOERR statements and the ERRCHK +declaration. The IFERR statement is grammatically equivalent to the IF +statement. Note that the condition to be tested in an IFERR statement may +be a procedure call or assignment statement, while the IF statement tests +a boolean expression. + + +.nf + errchk proc1, proc2, ... # errchk declaration + + iferr (procedure call or assignment statement) + + + iferr { + + } then + + + +Library procedures (ERROR and FATAL cause a RETURN): + + error (errcode, error_message) + fatal (errcode, error_message) + erract (severity) + val = errcode () + + +ERRACT severity codes (): + + EA_WARN # issue a warning message + EA_ERROR # assert recoverable error + EA_FATAL # assert fatal error +.fi + + +An arithmetic exception (X_ARITH) will be trapped by an IFERR statement, +provided the posted handler(s) return without causing error restart. +X_INT and X_ACV may only be caught by posting an exception handler with +XWHEN. diff --git a/sys/etc/doc/etc.hd b/sys/etc/doc/etc.hd new file mode 100644 index 00000000..759ba4e2 --- /dev/null +++ b/sys/etc/doc/etc.hd @@ -0,0 +1,29 @@ +# Help directory for the ETC (miscellaneous system stuff) package. + +$etc = "sys$etc/" + +brktime hlp = brktime.hlp, src = etc$brktime.x +btoi hlp = btoi.hlp, src = etc$btoi.x +clktime hlp = clktime.hlp, src = etc$clktime.x +cnvdate hlp = cnvdate.hlp, src = etc$cnvdate.x +cnvtime hlp = cnvtime.hlp, src = etc$cnvtime.x +cputime hlp = cputime.hlp, src = etc$cputime.x +envgetb hlp = envget.hlp, src = etc$envgetb.x +envgeti hlp = envget.hlp, src = etc$envgeti.x +envgets hlp = envget.hlp, src = etc$envgets.x +erract hlp = erract.hlp, src = etc$erract.x +errcode hlp = errcode.hlp, src = etc$errcode.x +error hlp = error.hlp, src = etc$error.x +getuid hlp = getuid.hlp, src = etc$getuid.x +itob hlp = itob.hlp, src = etc$itob.x +lpopen hlp = lpopen.hlp, src = etc$lpopen.x +main hlp = main.hlp, src = etc$main.x +onerror hlp = onerror.hlp, src = etc$onerror.x +onexit hlp = onexit.hlp, src = etc$onexit.x +oscmd hlp = oscmd.hlp, src = etc$oscmd.x +qsort hlp = qsort.hlp, src = etc$qsort.x +sys_ptime hlp = sys_ptime.hlp, src = etc$sys_ptime.x +syserr hlp = syserr.hlp, src = etc$syserr.x +tsleep hlp = tsleep.hlp, src = etc$tsleep.x +urand hlp = urand.hlp, src = etc$urand.x +xwhen hlp = xwhen.hlp, src = etc$xwhen.x diff --git a/sys/etc/doc/etc.men b/sys/etc/doc/etc.men new file mode 100644 index 00000000..5ed6f4ad --- /dev/null +++ b/sys/etc/doc/etc.men @@ -0,0 +1,24 @@ + brktime - Convert a long integer time into year, month, day, etc. + btoi - Boolean to integer + clktime - Get the clock time + cnvdate - Convert long integer time to date string (short format) + cnvtime - Convert long integer time to time string (long format) + cputime - Get the CPU time consumed by the process + envget[bis] - Get a boolean, integer, or string valued environment variable + erract - Take an error action for a previously posted error + errcode - Get the error code of the posted error + error - Post an error and take an error action + getuid - Get the name of the runtime user of a program + itob - Convert integer to boolean + lpopen - Open the line printer as a file + main - The IRAF Main + onerror - Post a procedure to be executed if error recovery occurs + onexit - Post a procedure to be executed upon process shutdown + oscmd - Send a command to the host operating system + qsort - General quick sort for any data structure + sys_mtime - Mark the time (for timing programs) + sys_ptime - Print the elapsed time since last mark + syserr - Post a system error and take an error action + tsleep - Delay process execution + urand - Uniform random number generator + xwhen - Post an exception handler diff --git a/sys/etc/doc/psio.doc b/sys/etc/doc/psio.doc new file mode 100644 index 00000000..d0f34c9a --- /dev/null +++ b/sys/etc/doc/psio.doc @@ -0,0 +1,275 @@ +.help pr_psio +.nf __________________________________________________________________________ +PR_PSIO -- Pseudofile i/o for a process. Process an i/o request for the +specified pseudofile stream of the specified process. Called either to read +command input from the CLIN of a process, or to process a read or write +request to a pseudofile of a process. + + +1. Introduction + + Pseudofile i/o in a multiprocess configuration, e.g., for the graphics +streams, is quite complex and difficult to explain briefly. I have tried to +cover the major points here but warn the reader that it is not going to be easy +to understand the flow of data and control involved. The problem is a difficult +one due to the nature of the IPC protocol and the complexity of the three +process architecture required when an external graphics kernel is used. The +discussion herein is not complete but should as least give the reader some +idea of what is going on. + + +2. Pseudofile I/O + + While a task is running the CL will be reading command input from the task. +This read eventually resolves into a call to PR_PSIO on the CLIN for the +process. When pseudofile i/o occurs, e.g., the process writes to STDOUT or +STDERR, an XMIT or XFER directive will be seen in the CLIN input from the +process. If we are directed to XMIT to an ordinary file our task is relatively +easy, i.e., we read the data block from CLIN and write it to the output file. +A directive to read from the standard input is also easy, i.e., we read from +the standard input of the parent (assuming i/o is not redirected) and write +the data block to the CLOUT of the process preceded by a count of the number +of chars. + + +2.1 I/O to a Graphics Stream + + If we are directed to read or write a graphics stream our task is somewhat +more difficult. The standard graphics streams STDGRAPH, STDIMAGE, and STDPLOT +differ from other pseudofiles in that the streams are both readable and +writable, provided all data is used up before switching modes. A graphics +stream may be connected to a file if output is being spooled, to the builtin +STDGRAPH kernel if the graphics device is the graphics terminal, or to a +graphics kernel resident in an external subprocess. + +If a graphics stream is redirected to a spool file we merely copy output to +the file and reading is forbidden. If output is to an external graphics +kernel but is unfiltered (no workstation transformation, e.g., for STDPLOT), +we merely copy data blocks on to the subprocess but the protocol involved +is nontrivial. If output is to the builtin STDGRAPH kernel or to an +external interactive kernel, output must be filtered through GIOTR before +being written to the local or remote graphics kernel. Graphics input is +also possible and is handled similarly but without need to call GIOTR. + +Before reading or writing a graphics stream GIO will send a special directive to +PR_PSIO to connect a kernel to the stream. This directive is passed to PR_PSIO +via an XMIT to the special pseudofile PSIOCONTROL. The data passed in the +XMIT call will be the GKI control instruction to be executed by PSIO. There +are currently three such directives, i.e., OPENWS, SETWCS, and GETWCS. Each +such directive is included in the normal metacode stream as well, but by +writing to a special pseudofile we avoid the need to have PR_PSIO scan each +metacode stream for control instructions, a fairly expensive operation if a +lot of data is involved. + + +2.1.1 Graphics Stream Dataflow + + A frame buffer is associated with each graphics stream in the parent +process. If graphics output (metacode) is being filtered, each output record +is appended to the frame buffer and then GIOTR is called to filter the new +instructions. GIOTR writes the filtered metacode stream either directly to +the builtin kernel or to the graphics output pseudofile stream of the parent +process. + +Output to the builtin kernel is easy to understand: GIOTR merely calls the +kernel to execute the transformed instruction. If output is to an external +kernel we unfortunately cannot simply write to the kernel because we require +that the graphics kernel task be a conventional task callable from either +the CL or by the graphics system, i.e., by PL_PSIO. We must buffer the +transformed output metacode and pass it on to the kernel process only when +requested to do so by an XFER command from the kernel. + +This buffering is done in a somewhat tricky way which makes it look like we +are writing to a simple file, and which allows us to use conventional READ and +WRITE calls to access the graphics stream. GIOTR, if not writing to the +builtin kernel, will write to one of the three graphics streams of the parent +process, i.e., to STDGRAPH, STDIMAGE, or STDPLOT. The graphics stream of the +parent is logically connected to the same stream in the kernel process. We +arrange things such that data may be written or read into the FIO buffer +associated with the stream, but the buffer will never actually be flushed, +since this would cause the contents to appear as garbage on the user terminal. + +The sequence of events for an XMIT to STDGRAPH with an external kernel is as +follows: + + + The parent process (CL) blocks, waiting for a read on the IPC + channel to the graphics task. + + Graphics task writes to stdgraph. + FIO flushes stdgraph buffer through IPC channel. + + PR_PSIO (in the parent) sees XMIT to stdgraph. + Parent reads data record from IPC channel, appending the + data record to the frame buffer for the stream. + + PR_PSIO calls GIOTR to process the new metacode. + GIOTR writes the transformed metacode instructions to the stdgraph + stream of the parent and returns control to PR_PSIO. + + PR_PSIO rewinds the stdgraph buffer in preparation for a read and + stacks the pending XMIT request and directs its command input + to the IPC of the kernel process. + + The kernel process sends zero or more XMIT or XFER requests to + the parent to read or write pseudofile streams other than + stdgraph. + The kernel process sends an XFER request to the parent to read + from stdgraph. + The parent reads the data record from the stdgraph FIO buffer + and passes it on to the kernel, completing the XFER request + of the kernel as well as the original XMIT request of the + graphics task. + + The parent process (CL) blocks, waiting for a read on the IPC + channel to the graphics task. + + +The sequence of operations for an XFER request from the graphics task is +as follows. + + The parent process (CL) blocks, waiting for a read on the IPC + channel to the graphics task. + + The parent receives an XFER request from the graphics task. + If there is any data in the stdgraph buffer the parent returns + that to the graphics task, otherwise the PR_PSIO procedure + pushes an XFER request and redirects its input to the + graphics kernel. + + The kernel process sends zero or more XMIT or XFER requests to + the parent to read or write pseudofile streams other than + stdgraph. + The kernel process sends an XMIT request to the parent to write + to stdgraph. + The parent reads the data block from the IPC channel to the kernel + and writes it to stdgraph, completing the XMIT request. + + The parent pops the XFER request and copies the data in the stdgraph + buffer to the graphics task, completing the original XFER request. + + The parent process (CL) blocks, waiting for a read on the IPC + channel to the graphics task. + + +In summary, the principal data buffers involved in pseudofile i/o to a graphics +stream are the frame buffer, used by GIOTR to spool the metacode instructions +for a graphics frame, and the FIO buffer for the graphics stream, used to +pass data between XMIT/XFER request pairs from cooperating processes at +opposite ends of a graphics stream. + + +3. Summary + + The actual code required to implement all this is probably easier to +understand than the English description. To summarize the justification for +the complexity of the scheme we have adopted: + + [1] The graphics kernel task is a conventional CL callable task with + parameters etc., usable to process metacode from a metafile or from + a pipe as well as callable by PR_PSIO. The conventional IPC protocol + is used in the graphics kernel task. Other tasks may be resident in + the same process, saving disk and memory. + + [2] The graphics kernel may read STDIN and write STDOUT and STDERR while + processing metacode, allowing access to the graphics terminal via the + CL process, output of debugging information during operation, and + output of error messages during operation. +.endhelp ______________________________________________________________________ + + +# PR_PSIO -- Process an i/o request for the specified pseudofile stream +# of the specified process. + +procedure pr_psio (pid, active_fd) + +pid process id +fd process stream for which i/o is requested + +begin + in = pr.clin + fd = active_fd + clear stack + + # Process i/o requests from the subprocess until a request is received + # and processed for pseudofile FD. + + repeat { + while (filbuf (in) != EOF) { + determine type of request and destfd + + if (xmit request to stream destfd) { + if (graphics filtering enabled) { + read data record and append to frame buffer + call giotr to filter output to destfd + } else { + read data record from process + write record to destfd + } + if (destination is a process) { + rewind destfd buffer for read + push (fd) + push (in) + push (xmit) + fd = destfd + in = newpr.clin + next + } + + } else if (xfer request from stream destfd) { + if (destfd is a process and buffer is empty) { + push (fd) + push (in) + push (xfer) + fd = destfd + in = newpr.clin + next + } else { + read data record from destfd + write data record to process + } + + } else if (gio directive) { + if (open workstation) + connect a kernel process to a graphics stream + else if (setwcs) + save wcs for the stream + else if (getwcs) + write wcs data to the process + + } else { + destfd = CLIN + if (fd != CLIN) + error: unsolicited command input from the subprocess + } + + if (destfd == fd) { + if (stack not empty) { + pop (request) + pop (in) + pop (fd) + if (request == xfer) { + read data record from fd + write data record to process owning "in" + } + } else + break + } + } + } until (stack is empty) +end + + + +File routing: + + Each pseudofile in a subprocess is associated with a stream in the parent +process. A subprocess pseudofile may map to a real file or to a parent +pseudofile. When a subprocess is connected as a graphics kernel graphics +i/o will be via any one of the standard graphics streams STDGRAPH etc., +with said graphics stream connected to the same stream in the parent. +The subprocess streams STDIN, STDOUT, and STDERR are by default connected +to the same streams in the parent, allowing the subprocess to access the +terminal, output error messages, and so on. A graphics kernel will be able +to access the standard i/o streams even while connected as a subprocess +to filter GKI metacode. diff --git a/sys/etc/dtmcnv.x b/sys/etc/dtmcnv.x new file mode 100644 index 00000000..63d89a12 --- /dev/null +++ b/sys/etc/dtmcnv.x @@ -0,0 +1,482 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + + +# DTMCNV.X -- Date and time conversions. +# +# The file contains the source for only the DTM routines listed below. All +# the related system date and time routines are also summarized so that the +# whole (rather scattered) interface can be viewed at a glance. +# +# FITS-Like Date and Time String Conversions +# +# status = dtm_decode (datestr, y,m,d, h, oldfits) +# nchars = dtm_encode (datestr,maxch, y,m,d, h, precision, flags) +# status = dtm_decode_hms (datestr, y,m,d, h,m,s, oldfits) +# nchars = dtm_encode_hms (datestr,maxch, y,m,d, h,m,s, precision, flags) +# status = dtm_ltime (datestr, ltime) +# +# +# General Date and Time Conversions +# +# cnvdate (ltime, outstr, maxch) +# cnvtime (ltime, outstr, maxch) +# brktime (ltime, tm) +# +# System Time +# +# lval = clktime (old_time) # returns local time +# lval = cputime (old_cputime) # process cpu time, seconds +# gmt = lsttogmt (lst) # lst/gmt are in seconds +# lst = gmttolst (gmt) # lst/gmt are in seconds +# +# sys_mtime (save_time) # mark/print cpu time used +# sys_ptime (fd, opstr, save_time) +# +# +# Kernel Support +# +# zgtime (clktime, cputime) # clock/cpu time in seconds +# zgmtco (gmtcor) # GMT = LST + gmtco (seconds) +# +# LST here means local standard time (clock time), including any correction +# for daylight savings time. + + + +# DTM_DECODE -- Decode the FITS format DATE-OBS string value into year, +# month, day and time fields. OK is returned if the date string is +# successfully decoded, ERR if it is not. The DATE-OBS string value may be +# in any of the following forms: DD/MM/YY (flags = TF_OLDFITS), CCYY-MM-DD +# (flags = 0, time = INDEFD), or CCYY-MM-DDTHH:MM:SS[.SSS...] (flags=0, +# time = double precision number). This routine verifies only the syntax. +# Routines in the SLALIB or ASTUTIL libraries can be used to check for +# valid year, month, day, or time values. + +int procedure dtm_decode (datestr, year, month, day, time, flags) + +char datestr[ARB] #I the input date-obs string +int year #O the output year (INDEFI if undefined) +int month #O the output month (INDEFI if undefined) +int day #O the output day (INDEFI if undefined) +double time #O the output time in hours (INDEFD if undefined) +int flags #O see + +double dval +int oldfits, ip, nchars, ival +int ctoi(), ctod() + +begin + # Initialize. + year = INDEFI + month = INDEFI + day = INDEFI + time = INDEFD + flags = 0 + + # Determine whether the format is old or new and get the day or + # month accordingly. + ip = 1 + nchars = ctoi (datestr, ip, ival) + if (nchars == 2) { + flags = or (flags, TF_OLDFITS) + oldfits = YES + day = ival + } else if (nchars == 4) { + flags = and (flags, not(TF_OLDFITS)) + oldfits = NO + year = ival + } else + return (ERR) + + # Check syntax. + if (oldfits == NO && datestr[ip] == '-') + ip = ip + 1 + else if (oldfits == YES && datestr[ip] == '/') + ip = ip + 1 + else + return (ERR) + + # Get the month + nchars = ctoi (datestr, ip, ival) + if (nchars == 2) { + month = ival + } else + return (ERR) + if (oldfits == NO && datestr[ip] == '-') + ip = ip + 1 + else if (oldfits == YES && datestr[ip] == '/') + ip = ip + 1 + else + return (ERR) + + # Get the year or day. + nchars = ctoi (datestr, ip, ival) + if (nchars == 2) { + if (oldfits == YES) + year = 1900 + ival + else + day = ival + } else + return (ERR) + + if (datestr[ip] != 'T' || oldfits == YES) + return (OK) + + # Get the time. + ip = ip + 1 + nchars = ctod (datestr, ip, dval) + if (nchars < 8) + return (ERR) + else + time = dval + + # Check for trailing garbage in the input string. Ignore whitespace. + while (IS_WHITE(datestr[ip])) + ip = ip + 1 + + if (datestr[ip] != EOS) + return (ERR) + else + return (OK) +end + + +# DTM_DECODE_HMS -- Decode a FITS format DATE-OBS string into year, month, +# day, hours, minutes, and seconds fields. OK is returned if the date string +# is successfully decoded, ERR if it is not. The DATE-OBS string value may +# be in any of the following forms: DD/MM/YY (oldfits = YES), CCYY-MM-DD +# (oldfits = NO, hours = INDEFI, minutes = INDEFI, seconds = INDEFD), or +# CCYY-MM-DDTHH:MM:SS[.SSS...] (oldfits = NO, hours = integer, minutes = +# integer, seconds = double precision number). This routine verifies only +# that the syntax is correct. Routines in the SLALIB or ASTUTIL libraries +# can be used to check for valid year, month, day, or time values. + +int procedure dtm_decode_hms (datestr, + year, month, day, hours, minutes, seconds, flags) + +char datestr[ARB] #I the input date-obs string +int year #O the output year (INDEFI if undefined) +int month #O the output month (INDEFI if undefined) +int day #O the output day (INDEFI if undefined) +int hours #O the output hours (INDEFI if undefined) +int minutes #O the output minutes (INDEFI if undefined) +double seconds #O the output seconds (INDEFD if undefined) +int flags #O see + +double dval +int oldfits, ip, nchars, ival +int ctoi(), ctod() + +begin + # Initialize. + year = INDEFI + month = INDEFI + day = INDEFI + hours = INDEFI + minutes = INDEFI + seconds = INDEFD + flags = 0 + + # Determine whether the format is old or new and get the day + # or month accordingly. + ip = 1 + nchars = ctoi (datestr, ip, ival) + if (nchars == 2) { + flags = or (flags, TF_OLDFITS) + oldfits = YES + day = ival + } else if (nchars == 4) { + flags = and (flags, not(TF_OLDFITS)) + oldfits = NO + year = ival + } else + return (ERR) + + # Check syntax. + if (oldfits == NO && datestr[ip] == '-') + ip = ip + 1 + else if (oldfits == YES && datestr[ip] == '/') + ip = ip + 1 + else + return (ERR) + + # Get the month. + nchars = ctoi (datestr, ip, ival) + if (nchars == 2) { + month = ival + } else + return (ERR) + if (oldfits == NO && datestr[ip] == '-') + ip = ip + 1 + else if (oldfits == YES && datestr[ip] == '/') + ip = ip + 1 + else + return (ERR) + + # Get the year or day. + nchars = ctoi (datestr, ip, ival) + if (nchars == 2) { + if (oldfits == YES) + year = 1900 + ival + else + day = ival + } else + return (ERR) + + if (datestr[ip] != 'T' || oldfits == YES) + return (OK) + + # Get the hours. + ip = ip + 1 + nchars = ctoi (datestr, ip, ival) + if (nchars == 2) + hours = ival + else + return (ERR) + if (datestr[ip] != ':') + return (ERR) + + # Get the minutes. + ip = ip + 1 + nchars = ctoi (datestr, ip, ival) + if (nchars == 2) + minutes = ival + else + return (ERR) + if (datestr[ip] != ':') + return (ERR) + + # Get the seconds. + ip = ip + 1 + nchars = ctod (datestr, ip, dval) + if (nchars < 2) + return (ERR) + else + seconds = dval + + # Check for trailing garbage in the input string. Ignore whitespace. + while (IS_WHITE(datestr[ip])) + ip = ip + 1 + + if (datestr[ip] != EOS) + return (ERR) + else + return (OK) +end + + +# DTM_ENCODE -- Encode year, month, day and time fields into a valid FITS +# format DATE-OBS string value. The number of characters in the output +# string is returned as the function value. The returned DATE-OBS keyword +# value may be in any of the following formats: DD/MM/YY (oldfits = YES, +# 1900 <= year < 2000), CCYY-MM-DD (oldfits = NO, time = INDEFD), or +# CCYY-MM-DDTHH:MM:SS[.SSS...] (oldfits = NO, time = double precision +# number). This routine formats the string but does not check for valid +# input values. Routines in the SLALIB or ASTUTIL libraries can be used +# to create valid year, month, day, or time values. + +int procedure dtm_encode (datestr, maxch, + year, month, day, time, precision, flags) + +char datestr[ARB] #O the output date string +int maxch #I the maximum length of the output date string +int year #I the input year, e.g. 1999 +int month #I the input month, e.g. 1-12 +int day #I the input day, e.g. 1-31 +double time #I the input time in hours, INDEFD if undefined +int precision #I the precision of the output time field +int flags #I see + +int oldfits, field +int strlen(), btoi() + +begin + datestr[1] = EOS + oldfits = btoi (and (flags, TF_OLDFITS) != 0) + + if (oldfits == YES) { + if (year >= 1900 && year < 2000) { + call sprintf (datestr, maxch, "%02d/%02d/%02d") + call pargi (day) + call pargi (month) + call pargi (mod (year, 1900)) + } + } else if (IS_INDEFD(time)) { + call sprintf (datestr, maxch, "%04d-%02d-%02d") + call pargi (year) + call pargi (month) + call pargi (day) + } else { + if (precision <= 0) + field = 8 + else + field = 9 + precision + call sprintf (datestr, maxch, "%04d-%02d-%02dT%0*.*h") + call pargi (year) + call pargi (month) + call pargi (day) + call pargi (field) + call pargi (precision) + call pargd (time) + } + + return (strlen (datestr)) +end + + +# DTM_ENCODE_HMS -- Encode year, month, day, hours, minutes, and seconds +# fields into a valid FITS format DATE-OBS string value. The number of +# characters in the output string is returned as the function value. The +# returned DATE-OBS keyword value may be in any of the following formats: +# DD/MM/YY (oldfits = YES, 1900 <= year < 2000), CCYY-MM-DD (oldfits = NO, +# time = INDEFD), or CCYY-MM-DDTHH:MM:SS[.SSS...] (oldfits = NO, time = +# double precision number). This routine formats the string but does not +# check for valid input values. Routines in the SLALIB or ASTUTIL libraries +# can be used to create valid year, month, day, or time values. + +int procedure dtm_encode_hms (datestr, maxch, + year, month, day, hours, minutes, seconds, precision, flags) +char datestr[ARB] #O the output date string +int maxch #I the maximum length of the output date string + +int year #I the input year, e.g. 1999 +int month #I the input month, e.g. 1-12 +int day #I the input day, e.g. 1-31 +int hours #I the input hours field, INDEFI if undefined +int minutes #I the input minutes field, INDEFI if undefined +double seconds #I the input seconds field, INDEFD if undefined +int precision #I the precision of the output time field +int flags #I see + +int oldfits, field +int strlen(), btoi() + +begin + + datestr[1] = EOS + oldfits = btoi (and (flags, TF_OLDFITS) != 0) + + if (oldfits == YES) { + if (year >= 1900 && year < 2000) { + call sprintf (datestr, maxch, "%02d/%02d/%02d") + call pargi (day) + call pargi (month) + call pargi (mod (year, 1900)) + } + } else if (IS_INDEFI(hours) || IS_INDEFI(minutes) || + IS_INDEFD(seconds)) { + call sprintf (datestr, maxch, "%04d-%02d-%02d") + call pargi (year) + call pargi (month) + call pargi (day) + } else { + if (precision <= 0) + field = 2 + else + field = 3 + precision + call sprintf (datestr, maxch, "%04d-%02d-%02dT%02d:%02d:%0*.*f") + call pargi (year) + call pargi (month) + call pargi (day) + call pargi (hours) + call pargi (minutes) + call pargi (field) + call pargi (precision) + call pargd (seconds) + } + + return (strlen (datestr)) +end + + +# DTM_LTIME -- Decode a FITS format DATE-OBS string into the number of +# seconds since 00:00:00 01-Jan-1980. OK is returned if the date string +# is successfully decoded, ERR if it is not or if it is a negative value. +# The 'datestr' string value may be in any of the following forms: DD/MM/YY +# or CCYY-MM-DD (where time is INDEF and assumed to be midnight), or as +# CCYY-MM-DDTHH:MM:SS[.SSS...]. + +int procedure dtm_ltime (datestr, ltime) + +char datestr[ARB] #I the input date string +long ltime #O seconds since 00:00:00 01-Jan-1980 + +double sec +int oldfits, ndays +int hr, min, yr, mon, day + +double dtm_date_to_julday() +int dtm_decode_hms() + +define START_IRAF_EPOCH 2444239.5 # JD of 00:00:00 01-Jan-1980 +define SECONDS_PER_DAY 86400 +define SECONDS_PER_HOUR 3600 +define SECONDS_PER_MINUTE 60 + +begin + ltime = INDEFL # initialize + + if (dtm_decode_hms (datestr, yr,mon,day, hr,min,sec, oldfits) == ERR) + return (ERR) + + # Take care of the assumption that 2-digit years are 1900. + if (oldfits == YES) + yr = yr + 100 + + # If we had a time specified, convert it to the number of seconds + # that day. + if (IS_INDEFI(hr) || IS_INDEFI(min) || IS_INDEFD(sec)) + ltime = 0 + else + ltime = (hr * SECONDS_PER_HOUR) + (min * SECONDS_PER_MINUTE) + sec + + # Compute the number of days since the start of the iraf epoch. + ndays = dtm_date_to_julday (yr, mon, day, 0.0d0) - START_IRAF_EPOCH + + # Convert days to seconds, add to time from before. + ltime = ltime + (ndays * SECONDS_PER_DAY) + + if (ltime >= 0) + return (OK) + else + return (ERR) +end + + +# DTM_DATE_TO_JULDAY -- Convert date to Julian day. Assumes dates after year 99. + +double procedure dtm_date_to_julday (year, month, day, t) + +int year # Year +int month # Month (1-12) +int day # Day of month +double t # Time for date (mean solar day) + +double jd +int y, m, d + +begin + if (year < 100) + y = 1900 + year + else + y = year + + if (month > 2) + m = month + 1 + else { + m = month + 13 + y = y - 1 + } + + jd = int (365.25D0 * y) + int (30.6001 * m) + day + 1720995 + if (day + 31 * (m + 12 * y) >= 588829) { + d = int (y / 100) + m = int (y / 400) + jd = jd + 2 - d + m + } + jd = jd - 0.5 + int (t * 360000. + 0.5) / 360000. / 24. + return (jd) +end diff --git a/sys/etc/envgetb.x b/sys/etc/envgetb.x new file mode 100644 index 00000000..564aa67f --- /dev/null +++ b/sys/etc/envgetb.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ENVGETB -- Check whether the named option is set in the environment. +# Return true only if the option is defined in the environment and either has +# no value string (i.e., the existence of the variable is what is significant) +# or a value string which begins with the character 'y' or 'Y'. + +bool procedure envgetb (varname) + +char varname[ARB] +bool answer +pointer sp, def +int envfind() + +begin + call smark (sp) + call salloc (def, SZ_LINE, TY_CHAR) + + if (envfind (varname, Memc[def], SZ_LINE) < 0) + answer = false + else { + switch (Memc[def]) { + case 'y', 'Y', EOS: + answer = true + default: # abort not justified + answer = false + } + } + + call sfree (sp) + return (answer) +end diff --git a/sys/etc/envgetd.x b/sys/etc/envgetd.x new file mode 100644 index 00000000..749c3aef --- /dev/null +++ b/sys/etc/envgetd.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# ENVGETD -- Fetch an environment variable and try to interpret its value +# as a double. Abort if variable is not found or cannot be converted to +# a number. + +double procedure envgetd (varname) + +char varname[ARB] + +int ip +double dval +char val[MAX_DIGITS] +int ctod(), envfind() +errchk envfind, syserrs + +begin + ip = 1 + if (envfind (varname, val, MAX_DIGITS) > 0) + if (ctod (val, ip, dval) > 0) + return (dval) + + call syserrs (SYS_ENVNNUM, varname) +end diff --git a/sys/etc/envgeti.x b/sys/etc/envgeti.x new file mode 100644 index 00000000..a3e14190 --- /dev/null +++ b/sys/etc/envgeti.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# ENVGETI -- Fetch an environment variable and try to interpret its value +# as an integer. Abort if variable is not found or cannot be converted to +# a number. + +int procedure envgeti (varname) + +char varname[ARB] + +int ival, ip +char val[MAX_DIGITS] +int ctoi(), envfind() +errchk envfind, syserrs + +begin + ip = 1 + if (envfind (varname, val, MAX_DIGITS) > 0) + if (ctoi (val, ip, ival) > 0) + return (ival) + + call syserrs (SYS_ENVNNUM, varname) +end diff --git a/sys/etc/envgetr.x b/sys/etc/envgetr.x new file mode 100644 index 00000000..5ec04d58 --- /dev/null +++ b/sys/etc/envgetr.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ENVGETR -- Fetch an environment variable and try to interpret its value +# as a real. Abort if variable is not found or cannot be converted to +# a number. + +real procedure envgetr (varname) + +char varname[ARB] +double val, envgetd() + +begin + val = envgetd (varname) + if (IS_INDEFD(val)) + return (INDEFR) + else + return (val) +end diff --git a/sys/etc/envgets.x b/sys/etc/envgets.x new file mode 100644 index 00000000..969a660d --- /dev/null +++ b/sys/etc/envgets.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "environ.h" + +# ENVGETS -- Search the environment list for the named environment variable +# and return the string value if found. If not found and the process input +# is a terminal (the process is being run interactively in debug mode), generate +# a query on the terminal, read the value of the environment variable, enter +# it into the environment table, and return the value to the caller. + +int procedure envgets (key, value, maxch) + +char key[ARB] # environment variable name +char value[maxch] # string value (output) +int maxch + +char buf[SZ_FNAME] +int nchars, ttydriver, junk, in, out, ip +int gstrcpy(), envfind(), fstati(), strlen(), envputs() +extern zgetty() + +begin + # Search the environment list first. + nchars = envfind (key, value, maxch) + if (nchars >= 0) + return (nchars) + + # Key not found. If the process input CLIN is a terminal, query the + # user for the value of the environment variable. Only low level + # calls are used in the query to avoid the possibity of recursion. + + call zlocpr (zgetty, ttydriver) + iferr { + out = fstati (CLOUT, F_CHANNEL) + in = fstati (CLIN, F_CHANNEL) + } then + return (0) + + if (fstati (CLIN, F_DEVICE) == ttydriver) { + # Issue prompt, format "env.key: " + call zputty (out, "env.", 4, junk) + call zputty (out, key, strlen(key), junk) + call zputty (out, ": ", 2, junk) + call zflsty (out, junk) + + # Get value and enter in envlist, excluding the trailing newline. + + call zgetty (in, buf, SZ_FNAME, nchars) + if (nchars <= 0) + return (0) + for (ip=1; buf[ip] != '\n' && ip <= nchars; ip=ip+1) + ; + buf[ip] = EOS + junk = envputs (key, buf) + + return (gstrcpy (buf, value, maxch)) + + } else + return (0) +end diff --git a/sys/etc/envindir.x b/sys/etc/envindir.x new file mode 100644 index 00000000..48902eee --- /dev/null +++ b/sys/etc/envindir.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ENVINDIR -- Return the name of an environment variable which may be given +# by the value of another environment variable as "@envvar". + +procedure envindir (envvar, outstr, maxch) + +char envvar[ARB] # possibly indirect env. variable name +char outstr[ARB] # receives value of variable +int maxch + +pointer sp, envname +int envfind() +errchk syserrs + +begin + call smark (sp) + call salloc (envname, SZ_FNAME, TY_CHAR) + + call strcpy (envvar, outstr, maxch) + + while (outstr[1] == '@') { + call strcpy (outstr[2], Memc[envname], SZ_FNAME) + if (envfind (Memc[envname], outstr, maxch) <= 0) + call syserrs (SYS_ENVNF, Memc[envname]) + } + + call sfree (sp) +end diff --git a/sys/etc/envinit.x b/sys/etc/envinit.x new file mode 100644 index 00000000..3b58f444 --- /dev/null +++ b/sys/etc/envinit.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "environ.h" + +# ENV_INIT -- Called by the IRAF main to initialize the environment common +# upon process startup. + +procedure env_init() + +bool first_time +int kmalloc() +include "environ.com" +data first_time /true/ + +begin + if (first_time) { + if (kmalloc (envbuf, LEN_ENVBUF, TY_SHORT) == ERR) + call sys_panic (SYS_MFULL, "Out of memory") + + call aclrs (threads, NTHREADS) + len_envbuf = LEN_ENVBUF + last = NULL + top = 1 + first_time = false + } +end diff --git a/sys/etc/environ.com b/sys/etc/environ.com new file mode 100644 index 00000000..4a2fae17 --- /dev/null +++ b/sys/etc/environ.com @@ -0,0 +1,8 @@ +# Common for the environment list package. + +pointer envbuf # buffer containing the environment list +int len_envbuf # length of the envbuf buffer +int last # index of the last list element entered +int top # index of the next list element +short threads[NTHREADS] # hashed threads through list +common /envcom/ envbuf, len_envbuf, last, top, threads diff --git a/sys/etc/environ.h b/sys/etc/environ.h new file mode 100644 index 00000000..ccdc77c8 --- /dev/null +++ b/sys/etc/environ.h @@ -0,0 +1,28 @@ +# ENVIRON.H -- Global defines for the environment list package. + +# Strings may optionally be quoted in SET stmts with either ' or ". +define IS_QUOTE ($1 == '\'' || $1 == '"') + +# Size limiting definitions. + +define NTHREADS 199 # number of hash threads +define MAX_HASHCHARS 18 # max chars to use for hashing +define LEN_ENVBUF 20480 # storage for environment list +define INC_ENVBUF 4096 # increment if overflow occurs +define MAX_SZKEY 32 # max chars in a key +define MIN_SZVALUE 20 # min allocated space for value +define MAX_SZVALUE 4096 # max chars in value string +define MAX_LENLISTELEM (4+(MAX_SZKEY+1+MAX_SZVALUE+1+SZ_SHORT-1)/SZ_SHORT) + +# List element structure, stored in ENVBUF, which is allocated as an array of +# type SHORT integer. Each list element is aligned on a short integer boundary +# within the array. E_NEXT points to the next element in a thread, whereas +# E_LASTELEM points to the last element in the envbuf (which is a stack). + +define E_NEXT Mems[$1] # next element in thread (list) +define E_LASTELEM Mems[$1+1] # next element in envbuf +define E_REDEF Mems[$1+2] # set if element is redefined +define E_LEN Mems[$1+3] # nchars allocated for value string +define E_SETP (($1+4-1)*SZ_SHORT+1) # char pointer to name field +define E_SET Memc[E_SETP($1)] # "name=value" string +define E_SETOFFSET 4 diff --git a/sys/etc/environ.x b/sys/etc/environ.x new file mode 100644 index 00000000..24e6b814 --- /dev/null +++ b/sys/etc/environ.x @@ -0,0 +1,315 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "environ.h" + +.help environ +.nf ___________________________________________________________________________ +ENVIRON -- Routines for managing the environment list. The environment list +is global in scope. A process, e.g., the CL, builds up the environment list +and passes it on to a child process when the process is spawned. + + nchars = envgets (name, value, maxch) # get value of envvar + redef = envputs (name, value) # set value of envvar + nchars = envfind (name, value, maxch) # get value of envvar if def + envmark (sp) # mark stack pointer + nredefs = envfree (sp, userfcn) # free back to marked posn + + bool = envgetb (name) # get boolean value of envvar + int = envgeti (name) # get integer value of envvar + envlist (fd, prefix, show_redefs) # print envlist on file + nscan = envscan (input_source) # read SET stmts from a file + + el = env_first (valp) # head of envlist + el = env_next (el, valp, show_redefs) # next element of envlist + +The environment list is maintained as a multi-threaded linked list. This +provides the searching efficiency of a hash table plus stack like semantics +for redefinitions and for freeing blocks of variables. There are two primary +data structures internally, an array of pointers to the heads of the threads, +and a buffer containing the list elements. These data structures are +dynamically allocated and will be automatically reallocated at runtime if +overflow occurs. The number of threads determines the hashing efficiency and +is a compile time parameter. + +The ENVMARK and ENVFREE procedures mark and free storage on the environment +list stack. All environment variables defined or redefined after a call to +ENVMARK will be deleted and storage freed by a call to ENVFREE. If a redef +is freed the next most recent definition becomes current. ENVFREE returns +as its function value the number of redefined variables uncovered by the free +operation. The calling program must mark and free in the correct order or the +environment list may be trashed. + +The ENVLIST procedure prints the environment list on a file. Redefined values +will only be printed if desired. The environment list is printed as a list of +SET statements in most recent first order, i.e., + + set nameN=valueN + set nameM=valueM + ... + set name1=value1 + +The ENVLIST function is used both to inspect the environment list and to pass +the list on to a child process. Redefined variables are omitted when passing +the list on to a child process, hence the order of definition does not matter. +The output format is "prefix name=value", where the prefix string is supplied +by the user. + +The ENVSCAN function parses one or more SET statements, calling ENVPUTS to +enter the SET declarations into the environment list. The argument is either +a SET declaration or a string of the form "set @filename", where "filename" is +the name of a file containing set declarations. +.endhelp ______________________________________________________________________ + + +# ENVFIND -- Search the environment list for the named environment variable +# and return the string value if found. + +int procedure envfind (key, value, maxch) + +char key[ARB] # environment variable name +char value[maxch] # string value (output) +int maxch + +long sum +pointer el, ep +int head, ip, nchars +int envputs(), gstrcpy() +include "environ.com" + +begin + # Get index into envbuf of the first element of the thread. + if (key[1] == EOS) + head = NULL + else { + sum = 0 + do ip = 1, MAX_HASHCHARS { + if (key[ip] == EOS) + break + sum = sum + (sum + key[ip]) + } + head = threads[mod(sum,NTHREADS)+1] + } + + # If thread is not empty search down it for the named key and return + # the value string if found. Note that the value of the E_NEXT pointer + # is given as an integer offset into envbuf to facilitate reallocation + # upon overflow. + + if (head != NULL) + for (el = envbuf + head; el > envbuf; el = envbuf + E_NEXT(el)) { + ep = E_SETP(el) + for (ip=1; key[ip] == Memc[ep]; ip=ip+1) + ep = ep + 1 + if (key[ip] == EOS && Memc[ep] == '=') + return (gstrcpy (Memc[ep+1], value, maxch)) + } + + # Key not found. Ask the host system for the value of the environment + # variable. + + call strpak (key, value, maxch) + call zgtenv (value, value, maxch, nchars) + + if (nchars >= 0) { + call strupk (value, value, maxch) + ip = envputs (key, value) + return (nchars) + } else { + value[1] = EOS + return (ERR) + } +end + + +# ENVPUTS -- Add a new SET definition to the environment list. A SET operation +# is allowed to redefine a previously defined environment variable, but if the +# new definition is a redef we return YES as the function value. If the set +# is a no-op (null key, or redef with the same value as previously) the envlist +# is not modified and NO is returned as the function value. + +int procedure envputs (key, value) + +char key[ARB] # environment variable name +char value[ARB] # string value + +long sum +int head, thread_index, redef, ip +pointer el, op, ep + +bool streq() +pointer coerce() +int gstrcpy(), krealloc() +include "environ.com" + +begin + if (key[1] == EOS) + return (NO) + + # Get index into envbuf of the first element of the thread. + sum = 0 + do ip = 1, MAX_HASHCHARS { + if (key[ip] == EOS) + break + sum = sum + (sum + key[ip]) + } + + thread_index = mod (sum, NTHREADS) + 1 + head = threads[thread_index] + + # If thread is not empty search down it for the named key to see if we + # have a redefinition. If we have a redef but the new value is the + # same as the old, do nothing. Otherwise flag the element being + # redefined as a redefinition (so that ENVLIST can ignore it). + + redef = NO + if (head != NULL) + for (el = envbuf + head; el > envbuf; el = envbuf + E_NEXT(el)) { + ep = E_SETP(el) + for (ip=1; key[ip] == Memc[ep]; ip=ip+1) + ep = ep + 1 + if (key[ip] == EOS && Memc[ep] == '=') + if (streq (Memc[ep+1], value)) + return (NO) + else { + E_REDEF(el) = YES + redef = YES + break + } + } + + # Append the new list element to the end of ENVBUF, increasing the size + # of the buffer if overflow occurs. The list structure must be aligned + # on a short integer boundary. Set the back link pointers for searches. + + if (top + MAX_LENLISTELEM >= len_envbuf) { + len_envbuf = len_envbuf + INC_ENVBUF + if (krealloc (envbuf, len_envbuf, TY_SHORT) == ERR) + call sys_panic (SYS_MFULL, "Out of memory") + } + + el = envbuf + top + E_NEXT(el) = head + E_LASTELEM(el) = last + E_REDEF(el) = NO + + # Deposit the string "key=value" in the E_SET field. At least + # MIN_SZVALUE chars are allocated for the value string, to permit + # the value to be updated via ENVRESET (possibly changing size in + # the process). + + op = E_SETP(el) + op = op + gstrcpy (key, Memc[op], MAX_SZKEY) + Memc[op] = '=' + op = op + 1 + E_LEN(el) = max (MIN_SZVALUE, gstrcpy(value,Memc[op],MAX_SZVALUE)) + op = op + E_LEN(el) + 1 + + last = top + threads[thread_index] = last + top = coerce (op, TY_CHAR, TY_SHORT) - envbuf + + # Update the environment in any connected kernel servers. + call ki_envreset (key, value) + + return (redef) +end + + +# ENVMARK -- Mark the position in the environment list. A subsequent call +# to ENVFREE with the marked position as argument will unset all elements +# set after the marked position. + +procedure envmark (old_top) + +int old_top # top of envbuf stack +include "environ.com" + +begin + old_top = top +end + + +# ENVFREE -- Free all environment list entries set since the matching call +# to ENVMARK. Return as the function value the number of redefined environment +# variables uncovered by the free operation. If the ZLOCPR integer entry point +# address of the user supplied function USERFCN is nonnull the function will +# be called with the name and value of each uncovered redefinition. The calling +# sequence is as follows: subroutine userfcn (name, value) + +int procedure envfree (old_top, userfcn) + +int old_top # top of envbuf stack +int userfcn # epa of function called for uncovered redefs + +int nredefs, head, i, j, t +pointer sp, start, namep, el1, el2, ep1, ep2 +include "environ.com" + +begin + if (old_top < 1 || old_top >= top) + return (0) + + call smark (sp) + call salloc (namep, SZ_FNAME, TY_CHAR) + + nredefs = 0 + + # Clear the redef flags for all list elements that are redefined by + # elements above the new top, and count the number of uncovered redefs. + # Examine only non-empty threads. + + for (t=1; t <= NTHREADS; t=t+1) { + head = threads[t] + if (head != NULL) { + # Examine only list elements in the thread which lie above the + # top we are reverting to. + + for (j = head; j >= old_top; j = E_NEXT(el1)) { + el1 = envbuf + j + + # Scan down the thread to see if this is a redefinition, + # and clear the redef flag if so. + + for (i = j; i != NULL; i = E_NEXT(el2)) { + el2 = envbuf + i + if (E_REDEF(el2) == YES) { + ep1 = E_SETP(el1) + ep2 = E_SETP(el2) + start = ep2 + while (Memc[ep1] == Memc[ep2] && Memc[ep1] != '=') { + ep1 = ep1 + 1 + ep2 = ep2 + 1 + } + if (Memc[ep1] == '=') { + E_REDEF(el2) = NO + nredefs = nredefs + 1 + if (userfcn != NULL) { + call strcpy (Memc[start], Memc[namep], + ep2 - start) + call zcall2 (userfcn, + Memc[namep], Memc[ep2+1]) + } + break + } + } + } + } + + # Set the head of the thread to the first element below + # the new top. + + threads[t] = j + } + } + + # The variable OLD_TOP is the index of a list element. Make it the + # new top. + + top = old_top + last = E_LASTELEM(envbuf+top) + + call sfree (sp) + return (nredefs) +end diff --git a/sys/etc/envlist.x b/sys/etc/envlist.x new file mode 100644 index 00000000..ebd904b6 --- /dev/null +++ b/sys/etc/envlist.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "environ.h" + +# ENVLIST -- Print the environment list on the output file as a sequence of +# SET commands. The commands are given in the reverse of the order in which +# they were originally entered. Printing of redefined variables may be +# inhibited if desired. + +procedure envlist (fd, prefix, print_redefined_variables) + +int fd # output file +char prefix[ARB] # prefix string to be prepended to each line +int print_redefined_variables +pointer el +include "environ.com" + +begin + for (el = envbuf + last; el > envbuf; el = envbuf + E_LASTELEM(el)) + if (E_REDEF(el) == NO || print_redefined_variables == YES) { + call putline (fd, prefix) + call putline (fd, E_SET(el)) + call putci (fd, '\n') + } +end diff --git a/sys/etc/envnext.x b/sys/etc/envnext.x new file mode 100644 index 00000000..80ddf226 --- /dev/null +++ b/sys/etc/envnext.x @@ -0,0 +1,53 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "environ.h" + +# ENV_FIRST -- Return a pointer to the first (most recently entered) entry +# in the environment list. A pointer to the string definition of the entry +# is returned as the output argument. + +pointer procedure env_first (valp) + +pointer valp # pointer to environment string +pointer el +include "environ.com" + +begin + el = envbuf + last + if (el > envbuf) { + valp = E_SETP(el) + return (el) + } else + return (NULL) +end + + +# ENV_NEXT -- Return a pointer to the next element in the environment list. +# A pointer to the string value of the element is returned as the output +# argument. + +pointer procedure env_next (last_el, valp, show_redefines) + +pointer last_el # pointer to last element returned +pointer valp # receives charp of next element define string +int show_redefines # do not skip redefined elements + +pointer el +include "environ.com" + +begin + el = envbuf + E_LASTELEM(last_el) + + while (el > envbuf) { + if (E_REDEF(el) == NO || show_redefines == YES) + break + else + el = envbuf + E_LASTELEM(el) + } + + if (el > envbuf) { + valp = E_SETP(el) + return (el) + } else + return (NULL) +end diff --git a/sys/etc/envreset.x b/sys/etc/envreset.x new file mode 100644 index 00000000..9ca8c5d7 --- /dev/null +++ b/sys/etc/envreset.x @@ -0,0 +1,66 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "environ.h" + +# ENVRESET -- Update the value of the named environment variable in place. +# This is used to permanently change the value of an environment variable, +# unlike ENVPUTS which will create a temporary redefinition which can later +# be discarded via ENVFREE. A fixed amount of string storage is allocated +# for the value string when the environment variable is first defined; if +# the new value won't fit we simply call ENVPUTS to redefine the variable +# at the top of the environment stack. A more sophisticated storage +# mechanism could be devised which could dynamically allocate more storage, +# but the simpler scheme seems adequate at present. + +procedure envreset (key, value) + +char key[ARB] # environment variable name +char value[ARB] # new string value + +long sum +pointer el, ep +int head, ip, junk, maxch +int envputs(), strlen() +include "environ.com" + +begin + # Get index into envbuf of the first element of the thread. + if (key[1] == EOS) + head = NULL + else { + sum = 0 + do ip = 1, MAX_HASHCHARS { + if (key[ip] == EOS) + break + sum = sum + (sum + key[ip]) + } + head = threads[mod(sum,NTHREADS)+1] + } + + # If thread is not empty search down it for the named key; if the key + # is redefined the most recent entry is updated. + + el = NULL + if (head != NULL) + for (el = envbuf + head; el > envbuf; el = envbuf + E_NEXT(el)) { + ep = E_SETP(el) + for (ip=1; key[ip] == Memc[ep]; ip=ip+1) + ep = ep + 1 + if (key[ip] == EOS && Memc[ep] == '=') + break + } + + # If the named key is not found or the new value won't fit add or + # redefine the variable, otherwise set the new value. + + if (el <= envbuf) + junk = envputs (key, value) + else if (strlen(value) > E_LEN(el)) + junk = envputs (key, value) + else { + maxch = E_LEN(el) + call strcpy (value, Memc[ep+1], maxch) + call ki_envreset (key, value) + } +end diff --git a/sys/etc/envscan.x b/sys/etc/envscan.x new file mode 100644 index 00000000..06f7a411 --- /dev/null +++ b/sys/etc/envscan.x @@ -0,0 +1,149 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "environ.h" + +define MAXLEV 8 # max nesting of includes +define SZ_LBUF (SZ_COMMAND+SZ_LINE) # max length SET on a single line + + +# ENVSCAN -- Parse one or more SET or RESET declarations and enter them into +# the environment list. +# +# Syntax: (set|reset) name = value enter a definition +# set @filename scan a file +# +# Comments, blank lines, and lines containing unrecognized statements are +# ignored without warning. + +int procedure envscan (cmd) + +char cmd[ARB] # command text to begin scan + +char ch +int fd, in, nset, lev, sv_fd[MAXLEV] +pointer sp, ip, op, op_top, lbuf, name, value +int open(), stropen(), getlline(), strmatch(), nowhite() +errchk open, stropen, getlline, syserrs +string s_reset "^#reset#" +string s_set "^#set#" +define again_ 91 + +begin + call smark (sp) + call salloc (lbuf, SZ_LBUF, TY_CHAR) + call salloc (name, MAX_SZKEY, TY_CHAR) + call salloc (value, MAX_SZVALUE, TY_CHAR) + + # Position to after the set or reset. + in = strmatch (cmd, s_set) + if (in == 0) { + in = strmatch (cmd, s_reset) + if (in == 0) { + call sfree (sp) + return (0) + } + } + + # Open the input to be scanned. + if (cmd[in] == '@') + fd = open (cmd[in+1], READ_ONLY, TEXT_FILE) + else + fd = stropen (cmd, ARB, READ_ONLY) + + # Process all SET or RESET statements in the file. Ignore all other + # statements. + + nset = 0 + lev = 0 + + repeat { + # Get the next SET statement into lbuf, leave IN at index of first + # char of the name field. + + if (getlline (fd, Memc[lbuf], SZ_LBUF) == EOF) { + if (lev > 0) { + call close (fd) + fd = sv_fd[lev] + lev = lev - 1 + next + } else + break + } else if (Memc[lbuf] == '\n' || Memc[lbuf] == '#') { + next + } else { + in = strmatch (Memc[lbuf], s_set) + if (in == 0) + in = strmatch (Memc[lbuf], s_reset) + + if (in <= 0) + next + else if (Memc[lbuf+in-1] == '@') { + ch = nowhite (Memc[lbuf+in], Memc[lbuf], SZ_LINE) + lev = lev + 1 + if (lev > MAXLEV) + call syserrs (SYS_FOPEN, Memc[lbuf]) + sv_fd[lev] = fd + fd = open (Memc[lbuf], READ_ONLY, TEXT_FILE) + next + } + } + + # Parse the name and value strings and enter into the environment + # list. Ignore optional quotes and whitespace. Ignore rest of + # line following the value field. + + op = name + op_top = name + MAX_SZKEY + ip = lbuf + in - 1 + for (ch=Memc[ip]; ch != '=' && ch != EOS; ch=Memc[ip]) { + if (!IS_QUOTE(ch) && !IS_WHITE(ch)) { + Memc[op] = Memc[ip] + op = min (op_top, op + 1) + } + ip = ip + 1 + } + Memc[op] = EOS + + op = value + if (Memc[ip] == '=') { + ip = ip + 1 + while (IS_WHITE(Memc[ip]) || IS_QUOTE(Memc[ip])) + ip = ip + 1 + op_top = value + MAX_SZVALUE + + for (ch=Memc[ip]; ch != EOS; ch=Memc[ip]) { + if (IS_QUOTE(ch) || ch == '\n') { + break + + } else if (ch == '\\' && Memc[ip+1] == '\n') { +again_ if (getlline (fd, Memc[lbuf], SZ_LBUF) == EOF) + break + + # Skip leading whitespace on the continuation line. + for (ip=lbuf; IS_WHITE(Memc[ip]); ip=ip+1) + ; + # Check for a commented out continuation line. + if (Memc[ip] == '#') + goto again_ + + } else { + Memc[op] = ch + op = min (op_top, op + 1) + ip = ip + 1 + } + } + } + Memc[op] = EOS + + # Enter the SET definition into the environment list. + call envreset (Memc[name], Memc[value]) + nset = nset + 1 + } + + call close (fd) + call sfree (sp) + + return (nset) +end diff --git a/sys/etc/erract.x b/sys/etc/erract.x new file mode 100644 index 00000000..5400544d --- /dev/null +++ b/sys/etc/erract.x @@ -0,0 +1,93 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +.help erract +.nf _________________________________________________________________________ +ERRACT -- Take error action. Called by FATAL, and by ERROR if a handler +is not posted. May be called by a user error handler to pass an error +back up to the handler at the next level, or to change the severity of +an error. Warning messages are posted to the standard error output, +whereas fatal errors result in error recovery followed by transmission of +the ERROR statement to the CL. + +Error restart consists of the following steps: + + (1) The IRAF main is restarted with the error code as argument. + (2) The main goes through error recovery. Error recovery consists + of cleaning up the files system, i.e., closing open files and + deleting NEW_FILES and TEMP_FILES, clearing the stack, and calling + any procedures posted with ONERROR. + (3) The ERROR statement is sent to the CL. An example of the + error statment is "ERROR (501, "Access Violation")". + (4) The main either waits for the next command, or if run from the CL + and the error code is SYS_XINT (a CL kill in response to a keyboard + interrupt), the main returns, shutting the process down. Procedures + posted with ONEXIT are called when the process shuts down. + +Any errors occuring during error restart or while executing the ONEXIT +procedures are fatal and result in immediate process termination, usually +with a panic error message. This is necessary to prevent infinite error +recursion. Also, if we are killed by the CL we should die and not hang up +trying to send error messages to the CL. +.endhelp ____________________________________________________________________ + +procedure erract (severity) + +int severity +int op, jumpbuf[LEN_JUMPBUF] +char wmsg[SZ_LINE] +int gstrcpy() +include "error.com" +common /JUMPCOM/ jumpbuf + +begin + # Clear error restart condition. Called by the IRAF Main + # after successful completion of error recovery. + + if (severity == EA_RESTART) { + err_restart = err_restart + 1 + xerflg = false + return + } else if (severity == OK) { + err_restart = 0 + xerflg = false + return + } + + # Any uncaught errors occuring during error restart are fatal and + # will result in process termination. This is necessary to prevent + # recursion and to ensure that a process killed by the CL dies if + # it cannot complete cleanup and shutdown without errors. If error + # recursion occurs we will be called repeatedly, causing the counter + # to be incremented until a panic abort occurs. + + if (severity != EA_WARN && err_restart > 2) { + call xer_fmterrmsg (xermsg, xermsg, SZ_XERMSG) + call sys_panic (xercod, xermsg) + } + + # If a handler is posted, set flag and return, deferring error + # recovery to the user handler. If warning message, merely put + # message to stderr. Otherwise initiate error recovery by restarting + # the IRAF main. This sounds reentrant, but it is not since it is an + # error restart using ZDOJMP. The ERROR statement is not sent to + # the CL until error recovery has completed. + + if (severity == EA_ERROR && nhandlers > 0) + xerflg = true + else { + call xer_fmterrmsg (xermsg, xermsg, SZ_XERMSG) + if (severity == EA_WARN) { + op = gstrcpy ("Warning: ", wmsg, SZ_LINE) + 1 + op = op + gstrcpy (xermsg, wmsg[op], SZ_LINE - op + 1) + wmsg[op] = '\n' + wmsg[op+1] = EOS + call xer_putline (STDERR, wmsg) + } else { + err_restart = err_restart + 1 + call zdojmp (jumpbuf, xercod) # Restart IRAF main. + } + } +end diff --git a/sys/etc/errcode.x b/sys/etc/errcode.x new file mode 100644 index 00000000..99df994b --- /dev/null +++ b/sys/etc/errcode.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ERRCODE -- Return the integer code of the last error posted. The error +# code is set to a positive nonnegative integer by a call to ERROR or +# FATAL, and is cleared (set to OK) whenever an IFERR block is entered. +# Note that if we are called from within an error handler (true part of +# an IFERR block), xerflg is false, so we cannot test xerflg to see if +# an error occurred. + +int procedure errcode() + +include "error.com" + +begin + return (xercod) +end diff --git a/sys/etc/errget.x b/sys/etc/errget.x new file mode 100644 index 00000000..e2ba10a9 --- /dev/null +++ b/sys/etc/errget.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ERRGET -- Return the integer code and descriptive error message string +# of the last error posted. The error code is set to a positive nonnegative +# integer by a call to ERROR or FATAL, and is cleared (set to OK) whenever +# an IFERR block is entered. Note that if we are called from within an error +# handler (true part of an IFERR block), xerflg is false, so we cannot test +# xerflg to see if an error occurred. + +int procedure errget (outstr, maxch) + +char outstr[maxch] # error message +int maxch +include "error.com" + +begin + call xer_fmterrmsg (xermsg, outstr, maxch) + return (xercod) +end diff --git a/sys/etc/error.com b/sys/etc/error.com new file mode 100644 index 00000000..2a7257f1 --- /dev/null +++ b/sys/etc/error.com @@ -0,0 +1,7 @@ + +bool xerflg # set when error is posted +int xercod # error code +int nhandlers # handler nesting level +int err_restart # YES during error restart, NO otherwise +char xermsg[SZ_XERMSG] # error message string +common /xercom/ xerflg,xercod,nhandlers,err_restart,xermsg diff --git a/sys/etc/error.x b/sys/etc/error.x new file mode 100644 index 00000000..42c390b5 --- /dev/null +++ b/sys/etc/error.x @@ -0,0 +1,60 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ERROR -- Take an error action. A call to ERROR does not necessarily +# terminate task execution, i.e., if an IFERR error handler is posted it +# will receive control after the procedure call stack is unwound back +# to the procedure containing the error handler. + +procedure error (error_code, message) + +int error_code # positive error code identifying error +char message[ARB] # error message describing error +include "error.com" + +begin + if (xerflg) { # error already posted? + if (max(error_code,1) == xercod) + return # same error again + else + call erract (EA_FATAL) # too many errors + } + + call xeract (error_code, message, EA_ERROR) +end + + +# FATAL -- Called when a fatal (irrecoverable) error occurs. Fatal errors +# cannot be caught by IFERR handlers. The calling task is terminated and +# error recovery is initiated in the IRAF Main. + +procedure fatal (error_code, message) + +int error_code # positive error code identifying error +char message[ARB] # error message describing error + +begin + call xeract (error_code, message, EA_FATAL) +end + + +# XERACT -- Take an error action; called by ERROR or FATAL. + +procedure xeract (error_code, message, severity) + +int error_code # positive error code identifying error +char message[ARB] # error message describing error +int severity # severity of the error +include "error.com" + +begin + xerflg = true # post error + xercod = max (1, error_code) + call strcpy (message, xermsg, SZ_XERMSG) + + if (nhandlers > 0 && severity == EA_ERROR) # is a handler posted? + return + else + call erract (severity) # take error action +end diff --git a/sys/etc/gen/miireadd.x b/sys/etc/gen/miireadd.x new file mode 100644 index 00000000..de15b8c1 --- /dev/null +++ b/sys/etc/gen/miireadd.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MIIREAD -- Read a block of data stored externally in MII format. +# Data is returned in the format of the local host machine. + +int procedure mii_readd (fd, spp, maxelem) + +int fd #I input file +double spp[ARB] #O receives data +int maxelem # max number of data elements to be read + +pointer sp, bp +int pksize, nchars, nelem +int miipksize(), miinelem(), read() +errchk read() + +long note() + +begin + pksize = miipksize (maxelem, MII_DOUBLE) + nelem = EOF + + if (pksize > maxelem * SZ_DOUBLE) { + # Read data into local buffer and unpack into user buffer. + + call smark (sp) + call salloc (bp, pksize, TY_CHAR) + + nchars = read (fd, Memc[bp], pksize) + if (nchars != EOF) { + nelem = min (maxelem, miinelem (nchars, MII_DOUBLE)) + call miiupkd (Memc[bp], spp, nelem, TY_DOUBLE) + } + + call sfree (sp) + + } else { + # Read data into user buffer and unpack in place. + + nchars = read (fd, spp, pksize) + if (nchars != EOF) { + nelem = min (maxelem, miinelem (nchars, MII_DOUBLE)) + call miiupkd (spp, spp, nelem, TY_DOUBLE) + } + } + + return (nelem) +end diff --git a/sys/etc/gen/miireadi.x b/sys/etc/gen/miireadi.x new file mode 100644 index 00000000..666166e6 --- /dev/null +++ b/sys/etc/gen/miireadi.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MIIREAD -- Read a block of data stored externally in MII format. +# Data is returned in the format of the local host machine. + +int procedure mii_readi (fd, spp, maxelem) + +int fd #I input file +int spp[ARB] #O receives data +int maxelem # max number of data elements to be read + +pointer sp, bp +int pksize, nchars, nelem +int miipksize(), miinelem(), read() +errchk read() + +long note() + +begin + pksize = miipksize (maxelem, MII_INT) + nelem = EOF + + if (pksize > maxelem * SZ_INT) { + # Read data into local buffer and unpack into user buffer. + + call smark (sp) + call salloc (bp, pksize, TY_CHAR) + + nchars = read (fd, Memc[bp], pksize) + if (nchars != EOF) { + nelem = min (maxelem, miinelem (nchars, MII_INT)) + call miiupki (Memc[bp], spp, nelem, TY_INT) + } + + call sfree (sp) + + } else { + # Read data into user buffer and unpack in place. + + nchars = read (fd, spp, pksize) + if (nchars != EOF) { + nelem = min (maxelem, miinelem (nchars, MII_INT)) + call miiupki (spp, spp, nelem, TY_INT) + } + } + + return (nelem) +end diff --git a/sys/etc/gen/miireadl.x b/sys/etc/gen/miireadl.x new file mode 100644 index 00000000..7a43688c --- /dev/null +++ b/sys/etc/gen/miireadl.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MIIREAD -- Read a block of data stored externally in MII format. +# Data is returned in the format of the local host machine. + +int procedure mii_readl (fd, spp, maxelem) + +int fd #I input file +long spp[ARB] #O receives data +int maxelem # max number of data elements to be read + +pointer sp, bp +int pksize, nchars, nelem +int miipksize(), miinelem(), read() +errchk read() + +long note() + +begin + pksize = miipksize (maxelem, MII_LONG) + nelem = EOF + + if (pksize > maxelem * SZ_LONG) { + # Read data into local buffer and unpack into user buffer. + + call smark (sp) + call salloc (bp, pksize, TY_CHAR) + + nchars = read (fd, Memc[bp], pksize) + if (nchars != EOF) { + nelem = min (maxelem, miinelem (nchars, MII_LONG)) + call miiupkl (Memc[bp], spp, nelem, TY_LONG) + } + + call sfree (sp) + + } else { + # Read data into user buffer and unpack in place. + + nchars = read (fd, spp, pksize) + if (nchars != EOF) { + nelem = min (maxelem, miinelem (nchars, MII_LONG)) + call miiupkl (spp, spp, nelem, TY_LONG) + } + } + + return (nelem) +end diff --git a/sys/etc/gen/miireadr.x b/sys/etc/gen/miireadr.x new file mode 100644 index 00000000..f3cded45 --- /dev/null +++ b/sys/etc/gen/miireadr.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MIIREAD -- Read a block of data stored externally in MII format. +# Data is returned in the format of the local host machine. + +int procedure mii_readr (fd, spp, maxelem) + +int fd #I input file +real spp[ARB] #O receives data +int maxelem # max number of data elements to be read + +pointer sp, bp +int pksize, nchars, nelem +int miipksize(), miinelem(), read() +errchk read() + +long note() + +begin + pksize = miipksize (maxelem, MII_REAL) + nelem = EOF + + if (pksize > maxelem * SZ_REAL) { + # Read data into local buffer and unpack into user buffer. + + call smark (sp) + call salloc (bp, pksize, TY_CHAR) + + nchars = read (fd, Memc[bp], pksize) + if (nchars != EOF) { + nelem = min (maxelem, miinelem (nchars, MII_REAL)) + call miiupkr (Memc[bp], spp, nelem, TY_REAL) + } + + call sfree (sp) + + } else { + # Read data into user buffer and unpack in place. + + nchars = read (fd, spp, pksize) + if (nchars != EOF) { + nelem = min (maxelem, miinelem (nchars, MII_REAL)) + call miiupkr (spp, spp, nelem, TY_REAL) + } + } + + return (nelem) +end diff --git a/sys/etc/gen/miireads.x b/sys/etc/gen/miireads.x new file mode 100644 index 00000000..acd7481a --- /dev/null +++ b/sys/etc/gen/miireads.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MIIREAD -- Read a block of data stored externally in MII format. +# Data is returned in the format of the local host machine. + +int procedure mii_reads (fd, spp, maxelem) + +int fd #I input file +short spp[ARB] #O receives data +int maxelem # max number of data elements to be read + +pointer sp, bp +int pksize, nchars, nelem +int miipksize(), miinelem(), read() +errchk read() + +long note() + +begin + pksize = miipksize (maxelem, MII_SHORT) + nelem = EOF + + if (pksize > maxelem * SZ_SHORT) { + # Read data into local buffer and unpack into user buffer. + + call smark (sp) + call salloc (bp, pksize, TY_CHAR) + + nchars = read (fd, Memc[bp], pksize) + if (nchars != EOF) { + nelem = min (maxelem, miinelem (nchars, MII_SHORT)) + call miiupks (Memc[bp], spp, nelem, TY_SHORT) + } + + call sfree (sp) + + } else { + # Read data into user buffer and unpack in place. + + nchars = read (fd, spp, pksize) + if (nchars != EOF) { + nelem = min (maxelem, miinelem (nchars, MII_SHORT)) + call miiupks (spp, spp, nelem, TY_SHORT) + } + } + + return (nelem) +end diff --git a/sys/etc/gen/miiwrited.x b/sys/etc/gen/miiwrited.x new file mode 100644 index 00000000..0b8d45c1 --- /dev/null +++ b/sys/etc/gen/miiwrited.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MIIWRITE -- Write a block of data to a file in MII format. +# The input data is in the host system native binary format. + +procedure mii_writed (fd, spp, nelem) + +int fd #I output file +int spp[ARB] #I native format data to be written +int nelem #I number of data elements to be written + +pointer sp, bp +int bufsize +int miipksize() + +begin + call smark (sp) + + bufsize = miipksize (nelem, MII_DOUBLE) + call salloc (bp, bufsize, TY_CHAR) + + call miipakd (spp, Memc[bp], nelem, TY_DOUBLE) + call write (fd, Memc[bp], bufsize) + + call sfree (sp) +end diff --git a/sys/etc/gen/miiwritei.x b/sys/etc/gen/miiwritei.x new file mode 100644 index 00000000..aa52be4a --- /dev/null +++ b/sys/etc/gen/miiwritei.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MIIWRITE -- Write a block of data to a file in MII format. +# The input data is in the host system native binary format. + +procedure mii_writei (fd, spp, nelem) + +int fd #I output file +int spp[ARB] #I native format data to be written +int nelem #I number of data elements to be written + +pointer sp, bp +int bufsize +int miipksize() + +begin + call smark (sp) + + bufsize = miipksize (nelem, MII_INT) + call salloc (bp, bufsize, TY_CHAR) + + call miipaki (spp, Memc[bp], nelem, TY_INT) + call write (fd, Memc[bp], bufsize) + + call sfree (sp) +end diff --git a/sys/etc/gen/miiwritel.x b/sys/etc/gen/miiwritel.x new file mode 100644 index 00000000..f9b800a5 --- /dev/null +++ b/sys/etc/gen/miiwritel.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MIIWRITE -- Write a block of data to a file in MII format. +# The input data is in the host system native binary format. + +procedure mii_writel (fd, spp, nelem) + +int fd #I output file +int spp[ARB] #I native format data to be written +int nelem #I number of data elements to be written + +pointer sp, bp +int bufsize +int miipksize() + +begin + call smark (sp) + + bufsize = miipksize (nelem, MII_LONG) + call salloc (bp, bufsize, TY_CHAR) + + call miipakl (spp, Memc[bp], nelem, TY_LONG) + call write (fd, Memc[bp], bufsize) + + call sfree (sp) +end diff --git a/sys/etc/gen/miiwriter.x b/sys/etc/gen/miiwriter.x new file mode 100644 index 00000000..94dcec38 --- /dev/null +++ b/sys/etc/gen/miiwriter.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MIIWRITE -- Write a block of data to a file in MII format. +# The input data is in the host system native binary format. + +procedure mii_writer (fd, spp, nelem) + +int fd #I output file +int spp[ARB] #I native format data to be written +int nelem #I number of data elements to be written + +pointer sp, bp +int bufsize +int miipksize() + +begin + call smark (sp) + + bufsize = miipksize (nelem, MII_REAL) + call salloc (bp, bufsize, TY_CHAR) + + call miipakr (spp, Memc[bp], nelem, TY_REAL) + call write (fd, Memc[bp], bufsize) + + call sfree (sp) +end diff --git a/sys/etc/gen/miiwrites.x b/sys/etc/gen/miiwrites.x new file mode 100644 index 00000000..ec2f48aa --- /dev/null +++ b/sys/etc/gen/miiwrites.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MIIWRITE -- Write a block of data to a file in MII format. +# The input data is in the host system native binary format. + +procedure mii_writes (fd, spp, nelem) + +int fd #I output file +int spp[ARB] #I native format data to be written +int nelem #I number of data elements to be written + +pointer sp, bp +int bufsize +int miipksize() + +begin + call smark (sp) + + bufsize = miipksize (nelem, MII_SHORT) + call salloc (bp, bufsize, TY_CHAR) + + call miipaks (spp, Memc[bp], nelem, TY_SHORT) + call write (fd, Memc[bp], bufsize) + + call sfree (sp) +end diff --git a/sys/etc/gen/mkpkg b/sys/etc/gen/mkpkg new file mode 100644 index 00000000..5437d80d --- /dev/null +++ b/sys/etc/gen/mkpkg @@ -0,0 +1,30 @@ +# Make the ETC portion of the system library libsys.a. + +$checkout libsys.a lib$ +$update libsys.a +$checkin libsys.a lib$ +$exit + +libsys.a: + miireadd.x + miireadi.x + miireadl.x + miireadr.x + miireads.x + miiwrited.x + miiwritei.x + miiwritel.x + miiwriter.x + miiwrites.x + + nmireadd.x + nmireadi.x + nmireadl.x + nmireadr.x + nmireads.x + nmiwrited.x + nmiwritei.x + nmiwritel.x + nmiwriter.x + nmiwrites.x + ; diff --git a/sys/etc/gen/nmireadb.x b/sys/etc/gen/nmireadb.x new file mode 100644 index 00000000..c3c0f75e --- /dev/null +++ b/sys/etc/gen/nmireadb.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# NMIREAD -- Read a block of data stored externally in NMI format. +# Data is returned in the format of the local host machine. + +int procedure nmi_readb (fd, spp, maxelem) + +int fd #I input file +bool spp[ARB] #O receives data +int maxelem # max number of data elements to be read + +pointer sp, bp +int pksize, nchars, nelem +int nmipksize(), nminelem(), read() +errchk read() + +long note() + +begin + pksize = nmipksize (maxelem, NMI_BOOL) + nelem = EOF + + if (pksize > maxelem * SZ_BOOL) { + # Read data into local buffer and unpack into user buffer. + + call smark (sp) + call salloc (bp, pksize, TY_CHAR) + + nchars = read (fd, Memc[bp], pksize) + if (nchars != EOF) { + nelem = min (maxelem, nminelem (nchars, NMI_BOOL)) + call nmiupkb (Memc[bp], spp, nelem, TY_BOOL) + } + + call sfree (sp) + + } else { + # Read data into user buffer and unpack in place. + + nchars = read (fd, spp, pksize) + if (nchars != EOF) { + nelem = min (maxelem, nminelem (nchars, NMI_BOOL)) + call nmiupkb (spp, spp, nelem, TY_BOOL) + } + } + + return (nelem) +end diff --git a/sys/etc/gen/nmireadd.x b/sys/etc/gen/nmireadd.x new file mode 100644 index 00000000..2d7c086a --- /dev/null +++ b/sys/etc/gen/nmireadd.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# NMI_READ -- Read a block of data stored externally in NMI format. +# Data is returned in the format of the local host machine. + +int procedure nmi_readd (fd, spp, maxelem) + +int fd #I input file +double spp[ARB] #O receives data +int maxelem # max number of data elements to be read + +pointer sp, bp +int pksize, nchars, nelem +int nmipksize(), nminelem(), read() +errchk read() + +long note() + +begin + pksize = nmipksize (maxelem, NMI_DOUBLE) + nelem = EOF + + if (pksize > maxelem * SZ_DOUBLE) { + # Read data into local buffer and unpack into user buffer. + + call smark (sp) + call salloc (bp, pksize, TY_CHAR) + + nchars = read (fd, Memc[bp], pksize) + if (nchars != EOF) { + nelem = min (maxelem, nminelem (nchars, NMI_DOUBLE)) + call nmiupkd (Memc[bp], spp, nelem, TY_DOUBLE) + } + + call sfree (sp) + + } else { + # Read data into user buffer and unpack in place. + + nchars = read (fd, spp, pksize) + if (nchars != EOF) { + nelem = min (maxelem, nminelem (nchars, NMI_DOUBLE)) + call nmiupkd (spp, spp, nelem, TY_DOUBLE) + } + } + + return (nelem) +end diff --git a/sys/etc/gen/nmireadi.x b/sys/etc/gen/nmireadi.x new file mode 100644 index 00000000..c07d5914 --- /dev/null +++ b/sys/etc/gen/nmireadi.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# NMI_READ -- Read a block of data stored externally in NMI format. +# Data is returned in the format of the local host machine. + +int procedure nmi_readi (fd, spp, maxelem) + +int fd #I input file +int spp[ARB] #O receives data +int maxelem # max number of data elements to be read + +pointer sp, bp +int pksize, nchars, nelem +int nmipksize(), nminelem(), read() +errchk read() + +long note() + +begin + pksize = nmipksize (maxelem, NMI_INT) + nelem = EOF + + if (pksize > maxelem * SZ_INT) { + # Read data into local buffer and unpack into user buffer. + + call smark (sp) + call salloc (bp, pksize, TY_CHAR) + + nchars = read (fd, Memc[bp], pksize) + if (nchars != EOF) { + nelem = min (maxelem, nminelem (nchars, NMI_INT)) + call nmiupki (Memc[bp], spp, nelem, TY_INT) + } + + call sfree (sp) + + } else { + # Read data into user buffer and unpack in place. + + nchars = read (fd, spp, pksize) + if (nchars != EOF) { + nelem = min (maxelem, nminelem (nchars, NMI_INT)) + call nmiupki (spp, spp, nelem, TY_INT) + } + } + + return (nelem) +end diff --git a/sys/etc/gen/nmireadl.x b/sys/etc/gen/nmireadl.x new file mode 100644 index 00000000..888beedf --- /dev/null +++ b/sys/etc/gen/nmireadl.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# NMI_READ -- Read a block of data stored externally in NMI format. +# Data is returned in the format of the local host machine. + +int procedure nmi_readl (fd, spp, maxelem) + +int fd #I input file +long spp[ARB] #O receives data +int maxelem # max number of data elements to be read + +pointer sp, bp +int pksize, nchars, nelem +int nmipksize(), nminelem(), read() +errchk read() + +long note() + +begin + pksize = nmipksize (maxelem, NMI_LONG) + nelem = EOF + + if (pksize > maxelem * SZ_LONG) { + # Read data into local buffer and unpack into user buffer. + + call smark (sp) + call salloc (bp, pksize, TY_CHAR) + + nchars = read (fd, Memc[bp], pksize) + if (nchars != EOF) { + nelem = min (maxelem, nminelem (nchars, NMI_LONG)) + call nmiupkl (Memc[bp], spp, nelem, TY_LONG) + } + + call sfree (sp) + + } else { + # Read data into user buffer and unpack in place. + + nchars = read (fd, spp, pksize) + if (nchars != EOF) { + nelem = min (maxelem, nminelem (nchars, NMI_LONG)) + call nmiupkl (spp, spp, nelem, TY_LONG) + } + } + + return (nelem) +end diff --git a/sys/etc/gen/nmireadr.x b/sys/etc/gen/nmireadr.x new file mode 100644 index 00000000..e8338400 --- /dev/null +++ b/sys/etc/gen/nmireadr.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# NMI_READ -- Read a block of data stored externally in NMI format. +# Data is returned in the format of the local host machine. + +int procedure nmi_readr (fd, spp, maxelem) + +int fd #I input file +real spp[ARB] #O receives data +int maxelem # max number of data elements to be read + +pointer sp, bp +int pksize, nchars, nelem +int nmipksize(), nminelem(), read() +errchk read() + +long note() + +begin + pksize = nmipksize (maxelem, NMI_REAL) + nelem = EOF + + if (pksize > maxelem * SZ_REAL) { + # Read data into local buffer and unpack into user buffer. + + call smark (sp) + call salloc (bp, pksize, TY_CHAR) + + nchars = read (fd, Memc[bp], pksize) + if (nchars != EOF) { + nelem = min (maxelem, nminelem (nchars, NMI_REAL)) + call nmiupkr (Memc[bp], spp, nelem, TY_REAL) + } + + call sfree (sp) + + } else { + # Read data into user buffer and unpack in place. + + nchars = read (fd, spp, pksize) + if (nchars != EOF) { + nelem = min (maxelem, nminelem (nchars, NMI_REAL)) + call nmiupkr (spp, spp, nelem, TY_REAL) + } + } + + return (nelem) +end diff --git a/sys/etc/gen/nmireads.x b/sys/etc/gen/nmireads.x new file mode 100644 index 00000000..190ce28f --- /dev/null +++ b/sys/etc/gen/nmireads.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# NMI_READ -- Read a block of data stored externally in NMI format. +# Data is returned in the format of the local host machine. + +int procedure nmi_reads (fd, spp, maxelem) + +int fd #I input file +short spp[ARB] #O receives data +int maxelem # max number of data elements to be read + +pointer sp, bp +int pksize, nchars, nelem +int nmipksize(), nminelem(), read() +errchk read() + +long note() + +begin + pksize = nmipksize (maxelem, NMI_SHORT) + nelem = EOF + + if (pksize > maxelem * SZ_SHORT) { + # Read data into local buffer and unpack into user buffer. + + call smark (sp) + call salloc (bp, pksize, TY_CHAR) + + nchars = read (fd, Memc[bp], pksize) + if (nchars != EOF) { + nelem = min (maxelem, nminelem (nchars, NMI_SHORT)) + call nmiupks (Memc[bp], spp, nelem, TY_SHORT) + } + + call sfree (sp) + + } else { + # Read data into user buffer and unpack in place. + + nchars = read (fd, spp, pksize) + if (nchars != EOF) { + nelem = min (maxelem, nminelem (nchars, NMI_SHORT)) + call nmiupks (spp, spp, nelem, TY_SHORT) + } + } + + return (nelem) +end diff --git a/sys/etc/gen/nmiwriteb.x b/sys/etc/gen/nmiwriteb.x new file mode 100644 index 00000000..9e3c19a0 --- /dev/null +++ b/sys/etc/gen/nmiwriteb.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# NMIWRITE -- Write a block of data to a file in NMI format. +# The input data is in the host system native binary format. + +procedure nmi_writeb (fd, spp, nelem) + +int fd #I output file +int spp[ARB] #I native format data to be written +int nelem #I number of data elements to be written + +pointer sp, bp +int bufsize +int nmipksize() + +begin + call smark (sp) + + bufsize = nmipksize (nelem, NMI_BOOL) + call salloc (bp, bufsize, TY_CHAR) + + call nmipakb (spp, Memc[bp], nelem, TY_BOOL) + call write (fd, Memc[bp], bufsize) + + call sfree (sp) +end diff --git a/sys/etc/gen/nmiwrited.x b/sys/etc/gen/nmiwrited.x new file mode 100644 index 00000000..d357fe4c --- /dev/null +++ b/sys/etc/gen/nmiwrited.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# NMI_WRITE -- Write a block of data to a file in NMI format. +# The input data is in the host system native binary format. + +procedure nmi_writed (fd, spp, nelem) + +int fd #I output file +int spp[ARB] #I native format data to be written +int nelem #I number of data elements to be written + +pointer sp, bp +int bufsize +int nmipksize() + +begin + call smark (sp) + + bufsize = nmipksize (nelem, NMI_DOUBLE) + call salloc (bp, bufsize, TY_CHAR) + + call nmipakd (spp, Memc[bp], nelem, TY_DOUBLE) + call write (fd, Memc[bp], bufsize) + + call sfree (sp) +end diff --git a/sys/etc/gen/nmiwritei.x b/sys/etc/gen/nmiwritei.x new file mode 100644 index 00000000..98e33f12 --- /dev/null +++ b/sys/etc/gen/nmiwritei.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# NMI_WRITE -- Write a block of data to a file in NMI format. +# The input data is in the host system native binary format. + +procedure nmi_writei (fd, spp, nelem) + +int fd #I output file +int spp[ARB] #I native format data to be written +int nelem #I number of data elements to be written + +pointer sp, bp +int bufsize +int nmipksize() + +begin + call smark (sp) + + bufsize = nmipksize (nelem, NMI_INT) + call salloc (bp, bufsize, TY_CHAR) + + call nmipaki (spp, Memc[bp], nelem, TY_INT) + call write (fd, Memc[bp], bufsize) + + call sfree (sp) +end diff --git a/sys/etc/gen/nmiwritel.x b/sys/etc/gen/nmiwritel.x new file mode 100644 index 00000000..0772b954 --- /dev/null +++ b/sys/etc/gen/nmiwritel.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# NMI_WRITE -- Write a block of data to a file in NMI format. +# The input data is in the host system native binary format. + +procedure nmi_writel (fd, spp, nelem) + +int fd #I output file +int spp[ARB] #I native format data to be written +int nelem #I number of data elements to be written + +pointer sp, bp +int bufsize +int nmipksize() + +begin + call smark (sp) + + bufsize = nmipksize (nelem, NMI_LONG) + call salloc (bp, bufsize, TY_CHAR) + + call nmipakl (spp, Memc[bp], nelem, TY_LONG) + call write (fd, Memc[bp], bufsize) + + call sfree (sp) +end diff --git a/sys/etc/gen/nmiwriter.x b/sys/etc/gen/nmiwriter.x new file mode 100644 index 00000000..3f22404b --- /dev/null +++ b/sys/etc/gen/nmiwriter.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# NMI_WRITE -- Write a block of data to a file in NMI format. +# The input data is in the host system native binary format. + +procedure nmi_writer (fd, spp, nelem) + +int fd #I output file +int spp[ARB] #I native format data to be written +int nelem #I number of data elements to be written + +pointer sp, bp +int bufsize +int nmipksize() + +begin + call smark (sp) + + bufsize = nmipksize (nelem, NMI_REAL) + call salloc (bp, bufsize, TY_CHAR) + + call nmipakr (spp, Memc[bp], nelem, TY_REAL) + call write (fd, Memc[bp], bufsize) + + call sfree (sp) +end diff --git a/sys/etc/gen/nmiwrites.x b/sys/etc/gen/nmiwrites.x new file mode 100644 index 00000000..ed284024 --- /dev/null +++ b/sys/etc/gen/nmiwrites.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# NMI_WRITE -- Write a block of data to a file in NMI format. +# The input data is in the host system native binary format. + +procedure nmi_writes (fd, spp, nelem) + +int fd #I output file +int spp[ARB] #I native format data to be written +int nelem #I number of data elements to be written + +pointer sp, bp +int bufsize +int nmipksize() + +begin + call smark (sp) + + bufsize = nmipksize (nelem, NMI_SHORT) + call salloc (bp, bufsize, TY_CHAR) + + call nmipaks (spp, Memc[bp], nelem, TY_SHORT) + call write (fd, Memc[bp], bufsize) + + call sfree (sp) +end diff --git a/sys/etc/gethost.x b/sys/etc/gethost.x new file mode 100644 index 00000000..029a9a0d --- /dev/null +++ b/sys/etc/gethost.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GETHOST -- Get the network name of the host machine. + +procedure gethost (outstr, maxch) + +char outstr[maxch] # receives host name string +int maxch + +begin + call zghost (outstr, maxch) + call strupk (outstr, outstr, maxch) +end diff --git a/sys/etc/getpid.x b/sys/etc/getpid.x new file mode 100644 index 00000000..6665a55e --- /dev/null +++ b/sys/etc/getpid.x @@ -0,0 +1,12 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GETPID -- Get the process id. + +int procedure getpid() + +int pid + +begin + call zgtpid (pid) + return (pid) +end diff --git a/sys/etc/getuid.x b/sys/etc/getuid.x new file mode 100644 index 00000000..3da5bbba --- /dev/null +++ b/sys/etc/getuid.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GETUID -- Get user id, i.e., return the name of the user. We do this by +# creating a temporary file and calling fowner to get the name of the file +# owner. + +procedure getuid (user_name, maxch) + +char user_name[ARB] +int maxch +pointer sp, tempfile +int open() + +begin + call smark (sp) + call salloc (tempfile, SZ_FNAME, TY_CHAR) + + call mktemp ("tmp$uid", Memc[tempfile], SZ_FNAME) + call close (open (Memc[tempfile], NEW_FILE, BINARY_FILE)) + call fowner (Memc[tempfile], user_name, maxch) + call delete (Memc[tempfile]) + + call sfree (sp) +end diff --git a/sys/etc/gmtcnv.x b/sys/etc/gmtcnv.x new file mode 100644 index 00000000..7713c9c0 --- /dev/null +++ b/sys/etc/gmtcnv.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GMTCNV.X -- GMT (Greenwich mean time) to LST (local standard time, or clock +# time) conversions. +# +# gmt = lsttogmt (lst) # lst/gmt are in seconds +# lst = gmttolst (gmt) # lst/gmt are in seconds + + + +# GMTTOLST -- Convert a long integer value in GMT seconds to LST seconds. + +long procedure gmttolst (gmt) + +long gmt # GMT in seconds +int gmtco + +begin + call zgmtco (gmtco) + return (gmt - gmtco) +end + + + +# LSTTOGMT -- Convert a long integer value in LST seconds to GMT seconds. + +long procedure lsttogmt (lst) + +long lst # LST in seconds +int gmtco + +begin + call zgmtco (gmtco) + return (lst + gmtco) +end diff --git a/sys/etc/gqsort.x b/sys/etc/gqsort.x new file mode 100644 index 00000000..8092aa29 --- /dev/null +++ b/sys/etc/gqsort.x @@ -0,0 +1,84 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define LOGPTR 32 # log2(maxpts) (4e9) + +# GQSORT -- General quicksort 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 (arg, 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] +# +# The value ARG is private to the compare routine and is merely passed on to +# the compare routine by gqsort. This allows context data to be passed to +# the compare routine without the need for initialization routines or commons. +# QSORT reorders the elements of the X array, which must be of type integer. + +procedure gqsort (x, nelem, compare, arg) + +int x[ARB] #U array to be sorted +int nelem #I number of elements in array +extern compare() #I function to be called to compare elements +int arg #I private data to be passed to compare func + +int i, j, k, lv[LOGPTR], p, pivot, uv[LOGPTR], temp +define swap {temp=$1;$1=$2;$2=temp} +int compare() + +begin + lv[1] = 1 + uv[1] = nelem + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy loop to trigger the optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # subfile, to avoid quadratic behavior on an already + # sorted list. + + k = (lv[p] + uv[p]) / 2 + swap (x[j], x[k]) + pivot = x[j] # pivot line + + while (i < j) { + for (i=i+1; compare (arg, x[i], pivot) < 0; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (compare (arg, x[j], pivot) <= 0) + break + if (i < j) # out of order pair + swap (x[i], x[j]) # interchange elements + } + + j = uv[p] # move pivot to position i + swap (x[i], x[j]) # interchange elements + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + + p = p + 1 # push onto stack + } + } +end diff --git a/sys/etc/intr.x b/sys/etc/intr.x new file mode 100644 index 00000000..e30d610c --- /dev/null +++ b/sys/etc/intr.x @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +define LEN_SAVE 10 + +# INTR_DISABLE, INTR_ENABLE -- Disable interrupts to protect a critical +# section of code. The interrupt handler is saved on a stack and restored +# when interupts are reenabled. + +procedure intr_disable() + +int sp +int save[LEN_SAVE] +common /zintde/ sp, save + +begin + sp = sp + 1 + if (sp > LEN_SAVE) + call sys_panic (1, "interrupt save stack overflow") + + call zxwhen (X_INT, X_IGNORE, save[sp]) +end + + +# INTR_ENABLE -- Reenable interrupts (restore saved interrupt handler). + +procedure intr_enable() + +int junk +int sp +int save[LEN_SAVE] +common /zintde/ sp, save + +begin + if (sp <= 0) + call sys_panic (1, "interrupt save stack underflow") + + call zxwhen (X_INT, save[sp], junk) + sp = sp - 1 +end + + +# INTR_RESET -- Clear the interrupt handler save stack. + +procedure intr_reset() + +int sp +int save[LEN_SAVE] +common /zintde/ sp, save + +begin + sp = 0 +end diff --git a/sys/etc/itob.x b/sys/etc/itob.x new file mode 100644 index 00000000..e01c6302 --- /dev/null +++ b/sys/etc/itob.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ITOB -- Convert integer to boolean. + +bool procedure itob (integer_value) + +int integer_value + +begin + if (integer_value == NO) + return (false) + else + return (true) +end diff --git a/sys/etc/lineoff.x b/sys/etc/lineoff.x new file mode 100644 index 00000000..23fe9050 --- /dev/null +++ b/sys/etc/lineoff.x @@ -0,0 +1,113 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# LINEOFF -- Textfile line offset package. This is a simple little package +# used to keep track of the file offsets of the lines in a text file. +# The entry points are as follows. +# +# lp = lno_open (maxlines) +# lno_close (lp) +# lno_save (lp, line, loffset, tag) +# OK|ERR = lno_fetch (lp, line, loffset, tag) +# +# The SAVE procedure is used to save line offsets in the database, and the +# FETCH procedure is used to look up line offsets, returning ERR if the offset +# of the line is not stored. + +define MIN_NLINES 64 +define LEN_LNODES 5 +define LNO_MAXLINES Memi[$1] # number of lines stored +define LNO_SLOT Memi[$1+1] # cycles around available slots +define LNO_LINENUMP Memi[$1+2] # pointer to array of line numbers +define LNO_LINEOFFP Memi[$1+3] # pointer to array of line offsets +define LNO_LINETAGP Memi[$1+4] # pointer to array of line tags + +# LNO_OPEN -- Open the line offset descriptor. + +pointer procedure lno_open (maxlines) + +int maxlines # max lines to store offsets for +int nlines +pointer lp +errchk calloc, malloc + +begin + nlines = max (MIN_NLINES, maxlines) + + call calloc (lp, LEN_LNODES, TY_STRUCT) + LNO_MAXLINES(lp) = nlines + call calloc (LNO_LINENUMP(lp), nlines, TY_LONG) + call malloc (LNO_LINEOFFP(lp), nlines, TY_LONG) + call malloc (LNO_LINETAGP(lp), nlines, TY_LONG) + + return (lp) +end + + +# LNO_CLOSE -- Return the line offset descriptor. + +procedure lno_close (lp) + +pointer lp # line offset descriptor + +begin + call mfree (LNO_LINENUMP(lp), TY_LONG) + call mfree (LNO_LINEOFFP(lp), TY_LONG) + call mfree (LNO_LINETAGP(lp), TY_LONG) + call mfree (lp, TY_STRUCT) +end + + +# LNO_SAVE -- Save a line number/offset pair in the LNO database. + +procedure lno_save (lp, line, loffset, ltag) + +pointer lp # line offset descriptor +int line # line number +long loffset # line offset from NOTE +long ltag # tag value assoc. with line +int slot + +begin + slot = LNO_SLOT(lp) + 1 + if (slot > LNO_MAXLINES(lp)) + slot = 1 + LNO_SLOT(lp) = slot + + Memi[LNO_LINENUMP(lp)+slot-1] = line + Meml[LNO_LINEOFFP(lp)+slot-1] = loffset + Meml[LNO_LINETAGP(lp)+slot-1] = ltag +end + + +# LNO_FETCH -- Search the LNO database for an entry for the indicated line and +# return its file offset if found. No assumptions are made about the ordering +# of the data since lines could have been entered in any order. ERR is +# returned if the line is not found in the database. A simple linear search +# is sufficient given that the applications using this package are not expected +# to look up a line often. + +int procedure lno_fetch (lp, line, loffset, ltag) + +pointer lp # line offset descriptor +int line # line number to search for +long loffset # receives line offset if entry for line is found +long ltag # receives tag value assoc. with line + +int maxl, i +pointer nump, offp, tagp + +begin + maxl = LNO_MAXLINES(lp) - 1 + nump = LNO_LINENUMP(lp) + offp = LNO_LINEOFFP(lp) + tagp = LNO_LINETAGP(lp) + + do i = 0, maxl + if (Memi[nump+i] == line) { + loffset = Meml[offp+i] + ltag = Meml[tagp+i] + return (OK) + } + + return (ERR) +end diff --git a/sys/etc/locpr.x b/sys/etc/locpr.x new file mode 100644 index 00000000..3af66d1d --- /dev/null +++ b/sys/etc/locpr.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# LOCPR -- Return the entry point address of a procedure, suitable for input +# to a ZCALL prcocedure to call the target procedure indirectly. + +int procedure locpr (proc) + +extern proc() # external procedure +int epa + +begin + call zlocpr (proc, epa) + return (epa) +end diff --git a/sys/etc/locva.x b/sys/etc/locva.x new file mode 100644 index 00000000..d3cc3bea --- /dev/null +++ b/sys/etc/locva.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# LOCVA -- Return the address (in CHAR units) of a variable. + +int procedure locva (variable) + +int variable # data object to be addressed +int address + +begin + call zlocva (variable, address) + return (address) +end diff --git a/sys/etc/lpopen.x b/sys/etc/lpopen.x new file mode 100644 index 00000000..4754e779 --- /dev/null +++ b/sys/etc/lpopen.x @@ -0,0 +1,118 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +define LP_INACTIVE 0 +define LP_READ 1 +define LP_WRITE 2 +define (LPCOM, common /lprcom/ lp_type, lp_nbytes) + +# LPOPEN -- Open the line printer device as a text or binary file. If opened +# as a text file, we arrange for the chars to be packed upon output, but in all +# cases the printer device appears to be a streaming binary file to FIO. +# If the printer device is opened as a binary file, the data stream is passed +# directly on to the device without modification. To simplify things a little +# we permit only one printer to be open at a time; this restriction can easily +# be removed should it prove desirable. + +int procedure lpopen (device, mode, type) + +char device[ARB] +int mode, type + +int fd +int lp_type, lp_nbytes +bool streq() +int fopnbf() +extern zopnlp(), lp_zaread(), lp_zawrite(), lp_zawait(), zsttlp(), zclslp() +LPCOM + +begin + # The TEXT device is special; it has a termcap entry and is used to + # format text for an ASCII textfile rather than a printer. + + if (streq (device, "text")) + fd = STDOUT + else { + lp_type = type + lp_nbytes = ERR + fd = fopnbf (device, mode, + zopnlp, lp_zaread, lp_zawrite, lp_zawait, zsttlp, zclslp) + } + + return (fd) +end + + +# LP_ZAREAD -- FIO z-aread routine for the line printer device. FIO calls +# us with the size of the buffer in bytes. If the printer is opened as a +# text file, we read a factor of SZB_CHAR less than that from the lowest +# level, then unpack the data inplace in the FIO buffer. + +procedure lp_zaread (chan, buf, maxbytes, offset) + +int chan +char buf[ARB] +int maxbytes +long offset # ignore, since lp is streaming device + +int nbytes +int lp_type, lp_nbytes +LPCOM + +begin + nbytes = maxbytes + if (lp_type == TEXT_FILE) + nbytes = nbytes / SZB_CHAR + + call zardlp (chan, buf, nbytes, offset) + call zawtlp (chan, lp_nbytes) + + if (lp_nbytes > 0 && lp_type == TEXT_FILE) + call chrupk (buf, 1, buf, 1, lp_nbytes) +end + + +# LP_ZAWRITE -- FIO z-awrite routine for the line printer device. FIO calls +# us with the size of the buffer in bytes. If the printer is opened as a +# text file, we first pack the data inplace in the FIO buffer, then write it +# out to the device. It is ok to modify the data directly in the FIO buffer +# since the device is a streaming device (no seeks). + +procedure lp_zawrite (chan, buf, nbytes, offset) + +int chan +char buf[ARB] +int nbytes +long offset # ignore, since lp is streaming device + +int nbytes_to_write +int lp_type, lp_nbytes +LPCOM + +begin + nbytes_to_write = nbytes + if (lp_type == TEXT_FILE) { + nbytes_to_write = nbytes_to_write / SZB_CHAR + call chrpak (buf, 1, buf, 1, nbytes_to_write) + } + + call zawrlp (chan, buf, nbytes_to_write, offset) + call zawtlp (chan, lp_nbytes) +end + + +# LP_ZAWAIT -- Wait for i/o to the line printer to complete. We do not bother +# with truely asynchronous i/o for line printer devices. + +procedure lp_zawait (chan, nbytes) + +int chan +int nbytes +int lp_type, lp_nbytes +LPCOM + +begin + nbytes = lp_nbytes +end diff --git a/sys/etc/maideh.x b/sys/etc/maideh.x new file mode 100644 index 00000000..d0850deb --- /dev/null +++ b/sys/etc/maideh.x @@ -0,0 +1,76 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +define SZ_ERRMSG SZ_LINE + +# MA_IDEH -- Iraf Main routine which installs the default exception handler. +# A single handler processes all exceptions. + +procedure ma_ideh() + +extern xstdexh() +int junk, i, epa_standard_handler +int exception[4] +data exception /X_ACV, X_INT, X_ARITH, X_IPC/ + +begin + call zlocpr (xstdexh, epa_standard_handler) + do i = 1, 4 + call xwhen (exception[i], epa_standard_handler, junk) + + # Initialize the critical section protection stack. + call intr_reset() +end + + +# XSTDEXH -- Standard exception handler. Unless the user code posts a handler +# for a particular exception, this handler will gain control. + +procedure xstdexh (exception, next_handler) + +int exception # code for exception +int next_handler # EPA of next handler to be called + +char os_errmsg[SZ_ERRMSG] +int os_errcode + +begin + # Get OS description of the exception. + call zxgmes (os_errcode, os_errmsg, SZ_ERRMSG) + call strupk (os_errmsg, os_errmsg, SZ_ERRMSG) + + # Cancel any output and resync awaits. + call fseti (STDOUT, F_CANCEL, OK) + call fseti (CLOUT, F_CANCEL, OK) + call fseti (CLIN, F_CANCEL, OK) + + # Set this here as error() will return immediately if it comes back. + next_handler = X_IGNORE + + # Take error action. + switch (exception) { + case X_ACV: + if (os_errcode > 0) + call fatal (SYS_XACV, os_errmsg) + else + call fatal (SYS_XACV, "Access violation") + case X_ARITH: + if (os_errcode > 0) + call fatal (SYS_XARITH, os_errmsg) + else + call fatal (SYS_XARITH, "Arithmetic exception") + case X_INT: + if (os_errcode > 0) + call fatal (SYS_XINT, os_errmsg) + else + call fatal (SYS_XINT, "Keyboard interrupt") + case X_IPC: + call fatal (SYS_XIPC, "Write to IPC with no reader") + + default: + call fatal (ERR, "Unknown exception") + } +end diff --git a/sys/etc/main.x b/sys/etc/main.x new file mode 100644 index 00000000..db6937bc --- /dev/null +++ b/sys/etc/main.x @@ -0,0 +1,908 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include +include +include + +.help iraf_main +.nf __________________________________________________________________________ +The IRAF MAIN + + Task resident interpreter for interface to CL. Supervises process startup +and shutdown, error restart, and task execution. A process may contain any +number of tasks, which need not be related. The iraf main allows a process to +be run either directly (interactively or in batch) or from the CL. A brief +description of the operation of the Main is given here; additional documentation +is given in the System Interface Reference Manual. + + +EXECUTION + +[1] The process containing the IRAF Main is run. The PROCESS MAIN, a machine + dependent code segment, gains control initially. The process main + determines whether the task is being run from as a connected subprocess, + as a detached process, or as a host process, and opens the process + standard i/o channels. The process main then calls the IRAF Main, i.e., us. + +[2] The IRAF Main performs the initialization associated with process startup + and then enters the interpreter loop waiting for a command. A number of + special commands are implemented, e.g.: + + ? print menu + bye shutdown process + chdir change directory + set set environment variable or variables + + Any other command is assumed to be the name of a task. The syntax of a + task invocation statement is as follows: + + [$]task [<[fname]], ([[stream[(T|B)]]>[fname]])|([[stream]>>[fname]]) + + Everything but the task name is optional. A leading $ enables printing of + the cpu time and clock time consumed by the process at termination. Any + combination of the standard i/o streams may be redirected on the command + line into a file. If the stream is redirected at the CL level redirection + is shown on the command line but the filename is omitted. + +[3] The communications protocol during task execution varies depending on + whether or not we are talking to the CL. If talking directly to the user, + the interpreter generates a prompt, and the standard input and output is + not blocked into XMIT and XFER commands. Interactive parameter requests + have the form "paramname: response" while CL/IPC requests have the form + "paramname=\nresponse", where "response" is the value entered by the user. + +[4] Task termination is indicated in interactive mode by generation of a prompt + for the next command and in CL/IPC mode by transmission of the command + "bye" to the parent process. If a task terminates abnormally the command + "error" is sent to the parent process or the terminal, and the Main reenters + the interpreter loop. + +A unique SYS_RUNTASK procedure is generated for each process at compile time by +performing string substitution on a TASK statement appearing in the source code. +The SYS_RUNTASK procedure contains the task dictionary, CALL statements for +each task, plus the special task "?". The main itself, i.e. this file, is a +precompiled library procedure which has no direct knowledge of the commands +to be run. + + +ERROR RECOVERY + + If a task terminates abnormally two things can happen: [1] a panic abort +occurs, causing immediate shutdown of the process (rare), or [2] the IRAF Main +is reentered at the ZSVJMP statement by a corresponding call to ZDOJMP from +elsewhere in the system, e.g., ERRACT in the error handling code. + +Error restart consists of the following steps: + + (1) The IRAF main is reentered at the point just after the ZDOJMP statement, + with a nonzero error code identifying the error in STATUS. + (2) The main performs error recovery, cleaning up the files system (deleting + NEW_FILES and TEMP_FILES), clearing the stack, and calling any + procedures posted with ONERROR. At present the error recovery code does + not free heap buffers or clear posted exception handlers. + (3) The ERROR statement is sent to the CL. An example of the + error statment is "ERROR (501, "Access Violation")". + (4) The main reenters the interpreter loop awaiting the next command from + the CL. + +Any error occuring during error restart is fatal and results in immediate +process termination, usually with a panic error message. This is necessary +to prevent infinite error recursion. + + +SHUTDOWN + + The process does not shutdown when interrupted by the CL or during error +recovery, unless a panic occurs. In normal operation shutdown only occurs when +the command BYE is received from the parennt process, or when EOF is read from +the process standard input. Procedures posted during execution with ONEXIT +will be called during process shutdown. Any error occuring while executing +an ONEXIT procedure is fatal and will result in a panic abort of the process. +.endhelp _____________________________________________________________________ + +define SZ_VALSTR SZ_COMMAND +define SZ_CMDBUF (SZ_COMMAND+1024) +define SZ_TASKNAME 32 +define TIMEIT_CHAR '$' +define MAXFD 5 # max redirectable fd's +define STARTUP 0 # stages of execution +define SHUTDOWN 1 +define IDLE 2 +define EXECUTING 3 +define DUMMY finit # any procedure will do + + +# IRAF_MAIN -- Execute commands read from the standard input until the special +# command "bye" is received, initiating process shutdown. The arguments tell +# the process type (connected, detached, or host) and identify the process +# standard i/o channels and device driver to be used. + +int procedure iraf_main (a_cmd, a_inchan, a_outchan, a_errchan, + a_driver, a_devtype, prtype, bkgfile, jobcode, sys_runtask, onentry) + +char a_cmd[ARB] # command to be executed or null string +int a_inchan # process standard input +int a_outchan # process standard output +int a_errchan # process standard error output +int a_driver # ZLOCPR address of device driver +int a_devtype # device type (text or binary) +int prtype # process type (connected, detached, host) +char bkgfile[ARB] # packed filename of bkg file if detached +int jobcode # jobcode if detached process +extern sys_runtask() # client task execution procedure +extern onentry() # client onentry procedure + +bool networking +int inchan, outchan, errchan, driver, devtype +char cmd[SZ_CMDBUF], taskname[SZ_TASKNAME], bkgfname[SZ_FNAME] +char irafinit[SZ_LINE] +int arglist_offset, timeit, junk, interactive, builtin_task, cmdin +int jumpbuf[LEN_JUMPBUF], status, errstat, state, interpret, i +long save_time[2] +pointer sp + +bool streq() +extern DUMMY() +int sys_getcommand(), sys_runtask(), oscmd() +int access(), envscan(), onentry(), stropen(), envgets() +errchk xonerror, fio_cleanup +common /JUMPCOM/ jumpbuf +string nullfile "dev$null" +data networking /KNET/ +define shutdown_ 91 + +# The following common is required on VMS systems to defeat the Fortran +# optimizer, which would otherwise produce optimizations that would cause +# a future return from ZSVJMP to fail. Beware that this trick may fail on +# other systems with clever optimizers. + +common /zzfakecom/ state + +begin + # The following initialization code is executed upon process + # startup only. + + errstat = OK + state = STARTUP + call mio_init() + call zsvjmp (jumpbuf, status) + if (status != OK) + call sys_panic (EA_FATAL, "fatal error during process startup") + + # Install the standard exception handlers, but if we are a connected + # subprocess do not enable interrupts until process startup has + # completed. + + call ma_ideh() + if (prtype == PR_CONNECTED) + call intr_disable() + + inchan = a_inchan + outchan = a_outchan + errchan = a_errchan + driver = a_driver + devtype = a_devtype + + # If the system is configured with networking initialize the network + # interface and convert the input channel codes and device driver + # code to their network equivalents. + + if (networking) + call ki_init (inchan, outchan, errchan, driver, devtype) + + # Other initializations. + call env_init() + call fmt_init (FMT_INITIALIZE) # init printf + call xer_reset() # init error checking + call erract (OK) # init error handling + call onerror (DUMMY) # init onerror + call onexit (DUMMY) # init onexit + call finit() # initialize FIO + call clopen (inchan, outchan, errchan, driver, devtype) + call clseti (CL_PRTYPE, prtype) + call clc_init() # init param cache + call strupk (bkgfile, bkgfname, SZ_FNAME) + + # If we are running as a host process (no IRAF parent process) look + # for the file "zzsetenv.def" in the current directory and then in + # the system library, and initialize the environment from this file + # if found. This works because the variable "iraf$" is defined at + # the ZGTENV level. + + interactive = NO + if (prtype == PR_HOST) { + interactive = YES + if (access ("zzsetenv.def",0,0) == YES) { + iferr (junk = envscan ("set @zzsetenv.def")) + ; + } else if (access ("hlib$zzsetenv.def",0,0) == YES) { + iferr (junk = envscan ("set @hlib$zzsetenv.def")) + ; + } else if (access ("host$hlib/zzsetenv.def",0,0) == YES) { + iferr (junk = envscan ("set @host$hlib/zzsetenv.def")) + ; + } + + # Allow the 'irafinit' environment variable to point to a file + # that may partially override the system zzsetenv.def file. + if (envgets ("irafinit", irafinit, SZ_LINE) > 0) { + if (access (irafinit, 0, 0) == YES) { + call sprintf (cmd, SZ_CMDBUF, "set @%s") + call pargstr (cmd) + iferr (junk = envscan (cmd)) + ; + } + } + } + + # Save context for error restart. If an error occurs execution + # resumes just past the ZSVJMP statement with a nonzero status. + + call smark (sp) + call zsvjmp (jumpbuf, status) + + if (status != OK) { + errstat = status + + # Give up if error occurs during shutdown. + if (state == SHUTDOWN) + call sys_panic (errstat, "fatal error during process shutdown") + + # Tell error handling package that an error restart is in + # progress (necessary to avoid recursion). + + call erract (EA_RESTART) + + iferr { + # Call user cleanup routines and then clean up files system. + # Make sure that user cleanup routines are called FIRST. + + call xonerror (status) + call ma_ideh() + call flush (STDERR) + do i = CLIN, STDPLOT + call fseti (i, F_CANCEL, OK) + call fio_cleanup (status) + call fmt_init (FMT_INITIALIZE) + call sfree (sp) + } then + call erract (EA_FATAL) # panic abort + + # Send ERROR statement to the CL, telling the CL that the task + # has terminated abnormally. The CL will either kill us, resulting + # in error restart with status=SYS_XINT, or send us another command + # to execute. If we are connected but idle, do not send the ERROR + # statement because the CL will not read it until it executes the + # next task (which it will then mistakenly think has aborted). + + if (!(prtype == PR_CONNECTED && state == IDLE)) + call xer_send_error_statement_to_cl (status) + + # Inform error handling code that error restart has completed, + # or next error call will result in a panic shutdown. + + call erract (OK) + call xer_reset () + status = OK + } + + # During process startup and shutdown the parent is not listening to + # us, hence we dump STDOUT and STDERR into the null file. If this is + # not done and we write to CLOUT, deadlock may occur. During startup + # we also call the ONENTRY procedure. This is a no-op for connected + # and host subprocesses unless a special procedure is linked by the + # user (for detached processes the standard ONENTRY procedure opens + # the bkgfile as CLIN). The return value of ONENTRY determines whether + # the interpreter loop is entered. Note that ONENTRY permits complete + # bypass of the standard interpreter loop by an application (e.g. the + # IRAF CL). + + if (state == STARTUP) { + # Redirect stderr and stdout to the null file. + if (prtype == PR_CONNECTED) { + call fredir (STDOUT, nullfile, WRITE_ONLY, TEXT_FILE) + call fredir (STDERR, nullfile, WRITE_ONLY, TEXT_FILE) + } + + # Call the custom or default ONENTRY procedure. The lowest bit + # of the return value contains the PR_EXIT/PR_NOEXIT flag, higher + # bits may contain a more meaningful 7-bit status code which will + # be returned to the shell. + + i = onentry (prtype, bkgfname, a_cmd) + if (mod(i, 2) == PR_EXIT) { + interpret = NO + errstat = i / 2 + goto shutdown_ + } else + interpret = YES + + # Open the command input stream. If a command string was given on + # the command line then we read commands from that, otherwise we + # take commands from CLIN. + + for (i=1; IS_WHITE(a_cmd[i]) || a_cmd[i] == '\n'; i=i+1) + ; + if (a_cmd[i] != EOS) { + cmdin = stropen (a_cmd, ARB, READ_ONLY) + call fseti (cmdin, F_KEEP, YES) + interpret = NO + interactive = NO + } else + cmdin = CLIN + } + + # Interpreter loop of the IRAF Main. Execute named tasks until the + # command "bye" is received, or EOF is read on the process standard + # input (CLIN). Prompts and other perturbations in the CL/IPC protocol + # are generated if we are being run directly as a host process. + + while (sys_getcommand (cmdin, cmd, taskname, arglist_offset, + timeit, prtype) != EOF) { + + builtin_task = NO + if (streq (taskname, "bye")) { + # Initiate process shutdown. + break + } else if (streq (taskname, "set") || streq (taskname, "reset")) { + builtin_task = YES + } else if (streq (taskname, "cd") || streq (taskname, "chdir")) { + builtin_task = YES + } else if (prtype == PR_CONNECTED && streq (taskname, "_go_")) { + # Restore the normal standard output streams, following + # completion of process startup. Reenable interrupts. + call close (STDOUT) + call close (STDERR) + call intr_enable() + state = IDLE + next + } else if (taskname[1] == '!') { + # Send a command to the host system. + junk = oscmd (cmd[arglist_offset], "", "", "") + next + } else + state = EXECUTING + + if (builtin_task == NO) { + if (timeit == YES) + call sys_mtime (save_time) + + # Clear the parameter cache. + call clc_init() + + # Set the name of the root pset. + call clc_newtask (taskname) + + # Process the argument list, consisting of any mixture of + # parameter=value directives and i/o redirection directives. + + call sys_scanarglist (cmdin, cmd[arglist_offset]) + } + + # Call sys_runtask (the code for which was generated automatically + # by the preprocessor in place of the TASK statement) to search + # the dictionary and run the named task. + + errstat = OK + call mem_init (taskname) + if (sys_runtask (taskname,cmd,arglist_offset,interactive) == ERR) { + call flush (STDOUT) + call sprintf (cmd, SZ_CMDBUF, + "ERROR (0, \"Iraf Main: Unknown task name (%s)\")\n") + call pargstr (taskname) + call putline (CLOUT, cmd) + call flush (CLOUT) + state = IDLE + next + } + call mem_fini (taskname) + + # Cleanup after successful termination of command. Flush the + # standard output, cancel any unread standard input so the next + # task won't try to read it, print elapsed time if enabled, + # check for an incorrect error handler, call any user posted + # termination procedures, close open files, close any redirected + # i/o and restore the normal standard i/o streams. + + if (builtin_task == NO) { + + call flush (STDOUT) + call fseti (STDIN, F_CANCEL, OK) + + if (timeit == YES) + call sys_ptime (STDERR, taskname, save_time) + + call xer_verify() + call xonerror (OK) + call fio_cleanup (OK) + + if (prtype == PR_CONNECTED) { + call putline (CLOUT, "bye\n") + call flush (CLOUT) + } + if (state != STARTUP) + state = IDLE + } + } + + # The interpreter has exited after receipt of "bye" or EOF. Redirect + # stdout and stderr to the null file (since the parent is no longer + # listening to us), call the user exit procedures if any, and exit. + +shutdown_ + state = SHUTDOWN + if (prtype == PR_CONNECTED) { + call fredir (STDOUT, nullfile, WRITE_ONLY, TEXT_FILE) + call fredir (STDERR, nullfile, WRITE_ONLY, TEXT_FILE) + } else if (prtype == PR_HOST && cmd[1] == EOS && interpret == YES) { + call putci (CLOUT, '\n') + call flush (CLOUT) + } + + call xonexit (OK) + call fio_cleanup (OK) + call clclose() + + return (errstat) +end + + +# SYS_GETCOMMAND -- Get the next command from the input file. Ignore blank +# lines and comment lines. Parse the command and return the components as +# output arguments. EOF is returned as the function value when eof file is +# reached on the input file. + +int procedure sys_getcommand (fd, cmd, taskname, arglist_offset, timeit, prtype) + +int fd #I command input file +char cmd[SZ_CMDBUF] #O command line +char taskname[SZ_TASKNAME] #O extracted taskname, lower case +int arglist_offset #O offset into CMD of first argument +int timeit #O if YES, time the command +int prtype #I process type code + +int ip, op +int getlline(), stridx() + +begin + repeat { + # Get command line. Issue prompt first if process is being run + # interactively. + + if (prtype == PR_HOST && fd == CLIN) { + call putline (CLOUT, "> ") + call flush (CLOUT) + } + if (getlline (fd, cmd, SZ_CMDBUF) == EOF) + return (EOF) + + # Check for timeit character and advance to first character of + # the task name. + + timeit = NO + for (ip=1; cmd[ip] != EOS; ip=ip+1) { + if (cmd[ip] == TIMEIT_CHAR && timeit == NO) + timeit = YES + else if (!IS_WHITE (cmd[ip])) + break + } + + # Skip blank lines and comment lines. + switch (cmd[ip]) { + case '#', '\n', EOS: + next + case '?', '!': + taskname[1] = cmd[ip] + taskname[2] = EOS + arglist_offset = ip + 1 + return (OK) + } + + # Extract task name. + op = 1 + while (IS_ALNUM (cmd[ip]) || stridx (cmd[ip], "_.$") > 0) { + taskname[op] = cmd[ip] + ip = ip + 1 + op = min (SZ_TASKNAME + 1, op + 1) + } + taskname[op] = EOS + + # Determine index of argument list. + while (IS_WHITE (cmd[ip])) + ip = ip + 1 + arglist_offset = ip + + # Get rid of the newline. + for (; cmd[ip] != EOS; ip=ip+1) + if (cmd[ip] == '\n') { + cmd[ip] = EOS + break + } + + return (OK) + } +end + + +# SYS_SCANARGLIST -- Parse the argument list of a task. At the level of the +# iraf main the command syntax is very simple. There are two types of +# arguments, parameter assignments (including switches) and i/o redirection +# directives. All param assignments are of the form "param=value", where +# PARAM must start with a lower case alpha and where VALUE is either quoted or +# is delimited by one of the metacharacters [ \t\n<>\\]. A redirection argument +# is anything which is not a parameter set argument, i.e., any argument which +# does not start with a lower case alpha. + +procedure sys_scanarglist (cmdin, i_args) + +int cmdin # command input stream +char i_args[ARB] # (first part of) argument list + +int fd +char ch +bool skip +pointer sp, fname, args, ip, op +int getlline() + +begin + call smark (sp) + call salloc (args, SZ_CMDBUF, TY_CHAR) + call salloc (fname, SZ_FNAME, TY_CHAR) + + call strcpy (i_args, Memc[args], SZ_CMDBUF) + + # Do not skip whitespace for param=value args on the command line. + skip = false + + # Inform FIO that all standard i/o streams are unredirected (overridden + # below if redirected by an argument). + + for (fd=1; fd < FIRST_FD; fd=fd+1) + call fseti (fd, F_REDIR, NO) + + # Process each argument in the argument list. If the command line ends + # with an escaped newline then continuation is assumed. Arguments are + # delimited by whitespace. + + for (ip=args; Memc[ip] != '\n' && Memc[ip] != EOS; ) { + # Advance to the next argument. + while (IS_WHITE (Memc[ip])) + ip = ip + 1 + + # Check for continuation. + ch = Memc[ip] + if (ch == '\\' && (Memc[ip+1] == '\n' || Memc[ip+1] == EOS)) { + if (getlline (cmdin, Memc[args], SZ_CMDBUF) == EOF) { + call sfree (sp) + return + } + ip = args + next + } else if (ch == '\n' || ch == EOS) + break + + # If the argument begins with an alpha, _, or $ (e.g., $nargs) + # then it is a param=value argument, otherwise it must be a redir. + # The form @filename causes param=value pairs to be read from + # the named file. + + if (ch == '@') { + op = fname + for (ip=ip+1; Memc[ip] != EOS; ip=ip+1) + if (IS_WHITE (Memc[ip]) || Memc[ip] == '\n') + break + else if (Memc[ip] == '\\' && Memc[ip+1] == '\n') + break + else { + Memc[op] = Memc[ip] + op = op + 1 + } + Memc[op] = EOS + call sys_getpars (Memc[fname]) + + } else if (IS_ALPHA(ch) || ch == '_' || ch == '$') { + call sys_paramset (Memc, ip, skip) + } else + call sys_redirect (Memc, ip) + } + + call sfree (sp) +end + + +# SYS_GETPARS -- Read a sequence of param=value parameter assignments from +# the named file and enter them into the CLIO cache for the task. + +procedure sys_getpars (fname) + +char fname # pset file + +bool skip +int lineno, fd +pointer sp, lbuf, ip +int open(), getlline() +errchk open, getlline + +begin + call smark (sp) + call salloc (lbuf, SZ_CMDBUF, TY_CHAR) + + fd = open (fname, READ_ONLY, TEXT_FILE) + + # Skip whitespace for param = value args in a par file. + skip = true + + lineno = 0 + while (getlline (fd, Memc[lbuf], SZ_CMDBUF) != EOF) { + lineno = lineno + 1 + for (ip=lbuf; IS_WHITE (Memc[ip]); ip=ip+1) + ; + if (Memc[ip] == '#' || Memc[ip] == '\n') + next + iferr (call sys_paramset (Memc, ip, skip)) { + for (; Memc[ip] != EOS && Memc[ip] != '\n'; ip=ip+1) + ; + Memc[ip] = EOS + call eprintf ("Bad param assignment, line %d: `%s'\n") + call pargi (lineno) + call pargstr (Memc[lbuf]) + } + } + + call close (fd) + call sfree (sp) +end + + +# SYS_PARAMSET -- Extract the param and value substrings from a param=value +# or switch argument and enter them into the CL parameter cache. (see also +# clio.clcache). + +procedure sys_paramset (args, ip, skip) + +char args[ARB] # argument list +int ip # pointer to first char of argument +bool skip # skip whitespace within "param=value" args + +pointer sp, param, value, op +int stridx() + +begin + call smark (sp) + call salloc (param, SZ_FNAME, TY_CHAR) + call salloc (value, SZ_VALSTR, TY_CHAR) + + # Extract the param field. + op = param + while (IS_ALNUM (args[ip]) || stridx (args[ip], "_.$") > 0) { + Memc[op] = args[ip] + op = op + 1 + ip = ip + 1 + } + Memc[op] = EOS + + # Advance to the switch character or assignment operator. + while (IS_WHITE (args[ip])) + ip = ip + 1 + + switch (args[ip]) { + case '+': + # Boolean switch "yes". + ip = ip + 1 + call strcpy ("yes", Memc[value], SZ_VALSTR) + + case '-': + # Boolean switch "no". + ip = ip + 1 + call strcpy ("no", Memc[value], SZ_VALSTR) + + case '=': + # Extract the value field. This is either a quoted string or a + # string delimited by any of the metacharacters listed below. + + ip = ip + 1 + if (skip) { + while (IS_WHITE (args[ip])) + ip = ip + 1 + } + call sys_gstrarg (args, ip, Memc[value], SZ_VALSTR) + + default: + call error (1, "IRAF Main: command syntax error") + } + + # Enter the param=value pair into the CL parameter cache. + call clc_enter (Memc[param], Memc[value]) + + call sfree (sp) +end + + +# SYS_REDIRECT -- Process a single redirection argument. The syntax of an +# argument to redirect the standard input is +# +# < [fname] +# +# If the filename is omitted it is understood that STDIN has been redirected +# in the CL. The syntax to redirect a standard output stream is +# +# [45678][TB](>|>>)[fname] +# +# where [4567] is the FD number of a standard output stream (STDOUT, STDERR, +# STDGRAPH, STDIMAGE, or STDPLOT), and [TB] indicates if the file is text or +# binary. If the stream is redirected at the CL level the output filename +# will be given as `$', serving only to indicate that the stream is redirected. + +procedure sys_redirect (args, ip) + +char args[ARB] # argument list +int ip # pointer to first char of redir arg + +pointer sp, fname +int fd, mode, type +int ctoi() +define badredir_ 91 +errchk fredir, fseti + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + # Get number of stream (0 if not given). + if (ctoi (args, ip, fd) <= 0) + fd = 0 + + # Get file type (optional). + while (IS_WHITE (args[ip])) + ip = ip + 1 + + switch (args[ip]) { + case 'T', 't': + type = TEXT_FILE + ip = ip + 1 + case 'B', 'b': + type = BINARY_FILE + ip = ip + 1 + default: + type = 0 + } + + # Check for "<", ">", or ">>". + while (IS_WHITE (args[ip])) + ip = ip + 1 + + switch (args[ip]) { + case '<': + ip = ip + 1 + mode = READ_ONLY + if (fd == 0) + fd = STDIN + else if (fd != STDIN || fd != CLIN) + goto badredir_ + + case '>': + ip = ip + 1 + if (args[ip] == '>') { + ip = ip + 1 + mode = APPEND + } else + mode = NEW_FILE + + if (fd == 0) + fd = STDOUT + else { + switch (fd) { + case CLOUT, STDOUT, STDERR, STDGRAPH, STDIMAGE, STDPLOT: + ; + default: + goto badredir_ + } + } + + default: + # Not a redirection argument. + call error (1, "IRAF Main: command syntax error") + } + + # Set default file type for given stream if no type specified. + if (type == 0) + switch (fd) { + case CLIN, CLOUT, STDIN, STDOUT, STDERR: + type = TEXT_FILE + default: + type = BINARY_FILE + } + + # Extract the filename, if any. If the CL has redirected the output + # and is merely using the redirection syntax to inform us of this, + # the metafilename "$" is given. + + while (IS_WHITE (args[ip])) + ip = ip + 1 + + if (args[ip] == '$') { + Memc[fname] = EOS + ip = ip + 1 + } else + call sys_gstrarg (args, ip, Memc[fname], SZ_FNAME) + + # At this point we have FD, FNAME, MODE and TYPE. If no file is + # named the stream has already been redirected by the parent and + # all we need to is inform FIO that the stream has been redirected. + # Otherwise we redirect the stream in the local process. A locally + # redirected stream will be closed and the normal direction restored + # during FIO cleanup, at program termination or during error + # recovery. + + if (Memc[fname] != EOS) + call fredir (fd, Memc[fname], mode, type) + else + call fseti (fd, F_REDIR, YES) + + call sfree (sp) + return + +badredir_ + call error (2, "IRAF Main: illegal redirection") +end + + +# SYS_GSTRARG -- Extract a string field. This is either a quoted string or a +# string delimited by any of the metacharacters " \t\n<>\\". + +procedure sys_gstrarg (args, ip, outstr, maxch) + +char args[ARB] # input string +int ip # pointer into input string +char outstr[maxch] # receives string field +int maxch + +char delim, ch +int op +int stridx() + +begin + op = 1 + if (args[ip] == '"' || args[ip] == '\'') { + # Quoted value string. + + delim = args[ip] + for (ip=ip+1; args[ip] != delim && args[ip] != EOS; ip=ip+1) { + if (args[ip] == '\n') { + break + } else if (args[ip] == '\\' && args[ip+1] == delim) { + outstr[op] = delim + op = op + 1 + ip = ip + 1 + } else { + outstr[op] = args[ip] + op = op + 1 + } + } + + } else { + # Nonquoted value string. + + for (delim=-1; args[ip] != EOS; ip=ip+1) { + ch = args[ip] + if (ch == '\\' && (args[ip+1] == '\n' || args[ip+1] == EOS)) + break + else if (stridx (ch, " \t\n<>\\") > 0) + break + else { + outstr[op] = ch + op = op + 1 + } + } + } + + outstr[op] = EOS + if (args[ip] == delim) + ip = ip + 1 +end diff --git a/sys/etc/miiread.gx b/sys/etc/miiread.gx new file mode 100644 index 00000000..a3efff2d --- /dev/null +++ b/sys/etc/miiread.gx @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MIIREAD -- Read a block of data stored externally in MII format. +# Data is returned in the format of the local host machine. + +int procedure mii_read$t (fd, spp, maxelem) + +int fd #I input file +PIXEL spp[ARB] #O receives data +int maxelem # max number of data elements to be read + +pointer sp, bp +int pksize, nchars, nelem +int miipksize(), miinelem(), read() +errchk read() + +long note() + +begin + pksize = miipksize (maxelem, MII_PIXEL) + nelem = EOF + + if (pksize > maxelem * SZ_PIXEL) { + # Read data into local buffer and unpack into user buffer. + + call smark (sp) + call salloc (bp, pksize, TY_CHAR) + + nchars = read (fd, Memc[bp], pksize) + if (nchars != EOF) { + nelem = min (maxelem, miinelem (nchars, MII_PIXEL)) + call miiupk$t (Memc[bp], spp, nelem, TY_PIXEL) + } + + call sfree (sp) + + } else { + # Read data into user buffer and unpack in place. + + nchars = read (fd, spp, pksize) + if (nchars != EOF) { + nelem = min (maxelem, miinelem (nchars, MII_PIXEL)) + call miiupk$t (spp, spp, nelem, TY_PIXEL) + } + } + + return (nelem) +end diff --git a/sys/etc/miireadc.x b/sys/etc/miireadc.x new file mode 100644 index 00000000..9354307c --- /dev/null +++ b/sys/etc/miireadc.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MIIREADC -- Read a block of character data stored externally in MII format. +# Data is returned in the machine independent character format. + +int procedure mii_readc (fd, spp, maxchars) + +int fd # input file +int spp[ARB] # receives data +int maxchars # max number of chars to be read + +pointer sp, bp +int pksize, nchars +int miipksize(), miinelem(), read() +errchk read() + +long note() + +begin + pksize = miipksize (maxchars, MII_BYTE) + nchars = max (maxchars, pksize) + + if (nchars > maxchars) { + # Read data into local buffer and unpack into user buffer. + + call smark (sp) + call salloc (bp, nchars, TY_CHAR) + + nchars = read (fd, Memc[bp], pksize) + if (nchars != EOF) { + nchars = min (maxchars, miinelem (nchars, MII_BYTE)) + call miiupk8 (Memc[bp], spp, nchars, TY_CHAR) + } + + call sfree (sp) + + } else { + # Read data into user buffer and unpack in place. + + nchars = read (fd, spp, pksize) + if (nchars != EOF) { + nchars = min (maxchars, miinelem (nchars, MII_BYTE)) + call miiupk8 (spp, spp, nchars, TY_CHAR) + } + } + + return (nchars) +end diff --git a/sys/etc/miiwrite.gx b/sys/etc/miiwrite.gx new file mode 100644 index 00000000..0bfce225 --- /dev/null +++ b/sys/etc/miiwrite.gx @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MIIWRITE -- Write a block of data to a file in MII format. +# The input data is in the host system native binary format. + +procedure mii_write$t (fd, spp, nelem) + +int fd #I output file +int spp[ARB] #I native format data to be written +int nelem #I number of data elements to be written + +pointer sp, bp +int bufsize +int miipksize() + +begin + call smark (sp) + + bufsize = miipksize (nelem, MII_PIXEL) + call salloc (bp, bufsize, TY_CHAR) + + call miipak$t (spp, Memc[bp], nelem, TY_PIXEL) + call write (fd, Memc[bp], bufsize) + + call sfree (sp) +end diff --git a/sys/etc/miiwritec.x b/sys/etc/miiwritec.x new file mode 100644 index 00000000..bdc20818 --- /dev/null +++ b/sys/etc/miiwritec.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MIIWRITEC -- Write a block of character data to a file in MII format. +# The input data is assumed to be in a machine independent format. + +procedure mii_writec (fd, spp, nchars) + +int fd # output file +int spp[ARB] # data to be written +int nchars # number of chars units to be written + +pointer sp, bp +int bufsize +int miipksize() + +begin + call smark (sp) + + bufsize = miipksize (nchars, MII_BYTE) + call salloc (bp, bufsize, TY_CHAR) + + call miipak8 (spp, Memc[bp], nchars, TY_CHAR) + call write (fd, Memc[bp], bufsize) + + call sfree (sp) +end diff --git a/sys/etc/mkpkg b/sys/etc/mkpkg new file mode 100644 index 00000000..578c290b --- /dev/null +++ b/sys/etc/mkpkg @@ -0,0 +1,125 @@ +# Make the ETC portion of the system library libsys.a. + +$checkout libsys.a lib$ +$update libsys.a +$checkin libsys.a lib$ +$exit + +generic: + $ifolder (gen/miireadi.x, miiread.gx) + $generic -k -p gen/ -t silrd miiread.gx + $endif + $ifolder (gen/miiwritei.x, miiwrite.gx) + $generic -k -p gen/ -t silrd miiwrite.gx + $endif + $ifolder (gen/nmireadi.x, nmiread.gx) + $generic -k -p gen/ -t silrd nmiread.gx + $endif + $ifolder (gen/nmiwritei.x, nmiwrite.gx) + $generic -k -p gen/ -t silrd nmiwrite.gx + $endif + ; + +libsys.a: + $ifeq (USE_GENERIC, yes) $call generic $endif + @gen + + brktime.x + btoi.x + clktime.x + cnvdate.x + cnvtime.x + cputime.x + dtmcnv.x + envgetb.x + envgetd.x + envgeti.x + envgetr.x + envgets.x environ.h + envindir.x + envinit.x environ.com environ.h + environ.x environ.com environ.h + envlist.x environ.com environ.h + envnext.x environ.com environ.h + envreset.x environ.com environ.h + envscan.x environ.h + erract.x error.com + errcode.x error.com + errget.x error.com + error.x error.com + gethost.x + getpid.x + getuid.x + gmtcnv.x + gqsort.x + intr.x + itob.x + lineoff.x + locpr.x + locva.x + lpopen.x + maideh.x + main.x \ + + miireadc.x + miiwritec.x + nmireadb.x + nmireadc.x + nmiwriteb.x + nmiwritec.x + onentry.x + onerror.x + onexit.x + oscmd.x + pagefiles.x \ + + prchdir.x + prclcpr.x prc.com + prcldpr.x prd.com + prclose.x prc.com + prdone.x prd.com + prenvfree.x + prenvset.x + prfilbuf.x prc.com + prfindpr.x prc.com + prgline.x prc.com + prgredir.x prc.com + prkill.x prd.com + propcpr.x prc.com \ + + propdpr.x prd.com + propen.x + proscmd.x prc.com + prpsio.x prc.com \ + + prpsload.x prc.com + prredir.x prc.com + prseti.x prc.com + prsignal.x prc.com + prstati.x prc.com + prupdate.x prc.com + psioisxt.x + psioxfer.x + qsort.x + sttyco.x + syserr.x + sysid.x + syspanic.x + sysptime.x + tsleep.x + ttopen.x + urlget.x + votable.x + xalloc.x + xerfmt.x + xerpop.x error.com + xerpue.x + xerreset.x error.com + xerstmt.x error.com + xerverify.x error.com + xgdevlist.x + xisatty.x + xmjbuf.x + xttysize.x + xwhen.x + ; diff --git a/sys/etc/nmiread.gx b/sys/etc/nmiread.gx new file mode 100644 index 00000000..401f1c2c --- /dev/null +++ b/sys/etc/nmiread.gx @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# NMI_READ -- Read a block of data stored externally in NMI format. +# Data is returned in the format of the local host machine. + +int procedure nmi_read$t (fd, spp, maxelem) + +int fd #I input file +PIXEL spp[ARB] #O receives data +int maxelem # max number of data elements to be read + +pointer sp, bp +int pksize, nchars, nelem +int nmipksize(), nminelem(), read() +errchk read() + +long note() + +begin + pksize = nmipksize (maxelem, NMI_PIXEL) + nelem = EOF + + if (pksize > maxelem * SZ_PIXEL) { + # Read data into local buffer and unpack into user buffer. + + call smark (sp) + call salloc (bp, pksize, TY_CHAR) + + nchars = read (fd, Memc[bp], pksize) + if (nchars != EOF) { + nelem = min (maxelem, nminelem (nchars, NMI_PIXEL)) + call nmiupk$t (Memc[bp], spp, nelem, TY_PIXEL) + } + + call sfree (sp) + + } else { + # Read data into user buffer and unpack in place. + + nchars = read (fd, spp, pksize) + if (nchars != EOF) { + nelem = min (maxelem, nminelem (nchars, NMI_PIXEL)) + call nmiupk$t (spp, spp, nelem, TY_PIXEL) + } + } + + return (nelem) +end diff --git a/sys/etc/nmireadb.x b/sys/etc/nmireadb.x new file mode 100644 index 00000000..dc23866c --- /dev/null +++ b/sys/etc/nmireadb.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + + +# NMI_READB -- Read a block of data stored externally in NMI format. +# Data is returned in the format of the local host machine. + +int procedure nmi_readb (fd, spp, maxelem) + +int fd #I input file +bool spp[ARB] #O receives data +int maxelem # max number of data elements to be read + +pointer sp, bp +int pksize, nchars, nelem +int nminelem(), read() +errchk read() + +long note() + +begin + pksize = nminelem (maxelem, NMI_INT) + nelem = EOF + + # Read data into user buffer and unpack in place. + nchars = read (fd, spp, pksize) + if (nchars != EOF) + nelem = min (maxelem, pksize) + + return (nelem) +end diff --git a/sys/etc/nmireadc.x b/sys/etc/nmireadc.x new file mode 100644 index 00000000..be65b9dd --- /dev/null +++ b/sys/etc/nmireadc.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# NMIREADC -- Read a block of character data stored externally in NMI format. +# Data is returned in the native machine character format. + +int procedure nmi_readc (fd, spp, maxchars) + +int fd # input file +int spp[ARB] # receives data +int maxchars # max number of chars to be read + +pointer sp, bp +int pksize, nchars +int nmipksize(), nminelem(), read() +errchk read() + +long note() + +begin + pksize = nmipksize (maxchars, NMI_BYTE) + nchars = max (maxchars, pksize) + + if (nchars > maxchars) { + # Read data into local buffer and unpack into user buffer. + + call smark (sp) + call salloc (bp, nchars, TY_CHAR) + + nchars = read (fd, Memc[bp], pksize) + if (nchars != EOF) { + nchars = min (maxchars, nminelem (nchars, NMI_BYTE)) + call nmiupk8 (Memc[bp], spp, nchars, TY_CHAR) + } + + call sfree (sp) + + } else { + # Read data into user buffer and unpack in place. + + nchars = read (fd, spp, pksize) + if (nchars != EOF) { + nchars = min (maxchars, nminelem (nchars, NMI_BYTE)) + call nmiupk8 (spp, spp, nchars, TY_CHAR) + } + } + + return (nchars) +end diff --git a/sys/etc/nmiwrite.gx b/sys/etc/nmiwrite.gx new file mode 100644 index 00000000..1efc4e45 --- /dev/null +++ b/sys/etc/nmiwrite.gx @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# NMI_WRITE -- Write a block of data to a file in NMI format. +# The input data is in the host system native binary format. + +procedure nmi_write$t (fd, spp, nelem) + +int fd #I output file +int spp[ARB] #I native format data to be written +int nelem #I number of data elements to be written + +pointer sp, bp +int bufsize +int nmipksize() + +begin + call smark (sp) + + bufsize = nmipksize (nelem, NMI_PIXEL) + call salloc (bp, bufsize, TY_CHAR) + + call nmipak$t (spp, Memc[bp], nelem, TY_PIXEL) + call write (fd, Memc[bp], bufsize) + + call sfree (sp) +end diff --git a/sys/etc/nmiwriteb.x b/sys/etc/nmiwriteb.x new file mode 100644 index 00000000..2819d1e8 --- /dev/null +++ b/sys/etc/nmiwriteb.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + + +# NMI_WRITEB -- Write a block of data to a file in NMI format. +# The input data is in the host system native binary format. + +procedure nmi_writeb (fd, spp, nelem) + +int fd #I output file +int spp[ARB] #I native format data to be written +int nelem #I number of data elements to be written + +int bufsize +int nminelem() + +begin + bufsize = nminelem (nelem, NMI_INT) + call write (fd, spp, bufsize) +end diff --git a/sys/etc/nmiwritec.x b/sys/etc/nmiwritec.x new file mode 100644 index 00000000..16dc572c --- /dev/null +++ b/sys/etc/nmiwritec.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# NMIWRITEC -- Write a block of character data to a file in NMI format. +# The input data is assumed to be in a native machine format. + +procedure nmi_writec (fd, spp, nchars) + +int fd # output file +int spp[ARB] # data to be written +int nchars # number of chars units to be written + +pointer sp, bp +int bufsize +int nmipksize() + +begin + call smark (sp) + + bufsize = nmipksize (nchars, NMI_BYTE) + call salloc (bp, bufsize, TY_CHAR) + + call nmipak8 (spp, Memc[bp], nchars, TY_CHAR) + call write (fd, Memc[bp], bufsize) + + call sfree (sp) +end diff --git a/sys/etc/onentry.x b/sys/etc/onentry.x new file mode 100644 index 00000000..6a2e823d --- /dev/null +++ b/sys/etc/onentry.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +define NFD 2 + +# ONENTRY -- Default procedure called by the IRAF Main during process startup, +# before entering the interpreter loop. If desired the user can supply their +# own ONENTRY procedure; this will be used instead of the system default if +# specified on the link line before the iraf libraries are searched. +# This procedure is a no-op for a connected or host process. For a detached +# process the default action is to redirect the standard input to the bkgfile, +# which is assumed to be a text file containing commands to be executed by +# the Main. +# +# The basic host calling sequence for an iraf process is as follows: +# +# x_file.e [-c | -d bkgfile ] [ command ] +# +# This is parsed by the zmain (host level main), returning the process type +# in PRTYPE, the bkgfile string in BKGFILE if the process type is detached, +# and anything remaining on the command line in CMD. If a custom onentry +# procedure is used CMD can be anything; all the iraf main does is concatenate +# the arguments into a string and pass it to the onentry procedure as CMD. + +int procedure onentry (prtype, bkgfile, cmd) + +int prtype #I process type (connected, detached, host) +char bkgfile[ARB] #I osfn of bkg file, if detached process +char cmd[ARB] #I command argument string, if any + +char osfn[SZ_FNAME] +int chan, loc_zgettx, i, fd[NFD] +data fd[1] /CLIN/, fd[2] /STDIN/ +extern zgettx() + +begin + if (prtype == PR_DETACHED) { + # Open the bkgfile and connect it to CLIN and STDIN. The stdin + # supplied by the process main is not used in this mode. + # We assume that no i/o has yet occurred on either file. Note + # that we do not wish to use FREDIR as that would preclude + # redirection on the command line. + + call strpak (bkgfile, osfn, SZ_FNAME) + call zopntx (osfn, READ_ONLY, chan) + if (chan == ERR) + call sys_panic (EA_FATAL, "Cannot open bkgfile") + call zlocpr (zgettx, loc_zgettx) + + do i = 1, NFD { + call fseti (fd[i], F_CHANNEL, chan) + call fseti (fd[i], F_DEVICE, loc_zgettx) + call fseti (fd[i], F_TYPE, TEXT_FILE) + } + } + + # If PR_EXIT is returned the interpreter loop is bypassed and process + # shutdown occurs immediately. + + return (PR_NOEXIT) +end diff --git a/sys/etc/onerror.x b/sys/etc/onerror.x new file mode 100644 index 00000000..d8bd36f3 --- /dev/null +++ b/sys/etc/onerror.x @@ -0,0 +1,96 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# ONERROR -- Give system the EPA of a procedure to be executed when task +# termination occurs (either normal task termination or task termination +# via error recovery). Each procedure will be called with the task termination +# status, i.e., OK for normal termination, else the ERRCODE argument to ERROR. + +procedure onerror (user_proc) + +extern user_proc() #I procedure to be posted + +int epa, i +bool first_time +int proc_list[MAX_ONERROR], nprocs +common /onercm/ nprocs, proc_list +data first_time /true/ + +begin + # The first call is by the IRAF main at process startup time, with + # a dummy argument. + + if (first_time) { + nprocs = 0 + first_time = false + return + } + + call zlocpr (user_proc, epa) + + # Ignore the call if the procedure has already been posted. + # Otherwise tack address of proc onto list and return. + + for (i=1; i <= nprocs; i=i+1) + if (epa == proc_list[i]) + return + + nprocs = nprocs + 1 + if (nprocs > MAX_ONERROR) + iferr (call syserr (SYS_SONERROVFL)) + call erract (EA_WARN) + + proc_list[nprocs] = epa +end + + +# ONERROR_REMOVE -- Remove a previously posted ONERROR procedure. + +procedure onerror_remove (user_proc) + +extern user_proc() #I procedure to be posted + +int epa, i +int proc_list[MAX_ONERROR], nprocs +common /onercm/ nprocs, proc_list + +begin + call zlocpr (user_proc, epa) + for (i=1; i <= nprocs; i=i+1) + if (proc_list[i] == epa) + proc_list[i] = 0 +end + + +# XONERROR -- Called at task termination by the IRAF Main to execute each of +# the posted user error cleanup procedures (if any). Procedures are executed +# in the order in which they were posted. The task termination status is +# passed to the called procedure as the single argument to the procedure. +# The list of termination handlers is cleared when finished. + +procedure xonerror (status) + +int status #I task termination status (OK or error code) + +int nprocs_to_execute, i +int proc_list[MAX_ONERROR], nprocs +common /onercm/ nprocs, proc_list +errchk zcall1 + +begin + # Clear "nprocs" before calling user procedures, to ensure that + # a reentrant call does not lead to an infinite loop (i.e., in the + # event of an error during execution of a cleanup procedure). + # In principle this should not be necessary, since an error occurring + # during error restart should result in a panic abort. + + nprocs_to_execute = nprocs + nprocs = 0 + + for (i=1; i <= nprocs_to_execute; i=i+1) + if (proc_list[i] != 0) + call zcall1 (proc_list[i], status) +end diff --git a/sys/etc/onexit.x b/sys/etc/onexit.x new file mode 100644 index 00000000..44212cf1 --- /dev/null +++ b/sys/etc/onexit.x @@ -0,0 +1,88 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# ONEXIT -- Give system the EPA of a procedure to be executed when process +# shutdown occurs. + +procedure onexit (user_proc) + +extern user_proc() #I procedure to be posted +bool first_time +int epa, i +int proc_list[MAX_ONEXIT], nprocs +common /onexcm/ nprocs, proc_list +data first_time /true/ + +begin + # The first call is by the IRAF main at process startup time, with + # a dummy argument. + + if (first_time) { + nprocs = 0 + first_time = false + return + } + + call zlocpr (user_proc, epa) + + # Ignore the call if the procedure has already been posted. + # Otherwise tack address of proc onto list and return. + + for (i=1; i <= nprocs; i=i+1) + if (epa == proc_list[i]) + return + + nprocs = nprocs + 1 + if (nprocs > MAX_ONEXIT) + iferr (call syserr (SYS_SONEXITOVFL)) + call erract (EA_WARN) + + proc_list[nprocs] = epa +end + + +# ONEXIT_REMOVE -- Remove a previously posted ONEXIT procedure. + +procedure onexit_remote (user_proc) + +extern user_proc() #I procedure to be posted + +int epa, i +int proc_list[MAX_ONERROR], nprocs +common /onexcm/ nprocs, proc_list + +begin + call zlocpr (user_proc, epa) + for (i=1; i <= nprocs; i=i+1) + if (proc_list[i] == epa) + proc_list[i] = 0 +end + + +# XONEXIT -- Called at process shutdown time by the IRAF main to execute +# each posted user exit procedure. Exit procedures are called in the order +# in which they were posted. Try to survive errors so that all exit +# procedures may be called. Do not take an error action or issue a warning +# message, since by the time we are called the CL has stopped listening to +# us (it might possibly be safer to panic). + +procedure xonexit (exit_code) + +int exit_code #I passed to exit handlers +int nprocs_to_execute, i +int proc_list[MAX_ONEXIT], nprocs +common /onexcm/ nprocs, proc_list +errchk zcall1 + +begin + nprocs_to_execute = nprocs + nprocs = 0 + + for (i=1; i <= nprocs_to_execute; i=i+1) + if (proc_list[i] != 0) + iferr (call zcall1 (proc_list[i], exit_code)) + ; +end diff --git a/sys/etc/oscmd.x b/sys/etc/oscmd.x new file mode 100644 index 00000000..78b723c2 --- /dev/null +++ b/sys/etc/oscmd.x @@ -0,0 +1,116 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# OSCMD -- Send a (machine dependent) command to the host operating system. +# Try to spool the standard output and error output in the named files if +# nonnull names for the files are given. OK is returned if the command +# executes successfully. + +int procedure oscmd (cmd, infile, outfile, errfile) + +char cmd[ARB] # host command +char infile[ARB] # name of host command input file +char outfile[ARB] # name of file to receive output +char errfile[ARB] # name of file to receive error output + +int status, ip, ch +pointer sp, cmdbuf, osin, osout, oserr, ostmp, op +errchk fmapfn, mktemp, fclobber, flush, putline +int clstati(), getci() +bool fnullfile() + +begin + call smark (sp) + call salloc (cmdbuf, SZ_COMMAND, TY_CHAR) + call salloc (osin, SZ_PATHNAME, TY_CHAR) + call salloc (osout, SZ_PATHNAME, TY_CHAR) + call salloc (oserr, SZ_PATHNAME, TY_CHAR) + call salloc (ostmp, SZ_PATHNAME, TY_CHAR) + + # If we are called from the root process, e.g., the CL, the ZOSCMD + # primitive is called directly to transmit the host command, otherwise + # the OS command is sent up to the parent (root) process which calls + # ZOSCMD. This is necessary because the ZOSCMD primitive will not + # work from a subprocess on some systems, due to difficulties trying + # to spawn the host command interpreter. + + if (clstati (CL_PRTYPE) != PR_CONNECTED) { + # Root process: send command directly to the host command + # interpreter. + + # Pack command string and get OS versions of the filenames. + call strpak (cmd, Memc[cmdbuf], SZ_COMMAND) + if (infile[1] == EOS) + call strpak ("", Memc[osin], SZ_PATHNAME) + else + call fmapfn (infile, Memc[osin], SZ_PATHNAME) + + # If output is directed to dev$null, save in temp file and delete. + if (fnullfile(outfile) || fnullfile(errfile)) + call mktemp ("tmp$null", Memc[ostmp], SZ_PATHNAME) + else + Memc[ostmp] = EOS + + if (outfile[1] == EOS) + call strpak ("", Memc[osout], SZ_PATHNAME) + else if (fnullfile (outfile)) + call fmapfn (Memc[ostmp], Memc[osout], SZ_PATHNAME) + else { + call fclobber (outfile) + call fmapfn (outfile, Memc[osout], SZ_PATHNAME) + } + + if (errfile[1] == EOS) + call strpak ("", Memc[oserr], SZ_PATHNAME) + else if (fnullfile (errfile)) + call fmapfn (Memc[ostmp], Memc[oserr], SZ_PATHNAME) + else { + call fclobber (errfile) + call fmapfn (errfile, Memc[oserr], SZ_PATHNAME) + } + + # Execute the command and wait for completion. + call zoscmd (Memc[cmdbuf], Memc[osin], Memc[osout], Memc[oserr], + status) + + # Discard output directed to dev$null. + if (Memc[ostmp] != EOS) + iferr (call delete (Memc[ostmp])) + call erract (EA_WARN) + + } else { + # Connected subprocess. Send the command to the parent process to + # be processed as a system directive by the pseudofile i/o system + # in the parent process. Synchronous execution is desired, so wait + # for a status return from the parent process before returning. + # The redirection files are ignored in this mode. + + call flush (CLOUT) + + # Send command. + Memc[cmdbuf] = '!' + op = cmdbuf + 1 + for (ip=1; cmd[ip] != EOS && cmd[ip] != '\n'; ip=ip+1) { + Memc[op] = cmd[ip] + op = op + 1 + } + Memc[op] = '\n' + Memc[op+1] = EOS + call putline (CLOUT, Memc[cmdbuf]) + call flush (CLOUT) + + # Get the return status, encoded as a nonnegative decimal integer. + for (status=0; getci (CLIN, ch) != EOF; ) + if (ch == '\n') + break + else + status = status * 10 + TO_INTEG(ch) + } + + call sfree (sp) + return (status) +end diff --git a/sys/etc/pagefiles.x b/sys/etc/pagefiles.x new file mode 100644 index 00000000..22ef4840 --- /dev/null +++ b/sys/etc/pagefiles.x @@ -0,0 +1,1140 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include + +# PAGEFILES.X -- Page through a file or set of files. Both backwards and +# forwards traversals of files and file lists are supported, but not +# (currently) backwards paging of a pipe. +# +# This program is a hack as it was coded starting from the original PAGE +# program, which was much simpler. TODO: Add upscrolling and the ability +# to buffer input and scoll backwards on a pipe. The present program is +# monolithic and should be restructured if these features are added. + +define CC_PREFIX '^' +define MAKE_PRINTABLE ($1+'A'-1) +define SZ_QUERYMSG 80 +define SZ_KEYSTR 80 +define LNO_MAXLINES 2048 +define SZ_LONGLINE 4096 +define MAX_PAGE 100 +define MAX_PBCMD 100 +define UKEYS "ukey" # CL parameter for keyboard input + +# Command keystrokes. + +define HELPTXT "[q=quit,e=edit,d=dn,u=up,f|sp=fpg,b=bpg,j|cr=dnln,k=upln,.=bof,N=nfile,P=pfile]" + +define HELP '?' # print helptxt +define QUIT 'q' # return to CL +define EDIT 'e' # edit current file +define FWD_SCREEN 'f' # forward one full screen +define BACK_SCREEN 'b' # back one full screen +define SCROLL_DOWN 'd' # forward half a screen +define SCROLL_UP 'u' # back half a screen +define PREV_LINE 'k' # back one line +define NEXT_LINE 'j' # forward one line +define TO_BOF '.' # to beginning of file +define TO_EOF 'G' # to end of file +define TO_EOF_ALT 'g' # to end of file +define SEARCH 'n' # search for next occurrence of pattern +define REDRAW '\014' # redraw screen + +define NEXT_FILE 'N' # goto next file in list +define PREV_FILE 'P' # goto previous file in list +define NEXT_FILE_ALT '\016' # +define PREV_FILE_ALT '\020' # + +define LCMD ':' # colon commands +define TO_FILE 'F' # ":file filename" + + +# PAGEFILES -- Display a text file or files on the standard output (the user +# terminal) one screen at a time, pausing after each screen has been filled. +# The program is keystroke driven in raw mode, and currently recognizes the +# keystrokes defined above. +# +# If map_cc is enabled, all unknown control characters will be converted into +# printable sequences. The following control character sequences have a +# special significance in IRAF textfiles: FF=formfeed, SO=set standout mode, +# SI=clear standout mode. These sequences are mapped into whatever the output +# device requires upon output by the TTY subroutines. + +procedure pagefiles (files) + +char files[ARB] # file template + +string device "terminal" +string prompt "" +int first_page +int clear_screen +int map_cc + +begin + first_page = 1 + clear_screen = YES + map_cc = YES + + call xpagefiles (files, device, + prompt, first_page, clear_screen, map_cc) +end + + +# PAGEFILE -- Page a single file; an alternate entry point to the more general +# routine. A prompt string different than the filename may be specified and +# the screen is not cleared when scrolling downward. + +procedure pagefile (fname, prompt) + +char fname[ARB] # name of file to be paged +char prompt[ARB] # prompt string, if different than fname + +string device "terminal" +int first_page +int clear_screen +int map_cc + +begin + first_page = 1 + clear_screen = NO + map_cc = YES + + call xpagefiles (fname, device, + prompt, first_page, clear_screen, map_cc) +end + + +# XPAGEFILES -- Generalized file pager. + +procedure xpagefiles (files, device, prompt, first_page, clear_screen, map_cc) + +char files[ARB] # file template +char device[ARB] # output device name +char prompt[ARB] # prompt string (filename if null) +int first_page # first page to be displayed +int clear_screen # clear screen between pages +int map_cc # map control chars on output + +bool redirin, useroot +pointer sp, fname, newfname, tty, lbuf +int spoolfd, list, nfiles, cmd, i, j, n, o + +pointer ttyodes() +bool ttygetb() +int strncmp(), strlen() +int fntopnb(), fntrfnb(), fntlenb(), fnldir() +int pg_getcmd(), pg_pagefile(), fstati() +errchk fntopnb, ttyodes, ttygetb, fntrfnb, pg_pagefile, pg_getcmd +define err_ 91 + +begin + call smark (sp) + call salloc (newfname, SZ_FNAME, TY_CHAR) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + list = fntopnb (files, YES) + nfiles = fntlenb (list) + spoolfd = NULL + + tty = ttyodes (device) + redirin = (fstati (STDIN, F_REDIR) == YES) + + # If terminal cannot scroll, set clear_screen to true regardless of the + # value given above. + + if (ttygetb (tty, "ns")) + clear_screen = YES + + cmd = NEXT_FILE + for (i=1; i <= nfiles && cmd != QUIT; i=i+1) { + # Get next filename. + if (fntrfnb (list, i, Memc[fname], SZ_FNAME) == EOF) + break + + # Page the file. + cmd = pg_pagefile (tty, Memc[fname], Memc[newfname], prompt, + clear_screen, first_page, map_cc, i, nfiles, redirin, spoolfd) + + # Decide what to do next. + while (cmd != QUIT) { + switch (cmd) { + case NEXT_FILE, BLANK, NEXT_LINE, CR, LF: + if (i >= nfiles) + cmd = pg_getcmd (tty, "no more files", 0,0,0,i,nfiles) + else + break + case PREV_FILE: + if (i <= 1) + cmd = pg_getcmd (tty, "at first file", 0,0,0,i,nfiles) + else { + i = i - 2 + break + } + + case TO_FILE: + # Position within the file list. If the user specified a + # logical directory in the filename, perform the compares + # on the raw filenames in the list, otherwise use only the + # root filename. + + useroot = (fnldir(Memc[newfname],Memc[fname],SZ_FNAME) <= 0) + n = strlen (Memc[newfname]) + + for (j=1; j <= nfiles; j=j+1) + if (fntrfnb (list, j, Memc[lbuf], SZ_FNAME) > 0) { + if (useroot) + o = fnldir (Memc[lbuf], Memc[fname], SZ_FNAME) + else + o = 0 + if (strncmp (Memc[lbuf+o], Memc[newfname], n) >= 0) + break + } + + if (j > nfiles) + i = nfiles - 1 + else + i = j - 1 + break + + case LCMD: + # Colon escape. Only :file is recognized at this level. + + call pg_getstr (Memc[newfname], SZ_FNAME) + cmd = TO_FILE + + case HELP: + cmd = pg_getcmd (tty, HELPTXT, 0,0,0,0,0) + + default: +err_ if (!redirin) { + call eprintf ("\07") + call flush (STDERR) + i = i - 1 # redisplay current file + } + break + } + } + } + + if (spoolfd != NULL) + call close (spoolfd) + + call fntclsb (list) + call sfree (sp) +end + + +# PG_PAGEFILE -- Display the named file on the standard output, page by +# page, pausing for user response between pages. + +int procedure pg_pagefile (tty, fname, newfname, u_prompt, clear_screen, + first_page, map_cc, fileno, nfiles, redirin, spoolfd) + +pointer tty +char fname[ARB] # file to be paged +char newfname[ARB] # next file to be page (ret. by :file) +char u_prompt[ARB] # prompt string, if not same as filename +int clear_screen # clear screen between pages? +int first_page # first page of file to be displayed +int map_cc # map control characters? +int fileno # current file number +int nfiles # number of files to be paged +bool redirin # reading from the standard input +int spoolfd # fd if spooling output in a file + +char patbuf[SZ_LINE] +int nlines, ncols, maxlines, maxcols +long fi[LEN_FINFO], nchars, totchars, loffset +pointer sp, lbuf, prompt, token, cmdbuf, ip, op, lp +long pgoff[MAX_PAGE], pgnch[MAX_PAGE], pglno[MAX_PAGE] +int fd, lineno, linelen, nleft, destline, toklen, lnout, i +bool ateof, first_call, redirout, pushback, upline, upline_ok +int o_loffset, o_nchars, o_lineno, o_pageno, junk, pageno, cmd, ch, n + +long note() +pointer lno_open() +bool streq(), ttygetb() +int pg_getcmd(), ctoi(), strncmp(), patmake(), patmatch(), pg_peekcmd() +int open(), finfo(), strlen(), pg_getline(), getci() +int lno_fetch(), fstati(), ttyctrl() +data first_call /true/ + +define err_ 91 +define quit_ 92 +define search_ 93 +define destline_ 94 + +begin + call smark (sp) + call salloc (lbuf, SZ_LONGLINE, TY_CHAR) + call salloc (cmdbuf, SZ_LINE, TY_CHAR) + call salloc (prompt, SZ_FNAME, TY_CHAR) + call salloc (token, SZ_FNAME, TY_CHAR) + + if (first_call) { + # The pattern buffer is retained indefinitely. + patbuf[1] = EOS + spoolfd = NULL + first_call = false + } + + call pg_setprompt (Memc[prompt], u_prompt, fname) + call xttysize (ncols, nlines) + maxlines = nlines - 1 + maxcols = ncols + + redirout = (fstati (STDOUT, F_REDIR) == YES) + upline_ok = (!redirout && ttygetb(tty,"cm") && ttygetb(tty,"al")) + call pg_pushcmd (NULL) + + # Get file size for (xx%) info in nomore. If reading from the + # standard input, file size is not known. + + nchars = 0 + if (streq (fname, "STDIN")) { + totchars = -1 + } else if (finfo (fname, fi) == ERR) { + call sprintf (Memc[lbuf], SZ_LINE, "Cannot access file `%s'") + call pargstr (fname) + cmd = pg_getcmd (tty, Memc[lbuf], 0, 0, 0, fileno, nfiles) + call sfree (sp) + return (cmd) + } else + totchars = FI_SIZE(fi) + + # If file is empty, return immediately without clearing screen. + if (totchars == 0) { + call sprintf (Memc[lbuf], SZ_LINE, "Null length file `%s'") + call pargstr (fname) + cmd = pg_getcmd (tty, Memc[lbuf], 0, 0, 0, fileno, nfiles) + call sfree (sp) + return (cmd) + } + + # Open the file. + iferr (fd = open (fname, READ_ONLY, TEXT_FILE)) { + call sprintf (Memc[lbuf], SZ_LINE, "Cannot open file `%s'") + call pargstr (fname) + cmd = pg_getcmd (tty, Memc[lbuf], 0, 0, 0, fileno, nfiles) + call sfree (sp) + return (cmd) + } + + # Open the line offset save/fetch database. + lp = lno_open (LNO_MAXLINES) + + # Advance to the first page of the file to be displayed. Pages are + # marked by FF chararacters in the text. If the first page is number + # one, do nothing. If the first character in the file is FF, do not + # count it. This is necessary to count pages correctly whether or not + # the first page is preceeded by a FF. + + pageno = 1 + lineno = 1 + pgoff[1] = BOF + pgnch[1] = nchars + pglno[1] = lineno + + if (first_page > 1) { + junk = getci (fd, ch) + nchars = nchars + 1 + + while (pageno < first_page) { + while (getci (fd, ch) != '\f') { + nchars = nchars + 1 + if (ch == '\n') + lineno = lineno + 1 + if (ch == EOF) { + call close (fd) + call lno_close (lp) + call sfree (sp) + return + } + } + pageno = pageno + 1 + nchars = nchars + 1 + pgoff[pageno] = note (fd) + pgnch[pageno] = nchars + pglno[pageno] = lineno + } + } + + # Always clear the screen between files; the "clear_screen" param + # applies only to the pages of a single file. + + if (!redirout) { + call ttyclear (STDERR, tty) + call flush (STDERR) + } + + # Output lines, mapping control characters if enabled. Pause at the + # end of every screen, or when FF is encountered in the text. + + pushback= false + ateof = false + nleft = maxlines # nlines left to display before prompt + lnout = 0 + + repeat { + # Fetch and display the next line of the file. + + if (pushback) + pushback = false + else + loffset = note (fd) + + if (pg_getline (fd, Memc[lbuf]) == EOF) { + if ((nfiles==1 && lineno <= maxlines) || redirin || redirout) { + # Simply quit if a single small file or the standard input + # is being paged. + + call close (fd) + call lno_close (lp) + call sfree (sp) + return (QUIT) + + } else { + nchars = totchars + SZ_LINE + ateof = true + nleft = 0 + } + + } else if (Memc[lbuf] == '\f') { + # Formfeed encountered; pause for the prompt and print the + # remainder of the line on the next screen. If we have not + # yet written anything on the screen (nleft=maxlines) don't + # bother to prompt again. + + pageno = pageno + 1 + pgoff[pageno] = loffset + pglno[pageno] = lineno + pgnch[pageno] = nchars + call ungetline (fd, Memc[lbuf+1]) + pushback = true + + if (nleft == maxlines) + next + else + nleft = 0 + + } else { + # Output line, processing all escapes as req'd by the device. + # Keep track of position in file for %done message in prompt, + # and of position on screen so that we know when to prompt. + + call lno_save (lp, lineno, loffset, nchars) + linelen = strlen (Memc[lbuf]) + nchars = nchars + linelen + lineno = lineno + 1 + + # Count the number of printed columns in the output text. + n = 1 + do i = 1, linelen + if (ch >= ' ') + n = n + 1 + else if (ch == '\t') { + n = n + 1 + while (mod (n-1, 8) != 0) + n = n + 1 + } + + # Decrement lines left on screen. + nleft = nleft - max (1, ((n + maxcols-1) / maxcols)) + + if (spoolfd != NULL) + call putline (spoolfd, Memc[lbuf]) + + # Cancel upline if line is too long. + if (upline && lnout <= 0 && linelen >= maxcols) { + call ttyclear (STDERR, tty) + call flush (STDERR) + upline = false + lnout = 0 + } + + if (!(upline && lnout > 0)) + call ttyputline (STDOUT, tty, Memc[lbuf], map_cc) + lnout = min (maxlines, lnout + 1) + } + + if (nleft <= 0) { + # Move cursor to query line at end of line insert sequence. + if (upline) { + # Don't bother if the next command is another insert. + if (pg_peekcmd() != PREV_LINE) { + call ttygoto (STDOUT, tty, 1, lnout + 1) + call ttyclearln (STDOUT, tty) + } + upline = false + } + + # Pause and get next keystroke from the user. + cmd = pg_getcmd (tty, Memc[prompt], nchars, totchars, lineno, + fileno, nfiles) + + # Allow use of the space bar to advance to the next file, + # when at the end of the current file. + + if (ateof && nfiles > 1 && (cmd == BLANK || cmd == FWD_SCREEN)) + cmd = NEXT_FILE + + repeat { + switch (cmd) { + case NEXT_FILE: + # This really means the next file if multiple files. + if (nfiles > 1) + goto quit_ + else if (pushback) { + cmd = FWD_SCREEN + next + } + + # Otherwise we want the next page (formfeed). + o_loffset = note (fd) + o_nchars = nchars + o_lineno = lineno + + repeat { + loffset = note (fd) + n = pg_getline (fd, Memc[lbuf]) + if (n == EOF) { + if (!redirin) { + call seek (fd, o_loffset) + pushback = false + nchars = o_nchars + lineno = o_lineno + ateof = false + } + cmd = pg_getcmd (tty, "No more pages", + nchars,totchars, lineno, fileno,nfiles) + Memc[lbuf] = EOS + break + } + + call lno_save (lp, lineno, loffset, nchars) + + if (Memc[lbuf] == '\f') { + pageno = min (MAX_PAGE, pageno + 1) + pgoff[pageno] = loffset + pgnch[pageno] = nchars + pglno[pageno] = lineno + if (!redirout) { + call ttyclear (STDERR, tty) + call flush (STDERR) + lnout = 0 + } + call ungetline (fd, Memc[lbuf+1]) + pushback = true + nleft = maxlines + break + } + + nchars = nchars + n + lineno = lineno + 1 + } + + if (n == EOF) + next + else + break + + case PREV_FILE: + # If there are multiple files go to previous file, + # otherwise, go to previous page (formfeed). + + if (nfiles > 1) + goto quit_ + if (redirin) + goto err_ + + # Special case - just reached beginning of next + # page, but still displaying previous page. + + if (pglno[pageno] == lineno) + pageno = max (1, pageno - 1) + + # If the beginning of the current page is not on + # the screen, go back to the beginning of the page. + + if (lineno <= pglno[pageno]+maxlines) + pageno = max (1, pageno - 1) + + # Go there. + call seek (fd, pgoff[pageno]) + nchars = pgnch[pageno] + lineno = pglno[pageno] + pushback = false + + if (!redirout) { + call ttyclear (STDERR, tty) + call flush (STDERR) + lnout = 0 + } + if (getci (fd, ch) != '\f') + call ungetci (fd, ch) + nleft = maxlines + break + + case QUIT: +quit_ call close (fd) + call lno_close (lp) + call sfree (sp) + return (cmd) + + case TO_BOF: + if (redirin) + goto err_ + + call pg_setprompt (Memc[prompt], u_prompt, fname) + call seek (fd, BOFL) + pushback = false + Memc[lbuf] = EOS + ateof = false + lineno = 1 + nchars = 0 + nleft = maxlines + pageno = 1 + + if (!redirout) { + call ttyclear (STDERR, tty) + call flush (STDERR) + lnout = 0 + } + break + + case FWD_SCREEN, BLANK: + if (!ateof && clear_screen == YES && !redirout) { + call ttyclear (STDERR, tty) + call flush (STDERR) + lnout = 0 + } + nleft = maxlines + break + + case TO_EOF, TO_EOF_ALT: + destline = MAX_INT + goto destline_ + case SCROLL_DOWN: + nleft = (maxlines + 1) / 2 + break + case SCROLL_UP: + if (redirin) + goto err_ + if (upline_ok) { + destline = lineno - 2 + do i = 1, ((maxlines + 1) / 2 - 1) + if (lineno - lnout - i > 1) + call pg_pushcmd (PREV_LINE) + } else + destline = lineno - ((maxlines + 1) / 2) - 1 + goto destline_ + case BACK_SCREEN: + if (redirin) + goto err_ + destline = lineno - maxlines - 1 + goto destline_ + case PREV_LINE: + if (redirin) + goto err_ + destline = lineno - 2 + goto destline_ + case REDRAW: + if (redirin) + goto err_ + destline = lineno + goto destline_ + case NEXT_LINE, CR, LF: + nleft = 1 + break + case SEARCH: + # Stop at next line containing current pattern. + goto search_ + + case HELP: + cmd = pg_getcmd (tty, HELPTXT, 0, 0, 0, 0, 0) + # get another command + + case EDIT: + # Edit the file being paged. + if (redirin) + goto err_ + + # Close file and LNO database. + call close (fd) + call lno_close (lp) + call flush (STDOUT) + call flush (STDERR) + + # Command the CL to edit the file. + call sprintf (Memc[lbuf], SZ_LINE, "edit (\"%s\")") + call pargstr (fname) + iferr (call clcmdw (Memc[lbuf])) + call erract (EA_WARN) + + # Reopen the file and LNO database. + iferr (fd = open (fname, READ_ONLY, TEXT_FILE)) { + call sfree (sp) + return (NEXT_FILE) + } else + lp = lno_open (LNO_MAXLINES) + + # Redisplay the file at the BOF. + if (!redirout) { + call ttyclear (STDERR, tty) + call flush (STDERR) + lnout = 0 + } + Memc[lbuf] = EOS + nchars = 0 + lineno = 1 + nleft = maxlines + break + + case LCMD: + # Colon escape. + call pg_getstr (Memc[cmdbuf], SZ_LINE) + for (ip=cmdbuf; IS_WHITE (Memc[ip]); ip=ip+1) + ; + + if (Memc[ip] == '!') { + # Send a command to the CL. + + iferr (call clcmdw (Memc[cmdbuf+1])) + call erract (EA_WARN) + cmd = pg_getcmd (tty, Memc[prompt], + nchars, totchars, lineno, fileno, nfiles) + Memc[lbuf] = EOS + next + + } else if (Memc[ip] == '/') { + # Search for a line containing the given pattern. + + if (patmake (Memc[ip+1], patbuf, SZ_LINE) == ERR) + goto err_ +search_ + if (patbuf[1] == EOS) { + cmd = pg_getcmd (tty, "No current pattern", + 0, 0, 0, fileno, nfiles) + Memc[lbuf] = EOS + next + } + + o_loffset = note (fd) + o_nchars = nchars + o_lineno = lineno + o_pageno = pageno + + repeat { + loffset = note (fd) + n = pg_getline (fd, Memc[lbuf]) + if (n == EOF) { + if (!redirin) { + call seek (fd, o_loffset) + pushback = false + nchars = o_nchars + lineno = o_lineno + pageno = o_pageno + ateof = false + } + cmd = pg_getcmd (tty, "Pattern not found", + nchars,totchars,lineno,fileno,nfiles) + Memc[lbuf] = EOS + break + } + + call lno_save (lp, lineno, loffset, nchars) + if (Memc[lbuf] == '\f') { + pageno = pageno + 1 + pgoff[pageno] = loffset + pgnch[pageno] = nchars + pglno[pageno] = lineno + } + + if (patmatch (Memc[lbuf], patbuf) > 0) { + if (redirin) { + call ungetline (fd, Memc[lbuf]) + pushback = true + nleft = maxlines + break + } else { + destline = lineno + nchars = nchars + n + lineno = lineno + 1 + goto destline_ + } + } + + nchars = nchars + n + lineno = lineno + 1 + } + + if (n == EOF) + next + else + break + } + + # Case ":cmd arg". + for (op=token; IS_ALPHA (Memc[ip]); ip=ip+1) { + Memc[op] = Memc[ip] + op = op + 1 + } + for (; IS_WHITE (Memc[ip]); ip=ip+1) + ; + Memc[op] = EOS + toklen = op - token + + # Print help if no : string given. + if (toklen <= 0) { + call strcpy ("help", Memc[token], SZ_FNAME) + toklen = 4 + } + + if (strncmp (Memc[token], "line", toklen) == 0) { + # Move to the destination line, expressed as + # ":line N" for an absolute line, or ":line +/-N" + # for a relative move. + + destline = lineno + if (Memc[ip] == '+') { + ip = ip + 1 + if (ctoi (Memc, ip, n) > 0) + destline = lineno + n + } else if (Memc[ip] == '-') { + ip = ip + 1 + if (ctoi (Memc, ip, n) > 0) + destline = lineno - n + } else if (ctoi (Memc, ip, n) > 0) + destline = n +destline_ + # Upscroll one line? + if (upline_ok && destline == lineno-2) + upline = true + + # Determine line at top of new screen. + nleft = maxlines + if (destline < lineno && destline >= lineno-lnout-1) + destline = destline - lnout + 1 + else + destline = destline - nleft + 1 + + # Don't upscroll off the top of the screen. + if (destline < 1) { + destline = 1 + upline = false + } + + # Look up the desired line offset in the database + # and go directly there if found, otherwise either + # advance forward or rewind the file and advance + # forward to the indicated line. + + if (lno_fetch(lp,destline,loffset,nchars)==ERR) { + if (!redirin && destline < lineno) { + call seek (fd, BOFL) + pushback = false + lineno = 1 + pageno = 1 + nchars = 0 + ateof = false + call pg_setprompt (Memc[prompt], + u_prompt, fname) + } + + while (lineno < destline) { + loffset = note (fd) + n = pg_getline (fd, Memc[lbuf]) + if (n == EOF) { + destline = lineno - 1 # goto EOF + goto destline_ + } + call lno_save (lp, lineno, loffset, nchars) + if (Memc[lbuf] == '\f') { + pageno = pageno + 1 + pgoff[pageno] = loffset + pgnch[pageno] = nchars + pglno[pageno] = lineno + } + nchars = nchars + n + lineno = lineno + 1 + } + } else if (!redirin) { + call seek (fd, loffset) + pushback = false + lineno = destline + ateof = false + + # Determine which page we are in. + do i = 2, MAX_PAGE + if (pglno[i] <= 0) { + pageno = i - 1 + break + } else if (pglno[i] >= lineno) { + pageno = i + break + } + + call pg_setprompt (Memc[prompt],u_prompt,fname) + } + + # Prepare to draw the screen. Upline mode means + # we want to insert a line at the top of the screen + # and then skip to the page prompt; otherwise we + # clear the screen and output a full page of text. + + if (!redirout) { + if (upline) { + # Clear screen if backing up over a page. + if (destline+1 == pglno[pageno]) + call ttyclear (STDERR, tty) + call ttygoto (STDOUT, tty, 1, 1) + junk = ttyctrl (STDOUT, tty, "al", maxlines) + lnout = 0 + } else { + call ttyclear (STDERR, tty) + upline = false + lnout = 0 + } + call flush (STDERR) + } + Memc[lbuf] = EOS + break + + } else if (strncmp (Memc[token], "file", toklen) == 0) { + # Position to the named file (must be in file list). + + call strcpy (Memc[ip], newfname, SZ_FNAME) + call close (fd) + call lno_close (lp) + call sfree (sp) + return (TO_FILE) + + } else if (strncmp (Memc[token],"spool",toklen) == 0) { + # Begin spooling output in a file. + + if (spoolfd != NULL) { + call close (spoolfd) + spoolfd = NULL + } + + if (Memc[ip] == EOS) { + ; + } else iferr { + spoolfd = open (Memc[ip], APPEND, TEXT_FILE) + } then { + spoolfd = NULL + call erract (EA_WARN) + } + + # Get next keystroke from the user. + cmd = pg_getcmd (tty, Memc[prompt], + nchars, totchars, lineno, fileno, nfiles) + + } else { + cmd = pg_getcmd (tty, + "colon cmds: :!cmd :/pat :line L :file F :spool F", + 0, 0, 0, 0, 0) + } + + default: +err_ call eprintf ("\07") + call flush (STDERR) + cmd = pg_getcmd (tty, Memc[prompt], nchars, totchars, + lineno, fileno, nfiles) + } + } + } + } +end + + +# PG_SETPROMPT -- Set the prompt string for the ukey end-of-page query. +# The name of the file currently being paged is used unless a prompt string +# is given. + +procedure pg_setprompt (prompt, u_prompt, fname) + +char prompt[SZ_FNAME] # receives prompt string +char u_prompt[ARB] # user prompt string +char fname[ARB] # file being paged + +int gstrcpy() + +begin + if (gstrcpy (u_prompt, prompt, SZ_FNAME) <= 0) + call strcpy (fname, prompt, SZ_FNAME) +end + + +# PG_GETLINE -- Get a line from the input file. Accumulates very long lines +# (requiring several getline calls to read) into a single string. + +int procedure pg_getline (fd, lbuf) + +int fd # input file +char lbuf[SZ_LONGLINE] # output buffer + +int nchars, op +int getline() +errchk getline + +begin + for (op=1; op + SZ_LINE < SZ_LONGLINE; op=op+nchars) { + nchars = getline (fd, lbuf[op]) + if (nchars == EOF) { + if (op == 1) + return (EOF) + else + return (op - 1) + } else if (lbuf[op+nchars-1] == '\n') + break + } + + return (op + nchars - 1) +end + + +# PG_GETCMD -- Query the user for a single character command keystroke. +# A prompt naming the current file and our position in it is printed, +# we read the single character command keystroke in raw mode, and then +# the prompt line is cleared and we return. + +int procedure pg_getcmd (tty, fname, nchars, totchars, lineno, fileno, nfiles) + +pointer tty # tty descriptor +char fname[ARB] # prefix string +long nchars # position in file +long totchars # size of file +int lineno # current line number +int fileno # current file number +int nfiles # nfiles being paged through + +char keystr[SZ_KEYSTR] +int key, pb, pbcmd[MAX_PBCMD] +common /pgucom/ key, pb, pbcmd, keystr +int clgkey(), fstati() + +begin + # If any commands have been pushed, return the next pushed command + # without generating a query. + + if (pb > 0) { + key = pbcmd[pb] + pb = pb - 1 + return (key) + } + + # If the standard output is redirected, skip the query and just go on + # to the next page. + + if (fstati (STDOUT, F_REDIR) == YES) + return (FWD_SCREEN) + + # Ensure synchronization with the standard output. + call flush (STDOUT) + + # Print query in standout mode, preceded by %done info. + call ttyso (STDERR, tty, YES) + call eprintf ("%s") + call pargstr (fname) + if (totchars > 0) { + if (nchars >= totchars + SZ_LINE) + call eprintf ("-(EOF)") + else { + call eprintf ("-(%02d%%)") + call pargi (max(0, min(99, nchars * 100 / totchars))) + } + } + if (lineno > 0) { + call eprintf ("-line %d") + call pargi (lineno - 1) + } + if (fileno > 0 && nfiles > 0) { + call eprintf ("-file %d of %d") + call pargi (fileno) + call pargi (nfiles) + } + call ttyso (STDERR, tty, NO) + call flush (STDERR) + + call fseti (STDIN, F_SETREDRAW, REDRAW) + + # Read the user's response, normally a single keystroke. + if (clgkey (UKEYS, key, keystr, SZ_KEYSTR) == EOF) + key = INTCHAR + + call fseti (STDIN, F_SETREDRAW, 0) + + if (key == INTCHAR) + key = QUIT + else if (key == NEXT_FILE_ALT) + key = NEXT_FILE + else if (key == PREV_FILE_ALT) + key = PREV_FILE + + # Erase the prompt and return. + call eprintf ("\r") + call ttyclearln (STDERR, tty) + call flush (STDERR) + + return (key) +end + + +# PG_GETSTR -- Called after receipt of a : key to get the string value. + +procedure pg_getstr (strval, maxch) + +char strval[maxch] # receives string +int maxch + +char keystr[SZ_KEYSTR] +int key, pb, pbcmd[MAX_PBCMD] +common /pgucom/ key, pb, pbcmd, keystr + +begin + call strcpy (keystr, strval, maxch) +end + + +# PG_PUSHCMD -- Push back a command keystroke. + +procedure pg_pushcmd (cmd) + +int cmd #I command to be pushed + +char keystr[SZ_KEYSTR] +int key, pb, pbcmd[MAX_PBCMD] +common /pgucom/ key, pb, pbcmd, keystr + +begin + if (cmd <= 0) + pb = 0 + else { + pb = min (MAX_PBCMD, pb + 1) + pbcmd[pb] = cmd + } +end + + +# PG_PEEKCMD -- Peek at any pushed back command keystroke. + +int procedure pg_peekcmd() + +char keystr[SZ_KEYSTR] +int key, pb, pbcmd[MAX_PBCMD] +common /pgucom/ key, pb, pbcmd, keystr + +begin + if (pb <= 0) + return (ERR) + else + return (pbcmd[pb]) +end diff --git a/sys/etc/prc.com b/sys/etc/prc.com new file mode 100644 index 00000000..5893ef10 --- /dev/null +++ b/sys/etc/prc.com @@ -0,0 +1,27 @@ +define MAX_PS 10 # maximum pseudofiles + +# Process table common. + +int pr_pid[MAX_CHILDPROCS] # process id +int pr_status[MAX_CHILDPROCS] # process status +int pr_inchan[MAX_CHILDPROCS] # input IPC channel from child +int pr_infd[MAX_CHILDPROCS] # fd of input IPC +int pr_outchan[MAX_CHILDPROCS] # output IPC channel to child +int pr_outfd[MAX_CHILDPROCS] # fd of output IPC +int pr_nopen[MAX_CHILDPROCS] # number of open channels +int pr_pstofd[MAX_CHILDPROCS,MAX_PS] # pseudofile -> FD +int pr_last_exit_code # exit code of last process closed +int pr_lastio # index of last active process +int pr_index # index of current process +int pr_oldipc # old X_IPC handler +int epa_giotr # gio.cursor driver entry points +int epa_control # " " +int epa_gflush # " " +int epa_writep # " " +int epa_readtty # " " +int epa_writetty # " " + +common /prccom/ pr_pid, pr_status, pr_inchan, pr_infd, pr_outchan, pr_outfd, + pr_nopen, pr_pstofd, pr_lastio, pr_last_exit_code, pr_index, pr_oldipc, + epa_giotr, epa_control, epa_gflush, epa_writep, epa_readtty, + epa_writetty diff --git a/sys/etc/prchdir.x b/sys/etc/prchdir.x new file mode 100644 index 00000000..d11c903a --- /dev/null +++ b/sys/etc/prchdir.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# PRCHDIR -- Change the current working directory of a connected child +# process, or of all connected subprocesses if pid=0. + +procedure prchdir (pid, newdir) + +int pid # process id of child, or 0 for all subprocesses +char newdir[ARB] # new directory +pointer sp, cmd + +begin + call smark (sp) + call salloc (cmd, SZ_COMMAND, TY_CHAR) + + call strcpy ("chdir ", Memc[cmd], SZ_COMMAND) + call strcat (newdir, Memc[cmd], SZ_COMMAND) + + call prupdate (pid, Memc[cmd], YES) + call sfree (sp) +end diff --git a/sys/etc/prclcpr.x b/sys/etc/prclcpr.x new file mode 100644 index 00000000..e5dd397c --- /dev/null +++ b/sys/etc/prclcpr.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PRCLCPR -- Close a connected subprocess. Given the PID of the child process +# we get the input and output file descriptors from the process table and +# close both files. When the second file is closed the process is disconnected +# by the PR_ZCLSPR procedure, which leaves the exit status in the process table +# common. + +int procedure prclcpr (pid) + +int pid # process id of child process + +int child +int pr_findproc() +include "prc.com" +errchk syserr + +begin + # Search process table for the PID of the child process and close it + # if found. Return process termination code to parent. + + child = pr_findproc (pid) + if (child == ERR) + call syserr (SYS_PRNOTFOUND) + + call close (pr_infd[child]) + call close (pr_outfd[child]) + + return (pr_last_exit_code) +end diff --git a/sys/etc/prcldpr.x b/sys/etc/prcldpr.x new file mode 100644 index 00000000..479fffb9 --- /dev/null +++ b/sys/etc/prcldpr.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +define NOKILL NO +define KILL YES + +# PRCLDPR -- Close a detached process. Called following process termination +# to obtain the exit status and free up any system resources still allocated +# to the job. If called prior to job termination execution of the current +# process will be suspended until the bkg job terminates. PRDONE should be +# called to determine if the job is still running if waiting is not desired. + +int procedure prcldpr (job) + +int job # slot number of job in prd.com table +int exit_status +include "prd.com" + +begin + # Wait for process to terminate if it is still active. If we are + # interrupted the process table is left unmodified. If the process + # has been killed the exit status will have been left in the table + # and ZCLDPR should not be called again. + + if (pr_jobcode[job] == NULL) + call syserr (SYS_PRBKGNF) + else if (pr_active[job] == YES) + call zcldpr (pr_jobcode[job], NOKILL, exit_status) + else + exit_status = pr_exit_status[job] + + # Free all remaining resources allocated to job. The bkgfile should + # already have been deleted by the process but if not, e.g., in the + # event of abnormal process termination, we delete it ourselves. The + # buffer for the bkgfile filename is freed as is the slot in the + # process table. + + iferr (call delete (Memc[pr_bkgfile[job]])) + ; + call mfree (pr_bkgfile[job], TY_CHAR) + pr_jobcode[job] = NULL + + return (exit_status) +end diff --git a/sys/etc/prclose.x b/sys/etc/prclose.x new file mode 100644 index 00000000..26e2702c --- /dev/null +++ b/sys/etc/prclose.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# PRCLOSE -- Close a connected subprocess. Send the command "bye" to the +# child to initiate process shutdown, then close the IPC channels and +# wait for the child to terminate, returning the termination status to +# our caller. Note that process shutdown may take an arbitrarily long +# time, depending on the number and nature of ONEXIT procedures posted by +# tasks in the the child process. + +int procedure prclose (pid) + +int pid # process-id of child process + +int child +int pr_findproc(), prclcpr() +include "prc.com" +errchk syserr + +begin + child = pr_findproc (pid) + if (child == ERR) + call syserr (SYS_PRNOTFOUND) + + if (pr_status[child] != P_DONE && pr_status[child] != P_DEAD) + call putline (pr_outfd[child], "bye\n") + + return (prclcpr (pid)) +end diff --git a/sys/etc/prd.com b/sys/etc/prd.com new file mode 100644 index 00000000..599dc6b6 --- /dev/null +++ b/sys/etc/prd.com @@ -0,0 +1,8 @@ +# Job table for detached processes. + +int pr_jobcode[MAX_BKGJOBS] # job code assigned by host system +int pr_active[MAX_BKGJOBS] # set to NO if job is killed +int pr_exit_status[MAX_BKGJOBS] # exit status of process +pointer pr_bkgfile[MAX_BKGJOBS] # bkgfile filename (signals job term) + +common /prdcom/ pr_jobcode, pr_active, pr_exit_status, pr_bkgfile diff --git a/sys/etc/prdone.x b/sys/etc/prdone.x new file mode 100644 index 00000000..2df2dccc --- /dev/null +++ b/sys/etc/prdone.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PRDONE -- Determine if a detached process (background job) has completed. +# This is a difficult process to perform portably at the system call level, +# hence the deletion of the bkgfile is used to signal the completion of a +# detached process. If the detached process fails to delete its bkgfile +# for some reason, PRCLDPR will do so if the process has indeed terminated. + +int procedure prdone (job) + +int job # job number (slot number in job table) +int access() +include "prd.com" + +begin + if (pr_jobcode[job] == NULL) + call syserr (SYS_PRBKGNF) + + if (access (Memc[pr_bkgfile[job]], 0, 0) == YES) + return (NO) + else + return (YES) +end diff --git a/sys/etc/prenvfree.x b/sys/etc/prenvfree.x new file mode 100644 index 00000000..90908789 --- /dev/null +++ b/sys/etc/prenvfree.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# PRENVFREE -- Free any recently defined or redefined environment variables, +# updating the values of any redefined variables uncovered by the free +# operation in the specified connected subprocesses. + +int procedure prenvfree (pid, marker) + +int pid # pid of process to be updated, or 0 for all subprocs +int marker # stack pointer returned by ENVMARK + +int ev_pid +common /prvcom/ ev_pid +int locpr(), envfree() +extern prv_reset() + +begin + ev_pid = pid + return (envfree (marker, locpr (prv_reset))) +end + + +# PRV_RESET -- Reset the value of an environment variable in the specified +# connected subprocesses. + +procedure prv_reset (name, value) + +char name[ARB] # name of variable to be reset +char value[ARB] # new value + +int ev_pid +common /prvcom/ ev_pid + +begin + call prenvset (ev_pid, name, value) +end diff --git a/sys/etc/prenvset.x b/sys/etc/prenvset.x new file mode 100644 index 00000000..6c21133d --- /dev/null +++ b/sys/etc/prenvset.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# PRENVSET -- Change the value of an environment variable in a connected child +# process, or in all connected subprocesses if pid=0. + +procedure prenvset (pid, envvar, valuestr) + +int pid # process id of child, or 0 for all subprocesses +char envvar[ARB] # name of environment variable +char valuestr[ARB] # value of environment variable +pointer sp, cmd + +begin + call smark (sp) + call salloc (cmd, SZ_COMMAND, TY_CHAR) + + call strcpy ("set ", Memc[cmd], SZ_COMMAND) + call strcat (envvar, Memc[cmd], SZ_COMMAND) + call strcat ("=", Memc[cmd], SZ_COMMAND) + call strcat (valuestr, Memc[cmd], SZ_COMMAND) + + call prupdate (pid, Memc[cmd], NO) + call sfree (sp) +end diff --git a/sys/etc/prfilbuf.x b/sys/etc/prfilbuf.x new file mode 100644 index 00000000..4ec09907 --- /dev/null +++ b/sys/etc/prfilbuf.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PRFILBUF -- Fill the FIO buffer from a process. The function is equivalent +# to the ordinary FIO filbuf with the exception that pseudofile read and +# write directives are intercepted and processed. Hence, the reader sees a +# stream of application specific commands need not know about pseudofile i/o. + +int procedure prfilbuf (fd) + +int fd # parent's input IPC from child process + +int pr +int filbuf(), prpsio() +include "prc.com" + +begin + # Determine which process has the given file as its CLIN stream. + # If FD not associated with a process call ordinary FILBUF, otherwise + # call PR_PSIO. To minimize searches of the process table we keep + # track of the slot number of the last active pid. + + if (pr_infd[pr_lastio] == fd && pr_pid[pr_lastio] != NULL) + pr = pr_lastio + else { + for (pr=1; pr <= MAX_CHILDPROCS; pr=pr+1) + if (pr_pid[pr] != NULL) + if (pr_infd[pr] == fd) + break + if (pr > MAX_CHILDPROCS) + return (filbuf (fd)) # normal file + pr_lastio = pr + } + + return (prpsio (pr_pid[pr], CLIN, FF_READ)) +end diff --git a/sys/etc/prfindpr.x b/sys/etc/prfindpr.x new file mode 100644 index 00000000..3df73ed2 --- /dev/null +++ b/sys/etc/prfindpr.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PR_FINDPROC -- Search the process table for the given PID of a child process, +# returning the index of the process if found. + +int procedure pr_findproc (pid) + +int pid # process id of child process +int pr +include "prc.com" + +begin + for (pr=1; pr <= MAX_CHILDPROCS; pr=pr+1) + if (pr_pid[pr] == pid) + return (pr) + + return (ERR) +end diff --git a/sys/etc/prgline.x b/sys/etc/prgline.x new file mode 100644 index 00000000..21ec1780 --- /dev/null +++ b/sys/etc/prgline.x @@ -0,0 +1,204 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +define XMIT 0 +define XFER 1 + +# PRGETLINE -- Get a line of text from a process. The function is equivalent +# to the ordinary FIO getline with the exception that pseudofile read and +# write directives are intercepted and processed. Hence, the reader sees a +# stream of application specific commands need not know about pseudofile i/o. +# The function of PRGETLINE is such that it can be used in place of GETLINE +# on any file; pseudofile directives are recognized and process only if the +# FD is associated with a connected subprocess. + +int procedure prgetline (fd, lbuf) + +int fd # parent's input IPC from child process +char lbuf[SZ_LINE] # output line buffer + +char ch +int nchars, maxchars, nchars_read, raw_mode_set, ndigits +int bufsize, outfd, destfd, pr, pseudofile, line_type, offset +pointer sp, buf, ip + +char getc() +int getline(), read(), fstati(), ctoi(), itoc() +errchk syserr, getline, fstati, read, write, pr_decodeargs, putc, getc +include "prc.com" + +begin + call smark (sp) + + pr = 0 + buf = NULL + raw_mode_set = 0 + + repeat { + nchars = getline (fd, lbuf) + + # Return immediately if not XMIT or XFER directive. This code is + # exercised heavily when performing raw mode i/o, hence some + # clarity is sacrificed for the sake of efficiency. + # + # Syntax: "xmit(P,NNN)" or "xfer(P,NNN)" + # 12345678 12345678 + # + # where P is the pseudofile code (0 MAX_CHILDPROCS) + break + pr_lastio = pr + } + outfd = pr_outfd[pr] + } + + # Map pseudofile code to a file descriptor in the local process. + + destfd = pr_pstofd[pr,pseudofile] + + + # RAW mode transfers are handled as a special case to minimize the + # per-character overhead. + + if (lbuf[8] == '1' && lbuf[9] == ')') { + if (line_type == XMIT) { + # XMIT + if (getc (fd, ch) == EOF) + call syserr (SYS_PRIPCSYNTAX) + + # Clear RAW input mode if newline is encountered in output. + # Only works for STDIN/STDOUT, but that is all raw mode is + # used for with pseudofiles. + + if (ch == '\n') + if (destfd == STDOUT) { + call fseti (STDIN, F_RAW, NO) + if (raw_mode_set == STDIN) + raw_mode_set = 0 + } + + call putc (destfd, ch) + call flush (destfd) + + } else { + # XFER + if (raw_mode_set != destfd) { + call fseti (destfd, F_RAW, YES) + raw_mode_set = destfd + } + + if (getc (destfd, ch) == EOF) + call putline (outfd, "0\n") + else { + call putline (outfd, "1\n") + call flush (outfd) + call putc (outfd, ch) + } + call flush (outfd) + } + next + } + + + # GENERAL XMIT or XFER directive. Read a block of data from one + # stream and transmit it to the other stream. + + if (buf == NULL) { + bufsize = fstati (fd, F_BUFSIZE) + call salloc (buf, bufsize, TY_CHAR) + } + + offset = 8 + if (ctoi (lbuf, offset, nchars) <= 0) + call syserr (SYS_PRIPCSYNTAX) + + if (line_type == XMIT) { + # XMIT -- Copy the block of data from the IPC channel to the + # destination file. + + nchars_read = read (fd, Memc[buf], nchars) + if (nchars_read != nchars) + call syserr (SYS_PRIPCSYNTAX) + else { + # Clear RAW input mode if set and newline is encountered + # in the output stream. + + if (destfd == STDOUT) + if (fstati (STDIN, F_RAW) == YES) + for (ip=buf+nchars-1; ip >= buf; ip=ip-1) + if (Memc[ip] == '\n') { + call fseti (STDIN, F_RAW, NO) + if (raw_mode_set == STDIN) + raw_mode_set = 0 + break + } + + call write (destfd, Memc[buf], nchars) + call flush (destfd) + } + next + + } else { + # XFER -- Read up to maxchars chars from the input file and + # pass them on to the output IPC channel. + + maxchars = min (nchars, bufsize) + nchars = read (destfd, Memc[buf], maxchars) + if (nchars == EOF) + nchars = 0 + + # Write the byte count record followed by the data record. + # These must be written as two separate records or deadlock + # will occur (with the reader waiting for the second record). + + ndigits = itoc (nchars, lbuf, SZ_LINE) + lbuf[ndigits+1] = '\n' + call write (outfd, lbuf, ndigits + 1) + call flush (outfd) + + call write (outfd, Memc[buf], nchars) + call flush (outfd) + + next + } + } + + call sfree (sp) + return (nchars) +end diff --git a/sys/etc/prgredir.x b/sys/etc/prgredir.x new file mode 100644 index 00000000..c5ffceee --- /dev/null +++ b/sys/etc/prgredir.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PR_GETREDIR -- Get the pseudofile redirection code for a process. + +int procedure pr_getredir (pid, stream) + +int pid # process id +int stream # stream for which redirection info is needed + +int pr +int pr_findproc() +include "prc.com" + +begin + pr = pr_findproc (pid) + return (pr_pstofd[pr,stream]) +end diff --git a/sys/etc/prkill.x b/sys/etc/prkill.x new file mode 100644 index 00000000..f6938923 --- /dev/null +++ b/sys/etc/prkill.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +define NOKILL NO +define KILL YES + +# PRKILL -- Kill a detached process. Control does not return until the process +# has terminated, unless the kill fails for some reason. If the process exists +# and is terminated by the kill directive, the exit status is left in the +# process table for return by PRCLDPR. + +procedure prkill (job) + +int job # slot number of job in prd.com table +include "prd.com" +errchk syserr + +begin + # Kill the process if there is such a process and it is still active. + # It is an error to try to kill a nonexistent process or a process + # which has already been killed. + + if (pr_jobcode[job] == NULL) + call syserr (SYS_PRBKGNF) + else if (pr_active[job] == NO) + call syserr (SYS_PRBKGNOKILL) + else { + call zcldpr (pr_jobcode[job], KILL, pr_exit_status[job]) + if (pr_exit_status[job] == ERR) + call syserr (SYS_PRBKGNOKILL) + else + pr_active[job] = NO + } + + # Delete the bkgfile if the process has not already done so during + # shutdown. + iferr (call delete (Memc[pr_bkgfile[job]])) + ; +end diff --git a/sys/etc/propcpr.x b/sys/etc/propcpr.x new file mode 100644 index 00000000..b7b394a1 --- /dev/null +++ b/sys/etc/propcpr.x @@ -0,0 +1,201 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include + +# PROPCPR -- Open a connected subprocess, i.e., spawn the subprocess and +# connect the two IPC channels to FIO file descriptors. No i/o is done on +# the IPC channels, hence this relatively low level command is independent +# of the IPC protocol used. PROPEN should be used if the standard IPC +# protocol is followed, so that the environment and current working directory +# may be passed to the subprocess. + +int procedure propcpr (process, in, out) + +char process[ARB] # filename of executable process file +int in # fd of IPC input from child (output) +int out # fd of IPC output to child (output) + +bool first_time +int pr, loc_onipc +pointer sp, fname +int fopnbf() +extern pr_onipc(), pr_dummy_open(), pr_zclspr() +extern zardpr(), zawrpr(), zawtpr(), zsttpr() +errchk xwhen, fmapfn, syserr +include "prc.com" + +define cleanup1_ 91 +define cleanup2_ 92 +define cleanup3_ 93 +data first_time /true/ + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + # Initialize the process table. Post exception handler to recover + # from write to IPC with no reader. + + if (first_time) { + do pr = 1, MAX_CHILDPROCS + pr_pid[pr] = NULL + pr_lastio = 1 # any legal slot number will do + pr_last_exit_code = OK + call zlocpr (pr_onipc, loc_onipc) + call xwhen (X_IPC, loc_onipc, pr_oldipc) + first_time = false + } + + # Find empty process slot. + for (pr=1; pr <= MAX_CHILDPROCS; pr=pr+1) + if (pr_pid[pr] == NULL) + break + if (pr > MAX_CHILDPROCS) + call syserr (SYS_PROVFL) + pr_index = pr + + # Initialize the mapping of pseudofile codes to file descriptor numbers. + # PS codes begin at 1, corresponding to STDIN. + + pr_pstofd[pr,STDIN] = STDIN + pr_pstofd[pr,STDOUT] = STDOUT + pr_pstofd[pr,STDERR] = STDERR + pr_pstofd[pr,STDGRAPH] = STDGRAPH + pr_pstofd[pr,STDIMAGE] = STDIMAGE + pr_pstofd[pr,STDPLOT] = STDPLOT + + # Spawn process and open IPC channels. + call fmapfn (process, Memc[fname], SZ_PATHNAME) + call zopcpr (Memc[fname], pr_inchan[pr], pr_outchan[pr], pr_pid[pr]) + if (pr_pid[pr] == ERR) + goto cleanup3_ + pr_nopen[pr] = 2 + + # Set up file descriptors for the two IPC channels. + + call strcpy (process, Memc[fname], SZ_PATHNAME) + call strcat (".in", Memc[fname], SZ_PATHNAME) + iferr (in = fopnbf (Memc[fname], READ_ONLY, + pr_dummy_open, zardpr, zawrpr, zawtpr, zsttpr, pr_zclspr)) + goto cleanup2_ + pr_infd[pr] = in + + call strcpy (process, Memc[fname], SZ_PATHNAME) + call strcat (".out", Memc[fname], SZ_PATHNAME) + iferr (out = fopnbf (Memc[fname], WRITE_ONLY, + pr_dummy_open, zardpr, zawrpr, zawtpr, zsttpr, pr_zclspr)) + goto cleanup1_ + pr_outfd[pr] = out + + pr_status[pr] = P_RUNNING + call sfree (sp) + return (pr_pid[pr]) + +cleanup1_ + iferr (call close (out)) + ; +cleanup2_ + iferr (call close (in)) + ; +cleanup3_ + call sfree (sp) + pr_pid[pr] = NULL + call syserrs (SYS_PROPEN, process) +end + + +# PR_DUMMY_OPEN -- Dummy ZOPNPR procedure called by FIO to "open" the IPC +# channel to a subprocess. Our only function is to return the appropriate +# channel code to FIO, since the channel has already been opened by ZOPCPR. + +procedure pr_dummy_open (osfn, mode, chan) + +char osfn[ARB] # not used +int mode # used to select read or write IPC channel +int chan # returned to FIO +include "prc.com" + +begin + if (mode == READ_ONLY) + chan = pr_inchan[pr_index] + else + chan = pr_outchan[pr_index] +end + + +# PR_ZCLSPR -- Dummy "zclspr" routine called by FIO to close an IPC channel +# when CLOSE is called on the corresponding FIO file descriptor. A subprocess +# opened with PROPCPR is normally closed with PRCLCPR, but if error recovery +# takes place CLOSE will automatically be called by the system to close both +# file descriptors. We decrement the count of open channels and close the +# process and both IPC channels when the count reaches zero. Hence, a +# connected subprocess may be closed either by calling PRCLCPR or by closing +# the IN and OUT file descriptors. + +procedure pr_zclspr (chan, status) + +int chan # either inchan or outchan of process +int status # OK or ERR on output +int pr +include "prc.com" + +begin + do pr = 1, MAX_CHILDPROCS + if (pr_pid[pr] != NULL) + if (pr_inchan[pr] == chan || pr_outchan[pr] == chan) { + pr_nopen[pr] = pr_nopen[pr] - 1 + if (pr_nopen[pr] == 0) { + call zclcpr (pr_pid[pr], pr_last_exit_code) + pr_pid[pr] = NULL + } + status = OK + return + } + + status = ERR +end + + +# PR_ONIPC -- Exception handler for the X_IPC (write to IPC with no reader) +# exception. This exception occurs when the child process dies unexpectedly. +# Determine what process was being written to, cancel any output (to prevent +# a cascade of onipcs trying to flush the output buffer), and cause FIO to +# return a file write error. We cannot do any more than that w/o reentrancy +# problems. + +procedure pr_onipc (vex, next_handler) + +int vex # virtual exception +int next_handler # next handler in chain +int pr, fd +int fstati() +include "prc.com" + +begin + # Chain to next exception handler, if any. + next_handler = pr_oldipc + + # Get the FD of the file being written to at the time that the + # exception occurred. We assume that the write operation is still + # in progress when the exception takes place. + + fd = fstati (0, F_LASTREFFILE) + for (pr=1; pr <= MAX_CHILDPROCS; pr=pr+1) + if (pr_pid[pr] != NULL) + if (pr_outfd[pr] == fd) + break + if (pr > MAX_CHILDPROCS) + return + + # Cancel any buffered output and remove write permission to ensure + # that we will not get a cascade of X_IPC exceptions. + + call fseti (fd, F_CANCEL, ERR) + call fseti (fd, F_MODE, READ_ONLY) + pr_status[pr] = P_DEAD +end diff --git a/sys/etc/propdpr.x b/sys/etc/propdpr.x new file mode 100644 index 00000000..79690a60 --- /dev/null +++ b/sys/etc/propdpr.x @@ -0,0 +1,68 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# PROPDPR -- Open a detached process. A detached process runs independently of +# and asynchronous with the parent, with no direct communications (i.e., like +# the IPC channels of connected subprocesses). The bkgfile is prepared by the +# parent and read by the detached process, telling the detached process what +# to do. There are no restrictions on the format or contents of the bkgfile +# other than those placed by the implementor of the two processes (either a +# text or binary file may be used). Deletion of the bkgfile is however assumed +# to signify that the bkg process has terminated. + +int procedure propdpr (process, bkgfile, bkgmsg) + +char process[ARB] # vfn of executable process file +char bkgfile[ARB] # vfn of background file +char bkgmsg[ARB] # control string for kernel + +bool first_time +int jobcode, pr +pointer sp, process_osfn, bkgfile_osfn, pk_bkgmsg +data first_time /true/ +errchk fmapfn, syserrs, malloc +include "prd.com" + +begin + call smark (sp) + call salloc (process_osfn, SZ_PATHNAME, TY_CHAR) + call salloc (bkgfile_osfn, SZ_PATHNAME, TY_CHAR) + call salloc (pk_bkgmsg, SZ_LINE, TY_CHAR) + + # First time initialization of the job table. + if (first_time) { + do pr = 1, MAX_BKGJOBS + pr_jobcode[pr] = NULL + first_time = false + } + + # Get job slot. + for (pr=1; pr <= MAX_BKGJOBS; pr=pr+1) + if (pr_jobcode[pr] == NULL) + break + if (pr > MAX_BKGJOBS) + call syserrs (SYS_PRBKGOVFL, process) + + # Map file names. + call fmapfn (process, Memc[process_osfn], SZ_PATHNAME) + call fmapfn (bkgfile, Memc[bkgfile_osfn], SZ_PATHNAME) + call strpak (bkgmsg, Memc[pk_bkgmsg], SZ_LINE) + + # Spawn or enqueue detached process. + call zopdpr (Memc[process_osfn], Memc[bkgfile_osfn], Memc[pk_bkgmsg], + jobcode) + if (jobcode == ERR) + call syserrs (SYS_PRBKGOPEN, process) + + # Set up bkg job descriptor. + pr_jobcode[pr] = jobcode + pr_active[pr] = YES + call malloc (pr_bkgfile[pr], SZ_FNAME, TY_CHAR) + call strcpy (bkgfile, Memc[pr_bkgfile[pr]], SZ_FNAME) + + call sfree (sp) + return (pr) +end diff --git a/sys/etc/propen.x b/sys/etc/propen.x new file mode 100644 index 00000000..21bdf334 --- /dev/null +++ b/sys/etc/propen.x @@ -0,0 +1,67 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PROPEN -- Open a connected subprocess. Call PROPCPR to spawn the child +# process and connect the input and output IPC channels to FIO file +# descriptors, then pass the environment list and current working directory +# to the child. The child is left waiting for the next command from the +# parent, which is eventually written to the OUT channel by the parent. +# +# N.B.: If the child cannot process a SET or CHDIR command it is will take +# a panic exit, raising the X_IPC exception in the parent. This is necessary +# to avoid filling the IN (childs out) IPC channel, which would cause deadlock +# if the parent were to fill the other channel with SET commands. Output of +# SET commands w/o handshaking is desirable to minimize context switches and +# IPC records and hence speed up process startup. + +int procedure propen (process, in, out) + +char process[ARB] # filename of executable file +int in, out # input, output file descriptors to child + +int pid, print_redefined_variables, status +pointer sp, cwd +int propcpr() +data print_redefined_variables /NO/ +errchk propcpr, envlist, putline, putci + +begin + call smark (sp) + call salloc (cwd, SZ_PATHNAME, TY_CHAR) + + # Connect the subprocess with read and write IPC channels. + + pid = propcpr (process, in, out) + + # Pass the environment list to the child, omitting all but the most + # recent definitions of each variable. The list is passed in the + # opposite order from which it was redefined, but it does not matter + # since there is only one entry for each variable. + + call envlist (out, "set ", print_redefined_variables) + + # Set the current working directory in the child, in case the OS does + # not do so, and to save the child the need to ask the kernel for the + # cwd name, an expensive operation on some systems. + + call zfgcwd (Memc[cwd], SZ_PATHNAME, status) + call strupk (Memc[cwd], Memc[cwd], SZ_PATHNAME) + call putline (out, "chdir ") + call putline (out, Memc[cwd]) + call putci (out, '\n') + + # The command "_go_" must be sent to the child to signal that process + # startup is completed. The process STDOUT and STDERR are redirected + # into the nullfile during startup, hence we will see no output if + # this command is not sent. + + call putline (out, "_go_\n") + + # Flush the output so the child can munch on this while we go off and + # do something else. + call flush (out) + + call sfree (sp) + return (pid) +end diff --git a/sys/etc/proscmd.x b/sys/etc/proscmd.x new file mode 100644 index 00000000..cf1e5bb3 --- /dev/null +++ b/sys/etc/proscmd.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PROSCMD -- Process an OS escape command from a subprocess. Execute the +# command and return the exit status to the subprocess via IPC. + +procedure proscmd (pr, cmd) + +int pr # subprocess process slot number +char cmd[ARB] # host command to be executed + +char statbuf[5] +int fd, status, op +int itoc(), oscmd() +include "prc.com" + +begin + fd = pr_outfd[pr] + + # Execute the command (waits for completion). + status = oscmd (cmd, "", "", "") + + # Encode the return status. + op = itoc (status, statbuf, 5) + 1 + statbuf[op] = '\n' + statbuf[op+1] = EOS + + # Return the status to the subprocess. + call write (fd, statbuf, op) + call flush (fd) +end diff --git a/sys/etc/prpsio.x b/sys/etc/prpsio.x new file mode 100644 index 00000000..99050481 --- /dev/null +++ b/sys/etc/prpsio.x @@ -0,0 +1,484 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include + +define LEN_STACK 5 # depth one level, four fields +define LEN_STACKFRAME 5 # size of one pushed stack frame + +define S_PR stack[$1] +define S_IN stack[$1+1] +define S_DESTFD stack[$1+2] +define S_STREAM stack[$1+3] +define S_REQUEST stack[$1+4] + +define push {stkp=stkp+1;stack[stkp]=($1)} +define pop {$1=stack[stkp];stkp=stkp-1} + + +# PR_PSIO -- Pseudofile i/o for a process. Process an i/o request for the +# specified pseudofile stream of the specified process. Called either to read +# command input from the CLIN of a process, or to process a read or write +# request to a pseudofile of a process. I/O to STDIN, STDOUT, and STDERR +# consists of simple binary copies of records. Output to the graphics streams +# STDGRAPH, STDIMAGE, or STDPLOT consists of GKI metacode and is optionally +# spooled and filtered with GIOTR (to apply the workstation transformation) +# before be passed to a graphics kernel. Process to process i/o is tricky +# since we must wait for a process to read or write (send us an XMIT or XFER) +# before transferring a data record. A process may read or write to streams +# of its own choosing before satisfying our request. A graphics kernel +# connected as a subprocess reads and writes metacode on a graphics stream +# and is free to read and write STDIN, STDOUT, etc. during execution as if +# the kernel were being run as a CL task. +# +# Note: This code is far more subtle than it appears. I was unable to express +# the subtleties in comments, eventually concluding that the code was easier +# to understand than the explanation (see Notes.psio for the attempts). Beware +# that the code is not completely general and assumes certain restrictions on +# process configurations. + +int procedure pr_psio (pid, fd, rwflag) + +int pid # process id number +int fd # file for which request is desired +int rwflag # type of transfer to wait for + +pointer ip, op +int stack[LEN_STACK], stkp, nchars, nleft +int stream, pr, in, record_type, rq, iotype +int pseudofile, destfd, destpr, destination, ps, flags +bool filter_gki, graphics_stream, xmit_pending, ioctrl + +int filbuf(), read(), strncmp(), fstati() +int pr_findproc(), psio_isxmit(), zfunc2(), zfunc3() +errchk epa_writep, epa_giotr, epa_writetty, epa_readtty, epa_gflush +errchk pr_findproc, psio_xfer, filbuf, read, write, flush, syserr +include +include "prc.com" + +begin + stream = fd + pr = pr_findproc (pid) + in = pr_infd[pr] + stkp = 0 + + if (rwflag == FF_WRITE) { + # We have been called to write to a subprocess. Simulate a + # pending XMIT request by pushing an XMIT on the stack. This + # causes XFER requests to be processed from the subprocess + # until the FIO buffer for destfd is exhausted. + + push (pr) + push (in) + push (fd) + push (stream) + push (XMIT) + } + +# call putline (STDERR, "----------------------------------------------\n") +# call eprintf ("PSIO (pid=%d, pr=%d, stream=%d)\n") +# call pargi(pid); call pargi(pr); call pargi(stream) + + # Process i/o requests from the subprocess until a request is received + # for the stream FD. Unsolicited requests from the process do not + # satisfy the request we were called for, e.g., a process may read from + # STDIN or write to STDERR before reading from fd=STDGRAPH. + + repeat { + repeat { +# call eprintf ("\n.....fill buffer: in=%d, pr=%d, stream=%d, stkp=%d\n") +# call pargi(in); call pargi(pr); call pargi(stream); call pargi(stkp) + nleft = itop[in] - iop[in] + if (nleft <= 0) + nleft = filbuf (in) + +# for(ip=iop[in];ip KSHIFT) { + destfd = mod (destination, KSHIFT) + destpr = destination / KSHIFT + } else { + destfd = destination + destpr = 0 + } + + graphics_stream = (destfd >= STDGRAPH && destfd <= STDPLOT) + + # Discard the xmit or xfer directive. We will reuse the + # buffer at Memc[ip] later for temporary storage. + + itop[in] = ip +# call eprintf ("filter=%b, destfd=%d, destpr=%d\n") +# call pargb(filter_gki); call pargi (destfd); call pargi (destpr) + + } else { + # Pseudofile control directive. + record_type = PSIO + itop[in] = ip + } + + # Process the record (data or PSIO directive). + switch (record_type) { + case DATA: + # Ordinary data record. If the requested fd is not CLIN + # we have an unsolicited command input error. If this + # occurs on a graphics stream, reset the stream (close the + # kernel and free all storage) to avoid leaving the graphics + # system in a funny state. + + iotype = FF_READ + destfd = CLIN + + if (stream != destfd) { + # Reset graphics stream. + if (graphics_stream) + call zcall1 (epa_gflush, stream) + + # Take error action. + Memc[ip+nchars] = EOS + call putline (STDERR, Memc[ip]) + call syserr (SYS_PRPSIOUCI) + } + + case XMIT: + # Write to a process pseudofile. + iotype = FF_READ + + # If pseudofile output is not connected to a stream read + # and discard the data block. This situation occurs + # whenever a task in interrupted. + + if (destfd == 0) { + if (read (in, Memc[ip], nchars) < nchars) + call syserr (SYS_PRIPCSYNTAX) + next + } + + if (filter_gki) { + # Process a block of GKI metacode. Append the block + # to the frame buffer for the stream and call GIOTR + # to process the metacode. + + op = zfunc2 (epa_writep, destfd, nchars) + if (read (in, Memc[op], nchars) < nchars) + call syserr (SYS_PRIPCSYNTAX) +# call eprintf ("___giotr, %d chars\n") +# call pargi (nchars) + + # Call GIOTR to process the graphics data. Any data + # to be returned to the client is spooled in the + # graphics stream to be read by a subsequent XFER. + + call fseti (destfd, F_CANCEL, OK) + call zcall1 (epa_giotr, destfd) + call seek (destfd, BOFL) + + } else { + # Binary transfer. + + if (read (in, Memc[ip], nchars) < nchars) + call syserr (SYS_PRIPCSYNTAX) + + # If writing to a standard stream and a raw mode i/o + # control sequence is seen, do a fseti on STDIN in + # this process to set up raw mode at the FIO level + # on the stream. If we don't do this, raw mode will + # be set in the driver but will be disabled in the + # first i/o operation by a nchars>1 read request from + # FIO. + + if (destfd >= STDIN && destfd <= STDERR) { + ioctrl = (Memc[ip] == ESC && + (nchars==LEN_RAWCMD || nchars==LEN_RAWCMD+1)) + if (ioctrl) { + if (strncmp(Memc[ip],RAWOFF,LEN_RAWCMD) == 0) { + flags = IO_NORMAL + } else if (strncmp (Memc[ip], + RAWON, LEN_RAWCMD) == 0) { + flags = IO_RAW + if (Memc[ip+LEN_RAWCMD] == 'N') + flags = flags + IO_NDELAY + } else + ioctrl = false + } + + if (ioctrl) + call fseti (STDIN, F_IOMODE, flags) + else { + call zcall3 (epa_writetty, destfd, Memc[ip], + nchars) + } + } else { + call write (destfd, Memc[ip], nchars) + if (!graphics_stream) + call flush (destfd) + } + } + + # If writing to another process, push the current request + # and transfer command input to the destination process. + # Rewind the destfd file buffer so that it may be read by + # the process in a subsequent XFER call on the stream. + + if (destpr != 0) { + if (graphics_stream) + call seek (destfd, BOFL) + + push (pr) + push (in) + push (destfd) + push (stream) + push (XMIT) + + pr = destpr + in = pr_infd[pr] + stream = destfd +# call eprintf ("push XMIT, new in = %d, new pr = %d\n") +# call pargi (in); call pargi(pr) + + } else if (stkp > 0) { + # If the XMIT just completed satisfies a pending XFER + # request, complete the XFER request and pop it from + # the stack. + + rq = stkp - LEN_STACKFRAME + 1 + if (S_REQUEST(rq) == XFER && + S_DESTFD(rq) == destfd) { + + pop (record_type) + pop (stream) + pop (destfd) + pop (in) + pop (pr) + + call seek (stream, BOFL) + nchars = itop[stream] - iop[stream] + if (nchars <= 0) + nchars = 0 + else + nchars = read (stream, Memc[ip], nchars) +# call eprintf ("XFER completed from fd=%d to pr=%d, %d chars\n") +# call pargi(stream); call pargi(pr); call pargi(nchars) + call psio_xfer (pr_outfd[pr], Memc[ip], nchars) + + # The stream buffer should now be empty as only + # one IPC record at a time is buffered for an + # XFER request. Mark the buffer empty. + + call fseti (stream, F_CANCEL, OK) + } + } + + case XFER: + # Read from a pseudofile. + iotype = FF_WRITE + + if (destpr != 0 && iop[destfd] >= itop[destfd]) { + # Read from another process. Pseudofile FIO buffer + # is empty. Push the current request and transfer + # command input to the second process to give it an + # opportunity to write data into the buffer so that + # we can complete the XFER request. + + push (pr) + push (in) + push (destfd) + push (stream) + push (XFER) + + pr = destpr + in = pr_infd[pr] + stream = destfd +# call eprintf ("push XFER, new in = %d, new pr = %d\n") +# call pargi (in); call pargi(pr) + + } else { + # Binary transfer. If reading from the stream + # associated with a pushed XMIT and the stream + # buffer is empty, the XMIT has been completed + # and must be popped. + + xmit_pending = false + if (stkp > 0) { + rq = stkp - LEN_STACKFRAME + 1 + if (S_REQUEST(rq) == XMIT && S_DESTFD(rq) == destfd) + xmit_pending = true + } + +# call eprintf ("in XFER: req=%d, str=%d, xmp=%b, iop=%d, itop=%d\n") +# call pargi(S_REQUEST(rq)); call pargi(S_STREAM(rq)) +# call pargb(xmit_pending); call pargi(iop[destfd]); call pargi(itop[destfd]) + + if (xmit_pending && iop[destfd] >= itop[destfd]) { + # The pending XMIT has been completed (the stream + # buffer has been emptied by the reading process). + # Push the current XFER request back into the + # process input stream since we are not prepared + # to deal with it now. + + itop[in] = iop[in] + nleft + + # Pop the XMIT request. + pop (record_type) + pop (stream) + pop (destfd) + pop (in) + pop (pr) + ip = iop[in] + + # Empty the fully read stream buffer. + call fseti (destfd, F_CANCEL, OK) +# call eprintf ("XFER pops XMIT; push back XFER for later\n") + + } else { + # Satisfy XFER by reading a data record and + # returning it to the requesting process. + # A request to read a single char enables raw + # mode, just as it does for ZGETTX. + +# This should not be necessary since the raw mode control sequence is +# intercepted above. Also it is incorrect since F_NDELAY is not supported. +# if (nchars == 1) +# call fseti (destfd, F_RAW, YES) + + if (destfd == STDIN) { + nchars = zfunc3 (epa_readtty, + destfd, Memc[ip], nchars) + } else + nchars = read (destfd, Memc[ip], nchars) + if (nchars == EOF) + nchars = 0 +# call eprintf ("XFER completed from fd=%d to pr=%d, %d chars\n") +# call pargi(destfd); call pargi(pr); call pargi(nchars) + call psio_xfer (pr_outfd[pr], Memc[ip], nchars) + } + } + + + case PSIO: + # Pseudofile i/o control directive. These directives are + # used to connect graphics kernels to streams, to set and + # get WCS, set cursor mode parameters, etc. An XMIT to the + # pseudofile PSIOCTRL is use to pass control instructions + # via us to GTR_CONTROL, below. Note that the PSIOCTRL + # pseudofile is used to control all the graphics pseudofile + # streams. The number of the graphics pseudofile stream + # to be operated upon by gtr_control is passed as the first + # integer word of the data block. + + # Read pseudofile number. + iotype = 0 + if (read (in, ps, SZ_INT32) < SZ_INT32) + call syserr (SYS_PRIPCSYNTAX) + + # Read data block. + nchars = nchars - SZ_INT32 + if (read (in, Memc[ip], nchars) < nchars) + call syserr (SYS_PRIPCSYNTAX) + + # Call gtr_control to process the control directives. + iferr (call zcall3 (epa_control,ps,Memc[ip],pr_pid[pr])) + call erract (EA_WARN) + + # When writing to a graphics subkernel gtr_control may + # leave graphics metacode spooled in the graphics stream + # which we need to pass on to the subkernel. This is + # done by pushing an XMIT on the psio control stack to + # cause the subkernel process to be polled to see if it + # wants the spooled data. + + nchars = fstati (ps, F_FILESIZE) + if (nchars > 0) { + destination = abs(pr_pstofd[pr,ps]) + if (destination > KSHIFT) { + destfd = mod (destination, KSHIFT) + destpr = destination / KSHIFT + } else { + destfd = destination + destpr = 0 + } + + if (destpr != 0) { + call seek (destfd, BOFL) + + push (pr) + push (in) + push (destfd) + push (stream) + push (XMIT) + + pr = destpr + in = pr_infd[pr] + stream = destfd + } + } + + case OSCMD: + # OS escape directive. There are portability problems + # with issuing ZOSCMD os escapes from subprocesses, so + # subprocesses send OS escapes to us (the parent process) + # as !cmd commands on CLOUT. + + Memc[ip+nchars] = EOS + call proscmd (pr, Memc[ip+1]) + } + + } until (stkp <= 0 && record_type != OSCMD) + +# call eprintf ("termination ps(%d)=st(%d), io(%d)=rw(%d)\n") +# call pargi(pseudofile); call pargi(stream) +# call pargi(iotype); call pargi(rwflag) + } until (pseudofile == stream && iotype == rwflag) + +# call putline (STDERR, "----------------------------------------------\n") +# call eprintf ("EXIT PSIO\n") + + if (nchars == 0) + return (EOF) + else + return (nchars) +end diff --git a/sys/etc/prpsload.x b/sys/etc/prpsload.x new file mode 100644 index 00000000..c44eea03 --- /dev/null +++ b/sys/etc/prpsload.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PRPSLOAD -- Must be called at process startup time to initialize pseudofile +# i/o for the graphics streams, if any i/o to the graphics pseudofiles is +# expected. The arguments are the LOCPR entry point addresses of the graphics +# driver (gio.cursor) procedures to be called to process i/o requests on the +# graphics streams. + +procedure prpsload (giotr, control, gflush, writep, readtty, writetty) + +extern giotr() #I gio.cursor driver procedures +extern control() #I " " +extern gflush() #I " " +extern writep() #I " " +extern readtty() #I " " +extern writetty() #I " " + +int locpr() +include "prc.com" + +begin + epa_giotr = locpr (giotr) + epa_control = locpr (control) + epa_gflush = locpr (gflush) + epa_writep = locpr (writep) + epa_readtty = locpr (readtty) + epa_writetty = locpr (writetty) +end diff --git a/sys/etc/prredir.x b/sys/etc/prredir.x new file mode 100644 index 00000000..baf68b48 --- /dev/null +++ b/sys/etc/prredir.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PRREDIR -- Redirect the pseudofile stream of a connected subprocess. A newly +# connected subprocess inherits the pseudofile streams of the parent, i.e., +# a write to STDOUT by the child will be directed to the STDOUT of the parent. +# Note that unlike FREDIR, the destination stream must already be open and +# is unaffected by the redirection of the pseudofile (the pseudofile stream is +# redirected into the existing stream). The destination file need not be of +# the same type (binary) as the pseudofile, unless the pseudofile stream +# contains binary data. + +procedure prredir (pid, stream, new_fd) + +int pid # process-id of child +int stream # stream to be redirected (STDIN, STDOUT, etc) +int new_fd # destination FD (already opened) + +int pr +int pr_findproc() +include "prc.com" +errchk syserr + +begin + pr = pr_findproc (pid) + if (pr == ERR) + call syserr (SYS_PRNOTFOUND) + + pr_pstofd[pr,stream] = new_fd +end diff --git a/sys/etc/prseti.x b/sys/etc/prseti.x new file mode 100644 index 00000000..ad798d42 --- /dev/null +++ b/sys/etc/prseti.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# PRSETI -- Set the value of a parameter for a connected subprocess. + +procedure prseti (pid, param, value) + +int pid #I process id of connected subprocess +int param #I parameter to be set +int value #I new parameter value + +int pr +int pr_findproc() +include "prc.com" +errchk syserr + +begin + pr = pr_findproc (pid) + if (pr == ERR) + call syserr (SYS_PRNOTFOUND) + + switch (param) { + case PR_STATUS: + pr_status[pr] = value + case PR_INCHAN: + pr_inchan[pr] = value + case PR_INFD: + pr_infd[pr] = value + case PR_OUTCHAN: + pr_outchan[pr] = value + case PR_OUTFD: + pr_outfd[pr] = value + case PR_STDIN: + pr_pstofd[pr,STDIN] = value + case PR_STDERR: + pr_pstofd[pr,STDERR] = value + case PR_STDOUT: + pr_pstofd[pr,STDOUT] = value + case PR_STDGRAPH: + pr_pstofd[pr,STDGRAPH] = value + case PR_STDIMAGE: + pr_pstofd[pr,STDIMAGE] = value + case PR_STDPLOT: + pr_pstofd[pr,STDPLOT] = value + default: + call syserr (SYS_PRSTAT) + } +end diff --git a/sys/etc/prsignal.x b/sys/etc/prsignal.x new file mode 100644 index 00000000..0ec647a0 --- /dev/null +++ b/sys/etc/prsignal.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# PRSIGNAL -- Send a signal (interrupt) to a child process. It is an error +# if the pid given is not found in the process table. + +procedure prsignal (pid, signal) + +int pid # process-id of child process +int signal # code of signal to be sent (e.g. X_INT) + +int child +int pr_findproc() +include "prc.com" +errchk syserr + +begin + child = pr_findproc (pid) + if (child != ERR) + call zintpr (pid, signal, child) + + if (child == ERR) + call syserr (SYS_PRSIGNAL) +end diff --git a/sys/etc/prstati.x b/sys/etc/prstati.x new file mode 100644 index 00000000..bd3eb221 --- /dev/null +++ b/sys/etc/prstati.x @@ -0,0 +1,49 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# PRSTATI -- Get the value of a parameter for a connected subprocess. + +int procedure prstati (pid, param) + +int pid # process id of connected subprocess +int param # parameter for which status is desired +int pr +int pr_findproc() +include "prc.com" +errchk syserr + +begin + pr = pr_findproc (pid) + if (pr == ERR) + call syserr (SYS_PRNOTFOUND) + + switch (param) { + case PR_STATUS: + return (pr_status[pr]) + case PR_INCHAN: + return (pr_inchan[pr]) + case PR_INFD: + return (pr_infd[pr]) + case PR_OUTCHAN: + return (pr_outchan[pr]) + case PR_OUTFD: + return (pr_outfd[pr]) + case PR_STDIN: + return (pr_pstofd[pr,STDIN]) + case PR_STDERR: + return (pr_pstofd[pr,STDERR]) + case PR_STDOUT: + return (pr_pstofd[pr,STDOUT]) + case PR_STDGRAPH: + return (pr_pstofd[pr,STDGRAPH]) + case PR_STDIMAGE: + return (pr_pstofd[pr,STDIMAGE]) + case PR_STDPLOT: + return (pr_pstofd[pr,STDPLOT]) + default: + call syserr (SYS_PRSTAT) + } +end diff --git a/sys/etc/prupdate.x b/sys/etc/prupdate.x new file mode 100644 index 00000000..49aa7e56 --- /dev/null +++ b/sys/etc/prupdate.x @@ -0,0 +1,61 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# PRUPDATE -- Broadcast a message to a process, or if pid=0, to all connected +# subprocesses. Used primarily to incrementally pass SET and CHDIR commands to +# subprocesses, eliminating the need to reconnect each process. Note that the +# child process does not return "bye" in response to one of the builtin +# functions SET and CHDIR. NOTE: if a child process is marked "busy" the +# message is not sent to that process; only idle processes receive the message. + +procedure prupdate (pid, message, flushout) + +int pid #I process to be updated, or 0 for all procs +char message[ARB] #I message to be broadcast to each child +int flushout #I flush output + +int pr, status +pointer sp, cmd, op +int gstrcpy(), prstati() +include "prc.com" + +begin + call smark (sp) + call salloc (cmd, SZ_COMMAND, TY_CHAR) + + # Make sure that the message string is non-null and is newline + # delimited. + + op = cmd + gstrcpy (message, Memc[cmd], SZ_COMMAND) + if (op == cmd) { + call sfree (sp) + return + } else if (Memc[op-1] != '\n') { + Memc[op] = '\n' + Memc[op+1] = EOS + } + + # Broadcast the message. If the child fails to process the command + # and returns the ERROR statement, the error will not be detected until + # the next user command is sent to the process (and indeed may corrupt + # the protocol). The parent should execute the SET or CHDIR prior + # to sending it to the child to make sure it is valid. + + for (pr=1; pr <= MAX_CHILDPROCS; pr=pr+1) + if ((pid != NULL && pr_pid[pr] == pid) || + (pid == NULL && pr_pid[pr] != NULL)) { + + status = prstati (pr_pid[pr], PR_STATUS) + if (status == P_RUNNING) { + iferr (call putline (pr_outfd[pr], Memc[cmd])) + call erract (EA_WARN) + else if (flushout == YES) + call flush (pr_outfd[pr]) + } + } + + call sfree (sp) +end diff --git a/sys/etc/psioisxt.x b/sys/etc/psioisxt.x new file mode 100644 index 00000000..ddebd7df --- /dev/null +++ b/sys/etc/psioisxt.x @@ -0,0 +1,58 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + + +# PSIO_ISXMIT -- Test for a pseudofile directive. Return XMIT, XFER, or DATA +# as the function value, and if we do have a pseudofile, decode the pseudofile +# number and char count. +# +# Syntax: "xmit(P,NNN)" or "xfer(P,NNN)" +# 12345678 12345678 +# +# where P is the pseudofile code (0= 0) { + ndigits = itoc (nchars, numbuf, SZ_NUMBUF) + numbuf[ndigits+1] = '\n' + call write (fd, numbuf, ndigits + 1) + call flush (fd) + + if (nchars > 0) { + call write (fd, buf, nchars) + call flush (fd) + } + } +end diff --git a/sys/etc/qsort.x b/sys/etc/qsort.x new file mode 100644 index 00000000..f7efc4d3 --- /dev/null +++ b/sys/etc/qsort.x @@ -0,0 +1,81 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define LOGPTR 32 # log2(maxpts) (4e9) + +# QSORT -- General quicksort 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] +# +# QSORT reorders the elements of the X array, which must be of type integer. +# **NOTE** - See also gqsort.x, a more recent version of this routine. + +procedure qsort (x, nelem, compare) + +int x[ARB] # array to be sorted +int nelem # number of elements in array +extern compare() # function to be called to compare elements + +int i, j, k, lv[LOGPTR], p, pivot, uv[LOGPTR], temp +define swap {temp=$1;$1=$2;$2=temp} +int compare() + +begin + lv[1] = 1 + uv[1] = nelem + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy loop to trigger the optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # subfile, to avoid quadratic behavior on an already + # sorted list. + + k = (lv[p] + uv[p]) / 2 + swap (x[j], x[k]) + pivot = x[j] # pivot line + + while (i < j) { + for (i=i+1; compare (x[i], pivot) < 0; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (compare (x[j], pivot) <= 0) + break + if (i < j) # out of order pair + swap (x[i], x[j]) # interchange elements + } + + j = uv[p] # move pivot to position i + swap (x[i], x[j]) # interchange elements + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + + p = p + 1 # push onto stack + } + } +end diff --git a/sys/etc/sttyco.x b/sys/etc/sttyco.x new file mode 100644 index 00000000..54f2c5ce --- /dev/null +++ b/sys/etc/sttyco.x @@ -0,0 +1,519 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +.help sttyco +.nf --------------------------------------------------------------------------- +STTYCO -- Set/stat VOS terminal driver options via command string. This is a +high level front-end to the ttset/ttstat procedures, used to set or query the +individual terminal driver parameters. Since STTYCO is driven by a command +string it may be called either as a task or as a subroutine. When called as +a task, e.g, as the STTY task in the CL, the argument list is simply +concatenated into a long string and passed to STTYCO for processing. + +The argument list consists of zero or more argument strings, as follows: + + reset Reset default terminal settings + init Send initialization sequence to the terminal + show Show terminal settings + all Show all parameters, even if not in use + Show terminal settings + Assumed to be the termcap name of a terminal. + Set envvars `terminal', `ttyncols', and + `ttynlines' for the named terminal. + baud=N Set envvar `ttybaud=N'. + ncols=N Set envvar `ttyncols=N'. + nlines=N Set envvar `ttynlines=N'. + resize Reset the screen size parameters. + + clear Disable named driver functions. + + ucasein Map input to lower case. + ucaseout Map output to upper case. + + logio [=logiofile] Log all i/o to the terminal in a file. + login [=loginfile] Log input from terminal in a file. + logout [=logoutfile] Log output to terminal in a file. + + playback [=pbfile] Read terminal input from a logfile. + verify Pause at newline when in playback mode. + delay=N Msec delay in playback mode, verify disabled. + +Simply naming a parameter like ucasein, logio, etc., causes that function to +be enabled, or disabled if preceeded by the keyword `clear'. Any of the +sequences +, -, =yes, =no may also be appended to turn the function on or off. +The logging functions may also take a filename argument, e.g., logio=file +enables i/o logging into the named file. The default filenames are as follows: + + logio home$ttyio.log + login home$ttin.log + logout home$ttout.log + playback home$ttin.log + +If verify is disabled a delay will precede each record returned from the +input file; the default delay is quite short. Pause mode is terminated by +typing a space or carriage return to continue execution, or `q' to terminate +playback mode. +.endhelp ---------------------------------------------------------------------- + +define STTY_KEYWORDS "|reset|init|all|show|baud|ncols|nlines|resize|clear|\ + |ucasein|ucaseout|logio|login|logout|playback|verify|delay|" + +define RESET 1 # reset default terminal settings +define INIT 2 # send initialization sequence to the terminal +define ALL 3 # show all parameters +define SHOW 4 # show parameters +define BAUD 5 # set envvar `ttybaud' +define NCOLS 6 # set envvar `ttyncols' +define NLINES 7 # set envvar `ttynlines' +define RESIZE 8 # reset the screen size parameters +define CLEAR 9 # set default action to NO rather than YES +# newline 10 +define UCASEIN 11 # map input to lower case +define UCASEOUT 12 # map output to upper case +define LOGIO 13 # log all i/o in a file +define LOGIN 14 # log input in a file +define LOGOUT 15 # log output in a file +define PLAYBACK 16 # take input from a file +define VERIFY 17 # wait for user to type a key after each record +define DELAY 18 # msec delay after each record in playback mode + + +# STTYCO -- Main entry point. Input consists of an argument list of arbitrary +# length. Output is to the given file descriptor. + +procedure sttyco (args, ttin, ttout, outfd) + +char args[ARB] # argument list +int ttin, ttout # tty file descriptors +int outfd # write task output here + +pointer sp, keyw, value, tty +int startcol, ival, nargs, yesno, defact, show, all, ip +int stty_getarg(), strdic(), ctoi() +pointer ttyodes() + +string keywords STTY_KEYWORDS +errchk ttseti, ttsets, stty_ttyinit +define argerr_ 91 + +begin + call smark (sp) + call salloc (keyw, SZ_FNAME, TY_CHAR) + call salloc (value, SZ_FNAME, TY_CHAR) + + defact = YES + show = NO + all = NO + ip = 1 + + # Process successive keyword=value arguments. + + for (nargs=0; stty_getarg (args, ip, Memc[keyw], SZ_FNAME, Memc[value], + SZ_FNAME, defact, yesno) != EOF; nargs = nargs + 1) { + + switch (strdic (Memc[keyw], Memc[keyw], SZ_FNAME, keywords)) { + case RESET: + call ttseti (ttin, TT_INITIALIZE, yesno) + case INIT: + call stty_ttyinit (ttin, ttout, "terminal") + + case ALL: + all = yesno + show = YES + case SHOW: + show = yesno + case BAUD: + if (IS_DIGIT (Memc[value])) + call stty_envreset ("ttybaud", Memc[value]) + else + goto argerr_ + case NCOLS: + if (IS_DIGIT (Memc[value])) + call stty_envreset ("ttyncols", Memc[value]) + else + goto argerr_ + case NLINES: + if (IS_DIGIT (Memc[value])) + call stty_envreset ("ttynlines", Memc[value]) + else + goto argerr_ + + case RESIZE: + tty = ttyodes ("terminal") + call stty_setsize (ttin, ttout, tty) + call ttycdes (tty) + + case CLEAR: + defact = NO + + case UCASEIN: + call ttseti (ttin, TT_UCASEIN, yesno) + case UCASEOUT: + call ttseti (ttin, TT_UCASEOUT, yesno) + + case LOGIO: + if (yesno == YES && Memc[value] != EOS) + call ttsets (ttin, TT_IOFILE, Memc[value]) + call ttseti (ttin, TT_LOGIO, yesno) + case LOGIN: + if (yesno == YES && Memc[value] != EOS) + call ttsets (ttin, TT_INFILE, Memc[value]) + call ttseti (ttin, TT_LOGIN, yesno) + case LOGOUT: + if (yesno == YES && Memc[value] != EOS) + call ttsets (ttin, TT_OUTFILE, Memc[value]) + call ttseti (ttin, TT_LOGOUT, yesno) + case PLAYBACK: + if (yesno == YES && Memc[value] != EOS) + call ttsets (ttin, TT_PBFILE, Memc[value]) + call ttseti (ttin, TT_PLAYBACK, yesno) + + case VERIFY: + call ttseti (ttin, TT_PBVERIFY, yesno) + case DELAY: + startcol = 1 + if (ctoi (Memc[value], startcol, ival) > 0) + call ttseti (ttin, TT_PBDELAY, ival) + else + goto argerr_ + + default: + # If not keyword, must be a terminal name. + iferr (call stty_newterm (ttin, ttout, Memc[keyw])) + call erract (EA_WARN) + } + } + + # If the argument list was null or the SHOW flag was set, show + # the current terminal settings. + + if (nargs == 0 || show == YES) + call stty_showterm (ttin, ttout, outfd, all) + + call sfree (sp) + return + +argerr_ + call syserrs (SYS_STTYNUMARG, Memc[keyw]) + call sfree (sp) +end + + +# STTY_NEWTERM -- Configure the environment for a new type of terminal. + +procedure stty_newterm (ttin, ttout, terminal) + +int ttin, ttout # tty file descriptors +char terminal[ARB] # termcap name of new terminal + +pointer sp, vp, tty +pointer ttyodes() + +bool ttygetb() +int ttygets() +errchk ttyodes, stty_envreset, ttygsize + +begin + call smark (sp) + call salloc (vp, SZ_FNAME, TY_CHAR) + + tty = ttyodes (terminal) + + # Set the terminal parameters. + call stty_envreset ("terminal", terminal) + call stty_setsize (ttin, ttout, tty) + + # Set the stdgraph device name for this terminal, if given. + if (ttygetb (tty, "gd")) { + if (ttygets (tty, "gd", Memc[vp], SZ_FNAME) <= 0) + call strcpy (terminal, Memc[vp], SZ_FNAME) + } else + call strcpy ("none", Memc[vp], SZ_FNAME) + call stty_envreset ("stdgraph", Memc[vp]) + + call ttycdes (tty) + call sfree (sp) +end + + +# STTY_SETSIZE -- Determine the terminal screen size in characters, and set +# up the environment appropriately. + +procedure stty_setsize (ttin, ttout, tty) + +int ttin, ttout # tty file descriptors +pointer tty + +char num[4] +int ncols, nlines, n +int itoc() + +begin + call ttygsize (ttin, ttout, tty, ncols, nlines) + + n = itoc (ncols, num, 4) + call stty_envreset ("ttyncols", num) + call ttyseti (tty, TTY_NCOLS, ncols) + + n = itoc (nlines, num, 4) + call stty_envreset ("ttynlines", num) + call ttyseti (tty, TTY_NLINES, nlines) +end + + +# STTY_TTYINIT -- Output the initialization string and the contents of +# the initialization file to the terminal, if either is specified in the +# termcap entry for the device. + +procedure stty_ttyinit (ttin, ttout, terminal) + +int ttin, ttout # tty file descriptors +char terminal[ARB] # termcap name of new terminal + +pointer tty +pointer ttyodes() + +begin + tty = ttyodes (terminal) + call ttyinit (ttout, tty) + call flush (ttout) + call ttycdes (tty) +end + + +# STTY_ENVRESET -- Set the value of an environment variable in the current +# process and in all connected subprocesses. + +procedure stty_envreset (envvar, value) + +char envvar[ARB] # environment variable to be set +char value[ARB] # new value + +errchk envreset + +begin + call envreset (envvar, value) + call prenvset (0, envvar, value) +end + + +# STTY_SHOWTERM -- Show the current terminal driver status. + +procedure stty_showterm (ttin, ttout, fd, all) + +int ttin, ttout # tty file descriptors +int fd # where the output goes +int all # show all params, even if not in use + +int junk +pointer sp, val +bool ucasein, ucaseout, shift, logio, login, logout, playback, showall +int ttstati(), ttstats(), envfind() + +string unknown "[unknown]" +string on "on" +string off "off" + +begin + call smark (sp) + call salloc (val, SZ_FNAME, TY_CHAR) + + ucasein = (ttstati (ttin, TT_UCASEIN) == YES) + ucaseout = (ttstati (ttin, TT_UCASEOUT) == YES) + shift = (ttstati (ttin, TT_SHIFTLOCK) == YES) + logio = (ttstati (ttin, TT_LOGIO) == YES) + login = (ttstati (ttin, TT_LOGIN) == YES) + logout = (ttstati (ttin, TT_LOGOUT) == YES) + playback = (ttstati (ttin, TT_PLAYBACK) == YES) + showall = (all == YES) + + # Show tty environment variables. + + if (envfind ("terminal", Memc[val], SZ_FNAME) <= 0) + call strcpy ("?", Memc[val], SZ_FNAME) + call fprintf (fd, "%s ") + call pargstr (Memc[val]) + + if (envfind ("ttyncols", Memc[val], SZ_FNAME) <= 0) + call strcpy ("?", Memc[val], SZ_FNAME) + call fprintf (fd, "ncols=%s ") + call pargstr (Memc[val]) + + if (envfind ("ttynlines", Memc[val], SZ_FNAME) <= 0) + call strcpy ("?", Memc[val], SZ_FNAME) + call fprintf (fd, "nlines=%s ") + call pargstr (Memc[val]) + + if (showall || ucasein || ucaseout) { + if (envfind ("ttybaud", Memc[val], SZ_FNAME) <= 0) + call strcpy ("?", Memc[val], SZ_FNAME) + call fprintf (fd, "baudrate=%s ") + call pargstr (Memc[val]) + + call fprintf (fd, "ucasein=%b ") + call pargb (ucasein) + call fprintf (fd, "ucaseout=%b ") + call pargb (ucaseout) + call fprintf (fd, "shift=%b\n") + call pargb (shift) + } else + call fprintf (fd, "\n") + + # Show internal driver state variables in `show all' mode. + + if (showall) { + call fprintf (fd, + "kichan=%d kochan=%d lichan=%d lochan=%d pbchan=%d ") + call pargi (ttstati (ttin, TT_KINCHAN)) + call pargi (ttstati (ttin, TT_KOUTCHAN)) + call pargi (ttstati (ttin, TT_LOGINCHAN)) + call pargi (ttstati (ttin, TT_LOGOUTCHAN)) + call pargi (ttstati (ttin, TT_PBINCHAN)) + + call fprintf (fd, "raw=%b passthru=%b\n") + call pargb (ttstati (ttin, TT_RAWMODE) == YES) + call pargb (ttstati (ttin, TT_PASSTHRU) == YES) + } + + # Show the status of the logging options. + + if (logio || showall) { + junk = ttstats (ttin, TT_IOFILE, Memc[val], SZ_FNAME) + call fprintf (fd, "logio=%s [%s]\n") + call pargstr (Memc[val]) + if (logio) + call pargstr (on) + else + call pargstr (off) + } + + if (!logio || showall) { + if (login || showall) { + junk = ttstats (ttin, TT_INFILE, Memc[val], SZ_FNAME) + call fprintf (fd, "login=%s [%s]\n") + call pargstr (Memc[val]) + if (login) + call pargstr (on) + else + call pargstr (off) + } + if (logout || showall) { + junk = ttstats (ttin, TT_OUTFILE, Memc[val], SZ_FNAME) + call fprintf (fd, "logout=%s [%s]\n") + call pargstr (Memc[val]) + if (logout) + call pargstr (on) + else + call pargstr (off) + } + } + + if (playback || showall) { + junk = ttstats (ttin, TT_PBFILE, Memc[val], SZ_FNAME) + call fprintf (fd, "playback=%s [%s] ") + call pargstr (Memc[val]) + if (playback) + call pargstr (on) + else + call pargstr (off) + + call fprintf (fd, "verify=%b ") + call pargb (ttstati (ttin, TT_PBVERIFY) == YES) + call fprintf (fd, "delay=%d (msec)") + call pargi (ttstati (ttin, TT_PBDELAY)) + call fprintf (fd, "\n") + } + + if (playback) { + call fprintf (fd, "script recorded with terminal=%s, stdgraph=%s\n") + if (ttstats (ttin, TT_TDEVICE, Memc[val], SZ_FNAME) <= 0) + call pargstr (unknown) + else + call pargstr (Memc[val]) + if (ttstats (ttin, TT_GDEVICE, Memc[val], SZ_FNAME) <= 0) + call pargstr (unknown) + else + call pargstr (Memc[val]) + } + + call sfree (sp) +end + + +# STTY_GETARG -- Get the next argument from an argument list. Arguments are of +# the form keyw, keyw+, keyw-, keyw=(yes|y), keyw=(no|n), or keyw=value. +# All forms are reduced to a flag YESNO and a value string VALUE. The forms +# keyw=yes, key=no, etc., cause YESNO to be set but not VALUE. If only the +# keyword name is given YESNO is set to YES and VALUE to the null string. +# The number of characters in the keyword=value argument string is returned +# as the function value, or EOF when the argument list is exhausted. + +int procedure stty_getarg (args, ip, keyw, maxkc, value, maxvc, defact, yesno) + +char args[ARB] # argument string +int ip # index into argument string [RW] +char keyw[ARB] # receives keyword name +int maxkc # max chars in keyw string +char value[ARB] # receives value string or EOS +int maxvc # max chars in value string +int defact # default action (yes/no) if only keyword given +int yesno # boolean value of parameter + +int op +int ip_save +bool streq() + +begin + while (IS_WHITE (args[ip])) + ip = ip + 1 + + ip_save = ip + + # Get keyword name. + for (op=1; IS_ALNUM (args[ip]); ip=ip+1) { + keyw[op] = args[ip] + op = min (maxkc, op + 1) + } + keyw[op] = EOS + + while (IS_WHITE (args[ip])) + ip = ip + 1 + + value[1] = EOS + yesno = defact + + if (args[ip] == '=') { + # Extract value string. + op = 1 + for (ip=ip+1; args[ip] > ' '; ip=ip+1) { + value[op] = args[ip] + op = min (maxvc, op + 1) + } + value[op] = EOS + + # Check for keyw=[yes|no]. + if (streq (value, "yes") || streq (value, "y")) { + yesno = YES + value[1] = EOS + } else if (streq (value, "no") || streq (value, "n")) { + yesno = NO + value[1] = EOS + } + } else if (args[ip] == '+') { + yesno = YES + ip = ip + 1 + } else if (args[ip] == '-') { + yesno = NO + ip = ip + 1 + } + + if (ip <= ip_save) + return (EOF) + else + return (ip - ip_save) +end diff --git a/sys/etc/syserr.x b/sys/etc/syserr.x new file mode 100644 index 00000000..a14d516d --- /dev/null +++ b/sys/etc/syserr.x @@ -0,0 +1,49 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define SZ_ERRMSG SZ_LINE + +# SYSERR -- Process a system error. No arguments; print only the error +# message from the system error message file. + +procedure syserr (errcode) + +int errcode + +begin + call syserrs (errcode, "") +end + + +# SYSERRS -- System error, with a user supplied string argument. We do not +# want to search the system error message file until ERRACT is called to +# output the error message and initiate error recovery, because if an IFERR +# error handler is posted the message will never be used. Hence we encode +# an error message of the form "123 user_string", where "123" is the encoded +# system error message number. If a message is ever actually output the +# 123 will be expanded into a readable error message. + +procedure syserrs (errcode, user_string) + +int errcode +char user_string[ARB] + +char buf[SZ_ERRMSG] +int ip, op +int itoc() + +begin + # Encode error code, to be used to search error message file. + op = itoc (errcode, buf, SZ_ERRMSG) + 1 + + if (user_string[1] != EOS) { + buf[op] = ' ' + op = op + 1 + for (ip=1; op <= SZ_ERRMSG && user_string[ip] != EOS; ip=ip+1) { + buf[op] = user_string[ip] + op = op + 1 + } + } + buf[op] = EOS + + call error (errcode, buf) +end diff --git a/sys/etc/sysid.x b/sys/etc/sysid.x new file mode 100644 index 00000000..94bd77bc --- /dev/null +++ b/sys/etc/sysid.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# SYSID -- Return a line of text identifying the current user, machine, and +# version of IRAF, and containing the current date and time. The format is +# as follows: +# +# NOAO/IRAF V1.3 username@lyra Tue 09:47:50 27-Aug-85 +# +# The string "NOAO/IRAF V1.3" is given by the value of the environment variable +# "version", defined in lib$clpackage.cl (unless redefined by the user). The +# string "username" is the value of the environment variable "userid", defined +# by the user in the login.cl file. The output string is not terminated by a +# newline. + +procedure sysid (outstr, maxch) + +char outstr[maxch] # receives id string +int maxch + +pointer sp, buf +int op, nchars +int envfind(), gstrcpy() +long clktime() + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + nchars = envfind ("version", outstr, maxch) + if (nchars <= 0) + nchars = gstrcpy ("NOAO/IRAF", outstr, maxch) + + op = nchars + 1 + outstr[op] = ' ' + op = op + 1 + + # The variable "userid" is defined in the user's login.cl file. This + # gives the user the opportunity to set the value of this string to + # something other than their host system login name. + + nchars = envfind ("userid", Memc[buf], SZ_LINE) + + op = op + gstrcpy (Memc[buf], outstr[op], maxch-op+1) + outstr[op] = '@' + op = op + 1 + + call gethost (Memc[buf], SZ_LINE) + op = op + gstrcpy (Memc[buf], outstr[op], maxch-op+1) + outstr[op] = ' ' + op = op + 1 + + call cnvtime (clktime(long(0)), Memc[buf], SZ_LINE) + op = op + gstrcpy (Memc[buf], outstr[op], maxch-op+1) + outstr[op] = EOS + + call sfree (sp) +end diff --git a/sys/etc/syspanic.x b/sys/etc/syspanic.x new file mode 100644 index 00000000..8ddfdb81 --- /dev/null +++ b/sys/etc/syspanic.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# SYS_PANIC -- Unconditionally abort process execution. Called when an error +# condition occurs so serious that process execution cannot continue reliably. + +procedure sys_panic (errcode, errmsg) + +int errcode # error code +char errmsg[ARB] # error message + +begin + # Since process termination is imminent we may as well overwrite the + # error message string by packing it in place. + + call strpak (errmsg, errmsg, ARB) + call zpanic (errcode, errmsg) +end diff --git a/sys/etc/sysptime.x b/sys/etc/sysptime.x new file mode 100644 index 00000000..3a2657c2 --- /dev/null +++ b/sys/etc/sysptime.x @@ -0,0 +1,84 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +define SZ_OBUF 8 +define CPU 1 +define CLK 2 + + +# SYS_MTIME -- Mark the time, i.e., save the current clock and cpu times in +# the save buffer. + +procedure sys_mtime (save_time) + +long save_time[2] # mark time buffer + +begin + call zgtime (save_time[CLK], save_time[CPU]) +end + + +# SYS_PTIME -- Print the cpu and clock time consumed since the last call to +# SYS_MTIME. + +procedure sys_ptime (fd, opstr, save_time) + +int fd # output file +char opstr[ARB] # optional operand name string +long save_time[2] # mark time buffer + +int op, junk +char obuf[SZ_OBUF] +long new_clk, new_cpu +int d_clk, d_cpu, msec, sec, percent +int itoc() + +begin + call zgtime (new_clk, new_cpu) + d_clk = (new_clk - save_time[CLK]) # clk seconds + d_cpu = (new_cpu - save_time[CPU]) # cpu msec + + call putline (fd, "Time ") + if (opstr[1] != EOS) { + call putci (fd, '(') + call putline (fd, opstr) + call putline (fd, ") ") + } + + # Output the cpu time in seconds. + op = itoc (d_cpu / 1000, obuf, SZ_OBUF) + 1 + obuf[op] = '.'; op = op + 1 + msec = mod (d_cpu, 1000) + if (msec < 100) { + obuf[op] = '0'; op = op + 1 + } + if (msec < 10) { + obuf[op] = '0'; op = op + 1 + } + if (msec > 0) + op = op + itoc (msec, obuf[op], SZ_OBUF-op+1) + call putline (fd, obuf) + + # Output the clock time in minutes and seconds. + call putci (fd, ' ') + op = itoc (d_clk / 60, obuf, SZ_OBUF) + 1 + obuf[op] = ':'; op = op + 1 + sec = mod (d_clk, 60) + obuf[op] = TO_DIGIT(sec/10); op = op + 1 + obuf[op] = TO_DIGIT(mod(sec,10)); op = op + 1 + obuf[op] = EOS + call putline (fd, obuf) + + # Output the percent cpu utilization. + call putci (fd, ' ') + if (d_clk < 1) + call strcpy ("99", obuf, SZ_OBUF) + else { + percent = min (99, d_cpu / d_clk / 10) + junk = itoc (percent, obuf, SZ_OBUF) + } + + call putline (fd, obuf) + call putline (fd, "%\n") +end diff --git a/sys/etc/tsleep.x b/sys/etc/tsleep.x new file mode 100644 index 00000000..d1dbccb1 --- /dev/null +++ b/sys/etc/tsleep.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# TSLEEP -- Suspend execution of the calling task for the specified number +# of seconds. + +procedure tsleep (seconds) + +int seconds + +begin + if (seconds > 0) + call zwmsec (seconds * 1000) +end diff --git a/sys/etc/ttopen.x b/sys/etc/ttopen.x new file mode 100644 index 00000000..979d6f67 --- /dev/null +++ b/sys/etc/ttopen.x @@ -0,0 +1,96 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# TTOPEN -- Open a terminal for direct i/o. The logical device "dev$tty" +# denotes the user terminal. Note that this string is passed on to the +# kernel without modification, despite the apparent use of a logical directory. +# (See also fio$zfiott.x, the logical terminal driver). + +int procedure ttopen (terminal, mode) + +char terminal[ARB] # device to be opened +int mode + +int fopntx() +extern zopntt(), zgettt(), zputtt(), zflstt(), zstttt(), zclstt(), + zsektt(), znottt() + +begin + return (fopntx (terminal, mode, zopntt, zgettt, zputtt, zflstt, + zstttt, zclstt, zsektt, znottt)) +end + + +# TTSETI -- Set special terminal driver options. The regular FIO options +# are set using FSETI. + +procedure ttseti (fd, param, value) + +int fd # file descriptor +int param # parameter to be set +int value # new value + +int channel +int fstati() + +begin + channel = fstati (fd, F_CHANNEL) + call zsettt (channel, param, value) +end + + +# TTSTATI -- Stat special terminal driver options. + +int procedure ttstati (fd, param) + +int fd # file descriptor +int param # parameter to be set + +long lvalue +int channel +int fstati() + +begin + channel = fstati (fd, F_CHANNEL) + call zstttt (channel, param, lvalue) + return (lvalue) +end + + +# TTSETS -- Set special terminal driver option, type string. The regular FIO +# options are set using FSETI. + +procedure ttsets (fd, param, svalue) + +int fd # file descriptor +int param # parameter to be set +char svalue[ARB] # new string value + +int channel +int fstati() + +begin + channel = fstati (fd, F_CHANNEL) + call zsestt (channel, param, svalue) +end + + +# TTSTATS -- Stat special terminal driver options, type string. + +int procedure ttstats (fd, param, outstr, maxch) + +int fd # file descriptor +int param # parameter to be set +char outstr[maxch] # receives parameter value +int maxch + +int nchars +int channel +int fstati() + +begin + channel = fstati (fd, F_CHANNEL) + call zststt (channel, param, outstr, maxch, nchars) + return (nchars) +end diff --git a/sys/etc/urlget.x b/sys/etc/urlget.x new file mode 100644 index 00000000..23270fed --- /dev/null +++ b/sys/etc/urlget.x @@ -0,0 +1,384 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + + +# HTTP error codes we care about + +define HTTP_OK 200 # Success +define HTTP_CREATED 201 # Created +define HTTP_ACCEPTED 202 # Accepted +define HTTP_PARTIAL 203 # Partial Information +define HTTP_NORESP 204 # No Response + +define HTTP_MOVED 301 # Moved +define HTTP_FOUND 302 # Found +define HTTP_SEEOTHER 303 # Method +define HTTP_NOTMOD 304 # Not Modified + +define HTTP_BADREQ 400 # Bad Request +define HTTP_UNAUTH 401 # Unauthorized +define HTTP_PAYMENT 402 # Payment Required +define HTTP_FORBIDDEN 403 # Forbidden +define HTTP_NOTFOUND 404 # Not Found + +define HTTP_INTERR 500 # Internal Error +define HTTP_NOTIMP 501 # Not Implemented +define HTTP_OVERLOAD 502 # Service Temporarily Overloaded +define HTTP_GWTIMEOUT 503 # Gateway Timeout + +define SZ_BUF 8192 # download buffer + +define DBG_HDRS FALSE + + + +# URL_GET -- Do an HTTP GET on the given URL, save the results to the named +# file. If a 'reply' pointer is given, return the request reply string (must +# be allocated at least SZ_PATHNAME). + +int procedure url_get (url, fname, reply) + +char url[ARB] #i URL to access +char fname[ARB] #i local filename +pointer reply #u pointer to reply string + +char protocol[SZ_FNAME], host[SZ_FNAME], path[SZ_BUF], emsg[SZ_PATHNAME] +char inurl[SZ_PATHNAME], outname[SZ_PATHNAME] +int port, stat +pointer buf + +int url_access(), strcmp() +bool url_redirect() + +define redirect_ 99 + +begin + # Breakup the URL into usable pieces. + call strcpy (url, inurl, SZ_PATHNAME) +redirect_ + call url_break (inurl, protocol, host, port, path) + + # Check for a supported protocol. + if (strcmp (protocol, "http") != 0) { + call aclrc (emsg, SZ_PATHNAME) + call sprintf (emsg, SZ_PATHNAME, "Unsupported URI protocol (%s)") + call pargstr (protocol) + call error (0, emsg) + } + + # Download the file to the given name + call strcpy (fname, outname, SZ_PATHNAME) + + if (reply == NULL) { + call calloc (buf, SZ_LINE, TY_CHAR) + stat = url_access (host, port, path, outname, buf) + if (url_redirect (stat, buf, inurl)) { # check for a redirection + call mfree (buf, TY_CHAR) + goto redirect_ + } + call mfree (buf, TY_CHAR) + + } else { + stat = url_access (host, port, path, outname, reply) + if (url_redirect (stat, reply, inurl)) # check for a redirection + goto redirect_ + } + + # URL Error Codes are returned as negative values, positive values + # are the number of bytes read. We let the caller decode the return + # value, if desired, using the url_errcode() procedure. + + return (stat) +end + + +# URL_REDIRECT -- Check for a redirection reply code and modify the URL so +# we can try again. + +bool procedure url_redirect (stat, reply, url) + +int stat #i status code +pointer reply #i pointer to reply string +char url[ARB] #u access url + +int code, loc +pointer ip, op +char inurl[SZ_LINE] + +int strsearch() +bool streq() + +begin + code = - stat + + if (code == HTTP_MOVED || code == HTTP_FOUND || code == HTTP_SEEOTHER) { + loc = strsearch (Memc[reply], "Location:") + if (loc > 0) { + call aclrc (inurl, SZ_LINE) + call strcpy (url, inurl, SZ_LINE) + for (ip=reply+loc; IS_WHITE(Memc[ip]); ip=ip+1) + ; + for (op=1; Memc[ip] != '\n'; op=op+1) { + url[op] = Memc[ip] + ip = ip + 1 + } + url[op-1] = EOS + + if (streq (inurl, url)) + return (FALSE) + + return (TRUE) + } + } + + return (FALSE) +end + + +# URL_BREAK -- Break the URL into components needed to make the netpath. + +procedure url_break (url, protocol, host, port, path) + +char url[SZ_BUF] #i url to parse +char protocol[ARB] #o URL protocol (only HTTP, for now) +char host[ARB] #o host name +int port #o server port (if specified, or 80) +char path[ARB] #o path part of URL, including args + +int i, nch, ip +int ctoi() + +begin + port = 80 # set default port number + + # Pull out the protocol part of the URL. + for (ip=1; url[ip] != ':'; ip = ip + 1) + protocol[ip] = url[ip] + protocol[ip] = '\0' + + # Skip the "://" separator. + while (url[ip] == ':' || url[ip] == '/') + ip = ip + 1 + + # Get the host name. + for (i=1; url[ip] != ':' && url[ip] != '/' && url[ip] != EOS; i=i+1) { + host[i] = url[ip] + ip = ip + 1 + } + host[i] = '\0' + + if (url[ip] == EOS) { + call strcpy ("/", path, 2) + return + } + + # Extract a port number of specified + if (url[ip] == ':') { + ip = ip + 1 + nch = ctoi (url, ip, port) + } + + # Get the remaining path. + for (i=1; url[ip] != EOS; i = i + 1) { + path[i] = url[ip] + ip = ip + 1 + } + path[i] = '\0' +end + + +# URL_ACCESS -- Do an HTTP GET of a resource to the named file. + +int procedure url_access (host, port, path, fname, reply) + +char host[ARB] #i host name +int port #i server port number +char path[ARB] #i resource path +char fname[ARB] #i saved file path +pointer reply #i reply buffer + +pointer rep +int in, out, nchars, totchars, retcode, clen, ip +char buf[SZ_BUF], netpath[SZ_PATHNAME], request[SZ_BUF], hd[SZ_PATHNAME] +bool done + +int open(), access(), ndopen(), getline(), read(), strlen(), ctoi() +int strncmp(), url_retcode() + +begin + # Connect to server on the given host. + call sprintf (netpath, SZ_PATHNAME, "inet:%d:%s:%s") + call pargi (port) + call pargstr (host) + call pargstr ("text") + + iferr (in = ndopen (netpath, READ_WRITE)) { + call eprintf ("cannot access host '%s:%d'\n") + call pargstr (host) + call pargi (port) + return (- HTTP_NOTFOUND) + } + + # Format the request header. + call aclrc (request, SZ_BUF) + call sprintf (request, SZ_BUF, "GET %s HTTP/1.0\n") + call pargstr (path) + call strcat ("Accept: */*\n", request, SZ_BUF) + call strcat ("User-Agent: IRAF/urlget\n", request, SZ_BUF) + call strcat ("Host: ", request, SZ_BUF) + call strcat ( host, request, SZ_BUF) + call strcat ("\n", request, SZ_BUF) + call strcat ("Connection: keep-alive\n\n", request, SZ_BUF) + + # Send the GET-url request to the server. + nchars = strlen (request) + call write (in, request, nchars) + call flush (in) + call fseti (in, F_CANCEL, OK) + + if (DBG_HDRS) { + call eprintf ("request [%d]:\n%s\n") + call pargi (nchars) + call pargstr (request) + } + + # Read the reply. Read the HTTP header assuming it ends with a \n or + # a \r\n. and then validate it will return the request correctly. + done = false + clen = -1 + call calloc (rep, SZ_PATHNAME, TY_CHAR) + repeat { + call aclrc (hd, SZ_PATHNAME) + nchars = getline (in, hd) + if (nchars <= 0) + break + call strcat (hd, Memc[rep], SZ_PATHNAME) + if (strncmp (hd, "Content-Length:", 15) == 0) { + ip = 16 + nchars = ctoi (hd, ip, clen) + } + } until ((hd[1] == '\r' && hd[2] == '\n') || (hd[1] == '\n')) + + if (DBG_HDRS) { + call eprintf ("reply: %s\nclen = %d\n") + call pargstr (Memc[rep]) + call pargi(clen) + } + + # Make sure we have a valid file. + retcode = url_retcode (Memc[rep]) + + if (reply != NULL) + call strcpy (Memc[rep], Memc[reply], SZ_PATHNAME) + call mfree (rep, TY_CHAR) + if (retcode != HTTP_OK) + return (- retcode) + + + # Open the named output file. + if (access (fname, 0, 0) == YES) + call syserrs (SYS_FCLOBBER, fname) + iferr (out = open (fname, NEW_FILE, TEXT_FILE)) + call syserrs (SYS_FOPEN, fname) + + # Now read the resource and save it to the named file. + totchars = 0 + done = false + repeat { + call aclrc (buf, SZ_BUF) + nchars = read (in, buf, SZ_BUF) + if (nchars > 0) { + call write (out, buf, nchars) + call flush (out) + totchars = totchars + nchars + done = false + } else + done = true + + if (clen > 0 && totchars >= clen) + break + } until (done) + + call close (in) # clean up + call close (out) + + return (totchars) # return number of chars read +end + + +# URL_RETCODE -- Get the return code from the HTTP header reply. + +int procedure url_retcode (reply) + +char reply[ARB] #i reply string + +int ip, len, code, ctoi() + +begin + for (ip=1; !IS_WHITE(reply[ip]); ip=ip+1) + ; + len = ctoi (reply, ip, code) + + return (code) +end + + +# URL_ERRCODE - Convert between an HTTP return code and the equivalent +# syserr() code value. + +int procedure url_errcode (code) + +int code #i http return code + +begin + # Note: Not all error codes are implemented in syserr. In this + # case we just return the input code. + + switch (code) { + case HTTP_OK: # Success + ; + case HTTP_CREATED: # Created + ; + case HTTP_ACCEPTED: # Accepted + ; + case HTTP_PARTIAL: # Partial Information + ; + case HTTP_NORESP: # No Response + ; + + case HTTP_MOVED: # Moved + return (SYS_URLREDIRECT); + case HTTP_FOUND: # Found + return (SYS_URLREDIRECT); + case HTTP_SEEOTHER: # See Other + return (SYS_URLREDIRECT); + case HTTP_NOTMOD: # Not Modified + ; + + case HTTP_BADREQ: # Bad Request + return (SYS_URLBADREQUEST) + case HTTP_UNAUTH: # Unauthorized + ; + case HTTP_PAYMENT: # Payment Required + ; + case HTTP_FORBIDDEN: # Forbidden + return (SYS_URLFORBIDDEN) + case HTTP_NOTFOUND: # Not Found + return (SYS_URLNOTFOUND) + + case HTTP_INTERR: # Internal Error + return (SYS_URLINTERROR) + case HTTP_NOTIMP: # Not Implemented + ; + case HTTP_OVERLOAD: # Service Temporarily Overloaded + ; + case HTTP_GWTIMEOUT: # Gateway Timeout + ; + } + + return (code) +end diff --git a/sys/etc/votable.x b/sys/etc/votable.x new file mode 100644 index 00000000..ec931030 --- /dev/null +++ b/sys/etc/votable.x @@ -0,0 +1,304 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + + +# VOTABLE.X -- Utility procedures for dealing with VOTables. + + +# VOTINIT -- Initialize the VOT struct, parse the document and save the +# summary. We return the VOT struct pointer itself, the caller is +# responsible for accessing the VOT_ROOT to get the raw root handle + +pointer procedure votinit (votable) + +char votable[ARB] #i VOTable file name + +pointer vot, vot_handle + +# Declare the libVOTable functions we'll be using. +int vx_openVOTABLE(), vx_getRESOURCE(), vx_getTABLE(), vx_getDATA() +int vx_getTABLEDATA(), vx_getFIELD(), vx_getINFO(), vx_getPARAM() +int vx_getNCols(), vx_getNRows(), vx_getLength() + +begin + # Allocate the structure. + call calloc (vot, SZ_VOT_STRUCT, TY_STRUCT) + + # Open and parse the votable. + vot_handle = vx_openVOTABLE (votable) + if (vot_handle <= 0) { + call eprintf ("Cannot open file: '%s'\n") + call pargstr (votable) + return (NULL) + } + VOT_ROOT(vot) = vot_handle + + # Now get various handles from the table. + VOT_RES(vot) = vx_getRESOURCE (vot_handle) + VOT_TAB(vot) = vx_getTABLE (VOT_RES(vot)) + VOT_DATA(vot) = vx_getDATA (VOT_TAB(vot)) + VOT_TDATA(vot) = vx_getTABLEDATA (VOT_DATA(vot)) + + VOT_INFO(vot) = vx_getINFO (VOT_RES(vot)) + VOT_PARAM(vot) = vx_getPARAM (VOT_RES(vot)) + VOT_FIELD(vot) = vx_getFIELD (VOT_TAB(vot)) + + VOT_NRES(vot) = vx_getLength (VOT_RES(vot)) + VOT_NCOLS(vot) = vx_getNCols (VOT_TDATA(vot)) + VOT_NROWS(vot) = vx_getNRows (VOT_TDATA(vot)) + + return (vot) # return the struct pointer +end + + +# VOTCLOSE -- Close the VOT struct and free any resources. + +procedure votclose (vot) + +pointer vot #i VOT struct pointer + +begin + call vx_closeVOTABLE (VOT_ROOT(vot)) + call mfree (vot, TY_STRUCT) +end + +# IS_VOTABLE -- Utility routine to determine if the named file is a VOTable +# XML document. + +define VOT_MAXLINES 10 + +bool procedure is_votable (fname) + +char fname[ARB] #i local filename + +int i, fd, nchars +bool stat +char buf[SZ_LINE] + +int open (), access (), getline (), strsearch () + +begin + stat = FALSE + + if (access (fname, 0, 0) == NO) + return (stat) + + iferr { + fd = open (fname, READ_ONLY, TEXT_FILE) + + # Look for a "" element in the first 10 lines of the file. + for (i=0; i < VOT_MAXLINES; i = i + 1) { + call aclrc (buf, SZ_LINE) + nchars = getline (fd, buf) + if (nchars == EOF) + break + + call strupr (buf) + if (strsearch (buf, " 0) + stat = TRUE + } + call close (fd) + } then + stat = FALSE + + return (stat) +end + + +# VOT_CONVERT -- Convert a VOTable to some other format. + +define VOT_FMTS "|ascii|asv|bsv|csv|tsv|html|shtml|fits|xml|raw|votable" + +define ASCII 1 # ascii separated values +define ASV 2 # ascii separated values +define BSV 3 # bar separated values +define CSV 4 # comma separated values +define TSV 5 # tab separated values +define HTML 6 # standalone HTML document +define SHTML 7 # single HTML element +define FITS 8 # FITS binary table +define XML 9 # VOTable alias +define RAW 10 # " " +define VOTBL 11 # " " + +int procedure vot_convert (in, out, fmt) + +char in[ARB] #i VOTable file name +char out[ARB] #i FITS bintable file name +char fmt[ARB] #i format name + +pointer sp, nodename, buf +char osfn[SZ_PATHNAME], cnvname[SZ_PATHNAME], format[SZ_LINE] +int vfd, status, ip, opt, delim, infile, outfile + +int vfnopen(), vfnmapu(), access(), ki_gnode(), strdic(), strncmp() +int open(), getline() +bool streq() + +begin + call smark (sp) + call salloc (nodename, SZ_FNAME, TY_CHAR) + call salloc (buf, SZ_LINE, TY_CHAR) + + + # Map input VFN to OSFN. + ip = 1 + if (strncmp (in, "http://", 7) == 0) { + call strcpy (in, osfn, SZ_PATHNAME) + } else { + vfd = vfnopen (in, READ_ONLY) + status = vfnmapu (vfd, osfn, SZ_PATHNAME) + call vfnclose (vfd, VFN_NOUPDATE) + + # If the file resides on the local node strip the node name, + # returning a legal host system filename as the result. + if (ki_gnode (osfn, Memc[nodename], delim) == 0) + ip = delim + 1 + } + + # Create a tempfile name for the converted output file. + call mktemp ("/tmp/vo", cnvname, SZ_PATHNAME) + call strcat (".", cnvname, SZ_PATHNAME) + call strcat (fmt, cnvname, SZ_PATHNAME) + + + # Validate the format. + opt = strdic (fmt, format, SZ_LINE, VOT_FMTS) + if (opt == 0) { + call eprintf ("Invalid output format '%s'\n") + call pargstr (fmt) + call sfree (sp) + return (ERR) + } + if (opt == VOTBL || opt == XML || opt == RAW) + call strcpy ("vot", format, SZ_FNAME) + if (opt == ASCII) + call strcpy ("asv", format, SZ_FNAME) + + + # Convert the file from VOTable to FITS bintable. + call vx_vocopy (5, "-f", format, "-o", cnvname, osfn[ip]) + + if (access (cnvname,0,0) == NO) { + call eprintf ("Cannot convert %s to '%s'\n") + call pargstr (osfn[ip]) + call pargstr (fmt) + return (ERR) + } + + # Delete the downloaded XML file, copy the bintable into its + # place and delete the converted output filename. + if (streq (in, out)) + call delete (in) + + + # Copy converted file to output file. Works for STDOUT/STDERR as + # well. + infile = open (cnvname, READ_ONLY, TEXT_FILE) + outfile = open (out, NEW_FILE, TEXT_FILE) + + while (getline (infile, Memc[buf]) != EOF) + call putline (outfile, Memc[buf]) + + call close (infile) + call close (outfile) + + call delete (cnvname) # delete the temporary converted file + call sfree (sp) + return (OK) +end + + +# VOT_TO_FITS -- Convert a VOTable to a FITS bintable. + +int procedure vot_to_fits (in, out) + +char in[ARB] #i VOTable file name +char out[ARB] #i FITS bintable file name + +pointer sp, nodename +char osfn[SZ_PATHNAME], cnvname[SZ_PATHNAME] +int vfd, status, ip, delim + +int vfnopen(), vfnmapu(), access(), ki_gnode() +bool streq() + +begin + call smark (sp) + call salloc (nodename, SZ_FNAME, TY_CHAR) + + # Map input VFN to OSFN. + vfd = vfnopen (in, READ_ONLY) + status = vfnmapu (vfd, osfn, SZ_PATHNAME) + call vfnclose (vfd, VFN_NOUPDATE) + + # If the file resides on the local node strip the node name, + # returning a legal host system filename as the result. + if (ki_gnode (osfn, Memc[nodename], delim) == 0) + ip = delim + 1 + else + ip = 1 + + + # Create a tempfile name for the converted output file. + call mktemp ("/tmp/vo", cnvname, SZ_PATHNAME) + call strcat (".fits", cnvname, SZ_PATHNAME) + + # Convert the file from VOTable to FITS bintable. + call vx_vocopy (5, "-f", "fits", "-o", cnvname, osfn[ip]) + + if (access (cnvname,0,0) == NO) + return (ERR) + + # Delete the downloaded XML file, copy the bintable into its + # place and delete the converted output filename. + if (streq (in, out)) + call delete (in) + + call fcopy (cnvname, out) # copy converted file to output file + call delete (cnvname) # delete the temporary converted file + + call sfree (sp) + + return (OK) +end + + +# VOT_FROM_FITS -- Convert from a FITS bintable to a VOTable. + +int procedure vot_from_fits (in, out) + +char in[ARB] #i FITS bintable file name +char out[ARB] #i VOTable file name + +char osfn[SZ_PATHNAME], cnvname[SZ_PATHNAME] +int vfd, status + +int vfnopen(), vfnmapu() +bool streq() + +begin + # Map input VFN to OSFN. + vfd = vfnopen (in, READ_ONLY) + status = vfnmapu (vfd, osfn, SZ_PATHNAME) + call vfnclose (vfd, VFN_NOUPDATE) + + # Create a tempfile name for the converted output file. + call mktemp ("/tmp/vo", cnvname, SZ_PATHNAME) + call strcat (".xml", cnvname, SZ_PATHNAME) + + # Convert the file from VOTable to FITS bintable. + call vx_vocopy (5, "-f", "votable", "-o", cnvname, osfn) + + # Delete the downloaded XML file, copy the bintable into its + # place and delete the converted output filename. + if (streq (in, out)) + call delete (in) + + call fcopy (cnvname, out) # copy converted file to output file + call delete (cnvname) # delete the temporary converted file + + return (OK) +end diff --git a/sys/etc/xalloc.x b/sys/etc/xalloc.x new file mode 100644 index 00000000..63be577a --- /dev/null +++ b/sys/etc/xalloc.x @@ -0,0 +1,197 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +.helpsys xalloc +.nf _________________________________________________________________________ +XALLOC -- Device allocation package. + + xallocate (device) + xdeallocate (device, rewind) + xdevowner (device, owner, maxch) + xdevstatus (device, out) + xgdevlist (device, devlist, maxch, onedev) + +status: + + DV_DEVFREE device is free and can be allocated + DV_DEVALLOC device is already allocated + DV_DEVINUSE device is in use by someone else + DV_DEVNOTFOUND device is not in device table + +The allocatable devices are defined in the text file dev$tapecap. +.endhelp ____________________________________________________________________ + +define SZ_DEVLIST 256 +define ALLOCATE 1 +define DEALLOCATE 0 + + +# XALLOCATE -- Attempt to allocate the named device, i.e., allocate the device +# for exclusive i/o, and ready it for i/o following some sort of OPEN call. +# Allocate performs the function called "mount" on some systems, as well as +# allocating the device. + +int procedure xallocate (device) + +char device[ARB] #I device to be allocated + +pointer sp, devlist +int status, onedev +int xgdevlist(), mtfile() +errchk xgdevlist, mtallocate +define done_ 91 + +begin + call smark (sp) + call salloc (devlist, SZ_DEVLIST, TY_CHAR) + + # Fetch the device list for the named device. + onedev = NO + status = xgdevlist (device, Memc[devlist], SZ_DEVLIST, onedev) + if (status != OK) + goto done_ + + # Attempt to allocate the device at the host system level. + call strpak (Memc[devlist], Memc[devlist], SZ_DEVLIST) + call zdvall (Memc[devlist], ALLOCATE, status) + + # If that worked and the device is a magtape, call MTIO to complete + # the allocation process. + + if (status == OK && mtfile (device) == YES) + call mtallocate (device) +done_ + call sfree (sp) + return (status) +end + + +# XDEALLOCATE -- Deallocate the named device. + +int procedure xdeallocate (device, rewind) + +char device[ARB] #I device to be deallocated +int rewind #I rewind if magtape? + +int status, onedev +pointer sp, devlist, osdev, owner +int xgdevlist(), mtfile() +errchk xgdevlist, syserrs +define done_ 91 + +begin + call smark (sp) + call salloc (devlist, SZ_DEVLIST, TY_CHAR) + call salloc (osdev, SZ_FNAME, TY_CHAR) + call salloc (owner, SZ_FNAME, TY_CHAR) + + # Get the i/o device name. + onedev = YES + status = xgdevlist (device, Memc[osdev], SZ_FNAME, onedev) + if (status != OK) + goto done_ + + # Verify that the device is actually allocated. If the device is a + # magtape, call MTIO to conditionally rewind the drive and deallocate + # the drive in MTIO. + + call strpak (Memc[osdev], Memc[osdev], SZ_FNAME) + call zdvown (Memc[osdev], Memc[owner], SZ_FNAME, status) + if (status != DV_DEVALLOC) + call syserrs (SYS_MTNOTALLOC, device) + else if (mtfile (device) == YES) + call mtdeallocate (device, rewind) + + # Fetch the device list for the named device. + onedev = NO + status = xgdevlist (device, Memc[devlist], SZ_DEVLIST, onedev) + if (status != OK) + goto done_ + + # Physically deallocate the device. + call strpak (Memc[devlist], Memc[devlist], SZ_DEVLIST) + call zdvall (Memc[devlist], DEALLOCATE, status) +done_ + call sfree (sp) + return (status) +end + + +# XDEVSTATUS -- Print the status of the named device on the output file. + +procedure xdevstatus (device, out) + +char device[ARB] #I device +int out #I output file + +int status +char owner[SZ_FNAME] +int xdevowner(), mtfile() +errchk xdevowner, mtfile + +begin + status = xdevowner (device, owner, SZ_FNAME) + + switch (status) { + case DV_DEVFREE: + call fprintf (out, "device %s is not currently allocated\n") + call pargstr (device) + if (mtfile (device) == YES) + iferr (call mtstatus (out, device)) + ; + case DV_DEVINUSE: + call fprintf (out, "device %s is currently allocated to %s\n") + call pargstr (device) + call pargstr (owner) + case DV_DEVALLOC: + if (mtfile (device) == YES) + call mtstatus (out, device) + else { + call fprintf (out, "device %s is allocated\n") + call pargstr (device) + } + default: + call fprintf (out, "cannot get device status for `%s'\n") + call pargstr (device) + } +end + + +# XDEVOWNER -- Determine whether or not the named device is already +# allocated, and if the device is currently allocated to someone else, +# return the owner name. + +int procedure xdevowner (device, owner, maxch) + +char device[ARB] #I device to be deallocated +char owner[maxch] #O receives owner name +int maxch #I max chars out + +pointer sp, devlist +int status, onedev +int xgdevlist() +errchk xgdevlist +define done_ 91 + +begin + call smark (sp) + call salloc (devlist, SZ_DEVLIST, TY_CHAR) + + # Fetch the device list for the named device. + onedev = YES + status = xgdevlist (device, Memc[devlist], SZ_DEVLIST, onedev) + if (status != OK) + goto done_ + + # Query device allocation. + call strpak (Memc[devlist], Memc[devlist], SZ_DEVLIST) + call zdvown (Memc[devlist], owner, maxch, status) + call strupk (owner, owner, maxch) +done_ + call sfree (sp) + return (status) +end diff --git a/sys/etc/xerfmt.x b/sys/etc/xerfmt.x new file mode 100644 index 00000000..596e6ce5 --- /dev/null +++ b/sys/etc/xerfmt.x @@ -0,0 +1,96 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# XER_FMTERRMSG -- Expand error message encoded as "123 user_string" into +# a full error message by looking the error message string up in lib$syserrmsg. +# If the first character of ERRMSG is nonnumeric no processing is done. +# The conversion may be performed in place, i.e., errmsg and outstr may be +# the same array. + +procedure xer_fmterrmsg (errmsg, outstr, maxch) + +char errmsg[ARB] # encoded error message. +char outstr[maxch] # output string +int maxch + +char buf[SZ_LINE], user_string[SZ_FNAME] +int codelen, nchars, chan, ip, op, junk +int strncmp(), envfind(), gstrcpy() +define nofile_ 91 + +begin + # Determine ndigits in error code. + for (ip=1; IS_DIGIT (errmsg[ip]); ip=ip+1) + ; + codelen = ip - 1 + + # Output message as is if no error code. Copy into local buf first + # in case errmsg and outstr overlap. + + if (codelen == 0) { + call strcpy (errmsg, buf, SZ_LINE) + call strcpy (buf, outstr, maxch) + return + } + + # Extract the user string into a local buffer. + while (IS_WHITE (errmsg[ip])) + ip = ip + 1 + for (op=1; errmsg[ip] != EOS && errmsg[ip] != '\n'; ip=ip+1) { + user_string[op] = errmsg[ip] + op = op + 1 + } + user_string[op] = EOS + + # Generate the OS pathname of the "lib$syserrmsg" file. + if (envfind ("iraf", buf, SZ_LINE) > 0) { + call zfsubd (buf, SZ_LINE, "lib", nchars) + call strcat ("syserrmsg", buf, SZ_LINE) + call strpak (buf, buf, SZ_LINE) + } else + goto nofile_ + + # Open and search the system error message file. + call zopntx (buf, READ_ONLY, chan) + if (chan == ERR) + goto nofile_ + + repeat { + call zgettx (chan, buf, SZ_LINE, nchars) + if (nchars == 0 || nchars == ERR) { + call zclstx (chan, junk) + goto nofile_ + } else if (strncmp (buf, errmsg, codelen) == 0) { + call zclstx (chan, junk) + break + } + } + + # Skip the error code prefix and the blank which follows. + for (ip=codelen+1; IS_WHITE(buf[ip]); ip=ip+1) + ; + + # Output system error message. + for (op=1; buf[ip] != '\n' && buf[ip] != EOS; ip=ip+1) { + outstr[op] = buf[ip] + op = op + 1 + } + + # Add user operand, if supplied, enclosed in parens. + if (user_string[1] != EOS) { + outstr[op] = ' ' + outstr[op+1] = '(' + op = op + 2 + op = op + gstrcpy (user_string, outstr[op], maxch-op+1) + outstr[op] = ')' + op = op + 1 + } + + outstr[op] = EOS + return + +nofile_ + call strcpy (errmsg, buf, SZ_LINE) + call strcpy (buf, outstr, maxch) +end diff --git a/sys/etc/xerpop.x b/sys/etc/xerpop.x new file mode 100644 index 00000000..a4723508 --- /dev/null +++ b/sys/etc/xerpop.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# XERPSH -- Push an error handler on the error "stack". All we really need +# do is keep track of the number of nested handlers. If an error condition +# already exists when we are called, an error has occurred which was not +# caught, probably because of a missing errchk declaration. + +procedure xerpsh() + +include "error.com" + +begin + if (xerflg) # error not caught + call erract (EA_FATAL) + nhandlers = nhandlers + 1 + xercod = OK +end + + +# XERPOP -- Pop an error handler, and return the error status flag (true if +# an error occurred). + +bool procedure xerpop() + +bool error_status +include "error.com" + +begin + nhandlers = nhandlers - 1 + error_status = xerflg + xerflg = false + + return (error_status) +end + + +# XERPOPI -- Integer version of XERPOP. + +int procedure xerpopi() + +bool error_status +include "error.com" + +begin + nhandlers = nhandlers - 1 + error_status = xerflg + xerflg = false + + if (error_status) + return (1) + else + return (0) +end diff --git a/sys/etc/xerpue.x b/sys/etc/xerpue.x new file mode 100644 index 00000000..9cc995ee --- /dev/null +++ b/sys/etc/xerpue.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# XER_PUTLINE -- Put a line to the output file (STDERR), using only low level +# routines. It is important to use run time indirection through the device +# table here, to avoid linking the entire IPC and KI into non-IRAF programs +# that use error handlers, e.g., HSI or IMFORT programs. + +procedure xer_putline (fd, text) + +int fd +char text[ARB] + +long offset +int nchars, junk +int strlen() +include + +begin + nchars = strlen (text) + fp = fiodes[fd] + + if (FTYPE(fp) == BINARY_FILE) { + offset = 0 + call zcall4 (ZAWRBF(fp), FCHAN(fp), text, nchars * SZB_CHAR, offset) + call zcall2 (ZAWTBF(fp), FCHAN(fp), junk) + } else + call zcall4 (ZPUTTX(fp), FCHAN(fp), text, nchars, junk) +end diff --git a/sys/etc/xerreset.x b/sys/etc/xerreset.x new file mode 100644 index 00000000..773e38f9 --- /dev/null +++ b/sys/etc/xerreset.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# XER_RESET -- Called to initialize error handling. Used during startup and +# during error recovery (e.g. in an interrupt handler) to reset the state of +# the error handling code. + +procedure xer_reset() + +include "error.com" + +begin + xerflg = false + xercod = OK + err_restart = NO + nhandlers = 0 + xermsg[1] = EOS +end diff --git a/sys/etc/xerstmt.x b/sys/etc/xerstmt.x new file mode 100644 index 00000000..0a28167b --- /dev/null +++ b/sys/etc/xerstmt.x @@ -0,0 +1,66 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +define SZ_NUMBUF 6 + +# XERSTMT -- Format and issue an error statement to the CL. Note that this is +# a command issued to the CL, not a line written to STDERR. The error code and +# error message string output were posted in the last call to ERROR or FATAL. +# +# Example: ERROR (501, "Access Violation") +# +# The actual concatentation and transmission of the error message is carried +# out by the primitive XERPUTC, rather than by PUTLINE and PUTC calls to CLOUT, +# to avoid recursion in the FIO routines, probably leading to error recursion. + +procedure xer_send_error_statement_to_cl (errcode) + +int errcode +char numbuf[SZ_NUMBUF] +int ip, junk, itoc() +include "error.com" + +begin + # The error code is passed as an argument rather than taken from the + # xercom common because XERPOP clears the error code before we are + # called by the IRAF Main. + + junk = itoc (errcode, numbuf, SZ_NUMBUF) + + # Format the ERROR statement and sent it to the CL. + + call xerpstr ("ERROR (") + call xerpstr (numbuf) + call xerpstr (", \"") + + # Output error message string, omitting characters like newline or + # quote which could cause syntax problems. + + for (ip=1; xermsg[ip] != EOS; ip=ip+1) + if (IS_PRINT (xermsg[ip]) && xermsg[ip] != '"') + call xerputc (xermsg[ip]) + + # Ring terminal bell if unexpected error (anything other than + # a keyboard interrupt). + + if (xercod != SYS_XINT) + call xerpstr ("\7") + call xerpstr ("\")\n") +end + + +# XERPSTR -- Put a string to the CL (special routine, to avoid recursion). +# Use PUTLINE in normal code. + +procedure xerpstr (str) + +char str[ARB] +int ip + +begin + for (ip=1; str[ip] != EOS; ip=ip+1) + call xerputc (str[ip]) +end diff --git a/sys/etc/xerverify.x b/sys/etc/xerverify.x new file mode 100644 index 00000000..dfb4e88a --- /dev/null +++ b/sys/etc/xerverify.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# XER_VERIFY -- The following procedure is called by the iraf main after +# a task completes, to verify that NHANDLERS is zero, indicating that an XERPOP +# was executed for each XERPSH. Note that a transfer out of an IFERR block +# (a programming error) could prevent XERPOP from being called. + +procedure xer_verify() + +include "error.com" + +begin + if (xerflg) + call erract (EA_FATAL) + if (nhandlers != 0) { + nhandlers = 0 + call putline (STDERR, "Warning: Transfer out of IFERR block\n") + } +end diff --git a/sys/etc/xgdevlist.x b/sys/etc/xgdevlist.x new file mode 100644 index 00000000..d20b68a9 --- /dev/null +++ b/sys/etc/xgdevlist.x @@ -0,0 +1,49 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# XGDEVLIST -- Fetch the allocation string for the named logical device from +# the device table (tapecap file). DV_DEVNOTFOUND is returned there is no +# entry in the device table for the device. An error action is taken if there +# is any problem reading the device entry. +# +# This routine is a bit of an anachronism in the days of tapecap, but is +# left pretty much as it was originally to minimize code modifications. +# In principle the allocation code can be used to allocate any device, not +# just tape drives. This is still the case, given an entry for the device +# in the tapecap file. + +int procedure xgdevlist (device, outstr, maxch, onedev) + +char device[ARB] #I logical device name +char outstr[maxch] #O receives device list +int maxch #I max chars out +int onedev #I return i/o device instead? + +pointer gty +int nchars +pointer mtcap() +int gtygets(), strlen() +errchk syserrs + +begin + # Fetch the tapecap entry for the named device. Do not close the GTY + # descriptor. mtcap always keeps the last one in an internal cache. + + iferr (gty = mtcap (device)) + return (DV_DEVNOTFOUND) + + if (onedev == YES) + nchars = gtygets (gty, "dv", outstr, maxch) + else + nchars = gtygets (gty, "al", outstr, maxch) + + call ki_xnode (device, outstr, maxch) + nchars = strlen (outstr) + + if (nchars <= 0) + call syserrs (SYS_MTTAPECAP, device) + + return (OK) +end diff --git a/sys/etc/xisatty.x b/sys/etc/xisatty.x new file mode 100644 index 00000000..177bec67 --- /dev/null +++ b/sys/etc/xisatty.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# XISATTY -- Test if the given file is a terminal. + +int procedure xisatty (fd) + +int fd # file descriptor of candidate device +int epa, epa_tt, epa_ty +extern zgettt(), zgetty() +int fstati(), clstati() + +begin + # If we are a connected subprocess, the referenced file is a standard + # stream, and i/o has not been redirected, assume that the file behaves + # as a terminal. + + if (clstati(CL_PRTYPE) == PR_CONNECTED) + if (fd == STDIN || fd == STDOUT || fd == STDERR) + if (fstati (fd, F_REDIR) == NO) + return (YES) + else + return (NO) + + # Otherwise, the use of the terminal driver tells us if the file is + # open on a terminal device. + + epa = fstati (fd, F_DEVICE) + call zlocpr (zgettt, epa_tt) + call zlocpr (zgetty, epa_ty) + + if (epa == epa_tt || epa == epa_ty) + return (YES) + else + return (NO) +end diff --git a/sys/etc/xmjbuf.x b/sys/etc/xmjbuf.x new file mode 100644 index 00000000..45585060 --- /dev/null +++ b/sys/etc/xmjbuf.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# XMJBUF -- Return a char pointer to the IRAF main interpreter context restart +# buffer (for ZDOJMP restarts). + +procedure xmjbuf (bp) + +pointer bp #O pointer to jumpbuf + +int a_jb, a_mem +int jumpbuf[LEN_JUMPBUF] +common /JUMPCOM/ jumpbuf + +begin + call zlocva (jumpbuf[1], a_jb) + call zlocva (Memc, a_mem) + bp = a_jb - a_mem + 1 +end diff --git a/sys/etc/xttysize.x b/sys/etc/xttysize.x new file mode 100644 index 00000000..4c95056e --- /dev/null +++ b/sys/etc/xttysize.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# XTTYSIZE -- Query the size of the terminal screen in characters. This is +# different than simply reading the screen size from the environment or from +# termcap, because the screen size will be queried at runtime if the terminal +# has a screen which can change size at runtime. Note that when this routine +# is called, the variables ttyncols and ttynlines are updated in the IRAF +# environment, allowing ordinary envgeti calls to be used thereafter to query +# the screen size. The XTTYSIZE routine should not be called all over the +# place, because it may involve i/o to the terminal. + +procedure xttysize (width, height) + +int width # width of screen (out) +int height # height of screen (out) + +int junk, i +pointer sp, buf, tty +pointer ttyodes() +int clstati(), getline(), envgeti(), envscan() +errchk clcmd, getline, envgeti, ttyodes + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + # If we are a connected subprocess it is difficult to write directly + # to the terminal, since the terminal is opened by the CL. Hence we + # have the CL run the STTY task instead to reset the screen size + # parameters in the environment. If we are not a connected subprocess + # we query the terminal size directly, assuming that the terminal is + # opened on the process standard input and output. + + if (clstati (CL_PRTYPE) == PR_CONNECTED) { + call clcmd ("stty resize") + do i = 1, 2 + if (getline (CLIN, Memc[buf]) != EOF) + junk = envscan (Memc[buf]) + width = envgeti ("ttyncols") + height = envgeti ("ttynlines") + + } else { + tty = ttyodes ("terminal") + call ttygsize (STDIN, STDOUT, tty, width, height) + call ttycdes (tty) + } + + call sfree (sp) +end diff --git a/sys/etc/xwhen.x b/sys/etc/xwhen.x new file mode 100644 index 00000000..948eca8f --- /dev/null +++ b/sys/etc/xwhen.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# XWHEN -- Post an exception handler. + +procedure xwhen (signal, handler, old_handler) + +int signal # signal to be caught +int handler # epa of user supplied exception handler +int old_handler # epa of old handler, if any + +begin + call zxwhen (signal, handler, old_handler) +end diff --git a/sys/etc/zzdebug.x b/sys/etc/zzdebug.x new file mode 100644 index 00000000..05324872 --- /dev/null +++ b/sys/etc/zzdebug.x @@ -0,0 +1,404 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# Debug the ENVIRON environment list package. The following definitions are +# from the header of "environ.x" and are used by envdebug to examine the +# environment list data structures; these should be compared to the defs in +# environ.x to make sure they agree. Use of a header file is not warranted +# since we really do not want the environ.x data structures known outside +# the package. + +task get = t_get, + put = t_put, + list = t_list, + mark = t_mark, + free = t_free, + debug = t_debug, + spawn = t_spawn, + edit = t_edit, + tty = t_tty, + urlget = t_urlget + + +# Strings may optionally be quoted in SET stmts with either ' or ". +define IS_QUOTE ($1 == '\'' || $1 == '"') + +# Size limiting definitions. + +define NTHREADS 100 # number of hash threads +define HASH_FACTOR 1637 # divisor for hash function +define NHASHCHARS 6 # no. chars used for hashing +define LEN_ENVBUF 1500 # storage for environment list +define INC_ENVBUF 500 # increment if overflow occurs +define MAX_SZKEY 32 # max chars in a key +define MAX_SZVALUE 80 # max chars in value string +define MAX_LENLISTELEM (3+(MAX_SZKEY+1+MAX_SZVALUE+1+SZ_SHORT-1)/SZ_SHORT) + +# List element structure, stored in ENVBUF, which is allocated as an array of +# type SHORT integer. Each list element is aligned on a short integer boundary +# within the array. E_NEXT points to the next element in a thread, whereas +# E_LASTELEM points to the last element in the envbuf (which is a stack). + +define E_NEXT Mems[$1] # next element in thread (list) +define E_LASTELEM Mems[$1+1] # next element in envbuf +define E_REDEF Mems[$1+2] # set if element is redefined +define E_SETP P2C($1+3) # char pointer to name field +define E_SET Memc[E_SETP($1)] # "name=value" string +define E_SETOFFSET 3 + + +# GET -- Lookup the definition of an environment variable. + +procedure t_get() + +char name[SZ_FNAME] +char value[SZ_LINE] +int envgets() + +begin + call clgstr ("name", name, SZ_FNAME) + if (envgets (name, value, SZ_LINE) <= 0) { + call printf ("%s not found\n") + call pargstr (name) + } else { + call printf ("%s = %s\n") + call pargstr (name) + call pargstr (value) + } +end + + +# PUT -- Enter a new environment variable or list of variables into the +# environment list. Enter "stmt: set name=value" to enter a single variable, +# or "stmt: set @filename" to process set statements from a file. + +procedure t_put() + +char stmt[SZ_LINE] +int envscan() + +begin + call clgstr ("statement", stmt, SZ_LINE) + call printf ("%d set statements processed\n") + call pargi (envscan (stmt)) +end + + +# LIST -- Print the environment list. + +procedure t_list() + +bool clgetb() +int btoi() + +begin + call envlist (STDOUT, " ", btoi (clgetb ("show_redefs"))) +end + + +# MARK -- Mark the end of the environment list for later restoration by +# the FREE task. + +procedure t_mark() + +int top +common /xxx/ top + +begin + call envmark (top) + call printf ("top = %d\n") + call pargi (top) +end + + +# FREE -- Free the environment list back to the last position marked. + +procedure t_free() + +int top +int envfree() +common /xxx/ top + +begin + call printf ("free uncovers %d redefs\n") + call pargi (envfree (top, 0)) +end + + +# DEBUG -- Print the internal data structures (the hash table) of the +# environment list package. + +procedure t_debug() + +begin + call envdebug (STDOUT) +end + + +# ENVDEBUG -- Print the contents of the environment list data structures for +# debugging the code. + +procedure envdebug (fd) + +int fd # output file +int i, t, head +pointer el, ep +include "environ.com" + +begin + call fprintf (fd, "envbuf at %d, len %d, last=%d, top=%d, %d%% full\n") + call pargi (envbuf) + call pargi (len_envbuf) + call pargi (last) + call pargi (top) + call pargr (real(top) / real(len_envbuf) * 100.0) + + for (t=1; t <= NTHREADS; t=t+1) { + call fprintf (fd, "%6d"); call pargi (t) + head = threads[t] + if (head != NULL) + for (i=head; i != NULL; i=E_NEXT(el)) { + el = envbuf + i + call putci (fd, ' ') + for (ep=E_SETP(el); Memc[ep] != '='; ep=ep+1) + call putc (fd, Memc[ep]) + } + call putci (fd, '\n') + } +end + + +# SPAWN -- Spawn a connected subprocess. Used to test process control and +# interprocess communication. + +procedure t_spawn() + +char process[SZ_FNAME] +char lbuf[SZ_LINE] +int in, out, pid +int prgetline(), propen(), prclose(), strmatch() +define done_ 91 + +begin + call clgstr ("process", process, SZ_FNAME) + pid = propen (process, in, out) + + call putline (STDERR, "-> ") + call flush (STDERR) + + while (prgetline (STDIN, lbuf) != EOF) { + if (strmatch (lbuf, "^bye") > 0) + break + else { + call putline (out, lbuf) + call flush (out) + } + + while (prgetline (in, lbuf) != EOF) { + call putline (STDERR, lbuf) + + if (strmatch (lbuf, "^bye") > 0) + break + else { + call putline (STDERR, ">> ") + call flush (STDERR) + if (prgetline (STDIN, lbuf) == EOF) + goto done_ + call putline (out, lbuf) + } + + call flush (STDERR) + call flush (out) + } + + call putline (STDERR, "------------\n") + call putline (STDERR, "-> ") + call flush (STDERR) + } + +done_ + call putline (STDERR, "\n") + call eprintf ("termination code %d\n") + call pargi (prclose (pid)) +end + + +# EDIT -- Test raw mode to a terminal. + +procedure t_edit() + +char lbuf[SZ_LINE], temp[SZ_LINE], ch +int i, stdline + +char getchar() +int envgets(), ttygeti() +pointer tty, ttyodes() +define accum_ 91 +define done_ 92 + +begin + # Set terminal to raw mode. + call fseti (STDIN, F_RAW, YES) + + # Open termcap for terminal. + if (envgets ("terminal", lbuf, SZ_LINE) <= 0) + call strcpy ("vt100", lbuf, SZ_LINE) + tty = ttyodes (lbuf) + stdline = ttygeti (tty, "li") + + # Edit loop. The variable I is the character position within the + # line. Start out in insert mode, with line displayed at bottom + # of terminal screen. + + lbuf[1] = EOS + i = 1 + call ttygoto (STDOUT, tty, 1, stdline) + call flush (STDOUT) + goto accum_ + + while (getchar (ch) != EOF) { + switch (ch) { + + case 'h': + # Move left one column. + if (i <= 1) + call putci (STDOUT, BEL) + else { + call putci (STDOUT, BS) + i = i - 1 + } + + case 'l': + # Move right one column. + if (lbuf[i+1] == EOS) + call putci (STDOUT, BEL) + else { + call putc (STDOUT, lbuf[i]) + i = i + 1 + } + + case 'x': + # Delete a character. + call strcpy (lbuf[i+1], lbuf[i], SZ_LINE-i+1) + call putline (STDOUT, lbuf[i]) + call putci (STDOUT, BLANK) + call ttygoto (STDOUT, tty, i, STDLINE) + + if (i > 1 && lbuf[i] == EOS) { + call putci (STDOUT, BS) + i = i - 1 + } + + case 'i': + # Insert a character. +accum_ + while (getchar (ch) != ESC) { + call putc (STDOUT, ch) + if (ch == '\r') + goto done_ + + # Insert char in line buffer. + call strcpy (lbuf[i], temp, SZ_LINE) + lbuf[i] = ch + i = i + 1 + call strcpy (temp, lbuf[i], SZ_LINE-i+1) + + # Redraw right portion of line. + call putline (STDOUT, lbuf[i]) + call ttygoto (STDOUT, tty, i, STDLINE) + call flush (STDOUT) + } + + if (i > 1) { + call putci (STDOUT, BS) + i = i - 1 + } + + case '\f': + # Redraw line. + call printf ("\r%s") + call pargstr (lbuf) + call ttygoto (STDOUT, tty, i, STDLINE) + + case '\r': + break + + default: + call putci (STDOUT, BEL) + } + + call flush (STDOUT) + } + +done_ + call fseti (STDIN, F_RAW, NO) + call putci (STDOUT, '\n') + call ttycdes (tty) +end + + +# TTY -- Test direct terminal i/o. + +procedure t_tty() + +int in, out, ch +int ttopen(), getci() +bool clgetb() + +begin + if (clgetb ("dualstreams")) { + in = ttopen ("dev$tty", READ_ONLY) + out = ttopen ("dev$tty", WRITE_ONLY) + } else { + in = ttopen ("dev$tty", READ_WRITE) # NOT SUPPORTED + out = in + } + + call fseti (in, F_RAW, YES) + while (getci (in, ch) > 0) { + call fprintf (out, "%c\r\n") + call pargi (ch) + call flush (out) + if (ch == EOFCHAR) + break + } + + if (in == out) + call close (in) + else { + call close (out) + call close (in) + } +end + + +# URL_GET -- Do an HTTP GET of a URL + +procedure t_urlget () + +pointer reply +char url[SZ_LINE], fname[SZ_FNAME] +bool hdr +int nread + +int url_get() + +begin + call clgstr ("url", url, SZ_LINE) # get the parameters + call clgstr ("fname", fname, SZ_FNAME) + hdr = clgetb ("hdr") + + call calloc (reply, SZ_LINE, TY_CHAR) + + nread = url_get (url, fname, reply) + + call eprintf ("File '%s', downloaded %d bytes.\n") + call pargstr (fname) + call pargi (nread) + + if (hdr) + call eprintf (Memc[reply]) + call mfree (reply, TY_CHAR) +end diff --git a/sys/fio/README b/sys/fio/README new file mode 100644 index 00000000..f4cf4d79 --- /dev/null +++ b/sys/fio/README @@ -0,0 +1,10 @@ +This directory contains the IRAF File I/O (FIO) routines. This version of +FIO fully implements revision 5 of the FIO interface as described in Fio.hlp. +Internally, however, the buffer management code has been simplified by +restricting the number of buffers to one per file, and omitting global buffers. +These features will be added in an upcoming revision of FIO. No modifications +to the external specifications of the FIO interface should be necessary. +D. Tody, 04-Apr-83. + +Jul84 Added filename mapping, filename locking, extensive modifications to + make use of the new kernel. diff --git a/sys/fio/access.x b/sys/fio/access.x new file mode 100644 index 00000000..6a7db09d --- /dev/null +++ b/sys/fio/access.x @@ -0,0 +1,58 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +# ACCESS -- Determine the accessiblity of a file. Use "access(file,0,0)" +# to determine if a file exists. Specify the mode and/or type to see if +# the file is accessible in a certain mode, and to verify the type of the file. + +int procedure access (fname, mode, type) + +char fname[ARB] # filename +int mode # file access mode (0 if dont care) +int type # file type (txt|bin) (0 if dont care) + +int zmode, status, fd, ip +int fstati(), fstdfile() +include +include "mmap.inc" +errchk fmapfn +define exit_ 91 + +begin + status = NO + + # Ignore any whitespace at the beginning of the filename. + for (ip=1; IS_WHITE (fname[ip]); ip=ip+1) + ; + + # Special handling is required for the pseudofiles STDIN, STDOUT, etc. + if (fname[ip] == 'S') { + if (fstdfile (fname[ip], fd) == YES) { + if (mode == 0 || mode == fstati (fd, F_MODE)) + if (type == 0 || type == fstati (fd, F_TYPE)) { + status = YES + goto exit_ + } + goto exit_ + } + } + + # Regular files. If the filename cannot be mapped the file does not + # exist (or the filename mapping file is lost or unreadable). + + iferr (call fmapfn (fname[ip], pathname, SZ_PATHNAME)) + goto exit_ + + zmode = mode + if (mode >= READ_ONLY && mode <= TEMP_FILE) + zmode = mmap[mode] + call zfacss (pathname, zmode, type, status) + +exit_ + return (status) +end diff --git a/sys/fio/aread.x b/sys/fio/aread.x new file mode 100644 index 00000000..a57c92c9 --- /dev/null +++ b/sys/fio/aread.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# AREAD -- Asychronous block read from a binary file. Reads can only +# start at a character offset which is an integral multiple of the file +# block size. + +procedure aread (fd, buffer, maxchars, char_offset) + +int fd # FIO file descriptor +int maxchars # maximum number of chars to be read +char buffer[ARB] # buffer into which data is to be read +long char_offset # one-indexed char offset in file + +int maxbytes +long byte_offset + +begin + maxbytes = maxchars * SZB_CHAR + byte_offset = (char_offset-1) * SZB_CHAR + 1 + + call areadb (fd, buffer, maxbytes, byte_offset) +end diff --git a/sys/fio/areadb.x b/sys/fio/areadb.x new file mode 100644 index 00000000..6f810c6e --- /dev/null +++ b/sys/fio/areadb.x @@ -0,0 +1,83 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# AREADB -- Asychronous byte-oriented block read from a binary file. Reads +# can only start at a character offset which is an integral multiple of the +# file block size. + +procedure areadb (fd, buffer, maxbytes, byte_offset) + +int fd # FIO file descriptor +int maxbytes # maximum number of machine bytes to read +char buffer[ARB] # buffer into to which data is to be read +long byte_offset # one-indexed byte offset in file + +long file_offset +int junk, awaitb() +errchk filerr, syserr +include + +begin + fp = fiodes[fd] + if (fd <= 0 || fp == NULL) + call syserr (SYS_FILENOTOPEN) + + # If channel is active, wait for completion. Do not abort if await is + # not called between i/o requests, since this is what happens when an + # error occurs, ant it would lead to a file error following error + # restart. + + if (FCIOMODE(fp) != INACTIVE) + junk = awaitb (FAFD(fp)) + + if (FBLKSIZE(fp) == 0) # streaming device + ; + else if (byte_offset < 1) + call filerr (FNAME(fp), SYS_FARDOOB) + else if (FILSIZE(fp) >= 0 && byte_offset - (FILSIZE(fp)*SZB_CHAR) > 1) { + FNBYTES(fp) = 0 # return EOF + return + } + + # If not a streaming device, check alignment of block. If streaming + # device, file offset passed to z-routine must be zero. + + file_offset = byte_offset + if (FBLKSIZE(fp) > 0) { + if (mod (byte_offset-1, (FBLKSIZE(fp)*SZB_CHAR)) != 0) + call filerr (FNAME(fp), SYS_FARDALIGN) + } else + file_offset = 0 + + call zlocva (buffer, FLOCBUF(fp)) + FCIOMODE(fp) = READ_IN_PROGRESS + FFIOMODE(fp) = READ_IN_PROGRESS + FAFD(fp) = fd + + # If the CLOSE flag is set for the channel, open and close the channel + # at the host level every time an i/o operation takes place. (Used to + # save host channel descriptors). The code is structured so that the + # FCLOSEFD flag may change state at any time, with the channel being + # left either closed or open the next time we are called. Any open or + # read errors are reported as read errors when AWAITB is later called. + + if (FCLOSEFD(fp) == NO && FCHAN(fp) != ERR) + call zcall4 (ZARDBF(fp), FCHAN(fp), buffer, maxbytes, file_offset) + else { + if (FCHAN(fp) == ERR) + call zcall3 (FDEVOPEN(fp), FPKOSFN(fp), FMODE(fp), FCHAN(fp)) + if (FCHAN(fp) != ERR) { + call zcall4 (ZARDBF(fp), + FCHAN(fp), buffer, maxbytes, file_offset) + if (FCLOSEFD(fp) == YES) { + junk = awaitb (FAFD(fp)) + call zcall2 (ZCLSBF(fp), FCHAN(fp), junk) + FCHAN(fp) = ERR + } + } + } +end diff --git a/sys/fio/await.x b/sys/fio/await.x new file mode 100644 index 00000000..64deeb40 --- /dev/null +++ b/sys/fio/await.x @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# AWAIT -- Wait for any pending i/o operations on a file to complete. +# Must be called after an AREAD or AWRITE (to check for an i/o error +# and for synchronization) or an abort will result. + +int procedure await (fd) + +int fd +pointer bufp +int nbytes, nchars, nfill, loc_Mem, zero, mode +int awaitb() +include + +data loc_Mem /0/, zero /0/ +errchk syserr + +begin + fp = fiodes[fd] + if (fd <= 0 || fp == NULL) + call syserr (SYS_FILENOTOPEN) + + # Read the i/o mode before awaitb clears it. + mode = FFIOMODE(fp) + + # Wait for i/o. + nbytes = awaitb (fd) + if (nbytes <= 0) + return (nbytes) + + # Zero fill the last char of the output buffer if the last transfer was + # a read and the number of bytes read was not commensurate with the + # size of a char. + + if (mode == READ_IN_PROGRESS && nbytes > 0) { + nchars = (nbytes + SZB_CHAR-1) / SZB_CHAR + nfill = nchars * SZB_CHAR - nbytes + + if (nfill > 0) { + if (loc_Mem == 0) + call zlocva (Memc, loc_Mem) + bufp = FLOCBUF(fp) - loc_Mem + 1 + call bytmov (zero, 1, Memc[bufp], nbytes + 1, nfill) + } + } + + # On exit from AWAITB, fp.filstat contains the number of chars + # transferred in the last aread or awrite, or ERR. + + return (FILSTAT(fp)) +end diff --git a/sys/fio/awaitb.x b/sys/fio/awaitb.x new file mode 100644 index 00000000..3d27f748 --- /dev/null +++ b/sys/fio/awaitb.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# AWAITB -- Wait for any pending i/o operations on a file to complete. +# Must be called after an AREADB or AWRITEB (to check for an i/o error +# and for synchronization) or an abort will result. + +int procedure awaitb (fd) + +int fd +int nbytes, nchars +include + +begin + fp = fiodes[fd] + + if (FFIOMODE(fp) == INACTIVE) + return (FNBYTES(fp)) + else + call zcall2 (ZAWTBF(fp), FCHAN(fp), nbytes) + + nchars = nbytes + if (nbytes >= 0) + nchars = (nbytes + SZB_CHAR-1) / SZB_CHAR + + FNBYTES(fp) = nbytes + FILSTAT(fp) = nchars + + FCIOMODE(fp) = INACTIVE # clear channel + FFIOMODE(fp) = INACTIVE # complete fd request + + if (nbytes >= 0) + return (nbytes) + else + return (ERR) +end diff --git a/sys/fio/awrite.x b/sys/fio/awrite.x new file mode 100644 index 00000000..a189d0e3 --- /dev/null +++ b/sys/fio/awrite.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# AWRITE -- Asychronous block write to a binary file. Writes can only +# start at a character offset which is an integral multiple of the file +# block size. + +procedure awrite (fd, buffer, nchars, char_offset) + +int fd +int nchars +char buffer[ARB] +long char_offset + +int nbytes +long byte_offset + +begin + nbytes = nchars * SZB_CHAR + byte_offset = (char_offset-1) * SZB_CHAR + 1 + + call awriteb (fd, buffer, nbytes, byte_offset) +end diff --git a/sys/fio/awriteb.x b/sys/fio/awriteb.x new file mode 100644 index 00000000..8c4f1c4d --- /dev/null +++ b/sys/fio/awriteb.x @@ -0,0 +1,90 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# AWRITEB -- Asychronous byte-oriented block write to a binary file. Writes +# can only start at a byte offset which is an integral multiple of the file +# block size. + +procedure awriteb (fd, buffer, nbytes, byte_offset) + +int fd # FIO file descriptor +int nbytes # number of machine bytes to be written +char buffer[ARB] # buffer containing the data +long byte_offset # one-indexed byte offset in file + +long file_offset, szb_file +int junk, awaitb() +errchk filerr, syserr +include + +begin + fp = fiodes[fd] + if (fd <= 0 || fp == NULL) + call syserr (SYS_FILENOTOPEN) + + # Ignore null writes. + if (nbytes == 0) + return + + # If channel is active, wait for completion. Do not abort if await is + # not called between i/o requests, since this is what happens when an + # error occurs, ant it would lead to a file error following error + # restart. + + if (FCIOMODE(fp) != INACTIVE) + junk = awaitb (FAFD(fp)) + + if (FBLKSIZE(fp) > 0) # not streaming device + if (byte_offset < 1 || byte_offset - (FILSIZE(fp)*SZB_CHAR) > 1) + call filerr (FNAME(fp), SYS_FAWROOB) + + # If not a streaming device, check alignment of block. If streaming + # device, byte offset passed to z-routine must be zero. + + file_offset = byte_offset + if (FBLKSIZE(fp) > 0) { + if (mod (byte_offset-1, (FBLKSIZE(fp)*SZB_CHAR)) != 0) + call filerr (FNAME(fp), SYS_FAWRALIGN) + } else + file_offset = 0 + + # Keep track of file size if appending to file. FIO keeps track of + # the file size to the nearest char. FILSIZE is negative for certain + # types of files, in which case we do not know the file size. + + if (FILSIZE(fp) >= 0) { + szb_file = max (FILSIZE(fp) * SZB_CHAR, file_offset-1 + nbytes) + FILSIZE(fp) = (szb_file + SZB_CHAR-1) / SZB_CHAR + } + + FCIOMODE(fp) = WRITE_IN_PROGRESS + FFIOMODE(fp) = WRITE_IN_PROGRESS + FAFD(fp) = fd + + # If the CLOSE flag is set for the channel, open and close the channel + # at the host level every time an i/o operation takes place. (Used to + # save host channel descriptors). The code is structured so that the + # FCLOSEFD flag may change state at any time, with the channel being + # left either closed or open the next time we are called. Any open or + # write errors are reported as write errors when AWAITB is later called. + + if (FCLOSEFD(fp) == NO && FCHAN(fp) != ERR) + call zcall4 (ZAWRBF(fp), FCHAN(fp), buffer, nbytes, file_offset) + else { + if (FCHAN(fp) == ERR) + call zcall3 (FDEVOPEN(fp), FPKOSFN(fp), FMODE(fp), FCHAN(fp)) + if (FCHAN(fp) != ERR) { + call zcall4 (ZAWRBF(fp), + FCHAN(fp), buffer, nbytes, file_offset) + if (FCLOSEFD(fp) == YES) { + junk = awaitb (FAFD(fp)) + call zcall2 (ZCLSBF(fp), FCHAN(fp), junk) + FCHAN(fp) = ERR + } + } + } +end diff --git a/sys/fio/close.x b/sys/fio/close.x new file mode 100644 index 00000000..622557c5 --- /dev/null +++ b/sys/fio/close.x @@ -0,0 +1,70 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# CLOSE -- Close a file, after possibly flushing the output buffer, and +# returning the file buffer (if any) and file descriptor. + +procedure close (fd_arg) + +int fd_arg, fd +int status +errchk flush, mfree, frtnfd +include + +begin + fp = fiodes[fd_arg] + if (fp == NULL) + return + else + call fcanpb (fd_arg) # cancel any pushback + + if (redir_fd[fd_arg] > 0) { + # If the stream was redirected locally onto a new file by FREDIR, + # swap streams back to their original order and close the redir + # file. + + fd = redir_fd[fd_arg] + call flush (fd_arg) + call fswapfd (fd, fd_arg) + redir_fd[fd_arg] = 0 + } else + fd = fd_arg + + switch (fd) { + case STDIN, CLIN: + return + case STDOUT, STDERR, CLOUT, STDGRAPH, STDIMAGE, STDPLOT: + call flush (fd) + + default: + call flush (fd) + status = OK + + switch (FTYPE(fp)) { + case TEXT_FILE: + call zcall2 (ZCLSTX(fp), FCHAN(fp), status) + call frtnfd (fd) + case STRING_FILE: + call strclose (fd) + case SPOOL_FILE: + call frtnfd (fd) + + default: + FREFCNT(fp) = FREFCNT(fp) - 1 + if (FREFCNT(fp) <= 0) { + if (FCHAN(fp) != ERR) + call zcall2 (ZCLSBF(fp), FCHAN(fp), status) + + if (FCD(fp) != FLCD(fp)) # separate chandes? + call mfree (FCD(fp), TY_STRUCT) + } + call frtnfd (fd) + } + + if (status == ERR) + call filerr (FNAME(fp), SYS_FCLOSE) + } +end diff --git a/sys/fio/delete.x b/sys/fio/delete.x new file mode 100644 index 00000000..c842d334 --- /dev/null +++ b/sys/fio/delete.x @@ -0,0 +1,110 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +# DELETE -- Delete a single physical file. It is an error if the file does +# not exist, is protected, or if the file simply cannot be deleted. DELETEFG +# should be called if deletion of subfiles or multiple versions is desired. +# Interrupts are disabled while the VFN database is open to protect the +# database, ensure that that the lock on the mapping file is cleared, and to +# ensure that the mapping file is closed. + +procedure delete (fname) + +char fname[ARB] # file to be deleted + +int status +bool nosuchfile +pointer vp, sp, osfn + +int vfndel() +bool fnullfile() +pointer vfnopen() +define abort_ 91 +define close_ 92 + +begin + # The null file "dev$null" is a special case; ignore attempts to + # delete this file. + + if (fnullfile (fname)) + return + + call smark (sp) + call salloc (osfn, SZ_PATHNAME, TY_CHAR) + + call intr_disable() + iferr (vp = vfnopen (fname, VFN_WRITE)) + goto abort_ + + # Delete the VFN and determine if the file actually exists. + nosuchfile = false + iferr (status = vfndel (vp, Memc[osfn], SZ_PATHNAME)) + goto close_ + + if (status == ERR) + nosuchfile = true + else { + call zfacss (Memc[osfn], 0, 0, status) + if (status == NO) { + # If the file is a symlink pointing to a non-existent file, + # we'll delete the link below. + call zfacss (Memc[osfn], 0, SYMLINK_FILE, status) + if (status == YES) + nosuchfile = false + else + nosuchfile = true + } + } + + # It is an error to try to delete a nonexistent file. + if (nosuchfile) { + iferr (call filerr (fname, SYS_FDELNXF)) + goto close_ + } + + # Is the file protected? + call zfprot (Memc[osfn], QUERY_PROTECTION, status) + + if (status == YES) { + iferr (call filerr (fname, SYS_FDELPROTFIL)) + goto close_ + } else { + # Try to delete the file. If the delete operation succeeds but + # the file still exists, an older version has surfaced and the + # VFN must not be deleted from the file table. + + call zfdele (Memc[osfn], status) + if (status == ERR) { + iferr (call filerr (fname, SYS_FDELETE)) + goto close_ + } else { + call zfacss (Memc[osfn], 0, 0, status) + if (status == YES) { + iferr (call vfnclose (vp, VFN_NOUPDATE)) + goto abort_ + } else { + iferr (call vfnclose (vp, VFN_UPDATE)) + goto abort_ + } + } + } + + call sfree (sp) + call intr_enable() + return + + + # Error recovery nasties. +close_ + iferr (call vfnclose (vp, VFN_NOUPDATE)) + ; +abort_ + call intr_enable() + call sfree (sp) + call erract (EA_ERROR) +end diff --git a/sys/fio/deletefg.x b/sys/fio/deletefg.x new file mode 100644 index 00000000..be397efd --- /dev/null +++ b/sys/fio/deletefg.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# DELETEFG -- Delete a file group, i.e., the file, all subfiles, and all +# versions. It is an error if the file does not exist, is protected, or +# if the file simply cannot be deleted. A subfile is a physical file which +# is logically subordinate to another file and which must be deleted if the +# main file is deleted (e.g., a pixel storage file is a subfile of an +# imagefile). + +procedure deletefg (fname, versions, subfiles) + +char fname[ARB] # file or file group to be deleted +int versions # delete all versions +int subfiles # delete any subfiles (no subsubfiles) + +int n, max_versions +errchk delete, erract + +begin + max_versions = 1 + if (versions == YES) + max_versions = 30000 + + for (n=0; n < max_versions; n=n+1) { + # Delete the main file. + iferr (call delete (fname)) + if (n == 0) + call erract (EA_ERROR) + else + break + # Delete any subfiles. + if (subfiles == YES) + call fsfdelete (fname) + } +end diff --git a/sys/fio/diropen.x b/sys/fio/diropen.x new file mode 100644 index 00000000..52f099ce --- /dev/null +++ b/sys/fio/diropen.x @@ -0,0 +1,289 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include + +define MAX_OPENDIR 20 + +# DIROPEN -- Open a directory file for reading. Directories are opened +# as read only text files. Writing, seeking, etc. are not permitted. +# The machine dependent OSFN's returned by the kernel are converted to +# VFN's and hidden files are skipped. Skipping of hidden files may be +# overriden (i.e., all filenames may be passed) as a option. + +int procedure diropen (fname, mode) + +char fname[ARB] # directory file to be opened +int mode # pass or skip hidden filenames + +int fd, dirf +bool first_time +int dirmode[MAX_OPENDIR] +int oschan[MAX_OPENDIR] +pointer vfnptr[MAX_OPENDIR], vp, sp, osfn + +pointer vfnopen() +int fopntx(), fstati(), errcode() +extern fopdir(), fgtdir(), fptdir(), ffldir(), fstdir(), fcldir() +extern fskdir(), fntdir() +errchk fopntx, vfnopen, syserrs +common /dircom/ dirmode, oschan, vfnptr +data first_time /true/ + +begin + call smark (sp) + call salloc (osfn, SZ_PATHNAME, TY_CHAR) + + # Free up all descriptor slots. + if (first_time) { + do dirf = 1, MAX_OPENDIR + oschan[dirf] = 0 + first_time = false + } + + # The file name must be mapped explicitly because FIO will not map + # filenames opened on special devices (when FOPNTX is called). + + call fmapfn (fname, Memc[osfn], SZ_PATHNAME) + call strupk (Memc[osfn], Memc[osfn], SZ_PATHNAME) + + # Open the VFN database, used to unmap filenames. + vp = vfnopen (Memc[osfn], VFN_UNMAP) + + # Open the file. We call FIO which eventually calls FOPDIR. + + iferr { + fd = fopntx (Memc[osfn], READ_ONLY, + fopdir, fgtdir, fptdir, ffldir, fstdir, fcldir, fskdir, fntdir) + } then { + call vfnclose (vp, VFN_NOUPDATE) + if (errcode() == SYS_FOPENDEV) + call syserrs (SYS_FOPENDIR, fname) + else + call erract (EA_ERROR) + } + + # Get the channel number (index into dirmode and oschan) assigned + # by FOPDIR. Save the mode and vp for later. + + dirf = fstati (fd, F_CHANNEL) + dirmode[dirf] = mode + vfnptr[dirf] = vp + + call sfree (sp) + return (fd) +end + + +# FOPDIR -- Open a directory; this is the "zopntx" routine called by FIO. +# Allocate a directory descriptor and call the kernel to physically open +# the directory. + +procedure fopdir (osfn, mode, channel) + +char osfn[ARB] # packed OS filename of directory file +int mode # file access mode (always read_only) +int channel # we return index into oschan + +int dirf +int dirmode[MAX_OPENDIR] +int oschan[MAX_OPENDIR] +int vfnptr[MAX_OPENDIR] +common /dircom/ dirmode, oschan, vfnptr + +begin + channel = ERR + if (mode != READ_ONLY) + return + + # Allocate a descriptor. + for (dirf=1; dirf <= MAX_OPENDIR; dirf=dirf+1) + if (oschan[dirf] == 0) + break + + # Open the physical directory file and return directory file index + # as the channel number. Free the slot if ZOPDIR returns ERR. + + if (dirf <= MAX_OPENDIR) { + call zopdir (osfn, oschan[dirf]) + if (oschan[dirf] == ERR) + oschan[dirf] = 0 + else + channel = dirf + } +end + + +# FCLDIR -- Close a directory previously opened with FOPDIR. + +procedure fcldir (channel, status) + +int channel # index into oschan +int status + +int dirmode[MAX_OPENDIR] +int oschan[MAX_OPENDIR] +int vfnptr[MAX_OPENDIR] +common /dircom/ dirmode, oschan, vfnptr + +begin + if (channel < 1 || channel > MAX_OPENDIR) + status = ERR + else if (oschan[channel] == 0) + status = ERR + else { + call zcldir (oschan[channel], status) + oschan[channel] = 0 + iferr (call vfnclose (vfnptr[channel], VFN_NOUPDATE)) + status = ERR + } +end + + +# FGTDIR -- Get the next "line of text", i.e. VFN, from a directory. Since we +# are being accessed as a text file we must return an unpacked string delimited +# by a newline. OS filenames are converted to virtual filenames and hidden +# files are skipped if desired. Raw mode is not supported. + +procedure fgtdir (chan, outline, maxch, status) + +int chan # oschan index +char outline[maxch] # buffer which receives the VFN +int maxch # maxchars to return +int status + +int nchars +pointer vp, sp, osfn +int dirmode[MAX_OPENDIR] +int oschan[MAX_OPENDIR] +int vfnptr[MAX_OPENDIR] + +int vfnunmap(), vfn_is_hidden_file() +errchk vfnunmap, vfn_is_hidden_file +common /dircom/ dirmode, oschan, vfnptr +define done_ 91 + +begin + call smark (sp) + call salloc (osfn, SZ_FNAME, TY_CHAR) + + status = ERR + if (chan < 1 || chan > MAX_OPENDIR) + goto done_ + if (oschan[chan] == 0) + goto done_ + vp = vfnptr[chan] + + repeat { + call zgfdir (oschan[chan], Memc[osfn], SZ_FNAME, nchars) + if (nchars > 0) { + nchars = vfnunmap (vp, Memc[osfn], outline, maxch) + if (nchars > 0 && nchars < maxch) { + if (dirmode[chan] == SKIP_HIDDEN_FILES) + if (outline[1] == '.' || + vfn_is_hidden_file (outline) == YES) { + nchars = 0 + next + } + outline[nchars+1] = '\n' + nchars = nchars + 1 + outline[nchars+1] = EOS + } + } + } until (nchars != 0) + + # FIO expects to read 0 chars when EOF is reached. + if (nchars == EOF) + status = 0 + else + status = nchars +done_ + call sfree (sp) +end + + +# FPTDIR -- Put a line to a directory. This function is illegal on directories. +# In principle FIO will never permit us to be called. + +procedure fptdir (chan, line, nchars, status) + +int chan, nchars, status +char line[ARB] + +begin + status = ERR +end + + +# FFLDIR -- Flush output to a directory. This function is illegal on +# directories. In principle FIO will never permit us to be called. + +procedure ffldir (chan, status) + +int chan, status + +begin + status = ERR +end + + +# FSTDIR -- Get file status for a directory file/device. This is a legal +# function, used to get the buffer size. + +procedure fstdir (chan, param, lvalue) + +int chan # not used +int param # parameter for which status is desired +long lvalue # returned value + +begin + switch (param) { + case FSTT_BLKSIZE: + lvalue = 1 + case FSTT_FILSIZE: + lvalue = 0 + case FSTT_OPTBUFSIZE: + lvalue = SZ_LINE + case FSTT_MAXBUFSIZE: + lvalue = 0 + default: + lvalue = ERR + } +end + + +# FSKDIR -- Seek on a directory file. Ignore seek to BOF since ZOPDIR +# opens at BOF automatically (FIO will call us to seek to BOF when the +# file is opened). + +procedure fskdir (chan, offset, status) + +int chan, status +long offset + +begin + switch (offset) { + case BOFL: + status = OK + default: + status = ERR + } +end + + +# FNTDIR -- Note position on a directory file. Seeking is illegal on +# directories so we merely return ERR. + +procedure fntdir (chan, offset) + +int chan +long offset + +begin + offset = ERR +end diff --git a/sys/fio/doc/fio.hd b/sys/fio/doc/fio.hd new file mode 100644 index 00000000..08da85cc --- /dev/null +++ b/sys/fio/doc/fio.hd @@ -0,0 +1,54 @@ +# Help directory for the FIO (file i/o) system package. + +$fio = "sys$fio/" + +access hlp = access.hlp, src = fio$access.x +aread hlp = aread.hlp, src = fio$aread.x +areadb hlp = areadb.hlp, src = fio$areadb.x +await hlp = await.hlp, src = fio$await.x +awaitb hlp = awaitb.hlp, src = fio$awaitb.x +awrite hlp = awrite.hlp, src = fio$awrite.x +awriteb hlp = awriteb.hlp, src = fio$awriteb.x +close hlp = close.hlp, src = fio$close.x +delete hlp = delete.hlp, src = fio$delete.x +diropen hlp = diropen.hlp, src = fio$diropen.x +falloc hlp = falloc.hlp, src = fio$falloc.x +fcopy hlp = fcopy.hlp, src = fio$fcopy.x +fdevbf hlp = fdevbf.hlp, src = fio$fdevbf.x +fdevtx hlp = fdevtx.hlp, src = fio$fdevtx.x +finfo hlp = finfo.hlp, src = fio$finfo.x +flush hlp = flush.hlp, src = fio$flush.x +fnextn hlp = fnextn.hlp, src = fio$fnextn.x +fnldir hlp = fnldir.hlp, src = fio$fnldir.x +fnroot hlp = fnroot.hlp, src = fio$fnroot.x +fntcls hlp = fntgfn.hlp, src = fio$fntgfn.x +fntclsb hlp = fntgfn.hlp, src = fio$fntgfn.x +fntgfn hlp = fntgfn.hlp, src = fio$fntgfn.x +fntgfnb hlp = fntgfn.hlp, src = fio$fntgfn.x +fntlenb hlp = fntgfn.hlp, src = fio$fntgfn.x +fntopn hlp = fntgfn.hlp, src = fio$fntgfn.x +fntopnb hlp = fntgfn.hlp, src = fio$fntgfn.x +fntrewb hlp = fntgfn.hlp, src = fio$fntgfn.x +fopnbf hlp = fopnbf.hlp, src = fio$fopnbf.x +fopntx hlp = fopntx.hlp, src = fio$fopntx.x +fowner hlp = fowner.hlp, src = fio$fowner.x +fpathname hlp = fpathname.hlp, src = fio$fpathname.x +fseti hlp = fseti.hlp, src = fio$fseti.x +fstati hlp = fstati.hlp, src = fio$fstati.x +fstatl hlp = fstatl.hlp, src = fio$fstatl.x +fstats hlp = fstats.hlp, src = fio$fstats.x +getc hlp = getc.hlp, src = fio$getc.x +getline hlp = getline.hlp, src = fio$getline.x +mktemp hlp = mktemp.hlp, src = fio$mktemp.x +note hlp = note.hlp, src = fio$note.x +open hlp = open.hlp, src = fio$open.x +protect hlp = protect.hlp, src = fio$protect.x +putc hlp = putc.hlp, src = fio$putc.x +putcc hlp = putcc.hlp, src = fio$putcc.x +putline hlp = putline.hlp, src = fio$putline.x +read hlp = read.hlp, src = fio$read.x +rename hlp = rename.hlp, src = fio$rename.x +reopen hlp = reopen.hlp, src = fio$reopen.x +seek hlp = seek.hlp, src = fio$seek.x +stropen hlp = stropen.hlp, src = fio$stropen.x +write hlp = write.hlp, src = fio$write.x diff --git a/sys/fio/doc/fio.hlp b/sys/fio/doc/fio.hlp new file mode 100644 index 00000000..1f87049f --- /dev/null +++ b/sys/fio/doc/fio.hlp @@ -0,0 +1,1912 @@ + +.help fio Jan83 "File i/o Design Rev.5" +.tp 30 +.sh +STRUCTURE OF THE BASIC FILE I/O PROCEDURES + + The high level FIO input procedures are GETC, GETLINE, and READ. +These procedures read directly out of the "current buffer". When the +buffer is exhausted, FILBUF is called to refill the buffer. The action +taken by FILBUF depends on whether the file contains text or binary data, +but does not depend on the characteristics of the device on which the +file is resident. The output procedures are similar to the input +procedures, except that FLSBUF is called to flush the buffer when it fills. + + + + +.ks +.nf + getc getline read + + + + filbuf + + + text files binary files + + zgettx fmkbfs ffault + + + + Structure of the Input Procedures +.fi +.ke + + + + + +.ks +.nf + putc putline write + + + + + flsbuf + + + text files binary files + + + zputtx fmkbfs ffault + + + + Structure of the Output Procedures +.fi +.ke + + +The "file fault" procedure (FFAULT) is called by both FILBUF and FLSBUF +for binary files, when the referenced data lies outside the range of +the current buffer. + + + +.ks +.nf + ffault + + + + + ffilbf frelnk fflsbf + + + + + fwatio fbseek + + + + aread await aseek/anote awrite + + + + zaread zawait zseek/znote zawrite + + + + FIO Structure for Accessing Binary Files +.fi +.ke + + +In the above structure chart, the "z" routines at the lowest level +are system and device dependent, and are actually part of the system +interface, rather than FIO. A separate set of z-routines is required +for each device serviced by FIO (regular binary files, the CL interface, +pipes, magtapes, memory, etc.). + +All of the system and device dependence of FIO is concentrated +into the z-routines. Only the routines AREAD, AWRITE, and AWAIT know +that more than one type of binary device is serviced by FIO. Furthermore, +FIO maintains a device table containing the entry point addresses of +the z-routines for each device. This provides a clean interface to the +device dependent routines, and makes it possible to add new devices +without editing the source for FIO. In fact, it is possible to interface +new devices to FIO dynamically, at run time. + + +.tp 10 +.sh +SEMICODE FOR THE BASIC FILE I/O PROCEDURES + + The procedures GETC and PUTC read and write character data, a single +character at a time. Since these procedures may be called once for each +character in a file, they must be as efficient (ergo, simple) as feasible. +These machine code for these routines should be hand optimized if much +text processing (i.e. compilations) is anticipated. + + + +.nf +.tp 5 +int procedure getc (fd, ch) # get character + +begin + if (iop < bufptr || iop >= itop) # buffer exhausted? + switch (filbuf(fd)) { + case EOF: + return (EOF) + case ERR: + take error action + } + + ch = Mem[iop] + iop = iop + 1 + + return (ch) +end + + + +.tp 5 +procedure putc (fd, ch) # put character + +begin + if (iop < bufptr || iop >= otop) { # buffer full? + if (flsbuf (fd) == ERR) + take error action + } + + Mem[iop] = ch + iop = iop + 1 + + if (ch == newline) { # end of line? + if (flush on newline is enabled for this file) + if (flsbuf (fd) == ERR) + take error action + } +end +.fi + + +Characters and strings (and even binary data) may be "pushed back" into +the input stream. UNGETC pushes a single character. Subsequent calls +to GETC, GETLINE, READ, etc. will read out the characters in the order +in which they were pushed (first in, first out). When all of the +pushback data has been read, reading resumes at the preceeding file +position, which may either be in one of the primary buffers, or an +earlier state in the pushback buffer. + +UNGETS differs from UNGETC in that it pushes back whole strings, +in a last in, first out fashion. UNGETS is used to implement recursive +macro expansions. The amount of recursion permitted may be specified +after the file is opened, and before any data is pushed back. Recursion +is limited by the size of the input pointer stack, and pushback capacity +by the size of the pushback buffer. + + +.tp 5 +.nf +procedure ungetc (fd, ch) # push back a character + +begin + if (iop < bufptr || iop >= otop) { + if (no pushback buffer) + create pushback buffer + else + error: "pushback buffer overflow" + + stack old iop, itop + + set iop to point at beginning of the pushback buffer, + set itop to iop, otop to top of pushback buffer. + } + + Mem[iop] = ch + iop = iop + 1 + itop = itop + 1 +end + + + +.tp 5 +procedure ungets (fd, str) # recursively push back a string + +begin + if (iop < bufptr || iop >= otop) { + if (no pushback buffer) { + create pushback buffer + setup iop, buftop for pushback buffer + } else + error: "pushback buffer overflow" + } + + stack old iop, itop + copy string to Mem[iop], advance iop + itop = iop +end +.fi + + + +Calls to GETLINE may be intermixed with calls to GETC, READ, and so on. +If, however, only GETLINE is used to access a file, and the associated +file is a text file, a file buffer will never need to be created (the +data will be placed directly in the user buffer instead). +If a buffer has been created and is not yet empty, GETLINE will read the +remainder of the current line from that buffer, before again calling FILBUF. + +The newline character is returned as part of the line. The maximum size +of a line (size of a line buffer) is set at compile time by the system +wide constant SZ_LINE. The constant SZ_LINE includes space for the newline +character, but not for the EOS marker (character array dimensions never +include space for the EOS, because the preprocessor automatically allows an +extra character for the EOS when dimensioning the array for Fortran). +.nf + + +.tp 5 +int procedure getline (fd, linebuf) # get a line from file + +begin + op = 1 + if (buffer is empty and file type is TEXT_FILE) { + # call ZGETTX to copy line directly into user linebuf + zgettx (channel(fd), linebuf, status) + + } else { + while (op <= SZ_LINE) { + if (iop < bufptr || iop >= itop) { + status = filbuf (fd) + if (status == ERR || status == EOF) + break + } + + linebuf[op] = Mem[iop] + iop = iop + 1 + op = op + 1 + + if (the character was newline) + break + } + linebuf[op] = EOS + } + + if (status == ERR) + take error action + else if (op == 1) + return (EOF) + else + return (op - 1) # number of chars +end + + + + +.tp 5 +procedure putline (fd, linebuf) # put a line to file + +begin + for (i=1; linebuf[i] != EOS; i=i+1) { + if (iop < bufptr || iop >= otop) + if (flsbuf (fd) == ERR) + take error action + } + + Mem[iop] = linebuf[i] + iop = iop + 1 + + if (the character is newline) { + if (flush on newline is enabled) + if (flsbuf (fd) == ERR) + take error action + } + } +end + + + +.fi +The READ procedure reads a maximum of MAXCHARS characters from the file +FD into the user supplied buffer BUFFER. In the case of block structured +devices, READ will continue to read blocks from the file until the output +buffer has filled. In the case of record structured devices (i.e., terminals, +text files, pipes) READ will read at most one record, after exhausting the +contents of the file buffer. + + + +.tp 5 +.nf +int procedure read (fd, buffer, maxchars) + +begin + check that fd is a valid file opened for reading + nchars = 0 + + while (nchars <= maxchars) { + if (iop < bufptr || iop >= itop) { + switch (filbuf(fd)) { + case EOF: + break + case ERR: + take error action + default: + # don't loop if record structured device or EOF + if (nchars read != buffer size) + maxchars = min (maxchars, nchars + nchars read) + } + } + chunk = min (maxchars - nchar, itop - iop) + if (chunk <= 0) + break + else { + amovc (Memc[iop], buffer[nchars+1], chunk) + iop = iop + chunk + nchars = nchars + chunk + } + } + + if (nchars == 0) + return (EOF) + else + return (nchars) +end + + + + +.tp 5 +procedure write (fd, buffer, maxchars) + +begin + check that fd is a valid file opened for writing + nchars = 0 + + while (nchars <= maxchars) { + if (iop < bufptr || iop >= otop) { + if (flsbuf (fd) == ERR) + take error action + } + chunk = min (maxchars - nchar, otop - iop) + if (chunk <= 0) + break + else { + amovc (buffer[nchars+1], Mem[iop], chunk) + iop = iop + chunk + nchars = nchars + chunk + } + } +end + + + + +.tp 5 +int procedure filbuf (fd) + +begin + verify fd: file open with read permission + + if (iop points into pushback buffer) { + pop state off pushback stack + return (itop - bufptr) + # eventually end up back in a real file buffer + } else if (no buffers) { + call fmkbfs to allocate buffer space for the file + # fmkbfs must adjust iop to reflect current file position + } + + if (TEXT_FILE) + zgettx (fd, file_buffer, nchars) + else + nchars = ffault (fd, logical_offset_in_file) + + iop = bufptr + itop = max (bufptr, bufptr + nchars) + otop = bufptr + + return (nchars) +end + + + + +.tp 5 +int procedure flsbuf (fd) + +begin + verify fd: file open with write permission + if (no buffers) + call fmkbfs to allocate buffer space + + if (otop = bufptr) { + set otop to top of buffer + status = OK + } else if (TEXT_FILE) { + zputtx (channel[fd], file_buffer, status) + reset iop to start of buffer + } else { + status = ffault (fd, logical_offset) + } + + return (status) +end +.fi + + +.sh +Buffer Management for Binary Files + + FIO maintains a "current buffer" for each file. A "file pointer" +is also maintained for each file. The file pointer is the character offset +within the file at which the next i/o transfer will occur. When the file +pointer no longer points into the current buffer, a "file fault" occurs. +The file pointer is modified when, and only when, an i/o transfer or seek +occurs. + +All i/o to binary files is routed through FFAULT. FILBUF and FLSBUF handle +i/o to text files directly. + +FFAULT makes a binary file appear to be a contiguous array (stream) of +characters, regardless of the device on which the file is resident, and +regardless of the block size. Image i/o and structure i/o depend on the +buffer management capabilities of FFAULT for efficient i/o. + +FFAULT must be able to deal with variable block size devices. The block +size is a run time variable, which is device dependent. +Magtapes and Mem files, for example, have a block size of one char, +whereas most disks have 256 char blocks (assuming two machine bytes per char). + +Image i/o requires that the number and size of the buffers for a file +be variable, and that asynchronous i/o be possible. The size of a +buffer, and the size of the data segment to be read in (normally one +row in the case of two dimensional imagefiles) need not be the same. + +Structure or virtual i/o is based on a global pool of buffers, shared +amongst all the files currently mapped for virtual i/o. Each buffer +in the pool is always linked into the list for the global pool, and is +also linked into the local list for a file, when containing data from +that file. New buffers are allocated from the tail of the global list. + +The virtual i/o primitives interface to file i/o via READ and WRITE +requests on a mapped file. FFAULT is required to manage the global pool +properly when faulting on a mapped file. The number and size of the +buffers in the global pool are run time variables. + +FFAULT calculates the file offset of the new buffer implied by the offset +argument (note that offset may be BOF or EOF as well as a real offset). +No actual i/o takes place if the data is already buffered. + + + +.tp 5 +.nf +int procedure ffault (fd, char_offset) + +fd: file descriptor number +char_offset: desired char offset in file + +begin + calculate buffer_offset (modulus block size) + if (i/o in progress on file fd) + wait for completion (awatio) + + if (buffer is already in local pool) + relink buffer at head of list (frelnk) + else { + if (buffer has been written into) + flush to file (fflsbf) + relink next buffer at head of lists (frelnk) + set buffer offset for new buffer + fill buffer from file (ffilbf) + } + + if (file is being accessed sequentially) + initiate write behind or read ahead + + set iop corresponding to desired char_offset + return (status: OK, ERR, or EOF) +end +.fi + + +.sh +Verification of the File Fault Procedure + + The database managed by FFAULT consists of the local and global +buffer lists, and the file descriptor structure. The major types of +file access are (1) sequential read, (2) write at EOF, (3) random +access, and (4) sequential write not at EOF. A mode change may occur +at any time. In what follows, we follow the logic of FFAULT through +for these four modes of access, to verify that FFAULT works properly +in each case. + +.tp 4 +.ls 4 Case 1: Sequential Read + +FFAULT will detect the sequential nature of the read requests, and will +begin reading ahead asychronously. No writing occurs, since the buffer +is never written into. If a buffer were to be written into, the subsequent +write i/o operation would cause read ahead to be interrupted for a time +(random mode would be asserted temporarily). + +.ks +.nf + normally, read ahead will be in progress + wait for i/o + buffer is now in pool + relink buffer at head of lists + initiate i/o on next available buffer + + when EOF is detected, buffer is zeroed, EOF is returned +.fi +.ke +.le + +.tp 4 +.ls Case 2: Sequential Write at EOF + +When writing at EOF, FFAULT will detect the fact that the writes are +occurring sequentially, and will start flushing the newly filled buffers +asynchronously. Read ahead does not occur, since the file is positioned +at EOF. + +.ks +.nf + normally, write behind will be in progress + wait for i/o + get next buffer (will not need to be flushed, due to + automatic write behind) + relink buffer at head of lists + fill buffer (no actual file access when at EOF) + initiate write behind of most recent buffer +.fi +.ke +.le + +.tp 4 +.ls Case 3: Random Access + +Old buffer is left in pool. No i/o is done on the old buffer, regardless +of whether the old buffer has been written into or not (unless there is only +one buffer in the pool). The buffer pool serves as a cache, with the buffers +linked in order of most recent access. Read ahead and write behind do not +occur as long as the pattern of access remains random. + +.ks +.nf + no i/o in progress + buffer not in pool + take buffer from tail of list + relink buffer at head of lists + if (buffer needs to be flushed) + flush it, wait for completion + fill buffer +.fi +.ke +.le + +.tp 4 +.ls Case 4: Sequential Write not at EOF + +This mode differs from write at EOF in that read and write i/o operations +are interspersed. Since only one i/o operation can be in effect on a +given file at one time, we cannot both read ahead and write behind. +Write behind will occur, but reading will not be asynchrounous. + +.ks +.nf + wait for i/o + buffer not in pool + take buffer from tail of list + relink buffer at head of lists + buffer will not need to be flushed, due to write behind + fill buffer, wait for completion + initiate write behind of most recent buffer +.fi +.ke +.le + + + + +.fi +In certain circumstances, such as when IMIO overwrites a line of an +image, where each line is known to be aligned on a block boundary, +the "fill buffer" operation can be omitted (since it is guaranteed +that the entire contents of the buffer will be overwritten before the +buffer is flushed). The fill buffer operation is disabled via an FSET +option. Both access modes 3 and 4 are affected, yielding a factor +of two reduction in the number of i/o transfers. + + + + +.tp 5 +.nf +procedure ffilbf (fd, bufdes) + +fd: file descriptor number +bufdes: buffer descriptor + +begin + if (at EOF) + return + else { + if (io in progress on file fd) + call fwatio to wait for completion of transfer + fbseek (fd, bufdes) + aread (fd, Memc[bufptr], buffer_size) + + set i/o mode word in buffer descriptor + set pointer to active buffer in file descriptor + } +end + + + +.fi +The FFLSBF routine is called by FFAULT to actually flush a buffer to +the file. Note that if the buffer is at the end of the file, and the +buffer is only partially full, a partially full block will be written. +If partial file blocks are not permitted by the underlying system, +the z-routine must compensate. + + + +.tp 6 +.nf +procedure fflsbf (fd, bufdes) + +fd: file descriptor number +bufdes: buffer descriptor + +begin + if (no write permission on file) + take error action + if (io in progress on file fd) + call fwatio to wait for completion of transfer + + nchars = max (iop, itop) - bufptr + fbseek (fd, bufdes) + awrite (fd, Memc[bufptr], nchars) + + set i/o mode word in buffer descriptor + set pointer to active buffer in file descriptor +end + + + + +.tp 5 +procedure fwatio (fd) + +begin + if (i/o mode == NULL) + return + nchars = await (fd) + + if (nchars == ERR) + set ERROR bit in status word + else { + # set i/o pointers in buffer descriptor + if (i/o mode == READ_IN_PROGRESS) + itop = bufptr + nchars + else + # don't change itop, data still valid + otop = bufptr + clear i/o mode word in buffer descriptor + clear pointer to active buffer in file descriptor + } +end + + + + +.tp 5 +procedure fbseek (fd, bufdes) + +begin + if (current_offset != buffer_offset) + aseek (fd, buffer_offset) +end + + + + +.fi +SEEK is used to move the file pointer (offset in a file at which the +next data transfer will occur). With text files, one can only seek +to the start of a line, the position of which must have been determined +by a prior call to NOTE. For binary files, SEEK merely sets the logical +offset within the file. This will usually cause a file fault when the +next i/o transfer occurs. An actual physical seek does not occur until +the fault occurs. + +The logical offset is the character offset in the file at which the next +i/o transfer will occur. In general, there is no simple relationship +between the logical offset and the actual physical offset in the file. +The physical offset is the file offset at which the next AREAD or AWRITE +transfer will occur, and is maintained by those routines and by the system. +The logical offset may be set to any character in a file. The physical +offset is always a multiple of the device block size. + +The logical offset is defined at all times by the offset of the current +buffer (buf_offset), and by the offset within the buffer (iop-bufptr). +The logical offset may take on the special values BOF and EOF. +Since the offset of the first character in a file is one (1), +and BOF and EOF are zero or negative, the special offsets are unambiguous. + +.rj (logical offset) + new iop = offset - buf_offset + bufptr + +A logical seek on a binary file is effected merely by setting the in-buffer +pointer IOP according to the relation shown above. A macro LSEEK (fd, offset) +is defined to perform a logical seek with inline code. +.nf + + + +.tp 5 +procedure seek (fd, offset) + +begin + verify that fd is a legal file descriptor of an open file + clear any pushback + + # make newly written data readable + itop = max (itop, iop) + + if (TEXT_FILE) { + if (buffer has been written into) + call zputtx to flush buffer to file + reset iop to beginning of buffer + if (offset is not equal to offset of buffer) + call zsektx routine to seek on text file + } else + lseek (fd, offset) +end + + + + +.tp 5 +long procedure note (fd) # note file position for later seek + +begin + verify that fd is a legal file descriptor of an open file + + if (TEXT_FILE) { + call znottx to get offset into text file + if (a buffer is in use) + save offset of buffer in buffer descriptor + return (offset) + } else + return (logical offset) +end + + + + +.tp 5 +procedure flush (fd) + +begin + verify fd: file open with write permission + + if (TEXT_FILE) + if (buffer has been written into) { + call zputtx to write out buffer + reset buffer pointers + } + else + for (each buffer in local pool) + if (buffer has been written into) + call fflsbf to flush buffer +end + + + + +.fi +The asynchronous i/o primitives ZAREAD and ZAWRIT must enforce device block +boundaries. Thus, if maxchars is not an integral multiple of the block size, +the file pointer will nonetheless be advanced to the next block boundary. +Some files (such as Mem files and magtapes) may have a block size of one char. + +Note that memory may be accessed as a "file". This facility is most often +used by the formatted i/o routines, to decode and encode character data in +strings. On a virtual memory machine, an entire binary file could be mapped +into memory, then opened with MEMOPEN as a memory resident file (this would +in effect replaces the FFAULT file faults by hardware page faults). + +The calling program is required to call AWAIT after an AREAD or AWRITE call to +a file, before issuing the next i/o request to that file. Failure to do so +causes an error action to be taken. This is done to ensure that the success +or failure of the i/o transfer (the status returned by AWAIT) is checked by +the calling program. + +The z-routines ZCALL2 and ZCALL3 are machine dependent routines which +call the procedure whose entry point address is given as the first argument. +The numeric suffix N means that the procedure given as the first argument is +to be called with N arguments, the values of which make up the remaining +arguments to ZCALL. The additional machine dependence of this routine +is thought to be more than justified by the clean, flexible interface +which it provides between FIO and the various supported devices. +.nf + + + +.tp 5 +procedure aread (fd, buffer, maxchars) + +begin + check that fd is a valid file opened for reading + if (i/o is already in progress on file fd) + error: "i/o already in progress" + set read_in_progress word in file descriptor + + zcall3 (zaread[fd], channel[fd], buffer, maxchars) +end + + + +.fi +Note that FIO, when it seeks to the end of a file for a buffered binary +write, actually seeks to the nearest block boundary preceeding the physical +EOF which is an integral multiple of the file buffer size. When the file +buffer fills, it is flushed out, OVERWRITING THE EOF. This may pose problems +for the implementor of the ZAWRITE routine on some systems. + + + +.tp 5 +.nf +procedure awrite (fd, buffer, maxchars) + +begin + check that fd is a valid file opened for writing + if (i/o is already in progress on file fd) + error: "i/o already in progress" + set write_in_progress in i/o mode word in file descriptor + + zcall3 (zawrite[fd], channel[fd], buffer, maxchars) +end + + + + +.tp 5 +int procedure await (fd) + +begin + verify thaf fd is a legal file descriptor of an open file + + if (bad error code in file descriptor) + set status to ERR + else if (no io in progress on file fd) + return (0) + else + zcall2 (zawait[fd], channel[fd], status) + + switch (status) { + case ERR: + set error code in file descriptor + case EOF: + set EOF flag + default: + increment file position counter by N file blocks + set nchars_last_transfer in file descriptor + } + + clear io_in_progress word in file descriptor + return (status) +end + + + + +.tp 5 +procedure aseek (fd, offset) + +begin + switch (offset) { + case BOF: + char_offset = 1 + clear at EOF flag + case EOF: + if (already at EOF) + return + else { + zcall2 (zaseek[fd], channel[fd], EOF) + current_offset = anote (fd) + char_offset = current_offset + set at EOF flag + } + default: + char_offset = offset + clear at EOF flag + } + + # can seek only to the beginning of a device block + block_offset = char_offset - mod (char_offset-1, block_size) + + zcall2 (zaseek[fd], channel[fd], block_offset) + if (anote(fd) != block_offset) + take error action +end + + + +.tp 5 +long procedure anote (fd) + +begin + zcall2 (zanote[fd], channel[fd], current_offset) + return (current_offset) +end +.fi + + + +.sh +Z-ROUTINES REQUIRED TO INTERFACE TO A BINARY DEVICE + + The interface between FIO and a binary device is defined by a set of +six so called z-routines. These routines may be as device and system +dependent as necessary, provided the standard calling sequences and semantics +are implemented. + +The following z-routines are required for each device serviced by FIO. +Since only the entry point addresses are given to FIO, the actual names +are arbitrary, but must be distinct to avoid collisions. The names shown +are reserved. + +.ks +.nf + zaread (channel, buffer, maxchars) + zawrit (channel, buffer, maxchars) + zawait (channel, nchars/EOF/ERR) + zaseek (channel, char_offset/BOF/EOF) + zanote (channel, char_offset) + zblksz (channel, device_block_size_in_chars) +.fi +.ke + +The exact specifications of these routines will be detailed in the system +interface documentation. + + +The following binary devices are fully supported by the program interface: + + +.ks +.nf + device type initialization + + regular random access binary files OPEN + the CL interface (STDIN,STDOUT,...) task startup + pipes CONNECT + memory MEMOPEN + magnetic tapes MTOPEN + graphics devices GOPEN +.fi +.ke + + +A new device may be interfaced to FIO at run time with the procedure FIODEV. +Repetitive calls to FIODEV for the same device are harmless and are +ignored. The maximum number of devices that may be interfaced to FIO is set +when FIO is compiled. An error action will occur if this number is exceedd. + + fiodev (zaread, zawrit, zawait, zaseek, zanote, zblksz) + +The purpose of FIODEV is to make the entry points of the z-routines for the +new device known to FIO. The device table is indexed by the entry point +address of the ZAREAD procedure, which must therefore be distinct for each +device. + +A default device is associated with a file when the file is opened. +To specify a device other than the default device requires a call to FSET, +passing the entry point address of the ZAREAD procedure for the device. +The device must have been installed with the FIODEV call by the time FSET +is called to associate the device with a particular file, or an error action +will result. + + +.sh +SEMICODE FOR THE FIO INITIALIZATION AND CONTROL PROCEDURES + + Before any i/o can be done on a file, the file must be opened. The +standard OPEN procedure may be used to access ordinary files containing either +text or binary data. To access a file on one of the special devices, a special +open procedure must be used (MEMOPEN, MTOPEN, ..). + +All file open procedures are alike in that they call the FIO routine +FGETFD to allocate and initialize (with defaults) a file descriptor. +Assorted calls to FSET and possibly FIODEV may optionally follow, +if the default file parameters are not applicable to the device in question. + + + + +.ks +.nf + open close + + + + + fgetfd frtnfd flush + + + + + zmapfn zopen malloc mfree zclose + + + + Structure of the Initialization Procedures +.fi +.ke + + + + +.tp 5 +.nf +int procedure open (file, mode, type) + +file: file name (EOS terminated character string) +mode: type of access permission desired +type: file type (text or binary) + +begin + # allocate and initialize file descriptor + fd = fgetfd (file, mode, type) + if (fd == ERR) { + set error code in file descriptor + return (ERR) + } + + # map virtual file name to OS file name + zmapfn (file, osfname, SZ_OSFNAME) + + switch (type) { # open file + case TEXT_FILE: + zopntx (osfname, mode, channel[fd]) + case BINARY_FILE: + zopenb (osfname, mode, channel[fd]) + default: + set error code in file descriptor + channel[fd] = ERR + } + + if (channel[fd] == ERR) { + frtnfd (fd) # return file descriptor + return (ERR) + } else + return (fd) +end + + + +.fi +To conserve resources (file descriptors, buffer space) a file should be +closed when no longer needed. Any file buffers that may have been +created and written into will be flushed before being deallocated. + +CLOSE ignores any attempts to close STDIN or CLIN. Attempts to close +STDOUT, STDERR, or CLOUT cause the respective output byte stream to be +flushed, but are otherwise ignored. An error action results if one +attempts to close a file which is not open, or if one attempts to close +a file which was not opened with OPEN. +.nf + + + +.tp 5 +procedure close (fd) # close an opened file + +begin + if (fd == STDIN || fd = CLIN) { + return + } else if (fd == STDOUT || fd == STDERR || fd == CLOUT) { + flush (fd) + return + } else if (fd is not a valid file descriptor of an open file) { + take error action + } else if (file device is not a standard one) + take error action + + flush (fd) + zclose (channel[fd]) + frtnfd (fd) +end + + + + + +.tp 5 +int procedure fgetfd (file, mode, type) # get file descriptor + +file: file name (EOS terminated character string) +mode: type of access permission desired +type: file type (text or binary) + +begin + # find an unused file descriptor slot + for (fd=FIRST_FD; fd <= LAST_FD; fd=fd+1) + if (fdes[fd] == NULL) + break + if (fd > LAST_FD) + return (ERR) + + # allocate memory for file descriptor proper + fdes[fd] = malloc (sizeof_struct_fiodes, TY_CHAR) + if (fdes[fd] == NULL) + return (ERR) + + initialize fields of file descriptor to default values + return (fd) +end + + + + +.tp 5 +procedure frtnfd (fd) # return file descriptor and buffers + +begin + if (fdes[fd] == NULL) + return + + # deallocate file buffers, if any + + if (file takes its buffers from the global pool) { + if (any buffers were actually ever allocated) + decrement reference count of files using global pool + for (each buffer in the local list) { + unlink buffer from the local list + if (global pool reference count is zero) { + unlink buffer from the global list + return buffer space to the system + } else + link at tail of the global list + } + } else + for (each buffer in the local list) { + unlink buffer from the local list + return buffer space to the system + } + + if (push back buffer exists) + return push-back buffer + + mfree (fdes[fd], TY_CHAR) + fdes[fd] = NULL +end +.fi + + +.sh +SETTING AND INSPECTING THE FIO CONTROL PARAMETERS + + Any file may be accessed after specifying only the file name, access +mode, and file type parameters in the OPEN call. +Occasionally, however, it is desirable to change the default file control +parameters, to optimize i/o to the file. The IMIO and VSIO interfaces, +for example, control the size, number, and ownership of the FIO file buffers. + + +.ks +.nf + fset (fd, parameter, value) + value = fget (fd, parameter) +.fi +.ke + + +The FSET procedure is used to set the FIO parameters for a particular file, +while FGET is used to inspect the values of these parameters. The special +value DEFAULT will restore the default value of the indicated parameter. +The following parameters are defined: + +.ls 4 +.ls 15 ADVICE +This parameter is used to advise FIO on the type of access expected for +the file. The legal values are SEQUENTIAL and RANDOM. Given such advice, +FIO will set up the buffers for the file using system dependent defaults +for the buffer types, sizes, and numbers. ADVICE is more system independent +than explicit calls to NBUFFERS, BUF_SIZE, and so on. +.le +.ls ASYNC_IO +If enabled (value = YES), and there are two or more buffers in the pool, +FIO will employ read ahead and early write behind when a sequential pattern +of i/o is detected. Specifying NO for this parameter guarantees that +buffered data will be retained until reuse of a buffer is forced by a fault. +Note that even if ASYNC_IO is enabled, read ahead and early write behind +are ONLY used while the pattern of i/o remains sequential. +.le +.ls BUF_SIZE +The size of a file buffer, in chars. The actual size of the buffer +created and used by FIO depends on the device block size and may be larger +than BUF_SIZE, but will not be any smaller. +.le +.ls BUF_TYPE +This parameter may have one of two values, LOCAL or GLOBAL, specifying whether +a local pool of buffers is to be created, or whether buffers are to be drawn +from the global pool. +.le +.ls FIO_DEVICE +The value given must be the entry point address of the ZAREAD procedure +for the desired device. The device must have been installed in the FIO +device table by a prior call to FIODEV. +.le +.ls FLUSH_NL +If enabled, the output buffer will be flushed after every line of output text, +rather than when the buffer fills or when a flush is otherwise forced. +Useful when the output file is an interactive terminal. +.le +.ls GBUF_SIZE +The size of a buffer in the global pool, in chars. +The FD parameter is ignored. +.le +.ls GNBUFFERS +The number of file buffers in the global pool. +The FD parameter is ignored. +.le +.ls NBUFFERS +The number of file buffers in the local pool. +.le +.ls PBB_SIZE +The size of the combined push back buffer and push back control stack area, +in chars. +.le +.le + + +The parameters controlling the size and number of the various buffers +(ADVICE, NBUFFERS, BUF_SIZE, BUF_TYPE, PBB_SIZE, GNBUFFERS, GBUF_SIZE) must +be set before i/o causes the affected buffers to be created using the default +number and size parameters. Thereafter, FSET calls to change these parameters +will be ignored. The values of the other parameters may be changed at any +time, with the new values taking effect immediately. + +.sh +Example 1: File access is expected to be highly random. + + The most system independent approach is to call FSET to set the +ADVICE parameter to RANDOM. + + +.nf + include + ... + + fd = open (file, READ_WRITE, BINARY_FILE) + if (fd == ERR) + ... + + call fset (fd, ADVICE, RANDOM) +.fi + +.sh +Example 2: High speed sequential access is desired + + In this case, the best approach would again be to call FSET to set ADVICE +to SEQUENTIAL. To demonstrate use of some of the other parameters, we have +taken a different approach here. + + +.nf + fd = open (file, READ_ONLY, BINARY_FILE) + if (fd == ERR) + ... + + call fset (fd, NBUFFERS, 2) + call fset (fd, BUF_SIZE, SZ_BLOCK * 16) + call fset (fd, ASYNC_IO, YES) +.fi + + +In practice it will rarely be necessary for the user to call FSET, because +the facilities provided by VSIO and IMIO (which do call FSET in the manner +shown) will probably provide the desired i/o capability, without need to +resort to the comparatively low level facilities provided by FIO. +Another reason for NOT calling FSET is that the system provided defaults +may indeed be best for the system on which the software is being run. + +The default values selected for the FIO parameters may be tuned to the +particular system. At one extreme, for example, we might provide a global +pool containing only two buffers, each the size of a single disk block. +By default, all files would share these buffers, and asynchronous i/o +would be disabled. This would be the minimum memory configuration. +At the other extreme, we might allocate two large buffers to each file, +with asynchronous i/o enabled. + + +.sh +DETAILS OF THE FIO DATA STRUCTURES + + By this point we have sufficiently detailed information about the +functioning of FIO to be able to fill in the details of the data +structures. The FIO database consists of the MAXFD file descriptors, +the global buffer pool, the descriptor for the global pool, and the +device table. Each file descriptor controls a local list of buffers, +and possibly a buffer for pushed back data. A buffer descriptor +structure is associated with each file buffer. + + + +.ks +.nf +# Static part of file descriptor structures + +common fiocom { + int gnbufs # size of global pool + int gbufsize # size of global buffer + int gnref # number of files using gpool + struct bufdes *ghead # head of the global list + struct bufdes *gtail # tail of the local list + int ndev # number of devices + int zdev[SZ_DEVTBL] # device table + char *iop[MAXFD] # i/o pointer + char *itop[MAXFD] # itop for current buffer + char *otop[MAXFD] # otop for current buffer + char *bufptr[MAXFD] # pointer to current buffer + long offset[MAXFD] # offset of the current buffer + struct fiodes *fdes[MAXFD] # pointer to rest of fd + char osfname[SZ_OSFNAME] # buffer for OS file names +} +.fi +.ke + + +.ks +.nf +# Template for dynamically allocated part of file descriptor + +struct fiodes { + char fname[SZ_FNAME] # file name string + int fmode # mode of access + int ftype # type of file + int fchan # OS file number (channel) + int fdev # index into device table + int bufsize # size of a file buffer + int pbbsize # size of pushback buffer + int nbufs # number of local buffers + int fflags # flag bits + int nchars # size of last transfer + int iomode # set if i/o in progress + int errcode # error code + long fpos # actual file position + char *pbbp # pointer to pushback buffer + char *pbsp # pushback stack pointer + char *pbsp0 # pointer to stack elem 0 + struct bufdes *iobuf # buffer i/o being done on + struct bufdes *lhead # head of local list + struct bufdes *ltail # tail of local list +} +.fi +.ke + + +.nf +# flags (saved in fdes[fd].fflags) + + F_ASYNC # enable async_io + F_EOF # true if at EOF + F_ERR # set when error occurs + F_FLUSHNL # flush after newline + F_GLOBAL # local or global buffers + F_RANDOM # optimize for rand. access + F_READ # read perm on file + F_SEQUENTIAL # optimize for seq. access + F_WRITE # write perm on file +.fi + + + +.ks +.nf +# Buffer descriptor structure. + +struct bufdes { + int b_fd # fd to which buffer belongs + int b_iomode # set when i/o in progress + int b_bufsize # size of buffer, chars + long b_offset # offset of buffer in file + char *b_itop # saved itop + char *b_otop # saved otop + char *b_bufptr # pointer to start of buffer + struct bufdes *luplnk # next buffer up, local list + struct bufdes *ldnlnk # next buffer down, local list + struct bufdes *guplnk # next buffer up, global list + struct bufdes *gdnlnk # next buffer down, global list +} +.fi +.ke + + +.sh +SEMICODE FOR THE FIO DATABASE ACCESS PROCEDURES + + Routines are required to allocate and deallocate buffers, +and to link and unlink buffers from the buffer lists. Now that the +data structures have been more clearly defined, we shall go into a +little more detail in the semicode. + + +.ks +.nf + fmkbfs + + + + fmklst + + + + flnkhd fmkbuf flnktl + + + + malloc + + + + Structure of the Buffer Allocation Procedures +.fi +.ke + + + +The main buffer creation procedure, FMKBFS, is called by either +FILBUF or FLSBUF when i/o is first done on a file. FMKLST allocates +a set of buffers and links them into a doubly linked list. FLNKHD +links a buffer at the head of a list, while FLNKTL links a buffer at +the tail of a list. FMKBUF calls MALLOC to allocate memory for a file +buffer, and initializes the descriptor for the buffer. + + + + +.tp 5 +.nf +procedure fmkbfs (fd) + +fd: file descriptor number +fp: pointer to file descriptor +bp: pointer to buffer descriptor + +begin + if (use global pool) { + if (no buffers in global pool yet) { + gnbufs = fmklst (NULL, gnbufs, gbufsize, GLOBAL) + if (gnbufs <= 0) # can't make buffers + take error action + } + gnref = gnref + 1 + + } else { # create local buffers + adjust bufsize to be an integral number of device blocks + fp = fdes[fd] + fp.nbufs = fmklst (fd, fp.nbufs, bufsize, LOCAL) + + if (fp.nbufs == 0) # must be at least one + take error action + } +end + + + +.fi +Unlink a buffer from whatever lists it is on, relink it at head of the +local list, and also at head of global list if a mapped file. Called +by FFAULT. +.nf + + +.tp 5 +procedure frelnk (fd, bp) + +fd: file descriptor number +bp: pointer to buffer descriptor + +begin + # relink buffer at head of the local list for file fd + call funlnk (bp, LOCAL) + call flnkhd (fd, bp, LOCAL) + + # relink at head of global list, if buffer in global pool + if (buffer is linked into the global pool) { + call funlnk (bp, GLOBAL) + call flnkhd (fd, bp, GLOBAL) + } +end + + + + +.tp 5 +int procedure fmklst (fd, nbufs, bufsize, list) # make list + +list: either global or local +bufdes: pointer to buffer descriptor + +begin + for (nb=0; nb <= nbufs; nb=nb+1) { + bufdes = fmkbuf (fd, bufsize) + if (bufdes == NULL) + break + else if (nb == 1) + flnkhd (fd, bufdes, list) + flnktl (fd, bufdes, list) + } + return (nb) +end + + + + +.tp 5 +int procedure fmkbuf (fd, bufsize) # make a buffer + +begin + assert (bufsize > 0 && mod (bufsize, block_size) == 0) + + sizeof_buffer = sizeof (struct bufdes) + bufsize + bufdes_pointer = malloc (sizeof_buffer, TY_CHAR) + if (bufdes_pointer == NULL) + return (NULL) + else { + initialize buffer descriptor + return (bufdes_pointer) + } +end + + + + +.tp 5 +procedure flnkhd (fd, bp, list) # link buf at head of list + +fd: file descriptor number +bp: pointer to buffer descriptor +list: global or local +fp: pointer to file descriptor + +begin + assert (bp != NULL) + assert (list == LOCAL || list == GLOBAL) + + switch (list) { + case GLOBAL: + if (buffer not already linked at head of list) { + bp.gdnlnk = ghead + ghead.guplnk = bp + ghead = bp + } + case LOCAL: + fp = fdes[fd] + if (buffer not already linked at head of list) { + bp.fd = fd + bp.ldnlnk = fp.lhead + if (fp.lhead != NULL) + fp.lhead.luplnk = bp + fp.lhead = bp + } + } +end + + + + +.tp 5 +procedure flnktl (fd, bp, list) # link buf at tail of list + +fd: file descriptor number +bp: pointer to buffer descriptor +list: global or local +fp: pointer to file descriptor + +begin + assert (bp != NULL) + assert (list == LOCAL || list == GLOBAL) + + switch (list) { + case GLOBAL: + if (buffer not already linked at tail of list) { + bp.guplnk = gtail + gtail.gdnlnk = bp + gtail = bp + } + case LOCAL: + fp = fdes[fd] + if (buffer not already linked at tail of list) { + bp.fd = fd + bp.luplnk = fp.ltail + if (fp.ltail != NULL) + fp.ltail.ldnlnk = bp + fp.ltail = bp + } + } +end + + + + +.tp 5 +procedure flnkto (fd, bp, to) # link buf bp after to + +bp: pointer to descriptor of buffer to be linked +to: pointer to descriptor of buffer to be linked to + +begin + bp.ldnlnk = to.ldnlnk + bp.luplnk = to + to.ldnlnk = bp + if (bp.ldnlnk == NULL) + fdes[fd].ltail = bp # new tail of list + else + bp.ldnlnk.luplnk = bp +end + + + + +.tp 5 +procedure funlnk (bp, list) # unlink from list + +bp: pointer to buffer descriptor +list: global or local +fp: pointer to file descriptor + +begin + switch (list) { + + case GLOBAL: + if (buffer is at head of the global list) + ghead = bp.gdnlnk + if (buffer is at tail of the global list) + gtail = bp.guplnk + if (bp.guplnk != NULL) + bp.guplnk.gdnlnk = bp.gdnlnk + if (bp.gdnlnk != NULL) + bp.gdnlnk.guplnk = bp.guplnk + + case LOCAL: + fp = fdes[bp.fd] + if (buffer is at head of the local list) + fp.lhead = bp.ldnlnk + if (buffer is at tail of the local list) + fp.ltail = bp.luplnk + if (bp.luplnk != NULL) + bp.luplnk.ldnlnk = bp.ldnlnk + if (bp.ldnlnk != NULL) + bp.ldnlnk.luplnk = bp.luplnk + } +end +.fi + + +.sh +SEMICODE FOR FFAULT, AGAIN + + The file fault procedure lies at the heart of FIO. Now that the +data structures, initialization procedures, and linked list operators are +clearer, it is time to go back and fill in some of the details in FFAULT. + + + +.tp 5 +.nf +int procedure ffault (fd, char_offset) + +fd: file descriptor number +char_offset: desired char offset in file +bp: pointer to a buffer descriptor +fp: pointer to the file descriptor + +begin + # calculate buffer_offset (modulus file buffer size) + buffer_offset = char_offset - mod(char_offset, buffer_size) + 1 + + # compute pointers to fd structure, current buffer + fp = fdes[fd] + bp = fp.lhead + + # update i/o pointers in the buffer descriptor + # note writes may have pushed iop beyond original itop + itop[fd] = max(itop[fd], iop[fd]) + if (bp != NULL) { + bp.b_itop = itop[fd] + bp.b_otop = otop[fd] + } + + # if buffer is found in local pool, relink at head of list. + if (ffndbf (fd, buffer_offset, bp) == YES) { + frelnk (fd, bp) + itop[fd] = bp.b_itop + otop[fd] = bp.b_otop + + # this next section of code is invoked whenever a fault + # occurs which requires an actual i/o transfer. + + } else { + if (bp.otop != bp.b_bufptr) # buffer dirty? + fflsbf (fd, bp) # flush buffer + + frelnk (fd, bp) # relink at head + bp.b_offset = buffer_offset + + if (F_READ flag is set) { + ffilbf (fd, bp) # fill buffer + fwatio (fd) + } else { + bp.b_itop = bp.b_bufptr + bp.b_otop = bp.b_bufptr + } + + # if asynchronous i/o is enabled (only if two or more + # buffers) initiate write behind or read ahead, if + # fwatio has detected a sequential pattern of i/o. + + if (ASYNC_IO enabled) + switch (io_pattern) { + case WSEQ: # write behind + bufp = bp.ldnlnk + if (bufp != NULL) + if (bufp.b_otop != bufp.b_bufptr) + fflsbf (fd, bufp) + case RSEQ: # read ahead + new_buffer_offset = buffer_offset + buffer_size + if (ffndbf (fd, new_buffer_offset, bufp) == YES) + # skip read ahead, buffer already in pool + else if (bufp.b_otop == bufp.b_bufptr) { + if (bufp.luplnk != fp.lhead) { + funlnk (bufp, LOCAL) + flnkto (bp, bufp, fp.lhead) + } + if (buffer in global pool) { + funlnk (bufp, GLOBAL) + flnkhd (bufp, GLOBAL) + } + bufp.b_offset = new_buffer_offset + ffilbf (fd, bufp) + } + } + } + + bufptr[fd] = bp.b_bufptr # set i/o pointers + offset[fd] = buffer_offset + lseek (fd, char_offset) + + if (fp.status == ERR) # check for ERR,EOF + return (ERR) + else if (iop[fd] == itop[fd]) + return (EOF) + else + return (itop[fd] - iop[fd]) # return nchars +end + + + + +# Search for a file buffer. If found, return buffer pointer in BP, +# otherwise allocate a buffer from the tail of either the global or +# local list. + + +.tp 5 +int procedure ffndbf (fd, buffer_offset, bp) + +begin + # desired buffer may be on the way; wait and see + if (read in progress on file fd) + fwatio (fd) + + # search local pool for the buffer + for (bp = fp.lhead; bp != NULL; bp = bp.ldnlnk) + if (bp.b_offset == buffer_offset) + break + + # if buffer already in pool, return buffer pointer, + # otherwise use oldest buffer in appropriate list. + + if (bp != NULL) # buffer found in pool + return (YES) + else { # use buffer at tail of list + if (this file uses global pool) { + bp = gtail + if (io in progress on this buffer) + fwatio (bp.fd) + } else + bp = fp.ltail + return (NO) + } + +end +.fi + + +.sh +SUMMARY OF THE FIO/OS INTERFACE (MACHINE DEPENDENT PRIMITIVES) + + FIO depends on a number of machine dependent primitives. Many of these +have been introduced in the semicode. Other primitives are not involved in +i/o, and hence have not appeared thus far in the discussion. Primitives are +required to map virtual file names into OS file names. + +The goal in designing the FIO/OS interface was to make the primitives as +"primitive" as feasible, rather than to minimize the number of primitives. +These primitives should be easy to implement on almost any modern minicomputer. +The ideal target OS will provide asynchronous, random access i/o, +logical name facilities, multiple directories per task, multitasking and +intertask communication facilities, and dynamic memory allocation/deallocation +facilities. + + +.nf +Text Files + + zopntx (osfn, access_mode; chan) + + zgettx (chan, line_buf, maxchars; nchars) + zputtx (chan, line_buf, nchars; nchars) + zflstx (chan) + zfsttx (chan, what; status_info) + zclstx (chan) + zsektx (chan, znotln_offset; status) + znottx (chan; file_offset) + + +Binary File Initialization (one set per device) + + zopnbf (osfn, access_mode; chan) + zfaloc (osfn, nchars; chan) + + +Binary File I/O primitives (one set per device) + + zaread (chan, buffer, maxchars, file_offset) + zawrit (chan, buffer, maxchars, file_offset) + zawait (chan; status) + zfsttb (chan, what; status_info) + zclsbf (chan; status) + + standard devices: regular files, inter-task pipes (CL,GIO), + memory, magnetic tapes. + + +Virtual File Name Mapping + + zmapfn (vfn, osfn, maxch) + zabsfn (vfn, osfn, maxch) + + +File Manipulation, Status, File Protection, Temporary Files + + zacces (osfn, mode, type; status) + zfdele (osfn; status) + zrenam (from_osfn, to_osfn; status) + zfprot (osfn) + zmktmp (root, temp_file_osfn) + + +Other Dependencies (also used outside of FIO) + + zcallN (entry_point, arg1, ..., argN) + pntr = malloc (nelements, data_type) + pntr = calloc (nelements, data_type) + mfree (pntr, data_type) + int = and (int, int) + int = or (int, int) + int = loc (reference) +.fi + + +The STATUS returned by the Z-routines may be ERR or a meaningful number, +such as the channel number or number of characters read or written. +EOF is signified at this level by a return value of zero for the number +of characters read (only ZGETTX and ZAREAD read from a file). There is +no provision for special error codes or messages at the Z-routine level. diff --git a/sys/fio/doc/fio.men b/sys/fio/doc/fio.men new file mode 100644 index 00000000..a0b2ddb6 --- /dev/null +++ b/sys/fio/doc/fio.men @@ -0,0 +1,50 @@ + access - Determine the type or accessibility of a file + aread - Asynchronous read from a binary file + areadb - Asynchronous read from a binary file in byte units + await - Wait for an asynchronous i/o transfer to complete + awaitb - Wait for i/o, and return status in byte units + awrite - Asynchronous write to a binary file + awriteb - Asynchronous write to a binary file in byte units + close - Close a file + delete - Delete a file + diropen - Open a directory as a text file + falloc - Preallocate (uninitialized) storage for a file + fcopy - Copy a file + fdevbf - Install a new binary device in the FIO device table + fdevtx - Install a new text device in the FIO device table + finfo - Get directory information for a file + flush - Flush any buffered output to a file + fnextn - Extract the extension field of a filename + fnldir - Extract the logical directory field of a filename + fnroot - Extract the root field of a filename + fntcls - Close unbuffered list + fntclsb - Close buffered list + fntgfn - Get next filename from unbuffered list + fntgfnb - Get next filename from buffered list + fntlenb - Get number of filenames in a buffered list + fntopn - Open an unbuffered filename list + fntopnb - Expand template and open a buffered filename list + fntrewb - Rewind the list + fopnbf - Open a binary file on a special device + fopntx - Open a text file on a special device + fowner - Get the name of the owner of a file + fpathname - Get the full pathname of a file + fseti - Set an integer FIO parameter + fstati - Get the value of an integer FIO parameter + fstatl - Get the value of a long integer FIO parameter + fstats - Get the value of a string valued FIO parameter + getc - Get the next character from a file + getline - Get the next line from a text file + mktemp - Make a unique temporary filename + note - Note the long integer position in a file for a later seek + open - Open or create a text or binary file + protect - Protect a file from deletion + putc - Put a character to a file + putcc - Put only printable characters to a file + putline - Put a line to to a text file + read - Read a binary block of data from a file + rename - Change the name of a file + reopen - Reopen a file on another file descriptor + seek - Set the file offset of the next char to be read or written + stropen - Open a character string as a file + write - Write a binary block of data to a file diff --git a/sys/fio/doc/vfn.hlp b/sys/fio/doc/vfn.hlp new file mode 100644 index 00000000..d6c20e8b --- /dev/null +++ b/sys/fio/doc/vfn.hlp @@ -0,0 +1,1028 @@ +.help vfn Jul84 "Virtual Filename Mapping" +.ce +\fBVirtual Filename Mapping Package\fR +.ce +Detailed Design +.ce +Doug Tody +.ce +July 1984 +.sp 2 +.NH +Introduction + + This document presents the detailed design of the filename mapping +code, used by FIO to map virtual filenames (VFN's) to host operating system +filenames (OSFN's) and back again. A description of the filename mapping +algorithm is given in \fIThe Reference Manual for the IRAF System Interface\fR, +May 1984. The purpose of this document is more to design the software than +to document the design, hence much is omitted. The discussion concentrates +on those aspects of the problem which were least-understood at the time of +the design. + +.sh +Primary Functions + +.nf + map vfn->osfn + map osfn->vfn +.fi + +.sh +Functions for accessing the vfnmap file + +.nf + open and optionally lock vfnmap file + close and unlock vfnmap file + + add entry to vfnmap + delete entry from vfnmap + lookup entry in vfnmap +.fi + +.sh +Mapping Functions + +.nf + extract OSDIR prefix + extract LDIR prefix + expand LDIR + fold subdir into OSDIR + encode filename via escape sequence encoding + decode encoded filename + squeeze filename + map filename extension +.fi + + +.nh +VFN Virtual Filename Mapping Package + + The VFN package is used to map and unmap virtual filenames and to add and +delete virtual filenames from the VFN database. A distinct open operation is +required for each vfn to be accessed. Any number of vfn's may be simultaneously +open for reading, but only \fIone\fR vfn may be opened for writing. +The mapping file is not physically opened unless the escape sequence encoded +filename is degenerate. It is intended that the vfn will be opened for only +a brief period of time to minimize the amount of time that the mapping file +is locked. The mapping file is locked only if the vfn is degenerate and the +access mode is VFN_WRITE. The recognized vfn access modes are VFN_READ, +VFN_WRITE, and VFN_UNMAP (for reading directories). + + +.ks +.nf + vp = vfnopen (vfn, mode) + vfnclose (vp, update) + stat = vfnmap (vp, osfn) + stat = vfnadd (vp, osfn) + stat = vfndel (vp, osfn) + stat = vfnunmap (vp, osfn, vfn) + + stat = fmapfn (vfn, osfn) [=:vfnopen/RO,vfnmap,vfnclose] +.fi +.ke + + +A distinction is made between mapping the filename and opening and closing +the vfn to permit efficient and secure error recovery. The mapping file is +not updated on disk until the physical file operation (create, delete, etc) +has succeeded. If the operation fails \fBvfnclose\fR is called with NO_UPDATE +and the mapping file is not touched. The the vfn was opened VFN_READ the +update flag is ignored. No vfn disk data structures will be modified +if a vfn is closed with NO_UPDATE set. If updating is enabled, ".zmd" +dependency files may be created or deleted, the mapping file may be created, +deleted, or updated. + +The procedure \fBvfnmap\fR returns ERR if the vfn is degenerate but no entry +could be found in the mapping file, i.e., if the file does not exist. +A status value of OK does not, however, imply that the file exists. +\fBVfnadd\fR returns ERR if the vfn is degenerate and an entry already +exists in the mapping file. If the status return is OK and the vfn is +degenerate then a new entry has been added to the mapping file. +\fBVfndel\fR returns ERR if the vfn is degenerate but no entry +could be found in the mapping file. \fIOsfn\fR is returned as a packed string. +The output buffer should be dimensioned SZ_PATHNAME. + +.nh +Semicode for Selected FIO Procedures + + The RO class procedures call FMAPFN to map the VFN of an existing file +into an OSFN. These operations are straightforward since the vfn database +is not affected. + +.ks +.nf + access, fchdir, finfo, fpath, fprot: RO operations + falloc, open/NF, fmkcopy: RW=ADD procedures + delete RW=DEL procedure + rename RW=DEL+ADD +.fi +.ke + + +.nf +# FALLOC -- Create a new file and allocate uninitialized storage. Open/NF and +# make copy are similar operations hence the semicode is not shown. + +procedure falloc (vfn, size) + +begin + # Map filename and determine if a file already exists with the + # same name. + vp = vfnopen (vfn, VFN_WRITE) # LOCK + if (vfnadd (vp, osfn) == ERR) + existing_file = yes + else { + call zfacss to see if file exists + existing_file = yes if file exists + } + + # If file exists and clobber is enabled, try to delete the file. + # If filename is degenerate, entry is either already in mapping file + # (if file exists), or has been added. + + if (existing_file) + iferr { + if (file clobber enabled) + delete file + else + error ("falloc would clobber file 'vfn'") + } then { + vfnclose (vp, NO_UPDATE) + erract (EA_ERROR) + } + + # Allocate the new file and update the filename mapping database. + + call ZFALOC to allocate the file + if (failure) { + vfnclose (vp, NO_UPDATE) + error ("cannot allocate file 'vfn'") + } else + vfnclose (vp, UPDATE) # UNLOCK +end + + +# DELETE -- Delete a file and all subfiles. A subfile is a file which is +# logically part of the parent file but which is physically a separate file +# at the kernel level. An example is the pixel storage file associated with +# an image. Whenever a file is deleted all subfiles must be deleted as well. +# The subfiles need not reside in the same directory as the main file. +# Subfile information is maintained in a separate, "invisible" file for each +# file having subfiles. The subfile list file has the same vfn as the main +# file with the extension ".sfl" appended. If the vfn already had an extension +# it is retained in the root of the new filename. For example, the vfn of the +# subfile list file for "data.db" would be "data.db.sfl". + +procedure delete (vfn) + +begin + # Delete the main file + fdelpf (vfn) + + # Delete any subfiles. Print warning message if a subfile appears + # in the list but cannot be deleted. + + ifnoerr (fd = fsf_open (vfn, READ_ONLY)) { + while (getline (fd, subfilename, SZ_FNAME) != EOF) + iferr (fdelpf (subfilename)) + call erract (EA_WARN) + close (fd) + } +end + + +# FDELPF -- Delete a single physical file. Check if the file is protected +# and do not try to delete the file if it is protected. If file cannot be +# deleted, determine why and print appropriate error message, and do not update +# the mapping file. + +procedure fdelpf (vfn) + +begin + vp = vfnopen (vfn, VFN_WRITE) # LOCK + if (vfndel (vp, osfn) == ERR) { + vfnclose (vp, NO_UPDATE) + error ("attempt to delete a nonexistent file (vfn)") + } + + call ZFPROT to check for file protection + if (file is protected) { + vfnclose (vp, NO_UPDATE) + error ("attempt to delete a protected file (vfn)") + } + + call ZFDELE to delete the file + if (failure) { + vfnclose (vp, NO_UPDATE) + call ZFACCS to determine if file exists + if (no such file) + error ("attempt to delete a nonexistent file (vfn)") + else + error ("cannot delete file 'vfn'") + } + + vfnclose (vp, UPDATE) # UNLOCK +end + + +# RENAME -- Rename a file. A file may be renamed within a single directory +# or may be moved to another directory by the rename operation. Note that +# we may only have one VFN opened for writing at a time. + +procedure rename (oldvfn, newvfn) + +begin + # Delete old filename from VFN database. + vp = vfnopen (oldvfn, VFN_WRITE) + if (vfndel (vp, oldosfn) == ERR) { + vfnclose (vp, NO_UPDATE) + error ("attempt to rename a nonexistent file (vfn)") + } else + vfnclose (vp, UPDATE) + + # Add new filename to VFN database. + vp = vfnopen (newvfn, VFN_WRITE) + if (vfnadd (vp, newosfn) == ERR) { + vfnclose (vp, NO_UPDATE) + error ("cannot create new file 'vfn'") + } else + vfnclose (vp, UPDATE) + + # Rename the physical file. + call ZFRNAM to rename the file + + # Patch up VFN database if the rename operation fails. If the rename + # fails then most likely the OSFN's were short and no mapping file + # access was involved (else we would have had an abort above), but + # then the calls cost almost nothing so make them anyhow. + + if (rename fails) { + # Restore old filename. + vp = vfnopen (oldvfn, VFN_WRITE) + vfnadd (vp, oldosfn) + vfnclose (vp, UPDATE) + + # Delete new filename. + vp = vfnopen (newvfn, VFN_WRITE) + vfndel (vp, newosfn) + vfnclose (vp, UPDATE) + + error ("cannot rename file (oldvfn -> newvfn)") + } +end +.fi + +.nh +Locking and Concurrency Considerations + + A locking mechanism is necessary to prevent two or more processes from +simultaneously modifying a mapping file. The dimensions of the problem are +as follows: + +.ls +.ls [1] +Mutual exclusion must be guaranteed. The period of time during which a process +opens and reads the mapping file, modifies it, and updates the file on disk +is the critical section. The locking protocol must guarantee that only one +process can be in the critical section at a time. A read-only access of the +mapping file is not a critical section, but we must guarantee that the file +is not in the process of being written when such a read occurs. +.le +.ls [2] +Deadlock must either be prevented or it must be detected and broken. +Deadlock will eventually occur if a process is permitted to simultaneously +access more than one mapping file. Deadlock will occur if process A locks +directory D1 and process B locks D2, then B tries to lock D1 and A tries to +lock D2. +.le +.ls [3] +Lockout will occur if a process dies while in the critical section, thus +failing to remove the lock. +.le +.le + + +On a system which provides file locking, i.e., which forbids a process +access to a file which is open with write permission by another process, +the host OS guarantees mutual exclusion and protection from lockout. +Unfortunately many UNIX systems (and probably some other systems as well) +do not provide file locking. The scheme discussed in this section is +awkward but provides secure locking on such systems. The file locking +facilities discussed herein are designed to make use of host system file +locking if available. The discussion is oriented towards the problems +of providing locking on systems which do not provide locking at the kernel +level, i.e., in \fBzopnbf\fR. + +.nh 2 +Mutual Exclusion + + Mutual exclusion can be guaranteed by use of a \fBsemaphore\fR. +The transportability requirement makes it very difficult to implement a +general semaphore, but a binary semaphore is possible using a null length +file in the same directory as the mapping file. To implement a semaphore +we must test and set the lock all in the same operation, to prevent +interleaving of the operations by two processes simultaneously trying to +set a lock (i.e., process A tests for a lock and finds none, B tests for a +lock and finds none, A sets a lock, B sets a lock, and mutual exclusion is +violated). + +A suitable binary semaphore can be implemented by \fIdeleting\fR the lock +file to set the lock, rather than by testing for the lock (no lock file) +and then creating the lock file to set the lock. We assume that the delete +operation will return error for an attempt to delete a nonexistent file. +Thus if the lock file can be successfully deleted, the lock has been tested +and found to be absent and the directory has been locked, all in one +indivisible kernel operation. + + +.ks +.nf + # Gain exclusive access to a file. The file must have an + # associated lockfile which is deleted while a process has + # the file locked. + + while (delete (lockfile) == ERR) + ; + + + # Give up exclusive access to a file. + create (lockfile) +.fi +.ke + + +The above is a bit simplistic because the file itself may not exist, +in which case there will be no lockfile, and the process may not have +delete permission for the lockfile if there is one. The point here is +that the OS kernel guarantees that only one process will be allowed +to successfully delete the lockfile, hence the deletion operation can +serve to gain exclusive access to a file. The problem of lockout, wherein +the lockfile gets lost, is dealt with later. + +Locking the directory is necessary whenever the mapping file is to be modified. +While it is not necessary to lock the directory to read the mapping file, +by not doing so we run the risk of trying to read while the file is being +written to (permissible on some systems, an error condition on others). +The simplest solution to this problem is to lock the file for all accesses, +including reads as well as writes. The problem with this approach is that +it precludes read access on directories for which a process does not have +write permission (preventing generation of the lock file). This is not +acceptable. Our solution is to include a \fBchecksum\fR in the mapping file. +If the file exists but cannot be opened for reading and a lock exists on the +directory, we will wait until the lock is lifted to read the file. If the +checksum is in error the read will be repeated until a valid checksum is +obtained. + +.nh 2 +Deadlock + + Deadlock can be avoided by the simple expedient of permitting a process to +lock only one directory at a time. The only time a process needs to lock +more than one directory is when renaming a file with a long, degenerate name +from one directory to another. Deadlock is unlikely but would certainly +occur at infrequent intervals. Locking only one directory at a time is +inefficient (because separate references are needed to map the filename +and to edit the mapping file), but it does not matter since lock file +accesses are expected to be infrequent (few mapped filenames are degenerate). +Detection of and breaking of deadlock is possible but not worth the trouble. +Thus we shall avoid the problem of deadlock entirely by permitting a process +to lock only a single directory at a time, for only a brief period of time. + +.nh 2 +Lockout + + At this point we have a solution which guarantees mutual exclusion and the +avoidance of deadlock nearly 100% of the time. The only problem remaining +is \fBlockout\fR. It is not possible to prevent lockout since we cannot +guarantee that a process (or the computer) will not die while in a critical +section, preventing removal of the lock. + +The obvious way to implement automatic recovery from lockout is to add a +provision for timeout. While we cannot guarantee that the time spent +in a critical section will be less than some absolute amount (because of +variable load conditions, swapping, the time required to delete a very +large file, etc.), we can say that the time spent in a critical section will +rarely be larger than some number on the order of one second. In a worst +case situation where several processes are heavily accessing a directory +it could take an arbitrarily long time for a particular process to gain a +lock on the directory, but this is very unlikely. + +If a process times out while waiting we must either abort or proceed to break +the lock. This may be done by creating a new lockfile as if the transaction +had been completed. There is a hidden bug, however -- if two or +more processes timeout simultaneously, the following scenario might occur: + + +.kf +.nf + A times out + B times out + A breaks the lock + A enters wait loop and places a new lock, + entering the critical section + B breaks the lock set by A + B enters wait loop and places a new lock, + entering the critical section + [...mutual exclusion is violated...] +.fi +.ke + + +No matter how unlikely this scenario might be, it prevents us from using the +simple technique to break the lock. Breaking the lock appears to be another +critical section, so perhaps we can use another semaphore to protect the lock +(we ignore the complications of checking for write permission on the directory, +which should be dealt with when the lock is set). + +Even if a semaphore is used concurrency +can still be a problem, as another process may timeout and break the lock +shortly after the first process has done so; this can happen because the +section between timeout and the test for permission to break the lock is +interruptable. To get around this we apply an additional constraint +that the lock can only be broken if it has been in place for a specified +interval of time which is much larger than the timeout interval. This suffices +to recover from a process crash and prevents two processes from breaking +the lock at almost the same time. + + +.ks +.nf + # Try to set a lock on the directory. If we timeout, try to get + # permission to break the lock; only one process is permitted to + # break the lock, and the lock can only be broken once in a + # specified interval of time. The timelock files are normally + # created whenever the directory is locked. + + repeat { + while (delete (lockfile) == ERR) + if (timeout) + if (delete (timelock1) != ERR) { + get creation date of timelock2 + if (timelock2 is an old file) { + create (lockfile) + delete (timelock2); create (timelock2) + create (timelock1) + } else + create (timelock1) + } + } until (lock is established) + + # Back to normal. + carry out transaction + create (lockfile) +.fi +.ke + + +Lockout is still possible if the process or the computer dies in the interval +between deletion and creation of timelock1, but the chances of that happening +are very remote because the interval is short and it only occurs during +recovery from lockout. An additional check should perhaps be provided to +detect this unlikely circumstance and break the lock without further ado +if timelock1 somehow gets permanently deleted. The mapping file can be +checkpointed when this occurs to minimize the risk. + +.nh 2 +Rollback + + Unfortunately, automatic lockout detection and recovery brings with it +the possibility that the lock will be broken when a process takes an abnormally +long time to complete a transaction. This might happen when a heavily loaded +system has begun swapping processes, or when a background job with a +very low priority accesses a directory. We must be able to detect that the +lock has been broken and \fIrollback\fR the transaction, i.e., obtain a new +lock and try again, repeating the unsuccessful transaction. + +Timeouts leading to improper breaking of the lock are not a problem if the +host system provides file locking for files opened for writing. After placing +the lock on a directory a process will open the mapping file with readwrite +permission and all other processes will be locked out until the transaction +completes. Unfortunately file locking is not provided on all systems (e.g., +many versions of UNIX do not provide file locking). + +Secure protection from a broken lock is difficult because if we check that +the lock is still in place and then perform the update, another process may +break the lock immediately after we check that the lock is in place and +before the update occurs. About the best we can do is check the creation time +on timelock2 immediately before updating, updating only if the timelock has +not been touched since we created it at lock time. If the lock has been +broken our timelock file will have been deleted and the transaction must be +rolled back. If a lot of time remains on the lock we go ahead and perform +the update, otherwise a new timelock2 is written, providing a time equal to +the minimum lifetime of a lock in which to update the file. + + +.ks +.nf + perform transaction upon MFD (in memory) + + # Determine if the lock is still in place and likely to remain + # in place until the update is completed. + + repeat { + get creation date of timelock2 + if (not the timelock we set at vfn_wait time) + rollback transaction + else if (not much time left on lock) + rollback transaction + else + break + } + + # Update and remove the lock. + + update the mapping file + close (mapping file) + + get creation date of timelock2 + if (not our timelock) + bad news: warn user + + create (lockfile) +.fi +.ke + +.nh 2 +File Locking Facilties + + From the above code fragments it appears that the lockfile approach +to file locking will work on any machine on which it is an error to delete +a nonexistent file. The next step is to encapsulate all this in file +locking primitives which will use the host OS file locking facilities if +any, otherwise the lockfile techniques we have developed. A set of file +locking primitives are presented below. These are low level routines +with fairly restrictive semantics, and are not intended to be used in other +than system code. + + +.ks +.nf + time = osfn_lock (osfn) + nsec = osfn_timeleft (osfn, time) + nsec = osfn_unlock (osfn, time) +.fi +.ke + + +A file is locked with the \fBosfn_lock\fR primitive, which returns when +it has successfully placed a lock on the file \fIosfn\fR. The lock is +guaranteed to remain in place for at least \fItimeout\fR seconds, where +\fItimeout\fR is a system constant. +On some systems the file may not actually be locked until it is opened +with write access. If the file does not exist or cannot be locked +\fBerror\fR is called. If the file is already locked but the lock has +expired \fBosfn_lock\fR will break the old lock and return when it has +set a new one. + +The primitive \fBosfn_timeleft\fR returns the number of seconds remaining +on the lock on file \fIosfn\fR. ERR is returned if the file is no longer +locked or if the file is currently locked by another user. + +A lock is removed with \fBosfn_unlock\fR. The number of seconds remaining +on the lock at the time it was removed is returned as the function value. +ERR is returned if the file was no longer locked or had been locked by +another user when \fBosfn_unlock\fR was called. + + +.nf +# OSFN_LOCK -- Lock the named OSFN, i.e., gain exclusive write access +# to a file. Only the process gaining the lock on a file may write +# to it, but there is no guarantee that another process may not read +# a locked file. On some systems the file will not actually be locked +# until it is opened with write permission. If multiple files exist +# in a directory with the same root but different extensions, only one +# can be locked at a time. + +long procedure osfn_lock (osfn) + +begin + # Even if file locking is provided by the OS we must determine + # if the file is write protected. If the file is not write + # protected but cannot be opened for writing our caller will + # conclude that the file is locked by another process. + + if (file locking is handled by the OS) + if (file osfn is write protected) + error ("no write permission on file 'osfn'") + else + return (clktime) + + # Generate filenames. + basename = osfn minus any extension + lockfile = strpak (basename // ".lok") + timelock1 = strpak (basename // ".tl1") + timelock2 = strpak (basename // ".tl2") + + # If the lockfile can be deleted (usual case) then we have + # little to do. + if (delete (lockfile) == OK) + goto setlock_ + + # If the lockfile cannot be deleted check that the file itself + # exists and that we have delete permission on the directory. + + if (file 'osfn' does not exist) + error ("attempt to lock a nonexistent file (osfn)") + if (no delete permission on directory) + error ("cannot delete file (lockfile)") + + # The file exists and all the necessary permissions are granted, + # hence someone else has the file locked and we must wait. + + repeat { + for (nsec=0; nsec < timeout_period; nsec=nsec+1) + if (delete (lockfile) == OK) + goto setlock_ + if (delete (timelock1) == OK) { + get creation date of timelock2 + if (timelock2 is an old file or does not exist) { + create (lockfile) + delete (timelock2); create (timelock2) + create (timelock1) + } else + create (timelock1) + } else if (continual failure to delete timelock1) + create (timelock1) + } + +setlock_ + delete (timelock2) + create (timelock2) + + return (creation time of timelock2) +end + + +# OSFN_TIMELEFT -- Determine if a file is still locked, and if so, how +# much time remains on the lock. TIME is the time value returned when +# the file was locked. All time values are in units of seconds. + +int procedure osfn_timeleft (osfn, time) + +begin + if (file locking is handled by the OS) + return (big number) + + basename = osfn minus any extension + lockfile = strpak (basename // ".lok") + timelock2 = strpak (basename // ".tl2") + + if (lockfile exists) + return (ERR) + else if (cannot get file info on timelock2) + return (ERR) + else if (timelock2.create_time != time) + return (ERR) + else { + timeleft = max (0, timeout_period - (clktime - time) + return (timeleft) + } +end + + +# OSFN_UNLOCK -- Release the lock on a file and return the number of +# seconds that were left on the lock. ERR is returned if the file is +# no longer locked or if the lock is not the one originally placed +# on the file. + +int procedure osfn_unlock (osfn, time) + +begin + timeleft = osfn_timeleft (osfn, time) + + if (timeleft != ERR) { + basename = osfn minus any extension + lockfile = strpak (basename // ".lok") + create (lockfile) + } + + return (timeleft) +end +.fi + +.nh +VFN Package Data Structures + + A process may have only a single VFN open with write permission at any +one time to eliminate the possibility of deadlock (section 4). Any number +of VFN's may be open for read-only access, e.g., when recursively descending +a directory tree. Most VFN accesses do not involve a reference to a mapping +file. Since the mapping file is infrequently referenced, separate descriptors +are used for the VFN and the mapping file. The VFN descriptor is called the +VFD and the mapping file descriptor the MFD. + +The MFD is only allocated if a mapping file is referenced, i.e., if the OSFN +is long. Before allocating a new MFD we must search the list of open VFN's +to see if the mapping file has already been opened and assigned a MFD. Every +VFN must have its own VFD. To prevent having to MALLOC a +VFD every time a filename is mapped, one VFD will always be allocated (after +the first file reference). Thus, for a simple filename mapping where the +OSFN is short, no MALLOC or other kernel calls will be required, i.e., the only +expense will be the string operations required to map the filename. + + +.ks +.nf +# VFN Descriptor + +struct vfd { + struct mfd *v_mfd # ptr to mapping file descr. + int v_acmode # access mode + int v_len_osdir # length of v_osdir string + int v_len_root # length of v_root string + int v_len_extn # length of v_extn string + char v_vfn[33] # original VFN, minus LDIR + char v_osdir[33] # OS directory name + char v_root[33] # encoded root filename + char v_extn[33] # encoded and mapped extension +} +.fi +.ke + + +.ks +.nf +# Mapping File Descriptor. The length of the descriptor is adjusted as +# necessary to provide storage for the filename pairs. + +struct mfd { + long m_locktime # clktime when lock set + int m_fd # file descriptor + int m_nfiles # number of files in map list + int m_lastop # last operation performed + int m_modified # was database modified + char m_vfnmap[] # OSFN of mapping file + int m_checksum # checksum of m_fnmap + char m_fnmap[nfiles*34*2] # vfn/osfn pairs +} +.fi +.ke + +.nh +Semicode for Parts of the VFN Package + +.nf +# VFNOPEN -- Open that part of the VFN database associated with a particular +# VFN. Allocate VFD descriptor, map but do not squeeze VFN to long OSFN. + +pointer procedure vfnopen (vfn, mode) + +begin + if (first_time) { + permanently allocate a VFD + nvfn_open = 0 + first_time = false + } + + # Allocate and initialize VFD. + if (no VFN's open) { + use preallocated VFD + increment count of open VFN's + } else + allocate a new VFD + + call fbrkfn to break VFN into OSDIR, ROOT, and EXTN fields + + return (pointer to VFD) +end + + +# VFNCLOSE -- Close a VFN and optionally update the VFN database. An update +# is performed only if the mapping file is open with write permission, +# a modify transaction has occurred, and updating is enabled. + +procedure vfnclose (vp, update) + +begin + # If the mapping file was not used or if it was not modified we + # just return the buffers and quit. + + mfp = vp.mfp + if (mfp == NULL) { + if (nvfn_open > 1) + mfree (vp, TY_STRUCT) + return + } else if (mfp.m_modified == NO || update == NO_UPDATE) { + mfree (mfp, TY_STRUCT) + if (nvfn_open > 1) + mfree (vp, TY_STRUCT) + return + } + + # If we get here the mapping file is open with write permission, + # a transaction has been performed which modified the database, + # and we were called with updating enabled. Rollback (repeat) + # the transaction if the lock has been broken or if there is not + # enough time remaining on the lock. + + while (osfn_timeleft (mfp.m_vfnmap, mfp.m_locktime) < xx) { + osfn_unlock (mfp.m_vfnmap, mfp.m_locktime) + switch (mfp.lastop) { + case VFN_ADD: + vfnadd (vp, junkstr) + case VFN_DEL: + vfndel (vp, junkstr) + } + } + + # Update and close the mapping file. + compute checksum and store in the mapping file + rewrite mapping file to disk + close (mapping file) + + if (osfn_unlock (mfp.m_vfnmap, mfp.m_locktime) == ERR) + warn ("broken file protect lock in directory 'vp.v_osdir'") + + mfree (mfp, TY_STRUCT) + if (nvfn_open > 1) + mfree (vp, TY_STRUCT) +end + + +# VFNMAP -- Map and pack the VFN into an OSFN, but do not modify the +# database. The mapping file is accessed only if the filename is +# degenerate. + +int procedure vfnmap (vp, osfn) + +begin + # If the OSFN is short or long but still unique within directory, + # then it is not necessary to access the mapping file. + + if (root is longer than permitted by host system) { + squeeze root + if (squeezed root filename is unique within directory) { + concatenate and pack osfn + return (OK) + } + } + + # If we get here then the squeezed filename is degenerate, i.e., + # not unique within the directory. It is necessary to read the + # mapping file to learn what OSFN has been assigned to the file. + + mfp = allocate and init mapping file descriptor + mfp.m_vfnmap = strpak (osdir // "zzvfnmap.vfn") + + # Open or create the mapping file. Create must precede lock + # as lock will abort if the file to be locked does not exist. + # If opening existing file READ_WRITE, lock first to determine + # if we have write perm on file, then keep trying to open file + # until open succeeds (if OS level file locking is in use the + # open will return ERR as long as another process has the + # file open for writing). + + switch (vp.v_acmode) { + case VFN_WRITE: + if (no mapping file created yet) { + create a new mapping file + time = osfn_lock (mfp.m_vfnmap) + } else { + time = osfn_lock (mfp.m_vfnmap) + repeat { + open mapping file for READ_WRITE access + sleep (1) + } until (open succeeds) + } + default: + open mapping file for READ_ONLY access + } + + # Read mapping file into descriptor. Increase default size of + # descriptor if necessary to read entire file. Repeat the + # read if the checksum is invalid, indicating that a write + # was in progress when we read. + + maxch = default buffer size for the filename map + repeat { + repeat { + read maxch chars into mfp.m_checksum + if (nchars_read >= maxch) { + increase size of descriptor + maxch = maxch + increase in storage + } + } until (nchars_read < maxch) + compute checksum + } until (checksum == mfp.m_checksum) + + if (nchars_read == EOF) + mfp.m_nfiles = 0 + else + mfp.m_nfiles = max (0, (nchars - SZ_INT) / SZ_FNMAP_PAIR) + + search mfp.m_fnmap for filename vp.vfn + if (not found) + status = ERR + else { + status = OK + pack osfn to output argument + } + + if (access_mode != VFN_WRITE) + close mapping file + + return (status) +end + + +# VFNADD -- Map a VFN to an OSFN and add an entry for the VFN to the +# database if the OSFN is degenerate. + +procedure vfnadd (vp, osfn) + +begin + # If VFNMAP does not return ERR then the file already exists. + # We return ERR if the file already exists. + + if (vfnmap (vp, osfn) != ERR) + return (ERR) + else if (short osfn) + return (OK) + + if (osfn is degenerate) { + generate a unique new_osfn + create degeneracy flag file osfn // ".zmd" + osfn = strpak (new_osfn) + } + + add vfn,osfn pair to vp.mfp.m_fnmap + mfp.m_lastop = VFN_ADD + + return (OK) +end + + +# VFNDEL -- Map a VFN to an OSFN and delete the entry for the VFN from +# the database if the OSFN is degenerate. Do not delete the degeneracy +# flag file if no longer degenerate, because even though the OSFN is +# no longer degenerate the OSFN reflects the former degeneracy of the +# file, and we do not want to rename the file. + +procedure vfnadd (vp, osfn) + +begin + # If VFNMAP returns ERR then the file does not exist. + # We return ERR if the file does not exist. + + if (vfnmap (vp, osfn) == ERR) + return (ERR) + else if (short osfn) + return (OK) + + delete vfn,osfn pair to vp.mfp.m_fnmap + mfp.m_lastop = VFN_DEL + + return (OK) +end + + +# FBRKFN -- Transform a VFN into an OSDIR, an escape sequence encoded and +# extension mapped root OS filename ROOT, and an extension EXTN. The root +# may be longer than permitted by the host OS, i.e., squeezing is not done +# here. + +procedure fbrkfn (vfn, osdir, lenosdir, root, lenroot, extn, lenextn) + +begin + # If the VFN begins with an OSDIR prefix it is assumed to be an OSFN + # and no mapping is performed. + + call ZFXDIR to extract osdir prefix, if any + if (osdir prefix found) { + copy remainder of vfn to root + return + } + + osdir = null_string + root = null_string + extn = null_string + + # Process the directory and filename fields. In the case of a simple + # filename the first pass performs the escape sequence encoding of the + # filename directly into root, and we return after possibly mapping + # the extension. + + repeat { + extract next field into root and extn with escape sequence encoding + if (delimiter == '$') + if (osdir == null_string) { + osdir = recursively expand ldir + if (ldir not found) + error ("logical directory 'ldir' not found") + } else + error ("illegal $ delimiter in filename 'vfn'") + } else if (delimiter == '/') + fold field, a subdirectory, into osdir + } until (delimiter == EOS) + + # At this point we have osdir, root, and extn strings, any of which may + # be null. If more than one "." delimited extn string was encountered + # during escape sequence encoding, or if the maximum extn length was + # exceedd, then that extn will already have been incorporated into the + # root. + + if (extn != null_string) + map filename extension +end diff --git a/sys/fio/falloc.x b/sys/fio/falloc.x new file mode 100644 index 00000000..c84ef000 --- /dev/null +++ b/sys/fio/falloc.x @@ -0,0 +1,73 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include + +# FALLOC -- Create a binary file of a given size, and open as a binary file +# with read write permission. Interrupts are disabled while the VFN database +# is open to protect the database, ensure that that the lock on the mapping +# file is cleared, and to ensure that the mapping file is closed. + +procedure falloc (fname, file_size) + +char fname[ARB] # virtual file name +long file_size # file size in chars + +int status, junk +pointer vp + +int vfnadd() +pointer vfnopen() +bool fnullfile() +errchk fclobber +include + +define close_ 91 +define abort_ 92 + +begin + # The null file "dev$null" is a special case; ignore attempts to + # create this file. + + if (fnullfile (fname)) + return + + # Perform clobber checking, delete old file if one exists. + # Note that this must be done before opening the new VFN for + # writing or deadlock on the VFN database may occur. + + call fclobber (fname) + + # Add new VFN and get the OSFN of the new file. + # Allocate the file and update VFN database. + + call intr_disable() + iferr (vp = vfnopen (fname, VFN_WRITE)) + goto abort_ + iferr (junk = vfnadd (vp, pathname, SZ_PATHNAME)) + goto close_ + + call zfaloc (pathname, file_size * SZB_CHAR, status) + if (status == ERR) { + iferr (call filerr (fname, SYS_FALLOC)) + goto close_ + } else + iferr (call vfnclose (vp, VFN_UPDATE)) + goto abort_ + + call intr_enable() + return + + + # Error recovery nasties. +close_ + iferr (call vfnclose (vp, VFN_NOUPDATE)) + ; +abort_ + call intr_enable() + call erract (EA_ERROR) +end diff --git a/sys/fio/fcache.x b/sys/fio/fcache.x new file mode 100644 index 00000000..c5dc3f11 --- /dev/null +++ b/sys/fio/fcache.x @@ -0,0 +1,733 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include + + +# FCACHE -- Simple file caching interface. Our purpose is to take as +# input a URL string and return a unique name for a local disk file. +# The format of the name is of the form +# +# cache$urlXXXXXX[.extn] +# +# where 'cache' is a logical directory for the stored file, and the XXXXXXX +# is the computed 32-bit checksum of the input URL string. To provide a +# backward mapping of the filename in the cache to the original URL, a +# file of the same name prefixed with a "." (e.g. "cache$.urlXXXX") will be +# created containing the URL string. This file may also be checked to +# avoid collisions of names in rare cases where multiple checksums may be +# the same for different URLs. +# +# The 'cache' environment variables is used to define the location of the +# cache directory. When creating a cache filename, the caller may choose +# to append an extension to the file if it determines this is appropriate +# for the type of file accessed. In this case, the dot-file will remain as +# just the root part of the name. +# +# This interface is intentionally simple so that it may be shared with host +# applications that also require a cache. +# +# +# fcinit (cache, pattern) +# fcpurge (cache, verbose, age) +# fcdestroy (cache, verbose) +# +# fclist (cache, verbose, fd) +# fclookup (cache, src, cfname, extn, maxch) +# +# fcaccess (cache, inname, extn) +# fcadd (cache, inname, cfname, maxch) +# fcdelete (cache, fname) +# fcwait (cache, fname, timeout) +# +# fcname (cache, in, root, out, maxch) +# fcsrc (cache, in, out, maxch) + + + +# FCINIT -- Initialize the file cache, i.e. delete all contents that contain +# the pattern substring (or all files if no pattern is specified). + +procedure fcinit (cache, pattern) + +char cache[ARB] #i cache dir to initialize +char pattern[ARB] #i filename substring pattern + +int dir, len +char cfname[SZ_PATHNAME], fname[SZ_LINE], dirname[SZ_PATHNAME] +char patbuf[SZ_LINE] + +int access(), strlen(), diropen(), isdirectory(), getline() +int patmatch(), patmake() +errchk delete() + +begin + # Simply create the directory if it doesn't exist. + if (access (cache, 0, 0) == NO) { + call fmkdir (cache) + return + + } else if (isdirectory (cache, dirname, SZ_PATHNAME) == 0) + call syserr (SYS_FOPENDIR) + + + if (patmake (pattern, patbuf, SZ_LINE) == ERR) + call error (1, "Pattern is too complex") + + + # Otherwise, read through the directory and remove the contents. + dir = diropen (dirname, PASS_HIDDEN_FILES) + + while (getline (dir, fname) != EOF) { + len = strlen (fname) + fname[len] = '\0' + + call sprintf (cfname, SZ_PATHNAME, "%s/%s") + call pargstr (cache) + call pargstr (fname) + + # We only delete plain files, skip directories. + if (isdirectory (cfname, dirname, SZ_PATHNAME) > 0) + next + + if (patmatch (fname, patbuf) > 0) { + iferr (call delete (cfname)) # delete the file, ignore errors + ; + } + } + + call close (dir) # clean up +end + + +# FCPURGE -- Clean out a cache of file older than the given age. + +procedure fcpurge (cache, verbose, age) + +char cache[ARB] #i cache dir to initialize +bool verbose #i print verbose output? +int age #i age (in days) + +int dir, len +long info[LEN_FINFO], old +char cfname[SZ_FNAME], fname[SZ_LINE], dirname[SZ_PATHNAME] + +int access(), strlen(), diropen(), isdirectory(), getline(), finfo() +long clktime() + +begin + # Simply return if it doesn't exist. + if (access (cache, 0, 0) == NO) + return + + if (isdirectory (cache, dirname, SZ_PATHNAME) == 0) + call syserr (SYS_FOPENDIR) + + # Otherwise, read through the directory and delete old files. + dir = diropen (dirname, SKIP_HIDDEN_FILES) + + old = (clktime (0) - age * 86400) # expiration time + while (getline (dir, fname) != EOF) { + len = strlen (fname) + fname[len] = '\0' + + call sprintf (cfname, SZ_PATHNAME, "%s/%s") + call pargstr (cache) + call pargstr (fname) + + # Skip directories. + if (isdirectory (cfname, dirname, SZ_FNAME) > 0) + next + + if (finfo (cfname, info) == ERR) + next + + if (FI_CTIME(info) < old) { + if (verbose) { + call eprintf ("Purging '%s'\n") + call pargstr (fname) + } + call fcdelete (cache, fname) # delete the file + } + } + + call close (dir) # clean up +end + + +# FCDESTROY -- Destroy the named cache directory. + +procedure fcdestroy (cache, verbose) + +char cache[ARB] #i cache dir to initialize +bool verbose #i print verbose output + +int dir, len +char cfname[SZ_FNAME], fname[SZ_LINE], dirname[SZ_PATHNAME] + +int access(), strlen(), diropen(), isdirectory(), getline() + +begin + # Simply return if it doesn't exist. + if (access (cache, 0, 0) == NO) + return + + if (isdirectory (cache, dirname, SZ_PATHNAME) == 0) + call syserr (SYS_FOPENDIR) + + # Otherwise, read through the directory and delete old files. + dir = diropen (dirname, PASS_HIDDEN_FILES) + + while (getline (dir, fname) != EOF) { + len = strlen (fname) + fname[len] = '\0' + + call sprintf (cfname, SZ_PATHNAME, "%s/%s") + call pargstr (cache) + call pargstr (fname) + + # Skip directories. + if (isdirectory (cfname, dirname, SZ_FNAME) > 0 || fname[1] != '.') + next + + if (verbose) { + call eprintf ("Purging '%s'\n") + call pargstr (fname[2]) + } + call fcdelete (cache, fname[2]) # delete the file + } + call close (dir) # clean up + + call frmdir (cache) # delete the cache directory +end + + +# FCLIST -- List info about the cache to the given descriptor. + +procedure fclist (cache, verbose, fd) + +char cache[ARB] #i cache dir to initialize +bool verbose #i verbose output +int fd #i output file descriptor + +int dir, len, age +char cfname[SZ_FNAME], fname[SZ_LINE], dirname[SZ_PATHNAME] +char src[SZ_LINE], date[SZ_LINE] +long file_info[LEN_FINFO] + +int access(), strlen(), diropen(), isdirectory(), getline(), finfo() +bool streq() +long clktime() + +begin + # Simply return if it doesn't exist. + if (access (cache, 0, 0) == NO) { + call fmkdir (cache) + return + } else if (isdirectory (cache, dirname, SZ_PATHNAME) == 0) + call syserr (SYS_FOPENDIR) + + # Otherwise, read through the directory and remove the contents. + dir = diropen (dirname, PASS_HIDDEN_FILES) + + while (getline (dir, fname) != EOF) { + len = strlen (fname) + fname[len] = '\0' + + # We only delete plain files, skip directories. + if (streq (fname, ".") || streq (fname, "..") || fname[1] != '.') + next + + ifnoerr (call fcsrc (cache, fname, src, SZ_LINE)) { + call sprintf (cfname, SZ_FNAME, "%s/%s") + call pargstr (cache) + call pargstr (fname) + if (finfo (cfname, file_info) != ERR) + call cnvdate (FI_CTIME(file_info), date, SZ_LINE) + else + call strcpy (" ", date, SZ_LINE) + age = (clktime(0) - FI_CTIME(file_info) + 86400) / 86400 + + if (verbose) { + call fprintf (fd, "%16s %s %s\n") + call pargstr (fname[2]) + call pargstr (date) + call pargstr (src) + } else { + call fprintf (fd, "%16s %d %s\n") + call pargstr (fname[2]) + call pargi (age) + call pargstr (src) + } + } + } +end + + +# FCLOOKUP -- Lookup the src string and return the cached filename. If a +# filename in the cache is specified, return the src string. Both strings +# must be at least 'maxch' chars long. + +procedure fclookup (cache, src, cfname, extn, maxch) + +char cache[ARB] #i cache dir to initialize +char src[ARB] #i lookup string +char cfname[ARB] #i cached filename +char extn[ARB] #i filename extension +int maxch #i output file descriptor + +int dir, len +char dirname[SZ_PATHNAME], fname[SZ_LINE], csrc[SZ_LINE] + +int diropen(), getline(), strlen(), isdirectory(), access () +bool streq() + +begin + if (access (cache, 0, 0) == YES) { + if (isdirectory (cache, dirname, SZ_PATHNAME) == 0) + call syserr (SYS_FOPENDIR) + } else { + call aclrc (cfname, SZ_FNAME) + return + } + + if (src[1] != EOS) { + call fcname (cache, src, "f", cfname, maxch) + + dir = diropen (dirname, PASS_HIDDEN_FILES) + while (getline (dir, fname) != EOF) { + len = strlen (fname) + fname[len] = '\0' + + # We only delete plain files, skip directories. + if (streq(fname, ".") || streq(fname, "..") || fname[1] != '.') + next + + ifnoerr (call fcsrc (cache, fname, csrc, SZ_LINE)) { + if (streq (src, csrc)) { + call strcpy (fname[2], cfname, maxch) + call close (dir) + + # Look for the extension. + call fc_find_extn (cache, cfname, extn, maxch) + return + } + } + } + call close (dir) + + } else if (cfname[1] != EOS) + call fcsrc (cache, cfname, src, SZ_LINE) +end + + +# FCACCESS -- See if a file is already in the cache. For best results, the +# input file name should include the full directory path name. + +bool procedure fcaccess (cache, inname, extn) + +char cache[ARB] #i cache dir to initialize +char inname[ARB] #i input file name +char extn[ARB] #i file extension + +char cname[SZ_PATHNAME], root[SZ_PATHNAME] +char extfile[SZ_PATHNAME], lext[SZ_PATHNAME] +bool stat + +int access(), fnroot() + +begin + # No cache, no file.... + if (access (cache, 0, 0) == NO) + return (FALSE) + + # Get the cache filename. + call fcname (cache, inname, "f", cname, SZ_PATHNAME) + call aclrc (lext, SZ_PATHNAME) + if (extn[1] != EOS) { + if (fnroot (cname, root, SZ_PATHNAME) > 0) + call fc_find_extn (cache, root, lext, SZ_PATHNAME) + } + + call sprintf (extfile, SZ_PATHNAME, "%s.%s") + call pargstr (cname) + call pargstr (lext) + + stat = (access (cname, 0, 0) == YES || access (extfile, 0, 0) == YES) + return (stat) +end + + +# FCADD -- Add a new file to the cache. This is a wrapper around copying +# the file and returning the cached name. For best results, the input file +# name should include the full directory path name. + +procedure fcadd (cache, inname, extn, cname, maxch) + +char cache[ARB] #i cache dir to initialize +char inname[ARB] #i input file name +char extn[ARB] #i file extension +char cname[ARB] #o cached filename +int maxch #i size of output file name + +char fname[SZ_PATHNAME], imname[SZ_PATHNAME] +char dotfile[SZ_PATHNAME] +int retcode, status + +int access(), strncmp(), url_get(), url_errcode(), fnroot() +bool fcaccess() + +errchk url_get(), delete() + +begin + if (access (cache, 0, 0) == NO) + call fmkdir (cache) + + # Get the cache filename. + call fcname (cache, inname, "f", cname, maxch) + + if (access (cname, 0, 0) == YES) { +# iferr (call delete (cname)) # delete the file, ignore errors +# ; + return + } + + + if (extn[1] != EOS) { + call sprintf (fname, SZ_PATHNAME, "%s.%s") + call pargstr (cname) + call pargstr (extn) + if (access (fname, 0, 0) == YES) { + iferr (call delete (fname)) # delete the file, ignore errors + ; + } + } else + call strcpy (cname, fname, SZ_PATHNAME) + + + if (strncmp ("http://", inname, 7) == 0) { + if (! fcaccess (cache, inname, "")) { + retcode = url_get (inname, fname, NULL) + if (retcode < 0) { + status = fnroot (cname, fname, maxch) + call sprintf (dotfile, SZ_PATHNAME, "%s/.%s") + call pargstr (cache) + call pargstr (fname) + call delete (dotfile) # delete the dot file + call filerr (inname, url_errcode (-retcode)) + return + } + + # Create a symlink to the file that can be used as an image ref. + call sprintf (imname, SZ_PATHNAME, "%s.fits") + call pargstr (fname) + call fsymlink (imname, fname) + } + + if (extn[1] != EOS) + call strcpy (fname, cname, maxch) + + } else if (strncmp ("file://localhost", inname, 16) == 0) { + iferr (call fcopy (inname[16], fname)) + call syserr (SYS_FMKCOPY) + call strcpy (fname, cname, maxch) + + } else if (strncmp ("file://localhost", inname, 17) == 0) { + iferr (call fcopy (inname[18], fname)) + call syserr (SYS_FMKCOPY) + call strcpy (fname, cname, maxch) + + } else if (strncmp ("file://", inname, 7) == 0) { + iferr (call fcopy (inname[7], fname)) + call syserr (SYS_FMKCOPY) + call strcpy (fname, cname, maxch) + + } else { + iferr (call fcopy (inname, fname)) + call syserr (SYS_FMKCOPY) + call strcpy (fname, cname, maxch) + } +end + + +# FCDELETE -- Delete a named file from the cache. + +procedure fcdelete (cache, fname) + +char cache[ARB] #i cache dir to initialize +char fname[ARB] #i cache filename to delete + +int dir, len +char cfname[SZ_FNAME], dfname[SZ_LINE], dotfile[SZ_FNAME] +char dirname[SZ_FNAME] + +int access(), diropen(), strlen(), strsearch(), getline(), isdirectory() + +errchk delete() + +begin + if (access (cache, 0, 0) == NO) { + return + } else if (isdirectory (cache, dirname, SZ_PATHNAME) == 0) + call syserr (SYS_FOPENDIR) + + + call sprintf (cfname, SZ_FNAME, "%s%s") + call pargstr (cache) + call pargstr (fname) + call sprintf (dotfile, SZ_FNAME, "%s.%s") + call pargstr (cache) + call pargstr (fname) + + + if (access (cfname, 0, 0) == YES) { + iferr (call delete (cfname)) + ; + } + if (access (dotfile, 0, 0) == YES) { + iferr (call delete (dotfile)) + ; + } + + # Loop through any other files in the directory that begin with + # the requested file. This removes the links created that may + # contain file-type specific extensions. + + dir = diropen (dirname, SKIP_HIDDEN_FILES) + while (getline (dir, dfname) != EOF) { + len = strlen (dfname) + dfname[len] = '\0' + + call sprintf (cfname, SZ_FNAME, "%s/%s") + call pargstr (cache) + call pargstr (dfname) + + if (strsearch (dfname, fname) > 0) { + iferr (call deletefg (cfname, YES, YES)) + call funlink (cfname) + } + } + call close (dir) +end + + +# FCWAIT -- Wait for the named file to appear in the cache. + +int procedure fcwait (cache, fname) + +char cache[ARB] #i cache dir to initialize +char fname[ARB] #i cache filename to wait for + +char cfname[SZ_FNAME], errfile[SZ_FNAME], lockfile[SZ_FNAME] +char root[SZ_FNAME], extn[SZ_FNAME] + +int access(), fnroot(), fnextn() + +begin + if (access (cache, 0, 0) == NO) + call fmkdir (cache) + + if (fnroot (fname, root, SZ_FNAME) == 0) + return + if (fnextn (fname, extn, SZ_FNAME) == 0) + ; + + call sprintf (cfname, SZ_FNAME, "%s%s") + call pargstr (cache) + call pargstr (root) + if (extn[1] != EOS) { + call strcat (".", cfname, SZ_PATHNAME) + call strcat (extn, cfname, SZ_PATHNAME) + } + call sprintf (errfile, SZ_FNAME, "%s.%s.ERR") + call pargstr (cache) + call pargstr (root) + call sprintf (lockfile, SZ_FNAME, "%s.%s.LOCK") + call pargstr (cache) + call pargstr (root) + + + # Even if we've asked to pre-fetch the data, we want to avoid + # having to do any process synchronization with the threads + # downloading the data. So, block until the requested file is + # available, or we get a file with a ".ERR" extension that + # indicates an error. + + if (access (cfname, 0, 0) == NO || access (lockfile,0,0) == YES) { + while (access (cfname,0,0) == NO || access (lockfile,0,0) == YES) { + if (access (errfile, 0, 0) == YES) + return (0) + call tsleep (1) + } + } + return (access (cfname, 0, 0)) +end + + +# FCNAME -- Convert an input filename/string/url/whatever to a unique +# filename in the cache. + +procedure fcname (cache, in, root, out, maxch) + +char cache[ARB] #i cache directory +char in[ARB] #i input string/name +char root[ARB] #i cache name root +char out[ARB] #o output cache filename +int maxch #i max size of filename + +char dotfile[SZ_PATHNAME], line[SZ_LINE] +int fd, len, sum + +int strsum(), strlen(), getline(), access(), filopn() +bool streq() + +extern zopntx(), zgettx() +errchk filopn + +begin + if (access (cache, 0, 0) == NO) + call fmkdir (cache) + + # Initialize the output string, trash any newlines in the string. + call aclrc (out, maxch) + len = strlen (in) + if (in[len] == '\n') + in[len] = EOS + + # Compute the string checksum. + sum = strsum (in, len, SZ_LINE) + + # Format the dotfile name string. + call sprintf (dotfile, SZ_PATHNAME, "%s.%s%d") + call pargstr (cache) + call pargstr (root) + call pargi (sum) + + # Format the name string. + call sprintf (out, maxch, "%s%s%d") + call pargstr (cache) + call pargstr (root) + call pargi (sum) + + # Check to see if the file already exists. + if (access (dotfile, 0, 0) == YES) { + fd = filopn (dotfile, READ_ONLY, TEXT_FILE, zopntx, zgettx) + if (getline (fd, line) != EOF) { + len = strlen (line) + line[len] = '\0' # kill newline + call close (fd) + if (streq (in, line)) # file exists and is current + return + + else { + # FIXME -- what to do ???? + ; + } + } + call close (fd) + + } else { + # File doesn't exist so the name is unique. Write the src string. + fd = filopn (dotfile, NEW_FILE, TEXT_FILE, zopntx, zgettx) + call fprintf (fd, "%s\n") + call pargstr (in) + call close (fd) + } +end + + +# FCSRC -- Return the source string for the named cache file. + +procedure fcsrc (cache, in, out, maxch) + +char cache[ARB] #i cache directory +char in[ARB] #i cache file name +char out[ARB] #o source string +int maxch #i size of output string + +int fd, len +char dotfile[SZ_PATHNAME], cfname[SZ_PATHNAME] +char dirname[SZ_PATHNAME], root[SZ_FNAME], line[SZ_LINE] + +int access(), fnldir(), fnroot(), open(), strlen(), getline() + +begin + # Be sure the input file exists, if so the get the root part of + # the filename. + call sprintf (cfname, SZ_PATHNAME, "%s/%s") + call pargstr (cache) + call pargstr (in) + if (access (in, 0, 0) == NO) { + if (access (cfname, 0, 0) == NO) { + call strcpy ("", out, SZ_FNAME) + return + } + } else + call strcpy (in, cfname, SZ_PATHNAME) + + # Break up the filename. + if (fnldir (cfname, dirname, SZ_PATHNAME) == NULL) + call strcpy ("./", dirname, SZ_PATHNAME) # use current dir + if (fnroot (cfname, root, SZ_FNAME) == NULL) + call strcpy (in, root, SZ_PATHNAME) # use current dir + + # Read the dotfile to get the source string. + if (root[1] == '.') + call sprintf (dotfile, maxch, "%s/%s") + else + call sprintf (dotfile, maxch, "%s/.%s") + call pargstr (cache) + call pargstr (root) + + if (access (dotfile, 0, 0) == YES) { + fd = open (dotfile, READ_ONLY, TEXT_FILE) + if (getline (fd, line) == EOF) + call aclrc (out, maxch) + call close (fd) + } else + call aclrc (line, SZ_LINE) + + # Copy to the output string. + len = strlen (line) + line[len] = '\0' + call strcpy (line, out, SZ_LINE) +end + + +# FC_FIND_EXTN -- Given a cache filename, see if a file/link exists with +# an extension and return the extn string. + +procedure fc_find_extn (cache, cfname, extn, maxch) + +char cache[ARB] #i cache directory +char cfname[ARB] #i cache file name +char extn[ARB] #o file extension +int maxch #i size of output string + +char fname[SZ_LINE], cmp[SZ_PATHNAME] +int fd, clen, flen + +int diropen(), strncmp(), strlen(), getline() + +begin + call strcpy (cfname, cmp, maxch) + call strcat (".", cmp, maxch) + clen = strlen (cmp) + + fd = diropen (cache, SKIP_HIDDEN_FILES) + while (getline (fd, fname) != EOF) { + flen = strlen (fname) + fname[flen] = '\0' + + if (strncmp (fname, cmp, clen) == 0) { + call strcpy (fname[clen+1], extn, maxch) + break + } + } + call close (fd) +end diff --git a/sys/fio/fcanpb.x b/sys/fio/fcanpb.x new file mode 100644 index 00000000..a3c58ab8 --- /dev/null +++ b/sys/fio/fcanpb.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# FCANPB -- Cancel any pushed back data, restoring the original file pointers. +# This should be done before performing any non-i/o operation which relys +# upon the FIO data structures being in their normal state (e.g., before the +# file buffers are deallocated). + +procedure fcanpb (fd) + +int fd # file descriptor + +int pb_sp +int and() +include + +begin + fp = fiodes[fd] + + while (and (fflags[fd], FF_PUSHBACK) != 0) { + pb_sp = FPBSP(fp) + + iop[fd] = Memi[pb_sp]; pb_sp = pb_sp + 1 + itop[fd] = Memi[pb_sp]; pb_sp = pb_sp + 1 + bufptr[fd] = Memi[pb_sp]; pb_sp = pb_sp + 1 + FPBIOP(fp) = Memi[pb_sp]; pb_sp = pb_sp + 1 + + FPBSP(fp) = pb_sp + + # When the pb stack pointer reaches the top of the pushback buffer, + # all pushed back data has been read. Note that the stack pointer + # is a pointer to int while FPBTOP is a pointer to char. + + if (pb_sp >= (FPBTOP(fp) - 1) / SZ_INT + 1) + fflags[fd] = fflags[fd] - FF_PUSHBACK + } +end diff --git a/sys/fio/fchdir.x b/sys/fio/fchdir.x new file mode 100644 index 00000000..92b34ee0 --- /dev/null +++ b/sys/fio/fchdir.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# FCHDIR -- Change the current working directory. + +procedure fchdir (newdir) + +char newdir[ARB] + +int ip, status +pointer sp, vfn, osfn1, osfn2 +int ki_extnode(), envfind() +errchk fmapfn, ki_extnode + +begin + call smark (sp) + call salloc (vfn, SZ_FNAME, TY_CHAR) + call salloc (osfn1, SZ_PATHNAME, TY_CHAR) + call salloc (osfn2, SZ_PATHNAME, TY_CHAR) + + call strcpy (newdir, Memc[vfn], SZ_FNAME) + + # Check for names of the form "node!" and convert them into + # "node!home$". This will also convert the null string into + # a chdir to home$. + + ip = ki_extnode (Memc[vfn], Memc[osfn1], SZ_PATHNAME, status) + if (newdir[ip+1] == EOS) + call strcat ("home$", Memc[vfn], SZ_FNAME) + + # Try the name as is. + call fmapfn (Memc[vfn], Memc[osfn1], SZ_PATHNAME) + call strupk (Memc[osfn1], Memc[osfn1], SZ_PATHNAME) + + call zfpath (Memc[osfn1], Memc[osfn2], SZ_PATHNAME, status) + call zfsubd (Memc[osfn2], SZ_PATHNAME, "", status) + + call strpak (Memc[osfn2], Memc[osfn2], SZ_PATHNAME) + call zfchdr (Memc[osfn2], status) + + # Try chdir ldir$. + if (status == ERR) { + call strcpy (Memc[vfn], Memc[osfn1], SZ_FNAME) + if (envfind (Memc[osfn1], Memc[osfn2], SZ_PATHNAME) > 0) { + call strcat ("$", Memc[osfn1], SZ_PATHNAME) + call fmapfn (Memc[osfn1], Memc[osfn2], SZ_PATHNAME) + call zfchdr (Memc[osfn2], status) + } else + status = ERR + } + + call sfree (sp) + if (status == ERR) + call syserrs (SYS_FCHDIR, newdir) +end diff --git a/sys/fio/fclobber.x b/sys/fio/fclobber.x new file mode 100644 index 00000000..f692176e --- /dev/null +++ b/sys/fio/fclobber.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# FCLOBBER -- Clobber the named file if it exists. Avoid clobbering a file +# which is already open. File clobber is enabled by the environment variable +# of the same name. If the file exists and clobber is disabled, it is an +# error unless multiple versions are permitted ("multversions"). + +procedure fclobber (fname) + +char fname[ARB] +int fd +int access() +bool streq(), envgetb() +errchk filerr, access, envgetb +include + +begin + # Avoid clobbering a file which is already open. + + for (fd=FIRST_FD; fd <= LAST_FD; fd=fd+1) + if (fiodes[fd] != NULL) + if (streq (fname, FNAME(fiodes[fd]))) + call filerr (fname, SYS_FCLOBOPNFIL) + + # If file clobbering is disabled, make sure file does not exist, + # otherwise try to clobber the file if it exists. No clobber + # checking is performed for special devices. If "multversions" is + # disabled we assume that the OS will open a new version of the + # file rather than overwrite the old one, and the clobber error + # is defeated. + + if (access (fname,0,0) == YES) + if (envgetb ("clobber")) { + iferr (call delete (fname)) + call filerr (fname, SYS_FCANTCLOB) + } else if (!envgetb ("multversions")) + call filerr (fname, SYS_FCLOBBER) +end diff --git a/sys/fio/fcopy.x b/sys/fio/fcopy.x new file mode 100644 index 00000000..de21fba8 --- /dev/null +++ b/sys/fio/fcopy.x @@ -0,0 +1,83 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +define MIN_BUFSIZE 512 + + +# FCOPY -- Copy a file. Works for either text or binary files. The new file +# will not be created unless the input file can be opened successfully. All +# buffer space is dynamically allocated, and buffer sizes are automatically +# adjusted by the system for efficient sequential access (the actual buffer +# size is dependent on the machine, device, and file type). + +procedure fcopy (oldfile, newfile) + +char oldfile[ARB] +char newfile[ARB] + +int in, out, file_type, fd +int open(), access(), fsfopen(), fstdfile() +errchk open, fcopyo, access + +begin + if (access (oldfile, 0, TEXT_FILE) == YES) + file_type = TEXT_FILE + else + file_type = BINARY_FILE + + in = open (oldfile, READ_ONLY, file_type) + if (fstdfile (newfile, out) == NO) { + iferr (call fmkcopy (oldfile, newfile)) { + call close (in) + call erract (EA_ERROR) + } + out = open (newfile, APPEND, file_type) + } + + # Warn user if the file being copied has subfiles. + ifnoerr (fd = fsfopen (oldfile, READ_ONLY)) { + call close (fd) + call eprintf ("Warning from fcopy: file `%s' has subfiles\n") + call pargstr (oldfile) + } + + # Copy the file. + call fcopyo (in, out) + + call close (in) + call close (out) +end + + +# FCOPYO -- Copy a file, where both the input and output files have +# already been open. Works regardless of the datatype of the files. + +procedure fcopyo (in, out) + +int in # input file descriptor +int out # output file descriptor + +pointer sp, buf +int buf_size +int fstati(), read() +errchk read, write + +begin + call smark (sp) + + # Set up file buffers, intermediate buffer for efficient + # sequential i/o (advice is ignored if text file). Local buffer + # is made same size as FIO buffer. + + call fseti (in, F_ADVICE, SEQUENTIAL) + call fseti (out, F_ADVICE, SEQUENTIAL) + buf_size = max (MIN_BUFSIZE, fstati (in, F_BUFSIZE)) + call salloc (buf, buf_size, TY_CHAR) + + while (read (in, Memc[buf], buf_size) != EOF) + call write (out, Memc[buf], fstati (in, F_NCHARS)) + + call sfree (sp) +end diff --git a/sys/fio/fdebug.x b/sys/fio/fdebug.x new file mode 100644 index 00000000..6998ab98 --- /dev/null +++ b/sys/fio/fdebug.x @@ -0,0 +1,163 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# FDEBUG -- Decode and print the contents of a file descriptor or of all +# file descriptors on the standard output. + +procedure fdebug (out, fd1_arg, fd2_arg) + +int out, fd1_arg, fd2_arg +int fd, fd1, fd2, n +int and() +long note() +pointer ffp +include + +begin + fd1 = max(1, min(LAST_FD, fd1_arg)) + if (fd2_arg <= 0) + fd2 = LAST_FD + else + fd2 = max(1, min(LAST_FD, fd2_arg)) + + if (fd1 < FIRST_FD) { + n = 0 # count open files + do fd = 1, LAST_FD + if (fiodes[fd] != NULL) + n = n + 1 + + call fprintf (out, + "FIO Status: %d open files, %d installed devices\n\n") + call pargi (n) + call pargi (next_dev / LEN_DTE) # count devices + } + + for (fd=fd1; fd <= fd2; fd=fd+1) { + ffp = fiodes[fd] + if (ffp != NULL) { + call fprintf (out, "%2d (%s), %s, %s, fp=%d,\n") + call pargi (fd) + call pargstr (FNAME(ffp)) + + switch (FMODE(ffp)) { + case READ_ONLY: + call pargstr ("READ_ONLY") + case READ_WRITE: + call pargstr ("READ_WRITE") + case WRITE_ONLY: + call pargstr ("WRITE_ONLY") + case APPEND: + call pargstr ("APPEND") + case NEW_FILE: + call pargstr ("NEW_FILE") + case TEMP_FILE: + call pargstr ("TEMP_FILE") + default: + call pargstr ("ILLEGAL_FMODE") + } + + switch (FTYPE(ffp)) { + case TEXT_FILE: + call pargstr ("TEXT_FILE") + case BINARY_FILE: + call pargstr ("BINARY_FILE") + case STRING_FILE: + call pargstr ("STRING_FILE") + case SPOOL_FILE: + call pargstr ("SPOOL_FILE") + default: + call pargstr ("ILLEGAL_FTYPE") + } + call pargi (ffp) + + call fprintf (out, " ") + call fprintf (out, + "chan=%d, device=%d, epa=0%xX, filesize(chars)=%d, posn=%s,\n") + call pargi (FCHAN(ffp)) + call pargi ((FDEV(ffp)-1) / LEN_DTE + 1) + call pargi (zdev[FDEV(ffp)]) + call pargl (FILSIZE(ffp)) + + if (FILSIZE(ffp) < 0) + call pargl (note(fd)) + else if (boffset[fd] > FILSIZE(ffp)) + call pargstr ("EOF") + else + call pargl (note(fd)) + + call fprintf (out, " ") + call fprintf (out, + "iomode=%s, status=%s, refcnt=%d, afd=%d,\n") + switch (FFIOMODE(ffp)) { + case INACTIVE: + call pargstr ("INACTIVE") + case READ_IN_PROGRESS: + call pargstr ("READ_IN_PROGRESS") + case WRITE_IN_PROGRESS: + call pargstr ("WRITE_IN_PROGRESS") + default: + call pargstr ("ILLEGAL") + } + + switch (FILSTAT(ffp)) { + case ERR: + call pargstr ("ERR") + case OK: + call pargstr ("OK") + default: + call pargi (FILSTAT(ffp)) + } + + call pargi (FREFCNT(ffp)) + call pargi (FAFD(ffp)) + + call fprintf (out, " ") + call fprintf (out, + "nbufs=%d, bufsize=%d, optbufsize=%d, blksize=%d,\n") + call pargi (FNBUFS(ffp)) + call pargi (FBUFSIZE(ffp)) + call pargi (FOPTBUFSIZE(ffp)) + call pargi (FBLKSIZE(ffp)) + + call fprintf (out, " ") + call fprintf (out, + "pbbufsize=%d, pbbuf=%d, pbtop=%d, pbiop=%d, pbsp=%d,\n") + call pargi (FPBBUFSIZE(ffp)) + call pargi (FPBBUF(ffp)) + call pargi (FPBTOP(ffp)) + call pargi (FPBIOP(ffp)) + call pargi (FPBSP(ffp)) + + call fprintf (out, " ") + call fprintf (out, + "iop=%d, itop=%d, otop=%d, bp=%d, top=%d, offset=%d,\n") + call pargi (iop[fd]) + call pargi (itop[fd]) + call pargi (otop[fd]) + call pargi (bufptr[fd]) + call pargi (buftop[fd]) + call pargi (boffset[fd]) + + call fprintf (out, " Flags =") + if (and (FF_FLUSH, fflags[fd]) != 0) + call fprintf (out, " FLUSH") + if (and (FF_FLUSHNL, fflags[fd]) != 0) + call fprintf (out, " FLUSHNL") + if (and (FF_READ, fflags[fd]) != 0) + call fprintf (out, " READ") + if (and (FF_WRITE, fflags[fd]) != 0) + call fprintf (out, " WRITE") + if (and (FF_KEEP, fflags[fd]) != 0) + call fprintf (out, " KEEP") + if (and (FF_EOF, fflags[fd]) != 0) + call fprintf (out, " EOF") + if (and (FF_ERR, fflags[fd]) != 0) + call fprintf (out, " ERR") + if (and (FF_PUSHBACK, fflags[fd]) != 0) + call fprintf (out, " PUSHBACK") + call fprintf (out, "\n\n") + } + } +end diff --git a/sys/fio/fdevbf.x b/sys/fio/fdevbf.x new file mode 100644 index 00000000..beba8d4b --- /dev/null +++ b/sys/fio/fdevbf.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# FDEVBF -- Install a new binary file device in the device table, if it has +# not already been installed. + +procedure fdevbf (zard, zawr, zawt, zstt, zcls) + +int i, dev_epa +extern zard(), zawr(), zawt(), zstt(), zcls() +include + +begin + # Search the device table to see if the device is already installed. + # The ZDEV array indices the EPA of the read procedure of each device + # driver. + + call zlocpr (zard, dev_epa) + for (i=1; i < next_dev; i=i+LEN_DTE) + if (zdev[i] == dev_epa) + return + + # Device not found; install the new device in the device table. + next_dev = next_dev + LEN_DTE + if (next_dev > LEN_DEVTBL) + call syserr (SYS_FDEVTBLOVFL) + else { + call zlocpr (zard, zdev[i]) + call zlocpr (zawr, zdev[i+1]) + call zlocpr (zawt, zdev[i+2]) + call zlocpr (zstt, zdev[i+3]) + call zlocpr (zcls, zdev[i+4]) + } +end diff --git a/sys/fio/fdevblk.x b/sys/fio/fdevblk.x new file mode 100644 index 00000000..b3a73cab --- /dev/null +++ b/sys/fio/fdevblk.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# FDEVBLK -- Get the device block size of the device on which the named logical +# directory resides. The named logical directory must have write permission. +# A file pathname may be used to pass the logical directory name. + +int procedure fdevblk (path) + +char path[ARB] # pathname of directory or file + +pointer sp, fname, ldir, tempfn +int fd, junk, block_size +int fstati(), open(), fnldir() +errchk mktemp, open, close + +begin + call smark (sp) + call salloc (ldir, SZ_PATHNAME, TY_CHAR) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (tempfn, SZ_PATHNAME, TY_CHAR) + + # Generate the name of a temporary file in named directory. + junk = fnldir (path, Memc[ldir], SZ_PATHNAME) + call strcpy (Memc[ldir], Memc[fname], SZ_PATHNAME) + call strcat ("zbk", Memc[fname], SZ_PATHNAME) + call mktemp (Memc[fname], Memc[tempfn], SZ_PATHNAME) + + # Open the file and get the device block size. + iferr { + fd = open (Memc[tempfn], NEW_FILE, BINARY_FILE) + block_size = fstati (fd, F_BLKSIZE) + call close (fd) + call delete (Memc[tempfn]) + } then + call syserrs (SYS_FACCDIR, Memc[ldir]) + + call sfree (sp) + return (block_size) +end diff --git a/sys/fio/fdevtx.x b/sys/fio/fdevtx.x new file mode 100644 index 00000000..65c02fc8 --- /dev/null +++ b/sys/fio/fdevtx.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# FDEVTX -- Install a new text file device in the device table, if it has +# not already been installed. + +procedure fdevtx (zget, zput, zfls, zstt, zcls, zsek, znot) + +int i, dev_epa +extern zget(), zput(), zfls(), zstt(), zcls(), zsek(), znot() +include + +begin + # Search the device table to determine if the device has already been + # installed. The ZDEV array indices the device table by the EPA of + # each device driver. + + call zlocpr (zget, dev_epa) + for (i=1; i < next_dev; i=i+LEN_DTE) + if (zdev[i] == dev_epa) + return + + # Device not found. Install the new device in the table. + next_dev = next_dev + LEN_DTE + if (next_dev > LEN_DEVTBL) + call syserr (SYS_FDEVTBLOVFL) + else { + call zlocpr (zget, zdev[i]) + call zlocpr (zput, zdev[i+1]) + call zlocpr (zfls, zdev[i+2]) + call zlocpr (zstt, zdev[i+3]) + call zlocpr (zcls, zdev[i+4]) + call zlocpr (zsek, zdev[i+5]) + call zlocpr (znot, zdev[i+6]) + } +end diff --git a/sys/fio/fdirname.x b/sys/fio/fdirname.x new file mode 100644 index 00000000..aa24709d --- /dev/null +++ b/sys/fio/fdirname.x @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# FDIRNAME -- Return the concatenatable directory prefix for the named +# directory. If no vfn is given (null string), a path to the current +# directory is returned. + +procedure fdirname (vfn, path, maxch) + +char vfn[ARB] # VFN of directory +char path[ARB] # unpacked path to directory +int maxch + +int len1, len2, ch +int gstrcpy() + +begin + if (vfn[1] == EOS) { + # Null vfn; return current directory. + call strcpy ("./", path, maxch) + return + } + + # Do we have an OS directory reference? + call zfxdir (vfn, path, maxch, len2) + ch = path[len2] + if (len2 > 0 && !(IS_ALNUM(ch) || ch == '_')) + return + + # Do we have an "ldir$" or "subdir/"? If so, quit, else if the last + # char is a normal identifier class filename char, assume that we have + # a VFN and add the / delimiter. This technique is not infallible, + # and a better solution would be to have ZFXDIR or FDIRNAME itself + # execute on the remote node. + + len1 = gstrcpy (vfn, path, maxch) + ch = path[len1] + if (ch == '$' || ch == '/') + return + + # Must be a subdirectory of the form "subdir". Add the /. + path[len1+1] = '/' + path[len1+2] = EOS +end diff --git a/sys/fio/fexbuf.x b/sys/fio/fexbuf.x new file mode 100644 index 00000000..38ba5b3d --- /dev/null +++ b/sys/fio/fexbuf.x @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +define INC_BUFSIZE 4096 + + +# FEXBUF -- Expand the size of the file buffer. Called by FLSBUF when the FIO +# buffer fills while writing to a file of type SPOOL_FILE. Spool files are +# files of arbitrary size, buffered entirely in memory. Typically, a finite +# amount of data is written into a spoolfile, the file is rewound, the data +# is read back out, and so on. This makes it possible to use the file interface +# to pass data between program modules. + +procedure fexbuf (fd) + +int fd # file which needs a larger buffer + +pointer bp +int offset +errchk malloc, realloc +include + +begin + fp = fiodes[fd] + bp = bufptr[fd] + offset = iop[fd] - bp + + if (bufptr[fd] == NULL) { + if (FBUFSIZE(fp) == 0) + FBUFSIZE(fp) = SZ_SPOOLBUF + call malloc (bp, FBUFSIZE(fp), TY_CHAR) + } else { + FBUFSIZE(fp) = FBUFSIZE(fp) + INC_BUFSIZE + call realloc (bp, FBUFSIZE(fp), TY_CHAR) + } + + boffset[fd] = 1 + bufptr[fd] = bp + buftop[fd] = bp + FBUFSIZE(fp) + + iop[fd] = bp + offset + itop[fd] = iop[fd] + otop[fd] = buftop[fd] +end diff --git a/sys/fio/ffault.x b/sys/fio/ffault.x new file mode 100644 index 00000000..76f43f4a --- /dev/null +++ b/sys/fio/ffault.x @@ -0,0 +1,127 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# FFAULT -- Read a file block into the file buffer (pick up file buffer and +# put it down on another part of the file). Although in this implementation +# there is only a single, local, file buffer for each file, in the future +# a variable number of either global or local buffers will be supported, as +# well as read ahead and write behind (see Fio.doc). + +int procedure ffault (fd, file_offset, nreserve, rwflag) + +int fd +long file_offset # char offset to be faulted in +int nreserve # size of transfer pending +int rwflag # next access is a read or a write + +pointer bp +long buffer_offset, fboff +int bufsize, nchars_read +bool block_write, stream, at_eof + +int and() +errchk ffilbf, fflsbf, fwatio +define ioerror_ 91 +include + +begin + # assert (file open, buffer already created) + # assert (iop does not point into buffer) + + fp = fiodes[fd] + bp = bufptr[fd] + bufsize = FBUFSIZE(fp) + fboff = FIRSTBUFOFF(fp) + stream = (FBLKSIZE(fp) == 0) + + # Calculate buffer_offset (modulus file buffer size). If the output + # device is a pipe or terminal (stream device), which does not permit + # rewriting of data and seeking, empty buffer. + + if (stream) { + buffer_offset = file_offset + } else if (file_offset <= 0) { + iferr (call filerr (FNAME(fp), SYS_FSEEK)) + goto ioerror_ + } else + buffer_offset = (file_offset-fboff) / bufsize * bufsize + fboff + + # Update i/o pointers (if an empty or partially full buffer has been + # written into, determine the top of the valid part of the buffer). + + UPDATE_IOP(fd) + + # Flush buffer if it has been written into. Write out only as much + # of the buffer as has been filled. + + if (BUF_MODIFIED(fd)) { + iferr (call fflsbf (fd, bp, otop[fd]-bp, boffset[fd])) + goto ioerror_ + + # We need to do this wait here since we immediately use this buffer + # without doing a wait. Which screws up the data going out to disk. + # This can be done away with when multi-buffering is done. (FJR). + + call fwatio (fd) + } + + # Fill buffer from file only if the file was opened with read + # permission, and if the fault was not caused by a WRITE which will + # immediately overwrite the entire contents of the buffer. + + if (rwflag == FF_WRITE) { + block_write = (stream || + (file_offset == buffer_offset && nreserve >= bufsize)) + } else + block_write = false + + if (block_write) { + itop[fd] = bp + otop[fd] = bp + + } else if (and(FF_READ,fflags[fd]) == 0) { + # Read is disabled. Zero-fill buffer; if inside existing + # random access file, set ITOP to end of buffer so that the + # entire buffer will be written when flushed. + + at_eof = (FILSIZE(fp) >= 0 && buffer_offset > FILSIZE(fp)) + otop[fd] = bp + + if (at_eof) + itop[fd] = bp + else + itop[fd] = bp + bufsize + + # Zero-fill the buffer. + call aclrc (Memc[bp], bufsize) + + } else { + iferr { + # Initialize buffer from file. + call ffilbf (fd, bp, bufsize, buffer_offset) + call fwatio (fd) + } then + goto ioerror_ + } + + boffset[fd] = buffer_offset + LSEEK (fd, file_offset) # set i/o pointer + + nchars_read = itop[fd] - iop[fd] + if (nchars_read <= 0) + return (EOF) + else + return (nchars_read) # only valid for a read + + # If an i/o error occurs, mark the buffer empty and pass the error + # back to our caller. + +ioerror_ + itop[fd] = bp + otop[fd] = bp + call erract (EA_ERROR) +end diff --git a/sys/fio/ffilbf.x b/sys/fio/ffilbf.x new file mode 100644 index 00000000..8948ce89 --- /dev/null +++ b/sys/fio/ffilbf.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# FFILBF -- Called by FFAULT to fill the file buffer for a binary file. + +procedure ffilbf (fd, bp, bufsize, buffer_offset) + +int fd, bufsize +pointer bp +bool at_eof, stream_dev +long buffer_offset +errchk fwatio +include + +begin + fp = fiodes[fd] + + if (FBUFMODE(fp) != INACTIVE) + call fwatio (fd) + + # If streaming device, read unconditionally, otherwise if + # positioned at EOF, initialize buffer pointers and return, + # else initiate read to fill buffer from file and return. + + stream_dev = (FBLKSIZE(fp) == 0) + at_eof = (FILSIZE(fp) >= 0 && buffer_offset > FILSIZE(fp)) + + if (!stream_dev && at_eof) { + itop[fd] = bufptr[fd] + otop[fd] = bufptr[fd] + } else { + call aread (fd, Memc[bp], bufsize, buffer_offset) + FBUFMODE(fp) = READ_IN_PROGRESS + } +end diff --git a/sys/fio/ffilsz.x b/sys/fio/ffilsz.x new file mode 100644 index 00000000..2a8a2926 --- /dev/null +++ b/sys/fio/ffilsz.x @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# FFILSZ -- Return file size in chars. When first called, the status +# z-routine for the channel is called to get the file size. Thereafter, +# FIO keeps track of the file size. + +long procedure ffilsz (fd) + +int fd +long file_size +include + +begin + fp = fiodes[fd] + UPDATE_IOP(fd) # update i/o pointers + + switch (FTYPE(fp)) { + case TEXT_FILE: + call zcall3 (ZSTTTX(fp), FCHAN(fp), FSTT_FILSIZE, file_size) + file_size = file_size + (otop[fd] - bufptr[fd]) + + case STRING_FILE, SPOOL_FILE: + file_size = otop[fd] - bufptr[fd] + + default: + # Call channel status z-routine to get file size if this is the + # first request. Thereafter, FIO keeps track of file size. + # Beware that FILSIZE (updated by AWRITE or by us) does not + # necessarily include data just recently written into the current + # buffer. + + if (FILSIZE(fp) < 0) { + call zcall3 (ZSTTBF(fp), FCHAN(fp), FSTT_FILSIZE, file_size) + file_size = (file_size + SZB_CHAR-1) / SZB_CHAR + } else + file_size = FILSIZE(fp) + + # If writing at EOF (or first block of a new file), and the file + # buffer has not yet been flushed, the file size is the buffer + # offset minus one (number of chars written to disk) plus the + # number of chars in the file buffer. + + if (BUF_MODIFIED(fd)) + file_size = max (file_size, + boffset[fd]-1 + (itop[fd] - bufptr[fd])) + } + + FILSIZE(fp) = file_size # update fildes + return (file_size) +end diff --git a/sys/fio/fflsbf.x b/sys/fio/fflsbf.x new file mode 100644 index 00000000..7503609a --- /dev/null +++ b/sys/fio/fflsbf.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# FFLSBF -- Flush the file buffer. Called by FFAULT to initiate a write +# of the file buffer when a fault occurs. + +procedure fflsbf (fd, bp, maxchars, buffer_offset) + +int fd +pointer bp +int maxchars +long buffer_offset +errchk fwatio +include + +begin + fp = fiodes[fd] + + if (FBUFMODE(fp) != INACTIVE) + call fwatio (fd) + call awrite (fd, Memc[bp], maxchars, buffer_offset) + + FBUFMODE(fp) = WRITE_IN_PROGRESS +end diff --git a/sys/fio/fgdevpar.x b/sys/fio/fgdevpar.x new file mode 100644 index 00000000..b9da21b3 --- /dev/null +++ b/sys/fio/fgdevpar.x @@ -0,0 +1,88 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +.help fgdev_param +.nf ________________________________________________________________________ +FGDEV_PARAM -- Get device parameters (block size, optimum buffer size) +and set up file descriptor accordingly. Called by FILOPN and FINIT. + + FSTT_BLKSIZE Device block size: + >= 1 if block structured device + == 0 if streaming device (terminal, + pipe, tape, etc.) + + FSTT_OPTBUFSIZE Minimum optimal buffer size for efficient + sequential i/o. Actual buffer size may be + any integer multiple of this value. + + FSTT_MAXBUFSIZE Maximum buffer size permitted, i.e., maximum + size transfer permitted in a call to aread + or awrite. FIO will not create a buffer + larger than this value, but will try to use + a larger buffer if created externally. + + FSTT_FILSIZE File size, chars. This is requested only + once for an open file, and is not requested + for streaming binary files. +.endhelp ____________________________________________________________________ + +procedure fgdev_param (fd) + +int fd +pointer ffp +long fgdev0(), ffilsz() +errchk fgdev0, ffilsz +include + +begin + ffp = fiodes[fd] + + FBLKSIZE(ffp) = max (0, fgdev0 (ffp, FSTT_BLKSIZE)) + FOPTBUFSIZE(ffp) = max (1, fgdev0 (ffp, FSTT_OPTBUFSIZE)) + FMAXBUFSIZE(ffp) = max (0, fgdev0 (ffp, FSTT_MAXBUFSIZE)) + FIRSTBUFOFF(ffp) = 1 + + # If regular device, and file size is not yet known, get file size. + if (FBLKSIZE(ffp) > 0 && FILSIZE(ffp) < 0) { + FILSIZE(ffp) = fgdev0 (ffp, FSTT_FILSIZE) + FILSIZE(ffp) = ffilsz (fd) # add buffered output + } + + if (FTYPE(ffp) == BINARY_FILE) + FBUFSIZE(ffp) = FOPTBUFSIZE(ffp) + else + FBUFSIZE(ffp) = max (SZ_LINE, FOPTBUFSIZE(ffp)) +end + + +# FGDEV0 -- Internal procedure to get status from either a text or binary +# file, rounding the byte count up to an integral number of chars. + +long procedure fgdev0 (ffp, what) + +pointer ffp +int what + +long nbytes +int status_epa +include + +begin + if (FTYPE(ffp) == BINARY_FILE) + status_epa = ZSTTBF(ffp) + else + status_epa = ZSTTTX(ffp) + + call zcall3 (status_epa, FCHAN(ffp), what, nbytes) + if (nbytes == ERR) + call filerr (FNAME(ffp), SYS_FDEVSTAT) + + if (FTYPE(ffp) == BINARY_FILE) + return ((nbytes+SZB_CHAR-1) / SZB_CHAR) + else + return (nbytes) +end diff --git a/sys/fio/fgetfd.x b/sys/fio/fgetfd.x new file mode 100644 index 00000000..7669421f --- /dev/null +++ b/sys/fio/fgetfd.x @@ -0,0 +1,135 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# FGETFD -- Allocate a file descriptor. Called by all OPEN routines. +# Search static part of file descriptor storage for an open file descriptor. +# Allocate memory for rest of file descriptor, initialize all fields. + +int procedure fgetfd (filename, mode, type) + +char filename[ARB] # name of file to be assigned a descriptor +int mode # access mode +int type # file type + +int fd +int fsetfd() +include + +begin + for (fd=FIRST_FD; fd <= LAST_FD && fiodes[fd] != NULL; fd=fd+1) + ; + if (fd > LAST_FD) # out of descriptors + call syserr (SYS_FTOOMANYFILES) + + return (fsetfd (fd, filename, mode, type)) +end + + +# FSETFD -- Initialize the file descriptor FD. + +int procedure fsetfd (fd, filename, mode, type) + +int fd # fd to be initialized +char filename[ARB] # name of file to be assigned to FD +int mode # access mode +int type # file type + +int or() +errchk calloc, filerr, syserr +include +include "mmap.inc" + +begin + # Allocate descriptor. + call calloc (fp, LEN_FIODES, TY_STRUCT) + + iop[fd] = NULL + itop[fd] = NULL + otop[fd] = NULL + bufptr[fd] = NULL + buftop[fd] = NULL + boffset[fd] = 1 + redir_fd[fd] = NULL + fflags[fd] = 0 + fiodes[fd] = fp # set ptr to fildes + FCD(fp) = FLCD(fp) # set ptr to chandes + + # Set the file permission bits for the given mode. Note that read + # permission is required in append mode on a binary file since the + # partial block at the end of the file has to be read in before we + # can append to it. + + switch (mode) { + case STRING_FILE, SPOOL_FILE: + # (neither read or write perm, disable flushnl) + case READ_ONLY: + fflags[fd] = FF_READ + FILSIZE(fp) = -1 # file size unknown + case WRITE_ONLY: + fflags[fd] = FF_WRITE + FILSIZE(fp) = -1 # file size unknown + case READ_WRITE, APPEND: + fflags[fd] = FF_READ + FF_WRITE + FILSIZE(fp) = -1 + case NEW_FILE, TEMP_FILE: + if (type == STATIC_FILE) { + fiodes[fd] = NULL + call mfree (fp, TY_STRUCT) + call filerr (filename, SYS_FSFOPNF) + } + fflags[fd] = FF_READ + FF_WRITE + FILSIZE(fp) = 0 # zero length file + default: + fiodes[fd] = NULL + call mfree (fp, TY_STRUCT) + call filerr (filename, SYS_FILLEGMODE) + } + + switch (type) { + case STRING_FILE, SPOOL_FILE: + # Allocate an (improper) device for string "files". Since there + # is no channel for a string file, any improper i/o on a string + # file will result in an error return. + + FDEV(fp) = TX_DRIVER + + # Spool files have all read and write permissions turned off + # so that they never try to write to a device driver - the file + # consists of only the buffered data. Spool files are considered + # to be streaming binary files, so also set the blk size to 0. + + if (type == SPOOL_FILE) { + fflags[fd] = 0 + FBLKSIZE(fp) = 0 + } + + case TEXT_FILE: + fflags[fd] = or (FF_FLUSH, fflags[fd]) + FDEV(fp) = TX_DRIVER + case BINARY_FILE: + FDEV(fp) = BF_DRIVER + case STATIC_FILE: + FDEV(fp) = SF_DRIVER + default: + fiodes[fd] = NULL + call mfree (fp, TY_STRUCT) + call filerr (filename, SYS_FILLEGTYPE) + } + + # A static file is equivalent to a binary file at the VOS level. + FMODE(fp) = mmap[mode] + if (type == STATIC_FILE) + FTYPE(fp) = BINARY_FILE + else + FTYPE(fp) = type + + FCHAN(fp) = -1 + FNBUFS(fp) = 1 + FREFCNT(fp) = 1 # no. fd active on chan + call strcpy (filename, FNAME(fp), SZ_FFNAME) + + return (fd) +end diff --git a/sys/fio/filbuf.x b/sys/fio/filbuf.x new file mode 100644 index 00000000..55878cad --- /dev/null +++ b/sys/fio/filbuf.x @@ -0,0 +1,113 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# FILBUF -- Fill the file buffer. Called by GETC, GETLINE, and READ when the +# i/o pointer no longer points into the file buffer. This happens when +# (1) there is no file buffer yet, (2) all the data in the buffer has been +# read, or (3) a SEEK has occurred. + +int procedure filbuf (fd) + +int fd #I input file + +pointer bp, pb_sp +int maxch, nchars_read + +int ffault() +errchk fmkbfs, ffault, filerr, syserr +include +define again_ 91 + +begin + fp = fiodes[fd] + if (fd <= 0 || fp == NULL) # verification + call syserr (SYS_FILENOTOPEN) +again_ + if (and (FF_READ+FF_PUSHBACK, fflags[fd]) == 0) { + if (FTYPE(fp) == STRING_FILE || FTYPE(fp) == SPOOL_FILE) + return (EOF) + else + call filerr (FNAME(fp), SYS_FNOREADPERM) + } + + # If filbuf was called at the end of a pushed back block of data, + # pop the old i/o pointers off the pushback stack and resume i/o + # at the point at which it was interrupted. + + if (and (fflags[fd], FF_PUSHBACK) != 0) { + repeat { + pb_sp = FPBSP(fp) + + iop[fd] = Memi[pb_sp]; pb_sp = pb_sp + 1 + itop[fd] = Memi[pb_sp]; pb_sp = pb_sp + 1 + bufptr[fd] = Memi[pb_sp]; pb_sp = pb_sp + 1 + FPBIOP(fp) = Memi[pb_sp]; pb_sp = pb_sp + 1 + + FPBSP(fp) = pb_sp + + # When the pb stack pointer reaches the top of the pushback + # buffer, all pushed back data has been read. Note that the + # stack pointer is a pointer to int while FPBTOP is a pointer + # to char. + + if (pb_sp >= (FPBTOP(fp) - 1) / SZ_INT + 1) + fflags[fd] = fflags[fd] - FF_PUSHBACK + + # If there was no data left when pushback occurred, then we + # aren't done yet. + + nchars_read = itop[fd] - iop[fd] + if (nchars_read > 0) + return (nchars_read) + + } until (and (fflags[fd], FF_PUSHBACK) == 0) + goto again_ + } + + # If we do not have a file buffer yet, allocate one. + bp = bufptr[fd] + if (bp == NULL) { + call fmkbfs (fd) + bp = bufptr[fd] + } + + if (FTYPE(fp) == TEXT_FILE) { + # Get next line from text file, initialize pointers. In raw mode + # we only read one character at a time. + + if (and (FF_RAW, fflags[fd]) == 0) + maxch = FBUFSIZE(fp) + else + maxch = 1 + call zcall4 (ZGETTX(fp), FCHAN(fp), Memc[bp], maxch, nchars_read) + + iop[fd] = bp + itop[fd] = max (bp, bp + nchars_read) + otop[fd] = bp + + } else if (FNCHARS(fp) < 0) { + # Validate data in buffer without performing a physical read (used + # to attempt error recovery following a read error - see fseti). + + nchars_read = -FNCHARS(fp) + iop[fd] = bp + itop[fd] = bp + nchars_read + otop[fd] = bp + + } else { + # Fill buffer from binary file. + nchars_read = ffault (fd, LNOTE(fd), 0, FF_READ) + } + + switch (nchars_read) { + case ERR: + call filerr (FNAME(fp), SYS_FREAD) + case 0: + return (EOF) + default: + return (nchars_read) # (or ERR) + } +end diff --git a/sys/fio/filerr.x b/sys/fio/filerr.x new file mode 100644 index 00000000..2f5b07da --- /dev/null +++ b/sys/fio/filerr.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# FILERR -- Take an error action, including the name of the file in the +# error message. Note that the order of the arguments is reversed in +# filerr and syserr; this is unfortunate, but too hard to change at this +# point. The logic behind this (if there is any) is that the main operand +# of filerr is the file name, that of syserr the error number. + +procedure filerr (fname, errcode) + +char fname[ARB] +int errcode + +begin + call syserrs (errcode, fname) +end diff --git a/sys/fio/filopn.x b/sys/fio/filopn.x new file mode 100644 index 00000000..72a71309 --- /dev/null +++ b/sys/fio/filopn.x @@ -0,0 +1,164 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include + +# FILOPN -- Open a file on an installed device. A file descriptor is +# allocated and initialized. If a new file is being opened, file clobber +# (overwrite) checking is performed. If the file exists but cannot be +# accessed because it is open by another process, and file waiting is +# enabled (usually in batch mode), the process is blocked until the file +# becomes available. If one attempts to "open" one of the files "STDIN", +# "STDOUT", "STDERR", etc. the fd of the appropriate standard file is returned. +# Interrupts are disabled while the VFN database is open to protect the +# database, ensure that that the lock on the mapping file is cleared, and to +# ensure that the mapping file is closed. + +int procedure filopn (fname, mode, type, zopen_proc, device) + +char fname[ARB] # virtual file name +int mode # access mode (ro,rw,apnd,newf,temp) +int type # text or binary file +extern zopen_proc(), device() + +pointer vp +bool standard_device +int ip, fd, dev_epa, junk, status, vfnmode + +pointer vfnopen() +int fgetfd(), fstdfile(), vfnadd(), vfnmap(), locpr() +errchk fwtacc, seek, fclobber, fgetfd +include +define cleanup_ 91 +define close_ 92 +define abort_ 93 + +begin + for (ip=1; IS_WHITE (fname[ip]); ip=ip+1) + ; + + # Do not bother to check access mode if reopening a standard + # stream. If one attempts to write to STDIN or read from STDOUT, + # a suitable error message will be generated at that time. If + # a standard file such as STDIN is reopened read-write but never + # written to, however, that is acceptable. + + if (fstdfile (fname[ip], fd) == YES) # standard stream? + return (fd) + + # Determine if "device" is a standard disk device, i.e., the driver + # TX or BF or the static file driver SF. Clobber and filewait are + # only performed for disk files. + + dev_epa = locpr (device) + standard_device = (dev_epa == zdev[TX_DRIVER] || + dev_epa == zdev[BF_DRIVER] || + dev_epa == zdev[SF_DRIVER]) + + # Perform clobber checking and waiting only for standard devices. + # If clobber is enabled and we are opening a new file, any existing + # file will be deleted. + + if (standard_device && (mode == NEW_FILE || mode == TEMP_FILE)) + call fclobber (fname[ip]) + + # Allocate and initialize the file descriptor. + fd = fgetfd (fname[ip], mode, type) + call fseti (fd, F_DEVICE, dev_epa) + fp = fiodes[fd] + + # Get OS pathname of file. + if (standard_device) { + + # Don't open VFN with write perm if file is readonly, else + # lockout may occur on the mapping file. + + if (FMODE(fp) == READ_ONLY) + vfnmode = VFN_READ + else + vfnmode = VFN_WRITE + + call intr_disable() + iferr (vp = vfnopen (fname[ip], vfnmode)) + goto abort_ + + if (FMODE(fp) == NEW_FILE) { + iferr (junk = vfnadd (vp, FPKOSFN(fp), SZ_FFNAME)) + goto close_ + } else { + iferr (status = vfnmap (vp, FPKOSFN(fp), SZ_FFNAME)) + goto close_ + if (status == ERR) + iferr (call syserrs (SYS_FOPEN, fname[ip])) + goto close_ + } + + iferr (call vfnclose (vp, VFN_UPDATE)) + goto abort_ + call intr_enable() + + } else + call strpak (fname[ip], FPKOSFN(fp), SZ_FFNAME) + + # Open file. If file exists on a standard device but cannot be + # accessed and "filewait" is enabled, wait for file to become + # accessible. + + repeat { + call zopen_proc (FPKOSFN(fp), FMODE(fp), FCHAN(fp)) + FDEVOPEN(fp) = locpr (zopen_proc) + + fp = fiodes[fd] + if (FCHAN(fp) == ERR) { + iferr { + if (standard_device) { + iferr (call fwtacc (fd, fname[ip])) + call syserrs (SYS_FOPEN, fname[ip]) + } else { + call syserrs (SYS_FOPENDEV, fname[ip]) + } + } then + goto cleanup_ + } else + break + } + + # Get the device parameters (block size, file size, streamer, etc.) + iferr (call fgdev_param (fd)) + goto cleanup_ + + iferr { + if (mode == APPEND) + call seek (fd, EOFL) + else + call seek (fd, BOFL) + + # Save name of temporary file for automatic deletion at program + # termination. + if (mode == TEMP_FILE) + call fsvtfn (fname) + } then + goto cleanup_ + + return (fd) + +cleanup_ + call frtnfd (fd) + call erract (EA_ERROR) + return (ERR) + + + # Error recovery nasties for when the VFN is open. +close_ + iferr (call vfnclose (vp, VFN_NOUPDATE)) + ; +abort_ + call frtnfd (fd) + call intr_enable() + call erract (EA_ERROR) + return (ERR) +end diff --git a/sys/fio/finfo.x b/sys/fio/finfo.x new file mode 100644 index 00000000..898b354b --- /dev/null +++ b/sys/fio/finfo.x @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +.help finfo +.nf ___________________________________________________________________________ +FINFO -- Return information on the named file (directory entry). +See for a definition of the contents of the output structure. + +The times are returned in units of seconds from midnight on Jan 1, 1980, +local standard time. Use CTIME to convert the integer time into a character +string. The owner name is returned as a character string (stored as chars +in the long integer finfo array). The owner permissions are bits 1-2 of the +FI_PERM field, group permissions are bits 3-4, world bits 5-6. The meaning +of the bits are RW (read, write). Execute permission is indicated by a +file type. Note that the file size is returned in BYTES, rather than chars +(bytes are more desirable for directory listings). + +Call ZFPROT to determine if a file has delete permission. Call ACCESS to +determine if a "regular" file is of type text or binary. This information +requires additional expense to obtain on some systems, is not required for +a simple directory listing, and hence is not provided by FINFO. +.endhelp ______________________________________________________________________ + +int procedure finfo (fname, ostruct) + +char fname[ARB] +long ostruct[LEN_FINFO] +int status +include + +begin + iferr (call fmapfn (fname, pathname, SZ_PATHNAME)) + return (ERR) + + call zfinfo (pathname, ostruct, status) + + # ZFINFO returns the file owner string as a packed string. + if (status != ERR) + call strupk (FI_OWNER(ostruct), FI_OWNER(ostruct), FI_SZOWNER) + + return (status) +end diff --git a/sys/fio/finit.x b/sys/fio/finit.x new file mode 100644 index 00000000..730afa0a --- /dev/null +++ b/sys/fio/finit.x @@ -0,0 +1,70 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include + +# FINIT -- Initialize FIO. Called once by the IRAF Main upon process startup. +# Mark all file descriptors empty and install drivers for the standard file +# defices, i.e., text file, binary file, terminal, and IPC. + +procedure finit() + +int fd, first_time + +extern zgettx(), zputtx(), zflstx(), zstttx(), zclstx(), zsektx(), znottx() +extern zgetty(), zputty(), zflsty(), zsttty(), zclsty(), zsekty(), znotty() +extern zgettt(), zputtt(), zflstt(), zstttt(), zclstt(), zsektt(), znottt() +extern zgetnu(), zputnu(), zflsnu(), zsttnu(), zclsnu(), zseknu(), znotnu() +extern zardbf(), zawrbf(), zawtbf(), zsttbf(), zclsbf() +extern zardsf(), zawrsf(), zawtsf(), zsttsf(), zclssf() +extern zardpr(), zawrpr(), zawtpr(), zsttpr(), pr_zclspr() +extern zardps(), zawrps(), zawtps(), zsttps(), zclsps() +extern zardnu(), zawrnu(), zawtnu() + +include +data first_time /YES/ +errchk syserr + +begin + # If we are called more than once it is probably due to a name conflict + # with a user routine, so generate a fatal error abort. + + if (first_time == YES) + first_time = NO + else iferr (call syserr (SYS_FINITREP)) + call erract (EA_FATAL) + + # Free up all the file descriptors. Note that FDs 1 through FIRST_FD + # will be assigned to CLIN through STDERR by CLOPEN. + + do fd = 1, LAST_FD + fiodes[fd] = NULL + + # Install the standard devices in the device table. The first entry + # should be the standard text file device, followed by the standard + # binary file device. NOTE: the standard devices must be installed + # in the table in the order TX,BF,TY,PR,SF to agree with the device + # code definitions in fio.h. The NU drivers implement the nullfile. + + next_dev = 1 + call fdevtx (zgettx, zputtx, zflstx, zstttx, zclstx, zsektx, znottx) + call fdevbf (zardbf, zawrbf, zawtbf, zsttbf, zclsbf) + call fdevtx (zgettt, zputtt, zflstt, zstttt, zclstt, zsektt, znottt) + call fdevbf (zardpr, zawrpr, zawtpr, zsttpr, pr_zclspr) + call fdevbf (zardsf, zawrsf, zawtsf, zsttsf, zclssf) + + call fdevtx (zgetty, zputty, zflsty, zsttty, zclsty, zsekty, znotty) + call fdevtx (zgetnu, zputnu, zflsnu, zsttnu, zclsnu, zseknu, znotnu) + call fdevbf (zardnu, zawrnu, zawtnu, zsttnu, zclsnu) + call fdevbf (zardps, zawrps, zawtps, zsttps, zclsps) + + # Initialize the TEMP_FILE handler. + call fsvtfn ("") + + # Initialize the TT logical terminal driver. + call zsettt (0, TT_INITIALIZE, 0) +end diff --git a/sys/fio/fioclean.x b/sys/fio/fioclean.x new file mode 100644 index 00000000..4b4671a3 --- /dev/null +++ b/sys/fio/fioclean.x @@ -0,0 +1,130 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# FIO_CLEANUP -- Clean up FIO after a crash, or upon normal termination of +# a task. Flush all open files (harmless on read only files, closed files). +# Close all open user files, unless the KEEP flag bit is set. Delete any +# partial new files, and all temporary files. Since this routine is called +# during error restart, convert any errors into warning messages to avoid an +# infinite loop. + +procedure fio_cleanup (status) + +int status + +int fd +bool stddev +int mode, ref_count +include +errchk close + +begin + call flush (STDERR) + call fio_qflush (STDOUT, status) + call fio_qflush (STDGRAPH, status) + call fio_qflush (STDIMAGE, status) + call fio_qflush (STDPLOT, status) + + for (fd=1; fd < FIRST_FD; fd=fd+1) { + # Cancel any pushback on the standard streams. + if (and (fflags[fd], FF_PUSHBACK) != 0) + call fcanpb (fd) + + # If any of the standard streams have been redirected locally (>0), + # cancel the redirection and close the redirection files. + # If streams were redirected by parent (<0), cancel the flag as + # the duration of the flag is only until task termination. + + if (redir_fd[fd] > 0) { + iferr (call close (fd)) + ; + } else if (redir_fd[fd] < 0) + redir_fd[fd] = 0 + } + + # Restore the default no flush on newline attribute to STDOUT. + call fseti (STDOUT, F_FLUSHNL, NO) + + # Delete any files opened TEMP_FILE during program execution. + iferr (call frmtmp()) + call erract (EA_WARN) + + # Close all open user files unless the F_KEEP (keep open) flag has + # been set. + + for (fd=FIRST_FD; fd <= LAST_FD; fd=fd+1) { + fp = fiodes[fd] + + if (fp != NULL) { # file open? + # Do nothing if file is to be kept open. + if (and (FF_KEEP, fflags[fd]) != 0) + next + + # Do not try to flush the output of a string file, or it + # will cause error recursion. The mode of the string file + # is reset to READ_ONLY to avoid writing the EOS at the end + # of the string buffer, as if the file is being closed during + # cleanup following task termination (which should not + # normally be the case) the buffer may no longer exist. + + if (FTYPE(fp) == STRING_FILE) { + call strsetmode (fd, READ_ONLY) + call close (fd) + next + } else if (FTYPE(fp) == SPOOL_FILE) { + call close (fd) + next + } + + iferr (call fio_qflush (fd, status)) + call erract (EA_WARN) # keep open? + + stddev = (FDEV(fp)==TX_DRIVER || FDEV(fp)==BF_DRIVER) + call strcpy (FNAME(fp), pathname, SZ_PATHNAME) + ref_count = FREFCNT(fp) - 1 + mode = FMODE(fp) + + iferr { + call close (fd) + + # Delete any new files that have been only partially + # written into. + + if (stddev && mode == NEW_FILE && ref_count <= 0) + call delete (pathname) + } then + call erract (EA_WARN) + } + } +end + + +# FIO_QFLUSH -- If cleanup is being performed following normal task completion +# (status is OK), flush any buffered output to file. If cleanup occurs during +# error restart, cancel any buffered output. + +procedure fio_qflush (fd, status) + +int fd, status +pointer bp +include + +begin + if (status == OK) { + # Flush any buffered output. + call flush (fd) + + } else { + # Cancel any buffered output. + call fcanpb (fd) + + bp = bufptr[fd] + itop[fd] = bp + otop[fd] = bp + iop[fd] = bp + } +end diff --git a/sys/fio/flsbuf.x b/sys/fio/flsbuf.x new file mode 100644 index 00000000..6f651577 --- /dev/null +++ b/sys/fio/flsbuf.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# FLSBUF -- Flush the file buffer. Called by PUTC, PUTLINE, and WRITE +# when the i/o pointer no longer points into the file buffer. Prior to +# the first write to a buffer, the OTOP pointer will be set to the +# beginning of the buffer. The first call to FLSBUF advances OTOP to the +# end of the buffer. The next call to FLSBUF finds the buffer "dirty", +# and flushes the buffer, leaving the buffer ready to be written into +# (OTOP left pointing at the end of the buffer). A seek on a binary file +# will usually leave the i/o pointer pointing outside the buffer, which +# requires a call to FFAULT (file fault). + +procedure flsbuf (fd, nreserve) + +int fd, nreserve +pointer bp +bool iop_in_range +int nchars_written, ffault(), and() +errchk fmkbfs, syserr, filerr, ffault +include + +begin + fp = fiodes[fd] + bp = bufptr[fd] + + if (fd <= 0 || fp == NULL) # verification + call syserr (SYS_FILENOTOPEN) + else if (and (FF_WRITE, fflags[fd]) == 0) { + if (FTYPE(fp) == SPOOL_FILE) { + if (otop[fd] < buftop[fd]) + otop[fd] = buftop[fd] + else + call fexbuf (fd) + return + } else + call filerr (FNAME(fp), SYS_FNOWRITEPERM) + } + + iop_in_range = iop[fd] >= bufptr[fd] && iop[fd] < buftop[fd] + + if (bp == NULL) { # no buffer yet + call fmkbfs (fd) + bp = bufptr[fd] + itop[fd] = bp + if (FTYPE(fp) == BINARY_FILE) + nchars_written = ffault (fd, LNOTE(fd), nreserve, FF_WRITE) + else + nchars_written = 0 + + } else if (iop_in_range && otop[fd] < buftop[fd]) { + nchars_written = 0 # buffer not full yet? + + } else if (FTYPE(fp) == TEXT_FILE) { # text files + call fputtx (fd, Memc[bp], iop[fd] - bp, nchars_written) + iop[fd] = bp + itop[fd] = bp + + } else # binary files + nchars_written = ffault (fd, LNOTE(fd), nreserve, FF_WRITE) + + otop[fd] = buftop[fd] # make space available + + if (nchars_written == ERR) + call filerr (FNAME(fp), SYS_FWRITE) +end diff --git a/sys/fio/flush.x b/sys/fio/flush.x new file mode 100644 index 00000000..9d321059 --- /dev/null +++ b/sys/fio/flush.x @@ -0,0 +1,59 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# FLUSH -- Flush any buffered output to the file. + +procedure flush (fd) + +int fd +pointer bp +int status, and() +errchk filerr, fflsbf, fwatio +include + +begin + fp = fiodes[fd] + if (fp == NULL) + return + else if (FTYPE(fp) == STRING_FILE || FTYPE(fp) == SPOOL_FILE) + return + bp = bufptr[fd] + + call fcanpb (fd) # cancel any pushback + UPDATE_IOP(fd) # update the i/o pointers + + if (BUF_MODIFIED(fd)) { + # Buffer has been written into and must be flushed to disk. + if (and (FF_WRITE, fflags[fd]) == 0) + call filerr (FNAME(fp), SYS_FNOWRITEPERM) + + if (FTYPE(fp) == TEXT_FILE) { + call fputtx (fd, Memc[bp], otop[fd] - bp, status) + iop[fd] = bp + itop[fd] = bp + } else { + call fflsbf (fd, bp, otop[fd]-bp, boffset[fd]) + call fwatio (fd) + if (FBLKSIZE(fp) == 0) { # streaming device? + boffset[fd] = LNOTE(fd) + iop[fd] = bp + otop[fd] = bp + itop[fd] = bp + } + status = FILSTAT(fp) + } + + if (status == ERR) + call filerr (FNAME(fp), SYS_FWRITE) + otop[fd] = bp + } + + if (FTYPE(fp) == TEXT_FILE && and (FF_WRITE, fflags[fd]) != 0) + call zcall2 (ZFLSTX(fp), FCHAN(fp), status) + + if (status == ERR) + call filerr (FNAME(fp), SYS_FWRITE) +end diff --git a/sys/fio/fmapfn.x b/sys/fio/fmapfn.x new file mode 100644 index 00000000..20fed43a --- /dev/null +++ b/sys/fio/fmapfn.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# FMAPFN -- Map the VFN of an existing file to a packed OSFN. ERR is returned +# if there is insufficient information in the VFN database to map the filename. +# OK is returned if the mapping can be performed, but a status of OK does not +# imply that the named file exists. + +procedure fmapfn (vfn, osfn, maxch) + +char vfn[ARB] # virtual filename of file to be mapped. +char osfn[maxch] # packed OS filename (output) +int maxch + +int status, ip, delim +pointer vfd, sp, nodename +pointer vfnopen() +int vfnmapu(), ki_gnode() +errchk vfnopen, vfnmapu, syserrs + +begin + call smark (sp) + call salloc (nodename, SZ_FNAME, TY_CHAR) + + # Map VFN to OSFN. + + vfd = vfnopen (vfn, READ_ONLY) + status = vfnmapu (vfd, osfn, maxch) + call vfnclose (vfd, VFN_NOUPDATE) + + if (status == ERR) + call syserrs (SYS_FNOSUCHFILE, vfn) + + # If the file resides on the local node strip the node name, returning + # a legal host system filename as the result. + + if (ki_gnode (osfn, Memc[nodename], delim) == 0) + ip = delim + 1 + else + ip = 1 + + call osfn_pkfname (osfn[ip], osfn, maxch) + call sfree (sp) +end diff --git a/sys/fio/fmkbfs.x b/sys/fio/fmkbfs.x new file mode 100644 index 00000000..12102e88 --- /dev/null +++ b/sys/fio/fmkbfs.x @@ -0,0 +1,61 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# FMKBFS -- Make file buffer. Called by FILBUF or FLSBUF when i/o is first +# done on a file, to create the file buffer. Note that the logical offset +# must be maintained when the buffer pointer is changed. + +procedure fmkbfs (fd) + +int fd +pointer bp +int dev_blksz +long offset +errchk malloc, FBUF_ALLOC +include + +begin + fp = fiodes[fd] + + # Apply constraints on the size of a file i/o buffer. + + if (FTYPE(fp) != TEXT_FILE) { + # Promote the input buffer size to the next integral number of + # device blocks. + + dev_blksz = FBLKSIZE(fp) + if (dev_blksz > 1) { + FBUFSIZE(fp) = (FBUFSIZE(fp) + dev_blksz-1) / + dev_blksz * dev_blksz + } else + FBUFSIZE(fp) = max (1, FBUFSIZE(fp)) + + # There is no maximum buffer (i/o transfer) size if the value + # returned by the kernel is zero. + + if (FMAXBUFSIZE(fp) > 0) + FBUFSIZE(fp) = min (FMAXBUFSIZE(fp), FBUFSIZE(fp)) + } + + # Note file offset, allocate buffer and initialize i/o pointers, + # restore seek offset (which depends on buffer pointer, buf offset). + + offset = LNOTE(fd) + if (FTYPE(fp) == TEXT_FILE) + call malloc (bp, FBUFSIZE(fp), TY_CHAR) + else + call FBUF_ALLOC (bp, FBUFSIZE(fp), TY_CHAR) + + boffset[fd] = NULL + bufptr[fd] = bp + buftop[fd] = bp + FBUFSIZE(fp) + itop[fd] = bp + otop[fd] = bp + + if (FTYPE(fp) == BINARY_FILE) + LSEEK (fd, offset) + else + iop[fd] = bp +end diff --git a/sys/fio/fmkcopy.x b/sys/fio/fmkcopy.x new file mode 100644 index 00000000..c49cff19 --- /dev/null +++ b/sys/fio/fmkcopy.x @@ -0,0 +1,92 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +# FMKCOPY -- Create a null length copy of an existing file. The new file +# inherits all the directory attributes of the original file. For example, +# if the oldfile is an executable file, the new one will be too. This avoids +# file copy operations which copy the file data but lose file attributes. +# Interrupts are disabled while the VFN database is open to protect the +# database, ensure that that the lock on the mapping file is cleared, and to +# ensure that the mapping file is closed. + +procedure fmkcopy (oldfile, newfile) + +char oldfile[ARB] # file to be copied +char newfile[ARB] # newfile + +char url[SZ_PATHNAME], old[SZ_PATHNAME] +int status, file_exists, junk +pointer vp, sp, oldosfn, newosfn +int vfnadd(), strncmp(), nowhite() +pointer vfnopen() +errchk delete, filerr, fmapfn, fclobber +include +define close_ 91 +define abort_ 92 + +begin + call smark (sp) + call salloc (oldosfn, SZ_PATHNAME, TY_CHAR) + call salloc (newosfn, SZ_PATHNAME, TY_CHAR) + + + # If we're given a URL to a file, cache it. + call aclrc (old, SZ_PATHNAME) + if (strncmp ("http:", oldfile, 5) == 0) + return + else if (strncmp ("file:", oldfile, 5) == 0) + return + else { + # Strip any whitespace at either end of the filename. + if (nowhite (oldfile, old, SZ_PATHNAME) == 0) + call syserr (SYS_FNOFNAME) + } + + # Get OSFN of old file and verify that the file exists. + + call fmapfn (old, Memc[oldosfn], SZ_PATHNAME) + call zfacss (Memc[oldosfn], 0, 0, file_exists) + if (file_exists == NO) + call filerr (oldfile, SYS_FOPEN) + + # Perform clobber checking, delete old file if one exists. + # Note that this must be done before opening the new VFN for + # writing or deadlock may occur. + + call fclobber (newfile) + + # Add the new VFN to the VFN database and create the new file. + + call intr_disable() + iferr (vp = vfnopen (newfile, VFN_WRITE)) + goto abort_ + iferr (junk = vfnadd (vp, Memc[newosfn], SZ_PATHNAME)) + goto close_ + + call zfmkcp (Memc[oldosfn], Memc[newosfn], status) + if (status == ERR) { + iferr (call filerr (newfile, SYS_FMKCOPY)) + goto close_ + } else + iferr (call vfnclose (vp, VFN_UPDATE)) + goto abort_ + + call intr_enable() + call sfree (sp) + return + + + # Error recovery nasties. +close_ + iferr (call vfnclose (vp, VFN_NOUPDATE)) + ; +abort_ + call intr_enable() + call sfree (sp) + call erract (EA_ERROR) +end diff --git a/sys/fio/fmkdir.x b/sys/fio/fmkdir.x new file mode 100644 index 00000000..79e1454b --- /dev/null +++ b/sys/fio/fmkdir.x @@ -0,0 +1,60 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# FMKDIR -- Create a new, empty directory. An error action is taken if the +# name of the new directory is too long, if a file already exists with the +# same name, or if there is no write permission on the directory. + +procedure fmkdir (newdir) + +char newdir[ARB] # virtual or OS-dependent directory spec + +int status +pointer sp, osfn, dirname +int access() +errchk syserrs + +begin + call smark (sp) + call salloc (osfn, SZ_PATHNAME, TY_CHAR) + call salloc (dirname, SZ_PATHNAME, TY_CHAR) + + # It is an error if the named file already exists, be it a directory + # or not. If the file does not exist but the filename cannot be + # mapped that indicates that the directory name is too long and + # FMAPFN tried to access the mapping file. Filename mapping does not + # currently map long directory names so we do not permit directories + # with long names to be created here. Filename mapping (using the + # mapping file) is intentionally not supported for reasons of + # efficiency and to discourage use of very long diectory names, which + # would tend to overflow filename buffers. + + if (access (newdir, 0, 0) == YES) + call syserrs (SYS_FMKDIR, newdir) + iferr (call fmapfn (newdir, Memc[osfn], SZ_PATHNAME)) + call syserrs (SYS_FMKDIRFNTL, newdir) + + # Always present ZFMKDR with a directory pathname (rather than an + # absolute or cwd relative filename), in case the kernel procedure + # is not smart enough to handle all these possibilities. + + call strupk (Memc[osfn], Memc[osfn], SZ_PATHNAME) + call zfpath (Memc[osfn], Memc[dirname], SZ_PATHNAME, status) + if (status != ERR) + call zfsubd (Memc[dirname], SZ_PATHNAME, "", status) + + # Try to create the new directory. If the directory cannot be created + # use the OS name of the directory in the error message to close the + # loop with the user. + + if (status != ERR) { + call strpak (Memc[dirname], Memc[osfn], SZ_PATHNAME) + call zfmkdr (Memc[osfn], status) + } + if (status == ERR) + call syserrs (SYS_FMKDIR, Memc[dirname]) + + call sfree (sp) +end diff --git a/sys/fio/fmkpbbuf.x b/sys/fio/fmkpbbuf.x new file mode 100644 index 00000000..ee891949 --- /dev/null +++ b/sys/fio/fmkpbbuf.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# FMKPBBUF -- Make the push back buffer. Called when the first attempt is +# made to push data back into an input stream. + +procedure fmkpbbuf (fd) + +int fd +int buflen +pointer bp +errchk malloc +include + +begin + fp = fiodes[fd] + if (bufptr[fd] == NULL) + call fmkbfs (fd) + + buflen = FPBBUFSIZE(fp) + if (buflen <= 0) { + buflen = SZ_PBBUF + FPBBUFSIZE(fp) = buflen + } + + call malloc (bp, buflen, TY_CHAR) + + FPBBUF(fp) = bp + FPBTOP(fp) = bp + buflen + FPBIOP(fp) = bp + FPBSP(fp) = (FPBTOP(fp) - 1) / SZ_INT + 1 +end diff --git a/sys/fio/fnextn.x b/sys/fio/fnextn.x new file mode 100644 index 00000000..47e73a08 --- /dev/null +++ b/sys/fio/fnextn.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# FNEXTN -- Extract the file name extension from a virtual file name (or a +# machine dependent file name. If the VFN contains no extension field, the +# null string is returned. The number of chars in the extension string is +# returned as the function value. + +int procedure fnextn (vfn, outstr, maxch) + +char vfn[ARB], outstr[maxch] +int maxch +int root_offset, extn_offset +int gstrcpy() + +begin + call zfnbrk (vfn, root_offset, extn_offset) + if (vfn[extn_offset] != EOS) + extn_offset = extn_offset + 1 + + return (gstrcpy (vfn[extn_offset], outstr, maxch)) +end diff --git a/sys/fio/fnldir.x b/sys/fio/fnldir.x new file mode 100644 index 00000000..2bcfbd94 --- /dev/null +++ b/sys/fio/fnldir.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# FNLDIR -- Extract the logical directory prefix from a virtual file name, +# e.g., the "ldir$" field in "ldir$root.extn", or the field "ldir$a/b/" +# in the vfn "ldir$a/b/file.xtn". Both logical and OS dependent directory +# prefixes are successfully extracted. The prefix returned is the (logical +# or explicit) file name of the directory containing the named file. If the +# VFN contains no logical directory field, the null string is returned, +# signifying the current directory. The number of chars in the directory +# prefix is returned as the function value. + +int procedure fnldir (vfn, outstr, maxch) + +char vfn[ARB], outstr[maxch] +int maxch +int root_offset, extn_offset +int gstrcpy() + +begin + call zfnbrk (vfn, root_offset, extn_offset) + return (gstrcpy (vfn[1], outstr, min (maxch, root_offset-1))) +end diff --git a/sys/fio/fnroot.x b/sys/fio/fnroot.x new file mode 100644 index 00000000..91042e87 --- /dev/null +++ b/sys/fio/fnroot.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# FNROOT -- Extract the root file name from a virtual file name (or from a +# machine dependent filename. If the VFN contains no root name, the null +# string is returned. This occurs when the VFN refers to a directory or +# device, or when the VFN string is a null string. The number of chars in +# the root file name is returned as the function value. + +int procedure fnroot (vfn, outstr, maxch) + +char vfn[ARB], outstr[maxch] +int maxch +int root_offset, extn_offset, nchars_root +int gstrcpy() + +begin + call zfnbrk (vfn, root_offset, extn_offset) + nchars_root = max(0, min(maxch, extn_offset - root_offset)) + + return (gstrcpy (vfn[root_offset], outstr, nchars_root)) +end diff --git a/sys/fio/fntgfn.x b/sys/fio/fntgfn.x new file mode 100644 index 00000000..3f2ba5de --- /dev/null +++ b/sys/fio/fntgfn.x @@ -0,0 +1,1004 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +.help fntgfn +.nf _________________________________________________________________________ +File Name Template Package + +This package contains routines to expand a file name template string into a +list of file names, and to access the individual elements of the list. The +template is a list of file names, patterns, and/or list file names. The +concatenation operator may be used within input list elements to form new +output filenames. String substitution may also be used to form new filenames. + +Sample template string: + + alpha, *.x, data* // .pix, [a-m]*, @list_file + +This template would be expanded as the file "alpha", followed in successive +calls by all the files in the current directory whose names end in ".x", +followed by all files whose names begin with "data" with the extension ".pix" +appended, and so on. The @ character signifies a list file (file containing +regular file names). + +String substitution uses the first string given for the template, expands +the template, and for each filename generated by the template, substitutes +the second string to generate a new filename. Some examples follow. + + *.%x%y% change extension to `y' + *%%_abc%.imh append `_abc' to root + nite%1%2%.1024.imh change `nite1' to `nite2' + +Main entry points: + + fntopnb - expand template and open a buffered filename list + fntgfnb - get next filename from buffered list (sequential) + fntrfnb - get next filename from buffered list (random) + fntclsb - close buffered list + fntlenb - get number of filenames in a buffered list + fntrewb - rewind the list + +Low Level Entry Points: + + fntopn - open an unbuffered filename list + fntgfn - get next filename from unbuffered list + fntcls - close unbuffered list + +The B suffix routines are the highest level and most convenient to use. +The remaining routines expand a template "on the fly" and do not permit +sorting or determination of the length of the list. +.endhelp ____________________________________________________________________ + +# FNTB descriptor structure. +define LEN_FNTBHDR 5 +define FNTB_MAGIC 5164 +define B_MAGIC Memi[$1] +define B_SBUFPTR Memi[$1+1] # string buffer pointer +define B_NSTR Memi[$1+2] # number of strings +define B_STRNUM Memi[$1+3] # used to read list +define B_STRINDX Memi[$1+$2-1+4] # index of string + +# FNTU descriptor structure. +define LEN_FNTUHDR (10+1024+256) +define FNTU_MAGIC 5664 +define U_MAGIC Memi[$1] +define U_FILDES Memi[$1+1] +define U_TEMPLATE Memi[$1+2] # pointer +define U_TEMPLATE_INDEX Memi[$1+3] +define U_PATTERN (P2C($1+10)) +define U_LDIR (P2C($1+1034)) + +# Special characters and size limiting definitions. +define TOK_DELIM ',' # token delimiter +define LIST_FILE_CHAR '@' # @listfile +define CH_EDIT '%' # string substitution metachar +define SZ_PATTERN 1023 +define SZ_LDIR 255 +define SZ_PATSTR 1023 +define MAX_EDIT 8 +define MAX_PATTERNS 8 + +# Tokens. +define EO_TEMPLATE 1 +define LIST_FILE 2 +define PATTERN_STRING 3 +define FILE_NAME 4 + +# Size limiting definitions (initial buffer sizes). +define SZ_DEFSTRBUF 2048 # default string buffer size +define LEN_INDEXVECTOR 256 # initial length of index vector + + +# FNTOPNB -- General open buffered list routine, for any type of filename list. +# Expand template into string buffer, sort if so indicated. + +int procedure fntopnb (template, sort) + +char template[ARB] # filename template +int sort # sort expanded patterns + +int nedit[MAX_PATTERNS], junk, nchars +bool is_template[MAX_PATTERNS], is_edit[MAX_PATTERNS], sortlist, is_url +pointer sp, pbuf, fname, rname, extn, ebuf, sbuf, list, ip, op, ep, pp +pointer patp[MAX_PATTERNS], flist[MAX_PATTERNS], editp[MAX_EDIT] +int nlists, npat, nstr, maxstr, nextch, sz_sbuf, ix, first_string, ch, i +int fntopn(), fntgfn(), fnt_getpat(), gstrcpy(), fnt_edit(), stridx() +int patmake(), patmatch(), strncmp() +errchk fntopn, fntgfn, syserr, malloc, realloc + +begin + call smark (sp) + call salloc (rname, SZ_FNAME, TY_CHAR) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (extn, SZ_FNAME, TY_CHAR) + call salloc (pbuf, SZ_LINE, TY_CHAR) + call salloc (ebuf, SZ_LINE, TY_CHAR) + + # Allocate list descriptor. + call malloc (list, LEN_FNTBHDR + LEN_INDEXVECTOR, TY_INT) + call malloc (sbuf, SZ_DEFSTRBUF, TY_CHAR) + + B_MAGIC(list) = FNTB_MAGIC + maxstr = LEN_INDEXVECTOR + sz_sbuf = SZ_DEFSTRBUF + nextch = 1 # offset into string buffer + nstr = 0 + + # Read the file names into the string buffer. Dynamically adjust + # the size of the string buffer and/or index vector as necessary. + # There must always be at least SZ_FNAME chars left in the string + # buffer. The outer loop is over comma delimited fields of the + # filename template. The inner loop is over individual filenames. + + ix = 1 + while (fnt_getpat (template, ix, patp, npat, pbuf, SZ_LINE) > 0) { + first_string = nstr + 1 + sortlist = (sort == YES) + nlists = 0 + ep = ebuf + + # Each piece of the current comma delimited template may consist + # of several sublists to be independently expanded and concatenated + # to form each output filename. The lists must either be degenerate + # (a simple string) or actual lists to be expanded with FNTOPN. + + do i = 1, npat { + is_template[i] = false + is_edit[i] = false + nedit[i] = 0 + op = patp[i] + + # Examine sublist to see if it is a template or a string + # constant. If template, open file list. Template + # metacharacters may be escaped to be included in filenames. + # If the pattern contains edit substitution sequences it + # must be processed to remove the substitution strings. + + is_url = false + for (ip=op; Memc[ip] != EOS; ip=ip+1) { + ch = Memc[ip] + + if (ch == ':' && strncmp (Memc[ip+1], "//", 2) == 0) { + # URL string. + is_template[i] = false + is_edit[i] = false + is_url = true + } else if (!is_url && stridx (Memc[ip], "@*?[%") > 0) { + if (ip > patp[i] && Memc[ip-1] == '\\') { + Memc[op-1] = ch + ip = ip + 1 + ch = Memc[ip] + } else if (ch == CH_EDIT) { + is_edit[i] = true + } else { + if (ch == '@' && op == ip) + sortlist = false + if (!is_url) + is_template[i] = true + } + } + + Memc[op] = ch + op = op + 1 + } + + Memc[op] = EOS + + # Open filename template if pattern contained metacharacters. + # A string constant containing edit string substitution is a + # special case, eg. "file%%_2%.ext". + + if (is_template[i] || is_edit[i]) { + editp[i] = ep + call fnt_mkpat (Memc[patp[i]], Memc[fname], SZ_FNAME, + ep, nedit[i]) + flist[i] = fntopn (Memc[fname]) + + # In the case of a string constant edit we do not really + # have a file template, but we open one anyhow just to + # make use of the common code and the descriptor. + + if (!is_template[i]) { + # Encode the pattern (containing the %%). + junk = patmake (Memc[fname], Memc[U_PATTERN(flist[i])], + SZ_PATTERN) + + # Strip the %% from the pattern, leaving the "input" + # filename in patp[i]. + + op = patp[i] + for (ip=fname; Memc[ip] != EOS; ip=ip+1) + if (Memc[ip] != CH_EDIT) { + Memc[op] = Memc[ip] + op = op + 1 + } + Memc[op] = EOS + + # Now match the stripped pattern against the %% + # pattern. This sets up U_PATTERN for the edit. + + junk = patmatch (Memc[patp[i]], + Memc[U_PATTERN(flist[i])]) + } else + nlists = nlists + 1 + } + } + + # Expand the template into a sequence of filenames in the string + # buffer, saving the indices of the list elements in the STRINDX + # array. Reallocate a larger buffer if necessary. If the sublists + # are not all the same length the shortest list will terminate the + # output list. + + repeat { + # Concatenate the next element from each sublist; the sublists + # may be either real lists or string constants. Concatenate + # only to the root filename. + + Memc[extn] = EOS + op = fname + + do i = 1, npat { + # Save first extension field encountered and set op to + # end of root. + + if (Memc[extn] == EOS) + for (ip=op-1; ip > fname; ip=ip-1) + if (Memc[ip] == '.') { + call strcpy (Memc[ip], Memc[extn], SZ_FNAME) + op = ip + break + } + + # Concatenate the next file element. This can be either a + # file name from a file template, a constant file name from + # a string edit expression, or a simple string constant. + + if (!is_url && (is_template[i] || is_edit[i])) { + ip = rname + pp = flist[i] + if (is_template[i]) { + if (fntgfn (pp, Memc[rname], SZ_FNAME) == EOF) { + op = fname + break + + } else if (U_FILDES(pp) != NULL) { + # Reading from a directory or list; set offset + # of substring to be edited to exclude any + # ldir prefix, since this will not have been + # used for the pattern match. + + nchars = gstrcpy (Memc[U_LDIR(pp)],Memc[op],ARB) + op = op + nchars + ip = ip + nchars + } + } else + call strcpy (Memc[patp[i]], Memc[rname], SZ_FNAME) + + op = op + fnt_edit (Memc[ip], Memc[op], editp[i], + nedit[i], Memc[U_PATTERN(pp)]) + + } else { + op = op + gstrcpy (Memc[patp[i]], Memc[op], ARB) + } + } + + # End of list if nothing returned. + if (op == fname) + break + + # Tack extension back on. + if (Memc[extn] != EOS) + op = op + gstrcpy (Memc[extn], Memc[op], ARB) + + # Need more room for list element pointers? + nstr = nstr + 1 + if (nstr > maxstr) { + maxstr = maxstr + LEN_INDEXVECTOR + call realloc (list, LEN_FNTBHDR + maxstr, TY_INT) + } + + # Out of space in string buffer? + if (nextch + (op - fname) >= sz_sbuf) { + sz_sbuf = sz_sbuf + SZ_DEFSTRBUF + call realloc (sbuf, sz_sbuf, TY_CHAR) + } + + # Save index of list element, move chars to string buffer. + # Allow space for the EOS after each string. + + B_STRINDX(list,nstr) = nextch + nextch = nextch + + gstrcpy (Memc[fname], Memc[sbuf+nextch-1], ARB) + 1 + + } until (nlists == 0) + + do i = 1, npat + if (is_template[i] || is_edit[i]) + call fntcls (flist[i]) + + # If sorting is desired and the pattern did not specify an explicit + # list (e.g., "@listfile"), sort the last batch of filenames. + + if (sortlist && nstr > first_string) + call strsrt (B_STRINDX(list,first_string), Memc[sbuf], + nstr - first_string + 1) + } + + # Update the string buffer descriptor, return unused buffer space. + # Rewind the list in preparation for reading (set strnum=1). + + call realloc (sbuf, nextch, TY_CHAR) + call realloc (list, LEN_FNTBHDR + nstr, TY_INT) + + B_NSTR(list) = nstr + B_STRNUM(list) = 1 + B_SBUFPTR(list) = sbuf + + call sfree (sp) + return (list) +end + + +# FNT_MKPAT -- Take a pattern string possibly containing %a%b% string +# substitution sequences, returning a pattern string as required for PATMAKE, +# and a sequence of substitution strings for later use by FNT_EDIT to edit +# filenames matched by FNTGFN. + +procedure fnt_mkpat (pat, patstr, maxch, ep, nedit) + +char pat[ARB] # pattern with embedded substitution sequences +char patstr[maxch] # receives pattern as req'd by PATMAKE +int maxch +pointer ep # where to put substitution string chars +int nedit # number of substitution chars + +int nhat +int ip, op + +begin + nedit = 0 + nhat = 0 + op = 1 + + for (ip=1; pat[ip] != EOS; ip=ip+1) { + if (pat[ip] == CH_EDIT) { + if (ip > 1 && pat[ip-1] == '\\') { + # Moved escaped metacharacter to pattern string. + patstr[op] = pat[ip] + op = op + 1 + + } else if (nhat > 0) { + # Copy substitution string to ebuf. + patstr[op] = pat[ip] + op = op + 1 + nedit = nedit + 1 + + ip = ip + 1 + while (pat[ip] != EOS && pat[ip] != CH_EDIT) { + Memc[ep] = pat[ip] + ep = ep + 1 + ip = ip + 1 + } + + Memc[ep] = EOS + ep = ep + 1 + if (pat[ip] == EOS) + ip = ip - 1 + nhat = 0 + + } else { + patstr[op] = pat[ip] + op = op + 1 + nhat = nhat + 1 + } + + } else { + patstr[op] = pat[ip] + op = op + 1 + if (op > maxch) + break + } + } + + patstr[op] = EOS +end + + +# FNT_EDIT -- Perform string substitution on a matched filename, using the +# list of substitution strings written by FNT_MKPAT, the first of which is +# pointed to by EDITP. The regions to be replaced were marked symbolically +# by the CH_EDIT characters in the user supplied pattern. The actual indices +# of these regions depend upon the actual filename and are saved by the +# pattern matching code in the encoded pattern buffer PATBUF, for retrieval +# by PATINDEX. Carry out the substitution and return the length of the +# output string as the function argument. + +int procedure fnt_edit (in, out, editp, nedit, patbuf) + +char in[ARB] # input string to be edited +char out[ARB] # receives edited string +pointer editp # pointer to first substitution string +int nedit # number of edits required +char patbuf[ARB] # encoded pattern + +pointer ep +int ip1, ip2, ip, op, i +int patindex() + +begin + ep = editp - 1 + ip = 1 + op = 1 + + do i = 1, nedit { + # Get indices of first and last+1 characters to be substituted for + # in the input string. + + ip1 = patindex (patbuf, (i-1) * 2 + 1) + ip2 = patindex (patbuf, (i-1) * 2 + 2) + if (ip1 == 0 || ip2 == 0 || ip1 > ip2) + break # cannot happen + + # Copy up to first char to be replaced. + for (; ip < ip1; ip=ip+1) { + out[op] = in[ip] + op = op + 1 + } + + # Append substitution string. + for (ep=ep+1; Memc[ep] != EOS; ep=ep+1) { + out[op] = Memc[ep] + op = op + 1 + } + + # Continue at character IP2 in the input string. + ip = ip2 + } + + # Copy remainder of input string to the output string. + for (; in[ip] != EOS; ip=ip+1) { + out[op] = in[ip] + op = op + 1 + } + + out[op] = EOS + return (op - 1) +end + + +# FNTGFNB -- Return the next filename from the list. + +int procedure fntgfnb (list, fname, maxch) + +pointer list # list descriptor pointer +char fname[ARB] # output filename +int maxch + +pointer strptr +int file_number +int gstrcpy() +errchk syserr + +begin + if (B_MAGIC(list) != FNTB_MAGIC) + call syserr (SYS_FNTMAGIC) + + file_number = B_STRNUM(list) + if (file_number > B_NSTR(list)) + return (EOF) + else { + B_STRNUM(list) = file_number + 1 + strptr = B_SBUFPTR(list) + B_STRINDX(list,file_number) - 1 + return (gstrcpy (Memc[strptr], fname, maxch)) + } +end + + +# FNTRFNB -- Return the indexed filename from the list. For applications +# which need to access the list at random. Returns len(fname) or EOF for +# references to nonexistent list elements. + +int procedure fntrfnb (list, index, fname, maxch) + +pointer list # list descriptor pointer +int index # index of list element to be returned +char fname[ARB] # output filename +int maxch + +pointer strptr +int gstrcpy() +errchk syserr + +begin + if (B_MAGIC(list) != FNTB_MAGIC) + call syserr (SYS_FNTMAGIC) + + if (index < 1 || index > B_NSTR(list)) + return (EOF) + else { + strptr = B_SBUFPTR(list) + B_STRINDX(list,index) - 1 + return (gstrcpy (Memc[strptr], fname, maxch)) + } +end + + +# FNTCLSB -- Close a buffered list and return all storage. + +procedure fntclsb (list) + +pointer list # list descriptor pointer +errchk syserr + +begin + if (B_MAGIC(list) != FNTB_MAGIC) + call syserr (SYS_FNTMAGIC) + + call mfree (B_SBUFPTR(list), TY_CHAR) + call mfree (list, TY_INT) +end + + +# FNTREWB -- Rewind a buffered filename list. + +procedure fntrewb (list) + +pointer list # list descriptor pointer +errchk syserr + +begin + if (B_MAGIC(list) != FNTB_MAGIC) + call syserr (SYS_FNTMAGIC) + + B_STRNUM(list) = 1 +end + + +# FNTLENB -- Return the number of filenames in the list. + +int procedure fntlenb (list) + +pointer list # list descriptor pointer +errchk syserr + +begin + if (B_MAGIC(list) != FNTB_MAGIC) + call syserr (SYS_FNTMAGIC) + + return (B_NSTR(list)) +end + + +# FNT_GETPAT -- Return the next comma delimited field from the template string +# with any leading or trailing whitespace stripped off. The field may consist +# of a simple string constant, a filename template, or a sequence of either +# delimited by concatenation operators //. We do not make any distinction here +# between string constants and patterns; return the \ with all escape sequences +# as this will be stripped by the higher level code if used to include pattern +# matching metacharacters in filenames. + +int procedure fnt_getpat (template, ix, patp, npat, sbuf, maxch) + +char template[ARB] # template from which to extract field +int ix # next char in template +pointer patp[MAX_PATTERNS] # receives pointers to sublists (patterns) +int npat # receives number of PATP elements set +pointer sbuf # used to store output strings +int maxch # maxch chars out + +int ch, peek +bool is_url +pointer op + +int strncmp(), stridx() +errchk syserr + +begin + while (IS_WHITE(template[ix]) || template[ix] == ',') + ix = ix + 1 + + patp[1] = sbuf + npat = 1 + op = sbuf + is_url = false + + #for (ch=template[ix]; ch != EOS && ch != ','; ch=template[ix]) { + for (ch=template[ix]; ch != EOS; ch=template[ix]) { + peek = template[ix+1] + if (IS_WHITE (ch)) { + # Ignore all whitespace. + ix = ix + 1 + next + + } else if ((is_url && ch == ',')) { + if (stridx (peek, "+-.0123456789") == 0) { + break + } else { + # Keep a comma in a URL followed by a digit + Memc[op] = ',' + op = op + 1 + ix = ix + 1 + } + + } else if (!is_url && ch == ',') { + break + + } else if (ch == '\\' && template[ix+1] == ',') { + # Escape a comma. + Memc[op] = ',' + op = op + 1 + ix = ix + 2 + + } else if (!is_url && (ch == '/' && template[ix+1] == '/')) { + # Concatenation operator: start a new sublist. + Memc[op] = EOS + op = op + 1 + ix = ix + 2 + npat = npat + 1 + if (npat > MAX_PATTERNS) + call syserr (SYS_FNTMAXPAT) + patp[npat] = op + + } else if (ch == ':' && strncmp ("//", template[ix+1], 2) == 0) { + # Start of URL string, deposit in output list. + Memc[op] = ch + op = op + 1 + ix = ix + 1 + is_url = true + + } else { + # Ordinary character, deposit in output list. + Memc[op] = ch + op = op + 1 + ix = ix + 1 + } + + if (op - sbuf > maxch) + break + } + + Memc[op] = EOS + return (op - sbuf) +end + + +# FNTGFN -- Get the next file name from the named parameter (template). +# This is the guy that does all the work. A file name may be selected from +# a directory file or list file by pattern matching, or may come from the +# template list string itself. + +int procedure fntgfn (pp, outstr, maxch) + +pointer pp # pattern pointer +char outstr[ARB] # output filename +int maxch + +bool match +pointer ip, sp, linebuf, fname, patstr +int nchars, token, first_ch, last_ch, status + +bool streq() +int getline(), gpatmatch(), patmake(), nowhite(), gstrcat() +int fnt_read_template(), fnt_open_list() +errchk salloc, getline, close, fnt_open_list, syserr + +begin + if (pp == NULL || U_MAGIC(pp) != FNTU_MAGIC) + call syserr (SYS_FNTMAGIC) + + call smark (sp) # get buffers + call salloc (linebuf, SZ_LINE, TY_CHAR) + call salloc (patstr, SZ_PATSTR, TY_CHAR) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + repeat { + # Read file names from either list file or directory file, until + # one is found which matches pattern, or until EOF is reached. + # Make sure pattern matches the ENTIRE file name string, rather + # than a substring. + + if (U_FILDES(pp) != NULL) { # reading from a file? + while (getline (U_FILDES(pp), Memc[linebuf]) != EOF) { + for (ip=linebuf; IS_WHITE (Memc[ip]); ip=ip+1) + ; + nchars = nowhite (Memc[ip], Memc[fname], maxch) + if (nchars == 0) # skip blank lines + next + + # If the encoded pattern is the null string match anything. + if (Memc[U_PATTERN(pp)] == EOS) { + match = true + } else if (gpatmatch (Memc[fname], Memc[U_PATTERN(pp)], + first_ch, last_ch) > 0) { + match = (first_ch == 1 && last_ch == nchars) + } else + match = false + + if (match) { + call strcpy (Memc[U_LDIR(pp)], outstr, maxch) + nchars = gstrcat (Memc[fname], outstr, maxch) + call sfree (sp) + return (nchars) + } + } + + call close (U_FILDES(pp)) + U_FILDES(pp) = NULL + } + + switch (fnt_read_template (pp, Memc[linebuf], SZ_LINE, token)) { + case EO_TEMPLATE: + nchars = EOF + outstr[1] = EOS + call sfree (sp) + return (nchars) + + case LIST_FILE, PATTERN_STRING: + # Break the pattern string into a list file or directory + # name and a pattern. + + if (token == PATTERN_STRING) { + Memc[patstr] = '^' + ip = patstr + 1 + } else + ip = patstr + + U_FILDES(pp) = fnt_open_list (Memc[linebuf], Memc[ip], + SZ_PATSTR-1, Memc[fname], Memc[U_LDIR(pp)], token) + + # Encode the pattern. If the pattern is matchall set encoded + # pattern string to NULL and pattern matching will be skipped. + + if (streq (Memc[patstr], "?*")) + Memc[U_PATTERN(pp)] = EOS + else { + status = patmake (Memc[patstr], Memc[U_PATTERN(pp)], + SZ_PATTERN) + if (status == ERR) + call syserr (SYS_FNTBADPAT) + } + + default: # simple file name + nchars = nowhite (Memc[linebuf], outstr, maxch) + if (nchars > 0) { + call sfree (sp) + return (nchars) + } + } + } +end + + +# FNT_READ_TEMPLATE -- Get next token from template string, return integer +# code identifying the type of token. + +int procedure fnt_read_template (pp, outstr, maxch, token) + +pointer pp #I pointer to param descriptor +char outstr[maxch] #O receives token +int maxch #I max chars out +int token #O token type code + +int nseen, i +pointer ip, ip_start, op, cp +int stridx(), strncmp() + +begin + ip = U_TEMPLATE_INDEX(pp) # retrieve pointer + while (IS_WHITE (Memc[ip])) + ip = ip + 1 + + + switch (Memc[ip]) { + case EOS: + op = 1 + token = EO_TEMPLATE + + case LIST_FILE_CHAR: # list file spec + ip = ip + 1 # skip the @ + for (op=1; Memc[ip] != TOK_DELIM && Memc[ip] != EOS; op=op+1) { + outstr[op] = Memc[ip] + ip = ip + 1 + } + token = LIST_FILE + if (Memc[ip] == TOK_DELIM) + ip = ip + 1 + + default: # fname or pat string + token = FILE_NAME + # Extract token. Determine if regular file name or pattern string. + # Disable metacharacters not useful for file name patterns. + + ip_start = ip + for (op=1; Memc[ip] != EOS; ip=ip+1) { + if (Memc[ip] == CH_ESCAPE && Memc[ip+1] != EOS) { + # Escape sequence. Pass both the escape and the escaped + # character on to the lower level code. + + outstr[op] = CH_ESCAPE + op = op + 1 + ip = ip + 1 + + } else if (Memc[ip] == TOK_DELIM) { + ip = ip + 1 + break + + } else if (Memc[ip] == FNLDIR_CHAR || Memc[ip] == '/') { + token = FILE_NAME + + } else if (Memc[ip] == '*') { + # Map "*" into "?*". + token = PATTERN_STRING + outstr[op] = '?' + op = op + 1 + + } else if (Memc[ip] == '%') { + # The % metacharacter must appear twice (not three times, + # as the high level code strips the subsitution field) to + # be recognized as the pattern substitution metacharacter. + + nseen = 0 + do i = 1, ARB { + cp = ip_start + i - 1 + if (Memc[cp] == EOS || Memc[cp] == TOK_DELIM) + break + else if (Memc[cp] == '%' && Memc[cp-1] != '\\') + nseen = nseen + 1 + } + if (nseen < 2) { + outstr[op] = CH_ESCAPE + op = op + 1 + } + } else if (stridx (Memc[ip], "[?{") > 0) + token = PATTERN_STRING + + outstr[op] = Memc[ip] + op = op + 1 + } + } + + # Remove any trailing whitespace. + op = op - 1 + while (op > 0 && IS_WHITE (outstr[op])) + op = op - 1 + outstr[op+1] = EOS + + if (op > 0) + if (outstr[op] == FNLDIR_CHAR || outstr[op] == '/') + token = PATTERN_STRING + + U_TEMPLATE_INDEX(pp) = ip # update pointer + + return (token) +end + + +# FNT_OPEN_LIST -- Open list file or directory. If reading from a directory, +# open the current directory if a directory name is not given. Extract +# pattern string (if any), and return in PATSTR. If no pattern string is +# given, return a pattern which will match all files in the list. + +int procedure fnt_open_list (str, patstr, maxch, fname, ldir, ftype) + +int maxch, ftype +char ldir[SZ_LDIR] +char str[ARB], patstr[maxch], fname[SZ_FNAME] +int fd, ip, op, fnt_delim, pat_start, dirmode +int open(), diropen() +errchk open, diropen, fpathname + +begin + op = 1 + fnt_delim = NULL + pat_start = NULL + + # Search for a valid directory prefix. + for (ip=1; str[ip] != EOS; ip=ip+1) { + fname[op] = str[ip] + if (ftype != LIST_FILE) + if (fname[op] == FNLDIR_CHAR || fname[op] == '//') + if (op == 1 || fname[op-1] != '\\') { + fnt_delim = op + pat_start = ip + 1 + } + op = op + 1 + } + fname[op] = EOS + + if (ftype == LIST_FILE) { + if (fnt_delim != NULL) + fname[fnt_delim] = EOS + fd = open (fname, READ_ONLY, TEXT_FILE) + ldir[1] = EOS + + } else { + if (fnt_delim != NULL) # specific directory + fname[fnt_delim+1] = EOS + else # current directory + fname[1] = EOS + call fpathname (fname, ldir, SZ_LDIR) + + dirmode = SKIP_HIDDEN_FILES + if (pat_start != NULL) { + if (str[pat_start] == '.') + dirmode = PASS_HIDDEN_FILES + } else if (ftype != LIST_FILE && str[1] == '.') + dirmode = PASS_HIDDEN_FILES + + fd = diropen (ldir, dirmode) + call strcpy (fname, ldir, SZ_LDIR) + } + + # If pattern string is appended to list file name, extract + # it, otherwise set the default pattern "match all" (*). + + op = 1 + if (pat_start != NULL) + ip = pat_start + else if (ftype != LIST_FILE) + ip = 1 + + for (; str[ip] != EOS; ip=ip+1) { + patstr[op] = str[ip] + op = op + 1 + } + + # No pattern string given, default to "?*". + if (op == 1) { + patstr[1] = CH_ANY + patstr[2] = CH_CLOSURE + op = 3 + } + patstr[op] = EOS + + return (fd) +end + + +# FNTOPN -- Open and initialize the template descriptor. + +pointer procedure fntopn (template) + +char template[ARB] + +pointer pp +int nchars +int strlen() +errchk calloc, malloc + +begin + nchars = strlen (template) + + call calloc (pp, LEN_FNTUHDR, TY_STRUCT) + call malloc (U_TEMPLATE(pp), nchars, TY_CHAR) + + call strcpy (template, Memc[U_TEMPLATE(pp)], nchars) + U_TEMPLATE_INDEX(pp) = U_TEMPLATE(pp) + U_MAGIC(pp) = FNTU_MAGIC + + return (pp) +end + + +# FNTCLS -- Close the template descriptor, return space. + +procedure fntcls (pp) + +pointer pp +errchk syserr + +begin + if (pp == NULL || U_MAGIC(pp) != FNTU_MAGIC) + call syserr (SYS_FNTMAGIC) + + if (U_FILDES(pp) != NULL) + call close (U_FILDES(pp)) + + call mfree (U_TEMPLATE(pp), TY_CHAR) + call mfree (pp, TY_STRUCT) +end diff --git a/sys/fio/fnullfile.x b/sys/fio/fnullfile.x new file mode 100644 index 00000000..4080a03b --- /dev/null +++ b/sys/fio/fnullfile.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# FNULLFILE -- Determine if the named file is the null file. + +bool procedure fnullfile (fname) + +char fname[ARB] # null file candidate + +pointer sp, osfn +bool first_time, bval +char nullpath[SZ_FNAME] +int strmatch() +bool streq() + +data first_time /true/ +string nullfile "dev$null" + +begin + # Some simple, fast tests first. + if (streq (fname, nullfile)) + return (true) + else if (strmatch (fname, "{null}") == 0) + return (false) + + call smark (sp) + call salloc (osfn, SZ_PATHNAME, TY_CHAR) + + if (first_time) { + call fpathname (nullfile, nullpath, SZ_FNAME) + first_time = false + } + + call fpathname (fname, Memc[osfn], SZ_PATHNAME) + bval = streq (Memc[osfn], nullpath) + + call sfree (sp) + return (bval) +end diff --git a/sys/fio/fopnbf.x b/sys/fio/fopnbf.x new file mode 100644 index 00000000..277c9565 --- /dev/null +++ b/sys/fio/fopnbf.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# FOPNBF -- Open a binary file on a device. A new entry is made in the +# device table if the device has not already been installed. + +int procedure fopnbf (fname, mode, zopn, zard, zawr, zawa, zstt, zcls) + +char fname[ARB] +int mode +extern zopn(), zard(), zawr(), zawa(), zstt(), zcls() +int filopn() + +begin + call fdevbf (zard, zawr, zawa, zstt, zcls) + return (filopn (fname, mode, BINARY_FILE, zopn, zard)) +end diff --git a/sys/fio/fopntx.x b/sys/fio/fopntx.x new file mode 100644 index 00000000..4b120ca7 --- /dev/null +++ b/sys/fio/fopntx.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# FOPNTX -- Open a text file on a device. A new entry is made in the +# device table if the device has not already been installed. + +int procedure fopntx (fname,mode,zopn,zget,zput,zfls,zstt,zcls,zsek,znot) + +char fname[ARB] +int mode +extern zopn(), zget(), zput(), zfls(), zstt(), zcls(), zsek(), znot() +int filopn() + +begin + call fdevtx (zget, zput, zfls, zstt, zcls, zsek, znot) + return (filopn (fname, mode, TEXT_FILE, zopn, zget)) +end diff --git a/sys/fio/fowner.x b/sys/fio/fowner.x new file mode 100644 index 00000000..40cc7fc1 --- /dev/null +++ b/sys/fio/fowner.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# FOWNER -- Get the name of the owner of a file. + +procedure fowner (fname, owner, maxch) + +char fname[ARB] # file name +char owner[ARB] # owner name string +int maxch # max chars in owner name string +long file_info[LEN_FINFO] +int finfo() + +begin + if (finfo (fname, file_info) == ERR) + call filerr (fname, SYS_FOWNER) + call strcpy (FI_OWNER(file_info), owner, maxch) +end diff --git a/sys/fio/fpathname.x b/sys/fio/fpathname.x new file mode 100644 index 00000000..12c29e1f --- /dev/null +++ b/sys/fio/fpathname.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# FPATHNAME -- Return the full OS pathname for a vfn. If no vfn is given +# (null string), the pathname of the current directory is returned. Do not +# try to make the pathname into a directory name; if it already is a directory +# name, however, it will remain so. + +procedure fpathname (vfn, output_pathname, maxchars) + +char vfn[ARB] # VFN of file +char output_pathname[maxchars] # pathname of file +int maxchars + +int status +include +errchk filerr + +begin + status = OK + + if (vfn[1] == EOS) + call strpak (vfn, pathname, SZ_PATHNAME) + else iferr (call fmapfn (vfn, pathname, SZ_PATHNAME)) + status = ERR + + if (status != ERR) { + call strupk (pathname, pathname, SZ_PATHNAME) + call zfpath (pathname, output_pathname, maxchars, status) + } + + if (status == ERR) + call filerr (vfn, SYS_FPATHNAME) +end diff --git a/sys/fio/fputtx.x b/sys/fio/fputtx.x new file mode 100644 index 00000000..0cea6f04 --- /dev/null +++ b/sys/fio/fputtx.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# FPUTTX -- Put a line to a text file. Flush output if flag is set. +# Called by FLSBUF, SEEK, FLUSH, etc. to flush an output line. + +procedure fputtx (fd, buf, nchars, status) + +int fd, nchars, status +char buf[ARB] +int and() +include + +begin + fp = fiodes[fd] + call zcall4 (ZPUTTX(fp), FCHAN(fp), buf, nchars, status) + + if (status != ERR && and (FF_FLUSHNL, fflags[fd]) != 0) + call zcall2 (ZFLSTX(fp), FCHAN(fp), status) +end diff --git a/sys/fio/freadp.x b/sys/fio/freadp.x new file mode 100644 index 00000000..facd74ec --- /dev/null +++ b/sys/fio/freadp.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# FREADP -- Read from a file, directly accessing the file data in the FIO +# buffer rather than copying the data from the FIO buffer to the user buffer. +# This technique can be used for very efficient file access, but is not as +# general as an ordinary read. In particular the requested data segment +# must lie entirely within the FIO buffer, and the referenced data must be +# used before a file fault causes the buffer contents to be replaced. The +# file size should be known in advance and any attempt to read outside the +# file boundaries is interpreted as an error. + +pointer procedure freadp (fd, offset, nchars) + +int fd # file to be accessed +long offset # file offset in chars +int nchars # nchars to "read" + +pointer bp, fiop +int ffault() +errchk filerr, ffault, fmkbfs +include + +begin + # Move file buffer onto file block containing the file offset. + # Verify that the buffer contains nchars of file data in contiguous + # storage. If the file buffer already contains the referenced + # data segment no fault is necessary and this is quite fast. + # The iop is left pointing to the first char following the + # referenced data block. + + repeat { + bp = bufptr[fd] + fiop = offset - boffset[fd] + bp # lseek + + if (fiop < bp || fiop >= itop[fd]) { + if (bp == NULL) { + call fmkbfs (fd) + next + } + if (ffault (fd, offset, nchars, FF_READ) == EOF) + call filerr (FNAME(fiodes[fd]), SYS_FREADP) + fiop = iop[fd] + } + + iop[fd] = fiop + nchars + if (iop[fd] > itop[fd]) + call filerr (FNAME(fiodes[fd]), SYS_FREADP) + + return (fiop) + } +end diff --git a/sys/fio/fredir.x b/sys/fio/fredir.x new file mode 100644 index 00000000..4b8f14b2 --- /dev/null +++ b/sys/fio/fredir.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# FREDIR -- Redirect the i/o to stream FD onto file FNAME. FD must be the file +# descriptor of an open file which has not already been redirected. The mode +# of access and file type of the redirection file need not agree with those of +# the stream being redirected. +# +# The "redir_fd" file parameter has the following meaning: +# redir_fd[fd] < 0 i/o redirected in the parent process +# redir_fd[fd] == 0 i/o is not redirected +# redir_fd[fd] > 0 i/o has been redirected in the local process +# to file FD redir_fd[fd] + +procedure fredir (fd, fname, mode, type) + +int fd # stream to be redirected +char fname[ARB] # name of redirection file +int mode # access mode of redirection file +int type # file type of redirection file + +int newfd, junk +int open(), itoc() +include +errchk open, syserrs + +begin + # Cancel any pushback on the open file. + call fcanpb (fd) + + # Verify that file FD is open and has not already been redirected. + + junk = itoc (fd, pathname, SZ_PATHNAME) + if (fiodes[fd] == NULL) + call syserrs (SYS_FREDIRFNO, pathname) + else if (redir_fd[fd] != NULL) + call syserrs (SYS_FMULTREDIR, pathname) + + # Open the redirection file and swap file descriptors. CLOSE will + # automatically swap back and close the redirection file. + + newfd = open (fname, mode, type) + call frediro (fd, newfd) +end + + +# FREDIRO -- Redirect a stream to another stream which has already been +# opened. + +procedure frediro (fd, newfd) + +int fd # stream to be redirected +int newfd # where it is to be redirected +include + +begin + call fswapfd (fd, newfd) + redir_fd[fd] = newfd +end diff --git a/sys/fio/frename.x b/sys/fio/frename.x new file mode 100644 index 00000000..b02fbe56 --- /dev/null +++ b/sys/fio/frename.x @@ -0,0 +1,122 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +# FRENAME -- Change the name of a file, or move a file from one directory +# to another. All file attributes, including file protection, are +# transferred with the file. If a file already exists with the new name, +# protection and clobber checking are performed and the old file is deleted +# if permitted. Interrupts are disabled while the VFN database is open to +# protect the database, ensure that that the lock on the mapping file is +# cleared, and to ensure that the mapping file is closed. + +procedure frename (oldfname, newfname) + +char oldfname[ARB] # old filename +char newfname[ARB] # new filename + +int file_exists +int status, junk +pointer sp, vp, oldosfn, newosfn, errmsg + +pointer vfnopen() +bool fnullfile() +int vfnadd(), vfndel() +include +errchk syserrs + +define fixvfn_ 91 +define close_ 92 +define abort_ 93 + +begin + # The null file "dev$null" is a special case; ignore attempts to + # rename this file. + + if (fnullfile (oldfname)) + call syserrs (SYS_FRENAME, oldfname) + else if (fnullfile (newfname)) + call syserrs (SYS_FRENAME, newfname) + + call smark (sp) + call salloc (oldosfn, SZ_PATHNAME, TY_CHAR) + call salloc (newosfn, SZ_PATHNAME, TY_CHAR) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + # Format the string "oldfname -> newfname" for error messages. + call strcpy (oldfname, Memc[errmsg], SZ_LINE) + call strcat (" --> ", Memc[errmsg], SZ_LINE) + call strcat (newfname, Memc[errmsg], SZ_LINE) + + # Get OSFN of old file and verify that the file exists. Delete + # the old file from the database. + + call intr_disable() + iferr (vp = vfnopen (oldfname, VFN_WRITE)) + goto abort_ + iferr (status = vfndel (vp, Memc[oldosfn], SZ_PATHNAME)) + goto close_ + if (status == ERR) + file_exists = NO + else + call zfacss (Memc[oldosfn], 0, 0, file_exists) + + if (file_exists == NO) { + iferr (call syserrs (SYS_FRENAME, Memc[errmsg])) + goto close_ + } else iferr (call vfnclose (vp, VFN_UPDATE)) + goto abort_ + + # Perform clobber checking, delete old newfile if one exists. + # Note that this must be done before opening the new VFN for + # writing or deadlock may occur. + + iferr (call fclobber (newfname)) + goto fixvfn_ + + # Add the new VFN to the VFN database and create the new file. + # If the vfnadd or the physical rename operation fail then we + # must go back and undelete the old VFN. + + iferr (vp = vfnopen (newfname, VFN_WRITE)) + goto abort_ + iferr (status = vfnadd (vp, Memc[newosfn], SZ_PATHNAME)) + goto close_ + if (status != ERR) + call zfrnam (Memc[oldosfn], Memc[newosfn], status) + + if (status == ERR) { + # Close new VFN, reopen old one and undelete old VFN. + iferr (call vfnclose (vp, VFN_NOUPDATE)) + goto abort_ +fixvfn_ + iferr (vp = vfnopen (oldfname, VFN_WRITE)) + goto abort_ + iferr (junk = vfnadd (vp, Memc[oldosfn], SZ_PATHNAME)) + goto close_ + iferr (call vfnclose (vp, VFN_UPDATE)) + goto abort_ + iferr (call syserrs (SYS_FRENAME, Memc[errmsg])) + goto abort_ + } else + iferr (call vfnclose (vp, VFN_UPDATE)) + goto abort_ + + call intr_enable() + call sfree (sp) + return + + + # Error recovery nasties. +close_ + iferr (call vfnclose (vp, VFN_NOUPDATE)) + ; +abort_ + call intr_enable() + call sfree (sp) + call erract (EA_ERROR) +end diff --git a/sys/fio/frmbfs.x b/sys/fio/frmbfs.x new file mode 100644 index 00000000..ec1df5e7 --- /dev/null +++ b/sys/fio/frmbfs.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# FRMBFS -- Return file buffer. Called by FSET to change the buffer size, +# and by FRTNFD when a file is closed. + +procedure frmbfs (fd) + +int fd # file descriptor + +long offset +errchk mfree, flush +include + +begin + fp = fiodes[fd] + if (bufptr[fd] == NULL) + return + else + call fcanpb (fd) + + # Note file offset, return buffer and initialize i/o pointers, + # restore seek offset (which depends on buffer pointer, buf offset). + + offset = LNOTE(fd) + call mfree (bufptr[fd], TY_CHAR) + call mfree (FPBBUF(fp), TY_CHAR) + + bufptr[fd] = NULL + boffset[fd] = NULL + buftop[fd] = NULL + itop[fd] = NULL + otop[fd] = NULL + + LSEEK (fd, offset) +end diff --git a/sys/fio/frmdir.x b/sys/fio/frmdir.x new file mode 100644 index 00000000..d12ad082 --- /dev/null +++ b/sys/fio/frmdir.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# FRMDIR -- Remove an empty directory. An error action is taken if the +# name of the directory is too long, if directory exists but is not +# empty, or if there is no write permission on the directory. + +procedure frmdir (dir) + +char dir[ARB] # virtual or OS-dependent directory spec + +int status +pointer sp, osfn, dirname +int access() +errchk syserrs + +begin + call smark (sp) + call salloc (osfn, SZ_PATHNAME, TY_CHAR) + call salloc (dirname, SZ_PATHNAME, TY_CHAR) + + iferr (call fmapfn (dir, Memc[osfn], SZ_PATHNAME)) + call syserrs (SYS_FMKDIRFNTL, dir) + + # Always present ZFRMDR with a directory pathname (rather than an + # absolute or cwd relative filename), in case the kernel procedure + # is not smart enough to handle all these possibilities. + + call strupk (Memc[osfn], Memc[osfn], SZ_PATHNAME) + call zfpath (Memc[osfn], Memc[dirname], SZ_PATHNAME, status) + if (status != ERR) + call zfsubd (Memc[dirname], SZ_PATHNAME, "", status) + + # Try to remove the directory. If the directory cannot be removed + # use the OS name of the directory in the error message to close the + # loop with the user. + + if (status != ERR) { + call strpak (Memc[dirname], Memc[osfn], SZ_PATHNAME) + call zfrmdr (Memc[osfn], status) + } + if (status == ERR) + call syserrs (SYS_FRMDIR, Memc[dirname]) + + call sfree (sp) +end diff --git a/sys/fio/frtnfd.x b/sys/fio/frtnfd.x new file mode 100644 index 00000000..cf98aa55 --- /dev/null +++ b/sys/fio/frtnfd.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# FRTNFD -- Return file descriptor and buffers. + +procedure frtnfd (fd) + +int fd +include + +begin + if (fiodes[fd] != NULL) { + call frmbfs (fd) + call mfree (fiodes[fd], TY_STRUCT) + fiodes[fd] = NULL + } +end diff --git a/sys/fio/fseti.x b/sys/fio/fseti.x new file mode 100644 index 00000000..42068096 --- /dev/null +++ b/sys/fio/fseti.x @@ -0,0 +1,403 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include + +# FSETI -- Set File I/O options. FSETI is not intended to be called +# routinely by user code. To provide maximum flexibility, any FIO parameter +# can be changed, and no checking is performed. Hence, the file buffer size, +# device, device channel, and so on can be changed during i/o to a file, +# though doing so is probably an error. User beware. +# +# The only FIO parameters that should be set in applications programs are +# F_FLUSHNL (flush output at end of every line of text), and occasionally +# F_ADVICE (sequential or random). + +procedure fseti (fd, param, value) + +int fd # file in question +int param # parameter to be set +int value # value of parameter + +pointer bp, ffp +long file_offset +int i, junk, outfd, flags +bool blocked_file, setraw, ndelay +char set_redraw[LEN_SETREDRAW] +char rawcmd[LEN_RAWCMD+1] + +int await(), xisatty() +include + +begin + ffp = fiodes[fd] + if (fd <= 0 || ffp == NULL) + iferr (call syserr (SYS_FILENOTOPEN)) + call erract (EA_FATAL) + + switch (param) { + + case F_ADVICE: + # Set file buffer size, based on expected type of i/o. By default, + # the device dependent OPTBUFSIZE is used. If i/o is expected to + # be very random, an integral multiple of the device block size is + # used (beware of 1 char block files). If highly sequential i/o is + # expected, a large buffer is allocated. + + if (fd >= FIRST_FD && bufptr[fd] == NULL) + switch (value) { + case RANDOM: + FBUFSIZE(ffp) = LEN_RANDBUF * max (1, FBLKSIZE(ffp)) + case SEQUENTIAL: + FBUFSIZE(ffp) = LEN_SEQBUF * FOPTBUFSIZE(ffp) + default: + FBUFSIZE(ffp) = FOPTBUFSIZE(ffp) + } + + case F_ASYNC: + # Enable asynchronous i/o. + ; # not implemented + + case F_BLKSIZE: + # Set the device block size in chars. + FBLKSIZE(ffp) = value + + case F_BUFPTR, F_BUFSIZE: + # An externally created buffer can be installed by setting F_BUFPTR + # and either F_BUFSIZE or F_BUFTOP (do NOT forget to set both). + # The file buffer size can be changed by a call to F_BUFSIZE, + # even after doing i/o on a file. In both cases, the current file + # offset will be retained. + + if (param == F_BUFSIZE && FBUFSIZE(ffp) == value) + return + else if (bufptr[fd] != NULL) { + call flush (fd) + call frmbfs (fd) + } + + if (param == F_BUFSIZE) { + FBUFSIZE(ffp) = value + if (buftop[fd] == NULL && bufptr[fd] != NULL) + buftop[fd] = bufptr[fd] + value + } else { + file_offset = LNOTE (fd) + bufptr[fd] = value + boffset[fd] = NULL + LSEEK (fd, file_offset) + if (buftop[fd] == NULL && FBUFSIZE(ffp) != NULL) + buftop[fd] = bufptr[fd] + FBUFSIZE(ffp) + } + + case F_BUFTOP: + # Set a pointer to the top of a buffer (first char after buffer). + buftop[fd] = value + if (FBUFSIZE(ffp) == NULL && bufptr[fd] != NULL) + FBUFSIZE(ffp) = buftop[fd] - bufptr[fd] + + case F_FILESIZE: + # Set the file size. Should not be called by ordinary programs; + # intended for use only in system code which writes to a file at + # the kernel level, preventing FIO from keeping track of the file + # size. + + FILSIZE(ffp) = value + + case F_FIRSTBUFOFF: + # FIO divides a random access binary file up into a series of + # fixed size buffers, or file "pages". By default the first buffer + # is at file offset BOF=1, but this does not have to be the case, + # and sometimes it is desirable to align the file buffers starting + # at some format specific offset in the file. Note that doing so + # renders the file segment to the left of FIRSTBUFOFF inaccessible. + + call flush (fd) + call frmbfs (fd) + FIRSTBUFOFF(ffp) = value + + case F_BUFTYPE: + # Use file-local buffers or the global pool. + ; # not implemented + + case F_CANCEL: + # Cancel any buffered data. For a blocked file, the file offset + # is preserved, hence the only effect is to force the file buffer + # to be refilled. Any changes made to buffered data are cancelled + # when the buffer is refilled. For a streaming file, the i/o + # pointers are reset to the beginning of the buffer, to force the + # next read to refill the buffer, or to cause the next write to + # start filling the buffer. + + call fcanpb (fd) + blocked_file = (FBLKSIZE(ffp) > 0) + if (blocked_file) + file_offset = LNOTE(fd) + + bp = bufptr[fd] + if (FFIOMODE(ffp) != INACTIVE) + junk = await (fd) + + iop[fd] = bp + itop[fd] = bp + otop[fd] = bp + + if (blocked_file) { + boffset[fd] = 0 # invalidate buffer + LSEEK (fd, file_offset) + } else + boffset[fd] = 1 # causes rewind to set iop=bp + + FILSTAT(ffp) = value + + case F_CHANNEL: + # Kernel i/o channel number. + FCHAN(ffp) = value + + case F_CLOBBER: + # Allow NEW_FILE files to overwrite old files of the same name. + call fset_env ("clobber", value) + + case F_CLOSEFD: + # If this option is set for a file descriptor, the host channel + # is reopened every time an i/o operation takes place (aread or + # awrite), and is closed while the channel is inactive. This + # is useful to save host system file descriptors, so that a + # program may have a very large number of files "open" at any one + # time (one is still limited by the maximum number of available + # FIO file descriptors). This option is supported only for binary + # files opened in some mode other than NEW_FILE; special devices + # are supported, but only if the device is randomly accessible and + # does not map file segments in to memory. + + if (value == YES && FCLOSEFD(ffp) == NO) { + if (FTYPE(ffp) == TEXT_FILE) + iferr (call filerr (FNAME(ffp), SYS_FCLFDTX)) + call erract (EA_FATAL) + if (FMODE(ffp) == NEW_FILE) + iferr (call filerr (FNAME(ffp), SYS_FCLFDNF)) + call erract (EA_FATAL) + + if (FCHAN(ffp) != ERR) { + call zcall2 (ZCLSBF(ffp), FCHAN(ffp), junk) + FCHAN(ffp) = ERR + } + + FCLOSEFD(ffp) = YES + + } else if (value == NO) { + # Wait until the next i/o operation occurs to reopen the file. + FCLOSEFD(ffp) = NO + } + + case F_DEVICE: + # Set entry point address of the read entry point of the device + # driver for a file. + + for (i=1; i < next_dev; i=i+LEN_DTE) + if (value == zdev[i]) { + FDEV(ffp) = i + return + } + iferr (call filerr (FNAME(ffp), SYS_FDEVNOTFOUND)) + call erract (EA_FATAL) + + case F_FILEWAIT: + # Wait for a file to become accessible during open. + call fset_env ("filewait", value) + + case F_FLUSHNL: + # Flush output when newline is seen. + if (value == YES) + fflags[fd] = or (FF_FLUSH + FF_FLUSHNL, fflags[fd]) + else if (FTYPE(ffp) == TEXT_FILE) + fflags[fd] = and (not(FF_FLUSHNL), fflags[fd]) + else + fflags[fd] = and (not(FF_FLUSH + FF_FLUSHNL), fflags[fd]) + + case F_KEEP: + # Keep a file open after program termination. + if (value == YES) + fflags[fd] = or (FF_KEEP, fflags[fd]) + else + fflags[fd] = and (not(FF_KEEP), fflags[fd]) + + case F_MODE: + # Set access mode of a file. + switch (value) { + case READ_ONLY: + fflags[fd] = and (not(FF_WRITE), fflags[fd]) + case READ_WRITE: + fflags[fd] = or (FF_READ + FF_WRITE, fflags[fd]) + case WRITE_ONLY: # disable buf read in ffault + fflags[fd] = and (not(FF_READ), fflags[fd]) + default: + iferr (call filerr (FNAME(ffp), SYS_FILLEGMODE)) + call erract (EA_FATAL) + } + FMODE(ffp) = value + + case F_NBUFS: + # Set the number of i/o buffers for a file. + ; # not implemented + + case F_ONEVERSION: + # Keep only one version of each file (in UNIX fashion, as opposed + # to the multiple versions of VMS). + call fset_env ("multversions", value) + + case F_PBBSIZE: + # Set the push-back buffer size for a file. + if (FPBBUF(ffp) == NULL) + FPBBUFSIZE(ffp) = value + + case F_TYPE: + # Set the file type (text, binary, etc). + FTYPE(ffp) = value + + if (value == TEXT_FILE) { + fflags[fd] = or (FF_FLUSH, fflags[fd]) + + } else if (value == SPOOL_FILE) { + # Reading and writing must be disabled for spool file or + # filbuf and flsbuf won't work. Also set the block size + # to zero, since spool files are considered to be streaming + # files. + + fflags[fd] = 0 + FBLKSIZE(ffp) = 0 + } + + case F_IOMODE, F_RAW: + # Set the i/o mode for reading from a text device. In raw mode, + # if the text device is a terminal, each character is returned as + # it is typed and most control characters are passed through on + # reads. If nonblocking raw mode is selected, each read will + # return immediately whether or not there is any data to be read. + # If no data could be read EOF is returned, but in RAWNB mode + # this indicates merely that no input data was available. + + setraw = (and (value, IO_RAW) != 0) + ndelay = (and (value, IO_NDELAY) != 0) + + fflags[fd] = and (not(FF_RAW+FF_NDELAY), fflags[fd]) + if (setraw) { + flags = FF_RAW + if (ndelay) + flags = flags + FF_NDELAY + fflags[fd] = or (fflags[fd], flags) + } + + # Send a special control sequence to the IRAF tty driver to + # physically turn raw mode on or off. If this were not done then + # raw mode would not be turned off until the next read occurred, + # which is counter intuitive and dangerous, as an abort might + # occur before the read, leaving the terminal in never never + # land. The funny string must of course agree with what ZPUTTY + # expects. + + if (fd == STDIN || fd == STDOUT || fd == STDERR) + outfd = STDOUT + else + outfd = fd + + if (xisatty (outfd) == YES && and (fflags[outfd], FF_WRITE) != 0) { + call flush (outfd) + + if (setraw) { + call strcpy (RAWON, rawcmd, LEN_RAWCMD) + if (ndelay) + rawcmd[LEN_RAWCMD+1] = 'N' + else + rawcmd[LEN_RAWCMD+1] = 'B' + rawcmd[LEN_RAWCMD+2] = EOS + call putline (outfd, rawcmd) + } else + call putline (outfd, RAWOFF) + + call flush (outfd) + } + + case F_SETREDRAW: + # Set the value of, and enable transmission of, the redraw control + # code to be issued following process suspension while in raw mode. + # Following a process suspend/continue while in raw mode, this code + # will be returned to the applications process in the next GETC + # call, as if it had been typed by the user. The redraw control + # code must be set to some positive nonzero value to enable + # transmission of the code by the terminal driver. Setting the + # code to zero disables the feature. The terminal driver (ZFIOTY) + # for host systems which do not support process suspension will + # recognize but ignore this control sequence. Note that the redraw + # control code to be returned by the driver is limited to a single + # character, e.g., or , depending upon the + # application. + + if (fd == STDIN || fd == STDOUT || fd == STDERR) + outfd = STDOUT + else + outfd = fd + + if (xisatty (outfd) == YES && and (fflags[outfd], FF_WRITE) != 0) { + call strcpy (SETREDRAW, set_redraw, LEN_SETREDRAW) + set_redraw[LEN_SETREDRAW] = value + call flush (outfd) + call write (outfd, set_redraw, LEN_SETREDRAW) + call flush (outfd) + } + + case F_REDIR: + # Set redir_fd to a negative value to indicate that the stream + # has been redirected in the parent process. If redir_fd is + # already set to a nonzero value, indicating that i/o has already + # been redirected either locally or in the parent, do nothing. + + if (value == YES) { + if (redir_fd[fd] == 0) + redir_fd[fd] = -1 + } else + redir_fd[fd] = 0 + + case F_VALIDATE: + # Validate the contents of the FIO buffer, e.g., after an i/o + # error has occurred during AREAD but it is thought that at least + # part of the data in the buffer may be valid. VALUE is the + # number of chars for which the FIO buffer is to be validated + # in the next call to FILBUF. This must be the only case for + # which FNCHARS can take on a negative value. + + FNCHARS(ffp) = -value + FNBYTES(ffp) = value * SZB_CHAR + FILSTAT(ffp) = OK + + default: + # This is a fatal error to prevent error recursion. + iferr (call filerr (FNAME(ffp), SYS_FSETUKNPAR)) + call erract (EA_FATAL) + } +end + + +# FSET_ENV -- Set the value of a boolean environment variable used for file +# control. A set environment call affects all programs in the current process +# and in all subprocesses, unless overriden by another SET statement or +# forgotten by ENVFREE. + +procedure fset_env (envvar, value) + +char envvar[ARB] # name of environment variable to be set +int value # YES or NO +int junk +int envputs() + +begin + switch (value) { + case YES: + junk = envputs (envvar, "yes") + case NO: + junk = envputs (envvar, "no") + } +end diff --git a/sys/fio/fsfopen.x b/sys/fio/fsfopen.x new file mode 100644 index 00000000..21ff9c95 --- /dev/null +++ b/sys/fio/fsfopen.x @@ -0,0 +1,82 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# FSFOPEN -- Open the subfile list file. A subfile is a physical file which is +# logically subordinate to another file (e.g., the pixel storage file is a +# subfile of an imagefile). The subfile list file is a hidden textfile, +# containing a list of filenames. + +int procedure fsfopen (fname, mode) + +char fname[ARB] # name of logical file +int mode # access mode for subfile list + +int fd +pointer sp, listfile +int open() +errchk open, fsf_getfname + +begin + call smark (sp) + call salloc (listfile, SZ_FNAME, TY_CHAR) + + call fsf_getfname (fname, Memc[listfile], SZ_FNAME) + fd = open (Memc[listfile], mode, TEXT_FILE) + + call sfree (sp) + return (fd) +end + + +# FSFDELETE -- Delete all of the subfiles of a file, then the subfile list +# file itself. + +procedure fsfdelete (fname) + +char fname[ARB] # file whose subfiles are to be deleted +int fd +pointer sp, subfile +int fsfopen(), getline() +errchk getline, delete, fsf_getfname + +begin + call smark (sp) + call salloc (subfile, SZ_FNAME, TY_CHAR) + + # Open the list and delete each subfile. To avoid recursion this must + # be done by calling delete, hence subfiles may not have subfiles. + # It is not an error if the listfile cannot be opened, i.e., if there + # are no subfiles. + + iferr (fd = fsfopen (fname, READ_ONLY)) { + call sfree (sp) + return + } + + while (getline (fd, Memc[subfile]) != EOF) + call delete (Memc[subfile]) + call close (fd) + + # Delete the listfile itself. + + call fsf_getfname (fname, Memc[subfile], SZ_FNAME) + call delete (Memc[subfile]) + + call sfree (sp) +end + + +# FSF_GETFNAME -- Get the name of the subfile list file for a file. + +procedure fsf_getfname (fname, fsf_file, maxch) + +char fname[ARB] # main file +char fsf_file[maxch] # file containing names of subfiles +int maxch + +begin + call strcpy (fname, fsf_file, maxch) + call strcat (SUBFILE_EXTN, fsf_file, maxch) +end diff --git a/sys/fio/fstati.x b/sys/fio/fstati.x new file mode 100644 index 00000000..9f22fe62 --- /dev/null +++ b/sys/fio/fstati.x @@ -0,0 +1,147 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# FSTATI -- Get information on the status and characteristics of an open +# file. Returns an integer value. See also FSTATL and FSTATS (for long +# integer and string status values). + +int procedure fstati (fd, what) + +int fd #I file descriptor +int what #I parameter to be returned + +pointer ffp, pb, pbtop +int flag, ffd, nchars, seglen, iomode +int and(), btoi() +bool envgetb() +long ffilsz() +include + +begin + ffp = fiodes[fd] + + switch (what) { + case F_ASYNC: + return (NO) # async i/o not implemented + case F_BLKSIZE: + return (FBLKSIZE(ffp)) + case F_BUFPTR: + return (bufptr[fd]) + case F_BUFSIZE: + return (FBUFSIZE(ffp)) + case F_BUFTYPE: + return (F_LOCAL) # global bufs not implemented + case F_FILESIZE: + FILSIZE(ffp) = ffilsz(fd) + return (FILSIZE(ffp)) + case F_FIRSTBUFOFF: + return (FIRSTBUFOFF(ffp)) + case F_CHANNEL: + return (FCHAN(ffp)) + case F_CLOBBER: + return (btoi (envgetb ("clobber"))) + case F_CLOSEFD: + return (FCLOSEFD(ffp)) + case F_DEVCODE: + return (FDEV(ffp)) + case F_DEVICE: + return (zdev[FDEV(ffp)]) + + case F_EOF: + if (FILSIZE(ffp) < 0 || LNOTE(fd) < ffilsz (fd)) + return (NO) + else + return (YES) + + case F_FILEWAIT: + return (btoi (envgetb ("filewait"))) + case F_FIODES: + return (ffp) + case F_FLUSHNL: + flag = FF_FLUSHNL + case F_IOMODE: + iomode = 0 + if (and (fflags[fd], FF_RAW) != 0) + iomode = iomode + IO_RAW + if (and (fflags[fd], FF_NDELAY) != 0) + iomode = iomode + IO_NDELAY + return (iomode) + case F_KEEP: + flag = FF_KEEP + + case F_LASTREFFILE: + # Return FD of last active file, i.e., the file on which i/o was + # most recently done (or on which i/o is in progress). FIO sets + # "fp" in fio.com whenever a file operation takes place. + + for (ffd=1; ffd <= LAST_FD; ffd=ffd+1) + if (fiodes[ffd] != NULL && fiodes[ffd] == fp) + return (ffd) + return (NULL) + + case F_MODE: + return (FMODE(ffp)) + + case F_NBUFS: + if (bufptr[fd] == NULL) + return (0) + else + return (FNBUFS(ffp)) + + case F_NCHARS: + return (FNCHARS(ffp)) + case F_ONEVERSION: + return (btoi (envgetb ("multversions"))) + case F_OPEN: + return (YES) + case F_OPTBUFSIZE: + return (FOPTBUFSIZE(ffp)) + case F_RAW: + flag = FF_RAW + case F_READ: + flag = FF_READ + + case F_REDIR: + if (redir_fd[fd] != 0) + return (YES) + else + return (NO) + + case F_SZBBLK: + return (FNBYTES(ffp)) + case F_TYPE: + return (FTYPE(ffp)) + case F_WRITE: + flag = FF_WRITE + case F_MAXBUFSIZE: + return (FMAXBUFSIZE(ffp)) + + case F_UNREAD: + UPDATE_IOP(fd) + if (iop[fd] < bufptr[fd] || iop[fd] >= itop[fd]) + nchars = 0 + else + nchars = itop[fd] - iop[fd] + if (and (FF_PUSHBACK, fflags[fd]) != 0) { + pbtop = (FPBTOP(ffp) - 1) / SZ_INT + 1 + for (pb=FPBSP(ffp); pb < pbtop; pb=pb+4) { + seglen = Memi[pb+1] - Memi[pb] + if (seglen > 0) + nchars = nchars + seglen + } + } + return (nchars) + + default: + return (ERR) + } + + if (and (flag, fflags[fd]) != 0) # test a flag bit + return (YES) + else + return (NO) +end diff --git a/sys/fio/fstatl.x b/sys/fio/fstatl.x new file mode 100644 index 00000000..3b4fdd26 --- /dev/null +++ b/sys/fio/fstatl.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +# FSTATL -- Return a file status value of type long integer (l). + +long procedure fstatl (fd, what) + +int fd, what +int ffilsz() +include + +begin + fp = fiodes[fd] + if (fd <= 0 || fp == NULL) + iferr (call syserr (SYS_FILENOTOPEN)) + call erract (EA_FATAL) + + switch (what) { + case F_FILESIZE: + FILSIZE(fp) = ffilsz (fd) + return (FILSIZE(fp)) + default: + iferr (call filerr (FNAME(fp), SYS_FSTATUNKPAR)) + call erract (EA_FATAL) + } +end diff --git a/sys/fio/fstats.x b/sys/fio/fstats.x new file mode 100644 index 00000000..469d0cc2 --- /dev/null +++ b/sys/fio/fstats.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# FSTATS -- Return a file status value of type string (s). + +procedure fstats (fd, what, outstr, maxch) + +int fd, what, maxch +char outstr[ARB] +pointer ffp +errchk syserr +include + +begin + ffp = fiodes[fd] + if (fd <= 0 || ffp == NULL) + call syserr (SYS_FILENOTOPEN) + + switch (what) { + case F_FILENAME: + call strcpy (FNAME(ffp), outstr, maxch) + default: + call filerr (FNAME(ffp), SYS_FSTATUNKPAR) + } +end diff --git a/sys/fio/fstdfile.x b/sys/fio/fstdfile.x new file mode 100644 index 00000000..b3f570a9 --- /dev/null +++ b/sys/fio/fstdfile.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# FSTDFILE -- Determine if the named file is a standard stream, and if so, +# return its file descriptor. + +int procedure fstdfile (fname, ofd) + +char fname[ARB] +int ofd +bool streq() + +begin + ofd = NULL + + if (fname[1] != 'S' || fname[2] != 'T') { + return (NO) + } else if (streq (fname, "STDIN")) { + ofd = STDIN + return (YES) + } else if (streq (fname, "STDOUT")) { + ofd = STDOUT + return (YES) + } else if (streq (fname, "STDERR")) { + ofd = STDERR + return (YES) + } else if (streq (fname, "STDGRAPH")) { + ofd = STDGRAPH + return (YES) + } else if (streq (fname, "STDIMAGE")) { + ofd = STDIMAGE + return (YES) + } else if (streq (fname, "STDPLOT")) { + ofd = STDPLOT + return (YES) + } else + return (NO) +end diff --git a/sys/fio/fstrfp.x b/sys/fio/fstrfp.x new file mode 100644 index 00000000..851bb6b1 --- /dev/null +++ b/sys/fio/fstrfp.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# FSTRFP -- Get a dummy file descriptor for use by STROPEN "files". +# The static part of the descriptor is returned to later be allocated +# by STROPEN. The dynamic part is permanently allocated, and is used to +# make the string look more like a regular file. + +procedure fstrfp (newfp) + +pointer newfp +pointer str_fp +int fd, fgetfd() +data str_fp /NULL/ +include + +begin + if (str_fp == NULL) { + fd = fgetfd ("String_File", STRING_FILE, STRING_FILE) + str_fp = fiodes[fd] + fiodes[fd] = NULL + } + + newfp = str_fp +end diff --git a/sys/fio/fsvtfn.x b/sys/fio/fsvtfn.x new file mode 100644 index 00000000..25b82f94 --- /dev/null +++ b/sys/fio/fsvtfn.x @@ -0,0 +1,81 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +define SZ_TMPFILBUF 100 +define SZ_INCREMENT 100 + + +# FSVTFN -- Save the name of a temporary file for automatic deletion at task +# termination. + +procedure fsvtfn (fname) + +char fname[ARB] +bool first_time +int sz_tmpbuf, nchars +int strlen() +errchk malloc, realloc + +pointer tmpbuf +int nextch +common /ftfcom/ tmpbuf, nextch +data first_time /true/ + +begin + if (first_time) { + tmpbuf = NULL + first_time = false + } + + # Call with a null filename permits first time initialization. + if (fname[1] == EOS) + return + + # Initial allocation of buffer. + if (tmpbuf == NULL) { + sz_tmpbuf = SZ_TMPFILBUF + call malloc (tmpbuf, sz_tmpbuf, TY_CHAR) + nextch = 0 + } + + # Increase size of buffer if necessary. + nchars = strlen (fname) + if (nchars == 0) + return + else { + while (nextch + nchars + 1 >= sz_tmpbuf) { + sz_tmpbuf = sz_tmpbuf + SZ_INCREMENT + call realloc (tmpbuf, sz_tmpbuf, TY_CHAR) + } + } + + # Save name of temporary file in buffer. + call strcpy (fname, Memc[tmpbuf+nextch], ARB) + nextch = nextch + nchars + 1 +end + + +# FRMTMP -- Delete all temporary files and return space. It seems harmless +# for the user to explicitly delete a temporary file, so we do not complain +# if the file does not exist. + +procedure frmtmp() + +pointer buftop, ip +int strlen(), access() + +pointer tmpbuf +int nextch +common /ftfcom/ tmpbuf, nextch + +begin + if (tmpbuf != NULL) { + buftop = tmpbuf + nextch + for (ip=tmpbuf; ip < buftop; ip = ip + strlen (Memc[ip]) + 1) + if (access (Memc[ip],0,0) == YES) + iferr (call delete (Memc[ip])) + call erract (EA_WARN) + call mfree (tmpbuf, TY_CHAR) + } +end diff --git a/sys/fio/fswapfd.x b/sys/fio/fswapfd.x new file mode 100644 index 00000000..d51d69a9 --- /dev/null +++ b/sys/fio/fswapfd.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +define SWAPI {tempi=$1;$1=$2;$2=tempi} +define SWAPL {templ=$1;$1=$2;$2=templ} +define SWAPP {tempp=$1;$1=$2;$2=tempp} + +# FSWAPFD -- Swap the file descriptors of two open files. All i/o to file +# fd1 is redirected to fd2 and vice versa, until the swap is reversed. +# We are used by FREDIR to temporarily redirect i/o (normally to one of the +# standard streams) to a special file. If CLOSE is called to close a +# redirected file, we are called to unswap the two streams and then the +# redirection file is closed. All the i/o pointers, buffer pointers, and +# so on of the original stream are restored to exactly the condition they +# were in before (unless i/o has occurred on the other file during the +# interim). + +procedure fswapfd (fd1, fd2) + +int fd1, fd2 # file descriptors to be swapped. +int tempi +long templ +pointer tempp +include + +begin + SWAPL (boffset[fd1], boffset[fd2]) + SWAPP (bufptr[fd1], bufptr[fd2]) + SWAPP (buftop[fd1], buftop[fd2]) + SWAPP (iop[fd1], iop[fd2]) + SWAPP (itop[fd1], itop[fd2]) + SWAPP (otop[fd1], otop[fd2]) + SWAPP (fiodes[fd1], fiodes[fd2]) + SWAPI (redir_fd[fd1], redir_fd[fd2]) +end diff --git a/sys/fio/fsymlink.x b/sys/fio/fsymlink.x new file mode 100644 index 00000000..c742baa7 --- /dev/null +++ b/sys/fio/fsymlink.x @@ -0,0 +1,53 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# FSYMLINK -- Remove a symlink. + +procedure fsymlink (link, target) + +char link[ARB] # link name +char target[ARB] # target file + +int status +pointer sp, oslnk, ostgt, lname, tname +int access() +errchk syserrs + +begin + call smark (sp) + call salloc (lname, SZ_PATHNAME, TY_CHAR) + call salloc (tname, SZ_PATHNAME, TY_CHAR) + call salloc (oslnk, SZ_PATHNAME, TY_CHAR) + call salloc (ostgt, SZ_PATHNAME, TY_CHAR) + + # It is an error if the link file already exists. + if (access (link, 0, 0) == YES) + call syserrs (SYS_FSYMLINK, link) + + # Always present ZFLINK with a full pathname (rather than an + # absolute or cwd relative filename), in case the kernel procedure + # is not smart enough to handle all these possibilities. + call aclrc (Memc[oslnk], SZ_PATHNAME) + iferr (call fmapfn (link, Memc[oslnk], SZ_PATHNAME)) + call syserrs (SYS_FSYMLINK, link) + +# call strupk (Memc[oslnk], Memc[oslnk], SZ_PATHNAME) +# call strpak (Memc[oslnk], Memc[oslnk], SZ_PATHNAME) + + + call aclrc (Memc[ostgt], SZ_PATHNAME) + iferr (call fmapfn (target, Memc[ostgt], SZ_PATHNAME)) + call syserrs (SYS_FSYMLINK, target) + +# call strupk (Memc[ostgt], Memc[ostgt], SZ_PATHNAME) +# call strpak (Memc[ostgt], Memc[ostgt], SZ_PATHNAME) + + # Try to create the symlink. + call zflink (Memc[ostgt], Memc[oslnk], status) + if (status == ERR) + call syserrs (SYS_FSYMLINK, link) + + call sfree (sp) +end diff --git a/sys/fio/funlink.x b/sys/fio/funlink.x new file mode 100644 index 00000000..402076f0 --- /dev/null +++ b/sys/fio/funlink.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# FUNLINK -- Remove a symlink. + +procedure funlink (lname) + +char lname[ARB] # link name + +int status +pointer sp, oslnk +int access() +errchk syserrs + +begin + call smark (sp) + call salloc (oslnk, SZ_PATHNAME, TY_CHAR) + + # It is an error if the link file doesn't exist. + if (access (lname, 0, 0) == NO) + call syserrs (SYS_FOPEN, lname) + + # Try to remove the symlink. + iferr (call fmapfn (lname, Memc[oslnk], SZ_PATHNAME)) + call syserrs (SYS_FSYMLINK, lname) + call zfulnk (Memc[oslnk], status) + if (status == ERR) + call syserrs (SYS_FUNLINK, lname) + + call sfree (sp) +end diff --git a/sys/fio/futime.x b/sys/fio/futime.x new file mode 100644 index 00000000..72ef268b --- /dev/null +++ b/sys/fio/futime.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + + +.help futime +.nf ___________________________________________________________________________ +FUTIME -- Set the file access/modify times of a file. Time arguments are +assumed to be in units of seconds from midnight on Jan 1, 1980, local standard +time. A file may be "touched" to update it's modify time to the current +clock time using the CLKTIME function with a call such as + + stat = futime (fname, NULL, clktime(0)) + +Remote files are handled via the KI interface automatically. +.endhelp ______________________________________________________________________ + +int procedure futime (fname, atime, mtime) + +char fname[ARB] +long atime, mtime +int status +include + +begin + iferr (call fmapfn (fname, pathname, SZ_PATHNAME)) + return (ERR) + + # Update the time, let the HSI routine handle NULL values. + call zfutim (pathname, atime, mtime, status) + + return (status) +end diff --git a/sys/fio/fwatio.x b/sys/fio/fwatio.x new file mode 100644 index 00000000..15e9c249 --- /dev/null +++ b/sys/fio/fwatio.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# FWATIO -- Wait for i/o to complete on the file buffer, update file +# buffer pointers. + +procedure fwatio (fd) + +int fd +int nchars, bufmode +int await() +errchk filerr +include + +begin + fp = fiodes[fd] + + if (FBUFMODE(fp) == INACTIVE) + return + + else { + nchars = await (fd) + + # Set the buffer mode flag to inactive regardless of the status + # returned by await. + + bufmode = FBUFMODE(fp) + FBUFMODE(fp) = INACTIVE + + if (bufmode == READ_IN_PROGRESS) { + if (nchars == ERR) + call filerr (FNAME(fp), SYS_FREAD) + else + itop[fd] = bufptr[fd] + nchars + + } else if (nchars == ERR) { + # If an i/o error occurs on a write invalidate the buffer + # else during error recovery close will try again to write + # the data, probably causing another error. + + otop[fd] = bufptr[fd] + call filerr (FNAME(fp), SYS_FWRITE) + } + + otop[fd] = bufptr[fd] + } +end diff --git a/sys/fio/fwritep.x b/sys/fio/fwritep.x new file mode 100644 index 00000000..f92aeaf0 --- /dev/null +++ b/sys/fio/fwritep.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# FWRITEP -- Write to a file, directly accessing the file data in the FIO +# buffer rather than copying the data from the user buffer to the FIO buffer. +# This technique can be used for very efficient file access, but is not as +# general as an ordinary write. In particular the requested data segment +# must lie entirely within the FIO buffer, and the data must be written into +# the FIO buffer before a file fault causes the buffer contents to be flushed +# to disk. The file size should be known in advance and any attempt to write +# outside the file boundaries is interpreted as an error. +# +# NOTE -- This routine returns a pointer into the FIO buffer. No data is +# transferred in the call itself. The data is not actually written to the +# output file until the FIO buffer is faulted out. If the output file is +# readwrite and offset,nchars does not span the entire buffer, file data +# will be read into the buffer when it is first faulted in. Hence, FWRITEP +# may be used for updating the contents of a file. + +pointer procedure fwritep (fd, offset, nchars) + +int fd # file to be accessed +long offset # file offset in chars +int nchars # nchars to "write" + +int junk +pointer fiop, bp +int ffault() +errchk filerr, ffault, fmkbfs +include + +begin + # Move file buffer onto file block containing the file offset. + # Verify that the buffer contains nchars of file data in contiguous + # storage. If the file buffer already contains the referenced + # data segment no fault is necessary and this is quite fast. + # The iop is left pointing to the first char following the + # referenced data block. + + repeat { + bp = bufptr[fd] + fiop = offset - boffset[fd] + bp # lseek + + if (fiop < bp || fiop >= otop[fd]) { + if (bp == NULL) { + call fmkbfs (fd) + next + } + junk = ffault (fd, offset, nchars, FF_WRITE) + fiop = iop[fd] + otop[fd] = buftop[fd] + } + + iop[fd] = fiop + nchars + if (iop[fd] > otop[fd]) + call filerr (FNAME(fiodes[fd]), SYS_FWRITEP) + + return (fiop) + } +end diff --git a/sys/fio/fwtacc.x b/sys/fio/fwtacc.x new file mode 100644 index 00000000..bcedcae0 --- /dev/null +++ b/sys/fio/fwtacc.x @@ -0,0 +1,120 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +define MIN_DELAY 1 +define MAX_DELAY 60 +define INC_DELAY 1 +define SOMEFILE "hlib$iraf.h" + + +# FWTACC -- Called if a file open fails. Determine if failure to open file +# was due to the file already being open by another task. If so, and file +# waiting is enabled in the environment, wait for file to become accessible, +# otherwise take error action. + +procedure fwtacc (fd, fname) + +int fd #I file we are trying to open +char fname[ARB] #I name of file + +bool locked +pointer sp, osfn +int perm, delay, chan, status, ofd +long fi[LEN_FINFO] + +int access(), finfo() +bool streq(), envgetb() +errchk filerr, fmapfn +include +define noacc_ 91 + +begin + call smark (sp) + call salloc (osfn, SZ_PATHNAME, TY_CHAR) + + fp = fiodes[fd] + if (FMODE(fp) == NEW_FILE) + call filerr (fname, SYS_FOPEN) + + # If file is blocked for some reason because it is already open + # by this process, waiting would result in a deadlock. + + for (ofd=FIRST_FD; ofd <= LAST_FD; ofd=ofd+1) + if (ofd != fd && fiodes[ofd] != NULL) + if (streq (fname, FNAME(fiodes[ofd]))) + call filerr (fname, SYS_FWTOPNFIL) + + # If file waiting is enabled, the file exists and has write permission + # for us but is not writable at the moment, wait for the file to + # become available. FINFO is used to determine the "permanent" + # permissions for the file and the file owner. ACCESS determines the + # runtime accessibility of the file. The permanent file protection may + # permit writing but the file may not be accessible for writing at + # runtime if opened for exclusive access by another process. + + if (finfo (fname, fi) == ERR) + call filerr (fname, SYS_FOPNNEXFIL) + + # Directory files are not accessible as files. + if (FI_TYPE(fi) == FI_DIRECTORY) + goto noacc_ + + # Test if we the open failed because we cannot physically open any + # more files. + + call fmapfn (SOMEFILE, Memc[osfn], SZ_PATHNAME) + call zopntx (Memc[osfn], READ_ONLY, chan) + if (chan == ERR) + call filerr (fname, SYS_FTOOMANYFILES) + else + call zclstx (chan, status) + + # If the file exists, we cannot access it, and there is no temporary + # read or write lock in place on the file, then the file cannot be + # accessed. + + perm = FI_PERM(fi) + locked = false + if (and (fflags[fd], FF_READ) != 0) + locked = locked || (and (perm, FF_RDLOCK) != 0) + if (and (fflags[fd], FF_WRITE) != 0) + locked = locked || (and (perm, FF_WRLOCK) != 0) + + # If filewait is enabled, wait for the file to become accessible. + if (envgetb ("filewait") && locked) { + call putline (STDERR, "Waiting for access to file '") + call putline (STDERR, fname) + call putline (STDERR, "'\n") + + for (delay=MIN_DELAY; delay > 0; delay=delay+INC_DELAY) { + call tsleep (min (delay, MAX_DELAY)) + + if (access (fname,0,0) == NO) + call filerr (fname, SYS_FOPNNEXFIL) + else if (access (fname,FMODE(fp),0) == YES) { + call sfree (sp) + return + } + + # Verify that the file is still locked. + if (finfo (fname, fi) == ERR) + call filerr (fname, SYS_FOPNNEXFIL) + + locked = false + if (and (fflags[fd], FF_READ) != 0) + locked = locked || (and (perm, FF_RDLOCK) != 0) + if (and (fflags[fd], FF_WRITE) != 0) + locked = locked || (and (perm, FF_WRLOCK) != 0) + + if (!locked) + break + } + } +noacc_ + call sfree (sp) + call filerr (fname, SYS_FWTNOACC) +end diff --git a/sys/fio/getc.x b/sys/fio/getc.x new file mode 100644 index 00000000..b8c469d5 --- /dev/null +++ b/sys/fio/getc.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GETC -- Get a character from a file. + +char procedure getc (fd, ch) + +int fd # input file +char ch # character (output) +int filbuf() +errchk filbuf +include + +begin + if (iop[fd] < bufptr[fd] || iop[fd] >= itop[fd]) + if (filbuf(fd) == EOF) { + ch = EOF + return (EOF) + } + + ch = Memc[iop[fd]] + iop[fd] = iop[fd] + 1 + + return (ch) +end diff --git a/sys/fio/getchar.x b/sys/fio/getchar.x new file mode 100644 index 00000000..2a2b6cd9 --- /dev/null +++ b/sys/fio/getchar.x @@ -0,0 +1,12 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GETCHAR -- Get a character from the standard input. + +char procedure getchar (ch) + +char ch # character (output) +char getc() + +begin + return (getc (STDIN, ch)) +end diff --git a/sys/fio/getci.x b/sys/fio/getci.x new file mode 100644 index 00000000..64dd6f66 --- /dev/null +++ b/sys/fio/getci.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GETCI -- Get a character (passed as an integer) from a file. + +int procedure getci (fd, ch) + +int fd # input file +int ch # character (output) +int filbuf() +errchk filbuf +include + +begin + if (iop[fd] < bufptr[fd] || iop[fd] >= itop[fd]) + if (filbuf(fd) == EOF) { + ch = EOF + return (EOF) + } + + ch = Memc[iop[fd]] + iop[fd] = iop[fd] + 1 + + return (ch) +end diff --git a/sys/fio/getline.x b/sys/fio/getline.x new file mode 100644 index 00000000..78bdb285 --- /dev/null +++ b/sys/fio/getline.x @@ -0,0 +1,85 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GETLINE -- Get a line of text from a file. If file buffer is empty and +# file is a text file, read line directly into the buffer supplied by the +# calling procedure. If text is buffered, copy characters out of file buffer +# into the output buffer until the newline character is encountered. Refill +# buffer as necessary. Note IOP, ITOP are moved into local variables to +# optimize the loop. The fd values must be updated before calling FILBUF +# and upon exit from the loop. + +int procedure getline (fd, linebuf) + +int fd # input file +char linebuf[ARB] # output line buffer (>= SZ_LINE) + +bool pushback +char ch +pointer ip, ip_top, op +int maxch, status +int filbuf(), and() +errchk filbuf, filerr +include + +begin + fp = fiodes[fd] + if (fd <= 0 || fp == NULL) + call filerr (FNAME(fp), SYS_FILENOTOPEN) + + pushback = (and (fflags[fd], FF_PUSHBACK) != 0) + + if (FTYPE(fp) == TEXT_FILE && iop[fd] == itop[fd] && !pushback) { + # Get next line from text file, initialize pointers. In raw mode + # we only read one character at a time. + + if (and (FF_RAW, fflags[fd]) == 0) + maxch = SZ_LINE + else + maxch = 1 + call zcall4 (ZGETTX(fp), FCHAN(fp), linebuf, maxch, status) + + if (status == ERR) + call filerr (FNAME(fp), SYS_FREAD) + op = max (0, status+1) + + } else { + op = 1 + ip = iop[fd] # loop optimization stuff + ip_top = itop[fd] + if (ip < bufptr[fd]) + goto 10 + + while (op <= SZ_LINE) { + if (ip >= ip_top) { + iop[fd] = ip + 10 status = filbuf (fd) + ip = iop[fd] + ip_top = itop[fd] + if (status <= 0) + break + } + + ch = Memc[ip] + linebuf[op] = ch + ip = ip + 1 + op = op + 1 + + if (ch == '\n') + break + } + iop[fd] = ip + } + + if (op <= 1) { + FNCHARS(fp) = 0 + return (EOF) + } else { + FNCHARS(fp) = op - 1 + linebuf[op] = EOS + return (op - 1) # number of chars read + } +end diff --git a/sys/fio/getlline.x b/sys/fio/getlline.x new file mode 100644 index 00000000..e8e25d77 --- /dev/null +++ b/sys/fio/getlline.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GETLLINE -- Get a logical line of text, i.e., an arbitrarily long line +# possibly broken up into multiple segments of size SZ_LINE. Accumulation +# stops when the indicated number of chars have been read, or newline is +# detected. MAXCH must be at least SZ_LINE characters greater than the +# longest line to be read. + +int procedure getlline (fd, obuf, maxch) + +int fd #I input file +char obuf[ARB] #O output buffer +int maxch #I max chars out, >= SZ_LINE + +int op, status +int getline() +errchk getline + +begin + op = 1 + + while (maxch - op + 1 >= SZ_LINE) { + # Get next physical line from the file. + status = getline (fd, obuf[op]) + if (status == EOF) { + if (op == 1) + return (EOF) + else + return (op - 1) + } else + op = op + status + + # If the last physical line read ends in a newline we are done. + # If no newline we get another line, thereby reconstructing long + # lines broken by the SZ_LINE limit of getline(). + + if (obuf[op-1] == '\n') + break + } + + return (op - 1) +end diff --git a/sys/fio/glongline.x b/sys/fio/glongline.x new file mode 100644 index 00000000..6350cb3e --- /dev/null +++ b/sys/fio/glongline.x @@ -0,0 +1,73 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GETLONGLINE -- Get a long line, i.e., a logical line possibly spanning +# several physical lines with the newlines escaped at the ends. Skip +# comment lines and .help sections. Blank lines are not skipped. +# Lines not terminated by newlines are joined to form a longer line. +# MAXCH must be at least SZ_LINE characters greater than the size of the +# longest line to be read. + +int procedure getlongline (fd, obuf, maxch, linenum) + +int fd #I input file +char obuf[ARB] #O output buffer +int maxch #I max chars out +int linenum #U line number counter + +int op, status +int getline(), strncmp() +errchk getline + +begin + op = 1 + + while (maxch - op + 1 >= SZ_LINE) { + # Get next non-comment line. + repeat { + status = getline (fd, obuf[op]) + if (status > 0 && obuf[op+status-1] == '\n') + linenum = linenum + 1 + + if (status == EOF) { + break + } else if (obuf[op] == '#') { + next + } else if (obuf[op] == '.') { + # Skip help sections. + if (strncmp (obuf[op], ".help", 5) == 0) { + repeat { + status = getline (fd, obuf[op]) + linenum = linenum + 1 + if (status == EOF) + break + if (strncmp (obuf[op], ".endhelp", 8) == 0) + break + } + } else + break + } else + break + } + + if (status == EOF) { + if (op == 1) + return (EOF) + else + return (op - 1) + } else + op = op + status + + # If the last physical line read ends in a newline we are done, + # unless the newline is escaped. If there is no newline we get + # another line, thereby reconstructing long lines broken by the + # SZ_LINE limit of getline(). + + if (obuf[op-1] == '\n') + if (obuf[op-2] == '\\') + op = op - 2 + else + break + } + + return (op - 1) +end diff --git a/sys/fio/isdir.x b/sys/fio/isdir.x new file mode 100644 index 00000000..92008da1 --- /dev/null +++ b/sys/fio/isdir.x @@ -0,0 +1,73 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# ISDIRECTORY -- Test whether the named file is a directory. Check first to +# see if it is a subdirectory of the current directory; otherwise look in +# the environment to see if it is a logical directory. If VFN is a directory, +# return the OS pathname of the directory in pathname, and the number of +# chars in the pathname as the function value. Otherwise return 0. + +int procedure isdirectory (vfn, pathname, maxch) + +char vfn[ARB] # name to be tested +char pathname[ARB] # receives path of directory +int maxch # max chars out + +bool isdir +pointer sp, fname, op +int ip, fd, nchars, ch +long file_info[LEN_FINFO] +int finfo(), diropen(), gstrcpy(), strlen() + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + # Copy the VFN string, minus any whitespace on either end. + op = fname + for (ip=1; vfn[ip] != EOS; ip=ip+1) { + ch = vfn[ip] + if (!IS_WHITE (ch)) { + Memc[op] = ch + op = op + 1 + } + } + Memc[op] = EOS + + # Remove any trailing '/' from the pathname. + if (Memc[op-1] == '/') + Memc[op-1] = EOS + + isdir = false + if (finfo (Memc[fname], file_info) != ERR) { + isdir = (FI_TYPE(file_info) == FI_DIRECTORY) + + if (isdir) { + call fdirname (Memc[fname], pathname, maxch) + nchars = strlen (pathname) + } + + } else { + # If we get here, either VFN is a logical directory (with the + # $ omitted), or it is the name of a new file. + + Memc[op] = '$' + Memc[op+1] = EOS + ifnoerr (fd = diropen (Memc[fname], 0)) { + call close (fd) + isdir = true + } + + nchars = gstrcpy (Memc[fname], pathname, maxch) + } + + call sfree (sp) + if (isdir) + return (nchars) + else { + pathname[1] = EOS + return (0) + } +end diff --git a/sys/fio/mkpkg b/sys/fio/mkpkg new file mode 100644 index 00000000..f135befc --- /dev/null +++ b/sys/fio/mkpkg @@ -0,0 +1,123 @@ +# Make the file i/o (FIO) portion of the system library. + +$checkout libsys.a lib$ +$update libsys.a +$checkin libsys.a lib$ +$exit + +libsys.a: + access.x mmap.inc \ + + aread.x + areadb.x + await.x + awaitb.x + awrite.x + awriteb.x + close.x + delete.x + deletefg.x + diropen.x \ + + falloc.x + fcache.x + fcanpb.x + fchdir.x + fclobber.x + fcopy.x + fdebug.x + fdevbf.x + fdevblk.x + fdevtx.x + fdirname.x + fexbuf.x + ffault.x + ffilbf.x + ffilsz.x + fflsbf.x + fgdevpar.x + fgetfd.x mmap.inc + filbuf.x + filerr.x + filopn.x \ + + finfo.x + finit.x \ + + fioclean.x + flsbuf.x + flush.x + fmapfn.x + fmkbfs.x + fmkcopy.x + fmkdir.x + fmkpbbuf.x + fnextn.x + fnldir.x + fnroot.x + frmdir.x + fntgfn.x + fnullfile.x + fopnbf.x + fopntx.x + fowner.x + fpathname.x + fputtx.x + freadp.x + fredir.x + frename.x + frmbfs.x + frtnfd.x + fseti.x \ + + fsfopen.x + fstati.x + fstatl.x + fstats.x + fstdfile.x + fstrfp.x + fsymlink.x + fsvtfn.x + fswapfd.x + funlink.x + futime.x + fwatio.x + fwritep.x + fwtacc.x + getc.x + getchar.x + getci.x + getline.x + getlline.x + glongline.x + isdir.x + mktemp.x + ndopen.x + note.x + nowhite.x + nullfile.x + open.x + osfnlock.x + poll.x + protect.x + putc.x + putcc.x + putci.x + putline.x + read.x + rename.x + reopen.x + seek.x + stropen.x + ungetc.x + ungetci.x + ungetline.x + unread.x + vfnmap.x \ + + vfntrans.x + write.x + xerputc.x + zfiott.x zfiott.com \ + + ; diff --git a/sys/fio/mktemp.x b/sys/fio/mktemp.x new file mode 100644 index 00000000..272d4c64 --- /dev/null +++ b/sys/fio/mktemp.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +define RADIX 26 +define SZ_SUFFIX 10 +define NTRIES 5 +define MAX_TRIP 5000 + +# MKTEMP -- Make a unique file name (used to generate temporary file names). +# Format of name is "seedNNNNcc.." where the seed is supplied by the caller, +# NNNN is (normally) the lowest four digits of the process id, and the +# characters "cc..." are the radix 26 representation of a local counter +# (maintained in static storage). The algorithm used virtually guarantees +# a unique name on the first try. Logical directory prefixes are allowed. + +procedure mktemp (seed, temp_file, maxchars) + +char seed[ARB], temp_file[ARB], suffix[SZ_SUFFIX] +int maxchars, counter, i, n, op, pid +int access(), itoc() +data counter/0/ + +begin + call zgtpid (pid) # get process id + + do i = 1, MAX_TRIP { + call strcpy (seed, temp_file, maxchars) + op = itoc (mod(pid,10000), suffix, SZ_SUFFIX) + call strcat (suffix, temp_file, maxchars) + + counter = counter + 1 + op = 1 + for (n=counter; n > 0; n = (n-1) / RADIX) { + suffix[op] = mod (n-1, RADIX) + 'a' + op = op + 1 + } + suffix[op] = EOS + call strcat (suffix, temp_file, maxchars) + + if (access (temp_file,0,0) == NO) # does file exist? + return + else if (mod(i,NTRIES) == 0) + pid = pid + mod(counter,10) # not likely to get here + } + + call filerr (seed, SYS_FMKTEMP) +end diff --git a/sys/fio/mmap.inc b/sys/fio/mmap.inc new file mode 100644 index 00000000..aebc0f27 --- /dev/null +++ b/sys/fio/mmap.inc @@ -0,0 +1,8 @@ +# map 6 file modes into one of five simpler modes +int mmap[TEMP_FILE] +data mmap[READ_ONLY] /READ_ONLY/ +data mmap[READ_WRITE] /READ_WRITE/ +data mmap[WRITE_ONLY] /WRITE_ONLY/ +data mmap[APPEND] /APPEND/ +data mmap[NEW_FILE] /NEW_FILE/ +data mmap[TEMP_FILE] /NEW_FILE/ diff --git a/sys/fio/ndopen.x b/sys/fio/ndopen.x new file mode 100644 index 00000000..bb71933e --- /dev/null +++ b/sys/fio/ndopen.x @@ -0,0 +1,94 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + + +# NDOPEN -- Open a network device. This is used by a client to connect to +# a server, or by a server to establish a port to which clients can connect. +# The open may or may not block until a client has connected, depending upon +# the type of connection. The access mode should be NEW_FILE for a server +# connection, anything else is a client connection. If the server is to +# support multiple client connections the server connection can be opened +# in nonblocking mode, then used to listen for client connections which are +# accepted each on a separate connection (see zfiond.c for details). Most +# clients use mode READ_WRITE. The connection is bidirectional and stream +# oriented. +# +# The syntax of the filename argument (network address) is determined by the +# host level ND driver. The filename is passed on to the driver transparently +# to the portable IRAF code. System independent IRAF code should treat these +# strings as data, like host filenames, and not attempt to parse or construct +# the strings. Refer to the ND driver source for further information on the +# ND filename syntax. +# +# The host driver (os$zfiond.c) determines the types of network or +# interprocess connections supported. For example, the initial ND driver for +# UNIX/IRAF systems supports Internet sockets, UNIX domain sockets, and FIFO +# pipes. +# +# If the same file descriptor is used for both reading and writing some means +# is needed to synchronize data transfer. When switching between reads and +# writes, the client code should execute a F_CANCEL on the stream before the +# first read or write of a sequence. FLUSH should be called after the last +# write. For example, +# +# call fseti (fd, F_CANCEL, OK) +# call write (fd, buf, nchars) +# +# call flush (fd) +# +# call fseti (fd, F_CANCEL, OK) +# nchars = read (fd, buf, maxch) +# +# +# A better approach however is to open two separate steams at the FIO level +# and use one for reading a one for writing. After the first stream is +# opened using NDOPEN, a second file descriptor can be opened using REOPEN. +# Both will share the same underlying network connection, but one stream +# can be used for reading and one for writing, with separate buffers for +# each stream and full streaming i/o capabilities. +# +# Any of the i/o routines may be used, e.g., getc/putc may be used to perform +# character i/o on the stream, with FIO doing the buffering. +# +# Once opened all ND connections are byte streams. The protocol used for +# client-server communications is determined entirely by the server; an IRAF +# client may connect to a "foreign" server via an ND connection, so long +# as the correct client-server protocol is observed. If the server supports +# multiple clients multiple ND connections may be made, either in the same +# process or in different processes. An IRAF task using the ND interface +# may be a server, but currently the ND driver does not support multiple +# concurrent client connections, since the connection and i/o block. +# Multiple nonconcurrent (i.e. sequential) clients are possible. Multiple +# conncurent connections are possible only if a scheme is used such as having +# inetd spawn a server process for each connection. + +int procedure ndopen (fname, mode) + +char fname[ARB] #I network address +int mode #I access mode + +int ip, fd +char port[SZ_PATHNAME] +int fopnbf(), strncmp(), ctoi(), fstati() +extern zopnnd(), zardnd(), zawrnd(), zawtnd(), zsttnd(), zclsnd() + +begin + # If a server connection is being opened (mode NEW_FILE) then + # check for the pseudo-domain "sock", which is defined by ZFIOND + # and used to accept a client connection request made to a server + # port. The ND driver in the kernel requires a host channel number + # so we must convert the FIO file descriptor passed in by the client. + + if (mode == NEW_FILE && strncmp(fname,"sock:",5) == 0) { + ip = 6 + if (ctoi (fname, ip, fd) <= 0) + return (ERR) + call sprintf (port, SZ_PATHNAME, "sock:%d") + call pargi (fstati (fd, F_CHANNEL)) + } else + call strcpy (fname, port, SZ_PATHNAME) + + return (fopnbf (port, mode, + zopnnd, zardnd, zawrnd, zawtnd, zsttnd, zclsnd)) +end diff --git a/sys/fio/note.x b/sys/fio/note.x new file mode 100644 index 00000000..d50ee01d --- /dev/null +++ b/sys/fio/note.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# NOTE -- Note offset in file for a subsequent SEEK. If text file, the offset +# of the current line is returned; it is only permissible to seek to the +# beginning of a line on a text file. If binary file, the offset returned is +# the offset at which the next BUFFERED i/o transfer will occur. If file is +# being accessed unbuffered random, the concept of file position is meaningless. + +long procedure note (fd) + +int fd +errchk filerr +include + +begin + fp = fiodes[fd] + if (fd <= 0 || fp == NULL) + call filerr (FNAME(fp), SYS_FILENOTOPEN) + + if (FTYPE(fp) == TEXT_FILE) { + call zcall2 (ZNOTTX(fp), FCHAN(fp), boffset[fd]) + return (boffset[fd]) + } else + return (LNOTE(fd)) +end diff --git a/sys/fio/nowhite.x b/sys/fio/nowhite.x new file mode 100644 index 00000000..966ebc20 --- /dev/null +++ b/sys/fio/nowhite.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# NOWHITE -- Return the input string minus any whitespace or newlines, +# returning a count of the number of nonwhite characters as the function value. + +int procedure nowhite (in, out, maxch) + +char in[ARB] # input string +char out[ARB] # output string +int maxch # max chars out + +int ch +int ip, op + +begin + op = 1 + do ip = 1, ARB { + ch = in[ip] + if (ch <= ' ') { + if (ch == EOS) + break + else if (IS_WHITE(ch) || ch == '\n') + next + } + if (op > maxch) + break + out[op] = ch + op = op + 1 + } + + out[op] = EOS + return (op - 1) +end diff --git a/sys/fio/nullfile.x b/sys/fio/nullfile.x new file mode 100644 index 00000000..363984d1 --- /dev/null +++ b/sys/fio/nullfile.x @@ -0,0 +1,251 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +.help nullfile +.nf ___________________________________________________________________________ +NULLFILE -- Text and binary file drivers for the nullfile, "dev$null". +These special drivers behave like regular text or binary drivers but +have the special property that no i/o occurs, i.e., all output is discarded, +making it appear as if the write was successful, and EOF is returned for +all attempts to read from the file. +.endhelp ______________________________________________________________________ + +define MAX_NULLFILES (LAST_FD-FIRST_FD+1) +define SZ_DEFINBUF 1 # buffer size when reading +define SZ_DEFOUTBUF 2048 # buffer size when writing + +define NU_INUSE 01B +define NU_READ 02B +define NU_WRITE 04B + + +# ZOPNNU -- Open a nullfile. Used for both binary and text nullfiles. + +procedure zopnnu (osfn, mode, chan) + +char osfn[ARB] # osfn version of dev$null, presumably +int mode # not used +int chan # assigned channel (output) + +bool first_time +int nu +int flags[MAX_NULLFILES] +int count[MAX_NULLFILES] +common /znucom/ flags, count +data first_time /true/ + +begin + # First time initialization. + if (first_time) { + do nu = 1, MAX_NULLFILES + flags[nu] = 0 + first_time = false + } + + # Find open slot. + for (nu=1; nu <= MAX_NULLFILES; nu=nu+1) + if (flags[nu] == 0) + break + if (nu > MAX_NULLFILES) { + chan = ERR + return + } + + switch (mode) { + case READ_ONLY: + flags[nu] = NU_INUSE + NU_READ + case READ_WRITE: + flags[nu] = NU_INUSE + NU_READ + NU_WRITE + default: + flags[nu] = NU_INUSE + NU_WRITE + } + + count[nu] = 0 + chan = nu +end + + +# ZCLSNU -- Close a null file. Used for both text and binary null files. + +procedure zclsnu (chan, status) + +int chan +int status + +int flags[MAX_NULLFILES] +int count[MAX_NULLFILES] +common /znucom/ flags, count + +begin + if (flags[chan] == 0) + status = ERR + else { + flags[chan] = 0 + status = OK + } +end + + +# ZSTTNU -- Status of a null file. Used for both text and binary null files. + +procedure zsttnu (chan, param, lvalue) + +int chan +int param +long lvalue +int and() + +int flags[MAX_NULLFILES] +int count[MAX_NULLFILES] +common /znucom/ flags, count + +begin + switch (param) { + case FSTT_BLKSIZE: + lvalue = 0 + case FSTT_FILSIZE: + lvalue = 0 + case FSTT_OPTBUFSIZE, FSTT_MAXBUFSIZE: + if (and (flags[chan], NU_WRITE) != 0) + lvalue = SZ_DEFOUTBUF + else + lvalue = SZ_DEFINBUF + } +end + + +# ZARDNU, ZAWRNU, ZAWTNU -- Binary file i/o to the null file. + +procedure zardnu (chan, buf, maxbytes, loffset) + +int chan, maxbytes +char buf[ARB] +long loffset + +int flags[MAX_NULLFILES] +int count[MAX_NULLFILES] +common /znucom/ flags, count + +begin + count[chan] = 0 +end + + +procedure zawrnu (chan, buf, nbytes, loffset) + +int chan, nbytes +char buf[ARB] +long loffset + +int flags[MAX_NULLFILES] +int count[MAX_NULLFILES] +common /znucom/ flags, count + +begin + count[chan] = nbytes +end + + +procedure zawtnu (chan, status) + +int chan, status + +int flags[MAX_NULLFILES] +int count[MAX_NULLFILES] +common /znucom/ flags, count + +begin + if (flags[chan] != 0) + status = count[chan] + else + status = ERR +end + + +# ZGETNU, ZPUTNU, ZFLSNU, ZSEKNU, ZNOTNU -- Text file i/o to the null file. + +procedure zgetnu (chan, buf, maxch, status) + +int chan, maxch, status +char buf[ARB] + +int flags[MAX_NULLFILES] +int count[MAX_NULLFILES] +common /znucom/ flags, count + +begin + if (flags[chan] != 0) + status = 0 + else + status = ERR +end + + +procedure zputnu (chan, buf, nchars, status) + +int chan, nchars, status +char buf[ARB] + +int flags[MAX_NULLFILES] +int count[MAX_NULLFILES] +common /znucom/ flags, count + +begin + if (flags[chan] != 0) + status = nchars + else + status = ERR +end + + +procedure zflsnu (chan, status) + +int chan +int status + +int flags[MAX_NULLFILES] +int count[MAX_NULLFILES] +common /znucom/ flags, count + +begin + if (flags[chan] != 0) + status = OK + else + status = ERR +end + + +procedure zseknu (chan, loffset, status) + +int chan, status +long loffset + +int flags[MAX_NULLFILES] +int count[MAX_NULLFILES] +common /znucom/ flags, count + +begin + if (flags[chan] != 0) + status = OK + else + status = ERR +end + + +procedure znotnu (chan, loffset) + +int chan +long loffset + +int flags[MAX_NULLFILES] +int count[MAX_NULLFILES] +common /znucom/ flags, count + +begin + if (flags[chan] != 0) + loffset = 0 + else + loffset = ERR +end diff --git a/sys/fio/open.x b/sys/fio/open.x new file mode 100644 index 00000000..cc540aa3 --- /dev/null +++ b/sys/fio/open.x @@ -0,0 +1,99 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# OPEN -- Open a text or binary file on the default device. If the filename +# is "dev$null" the null file driver is used. Writes to the null file are +# discarded and reads return EOF. No device is physically opened, hence +# multiple processes may write to the null file at one time. + +int procedure open (fname, mode, type) + +char fname[ARB] # virtual file name +int mode # access mode (ro,rw,apnd,newf,temp) +int type # text or binary file + +int fd +pointer sp, vfn +char url[SZ_PATHNAME], cache[SZ_PATHNAME], extn[SZ_PATHNAME] + +bool nullfile, fnullfile() +extern zopnbf(), zopntx(), zardbf(), zgettx(), zopnsf(), zardsf() +extern zopnnu(), zardnu(), zgetnu() +int filopn(), fgetfd(), nowhite(), strncmp() + +errchk syserr, fgetfd, filopn, seek + +begin + call smark (sp) + call salloc (vfn, SZ_PATHNAME, TY_CHAR) + + + # If we're given a URL to a file, cache it. + call aclrc (Memc[vfn], SZ_PATHNAME) + call strcpy ("cache$", cache, SZ_PATHNAME) + call strcpy ("", extn, SZ_PATHNAME) + + if (strncmp ("http:", fname, 5) == 0) { + call strcpy (fname, url, SZ_PATHNAME) + if (mode == NEW_FILE) + call syserr (SYS_FNOWRITEPERM) + call fcadd (cache, url, extn, Memc[vfn], SZ_PATHNAME) + + } else if (strncmp ("file:///localhost", fname, 17) == 0) { + # Handle local 'file' URIs + if (nowhite (fname[18], Memc[vfn], SZ_PATHNAME) == 0) + call syserr (SYS_FNOFNAME) + + } else if (strncmp ("file://localhost", fname, 16) == 0) { + # Handle local 'file' URIs + if (nowhite (fname[16], Memc[vfn], SZ_PATHNAME) == 0) + call syserr (SYS_FNOFNAME) + + } else if (strncmp ("file://", fname, 7) == 0) { + # Handle local 'file' URIs + if (nowhite (fname[7], Memc[vfn], SZ_PATHNAME) == 0) + call syserr (SYS_FNOFNAME) + + } else { + # Strip any whitespace at either end of the filename. + if (nowhite (fname, Memc[vfn], SZ_PATHNAME) == 0) + call syserr (SYS_FNOFNAME) + } + + # Check for the null file. + nullfile = fnullfile (Memc[vfn]) + + # Open the file. + switch (type) { + case TEXT_FILE: + if (nullfile) + fd = filopn (Memc[vfn], mode, type, zopnnu, zgetnu) + else + fd = filopn (Memc[vfn], mode, type, zopntx, zgettx) + case BINARY_FILE: + if (nullfile) + fd = filopn (Memc[vfn], mode, type, zopnnu, zardnu) + else + fd = filopn (Memc[vfn], mode, type, zopnbf, zardbf) + case STATIC_FILE: + if (nullfile) + fd = filopn (Memc[vfn], mode, type, zopnnu, zardnu) + else + fd = filopn (Memc[vfn], mode, type, zopnsf, zardsf) + case SPOOL_FILE: + if (nullfile) + fd = filopn (Memc[vfn], mode, type, zopnnu, zardnu) + else { + fd = fgetfd (Memc[vfn], mode, type) + call seek (fd, BOFL) + } + default: + call syserrs (SYS_FILLEGTYPE, Memc[vfn]) + fd = ERR + } + + call sfree (sp) + return (fd) +end diff --git a/sys/fio/osfnlock.x b/sys/fio/osfnlock.x new file mode 100644 index 00000000..213d75ac --- /dev/null +++ b/sys/fio/osfnlock.x @@ -0,0 +1,417 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +# Override the definition of ONECASE_OUT given in . This is necessary +# for networking until time permits a real fix to the filename mapping code. +# The override is necessary to prevent OSFN_PKFNAME from case-converting +# filenames destined for translation on a remote node. + +define ONECASE_OUT false + +.help file_locking +.nf ___________________________________________________________________________ +FILE LOCKING package. Lock the named OSFN for exclusive write access. +The host OS file locking facilities are used if available, otherwise null +length files are used to implement advisory locks. Read access may or may +not be excluded while a file is locked, depending on the host system. + + time = osfn_lock (osfn) + nsec = osfn_unlock (osfn, time) + nsec = osfn_timeleft (osfn, time) + osfn_initlock (osfn) + osfn_rmlock (osfn) + +A file is locked with the OSFN_LOCK primitive, which will wait or another +process to unlock the file if it is already locked. The lock is guaranteed +to remain in place for at least FILELOCK_PERIOD seconds. If the file does not +exist or cannot be locked ERROR is called. If the file is already locked but +the lock has expired osfn_lock will break the old lock and return when it has +set a new one. + +A lock is removed with OSFN_UNLOCK. The number of seconds remaining on the +lock at the time it was removed is returned as the function value; this value +should be checked to ensure that the lock was not broken due to a timeout. +ERR is returned if the file was no longer locked or had been locked by another +user when OSFN_UNLOCK was called. OSFN_RMLOCK is used to delete all lock +files (if any) when the main file is deleted. + +The primitive OSFN_TIMELEFT returns the number of seconds remaining on the +lock on file osfn. ERR is returned if the file is no longer locked or if the +file is currently locked by another user. OSFN_INITLOCK is called to create +the locking files initially, to avoid having to wait for a timeout when +placing the first lock. +.endhelp ____________________________________________________________________ + +define FILEWAIT_PERIOD 5 # wait 5 seconds for file to unlock +define MAX_DELAY 90 # recover from missing timelock1 +define setlock_ 91 + + +# OSFN_LOCK -- Lock the named OSFN, i.e., gain exclusive write access to a file. +# Only the process gaining the lock on a file may write to it, but there is no +# guarantee that another process may not read a locked file. On some systems +# the file will not actually be locked until it is opened with write permission. +# If multiple files exist in a directory with the same root but different +# extensions, only one can be locked at a time. An ERROR exit is taken if the +# file is write protected. + +long procedure osfn_lock (osfn) + +char osfn[ARB] # OS pathname of file to be locked +bool os_has_file_locking +int nsec, delay, status +long fi[LEN_FINFO] +pointer sp, lockfile, timelock1, timelock2, fname +long clktime() +data os_has_file_locking /OS_FILELOCKING/ +errchk syserrs + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + # Even if file locking is provided by the OS we must determine if the + # file does not exist or is write protected. If the file is not write + # protected but cannot be opened for writing our caller will conclude + # that the file is locked by another process. + + call zfacss (osfn, READ_WRITE, 0, status) + if (status == ERR) { + call strupk (osfn, Memc[fname], SZ_FNAME) + call syserrs (SYS_FNOWRITEPERM, Memc[fname]) + } else if (os_has_file_locking) { + call sfree (sp) + return (clktime (long(0))) + } + + call salloc (lockfile, SZ_PATHNAME, TY_CHAR) + call salloc (timelock1, SZ_PATHNAME, TY_CHAR) + call salloc (timelock2, SZ_PATHNAME, TY_CHAR) + + # Host system does not provide file locking; we must do it ourselves + # using null files as semaphores. The lock files need not exist + # when we are first called; they will be automatically generated + # when timeout occurs. + + # Generate osfn's of the lockfile and timelock files. + call osfn_mkfnames (osfn, Memc[lockfile], Memc[timelock1], + Memc[timelock2], SZ_PATHNAME) + + # The lock is set by deleteing the lockfile. Usually the file will + # be deleted on the first try, but if someone else has the file + # locked or if the lockfile is missing, we have to keep trying. + # If the lockfile cannot be deleted check that the file itself + # exists with write permission. We ASSUME that if we have write + # permission on the file we are trying to lock, we also have + # delete permission on the directory in which it is resident. + + delay = 0 + repeat { + # Try to set lock. + for (nsec=0; nsec < FILEWAIT_PERIOD; nsec=nsec+1) { + call zfdele (Memc[lockfile], status) + if (status == OK) + goto setlock_ + } + delay = delay + nsec + + # Timeout: if the lock is old, break it and try again to set + # new lock. No need to check status because if we get here we + # know osfn exists and we have write+delete perm on directory. + # N.B.: this block is subtle; see fio$doc/vfn.hlp for a detailed + # discussion of timeout and recovery from lockout. + + call zfdele (Memc[timelock1], status) + if (status == OK) { + call zfinfo (Memc[timelock2], fi, status) + if (status == ERR || clktime(FI_CTIME(fi)) >= FILELOCK_PERIOD) { + call zfmkcp (osfn, Memc[lockfile], status) + call zfdele (Memc[timelock2], status) + call zfmkcp (osfn, Memc[timelock2], status) + call zfmkcp (osfn, Memc[timelock1], status) + } else + call zfmkcp (osfn, Memc[timelock1], status) + } else if (delay >= MAX_DELAY) + call zfmkcp (osfn, Memc[timelock1], status) + } + +setlock_ + call zfdele (Memc[timelock2], status) + call zfmkcp (osfn, Memc[timelock2], status) + call zfinfo (Memc[timelock2], fi, status) + + call sfree (sp) + return (FI_CTIME(fi)) +end + + +# OSFN_TIMELEFT -- Determine if a file is still locked, and if so, how +# much time remains on the lock. TIME is the time value returned when +# the file was locked. All time values are in units of seconds. + +int procedure osfn_timeleft (osfn, time) + +char osfn[ARB] # OS pathname of file to be locked +long time # time when lock set + +bool os_has_file_locking +int time_left, status, file_exists +long fi[LEN_FINFO] +pointer sp, lockfile, timelock1, timelock2 +long clktime() +data os_has_file_locking /OS_FILELOCKING/ + +begin + if (os_has_file_locking) + return (FILELOCK_PERIOD) + + call smark (sp) + call salloc (lockfile, SZ_PATHNAME, TY_CHAR) + call salloc (timelock1, SZ_PATHNAME, TY_CHAR) + call salloc (timelock2, SZ_PATHNAME, TY_CHAR) + + call osfn_mkfnames (osfn, Memc[lockfile], Memc[timelock1], + Memc[timelock2], SZ_PATHNAME) + + # If the lockfile exists the file is no longer locked. + call zfacss (Memc[lockfile], 0, 0, file_exists) + if (file_exists == YES) { + call sfree (sp) + return (ERR) + } + + call zfinfo (Memc[timelock2], fi, status) + call sfree (sp) + + if (status == ERR) + return (ERR) + else if (FI_CTIME(fi) != time) + return (ERR) + else { + time_left = max (0, FILELOCK_PERIOD - clktime (time)) + return (time_left) + } +end + + +# OSFN_UNLOCK -- Release the lock on a file and return the number of seconds +# that were left on the lock. ERR is returned if the file is no longer locked +# or if the lock is not the one originally placed on the file. + +int procedure osfn_unlock (osfn, time) + +char osfn[ARB] # OS pathname of file to be locked +long time # time when lock set + +bool os_has_file_locking +int time_left, status +pointer sp, lockfile, timelock1, timelock2 +int osfn_timeleft() +data os_has_file_locking /OS_FILELOCKING/ + +begin + if (os_has_file_locking) + return (FILELOCK_PERIOD) + + call smark (sp) + call salloc (lockfile, SZ_PATHNAME, TY_CHAR) + call salloc (timelock1, SZ_PATHNAME, TY_CHAR) + call salloc (timelock2, SZ_PATHNAME, TY_CHAR) + + call osfn_mkfnames (osfn, Memc[lockfile], Memc[timelock1], + Memc[timelock2], SZ_PATHNAME) + + time_left = osfn_timeleft (osfn, time) + + if (time_left != ERR) + call zfmkcp (osfn, Memc[lockfile], status) + + call sfree (sp) + return (time_left) +end + + +# OSFN_RMLOCK -- Remove the locks (delete all lock files) on a file. Called +# to remove auxiliary lock files when the main file is deleted. + +procedure osfn_rmlock (osfn) + +char osfn[ARB] # OS pathname of main file +bool os_has_file_locking +int junk +pointer sp, lockfile, timelock1, timelock2 +data os_has_file_locking /OS_FILELOCKING/ + +begin + if (os_has_file_locking) + return + + call smark (sp) + call salloc (lockfile, SZ_PATHNAME, TY_CHAR) + call salloc (timelock1, SZ_PATHNAME, TY_CHAR) + call salloc (timelock2, SZ_PATHNAME, TY_CHAR) + + call osfn_mkfnames (osfn, Memc[lockfile], Memc[timelock1], + Memc[timelock2], SZ_PATHNAME) + + call zfdele (Memc[lockfile], junk) + call zfdele (Memc[timelock1], junk) + call zfdele (Memc[timelock2], junk) + + call sfree (sp) +end + + +# OSFN_INITLOCK -- Create the locking files for the named file. Should +# only be called once, generally when the file itself is created. If we +# are not called OSFN_LOCK will create the files anyhow, but only after +# timing out, which takes a while. + +procedure osfn_initlock (osfn) + +char osfn[ARB] # OS pathname of file to be locked +bool os_has_file_locking +int status +pointer sp, lockfile, timelock1, timelock2 +data os_has_file_locking /OS_FILELOCKING/ + +begin + if (os_has_file_locking) + return + + call smark (sp) + call salloc (lockfile, SZ_PATHNAME, TY_CHAR) + call salloc (timelock1, SZ_PATHNAME, TY_CHAR) + call salloc (timelock2, SZ_PATHNAME, TY_CHAR) + + call osfn_mkfnames (osfn, Memc[lockfile], Memc[timelock1], + Memc[timelock2], SZ_PATHNAME) + + call zfmkcp (osfn, Memc[lockfile], status) + call zfmkcp (osfn, Memc[timelock1], status) + call zfmkcp (osfn, Memc[timelock2], status) + + if (status == ERR) + call syserrs (SYS_FINITLOCK, osfn) + + call sfree (sp) +end + + +# OSFN_MKFNAMES -- Given the OSFN of the file to be locked, generate and +# return the names of the lockfile and the two timelock files. + +procedure osfn_mkfnames (osfn, lockfile, timelock1, timelock2, maxch) + +char osfn[ARB] # OS filename of file to be locked +char lockfile[maxch] # OSFN of locking file +char timelock1[maxch] # OSFN of the first timelock file +char timelock2[maxch] # OSFN of the second timelock file +int maxch + +char ch +int op, last_dot, max_chars +pointer sp, ip, fname + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + call strupk (osfn, Memc[fname], SZ_PATHNAME) + ip = fname + op = 1 + last_dot = 0 + + for (ch=Memc[ip]; ch != EOS; ch=Memc[ip]) { + lockfile[op] = ch + timelock1[op] = ch + timelock2[op] = ch + if (ch == '.') + last_dot = op + ip = ip + 1 + op = op + 1 + } + + if (last_dot > 0) + op = last_dot + max_chars = maxch - op + 1 + + call strcpy (LOCKFILE_EXTN, lockfile[op], max_chars) + call osfn_pkfname (lockfile, lockfile, maxch) + call strcpy (TIMELOCK1_EXTN, timelock1[op], max_chars) + call osfn_pkfname (timelock1, timelock1, maxch) + call strcpy (TIMELOCK2_EXTN, timelock2[op], max_chars) + call osfn_pkfname (timelock2, timelock2, maxch) + + call sfree (sp) +end + + +# OSFN_PKFNAME -- Convert an unpacked lower case OS filename into a true host +# OS filename. Convert to the host case if necessary and pack the string. +# Strip any backslash escapes remaining in the filename. + +procedure osfn_pkfname (spp_osfn, host_osfn, maxch) + +char spp_osfn[ARB] # unpacked, mixed or lower case OSFN +char host_osfn[maxch] # packed OSFN +int maxch + +int op, i +int ch + +begin + if (CASE_INSENSITIVE && ONECASE_OUT) { + switch (HOST_CASE) { + case 'U', 'u': + op = 1 + do i = 1, maxch { + ch = spp_osfn[i] + if (ch == EOS) + break + else if (IS_LOWER (ch)) + host_osfn[op] = TO_UPPER (ch) + else if (ch == '\\') + op = op - 1 + else + host_osfn[op] = ch + op = op + 1 + } + default: + op = 1 + do i = 1, maxch { + ch = spp_osfn[i] + if (ch == EOS) + break + else if (IS_UPPER (ch)) + host_osfn[op] = TO_LOWER (ch) + else if (ch == '\\') + op = op - 1 + else + host_osfn[op] = ch + op = op + 1 + } + } + + } else { + op = 1 + do i = 1, maxch { + ch = spp_osfn[i] + if (ch == EOS) + break + else if (ch == '\\') + op = op - 1 + else + host_osfn[op] = ch + op = op + 1 + } + } + + host_osfn[op] = EOS + call strpak (host_osfn, host_osfn, maxch) +end diff --git a/sys/fio/poll.x b/sys/fio/poll.x new file mode 100644 index 00000000..22e2bd14 --- /dev/null +++ b/sys/fio/poll.x @@ -0,0 +1,250 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + + +.help poll +.nf ___________________________________________________________________________ +POLL -- FIO descriptor polling interface. See for a definition of +the interface data structures and flags, this file is required to be included +by source files using this interface. + + fds = poll_open () # open a poll descriptor set + npolls = poll (fds, nfds, timeout) # poll the set + poll_close (fds) # free the poll descriptor set + + poll_zero (fds) # zero the poll array + poll_set (fds, fd, type) # set fd to poll for type + poll_clear (fds, fd, type) # unset type on fd poll + y/n = poll_test (fds, fd, type) # test fd for type event + N = poll_get_nfds (fds) # get size of descriptor set + +The polling interface provides the same functionality as the unix function +of the same name with a few implementation differences. The poll_open() +procedure is used to allocate a dynamic structure containing the descriptors +to be polled, poll_close() is used when done to free that structure. + The poll_zero(), poll_set(), and poll_clear() utility functions are +used to manipulate the descriptor set by zeroing the entire set, or adding or +removing a descriptor check for the specified polling type. Polling types +include POLLIN (fd is readable), POLLOUT (fd is writeable & won't block), or +POLLPRI (priority info at fd). The poll_test() function can be used to test +for these types folling the return of poll(). Additionally, a descriptor may +be checked for POLLERR (fd has error condition), POLLHUP (fd has been hung up +on), POLLNVAL (invalid pollfd entry). Descriptors may be checked for more +than one testable event. + Once the descriptor set has been created, the poll() function can be +called to check for activity on the set. A negative timeout value will cause +the function to block indefinitely, otherwise it represents a wait time given +in milliseconds. The poll() function will return a negative number if an +error is encountered, zero if the call times out and no file descriptors have +been selected, or a positive number indicating the number of descriptors +which can be serviced without blocking. +.endhelp ______________________________________________________________________ + + +# POLL_OPEN -- Open a poll descriptor set. + +pointer procedure poll_open () + +pointer fds + +begin + iferr (call calloc (fds, LEN_FPOLL, TY_STRUCT)) + call syserr (SYS_MFULL) + + return (fds) +end + + +# POLL -- Poll the descriptor set. + +int procedure poll (fds, nfds, timeout) + +pointer fds +int nfds +int timeout + +int pfds[LEN_FPOLL] +int i, j, npoll, status + +include + +begin + # Transform the descriptor set to a linear array. + j = 0 + for (i=1; j < nfds; i=i+3) { + pfds[i ] = FCHAN(fiodes[POLL_FD(fds,j)]) + pfds[i+1] = POLL_EVENTS(fds,j) + pfds[i+2] = POLL_REVENTS(fds,j) + j = j + 1 + } + + # Call the kernel routine to poll on the descriptor set. + call zfpoll (pfds, nfds, timeout, npoll, status) + if (status == ERR) + return (ERR) + + j = 0 + for (i=3; j < nfds; i=i+3) { + POLL_REVENTS(fds,j) = pfds[i] + j = j + 1 + } + + return (npoll) +end + + +# POLL_CLOSE -- Close and free a poll descriptor set. + +procedure poll_close (fds) + +pointer fds #i descriptor set pointer + +begin + call mfree (fds, TY_STRUCT) +end + + +# POLL_ZERO -- Zero the descriptor set. + +procedure poll_zero (fds) + +pointer fds #i descriptor set pointer + +begin + call aclri (Memi[fds], LEN_FPOLL) +end + + +# POLL_SET -- Add a descriptor to the set, and/or modify the event type. +# The type may be a bitwise or of testable events. + +procedure poll_set (fds, fd, type) + +pointer fds #i descriptor set pointer +int fd #i file descriptor +int type #i event type + +int i, top +int ori() + +begin + top = POLL_NFD(fds) + if (top > MAX_POLL_FD) + call eprintf ("File descriptor set overflow.\n") + + for (i=0; i < top; i=i+1) { + # Search for requested descriptor and OR the type on the event mask. + if (fd == POLL_FD(fds,i)) { + POLL_EVENTS(fds,i) = ori (POLL_EVENTS(fds,i), type) + return + } + } + + # Descriptor not found, add it to the set at the top + POLL_FD(fds,top) = fd + POLL_EVENTS(fds,top) = ori (POLL_EVENTS(fds,top), type) + POLL_NFD(fds) = top + 1 +end + + +# POLL_GET_NFDS -- Get the number of descriptors in the set. + +int procedure poll_get_nfds (fds) + +pointer fds #i descriptor set pointer + +begin + return (POLL_NFD(fds)) +end + + +# POLL_CLEAR -- Remove a descriptor or event type from the set. The type +# may be a bitwise or of testable events. If the event mask becomes NULL +# the descriptor is removed entirely from the set. + +procedure poll_clear (fds, fd, type) + +pointer fds #i descriptor set pointer +int fd #i file descriptor +int type #i event type + +int i, j, top +int noti(), andi() + +begin + top = POLL_NFD(fds) + + for (i=0; i < top; i=i+1) { + # Search for requested descriptor. + if (fd == POLL_FD(fds,i)) { + POLL_EVENTS(fds,i) = andi (noti(type), POLL_EVENTS(fds,i)) + + # If there are no events, remove the descriptor from the set + # by deleting it from the array and shifting the remainder. + if (POLL_EVENTS(fds,i) == 0) { + for (j=i+1; i < top; j=j+1) { + POLL_FD(fds,i) = POLL_FD(fds,j) + POLL_EVENTS(fds,i) = POLL_EVENTS(fds,j) + i = i + 1 + } + POLL_NFD(fds) = top - 1 + break + } + } + } +end + + +# POLL_TEST -- Test the descriptor for the given event type. + +int procedure poll_test (fds, fd, type) + +pointer fds #i descriptor set pointer +int fd #i file descriptor +int type #i event type + +int i, top +int andi() + +begin + top = POLL_NFD(fds) + + for (i=0; i < top; i=i+1) { + # Search for requested descriptor. + if (fd == POLL_FD(fds,i)) { + # OR the type on the event mask. + if (andi (POLL_REVENTS(fds,i), type) > 0) + return (YES) + else + return (NO) + } + } + + return (NO) +end + + +# POLL_PRINT -- Print the descriptor set (debug utility). + +procedure poll_print (fds) + +pointer fds #i descriptor set pointer + +int i, top + +begin + top = POLL_NFD(fds) + + for (i=0; i < top; i=i+1) { + call eprintf ("%2d: fd=%3d events=%6d revents=%6d\n") + call pargi(i) + call pargi(POLL_FD(fds,i)) + call pargi(POLL_EVENTS(fds,i)) + call pargi(POLL_REVENTS(fds,i)) + } +end diff --git a/sys/fio/protect.x b/sys/fio/protect.x new file mode 100644 index 00000000..64434638 --- /dev/null +++ b/sys/fio/protect.x @@ -0,0 +1,61 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +# PROTECT -- Protect a file from deletion. The recognized action codes are +# defined in and are used to set, remove, or query file +# protection. + +int procedure protect (fname, action) + +char fname[ARB] # file name +int action # protect action (prot, unprot, query) + +bool fnullfile() +int status, access() +errchk filerr, fmapfn +include + +begin + # The null file "dev$null" is a special case; ignore attempts to + # alter the protection of this file. + + if (fnullfile (fname)) + if (action == QUERY_PROTECTION) + return (YES) + else + return (OK) + + call fmapfn (fname, pathname, SZ_PATHNAME) + call zfprot (pathname, action, status) + + if (status == ERR) { + if (access (fname,0,0) == YES) { + switch (action) { + case SET_PROTECTION: + call filerr (fname, SYS_FPROTECT) + case REMOVE_PROTECTION: + call filerr (fname, SYS_FUNPROTECT) + default: + # If the file exists but we cannot query its protection, + # better to indicate that it is protected than to abort. + return (YES) + } + } else if (access (fname, 0, DIRECTORY_FILE) == YES) { + switch (action) { + case SET_PROTECTION: + return (OK) # directory files are protected + case REMOVE_PROTECTION: + call filerr (fname, SYS_FUNPROTECT) + default: + return (YES) + } + } else + call filerr (fname, SYS_FPROTNEXFIL) + } else + return (status) +end diff --git a/sys/fio/putc.x b/sys/fio/putc.x new file mode 100644 index 00000000..3021347d --- /dev/null +++ b/sys/fio/putc.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PUTC -- Put a character to a file. + +procedure putc (fd, ch) + +int fd # output file +char ch # character to be output + +int and() +errchk flsbuf +include + +begin + if (iop[fd] < bufptr[fd] || iop[fd] >= otop[fd]) + call flsbuf (fd, 0) + + Memc[iop[fd]] = ch + iop[fd] = iop[fd] + 1 + + if (ch == '\n') # end of line of text? + if (and (FF_FLUSH, fflags[fd]) != 0) + call flsbuf (fd, 0) +end + + +# PUTCHAR -- Put a character to the standard output. + +procedure putchar (ch) + +char ch # character to be output + +begin + call putc (STDOUT, ch) +end diff --git a/sys/fio/putcc.x b/sys/fio/putcc.x new file mode 100644 index 00000000..ac96f50e --- /dev/null +++ b/sys/fio/putcc.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +define SZ_CCSTR 5 + +# PUTCC -- Put a character to a file. This procedure is identical to PUTC, +# except that nonprintable characters are rendered as escape sequences. + +procedure putcc (fd, ch) + +int fd +char ch +char ccstr[SZ_CCSTR] +int ip, n, ctocc() + +begin + if (IS_PRINT (ch)) + call putc (fd, ch) + else { + n = ctocc (ch, ccstr, SZ_CCSTR) + do ip = 1, n + call putc (fd, ccstr[ip]) + } +end diff --git a/sys/fio/putci.x b/sys/fio/putci.x new file mode 100644 index 00000000..eeedb30e --- /dev/null +++ b/sys/fio/putci.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PUTCI -- Put a character constant (passed as an integer) to a file. + +procedure putci (fd, ch) + +int fd # output file +int ch # character to be output +int and() +errchk flsbuf +include + +begin + if (iop[fd] < bufptr[fd] || iop[fd] >= otop[fd]) + call flsbuf (fd, 0) + + Memc[iop[fd]] = ch + iop[fd] = iop[fd] + 1 + + if (ch == '\n') # end of line of text? + if (and (FF_FLUSH, fflags[fd]) != 0) + call flsbuf (fd, 0) +end diff --git a/sys/fio/putline.x b/sys/fio/putline.x new file mode 100644 index 00000000..bc69da66 --- /dev/null +++ b/sys/fio/putline.x @@ -0,0 +1,101 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# PUTLINE -- Put a line or part of a line of text to a file. May be called +# several times to build up a line of text. FLUSHNL should always be set +# for text files (when the file is opened) to avoid flushing partial lines +# to text files. This is a major output procedure hence the code has been +# carefully optimized to do as much as possible in loops. + +procedure putline (fd, linebuf) + +int fd # output file +char linebuf[ARB] # line to be output + +int ch, ip, ip_top, i +pointer op, op_top +int and() +errchk syserr, flsbuf +include +define done_ 91 + +begin + if (fd <= 0 || fiodes[fd] == NULL) + call syserr (SYS_FILENOTOPEN) + + # Copy the i/o pointers into local storage for more efficient access. + op = iop[fd] + op_top = otop[fd] + + # Check for a file fault. + if (op < bufptr[fd] || op > op_top) { + call flsbuf (fd, 0) + op = iop[fd] + op_top = otop[fd] + } + + # Copy all characters until EOS is seen. Flush the buffer if it fills + # or if newline is seen and FF_FLUSH is set for the stream. + + if (and (fflags[fd], FF_FLUSH) == 0) { + # Flush on newline is disabled. A special loop is used for this + # case to eliminate the need to compare every character against + # newline. + + for (ip=1; linebuf[ip] != EOS; ip=ip_top+1) { + # A do loop is used here to trigger Fortran optimization. Note + # that FLSBUF must not be called from within the loop or loop + # optimization will be turned off by most compilers. + + ip_top = ip + (op_top-op) - 1 + do i = ip, ip_top { + Memc[op] = linebuf[i] + op = op + 1 + if (linebuf[i+1] == EOS) + goto done_ + } + + # If we reach here then the buffer is full and needs to be + # flushed. + + iop[fd] = op + call flsbuf (fd, 0) + op = iop[fd] + op_top = otop[fd] + } + + } else { + # This section of code is used when it is necessary to check for + # newline and flush after every line of text. + + for (ip=1; linebuf[ip] != EOS; ip=ip_top+1) { + ip_top = ip + (op_top-op) - 1 + do i = ip, ip_top { + ch = linebuf[i] + Memc[op] = ch + op = op + 1 + if (ch == '\n') { + ip_top = i + break + } + if (linebuf[i+1] == EOS) + goto done_ + } + + # If we get here then either newline has been seen or the output + # buffer is full. In either case the buffer must be flushed. + + iop[fd] = op + call flsbuf (fd, 0) + op = iop[fd] + op_top = otop[fd] + } + } +done_ + iop[fd] = op + FNCHARS(fiodes[fd]) = ip - 1 +end diff --git a/sys/fio/read.x b/sys/fio/read.x new file mode 100644 index 00000000..69e71ba7 --- /dev/null +++ b/sys/fio/read.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# READ -- Read binary chars from a file. Data is read in "chunks" from +# the file buffer into the output buffer supplied by the calling procedure, +# refilling the file buffer as necessary. The read terminates, possibly +# returning fewer than the maximum number of chars, if the file buffer +# cannot be filled (as occurs at the EOF of a binary file, or when reading +# from a terminal or pipe). + +int procedure read (fd, buffer, maxchars) + +int fd +char buffer[ARB] +int maxchars + +int maxch +bool stream +int nchars, chunk_size, nchars_read, filbuf() +errchk filbuf, filerr +include + +begin + if (fd <= 0 || fiodes[fd] == NULL) + call syserr (SYS_FILENOTOPEN) + + nchars = 0 + maxch = maxchars + stream = (FBLKSIZE(fiodes[fd]) == 0) + + while (nchars < maxch) { + if (iop[fd] < bufptr[fd] || iop[fd] >= itop[fd]) { + nchars_read = filbuf (fd) + if (nchars_read == EOF) + break # return EOF only if nchars = 0 + else { + # Don't loop if record structured device or EOF. + if (itop[fd] < buftop[fd] || stream) + maxch = min (maxchars, nchars + nchars_read) + } + } + chunk_size = min (maxch - nchars, itop[fd] - iop[fd]) + if (chunk_size <= 0) + break + else { + call amovc (Memc[iop[fd]], buffer[nchars+1], chunk_size) + iop[fd] = iop[fd] + chunk_size + nchars = nchars + chunk_size + } + } + + FILSTAT(fiodes[fd]) = nchars + FNCHARS(fiodes[fd]) = nchars + + if (nchars == 0) + return (EOF) + else + return (nchars) +end diff --git a/sys/fio/rename.x b/sys/fio/rename.x new file mode 100644 index 00000000..c52c28bf --- /dev/null +++ b/sys/fio/rename.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# RENAME -- Rename a file. First try to rename the file using the ZFRNAM +# kernel primitive, accessed by FRENAME. If that fails try to copy the +# file and delete the original. + +procedure rename (oldname, newname) + +char oldname[ARB] # old filename +char newname[ARB] # new filename + +int junk, protect() +errchk fcopy, protect + +begin + # Try a simple file rename first. + ifnoerr (call frename (oldname, newname)) + return + + # That failed, so copy the file to the new name. + call fcopy (oldname, newname) + + # Now delete the original. Transfer file protection to the new file, + # if the old file was protected. + + if (protect (oldname, QUERY_PROTECTION) == YES) { + iferr (junk = protect (oldname, REMOVE_PROTECTION)) { + call delete (newname) + call erract (EA_ERROR) + } + call delete (oldname) + junk = protect (newname, SET_PROTECTION) + } else + call delete (oldname) +end diff --git a/sys/fio/reopen.x b/sys/fio/reopen.x new file mode 100644 index 00000000..59ddba30 --- /dev/null +++ b/sys/fio/reopen.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# REOPEN -- Reopen a binary file. Used to gain two or more independent +# sets of buffers to access a binary file. No protection against two +# file descriptors trying to write to the same part of the file at the +# same time, which may result in loss of data. The file descriptors and +# buffers of reopened files are independent, but all files accessing the +# same channel share the same channel descriptor (necessary to synchronize +# i/o requests and to maintain a unique file size parameter). + +int procedure reopen (fd, mode) + +int fd, mode +pointer newfp, ffp +int newfd, fgetfd() +errchk syserr, malloc, seek +include + +begin + ffp = fiodes[fd] + if (fd <= 0 || ffp == NULL) + call syserr (SYS_FILENOTOPEN) + + if (FMODE(ffp) == READ_ONLY && mode != READ_ONLY) + call filerr (FNAME(ffp), SYS_FREOPNMODE) + if (FTYPE(ffp) != BINARY_FILE) + call filerr (FNAME(ffp), SYS_FREOPNTYPE) + + newfd = fgetfd (FNAME(ffp), mode, BINARY_FILE) + newfp = fiodes[newfd] + + FDEV(newfp) = FDEV(ffp) + FBUFSIZE(newfp) = FBUFSIZE(ffp) + FCHAN(newfp) = FCHAN(ffp) + + # If this is the first reopen, allocate space for a separate channel + # descriptor and copy the channel descriptor from the original file. + + if (FCD(ffp) == FLCD(ffp)) { + call malloc (FCD(ffp), LEN_CHANDES, TY_STRUCT) + call amovi (Memi[FLCD(ffp)], Memi[FCD(ffp)], LEN_CHANDES) + } + + FREFCNT(ffp) = FREFCNT(ffp) + 1 # bump ref count + FCD(newfp) = FCD(ffp) + + if (mode == APPEND) + call seek (newfd, EOFL) + + return (newfd) +end diff --git a/sys/fio/seek.x b/sys/fio/seek.x new file mode 100644 index 00000000..73440a3c --- /dev/null +++ b/sys/fio/seek.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# SEEK -- Position the i/o pointer (file offset at which the next i/o transfer +# will occur) for a file. Note that ITOP may have to be adjusted before +# performing the seek, to make newly written data readable (as when writing at +# EOF, seeking backward within the same buffer, and reading). A physical seek +# is performed for text files. For binary files, a logical seek is performed, +# adjusting the i/o pointer. Physical seeks on binary files are initiated +# by FFAULT, when filling or flushing a file buffer. + +procedure seek (fd, offset) + +int fd # file +long offset # offset == BOF,EOF, or char offset + +pointer bp +long file_offset +int status +long ffilsz() +errchk filerr, syserr, ffilsz +include + +begin + fp = fiodes[fd] + if (fd <= 0 || fp == NULL) + call syserr (SYS_FILENOTOPEN) + + call fcanpb (fd) # cancel any pushback + UPDATE_IOP(fd) # make newly written data readable + + if (FTYPE(fp) == TEXT_FILE) { + # General seeks only permitted on text files opened for reading. + if (FMODE(fp) != READ_ONLY) + if (offset != BOF && offset != EOF) + call filerr (FNAME(fp), SYS_FSEEKNTXF) + + bp = bufptr[fd] + if (BUF_MODIFIED(fd)) { # flush buffer? + call fputtx (fd, Memc[bp], otop[fd] - bp, status) + if (status != ERR) + call zcall2 (ZFLSTX(fp), FCHAN(fp), status) + if (status == ERR) + call filerr (FNAME(fp), SYS_FWRITE) + } + + iop[fd] = bp + itop[fd] = bp + otop[fd] = bp + + call zcall3 (ZSEKTX(fp), FCHAN(fp), offset, status) + if (status == ERR) + call filerr (FNAME(fp), SYS_FSEEK) + + } else { # logical seek (binary files) + switch (offset) { + case BOF: + file_offset = 1 + case EOF: + file_offset = ffilsz (fd) + 1 + default: + file_offset = offset + } + iop[fd] = file_offset - boffset[fd] + bufptr[fd] + } +end diff --git a/sys/fio/stropen.x b/sys/fio/stropen.x new file mode 100644 index 00000000..ac3c8068 --- /dev/null +++ b/sys/fio/stropen.x @@ -0,0 +1,151 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# STROPEN, STRCLOSE -- Open/close a character string for file i/o. Called by +# sprintf (for example) to make the output string look like a file. +# +# The string is made to appear to be the file buffer. It is a fatal error +# if the string is not char aligned with Mem. If the output string should +# overflow, FIO will call FLSBUF, resulting in a system error action. STROPEN, +# for efficiency reasons, does not really open a file, it merely validates the +# buffer pointers and reserves a file descriptor. Note that the buffer +# pointers may be negative. Seeks are illegal on a string file, and will +# cause an error action to be taken. +# +# If alignment is not automatically guaranteed for char data on your machine, +# define "stropen" as "memopen($1,$2,$3,TEXT_FILE)", and "strclose" as "close", +# in (or install a dummy procedure in the library). + +int procedure stropen (str, maxch, mode) + +char str[ARB] #I string buffer for i/o +int maxch #I capacity of buffer +int mode #I FIO access mode + +pointer bp +int fd, ip, loc_str, loc_Mem +errchk syserr +include + +begin + # Find an unused file descriptor. + for (fd=FIRST_FD; fd <= LAST_FD && fiodes[fd] != NULL; fd=fd+1) + ; + if (fd > LAST_FD) + call syserr (SYS_FTOOMANYFILES) + + # Compute pointer (Memc index) to the string. + call zlocva (str, loc_str) + call zlocva (Memc, loc_Mem) + bp = loc_str - loc_Mem + 1 + + # Get file descriptor and init the buffer pointers. + call fstrfp (fiodes[fd]) + call strsetmode (fd, mode) + bufptr[fd] = bp + buftop[fd] = bp + maxch + fflags[fd] = 0 + + # If string is being opened in any of the following modes, it + # must be an initialized (written into) string with an EOS. + # Find EOS and set itop accordingly. + + if (mode == READ_ONLY || mode == READ_WRITE || mode == APPEND) + for (ip=1; str[ip] != EOS && ip <= maxch; ip=ip+1) + ; + + # Seeks are illegal on strings. Modes RO and RW are equivalent, as + # are WO, NF, and TF. Append is like WO/NF/TF, but the i/o pointer is + # positioned at the EOS. An EOS will automatically be written when + # a file opened with mode WO, NF, TF, or AP is closed. + + iop[fd] = bp + itop[fd] = bp + otop[fd] = bp + maxch + + switch (mode) { + case READ_ONLY, READ_WRITE: + itop[fd] = bp + ip - 1 + otop[fd] = bp + case APPEND: + iop[fd] = bp + ip - 1 + } + + return (fd) +end + + +# STRCLOSE -- Close a string file previously opened by STROPEN. If writing +# to a new string, append an EOS to the end of the string. This routine is +# automatically called by CLOSE if the string was opened as a file with +# STROPEN. Applications should call CLOSE, instead of calling STRCLOSE +# directly, to ensure that the file descriptor allocated by STROPEN and FIO +# is fully closed. + +procedure strclose (fd) + +int fd #I file descriptor +int strgetmode() +errchk syserr +include + +begin + if (fd < 0 || fiodes[fd] == NULL) + call syserr (SYS_FILENOTOPEN) + + # Free any file pushback. + call mfree (FPBBUF(fiodes[fd]), TY_CHAR) + + # If string was opened for writing, append EOS. NOTE that if the + # string was opened with length N, the EOS will go into location N+1 + # if the string is completely full. + + switch (strgetmode(fd)) { + case WRITE_ONLY, APPEND, NEW_FILE, TEMP_FILE: + Memc[iop[fd]] = EOS + default: + ; + } + + # Free the file descriptor. + bufptr[fd] = NULL + fiodes[fd] = NULL +end + + +# STRSETMODE -- Set the access mode for a string file. This is an internal +# routine normally called only by STROPEN above. It may also called during +# task termination and cleanup to change the string file access mode to avoid +# an attempt to EOS terminate the string buffer, before closing off any still +# open string files + +procedure strsetmode (fd, mode) + +int fd #I file descriptor +int mode #I file access mode +include + +begin + # For a string file the access mode is arbitrarily saved in BOFFSET + # for CLOSE (strclose), which needs to know the access mode in order + # to append an EOS. BOFFSET is not otherwise used for string files + # since the string buffer has no associated file offset. + + boffset[fd] = mode +end + + +# STRGETMODE -- Get the access mode for a string file. This is an internal +# routine normally called only by STRCLOSE. + +int procedure strgetmode (fd) + +int fd #I file descriptor +include + +begin + return (boffset[fd]) +end diff --git a/sys/fio/ungetc.x b/sys/fio/ungetc.x new file mode 100644 index 00000000..89f31c10 --- /dev/null +++ b/sys/fio/ungetc.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# UNGETC -- Push a character back into the input stream. Pushback is last +# in first out, i.e., the last character pushed will be the first character +# returned in the next getc, getline, or read. Multiple characters and +# strings may be pushed back into the input until the push back buffer +# overflows. Overflow is often an indication of recursion in whatever +# routine is doing the pushback. +# +# Single character pushback is fairly expensive, but the i/o system is +# very efficient for even character at a time input and is optimized with +# that in mind. The overhead for pushing back an entire string is about +# the same as for a single character, so recursive macro expansion may be +# implemented quite efficiently with this pushback technique. + +procedure ungetc (fd, ch) + +int fd # file +char ch # char to be pushed back +pointer pb_sp, pb_iop +int or() +include + +begin + fp = fiodes[fd] + if (fd <= 0 || fp == NULL) + call syserr (SYS_FILENOTOPEN) + + if (FPBBUF(fp) == NULL) + call fmkpbbuf (fd) + + # Push the old pb_iop, iop, itop and bufptr on the stack. Note bufptr + # must be set to a value less than or equal to iop to avoid a buffer + # fault. + + pb_iop = FPBIOP(fp) + pb_sp = FPBSP(fp) - 1 + + Memi[pb_sp] = pb_iop + pb_sp = pb_sp - 1 + Memi[pb_sp] = bufptr[fd] + pb_sp = pb_sp - 1 + Memi[pb_sp] = itop[fd] + pb_sp = pb_sp - 1 + Memi[pb_sp] = iop[fd] + + # Deposit the char in the pbbuf and set up i/o pointers. When iop + # reaches itop filbuf will pop the old input pointers off the pbstack. + # Note: pushed back data grows upward, while the pb stack grows + # downward. + + Memc[pb_iop] = ch + bufptr[fd] = pb_iop + iop[fd] = pb_iop + pb_iop = pb_iop + 1 + itop[fd] = pb_iop + + # Check for overflow. + if (pb_iop >= (pb_sp - 1) * SZ_INT + 1) + call syserrs (SYS_FPBOVFL, FNAME(fp)) + + FPBSP(fp) = pb_sp + FPBIOP(fp) = pb_iop + fflags[fd] = or (fflags[fd], FF_PUSHBACK) +end diff --git a/sys/fio/ungetci.x b/sys/fio/ungetci.x new file mode 100644 index 00000000..9a8283a3 --- /dev/null +++ b/sys/fio/ungetci.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# UNGETCI -- Push a character back into the input stream. Pushback is last +# in first out, i.e., the last character pushed will be the first character +# returned in the next getc, getline, or read. Multiple characters and +# strings may be pushed back into the input until the push back buffer +# overflows. Overflow is often an indication of recursion in whatever +# routine is doing the pushback. +# +# Single character pushback is fairly expensive, but the i/o system is +# very efficient for even character at a time input and is optimized with +# that in mind. The overhead for pushing back an entire string is about +# the same as for a single character, so recursive macro expansion may be +# implemented quite efficiently with this pushback technique. + +procedure ungetci (fd, ch) + +int fd # file +int ch # char to be pushed back +pointer pb_sp, pb_iop +int or() +include + +begin + fp = fiodes[fd] + if (fd <= 0 || fp == NULL) + call syserr (SYS_FILENOTOPEN) + + if (FPBBUF(fp) == NULL) + call fmkpbbuf (fd) + + # Push the old pb_iop, iop, itop and bufptr on the stack. Note bufptr + # must be set to a value less than or equal to iop to avoid a buffer + # fault. + + pb_iop = FPBIOP(fp) + pb_sp = FPBSP(fp) - 1 + + Memi[pb_sp] = pb_iop + pb_sp = pb_sp - 1 + Memi[pb_sp] = bufptr[fd] + pb_sp = pb_sp - 1 + Memi[pb_sp] = itop[fd] + pb_sp = pb_sp - 1 + Memi[pb_sp] = iop[fd] + + # Deposit the char in the pbbuf and set up i/o pointers. When iop + # reaches itop filbuf will pop the old input pointers off the pbstack. + # Note: pushed back data grows upward, while the pb stack grows + # downward. + + Memc[pb_iop] = ch + bufptr[fd] = pb_iop + iop[fd] = pb_iop + pb_iop = pb_iop + 1 + itop[fd] = pb_iop + + # Check for overflow. + if (pb_iop >= (pb_sp - 1) * SZ_INT + 1) + call syserrs (SYS_FPBOVFL, FNAME(fp)) + + FPBSP(fp) = pb_sp + FPBIOP(fp) = pb_iop + fflags[fd] = or (fflags[fd], FF_PUSHBACK) +end diff --git a/sys/fio/ungetline.x b/sys/fio/ungetline.x new file mode 100644 index 00000000..b93717ef --- /dev/null +++ b/sys/fio/ungetline.x @@ -0,0 +1,75 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# UNGETLINE -- Push an EOS delimited string back into the input stream. +# The next getc will return the first char of the pushed back string, +# followed by successive chars in the string until EOS is reached, at which +# time input reverts to wherever it was before pushback. Pushback is last +# in first out, i.e., the last string pushed will be the first string scanned +# when reading. Multiple characters and strings may be pushed back into the +# input until the push back buffer overflows. Overflow is often an indication +# of recursion in whatever routine is doing the pushback. +# +# N.B.: this routine really pushes a string, not a line, i.e. we don't give +# a whiz about newline characters. + +procedure ungetline (fd, str) + +int fd # file +char str[ARB] # string to be pushed back + +int or() +pointer ip, pb_iop, pb_sp, iop_limit +errchk syserr, syserrs, fmkpbbuf +include + +begin + fp = fiodes[fd] + if (fd <= 0 || fp == NULL) + call syserr (SYS_FILENOTOPEN) + + if (str[1] == EOS) + return + if (FPBBUF(fp) == NULL) + call fmkpbbuf (fd) + + # Push the old pb_iop, iop, itop and bufptr on the stack for later + # restoration of the interrupted input stream by filbuf. Note bufptr + # must be changed to point to a value less than iop to avoid a buffer + # fault. + + pb_sp = FPBSP(fp) - 1 + pb_iop = FPBIOP(fp) + + Memi[pb_sp] = pb_iop + pb_sp = pb_sp - 1 + Memi[pb_sp] = bufptr[fd] + pb_sp = pb_sp - 1 + Memi[pb_sp] = itop[fd] + pb_sp = pb_sp - 1 + Memi[pb_sp] = iop[fd] + + # Copy the string into the buffer; abort if the buffer overflows. + # Set iop to point to first char of string. Note: pushed back chars + # grow upward while the stacked i/o pointers grow downward. + + bufptr[fd] = pb_iop + iop[fd] = pb_iop + iop_limit = (pb_sp - 1) * SZ_INT + 1 + + for (ip=1; str[ip] != EOS; ip=ip+1) { + if (pb_iop >= iop_limit) + call syserrs (SYS_FPBOVFL, FNAME(fp)) + Memc[pb_iop] = str[ip] + pb_iop = pb_iop + 1 + } + + itop[fd] = pb_iop + + FPBSP(fp) = pb_sp + FPBIOP(fp) = pb_iop + fflags[fd] = or (fflags[fd], FF_PUSHBACK) +end diff --git a/sys/fio/unread.x b/sys/fio/unread.x new file mode 100644 index 00000000..1319e6b1 --- /dev/null +++ b/sys/fio/unread.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# UNREAD -- Push a binary block of data back into the input stream. Pushback +# is last in first out, i.e., the pushed back data will be read before input +# resumes at the point at which it was interrupted. Multiple blocks of data +# may be pushed back into the input until the push back buffer overflows. +# Overflow is often an indication of recursion in whatever routine is doing +# the pushback. + +procedure unread (fd, buf, nchars) + +int fd # file +char buf[ARB] # data block to be pushed back +int nchars # nchars to push back + +int or() +pointer pb_iop, pb_sp +errchk syserr, syserrs, fmkpbbuf +include + +begin + fp = fiodes (fd) + if (fd <= 0 || fp == NULL) + call syserr (SYS_FILENOTOPEN) + + if (FPBBUF(fp) == NULL) + call fmkpbbuf (fd) + + # Push the old pb_iop, iop, itop and bufptr on the stack for later + # restoration of the interrupted input stream by filbuf. Note bufptr + # must be set to <= iop to avoid a buffer fault. + + pb_sp = FPBSP(fp) - 1 + pb_iop = FPBIOP(fp) + + Memi[pb_sp] = pb_iop + pb_sp = pb_sp - 1 + Memi[pb_sp] = bufptr[fd] + pb_sp = pb_sp - 1 + Memi[pb_sp] = itop[fd] + pb_sp = pb_sp - 1 + Memi[pb_sp] = iop[fd] + + # Check that room remains for the data. + if (((pb_sp - 1) * SZ_INT + 1) - pb_iop < nchars) + call syserrs (SYS_FPBOVFL, FNAME(fp)) + + # Move the data block into the buffer. Set the iop to point to the + # first char of the block. Note: data grows upwards while the stack + # grows downward. + + bufptr[fd] = pb_iop + iop[fd] = pb_iop + call amovc (buf, Memc[pb_iop], nchars) + pb_iop = pb_iop + nchars + itop[fd] = pb_iop + + FPBSP(fp) = pb_sp + FPBIOP(fp) = pb_iop + fflags[fd] = or (fflags[fd], FF_PUSHBACK) +end diff --git a/sys/fio/vfnmap.x b/sys/fio/vfnmap.x new file mode 100644 index 00000000..6eff8b2e --- /dev/null +++ b/sys/fio/vfnmap.x @@ -0,0 +1,899 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include + +.help vfnmap +.nf ___________________________________________________________________________ +VFNMAP -- A package for mapping virtual filenames to and from OS filenames. +The abstract datatype dealt with here is the VFN. The operations defined for +a VFN are [1] map to OSFN, [2] add a new VFN to the VFN database, and [3] delete +a VFN from the VFN database. The VFN database is manipulated only by this +package. This is an internal package, not a user package -- the semantics of +locking parts of the VFN database are delicate. + +A VFN must be opened separately for each file to be accessed, except when +reading a directory in which case the vfnmap must be opened separately for +each directory to be scanned. Only a single VFN may be opened for writing by +a process at any one time (any number of VFN's, including directories, may be +opened for reading at any one time). The mapping file is not physically opened +unless the escape sequence encoded filename is degenerate. The mapping file is +locked only if the vfn is degenerate and the access mode is VFN_WRITE. The +recognized vfn access modes are VFN_READ, VFN_WRITE, and VFN_UNMAP (for reading +directories). + +It is intended that THE VFN WILL BE OPENED FOR ONLY A BRIEF PERIOD OF TIME TO +MINIMIZE THE AMOUNT OF TIME THAT THE MAPPING FILE IS LOCKED. Furthermore, +while the VFN is locked we must avoid any operations that involve waiting for +system resources and hence introduce the possibility of deadlock. + + vp = vfnopen (vfn, mode) + vfnclose (vp, update) + stat = vfnmap (vp, osfn, maxch) + stat = vfnadd (vp, osfn, maxch) + stat = vfndel (vp, osfn, maxch) + stat = vfnunmap (vp, osfn, vfn, maxch) + + fmapfn (vfn, osfn, maxch) [=:vfnopen/RO,vfnmap,vfnclose] + +A distinction is made between mapping the filename and opening and closing +the vfn to permit efficient and secure error recovery. The mapping file is +not updated on disk until the physical file operation (create, delete, etc) +has succeeded. If the operation fails vfnclose is called with VFN_NOUPDATE +and the mapping file is not touched. If the vfn was opened VFN_READ the +update flag is ignored. No vfn disk data structures will be modified if a +vfn is closed with VFN_NOUPDATE set. If updating is enabled, ".zmd" dependency +files may be created or deleted, the mapping file may be created, deleted, +or updated. + +The VFNMAP, VFNADD, VFNDEL, and VFNUNMAP procedures all perform a mapping +operation, returning OK if the filename could be mapped and ERR if the +mapping fails and no OSFN or VFN is returned. A VFNMAP, VFNADD, or VFNDEL +mapping can only return ERR if the VFN is degenerate and either no entry +was found in the mapping file (VFNMAP, VFNDEL) or there already was an entry +(VFNADD). OSFN is returned as a packed string, VFN as a normal string. + +NOTE1 -- (Dec84) The "degeneracy flag files" are no longer used, but some of +the code has been left in place, to avoid having to modify and test the code +after its removal. This code should be removed when other modifications are +required which will require careful testing of the package. + +NOTE2 -- Interrupts and automatic error checking should be disabled while a +VFN is open to prevent corruption of the mapping file, failure to remove a +file lock, or failure to close the mapping file. +.endhelp ______________________________________________________________________ + +define SZ_VFN 255 # max chars in V_VFN field +define LEN_FN 128 # no. chars allocated to VFNFN field +define SZ_FNPAIR (LEN_FN*2) # size of filename pair 2(+EOS+align) +define MAX_LONGFNAMES 100 # max filename pairs in FNMAP +define SZ_ZFD 4 # size of ".zfd" extension +define MAX_READS 5 # max trys to read mapping file +define MAX_DEGENERACY 50 # max VFN's mapping to same OSFN +define MAX_DIGITS 2 # max digits in degeneracy index + +define V_MAP 1 # VFN opcodes +define V_ADD 2 +define V_DEL 3 +define V_UNMAP 4 + +# VFD -- VFN descriptor structure. Assumes an 80 char (or less) OSDIR field +# and 35 char (or less) VFN, ROOT and EXTN fields (see fio.h). + +define LEN_VFD 778 + +define V_MFD Memi[$1] # ptr to mapping file descriptor +define V_ACMODE Memi[$1+1] # access mode +define V_LENOSDIR Memi[$1+2] # length of OSDIR string +define V_LENROOT Memi[$1+3] # length of ROOT string +define V_LENEXTN Memi[$1+4] # length of EXTN string +define V_LONGROOT Memi[$1+5] # root field exceeds OS limit +define V_VFN Memc[P2C($1+10)] # VFN - ldir +define V_OSDIR Memc[P2C($1+266)] # OS directory +define V_ROOT Memc[P2C($1+522)] # OS root filename +define V_EXTN Memc[P2C($1+650)] # OS extension + +# MFD -- Mapping file descriptor structure. An upper limit is placed on +# the number of filename pairs in the descriptor because it is assumed that +# long filenames are rare. Note that this places a limit on the number of long +# filenames in the directory, not on the number of files in the directory. +# If this is a problem the code is not difficult to generalize. + +define LEN_MFD (250+MAX_LONGFNAMES*SZ_FNPAIR/SZ_STRUCT) +define MIN_LENMFD (250+1*SZ_FNPAIR/SZ_STRUCT) +define SZ_MAPFNAME (240*SZ_STRUCT-1) + +define M_CHECKSUM Memi[$1] # checksum of file when written +define M_CHAN Memi[$1+1] # OS channel of mapping file +define M_LOCKTIME Meml[$1+2] # clktime when lock set +define M_NFILES Memi[$1+3] # no. filename pairs in map +define M_LASTOP Memi[$1+4] # code for last op on database +define M_MODIFIED Memi[$1+5] # YES if database modified +define M_ADDZMD Memi[$1+6] # create .zmd file at update +define M_DELZMD Memi[$1+7] # delete .zmd file at update +define M_MAPFNAME Memc[P2C($1+10)] # name of map file +define M_FNMAP (P2C($1+250)) # filename pairs + +# Subscript the (VFN,OSFN) filename pairs. For example, FN_VFN(mfd,n) +# references the VFN field of filename pair N of the mapping file MFD. + +define FN_VFN Memc[M_FNMAP($1)+(($2)*2-2)*LEN_FN] +define FN_OSFN Memc[M_FNMAP($1)+(($2)*2-1)*LEN_FN] + + +# VFNOPEN -- Open a VFN. Allocate VFD and convert the VFN into OSFN, ROOT, +# and EXTN fields. The EXTN field is mapped to the OS extension, but the +# ROOT field may be longer than is permitted by the OS. The mapping file +# is not referenced until the OSFN is requested in a map, add, or del op. + +pointer procedure vfnopen (vfn, mode) + +char vfn[ARB] # virtual filename +int mode # access mode for VFN database + +bool first_time +int n_open_vfns, root_offset, extn_offset +pointer def_vfd, vfd +data first_time /true/ +common /vfncom/ n_open_vfns +errchk syserrs, malloc, calloc, vfn_translate, vvfn_readmapfile + +begin + # After the first call a single VFD will be allocated at all times. + # This eliminates the need to allocate and free a descriptor in each + # call. + + if (first_time) { + call malloc (def_vfd, LEN_VFD, TY_STRUCT) + n_open_vfns = 0 + first_time = false + } + + # Allocate and initialize the VFD. + + if (n_open_vfns <= 0) { + vfd = def_vfd + call aclri (Memi[vfd], LEN_VFD) + } else + call calloc (vfd, LEN_VFD, TY_STRUCT) + n_open_vfns = n_open_vfns + 1 + + # Break the VFN into its component parts. Map using escape sequence + # encoding, but do not squeeze the OSFN. Most calls are read only + # accesses that do not involve accessing the VFN database. The + # following is what takes all the time (string concatenation and + # packing in VFNMAP is also a factor). + + call vfn_translate (vfn, V_OSDIR(vfd), V_LENOSDIR(vfd), + V_ROOT(vfd), V_LENROOT(vfd), + V_EXTN(vfd), V_LENEXTN(vfd)) + + # Determine whether the length of the root exceeds the max host system + # filename length, and set flag if so. If longroot, squeeze the root + # because the unsqueezed root is not useful for anything. The V_VFN + # field is used as a temporary. + + if (V_LENROOT(vfd) > MAX_ROOTLEN) { + call vfn_squeeze (V_ROOT(vfd), V_VFN(vfd), MAX_ROOTLEN) + call strcpy (V_VFN(vfd), V_ROOT(vfd), MAX_ROOTLEN) + V_LENROOT(vfd) = MAX_ROOTLEN + V_LONGROOT(vfd) = YES + } else + V_LONGROOT(vfd) = NO + + # Set access mode and save VFN. + V_ACMODE(vfd) = mode + + switch (mode) { + case VFN_READ, VFN_WRITE: + call zfnbrk (vfn, root_offset, extn_offset) + call strcpy (vfn[root_offset], V_VFN(vfd), SZ_VFN) + case VFN_UNMAP: + call vvfn_readmapfile (vfd) + default: + call syserrs (SYS_FVFNMODE, vfn) + } + + return (vfd) +end + + +# VFNMAP -- Map and pack the VFN into an OSFN, but do not modify the database. +# The mapping file is accessed only if the OS filename is degenerate, i.e., +# if the directory contains more than one VFN mapping to the same OSFN after +# escape sequence encoding and squeezing. + +int procedure vfnmap (vfd, osfn, maxch) + +pointer vfd # pointer to VFD descriptor +char osfn[ARB] # char buffer to receive packed OSFN +int maxch + +int status +int vfnmapu() + +begin + status = vfnmapu (vfd, osfn, maxch) + call osfn_pkfname (osfn, osfn, maxch) + + return (status) +end + + +# VFNMAPU -- Map but do not pack a VFN into an OSFN. Call VFNMAP if you want +# a packed osfn. + +int procedure vfnmapu (vfd, osfn, maxch) + +pointer vfd # pointer to VFD descriptor +char osfn[maxch] # char buffer to receive unpacked OSFN +int maxch + +int op, status +int gstrcpy(), vfn_getosfn() +errchk vfn_getosfn, vvfn_readmapfile +define degenerate_ 91 + +begin + # The OSDIR and ROOT fields are used twice below, so we concatenate + # them here. + + op = gstrcpy (V_OSDIR(vfd), osfn, maxch) + 1 + op = op + gstrcpy (V_ROOT(vfd), osfn[op], maxch-op+1) + + # If the root field of the osfn is within the length limit for a host + # system filename all we have to do is concatenate and pack, returning + # the packed osfn. If the root has been squeezed we have to look to + # see if it is unique within the directory; if it is then we do not + # have to read the mapping file. Filename mapping is fast provided + # we do not have to read the mapping file. + + if (V_LONGROOT(vfd) == YES) + goto degenerate_ + + # Concatenate the final osfn. + if (V_LENEXTN(vfd) > 0 && op < maxch) { + osfn[op] = EXTN_DELIMITER + op = op + 1 + call strcpy (V_EXTN(vfd), osfn[op], maxch-op+1) + } else + osfn[op] = EOS + + return (OK) + + +degenerate_ + # If we get here then the squeezed filename is degenerate and we have + # to read the mapping file to get the OSFN assigned by VFNADD. If the + # mapping file does not exist and the VFN is open with write perm, + # then we were probably called by VFNADD and we go ahead and create + # a new mapping file. + + call vvfn_readmapfile (vfd) + + # Search the file name list for the named VFN. + if (vfn_getosfn (vfd, V_VFN(vfd), osfn, maxch) <= 0) + status = ERR + else + status = OK + + M_LASTOP(V_MFD(vfd)) = V_MAP + + return (status) +end + + +# VFNADD -- Map a VFN to an OSFN and add the VFN,OSFN pair to the VFN database +# if the OSFN is long. An entry must be made whether or not the filename is +# degenerate, to permit the inverse mapping. + +int procedure vfnadd (vfd, osfn, maxch) + +pointer vfd # pointer to VFN descriptor +char osfn[maxch] # buffer to receive packed OSFN +int maxch + +int file_exists +int vfnmap(), vfn_enter() +errchk vfnmap + +begin + # Call VFNMAP to perform the mapping and possibly open the database. + # If VFNMAP returns ERR then the filename was degenerate but was not + # found in the database, which is what we want since we are adding + # the file. We return ERR if the file already exists, whether or + # not the name is degenerate. + + if (vfnmap (vfd, osfn, maxch) == ERR) { + # Long filename but no entry found in database; we have to add + # a new entry. + return (vfn_enter (vfd, osfn, maxch)) + } else if (V_LONGROOT(vfd) == NO) { + # Short filename; see if physical file exists. + call zfacss (osfn, 0, 0, file_exists) + if (file_exists == YES) + return (ERR) + else + return (OK) + } else + # VFN found in database and filename is long. + return (ERR) +end + + +# VFNDEL -- Map a VFN to an OSFN and delete the VFN,OSFN pair from the VFN +# database if the OSFN is long. + +int procedure vfndel (vfd, osfn, maxch) + +pointer vfd # pointer to VFN descriptor +char osfn[maxch] # buffer to receive packed OSFN +int maxch + +char first_char +int fn, fn_index, ip, junk +pointer sp, root, extn, mfd, vfnp +bool streq() +int vfnmap() +errchk vfnmap + +begin + call smark (sp) + call salloc (root, SZ_VFNFN, TY_CHAR) + call salloc (extn, SZ_VFNFN, TY_CHAR) + + # Call VFNMAP to perform the mapping and possibly open the database. + # If VFNMAP returns ERR then the filename was degenerate but was not + # found in the database and we are done. If VFNMAP returns OK we + # are done unless the filename is long. + + if (vfnmap (vfd, osfn, maxch) == ERR) { + # Long filename but no entry found in database; nothing to delete. + call sfree (sp) + return (ERR) + } else if (V_LONGROOT(vfd) == NO) { + # Short filename; nothing to delete but it is not an error. + call sfree (sp) + return (OK) + } + + # If we get here the VFN was found in the database and the filename + # is long. Locate the VFN entry and determine if there are any + # other entries mapping to the same squeezed root. + + mfd = V_MFD(vfd) + vfnp = M_FNMAP(mfd) + first_char = V_VFN(vfd) + fn_index = 0 + M_DELZMD(mfd) = YES + + do fn = 1, M_NFILES(mfd) { + if (Memc[vfnp] == first_char) { + if (fn_index == 0) + if (streq (Memc[vfnp], V_VFN(vfd))) + fn_index = fn + ip = 1 + call vfn_encode (Memc[vfnp], ip, Memc[root], junk, Memc[extn], + junk) + if (streq (Memc[root], V_ROOT(vfd))) { + M_DELZMD(mfd) = NO + if (fn_index != 0) + break + } + } + vfnp = vfnp + SZ_FNPAIR + } + + # Delete the filename pair from the database. Deletion is effected by + # shifting the higher indexed filename pairs back one filepair. + # We are more concerned here about saving space in the mapping file + # and in the MFD, than in making set deletion efficient. + + for (fn = fn_index + 1; fn <= M_NFILES(mfd); fn=fn+1) + call amovc (FN_VFN(mfd,fn), FN_VFN(mfd,fn-1), SZ_FNPAIR) + M_NFILES(mfd) = M_NFILES(mfd) - 1 + + M_LASTOP(mfd) = V_DEL + M_MODIFIED(mfd) = YES + + call sfree (sp) + return (OK) +end + + +# VFNUNMAP -- Convert an OSFN into a VFN. Search the MFD file list for the +# named OSFN, and if found return the associated VFN as an output argument and +# the length of the VFN string as the function value. If entry is not found +# perform the inverse transformation (map extension, invert escape sequence +# encoding). The VFN returned does not include a logical directory prefix. +# This function is called to perform the inverse mapping when reading +# directories. + +int procedure vfnunmap (vfd, osfn, vfn, maxch) + +pointer vfd # VFN descriptor +char osfn[maxch] # OS filename to be searched for (packed) +char vfn[ARB] # receives unpacked VFN +int maxch + +char first_char +int fn, op, extn_offset +pointer mfd, osfnp, sp, osfname, ip +bool streq() +int gstrcpy(), vfn_decode() + +begin + call smark (sp) + call salloc (osfname, SZ_PATHNAME, TY_CHAR) + + call strupk (osfn, Memc[osfname], SZ_PATHNAME) + if (CASE_INSENSITIVE && HOST_CASE != 'L') + call strlwr (Memc[osfname]) + + # Search mapping file for OSFN and return VFN if found. + + mfd = V_MFD(vfd) + osfnp = M_FNMAP(mfd) + LEN_FN + first_char = Memc[osfname] + + do fn = 1, M_NFILES(mfd) { + if (Memc[osfnp] == first_char) + if (streq (Memc[osfnp], Memc[osfname])) { + call sfree (sp) + return (gstrcpy (FN_VFN(mfd,fn), vfn, maxch)) + } + osfnp = osfnp + SZ_FNPAIR + } + + # No entry in mapping file, so we must perform the inverse + # transformation. Decode the root, unmap and decode the extension, + # and return VFN. If there are multiple EXTN_DELIMITER delimited + # fields only the final one is mapped as an extension, but all are + # decoded. + + vfn[1] = EOS + extn_offset = 0 + ip = osfname + op = 1 + + while (Memc[ip] != EOS) { + op = op + vfn_decode (Memc, ip, vfn[op], maxch-op+1) + if (Memc[ip] == EXTN_DELIMITER) { + ip = ip + 1 + vfn[op] = '.' + op = op + 1 + vfn[op] = EOS + extn_offset = op + } + } + + # Add mapped filename extension. If the OS extension maps into a + # null VFN extension omit the trailing period. If the . is preceded + # by another dot it is not considered an extension delimiter. + + if (extn_offset > 0) { + call vfn_unmap_extension (vfn[extn_offset], vfn[extn_offset], + SZ_VFNFN - extn_offset + 1) + if (vfn[extn_offset] != EOS) { + for (op=extn_offset; vfn[op] != EOS; op=op+1) + ; + } else if (extn_offset<=2 || vfn[extn_offset-2] == EXTN_DELIMITER) { + op = extn_offset + } else { + vfn[extn_offset-1] = EOS + op = extn_offset - 1 + } + } + + call sfree (sp) + return (op - 1) +end + + +# VFNCLOSE -- Close a VFN. Update the VFN database if the MFD has been +# modified and updating is enabled. Release the lock on the directory and +# return all storage. + +procedure vfnclose (vfd, update_enable) + +pointer vfd # VFN descriptor +int update_enable # update the database? + +int n_open_vfns, lastop, junk, len_struct +int status +pointer sp, fname, osfn, mfd + +int osfn_unlock(), osfn_timeleft() +int vfnadd(), vfndel(), vvfn_checksum() +common /vfncom/ n_open_vfns +errchk osfn_unlock, osfn_timeleft, vfnadd, vfndel, syserrs +define freemfd_ 91 +define freevfd_ 92 +define unlock_ 93 + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (osfn, SZ_PATHNAME, TY_CHAR) + + # If the mapping file was never referenced or the database was not + # modified in the MFD, just return buffers and quit. + + mfd = V_MFD(vfd) + n_open_vfns = n_open_vfns - 1 + + if (mfd == NULL) + goto freevfd_ + else if (M_MODIFIED(mfd) == NO || update_enable == VFN_NOUPDATE) { + if (V_ACMODE(vfd) == VFN_WRITE) + goto unlock_ + else + goto freemfd_ + } + + # If we get here then the mapping file is open with write permission, + # a transaction has been performed which modified the database, and we + # were called with updating enabled. If there is not enough time + # remaining on the lock to permit the update, rollback (repeat) the + # last transaction, otherwise update the database on disk. + + call osfn_pkfname (M_MAPFNAME(mfd), Memc[osfn], SZ_PATHNAME) + + while (osfn_timeleft (Memc[osfn], M_LOCKTIME(mfd)) < MIN_TIMELEFT) { + # Rollback transaction. Hopefully it wont take so long this time + # (should only take a second or so). + + junk = osfn_unlock (Memc[osfn], M_LOCKTIME(mfd)) + lastop = M_LASTOP(mfd) + call mfree (mfd, TY_STRUCT) + + switch (lastop) { + case V_ADD: + junk = vfnadd (vfd, Memc[fname], SZ_PATHNAME) + case V_DEL: + junk = vfndel (vfd, Memc[fname], SZ_PATHNAME) + } + } + + # From here on we are committed. Update and close the mapping file. + # Add checksum to ensure correct reads. + + len_struct = LEN_MFD - (MAX_LONGFNAMES - M_NFILES(mfd)) * + (SZ_FNPAIR / SZ_STRUCT) + M_CHECKSUM(mfd) = vvfn_checksum (Memi[mfd+1], (len_struct - 1) * SZ_INT) + + call zawrbf (M_CHAN(mfd), Memi[mfd], len_struct * SZ_STRUCT * SZB_CHAR, + long(1)) + call zawtbf (M_CHAN(mfd), status) + if (status == ERR) + call syserrs (SYS_FWRITE, M_MAPFNAME(mfd)) +unlock_ + call zclsbf (M_CHAN(mfd), status) + if (status == ERR) + call syserrs (SYS_FCLOSE, M_MAPFNAME(mfd)) + + # All done! Unlock the directory. If there are no files left in + # the mapping file, delete the file and all lock files. + + call osfn_pkfname (M_MAPFNAME(mfd), Memc[osfn], SZ_PATHNAME) + if (M_NFILES(mfd) == 0) { + call zfdele (Memc[osfn], junk) + call osfn_rmlock (Memc[osfn]) + } else if (osfn_unlock (Memc[osfn], M_LOCKTIME(mfd)) == ERR) { + iferr (call syserrs (SYS_FNOLOCK, M_MAPFNAME(mfd))) + call erract (EA_WARN) + } + +freemfd_ + call mfree (mfd, TY_STRUCT) +freevfd_ + if (n_open_vfns > 0) + call mfree (vfd, TY_STRUCT) + call sfree (sp) +end + + +# VVFN_READMAPFILE -- Open and read the mapping file. In VFN_WRITE mode a +# new mapping file is created if necessary. + +procedure vvfn_readmapfile (vfd) + +pointer vfd # pointer to VFD descriptor + +int new_struct_size, checksum, file_exists, maxbytes, new_mapping_file +int nbytes, len_file, junk, chan, ntrys, errnum, status +long locktime +pointer sp, mfd, fname, pkosfn + +int vvfn_checksum() +long osfn_lock() +errchk calloc, syserrs, osfn_lock, osfn_init +define cleanup_ 91 +define reallynew_ 92 + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (pkosfn, SZ_PATHNAME, TY_CHAR) + + call calloc (mfd, LEN_MFD, TY_STRUCT) + V_MFD(vfd) = mfd + + # Make OSFN of mapping file. If the mode is VFN_UNMAP then the root + # field, if any, is the filename of the directory containing the + # mapping file. + + call strcpy (V_OSDIR(vfd), M_MAPFNAME(mfd), SZ_MAPFNAME) + if (V_ACMODE(vfd) == VFN_UNMAP && V_LENROOT(vfd) > 0) + call zfsubd (M_MAPFNAME(mfd), SZ_MAPFNAME, V_ROOT(vfd), junk) + call strcat (FNMAPPING_FILE, M_MAPFNAME(mfd), SZ_MAPFNAME) + call strlwr (M_MAPFNAME(mfd)) + call osfn_pkfname (M_MAPFNAME(mfd), Memc[fname], SZ_PATHNAME) + + # Open or create mapping file. Create must precede lock as lock will + # abort if the file to be locked does not exist. OSFN_LOCK will call + # error if no write perm on directory. If file locking is implemented + # by host, open will return ERR if file is write locked by another + # process, in which case we wait until the file can be opened. + + call zfacss (Memc[fname], 0, 0, file_exists) + new_mapping_file = NO + + switch (V_ACMODE(vfd)) { + case VFN_WRITE: + # Determine whether or not the mapping file exists. + call osfn_pkfname (M_MAPFNAME(mfd), Memc[pkosfn], SZ_PATHNAME) + + if (file_exists == YES) { + # Open an existing mapping file for exclusive access. + iferr (locktime = osfn_lock (Memc[pkosfn])) { + call mfree (mfd, TY_STRUCT) + V_MFD(vfd) = NULL + call erract (EA_ERROR) + } + repeat { + call zopnbf (Memc[fname], READ_WRITE, chan) + if (chan == ERR) + call zwmsec (1000) + } until (chan != ERR || !OS_FILELOCKING) + + } else { + # Create a new mapping file and init the locks. + new_mapping_file = YES + call zopnbf (Memc[fname], NEW_FILE, chan) + if (chan != ERR) { + call osfn_initlock (Memc[pkosfn]) + locktime = osfn_lock (Memc[pkosfn]) + } else { + errnum = SYS_FOPEN + goto cleanup_ + } + } + default: + if (file_exists == YES) + call zopnbf (Memc[fname], READ_ONLY, chan) + } + + if (file_exists == YES && chan == ERR) { + errnum = SYS_FOPEN + goto cleanup_ + } + + # Read mapping file into descriptor. Repeat the read if the + # checksum is invalid, indicating that our read occurred while + # an update was in progress (locking need not lockout reads). + + if (file_exists == YES) { + ntrys = 0 + + repeat { + # Read the file into the MFD. + maxbytes = LEN_MFD * SZ_STRUCT * SZB_CHAR + call zardbf (chan, Memi[mfd], maxbytes, long(1)) + call zawtbf (chan, nbytes) + + # The mapping file can be zero length if it was opened for + # updating but never written into. + + if (nbytes == 0) + goto reallynew_ + + len_file = nbytes / SZB_CHAR / SZ_STRUCT + if (len_file < MIN_LENMFD) { + errnum = SYS_FREAD + goto cleanup_ + } + + # The checksum excludes the checksum field of MFD, but the + # entire MFD is written to the mapping file. Note that the + # file will contain garbage at the end following a file + # deletion (the file list gets shorter but the file does not). + # Compute checksum using only the valid file data, since that + # is how it is computed when the file is updated. + + len_file = LEN_MFD - (MAX_LONGFNAMES - M_NFILES(mfd)) * + (SZ_FNPAIR / SZ_STRUCT) + checksum = vvfn_checksum (Memi[mfd+1], (len_file-1) * SZ_INT) + + ntrys = ntrys + 1 + } until (checksum == M_CHECKSUM(mfd) || ntrys > MAX_READS) + + if (ntrys > MAX_READS) { + errnum = SYS_FVFNCHKSUM + goto cleanup_ + } + } + +reallynew_ + + # Close the mapping file if it is never going to be updated, and return + # any unused space in the mapping file descriptor. + + if (V_ACMODE(vfd) != VFN_WRITE) { + if (file_exists == YES) { + call zclsbf (chan, status) + if (status == ERR) + call syserrs (SYS_FCLOSE, M_MAPFNAME(mfd)) + } + new_struct_size = LEN_MFD - + (MAX_LONGFNAMES - M_NFILES(mfd)) * (SZ_FNPAIR/SZ_STRUCT) + call realloc (mfd, new_struct_size, TY_STRUCT) + V_MFD(vfd) = mfd + } else { + M_CHAN(mfd) = chan + M_LOCKTIME(mfd) = locktime + } + + call sfree (sp) + return + +cleanup_ + call strcpy (M_MAPFNAME(mfd), Memc[fname], SZ_PATHNAME) + call mfree (mfd, TY_STRUCT) + V_MFD(vfd) = NULL + call syserrs (errnum, Memc[fname]) +end + + +# VFN_ENTER -- Add a new filename pair to the mapping file. The VFN was not +# found in the database but that does not mean that there is not already an +# occurrence of the OSFN in the database and in the directory; if the OSFN is +# already in use, the filename is degenerate. If the OSFN exists in the +# directory then create ".zmd" degeneracy file and generate a unique OSFN, +# adding a new VFN,OSFN pair to the database. + +int procedure vfn_enter (vfd, osfn, maxch) + +pointer vfd # pointer to VFN descriptor +char osfn[maxch] # packaged OS filename (in/out) +int maxch + +int file_exists, op, ndigits, m, n, num, offset, fn +pointer sp, fname, numbuf, mfd +int gstrcpy(), itoc() +errchk syserrs + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (numbuf, MAX_DIGITS, TY_CHAR) + + # Generate the first attempt at the OSFN of the new file. + + op = gstrcpy (V_OSDIR(vfd), Memc[fname], SZ_PATHNAME) + op = op + gstrcpy (V_ROOT(vfd), Memc[fname+op], SZ_PATHNAME-op) + if (V_LENEXTN(vfd) > 0) { + Memc[fname+op] = EXTN_DELIMITER + op = op + 1 + call strcpy (V_EXTN(vfd), Memc[fname+op], SZ_PATHNAME-op) + } + offset = V_LENOSDIR(vfd) + 1 + + # Determine if a file already exists with the new OSFN. If so we + # must flag the file as degenerate and generate a unique OSFN. + + call osfn_pkfname (Memc[fname], osfn, maxch) + call zfacss (osfn, 0, 0, file_exists) + + if (file_exists == YES) { + # Set flag to create degeneracy flag file at update time. + M_ADDZMD(mfd) = YES + + # Generate a unique OSFN for the new file. This is done by + # overwriting the 2nd and following characters of the root with + # a number until a unique name results. Nines are preferred as + # they occur least frequently in ordinary filenames. + + for (m=0; file_exists == YES && m * 10 < MAX_DEGENERACY; m=m+1) + for (n=9; file_exists == YES && n >= 0; n=n-1) { + num = m * 10 + n + ndigits = itoc (num, Memc[numbuf], MAX_DIGITS) + call amovc (Memc[numbuf], Memc[fname+offset], ndigits) + call osfn_pkfname (Memc[fname], osfn, maxch) + call zfacss (osfn, 0, 0, file_exists) + } + + if (m * 10 >= MAX_DEGENERACY) + call syserrs (SYS_FDEGEN, Memc[fname]) + } + + # Add the filename pair to the database. The directory prefix is + # omitted. If we run out of room in the mapping file we just abort. + + mfd = V_MFD(vfd) + fn = M_NFILES(mfd) + 1 + M_NFILES(mfd) = fn + if (fn > MAX_LONGFNAMES) + call syserrs (SYS_FTMLONGFN, Memc[fname]) + + # Save the VFN and OSFN, minus the directory prefix, in the mapping + # file structure. + + call strcpy (V_VFN(vfd), FN_VFN(mfd,fn), SZ_VFNFN) + call strcpy (Memc[fname+offset-1], FN_OSFN(mfd,fn), SZ_VFNFN) + + M_LASTOP(mfd) = V_ADD + M_MODIFIED(mfd) = YES + + call sfree (sp) + return (OK) +end + + +# VFN_GETOSFN -- Search the MFD file list for the named VFN, and if found +# return the assigned OSFN as an output argument and the length of the OSFN +# string as the function value. ERR is returned if the entry cannot be found. +# The OSFN includes the OSDIR prefix. + +int procedure vfn_getosfn (vfd, vfn, osfn, maxch) + +pointer vfd # VFN descriptor +char vfn[ARB] # virtual filename to be searched for +char osfn[maxch] # receives unpacked OSFN +int maxch + +char first_char +int fn, op +pointer mfd, vfnp +bool streq() +int gstrcpy() + +begin + mfd = V_MFD(vfd) + vfnp = M_FNMAP(mfd) + first_char = vfn[1] + + do fn = 1, M_NFILES(mfd) { + if (Memc[vfnp] == first_char) + if (streq (Memc[vfnp], vfn)) { + op = gstrcpy (V_OSDIR(vfd), osfn, maxch) + 1 + op = op + gstrcpy (FN_OSFN(mfd,fn), osfn[op], maxch-op+1) + return (op - 1) + } + vfnp = vfnp + SZ_FNPAIR + } + + return (ERR) +end + + +# VVFN_CHECKSUM -- Compute the integer checksum of a char array. + +int procedure vvfn_checksum (a, nchars) + +char a[nchars] # array to be summed +int nchars # length of array +int i, sum + +begin + sum = 0 + do i = 1, nchars + sum = sum + a[i] + + return (sum) +end diff --git a/sys/fio/vfntrans.x b/sys/fio/vfntrans.x new file mode 100644 index 00000000..44f4f36f --- /dev/null +++ b/sys/fio/vfntrans.x @@ -0,0 +1,937 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include + +.help vfntrans +.nf ___________________________________________________________________________ +VFNTRANS -- Procedures for translating VFN's to OSFN's and back again in +memory. These procedures are called by the VFNMAP procedures, but do not +access the VFN database. This package contains most of the knowledge of the +characteristics of OS filenames. The characteristics of OS filenames (max +length, extensions, etc.) are defined in . + + vfn_translate (vfn, osdir, lenosdir, root, lenroot, extn, lenextn) + vfn_expand_ldir (vfn, outstr, maxch) + vfn_encode (vfn, ip, root, lenroot, extn, lenextn) + nchars = vfn_decode (osfn, ip, vfn, maxch) + vfn_map_extension (iraf_extn, os_extn, maxch) + vfn_unmap_extension (iraf_extn, os_extn, maxch) + vfn_squeeze (root, outstr, maxch) + y/n = vfn_is_hidden_file (fname) + +The main vfn to osfn translation routine is VFN_TRANSLATE. VFN_EXPAND_LDIR +performs recursive logical directory expansion. The encode and decode routines +perform escape sequence encoding and its inverse. Substitution of OS filename +extensions for IRAF extensions, and vice versa, is performed by the map +extension procedures. +.endhelp ______________________________________________________________________ + +# Size limiting definitions. + +define MAX_PUSHBACK 16 # determines length of pushback stack +define SZ_PBBUF 255 # size of pushback buffer +define MAX_EXTENSIONS 20 # max filename extension pairs in EXTN_MAP +define MAX_RESERVEXTN 20 # max reserved filename extensions +define SZ_EXTNMAP 64 # storage for iraf/os extn pairs + + +# VFN_TRANSLATE -- Translate a VFN into the OSDIR, ROOT, and EXTN fields. +# If a logical directory prefix is given it will be recursively expanded. +# Any number of subdirectories may be given; each is folded into the OSDIR. +# The ROOT field is escape sequence encoded but not squeezed. The EXTN +# field is encoded and selected IRAF extensions are mapped into OS +# extensions. + +procedure vfn_translate (rawvfn, osdir, lenosdir, root, lenroot, extn, lenextn) + +char rawvfn[ARB] # input virtual filename +char osdir[SZ_OSDIR] # OS directory prefix (output) +int lenosdir # length of the osdir string (output) +char root[SZ_VFNFN] # OS root filename (output) +int lenroot # length of the root string (output) +char extn[SZ_VFNFN] # OS filename extension (output) +int lenextn # length of the extn string (output) + +pointer sp, ip, vfn, fname, sqroot +int gstrcpy(), nowhite() +errchk syserr + +begin + call smark (sp) + call salloc (vfn, SZ_PATHNAME, TY_CHAR) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (sqroot, MAX_ROOTLEN, TY_CHAR) + + # Strip any whitespace at either end of the filename. + if (nowhite (rawvfn, Memc[vfn], SZ_PATHNAME) == 0) + call syserr (SYS_FNOFNAME) + + # If the VFN begins with a legal OS directory prefix it is assumed + # to be an OSFN and no mapping is performed. Do not bother to break + # the filename into osdir, root, extn. + + call zfxdir (Memc[vfn], osdir, SZ_OSDIR, lenosdir) + + if (lenosdir > 0) { + # VFN is actually an OSFN. Return the OSFN as the osdir filename + # to avoid the 32 char restriction. + root[1] = EOS + lenroot = 0 + extn[1] = EOS + lenextn = 0 + + lenosdir = gstrcpy (Memc[vfn], osdir, SZ_OSDIR) + + call sfree (sp) + return + } + + # The VFN is really a VFN. Check for a logical directory prefix and + # recursively expand it into an OS directory prefix if found. A VFN of + # the form "ldir$xxx" is converted to "osdir // xxx". Additional + # subdirectories may be introduced in the expansion. + + call vfn_expand_ldir (Memc[vfn], Memc[fname], SZ_PATHNAME) + call zfxdir (Memc[fname], osdir, SZ_OSDIR, lenosdir) + ip = fname + lenosdir + + # Translate the VFN. Each pass through the loop extracts and processes + # the next field of the VFN. A field may be a subdirectory delimited + # by a /, a root filename, or an extension. Subdirectory names are + # encoded and squeezed but not looked up in the mapping table, hence + # long directory names must be unique within a directory. + + repeat { + call vfn_encode (Memc, ip, root, lenroot, extn, lenextn) + if (Memc[ip] == '/' || + (root[1] == '.' && lenroot == 1) || + (root[1] == '.' && root[2] == '.' && lenroot == 2)) { + + if (lenroot > MAX_ROOTLEN) { + call vfn_squeeze (root, Memc[sqroot], MAX_ROOTLEN) + call zfsubd (osdir, SZ_OSDIR, Memc[sqroot], lenosdir) + } else + call zfsubd (osdir, SZ_OSDIR, root, lenosdir) + root[1] = EOS + lenroot = 0 + if (Memc[ip] == '/') + ip = ip + 1 + } + } until (Memc[ip] == EOS) + + # Map IRAF extension into OS extension. + if (lenextn > 0) + call vfn_map_extension (extn, extn, SZ_VFNFN) + call sfree (sp) +end + + +# VFN_EXPAND_LDIR -- Copy the input VFN to the output string. As the copy is +# being performed we scan for the ldir delimiter. If it is encountered, we +# lookup the ldir in the environment and push the value back into the input, +# resuming scanning on the new input. Logical directories are thus expanded +# recursively, i.e., one ldir may reference another in its definition. If an +# ldir references itself storage will overflow and an error message is printed. + +procedure vfn_expand_ldir (vfn, outstr, maxch) + +char vfn[ARB] # VFN possibly containing an ldir prefix +char outstr[maxch] # output string +int maxch + +char ch +pointer pbbuf # pushback buffer +pointer pb_stack[MAX_PUSHBACK] # pushback stack +int n, op, op_node, op_env, pbsp, in +pointer nextch, ip, sp + +int envfind(), gstrcpy(), ki_localnode() +define input {$1=Memc[ip];ip=ip+1} +define output {outstr[op]=$1;op=op+1} +errchk syserrs, envfind + +begin + call smark (sp) + call salloc (pbbuf, SZ_PBBUF, TY_CHAR) + + # Discard leading whitespace and copy the VFN into the input buffer. + for (in=1; IS_WHITE (vfn[in]); in=in+1) + ; + + nextch = pbbuf + gstrcpy (vfn[in], Memc[pbbuf], SZ_PBBUF) + 1 + ip = pbbuf + op = 1 + op_node = 1 + pbsp = 1 + + # Copy characters successively from the input buffer to the output + # buffer (outstr). Expand logical names recursively (by rescanning + # the translation string returned by ENVGETS). + + repeat { + input (ch) + if (IS_ALNUM (ch)) { # --- regular chars + output (ch) + + } else if (ch == FNNODE_CHAR) { + # If CH is the node name delimiter, either the named node + # is the local node passed as a prefix to any ldir strings, + # or the node was referenced IN one of the logical directory + # replacement strings. + + if (pbsp == 1) { + # If no logical directory definitions have been pushed + # back, the named node must be the local node. + + output (ch) + op_node = op + + } else { + outstr[op] = EOS + + if (ki_localnode (outstr) == YES) { + # Same as above; ignore local node prefix. + output (ch) + op_node = op + + } else { + # A remote node has been referenced during logical + # directory expansion. Filename translation must take + # place on the remote node, so exit immediately, + # returning the new filename "node!vfn". This will + # repeat when filename translation resumes on the + # remote node, but over there the named node will be + # the local node and the if(yes) branch will be taken. + + output (ch) + op = op + gstrcpy (vfn[in], outstr[op], maxch-op+1) + break + } + } + + } else if (ch == FNLDIR_CHAR) { + # If CH is the logical name delimiter, look up the logical name + # in the environment table. If found, push definition back into + # pbbuf, clear the output buffer, and scan pushed back string. + # If not found, pass the string on as a file name. Delete the + # '$' character, so that OS directory specs like "osdir$" + # are passed on correctly. + + output (EOS) + n = envfind (outstr[op_node], Memc[nextch], + pbbuf + SZ_PBBUF - nextch) + + if (n >= 0) { # push back defn + pb_stack[pbsp] = ip # save ip on stk + pbsp = pbsp + 1 + ip = nextch # set ip to new input + nextch = nextch + n + 1 + # Check for recursion (stack overflow). + if (pbsp > MAX_PUSHBACK || nextch-pbbuf >= SZ_PBBUF) + call syserrs (SYS_FZMAPRECUR, Memc[pbbuf]) + op = op_node # discard logical name + } else + op = op - 1 # cancel EOS, delete $ + + } else if (ch == '(') { + # Environment substitution. Mark the position of the left + # paren for later replacement. + + op_env = op + output (ch) + + } else if (ch == ')') { + # Complete an environment substitution. + + outstr[op_env] = EOS + n = gstrcpy (outstr[op_node], Memc[nextch], + pbbuf + SZ_PBBUF - nextch) + + pb_stack[pbsp] = ip # save ip on stk + pbsp = pbsp + 1 + ip = nextch # set ip to new input + nextch = nextch + n + + # Check for recursion (stack overflow). + if (pbsp > MAX_PUSHBACK || nextch-pbbuf >= SZ_PBBUF) + call syserrs (SYS_FZMAPRECUR, Memc[pbbuf]) + + # Get the envvar value string; use null string if not defined. + output (EOS) + n = envfind (outstr[op_env+1], Memc[nextch], + pbbuf + SZ_PBBUF - nextch) + if (n <= 0) { + Memc[nextch] = EOS + n = 0 + } + + nextch = nextch + n + 1 + op = op_node + + } else if (ch == EOS) { + # EOS may mean either the end of a pushed back string, or the + # end of the VFN string. Pop old ip off stack, continue until + # the pushback stack is empty (end of VFN). + + pbsp = pbsp - 1 # pop old ip off stk + ip = pb_stack[pbsp] + if (pbsp == 0) # --- all done + break + + } else if (ch == ESCAPE) { + # Escaped characters are passed straight to the output. + # Preserve the escape unless the escaped character is a + # metacharacter recognized by this procedure (i.e., $ or @). + + input (ch) + if (ch == EOS) + ip = ip - 1 + else if (ch == FNLDIR_CHAR || ch == FNNODE_CHAR) + output (ch) + else { + output ('\\') + output (ch) + } + + } else if (ch > BLANK) { + # Whitespace and control chars are deleted. + output (ch) + } + + if (op > maxch) # check for overflow + call syserrs (SYS_FZMAPOVFL, vfn) + } + + output (EOS) + call sfree (sp) +end + + +# VFN_ENCODE -- Extract and encode the next field of the input VFN. The subdir +# delimiter / or EOS will delimit the scan; the input pointer must be set to +# the first character to be scanned upon input and is left pointing at the +# delimiter character upon output. If the field is a subdir no extension will +# be returned. If an extension is encountered but its length exceeds that +# permitted by the OS or if another "." delimited field is encountered then +# the "." is encoded and the extension is included in the root. If the OS is +# case insensitive the output string will be all lower case. + +procedure vfn_encode (vfn, ip, root, lenroot, extn, lenextn) + +char vfn[ARB] # virtual filename to be scanned +int ip # offset of first char to be scanned (in/out) +char root[SZ_VFNFN] # receives the encoded root filename +int lenroot # nchars in root +char extn[SZ_VFNFN] # receives the encoded filename extn +int lenextn # nchars in extn + +int out, i +char ch, nextch +bool uc_mode, processing_extension, escape_extension, subdir +pointer sp, field, op + +int gstrcpy() +define putch {Memc[op]=$1;op=op+1} +define notextn_ 91 + +begin + call smark (sp) + call salloc (field, SZ_FNAME, TY_CHAR) + + # Skip leading whitespace and control chars. + while (vfn[ip] > 0 && vfn[ip] <= BLANK) + ip = ip + 1 + + # Do something sensible if the null string is input. + if (vfn[ip] == EOS) { + root[1] = EOS + extn[1] = EOS + lenroot = 0 + lenextn = 0 + call sfree (sp) + return + } + + out = 1 + op = field + uc_mode = false + processing_extension = false + escape_extension = false + + # If the first char is legal in an OSFN but is not a letter and only + # letters are permitted as the first char, then a no-op sequence (shift + # to lower) is output first. + + if (LEADING_ALPHA_ONLY) + if (vfn[ip] != '.' && !IS_ALPHA(vfn[ip])) + call vvfn_escape (SHIFT_TO_LOWER, root, out, SZ_VFNFN) + + # The main loop. Examine each input character and output zero or + # more characters depending on the input character class and on what + # the host system permits. Most characters are expected to be lower + # case alphas or digits, hence what we do after these first couple of + # IF's should not affect efficiency much. NOTE: set the escape char + # to NUL to turn off escapes on a machine that allows any char in a + # a filename. + + ch = vfn[ip] + do i = 1, ARB { + if (ch == EOS) { + break + } else if (IS_LOWER(ch)) { + if (uc_mode) { + putch (VFN_ESCAPE_CHAR) + putch (SHIFT_TO_LOWER) + uc_mode = false + } + putch (ch) + + } else if (IS_DIGIT(ch)) { + putch (ch) + + } else if (ch == '_') { + if (UNDERSCORE_PERMITTED) + putch (ch) + else { + putch (VFN_ESCAPE_CHAR) + putch (UNDERSCORE_CODE) + } + + } else if (IS_UPPER(ch)) { + if (!CASE_INSENSITIVE) + putch (ch) + else if (uc_mode) + putch (TO_LOWER(ch)) + else { + # Determine whether to do a case shift or just escape + # a single character. The crossover point is at 2 chars. + # If the next character is also upper case we shift up. + + putch (VFN_ESCAPE_CHAR) + if (IS_UPPER (vfn[ip+1])) { + uc_mode = true + putch (SHIFT_TO_UPPER) + } else + putch (SHIFT_NEXTCHAR) + putch (TO_LOWER(ch)) + } + + } else if (ch == '.') { + # Determine whether the "." marks an extension or is part of + # one of the two special subdirectories "." and "..". + + subdir = false + if (op == field && !processing_extension) { + nextch = vfn[ip+1] + if (nextch == '/' || nextch == EOS) { + subdir = true + } else if (nextch == '.' && + (vfn[ip+2] == '/' || vfn[ip+2] == EOS)) { + subdir = true + putch (ch) + ip = ip + 1 + } + } + + if (subdir) { + putch (ch) + + } else if (processing_extension) { + # We are already processing an extension and have just + # encountered another one (e.g., "file.x.old"). Escape + # the dot and include it and the old extension in the + # root. Start a new extension. + + putch (EOS) + if (PERIOD_PERMITTED) { + root[out] = '.' + out = out + 1 + } else + call vvfn_escape (PERIOD_CODE, root, out, SZ_VFNFN) + out = out + gstrcpy (Memc[field], root[out], SZ_VFNFN-out+1) + op = field + escape_extension = false + + } else { + # This is the first extension to be encountered. Move the + # contents of the field buffer to root and clear the buffer. + + putch (EOS) + out = out + gstrcpy (Memc[field], root[out], SZ_VFNFN-out+1) + op = field + processing_extension = true + escape_extension = false + } + + } else if (ch == '\\' && vfn[ip+1] != EOS) { + # Escaped characters are passed unconditionally, stripping the + # escape character itself unless used to escape the first char + # of an extension, in which case the \ must be retained in the + # output extension to defeat extension mapping. + + if (processing_extension && op == field) + escape_extension = true + ip = ip + 1 + putch (vfn[ip]) + + } else if (ch == '/') { + # End of subdirectory name terminates scan. Extensions are + # not recognized within subdirectory names; include as part + # of root name. + + if (processing_extension) + goto notextn_ + else + break + + } else if (ch <= BLANK) { + # Strip whitespace and control chars. + } else { + # Unknown characters are not mapped; user's discretion. + putch (ch) + } + + # If we are processing an extension and the max length of an OS + # extension has been exceeded, the extension is considered part of + # the root and we are no longer processing an extension. + + if (processing_extension) + if (op - field > MAX_EXTNLEN) { +notextn_ if (PERIOD_PERMITTED) { + root[out] = '.' + out = out + 1 + } else + call vvfn_escape (PERIOD_CODE, root, out, SZ_VFNFN) + processing_extension = false + escape_extension = false + if (ch == '/') + break + } + + ip = ip + 1 + ch = vfn[ip] + } + + putch (EOS) + if (processing_extension) { + # Move extension to the extn output buffer. Add the escape + # character if the extension was escaped. + if (escape_extension) { + extn[1] = '\\' + lenextn = gstrcpy (Memc[field], extn[2], SZ_VFNFN-1) + 1 + } else + lenextn = gstrcpy (Memc[field], extn, SZ_VFNFN) + + # If extn is the null string then root ended in a period; include + # the period in the root. + if (lenextn == 0) + if (PERIOD_PERMITTED) { + root[out] = '.' + out = out + 1 + } else + call vvfn_escape (PERIOD_CODE, root, out, SZ_VFNFN) + + root[out] = EOS + lenroot = out - 1 + + } else { + extn[1] = EOS + lenextn = 0 + lenroot = out + gstrcpy (Memc[field], root[out], SZ_VFNFN-out+1) - 1 + } + + call sfree (sp) +end + + +# VVFN_ESCAPE -- Deposit a character in the output buffer preceded by the +# escape character. Ensure that the output buffer does not overflow. + +procedure vvfn_escape (ch, outbuf, op, maxch) + +int ch # character to be output (passed as an INT) +char outbuf[maxch] # output buffer +int op # output pointer (in/out) +int maxch + +begin + outbuf[op] = VFN_ESCAPE_CHAR + op = min (maxch, op + 1) + outbuf[op] = ch + op = min (maxch, op + 1) +end + + +# VFN_DECODE -- Decode an escape sequence encoded field of a filename. This is +# easier than encoding because we have fewer decisions to make. +# +# NOTE: set the escape char to NUL on a machine which allows any character in a +# filename. Since such a character will never be encountered in filenames this +# effectively turns off decoding and will prevent misinterpretation of OS +# filenames not written by IRAF. + +int procedure vfn_decode (osfn, ip, outstr, maxch) + +char osfn[ARB] # escape sequence encoded filename +int ip # input pointer (in/out) +char outstr[maxch] # output string +int maxch + +int ch, op +bool convert_to_upper +define putback_ 91 + +begin + convert_to_upper = false + + # Optimization: most filenames start with a simple sequence of letters. + # Dispense with these as a special case, and fall into the more general + # code when some other character is encountered. + + do op = 1, maxch { + ch = osfn[ip+op-1] + if (ch != VFN_ESCAPE_CHAR && IS_LOWER (ch)) + outstr[op] = ch + else { + ip = ip + op - 1 + break + } + } + + for (ch=osfn[ip]; ch != EOS && op <= maxch; ch=osfn[ip]) { + # Process escapes. + + if (ch == VFN_ESCAPE_CHAR && osfn[ip+1] != EOS) { + ip = ip + 1 + ch = osfn[ip] + + switch (ch) { + case SHIFT_NEXTCHAR: + if (IS_LOWER (osfn[ip+1])) { + ip = ip + 1 + outstr[op] = TO_UPPER (osfn[ip]) + op = op + 1 + } else + goto putback_ + + case SHIFT_TO_LOWER, SHIFT_TO_UPPER: + if (IS_LOWER (osfn[ip+1])) + convert_to_upper = (ch == SHIFT_TO_UPPER) + else + goto putback_ + + case UNDERSCORE_CODE: + outstr[op] = '_' + op = op + 1 + + case PERIOD_CODE: + outstr[op] = '.' + op = op + 1 + + default: + # Not a recognized escape. Output the escape char + # and put the next char back into the input. +putback_ + outstr[op] = VFN_ESCAPE_CHAR + op = op + 1 + ip = ip - 1 + } + + } else if (IS_LOWER (ch)) { + if (convert_to_upper) + outstr[op] = TO_UPPER(ch) + else + outstr[op] = ch + op = op + 1 + + } else if (ch == EXTN_DELIMITER) { + break + + } else if (ch == FNLDIR_CHAR) { + outstr[op] = '\\' + op = op + 1 + outstr[op] = ch + op = op + 1 + + } else { + outstr[op] = ch + op = op + 1 + } + + ip = ip + 1 + } + + outstr[op] = EOS + return (op - 1) +end + + +# VFN_MAP_EXTENSION -- Map an IRAF filename extension to a host OS filename +# extension. Unrecognized extensions are merely copied. The set of +# extensions to be mapped is defined in + +procedure vfn_map_extension (iraf_extn, os_extn, maxch) + +char iraf_extn[ARB] # IRAF filename extension +char os_extn[maxch] # OS filename extension +int maxch + +bool first_time +char first_char +int extn +bool streq() +data first_time /true/ + +int nextn # number of extensions in map +short iraf[MAX_EXTENSIONS] # indices of IRAF extensions +short os[MAX_EXTENSIONS] # indices of OS extensions +char map[SZ_EXTNMAP] # iraf to os mappings, e.g. "|iraf,os|.." +common /vfnxtn/ nextn, iraf, os, map + +begin + # Init the iraf and os index arrays and count the number of extension + # in the map. + + if (first_time) { + call vvfn_init_extnmap (map, iraf, os, nextn, MAX_EXTENSIONS) + first_time = false + } + + first_char = iraf_extn[1] + + # Escaped extensions, i.e., "root.\extn", are passed on unmodified but + # with the escape character deleted. + + if (first_char == '\\') { + call strcpy (iraf_extn[2], os_extn, maxch) + return + } + + # Search map for the IRAF extension and of found return OS extension, + # else return IRAF extension. + + if (first_char != EOS) + for (extn=1; extn <= nextn; extn=extn+1) + if (map[iraf[extn]] == first_char) + if (streq (iraf_extn, map[iraf[extn]])) { + call strcpy (map[os[extn]], os_extn, maxch) + return + } + + call strcpy (iraf_extn, os_extn, maxch) +end + + +# VFN_UNMAP_EXTENSION -- Convert OS extension to IRAF extension by table lookup +# in the MAP array of extn pairs. + +procedure vfn_unmap_extension (os_extn, iraf_extn, maxch) + +char os_extn[maxch] # OS filename extension +char iraf_extn[ARB] # IRAF filename extension +int maxch + +int extn +char first_char +bool first_time +bool streq() +data first_time /true/ + +int nextn # number of extensions in map +short iraf[MAX_EXTENSIONS] # indices of IRAF extensions +short os[MAX_EXTENSIONS] # indices of OS extensions +char map[SZ_EXTNMAP] # iraf to os mappings, e.g. "|iraf,os|.." +common /vfnxtn/ nextn, iraf, os, map + +begin + # Init the iraf and os index arrays and count the number of extension + # in the map. + + if (first_time) { + call vvfn_init_extnmap (map, iraf, os, nextn, MAX_EXTENSIONS) + first_time = false + } + + # Search map for the OS extension and if found return IRAF extension. + # If the OS extension matches an IRAF extension then escape the first + # char of the extension to avoid interpretation as an IRAF extension. + + first_char = os_extn[1] + if (first_char != EOS) + for (extn=1; extn <= nextn; extn=extn+1) { + if (map[os[extn]] == first_char) { + if (streq (os_extn, map[os[extn]])) { + call strcpy (map[iraf[extn]], iraf_extn, maxch) + return + } + } + if (map[iraf[extn]] == first_char) { + if (streq (os_extn, map[iraf[extn]])) { + iraf_extn[1] = '\\' + call strcpy (map[iraf[extn]], iraf_extn[2], maxch-1) + return + } + } + } + + call strcpy (os_extn, iraf_extn, maxch) +end + + +# VVFN_INIT_EXTNMAP -- Scan the map and initialize the indices of the +# extension strings the first time we are called. Replace the field +# delimiters with EOS to ease string comparisons. The format of the map +# string is "Airaf,osA...", where A is any field delimiter character and +# a comma must be given between fields. Embedded whitespace is not +# permitted. For example: map = "|a,olb|e,exe|" + +procedure vvfn_init_extnmap (map, iraf, os, nextn, max_extn) + +char map[ARB] # set of extns to be mapped +short iraf[max_extn] # indices of IRAF extensions +short os[max_extn] # indices of OS extensions +int nextn # number of extensions in map +int max_extn + +int ip +char delim +bool first_time +data first_time /true/ + +begin + if (!first_time) + return + + call strcpy (EXTN_MAP, map, SZ_EXTNMAP) + nextn = 0 + delim = map[1] + if (delim == EOS) + return + + for (ip=2; map[ip] != EOS && nextn < max_extn; ip=ip+1) { + nextn = nextn + 1 + + iraf[nextn] = ip + while (map[ip] != ',' && map[ip] != EOS) + ip = ip + 1 + map[ip] = EOS + ip = ip + 1 + + os[nextn] = ip + while (map[ip] != delim && map[ip] != EOS) + ip = ip + 1 + map[ip] = EOS + } + + if (nextn > max_extn) + call fatal (1, "fio$vfntrans.x: too many extensions") + + first_time = false +end + + +# VFN_SQUEEZE -- Squeeze the root filename (or any string) to fit into the +# output string. Squeezing preserves the first N-1 and final characters of +# the input string, e.g., if N=6 "concatenate" is squeezed to "concae". + +procedure vfn_squeeze (root, outstr, maxch) + +char root[ARB] # input string to be squeezed +char outstr[maxch] # output, squeezed string +int maxch # length of squeezed string + +int ip, op + +begin + # Omit leading whitespace. + for (ip=1; IS_WHITE (root[ip]); ip=ip+1) + ; + + # Squeeze root to outstr. + for (op=0; root[ip] != EOS; ip=ip+1) { + op = min (maxch, op + 1) + outstr[op] = root[ip] + } + outstr[op+1] = EOS +end + + +# VFN_IS_HIDDEN_FILE -- Determine if the named file is a hidden file. +# Hidden files are files with reserved extensions. The set of reserved +# extensions is given by a list of the form "|.ex1|.ext|...|". + +int procedure vfn_is_hidden_file (fname) + +char fname[ARB] # unpacked filename +char ch +short extn[MAX_RESERVEXTN] +bool first_time +int nextn, first_char, off, i +bool streq() +int strldx() +string reserved RESERVED_EXTNS +data first_time /true/ + +begin + if (first_time) { + call vvfn_init_reserved_extns (reserved, extn,MAX_RESERVEXTN, nextn) + first_time = false + } + + if (nextn > 0) { + ch = EXTN_DELIMITER + off = strldx (ch, fname) + 1 + first_char = fname[off] + + if (off > 0 && first_char != EOS) + do i = 1, nextn + if (reserved[extn[i]] == first_char) + if (streq (reserved[extn[i]], fname[off])) + return (YES) + } + + return (NO) +end + + +# VVFN_INIT_RESERVED_EXTNS -- Inde the list of reserved extensions. Overwrite +# the delimiter character with EOS, set the indices of the extension strings +# in the EXTN array, and count the number of extensions. The format of the +# reserved extension array is "|str1|str2|str3|...|strN|", where the first +# char is taken to be the delimiter character. + +procedure vvfn_init_reserved_extns (ex, extn, max_extn, nextn) + +char ex[ARB] # list of reserved extensions +short extn[max_extn] # indices of substrings +int max_extn # max extensions +int nextn # number of extensions (output) + +char delim +int ip + +begin + nextn = 0 + delim = ex[1] + if (delim == EOS) + return + ip = 2 + + while (ex[ip] != EOS && nextn < max_extn) { + nextn = nextn + 1 + extn[nextn] = ip + + while (ex[ip] != delim && ex[ip] != EOS) + ip = ip + 1 + + if (ex[ip] == delim) { + ex[ip] = EOS + ip = ip + 1 + } + } +end diff --git a/sys/fio/write.x b/sys/fio/write.x new file mode 100644 index 00000000..66241ff5 --- /dev/null +++ b/sys/fio/write.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# WRITE -- Write binary chars to a file. The specified number of chars will +# always be written (with the file buffer being flushed as many times as +# necessary) unless an error occurs. + +procedure write (fd, buffer, maxchars) + +int fd +char buffer[ARB] +int maxchars +int nchars, chunk_size +errchk flsbuf +include + +begin + if (fd <= 0 || fiodes[fd] == NULL) + call syserr (SYS_FILENOTOPEN) + + nchars = 0 + + while (nchars < maxchars) { + if (iop[fd] < bufptr[fd] || iop[fd] >= otop[fd]) + call flsbuf (fd, maxchars - nchars) + chunk_size = min (maxchars - nchars, otop[fd] - iop[fd]) + if (chunk_size <= 0) + break + else { + call amovc (buffer[nchars+1], Memc[iop[fd]], chunk_size) + iop[fd] = iop[fd] + chunk_size + nchars = nchars + chunk_size + } + } + + FNCHARS(fiodes[fd]) = nchars +end diff --git a/sys/fio/xerputc.x b/sys/fio/xerputc.x new file mode 100644 index 00000000..5fda4026 --- /dev/null +++ b/sys/fio/xerputc.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# XERPUTC -- Low level routine, called by the error handling code, to +# accumulate an error command, and send it off to the CL. Clumsy, but +# necessary to avoid recursion if an error abort occurs in a routine +# such as PUTC or FLSBUF. The buffer is automatically flushed to CLOUT +# when newline is encountered. + +procedure xerputc (ch) + +char ch +int op, junk, nchars +char msg[SZ_LINE+1] +include +data op /1/ + +begin + msg[op] = ch + + if (ch == '\n' || op > SZ_PATHNAME) { + fp = fiodes[CLOUT] + nchars = op + op = 0 + + if (FTYPE(fp) == TEXT_FILE) + call fputtx (CLOUT, msg, nchars, junk) + else { + call zcall4 (ZAWRBF(fp), FCHAN(fp), msg, nchars * SZB_CHAR, 0) + } + } + + op = op + 1 +end diff --git a/sys/fio/zfiott.com b/sys/fio/zfiott.com new file mode 100644 index 00000000..f48830bc --- /dev/null +++ b/sys/fio/zfiott.com @@ -0,0 +1,35 @@ +# ZFIOTT.COM -- State variables for the VOS terminal driver. + +int tty_kinchan # kernel input channel of terminal +int tty_koutchan # kernel output channel of terminal +int tty_inlogchan # input spoolfile +int tty_outlogchan # output spoolfile +int tty_pbinchan # playback spoolfile +int tty_delay # playback delay/rec, msec +int tty_ip # pointer into tty_inbuf +int tty_filter # EPA of filter callback +int tty_filter_key # character key which triggers filter +bool tty_ucasein # map upper case input to lower case +bool tty_ucaseout # map output to upper case +bool tty_shiftlock # software shiftlock for ucasein mode +bool tty_rawmode # in raw terminal mode +bool tty_logio # logio logging in effect +bool tty_login # input logging in effect +bool tty_logout # output logging in effect +bool tty_playback # playback mode (cmd input from file) +bool tty_verify # pause when newline seen in input +bool tty_passthru # passthru mode (direct i/o to device) +char tty_iofile[SZ_FNAME] # name of logio spoolfile +char tty_infile[SZ_FNAME] # name of login spoolfile +char tty_outfile[SZ_FNAME] # name of logout spoolfile +char tty_pbfile[SZ_FNAME] # name of playback spoolfile +char tty_tdevice[SZ_DEVNAME] # terminal device at record time +char tty_gdevice[SZ_DEVNAME] # stdgraph device at record time +char tty_inbuf[SZ_LINE] # input line data buffer + +common /zttcom/ tty_kinchan, tty_koutchan, tty_inlogchan, tty_outlogchan, + tty_pbinchan, tty_delay, tty_ip, tty_filter, tty_filter_key, + tty_ucasein, tty_ucaseout, tty_shiftlock, tty_rawmode, tty_logio, + tty_login, tty_logout, tty_playback, tty_verify, tty_passthru, + tty_iofile, tty_infile, tty_outfile, tty_pbfile, tty_tdevice, + tty_gdevice, tty_inbuf diff --git a/sys/fio/zfiott.x b/sys/fio/zfiott.x new file mode 100644 index 00000000..ec7af7e8 --- /dev/null +++ b/sys/fio/zfiott.x @@ -0,0 +1,1256 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +# ZFIOTT -- Logical device driver for terminals. This VOS level driver +# implements various software terminal options as a transformation on the +# data stream to the hardware terminal driver "os$zfioty.c". In particular, +# the TT driver can transform input from a monocase terminal into the mixed +# case input required by IRAF, allowing IRAF to be used with old monocase +# terminals, and allowing the user to lock a dual case terminal into upper +# case if desired. The driver can also log i/o to a file, log the input +# or output streams to separate files, or take input from an input logfile +# (`playback' the command input in a file). + +define HELP "\ +\n\r[space or return to continue, g to turn verify off, q to quit]" + +define CONTINUE ' ' # execute command from logfile +define CONTINUE_ALT '\r' # alternative char to continue +define QUIT 'q' # terminate playback mode +define GO 'g' # continue with verify disabled +define CTRLCHAR '^' # used for shift escape functions +define SHIFTLOCK '+' # ^+ +define SHIFTOFF '-' # ^- +define BEGINCOM '{' # \{ comment \} +define ENDCOM '}' # \{ comment \} + +define RMARGIN 75 # for spoolfile output +define DONTCARE 2 # something other than YES or NO +define PBDELAY 500 # default delay in playback mode (msec) +define SZ_LOGLINE 4096 # max chars in a logfile record +define SZ_DEVNAME 20 # max size termcap/graphcap device name + +define IOFILE "home$ttyio.log" +define INFILE "home$ttyin.log" +define OUTFILE "home$ttyout.log" +define PBFILE "home$ttyin.log" + + +# ZGETTT -- Get a line of text from a terminal. Map the input to lower case +# if indicated, and not in raw mode. + +procedure zgettt (fd, buf, maxch, status) + +int fd # input file +char buf[ARB] # output buffer +int maxch # max chars out +int status # actual chars out + +pointer sp, logbuf +int nchars, ch, i +int ztt_lowercase(), ztt_query(), gstrcpy(), and() +include "zfiott.com" +define nextline_ 91 +define again_ 92 + +begin + # Set raw mode if reading a single character. + if (maxch == 1) + tty_rawmode = true + + if (tty_playback && !tty_passthru) { + # Read from the command input spoolfile. + + if (tty_inbuf[tty_ip] == EOS) { + call smark (sp) + call salloc (logbuf, SZ_LOGLINE, TY_CHAR) +nextline_ + call ztt_getlog (tty_pbinchan, Memc[logbuf], SZ_LOGLINE, nchars) + + if (nchars == 1 && Memc[logbuf] == EOFCHAR) { + call ztt_ttyput ("[EOF]\n") + status = 0 + + } else if (nchars > 0) { + # Process any \{ ... \} sequences in the line from the + # logfile, leave 'status' chars of data text in tty_inbuf. + + if (ztt_query (Memc[logbuf], nchars, + tty_inbuf, SZ_LINE, status) == QUIT) { + + # User commands us to quit. + tty_inbuf[1] = EOS + tty_ip = 1 + status = 0 + + } else { + # Copy data text to tty_inbuf. + tty_inbuf[status+1] = EOS + status = gstrcpy (tty_inbuf, buf, maxch) + tty_ip = status + 1 + + # If there was no data on the line but we get here, + # then the line must have been all control directive, + # so go fetch another line from the logfile. + + if (status == 0) + goto nextline_ + } + } else + status = nchars + + call sfree (sp) + + } else { + status = gstrcpy (tty_inbuf[tty_ip], buf, maxch) + tty_ip = tty_ip + status + if (!tty_verify || tty_rawmode) + call zwmsec (tty_delay) + } + + # Terminate playback if there is the read returns zero chars, + # unless this was due to a programmed EOF in the data stream. + + if (status <= 0 && Memc[logbuf] != EOFCHAR) { + call ztt_playback (NO) + call ztt_ttyput ("[playback mode terminated]\n") + buf[1] = '\n' + status = 1 + } + + } else { + # Read from the terminal. +again_ call zgetty (fd, buf, maxch, status) + + if (status > 0) { + # Some terminals set the parity bit, which may not be masked + # by the OS terminal driver in raw mode. Make sure that the + # parity bits are cleared. + + if (tty_rawmode) + do i = 1, status { + ch = buf[i] + buf[i] = and (ch, 177B) + } + + # Filter the input if a filter has been posted and the filter + # key is seen as the first character of the input data block. + # The filter edits the input buffer and returns the number of + # input characters left in the buffer after applying the filter. + + if (tty_filter != 0) + if (buf[1] == tty_filter_key) { + call zcall4 (tty_filter, fd, buf, maxch, status) + if (status == 0) + goto again_ + } + } + } + + # Log the input string if input logging is in effect. + if (tty_login && !tty_passthru) { + if (status <= 0) + call ztt_putlog (tty_inlogchan, "\032", 1) + else + call ztt_putlog (tty_inlogchan, buf, status) + } + + # If UCASE mode in set and not in raw mode, map the input string to + # lower case. + + if ((tty_ucasein || tty_ucaseout) && status > 0) + if (!tty_rawmode && tty_ucasein) + status = ztt_lowercase (buf, buf, status) +end + + +# ZPUTTT -- Put "nchars" characters into the text file "fd". Map the output +# to upper case if so indicated. Watch for the RAWOFF control string, used +# to turn raw mode off. + +procedure zputtt (fd, buf, nchars, status) + +int fd # file to be written to +char buf[ARB] # data to be output +int nchars # nchars to write to file +int status # return status + +int ch +pointer sp, obuf +bool ctrlstr +int strncmp() +include "zfiott.com" +define noucase_ 91 + +begin + # Do not map the raw-mode-off control sequence to upper case. + ctrlstr = false + if (tty_rawmode) + if (nchars == LEN_RAWCMD && buf[1] == ESC) + if (strncmp (buf, RAWOFF, LEN_RAWCMD) == 0) { + ctrlstr = true + tty_rawmode = false + } else if (strncmp (buf, RAWON, LEN_RAWCMD) == 0) { + ctrlstr = true + tty_rawmode = true + } + + if (tty_ucaseout) { + # If not control string and raw mode is not in effect, map the + # string to upper case and output it. Do not map escape or control + # sequences, i.e., any string which begins with a control character. + + if (!ctrlstr && !tty_rawmode) { + ch = buf[1] + if (ch < BLANK) + if (ch != HT && ch != LF && ch != FF && ch != CR) + goto noucase_ + + call smark (sp) + call salloc (obuf, SZ_LINE, TY_CHAR) + + call ztt_uppercase (buf, Memc[obuf], nchars) + call zputty (fd, Memc[obuf], nchars, status) + + if (tty_logout && !tty_passthru) + call ztt_putlog (tty_outlogchan, Memc[obuf], nchars) + + call sfree (sp) + return + } + } +noucase_ + call zputty (fd, buf, nchars, status) + if (tty_logout && !tty_passthru) + call ztt_putlog (tty_outlogchan, buf, nchars) +end + + +# ZTT_LOGIO -- Enable or disable logging of terminal i/o in a file. Logging +# is used for debug purposes but may also be used to keep a complete record +# of a terminal session. + +procedure ztt_logio (inflag, outflag) + +int inflag # log input stream (YES|NO|DONTCARE) +int outflag # log output stream (YES|NO|DONTCARE) + +int status +pointer sp, osfn, fname +string openerr "cannot open file " +include "zfiott.com" + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (osfn, SZ_PATHNAME, TY_CHAR) + + # Enable/disable logging of the input stream. + if (inflag == YES) { + if (tty_login) { + call zclstx (tty_inlogchan, status) + tty_inlogchan = NULL + tty_login = false + } + + if (tty_logio) + call strcpy (tty_iofile, Memc[fname], SZ_PATHNAME) + else + call strcpy (tty_infile, Memc[fname], SZ_PATHNAME) + + ifnoerr (call fmapfn (Memc[fname], Memc[osfn], SZ_PATHNAME)) { + call zopntx (Memc[osfn], APPEND, tty_inlogchan) + tty_login = (tty_inlogchan != ERR) + } + + if (tty_login) + call ztt_logdev (tty_inlogchan) + else { + call ztt_ttyput (openerr) + call ztt_ttyput (Memc[fname]) + call ztt_ttyput ("\n") + } + + } else if (inflag == NO && tty_login) { + call zclstx (tty_inlogchan, status) + tty_inlogchan = NULL + tty_login = false + if (tty_logio) { + tty_logout = false + tty_logio = false + } + } + + # If LOGIO mode is in effect, set the output logfile to the same + # as the input logfile, otherwise open the output logfile. + + if (tty_logio && tty_login) { + tty_logout = true + tty_outlogchan = tty_inlogchan + + } else if (outflag == YES) { + if (tty_logout) { + call zclstx (tty_outlogchan, status) + tty_outlogchan = NULL + tty_logout = false + } + + ifnoerr (call fmapfn (tty_outfile, Memc[osfn], SZ_PATHNAME)) { + call zopntx (Memc[osfn], APPEND, tty_outlogchan) + tty_logout = (tty_outlogchan != ERR) + } + + if (tty_logout) + call ztt_logdev (tty_outlogchan) + else { + call ztt_ttyput (openerr) + call ztt_ttyput (tty_outfile) + call ztt_ttyput ("\n") + } + + } else if (outflag == NO && tty_logout) { + call zclstx (tty_outlogchan, status) + tty_outlogchan = NULL + tty_logout = false + } + + call sfree (sp) +end + + +# ZTT_PLAYBACK -- Enable or disable playback mode. When playback mode is +# in effect command input is redirected to a tty logfile rather than to the +# terminal. Successive commands are read from the logfile and echoed on +# the terminal. If `verify' mode playback is enabled the user must then +# tap the space bar or CR to continue, at which time the line of text is +# returned to the calling program. Playback mode terminates when EOF is +# seen on the input file, or when the user types `q' in response to the +# verify query. + +procedure ztt_playback (flag) + +int flag # YES to enable playback, NO to disable + +int status +pointer sp, osfn +extern ztt_pboff() +string openerr "cannot open file " +include "zfiott.com" + +begin + call smark (sp) + call salloc (osfn, SZ_PATHNAME, TY_CHAR) + + if (flag == YES) { + # If we try to turn on playback mode while in login mode, log + # the command but do not interrupt login mode or try to reopen + # the ttyin.log file. The logged `stty playback' command will + # cause a (possibly infinite) loop when the logfile is later + # played back. + + if (tty_login) { + call ztt_ttyput ("[command logged but not executed]\n") + call sfree (sp) + return + } + + # Clear playback mode if already in effect. + if (tty_playback) { + call zclstx (tty_pbinchan, status) + tty_pbinchan = NULL + tty_playback = false + } + + # Open login file. + ifnoerr (call fmapfn (tty_pbfile, Memc[osfn], SZ_PATHNAME)) { + call zopntx (Memc[osfn], READ_ONLY, tty_pbinchan) + tty_playback = (tty_pbinchan != ERR) + } + + # Setup to clear playback mode if error occurs during playback. + if (tty_playback) { + call onerror (ztt_pboff) + tty_tdevice[1] = EOS + tty_gdevice[1] = EOS + } else { + call ztt_ttyput (openerr) + call ztt_ttyput (tty_pbfile) + call ztt_ttyput ("\n") + } + + } else if (flag == NO && tty_playback) { + # Clear playback mode. + + call zclstx (tty_pbinchan, status) + tty_pbinchan = NULL + tty_playback = false + } + + call sfree (sp) +end + + +# ZTT_PBOFF -- Called during error recovery to disable playback mode. + +procedure ztt_pboff (errcode) + +int errcode # error status + +int status +include "zfiott.com" + +begin + if (errcode != OK && tty_playback) { + call zclstx (tty_pbinchan, status) + tty_pbinchan = NULL + tty_playback = false + tty_rawmode = false + tty_passthru = false + } +end + + +# ZTT_LOGDEV -- Record the names of the terminal and stdgraph devices in a +# logfile. The format ("\X=devname\n") MUST agree with that in ztt_getlog. +# Also timestamp the logfile. + +procedure ztt_logdev (chan) + +int chan # output file + +int status +pointer sp, obuf, devname +int envfind(), strlen() + +begin + call smark (sp) + call salloc (obuf, SZ_LINE, TY_CHAR) + call salloc (devname, SZ_FNAME, TY_CHAR) + + # Timestamp the new entry in the logfile. + call strcpy ("\O=", Memc[obuf], SZ_LINE) + call sysid (Memc[obuf+3], SZ_LINE-3) + call strcat ("\n", Memc[obuf], SZ_LINE) + call zputtx (chan, Memc[obuf], strlen(Memc[obuf]), status) + + if (envfind ("terminal", Memc[devname], SZ_FNAME) > 0) { + call strcpy ("\T=", Memc[obuf], SZ_LINE) + call strcat (Memc[devname], Memc[obuf], SZ_LINE) + call strcat ("\n", Memc[obuf], SZ_LINE) + call zputtx (chan, Memc[obuf], strlen(Memc[obuf]), status) + } + if (envfind ("stdgraph", Memc[devname], SZ_FNAME) > 0) { + call strcpy ("\G=", Memc[obuf], SZ_LINE) + call strcat (Memc[devname], Memc[obuf], SZ_LINE) + call strcat ("\n", Memc[obuf], SZ_LINE) + call zputtx (chan, Memc[obuf], strlen(Memc[obuf]), status) + } + + call sfree (sp) +end + + +# ZTT_PUTLOG -- Put a message to the logfile. All characters in the data +# string are rendered into printable form. Long lines are broken and the +# output is followed by a newline. + +procedure ztt_putlog (chan, dstr, nchars) + +int chan # kernel i/o channel +char dstr[ARB] # data string +int nchars # length of data string (0 if EOS delimited) + +char cch +pointer sp, obuf, op +int status, ip, ch, n +int strlen(), ctocc() +define output {Memc[op]=($1);op=op+1} +include "zfiott.com" + +begin + # It is harmless to call us if logging is disabled. + if (!tty_login && !tty_logout) + return + + call smark (sp) + call salloc (obuf, SZ_LINE, TY_CHAR) + + n = nchars + if (n <= 0) + n = strlen (dstr) + + # Output the data string, rendering all characters into printable form. + # Break long lines. The characters \ and ^ must be escaped since they + # are logfile metacharacters. Data spaces are output as \s since + # whitespace in the logfile is ignored. + + op = obuf + do ip = 1, n { + ch = dstr[ip] + if (ch == ' ') { + output ('\\') + output ('s') + } else if (ch == '^' || ch == '\\') { + output ('\\') + output (ch) + } else if (IS_PRINT (ch)) { + output (ch) + } else if (ch == NUL) { + output ('^') + output ('@') + } else { + cch = ch + op = op + ctocc (cch, Memc[op], 5) + } + + if (op - obuf >= RMARGIN && ip+1 < n) { + output ('\\') + output ('\n') + call zputtx (chan, Memc[obuf], op-obuf, status) + for (op=obuf; op < obuf+4; op=op+1) + Memc[op] = ' ' + } + } + + # Terminate and output the line. + if (op > obuf) { + output ('\n') + call zputtx (chan, Memc[obuf], op-obuf, status) + call zflstx (chan, status) + } + + call sfree (sp) +end + + +# ZTT_GETLOG -- Read text from a logfile written by ztt_putlog. All control +# codes and spaces are rendered into escape sequences; newline marks the end +# of each record and an escaped newline followed by leading whitespace on a +# line indicates continuation. Blank lines in the logfile equate to null +# length records and are ignored. + +procedure ztt_getlog (chan, obuf, maxch, nchars) + +int chan # kernel input channel (text file) +char obuf[maxch] # output buffer +int maxch # max chars to return +int nchars # nchars returned or EOF + +bool incom +int lastch, ch, op, o +char cch, cc[4], devname[SZ_DEVNAME] +int ztt_getchar(), cctoc() +include "zfiott.com" + +begin + # Process characters and escape sequence encoded characters from + # the logfile until either maxch character have been output or an + # unescaped newline is seen. Ignore empty lines. Text enclosed + # in \{ ... \} (comment text) is returned without change. + + incom = false + ch = NULL + + for (op=1; op <= 1 && ch != EOF; ) { + while (op <= maxch) { + # Get the next character (not efficient, but doesn't matter + # since this is only called in `stty playback' mode). + + if (ztt_getchar (chan, ch) == EOF) { + break + } else if (IS_WHITE (ch) && !incom) { + next + } else if (ch == '\n' && !incom) { + break + + } else if (ch == '^') { + # Map a control code, e.g., ^[. + if (ztt_getchar (chan, ch) == EOF) + break + ch = mod (ch, 40B) + + } else if (ch == '\\') { + # Map an escape sequence, e.g., \n, \r, \^, \040, etc. + if (ztt_getchar (chan, ch) == EOF) + break + + switch (ch) { + case '\n': + next + case 's': + ch = ' ' + # output ch, below + + case BEGINCOM, ENDCOM: + # Copy a \{ ... \} logfile comment (to be echoed but + # not returned as data). + + obuf[op] = '\\' + op = op + 1 + obuf[op] = ch + op = op + 1 + + incom = (ch == BEGINCOM) + next + + case 'T', 'G', 'O', '#': + # Recall a terminal or stdgraph device name from the + # logfile (device used when logfile was written). + # The format must be "\X=devname\n". \O is the + # timestamp string, which we simply read and discard. + # \# is for logfile comments. + + lastch = ch + o = 1 + repeat { + if (ztt_getchar (chan, ch) == EOF) + break + else if (ch == '\n') + break + else { + devname[o] = ch + o = min (SZ_DEVNAME, o + 1) + } + } + devname[o] = EOS + + if (lastch == 'T') + call strcpy (devname[2], tty_tdevice, SZ_DEVNAME) + else if (lastch == 'G') + call strcpy (devname[2], tty_gdevice, SZ_DEVNAME) + next + + case '^', '\\': + # output ch, below + + default: + cc[1] = '\\' + cc[2] = ch + if (IS_DIGIT (ch)) { + for (o=3; o <= 4; o=o+1) + if (ztt_getchar (chan, ch) == EOF) + break + else + cc[o] = ch + cc[o] = EOS + } else + cc[3] = EOS + o = 1; o = cctoc (cc, o, cch) + ch = cch + # output ch, below + } + } + + obuf[op] = ch + op = op + 1 + } + } + + nchars = op - 1 +end + + +# ZTT_QUERY -- Called in playback mode to echo a line of logfile input text to +# the terminal and wait for the user to tap the CONTINUE key to continue. +# If the response is QUIT playback mode is terminated and input is restored +# to the terminal. If the response is GO verify mode is disabled for the +# remainder of the playback session. It would be easy for us to allow the +# user to edit the command line rather than just accept it, but this could too +# easily cause loss of sync with the input logfile, hence is not allowed. +# Echoing and verify are disabled if raw mode is in effect. + +int procedure ztt_query (logtext, nchars, dtext, maxch, sz_dtext) + +char logtext[ARB] # line of text from logfile +int nchars # nchars in logfile text +char dtext[maxch] # line of text to be returned from zgettt +int maxch # max chars returned +int sz_dtext # actual chars returned + +char text[1] +pointer sp, etext, ep +bool learn, incom, verify, format_control +int status, delay, ip_save, ip, op, ch, n + +int ctoi() +include "zfiott.com" +define done_ 91 +define deposit_ 92 + +begin + call smark (sp) + call salloc (etext, SZ_LINE, TY_CHAR) + + # The logfile line may contain embedded sequences of text which are + # to be echoed to the terminal, but which are not to be returned as + # data to the calling program. This comment or explanatory text is + # enclosed in braces as "\{ ... \}". Control over the verify/delay + # parameters may be specified for the command block by modifying + # the opening sequence, i.e., "\{%V+ ..." sets verify mode for the + # block, "\{%V-" disables verify mode, and "\{%NNNN sets the delay + # to NNNN msec. A leading !, e.g., "%!V+" causes the change to be + # "learned", i.e., the control parameter is permanently changed. + + verify = (tty_verify && !tty_rawmode) + delay = tty_delay + incom = false + ep = etext + op = 1 + + # Process the logfile text into the text to be echoed and the data + # (obuf) text to be returned to the calling program. + + format_control = false + for (ip=1; ip <= nchars; ) { + if (logtext[ip] == '\\') { + if (ip < nchars && logtext[ip+1] == BEGINCOM) { + # Begin comment section. + ip = ip + 2 + incom = true + + # Check for the verify/delay overrides. + while (logtext[ip] == '%') { + ip_save = ip + ip = ip + 1 + + # If !V+ or !delay, learn new value. + learn = (logtext[ip] == '!') + if (learn) + ip = ip + 1 + + if (logtext[ip] == 'V') { + ip = ip + 1 + if (logtext[ip] == '+') { + verify = true + if (learn) + tty_verify = true + ip = ip + 1 + } else if (logtext[ip] == '-') { + verify = false + if (learn) + tty_verify = false + ip = ip + 1 + } else + ip = ip_save + } else if (IS_DIGIT (logtext[ip])) { + if (ctoi (logtext, ip, delay) <= 0) { + delay = tty_delay + ip = ip_save + } else if (learn) + tty_delay = delay + } + + if (ip > ip_save) + format_control = true + else + break + } + + } else if (incom && ip < nchars && logtext[ip+1] == ENDCOM) { + # End comment section. + ip = ip + 2 + incom = false + } else + goto deposit_ + + } else { +deposit_ # Do not include the trailing data-newline in the echo text. + if (incom || (!tty_rawmode && logtext[ip] != '\n')) { + Memc[ep] = logtext[ip] + ep = ep + 1 + } + if (logtext[ip] == '\n' && ip < nchars) { + if (ep > etext) { + n = ep - etext + call zputty (tty_koutchan, Memc[etext], ep-etext, n) + call zflsty (tty_koutchan, status) + } + ep = etext + } + if (!incom) { + op = min (maxch, op) + dtext[op] = logtext[ip] + op = op + 1 + } + ip = ip + 1 + } + } + + # Don't need to add EOS for counted kernel i/o strings. + sz_dtext = op - 1 + + # Output any remaining echo text. + if (ep > etext) { + n = ep - etext + call zputty (tty_koutchan, Memc[etext], n, status) + call zflsty (tty_koutchan, status) + ep = etext + } + + # Do not verify or delay for blank lines with no format control. + if (!format_control && sz_dtext == 1 && dtext[1] == '\n') { + ch = NULL + goto done_ + } + + # If verify is disabled, return after the specified delay. + if (!verify) { + call zwmsec (delay) + ch = NULL + goto done_ + } + + # If verify is enabled, wait for user response. Note that the 1 + # char read leaves the terminal in raw mode. + + repeat { + call zgetty (tty_kinchan, text, 1, status) + if (status > 0) + ch = text[1] + else + ch = EOF + + if (ch == EOF || ch == INTCHAR || ch == QUIT) { + call ztt_playback (NO) + ch = QUIT + break + } else if (ch == GO) { + tty_verify = false + break + } else if (ch == CONTINUE || ch == CONTINUE_ALT) { + break + } else { + # Ignore other characters. + call ztt_ttyput (HELP) + } + } + + # Restore terminal to line mode, if raw mode was not already in + # effect before our query. + + if (!tty_rawmode) + call ztt_ttyput (RAWOFF) + +done_ + if (dtext[sz_dtext] == '\n') + call ztt_ttyput ("\n") + + call sfree (sp) + return (ch) +end + + +# ZTT_GETCHAR -- Get a character from a channel. + +int procedure ztt_getchar (chan, ch) + +int chan # input channel +int ch # receives character + +char text[1] +int status + +begin + call zgettx (chan, text, 1, status) + if (status <= 0) { + ch = EOF + return (EOF) + } else { + ch = text[1] + return (ch) + } +end + + +# ZTT_LOWERCASE -- Map a character string input in upper case to lower case. +# Control sequences may be embedded in the sequence to artifically generate +# upper case characters. +# +# ^ shift up next character +# ^+ shift lock (stay in upper case) +# ^- clear shift lock +# ^^ a single ^ +# +# The case shift control sequences are shown above. These are not recognized +# when the terminal is in raw mode. + +int procedure ztt_lowercase (in, out, nchars) + +char in[ARB] # input string +char out[ARB] # output string +int nchars # input string length + +int ch +int ip, op +include "zfiott.com" + +begin + op = 1 + for (ip=1; ip <= nchars; ip=ip+1) { + ch = in[ip] + + if (ch == CTRLCHAR) { + ch = in[ip+1] + ip = ip + 1 + + switch (ch) { + case CTRLCHAR: + out[op] = ch + op = op + 1 + case SHIFTLOCK: + tty_shiftlock = true + case SHIFTOFF: + tty_shiftlock = false + default: + if (IS_LOWER (ch)) + ch = TO_UPPER (ch) + out[op] = ch + op = op + 1 + } + } else if (tty_shiftlock) { + if (IS_LOWER (ch)) + ch = TO_UPPER (ch) + out[op] = ch + op = op + 1 + } else { + if (IS_UPPER (ch)) + ch = TO_LOWER (ch) + out[op] = ch + op = op + 1 + } + } + + return (op - 1) +end + + +# ZTT_UPPERCASE -- Convert a string to upper case. + +procedure ztt_uppercase (in, out, nchars) + +char in[ARB] # input string +char out[ARB] # output string +int nchars # string length + +int ch, i + +begin + do i = 1, nchars { + ch = in[i] + if (IS_LOWER (ch)) + ch = TO_UPPER (ch) + out[i] = ch + } +end + + +# ZTT_TTYPUT -- Write directly to the user terminal. + +procedure ztt_ttyput (message) + +char message[ARB] # message string + +int status +int stridxs(), strlen() +include "zfiott.com" + +begin + call zputty (tty_koutchan, message, strlen(message), status) + if (stridxs ("\n", message) > 0) + call zflsty (tty_koutchan, status) +end + + +# ZSETTT -- Set TT terminal driver options. Must be called before any i/o is +# done via the TT driver, e.g., by fio$finit. + +procedure zsettt (chan, param, value) + +int chan # kernel i/o channel (not used) +int param # parameter to be set +int value # new value + +bool itob() +bool first_time +data first_time /true/ +include "zfiott.com" + +begin + switch (param) { + case TT_INITIALIZE: + if (!first_time) { + # Close any open log files. + call ztt_playback (NO) + call ztt_logio (NO, NO) + } + + tty_inlogchan = NULL + tty_outlogchan = NULL + tty_pbinchan = NULL + tty_ucasein = false + tty_ucaseout = false + tty_shiftlock = false + tty_rawmode = false + tty_logio = false + tty_login = false + tty_logout = false + tty_playback = false + tty_verify = false + tty_passthru = false + tty_delay = PBDELAY + tty_filter = NULL + tty_filter_key = 0 + + call strcpy (IOFILE, tty_iofile, SZ_FNAME) + call strcpy (INFILE, tty_infile, SZ_FNAME) + call strcpy (OUTFILE, tty_outfile, SZ_FNAME) + call strcpy (PBFILE, tty_pbfile, SZ_FNAME) + + tty_tdevice[1] = EOS + tty_gdevice[1] = EOS + tty_inbuf[1] = EOS + tty_ip = 1 + + first_time = false + + case TT_KINCHAN: + tty_kinchan = value + case TT_KOUTCHAN: + tty_koutchan = value + case TT_LOGINCHAN: + tty_inlogchan = value + case TT_LOGOUTCHAN: + tty_outlogchan = value + case TT_PBINCHAN: + tty_pbinchan = value + case TT_SHIFTLOCK: + tty_shiftlock = itob (value) + case TT_RAWMODE: + tty_rawmode = itob (value) + + case TT_UCASEIN: + tty_ucasein = itob (value) + case TT_UCASEOUT: + tty_ucaseout = itob (value) + + case TT_LOGIO: + tty_logio = true + call ztt_logio (value, value) + case TT_LOGIN: + tty_logio = false + call ztt_logio (value, DONTCARE) + case TT_LOGOUT: + tty_logio = false + call ztt_logio (DONTCARE, value) + case TT_PASSTHRU: + tty_passthru = itob (value) + + case TT_PLAYBACK: + call ztt_playback (value) + case TT_PBVERIFY: + tty_verify = itob (value) + case TT_PBDELAY: + tty_delay = value + + case TT_FILTER: + tty_filter = value + case TT_FILTERKEY: + tty_filter_key = value + + default: + # (ignore) + } +end + + +# ZSTTTT -- Stat TT terminal driver options. Check for the special TT params, +# else pass the request to the hardware driver. + +procedure zstttt (fd, param, lvalue) + +int fd # file number (not used) +int param # parameter to be set +long lvalue # new value + +int btoi() +include "zfiott.com" + +begin + switch (param) { + case TT_KINCHAN: + lvalue = tty_kinchan + case TT_KOUTCHAN: + lvalue = tty_koutchan + case TT_LOGINCHAN: + lvalue = tty_inlogchan + case TT_LOGOUTCHAN: + lvalue = tty_outlogchan + case TT_PBINCHAN: + lvalue = tty_pbinchan + case TT_UCASEIN: + lvalue = btoi (tty_ucasein) + case TT_UCASEOUT: + lvalue = btoi (tty_ucaseout) + case TT_SHIFTLOCK: + lvalue = btoi (tty_shiftlock) + case TT_RAWMODE: + lvalue = btoi (tty_rawmode) + case TT_LOGIO: + lvalue = btoi (tty_logio) + case TT_LOGIN: + lvalue = btoi (tty_login) + case TT_LOGOUT: + lvalue = btoi (tty_logout) + case TT_PASSTHRU: + lvalue = btoi (tty_passthru) + case TT_PLAYBACK: + lvalue = btoi (tty_playback) + case TT_PBVERIFY: + lvalue = btoi (tty_verify) + case TT_PBDELAY: + lvalue = tty_delay + case TT_FILTER: + lvalue = tty_filter + case TT_FILTERKEY: + lvalue = tty_filter_key + default: + call zsttty (fd, param, lvalue) + } +end + + +# ZSESTT -- Set a TT terminal driver string valued option. + +procedure zsestt (fd, param, svalue) + +int fd # file number (not used) +int param # parameter to be set +char svalue[ARB] # new value + +include "zfiott.com" + +begin + switch (param) { + case TT_IOFILE: + call strcpy (svalue, tty_iofile, SZ_FNAME) + case TT_INFILE: + call strcpy (svalue, tty_infile, SZ_FNAME) + case TT_OUTFILE: + call strcpy (svalue, tty_outfile, SZ_FNAME) + case TT_PBFILE: + call strcpy (svalue, tty_pbfile, SZ_FNAME) + case TT_TDEVICE: + call strcpy (svalue, tty_tdevice, SZ_DEVNAME) + case TT_GDEVICE: + call strcpy (svalue, tty_gdevice, SZ_DEVNAME) + default: + # (ignore) + } +end + + +# ZSTSTT -- Stat TT terminal driver string valued option. + +procedure zststt (fd, param, outstr, maxch, nchars) + +int fd # file number (not used) +int param # parameter to be set +char outstr[maxch] # string value +int maxch # max chars out +int nchars # len (outstr) + +int gstrcpy() +include "zfiott.com" + +begin + switch (param) { + case TT_IOFILE: + nchars = gstrcpy (tty_iofile, outstr, maxch) + case TT_INFILE: + nchars = gstrcpy (tty_infile, outstr, maxch) + case TT_OUTFILE: + nchars = gstrcpy (tty_outfile, outstr, maxch) + case TT_PBFILE: + nchars = gstrcpy (tty_pbfile, outstr, maxch) + case TT_TDEVICE: + nchars = gstrcpy (tty_tdevice, outstr, maxch) + case TT_GDEVICE: + nchars = gstrcpy (tty_gdevice, outstr, maxch) + default: + nchars = 0 + } +end + + +# The following functions are straight pass throughs to the hardware +# driver for this device. +# -------------------------- + +# ZOPNTT -- Open a terminal. + +procedure zopntt (osfn, mode, chan) + +char osfn[ARB] # UNIX filename +int mode # file access mode +int chan # UNIX channel of file (output) + +begin + call zopnty (osfn, mode, chan) +end + + +# ZCLSTT -- Close a terminal. + +procedure zclstt (fd, status) + +int fd # channel +int status # return status + +begin + call zclsty (fd, status) +end + + +# ZFLSTT -- Flush any buffered terminal output. + +procedure zflstt (fd, status) + +int fd # channel +int status # return status + +begin + call zflsty (fd, status) +end + + +# ZSEKTT -- Seek on a text file to the character offset given by a prior +# call to ZNOTTT. This offset should always refer to the beginning of a line. +# (not used for terminals). + +procedure zsektt (fd, offset, status) + +int fd # channel +long offset # new offset +int status # return status + +begin + call zsekty (fd, offset, status) +end + + +# ZNOTTT -- Return the seek offset of the beginning of the current line +# of text (not used for terminals). + +procedure znottt (fd, offset) + +int fd # channel +long offset # file offset + +begin + call znotty (fd, offset) +end diff --git a/sys/fio/zzdebug.x b/sys/fio/zzdebug.x new file mode 100644 index 00000000..1e7179fc --- /dev/null +++ b/sys/fio/zzdebug.x @@ -0,0 +1,625 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include + + +# ZZDEBUG -- Debug tasks for the FIO (file i/o) interface. + +task mpp = t_mpp, + unget = t_unget, + pbb = t_pbb, + fnl = t_fnl, + txo = t_txo, + bfap = t_bfappend, + spool = t_spool, + many = t_many, + server = t_server, + client = t_client, + oserver = t_old_server, + oclient = t_old_client, + daytime = t_daytime, + http = t_http, + utime = t_utime, + symlink = t_symlink, + unlink = t_unlink + + +define SZ_BUF 2048 + + +# MPP -- Test macro pushback. + +procedure t_mpp() + +int fd +char ch +char getc() + +begin + fd = STDIN + + while (getc (fd, ch) != EOF) { + if (ch == '%') { + ch = '$' + call ungetc (fd, ch) + } else if (ch == '\n') { + call putchar (ch) + call flush (STDOUT) + } else if (ch == '^') { + call ungetline (fd, "carat") + } else if (ch == '&') { + call ungetline (fd, "amper%sand") + } else + call putchar (ch) + } +end + + +# UNGET-- Test ungetline. + +procedure t_unget() + +char lbuf[SZ_LINE] +int getline() + +begin + while (getline (STDIN, lbuf) != EOF) { + if (lbuf[1] == '.') { + call ungetline (STDIN, lbuf[2]) + call ungetline (STDIN, "pbb\n") + } else { + call putline (STDOUT, lbuf) + call flush (STDOUT) + } + call fdebug (STDOUT, STDIN, STDIN) + } +end + + +# PBB -- Test multilevel pushback. + +procedure t_pbb() + +char lbuf[SZ_LINE] +int fd +int getline() +include + +begin + fd = STDIN + fp = fiodes[fd] + + call fdebug (STDERR, fd, fd) + call ungetline (fd, "aaa\n") + call fdebug (STDERR, fd, fd) + call ungetline (fd, "bbb\n") + call fdebug (STDERR, fd, fd) + call ungetline (fd, "ccc\n") + call fdebug (STDERR, fd, fd) + call ungetline (fd, "ddd\n") + call fdebug (STDERR, fd, fd) + + call eprintf ("pbb='%s'\n\n"); call pargstr (FPBBUF(fp)) + + while (getline (fd, lbuf) != EOF) { + call putline (STDERR, lbuf) + call fdebug (STDERR, fd, fd) + } +end + + +# FNL -- Test filename template expansion. + +procedure t_fnl() + +char fname[SZ_FNAME] +int list, clpopns(), clgfil(), clplen() + +begin + list = clpopns ("files") + call printf ("nfiles = %d\n"); call pargi (clplen(list)) + + while (clgfil (list, fname, SZ_FNAME) != EOF) { + call printf ("%s\n"); call pargstr (fname) + } + + call clpcls (list) +end + + +# TXO -- Test the mixing of PUTC, PUTLINE, and WRITE calls to a text file. + +procedure t_txo() + +int fd, i, j +int open() + +begin + fd = open ("junk", NEW_FILE, TEXT_FILE) + + do i = 1, 5 { + do j = 1, 5 + call putci (fd, 'a' + i - 1) + call putline (fd, "12345") + call write (fd, "_6789[] ", 8) + } + + call close (fd) +end + + +# BFAP -- Test appending to a binary file. Should create the file and then +# add an unpacked line of text in each successive call. + +procedure t_bfappend() + +int fd +int open(), strlen() +string text "1234567890\n" + +begin + fd = open ("_bf", APPEND, BINARY_FILE) + call fdebug (STDERR, fd, fd) + call write (fd, text, strlen(text)) + call fdebug (STDERR, fd, fd) + call close (fd) +end + + +# SPOOL -- Test the spoolfile file type. + +procedure t_spool() + +int fd, i, j, n +int open(), read() + +begin + fd = open ("spool", READ_WRITE, SPOOL_FILE) + call fdebug (STDERR, fd, fd) + + call eprintf ("write test data\n") + do i = 1, 10000 + call write (fd, i, SZ_INT) + + call fdebug (STDERR, fd, fd) + call eprintf ("rewind file:\n") + call seek (fd, BOFL) + call fdebug (STDERR, fd, fd) + + call eprintf ("read back test data\n") + do i = 1, 10000 { + n = read (fd, j, SZ_INT) + if (n < SZ_INT || i != j) { + call eprintf ("read failure at word %d=%d of 10000, stat=%d\n") + call pargi (i) + call pargi (j) + call pargi (n) + } + } + + call eprintf ("test successful\n") + call close (fd) +end + + +# MANY -- Test what happens when we try to open too many files. + +procedure t_many() + +char fname[SZ_FNAME] +int list, nfiles, fd +int open(), fntopn(), fntgfn() + +begin + list = fntopn ("fio$*.x") + + for (nfiles=1; fntgfn(list,fname,SZ_FNAME) != EOF; nfiles=nfiles+1) { + fd = open (fname, READ_ONLY, TEXT_FILE) + call eprintf ("%d %s\n") + call pargi (nfiles) + call pargstr (fname) + } + + call fntcls (list) +end + + +# SERVER -- Simple ND server for testing the network driver. This server +# listens on the specified port and waits for a client connection, then +# returns a status message for every message received from the client, +# shutting down when the client exits. + +procedure t_server() + +char buf[SZ_BUF] +int fdi, fdo, nb, i +int ndopen(), read(), reopen() + +begin + do i = 1, 5 { + call printf ("server waiting for connection\n") + fdi = ndopen ("unix:/tmp/nd:text", NEW_FILE) + fdo = reopen (fdi, READ_WRITE) + + call printf ("fdin = %d fdout = %d\n") + call pargi (fdi) ; call pargi (fdo) + + call fdebug (STDOUT, fdi, fdo) + call flush (STDOUT) + + repeat { + nb = read (fdi, buf, SZ_BUF) + if (nb > 0) { + call fprintf (STDOUT, "read %d bytes from client\n") + call pargi (nb) + call flush (STDOUT) + + call fprintf (fdo, "read %d bytes from client\n") + call pargi (nb) + call flush (fdo) + } + } until (nb <= 0) + + call printf ("client has disconnected\n") + call close (fdi) + call close (fdo) + } +end + + +# CLIENT -- Connect to the server on the given port and send a number of +# test messages, then close the connection and exit. + +procedure t_client() + +char buf[SZ_BUF] +int fdi, fdo, n, i, msglen +int msgsize[8] + +int ndopen(), read(), reopen() +data msgsize /64, 128, 256, 134, 781, 3, 19, 1544/ + +begin + fdi = ndopen ("unix:/tmp/nd:text", READ_WRITE) + fdo = reopen (fdi, READ_WRITE) + + call printf ("fdin = %d fdout = %d\n") + call pargi (fdi) ; call pargi (fdo) + + call fdebug (STDOUT, fdi, fdo) + call flush (STDOUT) + + for (i=1; i <= 5; i=i+1) { + msglen = msgsize[mod(i,8)+1) + call printf ("send %d chars to server\n") + call pargi (msglen) + + call write (fdo, buf, msglen) + call flush (fdo) + + n = read (fdi, buf, SZ_BUF) + if (n > 0) { + buf[n+1] = EOS + call printf ("read %d bytes from server\n") + call pargi (n) + call printf ("server: %s\n") + call pargstr (buf) + } else { + call printf ("server has disconnected\n") + break + } + call flush (STDOUT) + } + + call close (fdi) + call close (fdo) +end + + +# SERVER -- Simple ND server for testing the network driver. This server +# listens on the specified port and waits for a client connection, then +# returns a status message for every message received from the client, +# shutting down when the client exits. +# +# To test the ND driver, start up two copies of zzdebug.e, one running the +# server task and the other the client task. Give the same value of "port" +# to both, and start the server. It will pause waiting for a client. Then +# start a test sequence in the client setting "nmsg" to the number of +# messages to be exchanged. The client will send nmsg messages of various +# sizes to the server and echo on the stdout the response returned by the +# server. +# +# NOTE - this is the original version, before adding support for "reopen" +# to have two fully streaming file descriptors per connection. + +procedure t_old_server() + +char port[SZ_LINE] +char buf[SZ_BUF] +int fd, sum, n, maxconn, i +int ndopen(), read(), checksum(), clgeti() + +begin + call clgstr ("port", port, SZ_LINE) + maxconn = clgeti ("maxconn") + if (maxconn <= 0) + maxconn = 9999 + + do i = 1, maxconn { + call printf ("server waiting for connection\n") + fd = ndopen (port, NEW_FILE) + + repeat { + call fseti (fd, F_CANCEL, YES) + n = read (fd, buf, SZ_BUF) + if (n > 0) { + call fseti (fd, F_CANCEL, YES) + sum = checksum (buf, n) + call fprintf (fd, "read %d bytes from client, sum=%x") + call pargi (n) + call pargi (sum) + call flush (fd) + } + } until (n <= 0) + + call printf ("client has disconnected\n") + call close (fd) + } +end + + +# CLIENT -- Connect to the server on the given port and send a number of +# test messages, then close the connection and exit. +# +# NOTE - this is the original version, before adding support for "reopen" +# to have two fully streaming file descriptors per connection. + +procedure t_old_client() + +char buf[SZ_BUF] +char port[SZ_LINE] +int fd, nmsg, n, i, msglen +int msgsize[8] + +int ndopen(), read(), clgeti(), checksum() +data msgsize /64, 128, 256, 134, 781, 3, 19, 1544/ + +begin + call clgstr ("port", port, SZ_LINE) + nmsg = clgeti ("nmsg") + + fd = ndopen (port, READ_WRITE) + + for (i=1; i <= nmsg; i=i+1) { + msglen = msgsize[mod(i,8)+1) + call printf ("send %d chars to server, sum=%x\n") + call pargi (msglen) + call pargi (checksum (buf, msglen)) + + call fseti (fd, F_CANCEL, YES) + call write (fd, buf, msglen) + call flush (fd) + + call fseti (fd, F_CANCEL, YES) + n = read (fd, buf, SZ_BUF) + if (n > 0) { + buf[n+1] = EOS + call printf ("server: %s\n") + call pargstr (buf) + } else { + call printf ("server has disconnected\n") + break + } + call flush (STDOUT) + } + + call close (fd) +end + + +# DAYTIME -- Connect to the daytime service on the local host and print +# out what it returns. + +procedure t_daytime() + +int fd, nchars, ip +char hostname[SZ_FNAME] +char line[SZ_LINE], netpath[SZ_LINE] +int ndopen(), read(), strlen() + +begin + # Open the daytime service on the named host or the local host. + call clgstr ("host", hostname, SZ_FNAME) + if (strlen(hostname) > 0) { + call sprintf (netpath, SZ_LINE, "inet:daytime:%s") + call pargstr (hostname) + iferr (fd = ndopen (netpath, READ_WRITE)) { + call printf ("cannot access host\n") + return + } + } else { + iferr (fd = ndopen("inet:daytime",READ_WRITE)) + call printf("fail 1\n") + iferr (fd = ndopen("inet:daytime:localhost",READ_WRITE)) + call printf("fail 2\n") + } + + # Read and print the daytime text. + call fseti (fd, F_CANCEL, OK) + nchars = read (fd, line, SZ_LINE) + if (nchars > 0) { + call strupk (line, line, SZ_LINE) + for (ip=1; line[ip] != EOS; ip=ip+1) + if (line[ip] == '\n') { + line[ip] = EOS + break + } + call printf ("%s\n") + call pargstr (line) + } + + call close (fd) +end + + +# HTTP -- Connect to a HTTP server on the given host, read a URL and print +# what it returns. + +procedure t_http() + +bool done +int fd, nchars, lastch +char hostname[SZ_FNAME], buf[SZ_BUF] +char netpath[SZ_LINE], path[SZ_LINE] +int ndopen(), read() + +begin + # Connect to HTTP server (default port 80) on the given host. + call clgstr ("host", hostname, SZ_FNAME) + call sprintf (netpath, SZ_LINE, "inet:80:%s:text") + call pargstr (hostname) + iferr (fd = ndopen (netpath, READ_WRITE)) { + call printf ("cannot access host\n") + return + } + + # Get the URL/URI (file pathname) to be read. + call clgstr ("path", path, SZ_LINE) + + # Send the get-url request to the server. + call fprintf (fd, "GET %s HTTP/1.0\n\n") + call pargstr (path) + call flush (fd) + + # Read and print the given URL. The returned text consists of the + # HTTP protocol header, a blank line, then the document text. + # Since this is a debug routine we output the protocol header as + # well as the document, but a real program would probably strip + # the header since it is not part of the document data. + + repeat { + call fseti (fd, F_CANCEL, OK) + nchars = read (fd, buf, SZ_BUF) + if (nchars > 0) { + buf[nchars+1] = EOS + call putline (STDOUT, buf) + lastch = buf[nchars] + done = false + } else + done = true + } until (done) + + if (lastch != '\n') + call putline (STDOUT, "\n") + + call close (fd) +end + + +# CHECKSUM -- Compute the checksum of a data buffer. + +int procedure checksum (buf, nchars) + +char buf[ARB] #I input buffer +int nchars #I number of chars + +int sum, i + +begin + sum = 0 + do i = 1, nchars { + if (and (sum, 1) != 0) + sum = sum / 2 + 8000X + else + sum = sum / 2 + sum = sum + buf[i] + sum = and (sum, 0FFFFX) + } + + return (sum) +end + + +# UTIME -- Test file modify time updates. + +procedure t_utime () + +char fname[SZ_LINE] +int offset +long fi[LEN_FINFO] + +int futime(), finfo(), clgeti() + +begin + # Get parameters. + call clgstr ("fname", fname, SZ_LINE) + offset = clgeti ("offset") + + # Get initial file times. + if (finfo (fname, fi) == ERR) + call syserrs (SYS_FOPEN, fname) + call printf ("Initial times: atime = %d mtime = %d\n") + call pargl (FI_ATIME(fi)) + call pargl (FI_MTIME(fi)) + + + # Update the time by the offset. + if (futime (fname, FI_ATIME(fi)+offset, FI_MTIME(fi)+offset) == ERR) + call error (0, "Fatal futime() error") + + # Get modified file times. + if (finfo (fname, fi) == ERR) + call syserrs (SYS_FOPEN, fname) + call printf ("Mofified times: atime = %d mtime = %d\n") + call pargl (FI_ATIME(fi)) + call pargl (FI_MTIME(fi)) + + + # Test the NULL arguments, output shouldn't change. + if (futime (fname, NULL, FI_MTIME(fi)) == ERR) + call error (0, "Fatal futime() error") + + # Get modified file times. + if (finfo (fname, fi) == ERR) + call syserrs (SYS_FOPEN, fname) + call printf ("NULL test time: atime = %d mtime = %d\n") + call pargl (FI_ATIME(fi)) + call pargl (FI_MTIME(fi)) +end + + +# SYMLINK -- Create a symlink. + +procedure t_symlink () + +char link[SZ_PATHNAME], target[SZ_PATHNAME] +int status + +int sum, i + +begin + call clgstr ("link", link, SZ_PATHNAME) + call clgstr ("target", target, SZ_PATHNAME) + + call fsymlink (link, target) +end + + +# UNLINK -- Remove a symlink. + +procedure t_unlink () + +char link[SZ_PATHNAME], target[SZ_PATHNAME] +int status + +int sum, i + +begin + call clgstr ("link", link, SZ_PATHNAME) + call funlink (link) +end diff --git a/sys/fmio/README b/sys/fmio/README new file mode 100644 index 00000000..726dbc3b --- /dev/null +++ b/sys/fmio/README @@ -0,0 +1,339 @@ +FMIO -- BINARY FILE MANAGER (Jul88 DCT) +---------------------------------------------- + + This directory contains the sources for a general low level binary file +manager (FMIO). The purpose of this file manager is to manage a fixed number +of "lightweight files", or LFILES, maintained within a single variable length +binary file. This facility is used by higher level interfaces such as +database interfaces to store variable length objects efficiently in a single +host binary file. + + +1. INTERFACE PROCEDURES + +1.1 General Procedures + + The main FMIO interface procedures are summarized in the table below. +Most access to lfile data is intended to be via the FIO binary file driver +procedures (beginning with fm_lfopen in the figure). + + yes|no = fm_acccess (datafile, mode) + fm_rename (datafile, newname) + fm_copy (datafile, newname) + fm_delete (datafile) + fm_rebuild (datafile) + + fm = fm_open (datafile, mode) + fm_seti (fm, param, ival) + ival = fm_stati (fm, param) + fm_debug (fm, out, what) + fm_copyo (fm, fm_to) + fm_sync (fm) + fm_close (fm) + + lfile = fm_nextlfile (fm) + fm_lfname (fm, lfile, type, lfname, maxch) + ERR|OK = fm_lfparse (lfname, fm, lfile, type) + fm_lfcopy (fm_src, lfile_src, fm_dst, lfile_dst) + fm_fopen (fm, lfile, mode, type) + + fm_lfopen (lfname, mode, lf) + fm_lfstati (lf, param, ival) + fm_lfaread (lf, buf, nbytes, offset, status) + fm_lfawrite (lf, buf, nbytes, offset, status) + fm_lfawait (lf, status) + fm_lfclose (lf, status) + + fm_lfstat (fm, lfile, statbuf) + fm_lfdelete (fm, lfile) + fm_lfundelete (fm, lfile) + + +1.2 Buffer Cache + + To avoid excessive disk i/o when randomly accessing the datafile, it is +desirable to maintain a cache of several lfile data buffers, e.g., so that +accesses to a series of objects stored in a single lfile, or repeated accesses +to portions of several lfiles should incur minimal disk accesses. A simple +way to implement such a buffer cache is to simply open each lfile as a file +under FIO, leaving it up to FIO to manage the file buffer, and maintaining +a LRU cache of open lfiles. The number of buffers (open lfiles) is easily +parameterized. The buffer cache procedures are summarized in the figure +below. + + fd = fm_getfd (fm, lfile, mode, type) + fm_retfd (fm, lfile) + fm_lockout (fm, lfile) + fm_debugfd (fm, out) + +The fm_getfd routine maps an lfile onto a file descriptor. A file descriptor +is opened on the lfile only when necessary. Once opened, an lfile remains in +the cache until forced out by the LRU replacement algorithm, or the datafile +is closed. While the datafile remains open, removal of an lfile from the +cache (closing the associated file descriptor) is permitted only after a call +to fm_retfd; calling this routine does not immediately close the file, it only +permits it to be closed. Repeated to fm_getfd should return a file descriptor +immediately, with very little overhead, with an already active file buffer, +hence repeated calls to the cache manager and FIO may often be made without +incurring any disk accesses. + +Note that lfiles may be opened on file descriptors via direct calls to the +file manager, regardless of whether these lfiles are already open in the +buffer cache (e.g., with fm_fopen). This allows two or more independent +file buffers to be simultaneously active on the same lfile, but opens the +possibility of loss of data if the buffers overlap. If this is a problem, +the routine fm_lockoutfd may be called to prevent inadvertent use of an lfile +by the cache. This should be followed by a call to fm_retfd to clear the +lockout bit once the reason for the lockout (usually a noncached lfile open) +is gone. The routine fm_debugfd will print information on stream 'out' +describing the status of the buffer cache. + + +2. FILE STRUCTURE + +The layout of a datafile is as follows: + + + +-------------------------+ + | | datafile header | (fixed size) + stored | | +-------------------+ | + as - + | file table | (configurable) + unit | | +-------------------+ | + | | page table index | (configurable) + + +-------------------------+ + | + data pages (dynamic) + | + v + +The datafile header is a fixed format binary structure. The file table +contains one entry for each lfile stored in the datafile; the maximum number +of lfiles is fixed at datafile creation time. Each lfile is known by its +lfile number, ranging from zero to MAXLFILES. Lfile zero is the PAGE TABLE, +used to map each data page in the datafile to the lfile to which it is +allocated. The first user lfile is hence number 1. Lfiles may by any size; +storage is allocated in units of PAGES. The page size is fixed at datafile +creation time. There are two types of files, binary (opaque) files, and +text files. Both file types appear as binary files to the high level code, +i.e., both are accessed by a FIO binary file driver, the only difference +being that for a text file, data blocks are assumed to contain text and are +packed/unpacked during i/o (saving storage and rendering the file machine +independent). + +It is important to realize that lfiles are referred to only by FILE NUMBER +in this interface; any association with symbolic names must be made at a +higher level (lfiles are by no means necessarily associated with "files" at +the higher level, i.e., they might be used to store variable length parameters, +relations, or whatever). All lfiles exist, in a sense, as zero length files +at datafile creation time. To open a new lfile, one first calls fm_nextlfile +to get the file number of an empty lfile. Lfiles can be deleted, but storage +is never deallocated; new pages are always allocated at the end of file. +Hence deleted lfiles can be undeleted, and the entire datafile must normally +be copied (or "rebuilt") to reclaim unused space and coalesce file segments +for more efficient i/o. (There are cases where a deleted lfile can be reused +without rebuilding the lfile: fm_nextlfile will begin reusing deleted lfiles +after it wraps around, and the client software can always open an lfile +NEW_FILE, overwriting the pages already allocated to the lfile). + +The FMIO datafile itself, and any text files stored therein, is maintained in +a machine indepenent format. Binary file data is merely copied to and from +the datafile, hence it is up to the client software to store binary data in +a machine independent format, if desired. + + +2.1 Recovery + + Since new data pages are always allocated at the end of file (next +available PTE), and the datafile state is always sync-ed as a unit, protected +as a critical section (ignoring modifications to lfile data), a datafile +should always be recoverable after a crash, with loss only of data written +since the last sync. The datafile is sync-ed automatically every several +minutes. Applications wishing to protect newly written lfile data can sync +the datafile manually if desired. + + +3. RUNTIME DATA STRUCTURES + +The internal runtime data structures are summarized below. The terminology +used is as follows: + + FM file manager + FT file table + FTE file table entry + LFILE lightweight file + PAGE unit of datafile file storage + PT page table + PTE page table entry + PTI page table index + + +# FMDES -- Main FM descriptor. +struct fmdes { + int fm_magic # identifies file/descriptor type + int fm_active # set once descriptor is initialized + int fm_chan # host i/o channel for datafile + int fm_mode # datafile access mode + int fm_dfversion # datafile file version + int fm_szpage # datafile page size, bytes + int fm_nlfiles # number of lfiles + int fm_datastart # file offset of first data page + int fm_devblksize # device block size + int fm_optbufsize # default file buffer size + int fm_maxbufsize # maximum file buffer size + int fm_lsynctime # time descriptor last updated on disk + int fm_dhmodified # set if header needs to be updated + + int fm_ftoff # offset (su) of FT in datafile + int fm_ftlastnf # file number of last lfile allocated + struct fte (*fm_ftable)[] # file table storage + + int fm_ptioff # offset (su) of PTI in datafile + int fm_ptilen # allocated length of PTI + int fm_ptinpti # number of PTI entries in use + int fm_ptindex[] # PTI storage + + int fm_ptlen # allocated length of page table array + int fm_ptnpte # number of PTE's in use (#data pages) + int fm_ptlupte # highest PTE updated on disk + short fm_ptable[] # runtime page table array + + struct lfcache *fm_lfcache; # lfile cache descriptor + int fm_errcode # error code of posted error + char fm_erropstr[] # operand string of posted error + char fm_dfname[] # datafile name, for error messages +} + + +3.1 Page Table + + During runtime access to the datafile, the page table is a vector mapping +each datafile page to an lfile. Each page is allocated to a single lfile, and +lfile storage is allocated in units of pages. As the datafile is extended by +writing to lfiles, elements are the in-core page table array. + +When an lfile is first accessed, the in-core page table is scanned to find +those pages belonging to the lfile, building up a vector mapping offsets in +the lfile into datafile page numbers, i.e., to offsets in the physical +datafile. As new pages are allocated to an lfile by writing at end of file, +both the lfile page vector and datafile page table are extended. + +Assume the datafile page size is 512 bytes. Since a PTE is 2 bytes, each PT +page holds 256 PTEs, representing 128 Kb of file space. 1 Mb of file space +(2048 pages) therefore requires 8 pages of page table space. If we allocate +a default PT index of 256 slots, this gives us (for a 512 byte page) a 32 Mb +default maximum file size. + +Only the PT index, stored in the datafile header, and the PT pages mapping +datafile page to lfile, are physically stored in the datafile. The PT index +size is fixed. The PT pages may be stored anywhere in the data pages and +are pointed to by the PT index. The PT is stored as lfile zero. + +This scheme is not intended for use with extremely large datafiles, or with +datafiles containing a very large number of lfiles. A datafile of 32-256 Mb, +page size 512-4096, containing up to several hundred lfiles is the design +limit. Of course, each datafile is a single host file, and there can be any +number of datafiles. + + +3.2 File Table + + The file table (FT) describes each lfile in the datafile. Each lfile +has an entry in the file table, regardless of whether the lfile has ever been +accessed or contains any data. As stored in the datafile, the FT is an array +of file table entries (FTEs) containing two longwords of data each, i.e., + + FTE.1: file size, bytes + FTE.2: flag bits (text, deleted, etc.) + +Additional information must be maintained while an lfile is being accessed +at runtime. The full runtime FTE is as follows. + + struct fte { + struct fmdes *lf_fm # backpointer to FMIO descriptor + int lf_fsize # file size, bytes + int lf_flags # flag bits + int lf_status # runtime i/o status (byte count) + int lf_ltsize # logical byte size of last transfer + int lf_npages # npages in lfile (pagemap size) + int *lf_pagemap # pagemap array for lfile + int lf_pmlen # pagemap array length (allocated) + } + +flag bits: + + LF_DELETED set if the lfile is deleted + LF_TEXTFILE set if the lfile data is byte-packed text + LF_IOINPROGRESS set when i/o transfer is in progress + +Deleting an lfile merely causes the FT_DELETED bit to be set; the actual +data will be lost only if the lfile is reused or explicitly overwritten, +or in a copy or rebuild operation. Lfile space, once allocated, is never +freed, i.e., new pages are always allocated at the end of the datafile, +but lfile space can be *reused* by opening the lfile NEW_FILE and writing +into it. + +Space for all lfile descriptors is preallocated in the FTE array at datafile +open time. When an lfile is first accessed the pagemap for that lfile is +filled in; subsequent accesses to the lfile (lfile opens) while the datafile +remains open require very little overhead, since the lfile descriptor is +accessible via a vectored array reference, and will already have been activated. + + +4. EXAMPLE + + The following dialogue is from the debug tasks in ZZDEBUG. A datafile Q +containing four textfiles has been created, and we print out the contents of +this with SHOW. Next we copy the datafile to Q, and "show" that. Note that +the page table file is moved to the beginning of the data pages area (which +will avoid an extra disk access during the datafile open), and all lfiles +have been rendered contiguous (lfile 5 was not stored in two segments in the +original datafile). + +> ? + create wfile pfile show copy rebuild +> +> show +datafile: q +FMIO V1.1: datafile=q, pagesize=512, nlfiles=128 +nlfinuse=5, nlfdeleted=0, nlffree=123, ftoff=13, ftlastnf=0 +headersize=2560, filesize=20992, freespace=1408 bytes (6%) +fm=15AE9X, chan=4, mode=2, time since last sync=1 seconds +datastart=2561, devblksize=512, optbufsize=2048, maxbufsize=0 +ptioff=271, ptilen=256, npti=1, ptlen=512, npte=36, lupte=36 +====================== file table ======================= + 0 size=72 [page table] + 1 size=1114 textfile + 2 size=7037 textfile + 5 size=4422 textfile + 6 size=4379 textfile +=================== page table index ==================== + 4 +====================== page table ======================= + 1 1 1 0 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 5 5 6 6 6 6 6 6 6 6 6 5 + 5 5 5 5 5 5 +> +> copy +source: q +destination: p +> +> show +datafile: p +FMIO V1.1: datafile=p, pagesize=512, nlfiles=128 +nlfinuse=5, nlfdeleted=0, nlffree=123, ftoff=13, ftlastnf=0 +headersize=2560, filesize=20992, freespace=1408 bytes (6%) +fm=15AE9X, chan=4, mode=2, time since last sync=0 seconds +datastart=2561, devblksize=512, optbufsize=2048, maxbufsize=0 +ptioff=271, ptilen=256, npti=1, ptlen=512, npte=36, lupte=36 +====================== file table ======================= + 0 size=72 [page table] + 1 size=1114 textfile + 2 size=7037 textfile + 5 size=4422 textfile + 6 size=4379 textfile +=================== page table index ==================== + 1 +====================== page table ======================= + 0 1 1 1 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 5 5 5 5 5 5 5 5 5 6 6 6 + 6 6 6 6 6 6 +> diff --git a/sys/fmio/fmaccess.x b/sys/fmio/fmaccess.x new file mode 100644 index 00000000..c1324fc4 --- /dev/null +++ b/sys/fmio/fmaccess.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# FM_ACCESS -- Test to see if the name FMIO datafile exists and is accessible +# with the given permissions. + +int procedure fm_access (dfname, mode) + +char dfname[ARB] #I datafile name +int mode #I access mode (0 to just test existence) + +int access() + +begin + return (access (dfname, mode, 0)) +end diff --git a/sys/fmio/fmclose.x b/sys/fmio/fmclose.x new file mode 100644 index 00000000..87e20674 --- /dev/null +++ b/sys/fmio/fmclose.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "fmio.h" + +# FM_CLOSE -- Close a datafile opened under FMIO. + +procedure fm_close (fm) + +pointer fm #I FMIO descriptor + +pointer lf +int status, i +errchk fmio_bind, fm_fcfree, fmio_errchk + +begin + # An open-new-file followed by a close should create an empty datafile. + if (FM_ACTIVE(fm) == NO) + call fmio_bind (fm) + + # Shut down the file cache, if in use (does a sync). + if (FM_FCACHE(fm) != NULL) + call fm_fcfree (fm) + else + call fm_sync (fm) + + # Report any posted errors. + call fmio_errchk (fm) + + # Close the physical datafile. + call zclsbf (FM_CHAN(fm), status) + if (status == ERR) + iferr (call syserrs (SYS_FMCLOSE, FM_DFNAME(fm))) + call erract (EA_WARN) + + # Free any storage used by the runtime file table. + lf = FM_FTABLE(fm) + do i = 0, FM_NLFILES(fm) { + if (LF_PAGEMAP(lf) != NULL) + call mfree (LF_PAGEMAP(lf), TY_INT) + lf = lf + LEN_FTE + } + + # Free the main descriptor. + call mfree (FM_PTABLE(fm), TY_SHORT) + call mfree (FM_PTINDEX(fm), TY_INT) + call mfree (FM_FTABLE(fm), TY_INT) + call mfree (fm, TY_STRUCT) +end diff --git a/sys/fmio/fmcopy.x b/sys/fmio/fmcopy.x new file mode 100644 index 00000000..1125a820 --- /dev/null +++ b/sys/fmio/fmcopy.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "fmset.h" + +# FM_COPY -- Copy a datafile, preserving all the physical attributes, but +# eliminating waste storage and rendering file structures logically contiguous. + +procedure fm_copy (dfname, newname) + +char dfname[ARB] #I existing datafile +char newname[ARB] #I new datafile name + +pointer o_fm, n_fm +pointer fm_open() +int fm_stati() +errchk fm_open, fm_copyo + +begin + # Open the old and new datafiles. + o_fm = fm_open (dfname, READ_ONLY) + n_fm = fm_open (newname, NEW_FILE) + + # The child inherits the attributes of the parent. + call fm_seti (n_fm, FM_PAGESIZE, fm_stati(o_fm,FM_PAGESIZE)) + call fm_seti (n_fm, FM_MAXLFILES, fm_stati(o_fm,FM_MAXLFILES)) + + # Copy the datafile and clean up. + iferr (call fm_copyo (o_fm, n_fm)) { + call fm_close (o_fm) + call fm_close (n_fm) + call erract (EA_ERROR) + } else { + call fm_close (o_fm) + call fm_close (n_fm) + } +end diff --git a/sys/fmio/fmcopyo.x b/sys/fmio/fmcopyo.x new file mode 100644 index 00000000..a6fd0be2 --- /dev/null +++ b/sys/fmio/fmcopyo.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "fmio.h" + +# FM_COPYO -- Copy an existing, open datafile to a new, open but empty +# datafile, rendering all lfile storage contiguous and omitting deleted +# lfiles. Lfile numbers are preserved by the copy operation, hence +# deleted lfiles will leave holes (zero length lfiles) in the file table. + +procedure fm_copyo (old, new) + +pointer old, new #I FMIO descriptors of source and destination + +pointer o_ft, o_lf +int n_szbpage, nlfiles, dpages, npte_perpage, npti, p1, dp, i +errchk fmio_bind, syserrs, fm_lfcopy +int fmio_extend() + +begin + call fmio_bind (old) + call fmio_bind (new) + + # Scan the file table of the old datafile and determine the number of + # data pages required to store the valid lfiles therein. Note that + # the page size may differ in the old and new datafiles. + + o_ft = FM_FTABLE(old) + n_szbpage = FM_SZBPAGE(new) + nlfiles = min (FM_NLFILES(old), FM_NLFILES(new)) + dpages = 0 + + do i = 0, nlfiles { + o_lf = o_ft + i * LEN_FTE + if (LF_FSIZE(o_lf) <= 0 || and(LF_FLAGS(o_lf),LFF_ALLOCATED) == 0) + next + dpages = dpages + (LF_FSIZE(o_lf) + n_szbpage-1) / n_szbpage + } + + # Now allocate enough lfile 0 space in the new datafile to permit + # contiguous storage of the entire datafile page table. + + npte_perpage = n_szbpage / (SZ_SHORT * SZB_CHAR) + npti = (dpages + npte_perpage-1) / npte_perpage + if (npti > FM_PTILEN(new)) + call syserrs (SYS_FMPTIOVFL, FM_DFNAME(new)) + + for (p1=FM_PTINPTI(new)+1; p1 <= npti; p1=p1+1) { + dp = fmio_extend (new, PT_LFILE, 1) + if (dp == ERR) + call syserrs (SYS_FMCOPYO, FM_DFNAME(new)) + Memi[FM_PTINDEX(new)+p1-1] = dp + FM_PTINPTI(new) = p1 + FM_DHMODIFIED(new) = YES + } + + # Copy the lfiles (excluding the page table). + do i = 1, nlfiles + call fm_lfcopy (old, i, new, i) + + call fm_sync (new) +end diff --git a/sys/fmio/fmdebug.x b/sys/fmio/fmdebug.x new file mode 100644 index 00000000..183e4481 --- /dev/null +++ b/sys/fmio/fmdebug.x @@ -0,0 +1,182 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "fmset.h" +include "fmio.h" + +# FM_DEBUG -- Print debug info on the contents of a datafile. +# +# Flags: +# FMD_HEADER general header parameters +# FMD_FTABLE summarize file table contents +# FMD_PTINDEX print page table index +# FMD_PTABLE print page table +# FMD_ALL print everything + +procedure fm_debug (fm, out, what) + +pointer fm #I FMIO descriptor +int out #I output file +int what #I what to print + +pointer ft, lf +bool deleted +int nlfiles, nlfdeleted, nlfinuse, i +int szbpage, spaceinuse, filesize, freespace +long clktime() +errchk fmio_bind + +define end_header_ 91 +define end_ftable_ 92 +define end_ptindex_ 93 +define end_ptable_ 94 + +begin + call fmio_bind (fm) + + ft = FM_FTABLE(fm) + nlfiles = FM_NLFILES(fm) + szbpage = FM_SZBPAGE(fm) + + # Print header and summary information? + if (and (what, FMD_HEADER) == 0) + goto end_header_ + + # Scan the file table and compute some important statistics. + spaceinuse = 0 + nlfdeleted = 0 + nlfinuse = 0 + + do i = 0, nlfiles { + lf = ft + i * LEN_FTE + deleted = (and (LF_FLAGS(lf), LFF_DELETED) != 0) + if (deleted) + nlfdeleted = nlfdeleted + 1 + if (!deleted) { + if (LF_FSIZE(lf) > 0) + spaceinuse = spaceinuse + LF_FSIZE(lf) + if (and (LF_FLAGS(lf), LFF_ALLOCATED) != 0) + nlfinuse = nlfinuse + 1 + } + } + + filesize = FM_PTNPTE(fm) * szbpage + FM_DATASTART(fm) - 1 + freespace = max (0, filesize - spaceinuse - (FM_DATASTART(fm)-1)) + + call fprintf (out, + "FMIO V%d.%d: datafile=%s, pagesize=%d, nlfiles=%d\n") + call pargi (FM_DFVERSION(fm) / 100) + call pargi (mod(FM_DFVERSION(fm),100)) + call pargstr (FM_DFNAME(fm)) + call pargi (szbpage) + call pargi (nlfiles) + + call fprintf (out, + "nlfinuse=%d, nlfdeleted=%d, nlffree=%d, ftoff=%d, ftlastnf=%d\n") + call pargi (nlfinuse) + call pargi (nlfdeleted) + call pargi (nlfiles - nlfinuse) + call pargi (FM_FTOFF(fm)) + call pargi (FM_FTLASTNF(fm)) + + call fprintf (out, + "headersize=%d, filesize=%d, freespace=%d bytes (%d%%)\n") + call pargi (FM_DATASTART(fm) - 1) + call pargi (filesize) + call pargi (freespace) + if (freespace <= 0) + call pargi (0) + else + call pargi (freespace * 100 / filesize) + + call fprintf (out, + "fm=%xX, chan=%d, mode=%d, time since last sync=%d seconds\n") + call pargi (fm) + call pargi (FM_CHAN(fm)) + call pargi (FM_MODE(fm)) + call pargi (clktime (FM_LSYNCTIME(fm))) + + call fprintf (out, + "datastart=%d, devblksize=%d, optbufsize=%d, maxbufsize=%d\n") + call pargi (FM_DATASTART(fm)) + call pargi (FM_DEVBLKSIZE(fm)) + call pargi (FM_OPTBUFSIZE(fm)) + call pargi (FM_MAXBUFSIZE(fm)) + + call fprintf (out, "ptioff=%d, ptilen=%d, npti=%d, ") + call pargi (FM_PTIOFF(fm)) + call pargi (FM_PTILEN(fm)) + call pargi (FM_PTINPTI(fm)) + call fprintf (out, "ptlen=%d, npte=%d, lupte=%d\n") + call pargi (FM_PTLEN(fm)) + call pargi (FM_PTNPTE(fm)) + call pargi (FM_PTLUPTE(fm)) + +end_header_ + + # Print file table? + if (and (what, FMD_FTABLE) == 0) + goto end_ftable_ + + call fprintf (out, + "====================== file table =======================\n") + do i = 0, nlfiles { + lf = ft + i * LEN_FTE + if (LF_FSIZE(lf) == 0) + next + call fprintf (out, " %4d size=%d") + call pargi (i) + call pargi (LF_FSIZE(lf)) + if (i == 0) + call fprintf (out, " [page table]") + if (LF_PAGEMAP(lf) != NULL) { + call fprintf (out, " npages=%d pmlen=%d") + call pargi (LF_NPAGES(lf)) + call pargi (LF_PMLEN(lf)) + } + if (and (LF_FLAGS(lf), LFF_ALLOCATED) != 0) + call fprintf (out, " allocated") + if (and (LF_FLAGS(lf), LFF_DELETED) != 0) + call fprintf (out, " deleted") + if (and (LF_FLAGS(lf), LFF_TEXTFILE) != 0) + call fprintf (out, " textfile") + call fprintf (out, "\n") + } + +end_ftable_ + + # Print page table index? + if (and (what, FMD_PTINDEX) == 0) + goto end_ptindex_ + + call fprintf (out, + "=================== page table index ====================\n") + do i = 0, FM_PTINPTI(fm) - 1 { + call fprintf (out, " %4d") + call pargi (Memi[FM_PTINDEX(fm)+i]) + if (mod (i+1, 15) == 0) + call fprintf (out, "\n") + } + if (mod (FM_PTINPTI(fm), 15) != 0) + call fprintf (out, "\n") + +end_ptindex_ + + # Print page table? + if (and (what, FMD_PTABLE) == 0) + goto end_ptable_ + + call fprintf (out, + "====================== page table =======================\n") + do i = 0, FM_PTNPTE(fm) - 1 { + call fprintf (out, " %4d") + call pargs (Mems[FM_PTABLE(fm)+i]) + if (mod (i+1, 15) == 0) + call fprintf (out, "\n") + } + if (mod (FM_PTINPTI(fm), 15) != 0) + call fprintf (out, "\n") + +end_ptable_ + + call flush (out) +end diff --git a/sys/fmio/fmdelete.x b/sys/fmio/fmdelete.x new file mode 100644 index 00000000..b90fb2af --- /dev/null +++ b/sys/fmio/fmdelete.x @@ -0,0 +1,11 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# FM_DELETE -- Delete a datafile. + +procedure fm_delete (dfname) + +char dfname[ARB] #I datafile name + +begin + call delete (dfname) +end diff --git a/sys/fmio/fmfcache.x b/sys/fmio/fmfcache.x new file mode 100644 index 00000000..6e1d16fe --- /dev/null +++ b/sys/fmio/fmfcache.x @@ -0,0 +1,395 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "fmset.h" +include "fmio.h" + +.help fcache +.nf ------------------------------------------------------------------------- +FCACHE -- FMIO File (Buffer) Cache package. + + This package is used to manage a cache of lfile data buffers maintained on +a FMIO datafile. The number and size of data buffers is user configurable: +the number of buffers by a call to FM_SETI to set FM_FCACHESIZE, and the buffer +size by a call to FSETI to set the file buffer size. + + fm_fcinit (fm, cachesize) + fm_fcdebug (fm, out, what) + fm_fcsync (fm) + fm_fcfree (fm) + + fd = fm_getfd (fm, lfile, mode, type) + fm_retfd (fm, lfile) + fm_lockout (fm, lfile) + fm_unlock (fm, lfile) + bool = fm_locked (fm, lfile) + +The cache is a conventional LRU cache. FM_GETFD returns the file descriptor +of an open, cached file opened on an lfile, locking the file in the cache in +the process. A subsequent call to FM_RETFD is required to allow the cache +slot to be reused. FM_LOCKOUT may be used to lock a particular lfile out of +the cache; FM_UNLOCK releases the lock. +.endhelp -------------------------------------------------------------------- + +define LEN_FCACHE (3+($1)*LEN_FSLOT) # len = LEN_FCACHE(cachesize) +define FC_NFILES Memi[$1] # number of files in cache +define FC_REFCNT Memi[$1+1] # cache reference count +define FC_LFSTAT Memi[$1+2] # lfile statistics array +define FC_FS ((($2)-1)*LEN_FSLOT+($1)+3) # get slot pointer + +define LEN_FSLOT 4 +define FC_NREF Memi[$1] # number of refs to this slot +define FC_LRU Memi[$1+1] # LRU count for slot +define FC_LFILE Memi[$1+2] # lfile assigned to slot +define FC_FD Memi[$1+3] # file descriptor + + +# FM_GETFD -- Map a FIO file descriptor onto an lfile and return the file +# descriptor. The opened file descriptor remains in the cache after the +# access, until the file ages out of the cache. + +int procedure fm_getfd (fm, lfile, mode, type) + +pointer fm # FMIO descriptor +int lfile # lfile to be opened +int mode # file access mode +int type # file type + +int acmode, lru, i +pointer oldest, fc, fs, st + +bool fm_locked() +pointer fm_findlf() +int fm_fopen(), fstati() +errchk fm_fopen, fm_fcinit, syserrs, close +define ref_ 91 + +begin + fc = FM_FCACHE(fm) + if (fc == NULL) { + call fm_fcinit (fm, FM_SZFCACHE(fm)) + fc = FM_FCACHE(fm) + } + + # Keep debug statistics on lfile accesses. + st = FC_LFSTAT(fc) + if (st != NULL) + Mems[st+lfile] = Mems[st+lfile] + 1 + + fs = fm_findlf (fc, lfile) + if (fs != NULL) { + # If lfile is already in the cache and the new mode is NEW_FILE, + # or we need write perm and do not currently have it, close and + # reopen the lfile with the desired mode. + + if (mode == NEW_FILE || + (mode != READ_ONLY && fstati (FC_FD(fs), F_WRITE) == NO)) { +ref_ + if (FC_NREF(fs) > 1) + call syserrs (SYS_FMFSINUSE, FM_DFNAME(fm)) + if (FC_NREF(fs) == 1) + call close (FC_FD(fs)) + if (fm_locked (fm, lfile)) + call syserrs (SYS_FMLFLOCKED, FM_DFNAME(fm)) + + if (mode == WRITE_ONLY || mode == APPEND) + acmode = READ_WRITE + else + acmode = mode + + FC_FD(fs) = fm_fopen (fm, lfile, acmode, type) + FC_NREF(fs) = 1 + FC_LFILE(fs) = lfile + } + + # Reference the cached lfile. + FC_REFCNT(fc) = FC_REFCNT(fc) + 1 + FC_LRU(fs) = FC_REFCNT(fc) + FC_NREF(fs) = FC_NREF(fs) + 1 + if (mode == APPEND) + call seek (FC_FD(fs), EOFL) + + return (FC_FD(fs)) + + } else { + # Lfile is not in cache. Find the oldest slot. + oldest = NULL + lru = NULL + do i = 1, FC_NFILES(fc) { + fs = FC_FS(fc,i) + if (FC_NREF(fs) <= 1) + if (lru == NULL || FC_LRU(fs) < lru) { + lru = FC_LRU(fs) + oldest = fs + if (FC_NREF(fs) <= 0) + break + } + } + + # Abort if all cache slots are busy. + if (oldest == NULL) + call syserrs (SYS_FMFCFULL, FM_DFNAME(fm)) + + # Replace the file in the cache, and return new descriptor. + fs = oldest + goto ref_ + } +end + + +# FM_RETFD -- Return a cached file, i.e., decrement the reference count for +# the file so that it may be returned. If FM_RETFD is called when the file +# is sitting in the cache idle, the file is physically closed (i.e., a GETFD +# followed by one RETFD leaves the file cached and idle, ready for another +# GETFD without losing context, but another RETFD while the file is idle +# closes the file and removes it from the cache). + +procedure fm_retfd (fm, lfile) + +pointer fm #I FMIO descriptor +int lfile #I lfile to be returned + +pointer fc, fs +pointer fm_findlf() +errchk fm_fcinit + +begin + fc = FM_FCACHE(fm) + if (fc == NULL) { + call fm_fcinit (fm, FM_SZFCACHE(fm)) + fc = FM_FCACHE(fm) + } + + fs = fm_findlf (fc, lfile) + if (fs != NULL) { + FC_NREF(fs) = FC_NREF(fs) - 1 + if (FC_NREF(fs) <= 0) { + call close (FC_FD(fs)) + FC_NREF(fs) = 0 + } + } +end + + +# FM_LOCKOUT -- Lock an lfile out of the file cache. + +procedure fm_lockout (fm, lfile) + +pointer fm #I FMIO descriptor +int lfile #I lfile to be locked out + +pointer fc, fs, lf +pointer fm_findlf() +errchk fm_fcinit, close, syserrs + +begin + fc = FM_FCACHE(fm) + if (fc == NULL) { + call fm_fcinit (fm, FM_SZFCACHE(fm)) + fc = FM_FCACHE(fm) + } + + # Close lfile if it is already in the cache, but idle. + fs = fm_findlf (fc, lfile) + if (fs != NULL) { + if (FC_NREF(fs) > 1) + call syserrs (SYS_FMLOKACTLF, FM_DFNAME(fm)) + FC_NREF(fs) = FC_NREF(fs) - 1 + if (FC_NREF(fs) <= 0) { + call close (FC_FD(fs)) + FC_NREF(fs) = 0 + } + } + + # Set the lockout bit in the file table. + lf = FM_FTABLE(fm) + lfile * LEN_FTE + LF_FLAGS(lf) = or (LF_FLAGS(lf), LFF_LOCKOUT) +end + + +# FM_UNLOCK -- Unlock an lfile. + +procedure fm_unlock (fm, lfile) + +pointer fm #I FMIO descriptor +int lfile #I lfile to be locked out + +pointer lf + +begin + # Clear the lockout bit in the file table. + lf = FM_FTABLE(fm) + lfile * LEN_FTE + LF_FLAGS(lf) = and (LF_FLAGS(lf), not(LFF_LOCKOUT)) +end + + +# FM_LOCKED -- Test the lfile lockout bit. + +bool procedure fm_locked (fm, lfile) + +pointer fm #I FMIO descriptor +int lfile #I lfile to be locked out + +pointer lf + +begin + # Test the lockout bit in the file table. + lf = FM_FTABLE(fm) + lfile * LEN_FTE + return (and (LF_FLAGS(lf), LFF_LOCKOUT) != 0) +end + + +# FM_FINDLF -- Search the cache for the given lfile. + +pointer procedure fm_findlf (fc, lfile) + +pointer fc #I file cache descriptor +int lfile #I lfile to search for + +int i +pointer fs + +begin + do i = 1, FC_NFILES(fc) { + fs = FC_FS(fc,i) + if (FC_NREF(fs) != 0 && FC_LFILE(fs) == lfile) + return (fs) + } + + return (NULL) +end + + +# FM_FCDEBUG -- Print debug info describing the contents and status of the +# file cache. + +procedure fm_fcdebug (fm, out, what) + +pointer fm #I FMIO descriptor +int out #I output file +int what #I type of debug output + +int nref, i +pointer fc, fs, st +errchk fm_fcinit + +begin + fc = FM_FCACHE(fm) + if (fc == NULL) { + call fm_fcinit (fm, FM_SZFCACHE(fm)) + fc = FM_FCACHE(fm) + } + + # Print cache status. + if (and (what, FCD_CACHE) != 0) { + call fprintf (out, "# LRU NREF LFILE FD\n") + do i = 1, FC_NFILES(fc) { + fs = FC_FS(fc,i) + call fprintf (out, "%6d %4d %5d %3d\n") + call pargi (FC_LRU(fs)) + call pargi (FC_NREF(fs)) + if (FC_NREF(fs) > 0) { + call pargi (FC_LFILE(fs)) + call pargi (FC_FD(fs)) + } else { + call pargi (0) + call pargi (0) + } + } + } + + # Print lfile access statistics. + if (and (what, FCD_LFSTATISTICS) != 0) { + st = FC_LFSTAT(fc) + if (st != NULL) { + call fprintf (out, "-------- getfd's per lfile ---------\n") + do i = 0, FM_NLFILES(fm) { + nref = Mems[st+i] + if (nref > 0) { + call fprintf (out, "%4d %4d\n") + call pargi (i) + call pargi (nref) + } + } + } + } +end + + +# FM_FCINIT -- Init the file cache. + +procedure fm_fcinit (fm, cachesize) + +pointer fm #I FMIO descriptor +int cachesize #I size of cache, file slots + +pointer fc + +begin + if (FM_FCACHE(fm) != NULL) + call fm_fcfree (fm) + + call calloc (fc, LEN_FCACHE(cachesize), TY_STRUCT) + call calloc (FC_LFSTAT(fc), FM_NLFILES(fm)+1, TY_SHORT) + FC_NFILES(fc) = cachesize + FC_REFCNT(fc) = 1 + + FM_FCACHE(fm) = fc +end + + +# FM_FCFREE -- Shutdown the file cache and free all resources, ignoring +# all file reference counts. + +procedure fm_fcfree (fm) + +pointer fm #I FMIO descriptor + +int i +pointer fc, fs + +begin + fc = FM_FCACHE(fm) + if (fc == NULL) + return + + # Update the datafile. + call fm_fcsync (fm) + + # Close any cached files. + do i = 1, FC_NFILES(fc) { + fs = FC_FS(fc,i) + if (FC_NREF(fs) >= 1) + iferr (call close (FC_FD(fs))) + call erract (EA_WARN) + } + + call mfree (FC_LFSTAT(fc), TY_SHORT) + call mfree (FM_FCACHE(fm), TY_STRUCT) +end + + +# FM_FCSYNC -- Sync the file cache and datafile. + +procedure fm_fcsync (fm) + +pointer fm #I FMIO descriptor + +int i +pointer fc, fs + +begin + fc = FM_FCACHE(fm) + if (fc != NULL) { + do i = 1, FC_NFILES(fc) { + fs = FC_FS(fc,i) + if (FC_NREF(fs) >= 1) + iferr (call flush (FC_FD(fs))) + call erract (EA_WARN) + } + } + + call fm_sync (fm) +end diff --git a/sys/fmio/fmfopen.x b/sys/fmio/fmfopen.x new file mode 100644 index 00000000..6b3b897a --- /dev/null +++ b/sys/fmio/fmfopen.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# FM_FOPEN -- Open an lfile as an FIO file. A FIO file descriptor is returned +# for the open file. CLOSE is used to close the opened file. + +int procedure fm_fopen (fm, lfile, mode, type) + +pointer fm #I FMIO descriptor +int lfile #I lfile to be opened +int mode #I file access mode +int type #I logical file type + +int fd +pointer sp, lfname +extern fm_lfopen(), fm_lfclose() +extern fm_lfaread(), fm_lfawrite(), fm_lfawait(), fm_lfstati() +int fopnbf() +errchk fopnbf + +begin + call smark (sp) + call salloc (lfname, SZ_FNAME, TY_CHAR) + + call fm_lfname (fm, lfile, type, Memc[lfname], SZ_FNAME) + fd = fopnbf (Memc[lfname], mode, fm_lfopen, fm_lfaread, fm_lfawrite, + fm_lfawait, fm_lfstati, fm_lfclose) + + call sfree (sp) + return (fd) +end diff --git a/sys/fmio/fmio.h b/sys/fmio/fmio.h new file mode 100644 index 00000000..41c43676 --- /dev/null +++ b/sys/fmio/fmio.h @@ -0,0 +1,97 @@ +# FMIO.H -- File manager interface definitions (private to FMIO). + +define FMIO_MAGIC 28006 # "fm" +define FMIO_VERSION 101 # current interface version number +define DEF_PAGESIZE 512 # default page size, bytes +define DEF_MAXLFILES 128 # default max lfiles / datafile +define DEF_MAXPTPAGES 256 # default max page table pages +define DEF_OPTBUFNP 4 # default npages in lfile FIO buffer +define DEF_MAXBUFNP 0 # default npages max buffer size +define DEF_BIGBUFNP 16 # large buffer for lfile copies +define DEF_DFHDRLEN 4096 # default DF header buflen (su) +define DEF_FCACHESIZE 8 # default open files in file cache +define DEF_PMLEN 64 # default lfile pagemap array length +define INC_PMLEN 128 # default page table buflen (pte) +define SZ_DFNAME 63 # datafile name +define SZ_ERROPSTR 63 # operand string, for posted errors +define SYNC_INTERVAL 300 # interval between automatic syncs +define PT_LFILE 0 # lfile in which page table is stored + +# Main FMIO descriptor. +define LEN_FMDES 150 +# GEN +define FM_MAGIC Memi[$1+0] # set once descriptor is initialized +define FM_ACTIVE Memi[$1+1] # set once descriptor is initialized +define FM_CHAN Memi[$1+2] # host channel of datafile +define FM_MODE Memi[$1+3] # access mode of datafile +define FM_DFVERSION Memi[$1+4] # datafile version number +define FM_SZBPAGE Memi[$1+5] # datafile page size, bytes +define FM_NLFILES Memi[$1+6] # number of lfiles in datafile +define FM_DATASTART Memi[$1+7] # file offset of first data page +define FM_DEVBLKSIZE Memi[$1+8] # device block size +define FM_OPTBUFSIZE Memi[$1+9] # optimum FIO buffer size +define FM_MAXBUFSIZE Memi[$1+10] # maximum FIO buffer size +define FM_SZFCACHE Memi[$1+11] # number of LF in file cache +define FM_LSYNCTIME Memi[$1+12] # time of last sync +define FM_DHMODIFIED Memi[$1+13] # datafile header has been modified +# FT +define FM_FTOFF Memi[$1+15] # offset of stored file table (su) +define FM_FTLASTNF Memi[$1+16] # last new file allocated (runtime) +define FM_FTABLE Memi[$1+17] # pointer to in-core file table +# PTI +define FM_PTIOFF Memi[$1+20] # offset of stored PTI (su) +define FM_PTILEN Memi[$1+21] # page table index length (allocated) +define FM_PTINPTI Memi[$1+22] # number of page table pages +define FM_PTINDEX Memi[$1+23] # pointer to page table index +# PT +define FM_PTLEN Memi[$1+25] # number of allocated PTE entries +define FM_PTNPTE Memi[$1+26] # number of PTEs (data pages) in-core +define FM_PTLUPTE Memi[$1+27] # last updated PTE on disk +define FM_PTABLE Memi[$1+28] # pointer to page table data +# LFC +define FM_FCACHE Memi[$1+30] # pointer to file cache descriptor +define FM_ERRCODE Memi[$1+31] # opcode for posting errors +define FM_ERROPSTR Memc[P2C($1+32)]# error operand string +define FM_DFNAME Memc[P2C($1+96)]# datafile name, for error messages + +# File table entry (FTE) during datafile access. +define LEN_FTE 8 # length of file table entry (ints) +define LF_FM Memi[$1] # backpointer to FMIO descriptor +define LF_FSIZE Memi[$1+1] # file size, bytes +define LF_FLAGS Memi[$1+2] # file bitflags +define LF_STATUS Memi[$1+3] # status word for async i/o +define LF_LTSIZE Memi[$1+4] # logical size of last transfer +define LF_NPAGES Memi[$1+5] # number of pages in file page table +define LF_PAGEMAP Memi[$1+6] # pointer to pagemap array +define LF_PMLEN Memi[$1+7] # length of pagemap array + +# FTE bitflags. +define LFF_SAVE 007B # flags saved while datafile is closed +define LFF_ALLOCATED 001B # lfile slot has been allocated +define LFF_DELETED 002B # set if file is deleted +define LFF_TEXTFILE 004B # set if file is a text file +define LFF_IOINPROGRESS 010B # set when i/o is in progress +define LFF_LOCKOUT 020B # set when i/o is in progress + +# -------------- +# Physical datafile file format. + +# Datafile file header. +define LEN_DHSTRUCT 12 +define DH_MAGIC Memi[$1] # magic value identifying data format +define DH_DFVERSION Memi[$1+1] # FMIO version used to write datafile +define DH_SZBPAGE Memi[$1+2] # datafile page size, bytes +define DH_NLFILES Memi[$1+3] # number of lfiles in datafile +define DH_FTOFF Memi[$1+4] # offset of file table in datafile +define DH_FTLASTNF Memi[$1+5] # last new file allocated (runtime) +define DH_PTIOFF Memi[$1+6] # offset of stored page table index +define DH_PTILEN Memi[$1+7] # page table index length (allocated) +define DH_PTINPTI Memi[$1+8] # number of page table pages +define DH_PTLEN Memi[$1+9] # number of allocated PTE entries +define DH_PTNPTE Memi[$1+10] # number of PTEs (data pages) +define DH_DATASTART Memi[$1+11] # file offset of first data page + +# File table entry (FTE) on disk. +define LEN_FTEX 2 # length of file table entry (ints) +define FT_FSIZE Memi[$1] # file size, bytes +define FT_FLAGS Memi[$1+1] # file bitflags diff --git a/sys/fmio/fmiobind.x b/sys/fmio/fmiobind.x new file mode 100644 index 00000000..b31c7ada --- /dev/null +++ b/sys/fmio/fmiobind.x @@ -0,0 +1,61 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "fmio.h" + +# FMIO_BIND -- Called when a new datafile is being created, to bind the +# current datafile parameters set in the descriptor to the physical datafile. + +procedure fmio_bind (fm) + +pointer fm #I FMIO descriptor + +pointer ft, pti, pt +int chan, szbpage, ftoff, ftlen, ptioff, ptilen, ptlen + +begin + if (FM_ACTIVE(fm) != NO) + return + + # Initialize buffer sizes. + call fmio_setbuf (fm) + + chan = FM_CHAN(fm) + szbpage = FM_SZBPAGE(fm) + ftoff = LEN_DHSTRUCT + 1 + ftlen = (FM_NLFILES(fm) + 1) * LEN_FTE + ptioff = ftoff + (FM_NLFILES(fm) + 1) * LEN_FTEX + ptilen = FM_PTILEN(fm) + ptlen = szbpage / (SZ_SHORT * SZB_CHAR) + + # Determine the byte offset of the first data page. + FM_DATASTART(fm) = max (1, + (((ptioff+ptilen-1) * SZ_INT*SZB_CHAR) + szbpage-1) / + szbpage) * szbpage + 1 + + # Initialize the file table. + call calloc (ft, ftlen, TY_STRUCT) + FM_FTOFF(fm) = ftoff + FM_FTLASTNF(fm) = 0 + FM_FTABLE(fm) = ft + + # Initialize the page table index. + call calloc (pti, ptilen, TY_INT) + FM_PTIOFF(fm) = ptioff + FM_PTINPTI(fm) = 0 + FM_PTINDEX(fm) = pti + + # Initialize the page table, stored in the data pages. Note that the + # page table length must be an integral multiple of the page size. + + call calloc (pt, ptlen, TY_SHORT) + FM_PTLEN(fm) = ptlen + FM_PTNPTE(fm) = 0 + FM_PTLUPTE(fm) = 0 + FM_PTABLE(fm) = pt + + FM_ACTIVE(fm) = YES + FM_DHMODIFIED(fm) = YES + + call fm_sync (fm) +end diff --git a/sys/fmio/fmioerr.x b/sys/fmio/fmioerr.x new file mode 100644 index 00000000..dd15e7be --- /dev/null +++ b/sys/fmio/fmioerr.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "fmio.h" + +# FMIO_ERRCHK -- Check for a posted error, and process the error if one is +# posted. + +procedure fmio_errchk (fm) + +pointer fm #I FMIO descriptor + +int errcode + +begin + errcode = FM_ERRCODE(fm) + if (errcode != OK) { + FM_ERRCODE(fm) = OK + call syserrs (errcode, FM_ERROPSTR(fm)) + } +end diff --git a/sys/fmio/fmioextnd.x b/sys/fmio/fmioextnd.x new file mode 100644 index 00000000..0517eb93 --- /dev/null +++ b/sys/fmio/fmioextnd.x @@ -0,0 +1,82 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "fmio.h" + +# FMIO_EXTEND -- Allocate new pages in the datafile. Allocate the new pages +# and modify the in-core page table and lfile pagemap accordingly. The PTI is +# not modified, allocating new pages to store the page table itself, until +# fm_sync is called. The page number of the first page allocated is returned +# as the function value (a contiguous sequence of pages will be allocated). + +int procedure fmio_extend (fm, lfile, npages) + +pointer fm #I FMIO descriptor +int lfile #I lfile getting the new pages +int npages #I number of pages to add + +pointer pt, pm, lf +int npte_perpage, npti +int inc, np, p1, p2, l1, l2, i +int krealloc() + +begin + # Extend the global page table. + p1 = FM_PTNPTE(fm) + 1 + p2 = p1 + npages - 1 + + # Make sure we have enough page table index entries for the new pages. + if (lfile != PT_LFILE) { + npte_perpage = FM_SZBPAGE(fm) / (SZB_CHAR*SZ_SHORT) + np = p2 + FM_PTILEN(fm) + npti = (np + npte_perpage-1) / npte_perpage + if (npti > FM_PTILEN(fm)) { + call fmio_posterr (fm, SYS_FMPTIOVFL, FM_DFNAME(fm)) + return (ERR) + } + } + + # Increase the size of the in-core page table if necessary. + if (p2 > FM_PTLEN(fm)) { + inc = FM_SZBPAGE(fm) / (SZ_SHORT * SZB_CHAR) + FM_PTLEN(fm) = ((p2 + inc-1) / inc) * inc + if (krealloc (FM_PTABLE(fm), FM_PTLEN(fm), TY_SHORT) == ERR) + return (ERR) + } + + # Add the pages to the global page table. + FM_PTNPTE(fm) = p2 + pt = FM_PTABLE(fm) + do i = p1, p2 + Mems[pt+i-1] = lfile + + lf = FM_FTABLE(fm) + lfile * LEN_FTE + pm = LF_PAGEMAP(lf) + + # Extend the lfile page table if the lfile is active. + if (pm != NULL) { + l1 = LF_NPAGES(lf) + 1 + l2 = l1 + npages - 1 + + # Increase the size of the lfile pagemap if necessary. + if (l2 > LF_PMLEN(lf)) { + LF_PMLEN(lf) = (l2 + INC_PMLEN-1) / INC_PMLEN * INC_PMLEN + if (krealloc (LF_PAGEMAP(lf), LF_PMLEN(lf), TY_INT) == ERR) + return (ERR) + pm = LF_PAGEMAP(lf) + } + + # Add the pages to the lfile page table. + LF_NPAGES(lf) = l2 + do i = l1, l2 + Memi[pm+i-1] = p1 + i - l1 + } + + # Update the FTE for lfile zero (the page table file). + lf = FM_FTABLE(fm) + LF_FSIZE(lf) = FM_PTNPTE(fm) * SZ_SHORT * SZB_CHAR + + FM_DHMODIFIED(fm) = YES + return (p1) +end diff --git a/sys/fmio/fmiopost.x b/sys/fmio/fmiopost.x new file mode 100644 index 00000000..23c5eaae --- /dev/null +++ b/sys/fmio/fmiopost.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "fmio.h" + +# FMIO_POSTERR -- Post an error. This is called to flag an error condition +# by low level code that cannot call the error handling code directly. + +procedure fmio_posterr (fm, errcode, opstr) + +pointer fm #I FMIO descriptor +int errcode #I error code +char opstr[ARB] #I operand id string + +begin + # In case of multiple errors, post only the first one. + if (FM_ERRCODE(fm) == OK) { + FM_ERRCODE(fm) = errcode + call strcpy (opstr, FM_ERROPSTR(fm), SZ_ERROPSTR) + } +end diff --git a/sys/fmio/fmiorhdr.x b/sys/fmio/fmiorhdr.x new file mode 100644 index 00000000..1b7f6c3c --- /dev/null +++ b/sys/fmio/fmiorhdr.x @@ -0,0 +1,147 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "fmio.h" + +# FMIO_READHEADER -- Read the header of a FMIO datafile and set up the FMIO +# runtime descriptor. + +procedure fmio_readheader (fm) + +pointer fm #I FMIO descriptor + +pointer sp, buf, dh, pti, pt, ft, ip, op +int offset, buflen, npti, p1, p2, d1, d2, b_off1, b_off2, i +int status, chan, nbytes, nwords, maxpages, szbpage +errchk syserrs, calloc, malloc, realloc +long clktime() + +begin + call smark (sp) + call salloc (dh, LEN_DHSTRUCT, TY_STRUCT) + + chan = FM_CHAN(fm) + + # Make a guess at the size of buffer needed to hold the header. + buflen = DEF_DFHDRLEN + call malloc (buf, buflen, TY_STRUCT) + + # Read the full datafile header area into BUF. + repeat { + # Get the raw data. + nbytes = buflen * (SZ_STRUCT * SZB_CHAR) + call zardbf (chan, Memi[buf], nbytes, 1) + call zawtbf (chan, status) + if (status == ERR) + call syserrs (SYS_FMRERR, FM_DFNAME(fm)) + + # Extract the datafile header struct. + call miiupk32 (Memi[buf], Memi[dh], LEN_DHSTRUCT, TY_STRUCT) + if (DH_MAGIC(dh) != FMIO_MAGIC) + call syserrs (SYS_FMBADMAGIC, FM_DFNAME(fm)) + + # Repeat if the full header was not read. + if (DH_DATASTART(dh)-1 > nbytes) { + buflen = DH_DATASTART(dh)-1 / (SZ_STRUCT * SZB_CHAR) + call realloc (buf, buflen, TY_STRUCT) + } else if (status < DH_DATASTART(dh)-1) { + call syserrs (SYS_FMTRUNC, FM_DFNAME(fm)) + } else + break + } + + # Compute region of file in buffer. + b_off1 = 1 + b_off2 = b_off1 + buflen * SZ_STRUCT * SZB_CHAR + + # Copy general header fields. + FM_DFVERSION(fm) = DH_DFVERSION(dh) + FM_SZBPAGE(fm) = DH_SZBPAGE(dh) + FM_NLFILES(fm) = DH_NLFILES(dh) + FM_DATASTART(fm) = DH_DATASTART(dh) + FM_LSYNCTIME(fm) = clktime(0) + FM_DHMODIFIED(fm) = NO + + # Initialize buffer sizes. + szbpage = FM_SZBPAGE(fm) + call fmio_setbuf (fm) + if (FM_SZBPAGE(fm) != szbpage) + call syserrs (SYS_FMBLKCHSZ, FM_DFNAME(fm)) + + # Initialize the file table. + call calloc (ft, (FM_NLFILES(fm) + 1) * LEN_FTE, TY_STRUCT) + FM_FTOFF(fm) = DH_FTOFF(dh) + FM_FTLASTNF(fm) = DH_FTLASTNF(dh) + FM_FTABLE(fm) = ft + + ip = buf + FM_FTOFF(fm) - 1 + call miiupk32 (Memi[ip], Memi[ip], + (FM_NLFILES(fm) + 1) * LEN_FTEX, TY_INT) + + do i = 0, FM_NLFILES(fm) { + op = ft + i * LEN_FTE + LF_FSIZE(op) = FT_FSIZE(ip) + LF_FLAGS(op) = FT_FLAGS(ip) + ip = ip + LEN_FTEX + } + + # Read the page table index. + FM_PTIOFF(fm) = DH_PTIOFF(dh) + FM_PTILEN(fm) = DH_PTILEN(dh) + FM_PTINPTI(fm) = DH_PTINPTI(dh) + + ip = buf + FM_PTIOFF(fm) - 1 + call malloc (pti, FM_PTILEN(fm), TY_INT) + call miiupk32 (Memi[ip], Memi[pti], FM_PTILEN(fm), TY_INT) + FM_PTINDEX(fm) = pti + + # Now read the page table itself, stored in the data pages. + FM_PTLEN(fm) = DH_PTLEN(dh) + FM_PTNPTE(fm) = DH_PTNPTE(dh) + FM_PTLUPTE(fm) = DH_PTNPTE(dh) + + call malloc (pt, FM_PTLEN(fm), TY_SHORT) + FM_PTABLE(fm) = pt + + maxpages = FM_MAXBUFSIZE(fm) / FM_SZBPAGE(fm) + if (maxpages <= 0) + maxpages = DEF_BIGBUFNP + + op = pt + npti = FM_PTINPTI(fm) + for (p1=1; p1 <= npti; p1=p2) { + # Get a contiguous range of page table pages. + d1 = Memi[pti+p1-1] + for (p2=p1+1; p2 <= npti; p2=p2+1) { + d2 = Memi[pti+p2-1] + if (d2-d1 != p2-p1 || p2-p1 >= maxpages) + break + } + + # Read in the pages. + nbytes = (p2 - p1) * FM_SZBPAGE(fm) + nwords = nbytes / (SZB_CHAR * SZ_SHORT) + offset = (d1-1) * FM_SZBPAGE(fm) + FM_DATASTART(fm) + + # Check to see if data is in BUF before reading datafile. + if (offset >= b_off1 && (offset+nbytes) <= b_off2) + call bytmov (Memi[buf], offset, Mems[op], 1, nbytes) + else { + call zardbf (chan, Mems[op], nbytes, offset) + call zawtbf (chan, status) + if (status < nbytes) + call syserrs (SYS_FMTRUNC, FM_DFNAME(fm)) + } + + op = op + nwords + } + + # Swap the data. + if (BYTE_SWAP2 == YES) + call bswap2 (Mems[pt], 1, Mems[pt], 1, npti * FM_SZBPAGE(fm)) + + call mfree (buf, TY_STRUCT) + call sfree (sp) +end diff --git a/sys/fmio/fmiosbuf.x b/sys/fmio/fmiosbuf.x new file mode 100644 index 00000000..358d4136 --- /dev/null +++ b/sys/fmio/fmiosbuf.x @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "fmio.h" + +# FMIO_SETBUF -- Set the various buffer size parameters, making sure that the +# physical constraints are met, i.e., that the buffers are an integral +# multiple of the device block size, and do not exceed the maximum transfer +# size for the device. + +procedure fmio_setbuf (fm) + +pointer fm #I FMIO descriptor + +int devblksize, devmaxsize +int optbufsize, maxbufsize, szbpage + +begin + # Get the device parameters for the device on which datafile resides. + call zsttbf (FM_CHAN(fm), FSTT_BLKSIZE, devblksize) + call zsttbf (FM_CHAN(fm), FSTT_MAXBUFSIZE, devmaxsize) + + # Make sure the page size is an integral multiple of the block size. + szbpage = (FM_SZBPAGE(fm) + devblksize-1) / devblksize * devblksize + + # Set the optimum (default) file buffer size. + optbufsize = FM_OPTBUFSIZE(fm) + if (optbufsize <= 0) { + if (DEF_OPTBUFNP <= 0) + call zsttbf (FM_CHAN(fm), FSTT_OPTBUFSIZE, optbufsize) + else + optbufsize = DEF_OPTBUFNP * szbpage + } + + # Set the maximum file buffer size. + maxbufsize = FM_MAXBUFSIZE(fm) + if (maxbufsize <= 0) { + if (DEF_MAXBUFNP > 0) + maxbufsize = DEF_MAXBUFNP * szbpage + else + maxbufsize = devmaxsize + } + + # Apply constraints and store values. + if (devmaxsize > 0) + maxbufsize = min (maxbufsize, devmaxsize) + if (maxbufsize > 0) + FM_MAXBUFSIZE(fm) = max (szbpage, maxbufsize / szbpage * szbpage) + + FM_OPTBUFSIZE(fm) = max (szbpage, optbufsize / szbpage * szbpage) + FM_DEVBLKSIZE(fm) = devblksize + FM_SZBPAGE(fm) = szbpage + + FM_DHMODIFIED(fm) = YES +end diff --git a/sys/fmio/fmiotick.x b/sys/fmio/fmiotick.x new file mode 100644 index 00000000..c29e035b --- /dev/null +++ b/sys/fmio/fmiotick.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "fmio.h" + +# FMIO_TICK -- Check the clock and do things that need to get done +# periodically, like sync the datafile. + +procedure fmio_tick (fm) + +pointer fm #I FMIO descriptor + +long clktime() + +begin + if (clktime(FM_LSYNCTIME(fm)) > SYNC_INTERVAL) + call fm_sync (fm) +end diff --git a/sys/fmio/fmlfard.x b/sys/fmio/fmlfard.x new file mode 100644 index 00000000..2e463f72 --- /dev/null +++ b/sys/fmio/fmlfard.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "fmio.h" + +# FM_LFAREAD -- Asynchronous blocked read from an lfile. The differences +# between text and binary lfiles are not visible above this level; both +# appear as binary files to FIO. + +procedure fm_lfaread (lf, buf, maxbytes, offset) + +pointer lf #I lfile descriptor +char buf[ARB] #O output data buffer +int maxbytes #I max bytes to read +long offset #I lfile offset + +int status, nb + +begin + # If reading text data, unpack the text data in place. + if (and (LF_FLAGS(lf), LFF_TEXTFILE) != 0) { + nb = (maxbytes + SZB_CHAR-1) / SZB_CHAR + call fm_lfbinread (lf, buf, nb, (offset-1) / SZB_CHAR + 1) + call fm_lfbinwait (lf, status) + if (status > 0) + call chrupk (buf, 1, buf, 1, min(maxbytes,status)) + } else + call fm_lfbinread (lf, buf, maxbytes, offset) +end diff --git a/sys/fmio/fmlfawr.x b/sys/fmio/fmlfawr.x new file mode 100644 index 00000000..7d122dc0 --- /dev/null +++ b/sys/fmio/fmlfawr.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "fmio.h" + +# FM_LFAWRITE -- Asynchronous blocked write to an lfile. The differences +# between text and binary lfiles are not visible above this level; both +# appear as binary files to FIO. + +procedure fm_lfawrite (lf, buf, nbytes, offset) + +pointer lf #I lfile descriptor +char buf[ARB] #O input data buffer +int nbytes #I nbytes to write +long offset #I lfile offset + +int status, nb +pointer sp, pk_buf + +begin + if (and (LF_FLAGS(lf), LFF_TEXTFILE) == 0) + call fm_lfbinwrite (lf, buf, nbytes, offset) + else { + call smark (sp) + call salloc (pk_buf, nbytes / SZB_CHAR, TY_CHAR) + + # Wait for i/o to complete before freeing buffer! + nb = (nbytes + SZB_CHAR-1) / SZB_CHAR + call chrpak (buf, 1, Memc[pk_buf], 1, nb) + call fm_lfbinwrite (lf, Memc[pk_buf], nb, (offset-1)/SZB_CHAR+1) + call fm_lfbinwait (lf, status) + + call sfree (sp) + } +end diff --git a/sys/fmio/fmlfawt.x b/sys/fmio/fmlfawt.x new file mode 100644 index 00000000..1fa66581 --- /dev/null +++ b/sys/fmio/fmlfawt.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "fmio.h" + +# FM_LFAWAIT -- Wait for i/o on an lfile. + +procedure fm_lfawait (lf, status) + +pointer lf #I lfile descriptor +int status #O i/o status (nbytes transferred or ERR) + +begin + call fm_lfbinwait (lf, status) + if (and (LF_FLAGS(lf), LFF_TEXTFILE) != 0) + if (status > 0) + status = status * SZB_CHAR +end diff --git a/sys/fmio/fmlfbrd.x b/sys/fmio/fmlfbrd.x new file mode 100644 index 00000000..acead281 --- /dev/null +++ b/sys/fmio/fmlfbrd.x @@ -0,0 +1,89 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "fmio.h" + +# FM_LFBINREAD -- Asynchronous blocked binary read from an lfile. We deal +# only with binary data here; unpacking of text must be done at a higher +# level. The basic procedure is to convert the indicated lfile segment into +# a range of lfile pages, then use the pagemap for the lfile to map these onto +# physical datafile pages. I/O is done in chunks of contiguous pages until +# the requested amount of data has been transferred. + +procedure fm_lfbinread (lf, buf, maxbytes, offset) + +pointer lf #I lfile descriptor +char buf[ARB] #O output data buffer +int maxbytes #I max bytes to read +long offset #I lfile offset + +pointer fm, pm +int status, chan, nleft, szbpage +int l1,l2, p1,p2, d1,d2, op, nb, np + +begin + fm = LF_FM(lf) + pm = LF_PAGEMAP(lf) + + # Verify descriptor. + if (fm == NULL || pm == NULL) { + LF_STATUS(lf) = ERR + return + } else + LF_STATUS(lf) = 0 + + np = LF_NPAGES(lf) + chan = FM_CHAN(fm) + + # Check that the read is in bounds. + nleft = min (offset + maxbytes, LF_FSIZE(lf) + 1) - offset + if (nleft <= 0) + return # read at EOF + + # Map lfile offset,nbytes into a range of lfile pages. + # I/O transfers are required to be aligned on page boundaries. + # Note that less than full page may be transferred in a read. + + szbpage = FM_SZBPAGE(fm) + l1 = (offset - 1) / szbpage + 1 + l2 = l1 + ((nleft + szbpage-1) / szbpage) - 1 + + # Read the data from the physical datafile into the user buffer, + # mapping lfile pages to physical offsets and moving data in chunks + # of as many contiguous pages as possible. + + op = 1 + for (p1=l1; nleft > 0 && p1 <= l2; p1=p2) { + # Get a contiguous range of datafile pages. + d1 = Memi[pm+p1-1] + for (p2=p1+1; p2 <= l2; p2=p2+1) { + d2 = Memi[pm+p2-1] + if (d2 - d1 != p2 - p1) + break + } + + # Read in the file segment. + nb = min (nleft, (p2 - p1) * szbpage) + call zardbf (chan, buf[op], nb, (d1-1)*szbpage + FM_DATASTART(fm)) + LF_FLAGS(lf) = or (LF_FLAGS(lf), LFF_IOINPROGRESS) + LF_LTSIZE(lf) = nb + + # Bump the i/o counters. + op = op + nb / SZB_CHAR + nleft = nleft - nb + + # If we didn't read all the data, wait until the read completes. + if (nleft > 0) { + call zawtbf (chan, status) + LF_FLAGS(lf) = and (LF_FLAGS(lf), not(LFF_IOINPROGRESS)) + if (status == ERR) { + LF_STATUS(lf) = ERR + return + } else if (status == 0) { + break + } else + LF_STATUS(lf) = LF_STATUS(lf) + status + } + } +end diff --git a/sys/fmio/fmlfbwr.x b/sys/fmio/fmlfbwr.x new file mode 100644 index 00000000..f16b71d1 --- /dev/null +++ b/sys/fmio/fmlfbwr.x @@ -0,0 +1,109 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "fmio.h" + +# FM_LFBINWRITE -- Asynchronous blocked binary write to an lfile. We deal +# only with binary data here; unpacking of text must be done at a higher +# level. The basic procedure is to convert the indicated lfile segment into +# a range of lfile pages, then use the pagemap for the lfile to map these onto +# physical datafile pages. I/O is done in chunks of contiguous pages until +# the requested amount of data has been transferred. When writing at or +# beyond EOF, new pages are automatically allocated upon demand. + +procedure fm_lfbinwrite (lf, buf, nbytes, offset) + +pointer lf #I lfile descriptor +char buf[ARB] #I input data buffer +int nbytes #I nbytes to write +long offset #I lfile offset + +pointer fm, pm +int status, chan, nleft, szbpage +int lfile, l1,l2, p1,p2, d1,d2, ip, nb, nt +int fmio_extend() + +begin + fm = LF_FM(lf) + pm = LF_PAGEMAP(lf) + + # Verify descriptor. + if (fm == NULL || pm == NULL) { + LF_STATUS(lf) = ERR + return + } else + LF_STATUS(lf) = 0 + + chan = FM_CHAN(fm) + szbpage = FM_SZBPAGE(fm) + lfile = (lf - FM_FTABLE(fm)) / LEN_FTE + nleft = nbytes + + # Extend the pagemap? + while (offset + nbytes > LF_NPAGES(lf)*szbpage + 1) + if (fmio_extend (fm, lfile, 1) == ERR) { + LF_STATUS(lf) = ERR + return + } else + pm = LF_PAGEMAP(lf) + + # Map lfile offset,nbytes into a range of lfile pages. + # I/O transfers are required to be aligned on page boundaries. + + l1 = (offset - 1) / szbpage + 1 + l2 = l1 + ((nleft + szbpage-1) / szbpage) - 1 + + # Write the data from the user buffer to the physical datafile, + # mapping lfile pages to physical offsets and moving data in chunks + # of as many contiguous pages as possible. + + ip = 1 + for (p1=l1; nleft > 0 && p1 <= l2; p1=p2) { + # Get a contiguous range of datafile pages. + d1 = Memi[pm+p1-1] + for (p2=p1+1; p2 <= l2; p2=p2+1) { + d2 = Memi[pm+p2-1] + if (d2 - d1 != p2 - p1) + break + } + + # Compute the logical transfer size NB, and the amount of data + # to be physically written NT. The latter is always an integral + # number of datafile pages in size. NOTE that this requires that + # the user buffer be an integral multiple of the page size, to + # prevent referencing off the end of the buffer. + + nb = min (nleft, (p2 - p1) * szbpage) + nt = (nb + szbpage-1) / szbpage * szbpage + LF_LTSIZE(lf) = nb + + # Write the file segment. + call zawrbf (chan, buf[ip], nt, (d1-1)*szbpage + FM_DATASTART(fm)) + LF_FLAGS(lf) = or (LF_FLAGS(lf), LFF_IOINPROGRESS) + + # Bump the i/o counters. + ip = ip + nb / SZB_CHAR + nleft = nleft - nb + + # If we didn't write all the data, wait until the write completes. + if (nleft > 0) { + call zawtbf (chan, status) + LF_FLAGS(lf) = and (LF_FLAGS(lf), not(LFF_IOINPROGRESS)) + if (status == ERR) { + LF_STATUS(lf) = ERR + return + } else if (status == 0) { + break + } else + LF_STATUS(lf) = LF_STATUS(lf) + min(LF_LTSIZE(lf),status) + } + } + + # Update the lfile size counter. + nb = offset + nbytes - 1 + if (nb > LF_FSIZE(lf)) { + LF_FSIZE(lf) = nb + FM_DHMODIFIED(fm) = YES + } +end diff --git a/sys/fmio/fmlfbwt.x b/sys/fmio/fmlfbwt.x new file mode 100644 index 00000000..2310c281 --- /dev/null +++ b/sys/fmio/fmlfbwt.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "fmio.h" + +# FM_LFBINWAIT -- Wait for i/o on a binary lfile. + +procedure fm_lfbinwait (lf, status) + +pointer lf #I lfile descriptor +int status #O i/o status (nbytes transferred or ERR) + +pointer fm +int chan + +begin + fm = LF_FM(lf) + chan = FM_CHAN(fm) + + # Wait for i/o and increment byte count. + if (and (LF_FLAGS(lf), LFF_IOINPROGRESS) != 0) { + call zawtbf (chan, status) + if (status >= 0) + LF_STATUS(lf) = LF_STATUS(lf) + min(LF_LTSIZE(lf),status) + else + LF_STATUS(lf) = ERR + LF_FLAGS(lf) = and (LF_FLAGS(lf), not(LFF_IOINPROGRESS)) + } + + call fmio_tick (fm) + status = LF_STATUS(lf) +end diff --git a/sys/fmio/fmlfcls.x b/sys/fmio/fmlfcls.x new file mode 100644 index 00000000..3084373d --- /dev/null +++ b/sys/fmio/fmlfcls.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "fmio.h" + +# FM_LFCLOSE -- Close an lfile descriptor. There isn't much for us to do, +# since the physical datafile remains open, and opening an lfile does not +# allocate a descriptor. + +procedure fm_lfclose (lf, status) + +pointer lf #I lfile descriptor +int status #O i/o status (nbytes transferred or ERR) + +pointer fm + +begin + fm = LF_FM(lf) + + if (fm == NULL) + status = ERR + else if (FM_MAGIC(fm) != FMIO_MAGIC) + status = ERR + else + status = OK + + call fmio_tick (fm) +end diff --git a/sys/fmio/fmlfcopy.x b/sys/fmio/fmlfcopy.x new file mode 100644 index 00000000..db937a7b --- /dev/null +++ b/sys/fmio/fmlfcopy.x @@ -0,0 +1,118 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "fmio.h" + +# FM_LFCOPY -- Copy an lfile, either to another lfile within the same +# datafile, or to another datafile. + +procedure fm_lfcopy (old, o_lfile, new, n_lfile) + +pointer old, new #I FMIO descriptors of source and destination +int o_lfile, n_lfile #I lfile numbers of source and dest. lfiles + +long offset +int n_szbpage +pointer sp, o_ft, n_ft, o_lf, n_lf, o_lfname, n_lfname, buf +int maxpages, maxbytes, nbytes, type, nleft, status + +errchk fmio_errchk, fmio_bind, syserrs +define olderr_ 91 +define newerr_ 92 + +begin + # Verify input. + if (o_lfile < 0 || o_lfile > FM_NLFILES(old)) + goto olderr_ + if (n_lfile < 0 || n_lfile > FM_NLFILES(new)) + goto newerr_ + + # Compute some useful values. + o_ft = FM_FTABLE(old) + n_ft = FM_FTABLE(new) + n_szbpage = FM_SZBPAGE(new) + maxpages = FM_MAXBUFSIZE(new) / n_szbpage + if (maxpages <= 0) + maxpages = DEF_BIGBUFNP + maxbytes = n_szbpage * maxpages + + # Copy the lfile. + o_lf = o_ft + o_lfile * LEN_FTE + n_lf = n_ft + n_lfile * LEN_FTE + + # Skip empty or deleted lfiles. + LF_FLAGS(n_lf) = and (LF_FLAGS(o_lf), not(LFF_DELETED)) + if (LF_FSIZE(o_lf) <= 0 || and(LF_FLAGS(o_lf),LFF_DELETED) != 0) + return + + # Get lfile type. + type = BINARY_FILE + if (and(LF_FLAGS(o_lf),LFF_TEXTFILE) != 0) + type = TEXT_FILE + + # Allocate buffers. + call smark (sp) + call salloc (o_lfname, SZ_FNAME, TY_CHAR) + call salloc (n_lfname, SZ_FNAME, TY_CHAR) + call salloc (buf, maxbytes / SZB_CHAR, TY_CHAR) + + # Open old lfile. + call fm_lfname (old, o_lfile, type, Memc[o_lfname], SZ_FNAME) + call strpak (Memc[o_lfname], Memc[o_lfname], SZ_FNAME) + call fm_lfopen (Memc[o_lfname], READ_ONLY, o_lf) + if (o_lf == ERR) + goto olderr_ + + # Open new lfile. + call fm_lfname (new, n_lfile, type, Memc[n_lfname], SZ_FNAME) + call strpak (Memc[n_lfname], Memc[n_lfname], SZ_FNAME) + call fm_lfopen (Memc[n_lfname], NEW_FILE, n_lf) + if (n_lf == ERR) + goto newerr_ + + # Copy the lfile data (as a binary file to avoid needless + # character unpack/pack). + + nleft = LF_FSIZE(o_lf) + for (offset=1; nleft > 0; offset=offset+nbytes) { + # Read a block of data. + call fm_lfbinread (o_lf, Memc[buf], maxbytes, offset) + call fm_lfbinwait (o_lf, nbytes) + if (nbytes == ERR) + goto olderr_ + else if (nbytes == 0) + break + + # Write to the new datafile. + call fm_lfbinwait (n_lf, status) + if (status == ERR) + goto newerr_ + call fm_lfbinwrite (n_lf, Memc[buf], nbytes, offset) + nleft = nleft - nbytes + } + + # Wait for the last write to terminate. + call fm_lfbinwait (n_lf, status) + if (status == ERR) + goto newerr_ + + # Close the lfiles. + call fm_lfclose (o_lf, status) + if (status == ERR) + goto olderr_ + call fm_lfclose (n_lf, status) + if (status == ERR) + goto newerr_ + + call fmio_errchk (old) + call fmio_errchk (new) + + call sfree (sp) + return + +olderr_ + call syserrs (SYS_FMLFCOPY, FM_DFNAME(old)) +newerr_ + call syserrs (SYS_FMLFCOPY, FM_DFNAME(new)) +end diff --git a/sys/fmio/fmlfdel.x b/sys/fmio/fmlfdel.x new file mode 100644 index 00000000..001de927 --- /dev/null +++ b/sys/fmio/fmlfdel.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "fmio.h" + +# FM_LFDELETE -- Delete an lfile. + +procedure fm_lfdelete (fm, lfile) + +pointer fm #I FMIO descriptor +int lfile #I lfile number + +pointer lf +errchk syserrs, fmio_bind, fmio_errchk + +begin + call fmio_bind (fm) + call fmio_errchk (fm) + + # Verify input. + if (lfile < 0 || lfile > FM_NLFILES(fm)) + call syserrs (SYS_FMLFNOOB, FM_DFNAME(fm)) + + lf = FM_FTABLE(fm) + lfile * LEN_FTE + LF_FLAGS(lf) = or (LF_FLAGS(lf), LFF_DELETED) + + FM_DHMODIFIED(fm) = YES + call fmio_tick (fm) +end diff --git a/sys/fmio/fmlfname.x b/sys/fmio/fmlfname.x new file mode 100644 index 00000000..1d0b92e7 --- /dev/null +++ b/sys/fmio/fmlfname.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "fmio.h" + +# FM_LFNAME -- Encode the pseudo-filename for an lfile. This is necessary to +# pass all lfile info through FIO, when opening a file descriptor on an lfile. +# +# The filename syntax is "Tddd.fff" where +# +# T is 'B' or 'T' for text or binary +# ddd is the encoded descriptor pointer +# fff is the encoded lfile number + +procedure fm_lfname (fm, lfile, type, lfname, maxch) + +pointer fm #I FMIO descriptor +int lfile #I lfile number +int type #I file type, text or binary +char lfname[maxch] #O encoded lfile filename +int maxch #I max chars out + +int op +int itoc() +errchk fmio_bind, fmio_errchk + +begin + call fmio_bind (fm) + call fmio_errchk (fm) + if (maxch <= 0) + return + + op = 1 + if (type == TEXT_FILE) + lfname[op] = 'T' + else + lfname[op] = 'B' + op = min (maxch, op + 1) + + op = min (maxch, op + itoc (fm, lfname[op], maxch-op+1)) + lfname[op] = '.' + op = min (maxch, op + 1) + op = min (maxch, op + itoc (lfile, lfname[op], maxch-op+1)) + lfname[op] = EOS +end diff --git a/sys/fmio/fmlfopen.x b/sys/fmio/fmlfopen.x new file mode 100644 index 00000000..a267834a --- /dev/null +++ b/sys/fmio/fmlfopen.x @@ -0,0 +1,89 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "fmio.h" + +# FM_LFOPEN -- Open an lfile. This routine is designed to be called with a +# pseudo-filename identifying the FMIO datafile, lfile therein, and file type. +# This is necessary to conform to the binary file driver interface standard. + +procedure fm_lfopen (pk_lfname, mode, chan) + +char pk_lfname[ARB] #I encoded lfile specification (packed char) +int mode #I file access mode +int chan #O i/o channel assigned (descriptor) + +int flags, lfile, type, np, i +pointer sp, lfname, fm, lf, pt, pm +int kmalloc(), krealloc(), fm_lfparse() +define err_ 91 + +begin + call smark (sp) + call salloc (lfname, SZ_FNAME, TY_CHAR) + + flags = 0 + + # Parse the file spec. + call strupk (pk_lfname, Memc[lfname], SZ_FNAME) + if (fm_lfparse (Memc[lfname], fm, lfile, type) == ERR) + goto err_ + else if (type == TEXT_FILE) + flags = flags + LFF_TEXTFILE + + # Verify input. + if (FM_MAGIC(fm) != FMIO_MAGIC) + goto err_ + else if (lfile < 0 || lfile > FM_NLFILES(fm)) + goto err_ + else if (lfile == PT_LFILE && mode != READ_ONLY) + goto err_ # protect page table! + + lf = FM_FTABLE(fm) + lfile * LEN_FTE + + # Activate the descriptor? + if (LF_PAGEMAP(lf) == NULL) { + LF_PMLEN(lf) = DEF_PMLEN + if (kmalloc (LF_PAGEMAP(lf), DEF_PMLEN, TY_INT) == ERR) + goto err_ + + pm = LF_PAGEMAP(lf) + pt = FM_PTABLE(fm) + np = 0 + + # Determine the lfile pages from the global page table. + do i = 1, FM_PTNPTE(fm) + if (Mems[pt+i-1] == lfile) { + np = np + 1 + if (np > LF_PMLEN(lf)) { + LF_PMLEN(lf) = (np+INC_PMLEN-1) / INC_PMLEN * INC_PMLEN + if (krealloc (pm, LF_PMLEN(lf), TY_INT) == ERR) + goto err_ + LF_PAGEMAP(lf) = pm + } + Memi[pm+np-1] = i + } + + LF_NPAGES(lf) = np + } + + # Mode dependent processing. + if (mode == NEW_FILE || and (LF_FLAGS(lf), LFF_DELETED) != 0) { + LF_FSIZE(lf) = 0 + LF_FLAGS(lf) = flags + } + + LF_FM(lf) = fm + LF_STATUS(lf) = 0 + LF_FLAGS(lf) = or (LFF_ALLOCATED, + and (LF_FLAGS(lf), not(LFF_IOINPROGRESS))) + + FM_DHMODIFIED(fm) = YES + + chan = lf + call fmio_tick (fm) + call sfree (sp) + return +err_ + chan = ERR + call sfree (sp) +end diff --git a/sys/fmio/fmlfparse.x b/sys/fmio/fmlfparse.x new file mode 100644 index 00000000..63f43a84 --- /dev/null +++ b/sys/fmio/fmlfparse.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# FM_LFPARSE -- Parse an encoded lfile filename. +# The filename syntax is "Tddd.fff" where +# +# T is 'B' or 'T' for text or binary +# ddd is the encoded descriptor pointer +# fff is the encoded lfile number + +int procedure fm_lfparse (lfname, fm, lfile, type) + +char lfname[ARB] #I encoded lfile filename +pointer fm #O FMIO descriptor +int lfile #O lfile number +int type #O lfile file type (text or binary) + +int ip +int ctoi() + +begin + # Determine file type. + if (lfname[1] == 'T') + type = TEXT_FILE + else + type = BINARY_FILE + + # Get FMIO descriptor. + ip = 2 + if (ctoi (lfname, ip, fm) <= 0) + return (ERR) + + # Skip . delimiter. + if (lfname[ip] == '.') + ip = ip + 1 + else + return (ERR) + + # Get lfile number. + if (ctoi (lfname, ip, lfile) <= 0) + return (ERR) + + return (OK) +end diff --git a/sys/fmio/fmlfstat.h b/sys/fmio/fmlfstat.h new file mode 100644 index 00000000..14df119b --- /dev/null +++ b/sys/fmio/fmlfstat.h @@ -0,0 +1,10 @@ +# FMLFSTAT.H -- Lfile status structure definitions. + +# Lfstat structure. +define LEN_LFSTAT 2 # struct size +define LFU_SIZE $1[1] # lfile size, bytes +define LFU_FLAGS $1[2] # lfile flag bits + +# Flag bits. +define LFB_DELETED 1B # delete bit +define LFB_TEXTFILE 2B # file contains packed text diff --git a/sys/fmio/fmlfstat.x b/sys/fmio/fmlfstat.x new file mode 100644 index 00000000..a5829de0 --- /dev/null +++ b/sys/fmio/fmlfstat.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "fmio.h" + +# FMLFSTAT.H -- Query the attributes of an lfile. + +int procedure fm_lfstat (fm, lfile, statbuf) + +pointer fm #I FMIO descriptor +int lfile #I lfile number +int statbuf[ARB] #O receives status + +pointer lf +errchk fmio_bind, fmio_errchk + +begin + call fmio_bind (fm) + call fmio_errchk (fm) + + # Verify input. + if (lfile < 0 || lfile > FM_NLFILES(fm)) + return (ERR) + + # Copy out the lfile status. + lf = FM_FTABLE(fm) + lfile * LEN_FTE + LFU_SIZE(statbuf) = LF_FSIZE(lf) + LFU_FLAGS(statbuf) = LF_FLAGS(lf) + + return (OK) +end diff --git a/sys/fmio/fmlfstt.x b/sys/fmio/fmlfstt.x new file mode 100644 index 00000000..951c44c2 --- /dev/null +++ b/sys/fmio/fmlfstt.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "fmio.h" + +# FM_LFSTATI -- Stat an lfile. + +procedure fm_lfstati (lf, param, lvalue) + +pointer lf #I lfile descriptor +int param #I parameter code +long lvalue #O parameter value + +pointer fm +int chan + +begin + fm = LF_FM(lf) + chan = FM_CHAN(fm) + + # Only the file size differs for each lfile. + switch (param) { + case FSTT_FILSIZE: + lvalue = LF_FSIZE(lf) + case FSTT_BLKSIZE: + lvalue = FM_SZBPAGE(fm) + case FSTT_OPTBUFSIZE: + lvalue = FM_OPTBUFSIZE(fm) + case FSTT_MAXBUFSIZE: + lvalue = FM_MAXBUFSIZE(fm) + } + + # For text lfiles, things appear to be SZB_CHAR larger. + if (and (LF_FLAGS(lf), LFF_TEXTFILE) != 0) + lvalue = lvalue * SZB_CHAR +end diff --git a/sys/fmio/fmlfundel.x b/sys/fmio/fmlfundel.x new file mode 100644 index 00000000..98c822ee --- /dev/null +++ b/sys/fmio/fmlfundel.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "fmio.h" + +# FM_LFUNDELETE -- Undelete an lfile. + +procedure fm_lfundelete (fm, lfile) + +pointer fm #I FMIO descriptor +int lfile #I lfile number + +pointer lf +errchk syserrs, fmio_bind, fmio_errchk + +begin + call fmio_bind (fm) + call fmio_errchk (fm) + + # Verify input. + if (lfile < 0 || lfile > FM_NLFILES(fm)) + call syserrs (SYS_FMLFNOOB, FM_DFNAME(fm)) + + lf = FM_FTABLE(fm) + lfile * LEN_FTE + LF_FLAGS(lf) = and (LF_FLAGS(lf), not(LFF_DELETED)) + FM_DHMODIFIED(fm) = YES + call fmio_tick (fm) +end diff --git a/sys/fmio/fmnextlf.x b/sys/fmio/fmnextlf.x new file mode 100644 index 00000000..0747a799 --- /dev/null +++ b/sys/fmio/fmnextlf.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "fmio.h" + +# FM_NEXTLFILE -- Return the next available (empty) lfile. An error action +# is taken if all lfiles are currently in use. Deleted lfiles will be reused +# if no unused lfiles are found. + +int procedure fm_nextlfile (fm) + +pointer fm #I FMIO descriptor + +pointer ft, lf +int nlfiles, flags, fn, i +errchk syserrs, fmio_bind, fmio_errchk + +begin + call fmio_bind (fm) + call fmio_errchk (fm) + + fn = FM_FTLASTNF(fm) + ft = FM_FTABLE(fm) + nlfiles = FM_NLFILES(fm) + + # Travel once around the file table and abort if all entries are used. + # New files are normally returned in sequence. Deleted files can be + # reused. + + do i = 1, nlfiles { + fn = fn + 1 + if (fn > nlfiles) + fn = 1 + lf = ft + fn * LEN_FTE + flags = LF_FLAGS(lf) + if (and(flags,LFF_ALLOCATED) == 0 || and(flags,LFF_DELETED) != 0) + break + } + + if (i > nlfiles) + call syserrs (SYS_FMOOF, FM_DFNAME(fm)) + + FM_FTLASTNF(fm) = fn + FM_DHMODIFIED(fm) = YES + call fmio_tick (fm) + + return (fn) +end diff --git a/sys/fmio/fmopen.x b/sys/fmio/fmopen.x new file mode 100644 index 00000000..8a8657ba --- /dev/null +++ b/sys/fmio/fmopen.x @@ -0,0 +1,67 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "fmio.h" + +# FM_OPEN -- Open or create a FMIO datafile. Since this is a low level +# interface we do not want to impose a choice of a file extension on the +# datafile, so if a file extension is desired it must be supplied. + +pointer procedure fm_open (fname, mode) + +char fname[ARB] #I datafile filename +int mode #I file access mode + +int chan, n +pointer sp, osfn, fn, fm +errchk syserrs, calloc, fclobber +int nowhite() + +begin + call smark (sp) + call salloc (fn, SZ_PATHNAME, TY_CHAR) + call salloc (osfn, SZ_PATHNAME, TY_CHAR) + + n = nowhite (fname, Memc[fn], SZ_PATHNAME) + + # Take care to not clobber an existing file. + if (mode == NEW_FILE) + call fclobber (Memc[fn]) + + # Open the datafile. + call fmapfn (Memc[fn], Memc[osfn], SZ_PATHNAME) + call zopnbf (Memc[osfn], mode, chan) + if (chan == ERR) + call syserrs (SYS_FMOPEN, Memc[fn]) + + # Allocate the FMIO descriptor. + call calloc (fm, LEN_FMDES, TY_STRUCT) + + FM_MODE(fm) = mode + FM_CHAN(fm) = chan + FM_MAGIC(fm) = FMIO_MAGIC + FM_SZFCACHE(fm) = DEF_FCACHESIZE + call strcpy (Memc[fn], FM_DFNAME(fm), SZ_DFNAME) + + if (mode == NEW_FILE) { + # Wait until first i/o operation to finish initialization. + FM_DFVERSION(fm) = FMIO_VERSION + FM_SZBPAGE(fm) = DEF_PAGESIZE + FM_NLFILES(fm) = DEF_MAXLFILES + FM_PTILEN(fm) = DEF_MAXPTPAGES + FM_ACTIVE(fm) = NO + + } else { + # Open an existing datafile. + iferr (call fmio_readheader(fm)) { + call mfree (fm, TY_STRUCT) + call erract (EA_ERROR) + } else + FM_ACTIVE(fm) = YES + } + + call sfree (sp) + return (fm) +end diff --git a/sys/fmio/fmrebuild.x b/sys/fmio/fmrebuild.x new file mode 100644 index 00000000..9eb55656 --- /dev/null +++ b/sys/fmio/fmrebuild.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# FM_REBUILD -- Rebuild a datafile. This has no affect on the logical content +# of a datafile, but is desirable for efficiency reasons to eliminate waste +# space (e.g., from deleted lfiles), and render the file structures logically +# contiguous within the file, increasing i/o access efficiency. + +procedure fm_rebuild (dfname) + +char dfname[ARB] #I datafile name + +pointer sp, tfname +errchk fm_copy, fm_delete, fm_rename + +begin + call smark (sp) + call salloc (tfname, SZ_PATHNAME, TY_CHAR) + + # The copy operation rebuilds a datafile. + call mktemp (dfname, Memc[tfname], SZ_PATHNAME) + call fm_copy (dfname, Memc[tfname]) + call fm_delete (dfname) + call fm_rename (Memc[tfname], dfname) + + call sfree (sp) +end diff --git a/sys/fmio/fmrename.x b/sys/fmio/fmrename.x new file mode 100644 index 00000000..e5221536 --- /dev/null +++ b/sys/fmio/fmrename.x @@ -0,0 +1,11 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# FM_RENAME -- Rename (or move) a datafile. + +procedure fm_rename (old, new) + +char old[ARB], new[ARB] #I old, new datafile names + +begin + call rename (old, new) +end diff --git a/sys/fmio/fmset.h b/sys/fmio/fmset.h new file mode 100644 index 00000000..a271cc27 --- /dev/null +++ b/sys/fmio/fmset.h @@ -0,0 +1,24 @@ +# FMSET.H -- User definitions for FMIO. + +# SET/STAT codes. +define FM_ACMODE 1 #RO datafile access mode +define FM_FCACHESIZE 2 #RW number of files in open file cache +define FM_MAXFBSIZE 3 #RW maximum lfile-FIO buffer size +define FM_MAXLFILES 4 #RW number of lfiles in datafile +define FM_MAXPTPAGES 5 #RW max page table pages (max filesize) +define FM_OPTFBSIZE 6 #RW default lfile-FIO buffer size +define FM_OSCHAN 7 #RO os channel of datafile +define FM_PAGESIZE 8 #RW datafile page size, bytes +define FM_VERSION 9 #RO FMIO version number of datafile + +# FM_DEBUG flags. +define FMD_HEADER 001B # general header parameters +define FMD_FTABLE 002B # summarize file table contents +define FMD_PTINDEX 004B # print page table index +define FMD_PTABLE 010B # print page table +define FMD_ALL 017B # print everything + +# FM_FCDEBUG flags. +define FCD_CACHE 001B # print current cache status +define FCD_LFSTATISTICS 002B # print statistics on lfile getfd's +define FCD_ALL 003B # print everything diff --git a/sys/fmio/fmseti.x b/sys/fmio/fmseti.x new file mode 100644 index 00000000..84cefc27 --- /dev/null +++ b/sys/fmio/fmseti.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "fmset.h" +include "fmio.h" + +# FM_SETI -- Set the value of an FMIO integer parameter. + +procedure fm_seti (fm, param, value) + +pointer fm #I FMIO descriptor +int param #I parameter code from +int value #I new parameter value + +int szbpage + +begin + szbpage = FM_SZBPAGE(fm) + + switch (param) { + case FM_ACMODE: + ; # read-only + case FM_MAXLFILES: + FM_NLFILES(fm) = value + case FM_MAXPTPAGES: + FM_PTILEN(fm) = value + case FM_OSCHAN: + FM_CHAN(fm) = value + case FM_PAGESIZE: + FM_SZBPAGE(fm) = value + case FM_VERSION: + ; # read-only + case FM_OPTFBSIZE: + FM_OPTBUFSIZE(fm) = value + case FM_MAXFBSIZE: + FM_MAXBUFSIZE(fm) = value + case FM_FCACHESIZE: + FM_SZFCACHE(fm) = value + } +end diff --git a/sys/fmio/fmstati.x b/sys/fmio/fmstati.x new file mode 100644 index 00000000..82720ade --- /dev/null +++ b/sys/fmio/fmstati.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "fmset.h" +include "fmio.h" + +# FM_STATI -- Query an FMIO integer parameter. + +int procedure fm_stati (fm, param) + +pointer fm #I FMIO descriptor +int param #I parameter code from + +begin + switch (param) { + case FM_ACMODE: + return (FM_MODE(fm)) + case FM_MAXLFILES: + return (FM_NLFILES(fm)) + case FM_MAXPTPAGES: + return (FM_PTILEN(fm)) + case FM_OSCHAN: + return (FM_CHAN(fm)) + case FM_PAGESIZE: + return (FM_SZBPAGE(fm)) + case FM_VERSION: + return (FM_DFVERSION(fm)) + case FM_OPTFBSIZE: + return (FM_OPTBUFSIZE(fm)) + case FM_MAXFBSIZE: + return (FM_MAXBUFSIZE(fm)) + case FM_FCACHESIZE: + return (FM_SZFCACHE(fm)) + default: + return (ERR) + } +end diff --git a/sys/fmio/fmsync.x b/sys/fmio/fmsync.x new file mode 100644 index 00000000..7c7d8112 --- /dev/null +++ b/sys/fmio/fmsync.x @@ -0,0 +1,169 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "fmio.h" + +define SZB_SHORT (SZB_CHAR*SZ_SHORT) + +# FM_SYNC -- Update any buffered portions of the datafile on disk which have +# been modified since the last update. + +procedure fm_sync (fm) + +pointer fm #I FMIO descriptor + +pointer sp, ip, op, dhbuf, pgbuf, pti, dh, ft, pt +int maxpages, nbytes, npti, p1, p2, d1, d2, dp, i +int szbpage, chan, buflen, status, npte_perpage +int fmio_extend() +long clktime() + +begin + if (FM_MODE(fm) == READ_ONLY) + return + + call smark (sp) + chan = FM_CHAN(fm) + szbpage = FM_SZBPAGE(fm) + npte_perpage = szbpage / SZB_SHORT + + call intr_disable() + + # Get more page table space (pages). During a normal file extend + # occurring while writing to a file, PTEs for *data* pages are added + # to the incore global page table and to the PT for the lfile. + # The additional pages needed to store the PT and PTI as they grow + # are however not allocated during i/o. We wait and do this at sync + # time to provide maximal separation of the data pages and PT pages, + # rendering both as contiguous as possible. + + # Check for page table index overflow (datafile too large). + npti = (FM_PTNPTE(fm) + npte_perpage-1) / npte_perpage + if (npti > FM_PTILEN(fm)) { + call fmio_posterr (fm, SYS_FMPTIOVFL, FM_DFNAME(fm)) + + # Truncate the page table to try to recover the datafile with + # some loss of data. + + npti = FM_PTILEN(fm) + FM_PTNPTE(fm) = npti * npte_perpage - (npti - FM_PTINPTI(fm)) + } + + # Allocate the page table pages. + for (p1=FM_PTINPTI(fm)+1; p1 <= npti; p1=p1+1) { + dp = fmio_extend (fm, PT_LFILE, 1) + if (dp != ERR) { + Memi[FM_PTINDEX(fm)+p1-1] = dp + FM_PTINPTI(fm) = p1 + FM_DHMODIFIED(fm) = YES + } else + call fmio_posterr (fm, SYS_FMPTIOVFL, FM_DFNAME(fm)) + } + + # Update the datafile header area. + if (FM_DHMODIFIED(fm) != NO) { + # Allocate a buffer to hold the encoded datafile header area. + buflen = (FM_DATASTART(fm) - 1) / (SZ_STRUCT * SZB_CHAR) + call salloc (dhbuf, buflen, TY_STRUCT) + + # Encode and output the datafile header. + call salloc (dh, LEN_DHSTRUCT, TY_STRUCT) + + DH_MAGIC(dh) = FMIO_MAGIC + DH_DFVERSION(dh) = FM_DFVERSION(fm) + DH_SZBPAGE(dh) = szbpage + DH_NLFILES(dh) = FM_NLFILES(fm) + DH_FTOFF(dh) = FM_FTOFF(fm) + DH_FTLASTNF(dh) = FM_FTLASTNF(fm) + DH_PTIOFF(dh) = FM_PTIOFF(fm) + DH_PTILEN(dh) = FM_PTILEN(fm) + DH_PTINPTI(dh) = FM_PTINPTI(fm) + DH_PTLEN(dh) = FM_PTLEN(fm) + DH_PTNPTE(dh) = FM_PTNPTE(fm) + DH_DATASTART(dh) = FM_DATASTART(fm) + + call miipak32 (Memi[dh], Memi[dhbuf], LEN_DHSTRUCT, TY_STRUCT) + + # Output the file table. + ft = FM_FTABLE(fm) + op = dhbuf + FM_FTOFF(fm) - 1 + do i = 0, FM_NLFILES(fm) { + ip = ft + i * LEN_FTE + FT_FSIZE(op) = LF_FSIZE(ip) + FT_FLAGS(op) = and (LFF_SAVE, LF_FLAGS(ip)) + op = op + LEN_FTEX + } + + op = dhbuf + FM_FTOFF(fm) - 1 + call miipak32 (Memi[op], Memi[op], + (FM_NLFILES(fm) + 1) * LEN_FTEX, TY_INT) + + # Output the page table index. + call miipak32 (Memi[FM_PTINDEX(fm)], Memi[dhbuf+FM_PTIOFF(fm)-1], + FM_PTILEN(fm), TY_INT) + + # Update the whole thing on disk. + call zawrbf (chan, Memi[dhbuf], FM_DATASTART(fm)-1, 1) + call zawtbf (chan, status) + if (status == ERR) + call fmio_posterr (fm, SYS_FMWRERR, FM_DFNAME(fm)) + + FM_DHMODIFIED(fm) = NO + } + + # Don't cache these pointers before calling fmio_extend! + pt = FM_PTABLE(fm) + pti = FM_PTINDEX(fm) + + # Update the page table itself, stored in the data pages. + if (FM_PTNPTE(fm) > FM_PTLUPTE(fm)) { + + # Determine the max transfer size. + maxpages = FM_MAXBUFSIZE(fm) / szbpage + if (maxpages <= 0) + maxpages = DEF_BIGBUFNP + + # Get an output temporary buffer if we have to swap on output. + if (BYTE_SWAP2 == YES) + call salloc (pgbuf, maxpages * szbpage / SZB_SHORT, TY_SHORT) + + # Determine the PT page containing the LUPTE+1. + p1 = FM_PTLUPTE(fm) / npte_perpage + 1 + + # Update that and all following PT pages. + npti = FM_PTINPTI(fm) + for (; p1 <= npti; p1=p2) { + # Get a contiguous range of page table pages. + d1 = Memi[pti+p1-1] + for (p2=p1+1; p2 <= npti; p2=p2+1) { + d2 = Memi[pti+p2-1] + if (d2-d1 != p2-p1 || p2-p1 >= maxpages) + break + } + + # Swap the data and set IP for the output transfer. + ip = pt + (p1 - 1) * npte_perpage + nbytes = (min(npti+1,p2) - p1) * szbpage + if (BYTE_SWAP2 == YES) { + call bswap2 (Mems[ip], 1, Mems[pgbuf], 1, nbytes) + ip = pgbuf + } + + # Update the pages. + call zawrbf (chan, Mems[ip], nbytes, + (d1-1) * szbpage + FM_DATASTART(fm)) + call zawtbf (chan, status) + if (status < nbytes) + call fmio_posterr (fm, SYS_FMWRERR, FM_DFNAME(fm)) + } + + FM_PTLUPTE(fm) = FM_PTNPTE(fm) + } + + FM_LSYNCTIME(fm) = clktime(0) + call intr_enable() + + call sfree (sp) +end diff --git a/sys/fmio/mkpkg b/sys/fmio/mkpkg new file mode 100644 index 00000000..0daf637a --- /dev/null +++ b/sys/fmio/mkpkg @@ -0,0 +1,52 @@ +# Make the FMIO (file manager i/o) library. + +$checkout libsys.a lib$ +$update libsys.a +$checkin libsys.a lib$ +$exit + +zzdebug: +zzdebug.e: + $omake zzdebug.x fmset.h + $link zzdebug.o + ; + +libsys.a: + fmaccess.x + fmclose.x fmio.h + fmcopy.x fmset.h + fmcopyo.x fmio.h + fmdebug.x fmio.h fmset.h + fmdelete.x + fmfcache.x fmio.h fmset.h + fmfopen.x + fmiobind.x fmio.h + fmioerr.x fmio.h + fmioextnd.x fmio.h + fmiopost.x fmio.h + fmiorhdr.x fmio.h + fmiosbuf.x fmio.h + fmiotick.x fmio.h + fmlfard.x fmio.h + fmlfawr.x fmio.h + fmlfawt.x fmio.h + fmlfbrd.x fmio.h + fmlfbwr.x fmio.h + fmlfbwt.x fmio.h + fmlfcls.x fmio.h + fmlfcopy.x fmio.h + fmlfdel.x fmio.h + fmlfname.x fmio.h + fmlfopen.x fmio.h + fmlfparse.x + fmlfstat.x fmio.h + fmlfstt.x fmio.h + fmlfundel.x fmio.h + fmnextlf.x fmio.h + fmopen.x fmio.h + fmrebuild.x + fmrename.x + fmseti.x fmio.h fmset.h + fmstati.x fmio.h fmset.h + fmsync.x fmio.h + ; diff --git a/sys/fmio/zzdebug.x b/sys/fmio/zzdebug.x new file mode 100644 index 00000000..1764d62e --- /dev/null +++ b/sys/fmio/zzdebug.x @@ -0,0 +1,303 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "fmset.h" + +# ZZDEBUG.X -- Debug routines for the FMIO package. + +task create = t_create, + enter = t_enter, + extract = t_extract, + mkfile = t_mkfile, + type = t_type, + show = t_show, + copy = t_copy, + rebuild = t_rebuild, + fcache = t_fcache + + +# CREATE -- Create a new, empty datafile. + +procedure t_create() + +pointer fm +char datafile[SZ_FNAME] +int pagesize, nlfiles, maxptpages + +int clgeti() +pointer fm_open() + +begin + call clgstr ("datafile", datafile, SZ_FNAME) + pagesize = clgeti ("pagesize") + nlfiles = clgeti ("nlfiles") + maxptpages = clgeti ("maxptpages") + + fm = fm_open (datafile, NEW_FILE) + if (pagesize > 0) + call fm_seti (fm, FM_PAGESIZE, pagesize) + if (nlfiles > 0) + call fm_seti (fm, FM_MAXLFILES, nlfiles) + if (maxptpages > 0) + call fm_seti (fm, FM_MAXPTPAGES, maxptpages) + call fm_close (fm) +end + + +# ENTER -- Copy a regular disk file into an lfile. + +procedure t_enter() + +pointer fm +int lfile, type, fd, lf +char datafile[SZ_FNAME], fname[SZ_FNAME] +int clgeti(), open(), fm_fopen(), access() +pointer fm_open() + +begin + call clgstr ("datafile", datafile, SZ_FNAME) + call clgstr ("fname", fname, SZ_FNAME) + lfile = clgeti ("lfile") + + if (access (fname, 0, TEXT_FILE) == YES) + type = TEXT_FILE + else + type = BINARY_FILE + + fm = fm_open (datafile, READ_WRITE) + fd = open (fname, READ_ONLY, type) + lf = fm_fopen (fm, lfile, NEW_FILE, type) + call fcopyo (fd, lf) + + call close (lf) + call close (fd) + call fm_close (fm) +end + + +# EXTRACT -- Copy an lfile out into a disk file. + +procedure t_extract() + +pointer fm +int lfstat[LEN_LFSTAT] +int lfile, type, fd, lf +char datafile[SZ_FNAME], fname[SZ_FNAME] +int clgeti(), open(), fm_fopen(), fm_lfstat() +pointer fm_open() + +begin + call clgstr ("datafile", datafile, SZ_FNAME) + call clgstr ("fname", fname, SZ_FNAME) + lfile = clgeti ("lfile") + + fm = fm_open (datafile, READ_ONLY) + + if (fm_lfstat (fm, lfile, lfstat) == ERR) + call error (1, "cannot stat lfile") + else if (and (LFU_FLAGS(lfstat), LFB_TEXTFILE) != 0) + type = TEXT_FILE + else + type = BINARY_FILE + + lf = fm_fopen (fm, lfile, READ_ONLY, type) + fd = open (fname, NEW_FILE, type) + call fcopyo (lf, fd) + + call close (lf) + call close (fd) + call fm_close (fm) +end + + +# MKFILE -- Create a file of the given size (in kilobytes) containing all +# zero data. + +procedure t_mkfile() + +pointer fm +int lfile, lf, kb, i +char datafile[SZ_FNAME], buf[1024/SZB_CHAR] +int clgeti(), fm_fopen() +pointer fm_open() + +begin + call clgstr ("datafile", datafile, SZ_FNAME) + lfile = clgeti ("lfile") + kb = clgeti ("kb") + + fm = fm_open (datafile, READ_WRITE) + lf = fm_fopen (fm, lfile, NEW_FILE, BINARY_FILE) + + do i = 1, kb + iferr (call write (lf, buf, 1024/SZB_CHAR)) { + call erract (EA_WARN) + break + } + + call close (lf) + call fm_close (fm) +end + + +# TYPE -- Print the contents of an lfile on the standard output. + +procedure t_type() + +pointer fm +int lfile, fd +char datafile[SZ_FNAME] +int clgeti(), fm_fopen() +pointer fm_open() + +begin + call clgstr ("datafile", datafile, SZ_FNAME) + lfile = clgeti ("lfile") + + fm = fm_open (datafile, READ_WRITE) + fd = fm_fopen (fm, lfile, READ_ONLY, TEXT_FILE) + call fcopyo (fd, STDOUT) + + call close (fd) + call fm_close (fm) +end + + +# SHOW -- Print the datafile status. + +procedure t_show() + +pointer fm +char datafile[SZ_FNAME] +pointer fm_open() + +begin + call clgstr ("datafile", datafile, SZ_FNAME) + + fm = fm_open (datafile, READ_WRITE) + call fm_debug (fm, STDOUT, FMD_ALL) + call fm_close (fm) +end + + +# COPY -- Copy a datafile. + +procedure t_copy() + +char df_src[SZ_FNAME] +char df_dst[SZ_FNAME] + +begin + call clgstr ("source", df_src, SZ_FNAME) + call clgstr ("destination", df_dst, SZ_FNAME) + call fm_copy (df_src, df_dst) +end + + +# REBUILD -- Rebuild a datafile. + +procedure t_rebuild() + +char datafile[SZ_FNAME] + +begin + call clgstr ("datafile", datafile, SZ_FNAME) + call fm_rebuild (datafile) +end + + +# Test the file cache package. +# ------------------------------- + +define GETFD 1 +define RETFD 2 +define LOCKOUT 3 +define UNLOCK 4 +define LOCKED 5 +define SYNC 6 +define DEBUG 7 +# +define FCDEBUG 9 +define PFILE 10 +define BYE 11 + +define KEYWORDS "|getfd|retfd|lockout|unlock|locked|sync|debug|\ + |fcdebug|pfile|bye|" + + +# FCACHE -- Test the file cache package. + +procedure t_fcache() + +pointer fm +int lfile, mode, type, fd +char datafile[SZ_FNAME], keyword[SZ_FNAME], junk[SZ_FNAME] +int strdic(), fscan(), fm_getfd() +bool fm_locked() +pointer fm_open() + +begin + call clgstr ("datafile", datafile, SZ_FNAME) + fm = fm_open (datafile, READ_WRITE) + + call printf ("* ") + call flush (STDOUT) + while (fscan (STDIN) != EOF) { + call gargwrd (keyword, SZ_FNAME) + if (IS_ALPHA(keyword[1])) + switch (strdic (keyword, junk, SZ_FNAME, KEYWORDS)) { + case GETFD: + call gargi (lfile) + call gargi (mode) + call gargi (type) + iferr (fd = fm_getfd (fm, lfile, mode, type)) + call erract (EA_WARN) + else { + call printf ("fd = %d\n") + call pargi (fd) + } + case RETFD: + call gargi (lfile) + call fm_retfd (fm, lfile) + + case LOCKOUT: + call gargi (lfile) + iferr (call fm_lockout (fm, lfile)) + call erract (EA_WARN) + case UNLOCK: + call gargi (lfile) + iferr (call fm_unlock (fm, lfile)) + call erract (EA_WARN) + case LOCKED: + call gargi (lfile) + call printf ("locked = %b\n") + call pargb (fm_locked (fm, lfile)) + + case SYNC: + call fm_fcsync (fm) + case DEBUG: + call fm_debug (fm, STDOUT, FMD_ALL) + case FCDEBUG: + call fm_fcdebug (fm, STDOUT, FCD_ALL) + case PFILE: + call gargi (lfile) + fd = fm_getfd (fm, lfile, READ_ONLY, TEXT_FILE) + iferr (call fcopyo (fd, STDOUT)) + call erract (EA_WARN) + call fm_retfd (fm, lfile) + case BYE: + break + default: + call eprintf ("commands: %s\n") + call pargstr (KEYWORDS) + } + + call printf ("* ") + call flush (STDOUT) + } + + call fm_close (fm) +end diff --git a/sys/fmtio/README b/sys/fmtio/README new file mode 100644 index 00000000..08d8bd28 --- /dev/null +++ b/sys/fmtio/README @@ -0,0 +1,6 @@ +This directory contains the IRAF Formatted I/O (FMTIO) routines. The FMTIO +package includes the string utilities (str___), character utilities (chr___), +encode/decode primitives (ctod, itoc, etc.), and the high level SCAN and +PRINTF routines. This is a full implementation of FMTIO (excluding the +language dependent features that will be provided when the full language +becomes available). diff --git a/sys/fmtio/cctoc.x b/sys/fmtio/cctoc.x new file mode 100644 index 00000000..6ad6ea8f --- /dev/null +++ b/sys/fmtio/cctoc.x @@ -0,0 +1,67 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +define OCTAL 8 + +# CCTOC -- Convert a character constant into the ASCII value of the character +# represented. A character constant may be any whitespace delimited +# character, backslash escaped character, or a string of the form 'c', '\c', +# or '\nnn'. The following are all legal character constants: +# +# c 'c' '\n' '\07' \ \\ \n +# +# The number of characters successfully converted is returned as the function +# value. + +int procedure cctoc (str, ip, cval) + +char str[ARB] # input string +int ip # index into input string +char cval # receives character value + +long lval +bool eat_tick +int n, junk, ip_save +int stridx(), gctol() +include "escchars.inc" + +begin + while (IS_WHITE (str[ip])) + ip = ip + 1 + ip_save = ip + + if (str[ip] == SQUOTE) { # '...' + eat_tick = true + ip = ip + 1 + } else + eat_tick = false + + if (str[ip] == ESCAPE && str[ip+1] != EOS) { # \... + ip = ip + 1 + n = stridx (str[ip], escape_chars) # \c + if (n > 0) { + cval = mapped_chars[n] + ip = ip + 1 + } else if (IS_DIGIT (str[ip])) { # \nnn + junk = gctol (str, ip, lval, -OCTAL) + cval = lval + } else if (eat_tick) { # '\c' + cval = str[ip] + ip = ip + 1 + } else + cval = ESCAPE # \ alone + + } else if (str[ip] != EOS) { + cval = str[ip] # c or 'c' + ip = ip + 1 + + } else if (eat_tick) + cval = SQUOTE # 'EOS + + if (eat_tick && str[ip] == SQUOTE) + ip = ip + 1 + + return (ip - ip_save) +end diff --git a/sys/fmtio/chdeposit.x b/sys/fmtio/chdeposit.x new file mode 100644 index 00000000..0e0dc961 --- /dev/null +++ b/sys/fmtio/chdeposit.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CHDEPOSIT -- Deposit a character in a string at the offset OP. Bump OP, +# taking care not to overflow the string. + +procedure chdeposit (ch, str, maxch, op) + +char ch # character to be deposited +char str[ARB] # output string +int maxch # maxch chars in output string +int op # pointer into output string + +begin + str[op] = ch + if (op < maxch) + op = op + 1 +end diff --git a/sys/fmtio/chfetch.x b/sys/fmtio/chfetch.x new file mode 100644 index 00000000..f9ab4197 --- /dev/null +++ b/sys/fmtio/chfetch.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CHFETCH -- Return the next character from a string, bump pointer. + +char procedure chfetch (str, ip, ch) + +char str[ARB], ch +int ip + +begin + ch = str[ip] + if (ch != EOS) + ip = ip + 1 + + return (ch) +end diff --git a/sys/fmtio/chrlwr.x b/sys/fmtio/chrlwr.x new file mode 100644 index 00000000..a0050207 --- /dev/null +++ b/sys/fmtio/chrlwr.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# CHRLWR -- Convert char to lower case + +char procedure chrlwr (ch) + +char ch + +begin + if (IS_UPPER (ch)) + return (TO_LOWER (ch)) + else + return (ch) +end diff --git a/sys/fmtio/chrupr.x b/sys/fmtio/chrupr.x new file mode 100644 index 00000000..53f6582e --- /dev/null +++ b/sys/fmtio/chrupr.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# CHRUPR -- Convert char to upper case. + +char procedure chrupr (ch) + +char ch + +begin + if (IS_LOWER (ch)) + return (TO_UPPER (ch)) + else + return (ch) +end diff --git a/sys/fmtio/clprintf.x b/sys/fmtio/clprintf.x new file mode 100644 index 00000000..d456c0a5 --- /dev/null +++ b/sys/fmtio/clprintf.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# CLPRINTF -- Format and output a string to the CL to set the value of the +# named (string or struct type) parameter. For example, to set a cursor +# struct parameter, "clprintf (param, "%8.4f %8.4f %c")" ... + +procedure clprintf (param, format_string) + +char param[ARB], format_string[ARB] + +begin + call putline (CLOUT, param) + call putline (CLOUT, " = \"") + call fprntf (CLOUT, format_string, CL_PARAM) +end diff --git a/sys/fmtio/clscan.x b/sys/fmtio/clscan.x new file mode 100644 index 00000000..563954d3 --- /dev/null +++ b/sys/fmtio/clscan.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CLSCAN -- Begin a scan of the value of a CL parameter + +int procedure clscan (param) + +char param[ARB] +int getline(), strncmp(), clc_fetch() +include "scan.com" +errchk clreqpar, getline + +begin + # Fetch the value of a CL parameter. First look in the parameter + # cache, querying the CL for the value of the parameter only if it + # is not found in the cache. + + if (clc_fetch (param, sc_scanbuf, SZ_SCANBUF) == ERR) { + call clreqpar (param) + if (getline (CLIN, sc_scanbuf) == EOF) + return (EOF) + } + + # Check for EOF on a list structured parameter; if not EOF initialize + # formatted input for the clget procedures. + + if (strncmp ("EOF\n", sc_scanbuf, 4) == 0) + return (EOF) + else { + call reset_scan() + return (OK) + } +end diff --git a/sys/fmtio/ctocc.x b/sys/fmtio/ctocc.x new file mode 100644 index 00000000..b2f4197a --- /dev/null +++ b/sys/fmtio/ctocc.x @@ -0,0 +1,64 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +define OCTAL 8 + +# CTOCC -- Convert a character into a printable character constant. +# Printable characters are output as is. The standard control characters +# (newline, tab, etc.) are output as escape sequences (\n, \t, etc.). +# Other control characters are output in the form '^X'. Characters which +# are neither printable nor standard control characters are output as +# octal constants of the form '\DDD'. Note that the ouput string is not +# enclosed in ticks ('\n', etc.), because the generated character constant +# might appear in a quoted string (or someplace other than an explicit +# character constant). + +int procedure ctocc (ch, outstr, maxch) + +char ch # character to be output +char outstr[ARB] # output string +int maxch # max chars out + +int op, n +int stridx() +define output {outstr[op]=$1;op=op+1;if(op>maxch)goto overflow_} +define overflow_ 99 +include "escchars.inc" + +begin + op = 1 + + if (maxch > 0) { + if (IS_PRINT(ch)) { # output char as is + output (ch) + } else if (IS_CNTRL (ch)) { + n = stridx (ch, mapped_chars) + if (n > 0) { # '\c' + output ('\\') + output (escape_chars[n]) + } else { + output ('^') # control chars + output (ch + 'A' - 1) + } + + } else { # '\nnn' + # Always output 3 digits so that strings like \0405 (a blank + # followed by a `5') can be interpreted during the reverse + # encoding operation. + + output ('\\') + output (TO_DIGIT (mod (ch / 0100B, 010B))) + output (TO_DIGIT (mod (ch / 0010B, 010B))) + output (TO_DIGIT (mod (ch / 0001B, 010B))) + } + } + + outstr[op] = EOS + return (op-1) + +overflow_ + outstr[1] = '?' # no room, print '?' + outstr[2] = EOS + return (1) +end diff --git a/sys/fmtio/ctod.x b/sys/fmtio/ctod.x new file mode 100644 index 00000000..06b1d351 --- /dev/null +++ b/sys/fmtio/ctod.x @@ -0,0 +1,154 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +define DECIMAL 10 + +.help +.nf _________________________________________________________________________ +Attempt to convert a string to a number: nchar = ctod (str, ip, dval) +The index IP must be set to the first character to be scanned upon entry +to CTOD, and will be left pointing at the first untranslated character. + +If the string is successfully converted, the number of characters used +is returned as the function argument. If the string (or the first few +characters of the string) cannot be interpreted as a number, zero will be +returned. Note that even if no numeric characters are encountered, the +index IP may be incremented, if leading whitespace is encountered (but the +return value N will still be zero). + +The upper case string "INDEF" is a legal real number, as is "." (. == 0.0). +Sexagesimal numbers are permitted. Excess digits of precision are ignored. +Out of range exponents are detected, and result in the value INDEF being +returned (this is not considered an ERROR condition). Any number with an +exponent greater than or equal to MAX_EXPONENT is interpreted as INDEF, +regardless of the mantissa. The number need not contain a decimal point. + +Lexical form of a sexagesimal number: + + D :== [0-9] numeric digit + E :== [eEdD] exponent symbol + + ({D}*:)+{D}*(".")?{D}*({E}("+"|"-")?{D}+)? + +The format for sexagesimal numbers is fairly permissive. Any number of +colon fields are permitted, with any number of digits (including zero) in +each field. An exponent may occur at the end of a sexagesimal number. +Leading zeros may be omitted in the fields. +.endhelp ____________________________________________________________________ + + +# CTOD -- Convert a string to double precision real. + +int procedure ctod (str, ip, dval) + +char str[ARB] # string to be converted +int ip # pointer into str +double dval # receives binary value + +bool neg +char dig[MAX_DIGITS] +int j, e, vexp, ip_start +long expon +double value, scalar +int strncmp(), gctol(), stridx() + +begin + while (IS_WHITE (str[ip])) # skip whitespace + ip = ip + 1 + ip_start = ip + dval = INDEFD + + if (strncmp (str[ip], "INDEF", 5) == 0) { # check for "INDEF" + for (ip=ip+5; IS_ALPHA (str[ip]) || str[ip] == '_'; ip=ip+1) + ; + return (ip - ip_start) + } + + neg = (str[ip] == '-') # check for sign + if (neg || str[ip] == '+') + ip = ip + 1 + + while (str[ip] == '0') # ignore leading zeros + ip = ip + 1 + + dval = 0.0 + scalar = 60.0 + + repeat { # accumulate digits + for (j=1; j <= MAX_DIGITS && IS_DIGIT(str[ip]); j=j+1) { + dig[j] = str[ip] + ip = ip + 1 + } + + for (e=0; IS_DIGIT(str[ip]); e=e+1) # ignore the rest + ip = ip + 1 + + scalar = scalar / 60.0 + if (ip > 1 && stridx(str[ip], "'\":dDhHmMsS")>0) { # sexagesimal? + ip = ip + 1 + dig[j] = EOS + value = 0.0 # convert digits + for (j=1; dig[j] != EOS; j=j+1) + value = value * 10.0D0 + TO_INTEG (dig[j]) + dval = dval + value * scalar * (10.0 ** e) + + while (str[ip] != EOS && # multiple spaces etc + stridx(str[ip]," '\":dDhHmMsS")>0) + ip = ip + 1 + } else + break + } + + if (str[ip] == '.') { # check for a fraction + ip = ip + 1 + if (j == 1) # skip leading zeros + while (str[ip] == '0') { # if str = "0.00ddd" + ip = ip + 1 + e = e - 1 + } + for (; j <= MAX_DIGITS && IS_DIGIT(str[ip]); j=j+1) { + dig[j] = str[ip] + e = e - 1 # adjust scale factor + ip = ip + 1 + } # discard insignificant + while (IS_DIGIT (str[ip])) # fractional digits + ip = ip + 1 + } + + dig[j] = EOS # no more digits + vexp = e + j - 1 # save for ovfl check + if (ip == ip_start) # not a number? + return (0) + + value = 0.0 # convert the mantissa + for (j=1; dig[j] != EOS; j=j+1) + value = value * 10.0D0 + TO_INTEG (dig[j]) + if (e != 0) + value = value * (10.0D0 ** e) # scale by e + + + # Check for exponent. + + j = ip + expon = 0 + if (stridx (str[ip], "eEdD") > 0) { # exponent? + ip = ip + 1 + if (gctol (str, ip, expon, DECIMAL) <= 0) { + ip = j # return chars + expon = 0 + } + } + + if (abs(vexp+expon) > MAX_EXPONENTD) # check for overflow + return (ip - ip_start) + + dval = dval + value * scalar + if (expon != 0) + dval = dval * (10.0D0 ** expon) # apply exponent + + if (neg) + dval = -dval + return (ip - ip_start) +end diff --git a/sys/fmtio/ctoi.x b/sys/fmtio/ctoi.x new file mode 100644 index 00000000..ce791222 --- /dev/null +++ b/sys/fmtio/ctoi.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# CTOI -- Simple character to integer (decimal radix). + +int procedure ctoi (str, ip, ival) + +char str[ARB] # decimal encoded numeric string +int ip # starting index in string (input/output) +int ival # decoded integer value (output) + +bool neg +int sum +int ip_start +int strncmp() + +begin + while (IS_WHITE (str[ip])) + ip = ip + 1 + ip_start = ip + + # Check for "INDEF". + if (str[ip] == 'I') + if (strncmp (str[ip], "INDEF", 5) == 0) + if (!IS_ALNUM (str[ip+5])) { + ival = INDEFI + ip = ip + 5 + return (5) + } + + neg = (str[ip] == '-') + if (neg) + ip = ip + 1 + + sum = 0 + while (IS_DIGIT (str[ip])) { + sum = sum * 10 + TO_INTEG (str[ip]) + ip = ip + 1 + } + + if (neg) + ival = -sum + else + ival = sum + + return (ip - ip_start) +end diff --git a/sys/fmtio/ctol.x b/sys/fmtio/ctol.x new file mode 100644 index 00000000..a83d1384 --- /dev/null +++ b/sys/fmtio/ctol.x @@ -0,0 +1,52 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# CTOL -- Simple character to long integer (decimal radix). + +int procedure ctol (str, ip, lval) + +char str[ARB] # decimal encoded numeric string +int ip # starting index in string (input/output) +long lval # decoded integer value (output) + +bool neg +long sum +int ip_start +int strncmp() + +begin + while (IS_WHITE (str[ip])) + ip = ip + 1 + ip_start = ip + + # Check for "INDEF". + if (str[ip] == 'I') + if (strncmp (str[ip], "INDEF", 5) == 0) + if (!IS_ALNUM (str[ip+5])) { + lval = INDEFL + ip = ip + 5 + return (5) + } + + neg = false + if (IS_DIGIT (str[ip+1])) + if (str[ip] == '-') { + neg = true + ip = ip + 1 + } else if (str[ip] == '+') + ip = ip + 1 + + sum = 0 + while (IS_DIGIT (str[ip])) { + sum = sum * 10 + TO_INTEG (str[ip]) + ip = ip + 1 + } + + if (neg) + lval = -sum + else + lval = sum + + return (ip - ip_start) +end diff --git a/sys/fmtio/ctor.x b/sys/fmtio/ctor.x new file mode 100644 index 00000000..a8fd16f1 --- /dev/null +++ b/sys/fmtio/ctor.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# CTOR -- Character to real. The number of characters converted to produce +# the output number is returned as the function value (0 is returned if the +# input cannot be interpreted as a number). + +int procedure ctor (str, ip, rval) + +char str[ARB] # input string to be decoded +int ip # first character to be used in string +real rval # decoded real value (output) + +double dval +int nchars, expon +int ctod() + +begin + nchars = ctod (str, ip, dval) + if (abs(dval) > EPSILOND) + expon = int (log10 (abs(dval))) + else + expon = 0 + + if (IS_INDEFD(dval)) + rval = INDEFR + else if (expon > MAX_EXPONENTR) + return (0) + else + rval = dval + + return (nchars) +end diff --git a/sys/fmtio/ctotok.x b/sys/fmtio/ctotok.x new file mode 100644 index 00000000..333984c9 --- /dev/null +++ b/sys/fmtio/ctotok.x @@ -0,0 +1,167 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +.help CTOTOK 2 "String Utilities" +.ih ___________________________________________________________________________ +NAME +CTOTOK -- Return next token from input text. +.ih +USAGE +token = ctotok (string, ip, outstr, maxch) +.ih +PARAMETERS +The integer value returned by CTOTOK is a code identifying the type of token +matched. The predefined tokens recognized by CTOTOK (defined in ) +are the following: +.ls +.nf +TOK_IDENTIFER [a-zA-Z][a-zA-Z0-9_$.]* +TOK_NUMBER [0-9][-+0-9.:xXa-fA-F]* +TOK_OPERATOR [-+*/!@#$%^&=`~<>?|]+ +TOK_PUNCTUATION [,:;(){}] or "[", "]" +TOK_STRING "..." +TOK_CHARCON '.' +TOK_EOS end of string +TOK_NEWLINE end of line +TOK_UNKNOWN control characters +.fi +.le +.ls string +The EOS delimited character string from which the next token is to be +extracted. +.le +.ls ip +On input, contains the index of the first character to be scanned +(initially 1). On output, left pointing at the first character after +the current token, unless EOS was reached. IP should normally be left +alone in successive calls to CTOTOK. +.le +.ls outstr +String to receive the extracted token value. +.le +.ls maxch +Capacity of the "outstr" buffer. +.le +.ih +DESCRIPTION +CTOTOK is useful for many simple parsing tasks. For example, it is used +by the HELP utility to parse the ".help" directive, which consists of +a list of keywords (delimited by commas), followed by two strings or +identifiers. + +CTOTOK selects the type of token to be extracted based on the token +class membership of the first nonwhitespace character encountered. +Characters are copied to the output string until a character not belonging +to the current class is encountered (or until MAXCH characters have been +output). Whitespace is always a token delimiter. The integer code for the +corresponding token is returned as the function value. + +An identifier is a letter followed by any number of letters, digits, or +one of the characters [_.$]. A number is any legal integer, octal, +hexadecimal, sexagesimal, or floating point number. All legal numbers are +matched: however, many illegal numbers (e.g. "99.33.22") are matched as well. +The numeric conversion routines may be used to verify that a number token +is actually a legal number, as well as to convert the number to binary. + +An operator is one or more operator characters, or any of the characters +[_.$], not occurring as part of an identifier, but occurring instead as the +first character of an operator. Note that a string of operator characters +is considered a single token, whereas punctuation characters are returned +as separate tokens. Strings are enclosed by either single or double quotes, +and all escape sequences are recognized and processed. +Control characters and DEL match the "unknown" token. +.ih +SEE ALSO +tokens(1), strmatch(), patmatch() +.endhelp ______________________________________________________________________ + +define TABLESIZE 95 +define NUMCHSIZE 6 +define OFFSET ' ' + + +# CTOTOK -- Character string to token. The token is returned in OUTSTR and the +# token type code is returned as the function value. + +int procedure ctotok (str, ip, outstr, maxch) + +char str[ARB] # input string +int ip # pointer into input string +char outstr[ARB] # buffer to receive token +int maxch # max chars in output buffer + +int currclass +char class[TABLESIZE] +int op, ch, i, junk, nchars +int ctowrd(), lexnum(), cctoc() +include "tokdata.inc" + +begin + while (IS_WHITE (str[ip])) + ip = ip + 1 + + ch = str[ip] + i = max(1, min(TABLESIZE, ch - OFFSET)) + op = 1 + + if (ch == EOS) { # select class (token) + outstr[1] = EOS + return (TOK_EOS) + + } else if (ch == NEWLINE) { # end of line + outstr[1] = ch + outstr[2] = EOS + ip = ip + 1 + return (TOK_NEWLINE) + + } else if (ch <= OFFSET) { # control characters + while (op <= maxch && ch != EOS && ch <= OFFSET) { + outstr[op] = ch + op = op + 1 + ip = ip + 1 + ch = str[ip] + } + outstr[op] = EOS + return (TOK_UNKNOWN) + + } else if (ch == DQUOTE) { # string constant + junk = ctowrd (str, ip, outstr, maxch) + return (TOK_STRING) + + } else if (ch == SQUOTE || ch == ESCAPE) { + nchars = cctoc (str, ip, junk) + call strcpy (str[ip-nchars], outstr, nchars) + return (TOK_CHARCON) + + } else if (lexnum (str, ip, nchars) != LEX_NONNUM) { + call strcpy (str[ip], outstr, nchars) + ip = ip + nchars + return (TOK_NUMBER) + + } else if (class[i] == TOK_IDENTIFIER && !IS_ALPHA (ch)) { + currclass = TOK_OPERATOR + + } else if (class[i] == TOK_PUNCTUATION) { # only one at a time + outstr[1] = ch + outstr[2] = EOS + ip = ip + 1 + return (TOK_PUNCTUATION) + + } else + currclass = class[i] + + repeat { # copy token to output + outstr[op] = ch + op = op + 1 + ip = ip + 1 + ch = str[ip] + i = max(1, min(TABLESIZE, ch - OFFSET)) + } until (ch == EOS || ch <= OFFSET || class[i] != currclass) + + outstr[op] = EOS + return (currclass) +end diff --git a/sys/fmtio/ctowrd.x b/sys/fmtio/ctowrd.x new file mode 100644 index 00000000..5f511075 --- /dev/null +++ b/sys/fmtio/ctowrd.x @@ -0,0 +1,83 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# CTOWRD -- Break whitespace delimited token or quoted string out of input +# stream. If string, process escape sequences. The number of characters +# converted from the input string, excluding whitespace, is returned as the +# function value. + +int procedure ctowrd (str, ip, outstr, maxch) + +char str[ARB] # input string +int ip # pointer into input string +char outstr[ARB] # receives extracted word +int maxch + +char cch +int ch, junk, op +int ip_start, delim, i +define qsput_ 91 +define wsput_ 92 +int cctoc() + +begin + while (IS_WHITE(str[ip])) + ip = ip + 1 + ip_start = ip + + delim = str[ip] + if (delim == DQUOTE || delim == SQUOTE) { + # Extract a quoted string. + op = 1 + ip = ip + 1 + do i = 1, ARB { + ch = str[ip] + if (ch == EOS) { + break + } else if (ch == ESCAPE) { + ch = str[ip+1] + if (ch == delim) { + ip = ip + 2 + goto qsput_ + } else { + junk = cctoc (str, ip, cch) + ch = cch + goto qsput_ + } + } else if (ch == delim) { + ip = ip + 1 + break + } else { + ip = ip + 1 +qsput_ if (op <= maxch) { + outstr[op] = ch + op = op + 1 + } + } + } + } else { + # Extract a whitespace delimited string. + op = 1 + do i = 1, ARB { + ch = str[ip] + if (IS_WHITE(ch) || ch == '\n' || ch == EOS) { + break + } else if (ch == ESCAPE) { + junk = cctoc (str, ip, cch) + ch = cch + goto wsput_ + } else { + ip = ip + 1 +wsput_ if (op <= maxch) { + outstr[op] = ch + op = op + 1 + } + } + } + } + + outstr[op] = EOS + return (ip - ip_start) +end diff --git a/sys/fmtio/ctox.x b/sys/fmtio/ctox.x new file mode 100644 index 00000000..3f0479a2 --- /dev/null +++ b/sys/fmtio/ctox.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# CTOX -- Convert a character string into a complex number. The complex +# number must have the form (r,i), with no embedded whitespace (GCTOX is +# cabable of accepting numbers in other formats). + +int procedure ctox (str, ip, xval) + +char str[ARB] +int ip, ip_save +double dval1, dval2 +complex xval +int ctod() +define notanumber_ 99 + +begin + while (IS_WHITE (str[ip])) + ip = ip + 1 + ip_save = ip + dval2 = 0.0d0 + + if (str[ip] == '(') { # x = (r1,r2) + ip = ip + 1 + if (ctod (str, ip, dval1) <= 0) + goto notanumber_ + if (str[ip] != ',') + goto notanumber_ + ip = ip + 1 + if (ctod (str, ip, dval2) <= 0) + goto notanumber_ + if (str[ip] != ')') + goto notanumber_ + ip = ip + 1 + } else + goto notanumber_ + + if (IS_INDEFD(dval1) || IS_INDEFD(dval2)) + xval = INDEFX + else + xval = complex (dval1, dval2) + return (ip - ip_save) + +notanumber_ + ip = ip_save + return (0) +end diff --git a/sys/fmtio/doc/evexpr.hlp b/sys/fmtio/doc/evexpr.hlp new file mode 100644 index 00000000..386baf91 --- /dev/null +++ b/sys/fmtio/doc/evexpr.hlp @@ -0,0 +1,147 @@ + EVEXPR + Evaluating Algebraic Expressions in SPP Programs + dct 17 April 1985 + + + +1. Introduction + + EVEXPR is a function which takes an algebraic expression as input, +evaluates the expression, and returns the value of the expression as the +function value. The input expression (a character string) is parsed and +reduced to a single value. The operands to the expression may be either +constants or identifiers (foreign strings). If an identifier is encountered +the user supplied get operand procedure is called to return the value of +the operand. Operands are described by the operand structure, and operands +are passed about by a pointer to such a structure. The value of the +expression is returned as the function value and is a pointer to an operand +structure. Operands of different datatypes may be mixed in an expression +with the usual automatic type coercion rules. All SPP datatypes are +supported plus the string datatype. All SPP operators and intrinsic +functions are recognized. + + +2. Procedures + + op = evexpr (expr, locpr(getop), locpr(ufcn)) + getop (identifier, op) + ufcn (fcn, args, nargs, op) + +where + + evexpr The main entry point. + expr A character string, the expression to be evaluated. + getop A user supplied procedure which returns the value + of a nonconstant operand given the NAME of the operand + (a character string) as input. If locpr(getop) is + NULL only constant operands are permitted in the + expression. + ufcn A user supplied procedure which returns the value of + a user defined function given the name of the function + as the first argument (a string). If locpr(ufcn) is + NULL only the standard functions are permitted. + fcn Name of the function to be evaluated. + args Array of pointers to operands (the arguments to the function). + nargs Number of arguments to function. + op A pointer to an operand structure + + +A a simple example, consider the following statement which evaluates a +constant expression and prints the value on the standard output. + + + include + pointer o, evexpr() + + o = evexpr ("sin(.5)**2 + cos(.5)**2)", NULL, NULL) + switch (O_TYPE(o)) { + case TY_INT: + call printf ("result = %d\n") + call pargi (O_VALI(o)) + case TY_REAL: + call printf ("result = %g\n") + call pargr (O_VALR(o)) + case TY_CHAR: + call printf ("result = %s\n") + call pargstr (O_VALC(o)) + } + + +If a syntax error occurs while parsing the expression EVEXPR will take the +error action "syntax error". The NULL arguments could be replaced by the +LOCPR addresses of get operand and/or user function procedures if required +by the application. + + +3. Lexical Form + + The lexical form of the input expression is the same as that of SPP and +the CL for all numeric, character, and string constants and operators. +Any other sequence of characters is considered an identifier and will be +passed to the user supplied get operand function to be turned into an operand. + + +4. Syntax + + Parsing and evaluating of the input expression is carried out by an SPP/Yacc +parser. The grammar recognized by the parser is given below. + + +expr : CONST # numeric or string constant + | IDENT # external operand (getop) + | '-' expr %prec UMINUS + | expr '+' expr + | expr '-' expr + | expr '*' expr + | expr '/' expr + | expr '**' expr + | expr '//' expr + | '!' expr + | expr '<' expr + | expr '<=' expr + | expr '>' expr + | expr '>=' expr + | expr '==' expr + | expr '!=' expr + | expr '&&' expr + | expr '||' expr + | IDENT '(' arglist ')' # function call + | '?' expr ':' expr # conditional expression + | '(' expr ')' + ; + +arglist : # Empty. + | arglist ',' expr + ; + + +2. Data Structures + + The operand structure (size 3 su) is used to represent all operands in +expressions and on the parser stack. Operands are passed to and from the +outside world by means of a pointer to an operand structure. The caller +is responsible for string storage of string operands passed to EVEXPR. +EVEXPR manages string storage for temporary string operands created during +expression evaluation, as well as storage for the final string value if +the expression is string valued. In the latter case the value string should +be used before EVEXPR is again called. + + + struct operand { + int type # operand datatype + union { + bool v_b # boolean value + int v_i # integer value + real v_r # real value + char *v_s # string value + } v + } + + +SPP equivalent () + + O_TYPE(o) # operand datatype + O_VALB(o) # boolean value + O_VALI(o) # integer value (or string ptr) + O_VALR(o) # real value + O_VALC(o) # string value diff --git a/sys/fmtio/doc/fmtio.hd b/sys/fmtio/doc/fmtio.hd new file mode 100644 index 00000000..525911dc --- /dev/null +++ b/sys/fmtio/doc/fmtio.hd @@ -0,0 +1,77 @@ +# Help directory for the FMTIO (formatted i/o) package. + +$fmtio = "sys$fmtio/" + +cctoc hlp = xtoc.hlp, src = fmtio$cctoc.x +chdeposit hlp = chdeposit.hlp, src = fmtio$chdeposit.x +chfetch hlp = chfetch.hlp, src = fmtio$chfetch.x +chrlwr hlp = chrlwr.hlp, src = fmtio$chrlwr.x +chrupr hlp = chrupr.hlp, src = fmtio$chrupr.x +clprintf hlp = printf.hlp, src = fmtio$clprintf.x +clscan hlp = scan.hlp, src = fmtio$clscan.x +ctocc hlp = ctox.hlp, src = fmtio$ctocc.x +ctod hlp = ctox.hlp, src = fmtio$ctod.x +ctoi hlp = ctox.hlp, src = fmtio$ctoi.x +ctol hlp = ctox.hlp, src = fmtio$ctol.x +ctor hlp = ctox.hlp, src = fmtio$ctor.x +ctotok hlp = ctox.hlp, src = fmtio$ctotok.x +ctowrd hlp = ctox.hlp, src = fmtio$ctowrd.x +ctox hlp = ctox.hlp, src = fmtio$ctox.x +dtoc hlp = xtoc.hlp, src = fmtio$dtoc.x +eprintf hlp = printf.hlp, src = fmtio$eprintf.x +fprintf hlp = printf.hlp, src = fmtio$fprintf.x +fscan hlp = scan.hlp, src = fmtio$fscan.x +gargb hlp = garg.hlp, src = fmtio$gargb.x +gargc hlp = garg.hlp, src = fmtio$gargc.x +gargd hlp = garg.hlp, src = fmtio$gargd.x +gargi hlp = garg.hlp, src = fmtio$gargi.x +gargl hlp = garg.hlp, src = fmtio$gargl.x +gargr hlp = garg.hlp, src = fmtio$gargr.x +gargrad hlp = garg.hlp, src = fmtio$gargrad.x +gargs hlp = garg.hlp, src = fmtio$gargs.x +gargstr hlp = garg.hlp, src = fmtio$gargstr.x +gargtok hlp = garg.hlp, src = fmtio$gargtok.x +gargwrd hlp = garg.hlp, src = fmtio$gargwrd.x +gargx hlp = garg.hlp, src = fmtio$gargx.x +gctod hlp = ctox.hlp, src = fmtio$gctod.x +gctol hlp = ctox.hlp, src = fmtio$gctol.x +gltoc hlp = xtoc.hlp, src = fmtio$gltoc.x +gstrcat hlp = gstrcat.hlp, src = fmtio$gstrcat.x +gstrcpy hlp = gstrcpy.hlp, src = fmtio$gstrcpy.x +itoc hlp = xtoc.hlp, src = fmtio$itoc.x +lexnum hlp = lexnum.hlp, src = fmtio$lexnum.x +ltoc hlp = xtoc.hlp, src = fmtio$ltoc.x +nscan hlp = scan.hlp, src = fmtio$nscan.x +pargb hlp = parg.hlp, src = fmtio$pargb.x +pargc hlp = parg.hlp, src = fmtio$parg.x +pargs hlp = parg.hlp, src = fmtio$parg.x +pargi hlp = parg.hlp, src = fmtio$parg.x +pargl hlp = parg.hlp, src = fmtio$parg.x +pargr hlp = parg.hlp, src = fmtio$parg.x +pargd hlp = parg.hlp, src = fmtio$parg.x +pargx hlp = parg.hlp, src = fmtio$parg.x +pargstr hlp = parg.hlp, src = fmtio$pargstr.x +patmatch hlp = patmatch.hlp, src = fmtio$patmatch.x +printf hlp = printf.hlp, src = fmtio$printf.x +scanc hlp = scan.hlp, src = fmtio$scanc.x +sprintf hlp = printf.hlp, src = fmtio$sprintf.x +sscan hlp = scan.hlp, src = fmtio$sscan.x +strcat hlp = strcat.hlp, src = fmtio$strcat.x +strcpy hlp = strcpy.hlp, src = fmtio$strcpy.x +strdic hlp = strdic.hlp, src = fmtio$strdic.x +streq hlp = streq.hlp, src = fmtio$streq.x +strge hlp = strge.hlp, src = fmtio$strge.x +strgt hlp = strgt.hlp, src = fmtio$strgt.x +stridx hlp = stridx.hlp, src = fmtio$stridx.x +strldx hlp = strldx.hlp, src = fmtio$strldx.x +strle hlp = strle.hlp, src = fmtio$strle.x +strlen hlp = strlen.hlp, src = fmtio$strlen.x +strlt hlp = strlt.hlp, src = fmtio$strlt.x +strlwr hlp = strlwr.hlp, src = fmtio$strlwr.x +strmatch hlp = strmatch.hlp, src = fmtio$strmatch.x +strncmp hlp = strncmp.hlp, src = fmtio$strncmp.x +strne hlp = strne.hlp, src = fmtio$strne.x +strsearch hlp = strsearch.hlp, src = fmtio$strsearch.x +strtbl hlp = strtbl.hlp, src = fmtio$strtbl.x +strupr hlp = strupr.hlp, src = fmtio$strupr.x +xtoc hlp = xtoc.hlp, src = fmtio$xtoc.x diff --git a/sys/fmtio/doc/fmtio.men b/sys/fmtio/doc/fmtio.men new file mode 100644 index 00000000..897a8139 --- /dev/null +++ b/sys/fmtio/doc/fmtio.men @@ -0,0 +1,59 @@ + cctoc - Character constant to char + chdeposit - Deposit a character in a string with overflow protection + chfetch - Fetch a character from a string + chrlwr - Convert a character to lower case + chrupr - Convert a character to upper case + clprintf - Formatted print to a CL parameter + clscan - Scan a CL parameter + ctocc - Char to character constant + ctod - Character to double + ctoi - Character to integer + ctol - Character to long + ctor - Character to real + ctox - Character to complex + ctotok - Character to lexical token + ctowrd - Character to whitespace delimited word + dtoc - Double to character + eprintf - Formatted print to STDERR + fprintf - Formatted print to any file + fscan - Scan a file + garg[bcsilrdx] - Get scan argument + gargrad - Get scan argument in any numerical radix + gargstr - Get scan argument of type string + gargtok - Get scan argument of type token + gargwrd - Get scan argument of type word + gctod - General character to double + gctol - General character to long (any radix) + gltoc - General long to character (any radix) + gstrcat - String concatenation returning length of output string + gstrcpy - String copy returning length of output string + itoc - Integer to character + lexnum - Lexically analyze a string to determine if it is a number + ltoc - Long to character + nscan - Get number of arguments successfully converted in last scan + parg[bcsilrdx] - Pass an argument to a printf + pargstr - Pass a string type argument to a printf + patmatch - General pattern matching + printf - Formatted print to STDOUT + scanc - Get the next character from a scan + sprintf - Formatted print to a string buffer + sscan - Scan a string buffer + strcat - String concatenation + strcpy - String copy + strdic - Look a string up in a dictionary + streq - Compare strings for equality + strge - Is string A greater than or equal to string B + strgt - Is string A greater than string B + stridx - First occurrence of a character in a string + strldx - Last occurrence of a character in a string + strle - Is string A less than or equal to string B + strlen - Length of a string + strlt - Is string A less than string B + strlwr - Convert string to lower case + strmatch - Search a string for a pattern + strncmp - Compare the first N characters of two strings + strne - Is string A not equal to string B + strsearch - Fast string search, no metacharacters + strtbl - Print a list of strings in a table + strupr - Convert a string to upper case + xtoc - Complex to character diff --git a/sys/fmtio/doc/lexnum.hlp b/sys/fmtio/doc/lexnum.hlp new file mode 100644 index 00000000..647654b1 --- /dev/null +++ b/sys/fmtio/doc/lexnum.hlp @@ -0,0 +1,303 @@ + +.help lexnum 2 "string utilities" +.ih _________________________________________________________________________ +NAME +lexnum -- Determine if string is a number +.ih +USAGE +token_type = lexnum (str, ip, nchars) + +.ih +PARAMETERS +.ls str +String to be scanned. +.le +.ls ip +Index within the string as which scanning is to start. Not modified. +.le +.ls nchars +On output, the number of characters in the number, not including any +leading whitespace. +.le +.ih +DESCRIPTION +The character string is scanned to determine if the next token is a +legal number, and if so, the type of number. The function value identifies +the type of number. The possible return values, defined in , +as as follows: + +.nf + LEX_OCTAL (+|-)?[0-7]+[bB] + LEX_DECIMAL (+|-)?[0-9]+ + LEX_HEX (+|-)?[0-9a-fA-F]+[xX] + LEX_REAL floating, exponential [eEdD], sexagesimal + LEX_NONNUM not a number +.fi +.ih +IMPLEMENTATION +Numtype is implemented as a finite state automaton. Additional documentation +is provided with the source code. +.ih +SEE ALSO +gctod(2), ctotok(2). +.endhelp ___________________________________________________________________ + + + +.help states 2 "States of the LEXNUM Finite State Automaton" +.fi + + +.ks +.nf +start: (1) + +- shift unop_or_number + 0-7 shift odhr + 8-9 shift dhr + acf reduce not_a_number + ed reduce not_a_number + : shift maybe_real_number + . shift maybe_real_fraction + x reduce not_a_number + b reduce not_a_number + other reduce not_a_number +.fi +.ke + + +.ks +.nf +unop_or_number: (+|-) (2) + +- revert + 0-7 shift odhr + 8-9 shift dhr + acf revert + ed revert + : revert + . shift maybe_real_fraction + x revert + b revert + other revert +.fi +.ke + + +.ks +.nf +odhr: (+|-)?[0-7] (3) + +- reduce decimal_number + 0-7 accept + 8-9 shift dhr + acf shift h + ed shift maybe_hex_or_rexp + : shift maybe_real_number + . shift real_fraction + x reduce hex_number + b shift octal_or_hex_number + other reduce decimal_number +.fi +.ke + + +.ks +.nf +dhr: (+|-)?[0-9]+ (4) + +- reduce decimal_number + 0-7 accept + 8-9 accept + acf shift h + ed shift maybe_hex_or_rexp + : shift maybe_real_number + . shift real_fraction + x reduce hex_number + b shift h + other reduce decimal_number +.fi +.ke + + +.ks +.nf +maybe_real_fraction: (+|-)?"." (5) + +- revert + 0-7 shift real_fraction + 8-9 shift real_fraction + acf revert + ed revert + : revert + . revert + x revert + b revert + other revert +.fi +.ke + + +.ks +.nf +h: (+|-)?[0-9]*[a-f] (6) + +- revert + 0-7 accept + 8-9 accept + acf accept + ed accept + : revert + . revert + x reduce hex_number + b accept + other revert +.fi +.ke + + +.ks +.nf +maybe_hex_or_rexp: (+|-)?[0-9]+[ed] (7) + +- shift maybe_rexp + 0-7 shift hex_or_rexp + 8-9 shift hex_or_rexp + acf shift h + ed shift h + : revert + . revert + x reduce hex_number + b shift h + other revert +.fi +.ke + + +.ks +.nf +maybe_real_number: (+|-)?[0-9]*":" (8) + +- revert + 0-7 shift r + 8-9 shift r + acf revert + ed revert + : accept + . revert + x revert + b revert + other revert +.fi +.ke + + +.ks +.nf +octal_or_hex_number: (+|-)?[0-7]"b" (9) + +- reduce octal_number + 0-7 shift h + 8-9 shift h + acf shift h + ed shift h + : reduce octal_number + . reduce octal_number + x reduce hex_number + b shift h + other reduce octal_number +.fi +.ke + + +.ks +.nf +real_fraction: (+|-)?"."[0-9] (10) + +- reduce real_number + 0-7 accept + 8-9 accept + acf reduce real_number + ed shift rfr_or_rexp + : reduce real_number + . reduce real_number + x reduce real_number + b reduce real_number + other reduce real_number +.fi +.ke + + +.ks +.nf +rfr_or_rexp: (+|-)?"."[0-9]+[ed] (11) + +- shift maybe_rexp + 0-7 shift rexp + 8-9 shift rexp + acf revert + ed revert + : revert + . revert + x revert + b revert + other revert +.fi +.ke + + +.ks +.nf +maybe_rexp: (+|-)?[0-9]+[ed](+|-) (12) + +- revert + 0-7 shift rexp + 8-9 shift rexp + acf revert + ed revert + : revert + . revert + x revert + b revert + other revert +.fi +.ke + + +.ks +.nf +hex_or_rexp: (+|-)?[0-9]+[ed][0-9] (13) + +- reduce real_number + 0-7 accept + 8-9 accept + acf shift h + ed shift h + : reduce real_number + . reduce real_number + x reduce hex_number + b reduce real_number + other reduce real_number +.fi +.ke + + +.ks +.nf +r: (+|-)?[0-9]*":"[0-9] (14) + +- reduce real_number + 0-7 accept + 8-9 accept + acf reduce real_number + ed shift maybe_rexp + : accept + . shift maybe_real_fraction + x reduce real_number + b reduce real_number + other reduce real_number +.fi +.ke + + +.ks +.nf +rexp: (+|-)?[0-9]+[ed](+|-)[0-9] (15) + +- reduce real_number + 0-7 accept + 8-9 accept + acf reduce real_number + ed reduce real_number + : reduce real_number + . reduce real_number + x reduce real_number + b reduce real_number + other reduce real_number +.fi +.ke diff --git a/sys/fmtio/dtcscl.x b/sys/fmtio/dtcscl.x new file mode 100644 index 00000000..afd6adc5 --- /dev/null +++ b/sys/fmtio/dtcscl.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# DTCSCL -- Scales a double precision real, maintaining maximum precision. +# Called by DTOC and CTOD. + +procedure dtcscl (v, e, sense) + +double v # value to be scaled +int e # exponent +int sense # sense of scaling (0=apply e to v; 1=calc e) + +begin + if (sense == 0) # scale v by 10 ** e + v = v * (10.0d0 ** e) + + else { # scale number to 0.1 <= v < 1.0 + if (v == 0.0d0) + e = 0 + else { + e = -1 + while (v < 0.1d0) { + v = v * 10.0d0 + e = e - 1 + if (v == 0.0d0) { # check for underflow to zero + e = 0 + break + } + } + while (v >= 1.0d0) { + v = v / 10.0d0 + e = e + 1 + } + } + } +end diff --git a/sys/fmtio/dtoc.x b/sys/fmtio/dtoc.x new file mode 100644 index 00000000..6bf7571e --- /dev/null +++ b/sys/fmtio/dtoc.x @@ -0,0 +1,129 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# DTOC -- Format and output a floating point number, in any of the formats +# F,E,G,H, or M (H and M are hours-minutes-seconds and minutes-seconds formats, +# respectively). + +int procedure dtoc (dval, outstr, maxch, decpl, a_fmt, width) + +double dval # number to be output +char outstr[ARB] # output string +int maxch # size of the output string +int decpl # number of decimal places or precision +int a_fmt, fmt # format type (feghm) +int width # field width + +bool neg +double val +int op, round, h, m, s, f, v, i +int dtoc3(), ltoc() + +define output {outstr[op]=$1;op=op+1;if(op>maxch)goto retry_} +define retry_ 91 + +begin + # If HMS format is not desired, simply call DTOC3. Control also + # returns to this point in the event of overflow. + + fmt = a_fmt + if (IS_UPPER (fmt)) + fmt = TO_LOWER (fmt) + + if (fmt == FMT_FIXED || fmt == FMT_EXPON || fmt == FMT_GENERAL || + IS_INDEFD(dval)) { +retry_ + return (dtoc3 (dval, outstr, maxch, decpl, fmt, width)) + } + + # HMS format is implemented using calls to DTOC3, LTOC. Use zero + # fill to get two chars for the second and third fields, if necessary. + # The second field is omitted for "m" format. No whitespace is + # permitted in an HMS (or other) number. If the format is %H or %M + # (instead of the usual %h or %m) scale the number by 15 before output + # (converting degrees to hours). + + if (IS_UPPER (a_fmt)) + val = dval / 15.0 + else + val = dval + + # Working with a positive number simplifies things. + neg = (val < 0.0) + if (neg) + val = -val + + # Decompose number into HMS or MS. + h = 0 + if (fmt == FMT_HMS) { + h = int(val); val = (val - h) * 60.0 + } + m = int(val); val = (val - m) * 60.0 + s = int(val); val = (val - s) + + # Round the fractional seconds field and carry if the rounded value + # is greater than 60. This has to be done explicitly due to the + # "base 60" sexagesimal arithmetic. + + round = (10.0 ** decpl) + f = int (val * round + 0.5) + while (f >= round) { + f = f - round + s = s + 1 + } + while (s >= 60) { + s = s - 60 + m = m + 1 + } + while (m >= 60) { + m = m - 60 + h = h + 1 + } + + # Format the output string. + op = 1 + if (neg) + output ('-') + + # Output the first field, which is the hours field for HMS format, + # or the minutes field for MS format. + + if (fmt == FMT_HMS) + v = h + else + v = h * 60 + m + op = op + ltoc (v, outstr[op], maxch-op+1) + output (':') + + # Output the minutes field in HMS format. + if (fmt == FMT_HMS) { + output (TO_DIGIT (m / 10)) + output (TO_DIGIT (mod (m, 10))) + output (':') + } + + # Output the seconds field. + output (TO_DIGIT (s / 10)) + output (TO_DIGIT (mod (s, 10))) + + # Output the fraction, if any. + if (decpl > 0) { + output ('.') + do i = 1, decpl { + round = round / 10 + output (TO_DIGIT (f / round)) + f = mod (f, round) + } + } + + # If the HMS format does not fit, go try a more compact format. + if (op-1 > abs(width) || op > maxch) { + fmt = FMT_GENERAL + goto retry_ + } + + outstr[op] = EOS + return (op-1) +end diff --git a/sys/fmtio/dtoc3.x b/sys/fmtio/dtoc3.x new file mode 100644 index 00000000..76101dd1 --- /dev/null +++ b/sys/fmtio/dtoc3.x @@ -0,0 +1,285 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +.help dtoc3 +.nf ___________________________________________________________________________ +This routine is based on the TOOLS routine of the same name by J. Chong. +The major changes are translation to the IRAF pp language, implementation +of the "G" format, and some restructuring to avoid duplicated code. +This procedure is called by the more general routine DTOC, which adds the +additional format type "H" (sexageximal, or hms format). + +Formats: f Fixed format. D == number of decimal places. If D + is -1 (or less), the "." will not be printed. If the + number being printed is too large to fit in F format, + "E" format will be used instead. Nonsignificant + digits are returned as zeros. + + e Exponential format. D == number of significant digits. + + g General format. D == number of significant digits. + The actual format used may be either F or E, depending + on which is smaller. If D is negative, the "." will + be omitted if possible (abs(D) remains the precision). + +If the field width is too small to convert the number, the field will be +filled with asterisks instead. If the number being converted is INDEF, the +string "INDEF" will be returned. The number is rounded to the desired precision +before being printed. +.endhelp ______________________________________________________________________ + +# DTOC3 --- Convert double precision real to string. + +int procedure dtoc3 (val, out, maxch, decpl, a_fmt, width) + +double val # value to be encoded +char out[ARB] # output string +int maxch # max chars out +int decpl # precision +int a_fmt # type of encoding ('f', 'e', etc.) +int width # field width + +double v +char digits[MAX_DIGITS] +bool neg, small, exp_format, squeeze +int i, w, d, e, j, len, no_digits, max_size, e_size, f_size, fmt +int itoc(), gstrcpy() + +begin + # Set flags indicating whether the number is greater or less that zero, + # and whether its absolute value is greater or less than 1. + + v = abs (val) + w = abs (width) + + fmt = a_fmt + if (IS_UPPER(a_fmt)) + fmt = TO_LOWER(a_fmt) + squeeze = (fmt == FMT_GENERAL) + neg = (val < 0.0) + small = (v < 0.1) + + if (squeeze) + d = abs (decpl) + else + d = max (0, decpl) + + if (IS_INDEFD (val)) # INDEF is a special case + return (gstrcpy ("INDEF", out, w)) + + # Scale number to 0.1 <= v < 1.0 + call dtcscl (v, e, 1) + + # Start tally for the maximum size of the number to determine if an + # error should be returned. + if (neg) # 1 for neg, plus 1 for . + max_size = 2 + else + max_size = 1 + no_digits = min (MAX_DIGITS, d) + + + # Determine exact format for printing. + + len = abs (e) # base size of E format + e_size = 1 + for (i=10; i <= 10000; i=i*10) { + if (len < i) + break + e_size = e_size + 1 + } + e_size = e_size + max_size + 1 + if (e < 0) + e_size = e_size + 1 # allow space for leading '0' + + if (squeeze) { # G-format: find best format + e_size = e_size + d + if (e > 0) + f_size = max (d, e + 1) + else + f_size = d - e + f_size = f_size + max_size + } else if (fmt == FMT_FIXED) + f_size = max (e, 1) + max_size + d + + + if (squeeze) { # 'G' format + if (f_size <= e_size) { + exp_format = false + if (e > 0) + no_digits = f_size - max_size + max_size = f_size + } else { + exp_format = true + max_size = e_size + } + d = w # deactivate dec-places count + + } else if (fmt == FMT_FIXED) { # Fortran 'F' format + exp_format = f_size > w + + if (exp_format) { # is there too little space? + no_digits = max (1, w - e_size) + max_size = no_digits + e_size + } else { + no_digits = e + d + 1 # negative e is OK here + max_size = f_size + } + + } else { # Fortran 'E' format + exp_format = true + max_size = e_size + d + d = w + } + + # Round the number at digit (no_digits + 1). + if (no_digits >= 0) + v = v + 0.5 * 10. ** (-no_digits) + + # Be sure the number of digits is in range. + no_digits = max(1, min(MAX_DIGITS, no_digits)) + + # Handle the unusual situation of rounding from .999.. up to 1.000. + if (v >= 1.0) { + v = v / 10.0 + e = e + 1 + if (!exp_format) { + max_size = max_size + 1 + no_digits = min (MAX_DIGITS, no_digits + 1) + } + } + + # See if the number will fit in 'w' characters + if (max_size > w) { + for (i=1; i <= w; i=i+1) + out[i] = OVFL_CHAR + out[i] = EOS + return (w) + } + + # Extract the first digits. At the start V is normalized + # to a value less than 1.0. The algorithm is to multiply by ten and + # take the integer part to get each digit. + + do i = 1, no_digits { + v = v * 10.0d0 + j = int (v + EPSILOND) # truncate to integer + v = v - j # lop off the integral part + + # Make sure the next iteration will produce a decimal J in the + # range 1-9. On some systems, due to precision problems J=int(V) + # can be off by one compared to V-J and this will result in a J + # of 10 in the next iteration. The expression below attempts to + # look ahead for J>=10 and adjusts the J for the current iteration + # up by one if this will occur. + + if (int (v * 10.0d0 + EPSILOND) >= 10) { + j = j + 1 + v = v - 1 + if (v < 0) + v = 0 + } + + digits[i] = TO_DIGIT(j) + } + + # Take digit string and exponent and arrange into desired format. + len = 1 + if (neg) { + out[1] = '-' + len = len + 1 + } + + if (exp_format) { # set up exponential format + out[len] = digits[1] + out[len+1] = '.' + len = len + 2 + for (i=2; i <= no_digits; i=i+1) { + out[len] = digits[i] + len = len + 1 + } + out[len] = 'E' + len = len + 1 + if (e < 0) { + out[len] = '-' + len = len + 1 + e = -e + } + len = len + itoc (e, out[len], w - len + 1) + + } else if (e >= no_digits) { + # Handle numbers >= 1 with dp after figures. + for (i=1; i <= no_digits; i=i+1) { + out[len] = digits[i] + len = len + 1 + } + for (i=no_digits; i <= e; i=i+1) { + out[len] = '0' + len = len + 1 + } + if (decpl > 0) { + out[len] = '.' + len = len + 1 + if (!squeeze) { + for (i=1; i <= d; i=i+1) { + out[len] = '0' + len = len + 1 + } + } + } + + } else { + if (e < 0) { + # Handle fixed numbers < 1. + if (d == 0 && e == -1 && digits[1] >= '5') + out[len] = '1' + else + out[len] = '0' + out[len + 1] = '.' + len = len + 2 + for (i=1; i < -e && d > 0; i=i+1) { + out[len] = '0' + len = len + 1 + d = d - 1 + } + i = 1 + } else { + # Handle numbers > 1 with dp inside figures. + e = e + 2 # one more zero below + for (i=1; i < e; i=i+1) { + out[len] = digits[i] + len = len + 1 + } + if (decpl > 0) { + out[len] = '.' + len = len + 1 + } + } + + for (j=1; i <= no_digits && j <= d; j=j+1) { + out[len] = digits[i] + i = i + 1 + len = len + 1 + } + if (squeeze) { + while (len > 2) { # skip trailing zeroes + len = len - 1 + if (out[len] != '0') { + len = len + 1 # non-digit -- keep it + break + } + } + } else { + for (i=1; i < d+e-no_digits && i <= d; i=i+1) { + out[len] = '0' + len = len + 1 + } + } + } + + out[len] = EOS + return (len - 1) +end diff --git a/sys/fmtio/eprintf.x b/sys/fmtio/eprintf.x new file mode 100644 index 00000000..51b2d196 --- /dev/null +++ b/sys/fmtio/eprintf.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# EPRINTF -- Format output to the standard error output. + +procedure eprintf (format_string) + +char format_string[ARB] + +begin + call flush (STDOUT) + call fprntf (STDERR, format_string, REGULAR_FILE) +end diff --git a/sys/fmtio/escchars.inc b/sys/fmtio/escchars.inc new file mode 100644 index 00000000..d3c4d33e --- /dev/null +++ b/sys/fmtio/escchars.inc @@ -0,0 +1,5 @@ + +# Escape sequences + +string escape_chars "ntfr'\"\\" +string mapped_chars "\n\t\f\r'\"\\" diff --git a/sys/fmtio/evexpr.com b/sys/fmtio/evexpr.com new file mode 100644 index 00000000..65488986 --- /dev/null +++ b/sys/fmtio/evexpr.com @@ -0,0 +1,7 @@ +# EVEXPR common. + +pointer ev_oval # pointer to expr value operand +int ev_getop # user supplied get operand procedure +int ev_ufcn # user supplied function call procedure + +common /xevcom/ ev_oval, ev_getop, ev_ufcn diff --git a/sys/fmtio/evexpr.x b/sys/fmtio/evexpr.x new file mode 100644 index 00000000..4d512a20 --- /dev/null +++ b/sys/fmtio/evexpr.x @@ -0,0 +1,1477 @@ + +# line 2 "evexpr.y" +include +include +include +include + +define YYMAXDEPTH 64 # parser stack length +define MAX_ARGS 16 # max args in a function call +define yyparse xev_parse + +define DTOR (($1)/57.2957795) +define RTOD (($1)*57.2957795) + +# Arglist structure. +define LEN_ARGSTRUCT (1+MAX_ARGS+(MAX_ARGS*LEN_OPERAND)) +define A_NARGS Memi[$1] # number of arguments +define A_ARGP Memi[$1+$2] # array of pointers to operand structs +define A_OPS ($1+MAX_ARGS+1) # offset to operand storage area + +# Intrinsic functions. + +define KEYWORDS "|abs|acos|asin|atan|atan2|bool|cos|exp|int|log|log10|\ + |max|min|mod|nint|real|sin|sqrt|str|tan|" + +define F_ABS 01 # function codes +define F_ACOS 02 +define F_ASIN 03 +define F_ATAN 04 +define F_ATAN2 05 +define F_BOOL 06 +define F_COS 07 +define F_EXP 08 +define F_INT 09 +define F_LOG 10 +define F_LOG10 11 + # newline 12 +define F_MAX 13 +define F_MIN 14 +define F_MOD 15 +define F_NINT 16 +define F_REAL 17 +define F_SIN 18 +define F_SQRT 19 +define F_STR 20 +define F_TAN 21 + + +# EVEXPR -- Evaluate an expression. This is the top level procedure, and the +# only externally callable entry point. Input consists of the expression to +# be evaluated (a string) and, optionally, user procedures for fetching +# external operands and executing external functions. Output is a pointer to +# an operand structure containing the computed value of the expression. +# The output operand structure is dynamically allocated by EVEXPR and must be +# freed by the user. +# +# N.B.: this is not intended to be an especially efficient procedure. Rather, +# this is a high level, easy to use procedure, intended to provide greater +# flexibility in the parameterization of applications programs. + +pointer procedure evexpr (expr, getop_epa, ufcn_epa) + +char expr[ARB] # expression to be evaluated +int getop_epa # user supplied get operand procedure +int ufcn_epa # user supplied function call procedure + +int junk +bool debug +pointer sp, ip +extern xev_gettok() +int strlen(), xev_parse() + +errchk xev_parse, calloc +include "evexpr.com" +data debug /false/ + +begin + call smark (sp) + + # Set user function entry point addresses. + ev_getop = getop_epa + ev_ufcn = ufcn_epa + + # Allocate an operand struct for the expression value. + call calloc (ev_oval, LEN_OPERAND, TY_STRUCT) + + # Make a local copy of the input string. + call salloc (ip, strlen(expr), TY_CHAR) + call strcpy (expr, Memc[ip], ARB) + + # Evaluate the expression. The expression value is copied into the + # output operand structure by XEV_PARSE, given the operand pointer + # passed in common. A common must be used since the standard parser + # subroutine has a fixed calling sequence. + + junk = xev_parse (ip, debug, xev_gettok) + + call sfree (sp) + return (ev_oval) +end + +define CONSTANT 257 +define IDENTIFIER 258 +define NEWLINE 259 +define YYEOS 260 +define PLUS 261 +define MINUS 262 +define STAR 263 +define SLASH 264 +define EXPON 265 +define CONCAT 266 +define QUEST 267 +define COLON 268 +define LT 269 +define GT 270 +define LE 271 +define EQ 272 +define NE 273 +define SE 274 +define AND 275 +define OR 276 +define NOT 277 +define AT 278 +define GE 279 +define UMINUS 280 +define yyclearin yychar = -1 +define yyerrok yyerrflag = 0 +define YYMOVE call amovi (Memi[$1], Memi[$2], YYOPLEN) +define YYERRCODE 256 + + + +# XEV_UNOP -- Unary operation. Perform the indicated unary operation on the +# input operand, returning the result as the output operand. + +procedure xev_unop (opcode, in, out) + +int opcode # operation to be performed +pointer in # input operand +pointer out # output operand + +errchk xev_error +define badsw_ 91 + +begin + call xev_initop (out, 0, O_TYPE(in)) + + switch (opcode) { + case MINUS: + # Unary negation. + switch (O_TYPE(in)) { + case TY_BOOL, TY_CHAR: + call xev_error ("negation of a nonarithmetic operand") + case TY_INT: + O_VALI(out) = -O_VALI(in) + case TY_REAL: + O_VALR(out) = -O_VALR(in) + default: + goto badsw_ + } + + case NOT: + switch (O_TYPE(in)) { + case TY_BOOL: + O_VALB(out) = !O_VALB(in) + case TY_CHAR, TY_INT, TY_REAL: + call xev_error ("not of a nonlogical") + default: + goto badsw_ + } + + default: +badsw_ call xev_error ("bad switch in unop") + } +end + + +# XEV_BINOP -- Binary operation. Perform the indicated arithmetic binary +# operation on the two input operands, returning the result as the output +# operand. + +procedure xev_binop (opcode, in1, in2, out) + +int opcode # operation to be performed +pointer in1, in2 # input operands +pointer out # output operand + +real r1, r2 +int i1, i2, dtype, nchars +int xev_newtype(), strlen() +errchk xev_newtype + +begin + # Set the datatype of the output operand, taking an error action if + # the operands have incompatible datatypes. + + dtype = xev_newtype (O_TYPE(in1), O_TYPE(in2)) + call xev_initop (out, 0, dtype) + + switch (dtype) { + case TY_BOOL: + call xev_error ("operation illegal for boolean operands") + case TY_CHAR: + if (opcode != CONCAT) + call xev_error ("operation illegal for string operands") + case TY_INT: + i1 = O_VALI(in1) + i2 = O_VALI(in2) + case TY_REAL: + if (O_TYPE(in1) == TY_INT) + r1 = O_VALI(in1) + else + r1 = O_VALR(in1) + if (O_TYPE(in2) == TY_INT) + r2 = O_VALI(in2) + else + r2 = O_VALR(in2) + default: + call xev_error ("unknown datatype code in binop") + } + + # Perform the operation. + switch (opcode) { + case PLUS: + if (dtype == TY_INT) + O_VALI(out) = i1 + i2 + else + O_VALR(out) = r1 + r2 + + case MINUS: + if (dtype == TY_INT) + O_VALI(out) = i1 - i2 + else + O_VALR(out) = r1 - r2 + + case STAR: + if (dtype == TY_INT) + O_VALI(out) = i1 * i2 + else + O_VALR(out) = r1 * r2 + + case SLASH: + if (dtype == TY_INT) + O_VALI(out) = i1 / i2 + else + O_VALR(out) = r1 / r2 + + case EXPON: + if (dtype == TY_INT) + O_VALI(out) = i1 ** i2 + else if (O_TYPE(in1) == TY_REAL && O_TYPE(in2) == TY_INT) + O_VALR(out) = r1 ** (O_VALI(in2)) + else + O_VALR(out) = r1 ** r2 + + case CONCAT: + if (dtype != TY_CHAR) + call xev_error ("concatenation of a nonstring operand") + nchars = strlen (O_VALC(in1)) + strlen (O_VALC(in2)) + call xev_makeop (out, nchars, TY_CHAR) + call strcpy (O_VALC(in1), O_VALC(out), ARB) + call strcat (O_VALC(in2), O_VALC(out), ARB) + call xev_freeop (in1) + call xev_freeop (in2) + + default: + call xev_error ("bad switch in binop") + } +end + + +# XEV_BOOLOP -- Boolean binary operations. Perform the indicated boolean binary +# operation on the two input operands, returning the result as the output +# operand. + +procedure xev_boolop (opcode, in1, in2, out) + +int opcode # operation to be performed +pointer in1, in2 # input operands +pointer out # output operand + +bool result +real r1, r2 +int i1, i2, dtype +int xev_newtype(), xev_patmatch(), strncmp() +errchk xev_newtype, xev_error +define badsw_ 91 + +begin + # Set the datatype of the output operand, taking an error action if + # the operands have incompatible datatypes. + + dtype = xev_newtype (O_TYPE(in1), O_TYPE(in2)) + call xev_initop (out, 0, dtype) + + switch (opcode) { + case AND, OR: + if (dtype != TY_BOOL) + call xev_error ("AND or OR of nonlogical") + case LT, GT, LE, GE: + if (dtype == TY_BOOL) + call xev_error ("order comparison of a boolean operand") + } + + if (dtype == TY_INT) { + i1 = O_VALI(in1) + i2 = O_VALI(in2) + } else if (dtype == TY_REAL) { + if (O_TYPE(in1) == TY_INT) { + i1 = O_VALI(in1) + r1 = i1 + } else + r1 = O_VALR(in1) + if (O_TYPE(in2) == TY_INT) { + i2 = O_VALI(in2) + r2 = i2 + } else + r2 = O_VALR(in2) + } + + # Perform the operation. + switch (opcode) { + case AND: + result = O_VALB(in1) && O_VALB(in2) + case OR: + result = O_VALB(in1) || O_VALB(in2) + + case LT, GE: + if (dtype == TY_INT) + result = i1 < i2 + else if (dtype == TY_REAL) + result = r1 < r2 + else + result = strncmp (O_VALC(in1), O_VALC(in2), ARB) < 0 + if (opcode == GE) + result = !result + + case GT, LE: + if (dtype == TY_INT) + result = i1 > i2 + else if (dtype == TY_REAL) + result = r1 > r2 + else + result = strncmp (O_VALC(in1), O_VALC(in2), ARB) > 0 + if (opcode == LE) + result = !result + + case EQ, SE, NE: + switch (dtype) { + case TY_BOOL: + if (O_VALB(in1)) + result = O_VALB(in2) + else + result = !O_VALB(in2) + case TY_CHAR: + if (opcode == SE) + result = xev_patmatch (O_VALC(in1), O_VALC(in2)) > 0 + else + result = strncmp (O_VALC(in1), O_VALC(in2), ARB) == 0 + case TY_INT: + result = i1 == i2 + case TY_REAL: + result = r1 == r2 + default: + goto badsw_ + } + if (opcode == NE) + result = !result + + default: +badsw_ call xev_error ("bad switch in boolop") + } + + call xev_makeop (out, 0, TY_BOOL) + O_VALB(out) = result + + # Free storage if there were any string type input operands. + call xev_freeop (in1) + call xev_freeop (in2) +end + + +# XEV_PATMATCH -- Match a string against a pattern, returning the patmatch +# index if the string matches. The pattern may contain any of the conventional +# pattern matching metacharacters. Closure (i.e., "*") is mapped to "?*". + +int procedure xev_patmatch (str, pat) + +char str[ARB] # operand string +char pat[ARB] # pattern + +int junk, ip, index +pointer sp, patstr, patbuf, op +int patmake(), patmatch() + +begin + call smark (sp) + call salloc (patstr, SZ_FNAME, TY_CHAR) + call salloc (patbuf, SZ_LINE, TY_CHAR) + call aclrc (Memc[patstr], SZ_FNAME) + call aclrc (Memc[patbuf], SZ_LINE) + + # Map pattern, changing '*' into '?*'. + op = patstr + for (ip=1; pat[ip] != EOS; ip=ip+1) { + if (pat[ip] == '*') { + Memc[op] = '?' + op = op + 1 + } + Memc[op] = pat[ip] + op = op + 1 + } + + # Encode pattern. + junk = patmake (Memc[patstr], Memc[patbuf], SZ_LINE) + + # Perform the pattern matching operation. + index = patmatch (str, Memc[patbuf]) + + call sfree (sp) + return (index) +end + + +# XEV_NEWTYPE -- Get the datatype of a binary operation, given the datatypes +# of the two input operands. An error action is taken if the datatypes are +# incompatible, e.g., boolean and anything else or string and anything else. + +int procedure xev_newtype (type1, type2) + +int type1, type2 +int newtype, p, q, i +int tyindex[NTYPES], ttbl[NTYPES*NTYPES] +data tyindex /TY_BOOL, TY_CHAR, TY_INT, TY_REAL/ +data (ttbl(i),i=1,4) /TY_BOOL, 0, 0, 0/ +data (ttbl(i),i=5,8) / 0, TY_CHAR, 0, 0/ +data (ttbl(i),i=9,12) / 0, 0, TY_INT, TY_REAL/ +data (ttbl(i),i=13,16) / 0, 0, TY_REAL, TY_REAL/ + +begin + do i = 1, NTYPES { + if (tyindex[i] == type1) + p = i + if (tyindex[i] == type2) + q = i + } + + newtype = ttbl[(p-1)*NTYPES+q] + if (newtype == 0) + call xev_error ("operands have incompatible types") + else + return (newtype) +end + + +# XEV_QUEST -- Conditional expression. If the condition operand is true +# return the first (true) operand, else return the second (false) operand. + +procedure xev_quest (cond, trueop, falseop, out) + +pointer cond # pointer to condition operand +pointer trueop, falseop # pointer to true,false operands +pointer out # pointer to output operand +errchk xev_error + +begin + if (O_TYPE(cond) != TY_BOOL) + call xev_error ("nonboolean condition operand") + + if (O_VALB(cond)) { + YYMOVE (trueop, out) + call xev_freeop (falseop) + } else { + YYMOVE (falseop, out) + call xev_freeop (trueop) + } +end + + +# XEV_CALLFCN -- Call an intrinsic function. If the function named is not +# one of the standard intrinsic functions, call an external user function +# if a function call procedure was supplied. + +procedure xev_callfcn (fcn, args, nargs, out) + +char fcn[ARB] # function to be called +pointer args[ARB] # pointer to arglist descriptor +int nargs # number of arguments +pointer out # output operand (function value) + +real rresult, rval[2], rtemp +int iresult, ival[2], type[2], optype, oplen, itemp +int opcode, v_nargs, i +pointer sp, buf, ap +include "evexpr.com" + +bool strne() +int strdic(), strlen() +errchk zcall4, xev_error1, xev_error2, malloc +string keywords KEYWORDS +define badtype_ 91 +define free_ 92 + +begin + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + + oplen = 0 + + # Lookup the function name in the dictionary. An exact match is + # required (strdic permits abbreviations). + + opcode = strdic (fcn, Memc[buf], SZ_FNAME, keywords) + if (opcode > 0 && strne(fcn,Memc[buf])) + opcode = 0 + + # If the function named is not a standard one and the user has supplied + # the entry point of an external function evaluation procedure, call + # the user procedure to evaluate the function, otherwise abort. + + if (opcode <= 0) + if (ev_ufcn != NULL) { + call zcall4 (ev_ufcn, fcn, args, nargs, out) + goto free_ + } else + call xev_error1 ("unknown function `%s' called", fcn) + + # Verify correct number of arguments. + switch (opcode) { + case F_MOD: + v_nargs = 2 + case F_MAX, F_MIN, F_ATAN, F_ATAN2: + v_nargs = -1 + default: + v_nargs = 1 + } + + if (v_nargs > 0 && nargs != v_nargs) + call xev_error2 ("function `%s' requires %d arguments", + fcn, v_nargs) + else if (v_nargs < 0 && nargs < abs(v_nargs)) + call xev_error2 ("function `%s' requires at least %d arguments", + fcn, abs(v_nargs)) + + # Verify datatypes. + if (opcode != F_STR && opcode != F_BOOL) { + optype = TY_REAL + do i = 1, min(2,nargs) { + switch (O_TYPE(args[i])) { + case TY_INT: + ival[i] = O_VALI(args[i]) + rval[i] = ival[i] + type[i] = TY_INT + case TY_REAL: + rval[i] = O_VALR(args[i]) + ival[i] = nint (rval[i]) + type[i] = TY_REAL + default: + goto badtype_ + } + } + } + + # Evaluate the function. + + ap = args[1] + + switch (opcode) { + case F_ABS: + if (type[1] == TY_INT) { + iresult = abs (ival[1]) + optype = TY_INT + } else + rresult = abs (rval[1]) + + case F_ACOS: + rresult = RTOD (acos (rval[1])) + case F_ASIN: + rresult = RTOD (asin (rval[1])) + case F_COS: + rresult = cos (DTOR (rval[1])) + case F_EXP: + rresult = exp (rval[1]) + case F_LOG: + rresult = log (rval[1]) + case F_LOG10: + rresult = log10 (rval[1]) + case F_SIN: + rresult = sin (DTOR (rval[1])) + case F_SQRT: + rresult = sqrt (rval[1]) + case F_TAN: + rresult = tan (DTOR (rval[1])) + + case F_ATAN, F_ATAN2: + if (nargs == 1) + rresult = RTOD (atan (rval[1])) + else + rresult = RTOD (atan2 (rval[1], rval[2])) + + case F_MOD: + if (type[1] == TY_REAL || type[2] == TY_REAL) + rresult = mod (rval[1], rval[2]) + else { + iresult = mod (ival[1], ival[2]) + optype = TY_INT + } + + case F_NINT: + iresult = nint (rval[1]) + optype = TY_INT + + case F_MAX, F_MIN: + # Determine datatype of result. + optype = TY_INT + do i = 1, nargs + if (O_TYPE(args[i]) == TY_REAL) + optype = TY_REAL + else if (O_TYPE(args[i]) != TY_INT) + goto badtype_ + + # Compute result. + if (optype == TY_INT) { + iresult = O_VALI(ap) + do i = 2, nargs { + itemp = O_VALI(args[i]) + if (opcode == F_MAX) + iresult = max (iresult, itemp) + else + iresult = min (iresult, itemp) + } + + } else { + if (O_TYPE(ap) == TY_INT) + rresult = O_VALI(ap) + else + rresult = O_VALR(ap) + + do i = 2, nargs { + if (O_TYPE(args[i]) == TY_INT) + rtemp = O_VALI(args[i]) + else + rtemp = O_VALR(args[i]) + if (opcode == F_MAX) + rresult = max (rresult, rtemp) + else + rresult = min (rresult, rtemp) + } + } + + case F_BOOL: + optype = TY_BOOL + switch (O_TYPE(ap)) { + case TY_BOOL: + if (O_VALB(ap)) + iresult = 1 + else + iresult = 0 + case TY_CHAR: + iresult = strlen (O_VALC(ap)) + case TY_INT: + iresult = O_VALI(ap) + case TY_REAL: + if (abs(rval[1]) > .001) + iresult = 1 + else + iresult = 0 + default: + goto badtype_ + } + + case F_INT: + optype = TY_INT + if (type[1] == TY_INT) + iresult = ival[1] + else + iresult = rval[1] + + case F_REAL: + rresult = rval[1] + + case F_STR: + # Convert operand to operand of type string. + + optype = TY_CHAR + switch (O_TYPE(ap)) { + case TY_BOOL: + call malloc (iresult, 3, TY_CHAR) + oplen = 3 + if (O_VALB(ap)) + call strcpy ("yes", Memc[iresult], 3) + else + call strcpy ("no", Memc[iresult], 3) + case TY_CHAR: + oplen = strlen (O_VALC(ap)) + call malloc (iresult, oplen, TY_CHAR) + call strcpy (O_VALC(ap), Memc[iresult], ARB) + case TY_INT: + oplen = MAX_DIGITS + call malloc (iresult, oplen, TY_CHAR) + call sprintf (Memc[iresult], SZ_FNAME, "%d") + call pargi (O_VALI(ap)) + case TY_REAL: + oplen = MAX_DIGITS + call malloc (iresult, oplen, TY_CHAR) + call sprintf (Memc[iresult], SZ_FNAME, "%g") + call pargr (O_VALR(ap)) + default: + goto badtype_ + } + + default: + call xev_error ("bad switch in callfcn") + } + + # Write the result to the output operand. Bool results are stored in + # iresult as an integer value, string results are stored in iresult as + # a pointer to the output string, and integer and real results are + # stored in iresult and rresult without any tricks. + + call xev_initop (out, oplen, optype) + + switch (optype) { + case TY_BOOL: + O_VALB(out) = (iresult != 0) + case TY_CHAR: + O_VALP(out) = iresult + case TY_INT: + O_VALI(out) = iresult + case TY_REAL: + O_VALR(out) = rresult + } + +free_ + # Free any storage used by the argument list operands. + do i = 1, nargs + call xev_freeop (args[i]) + + call sfree (sp) + return + +badtype_ + call xev_error1 ("bad argument to function `%s'", fcn) + call sfree (sp) + return +end + + +# XEV_STARTARGLIST -- Allocate an argument list descriptor to receive +# arguments as a function call is parsed. We are called with either +# zero or one arguments. The argument list descriptor is pointed to by +# a ficticious operand. The descriptor itself contains a count of the +# number of arguments, an array of pointers to the operand structures, +# as well as storage for the operand structures. The operands must be +# stored locally since the parser will discard its copy of the operand +# structure for each argument as the associated grammar rule is reduced. + +procedure xev_startarglist (arg, out) + +pointer arg # pointer to first argument, or NULL +pointer out # output operand pointing to arg descriptor +pointer ap + +errchk malloc + +begin + call xev_initop (out, 0, TY_POINTER) + call malloc (ap, LEN_ARGSTRUCT, TY_STRUCT) + O_VALP(out) = ap + + if (arg == NULL) + A_NARGS(ap) = 0 + else { + A_NARGS(ap) = 1 + A_ARGP(ap,1) = A_OPS(ap) + YYMOVE (arg, A_OPS(ap)) + } +end + + +# XEV_ADDARG -- Add an argument to the argument list for a function call. + +procedure xev_addarg (arg, arglist, out) + +pointer arg # pointer to argument to be added +pointer arglist # pointer to operand pointing to arglist +pointer out # output operand pointing to arg descriptor + +pointer ap, o +int nargs + +begin + ap = O_VALP(arglist) + + nargs = A_NARGS(ap) + 1 + A_NARGS(ap) = nargs + if (nargs > MAX_ARGS) + call xev_error ("too many function arguments") + + o = A_OPS(ap) + ((nargs - 1) * LEN_OPERAND) + A_ARGP(ap,nargs) = o + YYMOVE (arg, o) + + YYMOVE (arglist, out) +end + + +# XEV_ERROR1 -- Take an error action, formatting an error message with one +# format string plus one string argument. + +procedure xev_error1 (fmt, arg) + +char fmt[ARB] # printf format string +char arg[ARB] # string argument +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + call sprintf (Memc[buf], SZ_LINE, fmt) + call pargstr (arg) + + call xev_error (Memc[buf]) + call sfree (sp) +end + + +# XEV_ERROR2 -- Take an error action, formatting an error message with one +# format string plus one string argument and one integer argument. + +procedure xev_error2 (fmt, arg1, arg2) + +char fmt[ARB] # printf format string +char arg1[ARB] # string argument +int arg2 # integer argument +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + call sprintf (Memc[buf], SZ_LINE, fmt) + call pargstr (arg1) + call pargi (arg2) + + call xev_error (Memc[buf]) + call sfree (sp) +end + + +# XEV_ERROR -- Take an error action, given an error message string as the +# sole argument. + +procedure xev_error (errmsg) + +char errmsg[ARB] # error message + +begin + call error (1, errmsg) +end + + +# XEV_INITOP -- Set up an unintialized operand structure. + +procedure xev_initop (o, o_len, o_type) + +pointer o # pointer to operand structure +int o_len # length of operand (zero if scalar) +int o_type # datatype of operand + +begin + O_LEN(o) = 0 + call xev_makeop (o, o_len, o_type) +end + + +# XEV_MAKEOP -- Set up the operand structure. If the operand structure has +# already been initialized and array storage allocated, free the old array. + +procedure xev_makeop (o, o_len, o_type) + +pointer o # pointer to operand structure +int o_len # length of operand (zero if scalar) +int o_type # datatype of operand + +errchk malloc + +begin + # Free old array storage if any. + if (O_TYPE(o) != 0 && O_LEN(o) > 1) { + call mfree (O_VALP(o), O_TYPE(o)) + O_LEN(o) = 0 + } + + # Set new operand type. + O_TYPE(o) = o_type + + # Allocate array storage if nonscalar operand. + if (o_len > 0) { + call malloc (O_VALP(o), o_len, o_type) + O_LEN(o) = o_len + } +end + + +# XEV_FREEOP -- Reinitialize an operand structure, i.e., free any associated +# array storage and clear the operand datatype field, but do not free the +# operand structure itself (which may be only a segment of an array and not +# a separately allocated structure). + +procedure xev_freeop (o) + +pointer o # pointer to operand structure + +begin + # Free old array storage if any. + if (O_TYPE(o) != 0 && O_LEN(o) > 1) { + call mfree (O_VALP(o), O_TYPE(o)) + O_LEN(o) = 0 + } + + # Clear the operand type to mark operand invalid. + O_TYPE(o) = 0 +end +define YYNPROD 33 +define YYLAST 303 +# line 1 "/iraf/iraf/lib/yaccpar.x" +# 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 + + +# XEV_PARSE -- SPP/Yacc parser for the evaluation of an expression passed as +# a text string. Expression evaluation is carried out as the expression is +# parsed, rather than being broken into separate compile and execute stages. +# There is only one statement in this grammar, the expression. Our function +# is to reduce an expression to a single value of type bool, string, int, +# or real. + +pointer ap +bool streq() +errchk zcall2, xev_error1, xev_unop, xev_binop, xev_boolop +errchk xev_quest, xev_callfcn, xev_addarg +include "evexpr.com" + +short yyexca[96] +data (yyexca(i),i= 1, 8) / -1, 1, 0, -1, -2, 0, -1, 4/ +data (yyexca(i),i= 9, 16) / 40, 27, -2, 3, -1, 5, 40, 26/ +data (yyexca(i),i= 17, 24) / -2, 4, -1, 61, 269, 0, 270, 0/ +data (yyexca(i),i= 25, 32) / 271, 0, 279, 0, -2, 16, -1, 62/ +data (yyexca(i),i= 33, 40) / 269, 0, 270, 0, 271, 0, 279, 0/ +data (yyexca(i),i= 41, 48) / -2, 17, -1, 63, 269, 0, 270, 0/ +data (yyexca(i),i= 49, 56) / 271, 0, 279, 0, -2, 18, -1, 64/ +data (yyexca(i),i= 57, 64) / 269, 0, 270, 0, 271, 0, 279, 0/ +data (yyexca(i),i= 65, 72) / -2, 19, -1, 65, 272, 0, 273, 0/ +data (yyexca(i),i= 73, 80) / 274, 0, -2, 20, -1, 66, 272, 0/ +data (yyexca(i),i= 81, 88) / 273, 0, 274, 0, -2, 21, -1, 67/ +data (yyexca(i),i= 89, 96) / 272, 0, 273, 0, 274, 0, -2, 22/ +short yyact[303] +data (yyact(i),i= 1, 8) / 12, 13, 14, 15, 16, 17, 27, 71/ +data (yyact(i),i= 9, 16) / 20, 21, 22, 24, 26, 25, 18, 19/ +data (yyact(i),i= 17, 24) / 51, 16, 23, 11, 12, 13, 14, 15/ +data (yyact(i),i= 25, 32) / 16, 17, 27, 28, 20, 21, 22, 24/ +data (yyact(i),i= 33, 40) / 26, 25, 18, 19, 31, 49, 23, 12/ +data (yyact(i),i= 41, 48) / 13, 14, 15, 16, 17, 27, 10, 20/ +data (yyact(i),i= 49, 56) / 21, 22, 24, 26, 25, 18, 19, 10/ +data (yyact(i),i= 57, 64) / 9, 23, 12, 13, 14, 15, 16, 17/ +data (yyact(i),i= 65, 72) / 10, 1, 20, 21, 22, 24, 26, 25/ +data (yyact(i),i= 73, 80) / 18, 14, 15, 16, 23, 12, 13, 14/ +data (yyact(i),i= 81, 88) / 15, 16, 17, 0, 0, 20, 21, 22/ +data (yyact(i),i= 89, 96) / 24, 26, 25, 69, 0, 0, 70, 23/ +data (yyact(i),i= 97,104) / 12, 13, 14, 15, 16, 17, 0, 0/ +data (yyact(i),i=105,112) / 20, 21, 22, 12, 13, 14, 15, 16/ +data (yyact(i),i=113,120) / 17, 2, 23, 12, 13, 14, 15, 16/ +data (yyact(i),i=121,128) / 0, 29, 30, 0, 32, 0, 0, 0/ +data (yyact(i),i=129,136) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=137,144) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=145,152) / 0, 50, 0, 52, 54, 55, 56, 57/ +data (yyact(i),i=153,160) / 58, 59, 60, 61, 62, 63, 64, 65/ +data (yyact(i),i=161,168) / 66, 67, 68, 0, 0, 0, 0, 0/ +data (yyact(i),i=169,176) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=177,184) / 0, 0, 0, 0, 33, 0, 0, 0/ +data (yyact(i),i=185,192) / 72, 0, 0, 74, 0, 0, 0, 0/ +data (yyact(i),i=193,200) / 0, 0, 34, 35, 36, 37, 38, 39/ +data (yyact(i),i=201,208) / 40, 41, 42, 43, 44, 45, 46, 47/ +data (yyact(i),i=209,216) / 48, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=217,224) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=225,232) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=233,240) / 0, 0, 0, 0, 12, 13, 14, 15/ +data (yyact(i),i=241,248) / 16, 17, 27, 0, 20, 21, 22, 24/ +data (yyact(i),i=249,256) / 26, 25, 18, 19, 73, 0, 23, 0/ +data (yyact(i),i=257,264) / 0, 0, 0, 0, 0, 0, 0, 4/ +data (yyact(i),i=265,272) / 5, 53, 0, 0, 7, 0, 0, 3/ +data (yyact(i),i=273,280) / 4, 5, 0, 0, 0, 7, 0, 0/ +data (yyact(i),i=281,288) / 0, 4, 5, 8, 6, 0, 7, 0/ +data (yyact(i),i=289,296) / 0, 0, 0, 0, 8, 6, 0, 0/ +data (yyact(i),i=297,303) / 0, 0, 0, 0, 0, 8, 6/ +short yypact[75] +data (yypact(i),i= 1, 8) / 15,-1000,-241,-1000,-1000,-1000,-230, 24/ +data (yypact(i),i= 9, 16) / 24, -4, 24,-1000,-1000,-1000,-1000,-1000/ +data (yypact(i),i= 17, 24) /-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000/ +data (yypact(i),i= 25, 32) /-1000,-1000,-1000,-1000,-1000,-1000,-1000, 24/ +data (yypact(i),i= 33, 40) / -25, 6, 6, 6, 6, 6, 6, 6/ +data (yypact(i),i= 41, 48) / 6, 6, 6, 6, 6, 6, 6, 6/ +data (yypact(i),i= 49, 56) / 6, 50,-222,-1000,-190,-1000,-190,-248/ +data (yypact(i),i= 57, 64) /-248,-1000,-146,-184,-203,-154,-154,-154/ +data (yypact(i),i= 65, 72) /-154,-165,-165,-165,-261,-1000, 24,-1000/ +data (yypact(i),i= 73, 75) /-222, 6,-222/ +short yypgo[6] +data (yypgo(i),i= 1, 6) / 0, 65, 113, 180, 56, 37/ +short yyr1[33] +data (yyr1(i),i= 1, 8) / 0, 1, 1, 2, 2, 2, 2, 2/ +data (yyr1(i),i= 9, 16) / 2, 2, 2, 2, 2, 2, 2, 2/ +data (yyr1(i),i= 17, 24) / 2, 2, 2, 2, 2, 2, 2, 2/ +data (yyr1(i),i= 25, 32) / 2, 2, 4, 4, 5, 5, 5, 3/ +data (yyr1(i),i= 33, 33) / 3/ +short yyr2[33] +data (yyr2(i),i= 1, 8) / 0, 2, 1, 1, 1, 2, 2, 2/ +data (yyr2(i),i= 9, 16) / 4, 4, 4, 4, 4, 4, 4, 4/ +data (yyr2(i),i= 17, 24) / 4, 4, 4, 4, 4, 4, 4, 7/ +data (yyr2(i),i= 25, 32) / 4, 3, 1, 1, 0, 1, 3, 0/ +data (yyr2(i),i= 33, 33) / 2/ +short yychk[75] +data (yychk(i),i= 1, 8) /-1000, -1, -2, 256, 257, 258, 278, 262/ +data (yychk(i),i= 9, 16) / 277, -4, 40, 260, 261, 262, 263, 264/ +data (yychk(i),i= 17, 24) / 265, 266, 275, 276, 269, 270, 271, 279/ +data (yychk(i),i= 25, 32) / 272, 274, 273, 267, 257, -2, -2, 40/ +data (yychk(i),i= 33, 40) / -2, -3, -3, -3, -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, -5, -2, 41, -2, 259, -2, -2/ +data (yychk(i),i= 57, 64) / -2, -2, -2, -2, -2, -2, -2, -2/ +data (yychk(i),i= 65, 72) / -2, -2, -2, -2, -2, 41, 44, 268/ +data (yychk(i),i= 73, 75) / -2, -3, -2/ +short yydef[75] +data (yydef(i),i= 1, 8) / 0, -2, 0, 2, -2, -2, 0, 0/ +data (yydef(i),i= 9, 16) / 0, 0, 0, 1, 31, 31, 31, 31/ +data (yydef(i),i= 17, 24) / 31, 31, 31, 31, 31, 31, 31, 31/ +data (yydef(i),i= 25, 32) / 31, 31, 31, 31, 5, 6, 7, 28/ +data (yydef(i),i= 33, 40) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yydef(i),i= 41, 48) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yydef(i),i= 49, 56) / 0, 0, 29, 25, 8, 32, 9, 10/ +data (yydef(i),i= 57, 64) / 11, 12, 13, 14, 15, -2, -2, -2/ +data (yydef(i),i= 65, 72) / -2, -2, -2, -2, 0, 24, 0, 31/ +data (yydef(i),i= 73, 75) / 30, 0, 23/ + +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 135 "evexpr.y" +{ + # Normal exit. Move the final expression value operand + # into the operand structure pointed to by the global + # variable ev_oval. + + YYMOVE (yypvt-YYOPLEN, ev_oval) + return (OK) + } +case 2: +# line 143 "evexpr.y" +{ + call error (1, "syntax error") + } +case 3: +# line 149 "evexpr.y" +{ + # Numeric constant. + YYMOVE (yypvt, yyval) + } +case 4: +# line 153 "evexpr.y" +{ + # The boolean constants "yes" and "no" are implemented + # as reserved operands. + + call xev_initop (yyval, 0, TY_BOOL) + if (streq (O_VALC(yypvt), "yes")) + O_VALB(yyval) = true + else if (streq (O_VALC(yypvt), "no")) + O_VALB(yyval) = false + else if (ev_getop != NULL) + call zcall2 (ev_getop, O_VALC(yypvt), yyval) + else + call xev_error1 ("illegal operand `%s'", O_VALC(yypvt)) + call xev_freeop (yypvt) + } +case 5: +# line 168 "evexpr.y" +{ + # e.g., @"param" + if (ev_getop != NULL) + call zcall2 (ev_getop, O_VALC(yypvt), yyval) + else + call xev_error1 ("illegal operand `%s'", O_VALC(yypvt)) + call xev_freeop (yypvt) + } +case 6: +# line 176 "evexpr.y" +{ + # Unary arithmetic minus. + call xev_unop (MINUS, yypvt, yyval) + } +case 7: +# line 180 "evexpr.y" +{ + # Boolean not. + call xev_unop (NOT, yypvt, yyval) + } +case 8: +# line 184 "evexpr.y" +{ + # Addition. + call xev_binop (PLUS, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 9: +# line 188 "evexpr.y" +{ + # Subtraction. + call xev_binop (MINUS, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 10: +# line 192 "evexpr.y" +{ + # Multiplication. + call xev_binop (STAR, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 11: +# line 196 "evexpr.y" +{ + # Division. + call xev_binop (SLASH, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 12: +# line 200 "evexpr.y" +{ + # Exponentiation. + call xev_binop (EXPON, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 13: +# line 204 "evexpr.y" +{ + # String concatenation. + call xev_binop (CONCAT, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 14: +# line 208 "evexpr.y" +{ + # Boolean and. + call xev_boolop (AND, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 15: +# line 212 "evexpr.y" +{ + # Boolean or. + call xev_boolop (OR, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 16: +# line 216 "evexpr.y" +{ + # Boolean less than. + call xev_boolop (LT, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 17: +# line 220 "evexpr.y" +{ + # Boolean greater than. + call xev_boolop (GT, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 18: +# line 224 "evexpr.y" +{ + # Boolean less than or equal. + call xev_boolop (LE, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 19: +# line 228 "evexpr.y" +{ + # Boolean greater than or equal. + call xev_boolop (GE, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 20: +# line 232 "evexpr.y" +{ + # Boolean equal. + call xev_boolop (EQ, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 21: +# line 236 "evexpr.y" +{ + # String pattern-equal. + call xev_boolop (SE, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 22: +# line 240 "evexpr.y" +{ + # Boolean not equal. + call xev_boolop (NE, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 23: +# line 244 "evexpr.y" +{ + # Conditional expression. + call xev_quest (yypvt-6*YYOPLEN, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 24: +# line 248 "evexpr.y" +{ + # Call an intrinsic or external function. + ap = O_VALP(yypvt-YYOPLEN) + call xev_callfcn (O_VALC(yypvt-3*YYOPLEN), + A_ARGP(ap,1), A_NARGS(ap), yyval) + call mfree (ap, TY_STRUCT) + call xev_freeop (yypvt-3*YYOPLEN) + } +case 25: +# line 256 "evexpr.y" +{ + YYMOVE (yypvt-YYOPLEN, yyval) + } +case 26: +# line 262 "evexpr.y" +{ + YYMOVE (yypvt, yyval) + } +case 27: +# line 265 "evexpr.y" +{ + if (O_TYPE(yypvt) != TY_CHAR) + call error (1, "illegal function name") + YYMOVE (yypvt, yyval) + } +case 28: +# line 273 "evexpr.y" +{ + # Empty. + call xev_startarglist (NULL, yyval) + } +case 29: +# line 277 "evexpr.y" +{ + # First arg; start a nonnull list. + call xev_startarglist (yypvt, yyval) + } +case 30: +# line 281 "evexpr.y" +{ + # Add an argument to an existing list. + call xev_addarg (yypvt, yypvt-2*YYOPLEN, yyval) + } } + + goto yystack_ # stack new state and value +end diff --git a/sys/fmtio/evexpr.y b/sys/fmtio/evexpr.y new file mode 100644 index 00000000..297950bc --- /dev/null +++ b/sys/fmtio/evexpr.y @@ -0,0 +1,1087 @@ +%{ +include +include +include +include + +define YYMAXDEPTH 64 # parser stack length +define MAX_ARGS 16 # max args in a function call +define yyparse xev_parse + +define DTOR (($1)/57.2957795) +define RTOD (($1)*57.2957795) + +# Arglist structure. +define LEN_ARGSTRUCT (1+MAX_ARGS+(MAX_ARGS*LEN_OPERAND)) +define A_NARGS Memi[$1] # number of arguments +define A_ARGP Memi[$1+$2] # array of pointers to operand structs +define A_OPS ($1+MAX_ARGS+1) # offset to operand storage area + +# Intrinsic functions. + +define KEYWORDS "|abs|acos|asin|atan|atan2|bool|cos|exp|int|log|log10|\ + |max|min|mod|nint|real|sin|sqrt|str|tan|" + +define F_ABS 01 # function codes +define F_ACOS 02 +define F_ASIN 03 +define F_ATAN 04 +define F_ATAN2 05 +define F_BOOL 06 +define F_COS 07 +define F_EXP 08 +define F_INT 09 +define F_LOG 10 +define F_LOG10 11 + # newline 12 +define F_MAX 13 +define F_MIN 14 +define F_MOD 15 +define F_NINT 16 +define F_REAL 17 +define F_SIN 18 +define F_SQRT 19 +define F_STR 20 +define F_TAN 21 + + +# EVEXPR -- Evaluate an expression. This is the top level procedure, and the +# only externally callable entry point. Input consists of the expression to +# be evaluated (a string) and, optionally, user procedures for fetching +# external operands and executing external functions. Output is a pointer to +# an operand structure containing the computed value of the expression. +# The output operand structure is dynamically allocated by EVEXPR and must be +# freed by the user. +# +# N.B.: this is not intended to be an especially efficient procedure. Rather, +# this is a high level, easy to use procedure, intended to provide greater +# flexibility in the parameterization of applications programs. + +pointer procedure evexpr (expr, getop_epa, ufcn_epa) + +char expr[ARB] # expression to be evaluated +int getop_epa # user supplied get operand procedure +int ufcn_epa # user supplied function call procedure + +int junk +bool debug +pointer sp, ip +extern xev_gettok() +int strlen(), xev_parse() + +errchk xev_parse, calloc +include "evexpr.com" +data debug /false/ + +begin + call smark (sp) + + # Set user function entry point addresses. + ev_getop = getop_epa + ev_ufcn = ufcn_epa + + # Allocate an operand struct for the expression value. + call calloc (ev_oval, LEN_OPERAND, TY_STRUCT) + + # Make a local copy of the input string. + call salloc (ip, strlen(expr), TY_CHAR) + call strcpy (expr, Memc[ip], ARB) + + # Evaluate the expression. The expression value is copied into the + # output operand structure by XEV_PARSE, given the operand pointer + # passed in common. A common must be used since the standard parser + # subroutine has a fixed calling sequence. + + junk = xev_parse (ip, debug, xev_gettok) + + call sfree (sp) + return (ev_oval) +end + +%L +# XEV_PARSE -- SPP/Yacc parser for the evaluation of an expression passed as +# a text string. Expression evaluation is carried out as the expression is +# parsed, rather than being broken into separate compile and execute stages. +# There is only one statement in this grammar, the expression. Our function +# is to reduce an expression to a single value of type bool, string, int, +# or real. + +pointer ap +bool streq() +errchk zcall2, xev_error1, xev_unop, xev_binop, xev_boolop +errchk xev_quest, xev_callfcn, xev_addarg +include "evexpr.com" + +%} + +%token CONSTANT IDENTIFIER NEWLINE YYEOS +%token PLUS MINUS STAR SLASH EXPON CONCAT QUEST COLON +%token LT GT LE GT EQ NE SE AND OR NOT AT + +%nonassoc QUEST +%left OR +%left AND +%nonassoc EQ NE SE +%nonassoc LT GT LE GE +%left CONCAT +%left PLUS MINUS +%left STAR SLASH +%left EXPON +%right UMINUS NOT +%right AT + +%% + +stmt : expr YYEOS { + # Normal exit. Move the final expression value operand + # into the operand structure pointed to by the global + # variable ev_oval. + + YYMOVE ($1, ev_oval) + return (OK) + } + | error { + call error (1, "syntax error") + } + ; + + +expr : CONSTANT { + # Numeric constant. + YYMOVE ($1, $$) + } + | IDENTIFIER { + # The boolean constants "yes" and "no" are implemented + # as reserved operands. + + call xev_initop ($$, 0, TY_BOOL) + if (streq (O_VALC($1), "yes")) + O_VALB($$) = true + else if (streq (O_VALC($1), "no")) + O_VALB($$) = false + else if (ev_getop != NULL) + call zcall2 (ev_getop, O_VALC($1), $$) + else + call xev_error1 ("illegal operand `%s'", O_VALC($1)) + call xev_freeop ($1) + } + | AT CONSTANT { + # e.g., @"param" + if (ev_getop != NULL) + call zcall2 (ev_getop, O_VALC($2), $$) + else + call xev_error1 ("illegal operand `%s'", O_VALC($2)) + call xev_freeop ($2) + } + | MINUS expr %prec UMINUS { + # Unary arithmetic minus. + call xev_unop (MINUS, $2, $$) + } + | NOT expr { + # Boolean not. + call xev_unop (NOT, $2, $$) + } + | expr PLUS opnl expr { + # Addition. + call xev_binop (PLUS, $1, $4, $$) + } + | expr MINUS opnl expr { + # Subtraction. + call xev_binop (MINUS, $1, $4, $$) + } + | expr STAR opnl expr { + # Multiplication. + call xev_binop (STAR, $1, $4, $$) + } + | expr SLASH opnl expr { + # Division. + call xev_binop (SLASH, $1, $4, $$) + } + | expr EXPON opnl expr { + # Exponentiation. + call xev_binop (EXPON, $1, $4, $$) + } + | expr CONCAT opnl expr { + # String concatenation. + call xev_binop (CONCAT, $1, $4, $$) + } + | expr AND opnl expr { + # Boolean and. + call xev_boolop (AND, $1, $4, $$) + } + | expr OR opnl expr { + # Boolean or. + call xev_boolop (OR, $1, $4, $$) + } + | expr LT opnl expr { + # Boolean less than. + call xev_boolop (LT, $1, $4, $$) + } + | expr GT opnl expr { + # Boolean greater than. + call xev_boolop (GT, $1, $4, $$) + } + | expr LE opnl expr { + # Boolean less than or equal. + call xev_boolop (LE, $1, $4, $$) + } + | expr GE opnl expr { + # Boolean greater than or equal. + call xev_boolop (GE, $1, $4, $$) + } + | expr EQ opnl expr { + # Boolean equal. + call xev_boolop (EQ, $1, $4, $$) + } + | expr SE opnl expr { + # String pattern-equal. + call xev_boolop (SE, $1, $4, $$) + } + | expr NE opnl expr { + # Boolean not equal. + call xev_boolop (NE, $1, $4, $$) + } + | expr QUEST opnl expr COLON opnl expr { + # Conditional expression. + call xev_quest ($1, $4, $7, $$) + } + | funct '(' arglist ')' { + # Call an intrinsic or external function. + ap = O_VALP($3) + call xev_callfcn (O_VALC($1), + A_ARGP(ap,1), A_NARGS(ap), $$) + call mfree (ap, TY_STRUCT) + call xev_freeop ($1) + } + | '(' expr ')' { + YYMOVE ($2, $$) + } + ; + + +funct : IDENTIFIER { + YYMOVE ($1, $$) + } + | CONSTANT { + if (O_TYPE($1) != TY_CHAR) + call error (1, "illegal function name") + YYMOVE ($1, $$) + } + ; + + +arglist : { + # Empty. + call xev_startarglist (NULL, $$) + } + | expr { + # First arg; start a nonnull list. + call xev_startarglist ($1, $$) + } + | arglist ',' expr { + # Add an argument to an existing list. + call xev_addarg ($3, $1, $$) + } + ; + + +opnl : # Empty. + | opnl NEWLINE + ; + +%% + + +# XEV_UNOP -- Unary operation. Perform the indicated unary operation on the +# input operand, returning the result as the output operand. + +procedure xev_unop (opcode, in, out) + +int opcode # operation to be performed +pointer in # input operand +pointer out # output operand + +errchk xev_error +define badsw_ 91 + +begin + call xev_initop (out, 0, O_TYPE(in)) + + switch (opcode) { + case MINUS: + # Unary negation. + switch (O_TYPE(in)) { + case TY_BOOL, TY_CHAR: + call xev_error ("negation of a nonarithmetic operand") + case TY_INT: + O_VALI(out) = -O_VALI(in) + case TY_REAL: + O_VALR(out) = -O_VALR(in) + default: + goto badsw_ + } + + case NOT: + switch (O_TYPE(in)) { + case TY_BOOL: + O_VALB(out) = !O_VALB(in) + case TY_CHAR, TY_INT, TY_REAL: + call xev_error ("not of a nonlogical") + default: + goto badsw_ + } + + default: +badsw_ call xev_error ("bad switch in unop") + } +end + + +# XEV_BINOP -- Binary operation. Perform the indicated arithmetic binary +# operation on the two input operands, returning the result as the output +# operand. + +procedure xev_binop (opcode, in1, in2, out) + +int opcode # operation to be performed +pointer in1, in2 # input operands +pointer out # output operand + +real r1, r2 +int i1, i2, dtype, nchars +int xev_newtype(), strlen() +errchk xev_newtype + +begin + # Set the datatype of the output operand, taking an error action if + # the operands have incompatible datatypes. + + dtype = xev_newtype (O_TYPE(in1), O_TYPE(in2)) + call xev_initop (out, 0, dtype) + + switch (dtype) { + case TY_BOOL: + call xev_error ("operation illegal for boolean operands") + case TY_CHAR: + if (opcode != CONCAT) + call xev_error ("operation illegal for string operands") + case TY_INT: + i1 = O_VALI(in1) + i2 = O_VALI(in2) + case TY_REAL: + if (O_TYPE(in1) == TY_INT) + r1 = O_VALI(in1) + else + r1 = O_VALR(in1) + if (O_TYPE(in2) == TY_INT) + r2 = O_VALI(in2) + else + r2 = O_VALR(in2) + default: + call xev_error ("unknown datatype code in binop") + } + + # Perform the operation. + switch (opcode) { + case PLUS: + if (dtype == TY_INT) + O_VALI(out) = i1 + i2 + else + O_VALR(out) = r1 + r2 + + case MINUS: + if (dtype == TY_INT) + O_VALI(out) = i1 - i2 + else + O_VALR(out) = r1 - r2 + + case STAR: + if (dtype == TY_INT) + O_VALI(out) = i1 * i2 + else + O_VALR(out) = r1 * r2 + + case SLASH: + if (dtype == TY_INT) + O_VALI(out) = i1 / i2 + else + O_VALR(out) = r1 / r2 + + case EXPON: + if (dtype == TY_INT) + O_VALI(out) = i1 ** i2 + else if (O_TYPE(in1) == TY_REAL && O_TYPE(in2) == TY_INT) + O_VALR(out) = r1 ** (O_VALI(in2)) + else + O_VALR(out) = r1 ** r2 + + case CONCAT: + if (dtype != TY_CHAR) + call xev_error ("concatenation of a nonstring operand") + nchars = strlen (O_VALC(in1)) + strlen (O_VALC(in2)) + call xev_makeop (out, nchars, TY_CHAR) + call strcpy (O_VALC(in1), O_VALC(out), ARB) + call strcat (O_VALC(in2), O_VALC(out), ARB) + call xev_freeop (in1) + call xev_freeop (in2) + + default: + call xev_error ("bad switch in binop") + } +end + + +# XEV_BOOLOP -- Boolean binary operations. Perform the indicated boolean binary +# operation on the two input operands, returning the result as the output +# operand. + +procedure xev_boolop (opcode, in1, in2, out) + +int opcode # operation to be performed +pointer in1, in2 # input operands +pointer out # output operand + +bool result +real r1, r2 +int i1, i2, dtype +int xev_newtype(), xev_patmatch(), strncmp() +errchk xev_newtype, xev_error +define badsw_ 91 + +begin + # Set the datatype of the output operand, taking an error action if + # the operands have incompatible datatypes. + + dtype = xev_newtype (O_TYPE(in1), O_TYPE(in2)) + call xev_initop (out, 0, dtype) + + switch (opcode) { + case AND, OR: + if (dtype != TY_BOOL) + call xev_error ("AND or OR of nonlogical") + case LT, GT, LE, GE: + if (dtype == TY_BOOL) + call xev_error ("order comparison of a boolean operand") + } + + if (dtype == TY_INT) { + i1 = O_VALI(in1) + i2 = O_VALI(in2) + } else if (dtype == TY_REAL) { + if (O_TYPE(in1) == TY_INT) { + i1 = O_VALI(in1) + r1 = i1 + } else + r1 = O_VALR(in1) + if (O_TYPE(in2) == TY_INT) { + i2 = O_VALI(in2) + r2 = i2 + } else + r2 = O_VALR(in2) + } + + # Perform the operation. + switch (opcode) { + case AND: + result = O_VALB(in1) && O_VALB(in2) + case OR: + result = O_VALB(in1) || O_VALB(in2) + + case LT, GE: + if (dtype == TY_INT) + result = i1 < i2 + else if (dtype == TY_REAL) + result = r1 < r2 + else + result = strncmp (O_VALC(in1), O_VALC(in2), ARB) < 0 + if (opcode == GE) + result = !result + + case GT, LE: + if (dtype == TY_INT) + result = i1 > i2 + else if (dtype == TY_REAL) + result = r1 > r2 + else + result = strncmp (O_VALC(in1), O_VALC(in2), ARB) > 0 + if (opcode == LE) + result = !result + + case EQ, SE, NE: + switch (dtype) { + case TY_BOOL: + if (O_VALB(in1)) + result = O_VALB(in2) + else + result = !O_VALB(in2) + case TY_CHAR: + if (opcode == SE) + result = xev_patmatch (O_VALC(in1), O_VALC(in2)) > 0 + else + result = strncmp (O_VALC(in1), O_VALC(in2), ARB) == 0 + case TY_INT: + result = i1 == i2 + case TY_REAL: + result = r1 == r2 + default: + goto badsw_ + } + if (opcode == NE) + result = !result + + default: +badsw_ call xev_error ("bad switch in boolop") + } + + call xev_makeop (out, 0, TY_BOOL) + O_VALB(out) = result + + # Free storage if there were any string type input operands. + call xev_freeop (in1) + call xev_freeop (in2) +end + + +# XEV_PATMATCH -- Match a string against a pattern, returning the patmatch +# index if the string matches. The pattern may contain any of the conventional +# pattern matching metacharacters. Closure (i.e., "*") is mapped to "?*". + +int procedure xev_patmatch (str, pat) + +char str[ARB] # operand string +char pat[ARB] # pattern + +int junk, ip, index +pointer sp, patstr, patbuf, op +int patmake(), patmatch() + +begin + call smark (sp) + call salloc (patstr, SZ_FNAME, TY_CHAR) + call salloc (patbuf, SZ_LINE, TY_CHAR) + call aclrc (Memc[patstr], SZ_FNAME) + call aclrc (Memc[patbuf], SZ_LINE) + + # Map pattern, changing '*' into '?*'. + op = patstr + for (ip=1; pat[ip] != EOS; ip=ip+1) { + if (pat[ip] == '*') { + Memc[op] = '?' + op = op + 1 + } + Memc[op] = pat[ip] + op = op + 1 + } + + # Encode pattern. + junk = patmake (Memc[patstr], Memc[patbuf], SZ_LINE) + + # Perform the pattern matching operation. + index = patmatch (str, Memc[patbuf]) + + call sfree (sp) + return (index) +end + + +# XEV_NEWTYPE -- Get the datatype of a binary operation, given the datatypes +# of the two input operands. An error action is taken if the datatypes are +# incompatible, e.g., boolean and anything else or string and anything else. + +int procedure xev_newtype (type1, type2) + +int type1, type2 +int newtype, p, q, i +int tyindex[NTYPES], ttbl[NTYPES*NTYPES] +data tyindex /TY_BOOL, TY_CHAR, TY_INT, TY_REAL/ +data (ttbl(i),i=1,4) /TY_BOOL, 0, 0, 0/ +data (ttbl(i),i=5,8) / 0, TY_CHAR, 0, 0/ +data (ttbl(i),i=9,12) / 0, 0, TY_INT, TY_REAL/ +data (ttbl(i),i=13,16) / 0, 0, TY_REAL, TY_REAL/ + +begin + do i = 1, NTYPES { + if (tyindex[i] == type1) + p = i + if (tyindex[i] == type2) + q = i + } + + newtype = ttbl[(p-1)*NTYPES+q] + if (newtype == 0) + call xev_error ("operands have incompatible types") + else + return (newtype) +end + + +# XEV_QUEST -- Conditional expression. If the condition operand is true +# return the first (true) operand, else return the second (false) operand. + +procedure xev_quest (cond, trueop, falseop, out) + +pointer cond # pointer to condition operand +pointer trueop, falseop # pointer to true,false operands +pointer out # pointer to output operand +errchk xev_error + +begin + if (O_TYPE(cond) != TY_BOOL) + call xev_error ("nonboolean condition operand") + + if (O_VALB(cond)) { + YYMOVE (trueop, out) + call xev_freeop (falseop) + } else { + YYMOVE (falseop, out) + call xev_freeop (trueop) + } +end + + +# XEV_CALLFCN -- Call an intrinsic function. If the function named is not +# one of the standard intrinsic functions, call an external user function +# if a function call procedure was supplied. + +procedure xev_callfcn (fcn, args, nargs, out) + +char fcn[ARB] # function to be called +pointer args[ARB] # pointer to arglist descriptor +int nargs # number of arguments +pointer out # output operand (function value) + +real rresult, rval[2], rtemp +int iresult, ival[2], type[2], optype, oplen, itemp +int opcode, v_nargs, i +pointer sp, buf, ap +include "evexpr.com" + +bool strne() +int strdic(), strlen() +errchk zcall4, xev_error1, xev_error2, malloc +string keywords KEYWORDS +define badtype_ 91 +define free_ 92 + +begin + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + + oplen = 0 + + # Lookup the function name in the dictionary. An exact match is + # required (strdic permits abbreviations). + + opcode = strdic (fcn, Memc[buf], SZ_FNAME, keywords) + if (opcode > 0 && strne(fcn,Memc[buf])) + opcode = 0 + + # If the function named is not a standard one and the user has supplied + # the entry point of an external function evaluation procedure, call + # the user procedure to evaluate the function, otherwise abort. + + if (opcode <= 0) + if (ev_ufcn != NULL) { + call zcall4 (ev_ufcn, fcn, args, nargs, out) + goto free_ + } else + call xev_error1 ("unknown function `%s' called", fcn) + + # Verify correct number of arguments. + switch (opcode) { + case F_MOD: + v_nargs = 2 + case F_MAX, F_MIN, F_ATAN, F_ATAN2: + v_nargs = -1 + default: + v_nargs = 1 + } + + if (v_nargs > 0 && nargs != v_nargs) + call xev_error2 ("function `%s' requires %d arguments", + fcn, v_nargs) + else if (v_nargs < 0 && nargs < abs(v_nargs)) + call xev_error2 ("function `%s' requires at least %d arguments", + fcn, abs(v_nargs)) + + # Verify datatypes. + if (opcode != F_STR && opcode != F_BOOL) { + optype = TY_REAL + do i = 1, min(2,nargs) { + switch (O_TYPE(args[i])) { + case TY_INT: + ival[i] = O_VALI(args[i]) + rval[i] = ival[i] + type[i] = TY_INT + case TY_REAL: + rval[i] = O_VALR(args[i]) + ival[i] = nint (rval[i]) + type[i] = TY_REAL + default: + goto badtype_ + } + } + } + + # Evaluate the function. + + ap = args[1] + + switch (opcode) { + case F_ABS: + if (type[1] == TY_INT) { + iresult = abs (ival[1]) + optype = TY_INT + } else + rresult = abs (rval[1]) + + case F_ACOS: + rresult = RTOD (acos (rval[1])) + case F_ASIN: + rresult = RTOD (asin (rval[1])) + case F_COS: + rresult = cos (DTOR (rval[1])) + case F_EXP: + rresult = exp (rval[1]) + case F_LOG: + rresult = log (rval[1]) + case F_LOG10: + rresult = log10 (rval[1]) + case F_SIN: + rresult = sin (DTOR (rval[1])) + case F_SQRT: + rresult = sqrt (rval[1]) + case F_TAN: + rresult = tan (DTOR (rval[1])) + + case F_ATAN, F_ATAN2: + if (nargs == 1) + rresult = RTOD (atan (rval[1])) + else + rresult = RTOD (atan2 (rval[1], rval[2])) + + case F_MOD: + if (type[1] == TY_REAL || type[2] == TY_REAL) + rresult = mod (rval[1], rval[2]) + else { + iresult = mod (ival[1], ival[2]) + optype = TY_INT + } + + case F_NINT: + iresult = nint (rval[1]) + optype = TY_INT + + case F_MAX, F_MIN: + # Determine datatype of result. + optype = TY_INT + do i = 1, nargs + if (O_TYPE(args[i]) == TY_REAL) + optype = TY_REAL + else if (O_TYPE(args[i]) != TY_INT) + goto badtype_ + + # Compute result. + if (optype == TY_INT) { + iresult = O_VALI(ap) + do i = 2, nargs { + itemp = O_VALI(args[i]) + if (opcode == F_MAX) + iresult = max (iresult, itemp) + else + iresult = min (iresult, itemp) + } + + } else { + if (O_TYPE(ap) == TY_INT) + rresult = O_VALI(ap) + else + rresult = O_VALR(ap) + + do i = 2, nargs { + if (O_TYPE(args[i]) == TY_INT) + rtemp = O_VALI(args[i]) + else + rtemp = O_VALR(args[i]) + if (opcode == F_MAX) + rresult = max (rresult, rtemp) + else + rresult = min (rresult, rtemp) + } + } + + case F_BOOL: + optype = TY_BOOL + switch (O_TYPE(ap)) { + case TY_BOOL: + if (O_VALB(ap)) + iresult = 1 + else + iresult = 0 + case TY_CHAR: + iresult = strlen (O_VALC(ap)) + case TY_INT: + iresult = O_VALI(ap) + case TY_REAL: + if (abs(rval[1]) > .001) + iresult = 1 + else + iresult = 0 + default: + goto badtype_ + } + + case F_INT: + optype = TY_INT + if (type[1] == TY_INT) + iresult = ival[1] + else + iresult = rval[1] + + case F_REAL: + rresult = rval[1] + + case F_STR: + # Convert operand to operand of type string. + + optype = TY_CHAR + switch (O_TYPE(ap)) { + case TY_BOOL: + call malloc (iresult, 3, TY_CHAR) + oplen = 3 + if (O_VALB(ap)) + call strcpy ("yes", Memc[iresult], 3) + else + call strcpy ("no", Memc[iresult], 3) + case TY_CHAR: + oplen = strlen (O_VALC(ap)) + call malloc (iresult, oplen, TY_CHAR) + call strcpy (O_VALC(ap), Memc[iresult], ARB) + case TY_INT: + oplen = MAX_DIGITS + call malloc (iresult, oplen, TY_CHAR) + call sprintf (Memc[iresult], SZ_FNAME, "%d") + call pargi (O_VALI(ap)) + case TY_REAL: + oplen = MAX_DIGITS + call malloc (iresult, oplen, TY_CHAR) + call sprintf (Memc[iresult], SZ_FNAME, "%g") + call pargr (O_VALR(ap)) + default: + goto badtype_ + } + + default: + call xev_error ("bad switch in callfcn") + } + + # Write the result to the output operand. Bool results are stored in + # iresult as an integer value, string results are stored in iresult as + # a pointer to the output string, and integer and real results are + # stored in iresult and rresult without any tricks. + + call xev_initop (out, oplen, optype) + + switch (optype) { + case TY_BOOL: + O_VALB(out) = (iresult != 0) + case TY_CHAR: + O_VALP(out) = iresult + case TY_INT: + O_VALI(out) = iresult + case TY_REAL: + O_VALR(out) = rresult + } + +free_ + # Free any storage used by the argument list operands. + do i = 1, nargs + call xev_freeop (args[i]) + + call sfree (sp) + return + +badtype_ + call xev_error1 ("bad argument to function `%s'", fcn) + call sfree (sp) + return +end + + +# XEV_STARTARGLIST -- Allocate an argument list descriptor to receive +# arguments as a function call is parsed. We are called with either +# zero or one arguments. The argument list descriptor is pointed to by +# a ficticious operand. The descriptor itself contains a count of the +# number of arguments, an array of pointers to the operand structures, +# as well as storage for the operand structures. The operands must be +# stored locally since the parser will discard its copy of the operand +# structure for each argument as the associated grammar rule is reduced. + +procedure xev_startarglist (arg, out) + +pointer arg # pointer to first argument, or NULL +pointer out # output operand pointing to arg descriptor +pointer ap + +errchk malloc + +begin + call xev_initop (out, 0, TY_POINTER) + call malloc (ap, LEN_ARGSTRUCT, TY_STRUCT) + O_VALP(out) = ap + + if (arg == NULL) + A_NARGS(ap) = 0 + else { + A_NARGS(ap) = 1 + A_ARGP(ap,1) = A_OPS(ap) + YYMOVE (arg, A_OPS(ap)) + } +end + + +# XEV_ADDARG -- Add an argument to the argument list for a function call. + +procedure xev_addarg (arg, arglist, out) + +pointer arg # pointer to argument to be added +pointer arglist # pointer to operand pointing to arglist +pointer out # output operand pointing to arg descriptor + +pointer ap, o +int nargs + +begin + ap = O_VALP(arglist) + + nargs = A_NARGS(ap) + 1 + A_NARGS(ap) = nargs + if (nargs > MAX_ARGS) + call xev_error ("too many function arguments") + + o = A_OPS(ap) + ((nargs - 1) * LEN_OPERAND) + A_ARGP(ap,nargs) = o + YYMOVE (arg, o) + + YYMOVE (arglist, out) +end + + +# XEV_ERROR1 -- Take an error action, formatting an error message with one +# format string plus one string argument. + +procedure xev_error1 (fmt, arg) + +char fmt[ARB] # printf format string +char arg[ARB] # string argument +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + call sprintf (Memc[buf], SZ_LINE, fmt) + call pargstr (arg) + + call xev_error (Memc[buf]) + call sfree (sp) +end + + +# XEV_ERROR2 -- Take an error action, formatting an error message with one +# format string plus one string argument and one integer argument. + +procedure xev_error2 (fmt, arg1, arg2) + +char fmt[ARB] # printf format string +char arg1[ARB] # string argument +int arg2 # integer argument +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + call sprintf (Memc[buf], SZ_LINE, fmt) + call pargstr (arg1) + call pargi (arg2) + + call xev_error (Memc[buf]) + call sfree (sp) +end + + +# XEV_ERROR -- Take an error action, given an error message string as the +# sole argument. + +procedure xev_error (errmsg) + +char errmsg[ARB] # error message + +begin + call error (1, errmsg) +end + + +# XEV_INITOP -- Set up an unintialized operand structure. + +procedure xev_initop (o, o_len, o_type) + +pointer o # pointer to operand structure +int o_len # length of operand (zero if scalar) +int o_type # datatype of operand + +begin + O_LEN(o) = 0 + call xev_makeop (o, o_len, o_type) +end + + +# XEV_MAKEOP -- Set up the operand structure. If the operand structure has +# already been initialized and array storage allocated, free the old array. + +procedure xev_makeop (o, o_len, o_type) + +pointer o # pointer to operand structure +int o_len # length of operand (zero if scalar) +int o_type # datatype of operand + +errchk malloc + +begin + # Free old array storage if any. + if (O_TYPE(o) != 0 && O_LEN(o) > 1) { + call mfree (O_VALP(o), O_TYPE(o)) + O_LEN(o) = 0 + } + + # Set new operand type. + O_TYPE(o) = o_type + + # Allocate array storage if nonscalar operand. + if (o_len > 0) { + call malloc (O_VALP(o), o_len, o_type) + O_LEN(o) = o_len + } +end + + +# XEV_FREEOP -- Reinitialize an operand structure, i.e., free any associated +# array storage and clear the operand datatype field, but do not free the +# operand structure itself (which may be only a segment of an array and not +# a separately allocated structure). + +procedure xev_freeop (o) + +pointer o # pointer to operand structure + +begin + # Free old array storage if any. + if (O_TYPE(o) != 0 && O_LEN(o) > 1) { + call mfree (O_VALP(o), O_TYPE(o)) + O_LEN(o) = 0 + } + + # Clear the operand type to mark operand invalid. + O_TYPE(o) = 0 +end diff --git a/sys/fmtio/evvexpr.com b/sys/fmtio/evvexpr.com new file mode 100644 index 00000000..34a98be6 --- /dev/null +++ b/sys/fmtio/evvexpr.com @@ -0,0 +1,12 @@ +# EVVEXPR common. + +pointer ev_oval # pointer to expr value operand +int ev_st # symbol table +int ev_getop # user supplied get operand procedure +int ev_getop_data # client data for above +int ev_ufcn # user supplied function call procedure +int ev_ufcn_data # client data for above +int ev_flags # flag bits + +common /xvvcom/ ev_oval, ev_st, ev_getop, ev_getop_data, ev_ufcn, + ev_ufcn_data, ev_flags diff --git a/sys/fmtio/evvexpr.gy b/sys/fmtio/evvexpr.gy new file mode 100644 index 00000000..32a91153 --- /dev/null +++ b/sys/fmtio/evvexpr.gy @@ -0,0 +1,2680 @@ +%{ +include +include +include +include +include + +.help evvexpr +.nf -------------------------------------------------------------------------- +EVVEXPR.GY -- Generic XYacc source for a general vector expression evaluator. + + o = evvexpr (expr, getop, getop_data, ufcn, ufcn_data, flags) + evvfree (o) + +Client callbacks: + + getop (client_data, opname, out) + ufcn (client_data, fcn, args, nargs, out) + +here "out" is the output operand returned to EVVEXPR. Client_data is any +arbitrary integer or pointer value passed in to EVVEXPR when by the client +when the callback was registered. "args" is an array of operand structs, +the arguments for the user function being called. If the operand or +function call cannot be completed normally an error exit may be made (call +error) or an invalid operand may be returned (O_TYPE set to 0). The client +should not free the "args" input operands, this will be handled by EVVEXPR. + +Operand struct (lib$evvexpr.h): + + struct operand { + int O_TYPE # operand type (bcsilrd) + int O_LEN # operand length (0=scalar) + int O_FLAGS # O_FREEVAL, O_FREEOP + union { + char* O_VALC # string + short O_VALS + int O_VALI # int or bool + long O_VALL + real O_VALR + double O_VALD + pointer O_VALP # vector data + } + } + +The macro O_VALC references the string value of a TY_CHAR operand. The +flags are O_FREEVAL and O_FREEOP, which tell EVVEXPR and EVVFREE whether or +not to free any vector operand array or the operand struct when the operand +is freed. The client should set these flags on operands returned to EVVEXPR +if it wants EVVEXPR to free any operand storage. + +Supported types are bool, char (string), and SILRD. Bool is indicated as +TY_BOOL in the O_TYPE field of the operand struct, but is stored internally +as an integer and the value field of a boolean operand is given by O_VALI. + +Operands may be either scalars or vectors. A vector is indicated by a O_LEN +value greater than zero. For vector operands O_VALP points to the data array. +A special case is TY_CHAR (string), in which case O_LEN is the allocated +length of the EOS-terminated string. A string is logically a scalar value +even though it is physically stored in the operand as a character vector. + +The trig functions operate upon angles in units of radians. The intrinsic +functions RAD and DEG are available for converting between radians and +degrees. A string can be coerced to a binary value and vice versa, using +the INT, STR, etc. intrinsic functions. + +This is a generalization of the older EVEXPR routine, adding additional +datatypes, support for vector operands, and numerous minor enhancements. +.endhelp --------------------------------------------------------------------- + +define YYMAXDEPTH 64 # parser stack length +define MAX_ARGS 17 # max args in a function call +define yyparse xvv_parse + +# Arglist structure. +define LEN_ARGSTRUCT (1+MAX_ARGS+(MAX_ARGS*LEN_OPERAND)) +define A_NARGS Memi[$1] # number of arguments +define A_ARGP Memi[$1+$2] # array of pointers to operand structs +define A_OPS ($1+MAX_ARGS+1) # offset to operand storage area + +# Intrinsic functions. + +define LEN_STAB 300 # for symbol table +define LEN_SBUF 256 +define LEN_INDEX 97 + +define LEN_SYM 1 # symbol data +define SYM_CODE Memi[$1] + +define KEYWORDS "|abs|acos|asin|atan|atan2|bool|cos|cosh|deg|double|\ + |exp|hiv|int|len|log|log10|long|lov|max|mean|median|\ + |min|mod|nint|rad|real|repl|stddev|shift|short|sin|\ + |sinh|sort|sqrt|str|sum|tan|tanh|" + +define F_ABS 01 # function codes +define F_ACOS 02 +define F_ASIN 03 +define F_ATAN 04 +define F_ATAN2 05 +define F_BOOL 06 +define F_COS 07 +define F_COSH 08 +define F_DEG 09 # radians to degrees +define F_DOUBLE 10 + # newline 11 +define F_EXP 12 +define F_HIV 13 # high value +define F_INT 14 +define F_LEN 15 # vector length +define F_LOG 16 +define F_LOG10 17 +define F_LONG 18 +define F_LOV 19 # low value +define F_MAX 20 +define F_MEAN 21 +define F_MEDIAN 22 + # newline 23 +define F_MIN 24 +define F_MOD 25 +define F_NINT 26 +define F_RAD 27 # degrees to radians +define F_REAL 28 +define F_REPL 29 # replicate +define F_STDDEV 30 # standard deviation +define F_SHIFT 31 +define F_SHORT 32 +define F_SIN 33 + # newline 34 +define F_SINH 35 +define F_SORT 36 # sort +define F_SQRT 37 # square root +define F_STR 38 +define F_SUM 39 +define F_TAN 40 +define F_TANH 41 + +define T_B TY_BOOL +define T_C TY_CHAR +define T_S TY_SHORT +define T_I TY_INT +define T_L TY_LONG +define T_R TY_REAL +define T_D TY_DOUBLE + + +# EVVEXPR -- Evaluate a general mixed type vector expression. Input consists +# of the expression to be evaluated (a string) and, optionally, user +# procedures for fetching external operands and executing external functions. +# Output is a pointer to an operand structure containing the computed value of +# the expression. The output operand structure is dynamically allocated by +# EVVEXPR and must be freed by the user. +# +# NOTE: this is not intended to be an especially efficient procedure. Rather, +# this is a high level, easy to use procedure, intended to provide greater +# flexibility in the parameterization of applications programs. The main +# inefficiency is that, since compilation and execution are not broken out as +# separate steps, when the routine is repeatedly called to evaluate the same +# expression with different data, all the compile time computation (parsing +# etc.) has to be repeated. + +pointer procedure evvexpr (expr, getop, getop_data, ufcn, ufcn_data, flags) + +char expr[ARB] #I expression to be evaluated +int getop #I user supplied get operand procedure +int getop_data #I client data for above function +int ufcn #I user supplied function call procedure +int ufcn_data #I client data for above function +int flags #I flag bits + +int junk +pointer sp, ip +bool debug, first_time +int strlen(), xvv_parse() +pointer xvv_loadsymbols() +extern xvv_gettok() + +errchk xvv_parse, calloc +include "evvexpr.com" +data debug /false/ +data first_time /true/ + +begin + call smark (sp) + + if (first_time) { + # This creates data which remains for the life of the process. + ev_st = xvv_loadsymbols (KEYWORDS) + first_time = false + } + + # Set user function entry point addresses. + ev_getop = getop + ev_getop_data = getop_data + ev_ufcn = ufcn + ev_ufcn_data = ufcn_data + ev_flags = flags + + # Allocate an operand struct for the expression value. + call calloc (ev_oval, LEN_OPERAND, TY_STRUCT) + + # Make a local copy of the input string. + call salloc (ip, strlen(expr), TY_CHAR) + call strcpy (expr, Memc[ip], ARB) + + # Evaluate the expression. The expression value is copied into the + # output operand structure by XVV_PARSE, given the operand pointer + # passed in common. A common must be used since the standard parser + # subroutine has a fixed calling sequence. + + junk = xvv_parse (ip, debug, xvv_gettok) + O_FLAGS(ev_oval) = or (O_FLAGS(ev_oval), O_FREEOP) + + call sfree (sp) + return (ev_oval) +end + + +# EVVFREE -- Free an operand struct such as is returned by EVVEXPR. + +procedure evvfree (o) + +pointer o # operand struct + +begin + call xvv_freeop (o) +end + +%L +# XVV_PARSE -- SPP/Yacc parser for the evaluation of an expression passed as +# a text string. Expression evaluation is carried out as the expression is +# parsed, rather than being broken into separate compile and execute stages. +# There is only one statement in this grammar, the expression. Our function +# is to reduce an expression to a single value of type bool, string, int, +# or real. + +pointer ap +bool streq() +errchk zcall3, xvv_error1, xvv_unop, xvv_binop, xvv_boolop +errchk xvv_quest, xvv_callfcn, xvv_addarg +include "evvexpr.com" + +%} + +# The $/ following causes the generic preprocessor to pass this block of code +# through unchanged. + +$/ + +%token CONSTANT IDENTIFIER NEWLINE YYEOS +%token PLUS MINUS STAR SLASH EXPON CONCAT QUEST COLON +%token LT GT LE GT EQ NE SE LAND LOR LNOT BAND BOR BXOR BNOT AT + +%nonassoc QUEST +%left LAND LOR +%left BAND BOR BXOR +%nonassoc EQ NE SE +%nonassoc LT GT LE GE +%left CONCAT +%left PLUS MINUS +%left STAR SLASH +%right UMINUS LNOT BNOT +%left EXPON +%right AT + +%% + +stmt : exprlist YYEOS { + # Normal exit. Move the final expression value operand + # into the operand structure pointed to by the global + # variable ev_oval. + + YYMOVE ($1, ev_oval) + call sfree (yysp) + return (OK) + } + | error { + call error (1, "syntax error") + } + ; + +exprlist: expr { + YYMOVE ($1, $$) + } + | exprlist ',' opnl expr { + YYMOVE ($4, $$) + call xvv_freeop ($1) + } + + +expr : CONSTANT { + # Numeric constant. + YYMOVE ($1, $$) + } + | IDENTIFIER { + # The boolean constants "yes" and "no" are implemented + # as reserved operands. + + call xvv_initop ($$, 0, TY_BOOL) + if (streq (O_VALC($1), "yes")) { + O_VALI($$) = YES + } else if (streq (O_VALC($1), "no")) { + O_VALI($$) = NO + } else if (ev_getop != NULL) { + call zcall3 (ev_getop,ev_getop_data, O_VALC($1), $$) + if (O_TYPE($$) <= 0) + call xvv_error1 ("unknown operand `%s'", + O_VALC($1)) + } else + call xvv_error1 ("illegal operand `%s'", O_VALC($1)) + call xvv_freeop ($1) + } + | AT CONSTANT { + # e.g., @"param" + if (ev_getop != NULL) { + call zcall3 (ev_getop,ev_getop_data, O_VALC($2), $$) + if (O_TYPE($$) <= 0) + call xvv_error1 ("unknown operand `%s'", + O_VALC($1)) + } else + call xvv_error1 ("illegal operand `%s'", O_VALC($2)) + call xvv_freeop ($2) + } + | MINUS expr %prec UMINUS { + # Unary arithmetic minus. + call xvv_unop (MINUS, $2, $$) + } + | LNOT expr { + # Logical not. + call xvv_unop (LNOT, $2, $$) + } + | BNOT expr { + # Boolean not. + call xvv_unop (BNOT, $2, $$) + } + | expr PLUS opnl expr { + # Addition. + call xvv_binop (PLUS, $1, $4, $$) + } + | expr MINUS opnl expr { + # Subtraction. + call xvv_binop (MINUS, $1, $4, $$) + } + | expr STAR opnl expr { + # Multiplication. + call xvv_binop (STAR, $1, $4, $$) + } + | expr SLASH opnl expr { + # Division. + call xvv_binop (SLASH, $1, $4, $$) + } + | expr EXPON opnl expr { + # Exponentiation. + call xvv_binop (EXPON, $1, $4, $$) + } + | expr CONCAT opnl expr { + # Concatenate two operands. + call xvv_binop (CONCAT, $1, $4, $$) + } + | expr LAND opnl expr { + # Logical and. + call xvv_boolop (LAND, $1, $4, $$) + } + | expr LOR opnl expr { + # Logical or. + call xvv_boolop (LOR, $1, $4, $$) + } + | expr BAND opnl expr { + # Boolean and. + call xvv_binop (BAND, $1, $4, $$) + } + | expr BOR opnl expr { + # Boolean or. + call xvv_binop (BOR, $1, $4, $$) + } + | expr BXOR opnl expr { + # Boolean xor. + call xvv_binop (BXOR, $1, $4, $$) + } + | expr LT opnl expr { + # Boolean less than. + call xvv_boolop (LT, $1, $4, $$) + } + | expr GT opnl expr { + # Boolean greater than. + call xvv_boolop (GT, $1, $4, $$) + } + | expr LE opnl expr { + # Boolean less than or equal. + call xvv_boolop (LE, $1, $4, $$) + } + | expr GE opnl expr { + # Boolean greater than or equal. + call xvv_boolop (GE, $1, $4, $$) + } + | expr EQ opnl expr { + # Boolean equal. + call xvv_boolop (EQ, $1, $4, $$) + } + | expr SE opnl expr { + # String pattern-equal. + call xvv_boolop (SE, $1, $4, $$) + } + | expr NE opnl expr { + # Boolean not equal. + call xvv_boolop (NE, $1, $4, $$) + } + | expr QUEST opnl expr COLON opnl expr { + # Conditional expression. + call xvv_quest ($1, $4, $7, $$) + } + | funct '(' arglist ')' { + # Call an intrinsic or external function. + ap = O_VALP($3) + call xvv_callfcn (O_VALC($1), + A_ARGP(ap,1), A_NARGS(ap), $$) + call xvv_freeop ($1) + call xvv_freeop ($3) + } + | '(' expr ')' { + YYMOVE ($2, $$) + } + ; + + +funct : IDENTIFIER { + YYMOVE ($1, $$) + } + | CONSTANT { + if (O_TYPE($1) != TY_CHAR) + call error (1, "illegal function name") + YYMOVE ($1, $$) + } + ; + + +arglist : { + # Empty. + call xvv_startarglist (NULL, $$) + } + | expr { + # First arg; start a nonnull list. + call xvv_startarglist ($1, $$) + } + | arglist ',' opnl expr { + # Add an argument to an existing list. + call xvv_addarg ($4, $1, $$) + } + ; + + +opnl : # Empty. + | opnl NEWLINE + ; + +%% + +# End generic preprocessor escape. +/ + + +# XVV_UNOP -- Unary operation. Perform the indicated unary operation on the +# input operand, returning the result as the output operand. + +procedure xvv_unop (opcode, in, out) + +int opcode #I operation to be performed +pointer in #I input operand +pointer out #I output operand + +short val_s +long val_l +int val_i, nelem +errchk xvv_error, xvv_initop +string s_badswitch "unop: bad switch" + +begin + nelem = O_LEN(in) + + switch (opcode) { + case MINUS: + # Unary negation. + call xvv_initop (out, nelem, O_TYPE(in)) + switch (O_TYPE(in)) { + case TY_BOOL, TY_CHAR: + call xvv_error ("negation of a nonarithmetic operand") +$for (silrd) + case TY_PIXEL: + if (nelem > 0) + call aneg$t (Mem$t[O_VALP(in)], Mem$t[O_VALP(out)], nelem) + else + O_VAL$T(out) = -O_VAL$T(in) +$endfor + default: + call xvv_error (s_badswitch) + } + + case LNOT: + # Logical NOT. + + call xvv_initop (out, nelem, TY_BOOL) + switch (O_TYPE(in)) { + case TY_BOOL: + if (nelem > 0) + call abeqki (Memi[O_VALP(in)], NO, Memi[O_VALP(out)], nelem) + else { + if (O_VALI(in) == NO) + O_VALI(out) = YES + else + O_VALI(out) = NO + } +$for (sil) + case TY_PIXEL: + if (nelem > 0) { + val_$t = NO + call abeqk$t (Mem$t[O_VALP(in)], val_$t, Memi[O_VALP(out)], + nelem) + } else { + if (O_VAL$T(in) == NO) + O_VAL$T(out) = YES + else + O_VAL$T(out) = NO + } +$endfor + case TY_CHAR, TY_REAL, TY_DOUBLE: + call xvv_error ("not of a nonlogical") + default: + call xvv_error (s_badswitch) + } + + case BNOT: + # Bitwise boolean NOT. + + call xvv_initop (out, nelem, O_TYPE(in)) + switch (O_TYPE(in)) { + case TY_BOOL, TY_CHAR, TY_REAL, TY_DOUBLE: + call xvv_error ("boolean not of a noninteger operand") +$for (sil) + case TY_PIXEL: + if (nelem > 0) + call anot$t (Mem$t[O_VALP(in)], Mem$t[O_VALP(out)], nelem) + else + O_VAL$T(out) = not(O_VAL$T(in)) +$endfor + default: + call xvv_error (s_badswitch) + } + + default: + call xvv_error (s_badswitch) + } + + call xvv_freeop (in) +end + + +# XVV_BINOP -- Binary operation. Perform the indicated arithmetic binary +# operation on the two input operands, returning the result as the output +# operand. + +procedure xvv_binop (opcode, in1, in2, out) + +int opcode #I operation to be performed +pointer in1, in2 #I input operands +pointer out #I output operand + +$for (silrd) +PIXEL v_$t +PIXEL xvv_null$t() +extern xvv_null$t() +$endfor +pointer sp, otemp, p1, p2, po +int dtype, nelem, len1, len2 +include "evvexpr.com" + +int xvv_newtype(), strlen() +errchk xvv_newtype, xvv_initop, xvv_chtype, xvv_error +string s_badswitch "binop: bad case in switch" +string s_boolop "binop: bitwise boolean operands must be an integer type" +define done_ 91 + +begin + # Set the datatype of the output operand, taking an error action if + # the operands have incompatible datatypes. + + dtype = xvv_newtype (O_TYPE(in1), O_TYPE(in2)) + + # Compute the size of the output operand. If both input operands are + # vectors the length of the output vector is the shorter of the two. + + switch (dtype) { + case TY_BOOL: + call xvv_error ("binop: operation illegal for boolean operands") + case TY_CHAR: + nelem = strlen (O_VALC(in1)) + strlen (O_VALC(in2)) + default: + if (opcode == CONCAT) + nelem = max (1, O_LEN(in1)) + max (1, O_LEN(in2)) + else { + if (O_LEN(in1) > 0 && O_LEN(in2) > 0) + nelem = min (O_LEN(in1), O_LEN(in2)) + else if (O_LEN(in1) > 0) + nelem = O_LEN(in1) + else if (O_LEN(in2) > 0) + nelem = O_LEN(in2) + else + nelem = 0 + } + } + + # Convert input operands to desired type. + if (O_TYPE(in1) != dtype) + call xvv_chtype (in1, in1, dtype) + if (O_TYPE(in2) != dtype) + call xvv_chtype (in2, in2, dtype) + + # If this is a scalar/vector operation make sure the vector is the + # first operand. + + len1 = O_LEN(in1) + len2 = O_LEN(in2) + + if (len1 == 0 && len2 > 0) { + switch (opcode) { + case PLUS: + # Swap operands. + call smark (sp) + call salloc (otemp, LEN_OPERAND, TY_STRUCT) + YYMOVE (in1, otemp) + YYMOVE (in2, in1) + YYMOVE (otemp, in2) + call sfree (sp) + + case CONCAT: + ; # Do nothing + + default: + # Promote operand to a constant vector. Inefficient, but + # better than aborting. + + switch (dtype) { + $for (silrd) + case TY_PIXEL: + v_$t = O_VAL$T(in1) + call xvv_initop (in1, nelem, dtype) + call amovk$t (v_$t, Mem$t[O_VALP(in1)], nelem) + $endfor + } + } + + len1 = O_LEN(in1) + len2 = O_LEN(in2) + } + + # Initialize the output operand. + call xvv_initop (out, nelem, dtype) + + p1 = O_VALP(in1) + p2 = O_VALP(in2) + po = O_VALP(out) + + # The bitwise boolean binary operators a special case since only the + # integer datatypes are permitted. Otherwise the bitwise booleans + # are just like arithmetic booleans. + + if (opcode == BAND || opcode == BOR || opcode == BXOR) { + switch (dtype) { +$for (sil) + case TY_PIXEL: + switch (opcode) { + case BAND: + if (len1 <= 0) { + O_VAL$T(out) = and (O_VAL$T(in1), O_VAL$T(in2)) + } else if (len2 <= 0) { + call aandk$t (Mem$t[p1], O_VAL$T(in2), + Mem$t[po], nelem) + } else { + call aand$t (Mem$t[p1], Mem$t[p2], + Mem$t[po], nelem) + } + case BOR: + if (len1 <= 0) { + O_VAL$T(out) = or (O_VAL$T(in1), O_VAL$T(in2)) + } else if (len2 <= 0) { + call abork$t (Mem$t[p1], O_VAL$T(in2), + Mem$t[po], nelem) + } else { + call abor$t (Mem$t[p1], Mem$t[p2], + Mem$t[po], nelem) + } + case BXOR: + if (len1 <= 0) { + O_VAL$T(out) = xor (O_VAL$T(in1), O_VAL$T(in2)) + } else if (len2 <= 0) { + call axork$t (Mem$t[p1], O_VAL$T(in2), + Mem$t[po], nelem) + } else { + call axor$t (Mem$t[p1], Mem$t[p2], + Mem$t[po], nelem) + } + } +$endfor + default: + call xvv_error (s_boolop) + } + + goto done_ + } + + # Perform an arithmetic binary operation. + switch (dtype) { + case TY_CHAR: + switch (opcode) { + case CONCAT: + call strcpy (O_VALC(in1), O_VALC(out), ARB) + call strcat (O_VALC(in2), O_VALC(out), ARB) + default: + call xvv_error ("binop: operation illegal for string operands") + } +$for (silrd) + case TY_PIXEL: + switch (opcode) { + case PLUS: + if (len1 <= 0) { + O_VAL$T(out) = O_VAL$T(in1) + O_VAL$T(in2) + } else if (len2 <= 0) { + call aaddk$t (Mem$t[p1], O_VAL$T(in2), + Mem$t[po], nelem) + } else { + call aadd$t (Mem$t[p1], Mem$t[p2], + Mem$t[po], nelem) + } + case MINUS: + if (len1 <= 0) + O_VAL$T(out) = O_VAL$T(in1) - O_VAL$T(in2) + else if (len2 <= 0) + call asubk$t (Mem$t[p1], O_VAL$T(in2), Mem$t[po], nelem) + else + call asub$t (Mem$t[p1], Mem$t[p2], Mem$t[po], nelem) + + case STAR: + if (len1 <= 0) + O_VAL$T(out) = O_VAL$T(in1) * O_VAL$T(in2) + else if (len2 <= 0) + call amulk$t (Mem$t[p1], O_VAL$T(in2), Mem$t[po], nelem) + else + call amul$t (Mem$t[p1], Mem$t[p2], Mem$t[po], nelem) + + case SLASH: + if (and (ev_flags, EV_RNGCHK) == 0) { + # No range checking. + if (len1 <= 0) + O_VAL$T(out) = O_VAL$T(in1) / O_VAL$T(in2) + else if (len2 <= 0) + call adivk$t (Mem$t[p1], O_VAL$T(in2), Mem$t[po], nelem) + else + call adiv$t (Mem$t[p1], Mem$t[p2], Mem$t[po], nelem) + } else { + # Check for divide by zero. + if (len1 <= 0) { + if (O_VAL$T(in2) == 0$f) + O_VAL$T(out) = xvv_null$t(0$f) + else + O_VAL$T(out) = O_VAL$T(in1) / O_VAL$T(in2) + } else if (len2 <= 0) { + if (O_VAL$T(in2) == 0$f) + call amovk$t (xvv_null$t(0$f), Mem$t[po], nelem) + else { + call adivk$t (Mem$t[p1], O_VAL$T(in2), Mem$t[po], + nelem) + } + } else { + call advz$t (Mem$t[p1], Mem$t[p2], Mem$t[po], nelem, + xvv_null$t) + } + } + case EXPON: + if (len1 <= 0) + O_VAL$T(out) = O_VAL$T(in1) ** O_VAL$T(in2) + else if (len2 <= 0) + call aexpk$t (Mem$t[p1], O_VAL$T(in2), Mem$t[po], nelem) + else + call aexp$t (Mem$t[p1], Mem$t[p2], Mem$t[po], nelem) + + case CONCAT: + # Concatenate two numeric operands. + if (len1 <= 0) { + Mem$t[po] = O_VAL$T(in1) + po = po + 1 + } else { + call amov$t (Mem$t[p1], Mem$t[po], len1) + po = po + len1 + } + if (len2 <= 0) + Mem$t[po] = O_VAL$T(in2) + else + call amov$t (Mem$t[p2], Mem$t[po], len2) + + default: + call xvv_error (s_badswitch) + } +$endfor + default: + call xvv_error (s_badswitch) + } +done_ + # Free any storage in input operands. + call xvv_freeop (in1) + call xvv_freeop (in2) +end + + +# XVV_BOOLOP -- Boolean (actually logical) binary operations. Perform the +# indicated logical operation on the two input operands, returning the result +# as the output operand. The opcodes implemented by this routine are +# characterized by the fact that they all return a logical result (YES or NO +# physically expressed as an integer). + +procedure xvv_boolop (opcode, in1, in2, out) + +int opcode #I operation to be performed +pointer in1, in2 #I input operands +pointer out #I output operand + +$for (silrd) +PIXEL v_$t +$endfor +pointer sp, otemp, p1, p2, po +int dtype, nelem, len1, len2 +int xvv_newtype(), xvv_patmatch(), strncmp(), btoi() +errchk xvv_newtype, xvv_initop, xvv_chtype, xvv_error +string s_badop "boolop: illegal operation" +string s_badswitch "boolop: illegal switch" + +begin + # Boolean operands are treated as integer within this routine. + if (O_TYPE(in1) == TY_BOOL) + O_TYPE(in1) = TY_INT + if (O_TYPE(in2) == TY_BOOL) + O_TYPE(in2) = TY_INT + + # Determine the computation type for the operation, i.e., the type + # both input operands must have. This is not the same as the type + # of the output operand, which is always boolean for the operations + # implemented by this routine. + + dtype = xvv_newtype (O_TYPE(in1), O_TYPE(in2)) + + # Compute the size of the output operand. If both input operands are + # vectors the length of the output vector is the shorter of the two. + + if (dtype == TY_CHAR) + nelem = 0 + else { + if (O_LEN(in1) > 0 && O_LEN(in2) > 0) + nelem = min (O_LEN(in1), O_LEN(in2)) + else if (O_LEN(in1) > 0) + nelem = O_LEN(in1) + else if (O_LEN(in2) > 0) + nelem = O_LEN(in2) + else + nelem = 0 + } + + # Convert input operands to desired computation type. + if (O_TYPE(in1) != dtype) + call xvv_chtype (in1, in1, dtype) + if (O_TYPE(in2) != dtype) + call xvv_chtype (in2, in2, dtype) + + # If this is a scalar/vector operation make sure the vector is the + # first operand. + + len1 = O_LEN(in1) + len2 = O_LEN(in2) + + if (len1 == 0 && len2 > 0) { + switch (opcode) { + case EQ, NE: + call smark (sp) + call salloc (otemp, LEN_OPERAND, TY_STRUCT) + YYMOVE (in1, otemp) + YYMOVE (in2, in1) + YYMOVE (otemp, in2) + call sfree (sp) + default: + # Promote operand to a constant vector. Inefficient, but + # better than aborting. + + switch (dtype) { + $for (silrd) + case TY_PIXEL: + v_$t = O_VAL$T(in1) + call xvv_initop (in1, nelem, dtype) + call amovk$t (v_$t, Mem$t[O_VALP(in1)], nelem) + $endfor + } + } + + len1 = O_LEN(in1) + len2 = O_LEN(in2) + } + + # Initialize the output operand. + call xvv_initop (out, nelem, TY_BOOL) + + p1 = O_VALP(in1) + p2 = O_VALP(in2) + po = O_VALP(out) + + # Perform the operation. + if (dtype == TY_CHAR) { + # Character data is a special case. + + switch (opcode) { + case SE: + O_VALI(out) = btoi(xvv_patmatch (O_VALC(in1), O_VALC(in2)) > 0) + case LT: + O_VALI(out) = btoi(strncmp (O_VALC(in1), O_VALC(in2), ARB) < 0) + case LE: + O_VALI(out) = btoi(strncmp (O_VALC(in1), O_VALC(in2), ARB) <= 0) + case GT: + O_VALI(out) = btoi(strncmp (O_VALC(in1), O_VALC(in2), ARB) > 0) + case GE: + O_VALI(out) = btoi(strncmp (O_VALC(in1), O_VALC(in2), ARB) >= 0) + case EQ: + O_VALI(out) = btoi(strncmp (O_VALC(in1), O_VALC(in2), ARB) == 0) + case NE: + O_VALI(out) = btoi(strncmp (O_VALC(in1), O_VALC(in2), ARB) != 0) + default: + call xvv_error (s_badop) + } + + } else if (opcode == LAND || opcode == LOR) { + # Operations supporting only the integer types. + + switch (dtype) { +$for (sil) + case TY_PIXEL: + switch (opcode) { + case LAND: + if (len1 <= 0) { + O_VALI(out) = + btoi (O_VAL$T(in1) != 0 && O_VAL$T(in2) != 0) + } else if (len2 <= 0) { + call alank$t (Mem$t[p1], O_VAL$T(in2), Memi[po], nelem) + } else + call alan$t (Mem$t[p1], Mem$t[p2], Memi[po], nelem) + case LOR: + if (len1 <= 0) { + O_VALI(out) = + btoi (O_VAL$T(in1) != 0 || O_VAL$T(in2) != 0) + } else if (len2 <= 0) { + call alork$t (Mem$t[p1], O_VAL$T(in2), Memi[po], nelem) + } else + call alor$t (Mem$t[p1], Mem$t[p2], Memi[po], nelem) + default: + call xvv_error (s_badop) + } +$endfor + default: + call xvv_error (s_badswitch) + } + } else { + # Operations supporting any arithmetic type. + + switch (dtype) { +$for (silrd) + case TY_PIXEL: + switch (opcode) { + case LT: + if (len1 <= 0) + O_VALI(out) = btoi (O_VAL$T(in1) < O_VAL$T(in2)) + else if (len2 <= 0) + call abltk$t (Mem$t[p1], O_VAL$T(in2), Memi[po], nelem) + else + call ablt$t (Mem$t[p1], Mem$t[p2], Memi[po], nelem) + + case LE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VAL$T(in1) <= O_VAL$T(in2)) + else if (len2 <= 0) + call ablek$t (Mem$t[p1], O_VAL$T(in2), Memi[po], nelem) + else + call able$t (Mem$t[p1], Mem$t[p2], Memi[po], nelem) + + case GT: + if (len1 <= 0) + O_VALI(out) = btoi (O_VAL$T(in1) > O_VAL$T(in2)) + else if (len2 <= 0) + call abgtk$t (Mem$t[p1], O_VAL$T(in2), Memi[po], nelem) + else + call abgt$t (Mem$t[p1], Mem$t[p2], Memi[po], nelem) + + case GE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VAL$T(in1) >= O_VAL$T(in2)) + else if (len2 <= 0) + call abgek$t (Mem$t[p1], O_VAL$T(in2), Memi[po], nelem) + else + call abge$t (Mem$t[p1], Mem$t[p2], Memi[po], nelem) + + case EQ: + if (len1 <= 0) + O_VALI(out) = btoi (O_VAL$T(in1) == O_VAL$T(in2)) + else if (len2 <= 0) + call abeqk$t (Mem$t[p1], O_VAL$T(in2), Memi[po], nelem) + else + call abeq$t (Mem$t[p1], Mem$t[p2], Memi[po], nelem) + + case NE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VAL$T(in1) != O_VAL$T(in2)) + else if (len2 <= 0) + call abnek$t (Mem$t[p1], O_VAL$T(in2), Memi[po], nelem) + else + call abne$t (Mem$t[p1], Mem$t[p2], Memi[po], nelem) + + default: + call xvv_error (s_badop) + } +$endfor + default: + call xvv_error (s_badswitch) + } + } + + # Free any storage in input operands. + call xvv_freeop (in1) + call xvv_freeop (in2) +end + + +# XVV_PATMATCH -- Match a string against a pattern, returning the patmatch +# index if the string matches. The pattern may contain any of the conventional +# pattern matching metacharacters. Closure (i.e., "*") is mapped to "?*". + +int procedure xvv_patmatch (str, pat) + +char str[ARB] #I operand string +char pat[ARB] #I pattern + +int junk, ip, index +pointer sp, patstr, patbuf, op +int patmake(), patmatch() + +begin + call smark (sp) + call salloc (patstr, SZ_FNAME, TY_CHAR) + call salloc (patbuf, SZ_LINE, TY_CHAR) + call aclrc (Memc[patstr], SZ_FNAME) + call aclrc (Memc[patbuf], SZ_LINE) + + # Map pattern, changing '*' into '?*'. + op = patstr + for (ip=1; pat[ip] != EOS; ip=ip+1) { + if (pat[ip] == '*') { + Memc[op] = '?' + op = op + 1 + } + Memc[op] = pat[ip] + op = op + 1 + } + + # Encode pattern. + junk = patmake (Memc[patstr], Memc[patbuf], SZ_LINE) + + # Perform the pattern matching operation. + index = patmatch (str, Memc[patbuf]) + + call sfree (sp) + return (index) +end + + +# XVV_NEWTYPE -- Get the datatype of a binary operation, given the datatypes +# of the two input operands. An error action is taken if the datatypes are +# incompatible, e.g., boolean and anything else or string and anything else. + +int procedure xvv_newtype (type1, type2) + +int type1 #I datatype of first operand +int type2 #I datatype of second operand + +int newtype, p, q, i +int tyindex[NTYPES], ttbl[NTYPES*NTYPES] +data tyindex /T_B, T_C, T_S, T_I, T_L, T_R, T_D/ + +data (ttbl(i),i= 1, 7) /T_B, 0, 0, 0, 0, 0, 0/ +data (ttbl(i),i= 8,14) / 0, T_C, 0, 0, 0, 0, 0/ +data (ttbl(i),i=15,21) / 0, 0, T_S, T_I, T_L, T_R, T_D/ +data (ttbl(i),i=22,28) / 0, 0, T_I, T_I, T_L, T_R, T_D/ +data (ttbl(i),i=29,35) / 0, 0, T_L, T_L, T_L, T_R, T_D/ +data (ttbl(i),i=36,42) / 0, 0, T_R, T_R, T_R, T_R, T_D/ +data (ttbl(i),i=43,49) / 0, 0, T_D, T_D, T_D, T_D, T_D/ + +begin + do i = 1, NTYPES { + if (tyindex[i] == type1) + p = i + if (tyindex[i] == type2) + q = i + } + + newtype = ttbl[(p-1)*NTYPES+q] + if (newtype == 0) + call xvv_error ("operands have incompatible types") + else + return (newtype) +end + + +# XVV_QUEST -- Conditional expression. If the condition operand is true +# return the first (true) operand, else return the second (false) operand. + +procedure xvv_quest (cond, in1, in2, out) + +pointer cond #I pointer to condition operand +pointer in1, in2 #I pointer to true,false operands +pointer out #I pointer to output operand + +int dtype, nelem, i +pointer sp, otemp, ip1, ip2, op, sel +errchk xvv_error, xvv_newtype, xvv_initop, xvv_chtype +int xvv_newtype(), btoi() + +begin + switch (O_TYPE(cond)) { + case TY_BOOL, TY_INT: + ; + case TY_SHORT, TY_LONG: + call xvv_chtype (cond, cond, TY_BOOL) + default: + call xvv_error ("evvexpr: nonboolean condition operand") + } + + if (O_LEN(cond) <= 0 && + (O_LEN(in1) <= 0 || O_TYPE(in1) == TY_CHAR) && + (O_LEN(in2) <= 0 || O_TYPE(in2) == TY_CHAR)) { + + # Both operands and the conditional are scalars; the expression + # type is the type of the selected operand. + + if (O_VALI(cond) != 0) { + YYMOVE (in1, out) + call xvv_freeop (in2) + } else { + YYMOVE (in2, out) + call xvv_freeop (in1) + } + + } else if (O_TYPE(in1) == TY_CHAR || O_TYPE(in2) == TY_CHAR) { + # This combination is not legal. + call xvv_error ("evvexpr: character and vector in cond expr") + + } else { + # Vector/scalar or vector/vector operation. Both operands must + # be of the same type. + + dtype = xvv_newtype (O_TYPE(in1), O_TYPE(in2)) + + # Compute the size of the output operand. If both input operands + # are vectors the length of the output vector is the shorter of + # the two. The condition operand contributes to the dimension of + # the expression result, although not to the datatype. + + nelem = 0 + if (O_LEN(in1) > 0 && O_LEN(in2) > 0) + nelem = min (O_LEN(in1), O_LEN(in2)) + else if (O_LEN(in1) > 0) + nelem = O_LEN(in1) + else if (O_LEN(in2) > 0) + nelem = O_LEN(in2) + + if (O_LEN(cond) > 0 && nelem > 0) + nelem = min (O_LEN(cond), nelem) + else if (O_LEN(cond) > 0) + nelem = O_LEN(cond) + + # If this is a scalar/vector operation make sure the vector is the + # first operand. + + if (O_LEN(in1) == 0 && O_LEN(in2) > 0) { + call smark (sp) + call salloc (otemp, LEN_OPERAND, TY_STRUCT) + YYMOVE (in1, otemp) + YYMOVE (in2, in1) + YYMOVE (otemp, in2) + call sfree (sp) + + # Since we are swapping arguments we need to negate the cond. + if (O_LEN(cond) <= 0) + O_VALI(cond) = btoi (O_VALI(cond) == 0) + else { + call abeqki (Memi[O_VALP(cond)], NO, Memi[O_VALP(cond)], + nelem) + } + } + + # Initialize the output operand. + call xvv_initop (out, nelem, dtype) + + # Convert input operands to desired computation type. + if (O_TYPE(in1) != dtype) + call xvv_chtype (in1, in1, dtype) + if (O_TYPE(in2) != dtype) + call xvv_chtype (in2, in2, dtype) + + ip1 = O_VALP(in1) + ip2 = O_VALP(in2) + op = O_VALP(out) + sel = O_VALP(cond) + + # Perform the operation. + switch (dtype) { + $for (silrd) + case TY_PIXEL: + if (O_LEN(in1) <= 0 && O_LEN(in2) <= 0) { + # Vector conditional, both operands are scalars. + do i = 1, nelem + if (Memi[sel+i-1] != 0) + Mem$t[op+i-1] = O_VAL$T(in1) + else + Mem$t[op+i-1] = O_VAL$T(in2) + + } else if (O_LEN(in2) <= 0) { + # Operand 1 is a vector, operand 2 is a scalar. + if (O_LEN(cond) <= 0) { + # Conditional is a scalar. + if (O_VALI(cond) != 0) + call amov$t (Mem$t[ip1], Mem$t[op], nelem) + else + call amovk$t (O_VAL$T(in2), Mem$t[op], nelem) + } else { + # Conditional is a vector. + call aselk$t (Mem$t[ip1], O_VAL$T(in2), Mem$t[op], + Memi[sel], nelem) + } + } else { + # Both operands are vectors. + if (O_LEN(cond) <= 0) { + # Conditional is a scalar. + if (O_VALI(cond) != 0) + call amov$t (Mem$t[ip1], Mem$t[op], nelem) + else + call amov$t (Mem$t[ip2], Mem$t[op], nelem) + } else { + # Conditional is a vector. + call asel$t (Mem$t[ip1], Mem$t[ip2], Mem$t[op], + Memi[sel], nelem) + } + } + $endfor + default: + call xvv_error ("evvexpr: bad datatype in cond expr") + } + + call xvv_freeop (in1) + call xvv_freeop (in2) + } + + call xvv_freeop (cond) +end + + +# XVV_CALLFCN -- Call an intrinsic function. If the function named is not +# one of the standard intrinsic functions, call an external user function +# if a function call procedure was supplied. + +procedure xvv_callfcn (fcn, args, nargs, out) + +char fcn[ARB] #I function to be called +pointer args[ARB] #I pointer to arglist descriptor +int nargs #I number of arguments +pointer out #I output operand (function value) + +$for (silrd) +PIXEL v_$t +PIXEL ahiv$t(), alov$t() +PIXEL amed$t() +int arav$t() +$endfor + +real mean_r, sigma_r +double mean_d, sigma_d +real asums(), asumi(), asumr() +double asuml(), asumd() + +bool rangecheck +int optype, opcode +int chunk, repl, nelem, v_nargs, ch, shift, i, j +pointer sp, sym, buf, ap, ip, op, in1, in2 +include "evvexpr.com" + +pointer stfind() +int xvv_newtype(), strlen(), gctod(), btoi() +errchk xvv_chtype, xvv_initop, xvv_newtype, xvv_error1, xvv_error2 +errchk zcall5, malloc + +string s_badtype "%s: illegal operand type" +define free_ 91 + +begin + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + + # Lookup the function name in the symbol table. + sym = stfind (ev_st, fcn) + if (sym != NULL) + opcode = SYM_CODE(sym) + else + opcode = 0 + + # If the function named is not a standard one and the user has supplied + # the entry point of an external function evaluation procedure, call + # the user procedure to evaluate the function, otherwise abort. + + if (opcode <= 0) + if (ev_ufcn != NULL) { + call zcall5 (ev_ufcn, ev_ufcn_data, fcn, args, nargs, out) + if (O_TYPE(out) <= 0) + call xvv_error1 ("unrecognized macro or function `%s'", fcn) + goto free_ + } else + call xvv_error1 ("unknown function `%s' called", fcn) + + # Range checking on functions that need it? + rangecheck = (and (ev_flags, EV_RNGCHK) != 0) + + # Verify correct number of arguments. + switch (opcode) { + case F_MOD, F_REPL, F_SHIFT: + v_nargs = 2 + case F_MAX, F_MIN, F_ATAN, F_ATAN2, F_MEAN, F_STDDEV, F_MEDIAN: + v_nargs = -1 + default: + v_nargs = 1 + } + if (v_nargs > 0 && nargs != v_nargs) + call xvv_error2 ("function `%s' requires %d arguments", + fcn, v_nargs) + else if (v_nargs < 0 && nargs < abs(v_nargs)) + call xvv_error2 ("function `%s' requires at least %d arguments", + fcn, abs(v_nargs)) + + # Some functions require that the input operand be a certain type, + # e.g. floating. Handle the simple cases, converting input operands + # to the desired type. + + switch (opcode) { + case F_ACOS, F_ASIN, F_ATAN, F_ATAN2, F_COS, F_COSH, F_DEG, F_EXP, + F_LOG, F_LOG10, F_RAD, F_SIN, F_SINH, F_SQRT, F_TAN, F_TANH: + + # These functions want a floating point input operand. + optype = TY_REAL + do i = 1, nargs { + if (O_TYPE(args[i]) == TY_DOUBLE || O_TYPE(args[i]) == TY_LONG) + optype = TY_DOUBLE + } + do i = 1, nargs { + if (O_TYPE(args[i]) != optype) + call xvv_chtype (args[i], args[i], optype) + } + call xvv_initop (out, O_LEN(args[1]), optype) + + case F_MOD, F_MIN, F_MAX, F_MEDIAN: + # These functions may have multiple arguments, all of which + # should be the same type. + + optype = O_TYPE(args[1]) + nelem = O_LEN(args[1]) + do i = 2, nargs { + optype = xvv_newtype (optype, args[i]) + if (O_LEN(args[i]) > 0) + if (nelem > 0) + nelem = min (nelem, O_LEN(args[i])) + else if (nelem == 0) + nelem = O_LEN(args[i]) + } + + do i = 1, nargs + if (O_TYPE(args[i]) != optype) + call xvv_chtype (args[i], args[i], optype) + + if (nargs == 1 && opcode == F_MEDIAN) + nelem = 0 + call xvv_initop (out, nelem, optype) + + case F_LEN: + # This function always returns an integer scalar value. + nelem = 0 + optype = TY_INT + call xvv_initop (out, nelem, optype) + + case F_HIV, F_LOV: + # These functions return a scalar value. + nelem = 0 + optype = O_TYPE(args[1]) + if (optype == TY_BOOL) + optype = TY_INT + call xvv_initop (out, nelem, optype) + + case F_SUM, F_MEAN, F_STDDEV: + # These functions require a vector argument and return a scalar + # value. + + nelem = 0 + optype = O_TYPE(args[1]) + if (optype == TY_BOOL) + optype = TY_INT + + if (optype == TY_DOUBLE) + call xvv_initop (out, nelem, TY_DOUBLE) + else + call xvv_initop (out, nelem, TY_REAL) + + case F_SORT, F_SHIFT: + # Vector to vector, no type conversions. + nelem = O_LEN(args[1]) + optype = O_TYPE(args[1]) + call xvv_initop (out, nelem, optype) + + default: + optype = 0 + } + + # Evaluate the function. + ap = args[1] + + switch (opcode) { + case F_ABS: + call xvv_initop (out, O_LEN(ap), O_TYPE(ap)) + switch (O_TYPE(ap)) { + $for (silrd) + case TY_PIXEL: + if (O_LEN(ap) > 0) { + call aabs$t (Mem$t[O_VALP(ap)], Mem$t[O_VALP(out)], + O_LEN(ap)) + } else + O_VAL$T(out) = abs(O_VAL$T(ap)) + $endfor + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_ACOS: + $for (rd) + if (optype == TY_PIXEL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Mem$t[O_VALP(out)+i-1] = acos (Mem$t[O_VALP(ap)+i-1]) + } else + O_VAL$T(out) = acos (O_VAL$T(ap)) + $endfor + case F_ASIN: + $for (rd) + if (optype == TY_PIXEL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Mem$t[O_VALP(out)+i-1] = asin (Mem$t[O_VALP(ap)+i-1]) + } else + O_VAL$T(out) = asin (O_VAL$T(ap)) + $endfor + case F_COS: + $for (rd) + if (optype == TY_PIXEL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Mem$t[O_VALP(out)+i-1] = cos (Mem$t[O_VALP(ap)+i-1]) + } else + O_VAL$T(out) = cos (O_VAL$T(ap)) + $endfor + case F_COSH: + $for (rd) + if (optype == TY_PIXEL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Mem$t[O_VALP(out)+i-1] = cosh (Mem$t[O_VALP(ap)+i-1]) + } else + O_VAL$T(out) = cosh (O_VAL$T(ap)) + $endfor + case F_DEG: + $for (rd) + if (optype == TY_PIXEL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Mem$t[O_VALP(out)+i-1] = RADTODEG(Mem$t[O_VALP(ap)+i-1]) + } else + O_VAL$T(out) = RADTODEG (O_VAL$T(ap)) + $endfor + case F_EXP: + $for (rd) + if (optype == TY_PIXEL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Mem$t[O_VALP(out)+i-1] = exp (Mem$t[O_VALP(ap)+i-1]) + } else + O_VAL$T(out) = exp (O_VAL$T(ap)) + $endfor + case F_LOG: + $for (rd) + if (optype == TY_PIXEL) + if (O_LEN(ap) > 0) { + op = O_VALP(out) + do i = 1, O_LEN(ap) { + v_$t = Mem$t[O_VALP(ap)+i-1] + if (rangecheck && v_$t <= 0) + Mem$t[op] = 0 + else + Mem$t[op] = log (v_$t) + op = op + 1 + } + } else { + v_$t = O_VAL$T(ap) + if (rangecheck && v_$t <= 0) + O_VAL$T(out) = 0 + else + O_VAL$T(out) = log (v_$t) + } + $endfor + case F_LOG10: + $for (rd) + if (optype == TY_PIXEL) + if (O_LEN(ap) > 0) { + op = O_VALP(out) + do i = 1, O_LEN(ap) { + v_$t = Mem$t[O_VALP(ap)+i-1] + if (rangecheck && v_$t <= 0) + Mem$t[op] = 0 + else + Mem$t[op] = log10 (v_$t) + op = op + 1 + } + } else { + v_$t = O_VAL$T(ap) + if (rangecheck && v_$t <= 0) + O_VAL$T(out) = 0 + else + O_VAL$T(out) = log10 (v_$t) + } + $endfor + case F_RAD: + $for (rd) + if (optype == TY_PIXEL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Mem$t[O_VALP(out)+i-1] = DEGTORAD(Mem$t[O_VALP(ap)+i-1]) + } else + O_VAL$T(out) = DEGTORAD (O_VAL$T(ap)) + $endfor + case F_SIN: + $for (rd) + if (optype == TY_PIXEL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Mem$t[O_VALP(out)+i-1] = sin (Mem$t[O_VALP(ap)+i-1]) + } else + O_VAL$T(out) = sin (O_VAL$T(ap)) + $endfor + case F_SINH: + $for (rd) + if (optype == TY_PIXEL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Mem$t[O_VALP(out)+i-1] = sinh (Mem$t[O_VALP(ap)+i-1]) + } else + O_VAL$T(out) = sinh (O_VAL$T(ap)) + $endfor + case F_SQRT: + $for (rd) + if (optype == TY_PIXEL) + if (O_LEN(ap) > 0) { + op = O_VALP(out) + do i = 1, O_LEN(ap) { + v_$t = Mem$t[O_VALP(ap)+i-1] + if (rangecheck && v_$t < 0) + Mem$t[op] = 0 + else + Mem$t[op] = sqrt (v_$t) + op = op + 1 + } + } else { + v_$t = O_VAL$T(ap) + if (rangecheck && v_$t <= 0) + O_VAL$T(out) = 0 + else + O_VAL$T(out) = sqrt (v_$t) + } + $endfor + case F_TAN: + $for (rd) + if (optype == TY_PIXEL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Mem$t[O_VALP(out)+i-1] = tan (Mem$t[O_VALP(ap)+i-1]) + } else + O_VAL$T(out) = tan (O_VAL$T(ap)) + $endfor + case F_TANH: + $for (rd) + if (optype == TY_PIXEL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Mem$t[O_VALP(out)+i-1] = tanh (Mem$t[O_VALP(ap)+i-1]) + } else + O_VAL$T(out) = tanh (O_VAL$T(ap)) + $endfor + + case F_LEN: + # Vector length. + O_VALI(out) = O_LEN(ap) + + case F_HIV: + # High value. + switch (optype) { + $for (silrd) + case TY_PIXEL: + if (O_LEN(ap) > 0) + O_VAL$T(out) = ahiv$t (Mem$t[O_VALP(ap)], O_LEN(ap)) + else + O_VAL$T(out) = O_VAL$T(ap) + $endfor + default: + call xvv_error1 (s_badtype, fcn) + } + case F_LOV: + # Low value. + switch (optype) { + $for (silrd) + case TY_PIXEL: + if (O_LEN(ap) > 0) + O_VAL$T(out) = alov$t (Mem$t[O_VALP(ap)], O_LEN(ap)) + else + O_VAL$T(out) = O_VAL$T(ap) + $endfor + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_SUM: + # Vector sum. + switch (optype) { + $for (silr) + case TY_PIXEL: + if (O_LEN(ap) > 0) + v_r = asum$t (Mem$t[O_VALP(ap)], O_LEN(ap)) + else + v_r = O_VAL$T(ap) + $endfor + case TY_DOUBLE: + if (O_LEN(ap) > 0) + v_d = asumd (Memd[O_VALP(ap)], O_LEN(ap)) + else + v_d = O_VALD(ap) + default: + call xvv_error1 (s_badtype, fcn) + } + + if (optype == TY_DOUBLE) + O_VALD(out) = v_d + else + O_VALR(out) = v_r + + case F_MEAN, F_STDDEV: + # Compute the mean or standard deviation of a vector. An optional + # second argument may be supplied to compute a K-sigma rejection + # mean and sigma. + + if (nargs == 2) { + if (O_LEN(args[2]) > 0) + call xvv_error1 ("%s: ksigma arg must be a scalar" , fcn) + + switch (O_TYPE(args[2])) { + case TY_REAL: + v_r = O_VALR(args[2]) + v_d = v_r + case TY_DOUBLE: + v_d = O_VALD(args[2]) + v_r = v_d + default: + call xvv_chtype (args[2], args[2], TY_REAL) + v_r = O_VALR(args[2]) + v_d = v_r + } + } else { + v_r = 0.0 + v_d = 0.0 + } + + switch (optype) { + $for (sir) + case TY_PIXEL: + v_i = arav$t (Mem$t[O_VALP(ap)], O_LEN(ap), mean_r,sigma_r,v_r) + $endfor + $for (ld) + case TY_PIXEL: + v_i = arav$t (Mem$t[O_VALP(ap)], O_LEN(ap), mean_d,sigma_d,v_d) + $endfor + default: + call xvv_error1 (s_badtype, fcn) + } + + if (opcode == F_MEAN) { + if (O_TYPE(out) == TY_REAL) + O_VALR(out) = mean_r + else + O_VALD(out) = mean_d + } else { + if (O_TYPE(out) == TY_REAL) + O_VALR(out) = sigma_r + else + O_VALD(out) = sigma_d + } + + case F_MEDIAN: + # Compute the median value of a vector, or the vector median + # of 3 or more vectors. + + switch (nargs) { + case 1: + switch (optype) { + $for (silrd) + case TY_PIXEL: + O_VAL$T(out) = amed$t (Mem$t[O_VALP(ap)], O_LEN(ap)) + $endfor + default: + call xvv_error1 (s_badtype, fcn) + } + case 3: + switch (optype) { + $for (silrd) + case TY_PIXEL: + call amed3$t (Mem$t[O_VALP(args[1])], + Mem$t[O_VALP(args[2])], + Mem$t[O_VALP(args[3])], + Mem$t[O_VALP(out)], nelem) + $endfor + default: + call xvv_error1 (s_badtype, fcn) + } + case 4: + switch (optype) { + $for (silrd) + case TY_PIXEL: + call amed4$t (Mem$t[O_VALP(args[1])], + Mem$t[O_VALP(args[2])], + Mem$t[O_VALP(args[3])], + Mem$t[O_VALP(args[4])], + Mem$t[O_VALP(out)], nelem) + $endfor + default: + call xvv_error1 (s_badtype, fcn) + } + case 5: + switch (optype) { + $for (silrd) + case TY_PIXEL: + call amed5$t (Mem$t[O_VALP(args[1])], + Mem$t[O_VALP(args[2])], + Mem$t[O_VALP(args[3])], + Mem$t[O_VALP(args[4])], + Mem$t[O_VALP(args[5])], + Mem$t[O_VALP(out)], nelem) + $endfor + default: + call xvv_error1 (s_badtype, fcn) + } + default: + call xvv_error1 ("%s: wrong number of arguments", fcn) + } + + case F_REPL: + # Replicate an item to make a longer vector. + + chunk = O_LEN(ap) + optype = O_TYPE(ap) + if (optype == TY_BOOL) + optype = TY_INT + + if (O_LEN(args[2]) > 0) + call xvv_error1 ("%s: replication factor must be a scalar", fcn) + if (O_TYPE(args[2]) != TY_INT) + call xvv_chtype (args[2], args[2], TY_INT) + repl = max (1, O_VALI(args[2])) + + if (chunk <= 0) + nelem = repl + else + nelem = chunk * repl + call xvv_initop (out, nelem, optype) + + switch (optype) { + $for (silrd) + case TY_PIXEL: + if (chunk > 0) { + ip = O_VALP(ap) + op = O_VALP(out) + do i = 1, repl { + call amov$t (Mem$t[ip], Mem$t[op], chunk) + op = op + chunk + } + } else + call amovk$t (O_VAL$T(ap), Mem$t[O_VALP(out)], nelem) + $endfor + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_SHIFT: + # Vector shift. + if (O_LEN(args[2]) > 0) + call xvv_error1 ("%s: shift arg must be a scalar" , fcn) + if (O_TYPE(args[2]) != TY_INT) + call xvv_chtype (args[2], args[2], TY_INT) + shift = O_VALI(args[2]) + + if (abs(shift) > nelem) { + if (shift > 0) + shift = nelem + else + shift = -nelem + } + + switch (optype) { + $for (silrd) + case TY_PIXEL: + if (nelem > 0) { + do i = 1, nelem { + j = i - shift + if (j < 1) + j = j + nelem + else if (j > nelem) + j = j - nelem + Mem$t[O_VALP(out)+i-1] = Mem$t[O_VALP(ap)+j-1] + } + } else + O_VAL$T(out) = (O_VAL$T(ap)) + $endfor + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_SORT: + # Sort a vector. + switch (optype) { + $for (silrd) + case TY_PIXEL: + if (nelem > 0) + call asrt$t (Mem$t[O_VALP(ap)], Mem$t[O_VALP(out)], nelem) + else + O_VAL$T(out) = (O_VAL$T(ap)) + $endfor + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_ATAN, F_ATAN2: + $for (rd) + if (optype == TY_PIXEL) { + if (nargs == 1) { + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Mem$t[O_VALP(out)+i-1] = + atan (Mem$t[O_VALP(ap)+i-1]) + } else + O_VAL$T(out) = atan (O_VAL$T(ap)) + } else { + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Mem$t[O_VALP(out)+i-1] = + atan2 (Mem$t[O_VALP(args[1])+i-1], + Mem$t[O_VALP(args[2])+i-1]) + } else + O_VAL$T(out) = atan2(O_VAL$T(args[1]), O_VAL$T(args[2])) + } + } + $endfor + + case F_MOD: + in1 = args[1] + in2 = args[2] + + switch (optype) { + $for (silrd) + case TY_PIXEL: + if (O_LEN(in1) <= 0) { + O_VAL$T(out) = mod (O_VAL$T(in1), O_VAL$T(in2)) + } else if (O_LEN(in2) <= 0) { + call amodk$t (Mem$t[O_VALP(in1)], O_VAL$T(in2), + Mem$t[O_VALP(out)], nelem) + } else { + call amod$t (Mem$t[O_VALP(in1)], Mem$t[O_VALP(in2)], + Mem$t[O_VALP(out)], nelem) + } + $endfor + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_MAX: + switch (optype) { + $for (silrd) + case TY_PIXEL: + # Copy the first argument. + ap = args[1] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) > 0) + call amovk$t (O_VAL$T(ap), Mem$t[O_VALP(out)], nelem) + else + O_VAL$T(out) = O_VAL$T(ap) + } else + call amov$t (Mem$t[O_VALP(ap)], Mem$t[O_VALP(out)], nelem) + + # Process the second and remaining arguments. + do i = 2, nargs { + ap = args[i] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) <= 0) + O_VAL$T(out) = max (O_VAL$T(ap), O_VAL$T(out)) + else { + call amaxk$t (Mem$t[O_VALP(out)], O_VAL$T(ap), + Mem$t[O_VALP(out)], nelem) + } + } else { + call amax$t (Mem$t[O_VALP(out)], Mem$t[O_VALP(ap)], + Mem$t[O_VALP(out)], nelem) + } + } + $endfor + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_MIN: + switch (optype) { + $for (silrd) + case TY_PIXEL: + # Copy the first argument. + ap = args[1] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) > 0) + call amovk$t (O_VAL$T(ap), Mem$t[O_VALP(out)], nelem) + else + O_VAL$T(out) = O_VAL$T(ap) + } else + call amov$t (Mem$t[O_VALP(ap)], Mem$t[O_VALP(out)], nelem) + + # Process the second and remaining arguments. + do i = 2, nargs { + ap = args[i] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) <= 0) + O_VAL$T(out) = min (O_VAL$T(ap), O_VAL$T(out)) + else { + call amink$t (Mem$t[O_VALP(out)], O_VAL$T(ap), + Mem$t[O_VALP(out)], nelem) + } + } else { + call amin$t (Mem$t[O_VALP(out)], Mem$t[O_VALP(ap)], + Mem$t[O_VALP(out)], nelem) + } + } + $endfor + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_BOOL: + nelem = 0 + if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR) + nelem = O_LEN(ap) + call xvv_initop (out, nelem, TY_BOOL) + + switch (O_TYPE(ap)) { + case TY_BOOL: + if (O_LEN(ap) <= 0) + O_VALI(out) = O_VALI(ap) + else + call amovi (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_CHAR: + ch = O_VALC(ap) + O_VALI(out) = btoi (ch == 'y' || ch == 'Y') + + $for (silrd) + case TY_PIXEL: + if (O_LEN(ap) <= 0) + O_VALI(out) = btoi (O_VAL$T(ap) != 0$f) + else { + v_$t = 0$f + call abnek$t (Mem$t[O_VALP(ap)], v_$t, Memi[O_VALP(out)], + nelem) + } + $endfor + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_SHORT: + nelem = 0 + if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR) + nelem = O_LEN(ap) + call xvv_initop (out, nelem, TY_SHORT) + + switch (O_TYPE(ap)) { + case TY_BOOL: + if (O_LEN(ap) <= 0) + O_VALS(out) = O_VALI(ap) + else + call achtis (Memi[O_VALP(ap)], Mems[O_VALP(out)], nelem) + + case TY_CHAR: + ip = O_VALP(ap) + if (gctod (Memc, ip, v_d) <= 0) + O_VALS(out) = 0 + else + O_VALS(out) = v_d + + $for (silrd) + case TY_PIXEL: + if (O_LEN(ap) <= 0) + O_VALS(out) = O_VAL$T(ap) + else + call acht$ts (Mem$t[O_VALP(ap)], Memi[O_VALP(out)], nelem) + $endfor + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_INT: + nelem = 0 + if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR) + nelem = O_LEN(ap) + call xvv_initop (out, nelem, TY_INT) + + switch (O_TYPE(ap)) { + case TY_BOOL: + if (O_LEN(ap) <= 0) + O_VALI(out) = O_VALI(ap) + else + call amovi (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_CHAR: + ip = O_VALP(ap) + if (gctod (Memc, ip, v_d) <= 0) + O_VALI(out) = 0 + else + O_VALI(out) = v_d + + $for (silrd) + case TY_PIXEL: + if (O_LEN(ap) <= 0) + O_VALI(out) = O_VAL$T(ap) + else + call acht$ti (Mem$t[O_VALP(ap)], Memi[O_VALP(out)], nelem) + $endfor + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_LONG: + nelem = 0 + if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR) + nelem = O_LEN(ap) + call xvv_initop (out, nelem, TY_LONG) + + switch (O_TYPE(ap)) { + case TY_BOOL: + if (O_LEN(ap) <= 0) + O_VALL(out) = O_VALI(ap) + else + call amovi (Memi[O_VALP(ap)], Meml[O_VALP(out)], nelem) + + case TY_CHAR: + ip = O_VALP(ap) + if (gctod (Memc, ip, v_d) <= 0) + O_VALL(out) = 0 + else + O_VALL(out) = v_d + + $for (silrd) + case TY_PIXEL: + if (O_LEN(ap) <= 0) + O_VALL(out) = O_VAL$T(ap) + else + call acht$tl (Mem$t[O_VALP(ap)], Memi[O_VALP(out)], nelem) + $endfor + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_NINT: + nelem = 0 + if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR) + nelem = O_LEN(ap) + call xvv_initop (out, nelem, TY_INT) + + switch (O_TYPE(ap)) { + case TY_BOOL: + if (O_LEN(ap) <= 0) + O_VALI(out) = O_VALI(ap) + else + call amovi (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_CHAR: + ip = O_VALP(ap) + if (gctod (Memc, ip, v_d) <= 0) + O_VALI(out) = 0 + else + O_VALI(out) = nint (v_d) + + $for (sil) + case TY_PIXEL: + if (O_LEN(ap) <= 0) + O_VALI(out) = O_VAL$T(ap) + else + call acht$ti (Mem$t[O_VALP(ap)], Memi[O_VALP(out)], nelem) + $endfor + + $for (rd) + case TY_PIXEL: + if (O_LEN(ap) <= 0) + O_VALI(out) = nint (O_VAL$T(ap)) + else { + do i = 1, nelem + Memi[O_VALP(out)+i-1] = nint (Mem$t[O_VALP(ap)+i-1]) + } + $endfor + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_REAL: + nelem = 0 + if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR) + nelem = O_LEN(ap) + call xvv_initop (out, nelem, TY_REAL) + + switch (O_TYPE(ap)) { + case TY_BOOL: + if (O_LEN(ap) <= 0) + O_VALR(out) = O_VALI(ap) + else + call achtir (Memi[O_VALP(ap)], Memr[O_VALP(out)], nelem) + + case TY_CHAR: + ip = O_VALP(ap) + if (gctod (Memc, ip, v_d) <= 0) + O_VALR(out) = 0 + else + O_VALR(out) = v_d + + $for (silrd) + case TY_PIXEL: + if (O_LEN(ap) <= 0) + O_VALR(out) = O_VAL$T(ap) + else + call acht$tr (Mem$t[O_VALP(ap)], Memr[O_VALP(out)], nelem) + $endfor + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_DOUBLE: + nelem = 0 + if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR) + nelem = O_LEN(ap) + call xvv_initop (out, nelem, TY_DOUBLE) + + switch (O_TYPE(ap)) { + case TY_BOOL: + if (O_LEN(ap) <= 0) + O_VALD(out) = O_VALI(ap) + else + call achtid (Memi[O_VALP(ap)], Memd[O_VALP(out)], nelem) + + case TY_CHAR: + ip = O_VALP(ap) + if (gctod (Memc, ip, v_d) <= 0) + O_VALD(out) = 0 + else + O_VALD(out) = v_d + + $for (silrd) + case TY_PIXEL: + if (O_LEN(ap) <= 0) + O_VALD(out) = O_VAL$T(ap) + else + call acht$td (Mem$t[O_VALP(ap)], Memd[O_VALP(out)], nelem) + $endfor + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_STR: + optype = TY_CHAR + if (O_TYPE(ap) == TY_CHAR) + nelem = strlen (O_VALC(ap)) + else + nelem = MAX_DIGITS + call xvv_initop (out, nelem, TY_CHAR) + + switch (O_TYPE(ap)) { + case TY_BOOL: + call sprintf (O_VALC(out), nelem, "%b") + call pargi (O_VALI(ap)) + case TY_CHAR: + call sprintf (O_VALC(out), nelem, "%s") + call pargstr (O_VALC(ap)) + $for (sil) + case TY_PIXEL: + call sprintf (O_VALC(out), nelem, "%d") + call parg$t (O_VAL$T(ap)) + $endfor + $for (rd) + case TY_PIXEL: + call sprintf (O_VALC(out), nelem, "%g") + call parg$t (O_VAL$T(ap)) + $endfor + default: + call xvv_error1 (s_badtype, fcn) + } + + default: + call xvv_error ("callfcn: unknown function type") + } + +free_ + # Free any storage used by the argument list operands. + do i = 1, nargs + call xvv_freeop (args[i]) + + call sfree (sp) +end + + +# XVV_STARTARGLIST -- Allocate an argument list descriptor to receive +# arguments as a function call is parsed. We are called with either +# zero or one arguments. The argument list descriptor is pointed to by +# a ficticious operand. The descriptor itself contains a count of the +# number of arguments, an array of pointers to the operand structures, +# as well as storage for the operand structures. The operands must be +# stored locally since the parser will discard its copy of the operand +# structure for each argument as the associated grammar rule is reduced. + +procedure xvv_startarglist (arg, out) + +pointer arg #I pointer to first argument, or NULL +pointer out #I output operand pointing to arg descriptor + +pointer ap +errchk xvv_initop + +begin + call xvv_initop (out, LEN_ARGSTRUCT, TY_STRUCT) + ap = O_VALP(out) + + if (arg == NULL) + A_NARGS(ap) = 0 + else { + A_NARGS(ap) = 1 + A_ARGP(ap,1) = A_OPS(ap) + YYMOVE (arg, A_OPS(ap)) + } +end + + +# XVV_ADDARG -- Add an argument to the argument list for a function call. + +procedure xvv_addarg (arg, arglist, out) + +pointer arg #I pointer to argument to be added +pointer arglist #I pointer to operand pointing to arglist +pointer out #I output operand pointing to arg descriptor + +pointer ap, o +int nargs + +begin + ap = O_VALP(arglist) + + nargs = A_NARGS(ap) + 1 + A_NARGS(ap) = nargs + if (nargs > MAX_ARGS) + call xvv_error ("too many function arguments") + + o = A_OPS(ap) + ((nargs - 1) * LEN_OPERAND) + A_ARGP(ap,nargs) = o + YYMOVE (arg, o) + + YYMOVE (arglist, out) +end + + +# XVV_ERROR1 -- Take an error action, formatting an error message with one +# format string plus one string argument. + +procedure xvv_error1 (fmt, arg) + +char fmt[ARB] #I printf format string +char arg[ARB] #I string argument + +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + call sprintf (Memc[buf], SZ_LINE, fmt) + call pargstr (arg) + + call xvv_error (Memc[buf]) + call sfree (sp) +end + + +# XVV_ERROR2 -- Take an error action, formatting an error message with one +# format string plus one string argument and one integer argument. + +procedure xvv_error2 (fmt, arg1, arg2) + +char fmt[ARB] #I printf format string +char arg1[ARB] #I string argument +int arg2 #I integer argument + +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + call sprintf (Memc[buf], SZ_LINE, fmt) + call pargstr (arg1) + call pargi (arg2) + + call xvv_error (Memc[buf]) + call sfree (sp) +end + + +# XVV_ERROR -- Take an error action, given an error message string as the +# sole argument. + +procedure xvv_error (errmsg) + +char errmsg[ARB] #I error message + +begin + call error (1, errmsg) +end + + +# XVV_CHTYPE -- Change the datatype of an operand. The input and output +# operands may be the same. + +procedure xvv_chtype (o1, o2, dtype) + +pointer o1 #I input operand +pointer o2 #I output operand +int dtype #I new datatype + +short v_s +int v_i +long v_l +real v_r +double v_d +pointer vp, ip, op +bool float, freeval +int old_type, nelem, ch + +pointer coerce() +int sizeof(), btoi(), gctod() +string s_badtype "chtype: invalid operand type" + +begin + old_type = O_TYPE(o1) + nelem = O_LEN(o1) + + # No type conversion needed? + if (old_type == dtype) { + if (o1 != o2) { + if (nelem <= 0) + YYMOVE (o1, o2) + else { + call xvv_initop (o2, nelem, old_type) + call amovc (O_VALC(o1), O_VALC(o2), nelem * sizeof(dtype)) + } + } + return + } + + if (nelem <= 0) { + # Scalar input operand. + + O_TYPE(o2) = dtype + O_LEN(o2) = 0 + float = false + + # Read the old value into a local variable of type long or double. + switch (old_type) { + case TY_BOOL: + v_l = O_VALI(o1) + case TY_CHAR: + v_l = 0 # null string? + $for (sil) + case TY_PIXEL: + v_l = O_VAL$T(o1) + $endfor + $for (rd) + case TY_PIXEL: + v_d = O_VAL$T(o1) + float = true + $endfor + default: + call xvv_error (s_badtype) + } + + # Set the value of the output operand. + switch (dtype) { + case TY_BOOL: + if (float) + O_VALI(o2) = btoi (v_d != 0) + else + O_VALI(o2) = btoi (v_l != 0) + case TY_CHAR: + call xvv_initop (o2, MAX_DIGITS, TY_CHAR) + if (float) { + call sprintf (O_VALC(o2), MAX_DIGITS, "%g") + call pargd (v_d) + } else { + call sprintf (O_VALC(o2), MAX_DIGITS, "%d") + call pargl (v_l) + } + $for (sil) + case TY_PIXEL: + if (float) + O_VAL$T(o2) = v_d + else + O_VAL$T(o2) = v_l + $endfor + $for (rd) + case TY_PIXEL: + if (float) + O_VAL$T(o2) = v_d + else + O_VAL$T(o2) = v_l + $endfor + default: + call xvv_error (s_badtype) + } + + } else { + # Vector input operand. + + # Save a pointer to the input operand data vector, to avoid it + # getting clobbered if O1 and O2 are the same operand. + + vp = O_VALP(o1) + + # If we have a char string input operand the output numeric + # operand can only be a scalar. If we have a char string output + # operand nelem is the length of the string. + + if (old_type == TY_CHAR) + nelem = 0 + else if (dtype == TY_CHAR) + nelem = MAX_DIGITS + + # Initialize the output operand O2. The freeval flag is cleared + # cleared to keep the initop from freeing the input operand array, + # inherited when the input operand is copied (or when the input + # and output operands are the same). We free the old operand + # array manually below. + + if (o1 != o2) + YYMOVE (o1, o2) + freeval = (and (O_FLAGS(o1), O_FREEVAL) != 0) + O_FLAGS(o2) = and (O_FLAGS(o2), not(O_FREEVAL)) + call xvv_initop (o2, nelem, dtype) + + # Write output value. + switch (dtype) { + case TY_BOOL: + if (old_type == TY_CHAR) { + ch = Memc[vp] + O_VALI(o2) = btoi (ch == 'y' || ch == 'Y') + } else { + switch (old_type) { + $for (silrd) + case TY_PIXEL: + v_$t = 0$f + call abnek$t (Mem$t[vp], v_$t, Memi[O_VALP(o2)], nelem) + $endfor + default: + call xvv_error (s_badtype) + } + } + + case TY_CHAR: + call xvv_error (s_badtype) + + case TY_SHORT, TY_INT, TY_LONG, TY_REAL, TY_DOUBLE: + switch (old_type) { + case TY_BOOL: + op = coerce (O_VALP(o2), O_TYPE(o2), TY_CHAR) + call achti (Memi[vp], Memc[op], nelem, dtype) + case TY_CHAR: + ip = vp + if (gctod (Memc, ip, v_d) <= 0) + v_d = 0 + switch (dtype) { + $for (silrd) + case TY_PIXEL: + O_VAL$T(o2) = v_d + $endfor + } + $for (silrd) + case TY_PIXEL: + op = coerce (O_VALP(o2), O_TYPE(o2), TY_CHAR) + call acht$t (Mem$t[vp], Memc[op], nelem, dtype) + $endfor + default: + call xvv_error (s_badtype) + } + default: + call xvv_error (s_badtype) + } + + # Free old operand value. + if (freeval) + call mfree (vp, old_type) + } +end + + +# XVV_INITOP -- Initialize an operand, providing storage for an operand value +# of the given size and type. + +procedure xvv_initop (o, o_len, o_type) + +pointer o #I pointer to operand structure +int o_len #I length of operand (zero if scalar) +int o_type #I datatype of operand + +begin + O_LEN(o) = 0 + call xvv_makeop (o, o_len, o_type) +end + + +# XVV_MAKEOP -- Set up the operand structure. If the operand structure has +# already been initialized and array storage allocated, free the old array. + +procedure xvv_makeop (o, o_len, o_type) + +pointer o #I pointer to operand structure +int o_len #I length of operand (zero if scalar) +int o_type #I datatype of operand + +errchk malloc + +begin + # Free old array storage if any. + if (O_TYPE(o) != 0 && O_LEN(o) > 0) + if (and (O_FLAGS(o), O_FREEVAL) != 0) { + if (O_TYPE(o) == TY_BOOL) + call mfree (O_VALP(o), TY_INT) + else + call mfree (O_VALP(o), O_TYPE(o)) + O_LEN(o) = 0 + } + + # Set new operand type. + O_TYPE(o) = o_type + + # Allocate array storage if nonscalar operand. + if (o_len > 0) { + if (o_type == TY_BOOL) + call malloc (O_VALP(o), o_len, TY_INT) + else + call malloc (O_VALP(o), o_len, o_type) + O_LEN(o) = o_len + } + + O_FLAGS(o) = O_FREEVAL +end + + +# XVV_FREEOP -- Reinitialize an operand structure, i.e., free any associated +# array storage and clear the operand datatype field, but do not free the +# operand structure itself (which may be only a segment of an array and not +# a separately allocated structure). + +procedure xvv_freeop (o) + +pointer o #I pointer to operand structure + +begin + # Free old array storage if any. + if (O_TYPE(o) != 0 && O_LEN(o) > 0) + if (and (O_FLAGS(o), O_FREEVAL) != 0) { + if (O_TYPE(o) == TY_BOOL) + call mfree (O_VALP(o), TY_INT) + else + call mfree (O_VALP(o), O_TYPE(o)) + O_LEN(o) = 0 + } + + # Either free operand struct or clear the operand type to mark + # operand invalid. + + if (and (O_FLAGS(o), O_FREEOP) != 0) + call mfree (o, TY_STRUCT) + else + O_TYPE(o) = 0 +end + + +# XVV_LOADSYMBOLS -- Load a list of symbol names into a symbol table. Each +# symbol is tagged with an integer code corresponding to its sequence number +# in the symbol list. + +pointer procedure xvv_loadsymbols (s) + +char s[ARB] #I symbol list "|sym1|sym2|...|" + +int delim, symnum, ip +pointer sp, symname, st, sym, op +pointer stopen(), stenter() + +begin + call smark (sp) + call salloc (symname, SZ_FNAME, TY_CHAR) + + st = stopen ("evvexpr", LEN_INDEX, LEN_STAB, LEN_SBUF) + delim = s[1] + symnum = 0 + + for (ip=2; s[ip] != EOS; ip=ip+1) { + op = symname + while (s[ip] != delim && s[ip] != EOS) { + Memc[op] = s[ip] + op = op + 1 + ip = ip + 1 + } + Memc[op] = EOS + symnum = symnum + 1 + + if (op > symname && IS_ALPHA(Memc[symname])) { + sym = stenter (st, Memc[symname], LEN_SYM) + SYM_CODE(sym) = symnum + } + } + + call sfree (sp) + return (st) +end + + +# XVV_NULL -- Return a null value to be used when a computation cannot be +# performed and range checking is enabled. Perhaps we should permit a user +# specified value here, however this doesn't really work in an expression +# evaluator since the value generated may be used in subsequent calculations +# and hence may change. If more careful treatment of out of range values +# is needed a conditional expression can be used in which case the value +# we return here is ignored (but still needed to avoid a hardware exception +# when computing a vector). + +$for (silrd) +PIXEL procedure xvv_null$t (ignore) +PIXEL ignore #I ignored +begin + return (0$f) +end +$endfor diff --git a/sys/fmtio/evvexpr.x b/sys/fmtio/evvexpr.x new file mode 100644 index 00000000..19bc4790 --- /dev/null +++ b/sys/fmtio/evvexpr.x @@ -0,0 +1,5050 @@ + +# line 2 "evvexpr.y" +include +include +include +include +include + +.help evvexpr +.nf -------------------------------------------------------------------------- +EVVEXPR.GY -- Generic XYacc source for a general vector expression evaluator. + + o = evvexpr (expr, getop, getop_data, ufcn, ufcn_data, flags) + evvfree (o) + +Client callbacks: + + getop (client_data, opname, out) + ufcn (client_data, fcn, args, nargs, out) + +here "out" is the output operand returned to EVVEXPR. Client_data is any +arbitrary integer or pointer value passed in to EVVEXPR when by the client +when the callback was registered. "args" is an array of operand structs, +the arguments for the user function being called. If the operand or +function call cannot be completed normally an error exit may be made (call +error) or an invalid operand may be returned (O_TYPE set to 0). The client +should not free the "args" input operands, this will be handled by EVVEXPR. + +Operand struct (lib$evvexpr.h): + + struct operand { + int O_TYPE # operand type (bcsilrd) + int O_LEN # operand length (0=scalar) + int O_FLAGS # O_FREEVAL, O_FREEOP + union { + char* O_VALC # string + short O_VALS + int O_VALI # int or bool + long O_VALL + real O_VALR + double O_VALD + pointer O_VALP # vector data + } + } + +The macro O_VALC references the string value of a TY_CHAR operand. The +flags are O_FREEVAL and O_FREEOP, which tell EVVEXPR and EVVFREE whether or +not to free any vector operand array or the operand struct when the operand +is freed. The client should set these flags on operands returned to EVVEXPR +if it wants EVVEXPR to free any operand storage. + +Supported types are bool, char (string), and SILRD. Bool is indicated as +TY_BOOL in the O_TYPE field of the operand struct, but is stored internally +as an integer and the value field of a boolean operand is given by O_VALI. + +Operands may be either scalars or vectors. A vector is indicated by a O_LEN +value greater than zero. For vector operands O_VALP points to the data array. +A special case is TY_CHAR (string), in which case O_LEN is the allocated +length of the EOS-terminated string. A string is logically a scalar value +even though it is physically stored in the operand as a character vector. + +The trig functions operate upon angles in units of radians. The intrinsic +functions RAD and DEG are available for converting between radians and +degrees. A string can be coerced to a binary value and vice versa, using +the INT, STR, etc. intrinsic functions. + +This is a generalization of the older EVEXPR routine, adding additional +datatypes, support for vector operands, and numerous minor enhancements. +.endhelp --------------------------------------------------------------------- + +define YYMAXDEPTH 64 # parser stack length +define MAX_ARGS 17 # max args in a function call +define yyparse xvv_parse + +# Arglist structure. +define LEN_ARGSTRUCT (1+MAX_ARGS+(MAX_ARGS*LEN_OPERAND)) +define A_NARGS Memi[$1] # number of arguments +define A_ARGP Memi[$1+$2] # array of pointers to operand structs +define A_OPS ($1+MAX_ARGS+1) # offset to operand storage area + +# Intrinsic functions. + +define LEN_STAB 300 # for symbol table +define LEN_SBUF 256 +define LEN_INDEX 97 + +define LEN_SYM 1 # symbol data +define SYM_CODE Memi[$1] + +define KEYWORDS "|abs|acos|asin|atan|atan2|bool|cos|cosh|deg|double|\ + |exp|hiv|int|len|log|log10|long|lov|max|mean|median|\ + |min|mod|nint|rad|real|repl|stddev|shift|short|sin|\ + |sinh|sort|sqrt|str|sum|tan|tanh|" + +define F_ABS 01 # function codes +define F_ACOS 02 +define F_ASIN 03 +define F_ATAN 04 +define F_ATAN2 05 +define F_BOOL 06 +define F_COS 07 +define F_COSH 08 +define F_DEG 09 # radians to degrees +define F_DOUBLE 10 + # newline 11 +define F_EXP 12 +define F_HIV 13 # high value +define F_INT 14 +define F_LEN 15 # vector length +define F_LOG 16 +define F_LOG10 17 +define F_LONG 18 +define F_LOV 19 # low value +define F_MAX 20 +define F_MEAN 21 +define F_MEDIAN 22 + # newline 23 +define F_MIN 24 +define F_MOD 25 +define F_NINT 26 +define F_RAD 27 # degrees to radians +define F_REAL 28 +define F_REPL 29 # replicate +define F_STDDEV 30 # standard deviation +define F_SHIFT 31 +define F_SHORT 32 +define F_SIN 33 + # newline 34 +define F_SINH 35 +define F_SORT 36 # sort +define F_SQRT 37 # square root +define F_STR 38 +define F_SUM 39 +define F_TAN 40 +define F_TANH 41 + +define T_B TY_BOOL +define T_C TY_CHAR +define T_S TY_SHORT +define T_I TY_INT +define T_L TY_LONG +define T_R TY_REAL +define T_D TY_DOUBLE + + +# EVVEXPR -- Evaluate a general mixed type vector expression. Input consists +# of the expression to be evaluated (a string) and, optionally, user +# procedures for fetching external operands and executing external functions. +# Output is a pointer to an operand structure containing the computed value of +# the expression. The output operand structure is dynamically allocated by +# EVVEXPR and must be freed by the user. +# +# NOTE: this is not intended to be an especially efficient procedure. Rather, +# this is a high level, easy to use procedure, intended to provide greater +# flexibility in the parameterization of applications programs. The main +# inefficiency is that, since compilation and execution are not broken out as +# separate steps, when the routine is repeatedly called to evaluate the same +# expression with different data, all the compile time computation (parsing +# etc.) has to be repeated. + +pointer procedure evvexpr (expr, getop, getop_data, ufcn, ufcn_data, flags) + +char expr[ARB] #I expression to be evaluated +int getop #I user supplied get operand procedure +int getop_data #I client data for above function +int ufcn #I user supplied function call procedure +int ufcn_data #I client data for above function +int flags #I flag bits + +int junk +pointer sp, ip +bool debug, first_time +int strlen(), xvv_parse() +pointer xvv_loadsymbols() +extern xvv_gettok() + +errchk xvv_parse, calloc +include "evvexpr.com" +data debug /false/ +data first_time /true/ + +begin + call smark (sp) + + if (first_time) { + # This creates data which remains for the life of the process. + ev_st = xvv_loadsymbols (KEYWORDS) + first_time = false + } + + # Set user function entry point addresses. + ev_getop = getop + ev_getop_data = getop_data + ev_ufcn = ufcn + ev_ufcn_data = ufcn_data + ev_flags = flags + + # Allocate an operand struct for the expression value. + call calloc (ev_oval, LEN_OPERAND, TY_STRUCT) + + # Make a local copy of the input string. + call salloc (ip, strlen(expr), TY_CHAR) + call strcpy (expr, Memc[ip], ARB) + + # Evaluate the expression. The expression value is copied into the + # output operand structure by XVV_PARSE, given the operand pointer + # passed in common. A common must be used since the standard parser + # subroutine has a fixed calling sequence. + + junk = xvv_parse (ip, debug, xvv_gettok) + O_FLAGS(ev_oval) = or (O_FLAGS(ev_oval), O_FREEOP) + + call sfree (sp) + return (ev_oval) +end + + +# EVVFREE -- Free an operand struct such as is returned by EVVEXPR. + +procedure evvfree (o) + +pointer o # operand struct + +begin + call xvv_freeop (o) +end + +define CONSTANT 257 +define IDENTIFIER 258 +define NEWLINE 259 +define YYEOS 260 +define PLUS 261 +define MINUS 262 +define STAR 263 +define SLASH 264 +define EXPON 265 +define CONCAT 266 +define QUEST 267 +define COLON 268 +define LT 269 +define GT 270 +define LE 271 +define EQ 272 +define NE 273 +define SE 274 +define LAND 275 +define LOR 276 +define LNOT 277 +define BAND 278 +define BOR 279 +define BXOR 280 +define BNOT 281 +define AT 282 +define GE 283 +define UMINUS 284 +define yyclearin yychar = -1 +define yyerrok yyerrflag = 0 +define YYMOVE call amovi (Memi[$1], Memi[$2], YYOPLEN) +define YYERRCODE 256 + + +# End generic preprocessor escape. + + + +# XVV_UNOP -- Unary operation. Perform the indicated unary operation on the +# input operand, returning the result as the output operand. + +procedure xvv_unop (opcode, in, out) + +int opcode #I operation to be performed +pointer in #I input operand +pointer out #I output operand + +short val_s +long val_l +int val_i, nelem +errchk xvv_error, xvv_initop +string s_badswitch "unop: bad switch" + +begin + nelem = O_LEN(in) + + switch (opcode) { + case MINUS: + # Unary negation. + call xvv_initop (out, nelem, O_TYPE(in)) + switch (O_TYPE(in)) { + case TY_BOOL, TY_CHAR: + call xvv_error ("negation of a nonarithmetic operand") + + case TY_SHORT: + if (nelem > 0) + call anegs (Mems[O_VALP(in)], Mems[O_VALP(out)], nelem) + else + O_VALS(out) = -O_VALS(in) + + case TY_INT: + if (nelem > 0) + call anegi (Memi[O_VALP(in)], Memi[O_VALP(out)], nelem) + else + O_VALI(out) = -O_VALI(in) + + case TY_LONG: + if (nelem > 0) + call anegl (Meml[O_VALP(in)], Meml[O_VALP(out)], nelem) + else + O_VALL(out) = -O_VALL(in) + + case TY_REAL: + if (nelem > 0) + call anegr (Memr[O_VALP(in)], Memr[O_VALP(out)], nelem) + else + O_VALR(out) = -O_VALR(in) + + case TY_DOUBLE: + if (nelem > 0) + call anegd (Memd[O_VALP(in)], Memd[O_VALP(out)], nelem) + else + O_VALD(out) = -O_VALD(in) + + default: + call xvv_error (s_badswitch) + } + + case LNOT: + # Logical NOT. + + call xvv_initop (out, nelem, TY_BOOL) + switch (O_TYPE(in)) { + case TY_BOOL: + if (nelem > 0) + call abeqki (Memi[O_VALP(in)], NO, Memi[O_VALP(out)], nelem) + else { + if (O_VALI(in) == NO) + O_VALI(out) = YES + else + O_VALI(out) = NO + } + + case TY_SHORT: + if (nelem > 0) { + val_s = NO + call abeqks (Mems[O_VALP(in)], val_s, Memi[O_VALP(out)], + nelem) + } else { + if (O_VALS(in) == NO) + O_VALS(out) = YES + else + O_VALS(out) = NO + } + + case TY_INT: + if (nelem > 0) { + val_i = NO + call abeqki (Memi[O_VALP(in)], val_i, Memi[O_VALP(out)], + nelem) + } else { + if (O_VALI(in) == NO) + O_VALI(out) = YES + else + O_VALI(out) = NO + } + + case TY_LONG: + if (nelem > 0) { + val_l = NO + call abeqkl (Meml[O_VALP(in)], val_l, Memi[O_VALP(out)], + nelem) + } else { + if (O_VALL(in) == NO) + O_VALL(out) = YES + else + O_VALL(out) = NO + } + + case TY_CHAR, TY_REAL, TY_DOUBLE: + call xvv_error ("not of a nonlogical") + default: + call xvv_error (s_badswitch) + } + + case BNOT: + # Bitwise boolean NOT. + + call xvv_initop (out, nelem, O_TYPE(in)) + switch (O_TYPE(in)) { + case TY_BOOL, TY_CHAR, TY_REAL, TY_DOUBLE: + call xvv_error ("boolean not of a noninteger operand") + + case TY_SHORT: + if (nelem > 0) + call anots (Mems[O_VALP(in)], Mems[O_VALP(out)], nelem) + else + O_VALS(out) = not(O_VALS(in)) + + case TY_INT: + if (nelem > 0) + call anoti (Memi[O_VALP(in)], Memi[O_VALP(out)], nelem) + else + O_VALI(out) = not(O_VALI(in)) + + case TY_LONG: + if (nelem > 0) + call anotl (Meml[O_VALP(in)], Meml[O_VALP(out)], nelem) + else + O_VALL(out) = not(O_VALL(in)) + + default: + call xvv_error (s_badswitch) + } + + default: + call xvv_error (s_badswitch) + } + + call xvv_freeop (in) +end + + +# XVV_BINOP -- Binary operation. Perform the indicated arithmetic binary +# operation on the two input operands, returning the result as the output +# operand. + +procedure xvv_binop (opcode, in1, in2, out) + +int opcode #I operation to be performed +pointer in1, in2 #I input operands +pointer out #I output operand + + +short v_s +short xvv_nulls() +extern xvv_nulls() + +int v_i +int xvv_nulli() +extern xvv_nulli() + +long v_l +long xvv_nulll() +extern xvv_nulll() + +real v_r +real xvv_nullr() +extern xvv_nullr() + +double v_d +double xvv_nulld() +extern xvv_nulld() + +pointer sp, otemp, p1, p2, po +int dtype, nelem, len1, len2 +include "evvexpr.com" + +int xvv_newtype(), strlen() +errchk xvv_newtype, xvv_initop, xvv_chtype, xvv_error +string s_badswitch "binop: bad case in switch" +string s_boolop "binop: bitwise boolean operands must be an integer type" +define done_ 91 + +begin + # Set the datatype of the output operand, taking an error action if + # the operands have incompatible datatypes. + + dtype = xvv_newtype (O_TYPE(in1), O_TYPE(in2)) + + # Compute the size of the output operand. If both input operands are + # vectors the length of the output vector is the shorter of the two. + + switch (dtype) { + case TY_BOOL: + call xvv_error ("binop: operation illegal for boolean operands") + case TY_CHAR: + nelem = strlen (O_VALC(in1)) + strlen (O_VALC(in2)) + default: + if (opcode == CONCAT) + nelem = max (1, O_LEN(in1)) + max (1, O_LEN(in2)) + else { + if (O_LEN(in1) > 0 && O_LEN(in2) > 0) + nelem = min (O_LEN(in1), O_LEN(in2)) + else if (O_LEN(in1) > 0) + nelem = O_LEN(in1) + else if (O_LEN(in2) > 0) + nelem = O_LEN(in2) + else + nelem = 0 + } + } + + # Convert input operands to desired type. + if (O_TYPE(in1) != dtype) + call xvv_chtype (in1, in1, dtype) + if (O_TYPE(in2) != dtype) + call xvv_chtype (in2, in2, dtype) + + # If this is a scalar/vector operation make sure the vector is the + # first operand. + + len1 = O_LEN(in1) + len2 = O_LEN(in2) + + if (len1 == 0 && len2 > 0) { + switch (opcode) { + case PLUS: + # Swap operands. + call smark (sp) + call salloc (otemp, LEN_OPERAND, TY_STRUCT) + YYMOVE (in1, otemp) + YYMOVE (in2, in1) + YYMOVE (otemp, in2) + call sfree (sp) + + case CONCAT: + ; # Do nothing + + default: + # Promote operand to a constant vector. Inefficient, but + # better than aborting. + + switch (dtype) { + + case TY_SHORT: + v_s = O_VALS(in1) + call xvv_initop (in1, nelem, dtype) + call amovks (v_s, Mems[O_VALP(in1)], nelem) + + case TY_INT: + v_i = O_VALI(in1) + call xvv_initop (in1, nelem, dtype) + call amovki (v_i, Memi[O_VALP(in1)], nelem) + + case TY_LONG: + v_l = O_VALL(in1) + call xvv_initop (in1, nelem, dtype) + call amovkl (v_l, Meml[O_VALP(in1)], nelem) + + case TY_REAL: + v_r = O_VALR(in1) + call xvv_initop (in1, nelem, dtype) + call amovkr (v_r, Memr[O_VALP(in1)], nelem) + + case TY_DOUBLE: + v_d = O_VALD(in1) + call xvv_initop (in1, nelem, dtype) + call amovkd (v_d, Memd[O_VALP(in1)], nelem) + + } + } + + len1 = O_LEN(in1) + len2 = O_LEN(in2) + } + + # Initialize the output operand. + call xvv_initop (out, nelem, dtype) + + p1 = O_VALP(in1) + p2 = O_VALP(in2) + po = O_VALP(out) + + # The bitwise boolean binary operators a special case since only the + # integer datatypes are permitted. Otherwise the bitwise booleans + # are just like arithmetic booleans. + + if (opcode == BAND || opcode == BOR || opcode == BXOR) { + switch (dtype) { + + case TY_SHORT: + switch (opcode) { + case BAND: + if (len1 <= 0) { + O_VALS(out) = and (O_VALS(in1), O_VALS(in2)) + } else if (len2 <= 0) { + call aandks (Mems[p1], O_VALS(in2), + Mems[po], nelem) + } else { + call aands (Mems[p1], Mems[p2], + Mems[po], nelem) + } + case BOR: + if (len1 <= 0) { + O_VALS(out) = or (O_VALS(in1), O_VALS(in2)) + } else if (len2 <= 0) { + call aborks (Mems[p1], O_VALS(in2), + Mems[po], nelem) + } else { + call abors (Mems[p1], Mems[p2], + Mems[po], nelem) + } + case BXOR: + if (len1 <= 0) { + O_VALS(out) = xor (O_VALS(in1), O_VALS(in2)) + } else if (len2 <= 0) { + call axorks (Mems[p1], O_VALS(in2), + Mems[po], nelem) + } else { + call axors (Mems[p1], Mems[p2], + Mems[po], nelem) + } + } + + case TY_INT: + switch (opcode) { + case BAND: + if (len1 <= 0) { + O_VALI(out) = and (O_VALI(in1), O_VALI(in2)) + } else if (len2 <= 0) { + call aandki (Memi[p1], O_VALI(in2), + Memi[po], nelem) + } else { + call aandi (Memi[p1], Memi[p2], + Memi[po], nelem) + } + case BOR: + if (len1 <= 0) { + O_VALI(out) = or (O_VALI(in1), O_VALI(in2)) + } else if (len2 <= 0) { + call aborki (Memi[p1], O_VALI(in2), + Memi[po], nelem) + } else { + call abori (Memi[p1], Memi[p2], + Memi[po], nelem) + } + case BXOR: + if (len1 <= 0) { + O_VALI(out) = xor (O_VALI(in1), O_VALI(in2)) + } else if (len2 <= 0) { + call axorki (Memi[p1], O_VALI(in2), + Memi[po], nelem) + } else { + call axori (Memi[p1], Memi[p2], + Memi[po], nelem) + } + } + + case TY_LONG: + switch (opcode) { + case BAND: + if (len1 <= 0) { + O_VALL(out) = and (O_VALL(in1), O_VALL(in2)) + } else if (len2 <= 0) { + call aandkl (Meml[p1], O_VALL(in2), + Meml[po], nelem) + } else { + call aandl (Meml[p1], Meml[p2], + Meml[po], nelem) + } + case BOR: + if (len1 <= 0) { + O_VALL(out) = or (O_VALL(in1), O_VALL(in2)) + } else if (len2 <= 0) { + call aborkl (Meml[p1], O_VALL(in2), + Meml[po], nelem) + } else { + call aborl (Meml[p1], Meml[p2], + Meml[po], nelem) + } + case BXOR: + if (len1 <= 0) { + O_VALL(out) = xor (O_VALL(in1), O_VALL(in2)) + } else if (len2 <= 0) { + call axorkl (Meml[p1], O_VALL(in2), + Meml[po], nelem) + } else { + call axorl (Meml[p1], Meml[p2], + Meml[po], nelem) + } + } + + default: + call xvv_error (s_boolop) + } + + goto done_ + } + + # Perform an arithmetic binary operation. + switch (dtype) { + case TY_CHAR: + switch (opcode) { + case CONCAT: + call strcpy (O_VALC(in1), O_VALC(out), ARB) + call strcat (O_VALC(in2), O_VALC(out), ARB) + default: + call xvv_error ("binop: operation illegal for string operands") + } + + case TY_SHORT: + switch (opcode) { + case PLUS: + if (len1 <= 0) { + O_VALS(out) = O_VALS(in1) + O_VALS(in2) + } else if (len2 <= 0) { + call aaddks (Mems[p1], O_VALS(in2), + Mems[po], nelem) + } else { + call aadds (Mems[p1], Mems[p2], + Mems[po], nelem) + } + case MINUS: + if (len1 <= 0) + O_VALS(out) = O_VALS(in1) - O_VALS(in2) + else if (len2 <= 0) + call asubks (Mems[p1], O_VALS(in2), Mems[po], nelem) + else + call asubs (Mems[p1], Mems[p2], Mems[po], nelem) + + case STAR: + if (len1 <= 0) + O_VALS(out) = O_VALS(in1) * O_VALS(in2) + else if (len2 <= 0) + call amulks (Mems[p1], O_VALS(in2), Mems[po], nelem) + else + call amuls (Mems[p1], Mems[p2], Mems[po], nelem) + + case SLASH: + if (and (ev_flags, EV_RNGCHK) == 0) { + # No range checking. + if (len1 <= 0) + O_VALS(out) = O_VALS(in1) / O_VALS(in2) + else if (len2 <= 0) + call adivks (Mems[p1], O_VALS(in2), Mems[po], nelem) + else + call adivs (Mems[p1], Mems[p2], Mems[po], nelem) + } else { + # Check for divide by zero. + if (len1 <= 0) { + if (O_VALS(in2) == 0) + O_VALS(out) = xvv_nulls(0) + else + O_VALS(out) = O_VALS(in1) / O_VALS(in2) + } else if (len2 <= 0) { + if (O_VALS(in2) == 0) + call amovks (xvv_nulls(0), Mems[po], nelem) + else { + call adivks (Mems[p1], O_VALS(in2), Mems[po], + nelem) + } + } else { + call advzs (Mems[p1], Mems[p2], Mems[po], nelem, + xvv_nulls) + } + } + case EXPON: + if (len1 <= 0) + O_VALS(out) = O_VALS(in1) ** O_VALS(in2) + else if (len2 <= 0) + call aexpks (Mems[p1], O_VALS(in2), Mems[po], nelem) + else + call aexps (Mems[p1], Mems[p2], Mems[po], nelem) + + case CONCAT: + # Concatenate two numeric operands. + if (len1 <= 0) { + Mems[po] = O_VALS(in1) + po = po + 1 + } else { + call amovs (Mems[p1], Mems[po], len1) + po = po + len1 + } + if (len2 <= 0) + Mems[po] = O_VALS(in2) + else + call amovs (Mems[p2], Mems[po], len2) + + default: + call xvv_error (s_badswitch) + } + + case TY_INT: + switch (opcode) { + case PLUS: + if (len1 <= 0) { + O_VALI(out) = O_VALI(in1) + O_VALI(in2) + } else if (len2 <= 0) { + call aaddki (Memi[p1], O_VALI(in2), + Memi[po], nelem) + } else { + call aaddi (Memi[p1], Memi[p2], + Memi[po], nelem) + } + case MINUS: + if (len1 <= 0) + O_VALI(out) = O_VALI(in1) - O_VALI(in2) + else if (len2 <= 0) + call asubki (Memi[p1], O_VALI(in2), Memi[po], nelem) + else + call asubi (Memi[p1], Memi[p2], Memi[po], nelem) + + case STAR: + if (len1 <= 0) + O_VALI(out) = O_VALI(in1) * O_VALI(in2) + else if (len2 <= 0) + call amulki (Memi[p1], O_VALI(in2), Memi[po], nelem) + else + call amuli (Memi[p1], Memi[p2], Memi[po], nelem) + + case SLASH: + if (and (ev_flags, EV_RNGCHK) == 0) { + # No range checking. + if (len1 <= 0) + O_VALI(out) = O_VALI(in1) / O_VALI(in2) + else if (len2 <= 0) + call adivki (Memi[p1], O_VALI(in2), Memi[po], nelem) + else + call adivi (Memi[p1], Memi[p2], Memi[po], nelem) + } else { + # Check for divide by zero. + if (len1 <= 0) { + if (O_VALI(in2) == 0) + O_VALI(out) = xvv_nulli(0) + else + O_VALI(out) = O_VALI(in1) / O_VALI(in2) + } else if (len2 <= 0) { + if (O_VALI(in2) == 0) + call amovki (xvv_nulli(0), Memi[po], nelem) + else { + call adivki (Memi[p1], O_VALI(in2), Memi[po], + nelem) + } + } else { + call advzi (Memi[p1], Memi[p2], Memi[po], nelem, + xvv_nulli) + } + } + case EXPON: + if (len1 <= 0) + O_VALI(out) = O_VALI(in1) ** O_VALI(in2) + else if (len2 <= 0) + call aexpki (Memi[p1], O_VALI(in2), Memi[po], nelem) + else + call aexpi (Memi[p1], Memi[p2], Memi[po], nelem) + + case CONCAT: + # Concatenate two numeric operands. + if (len1 <= 0) { + Memi[po] = O_VALI(in1) + po = po + 1 + } else { + call amovi (Memi[p1], Memi[po], len1) + po = po + len1 + } + if (len2 <= 0) + Memi[po] = O_VALI(in2) + else + call amovi (Memi[p2], Memi[po], len2) + + default: + call xvv_error (s_badswitch) + } + + case TY_LONG: + switch (opcode) { + case PLUS: + if (len1 <= 0) { + O_VALL(out) = O_VALL(in1) + O_VALL(in2) + } else if (len2 <= 0) { + call aaddkl (Meml[p1], O_VALL(in2), + Meml[po], nelem) + } else { + call aaddl (Meml[p1], Meml[p2], + Meml[po], nelem) + } + case MINUS: + if (len1 <= 0) + O_VALL(out) = O_VALL(in1) - O_VALL(in2) + else if (len2 <= 0) + call asubkl (Meml[p1], O_VALL(in2), Meml[po], nelem) + else + call asubl (Meml[p1], Meml[p2], Meml[po], nelem) + + case STAR: + if (len1 <= 0) + O_VALL(out) = O_VALL(in1) * O_VALL(in2) + else if (len2 <= 0) + call amulkl (Meml[p1], O_VALL(in2), Meml[po], nelem) + else + call amull (Meml[p1], Meml[p2], Meml[po], nelem) + + case SLASH: + if (and (ev_flags, EV_RNGCHK) == 0) { + # No range checking. + if (len1 <= 0) + O_VALL(out) = O_VALL(in1) / O_VALL(in2) + else if (len2 <= 0) + call adivkl (Meml[p1], O_VALL(in2), Meml[po], nelem) + else + call adivl (Meml[p1], Meml[p2], Meml[po], nelem) + } else { + # Check for divide by zero. + if (len1 <= 0) { + if (O_VALL(in2) == 0) + O_VALL(out) = xvv_nulll(0) + else + O_VALL(out) = O_VALL(in1) / O_VALL(in2) + } else if (len2 <= 0) { + if (O_VALL(in2) == 0) + call amovkl (xvv_nulll(0), Meml[po], nelem) + else { + call adivkl (Meml[p1], O_VALL(in2), Meml[po], + nelem) + } + } else { + call advzl (Meml[p1], Meml[p2], Meml[po], nelem, + xvv_nulll) + } + } + case EXPON: + if (len1 <= 0) + O_VALL(out) = O_VALL(in1) ** O_VALL(in2) + else if (len2 <= 0) + call aexpkl (Meml[p1], O_VALL(in2), Meml[po], nelem) + else + call aexpl (Meml[p1], Meml[p2], Meml[po], nelem) + + case CONCAT: + # Concatenate two numeric operands. + if (len1 <= 0) { + Meml[po] = O_VALL(in1) + po = po + 1 + } else { + call amovl (Meml[p1], Meml[po], len1) + po = po + len1 + } + if (len2 <= 0) + Meml[po] = O_VALL(in2) + else + call amovl (Meml[p2], Meml[po], len2) + + default: + call xvv_error (s_badswitch) + } + + case TY_REAL: + switch (opcode) { + case PLUS: + if (len1 <= 0) { + O_VALR(out) = O_VALR(in1) + O_VALR(in2) + } else if (len2 <= 0) { + call aaddkr (Memr[p1], O_VALR(in2), + Memr[po], nelem) + } else { + call aaddr (Memr[p1], Memr[p2], + Memr[po], nelem) + } + case MINUS: + if (len1 <= 0) + O_VALR(out) = O_VALR(in1) - O_VALR(in2) + else if (len2 <= 0) + call asubkr (Memr[p1], O_VALR(in2), Memr[po], nelem) + else + call asubr (Memr[p1], Memr[p2], Memr[po], nelem) + + case STAR: + if (len1 <= 0) + O_VALR(out) = O_VALR(in1) * O_VALR(in2) + else if (len2 <= 0) + call amulkr (Memr[p1], O_VALR(in2), Memr[po], nelem) + else + call amulr (Memr[p1], Memr[p2], Memr[po], nelem) + + case SLASH: + if (and (ev_flags, EV_RNGCHK) == 0) { + # No range checking. + if (len1 <= 0) + O_VALR(out) = O_VALR(in1) / O_VALR(in2) + else if (len2 <= 0) + call adivkr (Memr[p1], O_VALR(in2), Memr[po], nelem) + else + call adivr (Memr[p1], Memr[p2], Memr[po], nelem) + } else { + # Check for divide by zero. + if (len1 <= 0) { + if (O_VALR(in2) == 0.0) + O_VALR(out) = xvv_nullr(0.0) + else + O_VALR(out) = O_VALR(in1) / O_VALR(in2) + } else if (len2 <= 0) { + if (O_VALR(in2) == 0.0) + call amovkr (xvv_nullr(0.0), Memr[po], nelem) + else { + call adivkr (Memr[p1], O_VALR(in2), Memr[po], + nelem) + } + } else { + call advzr (Memr[p1], Memr[p2], Memr[po], nelem, + xvv_nullr) + } + } + case EXPON: + if (len1 <= 0) + O_VALR(out) = O_VALR(in1) ** O_VALR(in2) + else if (len2 <= 0) + call aexpkr (Memr[p1], O_VALR(in2), Memr[po], nelem) + else + call aexpr (Memr[p1], Memr[p2], Memr[po], nelem) + + case CONCAT: + # Concatenate two numeric operands. + if (len1 <= 0) { + Memr[po] = O_VALR(in1) + po = po + 1 + } else { + call amovr (Memr[p1], Memr[po], len1) + po = po + len1 + } + if (len2 <= 0) + Memr[po] = O_VALR(in2) + else + call amovr (Memr[p2], Memr[po], len2) + + default: + call xvv_error (s_badswitch) + } + + case TY_DOUBLE: + switch (opcode) { + case PLUS: + if (len1 <= 0) { + O_VALD(out) = O_VALD(in1) + O_VALD(in2) + } else if (len2 <= 0) { + call aaddkd (Memd[p1], O_VALD(in2), + Memd[po], nelem) + } else { + call aaddd (Memd[p1], Memd[p2], + Memd[po], nelem) + } + case MINUS: + if (len1 <= 0) + O_VALD(out) = O_VALD(in1) - O_VALD(in2) + else if (len2 <= 0) + call asubkd (Memd[p1], O_VALD(in2), Memd[po], nelem) + else + call asubd (Memd[p1], Memd[p2], Memd[po], nelem) + + case STAR: + if (len1 <= 0) + O_VALD(out) = O_VALD(in1) * O_VALD(in2) + else if (len2 <= 0) + call amulkd (Memd[p1], O_VALD(in2), Memd[po], nelem) + else + call amuld (Memd[p1], Memd[p2], Memd[po], nelem) + + case SLASH: + if (and (ev_flags, EV_RNGCHK) == 0) { + # No range checking. + if (len1 <= 0) + O_VALD(out) = O_VALD(in1) / O_VALD(in2) + else if (len2 <= 0) + call adivkd (Memd[p1], O_VALD(in2), Memd[po], nelem) + else + call adivd (Memd[p1], Memd[p2], Memd[po], nelem) + } else { + # Check for divide by zero. + if (len1 <= 0) { + if (O_VALD(in2) == 0.0D0) + O_VALD(out) = xvv_nulld(0.0D0) + else + O_VALD(out) = O_VALD(in1) / O_VALD(in2) + } else if (len2 <= 0) { + if (O_VALD(in2) == 0.0D0) + call amovkd (xvv_nulld(0.0D0), Memd[po], nelem) + else { + call adivkd (Memd[p1], O_VALD(in2), Memd[po], + nelem) + } + } else { + call advzd (Memd[p1], Memd[p2], Memd[po], nelem, + xvv_nulld) + } + } + case EXPON: + if (len1 <= 0) + O_VALD(out) = O_VALD(in1) ** O_VALD(in2) + else if (len2 <= 0) + call aexpkd (Memd[p1], O_VALD(in2), Memd[po], nelem) + else + call aexpd (Memd[p1], Memd[p2], Memd[po], nelem) + + case CONCAT: + # Concatenate two numeric operands. + if (len1 <= 0) { + Memd[po] = O_VALD(in1) + po = po + 1 + } else { + call amovd (Memd[p1], Memd[po], len1) + po = po + len1 + } + if (len2 <= 0) + Memd[po] = O_VALD(in2) + else + call amovd (Memd[p2], Memd[po], len2) + + default: + call xvv_error (s_badswitch) + } + + default: + call xvv_error (s_badswitch) + } +done_ + # Free any storage in input operands. + call xvv_freeop (in1) + call xvv_freeop (in2) +end + + +# XVV_BOOLOP -- Boolean (actually logical) binary operations. Perform the +# indicated logical operation on the two input operands, returning the result +# as the output operand. The opcodes implemented by this routine are +# characterized by the fact that they all return a logical result (YES or NO +# physically expressed as an integer). + +procedure xvv_boolop (opcode, in1, in2, out) + +int opcode #I operation to be performed +pointer in1, in2 #I input operands +pointer out #I output operand + + +short v_s + +int v_i + +long v_l + +real v_r + +double v_d + +pointer sp, otemp, p1, p2, po +int dtype, nelem, len1, len2 +int xvv_newtype(), xvv_patmatch(), strncmp(), btoi() +errchk xvv_newtype, xvv_initop, xvv_chtype, xvv_error +string s_badop "boolop: illegal operation" +string s_badswitch "boolop: illegal switch" + +begin + # Boolean operands are treated as integer within this routine. + if (O_TYPE(in1) == TY_BOOL) + O_TYPE(in1) = TY_INT + if (O_TYPE(in2) == TY_BOOL) + O_TYPE(in2) = TY_INT + + # Determine the computation type for the operation, i.e., the type + # both input operands must have. This is not the same as the type + # of the output operand, which is always boolean for the operations + # implemented by this routine. + + dtype = xvv_newtype (O_TYPE(in1), O_TYPE(in2)) + + # Compute the size of the output operand. If both input operands are + # vectors the length of the output vector is the shorter of the two. + + if (dtype == TY_CHAR) + nelem = 0 + else { + if (O_LEN(in1) > 0 && O_LEN(in2) > 0) + nelem = min (O_LEN(in1), O_LEN(in2)) + else if (O_LEN(in1) > 0) + nelem = O_LEN(in1) + else if (O_LEN(in2) > 0) + nelem = O_LEN(in2) + else + nelem = 0 + } + + # Convert input operands to desired computation type. + if (O_TYPE(in1) != dtype) + call xvv_chtype (in1, in1, dtype) + if (O_TYPE(in2) != dtype) + call xvv_chtype (in2, in2, dtype) + + # If this is a scalar/vector operation make sure the vector is the + # first operand. + + len1 = O_LEN(in1) + len2 = O_LEN(in2) + + if (len1 == 0 && len2 > 0) { + switch (opcode) { + case EQ, NE: + call smark (sp) + call salloc (otemp, LEN_OPERAND, TY_STRUCT) + YYMOVE (in1, otemp) + YYMOVE (in2, in1) + YYMOVE (otemp, in2) + call sfree (sp) + default: + # Promote operand to a constant vector. Inefficient, but + # better than aborting. + + switch (dtype) { + + case TY_SHORT: + v_s = O_VALS(in1) + call xvv_initop (in1, nelem, dtype) + call amovks (v_s, Mems[O_VALP(in1)], nelem) + + case TY_INT: + v_i = O_VALI(in1) + call xvv_initop (in1, nelem, dtype) + call amovki (v_i, Memi[O_VALP(in1)], nelem) + + case TY_LONG: + v_l = O_VALL(in1) + call xvv_initop (in1, nelem, dtype) + call amovkl (v_l, Meml[O_VALP(in1)], nelem) + + case TY_REAL: + v_r = O_VALR(in1) + call xvv_initop (in1, nelem, dtype) + call amovkr (v_r, Memr[O_VALP(in1)], nelem) + + case TY_DOUBLE: + v_d = O_VALD(in1) + call xvv_initop (in1, nelem, dtype) + call amovkd (v_d, Memd[O_VALP(in1)], nelem) + + } + } + + len1 = O_LEN(in1) + len2 = O_LEN(in2) + } + + # Initialize the output operand. + call xvv_initop (out, nelem, TY_BOOL) + + p1 = O_VALP(in1) + p2 = O_VALP(in2) + po = O_VALP(out) + + # Perform the operation. + if (dtype == TY_CHAR) { + # Character data is a special case. + + switch (opcode) { + case SE: + O_VALI(out) = btoi(xvv_patmatch (O_VALC(in1), O_VALC(in2)) > 0) + case LT: + O_VALI(out) = btoi(strncmp (O_VALC(in1), O_VALC(in2), ARB) < 0) + case LE: + O_VALI(out) = btoi(strncmp (O_VALC(in1), O_VALC(in2), ARB) <= 0) + case GT: + O_VALI(out) = btoi(strncmp (O_VALC(in1), O_VALC(in2), ARB) > 0) + case GE: + O_VALI(out) = btoi(strncmp (O_VALC(in1), O_VALC(in2), ARB) >= 0) + case EQ: + O_VALI(out) = btoi(strncmp (O_VALC(in1), O_VALC(in2), ARB) == 0) + case NE: + O_VALI(out) = btoi(strncmp (O_VALC(in1), O_VALC(in2), ARB) != 0) + default: + call xvv_error (s_badop) + } + + } else if (opcode == LAND || opcode == LOR) { + # Operations supporting only the integer types. + + switch (dtype) { + + case TY_SHORT: + switch (opcode) { + case LAND: + if (len1 <= 0) { + O_VALI(out) = + btoi (O_VALS(in1) != 0 && O_VALS(in2) != 0) + } else if (len2 <= 0) { + call alanks (Mems[p1], O_VALS(in2), Memi[po], nelem) + } else + call alans (Mems[p1], Mems[p2], Memi[po], nelem) + case LOR: + if (len1 <= 0) { + O_VALI(out) = + btoi (O_VALS(in1) != 0 || O_VALS(in2) != 0) + } else if (len2 <= 0) { + call alorks (Mems[p1], O_VALS(in2), Memi[po], nelem) + } else + call alors (Mems[p1], Mems[p2], Memi[po], nelem) + default: + call xvv_error (s_badop) + } + + case TY_INT: + switch (opcode) { + case LAND: + if (len1 <= 0) { + O_VALI(out) = + btoi (O_VALI(in1) != 0 && O_VALI(in2) != 0) + } else if (len2 <= 0) { + call alanki (Memi[p1], O_VALI(in2), Memi[po], nelem) + } else + call alani (Memi[p1], Memi[p2], Memi[po], nelem) + case LOR: + if (len1 <= 0) { + O_VALI(out) = + btoi (O_VALI(in1) != 0 || O_VALI(in2) != 0) + } else if (len2 <= 0) { + call alorki (Memi[p1], O_VALI(in2), Memi[po], nelem) + } else + call alori (Memi[p1], Memi[p2], Memi[po], nelem) + default: + call xvv_error (s_badop) + } + + case TY_LONG: + switch (opcode) { + case LAND: + if (len1 <= 0) { + O_VALI(out) = + btoi (O_VALL(in1) != 0 && O_VALL(in2) != 0) + } else if (len2 <= 0) { + call alankl (Meml[p1], O_VALL(in2), Memi[po], nelem) + } else + call alanl (Meml[p1], Meml[p2], Memi[po], nelem) + case LOR: + if (len1 <= 0) { + O_VALI(out) = + btoi (O_VALL(in1) != 0 || O_VALL(in2) != 0) + } else if (len2 <= 0) { + call alorkl (Meml[p1], O_VALL(in2), Memi[po], nelem) + } else + call alorl (Meml[p1], Meml[p2], Memi[po], nelem) + default: + call xvv_error (s_badop) + } + + default: + call xvv_error (s_badswitch) + } + } else { + # Operations supporting any arithmetic type. + + switch (dtype) { + + case TY_SHORT: + switch (opcode) { + case LT: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALS(in1) < O_VALS(in2)) + else if (len2 <= 0) + call abltks (Mems[p1], O_VALS(in2), Memi[po], nelem) + else + call ablts (Mems[p1], Mems[p2], Memi[po], nelem) + + case LE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALS(in1) <= O_VALS(in2)) + else if (len2 <= 0) + call ableks (Mems[p1], O_VALS(in2), Memi[po], nelem) + else + call ables (Mems[p1], Mems[p2], Memi[po], nelem) + + case GT: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALS(in1) > O_VALS(in2)) + else if (len2 <= 0) + call abgtks (Mems[p1], O_VALS(in2), Memi[po], nelem) + else + call abgts (Mems[p1], Mems[p2], Memi[po], nelem) + + case GE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALS(in1) >= O_VALS(in2)) + else if (len2 <= 0) + call abgeks (Mems[p1], O_VALS(in2), Memi[po], nelem) + else + call abges (Mems[p1], Mems[p2], Memi[po], nelem) + + case EQ: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALS(in1) == O_VALS(in2)) + else if (len2 <= 0) + call abeqks (Mems[p1], O_VALS(in2), Memi[po], nelem) + else + call abeqs (Mems[p1], Mems[p2], Memi[po], nelem) + + case NE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALS(in1) != O_VALS(in2)) + else if (len2 <= 0) + call abneks (Mems[p1], O_VALS(in2), Memi[po], nelem) + else + call abnes (Mems[p1], Mems[p2], Memi[po], nelem) + + default: + call xvv_error (s_badop) + } + + case TY_INT: + switch (opcode) { + case LT: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALI(in1) < O_VALI(in2)) + else if (len2 <= 0) + call abltki (Memi[p1], O_VALI(in2), Memi[po], nelem) + else + call ablti (Memi[p1], Memi[p2], Memi[po], nelem) + + case LE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALI(in1) <= O_VALI(in2)) + else if (len2 <= 0) + call ableki (Memi[p1], O_VALI(in2), Memi[po], nelem) + else + call ablei (Memi[p1], Memi[p2], Memi[po], nelem) + + case GT: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALI(in1) > O_VALI(in2)) + else if (len2 <= 0) + call abgtki (Memi[p1], O_VALI(in2), Memi[po], nelem) + else + call abgti (Memi[p1], Memi[p2], Memi[po], nelem) + + case GE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALI(in1) >= O_VALI(in2)) + else if (len2 <= 0) + call abgeki (Memi[p1], O_VALI(in2), Memi[po], nelem) + else + call abgei (Memi[p1], Memi[p2], Memi[po], nelem) + + case EQ: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALI(in1) == O_VALI(in2)) + else if (len2 <= 0) + call abeqki (Memi[p1], O_VALI(in2), Memi[po], nelem) + else + call abeqi (Memi[p1], Memi[p2], Memi[po], nelem) + + case NE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALI(in1) != O_VALI(in2)) + else if (len2 <= 0) + call abneki (Memi[p1], O_VALI(in2), Memi[po], nelem) + else + call abnei (Memi[p1], Memi[p2], Memi[po], nelem) + + default: + call xvv_error (s_badop) + } + + case TY_LONG: + switch (opcode) { + case LT: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALL(in1) < O_VALL(in2)) + else if (len2 <= 0) + call abltkl (Meml[p1], O_VALL(in2), Memi[po], nelem) + else + call abltl (Meml[p1], Meml[p2], Memi[po], nelem) + + case LE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALL(in1) <= O_VALL(in2)) + else if (len2 <= 0) + call ablekl (Meml[p1], O_VALL(in2), Memi[po], nelem) + else + call ablel (Meml[p1], Meml[p2], Memi[po], nelem) + + case GT: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALL(in1) > O_VALL(in2)) + else if (len2 <= 0) + call abgtkl (Meml[p1], O_VALL(in2), Memi[po], nelem) + else + call abgtl (Meml[p1], Meml[p2], Memi[po], nelem) + + case GE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALL(in1) >= O_VALL(in2)) + else if (len2 <= 0) + call abgekl (Meml[p1], O_VALL(in2), Memi[po], nelem) + else + call abgel (Meml[p1], Meml[p2], Memi[po], nelem) + + case EQ: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALL(in1) == O_VALL(in2)) + else if (len2 <= 0) + call abeqkl (Meml[p1], O_VALL(in2), Memi[po], nelem) + else + call abeql (Meml[p1], Meml[p2], Memi[po], nelem) + + case NE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALL(in1) != O_VALL(in2)) + else if (len2 <= 0) + call abnekl (Meml[p1], O_VALL(in2), Memi[po], nelem) + else + call abnel (Meml[p1], Meml[p2], Memi[po], nelem) + + default: + call xvv_error (s_badop) + } + + case TY_REAL: + switch (opcode) { + case LT: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALR(in1) < O_VALR(in2)) + else if (len2 <= 0) + call abltkr (Memr[p1], O_VALR(in2), Memi[po], nelem) + else + call abltr (Memr[p1], Memr[p2], Memi[po], nelem) + + case LE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALR(in1) <= O_VALR(in2)) + else if (len2 <= 0) + call ablekr (Memr[p1], O_VALR(in2), Memi[po], nelem) + else + call abler (Memr[p1], Memr[p2], Memi[po], nelem) + + case GT: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALR(in1) > O_VALR(in2)) + else if (len2 <= 0) + call abgtkr (Memr[p1], O_VALR(in2), Memi[po], nelem) + else + call abgtr (Memr[p1], Memr[p2], Memi[po], nelem) + + case GE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALR(in1) >= O_VALR(in2)) + else if (len2 <= 0) + call abgekr (Memr[p1], O_VALR(in2), Memi[po], nelem) + else + call abger (Memr[p1], Memr[p2], Memi[po], nelem) + + case EQ: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALR(in1) == O_VALR(in2)) + else if (len2 <= 0) + call abeqkr (Memr[p1], O_VALR(in2), Memi[po], nelem) + else + call abeqr (Memr[p1], Memr[p2], Memi[po], nelem) + + case NE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALR(in1) != O_VALR(in2)) + else if (len2 <= 0) + call abnekr (Memr[p1], O_VALR(in2), Memi[po], nelem) + else + call abner (Memr[p1], Memr[p2], Memi[po], nelem) + + default: + call xvv_error (s_badop) + } + + case TY_DOUBLE: + switch (opcode) { + case LT: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALD(in1) < O_VALD(in2)) + else if (len2 <= 0) + call abltkd (Memd[p1], O_VALD(in2), Memi[po], nelem) + else + call abltd (Memd[p1], Memd[p2], Memi[po], nelem) + + case LE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALD(in1) <= O_VALD(in2)) + else if (len2 <= 0) + call ablekd (Memd[p1], O_VALD(in2), Memi[po], nelem) + else + call abled (Memd[p1], Memd[p2], Memi[po], nelem) + + case GT: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALD(in1) > O_VALD(in2)) + else if (len2 <= 0) + call abgtkd (Memd[p1], O_VALD(in2), Memi[po], nelem) + else + call abgtd (Memd[p1], Memd[p2], Memi[po], nelem) + + case GE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALD(in1) >= O_VALD(in2)) + else if (len2 <= 0) + call abgekd (Memd[p1], O_VALD(in2), Memi[po], nelem) + else + call abged (Memd[p1], Memd[p2], Memi[po], nelem) + + case EQ: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALD(in1) == O_VALD(in2)) + else if (len2 <= 0) + call abeqkd (Memd[p1], O_VALD(in2), Memi[po], nelem) + else + call abeqd (Memd[p1], Memd[p2], Memi[po], nelem) + + case NE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALD(in1) != O_VALD(in2)) + else if (len2 <= 0) + call abnekd (Memd[p1], O_VALD(in2), Memi[po], nelem) + else + call abned (Memd[p1], Memd[p2], Memi[po], nelem) + + default: + call xvv_error (s_badop) + } + + default: + call xvv_error (s_badswitch) + } + } + + # Free any storage in input operands. + call xvv_freeop (in1) + call xvv_freeop (in2) +end + + +# XVV_PATMATCH -- Match a string against a pattern, returning the patmatch +# index if the string matches. The pattern may contain any of the conventional +# pattern matching metacharacters. Closure (i.e., "*") is mapped to "?*". + +int procedure xvv_patmatch (str, pat) + +char str[ARB] #I operand string +char pat[ARB] #I pattern + +int junk, ip, index +pointer sp, patstr, patbuf, op +int patmake(), patmatch() + +begin + call smark (sp) + call salloc (patstr, SZ_FNAME, TY_CHAR) + call salloc (patbuf, SZ_LINE, TY_CHAR) + call aclrc (Memc[patstr], SZ_FNAME) + call aclrc (Memc[patbuf], SZ_LINE) + + # Map pattern, changing '*' into '?*'. + op = patstr + for (ip=1; pat[ip] != EOS; ip=ip+1) { + if (pat[ip] == '*') { + Memc[op] = '?' + op = op + 1 + } + Memc[op] = pat[ip] + op = op + 1 + } + + # Encode pattern. + junk = patmake (Memc[patstr], Memc[patbuf], SZ_LINE) + + # Perform the pattern matching operation. + index = patmatch (str, Memc[patbuf]) + + call sfree (sp) + return (index) +end + + +# XVV_NEWTYPE -- Get the datatype of a binary operation, given the datatypes +# of the two input operands. An error action is taken if the datatypes are +# incompatible, e.g., boolean and anything else or string and anything else. + +int procedure xvv_newtype (type1, type2) + +int type1 #I datatype of first operand +int type2 #I datatype of second operand + +int newtype, p, q, i +int tyindex[NTYPES], ttbl[NTYPES*NTYPES] +data tyindex /T_B, T_C, T_S, T_I, T_L, T_R, T_D/ + +data (ttbl(i),i= 1, 7) /T_B, 0, 0, 0, 0, 0, 0/ +data (ttbl(i),i= 8,14) / 0, T_C, 0, 0, 0, 0, 0/ +data (ttbl(i),i=15,21) / 0, 0, T_S, T_I, T_L, T_R, T_D/ +data (ttbl(i),i=22,28) / 0, 0, T_I, T_I, T_L, T_R, T_D/ +data (ttbl(i),i=29,35) / 0, 0, T_L, T_L, T_L, T_R, T_D/ +data (ttbl(i),i=36,42) / 0, 0, T_R, T_R, T_R, T_R, T_D/ +data (ttbl(i),i=43,49) / 0, 0, T_D, T_D, T_D, T_D, T_D/ + +begin + do i = 1, NTYPES { + if (tyindex[i] == type1) + p = i + if (tyindex[i] == type2) + q = i + } + + newtype = ttbl[(p-1)*NTYPES+q] + if (newtype == 0) + call xvv_error ("operands have incompatible types") + else + return (newtype) +end + + +# XVV_QUEST -- Conditional expression. If the condition operand is true +# return the first (true) operand, else return the second (false) operand. + +procedure xvv_quest (cond, in1, in2, out) + +pointer cond #I pointer to condition operand +pointer in1, in2 #I pointer to true,false operands +pointer out #I pointer to output operand + +int dtype, nelem, i +pointer sp, otemp, ip1, ip2, op, sel +errchk xvv_error, xvv_newtype, xvv_initop, xvv_chtype +int xvv_newtype(), btoi() + +begin + switch (O_TYPE(cond)) { + case TY_BOOL, TY_INT: + ; + case TY_SHORT, TY_LONG: + call xvv_chtype (cond, cond, TY_BOOL) + default: + call xvv_error ("evvexpr: nonboolean condition operand") + } + + if (O_LEN(cond) <= 0 && + (O_LEN(in1) <= 0 || O_TYPE(in1) == TY_CHAR) && + (O_LEN(in2) <= 0 || O_TYPE(in2) == TY_CHAR)) { + + # Both operands and the conditional are scalars; the expression + # type is the type of the selected operand. + + if (O_VALI(cond) != 0) { + YYMOVE (in1, out) + call xvv_freeop (in2) + } else { + YYMOVE (in2, out) + call xvv_freeop (in1) + } + + } else if (O_TYPE(in1) == TY_CHAR || O_TYPE(in2) == TY_CHAR) { + # This combination is not legal. + call xvv_error ("evvexpr: character and vector in cond expr") + + } else { + # Vector/scalar or vector/vector operation. Both operands must + # be of the same type. + + dtype = xvv_newtype (O_TYPE(in1), O_TYPE(in2)) + + # Compute the size of the output operand. If both input operands + # are vectors the length of the output vector is the shorter of + # the two. The condition operand contributes to the dimension of + # the expression result, although not to the datatype. + + nelem = 0 + if (O_LEN(in1) > 0 && O_LEN(in2) > 0) + nelem = min (O_LEN(in1), O_LEN(in2)) + else if (O_LEN(in1) > 0) + nelem = O_LEN(in1) + else if (O_LEN(in2) > 0) + nelem = O_LEN(in2) + + if (O_LEN(cond) > 0 && nelem > 0) + nelem = min (O_LEN(cond), nelem) + else if (O_LEN(cond) > 0) + nelem = O_LEN(cond) + + # If this is a scalar/vector operation make sure the vector is the + # first operand. + + if (O_LEN(in1) == 0 && O_LEN(in2) > 0) { + call smark (sp) + call salloc (otemp, LEN_OPERAND, TY_STRUCT) + YYMOVE (in1, otemp) + YYMOVE (in2, in1) + YYMOVE (otemp, in2) + call sfree (sp) + + # Since we are swapping arguments we need to negate the cond. + if (O_LEN(cond) <= 0) + O_VALI(cond) = btoi (O_VALI(cond) == 0) + else { + call abeqki (Memi[O_VALP(cond)], NO, Memi[O_VALP(cond)], + nelem) + } + } + + # Initialize the output operand. + call xvv_initop (out, nelem, dtype) + + # Convert input operands to desired computation type. + if (O_TYPE(in1) != dtype) + call xvv_chtype (in1, in1, dtype) + if (O_TYPE(in2) != dtype) + call xvv_chtype (in2, in2, dtype) + + ip1 = O_VALP(in1) + ip2 = O_VALP(in2) + op = O_VALP(out) + sel = O_VALP(cond) + + # Perform the operation. + switch (dtype) { + + case TY_SHORT: + if (O_LEN(in1) <= 0 && O_LEN(in2) <= 0) { + # Vector conditional, both operands are scalars. + do i = 1, nelem + if (Memi[sel+i-1] != 0) + Mems[op+i-1] = O_VALS(in1) + else + Mems[op+i-1] = O_VALS(in2) + + } else if (O_LEN(in2) <= 0) { + # Operand 1 is a vector, operand 2 is a scalar. + if (O_LEN(cond) <= 0) { + # Conditional is a scalar. + if (O_VALI(cond) != 0) + call amovs (Mems[ip1], Mems[op], nelem) + else + call amovks (O_VALS(in2), Mems[op], nelem) + } else { + # Conditional is a vector. + call aselks (Mems[ip1], O_VALS(in2), Mems[op], + Memi[sel], nelem) + } + } else { + # Both operands are vectors. + if (O_LEN(cond) <= 0) { + # Conditional is a scalar. + if (O_VALI(cond) != 0) + call amovs (Mems[ip1], Mems[op], nelem) + else + call amovs (Mems[ip2], Mems[op], nelem) + } else { + # Conditional is a vector. + call asels (Mems[ip1], Mems[ip2], Mems[op], + Memi[sel], nelem) + } + } + + case TY_INT: + if (O_LEN(in1) <= 0 && O_LEN(in2) <= 0) { + # Vector conditional, both operands are scalars. + do i = 1, nelem + if (Memi[sel+i-1] != 0) + Memi[op+i-1] = O_VALI(in1) + else + Memi[op+i-1] = O_VALI(in2) + + } else if (O_LEN(in2) <= 0) { + # Operand 1 is a vector, operand 2 is a scalar. + if (O_LEN(cond) <= 0) { + # Conditional is a scalar. + if (O_VALI(cond) != 0) + call amovi (Memi[ip1], Memi[op], nelem) + else + call amovki (O_VALI(in2), Memi[op], nelem) + } else { + # Conditional is a vector. + call aselki (Memi[ip1], O_VALI(in2), Memi[op], + Memi[sel], nelem) + } + } else { + # Both operands are vectors. + if (O_LEN(cond) <= 0) { + # Conditional is a scalar. + if (O_VALI(cond) != 0) + call amovi (Memi[ip1], Memi[op], nelem) + else + call amovi (Memi[ip2], Memi[op], nelem) + } else { + # Conditional is a vector. + call aseli (Memi[ip1], Memi[ip2], Memi[op], + Memi[sel], nelem) + } + } + + case TY_LONG: + if (O_LEN(in1) <= 0 && O_LEN(in2) <= 0) { + # Vector conditional, both operands are scalars. + do i = 1, nelem + if (Memi[sel+i-1] != 0) + Meml[op+i-1] = O_VALL(in1) + else + Meml[op+i-1] = O_VALL(in2) + + } else if (O_LEN(in2) <= 0) { + # Operand 1 is a vector, operand 2 is a scalar. + if (O_LEN(cond) <= 0) { + # Conditional is a scalar. + if (O_VALI(cond) != 0) + call amovl (Meml[ip1], Meml[op], nelem) + else + call amovkl (O_VALL(in2), Meml[op], nelem) + } else { + # Conditional is a vector. + call aselkl (Meml[ip1], O_VALL(in2), Meml[op], + Memi[sel], nelem) + } + } else { + # Both operands are vectors. + if (O_LEN(cond) <= 0) { + # Conditional is a scalar. + if (O_VALI(cond) != 0) + call amovl (Meml[ip1], Meml[op], nelem) + else + call amovl (Meml[ip2], Meml[op], nelem) + } else { + # Conditional is a vector. + call asell (Meml[ip1], Meml[ip2], Meml[op], + Memi[sel], nelem) + } + } + + case TY_REAL: + if (O_LEN(in1) <= 0 && O_LEN(in2) <= 0) { + # Vector conditional, both operands are scalars. + do i = 1, nelem + if (Memi[sel+i-1] != 0) + Memr[op+i-1] = O_VALR(in1) + else + Memr[op+i-1] = O_VALR(in2) + + } else if (O_LEN(in2) <= 0) { + # Operand 1 is a vector, operand 2 is a scalar. + if (O_LEN(cond) <= 0) { + # Conditional is a scalar. + if (O_VALI(cond) != 0) + call amovr (Memr[ip1], Memr[op], nelem) + else + call amovkr (O_VALR(in2), Memr[op], nelem) + } else { + # Conditional is a vector. + call aselkr (Memr[ip1], O_VALR(in2), Memr[op], + Memi[sel], nelem) + } + } else { + # Both operands are vectors. + if (O_LEN(cond) <= 0) { + # Conditional is a scalar. + if (O_VALI(cond) != 0) + call amovr (Memr[ip1], Memr[op], nelem) + else + call amovr (Memr[ip2], Memr[op], nelem) + } else { + # Conditional is a vector. + call aselr (Memr[ip1], Memr[ip2], Memr[op], + Memi[sel], nelem) + } + } + + case TY_DOUBLE: + if (O_LEN(in1) <= 0 && O_LEN(in2) <= 0) { + # Vector conditional, both operands are scalars. + do i = 1, nelem + if (Memi[sel+i-1] != 0) + Memd[op+i-1] = O_VALD(in1) + else + Memd[op+i-1] = O_VALD(in2) + + } else if (O_LEN(in2) <= 0) { + # Operand 1 is a vector, operand 2 is a scalar. + if (O_LEN(cond) <= 0) { + # Conditional is a scalar. + if (O_VALI(cond) != 0) + call amovd (Memd[ip1], Memd[op], nelem) + else + call amovkd (O_VALD(in2), Memd[op], nelem) + } else { + # Conditional is a vector. + call aselkd (Memd[ip1], O_VALD(in2), Memd[op], + Memi[sel], nelem) + } + } else { + # Both operands are vectors. + if (O_LEN(cond) <= 0) { + # Conditional is a scalar. + if (O_VALI(cond) != 0) + call amovd (Memd[ip1], Memd[op], nelem) + else + call amovd (Memd[ip2], Memd[op], nelem) + } else { + # Conditional is a vector. + call aseld (Memd[ip1], Memd[ip2], Memd[op], + Memi[sel], nelem) + } + } + + default: + call xvv_error ("evvexpr: bad datatype in cond expr") + } + + call xvv_freeop (in1) + call xvv_freeop (in2) + } + + call xvv_freeop (cond) +end + + +# XVV_CALLFCN -- Call an intrinsic function. If the function named is not +# one of the standard intrinsic functions, call an external user function +# if a function call procedure was supplied. + +procedure xvv_callfcn (fcn, args, nargs, out) + +char fcn[ARB] #I function to be called +pointer args[ARB] #I pointer to arglist descriptor +int nargs #I number of arguments +pointer out #I output operand (function value) + + +short v_s +short ahivs(), alovs() +short ameds() +int aravs() + +int v_i +int ahivi(), alovi() +int amedi() +int aravi() + +long v_l +long ahivl(), alovl() +long amedl() +int aravl() + +real v_r +real ahivr(), alovr() +real amedr() +int aravr() + +double v_d +double ahivd(), alovd() +double amedd() +int aravd() + + +real mean_r, sigma_r +double mean_d, sigma_d +real asums(), asumi(), asumr() +double asuml(), asumd() + +bool rangecheck +int optype, opcode +int chunk, repl, nelem, v_nargs, ch, shift, i, j +pointer sp, sym, buf, ap, ip, op, in1, in2 +include "evvexpr.com" + +pointer stfind() +int xvv_newtype(), strlen(), gctod(), btoi() +errchk xvv_chtype, xvv_initop, xvv_newtype, xvv_error1, xvv_error2 +errchk zcall5, malloc + +string s_badtype "%s: illegal operand type" +define free_ 91 + +begin + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + + # Lookup the function name in the symbol table. + sym = stfind (ev_st, fcn) + if (sym != NULL) + opcode = SYM_CODE(sym) + else + opcode = 0 + + # If the function named is not a standard one and the user has supplied + # the entry point of an external function evaluation procedure, call + # the user procedure to evaluate the function, otherwise abort. + + if (opcode <= 0) + if (ev_ufcn != NULL) { + call zcall5 (ev_ufcn, ev_ufcn_data, fcn, args, nargs, out) + if (O_TYPE(out) <= 0) + call xvv_error1 ("unrecognized macro or function `%s'", fcn) + goto free_ + } else + call xvv_error1 ("unknown function `%s' called", fcn) + + # Range checking on functions that need it? + rangecheck = (and (ev_flags, EV_RNGCHK) != 0) + + # Verify correct number of arguments. + switch (opcode) { + case F_MOD, F_REPL, F_SHIFT: + v_nargs = 2 + case F_MAX, F_MIN, F_ATAN, F_ATAN2, F_MEAN, F_STDDEV, F_MEDIAN: + v_nargs = -1 + default: + v_nargs = 1 + } + if (v_nargs > 0 && nargs != v_nargs) + call xvv_error2 ("function `%s' requires %d arguments", + fcn, v_nargs) + else if (v_nargs < 0 && nargs < abs(v_nargs)) + call xvv_error2 ("function `%s' requires at least %d arguments", + fcn, abs(v_nargs)) + + # Some functions require that the input operand be a certain type, + # e.g. floating. Handle the simple cases, converting input operands + # to the desired type. + + switch (opcode) { + case F_ACOS, F_ASIN, F_ATAN, F_ATAN2, F_COS, F_COSH, F_DEG, F_EXP, + F_LOG, F_LOG10, F_RAD, F_SIN, F_SINH, F_SQRT, F_TAN, F_TANH: + + # These functions want a floating point input operand. + optype = TY_REAL + do i = 1, nargs { + if (O_TYPE(args[i]) == TY_DOUBLE || O_TYPE(args[i]) == TY_LONG) + optype = TY_DOUBLE + } + do i = 1, nargs { + if (O_TYPE(args[i]) != optype) + call xvv_chtype (args[i], args[i], optype) + } + call xvv_initop (out, O_LEN(args[1]), optype) + + case F_MOD, F_MIN, F_MAX, F_MEDIAN: + # These functions may have multiple arguments, all of which + # should be the same type. + + optype = O_TYPE(args[1]) + nelem = O_LEN(args[1]) + do i = 2, nargs { + optype = xvv_newtype (optype, O_TYPE(args[i])) + if (O_LEN(args[i]) > 0) + if (nelem > 0) + nelem = min (nelem, O_LEN(args[i])) + else if (nelem == 0) + nelem = O_LEN(args[i]) + } + + do i = 1, nargs + if (O_TYPE(args[i]) != optype) + call xvv_chtype (args[i], args[i], optype) + + if (nargs == 1 && opcode == F_MEDIAN) + nelem = 0 + call xvv_initop (out, nelem, optype) + + case F_LEN: + # This function always returns an integer scalar value. + nelem = 0 + optype = TY_INT + call xvv_initop (out, nelem, optype) + + case F_HIV, F_LOV: + # These functions return a scalar value. + nelem = 0 + optype = O_TYPE(args[1]) + if (optype == TY_BOOL) + optype = TY_INT + call xvv_initop (out, nelem, optype) + + case F_SUM, F_MEAN, F_STDDEV: + # These functions require a vector argument and return a scalar + # value. + + nelem = 0 + optype = O_TYPE(args[1]) + if (optype == TY_BOOL) + optype = TY_INT + + if (optype == TY_DOUBLE) + call xvv_initop (out, nelem, TY_DOUBLE) + else + call xvv_initop (out, nelem, TY_REAL) + + case F_SORT, F_SHIFT: + # Vector to vector, no type conversions. + nelem = O_LEN(args[1]) + optype = O_TYPE(args[1]) + call xvv_initop (out, nelem, optype) + + default: + optype = 0 + } + + # Evaluate the function. + ap = args[1] + + switch (opcode) { + case F_ABS: + call xvv_initop (out, O_LEN(ap), O_TYPE(ap)) + switch (O_TYPE(ap)) { + + case TY_SHORT: + if (O_LEN(ap) > 0) { + call aabss (Mems[O_VALP(ap)], Mems[O_VALP(out)], + O_LEN(ap)) + } else + O_VALS(out) = abs(O_VALS(ap)) + + case TY_INT: + if (O_LEN(ap) > 0) { + call aabsi (Memi[O_VALP(ap)], Memi[O_VALP(out)], + O_LEN(ap)) + } else + O_VALI(out) = abs(O_VALI(ap)) + + case TY_LONG: + if (O_LEN(ap) > 0) { + call aabsl (Meml[O_VALP(ap)], Meml[O_VALP(out)], + O_LEN(ap)) + } else + O_VALL(out) = abs(O_VALL(ap)) + + case TY_REAL: + if (O_LEN(ap) > 0) { + call aabsr (Memr[O_VALP(ap)], Memr[O_VALP(out)], + O_LEN(ap)) + } else + O_VALR(out) = abs(O_VALR(ap)) + + case TY_DOUBLE: + if (O_LEN(ap) > 0) { + call aabsd (Memd[O_VALP(ap)], Memd[O_VALP(out)], + O_LEN(ap)) + } else + O_VALD(out) = abs(O_VALD(ap)) + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_ACOS: + + if (optype == TY_REAL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memr[O_VALP(out)+i-1] = acos (Memr[O_VALP(ap)+i-1]) + } else + O_VALR(out) = acos (O_VALR(ap)) + + if (optype == TY_DOUBLE) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memd[O_VALP(out)+i-1] = acos (Memd[O_VALP(ap)+i-1]) + } else + O_VALD(out) = acos (O_VALD(ap)) + + case F_ASIN: + + if (optype == TY_REAL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memr[O_VALP(out)+i-1] = asin (Memr[O_VALP(ap)+i-1]) + } else + O_VALR(out) = asin (O_VALR(ap)) + + if (optype == TY_DOUBLE) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memd[O_VALP(out)+i-1] = asin (Memd[O_VALP(ap)+i-1]) + } else + O_VALD(out) = asin (O_VALD(ap)) + + case F_COS: + + if (optype == TY_REAL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memr[O_VALP(out)+i-1] = cos (Memr[O_VALP(ap)+i-1]) + } else + O_VALR(out) = cos (O_VALR(ap)) + + if (optype == TY_DOUBLE) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memd[O_VALP(out)+i-1] = cos (Memd[O_VALP(ap)+i-1]) + } else + O_VALD(out) = cos (O_VALD(ap)) + + case F_COSH: + + if (optype == TY_REAL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memr[O_VALP(out)+i-1] = cosh (Memr[O_VALP(ap)+i-1]) + } else + O_VALR(out) = cosh (O_VALR(ap)) + + if (optype == TY_DOUBLE) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memd[O_VALP(out)+i-1] = cosh (Memd[O_VALP(ap)+i-1]) + } else + O_VALD(out) = cosh (O_VALD(ap)) + + case F_DEG: + + if (optype == TY_REAL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memr[O_VALP(out)+i-1] = RADTODEG(Memr[O_VALP(ap)+i-1]) + } else + O_VALR(out) = RADTODEG (O_VALR(ap)) + + if (optype == TY_DOUBLE) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memd[O_VALP(out)+i-1] = RADTODEG(Memd[O_VALP(ap)+i-1]) + } else + O_VALD(out) = RADTODEG (O_VALD(ap)) + + case F_EXP: + + if (optype == TY_REAL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memr[O_VALP(out)+i-1] = exp (Memr[O_VALP(ap)+i-1]) + } else + O_VALR(out) = exp (O_VALR(ap)) + + if (optype == TY_DOUBLE) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memd[O_VALP(out)+i-1] = exp (Memd[O_VALP(ap)+i-1]) + } else + O_VALD(out) = exp (O_VALD(ap)) + + case F_LOG: + + if (optype == TY_REAL) + if (O_LEN(ap) > 0) { + op = O_VALP(out) + do i = 1, O_LEN(ap) { + v_r = Memr[O_VALP(ap)+i-1] + if (rangecheck && v_r <= 0) + Memr[op] = 0 + else + Memr[op] = log (v_r) + op = op + 1 + } + } else { + v_r = O_VALR(ap) + if (rangecheck && v_r <= 0) + O_VALR(out) = 0 + else + O_VALR(out) = log (v_r) + } + + if (optype == TY_DOUBLE) + if (O_LEN(ap) > 0) { + op = O_VALP(out) + do i = 1, O_LEN(ap) { + v_d = Memd[O_VALP(ap)+i-1] + if (rangecheck && v_d <= 0) + Memd[op] = 0 + else + Memd[op] = log (v_d) + op = op + 1 + } + } else { + v_d = O_VALD(ap) + if (rangecheck && v_d <= 0) + O_VALD(out) = 0 + else + O_VALD(out) = log (v_d) + } + + case F_LOG10: + + if (optype == TY_REAL) + if (O_LEN(ap) > 0) { + op = O_VALP(out) + do i = 1, O_LEN(ap) { + v_r = Memr[O_VALP(ap)+i-1] + if (rangecheck && v_r <= 0) + Memr[op] = 0 + else + Memr[op] = log10 (v_r) + op = op + 1 + } + } else { + v_r = O_VALR(ap) + if (rangecheck && v_r <= 0) + O_VALR(out) = 0 + else + O_VALR(out) = log10 (v_r) + } + + if (optype == TY_DOUBLE) + if (O_LEN(ap) > 0) { + op = O_VALP(out) + do i = 1, O_LEN(ap) { + v_d = Memd[O_VALP(ap)+i-1] + if (rangecheck && v_d <= 0) + Memd[op] = 0 + else + Memd[op] = log10 (v_d) + op = op + 1 + } + } else { + v_d = O_VALD(ap) + if (rangecheck && v_d <= 0) + O_VALD(out) = 0 + else + O_VALD(out) = log10 (v_d) + } + + case F_RAD: + + if (optype == TY_REAL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memr[O_VALP(out)+i-1] = DEGTORAD(Memr[O_VALP(ap)+i-1]) + } else + O_VALR(out) = DEGTORAD (O_VALR(ap)) + + if (optype == TY_DOUBLE) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memd[O_VALP(out)+i-1] = DEGTORAD(Memd[O_VALP(ap)+i-1]) + } else + O_VALD(out) = DEGTORAD (O_VALD(ap)) + + case F_SIN: + + if (optype == TY_REAL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memr[O_VALP(out)+i-1] = sin (Memr[O_VALP(ap)+i-1]) + } else + O_VALR(out) = sin (O_VALR(ap)) + + if (optype == TY_DOUBLE) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memd[O_VALP(out)+i-1] = sin (Memd[O_VALP(ap)+i-1]) + } else + O_VALD(out) = sin (O_VALD(ap)) + + case F_SINH: + + if (optype == TY_REAL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memr[O_VALP(out)+i-1] = sinh (Memr[O_VALP(ap)+i-1]) + } else + O_VALR(out) = sinh (O_VALR(ap)) + + if (optype == TY_DOUBLE) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memd[O_VALP(out)+i-1] = sinh (Memd[O_VALP(ap)+i-1]) + } else + O_VALD(out) = sinh (O_VALD(ap)) + + case F_SQRT: + + if (optype == TY_REAL) + if (O_LEN(ap) > 0) { + op = O_VALP(out) + do i = 1, O_LEN(ap) { + v_r = Memr[O_VALP(ap)+i-1] + if (rangecheck && v_r < 0) + Memr[op] = 0 + else + Memr[op] = sqrt (v_r) + op = op + 1 + } + } else { + v_r = O_VALR(ap) + if (rangecheck && v_r <= 0) + O_VALR(out) = 0 + else + O_VALR(out) = sqrt (v_r) + } + + if (optype == TY_DOUBLE) + if (O_LEN(ap) > 0) { + op = O_VALP(out) + do i = 1, O_LEN(ap) { + v_d = Memd[O_VALP(ap)+i-1] + if (rangecheck && v_d < 0) + Memd[op] = 0 + else + Memd[op] = sqrt (v_d) + op = op + 1 + } + } else { + v_d = O_VALD(ap) + if (rangecheck && v_d <= 0) + O_VALD(out) = 0 + else + O_VALD(out) = sqrt (v_d) + } + + case F_TAN: + + if (optype == TY_REAL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memr[O_VALP(out)+i-1] = tan (Memr[O_VALP(ap)+i-1]) + } else + O_VALR(out) = tan (O_VALR(ap)) + + if (optype == TY_DOUBLE) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memd[O_VALP(out)+i-1] = tan (Memd[O_VALP(ap)+i-1]) + } else + O_VALD(out) = tan (O_VALD(ap)) + + case F_TANH: + + if (optype == TY_REAL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memr[O_VALP(out)+i-1] = tanh (Memr[O_VALP(ap)+i-1]) + } else + O_VALR(out) = tanh (O_VALR(ap)) + + if (optype == TY_DOUBLE) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memd[O_VALP(out)+i-1] = tanh (Memd[O_VALP(ap)+i-1]) + } else + O_VALD(out) = tanh (O_VALD(ap)) + + + case F_LEN: + # Vector length. + O_VALI(out) = O_LEN(ap) + + case F_HIV: + # High value. + switch (optype) { + + case TY_SHORT: + if (O_LEN(ap) > 0) + O_VALS(out) = ahivs (Mems[O_VALP(ap)], O_LEN(ap)) + else + O_VALS(out) = O_VALS(ap) + + case TY_INT: + if (O_LEN(ap) > 0) + O_VALI(out) = ahivi (Memi[O_VALP(ap)], O_LEN(ap)) + else + O_VALI(out) = O_VALI(ap) + + case TY_LONG: + if (O_LEN(ap) > 0) + O_VALL(out) = ahivl (Meml[O_VALP(ap)], O_LEN(ap)) + else + O_VALL(out) = O_VALL(ap) + + case TY_REAL: + if (O_LEN(ap) > 0) + O_VALR(out) = ahivr (Memr[O_VALP(ap)], O_LEN(ap)) + else + O_VALR(out) = O_VALR(ap) + + case TY_DOUBLE: + if (O_LEN(ap) > 0) + O_VALD(out) = ahivd (Memd[O_VALP(ap)], O_LEN(ap)) + else + O_VALD(out) = O_VALD(ap) + + default: + call xvv_error1 (s_badtype, fcn) + } + case F_LOV: + # Low value. + switch (optype) { + + case TY_SHORT: + if (O_LEN(ap) > 0) + O_VALS(out) = alovs (Mems[O_VALP(ap)], O_LEN(ap)) + else + O_VALS(out) = O_VALS(ap) + + case TY_INT: + if (O_LEN(ap) > 0) + O_VALI(out) = alovi (Memi[O_VALP(ap)], O_LEN(ap)) + else + O_VALI(out) = O_VALI(ap) + + case TY_LONG: + if (O_LEN(ap) > 0) + O_VALL(out) = alovl (Meml[O_VALP(ap)], O_LEN(ap)) + else + O_VALL(out) = O_VALL(ap) + + case TY_REAL: + if (O_LEN(ap) > 0) + O_VALR(out) = alovr (Memr[O_VALP(ap)], O_LEN(ap)) + else + O_VALR(out) = O_VALR(ap) + + case TY_DOUBLE: + if (O_LEN(ap) > 0) + O_VALD(out) = alovd (Memd[O_VALP(ap)], O_LEN(ap)) + else + O_VALD(out) = O_VALD(ap) + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_SUM: + # Vector sum. + switch (optype) { + + case TY_SHORT: + if (O_LEN(ap) > 0) + v_r = asums (Mems[O_VALP(ap)], O_LEN(ap)) + else + v_r = O_VALS(ap) + + case TY_INT: + if (O_LEN(ap) > 0) + v_r = asumi (Memi[O_VALP(ap)], O_LEN(ap)) + else + v_r = O_VALI(ap) + + case TY_LONG: + if (O_LEN(ap) > 0) + v_r = asuml (Meml[O_VALP(ap)], O_LEN(ap)) + else + v_r = O_VALL(ap) + + case TY_REAL: + if (O_LEN(ap) > 0) + v_r = asumr (Memr[O_VALP(ap)], O_LEN(ap)) + else + v_r = O_VALR(ap) + + case TY_DOUBLE: + if (O_LEN(ap) > 0) + v_d = asumd (Memd[O_VALP(ap)], O_LEN(ap)) + else + v_d = O_VALD(ap) + default: + call xvv_error1 (s_badtype, fcn) + } + + if (optype == TY_DOUBLE) + O_VALD(out) = v_d + else + O_VALR(out) = v_r + + case F_MEAN, F_STDDEV: + # Compute the mean or standard deviation of a vector. An optional + # second argument may be supplied to compute a K-sigma rejection + # mean and sigma. + + if (nargs == 2) { + if (O_LEN(args[2]) > 0) + call xvv_error1 ("%s: ksigma arg must be a scalar" , fcn) + + switch (O_TYPE(args[2])) { + case TY_REAL: + v_r = O_VALR(args[2]) + v_d = v_r + case TY_DOUBLE: + v_d = O_VALD(args[2]) + v_r = v_d + default: + call xvv_chtype (args[2], args[2], TY_REAL) + v_r = O_VALR(args[2]) + v_d = v_r + } + } else { + v_r = 0.0 + v_d = 0.0 + } + + switch (optype) { + + case TY_SHORT: + v_i = aravs (Mems[O_VALP(ap)], O_LEN(ap), mean_r,sigma_r,v_r) + + case TY_INT: + v_i = aravi (Memi[O_VALP(ap)], O_LEN(ap), mean_r,sigma_r,v_r) + + case TY_REAL: + v_i = aravr (Memr[O_VALP(ap)], O_LEN(ap), mean_r,sigma_r,v_r) + + + case TY_LONG: + v_i = aravl (Meml[O_VALP(ap)], O_LEN(ap), mean_d,sigma_d,v_d) + + case TY_DOUBLE: + v_i = aravd (Memd[O_VALP(ap)], O_LEN(ap), mean_d,sigma_d,v_d) + + default: + call xvv_error1 (s_badtype, fcn) + } + + if (opcode == F_MEAN) { + if (O_TYPE(out) == TY_REAL) + O_VALR(out) = mean_r + else + O_VALD(out) = mean_d + } else { + if (O_TYPE(out) == TY_REAL) + O_VALR(out) = sigma_r + else + O_VALD(out) = sigma_d + } + + case F_MEDIAN: + # Compute the median value of a vector, or the vector median + # of 3 or more vectors. + + switch (nargs) { + case 1: + switch (optype) { + + case TY_SHORT: + O_VALS(out) = ameds (Mems[O_VALP(ap)], O_LEN(ap)) + + case TY_INT: + O_VALI(out) = amedi (Memi[O_VALP(ap)], O_LEN(ap)) + + case TY_LONG: + O_VALL(out) = amedl (Meml[O_VALP(ap)], O_LEN(ap)) + + case TY_REAL: + O_VALR(out) = amedr (Memr[O_VALP(ap)], O_LEN(ap)) + + case TY_DOUBLE: + O_VALD(out) = amedd (Memd[O_VALP(ap)], O_LEN(ap)) + + default: + call xvv_error1 (s_badtype, fcn) + } + case 3: + switch (optype) { + + case TY_SHORT: + call amed3s (Mems[O_VALP(args[1])], + Mems[O_VALP(args[2])], + Mems[O_VALP(args[3])], + Mems[O_VALP(out)], nelem) + + case TY_INT: + call amed3i (Memi[O_VALP(args[1])], + Memi[O_VALP(args[2])], + Memi[O_VALP(args[3])], + Memi[O_VALP(out)], nelem) + + case TY_LONG: + call amed3l (Meml[O_VALP(args[1])], + Meml[O_VALP(args[2])], + Meml[O_VALP(args[3])], + Meml[O_VALP(out)], nelem) + + case TY_REAL: + call amed3r (Memr[O_VALP(args[1])], + Memr[O_VALP(args[2])], + Memr[O_VALP(args[3])], + Memr[O_VALP(out)], nelem) + + case TY_DOUBLE: + call amed3d (Memd[O_VALP(args[1])], + Memd[O_VALP(args[2])], + Memd[O_VALP(args[3])], + Memd[O_VALP(out)], nelem) + + default: + call xvv_error1 (s_badtype, fcn) + } + case 4: + switch (optype) { + + case TY_SHORT: + call amed4s (Mems[O_VALP(args[1])], + Mems[O_VALP(args[2])], + Mems[O_VALP(args[3])], + Mems[O_VALP(args[4])], + Mems[O_VALP(out)], nelem) + + case TY_INT: + call amed4i (Memi[O_VALP(args[1])], + Memi[O_VALP(args[2])], + Memi[O_VALP(args[3])], + Memi[O_VALP(args[4])], + Memi[O_VALP(out)], nelem) + + case TY_LONG: + call amed4l (Meml[O_VALP(args[1])], + Meml[O_VALP(args[2])], + Meml[O_VALP(args[3])], + Meml[O_VALP(args[4])], + Meml[O_VALP(out)], nelem) + + case TY_REAL: + call amed4r (Memr[O_VALP(args[1])], + Memr[O_VALP(args[2])], + Memr[O_VALP(args[3])], + Memr[O_VALP(args[4])], + Memr[O_VALP(out)], nelem) + + case TY_DOUBLE: + call amed4d (Memd[O_VALP(args[1])], + Memd[O_VALP(args[2])], + Memd[O_VALP(args[3])], + Memd[O_VALP(args[4])], + Memd[O_VALP(out)], nelem) + + default: + call xvv_error1 (s_badtype, fcn) + } + case 5: + switch (optype) { + + case TY_SHORT: + call amed5s (Mems[O_VALP(args[1])], + Mems[O_VALP(args[2])], + Mems[O_VALP(args[3])], + Mems[O_VALP(args[4])], + Mems[O_VALP(args[5])], + Mems[O_VALP(out)], nelem) + + case TY_INT: + call amed5i (Memi[O_VALP(args[1])], + Memi[O_VALP(args[2])], + Memi[O_VALP(args[3])], + Memi[O_VALP(args[4])], + Memi[O_VALP(args[5])], + Memi[O_VALP(out)], nelem) + + case TY_LONG: + call amed5l (Meml[O_VALP(args[1])], + Meml[O_VALP(args[2])], + Meml[O_VALP(args[3])], + Meml[O_VALP(args[4])], + Meml[O_VALP(args[5])], + Meml[O_VALP(out)], nelem) + + case TY_REAL: + call amed5r (Memr[O_VALP(args[1])], + Memr[O_VALP(args[2])], + Memr[O_VALP(args[3])], + Memr[O_VALP(args[4])], + Memr[O_VALP(args[5])], + Memr[O_VALP(out)], nelem) + + case TY_DOUBLE: + call amed5d (Memd[O_VALP(args[1])], + Memd[O_VALP(args[2])], + Memd[O_VALP(args[3])], + Memd[O_VALP(args[4])], + Memd[O_VALP(args[5])], + Memd[O_VALP(out)], nelem) + + default: + call xvv_error1 (s_badtype, fcn) + } + default: + call xvv_error1 ("%s: wrong number of arguments", fcn) + } + + case F_REPL: + # Replicate an item to make a longer vector. + + chunk = O_LEN(ap) + optype = O_TYPE(ap) + if (optype == TY_BOOL) + optype = TY_INT + + if (O_LEN(args[2]) > 0) + call xvv_error1 ("%s: replication factor must be a scalar", fcn) + if (O_TYPE(args[2]) != TY_INT) + call xvv_chtype (args[2], args[2], TY_INT) + repl = max (1, O_VALI(args[2])) + + if (chunk <= 0) + nelem = repl + else + nelem = chunk * repl + call xvv_initop (out, nelem, optype) + + switch (optype) { + + case TY_SHORT: + if (chunk > 0) { + ip = O_VALP(ap) + op = O_VALP(out) + do i = 1, repl { + call amovs (Mems[ip], Mems[op], chunk) + op = op + chunk + } + } else + call amovks (O_VALS(ap), Mems[O_VALP(out)], nelem) + + case TY_INT: + if (chunk > 0) { + ip = O_VALP(ap) + op = O_VALP(out) + do i = 1, repl { + call amovi (Memi[ip], Memi[op], chunk) + op = op + chunk + } + } else + call amovki (O_VALI(ap), Memi[O_VALP(out)], nelem) + + case TY_LONG: + if (chunk > 0) { + ip = O_VALP(ap) + op = O_VALP(out) + do i = 1, repl { + call amovl (Meml[ip], Meml[op], chunk) + op = op + chunk + } + } else + call amovkl (O_VALL(ap), Meml[O_VALP(out)], nelem) + + case TY_REAL: + if (chunk > 0) { + ip = O_VALP(ap) + op = O_VALP(out) + do i = 1, repl { + call amovr (Memr[ip], Memr[op], chunk) + op = op + chunk + } + } else + call amovkr (O_VALR(ap), Memr[O_VALP(out)], nelem) + + case TY_DOUBLE: + if (chunk > 0) { + ip = O_VALP(ap) + op = O_VALP(out) + do i = 1, repl { + call amovd (Memd[ip], Memd[op], chunk) + op = op + chunk + } + } else + call amovkd (O_VALD(ap), Memd[O_VALP(out)], nelem) + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_SHIFT: + # Vector shift. + if (O_LEN(args[2]) > 0) + call xvv_error1 ("%s: shift arg must be a scalar" , fcn) + if (O_TYPE(args[2]) != TY_INT) + call xvv_chtype (args[2], args[2], TY_INT) + shift = O_VALI(args[2]) + + if (abs(shift) > nelem) { + if (shift > 0) + shift = nelem + else + shift = -nelem + } + + switch (optype) { + + case TY_SHORT: + if (nelem > 0) { + do i = 1, nelem { + j = i - shift + if (j < 1) + j = j + nelem + else if (j > nelem) + j = j - nelem + Mems[O_VALP(out)+i-1] = Mems[O_VALP(ap)+j-1] + } + } else + O_VALS(out) = (O_VALS(ap)) + + case TY_INT: + if (nelem > 0) { + do i = 1, nelem { + j = i - shift + if (j < 1) + j = j + nelem + else if (j > nelem) + j = j - nelem + Memi[O_VALP(out)+i-1] = Memi[O_VALP(ap)+j-1] + } + } else + O_VALI(out) = (O_VALI(ap)) + + case TY_LONG: + if (nelem > 0) { + do i = 1, nelem { + j = i - shift + if (j < 1) + j = j + nelem + else if (j > nelem) + j = j - nelem + Meml[O_VALP(out)+i-1] = Meml[O_VALP(ap)+j-1] + } + } else + O_VALL(out) = (O_VALL(ap)) + + case TY_REAL: + if (nelem > 0) { + do i = 1, nelem { + j = i - shift + if (j < 1) + j = j + nelem + else if (j > nelem) + j = j - nelem + Memr[O_VALP(out)+i-1] = Memr[O_VALP(ap)+j-1] + } + } else + O_VALR(out) = (O_VALR(ap)) + + case TY_DOUBLE: + if (nelem > 0) { + do i = 1, nelem { + j = i - shift + if (j < 1) + j = j + nelem + else if (j > nelem) + j = j - nelem + Memd[O_VALP(out)+i-1] = Memd[O_VALP(ap)+j-1] + } + } else + O_VALD(out) = (O_VALD(ap)) + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_SORT: + # Sort a vector. + switch (optype) { + + case TY_SHORT: + if (nelem > 0) + call asrts (Mems[O_VALP(ap)], Mems[O_VALP(out)], nelem) + else + O_VALS(out) = (O_VALS(ap)) + + case TY_INT: + if (nelem > 0) + call asrti (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) + else + O_VALI(out) = (O_VALI(ap)) + + case TY_LONG: + if (nelem > 0) + call asrtl (Meml[O_VALP(ap)], Meml[O_VALP(out)], nelem) + else + O_VALL(out) = (O_VALL(ap)) + + case TY_REAL: + if (nelem > 0) + call asrtr (Memr[O_VALP(ap)], Memr[O_VALP(out)], nelem) + else + O_VALR(out) = (O_VALR(ap)) + + case TY_DOUBLE: + if (nelem > 0) + call asrtd (Memd[O_VALP(ap)], Memd[O_VALP(out)], nelem) + else + O_VALD(out) = (O_VALD(ap)) + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_ATAN, F_ATAN2: + + if (optype == TY_REAL) { + if (nargs == 1) { + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memr[O_VALP(out)+i-1] = + atan (Memr[O_VALP(ap)+i-1]) + } else + O_VALR(out) = atan (O_VALR(ap)) + } else { + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memr[O_VALP(out)+i-1] = + atan2 (Memr[O_VALP(args[1])+i-1], + Memr[O_VALP(args[2])+i-1]) + } else + O_VALR(out) = atan2(O_VALR(args[1]), O_VALR(args[2])) + } + } + + if (optype == TY_DOUBLE) { + if (nargs == 1) { + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memd[O_VALP(out)+i-1] = + atan (Memd[O_VALP(ap)+i-1]) + } else + O_VALD(out) = atan (O_VALD(ap)) + } else { + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memd[O_VALP(out)+i-1] = + atan2 (Memd[O_VALP(args[1])+i-1], + Memd[O_VALP(args[2])+i-1]) + } else + O_VALD(out) = atan2(O_VALD(args[1]), O_VALD(args[2])) + } + } + + + case F_MOD: + in1 = args[1] + in2 = args[2] + + switch (optype) { + + case TY_SHORT: + if (O_LEN(in1) <= 0) { + O_VALS(out) = mod (O_VALS(in1), O_VALS(in2)) + } else if (O_LEN(in2) <= 0) { + call amodks (Mems[O_VALP(in1)], O_VALS(in2), + Mems[O_VALP(out)], nelem) + } else { + call amods (Mems[O_VALP(in1)], Mems[O_VALP(in2)], + Mems[O_VALP(out)], nelem) + } + + case TY_INT: + if (O_LEN(in1) <= 0) { + O_VALI(out) = mod (O_VALI(in1), O_VALI(in2)) + } else if (O_LEN(in2) <= 0) { + call amodki (Memi[O_VALP(in1)], O_VALI(in2), + Memi[O_VALP(out)], nelem) + } else { + call amodi (Memi[O_VALP(in1)], Memi[O_VALP(in2)], + Memi[O_VALP(out)], nelem) + } + + case TY_LONG: + if (O_LEN(in1) <= 0) { + O_VALL(out) = mod (O_VALL(in1), O_VALL(in2)) + } else if (O_LEN(in2) <= 0) { + call amodkl (Meml[O_VALP(in1)], O_VALL(in2), + Meml[O_VALP(out)], nelem) + } else { + call amodl (Meml[O_VALP(in1)], Meml[O_VALP(in2)], + Meml[O_VALP(out)], nelem) + } + + case TY_REAL: + if (O_LEN(in1) <= 0) { + O_VALR(out) = mod (O_VALR(in1), O_VALR(in2)) + } else if (O_LEN(in2) <= 0) { + call amodkr (Memr[O_VALP(in1)], O_VALR(in2), + Memr[O_VALP(out)], nelem) + } else { + call amodr (Memr[O_VALP(in1)], Memr[O_VALP(in2)], + Memr[O_VALP(out)], nelem) + } + + case TY_DOUBLE: + if (O_LEN(in1) <= 0) { + O_VALD(out) = mod (O_VALD(in1), O_VALD(in2)) + } else if (O_LEN(in2) <= 0) { + call amodkd (Memd[O_VALP(in1)], O_VALD(in2), + Memd[O_VALP(out)], nelem) + } else { + call amodd (Memd[O_VALP(in1)], Memd[O_VALP(in2)], + Memd[O_VALP(out)], nelem) + } + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_MAX: + switch (optype) { + + case TY_SHORT: + # Copy the first argument. + ap = args[1] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) > 0) + call amovks (O_VALS(ap), Mems[O_VALP(out)], nelem) + else + O_VALS(out) = O_VALS(ap) + } else + call amovs (Mems[O_VALP(ap)], Mems[O_VALP(out)], nelem) + + # Process the second and remaining arguments. + do i = 2, nargs { + ap = args[i] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) <= 0) + O_VALS(out) = max (O_VALS(ap), O_VALS(out)) + else { + call amaxks (Mems[O_VALP(out)], O_VALS(ap), + Mems[O_VALP(out)], nelem) + } + } else { + call amaxs (Mems[O_VALP(out)], Mems[O_VALP(ap)], + Mems[O_VALP(out)], nelem) + } + } + + case TY_INT: + # Copy the first argument. + ap = args[1] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) > 0) + call amovki (O_VALI(ap), Memi[O_VALP(out)], nelem) + else + O_VALI(out) = O_VALI(ap) + } else + call amovi (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + # Process the second and remaining arguments. + do i = 2, nargs { + ap = args[i] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) <= 0) + O_VALI(out) = max (O_VALI(ap), O_VALI(out)) + else { + call amaxki (Memi[O_VALP(out)], O_VALI(ap), + Memi[O_VALP(out)], nelem) + } + } else { + call amaxi (Memi[O_VALP(out)], Memi[O_VALP(ap)], + Memi[O_VALP(out)], nelem) + } + } + + case TY_LONG: + # Copy the first argument. + ap = args[1] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) > 0) + call amovkl (O_VALL(ap), Meml[O_VALP(out)], nelem) + else + O_VALL(out) = O_VALL(ap) + } else + call amovl (Meml[O_VALP(ap)], Meml[O_VALP(out)], nelem) + + # Process the second and remaining arguments. + do i = 2, nargs { + ap = args[i] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) <= 0) + O_VALL(out) = max (O_VALL(ap), O_VALL(out)) + else { + call amaxkl (Meml[O_VALP(out)], O_VALL(ap), + Meml[O_VALP(out)], nelem) + } + } else { + call amaxl (Meml[O_VALP(out)], Meml[O_VALP(ap)], + Meml[O_VALP(out)], nelem) + } + } + + case TY_REAL: + # Copy the first argument. + ap = args[1] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) > 0) + call amovkr (O_VALR(ap), Memr[O_VALP(out)], nelem) + else + O_VALR(out) = O_VALR(ap) + } else + call amovr (Memr[O_VALP(ap)], Memr[O_VALP(out)], nelem) + + # Process the second and remaining arguments. + do i = 2, nargs { + ap = args[i] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) <= 0) + O_VALR(out) = max (O_VALR(ap), O_VALR(out)) + else { + call amaxkr (Memr[O_VALP(out)], O_VALR(ap), + Memr[O_VALP(out)], nelem) + } + } else { + call amaxr (Memr[O_VALP(out)], Memr[O_VALP(ap)], + Memr[O_VALP(out)], nelem) + } + } + + case TY_DOUBLE: + # Copy the first argument. + ap = args[1] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) > 0) + call amovkd (O_VALD(ap), Memd[O_VALP(out)], nelem) + else + O_VALD(out) = O_VALD(ap) + } else + call amovd (Memd[O_VALP(ap)], Memd[O_VALP(out)], nelem) + + # Process the second and remaining arguments. + do i = 2, nargs { + ap = args[i] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) <= 0) + O_VALD(out) = max (O_VALD(ap), O_VALD(out)) + else { + call amaxkd (Memd[O_VALP(out)], O_VALD(ap), + Memd[O_VALP(out)], nelem) + } + } else { + call amaxd (Memd[O_VALP(out)], Memd[O_VALP(ap)], + Memd[O_VALP(out)], nelem) + } + } + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_MIN: + switch (optype) { + + case TY_SHORT: + # Copy the first argument. + ap = args[1] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) > 0) + call amovks (O_VALS(ap), Mems[O_VALP(out)], nelem) + else + O_VALS(out) = O_VALS(ap) + } else + call amovs (Mems[O_VALP(ap)], Mems[O_VALP(out)], nelem) + + # Process the second and remaining arguments. + do i = 2, nargs { + ap = args[i] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) <= 0) + O_VALS(out) = min (O_VALS(ap), O_VALS(out)) + else { + call aminks (Mems[O_VALP(out)], O_VALS(ap), + Mems[O_VALP(out)], nelem) + } + } else { + call amins (Mems[O_VALP(out)], Mems[O_VALP(ap)], + Mems[O_VALP(out)], nelem) + } + } + + case TY_INT: + # Copy the first argument. + ap = args[1] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) > 0) + call amovki (O_VALI(ap), Memi[O_VALP(out)], nelem) + else + O_VALI(out) = O_VALI(ap) + } else + call amovi (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + # Process the second and remaining arguments. + do i = 2, nargs { + ap = args[i] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) <= 0) + O_VALI(out) = min (O_VALI(ap), O_VALI(out)) + else { + call aminki (Memi[O_VALP(out)], O_VALI(ap), + Memi[O_VALP(out)], nelem) + } + } else { + call amini (Memi[O_VALP(out)], Memi[O_VALP(ap)], + Memi[O_VALP(out)], nelem) + } + } + + case TY_LONG: + # Copy the first argument. + ap = args[1] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) > 0) + call amovkl (O_VALL(ap), Meml[O_VALP(out)], nelem) + else + O_VALL(out) = O_VALL(ap) + } else + call amovl (Meml[O_VALP(ap)], Meml[O_VALP(out)], nelem) + + # Process the second and remaining arguments. + do i = 2, nargs { + ap = args[i] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) <= 0) + O_VALL(out) = min (O_VALL(ap), O_VALL(out)) + else { + call aminkl (Meml[O_VALP(out)], O_VALL(ap), + Meml[O_VALP(out)], nelem) + } + } else { + call aminl (Meml[O_VALP(out)], Meml[O_VALP(ap)], + Meml[O_VALP(out)], nelem) + } + } + + case TY_REAL: + # Copy the first argument. + ap = args[1] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) > 0) + call amovkr (O_VALR(ap), Memr[O_VALP(out)], nelem) + else + O_VALR(out) = O_VALR(ap) + } else + call amovr (Memr[O_VALP(ap)], Memr[O_VALP(out)], nelem) + + # Process the second and remaining arguments. + do i = 2, nargs { + ap = args[i] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) <= 0) + O_VALR(out) = min (O_VALR(ap), O_VALR(out)) + else { + call aminkr (Memr[O_VALP(out)], O_VALR(ap), + Memr[O_VALP(out)], nelem) + } + } else { + call aminr (Memr[O_VALP(out)], Memr[O_VALP(ap)], + Memr[O_VALP(out)], nelem) + } + } + + case TY_DOUBLE: + # Copy the first argument. + ap = args[1] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) > 0) + call amovkd (O_VALD(ap), Memd[O_VALP(out)], nelem) + else + O_VALD(out) = O_VALD(ap) + } else + call amovd (Memd[O_VALP(ap)], Memd[O_VALP(out)], nelem) + + # Process the second and remaining arguments. + do i = 2, nargs { + ap = args[i] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) <= 0) + O_VALD(out) = min (O_VALD(ap), O_VALD(out)) + else { + call aminkd (Memd[O_VALP(out)], O_VALD(ap), + Memd[O_VALP(out)], nelem) + } + } else { + call amind (Memd[O_VALP(out)], Memd[O_VALP(ap)], + Memd[O_VALP(out)], nelem) + } + } + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_BOOL: + nelem = 0 + if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR) + nelem = O_LEN(ap) + call xvv_initop (out, nelem, TY_BOOL) + + switch (O_TYPE(ap)) { + case TY_BOOL: + if (O_LEN(ap) <= 0) + O_VALI(out) = O_VALI(ap) + else + call amovi (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_CHAR: + ch = O_VALC(ap) + O_VALI(out) = btoi (ch == 'y' || ch == 'Y') + + + case TY_SHORT: + if (O_LEN(ap) <= 0) + O_VALI(out) = btoi (O_VALS(ap) != 0) + else { + v_s = 0 + call abneks (Mems[O_VALP(ap)], v_s, Memi[O_VALP(out)], + nelem) + } + + case TY_INT: + if (O_LEN(ap) <= 0) + O_VALI(out) = btoi (O_VALI(ap) != 0) + else { + v_i = 0 + call abneki (Memi[O_VALP(ap)], v_i, Memi[O_VALP(out)], + nelem) + } + + case TY_LONG: + if (O_LEN(ap) <= 0) + O_VALI(out) = btoi (O_VALL(ap) != 0) + else { + v_l = 0 + call abnekl (Meml[O_VALP(ap)], v_l, Memi[O_VALP(out)], + nelem) + } + + case TY_REAL: + if (O_LEN(ap) <= 0) + O_VALI(out) = btoi (O_VALR(ap) != 0.0) + else { + v_r = 0.0 + call abnekr (Memr[O_VALP(ap)], v_r, Memi[O_VALP(out)], + nelem) + } + + case TY_DOUBLE: + if (O_LEN(ap) <= 0) + O_VALI(out) = btoi (O_VALD(ap) != 0.0D0) + else { + v_d = 0.0D0 + call abnekd (Memd[O_VALP(ap)], v_d, Memi[O_VALP(out)], + nelem) + } + + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_SHORT: + nelem = 0 + if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR) + nelem = O_LEN(ap) + call xvv_initop (out, nelem, TY_SHORT) + + switch (O_TYPE(ap)) { + case TY_BOOL: + if (O_LEN(ap) <= 0) + O_VALS(out) = O_VALI(ap) + else + call achtis (Memi[O_VALP(ap)], Mems[O_VALP(out)], nelem) + + case TY_CHAR: + ip = O_VALP(ap) + if (gctod (Memc, ip, v_d) <= 0) + O_VALS(out) = 0 + else + O_VALS(out) = v_d + + + case TY_SHORT: + if (O_LEN(ap) <= 0) + O_VALS(out) = O_VALS(ap) + else + call achtss (Mems[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_INT: + if (O_LEN(ap) <= 0) + O_VALS(out) = O_VALI(ap) + else + call achtis (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_LONG: + if (O_LEN(ap) <= 0) + O_VALS(out) = O_VALL(ap) + else + call achtls (Meml[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_REAL: + if (O_LEN(ap) <= 0) + O_VALS(out) = O_VALR(ap) + else + call achtrs (Memr[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_DOUBLE: + if (O_LEN(ap) <= 0) + O_VALS(out) = O_VALD(ap) + else + call achtds (Memd[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_INT: + nelem = 0 + if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR) + nelem = O_LEN(ap) + call xvv_initop (out, nelem, TY_INT) + + switch (O_TYPE(ap)) { + case TY_BOOL: + if (O_LEN(ap) <= 0) + O_VALI(out) = O_VALI(ap) + else + call amovi (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_CHAR: + ip = O_VALP(ap) + if (gctod (Memc, ip, v_d) <= 0) + O_VALI(out) = 0 + else + O_VALI(out) = v_d + + + case TY_SHORT: + if (O_LEN(ap) <= 0) + O_VALI(out) = O_VALS(ap) + else + call achtsi (Mems[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_INT: + if (O_LEN(ap) <= 0) + O_VALI(out) = O_VALI(ap) + else + call achtii (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_LONG: + if (O_LEN(ap) <= 0) + O_VALI(out) = O_VALL(ap) + else + call achtli (Meml[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_REAL: + if (O_LEN(ap) <= 0) + O_VALI(out) = O_VALR(ap) + else + call achtri (Memr[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_DOUBLE: + if (O_LEN(ap) <= 0) + O_VALI(out) = O_VALD(ap) + else + call achtdi (Memd[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_LONG: + nelem = 0 + if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR) + nelem = O_LEN(ap) + call xvv_initop (out, nelem, TY_LONG) + + switch (O_TYPE(ap)) { + case TY_BOOL: + if (O_LEN(ap) <= 0) + O_VALL(out) = O_VALI(ap) + else + call amovi (Memi[O_VALP(ap)], Meml[O_VALP(out)], nelem) + + case TY_CHAR: + ip = O_VALP(ap) + if (gctod (Memc, ip, v_d) <= 0) + O_VALL(out) = 0 + else + O_VALL(out) = v_d + + + case TY_SHORT: + if (O_LEN(ap) <= 0) + O_VALL(out) = O_VALS(ap) + else + call achtsl (Mems[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_INT: + if (O_LEN(ap) <= 0) + O_VALL(out) = O_VALI(ap) + else + call achtil (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_LONG: + if (O_LEN(ap) <= 0) + O_VALL(out) = O_VALL(ap) + else + call achtll (Meml[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_REAL: + if (O_LEN(ap) <= 0) + O_VALL(out) = O_VALR(ap) + else + call achtrl (Memr[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_DOUBLE: + if (O_LEN(ap) <= 0) + O_VALL(out) = O_VALD(ap) + else + call achtdl (Memd[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_NINT: + nelem = 0 + if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR) + nelem = O_LEN(ap) + call xvv_initop (out, nelem, TY_INT) + + switch (O_TYPE(ap)) { + case TY_BOOL: + if (O_LEN(ap) <= 0) + O_VALI(out) = O_VALI(ap) + else + call amovi (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_CHAR: + ip = O_VALP(ap) + if (gctod (Memc, ip, v_d) <= 0) + O_VALI(out) = 0 + else + O_VALI(out) = nint (v_d) + + + case TY_SHORT: + if (O_LEN(ap) <= 0) + O_VALI(out) = O_VALS(ap) + else + call achtsi (Mems[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_INT: + if (O_LEN(ap) <= 0) + O_VALI(out) = O_VALI(ap) + else + call achtii (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_LONG: + if (O_LEN(ap) <= 0) + O_VALI(out) = O_VALL(ap) + else + call achtli (Meml[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + + + case TY_REAL: + if (O_LEN(ap) <= 0) + O_VALI(out) = nint (O_VALR(ap)) + else { + do i = 1, nelem + Memi[O_VALP(out)+i-1] = nint (Memr[O_VALP(ap)+i-1]) + } + + case TY_DOUBLE: + if (O_LEN(ap) <= 0) + O_VALI(out) = nint (O_VALD(ap)) + else { + do i = 1, nelem + Memi[O_VALP(out)+i-1] = nint (Memd[O_VALP(ap)+i-1]) + } + + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_REAL: + nelem = 0 + if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR) + nelem = O_LEN(ap) + call xvv_initop (out, nelem, TY_REAL) + + switch (O_TYPE(ap)) { + case TY_BOOL: + if (O_LEN(ap) <= 0) + O_VALR(out) = O_VALI(ap) + else + call achtir (Memi[O_VALP(ap)], Memr[O_VALP(out)], nelem) + + case TY_CHAR: + ip = O_VALP(ap) + if (gctod (Memc, ip, v_d) <= 0) + O_VALR(out) = 0 + else + O_VALR(out) = v_d + + + case TY_SHORT: + if (O_LEN(ap) <= 0) + O_VALR(out) = O_VALS(ap) + else + call achtsr (Mems[O_VALP(ap)], Memr[O_VALP(out)], nelem) + + case TY_INT: + if (O_LEN(ap) <= 0) + O_VALR(out) = O_VALI(ap) + else + call achtir (Memi[O_VALP(ap)], Memr[O_VALP(out)], nelem) + + case TY_LONG: + if (O_LEN(ap) <= 0) + O_VALR(out) = O_VALL(ap) + else + call achtlr (Meml[O_VALP(ap)], Memr[O_VALP(out)], nelem) + + case TY_REAL: + if (O_LEN(ap) <= 0) + O_VALR(out) = O_VALR(ap) + else + call achtrr (Memr[O_VALP(ap)], Memr[O_VALP(out)], nelem) + + case TY_DOUBLE: + if (O_LEN(ap) <= 0) + O_VALR(out) = O_VALD(ap) + else + call achtdr (Memd[O_VALP(ap)], Memr[O_VALP(out)], nelem) + + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_DOUBLE: + nelem = 0 + if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR) + nelem = O_LEN(ap) + call xvv_initop (out, nelem, TY_DOUBLE) + + switch (O_TYPE(ap)) { + case TY_BOOL: + if (O_LEN(ap) <= 0) + O_VALD(out) = O_VALI(ap) + else + call achtid (Memi[O_VALP(ap)], Memd[O_VALP(out)], nelem) + + case TY_CHAR: + ip = O_VALP(ap) + if (gctod (Memc, ip, v_d) <= 0) + O_VALD(out) = 0 + else + O_VALD(out) = v_d + + + case TY_SHORT: + if (O_LEN(ap) <= 0) + O_VALD(out) = O_VALS(ap) + else + call achtsd (Mems[O_VALP(ap)], Memd[O_VALP(out)], nelem) + + case TY_INT: + if (O_LEN(ap) <= 0) + O_VALD(out) = O_VALI(ap) + else + call achtid (Memi[O_VALP(ap)], Memd[O_VALP(out)], nelem) + + case TY_LONG: + if (O_LEN(ap) <= 0) + O_VALD(out) = O_VALL(ap) + else + call achtld (Meml[O_VALP(ap)], Memd[O_VALP(out)], nelem) + + case TY_REAL: + if (O_LEN(ap) <= 0) + O_VALD(out) = O_VALR(ap) + else + call achtrd (Memr[O_VALP(ap)], Memd[O_VALP(out)], nelem) + + case TY_DOUBLE: + if (O_LEN(ap) <= 0) + O_VALD(out) = O_VALD(ap) + else + call achtdd (Memd[O_VALP(ap)], Memd[O_VALP(out)], nelem) + + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_STR: + optype = TY_CHAR + if (O_TYPE(ap) == TY_CHAR) + nelem = strlen (O_VALC(ap)) + else + nelem = MAX_DIGITS + call xvv_initop (out, nelem, TY_CHAR) + + switch (O_TYPE(ap)) { + case TY_BOOL: + call sprintf (O_VALC(out), nelem, "%b") + call pargi (O_VALI(ap)) + case TY_CHAR: + call sprintf (O_VALC(out), nelem, "%s") + call pargstr (O_VALC(ap)) + + case TY_SHORT: + call sprintf (O_VALC(out), nelem, "%d") + call pargs (O_VALS(ap)) + + case TY_INT: + call sprintf (O_VALC(out), nelem, "%d") + call pargi (O_VALI(ap)) + + case TY_LONG: + call sprintf (O_VALC(out), nelem, "%d") + call pargl (O_VALL(ap)) + + + case TY_REAL: + call sprintf (O_VALC(out), nelem, "%g") + call pargr (O_VALR(ap)) + + case TY_DOUBLE: + call sprintf (O_VALC(out), nelem, "%g") + call pargd (O_VALD(ap)) + + default: + call xvv_error1 (s_badtype, fcn) + } + + default: + call xvv_error ("callfcn: unknown function type") + } + +free_ + # Free any storage used by the argument list operands. + do i = 1, nargs + call xvv_freeop (args[i]) + + call sfree (sp) +end + + +# XVV_STARTARGLIST -- Allocate an argument list descriptor to receive +# arguments as a function call is parsed. We are called with either +# zero or one arguments. The argument list descriptor is pointed to by +# a ficticious operand. The descriptor itself contains a count of the +# number of arguments, an array of pointers to the operand structures, +# as well as storage for the operand structures. The operands must be +# stored locally since the parser will discard its copy of the operand +# structure for each argument as the associated grammar rule is reduced. + +procedure xvv_startarglist (arg, out) + +pointer arg #I pointer to first argument, or NULL +pointer out #I output operand pointing to arg descriptor + +pointer ap +errchk xvv_initop + +begin + call xvv_initop (out, LEN_ARGSTRUCT, TY_STRUCT) + ap = O_VALP(out) + + if (arg == NULL) + A_NARGS(ap) = 0 + else { + A_NARGS(ap) = 1 + A_ARGP(ap,1) = A_OPS(ap) + YYMOVE (arg, A_OPS(ap)) + } +end + + +# XVV_ADDARG -- Add an argument to the argument list for a function call. + +procedure xvv_addarg (arg, arglist, out) + +pointer arg #I pointer to argument to be added +pointer arglist #I pointer to operand pointing to arglist +pointer out #I output operand pointing to arg descriptor + +pointer ap, o +int nargs + +begin + ap = O_VALP(arglist) + + nargs = A_NARGS(ap) + 1 + A_NARGS(ap) = nargs + if (nargs > MAX_ARGS) + call xvv_error ("too many function arguments") + + o = A_OPS(ap) + ((nargs - 1) * LEN_OPERAND) + A_ARGP(ap,nargs) = o + YYMOVE (arg, o) + + YYMOVE (arglist, out) +end + + +# XVV_ERROR1 -- Take an error action, formatting an error message with one +# format string plus one string argument. + +procedure xvv_error1 (fmt, arg) + +char fmt[ARB] #I printf format string +char arg[ARB] #I string argument + +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + call sprintf (Memc[buf], SZ_LINE, fmt) + call pargstr (arg) + + call xvv_error (Memc[buf]) + call sfree (sp) +end + + +# XVV_ERROR2 -- Take an error action, formatting an error message with one +# format string plus one string argument and one integer argument. + +procedure xvv_error2 (fmt, arg1, arg2) + +char fmt[ARB] #I printf format string +char arg1[ARB] #I string argument +int arg2 #I integer argument + +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + call sprintf (Memc[buf], SZ_LINE, fmt) + call pargstr (arg1) + call pargi (arg2) + + call xvv_error (Memc[buf]) + call sfree (sp) +end + + +# XVV_ERROR -- Take an error action, given an error message string as the +# sole argument. + +procedure xvv_error (errmsg) + +char errmsg[ARB] #I error message + +begin + call error (1, errmsg) +end + + +# XVV_CHTYPE -- Change the datatype of an operand. The input and output +# operands may be the same. + +procedure xvv_chtype (o1, o2, dtype) + +pointer o1 #I input operand +pointer o2 #I output operand +int dtype #I new datatype + +short v_s +int v_i +long v_l +real v_r +double v_d +pointer vp, ip, op +bool float, freeval +int old_type, nelem, ch + +pointer coerce() +int sizeof(), btoi(), gctod() +string s_badtype "chtype: invalid operand type" + +begin + old_type = O_TYPE(o1) + nelem = O_LEN(o1) + + # No type conversion needed? + if (old_type == dtype) { + if (o1 != o2) { + if (nelem <= 0) + YYMOVE (o1, o2) + else { + call xvv_initop (o2, nelem, old_type) + call amovc (O_VALC(o1), O_VALC(o2), nelem * sizeof(dtype)) + } + } + return + } + + if (nelem <= 0) { + # Scalar input operand. + + O_TYPE(o2) = dtype + O_LEN(o2) = 0 + float = false + + # Read the old value into a local variable of type long or double. + switch (old_type) { + case TY_BOOL: + v_l = O_VALI(o1) + case TY_CHAR: + v_l = 0 # null string? + + case TY_SHORT: + v_l = O_VALS(o1) + + case TY_INT: + v_l = O_VALI(o1) + + case TY_LONG: + v_l = O_VALL(o1) + + + case TY_REAL: + v_d = O_VALR(o1) + float = true + + case TY_DOUBLE: + v_d = O_VALD(o1) + float = true + + default: + call xvv_error (s_badtype) + } + + # Set the value of the output operand. + switch (dtype) { + case TY_BOOL: + if (float) + O_VALI(o2) = btoi (v_d != 0) + else + O_VALI(o2) = btoi (v_l != 0) + case TY_CHAR: + call xvv_initop (o2, MAX_DIGITS, TY_CHAR) + if (float) { + call sprintf (O_VALC(o2), MAX_DIGITS, "%g") + call pargd (v_d) + } else { + call sprintf (O_VALC(o2), MAX_DIGITS, "%d") + call pargl (v_l) + } + + case TY_SHORT: + if (float) + O_VALS(o2) = v_d + else + O_VALS(o2) = v_l + + case TY_INT: + if (float) + O_VALI(o2) = v_d + else + O_VALI(o2) = v_l + + case TY_LONG: + if (float) + O_VALL(o2) = v_d + else + O_VALL(o2) = v_l + + + case TY_REAL: + if (float) + O_VALR(o2) = v_d + else + O_VALR(o2) = v_l + + case TY_DOUBLE: + if (float) + O_VALD(o2) = v_d + else + O_VALD(o2) = v_l + + default: + call xvv_error (s_badtype) + } + + } else { + # Vector input operand. + + # Save a pointer to the input operand data vector, to avoid it + # getting clobbered if O1 and O2 are the same operand. + + vp = O_VALP(o1) + + # If we have a char string input operand the output numeric + # operand can only be a scalar. If we have a char string output + # operand nelem is the length of the string. + + if (old_type == TY_CHAR) + nelem = 0 + else if (dtype == TY_CHAR) + nelem = MAX_DIGITS + + # Initialize the output operand O2. The freeval flag is cleared + # cleared to keep the initop from freeing the input operand array, + # inherited when the input operand is copied (or when the input + # and output operands are the same). We free the old operand + # array manually below. + + if (o1 != o2) + YYMOVE (o1, o2) + freeval = (and (O_FLAGS(o1), O_FREEVAL) != 0) + O_FLAGS(o2) = and (O_FLAGS(o2), not(O_FREEVAL)) + call xvv_initop (o2, nelem, dtype) + + # Write output value. + switch (dtype) { + case TY_BOOL: + if (old_type == TY_CHAR) { + ch = Memc[vp] + O_VALI(o2) = btoi (ch == 'y' || ch == 'Y') + } else { + switch (old_type) { + + case TY_SHORT: + v_s = 0 + call abneks (Mems[vp], v_s, Memi[O_VALP(o2)], nelem) + + case TY_INT: + v_i = 0 + call abneki (Memi[vp], v_i, Memi[O_VALP(o2)], nelem) + + case TY_LONG: + v_l = 0 + call abnekl (Meml[vp], v_l, Memi[O_VALP(o2)], nelem) + + case TY_REAL: + v_r = 0.0 + call abnekr (Memr[vp], v_r, Memi[O_VALP(o2)], nelem) + + case TY_DOUBLE: + v_d = 0.0D0 + call abnekd (Memd[vp], v_d, Memi[O_VALP(o2)], nelem) + + default: + call xvv_error (s_badtype) + } + } + + case TY_CHAR: + call xvv_error (s_badtype) + + case TY_SHORT, TY_INT, TY_LONG, TY_REAL, TY_DOUBLE: + switch (old_type) { + case TY_BOOL: + op = coerce (O_VALP(o2), O_TYPE(o2), TY_CHAR) + call achti (Memi[vp], Memc[op], nelem, dtype) + case TY_CHAR: + ip = vp + if (gctod (Memc, ip, v_d) <= 0) + v_d = 0 + switch (dtype) { + + case TY_SHORT: + O_VALS(o2) = v_d + + case TY_INT: + O_VALI(o2) = v_d + + case TY_LONG: + O_VALL(o2) = v_d + + case TY_REAL: + O_VALR(o2) = v_d + + case TY_DOUBLE: + O_VALD(o2) = v_d + + } + + case TY_SHORT: + op = coerce (O_VALP(o2), O_TYPE(o2), TY_CHAR) + call achts (Mems[vp], Memc[op], nelem, dtype) + + case TY_INT: + op = coerce (O_VALP(o2), O_TYPE(o2), TY_CHAR) + call achti (Memi[vp], Memc[op], nelem, dtype) + + case TY_LONG: + op = coerce (O_VALP(o2), O_TYPE(o2), TY_CHAR) + call achtl (Meml[vp], Memc[op], nelem, dtype) + + case TY_REAL: + op = coerce (O_VALP(o2), O_TYPE(o2), TY_CHAR) + call achtr (Memr[vp], Memc[op], nelem, dtype) + + case TY_DOUBLE: + op = coerce (O_VALP(o2), O_TYPE(o2), TY_CHAR) + call achtd (Memd[vp], Memc[op], nelem, dtype) + + default: + call xvv_error (s_badtype) + } + default: + call xvv_error (s_badtype) + } + + # Free old operand value. + if (freeval) + call mfree (vp, old_type) + } +end + + +# XVV_INITOP -- Initialize an operand, providing storage for an operand value +# of the given size and type. + +procedure xvv_initop (o, o_len, o_type) + +pointer o #I pointer to operand structure +int o_len #I length of operand (zero if scalar) +int o_type #I datatype of operand + +begin + O_LEN(o) = 0 + call xvv_makeop (o, o_len, o_type) +end + + +# XVV_MAKEOP -- Set up the operand structure. If the operand structure has +# already been initialized and array storage allocated, free the old array. + +procedure xvv_makeop (o, o_len, o_type) + +pointer o #I pointer to operand structure +int o_len #I length of operand (zero if scalar) +int o_type #I datatype of operand + +errchk malloc + +begin + # Free old array storage if any. + if (O_TYPE(o) != 0 && O_LEN(o) > 0) + if (and (O_FLAGS(o), O_FREEVAL) != 0) { + if (O_TYPE(o) == TY_BOOL) + call mfree (O_VALP(o), TY_INT) + else + call mfree (O_VALP(o), O_TYPE(o)) + O_LEN(o) = 0 + } + + # Set new operand type. + O_TYPE(o) = o_type + + # Allocate array storage if nonscalar operand. + if (o_len > 0) { + if (o_type == TY_BOOL) + call malloc (O_VALP(o), o_len, TY_INT) + else + call malloc (O_VALP(o), o_len, o_type) + O_LEN(o) = o_len + } + + O_FLAGS(o) = O_FREEVAL +end + + +# XVV_FREEOP -- Reinitialize an operand structure, i.e., free any associated +# array storage and clear the operand datatype field, but do not free the +# operand structure itself (which may be only a segment of an array and not +# a separately allocated structure). + +procedure xvv_freeop (o) + +pointer o #I pointer to operand structure + +begin + # Free old array storage if any. + if (O_TYPE(o) != 0 && O_LEN(o) > 0) + if (and (O_FLAGS(o), O_FREEVAL) != 0) { + if (O_TYPE(o) == TY_BOOL) + call mfree (O_VALP(o), TY_INT) + else + call mfree (O_VALP(o), O_TYPE(o)) + O_LEN(o) = 0 + } + + # Either free operand struct or clear the operand type to mark + # operand invalid. + + if (and (O_FLAGS(o), O_FREEOP) != 0) + call mfree (o, TY_STRUCT) + else + O_TYPE(o) = 0 +end + + +# XVV_LOADSYMBOLS -- Load a list of symbol names into a symbol table. Each +# symbol is tagged with an integer code corresponding to its sequence number +# in the symbol list. + +pointer procedure xvv_loadsymbols (s) + +char s[ARB] #I symbol list "|sym1|sym2|...|" + +int delim, symnum, ip +pointer sp, symname, st, sym, op +pointer stopen(), stenter() + +begin + call smark (sp) + call salloc (symname, SZ_FNAME, TY_CHAR) + + st = stopen ("evvexpr", LEN_INDEX, LEN_STAB, LEN_SBUF) + delim = s[1] + symnum = 0 + + for (ip=2; s[ip] != EOS; ip=ip+1) { + op = symname + while (s[ip] != delim && s[ip] != EOS) { + Memc[op] = s[ip] + op = op + 1 + ip = ip + 1 + } + Memc[op] = EOS + symnum = symnum + 1 + + if (op > symname && IS_ALPHA(Memc[symname])) { + sym = stenter (st, Memc[symname], LEN_SYM) + SYM_CODE(sym) = symnum + } + } + + call sfree (sp) + return (st) +end + + +# XVV_NULL -- Return a null value to be used when a computation cannot be +# performed and range checking is enabled. Perhaps we should permit a user +# specified value here, however this doesn't really work in an expression +# evaluator since the value generated may be used in subsequent calculations +# and hence may change. If more careful treatment of out of range values +# is needed a conditional expression can be used in which case the value +# we return here is ignored (but still needed to avoid a hardware exception +# when computing a vector). + + +short procedure xvv_nulls (ignore) +short ignore #I ignored +begin + return (0) +end + +int procedure xvv_nulli (ignore) +int ignore #I ignored +begin + return (0) +end + +long procedure xvv_nulll (ignore) +long ignore #I ignored +begin + return (0) +end + +real procedure xvv_nullr (ignore) +real ignore #I ignored +begin + return (0.0) +end + +double procedure xvv_nulld (ignore) +double ignore #I ignored +begin + return (0.0D0) +end + +define YYNPROD 39 +define YYLAST 303 +# line 1 "/iraf/iraf/lib/yaccpar.x" +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# Parser for yacc output, translated to the IRAF SPP language. The contents +# of this file form the bulk of the source of the parser produced by Yacc. +# Yacc recognizes several macros in the yaccpar input source and replaces +# them as follows: +# A user suppled "global" definitions and declarations +# B parser tables +# C user supplied actions (reductions) +# The remainder of the yaccpar code is not changed. + +define yystack_ 10 # statement labels for gotos +define yynewstate_ 20 +define yydefault_ 30 +define yyerrlab_ 40 +define yyabort_ 50 + +define YYFLAG (-1000) # defs used in user actions +define YYERROR goto yyerrlab_ +define YYACCEPT return (OK) +define YYABORT return (ERR) + + +# YYPARSE -- Parse the input stream, returning OK if the source is +# syntactically acceptable (i.e., if compilation is successful), +# otherwise ERR. The parameters YYMAXDEPTH and YYOPLEN must be +# supplied by the caller in the %{ ... %} section of the Yacc source. +# The token value stack is a dynamically allocated array of operand +# structures, with the length and makeup of the operand structure being +# application dependent. + +int procedure yyparse (fd, yydebug, yylex) + +int fd # stream to be parsed +bool yydebug # print debugging information? +int yylex() # user-supplied lexical input function +extern yylex() + +short yys[YYMAXDEPTH] # parser stack -- stacks tokens +pointer yyv # pointer to token value stack +pointer yyval # value returned by action +pointer yylval # value of token +int yyps # token stack pointer +pointer yypv # value stack pointer +int yychar # current input token number +int yyerrflag # error recovery flag +int yynerrs # number of errors + +short yyj, yym # internal variables +pointer yysp, yypvt +short yystate, yyn +int yyxi, i +errchk salloc, yylex + + +# XVV_PARSE -- SPP/Yacc parser for the evaluation of an expression passed as +# a text string. Expression evaluation is carried out as the expression is +# parsed, rather than being broken into separate compile and execute stages. +# There is only one statement in this grammar, the expression. Our function +# is to reduce an expression to a single value of type bool, string, int, +# or real. + +pointer ap +bool streq() +errchk zcall3, xvv_error1, xvv_unop, xvv_binop, xvv_boolop +errchk xvv_quest, xvv_callfcn, xvv_addarg +include "evvexpr.com" + +short yyexca[96] +data (yyexca(i),i= 1, 8) / -1, 1, 0, -1, -2, 0, -1, 5/ +data (yyexca(i),i= 9, 16) / 40, 33, -2, 5, -1, 6, 40, 32/ +data (yyexca(i),i= 17, 24) / -2, 6, -1, 76, 269, 0, 270, 0/ +data (yyexca(i),i= 25, 32) / 271, 0, 283, 0, -2, 22, -1, 77/ +data (yyexca(i),i= 33, 40) / 269, 0, 270, 0, 271, 0, 283, 0/ +data (yyexca(i),i= 41, 48) / -2, 23, -1, 78, 269, 0, 270, 0/ +data (yyexca(i),i= 49, 56) / 271, 0, 283, 0, -2, 24, -1, 79/ +data (yyexca(i),i= 57, 64) / 269, 0, 270, 0, 271, 0, 283, 0/ +data (yyexca(i),i= 65, 72) / -2, 25, -1, 80, 272, 0, 273, 0/ +data (yyexca(i),i= 73, 80) / 274, 0, -2, 26, -1, 81, 272, 0/ +data (yyexca(i),i= 81, 88) / 273, 0, 274, 0, -2, 27, -1, 82/ +data (yyexca(i),i= 89, 96) / 272, 0, 273, 0, 274, 0, -2, 28/ +short yyact[303] +data (yyact(i),i= 1, 8) / 15, 16, 17, 18, 19, 20, 33, 86/ +data (yyact(i),i= 9, 16) / 26, 27, 28, 30, 32, 31, 21, 22/ +data (yyact(i),i= 17, 24) / 62, 23, 24, 25, 19, 34, 29, 15/ +data (yyact(i),i= 25, 32) / 16, 17, 18, 19, 20, 33, 38, 26/ +data (yyact(i),i= 33, 40) / 27, 28, 30, 32, 31, 21, 22, 60/ +data (yyact(i),i= 41, 48) / 23, 24, 25, 12, 11, 29, 15, 16/ +data (yyact(i),i= 49, 56) / 17, 18, 19, 20, 12, 2, 26, 27/ +data (yyact(i),i= 57, 64) / 28, 30, 32, 31, 12, 1, 0, 23/ +data (yyact(i),i= 65, 72) / 24, 25, 0, 14, 29, 15, 16, 17/ +data (yyact(i),i= 73, 80) / 18, 19, 20, 0, 0, 26, 27, 28/ +data (yyact(i),i= 81, 88) / 30, 32, 31, 0, 15, 16, 17, 18/ +data (yyact(i),i= 89, 96) / 19, 20, 0, 29, 26, 27, 28, 15/ +data (yyact(i),i= 97,104) / 16, 17, 18, 19, 20, 15, 16, 17/ +data (yyact(i),i=105,112) / 18, 19, 29, 17, 18, 19, 4, 0/ +data (yyact(i),i=113,120) / 84, 0, 40, 85, 0, 0, 0, 35/ +data (yyact(i),i=121,128) / 36, 37, 0, 39, 0, 0, 0, 0/ +data (yyact(i),i=129,136) / 0, 0, 41, 42, 43, 44, 45, 46/ +data (yyact(i),i=137,144) / 47, 48, 49, 50, 51, 52, 53, 54/ +data (yyact(i),i=145,152) / 55, 56, 57, 58, 59, 61, 0, 63/ +data (yyact(i),i=153,160) / 65, 66, 67, 68, 69, 70, 71, 72/ +data (yyact(i),i=161,168) / 73, 74, 75, 76, 77, 78, 79, 80/ +data (yyact(i),i=169,176) / 81, 82, 83, 0, 0, 0, 0, 0/ +data (yyact(i),i=177,184) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=185,192) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=193,200) / 0, 0, 0, 0, 0, 0, 89, 90/ +data (yyact(i),i=201,208) / 87, 88, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=209,216) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=217,224) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=225,232) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=233,240) / 0, 0, 0, 0, 15, 16, 17, 18/ +data (yyact(i),i=241,248) / 19, 20, 33, 0, 26, 27, 28, 30/ +data (yyact(i),i=249,256) / 32, 31, 21, 22, 0, 23, 24, 25/ +data (yyact(i),i=257,264) / 0, 0, 29, 0, 5, 6, 64, 0/ +data (yyact(i),i=265,272) / 0, 8, 0, 0, 3, 5, 6, 0/ +data (yyact(i),i=273,280) / 0, 0, 8, 0, 0, 5, 6, 0/ +data (yyact(i),i=281,288) / 9, 0, 8, 13, 10, 7, 0, 0/ +data (yyact(i),i=289,296) / 0, 9, 0, 0, 0, 10, 7, 0/ +data (yyact(i),i=297,303) / 0, 9, 0, 0, 0, 10, 7/ +short yypact[91] +data (yypact(i),i= 1, 8) / 12,-1000, 23,-1000,-238,-1000,-1000,-236/ +data (yypact(i),i= 9, 16) / 20, 20, 20, -10, 20,-1000,-1000,-1000/ +data (yypact(i),i= 17, 24) /-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000/ +data (yypact(i),i= 25, 32) /-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000/ +data (yypact(i),i= 33, 40) /-1000,-1000,-1000,-245,-245,-245, 20, -25/ +data (yypact(i),i= 41, 48) / 3, 3, 3, 3, 3, 3, 3, 3/ +data (yypact(i),i= 49, 56) / 3, 3, 3, 3, 3, 3, 3, 3/ +data (yypact(i),i= 57, 64) / 3, 3, 3, 3, 71,-238,-1000,-238/ +data (yypact(i),i= 65, 72) /-1000,-156,-156,-245,-245,-1000,-160,-215/ +data (yypact(i),i= 73, 80) /-215,-192,-192,-192,-166,-166,-166,-166/ +data (yypact(i),i= 81, 88) /-177,-177,-177,-261,-1000,-1000,-1000, 3/ +data (yypact(i),i= 89, 91) / 3,-238,-238/ +short yypgo[7] +data (yypgo(i),i= 1, 7) / 0, 61, 53, 110, 114, 44, 39/ +short yyr1[39] +data (yyr1(i),i= 1, 8) / 0, 1, 1, 2, 2, 3, 3, 3/ +data (yyr1(i),i= 9, 16) / 3, 3, 3, 3, 3, 3, 3, 3/ +data (yyr1(i),i= 17, 24) / 3, 3, 3, 3, 3, 3, 3, 3/ +data (yyr1(i),i= 25, 32) / 3, 3, 3, 3, 3, 3, 3, 3/ +data (yyr1(i),i= 33, 39) / 5, 5, 6, 6, 6, 4, 4/ +short yyr2[39] +data (yyr2(i),i= 1, 8) / 0, 2, 1, 1, 4, 1, 1, 2/ +data (yyr2(i),i= 9, 16) / 2, 2, 2, 4, 4, 4, 4, 4/ +data (yyr2(i),i= 17, 24) / 4, 4, 4, 4, 4, 4, 4, 4/ +data (yyr2(i),i= 25, 32) / 4, 4, 4, 4, 4, 7, 4, 3/ +data (yyr2(i),i= 33, 39) / 1, 1, 0, 1, 4, 0, 2/ +short yychk[91] +data (yychk(i),i= 1, 8) /-1000, -1, -2, 256, -3, 257, 258, 282/ +data (yychk(i),i= 9, 16) / 262, 277, 281, -5, 40, 260, 44, 261/ +data (yychk(i),i= 17, 24) / 262, 263, 264, 265, 266, 275, 276, 278/ +data (yychk(i),i= 25, 32) / 279, 280, 269, 270, 271, 283, 272, 274/ +data (yychk(i),i= 33, 40) / 273, 267, 257, -3, -3, -3, 40, -3/ +data (yychk(i),i= 41, 48) / -4, -4, -4, -4, -4, -4, -4, -4/ +data (yychk(i),i= 49, 56) / -4, -4, -4, -4, -4, -4, -4, -4/ +data (yychk(i),i= 57, 64) / -4, -4, -4, -4, -6, -3, 41, -3/ +data (yychk(i),i= 65, 72) / 259, -3, -3, -3, -3, -3, -3, -3/ +data (yychk(i),i= 73, 80) / -3, -3, -3, -3, -3, -3, -3, -3/ +data (yychk(i),i= 81, 88) / -3, -3, -3, -3, 41, 44, 268, -4/ +data (yychk(i),i= 89, 91) / -4, -3, -3/ +short yydef[91] +data (yydef(i),i= 1, 8) / 0, -2, 0, 2, 3, -2, -2, 0/ +data (yydef(i),i= 9, 16) / 0, 0, 0, 0, 0, 1, 37, 37/ +data (yydef(i),i= 17, 24) / 37, 37, 37, 37, 37, 37, 37, 37/ +data (yydef(i),i= 25, 32) / 37, 37, 37, 37, 37, 37, 37, 37/ +data (yydef(i),i= 33, 40) / 37, 37, 7, 8, 9, 10, 34, 0/ +data (yydef(i),i= 41, 48) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yydef(i),i= 49, 56) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yydef(i),i= 57, 64) / 0, 0, 0, 0, 0, 35, 31, 4/ +data (yydef(i),i= 65, 72) / 38, 11, 12, 13, 14, 15, 16, 17/ +data (yydef(i),i= 73, 80) / 18, 19, 20, 21, -2, -2, -2, -2/ +data (yydef(i),i= 81, 88) / -2, -2, -2, 0, 30, 37, 37, 0/ +data (yydef(i),i= 89, 91) / 0, 36, 29/ + +begin + call smark (yysp) + call salloc (yyv, (YYMAXDEPTH+2) * YYOPLEN, TY_STRUCT) + + # Initialization. The first element of the dynamically allocated + # token value stack (yyv) is used for yyval, the second for yylval, + # and the actual stack starts with the third element. + + yystate = 0 + yychar = -1 + yynerrs = 0 + yyerrflag = 0 + yyps = 0 + yyval = yyv + yylval = yyv + YYOPLEN + yypv = yylval + +yystack_ + # SHIFT -- Put a state and value onto the stack. The token and + # value stacks are logically the same stack, implemented as two + # separate arrays. + + if (yydebug) { + call printf ("state %d, char 0%o\n") + call pargs (yystate) + call pargi (yychar) + } + yyps = yyps + 1 + yypv = yypv + YYOPLEN + if (yyps > YYMAXDEPTH) { + call sfree (yysp) + call eprintf ("yacc stack overflow\n") + return (ERR) + } + yys[yyps] = yystate + YYMOVE (yyval, yypv) + +yynewstate_ + # Process the new state. + yyn = yypact[yystate+1] + + if (yyn <= YYFLAG) + goto yydefault_ # simple state + + # The variable "yychar" is the lookahead token. + if (yychar < 0) { + yychar = yylex (fd, yylval) + if (yychar < 0) + yychar = 0 + } + yyn = yyn + yychar + if (yyn < 0 || yyn >= YYLAST) + goto yydefault_ + + yyn = yyact[yyn+1] + if (yychk[yyn+1] == yychar) { # valid shift + yychar = -1 + YYMOVE (yylval, yyval) + yystate = yyn + if (yyerrflag > 0) + yyerrflag = yyerrflag - 1 + goto yystack_ + } + +yydefault_ + # Default state action. + + yyn = yydef[yystate+1] + if (yyn == -2) { + if (yychar < 0) { + yychar = yylex (fd, yylval) + if (yychar < 0) + yychar = 0 + } + + # Look through exception table. + yyxi = 1 + while ((yyexca[yyxi] != (-1)) || (yyexca[yyxi+1] != yystate)) + yyxi = yyxi + 2 + for (yyxi=yyxi+2; yyexca[yyxi] >= 0; yyxi=yyxi+2) { + if (yyexca[yyxi] == yychar) + break + } + + yyn = yyexca[yyxi+1] + if (yyn < 0) { + call sfree (yysp) + return (OK) # ACCEPT -- all done + } + } + + + # SYNTAX ERROR -- resume parsing if possible. + + if (yyn == 0) { + switch (yyerrflag) { + case 0, 1, 2: + if (yyerrflag == 0) { # brand new error + call eprintf ("syntax error\n") +yyerrlab_ + yynerrs = yynerrs + 1 + # fall through... + } + + # case 1: + # case 2: incompletely recovered error ... try again + yyerrflag = 3 + + # Find a state where "error" is a legal shift action. + while (yyps >= 1) { + yyn = yypact[yys[yyps]+1] + YYERRCODE + if ((yyn >= 0) && (yyn < YYLAST) && + (yychk[yyact[yyn+1]+1] == YYERRCODE)) { + # Simulate a shift of "error". + yystate = yyact[yyn+1] + goto yystack_ + } + yyn = yypact[yys[yyps]+1] + + # The current yyps has no shift on "error", pop stack. + if (yydebug) { + call printf ("error recovery pops state %d, ") + call pargs (yys[yyps]) + call printf ("uncovers %d\n") + call pargs (yys[yyps-1]) + } + yyps = yyps - 1 + yypv = yypv - YYOPLEN + } + + # ABORT -- There is no state on the stack with an error shift. +yyabort_ + call sfree (yysp) + return (ERR) + + + case 3: # No shift yet; clobber input char. + + if (yydebug) { + call printf ("error recovery discards char %d\n") + call pargi (yychar) + } + + if (yychar == 0) + goto yyabort_ # don't discard EOF, quit + yychar = -1 + goto yynewstate_ # try again in the same state + } + } + + + # REDUCE -- Reduction by production yyn. + + if (yydebug) { + call printf ("reduce %d\n") + call pargs (yyn) + } + yyps = yyps - yyr2[yyn+1] + yypvt = yypv + yypv = yypv - yyr2[yyn+1] * YYOPLEN + YYMOVE (yypv + YYOPLEN, yyval) + yym = yyn + + # Consult goto table to find next state. + yyn = yyr1[yyn+1] + yyj = yypgo[yyn+1] + yys[yyps] + 1 + if (yyj >= YYLAST) + yystate = yyact[yypgo[yyn+1]+1] + else { + yystate = yyact[yyj+1] + if (yychk[yystate+1] != -yyn) + yystate = yyact[yypgo[yyn+1]+1] + } + + # Perform action associated with the grammar rule, if any. + switch (yym) { + +case 1: +# line 266 "evvexpr.y" +{ + # Normal exit. Move the final expression value operand + # into the operand structure pointed to by the global + # variable ev_oval. + + YYMOVE (yypvt-YYOPLEN, ev_oval) + call sfree (yysp) + return (OK) + } +case 2: +# line 275 "evvexpr.y" +{ + call error (1, "syntax error") + } +case 3: +# line 280 "evvexpr.y" +{ + YYMOVE (yypvt, yyval) + } +case 4: +# line 283 "evvexpr.y" +{ + YYMOVE (yypvt, yyval) + call xvv_freeop (yypvt-3*YYOPLEN) + } +case 5: +# line 289 "evvexpr.y" +{ + # Numeric constant. + YYMOVE (yypvt, yyval) + } +case 6: +# line 293 "evvexpr.y" +{ + # The boolean constants "yes" and "no" are implemented + # as reserved operands. + + call xvv_initop (yyval, 0, TY_BOOL) + if (streq (O_VALC(yypvt), "yes")) { + O_VALI(yyval) = YES + } else if (streq (O_VALC(yypvt), "no")) { + O_VALI(yyval) = NO + } else if (ev_getop != NULL) { + call zcall3 (ev_getop,ev_getop_data, O_VALC(yypvt), yyval) + if (O_TYPE(yyval) <= 0) + call xvv_error1 ("unknown operand `%s'", + O_VALC(yypvt)) + } else + call xvv_error1 ("illegal operand `%s'", O_VALC(yypvt)) + call xvv_freeop (yypvt) + } +case 7: +# line 311 "evvexpr.y" +{ + # e.g., @"param" + if (ev_getop != NULL) { + call zcall3 (ev_getop,ev_getop_data, O_VALC(yypvt), yyval) + if (O_TYPE(yyval) <= 0) + call xvv_error1 ("unknown operand `%s'", + O_VALC(yypvt-YYOPLEN)) + } else + call xvv_error1 ("illegal operand `%s'", O_VALC(yypvt)) + call xvv_freeop (yypvt) + } +case 8: +# line 322 "evvexpr.y" +{ + # Unary arithmetic minus. + call xvv_unop (MINUS, yypvt, yyval) + } +case 9: +# line 326 "evvexpr.y" +{ + # Logical not. + call xvv_unop (LNOT, yypvt, yyval) + } +case 10: +# line 330 "evvexpr.y" +{ + # Boolean not. + call xvv_unop (BNOT, yypvt, yyval) + } +case 11: +# line 334 "evvexpr.y" +{ + # Addition. + call xvv_binop (PLUS, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 12: +# line 338 "evvexpr.y" +{ + # Subtraction. + call xvv_binop (MINUS, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 13: +# line 342 "evvexpr.y" +{ + # Multiplication. + call xvv_binop (STAR, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 14: +# line 346 "evvexpr.y" +{ + # Division. + call xvv_binop (SLASH, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 15: +# line 350 "evvexpr.y" +{ + # Exponentiation. + call xvv_binop (EXPON, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 16: +# line 354 "evvexpr.y" +{ + # Concatenate two operands. + call xvv_binop (CONCAT, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 17: +# line 358 "evvexpr.y" +{ + # Logical and. + call xvv_boolop (LAND, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 18: +# line 362 "evvexpr.y" +{ + # Logical or. + call xvv_boolop (LOR, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 19: +# line 366 "evvexpr.y" +{ + # Boolean and. + call xvv_binop (BAND, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 20: +# line 370 "evvexpr.y" +{ + # Boolean or. + call xvv_binop (BOR, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 21: +# line 374 "evvexpr.y" +{ + # Boolean xor. + call xvv_binop (BXOR, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 22: +# line 378 "evvexpr.y" +{ + # Boolean less than. + call xvv_boolop (LT, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 23: +# line 382 "evvexpr.y" +{ + # Boolean greater than. + call xvv_boolop (GT, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 24: +# line 386 "evvexpr.y" +{ + # Boolean less than or equal. + call xvv_boolop (LE, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 25: +# line 390 "evvexpr.y" +{ + # Boolean greater than or equal. + call xvv_boolop (GE, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 26: +# line 394 "evvexpr.y" +{ + # Boolean equal. + call xvv_boolop (EQ, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 27: +# line 398 "evvexpr.y" +{ + # String pattern-equal. + call xvv_boolop (SE, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 28: +# line 402 "evvexpr.y" +{ + # Boolean not equal. + call xvv_boolop (NE, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 29: +# line 406 "evvexpr.y" +{ + # Conditional expression. + call xvv_quest (yypvt-6*YYOPLEN, yypvt-3*YYOPLEN, yypvt, yyval) + } +case 30: +# line 410 "evvexpr.y" +{ + # Call an intrinsic or external function. + ap = O_VALP(yypvt-YYOPLEN) + call xvv_callfcn (O_VALC(yypvt-3*YYOPLEN), + A_ARGP(ap,1), A_NARGS(ap), yyval) + call xvv_freeop (yypvt-3*YYOPLEN) + call xvv_freeop (yypvt-YYOPLEN) + } +case 31: +# line 418 "evvexpr.y" +{ + YYMOVE (yypvt-YYOPLEN, yyval) + } +case 32: +# line 424 "evvexpr.y" +{ + YYMOVE (yypvt, yyval) + } +case 33: +# line 427 "evvexpr.y" +{ + if (O_TYPE(yypvt) != TY_CHAR) + call error (1, "illegal function name") + YYMOVE (yypvt, yyval) + } +case 34: +# line 435 "evvexpr.y" +{ + # Empty. + call xvv_startarglist (NULL, yyval) + } +case 35: +# line 439 "evvexpr.y" +{ + # First arg; start a nonnull list. + call xvv_startarglist (yypvt, yyval) + } +case 36: +# line 443 "evvexpr.y" +{ + # Add an argument to an existing list. + call xvv_addarg (yypvt, yypvt-3*YYOPLEN, yyval) + } } + + goto yystack_ # stack new state and value +end diff --git a/sys/fmtio/evvexpr.y b/sys/fmtio/evvexpr.y new file mode 100644 index 00000000..d6efa629 --- /dev/null +++ b/sys/fmtio/evvexpr.y @@ -0,0 +1,4644 @@ +%{ +include +include +include +include +include + +.help evvexpr +.nf -------------------------------------------------------------------------- +EVVEXPR.GY -- Generic XYacc source for a general vector expression evaluator. + + o = evvexpr (expr, getop, getop_data, ufcn, ufcn_data, flags) + evvfree (o) + +Client callbacks: + + getop (client_data, opname, out) + ufcn (client_data, fcn, args, nargs, out) + +here "out" is the output operand returned to EVVEXPR. Client_data is any +arbitrary integer or pointer value passed in to EVVEXPR when by the client +when the callback was registered. "args" is an array of operand structs, +the arguments for the user function being called. If the operand or +function call cannot be completed normally an error exit may be made (call +error) or an invalid operand may be returned (O_TYPE set to 0). The client +should not free the "args" input operands, this will be handled by EVVEXPR. + +Operand struct (lib$evvexpr.h): + + struct operand { + int O_TYPE # operand type (bcsilrd) + int O_LEN # operand length (0=scalar) + int O_FLAGS # O_FREEVAL, O_FREEOP + union { + char* O_VALC # string + short O_VALS + int O_VALI # int or bool + long O_VALL + real O_VALR + double O_VALD + pointer O_VALP # vector data + } + } + +The macro O_VALC references the string value of a TY_CHAR operand. The +flags are O_FREEVAL and O_FREEOP, which tell EVVEXPR and EVVFREE whether or +not to free any vector operand array or the operand struct when the operand +is freed. The client should set these flags on operands returned to EVVEXPR +if it wants EVVEXPR to free any operand storage. + +Supported types are bool, char (string), and SILRD. Bool is indicated as +TY_BOOL in the O_TYPE field of the operand struct, but is stored internally +as an integer and the value field of a boolean operand is given by O_VALI. + +Operands may be either scalars or vectors. A vector is indicated by a O_LEN +value greater than zero. For vector operands O_VALP points to the data array. +A special case is TY_CHAR (string), in which case O_LEN is the allocated +length of the EOS-terminated string. A string is logically a scalar value +even though it is physically stored in the operand as a character vector. + +The trig functions operate upon angles in units of radians. The intrinsic +functions RAD and DEG are available for converting between radians and +degrees. A string can be coerced to a binary value and vice versa, using +the INT, STR, etc. intrinsic functions. + +This is a generalization of the older EVEXPR routine, adding additional +datatypes, support for vector operands, and numerous minor enhancements. +.endhelp --------------------------------------------------------------------- + +define YYMAXDEPTH 64 # parser stack length +define MAX_ARGS 17 # max args in a function call +define yyparse xvv_parse + +# Arglist structure. +define LEN_ARGSTRUCT (1+MAX_ARGS+(MAX_ARGS*LEN_OPERAND)) +define A_NARGS Memi[$1] # number of arguments +define A_ARGP Memi[$1+$2] # array of pointers to operand structs +define A_OPS ($1+MAX_ARGS+1) # offset to operand storage area + +# Intrinsic functions. + +define LEN_STAB 300 # for symbol table +define LEN_SBUF 256 +define LEN_INDEX 97 + +define LEN_SYM 1 # symbol data +define SYM_CODE Memi[$1] + +define KEYWORDS "|abs|acos|asin|atan|atan2|bool|cos|cosh|deg|double|\ + |exp|hiv|int|len|log|log10|long|lov|max|mean|median|\ + |min|mod|nint|rad|real|repl|stddev|shift|short|sin|\ + |sinh|sort|sqrt|str|sum|tan|tanh|" + +define F_ABS 01 # function codes +define F_ACOS 02 +define F_ASIN 03 +define F_ATAN 04 +define F_ATAN2 05 +define F_BOOL 06 +define F_COS 07 +define F_COSH 08 +define F_DEG 09 # radians to degrees +define F_DOUBLE 10 + # newline 11 +define F_EXP 12 +define F_HIV 13 # high value +define F_INT 14 +define F_LEN 15 # vector length +define F_LOG 16 +define F_LOG10 17 +define F_LONG 18 +define F_LOV 19 # low value +define F_MAX 20 +define F_MEAN 21 +define F_MEDIAN 22 + # newline 23 +define F_MIN 24 +define F_MOD 25 +define F_NINT 26 +define F_RAD 27 # degrees to radians +define F_REAL 28 +define F_REPL 29 # replicate +define F_STDDEV 30 # standard deviation +define F_SHIFT 31 +define F_SHORT 32 +define F_SIN 33 + # newline 34 +define F_SINH 35 +define F_SORT 36 # sort +define F_SQRT 37 # square root +define F_STR 38 +define F_SUM 39 +define F_TAN 40 +define F_TANH 41 + +define T_B TY_BOOL +define T_C TY_CHAR +define T_S TY_SHORT +define T_I TY_INT +define T_L TY_LONG +define T_R TY_REAL +define T_D TY_DOUBLE + + +# EVVEXPR -- Evaluate a general mixed type vector expression. Input consists +# of the expression to be evaluated (a string) and, optionally, user +# procedures for fetching external operands and executing external functions. +# Output is a pointer to an operand structure containing the computed value of +# the expression. The output operand structure is dynamically allocated by +# EVVEXPR and must be freed by the user. +# +# NOTE: this is not intended to be an especially efficient procedure. Rather, +# this is a high level, easy to use procedure, intended to provide greater +# flexibility in the parameterization of applications programs. The main +# inefficiency is that, since compilation and execution are not broken out as +# separate steps, when the routine is repeatedly called to evaluate the same +# expression with different data, all the compile time computation (parsing +# etc.) has to be repeated. + +pointer procedure evvexpr (expr, getop, getop_data, ufcn, ufcn_data, flags) + +char expr[ARB] #I expression to be evaluated +int getop #I user supplied get operand procedure +int getop_data #I client data for above function +int ufcn #I user supplied function call procedure +int ufcn_data #I client data for above function +int flags #I flag bits + +int junk +pointer sp, ip +bool debug, first_time +int strlen(), xvv_parse() +pointer xvv_loadsymbols() +extern xvv_gettok() + +errchk xvv_parse, calloc +include "evvexpr.com" +data debug /false/ +data first_time /true/ + +begin + call smark (sp) + + if (first_time) { + # This creates data which remains for the life of the process. + ev_st = xvv_loadsymbols (KEYWORDS) + first_time = false + } + + # Set user function entry point addresses. + ev_getop = getop + ev_getop_data = getop_data + ev_ufcn = ufcn + ev_ufcn_data = ufcn_data + ev_flags = flags + + # Allocate an operand struct for the expression value. + call calloc (ev_oval, LEN_OPERAND, TY_STRUCT) + + # Make a local copy of the input string. + call salloc (ip, strlen(expr), TY_CHAR) + call strcpy (expr, Memc[ip], ARB) + + # Evaluate the expression. The expression value is copied into the + # output operand structure by XVV_PARSE, given the operand pointer + # passed in common. A common must be used since the standard parser + # subroutine has a fixed calling sequence. + + junk = xvv_parse (ip, debug, xvv_gettok) + O_FLAGS(ev_oval) = or (O_FLAGS(ev_oval), O_FREEOP) + + call sfree (sp) + return (ev_oval) +end + + +# EVVFREE -- Free an operand struct such as is returned by EVVEXPR. + +procedure evvfree (o) + +pointer o # operand struct + +begin + call xvv_freeop (o) +end + +%L +# XVV_PARSE -- SPP/Yacc parser for the evaluation of an expression passed as +# a text string. Expression evaluation is carried out as the expression is +# parsed, rather than being broken into separate compile and execute stages. +# There is only one statement in this grammar, the expression. Our function +# is to reduce an expression to a single value of type bool, string, int, +# or real. + +pointer ap +bool streq() +errchk zcall3, xvv_error1, xvv_unop, xvv_binop, xvv_boolop +errchk xvv_quest, xvv_callfcn, xvv_addarg +include "evvexpr.com" + +%} + +# The $/ following causes the generic preprocessor to pass this block of code +# through unchanged. + + + +%token CONSTANT IDENTIFIER NEWLINE YYEOS +%token PLUS MINUS STAR SLASH EXPON CONCAT QUEST COLON +%token LT GT LE GT EQ NE SE LAND LOR LNOT BAND BOR BXOR BNOT AT + +%nonassoc QUEST +%left LAND LOR +%left BAND BOR BXOR +%nonassoc EQ NE SE +%nonassoc LT GT LE GE +%left CONCAT +%left PLUS MINUS +%left STAR SLASH +%right UMINUS LNOT BNOT +%left EXPON +%right AT + +%% + +stmt : exprlist YYEOS { + # Normal exit. Move the final expression value operand + # into the operand structure pointed to by the global + # variable ev_oval. + + YYMOVE ($1, ev_oval) + call sfree (yysp) + return (OK) + } + | error { + call error (1, "syntax error") + } + ; + +exprlist: expr { + YYMOVE ($1, $$) + } + | exprlist ',' opnl expr { + YYMOVE ($4, $$) + call xvv_freeop ($1) + } + + +expr : CONSTANT { + # Numeric constant. + YYMOVE ($1, $$) + } + | IDENTIFIER { + # The boolean constants "yes" and "no" are implemented + # as reserved operands. + + call xvv_initop ($$, 0, TY_BOOL) + if (streq (O_VALC($1), "yes")) { + O_VALI($$) = YES + } else if (streq (O_VALC($1), "no")) { + O_VALI($$) = NO + } else if (ev_getop != NULL) { + call zcall3 (ev_getop,ev_getop_data, O_VALC($1), $$) + if (O_TYPE($$) <= 0) + call xvv_error1 ("unknown operand `%s'", + O_VALC($1)) + } else + call xvv_error1 ("illegal operand `%s'", O_VALC($1)) + call xvv_freeop ($1) + } + | AT CONSTANT { + # e.g., @"param" + if (ev_getop != NULL) { + call zcall3 (ev_getop,ev_getop_data, O_VALC($2), $$) + if (O_TYPE($$) <= 0) + call xvv_error1 ("unknown operand `%s'", + O_VALC($1)) + } else + call xvv_error1 ("illegal operand `%s'", O_VALC($2)) + call xvv_freeop ($2) + } + | MINUS expr %prec UMINUS { + # Unary arithmetic minus. + call xvv_unop (MINUS, $2, $$) + } + | LNOT expr { + # Logical not. + call xvv_unop (LNOT, $2, $$) + } + | BNOT expr { + # Boolean not. + call xvv_unop (BNOT, $2, $$) + } + | expr PLUS opnl expr { + # Addition. + call xvv_binop (PLUS, $1, $4, $$) + } + | expr MINUS opnl expr { + # Subtraction. + call xvv_binop (MINUS, $1, $4, $$) + } + | expr STAR opnl expr { + # Multiplication. + call xvv_binop (STAR, $1, $4, $$) + } + | expr SLASH opnl expr { + # Division. + call xvv_binop (SLASH, $1, $4, $$) + } + | expr EXPON opnl expr { + # Exponentiation. + call xvv_binop (EXPON, $1, $4, $$) + } + | expr CONCAT opnl expr { + # Concatenate two operands. + call xvv_binop (CONCAT, $1, $4, $$) + } + | expr LAND opnl expr { + # Logical and. + call xvv_boolop (LAND, $1, $4, $$) + } + | expr LOR opnl expr { + # Logical or. + call xvv_boolop (LOR, $1, $4, $$) + } + | expr BAND opnl expr { + # Boolean and. + call xvv_binop (BAND, $1, $4, $$) + } + | expr BOR opnl expr { + # Boolean or. + call xvv_binop (BOR, $1, $4, $$) + } + | expr BXOR opnl expr { + # Boolean xor. + call xvv_binop (BXOR, $1, $4, $$) + } + | expr LT opnl expr { + # Boolean less than. + call xvv_boolop (LT, $1, $4, $$) + } + | expr GT opnl expr { + # Boolean greater than. + call xvv_boolop (GT, $1, $4, $$) + } + | expr LE opnl expr { + # Boolean less than or equal. + call xvv_boolop (LE, $1, $4, $$) + } + | expr GE opnl expr { + # Boolean greater than or equal. + call xvv_boolop (GE, $1, $4, $$) + } + | expr EQ opnl expr { + # Boolean equal. + call xvv_boolop (EQ, $1, $4, $$) + } + | expr SE opnl expr { + # String pattern-equal. + call xvv_boolop (SE, $1, $4, $$) + } + | expr NE opnl expr { + # Boolean not equal. + call xvv_boolop (NE, $1, $4, $$) + } + | expr QUEST opnl expr COLON opnl expr { + # Conditional expression. + call xvv_quest ($1, $4, $7, $$) + } + | funct '(' arglist ')' { + # Call an intrinsic or external function. + ap = O_VALP($3) + call xvv_callfcn (O_VALC($1), + A_ARGP(ap,1), A_NARGS(ap), $$) + call xvv_freeop ($1) + call xvv_freeop ($3) + } + | '(' expr ')' { + YYMOVE ($2, $$) + } + ; + + +funct : IDENTIFIER { + YYMOVE ($1, $$) + } + | CONSTANT { + if (O_TYPE($1) != TY_CHAR) + call error (1, "illegal function name") + YYMOVE ($1, $$) + } + ; + + +arglist : { + # Empty. + call xvv_startarglist (NULL, $$) + } + | expr { + # First arg; start a nonnull list. + call xvv_startarglist ($1, $$) + } + | arglist ',' opnl expr { + # Add an argument to an existing list. + call xvv_addarg ($4, $1, $$) + } + ; + + +opnl : # Empty. + | opnl NEWLINE + ; + +%% + +# End generic preprocessor escape. + + + +# XVV_UNOP -- Unary operation. Perform the indicated unary operation on the +# input operand, returning the result as the output operand. + +procedure xvv_unop (opcode, in, out) + +int opcode #I operation to be performed +pointer in #I input operand +pointer out #I output operand + +short val_s +long val_l +int val_i, nelem +errchk xvv_error, xvv_initop +string s_badswitch "unop: bad switch" + +begin + nelem = O_LEN(in) + + switch (opcode) { + case MINUS: + # Unary negation. + call xvv_initop (out, nelem, O_TYPE(in)) + switch (O_TYPE(in)) { + case TY_BOOL, TY_CHAR: + call xvv_error ("negation of a nonarithmetic operand") + + case TY_SHORT: + if (nelem > 0) + call anegs (Mems[O_VALP(in)], Mems[O_VALP(out)], nelem) + else + O_VALS(out) = -O_VALS(in) + + case TY_INT: + if (nelem > 0) + call anegi (Memi[O_VALP(in)], Memi[O_VALP(out)], nelem) + else + O_VALI(out) = -O_VALI(in) + + case TY_LONG: + if (nelem > 0) + call anegl (Meml[O_VALP(in)], Meml[O_VALP(out)], nelem) + else + O_VALL(out) = -O_VALL(in) + + case TY_REAL: + if (nelem > 0) + call anegr (Memr[O_VALP(in)], Memr[O_VALP(out)], nelem) + else + O_VALR(out) = -O_VALR(in) + + case TY_DOUBLE: + if (nelem > 0) + call anegd (Memd[O_VALP(in)], Memd[O_VALP(out)], nelem) + else + O_VALD(out) = -O_VALD(in) + + default: + call xvv_error (s_badswitch) + } + + case LNOT: + # Logical NOT. + + call xvv_initop (out, nelem, TY_BOOL) + switch (O_TYPE(in)) { + case TY_BOOL: + if (nelem > 0) + call abeqki (Memi[O_VALP(in)], NO, Memi[O_VALP(out)], nelem) + else { + if (O_VALI(in) == NO) + O_VALI(out) = YES + else + O_VALI(out) = NO + } + + case TY_SHORT: + if (nelem > 0) { + val_s = NO + call abeqks (Mems[O_VALP(in)], val_s, Memi[O_VALP(out)], + nelem) + } else { + if (O_VALS(in) == NO) + O_VALS(out) = YES + else + O_VALS(out) = NO + } + + case TY_INT: + if (nelem > 0) { + val_i = NO + call abeqki (Memi[O_VALP(in)], val_i, Memi[O_VALP(out)], + nelem) + } else { + if (O_VALI(in) == NO) + O_VALI(out) = YES + else + O_VALI(out) = NO + } + + case TY_LONG: + if (nelem > 0) { + val_l = NO + call abeqkl (Meml[O_VALP(in)], val_l, Memi[O_VALP(out)], + nelem) + } else { + if (O_VALL(in) == NO) + O_VALL(out) = YES + else + O_VALL(out) = NO + } + + case TY_CHAR, TY_REAL, TY_DOUBLE: + call xvv_error ("not of a nonlogical") + default: + call xvv_error (s_badswitch) + } + + case BNOT: + # Bitwise boolean NOT. + + call xvv_initop (out, nelem, O_TYPE(in)) + switch (O_TYPE(in)) { + case TY_BOOL, TY_CHAR, TY_REAL, TY_DOUBLE: + call xvv_error ("boolean not of a noninteger operand") + + case TY_SHORT: + if (nelem > 0) + call anots (Mems[O_VALP(in)], Mems[O_VALP(out)], nelem) + else + O_VALS(out) = not(O_VALS(in)) + + case TY_INT: + if (nelem > 0) + call anoti (Memi[O_VALP(in)], Memi[O_VALP(out)], nelem) + else + O_VALI(out) = not(O_VALI(in)) + + case TY_LONG: + if (nelem > 0) + call anotl (Meml[O_VALP(in)], Meml[O_VALP(out)], nelem) + else + O_VALL(out) = not(O_VALL(in)) + + default: + call xvv_error (s_badswitch) + } + + default: + call xvv_error (s_badswitch) + } + + call xvv_freeop (in) +end + + +# XVV_BINOP -- Binary operation. Perform the indicated arithmetic binary +# operation on the two input operands, returning the result as the output +# operand. + +procedure xvv_binop (opcode, in1, in2, out) + +int opcode #I operation to be performed +pointer in1, in2 #I input operands +pointer out #I output operand + + +short v_s +short xvv_nulls() +extern xvv_nulls() + +int v_i +int xvv_nulli() +extern xvv_nulli() + +long v_l +long xvv_nulll() +extern xvv_nulll() + +real v_r +real xvv_nullr() +extern xvv_nullr() + +double v_d +double xvv_nulld() +extern xvv_nulld() + +pointer sp, otemp, p1, p2, po +int dtype, nelem, len1, len2 +include "evvexpr.com" + +int xvv_newtype(), strlen() +errchk xvv_newtype, xvv_initop, xvv_chtype, xvv_error +string s_badswitch "binop: bad case in switch" +string s_boolop "binop: bitwise boolean operands must be an integer type" +define done_ 91 + +begin + # Set the datatype of the output operand, taking an error action if + # the operands have incompatible datatypes. + + dtype = xvv_newtype (O_TYPE(in1), O_TYPE(in2)) + + # Compute the size of the output operand. If both input operands are + # vectors the length of the output vector is the shorter of the two. + + switch (dtype) { + case TY_BOOL: + call xvv_error ("binop: operation illegal for boolean operands") + case TY_CHAR: + nelem = strlen (O_VALC(in1)) + strlen (O_VALC(in2)) + default: + if (opcode == CONCAT) + nelem = max (1, O_LEN(in1)) + max (1, O_LEN(in2)) + else { + if (O_LEN(in1) > 0 && O_LEN(in2) > 0) + nelem = min (O_LEN(in1), O_LEN(in2)) + else if (O_LEN(in1) > 0) + nelem = O_LEN(in1) + else if (O_LEN(in2) > 0) + nelem = O_LEN(in2) + else + nelem = 0 + } + } + + # Convert input operands to desired type. + if (O_TYPE(in1) != dtype) + call xvv_chtype (in1, in1, dtype) + if (O_TYPE(in2) != dtype) + call xvv_chtype (in2, in2, dtype) + + # If this is a scalar/vector operation make sure the vector is the + # first operand. + + len1 = O_LEN(in1) + len2 = O_LEN(in2) + + if (len1 == 0 && len2 > 0) { + switch (opcode) { + case PLUS: + # Swap operands. + call smark (sp) + call salloc (otemp, LEN_OPERAND, TY_STRUCT) + YYMOVE (in1, otemp) + YYMOVE (in2, in1) + YYMOVE (otemp, in2) + call sfree (sp) + + case CONCAT: + ; # Do nothing + + default: + # Promote operand to a constant vector. Inefficient, but + # better than aborting. + + switch (dtype) { + + case TY_SHORT: + v_s = O_VALS(in1) + call xvv_initop (in1, nelem, dtype) + call amovks (v_s, Mems[O_VALP(in1)], nelem) + + case TY_INT: + v_i = O_VALI(in1) + call xvv_initop (in1, nelem, dtype) + call amovki (v_i, Memi[O_VALP(in1)], nelem) + + case TY_LONG: + v_l = O_VALL(in1) + call xvv_initop (in1, nelem, dtype) + call amovkl (v_l, Meml[O_VALP(in1)], nelem) + + case TY_REAL: + v_r = O_VALR(in1) + call xvv_initop (in1, nelem, dtype) + call amovkr (v_r, Memr[O_VALP(in1)], nelem) + + case TY_DOUBLE: + v_d = O_VALD(in1) + call xvv_initop (in1, nelem, dtype) + call amovkd (v_d, Memd[O_VALP(in1)], nelem) + + } + } + + len1 = O_LEN(in1) + len2 = O_LEN(in2) + } + + # Initialize the output operand. + call xvv_initop (out, nelem, dtype) + + p1 = O_VALP(in1) + p2 = O_VALP(in2) + po = O_VALP(out) + + # The bitwise boolean binary operators a special case since only the + # integer datatypes are permitted. Otherwise the bitwise booleans + # are just like arithmetic booleans. + + if (opcode == BAND || opcode == BOR || opcode == BXOR) { + switch (dtype) { + + case TY_SHORT: + switch (opcode) { + case BAND: + if (len1 <= 0) { + O_VALS(out) = and (O_VALS(in1), O_VALS(in2)) + } else if (len2 <= 0) { + call aandks (Mems[p1], O_VALS(in2), + Mems[po], nelem) + } else { + call aands (Mems[p1], Mems[p2], + Mems[po], nelem) + } + case BOR: + if (len1 <= 0) { + O_VALS(out) = or (O_VALS(in1), O_VALS(in2)) + } else if (len2 <= 0) { + call aborks (Mems[p1], O_VALS(in2), + Mems[po], nelem) + } else { + call abors (Mems[p1], Mems[p2], + Mems[po], nelem) + } + case BXOR: + if (len1 <= 0) { + O_VALS(out) = xor (O_VALS(in1), O_VALS(in2)) + } else if (len2 <= 0) { + call axorks (Mems[p1], O_VALS(in2), + Mems[po], nelem) + } else { + call axors (Mems[p1], Mems[p2], + Mems[po], nelem) + } + } + + case TY_INT: + switch (opcode) { + case BAND: + if (len1 <= 0) { + O_VALI(out) = and (O_VALI(in1), O_VALI(in2)) + } else if (len2 <= 0) { + call aandki (Memi[p1], O_VALI(in2), + Memi[po], nelem) + } else { + call aandi (Memi[p1], Memi[p2], + Memi[po], nelem) + } + case BOR: + if (len1 <= 0) { + O_VALI(out) = or (O_VALI(in1), O_VALI(in2)) + } else if (len2 <= 0) { + call aborki (Memi[p1], O_VALI(in2), + Memi[po], nelem) + } else { + call abori (Memi[p1], Memi[p2], + Memi[po], nelem) + } + case BXOR: + if (len1 <= 0) { + O_VALI(out) = xor (O_VALI(in1), O_VALI(in2)) + } else if (len2 <= 0) { + call axorki (Memi[p1], O_VALI(in2), + Memi[po], nelem) + } else { + call axori (Memi[p1], Memi[p2], + Memi[po], nelem) + } + } + + case TY_LONG: + switch (opcode) { + case BAND: + if (len1 <= 0) { + O_VALL(out) = and (O_VALL(in1), O_VALL(in2)) + } else if (len2 <= 0) { + call aandkl (Meml[p1], O_VALL(in2), + Meml[po], nelem) + } else { + call aandl (Meml[p1], Meml[p2], + Meml[po], nelem) + } + case BOR: + if (len1 <= 0) { + O_VALL(out) = or (O_VALL(in1), O_VALL(in2)) + } else if (len2 <= 0) { + call aborkl (Meml[p1], O_VALL(in2), + Meml[po], nelem) + } else { + call aborl (Meml[p1], Meml[p2], + Meml[po], nelem) + } + case BXOR: + if (len1 <= 0) { + O_VALL(out) = xor (O_VALL(in1), O_VALL(in2)) + } else if (len2 <= 0) { + call axorkl (Meml[p1], O_VALL(in2), + Meml[po], nelem) + } else { + call axorl (Meml[p1], Meml[p2], + Meml[po], nelem) + } + } + + default: + call xvv_error (s_boolop) + } + + goto done_ + } + + # Perform an arithmetic binary operation. + switch (dtype) { + case TY_CHAR: + switch (opcode) { + case CONCAT: + call strcpy (O_VALC(in1), O_VALC(out), ARB) + call strcat (O_VALC(in2), O_VALC(out), ARB) + default: + call xvv_error ("binop: operation illegal for string operands") + } + + case TY_SHORT: + switch (opcode) { + case PLUS: + if (len1 <= 0) { + O_VALS(out) = O_VALS(in1) + O_VALS(in2) + } else if (len2 <= 0) { + call aaddks (Mems[p1], O_VALS(in2), + Mems[po], nelem) + } else { + call aadds (Mems[p1], Mems[p2], + Mems[po], nelem) + } + case MINUS: + if (len1 <= 0) + O_VALS(out) = O_VALS(in1) - O_VALS(in2) + else if (len2 <= 0) + call asubks (Mems[p1], O_VALS(in2), Mems[po], nelem) + else + call asubs (Mems[p1], Mems[p2], Mems[po], nelem) + + case STAR: + if (len1 <= 0) + O_VALS(out) = O_VALS(in1) * O_VALS(in2) + else if (len2 <= 0) + call amulks (Mems[p1], O_VALS(in2), Mems[po], nelem) + else + call amuls (Mems[p1], Mems[p2], Mems[po], nelem) + + case SLASH: + if (and (ev_flags, EV_RNGCHK) == 0) { + # No range checking. + if (len1 <= 0) + O_VALS(out) = O_VALS(in1) / O_VALS(in2) + else if (len2 <= 0) + call adivks (Mems[p1], O_VALS(in2), Mems[po], nelem) + else + call adivs (Mems[p1], Mems[p2], Mems[po], nelem) + } else { + # Check for divide by zero. + if (len1 <= 0) { + if (O_VALS(in2) == 0) + O_VALS(out) = xvv_nulls(0) + else + O_VALS(out) = O_VALS(in1) / O_VALS(in2) + } else if (len2 <= 0) { + if (O_VALS(in2) == 0) + call amovks (xvv_nulls(0), Mems[po], nelem) + else { + call adivks (Mems[p1], O_VALS(in2), Mems[po], + nelem) + } + } else { + call advzs (Mems[p1], Mems[p2], Mems[po], nelem, + xvv_nulls) + } + } + case EXPON: + if (len1 <= 0) + O_VALS(out) = O_VALS(in1) ** O_VALS(in2) + else if (len2 <= 0) + call aexpks (Mems[p1], O_VALS(in2), Mems[po], nelem) + else + call aexps (Mems[p1], Mems[p2], Mems[po], nelem) + + case CONCAT: + # Concatenate two numeric operands. + if (len1 <= 0) { + Mems[po] = O_VALS(in1) + po = po + 1 + } else { + call amovs (Mems[p1], Mems[po], len1) + po = po + len1 + } + if (len2 <= 0) + Mems[po] = O_VALS(in2) + else + call amovs (Mems[p2], Mems[po], len2) + + default: + call xvv_error (s_badswitch) + } + + case TY_INT: + switch (opcode) { + case PLUS: + if (len1 <= 0) { + O_VALI(out) = O_VALI(in1) + O_VALI(in2) + } else if (len2 <= 0) { + call aaddki (Memi[p1], O_VALI(in2), + Memi[po], nelem) + } else { + call aaddi (Memi[p1], Memi[p2], + Memi[po], nelem) + } + case MINUS: + if (len1 <= 0) + O_VALI(out) = O_VALI(in1) - O_VALI(in2) + else if (len2 <= 0) + call asubki (Memi[p1], O_VALI(in2), Memi[po], nelem) + else + call asubi (Memi[p1], Memi[p2], Memi[po], nelem) + + case STAR: + if (len1 <= 0) + O_VALI(out) = O_VALI(in1) * O_VALI(in2) + else if (len2 <= 0) + call amulki (Memi[p1], O_VALI(in2), Memi[po], nelem) + else + call amuli (Memi[p1], Memi[p2], Memi[po], nelem) + + case SLASH: + if (and (ev_flags, EV_RNGCHK) == 0) { + # No range checking. + if (len1 <= 0) + O_VALI(out) = O_VALI(in1) / O_VALI(in2) + else if (len2 <= 0) + call adivki (Memi[p1], O_VALI(in2), Memi[po], nelem) + else + call adivi (Memi[p1], Memi[p2], Memi[po], nelem) + } else { + # Check for divide by zero. + if (len1 <= 0) { + if (O_VALI(in2) == 0) + O_VALI(out) = xvv_nulli(0) + else + O_VALI(out) = O_VALI(in1) / O_VALI(in2) + } else if (len2 <= 0) { + if (O_VALI(in2) == 0) + call amovki (xvv_nulli(0), Memi[po], nelem) + else { + call adivki (Memi[p1], O_VALI(in2), Memi[po], + nelem) + } + } else { + call advzi (Memi[p1], Memi[p2], Memi[po], nelem, + xvv_nulli) + } + } + case EXPON: + if (len1 <= 0) + O_VALI(out) = O_VALI(in1) ** O_VALI(in2) + else if (len2 <= 0) + call aexpki (Memi[p1], O_VALI(in2), Memi[po], nelem) + else + call aexpi (Memi[p1], Memi[p2], Memi[po], nelem) + + case CONCAT: + # Concatenate two numeric operands. + if (len1 <= 0) { + Memi[po] = O_VALI(in1) + po = po + 1 + } else { + call amovi (Memi[p1], Memi[po], len1) + po = po + len1 + } + if (len2 <= 0) + Memi[po] = O_VALI(in2) + else + call amovi (Memi[p2], Memi[po], len2) + + default: + call xvv_error (s_badswitch) + } + + case TY_LONG: + switch (opcode) { + case PLUS: + if (len1 <= 0) { + O_VALL(out) = O_VALL(in1) + O_VALL(in2) + } else if (len2 <= 0) { + call aaddkl (Meml[p1], O_VALL(in2), + Meml[po], nelem) + } else { + call aaddl (Meml[p1], Meml[p2], + Meml[po], nelem) + } + case MINUS: + if (len1 <= 0) + O_VALL(out) = O_VALL(in1) - O_VALL(in2) + else if (len2 <= 0) + call asubkl (Meml[p1], O_VALL(in2), Meml[po], nelem) + else + call asubl (Meml[p1], Meml[p2], Meml[po], nelem) + + case STAR: + if (len1 <= 0) + O_VALL(out) = O_VALL(in1) * O_VALL(in2) + else if (len2 <= 0) + call amulkl (Meml[p1], O_VALL(in2), Meml[po], nelem) + else + call amull (Meml[p1], Meml[p2], Meml[po], nelem) + + case SLASH: + if (and (ev_flags, EV_RNGCHK) == 0) { + # No range checking. + if (len1 <= 0) + O_VALL(out) = O_VALL(in1) / O_VALL(in2) + else if (len2 <= 0) + call adivkl (Meml[p1], O_VALL(in2), Meml[po], nelem) + else + call adivl (Meml[p1], Meml[p2], Meml[po], nelem) + } else { + # Check for divide by zero. + if (len1 <= 0) { + if (O_VALL(in2) == 0) + O_VALL(out) = xvv_nulll(0) + else + O_VALL(out) = O_VALL(in1) / O_VALL(in2) + } else if (len2 <= 0) { + if (O_VALL(in2) == 0) + call amovkl (xvv_nulll(0), Meml[po], nelem) + else { + call adivkl (Meml[p1], O_VALL(in2), Meml[po], + nelem) + } + } else { + call advzl (Meml[p1], Meml[p2], Meml[po], nelem, + xvv_nulll) + } + } + case EXPON: + if (len1 <= 0) + O_VALL(out) = O_VALL(in1) ** O_VALL(in2) + else if (len2 <= 0) + call aexpkl (Meml[p1], O_VALL(in2), Meml[po], nelem) + else + call aexpl (Meml[p1], Meml[p2], Meml[po], nelem) + + case CONCAT: + # Concatenate two numeric operands. + if (len1 <= 0) { + Meml[po] = O_VALL(in1) + po = po + 1 + } else { + call amovl (Meml[p1], Meml[po], len1) + po = po + len1 + } + if (len2 <= 0) + Meml[po] = O_VALL(in2) + else + call amovl (Meml[p2], Meml[po], len2) + + default: + call xvv_error (s_badswitch) + } + + case TY_REAL: + switch (opcode) { + case PLUS: + if (len1 <= 0) { + O_VALR(out) = O_VALR(in1) + O_VALR(in2) + } else if (len2 <= 0) { + call aaddkr (Memr[p1], O_VALR(in2), + Memr[po], nelem) + } else { + call aaddr (Memr[p1], Memr[p2], + Memr[po], nelem) + } + case MINUS: + if (len1 <= 0) + O_VALR(out) = O_VALR(in1) - O_VALR(in2) + else if (len2 <= 0) + call asubkr (Memr[p1], O_VALR(in2), Memr[po], nelem) + else + call asubr (Memr[p1], Memr[p2], Memr[po], nelem) + + case STAR: + if (len1 <= 0) + O_VALR(out) = O_VALR(in1) * O_VALR(in2) + else if (len2 <= 0) + call amulkr (Memr[p1], O_VALR(in2), Memr[po], nelem) + else + call amulr (Memr[p1], Memr[p2], Memr[po], nelem) + + case SLASH: + if (and (ev_flags, EV_RNGCHK) == 0) { + # No range checking. + if (len1 <= 0) + O_VALR(out) = O_VALR(in1) / O_VALR(in2) + else if (len2 <= 0) + call adivkr (Memr[p1], O_VALR(in2), Memr[po], nelem) + else + call adivr (Memr[p1], Memr[p2], Memr[po], nelem) + } else { + # Check for divide by zero. + if (len1 <= 0) { + if (O_VALR(in2) == 0.0) + O_VALR(out) = xvv_nullr(0.0) + else + O_VALR(out) = O_VALR(in1) / O_VALR(in2) + } else if (len2 <= 0) { + if (O_VALR(in2) == 0.0) + call amovkr (xvv_nullr(0.0), Memr[po], nelem) + else { + call adivkr (Memr[p1], O_VALR(in2), Memr[po], + nelem) + } + } else { + call advzr (Memr[p1], Memr[p2], Memr[po], nelem, + xvv_nullr) + } + } + case EXPON: + if (len1 <= 0) + O_VALR(out) = O_VALR(in1) ** O_VALR(in2) + else if (len2 <= 0) + call aexpkr (Memr[p1], O_VALR(in2), Memr[po], nelem) + else + call aexpr (Memr[p1], Memr[p2], Memr[po], nelem) + + case CONCAT: + # Concatenate two numeric operands. + if (len1 <= 0) { + Memr[po] = O_VALR(in1) + po = po + 1 + } else { + call amovr (Memr[p1], Memr[po], len1) + po = po + len1 + } + if (len2 <= 0) + Memr[po] = O_VALR(in2) + else + call amovr (Memr[p2], Memr[po], len2) + + default: + call xvv_error (s_badswitch) + } + + case TY_DOUBLE: + switch (opcode) { + case PLUS: + if (len1 <= 0) { + O_VALD(out) = O_VALD(in1) + O_VALD(in2) + } else if (len2 <= 0) { + call aaddkd (Memd[p1], O_VALD(in2), + Memd[po], nelem) + } else { + call aaddd (Memd[p1], Memd[p2], + Memd[po], nelem) + } + case MINUS: + if (len1 <= 0) + O_VALD(out) = O_VALD(in1) - O_VALD(in2) + else if (len2 <= 0) + call asubkd (Memd[p1], O_VALD(in2), Memd[po], nelem) + else + call asubd (Memd[p1], Memd[p2], Memd[po], nelem) + + case STAR: + if (len1 <= 0) + O_VALD(out) = O_VALD(in1) * O_VALD(in2) + else if (len2 <= 0) + call amulkd (Memd[p1], O_VALD(in2), Memd[po], nelem) + else + call amuld (Memd[p1], Memd[p2], Memd[po], nelem) + + case SLASH: + if (and (ev_flags, EV_RNGCHK) == 0) { + # No range checking. + if (len1 <= 0) + O_VALD(out) = O_VALD(in1) / O_VALD(in2) + else if (len2 <= 0) + call adivkd (Memd[p1], O_VALD(in2), Memd[po], nelem) + else + call adivd (Memd[p1], Memd[p2], Memd[po], nelem) + } else { + # Check for divide by zero. + if (len1 <= 0) { + if (O_VALD(in2) == 0.0D0) + O_VALD(out) = xvv_nulld(0.0D0) + else + O_VALD(out) = O_VALD(in1) / O_VALD(in2) + } else if (len2 <= 0) { + if (O_VALD(in2) == 0.0D0) + call amovkd (xvv_nulld(0.0D0), Memd[po], nelem) + else { + call adivkd (Memd[p1], O_VALD(in2), Memd[po], + nelem) + } + } else { + call advzd (Memd[p1], Memd[p2], Memd[po], nelem, + xvv_nulld) + } + } + case EXPON: + if (len1 <= 0) + O_VALD(out) = O_VALD(in1) ** O_VALD(in2) + else if (len2 <= 0) + call aexpkd (Memd[p1], O_VALD(in2), Memd[po], nelem) + else + call aexpd (Memd[p1], Memd[p2], Memd[po], nelem) + + case CONCAT: + # Concatenate two numeric operands. + if (len1 <= 0) { + Memd[po] = O_VALD(in1) + po = po + 1 + } else { + call amovd (Memd[p1], Memd[po], len1) + po = po + len1 + } + if (len2 <= 0) + Memd[po] = O_VALD(in2) + else + call amovd (Memd[p2], Memd[po], len2) + + default: + call xvv_error (s_badswitch) + } + + default: + call xvv_error (s_badswitch) + } +done_ + # Free any storage in input operands. + call xvv_freeop (in1) + call xvv_freeop (in2) +end + + +# XVV_BOOLOP -- Boolean (actually logical) binary operations. Perform the +# indicated logical operation on the two input operands, returning the result +# as the output operand. The opcodes implemented by this routine are +# characterized by the fact that they all return a logical result (YES or NO +# physically expressed as an integer). + +procedure xvv_boolop (opcode, in1, in2, out) + +int opcode #I operation to be performed +pointer in1, in2 #I input operands +pointer out #I output operand + + +short v_s + +int v_i + +long v_l + +real v_r + +double v_d + +pointer sp, otemp, p1, p2, po +int dtype, nelem, len1, len2 +int xvv_newtype(), xvv_patmatch(), strncmp(), btoi() +errchk xvv_newtype, xvv_initop, xvv_chtype, xvv_error +string s_badop "boolop: illegal operation" +string s_badswitch "boolop: illegal switch" + +begin + # Boolean operands are treated as integer within this routine. + if (O_TYPE(in1) == TY_BOOL) + O_TYPE(in1) = TY_INT + if (O_TYPE(in2) == TY_BOOL) + O_TYPE(in2) = TY_INT + + # Determine the computation type for the operation, i.e., the type + # both input operands must have. This is not the same as the type + # of the output operand, which is always boolean for the operations + # implemented by this routine. + + dtype = xvv_newtype (O_TYPE(in1), O_TYPE(in2)) + + # Compute the size of the output operand. If both input operands are + # vectors the length of the output vector is the shorter of the two. + + if (dtype == TY_CHAR) + nelem = 0 + else { + if (O_LEN(in1) > 0 && O_LEN(in2) > 0) + nelem = min (O_LEN(in1), O_LEN(in2)) + else if (O_LEN(in1) > 0) + nelem = O_LEN(in1) + else if (O_LEN(in2) > 0) + nelem = O_LEN(in2) + else + nelem = 0 + } + + # Convert input operands to desired computation type. + if (O_TYPE(in1) != dtype) + call xvv_chtype (in1, in1, dtype) + if (O_TYPE(in2) != dtype) + call xvv_chtype (in2, in2, dtype) + + # If this is a scalar/vector operation make sure the vector is the + # first operand. + + len1 = O_LEN(in1) + len2 = O_LEN(in2) + + if (len1 == 0 && len2 > 0) { + switch (opcode) { + case EQ, NE: + call smark (sp) + call salloc (otemp, LEN_OPERAND, TY_STRUCT) + YYMOVE (in1, otemp) + YYMOVE (in2, in1) + YYMOVE (otemp, in2) + call sfree (sp) + default: + # Promote operand to a constant vector. Inefficient, but + # better than aborting. + + switch (dtype) { + + case TY_SHORT: + v_s = O_VALS(in1) + call xvv_initop (in1, nelem, dtype) + call amovks (v_s, Mems[O_VALP(in1)], nelem) + + case TY_INT: + v_i = O_VALI(in1) + call xvv_initop (in1, nelem, dtype) + call amovki (v_i, Memi[O_VALP(in1)], nelem) + + case TY_LONG: + v_l = O_VALL(in1) + call xvv_initop (in1, nelem, dtype) + call amovkl (v_l, Meml[O_VALP(in1)], nelem) + + case TY_REAL: + v_r = O_VALR(in1) + call xvv_initop (in1, nelem, dtype) + call amovkr (v_r, Memr[O_VALP(in1)], nelem) + + case TY_DOUBLE: + v_d = O_VALD(in1) + call xvv_initop (in1, nelem, dtype) + call amovkd (v_d, Memd[O_VALP(in1)], nelem) + + } + } + + len1 = O_LEN(in1) + len2 = O_LEN(in2) + } + + # Initialize the output operand. + call xvv_initop (out, nelem, TY_BOOL) + + p1 = O_VALP(in1) + p2 = O_VALP(in2) + po = O_VALP(out) + + # Perform the operation. + if (dtype == TY_CHAR) { + # Character data is a special case. + + switch (opcode) { + case SE: + O_VALI(out) = btoi(xvv_patmatch (O_VALC(in1), O_VALC(in2)) > 0) + case LT: + O_VALI(out) = btoi(strncmp (O_VALC(in1), O_VALC(in2), ARB) < 0) + case LE: + O_VALI(out) = btoi(strncmp (O_VALC(in1), O_VALC(in2), ARB) <= 0) + case GT: + O_VALI(out) = btoi(strncmp (O_VALC(in1), O_VALC(in2), ARB) > 0) + case GE: + O_VALI(out) = btoi(strncmp (O_VALC(in1), O_VALC(in2), ARB) >= 0) + case EQ: + O_VALI(out) = btoi(strncmp (O_VALC(in1), O_VALC(in2), ARB) == 0) + case NE: + O_VALI(out) = btoi(strncmp (O_VALC(in1), O_VALC(in2), ARB) != 0) + default: + call xvv_error (s_badop) + } + + } else if (opcode == LAND || opcode == LOR) { + # Operations supporting only the integer types. + + switch (dtype) { + + case TY_SHORT: + switch (opcode) { + case LAND: + if (len1 <= 0) { + O_VALI(out) = + btoi (O_VALS(in1) != 0 && O_VALS(in2) != 0) + } else if (len2 <= 0) { + call alanks (Mems[p1], O_VALS(in2), Memi[po], nelem) + } else + call alans (Mems[p1], Mems[p2], Memi[po], nelem) + case LOR: + if (len1 <= 0) { + O_VALI(out) = + btoi (O_VALS(in1) != 0 || O_VALS(in2) != 0) + } else if (len2 <= 0) { + call alorks (Mems[p1], O_VALS(in2), Memi[po], nelem) + } else + call alors (Mems[p1], Mems[p2], Memi[po], nelem) + default: + call xvv_error (s_badop) + } + + case TY_INT: + switch (opcode) { + case LAND: + if (len1 <= 0) { + O_VALI(out) = + btoi (O_VALI(in1) != 0 && O_VALI(in2) != 0) + } else if (len2 <= 0) { + call alanki (Memi[p1], O_VALI(in2), Memi[po], nelem) + } else + call alani (Memi[p1], Memi[p2], Memi[po], nelem) + case LOR: + if (len1 <= 0) { + O_VALI(out) = + btoi (O_VALI(in1) != 0 || O_VALI(in2) != 0) + } else if (len2 <= 0) { + call alorki (Memi[p1], O_VALI(in2), Memi[po], nelem) + } else + call alori (Memi[p1], Memi[p2], Memi[po], nelem) + default: + call xvv_error (s_badop) + } + + case TY_LONG: + switch (opcode) { + case LAND: + if (len1 <= 0) { + O_VALI(out) = + btoi (O_VALL(in1) != 0 && O_VALL(in2) != 0) + } else if (len2 <= 0) { + call alankl (Meml[p1], O_VALL(in2), Memi[po], nelem) + } else + call alanl (Meml[p1], Meml[p2], Memi[po], nelem) + case LOR: + if (len1 <= 0) { + O_VALI(out) = + btoi (O_VALL(in1) != 0 || O_VALL(in2) != 0) + } else if (len2 <= 0) { + call alorkl (Meml[p1], O_VALL(in2), Memi[po], nelem) + } else + call alorl (Meml[p1], Meml[p2], Memi[po], nelem) + default: + call xvv_error (s_badop) + } + + default: + call xvv_error (s_badswitch) + } + } else { + # Operations supporting any arithmetic type. + + switch (dtype) { + + case TY_SHORT: + switch (opcode) { + case LT: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALS(in1) < O_VALS(in2)) + else if (len2 <= 0) + call abltks (Mems[p1], O_VALS(in2), Memi[po], nelem) + else + call ablts (Mems[p1], Mems[p2], Memi[po], nelem) + + case LE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALS(in1) <= O_VALS(in2)) + else if (len2 <= 0) + call ableks (Mems[p1], O_VALS(in2), Memi[po], nelem) + else + call ables (Mems[p1], Mems[p2], Memi[po], nelem) + + case GT: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALS(in1) > O_VALS(in2)) + else if (len2 <= 0) + call abgtks (Mems[p1], O_VALS(in2), Memi[po], nelem) + else + call abgts (Mems[p1], Mems[p2], Memi[po], nelem) + + case GE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALS(in1) >= O_VALS(in2)) + else if (len2 <= 0) + call abgeks (Mems[p1], O_VALS(in2), Memi[po], nelem) + else + call abges (Mems[p1], Mems[p2], Memi[po], nelem) + + case EQ: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALS(in1) == O_VALS(in2)) + else if (len2 <= 0) + call abeqks (Mems[p1], O_VALS(in2), Memi[po], nelem) + else + call abeqs (Mems[p1], Mems[p2], Memi[po], nelem) + + case NE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALS(in1) != O_VALS(in2)) + else if (len2 <= 0) + call abneks (Mems[p1], O_VALS(in2), Memi[po], nelem) + else + call abnes (Mems[p1], Mems[p2], Memi[po], nelem) + + default: + call xvv_error (s_badop) + } + + case TY_INT: + switch (opcode) { + case LT: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALI(in1) < O_VALI(in2)) + else if (len2 <= 0) + call abltki (Memi[p1], O_VALI(in2), Memi[po], nelem) + else + call ablti (Memi[p1], Memi[p2], Memi[po], nelem) + + case LE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALI(in1) <= O_VALI(in2)) + else if (len2 <= 0) + call ableki (Memi[p1], O_VALI(in2), Memi[po], nelem) + else + call ablei (Memi[p1], Memi[p2], Memi[po], nelem) + + case GT: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALI(in1) > O_VALI(in2)) + else if (len2 <= 0) + call abgtki (Memi[p1], O_VALI(in2), Memi[po], nelem) + else + call abgti (Memi[p1], Memi[p2], Memi[po], nelem) + + case GE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALI(in1) >= O_VALI(in2)) + else if (len2 <= 0) + call abgeki (Memi[p1], O_VALI(in2), Memi[po], nelem) + else + call abgei (Memi[p1], Memi[p2], Memi[po], nelem) + + case EQ: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALI(in1) == O_VALI(in2)) + else if (len2 <= 0) + call abeqki (Memi[p1], O_VALI(in2), Memi[po], nelem) + else + call abeqi (Memi[p1], Memi[p2], Memi[po], nelem) + + case NE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALI(in1) != O_VALI(in2)) + else if (len2 <= 0) + call abneki (Memi[p1], O_VALI(in2), Memi[po], nelem) + else + call abnei (Memi[p1], Memi[p2], Memi[po], nelem) + + default: + call xvv_error (s_badop) + } + + case TY_LONG: + switch (opcode) { + case LT: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALL(in1) < O_VALL(in2)) + else if (len2 <= 0) + call abltkl (Meml[p1], O_VALL(in2), Memi[po], nelem) + else + call abltl (Meml[p1], Meml[p2], Memi[po], nelem) + + case LE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALL(in1) <= O_VALL(in2)) + else if (len2 <= 0) + call ablekl (Meml[p1], O_VALL(in2), Memi[po], nelem) + else + call ablel (Meml[p1], Meml[p2], Memi[po], nelem) + + case GT: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALL(in1) > O_VALL(in2)) + else if (len2 <= 0) + call abgtkl (Meml[p1], O_VALL(in2), Memi[po], nelem) + else + call abgtl (Meml[p1], Meml[p2], Memi[po], nelem) + + case GE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALL(in1) >= O_VALL(in2)) + else if (len2 <= 0) + call abgekl (Meml[p1], O_VALL(in2), Memi[po], nelem) + else + call abgel (Meml[p1], Meml[p2], Memi[po], nelem) + + case EQ: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALL(in1) == O_VALL(in2)) + else if (len2 <= 0) + call abeqkl (Meml[p1], O_VALL(in2), Memi[po], nelem) + else + call abeql (Meml[p1], Meml[p2], Memi[po], nelem) + + case NE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALL(in1) != O_VALL(in2)) + else if (len2 <= 0) + call abnekl (Meml[p1], O_VALL(in2), Memi[po], nelem) + else + call abnel (Meml[p1], Meml[p2], Memi[po], nelem) + + default: + call xvv_error (s_badop) + } + + case TY_REAL: + switch (opcode) { + case LT: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALR(in1) < O_VALR(in2)) + else if (len2 <= 0) + call abltkr (Memr[p1], O_VALR(in2), Memi[po], nelem) + else + call abltr (Memr[p1], Memr[p2], Memi[po], nelem) + + case LE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALR(in1) <= O_VALR(in2)) + else if (len2 <= 0) + call ablekr (Memr[p1], O_VALR(in2), Memi[po], nelem) + else + call abler (Memr[p1], Memr[p2], Memi[po], nelem) + + case GT: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALR(in1) > O_VALR(in2)) + else if (len2 <= 0) + call abgtkr (Memr[p1], O_VALR(in2), Memi[po], nelem) + else + call abgtr (Memr[p1], Memr[p2], Memi[po], nelem) + + case GE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALR(in1) >= O_VALR(in2)) + else if (len2 <= 0) + call abgekr (Memr[p1], O_VALR(in2), Memi[po], nelem) + else + call abger (Memr[p1], Memr[p2], Memi[po], nelem) + + case EQ: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALR(in1) == O_VALR(in2)) + else if (len2 <= 0) + call abeqkr (Memr[p1], O_VALR(in2), Memi[po], nelem) + else + call abeqr (Memr[p1], Memr[p2], Memi[po], nelem) + + case NE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALR(in1) != O_VALR(in2)) + else if (len2 <= 0) + call abnekr (Memr[p1], O_VALR(in2), Memi[po], nelem) + else + call abner (Memr[p1], Memr[p2], Memi[po], nelem) + + default: + call xvv_error (s_badop) + } + + case TY_DOUBLE: + switch (opcode) { + case LT: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALD(in1) < O_VALD(in2)) + else if (len2 <= 0) + call abltkd (Memd[p1], O_VALD(in2), Memi[po], nelem) + else + call abltd (Memd[p1], Memd[p2], Memi[po], nelem) + + case LE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALD(in1) <= O_VALD(in2)) + else if (len2 <= 0) + call ablekd (Memd[p1], O_VALD(in2), Memi[po], nelem) + else + call abled (Memd[p1], Memd[p2], Memi[po], nelem) + + case GT: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALD(in1) > O_VALD(in2)) + else if (len2 <= 0) + call abgtkd (Memd[p1], O_VALD(in2), Memi[po], nelem) + else + call abgtd (Memd[p1], Memd[p2], Memi[po], nelem) + + case GE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALD(in1) >= O_VALD(in2)) + else if (len2 <= 0) + call abgekd (Memd[p1], O_VALD(in2), Memi[po], nelem) + else + call abged (Memd[p1], Memd[p2], Memi[po], nelem) + + case EQ: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALD(in1) == O_VALD(in2)) + else if (len2 <= 0) + call abeqkd (Memd[p1], O_VALD(in2), Memi[po], nelem) + else + call abeqd (Memd[p1], Memd[p2], Memi[po], nelem) + + case NE: + if (len1 <= 0) + O_VALI(out) = btoi (O_VALD(in1) != O_VALD(in2)) + else if (len2 <= 0) + call abnekd (Memd[p1], O_VALD(in2), Memi[po], nelem) + else + call abned (Memd[p1], Memd[p2], Memi[po], nelem) + + default: + call xvv_error (s_badop) + } + + default: + call xvv_error (s_badswitch) + } + } + + # Free any storage in input operands. + call xvv_freeop (in1) + call xvv_freeop (in2) +end + + +# XVV_PATMATCH -- Match a string against a pattern, returning the patmatch +# index if the string matches. The pattern may contain any of the conventional +# pattern matching metacharacters. Closure (i.e., "*") is mapped to "?*". + +int procedure xvv_patmatch (str, pat) + +char str[ARB] #I operand string +char pat[ARB] #I pattern + +int junk, ip, index +pointer sp, patstr, patbuf, op +int patmake(), patmatch() + +begin + call smark (sp) + call salloc (patstr, SZ_FNAME, TY_CHAR) + call salloc (patbuf, SZ_LINE, TY_CHAR) + call aclrc (Memc[patstr], SZ_FNAME) + call aclrc (Memc[patbuf], SZ_LINE) + + # Map pattern, changing '*' into '?*'. + op = patstr + for (ip=1; pat[ip] != EOS; ip=ip+1) { + if (pat[ip] == '*') { + Memc[op] = '?' + op = op + 1 + } + Memc[op] = pat[ip] + op = op + 1 + } + + # Encode pattern. + junk = patmake (Memc[patstr], Memc[patbuf], SZ_LINE) + + # Perform the pattern matching operation. + index = patmatch (str, Memc[patbuf]) + + call sfree (sp) + return (index) +end + + +# XVV_NEWTYPE -- Get the datatype of a binary operation, given the datatypes +# of the two input operands. An error action is taken if the datatypes are +# incompatible, e.g., boolean and anything else or string and anything else. + +int procedure xvv_newtype (type1, type2) + +int type1 #I datatype of first operand +int type2 #I datatype of second operand + +int newtype, p, q, i +int tyindex[NTYPES], ttbl[NTYPES*NTYPES] +data tyindex /T_B, T_C, T_S, T_I, T_L, T_R, T_D/ + +data (ttbl(i),i= 1, 7) /T_B, 0, 0, 0, 0, 0, 0/ +data (ttbl(i),i= 8,14) / 0, T_C, 0, 0, 0, 0, 0/ +data (ttbl(i),i=15,21) / 0, 0, T_S, T_I, T_L, T_R, T_D/ +data (ttbl(i),i=22,28) / 0, 0, T_I, T_I, T_L, T_R, T_D/ +data (ttbl(i),i=29,35) / 0, 0, T_L, T_L, T_L, T_R, T_D/ +data (ttbl(i),i=36,42) / 0, 0, T_R, T_R, T_R, T_R, T_D/ +data (ttbl(i),i=43,49) / 0, 0, T_D, T_D, T_D, T_D, T_D/ + +begin + do i = 1, NTYPES { + if (tyindex[i] == type1) + p = i + if (tyindex[i] == type2) + q = i + } + + newtype = ttbl[(p-1)*NTYPES+q] + if (newtype == 0) + call xvv_error ("operands have incompatible types") + else + return (newtype) +end + + +# XVV_QUEST -- Conditional expression. If the condition operand is true +# return the first (true) operand, else return the second (false) operand. + +procedure xvv_quest (cond, in1, in2, out) + +pointer cond #I pointer to condition operand +pointer in1, in2 #I pointer to true,false operands +pointer out #I pointer to output operand + +int dtype, nelem, i +pointer sp, otemp, ip1, ip2, op, sel +errchk xvv_error, xvv_newtype, xvv_initop, xvv_chtype +int xvv_newtype(), btoi() + +begin + switch (O_TYPE(cond)) { + case TY_BOOL, TY_INT: + ; + case TY_SHORT, TY_LONG: + call xvv_chtype (cond, cond, TY_BOOL) + default: + call xvv_error ("evvexpr: nonboolean condition operand") + } + + if (O_LEN(cond) <= 0 && + (O_LEN(in1) <= 0 || O_TYPE(in1) == TY_CHAR) && + (O_LEN(in2) <= 0 || O_TYPE(in2) == TY_CHAR)) { + + # Both operands and the conditional are scalars; the expression + # type is the type of the selected operand. + + if (O_VALI(cond) != 0) { + YYMOVE (in1, out) + call xvv_freeop (in2) + } else { + YYMOVE (in2, out) + call xvv_freeop (in1) + } + + } else if (O_TYPE(in1) == TY_CHAR || O_TYPE(in2) == TY_CHAR) { + # This combination is not legal. + call xvv_error ("evvexpr: character and vector in cond expr") + + } else { + # Vector/scalar or vector/vector operation. Both operands must + # be of the same type. + + dtype = xvv_newtype (O_TYPE(in1), O_TYPE(in2)) + + # Compute the size of the output operand. If both input operands + # are vectors the length of the output vector is the shorter of + # the two. The condition operand contributes to the dimension of + # the expression result, although not to the datatype. + + nelem = 0 + if (O_LEN(in1) > 0 && O_LEN(in2) > 0) + nelem = min (O_LEN(in1), O_LEN(in2)) + else if (O_LEN(in1) > 0) + nelem = O_LEN(in1) + else if (O_LEN(in2) > 0) + nelem = O_LEN(in2) + + if (O_LEN(cond) > 0 && nelem > 0) + nelem = min (O_LEN(cond), nelem) + else if (O_LEN(cond) > 0) + nelem = O_LEN(cond) + + # If this is a scalar/vector operation make sure the vector is the + # first operand. + + if (O_LEN(in1) == 0 && O_LEN(in2) > 0) { + call smark (sp) + call salloc (otemp, LEN_OPERAND, TY_STRUCT) + YYMOVE (in1, otemp) + YYMOVE (in2, in1) + YYMOVE (otemp, in2) + call sfree (sp) + + # Since we are swapping arguments we need to negate the cond. + if (O_LEN(cond) <= 0) + O_VALI(cond) = btoi (O_VALI(cond) == 0) + else { + call abeqki (Memi[O_VALP(cond)], NO, Memi[O_VALP(cond)], + nelem) + } + } + + # Initialize the output operand. + call xvv_initop (out, nelem, dtype) + + # Convert input operands to desired computation type. + if (O_TYPE(in1) != dtype) + call xvv_chtype (in1, in1, dtype) + if (O_TYPE(in2) != dtype) + call xvv_chtype (in2, in2, dtype) + + ip1 = O_VALP(in1) + ip2 = O_VALP(in2) + op = O_VALP(out) + sel = O_VALP(cond) + + # Perform the operation. + switch (dtype) { + + case TY_SHORT: + if (O_LEN(in1) <= 0 && O_LEN(in2) <= 0) { + # Vector conditional, both operands are scalars. + do i = 1, nelem + if (Memi[sel+i-1] != 0) + Mems[op+i-1] = O_VALS(in1) + else + Mems[op+i-1] = O_VALS(in2) + + } else if (O_LEN(in2) <= 0) { + # Operand 1 is a vector, operand 2 is a scalar. + if (O_LEN(cond) <= 0) { + # Conditional is a scalar. + if (O_VALI(cond) != 0) + call amovs (Mems[ip1], Mems[op], nelem) + else + call amovks (O_VALS(in2), Mems[op], nelem) + } else { + # Conditional is a vector. + call aselks (Mems[ip1], O_VALS(in2), Mems[op], + Memi[sel], nelem) + } + } else { + # Both operands are vectors. + if (O_LEN(cond) <= 0) { + # Conditional is a scalar. + if (O_VALI(cond) != 0) + call amovs (Mems[ip1], Mems[op], nelem) + else + call amovs (Mems[ip2], Mems[op], nelem) + } else { + # Conditional is a vector. + call asels (Mems[ip1], Mems[ip2], Mems[op], + Memi[sel], nelem) + } + } + + case TY_INT: + if (O_LEN(in1) <= 0 && O_LEN(in2) <= 0) { + # Vector conditional, both operands are scalars. + do i = 1, nelem + if (Memi[sel+i-1] != 0) + Memi[op+i-1] = O_VALI(in1) + else + Memi[op+i-1] = O_VALI(in2) + + } else if (O_LEN(in2) <= 0) { + # Operand 1 is a vector, operand 2 is a scalar. + if (O_LEN(cond) <= 0) { + # Conditional is a scalar. + if (O_VALI(cond) != 0) + call amovi (Memi[ip1], Memi[op], nelem) + else + call amovki (O_VALI(in2), Memi[op], nelem) + } else { + # Conditional is a vector. + call aselki (Memi[ip1], O_VALI(in2), Memi[op], + Memi[sel], nelem) + } + } else { + # Both operands are vectors. + if (O_LEN(cond) <= 0) { + # Conditional is a scalar. + if (O_VALI(cond) != 0) + call amovi (Memi[ip1], Memi[op], nelem) + else + call amovi (Memi[ip2], Memi[op], nelem) + } else { + # Conditional is a vector. + call aseli (Memi[ip1], Memi[ip2], Memi[op], + Memi[sel], nelem) + } + } + + case TY_LONG: + if (O_LEN(in1) <= 0 && O_LEN(in2) <= 0) { + # Vector conditional, both operands are scalars. + do i = 1, nelem + if (Memi[sel+i-1] != 0) + Meml[op+i-1] = O_VALL(in1) + else + Meml[op+i-1] = O_VALL(in2) + + } else if (O_LEN(in2) <= 0) { + # Operand 1 is a vector, operand 2 is a scalar. + if (O_LEN(cond) <= 0) { + # Conditional is a scalar. + if (O_VALI(cond) != 0) + call amovl (Meml[ip1], Meml[op], nelem) + else + call amovkl (O_VALL(in2), Meml[op], nelem) + } else { + # Conditional is a vector. + call aselkl (Meml[ip1], O_VALL(in2), Meml[op], + Memi[sel], nelem) + } + } else { + # Both operands are vectors. + if (O_LEN(cond) <= 0) { + # Conditional is a scalar. + if (O_VALI(cond) != 0) + call amovl (Meml[ip1], Meml[op], nelem) + else + call amovl (Meml[ip2], Meml[op], nelem) + } else { + # Conditional is a vector. + call asell (Meml[ip1], Meml[ip2], Meml[op], + Memi[sel], nelem) + } + } + + case TY_REAL: + if (O_LEN(in1) <= 0 && O_LEN(in2) <= 0) { + # Vector conditional, both operands are scalars. + do i = 1, nelem + if (Memi[sel+i-1] != 0) + Memr[op+i-1] = O_VALR(in1) + else + Memr[op+i-1] = O_VALR(in2) + + } else if (O_LEN(in2) <= 0) { + # Operand 1 is a vector, operand 2 is a scalar. + if (O_LEN(cond) <= 0) { + # Conditional is a scalar. + if (O_VALI(cond) != 0) + call amovr (Memr[ip1], Memr[op], nelem) + else + call amovkr (O_VALR(in2), Memr[op], nelem) + } else { + # Conditional is a vector. + call aselkr (Memr[ip1], O_VALR(in2), Memr[op], + Memi[sel], nelem) + } + } else { + # Both operands are vectors. + if (O_LEN(cond) <= 0) { + # Conditional is a scalar. + if (O_VALI(cond) != 0) + call amovr (Memr[ip1], Memr[op], nelem) + else + call amovr (Memr[ip2], Memr[op], nelem) + } else { + # Conditional is a vector. + call aselr (Memr[ip1], Memr[ip2], Memr[op], + Memi[sel], nelem) + } + } + + case TY_DOUBLE: + if (O_LEN(in1) <= 0 && O_LEN(in2) <= 0) { + # Vector conditional, both operands are scalars. + do i = 1, nelem + if (Memi[sel+i-1] != 0) + Memd[op+i-1] = O_VALD(in1) + else + Memd[op+i-1] = O_VALD(in2) + + } else if (O_LEN(in2) <= 0) { + # Operand 1 is a vector, operand 2 is a scalar. + if (O_LEN(cond) <= 0) { + # Conditional is a scalar. + if (O_VALI(cond) != 0) + call amovd (Memd[ip1], Memd[op], nelem) + else + call amovkd (O_VALD(in2), Memd[op], nelem) + } else { + # Conditional is a vector. + call aselkd (Memd[ip1], O_VALD(in2), Memd[op], + Memi[sel], nelem) + } + } else { + # Both operands are vectors. + if (O_LEN(cond) <= 0) { + # Conditional is a scalar. + if (O_VALI(cond) != 0) + call amovd (Memd[ip1], Memd[op], nelem) + else + call amovd (Memd[ip2], Memd[op], nelem) + } else { + # Conditional is a vector. + call aseld (Memd[ip1], Memd[ip2], Memd[op], + Memi[sel], nelem) + } + } + + default: + call xvv_error ("evvexpr: bad datatype in cond expr") + } + + call xvv_freeop (in1) + call xvv_freeop (in2) + } + + call xvv_freeop (cond) +end + + +# XVV_CALLFCN -- Call an intrinsic function. If the function named is not +# one of the standard intrinsic functions, call an external user function +# if a function call procedure was supplied. + +procedure xvv_callfcn (fcn, args, nargs, out) + +char fcn[ARB] #I function to be called +pointer args[ARB] #I pointer to arglist descriptor +int nargs #I number of arguments +pointer out #I output operand (function value) + + +short v_s +short ahivs(), alovs() +short ameds() +int aravs() + +int v_i +int ahivi(), alovi() +int amedi() +int aravi() + +long v_l +long ahivl(), alovl() +long amedl() +int aravl() + +real v_r +real ahivr(), alovr() +real amedr() +int aravr() + +double v_d +double ahivd(), alovd() +double amedd() +int aravd() + + +real mean_r, sigma_r +double mean_d, sigma_d +real asums(), asumi(), asumr() +double asuml(), asumd() + +bool rangecheck +int optype, opcode +int chunk, repl, nelem, v_nargs, ch, shift, i, j +pointer sp, sym, buf, ap, ip, op, in1, in2 +include "evvexpr.com" + +pointer stfind() +int xvv_newtype(), strlen(), gctod(), btoi() +errchk xvv_chtype, xvv_initop, xvv_newtype, xvv_error1, xvv_error2 +errchk zcall5, malloc + +string s_badtype "%s: illegal operand type" +define free_ 91 + +begin + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + + # Lookup the function name in the symbol table. + sym = stfind (ev_st, fcn) + if (sym != NULL) + opcode = SYM_CODE(sym) + else + opcode = 0 + + # If the function named is not a standard one and the user has supplied + # the entry point of an external function evaluation procedure, call + # the user procedure to evaluate the function, otherwise abort. + + if (opcode <= 0) + if (ev_ufcn != NULL) { + call zcall5 (ev_ufcn, ev_ufcn_data, fcn, args, nargs, out) + if (O_TYPE(out) <= 0) + call xvv_error1 ("unrecognized macro or function `%s'", fcn) + goto free_ + } else + call xvv_error1 ("unknown function `%s' called", fcn) + + # Range checking on functions that need it? + rangecheck = (and (ev_flags, EV_RNGCHK) != 0) + + # Verify correct number of arguments. + switch (opcode) { + case F_MOD, F_REPL, F_SHIFT: + v_nargs = 2 + case F_MAX, F_MIN, F_ATAN, F_ATAN2, F_MEAN, F_STDDEV, F_MEDIAN: + v_nargs = -1 + default: + v_nargs = 1 + } + if (v_nargs > 0 && nargs != v_nargs) + call xvv_error2 ("function `%s' requires %d arguments", + fcn, v_nargs) + else if (v_nargs < 0 && nargs < abs(v_nargs)) + call xvv_error2 ("function `%s' requires at least %d arguments", + fcn, abs(v_nargs)) + + # Some functions require that the input operand be a certain type, + # e.g. floating. Handle the simple cases, converting input operands + # to the desired type. + + switch (opcode) { + case F_ACOS, F_ASIN, F_ATAN, F_ATAN2, F_COS, F_COSH, F_DEG, F_EXP, + F_LOG, F_LOG10, F_RAD, F_SIN, F_SINH, F_SQRT, F_TAN, F_TANH: + + # These functions want a floating point input operand. + optype = TY_REAL + do i = 1, nargs { + if (O_TYPE(args[i]) == TY_DOUBLE || O_TYPE(args[i]) == TY_LONG) + optype = TY_DOUBLE + } + do i = 1, nargs { + if (O_TYPE(args[i]) != optype) + call xvv_chtype (args[i], args[i], optype) + } + call xvv_initop (out, O_LEN(args[1]), optype) + + case F_MOD, F_MIN, F_MAX, F_MEDIAN: + # These functions may have multiple arguments, all of which + # should be the same type. + + optype = O_TYPE(args[1]) + nelem = O_LEN(args[1]) + do i = 2, nargs { + optype = xvv_newtype (optype, O_TYPE(args[i])) + if (O_LEN(args[i]) > 0) + if (nelem > 0) + nelem = min (nelem, O_LEN(args[i])) + else if (nelem == 0) + nelem = O_LEN(args[i]) + } + + do i = 1, nargs + if (O_TYPE(args[i]) != optype) + call xvv_chtype (args[i], args[i], optype) + + if (nargs == 1 && opcode == F_MEDIAN) + nelem = 0 + call xvv_initop (out, nelem, optype) + + case F_LEN: + # This function always returns an integer scalar value. + nelem = 0 + optype = TY_INT + call xvv_initop (out, nelem, optype) + + case F_HIV, F_LOV: + # These functions return a scalar value. + nelem = 0 + optype = O_TYPE(args[1]) + if (optype == TY_BOOL) + optype = TY_INT + call xvv_initop (out, nelem, optype) + + case F_SUM, F_MEAN, F_STDDEV: + # These functions require a vector argument and return a scalar + # value. + + nelem = 0 + optype = O_TYPE(args[1]) + if (optype == TY_BOOL) + optype = TY_INT + + if (optype == TY_DOUBLE) + call xvv_initop (out, nelem, TY_DOUBLE) + else + call xvv_initop (out, nelem, TY_REAL) + + case F_SORT, F_SHIFT: + # Vector to vector, no type conversions. + nelem = O_LEN(args[1]) + optype = O_TYPE(args[1]) + call xvv_initop (out, nelem, optype) + + default: + optype = 0 + } + + # Evaluate the function. + ap = args[1] + + switch (opcode) { + case F_ABS: + call xvv_initop (out, O_LEN(ap), O_TYPE(ap)) + switch (O_TYPE(ap)) { + + case TY_SHORT: + if (O_LEN(ap) > 0) { + call aabss (Mems[O_VALP(ap)], Mems[O_VALP(out)], + O_LEN(ap)) + } else + O_VALS(out) = abs(O_VALS(ap)) + + case TY_INT: + if (O_LEN(ap) > 0) { + call aabsi (Memi[O_VALP(ap)], Memi[O_VALP(out)], + O_LEN(ap)) + } else + O_VALI(out) = abs(O_VALI(ap)) + + case TY_LONG: + if (O_LEN(ap) > 0) { + call aabsl (Meml[O_VALP(ap)], Meml[O_VALP(out)], + O_LEN(ap)) + } else + O_VALL(out) = abs(O_VALL(ap)) + + case TY_REAL: + if (O_LEN(ap) > 0) { + call aabsr (Memr[O_VALP(ap)], Memr[O_VALP(out)], + O_LEN(ap)) + } else + O_VALR(out) = abs(O_VALR(ap)) + + case TY_DOUBLE: + if (O_LEN(ap) > 0) { + call aabsd (Memd[O_VALP(ap)], Memd[O_VALP(out)], + O_LEN(ap)) + } else + O_VALD(out) = abs(O_VALD(ap)) + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_ACOS: + + if (optype == TY_REAL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memr[O_VALP(out)+i-1] = acos (Memr[O_VALP(ap)+i-1]) + } else + O_VALR(out) = acos (O_VALR(ap)) + + if (optype == TY_DOUBLE) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memd[O_VALP(out)+i-1] = acos (Memd[O_VALP(ap)+i-1]) + } else + O_VALD(out) = acos (O_VALD(ap)) + + case F_ASIN: + + if (optype == TY_REAL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memr[O_VALP(out)+i-1] = asin (Memr[O_VALP(ap)+i-1]) + } else + O_VALR(out) = asin (O_VALR(ap)) + + if (optype == TY_DOUBLE) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memd[O_VALP(out)+i-1] = asin (Memd[O_VALP(ap)+i-1]) + } else + O_VALD(out) = asin (O_VALD(ap)) + + case F_COS: + + if (optype == TY_REAL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memr[O_VALP(out)+i-1] = cos (Memr[O_VALP(ap)+i-1]) + } else + O_VALR(out) = cos (O_VALR(ap)) + + if (optype == TY_DOUBLE) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memd[O_VALP(out)+i-1] = cos (Memd[O_VALP(ap)+i-1]) + } else + O_VALD(out) = cos (O_VALD(ap)) + + case F_COSH: + + if (optype == TY_REAL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memr[O_VALP(out)+i-1] = cosh (Memr[O_VALP(ap)+i-1]) + } else + O_VALR(out) = cosh (O_VALR(ap)) + + if (optype == TY_DOUBLE) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memd[O_VALP(out)+i-1] = cosh (Memd[O_VALP(ap)+i-1]) + } else + O_VALD(out) = cosh (O_VALD(ap)) + + case F_DEG: + + if (optype == TY_REAL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memr[O_VALP(out)+i-1] = RADTODEG(Memr[O_VALP(ap)+i-1]) + } else + O_VALR(out) = RADTODEG (O_VALR(ap)) + + if (optype == TY_DOUBLE) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memd[O_VALP(out)+i-1] = RADTODEG(Memd[O_VALP(ap)+i-1]) + } else + O_VALD(out) = RADTODEG (O_VALD(ap)) + + case F_EXP: + + if (optype == TY_REAL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memr[O_VALP(out)+i-1] = exp (Memr[O_VALP(ap)+i-1]) + } else + O_VALR(out) = exp (O_VALR(ap)) + + if (optype == TY_DOUBLE) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memd[O_VALP(out)+i-1] = exp (Memd[O_VALP(ap)+i-1]) + } else + O_VALD(out) = exp (O_VALD(ap)) + + case F_LOG: + + if (optype == TY_REAL) + if (O_LEN(ap) > 0) { + op = O_VALP(out) + do i = 1, O_LEN(ap) { + v_r = Memr[O_VALP(ap)+i-1] + if (rangecheck && v_r <= 0) + Memr[op] = 0 + else + Memr[op] = log (v_r) + op = op + 1 + } + } else { + v_r = O_VALR(ap) + if (rangecheck && v_r <= 0) + O_VALR(out) = 0 + else + O_VALR(out) = log (v_r) + } + + if (optype == TY_DOUBLE) + if (O_LEN(ap) > 0) { + op = O_VALP(out) + do i = 1, O_LEN(ap) { + v_d = Memd[O_VALP(ap)+i-1] + if (rangecheck && v_d <= 0) + Memd[op] = 0 + else + Memd[op] = log (v_d) + op = op + 1 + } + } else { + v_d = O_VALD(ap) + if (rangecheck && v_d <= 0) + O_VALD(out) = 0 + else + O_VALD(out) = log (v_d) + } + + case F_LOG10: + + if (optype == TY_REAL) + if (O_LEN(ap) > 0) { + op = O_VALP(out) + do i = 1, O_LEN(ap) { + v_r = Memr[O_VALP(ap)+i-1] + if (rangecheck && v_r <= 0) + Memr[op] = 0 + else + Memr[op] = log10 (v_r) + op = op + 1 + } + } else { + v_r = O_VALR(ap) + if (rangecheck && v_r <= 0) + O_VALR(out) = 0 + else + O_VALR(out) = log10 (v_r) + } + + if (optype == TY_DOUBLE) + if (O_LEN(ap) > 0) { + op = O_VALP(out) + do i = 1, O_LEN(ap) { + v_d = Memd[O_VALP(ap)+i-1] + if (rangecheck && v_d <= 0) + Memd[op] = 0 + else + Memd[op] = log10 (v_d) + op = op + 1 + } + } else { + v_d = O_VALD(ap) + if (rangecheck && v_d <= 0) + O_VALD(out) = 0 + else + O_VALD(out) = log10 (v_d) + } + + case F_RAD: + + if (optype == TY_REAL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memr[O_VALP(out)+i-1] = DEGTORAD(Memr[O_VALP(ap)+i-1]) + } else + O_VALR(out) = DEGTORAD (O_VALR(ap)) + + if (optype == TY_DOUBLE) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memd[O_VALP(out)+i-1] = DEGTORAD(Memd[O_VALP(ap)+i-1]) + } else + O_VALD(out) = DEGTORAD (O_VALD(ap)) + + case F_SIN: + + if (optype == TY_REAL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memr[O_VALP(out)+i-1] = sin (Memr[O_VALP(ap)+i-1]) + } else + O_VALR(out) = sin (O_VALR(ap)) + + if (optype == TY_DOUBLE) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memd[O_VALP(out)+i-1] = sin (Memd[O_VALP(ap)+i-1]) + } else + O_VALD(out) = sin (O_VALD(ap)) + + case F_SINH: + + if (optype == TY_REAL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memr[O_VALP(out)+i-1] = sinh (Memr[O_VALP(ap)+i-1]) + } else + O_VALR(out) = sinh (O_VALR(ap)) + + if (optype == TY_DOUBLE) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memd[O_VALP(out)+i-1] = sinh (Memd[O_VALP(ap)+i-1]) + } else + O_VALD(out) = sinh (O_VALD(ap)) + + case F_SQRT: + + if (optype == TY_REAL) + if (O_LEN(ap) > 0) { + op = O_VALP(out) + do i = 1, O_LEN(ap) { + v_r = Memr[O_VALP(ap)+i-1] + if (rangecheck && v_r < 0) + Memr[op] = 0 + else + Memr[op] = sqrt (v_r) + op = op + 1 + } + } else { + v_r = O_VALR(ap) + if (rangecheck && v_r <= 0) + O_VALR(out) = 0 + else + O_VALR(out) = sqrt (v_r) + } + + if (optype == TY_DOUBLE) + if (O_LEN(ap) > 0) { + op = O_VALP(out) + do i = 1, O_LEN(ap) { + v_d = Memd[O_VALP(ap)+i-1] + if (rangecheck && v_d < 0) + Memd[op] = 0 + else + Memd[op] = sqrt (v_d) + op = op + 1 + } + } else { + v_d = O_VALD(ap) + if (rangecheck && v_d <= 0) + O_VALD(out) = 0 + else + O_VALD(out) = sqrt (v_d) + } + + case F_TAN: + + if (optype == TY_REAL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memr[O_VALP(out)+i-1] = tan (Memr[O_VALP(ap)+i-1]) + } else + O_VALR(out) = tan (O_VALR(ap)) + + if (optype == TY_DOUBLE) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memd[O_VALP(out)+i-1] = tan (Memd[O_VALP(ap)+i-1]) + } else + O_VALD(out) = tan (O_VALD(ap)) + + case F_TANH: + + if (optype == TY_REAL) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memr[O_VALP(out)+i-1] = tanh (Memr[O_VALP(ap)+i-1]) + } else + O_VALR(out) = tanh (O_VALR(ap)) + + if (optype == TY_DOUBLE) + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memd[O_VALP(out)+i-1] = tanh (Memd[O_VALP(ap)+i-1]) + } else + O_VALD(out) = tanh (O_VALD(ap)) + + + case F_LEN: + # Vector length. + O_VALI(out) = O_LEN(ap) + + case F_HIV: + # High value. + switch (optype) { + + case TY_SHORT: + if (O_LEN(ap) > 0) + O_VALS(out) = ahivs (Mems[O_VALP(ap)], O_LEN(ap)) + else + O_VALS(out) = O_VALS(ap) + + case TY_INT: + if (O_LEN(ap) > 0) + O_VALI(out) = ahivi (Memi[O_VALP(ap)], O_LEN(ap)) + else + O_VALI(out) = O_VALI(ap) + + case TY_LONG: + if (O_LEN(ap) > 0) + O_VALL(out) = ahivl (Meml[O_VALP(ap)], O_LEN(ap)) + else + O_VALL(out) = O_VALL(ap) + + case TY_REAL: + if (O_LEN(ap) > 0) + O_VALR(out) = ahivr (Memr[O_VALP(ap)], O_LEN(ap)) + else + O_VALR(out) = O_VALR(ap) + + case TY_DOUBLE: + if (O_LEN(ap) > 0) + O_VALD(out) = ahivd (Memd[O_VALP(ap)], O_LEN(ap)) + else + O_VALD(out) = O_VALD(ap) + + default: + call xvv_error1 (s_badtype, fcn) + } + case F_LOV: + # Low value. + switch (optype) { + + case TY_SHORT: + if (O_LEN(ap) > 0) + O_VALS(out) = alovs (Mems[O_VALP(ap)], O_LEN(ap)) + else + O_VALS(out) = O_VALS(ap) + + case TY_INT: + if (O_LEN(ap) > 0) + O_VALI(out) = alovi (Memi[O_VALP(ap)], O_LEN(ap)) + else + O_VALI(out) = O_VALI(ap) + + case TY_LONG: + if (O_LEN(ap) > 0) + O_VALL(out) = alovl (Meml[O_VALP(ap)], O_LEN(ap)) + else + O_VALL(out) = O_VALL(ap) + + case TY_REAL: + if (O_LEN(ap) > 0) + O_VALR(out) = alovr (Memr[O_VALP(ap)], O_LEN(ap)) + else + O_VALR(out) = O_VALR(ap) + + case TY_DOUBLE: + if (O_LEN(ap) > 0) + O_VALD(out) = alovd (Memd[O_VALP(ap)], O_LEN(ap)) + else + O_VALD(out) = O_VALD(ap) + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_SUM: + # Vector sum. + switch (optype) { + + case TY_SHORT: + if (O_LEN(ap) > 0) + v_r = asums (Mems[O_VALP(ap)], O_LEN(ap)) + else + v_r = O_VALS(ap) + + case TY_INT: + if (O_LEN(ap) > 0) + v_r = asumi (Memi[O_VALP(ap)], O_LEN(ap)) + else + v_r = O_VALI(ap) + + case TY_LONG: + if (O_LEN(ap) > 0) + v_r = asuml (Meml[O_VALP(ap)], O_LEN(ap)) + else + v_r = O_VALL(ap) + + case TY_REAL: + if (O_LEN(ap) > 0) + v_r = asumr (Memr[O_VALP(ap)], O_LEN(ap)) + else + v_r = O_VALR(ap) + + case TY_DOUBLE: + if (O_LEN(ap) > 0) + v_d = asumd (Memd[O_VALP(ap)], O_LEN(ap)) + else + v_d = O_VALD(ap) + default: + call xvv_error1 (s_badtype, fcn) + } + + if (optype == TY_DOUBLE) + O_VALD(out) = v_d + else + O_VALR(out) = v_r + + case F_MEAN, F_STDDEV: + # Compute the mean or standard deviation of a vector. An optional + # second argument may be supplied to compute a K-sigma rejection + # mean and sigma. + + if (nargs == 2) { + if (O_LEN(args[2]) > 0) + call xvv_error1 ("%s: ksigma arg must be a scalar" , fcn) + + switch (O_TYPE(args[2])) { + case TY_REAL: + v_r = O_VALR(args[2]) + v_d = v_r + case TY_DOUBLE: + v_d = O_VALD(args[2]) + v_r = v_d + default: + call xvv_chtype (args[2], args[2], TY_REAL) + v_r = O_VALR(args[2]) + v_d = v_r + } + } else { + v_r = 0.0 + v_d = 0.0 + } + + switch (optype) { + + case TY_SHORT: + v_i = aravs (Mems[O_VALP(ap)], O_LEN(ap), mean_r,sigma_r,v_r) + + case TY_INT: + v_i = aravi (Memi[O_VALP(ap)], O_LEN(ap), mean_r,sigma_r,v_r) + + case TY_REAL: + v_i = aravr (Memr[O_VALP(ap)], O_LEN(ap), mean_r,sigma_r,v_r) + + + case TY_LONG: + v_i = aravl (Meml[O_VALP(ap)], O_LEN(ap), mean_d,sigma_d,v_d) + + case TY_DOUBLE: + v_i = aravd (Memd[O_VALP(ap)], O_LEN(ap), mean_d,sigma_d,v_d) + + default: + call xvv_error1 (s_badtype, fcn) + } + + if (opcode == F_MEAN) { + if (O_TYPE(out) == TY_REAL) + O_VALR(out) = mean_r + else + O_VALD(out) = mean_d + } else { + if (O_TYPE(out) == TY_REAL) + O_VALR(out) = sigma_r + else + O_VALD(out) = sigma_d + } + + case F_MEDIAN: + # Compute the median value of a vector, or the vector median + # of 3 or more vectors. + + switch (nargs) { + case 1: + switch (optype) { + + case TY_SHORT: + O_VALS(out) = ameds (Mems[O_VALP(ap)], O_LEN(ap)) + + case TY_INT: + O_VALI(out) = amedi (Memi[O_VALP(ap)], O_LEN(ap)) + + case TY_LONG: + O_VALL(out) = amedl (Meml[O_VALP(ap)], O_LEN(ap)) + + case TY_REAL: + O_VALR(out) = amedr (Memr[O_VALP(ap)], O_LEN(ap)) + + case TY_DOUBLE: + O_VALD(out) = amedd (Memd[O_VALP(ap)], O_LEN(ap)) + + default: + call xvv_error1 (s_badtype, fcn) + } + case 3: + switch (optype) { + + case TY_SHORT: + call amed3s (Mems[O_VALP(args[1])], + Mems[O_VALP(args[2])], + Mems[O_VALP(args[3])], + Mems[O_VALP(out)], nelem) + + case TY_INT: + call amed3i (Memi[O_VALP(args[1])], + Memi[O_VALP(args[2])], + Memi[O_VALP(args[3])], + Memi[O_VALP(out)], nelem) + + case TY_LONG: + call amed3l (Meml[O_VALP(args[1])], + Meml[O_VALP(args[2])], + Meml[O_VALP(args[3])], + Meml[O_VALP(out)], nelem) + + case TY_REAL: + call amed3r (Memr[O_VALP(args[1])], + Memr[O_VALP(args[2])], + Memr[O_VALP(args[3])], + Memr[O_VALP(out)], nelem) + + case TY_DOUBLE: + call amed3d (Memd[O_VALP(args[1])], + Memd[O_VALP(args[2])], + Memd[O_VALP(args[3])], + Memd[O_VALP(out)], nelem) + + default: + call xvv_error1 (s_badtype, fcn) + } + case 4: + switch (optype) { + + case TY_SHORT: + call amed4s (Mems[O_VALP(args[1])], + Mems[O_VALP(args[2])], + Mems[O_VALP(args[3])], + Mems[O_VALP(args[4])], + Mems[O_VALP(out)], nelem) + + case TY_INT: + call amed4i (Memi[O_VALP(args[1])], + Memi[O_VALP(args[2])], + Memi[O_VALP(args[3])], + Memi[O_VALP(args[4])], + Memi[O_VALP(out)], nelem) + + case TY_LONG: + call amed4l (Meml[O_VALP(args[1])], + Meml[O_VALP(args[2])], + Meml[O_VALP(args[3])], + Meml[O_VALP(args[4])], + Meml[O_VALP(out)], nelem) + + case TY_REAL: + call amed4r (Memr[O_VALP(args[1])], + Memr[O_VALP(args[2])], + Memr[O_VALP(args[3])], + Memr[O_VALP(args[4])], + Memr[O_VALP(out)], nelem) + + case TY_DOUBLE: + call amed4d (Memd[O_VALP(args[1])], + Memd[O_VALP(args[2])], + Memd[O_VALP(args[3])], + Memd[O_VALP(args[4])], + Memd[O_VALP(out)], nelem) + + default: + call xvv_error1 (s_badtype, fcn) + } + case 5: + switch (optype) { + + case TY_SHORT: + call amed5s (Mems[O_VALP(args[1])], + Mems[O_VALP(args[2])], + Mems[O_VALP(args[3])], + Mems[O_VALP(args[4])], + Mems[O_VALP(args[5])], + Mems[O_VALP(out)], nelem) + + case TY_INT: + call amed5i (Memi[O_VALP(args[1])], + Memi[O_VALP(args[2])], + Memi[O_VALP(args[3])], + Memi[O_VALP(args[4])], + Memi[O_VALP(args[5])], + Memi[O_VALP(out)], nelem) + + case TY_LONG: + call amed5l (Meml[O_VALP(args[1])], + Meml[O_VALP(args[2])], + Meml[O_VALP(args[3])], + Meml[O_VALP(args[4])], + Meml[O_VALP(args[5])], + Meml[O_VALP(out)], nelem) + + case TY_REAL: + call amed5r (Memr[O_VALP(args[1])], + Memr[O_VALP(args[2])], + Memr[O_VALP(args[3])], + Memr[O_VALP(args[4])], + Memr[O_VALP(args[5])], + Memr[O_VALP(out)], nelem) + + case TY_DOUBLE: + call amed5d (Memd[O_VALP(args[1])], + Memd[O_VALP(args[2])], + Memd[O_VALP(args[3])], + Memd[O_VALP(args[4])], + Memd[O_VALP(args[5])], + Memd[O_VALP(out)], nelem) + + default: + call xvv_error1 (s_badtype, fcn) + } + default: + call xvv_error1 ("%s: wrong number of arguments", fcn) + } + + case F_REPL: + # Replicate an item to make a longer vector. + + chunk = O_LEN(ap) + optype = O_TYPE(ap) + if (optype == TY_BOOL) + optype = TY_INT + + if (O_LEN(args[2]) > 0) + call xvv_error1 ("%s: replication factor must be a scalar", fcn) + if (O_TYPE(args[2]) != TY_INT) + call xvv_chtype (args[2], args[2], TY_INT) + repl = max (1, O_VALI(args[2])) + + if (chunk <= 0) + nelem = repl + else + nelem = chunk * repl + call xvv_initop (out, nelem, optype) + + switch (optype) { + + case TY_SHORT: + if (chunk > 0) { + ip = O_VALP(ap) + op = O_VALP(out) + do i = 1, repl { + call amovs (Mems[ip], Mems[op], chunk) + op = op + chunk + } + } else + call amovks (O_VALS(ap), Mems[O_VALP(out)], nelem) + + case TY_INT: + if (chunk > 0) { + ip = O_VALP(ap) + op = O_VALP(out) + do i = 1, repl { + call amovi (Memi[ip], Memi[op], chunk) + op = op + chunk + } + } else + call amovki (O_VALI(ap), Memi[O_VALP(out)], nelem) + + case TY_LONG: + if (chunk > 0) { + ip = O_VALP(ap) + op = O_VALP(out) + do i = 1, repl { + call amovl (Meml[ip], Meml[op], chunk) + op = op + chunk + } + } else + call amovkl (O_VALL(ap), Meml[O_VALP(out)], nelem) + + case TY_REAL: + if (chunk > 0) { + ip = O_VALP(ap) + op = O_VALP(out) + do i = 1, repl { + call amovr (Memr[ip], Memr[op], chunk) + op = op + chunk + } + } else + call amovkr (O_VALR(ap), Memr[O_VALP(out)], nelem) + + case TY_DOUBLE: + if (chunk > 0) { + ip = O_VALP(ap) + op = O_VALP(out) + do i = 1, repl { + call amovd (Memd[ip], Memd[op], chunk) + op = op + chunk + } + } else + call amovkd (O_VALD(ap), Memd[O_VALP(out)], nelem) + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_SHIFT: + # Vector shift. + if (O_LEN(args[2]) > 0) + call xvv_error1 ("%s: shift arg must be a scalar" , fcn) + if (O_TYPE(args[2]) != TY_INT) + call xvv_chtype (args[2], args[2], TY_INT) + shift = O_VALI(args[2]) + + if (abs(shift) > nelem) { + if (shift > 0) + shift = nelem + else + shift = -nelem + } + + switch (optype) { + + case TY_SHORT: + if (nelem > 0) { + do i = 1, nelem { + j = i - shift + if (j < 1) + j = j + nelem + else if (j > nelem) + j = j - nelem + Mems[O_VALP(out)+i-1] = Mems[O_VALP(ap)+j-1] + } + } else + O_VALS(out) = (O_VALS(ap)) + + case TY_INT: + if (nelem > 0) { + do i = 1, nelem { + j = i - shift + if (j < 1) + j = j + nelem + else if (j > nelem) + j = j - nelem + Memi[O_VALP(out)+i-1] = Memi[O_VALP(ap)+j-1] + } + } else + O_VALI(out) = (O_VALI(ap)) + + case TY_LONG: + if (nelem > 0) { + do i = 1, nelem { + j = i - shift + if (j < 1) + j = j + nelem + else if (j > nelem) + j = j - nelem + Meml[O_VALP(out)+i-1] = Meml[O_VALP(ap)+j-1] + } + } else + O_VALL(out) = (O_VALL(ap)) + + case TY_REAL: + if (nelem > 0) { + do i = 1, nelem { + j = i - shift + if (j < 1) + j = j + nelem + else if (j > nelem) + j = j - nelem + Memr[O_VALP(out)+i-1] = Memr[O_VALP(ap)+j-1] + } + } else + O_VALR(out) = (O_VALR(ap)) + + case TY_DOUBLE: + if (nelem > 0) { + do i = 1, nelem { + j = i - shift + if (j < 1) + j = j + nelem + else if (j > nelem) + j = j - nelem + Memd[O_VALP(out)+i-1] = Memd[O_VALP(ap)+j-1] + } + } else + O_VALD(out) = (O_VALD(ap)) + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_SORT: + # Sort a vector. + switch (optype) { + + case TY_SHORT: + if (nelem > 0) + call asrts (Mems[O_VALP(ap)], Mems[O_VALP(out)], nelem) + else + O_VALS(out) = (O_VALS(ap)) + + case TY_INT: + if (nelem > 0) + call asrti (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) + else + O_VALI(out) = (O_VALI(ap)) + + case TY_LONG: + if (nelem > 0) + call asrtl (Meml[O_VALP(ap)], Meml[O_VALP(out)], nelem) + else + O_VALL(out) = (O_VALL(ap)) + + case TY_REAL: + if (nelem > 0) + call asrtr (Memr[O_VALP(ap)], Memr[O_VALP(out)], nelem) + else + O_VALR(out) = (O_VALR(ap)) + + case TY_DOUBLE: + if (nelem > 0) + call asrtd (Memd[O_VALP(ap)], Memd[O_VALP(out)], nelem) + else + O_VALD(out) = (O_VALD(ap)) + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_ATAN, F_ATAN2: + + if (optype == TY_REAL) { + if (nargs == 1) { + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memr[O_VALP(out)+i-1] = + atan (Memr[O_VALP(ap)+i-1]) + } else + O_VALR(out) = atan (O_VALR(ap)) + } else { + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memr[O_VALP(out)+i-1] = + atan2 (Memr[O_VALP(args[1])+i-1], + Memr[O_VALP(args[2])+i-1]) + } else + O_VALR(out) = atan2(O_VALR(args[1]), O_VALR(args[2])) + } + } + + if (optype == TY_DOUBLE) { + if (nargs == 1) { + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memd[O_VALP(out)+i-1] = + atan (Memd[O_VALP(ap)+i-1]) + } else + O_VALD(out) = atan (O_VALD(ap)) + } else { + if (O_LEN(ap) > 0) { + do i = 1, O_LEN(ap) + Memd[O_VALP(out)+i-1] = + atan2 (Memd[O_VALP(args[1])+i-1], + Memd[O_VALP(args[2])+i-1]) + } else + O_VALD(out) = atan2(O_VALD(args[1]), O_VALD(args[2])) + } + } + + + case F_MOD: + in1 = args[1] + in2 = args[2] + + switch (optype) { + + case TY_SHORT: + if (O_LEN(in1) <= 0) { + O_VALS(out) = mod (O_VALS(in1), O_VALS(in2)) + } else if (O_LEN(in2) <= 0) { + call amodks (Mems[O_VALP(in1)], O_VALS(in2), + Mems[O_VALP(out)], nelem) + } else { + call amods (Mems[O_VALP(in1)], Mems[O_VALP(in2)], + Mems[O_VALP(out)], nelem) + } + + case TY_INT: + if (O_LEN(in1) <= 0) { + O_VALI(out) = mod (O_VALI(in1), O_VALI(in2)) + } else if (O_LEN(in2) <= 0) { + call amodki (Memi[O_VALP(in1)], O_VALI(in2), + Memi[O_VALP(out)], nelem) + } else { + call amodi (Memi[O_VALP(in1)], Memi[O_VALP(in2)], + Memi[O_VALP(out)], nelem) + } + + case TY_LONG: + if (O_LEN(in1) <= 0) { + O_VALL(out) = mod (O_VALL(in1), O_VALL(in2)) + } else if (O_LEN(in2) <= 0) { + call amodkl (Meml[O_VALP(in1)], O_VALL(in2), + Meml[O_VALP(out)], nelem) + } else { + call amodl (Meml[O_VALP(in1)], Meml[O_VALP(in2)], + Meml[O_VALP(out)], nelem) + } + + case TY_REAL: + if (O_LEN(in1) <= 0) { + O_VALR(out) = mod (O_VALR(in1), O_VALR(in2)) + } else if (O_LEN(in2) <= 0) { + call amodkr (Memr[O_VALP(in1)], O_VALR(in2), + Memr[O_VALP(out)], nelem) + } else { + call amodr (Memr[O_VALP(in1)], Memr[O_VALP(in2)], + Memr[O_VALP(out)], nelem) + } + + case TY_DOUBLE: + if (O_LEN(in1) <= 0) { + O_VALD(out) = mod (O_VALD(in1), O_VALD(in2)) + } else if (O_LEN(in2) <= 0) { + call amodkd (Memd[O_VALP(in1)], O_VALD(in2), + Memd[O_VALP(out)], nelem) + } else { + call amodd (Memd[O_VALP(in1)], Memd[O_VALP(in2)], + Memd[O_VALP(out)], nelem) + } + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_MAX: + switch (optype) { + + case TY_SHORT: + # Copy the first argument. + ap = args[1] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) > 0) + call amovks (O_VALS(ap), Mems[O_VALP(out)], nelem) + else + O_VALS(out) = O_VALS(ap) + } else + call amovs (Mems[O_VALP(ap)], Mems[O_VALP(out)], nelem) + + # Process the second and remaining arguments. + do i = 2, nargs { + ap = args[i] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) <= 0) + O_VALS(out) = max (O_VALS(ap), O_VALS(out)) + else { + call amaxks (Mems[O_VALP(out)], O_VALS(ap), + Mems[O_VALP(out)], nelem) + } + } else { + call amaxs (Mems[O_VALP(out)], Mems[O_VALP(ap)], + Mems[O_VALP(out)], nelem) + } + } + + case TY_INT: + # Copy the first argument. + ap = args[1] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) > 0) + call amovki (O_VALI(ap), Memi[O_VALP(out)], nelem) + else + O_VALI(out) = O_VALI(ap) + } else + call amovi (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + # Process the second and remaining arguments. + do i = 2, nargs { + ap = args[i] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) <= 0) + O_VALI(out) = max (O_VALI(ap), O_VALI(out)) + else { + call amaxki (Memi[O_VALP(out)], O_VALI(ap), + Memi[O_VALP(out)], nelem) + } + } else { + call amaxi (Memi[O_VALP(out)], Memi[O_VALP(ap)], + Memi[O_VALP(out)], nelem) + } + } + + case TY_LONG: + # Copy the first argument. + ap = args[1] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) > 0) + call amovkl (O_VALL(ap), Meml[O_VALP(out)], nelem) + else + O_VALL(out) = O_VALL(ap) + } else + call amovl (Meml[O_VALP(ap)], Meml[O_VALP(out)], nelem) + + # Process the second and remaining arguments. + do i = 2, nargs { + ap = args[i] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) <= 0) + O_VALL(out) = max (O_VALL(ap), O_VALL(out)) + else { + call amaxkl (Meml[O_VALP(out)], O_VALL(ap), + Meml[O_VALP(out)], nelem) + } + } else { + call amaxl (Meml[O_VALP(out)], Meml[O_VALP(ap)], + Meml[O_VALP(out)], nelem) + } + } + + case TY_REAL: + # Copy the first argument. + ap = args[1] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) > 0) + call amovkr (O_VALR(ap), Memr[O_VALP(out)], nelem) + else + O_VALR(out) = O_VALR(ap) + } else + call amovr (Memr[O_VALP(ap)], Memr[O_VALP(out)], nelem) + + # Process the second and remaining arguments. + do i = 2, nargs { + ap = args[i] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) <= 0) + O_VALR(out) = max (O_VALR(ap), O_VALR(out)) + else { + call amaxkr (Memr[O_VALP(out)], O_VALR(ap), + Memr[O_VALP(out)], nelem) + } + } else { + call amaxr (Memr[O_VALP(out)], Memr[O_VALP(ap)], + Memr[O_VALP(out)], nelem) + } + } + + case TY_DOUBLE: + # Copy the first argument. + ap = args[1] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) > 0) + call amovkd (O_VALD(ap), Memd[O_VALP(out)], nelem) + else + O_VALD(out) = O_VALD(ap) + } else + call amovd (Memd[O_VALP(ap)], Memd[O_VALP(out)], nelem) + + # Process the second and remaining arguments. + do i = 2, nargs { + ap = args[i] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) <= 0) + O_VALD(out) = max (O_VALD(ap), O_VALD(out)) + else { + call amaxkd (Memd[O_VALP(out)], O_VALD(ap), + Memd[O_VALP(out)], nelem) + } + } else { + call amaxd (Memd[O_VALP(out)], Memd[O_VALP(ap)], + Memd[O_VALP(out)], nelem) + } + } + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_MIN: + switch (optype) { + + case TY_SHORT: + # Copy the first argument. + ap = args[1] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) > 0) + call amovks (O_VALS(ap), Mems[O_VALP(out)], nelem) + else + O_VALS(out) = O_VALS(ap) + } else + call amovs (Mems[O_VALP(ap)], Mems[O_VALP(out)], nelem) + + # Process the second and remaining arguments. + do i = 2, nargs { + ap = args[i] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) <= 0) + O_VALS(out) = min (O_VALS(ap), O_VALS(out)) + else { + call aminks (Mems[O_VALP(out)], O_VALS(ap), + Mems[O_VALP(out)], nelem) + } + } else { + call amins (Mems[O_VALP(out)], Mems[O_VALP(ap)], + Mems[O_VALP(out)], nelem) + } + } + + case TY_INT: + # Copy the first argument. + ap = args[1] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) > 0) + call amovki (O_VALI(ap), Memi[O_VALP(out)], nelem) + else + O_VALI(out) = O_VALI(ap) + } else + call amovi (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + # Process the second and remaining arguments. + do i = 2, nargs { + ap = args[i] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) <= 0) + O_VALI(out) = min (O_VALI(ap), O_VALI(out)) + else { + call aminki (Memi[O_VALP(out)], O_VALI(ap), + Memi[O_VALP(out)], nelem) + } + } else { + call amini (Memi[O_VALP(out)], Memi[O_VALP(ap)], + Memi[O_VALP(out)], nelem) + } + } + + case TY_LONG: + # Copy the first argument. + ap = args[1] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) > 0) + call amovkl (O_VALL(ap), Meml[O_VALP(out)], nelem) + else + O_VALL(out) = O_VALL(ap) + } else + call amovl (Meml[O_VALP(ap)], Meml[O_VALP(out)], nelem) + + # Process the second and remaining arguments. + do i = 2, nargs { + ap = args[i] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) <= 0) + O_VALL(out) = min (O_VALL(ap), O_VALL(out)) + else { + call aminkl (Meml[O_VALP(out)], O_VALL(ap), + Meml[O_VALP(out)], nelem) + } + } else { + call aminl (Meml[O_VALP(out)], Meml[O_VALP(ap)], + Meml[O_VALP(out)], nelem) + } + } + + case TY_REAL: + # Copy the first argument. + ap = args[1] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) > 0) + call amovkr (O_VALR(ap), Memr[O_VALP(out)], nelem) + else + O_VALR(out) = O_VALR(ap) + } else + call amovr (Memr[O_VALP(ap)], Memr[O_VALP(out)], nelem) + + # Process the second and remaining arguments. + do i = 2, nargs { + ap = args[i] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) <= 0) + O_VALR(out) = min (O_VALR(ap), O_VALR(out)) + else { + call aminkr (Memr[O_VALP(out)], O_VALR(ap), + Memr[O_VALP(out)], nelem) + } + } else { + call aminr (Memr[O_VALP(out)], Memr[O_VALP(ap)], + Memr[O_VALP(out)], nelem) + } + } + + case TY_DOUBLE: + # Copy the first argument. + ap = args[1] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) > 0) + call amovkd (O_VALD(ap), Memd[O_VALP(out)], nelem) + else + O_VALD(out) = O_VALD(ap) + } else + call amovd (Memd[O_VALP(ap)], Memd[O_VALP(out)], nelem) + + # Process the second and remaining arguments. + do i = 2, nargs { + ap = args[i] + if (O_LEN(ap) <= 0) { + if (O_LEN(out) <= 0) + O_VALD(out) = min (O_VALD(ap), O_VALD(out)) + else { + call aminkd (Memd[O_VALP(out)], O_VALD(ap), + Memd[O_VALP(out)], nelem) + } + } else { + call amind (Memd[O_VALP(out)], Memd[O_VALP(ap)], + Memd[O_VALP(out)], nelem) + } + } + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_BOOL: + nelem = 0 + if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR) + nelem = O_LEN(ap) + call xvv_initop (out, nelem, TY_BOOL) + + switch (O_TYPE(ap)) { + case TY_BOOL: + if (O_LEN(ap) <= 0) + O_VALI(out) = O_VALI(ap) + else + call amovi (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_CHAR: + ch = O_VALC(ap) + O_VALI(out) = btoi (ch == 'y' || ch == 'Y') + + + case TY_SHORT: + if (O_LEN(ap) <= 0) + O_VALI(out) = btoi (O_VALS(ap) != 0) + else { + v_s = 0 + call abneks (Mems[O_VALP(ap)], v_s, Memi[O_VALP(out)], + nelem) + } + + case TY_INT: + if (O_LEN(ap) <= 0) + O_VALI(out) = btoi (O_VALI(ap) != 0) + else { + v_i = 0 + call abneki (Memi[O_VALP(ap)], v_i, Memi[O_VALP(out)], + nelem) + } + + case TY_LONG: + if (O_LEN(ap) <= 0) + O_VALI(out) = btoi (O_VALL(ap) != 0) + else { + v_l = 0 + call abnekl (Meml[O_VALP(ap)], v_l, Memi[O_VALP(out)], + nelem) + } + + case TY_REAL: + if (O_LEN(ap) <= 0) + O_VALI(out) = btoi (O_VALR(ap) != 0.0) + else { + v_r = 0.0 + call abnekr (Memr[O_VALP(ap)], v_r, Memi[O_VALP(out)], + nelem) + } + + case TY_DOUBLE: + if (O_LEN(ap) <= 0) + O_VALI(out) = btoi (O_VALD(ap) != 0.0D0) + else { + v_d = 0.0D0 + call abnekd (Memd[O_VALP(ap)], v_d, Memi[O_VALP(out)], + nelem) + } + + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_SHORT: + nelem = 0 + if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR) + nelem = O_LEN(ap) + call xvv_initop (out, nelem, TY_SHORT) + + switch (O_TYPE(ap)) { + case TY_BOOL: + if (O_LEN(ap) <= 0) + O_VALS(out) = O_VALI(ap) + else + call achtis (Memi[O_VALP(ap)], Mems[O_VALP(out)], nelem) + + case TY_CHAR: + ip = O_VALP(ap) + if (gctod (Memc, ip, v_d) <= 0) + O_VALS(out) = 0 + else + O_VALS(out) = v_d + + + case TY_SHORT: + if (O_LEN(ap) <= 0) + O_VALS(out) = O_VALS(ap) + else + call achtss (Mems[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_INT: + if (O_LEN(ap) <= 0) + O_VALS(out) = O_VALI(ap) + else + call achtis (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_LONG: + if (O_LEN(ap) <= 0) + O_VALS(out) = O_VALL(ap) + else + call achtls (Meml[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_REAL: + if (O_LEN(ap) <= 0) + O_VALS(out) = O_VALR(ap) + else + call achtrs (Memr[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_DOUBLE: + if (O_LEN(ap) <= 0) + O_VALS(out) = O_VALD(ap) + else + call achtds (Memd[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_INT: + nelem = 0 + if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR) + nelem = O_LEN(ap) + call xvv_initop (out, nelem, TY_INT) + + switch (O_TYPE(ap)) { + case TY_BOOL: + if (O_LEN(ap) <= 0) + O_VALI(out) = O_VALI(ap) + else + call amovi (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_CHAR: + ip = O_VALP(ap) + if (gctod (Memc, ip, v_d) <= 0) + O_VALI(out) = 0 + else + O_VALI(out) = v_d + + + case TY_SHORT: + if (O_LEN(ap) <= 0) + O_VALI(out) = O_VALS(ap) + else + call achtsi (Mems[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_INT: + if (O_LEN(ap) <= 0) + O_VALI(out) = O_VALI(ap) + else + call achtii (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_LONG: + if (O_LEN(ap) <= 0) + O_VALI(out) = O_VALL(ap) + else + call achtli (Meml[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_REAL: + if (O_LEN(ap) <= 0) + O_VALI(out) = O_VALR(ap) + else + call achtri (Memr[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_DOUBLE: + if (O_LEN(ap) <= 0) + O_VALI(out) = O_VALD(ap) + else + call achtdi (Memd[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_LONG: + nelem = 0 + if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR) + nelem = O_LEN(ap) + call xvv_initop (out, nelem, TY_LONG) + + switch (O_TYPE(ap)) { + case TY_BOOL: + if (O_LEN(ap) <= 0) + O_VALL(out) = O_VALI(ap) + else + call amovi (Memi[O_VALP(ap)], Meml[O_VALP(out)], nelem) + + case TY_CHAR: + ip = O_VALP(ap) + if (gctod (Memc, ip, v_d) <= 0) + O_VALL(out) = 0 + else + O_VALL(out) = v_d + + + case TY_SHORT: + if (O_LEN(ap) <= 0) + O_VALL(out) = O_VALS(ap) + else + call achtsl (Mems[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_INT: + if (O_LEN(ap) <= 0) + O_VALL(out) = O_VALI(ap) + else + call achtil (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_LONG: + if (O_LEN(ap) <= 0) + O_VALL(out) = O_VALL(ap) + else + call achtll (Meml[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_REAL: + if (O_LEN(ap) <= 0) + O_VALL(out) = O_VALR(ap) + else + call achtrl (Memr[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_DOUBLE: + if (O_LEN(ap) <= 0) + O_VALL(out) = O_VALD(ap) + else + call achtdl (Memd[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_NINT: + nelem = 0 + if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR) + nelem = O_LEN(ap) + call xvv_initop (out, nelem, TY_INT) + + switch (O_TYPE(ap)) { + case TY_BOOL: + if (O_LEN(ap) <= 0) + O_VALI(out) = O_VALI(ap) + else + call amovi (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_CHAR: + ip = O_VALP(ap) + if (gctod (Memc, ip, v_d) <= 0) + O_VALI(out) = 0 + else + O_VALI(out) = nint (v_d) + + + case TY_SHORT: + if (O_LEN(ap) <= 0) + O_VALI(out) = O_VALS(ap) + else + call achtsi (Mems[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_INT: + if (O_LEN(ap) <= 0) + O_VALI(out) = O_VALI(ap) + else + call achtii (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + case TY_LONG: + if (O_LEN(ap) <= 0) + O_VALI(out) = O_VALL(ap) + else + call achtli (Meml[O_VALP(ap)], Memi[O_VALP(out)], nelem) + + + + case TY_REAL: + if (O_LEN(ap) <= 0) + O_VALI(out) = nint (O_VALR(ap)) + else { + do i = 1, nelem + Memi[O_VALP(out)+i-1] = nint (Memr[O_VALP(ap)+i-1]) + } + + case TY_DOUBLE: + if (O_LEN(ap) <= 0) + O_VALI(out) = nint (O_VALD(ap)) + else { + do i = 1, nelem + Memi[O_VALP(out)+i-1] = nint (Memd[O_VALP(ap)+i-1]) + } + + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_REAL: + nelem = 0 + if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR) + nelem = O_LEN(ap) + call xvv_initop (out, nelem, TY_REAL) + + switch (O_TYPE(ap)) { + case TY_BOOL: + if (O_LEN(ap) <= 0) + O_VALR(out) = O_VALI(ap) + else + call achtir (Memi[O_VALP(ap)], Memr[O_VALP(out)], nelem) + + case TY_CHAR: + ip = O_VALP(ap) + if (gctod (Memc, ip, v_d) <= 0) + O_VALR(out) = 0 + else + O_VALR(out) = v_d + + + case TY_SHORT: + if (O_LEN(ap) <= 0) + O_VALR(out) = O_VALS(ap) + else + call achtsr (Mems[O_VALP(ap)], Memr[O_VALP(out)], nelem) + + case TY_INT: + if (O_LEN(ap) <= 0) + O_VALR(out) = O_VALI(ap) + else + call achtir (Memi[O_VALP(ap)], Memr[O_VALP(out)], nelem) + + case TY_LONG: + if (O_LEN(ap) <= 0) + O_VALR(out) = O_VALL(ap) + else + call achtlr (Meml[O_VALP(ap)], Memr[O_VALP(out)], nelem) + + case TY_REAL: + if (O_LEN(ap) <= 0) + O_VALR(out) = O_VALR(ap) + else + call achtrr (Memr[O_VALP(ap)], Memr[O_VALP(out)], nelem) + + case TY_DOUBLE: + if (O_LEN(ap) <= 0) + O_VALR(out) = O_VALD(ap) + else + call achtdr (Memd[O_VALP(ap)], Memr[O_VALP(out)], nelem) + + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_DOUBLE: + nelem = 0 + if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR) + nelem = O_LEN(ap) + call xvv_initop (out, nelem, TY_DOUBLE) + + switch (O_TYPE(ap)) { + case TY_BOOL: + if (O_LEN(ap) <= 0) + O_VALD(out) = O_VALI(ap) + else + call achtid (Memi[O_VALP(ap)], Memd[O_VALP(out)], nelem) + + case TY_CHAR: + ip = O_VALP(ap) + if (gctod (Memc, ip, v_d) <= 0) + O_VALD(out) = 0 + else + O_VALD(out) = v_d + + + case TY_SHORT: + if (O_LEN(ap) <= 0) + O_VALD(out) = O_VALS(ap) + else + call achtsd (Mems[O_VALP(ap)], Memd[O_VALP(out)], nelem) + + case TY_INT: + if (O_LEN(ap) <= 0) + O_VALD(out) = O_VALI(ap) + else + call achtid (Memi[O_VALP(ap)], Memd[O_VALP(out)], nelem) + + case TY_LONG: + if (O_LEN(ap) <= 0) + O_VALD(out) = O_VALL(ap) + else + call achtld (Meml[O_VALP(ap)], Memd[O_VALP(out)], nelem) + + case TY_REAL: + if (O_LEN(ap) <= 0) + O_VALD(out) = O_VALR(ap) + else + call achtrd (Memr[O_VALP(ap)], Memd[O_VALP(out)], nelem) + + case TY_DOUBLE: + if (O_LEN(ap) <= 0) + O_VALD(out) = O_VALD(ap) + else + call achtdd (Memd[O_VALP(ap)], Memd[O_VALP(out)], nelem) + + + default: + call xvv_error1 (s_badtype, fcn) + } + + case F_STR: + optype = TY_CHAR + if (O_TYPE(ap) == TY_CHAR) + nelem = strlen (O_VALC(ap)) + else + nelem = MAX_DIGITS + call xvv_initop (out, nelem, TY_CHAR) + + switch (O_TYPE(ap)) { + case TY_BOOL: + call sprintf (O_VALC(out), nelem, "%b") + call pargi (O_VALI(ap)) + case TY_CHAR: + call sprintf (O_VALC(out), nelem, "%s") + call pargstr (O_VALC(ap)) + + case TY_SHORT: + call sprintf (O_VALC(out), nelem, "%d") + call pargs (O_VALS(ap)) + + case TY_INT: + call sprintf (O_VALC(out), nelem, "%d") + call pargi (O_VALI(ap)) + + case TY_LONG: + call sprintf (O_VALC(out), nelem, "%d") + call pargl (O_VALL(ap)) + + + case TY_REAL: + call sprintf (O_VALC(out), nelem, "%g") + call pargr (O_VALR(ap)) + + case TY_DOUBLE: + call sprintf (O_VALC(out), nelem, "%g") + call pargd (O_VALD(ap)) + + default: + call xvv_error1 (s_badtype, fcn) + } + + default: + call xvv_error ("callfcn: unknown function type") + } + +free_ + # Free any storage used by the argument list operands. + do i = 1, nargs + call xvv_freeop (args[i]) + + call sfree (sp) +end + + +# XVV_STARTARGLIST -- Allocate an argument list descriptor to receive +# arguments as a function call is parsed. We are called with either +# zero or one arguments. The argument list descriptor is pointed to by +# a ficticious operand. The descriptor itself contains a count of the +# number of arguments, an array of pointers to the operand structures, +# as well as storage for the operand structures. The operands must be +# stored locally since the parser will discard its copy of the operand +# structure for each argument as the associated grammar rule is reduced. + +procedure xvv_startarglist (arg, out) + +pointer arg #I pointer to first argument, or NULL +pointer out #I output operand pointing to arg descriptor + +pointer ap +errchk xvv_initop + +begin + call xvv_initop (out, LEN_ARGSTRUCT, TY_STRUCT) + ap = O_VALP(out) + + if (arg == NULL) + A_NARGS(ap) = 0 + else { + A_NARGS(ap) = 1 + A_ARGP(ap,1) = A_OPS(ap) + YYMOVE (arg, A_OPS(ap)) + } +end + + +# XVV_ADDARG -- Add an argument to the argument list for a function call. + +procedure xvv_addarg (arg, arglist, out) + +pointer arg #I pointer to argument to be added +pointer arglist #I pointer to operand pointing to arglist +pointer out #I output operand pointing to arg descriptor + +pointer ap, o +int nargs + +begin + ap = O_VALP(arglist) + + nargs = A_NARGS(ap) + 1 + A_NARGS(ap) = nargs + if (nargs > MAX_ARGS) + call xvv_error ("too many function arguments") + + o = A_OPS(ap) + ((nargs - 1) * LEN_OPERAND) + A_ARGP(ap,nargs) = o + YYMOVE (arg, o) + + YYMOVE (arglist, out) +end + + +# XVV_ERROR1 -- Take an error action, formatting an error message with one +# format string plus one string argument. + +procedure xvv_error1 (fmt, arg) + +char fmt[ARB] #I printf format string +char arg[ARB] #I string argument + +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + call sprintf (Memc[buf], SZ_LINE, fmt) + call pargstr (arg) + + call xvv_error (Memc[buf]) + call sfree (sp) +end + + +# XVV_ERROR2 -- Take an error action, formatting an error message with one +# format string plus one string argument and one integer argument. + +procedure xvv_error2 (fmt, arg1, arg2) + +char fmt[ARB] #I printf format string +char arg1[ARB] #I string argument +int arg2 #I integer argument + +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + call sprintf (Memc[buf], SZ_LINE, fmt) + call pargstr (arg1) + call pargi (arg2) + + call xvv_error (Memc[buf]) + call sfree (sp) +end + + +# XVV_ERROR -- Take an error action, given an error message string as the +# sole argument. + +procedure xvv_error (errmsg) + +char errmsg[ARB] #I error message + +begin + call error (1, errmsg) +end + + +# XVV_CHTYPE -- Change the datatype of an operand. The input and output +# operands may be the same. + +procedure xvv_chtype (o1, o2, dtype) + +pointer o1 #I input operand +pointer o2 #I output operand +int dtype #I new datatype + +short v_s +int v_i +long v_l +real v_r +double v_d +pointer vp, ip, op +bool float, freeval +int old_type, nelem, ch + +pointer coerce() +int sizeof(), btoi(), gctod() +string s_badtype "chtype: invalid operand type" + +begin + old_type = O_TYPE(o1) + nelem = O_LEN(o1) + + # No type conversion needed? + if (old_type == dtype) { + if (o1 != o2) { + if (nelem <= 0) + YYMOVE (o1, o2) + else { + call xvv_initop (o2, nelem, old_type) + call amovc (O_VALC(o1), O_VALC(o2), nelem * sizeof(dtype)) + } + } + return + } + + if (nelem <= 0) { + # Scalar input operand. + + O_TYPE(o2) = dtype + O_LEN(o2) = 0 + float = false + + # Read the old value into a local variable of type long or double. + switch (old_type) { + case TY_BOOL: + v_l = O_VALI(o1) + case TY_CHAR: + v_l = 0 # null string? + + case TY_SHORT: + v_l = O_VALS(o1) + + case TY_INT: + v_l = O_VALI(o1) + + case TY_LONG: + v_l = O_VALL(o1) + + + case TY_REAL: + v_d = O_VALR(o1) + float = true + + case TY_DOUBLE: + v_d = O_VALD(o1) + float = true + + default: + call xvv_error (s_badtype) + } + + # Set the value of the output operand. + switch (dtype) { + case TY_BOOL: + if (float) + O_VALI(o2) = btoi (v_d != 0) + else + O_VALI(o2) = btoi (v_l != 0) + case TY_CHAR: + call xvv_initop (o2, MAX_DIGITS, TY_CHAR) + if (float) { + call sprintf (O_VALC(o2), MAX_DIGITS, "%g") + call pargd (v_d) + } else { + call sprintf (O_VALC(o2), MAX_DIGITS, "%d") + call pargl (v_l) + } + + case TY_SHORT: + if (float) + O_VALS(o2) = v_d + else + O_VALS(o2) = v_l + + case TY_INT: + if (float) + O_VALI(o2) = v_d + else + O_VALI(o2) = v_l + + case TY_LONG: + if (float) + O_VALL(o2) = v_d + else + O_VALL(o2) = v_l + + + case TY_REAL: + if (float) + O_VALR(o2) = v_d + else + O_VALR(o2) = v_l + + case TY_DOUBLE: + if (float) + O_VALD(o2) = v_d + else + O_VALD(o2) = v_l + + default: + call xvv_error (s_badtype) + } + + } else { + # Vector input operand. + + # Save a pointer to the input operand data vector, to avoid it + # getting clobbered if O1 and O2 are the same operand. + + vp = O_VALP(o1) + + # If we have a char string input operand the output numeric + # operand can only be a scalar. If we have a char string output + # operand nelem is the length of the string. + + if (old_type == TY_CHAR) + nelem = 0 + else if (dtype == TY_CHAR) + nelem = MAX_DIGITS + + # Initialize the output operand O2. The freeval flag is cleared + # cleared to keep the initop from freeing the input operand array, + # inherited when the input operand is copied (or when the input + # and output operands are the same). We free the old operand + # array manually below. + + if (o1 != o2) + YYMOVE (o1, o2) + freeval = (and (O_FLAGS(o1), O_FREEVAL) != 0) + O_FLAGS(o2) = and (O_FLAGS(o2), not(O_FREEVAL)) + call xvv_initop (o2, nelem, dtype) + + # Write output value. + switch (dtype) { + case TY_BOOL: + if (old_type == TY_CHAR) { + ch = Memc[vp] + O_VALI(o2) = btoi (ch == 'y' || ch == 'Y') + } else { + switch (old_type) { + + case TY_SHORT: + v_s = 0 + call abneks (Mems[vp], v_s, Memi[O_VALP(o2)], nelem) + + case TY_INT: + v_i = 0 + call abneki (Memi[vp], v_i, Memi[O_VALP(o2)], nelem) + + case TY_LONG: + v_l = 0 + call abnekl (Meml[vp], v_l, Memi[O_VALP(o2)], nelem) + + case TY_REAL: + v_r = 0.0 + call abnekr (Memr[vp], v_r, Memi[O_VALP(o2)], nelem) + + case TY_DOUBLE: + v_d = 0.0D0 + call abnekd (Memd[vp], v_d, Memi[O_VALP(o2)], nelem) + + default: + call xvv_error (s_badtype) + } + } + + case TY_CHAR: + call xvv_error (s_badtype) + + case TY_SHORT, TY_INT, TY_LONG, TY_REAL, TY_DOUBLE: + switch (old_type) { + case TY_BOOL: + op = coerce (O_VALP(o2), O_TYPE(o2), TY_CHAR) + call achti (Memi[vp], Memc[op], nelem, dtype) + case TY_CHAR: + ip = vp + if (gctod (Memc, ip, v_d) <= 0) + v_d = 0 + switch (dtype) { + + case TY_SHORT: + O_VALS(o2) = v_d + + case TY_INT: + O_VALI(o2) = v_d + + case TY_LONG: + O_VALL(o2) = v_d + + case TY_REAL: + O_VALR(o2) = v_d + + case TY_DOUBLE: + O_VALD(o2) = v_d + + } + + case TY_SHORT: + op = coerce (O_VALP(o2), O_TYPE(o2), TY_CHAR) + call achts (Mems[vp], Memc[op], nelem, dtype) + + case TY_INT: + op = coerce (O_VALP(o2), O_TYPE(o2), TY_CHAR) + call achti (Memi[vp], Memc[op], nelem, dtype) + + case TY_LONG: + op = coerce (O_VALP(o2), O_TYPE(o2), TY_CHAR) + call achtl (Meml[vp], Memc[op], nelem, dtype) + + case TY_REAL: + op = coerce (O_VALP(o2), O_TYPE(o2), TY_CHAR) + call achtr (Memr[vp], Memc[op], nelem, dtype) + + case TY_DOUBLE: + op = coerce (O_VALP(o2), O_TYPE(o2), TY_CHAR) + call achtd (Memd[vp], Memc[op], nelem, dtype) + + default: + call xvv_error (s_badtype) + } + default: + call xvv_error (s_badtype) + } + + # Free old operand value. + if (freeval) + call mfree (vp, old_type) + } +end + + +# XVV_INITOP -- Initialize an operand, providing storage for an operand value +# of the given size and type. + +procedure xvv_initop (o, o_len, o_type) + +pointer o #I pointer to operand structure +int o_len #I length of operand (zero if scalar) +int o_type #I datatype of operand + +begin + O_LEN(o) = 0 + call xvv_makeop (o, o_len, o_type) +end + + +# XVV_MAKEOP -- Set up the operand structure. If the operand structure has +# already been initialized and array storage allocated, free the old array. + +procedure xvv_makeop (o, o_len, o_type) + +pointer o #I pointer to operand structure +int o_len #I length of operand (zero if scalar) +int o_type #I datatype of operand + +errchk malloc + +begin + # Free old array storage if any. + if (O_TYPE(o) != 0 && O_LEN(o) > 0) + if (and (O_FLAGS(o), O_FREEVAL) != 0) { + if (O_TYPE(o) == TY_BOOL) + call mfree (O_VALP(o), TY_INT) + else + call mfree (O_VALP(o), O_TYPE(o)) + O_LEN(o) = 0 + } + + # Set new operand type. + O_TYPE(o) = o_type + + # Allocate array storage if nonscalar operand. + if (o_len > 0) { + if (o_type == TY_BOOL) + call malloc (O_VALP(o), o_len, TY_INT) + else + call malloc (O_VALP(o), o_len, o_type) + O_LEN(o) = o_len + } + + O_FLAGS(o) = O_FREEVAL +end + + +# XVV_FREEOP -- Reinitialize an operand structure, i.e., free any associated +# array storage and clear the operand datatype field, but do not free the +# operand structure itself (which may be only a segment of an array and not +# a separately allocated structure). + +procedure xvv_freeop (o) + +pointer o #I pointer to operand structure + +begin + # Free old array storage if any. + if (O_TYPE(o) != 0 && O_LEN(o) > 0) + if (and (O_FLAGS(o), O_FREEVAL) != 0) { + if (O_TYPE(o) == TY_BOOL) + call mfree (O_VALP(o), TY_INT) + else + call mfree (O_VALP(o), O_TYPE(o)) + O_LEN(o) = 0 + } + + # Either free operand struct or clear the operand type to mark + # operand invalid. + + if (and (O_FLAGS(o), O_FREEOP) != 0) + call mfree (o, TY_STRUCT) + else + O_TYPE(o) = 0 +end + + +# XVV_LOADSYMBOLS -- Load a list of symbol names into a symbol table. Each +# symbol is tagged with an integer code corresponding to its sequence number +# in the symbol list. + +pointer procedure xvv_loadsymbols (s) + +char s[ARB] #I symbol list "|sym1|sym2|...|" + +int delim, symnum, ip +pointer sp, symname, st, sym, op +pointer stopen(), stenter() + +begin + call smark (sp) + call salloc (symname, SZ_FNAME, TY_CHAR) + + st = stopen ("evvexpr", LEN_INDEX, LEN_STAB, LEN_SBUF) + delim = s[1] + symnum = 0 + + for (ip=2; s[ip] != EOS; ip=ip+1) { + op = symname + while (s[ip] != delim && s[ip] != EOS) { + Memc[op] = s[ip] + op = op + 1 + ip = ip + 1 + } + Memc[op] = EOS + symnum = symnum + 1 + + if (op > symname && IS_ALPHA(Memc[symname])) { + sym = stenter (st, Memc[symname], LEN_SYM) + SYM_CODE(sym) = symnum + } + } + + call sfree (sp) + return (st) +end + + +# XVV_NULL -- Return a null value to be used when a computation cannot be +# performed and range checking is enabled. Perhaps we should permit a user +# specified value here, however this doesn't really work in an expression +# evaluator since the value generated may be used in subsequent calculations +# and hence may change. If more careful treatment of out of range values +# is needed a conditional expression can be used in which case the value +# we return here is ignored (but still needed to avoid a hardware exception +# when computing a vector). + + +short procedure xvv_nulls (ignore) +short ignore #I ignored +begin + return (0) +end + +int procedure xvv_nulli (ignore) +int ignore #I ignored +begin + return (0) +end + +long procedure xvv_nulll (ignore) +long ignore #I ignored +begin + return (0) +end + +real procedure xvv_nullr (ignore) +real ignore #I ignored +begin + return (0.0) +end + +double procedure xvv_nulld (ignore) +double ignore #I ignored +begin + return (0.0D0) +end + diff --git a/sys/fmtio/fmt.com b/sys/fmtio/fmt.com new file mode 100644 index 00000000..3f6d2525 --- /dev/null +++ b/sys/fmtio/fmt.com @@ -0,0 +1,17 @@ +# Printf common block. + +int fd # output file +int ip # pointer to next char in format string +int width, decpl # field width, number of decimal places +int col # output column +int left_justify # left or right justify output in field +int radix # output radix +int fmt_state # current state of FPRFMT (gets a format) +int ofile_type # type of output file +int format_char # format type character (bcdefghmorstuxz#*) +char fill_char # filler char for rt. justification +char format[SZ_OBUF] # format string +char obuf[SZ_OBUF] # for formatting output + +common /fmtcom/ fd,ip,width,decpl,col,left_justify,radix,fmt_state, + ofile_type,format_char,fill_char,format,obuf diff --git a/sys/fmtio/fmterr.x b/sys/fmtio/fmterr.x new file mode 100644 index 00000000..7a341764 --- /dev/null +++ b/sys/fmtio/fmterr.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# FMT_ERR -- Print the format string on the standard error output, marking +# the position within the string to which the error refers. + +procedure fmt_err (preamble, format, index) + +char preamble[ARB], format[ARB] +int index, ip + +begin + call putline (STDERR, "(") + call putline (STDERR, preamble) + call putline (STDERR, "format = \"") + + for (ip=1; ip < index && format[ip] != EOS; ip=ip+1) + call putcc (STDERR, format[ip]) + + if (format[ip] != EOS) { # mark position of error + call putline (STDERR, "<>") + for (; format[ip] != EOS; ip=ip+1) + call putcc (STDERR, format[ip]) + } + call putline (STDERR, "\")\n") +end diff --git a/sys/fmtio/fmtinit.x b/sys/fmtio/fmtinit.x new file mode 100644 index 00000000..0d8ea547 --- /dev/null +++ b/sys/fmtio/fmtinit.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# FMT_INIT -- The following is called by SPRINTF and CLPRINTF to set a flag to +# close the mem file or finish the CL command, respectively, when +# the end of the format string is reached. This entry is also called +# by the iraf main at startup time to initialize the printf common. + +procedure fmt_init (ftype) + +int ftype +include "fmt.com" + +begin + if (ftype == FMT_INITIALIZE) { + ip = 1 + format[ip] = EOS + ofile_type = REGULAR_FILE # fpradv + fmt_state = FMT_START # fprfmt + } else + ofile_type = ftype +end diff --git a/sys/fmtio/fmtread.x b/sys/fmtio/fmtread.x new file mode 100644 index 00000000..e7506ab9 --- /dev/null +++ b/sys/fmtio/fmtread.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# FMT_READ -- Read and interpret a format specification. Called in +# circumstances where a NOT_DONE_YET return from FPRFMT is certain to +# indicate a missing PARGI type argument. If this happens, print warning +# message, and exhaust format string so that default formats will be used. + +procedure fmt_read() + +int fprfmt() +include "fmt.com" + +begin + while (fprfmt(0) != ALL_DONE) { # read format + call putline (STDERR, "Warning: Missing argument to printf\n") + call fmt_err ("", format, ip) + while (format[ip] != EOS) # discard rest of format + ip = ip + 1 + fmt_state = FMT_START # set defaults + } +end diff --git a/sys/fmtio/fmtsetcol.x b/sys/fmtio/fmtsetcol.x new file mode 100644 index 00000000..a8d06855 --- /dev/null +++ b/sys/fmtio/fmtsetcol.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# FMT_SETCOL -- Called when a control character is output, to keep track of +# the column index during output, for the "%nt" (tabulate) format. Columns +# are indexed from the start of the printf, rather than in absolute units on +# the output, unless a \r or \n is output during the print. + +procedure fmt_setcol (ch, col) + +char ch +int col + +begin + switch (ch) { + case '\t': # next tab stop + col = ((col + TABSTOP-1) / TABSTOP) * TABSTOP + 1 + case '\n', '\r', '\f': + col = 1 + case '\b': + col = col - 1 + default: + if (IS_PRINT (ch)) + col = col + 1 + } +end diff --git a/sys/fmtio/fmtstr.x b/sys/fmtio/fmtstr.x new file mode 100644 index 00000000..197ea2bd --- /dev/null +++ b/sys/fmtio/fmtstr.x @@ -0,0 +1,49 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# FMTSTR -- Place a string in a field of the given width, left or right +# justifying as indicated, and output to the named file. The length of +# the text string may exceed the field width, in which case there is no +# filling. + +procedure fmtstr (fd, str, col, fill_char, left_justify, maxch, width) + +int fd # output file +char str[ARB] # string to be output +int col # column: both input and output parameter +char fill_char # fill character, if right justify +int left_justify # YES or NO +int maxch # maximum string chars to output +int width # field width +int nchars, nfill, ip +int strlen() +errchk putc, putci + +begin + if (fd <= 0) + return + + if (width > 0) { + nchars = min (maxch, strlen(str)) + nfill = max (0, width - nchars) + } else { + nchars = maxch + nfill = 0 # free format + } + + if (left_justify == NO) # fill at left + for (col=col+nfill; nfill > 0; nfill=nfill-1) + call putc (fd, fill_char) + + for (ip=1; str[ip] != EOS && ip <= nchars; ip=ip+1) { # put string + call putc (fd, str[ip]) + if (IS_PRINT (str[ip])) + col = col + 1 + else + call fmt_setcol (str[ip], col) + } + + for (col=col+nfill; nfill > 0; nfill=nfill-1) # fill at right + call putci (fd, ' ') +end diff --git a/sys/fmtio/fpradv.x b/sys/fmtio/fpradv.x new file mode 100644 index 00000000..942c29aa --- /dev/null +++ b/sys/fmtio/fpradv.x @@ -0,0 +1,76 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# FPRADV -- Copy format chars to output until next "%w.dC" format sequence is +# encountered, or until EOS is encountered on format string. When EOS is +# encountered, return buffer containing format string, and if mem_flag is set, +# close the output file (a string) as well. If a format string contains no +# regular format sequences, and hence requires no PARG_ calls, we are all done. + +procedure fpradv() + +int i, junk, ival, ch +char cch +int ip_save +int ctoi(), cctoc() +include "fmt.com" +errchk putci + +begin + for (ch = format[ip]; ch != EOS; ch = format[ip]) { + cch = ch + if (ch == ESCAPE) { + junk = cctoc (format, ip, cch) + + } else if (ch == START_OF_FORMAT) { + if (format[ip+1] == START_OF_FORMAT) # '%%' --> '%' + ip = ip + 2 + + else if (IS_DIGIT (format[ip+1])) { # %Nw or %Nt + ip_save = ip # ip_save --> '%' + ip = ip + 1 + + junk = ctoi (format, ip, ival) + + switch (format[ip]) { + case FMT_WHITESPACE: # output blanks + do i = 1, ival + call putci (fd, BLANK) + col = col + ival + case FMT_TOCOLUMN: # advance to column + for (; col < ival; col=col+1) + call putci (fd, BLANK) + default: + ip = ip_save # regular format spec + return + } + + ip = ip + 1 # eat "t" or "w" + next + + } else + return # regular format spec + + } else + ip = ip + 1 + + call putc (fd, cch) # output ordinary chars + if (IS_PRINT (cch)) # keep track of column + col = col + 1 + else + call fmt_setcol (cch, col) + } + + switch (ofile_type) { # EOS of format reached + case STRING_FILE: + call close (fd) + case CL_PARAM: + call putline (CLOUT, "\"\n") + } + + ofile_type = REGULAR_FILE # restore default + fd = NULL +end diff --git a/sys/fmtio/fprfmt.x b/sys/fmtio/fprfmt.x new file mode 100644 index 00000000..d5e68fb6 --- /dev/null +++ b/sys/fmtio/fprfmt.x @@ -0,0 +1,180 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +.help +.nf _________________________________________________________________________ +Process a format descriptor, setting the variables "decpl", "fill_char", +"format_char", and "width" in the fmtio common. Called from PARG_ +to determine the format specification for printing a variable. + +Format: "%[w[.d]]C[n]", where W is the field width, D the number of decimal +places or precision, C the format type character, and N the radix numeral, +for format type FMT_RADIX only. A negative field width signifies left +justification. A leading zero in the W field sets the fill character to the +numeral zero (when right justifying). Default values will be supplied if +any of the fields are omitted. The minimum format is "%C". + +If any of the fields (wdCn) have the value GET_FIELD (= "*") the value of +the field will be taken from the next PARG_ call, rather than from the +format string. This makes it easy to vary the format specification at run +time. For example, "%10.*g" would print a number in G-floating format, +with a constant field width of 10, and with the number of digits of precision +being given by a PARGI call at execution time (followed by a PARG_ call to +pass the value to be printed). +.endhelp ____________________________________________________________________ + +# The following macro marks the position in the FPRFMT procedure (saves the +# code for the needed field), and returns the not done status to PARG_. +# A subsequent call to a PARG_ (with the value of the field we are waiting for +# as argument) causes FPRFMT to be reentered at the point where we left off. + +define (waitfor, if (ival_already_used) { fmt_state = $1; return (NOT_DONE_YET) } ; $1 ival_already_used = true) + +#define (waitfor, if (ival_already_used) { +# fmt_state = $1 +# return (NOT_DONE_YET) +# } +# $1 ival_already_used = true) + +# FPRFMT -- Process a %W.Dn format specification. ALL_DONE is returned when +# the format specification has been fully processed, else NOT_DONE_YET is +# returned, indicating that an additional PARG call is required to complete +# the format (which therefore contained one or more "*" specifiers). + +int procedure fprfmt (ival) + +int ival # argument value (from parg_) +bool ival_already_used # wait for next parg +int ctoi(), stridx() +char ch, chrlwr() +include "fmt.com" + +begin + # This routine functions as a coroutine. If one of the fields in + # the format spec is to be given in a pargi call, an early return + # is taken. The routine is later reentered with the value of the + # needed field, and execution continues at the point it left off. + # (Sorry, I could not think of a simpler way to do it...) + + switch (fmt_state) { # return from "waitfor" + case FMT_START: # initial state + ival_already_used = false + case GET_WIDTH_1: # "%*.dC" + goto GET_WIDTH_1 + case GET_WIDTH_2: # "%-0*.dC" + goto GET_WIDTH_2 + case GET_DECPL: # "%w.*C" + goto GET_DECPL + case GET_FMTCHAR: # "%w.d*" + goto GET_FMTCHAR + case GET_RADIX: # "%w.dr*" + goto GET_RADIX + case GET_OPERAND: # used ival for format + goto GET_OPERAND + } + + # It is not an error if there is no format string. + if (format[ip] == EOS || format[ip] != START_OF_FORMAT) { + width = USE_DEFAULT + decpl = USE_DEFAULT + format_char = USE_DEFAULT + fill_char = ' ' + left_justify = NO + fmt_state = FMT_START + return (ALL_DONE) + } else + ip = ip + 1 # eat the "%" + + if (format[ip] == GET_FIELD) { # "%*.dC" + ip = ip + 1 + waitfor (GET_WIDTH_1) # go get field width... + if (ival < 0) # ...and come back here + left_justify = YES + else + left_justify = NO + + fill_char = ' ' + width = abs (ival) + + } else { # "%-0*.dC" + if (format[ip] == '-') { # left or right justify + left_justify = YES + ip = ip + 1 + } else + left_justify = NO + + fill_char = ' ' # zero or blank fill + if (format[ip] == '0') { + if (IS_DIGIT (format[ip+1]) || format[ip+1] == GET_FIELD) { + fill_char = '0' + ip = ip + 1 + } else + fill_char = ' ' + } + + if (format[ip] == GET_FIELD) { + ip = ip + 1 + waitfor (GET_WIDTH_2) # go get field width... + if (ival < 0) # ... and come back here + left_justify = YES + else + left_justify = NO + width = abs (ival) + + } else if (ctoi (format, ip, width) <= 0) # "%N.dC" + width = USE_DEFAULT + } + + if (width == 0) # make as big as needed + width = USE_DEFAULT + + if (format[ip] == '.') { # get decpl field + ip = ip + 1 + if (format[ip] == GET_FIELD) { # "%w.*C" + ip = ip + 1 + waitfor (GET_DECPL) + decpl = ival + } else if (ctoi (format, ip, decpl) <= 0) # "%w.NC" + decpl = USE_DEFAULT + } else + decpl = USE_DEFAULT + + if (format[ip] == GET_FIELD) { # "%w.d*" + ip = ip + 1 + waitfor (GET_FMTCHAR) + format_char = ival + } else { + format_char = format[ip] # "%w.dC" + ip = ip + 1 + } + + ch = format_char + if (stridx (ch, "bcdefghHmMorstuwxz") <= 0) { + call putline (STDERR, "Warning: Unknown format type char\n") + call fmt_err ("", format, ip-1) + format_char = USE_DEFAULT + + } else if (format_char == FMT_RADIX) { # get radix + ch = chrlwr (format[ip]) + ip = ip + 1 + if (ch == GET_FIELD) { # "%w.dr*" + waitfor (GET_RADIX) + radix = ival + } else if (IS_DIGIT (ch)) { + radix = TO_INTEG (ch) + } else if (IS_LOWER (ch)) { + radix = ch - 'a' + 10 + } else { + radix = DECIMAL + ip = ip - 1 + } + + } else if (format_char == FMT_WHITESPACE || format_char == FMT_TOCOLUMN) + ival_already_used = false # no operand + + waitfor (GET_OPERAND) # used ival for format, + fmt_state = FMT_START # need to get another + return (ALL_DONE) +end diff --git a/sys/fmtio/fprintf.x b/sys/fmtio/fprintf.x new file mode 100644 index 00000000..dd5304d2 --- /dev/null +++ b/sys/fmtio/fprintf.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# FPRINTF -- Format output to a file. + +procedure fprintf (fd, format_string) + +int fd +char format_string[ARB] + +begin + call fprntf (fd, format_string, REGULAR_FILE) +end diff --git a/sys/fmtio/fprntf.x b/sys/fmtio/fprntf.x new file mode 100644 index 00000000..095b57b2 --- /dev/null +++ b/sys/fmtio/fprntf.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# FPRNTF -- Initiate a formatted print. Called by FPRINTF, SPRINTF, etc. +# Check that the previous print has completed, initialize the current +# print, and advance to the first format specification (if any). + +procedure fprntf (new_fd, format_string, file_type) + +int new_fd, file_type +char format_string[ARB] +include "fmt.com" + +begin + # Printf is not reentrant. An expression in a PARG_ call must not + # directly or indirectly call any of the printf entry points. There + # must be a PARG_ for each "%w.dC" format specification in the format + # string. Errors result in lost output, but are otherwise harmless, + # and are diagnosed below. + + if (format[ip] != EOS) { + call putline (STDERR, "Warning: Incomplete or reentrant printf\n") + call fmt_err ("Old ", format, ip) + call fmt_err ("New ", format_string, ARB) + + while (format[ip] != EOS) # discard rest of format string + ip = ip + 1 + call fpradv() # possibly close mem file + } + + fd = new_fd # normal initialization + ip = 1 + col = 1 + fmt_state = FMT_START # initialize FPRFMT state + ofile_type = file_type + + call strcpy (format_string, format, SZ_OBUF) + call fpradv() +end diff --git a/sys/fmtio/fscan.x b/sys/fmtio/fscan.x new file mode 100644 index 00000000..4a76c772 --- /dev/null +++ b/sys/fmtio/fscan.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# FSCAN -- Begin scanning a line from a file. + +int procedure fscan (fd) + +int fd +int getlline() +include "scan.com" +errchk getlline + +begin + if (getlline (fd, sc_scanbuf, SZ_SCANBUF) == EOF) + return (EOF) + else { + call reset_scan() + return (OK) + } +end + + +# SCAN -- Scan the standard input. + +int procedure scan() + +int fscan() + +begin + return (fscan (STDIN)) +end diff --git a/sys/fmtio/gargb.x b/sys/fmtio/gargb.x new file mode 100644 index 00000000..82d9e0cb --- /dev/null +++ b/sys/fmtio/gargb.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GARGB -- Interpret the next token in the input as a boolean quantity +# (token "y...." or "n...."). + +procedure gargb (bval) + +bool bval +include "scan.com" + +begin + if (sc_stopscan) + return + + while (IS_WHITE (sc_scanbuf[sc_ip])) + sc_ip = sc_ip + 1 + + switch (sc_scanbuf[sc_ip]) { + case 'Y','y': + bval = true + case 'N','n': + bval = false + default: + sc_stopscan = true + return + } + + while (IS_ALPHA(sc_scanbuf[sc_ip]) || sc_scanbuf[sc_ip] == '_') + sc_ip = sc_ip + 1 + sc_ntokens = sc_ntokens + 1 +end diff --git a/sys/fmtio/gargc.x b/sys/fmtio/gargc.x new file mode 100644 index 00000000..e6ce6996 --- /dev/null +++ b/sys/fmtio/gargc.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GARGC -- Interpret the next input token as a character constant. + +procedure gargc (cval) + +char cval +int cctoc() +include "scan.com" + +begin + if (sc_stopscan) + return + + if (cctoc (sc_scanbuf, sc_ip, cval) > 0) + sc_ntokens = sc_ntokens + 1 + else + sc_stopscan = true +end diff --git a/sys/fmtio/gargd.x b/sys/fmtio/gargd.x new file mode 100644 index 00000000..cb8c4561 --- /dev/null +++ b/sys/fmtio/gargd.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GARGD -- Interpret the next input token as a double precision floating +# number. + +procedure gargd (dval) + +double dval +int gctod() +include "scan.com" + +begin + if (sc_stopscan) + return + + if (gctod (sc_scanbuf, sc_ip, dval) > 0) + sc_ntokens = sc_ntokens + 1 + else + sc_stopscan = true +end diff --git a/sys/fmtio/gargi.x b/sys/fmtio/gargi.x new file mode 100644 index 00000000..5b53bba8 --- /dev/null +++ b/sys/fmtio/gargi.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GARGI -- Interpret the next input token as an integer quantity. + +procedure gargi (ival) + +int ival +double dval + +begin + call gargd (dval) + if (IS_INDEFD (dval)) + ival = INDEFI + else if (abs(dval) > MAX_INT) + ival = INDEFI + else + ival = dval +end diff --git a/sys/fmtio/gargl.x b/sys/fmtio/gargl.x new file mode 100644 index 00000000..142ac0e1 --- /dev/null +++ b/sys/fmtio/gargl.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GARGL -- Interpret the next input token as an integer quantity. + +procedure gargl (lval) + +long lval +double dval + +begin + call gargd (dval) + if (IS_INDEFD (dval)) + lval = INDEFL + else if (abs(dval) > MAX_LONG) + lval = INDEFL + else + lval = dval +end diff --git a/sys/fmtio/gargr.x b/sys/fmtio/gargr.x new file mode 100644 index 00000000..4f25d717 --- /dev/null +++ b/sys/fmtio/gargr.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GARGR -- Interpret the next input token as a single precision floating +# quantity. + +procedure gargr (rval) + +real rval +double dval + +begin + call gargd (dval) + if (IS_INDEFD (dval)) + rval = INDEFR + else + rval = dval +end diff --git a/sys/fmtio/gargrad.x b/sys/fmtio/gargrad.x new file mode 100644 index 00000000..8ff78bf8 --- /dev/null +++ b/sys/fmtio/gargrad.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GARGRAD -- Convert the next number using the radix given as the second +# argument. + +procedure gargrad (lval, radix) + +long lval +int radix, gctol() +include "scan.com" + +begin + if (sc_stopscan) + return + + if (gctol (sc_scanbuf, sc_ip, lval, radix) > 0) + sc_ntokens = sc_ntokens + 1 + else + sc_stopscan = true +end diff --git a/sys/fmtio/gargs.x b/sys/fmtio/gargs.x new file mode 100644 index 00000000..193a725f --- /dev/null +++ b/sys/fmtio/gargs.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GARGS -- Interpret the next input token as an integer quantity. + +procedure gargs (sval) + +short sval +double dval + +begin + call gargd (dval) + if (IS_INDEFD (dval)) + sval = INDEFS + else if (abs(dval) > MAX_SHORT) + sval = INDEFS + else + sval = dval +end diff --git a/sys/fmtio/gargstr.x b/sys/fmtio/gargstr.x new file mode 100644 index 00000000..9ae30462 --- /dev/null +++ b/sys/fmtio/gargstr.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GARGSTR -- Return the remainder of the scanned input line as a string. + +procedure gargstr (outstr, maxch) + +char outstr[ARB] +int maxch, op +include "scan.com" + +begin + if (sc_stopscan) + return + + for (op=1; op <= maxch && sc_scanbuf[sc_ip] != EOS; op=op+1) { + if (sc_scanbuf[sc_ip] == '\n') + break # don't keep newlines + outstr[op] = sc_scanbuf[sc_ip] + sc_ip = sc_ip + 1 + } + + outstr[op] = EOS + sc_ntokens = sc_ntokens + 1 # null strings are ok +end diff --git a/sys/fmtio/gargtok.x b/sys/fmtio/gargtok.x new file mode 100644 index 00000000..b775c7ea --- /dev/null +++ b/sys/fmtio/gargtok.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GARGTOK -- Return the next token from the scanned input line. + +procedure gargtok (token, outstr, maxch) + +int token +char outstr[ARB] +int maxch, ctotok() +include "scan.com" + +begin + if (sc_stopscan) + return + + sc_ntokens = sc_ntokens + 1 # Newline, EOS are legal tokens + token = ctotok (sc_scanbuf, sc_ip, outstr, maxch) +end diff --git a/sys/fmtio/gargwrd.x b/sys/fmtio/gargwrd.x new file mode 100644 index 00000000..cc8aa695 --- /dev/null +++ b/sys/fmtio/gargwrd.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GARGWRD -- Return the next whitespace delimited token or quoted string from +# the scan buffer. + +procedure gargwrd (outstr, maxch) + +char outstr[ARB] +int maxch, ctowrd() +include "scan.com" + +begin + if (sc_stopscan) { + outstr[1] = EOS + return + } + + if (ctowrd (sc_scanbuf, sc_ip, outstr, maxch) > 0) + sc_ntokens = sc_ntokens + 1 + else + sc_stopscan = true +end diff --git a/sys/fmtio/gargx.x b/sys/fmtio/gargx.x new file mode 100644 index 00000000..2a1be607 --- /dev/null +++ b/sys/fmtio/gargx.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GARGX -- Interpret the next input token as a complex number. + +procedure gargx (xval) + +complex xval +int gctox() +include "scan.com" + +begin + if (sc_stopscan) + return + + if (gctox (sc_scanbuf, sc_ip, xval) > 0) + sc_ntokens = sc_ntokens + 1 + else + sc_stopscan = true +end diff --git a/sys/fmtio/gctod.x b/sys/fmtio/gctod.x new file mode 100644 index 00000000..ff58555b --- /dev/null +++ b/sys/fmtio/gctod.x @@ -0,0 +1,81 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +define OCTAL 8 +define DECIMAL 10 +define HEX 16 + + +# GCTOD -- General character string to double precision real. Any legal +# number, e.g., integer, floating point, complex, or character constant, +# is decoded and returned as a double. + +int procedure gctod (str, ip, odval) + +char str[ARB] # input string +int ip # pointer into input string +double odval # output double + +char ch +double dval +complex xval +long lval +int ip_save, radix, nchars, vtype +int ctox(), cctoc(), ctod(), gctol(), lexnum() + +begin + vtype = TY_DOUBLE # val to be returned + while (IS_WHITE (str[ip])) + ip = ip + 1 + + ip_save = ip + ch = str[ip] # first nonwhite + + if (ch == '(') { # complex number? + if (ctox (str, ip, xval) <= 0) + return (0) # not a number + else + vtype = TY_COMPLEX + + } else if (ch == SQUOTE || ch == ESCAPE) { + if (cctoc (str, ip, ch) <= 0) # character constant? + return (0) + else + dval = ch + + } else { # determine type of number + switch (lexnum (str, ip, nchars)) { + case LEX_OCTAL: + radix = OCTAL + case LEX_DECIMAL: + radix = DECIMAL + case LEX_HEX: + radix = HEX + case LEX_REAL: + radix = TY_REAL + default: + return (0) + } + + if (radix == TY_REAL) # perform the conversion + nchars = ctod (str, ip, dval) + else { + nchars = gctol (str, ip, lval, radix) + dval = lval + if (IS_INDEFL (lval)) + dval = INDEFD + } + } + + if (vtype == TY_COMPLEX) { + odval = xval + if (IS_INDEFX (xval)) + odval = INDEFD + } else + odval = dval + + return (ip - ip_save) +end diff --git a/sys/fmtio/gctol.x b/sys/fmtio/gctol.x new file mode 100644 index 00000000..f1478ff0 --- /dev/null +++ b/sys/fmtio/gctol.x @@ -0,0 +1,78 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +define OCTAL 8 +define DECIMAL 10 +define HEX 16 + +.help gctol +.nf _______________________________________________________________________ +GCTOL -- Convert string to long integer (any radix). The long integer +value is returned in LVAL, and the pointer IP is left pointing at the +first character following the number. IP must be set to the index of +the character at which conversion is to start before calling GCTOL. + +If the conversion radix is octal (hex), and the number is immediately +followed by the suffix "b|B" ("x|X"), IP will be advanced past the suffix +character, which is considered to be part of the number. +.endhelp __________________________________________________________________ + + +int procedure gctol (str, ip, lval, radix) + +char str[ARB] # string to be decoded +int ip # pointer within string +int radix # radix of number +long lval # output variable + +int digit, base, ip_save, first_char +char ch +bool neg + +begin + while (IS_WHITE (str[ip])) + ip = ip + 1 + ip_save = ip + + neg = (str[ip] == '-') + if (neg || str[ip] == '+') # eat the +/- + ip = ip + 1 + + first_char = ip + base = abs (radix) + + # The first character (following than the sign character) must be + # a digit, regardless of the radix. + + for (lval=0; str[ip] != EOS; ip=ip+1) { + ch = str[ip] + + if (IS_DIGIT (ch)) # cvt char to binary + digit = TO_INTEG (ch) + else if (base > DECIMAL) { + if (IS_UPPER (ch)) + ch = TO_LOWER (ch) + else if (! IS_LOWER (ch)) + break + digit = ch - 'a' + 10 # for radices > 10 + } else + break + + if (digit < 0 || digit >= base) + break + lval = lval * base + digit + } + + if (neg) + lval = -lval + + if (ip == first_char) # not a number ? + ip = ip_save # restore pointer + else if (radix == OCTAL && ch == 'b' || ch == 'B') + ip = ip + 1 + else if (radix == HEX && ch == 'x' || ch == 'X') + ip = ip + 1 # eat suffix char + + return (ip - first_char) +end diff --git a/sys/fmtio/gctox.x b/sys/fmtio/gctox.x new file mode 100644 index 00000000..2a23a917 --- /dev/null +++ b/sys/fmtio/gctox.x @@ -0,0 +1,81 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +define OCTAL 8 +define DECIMAL 10 +define HEX 16 + + +# GCTOX -- General character string to complex. Any legal number, e.g., +# integer, floating point, complex, or character constant, is decoded and +# returned as a complex. + +int procedure gctox (str, ip, oxval) + +char str[ARB] # input string +int ip # pointer into input string +complex oxval # output complex + +char ch +double dval +complex xval +long lval +int ip_save, radix, nchars, vtype +int ctox(), cctoc(), ctod(), gctol(), lexnum() + +begin + vtype = TY_DOUBLE # val to be returned + while (IS_WHITE (str[ip])) + ip = ip + 1 + + ip_save = ip + ch = str[ip] # first nonwhite + + if (ch == '(') { # complex number? + if (ctox (str, ip, xval) <= 0) + return (0) # not a number + else + vtype = TY_COMPLEX + + } else if (ch == SQUOTE || ch == ESCAPE) { + if (cctoc (str, ip, ch) <= 0) # character constant? + return (0) + else + dval = ch + + } else { # determine type of number + switch (lexnum (str, ip, nchars)) { + case LEX_OCTAL: + radix = OCTAL + case LEX_DECIMAL: + radix = DECIMAL + case LEX_HEX: + radix = HEX + case LEX_REAL: + radix = TY_REAL + default: + return (0) + } + + if (radix == TY_REAL) # perform the conversion + nchars = ctod (str, ip, dval) + else { + nchars = gctol (str, ip, lval, radix) + dval = lval + if (IS_INDEFL (lval)) + dval = INDEFD + } + } + + if (vtype == TY_DOUBLE) { + oxval = dval + if (IS_INDEFD (dval)) + oxval = INDEFX + } else + oxval = xval + + return (ip - ip_save) +end diff --git a/sys/fmtio/gltoc.x b/sys/fmtio/gltoc.x new file mode 100644 index 00000000..eaf47405 --- /dev/null +++ b/sys/fmtio/gltoc.x @@ -0,0 +1,82 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +define OCTAL 8 +define DECIMAL 10 +define HEX 16 +define MAX_RADIX 'Z' - 'A' + 11 + +# GLTOC -- Convert long integer to any radix string. Returns the +# number of characters generated. + +int procedure gltoc (lval, outstr, maxch, base) + +long lval # long integer to be encoded +char outstr[maxch] # output buffer +int maxch, base # numeric base (2..16) + +int carry, d, op, radix, n, size, nchars, gstrcpy() +long andl(), orl() +bool unsigned + +begin + if (IS_INDEFL(lval) && base > 0) + return (gstrcpy ("INDEF", outstr, maxch)) + size = maxch + + # Digit string is generated backwards, then reversed. Unsigned + # conversion used if radix negative. + + radix = max(2, min(MAX_RADIX, abs(base))) + + unsigned = (base < 0) # get raw number + if (unsigned) { + n = andl (lval, MAX_LONG) / 2 + if (lval < 0) + n = orl (n, (MAX_LONG / 2 + 1)) + carry = andl (lval, 1) # get initial carry + } else + n = lval + + op = 0 + repeat { + d = abs (mod (n, radix)) # generate next digit + if (unsigned) { + d = 2 * d + carry # get actual digit value + if (d >= radix) { # check for generated carry + d = d - radix + carry = 1 + } else + carry = 0 + } + op = op + 1 + if (d < 10) # convert to char and store + outstr[op] = TO_DIGIT (d) + else + outstr[op] = d - 10 + 'A' + n = n / radix + } until (n == 0 || op >= size) + + if (unsigned) { + if (carry != 0 && op < size) { # check for final carry + op = op + 1 + outstr[op] = '1' + } + } else if (lval < 0 && op < size) { # add sign if needed + op = op + 1 + outstr[op] = '-' + } + nchars = op # return length of string + + for (d=1; d < op; d=d+1) { # reverse digits + carry = outstr[d] + outstr[d] = outstr[op] + outstr[op] = carry + op = op - 1 + } + + outstr[nchars+1] = EOS + return (nchars) +end diff --git a/sys/fmtio/gstrcat.x b/sys/fmtio/gstrcat.x new file mode 100644 index 00000000..d3f3fa94 --- /dev/null +++ b/sys/fmtio/gstrcat.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GSTRCAT -- String concatenation. String STR is appended to OUTSTR. + +int procedure gstrcat (str, outstr, maxch) + +char str[ARB], outstr[ARB] +int maxch + +int ip, op, n + +begin + do op = 0, maxch-1 + if (outstr[op+1] == EOS) + break + + n = maxch - op + do ip = 1, n { + outstr[op+ip] = str[ip] + if (str[ip] == EOS) + return (op + ip-1) + } + + outstr[maxch+1] = EOS + return (maxch) +end diff --git a/sys/fmtio/gstrcpy.x b/sys/fmtio/gstrcpy.x new file mode 100644 index 00000000..e2d6e7b1 --- /dev/null +++ b/sys/fmtio/gstrcpy.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GSTRCPY -- Copy string s1 to s2, return the number of characters copied. + +int procedure gstrcpy (s1, s2, maxch) + +char s1[ARB], s2[ARB] +int maxch, i + +begin + do i = 1, maxch { + s2[i] = s1[i] + if (s2[i] == EOS) + return (i - 1) + } + + s2[maxch+1] = EOS + return (maxch) +end diff --git a/sys/fmtio/itoc.x b/sys/fmtio/itoc.x new file mode 100644 index 00000000..726fbc40 --- /dev/null +++ b/sys/fmtio/itoc.x @@ -0,0 +1,53 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# ITOC -- Integer to character string. We do not resolve this into a call +# to GLTOC for reasons of efficiency. + +int procedure itoc (ival, str, maxch) + +int ival, maxch +char str[ARB] + +char buf[MAX_DIGITS] +int b_op, s_op, num, temp +int gstrcpy() + +begin + s_op = 1 + + if (IS_INDEFI (ival)) { + return (gstrcpy ("INDEF", str, maxch)) + } else if (ival < 0) { + str[1] = '-' + s_op = 2 + num = -ival + } else + num = ival + + # Encode nonnegative number in BUF, least significant digits first. + + b_op = 0 + repeat { + temp = num / 10 + b_op = b_op + 1 + buf[b_op] = TO_DIGIT (num - temp * 10) + num = temp + } until (num == 0) + + # Copy encoded number to output string, reversing the order of the + # digits so that the most significant digits are first. + + while (b_op > 0) { + if (s_op > maxch) + return (gstrcpy ("**********", str, maxch)) + str[s_op] = buf[b_op] + s_op = s_op + 1 + b_op = b_op - 1 + } + + str[s_op] = EOS + return (s_op - 1) +end diff --git a/sys/fmtio/lexdata.inc b/sys/fmtio/lexdata.inc new file mode 100644 index 00000000..1a1bf3e4 --- /dev/null +++ b/sys/fmtio/lexdata.inc @@ -0,0 +1,28 @@ +# Actions of the LEXNUM finite state automaton. + +define Acc ACCEPT # special actions +define Rvt REVERT + +define o_o LEX_OCTAL # reductions +define d_d LEX_DECIMAL +define x_x LEX_HEX +define r_r LEX_REAL +define n__ LEX_NONNUM # (other actions are new states) + +# cc: +- 0-7 8-9 ACF ED : . X B other + +data action /UNM, ODH, DHR, n__, n__, QRN, QRF, n__, n__, n__, # start + Rvt, ODH, DHR, Rvt, Rvt, Rvt, QRF, Rvt, Rvt, Rvt, # UNM + d_d, Acc, DHR, HEX, QHX, QRN, RFR, x_x, OHN, d_d, # ODH + d_d, Acc, Acc, HEX, QHX, QRN, RFR, x_x, HEX, d_d, # DHR + Rvt, RFR, RFR, Rvt, Rvt, Rvt, Rvt, Rvt, Rvt, Rvt, # QRF + Rvt, Acc, Acc, Acc, Acc, Rvt, Rvt, x_x, Acc, Rvt, # HEX + QRX, HRX, HRX, HEX, HEX, Rvt, Rvt, x_x, HEX, Rvt, # QHX + Rvt, RNM, RNM, Rvt, Rvt, Acc, Rvt, Rvt, Rvt, Rvt, # QRN + o_o, HEX, HEX, HEX, HEX, o_o, o_o, x_x, HEX, o_o, # OHN + r_r, Acc, Acc, r_r, RRX, r_r, r_r, r_r, r_r, r_r, # RFR + QRX, REX, REX, Rvt, Rvt, Rvt, Rvt, Rvt, Rvt, Rvt, # RRX + Rvt, REX, REX, Rvt, Rvt, Rvt, Rvt, Rvt, Rvt, Rvt, # QRX + r_r, Acc, Acc, HEX, HEX, r_r, r_r, x_x, r_r, r_r, # HRX + r_r, Acc, Acc, r_r, QRX, Acc, QRF, r_r, r_r, r_r, # RNM + r_r, Acc, Acc, r_r, r_r, r_r, r_r, r_r, r_r, r_r/ # REX diff --git a/sys/fmtio/lexnum.x b/sys/fmtio/lexnum.x new file mode 100644 index 00000000..f62b0ed2 --- /dev/null +++ b/sys/fmtio/lexnum.x @@ -0,0 +1,190 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# LEXNUM -- Lexically analyse a character string, determine if string is +# a number, and if so, the type of number, and the number of characters +# in the number. The ip_start argument is left pointing at the first char +# of the number (or other token), and the number of chars in the number is +# returned as the third argument (0 if not a number). +# +# NOTE - See .doc/lexnum.hlp for a description of the states of the automaton. + +define SZ_STACK 15 + +# Lexical actions. "Reduce" means exit, returning code identifying lexical +# type of token. "Shift" means switch to a new state in the automaton. +# "Revert" means reduce class "other" in the previous state. + +define ACCEPT -6 # remain in same state +define REVERT -5 # revert to earlier state + + +# Character classes + +define SIGNCHAR 1 # +- +define OCTDIG 2 # 0-7 +define DECDIG 3 # 8-9 +define HEXDIG 4 # a-fA-F +define REALEXP 5 # eEdD +define SEXAG 6 # : +define FRACTION 7 # . +define HEXSUFFIX 8 # xX +define OCTSUFFIX 9 # bB +define OTHER 10 # invalid character +define NCC 10 + + +# States of the automaton + +define START 1 # initial state +define UNM 2 # unop or number +define ODH 3 # octal, decimal, hex, or real +define DHR 4 # decimal, hex, or real +define QRF 5 # maybe real fraction +define HEX 6 # hex +define QHX 7 # maybe hex or real exponent +define QRN 8 # maybe real number +define OHN 9 # octal or hex number +define RFR 10 # real fraction +define RRX 11 # real or real exponent +define QRX 12 # maybe real exponent +define HRX 13 # hex or real exponent +define RNM 14 # real number +define REX 15 # real exponent +define NSTATES 15 + + +# LEXNUM -- Determine if the next sequence of characters in the string STR +# can be interpreted as a number. Return the numeric type as the function +# value or LEX_NONNUM if the string is not a number. + +int procedure lexnum (str, ip_start, nchars) + +char str[ARB] # string to be decoded +int ip_start # starting index in string +int nchars # receives nchars in next token + +char ch +int stk_ip[SZ_STACK] +int ip, sp, cc, state, ip_save, toktype, act +short stk_state[SZ_STACK], action[NCC,NSTATES] +int strncmp() +include "lexdata.inc" + +begin + while (IS_WHITE (str[ip_start])) + ip_start = ip_start + 1 + ip = ip_start + + # INDEF is a legal number and is best dealt with as a special case. + if (str[ip] == 'I') + if (strncmp (str[ip], "INDEF", 5) == 0) { + nchars = 5 + return (LEX_REAL) + } + + state = START # initialization + ip_save = ip + sp = 0 + + repeat { + ch = str[ip] + + repeat { # determine character class + switch (ch) { + case '+','-': + cc = SIGNCHAR + break + case '0','1','2','3','4','5','6','7': + cc = OCTDIG + break + case '8','9': + cc = DECDIG + break + case 'B': + cc = OCTSUFFIX + break + case 'D','E': + cc = REALEXP + break + case 'A','C','F': + cc = HEXDIG + break + case ':': + cc = SEXAG + break + case '.': + cc = FRACTION + break + default: + if (IS_LOWER (ch)) + ch = TO_UPPER (ch) # and repeat + else if (ch == 'X') { + cc = HEXSUFFIX + break + } else { + cc = OTHER + break + } + } + } + +#call eprintf ("ip=%2d, sp=%2d, ch=%c, cc=%d, state=%d, action=%d\n") +#call pargi(ip); call pargi(sp) +#call pargc(ch); call pargi(cc); call pargi(state) +#call pargs(action[cc,state]) + + # Perform the action indicated by the action table when this + # class of character is encountered in the current state. + + act = action[cc,state] + if (act == ACCEPT) { + ip = ip + 1 # a simple optimization + next + } + + switch (act) { + case REVERT: + repeat { + ip = stk_ip[sp] + state = stk_state[sp] + toktype = action[OTHER,state] + sp = sp - 1 + } until (toktype != REVERT || sp <= 0) + + break + + case LEX_OCTAL, LEX_DECIMAL, LEX_HEX, LEX_REAL, LEX_NONNUM: + toktype = action[cc,state] + if (toktype == LEX_OCTAL && cc == OCTSUFFIX) + ip = ip + 1 # discard suffix char + else if (toktype == LEX_HEX && cc == HEXSUFFIX) + ip = ip + 1 + break + + default: # shift to new state + sp = sp + 1 + if (sp > SZ_STACK) { + toktype = LEX_NONNUM + break + } + stk_ip[sp] = ip + stk_state[sp] = state + + ip = ip + 1 + state = action[cc,state] + if (state < 1 || state > NSTATES) + call error (0, "In LEXNUM: cannot happen") + } + } + + if (toktype == LEX_NONNUM) + nchars = 0 + else + nchars = ip - ip_save + + return (toktype) +end diff --git a/sys/fmtio/ltoc.x b/sys/fmtio/ltoc.x new file mode 100644 index 00000000..d2105433 --- /dev/null +++ b/sys/fmtio/ltoc.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DECIMAL 10 + +# LTOC -- Convert long integer to decimal string. +# Returns the number of characters generated. + +int procedure ltoc (lval, outstr, maxch) + +long lval # long integer to be encoded +char outstr[ARB] # output buffer +int maxch # size of output buffer +int gltoc() + +begin + return (gltoc (lval, outstr, maxch, DECIMAL)) +end diff --git a/sys/fmtio/mkpkg b/sys/fmtio/mkpkg new file mode 100644 index 00000000..b27d6a5f --- /dev/null +++ b/sys/fmtio/mkpkg @@ -0,0 +1,125 @@ +# Formatted i/o (FMTIO) portion of the system library. + +$checkout libsys.a lib$ +$update libsys.a +$checkin libsys.a lib$ +$exit + +tfiles: + $ifnewer (evvexpr.gy, evvexpr.y) + $generic -k evvexpr.gy -o evvexpr.y + $endif + + $ifnewer (evvexpr.y, evvexpr.x) + $ifeq (HOSTID, unix) + $echo "fmtio/evvexpr.x is out of date; rebuilding with XYACC:" + !(xyacc evvexpr.y; mv -f ytab.x evvexpr.x) + $else + $echo "fmtio/evvexpr.x is out of date; rebuild with XYACC" + $endif + $endif + + $ifnewer (evexpr.y, evexpr.x) + $ifeq (HOSTID, unix) + $echo "fmtio/evexpr.x is out of date; rebuilding with XYACC:" + !(xyacc evexpr.y; mv -f ytab.x evexpr.x) + $else + $echo "fmtio/evexpr.x is out of date; rebuild with XYACC" + $endif + $endif + ; + +libsys.a: + $ifeq (USE_GENERIC, yes) $call tfiles $endif + + cctoc.x escchars.inc + chdeposit.x + chfetch.x + chrlwr.x + chrupr.x + clprintf.x + clscan.x scan.com + ctocc.x escchars.inc + ctod.x + ctoi.x + ctol.x + ctor.x + ctotok.x tokdata.inc + ctowrd.x + ctox.x + dtcscl.x + dtoc.x + dtoc3.x + eprintf.x + evexpr.x evexpr.com + evvexpr.x evvexpr.com \ + + fmterr.x + fmtinit.x fmt.com + fmtread.x fmt.com + fmtsetcol.x + fmtstr.x + fpradv.x fmt.com + fprfmt.x fmt.com + fprintf.x + fprntf.x fmt.com + fscan.x scan.com + gargb.x scan.com + gargc.x scan.com + gargd.x scan.com + gargi.x + gargl.x + gargr.x + gargrad.x scan.com + gargs.x + gargstr.x scan.com + gargtok.x scan.com + gargwrd.x scan.com + gargx.x scan.com + gctod.x + gctol.x + gctox.x + gltoc.x + gstrcat.x + gstrcpy.x + itoc.x + lexnum.x lexdata.inc + ltoc.x + nscan.x scan.com + parg.x fmt.com + pargb.x + pargstr.x fmt.com + pargx.x fmt.com + patmatch.x + printf.x + resetscan.x scan.com + scanc.x scan.com + sprintf.x + sscan.x scan.com + strcat.x + strcmp.x + strcpy.x + strdic.x + streq.x + strge.x + strgt.x + stridx.x + stridxs.x + strldx.x + strldxs.x + strle.x + strlen.x + strlt.x + strlwr.x + strmac.x + strmatch.x + strncmp.x + strne.x + strsearch.x + strsrt.x + strtbl.x + strupr.x + xevgettok.x + xvvgettok.x + xtoc.x + ; diff --git a/sys/fmtio/nscan.x b/sys/fmtio/nscan.x new file mode 100644 index 00000000..c9069927 --- /dev/null +++ b/sys/fmtio/nscan.x @@ -0,0 +1,12 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# NSCAN -- Return the number of tokens successfully converted in the most +# recent scan. + +int procedure nscan() + +include "scan.com" + +begin + return (sc_ntokens) +end diff --git a/sys/fmtio/parg.x b/sys/fmtio/parg.x new file mode 100644 index 00000000..d65bd3ce --- /dev/null +++ b/sys/fmtio/parg.x @@ -0,0 +1,283 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +.help parg +.nf ___________________________________________________________________________ +PARG[CSILRDX] -- Pass a numeric argument to printf. Get the format spec and +format the number on the output file. Try to provide reasonable automatic +type conversions. Avoid any type coercion of indefinites. +We try to make the operand fit in the specified field width, decreasing the +precision if necessary, but if it cannot be made to fit we increase the field +width until it does. We feel that it is more important to output a readable +number than to keep the output columns justified. +.endhelp ______________________________________________________________________ + + +# PARGD -- Pass a double. + +procedure pargd (dval) + +double dval + +begin + call pargg (dval, TY_DOUBLE) +end + + +# PARGC -- Pass a char. + +procedure pargc (cval) + +char cval +double dval + +begin + dval = cval + call pargg (dval, TY_CHAR) +end + + +# PARGS -- Pass a short. + +procedure pargs (sval) + +short sval +double dval + +begin + dval = sval + if (IS_INDEFS (sval)) + dval = INDEFD + + call pargg (dval, TY_SHORT) +end + + +# PARGI -- Pass an int. + +procedure pargi (ival) + +int ival +double dval + +begin + dval = ival + if (IS_INDEFI (ival)) + dval = INDEFD + + call pargg (dval, TY_INT) +end + + +# PARGL -- Pass a long. + +procedure pargl (lval) + +long lval +double dval + +begin + dval = lval + if (IS_INDEFL (lval)) + dval = INDEFD + + call pargg (dval, TY_LONG) +end + + +# PARGR -- Pass a real. + +procedure pargr (rval) + +real rval +double dval + +begin + dval = rval + if (IS_INDEFR (rval)) + dval = INDEFD + + call pargg (dval, TY_REAL) +end + + +# PARGG -- Generic put argument. Encode a value of a specific datatype passed +# as a double precision value. + +procedure pargg (value, dtype) + +double value +int dtype + +char ch +long lnum +complex xnum +int n, precision, i, junk, ival, nchars, nbits, fmt +int ctocc(), gltoc(), dtoc(), xtoc(), fprfmt() +errchk putci, fmtstr, fpradv +include "fmt.com" + +begin + # Read format. If format spec contains "*" fields, VALUE is a part of + # the format, rather than a true operand. In that case we return, + # and the next call again checks to see if the format spec is complete. + # Note that if VALUE is not part of the format but is instead a floating + # point value to be printed, it may have an exponent large enough to + # cause integer overflow in an INT(VALUE) operation, hence we must + # guard against this. This is easy since only PARGI will be used to + # pass format information. + + if (dtype == TY_REAL || dtype == TY_DOUBLE) + ival = 0 + else if (IS_INDEFD (value)) + ival = INDEFI + else + ival = nint (value) + + if (fprfmt (ival) == NOT_DONE_YET) + return + + if (format_char == USE_DEFAULT || format_char == FMT_STRING) + switch (dtype) { + case TY_CHAR: + format_char = FMT_CHAR + case TY_INT: + format_char = FMT_DECIMAL + default: + format_char = FMT_GENERAL + } + + if (dtype == TY_DOUBLE) # supply def. precision + precision = NDIGITS_DP + else + precision = NDIGITS_RP + + if (width == USE_DEFAULT) # make as big as needed + width = SZ_OBUF + + # Convert number from binary into character form in OBUF, applying + # defaults as needed. + + # Ignore case in testing format type. + fmt = format_char + if (IS_UPPER (fmt)) + fmt = TO_LOWER(fmt) + + switch (fmt) { + case FMT_BOOL: + if (IS_INDEFD (value)) + call strcpy ("INDEF", obuf, SZ_OBUF) + else if (int (value) == 0) + call strcpy ("NO", obuf, SZ_OBUF) + else + call strcpy ("YES", obuf, SZ_OBUF) + + case FMT_CHAR: + if (IS_INDEFD (value)) + call strcpy ("INDEF", obuf, SZ_OBUF) + else { + ch = nint (value) + junk = ctocc (ch, obuf, SZ_OBUF) + } + + case FMT_DECIMAL, FMT_OCTAL, FMT_HEX, FMT_RADIX, FMT_UNSIGNED: + switch (fmt) { + case FMT_DECIMAL: + radix = DECIMAL # signed decimal + case FMT_OCTAL: + radix = -OCTAL # unsigned octal + case FMT_HEX: + radix = -HEX # unsigned hex + case FMT_UNSIGNED: + radix = -DECIMAL # unsigned decimal + default: + radix = -abs(radix) # unsigned radix + } + + if (IS_INDEFD (value)) { + lnum = INDEFL + nchars = gltoc (lnum, obuf, SZ_OBUF, radix) + + } else { + lnum = long (value) + nchars = gltoc (lnum, obuf, SZ_OBUF, radix) + + # Limit sign extension if negative number, hex or octal. + if (lnum < 0 && (dtype == TY_SHORT || dtype == TY_CHAR)) { + nbits = SZB_CHAR * NBITS_BYTE + if (dtype == TY_SHORT) + nbits = nbits * SZ_SHORT + if (fmt == FMT_OCTAL) { + n = nchars - (nbits + 2) / 3 + if (n > 0) { + call strcpy (obuf[n+2], obuf[2], SZ_OBUF) + obuf[1] = '1' + } + } else if (fmt == FMT_HEX) { + n = nchars - (nbits + 3) / 4 + if (n > 0) + call strcpy (obuf[n+1], obuf[1], SZ_OBUF) + } + } + } + + case FMT_EXPON, FMT_FIXED, FMT_GENERAL, FMT_HMS, FMT_MINSEC: + if (decpl == USE_DEFAULT || decpl == 0) + switch (fmt) { + case FMT_EXPON, FMT_GENERAL: + decpl = precision + case FMT_HMS, FMT_MINSEC: + if (decpl == USE_DEFAULT) + decpl = 1 + default: + if (decpl == USE_DEFAULT) + decpl = precision + } + repeat { + # Need the case sensitive format char here. + n = dtoc (value, obuf, SZ_OBUF, decpl, format_char, width+1) + decpl = decpl - 1 + } until (n <= width || decpl <= 0) + + case FMT_TOCOLUMN: # advance to column + for (i=int(value); col < i; col=col+1) + call putci (fd, ' ') + call fpradv() + return + + case FMT_WHITESPACE: # output whitespace + for (i=0; i < int(value); i=i+1) + call putci (fd, ' ') + col = col + i + call fpradv() + return + + case FMT_COMPLEX: + if (decpl == USE_DEFAULT) # set defaults + decpl = precision + else + decpl = abs (decpl) + + if (IS_INDEFD (value)) + xnum = INDEFX + else + xnum = complex (value) + + # Convert, decrease precision until it fits in given field width. + repeat { + n = xtoc (xnum, obuf, SZ_OBUF, decpl, 'e', SZ_OBUF) + decpl = decpl - 1 + } until (n <= width || decpl <= 0) + } + + # Move the string in OBUF to the output file, left or right justifying + # as specified. Advance to the next format spec (or finish up). + + if (width == SZ_OBUF) # free format? + width = 0 + call fmtstr (fd, obuf, col, fill_char, left_justify, SZ_OBUF, width) + call fpradv () +end diff --git a/sys/fmtio/pargb.x b/sys/fmtio/pargb.x new file mode 100644 index 00000000..bc3e6eb0 --- /dev/null +++ b/sys/fmtio/pargb.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PARGB -- Print a boolean operand (as a string). + +procedure pargb (bval) + +bool bval + +begin + if (bval) + call pargstr ("yes") + else + call pargstr ("no") +end diff --git a/sys/fmtio/pargstr.x b/sys/fmtio/pargstr.x new file mode 100644 index 00000000..59fc7433 --- /dev/null +++ b/sys/fmtio/pargstr.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PARGSTR -- Pass a string type operand to printf. + +procedure pargstr (str) + +char str[ARB] +int maxch +include "fmt.com" + +begin + call fmt_read() # get format + + if (decpl == USE_DEFAULT) + maxch = SZ_OBUF + else + maxch = abs (decpl) + + if (width == USE_DEFAULT) + width = 0 + + call fmtstr (fd, str, col, fill_char, left_justify, maxch, width) + call fpradv () +end diff --git a/sys/fmtio/pargx.x b/sys/fmtio/pargx.x new file mode 100644 index 00000000..d399da29 --- /dev/null +++ b/sys/fmtio/pargx.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# PARGX -- Pass a numeric argument of type complex to printf. Get the format +# spec and format the number on the output file. Try to provide reasonable +# automatic type conversions. Avoid any type coercion of indefinites. + +procedure pargx (xval) + +complex xval # complex value to be encoded +double value +int n, xtoc() +include "fmt.com" + +begin + call fmt_read() # read format + + if (format_char == FMT_COMPLEX || format_char == USE_DEFAULT) { + if (width == USE_DEFAULT) # print as (r,r) + width = SZ_OBUF + + if (decpl == USE_DEFAULT || decpl == 0) + decpl = NDIGITS_RP + else + decpl = abs (decpl) + + # Encode number in the available field width, decreasing the + # precision until the number fits. + + repeat { + n = xtoc (xval, obuf, SZ_OBUF, decpl, FMT_EXPON, SZ_OBUF) + decpl = decpl - 1 + } until (n <= width || decpl <= 0) + + # Move the string in OBUF to the output file, left or right + # justifying as specified. Advance to the next format spec + # (or finish up). + + if (width == SZ_OBUF) # free format? + width = 0 + call fmtstr (fd, obuf, col, fill_char, left_justify, SZ_OBUF, width) + call fpradv () + + } else { + # Print real part of complex number in some format other than + # complex. + + value = real (xval) + if (IS_INDEFR (real(xval))) + value = INDEFD + + call pargg (value, TY_REAL) + } +end diff --git a/sys/fmtio/patmatch.x b/sys/fmtio/patmatch.x new file mode 100644 index 00000000..9972060f --- /dev/null +++ b/sys/fmtio/patmatch.x @@ -0,0 +1,568 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# PATMATCH.X -- Routines for matching regular expressions (general pattern +# matching). Adapted from Software Tools. +# +# patsize = patmake (patstr, patbuf, sz_patbuf) +# next_char = patmatch (str, patbuf) +# next_char = gpatmatch (str, patbuf, first_char, last_char) +# ip = patindex (patbuf, index_number) +# +# The pattern string must be encoded with PATMAKE before use. See also +# STRMATCH, STRNCMP, etc. + +# Pattern codes (for encoded patterns). + +define EOP -1 # end of encoded pattern +define CHAR -2 # match char +define UCHAR -3 # match either case +define LCHAR -4 # match either case +define BOL -5 # match at beginning of line +define EOL -6 # match at end of line +define ANY -7 # "?" +define WHITESPACE -8 # "#" +define CCL -9 # [... +define NCCL -10 # [^... +define CLOSURE -11 # "*" +define INDEX -12 # % (mark index of ^ in pattern) + +define CH_INDEX '%' # move to after a while + +# Definitions for the closure structure. + +define CLOSIZE 4 # size of closure structure +define COUNT 1 # repeat count for matches +define PREVCL 2 # index of previous closure in pat +define START 3 # index in str where match starts + + +# PATMATCH -- Match pattern anywhere on line. Returns the index of the +# first character AFTER the match, or zero if no match. + +int procedure patmatch (str, pat) + +char str[ARB] # string to be scanned +char pat[ARB] # encoded pattern + +int first_char, last_char +int gpatmatch() + +begin + return (gpatmatch (str, pat, first_char, last_char)) +end + + +# GPATMATCH -- Generalized pattern match. Matches pattern anywhere on +# line (the first such pattern matched terminates the search). Function +# return same as for PATMATCH, but also returns indices of the first and +# last characters in the matched substring. + +int procedure gpatmatch (str, pat, first_char, last_char) + +char str[ARB] # string to be scanned +char pat[ARB] # encoded pattern +int first_char # index of first char matched (output) +int last_char # index of last char matched (output) + +int ip, nchars_matched +int pat_amatch() # anchored match + +begin + nchars_matched = 0 + + if (pat[1] == BOL) { + ip = 1 + nchars_matched = pat_amatch (str, ip, pat) + } else { + for (ip=1; str[ip] != EOS; ip=ip+1) { + nchars_matched = pat_amatch (str, ip, pat) + if (nchars_matched > 0) + break + } + } + + if (nchars_matched > 0) { + first_char = ip + last_char = ip + nchars_matched - 1 + return (last_char + 1) + } else + return (0) +end + + +# PATINDEX -- Return the index of a marked position in the pattern. Inclusion +# of the character % in the pattern causes the index of the character following +# the % to be saved in the encoded pattern at patmatch time. We are called +# after a patmatch operation to scan the pattern and recall the Nth saved index. +# Zero is returned if N is larger than the number of saved index points. + +int procedure patindex (pat, n) + +char pat[ARB] # encoded pattern +int n # number of index to be returned + +int pp, ix +int pat_gsize() + +begin + ix = 1 + for (pp=1; pat[pp] != EOP; pp=pp+pat_gsize(pat,pp)) + if (pat[pp] == INDEX) + if (ix >= n) + return (pat[pp+1]) + else + ix = ix + 1 + + return (0) +end + + +# PAT_AMATCH -- Anchored match. Look for match starting at the given +# offset. Return the number of characters matched. + +int procedure pat_amatch (str, from, pat) + +char str[ARB] # string to be matched +int from # starting at this index +char pat[ARB] # encoded pattern + +int ip, pp, offset, stack +int pat_omatch(), pat_gsize() + +begin + stack = 0 + offset = from # next unexamined input char + + for (pp=1; pat[pp] != EOP; pp = pp + pat_gsize(pat,pp)) { + if (pat[pp] == CLOSURE) { # a closure entry + stack = pp + pp = pp + CLOSIZE + # Match as many characters as possible, save results + for (ip=offset; str[ip] != EOS; ) + if (pat_omatch (str, ip, pat, pp) == NO) + break + pat[stack+COUNT] = ip - offset + pat[stack+START] = offset + offset = ip # character that made us fail + + } else if (pat_omatch (str, offset, pat, pp) == NO) { + for (; stack > 0; stack = pat[stack+PREVCL]) + if (pat[stack+COUNT] > 0) + break + if (stack <= 0) # stack is empty + return (0) # return failure + + pat[stack+COUNT] = pat[stack+COUNT] - 1 + pp = stack + CLOSIZE + offset = pat[stack+START] + pat[stack+COUNT] + } + } + + return (offset-from) # successful match +end + + +# PAT_GSIZE -- Returns size of pattern entry at pat[n]. + +int procedure pat_gsize (pat, n) + +char pat[ARB] # encoded pattern +int n # pointer into pattern +int pattern_size + +begin + switch (pat[n]) { + case CHAR, UCHAR, LCHAR, INDEX: + pattern_size = 2 + case BOL, EOL, ANY, WHITESPACE: + pattern_size = 1 + case CCL, NCCL: + pattern_size = pat[n+1] + 2 + case CLOSURE: # not used + pattern_size = CLOSIZE + default: + call error (0, "In patsize: can't happen.") + } + + return (pattern_size) +end + + +# PAT_OMATCH -- Try to match a single pattern at pat[pp]. If match, bump IP +# to point to the next unmatched character. Return OK if match. + +int procedure pat_omatch (str, ip, pat, pp) + +char str[ARB] # string to be scanned +int ip # starting index in string (may be changed) +char pat[ARB] # encoded pattern +int pp # pointer to next pattern element + +char str_ch +int bump, pat_locate() + +begin + if (str[ip] == EOS) + if (pat[pp] == INDEX) { + pat[pp+1] = ip + return (YES) + } else if (pat[pp] == EOL) { + return (YES) + } else + return (NO) + + # Treat CHAR (simple character match) as a special case to speed + # things up a bit. + + if (pat[pp] == CHAR) + if (str[ip] == pat[pp+1]) { + ip = ip + 1 + return (YES) + } else + return (NO) + + # Compare as indicated by encoded pattern opcode. + bump = -1 + + switch (pat[pp]) { + case UCHAR: # match either case + str_ch = str[ip] + if (IS_LOWER (str_ch)) + str_ch = TO_UPPER (str_ch) + if (str_ch == pat[pp+1]) + bump = 1 + case LCHAR: # match either case + str_ch = str[ip] + if (IS_UPPER (str_ch)) + str_ch = TO_LOWER (str_ch) + if (str_ch == pat[pp+1]) + bump = 1 + case BOL: # beg. of line + if (ip == 1) + bump = 0 + case EOL: # end of line + if (str[ip] == '\n') + bump = 0 + case ANY: # match any char + if (str[ip] != '\n') + bump = 1 + case WHITESPACE: + for (bump=0; IS_WHITE (str[ip+bump]); bump=bump+1) + ; + case CCL: # char class + if (pat_locate (str[ip], pat, pp + 1) == YES) + bump = 1 + case NCCL: # not in char class + if (str[ip] != '\n' && pat_locate (str[ip], pat, pp + 1) == NO) + bump = 1 + case INDEX: + pat[pp+1] = ip + bump = 0 + default: + call error (0, "In omatch: can't happen.") + } + + if (bump >= 0) { + ip = ip + bump + return (YES) + } else + return (NO) +end + + +# PAT_LOCATE -- Look for c in char class at pat[offset]. + +int procedure pat_locate (ch, pat, offset) + +char ch # char to search for +char pat[ARB] # encoded pattern +int offset # offset of character class in pattern + +int nchars, i + +begin + # Size of class is at pat[offset], characters follow. + nchars = pat[offset] + do i = 1, nchars + if (ch == pat[offset+i]) + return (YES) + + return (NO) +end + + +# PATMAKE -- Encode pattern specification string. Returns the size of +# the encoded pattern string. + +int procedure patmake (str, pat, sz_pat) + +char str[ARB] # pattern to be encoded +char pat[ARB] # encoded pattern (output) +int sz_pat # max size of the pattern string +int gpatmake() + +begin + return (gpatmake (str, 1, EOS, pat, sz_pat)) +end + + +# GPATMAKE -- Make pattern from str[from], terminate at delim. + +int procedure gpatmake (patstr, from, delim, patbuf, sz_pat) + +char patstr[ARB] # pattern to be encoded +int from # starting index +int delim # delimiter character +char patbuf[ARB] # put encoded pattern here +int sz_pat # max chars in encoded pattern + +int ip, op, last_closure, last_op, l_op +char cval +bool ignore_case +int cctoc(), pat_getccl(), pat_stclos() + +begin + op = 1 # pat index + last_op = 1 + last_closure = 0 + ignore_case = false + + for (ip=from; patstr[ip] != delim && patstr[ip] != EOS; ip=ip+1) { + l_op = op + + # If CVAL gets set to nonzero it will be deposited in the output + # buffer at end of switch. + + cval = 0 + + switch (patstr[ip]) { + case CH_ANY: + cval = ANY + case CH_WHITESPACE: + cval = WHITESPACE + + case CH_BOL: + if (ip == from) + cval = BOL + else { + cval = CHAR + call chdeposit (cval, patbuf, sz_pat, op) + cval = CH_BOL + } + + case CH_EOL: + if (patstr[ip+1] == delim) + cval = EOL + else { + cval = CHAR + call chdeposit (cval, patbuf, sz_pat, op) + cval = CH_EOL + } + + case CH_IGNORECASE: + ignore_case = true + case CH_MATCHCASE: + ignore_case = false + + case CH_CCL: + if (pat_getccl (patstr, patbuf, sz_pat, ip, op) == ERR) + return (ERR) + + case CH_CLOSURE: + # The "closure" of a pattern, e.g., "..*". + + l_op = last_op + # Convert a pattern such as "*..." into "?*...". + if (ip == from) # closure of nothing + cval = ANY + else { + switch (patbuf[l_op]) { + case BOL, EOL, CLOSURE: + cval = ANY + } + } + + if (cval != 0) + call chdeposit (cval, patbuf, sz_pat, op) + cval = 0 + + last_closure = pat_stclos (patbuf, sz_pat, op, last_op, + last_closure) + + case CH_INDEX: + # This metacharacter does not match anything, but rather is + # used to record the index of the marked position in the + # matched pattern. The index is recorded in the pattern + # buffer at match time, to be later recovered with patindex. + + cval = INDEX + call chdeposit (cval, patbuf, sz_pat, op) + cval = 0 + call chdeposit (cval, patbuf, sz_pat, op) + + default: + # Ordinary character. + + # Deposit command code. + if (ignore_case) { + if (IS_UPPER (patstr[ip])) + cval = UCHAR + else + cval = LCHAR + } else + cval = CHAR + call chdeposit (cval, patbuf, sz_pat, op) + + # Set CVAL to actual character value. + if (patstr[ip] == CH_ESCAPE) { + if (cctoc (patstr, ip, cval) == 1) + cval = patstr[ip] + else + ip = ip - 1 + } else + cval = patstr[ip] + } + + # Deposit the character left in CVAL by the code above. + if (cval != 0) + call chdeposit (cval, patbuf, sz_pat, op) + + last_op = l_op + } + + # Terminate the pattern. + cval = EOP + call chdeposit (cval, patbuf, sz_pat, op) + + if (patstr[ip] != delim || op >= sz_pat) + return (ERR) + else + return (op - 1) # return size patbuf +end + + +# PAT_GETCCL -- Expand character class at patstr[i] into patbuf[op]. + +int procedure pat_getccl (patstr, patbuf, sz_pat, ip, op) + +char patstr[ARB], patbuf[ARB] +int sz_pat, ip, op +char cval +int op_start + +begin + ip = ip + 1 # skip over [ + if (patstr[ip] == CH_NOT) { + cval = NCCL + ip = ip + 1 + } else + cval = CCL + + call chdeposit (cval, patbuf, sz_pat, op) + + op_start = op + cval = 0 + call chdeposit (cval, patbuf, sz_pat, op) # leave room for count + call pat_filset (CH_CCLEND, patstr, ip, patbuf, sz_pat, op) + patbuf[op_start] = op - op_start - 1 # fix up count + + if (patstr[ip] == CH_CCLEND) + return (OK) + else + return (ERR) +end + + +# PAT_STCLOS -- Insert closure entry at patbuf[op]. + +int procedure pat_stclos (patbuf, sz_pat, op, last_op, last_closure) + +char patbuf[ARB] +int sz_pat +int op +int last_op +int last_closure + +char cvals[4] +int next_closure, jp, jt, i + +begin + for (jp=op-1; jp >= last_op; jp=jp-1) { # make a hole + jt = min (sz_pat, jp + CLOSIZE) + patbuf[jt] = patbuf[jp] + } + + op = op + CLOSIZE + next_closure = last_op + + cvals[1] = CLOSURE + cvals[2] = 0 # COUNT + cvals[3] = last_closure # PREVCL + cvals[4] = 0 # START + + do i = 1, 4 + call chdeposit (cvals[i], patbuf, sz_pat, last_op) + + return (next_closure) +end + + +# PAT_FILSET -- Process a character class into a simple list of characters. + +procedure pat_filset (delim, patstr, ip, patbuf, sz_pat, op) + +int delim # character class delimiter character +char patstr[ARB] # character class characters +int ip # index where they start +char patbuf[ARB] # encode character class in this string +int sz_pat # max chars out +int op # offset into patbuf + +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) + + } else { + # 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. + + 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 diff --git a/sys/fmtio/printf.x b/sys/fmtio/printf.x new file mode 100644 index 00000000..e0662d90 --- /dev/null +++ b/sys/fmtio/printf.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PRINTF -- Format output to the standard output. + +procedure printf (format_string) + +char format_string[ARB] + +begin + call fprntf (STDOUT, format_string, REGULAR_FILE) +end diff --git a/sys/fmtio/resetscan.x b/sys/fmtio/resetscan.x new file mode 100644 index 00000000..bde3a8f7 --- /dev/null +++ b/sys/fmtio/resetscan.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# RESET_SCAN -- Initialize the scan common at the start of a scan. May also +# be called by the user to rescan a line, following a conversion failure. + +procedure reset_scan() + +include "scan.com" + +begin + sc_ip = 1 + sc_ntokens = 0 + sc_stopscan = false +end diff --git a/sys/fmtio/scan.com b/sys/fmtio/scan.com new file mode 100644 index 00000000..cb60824c --- /dev/null +++ b/sys/fmtio/scan.com @@ -0,0 +1,10 @@ +# SCAN.COM -- Global common for the scan family of routines. + +define SZ_SCANBUF 4096 + +int sc_ip # char pointer into lbuf +int sc_ntokens # keep track of successful conversions +bool sc_stopscan # set if conversion is unsuccessful +char sc_scanbuf[SZ_SCANBUF] # line buffer for scan procedures + +common /scncom/ sc_ip, sc_ntokens, sc_stopscan, sc_scanbuf diff --git a/sys/fmtio/scanc.x b/sys/fmtio/scanc.x new file mode 100644 index 00000000..1578af42 --- /dev/null +++ b/sys/fmtio/scanc.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# SCANC -- Return the next character from the scanned input. + +procedure scanc (cval) + +char cval +include "scan.com" + +begin + cval = sc_scanbuf[sc_ip] + if (cval != EOS) + sc_ip = sc_ip + 1 +end diff --git a/sys/fmtio/sprintf.x b/sys/fmtio/sprintf.x new file mode 100644 index 00000000..c247d868 --- /dev/null +++ b/sys/fmtio/sprintf.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# SPRINTF: Open string as a file, call fprntf. When the last argument is +# passed, and EOS is reached, the string will be closed (by fpradv). + +procedure sprintf (outstr, maxch, format_string) + +char outstr[maxch] +int maxch +char format_string[ARB] +int mem_fd, stropen() +errchk stropen, fprntf + +begin + mem_fd = stropen (outstr, maxch, WRITE_ONLY) + call fprntf (mem_fd, format_string, STRING_FILE) +end diff --git a/sys/fmtio/sscan.x b/sys/fmtio/sscan.x new file mode 100644 index 00000000..6c877dc2 --- /dev/null +++ b/sys/fmtio/sscan.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# SSCAN -- Begin a scan from a string. Only the first newline terminated +# line in the string buffer will be scanned. If a string buffer containing +# more than a single line must be scanned, MEMOPEN and FSCAN may be used. + +procedure sscan (str) + +char str[ARB] +int ip, op +include "scan.com" + +begin + op = 1 + for (ip=1; str[ip] != EOS && str[ip] != '\n'; ip=ip+1) { + sc_scanbuf[op] = str[ip] + op = op + 1 + if (op >= SZ_SCANBUF) + break + } + + sc_scanbuf[op] = EOS + call reset_scan() # initialize scan +end diff --git a/sys/fmtio/strcat.x b/sys/fmtio/strcat.x new file mode 100644 index 00000000..777174a3 --- /dev/null +++ b/sys/fmtio/strcat.x @@ -0,0 +1,12 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# STRCAT -- String concatenation. String STR is appended to OUTSTR. + +procedure strcat (str, outstr, maxch) + +char str[ARB], outstr[ARB] +int maxch, junk, gstrcat() + +begin + junk = gstrcat (str, outstr, maxch) +end diff --git a/sys/fmtio/strcmp.x b/sys/fmtio/strcmp.x new file mode 100644 index 00000000..67dbc2ba --- /dev/null +++ b/sys/fmtio/strcmp.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# STRCMP -- Compare two strings. -N is returned if S1 < S2, 0 if S1 == S2, +# and +N if S1 > S2. + +int procedure strcmp (s1, s2) + +char s1[ARB], s2[ARB] # strings to be compared +int i + +begin + do i = 1, ARB + if (s1[i] != s2[i]) + return (s1[i] - s2[i]) + else if (s1[i] == EOS) + return (0) +end diff --git a/sys/fmtio/strcpy.x b/sys/fmtio/strcpy.x new file mode 100644 index 00000000..8892e89d --- /dev/null +++ b/sys/fmtio/strcpy.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# STRCPY -- Copy string s1 to s2. + +procedure strcpy (s1, s2, maxch) + +char s1[ARB], s2[ARB] +int maxch, i + +begin + do i = 1, maxch { + s2[i] = s1[i] + if (s2[i] == EOS) + return + } + + s2[maxch+1] = EOS +end diff --git a/sys/fmtio/strdic.x b/sys/fmtio/strdic.x new file mode 100644 index 00000000..3da4a71b --- /dev/null +++ b/sys/fmtio/strdic.x @@ -0,0 +1,73 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# STRDIC -- Search a dictionary string for a match with an input string. +# The input string may be an abbreviation of a dictionary entry, however, +# it is an error if the abbreviation is not unique. The entries in the +# dictionary string are separated by a delimiter character which is the first +# character of the dictionary string. The full name of the matched dictionary +# entry found is returned in out_str; the function value is the word index of +# the dictionary entry. The output string may be the same as the input string. + +int procedure strdic (in_str, out_str, maxchars, dict) + +char in_str[ARB] # Input string, always lower case +char out_str[ARB] # Output string as found in dictionary +int maxchars # Maximum length of output string +char dict[ARB] # Dictionary string + +char ch, fch +int start, len, ip, i, match, entry +int strlen(), strncmp() + +begin + if (dict[1] == EOS) + return (0) + + for (i=1; IS_WHITE (in_str[i]); i=i+1) + ; + + start = i + match = 0 + ip = 2 + len = strlen (in_str[start]) + fch = in_str[start] + + # Search the dictionary string. If the input string matches a + # dictionary entry it is either an exact match (len = dictionary + # entry length) or a legal abbreviation. If an abbreviation + # matches two entries it is ambiguous and an error. + + for (entry=1; dict[ip] != EOS; entry=entry+1) { + if (dict[ip] == fch) { + if (strncmp (dict[ip], in_str[start], len) == 0) { + for (i=1; i <= maxchars; i=i+1) { + ch = dict[ip+i-1] + if ((ch == dict[1]) || (ch == EOS)) + break + out_str[i] = ch + } + out_str[i] = EOS + + if ((dict[ip+len] == dict[1]) || (dict[ip+len] == EOS)) + return (entry) # exact match + else { + # If we already have a match and the new match is not + # exact, then the abbreviation is ambiguous. + + if (match != 0) + return (0) + else + match = entry + } + } + } + + repeat { + ip = ip + 1 + } until (dict[ip-1] == dict[1] || dict[ip] == EOS) + } + + return (match) +end diff --git a/sys/fmtio/streq.x b/sys/fmtio/streq.x new file mode 100644 index 00000000..0f394d6d --- /dev/null +++ b/sys/fmtio/streq.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# STREQ -- Compare two strings for equality. + +bool procedure streq (s1, s2) + +char s1[ARB], s2[ARB] +int ip + +begin + do ip = 1, ARB + if (s1[ip] != s2[ip]) + return (false) + else if (s1[ip] == EOS) + return (s2[ip] == EOS) +end diff --git a/sys/fmtio/strge.x b/sys/fmtio/strge.x new file mode 100644 index 00000000..4fc24c59 --- /dev/null +++ b/sys/fmtio/strge.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# STRGE -- Is S1 >= S2. + +bool procedure strge (s1, s2) + +char s1[ARB], s2[ARB] +int ip + +begin + do ip = 1, ARB + if (s2[ip] == EOS) + return (true) + else if (s1[ip] != s2[ip]) + return (s1[ip] > s2[ip]) +end diff --git a/sys/fmtio/strgt.x b/sys/fmtio/strgt.x new file mode 100644 index 00000000..720a1397 --- /dev/null +++ b/sys/fmtio/strgt.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# STRGT -- Is S1 > S2. + +bool procedure strgt (s1, s2) + +char s1[ARB], s2[ARB] +int ip + +begin + do ip = 1, ARB + if (s1[ip] == EOS) + return (false) + else if (s1[ip] != s2[ip]) + return (s1[ip] > s2[ip]) +end diff --git a/sys/fmtio/stridx.x b/sys/fmtio/stridx.x new file mode 100644 index 00000000..dda74f5a --- /dev/null +++ b/sys/fmtio/stridx.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# STRIDX -- Return the index of the first occurrence of a character in a +# string. + +int procedure stridx (ch, str) + +char ch, str[ARB] +int ip + +begin + do ip = 1, ARB + if (str[ip] == EOS) + return (0) + else if (str[ip] == ch) + return (ip) +end diff --git a/sys/fmtio/stridxs.x b/sys/fmtio/stridxs.x new file mode 100644 index 00000000..fef58806 --- /dev/null +++ b/sys/fmtio/stridxs.x @@ -0,0 +1,43 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define BIGSET 10 +define SZ_ASCII 128 + +# STRIDXS -- Return the index of the first occurrence of any of a set of +# characters in a string. + +int procedure stridxs (set, str) + +char set[ARB] # set of characters to be searched for +char str[ARB] # string to be searched + +int setlen, ip, i +char ch, lut[SZ_ASCII] +int strlen() + +begin + setlen = strlen (set) + + if (setlen > BIGSET) { + # Encode the set in a lookup table. + call aclrc (lut, SZ_ASCII) + do i = 1, setlen + lut[set[i]] = 1 + + # Search the string. + for (ip=1; str[ip] != EOS; ip=ip+1) + if (lut[str[ip]] != 0) + return (ip) + + } else { + # Set is too small to be worth using a lookup table. + for (ip=1; str[ip] != EOS; ip=ip+1) { + ch = str[ip] + do i = 1, setlen + if (ch == set[i]) + return (ip) + } + } + + return (0) +end diff --git a/sys/fmtio/strldx.x b/sys/fmtio/strldx.x new file mode 100644 index 00000000..0087a208 --- /dev/null +++ b/sys/fmtio/strldx.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# STRLDX -- Return the index of the last occurrence of a character in a +# string. + +int procedure strldx (ch, str) + +char ch, str[ARB] +int ip, offset + +begin + offset = 0 + do ip = 1, ARB + if (str[ip] == EOS) + break + else if (str[ip] == ch) + offset = ip + + return (offset) +end diff --git a/sys/fmtio/strldxs.x b/sys/fmtio/strldxs.x new file mode 100644 index 00000000..1c583d0f --- /dev/null +++ b/sys/fmtio/strldxs.x @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define BIGSET 10 +define SZ_ASCII 128 + +# STRLDXS -- Return the index of the last occurrence of any of a set of +# characters in a string. + +int procedure strldxs (set, str) + +char set[ARB] # set of characters to be searched for +char str[ARB] # string to be searched + +int setlen, ip, i, last_member +char ch, lut[SZ_ASCII] +int strlen() + +begin + setlen = strlen (set) + last_member = 0 + + if (setlen > BIGSET) { + # Encode the set in a lookup table. + call aclrc (lut, SZ_ASCII) + do i = 1, setlen + lut[set[i]] = 1 + + # Search the string. + for (ip=1; str[ip] != EOS; ip=ip+1) + if (lut[str[ip]] != 0) + last_member = ip + + } else { + # Set is too small to be worth using a lookup table. + for (ip=1; str[ip] != EOS; ip=ip+1) { + ch = str[ip] + do i = 1, setlen + if (ch == set[i]) { + last_member = ip + break + } + } + } + + return (last_member) +end diff --git a/sys/fmtio/strle.x b/sys/fmtio/strle.x new file mode 100644 index 00000000..34ad7870 --- /dev/null +++ b/sys/fmtio/strle.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# STRLE -- Is S1 <= S2. + +bool procedure strle (s1, s2) + +char s1[ARB], s2[ARB] +int ip + +begin + do ip = 1, ARB + if (s1[ip] == EOS) + return (true) + else if (s1[ip] != s2[ip]) + return (s1[ip] < s2[ip]) +end diff --git a/sys/fmtio/strlen.x b/sys/fmtio/strlen.x new file mode 100644 index 00000000..4c3e7364 --- /dev/null +++ b/sys/fmtio/strlen.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# STRLEN -- Return length of string (EOS not included). + +int procedure strlen (str) + +char str[ARB] +int ip + +begin + do ip = 1, ARB + if (str[ip] == EOS) + return (ip - 1) +end diff --git a/sys/fmtio/strlt.x b/sys/fmtio/strlt.x new file mode 100644 index 00000000..0a530d4d --- /dev/null +++ b/sys/fmtio/strlt.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# STRLT -- Is S1 < S2. + +bool procedure strlt (s1, s2) + +char s1[ARB], s2[ARB] +int ip + +begin + do ip = 1, ARB + if (s2[ip] == EOS) + return (false) + else if (s1[ip] != s2[ip]) + return (s1[ip] < s2[ip]) +end diff --git a/sys/fmtio/strlwr.x b/sys/fmtio/strlwr.x new file mode 100644 index 00000000..318366ac --- /dev/null +++ b/sys/fmtio/strlwr.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# STRLWR -- Convert string to lower case. + +procedure strlwr (a) + +char a[ARB] +int ip + +begin + do ip = 1, ARB + if (a[ip] == EOS) + break + else if (IS_UPPER(a[ip])) + a[ip] = TO_LOWER (a[ip]) +end diff --git a/sys/fmtio/strmac.x b/sys/fmtio/strmac.x new file mode 100644 index 00000000..1f3f3e98 --- /dev/null +++ b/sys/fmtio/strmac.x @@ -0,0 +1,86 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +define MAX_ARGS 9 + +.help strmac +.nf ___________________________________________________________________________ +STRMAC -- Expand a macro (nonrecursively) by string substitution. +The macro string may contain zero or more occurrences of the sequences +"$1" through "$9". The substitution strings are passed in the string +buffer "argstr", wherein successive strings are delimited by the EOS marker. +A double EOS marks the end of the list. + +Macros $1-$9 are replaced by the substitution string. The sequence $$ is +replaced by a single $. If any other character follows the $, both the $ +and the following character are passed to the output unchanged. An error +action is taken if there are insufficient arguments or if the output buffer +overflows. Bugs: null substitution strings don't work. +.endhelp ______________________________________________________________________ + +int procedure strmac (macro, argstr, outstr, maxch) + +char macro[ARB] # substitution string +char argstr[ARB] # argument strings, if any +char outstr[maxch] # output string +int maxch + +short offset[MAX_ARGS] +char ch +int i, ip, op, arg, nargs, nchars +int strlen() + +begin + # Determine the offsets of the argument strings. + ip = 1 + for (nargs=1; nargs <= MAX_ARGS; nargs=nargs+1) { + nchars = strlen (argstr[ip]) + if (nchars > 0) { + offset[nargs] = ip + ip = ip + nchars + 1 + } else + break + } + nargs = nargs - 1 + + # Expand the macro. + op = 1 + for (ip=1; macro[ip] != EOS; ip=ip+1) { + ch = macro[ip] + + if (ch == '$') { # Process $ arg sequence. + ip = ip + 1 + ch = macro[ip] + if (ch >= '1' && ch <= '9') { + arg = TO_INTEG(ch) + if (arg > nargs) + call error (1, "Strmac: too few substitution arguments") + for (i = offset[arg]; argstr[i] != EOS; i=i+1) { + outstr[op] = argstr[i] + op = op + 1 + } + + } else if (ch == '$') { # "$$" --> "$" + outstr[op] = '$' + op = op + 1 + + } else { # "$?" --> "$?" + outstr[op] = '$' + op = op + 1 + outstr[op] = ch + op = op + 1 + } + + } else { # ordinary character + outstr[op] = ch + op = op + 1 + } + + if (op > maxch) + call error (2, "Strmac: output buffer overflow") + } + + outstr[op] = EOS + return (op - 1) +end diff --git a/sys/fmtio/strmatch.x b/sys/fmtio/strmatch.x new file mode 100644 index 00000000..ad16bef8 --- /dev/null +++ b/sys/fmtio/strmatch.x @@ -0,0 +1,136 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +.help strmatch, gstrmatch +.nf ________________________________________________________________________ +STRMATCH -- Find the first occurrence of the string A in the string B. +If not found, return zero, else return the index of the first character +following the matched substring. + +GSTRMATCH -- More general version of strmatch. The indices of the +first and last characters matched are returned as arguments. The function +value is the same as for STRMATCH. + +STRMATCH recognizes the metacharacters BOL, EOL, ANY, WHITESPACE, IGNORECASE, +and MATCHCASE (BOL and EOL are special only as the first and last chars +in the pattern). The null pattern matches any string. Metacharacters +can be escaped. +.endhelp ___________________________________________________________________ + + +# STRMATCH -- Search string STR for pattern PAT. Return the index of the +# next character following the matched substring, or 0. + +int procedure strmatch (str, pat) + +char pat[ARB], str[ARB] +int first_char, last_char +int gstrmatch() + +begin + return (gstrmatch (str, pat, first_char, last_char)) +end + + +# GSTRMATCH -- Generalized string match. Returns the indices of the first and +# last characters in the matched substring if a match occurs. + +int procedure gstrmatch (str, pat, first_char, last_char) + +char pat[ARB], str[ARB] +int first_char, last_char +bool ignore_case, bolflag +char ch, pch +int i, ip, initial_pp, pp + +begin + ignore_case = false + bolflag = false + first_char = 1 + initial_pp = 1 + + if (pat[1] == CH_BOL) { # match at beginning of line? + bolflag = true + initial_pp = 2 + } + + # Try to match pattern starting at each character offset in string. + do ip = 1, ARB { + if (str[ip] == EOS) + break + i = ip + + # Compare pattern to string str[ip]. + for (pp=initial_pp; pat[pp] != EOS; pp=pp+1) { + switch (pat[pp]) { + case CH_WHITESPACE: + while (IS_WHITE (str[i])) + i = i + 1 + case CH_ANY: + if (str[i] != '\n') + i = i + 1 + case CH_IGNORECASE: + ignore_case = true + case CH_MATCHCASE: + ignore_case = false + + default: + pch = pat[pp] + if (pch == CH_ESCAPE && pat[pp+1] != EOS) { + pp = pp + 1 + pch = pat[pp] + } else if (pch == CH_EOL) + if (pat[pp+1] == EOS && (str[i]=='\n' || str[i]==EOS)) { + first_char = ip + last_char = i + if (str[i] == EOS) + last_char = last_char - 1 + return (last_char + 1) + } + + ch = str[i] + i = i + 1 + + # Compare ordinary characters. The comparison is trivial + # unless case insensitivity is required. + + if (ignore_case) { + if (IS_UPPER (ch)) { + if (IS_UPPER (pch)) { + if (pch != ch) + break + } else if (pch != TO_LOWER (ch)) + break + } else if (IS_LOWER (ch)) { + if (IS_LOWER (pch)) { + if (pch != ch) + break + } else if (pch != TO_UPPER (ch)) + break + } else { + if (pch != ch) + break + } + } else { + if (pch != ch) + break + } + } + } + + # If the above loop was exited before the end of the pattern + # was reached, the pattern did not match. + + if (pat[pp] == EOS) { + first_char = ip + last_char = i-1 + return (i) + + } else if (bolflag || str[i] == EOS) + break + } + + return (0) # no match +end diff --git a/sys/fmtio/strncmp.x b/sys/fmtio/strncmp.x new file mode 100644 index 00000000..515aeaaf --- /dev/null +++ b/sys/fmtio/strncmp.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# STRNCMP -- Compare the first N characters of two strings. A negative value +# is returned if S1 < S2, 0 if S1 == S2, and a positive value if S1 > S2. + +int procedure strncmp (s1, s2, n) + +char s1[ARB], s2[ARB] # strings to be compared +int n # number of chars to compare +int i + +begin + do i = 1, n + if (s1[i] != s2[i]) + return (s1[i] - s2[i]) + else if (s1[i] == EOS) + return (0) + + return (0) +end diff --git a/sys/fmtio/strne.x b/sys/fmtio/strne.x new file mode 100644 index 00000000..ee95d3fe --- /dev/null +++ b/sys/fmtio/strne.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# STRNE -- Compare two strings for inequality. + +bool procedure strne (s1, s2) + +char s1[ARB], s2[ARB] +int ip + +begin + do ip = 1, ARB + if (s1[ip] == EOS) + return (s2[ip] != EOS) + else if (s1[ip] != s2[ip]) + return (true) +end diff --git a/sys/fmtio/strsearch.x b/sys/fmtio/strsearch.x new file mode 100644 index 00000000..e3006ed8 --- /dev/null +++ b/sys/fmtio/strsearch.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# STRSEARCH -- Search a string for a substring. This is the simplest and +# fastest member of the pattern matching family. A significant increase in +# efficiency will result if this procedure is used to search for substrings +# that do not use any metacharacters. + +int procedure strsearch (str, patstr) + +char str[ARB] # string to be searched +char patstr[ARB] # substring to search for + +int first_char, ch +int ip, patlen +bool strse1() + +begin + # The null pattern matches any string. + if (patstr[1] == EOS) + return (1) + + first_char = patstr[1] + + do ip = 1, ARB { + ch = str[ip] + if (ch == EOS) + break + if (ch == first_char) + if (strse1 (str[ip], patstr, patlen)) + return (ip + patlen) + } + + return (0) +end + + +# STRSE1 -- Internal routine which compares a substring of the first string +# with the pattern string. STREQ cannot be used because it does not give a +# match unless the two strings have the same length. + +bool procedure strse1 (str, patstr, patlen) + +char str[ARB] +char patstr[ARB] +int patlen +int ip + +begin + do ip = 1, ARB + if (patstr[ip] == EOS || str[ip] != patstr[ip]) + break + + patlen = ip - 1 + return (patstr[ip] == EOS) +end diff --git a/sys/fmtio/strsrt.x b/sys/fmtio/strsrt.x new file mode 100644 index 00000000..67318f01 --- /dev/null +++ b/sys/fmtio/strsrt.x @@ -0,0 +1,73 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define LOGPTR 20 # log2(maxpts) (1e6) + +# STRSRT -- Sort a list of strings, given an array of indices pointing into a +# string buffer (e.g., sbuf=1 is Memc). The sort is performed by permutation +# of the index array. + +procedure strsrt (x, sb, nstr) + +int x[ARB] # array of string pointers or indices +char sb[ARB] # string buffer +int nstr # number of strings + +int i, j, k, p, temp +int lv[LOGPTR], uv[LOGPTR], pivot +define swap {temp=$1;$1=$2;$2=temp} +int strcmp() + +begin + lv[1] = 1 + uv[1] = nstr + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do-loop to trigger optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the middle of the + # subfile; move it to the end of the range so that the + # for loops below do not have to skip over it. Selecting + # a pivot near the center of the subfile helps prevent + # quadratic behavior when sorting an already sorted array. + + k = (lv[p] + uv[p]) / 2 + swap (x[j], x[k]) + pivot = x[j] + + while (i < j) { + for (i=i+1; strcmp (sb[x[i]], sb[pivot]) < 0; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (strcmp (sb[x[j]], sb[pivot]) <= 0) + break + if (i < j) # out of order pair + swap (x[i], x[j]) # interchange elements + } + + j = uv[p] # move pivot to position i + swap (x[i], x[j]) # interchange elements + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + + p = p + 1 # push onto stack + } + } +end diff --git a/sys/fmtio/strtbl.x b/sys/fmtio/strtbl.x new file mode 100644 index 00000000..7ec0205d --- /dev/null +++ b/sys/fmtio/strtbl.x @@ -0,0 +1,81 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# STRTBL -- Print a list of strings on the named file. If NCOL is zero, +# the maximum number of columns is calculated based on the maximum +# string length. If NCOL is nonzero, it is taken to be the maximum +# number of columns (the actual number may be less, depending on the +# maximum string length). FIRST_COL and LAST_COL define where on the +# page the table will be placed. + +procedure strtbl (fd, buf, strp, nstr, first_col, last_col, maxch, ncol) + +int fd # output file +char buf[ARB] # buffer containing the strings +int strp[ARB] # array of string pointers +int nstr # number of strings +int first_col, last_col # where to place table on a line +int maxch # maximum chars to print from a string +int ncol # desired number of columns (0 to autoscale) + +pointer sp, obuf, op +int row, i, j, p, nspaces, maxlen, colwidth, numcol, numrow, str +int strlen() + +begin + call smark (sp) + call salloc (obuf, last_col + 1, TY_CHAR) + + maxlen = 0 + do i = 1, nstr + maxlen = max (maxlen, strlen(buf[strp[i]])) + if (maxch > 0) + maxlen = min (maxch, maxlen) + numcol = max (1, (last_col - first_col + 1) / (maxlen + 2)) + + if (ncol > 0) + numcol = min (numcol, ncol) + colwidth = (last_col - first_col + 1) / numcol + numrow = (nstr + numcol-1) / numcol + + # For each row in the table: + do row = 1, numrow { + op = obuf + + # Space to the first column. + do i = 2, first_col { + Memc[op] = ' ' + op = op + 1 + } + + # For each string in the row: + do i = 1, numcol { + str = row + (i-1) * numrow + if (str > nstr) + next + p = strp[str] + + # Output the string. + for (j=0; buf[p+j] != EOS && j < maxlen; j=j+1) { + Memc[op] = buf[p+j] + op = op + 1 + } + + # Advance to the next column. + if (i < numcol) { + nspaces = max (2, colwidth - j) + for (j=1; j <= nspaces; j=j+1) { + Memc[op] = ' ' + op = op + 1 + } + } + } + + # Terminate this row of the table. + Memc[op] = '\n' + op = op + 1 + Memc[op] = EOS + call putline (fd, Memc[obuf]) + } + + call sfree (sp) +end diff --git a/sys/fmtio/strupr.x b/sys/fmtio/strupr.x new file mode 100644 index 00000000..6e80108c --- /dev/null +++ b/sys/fmtio/strupr.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# STRUPR -- Convert string to upper case. + +procedure strupr (str) + +char str[ARB] +int ip + +begin + do ip = 1, ARB + if (str[ip] == EOS) + return + else if (IS_LOWER (str[ip])) + str[ip] = TO_UPPER (str[ip]) +end diff --git a/sys/fmtio/tokdata.inc b/sys/fmtio/tokdata.inc new file mode 100644 index 00000000..ceb7c090 --- /dev/null +++ b/sys/fmtio/tokdata.inc @@ -0,0 +1,32 @@ +# TOKDATA.INC -- Character classes for ctotok.x. +# identifier=1, number=2, operator=3, punctuation=4, string=5, unknown=8 + +# ! " # $ % & ' ( ) * +data (class(i),i= 1,10) / 3, 5, 3, 1, 3, 3, 5, 4, 4, 3/ + +# + , - . / 0 1 2 3 4 +data (class(i),i=11,20) / 3, 4, 3, 1, 3, 1, 1, 1, 1, 1/ + +# 5 6 7 8 9 : ; < = > +data (class(i),i=21,30) / 1, 1, 1, 1, 1, 4, 4, 3, 3, 3/ + +# ? @ A B C D E F G H +data (class(i),i=31,40) / 3, 3, 1, 1, 1, 1, 1, 1, 1, 1/ + +# I J K L M N O P Q R +data (class(i),i=41,50) / 1, 1, 1, 1, 1, 1, 1, 1, 1, 1/ + +# S T U V W X Y Z [ \ +data (class(i),i=51,60) / 1, 1, 1, 1, 1, 1, 1, 1, 4, 4/ + +# ] ^ _ ` a b c d e f +data (class(i),i=61,70) / 4, 3, 1, 3, 1, 1, 1, 1, 1, 1/ + +# g h i j k l m n o p +data (class(i),i=71,80) / 1, 1, 1, 1, 1, 1, 1, 1, 1, 1/ + +# q r s t u v w x y z +data (class(i),i=81,90) / 1, 1, 1, 1, 1, 1, 1, 1, 1, 1/ + +# { | } ~ DEL +data (class(i),i=91,96) / 4, 3, 4, 3, 8, EOS/ diff --git a/sys/fmtio/xevgettok.x b/sys/fmtio/xevgettok.x new file mode 100644 index 00000000..34e6c37e --- /dev/null +++ b/sys/fmtio/xevgettok.x @@ -0,0 +1,208 @@ +include +include +include + + + +# Parse definitions. +define CONSTANT 257 +define IDENTIFIER 258 +define NEWLINE 259 +define YYEOS 260 +define PLUS 261 +define MINUS 262 +define STAR 263 +define SLASH 264 +define EXPON 265 +define CONCAT 266 +define QUEST 267 +define COLON 268 +define LT 269 +define GT 270 +define LE 271 +define EQ 272 +define NE 273 +define SE 274 +define AND 275 +define OR 276 +define NOT 277 +define AT 278 +define GE 279 +define UMINUS 280 + + +# XEV_GETTOK -- Lexical analyzer for EVEXPR. Returns the token code as the +# function value. If the token is an operand (identifier or constant) the +# operand value is returned in OUT. + +int procedure xev_gettok (ip, out) + +pointer ip # pointer into input string (expression) +pointer out # pointer to yacc YYLVAL token value operand + +char ch +long lval +double dval +pointer ip_start +int nchars, token, junk +int stridx(), lexnum(), gctod(), gctol() +define ident_ 91 + +begin + while (IS_WHITE(Memc[ip])) + ip = ip + 1 + + ch = Memc[ip] + switch (ch) { + case 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'J', 'K', 'L', 'M', + 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', + 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', + 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z': + + # Return an identifier. +ident_ + ip_start = ip + while (IS_ALNUM(ch) || stridx (ch, "_.$@#%&;[]\\^{}~") > 0) { + ip = ip + 1 + ch = Memc[ip] + } + + nchars = ip - ip_start + call xev_initop (out, nchars, TY_CHAR) + call strcpy (Memc[ip_start], O_VALC(out), nchars) + + return (IDENTIFIER) + + case 'I', '.', '0', '1', '2', '3', '4', '5', '6', '7', '8', '9': + # Return a numeric constant. The character I vectors here so + # that we can check for INDEF, a legal number. + + token = lexnum (Memc, ip, nchars) + switch (token) { + case LEX_OCTAL: + junk = gctol (Memc, ip, lval, 8) + call xev_initop (out, 0, TY_INT) + O_VALI(out) = lval + case LEX_DECIMAL: + junk = gctol (Memc, ip, lval, 10) + call xev_initop (out, 0, TY_INT) + O_VALI(out) = lval + case LEX_HEX: + junk = gctol (Memc, ip, lval, 16) + call xev_initop (out, 0, TY_INT) + O_VALI(out) = lval + case LEX_REAL: + junk = gctod (Memc, ip, dval) + call xev_initop (out, 0, TY_REAL) + if (IS_INDEFD (dval)) + O_VALR(out) = INDEFR + else + O_VALR(out) = dval + default: + goto ident_ + } + + return (CONSTANT) + + case '\'', '"': + # Return a string constant. + + ip_start = ip + 1 + for (ip=ip+1; Memc[ip] != ch && Memc[ip] != EOS; ip=ip+1) + ; + + nchars = ip - ip_start + if (Memc[ip] == EOS) + call xev_error ("missing closing quote in string constant") + else + ip = ip + 1 + + call xev_initop (out, nchars, TY_CHAR) + call strcpy (Memc[ip_start], O_VALC(out), nchars) + + return (CONSTANT) + + case '+': + token = PLUS + case '-': + token = MINUS + case '*': + if (Memc[ip+1] == '*') { + ip = ip + 1 + token = EXPON + } else + token = STAR + case '/': + if (Memc[ip+1] == '/') { + ip = ip + 1 + token = CONCAT + } else + token = SLASH + + case '?': + if (Memc[ip+1] == '=') { + ip = ip + 1 + token = SE + } else + token = QUEST + + case ':': + token = COLON + + case '@': + token = AT + + case '<': + if (Memc[ip+1] == '=') { + ip = ip + 1 + token = LE + } else + token = LT + case '>': + if (Memc[ip+1] == '=') { + ip = ip + 1 + token = GE + } else + token = GT + case '!': + if (Memc[ip+1] == '=') { + ip = ip + 1 + token = NE + } else + token = NOT + case '=': + if (Memc[ip+1] == '=') { + ip = ip + 1 + token = EQ + } else + token = EQ + case '&': + if (Memc[ip+1] == '&') { + ip = ip + 1 + token = AND + } else + token = AND + case '|': + if (Memc[ip+1] == '|') { + ip = ip + 1 + token = OR + } else + token = OR + + case '(', ')', ',': + token = ch + + default: + if (ch == '\n') + token = NEWLINE + else if (ch == EOS) + token = YYEOS + else { + # Anything we don't understand is assumed to be an identifier. + goto ident_ + } + } + + ip = ip + 1 + return (token) +end diff --git a/sys/fmtio/xtoc.x b/sys/fmtio/xtoc.x new file mode 100644 index 00000000..8315b4cd --- /dev/null +++ b/sys/fmtio/xtoc.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# XTOC -- Encode a complex number as a character string in a field width of +# at most WIDTH characters. + +int procedure xtoc (xval, outstr, maxch, decpl, fmt, width) + +complex xval # value to be formatted +char outstr[ARB] # output string +int fmt # format encoding (f,e,etc.) +int maxch # max chars out +int decpl # precision +int width # field width + +int op, dtoc() +double real_part, imag_part +define output {outstr[op]=$1;op=op+1;if(op>maxch)goto overflow_} +define overflow_ 91 + +begin + if (IS_INDEFX (xval)) { + real_part = INDEFD + imag_part = INDEFD + } else { + real_part = real (xval) + imag_part = aimag (xval) + } + + op = 1 + output ('(') + op = op + dtoc (real_part, outstr[op], maxch-op+1, decpl, fmt, width) + output (',') + op = op + dtoc (imag_part, outstr[op], maxch-op+1, decpl, fmt, width) + output (')') + +overflow_ + outstr[op] = EOS + return (op-1) +end diff --git a/sys/fmtio/xvvgettok.x b/sys/fmtio/xvvgettok.x new file mode 100644 index 00000000..f2a05977 --- /dev/null +++ b/sys/fmtio/xvvgettok.x @@ -0,0 +1,234 @@ +include +include +include +include +include + + +# Parser definitions. +define CONSTANT 257 +define IDENTIFIER 258 +define NEWLINE 259 +define YYEOS 260 +define PLUS 261 +define MINUS 262 +define STAR 263 +define SLASH 264 +define EXPON 265 +define CONCAT 266 +define QUEST 267 +define COLON 268 +define LT 269 +define GT 270 +define LE 271 +define EQ 272 +define NE 273 +define SE 274 +define LAND 275 +define LOR 276 +define LNOT 277 +define BAND 278 +define BOR 279 +define BXOR 280 +define BNOT 281 +define AT 282 +define GE 283 +define UMINUS 284 + + +# XVV_GETTOK -- Lexical analyzer for EVVEXPR. Returns the token code as the +# function value. If the token is an operand (identifier or constant) the +# operand value is returned in OUT. + +int procedure xvv_gettok (ip, out) + +pointer ip #I pointer into input string (expression) +pointer out #I pointer to yacc YYLVAL token value operand + +char ch +long lval +double dval +pointer ip_start +char numbuf[MAX_DIGITS] +int nchars, token, junk, dtype +int stridx(), stridxs(), lexnum(), gctod(), gctol() +define ident_ 91 + +begin + while (IS_WHITE(Memc[ip])) + ip = ip + 1 + + ch = Memc[ip] + switch (ch) { + case 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'J', 'K', 'L', 'M', + 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', + 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', + 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z': + + # Return an identifier. +ident_ + ip_start = ip + while (IS_ALNUM(ch) || stridx (ch, "_.$@#%&;[]\\^{}~") > 0) { + ip = ip + 1 + ch = Memc[ip] + } + + nchars = ip - ip_start + call xvv_initop (out, nchars, TY_CHAR) + call strcpy (Memc[ip_start], O_VALC(out), nchars) + + return (IDENTIFIER) + + case 'I', '.', '0', '1', '2', '3', '4', '5', '6', '7', '8', '9': + # Return a numeric constant. The character I vectors here so + # that we can check for INDEF, a legal number. + + token = lexnum (Memc, ip, nchars) + switch (token) { + case LEX_OCTAL: + junk = gctol (Memc, ip, lval, 8) + call xvv_initop (out, 0, TY_INT) + O_VALI(out) = lval + case LEX_DECIMAL: + junk = gctol (Memc, ip, lval, 10) + call xvv_initop (out, 0, TY_INT) + O_VALI(out) = lval + case LEX_HEX: + junk = gctol (Memc, ip, lval, 16) + call xvv_initop (out, 0, TY_INT) + O_VALI(out) = lval + + case LEX_REAL: + ip_start = ip + nchars = gctod (Memc, ip, dval) + call strcpy (Memc[ip], numbuf, min(nchars,MAX_DIGITS)) + + dtype = TY_REAL + if (stridxs ("dD", numbuf) > 0 || nchars > NDIGITS_RP+3) + dtype = TY_DOUBLE + + call xvv_initop (out, 0, dtype) + if (dtype == TY_REAL) { + if (IS_INDEFD (dval)) + O_VALR(out) = INDEFR + else + O_VALR(out) = dval + } else { + if (IS_INDEFD (dval)) + O_VALD(out) = INDEFD + else + O_VALD(out) = dval + } + default: + goto ident_ + } + + return (CONSTANT) + + case '\'', '"': + # Return a string constant. + + ip_start = ip + 1 + for (ip=ip+1; Memc[ip] != ch && Memc[ip] != EOS; ip=ip+1) + ; + + nchars = ip - ip_start + if (Memc[ip] == EOS) + call xvv_error ("missing closing quote in string constant") + else + ip = ip + 1 + + call xvv_initop (out, nchars, TY_CHAR) + call strcpy (Memc[ip_start], O_VALC(out), nchars) + + return (CONSTANT) + + case '+': + token = PLUS + case '-': + token = MINUS + case '*': + if (Memc[ip+1] == '*') { + ip = ip + 1 + token = EXPON + } else + token = STAR + case '/': + if (Memc[ip+1] == '/') { + ip = ip + 1 + token = CONCAT + } else + token = SLASH + + case '?': + if (Memc[ip+1] == '=') { + ip = ip + 1 + token = SE + } else + token = QUEST + + case ':': + token = COLON + + case '@': + token = AT + + case '<': + if (Memc[ip+1] == '=') { + ip = ip + 1 + token = LE + } else + token = LT + case '>': + if (Memc[ip+1] == '=') { + ip = ip + 1 + token = GE + } else + token = GT + case '!': + if (Memc[ip+1] == '=') { + ip = ip + 1 + token = NE + } else + token = LNOT + case '=': + if (Memc[ip+1] == '=') { + ip = ip + 1 + token = EQ + } else + token = EQ + case '&': + if (Memc[ip+1] == '&') { + ip = ip + 1 + token = LAND + } else + token = BAND + case '|': + if (Memc[ip+1] == '|') { + ip = ip + 1 + token = LOR + } else + token = BOR + + case '^': + token = BXOR + case '~': + token = BNOT + + case '(', ')', ',': + token = ch + + default: + if (ch == '\n') + token = NEWLINE + else if (ch == EOS) + token = YYEOS + else { + # Anything we don't understand is assumed to be an identifier. + goto ident_ + } + } + + ip = ip + 1 + return (token) +end diff --git a/sys/fmtio/zzdebug.x b/sys/fmtio/zzdebug.x new file mode 100644 index 00000000..3729a1ff --- /dev/null +++ b/sys/fmtio/zzdebug.x @@ -0,0 +1,319 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +task ev = t_ev, + lex = t_lex, + eq = t_eq, + ne = t_ne, + lt = t_lt, + le = t_le, + gt = t_gt, + ge = t_ge, + cmp = t_cmp, + ncmp = t_ncmp, + mat = t_mat, + srch = t_srch, + ctowrd = t_ctowrd + + +# EV -- Text EVEXPR. + +procedure t_ev + +char expr[SZ_LINE] +pointer o, evexpr() +int clglstr() + +begin + while (clglstr ("expr", expr, SZ_LINE) != EOF) { + o = evexpr (expr, 0, 0) + + switch (O_TYPE(o)) { + case TY_BOOL: + call printf ("%b = %s\n") + call pargb (O_VALB(o)) + call pargstr (expr) + + case TY_CHAR: + call printf ("%s = %s\n") + call pargstr (O_VALC(o)) + call pargstr (expr) + + case TY_INT: + call printf ("%d = %s\n") + call pargi (O_VALI(o)) + call pargstr (expr) + + case TY_REAL: + call printf ("%g = %s\n") + call pargr (O_VALR(o)) + call pargstr (expr) + + default: + call error (1, "expression datatype unknown") + } + } + + call printf ("\n") +end + + +# LEX -- Test LEXNUM. + +procedure t_lex() + +int ip, nchars, toktype +char token[SZ_FNAME] +int lexnum(), strlen() + +begin + repeat { + call clgstr ("token", token, SZ_FNAME) + if (strlen (token) == 0) + break + + ip = 1 + toktype = lexnum (token, ip, nchars) + + call printf ("tokchars=%d, type = %s\n") + call pargi (nchars) + + switch (toktype) { + case LEX_OCTAL: + call pargstr ("octal") + case LEX_DECIMAL: + call pargstr ("decimal") + case LEX_HEX: + call pargstr ("hex") + case LEX_REAL: + call pargstr ("real") + case LEX_NONNUM: + call pargstr ("nonnumeric") + default: + call pargstr ("unknown") + } + } +end + + +# EQ -- Test string equals. + +procedure t_eq() + +char s1[SZ_FNAME], s2[SZ_FNAME] +bool streq() + +begin + repeat { + call clgstr ("s1", s1, SZ_FNAME) + call clgstr ("s2", s2, SZ_FNAME) + call printf ("%s == %s: %b\n") + call pargstr (s1) + call pargstr (s2) + call pargb (streq (s1, s2)) + call flush (STDOUT) + } +end + + +# NE -- Test string not equals. + +procedure t_ne() + +char s1[SZ_FNAME], s2[SZ_FNAME] +bool strne() + +begin + repeat { + call clgstr ("s1", s1, SZ_FNAME) + call clgstr ("s2", s2, SZ_FNAME) + call printf ("%s != %s: %b\n") + call pargstr (s1) + call pargstr (s2) + call pargb (strne (s1, s2)) + call flush (STDOUT) + } +end + + +# LT -- Test string less than. + +procedure t_lt() + +char s1[SZ_FNAME], s2[SZ_FNAME] +bool strlt() + +begin + repeat { + call clgstr ("s1", s1, SZ_FNAME) + call clgstr ("s2", s2, SZ_FNAME) + call printf ("%s < %s: %b\n") + call pargstr (s1) + call pargstr (s2) + call pargb (strlt (s1, s2)) + call flush (STDOUT) + } +end + + +# LE -- Test string less than or equals. + +procedure t_le() + +char s1[SZ_FNAME], s2[SZ_FNAME] +bool strle() + +begin + repeat { + call clgstr ("s1", s1, SZ_FNAME) + call clgstr ("s2", s2, SZ_FNAME) + call printf ("%s <= %s: %b\n") + call pargstr (s1) + call pargstr (s2) + call pargb (strle (s1, s2)) + call flush (STDOUT) + } +end + + +# GT -- Test string greater than. + +procedure t_gt() + +char s1[SZ_FNAME], s2[SZ_FNAME] +bool strgt() + +begin + repeat { + call clgstr ("s1", s1, SZ_FNAME) + call clgstr ("s2", s2, SZ_FNAME) + call printf ("%s > %s: %b\n") + call pargstr (s1) + call pargstr (s2) + call pargb (strgt (s1, s2)) + call flush (STDOUT) + } +end + + +# GE -- Test string greater than or equals. + +procedure t_ge() + +char s1[SZ_FNAME], s2[SZ_FNAME] +bool strge() + +begin + repeat { + call clgstr ("s1", s1, SZ_FNAME) + call clgstr ("s2", s2, SZ_FNAME) + call printf ("%s >= %s: %b\n") + call pargstr (s1) + call pargstr (s2) + call pargb (strge (s1, s2)) + call flush (STDOUT) + } +end + + +# CMP -- Test string compare. + +procedure t_cmp() + +char s1[SZ_FNAME], s2[SZ_FNAME] +int strcmp() + +begin + repeat { + call clgstr ("s1", s1, SZ_FNAME) + call clgstr ("s2", s2, SZ_FNAME) + call printf ("compare %s, %s: %d\n") + call pargstr (s1) + call pargstr (s2) + call pargi (strcmp (s1, s2)) + call flush (STDOUT) + } +end + + +# NCMP -- Test counted string compare. + +procedure t_ncmp() + +char s1[SZ_FNAME], s2[SZ_FNAME] +int strncmp(), clgeti() + +begin + repeat { + call clgstr ("s1", s1, SZ_FNAME) + call clgstr ("s2", s2, SZ_FNAME) + call printf ("compare %s, %s: %d\n") + call pargstr (s1) + call pargstr (s2) + call pargi (strncmp (s1, s2, clgeti("nchars"))) + call flush (STDOUT) + } +end + + +# MAT -- Test string match. + +procedure t_mat() + +char s1[SZ_FNAME], pat[SZ_FNAME] +int strmatch() + +begin + repeat { + call clgstr ("s1", s1, SZ_FNAME) + call clgstr ("pat", pat, SZ_FNAME) + call printf ("match %s, pat=%s: %d\n") + call pargstr (s1) + call pargstr (pat) + call pargi (strmatch (s1, pat)) + call flush (STDOUT) + } +end + + +# SRCH -- Test string search. + +procedure t_srch() + +char s1[SZ_FNAME], pat[SZ_FNAME] +int strsearch() + +begin + repeat { + call clgstr ("s1", s1, SZ_FNAME) + call clgstr ("pat", pat, SZ_FNAME) + call printf ("search %s, pat=%s: %d\n") + call pargstr (s1) + call pargstr (pat) + call pargi (strsearch (s1, pat)) + call flush (STDOUT) + } +end + + +# CTOWRD -- Test ctowrd. + +procedure t_ctowrd() + +char buf1[SZ_LINE], buf2[SZ_LINE] +int n, ip, ctowrd(), getline() + +begin + while (getline (STDIN, buf1) != EOF) { + ip = 1 + repeat { + buf2[1] = EOS + n = ctowrd (buf1, ip, buf2, SZ_LINE) + call printf ("n=%d, token=%s\n") + call pargi (n) + call pargstr (buf2) + } until (n <= 0) + } +end diff --git a/sys/gio/README b/sys/gio/README new file mode 100644 index 00000000..e7db4cdd --- /dev/null +++ b/sys/gio/README @@ -0,0 +1,6 @@ +GIO + + This directory contains the source for the IRAF GIO (graphics i/o) +interface. The interface is documented in the file "Gio.hlp". Source for +the STDGRAPH kernel will be found in the subdirectory "stdgraph". Source +for the NSPP kernel will be found in the subdirectory "nspp". diff --git a/sys/gio/aelogd.x b/sys/gio/aelogd.x new file mode 100644 index 00000000..0a3d3b26 --- /dev/null +++ b/sys/gio/aelogd.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AELOGD -- Inverse of the elogd function. + +double procedure aelogd (x) + +double x + +begin + if (x > 1.0D0) + return (10.0D0 ** x) + else if (x >= -1.0D0) + return (x * 10.0D0) + else + return (- (10.0D0 ** (-x))) +end diff --git a/sys/gio/aelogr.x b/sys/gio/aelogr.x new file mode 100644 index 00000000..81920a9a --- /dev/null +++ b/sys/gio/aelogr.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AELOGR -- Inverse of the elogr function. + +real procedure aelogr (x) + +real x + +begin + if (x > 1.0) + return (10.0 ** x) + else if (x >= -1.0) + return (x * 10.0) + else + return (-(10.0 ** (-x))) +end diff --git a/sys/gio/calcomp/README b/sys/gio/calcomp/README new file mode 100644 index 00000000..c3dd017f --- /dev/null +++ b/sys/gio/calcomp/README @@ -0,0 +1,34 @@ +GIO Calcomp kernel + +This directory contains source for the IRAF calcomp graphics kernel. +Specifications may be found in ccpspecs.hlp. Installation involves +building the kernel task, which is accomplished using "make" (Makefile) +with argument "install" to move the executable into lib$. + +In addition to the kernel task routines, the vttest.x routine contains code +to simulate calcomp software on standard gio graphics devices. vttest.x +contains all the source for the simulation, using parameter file vttest.par. +Here, the calcomp routines "plot", "plots", "newpen", and "symbol" are +replaced with appropriate gio calls (violating interfaces) and to be used +mainly for testing text fonts, line type and width simulation. + +TODO: + +- super-bold font +- bold + italic + +- multiples of dash, dot for linetypes numbered higher than 4 + +-------------------------------------------------------------------------------- +FUTURE ENHANCEMENTS (much work): + +1) Sophisticated parallel-tracing algorithm that looks at entire array + and merges intersections so that all adjacent segments are parallel + to each other and do not cross the acute bisector. Implemented by + parallel array segments rather than drawing each parallel segment + individually, to avoid pen overtravel on short choppy lines. + +2) Panelling: when plot width exceeds available paper width, wrap graphics + to beyond maximum x so that paper can be cut and pasted. + +3) Versatec extension with area-fill. diff --git a/sys/gio/calcomp/ccp.com b/sys/gio/calcomp/ccp.com new file mode 100644 index 00000000..d9e9ac69 --- /dev/null +++ b/sys/gio/calcomp/ccp.com @@ -0,0 +1,38 @@ +# CCP common. A common is necessary since there is no graphics descriptor +# in the argument list of the kernel procedures. The kernel data structures +# are designed along the lines of FIO: a small common is used to hold the time +# critical data elements, and an auxiliary dynamically allocated descriptor is +# used for everything else. + +pointer g_cc # kernel graphics descriptor +pointer g_tty # graphcap descriptor +int g_nframes # number of frames written +int g_maxframes # max frames per device metafile +int g_ndraw # no draw instr. in current frame +int g_in # input file +real g_xres # x resolution of plotter +real g_yres # y resolution of plotter +real g_max_x # maximum x drawn, in plotter units +real g_xndcto_p # x(pltr) = GKI*g_xndcto_p; final scale +real g_yndcto_p # y(pltr) = GKI*g_yndcto_p; final scale +real g_xtask_scale # x scale determined from task params +real g_ytask_scale # y scale determined from task params +real g_xdefault_scale # x scale from graphcap or compile-time +real g_ydefault_scale # y scale from graphcap or compile-time +int g_ltype # line type +real g_dashlen # length of dash in dashed line, p_units +real g_gaplen # width of gap in dash/dot line, p_units +real g_plwsep # polyline width separation for ntracing +int g_txquality # text quality parameter +bool g_ltover # user override of line-type generator +bool g_lwover # user override of line width simulation +bool g_lcover # user override of line color generator +char g_lwtype # line width mode parameter +char g_device[SZ_GDEVICE] # force output to named device + +common /ccpcom/ g_cc, g_tty, g_nframes, g_maxframes, g_ndraw, + g_in, g_xres, g_yres, g_max_x, g_xndcto_p, g_yndcto_p, + g_xtask_scale, g_ytask_scale, + g_xdefault_scale, g_ydefault_scale, + g_ltype, g_dashlen, g_gaplen, g_plwsep, g_txquality, + g_ltover, g_lwover, g_lcover, g_lwtype, g_device diff --git a/sys/gio/calcomp/ccp.h b/sys/gio/calcomp/ccp.h new file mode 100644 index 00000000..037dbc6a --- /dev/null +++ b/sys/gio/calcomp/ccp.h @@ -0,0 +1,92 @@ +# CCP definitions. + +define MAX_CHARSIZES 10 # max discreet device char sizes +define SZ_SBUF 1024 # initial string buffer size +define SZ_GDEVICE 31 # maxsize forced device name +define CCP_LDEV 5 # device for "plots(0,0,ldev") +define CCP_UP 3 # "pen-up" code +define CCP_DOWN 2 # "pen-down" code +define PL_SINGLE 1 # rel width of single-width line +define MAXTRACES 15 # maximum adjacent bold traces +define SEGSIZE 256 # segment buffer size +define XSEG Memr[xseg + $1 - 1] # segment buffer for ccp_calcseg +define YSEG Memr[yseg + $1 - 1] # " +define DIS sqrt ((($3)-($1))**2+(($4)-($2))**2) #dis (x1,y1, x2,y2) +define XTRAN ($1) * g_xndcto_p # convert NDC to plotter coords +define YTRAN ($1) * g_yndcto_p # " +define FRAME_OFFSET 1.0 # pltr units between [new]frames +define MAX_PL_XWIDTH 0.3307 # max pltr x (m) if no graphcap +define MAX_PL_YHEIGHT 0.2540 # max pltr y (m) if no graphcap +define DEF_MPER_PUNIT 0.0254 # default meters / plotter unit +define DEF_DASHLEN 0.1000 # default dash length, pltr unit +define DEF_GAPLEN 0.0500 # default gap length, pltr units +define DEF_PLWSEP 0.0050 # default ntracing sep. in pu + +# CCP state device descriptor: + +define LEN_CCP 81 + +define CCP_SBUF Memi[$1] # string buffer +define CCP_SZSBUF Memi[$1+1] # size of string buffer +define CCP_NEXTCH Memi[$1+2] # next char pos in string buf +define CCP_NCHARSIZES Memi[$1+3] # number of character sizes +define CCP_POLYLINE Memi[$1+4] # device supports polyline +define CCP_POLYMARKER Memi[$1+5] # device supports polymarker +define CCP_FILLAREA Memi[$1+6] # device supports fillarea +define CCP_CELLARRAY Memi[$1+7] # device supports cell array +define CCP_ZRES Memi[$1+8] # device resolution in Z +define CCP_FILLSTYLE Memi[$1+9] # number of fill styles +define CCP_ROAM Memi[$1+10] # device supports roam +define CCP_ZOOM Memi[$1+11] # device supports zoom +define CCP_SELERASE Memi[$1+12] # device has selective erase +define CCP_PIXREP Memi[$1+13] # device supports pixel replic. +define CCP_STARTFRAME Memi[$1+14] # frame advance at metafile BOF +define CCP_ENDFRAME Memi[$1+15] # frame advance at metafile EOF + # extra space +define CCP_CURSOR Memi[$1+20] # last cursor accessed +define CCP_COLOR Memi[$1+21] # last color set +define CCP_TXSIZE Memi[$1+22] # last text size set +define CCP_TXFONT Memi[$1+23] # last text font set +define CCP_LTYPE Memi[$1+24] # last line type set +define CCP_WIDTH Memi[$1+25] # last line width set +define CCP_DEVNAME Memi[$1+26] # name of open device +define CCP_DEVCHAN Memi[$1+27] # channel for "plots(0,0,ldev)" + # extra space +define CCP_CHARHEIGHT Memi[$1+30+$2-1] # character height +define CCP_CHARWIDTH Memi[$1+40+$2-1] # character width +define CCP_CHARSIZE Memr[P2R($1+50+$2-1)] # text sizes permitted +define CCP_PLAP ($1+60) # polyline attributes +define CCP_PMAP ($1+64) # polymarker attributes +define CCP_FAAP ($1+68) # fill area attributes +define CCP_TXAP ($1+71) # default text attributes + +# Substructure definitions. + +define LEN_PL 4 +define PL_STATE Memi[$1] # polyline attributes +define PL_LTYPE Memi[$1+1] +define PL_WIDTH Memi[$1+2] +define PL_COLOR Memi[$1+3] + +define LEN_PM 4 +define PM_STATE Memi[$1] # polymarker attributes +define PM_LTYPE Memi[$1+1] +define PM_WIDTH Memi[$1+2] +define PM_COLOR Memi[$1+3] + +define LEN_FA 3 # fill area attributes +define FA_STATE Memi[$1] +define FA_STYLE Memi[$1+1] +define FA_COLOR Memi[$1+2] + +define LEN_TX 10 # text attributes +define TX_STATE Memi[$1] +define TX_UP Memi[$1+1] +define TX_SIZE Memi[$1+2] +define TX_PATH Memi[$1+3] +define TX_SPACING Memr[P2R($1+4)] +define TX_HJUSTIFY Memi[$1+5] +define TX_VJUSTIFY Memi[$1+6] +define TX_FONT Memi[$1+7] +define TX_QUALITY Memi[$1+8] +define TX_COLOR Memi[$1+9] diff --git a/sys/gio/calcomp/ccpclear.x b/sys/gio/calcomp/ccpclear.x new file mode 100644 index 00000000..9ff17c20 --- /dev/null +++ b/sys/gio/calcomp/ccpclear.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ccp.h" + +# CCP_CLEAR -- Advance a frame on the plotter. All attribute packets are +# initialized to their default values. Redundant calls or calls immediately +# after a workstation open (before anything has been drawn) are ignored. + +procedure ccp_clear (dummy) + +int dummy # not used at present +include "ccp.com" + +begin + # This is a no-op if nothing has been drawn. + if (g_cc == NULL || g_ndraw == 0) + return + + # Start a new frame. This is by resetting the origin to the last + # x-position drawn plus a compile-time offset. + + call plot (g_max_x + FRAME_OFFSET, 0.0, -3) + g_max_x = 0.0 + + # Init kernel data structures. + call ccp_reset() + g_ndraw = 0 +end diff --git a/sys/gio/calcomp/ccpclose.x b/sys/gio/calcomp/ccpclose.x new file mode 100644 index 00000000..3d433eb0 --- /dev/null +++ b/sys/gio/calcomp/ccpclose.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "ccp.h" + +# CCP_CLOSE -- Close the calcomp kernel. Free up storage. + +procedure ccp_close() + +include "ccp.com" + +begin + # Signal end of plot. + call plot (0, 0, 999) + # call plots (0, 0, CCP_DEVCHAN(g_cc)) #do we really want to do this? + # (calcomp may get into funny state without, but may mess up APPEND + + # Free kernel data structures. + call mfree (CCP_SBUF(g_cc), TY_CHAR) + call mfree (g_cc, TY_STRUCT) + + g_cc = NULL +end diff --git a/sys/gio/calcomp/ccpclws.x b/sys/gio/calcomp/ccpclws.x new file mode 100644 index 00000000..f536d7ab --- /dev/null +++ b/sys/gio/calcomp/ccpclws.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# include "ccp.h" + +# CCP_CLOSEWS -- Close the named workstation. +# If the plot were terminated (plot (0, 0, 999)) APPEND mode would not work. + +procedure ccp_closews (devname, n) + +short devname[ARB] # device name (not used) +int n # length of device name +# include "ccp.com" + +begin + # noop + return +end diff --git a/sys/gio/calcomp/ccpcolor.x b/sys/gio/calcomp/ccpcolor.x new file mode 100644 index 00000000..98b701d0 --- /dev/null +++ b/sys/gio/calcomp/ccpcolor.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "ccp.h" + +# Calcomp pen colors +define BLACK 1 +define WHITE 2 +define RED 3 +define GREEN 4 +define BLUE 5 + +# CCP_COLOR set pen color + +procedure ccp_color(index) + +int index # index for color switch statement +include "ccp.com" + +begin + if (g_lcover) # CL param lcover, line color override is on; noop + return + + switch (index) { + + case WHITE: + call newpen (WHITE) + case RED: + call newpen (RED) + case GREEN: + call newpen (GREEN) + case BLUE: + call newpen (BLUE) + default: + call newpen (BLACK) + } +end diff --git a/sys/gio/calcomp/ccpcseg.x b/sys/gio/calcomp/ccpcseg.x new file mode 100644 index 00000000..7b55adc7 --- /dev/null +++ b/sys/gio/calcomp/ccpcseg.x @@ -0,0 +1,207 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "ccp.h" + +# CCP_CALCSEG -- Calculate a contiguous line segment; used to return individual +# line segments under the various options of line type simulation. (Width is +# not simulated here). Each segment returned is actually drawable, guaranteeing +# constant-length dashes and gaps along the exact length of the input polyline. +# Normally called by ccp_polyline. + +procedure ccp_calcseg (p, npts, ltype, curpl_pt, segsize, xseg,yseg, nsegpts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs +int ltype # line type; CCP_CLEAR <= ltype <= CCP_DASHDOT +int curpl_pt # current polyline point; input and output +int segsize # current segment memory size +pointer xseg,yseg # plotter-unit contiguous line segment, output +int nsegpts # number of points in segment, output + +int i, j +real lastp_x, lastp_y, x, y, curseglen +bool toggle + +include "ccp.com" + +begin + if (curpl_pt == 1) { # always start line w/beginning of dash, etc. + lastp_x = XTRAN(p[1]) + lastp_y = YTRAN(p[2]) + curpl_pt = curpl_pt + 1 + toggle = false + } + + XSEG(1) = lastp_x + YSEG(1) = lastp_y + nsegpts = 1 + curseglen = 0.0 + + switch (ltype) { + case GL_CLEAR: + nsegpts = 0 + + case GL_DASHED: + # Return one contiguous polyline segment worth one dash: + call ccx_dash (p, npts, curpl_pt, curseglen, nsegpts, segsize, + xseg,yseg, lastp_x,lastp_y) + + # Now increment internal counters for gap width for next call + call ccx_gap (p, npts, curpl_pt, curseglen, g_dashlen + g_gaplen, + lastp_x,lastp_y) + + case GL_DOTTED: + # Since we already built one point, we need only the following gap: + call ccx_gap (p, npts, curpl_pt, curseglen, g_gaplen, + lastp_x,lastp_y) + + case GL_DOTDASH: + # Implement as dash/gap/dot/gap/: + if (toggle) { # build dot/gap/ + x = lastp_x #XTRAN(p[i]) + y = lastp_y #YTRAN(p[i+1]) + nsegpts = 0 + call ccx_addsegpt (x,y, xseg,yseg, nsegpts, segsize) + toggle = false + call ccx_gap (p, npts, curpl_pt, curseglen, g_gaplen, + lastp_x,lastp_y) + + } else { # build dash/gap/ + call ccx_dash (p, npts, curpl_pt, curseglen, nsegpts, + segsize, xseg,yseg, lastp_x,lastp_y) + call ccx_gap (p, npts, curpl_pt, curseglen, + g_dashlen + g_gaplen, lastp_x,lastp_y) + toggle = true + } + + default: # solid line + do i = curpl_pt, npts { + j = (i-1) * 2 + 1 + x = XTRAN(p[j]) + y = YTRAN(p[j+1]) + call ccx_addsegpt (x,y, xseg,yseg, nsegpts, segsize) + } + curpl_pt = npts + } +end + + +# CCX_DASH -- Do the actual work of building a dashed line segment (no gap) + +procedure ccx_dash (p, npts, curpl_pt, curseglen, cursegpt, segsize, + xseg,yseg, lastp_x,lastp_y) + +short p[ARB] # Input: points defining line +int npts # Input: number of points, i.e., (x,y) pairs +int curpl_pt # In/Output: current polyline point +real curseglen # Output: length of current simulated ltype unit (._) +int cursegpt # Output: index of current drawable point in segment +int segsize # In/Output: current segment size +pointer xseg,yseg # Output: plotter-units, contiguous line segment +real lastp_x,lastp_y # Output: last point in segment (visible or invisible) + +int i +real temppl_dis, x, y, delx, dely +real actual_dis, rem_dashlen + +include "ccp.com" + +begin + rem_dashlen = g_dashlen + + # Build up current "dash" (may be bent any number of times). + + while (curseglen + EPSILON < g_dashlen && curpl_pt <= npts) { + i = (curpl_pt-1) * 2 + 1 + x = XTRAN(p[i]) + y = YTRAN(p[i+1]) + temppl_dis = DIS(lastp_x, lastp_y, x, y) + if (temppl_dis >= EPSILON) { + actual_dis = min (temppl_dis, rem_dashlen) + rem_dashlen = rem_dashlen - actual_dis + + delx = x - lastp_x + dely = y - lastp_y + x = lastp_x + delx * actual_dis / temppl_dis + y = lastp_y + dely * actual_dis / temppl_dis + + call ccx_addsegpt (x,y, xseg,yseg, cursegpt, segsize) + curseglen = curseglen + actual_dis + lastp_x = XSEG(cursegpt) + lastp_y = YSEG(cursegpt) + } + if (curseglen + EPSILON < g_dashlen) + curpl_pt = curpl_pt + 1 + } +end + + +# CCX_GAP -- Do the actual work of building an invisible gap along original +# polyline. + +procedure ccx_gap (p, npts, curpl_pt, curseglen, matchlen, lastp_x,lastp_y) + +short p[ARB] # Input: points defining line +int npts # Input: number of points, i.e., (x,y) pairs +int curpl_pt # In/Output: current polyline point +real curseglen # In/Output: length of current simulated ltype unit (._) +real matchlen # Output: length to build curseglen up to +real lastp_x,lastp_y # Output: last point in segment (visible, invisible) + +int i +real x, y, delx, dely +real temppl_dis, actual_dis, rem_gaplen + +include "ccp.com" + +begin + rem_gaplen = g_gaplen + + # Build up current "gap" (may be bent any number of times). + + while ((curseglen + EPSILON < (matchlen)) && (curpl_pt <= npts)) { + i = (curpl_pt-1) * 2 + 1 + x = XTRAN(p[i]) + y = YTRAN(p[i+1]) + + temppl_dis = DIS(lastp_x, lastp_y, x, y) + if (temppl_dis >= EPSILON) { + actual_dis = min (temppl_dis, rem_gaplen) + rem_gaplen = rem_gaplen - actual_dis + + delx = x - lastp_x + dely = y - lastp_y + curseglen = curseglen + actual_dis + lastp_x = lastp_x + delx * actual_dis / temppl_dis + lastp_y = lastp_y + dely * actual_dis / temppl_dis + } + if (curseglen + EPSILON < matchlen) + curpl_pt = curpl_pt + 1 + } +end + + +# CCX_ADDSEGPT -- add a point to the segment structure; handle memory needs + +procedure ccx_addsegpt (x,y, xseg,yseg, cursegpt,segsize) + +real x,y # point to be added to output segment +pointer xseg,yseg # NDC-coord contiguous line segment, output +int cursegpt # index of current drawable point in segment +int segsize # current segment size + +begin + cursegpt = cursegpt + 1 + + if (cursegpt > segsize) { + segsize = segsize + SEGSIZE + call realloc (xseg, segsize, TY_REAL) + call realloc (yseg, segsize, TY_REAL) + } + + XSEG(cursegpt) = x + YSEG(cursegpt) = y +end diff --git a/sys/gio/calcomp/ccpdrawch.x b/sys/gio/calcomp/ccpdrawch.x new file mode 100644 index 00000000..dab89158 --- /dev/null +++ b/sys/gio/calcomp/ccpdrawch.x @@ -0,0 +1,233 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "ccp.h" +include "font.h" + +define ITALIC_TILT 0.30 # fraction of xsize to tilt italics at top +define MAX_STROKESIZE 32 # max number of vectors making up one stroke +define CALCOMP_CHSTART 16 # maximum calcomp special symbol plus 1 +define SYMBOL_ASPECT 1.17 # calcomp height = 7/6 width for normal spacing. +define LOW_REDRAWS 5 # multiple traces for low-quality bold text +define HIGH_REDRAWS 9 # multiple traces for high-quality bold text + + +# CCP_DRAWCHAR -- Draw a character of the given size and orientation at the +# given position. + +procedure ccp_drawchar (ch, x, y, xsize, ysize, orien, font, quality) + +char ch # character to be drawn +int x, y # lower left GKI coords of character +int xsize, ysize # char width and height in unscaled GKI units +int orien # orientation of character (0 degrees normal) +int font # desired character font +int quality # quality control -- low(calcomp); other(iraf) + +real px, py, coso, sino, theta, xto_nicesize, yto_nicesize +real sx[MAX_STROKESIZE], sy[MAX_STROKESIZE] +int stroke, tab1, tab2, i, j, pen +int bitupk() + +include "ccp.com" +include "font.com" + +begin + # Compute correction factor for absolute physical character size. + # This also corrects for distortion of high-qual text if xscale<>yscale. + xto_nicesize = g_xdefault_scale / g_xndcto_p + yto_nicesize = g_ydefault_scale / g_yndcto_p + + # Set the font. + call ccp_font (font) + + if (quality == GT_LOW) { + # If low text quality requested, draw with Calcomp's SYMBOL call. + # We avoid machine-dependency word-size problems by always + # calling SYMBOL only from here, one char per call. + # Calcomp's SYMBOL expects height as only size; aspect is height + # = 7/6 (width) for normal character spacing. + + call ccx_intersymbol (XTRAN(x),YTRAN(y), real(xsize) * xto_nicesize, + real(ysize) * yto_nicesize, ch, real(orien)) + + } else { + # Text quality requested is not low; draw font either with single- + # width line or bold, via ccp_drawseg. + + if (ch < CHARACTER_START || ch > CHARACTER_END) + i = '?' - CHARACTER_START + 1 + else + i = ch - CHARACTER_START + 1 + + tab1 = chridx[i] + tab2 = chridx[i+1] - 1 + + if (tab2 - tab1 + 1 > MAX_STROKESIZE) { + call eprintf ( + "CCP KERNEL WARNING: up-dimension MAX_STROKESIZE\n") + call eprintf ( + "in module ccp_drawch; new stroke size %d, char %s\n") + call pargi (tab2 - tab1 + 1) + call pargc (ch) + tab2 = tab1 + MAX_STROKESIZE - 1 + } + + theta = -DEGTORAD(orien) + coso = cos(theta) + sino = sin(theta) + + j = 0 + do i = tab1, tab2 { + stroke = chrtab[i] + px = bitupk (stroke, COORD_X_START, COORD_X_LEN) + py = bitupk (stroke, COORD_Y_START, COORD_Y_LEN) + pen = bitupk (stroke, COORD_PEN_START, COORD_PEN_LEN) + + # Scale size of character in unwarped (xscale == yscale) system. + px = px / FONT_WIDTH * xsize + py = py / FONT_HEIGHT * ysize + + # The italic font is implemented applying a tilt. + if (font == GT_ITALIC) + px = px + ((py / ysize) * xsize * ITALIC_TILT) + + if (pen == 0 && j > 0) { # new stroke segment; draw last + if (j > 1) + call ccx_interpoly (sx, sy, j, quality) + j = 0 + } + + # Rotate, shift (unwarped), then correct for xscale <> yscale. + j = j + 1 + sx[j] = XTRAN(x + ( px * coso + py * sino) * xto_nicesize) + sy[j] = YTRAN(y + (-px * sino + py * coso) * yto_nicesize) + } + + # last stroke segment: + if (j > 1) + call ccx_interpoly (sx, sy, j, quality) + } +end + + +# CCX_INTERPOLY -- intermediate routine to 1) pass simple draw instruction to +# calcomp plot routines if linewidth single or bold method = penchange, or +# 2) simulate bold text by offsetting to the four corners and four edges +# of a box surrounding the character. + +procedure ccx_interpoly (x, y, npts, quality) + +real x[ARB],y[ARB] # plotter-unit coordinates to be drawn as polyline +int npts # number points in x,y +int quality # text quality (distinguish between medium and high) + +int i, j, num_redraws, twidth +real xp, yp +real xoff[HIGH_REDRAWS],yoff[HIGH_REDRAWS] + +include "ccp.com" + +data xoff/0., 1., 0., -1., 0., 1., -1., -1., 1./ +data yoff/0., 0., 1., 0., -1., 1., 1., -1., -1./ + +begin + if (npts <= 0) + return + + # If line width override is on, or linewidth is single, do simple move + # and draws. + + num_redraws = 1 + twidth = nint(GKI_UNPACKREAL(CCP_WIDTH(g_cc))) + if (!g_lwover) + if (g_lwtype == 'p' && twidth >= 1) + call ccp_lwidth (twidth) + else if (twidth > 1 && quality == GT_HIGH) + num_redraws = HIGH_REDRAWS + else + num_redraws = LOW_REDRAWS + + if (num_redraws == 1) { + call plot (x[1], y[1], CCP_UP) + g_max_x = max (x[1], g_max_x) + + if (npts == 1) { # single pt is special case; drop pen + call plot (x[1], y[1], CCP_DOWN) + } else { # draw normally + do i = 2, npts { + call plot (x[i], y[i], CCP_DOWN) + g_max_x = max (x[i], g_max_x) + } + } + } else { + do i = 1, num_redraws { + xp = x[1] + xoff[i] * g_plwsep + yp = y[1] + yoff[i] * g_plwsep + call plot (xp, yp, CCP_UP) + g_max_x = max (xp, g_max_x) + + if (npts == 1) { # single pt is special case; drop pen + call plot (xp, yp, CCP_DOWN) + } else { # draw normally + do j = 2, npts { + xp = x[j] + xoff[i] * g_plwsep + yp = y[j] + yoff[i] * g_plwsep + call plot (xp, yp, CCP_DOWN) + g_max_x = max (xp, g_max_x) + } + } + } + } +end + + +# CCX_INTERSYMBOL -- routine intermediate to Calcomp SYMBOL routine; handles +# bold text. + +procedure ccx_intersymbol (x,y, xsize,ysize, ch, orien) + +real x,y # plotter-unit coords of lower left of character +real xsize,ysize # char width, height in GKI units scaled to "nice" sizes +char ch # character to be drawn +real orien # degrees counterclockwise from +x axis to text path + +int i, nsym, symchar, num_redraws +real xp,yp, xoff[HIGH_REDRAWS],yoff[HIGH_REDRAWS], csize + +include "ccp.com" + +data xoff/0., 1., 0., -1., 0., 1., -1., -1., 1./ +data yoff/0., 0., 1., 0., -1., 1., 1., -1., -1./ + +begin + symchar = int (ch) + nsym = 1 + + if (ch < CALCOMP_CHSTART && ch >= 0) { + nsym = -1 + } else if (ch < ' ' || ch > '~') + ch = '~' + + # Since we are only called if text_quality == low, implement + # bold text with only the center and edge positions (LOW_REDRAWS). + num_redraws = 1 + if (!g_lwover && nint(GKI_UNPACKREAL(CCP_WIDTH(g_cc))) > 1) + num_redraws = LOW_REDRAWS + + # Set the size as the height of the character in device units; we + # start with the width to avoid overlapping, and we use the default + # scale, which results in reasonable-sized characters; the specified + # scale would produce strange results as orien passes from 0 to 90. + + csize = min (xsize * g_xndcto_p * SYMBOL_ASPECT, ysize * g_yndcto_p) + + do i = 1, num_redraws { + xp = x + xoff[i] * g_plwsep + yp = y + yoff[i] * g_plwsep + call symbol (xp, yp, csize, symchar, orien, nsym) + g_max_x = max (xp + csize, g_max_x) + } +end diff --git a/sys/gio/calcomp/ccpdseg.x b/sys/gio/calcomp/ccpdseg.x new file mode 100644 index 00000000..2d5d1c76 --- /dev/null +++ b/sys/gio/calcomp/ccpdseg.x @@ -0,0 +1,208 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ccp.h" + +define DIAGSEP (g_plwsep / 0.8660254) # distance to vertex of hexagon +define PIOVER3 (PI / 3.0) +define PIOVER6 (PI / 6.0) +define SIN_MIN_HALFBISECTOR 0.1 # sine of minimum half-bisector + + +# CCP_DRAWSEG -- Draw a polyline segment, optionally simulating variable +# widths. + +procedure ccp_drawseg (xseg, yseg, nsegpts, lwidth) + +real xseg[ARB] # plotter coordinate array of contiguous points +real yseg[ARB] +int nsegpts # number of pts in array +int lwidth # line width relative to single width + +int i, j +real pleft_x[MAXTRACES], pleft_y[MAXTRACES] +real pright_x[MAXTRACES], pright_y[MAXTRACES], lastp_x,lastp_y +real ahp2p1, theta, delx,dely, dx,dy, tx,ty +real rptheta4 () +include "ccp.com" +data lastp_x/0.0/, lastp_y/0.0/ + +begin + if (nsegpts < 1) + return + if (lwidth > MAXTRACES) { + call eprintf ("WARNING: line width > MAXTRACES in ccp_drawseg\n") + call eprintf (" line width reset to %d\n") + call pargi (MAXTRACES) + lwidth = MAXTRACES + } + + if (nsegpts == 1) { # 1 pt spcl bold + + # Draw a single point as a hexagon lined up in the direction from + # the preceding point. Start bounding hexagon 60 degrees cc from + # projection of last point drawn (0,0 initially) through current pt. + # 'ahp2p1' = Angle from Horizontal at P1 to line P1 -> P2, etc. + + ahp2p1 = rptheta4 (xseg[1], yseg[1], lastp_x, lastp_y) + lastp_x = xseg[1] + lastp_y = yseg[1] + theta = ahp2p1 - PIOVER6 + + # do even a single, interior point as a hexagon, up to lwidth times + do i = 1, lwidth { + tx = xseg[1] + (2 + i) * DIAGSEP * cos (theta) + ty = yseg[1] + (2 + i) * DIAGSEP * sin (theta) + call plot (tx, ty, CCP_UP) + + # draw a bounding hexagon around point: + do j = 1, 6 { + theta = theta + PIOVER3 + tx = xseg[1] + (2 + i) * DIAGSEP * cos (theta) + ty = yseg[1] + (2 + i) * DIAGSEP * sin (theta) + call plot (tx, ty, CCP_DOWN) + + # Store maximum-x plotted for a "newframe" in ccp_clear. + g_max_x = max (tx, g_max_x) + } + + # fill in a diagonal line across hexagon: + tx = xseg[1] + (2 + i) * DIAGSEP * cos (theta + PI) + ty = yseg[1] + (2 + i) * DIAGSEP * sin (theta + PI) + call plot (tx, ty, CCP_DOWN) + theta = theta + PIOVER3 # rotate spokes + } + + } else { # nsegpts > 1 + + if (g_lwover || lwidth == PL_SINGLE) { + call plot (xseg[1], yseg[1], CCP_UP) + g_max_x = max (xseg[1], g_max_x) + + do i = 2, nsegpts { + call plot (xseg[i], yseg[i], CCP_DOWN) + g_max_x = max (xseg[i], g_max_x) + } + } else if (lwidth > PL_SINGLE) { + + # compute flanking points; by definition +-90 deg. from p1-p2, + # so first point is special case; do for all thicknesses: + + call ccx_offsets (xseg[1]-xseg[2]+xseg[1], + yseg[1]-yseg[2]+yseg[1], xseg[1],yseg[1], + xseg[2],yseg[2], delx,dely) + + do i = 1, lwidth - 1 { + pleft_x[i] = xseg[1] + i * delx + pleft_y[i] = yseg[1] + i * dely + pright_x[i] = xseg[1] - i * delx + pright_y[i] = yseg[1] - i * dely + } + + # must draw each segment individually, to make flanks meet. + do i = 1, nsegpts - 2 { + + # actual line segment in data: + call plot (xseg[i], yseg[i], CCP_UP) + call plot (xseg[i+1], yseg[i+1], CCP_DOWN) + g_max_x = max (xseg[i], g_max_x) + + call ccx_offsets (xseg[i],yseg[i], xseg[i+1],yseg[i+1], + xseg[i+2],yseg[i+2], delx,dely) + + # for each flanking line; p2 in middle, at temp origin + do j = 1, lwidth - 1 { + + # point to left of p1-p2, facing p2: + dx = j * delx + dy = j * dely + tx = xseg[i+1] + dx + ty = yseg[i+1] + dy + call plot (pleft_x[j], pleft_y[j], CCP_UP) + call plot (tx, ty, CCP_DOWN) + pleft_x[j] = tx + pleft_y[j] = ty + + # point to right of p1-p2, facing p2: + tx = xseg[i+1] - dx + ty = yseg[i+1] - dy + call plot (pright_x[j], pright_y[j], CCP_UP) + call plot (tx, ty, CCP_DOWN) + pright_x[j] = tx + pright_y[j] = ty + } + } + + # last point: + call plot (xseg[nsegpts-1], yseg[nsegpts-1], CCP_UP) + call plot (xseg[nsegpts], yseg[nsegpts], CCP_DOWN) + g_max_x = max (xseg[nsegpts-1], g_max_x) + g_max_x = max (xseg[nsegpts], g_max_x) + + # save this point for a possible following dotted line segment: + lastp_x = xseg[nsegpts] + lastp_y = yseg[nsegpts] + + # square the flanking lines: + call ccx_offsets (xseg[nsegpts-1], yseg[nsegpts-1], + xseg[nsegpts], yseg[nsegpts], + xseg[nsegpts] * 2.0 - xseg[nsegpts-1], + yseg[nsegpts] * 2.0 - yseg[nsegpts-1], + delx, dely) + + do i = 1, lwidth - 1 { + tx = xseg[nsegpts] + i * delx + ty = yseg[nsegpts] + i * dely + call plot (pleft_x[i], pleft_y[i], CCP_UP) + call plot (tx, ty, CCP_DOWN) + tx = xseg[nsegpts] - i * delx + ty = yseg[nsegpts] - i * dely + call plot (pright_x[i], pright_y[i], CCP_UP) + call plot (tx, ty, CCP_DOWN) + } + } + } +end + + +# CCX_OFFSETS -- return offsets in x, y from point 2 to one level of line width +# simulation, given points 1, 2, 3. + +procedure ccx_offsets (p1x,p1y, p2x,p2y, p3x,p3y, delx,dely) + +real p1x,p1y # input: point 1 is previous point +real p2x,p2y # input: point 2 is current point (middle of the three) +real p3x,p3y # input: point 3 is succeeding point +real delx,dely # output: offsets from point 2 to one flanking point + +real ahp2p1 # Angle from Horizontal to line p2-->p1, etc. +real ahp2p3, ap1p2p3, ahbisector, sintheta, r +real rptheta4 () +include "ccp.com" + +begin + # convention is that p2 is current point, at temporary origin; p1 + # is "behind", and p3 is "ahead" of the current point, p2. + # "ahp2p1" = angle from horizontal to segment p2->p1 + # "ap1p2p3" = angle from p1 to p2 to p3 + # "ahbisector" = angle from horizontal (+x) to bisector of p1->p2->p3 + + ahp2p1 = rptheta4 (p2x,p2y, p1x,p1y) + ahp2p3 = rptheta4 (p2x,p2y, p3x,p3y) + ap1p2p3 = ahp2p1 - ahp2p3 + ahbisector = ahp2p3 + 0.5 * ap1p2p3 + sintheta = sin (ahp2p1 - ahbisector) + + # very small angles cause extremely exaggerated vertices; truncate + # at arbitrary multiple of plwsep; 10*plwsep is eqv. to 11.5 deg. bisect + + if (abs (sintheta) < SIN_MIN_HALFBISECTOR) { + r = g_plwsep / SIN_MIN_HALFBISECTOR + if (sintheta < 0.0) + r = -r + } else + r = g_plwsep / sintheta + + delx = r * cos (ahbisector) + dely = r * sin (ahbisector) +end diff --git a/sys/gio/calcomp/ccpescape.x b/sys/gio/calcomp/ccpescape.x new file mode 100644 index 00000000..37e81972 --- /dev/null +++ b/sys/gio/calcomp/ccpescape.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ccp.h" + +# CCP_ESCAPE -- Pass a device dependent instruction on to the kernel. +# used for passing exact scaling factors through gki metacode + +procedure ccp_escape (fn, instruction, nwords) + +int fn # function code +short instruction[ARB] # instruction data words +int nwords # length of instruction + +int ip +real tempr +char scale_str[SZ_LINE] +int ctod () + +include "ccp.com" + +string warnx "Warning: ccpkern unable to convert gki_escape xscale\n" +string warny "Warning: ccpkern unable to convert gki_escape yscale\n" + +begin + call achtsc (instruction, scale_str, nwords) + scale_str[nwords+1] = EOS + ip = 1 + + switch (fn) { + + case GSC_X_GKITODEV: + + # if kernel task scale params were not specified, set actual scale + # params to those passed from metacode if translatable, set to + # default scale from ccp_init/graphcap if untranslatable. If + # kernel task did specify scale, this is a no op. + + if (IS_INDEF (g_xtask_scale)) { + if (ctod (scale_str, ip, tempr) < 1) { + g_xndcto_p = g_xdefault_scale + call eprintf (warnx) + call eprintf ("scale string: %s\n") + call pargstr (scale_str) + call eprintf ("new (graphcap-default) x scale: %f\n") + call pargr (g_xndcto_p) + } else + g_xndcto_p = tempr + } + + case GSC_Y_GKITODEV: + + if (IS_INDEF (g_ytask_scale)) { + if (ctod (scale_str, ip, tempr) < 1) { + g_yndcto_p = g_ydefault_scale + call eprintf (warny) + call eprintf ("scale string: %s\n") + call pargstr (scale_str) + call eprintf ("new (graphcap-default) y scale: %f\n") + call pargr (g_yndcto_p) + } else + g_yndcto_p = tempr + } + } +end diff --git a/sys/gio/calcomp/ccpfa.x b/sys/gio/calcomp/ccpfa.x new file mode 100644 index 00000000..cf54861d --- /dev/null +++ b/sys/gio/calcomp/ccpfa.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "ccp.h" + +# CCP_FILLAREA -- Fill a closed area. + +procedure ccp_fillarea (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs +include "ccp.com" + +begin + # Not implemented yet. + call ccp_polyline (p, npts) +end diff --git a/sys/gio/calcomp/ccpfaset.x b/sys/gio/calcomp/ccpfaset.x new file mode 100644 index 00000000..228669f9 --- /dev/null +++ b/sys/gio/calcomp/ccpfaset.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ccp.h" + +# CCP_FASET -- Set the fillarea attributes. + +procedure ccp_faset (gki) + +short gki[ARB] # attribute structure +pointer fa +include "ccp.com" + +begin + fa = CCP_FAAP(g_cc) + FA_STYLE(fa) = gki[GKI_FASET_FS] + FA_COLOR(fa) = gki[GKI_FASET_CI] +end diff --git a/sys/gio/calcomp/ccpfont.x b/sys/gio/calcomp/ccpfont.x new file mode 100644 index 00000000..0e7ad9a4 --- /dev/null +++ b/sys/gio/calcomp/ccpfont.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ccp.h" + +# CCP_FONT -- Set the character font. The roman font is normal. Bold is +# implemented by increasing the vector line width; care must be taken to +# set CCP_WIDTH so that the other vector drawing procedures remember to +# change the width back. The italic font is implemented in the character +# generator by a geometric transformation. + +procedure ccp_font (font) + +int font # code for font to be set +int pk1, pk2, width +include "ccp.com" + +begin + pk1 = GKI_PACKREAL(1.0) + pk2 = GKI_PACKREAL(2.0) + + width = CCP_WIDTH(g_cc) + + if (font == GT_BOLD) { + if (width != pk2) + width = pk2 + } else { + if (GKI_UNPACKREAL(width) > 1.5) + width = pk1 + } + + CCP_WIDTH(g_cc) = width +end diff --git a/sys/gio/calcomp/ccpinit.x b/sys/gio/calcomp/ccpinit.x new file mode 100644 index 00000000..1ae558c7 --- /dev/null +++ b/sys/gio/calcomp/ccpinit.x @@ -0,0 +1,165 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "ccp.h" + +# CCP_INIT -- Initialize the CCP data structures from the graphcap entry +# for the plotter. Called once, at OPENWS time, with the TTY pointer already +# set in the common. The companion routine CCP_RESET initializes the attribute +# packets. + +procedure ccp_init (tty, devname) + +pointer tty # graphcap descriptor +char devname[ARB] # device name + +pointer nextch +int maxch, i +real char_height, char_width, char_size, xres, yres, xwidth, yheight +real mper_punit +bool ttygetb() +real ttygetr() +int ttygeti(), btoi(), gstrcpy() +include "ccp.com" + +begin + # Allocate the CCP descriptor, string buffer, and x,y segment buffers. + if (g_cc == NULL) { + call calloc (g_cc, LEN_CCP, TY_STRUCT) + call malloc (CCP_SBUF(g_cc), SZ_SBUF, TY_CHAR) + } + + # Init string buffer parameters. The first char of the string buffer + # is reserved as a null string, used for graphcap control strings + # omitted from the graphcap entry for the device. + + CCP_SZSBUF(g_cc) = SZ_SBUF + CCP_NEXTCH(g_cc) = CCP_SBUF(g_cc) + 1 + Memc[CCP_SBUF(g_cc)] = EOS + + # Get the device resolution, dimensions in meters, and meter-to-pltr + # unit conversion factor from graphcap; if none are specified, use + # compile-time constants. + + xres = ttygeti (tty, "xr") + if (xres <= 0) + xres = GKI_MAXNDC + yres = ttygeti (tty, "yr") + if (yres <= 0) + yres = GKI_MAXNDC + + xwidth = ttygetr (tty, "xs") + if (xwidth <= 0.0) + xwidth = MAX_PL_XWIDTH + yheight = ttygetr (tty, "ys") + if (yheight <= 0.0) + yheight = MAX_PL_YHEIGHT + + mper_punit = ttygetr (tty, "MP") + if (mper_punit <= 0.0) + mper_punit = DEF_MPER_PUNIT + + # Set up coordinate transformation if not explicitly specified to + # kernel task at run time. Scale determined from graphcap is saved + # in case ccp_escape gets a metacode scale it cannot translate. + # Set up default scale such that a full max_gki_ndc plot will fit in y. + + g_ydefault_scale = yheight / (mper_punit * GKI_MAXNDC) + if (IS_INDEF (g_ytask_scale)) + g_yndcto_p = g_ydefault_scale + + g_xdefault_scale = xwidth / (mper_punit * GKI_MAXNDC) + if (IS_INDEF (g_xtask_scale)) + g_xndcto_p = g_xdefault_scale + + # Initialize the character scaling parameters, required for text + # generation. The heights are given in NDC units in the graphcap + # file, which we convert to GKI units. Estimated values are + # supplied if the parameters are missing in the graphcap entry. + + char_height = ttygetr (tty, "ch") + if (char_height < EPSILON) + char_height = 1.0 / 35.0 + char_height = char_height * GKI_MAXNDC + + char_width = ttygetr (tty, "cw") + if (char_width < EPSILON) + char_width = 1.0 / 80.0 + char_width = char_width * GKI_MAXNDC + + # If the plotter has a set of discrete character sizes, get the + # size of each by fetching the parameter "tN", where the N is + # a digit specifying the text size index. Compute the height and + # width of each size character from the "ch" and "cw" parameters + # and the relative scale of character size I. + + CCP_NCHARSIZES(g_cc) = min (MAX_CHARSIZES, ttygeti (tty, "th")) + nextch = CCP_NEXTCH(g_cc) + + if (CCP_NCHARSIZES(g_cc) <= 0) { + CCP_NCHARSIZES(g_cc) = 1 + CCP_CHARSIZE(g_cc,1) = 1.0 + CCP_CHARHEIGHT(g_cc,1) = char_height + CCP_CHARWIDTH(g_cc,1) = char_width + } else { + Memc[nextch+2] = EOS + for (i=1; i <= CCP_NCHARSIZES(g_cc); i=i+1) { + Memc[nextch] = 't' + Memc[nextch+1] = TO_DIGIT(i) + char_size = ttygetr (tty, Memc[nextch]) + CCP_CHARSIZE(g_cc,i) = char_size + CCP_CHARHEIGHT(g_cc,i) = char_height * char_size + CCP_CHARWIDTH(g_cc,i) = char_width * char_size + } + } + + # Get dash length, gap length, and n-tracing separation width: + if (IS_INDEF (g_dashlen)) { + g_dashlen = ttygetr (tty, "DL") + if (g_dashlen <= 0.0) + g_dashlen = DEF_DASHLEN + } + if (IS_INDEF (g_gaplen)) { + g_gaplen = ttygetr (tty, "GL") + if (g_gaplen <= 0.0) + g_gaplen = DEF_GAPLEN + } + if (IS_INDEF (g_plwsep)) { + g_plwsep = ttygetr (tty, "PW") + if (g_plwsep <= 0.0) + g_plwsep = DEF_PLWSEP + } + + # Initialize the output parameters. All boolean parameters are stored + # as integer flags. All string valued parameters are stored in the + # string buffer, saving a pointer to the string in the CCP + # descriptor. If the capability does not exist the pointer is set to + # point to the null string at the beginning of the string buffer. + + CCP_POLYLINE(g_cc) = btoi (ttygetb (tty, "pl")) + CCP_POLYMARKER(g_cc) = btoi (ttygetb (tty, "pm")) + CCP_FILLAREA(g_cc) = btoi (ttygetb (tty, "fa")) + CCP_FILLSTYLE(g_cc) = ttygeti (tty, "fs") + CCP_ROAM(g_cc) = btoi (ttygetb (tty, "ro")) + CCP_ZOOM(g_cc) = btoi (ttygetb (tty, "zo")) + CCP_ZRES(g_cc) = ttygeti (tty, "zr") + CCP_SELERASE(g_cc) = btoi (ttygetb (tty, "se")) + CCP_PIXREP(g_cc) = btoi (ttygetb (tty, "pr")) + + # Initialize the input parameters. + + CCP_CURSOR(g_cc) = 1 + + # Save the device string in the descriptor. + nextch = CCP_NEXTCH(g_cc) + CCP_DEVNAME(g_cc) = nextch + CCP_DEVCHAN(g_cc) = CCP_LDEV + maxch = CCP_SBUF(g_cc) + SZ_SBUF - nextch + 1 + nextch = nextch + gstrcpy (devname, Memc[nextch], maxch) + 1 + CCP_NEXTCH(g_cc) = nextch + + # Initialize maximum-x tracker, used for "newframe" in ccp_clear. + g_max_x = 0.0 +end diff --git a/sys/gio/calcomp/ccpltype.x b/sys/gio/calcomp/ccpltype.x new file mode 100644 index 00000000..e5325ddd --- /dev/null +++ b/sys/gio/calcomp/ccpltype.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ccp.h" + +# CCP_LINETYPE -- Set the line type option in the nspp world. + +procedure ccp_linetype (index) + +int index # index for line type switch statement + +include "ccp.com" + +begin + switch (index) { + case GL_CLEAR: + g_ltype = 0 + case GL_DASHED: + g_ltype = 2 + case GL_DOTTED: + g_ltype = 3 + case GL_DOTDASH: + g_ltype = 4 + default: + g_ltype = 1 # GL_SOLID and default + } +end diff --git a/sys/gio/calcomp/ccplwidth.x b/sys/gio/calcomp/ccplwidth.x new file mode 100644 index 00000000..bda9c33b --- /dev/null +++ b/sys/gio/calcomp/ccplwidth.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "ccp.h" + +# Calcomp pen widths +define SINGLE 1 # ***** site dependence!! [MACHDEP] +define DOUBLE 2 # + +# CCP_LWIDTH set pen width; see ccp_color, which also sets pens. +# We should only be called if task param "lwtype" was explicitly set to +# "p" for pen method; normally bold lines are handled by ntracing. + +procedure ccp_lwidth (index) + +int index # index for width switch statement +include "ccp.com" + +begin + if (g_lwover) # CL param lwover, line width override is on; noop + return + + # ***** site dependence; add other pen numbers here; if pen numbers + # for multiple widths are monotonic, make single call to newpen(index). + + switch (index) { + + case DOUBLE: + call newpen (DOUBLE) + default: + call newpen (SINGLE) + } +end diff --git a/sys/gio/calcomp/ccpopen.x b/sys/gio/calcomp/ccpopen.x new file mode 100644 index 00000000..f900b95b --- /dev/null +++ b/sys/gio/calcomp/ccpopen.x @@ -0,0 +1,77 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ccp.h" + +# CCP_OPEN -- Install the calcomp kernel as a graphics kernel device driver. +# The device table DD consists of an array of the entry point addresses for +# the driver procedures. The table entry for non-implemented procedures is +# set to zero, causing the interpreter to ignore the instruction. + +procedure ccp_open (devname, dd) + +char devname[ARB] # ignored if only one plotter on system +int dd[ARB] # device table to be initialized + +pointer sp, devns +int len_devname +int locpr(), strlen() +extern ccp_openws(), ccp_closews(), ccp_clear() +extern ccp_polyline(), ccp_polymarker(), ccp_text() +extern ccp_plset() +extern ccp_pmset(), ccp_txset() +extern ccp_escape() +include "ccp.com" + +begin + call smark (sp) + call salloc (devns, SZ_FNAME, TY_SHORT) + + # Flag first pass. Save forced device name in common for OPENWS. + # Zero the frame and instruction counters. + + g_cc = NULL + g_ndraw = 0 #????? may not need; also used in ccp_openws,ccp_clear, + # ccp_polyline, ccp_polymarker, ccp_text; may want for + # debug etc. + call strcpy (devname, g_device, SZ_GDEVICE) + + # Install the device driver. + + dd[GKI_OPENWS] = locpr (ccp_openws) + dd[GKI_CLOSEWS] = locpr (ccp_closews) + dd[GKI_DEACTIVATEWS] = 0 + dd[GKI_REACTIVATEWS] = 0 + dd[GKI_MFTITLE] = 0 + dd[GKI_CLEAR] = locpr (ccp_clear) + dd[GKI_CANCEL] = 0 + dd[GKI_FLUSH] = 0 + dd[GKI_POLYLINE] = locpr (ccp_polyline) + dd[GKI_POLYMARKER] = locpr (ccp_polymarker) + dd[GKI_TEXT] = locpr (ccp_text) + dd[GKI_FILLAREA] = 0 + dd[GKI_PUTCELLARRAY] = 0 + dd[GKI_SETCURSOR] = 0 + dd[GKI_PLSET] = locpr (ccp_plset) + dd[GKI_PMSET] = locpr (ccp_pmset) + dd[GKI_TXSET] = locpr (ccp_txset) + dd[GKI_FASET] = 0 + dd[GKI_GETCURSOR] = 0 + dd[GKI_GETCELLARRAY] = 0 + dd[GKI_ESCAPE] = locpr (ccp_escape) + dd[GKI_SETWCS] = 0 + dd[GKI_GETWCS] = 0 + dd[GKI_UNKNOWN] = 0 + + # If a device was named open the workstation as well. This is + # necessary to permit processing of metacode files which do not + # contain the open workstation instruction. + + len_devname = strlen (devname) + if (len_devname > 0) { + call achtcs (devname, Mems[devns], len_devname) + call ccp_openws (Mems[devns], len_devname, NEW_FILE) + } + + call sfree (sp) +end diff --git a/sys/gio/calcomp/ccpopenws.x b/sys/gio/calcomp/ccpopenws.x new file mode 100644 index 00000000..aec063cf --- /dev/null +++ b/sys/gio/calcomp/ccpopenws.x @@ -0,0 +1,87 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "ccp.h" + +# CCP_OPENWS -- Open the named workstation. Once a workstation has been +# opened we leave it open until some other workstation is opened or the +# kernel is closed. Opening a workstation involves initialization of the +# kernel data structures, following by initialization of the device itself. + +procedure ccp_openws (devname, n, mode) + +short devname[ARB] # device name +int n # length of device name +int mode # access mode + +pointer sp, buf +pointer ttygdes() +bool streq() +bool need_open, same_dev +include "ccp.com" + +begin + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + + # If a particular plotter was named when the kernel was opened then + # output will always go to that plotter (g_device) regardless of the + # plotter named in the OPENWS instruction. If no plotter was named + # (null string) then unpack the plotter name, passed as a short integer + # array. + + if (g_device[1] == EOS) { + call achtsc (devname, Memc[buf], n) + Memc[buf+n] = EOS + } else + call strcpy (g_device, Memc[buf], SZ_FNAME) + + # Find out if first time, and if not, if same device as before + # note that if (g_cc == NULL), then same_dev is false. + + same_dev = false + need_open = true + + if (g_cc != NULL) { # not first time + same_dev = (streq (Memc[CCP_DEVNAME(g_cc)], Memc[buf])) + if (!same_dev) { + # close previous plotter, initialize new one. + call plot (0, 0, 999) + call plots (0, 0, CCP_DEVCHAN(g_cc)) + } else + need_open = false + } + + # Initialize the kernel data structures. Open graphcap descriptor + # for the named device, allocate and initialize descriptor and common. + # graphcap entry for device must exist. + + if (need_open) { + if ((g_cc != NULL) && !same_dev) + call ttycdes (g_tty) # close prev tty + if (!same_dev) { + iferr (g_tty = ttygdes (Memc[buf])) + call erract (EA_ERROR) + g_ndraw = 0 + } + } + + # Initialize data structures if we had to open a new device. + if (!same_dev) { + call ccp_init (g_tty, Memc[buf]) + call ccp_reset() + call plots (0, 0, CCP_DEVCHAN(g_cc)) + } + + # Advance a frame if device is being opened in new_file mode. + # This is a nop if we really opened a new device, but it will advance + # the paper if this is just a reopen of the same device in new file + # mode. + + if (mode == NEW_FILE) + call ccp_clear (0) + + call sfree (sp) +end diff --git a/sys/gio/calcomp/ccppl.x b/sys/gio/calcomp/ccppl.x new file mode 100644 index 00000000..2b1712bd --- /dev/null +++ b/sys/gio/calcomp/ccppl.x @@ -0,0 +1,105 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ccp.h" + +# CCP_POLYLINE -- Set up a polyline. The polyline is defined by the array of +# points P, consisting of successive (x,y) coordinate pairs. The first point +# is not plotted unless it is the only point, but rather defines the start of +# the polyline. The remaining points define line segments to be drawn. + +procedure ccp_polyline (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs + +pointer pl, xseg,yseg +int i, curpl_pt, nsegpts +int len_p, segsize, lsize + +include "ccp.com" + +begin + if (npts <= 0) + return + + len_p = npts * 2 + + # Keep track of number of drawing instructions since last frame clear. + g_ndraw = g_ndraw + 1 + + # Update polyline attributes if necessary. + pl = CCP_PLAP(g_cc) + + if (CCP_LTYPE(g_cc) != PL_LTYPE(pl)) { + call ccp_linetype (PL_LTYPE(pl)) # set g_ltype in ccp.com + CCP_LTYPE(g_cc) = PL_LTYPE(pl) + } + if (CCP_WIDTH(g_cc) != PL_WIDTH(pl)) { + if (GKI_UNPACKREAL(PL_WIDTH(pl)) < 1.5) { + CCP_WIDTH(g_cc) = GKI_PACKREAL(PL_SINGLE) + } else + CCP_WIDTH(g_cc) = PL_WIDTH(pl) + } + if (CCP_COLOR(g_cc) != PL_COLOR(pl)) { + call ccp_color (PL_COLOR(pl)) + CCP_COLOR(g_cc) = PL_COLOR(pl) + } + + # If the overrides are on, or linetype is solid and linewidth is single, + # do simple move and draws: + + if ((g_ltover && g_lwover) || (!g_lwover && g_lwtype == 'p') || + (g_ltype == GL_SOLID && CCP_WIDTH(g_cc) == GKI_PACKREAL(PL_SINGLE)) + || (g_ltover && CCP_WIDTH(g_cc) == GKI_PACKREAL(PL_SINGLE)) || + (g_ltype == GL_SOLID && g_lwover)) { + + if (g_lwtype == 'p') + call newpen (PL_WIDTH(pl)) + + call plot (XTRAN(p[1]), YTRAN(p[2]), CCP_UP) + if (npts == 1) { + call plot (XTRAN(p[1]), YTRAN(p[2]), CCP_DOWN) + } else { # draw normally + do i = 3, len_p, 2 + call plot (XTRAN(p[i]), YTRAN(p[i+1]), CCP_DOWN) + } + + # Store maximum-x point plotted for a "newframe" in ccp_clear. + do i = 1, len_p, 2 + g_max_x = max (XTRAN(p[i]), g_max_x) + + + # Otherwise, must calculate individual segments of dashes and dots, + # keeping their lengths constant along polyline (ccp_calcseg), before + # optionally simulating bold and drawing (ccp_drawseg): + + } else { # vector polyline; simulate linetype, linewidth + + segsize = SEGSIZE + call malloc (xseg, segsize, TY_REAL) + call malloc (yseg, segsize, TY_REAL) + + curpl_pt = 1 + lsize = nint(GKI_UNPACKREAL(CCP_WIDTH(g_cc))) + if (!g_ltover && (g_ltype >= GL_DASHED && g_ltype <= GL_DOTDASH)) { + + while (curpl_pt <= npts) { + call ccp_calcseg (p, npts, g_ltype, curpl_pt, segsize, + xseg,yseg, nsegpts) + call ccp_drawseg (Memr[xseg],Memr[yseg], nsegpts, lsize) + } + + } else { # either (ltype override or solid line), not single wid. + + call ccp_calcseg (p, npts, GL_SOLID, curpl_pt, segsize, xseg, + yseg, nsegpts) + call ccp_drawseg (Memr[xseg],Memr[yseg], nsegpts, lsize) + } + + call mfree (xseg, TY_REAL) + call mfree (yseg, TY_REAL) + } + +end diff --git a/sys/gio/calcomp/ccpplset.x b/sys/gio/calcomp/ccpplset.x new file mode 100644 index 00000000..c118f93e --- /dev/null +++ b/sys/gio/calcomp/ccpplset.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ccp.h" + +# CCP_PLSET -- Set the polyline attributes. The polyline width parameter is +# passed to the encoder as a packed floating point number, i.e., int(LWx100). + +procedure ccp_plset (gki) + +short gki[ARB] # attribute structure +pointer pl +include "ccp.com" + +begin + pl = CCP_PLAP(g_cc) + PL_LTYPE(pl) = gki[GKI_PLSET_LT] + PL_WIDTH(pl) = gki[GKI_PLSET_LW] + PL_COLOR(pl) = gki[GKI_PLSET_CI] +end diff --git a/sys/gio/calcomp/ccppm.x b/sys/gio/calcomp/ccppm.x new file mode 100644 index 00000000..bb6c783f --- /dev/null +++ b/sys/gio/calcomp/ccppm.x @@ -0,0 +1,73 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ccp.h" + +define DIAGSEP (1.0 * g_plwsep / 0.7071068) # dis at 40 degrees from plwsep + +# CCP_POLYMARKER -- Draw a polymarker. The polymarker is defined by the array +# of points P, consisting of successive (x,y) coordinate pairs. + +procedure ccp_polymarker (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs + +pointer pm +int i, j, len_p +real theta, x, y, tx, ty +include "ccp.com" + +begin + if (npts <= 0) + return + + len_p = npts * 2 + + # Keep track of the number of drawing instructions since the last frame + # clear. + g_ndraw = g_ndraw + 1 + + # Update polymarker attributes if necessary. + + pm = CCP_PMAP(g_cc) + + if (CCP_LTYPE(g_cc) != PM_LTYPE(pm)) { + call ccp_linetype (PM_LTYPE(pm)) + CCP_LTYPE(g_cc) = PM_LTYPE(pm) + } + if (CCP_WIDTH(g_cc) != PM_WIDTH(pm)) + CCP_WIDTH(g_cc) = PM_WIDTH(pm) + + if (CCP_COLOR(g_cc) != PM_COLOR(pm)) { + call ccp_color (PM_COLOR(pm)) + CCP_COLOR(g_cc) = PM_COLOR(pm) + } + + # Draw the polymarker. + do i = 1, len_p, 2 { + # Draw the single point as a box with a diagonal + # through it. + + theta = 0.5 * HALFPI + x = XTRAN(p[i]) + y = YTRAN(p[i+1]) + tx = x + DIAGSEP * cos (theta) + ty = y + DIAGSEP * sin (theta) + call plot (tx, ty, CCP_UP) + g_max_x = max (tx, g_max_x) + + do j = 1, 4 { + theta = theta + HALFPI + tx = x + DIAGSEP * cos (theta) + ty = y + DIAGSEP * sin (theta) + call plot (tx, ty, CCP_DOWN) + } + + # Fill in diagonal. + tx = x + DIAGSEP * cos (theta + PI) + ty = y + DIAGSEP * sin (theta + PI) + call plot (tx, ty, CCP_DOWN) + } +end diff --git a/sys/gio/calcomp/ccppmset.x b/sys/gio/calcomp/ccppmset.x new file mode 100644 index 00000000..2f3f5534 --- /dev/null +++ b/sys/gio/calcomp/ccppmset.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ccp.h" + +# CCP_PMSET -- Set the polymarker attributes. + +procedure ccp_pmset (gki) + +short gki[ARB] # attribute structure +pointer pm +include "ccp.com" + +begin + pm = CCP_PMAP(g_cc) + PM_LTYPE(pm) = gki[GKI_PMSET_MT] + PM_WIDTH(pm) = gki[GKI_PMSET_MW] + PM_COLOR(pm) = gki[GKI_PMSET_CI] +end diff --git a/sys/gio/calcomp/ccpreset.x b/sys/gio/calcomp/ccpreset.x new file mode 100644 index 00000000..7d4514f6 --- /dev/null +++ b/sys/gio/calcomp/ccpreset.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ccp.h" + +# CCP_RESET -- Reset the state of the transform common, i.e., in response to +# a clear or a cancel. Initialize all attribute packets to their default +# values and set the current state of the device to undefined, forcing the +# device state to be reset when the next output instruction is executed. + +procedure ccp_reset() + +pointer pl, pm, fa, tx +include "ccp.com" + +begin + # Set pointers to attribute substructures. + pl = CCP_PLAP(g_cc) + pm = CCP_PMAP(g_cc) + fa = CCP_FAAP(g_cc) + tx = CCP_TXAP(g_cc) + + # Initialize the attribute packets. + PL_LTYPE(pl) = GL_SOLID + PL_WIDTH(pl) = GKI_PACKREAL(PL_SINGLE) + PL_COLOR(pl) = 1 + PM_LTYPE(pm) = GL_SOLID + PM_WIDTH(pm) = GKI_PACKREAL(PL_SINGLE) + PM_COLOR(pm) = 1 + TX_UP(tx) = 90 + TX_SIZE(tx) = GKI_PACKREAL(1.) + TX_PATH(tx) = GT_RIGHT + TX_HJUSTIFY(tx) = GT_LEFT + TX_VJUSTIFY(tx) = GT_BOTTOM + TX_FONT(tx) = GT_ROMAN + TX_COLOR(tx) = 1 + TX_SPACING(tx) = 0.0 + + # Set the device attributes to undefined, forcing them to be reset + # when the next output instruction is executed. + + CCP_LTYPE(g_cc) = -1 + CCP_WIDTH(g_cc) = -1 + CCP_COLOR(g_cc) = -1 + CCP_TXSIZE(g_cc) = -1 + CCP_TXFONT(g_cc) = -1 +end diff --git a/sys/gio/calcomp/ccptx.x b/sys/gio/calcomp/ccptx.x new file mode 100644 index 00000000..b93b5223 --- /dev/null +++ b/sys/gio/calcomp/ccptx.x @@ -0,0 +1,463 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "ccp.h" + +define BASECS_X 12 # Base (size 1.0) char width in GKI coords. +define BASECS_Y 12 # Base (size 1.0) char height in GKI coords. + + +# CCP_TEXT -- Draw a text string. The string is drawn at the position (X,Y) +# using the text attributes set by the last GKI_TXSET instruction. The text +# string to be drawn may contain embedded set font escape sequences of the +# form \fR (roman), \fG (greek), etc. We break the input text sequence up +# into segments at font boundaries and draw these on the output device, +# setting the text size, color, font, and position at the beginning of each +# segment. + +procedure ccp_text (xc, yc, text, n) + +int xc, yc # where to draw text string +short text[ARB] # text string +int n # number of characters + +real g_dx, g_dy # scale GKI to window coords +int g_x1, g_y1 # origin of device window +int g_x2, g_y2 # upper right corner of device window +real x, y, dx, dy, tsz, xto_nicesize, yto_nicesize +int x1, x2, y1, y2, orien +int x0, y0, gki_dx, gki_dy, ch, cw +int xstart, ystart, newx, newy +int totlen, polytext, font, seglen, quality +pointer sp, seg, ip, op, tx, first, pl +int ccx_segment() +include "ccp.com" + +data g_dx /1.0/, g_dy /1.0/ +data g_x1 /0/, g_y1 /0/, g_x2 /GKI_MAXNDC/, g_y2 / GKI_MAXNDC/ + +begin + call smark (sp) + call salloc (seg, n + 2, TY_CHAR) + + # Keep track of the number of drawing instructions since the last frame + # clear. + g_ndraw = g_ndraw + 1 + + # Set pointer to the text attribute structure. + tx = CCP_TXAP(g_cc) + + # Set the text size and color if not already set. Both should be + # invalidated when the screen is cleared. Text color should be + # invalidated whenever another color is set. The text size was + # set by ccp_txset, and is just a scaling factor. + + CCP_TXSIZE(g_cc) = TX_SIZE(tx) + if (TX_COLOR(tx) != CCP_COLOR(g_cc)) { + call ccp_color (TX_COLOR(tx)) + CCP_COLOR(g_cc) = TX_COLOR(tx) + } + + # Set the character-generator quality. Only low (Calcomp "symbol") + # and other (ccp_font; see NSPP doc. on its font) are supported. + if (g_txquality == 0) { + quality = TX_QUALITY(tx) # param was specified "normal" to task + } else + quality = g_txquality # param was explicit to task + + # Set the linetype to a solid line, and invalidate last setting. + call ccp_linetype (GL_SOLID) # for use in ccp_polyline + CCP_LTYPE(g_cc) = -1 # PL_LTYPE still contains current settng + + # Set pointer to polyline attribute structure and set line width + # if necessary. + pl = CCP_PLAP(g_cc) + + if (CCP_WIDTH(g_cc) != PL_WIDTH(pl)) { + if (GKI_UNPACKREAL(PL_WIDTH(pl)) < 1.5) { + CCP_WIDTH(g_cc) = GKI_PACKREAL(PL_SINGLE) + } else + CCP_WIDTH(g_cc) = PL_WIDTH(pl) + } + # Break the text string into segments at font boundaries and count + # the total number of printable characters. + + totlen = ccx_segment (text, n, Memc[seg], TX_FONT(tx)) + + # Compute the text drawing parameters, i.e., the coordinates of the + # first character to be drawn, the step between successive characters, + # and the polytext flag (GKI coords). + + call ccx_parameters (xc,yc, totlen, x0,y0, gki_dx,gki_dy, polytext, + orien) + + # Scale the base sizes. + tsz = GKI_UNPACKREAL(TX_SIZE(tx)) # scale factor + ch = CCP_CHARHEIGHT(g_cc,1) * tsz + cw = CCP_CHARWIDTH(g_cc,1) * tsz + + # Compute correction factors for absolute physical character sizes. + # This also corrects for distortion of high-qual text if xscale<>yscale. + xto_nicesize = g_xdefault_scale / g_xndcto_p + yto_nicesize = g_ydefault_scale / g_yndcto_p + + # The first segment is drawn at (X0,Y0). The separation between + # characters is DX,DY. A segment is drawn as a block if the polytext + # flag is set, otherwise each character is drawn individually. + + x = x0 * g_dx + g_x1 + y = y0 * g_dy + g_y1 + dx = gki_dx * g_dx + dy = gki_dy * g_dy + + for (ip=seg; Memc[ip] != EOS; ip=ip+1) { + # Process the font control character heading the next segment. + font = Memc[ip] + ip = ip + 1 + + # Draw the segment. + while (Memc[ip] != EOS) { + # Clip leading out of bounds characters. + for (; Memc[ip] != EOS; ip=ip+1) { + x1 = x + x2 = x1 + cw * xto_nicesize + y1 = y + y2 = y1 + ch * yto_nicesize + + if (x1 >= g_x1 && x2 <= g_x2 && y1 >= g_y1 && y2 <= g_y2) + break + else { + x = x + dx + y = y + dy + } + + if (polytext == NO) { + ip = ip + 1 + break + } + } + + # Coords of first char to be drawn. + xstart = x + ystart = y + + # Move OP to first out of bounds char. + for (op=ip; Memc[op] != EOS; op=op+1) { + x1 = x + x2 = x1 + cw * xto_nicesize + y1 = y + y2 = y1 + ch * yto_nicesize + + if (x1 <= g_x1 || x2 >= g_x2 || y1 <= g_y1 || y2 >= g_y2) + break + else { + x = x + dx + y = y + dy + } + + if (polytext == NO) { + op = op + 1 + break + } + } + + # Count number of inbounds chars. + seglen = op - ip + + # Leave OP pointing to the end of this segment. + if (polytext == NO) + op = ip + 1 + else { + while (Memc[op] != EOS) + op = op + 1 + } + + # Compute X,Y of next segment. + newx = xstart + (dx * (op - ip)) + newy = ystart + dy + + # Quit if no inbounds chars. + if (seglen == 0) { + x = newx + y = newy + ip = op + next + } + + # Output the inbounds chars. + + first = ip + x = xstart + y = ystart + + while (seglen > 0 && (polytext == YES || ip == first)) { + call ccp_drawchar (Memc[ip], nint(x), nint(y), cw, ch, + orien, font, quality) + ip = ip + 1 + seglen = seglen - 1 + x = x + dx + y = y + dy + } + + x = newx + y = newy + ip = op + } + } + + call sfree (sp) +end + + +# CCX_SEGMENT -- Process the text string into segments, in the process +# converting from type short to char. The only text attribute that can +# change within a string is the font, so segments are broken by \fI, \fG, +# etc. font select sequences embedded in the text. The segments are encoded +# sequentially in the output string. The first character of each segment is +# the font number. A segment is delimited by EOS. A font number of EOS +# marks the end of the segment list. The output string is assumed to be +# large enough to hold the segmented text string. + +int procedure ccx_segment (text, n, out, start_font) + +short text[ARB] # input text +int n # number of characters in text +char out[ARB] # output string +int start_font # initial font code + +int ip, op +int totlen, font + +begin + out[1] = start_font + totlen = 0 + op = 2 + + for (ip=1; ip <= n; ip=ip+1) { + if (text[ip] == '\\' && text[ip+1] == 'f') { + # Select font. + out[op] = EOS + op = op + 1 + ip = ip + 2 + + switch (text[ip]) { + case 'B': + font = GT_BOLD + case 'I': + font = GT_ITALIC + case 'G': + font = GT_GREEK + default: + font = GT_ROMAN + } + + out[op] = font + op = op + 1 + + } else { + # Deposit character in segment. + out[op] = text[ip] + op = op + 1 + totlen = totlen + 1 + } + } + + # Terminate last segment and add null segment. + + out[op] = EOS + out[op+1] = EOS + + return (totlen) +end + + +# CCX_PARAMETERS -- Set the text drawing parameters, i.e., the coordinates +# of the lower left corner of the first character to be drawn, the spacing +# between characters, and the polytext flag. Input consists of the coords +# of the text string, the length of the string, and the text attributes +# defining the character size, justification in X and Y of the coordinates, +# and orientation of the string. All coordinates are in GKI units. + +procedure ccx_parameters (xc, yc, totlen, x0, y0, dx, dy, polytext, orien) + +int xc, yc # coordinates at which string is to be drawn +int totlen # number of characters to be drawn +int x0, y0 # lower left corner of first char to be drawn +int dx, dy # step in X and Y between characters +int polytext # OK to output text segment all at once +int orien # rotation angle of characters + +pointer tx +int up, path +real dir, sz, ch, cw, cosv, sinv, space, xto_nicesize, yto_nicesize +real xsize, ysize, xvlen, yvlen, xu, yu, xv, yv, p, q, xtmp, ytmp +include "ccp.com" + +begin + tx = CCP_TXAP(g_cc) + + # Compute correction factors for absolute physical character sizes. + # This also removes any warping due to different xscale, yscale. + xto_nicesize = g_xdefault_scale / g_xndcto_p + yto_nicesize = g_ydefault_scale / g_yndcto_p + + # Get character sizes in GKI(plotter) coords; scale y (ch) dimension + # to that of x for absolute scale systems that are different in x,y. + + sz = GKI_UNPACKREAL (TX_SIZE(tx)) + ch = CCP_CHARHEIGHT(g_cc,1) * sz + cw = CCP_CHARWIDTH(g_cc,1) * sz + + # Compute the character rotation angle. This is independent of the + # direction in which characters are drawn. A character up vector of + # 90 degrees (normal) corresponds to a rotation angle of zero. + + up = TX_UP(tx) + orien = up - 90 + + # Determine the direction in which characters are to be plotted. + # This depends on both the character up vector and the path, which + # is defined relative to the up vector. + + path = TX_PATH(tx) + switch (path) { + case GT_UP: + dir = up + case GT_DOWN: + dir = up - 180 + case GT_LEFT: + dir = up + 90 + default: # GT_NORMAL, GT_RIGHT + dir = up - 90 + } + + # ------- DX, DY --------- + # Convert the direction vector into the step size between characters. + # Note CW and CH are in GKI coordinates, hence DX and DY are too. + # Additional spacing of some fraction of the character size is used + # if TX_SPACING is nonzero. + + dir = -DEGTORAD(dir) + cosv = cos (dir) + sinv = sin (dir) + + # Correct for spacing (unrotated and unscaled). + space = (1.0 + TX_SPACING(tx)) + if (path == GT_UP || path == GT_DOWN) + p = ch * space + else + p = cw * space + q = 0 + + # Correct for rotation, scaling differences, and absolute size. + dx = ( p * cosv + q * sinv) * xto_nicesize + dy = (-p * sinv + q * cosv) * yto_nicesize + + # ------- XU, YU --------- + # Determine the coordinates of the center of the first character req'd + # to justify the string, assuming dimensionless characters spaced on + # centers DX,DY apart. + + xvlen = dx * (totlen - 1) + yvlen = dy * (totlen - 1) + + switch (TX_HJUSTIFY(tx)) { + case GT_CENTER: + xu = - (xvlen / 2.0) + case GT_RIGHT: + # If right justify and drawing to the left, no offset req'd. + if (xvlen < 0) + xu = 0 + else + xu = -xvlen + default: # GT_LEFT, GT_NORMAL + # If left justify and drawing to the left, full offset right req'd. + if (xvlen < 0) + xu = -xvlen + else + xu = 0 + } + + switch (TX_VJUSTIFY(tx)) { + case GT_CENTER: + yu = - (yvlen / 2.0) + case GT_TOP: + # If top justify and drawing downward, no offset req'd. + if (yvlen < 0) + yu = 0 + else + yu = -yvlen + default: # GT_BOTTOM, GT_NORMAL + # If bottom justify and drawing downward, full offset up req'd. + if (yvlen < 0) + yu = -yvlen + else + yu = 0 + } + + # ------- XV, YV --------- + # Compute the offset from the center of a single character required + # to justify that character, given a particular character up vector. + # (This could be combined with the above case but is clearer if + # treated separately.) + + p = -DEGTORAD(orien) + cosv = cos(p) + sinv = sin(p) + + # Compute the rotated character size in X and Y. + xsize = abs ( cw * cosv + ch * sinv) * xto_nicesize + ysize = abs (-cw * sinv + ch * cosv) * yto_nicesize + + switch (TX_HJUSTIFY(tx)) { + case GT_CENTER: + xv = 0 + case GT_RIGHT: + xv = - (xsize / 2.0) + default: # GT_LEFT, GT_NORMAL + xv = xsize / 2 + } + + switch (TX_VJUSTIFY(tx)) { + case GT_CENTER: + yv = 0 + case GT_TOP: + yv = - (ysize / 2.0) + default: # GT_BOTTOM, GT_NORMAL + yv = ysize / 2 + } + + # ------- X0, Y0 --------- + # The center coordinates of the first character to be drawn are given + # by the reference position plus the string justification vector plus + # the character justification vector. + + x0 = xc + xu + xv + y0 = yc + yu + yv + + # The character drawing primitive requires the coordinates of the + # lower left corner of the character (irrespective of orientation). + # Compute the vector from the center of a character to the lower left + # corner of a character, rotate to the given orientation, and correct + # the starting coordinates by addition of this vector. + + p = - (cw / 2.0) + q = - (ch / 2.0) + + xtmp = ( p * cosv + q * sinv) * xto_nicesize + ytmp = (-p * sinv + q * cosv) * yto_nicesize + + x0 = x0 + xtmp + y0 = y0 + ytmp + + # ------- POLYTEXT --------- + # Set the polytext flag. Polytext output is possible only if chars + # are to be drawn to the right with no extra spacing between chars. + + if (abs(dy) == 0 && dx == cw) + polytext = YES + else + polytext = NO +end diff --git a/sys/gio/calcomp/ccptxset.x b/sys/gio/calcomp/ccptxset.x new file mode 100644 index 00000000..f2f4f040 --- /dev/null +++ b/sys/gio/calcomp/ccptxset.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ccp.h" + +# CCP_TXSET -- Set the text drawing attributes. + +procedure ccp_txset (gki) + +short gki[ARB] # attribute structure + +pointer tx +include "ccp.com" + +begin + tx = CCP_TXAP(g_cc) + + TX_UP(tx) = gki[GKI_TXSET_UP] + TX_PATH(tx) = gki[GKI_TXSET_P ] + TX_HJUSTIFY(tx) = gki[GKI_TXSET_HJ] + TX_VJUSTIFY(tx) = gki[GKI_TXSET_VJ] + TX_FONT(tx) = gki[GKI_TXSET_F ] + TX_QUALITY(tx) = gki[GKI_TXSET_Q ] + TX_COLOR(tx) = gki[GKI_TXSET_CI] + + TX_SPACING(tx) = GKI_UNPACKREAL (gki[GKI_TXSET_SP]) + TX_SIZE(tx) = gki[GKI_TXSET_SZ] +end diff --git a/sys/gio/calcomp/doc/ccpspecs.hlp b/sys/gio/calcomp/doc/ccpspecs.hlp new file mode 100644 index 00000000..fae12e4e --- /dev/null +++ b/sys/gio/calcomp/doc/ccpspecs.hlp @@ -0,0 +1,384 @@ +.help +\fBSpecifications for IRAF Calcomp kernel -- (CCP package)\fR + + +The Calcomp kernel (package prefix "ccp") will implement selected GKI +instructions, using only calls to the Calcomp routines \fBplots\fR, +\fBplot\fR, \fBnewpen\fR and \fBsymbol\fR. + + +There are two sub-components of the CCP package: 1) the kernel driver +task allowing a user to send a specified graphics metafile to the plotter, and +2) the low-level kernel routines which implement specific GKI instructions, +and which make the only calls to the Calcomp library. + + +.nh +\fBCL interface -- task CALCOMP\fR + + +The driver task, \fBcalcomp\fR, allows a user to direct an existing GKI metacode +file to a particular Calcomp plotter under control of a set of CL parameters. +The task is loaded either by being run directly from the CL as a task, or by +being invoked through inter-process control following a write-to-pseudofile +containing the GKI_OPENWS metacode instruction. The task may +optionally control certain kinds of debug output. + +.nf +CL parameters to the kernel driver task \fBcalcomp\fR: + +input,s,a,,,,"input metacode file" +device,s,h,"calcomp",,,"output device" +generic,b,h,no,,,"ignore remaining kernel dependent parameters" +debug,b,h,no,,,"print decoded graphics instructions during processing" +verbose,b,h,no,,,"print elements of polylines, etc. in debug mode" +gkiunits,b,h,no,,,"print coordinates in GKI rather than NDC units" +xscale,r,h,INDEF,0.0,,"plotter x = GKI_NDC_X * xscale" +yscale,r,h,INDEF,0.0,,"plotter y = GKI_NDC_Y * yscale" +txquality,s,h,"normal","normal|low|high",,"character quality; n=from metacode" +lwtype,s,h,"ntracing","ntracing|penchange",,"bold line/text implementation" +ltover,b,h,no,,,"override line type simulation" +lwover,b,h,no,,,"override line width simulation" +lcover,b,h,no,,,"override line color implementation by penchange" +dashlen,r,h,INDEF,0.0,,"dashed line dash length, pltr units; 0.5 reasonable" +gaplen,r,h,INDEF,0.0,,"dashed line gap length, pltr units; 0.1 reasonable" +plwsep,r,hl,INDEF,0.,,"polyline width separation for ntracing; 0.005 reasonable" + +.fi + + +.nh +\fBSuggested GRAPHCAP entry for calcomp plotter\fR + +.nf + + p5|calcomp|calcomp pen plotter:\ + :kf=xcalcomp.e:tn=calcomp:co#132:li#66:xr#32767:yr#5375:\ + :ch#.0294:cw#.0125:xs#1.664564:ys#0.27305:\ + :PU=inches:MP#.0254:DL#.50:GL#.10:PW#.005:\ + :DD=plot!calcomp,/tmp/gcaXXXXXX,\ + !{ cd /tmp; nice /local/bin/plotX -Tcalcomp -W=1 $F |\ + nice /usr/bin/plot -Tcalcomp; rm $F; }&: + + #xs 1.664564 # maximum x in meters; max at .002 inches step size + #ys .27305000 # maximum y in meters; 10.75 inch paper + #xr 32767 # max resolution in x; limited by GKI short int coords + #yr 5375 # max resolution in y; 10.75 inches at .002 inches step + #PU inches # plotter units + #MP 0.0254 # meters per plotter unit + #DL 0.5000 # dash length in plotter units + #GL 0.1000 # gap length in plotter units + #PW 0.0050 # n-tracing (bold line simul.) width sep. in pltr units + #if yscale not set by kernel, g_yndcto_p = GKI_MAXNDC/(MP*yr); 32767/10.75" + #if xscale not set by kernel, g_xndcto_p = g_yndcto_p; square aspect ratio + +.fi + + +.nh +\fBInterface between CALCOMP task and lower-level kernel routines\fR + + +Two kernel routines will normally be called from outside the GKI +instruction-stream decoding facility (as from the driver task): + +.nf + ccp_open (devname, dd) + + devname: device name of desired Calcomp plotter (must have + entry in graphcap file) + + dd: array of entry point addresses to lower-level kernel + routines + + discussion: linking to multiple Calcomp plotters is a + site-dependent function. Ordinarily devname is + ignored; if this kernel is called, output will go + to the device initialized by the Calcomp library. + See ccp_openws. + + + ccp_close () + + discussion: causes a Calcomp "newframe" -- resets origin to + right of last previously-plotted point. + + +.fi +.nh +\fBLow-level kernel routines\fR + + +All remaining kernel routines will normally be called either by ccp_open or +by gki_execute, or by each other. Following are descriptions of the +implementation of GKI instructions: +.nf + + GKI_EOF + + Not implemented; it should be trapped outside the kernel, as in + \fBgki_execute\fR. + + GKI_OPENWS + + ccp_openws (devname, len_devname, mode) + + devname; len_devname: + + name of plotter, name length, if not present in metafile + + mode: + + file access mode for gki metafile; if NEWFILE, a Calcomp + "newframe" (reorigin to right of previous plot) will + occur; if APPEND mode, no newframe. + + discussion: + + There is no output metafile; device connection and any + site-specific spooling is handled below this level. + Note that there must be a graphcap entry for devname. + + GKI_CLOSEWS + + ccp_closews () + + discussion: + + As there is no output metafile, this is a noop. + + GKI_REACTIVATEWS + + Not implemented. + + GKI_DEACTIVATEWS + + Not implemented. + + GKI_MFTITLE + + Not implemented. + + GKI_CLEARWS + + ccp_clear () + + discussion: + + Implemented only by a Calcomp "newframe"; there is no + output metacode file for spooling at this level. + + GKI_CANCEL + + Not implemented, since there is no buffered output. + + GKI_FLUSH + + Not implemented. + + GKI_POLYLINE + + ccp_polyline (p, npts) + + p: array of points (x1, y1, x2, y2, ...) + + npts: number of pairs + + discussion: + + To GKI, ccp_polyline will appear pretty normal; due to + the lack of settable parameters like dashed-line in + Calcomp, such features are implemented in further layers + between ccp_polyline and the actual Calcomp vector-draw + routine. See kernel task parameters lwtype, lwover, and + ltover for line width and type control. + + GKI_POLYMARKER + + ccp_polymarker (p, npts) + + arguments: same as above + + discussion: + + Ccp_polymarker will merely dot the location at the + coordinate passed in; more complicated marker + symbols will be assumed to have been handled above, for + purposes of clipping, and will be drawn with ccp_polyline + at this level. + + GKI_TEXT + + ccp_text (x, y, text, nchar) + + x, y: + + NDC coordinates of text stream; note that the JUSTIFY + parameters in GSET determine where these coordinates are + relative to the text characters. + + text: array of type short characters + + nchar: number of chars in text + + discussion: + + The same levels of text quality will be supported as in + the stdgraph kernel; normal is taken from the metacode + request, medium and high fonts are stroke text, while low + quality is Calcomp hardware text. Depending on the + particular plotter controller at each site, low quality + text may or may not be significantly faster than stroke + text. + + The special Calcomp symbols numbered 0 - 15 in the + Calcomp symbol library are invoked by characters with + ASCII values 0 - 15. When using hardware text generation, + the ASCII symbol requested will be mapped to the Calcomp + set if possible; otherwise, a default "indefinite" character + will appear. + + GKI_FILLAREA + + ccp_fillarea (p, npts) + + p, npts: same as above for ccp_polyline + + discussion: + + With Calcomp, fillarea could only be implemented by + simulating with hatching patterns, a time-consuming + process for a pen plotter. We may or may not choose + to do this, depending upon users' needs. For the + very similar Versaplot kernel which may follow, it + should definitely be implemented, using Versaplot's + \fBtone\fR call. Initially, it will only be implemented + here with a call to ccp_polyline for the border. + + GKI_PUTCELLARRAY + + Not implemented. + + GKI_SETCURSOR + + Not implemented. + + GKI_PLSET + + ccp_plset (gki) + + gki: attribute structure decoded by gki + + discussion: + + Line types documented in the GIO manual will be + implemented in software except for "erase", unless the + CL parameter to the CALCOMP task "ltover" is on, in + which case all lines drawn will be solid. See task + parameters dash and gap. In the future, line types + numbered higher than 4 may be implemented using various + combinations of dashes and dots as in Morse code. Line + width and color may be similarly implemented or overridden; + if not overridden, line width will be done by default using + n-tracing (n = nearest integer value of line width) or by a + penchange, under control of task parameter "lwtype". + + GKI_PMSET + + ccp_pmset (gki) + + gki, discussion: Same as for ccp_plset. + + GKI_TXSET + + ccp_txset (gki) + + gki, discussion: + + Internal flags are set from structure gki controlling + text up vector, path relative to up vector, horizontal + and vertical justification, font, quality, color, + spacing, and size. For high-quality text, all flags are + implemented (color by a pen change, with optional + override); see GKI_TEXT discussion. + + GKI_FASET + + ccp_faset (gki) + + gki, discussion: + + Internal flags are set for fill area style and color. + If we decide to implement fill area in software (the only + way for Calcomp), we will use GKS conventions wherever + possible. + + GKI_GETCURSOR + + Not implemented. The Calcomp \fBwhere\fR routine would only + duplicate GCURPOS in GIO. + + GKI_CURSORVALUE + + Not implemented; not an interactive device. + + GKI_GETCELLARRAY + + Not implemented; not a storage device. + + GKI_CELLARRAY + + Not implemented. + + GKI_ESCAPE + + ccp_escape (fn, instruction, nwords) + + fn: escape function code + + instruction, nwords: + + Nwords-long array of short integers containing the + instruction sequence. + + discussion: + + A high-level task may pass the NDC-to-plotter units + coordinate scaling factor down into the kernel to + permit exact scaling. The scale factors will be + set in common to allow fast access by the ccp_draw + routine. + + GKI_ESCAPE = BOI 25 L FN N DC + + L(i) 5 + N + FN(i) escape function code + N(i) number of escape data words + DC(i) escape data words + + 1) xndc_to_plotter: + + FN = ESC_XNDCTO_P (currently = 1 in ccp.h) + N = number of characters in the scale specification + DC = array of N short integers containing character- + packed scale (must be achtsc'd then ctod'd to + get x scale) + + 2) yndc_to_plotter: + + FN = ESC_YNDCTO_P (currently = 2 in ccp.h) + N = same as in (1) + DC = same as in (1) + + The macros ESC_*NDCTO_P, currently defined in ccp.h, should + probably be defined in a gki-public place like gki.h. + + + GKI_SETWCS + + Not implemented. + + GKI_GETWCS + + Not implemented. +.fi diff --git a/sys/gio/calcomp/font.com b/sys/gio/calcomp/font.com new file mode 100644 index 00000000..ec1b0ec9 --- /dev/null +++ b/sys/gio/calcomp/font.com @@ -0,0 +1,207 @@ +# CHRTAB -- Table of strokes for the printable ASCII characters. Each character +# is encoded as a series of strokes. Each stroke is expressed by a single +# integer containing the following bitfields: +# +# 2 1 +# 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 +# | | | | | | | +# | | | +---------+ +---------+ +# | | | | | +# | | | X Y +# | | | +# | | +-- pen up/down +# | +---- begin paint (not used at present) +# +------ end paint (not used at present) +# +#------------------------------------------------------------------------------ + +# Define the database. + +short chridx[96] # character index in chrtab +short chrtab[800] # stroke data to draw the characters + +# Index into CHRTAB of each printable character (starting with SP). + +data (chridx(i), i=01,05) / 1, 3, 12, 21, 30/ +data (chridx(i), i=06,10) / 45, 66, 79, 85, 92/ +data (chridx(i), i=11,15) / 99, 106, 111, 118, 121/ +data (chridx(i), i=16,20) / 128, 131, 141, 145, 154/ +data (chridx(i), i=21,25) / 168, 177, 187, 199, 203/ +data (chridx(i), i=26,30) / 221, 233, 246, 259, 263/ +data (chridx(i), i=31,35) / 268, 272, 287, 307, 314/ +data (chridx(i), i=36,40) / 327, 336, 344, 352, 359/ +data (chridx(i), i=41,45) / 371, 378, 385, 391, 398/ +data (chridx(i), i=46,50) / 402, 408, 413, 425, 433/ +data (chridx(i), i=51,55) / 445, 455, 468, 473, 480/ +data (chridx(i), i=56,60) / 484, 490, 495, 501, 506/ +data (chridx(i), i=61,65) / 511, 514, 519, 523, 526/ +data (chridx(i), i=66,70) / 529, 543, 554, 563, 574/ +data (chridx(i), i=71,75) / 585, 593, 607, 615, 625/ +data (chridx(i), i=76,80) / 638, 645, 650, 663, 671/ +data (chridx(i), i=81,85) / 681, 692, 703, 710, 723/ +data (chridx(i), i=86,90) / 731, 739, 743, 749, 754/ +data (chridx(i), i=91,95) / 759, 764, 776, 781, 793/ +data (chridx(i), i=96,96) / 801/ + +# Stroke data. + +data (chrtab(i), i=001,005) / 36, 1764, 675, 29328, 585/ +data (chrtab(i), i=006,010) / 21063, 21191, 21193, 21065, 29383/ +data (chrtab(i), i=011,015) / 1764, 355, 29023, 351, 29027/ +data (chrtab(i), i=016,020) / 931, 29599, 927, 29603, 1764/ +data (chrtab(i), i=021,025) / 603, 29066, 842, 29723, 1302/ +data (chrtab(i), i=026,030) / 28886, 143, 29839, 1764, 611/ +data (chrtab(i), i=031,035) / 29256, 78, 20810, 21322, 21581/ +data (chrtab(i), i=036,040) / 21586, 21334, 20822, 20569, 20573/ +data (chrtab(i), i=041,045) / 20833, 21345, 29789, 1764, 419/ +data (chrtab(i), i=046,050) / 20707, 20577, 20574, 20700, 20892/ +data (chrtab(i), i=051,055) / 21022, 21025, 20899, 1187, 28744/ +data (chrtab(i), i=056,060) / 717, 21194, 21320, 21512, 21642/ +data (chrtab(i), i=061,065) / 21645, 21519, 21327, 21197, 1764/ +data (chrtab(i), i=066,070) / 1160, 20700, 20704, 20835, 21027/ +data (chrtab(i), i=071,075) / 21152, 21149, 20561, 20556, 20744/ +data (chrtab(i), i=076,080) / 21192, 29841, 1764, 611, 21023/ +data (chrtab(i), i=081,085) / 21087, 21155, 21091, 1764, 739/ +data (chrtab(i), i=086,090) / 21087, 21018, 21009, 21068, 29384/ +data (chrtab(i), i=091,095) / 1764, 547, 21151, 21210, 21201/ +data (chrtab(i), i=096,100) / 21132, 29192, 1764, 93, 29774/ +data (chrtab(i), i=101,105) / 608, 29259, 78, 29789, 1764/ +data (chrtab(i), i=106,110) / 604, 29260, 84, 29780, 1764/ +data (chrtab(i), i=111,115) / 516, 21062, 21065, 21001, 21000/ +data (chrtab(i), i=116,120) / 21064, 1764, 84, 29780, 1764/ +data (chrtab(i), i=121,125) / 585, 21063, 21191, 21193, 21065/ +data (chrtab(i), i=126,130) / 21191, 1764, 72, 29859, 1764/ +data (chrtab(i), i=131,135) / 419, 20573, 20558, 20872, 21320/ +data (chrtab(i), i=136,140) / 21646, 21661, 21347, 20899, 1764/ +data (chrtab(i), i=141,145) / 221, 21155, 29320, 1764, 95/ +data (chrtab(i), i=146,150) / 20835, 21411, 21663, 21655, 20556/ +data (chrtab(i), i=151,155) / 20552, 29832, 1764, 95, 20899/ +data (chrtab(i), i=156,160) / 21347, 21663, 21658, 21334, 29270/ +data (chrtab(i), i=161,165) / 854, 5266, 21644, 21320, 20872/ +data (chrtab(i), i=166,170) / 28749, 1764, 904, 21411, 21283/ +data (chrtab(i), i=171,175) / 20561, 20559, 21391, 911, 13455/ +data (chrtab(i), i=176,180) / 1764, 136, 21320, 21645, 21652/ +data (chrtab(i), i=181,185) / 21337, 20889, 20565, 20579, 29859/ +data (chrtab(i), i=186,190) / 1764, 83, 20888, 21336, 21651/ +data (chrtab(i), i=191,195) / 21645, 21320, 20872, 20557, 20563/ +data (chrtab(i), i=196,200) / 20635, 29347, 1764, 99, 21667/ +data (chrtab(i), i=201,205) / 29064, 1764, 355, 20575, 20570/ +data (chrtab(i), i=206,210) / 20822, 20562, 20556, 20808, 21384/ +data (chrtab(i), i=211,215) / 21644, 21650, 21398, 20822, 918/ +data (chrtab(i), i=216,220) / 5274, 21663, 21411, 20835, 1764/ +data (chrtab(i), i=221,225) / 648, 21584, 21656, 21662, 21347/ +data (chrtab(i), i=226,230) / 20899, 20574, 20568, 20883, 21331/ +data (chrtab(i), i=231,235) / 21656, 1764, 602, 21210, 21207/ +data (chrtab(i), i=236,240) / 21079, 21082, 21207, 592, 21069/ +data (chrtab(i), i=241,245) / 21197, 21200, 21072, 21197, 1764/ +data (chrtab(i), i=246,250) / 602, 21146, 21143, 21079, 21082/ +data (chrtab(i), i=251,255) / 21143, 585, 21132, 21136, 21072/ +data (chrtab(i), i=256,260) / 21071, 21135, 1764, 988, 20628/ +data (chrtab(i), i=261,265) / 29644, 1764, 1112, 28824, 144/ +data (chrtab(i), i=266,270) / 29776, 1764, 156, 21460, 28812/ +data (chrtab(i), i=271,275) / 1764, 221, 20704, 20899, 21218/ +data (chrtab(i), i=276,280) / 21471, 21466, 21011, 21007, 521/ +data (chrtab(i), i=281,285) / 20999, 21127, 21129, 21001, 21127/ +data (chrtab(i), i=286,290) / 1764, 908, 20812, 20560, 20571/ +data (chrtab(i), i=291,295) / 20831, 21407, 21659, 21651, 21521/ +data (chrtab(i), i=296,300) / 21393, 21331, 21335, 21210, 21018/ +data (chrtab(i), i=301,305) / 20887, 20883, 21009, 21201, 21331/ +data (chrtab(i), i=306,310) / 1764, 72, 20963, 21219, 29768/ +data (chrtab(i), i=311,315) / 210, 5074, 1764, 99, 21411/ +data (chrtab(i), i=316,320) / 21663, 21658, 21398, 20566, 918/ +data (chrtab(i), i=321,325) / 5266, 21644, 21384, 20552, 20579/ +data (chrtab(i), i=326,330) / 1764, 1165, 21320, 20872, 20557/ +data (chrtab(i), i=331,335) / 20574, 20899, 21347, 29854, 1764/ +data (chrtab(i), i=336,340) / 99, 21347, 21662, 21645, 21320/ +data (chrtab(i), i=341,345) / 20552, 20579, 1764, 99, 20552/ +data (chrtab(i), i=346,350) / 29832, 86, 13078, 99, 29859/ +data (chrtab(i), i=351,355) / 1764, 99, 20552, 86, 13078/ +data (chrtab(i), i=356,360) / 99, 29859, 1764, 722, 21650/ +data (chrtab(i), i=361,365) / 29832, 1165, 4936, 20872, 20557/ +data (chrtab(i), i=366,370) / 20574, 20899, 21347, 29854, 1764/ +data (chrtab(i), i=371,375) / 99, 28744, 85, 5269, 1160/ +data (chrtab(i), i=376,380) / 29859, 1764, 291, 29603, 611/ +data (chrtab(i), i=381,385) / 4680, 328, 29576, 1764, 77/ +data (chrtab(i), i=386,390) / 20872, 21256, 21581, 29795, 1764/ +data (chrtab(i), i=391,395) / 99, 28744, 1160, 20887, 82/ +data (chrtab(i), i=396,400) / 13475, 1764, 99, 20552, 29832/ +data (chrtab(i), i=401,405) / 1764, 72, 20579, 21077, 21603/ +data (chrtab(i), i=406,410) / 29768, 1764, 72, 20579, 21640/ +data (chrtab(i), i=411,415) / 29859, 1764, 94, 20899, 21347/ +data (chrtab(i), i=416,420) / 21662, 21645, 21320, 20872, 20557/ +data (chrtab(i), i=421,425) / 20574, 862, 29859, 1764, 72/ +data (chrtab(i), i=426,430) / 20579, 21411, 21663, 21656, 21396/ +data (chrtab(i), i=431,435) / 20564, 1764, 94, 20557, 20872/ +data (chrtab(i), i=436,440) / 21320, 21645, 21662, 21347, 20899/ +data (chrtab(i), i=441,445) / 20574, 536, 29828, 1764, 72/ +data (chrtab(i), i=446,450) / 20579, 21411, 21663, 21657, 21398/ +data (chrtab(i), i=451,455) / 20566, 918, 13448, 1764, 76/ +data (chrtab(i), i=456,460) / 20808, 21384, 21644, 21649, 21397/ +data (chrtab(i), i=461,465) / 20822, 20570, 20575, 20835, 21411/ +data (chrtab(i), i=466,470) / 29855, 1764, 648, 21155, 99/ +data (chrtab(i), i=471,475) / 29923, 1764, 99, 20557, 20872/ +data (chrtab(i), i=476,480) / 21320, 21645, 29859, 1764, 99/ +data (chrtab(i), i=481,485) / 21064, 29795, 1764, 99, 20808/ +data (chrtab(i), i=486,490) / 21141, 21448, 29923, 1764, 99/ +data (chrtab(i), i=491,495) / 29832, 72, 29859, 1764, 99/ +data (chrtab(i), i=496,500) / 21079, 29256, 599, 13411, 1764/ +data (chrtab(i), i=501,505) / 99, 21667, 20552, 29832, 1764/ +data (chrtab(i), i=506,510) / 805, 20965, 20935, 29447, 1764/ +data (chrtab(i), i=511,515) / 99, 29832, 1764, 421, 21221/ +data (chrtab(i), i=516,520) / 21191, 29063, 1764, 288, 21091/ +data (chrtab(i), i=521,525) / 29600, 1764, 3, 29891, 1764/ +data (chrtab(i), i=526,530) / 547, 29341, 1764, 279, 21207/ +data (chrtab(i), i=531,535) / 21396, 21387, 21127, 20807, 20555/ +data (chrtab(i), i=536,540) / 20558, 20753, 21201, 21391, 907/ +data (chrtab(i), i=541,545) / 13447, 1764, 99, 28744, 76/ +data (chrtab(i), i=546,550) / 4424, 21256, 21516, 21523, 21271/ +data (chrtab(i), i=551,555) / 20823, 20563, 1764, 981, 21271/ +data (chrtab(i), i=556,560) / 20823, 20563, 20556, 20808, 21256/ +data (chrtab(i), i=561,565) / 29642, 1764, 1043, 4887, 20823/ +data (chrtab(i), i=566,570) / 20563, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=571,575) / 1032, 29731, 1764, 80, 5136/ +data (chrtab(i), i=576,580) / 21523, 21271, 20823, 20563, 20556/ +data (chrtab(i), i=581,585) / 20808, 21256, 29707, 1764, 215/ +data (chrtab(i), i=586,590) / 29591, 456, 20958, 21153, 21409/ +data (chrtab(i), i=591,595) / 29727, 1764, 67, 20800, 21248/ +data (chrtab(i), i=596,600) / 21508, 29719, 1043, 21271, 20823/ +data (chrtab(i), i=601,605) / 20563, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=606,610) / 1764, 99, 28744, 83, 4439/ +data (chrtab(i), i=611,615) / 21271, 21523, 29704, 1764, 541/ +data (chrtab(i), i=616,620) / 21019, 21147, 21149, 21021, 21147/ +data (chrtab(i), i=621,625) / 533, 21077, 29256, 1764, 541/ +data (chrtab(i), i=626,630) / 21019, 21147, 21149, 21021, 21147/ +data (chrtab(i), i=631,635) / 533, 21077, 21058, 20928, 20736/ +data (chrtab(i), i=636,640) / 28802, 1764, 99, 28744, 84/ +data (chrtab(i), i=641,645) / 29530, 342, 13320, 1764, 483/ +data (chrtab(i), i=646,650) / 21089, 21066, 29384, 1764, 87/ +data (chrtab(i), i=651,655) / 28744, 584, 21076, 84, 4375/ +data (chrtab(i), i=656,660) / 20951, 21076, 21207, 21399, 21588/ +data (chrtab(i), i=661,665) / 29768, 1764, 87, 28744, 83/ +data (chrtab(i), i=666,670) / 20823, 21271, 21523, 29704, 1764/ +data (chrtab(i), i=671,675) / 83, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=676,680) / 21523, 21271, 20823, 20563, 1764/ +data (chrtab(i), i=681,685) / 87, 28736, 83, 20823, 21271/ +data (chrtab(i), i=686,690) / 21523, 21516, 21256, 20808, 20556/ +data (chrtab(i), i=691,695) / 1764, 1047, 29696, 1036, 21256/ +data (chrtab(i), i=696,700) / 20808, 20556, 20563, 20823, 21271/ +data (chrtab(i), i=701,705) / 21523, 1764, 87, 28744, 83/ +data (chrtab(i), i=706,710) / 20823, 21271, 29716, 1764, 74/ +data (chrtab(i), i=711,715) / 20808, 21256, 21514, 21518, 21264/ +data (chrtab(i), i=716,720) / 20816, 20562, 20565, 20823, 21271/ +data (chrtab(i), i=721,725) / 21461, 1764, 279, 29591, 970/ +data (chrtab(i), i=726,730) / 21320, 21128, 21002, 21025, 1764/ +data (chrtab(i), i=731,735) / 87, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=736,740) / 1032, 29719, 1764, 151, 21064/ +data (chrtab(i), i=741,745) / 29719, 1764, 87, 20808, 21077/ +data (chrtab(i), i=746,750) / 21320, 29783, 1764, 151, 29704/ +data (chrtab(i), i=751,755) / 136, 29719, 1764, 87, 21064/ +data (chrtab(i), i=756,760) / 320, 29783, 1764, 151, 21527/ +data (chrtab(i), i=761,765) / 20616, 29704, 1764, 805, 21157/ +data (chrtab(i), i=766,770) / 21026, 21017, 20951, 20822, 20949/ +data (chrtab(i), i=771,775) / 21011, 21001, 21127, 21255, 1764/ +data (chrtab(i), i=776,780) / 611, 29273, 594, 29256, 1764/ +data (chrtab(i), i=781,785) / 485, 21093, 21218, 21209, 21271/ +data (chrtab(i), i=786,790) / 21398, 21269, 21203, 21193, 21063/ +data (chrtab(i), i=791,795) / 29127, 1764, 83, 20758, 20950/ +data (chrtab(i), i=796,800) / 21265, 21457, 29844, 1764, 0/ diff --git a/sys/gio/calcomp/font.h b/sys/gio/calcomp/font.h new file mode 100644 index 00000000..c33dc6ee --- /dev/null +++ b/sys/gio/calcomp/font.h @@ -0,0 +1,29 @@ +# NCAR font definitions. + +define CHARACTER_START 32 +define CHARACTER_END 126 +define CHARACTER_HEIGHT 26 +define CHARACTER_WIDTH 17 + +define FONT_LEFT 0 +define FONT_CENTER 9 +define FONT_RIGHT 27 +define FONT_TOP 36 +define FONT_CAP 34 +define FONT_HALF 23 +define FONT_BASE 9 +define FONT_BOTTOM 0 +define FONT_WIDTH 27 +define FONT_HEIGHT 36 + +define COORD_X_START 7 +define COORD_Y_START 1 +define COORD_PEN_START 13 +define COORD_X_LEN 6 +define COORD_Y_LEN 6 +define COORD_PEN_LEN 1 + +define PAINT_BEGIN_START 14 +define PAINT_END_START 15 +define PAINT_BEGIN_LEN 1 +define PAINT_END_LEN 1 diff --git a/sys/gio/calcomp/mkpkg b/sys/gio/calcomp/mkpkg new file mode 100644 index 00000000..f4b7f8b9 --- /dev/null +++ b/sys/gio/calcomp/mkpkg @@ -0,0 +1,52 @@ +# Make the CALCOMP GIO graphics kernel. Requires the host system library +# LIB_CALCOMP, which must be callable from an IRAF program (which is not the +# same as a Fortran program). + +$checkout libccp.a lib$ +$update libccp.a +$checkin libccp.a lib$ +$call relink +$exit + +update: # update lib$x_calcomp.e + $call relink + $call install + ; + +relink: # make x_calcomp.e in local directory + $omake x_calcomp.x + $link x_calcomp.o -lccp $(LIB_CALCOMP) + ; + +install: # install in system library + $move x_calcomp.e bin$ + ; + +libccp.a: + ccpclear.x ccp.com ccp.h + ccpclose.x ccp.com ccp.h + ccpclws.x ccp.com ccp.h + ccpcolor.x ccp.com ccp.h + ccpcseg.x ccp.com ccp.h + ccpdrawch.x ccp.com ccp.h font.com font.h \ + + ccpdseg.x ccp.com ccp.h + ccpescape.x ccp.com ccp.h + ccpfa.x ccp.com ccp.h + ccpfaset.x ccp.com ccp.h + ccpfont.x ccp.com ccp.h + ccpinit.x ccp.com ccp.h + ccpltype.x ccp.com ccp.h + ccplwidth.x ccp.com ccp.h + ccpopen.x ccp.com ccp.h + ccpopenws.x ccp.com ccp.h + ccppl.x ccp.com ccp.h + ccpplset.x ccp.com ccp.h + ccppm.x ccp.com ccp.h + ccppmset.x ccp.com ccp.h + ccpreset.x ccp.com ccp.h + ccptx.x ccp.com ccp.h + ccptxset.x ccp.com ccp.h + rptheta4.x + t_calcomp.x ccp.com ccp.h + ; diff --git a/sys/gio/calcomp/rptheta4.x b/sys/gio/calcomp/rptheta4.x new file mode 100644 index 00000000..b2ee42b7 --- /dev/null +++ b/sys/gio/calcomp/rptheta4.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +define PIOVER4 (0.25 * PI) +define THREEPIOVER4 (0.75 * TWOPI) + +# RPTHETA4 -- Polar angle, Real precision, 4 arguments; from p1(x,y) to p2(x,y): +# angle between line segment p1-p2 and horizontal +x axis centered on p1; +# returned in radians; single precision (see pdtheta4). + +real procedure rptheta4 (p1x, p1y, p2x, p2y) + +real p1x,p1y, p2x,p2y # x,y of each point +real dx, dy, ang + +begin + dx = p2x - p1x + dy = p2y - p1y + + if (dx == 0.0) { + if (dy >= 0.0) { + ang = HALFPI + } else { + ang = THREEPIOVER4 + } + } else { + ang = atan (dy / dx) + if (dx < 0.0) { # 2nd or 3rd quadrant + ang = ang + PI + } else if (dy < 0.0) { # 4th quadrant + ang = ang + TWOPI + } + } + + return (ang) +end diff --git a/sys/gio/calcomp/t_calcomp.x b/sys/gio/calcomp/t_calcomp.x new file mode 100644 index 00000000..0164d043 --- /dev/null +++ b/sys/gio/calcomp/t_calcomp.x @@ -0,0 +1,125 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "ccp.h" + +define SZ_TXQUALITY 1 + +# CALCOMP -- Graphics kernel for Calcomp pen plotter output. The whole +# package is copied as much as possible from the NSPP kernel. + +procedure t_calcomp() + +int fd, list +pointer gki, sp, fname, devname +int dev[LEN_GKIDD], deb[LEN_GKIDD] +int debug, verbose, gkiunits +char txquality[SZ_TXQUALITY] +bool clgetb() +char clgetc() +real clgetr() +int clpopni(), clgfil(), open(), btoi() +int gki_fetch_next_instruction() + +include "ccp.com" + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (devname, SZ_FNAME, TY_CHAR) + + # Open list of metafiles to be decoded. + list = clpopni ("input") + + # Get parameters. + call clgstr ("device", Memc[devname], SZ_FNAME) + + if (clgetb ("generic")) { + debug = NO + verbose = NO + gkiunits = NO + g_xtask_scale = INDEF + g_xndcto_p = INDEF + g_ytask_scale = INDEF + g_yndcto_p = INDEF + g_txquality = 0 + g_lwtype = 'n' + g_ltover = false + g_lwover = true + g_lcover = false + g_dashlen = INDEF + g_gaplen = INDEF + g_plwsep = INDEF + + } else { + debug = btoi (clgetb ("debug")) + verbose = btoi (clgetb ("verbose")) + gkiunits = btoi (clgetb ("gkiunits")) + + # scale precedence: calcomp.par->metacode->graphcap->compile_time + g_xtask_scale = clgetr ("xscale") + if (!IS_INDEF (g_xtask_scale)) + g_xndcto_p = g_xtask_scale + g_ytask_scale = clgetr ("yscale") + if (!IS_INDEF (g_ytask_scale)) + g_yndcto_p = g_ytask_scale + + # Get the quality parameter for the text generator. + call clgstr ("txquality", txquality, SZ_TXQUALITY) + switch (txquality[1]) { + case 'l': + g_txquality = GT_LOW + case 'm': + g_txquality = GT_MEDIUM + case 'h': + g_txquality = GT_HIGH + default: + g_txquality = 0 # .par default is "normal" + } + + # Method of line width implementation: + g_lwtype = clgetc ("lwtype") + + # The overrides: + g_ltover = clgetb ("ltover") + g_lwover = clgetb ("lwover") + g_lcover = clgetb ("lcover") + + # Plotter line type, width control: + g_dashlen = clgetr ("dashlen") + g_gaplen = clgetr ("gaplen") + g_plwsep = clgetr ("plwsep") + } + + # Open the graphics kernel. + call ccp_open (Memc[devname], dev) + call gkp_install (deb, STDERR, verbose, gkiunits) + + # Process a list of metacode files, writing the decoded metacode + # instructions on the standard output. + + while (clgfil (list, Memc[fname], SZ_FNAME) != EOF) { + # Open input file. + iferr (fd = open (Memc[fname], READ_ONLY, BINARY_FILE)) { + call erract (EA_WARN) + next + } + + # Process the metacode instruction stream. + while (gki_fetch_next_instruction (fd, gki) != EOF) { + if (debug == YES) + call gki_execute (Mems[gki], deb) + call gki_execute (Mems[gki], dev) + } + + call close (fd) + } + + call gkp_close() + call ccp_close() + call clpcls (list) + call sfree (sp) +end diff --git a/sys/gio/calcomp/vttest.par b/sys/gio/calcomp/vttest.par new file mode 100644 index 00000000..fcbcb2ad --- /dev/null +++ b/sys/gio/calcomp/vttest.par @@ -0,0 +1,10 @@ +lname,s,hl,"ltest1.dat",,,"input polyline test file name" +tname,s,hl,"ttest3.dat",,,"input text test file name" +ltype,i,hl,1,1,6,"line type" +lwidth,i,hl,1,1,15,"line width" +mtype,i,hl,0,0,1023,"polymarker type code" +dashlen,r,hl,10000.,0.,,"length of dash in plotter units" +gaplen,r,hl,5000.,0.,,"width of gap in plotter units" +plwsep,r,hl,50.,0.,,"polyline width separation for ntracing" +option,s,hl,"l",,,"test option: {l-line; t-text; m-marker}" +device,s,hl,"vt640",,,"output device for test program" diff --git a/sys/gio/calcomp/vttest.x b/sys/gio/calcomp/vttest.x new file mode 100644 index 00000000..ceff7c7a --- /dev/null +++ b/sys/gio/calcomp/vttest.x @@ -0,0 +1,608 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include "ccp.h" + +define SZ_BUF 2048 +define PIOVER4 (0.25 * PI) +define THREEPIOVER4 (0.75 * TWOPI) +define MAXCH 15 + +# X_VTTEST -- testing task for simulating calcomp kernel routines on vt640 + +task vttest = t_vttest + +# T_VTTEST -- test low-level Calcomp graphics simulation routines on vt640 + +procedure t_vttest () + +char lname[SZ_FNAME], tname[SZ_FNAME], devname[SZ_FNAME] +int ltype, lwidth, npts, n, mtype, i +char testoption +pointer x, y, gp, sim_gp +short p[ARB] + +pointer sp, nambuf, pl, pm +int clgeti (), strlen () +real clgetr () +char clgetc () +pointer ttygdes (), gopen () + +include "ccp.com" +common /simulate/ sim_gp + +string fdevice "vt640" + +begin + call smark (sp) + call salloc (nambuf, SZ_FNAME, TY_CHAR) + + testoption= clgetc ("option") + if (testoption == 'l') { + call clgstr ("lname", lname, SZ_FNAME) + ltype = clgeti ("ltype") + lwidth = clgeti ("lwidth") # width in rel. units + g_dashlen = clgetr ("dashlen") + g_gaplen = clgetr ("gaplen") + g_plwsep = clgetr ("plwsep") + } else if (testoption == 't') { + call clgstr ("tname", tname, SZ_FNAME) + g_plwsep = clgetr ("plwsep") + } else if (testoption == 'm') { + mtype = clgeti ("mtype") + } + call clgstr ("device", devname, SZ_FNAME) + + n = strlen (devname) + if (g_device[1] == EOS) { + call achtsc (devname, Memc[nambuf], n) + Memc[nambuf+n] = EOS + } + iferr (g_tty = ttygdes (Memc[nambuf])) + call erract (EA_ERROR) + g_cc = NULL + call ccp_init (g_tty, Memc[nambuf]) + call ccp_reset () + + g_xndcto_p = 1.0 # for testing, raw data is NDC-space (0-32767) + g_yndcto_p = 1.0 # (that is, after passing through to_short()) + g_ltover = false + g_lwover = true + + pl = CCP_PLAP(g_cc) + pm = CCP_PMAP(g_cc) + + PL_LTYPE(pl) = ltype + PL_WIDTH(pl) = GKI_PACKREAL(lwidth) + PM_LTYPE(pm) = mtype + + gp = gopen (devname, NEW_FILE, STDGRAPH) + sim_gp = gp + call gsview (gp, 0.0, 0.63, 0.0, 1.0) # square viewport + call gswind (gp, 0.0, 32767.0, 0.0, 32767.0) + + switch (testoption) { + + case 'l': # polyline + + call rddata (lname, x, y, npts) # range 0.0-1.0 + call to_short (Memr[x], Memr[y], npts, p) # range 0-32767 + call ccp_polyline (p, npts) + + case 't': # text + + call testtext (gp, tname) # read, calc, call ccppl + + case 'm': # polymarker + + call rddata (lname, x, y, npts) # x,y array of mrkr pos. + do i = 1, npts { + call calcmarker (32767 * Memr[x+i-1], 32767 * Memr[y+i-1], + mtype, p, npts) + call ccp_polymarker (p, npts) + } + } + + call gclose (gp) + call ccp_close () # free g descriptors + call mfree (x, TY_REAL) + call mfree (y, TY_REAL) + call sfree (sp) +end + +# TO_SHORT -- convert x, y real arrays to short integers as NDC coords + +procedure to_short (x, y, npts, p) + +real x[ARB], y[ARB] +int npts +short p[ARB] + +int i, j + +begin + do i = 1, npts, 1 { + j = (i - 1) * 2 + 1 + p[j] = x[i] * 32767 + p[j+1] = y[i] * 32767 + } + return +end + +# CALCMARKER -- calculate and return a pattern of points representing a +# polymarker of the specified type, origined at x, y. + +procedure calcmarker (x, y, marktype, p, npts) + +real x,y # GKI_NDC coordinates of marker origin +int marktype # polymarker type, specified in GIO specs +short p[ARB] # output array of points defining marker, in GKI_NDC +int npts # no. of points; x,y pairs (= 1/2 elements in p) + +int i, j, m, fill +real xsize, ysize +pointer tx +int and() + +include "ccp.com" +include "/iraf/sys/gio/markers.dat" + +begin + tx = CCP_TXAP(g_cc) + xsize = CCP_CHARHEIGHT(g_cc,1) * GKI_UNPACKREAL(TX_SIZE(tx)) + ysize = xsize # for now + # The point marker type cannot be combined with the other types and + # is treated as a special case. The remaining markers are drawn + # using GUMARK, which draws marks represented as polygons + + if (marktype == GM_POINT || (xsize == 0 && ysize == 0)) { + p[1] = x + p[2] = y + npts = 1 + + } else { + + # The polylines for the standard marks are stored in MPX and MPY + # at offsets MXO and MYO. + fill = NO + npts = 0 + do i = GM_FIRSTMARK, GM_LASTMARK + if (and (marktype, 2 ** i) != 0) { + m = i - GM_FIRSTMARK + 1 + do j = 1, mnpts[m] { + npts = npts + 1 + p[npts*2-1] = x - 0.5 * xsize + xsize * mpx[moff[m]+j-1] + p[npts*2] = y - 0.5 * ysize + ysize * mpy[moff[m]+j-1] + } + } + } +end + + +procedure rddata (fname, x, y, npts) + +char fname[ARB] +pointer x, y +int npts + +int buflen, n, fd, ncols, lineno, i, status, testint +pointer sp, lbuf, ip +real xval, yval, maxy +int getline(), nscan(), open() +errchk open, sscan, getline, malloc + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + fd = open (fname, READ_ONLY, TEXT_FILE) + + buflen = SZ_BUF + iferr { + call malloc (x, buflen, TY_REAL) + call malloc (y, buflen, TY_REAL) + } then + call erract (EA_FATAL) + + n = 0 + ncols = 0 + lineno = 0 + + status = 0 + while (status != EOF) { + iferr (status = getline (fd, Memc[lbuf])) { + call eprintf ("getline error from rddata: status=%d\n") + call pargi (status) + call erract (EA_FATAL) + } + if (status == EOF) + next + # 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 + + # Decode the points to be plotted. + call sscan (Memc[ip]) + call gargr (xval) + call gargr (yval) + + # 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: + yval = xval + default: # normally, ncols=2 + if (ncols != 2) { + call eprintf ("weird data; file %s, line %d: %s\n") + call pargstr (fname) + call pargi (lineno) + call pargstr (Memc[lbuf]) + next + } + } + + n = n + 1 + if (n > buflen) { + buflen = buflen + SZ_BUF + call realloc (x, buflen, TY_REAL) + call realloc (y, buflen, TY_REAL) + } + + Memr[x+n-1] = xval + Memr[y+n-1] = yval + testint = x+n-1 + } + + if (ncols == 1) { + maxy = 0.0 + do i = 1, n + maxy = max (Memr[y+i-1], maxy) + do i = 1, n + Memr[x+i-1] = maxy * real(i) / real(n) + } + call realloc (x, n, TY_REAL) + call realloc (y, n, TY_REAL) + + call close (fd) + call sfree (sp) + npts = n +end + + +# RPTHETA4 -- Polar angle, Real precision, 4 arguments; from p1(x,y) to p2(x,y): +# angle between line segment p1-p2 and horizontal +x axis centered on p1; +# returned in radians; single precision (see pdtheta4). + +real procedure rptheta4 (p1x, p1y, p2x, p2y) + +real p1x,p1y, p2x,p2y # x,y of each point + +real dx, dy, ang + +begin + dx = p2x - p1x + dy = p2y - p1y + if (dx == 0.0) { + if (dy >= 0.0) { + ang = HALFPI + } else { + ang = THREEPIOVER4 + } + } else { + ang = atan (dy / dx) + if (dx < 0.0) { # 2nd or 3rd quadrant + ang = ang + PI + } else if (dy < 0.0) { # 4th quadrant + ang = ang + TWOPI + } + } + return (ang) +end + +# PLOT -- simulate Calcomp's PLOT routine for testing development version of +# calcomp kernel + +procedure plot (x, y, pencode) + +real x,y # plotter coords (ndc in simulation) +int pencode + +real lastp_x, lastp_y + +pointer gp +common /simulate/ gp + +begin + if (pencode == CCP_DOWN) + call gline (gp, lastp_x, lastp_y, x, y) + if (pencode == CCP_DOWN || pencode == CCP_UP) { + lastp_x = x + lastp_y = y + } +end + +# PLOTS -- simulate calcomp plots routine for testing ccp code on vt640 + +procedure plots (dum1, dum2, ldev) + +int dum1, dum2, ldev + +begin + return +end + + +# NEWPEN -- temporary dummy routine for simulating Calcomp + +procedure newpen (whichpen) + +int whichpen + +begin + return +end + +# SYMBOL -- simulate Calcomp's SYMBOL routine for testing development version of +# calcomp kernel + +procedure symbol (xp, yp, size, ch, orien, nchar) + +real xp,yp # plotter coords (ndc in simulation) +real size # char size in plotter coords +char ch[ARB] # chars to be drawn +real orien # degrees counterclockwise from +x to rightward vector +int nchar # number of chars + +pointer gp +common /simulate/ gp + +string format "" + +begin + ch[nchar+1] = EOS + call gseti (gp, G_TXUP, 90 + int(orien)) + call gsetr (gp, G_TXSIZE, size) + call gtext (gp, xp, yp, ch, format) +end + + +# TESTTEXT -- read sequential lines from designated file and call ccp_text to +# draw text at specified coordinates in specified format. + +procedure testtext (gp, fname) + +pointer gp # graphics device +char fname[SZ_FNAME] # name of file from which to extract table + +int fd, textlen, restlen, ip, op +char lbuf[SZ_LINE], ttext[SZ_LINE], rest[SZ_LINE], tformat[SZ_LINE], quote +short sttext[SZ_LINE] +real x,y +int open (), strlen (), getline (), nscan () + +string errmsg "unable to open table file " +data quote/34/ + +begin + iferr (fd = open (fname, READ_ONLY, TEXT_FILE)) { + call sprintf (errmsg[27], SZ_FNAME, "%s") + call pargstr (fname) + call fatal (EA_FATAL, errmsg) + } + + while (getline (fd, lbuf) != EOF) { + # Skip comment lines and blank lines. + if (lbuf[1] == '#') + next + for (ip=1; IS_WHITE(lbuf[ip]); ip=ip+1) + ; + if (lbuf[ip] == '\n' || lbuf[ip] == EOS) + next + + # Decode. + call sscan (lbuf[ip]) + call gargr (x) + call gargr (y) + call gargstr (rest, SZ_LINE) + + if (nscan() < 3) # insufficient fields; ignore line, not nice. + next + + restlen = strlen (rest) + + # Pull out text buffer: + for (ip=1; rest[ip] != quote && ip < restlen; ip=ip+1) #->1st " + ; + op = 0 + for (ip=ip+1; rest[ip] != quote && ip < restlen; ip=ip+1) { + op = op + 1 + ttext[op] = rest[ip]; + } + textlen = op + ttext[op+1] = EOS + + # Pull out format string: + for (ip=ip+1; IS_WHITE(rest[ip]); ip=ip+1) #-> past whitesp + ; + op = 0 + for (; ip <= restlen && !IS_WHITE(rest[ip]); ip=ip+1) { + op = op + 1 + tformat[op] = rest[ip]; + } + tformat[op+1] = EOS + + # set ccp descriptor text attributes if specified: + if (tformat[1] != EOS) + call testxset (tformat) + call achtcs (ttext, sttext, textlen) # ccp_text expects short text + sttext[textlen+1] = EOS + call ccp_text (nint(x), nint(y), sttext, textlen) + } + call close (fd) +end + + +# TESTXSET -- Parse a text drawing format string and set the values of the text +# attributes in the TX (g_cc) output structure. + +procedure testxset (format) + +char format[ARB] # text attribute format string + +pointer tx +char attribute[MAXCH], value[MAXCH] +real tempsize +int ip, op, tip, temp, ch +int h_v[4], v_v[4], f_v[4], q_v[4], p_v[4] +int ctoi(), ctor(), stridx() + +include "ccp.com" + +define badformat_ 91 + +string h_c "nclr" +data h_v /GT_NORMAL, GT_CENTER, GT_LEFT, GT_RIGHT/ +string v_c "nctb" +data v_v /GT_NORMAL, GT_CENTER, GT_TOP, GT_BOTTOM/ +string f_c "rgib" +data f_v /GT_ROMAN, GT_GREEK, GT_ITALIC, GT_BOLD/ +string q_c "nlmh" +data q_v /GT_NORMAL, GT_LOW, GT_MEDIUM, GT_HIGH/ +string p_c "lrud" +data p_v /GT_LEFT, GT_RIGHT, GT_UP, GT_DOWN/ + +begin + # ccp kernel text descriptor: + tx = CCP_TXAP(g_cc) + + # Parse the format string and set the text attributes. The code is + # more general than need be, i.e., the entire attribute name string + # is extracted but only the first character is used. Whitespace is + # permitted and ignored. + + for (ip=1; format[ip] != EOS; ip=ip+1) { + # Extract the next "attribute=value" construct. + while (IS_WHITE (format[ip])) + ip = ip +1 + + op = 1 + for (ch=format[ip]; ch != EOS && ch != '='; ch=format[ip]) { + if (op <= MAXCH) { + attribute[op] = format[ip] + op = op + 1 + } + ip = ip + 1 + } + attribute[op] = EOS + + if (ch == '=') + ip = ip + 1 + + op = 1 + while (IS_WHITE (format[ip])) + ip = ip +1 + ch = format[ip] + while (ch != EOS && ch != ';' && ch != ',') { + if (op <= MAXCH) { + value[op] = format[ip] + op = op + 1 + } + ip = ip + 1 + ch = format[ip] + } + value[op] = EOS + + if (attribute[1] == EOS || value[1] == EOS) + break + + # Decode the assignment and set the corresponding text attribute + # in the graphics descriptor. + + switch (attribute[1]) { + case 'u': # character up vector + tip = 1 + if (ctoi (value, tip, TX_UP(tx)) <= 0) { + TX_UP(tx) = 90 + goto badformat_ + } + + case 'p': # path + temp = stridx (value[1], p_c) + if (temp <= 0) + goto badformat_ + else + TX_PATH(tx) = p_v[temp] + + case 'c': # color + tip = 1 + if (ctoi (value, tip, TX_COLOR(tx)) <= 0) { + TX_COLOR(tx) = 1 + goto badformat_ + } + + case 's': # character size scale factor + tip = 1 + if (ctor (value, tip, tempsize) <= 0) { + TX_SIZE(tx) = GKI_PACKREAL(1.0) + goto badformat_ + } + TX_SIZE(tx) = GKI_PACKREAL(tempsize) + + case 'h': # horizontal justification + temp = stridx (value[1], h_c) + if (temp <= 0) + goto badformat_ + else + TX_HJUSTIFY(tx) = h_v[temp] + + case 'v': # vertical justification + temp = stridx (value[1], v_c) + if (temp <= 0) + goto badformat_ + else + TX_VJUSTIFY(tx) = v_v[temp] + + case 'f': # font + temp = stridx (value[1], f_c) + if (temp <= 0) + goto badformat_ + else + TX_FONT(tx) = f_v[temp] + + case 'q': # font quality + temp = stridx (value[1], q_c) + if (temp <= 0) + goto badformat_ + else + TX_QUALITY(tx) = q_v[temp] + + default: +badformat_ call eprintf ("Warning (testtxset): bad gtext format '%s'\n") + call pargstr (format) + } + + if (format[ip] == EOS) + break + } +end diff --git a/sys/gio/calcomp/x_calcomp.x b/sys/gio/calcomp/x_calcomp.x new file mode 100644 index 00000000..32c82aa2 --- /dev/null +++ b/sys/gio/calcomp/x_calcomp.x @@ -0,0 +1,3 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +task calcomp = t_calcomp diff --git a/sys/gio/cursor/README b/sys/gio/cursor/README new file mode 100644 index 00000000..6534b497 --- /dev/null +++ b/sys/gio/cursor/README @@ -0,0 +1,9 @@ +This directory contains the source for GIOTR and cursor mode, i.e., the code +required to process the graphics output of a graphics task, spooling and/or +applying the workstation transformation and passing the transformed metacode +instructions on to the builtin STDGRAPH kernel or to an external kernel. The +procedure RCURSOR is the main entry point for cursor mode. RCURSOR is called +by the CL to service a query for a cursor type parameter when query mode is +in effect. The workstation transformation is used to zoom and pan on a frame +buffer and consists of a viewport transformation in GKI coordinates with +clipping at the viewport boundary. diff --git a/sys/gio/cursor/doc/cursor.hlp b/sys/gio/cursor/doc/cursor.hlp new file mode 100644 index 00000000..d9912607 --- /dev/null +++ b/sys/gio/cursor/doc/cursor.hlp @@ -0,0 +1,194 @@ +.help GIO Mar85 "Cursor Mode" +.nh 3 +Cursor Mode + + In cursor mode, i.e., after a call to \fBclgcur\fR or after typing "=gcur", +a number of special keystrokes shall be recognized for interactive display +control. All graphics output to stdgraph and stdimage is routed through the +CL on the way to the graphics kernel. The CL will optionally spool in an +internal buffer all graphics instructions output to an interactive device. +This internal buffer is emptied whenever the device screen is cleared. +In cursor mode, special keystrokes may be used to redraw all or any portion +of the spooled graphics, e.g., one may zoom in on a portion of the plot and +then roam about on the plot at high magnification. Since the spooled graphics +vectors typically contain more information than can be displayed at normal +magnification, zooming in on a feature may bring out additional detail +(the maximum resolution is 32768 points in either axis). Increasing the +magnification will increase the precision of the cursor by the same factor. + +Cursor mode is implemented by performing coordinate transformation and +clipping on each GKI instruction in the frame buffer, passing the transformed +and clipped instructions on to the graphics kernel. +The cursor mode operations perform a simple geometric transformation on +the spooled graphics frame, mapping a rectangular window of the spooled +frame onto the device screen. The graphics frame itself is not modified, +hence zoom out or reset and redraw will restore the original display. + +If the graphics frame is a typical vector plot with drawn and labeled +axes, magnifying a portion of the plot may cause the axes to be lost. +If this is not what is desired a keystroke is provided to draw and label +the axes of the displayed window. The axes will be overplotted on the +current display and will not be saved in the frame buffer, hence they +will be lost when the frame is redrawn. In cursor mode the viewport is +the full display area of the output device, hence the tick mark labels +of the drawn axes will be drawn inside the viewport. This form of axes +labeling is used because it is simple and because it is appropriate for +both vector graphics and image display output devices (and cursor mode +must serve both). + +The cursor mode keystrokes are all upper case letters, reserving lower case +for applications programs. The terminal shift lock key may be used to +minimize typing. The recognized cursor mode keystrokes are shown below. + + +.ks +.nf +(*X* means not yet implemented) + + ? print list of keystrokes + *A* draw and label the axes of current viewport + C print the cursor position as it moves + *D* draw a line by marking the endpoints + E expand plot by setting window corners + F set fast cursor (for HJKL) + H step cursor left + J step cursor down + K step cursor up + L step cursor right + M move point under cursor to center of screen + P zoom out (restore previous expansion) + *S* select WCS at current position of cursor + *T* draw a text string + *U* undo (delete) the last instruction in the frame buffer + V set slow cursor (for HJKL) + X zoom in, X only + Y zoom in, Y only + Z zoom in, both X and Y + < set lower limit of plot to the cursor y value + > set upper limit of plot to the cursor y value + *\* escape next character + : set cursor mode options + :! send a command to the host system + 0 reset and redraw + 1-9 roam + +.fi +.ce +Figure 2. Cursor Mode Keystrokes +.ke + + +The numeric keypad of the terminal (if it has one) is used for directional +roaming. The directional significance of the numeric keys for roaming +is obvious if the terminal has a keypad, and is illustrated below. + + +.ks +.nf + 7 8 9 135 090 045 + + 4 5 6 180 000 000 + + 1 2 3 225 -90 -45 +.fi +.ke + + +If the character : is typed while in cursor mode the alpha cursor will appear +at the bottom of the screen, allowing a command line to be entered. If the +command \fIbegins with a period it is interpreted as a cursor mode command\fR, +otherwise the command is passed as a string to the applications program. +Multiple commands may be entered on a line delimited by semicolons. +The command set currently recognized is shown below. Minimum match +abbreviations are permitted. + +.ls 4 +.ls 15 help +Print a list of the cursor mode commands. +.le +.ls case[+-] +Ignore case when interpreting keystrokes. If this option is selected the cursor +mode keystrokes may conflict with those of the applications program. +.le +.ls clear +Clear the alpha screen (but not the graphics screen). This is done by writing +sufficient blank lines to scroll any text off the screen. Does not work if +terminal has only one memory. +.le +.ls markcur[+-] +Draw a small graphics mark at the position of the cursor whenever the cursor +is read, i.e., when cursor mode exits. The default is to not mark. +.le +.ls off [keys] +Disable all cursor mode keystrokes except : (colon). If followed by a list +of keys, e.g., ":.off 0-9IC", only the listed keys are disabled. +.le +.ls on [keys] +Renable all cursor mode keystrokes, or just the listed keystrokes. +.le +.ls page[+-] +Clear the screen when large blocks of text are to be printed, e.g., for '?', +show, and so on. If paging is disabled the text will overwrite the graphics +display. +.le +.ls read +Load the graphics frame from the named metafile. +The current graphics frame is discarded. +.le +.ls reset +Disconnect any connected graphics kernels and free all file descriptors and +memory used by the graphics system. Exit cursor mode. +.le +.ls show +Print the values of all cursor mode parameters, show the status of any +connected graphics kernels, summarize memory utilization, etc. +.le +.ls snap [device] +Dispose of the graphics frame to the standard plotter or to the named device. +A magnified graph will be plotted as it appears on the screen. +.le +.ls txset [size] [up] +Set the text drawing parameters (character size and character up vector). +For example, ".tx 2 180" would set the character size to 2.0 and character +up to 180 degrees for a vertical string drawn upwards. +.le +.ls write +Save the graphics frame in (or append to) the named metafile. +If an exclamation is appended to the command (e.g., "w! file") the output +file, if any, will be overwritten. If a plus sign is appended the entire +frame will be saved regardless of any plot expansion. +.le +.ls xres=N +Set the (soft) device resolution in X. A decrease in resolution will generally +yield an increase in plotting speed. Only plots generated on the graphics +terminal are affected. +.le +.ls yres=N +Set the (soft) device resolution in Y. +.le +.ls zero +Equivalent to the numeric key 0, i.e., restore the unitary workstation +transformation and redraw the screen. +.le +.le + + +For example, to set the X and Y resolutions to 250 and 100, respectively, +one could enter the following command (the computer will type the ':' at +the bottom of the screen when the ':' key is pressed): + + :.xres=250;yres=100 + +Cursor mode may be initialized at login time by supplying a CL environment +variable named "cminit". For example, + + cl> set cminit = off + +would disable cursor mode, and + + cl> set cminit = "mark;case-;xres=100;yres=50" + +would enable marking, turn off case sensitivity, and set the plotting +resolution to 100x50. Initialization is performed only once, when cursor +mode is first entered. +.sh diff --git a/sys/gio/cursor/doc/giotr.notes b/sys/gio/cursor/doc/giotr.notes new file mode 100644 index 00000000..a9221445 --- /dev/null +++ b/sys/gio/cursor/doc/giotr.notes @@ -0,0 +1,330 @@ +.help GIO Feb85 "Graphics I/O" +.nh +Graphics I/O Dataflow + + The GIO procedures are resident in an external applications task which +does graphics. GIO writes a GKI instruction stream which, if not sent directly +to a metafile, is sent to one of the standard graphics streams STDGRAPH, +STDIMAGE, or STDPLOT, much as output is sent to STDOUT or STDERR. +The procedure \fBprfilbuf\fR (directory etc$), which reads the command +stream from a subprocess, is resident in the CL and executes all pseudofile +i/o instructions from a subprocess. Note that \fBprfilbuf\fR is part of the +i/o system of IRAF and operates transparently to the CL. + + +.ks +.nf + GIO(task) ---ipc--> PRFILBUF(CL) --> file (or pipe) + | + v external + GIOTR ---ipc--> graphics + | kernel + v + stdgraph kernel + | + v + (zfioty) + graphics terminal + + + task | cl | task +.fi + +.ce +Graphics Output Dataflow +.ke + + +The \fBprfilbuf\fR procedure passes record read or write requests for the +pseudofiles STDIN, STDOUT or STDERR on to file descriptors assigned by the +CL with the \fBprredir\fR procedure at task execution time. The sole function +of the CL in graphics i/o is to control the redirection of the graphics +i/o streams with \fBprredir\fR. The CL may redirect any of the graphics +streams, i.e., the user may redirect any graphics stream on the command line +when a command is entered, but by default output is directed to a filter +resident in the CL process. This filter is a procedure named \fBgiotr\fR. + + giotr (stream, buffer, nchars) + +The primary function of GIOTR is to pass metacode instructions on to a kernel. +The instruction stream is scanned and special actions are taken for some of +the GKI control instructions. In particular, GIOTR must spawn graphics kernel +subprocesses upon demand. GIOTR is also capabable of performing an +additional transformation upon the drawing instructions before they are passed +to the kernel. This transformation, known as the \fBworkstation +transformation\fR, maps a rectangular portion of the NDC space into the full +device screen, clipping at the boundary of the viewport into NDC space. +The workstation transformation provides a zoom and pan capability and is +controlled interactively by the user in \fBcursor mode\fR (section 3.3). + +As noted earlier, the \fBstdgraph kernel\fR ("fast" kernel) is resident in +the CL process. This is necessary for efficiency reasons and is desirable +in any case because the CL process owns the graphics device, i.e., the +graphics terminal. All devices except the user's graphics terminal are +controlled by external graphics kernel processes. The STDGRAPH kernel is +itself available as an external process and may be called as such to drive +a graphics terminal other than the user terminal (or even to drive the user +terminal if one is willing to shuffle output back through IPC). A graphics +kernel may support an arbitrary number of devices, and may write to more +than one device simultaneously. In addition to being called by GIOTR, +a graphics kernel may be called directly as a CL task to process metacode from +either a file or the standard input, e.g., from a pipe. This offers +additional flexibility as the CL parameter mechanism may then be used to +gain control over metacode translation. + +.nh 2 +Graphics Stream I/O + + The functions performed by GIOTR are summarized in pseudocode below. +GIOTR maintains a separate descriptor for each of the three graphics streams +and is capable of servicing intermixed i/o requests for all streams +simultaneously. The information stored in the descriptor +includes the workstation name, process information, WCS storage for +the SETWCS and GETWCS instructions, the workstation transformation, +and the frame buffer, used to spool GKI instructions for cursor mode. + + +.tp 6 +.nf +procedure giotr (fd, buffer, nchars) + +fd graphics stream (STDGRAPH, etc.) +buffer[] buffer containing GKI metacode instructions +nchars number of chars to be read or written + +begin + # Note that a GKI instruction may span a buffer boundary. + # The code which gets the next instruction from the buffer + # must always return a full instruction, hence some local + # buffering is required therein to reconstruct instructions. + + while (get next instruction != buffer empty) { + + # Handle special instructions. + switch (instruction) { + + case GKI_OPENWS: + if (device not already open) { + read graphcap entry for device + get process name from graphcap entry + if (process not already connected) { + if (some other process is connected) + disconnect current kernel process + connect new kernel process + } + } + output instruction + flush output + clear frame buffer + + case GKI_CLOSEWS, GKI_FLUSH: + output instruction + flush output + + case GKI_CANCEL: + output instruction + flush output + clear frame buffer + + case GKI_SETWCS: + save WCS in descriptor + + case GKI_GETWCS: + write saved WCS to fd + flush (fd) + + default: + append unmodified instruction to frame buffer + perform workstation transformation upon instruction + output transformed instruction + } + } +end +.fi + + +The action implied by "output instruction" above is the following: + + +.ks +.nf + if (kernel is resident in this process) + call gki_execute to execute the instruction + else + call write (process, instruction, nchars) +.fi +.ke + + +The frame buffer (required for cursor mode) will be dynamically allocated and +will be no larger than it has to be, but will have a fixed (user defined) +upper limit, e.g., 128Kb. The median size for a plot is typically 5-10Kb. +Instructions will be silently discarded if the buffer grows too large. +Buffering can be turned off completely if desired, and will always be turned +off for STDPLOT. + +.nh 2 +Cursor Mode Details + + Most of the functionality required to implement cursor mode is provided +by GIOTR. The primary functions of the cursor mode code are to read the +cursor and keystroke, modify the workstation transformation, and redraw the +contents of the frame buffer subject to the new workstation transformation. +Cursor mode does not modify the contents of the frame buffer, except for +possibly appending new graphics instructions to the frame buffer. +A workstation transformation set with cursor mode remains in effect until +the frame buffer is cleared, hence any additional graphics output from the +task which initiated the cursor read (and cursor mode) will undergo the +workstation transformation when drawn. + + +.nf +# PR_FILBUF -- Fill FIO buffer from an IPC channel subject to the CL/IPC +# protocol for multiplexing pseudofile data streams with the command stream. +# Each process has an associated set of pseudofile streams. Each pseudofile +# stream is connected to one, and only one, file or pseudofile of another +# process. I/O requests to XMIT or XFER to an ordinary file are straightforward +# to satisfy. An i/o request from one pseudofile to another is satisfied +# by posting the request (pushing it on a stack) and redirecting our input +# to the process owning the pseudofile being read or written. Pseudofile +# requests are then processed from the second process until a request is +# received which satisfies the posted request from the original process. +# When the original request is satisfied it is popped from the stack and input +# will again be taken from the original process. Note that we cannot write +# directly to the output process since that would violate the IPC protocol +# (the second process may wish to write to its stdout or stderr rather than +# read, etc.: the process must be allowed to complete the original request +# itself). +# +# Request Packet (pushed onto stack for IPC to IPC i/o). +# +# pr process slot number of process placing the request +# iomode request is a read or a write +# count number of chars to be transferred +# ps_server pseudofile number in server process +# ps_receiver pseudofile number in receiver process +# +# The request packet describes a pending pseudofile i/o request. The named +# pseudofile in the server process is either reading from or writing to the +# named pseudofile in the receiver process. + +int procedure pr_filbuf (fd) + +begin + input = fd (the IPC input channel of a process) + + repeat { + get a line from the input file + if (neither XMIT nor XFER directive) + if (request pending) + error: IPC protocol corrupted + else + return command + + if (line is an XMIT directive) { + if (destination is a file) { + # Write from pseudofile to an ordinary file. + get data record from input + write data record to file + + } else { + # Write from pseudofile to another pseudofile. + if (XMIT satisfies XFER request on top of stack) + get data record from input + write record to stacked process + restore input to stacked process + pop request from stack + + } else { + # If writing to local kernel GIOTR will return a null + # length record and we are done. + + get data record from input + if (writing to a graphics stream) + call giotr filter to transform record + if (anything left to output) { + push request on stack + switch input to IPC input of receiver process + } + } + } + + } else if (line is an XFER directive) { + if (source is an ordinary file) { + # Read from a file. + read data record from file + write to active process + + } else if (source is another process) { + # Read from another pseudofile. + if (XFER satisfies XMIT request on top of stack) { + read record from stacked process + write to active process + restore input to stacked process + pop request from stack + } else { + push request on stack + switch input to IPC input channel of receiver process + } + } + } + } +end + + +# GIOTR -- Graphics i/o filter. + +procedure giotr (fd, buffer, nchars) + +fd graphics stream (STDGRAPH, etc.) +buffer[] buffer containing GKI metacode instructions +nchars number of chars to be read or written + +begin + # Note that a GKI instruction may span a buffer boundary. + # The code which gets the next instruction from the buffer + # must always return a full instruction, hence some local + # buffering is required therein to reconstruct instructions. + + while (buffer not empty) { + + # Handle special instructions. + switch (next_instruction) { + + case GKI_OPENWS: + if (device not already open) { + read graphcap entry for device + get process name from graphcap entry + if (process not already connected) { + if (some other process is connected) + disconnect current kernel process + connect new kernel process + } + } + output instruction + flush output + clear frame buffer + + case GKI_CLOSEWS, GKI_FLUSH: + output instruction + flush output + + case GKI_CANCEL: + output instruction + flush output + clear frame buffer + + case GKI_SETWCS: + save WCS in descriptor + + case GKI_GETWCS: + write saved WCS to fd + flush (fd) + + default: + append unmodified instruction to frame buffer + perform workstation transformation upon instruction + output transformed instruction + } + } +end diff --git a/sys/gio/cursor/giotr.x b/sys/gio/cursor/giotr.x new file mode 100644 index 00000000..cfc8f706 --- /dev/null +++ b/sys/gio/cursor/giotr.x @@ -0,0 +1,183 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "gtr.h" + +# GIOTR -- A graphics filter, called by PR_PSIO (during normal graphics output) +# and RCURSOR (when in cursor mode) to perform the workstation transformation +# on a block of metacode instructions, writing the individual instructions to +# either the inline stdgraph kernel or to an external kernel. Input is taken +# from the frame buffer for the stream. All full instructions starting at the +# input pointer IP and ending at the output pointer OP are processed, leaving +# the input pointer positioned to BOI of the last (and incomplete) instruction +# in the frame buffer. If output is to an inline kernel the kernel is called +# to execute each instruction as it is extracted. If output is to an external +# kernel instructions are written to the named stream, i.e., into the FIO +# buffer associated with the stream, and later transferred to the kernel in the +# external process when the process requests input from the named stream in an +# XFER directive (see PR_PSIO). + +procedure giotr (stream) + +int stream # graphics stream + +pointer tr, gki +int jmpbuf[LEN_JUMPBUF], fn +int mode, xint, status, junk, nwords +common /gtrvex/ jmpbuf + +pointer gtr_init(), coerce() +extern giotr_onint(), gtr_delete() +int gtr_fetch_next_instruction(), locpr() +errchk gtr_init, gtr_fetch_next_instruction, gki_write +data status /OK/, xint /NULL/ +include "gtr.com" + +begin + tr = gtr_init (stream) + + # If an interrupt occurs while GIOTR is executing output is cancelled + # and further processing is disabled until the next frame begins. + + if (xint == NULL) + call xwhen (X_INT, locpr(giotr_onint), xint) + + call zsvjmp (jmpbuf, status) + if (status != OK) { + call gki_cancel (stream) + call gki_deactivatews (stream, 0) + } + + # Fetch, optionally transform, and execute each metacode instruction + # in the frame buffer. + + while (gtr_fetch_next_instruction (tr, gki) != EOF) { + switch (Mems[gki+GKI_HDR_OPCODE-1]) { + + case GKI_OPENWS: + mode = Mems[gki+GKI_OPENWS_M-1] + if (mode != APPEND) + status = OK + + if (status == OK) { + # If the open instruction has already been passed to the + # kernel by gtr_control, do not do so again here. + + if (TR_SKIPOPEN(tr) == YES) + TR_SKIPOPEN(tr) = NO + else + call gki_write (stream, Mems[gki]) + + # gtr_control does not call gki_escape so always do this. + call gki_escape (stream, GKI_OPENWS, 0, 0) + + # Discard frame buffer contents up to and including the + # openws instruction, so that it will only be executed + # once. + + if (Mems[gki+GKI_OPENWS_M-1] == NEW_FILE) + call gtr_frame (tr, TR_IP(tr), stream) + } + + case GKI_CLOSEWS, GKI_DEACTIVATEWS, GKI_REACTIVATEWS: + # These instructions are passed directly to the kernel via + # the PSIOCTRL stream at runtime, but are ignored in metacode + # to avoid unnecessary mode switching of the terminal. + ; + + case GKI_CANCEL: + # Cancel any buffered graphics data. + call gki_write (stream, Mems[gki]) + call gtr_frame (tr, TR_IP(tr), stream) + + case GKI_FLUSH, GKI_GETCURSOR, GKI_GETCELLARRAY: + # Do not buffer these instructions. + call gki_write (stream, Mems[gki]) + call gtr_delete (tr, gki) + + case GKI_CLEAR: + # Clear is special because it initializes things. + if (status != OK) { + call gki_reactivatews (stream, 0) + status = OK + } + # Execute the instruction. + call gki_write (stream, Mems[gki]) + call gki_escape (stream, GKI_CLEAR, 0, 0) + + # Discard frame buffer contents up to and including the clear. + call gtr_frame (tr, TR_IP(tr), stream) + + case GKI_SETWCS: + call gki_write (stream, Mems[gki]) + nwords = Mems[gki+GKI_SETWCS_N-1] + call amovs (Mems[gki+GKI_SETWCS_WCS-1], + Mems[coerce (TR_WCSPTR(tr,1), TY_STRUCT, TY_SHORT)], + min (nwords, LEN_WCS * MAX_WCS * SZ_STRUCT / SZ_SHORT)) + + case GKI_ESCAPE: + if (status == OK) { + fn = Mems[gki+GKI_ESCAPE_FN-1] + + # Execute the escape instruction. + if (wstranset == YES) { + call sge_wstran (fn, Mems[gki+GKI_ESCAPE_DC-1], + vx1,vy1, vx2,vy2) + } else + call gki_write (stream, Mems[gki]) + + # Allow the kernel escape handling code to preserve, + # delete, or edit the instruction. + + call sge_spoolesc (tr, gki, fn, Mems[gki+GKI_ESCAPE_DC-1], + TR_FRAMEBUF(tr), TR_OP(tr), locpr(gtr_delete)) + } + + default: + if (status == OK) + if (wstranset == YES) { + # Perform the workstation transformation and output the + # transformed instruction, if there is anything left. + call gtr_wstran (Mems[gki]) + } else + call gki_write (stream, Mems[gki]) + } + } + + # Clear the frame buffer if spooling is disabled. This is done by + # moving the upper part of the buffer to the beginning of the buffer, + # starting with the word pointed to by the second argument, preserving + # the partial instruction likely to be found at the end of the buffer. + # Truncate the buffer if it grows too large by the same technique of + # shifting data backwards, but in this case without destroying all + # of the data. + + if (TR_SPOOLDATA(tr) == NO) + call gtr_frame (tr, TR_IP(tr), stream) + else if (TR_OP(tr) - TR_FRAMEBUF(tr) > TR_MAXLENFRAMEBUF(tr)) + call gtr_truncate (tr, TR_IP(tr)) + + # Pop the interrupt handler. + if (xint != NULL) { + call xwhen (X_INT, xint, junk) + xint = NULL + } +end + + +# GIOTR_ONINT -- Interrupt handler for GIOTR. + +procedure giotr_onint (vex, next_handler) + +int vex # virtual exception +int next_handler # next exception handler in chain +int jmpbuf[LEN_JUMPBUF] +common /gtrvex/ jmpbuf + +begin + call xer_reset() + call zdojmp (jmpbuf, vex) +end diff --git a/sys/gio/cursor/grc.h b/sys/gio/cursor/grc.h new file mode 100644 index 00000000..35af451f --- /dev/null +++ b/sys/gio/cursor/grc.h @@ -0,0 +1,20 @@ +# GRC.H -- Global definitions and data structures for the RCURSOR (cursor read) +# procedures. + +define KEYSFILE "lib$scr/cursor.key" +define KEYSTROKES "ABCDEFHJKLMPRTUVWXYZ<>0123456789:=" +define MAX_KEYS 128 +define LEN_RCSTRUCT (10+(128/SZ_STRUCT)) + +define RC_CASE Memi[$1] # case sensitive +define RC_MARKCUR Memi[$1+1] # mark cursor +define RC_PHYSOPEN Memi[$1+2] # physical open by rcursor +define RC_AXES Memi[$1+3] # draw axes if screen redrawn + # (open) +define RC_KEYS Memc[P2C($1+10)+$2] # keystroke mappings + +define LEN_CT 2,4 +define CT_TRAN 1 +define CT_SCALE 2 +define CT_WORIGIN 3 +define CT_MORIGIN 4 diff --git a/sys/gio/cursor/grcaxes.x b/sys/gio/cursor/grcaxes.x new file mode 100644 index 00000000..f2f69e4f --- /dev/null +++ b/sys/gio/cursor/grcaxes.x @@ -0,0 +1,402 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gtr.h" +include "grc.h" + +define LEN_POLYLINE 128 # polyline for axes and ticks +define NTICKS 6 # default rough ticks on an axis +define SZ_TICKFORMAT 6 # "%0.Xg" +define SZ_TICKLABEL 10 # encoded tick label +define TICKLEN 0.03 # tick length, ndc units +define LABELOFFSET 1.5 # offset to tick label in ticklen units + + +# GRC_AXES -- Draw and label the axes of the viewport. This is a simple +# routine not intended to be competitive with GLABAX. We draw a box around +# the edge of the screen, find and label the ticks within the plotting area. + +procedure grc_axes (stream, sx, sy, raster, rx, ry) + +int stream #I graphics stream +real sx, sy #I screen coords of cursor +int raster #I raster number +real rx, ry #I raster coords of cursor + +char tickformat[SZ_TICKFORMAT], ticklabel[SZ_TICKLABEL] +pointer tr, w, ap, save_op +int xt, yt, nwords, nticks, wcs, lt_save +real xb, xe, x1, dx, x, y, lw_save +real yb, ye, y1, dy, aspect_ratio, xticklen, yticklen + +int gt_ndigits() +pointer gtr_init() +real ttygetr() + +errchk gtr_init, ttygetr, realloc, gax_start +include "gtr.com" + +begin + tr = gtr_init (stream) + + # Draw the axes with a solid polyline of width 2.0. + ap = TR_PLAP(tr) + lt_save = PL_LTYPE(ap); PL_LTYPE(ap) = GL_SOLID + lw_save = PL_WIDTH(ap); PL_WIDTH(ap) = 2.0 + + # Select a WCS. + call grc_scrtowcs (stream, sx, sy, raster, rx, ry, x1, y1, wcs) + w = TR_WCSPTR(tr,wcs) + + # Get the coordinates of the axes corners and the tick parameters. + call gax_findticks (w, xb,xe,yb,ye, x1,dx,xt, y1,dy,yt) + + # Mark the position in the frame buffer. The axes drawing instructions + # will be appended to the frame buffer by the drawing routines. When + # we get all done we will move these instructions to the scratch buffer + # and reset the frame buffer pointers, since we do not want the axes + # to be a permanent part of the plot. + + save_op = TR_OP(tr) + + # Compute the X and Y tick lengths in NDC coordinates, corrected for + # the aspect ratio and workstation transformation. + + aspect_ratio = ttygetr (TR_TTY(tr), "ar") + if (aspect_ratio < .001) + aspect_ratio = 1.0 + xticklen = TICKLEN / xscale * aspect_ratio + yticklen = TICKLEN / yscale + + # Construct the polyline to draw the first two axes and ticks. We + # start at the lower left and draw to the lower right then upper right. + + nticks = int ((xe - xb) / dx) # Bottom axis. + call gax_start (xb, yb) + call gax_draw (x1, yb) + call gax_tick (0., yticklen) + + for (x=x1+dx; nticks > 0; nticks=nticks-1) { + call gax_draw (min(x,xe), yb) + call gax_tick (0., yticklen) + x = x + dx + } + + nticks = int ((ye - yb) / dy) # Right axis. + call gax_draw (xe, yb) + call gax_draw (xe, y1) + call gax_tick (-xticklen, 0.) + + for (y=y1+dy; nticks > 0; nticks=nticks-1) { + call gax_draw (xe, min(y,ye)) + call gax_tick (-xticklen, 0.) + y = y + dy + } + + call gax_draw (xe, ye) + call gax_flush (stream) + + # Construct the polyline to draw the second two axes and ticks. We + # start at the lower left and draw to the upper left then upper right. + + nticks = int ((ye - yb) / dy) # Left axis. + call gax_start (xb, yb) + call gax_draw (xb, y1) + call gax_tick (xticklen, 0.) + + for (y=y1+dy; nticks > 0; nticks=nticks-1) { + call gax_draw (xb, min(y,ye)) + call gax_tick (xticklen, 0.) + y = y + dy + } + + nticks = int ((xe - xb) / dx) # Top axis. + call gax_draw (xb, ye) + call gax_draw (x1, ye) + call gax_tick (0., -yticklen) + + for (x=x1+dx; nticks > 0; nticks=nticks-1) { + call gax_draw (min(x,xe), ye) + call gax_tick (0., -yticklen) + x = x + dx + } + + call gax_draw (xe, ye) + call gax_flush (stream) + + # Label the ticks on the bottom axis. The tick labels are centered + # just above each tick. + + nticks = int ((xe - xb) / dx) + 1 + call sprintf (tickformat, SZ_TICKFORMAT, "%%0.%dg") + call pargi (max (1, gt_ndigits (xb, xe, dx)) + 1) + + for (x=x1; nticks > 0; nticks=nticks-1) { + call glb_encode (x, ticklabel, SZ_TICKLABEL, tickformat, dx) + call gax_ndc (x, yb, sx, sy) + call gax_text (stream, sx, sy + (yticklen * LABELOFFSET), + ticklabel, GT_CENTER, GT_BOTTOM) + x = x + dx + } + + # Label the ticks on the left axis. The tick labels are left justified + # just to the right of each tick. + + nticks = int ((ye - yb) / dy) + 1 + call sprintf (tickformat, SZ_TICKFORMAT, "%%0.%dg") + call pargi (max (1, gt_ndigits (yb, ye, dy)) + 1) + + for (y=y1; nticks > 0; nticks=nticks-1) { + call glb_encode (y, ticklabel, SZ_TICKLABEL, tickformat, dy) + call gax_ndc (xb, y, sx, sy) + call gax_text (stream, sx + (xticklen * LABELOFFSET), sy, + ticklabel, GT_LEFT, GT_CENTER) + y = y + dy + } + + # Restore the default polyline attributes. + PL_LTYPE(ap) = lt_save + PL_WIDTH(ap) = lw_save + + # Move the axes drawing and labelling instructions to the scratch + # buffer and fix up the frame buffer pointers. + + nwords = TR_OP(tr) - save_op + if (nwords > TR_LENSCRATCHBUF(tr)) { + call realloc (TR_SCRATCHBUF(tr), nwords, TY_SHORT) + TR_LENSCRATCHBUF(tr) = nwords + } + + call amovs (Mems[save_op], Mems[TR_SCRATCHBUF(tr)], nwords) + TR_OPSB(tr) = TR_SCRATCHBUF(tr) + nwords + TR_OP(tr) = save_op + TR_IP(tr) = save_op + TR_LASTOP(tr) = save_op +end + + +# GAX_FINDTICKS -- Get the coordinates of the endpoints of the axes, the first +# tick on each axis, and the tick spacing on each axis. If log scaling is in +# use on an axis we shall work in log coordinate units, which are linear. + +procedure gax_findticks (w, wx1,wx2,wy1,wy2, x1,dx,xt, y1,dy,yt) + +pointer w # window descriptor +real wx1,wx2,wy1,wy2 # endpoints of axes +real x1,dx # tick start and spacing in X +int xt # type of scaling in X +real y1,dy # tick start and spacing in Y +int yt # type of scaling in Y + +pointer wp +real ct[LEN_CT] +common /ftkgcm/ wp, ct + +real sx1, sx2, sy1, sy2 +real elogr() + +begin + wp = w + + # Set up WCS/NDC coordinate transformations. + call grc_settran (w, ct) + + # Get NDC coords of the corners of the screen. + call grc_scrtondc (0.001, 0.001, sx1, sy1) + call grc_scrtondc (0.999, 0.999, sx2, sy2) + + # Move in a bit if the graphics viewport lies within the screen area. + # This depends upon the workstation transformation, of course. + sx1 = max (WCS_SX1(w), sx1) + sx2 = min (WCS_SX2(w), sx2) + sy1 = max (WCS_SY1(w), sy1) + sy2 = min (WCS_SY2(w), sy2) + + # Compute world coordinates of the viewport (of the axes to be drawn). + call grc_ndctowcs (ct, sx1, sy1, wx1, wy1) + call grc_ndctowcs (ct, sx2, sy2, wx2, wy2) + + # Find the ticks. If log scaling is in use on an axis we shall find + # and draw the ticks in log coordinates. + + switch (WCS_XTRAN(w)) { + case GW_LOG: + wx1 = log10 (wx1) + wx2 = log10 (wx2) + case GW_ELOG: + wx1 = elogr (wx1) + wx2 = elogr (wx2) + } + call gtickr (wx1, wx2, NTICKS, NO, x1, dx) + + switch (WCS_YTRAN(w)) { + case GW_LOG: + wy1 = log10 (wy1) + wy2 = log10 (wy2) + case GW_ELOG: + wy1 = elogr (wy1) + wy2 = elogr (wy2) + } + call gtickr (wy1, wy2, NTICKS, NO, y1, dy) + + xt = WCS_XTRAN(w) + yt = WCS_YTRAN(w) +end + + +# GAX_NDC -- Convert a pair of world or log-world coordinates to NDC +# coordinates. GAX_FINDTICKS must be called first to set up transformation. + +procedure gax_ndc (wx, wy, sx, sy) + +real wx, wy # world coords (input) +real sx, sy # ndc coords (output) + +pointer wp +real ct[LEN_CT] +common /ftkgcm/ wp, ct + +real x, y +real aelogr() + +begin + # Get X in world coordinates. + switch (WCS_XTRAN(wp)) { + case GW_LOG: + x = 10.0 ** wx + case GW_ELOG: + x = aelogr (wx) + default: + x = wx + } + + # Get Y in world coordinates. + switch (WCS_YTRAN(wp)) { + case GW_LOG: + y = 10.0 ** wy + case GW_ELOG: + y = aelogr (wy) + default: + y = wy + } + + # Transform to NDC coordinates and return. + call grc_wcstondc (ct, x, y, sx, sy) +end + + +# GAX_DRAW -- Add a point to the output polyline for an axis. The polyline +# is built up in NDC coordinates for output to GTR_POLYLINE. In addition to +# the draw routine, entry points are provided for start, flush, and tick +# drawing. + +procedure gax_draw (wx, wy) + +real wx, wy # world or log-world coords to draw to +real sx, sy +pointer polyline, op +common /gaxdcm/ polyline, op + +begin + # Transform to NDC coords and add the point to the polyline. + call gax_ndc (wx, wy, sx, sy) + Memr[op] = sx + op = op + 1 + Memr[op] = sy + op = op + 1 +end + + +# GAX_TICK -- Draw a tick at the current position. The offsets to draw the +# tick are given in NDC coordinates. + +procedure gax_tick (dx, dy) + +real dx, dy # tick offset in NDC coords for gax_tick +real x, y +pointer polyline, op +common /gaxdcm/ polyline, op + +begin + x = Memr[op-2] + y = Memr[op-1] + + Memr[op] = x + dx + op = op + 1 + Memr[op] = y + dy + op = op + 1 + + Memr[op] = x + op = op + 1 + Memr[op] = y + op = op + 1 +end + + +# GAX_START -- Start a new polyline at the indicated point in world coords. +# The polyline buffer is of a fixed length with no bounds checking. + +procedure gax_start (wx, wy) + +real wx, wy # world or log-world coords to draw to +pointer polyline, op + +errchk malloc +common /gaxdcm/ polyline, op + +begin + call malloc (polyline, LEN_POLYLINE, TY_REAL) + op = polyline + call gax_draw (wx, wy) +end + + +# GAX_FLUSH -- Flush the buffered polyline and free space on the heap. + +procedure gax_flush (stream) + +int stream # graphics stream +pointer polyline, op +common /gaxdcm/ polyline, op + +begin + call grc_polyline (stream, Memr[polyline], (op - polyline) / 2) + call mfree (polyline, TY_REAL) +end + + +# GAX_TEXT -- Draw a text string (tick label) of size 1.0 with the indicated +# justification. + +procedure gax_text (stream, sx, sy, text, hjustify, vjustify) + +int stream # graphics stream +real sx, sy # text coordinates, NDC +char text[ARB] # text string to be drawn +int hjustify # horizontal justification +int vjustify # vertical justification + +pointer tr, tx +int save_tx[LEN_TX] +errchk gtr_init +pointer gtr_init() + +begin + tr = gtr_init (stream) + tx = TR_TXAP(tr) + call amovi (Memi[tx], save_tx, LEN_TX) + + TX_UP(tx) = 90 + TX_SIZE(tx) = 1.0 + TX_PATH(tx) = GT_RIGHT + TX_SPACING(tx) = 0 + TX_HJUSTIFY(tx) = hjustify + TX_VJUSTIFY(tx) = vjustify + TX_FONT(tx) = GT_BOLD + TX_QUALITY(tx) = GT_NORMAL + TX_COLOR(tx) = 1 + + call grc_text (stream, sx, sy, text) + call amovi (save_tx, Memi[tx], LEN_TX) +end diff --git a/sys/gio/cursor/grcclose.x b/sys/gio/cursor/grcclose.x new file mode 100644 index 00000000..304a0904 --- /dev/null +++ b/sys/gio/cursor/grcclose.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gtr.h" +include "grc.h" + +# GRC_CLOSE -- Close the workstation (kernel). Called by RCURSOR to close the +# kernel after a cursor read. Note that a cursor read may occur while the +# workstation is open, i.e., after gopen but before gclose, or after the +# workstation has been closed, i.e., after a plotting program terminates. +# If the workstation was already open (GKI_OPENWS) by the application when +# the cursor read occurred we must leave things as they were. + +procedure grc_close (fd, rc) + +int fd # graphics stream +pointer rc # rcursor descriptor + +pointer tr +pointer gtr_init() +errchk gtr_init + +begin + tr = gtr_init (fd) + + # Decrement the logical OPENWS count and issue the actual CLOSEWS + # only if the counter goes to zero. If the workstation was open + # but deactivated when grc_open() was called (WS_ACTIVE == NO), + # restore it to its former (deactivated) state. + + TR_WSOPEN(tr) = TR_WSOPEN(tr) - 1 + if (TR_WSOPEN(tr) <= 0) { + call gki_closews (fd, TR_DEVNAME(tr)) + TR_WSOPEN(tr) = 0 + TR_WSACTIVE(tr) = NO + } else if (TR_WSACTSAVE(tr) == NO) { + call gki_deactivatews (fd, 0) + TR_WSACTIVE(tr) = NO + } + + call gki_fflush (fd) +end diff --git a/sys/gio/cursor/grccmd.x b/sys/gio/cursor/grccmd.x new file mode 100644 index 00000000..5aca0f84 --- /dev/null +++ b/sys/gio/cursor/grccmd.x @@ -0,0 +1,533 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include +include "gtr.h" +include "grc.h" + +define MAX_KWLEN 10 + +# Assign opcodes to the recognized keywords. + +define KW_AXES 1 +define KW_CASE 2 +define KW_CLEAR 3 +define KW_CURSOR 4 +define KW_GFLUSH 5 +define KW_HELP 6 +define KW_INIT 7 +define KW_MARKCUR 8 +define KW_OFF 9 +define KW_ON 10 +define KW_PAGE 11 +define KW_READ 12 +define KW_SHOW 13 +define KW_SNAP 14 +define KW_TXQUALITY 15 +define KW_TXSET 16 +define KW_VIEWPORT 17 +define KW_WRITE 18 +define KW_XRES 19 +define KW_YRES 20 +define KW_ZERO 21 + + +# GRC_COMMAND -- Process a ":." cursor mode option string. The RC structure +# contains the current values of the cursor mode options. Some option strings +# are commands that do something, others set options, and still others show +# the status of the program. + +int procedure grc_command (rc, stream, sx, sy, raster, rx, ry, opstr) + +pointer rc #I rcursor descriptor +int stream #I graphics stream +real sx, sy #I screen coords of cursor +int raster #I raster number +real rx, ry #I raster coords of cursor +char opstr[ARB] #I options string excluding the leading ":.". + +pointer tr, p_tr, sp, fname, lbuf, tty +bool clobber, fullframe, auto_gflush +int ip, op, ch, opcode, cursor +int save1, save2, i, xres, yres, quality +char kwname[MAX_KWLEN] + +pointer gtr_init(), grc_open(), ttyodes() +int strdic(), grc_boolval(), ttygeti(), ttystati() +real grc_realval() +string keywords "|axes|case|clear|cursor|gflush|help|init|markcur|off|on|page|\ +read|show|snap|txquality|txset|viewport|write|xres|yres|zero|" +errchk gtr_redraw, gki_flush, gtr_init +define exit_ 91 + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + # The terminal is left in graphics mode when the user types return to + # enter the command. Echo the user command to the terminal without + # the newline to leave the terminal in status line mode, so that any + # output directly to the terminal from the lower level code in the CL + # goes into the status line. + + call strcpy (":.", Memc[lbuf], SZ_LINE) + op = lbuf + 2 + for (ip=1; opstr[ip] != EOS && opstr[ip] != '\n'; ip=ip+1) { + Memc[op] = opstr[ip] + op = op + 1 + } + Memc[op] = EOS + call stg_putline (STDERR, Memc[lbuf]) + + tr = gtr_init (stream) + ip = 1 + + while (ip == 1 || opstr[ip] != EOS) { + while (IS_WHITE(opstr[ip])) + ip = ip + 1 + + # If EOS and not first command, all done. If first command do + # not quit, rather assume ":.help" (see below). + + if (ip > 1 && opstr[ip] == EOS) + break + + # Extract the keyword into the KWNAME buffer. Leave the input + # pointer positioned to the first char following the keyword. + + for (op=1; opstr[ip] != EOS; ip=ip+1) { + ch = opstr[ip] + if (IS_ALNUM(ch)) { + kwname[op] = ch + op = op + 1 + } else + break + } + kwname[op] = EOS + + # Look up the keyword in the dictionary. If not found ring the bell + # but do not return EOF (do not quit cursor mode). + + if (op == 1) + opcode = KW_HELP + else { + opcode = strdic (kwname, kwname, MAX_KWLEN, keywords) + if (opcode <= 0) { + call fprintf (STDERR, "\7") + goto exit_ + } + } + + # Process the command. + + switch (opcode) { + case KW_AXES: + # Set flag to draw axes of viewport when screen readrawn. + RC_AXES(rc) = grc_boolval (opstr, ip) + + case KW_CASE: + # Enable/disable case sensitivity. + RC_CASE(rc) = grc_boolval (opstr, ip) + + case KW_CLEAR: + # Clear the alpha screen. + iferr (tty = ttyodes ("terminal")) + call grc_warn (STDERR) + else { + do i = 1, ttystati (tty, TTY_NLINES) { + call ttygoto (STDOUT, tty, 1, i) + call ttyclearln (STDOUT, tty) + } + call flush (STDOUT) + call ttycdes (tty) + } + + case KW_CURSOR: + # Select the cursor to be referenced in all subsequent reads + # and writes. + + ip = ip + 1 + cursor = max (0, nint (grc_realval (opstr, ip))) + call stg_lockcursor (cursor) + + case KW_GFLUSH: + # Flush any buffered graphics output (dispose of spooled + # plotter output). + + call stg_putline (STDERR, " - ") + call gtr_gflush (STDPLOT) + + case KW_HELP: + # Print help text for cursor mode. + call gtr_page (STDERR, stream) + iferr (call pagefile (KEYSFILE, "cursor mode help")) + call grc_warn (STDERR) + ip = ip + 1 + + case KW_INIT: + # Disconnect all kernels and free memory. Exits cursor mode + # with an EOF. + + call stg_putline (STDERR, " - ") + call gtr_reset (OK) + call sfree (sp) + return (EOF) + + case KW_MARKCUR: + # Enable marking of the cursor position when the cursor is read. + RC_MARKCUR(rc) = grc_boolval (opstr, ip) + + case KW_OFF: + # Disable the listed keys. + call grc_keys (rc, opstr, ip, 0) + + case KW_ON: + # Enable or set the listed keys. + call grc_keys (rc, opstr, ip, 1) + + case KW_PAGE: + # Enable screen clear when ?, show, etc. print text. + TR_PAGE(tr) = grc_boolval (opstr, ip) + + case KW_READ: + # Fill the frame buffer from a metacode spool file. + + call grc_word (opstr, ip, Memc[fname], SZ_FNAME) + call grc_read (tr, stream, Memc[fname]) + + case KW_SHOW: + # Show status of RCURSOR and GIOTR. + + call gtr_page (STDERR, stream) + call fprintf (STDERR, "Cursor Mode Parameters:\n\n") + call grc_status (STDERR, rc) + + call fprintf (STDERR, "\n\nGraphics Kernel Status:\n\n") + call gtr_status (STDERR) + + case KW_SNAP: + # Write a snapshot of the screen to a plotter. Open a subkernel + # on STDPLOT, redraw the screen into the STDPLOT fio buffer, + # flush the buffered metacode to the kernel, then restore + # everything. NOTE: should restore things automatically if an + # interrupt occurs. + + call stg_putline (STDERR, " - ") + call grc_word (opstr, ip, Memc[fname], SZ_FNAME) + iferr (p_tr = grc_open (Memc[fname], NEW_FILE, STDPLOT, rc)) { + call grc_warn (STDERR) + goto exit_ + } + + call gki_redir (stream, STDPLOT, save1, save2) + call fseti (STDPLOT, F_CANCEL, OK) + + iferr { + call gtr_redraw (stream) + call gki_flush (STDPLOT) + } then + call grc_warn (STDERR) + + call gki_redir (stream, 0, save1, save2) + + auto_gflush = (ttygeti (TR_TTY(p_tr), "MF") <= 1) + call grc_close (STDPLOT, rc) + + if (auto_gflush) + call gtr_gflush (STDPLOT) + + call stg_putline (STDERR, " done") + + case KW_VIEWPORT: + # Set the viewport in world coordinates. + call grc_viewport (tr, stream, + sx, sy, raster, rx, ry, opstr, ip) + + case KW_WRITE: + # Save the contents of the frame buffer in a file. + # "w!" clobbers any existing file and "w+" writes the + # full frame. By default the frame is appended to the + # output file. + + if (opstr[ip] == '!') { + clobber = true + ip = ip + 1 + } else + clobber = false + + if (opstr[ip] == '+') { + fullframe = true + ip = ip + 1 + } else + fullframe = false + + # Extract the filename. + call grc_word (opstr, ip, Memc[fname], SZ_FNAME) + + # Write to the spoolfile. + call grc_write (tr, stream, Memc[fname], clobber, fullframe) + + case KW_XRES: + # Set the stdgraph X resolution. + xres = nint (grc_realval (opstr, ip)) + yres = 0 + call stg_resolution (xres, yres) + + case KW_YRES: + # Set the stdgraph Y resolution. + xres = 0 + yres = nint (grc_realval (opstr, ip)) + call stg_resolution (xres, yres) + + case KW_TXQUALITY: + # Set character generator quality. + + while (IS_WHITE(opstr[ip])) + ip = ip + 1 + + switch (opstr[ip]) { + case 'l': + quality = GT_LOW + case 'm': + quality = GT_MEDIUM + case 'h': + quality = GT_HIGH + default: + quality = 0 + } + call stg_txquality (quality) + + case KW_TXSET: + # Set the text drawing attributes. + call gtxset (TR_TXAP(tr), opstr, ip) + + case KW_ZERO: + # Reset and redraw. + call gtr_ptran (stream, 0., 1., 0., 1.) + call gtr_writecursor (stream, .5, .5) + call gtr_redraw (stream) + } + + # Advance to the next statement or the end of string. Any unused + # characters in the statement just processed are discarded. + + while (opstr[ip] != ';' && opstr[ip] != EOS) + ip = ip + 1 + while (opstr[ip] == ';' || opstr[ip] == '.') + ip = ip + 1 + } +exit_ + # Restore the terminal to graphics mode if gtr_page was not called to + # deactivate the ws. (this leaves the waitpage flag set). + + if (TR_WAITPAGE(tr) == NO) + call stg_putline (STDERR, "\n") + + # Leave the graphics descriptor set up as we found it. + tr = gtr_init (stream) + + call flush (STDERR) + call sfree (sp) + return (OK) +end + + +# GRC_WORD -- Extract the next whitespace delimited word from the command line. + +procedure grc_word (opstr, ip, outstr, maxch) + +char opstr[ARB] # input string +int ip # pointer into input string +char outstr[ARB] # output string +int maxch # max chars out +int op + +begin + while (IS_WHITE (opstr[ip])) + ip = ip + 1 + + op = 1 + while (!IS_WHITE (opstr[ip]) && opstr[ip] != EOS) { + outstr[op] = opstr[ip] + op = op + 1 + ip = ip + 1 + } + + outstr[op] = EOS +end + + +# GRC_BOOL -- Get the boolean value of a parameter. Upon entry, the input +# pointer is positioned to the first character following the parameter name. + +int procedure grc_boolval (opstr, ip) + +char opstr[ARB] # command string +int ip # input pointer +int value +int btoi() + +begin + while (IS_WHITE (opstr[ip])) + ip = ip + 1 + + if (opstr[ip] == '=') { + ip = ip + 1 + while (IS_WHITE (opstr[ip])) + ip = ip + 1 + value = btoi (opstr[ip] != 'n' && opstr[ip] != 'N') + while (IS_ALPHA (opstr[ip])) + ip = ip + 1 + } else + value = btoi (opstr[ip] != '-') + + return (value) +end + + +# GRC_REALVAL -- Get the real value of a parameter. Upon entry, the input +# pointer is positioned to the first character following the parameter name. +# Zero is returned if no value is given. + +real procedure grc_realval (opstr, ip) + +char opstr[ARB] # command string +int ip # input pointer +real value +int ctor() + +begin + while (IS_WHITE (opstr[ip])) + ip = ip + 1 + if (opstr[ip] == '=') + ip = ip + 1 + while (IS_WHITE (opstr[ip])) + ip = ip + 1 + + if (ctor (opstr, ip, value) <= 0) + value = 0 + + return (value) +end + + +# GRC_KEYS -- Enable the listed keys or ranges of keys. The operation is +# additive, i.e., only the named keys are affected. + +procedure grc_keys (rc, opstr, ip, onoff) + +pointer rc # rcursor descriptor +char opstr[ARB] # command string +int ip # next char in opstr +int onoff # set keys on (1) or off (0) + +int new_value +int ch, ch1, ch2, ip_start, i +string keys KEYSTROKES + +begin + while (IS_WHITE (opstr[ip])) + ip = ip + 1 + + ip_start = ip + for (ch=opstr[ip]; ch != EOS; ch=opstr[ip]) { + if (ch == ';' || ch == '\n' || IS_WHITE(ch)) + break + + ch1 = ch + if (opstr[ip+1] == '-' && opstr[ip+2] != EOS) { + # Enable a range of keys. + ip = ip + 2 + ch2 = opstr[ip] + } else if (opstr[ip+1] == '=' && opstr[ip+2] != EOS) { + # Assign the value of a key. + ip = ip + 3 + RC_KEYS(rc,ch) = opstr[ip] + next + } else + ch2 = ch + + for (ch=ch1; ch <= ch2; ch=ch+1) { + if (onoff == 0) + new_value = 0 + else + new_value = ch + RC_KEYS(rc,ch) = new_value + } + + ip = ip + 1 + } + + # If no keys were listed, set all cursor mode keys. + if (ip == ip_start) + for (i=1; keys[i] != EOS; i=i+1) { + ch = keys[i] + if (onoff == 0) + new_value = 0 + else + new_value = ch + RC_KEYS(rc,ch) = new_value + } + + # The ":" key cannot be mapped or disabled. + RC_KEYS(rc,':') = ':' +end + + +# GRC_VIEWPORT -- Set the viewport in world coordinates. Use the current +# cursor position to determine the WCS, then convert the world coordinates +# of the viewport given by the user into NDC coordinates and set the work- +# station transformation. + +procedure grc_viewport (tr, stream, sx, sy, raster, rx, ry, opstr, ip) + +pointer tr #I giotr descriptor +int stream #I graphics stream +real sx, sy #I screen coordinates of cursor +int raster #I raster number +real rx, ry #I raster coordinates of cursor +char opstr[ARB] #I command string +int ip #I input pointer + +pointer w +int i, wcs +real wx, wy, value +real vn[4], vw[4], ct[LEN_CT] +int ctor() + +begin + # Select a WCS. We are not otherwise interested in the cursor value. + call grc_scrtowcs (stream, sx, sy, raster, rx, ry, wx, wy, wcs) + w = TR_WCSPTR(tr,wcs) + call grc_settran (w, ct) + + # Start with the current viewport. + call gtr_gtran (stream, vn[1], vn[2], vn[3], vn[4]) + + # Transform to world coordinates. + call grc_ndctowcs (ct, vn[1], vn[3], vw[1], vw[3]) + call grc_ndctowcs (ct, vn[2], vn[4], vw[2], vw[4]) + + # Get the new viewport (world) coordinates. + do i = 1, 4 + if (ctor (opstr, ip, value) <= 0) + break + else + vw[i] = value + + # Transform to NDC coordinates. + call grc_wcstondc (ct, vw[1], vw[3], vn[1], vn[3]) + call grc_wcstondc (ct, vw[2], vw[4], vn[2], vn[4]) + + # Set the new workstation transformation. + call gtr_ptran (stream, vn[1], vn[2], vn[3], vn[4]) + + # Redraw the screen. + call gtr_redraw (stream) +end diff --git a/sys/gio/cursor/grcinit.x b/sys/gio/cursor/grcinit.x new file mode 100644 index 00000000..3160203c --- /dev/null +++ b/sys/gio/cursor/grcinit.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "grc.h" + +# GRC_INIT -- Initialize the rcursor descriptor. Allocate storage for the +# descriptor and initialize all variables and the keystroke mapping. + +procedure grc_init (rc) + +pointer rc #U grc descriptor (pointer) + +int ip, ch +string keys KEYSTROKES +errchk malloc + +begin + if (rc == NULL) + call malloc (rc, LEN_RCSTRUCT, TY_STRUCT) + call aclri (Memi[rc], LEN_RCSTRUCT) + + # Initialize variables. + RC_CASE(rc) = YES + RC_MARKCUR(rc) = NO + RC_PHYSOPEN(rc) = NO + + # Initialize keystrokes. + for (ip=1; keys[ip] != EOS; ip=ip+1) { + ch = keys[ip] + RC_KEYS(rc,keys[ip]) = ch + } +end diff --git a/sys/gio/cursor/grcopen.x b/sys/gio/cursor/grcopen.x new file mode 100644 index 00000000..8a39d191 --- /dev/null +++ b/sys/gio/cursor/grcopen.x @@ -0,0 +1,105 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "gtr.h" +include "grc.h" + +# GRC_OPEN -- Open the workstation. Most commonly used to reopen the +# workstation for a cursor read after plotting. + +pointer procedure grc_open (device, mode, stream, rc) + +char device[ARB] # device name (optional) +int mode # desired access mode +int stream # graphics stream +pointer rc # rcursor descriptor + +pointer sp, devname, envvar, tr +int envgets() +bool streq() +pointer gtr_init() + +include "gtr.com" +string stdgraph "stdgraph" +string stdimage "stdimage" +string stdplot "stdplot" +errchk syserrs, gtr_openws, gki_openws, gtr_init + +begin + call smark (sp) + call salloc (envvar, SZ_FNAME, TY_CHAR) + call salloc (devname, SZ_FNAME, TY_CHAR) + + tr = gtr_init (stream) + + # If the workstation is already connected and the kernel is open + # issue the openws directive if it has not already been issued. + + if (TR_DEVNAME(tr) != EOS) + if (device[1] == EOS || streq (device, TR_DEVNAME(tr))) { + # Kernel is already physically open on this stream. Activate + # it if necessary; record whether or not is was active when + # we were called, so that we can restore the original state + # when grc_close() is called. + + if (TR_WSOPEN(tr) <= 0) { + call gki_openws (stream, TR_DEVNAME(tr), mode) + TR_WSACTIVE(tr) = YES + TR_WSACTSAVE(tr) = NO + } else { + TR_WSACTSAVE(tr) = TR_WSACTIVE(tr) + call gki_reactivatews (stream, 0) + TR_WSACTIVE(tr) = YES + } + + call gki_fflush (stream) + + TR_WSOPEN(tr) = TR_WSOPEN(tr) + 1 + call sfree (sp) + return (tr) + } + + # If no device name given fetch the device name from the environment. + + if (device[1] == EOS) { + switch (stream) { + case STDGRAPH: + call strcpy (stdgraph, Memc[envvar], SZ_FNAME) + case STDIMAGE: + call strcpy (stdimage, Memc[envvar], SZ_FNAME) + default: + call strcpy (stdplot, Memc[envvar], SZ_FNAME) + } + + # Convert environment variable name into device name. Indirection + # and assumption of the value of "terminal" are allowed. + + repeat { + if (envgets (Memc[envvar], Memc[devname], SZ_FNAME) <= 0) + call syserrs (SYS_ENVNF, Memc[envvar]) + if (Memc[devname] == '@') { + # Indirection in environment variable name. + call strcpy (Memc[devname+1], Memc[envvar], SZ_FNAME) + } else if (streq (Memc[devname], "terminal")) { + call strcpy (Memc[devname], Memc[envvar], SZ_FNAME) + } else + break + } + } else + call strcpy (device, Memc[devname], SZ_FNAME) + + # Open the workstation (kernel) on stream FD. + call gtr_openws (Memc[devname], mode, stream, NULL) + + TR_WSOPEN(tr) = TR_WSOPEN(tr) + 1 + TR_WSACTSAVE(tr) = NO + TR_WSACTIVE(tr) = YES + + call gki_openws (stream, Memc[devname], mode) + call gki_fflush (stream) + + call sfree (sp) + return (tr) +end diff --git a/sys/gio/cursor/grcpl.x b/sys/gio/cursor/grcpl.x new file mode 100644 index 00000000..7768bf85 --- /dev/null +++ b/sys/gio/cursor/grcpl.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "gtr.h" +include "grc.h" + +# GRC_POLYLINE -- Draw a solid polyline. The instruction is encoded and +# appended to the frame buffer and GIOTR is called to draw the line, +# possibly applying the workstation transformation in the process. + +procedure grc_polyline (stream, v, npts) + +int stream # graphics stream +real v[ARB] # polyline, NDC units +int npts # number of points (coord pairs) in polyline + +pointer tr, sp, p, pl, op, last_op +int nwords, fd, save1, save2, i +int stropen() +pointer gtr_init(), gtr_writep() +errchk gtr_init, gtr_writep, gki_redir + +begin + call smark (sp) + call salloc (p, npts * 2, TY_SHORT) + + tr = gtr_init (stream) + + # Transform the type real, NDC polyline to GKI units, type short. + do i = 1, npts * 2, 2 { + Mems[p+i-1] = v[i ] * GKI_MAXNDC + Mems[p+i ] = v[i+1] * GKI_MAXNDC + } + + # Allocate space in the frame buffer for the polyline set attribute + # and line drawing instructions. Set the last op for undo to undo + # the line. This is also set by writep, hence we must wait to set + # TR_LASTOP until after the call to writep. + + last_op = TR_OP(tr) + nwords = GKI_PLSET_LEN + GKI_POLYLINE_LEN + (npts * 2) + op = gtr_writep (stream, nwords) + TR_LASTOP(tr) = last_op + + # Open the frame buffer as a file and redirect the graphics stream + # output into the buffer. + + fd = stropen (Mems[op], nwords, NEW_FILE) + call gki_redir (stream, fd, save1, save2) + + # Output a polyline set attribute instruction to ensure that a solid + # line is drawn. Output the polyline. + + pl = TR_PLAP(tr) + call gki_plset (stream, pl) + call gki_polyline (stream, Mems[p], npts) + + # Restore the normal output for the stream. + call gki_redir (stream, 0, save1, save2) + call close (fd) + + # Call giotr to send the new instructions off the to the kernel, + # optionally applying the workstation transformation in the process. + + call giotr (stream) + call sfree (sp) +end diff --git a/sys/gio/cursor/grcread.x b/sys/gio/cursor/grcread.x new file mode 100644 index 00000000..ce95fc07 --- /dev/null +++ b/sys/gio/cursor/grcread.x @@ -0,0 +1,60 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gtr.h" + +# GRC_READ -- Fill the frame buffer from a metacode spool file and redraw +# the screen. The contents of the frame buffer are overwritten. + +procedure grc_read (tr, stream, fname) + +pointer tr # graphics descriptor +int stream # graphics stream +char fname[ARB] # metacode file + +pointer sp, lbuf, op +int fd, nchars, filelen +long fstatl() +pointer gtr_writep() +int open(), read() +errchk read +define err_ 91 + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + iferr (fd = open (fname, READ_ONLY, BINARY_FILE)) { + call grc_message (stream, " - cannot open file") + call sfree (sp) + return + } + + filelen = fstatl (fd, F_FILESIZE) + call sprintf (Memc[lbuf], SZ_LINE, " - file size %d chars") + call pargi (filelen) + call grc_message (stream, Memc[lbuf]) + + # Discard the current frame. + call gtr_frame (tr, TR_FRAMEBUF(tr), stream) + + # Read new frame buffer. + nchars = filelen + if (nchars <= 0) + goto err_ + op = gtr_writep (stream, nchars) + if (read (fd, Mems[op], nchars) < nchars) + goto err_ + + # Redraw the new frame buffer. + call gtr_redraw (stream) + + call close (fd) + call sfree (sp) + return +err_ + call close (fd) + call grc_message (stream, " [READ ERROR]") + call sfree (sp) +end diff --git a/sys/gio/cursor/grcredraw.x b/sys/gio/cursor/grcredraw.x new file mode 100644 index 00000000..4317db96 --- /dev/null +++ b/sys/gio/cursor/grcredraw.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "grc.h" + +# GRC_REDRAW -- Redraw the screen, and, if the "axes" flag is set, draw the axes +# of the plot. + +procedure grc_redraw (rc, stream, sx, sy, raster, rx, ry) + +pointer rc #I rcursor descriptor +int stream #I graphics stream +real sx, sy #I screen coords of cursor +int raster #I raster number +real rx, ry #I raster coords of cursor + +begin + call gtr_redraw (stream) + if (RC_AXES(rc) == YES) + call grc_axes (stream, sx, sy, raster, rx, ry) +end diff --git a/sys/gio/cursor/grcscr.x b/sys/gio/cursor/grcscr.x new file mode 100644 index 00000000..add322b4 --- /dev/null +++ b/sys/gio/cursor/grcscr.x @@ -0,0 +1,49 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gtr.h" + +# GRC_SCRTONDC -- Coordinate transformation from screen coordinates to NDC +# coordinates. Screen coordinates physically address the device screen and +# range from 0 to 1 in either axis. NDC coordinates also range from 0 to 1 +# in either axis but differ from screen coordinates when the workstation +# transformation is non unitary. The workstation transformation parameters +# are cached in the GTR common. We assume that GTR_INIT has already been +# called to initialize the common for a graphics stream. + +procedure grc_scrtondc (sx, sy, mx, my) + +real sx, sy # screen coordinates (input) +real mx, my # NDC coordinates (output) +include "gtr.com" + +begin + if (wstranset == YES) { + mx = ((sx * GKI_MAXNDC - xorigin) / xscale + mx1) / GKI_MAXNDC + my = ((sy * GKI_MAXNDC - yorigin) / yscale + my1) / GKI_MAXNDC + } else { + mx = sx + my = sy + } +end + + +# GRC_NDCTOSCR -- Coordinate transformation from NDC coordinates to screen +# coordinates. + +procedure grc_ndctoscr (mx, my, sx, sy) + +real mx, my # NDC coordinates (input) +real sx, sy # screen coordinates (output) +include "gtr.com" + +begin + if (wstranset == YES) { + sx = ((mx * GKI_MAXNDC - mx1) * xscale + xorigin) / GKI_MAXNDC + sy = ((my * GKI_MAXNDC - my1) * yscale + yorigin) / GKI_MAXNDC + } else { + sx = mx + sy = my + } +end diff --git a/sys/gio/cursor/grcstatus.x b/sys/gio/cursor/grcstatus.x new file mode 100644 index 00000000..55f44f18 --- /dev/null +++ b/sys/gio/cursor/grcstatus.x @@ -0,0 +1,49 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gtr.h" +include "grc.h" + +# GRC_STATUS -- Called by ":.show" to print the values of the cursor mode +# parameters. + +procedure grc_status (fd, rc) + +int fd # output file +pointer rc # rcursor descriptor + +int ip, ch +string keys KEYSTROKES +include "gtr.com" + +begin + call fprintf (fd, "\tcase\t= %b\n") + call pargi (RC_CASE(rc)) + call fprintf (fd, "\tmarkcur\t= %b\n") + call pargi (RC_MARKCUR(rc)) + call fprintf (fd, "\taxes\t= %b\n") + call pargi (RC_AXES(rc)) + + if (wstranset == YES) { + call fprintf (fd, "\tview\t= %5.3f %5.3f %5.3f %5.3f\n") + call pargr (vx1) + call pargr (vx2) + call pargr (vy1) + call pargr (vy2) + } else + call fprintf (fd, "\tview\t= full screen\n") + + call fprintf (fd, "\tkeys\t= %s\n") + call pargstr (keys) + call fprintf (fd, "\t\t->") + + for (ip=1; keys[ip] != EOS; ip=ip+1) { + ch = RC_KEYS(rc,keys[ip]) + if (ch != 0) + call putci (fd, ch) + else + call putci (fd, ' ') + } + + call fprintf (fd, "\n") +end diff --git a/sys/gio/cursor/grctext.x b/sys/gio/cursor/grctext.x new file mode 100644 index 00000000..5bee9b34 --- /dev/null +++ b/sys/gio/cursor/grctext.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "gtr.h" +include "grc.h" + +# GRC_TEXT -- Draw a text string. The instruction is encoded and appended to +# the frame buffer and GIOTR is called to draw the new instructions. + +procedure grc_text (stream, x, y, text) + +int stream # graphics stream +real x, y # NDC coordinates of ll corner of first char +char text[ARB] # text string + +pointer tr, op, last_op +int fd, save1, save2, nwords +int stropen(), strlen() +pointer gtr_init(), gtr_writep() +errchk gtr_init, stropen, gki_redir + +begin + tr = gtr_init (stream) + + # Allocate space in the frame buffer for the text set attribute + # and text drawing instructions. Set the last op for undo to undo + # the line. This is also set by writep, hence we must wait to set + # TR_LASTOP until after the call to writep. + + last_op = TR_OP(tr) + nwords = GKI_TXSET_LEN + GKI_TEXT_LEN + strlen(text) + op = gtr_writep (stream, nwords) + TR_LASTOP(tr) = last_op + + # Open the frame buffer as a file and redirect the graphics stream + # output into the buffer. + + fd = stropen (Mems[op], nwords, NEW_FILE) + call gki_redir (stream, fd, save1, save2) + + # Output the set text attribute instruction and the text drawing + # instruction. + + call gki_txset (stream, TR_TXAP(tr)) + call gki_text (stream, nint(x*GKI_MAXNDC), nint(y*GKI_MAXNDC), text) + + # Restore the normal output for the stream. + call gki_redir (stream, 0, save1, save2) + call close (fd) + + # Call giotr to send the new instructions off to the kernel, optionally + # applying the workstation transformation in the process. + + call giotr (stream) +end diff --git a/sys/gio/cursor/grcwarn.x b/sys/gio/cursor/grcwarn.x new file mode 100644 index 00000000..ba9fcb0e --- /dev/null +++ b/sys/gio/cursor/grcwarn.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GRC_WARN -- Called in an error handler to intercept an error message string +# and write it to the workstation in the status line. + +procedure grc_warn (fd) + +int fd # output stream + +int errcode +pointer sp, msg, ip +int errget() + +begin + call smark (sp) + call salloc (msg, SZ_LINE, TY_CHAR) + + errcode = errget (Memc[msg], SZ_LINE) + for (ip=msg; Memc[ip] != EOS && Memc[ip] != '\n'; ip=ip+1) + ; + Memc[ip] = EOS + + call stg_putline (fd, " - ") + call stg_putline (fd, Memc[msg]) + + call sfree (sp) +end diff --git a/sys/gio/cursor/grcwcs.x b/sys/gio/cursor/grcwcs.x new file mode 100644 index 00000000..7c73657a --- /dev/null +++ b/sys/gio/cursor/grcwcs.x @@ -0,0 +1,282 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "gtr.h" +include "grc.h" + +# GRC_SCRTOWCS -- Transform screen coordinates (raw cursor coordinates) to +# world coordinates. This is not terribly efficient, but it does not matter +# for cursor mode applications which do not involve many coordinate +# transformations. + +procedure grc_scrtowcs (stream, sx, sy, raster, rx, ry, wx, wy, wcs) + +int stream #I graphics stream +real sx, sy #I screen coordinates +int raster #I raster number +real rx, ry #I raster coordinates +real wx, wy #O world coordinates +int wcs #O world coordinate system + +pointer w, tr +real mx, my +real ct[LEN_CT] +int grc_selectwcs() +pointer gtr_init() +errchk gtr_init + +begin + tr = gtr_init (stream) + + # Convert screen (raster 0) to NDC coordinates, undoing the effects + # of the workstation transformation. This is not done for raster + # coordinates since these are already raster-normalized coordinates + # as returned by the server. + + if (raster == 0) + call grc_scrtondc (rx, ry, mx, my) + else { + mx = rx + my = ry + } + + # Select a WCS. The TR_WCS variable is set only if the user + # explicitly fixes the WCS to override automatic selection. The + # best WCS for the raster is used if there is one, otherwise the + # best screen WCS is used. + + if (TR_WCS(tr) == NULL) { + wcs = grc_selectwcs (tr, raster, mx, my) + if (wcs == 0) { + call grc_scrtondc (sx, sy, mx, my) + wcs = grc_selectwcs (tr, 0, mx, my) + } + } else + wcs = TR_WCS(tr) + + # Set up the coordinate transformation. + w = TR_WCSPTR(tr,wcs) + call grc_settran (w, ct) + + # Transform NDC coordinates to WCS coordinates. + call grc_ndctowcs (ct, mx, my, wx, wy) +end + + +# GRC_SETTRAN -- Set up the coordinate transformation parameters for a given +# world coordinate system. + +procedure grc_settran (w, ct) + +pointer w # window descriptor +real ct[LEN_CT] # transformation descriptor + +real worigin, scale +real m1, m2, w1, w2 +int transformation, ax +bool fp_equalr() +real elogr() + +begin + # Compute world -> NDC coordinate transformation. + + do ax = 1, 2 { + if (ax == 1) { + transformation = WCS_XTRAN(w) + w1 = WCS_WX1(w) + w2 = WCS_WX2(w) + m1 = WCS_SX1(w) + m2 = WCS_SX2(w) + } else { + transformation = WCS_YTRAN(w) + w1 = WCS_WY1(w) + w2 = WCS_WY2(w) + m1 = WCS_SY1(w) + m2 = WCS_SY2(w) + } + + if (transformation == LINEAR) { + worigin = w1 + if (fp_equalr (w1, w2)) + scale = 1.0 + else + scale = (m2 - m1) / (w2 - w1) + } else if (transformation == LOG && w1 > 0 && w2 > 0) { + worigin = log10 (w1) + if (fp_equalr (log10(w2), worigin)) + scale = 1.0 + else + scale = (m2 - m1) / (log10(w2) - worigin) + } else { + worigin = elogr (w1) + if (fp_equalr (elogr(w2), worigin)) + scale = 1.0 + else + scale = (m2 - m1) / (elogr(w2) - worigin) + } + + ct[ax,CT_TRAN] = transformation + ct[ax,CT_SCALE] = scale + ct[ax,CT_WORIGIN] = worigin + ct[ax,CT_MORIGIN] = m1 + } +end + + +# GRC_WCSTONDC -- Transform world coordinates to NDC coordinates using the +# computed transformation parameters. + +procedure grc_wcstondc (ct, wx, wy, mx, my) + +real ct[LEN_CT] # coordinate transformation descriptor +real wx, wy # world coordinates of point +real mx, my # ndc coordinates of point + +real v +int transformation, ax +real elogr() + +begin + do ax = 1, 2 { + transformation = nint (ct[ax,CT_TRAN]) + if (ax == 1) + v = wx + else + v = wy + + if (transformation == LINEAR) + ; + else if (transformation == LOG) + v = log10 (v) + else + v = elogr (v) + + v = ((v - ct[ax,CT_WORIGIN]) * ct[ax,CT_SCALE]) + ct[ax,CT_MORIGIN] + if (ax == 1) + mx = v + else + my = v + } +end + + +# GRC_NDCTOWCS -- Transform NDC coordinates to world coordinates using the +# computed transformation parameters. + +procedure grc_ndctowcs (ct, mx, my, wx, wy) + +real ct[LEN_CT] # coordinate transformation descriptor +real mx, my # ndc coordinates of point +real wx, wy # world coordinates of point + +real v +int transformation, ax +real aelogr() + +begin + do ax = 1, 2 { + transformation = nint (ct[ax,CT_TRAN]) + if (ax == 1) + v = mx + else + v = my + + v = ((v - ct[ax,CT_MORIGIN]) / ct[ax,CT_SCALE]) + ct[ax,CT_WORIGIN] + if (transformation == LINEAR) + ; + else if (transformation == LOG) + v = 10.0 ** v + else + v = aelogr (v) + + if (ax == 1) + wx = v + else + wy = v + } +end + + +# GRC_SELECTWCS -- Select the WCS nearest to the given position in NDC +# coordinates. If the point falls within a single WCS then that WCS is +# selected. If the point falls within multiple WCS then the closest WCS +# is selected. If multiple (non unitary) WCS are defined at the same +# distance, e.g., when the WCS share the same viewport, then the highest +# numbered WCS is selected. + +int procedure grc_selectwcs (tr, raster, mx, my) + +pointer tr #I GTR descriptor +int raster #I raster number +real mx, my #I NDC coordinates of point + +pointer w +int wcs, closest_wcs, flags +real tol, sx1, sx2, sy1, sy2 +real distance, old_distance, xcen, ycen +int nin, in[MAX_WCS] + +begin + nin = 0 + closest_wcs = 0 + old_distance = 1.0 + tol = EPSILON * 10.0 + + # Inspect each WCS. All WCS are passed even though only one or two + # WCS will be set to nonunitary values for a given plot. Omitting + # the unitary WCS, determine the closest WCS and make a list of the + # WCS containing the given point. + + do wcs = 1, MAX_WCS { + w = TR_WCSPTR(tr,wcs) + + # Cache WCS params in local storage. + sx1 = WCS_SX1(w) + sx2 = WCS_SX2(w) + sy1 = WCS_SY1(w) + sy2 = WCS_SY2(w) + flags = WCS_FLAGS(w) + xcen = (sx1 + sx2) / 2.0 + ycen = (sy1 + sy2) / 2.0 + + # Skip to next WCS if the raster number doesn't match. + if (WF_RASTER(flags) != raster) + next + + # Skip to next WCS if this one is not defined. + if (and (flags, WF_NEWFORMAT) == 0) { + # Preserve old semantics if passed old format WCS. + if (sx1 == 0 && sx2 == 0 || sy1 == 0 && sy2 == 0) + next + if (abs ((sx2-sx1) - 1.0) < tol && abs ((sy2-sy1) - 1.0) < tol) + next + } else if (and (flags, WF_DEFINED) == 0) + next + + # Determine closest WCS to point (mx,my). + distance = ((mx - xcen) ** 2) + ((my - ycen) ** 2) + if (distance <= old_distance) { + closest_wcs = wcs + old_distance = distance + } + + # Check if point is inside this WCS. + if (mx >= sx1 && mx <= sx2 && my >= sy1 && my <= sy2) { + nin = nin + 1 + in[nin] = wcs + } + } + + # If point is inside exactly one non-unitary WCS then select that WCS. + if (nin == 1) + return (in[1]) + + # If point is inside more than one WCS, or if point is not inside any + # WCS, select the closest WCS. If multiple WCS are at the same + # distance we have already selected the higher numbered WCS due to + # the way the distance test is conducted, above. + + return (closest_wcs) +end diff --git a/sys/gio/cursor/grcwrite.x b/sys/gio/cursor/grcwrite.x new file mode 100644 index 00000000..c0a602a9 --- /dev/null +++ b/sys/gio/cursor/grcwrite.x @@ -0,0 +1,66 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gtr.h" +include "grc.h" + +# GRC_WRITE -- Write the contents of the frame buffer to a file, with or +# without applying the workstation transformation, optionally clobbering +# any existing file of the same name. + +procedure grc_write (tr, stream, fname, clobber, fullframe) + +pointer tr # graphics stream descriptor +int stream # graphics stream +char fname[ARB] # file name +bool clobber # clobber existing file +bool fullframe # write full frame (no workstation transform) + +pointer sp, lbuf +long size1, size2 +int save1, save2, fd, nchars +long fstatl() +int open() +errchk write, gtr_redraw + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + # Delete existing file if clobber requested. + if (clobber) + iferr (call delete (fname)) + ; + + # Open metacode spool file for appending. + iferr (fd = open (fname, APPEND, BINARY_FILE)) { + call grc_message (stream, " - cannot open file for appending") + call sfree (sp) + return + } + + # Write either the full frame or the displayed frame into spool file. + + size1 = fstatl (fd, F_FILESIZE) + if (fullframe) { + nchars = (TR_OP(tr) - TR_FRAMEBUF(tr)) * SZ_SHORT + call write (fd, Mems[TR_FRAMEBUF(tr)], nchars) + } else { + call gki_redir (stream, fd, save1, save2) + call gtr_redraw (stream) + call gki_redir (stream, 0, save1, save2) + } + + size2 = fstatl (fd, F_FILESIZE) + call sprintf (Memc[lbuf], SZ_LINE, " - %d chars %s") + call pargi (size2 - size1) + if (size1 > 0) + call pargstr ("appended") + else + call pargstr ("") + call grc_message (stream, Memc[lbuf]) + + call close (fd) + call sfree (sp) +end diff --git a/sys/gio/cursor/gtr.com b/sys/gio/cursor/gtr.com new file mode 100644 index 00000000..ae5c3ac6 --- /dev/null +++ b/sys/gio/cursor/gtr.com @@ -0,0 +1,25 @@ +# GTR.COM -- Polyline clipping common for the workstation transformation. +# The length of this common in integer units from startcom to endcom inclusive +# is a defined parameter in giotr.h. Values within the save area are saved +# in the TR descriptor for a device and loaded into the common (which serves +# as a cache) when GIOTR or RCURSOR is called for a device. LENGTH=28 + +pointer trdes[MAX_PSEUDOFILES] # pointers to giotr descriptors +int tr_stream # graphics stream currently in the cache +int startcom # dummy entry marking start of common +int pl_op # index of next cell in polyline array +bool last_point_inbounds # last point was inbounds +int pl_type # type of instruction (polyline, polymarker,...) +int wstranset # workstation transformation has been set +real xscale, yscale # scale factor, world to GKI, for transform +real xorigin, yorigin # origins in GKI coords, for transform +long cx, cy # current pen position, GKI coords +long mx1, mx2, my1, my2 # clipping viewport, GKI coords +real vx1, vx2, vy1, vy2 # NDC viewport, may extend beyond boundary +long xs[4], ys[4] # last point plotted (for clipping code) +int endcom # dummy entry marking end of saved area +short pl[LEN_PLBUF+5] # output polyline buffer (plus GKI header) + +common /gtrcom/ trdes, tr_stream, startcom, pl_op, last_point_inbounds, + pl_type, wstranset, xscale, yscale, xorigin, yorigin, cx, cy, + mx1, mx2, my1, my2, vx1, vx2, vy1, vy2, xs, ys, endcom, pl diff --git a/sys/gio/cursor/gtr.h b/sys/gio/cursor/gtr.h new file mode 100644 index 00000000..3fbf93f5 --- /dev/null +++ b/sys/gio/cursor/gtr.h @@ -0,0 +1,51 @@ +# GIOTR.H -- Global definitions for the GIOTR graphics i/o workstation +# transformation and i/o program unit. Note: requires . + +define DEF_MAXLENFRAMEBUF 128000 +define DEF_LENFRAMEBUF 8192 +define INC_LENFRAMEBUF 4096 +define DEF_LENSCRATCHBUF 256 +define INC_LENSCRATCHBUF 256 +define MAX_PSEUDOFILES 10 +define SZ_TRDEVNAME 229 +define SZ_KERNFNAME 259 +define LEN_GTRCOM 28 # see "gtr.com" +define KSHIFT 10000 # encode pr ("etc$prpsio.x") such that + # + # ((pr*KSHIFT)+stream) > LAST_FD + # + # see also + +define LEN_TRSTRUCT (564+204) + +define TR_PID Memi[$1] # process id of kernel +define TR_IN Memi[$1+1] # input from process +define TR_OUT Memi[$1+2] # output to process +define TR_TTY Memi[$1+3] # graphcap descriptor +define TR_SPOOLDATA Memi[$1+4] # spool metacode instructions +define TR_FRAMEBUF Memi[$1+5] # pointer to frame buffer +define TR_LENFRAMEBUF Memi[$1+6] # length of the frame buffer +define TR_MAXLENFRAMEBUF Memi[$1+7] # max length of the frame buffer +define TR_IP Memi[$1+8] # input pointer into frame buf +define TR_OP Memi[$1+9] # output pointer into frame buf +define TR_LASTOP Memi[$1+10] # last OP (for undo) +define TR_SCRATCHBUF Memi[$1+11] # for annotating plots +define TR_LENSCRATCHBUF Memi[$1+12] # length of the scratch buffer +define TR_OPSB Memi[$1+13] # output pointer, scratch buf +define TR_NOPEN Memi[$1+14] # number of opens +define TR_REDIR Memi[$1+15] # redirection information +define TR_WCS Memi[$1+16] # WCS selected, 0 if none +define TR_PAGE Memi[$1+17] # clear screen for text +define TR_WAITPAGE Memi[$1+18] # grc_waitpage flag +define TR_WSOPEN Memi[$1+19] # workstation open count +define TR_SKIPOPEN Memi[$1+20] # skip wsopen in metacode +define TR_WSACTIVE Memi[$1+21] # workstation activated? +define TR_WSACTSAVE Memi[$1+22] # save old wsactive state +define TR_INTERACTIVE Memi[$1+23] # the user graphics terminal? + # (open) +define TR_TXAP ($1+30) # text drawing attributes +define TR_PLAP ($1+40) # text drawing attributes +define TR_DEVNAME Memc[P2C($1+44)] # device name +define TR_KERNFNAME Memc[P2C($1+274)] # name of kernel file (or "cl") +define TR_GTRCOM Memi[$1+534] # storage for the gtr common +define TR_WCSPTR (($1)+564+($2)*LEN_WCS) # WCS storage (0=not used) diff --git a/sys/gio/cursor/gtrbackup.x b/sys/gio/cursor/gtrbackup.x new file mode 100644 index 00000000..9ab13c0b --- /dev/null +++ b/sys/gio/cursor/gtrbackup.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "gtr.h" + +# GTR_BACKUP -- Backup one drawing instruction in the frame buffer. Erase +# the graphics if possible. The effects of this function may be undone by +# the UNDO operator. + +procedure gtr_backup (stream) + +int stream # graphics stream + +int opcode +pointer tr, op, bp, sp, ap +pointer gtr_init() +errchk gtr_init +include "gtr.com" + +begin + call smark (sp) + call salloc (ap, LEN_PL, TY_STRUCT) + + tr = gtr_init (stream) + + # Scan backward to the beginning of the last drawing instruction in the + # frame buffer. + + op = TR_OP(tr) + bp = TR_FRAMEBUF(tr) + if (op <= bp) { + call sfree (sp) + return + } + + repeat { + op = op - 1 + while (Mems[op] != BOI) + if (op <= bp) { + TR_OP(tr) = bp + TR_IP(tr) = bp + call sfree (sp) + return + } else + op = op - 1 + opcode = Mems[op+GKI_HDR_OPCODE-1] + } until (opcode >= GKI_POLYLINE && opcode <= GKI_PUTCELLARRAY) + + # Redraw the last instruction to erase it (device permitting). + if (opcode == GKI_POLYLINE) { + PL_LTYPE(ap) = GL_CLEAR + PL_WIDTH(ap) = 1.0 + PL_COLOR(ap) = 1 + call gki_plset (stream, ap) + + if (wstranset == YES) + call gtr_wstran (Mems[op]) + else + call gki_write (stream, Mems[op]) + + PL_LTYPE(ap) = GL_SOLID + call gki_plset (stream, ap) + call gki_fflush (stream) + } + + # Return the space in the buffer. + TR_LASTOP(tr) = TR_OP(tr) + TR_OP(tr) = op + TR_IP(tr) = min (op, TR_IP(tr)) + + call sfree (sp) +end diff --git a/sys/gio/cursor/gtrconn.x b/sys/gio/cursor/gtrconn.x new file mode 100644 index 00000000..c2e6fb47 --- /dev/null +++ b/sys/gio/cursor/gtrconn.x @@ -0,0 +1,78 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GTR_CONNECT -- Connect a subprocess containing a graphics kernel task to a +# graphics stream. The graphics kernel task is a conventional IRAF task +# linked into the kernel process. After spawning the subprocess, we command +# the process to run the named kernel task, then service the parameter +# requests from the task as it begins running. Graphics i/o will be via one +# of the graphics streams, leaving STDIN, STDOUT, and STDERR free to access +# the corresponding streams in the parent (the CL). A kernel may be opened +# either to drive a particular device (if devname is specified) or to drive +# a device selected at runtime. If the kernel is opened to drive a particular +# device the device name in the OPENWS instruction will be ignored. We require +# that the graphics kernel begin processing metacode immediately after +# receiving "yes" for the value of the parameter "generic", signifying that +# the caller wishes a generic kernel, i.e., cannot return the values of any +# kernel dependent parameters. + +int procedure gtr_connect (kernfname, taskname, devname, stream, in, out) + +char kernfname[ARB] # name of executable kernel file +char taskname[ARB] # name of kernel task +char devname[ARB] # device name or null string +int stream # graphics stream to connect process to +int in, out # input and output streams to process + +pointer sp, lbuf +int pid +bool streq() +int propen(), getline() +errchk propen, flush, getline, syserr + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + pid = propen (kernfname, in, out) + call fprintf (out, "%s\n") + call pargstr (taskname) + call flush (out) + + # Pass values of the kernel parameters. For a kernel run as + # part of the graphics system there are only three parameters, + # the input file name (STDGRAPH, etc. for a connected kernel) + # the device name if the kernel is to ignore device names in + # OPENWS instructions, and "generic=yes", signifying that the + # kernel dependent parameters are not to be requested. + + while (getline (in, Memc[lbuf]) != EOF) { + if (streq (Memc[lbuf], "=input\n")) { + call fprintf (out, "%s\n") + switch (stream) { + case STDGRAPH: + call pargstr ("STDGRAPH") + case STDIMAGE: + call pargstr ("STDIMAGE") + case STDPLOT: + call pargstr ("STDPLOT") + } + call flush (out) + } else if (streq (Memc[lbuf], "=device\n")) { + call fprintf (out, "%s\n") + call pargstr (devname) + call flush (out) + } else if (streq (Memc[lbuf], "=generic\n")) { + call putline (out, "yes\n") + call flush (out) + break + } else { + call putline (STDERR, Memc[lbuf]) + call syserr (SYS_GKERNPARAM) + } + } + + call sfree (sp) + return (pid) +end diff --git a/sys/gio/cursor/gtrctrl.x b/sys/gio/cursor/gtrctrl.x new file mode 100644 index 00000000..8de08ccb --- /dev/null +++ b/sys/gio/cursor/gtrctrl.x @@ -0,0 +1,122 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include "gtr.h" + +# GTR_CONTROL -- Execute a graphics control instruction, e.g., connect a +# graphics kernel to a graphics stream and set or get the WCS for a frame. +# The control instructions are GKI encoded instructions transmitted to the +# pseudofile GIOCONTROL. The PR_PSIO procedure (which processes the pseudofile +# directives from a subprocess) calls us whenever data is sent to this +# special pseudofile. + +procedure gtr_control (stream, gki, source_pid) + +int stream # graphics stream +short gki[ARB] # encoded graphics control instruction +int source_pid # pid of requesting process + +bool redirected +pointer tr, sp, devname, gki_out +int flags, mode, nwords, fd, p_fd +int prstati(), pr_getredir() +pointer gtr_init(), coerce() +errchk gtr_init, gtr_openws, write, flush, gki_write +include "gtr.com" + +begin + call smark (sp) + call salloc (devname, SZ_TRDEVNAME, TY_CHAR) + + nwords = gki[GKI_HDR_LENGTH] + call salloc (gki_out, nwords, TY_SHORT) + call amovs (gki, Mems[gki_out], nwords) + + tr = gtr_init (stream) + p_fd = abs (pr_getredir (source_pid, stream)) + redirected = (p_fd >= FIRST_FD && p_fd <= LAST_FD) + + switch (gki[GKI_HDR_OPCODE]) { + case GKI_OPENWS: + mode = gki[GKI_OPENWS_M] + nwords = gki[GKI_OPENWS_N] + + # Unpack the device name, passed as a short integer array. + call achtsc (gki[GKI_OPENWS_D], Memc[devname], nwords) + Memc[devname+nwords] = EOS + + # Connect the kernel. + call fseti (stream, F_CANCEL, OK) + call gtr_openws (Memc[devname], mode, stream, source_pid) + + # Count the logical openws. + TR_WSOPEN(tr) = TR_WSOPEN(tr) + 1 + TR_WSACTIVE(tr) = YES + TR_WSACTSAVE(tr) = NO + + # Due to a call to F_CANCEL in prpsio the openws instruction + # spooled by gki_write below is being lost for subkernels, + # so don't set the skipopen flag. This causes giotr to pass + # the openws on to the subkernel. For inline kernels setting + # skipopen prevents the openws from being executed twice. + + if (TR_INTERACTIVE(tr) == YES) + TR_SKIPOPEN(tr) = YES + + # If opening NEW_FILE, discard any previous WCS and clear the + # frame buffer. + + if (mode == NEW_FILE) { + call aclri (Memi[TR_WCSPTR(tr,1)], LEN_WCS * MAX_WCS) + call gtr_frame (tr, TR_FRAMEBUF(tr), stream) + } + + case GKI_CLOSEWS: + # Count the logical closews. + TR_WSOPEN(tr) = TR_WSOPEN(tr) - 1 + TR_WSACTIVE(tr) = NO + + case GKI_DEACTIVATEWS: + TR_WSACTIVE(tr) = NO + if (TR_INTERACTIVE(tr) == YES && TR_PAGE(tr) == NO) { + flags = gki[GKI_REACTIVATEWS_F] + if (and (flags, AW_CLEAR) != 0) + Mems[gki_out+GKI_REACTIVATEWS_F-1] = flags - AW_CLEAR + } + + case GKI_REACTIVATEWS: + TR_WSACTIVE(tr) = YES + if (TR_INTERACTIVE(tr) == YES) { + flags = gki[GKI_REACTIVATEWS_F] + if (and (flags, AW_PAUSE) != 0) + call gtr_waitpage (STDERR, stream) + } + + case GKI_SETWCS: + nwords = gki[GKI_SETWCS_N] + call amovs (gki[GKI_SETWCS_WCS], + Mems[coerce (TR_WCSPTR(tr,1), TY_STRUCT, TY_SHORT)], + min (nwords, LEN_WCS * MAX_WCS * SZ_STRUCT / SZ_SHORT)) + + case GKI_GETWCS: + nwords = gki[GKI_GETWCS_N] + fd = prstati (source_pid, PR_OUTFD) + + call write (fd, Memi[TR_WCSPTR(tr,1)], nwords * SZ_SHORT) + call flush (fd) + } + + # Pass the (possibly modified) instruction on to the kernel. + # We must NOT call gki_flush or gki_fflush here, as this would + # result in a reentrant call to prpsio when writing to a subkernel. + + if (!redirected) + call gki_write (stream, Mems[gki_out]) + + call sfree (sp) +end diff --git a/sys/gio/cursor/gtrdelete.x b/sys/gio/cursor/gtrdelete.x new file mode 100644 index 00000000..97f418a0 --- /dev/null +++ b/sys/gio/cursor/gtrdelete.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gtr.h" + +# GTR_DELETE -- Delete an instruction from the frame buffer. This prevents +# the instruction from being executed if the frame is redrawn. + +procedure gtr_delete (tr, gki) + +pointer tr #I giotr descriptor +pointer gki #I instruction to be deleted + +pointer inext +int nwords, shift, ilen + +begin + ilen = Mems[gki+GKI_HDR_LENGTH-1] + inext = gki + ilen + + if (inext >= TR_OP(tr)) { + # Instruction is the last one in the buffer. + TR_OP(tr) = gki + TR_LASTOP(tr) = TR_OP(tr) + if (TR_IP(tr) >= gki) + TR_IP(tr) = gki + + } else { + # If the instruction is small and would be expensive to delete + # just change the opcode to disable it, otherwise shift the + # buffer contents back to overwrite the deleted instruction. + + nwords = TR_OP(tr) - inext + if (ilen < 32 && nwords > 2048) + Mems[gki+GKI_HDR_OPCODE-1] = GKI_UNKNOWN + else { + call amovs (Mems[inext], Mems[gki], nwords) + shift = inext - gki + TR_IP(tr) = TR_IP(tr) - shift + TR_OP(tr) = TR_OP(tr) - shift + TR_LASTOP(tr) = TR_OP(tr) + } + } +end diff --git a/sys/gio/cursor/gtrdiscon.x b/sys/gio/cursor/gtrdiscon.x new file mode 100644 index 00000000..5eba23f4 --- /dev/null +++ b/sys/gio/cursor/gtrdiscon.x @@ -0,0 +1,66 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GTR_DISCONNECT -- Disconnect from a kernel subprocess. To achieve an orderly +# shutdown we process any outstanding XMIT or XFER requests, then transmit an +# end of file (zero length record) to the kernel task when it reads from the +# graphics stream. The kernel should then shutdown and eventually we will +# receive "bye" from the process. We then call PRCLOSE to shutdown the +# process for good. Note: we do not expect anything but an XFER (read) request +# on the graphics stream, but it seems prudent to do something reasonable if +# some other request is received. + +procedure gtr_disconnect (pid, in, out, stream) + +int pid # process id of subprocess +int in, out # command i/o streams of the subprocess +int stream # graphics stream used by kernel + +pointer sp, sp2, lbuf, buf +int pseudofile, nchars, junk +bool streq() +int getline(), read(), strncmp(), psio_isxmit(), prclose(), pr_findproc() +errchk getline, prclose, read, write + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + while (getline (in, Memc[lbuf]) != EOF) { + if (streq (Memc[lbuf], "bye\n") || + strncmp (Memc[lbuf], "ERROR", 5) == 0) { + + junk = prclose (pid) + break + + } else if (Memc[lbuf] == '!') { + # OS escape. + call proscmd (pr_findproc(pid), Memc[lbuf+1]) + + } else { + call smark (sp2) + + switch (psio_isxmit (Memc[lbuf], pseudofile, nchars)) { + case XMIT: + call salloc (buf, nchars, TY_CHAR) + nchars = read (in, Memc[buf], nchars) + if (nchars > 0) + if (pseudofile == STDOUT || pseudofile == STDERR) + call write (pseudofile, Memc[buf], nchars) + + case XFER: + call salloc (buf, nchars, TY_CHAR) + if (pseudofile == STDIN) + nchars = read (pseudofile, Memc[buf], nchars) + else + nchars = 0 # this is the EOF + call psio_xfer (out, Memc[buf], nchars) + } + + call sfree (sp2) + } + } + + call sfree (sp) +end diff --git a/sys/gio/cursor/gtrfetch.x b/sys/gio/cursor/gtrfetch.x new file mode 100644 index 00000000..44ccfe60 --- /dev/null +++ b/sys/gio/cursor/gtrfetch.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gtr.h" + +# GTR_FETCH_NEXT_INSTRUCTION -- Return a pointer to the next GKI metacode +# instruction in the input buffer. Only complete instructions resident in +# a contiguous section of memory are returned. EOF is returned when the +# end of the current buffer is reached, or when the last instruction in the +# frame buffer is not yet complete. EOF does not signify the end of the +# metacode stream. + +int procedure gtr_fetch_next_instruction (tr, gki) + +pointer tr # pointer to giotr descriptor +pointer gki # pointer to next instruction (output) + +int nleft, length +pointer ip, itop + +begin + ip = TR_IP(tr) + itop = TR_OP(tr) + + # Search for the beginning of the next instruction. + while (Mems[ip] != BOI && ip < itop) + ip = ip + 1 + + nleft = itop - ip + if (nleft < 3) { + # The length field of the next instruction is not yet present. + TR_IP(tr) = ip + return (EOF) + } else { + length = Mems[ip+GKI_HDR_LENGTH-1] + if (length > nleft) { + # Entire instruction is not yet present in buffer. + TR_IP(tr) = ip + return (EOF) + } else { + # Entire instruction is present in buffer. + TR_IP(tr) = ip + length + gki = ip + return (length) + } + } +end diff --git a/sys/gio/cursor/gtrframe.x b/sys/gio/cursor/gtrframe.x new file mode 100644 index 00000000..baf68ffb --- /dev/null +++ b/sys/gio/cursor/gtrframe.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gtr.h" + +# GTR_FRAME -- Clear the frame buffer, used to spool the metacode instructions +# required to draw a graphics frame. This is done by moving the metacode data +# at the end of the buffer (beginning with the word pointed to by gki) to the +# beginning of the buffer and adjusting the input and output pointers +# accordingly. The workstation transformation is also reset to the unitary +# transformation when the frame is cleared, i.e., zoom is cancelled. + +procedure gtr_frame (tr, gki, stream) + +pointer tr # giotr descriptor +pointer gki # pointer to first word to be preserved +int stream # graphics stream + +pointer bp +int nwords, shift + +begin + bp = TR_FRAMEBUF(tr) + + if (gki > bp) { + nwords = TR_OP(tr) - gki + call amovs (Mems[gki], Mems[bp], nwords) + shift = gki - bp + TR_IP(tr) = TR_IP(tr) - shift + TR_OP(tr) = TR_OP(tr) - shift + } else { + TR_IP(tr) = bp + TR_OP(tr) = bp + } + + call gtr_ptran (stream, 0., 1., 0., 1.) + TR_OPSB(tr) = TR_SCRATCHBUF(tr) + TR_LASTOP(tr) = TR_OP(tr) + TR_WCS(tr) = NULL +end diff --git a/sys/gio/cursor/gtrgflush.x b/sys/gio/cursor/gtrgflush.x new file mode 100644 index 00000000..5681e234 --- /dev/null +++ b/sys/gio/cursor/gtrgflush.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gtr.h" + +# GTR_GFLUSH -- Dispose of any buffered output on the stream STDPLOT. The last +# plot sent to stdplot cannot be disposed of at CLOSEWS time due to the need +# to permit APPEND mode in the next OPENWS call. We are called to dispose +# of all output to the plotter device. Logging out or doing a reset will have +# the same effect. + +procedure gtr_gflush (stream) + +int stream +pointer tr +bool streq() +include "gtr.com" + +begin + tr = trdes[stream] + if (tr == NULL) + return + + # Disconnect the kernel. + iferr { + if (streq (TR_KERNFNAME(tr), "cl")) + call stg_close() + else if (TR_DEVNAME(tr) != EOS && TR_KERNFNAME(tr) != EOS) { + call gtr_disconnect (TR_PID(tr), TR_IN(tr), TR_OUT(tr), + stream) + TR_PID(tr) = NULL + } + } then + call erract (EA_WARN) + + # Free all storage. + call mfree (TR_FRAMEBUF(tr), TY_SHORT) + call mfree (TR_SCRATCHBUF(tr), TY_SHORT) + call mfree (tr, TY_STRUCT) + + trdes[stream] = NULL + if (tr_stream == stream) + tr_stream = NULL +end diff --git a/sys/gio/cursor/gtrgtran.x b/sys/gio/cursor/gtrgtran.x new file mode 100644 index 00000000..c83c83aa --- /dev/null +++ b/sys/gio/cursor/gtrgtran.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gtr.h" + +# GTR_GTRAN -- Get the workstation transformation. + +procedure gtr_gtran (fd, x1, x2, y1, y2) + +int fd # graphics stream to be set +real x1, x2 # range of workstation viewport in X +real y1, y2 # range of workstation viewport in Y +include "gtr.com" + +begin + if (wstranset == YES) { + x1 = vx1 + x2 = vx2 + y1 = vy1 + y2 = vy2 + } else { + x1 = 0 + x2 = 1.0 + y1 = 0 + y2 = 1.0 + } +end diff --git a/sys/gio/cursor/gtrgtty.x b/sys/gio/cursor/gtrgtty.x new file mode 100644 index 00000000..0e67a1fd --- /dev/null +++ b/sys/gio/cursor/gtrgtty.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gtr.h" + +# GTR_GTTY -- Get the graphcap descriptor for a stream. + +pointer procedure gtr_gtty (stream) + +int stream # graphics stream of interest + +pointer tr +pointer gtr_init() +errchk gtr_init + +begin + tr = gtr_init (stream) + return (TR_TTY(tr)) +end diff --git a/sys/gio/cursor/gtrinit.x b/sys/gio/cursor/gtrinit.x new file mode 100644 index 00000000..734d8202 --- /dev/null +++ b/sys/gio/cursor/gtrinit.x @@ -0,0 +1,136 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "gtr.h" + +# GTR_INIT -- Initialize the GIOTR data structures for a graphics stream. These +# data structures are initialized only once, when the first i/o occurs on the +# stream. Thereafter our only function is to fault the workstation +# transformation parameters into the cache (the gtr common). + +pointer procedure gtr_init (stream) + +int stream # graphics stream + +int i, len_fb, len_sb +pointer tr, tx, ap, w +bool first_time +int btoi(), envgeti() +data first_time /true/ +errchk calloc, malloc +include "gtr.com" + +begin + if (first_time) { + call amovki (NULL, trdes, MAX_PSEUDOFILES) + tr_stream = NULL + first_time = false + } + + tr = trdes[stream] + + if (tr == NULL) { + # This is the first time the stream has been accessed. + + # Allocate descriptor. + call calloc (tr, LEN_TRSTRUCT, TY_STRUCT) + + # Don't need a frame buffer for STDPLOT, but make a dummy one + # anyhow so that the stream looks like the interactive ones. + + if (stream == STDPLOT) { + len_fb = 1 + len_sb = 1 + } else { + len_fb = DEF_LENFRAMEBUF + len_sb = DEF_LENSCRATCHBUF + } + + call malloc (TR_FRAMEBUF(tr), len_fb, TY_SHORT) + call malloc (TR_SCRATCHBUF(tr), len_sb, TY_SHORT) + + trdes[stream] = tr + TR_IP(tr) = TR_FRAMEBUF(tr) + TR_OP(tr) = TR_FRAMEBUF(tr) + TR_OPSB(tr) = TR_SCRATCHBUF(tr) + TR_LENFRAMEBUF(tr) = len_fb + TR_LENSCRATCHBUF(tr) = len_sb + TR_SPOOLDATA(tr) = btoi (stream != STDPLOT) + TR_WAITPAGE(tr) = NO + TR_PAGE(tr) = YES + + # Set text drawing attributes for annotating plots. + tx = TR_TXAP(tr) + TX_UP(tx) = 90 + TX_SIZE(tx) = 1.0 + TX_PATH(tx) = GT_RIGHT + TX_SPACING(tx) = 0 + TX_HJUSTIFY(tx) = GT_LEFT + TX_VJUSTIFY(tx) = GT_BOTTOM + TX_FONT(tx) = GT_ROMAN + TX_QUALITY(tx) = GT_NORMAL + TX_COLOR(tx) = 1 + + # Set default polyline attributes for axis drawing. + ap = TR_PLAP(tr) + PL_LTYPE(ap) = GL_SOLID + PL_WIDTH(ap) = 1.0 + PL_COLOR(ap) = 1 + + # The user can override the default maximum frame buffer length + # if they wish, permitting spooling of frames of any size. + + iferr (TR_MAXLENFRAMEBUF(tr) = envgeti ("cmbuflen")) + TR_MAXLENFRAMEBUF(tr) = DEF_MAXLENFRAMEBUF + + if (tr_stream != NULL) { + # Save the workstation transformation parameters for the + # stream currently in the cache, if any. + + call amovi (startcom, TR_GTRCOM(trdes[tr_stream]), LEN_GTRCOM) + call amovi (TR_GTRCOM(tr), startcom, LEN_GTRCOM) + } + + # Initialize the transformation parameters for the new stream. + tr_stream = stream + xscale = 1.0 + yscale = 1.0 + mx2 = GKI_MAXNDC + my2 = GKI_MAXNDC + vx2 = 1.0 + vy2 = 1.0 + + # Initialize the WCS in case someone tries to read the cursor + # before there are any graphics. + + do i = 1, MAX_WCS { + w = TR_WCSPTR(tr,i) + WCS_SX1(w) = 0.0 + WCS_SX2(w) = 1.0 + WCS_SY1(w) = 0.0 + WCS_SY2(w) = 1.0 + + WCS_WX1(w) = 0.0 + WCS_WX2(w) = 1.0 + WCS_WY1(w) = 0.0 + WCS_WY2(w) = 1.0 + } + + } else if (stream != tr_stream) { + # The stream has already been initialized. + + # If the cache is currently validated for some different stream + # move the data for that stream out into its descriptor. + + if (tr_stream != NULL) + call amovi (startcom, TR_GTRCOM(trdes[tr_stream]), LEN_GTRCOM) + + # Load the data for the new stream into the cache. + call amovi (TR_GTRCOM(tr), startcom, LEN_GTRCOM) + tr_stream = stream + } + + return (tr) +end diff --git a/sys/gio/cursor/gtropenws.x b/sys/gio/cursor/gtropenws.x new file mode 100644 index 00000000..27a3072a --- /dev/null +++ b/sys/gio/cursor/gtropenws.x @@ -0,0 +1,206 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include +include +include "gtr.h" + +# GTR_OPENWS -- Called by gtr_control(pr_psio) to connect a kernel to a +# graphics stream and to initialize the datapath to the kernel. +# The workstation is not physically opened until the GKI open workstation +# directive has been sent to the kernel. There are two types of kernels, +# the builtin (STDGRAPH) kernel, and all external kernels. The external +# kernels reside in connected subprocesses communicating via the central +# process (the CL process) with the graphics task in another subprocess. + +procedure gtr_openws (devspec, mode, stream, source_pid) + +char devspec[ARB] #I device specification +int mode #I access mode +int stream #I graphics stream +int source_pid #I process which issued the openws directive + +int redir_code, dd[LEN_GKIDD], ip +pointer sp, op, tr, tty, kernfname, taskname, device + +bool streq() +pointer ttygdes() +int pr_getredir(), ttygets(), gtr_connect(), pr_findproc(), locpr() +extern gtr_reset(), prpsio() + +errchk syserr, syserrs, fseti, ttygdes, ttycdes, pr_redir, stg_close, stg_open +errchk gtr_connect, gtr_disconnect +include "gtr.com" + +begin + call smark (sp) + call salloc (kernfname, SZ_FNAME, TY_CHAR) + call salloc (taskname, SZ_FNAME, TY_CHAR) + call salloc (device, SZ_FNAME, TY_CHAR) + + tr = trdes[stream] + + # Extract the device name field from the device specification. + op = device + for (ip=1; devspec[ip] != EOS; ip=ip+1) + if (devspec[ip] == ',') + break + else { + Memc[op] = devspec[ip] + op = op + 1 + } + Memc[op] = EOS + + # We only connect up the i/o channels, and do not issue the OPENWS + # to the gio kernel, so reset the counter to zero to indicate that + # the workstation has not yet been (logically) opened. + + TR_WSOPEN(tr) = 0 + + # If the stream has been redirected into a file, do not connect a + # kernel. + + redir_code = pr_getredir (source_pid, stream) + if (redir_code >= FIRST_FD && redir_code <= LAST_FD) { + call sfree (sp) + return + } + + # The graphics stream is a spoolfile in this process (the CL process). + # Spoolfiles are files that are fully buffered in memory and never + # get written to disk. Data is written into the spoolfile and then + # read back out by a different part of the program. + + call fseti (stream, F_TYPE, SPOOL_FILE) + call fseti (stream, F_CANCEL, OK) + + # If the device is already connected to the stream (or we are + # appending to a connected device) all we need do is reset the + # redirection code for the graphics stream. This code is reset to + # the default value (the code for the stream itself) by the CL when + # a task is spawned. + + if (TR_DEVNAME(tr) != EOS && mode == APPEND || + streq (devspec, TR_DEVNAME(tr))) { + call pr_redir (source_pid, stream, TR_REDIR(tr)) + call sfree (sp) + return + } + + # Connect the named kernel, i.e., disconnect the old kernel if any + # and connect the new one. Set the redirection information for the + # named stream of the source process. + + iferr { + # Close device graphcap descriptor. + if (TR_TTY(tr) != NULL) + call ttycdes (TR_TTY(tr)) + + # Disconnect old kernel. + if (streq (TR_KERNFNAME(tr), "cl")) + call stg_close() + else if (TR_DEVNAME(tr) != EOS && TR_KERNFNAME(tr) != EOS) { + call gtr_disconnect (TR_PID(tr), TR_IN(tr), TR_OUT(tr), stream) + TR_PID(tr) = NULL + TR_IN(tr) = NULL + TR_OUT(tr) = NULL + } + } then { + TR_DEVNAME(tr) = EOS + call erract (EA_ERROR) + } else + TR_DEVNAME(tr) = EOS + + # Get graphcap entry for the new device. The special device name + # "none" indicates that there is no suitable stdgraph device. + + if (streq (devspec, "none")) { + switch (stream) { + case STDGRAPH: + call syserr (SYS_GGNONE) + case STDIMAGE: + call syserr (SYS_GINONE) + case STDPLOT: + call syserr (SYS_GPNONE) + default: + call syserr (SYS_GGNONE) + } + } else { + tty = ttygdes (Memc[device]) + TR_TTY(tr) = tty + } + + # Get the name of the executable file containing the kernel for the + # device. The special name "cl" signifies the builtin STDGRAPH kernel. + + if (ttygets (tty, "kf", Memc[kernfname], SZ_FNAME) <= 0) { + call ttycdes (tty) + call syserrs (SYS_GNOKF, Memc[device]) + } else if (ttygets (tty, "tn", Memc[taskname], SZ_FNAME) <= 0) + ; + + # Connect the new kernel. + call strcpy (Memc[kernfname], TR_KERNFNAME(tr), SZ_KERNFNAME) + + if (streq (Memc[kernfname], "cl")) { + # Open the stdgraph kernel. Connect the referenced GKI stream to + # the stdgraph kernel. Set a negative redirection code value to + # flag that GIOTR is to be called to filter graphics output from + # the process. + + call stg_open (devspec, dd, STDIN, STDOUT, 0, 0, 0) + call gki_inline_kernel (stream, dd) + if (source_pid != NULL) + call pr_redir (source_pid, stream, -stream) + TR_REDIR(tr) = -stream + TR_INTERACTIVE(tr) = YES + + } else { + # Spawn subprocess and start up kernel task. + TR_PID(tr) = gtr_connect (Memc[kernfname], Memc[taskname], + devspec, stream, TR_IN(tr), TR_OUT(tr)) + + # Encode the process slot number of the kernel process in the + # redirection code for the source process (the process which + # issued the openws). If the stream is STDGRAPH or STDIMAGE + # make the redirection code negative to flag that graphics + # output is to be processed through GIOTR (the workstation + # transformation). + + if (source_pid != NULL) { + redir_code = (pr_findproc(TR_PID(tr)) * KSHIFT) + stream + if (stream == STDGRAPH || stream == STDIMAGE) + redir_code = -redir_code + call pr_redir (source_pid, stream, redir_code) + TR_REDIR(tr) = redir_code + + # Mark the process busy. This flags it it as busy executing + # some subprotocol (in this case processing GKI metacode) and + # prevents commands such as chdir/set from being sent to the + # process and corrupting the IPC protocol. + + call prseti (TR_PID(tr), PR_STATUS, P_BUSY) + } + + call gki_subkernel (stream, TR_PID(tr), locpr(prpsio)) + TR_INTERACTIVE(tr) = NO + } + + # Do not change value of DEVNAME until the new kernel has been + # successfully connected, since this variable is used to test if + # the kernel is already connected. + + call strcpy (devspec, TR_DEVNAME(tr), SZ_TRDEVNAME) + + # Post the gtr_reset procedure to be executed upon process shutdown, + # to close down any connected graphics subkernels in an orderly way. + + call onexit (gtr_reset) + + call sfree (sp) +end diff --git a/sys/gio/cursor/gtrpage.x b/sys/gio/cursor/gtrpage.x new file mode 100644 index 00000000..2caa53cb --- /dev/null +++ b/sys/gio/cursor/gtrpage.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gtr.h" + +# GTR_PAGE -- Prepare the workstation for output of one or more pages of text. +# Whether or not the terminal is paged is optional. On terminals where the +# text and graphics are overlaid, it is possible to run the text by beneath +# the plot without affecting the plot. + +procedure gtr_page (fd, stream) + +int fd # output file +int stream # graphics stream + +pointer tr +pointer gtr_init() +errchk gtr_init + +begin + tr = gtr_init (stream) + + if (TR_PAGE(tr) == YES) + call gki_deactivatews (stream, AW_CLEAR) + else + call gki_deactivatews (stream, 0) + + TR_WAITPAGE(tr) = YES +end diff --git a/sys/gio/cursor/gtrptran.x b/sys/gio/cursor/gtrptran.x new file mode 100644 index 00000000..eba3075e --- /dev/null +++ b/sys/gio/cursor/gtrptran.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "gtr.h" + +# GTR_PTRAN -- Set the workstation transformation. The workstation +# transformation is automatically zeroed whenever the screen is cleared +# or when a workstation is opened. + +procedure gtr_ptran (stream, x1, x2, y1, y2) + +int stream # graphics stream to be set +real x1, x2 # range of workstation viewport in X +real y1, y2 # range of workstation viewport in Y + +pointer tr +real tol, min_width, dx, dy +real cx1, cx2, cy1, cy2 +include "gtr.com" + +begin + tr = trdes[stream] + tol = 5.0 * EPSILON + + if (abs(x1) < tol && abs (x2 - 1.0) < tol && + abs(y1) < tol && abs (y2 - 1.0) < tol) { + + wstranset = NO + + } else { + # Save viewport. + vx1 = x1 + vx2 = x2 + vy1 = y1 + vy2 = y2 + + # Clip viewport at NDC boundary. + cx1 = max (0., min (1., x1)) + cx2 = max (0., min (1., x2)) + cy1 = max (0., min (1., y1)) + cy2 = max (0., min (1., y2)) + + # Make sure the viewport does not have a zero extent in either + # axis after clipping. + min_width = 1E-4 + if (cx2 - cx1 < min_width) + cx2 = cx1 + min_width + if (cy2 - cy1 < min_width) + cy2 = cy1 + min_width + + # Set clipping viewport in input GKI space. + mx1 = nint (cx1 * GKI_MAXNDC) + mx2 = nint (cx2 * GKI_MAXNDC) + my1 = nint (cy1 * GKI_MAXNDC) + my2 = nint (cy2 * GKI_MAXNDC) + + # Set transformation upon the clipped GKI coordinates. + dx = max (min_width, (x2 - x1)) + dy = max (min_width, (y2 - y1)) + xorigin = (cx1 - x1) / dx * GKI_MAXNDC + yorigin = (cy1 - y1) / dy * GKI_MAXNDC + xscale = 1. / dx + yscale = 1. / dy + + wstranset = YES + } + + # Clear the scratch buffer whenever the workstation viewport is + # changed. + + TR_OPSB(tr) = TR_SCRATCHBUF(tr) +end diff --git a/sys/gio/cursor/gtrrcur.x b/sys/gio/cursor/gtrrcur.x new file mode 100644 index 00000000..495117a3 --- /dev/null +++ b/sys/gio/cursor/gtrrcur.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GTR_READCURSOR -- Read the graphics cursor position in NDC coordinates. +# By the time we are called the plot has already been drawn and the +# workstation closed, hence we must reopen the workstation to read the +# cursor (the graphics terminal will not be in graphics mode otherwise). + +int procedure gtr_readcursor (fd, key, sx, sy, raster, rx, ry) + +int fd #I graphics stream +int key #O keystroke value +real sx, sy #O NDC screen coords of cursor +int raster #O raster number +real rx, ry #O NDC raster coords of cursor + +int cn +int m_sx, m_sy +int m_rx, m_ry + +begin + call gki_getcursor (fd, 0, + cn, key, m_sx, m_sy, raster, m_rx, m_ry) + + sx = real(m_sx) / GKI_MAXNDC + sy = real(m_sy) / GKI_MAXNDC + rx = real(m_rx) / GKI_MAXNDC + ry = real(m_ry) / GKI_MAXNDC + + return (key) +end diff --git a/sys/gio/cursor/gtrredraw.x b/sys/gio/cursor/gtrredraw.x new file mode 100644 index 00000000..ca2191b3 --- /dev/null +++ b/sys/gio/cursor/gtrredraw.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gtr.h" + +# GTR_REDRAW -- Redraw the screen from the metacode spooled in the frame +# buffer. + +procedure gtr_redraw (stream) + +int stream # graphics stream to be redrawn + +pointer tr, ip_save, op_save +pointer gtr_init() +errchk gtr_init + +begin + tr = gtr_init (stream) + + if (TR_SPOOLDATA(tr) == YES && TR_OP(tr) > TR_FRAMEBUF(tr)) { + # Rewind the input pointer into the frame buffer. + TR_IP(tr) = TR_FRAMEBUF(tr) + + # Redraw frame buffer. + call gki_clear (stream) + call giotr (stream) + + # Redraw scratch buffer (axes). Set i/o pointers to the scratch + # buffer and draw its contents. Turn off interrupts to prevent + # an interrupt from leaving the pointers pointing to the wrong + # buffer. + + if (TR_OPSB(tr) > TR_SCRATCHBUF(tr)) { + call intr_disable() + ip_save = TR_IP(tr); TR_IP(tr) = TR_SCRATCHBUF(tr) + op_save = TR_OP(tr); TR_OP(tr) = TR_OPSB(tr) + + call giotr (stream) + + TR_IP(tr) = ip_save + TR_OP(tr) = op_save + call intr_enable() + } + + # Flush graphics output. + call gki_flush (stream) + } +end diff --git a/sys/gio/cursor/gtrreset.x b/sys/gio/cursor/gtrreset.x new file mode 100644 index 00000000..36c55a9a --- /dev/null +++ b/sys/gio/cursor/gtrreset.x @@ -0,0 +1,53 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gtr.h" + +# GTR_RESET -- Reset the graphics system. Disconnect all connected subkernels +# and free all file descriptors and memory. + +procedure gtr_reset (status) + +int status # not used (req. for ONEXIT) + +pointer tr +int stream +bool streq() +include "gtr.com" + +begin + do stream = STDGRAPH, STDPLOT { + tr = trdes[stream] + if (tr == NULL) + next + + iferr { + # Close device graphcap descriptor. + if (TR_TTY(tr) != NULL) + call ttycdes (TR_TTY(tr)) + + # Disconnect old kernel. + if (streq (TR_KERNFNAME(tr), "cl")) + call stg_close() + else if (TR_DEVNAME(tr) != EOS && TR_KERNFNAME(tr) != EOS) { + call gtr_disconnect (TR_PID(tr), + TR_IN(tr), TR_OUT(tr), stream) + TR_PID(tr) = NULL + TR_IN(tr) = NULL + TR_OUT(tr) = NULL + } + } then { + TR_DEVNAME(tr) = EOS + call erract (EA_WARN) + } else + TR_DEVNAME(tr) = EOS + + # Free all storage. + call mfree (TR_FRAMEBUF(tr), TY_SHORT) + call mfree (TR_SCRATCHBUF(tr), TY_SHORT) + call mfree (tr, TY_STRUCT) + + trdes[stream] = NULL + } +end diff --git a/sys/gio/cursor/gtrset.x b/sys/gio/cursor/gtrset.x new file mode 100644 index 00000000..629ef097 --- /dev/null +++ b/sys/gio/cursor/gtrset.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gtr.h" + +# GTRSET -- Set the workstation transformation. The workstation transformation +# is automatically zeroed whenever the screen is cleared or when a workstation +# is opened. + +procedure gtrset (fd, x1, x2, y1, y2) + +int fd # graphics stream to be set +real x1, x2 # range of workstation viewport in X +real y1, y2 # range of workstation viewport in Y +include "gtr.com" + +begin + mx1 = x1 * GKI_MAXNDC + mx2 = x2 * GKI_MAXNDC + my1 = y1 * GKI_MAXNDC + my2 = y2 * GKI_MAXNDC + + xscale = GKI_MAXNDC / (mx2 - mx1) + yscale = GKI_MAXNDC / (my2 - my1) + + wstranset = YES +end diff --git a/sys/gio/cursor/gtrstatus.x b/sys/gio/cursor/gtrstatus.x new file mode 100644 index 00000000..45b5731c --- /dev/null +++ b/sys/gio/cursor/gtrstatus.x @@ -0,0 +1,100 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gtr.h" + +define LEN_NAME 10 + + +# GTR_STATUS -- Print information summarizing the utilization of resources +# by each of the three graphics streams. + +procedure gtr_status (fd) + +int fd # output file +int stream, ip +string names "STDGRAPH:,STDIMAGE:,STDPLOT: " +include "gtr.com" + +begin + for (ip=1; names[ip] != EOS; ip=ip+1) + if (names[ip] == ',') + names[ip] = EOS + + do stream = STDGRAPH, STDPLOT { + ip = (stream - STDGRAPH) * LEN_NAME + 1 + if (trdes[stream] == NULL) { + call fprintf (fd, "\t%s disconnected\n") + call pargstr (names[ip]) + } else + call gtr_memusage (fd, stream, names[ip]) + } + + call fprintf (fd, "\n") + call flush (fd) +end + + +# GTR_MEMUSAGE -- Print information summarizing the utilization of memory and +# other resources by a graphics stream. + +procedure gtr_memusage (fd, stream, name) + +int fd # output file +int stream # graphics stream to be described +char name[ARB] # name of graphics stream + +pointer tr, tx +int bufsize +int fstati() +pointer gtr_init() +errchk gtr_init + +begin + tr = gtr_init (stream) + + call fprintf (fd, "\t%s kernel=%s, device=%s, page %s\n") + call pargstr (name) + call pargstr (TR_KERNFNAME(tr)) + call pargstr (TR_DEVNAME(tr)) + if (TR_PAGE(tr) == YES) + call pargstr ("enabled") + else + call pargstr ("disabled") + + bufsize = fstati (stream, F_BUFSIZE) + call fprintf (fd, + "\t\tmemory=%d (%dfb+%dsb+%dfio), frame=%d+%d words\n") + call pargi (TR_LENFRAMEBUF(tr) + TR_LENSCRATCHBUF(tr) + bufsize) + call pargi (TR_LENFRAMEBUF(tr)) + call pargi (TR_LENSCRATCHBUF(tr)) + call pargi (bufsize) + call pargi (TR_OP(tr) - TR_FRAMEBUF(tr)) + call pargi (TR_OPSB(tr) - TR_SCRATCHBUF(tr)) + + call fprintf (fd, + "\t\tspool=%s, nopen=%d, pid=%d, in=%d, out=%d, redir=%d, wcs=%d\n") + if (TR_SPOOLDATA(tr) == YES) + call pargstr ("yes") + else + call pargstr ("no") + call pargi (TR_NOPEN(tr)) + call pargi (TR_PID(tr)) + call pargi (TR_IN(tr)) + call pargi (TR_OUT(tr)) + call pargi (TR_REDIR(tr)) + call pargi (TR_WCS(tr)) + + tx = TR_TXAP(tr) + call fprintf (fd, + "\t\ttext size=%g, up=%d, path=%s, hj=%s, vj=%s, color=%d\n") + call pargr (TX_SIZE(tx)) + call pargi (TX_UP(tx)) + call gkp_txparg (TX_PATH(tx)) + call gkp_txparg (TX_HJUSTIFY(tx)) + call gkp_txparg (TX_VJUSTIFY(tx)) + call pargi (TX_COLOR(tx)) + + call fprintf (fd, "\n") +end diff --git a/sys/gio/cursor/gtrtrunc.x b/sys/gio/cursor/gtrtrunc.x new file mode 100644 index 00000000..6abda3ba --- /dev/null +++ b/sys/gio/cursor/gtrtrunc.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gtr.h" + +# GTR_TRUNCATE -- Truncate the frame buffer, which has grown larger than +# the limit set by the user (or the system default). This is done by moving +# the metacode data at the end of the buffer (beginning with the word pointed +# to by gki) to the maximum upper limit of the buffer and adjusting the input +# and output pointers accordingly. + +procedure gtr_truncate (tr, gki) + +pointer tr # giotr descriptor +pointer gki # pointer to first word to be preserved +pointer top +int nwords + +begin + # Find the first instruction preceding the soft upper limit on the + # size of the buffer. + + top = TR_FRAMEBUF(tr) + TR_MAXLENFRAMEBUF(tr) + while (Mems[top] != BOI && top > TR_FRAMEBUF(tr)) + top = top - 1 + + # Move the partial instruction likely to be at the end of the buffer + # to the new "top". Note that we can only truncate (discard) + # instructions which have already been executed, hence the partial + # instruction at the end of the buffer must be preserved. + + if (gki != top) { + nwords = TR_OP(tr) - gki + call amovs (Mems[gki], Mems[top], nwords) + TR_IP(tr) = top + TR_OP(tr) = top + nwords + } +end diff --git a/sys/gio/cursor/gtrundo.x b/sys/gio/cursor/gtrundo.x new file mode 100644 index 00000000..5b8d3e02 --- /dev/null +++ b/sys/gio/cursor/gtrundo.x @@ -0,0 +1,76 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "gtr.h" + +# GTR_UNDO -- Undo the last frame buffer edit. Successive pairs of undos leave +# the frame buffer unchanged. + +procedure gtr_undo (stream) + +int stream # graphics stream +int opcode +pointer tr, op, new_op, old_op, sp, ap + +pointer gtr_init() +errchk gtr_init +include "gtr.com" + +begin + call smark (sp) + call salloc (ap, LEN_PL, TY_STRUCT) + + tr = gtr_init (stream) + + old_op = TR_OP(tr) + new_op = TR_LASTOP(tr) + if (new_op == old_op || new_op <= TR_FRAMEBUF(tr)) { + call sfree (sp) + return + } + + # Edit the frame buffer. + TR_LASTOP(tr) = old_op + TR_OP(tr) = new_op + TR_IP(tr) = min (new_op, TR_IP(tr)) + + # Redraw the last drawing instruction to erase it (device permitting), + # if we are backing up one instruction. Note that it may be necessary + # to skip one or more control instructions. We assume that the undo + # only has to undo one drawing instruction. + + if (new_op < old_op) { + op = new_op + repeat { + opcode = Mems[op+GKI_HDR_OPCODE-1] + if (opcode == GKI_POLYLINE) + break + else + op = op + Mems[op+GKI_HDR_LENGTH-1] + } until (op >= old_op) + + if (opcode == GKI_POLYLINE && op < old_op) { + PL_LTYPE(ap) = GL_CLEAR + PL_WIDTH(ap) = 1.0 + PL_COLOR(ap) = 1 + call gki_plset (stream, ap) + + if (wstranset == YES) + call gtr_wstran (Mems[op]) + else + call gki_write (stream, Mems[op]) + + PL_LTYPE(ap) = GL_SOLID + call gki_plset (stream, ap) + } + + } else if (new_op > old_op) { + # Call giotr to redraw the recovered instructions. + call giotr (stream) + } + + call gki_flush (stream) + call sfree (sp) +end diff --git a/sys/gio/cursor/gtrwaitp.x b/sys/gio/cursor/gtrwaitp.x new file mode 100644 index 00000000..67f46dd8 --- /dev/null +++ b/sys/gio/cursor/gtrwaitp.x @@ -0,0 +1,94 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "gtr.h" +include "grc.h" + +# GTR_WAITPAGE -- Print the "hit return to continue" message on the terminal +# screen and wait for the user to respond before returning to graphics mode. +# Redrawing of the graphics frame is optional. + +procedure gtr_waitpage (fd, stream) + +int fd # output file +int stream # graphics stream + +int key, i +pointer tty, tr +int getci(), ttystati() +pointer ttyodes(), gtr_init() +errchk gtr_init, ttyodes + +begin + tr = gtr_init (stream) + tty = ttyodes ("terminal") + + repeat { + # Print prompt in standout mode. + call ttyclearln (fd, tty) + call ttyso (fd, tty, YES) + call fprintf (fd, + "[space=cmhelp,return=quit+redraw,q=quit+noredraw]") + call ttyso (fd, tty, NO) + call flush (fd) + + # Wait for user to hit a key. This is done in text mode via + # a raw getc rather than via a cursor read to avoid switching to + # graphics mode. On some terminals with separate text and + # graphics planes a switch to graphics mode turns off the text + # plane. + + call fseti (STDIN, F_RAW, YES) + if (getci (STDIN, key) == EOF) + key = '\r' + call fseti (STDIN, F_RAW, NO) + + # Take the action commanded by the user. At present the morehelp + # option merely prints cursor mode help; this is appropriate + # because the first waitpage call occurs after printing user help + # in response to ? (or after a :.show). + + switch (key) { + case 'q': + # Quit, do not clear graphics and redraw. + if (TR_PAGE(tr) == NO) { + # If screen paging is disabled (text drawn underneath + # transparent graphics overlay), clear the text frame + # only, using the clear line function. + + do i = 1, ttystati (tty, TTY_NLINES) { + call ttygoto (fd, tty, 1, i) + call ttyclearln (fd, tty) + } + } else + call ttyclearln (fd, tty) + + call flush (fd) + call gki_reactivatews (stream, 0) + break + + case '\r', '\n': + # Quit, clear graphics and redraw. + call ttyclearln (fd, tty) + call flush (fd) + call gki_reactivatews (stream, 0) + call gtr_redraw (stream) + break + + case ' ': + # Print cursor mode help. + iferr (call pagefile (KEYSFILE, "cursor mode help")) + call erract (EA_WARN) + + default: + # Illegal keystroke. + call printf ("\007") + call flush (STDOUT) + } + } + + call ttycdes (tty) +end diff --git a/sys/gio/cursor/gtrwcur.x b/sys/gio/cursor/gtrwcur.x new file mode 100644 index 00000000..9def0a67 --- /dev/null +++ b/sys/gio/cursor/gtrwcur.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GTR_WRITECURSOR -- Write the graphics cursor position in NDC coordinates. + +procedure gtr_writecursor (fd, x, y) + +int fd # graphics stream +real x, y # NDC coords of cursor + +int mx, my + +begin + mx = max(0, min(GKI_MAXNDC, nint (x * GKI_MAXNDC))) + my = max(0, min(GKI_MAXNDC, nint (y * GKI_MAXNDC))) + + call gki_setcursor (fd, mx, my, 0) +end diff --git a/sys/gio/cursor/gtrwritep.x b/sys/gio/cursor/gtrwritep.x new file mode 100644 index 00000000..d1a3fd4a --- /dev/null +++ b/sys/gio/cursor/gtrwritep.x @@ -0,0 +1,68 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "gtr.h" + +# GTR_WRITEP -- Virtually write (append) to the graphics frame buffer. Return a +# pointer to the start of the area reserved for the data and advance the +# output pointer beyond the new data area. The use of a buffer pointer here +# yields a very efficient graphics i/o dataflow. For the stdgraph kernel, +# XMIT (pr_psio) places a block of metacode directly in the frame buffer at +# the memory location we point to. GIOTR is then called to process the new +# data block. GIOTR calls GTR_FETCH, which "fetches" the next instruction +# by merely returning a pointer into the frame buffer. The stdgraph kernel +# is then called to execute the instruction. Hence in the simple case, there +# are no memory to memory copies and the contents of an instruction are +# touched only by the kernel. + +pointer procedure gtr_writep (fd, nchars) + +int fd # graphics stream +int nchars # nchars to reserve at end of buffer + +pointer tr, bufp, top, segp +int blen, nwords, ip_offset, op_offset +errchk syserr, realloc +include "gtr.com" + +begin + tr = trdes[fd] + if (tr == NULL) + call syserr (SYS_GWRITEP) + + nwords = nchars / SZ_SHORT + bufp = TR_FRAMEBUF(tr) + blen = TR_LENFRAMEBUF(tr) + segp = TR_OP(tr) # pointer to next segment + top = bufp + blen + + # Make space available in the buffer. We must always allocate the + # requested space, even if the result is a buffer larger than the + # (soft) maximum size permitted. Buffer space will be returned + # after GIOTR processes the new instructions if the buffer grows + # too large. + + if (nwords > top - segp) { + # Note that realloc may move the buffer, hence we must adjust any + # pointers into the buffer after the call to realloc. + + ip_offset = TR_IP(tr) - bufp + op_offset = segp - bufp + blen = blen + max (INC_LENFRAMEBUF, nwords) + + call realloc (bufp, blen, TY_SHORT) + + TR_FRAMEBUF(tr) = bufp + TR_LENFRAMEBUF(tr) = blen + TR_IP(tr) = bufp + ip_offset + segp = bufp + op_offset + } + + TR_OP(tr) = segp + nwords + TR_LASTOP(tr) = TR_OP(tr) + + return (segp) +end diff --git a/sys/gio/cursor/gtrwsclip.x b/sys/gio/cursor/gtrwsclip.x new file mode 100644 index 00000000..3a0a384b --- /dev/null +++ b/sys/gio/cursor/gtrwsclip.x @@ -0,0 +1,144 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GTR_POLYCLIP -- Clip a convex polygon to a box. If the polygon is entirely +# outside the box 0 is returned; if the polygon is entirely within the box 1 +# is returned, otherwise the polygon is clipped and a value other than 0 or 1 +# is returned. This is based on code by Paul Heckbert from Graphics Gems, +# 1985/1989. + +int procedure gtr_polyclip (pv, npts, x1, x2, y1, y2) + +short pv[ARB] #U polygon to be clipped +int npts #U number of points in polygon +int x1,x2,y1,y2 #I clipping box + +pointer sp, p1, p2, pt +int x1out, x2out, y1out, y2out, i +int gtr_cliptoplane() +define nopts_ 91 + +begin + x1out = 0; x2out = 0 + y1out = 0; y2out = 0 + + # Count vertices which are outside with respect to each of the + # four planes. + + do i = 1, npts*2, 2 { + if (pv[i+0] < x1) x1out = x1out + 1 + if (pv[i+0] > x2) x2out = x2out + 1 + if (pv[i+1] < y1) y1out = y1out + 1 + if (pv[i+1] > y2) y2out = y2out + 1 + } + + # Is the polygon entirely inside the clipping box? + if (x1out + x2out + y1out + y2out == 0) + return (1) + + # Is the polygon entirely outside the clipping box? + if (x1out == npts || x2out == npts || y1out == npts || y2out == npts) + return (0) + + # If we get here the polygon partially intersects the clipping box. + # Clip against each of the planes that might cut the polygon, clipping + # the previously clipped polygon in each step. This is done in + # floating point to minimize accumulation of error when interpolating + # to the clipping plane to compute a new polygon vertex when the plane + # is crossed. + + call smark (sp) + call salloc (p1, npts * 4, TY_REAL) + p2 = p1 + npts * 2 + + call achtsr (pv, Memr[p1], npts * 2) + + if (x1out > 0) + if (gtr_cliptoplane (p1, p2, npts, 0, -1.0, real(x1)) == 0) + goto nopts_ + else { + pt = p1; p1 = p2; p2 = pt + } + if (x2out > 0) + if (gtr_cliptoplane (p1, p2, npts, 0, 1.0, real(x2)) == 0) + goto nopts_ + else { + pt = p1; p1 = p2; p2 = pt + } + if (y1out > 0) + if (gtr_cliptoplane (p1, p2, npts, 1, -1.0, real(y1)) == 0) + goto nopts_ + else { + pt = p1; p1 = p2; p2 = pt + } + if (y2out > 0) + if (gtr_cliptoplane (p1, p2, npts, 1, 1.0, real(y2)) == 0) + goto nopts_ + else { + pt = p1; p1 = p2; p2 = pt + } + + call achtrs (Memr[p1], pv, npts * 2) + call sfree (sp) + return (npts) + +nopts_ + call sfree (sp) + return (0) +end + + +# GTR_CLIPTOPLANE -- Clip the convex polygon P1 against a plane, copying +# the inbounds portion to the output polygon P2. + +int procedure gtr_cliptoplane (p1, p2, npts, index, s, ref) + +pointer p1 #I pointer to input polygon +pointer p2 #I pointer to output polygon +int npts #U number of polygon points or vertices +int index #I index of coordinate to be tested +real s #I sign for comparison +real ref #I value to compare against + +int nout, i +pointer op, u, v +real tu, tv, t + +begin + nout = 0 + op = p2 + + u = p1 + (npts - 1) * 2 + tu = s * Memr[u+index] - ref + v = p1 + + do i = 1, npts { + # On old polygon P1, U is previous vertex, V is current vertex, + # TV is negative if vertex V is in. + + tv = s * Memr[v+index] - ref + + if (! ((tu <= 0 && tv <= 0) || (tu > 0 && tv > 0))) { + # Edge crosses plane; add intersection point to P2. + t = tu / (tu - tv) + Memr[op+0] = Memr[u+0] + t * (Memr[v+0] - Memr[u+0]) + Memr[op+1] = Memr[u+1] + t * (Memr[v+1] - Memr[u+1]) + nout = nout + 1 + op = op + 2 + } + + if (tv <= 0) { + # Vertex V is in, copy it out. + Memr[op+0] = Memr[v+0] + Memr[op+1] = Memr[v+1] + nout = nout + 1 + op = op + 2 + } + + u = v + tu = tv + v = v + 2 + } + + npts = nout + return (nout) +end diff --git a/sys/gio/cursor/gtrwstran.x b/sys/gio/cursor/gtrwstran.x new file mode 100644 index 00000000..9262e00a --- /dev/null +++ b/sys/gio/cursor/gtrwstran.x @@ -0,0 +1,490 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "gtr.h" + +define MOVE 0 +define DRAW 1 +define LEFT 0 +define RIGHT 1 +define BELOW 0 +define ABOVE 1 +define INSIDE 2 +define FIRSTPT GKI_POLYLINE_P + + +# GTR_WSTRAN -- Apply the workstation transformation to an instruction and +# write the transformed instruction to the graphics kernel. The transformation +# parameters etc. should have been initialized in the gtr common before we +# are called. + +procedure gtr_wstran (gki) + +short gki[ARB] #I metacode instruction to be spooled + +long x, y +pointer sp, buf +int length, npts, data +int gtr_polyclip() +bool sge_wsenable() +include "gtr.com" + +begin + # Check with the graphics kernel to see if scaling of graphics + # instructions is enabled (it is disabled if the graphics device is + # already doing it for us). + + if (!sge_wsenable()) { + call gki_write (tr_stream, gki) + return + } + + switch (gki[GKI_HDR_OPCODE]) { + case GKI_FILLAREA: + npts = gki[GKI_FILLAREA_N] + data = GKI_FILLAREA_P + length = gki[GKI_HDR_LENGTH] + call amovs (gki, pl, length) + + switch (gtr_polyclip (pl[data], npts, mx1, mx2, my1, my2)) { + case 0: + # Entire instruction out of bounds. + case 1: + # Entire instruction in bounds. + pl_op = GKI_POLYLINE_P + npts * 2 + call gpt_flush() + default: + # Instruction has been clipped. + pl_op = GKI_POLYLINE_P + npts * 2 + call gpt_flush() + } + + case GKI_POLYLINE, GKI_POLYMARKER: + call gtr_polytran (gki) + + case GKI_SETCURSOR: + length = gki[GKI_HDR_LENGTH] + call smark (sp) + call salloc (buf, length, TY_SHORT) + + # Move cursor to edge of screen if point referenced is out of + # bounds. + + call amovs (gki, Mems[buf], length) + x = gki[GKI_SETCURSOR_POS] + y = gki[GKI_SETCURSOR_POS+1] + call gtr_ctran (x, y, x, y) + Mems[buf+GKI_SETCURSOR_POS-1] = x + Mems[buf+GKI_SETCURSOR_POS] = y + call gki_write (tr_stream, Mems[buf]) + + call sfree (sp) + + case GKI_TEXT: + length = gki[GKI_HDR_LENGTH] + call smark (sp) + call salloc (buf, length, TY_SHORT) + + # Discard text drawing instruction if the point referenced is + # out of bounds. If in bounds, transform coordinates and draw + # at the transformed point. + + call amovs (gki, Mems[buf], length) + x = gki[GKI_TEXT_P] + y = gki[GKI_TEXT_P+1] + if (x >= mx1 && x <= mx2 && y >= my1 && y <= my2) { + call gtr_ctran (x, y, x, y) + Mems[buf+GKI_TEXT_P-1] = x + Mems[buf+GKI_TEXT_P] = y + call gki_write (tr_stream, Mems[buf]) + } + + call sfree (sp) + + case GKI_PUTCELLARRAY: + # Just filter these out for now. + + default: + call gki_write (tr_stream, gki) + } +end + + +# GTR_CTRAN -- Apply the workstation transform to a set of GKI coordinates, +# i.e., transform raw GKI coords to screen coords in GKI units. + +procedure gtr_ctran (mx, my, sx, sy) + +int mx, my # raw GKI coordinates +int sx, sy # screen coordinates in GKI units +include "gtr.com" + +begin + sx = max(0, min(GKI_MAXNDC, nint ((mx - mx1) * xscale + xorigin))) + sy = max(0, min(GKI_MAXNDC, nint ((my - my1) * yscale + yorigin))) +end + + +# GTR_POLYTRAN -- Scale a polyline, polymarker, or fill area instruction +# by applying the workstation transformation. The workstation transformation +# scales vectors in a viewport defined in NDC(GKI) space to fit the full +# device screen. Vectors or segments of vectors lying outside the viewport +# are clipped at the screen boundary. + +procedure gtr_polytran (gki) + +short gki[ARB] # gki instruction to be transformed +long mx, my +int last_ip, opcode, i, ip +bool inbounds, otherside, points +int gpt_firstpt() +include "gtr.com" + +begin + last_ip = gki[GKI_HDR_LENGTH] + opcode = gki[GKI_HDR_OPCODE] + points = (opcode == GKI_POLYMARKER) + + # In the process of clipping a polyline may be broken into several + # smaller polylines (or polymarkers or fillareas, all of which are + # very similar at the instruction level). We store the GKI header + # in the first few words of the PL array so that when the transformed + # polyline is broken it is ready for execution. + + do i = 1, GKI_POLYLINE_P - 1 + pl[i] = gki[i] + pl_op = GKI_POLYLINE_P + + # Clip all points until either a point is encountered which is inbounds + # or which is on the other side of the viewport (in either axis). This + # is a fast way of clipping polylines which are mostly out of bounds. + # Return immediately if the entire vector is out of bounds. + + otherside = true + ip = FIRSTPT + if (gpt_firstpt (gki, ip, last_ip) <= 0) + return + + # Set initial position. + cx = gki[ip] + cy = gki[ip+1] + + # Clip the remaining points. Clipping is performed in GKI coordinates. + # The workstation transformation is not applied until the clipped + # vector is output. + + for (ip=ip+2; ip < last_ip; ip=ip+2) { + mx = gki[ip] + my = gki[ip+1] + + # Check to see if this is the first point of a new polyline. + # If so we must set the first physical point in the output + # polyline to the current position, making the current point + # the second physical point of the output polyline. + + if (pl_op <= GKI_POLYLINE_P) { + # Place the current pen position in the polyline as the + # first point if it is inbounds. + + if (cy <= my2 && cy >= my1 && cx <= mx2 && cx >= mx1) { + last_point_inbounds = true + pl[pl_op] = cx + pl_op = pl_op + 1 + pl[pl_op] = cy + pl_op = pl_op + 1 + } else { + last_point_inbounds = false + do i = 1, 4 { + xs[i] = cx + ys[i] = cy + } + } + } + + # Update the current position. + + cx = mx + cy = my + + # Clip at the edge of the device screen. + + inbounds = (my <= my2 && my >= my1 && mx <= mx2 && mx >= mx1) + + if (inbounds && (last_point_inbounds || points)) { + # Add point to polyline (the fast way). + pl[pl_op] = mx + pl_op = pl_op + 1 + pl[pl_op] = my + pl_op = pl_op + 1 + + } else if ((inbounds||last_point_inbounds||otherside) && !points) { + # Clip at viewport boundary. + + if (last_point_inbounds) { + # Update coords of last point drawn (necessary since we did + # not use the clipping code for inbounds points). + do i = 1, 4 { + xs[i] = pl[pl_op-2] + ys[i] = pl[pl_op-1] + } + } + call gpt_clipl (DRAW, mx, my) + otherside = false + + } else { + # Both points are out of bounds. Scan along until a point is + # found which is again in bounds, or which is on the other side + # of the viewport, requiring clipping across the viewport. + + if (gpt_firstpt (gki, ip, last_ip) > 0) { + do i = 1, 4 { + xs[i] = gki[ip] + ys[i] = gki[ip+1] + } + cx = gki[ip] + cy = gki[ip+1] + } + + otherside = true + inbounds = false + } + + last_point_inbounds = inbounds + } + + call gpt_flush() +end + + +# GPT_FIRSTPT -- Scan a vector and return the index of the next good point. +# A good point is a point which is either inbounds or which preceeds a point +# which is either inbounds or on the other side of the viewport, necessitating +# clipping across the viewport. + +int procedure gpt_firstpt (gki, ip, last_ip) + +short gki[ARB] # vector being clipped +int last_ip # last legal value of ip +int ip # starting index + +int mx, my, i +int first_ip, new_ip +include "gtr.com" + +begin + mx = gki[ip] + my = gki[ip+1] + first_ip = ip + new_ip = last_ip + + if (mx < mx1) { + do i=ip+2, last_ip, 2 + if (gki[i] >= mx1) { + new_ip = i + break + } + } else if (mx > mx2) { + do i=ip+2, last_ip, 2 + if (gki[i] <= mx2) { + new_ip = i + break + } + } else if (my < my1) { + do i=ip+3, last_ip, 2 + if (gki[i] >= my1) { + new_ip = i - 1 + break + } + } else if (my > my2) { + do i=ip+3, last_ip, 2 + if (gki[i] <= my2) { + new_ip = i - 1 + break + } + } else + return (ip) + + if (new_ip >= last_ip) + return (0) # entire vector is indefinite + else + ip = max (first_ip, new_ip - 2) + + return (ip) +end + + +# GPT_CLIPL -- Clip at left boundary. + +procedure gpt_clipl (pen, mx, my) + +int pen # move or draw +long mx, my # point to be clipped +long new_my +int newpen +include "gtr.com" + +begin + # Does line cross boundary? + if ((mx >= mx1 && xs[1] < mx1) || (mx <= mx1 && xs[1] > mx1)) { + if (mx >= mx1) + newpen = MOVE + else + newpen = pen + new_my = real(my - ys[1]) * real(mx1 - mx) / real(mx - xs[1]) + + my + 0.5 + call gpt_clipr (newpen, mx1, new_my) + } + + xs[1] = mx + ys[1] = my + + if (mx >= mx1) + call gpt_clipr (pen, mx, my) +end + + +# GPT_CLIPR -- Clip at right boundary. + +procedure gpt_clipr (pen, mx, my) + +int pen # move or draw +long mx, my # point to be clipped +long new_my +int newpen +include "gtr.com" + +begin + # Does line cross boundary? + if ((mx <= mx2 && xs[2] > mx2) || (mx >= mx2 && xs[2] < mx2)) { + if (mx <= mx2) + newpen = MOVE + else + newpen = pen + new_my = real(my - ys[2]) * real(mx2 - mx) / real(mx - xs[2]) + + my + 0.5 + call gpt_clipb (newpen, mx2, new_my) + } + + xs[2] = mx + ys[2] = my + + if (mx <= mx2) + call gpt_clipb (pen, mx, my) +end + + +# GPT_CLIPB -- Clip at bottom boundary. + +procedure gpt_clipb (pen, mx, my) + +int pen # move or draw +long mx, my # point to be clipped +long new_mx +int newpen +include "gtr.com" + +begin + # Does line cross boundary? + if ((my >= my1 && ys[3] < my1) || (my <= my1 && ys[3] > my1)) { + if (my >= my1) + newpen = MOVE + else + newpen = pen + new_mx = real(mx - xs[3]) * real(my1 - my) / real(my - ys[3]) + + mx + 0.5 + call gpt_clipt (newpen, new_mx, my1) + } + + xs[3] = mx + ys[3] = my + + if (my >= my1) + call gpt_clipt (pen, mx, my) +end + + +# GPT_CLIPT -- Clip at top boundary and put the final clipped point(s) in +# the output polyline. Note that a "move" at this level does not affect +# the current position (cx,cy), since the vector endpoints have been clipped +# and the current position vector follows the unclipped vector points input +# by the user. + +procedure gpt_clipt (pen, mx, my) + +int pen # move or draw +long mx, my # point to be clipped +include "gtr.com" + +begin + # Does line cross boundary? + if ((my <= my2 && ys[4] > my2) || (my >= my2 && ys[4] < my2)) { + if (my <= my2 || pen == MOVE) + call gpt_flush() + pl[pl_op] = real(mx - xs[4]) * real(my2 - my) / real(my - ys[4]) + + mx + 0.5 + pl_op = pl_op + 1 + pl[pl_op] = my2 + pl_op = pl_op + 1 + } + + xs[4] = mx + ys[4] = my + + if (my <= my2) { + if (pen == MOVE) + call gpt_flush() + pl[pl_op] = mx + pl_op = pl_op + 1 + pl[pl_op] = my + pl_op = pl_op + 1 + } +end + + +# GPT_FLUSH -- Flush the buffered "polyline", i.e., array of transformed and +# clipped points. For a polyline or fill area polygon there must be at least +# two points (4 cells) or it will be discarded. A single point polymarker is +# permitted. + +procedure gpt_flush() + +int npts, i +long mx, my +include "gtr.com" + +begin + if (pl_op >= GKI_POLYLINE_P + 2) { + npts = (pl_op - GKI_POLYLINE_P) / 2 + + # Apply the workstation transformation. + do i = GKI_POLYLINE_P, pl_op, 2 { + mx = nint ((pl[i] - mx1) * xscale + xorigin) + my = nint ((pl[i+1] - my1) * yscale + yorigin) + pl[i] = max(0, min(GKI_MAXNDC, mx)) + pl[i+1] = max(0, min(GKI_MAXNDC, my)) + } + + switch (pl[GKI_HDR_OPCODE]) { + case GKI_POLYMARKER: + pl[GKI_POLYMARKER_L] = pl_op - 1 + pl[GKI_POLYMARKER_N] = npts + call gki_write (tr_stream, pl) + + case GKI_FILLAREA: + pl[GKI_FILLAREA_L] = pl_op - 1 + pl[GKI_FILLAREA_N] = npts + call gki_write (tr_stream, pl) + + default: + if (npts >= 2) { + pl[GKI_POLYLINE_L] = pl_op - 1 + pl[GKI_POLYLINE_N] = npts + call gki_write (tr_stream, pl) + } + } + + pl_op = GKI_POLYLINE_P + } +end diff --git a/sys/gio/cursor/mkpkg b/sys/gio/cursor/mkpkg new file mode 100644 index 00000000..f6a79332 --- /dev/null +++ b/sys/gio/cursor/mkpkg @@ -0,0 +1,57 @@ +# Make the CURSOR package. + +$checkout libcur.a lib$ +$update libcur.a +$checkin libcur.a lib$ +$exit + +libcur.a: + # $set xflags = "$(xflags) -qfx" + + giotr.x gtr.com gtr.h + grcaxes.x grc.h gtr.com gtr.h + grcclose.x grc.h gtr.h + grccmd.x grc.h gtr.h \ + + grcinit.x grc.h + grcopen.x grc.h gtr.com gtr.h + grcpl.x gtr.h grc.h + grcread.x gtr.h + grcredraw.x grc.h + grcscr.x gtr.com gtr.h + grcstatus.x grc.h gtr.com gtr.h + grctext.x gtr.h grc.h + grcwarn.x + grcwcs.x grc.h gtr.h + grcwrite.x grc.h gtr.h + gtrbackup.x gtr.com gtr.h + gtrconn.x + gtrctrl.x gtr.com gtr.h \ + + gtrdelete.x gtr.h + gtrdiscon.x + gtrfetch.x gtr.h + gtrframe.x gtr.h + gtrgflush.x gtr.com gtr.h + gtrgtran.x gtr.com gtr.h + gtrgtty.x gtr.h + gtrinit.x gtr.com gtr.h + gtropenws.x gtr.com gtr.h \ + + gtrpage.x gtr.h + gtrptran.x gtr.com gtr.h + gtrrcur.x + gtrredraw.x gtr.h + gtrreset.x gtr.com gtr.h + gtrset.x gtr.com gtr.h + gtrstatus.x gtr.com gtr.h + gtrtrunc.x gtr.h + gtrundo.x gtr.com gtr.h + gtrwaitp.x grc.h gtr.h + gtrwcur.x + gtrwritep.x gtr.com gtr.h + gtrwstran.x gtr.com gtr.h + gtrwsclip.x + prpsinit.x + rcursor.x grc.h gtr.com gtr.h + ; diff --git a/sys/gio/cursor/prpsinit.x b/sys/gio/cursor/prpsinit.x new file mode 100644 index 00000000..4959deff --- /dev/null +++ b/sys/gio/cursor/prpsinit.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# PRPSINIT -- Load the gio.cursor graphics driver for pseudofile i/o to the +# graphics streams. + +procedure prpsinit() + +extern giotr() +extern gtr_control(), gtr_gflush(), gtr_writep() +extern stg_readtty(), stg_writetty() + +begin + call prpsload (giotr, gtr_control, gtr_gflush, gtr_writep, + stg_readtty, stg_writetty) +end diff --git a/sys/gio/cursor/rcursor.x b/sys/gio/cursor/rcursor.x new file mode 100644 index 00000000..cc7dc739 --- /dev/null +++ b/sys/gio/cursor/rcursor.x @@ -0,0 +1,692 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "gtr.h" +include "grc.h" + +define SZ_CHARCON 5 +define MARKLEN 0.01 + +# Cursor step algorithm parameters. + +define MAX_STEP 0.1 # max cursor step size, cursor motions +define MIN_STEP 0.002 # min cursor step size, cursor motions +define LARGER_STEP 2.0 # factor by which step size is increased +define SMALLER_STEP 0.5 # factor by step size is decreased +define NSTEP 2 # number of steps before larger step +define MANUAL_STEP 5.0 # gear ratio for F/V cursor control +define SLOW 1 # for fast/slow algorithm +define FAST 2 + +# Zoom parameters. + +define X_ZOOMFACTOR 0.5 # zoom factors +define Y_ZOOMFACTOR 0.5 +#define X_ZOOMFACTOR 0.666 # zoom factors +#define Y_ZOOMFACTOR 0.666 + +# Roam factors. + +define X_ROAM 0.333 # fraction of the current window +define Y_ROAM 0.333 # fraction of the current window + + +# RCURSOR -- Read the position of a cursor. This is the main entry point to +# cursor mode/cursor input from the CL; we are called by the QUERY procedure +# of the CL when a cursor type parameter is read. The cursor position is +# returned as a string of the form +# +# x y wcs key stringval +# +# where the "stringval" field may be absent if not appropriate for a given key. +# If EOF is returned the cursor value string is undefined. + +int procedure rcursor (stream, outstr, maxch) + +int stream # graphics stream +char outstr[ARB] # encoded cursor value (output) +int maxch + +bool cminit +int xroam[9], yroam[9] +pointer rc, tr, sp, lbuf, ip +char charcon[SZ_CHARCON], ch +real x1, x2, y1, y2, xt, yt, v[10] +real lx1, lx2, ly1, ly2, aspect_ratio +real x, y, rx, ry, xw, yw, dx, dy, xc, yc +int junk, key, nukey, last_zoom, i, wcs, ppos, ucasein, raster + +bool ttygetb() +pointer grc_open() +int envfind(), ctocc(), oscmd(), gtr_readcursor(), grc_readtty() +int grc_cursor(), grc_command(), grc_selectwcs(), grc_mapkey(), ttstati() +real ttygetr() + +errchk grc_text, grc_readtty, grc_writecursor +errchk grc_init, grc_open, grc_command, grc_cursor, grc_message +errchk grc_readcursor, grc_mapkey, grc_redraw, envfind + +data xroam /1,0,-1,1,0,-1,1,0,-1/ +data yroam /1,1,1,0,0,0,-1,-1,-1/ +data rc /NULL/ +define done_ 91 +define coloncmd_ 92 + +begin + call smark (sp) + call salloc (lbuf, SZ_COMMAND, TY_CHAR) + + # Allocate and initialize the RCURSOR descriptor. + if (rc == NULL) { + call grc_init (rc) + cminit = true + } else + cminit = false + + # Open or reopen the graphics kernel. + tr = grc_open ("", APPEND, stream, rc) + + # Process CMINIT command string, if present in environment. This is + # only done once. + + if (cminit) { + if (envfind ("cminit", Memc[lbuf], SZ_COMMAND) > 0) { + ip = lbuf + while (IS_WHITE(Memc[ip]) || Memc[ip] == '.') + ip = ip + 1 + junk = grc_command (rc, stream, 0.,0.,0,0.,0., Memc[ip]) + } + cminit = false + } + + # If the graphics device does not permit input, i.e., does not have + # a cursor, return EOF. + + if (!ttygetb (TR_TTY(tr), "in")) { + x = 0; y = 0 + key = EOF + goto done_ + } + + # Determine if input keys are to be mapped to lower case by default, + # i.e., ucasein mode has been set for the terminal driver. + + ucasein = ttstati (STDIN, TT_UCASEIN) + + last_zoom = 3 + ppos = NO + + # Enter cursor mode loop. The loop terminates when a non cursor mode + # keystroke is typed. + + while (grc_cursor (rc, stream, key,x,y, raster,rx,ry, ppos) != EOF) { + Memc[lbuf] = EOS + + # As a rule, no processing is performed on escaped keys. The only + # exception is when ucasein mode is set in the terminal driver, + # causing upper case input to be mapped to lower case. This mapping + # is disabled in a raw mode cursor read, hence we must perform the + # mapping explicitly here, returning a lower case key to the + # applications program. Unescaped upper case input keystrokes will + # be intercepted by cursor mode when ucasein mode is in effect. + + if (key == '\\') { + junk = gtr_readcursor (stream, key, x, y, raster, rx, ry) + if (ucasein == YES && IS_UPPER(key)) + key = TO_LOWER (key) + break + } + + # Map keystroke. If the keystroke maps to a null value the key + # is not recognized as a cursor mode keystroke and we exit. + + if (grc_mapkey (rc, key, nukey) == NULL) + break + + switch (nukey) { + case 'M': + # Move the feature under the cursor to the center of the + # screen without changing the scaling. + + call grc_scrtondc (x, y, xc, yc) + call gtr_gtran (stream, x1, x2, y1, y2) + xw = (x2 - x1) / 2. + yw = (y2 - y1) / 2. + call gtr_ptran (stream, xc-xw, xc+xw, yc-yw, yc+yw) + call grc_redraw (rc, stream, x, y, raster, rx, ry) + call grc_restorecurpos (stream, xc, yc) + + case 'Z': + # Zoom in in both X and Y. + call grc_scrtondc (x, y, xc, yc) + call gtr_gtran (stream, x1, x2, y1, y2) + xw = (x2 - x1) * X_ZOOMFACTOR / 2. + yw = (y2 - y1) * Y_ZOOMFACTOR / 2. + call gtr_ptran (stream, xc-xw, xc+xw, yc-yw, yc+yw) + call grc_redraw (rc, stream, x, y, raster, rx, ry) + call grc_restorecurpos (stream, xc, yc) + last_zoom = 3 + + case 'X': + # Zoom in in X. + call grc_scrtondc (x, y, xc, yc) + call gtr_gtran (stream, x1, x2, y1, y2) + xw = (x2 - x1) * X_ZOOMFACTOR / 2. + call gtr_ptran (stream, xc-xw, xc+xw, y1, y2) + call grc_redraw (rc, stream, x, y, raster, rx, ry) + call grc_restorecurpos (stream, xc, yc) + last_zoom = 1 + + case 'Y': + # Zoom in in Y. + call grc_scrtondc (x, y, xc, yc) + call gtr_gtran (stream, x1, x2, y1, y2) + yw = (y2 - y1) * Y_ZOOMFACTOR / 2. + call gtr_ptran (stream, x1, x2, yc-yw, yc+yw) + call grc_redraw (rc, stream, x, y, raster, rx, ry) + call grc_restorecurpos (stream, xc, yc) + last_zoom = 2 + + case '>': + # Zoom in in Y by setting the upper limit of the viewport + # to the cursor Y position. + + call grc_scrtondc (x, y, xc, yc) + call gtr_gtran (stream, lx1, lx2, ly1, ly2) + call gtr_ptran (stream, lx1, lx2, ly1, yc) + call grc_redraw (rc, stream, x, y, raster, rx, ry) + call gtr_writecursor (stream, x, 0.5) + last_zoom = 'E' + + case '<': + # Zoom in in Y by setting the lower limit of the viewport + # to the cursor Y position. + + call grc_scrtondc (x, y, xc, yc) + call gtr_gtran (stream, lx1, lx2, ly1, ly2) + call gtr_ptran (stream, lx1, lx2, yc, ly2) + call grc_redraw (rc, stream, x, y, raster, rx, ry) + call gtr_writecursor (stream, x, 0.5) + last_zoom = 'E' + + case 'E': + # Expand by marking corners of new viewport. If the range is + # small in either X or Y only the other axis will be expanded. + + call gtr_gtran (stream, lx1, lx2, ly1, ly2) + call grc_scrtondc (x, y, x1, y1) + call grc_message (stream, "again:") + junk = grc_cursor (rc, stream, key,x2,y2, raster,rx,ry, ppos) + call grc_scrtondc (x2, y2, x2, y2) + + if (x1 > x2) + { xt = x2; x2 = x1; x1 = xt } + if (y1 > y2) + { yt = y2; y2 = y1; y1 = yt } + + if (abs (x1 - x2) < .01) + call gtr_ptran (stream, lx1, lx2, y1, y2) + else if (abs (y1 - y2) < .01) + call gtr_ptran (stream, x1, x2, ly1, ly2) + else + call gtr_ptran (stream, x1, x2, y1, y2) + + call grc_redraw (rc, stream, x, y, raster, rx, ry) + call gtr_writecursor (stream, 0.5, 0.5) + last_zoom = 'E' + + case 'P': + # Zoom out. + call grc_scrtondc (x, y, xc, yc) + call gtr_gtran (stream, x1, x2, y1, y2) + + if (last_zoom == 'E') { + call gtr_ptran (stream, lx1, lx2, ly1, ly2) + lx1 = x1; lx2 = x2; ly1 = y1; ly2 = y2 + } else { + if (last_zoom == 1 || last_zoom == 3) { + xw = (x2 - x1) / X_ZOOMFACTOR / 2. + x1 = xc - xw + x2 = xc + xw + } + if (last_zoom == 2 || last_zoom == 3) { + yw = (y2 - y1) / Y_ZOOMFACTOR / 2. + y1 = yc - yw + y2 = yc + yw + } + call gtr_ptran (stream, x1, x2, y1, y2) + } + + call grc_redraw (rc, stream, x, y, raster, rx, ry) + call grc_restorecurpos (stream, xc, yc) + + case 'W': + # Select and fix WCS to be used for scr->wcs coordinate + # transformations. + + call grc_scrtondc (x, y, xc, yc) + TR_WCS(tr) = grc_selectwcs (tr, raster, xc, yc) + + case 'C': + # Running tally of cursor position. + #if (ppos == NO) { + # call grc_pcursor (stream, x, y, raster, rx, ry) + # ppos = YES + #} else { + # call grc_message (stream, "\n\n") + # ppos = NO + #} + + call grc_pcursor (stream, x, y, raster, rx, ry) + + case 'D': + # Draw a line by marking the endpoints. + call grc_scrtondc (x, y, v[1], v[2]) + call grc_message (stream, "again:") + junk = grc_cursor (rc, stream, key,x2,y2, raster,rx,ry, ppos) + call grc_scrtondc (x2, y2, v[3], v[4]) + call grc_polyline (stream, v, 2) + + case 'T': + # Draw a text string. + if (grc_readtty (stream, "text: ", Memc[lbuf], SZ_COMMAND) <= 0) + next + call grc_scrtondc (x, y, xc, yc) + call grc_text (stream, xc, yc, Memc[lbuf]) + + case 'A': + # Draw and label the axes of the viewport. + call grc_axes (stream, x, y, raster, rx, ry) + + case 'B': + # Backup one instruction in the frame buffer. + call gtr_backup (stream) + + case 'U': + # Undo the last frame buffer edit. + call gtr_undo (stream) + + case 'R': + # Redraw the screen. + call grc_redraw (rc, stream, x, y, raster, rx, ry) + + case '0': + # Reset and redraw. + call gtr_ptran (stream, 0., 1., 0., 1.) + call gtr_writecursor (stream, .5, .5) + call grc_redraw (rc, stream, x, y, raster, rx, ry) + + case '5': + # Redraw (null roam request). + call grc_redraw (rc, stream, x, y, raster, rx, ry) + + case '1','2','3','4','6','7','8','9': + # Roam. + i = TO_INTEG (key) + if (xroam[i] != 0 || yroam[i] != 0) { + call gtr_gtran (stream, x1, x2, y1, y2) + dx = (x2 - x1) * X_ROAM * xroam[i] + dy = (y2 - y1) * Y_ROAM * yroam[i] + call gtr_ptran (stream, x1+dx, x2+dx, y1+dy, y2+dy) + call grc_redraw (rc, stream, x, y, raster, rx, ry) + } + + case ':': + # Enter a colon command string and terminate cursor mode. + + # Get the string value. + if (grc_readtty (stream, ":", Memc[lbuf], SZ_COMMAND) <= 0) + next + + # All cursor mode commands must begin with a ".". An osescape + # begins with an "!". + + if (Memc[lbuf] == '!') { + call gtr_page (STDERR, stream) + if (oscmd (Memc[lbuf+1], "", "", "") == ERR) + call fprintf (STDERR, "\7") + call gtr_waitpage (STDERR, stream) + + } else if (Memc[lbuf] == '.') { + # Save viewport for 'P'. +coloncmd_ + call gtr_gtran (stream, lx1, lx2, ly1, ly2) + last_zoom = 'E' + + TR_WAITPAGE(tr) = NO + if (grc_command (rc, stream, x, y, raster, rx, ry, + Memc[lbuf+1]) == EOF) { + key = EOF + goto done_ + } + + # The following is a no-op for most colon commands. + if (TR_WAITPAGE(tr) == YES) + call gtr_waitpage (STDERR, stream) + } else + break + + case '=': + # Shorthand for :.snap. The latter must be used once to + # set the plotter device, else the default stdplot device + # will be used. + + call strcpy (".snap", Memc[lbuf], SZ_COMMAND) + goto coloncmd_ + + default: + call fprintf (STDERR, "\007") + } + } + + # Mark the cursor position if markcur enabled. + if (RC_MARKCUR(rc) == YES && key != EOF) { + call grc_scrtondc (x, y, xc, yc) + aspect_ratio = ttygetr (TR_TTY(tr), "ar") + if (aspect_ratio < .001) + aspect_ratio = 1.0 + + v[1] = xc - MARKLEN * aspect_ratio + v[2] = yc + v[3] = xc + MARKLEN * aspect_ratio + v[4] = yc + v[5] = xc + v[6] = yc + v[7] = xc + v[8] = yc - MARKLEN + v[9] = xc + v[10] = yc + MARKLEN + call grc_polyline (stream, v, 5) + } + + # Close the workstation, leave graphics mode, position alpha cursor to + # lower left corner of graphics terminal. + + call grc_close (stream, rc) + + # Encode the cursor value as a string for the CL. +done_ + if (key != EOF) { + if (key == ' ') + call strcpy ("\\40", charcon, SZ_CHARCON) + else { + ch = char (key) + junk = ctocc (ch, charcon, SZ_CHARCON) + } + call grc_scrtowcs (stream, x, y, raster, rx, ry, xc, yc, wcs) + + call sprintf (outstr, maxch, "%g %g %d %s %s\n") + call pargr (xc) + call pargr (yc) + call pargi (wcs) + call pargstr (charcon) + call pargstr (Memc[lbuf]) + } else + outstr[1] = EOS + + call sfree (sp) + return (key) +end + + +# GRC_CURSOR -- Read the position of a cursor in screen coordinates. Recognizes +# the cursor movement keystrokes H, J, K, and L, exiting only when some other +# keystroke is received. The cursor movement algorithm is initialized upon +# entry. Two algorithms are provided for controlling the cursor step size. +# The first algorithm (automatic control) starts with a large initial step +# size. In the vicinity of a feature the cursor will overshoot the feature +# and the user will step back in the opposite direction, causing the step size +# to be decreased, rapidly converging to the desired position. Several steps +# in the same direction cause the large step size to be restored. The second +# algorithm (manual control) uses the F and V keys to directly control the step +# size. + +int procedure grc_cursor (rc, stream, key, x, y, raster, rx, ry, ppos) + +pointer rc #I rcursor descriptor +int stream #I graphics stream +int key #O keystroke typed +real x, y #O cursor screen coordinates +int raster #O raster number +real rx, ry #O cursor raster coordinates +int ppos #I print cursor position flag + +int speed +int xdir, ydir, nukey +real xstep, ystep, newx, newy + +bool ttygetb() +pointer gtr_gtty() +int gtr_readcursor(), grc_mapkey() +errchk gtr_readcursor, gtr_writecursor + +begin + # Reset the cursor step size to the default. + xstep = MAX_STEP + ystep = MAX_STEP + xdir = 0 + ydir = 0 + speed = 0 + + while (gtr_readcursor (stream, key, x, y, raster, rx, ry) != EOF) { + if (grc_mapkey (rc, key, nukey) == NULL) + break + + newx = x + newy = y + + switch (nukey) { + case 'F': + # Faster. + xstep = min (MAX_STEP, xstep * MANUAL_STEP) + ystep = min (MAX_STEP, ystep * MANUAL_STEP) + speed = FAST + + case 'V': + # Slower. + xstep = max (MIN_STEP, xstep / MANUAL_STEP) + ystep = max (MIN_STEP, ystep / MANUAL_STEP) + speed = SLOW + + case 'H': + # Step cursor left. + if (speed == 0) + if (xdir < -NSTEP) { + xstep = MAX_STEP + xdir = -1 + } else if (xdir > 0) { + xstep = max (MIN_STEP, xstep * SMALLER_STEP) + xdir = -1 + } else + xdir = xdir - 1 + newx = newx - xstep + call gtr_writecursor (stream, newx, newy) + + case 'J': + # Step cursor down. + if (speed == 0) + if (ydir < -NSTEP) { + ystep = MAX_STEP + ydir = -1 + } else if (ydir > 0) { + ystep = max (MIN_STEP, ystep * SMALLER_STEP) + ydir = -1 + } else + ydir = ydir - 1 + newy = newy - ystep + call gtr_writecursor (stream, newx, newy) + + case 'K': + # Step cursor up. + if (speed == 0) + if (ydir > NSTEP) { + ystep = MAX_STEP + ydir = 1 + } else if (ydir < 0) { + ystep = max (MIN_STEP, ystep * SMALLER_STEP) + ydir = 1 + } else + ydir = ydir + 1 + newy = newy + ystep + call gtr_writecursor (stream, newx, newy) + + case 'L': + # Step cursor right. + if (speed == 0) + if (xdir > NSTEP) { + xstep = MAX_STEP + xdir = 1 + } else if (xdir < 0) { + xstep = max (MIN_STEP, xstep * SMALLER_STEP) + xdir = 1 + } else + xdir = xdir + 1 + newx = newx + xstep + call gtr_writecursor (stream, newx, newy) + + default: + break + } + + # We assume the cursor may have moved if the WC capability exists + # for this device. + + if (ttygetb (gtr_gtty (stream), "WC")) { + x = newx + y = newy + } + + # Print the cursor position. + if (ppos == YES) + call grc_pcursor (stream, x, y, raster, rx, ry) + } + + return (key) +end + + +# GRC_MAPKEY -- Map keystroke. If the keystroke maps to a null value the key +# is not recognized as a cursor mode keystroke and we exit. Note that if case +# sensitivity is disabled, KEYS comparisions must be made in upper case but +# only lower case is to be returned to the calling program. + +int procedure grc_mapkey (rc, key, nukey) + +pointer rc #I rcursor descriptor +int key #U raw key value +int nukey #O mapped key value + +begin + nukey = max(1, min(MAX_KEYS, key)) + if (RC_CASE(rc) == NO && IS_LOWER(nukey)) + nukey = TO_UPPER(nukey) + + nukey = RC_KEYS(rc,nukey) + if (nukey == NULL) { + # Not a cursor mode key. + if (RC_CASE(rc) == NO && IS_UPPER(nukey)) + key = TO_LOWER(key) + } else if (IS_LOWER(nukey)) + nukey = TO_UPPER(nukey) + + return (nukey) +end + + +# GRC_RESTORECURPOS -- Restore the cursor position in NDC coordinates +# regardless of the current workstation transformation. + +procedure grc_restorecurpos (stream, x, y) + +int stream # graphics stream +real x, y # new cursor position in NDC coords +real sx, sy +include "gtr.com" + +begin + call grc_ndctoscr (x, y, sx, sy) + call gtr_writecursor (stream, sx, sy) +end + + +# GRC_READTTY -- Read from the terminal via the graphics kernel. If the +# kernel already has message data buffered we merely return that data, +# otherwise we issue the prompt given and interactively read the data. + +int procedure grc_readtty (stream, prompt, obuf, maxch) + +int stream #I graphics stream +char prompt[ARB] #I prompt, if read is interactive +char obuf[ARB] #O output buffer +int maxch #I max chars out + +bool issue_prompt +int nchars, index +int stg_msglen(), stg_readtty() +int stridxs(), strlen() + +begin + issue_prompt = (stg_msglen(STDIN) <= 0) + if (issue_prompt) + call stg_putline (STDERR, prompt) + + nchars = stg_readtty (STDIN, obuf, maxch) + index = stridxs ("\n", obuf) + if (index > 0) + obuf[index] = EOS + nchars = strlen (obuf) + + if (issue_prompt && nchars == 0) + call grc_message (stream, "\n\n") + + return (nchars) +end + + +# GRC_MESSAGE -- Write a message on the status line at the bottom of the +# screen. If the string is not newline terminated the terminal is left in +# status line text mode. To clear the status line and force the terminal +# back into graphics mode, output the string "\n\n". + +procedure grc_message (stream, message) + +int stream # graphics stream +char message[ARB] # message to be printed + +begin + call stg_putline (STDERR, message) +end + + +# GRC_PCURSOR -- Convert the cursor position in screen coordinates to world +# coordinates and print on the standard output. + +procedure grc_pcursor (stream, sx, sy, raster, rx, ry) + +int stream #I graphics stream +real sx, sy #I screen coords of cursor +int raster #I raster number +real rx, ry #I raster coords of cursor + +int wcs +real xc, yc +pointer sp, lbuf + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + call grc_scrtowcs (stream, sx, sy, raster, rx, ry, xc, yc, wcs) + if (abs(xc) > 1 && abs(xc) < 10000 && abs(yc) > 1 && abs(yc) < 10000) + call sprintf (Memc[lbuf], SZ_LINE, "%10.3f %10.3f \n") + else + call sprintf (Memc[lbuf], SZ_LINE, "%12.7g %12.7g \n") + call pargr (xc) + call pargr (yc) + + call stg_putline (STDERR, Memc[lbuf]) + call sfree (sp) +end diff --git a/sys/gio/doc/gio.hlp b/sys/gio/doc/gio.hlp new file mode 100644 index 00000000..f8749c23 --- /dev/null +++ b/sys/gio/doc/gio.hlp @@ -0,0 +1,3498 @@ +.help gio Dec84 "Graphics I/O" +.ce +\fBGraphics I/O Design\fR +.ce +Doug Tody +.ce +December 1984 +.ce +(revised October 1987) +.sp 3 +.nh +Introduction + + The graphics i/o (GIO) interface is a library of SPP or Fortran callable +procedures for interactive vector graphics. The interface is designed primarily +for scientific applications (graphing 1-dimensional data vectors). Limited +support is also provided for displaying 2-dimensional image data. GIO is fully +integrated into the IRAF system and is not intended for use in systems other +than IRAF. The principal design objectives of GIO are outlined below. + +.ls +.ls o +Simple and efficient interactive graphics. For interactive data analysis +applications speed is typically much more important than the quality of +the plot. +.le +.ls o +Ease of use. The interface must be easy to use for scientific data analysis +applications. Ease of use for interactive graphics in scientific applications +is considered more important than the flexibility required to produce +publication quality graphics. +.le +.ls o +Compact size. That portion of the graphics system required for interactive +graphics must be small enough to be linked into every process which performs +interactive graphics. +.le +.ls o +Device independence. The interface must be device independent without +compromising compactness and speed. True device independence means that +an applications program that normally uses interactive graphics can be run +noninteractively or from a nongraphics workstation. +.le +.le + + +IRAF needs its own graphics interface partly because no existing graphics +interface meets all of the above requirements, and partly because we do not +want our applications to be dependent upon any particular external graphics +package. The existing large graphics interfaces such as GKS and CORE are +likely to make it easier to interface GIO to new graphics devices, but to +be completely and directly dependent on any one such interface is unwise since +implementations are sometimes hard to come by. Furthermore, packages such +as GKS and CORE were designed to serve as the kernel of a graphics system +and are cumbersome to use directly in applications software. GIO will serve +as a front end to the graphics kernel, providing a higher level interface +for applications software and isolating the IRAF applications from the kernel, +making it possible to switch to a different kernel without rewriting the +applications packages. + +.nh +Conceptual Design + + GIO is intended to be used either as a self contained interface to a +graphics device, with GIO writing device instructions directly to the device, +or as an interface to a more general device independent graphics kernel. +For maximum speed in interactive applications GIO will use a special builtin +kernel capable of driving only the interactive graphics devices in use at +a particular site (e.g., tektronix compatible graphics terminals). +Other devices will be driven by a device independent graphics kernel resident +in a separate process. GIO will select the data path to be used for a +particular device transparently to the calling program. Thus, the overhead +of process initiation and IPC will be eliminated in common interactive +applications without sacrificing device independence. The builtin kernel +will be table driven using a \fBtermcap\fR format graphics device database, +allowing maximum flexibility for adapting GIO to new graphics devices. + +The device independent graphics kernel may be GKS, CORE, NSPP, or any other +reasonably capable kernel. GIO will be designed to require only a few simple +graphics primitives at the bottom end, making it straightforward to interface +to different graphics kernels. Any application which requires a more +sophisticated graphics interface than that provided by GIO may bypass GIO +and talk directly to the underlying graphics kernel, but doing so will +render the application usable only with that particular graphics kernel. + +Placing the device independent graphics kernel in a separate process makes +it possible to use a large, sophisticated graphics kernel without linking +enormous libraries of subroutines into applications processes. Bugs can be +fixed and new features and devices added without relinking applications +processes. In principle it is even possible to interface simultaneously +to more than one graphics kernel, e.g., one might drive some devices with +an NSPP kernel and others with a GKS kernel. On a different host CORE might +be the only thing available and GIO would have to be interfaced to CORE on +such a host. + + +.ks +.nf + __________ + / \ + | graphics | + | terminal | + \__________/ + | ^ + | |(device codes) + v | _________ + +--------+ +-----------+ / \ + | CL+ |<----| graphics |<----| | + | fast | | kernel | | gdevice | + | kernel |---->| task |---->| | + +--------+ +-----------+ \_________/ + | ^ | + | |(gki metacode) | (core metacode) + v | +--------> (nspp metacode) + +--------+ (gks vdm) + | user | + | task |-----------------------> (gki metacode) + +--------+ + + + simple plotters + |--- interactive ---|------ metafile ------| + graphics special devices + + +.fi +.ce +Figure 1. Graphics Task Structure +.ke + + +The IRAF command language (CL) is the user interface to IRAF programs and +as such moderates all interaction with the user, including interaction via +graphics devices. GIO is primarily a graphics \fIoutput\fR interface; +graphics input (other than pixel readback) is decoupled from graphics output +and is controlled by the CL. Often the task requesting cursor input will +differ from that which produced the graphics. The CL, under control of the +user, may set the default graphics input and output devices, redirect graphics +input and/or output to devices other than the default, and control whether +a graphics task is used interactively or in batch mode. + +.nh +Specifications + + The GIO graphics output procedures draw various flavors of vectors and +fill or color two dimensional areas. Cursor input is a way of interacting +with the user and is therefore handled by CLIO (the command language +interface). We first define important terms and define the coordinate +systems used by GIO. Next follows an overview of the input and output +procedures. Finally, we describe in detail the individual procedures and +the interface to the graphics kernel. + +.nh 2 +Coordinate Systems + + The full plotting surface of a device defines the domain of definition +of the coordinate systems used by GIO. +GIO supports up to sixteen user defined \fBworld coordinate systems\fR +(WCS) per open device, numbered 1 through 16. +One additional coordinate system (WCS 0) with values ranging from 0 to 1 in +either axis is predefined for every device; this \fBnormalized device +coordinate system\fR (NDC) spans the full plotting surface of the device. + +The mapping of world coordinates to device coordinates is +defined by a \fBwindow\fR into world space and a corresponding \fBviewport\fR +into device space. Each window-viewport pair defines one of the 16 world +coordinate systems. At \fBgopen\fR time GIO is initialized to WCS 1, +which has both window and viewport set to NDC coordinates. A subsequent +call to either \fBgswind\fR or \fBgscale\fR will set the window and a +subsequent call to \fBgsview\fR will set the viewport. The WCS is not fixed +to the device until a plotting operation occurs which requires use of the WCS. +Hence, multiple calls to \fBgscale\fR to determine the range of data values +in X and Y for a family of curves are possible before fixing the WCS to the +device, e.g. in a call to \fBglabax\fR. + +A \fBviewport\fR is any rectangular plotting area lying entirely within the +plotting area of the device. The viewport defines the area in which data +can be plotted, i.e., the boundary at which \fBclipping\fR will occur if +enabled. The viewport is the area framed by \fBglabax\fR; the tick and axis +labels will be plotted in the area just outside the viewport. +A square viewport need not have the same resolution in both X and Y. +Devices with variable resolution, e.g. pen plotters, have a default +resolution in either axis which can be overridden when the plot is drawn. +The aspect ratio of the device is the ratio of the physical size of a +device pixel in Y to that in X. Most devices have an aspect ratio of +unity, but it is common for the resolution to be different in X and Y. +The aspect ratio of the device is available via a \fBgget\fR inquiry, +as is the device resolution in either axis. + +A \fBwindow\fR is the range of world coordinates which GIO will map to the +corresponding viewport. The world coordinates must be cartesian and +either linear or logarithmic (base 10) in either axis. +There are no restrictions on the range of world coordinates other than +those imposed by the single precision floating point hardware of the +host computer, provided that the WCS is not degenerate +(zero range in either axis). + +Most applications will use only a single WCS, hence the WCS number is not +included explicitly in the argument lists of the GIO procedures. +A call to \fBgset\fR is required to change to a different WCS. +Thereafter all graphics output and cursor input will refer to the new WCS. +Multiple WCS are useful when plotting in several distinct (nonoverlapping) +viewports on a device, or when overplotting curves within the same viewport +but with different world coordinate windows. + +.nh 2 +Graphics Output Procedures + + The GIO output procedures range from \fBgplotv\fR and \fBgploto\fR, +which can draw an entire plot with autoscaling and axis labeling in one call, +to the polyline, polymarker, move, draw, and text drawing primitives at +the low end. + + +.ks +.nf + gplotv (v, npts, x1, x2, title) + gploto (gp, v, npts, x1, x2, title) + gpagefile (gp, fname, prompt) + + gp = gopen (device, mode, fd) + gclose (gp) + gdeactivate (gp, flags) + greactivate (gp, flags) + gcancel (gp) + gflush (gp) + gclear (gp) + gframe (gp) + greset (gp, flags) + gmftitle (gp, metafile_title) + + gscan (gp, text) + gset[irs] (gp, param, value) + val = gstat[irs] (gp, param[, outstr, maxch]) + val = gget[birs] (gp, devcap[, outstr, maxch]) + g[sg]view (gp, x1, x2, y1, y2) + g[sg]wind (gp, x1, x2, y1, y2) + g[ar]scale (gp, v, npts, axis) + ggscale (gp, x, y, dx, dy) + gctran (gp, x1, y1, x2, y2, wcs1, wcs2) + gcurpos (gp, x, y) + gescape (gp, fn, instruction, nwords) + + glabax (gp, title, xlabel, ylabel) + gline (gp, x1, y1, x2, y2) + gpline (gp, x, y, npts) + gvline (gp, v, npts, x1, x2) + gmark (gp, x, y, marktype, xsize, ysize) + gpmark (gp, x, y, npts, marktype, xsize, ysize) + gvmark (gp, v, npts, x1, x2, marktype, xsize, ysize) + gumark (gp, x, y, npts, xcen, ycen, xsize, ysize, fill) + g[ar]move (gp, x, y) + g[ar]draw (gp, x, y) + gtext (gp, x, y, text, format) + gfill (gp, x, y, npts, style) + g[pg]cell (gp, m, nx, ny, x1, y1, x2, y2) + + gscur (gp, x, y) + stat = ggcur (gp, x, y, key) +.fi +.ke + + +All coordinates are given in world coordinates (user coordinates) +except the viewport coordinates and the marker sizes, which are given in +device coordinates. Low level graphics i/o requires that the graphics +device first be opened with \fBgopen\fR and later closed with \fBgclose\fR. +Several graphics devices may be open simultaneously. + +When a graphics device is opened with \fBgopen\fR all internal parameters +are initialized to their default values, unless the device is opened in +APPEND mode. The default values of these internal parameters may be changed +via explicit \fBgset\fR, \fBgswind\fR, \fBgscale\fR, or \fBgscan\fR calls. +Most powerful is \fBgscan\fR, which interprets graphics commands passed +either as an explicit string or in a text file. + +Much of the flexibility of GIO derives from its parameter defaulting +mechanism. The interface may be expanded indefinitely by adding new +internal parameters accessed via \fBgset\fR calls, without changing the +basic interface. + +.nh 2 +Graphics Input Procedures + + The most commonly used type of graphics input is cursor readback. +Two forms of cursor input are supported: cursor input via the CLIO procedure +\fBclgcur\fR, and cursor input via the GIO procedure \fBggcur\fR. +CLIO based cursor input should be used whenever possible, i.e., when writing +to \fBstdgraph\fR or \fBstdimage\fR. The advantage of cursor input via the +CL is that input may come from a list file or the terminal as well as from +a physical cursor read, allowing programs to be used either interactively +or in batch mode. Furthermore, WCS selection and conversion of NDC cursor +coordinates to WCS and cursor mode interaction are only available with +\fBclgcur\fR. Programs which do not produce any graphics output may read +the cursor via CLIO without using any part of the GIO interface. +The lower level GIO cursor read procedure always reads the physical device +cursor in NDC coordinates and is device dependent (it is what is called by +\fBclgcur\fR). + +Cursors are implemented as abstract datatypes within the CL. A user task +accesses a cursor by reading the value of a CL parameter of type \fBgcur\fR +(stdgraph cursor) or \fBimcur\fR (stdimage cursor). Multiple cursors may +be implemented using multiple cursor type parameters. A cursor parameter +is assumed to have a \fIlist\fR of values; EOF is returned when the end of +the list is reached. Reading the cursor automatically causes any graphics +output to be flushed. + + stat = clgcur (param, wx, wy, wcs, key, strval, maxch) + +The CLIO function \fBclgcur\fR reads the next cursor value from the named +cursor parameter, returning as output arguments the cursor position in world +coordinates, the index of the referenced WCS, the keystroke value (character +typed) of the cursor event, and a string value if the key was ':', the +cursor mode set option escape character. +A cursor read sequence begins with a prompt, i.e., the cursor lights up +or starts blinking. The user is then free to move the cursor about; +the cursor position is not read until a key is typed on the user terminal. +Using a keystroke on the user terminal to terminate both \fBstdgraph\fR +and \fBstdimage\fR cursor reads provides a rich and device independent set of +keystroke values for identifying the action to be performed (imaging devices +are typically very limited in this area). + +GIO always returns the cursor position in world coordinates, along with +the index of the WCS selected. Typically there will be exactly one world +coordinate system (excluding WCS 0) and the WCS value may be ignored. +If no world coordinate systems are defined for the device the cursor +position will be returned in NDC coordinates with WCS=0. + +If multiple world coordinate systems are defined GIO will select the WCS +closest to the position of the cursor, i.e., the cursor may lie outside the +viewport and GIO will still return WCS coordinates. If the cursor lies +within two or more overlapping viewports GIO will select the WCS with the +highest number. The cursor read protocol will allow the user to force +the selection of a particular viewport by first placing the cursor on a +nonoverlapping portion of the viewport and typing a special code, +e.g., W (see next section), and then continuing with the normal cursor read. +If the application wishes to override the automatic WCS selection it may +do so by calling \fBgctran\fR to transform the cursor coordinates returned +by \fBclgcur\fR to a different world coordinate system. + +.nh 3 +Cursor Mode + + In cursor mode, i.e., after a call to \fBclgcur\fR or after typing "=gcur", +a number of special keystrokes shall be recognized for interactive display +control. All graphics output to stdgraph and stdimage is routed through the +CL on the way to the graphics kernel. The CL will optionally spool in an +internal buffer all graphics instructions output to an interactive device. +This internal buffer is emptied whenever the device screen is cleared. +In cursor mode, special keystrokes may be used to redraw all or any portion +of the spooled graphics, e.g., one may zoom in on a portion of the plot and +then roam about on the plot at high magnification. Since the spooled graphics +vectors typically contain more information than can be displayed at normal +magnification, zooming in on a feature may bring out additional detail +(the maximum resolution is 32768 points in either axis). Increasing the +magnification will increase the precision of the cursor by the same factor. + +Cursor mode is implemented by performing coordinate transformation and +clipping on each GKI instruction in the frame buffer, passing the transformed +and clipped instructions on to the graphics kernel. +The cursor mode operations perform a simple geometric transformation on +the spooled graphics frame, mapping a rectangular window of the spooled +frame onto the device screen. The graphics frame itself is not modified, +hence zoom out or reset and redraw will restore the original display. + +If the graphics frame is a typical vector plot with drawn and labeled +axes, magnifying a portion of the plot may cause the axes to be lost. +If this is not what is desired a keystroke is provided to draw and label +the axes of the displayed window. The axes will be overplotted on the +current display and will not be saved in the frame buffer, hence they +will be lost when the frame is redrawn. In cursor mode the viewport is +the full display area of the output device, hence the tick mark labels +of the drawn axes will be drawn inside the viewport. This form of axes +labeling is used because it is simple and because it is appropriate for +both vector graphics and image display output devices (and cursor mode +must serve both). + + +.ks +.nf + A draw and label the axes of current viewport + B backup over last instruction in frame buffer + C print the cursor position as it moves + D draw a line by marking the endpoints + E expand plot by setting window corners + F set fast cursor (for HJKL) + H step cursor left + J step cursor down + K step cursor up + L step cursor right + M move point under cursor to center of screen + P zoom out (restore previous expansion) + R redraw the screen + T draw a text string + U undo last frame buffer edit + V set slow cursor (for HJKL) + W select WCS at current position of cursor + X zoom in, X only + Y zoom in, Y only + Z zoom in, both X and Y + < set lower limit of plot to the cursor y value + > set upper limit of plot to the cursor y value + \ escape next character + : set cursor mode options + :! send a command to the host system + = shorthand for :.snap (make graphics hardcopy) + 0 reset and redraw + 1-9 roam +.fi +.ce +Figure 2. Cursor Mode Keystrokes +.ke + + +By default the cursor mode keystrokes are all upper case letters, reserving +lower case for applications programs. The terminal shift lock key may be +used to simplify typing in lengthy interactive cursor mode sessions. +The cursor motions are decoupled from roam since zoom and roam are often used +merely to increase the precision of a cursor read. Special keystrokes are +provided for stepwise cursor motions to increase the speed of cursor setting +on terminals that do not have fast cursor motions (e.g., the retro-graphics +enhanced VT100). The recognized keystrokes are shown in Figure 2. + +If the character : is typed while in cursor mode the alpha cursor will appear +at the bottom of the screen, allowing a command line to be entered. Commands +which begin with a period, e.g., ":." are interpreted by the graphics system; +any other command will terminate the cursor read, returning the character ':' +as the key value, and the command string as the string value of the cursor +read. The commands recognized by the graphics system are summarized in +figure 3. + + +.ks +.nf + :.axes[+-] draw axes of viewport whenever screen is redrawn + :.case[+-] enable case sensitivity for keystrokes + :.clear clear alpha memory (e.g, this text) + :.cursor n select cursor (0=normal,1=crosshair,2=lightpen) + :.gflush flush plotter output + :.help print help text for cursor mode + :.init initialize the graphics system + :.markcur[+-] mark cursor position after each cursor read + :.off [keys] disable selected cursor mode keys + :.on [keys] enable selected cursor mode keys + :.page[+-] enable screen clear before printing help text + :.read file fill frame buffer from a file + :.show print cursor mode and graphics kernel status + :.snap [device] make hardcopy of graphics display + :.txqual qual set character generator quality (normal,l,m,h) + :.txset format set text drawing parameters (size,up,hj,vj,etc) + :.xres=value set X resolution (stdgraph only) + :.yres=value set Y resolution (stdgraph only) + :.viewport x1 x2 y1 y2 set workstation viewport in world coordinates + :.write[!][+] file save frame buffer in a spool file + :.zero reset viewport and redraw frame +.fi + + +.ce +Figure 3. Cursor Mode Commands +.ke + + +Minimum match abbreviations are permitted for cursor mode command names. +Multiple commands may be given on one line, delimited by semicolons. +If the CL environment variable \fBcminit\fR is defined when cursor mode is +first entered, the string value will be interpreted as a cursor mode command +and used for initialization. For example, to disable the numeric keys and +set the graphics resolution to 200 points in X and 100 points in Y, one +could add the following \fBset\fR declaration to their "login.cl" file: + + set cminit = "xres=200; yres=150; off 0-9" + +The numeric keypad of the terminal (if it has one) is used to roam about +when the zoom factor is greater than one. If the magnification is normal +the numeric keys are not recognized as special keystrokes, i.e., typing +a numeric key will exit cursor mode, returning the character typed to the +applications program. In roam mode a numeric key must be escaped to exit +cursor mode. The directional significance of the numeric keys in roam +mode is obvious if the terminal has a keypad, and is illustrated below. + + +.ks +.nf + 7 8 9 135 090 045 + + 4 5 6 180 000 000 + + 1 2 3 225 -90 -45 +.fi +.ke + + +There is a fixed upper limit on the size of the cursor mode frame buffer. +If the frame data overflows the frame buffer while plotting the plot will +still come out correctly, but only the final plotting instructions will be +retained in the buffer. Redisplay of the frame in cursor mode will thus +result in only a portion of the full frame being drawn. If this is a problem +the user can increase the upper limit on the size of the frame buffer by +setting the value of the environment variable \fBcmbuflen\fR, e.g., + + gflush; set cmbuflen = 512000 + +would initialize the graphics system (freeing the old frame buffer) and set +the upper limit on the size of the frame buffer to 512K words or 1Mb. + +.nh 2 +Example + + At this point a brief example may help to illustrate the use of the GIO +procedures. The following procedure will plot a data vector (pixel array) +and then repeatedly read the cursor, drawing a mark at successive positions +of the cursor. The procedure exits if the user types either the character +'q' or EOF, e.g., or carriage return. + + +.ks +.nf + include + + # MARKPLOT -- Plot a data array and then enter a loop, drawing + # circles at successive cursor positions. + + procedure markplot (data, npts, x1, x2) + + real data[npts] # data vector to be plotted + int npts # length of array + real x1, x2 # world X-coords of vector + + pointer gp + int wcs, key + char str[32] + real wx, wy + pointer gopen() + int clgcur() + + begin + gp = gopen ("stdgraph", NEW_FILE, STDGRAPH) + + call gploto (gp, data, npts, x1, x2, "data") + + while (clgcur ("points", wx, wy, wcs, key, str, 32) != EOF) + if (key == 'q') + break + else + call gmark (gp, wx, wy, GM_CIRCLE, 1., 1.) + + call gclose (gp) + end +.fi +.ke + +.nh 2 +Graphics Output Devices + + While the graphics output device may be specified explicitly by name, +more often graphics output devices will be specified by one of the logical +device names shown below. Examples of the installation dependent device name +associated with each logical name are also shown. + + +.ks +.nf + stdgraph = "gterm" + stdimage = "deanza" + stdplot = "qms" + stdvdm = "uparm$vdm" +.fi +.ke + + +Interaction (via the CL) is supported only for \fBstdgraph\fR and +\fBstdimage\fR. The standard batch plotter device is \fBstdplot\fR, +and the standard metafile (for spooling graphics output) is \fBstdvdm\fR. + +The user should not normally set the value of \fBstdgraph\fR directly with +\fIset\fR, rather they should set the terminal type with \fIstty\fR and let +the latter specify the value of \fBstdgraph\fR. If the terminal specified +is not a graphics terminal (no ":gd" capability in the termcap entry for the +device) the value of \fBstdgraph\fR will be set to "none", otherwise +\fBstdgraph\fR will be set to the name of the stdgraph device entry for the +graphics terminal. + +The device name associated with a logical graphics output +device must have an associated entry in the \fBgraphcap\fR file, +a text file used to describe the characteristics of each device. +New graphcap entries may easily be added by the user to interface to +special graphics devices. +System privledge is not required to modify graphcap, since the name +of the graphcap file is taken from a CL environment variable of the +same name (which can be redefined by the user to point to a file in a +private directory). The graphcap entries for the most commonly used +devices at a given site may be precompiled by the system manager to +eliminate the overhead of searching the graphcap file at \fBgopen\fR time. + +The graphcap parameters (device \fIcapabilities\fR) are too involved to +be presented here and will be described in a later section. +Examples of device capabilities are the device resolution, whether a frame +advance is required before or after a plot, indication of device capabilities +such as the ability to generate text, and the name of the executable +graphics kernel file associated with the device. Many additional parameters +are defined for interactive devices. The graphcap device capabilities +may be inspected with the \fBgget[birs]\fR procedures, which resolve into +calls to the TTY interface, used to access both graphcap and termcap files. + +The sequence of actions taken by GIO to access the graphcap entry for a +device is summarized below. + + +.ks +.nf + if (standard graphics output device) + get device name from environment + + if (device name is actually a filename) { + load graphics device descriptor using the first device entry + from the named graphcap format file + } else { + get filename of graphcap file from environment + load graphics device descriptor by searching the graphcap file + for the named device + } +.fi +.ke + +.nh 2 +Graphics Input Devices + + The technique used to associate an input source with a graphics cursor +is similar to that used for output devices. A CL environment variable is +associated with each cursor type. The names and default values of the +environment variables are shown below. + + +.ks +.nf + stdgcur = "stdgraph" + stdimcur = "stdimage" +.fi +.ke + + +The default input source for a cursor is the graphics output device associated +with the graphics output stream. If the cursor device is "stdgraph" or +"stdimage" the graphics kernel is called to read the physical device cursor +for \fIstdgraph\fR or \fIstdimage\fR. If the cursor device is "text" +the cursor value is a line of text read from the user terminal. +In this mode the user enters at least two of the fields defining +a cursor value. Missing fields are assigned the value zero (the user +presumably will know that the program does not use the extra fields). + + +.ks +.nf + cl> set stdgcur = "text" + cl> = gcur + gcur: 345.33 23.22 1 c + 345.33 23.22 1 c + cl> +.fi +.ke + + +An example of a cursor read request entered interactively by the user, +taking input from the terminal and sending output to the terminal, +is shown above (the CL typed the "gcur: " query and the user entered the +remainder of that line). If the cursor device were "stdgraph" a real +cursor read would occur and the equivalent interaction might appear as +shown below. The cursor position is returned in world coordinates, +where the world coordinate system was defined by the last plot output to +the device. For an imaging device the world coordinates will typically +be the pixel coordinates of the image section being displayed. + + +.ks +.nf + cl> = gcur + 345.33 23.22 1 c + cl> +.fi +.ke + + +Redirecting cursor input to the terminal is useful when working from a +nongraphics workstation and when debugging programs. ASCII cursor queries +are the only type supported when running an IRAF program outside the CL. +Cursor input may also be taken from a list file by assigning a filename +to a cursor parameter, i.e., by assigning a list file to a list structured +parameter and overriding query mode: + + +.ks +.nf + cl> gcur = filename + cl> = gcur + 345.33 23.22 1 c + cl> +.fi +.ke + + +This last mechanism is a standard technique used with CL list structured +parameters and will not be discussed further here. + +.NH 2 +Mixed Terminal and Graphics I/O + + Interactive graphics programs are normally (but not necessarily) executed +on a graphics terminal or workstation supporting both ordinary terminal i/o +and vector graphics. IRAF is designed to use a single terminal for both text +and graphics; text and graphics on separate devices is also supported but is +not the norm. By text we refer here to ordinary line or screen oriented +terminal i/o (e.g., for \fIhelp\fR or \fIeparam\fR), not the use of text in +the graphics plane to annotate plots. + +.NH 3 +Text and Graphics Mode + + Most modern graphics terminals provide separate memory planes for text +and graphics. Depending upon the device, these planes may be displayed +simultaneously, displayed alternately, or only a single memory plane may be +available for both terminal modes, in which case a mode switch is destructive. +The graphics device model implemented by GIO and the STDGRAPH kernel is +flexible enough to deal with all or nearly all such devices. + +The normal mode for the terminal or workstation is text mode. Activating the +workstation causes a switch to graphics mode; deactivating the workstation +restores the terminal to text mode. Activation is implied whenever a device +is opened with \fBgopen\fR, unless the AW_DEFER mode bit is set to defer the +activate workstation until graphics i/o is actually done to the device. +Closing the workstation automatically deactivates the workstation. The GIO +procedures \fBgreactivate\fR and \fBgdeactivate\fR are provided to simplify +mode switching while a device is open on a graphics stream. + +Occasionally it is necessary to print out a large amount of text in response +to a user command entered in a cursor loop while in graphics mode. If the +text is in a file this is done most easily by calling \fBgpagefile\fR to page +the file in text mode, restoring graphics mode when the operation is completed. +If the application generates the output text dynamically then the workstation +must be explicitly deactivated and later reactivated before resuming graphics +i/o, e.g., + +.ks +.nf + while (clgcur (gp, ...) != EOF) { + switch (key) { + case XXX: + call gdeactivate (gp, AW_CLEAR) + + call greactivate (gp, AW_PAUSE) + case YYY: + ... + } + } +.fi +.ke + +The sequence shown will switch to text mode, clear the screen, output the +text, and pause for the user to read the text before restoring graphics mode +and initiating another cursor read. + +.NH 3 +Status Line I/O + + The deactivate/reactivate workstation technique is fine for outputting +large amounts of text, but is not well suited for small amounts of text, +e.g., single line commands to interactively set internal parameters, +output of single lines of text to prompt the user, print the value of a +calculation or some variable, and so on. The so-called "status line" +interface is provided for this purpose. Status line i/o makes it possible +to interact directly with the user without interfering with the contents of +the graphics frame, and without leaving graphics mode. + +What the status line actually is determined by the graphcap entry for the +device and the characteristics or limitations of the actual device. +On most devices, the status line is a single line at the bottom of the screen. +This only works, however, if the device can dynamically erase the status line; +if this is not possible the status "line" may actually be the entire screen, +with successive output lines being drawn on top of the graph. + +To output text to the status line while in graphics mode one merely writes to +STDOUT or STDERR in the usual way, e.g., in a call to \fBprintf\fR. When +newline is seen a flag is set which causes the status line to be cleared when +the next output character is received. Output lines may be built up in +successive calls to output procedures, outputting a single newline to terminate +the line and start a new one. After a newline delimited line of text has been +output, output of a single newline (blank line) will clear the status line. + +It is also possible to read from the status line. This is most commonly done +after writing a prompt string to the status line. The prompt should be +terminated with a colon (e.g., "enter value: ") rather than a newline, +to signal to the user that input is expected, and to avoid having the +subsequent status line read clear the prompt string. In many cases such +explicit prompting and decoding of the return string can be avoided by using +the standard CLIO parameter prompting mechanism for interactive input. +CL parameter prompts are also permitted in graphics mode, and will interact +with the user on the status line in the expected way, without interfering +with the graphics state of the device. + +When mixing status line i/o and graphics i/o one must be careful to flush any +buffered graphics or textual output before switching modes. In many cases the +system will do this for you automatically, but there are exceptions where +explicitly flushing of buffered output is necessary (e.g., STDOUT and STDERR +are low level facilities with no knowledge of GIO, and output to one of these +streams will not automatically cause any graphics output to be flushed). + +.NH 2 +User Interface Conventions + + While different interactive (cursor driven) graphics programs will differ +in many ways, there are certain operations which are common to all such +programs. In order to present a more consistent interface to the user, +conventions have been defined for these common operations. + +.NH 3 +On Line Help + + All interactive graphics programs should respond to the key '?' with a +description of the keystrokes and colon commands recognized by the program +(or submenu, in the case of a menu structured interface). This is normally +done by calling \fBgpagefile\fR to interactively page the ".key" keystrokes +help file for the program. The keystroke files for system programs are +stored in the directory lib$scr; non-system programs keep their keys files +either in the package directory, or in a global package library. + +.NH 3 +Cursor and Device Names + + In general, applications programs should not read directly from \fBgcur\fR +or \fBimcur\fR (the global cursor parameters), nor should the open the +"stdgraph", "stdimage", or "stdplot" device directly by these explicit string +values. This works, but is inflexible. To make it easy for the user to +run an otherwise interactive program in batch mode, taking input from a cursor +list file, the task should include a cursor type parameter in its parameter +set. Likewise, to make it easy for the user to temporarily redirect the +output of the program to a device other than the current stdgraph, stdplot, +etc., device, the device name should be parameterized as a string type CL +parameter. + +For example, if task \fBplotit\fR has cursor and device parameters named +"cursor" and "device", the command + + cl> plotit cursor=listfile device=qms + +would run the task taking cursor input from the text file "listfile", with +stdgraph graphics output directed to the plotter device "qms". + +.NH 3 +Exiting an Interactive Cursor Loop + + The following standards have been defined for dealing with EOF/quit in +interactive cursor loops. +.ls +.ls EOF +End of file is indicated for a cursor list either by an actual +end of file in the case of a true cursor list, or by typing the EOF character +(e.g., , , or the interrupt character) in an interactive +cursor read. EOF on the cursor list should be taken seriously by the +applications program, and not treated as just another key, hence it should +not be something that the user is expected to type routinely to exit a cursor +loop. If a program gets EOF back as the value of \fBclgcur\fR it should exit +immediately, without any verification queries etc, since it may well have +been run in batch mode with input redirected to a cursor list file. +.le +.ls q +The standard interactive cursor loop exit character is 'q'. +All interactive graphics programs should recognize this character +and take some action to exit the cursor loop, e.g.: + +.ks +.nf + while (clgcur (...) != EOF) + switch (key) { + case 'q': + break + case ... +.fi +.ke + +The 'q' character is intended to be handled directly by the application +program, rather than mapped into EOF by the system (like Q was, and CR and +the gt_gcur 'q' before that in old versions of IRAF), +to distinguish this case from a hard-EOF and to provide maximum +flexibility in how the program treats a request from the user to exit. +If the user would suffer from an accidental program exit then the 'q' key +action should do something before exiting, e.g., ask that the user first +update the database, ask that CR be hit to verify the quit, and so on. +In general, if it would take the user more than a minute to recover after +an accidental program exit, one should consider coding some sort of +verification action to be executed before exiting when 'q' is typed (but not +when EOF is seen on the list). +.le +.le + +The GIO procedure \fBgqverify\fR is provided for programming convenience in +cases where only simple verification is desired. Note that lightweight tasks +or submenus which can easily be reentered should not bother even with this, +but should simply exit. For example: + +.ks +.nf + case 'q': + if (gqverify() == YES) + break +.fi +.ke + +As a more complex example, suppose the program is used to edit or +create a database which could be lost or damaged in an accidental +exit, if not updated first. We do not want to update the database +automatically because this would overwrite the former contents of +the database. The program might be set up as follows. + +.ks +.nf + 'q' program prints error message on status line, e.g., + "No write since last change (:quit! overrides)" + :w[rite] updates the database; q will execute silently + :q[uit]! force a quit w/o an update; discard changes +.fi +.ke + +.nh 2 +Detailed Procedure Specifications + + The graphics output procedures provided by GIO fall into four main +groups. First are the high level "plot at a time" procedures, +used to plot entire data vectors. Second are the control procedures, +used to open and close a device, to flush output and clear the screen, +and to cancel output in the event of an interrupt. +Third are the procedures used to set and stat (inquire) the GIO +internal parameters, e.g. to define a WCS, change pens, select axis labeling +options, or inquire the device resolution. Fourth and last are the output +procedures, used to draw and label the axes of a viewport, set the cursor, +draw lines or marks, plot text, or fill areas. + +.nh 3 +High Level Procedures +.ls 4 +.tp 8 +.ls gplotv (v, npts, x1, x2, title) + +.nf +real v[npts] # data vector +int npts # number of data points +real x1, x2 # WC assigned v[1] and v[npts] +char title[ARB] # plot title +.fi + +Open GIO, clear the screen, autoscale and plot the data vector, then close GIO. +A default viewport is used. The axes are drawn, tick marks are selected, +marked, and labeled, and the plot title is printed. The data is plotted +using solid line segments. The X values of the data points are evenly +distributed from X1 to X2. +.le + +.tp 8 +.ls gploto (gp, v, npts, x1, x2, title) + +.nf +pointer gp # graphics descriptor +real v[npts] # data vector +int npts # number of data points +real x1, x2 # WC assigned v[1] and v[npts] +char title[ARB] # plot title +.fi + +A more flexible version of \fBgplotv\fR. The graphics device must already +have been opened with an explicit call to \fBgopen\fR. The explicit open +call makes it possible to append to an existing plot or to change plotting +options with calls to \fBgset\fR before calling \fBgploto\fR to autoscale, +draw the axes, and plot the data vector. Annotation of the plot via calls +to the low level output primitives is possible before a final call to +\fBgclose\fR to close the device and free the graphics descriptor. +.le + +.tp 8 +.ls gpagefile (gp, fname, prompt) + +.nf +pointer gp # graphics descriptor +char fname[ARB] # file to be paged +char prompt[ARB] # end of page prompt string +.fi + +Interactively page through a file on the terminal in text mode, e.g., to +display help text in response to the '?' standard help query key. +The workstation is deactivated, the screen is cleared and the file is paged, +with the usual file pager prompt being displayed at the bottom of each page +of text. When the pager is exited the workstation is reactivated if it was +active when the pager was called. If the prompt string is null the file +name is used. +.le +.le + +.nh 3 +Control Procedures +.ls +.tp 8 +.ls gopen (device, mode, fd) + +.nf +char device[ARB] # name of device to be opened +int mode # access mode +int fd # graphics stream to be written +.fi + +The named graphics device is opened for graphics i/o. A pointer to the GIO +graphics descriptor assigned to the device is returned as the function value. +The device name may be the name of one of the standard logical graphics +devices, i.e., \fBstdgraph\fR, \fBstdimage\fR, \fBstdplot\fR, or \fBstdvdm\fR, +or the actual name of a physical device. + +The only meaningful device access modes at present are NEW_FILE and APPEND. +In NEW_FILE mode all WCS are initialized to NDC coordinates. +Opening the stdgraph device in NEW_FILE mode causes a screen clear on the next +call to \fIgflush\fR. In APPEND mode the WCS are restored to the values they +had when the device was last accessed. +The GIO internal state variables are initialized to their default values +at \fBgopen\fR time regardless of the access mode for the device. + +Opening the stdgraph device causes an implicit reactivate workstation unless +the AW_DEFER flag () is set in the access mode, e.g., + + gp = gopen (device, NEW_FILE+AW_DEFER, fd) + +Defer mode allows the graphics descriptor to be opened once, e.g., during task +startup, before any graphics output is required. This is sometimes useful in +applications which switch back and forth between text and graphics mode often, +by bracketing each graphics sequence with calls to \fIgreactivate\fR to enter +graphics mode, and \fIgdeactivate\fR to return to text mode. Defer mode may +be combined with any normal access mode code. + +Graphics output will be written to the stream \fIfd\fR, which may be one +of the standard streams STDGRAPH, STDIMAGE, or STDPLOT, or to a binary file +opened explicitly by the user before calling \fBgopen\fR. +.le + +.tp 5 +.ls gclose (gp) + +The graphics device associated with graphics descriptor \fBgp\fR is closed, +freeing all resources allocated to the device. Any buffered graphics output +is automatically flushed before closing the device. +.le + +.tp 4 +.ls gdeactivate (gp, flags) + +.nf +pointer gp # graphics descriptor +int flags # AW_CLEAR, AW_PAUSE (see ) +.fi + +The graphics workstation is deactivated, i.e., restored to the normal terminal +(text drawing) mode, the state the terminal was in prior to \fIgopen\fR, and to +which it will be restored after a \fIgclose\fR. This function is intended for +interactive graphics applications and may be may be ignored by some graphics +kernels. If the AW_PAUSE flag bit is set the user will be asked to type a +key before the terminal is restored to text mode. If the AW_CLEAR flag bit +is set the terminal (text) screen will be cleared after the workstation is +deactivated. + +.le + +.tp 4 +.ls greactivate (gp, flags) + +.nf +pointer gp # graphics descriptor +int flags # AW_CLEAR, AW_PAUSE (see ) +.fi + +The graphics workstation is reactivated, i.e., restored to graphics mode from +the normal terminal (text drawing) mode. This function is intended for +interactive graphics applications and may be may be ignored by some graphics +kernels. If the AW_PAUSE flag bit is set the user will be asked to type a +key before the terminal is restored to graphics mode. If the AW_CLEAR flag +bit is set the graphics frame will be cleared. +.le + +.tp 4 +.ls gcancel (gp) + +Any buffered graphics output is discarded and any output operation currently +in progress is aborted. Used to recover from an interrupt. +.le + +.tp 3 +.ls gflush (gp) + +Any buffered graphics output is flushed to the output device. +.le + +.tp 4 +.ls gclear (gp) + +If the output device is a CRT the screen is erased (including all viewports). +If the output device is a plotter a formfeed is issued, advancing to the next +page of output (whether or not any graphics output has occurred). +All WCS are initialized to NDC coordinates and the internal state of GIO +is initialized, i.e., the state of each drawing instruction attribute packet +is set to UNSET to force retransmission to the graphics kernel as i/o occurs, +and the current settings of the \fIgset\fR options, e.g., line style and width, +\fIglabax\fR options, etc., are all initialized to their default (\fBgopen\fR) +values. +.le + +.tp 4 +.ls gframe (gp) + +Issue a screen clear or frame advance. This call is equivalent to \fBgclear\fR +except that the internal state of GIO is not initialized. An application +might want to call \fBgframe\fR and \fBgreset\fR directly rather than using +\fBgclear\fR, if the full initialization implied by \fBgclear\fR is not what +is desired. +.le + +.tp 4 +.ls greset (gp, flags) + +.nf +pointer gp # graphics descriptor +int flags # bitflags noting what to reset (0 is a no-op) +.fi + +The \fBgreset\fR may be used to reset all or parts of the internal state of +GIO, without actually doing any i/o to the graphics device. The \fIflags\fR +argument is used to specify what is to be reset. The bitflags (defined in +) are enumerated below. + +.nf + GR_RESETALL reset everything + GR_RESETGIO reset only GIO drawing parameters + GR_RESETWCS reset the WCS to wcs=1, all NDC + GR_RESETGLABAX reset the GLABAX parameters +.fi + +A \fBgclear\fR is equivalent to a \fBgframe\fR followed by a +greset(gp,GR_RESETALL). +.le + +.tp 8 +.ls gmftitle (gp, mftitle) + +.nf +pointer gp # graphics descriptor +char mftitle[ARB] # comment (metafile title string) +.fi + +Place a comment describing the graphics being generated in the output +stream. Useful primarily when the output is expected to be saved in a +metafile. No graphics is generated. +.le +.le + +.nh 3 +Set and Stat Procedures +.ls +.tp 8 +.ls gscan (gp, text) [NOT YET IMPLEMENTED] + +.nf +pointer gp # graphics descriptor +char text[ARB] # graphics commands +.fi + +The string \fBtext\fR, consisting of an arbitrary length sequence of +printable ASCII graphics commands delimited by semicolons or newlines, +is interpreted and executed by GIO. Each GIO procedure has a corresponding +command of the same syntax, minus the parenthesis, commas, and the argument +\fBgp\fR. The syntax of a \fBgset\fR command is "param=value". +File inclusion is provided by the operator "@" followed by the filename +of the file to be included. +The include operator may appear anywhere a token is expected and includes +may be nested up to some maximum depth. +The sequence "@STDIN" is especially useful for entering commands or data +interactively. +.le + +.tp 8 +.ls gset[irs] (gp, param, value) + +.nf +pointer gp # graphics descriptor +int param # parameter to be set +[irs] value # new value for parameter +.fi + +Set the value of the indicated parameter. A separate procedure is used for +integer, real, and string valued parameters, i.e., gseti, gsetr, gsets. +GIO parameters may be either internal state variables (e.g. the number of +ticks on an axis) or device parameters (e.g. the number of the pen to be +used to draw lines). +The GIO parameters are defined in the global include file \fB\fR. +.le + +.tp 10 +.sp +.nf +gstati (gp, param) +gstatr (gp, param) +gstats (gp, param, outstr, maxch) +.fi +.ls +.nf +pointer gp # graphics descriptor +int param # parameter to be set +char outstr[maxch] # output string +.fi + +Inquire the value of the indicated GIO internal parameter. +The integer and real functions \fBgstati\fR and \fBgstatr\fR return +the parameter value as the function value, whereas \fBgstats\fR is +a procedure returning the string value of a parameter as an output argument. +The GIO parameters are defined in the global include file \fB\fR. +.le + +.tp 11 +.sp +.nf +ggetb (gp, cap) +ggeti (gp, cap) +ggetr (gp, cap) +ggets (gp, cap, outstr, maxch) +.fi +.ls +.nf +pointer gp # graphics descriptor +char cap[2] # device capability +char outstr[maxch] # output string +.fi + +Inquire the value of the indicated graphics device capability. +The device capability \fIcap\fR is the two character name of the capability +as it appears in the \fIgraphcap\fR file. Aside from the device capabilities +required by GIO, GIO itself knows nothing about the graphcap device +capabilities. New capabilities may be added without modifying GIO. +The \fBgget\fR procedures call the corresponding procedures in the TTY +interface. If more control over device capabilities is required than +that provided by GIO, the TTY interface may be used directly, following a +call to \fBgstati\fR to get the pointer to the TTY descriptor for the device. + +The boolean function \fBggetb\fR tests whether the device has the named +capability. The integer and real functions \fBggeti\fR and \fBggetr\fR return +the capability value as the function value, or zero if the capability is +not defined for the device. String valued capabilities are returned by +\fBggets\fR as an output argument; the null string is returned if the +device does not have the indicated capability. +.le + +.tp 8 +.ls g[sg]view (gp, x1, x2, y1, y2) + +.nf +pointer gp # graphics descriptor +real x1, x2 # range of NDC coordinates in X +real y1, y2 # range of NDC coordinates in Y +.fi + +Set or get the NDC coordinates of the viewport associated with the current WCS. +The default viewport is the full display area of the device. +.le + +.tp 8 +.ls g[sg]wind (gp, x1, x2, y1, y2) + +.nf +pointer gp # graphics descriptor +real x1, x2 # range of world coordinates in X +real y1, y2 # range of world coordinates in Y +.fi + +Set or get the world coordinates of the window associated with the current WCS. +The default window ranges from 0 to 1 in both X and Y, i.e., the default +window associates a normalized coordinate system with the associated viewport. +Any window limits passed as INDEF will be ignored, i.e., those window +parameters will not be modified. +.le + +.tp 9 +.ls g[ar]scale (gp, v, npts, axis) + +.nf +pointer gp # graphics descriptor +real v[npts] # data vector window is to be scaled to +int npts # length of data vector +int axis # axis to be scaled (1=X, 2=Y). +.fi + +Set absolute (\fIgascale\fR) or rescale (\fBgrscale\fR) the minimum and +maximum world coordinates of the indicated axis of the current window, +i.e., scale the window to fit a data vector. +May be called repeatedly if overplotting several curves. The current minimum +and maximum values for either axis may be obtained at any time by calling +\fBggwind\fR. To scale the window to fit a family of curves, +call \fBgascale\fR for the first curve and \fBgrscale\fR for the remaining +curves, thereby computing the range in X and or Y of all curves. +.le + +.tp 9 +.ls ggscale (gp, x, y, dx, dy) + +.nf +pointer gp # graphics descriptor +real x, y # point at which scale is desired (wc) +real dx, dy # scale, wcs units per ndc unit +.fi + +Determine the scale in world coordinate units at the point (x,y). Useful +for computing the size of an object in world coordinates given its size +in ndc coordinates, or vice versa. An approximation is used to determine +the scale if log scaling is in use. Note that the scale is a function of +position for the nonlinear coordinate systems. +.le + +.tp 9 +.ls gctran (gp, x1, y1, x2, y2, wcs1, wcs2) + +.nf +pointer gp # graphics descriptor +real x1, y1 # input point in WCS1 coords +real x2, y2 # output point in WCS2 coords +int wcs1, wcs2 # input, output world coordinate systems +.fi + +Transform a point in world coordinate system \fIwcs1\fR to world coordinate +system \fIwcs2\fR. If \fIwcs1\fR is zero the transformation is from NDC +coordinates to WCS coordinates. If \fIwcs2\fR is zero the transformation is +from WCS coordinates to NDC coordinates. Otherwise the transformation is +between two user defined world coordinate systems. The point need not fall +within the viewports of the two world coordinate systems. World coordinate +systems which were never set are equivalent to WCS=0. +.le + +.tp 9 +.ls gcurpos (gp, x, y) + +.nf +pointer gp # graphics descriptor +real x, y # current pen position in world coordinates +.fi + +Return the "current pen position" in the current world coordinate system. +The current pen position is the position set by the last move or draw +command. +.le + +.tp 10 +.ls gescape (gp, fn, instruction, nwords) + +.nf +pointer gp # graphics descriptor +int fn # function code +short instruction[nwords] # instruction sequence to be passed +int nwords # length of instruction sequence +.fi + +Send a device dependent instruction sequence to the graphics kernel. +Escape functions are ignored by GIO and by graphics kernels that do +not recognize the function code. +.le +.le + +.nh 3 +Output Procedures + + Data passed to the polyline or polymarker output procedures may contain +embedded INDEF (indefinite) values in the X, Y, or V arrays. Indefinite valued +points appear as gaps in the plot and are ignored when autoscaling. +Indefinite valued pixels are not permitted in a cell array since GIO does +not look at the values of the pixels. + +.ls +.tp 9 +.ls glabax (gp, title, xlabel, ylabel) + +.nf +pointer gp # graphics descriptor +char title[ARB] # plot title +char xlabel[ARB] # X axis label +char ylabel[ARB] # Y axis label +.fi + +Draw and label the axes of the viewport. +If the WCS has not yet been fixed it will be fixed by this call. +If desired, \fBglabax\fR may modify the window slightly to place +simple values on the tick marks. Numerous \fBgset\fR options are +available for controlling the number and sizes of the tick marks, +the format of tick labels, the axes on which tick labels appear, +and so on. If the device viewport has not yet been set and axis labeling +is enabled, \fBglabax\fR will set a default size viewport which allows room +for the label text outside the viewport. +.le + +.tp 8 +.ls gline (gp, x1, y1, x2, y2) + +.nf +pointer gp # graphics descriptor +real x1, y1 # start of line +real x2, y2 # end of line +.fi + +Draw a line connecting the point (x1,y1) to the point (x2,y2) (WCS coordinates). +The linetype, linewidth, and color may be changed beforehand with a call +to \fBgset\fR. The relevant parameters and their possible values are shown +below. Linetype zero (clear) may be used to erase lines drawn with any of the +other linetypes (device permitting). + +.ks +.nf + G_PLTYPE 0=clear, 1=solid, 2=dashed, 3=dotted, + 4=dotdash, >4=device dependent + G_PLWIDTH relative line width (default 1.0) + G_PLCOLOR color index +.fi +.ke +.le + +.tp 8 +.ls gpline (gp, x, y, npts) + +.nf +pointer gp # graphics descriptor +real x[npts] # X coordinates of the line endpoints +real y[npts] # Y coordinates of the line endpoints +int npts # number of line endpoints +.fi + +Polyline. Draw a line connecting the points (WCS coordinates). +The linetype, linewidth, and color may be changed beforehand with a call +to \fBgset\fR. +.le + +.tp 8 +.ls gvline (gp, v, npts, x1, x2) + +.nf +pointer gp # graphics descriptor +real v[npts] # vector to be plotted (Y values) +int npts # number of line endpoints +real x1, x2 # range of vector in X +.fi + +Vector polyline. Draw a polyline wherein the Y values of the polyline are +taken from V and the X values are evenly distributed along the X-axis, +ranging from X1 at point V[1] to X2 at point V[npts] (WCS coordinates). +.le + +.tp 9 +.ls gmark (gp, x, y, marktype, xsize, ysize) + +.nf +pointer gp # graphics descriptor +real x, y # WCS coordinates of marker +int marktype # marker type +real xsize, ysize # marker sizes +.fi + +Mark drawing primitive. Draw a mark of type \fImarktype\fR and size +\fImarksize\fR at the given position in WCS coordinates. +The marker type codes recognized are shown below and are defined in . +Marktype codes may be summed to make composite marks, e.g., + + call gmark (gp, x, y, GM_PLUS+GM_CROSS, 1.) + +is an asterisk. The pseudo-mark GM_FILL may be combined with GM_CIRCLE, +GM_BOX, or GM_DIAMOND to output the mark as a filled area, using the current +fill area attributes. A positive \fImarksize\fR specifies the mark size in NDC +coordinates, whereas negative signifies WCS coordinates. +The positive marksizes 1., 2., 3., and 4. signify default size marks of +increasing size. + +.ks +.nf + typecode name symbol + + 0 GM_POINT smallest plottable point + 1 GM_FILL fill interior of mark + 2 GM_BOX square box + 4 GM_PLUS plus + 8 GM_CROSS cross + 16 GM_DIAMOND diamond + 32 GM_HLINE horizontal line + 64 GM_VLINE vertical line + 128 GM_HEBAR horizontal error bar + 256 GM_VEBAR vertical error bar + 512 GM_CIRCLE circle +.fi +.ke + +The linetype for a mark is set by the parameter G_PMLTYPE. A mark may +be erased (device permitting) by setting the marker linetype to clear and +redrawing the mark. The color index used for marks is controlled by the +\fBgset\fR parameter G_PMCOLOR. +.le + +.tp 9 +.ls gpmark (gp, x, y, npts, marktype, xsize, ysize) + +.nf +pointer gp # graphics descriptor +real x[npts] # WCS X coordinates of markers +real y[npts] # WCS Y coordinates of markers +int npts # number of markers +int marktype # marker type +real xsize, ysize # marker sizes +.fi + +Polymarker. Plot a sequence of \fInpts\fR markers at the positions given +by successive WCS coordinate pairs (x[i],y[i]). All markers will be of +the same type and size. The significance of the marker type and size codes +is the same as for \fBgmark\fR. +.le + +.tp 9 +.ls gvmark (gp, v, npts, x1, x2, marktype, xsize, ysize) + +.nf +pointer gp # graphics descriptor +real v[npts] # WCS Y coordinates of markers +int npts # number of markers +real x1, x2 # range of WCS X coordinates +int marktype # marker type +real xsize, ysize # marker sizes +.fi + +Vector polymarker. Plot a sequence of \fInpts\fR markers at the positions given +by successive WCS coordinate pairs (x[i],y[i]), where the x[i] are evenly +distributed from X1 at V[1] to X2 at V[npts]. All markers will be of the same +type and size. The significance of the marker type and size codes is the same +as for \fBgmark\fR. +.le + +.tp 11 +.ls gumark (gp, x, y, npts, xcen, ycen, xsize, ysize, fill) + +.nf +pointer gp # graphics descriptor +real x[npts],y[npts] # normalized polyline defining marker +int npts # number of points in polyline +real xcen, xcen # world coordinates of center of marker +real xsize, ysize # marker size in X and Y +int fill # draw mark using area fill +.fi + +Draw a user defined marker. The marker is defined by the polyline (X[i],Y[i]), +normalized to the unit square. The marker polyline is scaled to fit the +window defined by \fIxcen\fR, \fIycen\fR, \fIxsize\fR, and \fIysize\fR, +where the center is always defined in world coordinates but the marker sizes +may be defined in any of a number of ways (see \fBgmark\fR). If \fIfill\fR +is YES the marker will be drawn using area fill rather than as a polyline. +.le + +.tp 8 +.ls g[ar]move (gp, x, y) + +.nf +pointer gp # graphics descriptor +real x, y # WCS coordinates to move or shift +.fi + +Move absolute (\fBgamove\fR) or move relative (\fBgrmove\fR), +with the "pen up". A move relative should be preceded by a move absolute +to unambiguously define the "current pen position" in WCS coordinates. +Only the move, draw, and mark primitives leave the pen in a defined position. +Calls to \fBgset\fR may be intermixed with move and draw commands without +affecting the current pen position. +.le + +.tp 8 +.ls g[ar]draw (gp, x, y) + +.nf +pointer gp # graphics descriptor +real x, y # WCS coordinates to move or shift +.fi + +Move absolute (\fBgadraw\fR) or move relative (\fBgrdraw\fR), +with the "pen down". Draws a line segment. +The type of line drawn (linetype or "pen number") defaults to solid but +may be changed beforehand with a call to \fBgset\fR. +Calls to \fBgset\fR may be intermixed with move and draw commands without +affecting the current pen position. +.le + +.tp 9 +.ls gtext (gp, x, y, text, format) + +.nf +pointer gp # graphics descriptor +real x, y # WCS coordinates of text string +char text[ARB] # text to be plotted +char format[ARB] # text characteristics +.fi + +Plot the string \fItext\fR at the position (x,y) in WCS coordinates. +The default size, orientation, and justification of the generated string +may be set by a prior call to \fBgset\fR or overridden for the duration +of the current call by the \fIformat\fR string. A null format string +is permtted. + + +.ks +.nf + keyword values default + + up degrees ccw, zero = +x 90 + size character size scale factor 1.0 + path left,right,up,down r + hjustify normal,center,left,right l + vjustify normal,center,top,bottom b + font roman,greek,italic,bold r + quality normal,low,medium,high n + color integers greater than one 1 +.fi +.ke + + +The attributes controlling how text is generated are shown above. +The character up vector (attribute \fIup\fR) defines the horizontal and +vertical axes (the horizontal axis is perpendicular to the character up +vector). Directions left and right, up and down are relative to these axes. +The attribute \fIpath\fR defines the direction in which characters are +to be plotted. The attribute \fBquality\fR makes it possible to choose +between low or medium quality (fast) and high quality (expensive) character +generation techniques, e.g., hardware versus software character generation. +This attribute is normally best set to "normal" and then overridden at +metafile translation time. + +The attributes are set in the format string by a semicolon delimited list of +keyword=value constructs. Only the first character of keyword and value +strings is significant, i.e., keywords and values may be abbreviated to as +little as one character if desired. For example, the format "p=d;v=c" +would plot characters downward in a vertical string centered at the position +given. + +The default font is set by the font attribute at the beginning of each call. +Font changes may also be signaled by placing the sequence "\fF" in the text, +where F is one of the characters RGIB, denoting the fonts roman, greek, +italic, and bold. In this manner the font may change from character +to character within a single line of text. Additional escape sequences may +be added to represent special symbols. +.le + +.tp 10 +.ls gfill (gp, x, y, npts, style) + +.nf +pointer gp # graphics descriptor +real x[npts] # X coordinates of polygon +real y[npts] # Y coordinates of polygon +int npts # number of vertices of polygon +int style # type of fill +.fi + +Area fill. The points (x[i],y[i]) define a closed area which will be filled +in the indicated \fIstyle\fR. The recognized style codes, defined in , +are: + +.ks +.nf + 0 GF_CLEAR clear area + 1 GF_HOLLOW draw only outline of area + 2 GF_SOLID fill area with a color + 3-6 GF_HATCH[1234] fill area with a pattern + 7-N device dependent +.fi +.ke + +If the device can support multiple colors the color index for area fill may +be set beforehand with a call to \fBgset\fR to set the parameter G_FILLCOLOR. +.le + +.tp 10 +.ls gpcell (gp, m, nx, ny, x1, y1, x2, y2) + +.nf +pointer gp # graphics descriptor +short m[nx,ny] # greylevels or colors (pixels) +int nx, ny # number of pixels in X and Y +real x1, y1 # lower left corner of output area +real x2, y2 # upper right corner of output area +.fi + +Output a cell array. +Map each pixel in the input array into the corresponding area +of the output device. For maximum efficiency the resolution of M should +match that of the area of the output device defined by the window (x1,y1) +and (x2,y2), otherwise M is subsampled or replicated to best fill the output +area. The aspect ratio of a pixel need not be preserved in the mapping. +The pixel values (greylevels or color indices) are passed on to the kernel +without modification. +.le + +.tp 7 +.ls gscur (gp, x, y) + +.nf +pointer gp # graphics descriptor +real x, y # new cursor position +.fi + +Move the device cursor to the indicated position (WCS coordinates). +.le +.le + +.nh 3 +Input Procedures + + Input procedures are available for cursor and pixel input. Inquiry of GIO +parameters and device capabilities is handled by the \fBgstat\fR and \fBgget\fR +procedures and is not considered graphics input. + +.ls +.tp 8 +.ls clgcur (param, wx, wy, wcs, key, strval, maxch) + +.nf +char param[ARB] # CL parameter to be input +real wx, wy # world coordinates of cursor event +int wcs # index of WCS selected +int key # keystroke value of cursor event +char strval[maxch] # string value if set option (key = ':') +int maxch # max chars to be returned in strval +.fi + +The next value of the list structured CL cursor type parameter \fIparam\fR +is read and the cursor coordinates in WCS units are decoded and returned +as output arguments, along with the WCS number and the keystroke value, +i.e., the character typed by the user causing the cursor to be read. +The range of keystroke values is the full ASCII character set, minus a system +dependent subset of control codes (if a physical cursor is read, the read is +always terminated by the user typing a key on the user terminal). +No GIO device need be open to read the cursor. EOF is returned as the +function value when the end of the cursor list is reached. +The number of output arguments successfully decoded is returned as the +function value for a normal read. Values not converted are set to zero. +.le + +.tp 8 +.ls ggcur (gp, sx, sy, key) + +.nf +pointer gp # graphics descriptor +real sx, sy # NDC coordinates of cursor event +int key # keystroke value of cursor event +.fi + +The physical cursor of the graphics device associated with graphics +descriptor \fIgp\fR is read and the cursor coordinates in NDC units are +returned as output arguments, along with the keystroke value, i.e., +the character typed or button pushed causing the cursor to be read. +On many devices the cursor read will be instantaneous (the cursor position +will be sampled), and the keystroke value will always be zero. The range +of possible keystroke values is device dependent. EOF is returned as the +function value when the end of the cursor list is reached. An error action +is taken if the device is not readable. The GIO device must have previously +been opened with \fBgopen\fR. + +Use of this low level procedure is not recommended since it forces a program +to be used interactively, operation is device dependent, and cursor mode +interaction is not supported. The main uses for \fBggcur\fR are cursor input +from special graphics devices, i.e., devices other than \fBstdgraph\fR or +\fBstdimage\fR, and continuous sampling of the cursor position on devices +which support it. The characteristics of the device cursors are described +in the graphcap entry for the device. +.le + +.tp 10 +.ls ggcell (gp, m, nx, ny, x1, y1, x2, y2) + +.nf +pointer gp # graphics descriptor +short m[nx,ny] # output pixel array +int nx, ny # number of pixels out in X and Y +real x1, y1 # lower left corner of input area +real x2, y2 # upper right corner of input area +.fi + +Input a cell array. The cell array defined by the rectangular window +from point (x1,y1) to (x2,y2) is read into the output array M of size +NX columns by NY lines. +For maximum efficiency the resolution of the output array should match +that of the device area defined by the input window. +If the resolution of the output array does not match that of the device +output lines will be subsampled or replicated to best fit the output array. +Unaddressable pixels are returned as negative values. An error action is +taken if the device is not readable. +.le +.le + +.nh 2 +GIO Internal Parameters + + The GIO internal parameters may be set with either a \fBgset\fR or +\fBgscan\fR call, and inspected with a \fBgstat\fR function call. +Parameters are identified to \fBgset\fR and \fBgscan\fR by an integer +code. Each integer code is assigned a symbolic name of the form G_PARAM +in the include file . In input to \fBgscan\fR, parameters are +referred to by name in lower case, without the "g_" prefix. The parameters +and their default values are shown below. + + +.tp 5 +.nf + \fBparameter default description\fR + + wcs 1 index of current WCS + xtran linear linear, log, or nlog (WCS attribute) + ytran linear linear, log, or nlog (WCS attribute) + clip yes clip at viewport boundary (WCS attribute) + cursor 1 current cursor number + pltype 1 polyline linetype + plwidth 1.0 polyline relative line width + plcolor 1 polyline color index + pmltype 1 polymarker linetype + pmcolor 1 polymarker color index + szmarker[1-4] (.5:2)*ch standard marker sizes, NDC coordinates + fastyle 1 fill area interior style + facolor 1 fill area color index + txsize 1.0 relative character size + txup 90 character up vector + txpath right direction in which characters are drawn + txspacing 0.0 character spacing relative to height + txhjustify left horizontal justification (n,c,l,r) + txvjustify bottom vertical justification (n,c,t,b) + txfont roman text font (roman,greek,italic,bold) + txquality normal text generator precision (n,l,m,h) + txcolor 1 text color index +.fi + +.tp 9 +.nf + (axis labeling parameters) + + drawtitle yes draw plot title if given + titlesize 1.0 character size for plot title + titlejust center horizontal justification of title + ntitlelines 1 number of lines in title block + aspect 0.0 aspect ratio of viewport (0=dontcare) + + (the following are duplicated for the Y axis) + + xdrawaxes 3 draw X axis 1, 2, both (3), none (0) + xsetaxispos no set world coords of X axes + xaxispos1 0.0 world coord of X axis 1 (default wx1) + xaxispos2 0.0 world coord of X axis 2 (default wx2) + xdrawgrid yes draw grid marks connecting X ticks + xround no extend WCS to end at a tick mark + xlabelaxis yes draw axis label string if given + xaxislabelsize 1.0 character size for X axis label + xdrawticks yes draw and label X ticks + xlabelticks yes label X ticks + xnmajor 6 number of major ticks in X + xnminor 4 number of minor ticks in X + xmajorlength 0.8ch length of a major tick, X + xminorlength 0.4ch length of a minor tick, X + xmajorwidth 1.0 linewidth of a major tick, X + xminorwidth 1.0 linewidth of a minor tick, X + xaxiswidth 1.0 linewidth of the axis + xticklabelsize 1.0 character size for X tick labels + xtickformat "" override format for X tick labels +.fi + +.tp 4 +.nf + (read only variables) + + tty - pointer to TTY graphcap descriptor + fd - file descriptor of output stream + devname - device name as passed to gopen +.fi + + +The Y axis parameters have names equivalent to those shown with the +X prefix replaced by a Y. If the prefix is omitted entirely then the +parameters for both axes will be set or queried. +The \fBglabax\fR code and parameters are built upon the GIO graphics +primitives and may be replaced by a more sophisticated user program +if desired. + +Drawing and labeling of the X and Y axes is parameterized independently +in X and Y. If drawing and labeling of an axis is disabled, tick drawing +and labeling is automatically disabled. Drawing and labeling of an axis +may be disabled on only one side of the viewport (useful when a single viewport +is used simultaneously for two different world coordinate systems). +If tick drawing is disabled tick labeling is automatically disabled. +The tick marks, if drawn, may be connected by dotted lines within the +interior of the plot. + +Given the approximate number of major ticks, GIO will compute the nearest +number of tick marks resulting in round numbers for the tick mark labels. +If rounding is enabled the window will be enlarged to the nearest tick +outward on either end of an axis, otherwise an axis will end at the window +boundary, which need not fall on a tick mark. +If linear scaling is indicated \fInminor\fR minor ticks will be drawn +between each pair of major ticks. If log scaling is indicated the +\fInmajor\fR and \fInminor\fR parameters are ignored and +major ticks will be placed at powers of ten with eight minor ticks +(e.g., 2,3,4,5,6,7,8,9) between each pair of major ticks. +Tick lengths are given in NDC coordinates. The default tick lengths +are parameterized in terms of the character height for the device. + + +.nh 2 +Graphcap Parameters + + Each logical graphics device accessible to GIO must have an entry +in the \fBgraphcap\fR (graphics capabilities) file. The name of the +device entry in the graphcap file must agree with that specified in the +\fBgopen\fR call when the device is opened. Multiple logical device +entries may be given for a single physical device, each with slightly +different parameters. The name of the graphcap file is parameterized +by the CL environment variable "graphcap", making it easy for the user +to customize or extend the graphcap file. The graphcap entries for +common devices may be precompiled by the system manager to eliminate +the overhead of searching the graphcap file at run time. + +The format of the graphcap file is identical to that of a UNIX \fBtermcap\fR +file, and indeed the same interface (TTY) is used to access both types of files. +The set of capabilities defined for a graphics device is however quite +different than that defined for a terminal. Capabilities are typed +parameters referred to by a two character internal name. The restriction to +two characters is perhaps unfortunate but is desirable for efficiency reasons +(as well as for compatablity with the original termcap) and may be alleviated +at some point in the future by the use of macro defines. + +Graphcap parameters fall into two classes, those parameters which are +common to all devices, and those parameters which are required only for +devices accessed with a particular graphics kernel. GIO is capable +of supporting any number of quite different kernels, each of which may +support any number of devices. These kernels are free to add parameters +to their graphcap entries provided they do not conflict with the standard +parameters. An example is the "fast" or \fBstdgraph\fR kernel, discussed +in detail in a later section. If a device is to be accessed by more than +one kernel each kernel must typically have its own graphcap entry for the +device, with selection of the graphcap entry (logical device name) +specifying the kernel to be used. + +In the discussion which follows the reader is assumed to already be familiar +with the syntax and usage of \fBtermcap\fR format files. This is documented, +for example, in section 5 of the UNIX manuals. A sample termcap entry for +the devices "vt100-nam" and "vt100-am" is included below as an example of +a typical termcap entry. + + +.tp 5 +.nf +d1|vt100|vt100-nam|vt100 w/no am:\ + :am@:xn@:tc=vt100-am: +d0|vt100|vt100-am|vt100|dec vt100:\ + :cr=^M:do=^J:nl=^J:bl=^G:co#80:li#24:cl=50\E[;H\E[2J:\ + :le=^H:bs:am:cm=5\E[%i%d;%dH:nd=2\E[C:up=2\E[A:\ + :ce=3\E[K:cd=50\E[J:so=2\E[7m:se=2\E[m:us=2\E[4m:ue=2\E[m:\ + :md=2\E[1m:mr=2\E[7m:mb=2\E[5m:me=2\E[m:is=\E[1;24r\E[24;1H:\ + :rs=\E>\E[?3l\E[?4l\E[?5l\E[?7h\E[?8h:\ + :if=/usr/lib/tabset/vt100:ku=\EOA:kd=\EOB:kr=\EOC:kl=\EOD:kb=^H:\ + :ho=\E[H:k1=\EOP:k2=\EOQ:k3=\EOR:k4=\EOS:ta=^I:pt:sr=5\EM:vt#3:xn:\ + :k5=\EOp:k6=\EOx:k7=\EOr:k8=\EOm:k9=\EOl:k0=\EOq:\ + :sc=\E7:rc=\E8:cs=\E[%i%d;%dr:ks=\E[?1h\E=:ke=\E[?1l\E>: +.fi + + +Note that each device may be known by several names. The device capabilities +are delimited by colons, e.g., ":xx=...:yy=...:". The special capability "tc" +allows an entry to include another entry recursively. Escape is represented +as either "\E" or "^[", is "^H". If a delay of so many milliseconds +is required after transmission of a string, the number of milliseconds +appears as the first few chars in an entry, e.g., "cl=50..." causes a +delay of 50 milliseconds following a screen clear. Numeric capabilities are +prefaced by a sharp, e.g., ":co#80:" (screen has 80 columns). + + +.nh 3 +Generic GRAPHCAP Parameters + + To make the distinction between the generic and kernel graphcap parameters +clear and to eliminate the possibility of redefinitions, the generic +parameters have lower case names and the kernel parameters have upper case +names. Only the standard graphcap parameters should be accessed from within +applications programs. The standard parameters are listed and defined below. +These parameters should be included in the graphcap entry for every device. + +.ls 4 +.ls 15 ar real +Aspect ratio dY/dX, i.e., the ratio of the size of the device screen in Y to +that in X (equivalent to ys/xs). +.le +.ls ca bool +Device implements cellarray plotting in hardware, i.e, the \fIzr\fR greylevels +are displayed by the hardware rather than emulated by software in the kernel. +.le +.ls ch real +Height in NDC units of a character of size 1.0. +.le +.ls co int +Number of columns of text displayable on the device screen at character +size 1.0. +.le +.ls cw real +Width in NDC units of a character of size 1.0. +.le +.ls fa bool +Device implements fill area in hardware. +.le +.ls fs int +Number of fill area styles supported by the device. +.le +.ls in bool +Device supports at least one input function, i.e., cursor readback or cell +array input. +.le +.ls k1 int +Minimum possible key value in a cursor read. +.le +.ls k2 int +Maximum possible key value in a cursor read. +.le +.ls kf str +Filename of the executable graphics kernel file for the device. +If this is given as "cl", the kernel is assumed to be resident in the +CL process. Should be a virtual filename, e.g., "dev$x_device.e". +See also parameter \fItn\fR. +.le +.ls li int +Number of lines of text displayable on the device screen at character +size 1.0. +.le +.ls lt int +Number of linetypes supported by the device. +.le +.ls lw int +Number of linewidths supported by the device. +.le +.ls nc int +Number of cursors supported by the device. +.le +.ls nk int +Number of possible key values in a cursor read. +.le +.ls pl bool +Device implements polyline drawing in hardware. +.le +.ls pm bool +Device implements polymarker drawing in hardware. +.le +.ls ro bool +Device supports roam at the hardware level (used in cursor mode). +.le +.ls se bool +Device supports selective erase of portions of the screen. +.le +.ls tf int +Number of text fonts supported by the device. +.le +.ls th int +Number of text heights or sizes supported by the device. If absent or zero +it is assumed that characters may be freely scaled in size. If only a number +of discreet character sizes are available the sizes are given by the +parameters \fItN\fR. +.le +.ls tn str +Taskname, i.e., name of the logical task within the kernel file \fIkf\fR +to be run to exercise a kernel. +.le +.ls tq int +Number of text quality or precision levels supported by the device. +.le +.ls tN real +Sizes of the \fIth\fR possible character sizes, relative to a character +of size 1.0 (expands to the set of parameters t1,t2,...,tN). +.le +.ls tx bool +Device implements text generation in hardware. +.le +.ls wc bool +Reading the cursor implies a wait, i.e., a cursor read is triggered by +the user. +.le +.ls xr int +Device resolution in X. +.le +.ls xs real +Device scale in X, i.e., the width of the display area in meters. +.le +.ls yr int +Device resolution in Y. +.le +.ls ys real +Device scale in Y, i.e., the height of the display area in meters. +.le +.ls zo bool +Device supports zoom at the hardware level (used in cursor mode). +.le +.ls zr int +Device resolution in Z, i.e., the number of greylevels or colors displayable +at each point using the cell array primitive. +.le +.le + + +The graphcap parameters are accessed by name via \fBgget\fR calls. +For example, + + xr = ggetr (gp, "xr") + +would assign the value of the parameter "xr" into the local variable of +the same name. + +.nh 3 +STDGRAPH Graphcap Parameters + + The \fBstdgraph\fR kernel is the "fast" kernel, i.e., the graphics kernel +resident in the CL process. This kernel is capable of driving almost any +modern graphics terminals given only a graphcap entry for the device, +providing the graphics terminal is data driven and provides both character +and vector generation in hardware. + +.nh 4 +Classes of Parameters + + The stdgraph parameters fall into a number of classes which we shall +describe separately. An alphabetical summary of all parameters is given in +a later section. + +The open and close workstation sequences are sent to the device whenever the +workstation is activated (OW) or deactivated (CW), e.g., when the STDGRAPH +kernel receives the open workstation or close workstation directive, or when +the open workstation is explicitly deactivated and later reactivated by the +applications program. + +The primary function of the open and close workstation sequences is to +effect a mode switch from text mode to graphics mode and back again, +but the sequences may also contain instructions used only for initialization +or mode setting. For example, OW might initialize user defined line types +or enable the graphics board. The close string CW might disable the graphics +board and set the alpha cursor to a standard place on the screen. + +The graphics enable and disable strings (GE,GD) are sent to the terminal +by the STDGRAPH kernel when status line i/o occurs. The GD sequence should +clear the status line, leaving the terminal in status line mode, with the +text cursor positioned to the start of the status line. The GE sequence +restores the terminal to graphics mode, and is often the same as the OW +sequence. Note that GD should not cause the graphics frame to disappear, +as the status line is supposed to be visible at the same time as the plot. + +The status line is normally the line at the bottom of the screen. On terminals +with separate text and graphics memories which can both be displayed at the +same time, the status line is normally written into the text memory. If the +terminal has both text and graphics memories but can only display one at a time +the graphics memory should be used, provided the status line can be erased in +the graphics memory. If the graphics plane must be used but erase is not +possible, the best approach is probably to write successive lines of status +line text on top of the plot, starting at the upper left corner and advancing +downward for each line of output text (see the 4012 entry in dev$graphcap). + +The parameters X1, X2, Y1, and Y2 define the range of device coordinates +to be output. Normally these will span the full screen of the device, +but in general they may define any rectangular window on the device screen. +The fill area and font tables are array valued parameters mapping the GKI +fill area and font indices into device codes (if the device should happen +to support such niceties). + + +.ks +.nf + OW open (reactivate) workstation + IF initialization file, if OW string is large + CW close (deactivate) workstation + GE graphics enable (exit status line mode) + GD graphics disable (enter status line mode) + CL screen clear + LR load registers (see "binary encoding") + + X1,X2 range of device X coordinates + Y1,Y2 range of device Y coordinates +.fi +.ke + + +The set attribute parameters are format strings used to encode set attribute +commands, each of which has a single integer argument. The format string is +similar to a \fBprintf\fR format string with the addition of a notation for +binary encoding (described below). + + +.ks +.nf + TH(i) set text height + TC(i) set text color + TF(i) set text font + LT(i) set line type + LC(i) set line color + LW(i) set line width + MC(i) set marker color + FT(i) set fill area type + FC(i) set fill area color +.fi +.ke + + +Polyline generation, i.e., vector drawing, is more difficult to parameterize. +We assume that polylines, polymarkers, fill areas, etc. are all similar enough +to be described by the same coordinate encoding format, but we allow each +such instruction to have different head and tail strings. + +.ks +.nf + PL polyline flag + VS move start + VE move end + DS draw start + DE draw end + MS marker start + ME marker end + FS fillarea start + FE fillarea end + XY(i,j) coord format +.fi +.ke + + +A polyline command consists of a number of subcommands, as outlined in the +drawing below. The polyline is a move followed by one or more draws. +The polyline flag PL is set to indicate that multiple coordinate pairs +can be output between the DS and DE commands. If PL is false (or omitted) +each coordinate pair in the GKI polyline will be output surrounded by DS +and DE commands. The encoding of each coordinate pair is defined by the +parameter XY. + + +.ks +.nf + set attributes if necessary + move start + x, y + move end + draw start + x, y + ... + x, y + draw end +.fi +.ke + + +The polymarker and fillarea parameters are optional. The kernel will +emulate markers and fill area if not supported by the hardware. +Recall that GIO handles all mark drawing except GM_POINT (point mode), +hence sophisticated mark drawing facilities are not required. + +Text generation is handled by the kernel a character at a time. +If character up is 90 degrees and the path is to the right, the kernel +will assume that it can output a number of characters between a TS +and a TE. Otherwise each character will be output preceded by a TS +and followed by a TE. The TS parameter is a format string with two +arguments, the device coordinates of the lower left corner of the +character to be drawn. The encoding of these coordinates is defined +by the TS format string. It is possible to perform a coordinate +transformation using the binary encoding facilities, if such is necessary. +If characters are not addressed at the lower left corner an offset +may be applied to the given coordinates using the binary encoding +facilities. + + +.ks +.nf + TS(i,j) text start + TE text end +.fi +.ke + + +Cursor output is controlled by the parameter WC. +Cursor input is initiated by output of the sequence defined by the format RC. +RC has one integer argument, the number of the cursor to be read. +The UC capability, if defined, will cause the cursor position to be updated +(with WC) to the position at the last cursor read. This is desirable if the +device cannot maintain the cursor position, i.e., if unrelated graphics +output commands affect the cursor position as an unwanted side effect. + + +.ks +.nf + UC update cursor pos before read + WC(x,y,i) write cursor + RC(i) read cursor start + RE read cursor end + CN cursor value length + CD cursor value delimiter + SC scan cursor (-> x,y,key) +.fi +.ke + + +Following transmission of the RC sequence the kernel will read the +response as defined by the parameters CN and CD. At least one of CN or CD +must be given. If CN is given but not CD exactly CN characters will be +read. If CD is given then characters will be read until the delimiter string +is matched (and until at least CN characters have been read). If possible +a delimiter string should be specified to permit recovery from bad cursor +reads, e.g., when the user types something before the cursor is displayed. +When a satisfactory cursor response string has been obtained the format SC +will be used to decode the string into the output values X, Y, and KEY. +The RE sequence is transmitted once the cursor read has successfully +completed. + +.nh 4 +Binary Encoding + + Graphics devices vary widely in the techniques used to encode numeric +data such as a line type or color index, or the coordinate pairs of a +polyline. Our approach to the encoding problem is a generalization of the +\fBprintf\fR format string. The encoder is driven by a format string +taken from the graphcap entry for the device. A number of standard formats +are recognized with encoding provided internally for these standard formats +by the encoder. To permit encoding of special formats the encoder provides +a very general yet efficient RPN virtual machine capable of computing bit +patterns according to a user supplied program embedded in the format string. + +A format string is a sequence of ASCII characters. Any ASCII character, +including all control characters, is permitted in the string. +The significance of a character depends on the context in which it appears. +Initially characters are simply copied to the output. Three special +characters are recognized in \fBcopy mode\fR (excluding the characters +already counted as special by termcap): + + +.ks +.nf + ' escape next character (literal) + % begin a formatted output string + ( begin an executable expression +.fi +.ke + + +The encoder is a table driven interpreter which is programmed by the format +given in the graphcap file. Programming the encoder is rather +like programming in assembler or microcode (its fun but easy to screw up). +The encoder provides a set of 12 integer registers, an integer stack with a +capacity of 50 values, and a dozen or so instructions. It is fundamentally +assumed that the character set is ASCII (this is guaranteed by the IRAF +programming environment). + +Upon entry one or more of the registers 1 through 3 are initialized to the +values of the input arguments, leaving the remaining registers, i.e., R4-R9 +and R0 (R10) available for general use. Registers R11 and R12 are reserved +for internal use. +The interpreter is activated when an unescaped ( is encountered in the input. +In \fBexecute mode\fR the following characters have special meanings +(excluding :, ^, and \, which are special characters to termcap/TTY): + +.ks +.nf + ' escape next character (recognized everywhere) + % conventional formatted output + ) revert to copy mode + #nnn push signed decimal integer number nnn + $ switch case construct + . pop number from stack and place in output string + , get next character from input string and push on stack + & modulus (similar to AND of low bits) + + add (similar to OR) + - subtract (similar to AND) + * multiply (shift left if pwr of 2) + / divide (shift right if pwr of 2) + < less than (0=false, 1=true) + > greater than (0=false, 1=true) + = equals (0=false, 1=true) + ; branch if: ;. The ; is at offset=0. + 0-9 push contents of register 0 through 9 + !N pop stack into register N + !! generate a N millisecond delay, where N is on the stack +.fi +.ke + + +Any other character encountered in execute mode is interpreted as an integer +number and pushed on the stack. Hence, the character "@" is equivalent to +"#64", i.e., octal 100. A blank is the integer constant 40B. + +The output format directive % will format and output the number on the top +of the stack, popping the stack in the process. The format specification +may be any legal \fBprintf\fR format. The case construct is used to process +set attribute commands, e.g., set linetype 0, 1, 2, text size 1, 2, 3, etc, +and also provides a rudimentary conditional processing capability. The branch +if operator ; provides a rudimentary branching and looping capability. +Beware that sequences like "^N" and "\E" compile as a single character in +the format string. + +.nh 4 +Examples + + As a simple example consider the encoding of the ANSI command to set +the cursor of a nongraphics terminal. The required sequence is the +following: + + ESC [ line ; col H + +Assuming that the column number is designated as X and the line number as +Y, in registers 1 and 2 respectively, the format would be as follows +(the quotes are not part of the format): + + "\E[(2)%d;(1)%dH" + +Now assume that the output sequence is the same but the line and column +numbers are one-indexed while the terminal requires zero-indexed +coordinates: + + "\E[(2#1-)%d;(1#1-)%dH" + +Thus far the examples have been pretty trivial and do not warrant the +complexity of the RPN interpreter proposed here. For our next example +consider the encoding of a polyline coordinate pair for a Tektronix +compatible graphics terminal and for an AED512, two quite different +graphics terminals. The Tektronix format for encoding an (X,Y) coordinate +pair is as follows: + + +.ks +.nf + 0 1 YA Y9 Y8 Y7 Y6 + 1 1 Y5 Y4 Y3 Y2 Y1 + 0 1 XA X9 X8 X7 X6 + 1 0 X5 X4 X3 X2 X1 +.fi +.ke + + +Since the Tektronix device is so common the special format %t is provided +for encoding register 1 and 2 (X and Y) in this format, and writing out +the result. The format string + + "%t" + +is all that is required. The more general solution is provided by the +following format. + + "(2 / +.2 &`+.1 / +.1 &@+." + +To understand this last example one must look up the octal values of +the characters " " (40B), "`" (140B), and "@" (100B). The notation is +admittedly rather cryptic but it is also concise and efficient, and works +for a wide range of devices. + +Now consider the AED512 in binary mode (this is courtesy of NCAR; I do not +have access to such a terminal). The output encoding of a coordinate pair +is as follows: + + +.ks +.nf + XA X9 X8 YB YA Y9 Y8 + X7 X6 X5 X4 X3 X2 X1 + Y7 Y6 Y5 Y4 Y3 Y2 Y1 +.fi +.ke + + +The format required to generate this is shown below. Note the use of +register 9 to store the constant 200B. The "^N" signifies , +i.e., 16B, used to effect a left shift of four bits. + + "(#128!919/^N*29/+.19&.29&." + +This format could be further optimized by preloading register 9 at +\fBopenws\fR time by moving the "(#128!9" to parameter LR. The encoder +registers maintain their values indefinitely. Using LR the two parameters +might appear in the graphcap entry as follows. + + ":LR=(#128!9:XY=(19/^N*29/+.19&.29&.:" + +The case construct makes it possible to generate output conditionally based +on the value of an integer switch. The syntax of a case statement is as +follows: + + $1 ... $2-5 ... $6 ... $D ... $$ + +When the first $ is encountered the switch value is popped off the stack +and converted into a character by addition of the constant '0' (60B). +The interpreter will then scan forward until it finds the indicated case, +at which point it resumes execution in case mode. If the indicated case +is not found scanning will stop at $D (the default case) or $$, whichever +comes first. When the next $ is seen the interpreter skips forward until +it finds $$, which marks the end of the case. Case constructs are not +nestable. + +The case construct is used primarily for set attribute formats. +For example, the GKI linetype codes are integers greater than or equal to zero, +with case zero being the line clear and the other cases actual linetypes. +For the VT640 there are nine possible linetypes, i.e., line clear, +five builtin linetypes, and 3 user defined linetypes. The strings to be +output for the cases 0 through 5 are the following: + + +.ks +.nf + linetype string + + 0 ESC / 1 d ESC ` + 1 ESC / 0 d ESC ` + 2 ESC / 0 d ESC a + 3 ESC / 0 d ESC b + (etc) (etc) +.fi +.ke + + +We could encode linetypes 0, 1 through 5, and everything else with the +following format (linetype code in register 1): + + "\E/(1$0)0d\E`($1-5)1d\E(1_+.$D)0d\E`($$" + +Note that case searching is a simple string matching operation that ignores +operators such as ( and ). Only $, ' (escape), and EOS are recognized when +searching for a case. + +.nh 4 +Efficiency + + The interpreter approach to solving the general encoding problem +presented here is not the only solution to the problem. Before adopting +this approach several alternatives were considered. One such alternative +was the bitfield packing and unpacking scheme used by NCAR to solve the +same problem. The third alternative considered was to hand code a +subroutine for each encoding required for each device. Benchmarks run +to compare the three alternatives yielded the following times in +cpu seconds required to plot a 1000 point array with Tektronix encoding: + + +.ks +.nf + bitfields approximately 30 seconds + interpreter 0.82 - 2.0 seconds + hand coded 0.78 seconds (mostly i/o) +.fi +.ke + + +The time required for character output is included in the figures shown. +The bitfields benchmark is an extrapolation from an actual timing of the +prototype NCAR software as ported to the UNIX VAX by Cliff Stoll. +The GBYTE and SBYTE primitives used to implement bitfields in the NCAR +software were written in portable C by Cliff and did not use the VAX bitfield +instructions, which would have helped significantly (but which would not +have yielded a fair test: all IRAF target machines may not have bitfield +instructions). The two timings shown for the interpreter are for the "%t" +format and the general format. The clock time required by the hardware +(VT100 with VT640 retrographics board) to draw the vectors was about 7 seconds. + +We conclude that the execution time overhead of the interpreter for encoding +polyline points is acceptable and the use of hand coded, device dependent +procedures is neither warranted nor desirable. The bitfields technique +is too inefficient to use in a production interface. + +.nh 4 +Decoding Cursor Input + + Decoding of the cursor value string returned by the device into +X, Y, and KEY (keystroke) values is carried out using the table driven +interpreter for decoding rather than for encoding. In this mode characters +are input with "," and the decoded output values X, Y, and KEY are returned +in registers 1 through 3. The % format encoding operator is not used. +If the cursor value is returned in ASCII X and Y must be converted to +binary the hard way (e.g., "ch1 '0' - 100 * ch2 '0' - 10 * +", etc.). + +To verify that this scheme will work consider the cursor value returned +by a Tektronix compatible terminal. The return value is 6 characters, +consisting of the character typed followed by the encoded X and Y in +the next four characters, and lastly a CR terminator: + + +.ks +.nf + C7 C6 C5 C4 C3 C2 C1 + 0 1 XA X9 X8 X7 X6 + 0 1 X5 X4 X3 X2 X1 + 0 1 YA Y9 Y8 Y7 Y6 + 0 1 Y5 Y4 Y3 Y2 Y1 + 0 0 0 1 1 0 1 +.fi +.ke + + +The required decoding format is shown below. + + ",!3, & *, &+!1, & *, &+!2" + +.nh 4 +Summary of STDGRAPH Graphcap Parameters + + An alphabetical summary of the graphcap parameters used by the STDGRAPH +kernel is given below. + + +.tp 3 +.nf + CD cursor value delimiter + CL screen clear + CN cursor response length + CW close (deactivate) workstation + DE draw end + DS draw start + FC(i) set fill area color + FE fillarea end + FS fillarea start + FT(i) set fill area type + GD graphics disable (exit status line mode) + GE graphics enable (enter status line mode) + IF initialization file, if OP string is large + LC(i) set line color + LR load registers + LT(i) set line type + LW(i) set line width + MC(i) set marker color + ME marker end + MS marker start + OW open (reactivate) workstation + PL polyline flag + RC(i) read cursor start + RE read cursor end + SC scan cursor (-> x,y,key) + TC(i) set text color + TE text end + TF(i) set text font + TH(i) set text height + TS(i,j) text start + VE move end + VS move start + WC(x,y,i) write cursor + X1 first device X coordinate + X2 last device X coordinate + XY(i,j) coordinate format + Y1 first device Y coordinate + Y2 last device Y coordinate +.fi + + +As a final example, the actual graphcap entry for the vt640 terminal +(DEC VT100 with retrographics) is reproduced below. + + +.ks +.nf +vt640|vt640g|vt100 with Retrographics:\ + :RC=(1$2)^X\E[24;65H\E[7mLIGHT PEN READY\E[0m($$)^]\E"(1$2)5($D)4($$)g:\ + :WC=^]%t\E/f:OW=150^]^_:CW=^X\E[24;0H\E[K:GE=150^]^_:GD=^X\E[24;0H\E[K:\ + :lt#5:nc#2:se:CL=50^]\E^L:xr#640:yr#480:ar#.57:xs#.23:ys#.13:tc=4012: + +4012|tek4012|tektronix 4012:\ + :ar#.70:ch#.0294:co#80:cw#.0125:in:k1#1:k2#127:kf=cl:li#35:\ + :lt#5:nc#1:nk#127:pl:pm:th#4:t1#1:t2#2:t3#3:t4#4:tx:\ + :wc:xr#1024:yr#780:xs#.20:ys#.14:\ + :CD=^M:CN#6:LT=^]\E/(1$0)1d\E`($1-5)0d\E(1_+.$D)0d\E`($$:\ + :MS=\034:PL:RC=\E^Z:SC=(,!3, & *, &+!1, & *, &+!2:\ + :TH=\E(1#47+.:TS=^]%t^_:VS=^]:X1#0:X2#1023:XY=%t:Y1#0:Y2#779:\ + :OW=^]^_:CW=(#682!2#0!1)^]%t^_:GE=^]^_:\ + :CL=1000(#32!9)\E^L:\ + :LR=(#32!9:GD=(9#1-!99$0#31!9$$9#22*!2#0!1)^]%t^_: +.fi +.ke + +.NH 3 +TERMCAP and GRAPHCAP + + Every graphics terminal entry in the graphcap file should have a +corresponding terminal capability entry in the termcap file. When the user +sets the terminal type with the \fBstty\fR task in the CL, the termcap entry +tells whether or not the terminal supports vector graphics, and the value +of the \fBstdgraph\fR environment variable is set to "none" for a non-graphics +terminal, or to the graphcap name of the device for a graphics terminal. +For a terminal to be recognized by the system as a graphics terminal the +termcap entry must include the ":gd" capability. If the graphcap name for +the device is different than the termcap name then the form ":gd=gcname:" +should be used. + +For example, the minimal termcap entry for the vt640 graphics terminal would +be as follows. Note that it makes no sense to set the terminal type to +"vt100", since a standard vt100 does not support vector graphics. + +.ks +.nf + vt640|Retrographics enhanced VT100:\ + :gd:tc=vt100: +.fi +.ke + +The "gd" capability is not standard termcap, but will be ignored by non-IRAF +programs which do not recognize the capability. + +.nh 2 +Graphics Kernel Interface + + The graphics kernel interface (GKI) is the interface between GIO and the +underlying graphics kernel or kernels. The GKI is a data driven interface, +i.e., GIO communicates with the graphics kernel via bidirectional streams +of control instructions and data. The functionality assumed by the GKI is +simple enough to permit use of a variety of graphics kernels, e.g., the builtin +GIO kernel for interactive graphics terminals, GKS, CORE, NSPP, and so on. +To understand the level of functionality expected from the kernel we first +summarize the functions the kernel is \fInot\fR expected to perform, i.e., +the functions performed by GIO before output to the kernel: + +.ls 4 +.ls o +All WCS coordinate transformations and clipping at the viewport boundary. +The kernel sees only NDC coordinates. +.le +.ls o +Axis drawing and labeling. GIO processes a \fBglabax\fR call into a +sequence of polylines in NDC coordinates. +.le +.ls o +Mark drawing. GIO processes all mark drawing commands into polyline +instructions. +.le +.ls o +Move and draw commands. GIO processes all absolute and relative move and draw +commands into sequences of polyline instructions. +.le +.le + + +The main functions of the kernel are the control and attribute set functions, +set cursor, polyline, polymarker (GM_POINT only), text generation, fill area, +cell array, and cursor read. A kernel need not implement all such functions, +but it must at least recognize and ignore the corresponding GKI instructions. +The GKI kernel instructions are easily implemented for modern intelligent +graphics terminals. The fast kernel will let the terminal handle polyline +drawing, point mode polymarker drawing, dashed lines, and character generation. + +The GKI format is a sequence of variable length binary control and +output instructions. Each instruction consists of the beginning of instruction +sentinel (BOI), an integer binary opcode identifying the instruction, +an integer giving the length of the instruction in metacode words, +and an arbitrary number of parameter and data words. +The BOI word aids in the detection of and recovery from botched instructions, +e.g., if an interrupt occurs while writing an instruction. + + +.ks +.nf + \fBfield\fR \fBdescription\fR + + BOI beginning of instruction (magic value = 100000B) + opcode unique instruction identification code (1-27) + length length of entire of instruction in metacode + words (includes all four fields) + data variable length part of instruction +.fi + +.ce +Figure 3. GKI Instruction Format +.ke + + +The instruction format chosen for GKI is basically a direct mapping of the +required low level functions into binary opcodes. +Various standard formats were considered and rejected, +in particular the GKS VDM (virtual device metafile) format. +GKS VDM turned out to be far to complex to be worth using at this level +in the system. The GKS VDI format might have been better suited, +but I could not find any information describing this format +(my understanding was that, although there are numerous implementations of VDI, +there is no formal standard as yet). + +The GKI format may be extended at some point in the future to provide +a binary instruction for each procedure in the GKS Fortran binding. +This will make it possible for applications to use either GIO or GKS, +provided a GKS kernel is available. This will make it easier to +import applications which are already written to use GKS (alternatively a +mini-GKS might be built upon GIO, since the primitive functions are almost +identical). Since IRAF itself is transportable and it is desirable for IRAF +applications to have full access to the IRAF i/o facilities, new IRAF +applications are not being written with transport to another data reduction +system in mind. New IRAF applications will use only GIO whenever the +facilities provided by GIO are adequate. Applications which use only GIO +will continue to be usable with any graphics kernel. + +.nh 3 +GKI Instructions + + The GKI instruction stream transmitted between processes on the same or +compatible machines will be a sequence of SPP short integer metacode words. +The machine independent GKI metafile format will be the equivalent stream +encoded as 16 bit twos complement signed integer metacode words, blocked +1440 words per block, with conversion between the internal and external +metacode formats being provided by the IRAF MII (machine independent integer) +interface (MII takes care of byte swapping, etc.). GKI metafiles in MII +format will be easily read and written by different machines, offloading most +of the work to the graphics kernel on the reader machine. The GKI instruction +format is designed for maximum efficiency on modern minicomputers, i.e., +the internal format (SPP short integer) is an atomic datatype and no bit +operations are required to generate or interpret metacode. + +NDC coordinates (0.0 to 1.0) will be represented in GKI as integers in the +range 0-32767. Character data will be packed one 7 bit ASCII character per +metacode word. Floating point is required only for certain output attributes, +e.g., the linewidth and character height (size) scale factors. +To avoid the problems of machine dependent floating point formats we shall +represent the low precision real numbers by converting them to integer +metacode words scaled according to the following relation: + + I = int (R * 1E2) + +Specifications for the GKI metafile instructions follow. The datatype and +size of each field of the instruction is given in parenthesis. +The datatype "p" denotes a coordinate pair (x,y) of type (m,m), +where "m" denotes an NDC coordinate. + +The OPENWS instruction marks the start of an instruction stream or +\fBmetafile\fR for a particular device. +A subsequent CLOSEWS (or physical end of file) marks the end of a metafile. +An OPENWS in APPEND mode requires that GIO recall the WCS defined when the +device was last accessed. +A physical file may consist of any number of independent metafiles. +Although there is no explicit connection between OPENWS and screen clear +(CLEARWS), a screen clear is implied for some devices when opened in +new file mode. +The MFTITLE instruction is optional and is provided only for documenting +the contents of a metafile. + + +.ks +.nf + GKI_EOF = BOI 0 L + GKI_OPENWS = BOI 1 L M N D + GKI_CLOSEWS = BOI 2 L N D + GKI_REACTIVATEWS = BOI 3 L + GKI_DEACTIVATEWS = BOI 4 L + GKI_MFTITLE = BOI 5 L N T + GKI_CLEARWS = BOI 6 L + GKI_CANCEL = BOI 7 L + GKI_FLUSH = BOI 8 L + GKI_POLYLINE = BOI 9 L N P + GKI_POLYMARKER = BOI 10 L N P + GKI_TEXT = BOI 11 L P N T + GKI_FILLAREA = BOI 12 L N P + GKI_PUTCELLARRAY = BOI 13 L LL UR NC NL P + GKI_SETCURSOR = BOI 14 L CN POS + GKI_PLSET = BOI 15 L LT LW CI + GKI_PMSET = BOI 16 L MT MW CI + GKI_TXSET = BOI 17 L UP SZ SP P HJ VJ F Q CI + GKI_FASET = BOI 18 L FS CI + GKI_GETCURSOR = BOI 19 L CN + GKI_CURSORVALUE = BOI 19 L CN POS KEY + GKI_GETCELLARRAY = BOI 20 L LL UR NC NL + GKI_CELLARRAY = BOI 20 L NP P + GKI_ESCAPE = BOI 25 L FN N DC + GKI_SETWCS = BOI 26 L N WCS + GKI_GETWCS = BOI 27 L N +.fi + +.ce +The GKI Instruction Set +.ke + +.nh 4 +Control Instructions + + The NULL instruction is unique in that it consists of a single metacode +word with value zero. The BOI and length fields are omitted. Any number +of null words may be inserted between regular metacode instructions, e.g., +to pad a block of metacode to be written to an MII format metafile. +The EOF instruction is used internally by GIO to stop metacode translation +on a pseudofile stream, as if end of file had been encountered. + +The open workstation instruction should start a new frame unless the access +mode is APPEND, in which case graphics is to be added to the last frame. +An OPENWS implies an REACTIVATEWS. CLOSEWS does little more than deactivate +the workstation, since the last frame must in some sense remain open for +APPEND mode to be possible. Normal termination of the kernel process +will or an open workstation in a mode other than append will cause the last +frame to be terminated. + + +.ls +.tp 4 +GKI_EOF = BOI 0 L +.ls +.nf +L(i) 3 +.fi +.le + + +.tp 6 +GKI_OPENWS = BOI 1 L M N D +.ls +.nf +L(i) 5 + N +M(i) access mode (APPEND=4, NEW_FILE=5, TEE=6) +N(i) number of characters in field D +D(Nc) device name as in \fBgraphcap\fR file +.fi +.le + + +.tp 5 +GKI_CLOSEWS = BOI 2 L N D +.ls +.nf +L(i) 4 + N +N(i) number of characters in field D +D(Nc) device name as in \fBgraphcap\fR file +.fi +.le + + +.tp 5 +GKI_REACTIVATEWS = BOI 3 L +.ls +.nf +L(i) 3 +.fi +.le + + +.tp 5 +GKI_DEACTIVATEWS = BOI 4 L +.ls +.nf +L(i) 3 +.fi +.le + + +.tp 5 +.rj (optional) +GKI_MFTITLE = BOI 5 L N T +.ls +.nf +L(i) 4 + N +N(i) number of characters in field T +T(Nc) title string identifying metafile +.fi +.le + + +.tp 3 +GKI_CLEARWS = BOI 6 L +.ls +.nf +L(i) set to the constant 3 (no data fields) +.fi +.le + + +.tp 3 +GKI_CANCEL = BOI 7 L +.ls +.nf +L(i) set to the constant 3 (no data fields) +.fi +.le + + +.tp 3 +GKI_FLUSH = BOI 8 L +.ls +.nf +L(i) set to the constant 3 (no data fields) +.fi +.le +.le + +.nh 4 +Output Instructions + + All data points in the GKI output instructions have been transformed into +NDC coordinates and clipped at the viewport boundary (if clipping is enabled). +In the process GIO will translate any INDEF valued points by breaking large +polylines into smaller polylines, hence the semantics of plotting polylines and +polymarkers is quite simple at the graphics kernel level. + +CELLARRAY is processed into a series of one dimensional cell array instructions, +one for each line in the two dimensional array supplied by the user. Fewer or +shorter lines will be output if clipping is necessary. Arrays larger than 32767 +pixels may be output since each line is passed as a separate instruction. +The maximum number of lines and columns in a cell array is 32767 and 32761, +respectively (more lines can be input but they will not be resolved). +The kernel is expected to scale cell arrays to fit the output device via some +combination of pixel replication or subsampling, if there is not a one to one +correspondence between cell array pixels and device pixels. + +.ls +.tp 5 +GKI_POLYLINE = BOI 9 L N P +.ls +.nf +L(i) 4 + N * 2 +N(i) number of points in the polyline +P(Np) list of points (x,y pairs) +.fi +.le + + +.tp 5 +GKI_POLYMARKER = BOI 10 L N P +.ls +.nf +L(i) 4 + N * 2 +N(i) number of points in the polymarker +P(Np) list of points (x,y pairs) +.fi +.le + + +.tp 6 +GKI_TEXT = BOI 11 L P N T +.ls +.nf +L(i) 6 + N +P(p) starting point of character string +N(i) number of characters in string T +T(Nc) string of N ASCII characters +.fi +.le + + +.tp 5 +GKI_FILLAREA = BOI 12 L N P +.ls +.nf +L(i) 4 + (N * 2) +N(i) number of points defining the polygon to be filled +P(Np) list of points (x,y pairs) +.fi +.le + + +.tp 8 +GKI_PUTCELLARRAY = BOI 13 L LL UR NC NL P +.ls +.nf +L(i) 9 + (N * M) +LL(p) coordinates of lower left corner of output area +UR(p) coordinates of upper right corner of output area +NC(i) number of columns in array +NL(i) number of lines in array +P(NCNLi) array of color indices (pixels) stored by row +.fi +.le + + +.tp 5 +GKI_SETCURSOR = BOI 14 L CN POS +.ls +.nf +L(i) 6 +CN(i) cursor number +POS(p) new cursor position +.fi +.le +.le + +.nh 4 +Set Attribute Instructions + + The set polyline, polymarker, text, and fillarea instructions change +the attributes used to generate graphics output. These instructions need be +issued only when one of the attributes in an instruction packet changes, i.e., +the kernel is assumed to remember the attributes while a device is open. + +.ls +.tp 6 +GKI_PLSET = BOI 15 L LT LW CI +.ls +.nf +L(i) 6 +LT(i) linetype number +LW(r) linewidth scale factor +CI(i) polyline color index +.fi +.le + + +.tp 6 +GKI_PMSET = BOI 16 L MT MW CI +.ls +.nf +L(i) 6 +MT(i) marktype (not used at present) +MW(i) marksize, NDC coords (not used at present) +CI(i) marker color index +.fi +.le + + +.tp 9 +GKI_TXSET = BOI 17 L UP SZ SP P HJ VJ F Q CI +.ls +.nf +L(i) 12 +UP(i) character up vector (degrees) +SZ(r) character size scale factor +SP(r) character spacing +P(i) path (0,2=left,3=right,4=up,5=down) +HJ(i) horizontal justification + (0=normal,1=center,2=left,3=right) +VJ(i) vertical justification + (0=normal,1=center,6=top,7=bottom) +F(i) font (8=roman,9=greek,10=italic,11=bold) +Q(i) quality (0=normal,12=low,13=medium,14=high) +CI(i) text color index +.fi +.le + + +.tp 5 +GKI_FASET = BOI 18 L FS CI +.ls +.nf +L(i) 5 +FS(i) fill style (0=clear,1=hollow,2=solid,3-6=hatch) +CI(i) fill area color index +.fi +.le +.le + + +The attributes for the output primitives are assumed to be set to their +default values when OPENWS is issued. + +.nh 4 +Input Instructions + + The primary input instruction is the cursor read instruction, used to read +the cursor position in NDC coordinates. The device cursor read may be either +event driven or instantaneous. If the cursor read is event driven a nonzero +keystroke value may be returned, the range of possible keystroke values being +device dependent. The instantaneous type of cursor read is preferred at the +GKI level since it offers the maximum flexibility (\fBclgcur\fR may then be +used to provide an optional device independent keystroke driven cursor read). +Devices which support both forms of cursor read may provide both as separate +logical cursors. The graphics kernel should return a null cursor value if +the output device does not have a cursor. + +.ls +.tp 6 +GKI_GETCURSOR = BOI 19 L CN +.ls +.nf +L(i) 4 +CN(i) cursor number +.fi + +The kernel reads graphics cursor number CN and returns the keystroke value +(if any) and the cursor position in NDC coordinates. The cursor attributes +are returned in the following format: + + GKI_CURSORVALUE = BOI 19 L CN POS KEY + +where + +.nf + L(i) 7 + CN(i) cursor number + POS(r) NDC coordinates of cursor + KEY(i) keystroke value (>= 0 or EOF) +.fi +.le + + +.tp 8 +GKI_GETCELLARRAY = BOI 20 L LL UR NC NL +.ls +.nf +L(i) 9 +LL(p) coordinates of lower left corner of input area +UR(p) coordinates of upper right corner of input area +NC(i) number of columns in output array +NL(i) number of lines in output array +.fi + +The GETCELLARRAY instruction is the converse of the PUTCELLARRAY instruction. +The cell array is returned in the following format: + + GKI_CELLARRAY = BOI 20 L NP P + +where + +.nf + L(i) 4 + NP + NP(i) number of pixels (0 if noread) + P(NPi) array of pixels +.fi +.le + + +(instruction codes 19-24 are reserved for future use) +.le + +.nh 4 +Escape Instruction + + The escape instruction is used to pass device dependent information or +commands to the graphics kernel via GKI. The graphics kernel will ignore +unrecognized escape functions. Function codes 1 through 100 are reserved +for use by GIO. + +.ls +.tp 5 +GKI_ESCAPE = BOI 25 L FN N DC +.ls +.nf +L(i) 5 + N +FN(i) escape function code +N(i) number of escape data words +DC(i) escape data words +.fi +.le +.le + +.nh 4 +Pseudo-GKI Instructions + + Since the CL must be able to read the device cursor and convert NDC +coordinates to WCS coordinates, the WCS must be passed to the CL when they +are "fixed" to the device. The most natural and efficient way to do this +is via the GKI instruction stream, hence several additional instructions +are used internally in GIO to communicate with the portion of GIO resident +in the CL process. These instructions are filtered out and executed by the +CL process and their existence may therefore be ignored by the graphics kernels. + +The SETWCS instruction is used to pass WCS information to the CL process. +The GETWCS instruction is used to recall the WCS for a device opened in APPEND +mode (the WCS are returned in SETWCS format). Since these instructions +are passed only between two closely coupled processes on a single cpu, +floating point numbers are passed in machine dependent format. +The length of this instruction is machine dependent. +Only the fields L and WCS are truely part of the instruction; the remaining +fields are a binary copy of the GIO internal WCS structure. + +.ls +.tp 6 +GKI_SETWCS = BOI 26 L N WCS +.ls +.nf +L(i) 4 + 17 * sizeof (struct wcs) +N(i) length of WCS structure, words +WCS binary copy of the 17 WCS structures, transmitted + in a single call to WRITE +.fi +.le + + +.tp 5 +GKI_GETWCS = BOI 27 L N +.ls +.nf +L(i) 4 +N(i) maximum number of words to read +.fi +.le +.le + +.nh 3 +Encoding GKI Instructions + + The GKI instruction opcodes and fields are defined in the global include +file lib$gki.h. To avoid direct knowledge of the binary format of the GKI +instructions, GIO uses a subpackage called GKI to encode the GKI instructions. +The GKI procedures each encode and transmit a single GKI instruction on the +output stream. Although the GIO and GKI procedures have similar names, they +should not be confused. The GIO \fBgpline\fR, for example, performs conversion +from a WCS to GKI coordinates with clipping at the viewport boundary, checking +that the polyline attributes are up to date before transmitting the polyline +instruction. In contrast the GKI \fBgki_polyline\fR merely encodes and +transmits the GKI_POLYLINE metacode instruction. + +The GKI procedures are self contained with the exception of the set attribute +instructions, which reference attribute packet structures (argument \fIap\fR) +defined in the include file gio.h. +The GKI instruction encoding procedures are shown below. + +.ks +.nf + gki_openws (fd, device, mode) + gki_closews (fd, device) + gki_reactivatews (fd, flags) + gki_deactivatews (fd, flags) + gki_mftitle (fd, title) + gki_clearws (fd) + gki_cancel (fd) + gki_flush (fd) + gki_polyline (fd, points, npts) + gki_polymarker (fd, points, npts) + gki_text (fd, x, y, text) + gki_fillarea (fd, points, npts) + gki_getcellarray (fd, m, nx, ny, x1,y1, x2,y2) + gki_putcellarray (fd, m, nx, ny, x1,y1, x2,y2) + gki_plset (fd, ap) + gki_pmset (fd, ap) + gki_txset (fd, ap) + gki_faset (fd, ap) + gki_setcursor (fd, x, y, cursor) + gki_getcursor (fd, x, y, key, cursor) + gki_escape (fd, fn, instruction, nwords) + gki_setwcs (fd, wcsdata, len_wcsdata) + gki_getwcs (fd, wcsdata, len_wcsdata) + + gki_fflush (fd) # not GKI instruction; flushes GKI stream +.fi +.ke + + +.nh 3 +Decoding GKI Instructions + + The following additional procedures are provided for decoding and executing +GKI metacode, e.g., in a graphics kernel. In what follows, \fIinstruction\fR +is a short integer array containing the encoded GKI instruction, and \fIdd\fR +is the device driver table, i.e., array of \fBzlocpr\fR entry point addresses +of the standard kernel procedures. + + +.ks +.nf + stat = gki_fetch_next_instruction (fd, instruction_ptr) + gki_execute (instruction, dd) + gkp_install (dd, out_fd, verbose_output) +.fi +.ke + + +The \fBfetch\fR procedure extracts the next instruction from the input metacode +stream, returning a short integer pointer to the instruction as an output +argument. EOF is returned as the function value when end of file is detected. +The \fBexecute\fR procedure decodes an instruction and calls a graphics device +driver procedure to execute the instruction. If the entry point address +of the driver procedure is NULL \fBgki_execute\fR will ignore the corresponding +GKI instruction. The fields of the metacode instruction are passed to the +driver procedure as distinct arguments, hence the device driver need not +understand the GKI format. + +A standard kernel is provided for decoding GKI instructions, printing the +decoded instructions in text form on the output stream. The driver for this +kernel is installed with \fBgkp_install\fR, setting the output file and +verbose output flag in the process. + +.nh 3 +Example + + To illustrate the use of GKI as well as the output of the GKI decoding +kernel, consider the simple \fBgplotv\fR style plot of the following function: + + y = x ** 2 + +over the range + + x = 1 to 5, y = 1 to 25 + +The decoded GKI metacode produced by GIO to graph this function is +shown below. The "verbose" mode of output (shown) lists the values +of the data points in the polyline, etc. output functions. If verbose +output is disabled only the statistics of the output polylines +(computed by the decoder) will be printed. All coordinates are printed +in NDC units. The redundant points appearing in the output metacode +are expected to be filtered out by the kernel, which should not plot +points separated by less than the device resolution in NDC units. + + +.tp 4 +.nf +open_workstation 'vt640', mode=new_file +set_wcs nwords=352 + 1 1. 5. 1. 25. 0.19 0.81 0.33 0.96 0 0 1 +set_polyline ltype=1, lwidth=2.00, color=1 +polyline np=3, xmin=0.19,xmax=0.19,xavg=0.19, ymin=0.33,ymax=0.37,yavg=0.34 + 0.188 0.334 0.188 0.334 0.188 0.367 +set_text up=90, path=right, hjustify=center, vjustify=top, font=roman, + size=1.00, spacing=0.00, color=1, quality=normal +text 0.19, 0.31, '1' +polyline np=15, xmin=0.19,xmax=0.34,xavg=0.27, ymin=0.33,ymax=0.37,yavg=0.34 + 0.188 0.334 0.219 0.334 0.219 0.350 0.219 0.334 0.250 0.334 + 0.250 0.350 0.250 0.334 0.281 0.334 0.281 0.350 0.281 0.334 + 0.313 0.334 0.313 0.350 0.313 0.334 0.344 0.334 0.344 0.367 +text 0.34, 0.31, '2' +polyline np=15, xmin=0.34,xmax=0.50,xavg=0.43, ymin=0.33,ymax=0.37,yavg=0.34 + 0.344 0.334 0.375 0.334 0.375 0.350 0.375 0.334 0.406 0.334 + 0.406 0.350 0.406 0.334 0.437 0.334 0.437 0.350 0.437 0.334 + 0.469 0.334 0.469 0.350 0.469 0.334 0.500 0.334 0.500 0.367 +text 0.50, 0.31, '3' +polyline np=15, xmin=0.50,xmax=0.66,xavg=0.58, ymin=0.33,ymax=0.37,yavg=0.34 + 0.500 0.334 0.531 0.334 0.531 0.350 0.531 0.334 0.562 0.334 + 0.562 0.350 0.562 0.334 0.593 0.334 0.593 0.350 0.593 0.334 + 0.625 0.334 0.625 0.350 0.625 0.334 0.656 0.334 0.656 0.367 +text 0.66, 0.31, '4' +polyline np=15, xmin=0.66,xmax=0.81,xavg=0.74, ymin=0.33,ymax=0.37,yavg=0.34 + 0.656 0.334 0.687 0.334 0.687 0.350 0.687 0.334 0.718 0.334 + 0.718 0.350 0.718 0.334 0.750 0.334 0.750 0.350 0.750 0.334 + 0.781 0.334 0.781 0.350 0.781 0.334 0.812 0.334 0.812 0.367 +text 0.81, 0.31, '5' +polyline np=2, xmin=0.81,xmax=0.81,xavg=0.81, ymin=0.33,ymax=0.33,yavg=0.33 + 0.812 0.334 0.812 0.334 +polyline np=77, xmin=0.78,xmax=0.81,xavg=0.81, ymin=0.33,ymax=0.96,yavg=0.65 + 0.812 0.334 0.812 0.334 0.796 0.334 0.812 0.334 0.812 0.360 + 0.796 0.360 0.812 0.360 0.812 0.386 0.796 0.386 0.812 0.386 + 0.812 0.412 0.796 0.412 0.812 0.412 0.812 0.438 0.779 0.438 + 0.812 0.438 0.812 0.464 0.795 0.464 0.812 0.464 0.812 0.490 + 0.795 0.490 0.812 0.490 0.812 0.516 0.795 0.516 0.812 0.516 + 0.812 0.542 0.795 0.542 0.812 0.542 0.812 0.568 0.779 0.568 + 0.812 0.568 0.812 0.594 0.795 0.594 0.812 0.594 0.812 0.620 + 0.795 0.620 0.812 0.620 0.812 0.646 0.795 0.646 0.812 0.646 + 0.812 0.672 0.795 0.672 0.812 0.672 0.812 0.698 0.779 0.698 + 0.812 0.698 0.812 0.724 0.795 0.724 0.812 0.724 0.812 0.750 + 0.795 0.750 0.812 0.750 0.812 0.776 0.795 0.776 0.812 0.776 + 0.812 0.802 0.795 0.802 0.812 0.802 0.812 0.828 0.778 0.828 + 0.812 0.828 0.812 0.854 0.795 0.854 0.812 0.854 0.812 0.880 + 0.795 0.880 0.812 0.880 0.812 0.906 0.795 0.906 0.812 0.906 + 0.812 0.932 0.795 0.932 0.812 0.932 0.812 0.958 0.778 0.958 + 0.812 0.958 0.812 0.958 +polyline np=15, xmin=0.19,xmax=0.22,xavg=0.19, ymin=0.33,ymax=0.44,yavg=0.38 + 0.188 0.334 0.188 0.334 0.204 0.334 0.188 0.334 0.188 0.360 + 0.204 0.360 0.188 0.360 0.188 0.386 0.204 0.386 0.188 0.386 + 0.188 0.412 0.204 0.412 0.188 0.412 0.188 0.438 0.221 0.438 +set_text up=90, path=right, hjustify=right, vjustify=center, font=roman, + size=1.00, spacing=0.00, color=1, quality=normal +text 0.19, 0.44, '5' +polyline np=15, xmin=0.19,xmax=0.22,xavg=0.19, ymin=0.44,ymax=0.57,yavg=0.51 + 0.188 0.438 0.188 0.464 0.204 0.464 0.188 0.464 0.188 0.490 + 0.204 0.490 0.188 0.490 0.188 0.516 0.204 0.516 0.188 0.516 + 0.188 0.542 0.204 0.542 0.188 0.542 0.188 0.568 0.221 0.568 +text 0.19, 0.57, '10' +polyline np=15, xmin=0.19,xmax=0.22,xavg=0.19, ymin=0.57,ymax=0.70,yavg=0.64 + 0.188 0.568 0.188 0.594 0.204 0.594 0.188 0.594 0.188 0.620 + 0.204 0.620 0.188 0.620 0.188 0.646 0.204 0.646 0.188 0.646 + 0.188 0.672 0.204 0.672 0.188 0.672 0.188 0.698 0.221 0.698 +text 0.19, 0.70, '15' +polyline np=15, xmin=0.19,xmax=0.22,xavg=0.19, ymin=0.70,ymax=0.83,yavg=0.77 + 0.188 0.698 0.188 0.724 0.204 0.724 0.188 0.724 0.188 0.750 + 0.204 0.750 0.188 0.750 0.188 0.776 0.204 0.776 0.188 0.776 + 0.188 0.802 0.204 0.802 0.188 0.802 0.188 0.828 0.221 0.828 +text 0.19, 0.83, '20' +polyline np=15, xmin=0.19,xmax=0.22,xavg=0.19, ymin=0.83,ymax=0.96,yavg=0.90 + 0.188 0.828 0.188 0.854 0.204 0.854 0.188 0.854 0.188 0.880 + 0.204 0.880 0.188 0.880 0.188 0.906 0.204 0.906 0.188 0.906 + 0.188 0.932 0.204 0.932 0.188 0.932 0.188 0.958 0.221 0.958 +text 0.19, 0.96, '25' +polyline np=2, xmin=0.19,xmax=0.19,xavg=0.19, ymin=0.96,ymax=0.96,yavg=0.96 + 0.188 0.958 0.188 0.958 +polyline np=65, xmin=0.19,xmax=0.81,xavg=0.50, ymin=0.92,ymax=0.96,yavg=0.95 + 0.188 0.958 0.188 0.958 0.188 0.925 0.188 0.958 0.219 0.958 + 0.219 0.942 0.219 0.958 0.250 0.958 0.250 0.942 0.250 0.958 + 0.281 0.958 0.281 0.941 0.281 0.958 0.313 0.958 0.313 0.941 + 0.313 0.958 0.344 0.958 0.344 0.925 0.344 0.958 0.375 0.958 + 0.375 0.941 0.375 0.958 0.406 0.958 0.406 0.941 0.406 0.958 + 0.437 0.958 0.437 0.941 0.437 0.958 0.469 0.958 0.469 0.941 + 0.469 0.958 0.500 0.958 0.500 0.925 0.500 0.958 0.531 0.958 + 0.531 0.941 0.531 0.958 0.562 0.958 0.562 0.941 0.562 0.958 + 0.593 0.958 0.593 0.941 0.593 0.958 0.625 0.958 0.625 0.941 + 0.625 0.958 0.656 0.958 0.656 0.924 0.656 0.958 0.687 0.958 + 0.687 0.941 0.687 0.958 0.718 0.958 0.718 0.941 0.718 0.958 + 0.750 0.958 0.750 0.941 0.750 0.958 0.781 0.958 0.781 0.941 + 0.781 0.958 0.812 0.958 0.812 0.924 0.812 0.958 0.812 0.958 +set_text up=90, path=right, hjustify=center, vjustify=bottom, font=roman, + size=1.00, spacing=0.00, color=1, quality=normal +text 0.50, 0.96, 'title' +set_polyline ltype=1, lwidth=1.00, color=1 +polyline np=5, xmin=0.19,xmax=0.69,xavg=0.44, ymin=0.33,ymax=0.96,yavg=0.59 + 0.188 0.334 0.313 0.412 0.438 0.542 0.562 0.724 0.687 0.958 +flush +close_workstation 'vt640' +.fi + + +.nh 2 +Graphics Kernel Parameters + + The translation from GKI codes to device codes should ideally be +parameterized to permit variable device resolution, font substitution, +and so on at translation time. In general this is best handled by +spooling the metacode and later processing it via an explicit call to +a metacode translator program, using CL parameters to control the translation. +Some control over translation may also be achieved by modifying the +\fBgraphcap\fR entry for a device, provided the graphics kernel uses +the graphics capability database. + +One of the most useful translation time parameters is the device resolution. +On some devices, e.g. pen plotters, it is necessary to be able to change +the device resolution at translation time to permit plotting of large vectors +without loss of resolution. Changing the device resolution is also a valuable +technique for speeding up graphics when working remotely via a modem. + +.nh +GKS Emulation + + The basic graphics primitives provided by GIO (polyline, polymarker, etc.) +are functionally identical to those provided by GKS (the Graphics Kernel +System). The basic drawing primitives of GKS are therefore easily emulated +using GIO. A subset of the Fortran binding of GKS has already been emulated, +sufficient to run the NCAR utilities recently converted by NCAR for use with +GKS. In principle it should be possible to expand the GKS emulation to a +full level 0b or 1b interface, although we have no plans to do so at present. diff --git a/sys/gio/elogd.x b/sys/gio/elogd.x new file mode 100644 index 00000000..b910a80c --- /dev/null +++ b/sys/gio/elogd.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ELOGD -- Extended range log function. Logarithmic scaling function for +# negative or partially negative data. The function is piecewise, continuous, +# monotonic, reasonably smooth, and most importantly, is defined for all x. +# +# 10.0 < X y = log(x) +# -10.0 <= X <= 10.0 y = x / 10.0 +# X < -10.0 y = -log(-x) +# +# Axes scaled with this function should have ticks labelled, e.g., 10**3, +# 10**2, 10**1, 0, -10**1, -10**2, -10**3. The corresponding ticks for +# the normal log function would have values like 10**-2 rather than -10**2, +# hence it is not difficult to distinguish between the two functions. + +double procedure elogd (x) + +double x + +begin + if (x > 10.0D0) + return (log10 (x)) + else if (x >= -10.0D0) + return (x / 10.0D0) + else + return (-log10 (-x)) +end diff --git a/sys/gio/elogr.x b/sys/gio/elogr.x new file mode 100644 index 00000000..3dfb26ee --- /dev/null +++ b/sys/gio/elogr.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ELOGR -- Extended range log function. Logarithmic scaling function for +# negative or partially negative data. The function is piecewise, continuous, +# monotonic, reasonably smooth, and most importantly, is defined for all x. +# +# 10.0 < X y = log(x) +# -10.0 <= X <= 10.0 y = x / 10.0 +# X < -10.0 y = -log(-x) +# +# Axes scaled with this function should have ticks labelled, e.g., 10**3, +# 10**2, 10**1, 0, -10**1, -10**2, -10**3. The corresponding ticks for +# the normal log function would have values like 10**-2 rather than -10**2, +# hence it is not difficult to distinguish between the two functions. + +real procedure elogr (x) + +real x + +begin + if (x > 10.0) + return (log10 (x)) + else if (x >= -10.0) + return (x / 10.0) + else + return (-log10 (-x)) +end diff --git a/sys/gio/fonts/README b/sys/gio/fonts/README new file mode 100644 index 00000000..8b657b76 --- /dev/null +++ b/sys/gio/fonts/README @@ -0,0 +1,42 @@ + +FONT Generation Utilities (August 1997) +---------------------------------------- + +This directory contains utilities for building font tables for the GIO +system executables. For reference we include here the font tables for +the standard and greek fonts currently installed in the system: + + font.com standard text font (Roman) + greek.com greek character font + +These table were built from the Hershey stroke data using the following +files: + + mkfont.c task to build font table + hershey.dat Hershey stroke data table + +Once compiled the MKFONT task can be used to build the table with a command +such as + + % mkfont < romant.txt > font.com + +Note that by default the tables are created with a "chr" prefix for the +index, width, and character tables in the .com file. When building a new +Greek or other symbolic font these should be changed appropriately. + + +Addition input files for fonts supplied here include: + + futural.txt Futura (light) + futuram.txt Futura (medium) + gotheng.txt Gothic (english) + gothger.txt Gothic (german) + gothita.txt Gothic (italian) + greekc.txt Greek (complex) (current greek.com) + greeks.txt Greek (simple) + math.txt Math symbols + meteor.txt Meteorological symbols + romans.txt Roman (simple) + romant.txt Roman (Times) (current font.com) + scripts.txt Script text font + timesr.txt Times-Roman diff --git a/sys/gio/fonts/font.com b/sys/gio/fonts/font.com new file mode 100644 index 00000000..c26af8d6 --- /dev/null +++ b/sys/gio/fonts/font.com @@ -0,0 +1,746 @@ +# CHRTAB -- Table of strokes for the printable ASCII characters. Each +# character is encoded as a series of strokes. Each stroke is ex- +# pressed by a single integer containing the following bitfields: +# +# 2 1 +# 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 +# | | | | | | | +# | | | +---------+ +---------+ +# | | | | | +# | | | X Y +# | | | +# | | +-- pen up/down +# | +---- begin paint (not used at present) +# +------ end paint (not used at present) +# +#---------------------------------------------------------------------------- + +# Define the database. + +short chridx[97] # character index in chrtab +short chrwid[97] # character width table +short chrtab[3363] # stroke data to draw the characters + +# Index into CHRTAB of each printable character (starting with SP) + +data (chridx(i), i=001,005) / 1, 3, 32, 49, 58/ +data (chridx(i), i=006,010) / 110, 140, 207, 228, 253/ +data (chridx(i), i=011,015) / 278, 309, 322, 343, 350/ +data (chridx(i), i=016,020) / 365, 372, 418, 438, 494/ +data (chridx(i), i=021,025) / 563, 583, 632, 696, 733/ +data (chridx(i), i=026,030) / 803, 867, 896, 931, 935/ +data (chridx(i), i=031,035) / 948, 952, 999, 1052, 1077/ +data (chridx(i), i=036,040) / 1139, 1174, 1223, 1281, 1330/ +data (chridx(i), i=041,045) / 1381, 1436, 1463, 1500, 1547/ +data (chridx(i), i=046,050) / 1583, 1626, 1653, 1703, 1748/ +data (chridx(i), i=051,055) / 1818, 1881, 1923, 1962, 1997/ +data (chridx(i), i=056,060) / 2021, 2060, 2097, 2131, 2160/ +data (chridx(i), i=061,065) / 2169, 2172, 2181, 2190, 2193/ +data (chridx(i), i=066,070) / 2214, 2263, 2303, 2335, 2378/ +data (chridx(i), i=071,075) / 2415, 2447, 2527, 2575, 2606/ +data (chridx(i), i=076,080) / 2640, 2682, 2704, 2778, 2826/ +data (chridx(i), i=081,085) / 2868, 2916, 2961, 2994, 3033/ +data (chridx(i), i=086,090) / 3052, 3086, 3108, 3140, 3173/ +data (chridx(i), i=091,095) / 3204, 3233, 3271, 3274, 3312/ +data (chridx(i), i=096,096) / 3335/ + + +# Width data. + +data (chrwid(i), i=001,005) / 21, 16, 23, 26, 25/ +data (chrwid(i), i=006,010) / 29, 31, 16, 19, 19/ +data (chrwid(i), i=011,015) / 21, 30, 16, 30, 16/ +data (chrwid(i), i=016,020) / 28, 25, 25, 25, 25/ +data (chrwid(i), i=021,025) / 25, 25, 25, 25, 25/ +data (chrwid(i), i=026,030) / 25, 16, 16, 29, 30/ +data (chrwid(i), i=031,035) / 29, 24, 32, 25, 27/ +data (chrwid(i), i=036,040) / 26, 27, 26, 25, 28/ +data (chrwid(i), i=041,045) / 29, 17, 21, 27, 23/ +data (chrwid(i), i=046,050) / 31, 29, 27, 27, 27/ +data (chrwid(i), i=051,055) / 27, 25, 25, 29, 25/ +data (chrwid(i), i=056,060) / 29, 25, 27, 25, 19/ +data (chrwid(i), i=061,065) / 19, 19, 21, 21, 16/ +data (chrwid(i), i=066,070) / 25, 26, 24, 26, 24/ +data (chrwid(i), i=071,075) / 19, 24, 28, 17, 18/ +data (chrwid(i), i=076,080) / 27, 17, 32, 28, 25/ +data (chrwid(i), i=081,085) / 26, 25, 22, 22, 20/ +data (chrwid(i), i=086,090) / 28, 23, 29, 25, 24/ +data (chrwid(i), i=091,095) / 23, 19, 13, 19, 29/ +data (chrwid(i), i=096,096) / 19/ + + +# Stroke data. + +data (chrtab(i), i=0001,0005) / 35, 0, 220, 4251, 4249/ +data (chrtab(i), i=0006,0010) / 4305, 220, 4302, 4366, 220/ +data (chrtab(i), i=0011,0015) / 4380, 4366, 284, 4443, 4441/ +data (chrtab(i), i=0016,0020) / 4369, 202, 4233, 4232, 4295/ +data (chrtab(i), i=0021,0025) / 4359, 4424, 4425, 4362, 4298/ +data (chrtab(i), i=0026,0030) / 201, 4296, 4360, 4361, 4297/ +data (chrtab(i), i=0031,0035) / 0, 220, 4251, 4245, 219/ +data (chrtab(i), i=0036,0040) / 4245, 220, 4379, 4245, 796/ +data (chrtab(i), i=0041,0045) / 4827, 4821, 795, 4821, 796/ +data (chrtab(i), i=0046,0050) / 4955, 4821, 0, 604, 4224/ +data (chrtab(i), i=0051,0055) / 988, 4608, 145, 5137, 75/ +data (chrtab(i), i=0056,0060) / 5067, 0, 416, 4483, 672/ +data (chrtab(i), i=0061,0065) / 4739, 919, 5016, 4952, 4950/ +data (chrtab(i), i=0066,0070) / 5078, 5080, 5018, 4955, 4764/ +data (chrtab(i), i=0071,0075) / 4508, 4315, 4185, 4182, 4244/ +data (chrtab(i), i=0076,0080) / 4434, 4816, 4943, 5005, 5002/ +data (chrtab(i), i=0081,0085) / 4936, 150, 4308, 4435, 4817/ +data (chrtab(i), i=0086,0090) / 4944, 5006, 219, 4249, 4247/ +data (chrtab(i), i=0091,0095) / 4309, 4436, 4818, 5008, 5070/ +data (chrtab(i), i=0096,0100) / 5067, 5001, 4936, 4743, 4487/ +data (chrtab(i), i=0101,0105) / 4296, 4233, 4171, 4173, 4301/ +data (chrtab(i), i=0106,0110) / 4299, 4235, 4236, 0, 1244/ +data (chrtab(i), i=0111,0115) / 4167, 412, 4634, 4632, 4566/ +data (chrtab(i), i=0116,0120) / 4437, 4309, 4183, 4185, 4251/ +data (chrtab(i), i=0121,0125) / 4380, 4508, 4635, 4826, 5018/ +data (chrtab(i), i=0126,0130) / 5211, 5340, 974, 4941, 4875/ +data (chrtab(i), i=0131,0135) / 4873, 4999, 5127, 5256, 5322/ +data (chrtab(i), i=0136,0140) / 5324, 5198, 5070, 0, 1299/ +data (chrtab(i), i=0141,0145) / 5396, 5332, 5330, 5458, 5460/ +data (chrtab(i), i=0146,0150) / 5397, 5333, 5268, 5202, 5069/ +data (chrtab(i), i=0151,0155) / 4938, 4808, 4679, 4423, 4296/ +data (chrtab(i), i=0156,0160) / 4234, 4237, 4303, 4691, 4821/ +data (chrtab(i), i=0161,0165) / 4887, 4889, 4827, 4700, 4571/ +data (chrtab(i), i=0166,0170) / 4505, 4502, 4563, 4688, 4939/ +data (chrtab(i), i=0171,0175) / 5128, 5255, 5383, 5449, 5450/ +data (chrtab(i), i=0176,0180) / 264, 4298, 4301, 4367, 4432/ +data (chrtab(i), i=0181,0185) / 725, 4889, 791, 4827, 475/ +data (chrtab(i), i=0186,0190) / 4503, 468, 4689, 4940, 5129/ +data (chrtab(i), i=0191,0195) / 5256, 455, 4424, 4362, 4365/ +data (chrtab(i), i=0196,0200) / 4431, 4691, 409, 4565, 4753/ +data (chrtab(i), i=0201,0205) / 5004, 5193, 5320, 5384, 5449/ +data (chrtab(i), i=0206,0210) / 0, 346, 4377, 4313, 4250/ +data (chrtab(i), i=0211,0215) / 4251, 4316, 4380, 4443, 4440/ +data (chrtab(i), i=0216,0220) / 4374, 4245, 219, 4314, 4378/ +data (chrtab(i), i=0221,0225) / 4379, 4315, 281, 4440, 346/ +data (chrtab(i), i=0226,0230) / 4374, 0, 544, 4510, 4379/ +data (chrtab(i), i=0231,0235) / 4247, 4178, 4174, 4233, 4357/ +data (chrtab(i), i=0236,0240) / 4482, 4608, 282, 4311, 4243/ +data (chrtab(i), i=0241,0245) / 4237, 4297, 4358, 414, 4444/ +data (chrtab(i), i=0246,0250) / 4377, 4307, 4301, 4359, 4420/ +data (chrtab(i), i=0251,0255) / 4482, 0, 160, 4382, 4507/ +data (chrtab(i), i=0256,0260) / 4631, 4690, 4686, 4617, 4485/ +data (chrtab(i), i=0261,0265) / 4354, 4224, 410, 4567, 4627/ +data (chrtab(i), i=0266,0270) / 4621, 4553, 4486, 286, 4444/ +data (chrtab(i), i=0271,0275) / 4505, 4563, 4557, 4487, 4420/ +data (chrtab(i), i=0276,0280) / 4354, 0, 412, 4443, 4561/ +data (chrtab(i), i=0281,0285) / 4496, 412, 4496, 412, 4571/ +data (chrtab(i), i=0286,0290) / 4433, 4496, 89, 4249, 4755/ +data (chrtab(i), i=0291,0295) / 4819, 89, 4819, 89, 4184/ +data (chrtab(i), i=0296,0300) / 4820, 4819, 729, 4761, 4243/ +data (chrtab(i), i=0301,0305) / 4179, 729, 4179, 729, 4824/ +data (chrtab(i), i=0306,0310) / 4180, 4179, 0, 665, 4744/ +data (chrtab(i), i=0311,0315) / 4808, 665, 4825, 4808, 145/ +data (chrtab(i), i=0316,0320) / 5329, 5328, 145, 4240, 5328/ +data (chrtab(i), i=0321,0325) / 0, 328, 4359, 4295, 4232/ +data (chrtab(i), i=0326,0330) / 4233, 4298, 4362, 4425, 4422/ +data (chrtab(i), i=0331,0335) / 4356, 4227, 201, 4296, 4360/ +data (chrtab(i), i=0336,0340) / 4361, 4297, 263, 4422, 328/ +data (chrtab(i), i=0341,0345) / 4356, 0, 145, 5329, 5328/ +data (chrtab(i), i=0346,0350) / 145, 4240, 5328, 0, 202/ +data (chrtab(i), i=0351,0355) / 4233, 4232, 4295, 4359, 4424/ +data (chrtab(i), i=0356,0360) / 4425, 4362, 4298, 201, 4296/ +data (chrtab(i), i=0361,0365) / 4360, 4361, 4297, 0, 1184/ +data (chrtab(i), i=0366,0370) / 4096, 4160, 1184, 5344, 4160/ +data (chrtab(i), i=0371,0375) / 0, 476, 4379, 4248, 4179/ +data (chrtab(i), i=0376,0380) / 4176, 4235, 4360, 4551, 4679/ +data (chrtab(i), i=0381,0385) / 4872, 5003, 5072, 5075, 5016/ +data (chrtab(i), i=0386,0390) / 4891, 4700, 4572, 282, 4312/ +data (chrtab(i), i=0391,0395) / 4244, 4239, 4299, 4361, 777/ +data (chrtab(i), i=0396,0400) / 4939, 5007, 5012, 4952, 4890/ +data (chrtab(i), i=0401,0405) / 476, 4443, 4377, 4308, 4303/ +data (chrtab(i), i=0406,0410) / 4362, 4424, 4551, 583, 4808/ +data (chrtab(i), i=0411,0415) / 4874, 4943, 4948, 4889, 4827/ +data (chrtab(i), i=0416,0420) / 4700, 0, 474, 4551, 538/ +data (chrtab(i), i=0421,0425) / 4616, 604, 4679, 604, 4505/ +data (chrtab(i), i=0426,0430) / 4376, 199, 4935, 456, 4423/ +data (chrtab(i), i=0431,0435) / 457, 4487, 585, 4743, 584/ +data (chrtab(i), i=0436,0440) / 4807, 0, 152, 4247, 4311/ +data (chrtab(i), i=0441,0445) / 4312, 4248, 153, 4313, 4376/ +data (chrtab(i), i=0446,0450) / 4375, 4310, 4246, 4183, 4184/ +data (chrtab(i), i=0451,0455) / 4250, 4315, 4508, 4764, 4955/ +data (chrtab(i), i=0456,0460) / 5018, 5080, 5078, 5012, 4818/ +data (chrtab(i), i=0461,0465) / 4496, 4367, 4237, 4170, 4167/ +data (chrtab(i), i=0466,0470) / 858, 5016, 5014, 4948, 668/ +data (chrtab(i), i=0471,0475) / 4891, 4952, 4950, 4884, 4754/ +data (chrtab(i), i=0476,0480) / 4496, 73, 4234, 4362, 4681/ +data (chrtab(i), i=0481,0485) / 4937, 5066, 266, 4680, 4936/ +data (chrtab(i), i=0486,0490) / 5001, 266, 4679, 4935, 5000/ +data (chrtab(i), i=0491,0495) / 5066, 5068, 0, 152, 4247/ +data (chrtab(i), i=0496,0500) / 4311, 4312, 4248, 153, 4313/ +data (chrtab(i), i=0501,0505) / 4376, 4375, 4310, 4246, 4183/ +data (chrtab(i), i=0506,0510) / 4184, 4250, 4315, 4508, 4764/ +data (chrtab(i), i=0511,0515) / 4955, 5017, 5014, 4948, 4755/ +data (chrtab(i), i=0516,0520) / 795, 4953, 4950, 4884, 604/ +data (chrtab(i), i=0521,0525) / 4827, 4889, 4886, 4820, 4691/ +data (chrtab(i), i=0526,0530) / 467, 4755, 4882, 5008, 5070/ +data (chrtab(i), i=0531,0535) / 5067, 5001, 4936, 4743, 4487/ +data (chrtab(i), i=0536,0540) / 4296, 4233, 4171, 4172, 4237/ +data (chrtab(i), i=0541,0545) / 4301, 4364, 4363, 4298, 4234/ +data (chrtab(i), i=0546,0550) / 848, 5006, 5003, 4937, 595/ +data (chrtab(i), i=0551,0555) / 4818, 4881, 4942, 4939, 4872/ +data (chrtab(i), i=0556,0560) / 4743, 140, 4235, 4299, 4300/ +data (chrtab(i), i=0561,0565) / 4236, 0, 601, 4679, 666/ +data (chrtab(i), i=0566,0570) / 4744, 732, 4807, 732, 4109/ +data (chrtab(i), i=0571,0575) / 5133, 391, 4999, 584, 4551/ +data (chrtab(i), i=0576,0580) / 585, 4615, 713, 4871, 712/ +data (chrtab(i), i=0581,0585) / 4935, 0, 220, 4178, 4308/ +data (chrtab(i), i=0586,0590) / 4501, 4693, 4884, 5010, 5071/ +data (chrtab(i), i=0591,0595) / 5069, 5002, 4872, 4679, 4487/ +data (chrtab(i), i=0596,0600) / 4296, 4233, 4171, 4172, 4237/ +data (chrtab(i), i=0601,0605) / 4301, 4364, 4363, 4298, 4234/ +data (chrtab(i), i=0606,0610) / 850, 5008, 5004, 4938, 597/ +data (chrtab(i), i=0611,0615) / 4820, 4883, 4944, 4940, 4873/ +data (chrtab(i), i=0616,0620) / 4808, 4679, 140, 4235, 4299/ +data (chrtab(i), i=0621,0625) / 4300, 4236, 220, 4956, 219/ +data (chrtab(i), i=0626,0630) / 4827, 218, 4570, 4827, 4956/ +data (chrtab(i), i=0631,0635) / 0, 793, 4888, 4952, 4953/ +data (chrtab(i), i=0636,0640) / 4889, 858, 4890, 4825, 4824/ +data (chrtab(i), i=0641,0645) / 4887, 4951, 5016, 5017, 4955/ +data (chrtab(i), i=0646,0650) / 4828, 4636, 4443, 4313, 4247/ +data (chrtab(i), i=0651,0655) / 4179, 4173, 4234, 4360, 4551/ +data (chrtab(i), i=0656,0660) / 4679, 4872, 5002, 5069, 5070/ +data (chrtab(i), i=0661,0665) / 5009, 4883, 4692, 4564, 4435/ +data (chrtab(i), i=0666,0670) / 4370, 4304, 281, 4311, 4243/ +data (chrtab(i), i=0671,0675) / 4237, 4298, 4361, 842, 5004/ +data (chrtab(i), i=0676,0680) / 5007, 4945, 540, 4507, 4442/ +data (chrtab(i), i=0681,0685) / 4376, 4308, 4301, 4362, 4424/ +data (chrtab(i), i=0686,0690) / 4551, 583, 4808, 4873, 4940/ +data (chrtab(i), i=0691,0695) / 4943, 4882, 4819, 4692, 0/ +data (chrtab(i), i=0696,0700) / 92, 4182, 988, 5081, 5014/ +data (chrtab(i), i=0701,0705) / 4753, 4687, 4619, 4615, 592/ +data (chrtab(i), i=0706,0710) / 4622, 4555, 4551, 918, 4689/ +data (chrtab(i), i=0711,0715) / 4558, 4491, 4487, 4615, 88/ +data (chrtab(i), i=0716,0720) / 4250, 4380, 4508, 4825, 4953/ +data (chrtab(i), i=0721,0725) / 5018, 5084, 218, 4379, 4507/ +data (chrtab(i), i=0726,0730) / 4634, 88, 4249, 4378, 4506/ +data (chrtab(i), i=0731,0735) / 4825, 0, 412, 4315, 4249/ +data (chrtab(i), i=0736,0740) / 4246, 4308, 4499, 4755, 4948/ +data (chrtab(i), i=0741,0745) / 5014, 5017, 4955, 4764, 4508/ +data (chrtab(i), i=0746,0750) / 283, 4313, 4310, 4372, 788/ +data (chrtab(i), i=0751,0755) / 4950, 4953, 4891, 412, 4443/ +data (chrtab(i), i=0756,0760) / 4377, 4374, 4436, 4499, 659/ +data (chrtab(i), i=0761,0765) / 4820, 4886, 4889, 4827, 4764/ +data (chrtab(i), i=0766,0770) / 403, 4306, 4241, 4175, 4171/ +data (chrtab(i), i=0771,0775) / 4233, 4296, 4487, 4743, 4936/ +data (chrtab(i), i=0776,0780) / 5001, 5067, 5071, 5009, 4946/ +data (chrtab(i), i=0781,0785) / 4755, 209, 4239, 4235, 4297/ +data (chrtab(i), i=0786,0790) / 841, 5003, 5007, 4945, 403/ +data (chrtab(i), i=0791,0795) / 4370, 4303, 4299, 4360, 4487/ +data (chrtab(i), i=0796,0800) / 647, 4872, 4939, 4943, 4882/ +data (chrtab(i), i=0801,0805) / 4755, 0, 203, 4298, 4362/ +data (chrtab(i), i=0806,0810) / 4363, 4299, 851, 4881, 4816/ +data (chrtab(i), i=0811,0815) / 4687, 4559, 4368, 4242, 4181/ +data (chrtab(i), i=0816,0820) / 4182, 4249, 4379, 4572, 4700/ +data (chrtab(i), i=0821,0825) / 4891, 5017, 5078, 5072, 5004/ +data (chrtab(i), i=0826,0830) / 4938, 4808, 4615, 4423, 4296/ +data (chrtab(i), i=0831,0835) / 4234, 4235, 4300, 4364, 4427/ +data (chrtab(i), i=0836,0840) / 4426, 4361, 4297, 210, 4244/ +data (chrtab(i), i=0841,0845) / 4247, 4313, 794, 4953, 5014/ +data (chrtab(i), i=0846,0850) / 5008, 4940, 4874, 463, 4432/ +data (chrtab(i), i=0851,0855) / 4369, 4308, 4311, 4378, 4443/ +data (chrtab(i), i=0856,0860) / 4572, 604, 4827, 4889, 4950/ +data (chrtab(i), i=0861,0865) / 4943, 4875, 4809, 4744, 4615/ +data (chrtab(i), i=0866,0870) / 0, 213, 4244, 4243, 4306/ +data (chrtab(i), i=0871,0875) / 4370, 4435, 4436, 4373, 4309/ +data (chrtab(i), i=0876,0880) / 212, 4307, 4371, 4372, 4308/ +data (chrtab(i), i=0881,0885) / 202, 4233, 4232, 4295, 4359/ +data (chrtab(i), i=0886,0890) / 4424, 4425, 4362, 4298, 201/ +data (chrtab(i), i=0891,0895) / 4296, 4360, 4361, 4297, 0/ +data (chrtab(i), i=0896,0900) / 213, 4244, 4243, 4306, 4370/ +data (chrtab(i), i=0901,0905) / 4435, 4436, 4373, 4309, 212/ +data (chrtab(i), i=0906,0910) / 4307, 4371, 4372, 4308, 328/ +data (chrtab(i), i=0911,0915) / 4359, 4295, 4232, 4233, 4298/ +data (chrtab(i), i=0916,0920) / 4362, 4425, 4422, 4356, 4227/ +data (chrtab(i), i=0921,0925) / 201, 4296, 4360, 4361, 4297/ +data (chrtab(i), i=0926,0930) / 263, 4422, 328, 4356, 0/ +data (chrtab(i), i=0931,0935) / 1177, 4240, 5255, 0, 149/ +data (chrtab(i), i=0936,0940) / 5333, 5332, 149, 4244, 5332/ +data (chrtab(i), i=0941,0945) / 141, 5325, 5324, 141, 4236/ +data (chrtab(i), i=0946,0950) / 5324, 0, 153, 5264, 4231/ +data (chrtab(i), i=0951,0955) / 0, 151, 4248, 4312, 4310/ +data (chrtab(i), i=0956,0960) / 4182, 4184, 4250, 4315, 4444/ +data (chrtab(i), i=0961,0965) / 4700, 4891, 4954, 5016, 5014/ +data (chrtab(i), i=0966,0970) / 4948, 4883, 4625, 794, 4953/ +data (chrtab(i), i=0971,0975) / 4949, 4884, 604, 4827, 4889/ +data (chrtab(i), i=0976,0980) / 4885, 4819, 4754, 465, 4558/ +data (chrtab(i), i=0981,0985) / 4622, 4625, 4561, 458, 4489/ +data (chrtab(i), i=0986,0990) / 4488, 4551, 4615, 4680, 4681/ +data (chrtab(i), i=0991,0995) / 4618, 4554, 457, 4552, 4616/ +data (chrtab(i), i=0996,1000) / 4617, 4553, 0, 1044, 5078/ +data (chrtab(i), i=1001,1005) / 4951, 4759, 4630, 4565, 4498/ +data (chrtab(i), i=1006,1010) / 4495, 4557, 4684, 4876, 5005/ +data (chrtab(i), i=1011,1015) / 5071, 663, 4629, 4562, 4559/ +data (chrtab(i), i=1016,1020) / 4621, 4684, 1047, 5071, 5069/ +data (chrtab(i), i=1021,1025) / 5196, 5324, 5454, 5521, 5523/ +data (chrtab(i), i=1026,1030) / 5462, 5400, 5274, 5147, 4956/ +data (chrtab(i), i=1031,1035) / 4764, 4571, 4442, 4312, 4246/ +data (chrtab(i), i=1036,1040) / 4179, 4176, 4237, 4299, 4425/ +data (chrtab(i), i=1041,1045) / 4552, 4743, 4935, 5128, 5257/ +data (chrtab(i), i=1046,1050) / 5322, 1111, 5135, 5133, 5196/ +data (chrtab(i), i=1051,1055) / 0, 540, 4168, 473, 4935/ +data (chrtab(i), i=1056,1060) / 537, 4999, 540, 5063, 205/ +data (chrtab(i), i=1061,1065) / 4877, 7, 4423, 647, 5191/ +data (chrtab(i), i=1066,1070) / 72, 4103, 72, 4295, 840/ +data (chrtab(i), i=1071,1075) / 4807, 841, 4871, 905, 5127/ +data (chrtab(i), i=1076,1080) / 0, 220, 4295, 283, 4360/ +data (chrtab(i), i=1081,1085) / 348, 4423, 28, 4892, 5083/ +data (chrtab(i), i=1086,1090) / 5146, 5208, 5206, 5140, 5075/ +data (chrtab(i), i=1091,1095) / 4882, 986, 5144, 5142, 5076/ +data (chrtab(i), i=1096,1100) / 796, 5019, 5081, 5077, 5011/ +data (chrtab(i), i=1101,1105) / 4882, 338, 4882, 5073, 5136/ +data (chrtab(i), i=1106,1110) / 5198, 5195, 5129, 5064, 4871/ +data (chrtab(i), i=1111,1115) / 4103, 976, 5134, 5131, 5065/ +data (chrtab(i), i=1116,1120) / 786, 5009, 5071, 5066, 5000/ +data (chrtab(i), i=1121,1125) / 4871, 92, 4315, 156, 4314/ +data (chrtab(i), i=1126,1130) / 412, 4442, 476, 4443, 200/ +data (chrtab(i), i=1131,1135) / 4167, 201, 4231, 329, 4487/ +data (chrtab(i), i=1136,1140) / 328, 4551, 0, 985, 5148/ +data (chrtab(i), i=1141,1145) / 5142, 5081, 4955, 4828, 4636/ +data (chrtab(i), i=1146,1150) / 4443, 4313, 4247, 4180, 4175/ +data (chrtab(i), i=1151,1155) / 4236, 4298, 4424, 4615, 4807/ +data (chrtab(i), i=1156,1160) / 4936, 5066, 5132, 281, 4311/ +data (chrtab(i), i=1161,1165) / 4244, 4239, 4300, 4362, 540/ +data (chrtab(i), i=1166,1170) / 4507, 4376, 4308, 4303, 4363/ +data (chrtab(i), i=1171,1175) / 4488, 4615, 0, 220, 4295/ +data (chrtab(i), i=1176,1180) / 283, 4360, 348, 4423, 28/ +data (chrtab(i), i=1181,1185) / 4764, 4955, 5081, 5143, 5204/ +data (chrtab(i), i=1186,1190) / 5199, 5132, 5066, 4936, 4743/ +data (chrtab(i), i=1191,1195) / 4103, 921, 5079, 5140, 5135/ +data (chrtab(i), i=1196,1200) / 5068, 5002, 668, 4891, 5016/ +data (chrtab(i), i=1201,1205) / 5076, 5071, 5003, 4872, 4743/ +data (chrtab(i), i=1206,1210) / 92, 4315, 156, 4314, 412/ +data (chrtab(i), i=1211,1215) / 4442, 476, 4443, 200, 4167/ +data (chrtab(i), i=1216,1220) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=1221,1225) / 4551, 0, 220, 4295, 283/ +data (chrtab(i), i=1226,1230) / 4360, 348, 4423, 28, 5148/ +data (chrtab(i), i=1231,1235) / 5142, 338, 4818, 726, 4814/ +data (chrtab(i), i=1236,1240) / 7, 5127, 5133, 92, 4315/ +data (chrtab(i), i=1241,1245) / 156, 4314, 412, 4442, 476/ +data (chrtab(i), i=1246,1250) / 4443, 732, 5147, 860, 5146/ +data (chrtab(i), i=1251,1255) / 924, 5145, 988, 5142, 726/ +data (chrtab(i), i=1256,1260) / 4754, 4814, 724, 4690, 4816/ +data (chrtab(i), i=1261,1265) / 723, 4562, 4817, 200, 4167/ +data (chrtab(i), i=1266,1270) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=1271,1275) / 4551, 711, 5128, 839, 5129/ +data (chrtab(i), i=1276,1280) / 903, 5130, 967, 5133, 0/ +data (chrtab(i), i=1281,1285) / 220, 4295, 283, 4360, 348/ +data (chrtab(i), i=1286,1290) / 4423, 28, 5148, 5142, 338/ +data (chrtab(i), i=1291,1295) / 4818, 726, 4814, 7, 4615/ +data (chrtab(i), i=1296,1300) / 92, 4315, 156, 4314, 412/ +data (chrtab(i), i=1301,1305) / 4442, 476, 4443, 732, 5147/ +data (chrtab(i), i=1306,1310) / 860, 5146, 924, 5145, 988/ +data (chrtab(i), i=1311,1315) / 5142, 726, 4754, 4814, 724/ +data (chrtab(i), i=1316,1320) / 4690, 4816, 723, 4562, 4817/ +data (chrtab(i), i=1321,1325) / 200, 4167, 201, 4231, 329/ +data (chrtab(i), i=1326,1330) / 4487, 328, 4551, 0, 985/ +data (chrtab(i), i=1331,1335) / 5148, 5142, 5081, 4955, 4828/ +data (chrtab(i), i=1336,1340) / 4636, 4443, 4313, 4247, 4180/ +data (chrtab(i), i=1341,1345) / 4175, 4236, 4298, 4424, 4615/ +data (chrtab(i), i=1346,1350) / 4807, 4936, 5064, 5127, 5135/ +data (chrtab(i), i=1351,1355) / 281, 4311, 4244, 4239, 4300/ +data (chrtab(i), i=1356,1360) / 4362, 540, 4507, 4376, 4308/ +data (chrtab(i), i=1361,1365) / 4303, 4363, 4488, 4615, 974/ +data (chrtab(i), i=1366,1370) / 5065, 911, 5001, 4936, 719/ +data (chrtab(i), i=1371,1375) / 5327, 783, 5006, 847, 5005/ +data (chrtab(i), i=1376,1380) / 1103, 5133, 1167, 5134, 0/ +data (chrtab(i), i=1381,1385) / 220, 4295, 283, 4360, 348/ +data (chrtab(i), i=1386,1390) / 4423, 988, 5063, 1051, 5128/ +data (chrtab(i), i=1391,1395) / 1116, 5191, 28, 4636, 796/ +data (chrtab(i), i=1396,1400) / 5404, 338, 5074, 7, 4615/ +data (chrtab(i), i=1401,1405) / 775, 5383, 92, 4315, 156/ +data (chrtab(i), i=1406,1410) / 4314, 412, 4442, 476, 4443/ +data (chrtab(i), i=1411,1415) / 860, 5083, 924, 5082, 1180/ +data (chrtab(i), i=1416,1420) / 5210, 1244, 5211, 200, 4167/ +data (chrtab(i), i=1421,1425) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=1426,1430) / 4551, 968, 4935, 969, 4999/ +data (chrtab(i), i=1431,1435) / 1097, 5255, 1096, 5319, 0/ +data (chrtab(i), i=1436,1440) / 220, 4295, 283, 4360, 348/ +data (chrtab(i), i=1441,1445) / 4423, 28, 4636, 7, 4615/ +data (chrtab(i), i=1446,1450) / 92, 4315, 156, 4314, 412/ +data (chrtab(i), i=1451,1455) / 4442, 476, 4443, 200, 4167/ +data (chrtab(i), i=1456,1460) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=1461,1465) / 4551, 0, 476, 4555, 4488/ +data (chrtab(i), i=1466,1470) / 4423, 539, 4619, 4552, 604/ +data (chrtab(i), i=1471,1475) / 4683, 4616, 4423, 4295, 4168/ +data (chrtab(i), i=1476,1480) / 4106, 4108, 4173, 4237, 4300/ +data (chrtab(i), i=1481,1485) / 4299, 4234, 4170, 76, 4171/ +data (chrtab(i), i=1486,1490) / 4235, 4236, 4172, 284, 4892/ +data (chrtab(i), i=1491,1495) / 348, 4571, 412, 4570, 668/ +data (chrtab(i), i=1496,1500) / 4698, 732, 4699, 0, 220/ +data (chrtab(i), i=1501,1505) / 4295, 283, 4360, 348, 4423/ +data (chrtab(i), i=1506,1510) / 1051, 4432, 530, 5063, 594/ +data (chrtab(i), i=1511,1515) / 5127, 596, 5191, 28, 4636/ +data (chrtab(i), i=1516,1520) / 860, 5340, 7, 4615, 775/ +data (chrtab(i), i=1521,1525) / 5319, 92, 4315, 156, 4314/ +data (chrtab(i), i=1526,1530) / 412, 4442, 476, 4443, 988/ +data (chrtab(i), i=1531,1535) / 5147, 1180, 5147, 200, 4167/ +data (chrtab(i), i=1536,1540) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=1541,1545) / 4551, 969, 4935, 969, 5255/ +data (chrtab(i), i=1546,1550) / 0, 220, 4295, 283, 4360/ +data (chrtab(i), i=1551,1555) / 348, 4423, 28, 4636, 7/ +data (chrtab(i), i=1556,1560) / 5063, 5069, 92, 4315, 156/ +data (chrtab(i), i=1561,1565) / 4314, 412, 4442, 476, 4443/ +data (chrtab(i), i=1566,1570) / 200, 4167, 201, 4231, 329/ +data (chrtab(i), i=1571,1575) / 4487, 328, 4551, 647, 5064/ +data (chrtab(i), i=1576,1580) / 775, 5065, 839, 5066, 903/ +data (chrtab(i), i=1581,1585) / 5069, 0, 220, 4296, 220/ +data (chrtab(i), i=1586,1590) / 4743, 284, 4746, 348, 4810/ +data (chrtab(i), i=1591,1595) / 1116, 4743, 1116, 5191, 1179/ +data (chrtab(i), i=1596,1600) / 5256, 1244, 5319, 28, 4444/ +data (chrtab(i), i=1601,1605) / 1116, 5532, 7, 4487, 903/ +data (chrtab(i), i=1606,1610) / 5511, 92, 4315, 1308, 5338/ +data (chrtab(i), i=1611,1615) / 1372, 5339, 200, 4167, 200/ +data (chrtab(i), i=1616,1620) / 4423, 1096, 5063, 1097, 5127/ +data (chrtab(i), i=1621,1625) / 1225, 5383, 1224, 5447, 0/ +data (chrtab(i), i=1626,1630) / 220, 4296, 220, 5191, 284/ +data (chrtab(i), i=1631,1635) / 5130, 348, 5194, 1115, 5191/ +data (chrtab(i), i=1636,1640) / 28, 4444, 924, 5404, 7/ +data (chrtab(i), i=1641,1645) / 4487, 92, 4315, 988, 5211/ +data (chrtab(i), i=1646,1650) / 1244, 5211, 200, 4167, 200/ +data (chrtab(i), i=1651,1655) / 4423, 0, 540, 4443, 4313/ +data (chrtab(i), i=1656,1660) / 4247, 4179, 4176, 4236, 4298/ +data (chrtab(i), i=1661,1665) / 4424, 4615, 4743, 4936, 5066/ +data (chrtab(i), i=1666,1670) / 5132, 5200, 5203, 5143, 5081/ +data (chrtab(i), i=1671,1675) / 4955, 4764, 4636, 281, 4311/ +data (chrtab(i), i=1676,1680) / 4244, 4239, 4300, 4362, 906/ +data (chrtab(i), i=1681,1685) / 5068, 5135, 5140, 5079, 5017/ +data (chrtab(i), i=1686,1690) / 540, 4507, 4376, 4308, 4303/ +data (chrtab(i), i=1691,1695) / 4363, 4488, 4615, 647, 4872/ +data (chrtab(i), i=1696,1700) / 5003, 5071, 5076, 5016, 4891/ +data (chrtab(i), i=1701,1705) / 4764, 0, 220, 4295, 283/ +data (chrtab(i), i=1706,1710) / 4360, 348, 4423, 28, 4892/ +data (chrtab(i), i=1711,1715) / 5083, 5146, 5208, 5205, 5139/ +data (chrtab(i), i=1716,1720) / 5074, 4881, 4433, 986, 5144/ +data (chrtab(i), i=1721,1725) / 5141, 5075, 796, 5019, 5081/ +data (chrtab(i), i=1726,1730) / 5076, 5010, 4881, 7, 4615/ +data (chrtab(i), i=1731,1735) / 92, 4315, 156, 4314, 412/ +data (chrtab(i), i=1736,1740) / 4442, 476, 4443, 200, 4167/ +data (chrtab(i), i=1741,1745) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=1746,1750) / 4551, 0, 540, 4443, 4313/ +data (chrtab(i), i=1751,1755) / 4247, 4179, 4176, 4236, 4298/ +data (chrtab(i), i=1756,1760) / 4424, 4615, 4743, 4936, 5066/ +data (chrtab(i), i=1761,1765) / 5132, 5200, 5203, 5143, 5081/ +data (chrtab(i), i=1766,1770) / 4955, 4764, 4636, 281, 4311/ +data (chrtab(i), i=1771,1775) / 4244, 4239, 4300, 4362, 906/ +data (chrtab(i), i=1776,1780) / 5068, 5135, 5140, 5079, 5017/ +data (chrtab(i), i=1781,1785) / 540, 4507, 4376, 4308, 4303/ +data (chrtab(i), i=1786,1790) / 4363, 4488, 4615, 647, 4872/ +data (chrtab(i), i=1791,1795) / 5003, 5071, 5076, 5016, 4891/ +data (chrtab(i), i=1796,1800) / 4764, 330, 4492, 4621, 4685/ +data (chrtab(i), i=1801,1805) / 4812, 4874, 4932, 4994, 5122/ +data (chrtab(i), i=1806,1810) / 5188, 5190, 838, 4996, 5059/ +data (chrtab(i), i=1811,1815) / 5123, 778, 4997, 5060, 5124/ +data (chrtab(i), i=1816,1820) / 5189, 0, 220, 4295, 283/ +data (chrtab(i), i=1821,1825) / 4360, 348, 4423, 28, 4892/ +data (chrtab(i), i=1826,1830) / 5083, 5146, 5208, 5206, 5140/ +data (chrtab(i), i=1831,1835) / 5075, 4882, 4434, 986, 5144/ +data (chrtab(i), i=1836,1840) / 5142, 5076, 796, 5019, 5081/ +data (chrtab(i), i=1841,1845) / 5077, 5011, 4882, 594, 4817/ +data (chrtab(i), i=1846,1850) / 4879, 5001, 5063, 5191, 5257/ +data (chrtab(i), i=1851,1855) / 5259, 907, 5065, 5128, 5192/ +data (chrtab(i), i=1856,1860) / 721, 4880, 5066, 5129, 5193/ +data (chrtab(i), i=1861,1865) / 5258, 7, 4615, 92, 4315/ +data (chrtab(i), i=1866,1870) / 156, 4314, 412, 4442, 476/ +data (chrtab(i), i=1871,1875) / 4443, 200, 4167, 201, 4231/ +data (chrtab(i), i=1876,1880) / 329, 4487, 328, 4551, 0/ +data (chrtab(i), i=1881,1885) / 921, 5084, 5078, 5017, 4891/ +data (chrtab(i), i=1886,1890) / 4700, 4508, 4315, 4185, 4182/ +data (chrtab(i), i=1891,1895) / 4244, 4434, 4816, 4943, 5005/ +data (chrtab(i), i=1896,1900) / 5002, 4936, 150, 4308, 4435/ +data (chrtab(i), i=1901,1905) / 4817, 4944, 5006, 219, 4249/ +data (chrtab(i), i=1906,1910) / 4247, 4309, 4436, 4818, 5008/ +data (chrtab(i), i=1911,1915) / 5070, 5067, 5001, 4936, 4743/ +data (chrtab(i), i=1916,1920) / 4551, 4360, 4234, 4173, 4167/ +data (chrtab(i), i=1921,1925) / 4234, 0, 28, 4118, 476/ +data (chrtab(i), i=1926,1930) / 4551, 539, 4616, 604, 4679/ +data (chrtab(i), i=1931,1935) / 1052, 5142, 28, 5148, 263/ +data (chrtab(i), i=1936,1940) / 4871, 92, 4118, 156, 4121/ +data (chrtab(i), i=1941,1945) / 220, 4122, 348, 4123, 732/ +data (chrtab(i), i=1946,1950) / 5147, 860, 5146, 924, 5145/ +data (chrtab(i), i=1951,1955) / 988, 5142, 456, 4423, 457/ +data (chrtab(i), i=1956,1960) / 4487, 585, 4743, 584, 4807/ +data (chrtab(i), i=1961,1965) / 0, 220, 4301, 4362, 4488/ +data (chrtab(i), i=1966,1970) / 4679, 4807, 5000, 5130, 5197/ +data (chrtab(i), i=1971,1975) / 5211, 283, 4364, 4426, 348/ +data (chrtab(i), i=1976,1980) / 4428, 4489, 4552, 4679, 28/ +data (chrtab(i), i=1981,1985) / 4636, 924, 5404, 92, 4315/ +data (chrtab(i), i=1986,1990) / 156, 4314, 412, 4442, 476/ +data (chrtab(i), i=1991,1995) / 4443, 988, 5211, 1244, 5211/ +data (chrtab(i), i=1996,2000) / 0, 92, 4615, 156, 4618/ +data (chrtab(i), i=2001,2005) / 4615, 220, 4682, 987, 4615/ +data (chrtab(i), i=2006,2010) / 28, 4508, 732, 5212, 28/ +data (chrtab(i), i=2011,2015) / 4250, 284, 4314, 348, 4315/ +data (chrtab(i), i=2016,2020) / 860, 5083, 1052, 5083, 0/ +data (chrtab(i), i=2021,2025) / 156, 4487, 220, 4492, 4487/ +data (chrtab(i), i=2026,2030) / 284, 4556, 668, 4556, 4487/ +data (chrtab(i), i=2031,2035) / 668, 4999, 732, 5004, 4999/ +data (chrtab(i), i=2036,2040) / 796, 5068, 1179, 5068, 4999/ +data (chrtab(i), i=2041,2045) / 28, 4572, 668, 4892, 988/ +data (chrtab(i), i=2046,2050) / 5468, 28, 4315, 92, 4314/ +data (chrtab(i), i=2051,2055) / 348, 4378, 412, 4379, 1052/ +data (chrtab(i), i=2056,2060) / 5275, 1308, 5275, 0, 92/ +data (chrtab(i), i=2061,2065) / 4935, 156, 4999, 220, 5063/ +data (chrtab(i), i=2066,2070) / 923, 4232, 28, 4508, 732/ +data (chrtab(i), i=2071,2075) / 5212, 7, 4423, 647, 5191/ +data (chrtab(i), i=2076,2080) / 28, 4314, 284, 4314, 348/ +data (chrtab(i), i=2081,2085) / 4315, 796, 5019, 1052, 5019/ +data (chrtab(i), i=2086,2090) / 136, 4103, 136, 4359, 840/ +data (chrtab(i), i=2091,2095) / 4807, 841, 4871, 841, 5127/ +data (chrtab(i), i=2096,2100) / 0, 92, 4625, 4615, 156/ +data (chrtab(i), i=2101,2105) / 4689, 4680, 220, 4753, 4743/ +data (chrtab(i), i=2106,2110) / 1051, 4753, 28, 4508, 860/ +data (chrtab(i), i=2111,2115) / 5340, 327, 4935, 28, 4251/ +data (chrtab(i), i=2116,2120) / 348, 4315, 924, 5147, 1180/ +data (chrtab(i), i=2121,2125) / 5147, 520, 4487, 521, 4551/ +data (chrtab(i), i=2126,2130) / 649, 4807, 648, 4871, 0/ +data (chrtab(i), i=2131,2135) / 988, 4188, 4182, 860, 4167/ +data (chrtab(i), i=2136,2140) / 924, 4231, 988, 4295, 71/ +data (chrtab(i), i=2141,2145) / 5063, 5069, 156, 4182, 220/ +data (chrtab(i), i=2146,2150) / 4185, 284, 4186, 412, 4187/ +data (chrtab(i), i=2151,2155) / 647, 5064, 775, 5065, 839/ +data (chrtab(i), i=2156,2160) / 5066, 903, 5069, 0, 160/ +data (chrtab(i), i=2161,2165) / 4224, 224, 4288, 160, 4704/ +data (chrtab(i), i=2166,2170) / 128, 4672, 0, 28, 4868/ +data (chrtab(i), i=2171,2175) / 0, 480, 4544, 544, 4608/ +data (chrtab(i), i=2176,2180) / 96, 4640, 64, 4608, 0/ +data (chrtab(i), i=2181,2185) / 278, 4505, 4630, 83, 4504/ +data (chrtab(i), i=2186,2190) / 4819, 408, 4487, 0, 5/ +data (chrtab(i), i=2191,2195) / 4997, 0, 348, 4315, 4249/ +data (chrtab(i), i=2196,2200) / 4246, 4309, 4373, 4438, 4439/ +data (chrtab(i), i=2201,2205) / 4376, 4312, 4247, 215, 4310/ +data (chrtab(i), i=2206,2210) / 4374, 4375, 4311, 219, 4247/ +data (chrtab(i), i=2211,2215) / 153, 4312, 0, 210, 4307/ +data (chrtab(i), i=2216,2220) / 4371, 4369, 4241, 4243, 4308/ +data (chrtab(i), i=2221,2225) / 4437, 4693, 4820, 4883, 4945/ +data (chrtab(i), i=2226,2230) / 4938, 5000, 5063, 723, 4881/ +data (chrtab(i), i=2231,2235) / 4874, 4936, 597, 4756, 4818/ +data (chrtab(i), i=2236,2240) / 4810, 4872, 5063, 5127, 720/ +data (chrtab(i), i=2241,2245) / 4751, 4430, 4237, 4171, 4170/ +data (chrtab(i), i=2246,2250) / 4232, 4423, 4615, 4744, 4810/ +data (chrtab(i), i=2251,2255) / 205, 4235, 4234, 4296, 655/ +data (chrtab(i), i=2256,2260) / 4494, 4365, 4299, 4298, 4360/ +data (chrtab(i), i=2261,2265) / 4423, 0, 220, 4295, 4360/ +data (chrtab(i), i=2266,2270) / 4488, 283, 4361, 28, 4444/ +data (chrtab(i), i=2271,2275) / 4424, 338, 4500, 4629, 4757/ +data (chrtab(i), i=2276,2280) / 4948, 5074, 5135, 5133, 5066/ +data (chrtab(i), i=2281,2285) / 4936, 4743, 4615, 4488, 4426/ +data (chrtab(i), i=2286,2290) / 914, 5072, 5068, 5002, 661/ +data (chrtab(i), i=2291,2295) / 4884, 4947, 5008, 5004, 4937/ +data (chrtab(i), i=2296,2300) / 4872, 4743, 92, 4315, 156/ +data (chrtab(i), i=2301,2305) / 4314, 0, 849, 4946, 4882/ +data (chrtab(i), i=2306,2310) / 4880, 5008, 5010, 4884, 4757/ +data (chrtab(i), i=2311,2315) / 4565, 4372, 4242, 4175, 4173/ +data (chrtab(i), i=2316,2320) / 4234, 4360, 4551, 4679, 4872/ +data (chrtab(i), i=2321,2325) / 5002, 210, 4240, 4236, 4298/ +data (chrtab(i), i=2326,2330) / 469, 4436, 4371, 4304, 4300/ +data (chrtab(i), i=2331,2335) / 4361, 4424, 4551, 0, 796/ +data (chrtab(i), i=2336,2340) / 4871, 5191, 859, 4936, 604/ +data (chrtab(i), i=2341,2345) / 5020, 4999, 786, 4820, 4693/ +data (chrtab(i), i=2346,2350) / 4565, 4372, 4242, 4175, 4173/ +data (chrtab(i), i=2351,2355) / 4234, 4360, 4551, 4679, 4808/ +data (chrtab(i), i=2356,2360) / 4874, 210, 4240, 4236, 4298/ +data (chrtab(i), i=2361,2365) / 469, 4436, 4371, 4304, 4300/ +data (chrtab(i), i=2366,2370) / 4361, 4424, 4551, 668, 4891/ +data (chrtab(i), i=2371,2375) / 732, 4890, 905, 5063, 904/ +data (chrtab(i), i=2376,2380) / 5127, 0, 207, 5007, 5009/ +data (chrtab(i), i=2381,2385) / 4947, 4884, 4693, 4565, 4372/ +data (chrtab(i), i=2386,2390) / 4242, 4175, 4173, 4234, 4360/ +data (chrtab(i), i=2391,2395) / 4551, 4679, 4872, 5002, 848/ +data (chrtab(i), i=2396,2400) / 4945, 4883, 210, 4240, 4236/ +data (chrtab(i), i=2401,2405) / 4298, 783, 4882, 4820, 4693/ +data (chrtab(i), i=2406,2410) / 469, 4436, 4371, 4304, 4300/ +data (chrtab(i), i=2411,2415) / 4361, 4424, 4551, 0, 666/ +data (chrtab(i), i=2416,2420) / 4763, 4699, 4697, 4825, 4827/ +data (chrtab(i), i=2421,2425) / 4764, 4572, 4443, 4378, 4311/ +data (chrtab(i), i=2426,2430) / 4295, 346, 4375, 4360, 476/ +data (chrtab(i), i=2431,2435) / 4507, 4441, 4423, 21, 4693/ +data (chrtab(i), i=2436,2440) / 7, 4615, 200, 4167, 201/ +data (chrtab(i), i=2441,2445) / 4231, 329, 4487, 328, 4551/ +data (chrtab(i), i=2446,2450) / 0, 852, 5011, 5076, 5013/ +data (chrtab(i), i=2451,2455) / 4949, 4820, 4755, 405, 4372/ +data (chrtab(i), i=2456,2460) / 4307, 4241, 4239, 4301, 4364/ +data (chrtab(i), i=2461,2465) / 4491, 4619, 4748, 4813, 4879/ +data (chrtab(i), i=2466,2470) / 4881, 4819, 4756, 4629, 4501/ +data (chrtab(i), i=2471,2475) / 275, 4305, 4303, 4365, 653/ +data (chrtab(i), i=2476,2480) / 4815, 4817, 4755, 405, 4436/ +data (chrtab(i), i=2481,2485) / 4370, 4366, 4428, 4491, 523/ +data (chrtab(i), i=2486,2490) / 4684, 4750, 4754, 4692, 4629/ +data (chrtab(i), i=2491,2495) / 205, 4236, 4170, 4169, 4231/ +data (chrtab(i), i=2496,2500) / 4294, 4485, 4741, 4932, 4995/ +data (chrtab(i), i=2501,2505) / 199, 4486, 4742, 4933, 73/ +data (chrtab(i), i=2506,2510) / 4232, 4423, 4743, 4934, 4996/ +data (chrtab(i), i=2511,2515) / 4995, 4929, 4736, 4352, 4161/ +data (chrtab(i), i=2516,2520) / 4099, 4100, 4166, 4359, 256/ +data (chrtab(i), i=2521,2525) / 4225, 4163, 4164, 4230, 4359/ +data (chrtab(i), i=2526,2530) / 0, 220, 4295, 283, 4360/ +data (chrtab(i), i=2531,2535) / 28, 4444, 4423, 337, 4499/ +data (chrtab(i), i=2536,2540) / 4564, 4693, 4885, 5012, 5075/ +data (chrtab(i), i=2541,2545) / 5136, 5127, 915, 5072, 5064/ +data (chrtab(i), i=2546,2550) / 789, 4948, 5009, 4999, 7/ +data (chrtab(i), i=2551,2555) / 4615, 711, 5319, 92, 4315/ +data (chrtab(i), i=2556,2560) / 156, 4314, 200, 4167, 201/ +data (chrtab(i), i=2561,2565) / 4231, 329, 4487, 328, 4551/ +data (chrtab(i), i=2566,2570) / 904, 4871, 905, 4935, 1033/ +data (chrtab(i), i=2571,2575) / 5191, 1032, 5255, 0, 220/ +data (chrtab(i), i=2576,2580) / 4314, 4442, 4444, 4316, 284/ +data (chrtab(i), i=2581,2585) / 4378, 219, 4443, 213, 4295/ +data (chrtab(i), i=2586,2590) / 276, 4360, 21, 4437, 4423/ +data (chrtab(i), i=2591,2595) / 7, 4615, 85, 4308, 149/ +data (chrtab(i), i=2596,2600) / 4307, 200, 4167, 201, 4231/ +data (chrtab(i), i=2601,2605) / 329, 4487, 328, 4551, 0/ +data (chrtab(i), i=2606,2610) / 348, 4442, 4570, 4572, 4444/ +data (chrtab(i), i=2611,2615) / 412, 4506, 347, 4571, 341/ +data (chrtab(i), i=2616,2620) / 4420, 4353, 4288, 404, 4485/ +data (chrtab(i), i=2621,2625) / 4418, 149, 4565, 4549, 4482/ +data (chrtab(i), i=2626,2630) / 4417, 4288, 4096, 4097, 4099/ +data (chrtab(i), i=2631,2635) / 4163, 4161, 4097, 4098, 213/ +data (chrtab(i), i=2636,2640) / 4436, 277, 4435, 0, 220/ +data (chrtab(i), i=2641,2645) / 4295, 283, 4360, 28, 4444/ +data (chrtab(i), i=2646,2650) / 4423, 916, 4427, 591, 5127/ +data (chrtab(i), i=2651,2655) / 590, 5063, 526, 4999, 725/ +data (chrtab(i), i=2656,2660) / 5269, 7, 4615, 711, 5255/ +data (chrtab(i), i=2661,2665) / 92, 4315, 156, 4314, 789/ +data (chrtab(i), i=2666,2670) / 5012, 1109, 5012, 200, 4167/ +data (chrtab(i), i=2671,2675) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=2676,2680) / 4551, 905, 4871, 841, 5191/ +data (chrtab(i), i=2681,2685) / 0, 220, 4295, 283, 4360/ +data (chrtab(i), i=2686,2690) / 28, 4444, 4423, 7, 4615/ +data (chrtab(i), i=2691,2695) / 92, 4315, 156, 4314, 200/ +data (chrtab(i), i=2696,2700) / 4167, 201, 4231, 329, 4487/ +data (chrtab(i), i=2701,2705) / 328, 4551, 0, 213, 4295/ +data (chrtab(i), i=2706,2710) / 276, 4360, 21, 4437, 4423/ +data (chrtab(i), i=2711,2715) / 337, 4499, 4564, 4693, 4885/ +data (chrtab(i), i=2716,2720) / 5012, 5075, 5136, 5127, 915/ +data (chrtab(i), i=2721,2725) / 5072, 5064, 789, 4948, 5009/ +data (chrtab(i), i=2726,2730) / 4999, 1041, 5203, 5268, 5397/ +data (chrtab(i), i=2731,2735) / 5589, 5716, 5779, 5840, 5831/ +data (chrtab(i), i=2736,2740) / 1619, 5776, 5768, 1493, 5652/ +data (chrtab(i), i=2741,2745) / 5713, 5703, 7, 4615, 711/ +data (chrtab(i), i=2746,2750) / 5319, 1415, 6023, 85, 4308/ +data (chrtab(i), i=2751,2755) / 149, 4307, 200, 4167, 201/ +data (chrtab(i), i=2756,2760) / 4231, 329, 4487, 328, 4551/ +data (chrtab(i), i=2761,2765) / 904, 4871, 905, 4935, 1033/ +data (chrtab(i), i=2766,2770) / 5191, 1032, 5255, 1608, 5575/ +data (chrtab(i), i=2771,2775) / 1609, 5639, 1737, 5895, 1736/ +data (chrtab(i), i=2776,2780) / 5959, 0, 213, 4295, 276/ +data (chrtab(i), i=2781,2785) / 4360, 21, 4437, 4423, 337/ +data (chrtab(i), i=2786,2790) / 4499, 4564, 4693, 4885, 5012/ +data (chrtab(i), i=2791,2795) / 5075, 5136, 5127, 915, 5072/ +data (chrtab(i), i=2796,2800) / 5064, 789, 4948, 5009, 4999/ +data (chrtab(i), i=2801,2805) / 7, 4615, 711, 5319, 85/ +data (chrtab(i), i=2806,2810) / 4308, 149, 4307, 200, 4167/ +data (chrtab(i), i=2811,2815) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=2816,2820) / 4551, 904, 4871, 905, 4935/ +data (chrtab(i), i=2821,2825) / 1033, 5191, 1032, 5255, 0/ +data (chrtab(i), i=2826,2830) / 469, 4372, 4242, 4175, 4173/ +data (chrtab(i), i=2831,2835) / 4234, 4360, 4551, 4679, 4872/ +data (chrtab(i), i=2836,2840) / 5002, 5069, 5071, 5010, 4884/ +data (chrtab(i), i=2841,2845) / 4693, 4565, 210, 4240, 4236/ +data (chrtab(i), i=2846,2850) / 4298, 842, 5004, 5008, 4946/ +data (chrtab(i), i=2851,2855) / 469, 4436, 4371, 4304, 4300/ +data (chrtab(i), i=2856,2860) / 4361, 4424, 4551, 583, 4808/ +data (chrtab(i), i=2861,2865) / 4873, 4940, 4944, 4883, 4820/ +data (chrtab(i), i=2866,2870) / 4693, 0, 213, 4288, 276/ +data (chrtab(i), i=2871,2875) / 4353, 21, 4437, 4416, 338/ +data (chrtab(i), i=2876,2880) / 4500, 4629, 4757, 4948, 5074/ +data (chrtab(i), i=2881,2885) / 5135, 5133, 5066, 4936, 4743/ +data (chrtab(i), i=2886,2890) / 4615, 4488, 4426, 914, 5072/ +data (chrtab(i), i=2891,2895) / 5068, 5002, 661, 4884, 4947/ +data (chrtab(i), i=2896,2900) / 5008, 5004, 4937, 4872, 4743/ +data (chrtab(i), i=2901,2905) / 0, 4608, 85, 4308, 149/ +data (chrtab(i), i=2906,2910) / 4307, 193, 4160, 194, 4224/ +data (chrtab(i), i=2911,2915) / 322, 4480, 321, 4544, 0/ +data (chrtab(i), i=2916,2920) / 788, 4864, 851, 4929, 724/ +data (chrtab(i), i=2921,2925) / 4948, 5013, 4992, 786, 4820/ +data (chrtab(i), i=2926,2930) / 4693, 4565, 4372, 4242, 4175/ +data (chrtab(i), i=2931,2935) / 4173, 4234, 4360, 4551, 4679/ +data (chrtab(i), i=2936,2940) / 4808, 4874, 210, 4240, 4236/ +data (chrtab(i), i=2941,2945) / 4298, 469, 4436, 4371, 4304/ +data (chrtab(i), i=2946,2950) / 4300, 4361, 4424, 4551, 576/ +data (chrtab(i), i=2951,2955) / 5184, 769, 4736, 770, 4800/ +data (chrtab(i), i=2956,2960) / 898, 5056, 897, 5120, 0/ +data (chrtab(i), i=2961,2965) / 213, 4295, 276, 4360, 21/ +data (chrtab(i), i=2966,2970) / 4437, 4423, 787, 4884, 4820/ +data (chrtab(i), i=2971,2975) / 4818, 4946, 4948, 4885, 4757/ +data (chrtab(i), i=2976,2980) / 4628, 4498, 4431, 7, 4615/ +data (chrtab(i), i=2981,2985) / 85, 4308, 149, 4307, 200/ +data (chrtab(i), i=2986,2990) / 4167, 201, 4231, 329, 4487/ +data (chrtab(i), i=2991,2995) / 328, 4551, 0, 723, 4885/ +data (chrtab(i), i=2996,3000) / 4881, 4819, 4756, 4629, 4373/ +data (chrtab(i), i=3001,3005) / 4244, 4179, 4177, 4239, 4366/ +data (chrtab(i), i=3006,3010) / 4685, 4812, 4873, 148, 4177/ +data (chrtab(i), i=3011,3015) / 144, 4367, 4686, 4813, 780/ +data (chrtab(i), i=3016,3020) / 4808, 83, 4241, 4368, 4687/ +data (chrtab(i), i=3021,3025) / 4814, 4876, 4873, 4808, 4679/ +data (chrtab(i), i=3026,3030) / 4423, 4296, 4233, 4171, 4167/ +data (chrtab(i), i=3031,3035) / 4233, 0, 218, 4300, 4361/ +data (chrtab(i), i=3036,3040) / 4424, 4551, 4679, 4808, 4874/ +data (chrtab(i), i=3041,3045) / 282, 4363, 4425, 218, 4444/ +data (chrtab(i), i=3046,3050) / 4427, 4488, 4551, 21, 4693/ +data (chrtab(i), i=3051,3055) / 0, 213, 4300, 4361, 4424/ +data (chrtab(i), i=3056,3060) / 4551, 4743, 4872, 4937, 5003/ +data (chrtab(i), i=3061,3065) / 276, 4363, 4425, 21, 4437/ +data (chrtab(i), i=3066,3070) / 4427, 4488, 4551, 917, 4999/ +data (chrtab(i), i=3071,3075) / 5319, 980, 5064, 725, 5141/ +data (chrtab(i), i=3076,3080) / 5127, 85, 4308, 149, 4307/ +data (chrtab(i), i=3081,3085) / 1033, 5191, 1032, 5255, 0/ +data (chrtab(i), i=3086,3090) / 85, 4551, 149, 4553, 213/ +data (chrtab(i), i=3091,3095) / 4617, 852, 4617, 4551, 21/ +data (chrtab(i), i=3096,3100) / 4501, 597, 5077, 21, 4307/ +data (chrtab(i), i=3101,3105) / 341, 4308, 725, 4948, 917/ +data (chrtab(i), i=3106,3110) / 4948, 0, 149, 4487, 213/ +data (chrtab(i), i=3111,3115) / 4490, 277, 4554, 661, 4554/ +data (chrtab(i), i=3116,3120) / 4487, 661, 4999, 725, 5002/ +data (chrtab(i), i=3121,3125) / 661, 4885, 5066, 1172, 5066/ +data (chrtab(i), i=3126,3130) / 4999, 21, 4565, 981, 5461/ +data (chrtab(i), i=3131,3135) / 21, 4308, 405, 4372, 1045/ +data (chrtab(i), i=3136,3140) / 5268, 1301, 5268, 0, 149/ +data (chrtab(i), i=3141,3145) / 4871, 213, 4935, 277, 4999/ +data (chrtab(i), i=3146,3150) / 852, 4296, 21, 4565, 661/ +data (chrtab(i), i=3151,3155) / 5141, 7, 4487, 583, 5127/ +data (chrtab(i), i=3156,3160) / 85, 4308, 405, 4372, 725/ +data (chrtab(i), i=3161,3165) / 4948, 981, 4948, 200, 4167/ +data (chrtab(i), i=3166,3170) / 200, 4423, 776, 4743, 840/ +data (chrtab(i), i=3171,3175) / 5063, 0, 149, 4615, 213/ +data (chrtab(i), i=3176,3180) / 4617, 277, 4681, 916, 4681/ +data (chrtab(i), i=3181,3185) / 4483, 4353, 4224, 4096, 4097/ +data (chrtab(i), i=3186,3190) / 4099, 4163, 4161, 4097, 4098/ +data (chrtab(i), i=3191,3195) / 21, 4565, 661, 5141, 85/ +data (chrtab(i), i=3196,3200) / 4371, 405, 4372, 789, 5012/ +data (chrtab(i), i=3201,3205) / 981, 5012, 0, 725, 4167/ +data (chrtab(i), i=3206,3210) / 789, 4231, 853, 4295, 853/ +data (chrtab(i), i=3211,3215) / 4181, 4177, 71, 4935, 4939/ +data (chrtab(i), i=3216,3220) / 149, 4177, 213, 4178, 277/ +data (chrtab(i), i=3221,3225) / 4179, 405, 4180, 519, 4936/ +data (chrtab(i), i=3226,3230) / 647, 4937, 711, 4938, 775/ +data (chrtab(i), i=3231,3235) / 4939, 0, 480, 4447, 4382/ +data (chrtab(i), i=3236,3240) / 4316, 4314, 4376, 4439, 4501/ +data (chrtab(i), i=3241,3245) / 4499, 4369, 351, 4381, 4379/ +data (chrtab(i), i=3246,3250) / 4441, 4504, 4566, 4564, 4498/ +data (chrtab(i), i=3251,3255) / 4240, 4494, 4556, 4554, 4488/ +data (chrtab(i), i=3256,3260) / 4423, 4357, 4355, 4417, 271/ +data (chrtab(i), i=3261,3265) / 4493, 4491, 4425, 4360, 4294/ +data (chrtab(i), i=3266,3270) / 4292, 4354, 4417, 4544, 0/ +data (chrtab(i), i=3271,3275) / 160, 4224, 0, 224, 4447/ +data (chrtab(i), i=3276,3280) / 4510, 4572, 4570, 4504, 4439/ +data (chrtab(i), i=3281,3285) / 4373, 4371, 4497, 351, 4509/ +data (chrtab(i), i=3286,3290) / 4507, 4441, 4376, 4310, 4308/ +data (chrtab(i), i=3291,3295) / 4370, 4624, 4366, 4300, 4298/ +data (chrtab(i), i=3296,3300) / 4360, 4423, 4485, 4483, 4417/ +data (chrtab(i), i=3301,3305) / 399, 4365, 4363, 4425, 4488/ +data (chrtab(i), i=3306,3310) / 4550, 4548, 4482, 4417, 4288/ +data (chrtab(i), i=3311,3315) / 0, 77, 4175, 4242, 4371/ +data (chrtab(i), i=3316,3320) / 4499, 4626, 4879, 5006, 5134/ +data (chrtab(i), i=3321,3325) / 5263, 5329, 79, 4241, 4370/ +data (chrtab(i), i=3326,3330) / 4498, 4625, 4878, 5005, 5133/ +data (chrtab(i), i=3331,3335) / 5262, 5329, 5331, 0, 284/ +data (chrtab(i), i=3336,3340) / 4251, 4185, 4183, 4245, 4372/ +data (chrtab(i), i=3341,3345) / 4500, 4629, 4695, 4697, 4635/ +data (chrtab(i), i=3346,3350) / 4508, 4380, 284, 4185, 4245/ +data (chrtab(i), i=3351,3355) / 4500, 4695, 4635, 4380, 412/ +data (chrtab(i), i=3356,3360) / 4251, 4183, 4372, 4629, 4697/ +data (chrtab(i), i=3361,3362) / 4508, 0/ diff --git a/sys/gio/fonts/greek.com b/sys/gio/fonts/greek.com new file mode 100644 index 00000000..82c5fe34 --- /dev/null +++ b/sys/gio/fonts/greek.com @@ -0,0 +1,501 @@ +# CHRTAB -- Table of strokes for the printable ASCII characters. Each +# character is encoded as a series of strokes. Each stroke is ex- +# pressed by a single integer containing the following bitfields: +# +# 2 1 +# 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 +# | | | | | | | +# | | | +---------+ +---------+ +# | | | | | +# | | | X Y +# | | | +# | | +-- pen up/down +# | +---- begin paint (not used at present) +# +------ end paint (not used at present) +# +#---------------------------------------------------------------------------- + +# Define the database. + +short gchidx[97] # character index in gchtab +short gchwid[97] # character width table +short gchtab[2140] # stroke data to draw the characters + +# Index into CHRTAB of each printable character (starting with SP) + +data (gchidx(i), i=001,005) / 1, 3, 16, 29, 38/ +data (gchidx(i), i=006,010) / 77, 107, 154, 162, 181/ +data (gchidx(i), i=011,015) / 200, 205, 212, 233, 240/ +data (gchidx(i), i=016,020) / 246, 259, 297, 306, 348/ +data (gchidx(i), i=021,025) / 392, 402, 437, 483, 510/ +data (gchidx(i), i=026,030) / 568, 614, 645, 658, 666/ +data (gchidx(i), i=031,035) / 673, 681, 688, 741, 767/ +data (gchidx(i), i=036,040) / 793, 795, 806, 821, 863/ +data (gchidx(i), i=041,045) / 874, 883, 888, 899, 901/ +data (gchidx(i), i=046,050) / 912, 921, 930, 972, 987/ +data (gchidx(i), i=051,055) / 1037, 1067, 1083, 1088, 1117/ +data (gchidx(i), i=056,060) / 1143, 1182, 1207, 1242, 1244/ +data (gchidx(i), i=061,065) / 1253, 1256, 1265, 1267, 1276/ +data (gchidx(i), i=066,070) / 1284, 1321, 1373, 1394, 1436/ +data (gchidx(i), i=071,075) / 1465, 1500, 1525, 1554, 1568/ +data (gchidx(i), i=076,080) / 1610, 1635, 1655, 1679, 1699/ +data (gchidx(i), i=081,085) / 1729, 1746, 1788, 1817, 1849/ +data (gchidx(i), i=086,090) / 1862, 1891, 1893, 1934, 1975/ +data (gchidx(i), i=091,095) / 2006, 2036, 2074, 2079, 2117/ +data (gchidx(i), i=096,096) / 2126/ + + +# Width data. + +data (gchwid(i), i=001,005) / 21, 15, 15, 26, 25/ +data (gchwid(i), i=006,010) / 29, 30, 15, 19, 19/ +data (gchwid(i), i=011,015) / 27, 29, 30, 29, 15/ +data (gchwid(i), i=016,020) / 31, 25, 25, 25, 25/ +data (gchwid(i), i=021,025) / 25, 25, 25, 25, 25/ +data (gchwid(i), i=026,030) / 25, 29, 15, 29, 31/ +data (gchwid(i), i=031,035) / 29, 31, 32, 25, 30/ +data (gchwid(i), i=036,040) / 21, 25, 29, 26, 23/ +data (gchwid(i), i=041,045) / 26, 19, 25, 21, 25/ +data (gchwid(i), i=046,050) / 21, 21, 27, 29, 27/ +data (gchwid(i), i=051,055) / 29, 26, 19, 24, 25/ +data (gchwid(i), i=056,060) / 27, 27, 28, 21, 19/ +data (gchwid(i), i=061,065) / 19, 19, 21, 31, 27/ +data (gchwid(i), i=066,070) / 28, 26, 23, 24, 23/ +data (gchwid(i), i=071,075) / 27, 25, 27, 17, 24/ +data (gchwid(i), i=076,080) / 25, 25, 28, 25, 23/ +data (gchwid(i), i=081,085) / 27, 28, 24, 26, 25/ +data (gchwid(i), i=086,090) / 25, 21, 28, 22, 28/ +data (gchwid(i), i=091,095) / 23, 19, 19, 19, 31/ +data (gchwid(i), i=096,096) / 19/ + + +# Stroke data. + +data (gchtab(i), i=0001,0005) / 35, 0, 220, 4250, 4302/ +data (gchtab(i), i=0006,0010) / 4378, 4316, 218, 4308, 201/ +data (gchtab(i), i=0011,0015) / 4232, 4295, 4360, 4297, 0/ +data (gchtab(i), i=0016,0020) / 213, 4244, 4307, 4372, 4309/ +data (gchtab(i), i=0021,0025) / 199, 4232, 4297, 4360, 4358/ +data (gchtab(i), i=0026,0030) / 4292, 4227, 0, 604, 4224/ +data (gchtab(i), i=0031,0035) / 988, 4608, 145, 5137, 75/ +data (gchtab(i), i=0036,0040) / 5067, 0, 416, 4483, 672/ +data (gchtab(i), i=0041,0045) / 4739, 921, 4952, 5015, 5080/ +data (gchtab(i), i=0046,0050) / 5081, 4955, 4764, 4508, 4315/ +data (gchtab(i), i=0051,0055) / 4185, 4183, 4245, 4308, 4435/ +data (gchtab(i), i=0056,0060) / 4817, 4944, 5070, 87, 4309/ +data (gchtab(i), i=0061,0065) / 4436, 4818, 4945, 5008, 5070/ +data (gchtab(i), i=0066,0070) / 5066, 4936, 4743, 4487, 4296/ +data (gchtab(i), i=0071,0075) / 4170, 4171, 4236, 4299, 4234/ +data (gchtab(i), i=0076,0080) / 0, 1244, 4167, 412, 4634/ +data (gchtab(i), i=0081,0085) / 4632, 4566, 4437, 4309, 4183/ +data (gchtab(i), i=0086,0090) / 4185, 4251, 4380, 4508, 4635/ +data (gchtab(i), i=0091,0095) / 4826, 5018, 5211, 5340, 974/ +data (gchtab(i), i=0096,0100) / 4941, 4875, 4873, 4999, 5127/ +data (gchtab(i), i=0101,0105) / 5256, 5322, 5324, 5198, 5070/ +data (gchtab(i), i=0106,0110) / 0, 1236, 5267, 5330, 5395/ +data (gchtab(i), i=0111,0115) / 5396, 5333, 5269, 5204, 5138/ +data (gchtab(i), i=0116,0120) / 5005, 4874, 4744, 4615, 4423/ +data (gchtab(i), i=0121,0125) / 4232, 4170, 4173, 4239, 4627/ +data (gchtab(i), i=0126,0130) / 4757, 4823, 4825, 4763, 4636/ +data (gchtab(i), i=0131,0135) / 4507, 4441, 4439, 4500, 4625/ +data (gchtab(i), i=0136,0140) / 4938, 5064, 5255, 5319, 5384/ +data (gchtab(i), i=0141,0145) / 5385, 327, 4296, 4234, 4237/ +data (gchtab(i), i=0146,0150) / 4303, 4433, 343, 4501, 5002/ +data (gchtab(i), i=0151,0155) / 5128, 5255, 0, 218, 4251/ +data (gchtab(i), i=0156,0160) / 4316, 4379, 4377, 4311, 4246/ +data (gchtab(i), i=0161,0165) / 0, 608, 4574, 4443, 4311/ +data (gchtab(i), i=0166,0170) / 4242, 4238, 4297, 4421, 4546/ +data (gchtab(i), i=0171,0175) / 4672, 478, 4442, 4375, 4306/ +data (gchtab(i), i=0176,0180) / 4302, 4361, 4422, 4546, 0/ +data (gchtab(i), i=0181,0185) / 96, 4318, 4443, 4567, 4626/ +data (gchtab(i), i=0186,0190) / 4622, 4553, 4421, 4290, 4160/ +data (gchtab(i), i=0191,0195) / 222, 4442, 4503, 4562, 4558/ +data (gchtab(i), i=0196,0200) / 4489, 4422, 4290, 0, 151/ +data (gchtab(i), i=0201,0205) / 5129, 1047, 4233, 0, 664/ +data (gchtab(i), i=0206,0210) / 4743, 144, 5264, 135, 5255/ +data (gchtab(i), i=0211,0215) / 0, 1227, 5195, 5068, 4942/ +data (gchtab(i), i=0216,0220) / 4754, 4691, 4564, 4436, 4307/ +data (gchtab(i), i=0221,0225) / 4241, 4239, 4301, 4428, 4556/ +data (gchtab(i), i=0226,0230) / 4685, 4750, 4946, 5076, 5205/ +data (gchtab(i), i=0231,0235) / 5333, 0, 664, 4743, 152/ +data (gchtab(i), i=0236,0240) / 5272, 144, 5264, 0, 201/ +data (gchtab(i), i=0241,0245) / 4232, 4295, 4360, 4297, 0/ +data (gchtab(i), i=0246,0250) / 729, 4760, 4823, 4888, 4825/ +data (gchtab(i), i=0251,0255) / 144, 5392, 713, 4744, 4807/ +data (gchtab(i), i=0256,0260) / 4872, 4809, 0, 476, 4379/ +data (gchtab(i), i=0261,0265) / 4248, 4179, 4176, 4235, 4360/ +data (gchtab(i), i=0266,0270) / 4551, 4679, 4872, 5003, 5072/ +data (gchtab(i), i=0271,0275) / 5075, 5016, 4891, 4700, 4572/ +data (gchtab(i), i=0276,0280) / 476, 4443, 4378, 4312, 4243/ +data (gchtab(i), i=0281,0285) / 4240, 4299, 4361, 4424, 4551/ +data (gchtab(i), i=0286,0290) / 583, 4808, 4873, 4939, 5008/ +data (gchtab(i), i=0291,0295) / 5011, 4952, 4890, 4827, 4700/ +data (gchtab(i), i=0296,0300) / 0, 280, 4505, 4700, 4679/ +data (gchtab(i), i=0301,0305) / 539, 4615, 263, 4935, 0/ +data (gchtab(i), i=0306,0310) / 152, 4311, 4246, 4183, 4184/ +data (gchtab(i), i=0311,0315) / 4250, 4315, 4508, 4764, 4955/ +data (gchtab(i), i=0316,0320) / 5018, 5080, 5078, 5012, 4818/ +data (gchtab(i), i=0321,0325) / 4496, 4367, 4237, 4170, 4167/ +data (gchtab(i), i=0326,0330) / 668, 4891, 4954, 5016, 5014/ +data (gchtab(i), i=0331,0335) / 4948, 4754, 4496, 73, 4234/ +data (gchtab(i), i=0336,0340) / 4362, 4680, 4872, 5001, 5066/ +data (gchtab(i), i=0341,0345) / 266, 4679, 4935, 5000, 5066/ +data (gchtab(i), i=0346,0350) / 5068, 0, 152, 4311, 4246/ +data (gchtab(i), i=0351,0355) / 4183, 4184, 4250, 4315, 4508/ +data (gchtab(i), i=0356,0360) / 4764, 4955, 5017, 5014, 4948/ +data (gchtab(i), i=0361,0365) / 4755, 4563, 668, 4891, 4953/ +data (gchtab(i), i=0366,0370) / 4950, 4884, 4755, 659, 4882/ +data (gchtab(i), i=0371,0375) / 5008, 5070, 5067, 5001, 4936/ +data (gchtab(i), i=0376,0380) / 4743, 4487, 4296, 4233, 4171/ +data (gchtab(i), i=0381,0385) / 4172, 4237, 4300, 4235, 849/ +data (gchtab(i), i=0386,0390) / 5006, 5003, 4937, 4872, 4743/ +data (gchtab(i), i=0391,0395) / 0, 666, 4743, 732, 4807/ +data (gchtab(i), i=0396,0400) / 732, 4109, 5133, 455, 4999/ +data (gchtab(i), i=0401,0405) / 0, 220, 4178, 82, 4308/ +data (gchtab(i), i=0406,0410) / 4501, 4693, 4884, 5010, 5071/ +data (gchtab(i), i=0411,0415) / 5069, 5002, 4872, 4679, 4487/ +data (gchtab(i), i=0416,0420) / 4296, 4233, 4171, 4172, 4237/ +data (gchtab(i), i=0421,0425) / 4300, 4235, 597, 4820, 4946/ +data (gchtab(i), i=0426,0430) / 5007, 5005, 4938, 4808, 4679/ +data (gchtab(i), i=0431,0435) / 220, 4956, 219, 4635, 4956/ +data (gchtab(i), i=0436,0440) / 0, 857, 4888, 4951, 5016/ +data (gchtab(i), i=0441,0445) / 5017, 4955, 4828, 4636, 4443/ +data (gchtab(i), i=0446,0450) / 4313, 4247, 4179, 4173, 4234/ +data (gchtab(i), i=0451,0455) / 4360, 4551, 4679, 4872, 5002/ +data (gchtab(i), i=0456,0460) / 5069, 5070, 5009, 4883, 4692/ +data (gchtab(i), i=0461,0465) / 4628, 4435, 4305, 4238, 540/ +data (gchtab(i), i=0466,0470) / 4507, 4377, 4311, 4243, 4237/ +data (gchtab(i), i=0471,0475) / 4298, 4424, 4551, 583, 4808/ +data (gchtab(i), i=0476,0480) / 4938, 5005, 5006, 4945, 4819/ +data (gchtab(i), i=0481,0485) / 4692, 0, 92, 4182, 88/ +data (gchtab(i), i=0486,0490) / 4250, 4380, 4508, 4825, 4953/ +data (gchtab(i), i=0491,0495) / 5018, 5084, 154, 4379, 4507/ +data (gchtab(i), i=0496,0500) / 4825, 988, 5081, 5014, 4753/ +data (gchtab(i), i=0501,0505) / 4687, 4620, 4615, 918, 4689/ +data (gchtab(i), i=0506,0510) / 4623, 4556, 4551, 0, 412/ +data (gchtab(i), i=0511,0515) / 4315, 4249, 4246, 4308, 4499/ +data (gchtab(i), i=0516,0520) / 4755, 4948, 5014, 5017, 4955/ +data (gchtab(i), i=0521,0525) / 4764, 4508, 412, 4379, 4313/ +data (gchtab(i), i=0526,0530) / 4310, 4372, 4499, 659, 4884/ +data (gchtab(i), i=0531,0535) / 4950, 4953, 4891, 4764, 403/ +data (gchtab(i), i=0536,0540) / 4306, 4241, 4175, 4171, 4233/ +data (gchtab(i), i=0541,0545) / 4296, 4487, 4743, 4936, 5001/ +data (gchtab(i), i=0546,0550) / 5067, 5071, 5009, 4946, 4755/ +data (gchtab(i), i=0551,0555) / 403, 4370, 4305, 4239, 4235/ +data (gchtab(i), i=0556,0560) / 4297, 4360, 4487, 647, 4872/ +data (gchtab(i), i=0561,0565) / 4937, 5003, 5007, 4945, 4882/ +data (gchtab(i), i=0566,0570) / 4755, 0, 917, 4946, 4816/ +data (gchtab(i), i=0571,0575) / 4623, 4559, 4368, 4242, 4181/ +data (gchtab(i), i=0576,0580) / 4182, 4249, 4379, 4572, 4700/ +data (gchtab(i), i=0581,0585) / 4891, 5017, 5078, 5072, 5004/ +data (gchtab(i), i=0586,0590) / 4938, 4808, 4615, 4423, 4296/ +data (gchtab(i), i=0591,0595) / 4234, 4235, 4300, 4363, 4298/ +data (gchtab(i), i=0596,0600) / 463, 4432, 4306, 4245, 4246/ +data (gchtab(i), i=0601,0605) / 4313, 4443, 4572, 604, 4827/ +data (gchtab(i), i=0606,0610) / 4953, 5014, 5008, 4940, 4874/ +data (gchtab(i), i=0611,0615) / 4744, 4615, 0, 1247, 5278/ +data (gchtab(i), i=0616,0620) / 5341, 5406, 5407, 5344, 5216/ +data (gchtab(i), i=0621,0625) / 5087, 4957, 4891, 4824, 4756/ +data (gchtab(i), i=0626,0630) / 4616, 4548, 4482, 926, 4956/ +data (gchtab(i), i=0631,0635) / 4888, 4748, 4680, 4613, 4547/ +data (gchtab(i), i=0636,0640) / 4417, 4288, 4160, 4097, 4098/ +data (gchtab(i), i=0641,0645) / 4163, 4226, 4161, 0, 213/ +data (gchtab(i), i=0646,0650) / 4244, 4307, 4372, 4309, 199/ +data (gchtab(i), i=0651,0655) / 4232, 4297, 4360, 4358, 4292/ +data (gchtab(i), i=0656,0660) / 4227, 0, 1180, 4245, 5262/ +data (gchtab(i), i=0661,0665) / 140, 5260, 135, 5255, 0/ +data (gchtab(i), i=0666,0670) / 149, 5397, 144, 5392, 139/ +data (gchtab(i), i=0671,0675) / 5387, 0, 156, 5269, 4238/ +data (gchtab(i), i=0676,0680) / 140, 5260, 135, 5255, 0/ +data (gchtab(i), i=0681,0685) / 1177, 4359, 147, 5395, 141/ +data (gchtab(i), i=0686,0690) / 5389, 0, 1044, 5078, 4951/ +data (gchtab(i), i=0691,0695) / 4759, 4630, 4565, 4498, 4495/ +data (gchtab(i), i=0696,0700) / 4557, 4684, 4876, 5005, 5071/ +data (gchtab(i), i=0701,0705) / 663, 4629, 4562, 4559, 4621/ +data (gchtab(i), i=0706,0710) / 4684, 1047, 5071, 5069, 5196/ +data (gchtab(i), i=0711,0715) / 5324, 5454, 5521, 5523, 5462/ +data (gchtab(i), i=0716,0720) / 5400, 5274, 5147, 4956, 4764/ +data (gchtab(i), i=0721,0725) / 4571, 4442, 4312, 4246, 4179/ +data (gchtab(i), i=0726,0730) / 4176, 4237, 4299, 4425, 4552/ +data (gchtab(i), i=0731,0735) / 4743, 4935, 5128, 5257, 5322/ +data (gchtab(i), i=0736,0740) / 1111, 5135, 5133, 5196, 0/ +data (gchtab(i), i=0741,0745) / 473, 4167, 601, 5063, 537/ +data (gchtab(i), i=0746,0750) / 4999, 205, 4877, 7, 4423/ +data (gchtab(i), i=0751,0755) / 711, 5191, 480, 4447, 4381/ +data (gchtab(i), i=0756,0760) / 4379, 4441, 4568, 4696, 4825/ +data (gchtab(i), i=0761,0765) / 4891, 4893, 4831, 4704, 4576/ +data (gchtab(i), i=0766,0770) / 0, 1295, 5325, 5196, 5068/ +data (gchtab(i), i=0771,0775) / 4941, 4878, 4690, 4627, 4500/ +data (gchtab(i), i=0776,0780) / 4372, 4243, 4177, 4175, 4237/ +data (gchtab(i), i=0781,0785) / 4364, 4492, 4621, 4686, 4882/ +data (gchtab(i), i=0786,0790) / 4947, 5076, 5204, 5331, 5393/ +data (gchtab(i), i=0791,0795) / 5391, 0, 35, 0, 540/ +data (gchtab(i), i=0796,0800) / 4103, 540, 5127, 537, 5063/ +data (gchtab(i), i=0801,0805) / 72, 5064, 7, 5127, 0/ +data (gchtab(i), i=0806,0810) / 1176, 4824, 4567, 4438, 4308/ +data (gchtab(i), i=0811,0815) / 4241, 4239, 4300, 4426, 4553/ +data (gchtab(i), i=0816,0820) / 4808, 5256, 144, 5008, 0/ +data (gchtab(i), i=0821,0825) / 540, 4615, 604, 4679, 407/ +data (gchtab(i), i=0826,0830) / 4310, 4245, 4179, 4176, 4238/ +data (gchtab(i), i=0831,0835) / 4301, 4492, 4812, 5005, 5070/ +data (gchtab(i), i=0836,0840) / 5136, 5139, 5077, 5014, 4823/ +data (gchtab(i), i=0841,0845) / 4503, 407, 4374, 4309, 4243/ +data (gchtab(i), i=0846,0850) / 4240, 4302, 4365, 4492, 716/ +data (gchtab(i), i=0851,0855) / 4941, 5006, 5072, 5075, 5013/ +data (gchtab(i), i=0856,0860) / 4950, 4823, 348, 4892, 327/ +data (gchtab(i), i=0861,0865) / 4871, 0, 220, 4295, 284/ +data (gchtab(i), i=0866,0870) / 4359, 28, 5084, 5078, 5020/ +data (gchtab(i), i=0871,0875) / 7, 4551, 0, 608, 4224/ +data (gchtab(i), i=0876,0880) / 992, 4608, 147, 5139, 77/ +data (gchtab(i), i=0881,0885) / 5069, 0, 160, 4224, 544/ +data (gchtab(i), i=0886,0890) / 4608, 0, 28, 4615, 92/ +data (gchtab(i), i=0891,0895) / 4617, 1052, 4615, 28, 5148/ +data (gchtab(i), i=0896,0900) / 91, 5083, 0, 35, 0/ +data (gchtab(i), i=0901,0905) / 540, 4167, 540, 5063, 537/ +data (gchtab(i), i=0906,0910) / 4999, 7, 4423, 711, 5191/ +data (gchtab(i), i=0911,0915) / 0, 278, 4505, 4630, 83/ +data (gchtab(i), i=0916,0920) / 4504, 4819, 408, 4487, 0/ +data (gchtab(i), i=0921,0925) / 266, 4487, 4618, 77, 4488/ +data (gchtab(i), i=0926,0930) / 4813, 409, 4488, 0, 540/ +data (gchtab(i), i=0931,0935) / 4443, 4313, 4247, 4179, 4176/ +data (gchtab(i), i=0936,0940) / 4236, 4298, 4424, 4615, 4743/ +data (gchtab(i), i=0941,0945) / 4936, 5066, 5132, 5200, 5203/ +data (gchtab(i), i=0946,0950) / 5143, 5081, 4955, 4764, 4636/ +data (gchtab(i), i=0951,0955) / 540, 4507, 4377, 4311, 4243/ +data (gchtab(i), i=0956,0960) / 4240, 4300, 4362, 4488, 4615/ +data (gchtab(i), i=0961,0965) / 647, 4872, 5002, 5068, 5136/ +data (gchtab(i), i=0966,0970) / 5139, 5079, 5017, 4891, 4764/ +data (gchtab(i), i=0971,0975) / 0, 220, 4295, 284, 4359/ +data (gchtab(i), i=0976,0980) / 1052, 5127, 1116, 5191, 28/ +data (gchtab(i), i=0981,0985) / 5404, 7, 4551, 839, 5383/ +data (gchtab(i), i=0986,0990) / 0, 540, 4443, 4313, 4247/ +data (gchtab(i), i=0991,0995) / 4179, 4176, 4236, 4298, 4424/ +data (gchtab(i), i=0996,1000) / 4615, 4743, 4936, 5066, 5132/ +data (gchtab(i), i=1001,1005) / 5200, 5203, 5143, 5081, 4955/ +data (gchtab(i), i=1006,1010) / 4764, 4636, 540, 4507, 4377/ +data (gchtab(i), i=1011,1015) / 4311, 4243, 4240, 4300, 4362/ +data (gchtab(i), i=1016,1020) / 4488, 4615, 647, 4872, 5002/ +data (gchtab(i), i=1021,1025) / 5068, 5136, 5139, 5079, 5017/ +data (gchtab(i), i=1026,1030) / 4891, 4764, 405, 4494, 789/ +data (gchtab(i), i=1031,1035) / 4878, 402, 4882, 401, 4881/ +data (gchtab(i), i=1036,1040) / 0, 1244, 4167, 412, 4634/ +data (gchtab(i), i=1041,1045) / 4632, 4566, 4437, 4309, 4183/ +data (gchtab(i), i=1046,1050) / 4185, 4251, 4380, 4508, 4635/ +data (gchtab(i), i=1051,1055) / 4826, 5018, 5211, 5340, 974/ +data (gchtab(i), i=1056,1060) / 4941, 4875, 4873, 4999, 5127/ +data (gchtab(i), i=1061,1065) / 5256, 5322, 5324, 5198, 5070/ +data (gchtab(i), i=1066,1070) / 0, 92, 4626, 4103, 28/ +data (gchtab(i), i=1071,1075) / 4562, 28, 5084, 5142, 5020/ +data (gchtab(i), i=1076,1080) / 72, 5000, 7, 5063, 5133/ +data (gchtab(i), i=1081,1085) / 4999, 0, 160, 4224, 544/ +data (gchtab(i), i=1086,1090) / 4608, 0, 23, 4121, 4187/ +data (gchtab(i), i=1091,1095) / 4252, 4380, 4443, 4505, 4565/ +data (gchtab(i), i=1096,1100) / 4551, 25, 4251, 4379, 4505/ +data (gchtab(i), i=1101,1105) / 983, 5081, 5019, 4956, 4828/ +data (gchtab(i), i=1106,1110) / 4763, 4697, 4629, 4615, 985/ +data (gchtab(i), i=1111,1115) / 4955, 4827, 4697, 263, 4807/ +data (gchtab(i), i=1116,1120) / 0, 473, 4167, 601, 5063/ +data (gchtab(i), i=1121,1125) / 537, 4999, 205, 4877, 7/ +data (gchtab(i), i=1126,1130) / 4423, 711, 5191, 480, 4447/ +data (gchtab(i), i=1131,1135) / 4381, 4379, 4441, 4568, 4696/ +data (gchtab(i), i=1136,1140) / 4825, 4891, 4893, 4831, 4704/ +data (gchtab(i), i=1141,1145) / 4576, 0, 74, 4231, 4487/ +data (gchtab(i), i=1146,1150) / 4363, 4239, 4178, 4182, 4249/ +data (gchtab(i), i=1151,1155) / 4379, 4572, 4828, 5019, 5145/ +data (gchtab(i), i=1156,1160) / 5206, 5202, 5135, 5003, 4871/ +data (gchtab(i), i=1161,1165) / 5127, 5194, 267, 4302, 4242/ +data (gchtab(i), i=1166,1170) / 4246, 4313, 4443, 4572, 732/ +data (gchtab(i), i=1171,1175) / 4955, 5081, 5142, 5138, 5070/ +data (gchtab(i), i=1176,1180) / 5003, 136, 4424, 840, 5128/ +data (gchtab(i), i=1181,1185) / 0, 157, 4184, 1117, 5144/ +data (gchtab(i), i=1186,1190) / 404, 4431, 852, 4879, 139/ +data (gchtab(i), i=1191,1195) / 4166, 1099, 5126, 155, 5147/ +data (gchtab(i), i=1196,1200) / 154, 5146, 402, 4882, 401/ +data (gchtab(i), i=1201,1205) / 4881, 137, 5129, 136, 5128/ +data (gchtab(i), i=1206,1210) / 0, 604, 4679, 668, 4743/ +data (gchtab(i), i=1211,1215) / 21, 4182, 4309, 4369, 4431/ +data (gchtab(i), i=1216,1220) / 4494, 4621, 86, 4245, 4305/ +data (gchtab(i), i=1221,1225) / 4367, 4430, 4621, 4813, 5006/ +data (gchtab(i), i=1226,1230) / 5071, 5137, 5205, 5270, 717/ +data (gchtab(i), i=1231,1235) / 4942, 5007, 5073, 5141, 5270/ +data (gchtab(i), i=1236,1240) / 5333, 412, 4956, 391, 4935/ +data (gchtab(i), i=1241,1245) / 0, 35, 0, 160, 4224/ +data (gchtab(i), i=1246,1250) / 224, 4288, 160, 4704, 128/ +data (gchtab(i), i=1251,1255) / 4672, 0, 28, 4868, 0/ +data (gchtab(i), i=1256,1260) / 480, 4544, 544, 4608, 96/ +data (gchtab(i), i=1261,1265) / 4640, 64, 4608, 0, 35/ +data (gchtab(i), i=1266,1270) / 0, 1106, 5392, 5198, 917/ +data (gchtab(i), i=1271,1275) / 5328, 5003, 144, 5328, 0/ +data (gchtab(i), i=1276,1280) / 85, 4437, 4809, 277, 4807/ +data (gchtab(i), i=1281,1285) / 1312, 4807, 0, 533, 4436/ +data (gchtab(i), i=1286,1290) / 4306, 4240, 4173, 4170, 4232/ +data (gchtab(i), i=1291,1295) / 4423, 4551, 4680, 4875, 5006/ +data (gchtab(i), i=1296,1300) / 5138, 5205, 533, 4500, 4370/ +data (gchtab(i), i=1301,1305) / 4304, 4237, 4234, 4296, 4423/ +data (gchtab(i), i=1306,1310) / 533, 4757, 4884, 4946, 5066/ +data (gchtab(i), i=1311,1315) / 5128, 5191, 661, 4820, 4882/ +data (gchtab(i), i=1316,1320) / 5002, 5064, 5191, 5255, 0/ +data (gchtab(i), i=1321,1325) / 732, 4635, 4505, 4373, 4306/ +data (gchtab(i), i=1326,1330) / 4238, 4168, 4096, 732, 4699/ +data (gchtab(i), i=1331,1335) / 4569, 4437, 4370, 4302, 4232/ +data (gchtab(i), i=1336,1340) / 4160, 732, 4956, 5083, 5146/ +data (gchtab(i), i=1341,1345) / 5143, 5077, 5012, 4819, 4563/ +data (gchtab(i), i=1346,1350) / 860, 5082, 5079, 5013, 4948/ +data (gchtab(i), i=1351,1355) / 4819, 467, 4818, 4944, 5006/ +data (gchtab(i), i=1356,1360) / 5003, 4937, 4872, 4679, 4551/ +data (gchtab(i), i=1361,1365) / 4424, 4361, 4300, 467, 4754/ +data (gchtab(i), i=1366,1370) / 4880, 4942, 4939, 4873, 4808/ +data (gchtab(i), i=1371,1375) / 4679, 0, 21, 4245, 4372/ +data (gchtab(i), i=1376,1380) / 4434, 4739, 4801, 4864, 149/ +data (gchtab(i), i=1381,1385) / 4308, 4370, 4675, 4737, 4864/ +data (gchtab(i), i=1386,1390) / 4992, 981, 5011, 4880, 4229/ +data (gchtab(i), i=1391,1395) / 4098, 4096, 0, 724, 4693/ +data (gchtab(i), i=1396,1400) / 4565, 4372, 4241, 4174, 4171/ +data (gchtab(i), i=1401,1405) / 4233, 4296, 4423, 4551, 4744/ +data (gchtab(i), i=1406,1410) / 4875, 4942, 4945, 4883, 4632/ +data (gchtab(i), i=1411,1415) / 4570, 4572, 4637, 4765, 4892/ +data (gchtab(i), i=1416,1420) / 5018, 469, 4436, 4305, 4238/ +data (gchtab(i), i=1421,1425) / 4234, 4296, 455, 4680, 4811/ +data (gchtab(i), i=1426,1430) / 4878, 4882, 4820, 4695, 4633/ +data (gchtab(i), i=1431,1435) / 4635, 4700, 4828, 5018, 0/ +data (gchtab(i), i=1436,1440) / 850, 4820, 4693, 4437, 4308/ +data (gchtab(i), i=1441,1445) / 4306, 4432, 4623, 341, 4372/ +data (gchtab(i), i=1446,1450) / 4370, 4496, 4623, 527, 4302/ +data (gchtab(i), i=1451,1455) / 4172, 4170, 4232, 4423, 4615/ +data (gchtab(i), i=1456,1460) / 4744, 4874, 527, 4366, 4236/ +data (gchtab(i), i=1461,1465) / 4234, 4296, 4423, 0, 404/ +data (gchtab(i), i=1466,1470) / 4371, 4241, 4174, 4171, 4233/ +data (gchtab(i), i=1471,1475) / 4296, 4423, 4615, 4808, 5002/ +data (gchtab(i), i=1476,1480) / 5133, 5200, 5203, 5077, 4949/ +data (gchtab(i), i=1481,1485) / 4819, 4687, 4554, 4352, 75/ +data (gchtab(i), i=1486,1490) / 4297, 4424, 4616, 4809, 5003/ +data (gchtab(i), i=1491,1495) / 5133, 1107, 5076, 4948, 4818/ +data (gchtab(i), i=1496,1500) / 4687, 4553, 4416, 0, 18/ +data (gchtab(i), i=1501,1505) / 4180, 4309, 4437, 4564, 4627/ +data (gchtab(i), i=1506,1510) / 4688, 4684, 4616, 4416, 19/ +data (gchtab(i), i=1511,1515) / 4244, 4500, 4627, 1045, 5074/ +data (gchtab(i), i=1516,1520) / 5008, 4681, 4484, 4352, 981/ +data (gchtab(i), i=1521,1525) / 5010, 4944, 4681, 0, 17/ +data (gchtab(i), i=1526,1530) / 4115, 4245, 4437, 4500, 4498/ +data (gchtab(i), i=1531,1535) / 4430, 4295, 277, 4436, 4434/ +data (gchtab(i), i=1536,1540) / 4366, 4231, 334, 4562, 4692/ +data (gchtab(i), i=1541,1545) / 4821, 4949, 5076, 5139, 5136/ +data (gchtab(i), i=1546,1550) / 5067, 4864, 853, 5075, 5072/ +data (gchtab(i), i=1551,1555) / 5003, 4800, 0, 277, 4238/ +data (gchtab(i), i=1556,1560) / 4170, 4168, 4231, 4423, 4553/ +data (gchtab(i), i=1561,1565) / 4619, 341, 4302, 4234, 4232/ +data (gchtab(i), i=1566,1570) / 4295, 0, 848, 4883, 4820/ +data (gchtab(i), i=1571,1575) / 4693, 4565, 4372, 4241, 4174/ +data (gchtab(i), i=1576,1580) / 4171, 4233, 4296, 4423, 4551/ +data (gchtab(i), i=1581,1585) / 4744, 4874, 4941, 5010, 5015/ +data (gchtab(i), i=1586,1590) / 4954, 4891, 4764, 4572, 4443/ +data (gchtab(i), i=1591,1595) / 4378, 4377, 4441, 4442, 469/ +data (gchtab(i), i=1596,1600) / 4436, 4305, 4238, 4234, 4296/ +data (gchtab(i), i=1601,1605) / 455, 4680, 4810, 4877, 4946/ +data (gchtab(i), i=1606,1610) / 4951, 4890, 4764, 0, 277/ +data (gchtab(i), i=1611,1615) / 4103, 341, 4167, 917, 5076/ +data (gchtab(i), i=1616,1620) / 5140, 5077, 4949, 4820, 4560/ +data (gchtab(i), i=1621,1625) / 4431, 4303, 335, 4558, 4680/ +data (gchtab(i), i=1626,1630) / 4743, 335, 4494, 4616, 4679/ +data (gchtab(i), i=1631,1635) / 4807, 4936, 5067, 0, 92/ +data (gchtab(i), i=1636,1640) / 4316, 4443, 4506, 4568, 4938/ +data (gchtab(i), i=1641,1645) / 5000, 5063, 220, 4442, 4504/ +data (gchtab(i), i=1646,1650) / 4874, 4936, 5063, 5127, 533/ +data (gchtab(i), i=1651,1655) / 4103, 533, 4167, 0, 341/ +data (gchtab(i), i=1656,1660) / 4096, 405, 4096, 338, 4364/ +data (gchtab(i), i=1661,1665) / 4361, 4487, 4615, 4744, 4874/ +data (gchtab(i), i=1666,1670) / 5005, 1045, 4938, 4936, 4999/ +data (gchtab(i), i=1671,1675) / 5191, 5321, 5387, 1109, 5002/ +data (gchtab(i), i=1676,1680) / 5000, 5063, 0, 277, 4231/ +data (gchtab(i), i=1681,1685) / 341, 4367, 4298, 4231, 981/ +data (gchtab(i), i=1686,1690) / 5009, 4877, 1045, 5074, 5008/ +data (gchtab(i), i=1691,1695) / 4877, 4747, 4553, 4424, 4231/ +data (gchtab(i), i=1696,1700) / 85, 4437, 0, 469, 4372/ +data (gchtab(i), i=1701,1705) / 4241, 4174, 4171, 4233, 4296/ +data (gchtab(i), i=1706,1710) / 4423, 4551, 4744, 4875, 4942/ +data (gchtab(i), i=1711,1715) / 4945, 4883, 4820, 4693, 4565/ +data (gchtab(i), i=1716,1720) / 469, 4436, 4305, 4238, 4234/ +data (gchtab(i), i=1721,1725) / 4296, 455, 4680, 4811, 4878/ +data (gchtab(i), i=1726,1730) / 4882, 4820, 0, 468, 4295/ +data (gchtab(i), i=1731,1735) / 468, 4359, 852, 4935, 852/ +data (gchtab(i), i=1736,1740) / 4999, 18, 4244, 4437, 5269/ +data (gchtab(i), i=1741,1745) / 18, 4243, 4436, 5268, 0/ +data (gchtab(i), i=1746,1750) / 17, 4115, 4245, 4437, 4500/ +data (gchtab(i), i=1751,1755) / 4498, 4429, 4426, 4488, 4551/ +data (gchtab(i), i=1756,1760) / 277, 4436, 4434, 4365, 4362/ +data (gchtab(i), i=1761,1765) / 4424, 4551, 4679, 4808, 4938/ +data (gchtab(i), i=1766,1770) / 5069, 5136, 5205, 5209, 5147/ +data (gchtab(i), i=1771,1775) / 5020, 4892, 4762, 4760, 4821/ +data (gchtab(i), i=1776,1780) / 4946, 5072, 5262, 712, 4939/ +data (gchtab(i), i=1781,1785) / 5005, 5072, 5141, 5145, 5083/ +data (gchtab(i), i=1786,1790) / 5020, 0, 140, 4297, 4360/ +data (gchtab(i), i=1791,1795) / 4487, 4615, 4808, 4939, 5006/ +data (gchtab(i), i=1796,1800) / 5009, 4947, 4884, 4757, 4629/ +data (gchtab(i), i=1801,1805) / 4436, 4305, 4238, 4096, 519/ +data (gchtab(i), i=1806,1810) / 4744, 4875, 4942, 4946, 4884/ +data (gchtab(i), i=1811,1815) / 533, 4500, 4369, 4302, 4096/ +data (gchtab(i), i=1816,1820) / 0, 1109, 4565, 4372, 4241/ +data (gchtab(i), i=1821,1825) / 4174, 4171, 4233, 4296, 4423/ +data (gchtab(i), i=1826,1830) / 4551, 4744, 4875, 4942, 4945/ +data (gchtab(i), i=1831,1835) / 4883, 4820, 4693, 469, 4436/ +data (gchtab(i), i=1836,1840) / 4305, 4238, 4234, 4296, 455/ +data (gchtab(i), i=1841,1845) / 4680, 4811, 4878, 4882, 4820/ +data (gchtab(i), i=1846,1850) / 724, 5204, 0, 596, 4487/ +data (gchtab(i), i=1851,1855) / 596, 4551, 18, 4244, 4437/ +data (gchtab(i), i=1856,1860) / 5141, 18, 4243, 4436, 5140/ +data (gchtab(i), i=1861,1865) / 0, 17, 4115, 4245, 4437/ +data (gchtab(i), i=1866,1870) / 4500, 4498, 4364, 4361, 4487/ +data (gchtab(i), i=1871,1875) / 277, 4436, 4434, 4300, 4297/ +data (gchtab(i), i=1876,1880) / 4360, 4487, 4551, 4744, 4874/ +data (gchtab(i), i=1881,1885) / 5005, 5072, 5075, 5013, 4948/ +data (gchtab(i), i=1886,1890) / 5011, 5072, 909, 5075, 0/ +data (gchtab(i), i=1891,1895) / 35, 0, 145, 4371, 4564/ +data (gchtab(i), i=1896,1900) / 4501, 4372, 4241, 4174, 4171/ +data (gchtab(i), i=1901,1905) / 4232, 4295, 4423, 4552, 4683/ +data (gchtab(i), i=1906,1910) / 4750, 75, 4233, 4296, 4424/ +data (gchtab(i), i=1911,1915) / 4553, 4683, 590, 4683, 4744/ +data (gchtab(i), i=1916,1920) / 4807, 4935, 5064, 5195, 5262/ +data (gchtab(i), i=1921,1925) / 5265, 5204, 5141, 5076, 5203/ +data (gchtab(i), i=1926,1930) / 5265, 587, 4745, 4808, 4936/ +data (gchtab(i), i=1931,1935) / 5065, 5195, 0, 604, 4571/ +data (gchtab(i), i=1936,1940) / 4506, 4505, 4568, 4759, 4951/ +data (gchtab(i), i=1941,1945) / 663, 4502, 4373, 4307, 4305/ +data (gchtab(i), i=1946,1950) / 4431, 4622, 4814, 663, 4566/ +data (gchtab(i), i=1951,1955) / 4437, 4371, 4369, 4495, 4622/ +data (gchtab(i), i=1956,1960) / 526, 4365, 4236, 4170, 4168/ +data (gchtab(i), i=1961,1965) / 4294, 4612, 4675, 4673, 4544/ +data (gchtab(i), i=1966,1970) / 4416, 526, 4429, 4300, 4234/ +data (gchtab(i), i=1971,1975) / 4232, 4358, 4612, 0, 860/ +data (gchtab(i), i=1976,1980) / 4544, 924, 4480, 17, 4115/ +data (gchtab(i), i=1981,1985) / 4245, 4437, 4500, 4498, 4429/ +data (gchtab(i), i=1986,1990) / 4426, 4552, 4744, 4873, 5068/ +data (gchtab(i), i=1991,1995) / 5199, 277, 4436, 4434, 4365/ +data (gchtab(i), i=1996,2000) / 4362, 4424, 4551, 4743, 4872/ +data (gchtab(i), i=2001,2005) / 5002, 5133, 5199, 5333, 0/ +data (gchtab(i), i=2006,2010) / 604, 4571, 4506, 4505, 4568/ +data (gchtab(i), i=2011,2015) / 4759, 5079, 5080, 4887, 4629/ +data (gchtab(i), i=2016,2020) / 4435, 4240, 4173, 4171, 4233/ +data (gchtab(i), i=2021,2025) / 4423, 4613, 4675, 4673, 4608/ +data (gchtab(i), i=2026,2030) / 4480, 4417, 662, 4499, 4304/ +data (gchtab(i), i=2031,2035) / 4237, 4235, 4297, 4423, 0/ +data (gchtab(i), i=2036,2040) / 480, 4447, 4382, 4316, 4314/ +data (gchtab(i), i=2041,2045) / 4376, 4439, 4501, 4499, 4369/ +data (gchtab(i), i=2046,2050) / 351, 4381, 4379, 4441, 4504/ +data (gchtab(i), i=2051,2055) / 4566, 4564, 4498, 4240, 4494/ +data (gchtab(i), i=2056,2060) / 4556, 4554, 4488, 4423, 4357/ +data (gchtab(i), i=2061,2065) / 4355, 4417, 271, 4493, 4491/ +data (gchtab(i), i=2066,2070) / 4425, 4360, 4294, 4292, 4354/ +data (gchtab(i), i=2071,2075) / 4417, 4544, 0, 160, 4224/ +data (gchtab(i), i=2076,2080) / 544, 4608, 0, 224, 4447/ +data (gchtab(i), i=2081,2085) / 4510, 4572, 4570, 4504, 4439/ +data (gchtab(i), i=2086,2090) / 4373, 4371, 4497, 351, 4509/ +data (gchtab(i), i=2091,2095) / 4507, 4441, 4376, 4310, 4308/ +data (gchtab(i), i=2096,2100) / 4370, 4624, 4366, 4300, 4298/ +data (gchtab(i), i=2101,2105) / 4360, 4423, 4485, 4483, 4417/ +data (gchtab(i), i=2106,2110) / 399, 4365, 4363, 4425, 4488/ +data (gchtab(i), i=2111,2115) / 4550, 4548, 4482, 4417, 4288/ +data (gchtab(i), i=2116,2120) / 0, 338, 4240, 4430, 533/ +data (gchtab(i), i=2121,2125) / 4304, 4619, 208, 5392, 0/ +data (gchtab(i), i=2126,2130) / 284, 4251, 4185, 4183, 4245/ +data (gchtab(i), i=2131,2135) / 4372, 4500, 4629, 4695, 4697/ +data (gchtab(i), i=2136,2139) / 4635, 4508, 4380, 0/ diff --git a/sys/gio/fonts/greekc.txt b/sys/gio/fonts/greekc.txt new file mode 100644 index 00000000..3dbbf454 --- /dev/null +++ b/sys/gio/fonts/greekc.txt @@ -0,0 +1,96 @@ +2199 +2214 +2213 +2275 +2274 +2271 +2272 +2251 +2221 +2222 +8004 +8002 +8063 +8003 +2210 +8089 +2200 +2201 +2202 +2203 +2204 +2205 +2206 +2207 +2208 +2209 +8081 +2213 +8007 +8033 +8008 +8032 +2273 +2078 +8064 +2199 +2030 +8073 +2047 +2029 +733 +8090 +8079 +2199 +2037 +8075 +8077 +2041 +2042 +2034 +2271 +2044 +8090 +2046 +2078 +2050 +2040 +2049 +2199 +2223 +804 +2224 +2199 +8074 +8067 +2127 +2128 +2148 +2130 +2131 +2147 +2129 +2133 +2135 +8078 +2136 +2137 +2138 +2139 +2141 +2142 +2134 +2143 +2144 +2145 +2146 +2199 +2150 +2140 +2149 +2132 +2225 +8090 +2226 +8076 +2218 diff --git a/sys/gio/fonts/mkfont.c b/sys/gio/fonts/mkfont.c new file mode 100644 index 00000000..841d99f5 --- /dev/null +++ b/sys/gio/fonts/mkfont.c @@ -0,0 +1,199 @@ +#include + +#define DEBUG 0 +#define MASK 0x3F +#define SCALE 1.0 + +#define max(a,b) (a > b ? a : b) +#define min(a,b) (a < b ? a : b) +/* +#define XCOORD() ((*dp - 'R') + 9) +#define YCOORD() (('R' - *dp) + 14) +#define XCOORD() (max(0,min(20,((int)(((*dp - 'R') + 9)*SCALE+0.5))))) +#define XCOORD() (max(0,min(20,((int)(((*dp - 'R') - minx)*SCALE+0.5))))) +#define YCOORD() ((int)((('R' - *dp) + 13) * SCALE + 0.5)) +#define XCOORD() ((int)(((*dp - 'R') - minx) * SCALE + 0.5)) +#define YCOORD() (max(0,min(32,(((int)(('R' - *dp) + 13)*SCALE+0.5))))) +*/ +#define XCOORD() (max(0,((int)(((*dp - 'R') - minx - 2) * SCALE + 0.5)))) +#define YCOORD() (max(0,min(35,(((int)(('R' - *dp) + 16)*SCALE+0.5))))) +#define ENCODE(pen,x,y) ((int)(((pen<<12)|((x&MASK)<<6))|(y&MASK))) + +int chridx[200]; /* Character index table */ +int chrwid[200]; /* Character width table */ +int chrtab[5000]; /* Character stroke table */ + + +struct hershey_tab { + int num; /* hershey number */ + int length; /* length */ + char *code; /* stroke data string */ +} htab[] = { +#include "hershey.dat" +}; + +int encode(); + + +main (argc, argv) +int argc; +char *argv[]; +{ + register int i=0; + int minx, maxx, charnum=0, idx=0, hnum, hindex, hlength; + short x, y, pen, xspace, yspace; + char ch, *dp, *data; + + /* Read all the hershey numbers from standard input and build up a + * table of stroke data. + */ + ch = 32; + while (scanf ("%d", &hnum) != EOF) { + + chridx[charnum] = idx + 1; + + /* Get the index for the given number. */ + for (hindex=0; hnum != htab[hindex].num; hindex++) + ; + + hlength = htab[hindex].length; + dp = data = htab[hindex].code; + + if (DEBUG) + printf ("'%c' %4d: index=%4d len=%3d dlen=%3d %s\n", + ch, hnum, hindex, hlength, strlen(data), + (strlen(data) % 2) ? "ERROR" : ""); + + /* Now decode the stroke data into X-Y pairs, first pair is for + * proportional spacing. + */ + minx = (*dp - 'R'); dp++; + maxx = (*dp - 'R'); dp++; + chrwid[charnum++] = min (32, maxx - minx + 5); + + if (DEBUG) printf("\twidth (%02d) (%d,%d)\n", maxx-minx,minx,maxx); + + /* Next pair is the initial move. The Y coords are flipped + * for what we need so fix that every place we get a Yval. + */ + pen = 0; + x = XCOORD(); dp++; +x = (ch == '1' ? x-3: x); + y = YCOORD(); dp++; + chrtab[idx++] = ENCODE(pen, x, y); + + if (DEBUG) printf ("\tmove (%3d,%3d) '%s'\n", x, y, dp); + + /* The remainder of the codes are move/draw strokes. + */ + for (i=0; i < (hlength-2); i++) { + if (*dp == ' ') { + pen = 0; + x = XCOORD(); dp++; /* skip pen-up coords */ +x = (ch == '1' ? x-3: x); + y = YCOORD(); dp++; + i++; + } else + pen = 1; + x = XCOORD(); dp++; +x = (ch == '1' ? x-3: x); + y = YCOORD(); dp++; + + chrtab[idx++] = ENCODE(pen, x, y); + + if (DEBUG) + printf("\t%s (%3d,%3d) => %6d\n", + pen?"draw":"move", x, y, ENCODE(pen,x,y)); + } + chrtab[idx++] = ENCODE(0, 0, 0); + ch++; + } + + print_prologue (charnum, idx); + print_index (chridx, charnum); + printf ("\n\n# Width data.\n\n"); + print_widths (chrwid, charnum); + printf ("\n\n# Stroke data.\n\n"); + print_strokes (chrtab, idx); +} + + +print_index (idxtab, N) +int *idxtab, N; +{ + register int i, j, start=1, end=5; + + for (i=0; i < N; ) { + printf ("data (chridx(i), i=%03d,%03d) /", start, min(N,end)); + for (j=0; j < 5 && i < N; j++) + printf ("%5d%c", idxtab[i++], (j<4 && i + +# FP_EQUALD -- The following procedure is used to compare two double precision +# numbers for equality to within the machine precision for doubles. A simple +# comparison of the difference of the two numbers with the machine epsilon +# does not suffice unless the numbers are first normalized to near 1.0, the +# constant used to compute the machine epsilon (epsilon is the smallest number +# such that 1.0 + epsilon > 1.0). + +bool procedure fp_equald (x, y) + +double x, y +double x1, x2, normx, normy, tol +int ex, ey + +begin + # Check for the obvious first. + if (x == y) + return (true) + + # We can't normalize zero, so handle the zero operand cases first. + # Note that the case 0 equals 0 is handled above. + + if (x == 0.0D0 || y == 0.0D0) + return (false) + + # Normalize operands and do an epsilon compare. + call fp_normd (x, normx, ex) + call fp_normd (y, normy, ey) + + if (ex != ey) + return (false) + else { + tol = EPSILOND * 32.0D0 + x1 = 1.0D0 + abs (normx - normy) + x2 = 1.0D0 + tol + return (x1 <= x2) + } +end diff --git a/sys/gio/fpequalr.x b/sys/gio/fpequalr.x new file mode 100644 index 00000000..8e9a9354 --- /dev/null +++ b/sys/gio/fpequalr.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# FP_EQUALR -- The following procedure is used to compare two single precision +# numbers for equality to within the machine precision for single. A simple +# comparison of the difference of the two numbers with the machine epsilon +# does not suffice unless the numbers are first normalized to near 1.0, the +# constant used to compute the machine epsilon (epsilon is the smallest number +# such that 1.0 + epsilon > 1.0). + +bool procedure fp_equalr (x, y) + +real x, y +real x1, x2, normx, normy, tol +int ex, ey + +begin + # Check for the obvious first. + if (x == y) + return (true) + + # We can't normalize zero, so handle the zero operand cases first. + # Note that the case 0 equals 0 is handled above. + + if (x == 0.0D0 || y == 0.0D0) + return (false) + + # Normalize operands and do an epsilon compare. + call fp_normr (x, normx, ex) + call fp_normr (y, normy, ey) + + if (ex != ey) + return (false) + else { + tol = EPSILONR * 32.0 + x1 = 1.0E0 + abs (normx - normy) + x2 = 1.0E0 + tol + return (x1 <= x2) + } +end diff --git a/sys/gio/fpfixd.x b/sys/gio/fpfixd.x new file mode 100644 index 00000000..64a2f544 --- /dev/null +++ b/sys/gio/fpfixd.x @@ -0,0 +1,43 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# FP_FIXD -- The following procedure is equivalent to "int(x)", except that +# it preserves the most significant digits of x, when x is greater than the +# largest integer. For example, if an integer is 32 bits and X has a 58 bit +# mantissa, "int(x)" would cause nearly half the precision to be lost. +# +# Algorithm (x is assumed nonnegative): +# (1) find high, low x such that x = highx + lowx +# and highx contains the extra digits of precision. +# (2) subtract highx from x, and truncate the residual by assignment +# into a long integer. +# (3) add truncated lowx and highx to get high precision truncated +# double result. + +double procedure fp_fixd (x) + +double x +double absx, highx, scaledx +int expon +long longx, lowx + +begin + absx = abs (x) + scaledx = absx + expon = 0 + + while (scaledx > MAX_LONG) { + scaledx = scaledx / 10.0D0 + expon = expon + 1 + } + + longx = scaledx + highx = longx * (10.0D0 ** expon) + lowx = absx - highx + + if (x > 0) + return (highx + lowx) + else + return (-highx - lowx) +end diff --git a/sys/gio/fpfixr.x b/sys/gio/fpfixr.x new file mode 100644 index 00000000..fe67c5b8 --- /dev/null +++ b/sys/gio/fpfixr.x @@ -0,0 +1,43 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# FP_FIXR -- The following procedure is equivalent to "int(x)", except that +# it preserves the most significant digits of x, when x is greater than the +# largest integer. For example, if an integer is 32 bits and X has a 58 bit +# mantissa, "int(x)" would cause nearly half the precision to be lost. +# +# Algorithm (x is assumed nonnegative): +# (1) find high, low x such that x = highx + lowx +# and highx contains the extra digits of precision. +# (2) subtract highx from x, and truncate the residual by assignment +# into a long integer. +# (3) add truncated lowx and highx to get high precision truncated +# real or double result. + +real procedure fp_fixr (x) + +real x +real absx, highx, scaledx +int expon +long longx, lowx + +begin + absx = abs (x) + scaledx = absx + expon = 0 + + while (scaledx > MAX_LONG) { + scaledx = scaledx / 10.0E0 + expon = expon + 1 + } + + longx = scaledx + highx = longx * (10.0E0 ** expon) + lowx = absx - highx + + if (x > 0) + return (highx + lowx) + else + return (-highx - lowx) +end diff --git a/sys/gio/fpndgr.x b/sys/gio/fpndgr.x new file mode 100644 index 00000000..ae471e34 --- /dev/null +++ b/sys/gio/fpndgr.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# FP_NONDEGENR -- If two floating point numbers are equivalent to within the +# machine epsilon, adjust their values until a nondegenerate range is obtained. +# The boolean function returns true if it has to MAKE the range nondegenerate, +# i.e., if it modifies their values. + +bool procedure fp_nondegenr (x1, x2) + +real x1, x2 # range to be adjusted +int n +bool fp_equalr() + +begin + for (n=0; fp_equalr(x1,x2); n=n+1) { + x1 = x1 - max (abs(x1) * 0.01, 0.01) + x2 = x2 + max (abs(x2) * 0.01, 0.01) + } + + return (n > 0) +end diff --git a/sys/gio/fpnormd.x b/sys/gio/fpnormd.x new file mode 100644 index 00000000..067ef1e0 --- /dev/null +++ b/sys/gio/fpnormd.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# FP_NORMD -- Normalize a double precision number x to the value NORMX, in the +# range [1-10). EXPON is returned such that x = normx * (10.0d0 ** expon). + +procedure fp_normd (x, normx, expon) + +double x # number to be normalized +double normx # X normalized to the range 1-10 (output) +int expon # exponent of normalized X +double absx, tol + +begin + tol = EPSILOND * 10.0D0 + absx = abs (x) + expon = 0 + + if (absx > 0) { + while (absx < (1.0D0 - tol)) { + absx = absx * 10.0D0 + expon = expon - 1 + if (absx == 0.0D0) { # check for underflow to zero + normx = 0 + expon = 0 + return + } + } + while (absx >= (10.0D0 + tol)) { + absx = absx / 10.0D0 + expon = expon + 1 + } + } + + if (x < 0) + normx = -absx + else + normx = absx +end diff --git a/sys/gio/fpnormr.x b/sys/gio/fpnormr.x new file mode 100644 index 00000000..45ad3f2a --- /dev/null +++ b/sys/gio/fpnormr.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# FP_NORMR -- Normalize a single precision number x to the value NORMX, in the +# range [1-10). EXPON is returned such that x = normx * (10.0E0 ** expon). + +procedure fp_normr (x, normx, expon) + +real x # number to be normalized +real normx # X normalized to the range 1-10 (output) +int expon # exponent of normalized X +real absx, tol + +begin + tol = EPSILONR * 10.0 + absx = abs (x) + expon = 0 + + if (absx > 0) { + while (absx < (1.0E0 - tol)) { + absx = absx * 10.0E0 + expon = expon - 1 + if (absx == 0.0) { # check for underflow to zero + normx = 0 + expon = 0 + return + } + } + while (absx >= (10.0E0 + tol)) { + absx = absx / 10.0E0 + expon = expon + 1 + } + } + + if (x < 0) + normx = -absx + else + normx = absx +end diff --git a/sys/gio/gactivate.x b/sys/gio/gactivate.x new file mode 100644 index 00000000..6d3c8da7 --- /dev/null +++ b/sys/gio/gactivate.x @@ -0,0 +1,72 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# GACTIVATE -- Perform the initial activation of the workstation, i.e., +# connect to the graphics kernel and issue the GKI_OPENWS instruction to +# the kernel to physically open the workstation. + +procedure gactivate (gp, flags) + +pointer gp # graphics descriptor +int flags # AW_ bit flags; zero if no flags + +int junk, fd +pointer w, sp, devname + +extern zardbf() +int fstati(), grdwcs(), and(), locpr() +errchk gki_openws, gki_getwcs, gki_reactivatews + +begin + # If WS has already been opened, just make sure it is activated. + if (and (GP_GFLAGS(gp), GF_WSOPEN) != 0) { + if (and (GP_GFLAGS(gp), GF_WSACTIVE) == 0) { + call gki_reactivatews (GP_FD(gp), flags) + GP_GFLAGS(gp) = GP_GFLAGS(gp) + GF_WSACTIVE + } + return + } + + call smark (sp) + call salloc (devname, SZ_PATHNAME, TY_CHAR) + + fd = GP_FD(gp) + + # Physically open and activate the workstation. NOTE - the flags + # argument is currently ignored; this should be fixed at some point. + # The UI specification file name, if any, is passed as part of the + # logical device specification (a bit of a kludge, but it avoids + # changing the GKI datastream prototcol and hence obsoleting all the + # old graphics kernels). + + if (GP_UIFNAME(gp) != EOS) { + # gki_openws device = devname,uifname. + call sprintf (Memc[devname], SZ_PATHNAME, "%s,%s") + call pargstr (GP_DEVNAME(gp)) + call pargstr (GP_UIFNAME(gp)) + } else + call strcpy (GP_DEVNAME(gp), Memc[devname], SZ_PATHNAME) + + call gki_openws (fd, Memc[devname], GP_ACMODE(gp)) + + # If the device is being opened in APPEND mode retrieve the WCS + # from either the GIO code in the CL process (if talking to a + # process the FIO driver will not be the standard binary file + # driver) or from an auxiliary file if the device output is being + # spooled in a metafile. + + if (GP_ACMODE(gp) == APPEND) { + w = GP_WCSPTR(gp,1) + if (fstati (fd, F_DEVICE) != locpr (zardbf)) + call gki_getwcs (fd, Memi[w], LEN_WCSARRAY) + else iferr (junk = grdwcs(GP_DEVNAME(gp), Memi[w], LEN_WCSARRAY)) + ; + } + + GP_GFLAGS(gp) = GP_GFLAGS(gp) + (GF_WSOPEN+GF_WSACTIVE) + call sfree (sp) +end diff --git a/sys/gio/gadraw.x b/sys/gio/gadraw.x new file mode 100644 index 00000000..4d8ac8b8 --- /dev/null +++ b/sys/gio/gadraw.x @@ -0,0 +1,284 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +define MOVE 0 +define DRAW 1 + +# GADRAW -- Draw absolute. This is the primary line drawing primitive, used +# to transform and clip polylines, polymarkers, and polygons (fill area). +# Our function is to handle INDEFS, the normalization transformation, and +# clipping, building up a polyline in GKI coordinates. Each call processes +# a point of the input polyline, adding zero, one, or two points to the output +# clipped polyline, which is buffered internally in the static polyline buffer +# PL. Plotting an INDEF terminates the polyline and starts a new one, causing +# a gap to appear in the plotted polyline. Long polylines are broken up into +# shorter polylines to simplify buffering. The transformation parameters are +# computed and cached in the GPL common for maximum efficiency. + +procedure gadraw (gp, wx, wy) + +pointer gp # graphics descriptor +real wx, wy # absolute world coordinates of next point + +int i +real x, y +long mx, my +bool inbounds +include "gpl.com" + +begin + # Update cached transformation parameters if device changes or cache + # is invalidated by setting gp_out to null. If the WCS changes it + # is not necessary to flush the polyline but we must update the + # cached transformation parameters. + + if (gp != gp_out) { + call gpl_flush() + call gpl_cache (gp) + } else if (GP_WCS(gp) != wcs) + call gpl_cache (gp) + + # Break polyline (visible break in the plotted line) if point is + # indefinite. + + if (IS_INDEFR(wx) || IS_INDEFR(wy)) { + call gamove (gp, wx, wy) + return + } + + # Transform point (wx,wy) to long integer NDC coordinates in the range + # 0 to GKI_MAXNDC. This combines the WCS->NDC->GKI transformations into + # a single transformation and permits use of integer arithmetic for + # clipping. Long integer arithmetic is necessary to provide sufficient + # precision to represent GKI_MAXNDC**2, the largest possible integer + # value in an expression. + + if (xtran == LINEAR && ytran == LINEAR) { + # Optimize the case linear. + x = max (0.0, min (real(GKI_MAXNDC), + ((wx - wxorigin) * xscale) + mxorigin)) + y = max (0.0, min (real(GKI_MAXNDC), + ((wy - wyorigin) * yscale) + myorigin)) + } else { + # General case. + call gpl_wcstogki (gp, wx, wy, x, y) + } + + # Check to see if this is the first point of a new polyline. If so we + # must set the first physical point in the output polyline to the + # current position, making the current point the second physical point + # of the output polyline. If the current position is indefinite + # then we take the current point to define the current position and + # it is put into the polyline on the next call. + + if (op == 1) { + if (IS_INDEF(cx) || IS_INDEF(cy)) { + cx = x + cy = y + return + + } else { + # Place the current pen position in the polyline as the + # first point if it is inbounds. + + mx = cx + my = cy + if (my <= my2 && my >= my1 && mx <= mx2 && mx >= mx1) { + last_point_inbounds = true + pl[op] = mx + op = op + 1 + pl[op] = my + op = op + 1 + } else { + last_point_inbounds = false + do i = 1, 4 { + xs[i] = cx + ys[i] = cy + } + } + } + } + + # Update the current position, maintained in GKI coordinates to make + # the current position invariant with respect to changes in the + # current WCS. The current position is maintained in floating point + # to minimize the accumulation of errors in relative moves and draws. + + cx = x + cy = y + + # Convert to long integer metacode coords for clipping. + + mx = x + my = y + + # Clip at either the viewport boundary or the edge of the device screen, + # if clipping is "disabled". Clipping is performed in NDC space rather + # than world space because NDC space is simpler (mx1 < mx2, my1 < my2, + # no log scaling), and because we need to clip at the device screen + # boundary anyhow. If the boundary is crossed the polyline is broken. + # A line segment may lie entirely outside the viewport, entirely inside, + # may cross from inside to outside, from outside to inside, or may + # cross twice (cross two different boundaries). The clipping algorithm + # used (Harrington, 1983; Sutherland and Hodgman, 1974) clips at each + # of the four boundaries in sequence, using the clipped point from the + # previous iteration as input to the next. It isn't simple but neither + # is the problem. The code is optimized for the usual inbounds case. + # Clipped points are discarded. + + inbounds = (my <= my2 && my >= my1 && mx <= mx2 && mx >= mx1) + + if (inbounds && (last_point_inbounds || pl_pointmode == YES)) { + # Add point to polyline (the fast way). + pl[op] = mx + op = op + 1 + pl[op] = my + op = op + 1 + + } else if (pl_pointmode == NO) { + if (last_point_inbounds) { + # Update coords of last point drawn (necessary since we did + # not use the clipping code for inbounds points). + do i = 1, 4 { + xs[i] = pl[op-2] + ys[i] = pl[op-1] + } + } + call gpl_clipl (DRAW, mx, my) + } + + last_point_inbounds = inbounds + + # Break long polylines to avoid overflowing the polyline output + # buffer. The output buffer contains two cells for each output + # point (x,y pair). There must be space for at least two points + # (four cells) left in the buffer, since a single clip operation + # can add up to two points to the polyline. OP points to the next + # available cell. + + if (op > LEN_PLBUF - 2) + call gpl_flush() +end + + +# GPL_CLIPL -- Clip at left boundary. + +procedure gpl_clipl (pen, mx, my) + +int pen # move or draw +long mx, my # point to be clipped +int newpen +include "gpl.com" + +begin + # Does line cross boundary? + if ((mx >= mx1 && xs[1] < mx1) || (mx <= mx1 && xs[1] > mx1)) { + if (mx >= mx1) + newpen = MOVE + else + newpen = pen + call gpl_clipr (newpen, mx1, + (my - ys[1]) * (mx1 - mx) / (mx - xs[1]) + my) + } + + xs[1] = mx + ys[1] = my + + if (mx >= mx1) + call gpl_clipr (pen, mx, my) +end + + +# GPL_CLIPR -- Clip at right boundary. + +procedure gpl_clipr (pen, mx, my) + +int pen # move or draw +long mx, my # point to be clipped +int newpen +include "gpl.com" + +begin + # Does line cross boundary? + if ((mx <= mx2 && xs[2] > mx2) || (mx >= mx2 && xs[2] < mx2)) { + if (mx <= mx2) + newpen = MOVE + else + newpen = pen + call gpl_clipb (newpen, mx2, + (my - ys[2]) * (mx2 - mx) / (mx - xs[2]) + my) + } + + xs[2] = mx + ys[2] = my + + if (mx <= mx2) + call gpl_clipb (pen, mx, my) +end + + +# GPL_CLIPB -- Clip at bottom boundary. + +procedure gpl_clipb (pen, mx, my) + +int pen # move or draw +long mx, my # point to be clipped +int newpen +include "gpl.com" + +begin + # Does line cross boundary? + if ((my >= my1 && ys[3] < my1) || (my <= my1 && ys[3] > my1)) { + if (my >= my1) + newpen = MOVE + else + newpen = pen + call gpl_clipt (newpen, + (mx - xs[3]) * (my1 - my) / (my - ys[3]) + mx, my1) + } + + xs[3] = mx + ys[3] = my + + if (my >= my1) + call gpl_clipt (pen, mx, my) +end + + +# GPL_CLIPT -- Clip at top boundary and put the final clipped point(s) in +# the output polyline. Note that a "move" at this level does not affect +# the current position (cx,cy), since the vector endpoints have been clipped +# and the current position vector follows the unclipped vector points input +# by the user. + +procedure gpl_clipt (pen, mx, my) + +int pen # move or draw +long mx, my # point to be clipped +include "gpl.com" + +begin + # Does line cross boundary? + if ((my <= my2 && ys[4] > my2) || (my >= my2 && ys[4] < my2)) { + if (my <= my2 || pen == MOVE) + call gpl_flush() + pl[op] = (mx - xs[4]) * (my2 - my) / (my - ys[4]) + mx + op = op + 1 + pl[op] = my2 + op = op + 1 + } + + xs[4] = mx + ys[4] = my + + if (my <= my2) { + if (pen == MOVE) + call gpl_flush() + pl[op] = mx + op = op + 1 + pl[op] = my + op = op + 1 + } +end diff --git a/sys/gio/gamove.x b/sys/gio/gamove.x new file mode 100644 index 00000000..7c40d1b7 --- /dev/null +++ b/sys/gio/gamove.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GAMOVE -- Absolute move. Move the pen to the indicated position in +# preparation for a draw. + +procedure gamove (gp, x, y) + +pointer gp # graphics descriptor +real x, y # new position of pen +include "gpl.com" + +begin + if (op > 1) + call gpl_flush() + + if (IS_INDEF(x) || IS_INDEF(y)) { + # Set current position to indefinite. + cx = INDEF + cy = INDEF + } else { + # Set current position to (x,y) in GKI coordinates. + call gpl_wcstogki (gp, x, y, cx, cy) + } +end diff --git a/sys/gio/gascale.x b/sys/gio/gascale.x new file mode 100644 index 00000000..f2b29926 --- /dev/null +++ b/sys/gio/gascale.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GASCALE -- Scale the world coordinates of either the X or Y axis to fit the +# data vector. This is done by setting the WCS limits to the minimum and +# maximum pixel values of the data vector. The original WCS limits are +# overwritten. + +procedure gascale (gp, v, npts, axis) + +pointer gp # graphics descriptor +real v[ARB] # data vector +int npts # length of data vector +int axis # asis to be scaled (1=X, 2=Y) + +int start, i +real minval, maxval, pixval +pointer w + +begin + # Find first definite valued pixel. If entire data vector is + # indefinite we cannot perform our function and must abort. + + for (start=1; start <= npts; start=start+1) + if (!IS_INDEF (v[start])) + break + if (start > npts) + call syserr (SYS_GINDEF) + + minval = v[start] + maxval = minval + + # Compute min and max values of data vector. + do i = start+1, npts { + pixval = v[i] + if (!IS_INDEF(pixval)) + if (pixval < minval) + minval = pixval + else if (pixval > maxval) + maxval = pixval + } + + w = GP_WCSPTR (gp, GP_WCS(gp)) + + # Set the window limits. + switch (axis) { + case 1: + WCS_WX1(w) = minval + WCS_WX2(w) = maxval + case 2: + WCS_WY1(w) = minval + WCS_WY2(w) = maxval + default: + call syserr (SYS_GSCALE) + } + + WCS_FLAGS(w) = or (WCS_FLAGS(w), WF_DEFINED) + GP_WCSSTATE(gp) = MODIFIED + call gpl_reset() +end diff --git a/sys/gio/gcancel.x b/sys/gio/gcancel.x new file mode 100644 index 00000000..30e53ce5 --- /dev/null +++ b/sys/gio/gcancel.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GCANCEL -- Cancel any buffered graphics output (as far as possible). Should +# be called by interrupt handlers to avoid leaving GIO in a funny state +# following an interrupt. +# +# As far as possible, GKI instructions are built up in internal storage and +# written to the output file in a single write. This decreases the likliehood +# of leaving a botched instruction in the output stream in response to an +# interrupt. Do not call FSETI to cancel the file output because that will +# almost certainly guarantee a botched instruction. Instead, we discard any +# partially built polylines still in GPL storage and append the GKI_CANCEL to +# the output instruction stream. The cancel instruction is passed on to the +# graphics kernel which eventually calls FSETI to cancel its output file +# buffer (containing device instructions). If a metacode reader does detect +# a botched instruction it will scan forward for the next BOI to try to resync +# the instruction stream. + +procedure gcancel (gp) + +pointer gp # graphics descriptor +int and() + +begin + if (and (GP_GFLAGS(gp), GF_WSOPEN) != 0) { + call gki_cancel (GP_FD(gp)) + call gki_fflush (GP_FD(gp)) + } + call gfrinit (gp) +end diff --git a/sys/gio/gclear.x b/sys/gio/gclear.x new file mode 100644 index 00000000..a3a5d895 --- /dev/null +++ b/sys/gio/gclear.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GCLEAR -- Clear the screen and initialize all internal state variables to +# the original GOPEN state. Plots separated by calls to GCLEAR cannot affect +# each other. See also GFRAME and GRESET if a full state reset is not +# desired. + +procedure gclear (gp) + +pointer gp # graphics descriptor + +begin + call gactivate (gp, 0) + call gpl_flush() + call gki_clear (GP_FD(gp)) + call greset (gp, GR_RESETALL) +end diff --git a/sys/gio/gclose.x b/sys/gio/gclose.x new file mode 100644 index 00000000..a6802a0a --- /dev/null +++ b/sys/gio/gclose.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GCLOSE -- Close a graphics stream previously opened with GOPEN. Flush any +# buffered polyline output, output the close worstation metacode instruction, +# close the output stream, close the graphcap descriptor, and return all +# buffer space. + +procedure gclose (gp) + +pointer gp # graphics descriptor + +int fd +int and() + +begin + fd = GP_FD(gp) + + if (and (GP_GFLAGS(gp), GF_WSOPEN) != 0) { + call gflush (gp) + call gki_closews (fd, GP_DEVNAME(gp)) + + # If the output stream is a file rather than a standard graphics + # stream, write a WCS savefile to permit restoration of the WCS if + # the device is subsequently opened in APPEND mode. + + if (fd > STDPLOT) + call gwrwcs (GP_DEVNAME(gp), + Memi[GP_WCSPTR(gp,1)], LEN_WCSARRAY) + + # If the output file was opened by GOPEN (as indicated by the + # CLOSEFD flag), close the file. + + if (and (GP_GFLAGS(gp), GF_CLOSEFD) != 0) + call close (fd) + else + call flush (fd) + } + + call ttycdes (GP_TTY(gp)) + call mfree (gp, TY_STRUCT) + call gki_redir (fd, NULL, NULL, NULL) + call gexfls_clear (fd) +end diff --git a/sys/gio/gctran.x b/sys/gio/gctran.x new file mode 100644 index 00000000..3c804dc8 --- /dev/null +++ b/sys/gio/gctran.x @@ -0,0 +1,138 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GCTRAN -- Transform a point in world coordinate system WCS_A to world +# coordinate system WCS_B. The transformation is performed by transforming +# from WCS_A to NDC, followed by a transformation from NDC to WCS_B. The +# transformation parameters are cached for efficiency when transforming +# multiple points in the same pairs of coordinate systems. Three types of +# transformations are supported: linear, log, and "elog". The latter is +# a logarithmic function defined for all X, i.e., for negative as well as +# positive X. + +procedure gctran (gp, x1,y1, x2,y2, wcs_a, wcs_b) + +pointer gp # graphics descriptor +real x1, y1 # coords of point in WCS_A (input) +real x2, y2 # coords of point in WCS_B (output) +int wcs_a # input WCS +int wcs_b # output WCS + +int w, a +int wcsord, tran[2,2], wcs[2] +real morigin[2,2], worigin[2,2], scale[2,2], ds +real w1[2,2], w2[2,2], s1[2,2], s2[2,2], p1[2], p2[2] +pointer wp + +bool fp_nondegenr() +real elogr(), aelogr() + +begin + # Verify that the WCS has not changed since we were last called. + # WCSORD is a unique integer (ordinal) assigned by GIO each time a + # WCS is fixed. + + if (GP_WCSSTATE(gp) != FIXED || GP_WCSORD(gp) != wcsord) + wcs[1] = -1 + + # Verify that cached transformation parameters are up to date, and if + # not, recompute them. + + if (wcs[1] != wcs_a || wcs[2] != wcs_b) { + wcsord = GP_WCSORD(gp) + wcs[1] = wcs_a + wcs[2] = wcs_b + + # Copy the WCS parameters into 2-dim arrays so that we can use the + # same code for both axes. + + do w = 1, 2 { + wp = GP_WCSPTR (gp, wcs[w]) + tran[1,w] = WCS_XTRAN(wp) + tran[2,w] = WCS_YTRAN(wp) + + # If the window is degenerate enlarge the window until there + # is enough range to make a plot. + + if (fp_nondegenr (WCS_WX1(wp), WCS_WX2(wp))) + GP_WCSSTATE(gp) = MODIFIED + if (fp_nondegenr (WCS_WY1(wp), WCS_WY2(wp))) + GP_WCSSTATE(gp) = MODIFIED + + w1[1,w] = WCS_WX1(wp) + w2[1,w] = WCS_WX2(wp) + w1[2,w] = WCS_WY1(wp) + w2[2,w] = WCS_WY2(wp) + + s1[1,w] = WCS_SX1(wp) + s2[1,w] = WCS_SX2(wp) + s1[2,w] = WCS_SY1(wp) + s2[2,w] = WCS_SY2(wp) + } + + # Compute the transformation parameters for both axes and both + # world coordinate systems. + + do w = 1, 2 # w = wcs index + do a = 1, 2 { # a = axis + morigin[a,w] = s1[a,w] + ds = s2[a,w] - s1[a,w] + + if (tran[a,w] == LINEAR) { + worigin[a,w] = w1[a,w] + scale[a,w] = ds / (w2[a,w] - w1[a,w]) + } else if (tran[a,w] == LOG && w1[a,w] > 0 && w2[a,w] > 0) { + worigin[a,w] = log10 (w1[a,w]) + scale[a,w] = ds / (log10(w2[a,w]) - worigin[a,w]) + } else { + worigin[a,w] = elogr (w1[a,w]) + scale[a,w] = ds / (elogr(w2[a,w]) - worigin[a,w]) + } + } + } + + p1[1] = x1 + p1[2] = y1 + + # Forward Transformation. Transform P1 (point-A) in wcs_a to NDC + # coordinates, if the input WCS is not number zero (the NDC coordinate + # system). + + if (wcs_a != 0) + do a = 1, 2 { + if (tran[a,1] != LINEAR) + if (tran[a,1] == LOG) { + if (p1[a] <= 0) + p1[a] = INDEF + else + p1[a] = log10 (p1[a]) + } else + p1[a] = elogr (p1[a]) + p1[a] = ((p1[a] - worigin[a,1]) * scale[a,1]) + morigin[a,1] + } + + # Inverse Transformation. Transform point P1, now in NDC coordinates, + # to WCS-B. If WCS-B is zero (NDC), we need only copy the points. + + if (wcs_b == 0) { + p2[1] = p1[1] + p2[2] = p1[2] + } else { + do a = 1, 2 { + if (IS_INDEF (p1[a])) + p2[a] = INDEF + else { + p2[a] = (p1[a] - morigin[a,2]) / scale[a,2] + worigin[a,2] + if (tran[a,2] != LINEAR) + if (tran[a,2] == LOG) + p2[a] = 10.0 ** p2[a] + else + p2[a] = aelogr (p2[a]) + } + } + } + + x2 = p2[1] + y2 = p2[2] +end diff --git a/sys/gio/gcurpos.x b/sys/gio/gcurpos.x new file mode 100644 index 00000000..a0d4cb4d --- /dev/null +++ b/sys/gio/gcurpos.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GCURPOS -- Get the current position in world coordinates. The current +# position is maintained internally in GKI coordinates to make it invariant +# with respect to changes in the current WCS. + +procedure gcurpos (gp, x, y) + +pointer gp # graphics descriptor +real x, y # current position in current WCS (output) + +real aelogr() +include "gpl.com" + +begin + if (gp != gp_out || GP_WCS(gp) != wcs) + call gpl_cache (gp) + + if (IS_INDEF(cx) || IS_INDEF(cy)) { + x = INDEF + y = INDEF + + } else { + x = (cx - mxorigin) / xscale + wxorigin + if (xtran != LINEAR) + if (xtran == LOG) + x = 10.0 ** x + else + x = aelogr (x) + + y = (cy - myorigin) / yscale + wyorigin + if (ytran != LINEAR) + if (ytran == LOG) + y = 10.0 ** y + else + y = aelogr (y) + } +end diff --git a/sys/gio/gdeact.x b/sys/gio/gdeact.x new file mode 100644 index 00000000..f61f4133 --- /dev/null +++ b/sys/gio/gdeact.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GDEACTIVATE -- Deactivate the workstation, i.e., for an interactive device +# (graphics terminal) restore the terminal to text mode. This is similar to +# closing the workstation will gclose, except that the graphics state is +# retained and graphics i/o may be resumed following a subsequent call to +# greactivate. These calls are generally no-ops for noninteractive devices. + +procedure gdeactivate (gp, flags) + +pointer gp # graphics descriptor +int flags # action flags + +int and() +errchk gflush +errchk gki_deactivatews + +begin + if (and (GP_GFLAGS(gp), GF_WSOPEN) != 0) { + call gflush (gp) + call gki_deactivatews (GP_FD(gp), flags) + if (and (GP_GFLAGS(gp), GF_WSACTIVE) != 0) + GP_GFLAGS(gp) = GP_GFLAGS(gp) - GF_WSACTIVE + } +end diff --git a/sys/gio/gescape.x b/sys/gio/gescape.x new file mode 100644 index 00000000..c6a1bf63 --- /dev/null +++ b/sys/gio/gescape.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GESCAPE -- Pass a device dependent instruction on to the graphics kernel. +# A unique function code should be assigned each escape function. The graphics +# kernel will ignore escapes with unrecognized function codes. + +procedure gescape (gp, fn, instruction, nwords) + +pointer gp # graphics descriptor +int fn # function code (1 - 32767) +short instruction[ARB] # instruction to be transmitted +int nwords # length of instruction + +begin + call gpl_flush() + call gki_escape (GP_FD(gp), fn, instruction, nwords) +end diff --git a/sys/gio/gfill.x b/sys/gio/gfill.x new file mode 100644 index 00000000..4db5d117 --- /dev/null +++ b/sys/gio/gfill.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GFILL -- Fill area. Fill the area defined by the polygon (X[i],Y[i]) in the +# indicated style. + +procedure gfill (gp, x, y, npts, style) + +pointer gp # graphics descriptor +real x[ARB], y[ARB] # polygon +int npts # npts in polygon +int style # style for area fill + +pointer ap + +begin + call gpl_flush() + + ap = GP_FAAP(gp) + if (style != FA_STYLE(ap) || FA_STATE(ap) != FIXED) { + FA_STYLE(ap) = style + call gki_faset (GP_FD(gp), ap) + FA_STATE(ap) = FIXED + } + + call gpl_settype (gp, FILLAREA) + call gpline (gp, x, y, npts) + call gpl_settype (gp, POLYLINE) +end diff --git a/sys/gio/gflush.x b/sys/gio/gflush.x new file mode 100644 index 00000000..ef597da8 --- /dev/null +++ b/sys/gio/gflush.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GFLUSH -- Flush the graphics output. A simple call to the FIO flush does not +# suffice since the graphics data stream may be spread over three or more +# processes. Flush any buffered polyline output, append the GKI_FLUSH metacode +# instruction, and flush the FIO buffered metacode output. The other processes +# will take similar actions upon receipt of the GKI_FLUSH instruction. + +procedure gflush (gp) + +pointer gp # graphics descriptor + +begin + call gpl_flush() + call gki_flush (GP_FD(gp)) +end diff --git a/sys/gio/gframe.x b/sys/gio/gframe.x new file mode 100644 index 00000000..02a1e41e --- /dev/null +++ b/sys/gio/gframe.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GFRAME -- Clear the screen, but do not modify the internal state of GIO, +# other than to reset the WCS and attribute packet states to UNSET, to force +# retranmission to the graphics kernel. + +procedure gframe (gp) + +pointer gp # graphics descriptor + +begin + call gactivate (gp, 0) + call gpl_flush() + call gki_clear (GP_FD(gp)) + call gfrinit (gp) +end diff --git a/sys/gio/gfrinit.x b/sys/gio/gfrinit.x new file mode 100644 index 00000000..bf8181ed --- /dev/null +++ b/sys/gio/gfrinit.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GFRINIT -- Initialize the internal state variables of GIO for a new frame. +# The state of all the attribute packets is set to UNSET to force them to be +# retransmitted to the graphics kernel when i/o occurs. + +procedure gfrinit (gp) + +pointer gp # graphics descriptor +pointer ap + +begin + # Force retransmission of the WCS. + GP_WCSSTATE(gp) = UNSET + + # Force retransmission of the attribute packets. + ap = GP_PLAP(gp); PL_STATE(ap) = UNSET + ap = GP_PMAP(gp); PM_STATE(ap) = UNSET + ap = GP_FAAP(gp); FA_STATE(ap) = UNSET + ap = GP_TXAP(gp); TX_STATE(ap) = UNSET + ap = GP_TXAPCUR(gp); TX_STATE(ap) = UNSET + + call gpl_reset() +end diff --git a/sys/gio/ggcell.x b/sys/gio/ggcell.x new file mode 100644 index 00000000..1dfd7a40 --- /dev/null +++ b/sys/gio/ggcell.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GGCELL -- Get a cell array, i.e., a two dimensional array of pixels. If the +# resolution of the graphics device does not match that of the cell array the +# kernel is expected to compute the coordinates of each cell array pixel in +# device coordinates and return the value of the nearest device pixel as the +# cell array value. This equates to either subsampling or block replication +# depending on the relative scale of the two devices. See put cell array for +# additional information. + +procedure ggcell (gp, m, nx, ny, x1, y1, x2, y2) + +pointer gp # device descriptor +int nx, ny # size of pixel array +short m[nx,ny] # pixels +real x1, y1 # lower left corner of input window +real x2, y2 # upper right corner of input window + +real dy +int ly1, ly2, i +int sx1, sx2, sy1, sy2 +include "gpl.com" + +begin + # Flush any buffered polyline output. Make sure the wcs transformation + # in the cache is up to date. + + if (op > 1) + call gpl_flush() + else if (gp != gp_out || GP_WCS(gp) != wcs) + call gpl_cache (gp) + + # Transform cell window to GKI coordinates. The coordinate + # transformation must be linear. + + sx1 = (x1 - wxorigin) * xscale + mxorigin + sx2 = (x2 - wxorigin) * xscale + mxorigin + sy1 = (y1 - wyorigin) * yscale + myorigin + sy2 = (y2 - wyorigin) * yscale + myorigin + + dy = real (sy2 - sy1) / ny # height of a line in GKI coords + + # Read the cell array into M, one line at a time. Take care that the + # GKI integer value of ly1 of one line is the same as the ly2 value + # of the previous line, or there will be a blank line in the output + # image. + + do i = 1, ny { + ly1 = (i-1) * dy + sy1 + ly2 = (i ) * dy + sy1 + call gki_getcellarray (GP_FD(gp), m[1,i], nx,1, sx1,ly1, sx2,ly2) + } +end diff --git a/sys/gio/ggcur.x b/sys/gio/ggcur.x new file mode 100644 index 00000000..40da0a0f --- /dev/null +++ b/sys/gio/ggcur.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GGCUR -- Perform a graphics cursor read. The current graphics cursor is +# read and the cursor value is returned. On output, CN is the cursor number +# which was read, KEY is the key typed to terminate the cursor read, SX,SY +# are the NDC screen coordinates of the cursor, RASTER is the raster number +# or zero, and RX,RY are the raster-relative coordinates of the cursor. If +# the device does not support rasters or if the cursor is not in a rasters +# when read, RASTER is zero on output and RX,RY are the same as SX,SY. + +int procedure ggcur (gp, cn, key, sx, sy, raster, rx, ry) + +pointer gp #I graphics descriptor +int cn #O cursor which was read +int key #O key typed or EOF +real sx, sy #O screen position of cursor in NDC coordinates +int raster #O raster number +real rx, ry #O raster position of cursor in NDC coordinates + +int m_sx, m_sy +int m_rx, m_ry + +begin + call gflush (gp) + call gki_getcursor (GP_FD(gp), GP_CURSOR(gp), + cn, key, m_sx, m_sy, raster, m_rx, m_ry) + + sx = real(m_sx) / GKI_MAXNDC + sy = real(m_sy) / GKI_MAXNDC + rx = real(m_rx) / GKI_MAXNDC + ry = real(m_ry) / GKI_MAXNDC + + return (key) +end diff --git a/sys/gio/ggetb.x b/sys/gio/ggetb.x new file mode 100644 index 00000000..790da996 --- /dev/null +++ b/sys/gio/ggetb.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GGETB -- Get a boolean device parameter from the graphcap entry for the +# device. A boolean graphcap query tests if the named parameter exists. +# Boolean queries are permitted for any capability, regardless of its actual +# datatype. + +bool procedure ggetb (gp, cap) + +pointer gp # graphics descriptor +char cap[ARB] # name of device capability +bool ttygetb() + +begin + return (ttygetb (GP_TTY(gp), cap)) +end diff --git a/sys/gio/ggeti.x b/sys/gio/ggeti.x new file mode 100644 index 00000000..31f81bb2 --- /dev/null +++ b/sys/gio/ggeti.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GGETI -- Get the integer value of an device parameter from the graphcap +# entry for the device. Zero is returned if the device does not have the +# named parameter. + +int procedure ggeti (gp, cap) + +pointer gp # graphics descriptor +char cap[ARB] # name of device capability +int ttygeti() + +begin + return (ttygeti (GP_TTY(gp), cap)) +end diff --git a/sys/gio/ggetr.x b/sys/gio/ggetr.x new file mode 100644 index 00000000..b595793c --- /dev/null +++ b/sys/gio/ggetr.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GGETR -- Get the real value of an device parameter from the graphcap entry +# for the device. Zero is returned if the device does not have the +# named parameter. + +real procedure ggetr (gp, cap) + +pointer gp # graphics descriptor +char cap[ARB] # name of device capability +real ttygetr() + +begin + return (ttygetr (GP_TTY(gp), cap)) +end diff --git a/sys/gio/ggets.x b/sys/gio/ggets.x new file mode 100644 index 00000000..d82c7090 --- /dev/null +++ b/sys/gio/ggets.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GGETS -- Get the string value of a device parameter from the graphcap entry +# for the device. The null string is returned if no entry is found for the +# named capability, or if the capability exists but the value field is null. +# The value of any parameter may be returned as a string, regardless of its +# datatype. Escape sequences are converted to control codes in the output +# string. + +int procedure ggets (gp, cap, outstr, maxch) + +pointer gp # graphics descriptor +char cap[ARB] # name of device capability +char outstr[ARB] # output string +int maxch +int ttygets() + +begin + return (ttygets (GP_TTY(gp), cap, outstr, maxch)) +end diff --git a/sys/gio/ggscale.x b/sys/gio/ggscale.x new file mode 100644 index 00000000..76dffa2a --- /dev/null +++ b/sys/gio/ggscale.x @@ -0,0 +1,64 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GGSCALE -- Get the WCS scale in world coords per NDC at the point (x,y). +# Used to convert offsets or sizes in NDC coordinates into world coordinates, +# and vice versa. If log scaling is in use we can only locally approximate +# the scale. + +procedure ggscale (gp, x, y, dx, dy) + +pointer gp # graphics descriptor +real x, y # point for which scale is desired +real dx, dy # scale wcs/nds (output) + +pointer w +real x1, x2, y1, y2, xs, ys, elog_scale +real log10e, elogr() +data log10e /0.434294482/ + +begin + w = GP_WCSPTR(gp,GP_WCS(gp)) + + x1 = WCS_WX1(w) + x2 = WCS_WX2(w) + y1 = WCS_WY1(w) + y2 = WCS_WY2(w) + xs = WCS_SX2(w) - WCS_SX1(w) + ys = WCS_SY2(w) - WCS_SY1(w) + + switch (WCS_XTRAN(w)) { + case LOG: + dx = (x / log10e) * log10 (x2 / x1) / xs + case ELOG: + # The following is an approximation. + elog_scale = (elogr(x2) - elogr(x1)) / xs + if (x < 10.0) + dx = (-x / log10e) * elog_scale + else if (x > 10.0) + dx = (x / log10e) * elog_scale + else + dx = (10. / log10e) * elog_scale + default: + # LINEAR + dx = (x2 - x1) / xs + } + + switch (WCS_YTRAN(w)) { + case LOG: + dy = (y / log10e) * log10 (y2 / y1) / ys + case ELOG: + # The following is an approximation. + elog_scale = (elogr(y2) - elogr(y1)) / ys + if (y < 10.0) + dy = (-y / log10e) * elog_scale + else if (y > 10.0) + dy = (y / log10e) * elog_scale + else + dy = (10. / log10e) * elog_scale + default: + # LINEAR + dy = (y2 - y1) / ys + } +end diff --git a/sys/gio/ggview.x b/sys/gio/ggview.x new file mode 100644 index 00000000..486035b6 --- /dev/null +++ b/sys/gio/ggview.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GGVIEW -- Get the viewport of the current WCS. + +procedure ggview (gp, x1, x2, y1, y2) + +pointer gp # graphics descriptor +real x1, x2 # range of NDC in X (output) +real y1, y2 # range of NDC in Y (output) +pointer w + +begin + w = GP_WCSPTR (gp, GP_WCS(gp)) + + x1 = WCS_SX1(w) + x2 = WCS_SX2(w) + y1 = WCS_SY1(w) + y2 = WCS_SY2(w) +end diff --git a/sys/gio/ggwind.x b/sys/gio/ggwind.x new file mode 100644 index 00000000..4972fb75 --- /dev/null +++ b/sys/gio/ggwind.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GGWIND -- Get the window into world coordinates of the current WCS. + +procedure ggwind (gp, x1, x2, y1, y2) + +pointer gp # graphics descriptor +real x1, x2 # range of world coords in X (output) +real y1, y2 # range of world coords in Y (output) +pointer w + +begin + call gactivate (gp, 0) + w = GP_WCSPTR (gp, GP_WCS(gp)) + + x1 = WCS_WX1(w) + x2 = WCS_WX2(w) + y1 = WCS_WY1(w) + y2 = WCS_WY2(w) +end diff --git a/sys/gio/gim/README b/sys/gio/gim/README new file mode 100644 index 00000000..3c98b736 --- /dev/null +++ b/sys/gio/gim/README @@ -0,0 +1,215 @@ +GIM -- GIO graphics imaging library. This is a developmental library based +on GIO escapes, providing IRAF applications with access to the Gterm widget +imaging functions. This library is tied directly to the Gterm widget and is +expected to be replaced by a more general imaging library in the future. + +This library is intended only for clients that need to directly access the +imaging functions in the Gterm widget for full control over the imaging +capabilities of the Gterm widget. Applications which merely need to display +an image as part of a more complex graphic would probably be better off +using the more device independent gpcell (put cell-array) and gpcmap (put +colormap) calls. + + +The following functions are direct RPC calls to the corresponding Gt-prefixed +imaging functions in the Gterm widget. + + gim_rasterinit (gp) + gim_createraster (gp, raster, type, width, height, depth) + gim_destroyraster (gp, raster) + exists = gim_queryraster (gp, raster, type, width, height, depth) + gim_setraster (gp, raster) # see gseti(gp,G_RASTER,n) + + gim_writepixels (gp, raster, data, nbits, x1, y1, nx, ny) + gim_readpixels (gp, raster, data, nbits, x1, y1, nx, ny) + gim_refreshpix (gp, raster, ct, x1, y1, nx, ny) + gim_setpixels (gp, raster, ct, x1, y1, nx, ny, color, rop) + + gim_writecolormap (gp, colormap, first, nelem, r, g, b) + nelem = gim_readcolormap (gp, colormap, first, maxelem, r, g, b) + gim_loadcolormap (gp, colormap, offset, slope) + gim_freecolormap (gp, colormap) + gim_iomapwrite (gp, iomap, first, nelem) + gim_iomapread (gp, iomap, first, nelem) + + gim_initmappings (gp) + gim_freemapping (gp, mapping) + gim_copyraster (gp, rop, src,st,sx,sy,sw,sh, dst,dt,dx,dy,dw,dh) + gim_setmapping (gp, mapping, rop, + src,st,sx,sy,sw,sh, dst,dt,dx,dy,dw,dh) + status = gim_getmapping (gp, mapping, rop, + src,st,sx,sy,sw,sh, dst,dt,dx,dy,dw,dh) + gim_enablemapping (gp, mapping, refresh) + gim_disablemapping (gp, mapping, erase) + gim_refreshmapping (gp, mapping) + +The following Gterm widget imaging functions have no analogue in the GIM +imaging interface, but can be called from within GUI code. These functions +are not implemented at the GIM level either because they are not essential +and would be too inefficient to be worth using via RPC, or because they +access resources available only to GUI code. + + GtAssignRaster (gt, raster, drawable) + pixmap = GtExtractPixmap (gt, src, ct, x, y, width, height) + GtInsertPixmap (gt, pixmap, dst, ct, x, y, width, height) + raster = GtSelectRaster (gt, dras, dt, dx, dy, rt, rx, ry, mapping) + raster = GtNextRaster (gt) + raster = GtGetRaster (gt) + n = GtNRasters (gt) + pixel = GtGetClientPixel (gt, gterm_pixel) + mapping = GtNextMapping (gt) + active = GtActiveMapping (gt, mapping) + + +The following messaging routines are also defined by the GIO interface. +These are used to set the values of UI parameters (i.e., send messages to +the user interface). + + gmsg (gp, object, message) + gmsg[bcsilrdx] (gp, object, value) + gmprintf (gp, object, format) + + +The imaging model of the Gterm widget defines the following key object or +data types: rasters, mappings, and colors. + + raster A raster is a MxN array of pixels. At present pixels are 8 + bits deep but hooks are built in to the interface to expand + this in the future. Pixel values are indices into the Gterm + virtual colormap, with values starting at zero. A raster + may be any size. A raster is merely a two-dimensional array + in the graphics server; it is not displayed unless mapped. + An exception is raster zero, which is the graphics window. + Rasters are referred to by number, starting with zero. + Initially only raster zero exists; new rasters are created + with gim_createraster. Space for rasters may be allocated + either in the graphics server, or in the X server. This has + implications on performance but is otherwise transparent to + the client. By default rasters are allocated in the + graphics server, i.e., in the X client. + + mapping A mapping defines a projection of a rectangle of the source + raster onto a rectangle of the destination raster. Mappings + may be either enabled (active) or disabled. When a mapping + is enabled, any change to a pixel in the source rect will + cause the corresponding pixels in the destination rect to be + updated. Mappings are referred to by number starting with + one. Initially no mappings are defined. If the size of the + input and output rect is not the same the input rect will be + scaled by pixel replication or subsampling to fill the + output rect. If the argument DW or DH of the destination + rect is negative, the image will be flipped around the + corresponding axis when copied to the destination; the + region of the destination drawn into is the same in either + case. Multiple mappings may reference the same source or + destination raster. Mappings are refreshed in order by the + mapping number. Modifying a mapping causes the changed + regions of the destination rect to be refreshed. + + color The gterm widget provides a fixed number of preassigned colors + corresponding to pixel values 0 through 9. 0 is the background + color, 1 is the foreground color, and 2-9 (8 colors) are + arbitrary colors defined by Gterm widget resources. These + static colors are normally used to draw the background, frame, + axes, titles, etc. of a plot, or to draw color graphics within + the drawing area. The advantage of static colors is that they + are shared with other X clients, and the values of these + colors may be assigned by the user to personalize the way + plots look. + + The gterm widget also allows any number (up to about 200 or + so) additional colors to be defined at runtime by the client + application. These color values start at pixel value 10 and + go up to the maximum pixel value assigned by the client. The + client application allocates colors with gim_writecolormap. + Attempts to overwrite the values of the static colors are + ignored. The values of already allocated colors may be + changed dynamically at runtime using gim_writecolormap to + write the desired range of color values. + + Applications should not assume that there are 10 static + colors and 200 or so allocatable colors. The graphcap entry + for the logical device in use defines these parameters for + the device. Alternatively, the readcolormap call may be + used to dynamically determine how many colors the server has + preallocated when the application starts up. + + An image may use either static and dyamic pixel values or + both types of values, but in most cases imaging applications + involve smoothly shaded surfaces hence will require + dyamically assigned private colors. + + If for some reason the client application cannot use the + gterm widget color model, the IOMAP feature can be used to + make the widget appear to have some externally defined + (i.e., client defined) color model. + + +The maximum number of rasters and maximum number of mappings is defined by +Gterm widget resources (e.g. in the GUI file) when the graphics application +starts up. The maximum values should be much larger than most applications +require. Applications should allocate raster or mapping numbers +sequentially starting at 1 (more or less) to avoid running out of raster or +mapping descriptors. + +The {read|write}pixels routines in the GIM interface operate directly on +raster pixels. The mapping routines support two alternative coordinate +systems, raster pixels and NDC (normalized device coordinates), as indicated +by the ST or DT argument (source or destination coordinate type). Note +that the origin of the pixel coordinate system is the upper left corner of +the display window (consistent with most graphics systems), whereas the origin +of the NDC coordinate system is the lower left corner (consistent with IRAF). + +Pixel coordinates allow precise control of imaging but require the +application to know the window size, and may result in complications e.g. if +the window is resized. NDC coordinates pretty much guarantee that a mapping +will involve sampling, hence are not the most efficient, but the graphics +will be drawn correctly no matter how the window is resized and for most +applications the performance difference is negligible. Most applications +should use NDC coordinates for raster 0 (the display window), and pixel +coordinates for rasters 1-N. + +Although the size of rasters 1 and higher are defined by the client +application, the size of raster zero, the actual gterm display window, is +subject to the constraints of the window system. The client can attempt to +reset the size of the gterm window using gim_createraster with raster=0, +however the Gterm widget, UI containing the gterm widget, and the window +manager are all free to deny such a request. gim_queryraster should be +called to determine the actual size of the window one will be drawing into. + + +EXAMPLE + + A simple example of an imaging application might download an image and +display it in the gterm window, filling the window. This could be done as +follows (following a GOPEN and other GIO calls to prepare the drawing surface). + + gim_createraster Create raster 1 the size of the pixel array + to be displayed. This need not be the same + as the size of the gterm display window. + + gim_setmapping Define a mapping between raster 1 and raster 0, + the display window, using NDC coordinates to + define the region of the display window to be + filled. The mapping number is arbitrary but + mappings should normally be allocated starting + with 1. The mapping is automatically enabled + when first defined. + + gim_writecolormap (Optional). Define the pixel value to RGB + color assignments for the image pixels. + + gim_writepixels This routine is called one or more times to + write pixels into raster 1. At most 32K + pixels (minus a bit for the GKI headers) can + be written in each call. As each write is + made the affected region of the display + window will be updated. + +Alternatively, one could write the pixels and then define the mapping, to +cause the entire image to be displayed at once. + +Note that the GIM calls can be combined with normal GIO graphics to draw text +and graphics around or on top of an image region. The order in which drawing +operations occur is important, e.g., to draw graphics or text on top of an +image the image should be drawn first. diff --git a/sys/gio/gim/gimcpras.x b/sys/gio/gim/gimcpras.x new file mode 100644 index 00000000..ea1ab32f --- /dev/null +++ b/sys/gio/gim/gimcpras.x @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GIM_COPYRASTER -- Copy a portion of the source raster to a rectangular +# region of the destination raster. + +procedure gim_copyraster (gp, rop, src,st,sx,sy,sw,sh, dst,dt,dx,dy,dw,dh) + +pointer gp #I graphics descriptor +int rop #I rasterop +int src #I source raster +int st #I coordinate type for source raster +real sx,sy,sw,sh #I source rect +int dst #I destination raster +int dt #I coordinate type for destination raster +real dx,dy,dw,dh #I destination rect + +short gim[GIM_COPYRASTER_LEN] + +begin + gim[GIM_COPYRASTER_OP] = rop + gim[GIM_COPYRASTER_SR] = src + gim[GIM_COPYRASTER_ST] = st + + if (st == CT_PIXEL) { + gim[GIM_COPYRASTER_SX] = sx + gim[GIM_COPYRASTER_SY] = sy + gim[GIM_COPYRASTER_SW] = sw + gim[GIM_COPYRASTER_SH] = sh + } else { + gim[GIM_COPYRASTER_SX] = sx * GKI_MAXNDC + gim[GIM_COPYRASTER_SY] = sy * GKI_MAXNDC + gim[GIM_COPYRASTER_SW] = nint (sw * GKI_MAXNDC) + gim[GIM_COPYRASTER_SH] = nint (sh * GKI_MAXNDC) + } + + gim[GIM_COPYRASTER_DR] = dst + gim[GIM_COPYRASTER_DT] = dt + + if (dt == CT_PIXEL) { + gim[GIM_COPYRASTER_DX] = dx + gim[GIM_COPYRASTER_DY] = dy + gim[GIM_COPYRASTER_DW] = dw + gim[GIM_COPYRASTER_DH] = dh + } else { + gim[GIM_COPYRASTER_DX] = dx * GKI_MAXNDC + gim[GIM_COPYRASTER_DY] = dy * GKI_MAXNDC + gim[GIM_COPYRASTER_DW] = nint (dw * GKI_MAXNDC) + gim[GIM_COPYRASTER_DH] = nint (dh * GKI_MAXNDC) + } + + call gescape (gp, GIM_COPYRASTER, gim, GIM_COPYRASTER_LEN) +end diff --git a/sys/gio/gim/gimcrras.x b/sys/gio/gim/gimcrras.x new file mode 100644 index 00000000..9372f85f --- /dev/null +++ b/sys/gio/gim/gimcrras.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GIM_CREATERASTER -- Create, recreate, or resize a raster. + +procedure gim_createraster (gp, raster, type, width, height, depth) + +pointer gp #I graphics descriptor +int raster #I raster number (0 is display window) +int type #I raster type (normal,ximage,pixmap) +int width #I raster width in pixels +int height #I raster height in pixels +int depth #I raster depth, bits per pixel + +short gim[GIM_CREATERASTER_LEN] + +begin + gim[GIM_CREATERASTER_RN] = raster + gim[GIM_CREATERASTER_RT] = type + gim[GIM_CREATERASTER_NX] = width + gim[GIM_CREATERASTER_NY] = height + gim[GIM_CREATERASTER_BP] = depth + + call gescape (gp, GIM_CREATERASTER, gim, GIM_CREATERASTER_LEN) +end diff --git a/sys/gio/gim/gimderas.x b/sys/gio/gim/gimderas.x new file mode 100644 index 00000000..9a492759 --- /dev/null +++ b/sys/gio/gim/gimderas.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GIM_DESTROYRASTER -- Destroy a raster. + +procedure gim_destroyraster (gp, raster) + +pointer gp #I graphics descriptor +int raster #I raster number (0 is display window) + +short gim[GIM_DESTROYRASTER_LEN] + +begin + gim[GIM_DESTROYRASTER_RN] = raster + call gescape (gp, GIM_DESTROYRASTER, gim, GIM_DESTROYRASTER_LEN) +end diff --git a/sys/gio/gim/gimdsmap.x b/sys/gio/gim/gimdsmap.x new file mode 100644 index 00000000..a1618413 --- /dev/null +++ b/sys/gio/gim/gimdsmap.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GIM_DISABLEMAPPING -- Disable a previously defined mapping. Disabling a +# mapping does not automatically erase the mapping unless the erase flag +# is set. + +procedure gim_disablemapping (gp, mapping, erase) + +pointer gp #I graphics descriptor +int mapping #I mapping to be defined or edited +int erase #I erase flag + +short gim[GIM_DISABLEMAPPING_LEN] + +begin + gim[GIM_DISABLEMAPPING_MP] = mapping + gim[GIM_DISABLEMAPPING_FL] = erase + call gescape (gp, GIM_DISABLEMAPPING, gim, GIM_DISABLEMAPPING_LEN) +end diff --git a/sys/gio/gim/gimenmap.x b/sys/gio/gim/gimenmap.x new file mode 100644 index 00000000..02e9af3b --- /dev/null +++ b/sys/gio/gim/gimenmap.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GIM_ENABLEMAPPING -- Enable a previously defined mapping. Enabling a +# mapping does not automatically refresh the destination unless the refresh +# flag is set (refresh=YES). + +procedure gim_enablemapping (gp, mapping, refresh) + +pointer gp #I graphics descriptor +int mapping #I mapping to be defined or edited +int refresh #I refresh flag + +short gim[GIM_ENABLEMAPPING_LEN] + +begin + gim[GIM_ENABLEMAPPING_MP] = mapping + gim[GIM_ENABLEMAPPING_FL] = refresh + call gescape (gp, GIM_ENABLEMAPPING, gim, GIM_ENABLEMAPPING_LEN) +end diff --git a/sys/gio/gim/gimfcmap.x b/sys/gio/gim/gimfcmap.x new file mode 100644 index 00000000..9194e9bf --- /dev/null +++ b/sys/gio/gim/gimfcmap.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GIM_FREECOLORMAP -- Free a colormap. + +procedure gim_freecolormap (gp, colormap) + +pointer gp #I graphics descriptor +int colormap #I colormap number + +short gim[GIM_FREECMAP_LEN] + +begin + gim[GIM_FREECMAP_MP] = colormap + call gescape (gp, GIM_FREECMAP, gim, GIM_FREECMAP_LEN) +end diff --git a/sys/gio/gim/gimfmap.x b/sys/gio/gim/gimfmap.x new file mode 100644 index 00000000..f69355a4 --- /dev/null +++ b/sys/gio/gim/gimfmap.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GIM_FREEMAPPING -- Free a mapping. + +procedure gim_freemapping (gp, mapping) + +pointer gp #I graphics descriptor +int mapping #I mapping number + +short gim[GIM_FREEMAPPING_LEN] + +begin + gim[GIM_FREEMAPPING_MP] = mapping + call gescape (gp, GIM_FREEMAPPING, gim, GIM_FREEMAPPING_LEN) +end diff --git a/sys/gio/gim/gimgetmap.x b/sys/gio/gim/gimgetmap.x new file mode 100644 index 00000000..c58bae0d --- /dev/null +++ b/sys/gio/gim/gimgetmap.x @@ -0,0 +1,85 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include + +# GIM_GETMAPPING -- Get the parameters defining a mapping. The function value +# is YES if the mapping is defined and enabled and NO if the mapping is +# defined but not enabled. If the mapping is not defined ERR is returned. + +int procedure gim_getmapping (gp, mapping, rop, + src,st,sx,sy,sw,sh, dst,dt,dx,dy,dw,dh) + +pointer gp #I graphics descriptor +int mapping #I mapping to be queried +int rop #O rasterop +int src #O source raster +int st #O coordinate type for source raster +int sx,sy,sw,sh #O source rect +int dst #O destination raster +int dt #O coordinate type for destination raster +int dx,dy,dw,dh #O destination rect + +int nchars, nread +short gim[GIM_GETMAPPING_LEN] +short retval[GIM_RET_GMAP_LEN] +errchk gescape, flush, read, syserrs +int read(), btoi() + +begin + call gpl_flush() + gim[GIM_GETMAPPING_MP] = mapping + call gescape (gp, GIM_GETMAPPING, gim, GIM_GETMAPPING_LEN) + call flush (GP_FD(gp)) + + # This assumes a normal stream type GKI connection. + nchars = GIM_RET_GMAP_LEN * SZ_SHORT + nread = read (GP_FD(gp), retval, nchars) + call fseti (GP_FD(gp), F_CANCEL, OK) + if (nread != nchars) + call syserrs (SYS_FREAD, "gim_getmapping") + + # EN=0 not defined, EN=1 defined not enabled, EN=2 defined enabled. + if (retval[GIM_RET_GMAP_EN] == 0) + return (ERR) + else { + rop = retval[GIM_RET_GMAP_OP] + + src = retval[GIM_RET_GMAP_SR] + st = retval[GIM_RET_GMAP_ST] + + if (st == CT_PIXEL) { + sx = retval[GIM_RET_GMAP_SX] + sy = retval[GIM_RET_GMAP_SY] + sw = retval[GIM_RET_GMAP_SW] + sh = retval[GIM_RET_GMAP_SH] + } else { + sx = real (retval[GIM_RET_GMAP_SX]) / GKI_MAXNDC + sy = real (retval[GIM_RET_GMAP_SY]) / GKI_MAXNDC + sw = real (retval[GIM_RET_GMAP_SW]) / GKI_MAXNDC + sh = real (retval[GIM_RET_GMAP_SH]) / GKI_MAXNDC + } + + dst = retval[GIM_RET_GMAP_SR] + dt = retval[GIM_RET_GMAP_DT] + + if (dt == CT_PIXEL) { + dx = retval[GIM_RET_GMAP_DX] + dy = retval[GIM_RET_GMAP_DY] + dw = retval[GIM_RET_GMAP_DW] + dh = retval[GIM_RET_GMAP_DH] + } else { + dx = real (retval[GIM_RET_GMAP_DX]) / GKI_MAXNDC + dy = real (retval[GIM_RET_GMAP_DY]) / GKI_MAXNDC + dw = real (retval[GIM_RET_GMAP_DW]) / GKI_MAXNDC + dh = real (retval[GIM_RET_GMAP_DH]) / GKI_MAXNDC + } + + } + + return (btoi (retval[GIM_RET_GMAP_EN] == 2)) +end diff --git a/sys/gio/gim/gimimap.x b/sys/gio/gim/gimimap.x new file mode 100644 index 00000000..2c4a5d28 --- /dev/null +++ b/sys/gio/gim/gimimap.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GIM_INITMAPPINGS -- Initialize the Gterm widget raster mappings. + +procedure gim_initmappings (gp) + +pointer gp #I graphics descriptor + +begin + call gescape (gp, GIM_INITMAPPINGS, 0, GIM_INITMAPPINGS_LEN) +end diff --git a/sys/gio/gim/gimlcmap.x b/sys/gio/gim/gimlcmap.x new file mode 100644 index 00000000..afcd9045 --- /dev/null +++ b/sys/gio/gim/gimlcmap.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# GIM_LOADCOLORMAP -- Load a colormap into the display (hardware) colormap. +# Any number of colormaps may be defined, but only one may be loaded at a +# time. A linear transformation may optionally be applied to the (normalized) +# colormap when it is loaded. Set offset=0.5, slope=1.0 to load the colormap +# without scaling. A negative slope inverts the image. +# +# The offset refers to the center of the mapped region of the transfer +# function, which is why the center value is at 0.5. For example, if the +# range of raster pixel intensities is normalized to the range 0.0 to 1.0, +# then a transfer function of [offset=0.3,slope=3.0] will display the region +# of intenstities centered around the normalized intenstity of 0.3, with a +# contrast of 3.0 (the screen intensity changes 3 units for a unit change in +# raster pixel intensity). The transfer function [offset=0.3,slope=-3.0] +# will display the same range of pixel intensitites, but with a negative +# contrast. The transfer function [offset=0.5,slope=1.0] has intercepts +# of [0,0] and [1,1] hence it displays the full range of raster pixel +# intensities - the input colormap is used as is, without resampling. + +procedure gim_loadcolormap (gp, colormap, offset, slope) + +pointer gp #I graphics descriptor +int colormap #I colormap number (0 is display colormap) +real offset, slope #I linear transformation on colormap + +real veclen, scale +short gim[GIM_LOADCMAP_LEN] + +begin + scale = GIM_LOADCMAP_SCALE + gim[GIM_LOADCMAP_MP] = colormap + gim[GIM_LOADCMAP_OF] = ((GKI_MAXNDC + 1) / scale) * + max(-scale, min(scale, offset)) + + if (abs(slope) < EPSILONR) + veclen = GKI_MAXNDC + else { + veclen = GKI_MAXNDC + 1 + veclen = min (veclen / 2, veclen / abs(slope) / 2) + } + gim[GIM_LOADCMAP_DX] = veclen + gim[GIM_LOADCMAP_DY] = veclen * slope + + call gescape (gp, GIM_LOADCMAP, gim, GIM_LOADCMAP_LEN) +end diff --git a/sys/gio/gim/gimqras.x b/sys/gio/gim/gimqras.x new file mode 100644 index 00000000..fa8f5909 --- /dev/null +++ b/sys/gio/gim/gimqras.x @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# GIM_QUERYRASTER -- Query a raster. The function value (YES/NO) indicates +# whether or not the raster exists. If the raster exists, the raster type +# and size are returned as output arguments. + +int procedure gim_queryraster (gp, raster, type, width, height, depth) + +pointer gp #I graphics descriptor +int raster #I raster number (0 is display window) +int type #O raster type (ximage,pixmap) +int width #O raster width in pixels +int height #O raster height in pixels +int depth #O raster depth, bits per pixel + +int nchars, nread +short gim[GIM_QUERYRASTER_LEN] +short retval[GIM_RET_QRAS_LEN] +errchk gescape, flush, read, syserrs +int read() + +begin + call gpl_flush() + gim[GIM_QUERYRASTER_RN] = raster + call gescape (gp, GIM_QUERYRASTER, gim, GIM_QUERYRASTER_LEN) + call flush (GP_FD(gp)) + + # This assumes a normal stream type GKI connection. + nchars = GIM_RET_QRAS_LEN * SZ_SHORT + nread = read (GP_FD(gp), retval, nchars) + call fseti (GP_FD(gp), F_CANCEL, OK) + if (nread != nchars) + call syserrs (SYS_FREAD, "gim_queryraster") + + type = retval[GIM_RET_QRAS_RT] + width = retval[GIM_RET_QRAS_NX] + height = retval[GIM_RET_QRAS_NY] + depth = retval[GIM_RET_QRAS_BP] + + return (retval[GIM_RET_QRAS_EX]) +end diff --git a/sys/gio/gim/gimrasini.x b/sys/gio/gim/gimrasini.x new file mode 100644 index 00000000..56914746 --- /dev/null +++ b/sys/gio/gim/gimrasini.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GIM_RASTERINIT -- Initialize the Gterm widget imaging subsystem. Destroys +# any existing rasters, mappings, and dynamic colors. + +procedure gim_rasterinit (gp) + +pointer gp #I graphics descriptor + +begin + call gescape (gp, GIM_RASTERINIT, 0, GIM_RASTERINIT_LEN) +end diff --git a/sys/gio/gim/gimrcmap.x b/sys/gio/gim/gimrcmap.x new file mode 100644 index 00000000..8fb9f4d2 --- /dev/null +++ b/sys/gio/gim/gimrcmap.x @@ -0,0 +1,68 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# GIM_READCOLORMAP -- Read a segment of a colormap. The number of cells +# read is returned. The number of cells read may be less than the request +# size if the cells have not yet been allocated. + +int procedure gim_readcolormap (gp, colormap, first, maxelem, r, g, b) + +pointer gp #I graphics descriptor +int colormap #I colormap number (0=screen) +int first #I first colormap entry to be read +int maxelem #I number of elements to read +int r[ARB],g[ARB],b[ARB] #O RGB color values (0-255) + +pointer sp, cm, ip +int ncells, nret, nchars, i +short gim[GIM_READCMAP_LEN] +short retval[GIM_RET_RCMAP_LEN] +int read() + +string s_readcmap "gim_readcolormap" +errchk flush, read, syserrs + +begin + call smark (sp) + call gpl_flush() + + gim[GIM_READCMAP_MP] = colormap + gim[GIM_READCMAP_FC] = first + gim[GIM_READCMAP_NC] = maxelem + call gescape (gp, GIM_READCMAP, gim, GIM_READCMAP_LEN) + call flush (GP_FD(gp)) + + # Get return value instruction header. + nchars = GIM_RET_RCMAP_LEN * SZ_SHORT + if (read (GP_FD(gp), retval, nchars) != nchars) { + call fseti (GP_FD(gp), F_CANCEL, OK) + call syserrs (SYS_FREAD, s_readcmap) + } + + ncells = retval[GIM_RET_RCMAP_NC] + call salloc (cm, ncells * 3, TY_SHORT) + nret = min (ncells, maxelem) + + # Get the colormap data. + nchars = (ncells * 3) * SZ_SHORT + if (read (GP_FD(gp), Mems[cm], nchars) != nchars) { + call fseti (GP_FD(gp), F_CANCEL, OK) + call syserrs (SYS_FREAD, s_readcmap) + } + + do i = 1, nret { + ip = cm + (i - 1) * 3 + r[i] = Mems[ip+0] + g[i] = Mems[ip+1] + b[i] = Mems[ip+2] + } + + call fseti (GP_FD(gp), F_CANCEL, OK) + call sfree (sp) + + return (nret) +end diff --git a/sys/gio/gim/gimref.x b/sys/gio/gim/gimref.x new file mode 100644 index 00000000..dd3085d4 --- /dev/null +++ b/sys/gio/gim/gimref.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GIM_REFRESHMAPPING -- Refresh a previously defined mapping, i.e., repaint +# the destination rect. + +procedure gim_refreshmapping (gp, mapping) + +pointer gp #I graphics descriptor +int mapping #I mapping to be defined or edited + +short gim[GIM_REFRESHMAPPING_LEN] + +begin + gim[GIM_REFRESHMAPPING_MP] = mapping + call gescape (gp, GIM_REFRESHMAPPING, gim, GIM_REFRESHMAPPING_LEN) +end diff --git a/sys/gio/gim/gimrefpix.x b/sys/gio/gim/gimrefpix.x new file mode 100644 index 00000000..1d906a1a --- /dev/null +++ b/sys/gio/gim/gimrefpix.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GIM_REFRESHPIX -- Update any mappings defined upon the given region of +# the given source raster, as if the pixel values had been set with a write +# pixels call. + +procedure gim_refreshpix (gp, raster, ct, x1, y1, width, height) + +pointer gp #I graphics descriptor +int raster #I raster number (0 is display window) +int ct #I coordinate type +real x1, y1 #I region to be refreshed +real width, height #I region to be refreshed + +short gim[GIM_REFRESHPIXELS_LEN] + +begin + gim[GIM_REFRESHPIXELS_RN] = raster + gim[GIM_REFRESHPIXELS_CT] = ct + + if (ct == CT_PIXEL) { + gim[GIM_REFRESHPIXELS_X1] = x1 + gim[GIM_REFRESHPIXELS_Y1] = y1 + gim[GIM_REFRESHPIXELS_NX] = width + gim[GIM_REFRESHPIXELS_NY] = height + } else { + gim[GIM_REFRESHPIXELS_X1] = x1 * GKI_MAXNDC + gim[GIM_REFRESHPIXELS_Y1] = y1 * GKI_MAXNDC + gim[GIM_REFRESHPIXELS_NX] = nint (width * GKI_MAXNDC) + gim[GIM_REFRESHPIXELS_NY] = nint (height * GKI_MAXNDC) + } + + call gescape (gp, GIM_REFRESHPIXELS, gim, GIM_REFRESHPIXELS_LEN) +end diff --git a/sys/gio/gim/gimriomap.x b/sys/gio/gim/gimriomap.x new file mode 100644 index 00000000..0f152ca5 --- /dev/null +++ b/sys/gio/gim/gimriomap.x @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# GIM_IOMAPREAD -- Read a segment of the gterm widget iomap. + +procedure gim_iomapread (gp, iomap, first, nelem) + +pointer gp #I graphics descriptor +int iomap[ARB] #o iomap data +int first #I first iomap cell to be read +int nelem #I number of elements to read + +int nchars +pointer sp, data +short gim[GIM_READIOMAP_LEN] +short retval[GIM_RET_RIOMAP_LEN] +int read() + +string s_readiomap "gim_iomapread" +errchk flush, read, syserrs + +begin + call smark (sp) + call gpl_flush() + + gim[GIM_READIOMAP_FC] = first + gim[GIM_READIOMAP_NC] = nelem + call gescape (gp, GIM_READIOMAP, gim, GIM_READIOMAP_LEN) + call flush (GP_FD(gp)) + + # Get return value instruction header. + nchars = GIM_RET_RIOMAP_LEN * SZ_SHORT + if (read (GP_FD(gp), retval, nchars) != nchars) { + call fseti (GP_FD(gp), F_CANCEL, OK) + call syserrs (SYS_FREAD, s_readiomap) + } + + if (retval[GIM_RET_RIOMAP_NC] != nelem) + call syserrs (SYS_FREAD, s_readiomap) + + # Get the iomap data. + call salloc (data, nelem, TY_SHORT) + nchars = nelem * SZ_SHORT + if (read (GP_FD(gp), Mems[data], nchars) != nchars) { + call fseti (GP_FD(gp), F_CANCEL, OK) + call syserrs (SYS_FREAD, s_readiomap) + } else + call achtsi (Mems[data], iomap, nelem) + + call fseti (GP_FD(gp), F_CANCEL, OK) + call sfree (sp) +end diff --git a/sys/gio/gim/gimrpix.x b/sys/gio/gim/gimrpix.x new file mode 100644 index 00000000..4b6c7e9b --- /dev/null +++ b/sys/gio/gim/gimrpix.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +# GIM_READPIXELS -- Read from a rectangular region of a raster. + +procedure gim_readpixels (gp, raster, data, nbits, x1, y1, nx, ny) + +pointer gp #I graphics descriptor +int raster #I raster number (0 is display window) +short data[ARB] #O returned pixel data +int nbits #I nbits per raster pixel (1,8,16,32) +int x1, y1 #I first pixel to be written +int nx, ny #I size of region to be written + +int npix, nchars, nwords +short gim[GIM_READPIXELS_LEN] +short retval[GIM_RET_RPIX_LEN] +errchk gpl_flush, gflush, read, syserrs +string s_readpixels "gim_readpixels" +int read() + +begin + call gpl_flush() + npix = nx * ny + nchars = (npix * nbits / NBITS_BYTE + SZB_CHAR-1) / SZB_CHAR + nwords = (nchars + SZ_SHORT-1) / SZ_SHORT + + gim[GIM_READPIXELS_RN] = raster + gim[GIM_READPIXELS_EC] = 0 + gim[GIM_READPIXELS_X1] = x1 + gim[GIM_READPIXELS_Y1] = y1 + gim[GIM_READPIXELS_NX] = nx + gim[GIM_READPIXELS_NY] = ny + gim[GIM_READPIXELS_BP] = nbits + + call gki_escape (gp, GIM_READPIXELS, gim, GIM_READPIXELS_LEN) + call flush (GP_FD(gp)) + + # Get return value instruction header. + nchars = GIM_RET_RPIX_LEN * SZ_SHORT + if (read (GP_FD(gp), retval, nchars) != nchars) { + call fseti (GP_FD(gp), F_CANCEL, OK) + call syserrs (SYS_FREAD, s_readpixels) + } + + # Get the pixel data. + npix = retval[GIM_RET_RPIX_NP] + nchars = (npix * nbits / NBITS_BYTE + SZB_CHAR-1) / SZB_CHAR + if (read (GP_FD(gp), data, nchars) != nchars) { + call fseti (GP_FD(gp), F_CANCEL, OK) + call syserrs (SYS_FREAD, s_readpixels) + } + + call fseti (GP_FD(gp), F_CANCEL, OK) + if (npix != nx * ny) + call syserrs (SYS_IMNOPIX, s_readpixels) +end diff --git a/sys/gio/gim/gimsetmap.x b/sys/gio/gim/gimsetmap.x new file mode 100644 index 00000000..2cf5f7b6 --- /dev/null +++ b/sys/gio/gim/gimsetmap.x @@ -0,0 +1,80 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# GIM_SETMAPPING -- Define a mapping between a source rect and a destination +# rect. While the mapping is enabled, any changes to the source rect will +# be automatically propagated to the destination rect. If the source and +# destination rects are not the same size the source rect will be scaled to +# fit the output rect. A negative DW or DH causes the X or Y axis to be +# flipped during the mapping. Setmapping automatically enables a new +# mapping, but no data is copied until the source rect is subsequently +# modified or the mapping is modified or refreshed. Setmapping may be called +# on an already existing mapping to edit the mapping. If the mapping is +# enabled the effect of the edit will be visible immediately. Only the +# modified regions of the destination rect will be updated by a mapping. + +procedure gim_setmapping (gp, mapping, rop, + src,st,sx,sy,sw,sh, dst,dt,dx,dy,dw,dh) + +pointer gp #I graphics descriptor +int mapping #I mapping to be defined or edited +int rop #I rasterop +int src #I source raster +int st #I coordinate type for source raster +real sx,sy,sw,sh #I source rect +int dst #I destination raster +int dt #I coordinate type for destination raster +real dx,dy,dw,dh #I destination rect + +short gim[GIM_SETMAPPING_LEN] +errchk gpl_flush, gpl_cache +include "../gpl.com" + +begin + # Flush any buffered polyline output. Make sure the wcs transformation + # in the cache is up to date. + + if (op > 1) + call gpl_flush() + else if (gp != gp_out || GP_WCS(gp) != wcs) + call gpl_cache (gp) + + # Output the setmapping escape. + gim[GIM_SETMAPPING_MP] = mapping + gim[GIM_SETMAPPING_OP] = rop + gim[GIM_SETMAPPING_SR] = src + gim[GIM_SETMAPPING_ST] = st + + if (st == CT_PIXEL) { + gim[GIM_SETMAPPING_SX] = sx + gim[GIM_SETMAPPING_SY] = sy + gim[GIM_SETMAPPING_SW] = sw + gim[GIM_SETMAPPING_SH] = sh + } else { + gim[GIM_SETMAPPING_SX] = sx * GKI_MAXNDC + gim[GIM_SETMAPPING_SY] = sy * GKI_MAXNDC + gim[GIM_SETMAPPING_SW] = nint (sw * GKI_MAXNDC) + gim[GIM_SETMAPPING_SH] = nint (sh * GKI_MAXNDC) + } + + gim[GIM_SETMAPPING_DR] = dst + gim[GIM_SETMAPPING_DT] = dt + + if (dt == CT_PIXEL) { + gim[GIM_SETMAPPING_DX] = dx + gim[GIM_SETMAPPING_DY] = dy + gim[GIM_SETMAPPING_DW] = dw + gim[GIM_SETMAPPING_DH] = dh + } else { + gim[GIM_SETMAPPING_DX] = dx * GKI_MAXNDC + gim[GIM_SETMAPPING_DY] = dy * GKI_MAXNDC + gim[GIM_SETMAPPING_DW] = nint (dw * GKI_MAXNDC) + gim[GIM_SETMAPPING_DH] = nint (dh * GKI_MAXNDC) + } + + call gescape (gp, GIM_SETMAPPING, gim, GIM_SETMAPPING_LEN) +end diff --git a/sys/gio/gim/gimsetpix.x b/sys/gio/gim/gimsetpix.x new file mode 100644 index 00000000..09250221 --- /dev/null +++ b/sys/gio/gim/gimsetpix.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GIM_SETPIX -- Set the pixels in a region of a raster to a solid color. +# If width=height=0 the entire raster will be written. + +procedure gim_setpix (gp, raster, ct, x1, y1, width, height, color, rop) + +pointer gp #I graphics descriptor +int raster #I raster number (0 is display window) +int ct #I coordinate type +real x1, y1 #I region to be refreshed +real width, height #I region to be refreshed +int color #I pixel value +int rop #I rasterop + +short gim[GIM_SETPIXELS_LEN] + +begin + gim[GIM_SETPIXELS_RN] = raster + gim[GIM_SETPIXELS_CT] = ct + gim[GIM_SETPIXELS_CO] = color + gim[GIM_SETPIXELS_OP] = rop + + if (ct == CT_PIXEL) { + gim[GIM_SETPIXELS_X1] = x1 + gim[GIM_SETPIXELS_Y1] = y1 + gim[GIM_SETPIXELS_NX] = width + gim[GIM_SETPIXELS_NY] = height + } else { + gim[GIM_SETPIXELS_X1] = x1 * GKI_MAXNDC + gim[GIM_SETPIXELS_Y1] = y1 * GKI_MAXNDC + gim[GIM_SETPIXELS_NX] = nint (width * GKI_MAXNDC) + gim[GIM_SETPIXELS_NY] = nint (height * GKI_MAXNDC) + } + + call gescape (gp, GIM_SETPIXELS, gim, GIM_SETPIXELS_LEN) +end diff --git a/sys/gio/gim/gimsetras.x b/sys/gio/gim/gimsetras.x new file mode 100644 index 00000000..efb5add5 --- /dev/null +++ b/sys/gio/gim/gimsetras.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GIM_SETRASTER -- Set the raster to be used as the coordinate system for +# graphics drawing operations. A setraster for raster N causes subsequent +# drawing operations to be drawn using any raster-to-screen mappings defined +# for raster N. A setraster to raster=0 restores the normal semantics of +# drawing directly to the screen with no additional transformations. +# Applications which use gim_setraster to draw graphics or text overlays on +# a raster should always restore the raster to zero when done so that +# subsequent drawing operations (e.g., in cursor mode) behave normally. +# The setraster is not reset automatically except in a screen clear. +# +# NOTE - Most applications should use gseti(gp,G_RASTER,n) instead of the +# lower level gim_setraster. + +procedure gim_setraster (gp, raster) + +pointer gp #I graphics descriptor +int raster #I raster number + +short gim[GIM_SETRASTER_LEN] + +begin + gim[GIM_SETRASTER_RN] = raster + call gescape (gp, GIM_SETRASTER, gim, GIM_SETRASTER_LEN) +end diff --git a/sys/gio/gim/gimwcmap.x b/sys/gio/gim/gimwcmap.x new file mode 100644 index 00000000..54a6d3f2 --- /dev/null +++ b/sys/gio/gim/gimwcmap.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GIM_WRITECOLORMAP -- Write to a colormap. + +procedure gim_writecolormap (gp, colormap, first, nelem, r, g, b) + +pointer gp #I graphics descriptor +int colormap #I colormap number (0=screen) +int first #I first colormap entry to be written +int nelem #I number of elements to write +int r[ARB],g[ARB],b[ARB] #I RGB color values (0-255) + +int i +pointer sp, cm, op +short gim[GIM_WRITECMAP_LEN] +errchk gpl_flush + +begin + call gpl_flush() + + call smark (sp) + call salloc (cm, nelem * 3, TY_SHORT) + + gim[GIM_WRITECMAP_MP] = colormap + gim[GIM_WRITECMAP_FC] = first + gim[GIM_WRITECMAP_NC] = nelem + + do i = 1, nelem { + op = cm + (i - 1) * 3 + Mems[op+0] = r[i] + Mems[op+1] = g[i] + Mems[op+2] = b[i] + } + + call gki_wescape (GP_FD(gp), GIM_WRITECMAP, + gim, GIM_WRITECMAP_LEN, Mems[cm], nelem * 3) + + call sfree (sp) +end diff --git a/sys/gio/gim/gimwiomap.x b/sys/gio/gim/gimwiomap.x new file mode 100644 index 00000000..a756a235 --- /dev/null +++ b/sys/gio/gim/gimwiomap.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GIM_IOMAPWRITE -- Write to the iomap. The iomap maps client pixel values +# (colors) to gterm widget pixel value (widget colormap indices). The iomap +# should be set only if the client application does not use the gterm widget +# color model. iomap[i] gives the widget colormap index corresponding to +# client pixel I. + +procedure gim_iomapwrite (gp, iomap, first, nelem) + +pointer gp #I graphics descriptor +int iomap[ARB] #I iomap data +int first #I first iomap entry to be written +int nelem #I number of elements to write + +pointer sp, data +short gim[GIM_WRITEIOMAP_LEN] +errchk gpl_flush + +begin + call gpl_flush() + + call smark (sp) + call salloc (data, nelem, TY_SHORT) + + gim[GIM_WRITEIOMAP_FC] = first + gim[GIM_WRITEIOMAP_NC] = nelem + + call achtis (iomap, Mems[data], nelem) + call gki_wescape (GP_FD(gp), GIM_WRITEIOMAP, + gim, GIM_WRITEIOMAP_LEN, Mems[data], nelem) + + call sfree (sp) +end diff --git a/sys/gio/gim/gimwpix.x b/sys/gio/gim/gimwpix.x new file mode 100644 index 00000000..fc55a55b --- /dev/null +++ b/sys/gio/gim/gimwpix.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GIM_WRITEPIXELS -- Write to a rectangular region of a raster. + +procedure gim_writepixels (gp, raster, data, nbits, x1, y1, nx, ny) + +pointer gp #I graphics descriptor +int raster #I raster number (0 is display window) +short data[ARB] #I output pixel data +int nbits #I nbits per raster pixel (1,8,16,32) +int x1, y1 #I first pixel to be written +int nx, ny #I size of region to be written + +int npix, nchars, nwords +short gim[GIM_WRITEPIXELS_LEN] +errchk gpl_flush, gpl_cache +include "../gpl.com" + +begin + # Flush any buffered polyline output. Make sure the wcs transformation + # in the cache is up to date. + + if (op > 1) + call gpl_flush() + else if (gp != gp_out || GP_WCS(gp) != wcs) + call gpl_cache (gp) + + # Output the writepixels escape. + npix = nx * ny + nchars = (npix * nbits / NBITS_BYTE + SZB_CHAR-1) / SZB_CHAR + nwords = (nchars + SZ_SHORT-1) / SZ_SHORT + + gim[GIM_WRITEPIXELS_RN] = raster + gim[GIM_WRITEPIXELS_EC] = 0 + gim[GIM_WRITEPIXELS_X1] = x1 + gim[GIM_WRITEPIXELS_Y1] = y1 + gim[GIM_WRITEPIXELS_NX] = nx + gim[GIM_WRITEPIXELS_NY] = ny + gim[GIM_WRITEPIXELS_BP] = nbits + + call gki_wescape (GP_FD(gp), GIM_WRITEPIXELS, + gim, GIM_WRITEPIXELS_LEN, data, nwords) +end diff --git a/sys/gio/gim/mkpkg b/sys/gio/gim/mkpkg new file mode 100644 index 00000000..9aab719b --- /dev/null +++ b/sys/gio/gim/mkpkg @@ -0,0 +1,32 @@ +# Make the GIM (graphics imaging) interface. + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + gimcpras.x + gimcrras.x + gimderas.x + gimdsmap.x + gimenmap.x + gimfcmap.x + gimfmap.x + gimgetmap.x + gimimap.x + gimlcmap.x + gimqras.x + gimrasini.x + gimrcmap.x + gimref.x + gimrefpix.x + gimriomap.x + gimrpix.x + gimsetmap.x ../gpl.com + gimsetpix.x + gimsetras.x + gimwcmap.x + gimwiomap.x + gimwpix.x ../gpl.com + ; diff --git a/sys/gio/gki/README b/sys/gio/gki/README new file mode 100644 index 00000000..171de8d9 --- /dev/null +++ b/sys/gio/gki/README @@ -0,0 +1,84 @@ +GKI -- The graphics kernel interface. + + The GKI package is used to encode and decode the GKI instructions used to +communicate with a graphics kernel. The kernel may be resident in the same +process, in the CL process, or in a subprocess of the CL. Output may also +be spooled in a metafile. The purposes of the GKI interface are to isolate GIO +from the kernel, to hide the details of packing and unpacking GKI metacode +from both GIO and the kernels, and to hide the details of the communications +protocols required to communicate with the different types of kernels. + + Before any i/o can be done on a GKI graphics stream, GKI must be informed +of the residency of the kernel associated with the stream. Three calls are +provided for this purpose: + + gki_redir (stream, fd, old_type, old_fd) [1] + gki_inline (stream, dd) [2] + gki_subkernel (stream, pid, epa_prpsio) [3] + +Use [1] in the normal case of GIO talking to the CL or to a metafile. The +first call will set, rather than redirect, the FD for a stream. Subsequent +calls may be made to truely redirect a stream and then restore its normal +dataflow. Use [2] when the graphics kernel is in the same process. The +kernel must already have been opened with the driver for the kernel in the +DD array. This is the most efficient mode of operation if a high data +bandwidth is required. Kernel type [2] is used by GIOTR in the CL process +to communicate with external kernels. A slightly different protocol is +required in this case since the input must be switched to the subprocess +before it can read or write the graphics stream. + + + Summary Of Procedures + +1. Initialize GKI + + gki_redir (stream, fd, old_fd, old_type) + gki_inline_kernel (stream, dd) + gki_subkernel (stream, pid, prpsio_epa) + + +2. Metacode interpretation + + gki_fetch_next_instruction (fd, instruction) (EOF|nwords) + gki_execute (gki, dd) + gki_write (fd, gki) + + +3. Instructions + + gki_cancel (fd) + gki_clear (fd) + gki_closews (fd, device) + gki_deactivatews (fd) + gki_eof (fd) + gki_escape (fd, fn, instruction, nwords) + gki_faset (fd, ap) + gki_fillarea (fd, points, npts) + gki_flush (fd) + gki_getcellarray (fd, m, nx, ny, x1,y1, x2,y2) + gki_getcursor (fd, x, y, key, cursor) + gki_getwcs (fd, wcs, len_wcs) + gki_mftitle (fd, title) + gki_openws (fd, device, mode) + gki_plset (fd, ap) + gki_pmset (fd, ap) + gki_polyline (fd, points, npts) + gki_polymarker (fd, points, npts) + gki_putcellarray (fd, m, nx, ny, x1,y1, x2,y2) + gki_reactivatews (fd) + gki_setcursor (fd, x, y, cursor) + gki_setwcs (fd, wcs, len_wcs) + gki_text (fd, x, y, text) + gki_txset (fd, ap) + + +4. Instructions for encoding return values + + gki_retcellarray (fd, m, np) + gki_retcursorvalue (fd, x, y, key, cursor) + + +5. Initialization of the GKIPRINT kernel + + gkp_install (dd, out_fd, verbose_output) + gkp_close () diff --git a/sys/gio/gki/gki.com b/sys/gio/gki/gki.com new file mode 100644 index 00000000..4c5e3152 --- /dev/null +++ b/sys/gio/gki/gki.com @@ -0,0 +1,8 @@ +# Common for the GKI (graphics kernel interface) package. + +int gk_type[LAST_FD] # type of output +int gk_fd[LAST_FD] # output file descriptor +int gk_dd[LEN_GKIDD] # local device driver +int gk_prpsio # EPA of pr_psio procedure + +common /gkicom/ gk_type, gk_fd, gk_dd, gk_prpsio diff --git a/sys/gio/gki/gkicancel.x b/sys/gio/gki/gkicancel.x new file mode 100644 index 00000000..ff2bc5f4 --- /dev/null +++ b/sys/gio/gki/gkicancel.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_CANCEL -- Cancel graphics output and reset internal parameters. +# +# BOI GKI_CANCEL 0 +# +# L(i) set to the constant 3 (no data fields) + +procedure gki_cancel (fd) + +int fd # output file + +int epa +short gki[GKI_CANCEL_LEN] +data gki[1] /BOI/, gki[2] /GKI_CANCEL/, gki[3] /LEN_GKIHDR/ +include "gki.com" + +begin + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_CANCEL] + if (epa != 0) + call zcall1 (epa, 0) + } else + call write (gk_fd[fd], gki, GKI_CANCEL_LEN * SZ_SHORT) +end diff --git a/sys/gio/gki/gkiclear.x b/sys/gio/gki/gkiclear.x new file mode 100644 index 00000000..ac1e5961 --- /dev/null +++ b/sys/gio/gki/gkiclear.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_CLEAR -- Clear the workstation screen. +# +# BOI GKI_CLEAR 0 +# +# L(i) set to the constant 3 (no data fields) + +procedure gki_clear (fd) + +int fd # output file + +int epa +short gki[GKI_CLEAR_LEN] +data gki[1] /BOI/, gki[2] /GKI_CLEAR/, gki[3] /LEN_GKIHDR/ +include "gki.com" + +begin + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_CLEAR] + if (epa != 0) + call zcall1 (epa, 0) + } else + call write (gk_fd[fd], gki, GKI_CLEAR_LEN * SZ_SHORT) +end diff --git a/sys/gio/gki/gkiclose.x b/sys/gio/gki/gkiclose.x new file mode 100644 index 00000000..e7ceea15 --- /dev/null +++ b/sys/gio/gki/gkiclose.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_CLOSEWS -- Close workstation. +# +# BOI GKI_CLOSEWS L N D +# +# L(i) 4 + N +# N(i) number of characters in field D +# D(Nc) device name as in graphcap file + +procedure gki_closews (fd, device) + +int fd # output file +char device[ARB] # device name + +int epa +int ip, nchars, n +pointer sp, gki, op +int strlen() +include "gki.com" + +begin + call smark (sp) + + n = strlen (device) + call salloc (gki, GKI_CLOSEWS_LEN + n, TY_SHORT) + + # Pack the device name as a SHORT integer array. + op = gki + GKI_CLOSEWS_D - 1 + for (ip=1; ip <= n; ip=ip+1) { + Mems[op] = device[ip] + op = op + 1 + } + + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_CLOSEWS] + if (epa != 0) + call zcall2 (epa, Mems[gki+GKI_CLOSEWS_D-1], n) + } else { + Mems[gki ] = BOI + Mems[gki+1] = GKI_CLOSEWS + Mems[gki+2] = GKI_CLOSEWS_LEN + n + Mems[gki+GKI_CLOSEWS_N-1] = n + + # Send a copy of the close workstation directive to PSIOCTRL in + # the CL process to connect the graphics stream to a kernel, + # before writing to the graphics stream. The GKI instruction + # must be preceded by the integer value of the stream number. + + nchars = (GKI_CLOSEWS_LEN + n) * SZ_SHORT + if (IS_FILE(fd) && (fd >= STDGRAPH && fd <= STDPLOT)) { + call write (PSIOCTRL, fd, SZ_INT32) + call write (PSIOCTRL, Mems[gki], nchars) + call flush (PSIOCTRL) + } + + # Now send a copy to the graphics kernel. + call write (gk_fd[fd], Mems[gki], nchars) + } + + call sfree (sp) +end diff --git a/sys/gio/gki/gkideact.x b/sys/gio/gki/gkideact.x new file mode 100644 index 00000000..b742f7ed --- /dev/null +++ b/sys/gio/gki/gkideact.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_DEACTIVATEWS -- Deactivate the workstation (disable graphics). +# +# BOI GKI_DEACTIVATEWS L F +# +# L(i) 4 +# F flags (0,AW_PAUSE,AW_CLEAR) + +procedure gki_deactivatews (fd, flags) + +int fd # output file +int flags # action modifier flags + +int epa, nchars +short gki[GKI_DEACTIVATEWS_LEN] +data gki[1] /BOI/, gki[2] /GKI_DEACTIVATEWS/, gki[3] /GKI_DEACTIVATEWS_LEN/ +include "gki.com" + +begin + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_DEACTIVATEWS] + if (epa != 0) + call zcall1 (epa, flags) + + } else { + # Send a copy to the pseudofile i/o controller. + gki[GKI_DEACTIVATEWS_F] = flags + nchars = GKI_DEACTIVATEWS_LEN * SZ_SHORT + if (IS_FILE(fd) && (fd >= STDGRAPH && fd <= STDPLOT)) { + call write (PSIOCTRL, fd, SZ_INT32) + call write (PSIOCTRL, gki, nchars) + call flush (PSIOCTRL) + } + + # Now send a copy to the graphics kernel. + call write (gk_fd[fd], gki, nchars) + } +end diff --git a/sys/gio/gki/gkieof.x b/sys/gio/gki/gkieof.x new file mode 100644 index 00000000..05700156 --- /dev/null +++ b/sys/gio/gki/gkieof.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_EOF -- Signal end of file on a metacode stream. +# +# BOI GKI_EOF 0 +# +# L(i) set to the constant 3 (no data fields) + +procedure gki_eof (fd) + +int fd # output file + +short gki[GKI_EOF_LEN] +data gki[1] /BOI/, gki[2] /GKI_EOF/, gki[3] /LEN_GKIHDR/ +include "gki.com" + +begin + if (!IS_INLINE(fd)) + call write (gk_fd[fd], gki, GKI_EOF_LEN * SZ_SHORT) +end diff --git a/sys/gio/gki/gkiesc.x b/sys/gio/gki/gkiesc.x new file mode 100644 index 00000000..a33c769d --- /dev/null +++ b/sys/gio/gki/gkiesc.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_ESCAPE -- Pass a device dependent instruction on to the kernel. +# +# BOI GKI_ESCAPE L FN N DC +# +# L(i) 5 + N +# FN(i) escape function code +# N(i) number of escape data words +# DC(i) escape data words + +procedure gki_escape (fd, fn, instruction, nwords) + +int fd # output file +int fn # function code +short instruction[ARB] # instruction sequence of unknown format +int nwords # number of shorts in instruction + +int epa +short gki[GKI_ESCAPE_LEN] +data gki[1] /BOI/, gki[2] /GKI_ESCAPE/ +include "gki.com" + +begin + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_ESCAPE] + if (epa != 0) + call zcall3 (epa, fn, instruction, nwords) + } else { + gki[GKI_ESCAPE_L] = GKI_ESCAPE_LEN + nwords + gki[GKI_ESCAPE_N] = nwords + gki[GKI_ESCAPE_FN] = fn + + call write (gk_fd[fd], gki, GKI_ESCAPE_LEN * SZ_SHORT) + call write (gk_fd[fd], instruction, nwords * SZ_SHORT) + } +end diff --git a/sys/gio/gki/gkiexe.x b/sys/gio/gki/gkiexe.x new file mode 100644 index 00000000..05e8ec8d --- /dev/null +++ b/sys/gio/gki/gkiexe.x @@ -0,0 +1,178 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GKI_EXECUTE -- Execute a metacode instruction. The instruction is decoded +# and a graphics kernel driver subroutine is called to execute the instruction. +# If the device driver does not include a procedure for the instruction the +# instruction is discarded. Integer and real parameters are unpacked from +# their short integer metacode representation. Character data is passed by +# reference, i.e., as a SHORT integer array (not EOS delimited char!!), along +# with the character count. Attribute packets are passed to the set attribute +# procedure by reference as a short integer array. + +procedure gki_execute (gki, dd) + +short gki[ARB] # graphics kernel instruction +int dd[ARB] # device driver + +int kp # kernel procedure +int m, n, cn, fn, dummy, flags +int x, y, x1, y1, x2, y2 + +begin + switch (gki[GKI_HDR_OPCODE]) { + + case GKI_OPENWS: + kp = dd[GKI_OPENWS] + if (kp != NULL) { + m = gki[GKI_OPENWS_M] + n = gki[GKI_OPENWS_N] + call zcall3 (kp, gki[GKI_OPENWS_D], n, m) + } + case GKI_CLOSEWS: + kp = dd[GKI_CLOSEWS] + if (kp != NULL) { + n = gki[GKI_CLOSEWS_N] + call zcall2 (kp, gki[GKI_CLOSEWS_D], n) + } + case GKI_REACTIVATEWS: + kp = dd[GKI_REACTIVATEWS] + if (kp != NULL) { + flags = gki[GKI_REACTIVATEWS_F] + call zcall1 (kp, flags) + } + case GKI_DEACTIVATEWS: + kp = dd[GKI_DEACTIVATEWS] + if (kp != NULL) { + flags = gki[GKI_DEACTIVATEWS_F] + call zcall1 (kp, flags) + } + case GKI_MFTITLE: + kp = dd[GKI_MFTITLE] + if (kp != NULL) { + n = gki[GKI_MFTITLE_N] + call zcall2 (kp, gki[GKI_MFTITLE_T], n) + } + case GKI_CLEAR: + kp = dd[GKI_CLEAR] + if (kp != NULL) { + call zcall1 (kp, dummy) + } + case GKI_CANCEL: + kp = dd[GKI_CANCEL] + if (kp != NULL) { + call zcall1 (kp, dummy) + } + case GKI_FLUSH: + kp = dd[GKI_FLUSH] + if (kp != NULL) { + call zcall1 (kp, dummy) + } + case GKI_POLYLINE: + kp = dd[GKI_POLYLINE] + if (kp != 0) { + n = gki[GKI_POLYLINE_N] + call zcall2 (kp, gki[GKI_POLYLINE_P], n) + } + case GKI_POLYMARKER: + kp = dd[GKI_POLYMARKER] + if (kp != 0) { + n = gki[GKI_POLYMARKER_N] + call zcall2 (kp, gki[GKI_POLYMARKER_P], n) + } + case GKI_TEXT: + kp = dd[GKI_TEXT] + if (kp != NULL) { + x = gki[GKI_TEXT_P] + y = gki[GKI_TEXT_P+1] + n = gki[GKI_TEXT_N] + call zcall4 (kp, x, y, gki[GKI_TEXT_T], n) + } + case GKI_FILLAREA: + kp = dd[GKI_FILLAREA] + if (kp != 0) { + n = gki[GKI_FILLAREA_N] + call zcall2 (kp, gki[GKI_FILLAREA_P], n) + } + case GKI_PUTCELLARRAY: + kp = dd[GKI_PUTCELLARRAY] + if (kp != NULL) { + x1 = gki[GKI_PUTCELLARRAY_LL] + y1 = gki[GKI_PUTCELLARRAY_LL+1] + x2 = gki[GKI_PUTCELLARRAY_UR] + y2 = gki[GKI_PUTCELLARRAY_UR+1] + m = gki[GKI_PUTCELLARRAY_NC] + n = gki[GKI_PUTCELLARRAY_NL] + call zcall7 (kp, gki[GKI_PUTCELLARRAY_P], m, n, x1,y1, x2,y2) + } + case GKI_SETCURSOR: + kp = dd[GKI_SETCURSOR] + if (kp != NULL) { + cn = gki[GKI_SETCURSOR_CN] + x = gki[GKI_SETCURSOR_POS] + y = gki[GKI_SETCURSOR_POS+1] + call zcall3 (kp, x, y, cn) + } + case GKI_PLSET: + kp = dd[GKI_PLSET] + if (kp != NULL) { + call zcall1 (kp, gki) + } + case GKI_PMSET: + kp = dd[GKI_PMSET] + if (kp != NULL) { + call zcall1 (kp, gki) + } + case GKI_TXSET: + kp = dd[GKI_TXSET] + if (kp != NULL) { + call zcall1 (kp, gki) + } + case GKI_FASET: + kp = dd[GKI_FASET] + if (kp != NULL) { + call zcall1 (kp, gki) + } + case GKI_GETCURSOR: + kp = dd[GKI_GETCURSOR] + if (kp != NULL) { + cn = gki[GKI_GETCURSOR_CN] + call zcall1 (kp, cn) + } + case GKI_GETCELLARRAY: + kp = dd[GKI_GETCELLARRAY] + if (kp != NULL) { + x1 = gki[GKI_GETCELLARRAY_LL] + y1 = gki[GKI_GETCELLARRAY_LL+1] + x2 = gki[GKI_GETCELLARRAY_UR] + y2 = gki[GKI_GETCELLARRAY_UR+1] + m = gki[GKI_GETCELLARRAY_NC] + n = gki[GKI_GETCELLARRAY_NL] + call zcall6 (kp, m, n, x1,y1, x2,y2) + } + case GKI_ESCAPE: + kp = dd[GKI_ESCAPE] + if (kp != NULL) { + fn = gki[GKI_ESCAPE_FN] + n = gki[GKI_ESCAPE_N] + call zcall3 (kp, fn, gki[GKI_ESCAPE_DC], n) + } + case GKI_SETWCS: + kp = dd[GKI_SETWCS] + if (kp != NULL) { + n = gki[GKI_SETWCS_N] + call zcall2 (kp, gki[GKI_SETWCS_WCS], n) + } + case GKI_GETWCS: + kp = dd[GKI_SETWCS] + if (kp != NULL) { + n = gki[GKI_SETWCS_N] + call zcall2 (kp, gki[GKI_SETWCS_WCS], n) + } + default: + kp = dd[GKI_UNKNOWN] + if (kp != NULL) + call zcall1 (kp, gki) + } +end diff --git a/sys/gio/gki/gkifa.x b/sys/gio/gki/gkifa.x new file mode 100644 index 00000000..328ec7cc --- /dev/null +++ b/sys/gio/gki/gkifa.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_FILLAREA -- Output the fill area instruction. +# +# BOI GKI_FILLAREA L N P +# +# L(i) 4 + (N * 2) +# N(i) number of points defining the polygon to be filled +# P(Np) list of points (x,y pairs) + +procedure gki_fillarea (fd, points, npts) + +int fd # output file +short points[ARB] # polygon defining area to be filled +int npts # number of (x,y) points in polygon + +int epa +short gki[GKI_FILLAREA_LEN] +data gki[1] /BOI/, gki[2] /GKI_FILLAREA/ +include "gki.com" + +begin + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_FILLAREA] + if (epa != 0) + call zcall2 (epa, points, npts) + } else { + gki[GKI_FILLAREA_L] = GKI_FILLAREA_LEN + (npts * 2) + gki[GKI_FILLAREA_N] = npts + + call write (gk_fd[fd], gki, GKI_FILLAREA_LEN * SZ_SHORT) + call write (gk_fd[fd], points, (npts * 2) * SZ_SHORT) + } +end diff --git a/sys/gio/gki/gkifaset.x b/sys/gio/gki/gkifaset.x new file mode 100644 index 00000000..7531be73 --- /dev/null +++ b/sys/gio/gki/gkifaset.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GKI_FASET -- Set the fill area attributes. +# +# BOI GKI_FASET L FS CI +# +# L(i) 5 +# FS(i) fill style (0=clear,1=hollow,2=solid,3-6=hatch) +# CI(i) fill area color index + +procedure gki_faset (fd, ap) + +int fd # output file +pointer ap # pointer to fillarea attribute structure + +int epa +short gki[GKI_FASET_LEN] +data gki[1] /BOI/, gki[2] /GKI_FASET/, gki[3] /GKI_FASET_LEN/ +include "gki.com" + +begin + gki[GKI_FASET_FS] = FA_STYLE(ap) + gki[GKI_FASET_CI] = FA_COLOR(ap) + + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_FASET] + if (epa != 0) + call zcall1 (epa, gki) + } else + call write (gk_fd[fd], gki, GKI_FASET_LEN * SZ_SHORT) +end diff --git a/sys/gio/gki/gkifetch.x b/sys/gio/gki/gkifetch.x new file mode 100644 index 00000000..53fa315b --- /dev/null +++ b/sys/gio/gki/gkifetch.x @@ -0,0 +1,80 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +define LEN_DEFIBUF 2048 +define ONEWORD SZ_SHORT +define TWOWORDS (2*SZ_SHORT) + +# Header fields of a GKI instruction. +define I_BOI Mems[$1+GKI_HDR_BOI-1] +define I_OPCODE Mems[$1+GKI_HDR_OPCODE-1] +define I_LENGTH Mems[$1+GKI_HDR_LENGTH-1] +define I_DATA Mems[$1+GKI_DATAFIELDS-1] + +# GKI_FETCH_NEXT_INSTRUCTION -- Fetch the next GKI metacode instruction from the +# input stream. A pointer to a short integer buffer containing the instruction +# is returned as an output argument. EOF is returned as the function value +# when EOF is seen on the input stream. The instruction buffer may be +# deallocated by our caller at any time, if desired. A new buffer will be +# created automatically when next we are called. + +int procedure gki_fetch_next_instruction (fd, instruction) + +int fd # input file containing metacode +pointer instruction # pointer to instruction (output) + +int len_ibuf, nchars +pointer ibuf +int read() +errchk read, malloc, realloc +data ibuf /NULL/ + +begin + # Allocate a default sized instruction buffer. We can reallocate + # a larger buffer later if necessary. + + if (ibuf == NULL) { + call malloc (ibuf, LEN_DEFIBUF, TY_SHORT) + len_ibuf = LEN_DEFIBUF + } + + # Advance to the next instruction. Nulls and botched portions of + # instructions are ignored. Read the instruction header to determine + # the length of the instruction, and then read the rest of instruction + # into buffer. If the entire instruction cannot be read we have a + # botched instruction and must try again. + + repeat { + repeat { + if (read (fd, I_BOI(ibuf), ONEWORD) == EOF) + return (EOF) + } until (I_BOI(ibuf) == BOI) + + if (read (fd, I_OPCODE(ibuf), TWOWORDS) == EOF) + return (EOF) + + # Make instruction buffer large enough to hold instruction. + # Compute length of remainder of instruction in chars. + + if (I_LENGTH(ibuf) > len_ibuf) { + len_ibuf = I_LENGTH(ibuf) + call realloc (ibuf, len_ibuf, TY_SHORT) + } + + nchars = (I_LENGTH(ibuf) - LEN_GKIHDR) * SZ_SHORT + if (nchars == 0) + break + + } until (read (fd, I_DATA(ibuf), nchars) == nchars) + + instruction = ibuf + + # Check for a soft end of file, otherwise return the length of the + # instruction as the function value. + + if (I_OPCODE(ibuf) == GKI_EOF) + return (EOF) + else + return (I_LENGTH(ibuf)) +end diff --git a/sys/gio/gki/gkifflush.x b/sys/gio/gki/gkifflush.x new file mode 100644 index 00000000..9eebf406 --- /dev/null +++ b/sys/gio/gki/gkifflush.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GKI_FFLUSH -- Flush a graphics stream. This does not issue the GKI_FLUSH +# graphics instruction to the graphics kernel, it merely flushes any buffered +# data in the output stream, and is a no-op in the case of an inline kernel. + +procedure gki_fflush (fd) + +int fd # output file + +errchk seek +include "gki.com" + +begin + if (IS_SUBKERNEL(fd)) { + call seek (fd, BOFL) + call zcall3 (gk_prpsio, KERNEL_PID(fd), fd, FF_WRITE) + } else if (!IS_INLINE(fd)) + call flush (gk_fd[fd]) +end diff --git a/sys/gio/gki/gkiflush.x b/sys/gio/gki/gkiflush.x new file mode 100644 index 00000000..878502d4 --- /dev/null +++ b/sys/gio/gki/gkiflush.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GKI_FLUSH -- Flush any buffered output. +# +# BOI GKI_FLUSH 0 +# +# L(i) set to the constant 3 (no data fields) + +procedure gki_flush (fd) + +int fd # output file + +int epa +short gki[GKI_FLUSH_LEN] +data gki[1] /BOI/, gki[2] /GKI_FLUSH/, gki[3] /LEN_GKIHDR/ +errchk write, seek +include "gki.com" + +begin + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_FLUSH] + if (epa != 0) + call zcall1 (epa, 0) + } else { + call write (gk_fd[fd], gki, GKI_FLUSH_LEN * SZ_SHORT) + + # If writing to a subkernel we must call PR_PSIO to give the + # kernel a chance to read the spooled metacode. + + if (IS_SUBKERNEL(fd)) { + call seek (fd, BOFL) + call zcall3 (gk_prpsio, KERNEL_PID(fd), fd, FF_WRITE) + } else + call flush (gk_fd[fd]) + } +end diff --git a/sys/gio/gki/gkigca.x b/sys/gio/gki/gkigca.x new file mode 100644 index 00000000..07abf9d3 --- /dev/null +++ b/sys/gio/gki/gkigca.x @@ -0,0 +1,87 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +# GKI_GETCELLARRAY -- Input a cell array (pixel array). +# +# BOI GKI_GETCELLARRAY L LL UR NC NL +# +# L(i) 9 +# LL(p) coordinates of lower left corner of input area +# UR(p) coordinates of upper right corner of input area +# NC(i) number of columns in array +# NL(i) number of lines in array + +procedure gki_getcellarray (fd, m, nx, ny, x1,y1, x2,y2) + +int fd # output file +int nx, ny # number of columns and lines in M +short m[nx,ny] # output array +int x1, y1 # lower left corner of window to be read +int x2, y2 # upper right corner of window to be read + +int epa, nchars, npts +short ca[GKI_CELLARRAY_LEN] +short gki[GKI_GETCELLARRAY_LEN] +int read() +data gki[1] /BOI/, gki[2] /GKI_GETCELLARRAY/, gki[3] /GKI_GETCELLARRAY_LEN/ +errchk write, seek, flush, read +include "gki.com" + +begin + # If the kernel is inline it will return the cell array value in the + # graphics stream FIO buffer just as if the kernel were resident + # in another process. We rewind the buffer after the kernel writes + # into it in preparation for the read below. + + if (IS_INLINE(fd)) { + call fseti (fd, F_CANCEL, OK) + epa = gk_dd[GKI_GETCELLARRAY] + if (epa != 0) + call zcall6 (epa, nx,ny, x1,y1, x2,y2) + call seek (fd, BOFL) + + } else { + # Write get cell array instruction to the kernel. + + gki[GKI_GETCELLARRAY_LL] = x1 + gki[GKI_GETCELLARRAY_LL+1] = y1 + gki[GKI_GETCELLARRAY_UR] = x2 + gki[GKI_GETCELLARRAY_UR+1] = y2 + gki[GKI_GETCELLARRAY_NC] = nx + gki[GKI_GETCELLARRAY_NL] = ny + + call write (gk_fd[fd], gki, GKI_GETCELLARRAY_LEN) + + # If the kernel is a subprocess we must call PR_PSIO to allow the + # kernel to read the instruction and return the cell array value. + + if (IS_SUBKERNEL(fd)) { + call seek (fd, BOFL) + call zcall3 (gk_prpsio, KERNEL_PID(fd), fd, FF_READ) + call seek (fd, BOFL) + } else + call flush (gk_fd[fd]) + } + + # Read and decode the cell array value. + + nchars = GKI_CELLARRAY_LEN * SZ_SHORT + if (read (fd, ca, nchars) < nchars) { + call syserr (SYS_GGCELL) + } else if (ca[1] != BOI || ca[2] != GKI_CELLARRAY || + ca[GKI_CELLARRAY_NP] <= 0) { + call syserr (SYS_GGCELL) + } else { + npts = ca[GKI_CELLARRAY_NP] + nchars = min (nx * ny, npts) * SZ_SHORT + if (read (fd, m, nchars) < nchars) + call syserr (SYS_GGCELL) + } + + call fseti (fd, F_CANCEL, OK) +end diff --git a/sys/gio/gki/gkigcur.x b/sys/gio/gki/gkigcur.x new file mode 100644 index 00000000..e87e030e --- /dev/null +++ b/sys/gio/gki/gkigcur.x @@ -0,0 +1,106 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +# GKI_GETCURSOR -- Read the cursor position in device coordinates. +# +# BOI GKI_GETCURSOR L CN +# +# L(i) 4 +# CN(i) cursor number +# +# The kernel reads graphics cursor number CN and returns the +# keystroke value (if any) and the cursor position in NDC +# coordinates. The cursor attributes are returned in the +# following format: +# +# BOI GKI_CURSORVALUE L CN KEY SX SY RN RX RY +# +# where +# +# L(i) 10 +# CN(i) cursor number +# KEY(i) keystroke value (>= 0 or EOF) +# SX(i) NDC X screen coordinate of cursor +# SY(i) NDC Y screen coordinate of cursor +# RN(i) raster number or zero +# RX(i) NDC X raster coordinate of cursor +# RY(i) NDC Y raster coordinate of cursor +# +# The screen or display window coordinates SX and SY of the cursor are +# returned for all devices. Only some devices support multiple rasters. +# If the device supports rasters and the cursor is in a rasters when read, the +# rasters number and rasters coordinates are returned in RN,RX,RY. This is in +# addition to the screen coordinates SX,SY. If rasters coordinates are not +# returned, the rasters number will be set to zero and RX,RY will be the same +# as SX,SY. + +procedure gki_getcursor (fd, cursor, cn, key, sx, sy, raster, rx, ry) + +int fd #I output file +int cursor #I cursor to be read +int cn #O cursor number actually read +int key #O keystroke value or EOF +int sx, sy #O screen coordinates of cursor +int raster #O raster number +int rx, ry #O raster coordinates of cursor + +int epa +int nchars, read() +short gki[GKI_GETCURSOR_LEN] +short cur[GKI_CURSORVALUE_LEN] +data gki[1] /BOI/, gki[2] /GKI_GETCURSOR/, gki[3] /GKI_GETCURSOR_LEN/ +include "gki.com" +errchk write, flush, read + +begin + # If the kernel is inline it will return the cursor value in the + # graphics stream FIO buffer just as if the kernel were resident + # in another process. We rewind the buffer after the kernel writes + # into it in preparation for the read below. + + if (IS_INLINE(fd)) { + call fseti (fd, F_CANCEL, OK) + epa = gk_dd[GKI_GETCURSOR] + if (epa != 0) + call zcall1 (epa, cursor) + call seek (fd, BOFL) + + } else { + # Write cursor read instruction to the kernel. + gki[GKI_GETCURSOR_CN] = cursor + call write (gk_fd[fd], gki, GKI_GETCURSOR_LEN * SZ_SHORT) + + # If the kernel is a subprocess we must call PR_PSIO to allow the + # kernel to read the instruction and return the cursor value. + + if (IS_SUBKERNEL(fd)) { + call seek (fd, BOFL) + call zcall3 (gk_prpsio, KERNEL_PID(fd), fd, FF_READ) + call seek (fd, BOFL) + } else + call flush (gk_fd[fd]) + } + + # Read and decode the cursor value instruction. + nchars = GKI_CURSORVALUE_LEN * SZ_SHORT + if (read (fd, cur, nchars) < nchars) + key = EOF + else if (cur[1] != BOI || cur[2] != GKI_CURSORVALUE) + call syserr (SYS_GGCUR) + else { + cn = cur[GKI_CURSORVALUE_CN] + key = cur[GKI_CURSORVALUE_KEY] + sx = cur[GKI_CURSORVALUE_SX] + sy = cur[GKI_CURSORVALUE_SY] + raster = cur[GKI_CURSORVALUE_RN] + rx = cur[GKI_CURSORVALUE_RX] + ry = cur[GKI_CURSORVALUE_RY] + } + + call fseti (fd, F_CANCEL, OK) +end diff --git a/sys/gio/gki/gkigetwcs.x b/sys/gio/gki/gkigetwcs.x new file mode 100644 index 00000000..f6aa07c2 --- /dev/null +++ b/sys/gio/gki/gkigetwcs.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GKI_GETWCS -- Retrieve the WCS from the CL process. Used when opening a +# (non-metafile) device in append mode. +# +# BOI GKI_GETWCS L N +# +# L(i) 3 +# N(i) number of words of WCS data to be read + +procedure gki_getwcs (fd, wcs, len_wcs) + +int fd # input/output file +int wcs[ARB] # array of WCS structures (output) +int len_wcs # number of ints (struct units) in array + +int nchars, nwords, read() +short gki[GKI_GETWCS_LEN] +data gki[1] /BOI/, gki[2] /GKI_GETWCS/, gki[3] /GKI_GETWCS_LEN/ +errchk syserr, read, write, flush +include "gki.com" + +begin + nwords = (len_wcs * SZ_INT / SZ_SHORT) + gki[GKI_GETWCS_N] = nwords + + # Request CL to send SETWCS instruction back to us. The directive + # must be sent on the pseudofile control stream. + + call write (PSIOCTRL, fd, SZ_INT32) + call write (PSIOCTRL, gki, GKI_GETWCS_LEN * SZ_SHORT) + call flush (PSIOCTRL) + + # Read the wcs data. This is returned on the process CLIN channel + # by the CL. + + nchars = nwords * SZ_SHORT + if (read (CLIN, wcs, nchars) != nchars) + call syserr (SYS_GGETWCS) +end diff --git a/sys/gio/gki/gkiinit.x b/sys/gio/gki/gkiinit.x new file mode 100644 index 00000000..0813a708 --- /dev/null +++ b/sys/gio/gki/gkiinit.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_INIT -- Initialize GKI i/o on a graphics stream. Called by GOPEN to +# make the connection to either a metacode stream file or an inline kernel. +# If the stream has already been directed to a kernel we do nothing, else +# we initialize the stream as for a metacode file or remote kernel. If +# gki_inline is called before gopen then this procedure is a nop. + +procedure gki_init (stream) + +int stream # graphics stream to be redirected +include "gki.com" + +begin + if (gk_type[stream] == NULL) { + gk_type[stream] = TY_FILE + gk_fd[stream] = stream + } +end diff --git a/sys/gio/gki/gkiinline.x b/sys/gio/gki/gkiinline.x new file mode 100644 index 00000000..87fc1f29 --- /dev/null +++ b/sys/gio/gki/gkiinline.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_INLINE_KERNEL -- Identify a graphics stream for use with an inline +# kernel, i.e., with a kernel linked into the same process as the high level +# code which calls the GKI procedures. At present there may be at most one +# inline kernel at a time. The entry point addresses of the kernel procedures +# are passed in the array DD. Subsequent GKI calls for the named stream will +# result in direct calls to the inline kernel without encoding and decoding +# GKI instructions, hence this is the most efficient mode of operation. + +procedure gki_inline_kernel (stream, dd) + +int stream # graphics stream to be redirected +int dd[ARB] # device driver for the kernel +include "gki.com" + +begin + gk_type[stream] = TY_INLINE + call amovi (dd, gk_dd, LEN_GKIDD) +end diff --git a/sys/gio/gki/gkikern.x b/sys/gio/gki/gkikern.x new file mode 100644 index 00000000..95c8e648 --- /dev/null +++ b/sys/gio/gki/gkikern.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_SUBKERNEL -- Identify a graphics stream for use with a kernel in a +# connected subprocess of the current process. This type of kernel is +# equivalent to a file for all of the output instructions, but the input +# instructions (e.g., read cursor) must fiddle with process i/o and need +# additional information to do so, i.e., the process id number of the kernel +# process, and the entry point address of the PR_PSIO procedure. We do not +# wish to directly reference the latter procedure as this would require +# all processes which use GKI to link in the process control code, even if +# they never talk directly to a process. Note that processes which talk to +# an external kernel via the CL do so with the normal file interface, hence +# do not need to call us. We are called by the GIOTR (cursor mode) code in +# the CL process when an external kernel is spawned. + +procedure gki_subkernel (stream, pid, prpsio_epa) + +int stream # graphics stream to be redirected +int pid # process id of kernel process +int prpsio_epa # epa of the etc$prpsio procedure. +include "gki.com" + +begin + gk_type[stream] = pid + gk_fd[stream] = stream + gk_prpsio = prpsio_epa +end diff --git a/sys/gio/gki/gkiopen.x b/sys/gio/gki/gkiopen.x new file mode 100644 index 00000000..562ed8c3 --- /dev/null +++ b/sys/gio/gki/gkiopen.x @@ -0,0 +1,67 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_OPENWS -- Open workstation. +# +# BOI GKI_OPENWS L M N D +# +# L(i) 5 + N +# M(i) access mode (APPEND=4, NEW_FILE=5, TEE=6) +# N(i) number of characters in field D +# D(Nc) device name as in graphcap file + +procedure gki_openws (fd, device, mode) + +int fd # output file +char device[ARB] # device name +int mode # access mode + +int ip, n, epa, nchars +pointer sp, gki, op +int strlen() +include "gki.com" + +begin + call smark (sp) + + n = strlen (device) + call salloc (gki, GKI_OPENWS_LEN + n, TY_SHORT) + + # Pack the device name as a SHORT integer array. + op = gki + GKI_OPENWS_D - 1 + for (ip=1; ip <= n; ip=ip+1) { + Mems[op] = device[ip] + op = op + 1 + } + + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_OPENWS] + if (epa != 0) + call zcall3 (epa, Mems[gki+GKI_OPENWS_D-1], n, mode) + } else { + Mems[gki ] = BOI + Mems[gki+1] = GKI_OPENWS + Mems[gki+2] = GKI_OPENWS_LEN + n + Mems[gki+GKI_OPENWS_M-1] = mode + Mems[gki+GKI_OPENWS_N-1] = n + + # Send a copy of the open workstation directive to PSIOCTRL in + # the CL process to connect the graphics stream to a kernel, + # before writing to the graphics stream. The GKI instruction + # must be preceded by the integer value of the stream number. + + nchars = (GKI_OPENWS_LEN + n) * SZ_SHORT + if (IS_FILE(fd) && (fd >= STDGRAPH && fd <= STDPLOT)) { + call write (PSIOCTRL, fd, SZ_INT32) + call write (PSIOCTRL, Mems[gki], nchars) + call flush (PSIOCTRL) + } + + # Now send a copy to the graphics kernel. + call write (gk_fd[fd], Mems[gki], nchars) + } + + call sfree (sp) +end diff --git a/sys/gio/gki/gkipca.x b/sys/gio/gki/gkipca.x new file mode 100644 index 00000000..b2cf30ab --- /dev/null +++ b/sys/gio/gki/gkipca.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_PUTCELLARRAY -- Output a cell array (pixel array). +# +# BOI GKI_PUTCELLARRAY L LL UR NC NL P +# +# L(i) 9 + (NC * NL) +# LL(p) coordinates of lower left corner of output area +# UR(p) coordinates of upper right corner of output area +# NC(i) number of columns in array +# NL(i) number of lines in array +# P(NCNLi) array of color indices (pixels) stored by row + +procedure gki_putcellarray (fd, m, nx, ny, x1,y1, x2,y2) + +int fd # output file +int nx, ny # number of columns and lines in M +short m[nx,ny] # pixel array +int x1, y1 # lower left corner of window to be written +int x2, y2 # upper right corner of window to be written + +int epa +short gki[GKI_PUTCELLARRAY_LEN] +data gki[1] /BOI/, gki[2] /GKI_PUTCELLARRAY/ +include "gki.com" + +begin + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_PUTCELLARRAY] + if (epa != 0) + call zcall7 (epa, m, nx,ny, x1,y1, x2,y2) + } else { + gki[GKI_PUTCELLARRAY_L] = GKI_PUTCELLARRAY_LEN + (nx * ny) + gki[GKI_PUTCELLARRAY_LL] = x1 + gki[GKI_PUTCELLARRAY_LL+1] = y1 + gki[GKI_PUTCELLARRAY_UR] = x2 + gki[GKI_PUTCELLARRAY_UR+1] = y2 + gki[GKI_PUTCELLARRAY_NC] = nx + gki[GKI_PUTCELLARRAY_NL] = ny + + call write (gk_fd[fd], gki, GKI_PUTCELLARRAY_LEN) + call write (gk_fd[fd], m, (nx * ny) * SZ_SHORT) + } +end diff --git a/sys/gio/gki/gkipl.x b/sys/gio/gki/gkipl.x new file mode 100644 index 00000000..7d36b749 --- /dev/null +++ b/sys/gio/gki/gkipl.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_POLYLINE -- Output a polyline. +# +# BOI GKI_POLYLINE L N P +# +# L(i) 4 + (N * 2) +# N(i) number of points in the polyline +# P(Np) list of points (x,y pairs) + +procedure gki_polyline (fd, points, npts) + +int fd # output file +short points[ARB] # polyline +int npts # number of (x,y) points in polyline + +int epa +short gki[GKI_POLYLINE_LEN] +data gki[1] /BOI/, gki[2] /GKI_POLYLINE/ +include "gki.com" + +begin + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_POLYLINE] + if (epa != 0) + call zcall2 (epa, points, npts) + } else { + gki[GKI_POLYLINE_L] = GKI_POLYLINE_LEN + (npts * 2) + gki[GKI_POLYLINE_N] = npts + + call write (gk_fd[fd], gki, GKI_POLYLINE_LEN * SZ_SHORT) + call write (gk_fd[fd], points, (npts * 2) * SZ_SHORT) + } +end diff --git a/sys/gio/gki/gkiplset.x b/sys/gio/gki/gkiplset.x new file mode 100644 index 00000000..1a7b092f --- /dev/null +++ b/sys/gio/gki/gkiplset.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GKI_PLSET -- Set the polyline attributes. +# +# BOI GKI_PLSET L LT LW CI +# +# L(i) 6 +# LT(i) linetype number +# LW(r) linewidth scale factor +# CI(i) polyline color index + +procedure gki_plset (fd, ap) + +int fd # output file +pointer ap # pointer to polyline attribute structure + +int epa +short gki[GKI_PLSET_LEN] +data gki[1] /BOI/, gki[2] /GKI_PLSET/, gki[3] /GKI_PLSET_LEN/ +include "gki.com" + +begin + gki[GKI_PLSET_LT] = PL_LTYPE(ap) + gki[GKI_PLSET_LW] = GKI_PACKREAL (PL_WIDTH(ap)) + gki[GKI_PLSET_CI] = PL_COLOR(ap) + + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_PLSET] + if (epa != 0) + call zcall1 (epa, gki) + } else + call write (gk_fd[fd], gki, GKI_PLSET_LEN * SZ_SHORT) +end diff --git a/sys/gio/gki/gkipm.x b/sys/gio/gki/gkipm.x new file mode 100644 index 00000000..ea493b54 --- /dev/null +++ b/sys/gio/gki/gkipm.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_POLYMARKER -- Output a polymarker. +# +# BOI GKI_POLYMARKER L N P +# +# L(i) 4 + (N * 2) +# N(i) number of points in the polymarker +# P(Np) list of points (x,y pairs) + +procedure gki_polymarker (fd, points, npts) + +int fd # output file +short points[ARB] # polymarker +int npts # number of (x,y) points in polymarker + +int epa +short gki[GKI_POLYMARKER_LEN] +data gki[1] /BOI/, gki[2] /GKI_POLYMARKER/ +include "gki.com" + +begin + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_POLYMARKER] + if (epa != 0) + call zcall2 (epa, points, npts) + } else { + gki[GKI_POLYMARKER_L] = GKI_POLYMARKER_LEN + (npts * 2) + gki[GKI_POLYMARKER_N] = npts + + call write (gk_fd[fd], gki, GKI_POLYMARKER_LEN * SZ_SHORT) + call write (gk_fd[fd], points, (npts * 2) * SZ_SHORT) + } +end diff --git a/sys/gio/gki/gkipmset.x b/sys/gio/gki/gkipmset.x new file mode 100644 index 00000000..7bdc27ac --- /dev/null +++ b/sys/gio/gki/gkipmset.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GKI_PMSET -- Set the polymarker attributes. +# +# BOI GKI_PMSET L MT MW CI +# +# L(i) 6 +# MT(i) marktype (not used at present) +# MW(i) marksize, NDC coords (not used at present) +# CI(i) marker color index + +procedure gki_pmset (fd, ap) + +int fd # output file +pointer ap # pointer to polymarker attribute structure + +int epa +short gki[GKI_PMSET_LEN] +data gki[1] /BOI/, gki[2] /GKI_PMSET/, gki[3] /GKI_PMSET_LEN/ +include "gki.com" + +begin + gki[GKI_PMSET_MT] = PM_LTYPE(ap) + gki[GKI_PMSET_MW] = GKI_PACKREAL (PM_WIDTH(ap)) + gki[GKI_PMSET_CI] = PM_COLOR(ap) + + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_PMSET] + if (epa != 0) + call zcall1 (epa, gki) + } else + call write (gk_fd[fd], gki, GKI_PMSET_LEN * SZ_SHORT) +end diff --git a/sys/gio/gki/gkiprint.x b/sys/gio/gki/gkiprint.x new file mode 100644 index 00000000..14e623bd --- /dev/null +++ b/sys/gio/gki/gkiprint.x @@ -0,0 +1,820 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +.help gkiprint +.nf __________________________________________________________________________ +GKIPRINT -- Graphics kernel for decoding metacode. This graphics kernel +formats metacode instructions into readable form and prints them on the output +file. The gkiprint kernel is useful for examining metafiles and for +debugging kernels which drive specific devices. The driver consists of the +following procedures: + + gkp_openws (devname, n, mode) + gkp_closews (devname, n) + gkp_deactivatews (flags) + gkp_reactivatews (flags) + gkp_mftitle (title, n) ** + gkp_clear (dummy) + gkp_cancel (dummy) + gkp_flush (dummy) + gkp_polyline (p, npts) + gkp_polymarker (p, npts) + gkp_text (x, y, text, n) + gkp_fillarea (p, npts) + gkp_getcellarray (m, nx, ny, x1,y1, x2,y2) + gkp_putcellarray (m, nx, ny, x1,y1, x2,y2) + gkp_setcursor (x, y, cursor) + gkp_plset (gki) + gkp_pmset (gki) + gkp_txset (gki) + gkp_faset (gki) + gkp_getcursor (cursor) + gkp_escape (fn, instruction, nwords) ** + gkp_setwcs (wcs, nwords) ** + gkp_getwcs (wcs, nwords) ** + gkp_unknown (gki) ** + +A GKI driven device driver may implement any subset of these procedures. +The starred procedures should be omitted by most drivers. In particular, +the SETWCS and GETWCS instructions are internal instructions which should +be ignored by ordinary device drivers. The procedure names may be anything, +but the arguments lists must be as shown. All coordinates are in GKI units, +0 to 32767. Character strings are passed in ASCII, one character per metacode +word. Whenever a GKI character string appears as an array argument in the +argument list of a procedure, the count N of the number of characters in the +string follows as the next argument. GKI character strings are not EOS +delimited. Polyline, polymarker, and fillarea data is passed as an array +of (x,y) points P, in GKI coordinates, defining the polyline or polygon to +be plotted. + +One additional procedure, GKP_INSTALL, is called by the main program of the +graphics kernel task to install the debugging driver, i.e., to fill the DD +array with the entry point addresses of the driver procedures. For a normal +driver this function is performed by a user supplied procedure named +GKOPEN (graphics kernel open). The user supplied kernel procedures will +be called to execute each instruction as the instructions are decoded by the +main routine. The user supplied procedure GKCLOSE will be called when +interpretation ends and the task is about to exit. + + gkopen (dd) + gkclose () + +Do not confuse GKOPEN and GKCLOSE, which open and close the graphics kernel, +with GKI_OPENWS and GKI_CLOSEWS, the metacode instructions used to direct +an opened kernel to open and close workstations. +.endhelp ___________________________________________________________________ + + +# GKP_INSTALL -- Install the GKI debugging kernel as a graphics kernel +# device driver. The device table DD consists of an array of the entry +# point addresses for the driver procedures. If a driver does not implement +# a particular instruction the table entry for that procedure may be set +# to zero, causing the interpreter to ignore the instruction. + +procedure gkp_install (dd, out_fd, verbose_output, use_gkiunits) + +int dd[ARB] # device table to be initialized +int out_fd # output file +int verbose_output # verbose output desired +int use_gkiunits # print coords in GKI units rather than NDC + +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +extern gkp_openws(), gkp_closews(), gkp_mftitle(), gkp_clear(), gkp_cancel() +extern gkp_flush(), gkp_polyline(), gkp_polymarker(), gkp_text() +extern gkp_fillarea(), gkp_putcellarray(), gkp_setcursor(), gkp_plset() +extern gkp_pmset(), gkp_txset(), gkp_faset(), gkp_getcursor() +extern gkp_getcellarray(), gkp_escape(), gkp_setwcs(), gkp_getwcs() +extern gkp_unknown(), gkp_reactivatews(), gkp_deactivatews() + +begin + # Set the GDC internal parameters. + fd = out_fd + stream = NULL + gkiunits = use_gkiunits + verbose = verbose_output + + # Install the device driver. + call zlocpr (gkp_openws, dd[GKI_OPENWS]) + call zlocpr (gkp_closews, dd[GKI_CLOSEWS]) + call zlocpr (gkp_reactivatews, dd[GKI_REACTIVATEWS]) + call zlocpr (gkp_deactivatews, dd[GKI_DEACTIVATEWS]) + call zlocpr (gkp_mftitle, dd[GKI_MFTITLE]) + call zlocpr (gkp_clear, dd[GKI_CLEAR]) + call zlocpr (gkp_cancel, dd[GKI_CANCEL]) + call zlocpr (gkp_flush, dd[GKI_FLUSH]) + call zlocpr (gkp_polyline, dd[GKI_POLYLINE]) + call zlocpr (gkp_polymarker, dd[GKI_POLYMARKER]) + call zlocpr (gkp_text, dd[GKI_TEXT]) + call zlocpr (gkp_fillarea, dd[GKI_FILLAREA]) + call zlocpr (gkp_putcellarray, dd[GKI_PUTCELLARRAY]) + call zlocpr (gkp_setcursor, dd[GKI_SETCURSOR]) + call zlocpr (gkp_plset, dd[GKI_PLSET]) + call zlocpr (gkp_pmset, dd[GKI_PMSET]) + call zlocpr (gkp_txset, dd[GKI_TXSET]) + call zlocpr (gkp_faset, dd[GKI_FASET]) + call zlocpr (gkp_getcursor, dd[GKI_GETCURSOR]) + call zlocpr (gkp_getcellarray, dd[GKI_GETCELLARRAY]) + call zlocpr (gkp_escape, dd[GKI_ESCAPE]) + call zlocpr (gkp_setwcs, dd[GKI_SETWCS]) + call zlocpr (gkp_getwcs, dd[GKI_GETWCS]) + call zlocpr (gkp_unknown, dd[GKI_UNKNOWN]) +end + + +# GKP_CLOSE -- Close the GKP kernel. + +procedure gkp_close() +begin +end + + +# GKP_GRSTREAM -- Set the FD of the graphics stream, from which we shall read +# metacode instructions and to which we shall return cell arrays and cursor +# values. + +procedure gkp_grstream (graphics_stream) + +int graphics_stream # FD of the new graphics stream +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + stream = graphics_stream +end + + +# GKP_OPENWS -- Open the named workstation. + +procedure gkp_openws (devname, n, mode) + +short devname[ARB] # device name +int n # length of device name +int mode # access mode + +int junk +pointer sp, buf +int itoc() +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call smark (sp) + call salloc (buf, max (SZ_FNAME, n), TY_CHAR) + + call achtsc (devname, Memc[buf], n) + Memc[buf+n] = EOS + + call fprintf (fd, "open_workstation '%s', mode=%s\n") + call pargstr (Memc[buf]) + switch (mode) { + case NEW_FILE: + call pargstr ("new_file") + case APPEND: + call pargstr ("append") + default: + junk = itoc (mode, Memc[buf], SZ_FNAME) + } + + call sfree (sp) +end + + +# GKP_CLOSEWS -- Close the named workstation. + +procedure gkp_closews (devname, n) + +short devname[ARB] # device name +int n # length of device name +pointer sp, buf +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call smark (sp) + call salloc (buf, n, TY_CHAR) + + call achtsc (devname, Memc[buf], n) + Memc[buf+n] = EOS + + call fprintf (fd, "close_workstation '%s'\n") + call pargstr (Memc[buf]) + call flush (fd) + + call sfree (sp) +end + + +# GKP_REACTIVATEWS -- Reactivate the workstation (enable graphics). + +procedure gkp_reactivatews (flags) + +int flags # action flags +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call fprintf (fd, "reactivatews %d\n") + call pargi (flags) +end + + +# GKP_DEACTIVATEWS -- Deactivate the workstation (disable graphics). + +procedure gkp_deactivatews (flags) + +int flags # action flags +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call fprintf (fd, "deactivatews %d\n") + call pargi (flags) + call flush (fd) +end + + +# GKP_MFTITLE -- Metafile title or comment. A nonfunctional instruction used +# to document a metafile. + +procedure gkp_mftitle (title, n) + +short title[ARB] # title string +int n # length of title string +pointer sp, buf +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call smark (sp) + call salloc (buf, n, TY_CHAR) + + call achtsc (title, Memc[buf], n) + Memc[buf+n] = EOS + + call fprintf (fd, "title '%s'\n") + call pargstr (Memc[buf]) + + call sfree (sp) +end + + +# GKP_CLEAR -- Clear the workstation screen. + +procedure gkp_clear (dummy) + +int dummy # not used at present +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call fprintf (fd, "clear\n") +end + + +# GKP_CANCEL -- Cancel output. + +procedure gkp_cancel (dummy) + +int dummy # not used at present +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call fprintf (fd, "cancel\n") + call flush (fd) +end + + +# GKP_FLUSH -- Flush output. + +procedure gkp_flush (dummy) + +int dummy # not used at present +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call fprintf (fd, "flush\n") + call flush (fd) +end + + +# GKP_POLYLINE -- Draw a polyline. + +procedure gkp_polyline (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + # Print statistics on polyline. + call gkp_pstat (fd, p, npts, "polyline", verbose, gkiunits) +end + + +# GKP_POLYMARKER -- Draw a polymarker. + +procedure gkp_polymarker (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + # Print statistics on polymarker. + call gkp_pstat (fd, p, npts, "polymarker", verbose, gkiunits) +end + + +# GKP_FILLAREA -- Fill a closed area. + +procedure gkp_fillarea (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + # Print statistics on the fillarea polygon. + call gkp_pstat (fd, p, npts, "fillarea", verbose, gkiunits) +end + + +# GKP_TEXT -- Draw a text string. + +procedure gkp_text (x, y, text, n) + +int x, y # where to draw text string +short text[ARB] # text string +int n # number of characters + +pointer sp, buf +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call smark (sp) + call salloc (buf, n, TY_CHAR) + + call achtsc (text, Memc[buf], n) + Memc[buf+n] = EOS + + if (gkiunits == YES) { + call fprintf (fd, "text %5d, %5d, '%s'\n") + call pargi (x) + call pargi (y) + call pargstr (Memc[buf]) + } else { + call fprintf (fd, "text %4.2f, %4.2f, '%s'\n") + call pargr (real(x) / GKI_MAXNDC) + call pargr (real(y) / GKI_MAXNDC) + call pargstr (Memc[buf]) + } + + call sfree (sp) +end + + +# GKP_PUTCELLARRAY -- Draw a cell array, i.e., two dimensional array of pixels +# (greylevels or colors). + +procedure gkp_putcellarray (m, nx, ny, x1,y1, x2,y2) + +int nx, ny # number of pixels in X and Y +short m[nx,ny] # cell array +int x1, y1 # lower left corner of output window +int x2, y2 # lower left corner of output window + +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call fprintf (fd, "put_cellarray nx=%d, ny=%d, ") + call pargi (nx) + call pargi (ny) + + if (gkiunits == YES) { + call fprintf (fd, "x1=%5d, y1=%5d, x2=%5d, y2=%5d\n") + call pargi (x1) + call pargi (y1) + call pargi (x2) + call pargi (y2) + } else { + call fprintf (fd, "x1=%4.2f, y1=%4.2f, x2=%4.2f, y2=%4.2f\n") + call pargr (real(x1) / GKI_MAXNDC) + call pargr (real(y1) / GKI_MAXNDC) + call pargr (real(x2) / GKI_MAXNDC) + call pargr (real(y2) / GKI_MAXNDC) + } + + if (verbose == YES) + call gkp_dump (fd, m, (nx * ny)) +end + + +# GKP_GETCELLARRAY -- Input a cell array, i.e., two dimensional array of pixels +# (greylevels or colors). + +procedure gkp_getcellarray (nx, ny, x1,y1, x2,y2) + +int nx, ny # number of pixels in X and Y +int x1, y1 # lower left corner of input window +int x2, y2 # lower left corner of input window + +pointer sp, buf +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call fprintf (fd, "get_cellarray nx=%d, ny=%d, ") + call pargi (nx) + call pargi (ny) + + if (gkiunits == YES) { + call fprintf (fd, "x1=%5d, y1=%5d, x2=%5d, y2=%5d\n") + call pargi (x1) + call pargi (y1) + call pargi (x2) + call pargi (y2) + } else { + call fprintf (fd, "x1=%4.2f, y1=%4.2f, x2=%4.2f, y2=%4.2f\n") + call pargr (real(x1) / GKI_MAXNDC) + call pargr (real(y1) / GKI_MAXNDC) + call pargr (real(x2) / GKI_MAXNDC) + call pargr (real(y2) / GKI_MAXNDC) + } + + if (stream == NULL) + return + + call smark (sp) + call salloc (buf, nx * ny, TY_SHORT) + call amovks (short(-1), Mems[buf], nx * ny) + + call flush (fd) + iferr { + call gki_retcellarray (stream, Mems[buf], nx * ny) + call flush (stream) + } then + ; + + call sfree (sp) +end + + +# GKP_SETCURSOR -- Set the position of a cursor. + +procedure gkp_setcursor (x, y, cursor) + +int x, y # new position of cursor +int cursor # cursor to be set +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + if (gkiunits == YES) { + call fprintf (fd, "set_cursor %5d, %5d, cursor=%d\n") + call pargi (x) + call pargi (y) + call pargi (cursor) + } else { + call fprintf (fd, "set_cursor %4.2f, %4.2f, cursor=%d\n") + call pargr (real(x) / GKI_MAXNDC) + call pargr (real(y) / GKI_MAXNDC) + call pargi (cursor) + } +end + + +# GKP_GETCURSOR -- Get the position of a cursor. + +procedure gkp_getcursor (cursor) + +int cursor +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call fprintf (fd, "get_cursor cursor=%d\n") + call pargi (cursor) + call flush (fd) + + if (stream != NULL) + iferr { + # gki_retcursorvalue (stream, cn, key, sx, sy, rn, rx, ry) + call gki_retcursorvalue (stream, 0, EOF, 0, 0, 0, 0, 0) + call flush (stream) + } then + ; +end + + +# GKP_PLSET -- Set the polyline attributes. + +procedure gkp_plset (gki) + +short gki[ARB] # attribute structure +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call fprintf (fd, "set_polyline ltype=%d, lwidth=%0.2f, color=%d\n") + call pargs (gki[GKI_PLSET_LT]) + call pargr (GKI_UNPACKREAL (gki[GKI_PLSET_LW])) + call pargs (gki[GKI_PLSET_CI]) +end + + +# GKP_PMSET -- Set the polymarker attributes. + +procedure gkp_pmset (gki) + +short gki[ARB] # attribute structure +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call fprintf (fd, "set_polymarker mtype=%d, mwidth=%0.2f, color=%d\n") + call pargs (gki[GKI_PMSET_MT]) + call pargr (GKI_UNPACKREAL (gki[GKI_PMSET_MW])) + call pargs (gki[GKI_PMSET_CI]) +end + + +# GKP_FASET -- Set the fillarea attributes. + +procedure gkp_faset (gki) + +short gki[ARB] # attribute structure +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call fprintf (fd, "set_fillarea style=%d, color=%d\n") + call pargs (gki[GKI_FASET_FS]) + call pargs (gki[GKI_FASET_CI]) +end + + +# GKP_TXSET -- Set the text drawing attributes. + +procedure gkp_txset (gki) + +short gki[ARB] # attribute structure +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call fprintf (fd, "set_text up=%d, path=%d, hjustify=%s, ") + call pargs (gki[GKI_TXSET_UP]) + call gkp_txparg (gki[GKI_TXSET_P]) + call gkp_txparg (gki[GKI_TXSET_HJ]) + call fprintf (fd, "vjustify=%s, font=%s,\n") + call gkp_txparg (gki[GKI_TXSET_VJ]) + call gkp_txparg (gki[GKI_TXSET_F]) + + call fprintf (fd, "\tsize=%0.2f, spacing=%0.2f, color=%d, quality=%s\n") + call pargr (GKI_UNPACKREAL (gki[GKI_TXSET_SZ])) + call pargr (GKI_UNPACKREAL (gki[GKI_TXSET_SP])) + call pargs (gki[GKI_TXSET_CI]) + call gkp_txparg (gki[GKI_TXSET_Q]) +end + + +# GKP_ESCAPE -- Device dependent instruction. + +procedure gkp_escape (fn, instruction, nwords) + +int fn # function code +short instruction[ARB] # instruction data words +int nwords # length of instruction +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call fprintf (fd, "escape %d, nwords=%d\n") + call pargi (fn) + call pargi (nwords) + + # Dump the instruction. + if (verbose == YES) + call gkp_dump (fd, instruction, nwords) +end + + +# GKP_SETWCS -- Set the world coordinate systems. Internal GIO instruction. + +procedure gkp_setwcs (wcs, nwords) + +short wcs[ARB] # WCS data +int nwords # number of words of data + +int i, nwcs +pointer sp, wcs_temp, w +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call smark (sp) + call salloc (wcs_temp, LEN_WCSARRAY, TY_STRUCT) + + call fprintf (fd, "set_wcs nwords=%d\n") + call pargi (nwords) + + nwcs = nwords * SZ_SHORT / SZ_STRUCT / LEN_WCS + if (verbose == YES && nwcs > 1) { + call amovi (wcs, Memi[wcs_temp], nwcs * LEN_WCS) + + do i = 1, nwcs { + w = ((i - 1) * LEN_WCS) + wcs_temp + if ((WCS_WX1(w) > EPSILON) || + (abs(1.0 - WCS_WX2(w)) > EPSILON) || + (WCS_WY1(w) > EPSILON) || + (abs(1.0 - WCS_WY2(w)) > EPSILON)) { + + call fprintf (fd, "\t%2d %g %g %g %g ") + call pargi (i) + call pargr (WCS_WX1(w)) + call pargr (WCS_WX2(w)) + call pargr (WCS_WY1(w)) + call pargr (WCS_WY2(w)) + + call fprintf (fd, "%4.2f %4.2f %4.2f %4.2f ") + call pargr (WCS_SX1(w)) + call pargr (WCS_SX2(w)) + call pargr (WCS_SY1(w)) + call pargr (WCS_SY2(w)) + + call fprintf (fd, "%d %d %d\n") + call pargi (WCS_XTRAN(w)) + call pargi (WCS_YTRAN(w)) + call pargi (WCS_CLIP(w)) + } + } + } + + call sfree (sp) +end + + +# GKP_GETWCS -- Get the world coordinate systems. Internal GIO instruction. + +procedure gkp_getwcs (wcs, nwords) + +short wcs[ARB] # WCS data +int nwords # number of words of data +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call fprintf (fd, "get_wcs nwords=%d\n") + call pargi (nwords) +end + + +# GKP_UNKNOWN -- The unknown instruction. Called by the interpreter whenever +# an unrecognized opcode is encountered. Should never be called. + +procedure gkp_unknown (gki) + +short gki[ARB] # the GKI instruction +int fd, stream, verbose, gkiunits +common /gkpcom/ fd, stream, verbose, gkiunits + +begin + call fprintf (fd, "unknown\n") +end + + +# GKP_PSTAT -- Compute and print on the standard error output a statistical +# summary of a sequence of (x,y) points. If verbose mode is enabled, follow +# this by the values of the points themselves. + +procedure gkp_pstat (fd, p, npts, label, verbose, gkiunits) + +int fd # output file +short p[npts] # array of points, i.e., (x,y) pairs +int npts # number of points +char label[ARB] # type of instruction +int verbose # verbose output desired +int gkiunits # print coords in GKI rather than NDC units + +int i +real x, y, xsum, xmin, xmax, ysum, ymin, ymax, scale + +begin + if (gkiunits == YES) + scale = 1.0 + else + scale = 1.0 / GKI_MAXNDC + + xsum = 0 + xmin = 1.0 + xmax = 0 + ysum = 0 + ymin = 1.0 + ymax = 0 + + # Compute mean, minimum, and maximum values. + do i = 1, npts * 2, 2 { + x = real (p[i]) * scale + xsum = xsum + x + if (x < xmin) + xmin = x + if (x > xmax) + xmax = x + + y = real (p[i+1]) * scale + ysum = ysum + y + if (y < ymin) + ymin = y + if (y > ymax) + ymax = y + } + + # Print summary of statistics. + call fprintf (fd, "%s np=%d, ") + call pargstr (label) + call pargi (npts) + + if (gkiunits == YES) + call fprintf (fd, "xmin=%d,xmax=%d,xavg=%d, ") + else + call fprintf (fd, "xmin=%4.2f,xmax=%4.2f,xavg=%4.2f, ") + if (npts == 0) { + do i = 1, 3 + call pargr (INDEF) + } else { + call pargr (xmin) + call pargr (xmax) + call pargr (xsum / npts) + } + + if (gkiunits == YES) + call fprintf (fd, "ymin=%d,ymax=%d,yavg=%d\n") + else + call fprintf (fd, "ymin=%4.2f,ymax=%4.2f,yavg=%4.2f\n") + if (npts == 0) { + do i = 1, 3 + call pargr (INDEF) + } else { + call pargr (ymin) + call pargr (ymax) + call pargr (ysum / npts) + } + + # Dump the points if verbose output is enabled. + if (verbose == NO && npts > 0) + return + + call fprintf (fd, "\t") + for (i=1; i <= npts * 2; i=i+2) { + if (i > 1 && mod (i-1, 10) == 0) + call fprintf (fd, "\n\t") + if (gkiunits == YES) + call fprintf (fd, "%5d %5d ") + else + call fprintf (fd, "%5.3f %5.3f ") + call pargr (real(p[i]) * scale) + call pargr (real(p[i+1]) * scale) + } + call fprintf (fd, "\n") +end + + +# GKP_DUMP -- Print a sequence of metacode words as a table, formatted eight +# words per line, in decimal. + +procedure gkp_dump (fd, data, nwords) + +int fd # output file +short data[ARB] # metacode data +int nwords # number of words of data +int i + +begin + if (nwords <= 0) + return + + call fprintf (fd, "\t") + + for (i=1; i <= nwords; i=i+1) { + if (i > 1 && mod (i-1, 8) == 0) + call fprintf (fd, "\n\t") + call fprintf (fd, "%7d") + call pargs (data[i]) + } + + call fprintf (fd, "\n") +end diff --git a/sys/gio/gki/gkirca.x b/sys/gio/gki/gkirca.x new file mode 100644 index 00000000..54b38813 --- /dev/null +++ b/sys/gio/gki/gkirca.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GKI_RETCELLARRAY -- Return a cell array (pixel array). Used by a graphics +# kernel to return a cell array to GIO in response to a GETCELLARRAY +# instruction. +# +# BOI GKI_CELLARRAY L NP P +# +# L(i) 4 + NP +# NP(i) number of pixels in cell array +# P(NPi) cell array + +procedure gki_retcellarray (fd, m, np) + +int fd # output file +short m[ARB] # cell array +int np # number of pixels in cell array + +short gki[GKI_CELLARRAY_LEN] +data gki[1] /BOI/, gki[2] /GKI_CELLARRAY/ + +begin + gki[GKI_CELLARRAY_L] = GKI_CELLARRAY_LEN + np + gki[GKI_CELLARRAY_NP] = np + + call write (fd, gki, GKI_CELLARRAY_LEN * SZ_SHORT) + call write (fd, m, np * SZ_SHORT) +end diff --git a/sys/gio/gki/gkircval.x b/sys/gio/gki/gkircval.x new file mode 100644 index 00000000..9bfb3052 --- /dev/null +++ b/sys/gio/gki/gkircval.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GKI_RETCURSORVALUE -- Return a cursor value. Used by a graphics kernel to +# return a cursor value to GIO in response to a GETCURSOR instruction. +# +# BOI GKI_CURSORVALUE L CN KEY SX SY RN RX RY +# +# where +# +# L(i) 10 +# CN(i) cursor number +# KEY(i) keystroke value (>= 0 or EOF) +# SX(i) NDC X screen coordinate of cursor +# SY(i) NDC Y screen coordinate of cursor +# RN(i) raster number or zero +# RX(i) NDC X raster coordinate of cursor +# RY(i) NDC Y raster coordinate of cursor +# +# The screen or display window coordinates SX and SY of the cursor are +# returned for all devices. Only some devices support multiple rasters. +# If the device supports rasters and the cursor is in a raster when read, the +# raster number and raster coordinates are returned in RN,RX,RY. This is in +# addition to the screen coordinates SX,SY. If raster coordinates are not +# returned, the raster number will be set to zero and RX,RY will be the same +# as SX,SY. + +procedure gki_retcursorvalue (fd, cn, key, sx, sy, raster, rx, ry) + +int fd #I output file +int cn #I cursor number +int key #I keystroke value +int sx, sy #I screen coordinates of cursor (GKI coords) +int raster #I raster number +int rx, ry #I raster coordinates of cursor (GKI coords) + +short gki[GKI_CURSORVALUE_LEN] +data gki[1] /BOI/, gki[2] /GKI_CURSORVALUE/, gki[3] /GKI_CURSORVALUE_LEN/ + +begin + gki[GKI_CURSORVALUE_CN ] = cn + gki[GKI_CURSORVALUE_KEY] = key + gki[GKI_CURSORVALUE_SX ] = sx + gki[GKI_CURSORVALUE_SY ] = sy + gki[GKI_CURSORVALUE_RN ] = raster + gki[GKI_CURSORVALUE_RX ] = rx + gki[GKI_CURSORVALUE_RY ] = ry + + call write (fd, gki, GKI_CURSORVALUE_LEN * SZ_SHORT) +end diff --git a/sys/gio/gki/gkireact.x b/sys/gio/gki/gkireact.x new file mode 100644 index 00000000..a84ad95d --- /dev/null +++ b/sys/gio/gki/gkireact.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_REACTIVATEWS -- Reactivate the workstation (enable graphics). +# +# BOI GKI_REACTIVATEWS L F +# +# L(i) 4 +# F flags (0,AW_PAUSE,AW_CLEAR) + +procedure gki_reactivatews (fd, flags) + +int fd # output file +int flags # action modifier flags + +int epa, nchars +short gki[GKI_REACTIVATEWS_LEN] +data gki[1] /BOI/, gki[2] /GKI_REACTIVATEWS/, gki[3] /GKI_REACTIVATEWS_LEN/ +include "gki.com" + +begin + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_REACTIVATEWS] + if (epa != 0) + call zcall1 (epa, flags) + + } else { + # Send a copy to the pseudofile i/o controller. + gki[GKI_REACTIVATEWS_F] = flags + nchars = GKI_REACTIVATEWS_LEN * SZ_SHORT + if (IS_FILE(fd) && (fd >= STDGRAPH && fd <= STDPLOT)) { + call write (PSIOCTRL, fd, SZ_INT32) + call write (PSIOCTRL, gki, nchars) + call flush (PSIOCTRL) + } + + # Now send a copy to the graphics kernel. + call write (gk_fd[fd], gki, nchars) + } +end diff --git a/sys/gio/gki/gkiredir.x b/sys/gio/gki/gkiredir.x new file mode 100644 index 00000000..3e204bf0 --- /dev/null +++ b/sys/gio/gki/gkiredir.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_REDIR -- Redirect (or set) a graphics stream. All i/o will be to the +# file FD until the graphics stream is reset in another call to GKI_REDIR. +# The current encoded value for a stream is retured so that a subsequent call +# (with FD=0) may be made to undo the redirection. A call with FD<0 may be +# used to stat the stream without changing anything. NOTE: This procedure +# (or either GKI_INLINE_KERNEL or GKI_SUBKERNEL) must be called before using +# the GKI package for a graphics stream. + +procedure gki_redir (stream, fd, old_fd, old_type) + +int stream # graphics stream to be redirected +int fd # file to be connected to the stream +int old_fd, old_type # old values for later restoration + +include "gki.com" + +begin + if (fd == NULL) { + gk_type[stream] = old_type + gk_fd[stream] = old_fd + } else { + old_type = gk_type[stream] + old_fd = gk_fd[stream] + if (fd > 0) { + gk_type[stream] = TY_FILE + gk_fd[stream] = fd + } + } +end diff --git a/sys/gio/gki/gkiscur.x b/sys/gio/gki/gkiscur.x new file mode 100644 index 00000000..f3ca7c53 --- /dev/null +++ b/sys/gio/gki/gkiscur.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_SETCURSOR -- Set the position of a device cursor. +# +# BOI GKI_SETCURSOR L CN POS +# +# L(i) 6 +# CN(i) cursor number +# POS(p) new cursor position + +procedure gki_setcursor (fd, x, y, cursor) + +int fd # output file +int x, y # new cursor position +int cursor # cursor to be set + +int epa +short gki[GKI_SETCURSOR_LEN] +data gki[1] /BOI/, gki[2] /GKI_SETCURSOR/, gki[3] /GKI_SETCURSOR_LEN/ +include "gki.com" + +begin + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_SETCURSOR] + if (epa != 0) + call zcall3 (epa, x, y, cursor) + } else { + gki[GKI_SETCURSOR_CN] = cursor + gki[GKI_SETCURSOR_POS] = x + gki[GKI_SETCURSOR_POS+1] = y + + call write (gk_fd[fd], gki, GKI_SETCURSOR_LEN * SZ_SHORT) + } +end diff --git a/sys/gio/gki/gkisetwcs.x b/sys/gio/gki/gkisetwcs.x new file mode 100644 index 00000000..f8d0e896 --- /dev/null +++ b/sys/gio/gki/gkisetwcs.x @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_SETWCS -- Copy the set of 16 WCS to the graphics controller in the CL +# process. The WCS are transmitted as a binary array of WCS structures. +# +# BOI GKI_SETWCS L N WCS +# +# L(i) 4 + N +# N(i) length of WCS field in words +# WCS binary copy of the 16 WCS structures, transmitted +# in a single call to WRITE + +procedure gki_setwcs (fd, wcs, len_wcs) + +int fd # output file +int wcs[ARB] # array of WCS structures +int len_wcs # number of ints (struct units) in array + +int nshorts +short gki[GKI_SETWCS_LEN] +data gki[1] /BOI/, gki[2] /GKI_SETWCS/ +include "gki.com" + +begin + if (IS_FILE(fd)) { + nshorts = (len_wcs * SZ_INT) / SZ_SHORT + gki[GKI_SETWCS_L] = GKI_SETWCS_LEN + nshorts + gki[GKI_SETWCS_N] = nshorts + + if (fd >= STDGRAPH && fd <= STDPLOT) { + # Send a copy of the WCS information to the PSIO control + # stream if the graphics output is a standard graphics stream. + + call write (PSIOCTRL, fd, SZ_INT32) + call write (PSIOCTRL, gki, GKI_SETWCS_LEN * SZ_SHORT) + call write (PSIOCTRL, wcs, nshorts * SZ_SHORT) + call flush (PSIOCTRL) + } + + call write (gk_fd[fd], gki, GKI_SETWCS_LEN * SZ_SHORT) + call write (gk_fd[fd], wcs, nshorts * SZ_SHORT) + } +end diff --git a/sys/gio/gki/gkititle.x b/sys/gio/gki/gkititle.x new file mode 100644 index 00000000..397bd50a --- /dev/null +++ b/sys/gio/gki/gkititle.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_MFTITLE -- Write the metafile title. +# +# BOI GKI_MFTITLE L N T +# +# L(i) 4 + N +# N(i) number of characters in field T +# T(Nc) title string identifying metafile + +procedure gki_mftitle (fd, title) + +int fd # output file +char title[ARB] # title string + +int epa +int ip, n +pointer sp, gki, op +int strlen() +include "gki.com" + +begin + call smark (sp) + + n = strlen (title) + call salloc (gki, GKI_MFTITLE_LEN + n, TY_SHORT) + + # Pack the title name as a SHORT integer array. + op = gki + GKI_MFTITLE_T - 1 + for (ip=1; ip <= n; ip=ip+1) { + Mems[op] = title[ip] + op = op + 1 + } + + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_MFTITLE] + if (epa != 0) + call zcall2 (epa, Mems[gki+GKI_MFTITLE_T-1], n) + } else { + Mems[gki ] = BOI + Mems[gki+1] = GKI_MFTITLE + Mems[gki+2] = GKI_MFTITLE_LEN + n + Mems[gki+3] = n + call write (gk_fd[fd], Mems[gki], (GKI_MFTITLE_LEN + n) * SZ_SHORT) + } + + call sfree (sp) +end diff --git a/sys/gio/gki/gkitx.x b/sys/gio/gki/gkitx.x new file mode 100644 index 00000000..7cc616ba --- /dev/null +++ b/sys/gio/gki/gkitx.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_TEXT -- Text drawing instruction. +# +# BOI GKI_TEXT L P N T +# +# L(i) 6 + N +# P(p) starting point of character string +# N(i) number of characters in string T +# T(Nc) string of N ASCII characters + +procedure gki_text (fd, x, y, text) + +int fd # output file +int x, y # position at which text is to be drawn +char text[ARB] # text string to be drawn + +int epa +int ip, n +pointer sp, gki, op +int strlen() +include "gki.com" + +begin + call smark (sp) + + n = strlen (text) + call salloc (gki, GKI_TEXT_LEN + n, TY_SHORT) + + # Pack the text string as a SHORT integer array. + op = gki + GKI_TEXT_T - 1 + for (ip=1; ip <= n; ip=ip+1) { + Mems[op] = text[ip] + op = op + 1 + } + + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_TEXT] + if (epa != 0) + call zcall4 (epa, x, y, Mems[gki+GKI_TEXT_T-1], n) + } else { + Mems[gki ] = BOI + Mems[gki+1] = GKI_TEXT + Mems[gki+2] = GKI_TEXT_LEN + n + Mems[gki+GKI_TEXT_L-1] = GKI_TEXT_LEN + n + Mems[gki+GKI_TEXT_P-1] = x + Mems[gki+GKI_TEXT_P-1+1] = y + Mems[gki+GKI_TEXT_N-1] = n + + call write (gk_fd[fd], Mems[gki], (GKI_TEXT_LEN + n) * SZ_SHORT) + } + + call sfree (sp) +end diff --git a/sys/gio/gki/gkitxset.x b/sys/gio/gki/gkitxset.x new file mode 100644 index 00000000..93f427b9 --- /dev/null +++ b/sys/gio/gki/gkitxset.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GKI_TXSET -- Set the text drawing attributes. +# +# BOI GKI_TXSET L UP SZ SP P HJ VJ F Q CI +# +# L(i) 12 +# UP(i) character up vector (degrees) +# SZ(r) character size scale factor +# SP(r) character spacing +# P(i) path (0,1=right,2=left,3=up,4=down) +# HJ(i) horizontal justification +# (0=normal,1=center,2=left,3=right) +# VJ(i) vertical justification +# (0=normal,1=center,2=up,3=down) +# F(i) font (0,1=roman,2=greek,3=italic,4=bold) +# Q(i) quality (0=normal,1=low,2=medium,3=high) +# CI(i) text color index + +procedure gki_txset (fd, ap) + +int fd # output file +pointer ap # pointer to attribute structure + +int epa +short gki[GKI_TXSET_LEN] +data gki[1] /BOI/, gki[2] /GKI_TXSET/, gki[3] /GKI_TXSET_LEN/ +include "gki.com" + +begin + gki[GKI_TXSET_UP] = TX_UP(ap) + gki[GKI_TXSET_SZ] = GKI_PACKREAL (TX_SIZE(ap)) + gki[GKI_TXSET_SP] = GKI_PACKREAL (TX_SPACING(ap)) + gki[GKI_TXSET_P ] = TX_PATH(ap) + gki[GKI_TXSET_HJ] = TX_HJUSTIFY(ap) + gki[GKI_TXSET_VJ] = TX_VJUSTIFY(ap) + gki[GKI_TXSET_F ] = TX_FONT(ap) + gki[GKI_TXSET_Q ] = TX_QUALITY(ap) + gki[GKI_TXSET_CI] = TX_COLOR(ap) + + if (IS_INLINE(fd)) { + epa = gk_dd[GKI_TXSET] + if (epa != 0) + call zcall1 (epa, gki) + } else + call write (gk_fd[fd], gki, GKI_TXSET_LEN * SZ_SHORT) +end diff --git a/sys/gio/gki/gkiwesc.x b/sys/gio/gki/gkiwesc.x new file mode 100644 index 00000000..bd4c8571 --- /dev/null +++ b/sys/gio/gki/gkiwesc.x @@ -0,0 +1,59 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_WESCAPE -- Write a GKI escape instruction, used to pass device +# dependent instructions on to a graphics kernel. This version of gki_escape +# is used in cases where the escape instruction consists of the escape header +# followed by a block of data, and it is inconvenient to have to combine the +# header and the data into one array. +# +# BOI GKI_ESCAPE L FN N DC +# +# L(i) 5 + N +# FN(i) escape function code +# N(i) number of escape data words +# DC(i) escape data words + +procedure gki_wescape (fd, fn, hdr, hdrlen, data, datalen) + +int fd #I output file +int fn #I escape function code +short hdr[ARB] #I escape instruction header +int hdrlen #I header length, shorts +short data[ARB] #I escape instruction data +int datalen #I data length, shorts + +pointer sp, buf +int epa, nwords +short gki[GKI_ESCAPE_LEN] +data gki[1] /BOI/, gki[2] /GKI_ESCAPE/ +include "gki.com" + +begin + nwords = hdrlen + datalen + + if (IS_INLINE(fd)) { + call smark (sp) + call salloc (buf, nwords, TY_SHORT) + + call amovs (hdr, Mems[buf], hdrlen) + call amovs (data, Mems[buf+hdrlen], datalen) + + epa = gk_dd[GKI_ESCAPE] + if (epa != 0) + call zcall3 (epa, fn, Mems[buf], nwords) + + call sfree (sp) + + } else { + gki[GKI_ESCAPE_L] = GKI_ESCAPE_LEN + nwords + gki[GKI_ESCAPE_N] = nwords + gki[GKI_ESCAPE_FN] = fn + + call write (gk_fd[fd], gki, GKI_ESCAPE_LEN * SZ_SHORT) + call write (gk_fd[fd], hdr, hdrlen * SZ_SHORT) + call write (gk_fd[fd], data, datalen * SZ_SHORT) + } +end diff --git a/sys/gio/gki/gkiwrite.x b/sys/gio/gki/gkiwrite.x new file mode 100644 index 00000000..65d911b1 --- /dev/null +++ b/sys/gio/gki/gkiwrite.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKI_WRITE -- Write a GKI metacode instruction to a graphics kernel. If the +# kernel is inline the kernel is directly called to execute the instruction, +# otherwise the instruction is written into the graphics stream for the +# kernel. This procedure is functionally equivalent to GKI_EXECUTE, but works +# for both inline and external kernels. + +procedure gki_write (fd, gki) + +int fd # graphics stream +short gki[ARB] # encoded instruction +int length +include "gki.com" + +begin + if (IS_INLINE(fd)) + call gki_execute (gki, gk_dd) + else { + length = gki[GKI_HDR_LENGTH] + call write (gk_fd[fd], gki, length * SZ_SHORT) + } +end diff --git a/sys/gio/gki/gkptxparg.x b/sys/gio/gki/gkptxparg.x new file mode 100644 index 00000000..75d7325a --- /dev/null +++ b/sys/gio/gki/gkptxparg.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GKP_TXPARG -- Convert a short integer text attribute code into a string +# and pass the string to FMTIO. + +procedure gkp_txparg (code) + +short code # defined in + +begin + switch (code) { + case GT_NORMAL: + call pargstr ("normal") + case GT_CENTER: + call pargstr ("center") + case GT_LEFT: + call pargstr ("left") + case GT_RIGHT: + call pargstr ("right") + case GT_UP: + call pargstr ("up") + case GT_DOWN: + call pargstr ("down") + case GT_TOP: + call pargstr ("top") + case GT_BOTTOM: + call pargstr ("bottom") + case GT_ROMAN: + call pargstr ("roman") + case GT_GREEK: + call pargstr ("greek") + case GT_ITALIC: + call pargstr ("italic") + case GT_BOLD: + call pargstr ("bold") + case GT_LOW: + call pargstr ("low") + case GT_MEDIUM: + call pargstr ("medium") + case GT_HIGH: + call pargstr ("high") + default: + call pargstr ("??") + } +end diff --git a/sys/gio/gki/mkpkg b/sys/gio/gki/mkpkg new file mode 100644 index 00000000..c71f2e71 --- /dev/null +++ b/sys/gio/gki/mkpkg @@ -0,0 +1,46 @@ +# Make the GKI (graphics kernel interface) package. + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + gkicancel.x gki.com + gkiclear.x gki.com + gkiclose.x gki.com + gkideact.x gki.com + gkieof.x gki.com + gkiesc.x gki.com + gkiexe.x + gkifa.x gki.com + gkifaset.x gki.com + gkifetch.x + gkifflush.x gki.com + gkiflush.x gki.com + gkigca.x gki.com + gkigcur.x gki.com + gkigetwcs.x gki.com + gkiinit.x gki.com + gkiinline.x gki.com + gkikern.x gki.com + gkiopen.x gki.com + gkipca.x gki.com + gkipl.x gki.com + gkiplset.x gki.com + gkipm.x gki.com + gkipmset.x gki.com + gkiprint.x + gkirca.x + gkircval.x + gkireact.x gki.com + gkiredir.x gki.com + gkiscur.x gki.com + gkisetwcs.x gki.com + gkititle.x gki.com + gkitx.x gki.com + gkitxset.x gki.com + gkiwesc.x gki.com + gkiwrite.x gki.com + gkptxparg.x + ; diff --git a/sys/gio/gki/zzdebug.x b/sys/gio/gki/zzdebug.x new file mode 100644 index 00000000..e56c5cc0 --- /dev/null +++ b/sys/gio/gki/zzdebug.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +task ggcur = t_ggcur + + +# GGCUR -- Debug cursor read in inline graphics kernel. + +procedure t_ggcur() + +pointer gp +char device[SZ_FNAME] + +real cx, cy +int key, xres, yres, hardchar +int dd[LEN_GKIDD] +pointer gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + hardchar = YES + xres = 0 + yres = 0 + + call fseti (STDGRAPH, F_TYPE, SPOOL_FILE) + call fseti (STDGRAPH, F_CANCEL, OK) + + call stg_open (device, dd, STDIN, STDOUT, xres, yres, hardchar) + call gki_inline_kernel (STDGRAPH, dd) + + gp = gopen (device, NEW_FILE, STDGRAPH) + call ggcur (gp, cx, cy, key) + + call gclose (gp) + call stg_close() + + call printf ("cx=%f, cy=%f, key=%d\n") + call pargr (cx) + call pargr (cy) + call pargi (key) +end diff --git a/sys/gio/gks/README b/sys/gio/gks/README new file mode 100644 index 00000000..fc3307c7 --- /dev/null +++ b/sys/gio/gks/README @@ -0,0 +1,50 @@ +GKS - This directory contains code for a partial implementation of the Fortran +binding of GKS level OA. The GKS functions are layered upon GIO. The functions +provided are: + + gacwk --- activate workstation + gca --- output (integer) cell array + gcas --- output (short) cell array + gclks --- close GKS + gclrwk --- clear workstation + gclwk --- close workstation + gdawk --- deactivate workstation + gfa --- fill area + gopks --- open GKS + gopwk --- open workstation + gpl --- polyline + gpm --- polymarker + gqasf --- query aspect source flag + gqchh --- query character height + gqchup --- query character up vector + gqcntn --- query current transformation number + gqnt --- query normalization transformation (window and viewport) + gqopwk --- query open workstations + gqplci --- query polyline color index + gqpmi --- query polymarker index + gqtxal --- query text alignment + gqtxci --- query text color index + gqtxp --- query text path + gqwks --- query workstation state + qsasf --- query aspect source flag + gschh --- set character height + gschup --- set character up vector + gscr --- set color representation + gselnt --- set normalization transformation + gsfaci --- set fill area color index + gsfais --- set fill area interior style + gslwsc --- set line width scale factor + gsmk --- set marker type + gsplci --- set polyline color index + gspmci --- set polymarker color index + gspmi --- set polymarker index + gstxal --- set text alignment + gstxci --- set text color index + gstxp --- set text path + gsvp --- set viewport + gswn --- set window + gtx --- text (gtx.f, gxgtx.x) + +Two functions were added 8Sep86: + gsclip --- set clipping flag + gqclip --- query clipping flag diff --git a/sys/gio/gks/gacwk.x b/sys/gio/gks/gacwk.x new file mode 100644 index 00000000..c9393d07 --- /dev/null +++ b/sys/gio/gks/gacwk.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gks.h" + +# GACWK -- Activate workstation. + +procedure gacwk (wkid) + +int wkid # Workstation identifier +include "gks.com" + +begin + # This procedure sets the active flag for a particular workstation. + gk_status[wkid] = ACTIVE + + # Also, set gk_std to be the first activated workstation. Once + # gk_std has been set, it will no longer = NULL. + if (gk_std == NULL) + gk_std = wkid +end diff --git a/sys/gio/gks/gca.x b/sys/gio/gks/gca.x new file mode 100644 index 00000000..918c3e37 --- /dev/null +++ b/sys/gio/gks/gca.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GCA -- Cell array. Output a cell array to the specified output device +# area. + +procedure gca (px, py, qx, qy, dimx, dimy, ncs, nrs, dx, dy, colia) + +real px, py, qx, qy # Two points (P, Q) in world coordinates +int dx, dy # Number of columns, number of rows +int dimx, dimy # Dimensions of color index array +int ncs, nrs # Starting column, row of color array +int colia[dimx,dimy] # Colour index array + +int i, j, off +pointer sp, pixels +include "gks.com" + +begin + # Extract subraster and convert to type short. + call smark (sp) + call salloc (pixels, dx * dy, TY_SHORT) + do j = 1, dy { + off = (j - 1) * dx + call achtis (colia[ncs,nrs+j-1], Mems[pixels+off], dx) + } + + # Output color array to all active workstations. + do i = 1, NDEV + if (gk_status[i] == ACTIVE) + call gpcell (gp[i], Mems[pixels], dx, dy, px, py, qx, qy) + + call sfree (sp) +end diff --git a/sys/gio/gks/gcas.x b/sys/gio/gks/gcas.x new file mode 100644 index 00000000..3ab44f99 --- /dev/null +++ b/sys/gio/gks/gcas.x @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GCAS -- Cell array. Output a cell array to the specified output device +# area. This version of GCA intended for input color array of type short. + +procedure gcas (px, py, qx, qy, dimx, dimy, ncs, nrs, dx, dy, colia) + +real px, py, qx, qy # Two points (P, Q) in world coordinates +int dx, dy # Number of columns, number of rows +int dimx, dimy # Dimensions of color index array +int ncs, nrs # Starting column, row of color array +short colia[dimx, dimy] # Colour index array + +int i, j, off +pointer sp, pixels +include "gks.com" + +begin + if (ncs == 1 && nrs == 1) { + # Output color array to all active workstations. + do i = 1, NDEV + if (gk_status[i] == ACTIVE) + call gpcell (gp[i], Mems[pixels], dx, dy, px, py, qx, qy) + + } else { + # Cell array is subraster of a larger array + call smark (sp) + call salloc (pixels, dx * dy, TY_SHORT) + + # Extract subraster + do j = 1, dy { + off = (j - 1) * dx + call amovs (colia[ncs,nrs+j-1], Mems[off], dx) + } + + # Output color array to all active workstations. + do i = 1, NDEV + if (gk_status[i] == ACTIVE) + call gpcell (gp[i], Mems[pixels], dx, dy, px, py, qx, qy) + + call sfree (sp) + } +end diff --git a/sys/gio/gks/gclks.x b/sys/gio/gks/gclks.x new file mode 100644 index 00000000..a82b760d --- /dev/null +++ b/sys/gio/gks/gclks.x @@ -0,0 +1,9 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GCLKS -- Close GKS. + +procedure gclks () + +begin + # This procedure performs no function in the GKS emulator. +end diff --git a/sys/gio/gks/gclrwk.x b/sys/gio/gks/gclrwk.x new file mode 100644 index 00000000..7f92bc91 --- /dev/null +++ b/sys/gio/gks/gclrwk.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gks.h" + +# GCLRWK -- Clear workstation. + +procedure gclrwk (wkid, cofl) + +int wkid # Workstation identifier +int cofl # Control flags (GCONDI, GALWAY) +include "gks.com" + +begin + # Clear the screen or advance film on the specified workstation. GKS + # allows this to be done conditionally, dependent on whether or not + # something has been drawn. + + call gclear (gp[wkid]) +end diff --git a/sys/gio/gks/gclwk.x b/sys/gio/gks/gclwk.x new file mode 100644 index 00000000..6fc3c16a --- /dev/null +++ b/sys/gio/gks/gclwk.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gks.h" + +# GCLWK -- Close workstation. + +procedure gclwk (wkid) + +int wkid # Workstation identifier +include "gks.com" + +begin + call gclose (gp[wkid]) +end diff --git a/sys/gio/gks/gdawk.x b/sys/gio/gks/gdawk.x new file mode 100644 index 00000000..23eaff14 --- /dev/null +++ b/sys/gio/gks/gdawk.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gks.h" + +# GDAWK -- Deactivate workstation. + +procedure gdawk (wkid) + +int wkid # Workstation identifier +int i +include "gks.com" + +begin + # This procedure sets the status flag to INACTIVE for a particular + # device. Because this workstation may have been the reference + # workstation, gk_std, it may also necessary to update gk_std. + # In this case, the reference workstation will be the one with the + # lowest workstation id number. + + gk_status[wkid] = INACTIVE + + if (wkid == gk_std) { + gk_std = NULL + # Find next activated workstation, if any + do i = 1, NDEV { + if (gk_status[i] == ACTIVE) { + gk_std = i + break + } + } + } +end diff --git a/sys/gio/gks/gfa.x b/sys/gio/gks/gfa.x new file mode 100644 index 00000000..9eb612b2 --- /dev/null +++ b/sys/gio/gks/gfa.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GFA -- Fill area. The style of fill has already been set and is read +# from gio.com. + +procedure gfa (n, px, py) + +int n # Number of points +real px[n], py[n] # Coordinates of points in world coordinates + +int i +include "gks.com" + +begin + do i = 1, NDEV { + if (gk_status[i] == ACTIVE) + call gfill (gp[i], px, py, n, gk_style) + } +end diff --git a/sys/gio/gks/gks.com b/sys/gio/gks/gks.com new file mode 100644 index 00000000..63c20568 --- /dev/null +++ b/sys/gio/gks/gks.com @@ -0,0 +1,10 @@ +# Common for GKS emulator. + +pointer gp[NDEV] # Graphics file descriptor for gio calls +int gk_status[NDEV] # Active bit = INACTIVE or ACTIVE +int gk_std # Index of gp array used for reference in set/get calls +int gk_style # Fill area type of fill - set by GSFAIS +int gk_marker # Marker type for use by GPM +int gk_asf[NASF] # Array for maintaining aspect source flags + +common /gksemu/ gp, gk_status, gk_std, gk_style, gk_marker, gk_asf diff --git a/sys/gio/gks/gks.h b/sys/gio/gks/gks.h new file mode 100644 index 00000000..2373c55f --- /dev/null +++ b/sys/gio/gks/gks.h @@ -0,0 +1,40 @@ +# Definitions for the gks emulator. + +define NDEV 10 # Maximum number of open devices possible +define INACTIVE 0 +define ACTIVE 1 +define MAX_WCS 16 # Maximum number of world coordinate systems +define NASF 13 # Number of aspect source flags + +# Following are emuneration types used by the GKS emulator. +define GRIGHT 0 +define GLEFT 1 +define GUP 2 +define GDOWN 3 +define GAHNOR 0 +define GALEFT 1 +define GACENT 2 +define GARITE 3 +define GAVNOR 0 +define GATOP 1 +define GACAP 2 +define GAHALF 3 +define GABASE 4 +define GABOTT 5 +define GPOINT 1 +define GPLUS 2 +define GAST 3 +define GOMARK 4 +define GXMARK 5 +define GHOLLO 0 +define GSOLID 1 +define GPATTR 2 +define GHATCH 3 +define GBUNDL 0 +define GINDIV 1 +define GRIGHT 0 +define GLEFT 1 +define GUP 2 +define GDOWN 3 +define GCONDI 0 +define GALWAY 1 diff --git a/sys/gio/gks/gopks.x b/sys/gio/gks/gopks.x new file mode 100644 index 00000000..48f39de0 --- /dev/null +++ b/sys/gio/gks/gopks.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gks.h" + +# GOPKS -- Open GKS. In the GIO implementation, this routine sets the +# file to receive error output to STDERR and initializes all possible +# workstations to inactive. It also initializes the ASF array to GINDIV. + +procedure gopks (errfil) + +int errfil # Unit number for error output +int i +include "gks.com" + +begin + # This procedure initializes the gk_status and gk_std variables. + do i = 1, NDEV + gk_status[i] = INACTIVE + + gk_std = NULL + + do i = 1, NASF + gk_asf[i] = GINDIV +end diff --git a/sys/gio/gks/gopwk.x b/sys/gio/gks/gopwk.x new file mode 100644 index 00000000..baa040e3 --- /dev/null +++ b/sys/gio/gks/gopwk.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gks.h" + +# GOPWK -- Open workstation. + +procedure gopwk (wkid, conid, wtype) + +int wkid # Workstation identifier +int conid # Connection identifier, not used. +int wtype # Workstation type + +include "gks.com" + + +begin + # This procedure sets "gp[wkid]" to be the "gp" of workstation "wkid". + # Procedure gopen has been called by the calling routine. The wkid + # runs sequentially from 1 to the maximum allowable number of open + # workstations. Parameter wtype is the gp returned from gopen. + + gp[wkid] = wtype +end diff --git a/sys/gio/gks/gpl.x b/sys/gio/gks/gpl.x new file mode 100644 index 00000000..ea5b880f --- /dev/null +++ b/sys/gio/gks/gpl.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gks.h" + +# GPL -- Polyline. Draw a line connecting the points. + +procedure gpl (n, px, py) + +int n # Number of points +real px[n], py[n] # Coordinates of points in world coordinates + +int i +include "gks.com" + +begin + do i = 1, NDEV { + if (gk_status[i] == ACTIVE) + call gpline (gp[i], px, py, n) + } +end diff --git a/sys/gio/gks/gpm.x b/sys/gio/gks/gpm.x new file mode 100644 index 00000000..1a7d8ac7 --- /dev/null +++ b/sys/gio/gks/gpm.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GPM -- Polymarker. Draw marks of type "gk_marker" and size 2.0 +# at the given positions. Marker type has already been set. + +procedure gpm (n, px, py) + +int n # Number of points +real px[n], py[n] # Coordinates of points in world coordinates + +int i +real size +include "gks.com" + +begin + # Marker size is a constant. + size = 2.0 + do i = 1, NDEV { + if (gk_status[i] == ACTIVE) + call gpmark (gp[i], px, py, n, gk_marker, size, size) + } +end diff --git a/sys/gio/gks/gqasf.x b/sys/gio/gks/gqasf.x new file mode 100644 index 00000000..828ddef0 --- /dev/null +++ b/sys/gio/gks/gqasf.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gks.h" + +# GQASF -- Inquire aspect source flags. + +procedure gqasf (ierror, lasf) + +int lasf[13] # Array of source aspect flags +int ierror # Error indicator, where ierror = 0 for no error +int i +include "gks.com" + +begin + ierror = 0 + do i = 1, NASF + lasf[i] = gk_asf[i] +end diff --git a/sys/gio/gks/gqchh.x b/sys/gio/gks/gqchh.x new file mode 100644 index 00000000..733d0a2a --- /dev/null +++ b/sys/gio/gks/gqchh.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GQCHH - Inquire character height. + +procedure gqchh (ierror, chh) + +int ierror # Error indicator +real chh # Character height, in world coordinates + +real dx, dy +real gstatr() +include "gks.com" +errchk gstatr, ggscale + +begin + if (gk_std == NULL) { + # GKS not in proper state; no active workstations + ierror = 7 + chh = -1.0 + return + } else + ierror = 0 + + iferr { + chh = gstatr (gp[gk_std], G_CHARSIZE) + + # The character height is expressed in NDC units. It must be + # converted to world coordinates before returning. + + call ggscale (gp[gk_std], 0., 0., dx, dy) + chh = chh * dy + } then { + ierror = 1 + chh = -1.0 + } +end diff --git a/sys/gio/gks/gqchup.x b/sys/gio/gks/gqchup.x new file mode 100644 index 00000000..3f12d8c4 --- /dev/null +++ b/sys/gio/gks/gqchup.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GQCHUP -- Inquire character up vector. + +procedure gqchup (ierror, chupx, chupy) + +int ierror # Error code; ierror = 0 for no error +real chupx, chupy # Character up vector x and y components + +int angle +real txup +int gstati() +include "gks.com" + +begin + if (gk_std == NULL) { + # GKS not in proper state; no active workstations + ierror = 7 + chupx = 0.0 + chupy = 0.0 + return + } else + ierror = 0 + + iferr { + angle = gstati (gp[gk_std], G_TXUP) + + txup = real (angle) * 3.1415926 / 180. + chupx = cos (txup) + chupy = sin (txup) + } then { + ierror = 1 + chupx = 0.0 + chupy = 0.0 + } +end diff --git a/sys/gio/gks/gqclip.x b/sys/gio/gks/gqclip.x new file mode 100644 index 00000000..5694b353 --- /dev/null +++ b/sys/gio/gks/gqclip.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GQCLIP -- Inquire value of clipping flag + +procedure gqclip (errind, iclip, iar) + +int errind # Error indicator +int iclip # Clipping flag - returned value +real iar[4] # Clipping array + +int gstati() +include "gks.com" + +begin + # Until I know what this argument is, set iar to full viewport. + # Consulting with NCAR was not enlightning. This argument (iar) + # is not documented in the GKS level 0A standard. + iar[1] = 0.0 + iar[2] = 1.0 + iar[3] = 0.0 + iar[4] = 1.0 + + if (gk_std == NULL) { + # GKS not in proper state; no active workstations + errind = 7 + iclip = -1 + return + } else + errind = 0 + + iferr { + iclip = gstati (gp[gk_std], G_CLIP) + } then { + errind = 1 + iclip = -1 + } +end diff --git a/sys/gio/gks/gqcntn.x b/sys/gio/gks/gqcntn.x new file mode 100644 index 00000000..aaaa79bf --- /dev/null +++ b/sys/gio/gks/gqcntn.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GQCNTN -- Inquire current normalization transformation number (WCS). + +procedure gqcntn (errind, cntr) + +int errind # Error indicator; errind = 0 means no error +int cntr # Current normalization transformation number +int gstati() +include "gks.com" + +begin + if (gk_std == NULL) { + # GKS not in proper state; no active workstations + errind = 7 + cntr = -1 + return + } else + errind = 0 + + iferr { + cntr = gstati (gp[gk_std], G_WCS) + } then { + errind = 1 + cntr = -1 + } +end diff --git a/sys/gio/gks/gqmk.x b/sys/gio/gks/gqmk.x new file mode 100644 index 00000000..0e90fbe7 --- /dev/null +++ b/sys/gio/gks/gqmk.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GQMK -- Query marker type. Integer variable "marker" is read from +# "gks.com" and returned. + +procedure gqmk (ierr, mtype) + +int ierr # Error indicator - no way it can be set +int mtype # Marker type for polymarker +include "gks.com" + +begin + ierr = 0 + switch (gk_marker) { + case GM_POINT: + mtype = GPOINT + case GM_PLUS: + mtype = GPLUS + case GM_BOX: + mtype = GAST + case GM_DIAMOND: + mtype = GOMARK + case GM_CROSS: + mtype = GXMARK + default: + mtype = GPOINT + } +end diff --git a/sys/gio/gks/gqnt.x b/sys/gio/gks/gqnt.x new file mode 100644 index 00000000..c172647f --- /dev/null +++ b/sys/gio/gks/gqnt.x @@ -0,0 +1,70 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GQNT -- Inquire normalization transformation (window and vport). Note +# that this procedure gets the information for WCS ntnr, then resets to +# the current WCS before returning. + +procedure gqnt (ntnr, errind, window, vport) + +int ntnr # Normalization transformation number to query +int errind # Error indicator; errind = 0 means no error +real window[4] # Window coordinates for WCS ntnr +real vport[4] # Viewport coordinates for WCS ntnr + +int current_wcs +int gstati() +include "gks.com" +errchk gstati, gseti, ggwind, ggview + +begin + if (gk_std == NULL) { + # GKS not in proper state; no active workstations + errind = 7 + window[1] = 0.0 + window[2] = 0.0 + window[3] = 0.0 + window[4] = 0.0 + vport[1] = -1.0 + vport[2] = -1.0 + vport[3] = -1.0 + vport[4] = -1.0 + return + } else + errind = 0 + + if (ntnr < 0 || ntnr > MAX_WCS) { + errind = 50 + window[1] = 0.0 + window[2] = 0.0 + window[3] = 0.0 + window[4] = 0.0 + vport[1] = -1.0 + vport[2] = -1.0 + vport[3] = -1.0 + vport[4] = -1.0 + return + } + + iferr { + current_wcs = gstati (gp[gk_std], G_WCS) + + call gseti (gp[gk_std], G_WCS, ntnr) + call ggwind (gp[gk_std], window[1], window[2], window[3], window[4]) + call ggview (gp[gk_std], vport[1], vport[2], vport[3], vport[4]) + + call gseti (gp[gk_std], G_WCS, current_wcs) + } then { + errind = 1 + window[1] = 0.0 + window[2] = 0.0 + window[3] = 0.0 + window[4] = 0.0 + vport[1] = -1.0 + vport[2] = -1.0 + vport[3] = -1.0 + vport[4] = -1.0 + } +end diff --git a/sys/gio/gks/gqopwk.x b/sys/gio/gks/gqopwk.x new file mode 100644 index 00000000..cf297f45 --- /dev/null +++ b/sys/gio/gks/gqopwk.x @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gks.h" + +# GQOPWK -- Inquire number of open work stations. From looking at how this +# procedure is called, it seems to have two functions, depending on the value +# of "n". It returns either the number of active workstations (n=0), or the +# wkid for nth open workstation. + +procedure gqopwk (n, errind, ol, wkid) + +int n # Number of workstation to query +int errind # Error indicator; errind = 0 means no error +int ol # Returned value (number of open workstations) +int wkid # WKID of nth open workstation - returned + +int i, this_wkstation +include "gks.com" + +begin + if (gk_std == NULL) { + # GKS not in proper state; no active workstations + errind = 7 + wkid = -1 + return + } else + errind = 0 + + if (n < 0 || n > NDEV) { + # Invalid workstation identifier + wkid = -1 + errind = 502 + return + } else { + ol = 0 + if (n == 0) { + # return the number of active workstations + do i = 1, NDEV { + if (gk_status[i] == ACTIVE) + ol = ol + 1 + } + } else { + # Find the nth open workstation and return its wkid + this_wkstation = 0 + do i = 1, NDEV { + if (gk_status[i] == ACTIVE) { + this_wkstation = this_wkstation + 1 + if (this_wkstation == n) { + wkid = i + break + } + } + } + } + } +end diff --git a/sys/gio/gks/gqplci.x b/sys/gio/gks/gqplci.x new file mode 100644 index 00000000..23858491 --- /dev/null +++ b/sys/gio/gks/gqplci.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GQPLCI -- Inquire Polyline color index. + +procedure gqplci (errind, coli) + +int coli # Color index - returned value +int errind # Error indicator +real gstatr() +include "gks.com" + +begin + if (gk_std == NULL) { + # GKS not in proper state; no active workstations + errind = 7 + coli = -1 + return + } else + errind = 0 + + iferr { + coli = int (gstatr (gp[gk_std], G_PLWIDTH)) + } then { + errind = 1 + coli = -1 + } +end diff --git a/sys/gio/gks/gqpmci.x b/sys/gio/gks/gqpmci.x new file mode 100644 index 00000000..d1760d15 --- /dev/null +++ b/sys/gio/gks/gqpmci.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GQPMCI -- Inquire Polymarker color index. + +procedure gqpmci (errind, coli) + +int coli # Color index - returned value +int errind # Error indicator +real gstatr() +include "gks.com" + +begin + if (gk_std == NULL) { + # GKS not in proper state; no active workstations + errind = 7 + coli = -1 + return + } else + errind = 0 + + iferr { + coli = int (gstatr (gp[gk_std], G_PMWIDTH)) + } then { + errind = 1 + coli = -1 + } +end diff --git a/sys/gio/gks/gqpmi.x b/sys/gio/gks/gqpmi.x new file mode 100644 index 00000000..b1332b54 --- /dev/null +++ b/sys/gio/gks/gqpmi.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GQPMI -- Inquire Polymarker index. + +procedure gqpmi (errind, index) + +real index # Polymarker index - returned value. +int errind # Error indicator +include "gks.com" + +begin + errind = 0 + index = 1.0 +end diff --git a/sys/gio/gks/gqtxal.x b/sys/gio/gks/gqtxal.x new file mode 100644 index 00000000..36a90186 --- /dev/null +++ b/sys/gio/gks/gqtxal.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GQTXAL -- Inquire text alignment. + +procedure gqtxal (ierror, txalh, txalv) + +int ierror # Error indicator; ierror = 0 means no error +int txalh # Horizontal text alignment +int txalv # Vertical text alignment + +int justify +int gstati() +include "gks.com" + +begin + if (gk_std == NULL) { + # GKS not in proper state; no active workstations + ierror = 7 + txalh = -1 + txalv = -1 + return + } else + ierror = 0 + + iferr { + # Get value of horizontal text justification + justify = gstati (gp[gk_std], G_TXHJUSTIFY) + + switch (justify) { + case GT_NORMAL: + txalh = GAHNOR + case GT_CENTER: + txalh = GACENT + case GT_LEFT: + txalh = GALEFT + case GT_RIGHT: + txalh = GARITE + default: + txalh = GAHNOR + } + + # Get value of vertical text justification + justify = gstati (gp[gk_std], G_TXVJUSTIFY) + + switch (justify) { + case GT_NORMAL: + txalv = GAVNOR + case GT_CENTER: + txalv = GAHALF + case GT_TOP: + txalv = GATOP + case GT_BOTTOM: + txalv = GABOTT + default: + txalv = GAVNOR + } + } then { + ierror = 1 + txalv = -1 + txalh = -1 + } +end diff --git a/sys/gio/gks/gqtxci.x b/sys/gio/gks/gqtxci.x new file mode 100644 index 00000000..e327660b --- /dev/null +++ b/sys/gio/gks/gqtxci.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GQTXCI -- Inquire text color index. + +procedure gqtxci (ierror, coli) + +int ierror # Error indicator +int coli # Color index - returned value. +int gstati () +include "gks.com" + +begin + if (gk_std == NULL) { + # GKS not in proper state; no active workstations + ierror = 7 + coli = -1 + return + } else + ierror = 0 + + iferr { + coli = gstati (gp[gk_std], G_TXCOLOR) + } then { + ierror = 1 + coli = -1 + } +end diff --git a/sys/gio/gks/gqtxp.x b/sys/gio/gks/gqtxp.x new file mode 100644 index 00000000..53dfd1af --- /dev/null +++ b/sys/gio/gks/gqtxp.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GQTXP -- Inquire text path. + +procedure gqtxp (ierror, path) + +int ierror # Error indicator +int path # Text path - returned value. + +int text_path +int gstati() +include "gks.com" + +begin + if (gk_std == NULL) { + # GKS not in proper state; no active workstations + ierror = 7 + path = -1 + return + } else + ierror = 0 + + iferr { + text_path = gstati (gp[gk_std], G_TXPATH) + + switch (text_path) { + case (GT_LEFT): + path = GLEFT + case (GT_RIGHT): + path = GRIGHT + case (GT_UP): + path = GUP + case (GT_DOWN): + path = GDOWN + default: + path = GRIGHT + } + } then { + ierror = 1 + path = -1 + } +end diff --git a/sys/gio/gks/gqwks.x b/sys/gio/gks/gqwks.x new file mode 100644 index 00000000..b555fee0 --- /dev/null +++ b/sys/gio/gks/gqwks.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gks.h" + +# GQWKS -- Inquire workstation state. State is either ACTIVE or INACTIVE; +# this information has been stored in gks.com by GACWK. + +procedure gqwks (wkid, errind, state) + +int wkid # Workstation id for inquire +int errind # Error indicator +int state # Returned state value: ACTIVE or INACTIVE +include "gks.com" + +begin + errind = 0 + if (wkid > NDEV) + errind = 1 + else + state = gk_status[wkid] +end diff --git a/sys/gio/gks/gsasf.x b/sys/gio/gks/gsasf.x new file mode 100644 index 00000000..be321060 --- /dev/null +++ b/sys/gio/gks/gsasf.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gks.h" + +# GSASF -- Set aspect source flags. Aspect source flags allow the following +# elements to be set to either GBUNDL or GINDIV: +# 1 linetype ASF +# 2 linewidth scale factor ASF +# 3 polyline colour index ASF +# 4 marker type ASF +# 5 marker size scale factor ASF +# 6 polymarker colout index ASF +# 7 text font and precision factor ASF +# 8 character expansion factor ASF +# 9 character spacing ASF +# 10 text colour index ASF +# 11 fill area interior style ASF +# 12 fill area style index ASF +# 13 fill area colout index ASF + +procedure gsasf (lasf) + +int lasf[13] # List of aspect source flags +int i +include "gks.com" + +begin + do i = 1, NASF + gk_asf[i] = lasf[i] +end diff --git a/sys/gio/gks/gsaw.x b/sys/gio/gks/gsaw.x new file mode 100644 index 00000000..dbbc0190 --- /dev/null +++ b/sys/gio/gks/gsaw.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GSAW[IR] -- Sets integer or real parameters for all active workstations. + +procedure gsawi (param, value) + +int param # Parameter to be set +int value # New value for parameter + +int i +include "gks.com" + +begin + do i = 1, NDEV { + if (gk_status[i] == ACTIVE) + call gseti (gp[i], param, value) + } +end + + +procedure gsawr (param, value) + +int param # Parameter to be set +real value # New value for parameter + +int i +include "gks.com" + +begin + do i = 1, NDEV { + if (gk_status[i] == ACTIVE) + call gsetr (gp[i], param, value) + } +end diff --git a/sys/gio/gks/gschh.x b/sys/gio/gks/gschh.x new file mode 100644 index 00000000..172af231 --- /dev/null +++ b/sys/gio/gks/gschh.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GSCHH -- Set character height. + +procedure gschh (chh) + +real chh # Character height in world coordinates + +real dx, dy, ndc_chh +include "gks.com" + +begin + # Input chh is in world coordinates; it must be transformed to NDC. + # Assuming spatial transformation is linear, input coordinates to + # ggscale are not used and so are set to 0.0. + + call ggscale (gp[gk_std], 0.0, 0.0, dx, dy) + if (dy != 0) { + ndc_chh = chh / dy + call gsawr (G_CHARSIZE, ndc_chh) + } else + call gsawr (G_CHARSIZE, chh) +end diff --git a/sys/gio/gks/gschup.x b/sys/gio/gks/gschup.x new file mode 100644 index 00000000..d7698c41 --- /dev/null +++ b/sys/gio/gks/gschup.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GSCHUP -- Set character up vector. + +procedure gschup (chux, chuy) + +real chux, chuy # Character up vector, in world coordinates +int char_up +bool fp_equalr() + +begin + # Find the angle normal to the text baseline. The angle is stored + # in degrees between -180 and +180. + + if (fp_equalr (chux, 0.0)) + char_up = 90 + else + char_up = nint (atan2 (chuy, chux) * 180. / 3.1415926) + + call gsawi (G_TXUP, char_up) +end diff --git a/sys/gio/gks/gsclip.x b/sys/gio/gks/gsclip.x new file mode 100644 index 00000000..80fe32c0 --- /dev/null +++ b/sys/gio/gks/gsclip.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GSCLIP -- Set clipping flag. + +procedure gsclip (iclip) + +int iclip # New value of clipping flag + +begin + call gsawi (G_CLIP, iclip) +end diff --git a/sys/gio/gks/gscr.x b/sys/gio/gks/gscr.x new file mode 100644 index 00000000..39a248e1 --- /dev/null +++ b/sys/gio/gks/gscr.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GSCR -- Set color representation. Currently implemented as a no-op. + +procedure gscr (wkstation, color_index, rgb) + +int wkstation # Workstation id +int color_index +real rgb[3] +include "gks.com" + +begin + ; +end diff --git a/sys/gio/gks/gselnt.x b/sys/gio/gks/gselnt.x new file mode 100644 index 00000000..dfe39a3b --- /dev/null +++ b/sys/gio/gks/gselnt.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GSELNT -- Select normalization transformation (same as world coord sys) + +procedure gselnt (wcs) + +int wcs # Transformation number + +begin + call gsawi (G_WCS, wcs) +end diff --git a/sys/gio/gks/gsfaci.x b/sys/gio/gks/gsfaci.x new file mode 100644 index 00000000..620b0bca --- /dev/null +++ b/sys/gio/gks/gsfaci.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GSFACI -- Set fill area color index. Currently implemented as a no-op. + +procedure gsfaci (index) + +int index # Fill area color index. + +include "gks.com" + +begin + ; +end diff --git a/sys/gio/gks/gsfais.x b/sys/gio/gks/gsfais.x new file mode 100644 index 00000000..461cab8d --- /dev/null +++ b/sys/gio/gks/gsfais.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GSFAIS -- Set fill area interior style. Integer variable "gk_style" is +# set and stored in "gks.com". Procedure GFA will use this value. + +procedure gsfais (ints) + +int ints # Fill area interior style + +include "gks.com" + +begin + switch (ints) { + case GHOLLO: + gk_style = GF_HOLLOW + case GSOLID: + gk_style = GF_SOLID + case GPATTR: + gk_style = GF_HATCH4 + case GHATCH: + gk_style = GF_HATCH1 + default: + gk_style = GF_HOLLOW + } +end diff --git a/sys/gio/gks/gslwsc.x b/sys/gio/gks/gslwsc.x new file mode 100644 index 00000000..b6f75963 --- /dev/null +++ b/sys/gio/gks/gslwsc.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GSLWSC -- Set linewidth scale. Currently implemented as a no-op. + +procedure gslwsc (width) + +real width # Linewidth scale width. + +include "gks.com" + +begin + ; +end diff --git a/sys/gio/gks/gsmk.x b/sys/gio/gks/gsmk.x new file mode 100644 index 00000000..41a7b05d --- /dev/null +++ b/sys/gio/gks/gsmk.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GSMK -- Set marker type. Integer variable "marker" is set and +# stored in "gks.com". Procedure gpm uses this value. + +procedure gsmk (mtype) + +int mtype # Marker type for polymarker +include "gks.com" + +begin + switch (mtype) { + case GPOINT: + gk_marker = GM_POINT + case GPLUS: + gk_marker = GM_PLUS + case GAST: + gk_marker = GM_BOX + case GOMARK: + gk_marker = GM_DIAMOND + case GXMARK: + gk_marker = GM_CROSS + default: + gk_marker = GM_POINT + } +end diff --git a/sys/gio/gks/gsmksc.x b/sys/gio/gks/gsmksc.x new file mode 100644 index 00000000..4936d7ea --- /dev/null +++ b/sys/gio/gks/gsmksc.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GSMKSC -- Set marker scale. Currently implemented as a no-op. + +procedure gsmksc (width) + +real width # Marker scale width. + +include "gks.com" + +begin + ; +end diff --git a/sys/gio/gks/gsplci.x b/sys/gio/gks/gsplci.x new file mode 100644 index 00000000..afb74b4d --- /dev/null +++ b/sys/gio/gks/gsplci.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GSPLC -- Set polyline colour index. This function is currently +# implemented as setting the polyline width, not color. + +procedure gsplci (coli) + +int coli # Polyline colour index + +begin + call gsawr (G_PLWIDTH, real (coli)) +end diff --git a/sys/gio/gks/gspmci.x b/sys/gio/gks/gspmci.x new file mode 100644 index 00000000..909800cf --- /dev/null +++ b/sys/gio/gks/gspmci.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GSPMCI -- Set polymarker colour index. This function is currently +# implemented as setting the polymarker width, not color. + +procedure gspmci (coli) + +int coli # Polymarker colour index. + +begin + call gsawr (G_PMCOLOR, real (coli)) +end diff --git a/sys/gio/gks/gspmi.x b/sys/gio/gks/gspmi.x new file mode 100644 index 00000000..e238fc10 --- /dev/null +++ b/sys/gio/gks/gspmi.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GSPMI -- Set polymarker index. This function is currently +# implemented as a no-op. + +procedure gspmi (index) + +int index # Polymarker index. (whatever that is) + +begin + ; +end diff --git a/sys/gio/gks/gstxal.x b/sys/gio/gks/gstxal.x new file mode 100644 index 00000000..aecae88f --- /dev/null +++ b/sys/gio/gks/gstxal.x @@ -0,0 +1,43 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GSTXAL -- Set format alignment. + +procedure gstxal (txalh, txalv) + +int txalh # Horizontal alignment +int txalv # Vertical alignment + +begin + switch (txalh) { + case GAHNOR: + call gsawi (G_TXHJUSTIFY, GT_NORMAL) + case GALEFT: + call gsawi (G_TXHJUSTIFY, GT_LEFT) + case GACENT: + call gsawi (G_TXHJUSTIFY, GT_CENTER) + case GARITE: + call gsawi (G_TXHJUSTIFY, GT_RIGHT) + default: + call gsawi (G_TXHJUSTIFY, GT_NORMAL) + } + + switch (txalv) { + case GAVNOR: + call gsawi (G_TXVJUSTIFY, GT_NORMAL) + case GATOP: + call gsawi (G_TXVJUSTIFY, GT_TOP) + case GACAP: + call gsawi (G_TXVJUSTIFY, GT_TOP) + case GAHALF: + call gsawi (G_TXVJUSTIFY, GT_CENTER) + case GABASE: + call gsawi (G_TXVJUSTIFY, GT_BOTTOM) + case GABOTT: + call gsawi (G_TXVJUSTIFY, GT_BOTTOM) + default: + call gsawi (G_TXVJUSTIFY, GT_NORMAL) + } +end diff --git a/sys/gio/gks/gstxci.x b/sys/gio/gks/gstxci.x new file mode 100644 index 00000000..ec04132c --- /dev/null +++ b/sys/gio/gks/gstxci.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GSTXCI -- Set colour index. This function is currently implemented +# by setting the text font to bold when the color index > 1, and to +# the default (roman) otherwise. + +procedure gstxci (coli) + +int coli # Text colour index + +begin + if (coli > 1) + call gsawi (G_TXFONT, GT_BOLD) + else + call gsawi (G_TXFONT, GT_ROMAN) +end diff --git a/sys/gio/gks/gstxp.x b/sys/gio/gks/gstxp.x new file mode 100644 index 00000000..cf87e4f2 --- /dev/null +++ b/sys/gio/gks/gstxp.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GSTXP -- Set text path. + +procedure gstxp (txp) + +int txp # Text path to be set + +begin + switch (txp) { + case GRIGHT: + call gsawi (G_TXPATH, GT_RIGHT) + case GLEFT: + call gsawi (G_TXPATH, GT_LEFT) + case GUP: + call gsawi (G_TXPATH, GT_UP) + case GDOWN: + call gsawi (G_TXPATH, GT_DOWN) + default: + call gsawi (G_TXPATH, GT_RIGHT) + } +end diff --git a/sys/gio/gks/gsvp.x b/sys/gio/gks/gsvp.x new file mode 100644 index 00000000..f2a61711 --- /dev/null +++ b/sys/gio/gks/gsvp.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GSVP -- Set viewport. This procedure sets the viewport for world coord +# sys "wcs", which may not be the current WCS. + +procedure gsvp (wcs, x1, x2, y1, y2) + +int wcs # Number of world coordinate system +real x1, x2 # Range of viewport coordinate in x (NDC) +real y1, y2 # Range of viewport coordinate in y (NDC) + +int current_wcs, i +int gstati() +include "gks.com" + +begin + current_wcs = gstati (gp[gk_std], G_WCS) + call gsawi (G_WCS, wcs) + + do i = 1, NDEV { + if (gk_status[i] == ACTIVE) + call gsview (gp[i], x1, x2, y1, y2) + } + + # Now return to the current WCS + call gsawi (G_WCS, current_wcs) +end diff --git a/sys/gio/gks/gswn.x b/sys/gio/gks/gswn.x new file mode 100644 index 00000000..713ae487 --- /dev/null +++ b/sys/gio/gks/gswn.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GSWN -- Set window. Window of world coord system "wcs" is set, which +# is not necessarily the current WCS. + +procedure gswn (wcs, x1, x2, y1, y2) + +int wcs # Number of world coordinate system (transformation) +real x1, x2 # Range of world coordinates in x +real y1, y2 # Range of world coordinates in y + +int current_wcs, i +int gstati() +include "gks.com" + +begin + current_wcs = gstati (gp[gk_std], G_WCS) + call gsawi (G_WCS, wcs) + do i = 1, NDEV { + if (gk_status[i] == ACTIVE) + call gswind (gp[i], x1, x2, y1, y2) + } + + # Now return to current WCS before returning + call gsawi (G_WCS, current_wcs) +end diff --git a/sys/gio/gks/gtx.f b/sys/gio/gks/gtx.f new file mode 100644 index 00000000..c09ef7c4 --- /dev/null +++ b/sys/gio/gks/gtx.f @@ -0,0 +1,16 @@ +c GTX -- Text. Unpack an f77 string and call gx_gtx to output the string. +c + subroutine gtx (px, py, f77chars) +c + real px, py + character*(*) f77chars + integer*2 sppchars(161) +c +c +c Unpack characters from packed input array +c + call f77upk (f77chars, sppchars, min (len(f77chars), 161)) + call gxgtx (px, py, sppchars) +c +c + end diff --git a/sys/gio/gks/gxgtx.x b/sys/gio/gks/gxgtx.x new file mode 100644 index 00000000..0ca39bb5 --- /dev/null +++ b/sys/gio/gks/gxgtx.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gks.h" + +# GXGTX -- Text. Ouptut an spp string with gtext. The string has already +# been unpacked from an f77 to spp string. + +procedure gxgtx (px, py, chars) + +real px, py # Text position in world coordinates +char chars[ARB] # String of characters + +int i +include "gks.com" + +begin + do i = 1, NDEV { + if (gk_status[i] == ACTIVE) + call gtext (gp[i], px, py, chars, "") + } +end diff --git a/sys/gio/gks/mkpkg b/sys/gio/gks/mkpkg new file mode 100644 index 00000000..864c3ba7 --- /dev/null +++ b/sys/gio/gks/mkpkg @@ -0,0 +1,58 @@ +# Make the GKS emulator. + +$checkout libgks.a lib$ +$update libgks.a +$checkin libgks.a lib$ +$exit + +libgks.a: + gacwk.x gks.com gks.h + gca.x gks.com gks.h + gcas.x gks.com gks.h + gclks.x + gclrwk.x gks.com gks.h + gclwk.x gks.com gks.h + gdawk.x gks.com gks.h + gfa.x gks.h gks.com + gopks.x gks.com gks.h + gopwk.x gks.com gks.h + gpl.x gks.com gks.h + gpm.x gks.com gks.h + gqasf.x gks.com gks.h + gqchh.x gks.com gks.h + gqchup.x gks.com gks.h + gqclip.x gks.com gks.h + gqcntn.x gks.com gks.h + gqmk.x gks.com gks.h + gqnt.x gks.com gks.h + gqopwk.x gks.com gks.h + gqplci.x gks.com gks.h + gqpmci.x gks.com gks.h + gqpmi.x gks.com gks.h + gqtxal.x gks.com gks.h + gqtxci.x gks.com gks.h + gqtxp.x gks.com gks.h + gqwks.x gks.com gks.h + gsasf.x gks.com gks.h + gsaw.x gks.com gks.h + gschh.x gks.com gks.h + gschup.x + gsclip.x + gscr.x gks.com gks.h + gselnt.x + gsfaci.x gks.com gks.h + gsfais.x gks.com gks.h + gslwsc.x gks.com gks.h + gsmk.x gks.com gks.h + gsmksc.x gks.com gks.h + gsplci.x + gspmci.x + gspmi.x + gstxal.x gks.h + gstxci.x + gstxp.x gks.h + gsvp.x gks.com gks.h + gswn.x gks.com gks.h + gtx.f + gxgtx.x gks.com gks.h + ; diff --git a/sys/gio/glabax/README b/sys/gio/glabax/README new file mode 100644 index 00000000..4c9f9ad5 --- /dev/null +++ b/sys/gio/glabax/README @@ -0,0 +1 @@ +GLABAX -- GIO axis drawing and labelling package. diff --git a/sys/gio/glabax/glabax.h b/sys/gio/glabax/glabax.h new file mode 100644 index 00000000..070918ec --- /dev/null +++ b/sys/gio/glabax/glabax.h @@ -0,0 +1,46 @@ +# GLABAX.H -- Axis drawing and labelling. + +define SZ_FORMAT 19 +define SZ_LABEL 19 +define MAX_LINEARITY 1.0 # no log scaling if gt +define LEFT_BORDER 9 # nchars at l|r edge +define BOTTOM_BORDER 5 # nlines at bottom edge +define Y_LABELOFFSET 7 # Y label dist from axis +define MAX_SZTITLEBLOCK 0.5 # max sztitleblock, NDC +define MIN_NTITLELINES 2 # min lines in titleblk +define TOL (EPSILONR*10.0) + +define LEN_AX 85 +define AX_POS Memd[P2D($1)+$2-1] # tick coords +define AX_DRAWME Memi[$1+4] # draw this axis +define AX_HORIZONTAL Memi[$1+5] # axis is horizontal +define AX_SCALING Memi[$1+6] # type of scaling +define AX_DRAWTICKS Memi[$1+7] # draw the ticks +define AX_START Memr[P2R($1+8+$2-1)] # axis starts here +define AX_END Memr[P2R($1+10+$2-1)] # axis ends here +define AX_TICK1 Memr[P2R($1+12+$2-1)] # first tick is here +define AX_STEP Memr[P2R($1+14+$2-1)] # offset between ticks +define AX_ISTEP Memr[P2R($1+16+$2-1)] # intial offset +define AX_KSTEP Memr[P2R($1+18)] # step scalar at majors +define AX_IKSTEP Memr[P2R($1+19)] # initial kstep +define AX_NMINOR Memi[$1+20] # nminor ticks +define AX_NLEFT Memi[$1+21] # nminor to next major +define AX_INLEFT Memi[$1+22] # initial nleft +define AX_NDIGITS Memi[$1+23] # ndigits of precision +define AX_MINORTICK Memr[P2R($1+24+$2-1)] # offset to draw minor +define AX_MAJORTICK Memr[P2R($1+26+$2-1)] # offset to draw major +define AX_MINORWIDTH Memr[P2R($1+28)] # minor tick linewidth +define AX_MAJORWIDTH Memr[P2R($1+29)] # major tick linewidth +define AX_LABELTICKS Memi[$1+30] # draw tick labels +define AX_TICKLABELOFFSET Memr[P2R($1+31+$2-1)] # offset to ticklabel +define AX_TICKLABELSIZE Memr[P2R($1+33)] # char size of ticklabel +define AX_TICKLABELCOLOR Memi[$1+34] # char size of ticklabel +define AX_TICKCOLOR Memi[$1+35] # grid between ticks +define AX_AXISLABELSIZE Memr[P2R($1+36)] # char size axislabel +define AX_AXISLABELCOLOR Memi[$1+37] # char size axislabel +define AX_AXISWIDTH Memr[P2R($1+38)] # axis linewidth +define AX_AXISCOLOR Memi[$1+39] # axis linewidth +define AX_GRIDCOLOR Memi[$1+40] # grid between ticks + +define AX_TICKLABELPOS Memc[P2C($1+45)] # gtext format +define AX_TICKFORMAT Memc[P2C($1+65)] # numeric format diff --git a/sys/gio/glabax/glabax.x b/sys/gio/glabax/glabax.x new file mode 100644 index 00000000..0c30021b --- /dev/null +++ b/sys/gio/glabax/glabax.x @@ -0,0 +1,264 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "glabax.h" + +# GLABAX -- Draw and label the axes of the plot (normally the viewport +# boundary). This is done in two steps. First we compute all the required +# parameters, and then we draw and label the axes. Up to four axes can be +# drawn. To simplify matters, all four axes are treated equally and +# independently. The axes are drawn a tick at a time in world coordinates. + +procedure glabax (gp, title, xlabel, ylabel) + +pointer gp # graphics descriptor +char title[ARB] # plot title (may be more than one line) +char xlabel[ARB] # X axis label +char ylabel[ARB] # Y axis label + +char label[SZ_LABEL] +int axis, wcs, ntitlelines, ip, major_tick +int save_plcolor, save_txcolor, save_facolor +int save_pltype, save_clip, save_txfont +real xv[4], yv[4], x1, x2, y1, y2 +real save_plwidth, save_txsize +real dx, dy, x, y, sx, sy, scalar, wc, wstep +pointer sp, axes[4], ax, w + +real gstatr() +bool ttygetb() +int gstati(), glb_gettick() +errchk glb_setup, gadraw, grdraw, gamove, gtext +errchk glb_label_axis, glb_plot_title, glb_gettick + +begin + call smark (sp) + call salloc (axes[1], LEN_AX, TY_STRUCT) + call salloc (axes[2], LEN_AX, TY_STRUCT) + call salloc (axes[3], LEN_AX, TY_STRUCT) + call salloc (axes[4], LEN_AX, TY_STRUCT) + + wcs = GP_WCS(gp) + w = GP_WCSPTR(gp,wcs) + + # Count the number of lines in the title block. + ntitlelines = 0 + if (title[1] != EOS) { + for (ip=1; title[ip] != EOS; ip=ip+1) + if (title[ip] == '\n' && title[ip+1] != EOS) + ntitlelines = ntitlelines + 1 + ntitlelines = ntitlelines + 1 + } + ntitlelines = max (ntitlelines, GP_NTITLELINES(gp)) + + # Fix the coordinates systems and set the axis drawing parameters. + # The number of lines in the title block is needed to determine how + # much space to allow at the top of the screen. + + call glb_setup (gp, axes, ntitlelines, xlabel, ylabel) + + # Save the values of any user parameters we must change while drawing + # the axes. + + save_pltype = gstati (gp, G_PLTYPE) + save_plwidth = gstatr (gp, G_PLWIDTH) + save_plcolor = gstati (gp, G_PLCOLOR) + save_txfont = gstati (gp, G_TXFONT) + save_txsize = gstatr (gp, G_TXSIZE) + save_txcolor = gstati (gp, G_TXCOLOR) + save_facolor = gstati (gp, G_FACOLOR) + save_clip = WCS_CLIP(w) + + # Prepare the background. + if (ttygetb (GP_TTY(gp), "fa") && + GP_FRAMECOLOR(gp) != 0 && GP_FRAMEDRAWN(gp) == NO) { + + call ggview (gp, x1, x2, y1, y2) + call gseti (gp, G_WCS, 0) + call gseti (gp, G_CLIP, NO) + + xv[1] = 0.0; yv[1] = 0.0 + xv[2] = 1.0; yv[2] = 0.0 + xv[3] = 1.0; yv[3] = 1.0 + xv[4] = 0.0; yv[4] = 1.0 + call gseti (gp, G_FACOLOR, GP_FRAMECOLOR(gp)) + call gfill (gp, xv, yv, 4, GF_SOLID) + + xv[1] = x1; yv[1] = y1 + xv[2] = x2; yv[2] = y1 + xv[3] = x2; yv[3] = y2 + xv[4] = x1; yv[4] = y2 + call gseti (gp, G_FACOLOR, 0) + call gfill (gp, xv, yv, 4, GF_SOLID) + + call gseti (gp, G_CLIP, save_clip) + call gseti (gp, G_WCS, wcs) + GP_FRAMEDRAWN(gp) = YES + } + + # Draw and label the four axes. First set the linetype and linewidth + # to be used to draw the axes and ticks; these may be different than + # that used to plot the data. Draws are preferred to moves to minimize + # the number of polylines needed to draw the axis. An axis is drawn + # by moving to the start of the axis, drawing each tick in sequence, + # and then moving to the end of the axis. Tick labels are drawn at + # the major ticks if required. The axes and ticks must be drawn in + # world coords to get the proper scaling. Clipping is turned off while + # drawing the axes to avoid clipping portions of the axes due to small + # floating point errors. + + call gseti (gp, G_PLTYPE, 1) + call gseti (gp, G_CLIP, NO) + call gseti (gp, G_TXFONT, GT_BOLD) + + do axis = 1, 4 { + ax = axes[axis] + if (AX_DRAWME(ax) == NO) + next + +# call eprintf ("axis %d: tick1=(%g,%g) istep=(%g,%g) kstep=%g\n") +# call pargi (axis) +# call pargr (AX_TICK1(ax,1)); call pargr (AX_TICK1(ax,2)) +# call pargr (AX_ISTEP(ax,1)); call pargr (AX_ISTEP(ax,2)) +# call pargr (AX_IKSTEP(ax)) +# call eprintf ("\tstart=(%g,%g) end=(%g,%g)\n") +# call pargr (AX_START(ax,1)); call pargr (AX_START(ax,2)) +# call pargr (AX_END(ax,1)); call pargr (AX_END(ax,2)) +# call eprintf ("nminor=%d, inleft=%d, minortick=(%g,%g), majortick=(%g,%g)\n") +# call pargi (AX_NMINOR(ax)); call pargi (AX_INLEFT(ax)) +# call pargr (AX_MINORTICK(ax,1)); call pargr (AX_MINORTICK(ax,2)) +# call pargr (AX_MAJORTICK(ax,1)); call pargr (AX_MAJORTICK(ax,2)) + + # Set the axis linewidth and move to the start of the axis. + call gsetr (gp, G_PLWIDTH, AX_AXISWIDTH(ax)) + call gseti (gp, G_PLCOLOR, AX_AXISCOLOR(ax)) + call gamove (gp, AX_START(ax,1), AX_START(ax,2)) + + # Draw the axis and label the major ticks if so indicated. + # First set flag to initialize glb_gettick. + + AX_NLEFT(ax) = -1 + while (glb_gettick (gp, ax, x, y, major_tick) != EOF) { + + # Advance to the next tick. + call gsetr (gp, G_PLWIDTH, AX_AXISWIDTH(ax)) + call gseti (gp, G_PLCOLOR, AX_AXISCOLOR(ax)) + call gadraw (gp, x, y) + + if (major_tick == YES) { + # Draw a major tick. + + call gsetr (gp, G_PLWIDTH, AX_MAJORWIDTH(ax)) + call gseti (gp, G_PLCOLOR, AX_TICKCOLOR(ax)) + dx = AX_MAJORTICK(ax,1) + dy = AX_MAJORTICK(ax,2) + call grdraw (gp, dx, dy) + call grdraw (gp, -dx, -dy) + + if (AX_LABELTICKS(ax) == YES) { + # Get the tick label position in NDC coords. World + # coords cannot be used for an offset outside the + # viewport as the coords might be indefinite if log + # scaling. + + call gseti (gp, G_WCS, 0) + call gcurpos (gp, sx, sy) + dx = AX_TICKLABELOFFSET(ax,1) + dy = AX_TICKLABELOFFSET(ax,2) + + # Format the numeric tick label string. The scalar + # multiplier is used to compute the step size between + # major ticks. + + scalar = AX_NMINOR(ax) + 1.0 + if (AX_HORIZONTAL(ax) == YES) { + wc = x + wstep = AX_STEP(ax,1) * scalar + } else { + wc = y + wstep = AX_STEP(ax,2) * scalar + } + + # Draw the label string. + call gsetr (gp, G_TXSIZE, AX_TICKLABELSIZE(ax)) + call gseti (gp, G_TXCOLOR, AX_TICKLABELCOLOR(ax)) + + # If log scaling, label the ticks in log units. + if (AX_SCALING(ax) == LINEAR) { + call glb_encode (wc, label, SZ_LABEL, + AX_TICKFORMAT(ax), wstep) + call gtext (gp, sx + dx, sy + dy, label, + AX_TICKLABELPOS(ax)) + } else { + call glb_loglab (gp, sx+dx, sy+dy, wc, + AX_TICKLABELPOS(ax), AX_SCALING(ax)) + } + + # Leave the pen back at the base of the tick. + call gamove (gp, sx, sy) + call gseti (gp, G_WCS, wcs) + } + + } else { + # Draw a minor tick. + + dx = AX_MINORTICK(ax,1) + dy = AX_MINORTICK(ax,2) + + call gsetr (gp, G_PLWIDTH, AX_MINORWIDTH(ax)) + call gseti (gp, G_PLCOLOR, AX_TICKCOLOR(ax)) + call grdraw (gp, dx, dy) + call grdraw (gp, -dx, -dy) + } + } + + # Draw line segment from last tick to the end of the axis. + call gadraw (gp, AX_END(ax,1), AX_END(ax,2)) + + # Flush the graphics output. When working interactively, this + # gives the user something to watch while we generate the rest + # of the plot. + + if (AX_NMINOR(ax) > 0) + call gflush (gp) + } + + # Draw grid between major ticks. + if (GL_DRAWGRID (GP_XAP(gp)) == YES) { + call gseti (gp, G_PLCOLOR, AX_GRIDCOLOR(axes[3])) + call glb_drawgrid (gp, axes[3], axes[2]) + } + if (GL_DRAWGRID (GP_YAP(gp)) == YES) { + call gseti (gp, G_PLCOLOR, AX_GRIDCOLOR(axes[1])) + call glb_drawgrid (gp, axes[1], axes[4]) + } + + # Label the X and Y axes. + do axis = 1, 4 { + ax = axes[axis] + if (AX_DRAWME(ax) == YES && AX_LABELTICKS(ax) == YES) { + call gseti (gp, G_TXCOLOR, AX_AXISLABELCOLOR(ax)) + call glb_label_axis (gp, ax, xlabel, ylabel) + } + } + + # Draw plot title block. + call gseti (gp, G_TXCOLOR, GP_TITLECOLOR(gp)) + call glb_plot_title (gp, title, ntitlelines) + + # Restore the parameters we were originally called with. + call gseti (gp, G_WCS, wcs) + call gseti (gp, G_CLIP, save_clip) + call gseti (gp, G_PLTYPE, save_pltype) + call gsetr (gp, G_PLWIDTH, save_plwidth) + call gseti (gp, G_PLCOLOR, save_plcolor) + call gsetr (gp, G_TXSIZE, save_txsize) + call gseti (gp, G_TXFONT, save_txfont) + call gseti (gp, G_TXCOLOR, save_txcolor) + call gseti (gp, G_FACOLOR, save_facolor) + + call gflush (gp) + call sfree (sp) +end diff --git a/sys/gio/glabax/glbencode.x b/sys/gio/glabax/glbencode.x new file mode 100644 index 00000000..cbed6875 --- /dev/null +++ b/sys/gio/glabax/glbencode.x @@ -0,0 +1,66 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "glabax.h" + +# GLB_ENCODE -- Encode a floating point number as a character string for a +# tick label. We have to be careful how we do this, since on the one hand +# we want the most concise label possible (e.g., 500 not 500.00) but on the +# other we must provide enough precision to discriminate between ticks that +# are close together (e.g., 500.02 and 500.04). The extra information is +# given by the "ndigits" argument, which was calculated knowing the range +# and step at setup time. + +procedure glb_encode (x, out, maxch, format, step) + +real x # number to be encoded +char out[ARB] # output string +int maxch # max chars out +char format[ARB] # sprintf format +real step # tick spacing + +int ip, op +real nicex +define trim_ 91 + +begin + # Test for the zero tick, to avoid tick labels that look like the + # machine epsilon. + + if (abs (x / step) < TOL) + nicex = 0 + else + nicex = x + + # Encode number. + call sprintf (out, maxch, format) + call pargr (nicex) + + # Lop off any insignificant trailing zeros or periods. Watch out for + # trailing zeros in exponential format, e.g., "1.0E10". + + for (ip=1; out[ip] != EOS; ip=ip+1) + if (out[ip] == 'E' || out[ip] == 'D') + goto trim_ + + for (ip=ip-1; ip > 1 && out[ip] == '0'; ip=ip-1) + ; + if (ip > 1 && out[ip] == '.') + ip = ip - 1 + if (ip >= 1) + out[ip+1] = EOS + + # Lop off any insignificant leading zeros, but be sure to leave at + # least one digit. +trim_ + for (op=1; out[op] == '-' || out[op] == '+'; op=op+1) + ; + for (ip=op; out[ip] == '0' && out[ip+1] != EOS; ip=ip+1) + ; + while (out[ip] != EOS) { + out[op] = out[ip] + op = op + 1 + ip = ip + 1 + } + out[op] = EOS +end diff --git a/sys/gio/glabax/glbfind.x b/sys/gio/glabax/glbfind.x new file mode 100644 index 00000000..b9ff3975 --- /dev/null +++ b/sys/gio/glabax/glbfind.x @@ -0,0 +1,339 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "glabax.h" + +# GLB_FIND_TICKS -- Find the optimal positions for the tick marks on an axis. +# If rounding is enabled, extend the WCS out to the next tick outside the +# boundary on either end of the axis. Since this routine may modify the WCS +# it must be called before any other routines (e.g., glb_setaxes). Our task +# is to position the major ticks in world coordinates at round numbers, e.g., +# 10, 20, 30 for a linear scale or 10, 100, 1000 for a log scale. The minor +# ticks are evenly distributed over the range between the major ticks. If +# log scaling is in use the step size between ticks will change by an order +# of magnitude (by the factor KSTEP) in each decade of the log scale, i.e., +# at each major tick. All tick positions and offsets are output in world +# coordinates. + +procedure glb_find_ticks (gp, ap, ax1, ax2, angle) + +pointer gp # graphics descriptor +pointer ap # axis parameters (from graphics descriptor) +pointer ax1, ax2 # axis descriptors (output) +int angle # axis orientation, 0 or 90 degrees + +pointer w +int logflag, nminor, scaling, t1, t2 +real char_height, char_width, wctick, tval +real p1, p2, tp1, tp2, wcp1, tick1, step, minor_step, length + +bool fp_equalr() +int gt_ndigits() +real ggetr(), elogr(), aelogr(), glb_minorstep() + +begin + w = GP_WCSPTR (gp, GP_WCS(gp)) + + # Start by zeroing the AX structures so that we do not have to zero + # fields explicitly. This is a bit tricky because we are implicitly + # setting fields that are not named, but it saves time and space. + + call aclri (Memi[ax1], LEN_AX) + call aclri (Memi[ax2], LEN_AX) + + # If ticks are not to be drawn or if there are fewer than 2 ticks then + # we are done. + + if (GL_NMAJOR(ap) <= 2) + return + + # Call the tick placement algorithm to determine where to put the major + # tick marks. The output of this block are the variables P1 and P1, + # the world coords of the ends of the axis, and TICK1 and STEP, the + # world coords of the first tick and separation in world coords between + # major ticks. + + if (angle == 0) { + p1 = WCS_WX1(w) + p2 = WCS_WX2(w) + scaling = WCS_XTRAN(w) + } else { + p1 = WCS_WY1(w) + p2 = WCS_WY2(w) + scaling = WCS_YTRAN(w) + } + + AX_SCALING(ax1) = scaling + AX_SCALING(ax2) = scaling + + if (scaling == LOG) { + p1 = log10 (p1) + p2 = log10 (p2) + logflag = YES + } else if (scaling == ELOG) { + p1 = elogr (p1) + p2 = elogr (p2) + logflag = YES + } else + logflag = NO + + # Call the tick placement algorithm. + call gtickr (p1, p2, GL_NMAJOR(ap), logflag, tick1, step) + + # If rounding is enabled, extend the WCS out to the next major tick + # position outward on either end. Always round if log scaling. + + if (GL_ROUND(ap) == YES || scaling != LINEAR) { + if (!fp_equalr (p1, tick1)) { + tick1 = tick1 - step + p1 = tick1 + } + + length = (p2 - p1) / step + if (!fp_equalr (p1 + int(length) * step, p2)) + p2 = p1 + (int(length) + 1) * step + + if (scaling == ELOG) { + tp1 = aelogr (p1) + tp2 = aelogr (p2) + } else if (scaling == LOG) { + tp1 = 10.0 ** p1 + tp2 = 10.0 ** p2 + } else { + tp1 = p1 + tp2 = p2 + } + + if (angle == 0) { + WCS_WX1(w) = tp1 + WCS_WX2(w) = tp2 + } else { + WCS_WY1(w) = tp1 + WCS_WY2(w) = tp2 + } + + GP_WCSSTATE(gp) = MODIFIED + } + + # Compute the coords of the axis endpoint and of the first tick in world + # coords. + + if (scaling == LINEAR) { + wctick = tick1 + wcp1 = p1 + } else if (scaling == LOG) { + wctick = 10.0 ** tick1 + wcp1 = 10.0 ** p1 + } else { + wctick = aelogr (tick1) + wcp1 = aelogr (p1) + } + + # Compute the number of minor ticks. If we are log scaling there + # are either no minor ticks or 8 minor ticks. If the scaling is + # linear the tick placement algorithm is used to compute the best + # number of minor ticks, using GL_NMINOR as a close estimate. If + # NMINOR is negative automatic tick selection is disabled and exactly + # abs(NMINOR) ticks will be drawn. If NMINOR is zero no minor ticks + # are drawn. + + if (GL_NMINOR(ap) == 0) # no minor ticks + nminor = 0 + else if (logflag == YES) # log scaling + nminor = 8 + else { + minor_step = glb_minorstep (tick1, tick1+step, GL_NMINOR(ap)) + nminor = nint (abs (step / minor_step)) - 1 + } + + AX_NMINOR(ax1) = nminor + AX_NMINOR(ax2) = nminor + + # Compute the step size in world coords between minor ticks and the + # number of minor ticks to be drawn initially until the first major + # tick (tick1) is reached. Note that for ELOG scaling the minor + # step size and number of minor ticks are different in the range + # +-10 (which is linear) than elsewhere, but we ignore that here. + + if (scaling == LINEAR) { + minor_step = step / (nminor + 1) + AX_INLEFT(ax1) = abs (int ((wctick - wcp1) / minor_step)) + } else { + t1 = nint (tick1) + t2 = nint (tick1 + step) + if (scaling == LOG) + minor_step = (10.0 ** t2 - 10.0 ** t1) / 9. + else + minor_step = (aelogr(real(t2)) - aelogr(real(t1))) / 9. + if (nminor == 0) + minor_step = minor_step * 9. + AX_INLEFT(ax1) = 0 + } + + AX_INLEFT(ax2) = AX_INLEFT(ax1) + + # Set KSTEP, the adjustment to the step size at each major tick. This + # is always 1.0 if the scale is linear. Set KSTEP to negative if ELOG + # scaling, to tell the drawing code to invert kstep (.1->10 or 10->.1) + # when passing through the origin (necessary for ELOG scaling). The + # sign is not otherwise significant. If heading toward the origin + # initially then KSTEP is inverted for ELOG scaling vs LOG scaling. + + if (scaling == LINEAR) { + AX_IKSTEP(ax1) = 1.0 + } else if (scaling == ELOG) { + tval = p1 + if (abs (tval + step) > abs(t1)) + AX_IKSTEP(ax1) = -10.0 + else + AX_IKSTEP(ax1) = -0.1 + } else + AX_IKSTEP(ax1) = 10.0 ** step + AX_IKSTEP(ax2) = AX_IKSTEP(ax1) + + # Set those parameters which differ depending on whether the axis is + # horizontal or vertical. + + if (angle == 0) { + AX_TICK1(ax1,1) = wctick - (AX_INLEFT(ax1) * minor_step) + AX_TICK1(ax2,1) = wctick - (AX_INLEFT(ax2) * minor_step) + + if (GL_SETAXISPOS(ap) == YES) { + AX_TICK1(ax1,2) = GL_AXISPOS1(ap) + AX_TICK1(ax2,2) = GL_AXISPOS2(ap) + } else { + AX_TICK1(ax1,2) = WCS_WY1(w) + AX_TICK1(ax2,2) = WCS_WY2(w) + } + + AX_ISTEP(ax1,1) = minor_step + AX_ISTEP(ax2,1) = minor_step + + char_height = ggetr (gp, "ch") + if (char_height < EPSILON) + char_height = DEF_CHARHEIGHT + char_height = char_height * GL_TICKLABELSIZE(ap) + + AX_TICKLABELOFFSET(ax2,2) = 0.5 * char_height + AX_TICKLABELOFFSET(ax1,2) = -AX_TICKLABELOFFSET(ax2,2) + + # Set gtext format for tick labels. + call strcpy ("hj=c,vj=t", AX_TICKLABELPOS(ax1), SZ_FORMAT) + call strcpy ("hj=c,vj=b", AX_TICKLABELPOS(ax2), SZ_FORMAT) + + } else { + if (GL_SETAXISPOS(ap) == YES) { + AX_TICK1(ax1,1) = GL_AXISPOS1(ap) + AX_TICK1(ax2,1) = GL_AXISPOS2(ap) + } else { + AX_TICK1(ax1,1) = WCS_WX1(w) + AX_TICK1(ax2,1) = WCS_WX2(w) + } + + AX_TICK1(ax1,2) = wctick - (AX_INLEFT(ax1) * minor_step) + AX_TICK1(ax2,2) = wctick - (AX_INLEFT(ax2) * minor_step) + + AX_ISTEP(ax1,2) = minor_step + AX_ISTEP(ax2,2) = minor_step + + char_width = ggetr (gp, "cw") + if (char_width < EPSILON) + char_width = DEF_CHARWIDTH + char_width = char_width * GL_TICKLABELSIZE(ap) + + AX_TICKLABELOFFSET(ax2,1) = 0.5 * char_width + AX_TICKLABELOFFSET(ax1,1) = -AX_TICKLABELOFFSET(ax2,1) + + call strcpy ("hj=r,vj=c", AX_TICKLABELPOS(ax1), SZ_FORMAT) + call strcpy ("hj=l,vj=c", AX_TICKLABELPOS(ax2), SZ_FORMAT) + } + + # Set the tick parameters that are identical for the two axes and + # which do not depend on whether the axis is horizontal or vertical. + + AX_DRAWTICKS(ax1) = GL_DRAWTICKS(ap) + AX_DRAWTICKS(ax2) = GL_DRAWTICKS(ap) + AX_TICKLABELSIZE(ax1) = GL_TICKLABELSIZE(ap) + AX_TICKLABELSIZE(ax2) = GL_TICKLABELSIZE(ap) + AX_TICKLABELCOLOR(ax1) = GL_TICKLABELCOLOR(ap) + AX_TICKLABELCOLOR(ax2) = GL_TICKLABELCOLOR(ap) + AX_TICKCOLOR(ax1) = GL_TICKCOLOR(ap) + AX_TICKCOLOR(ax2) = GL_TICKCOLOR(ap) + AX_GRIDCOLOR(ax1) = GL_GRIDCOLOR(ap) + AX_GRIDCOLOR(ax2) = GL_GRIDCOLOR(ap) + AX_AXISLABELSIZE(ax1) = GL_AXISLABELSIZE(ap) + AX_AXISLABELSIZE(ax2) = GL_AXISLABELSIZE(ap) + AX_AXISLABELCOLOR(ax1) = GL_AXISLABELCOLOR(ap) + AX_AXISLABELCOLOR(ax2) = GL_AXISLABELCOLOR(ap) + AX_AXISWIDTH(ax1) = GL_AXISWIDTH(ap) + AX_AXISWIDTH(ax2) = GL_AXISWIDTH(ap) + AX_AXISCOLOR(ax1) = GL_AXISCOLOR(ap) + AX_AXISCOLOR(ax2) = GL_AXISCOLOR(ap) + AX_MINORWIDTH(ax1) = GL_MINORWIDTH(ap) + AX_MINORWIDTH(ax2) = GL_MINORWIDTH(ap) + AX_MAJORWIDTH(ax1) = GL_MAJORWIDTH(ap) + AX_MAJORWIDTH(ax2) = GL_MAJORWIDTH(ap) + + # Compute the number of digits of precision needed for the tick labels. + AX_NDIGITS(ax1) = max (1, gt_ndigits (p1, p2, step)) + AX_NDIGITS(ax2) = AX_NDIGITS(ax1) + + # If both axes are to be drawn label ticks if enabled. If only one + # axis is to be drawn that is the axis that must be labelled. + + if (GL_DRAWAXES(ap) > 0) { + AX_LABELTICKS(ax1) = GL_LABELTICKS(ap) + AX_LABELTICKS(ax2) = GL_LABELTICKS(ap) + } + if (GL_DRAWAXES(ap) == 1 || GL_DRAWAXES(ap) == 3) + AX_LABELTICKS(ax2) = NO + else if (GL_DRAWAXES(ap) == 2) + AX_LABELTICKS(ax1) = NO + + # The user may override the tick label format if desired. + if (GL_TICKFORMAT(ap) == EOS) { + call sprintf (AX_TICKFORMAT(ax1), SZ_FORMAT, "%%0.%dg") + call pargi (AX_NDIGITS(ax1) + 1) + } else + call strcpy (GL_TICKFORMAT(ap), AX_TICKFORMAT(ax1), SZ_FORMAT) + call strcpy (AX_TICKFORMAT(ax1), AX_TICKFORMAT(ax2), SZ_FORMAT) +end + + +# GLB_MINORSTEP -- Determine the step size for the minor ticks. Adapted +# from a routine by J. Eisenhamer (STScI) which was based on some MONGO code. + +real procedure glb_minorstep (x1, x2, nminor) + +real x1, x2 #I interval between major ticks +int nminor #I suggested number of minor ticks, or actual# if neg + +int iexp +real amant, diff, num, range + +begin + range = abs (x2 - x1) + if (nminor < 0) + return (range / real (-nminor + 1)) + else { + # Determine magnitude of the intervals. + diff = log10 (range / nminor) + iexp = int (diff) + if (diff < 0) + iexp = iexp - 1 + amant = diff - real(iexp) + + # Determine an appropriate step size. + if (amant < 0.15) + num = 1.0 + else if (amant < 0.50) + num = 2.0 + else if (amant < 0.85) + num = 5.0 + else + num = 10.0 + + return (num * 10.0**iexp) + } +end diff --git a/sys/gio/glabax/glbgrid.x b/sys/gio/glabax/glbgrid.x new file mode 100644 index 00000000..ecb24ffb --- /dev/null +++ b/sys/gio/glabax/glbgrid.x @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "glabax.h" + +# GLB_DRAWGRID -- Draw a grid across the plotting surface, i.e., draw +# dotted lines between the major tick marks. + +procedure glb_drawgrid (gp, ax1, ax2) + +pointer gp # graphics descriptor +pointer ax1 # descriptor for first axis +pointer ax2 # descriptor for second axis + +int wcs, major_tick +real x, y, tolerance +real x1, y1, x2, y2, sx, sy +int glb_gettick() +errchk glb_gettick, gseti, gsetr, gline, gctran + +begin + tolerance = TOL + wcs = GP_WCS(gp) + + # Cache the NDC coordinates of the ends of an axis. + call gctran (gp, AX_START(ax1,1), AX_START(ax1,2), x1,y1, wcs, 0) + call gctran (gp, AX_END(ax1,1), AX_END(ax1,2), x2,y2, wcs, 0) + + # Set polyline linetype for a dotted line. + call gseti (gp, G_PLTYPE, GL_DOTTED) + call gsetr (gp, G_PLWIDTH, 1.0) + + AX_NLEFT(ax1) = -1 + while (glb_gettick (gp, ax1, x, y, major_tick) != EOF) { + if (major_tick == NO) + next + + # Draw grid line if we are at a major tick, provided the tick + # is not at the end of the axis. + + call gctran (gp, x,y, sx,sy, wcs, 0) + if (AX_HORIZONTAL(ax1) == YES) { + if (sx - x1 > tolerance && sx - x2 < tolerance) + call gline (gp, x, AX_END(ax1,2), x, AX_END(ax2,2)) + } else { + if (sy - y1 > tolerance && sy - y2 < tolerance) + call gline (gp, AX_END(ax1,1), y, AX_END(ax2,1), y) + } + } + + call gseti (gp, G_PLTYPE, GL_SOLID) +end diff --git a/sys/gio/glabax/glbgtick.x b/sys/gio/glabax/glbgtick.x new file mode 100644 index 00000000..cc70fd3a --- /dev/null +++ b/sys/gio/glabax/glbgtick.x @@ -0,0 +1,252 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "glabax.h" + +# GLB_GETTICK -- Get the position and type of the next tick on an axis. +# Ticks are accessed sequentially. There are three types of tick scalings, +# LINEAR, LOG, and ELOG. The tick scaling need not necessarily agree with +# the WCS scaling, hence linear tick scaling might be used on a nonlinear +# coordinate system. If the scaling is linear then the first tick need not +# fall at the endpoint of the axis. If log (or elog) scaling is in use then +# the axis will have been rounded out to a decade and the first tick will +# necessarily fall on the axis endpoint. The scalings are described by the +# following parameters: +# +# (variables) +# nleft number of minor ticks left to next major tick +# step(x,y) displacement between minor ticks (world coords) +# +# (constants) +# tick1(x,y) world coords of the first tick on an axis +# nminor number of minor ticks between major ticks +# istep(x,y) initial step (actual step may differ) +# kstep(x,y) adjustment to step at major ticks +# +# KSTEP is unity if the scaling is linear. The log scalings have a KSTEP of +# either 10.0 or 0.1. A negative KSTEP value is used to flag ELOG scaling. +# ELOG, or extended range log scaling, is a log scaling which is defined for +# X <=0 as well as x > 0. This function is logarithmic for values less than +# -10 or greater than 10, and linear in the range [-10:+10]. This complicates +# tick computation because the usual 8 minor ticks per decade characteristic +# of log scaling are not appropriate in the linear regime. If the scaling +# is ELOG then we ignore NMINOR and ISTEP in the linear range, changing the +# values of these parameters temporarily to reflect 4 minor ticks with a tick +# spacing of 2.0. +# +# (Note to the reader: don't feel discouraged if you don't understand this +# (stuff, it is so complicated I don't understand it either! Having to deal +# (with linear, log, and elog scaling with both major and minor ticks, +# (sometimes no minor ticks, with the axis starting at any part of the scale +# (seems an inherently difficult problem to program compactly. Barring +# (programming each case separately, the best approach I could come up with was +# (to walkthrough the code separately for each case, from all initial +# (conditions, until it works for all cases. If you have problems determine +# (the initial conditions (the case) and do a similar walkthough. Of course, +# (if you make a change affecting one case, you may well make the code fail for +# (a different case. + +int procedure glb_gettick (gp, ax, x, y, major_tick) + +pointer gp # graphics descriptor +pointer ax # axis descriptor +real x, y # coordinates of next tick (output) +int major_tick # YES if next tick is a major tick + +int i, axis, wcs, w, scaling, nminor, expon +real kstep, step, astep, ten, sx, sy, tolerance, pos, norm_pos +bool glb_eq() +define logscale_ 91 + +begin + if (AX_DRAWTICKS(ax) == NO) + return (EOF) + + tolerance = TOL + scaling = AX_SCALING(ax) + nminor = AX_NMINOR(ax) + kstep = AX_KSTEP(ax) + + if (AX_HORIZONTAL(ax) == YES) + axis = 1 + else + axis = 2 + + # Count down a minor tick. If nleft is negative then we are being + # called for the first time for this axis. + + if (AX_NLEFT(ax) < 0) { + + # Initialize everything and return coords of the first tick. + AX_KSTEP(ax) = AX_IKSTEP(ax) + AX_NLEFT(ax) = AX_INLEFT(ax) + do i = 1, 2 { + AX_POS(ax,i) = AX_TICK1(ax,i) + AX_STEP(ax,i) = AX_ISTEP(ax,i) + } + + step = AX_STEP(ax,axis) + astep = abs (step) + + if (AX_NLEFT(ax) == 0) { + # Note that there may not be any minor ticks. + major_tick = YES + AX_NLEFT(ax) = nminor + if (nminor > 0) + if (scaling == ELOG && (astep >= .99 && astep < 2.0)) { + # Elog scaling in linear region. + AX_NLEFT(ax) = 4 + if (step < 0) + step = -2.0 + else + step = 2.0 + AX_STEP(ax,axis) = step + } + } else { + AX_NLEFT(ax) = AX_NLEFT(ax) - 1 + major_tick = NO + } + + # Elog scaling in linear region. KSTEP must be inverted as we + # pass through the origin. This normally occurs upon entry to the + # linear region, but if we start out at +/- 10 we must set KSTEP + # to its linear value during setup. + + if (scaling == ELOG && glb_eq(step,2.0)) + AX_KSTEP(ax) = -10.0 + + } else { + # All ticks after the first tick. + do i = 1, 2 + AX_POS(ax,i) = AX_POS(ax,i) + AX_STEP(ax,i) + AX_NLEFT(ax) = AX_NLEFT(ax) - 1 + + # If we are log scaling the ticks will never have more than 2 + # digits of precision. Try to correct for the accumulation of + # error by rounding. When log scaling the error increases by + # a factor of ten in each decade and can get quite large if + # the log scale covers a large range. + + if (scaling != LINEAR) { + pos = AX_POS(ax,axis) + call fp_normr (pos, norm_pos, expon) + pos = nint (norm_pos * 10.0) / 10.0 + pos = pos * (10.0 ** expon) + AX_POS(ax,axis) = pos + } + + if (AX_NLEFT(ax) < 0) { + # Next tick is a major tick. If log scaling we must reset + # the tick parameters for the next decade. + + major_tick = YES + AX_NLEFT(ax) = nminor + + # The following handles the special case of ELOG scaling in + # the linear regime when the number of minor ticks is zero. + # The step size in such a case is 9 to some power in the log + # region and +/- 10 in the linear region. + + if (scaling == ELOG && nminor == 0) { + pos = AX_POS(ax,axis) + if (step < 0) + ten = -10. + else + ten = 10. + + if (glb_eq (pos, 10.0)) { + if (glb_eq (step, 10.0)) { + if (step < 0) + AX_STEP(ax,axis) = -9. + else + AX_STEP(ax,axis) = 9. + goto logscale_ + } else + step = ten + } else if (glb_eq (pos, 0.0)) { + step = ten + if (pos / step < 0) + AX_KSTEP(ax) = -0.1 + else + AX_KSTEP(ax) = -10.0 + } else + goto logscale_ + AX_STEP(ax,axis) = step + + } else if (scaling != LINEAR) { + # Adjust the tick step by the kstep factor, provided we + # are not at the origin in ELOG scaling (the step is 1 + # on either side of the origin for ELOG scaling). Reset + # the step size to 1.0 if ELOG scaling and just coming out + # of the linear regime. +logscale_ + step = AX_STEP(ax,axis) + if (scaling != ELOG || abs(AX_POS(ax,axis)) > 0.1) { + if (scaling == ELOG && glb_eq (step, 2.0)) + AX_STEP(ax,axis) = step / 2.0 + + do i = 1, 2 + AX_STEP(ax,i) = AX_STEP(ax,i) * abs (AX_KSTEP(ax)) + } + + # Adjust the step size to 2.0 if ELOG scaling and in the + # linear regime (initial step size of 1). + + step = AX_STEP(ax,axis) + if (scaling == ELOG && glb_eq(step,1.0)) { + if (step < 0) + step = -2.0 + else + step = 2.0 + AX_STEP(ax,axis) = step + } + + # If elog scaling and we have just entered the linear + # regime, adjust the number of ticks and the KSTEP factor. + + if (scaling == ELOG && glb_eq(step,2.0)) { + # Elog scaling in linear region. KSTEP must be + # inverted as we pass through the origin. + + if (abs(AX_POS(ax,axis)) > 0.1) + AX_KSTEP(ax) = -10.0 + + if (nminor > 0) + AX_NLEFT(ax) = 4 + } + } + } else + major_tick = NO + } + + x = AX_POS(ax,1) + y = AX_POS(ax,2) + + # Return EOF if tick falls beyond end of axis. The comparison is made + # in NDC coords to avoid having to check if the WCS is increasing or + # decreasing and to avoid the problems of comparing unnormalized + # floating point numbers. + + wcs = GP_WCS(gp) + w = GP_WCSPTR(gp,wcs) + + call gctran (gp, x,y, sx,sy, wcs, 0) + if (sx - WCS_SX2(w) > tolerance || sy - WCS_SY2(w) > tolerance) + return (EOF) + else + return (OK) +end + + +# GLB_EQ -- Compare two (near normalized) floating point numbers for +# equality, using the absolute value of the first argument. + +bool procedure glb_eq (a, b) + +real a # compare absolute value of this number +real b # to this positive number + +begin + return (abs (abs(a) - b) < 0.1) +end diff --git a/sys/gio/glabax/glblabel.x b/sys/gio/glabax/glblabel.x new file mode 100644 index 00000000..ecf57c94 --- /dev/null +++ b/sys/gio/glabax/glblabel.x @@ -0,0 +1,84 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "glabax.h" + +# GLB_LABEL_AXIS -- Label an axis. If both axes were drawn only the first is +# labelled, otherwise the label is placed on withever axis was drawn. This is +# done by drawing the axis labels just outside the tick mark labels, wherever +# those happened to be. The axis label offset is in the same direction as the +# tick label offset and is centered on each axis. The distance from the axis +# is a function of the size of the tick labels. + +procedure glb_label_axis (gp, ax, xlabel, ylabel) + +pointer gp # graphics descriptor +pointer ax # axis descriptor +char xlabel[ARB] # X axis label +char ylabel[ARB] # Y axis label + +int wcs +real x1, x2, y1, y2, x, y, dx, dy +real char_height, char_width +int strlen() +real ggetr() + +begin + wcs = GP_WCS(gp) + + # Get character height and width in NDC coords. + char_height = ggetr (gp, "ch") + char_width = ggetr (gp, "cw") + + if (char_height < EPSILON) + char_height = DEF_CHARHEIGHT + if (char_width < EPSILON) + char_width = DEF_CHARWIDTH + + # Compute axis center in NDC coords. + call gctran (gp, AX_START(ax,1), AX_START(ax,2), x1,y1, wcs, 0) + call gctran (gp, AX_END(ax,1), AX_END(ax,2), x2,y2, wcs, 0) + x = (x1 + x2) / 2.0 + y = (y1 + y2) / 2.0 + + # Set relative text size and get device character size for a text + # size of 1.0. Set WCS to NDC coords since the offset to the + # tick label is in NDC coordinates. + + call gsetr (gp, G_TXSIZE, AX_AXISLABELSIZE(ax)) + call gseti (gp, G_WCS, 0) + + # Draw the axis label. + + if (AX_HORIZONTAL(ax) == YES) { + # Axis is horizontal. Tick label vector tells us whether to + # draw axis label above or below axis. + + if (strlen (xlabel) > 0) { + dy = 2.0 * AX_TICKLABELSIZE(ax) * char_height + + 0.5 * AX_AXISLABELSIZE(ax) * char_height + if (AX_TICKLABELOFFSET(ax,2) < 0) + dy = -dy + call gtext (gp, x, y + dy, xlabel, "hj=c;vj=c") + } + } else { + # Axis is vertical. Always put label fixed distance from axis + # regardless of size of tick labels (for consistency and to + # avoid clipping at the device screen boundary). Label runs + # bottom to top in a vertical field with char up pointing to + # the left. + + if (strlen (ylabel) > 0) { + dx = (Y_LABELOFFSET * char_width * AX_TICKLABELSIZE(ax)) + + 0.5 * AX_AXISLABELSIZE(ax) * char_height + + if (AX_TICKLABELOFFSET(ax,1) < 0) + dx = -dx + call gtext (gp, x + dx, y, ylabel, "up=180;hj=c;vj=c") + } + } + + call gseti (gp, G_WCS, wcs) +end diff --git a/sys/gio/glabax/glbloglab.x b/sys/gio/glabax/glbloglab.x new file mode 100644 index 00000000..6e7ec1cc --- /dev/null +++ b/sys/gio/glabax/glbloglab.x @@ -0,0 +1,139 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "glabax.h" + +define SZ_MANTISSA 3 # "10" or "-10" +define SZ_EXPONENT 4 # largest is "-999" + + +# GLB_LOGLAB -- Draw a tick label in log units at the given position. +# A log tick is a power of ten, e.g. 10^2, where the ^ signifies that +# the 2 is to be drawn one half character height higher than the 10. + +procedure glb_loglab (gp, sx, sy, val, fmt, scaling) + +pointer gp # graphics descriptor +real sx, sy # NDC coords of label +real val # value to be encoded (not the log of) +char fmt[ARB] # tick label gtext format (justification) +int scaling # type of scaling on axis + +bool zero +char mantissa[SZ_MANTISSA] +char exponent[SZ_EXPONENT] +int len_mantissa, len_exponent, ip, hj, vj +real logval, char_height, char_width, left, xpos, ypos, txsize + +bool fp_equalr() +real elogr(), gstatr(), ggetr() +int strlen(), strmatch(), itoc() + +begin + # Compute the log value to be encoded. + if (scaling == LOG) + logval = log10 (val) + else { + logval = elogr (val) + zero = fp_equalr (logval, 0.0) + } + + txsize = gstatr (gp, G_TXSIZE) + + # Get char height and width in NDC coords. + char_height = ggetr (gp, "ch") + if (char_height < EPSILON) + char_height = DEF_CHARHEIGHT + char_height = char_height * txsize + + char_width = ggetr (gp, "cw") + if (char_width < EPSILON) + char_width = DEF_CHARWIDTH + char_width = char_width * txsize + + # Encode the mantissa and exponent strings. + if (zero) { + call strcpy ("0", mantissa, SZ_MANTISSA) + } else if (logval < 0 && scaling == ELOG) { + call strcpy ("-10", mantissa, SZ_MANTISSA) + logval = abs (logval) + } else + call strcpy ("10", mantissa, SZ_MANTISSA) + + len_mantissa = strlen (mantissa) + if (zero) + len_exponent = 0 + else + len_exponent = itoc (nint(logval), exponent, SZ_EXPONENT) + + # Determine type of horizontal justification required. + ip = strmatch (fmt, "hj=") + if (ip <= 0) + hj = 'c' + else + hj = fmt[ip] + + # Determine type of vertical justification required. + ip = strmatch (fmt, "vj=") + if (ip <= 0) + vj = 'c' + else + vj = fmt[ip] + + # On devices with adjustable character sizes the most pleasing results + # are obtained if the digits "10" are nicely aligned on the vertical + # axis, regardless of the actual number of characters in the exponent + # string, minus signs etc (this type of alignment is more natural + # because the exponent is printed at half size). Hence if we are on + # a vertical axis (hj != c) fix the number of characters in the two + # strings so that the alignment comes out the same regardless of the + # actual number of chars in either field. The length of the exponent + # field is not completely fixed, rather we allow a little more space + # if the exponent is large. For small exponents len_exponent=1. + + if (hj != 'c') { + len_mantissa = 2 + len_exponent = (len_exponent + 1) / 2 + } + + # Compute XPOS, the NDC X coord of the point halfway between the + # last char of the mantissa and the first char of the exponent. + + switch (hj) { + case 'l': + left = sx + case 'r': + left = sx - (len_mantissa + len_exponent) * char_width + default: + left = sx - ((len_mantissa + len_exponent) * char_width) / 2.0 + } + + xpos = left + len_mantissa * char_width + + # Compute YPOS, the NDC Y coord of the center of a mantissa character + # and of the bottom of an exponent character. Using the same coordinate + # to address both positions makes the label come out the same regardless + # of the plot magnification, even on a device where the character size + # is fixed by the hardware. + + switch (vj) { + case 'b': + ypos = sy + char_height / 2.0 + case 't': + ypos = sy - char_height / 2.0 + default: + ypos = sy + } + + # Draw the mantissa. + call gtext (gp, xpos, ypos, mantissa, "hj=r,vj=c") + + # Draw the exponent if there is one. + if (!zero) { + call gsetr (gp, G_TXSIZE, txsize / 2.0) + call gtext (gp, xpos, ypos, exponent, "hj=l;vj=b") + call gsetr (gp, G_TXSIZE, txsize) + } +end diff --git a/sys/gio/glabax/glbsetax.x b/sys/gio/glabax/glbsetax.x new file mode 100644 index 00000000..f0c9aa29 --- /dev/null +++ b/sys/gio/glabax/glbsetax.x @@ -0,0 +1,130 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "glabax.h" + +# GLB_SET_AXES -- Set all axis descriptor parameters not pertaining to the +# ticks. The WCS has already been fixed by the time we get here. + +procedure glb_set_axes (gp, ap, ax1, ax2, angle) + +pointer gp # graphics descriptor +pointer ap # axis parameters (from graphics descriptor) +pointer ax1, ax2 # axis descriptors (output) +int angle # axis orientation, 0 or 90 degrees + +pointer w +int axis +real p1, p2 +real x1, x2, y1, y2 +real glb_ticklen() + +begin + w = GP_WCSPTR (gp, GP_WCS(gp)) + + # If the window was rounded in Y in the second call to find_ticks, + # then the Y positions of the first ticks set in the first call will + # be in error and must be corrected. If the user has elected to set + # the axis position explicitly, however, then we must leave it alone. + + if (angle == 0 && GL_SETAXISPOS(GP_XAP(gp)) == NO) { + AX_TICK1(ax1,2) = WCS_WY1(w) + AX_TICK1(ax2,2) = WCS_WY2(w) + } + + # Set the tick lengths. This is done here rather than in findticks + # due to rounding, as noted above. The tick offsets in world + # coordinates. The GL values are given in NDC coordinates. + + if (angle == 0) { + axis = 2 + AX_HORIZONTAL(ax1) = YES + AX_HORIZONTAL(ax2) = YES + } else { + axis = 1 + AX_HORIZONTAL(ax1) = NO + AX_HORIZONTAL(ax2) = NO + } + + AX_MAJORTICK(ax1,axis) = glb_ticklen (gp, ax1, GL_MAJORLENGTH(ap)) + AX_MINORTICK(ax1,axis) = glb_ticklen (gp, ax1, GL_MINORLENGTH(ap)) + AX_MAJORTICK(ax2,axis) = glb_ticklen (gp, ax2, -GL_MAJORLENGTH(ap)) + AX_MINORTICK(ax2,axis) = glb_ticklen (gp, ax2, -GL_MINORLENGTH(ap)) + + # Select none, either, or both axes to be drawn. If only the second + # axis is drawn then that is the side we must draw the tick and axis + # labels on. + + switch (GL_DRAWAXES(ap)) { + case 0: + AX_DRAWME(ax1) = NO + AX_DRAWME(ax2) = NO + return + case 1: + AX_DRAWME(ax1) = YES + AX_DRAWME(ax2) = NO + case 2: + AX_DRAWME(ax1) = NO + AX_DRAWME(ax2) = YES + default: + AX_DRAWME(ax1) = YES + AX_DRAWME(ax2) = YES + } + + # Determine the endpoints of the axis. These default to the corners of + # the viewport (in world coordinates), but the positions may be + # overriden by the user if desired. + + # First get the positions of the two axes. + if (GL_SETAXISPOS(ap) == YES) { + p1 = GL_AXISPOS1(ap) + p2 = GL_AXISPOS2(ap) + } else if (angle == 0) { + p1 = WCS_WY1(w) + p2 = WCS_WY2(w) + } else { + p1 = WCS_WX1(w) + p2 = WCS_WX2(w) + } + + # Convert these positions into the world coordinates of the endpoints. + if (angle == 0) { + x1 = WCS_WX1(w) + x2 = WCS_WX2(w) + y1 = p1 + y2 = p2 + } else { + x1 = p1 + x2 = p2 + y1 = WCS_WY1(w) + y2 = WCS_WY2(w) + } + + if (angle == 0) { + # Set the left and right endpoints of the axes. + + AX_START(ax1,1) = x1 + AX_START(ax1,2) = y1 + AX_END(ax1,1) = x2 + AX_END(ax1,2) = y1 + + AX_START(ax2,1) = x1 + AX_START(ax2,2) = y2 + AX_END(ax2,1) = x2 + AX_END(ax2,2) = y2 + + } else { + # Set the lower and upper endpoints of the axes. + + AX_START(ax1,1) = x1 + AX_START(ax1,2) = y1 + AX_END(ax1,1) = x1 + AX_END(ax1,2) = y2 + + AX_START(ax2,1) = x2 + AX_START(ax2,2) = y1 + AX_END(ax2,1) = x2 + AX_END(ax2,2) = y2 + } +end diff --git a/sys/gio/glabax/glbsetup.x b/sys/gio/glabax/glbsetup.x new file mode 100644 index 00000000..a609d2ad --- /dev/null +++ b/sys/gio/glabax/glbsetup.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GLB_SETUP -- Set up the axis drawing and labelling parameters. These are +# the coordinate transformations, i.e., log scaling, window and viewport +# coordinates, plus the parameters which pertain only to axis drawing and +# labelling. The order in which the subprocedures are called is significant. + +procedure glb_setup (gp, axes, ntitlelines, xlabel, ylabel) + +pointer gp # graphics descriptor +pointer axes[4] # array of pointers to axis descriptors +int ntitlelines # number of lines in title block +char xlabel[ARB] # x axis label +char ylabel[ARB] # y axis label + +pointer w +bool fp_nondegenr() + +begin + w = GP_WCSPTR (gp, GP_WCS(gp)) + + # Verify that there is sufficient range in the wcs X and Y. + if (fp_nondegenr (WCS_WX1(w), WCS_WX2(w))) + GP_WCSSTATE(gp) = MODIFIED + if (fp_nondegenr (WCS_WY1(w), WCS_WY2(w))) + GP_WCSSTATE(gp) = MODIFIED + + # If log scaling is in effect on either axis, verify that log scaling + # is sensible and if so select either LOG or ELOG scaling. + + call glb_verify_log_scaling (gp) + + # Set the viewport if not already set. + call glb_set_viewport (gp, ntitlelines, xlabel, ylabel) + + # Find the best positions for the tick marks, and if rounding is + # enabled, extend the WCS outward to the next tick mark on either + # end. + + call glb_find_ticks (gp, GP_XAP(gp), axes[1], axes[4], 0) + call glb_find_ticks (gp, GP_YAP(gp), axes[3], axes[2], 90) + + # Set the remaining parameters in the axis drawing descriptors. + # Must not be called until the window and viewport coordinates are + # fixed. + + call glb_set_axes (gp, GP_XAP(gp), axes[1], axes[4], 0) + call glb_set_axes (gp, GP_YAP(gp), axes[3], axes[2], 90) +end diff --git a/sys/gio/glabax/glbsview.x b/sys/gio/glabax/glbsview.x new file mode 100644 index 00000000..1b099b1a --- /dev/null +++ b/sys/gio/glabax/glbsview.x @@ -0,0 +1,117 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "glabax.h" + +# GLB_SET_VIEWPORT -- If the viewport has not yet been set, i.e., if the +# viewport is still [0:1,0:1], compute the size of the largest viewport which +# leaves sufficient room around the border for the axis labels and plot title. +# If a nonzero aspect ratio is specified make the viewport have that aspect +# ratio. + +procedure glb_set_viewport (gp, ntitlelines, xlabel, ylabel) + +pointer gp # graphics descriptor +int ntitlelines # number of lines to reserve for title block +char xlabel[ARB] # x axis label +char ylabel[ARB] # y axis label + +pointer w, xap, yap +bool draw_title, draw_xlabel, draw_ylabel, draw_xticks, draw_yticks +real char_height, char_width +real aspect, cur_aspect, dev_aspect, dx, dy +real xwidth, ywidth, yreserve +real ggetr() + +begin + w = GP_WCSPTR (gp, GP_WCS(gp)) + xap = GP_XAP(gp) + yap = GP_YAP(gp) + + if ((WCS_SX1(w) > EPSILON) || (abs(1.0 - WCS_SX2(w)) > EPSILON) || + (WCS_SY1(w) > EPSILON) || (abs(1.0 - WCS_SY2(w)) > EPSILON)) + return + + draw_title = (ntitlelines > 0 && GP_DRAWTITLE(gp) == YES) + draw_xticks = (GL_DRAWAXES(xap) > 0 && GL_LABELTICKS(xap) == YES) + draw_xlabel = + (draw_xticks && xlabel[1] != EOS && GL_LABELAXIS(xap) == YES) + draw_yticks = (GL_DRAWAXES(yap) > 0 && GL_LABELTICKS(yap) == YES) + draw_ylabel = + (draw_yticks && ylabel[1] != EOS && GL_LABELAXIS(yap) == YES) + + char_width = ggetr (gp, "cw") + char_height = ggetr (gp, "ch") + + if (char_width < EPSILON) + char_width = DEF_CHARWIDTH + if (char_height < EPSILON) + char_height = DEF_CHARHEIGHT + + # X axis. + if (draw_yticks && draw_ylabel) + xwidth = max (4, LEFT_BORDER + 2) + else if (draw_yticks) + xwidth = max (4, LEFT_BORDER) + else + xwidth = 0 + xwidth = xwidth * char_width * GL_TICKLABELSIZE(xap) + + # Y axis. + if (draw_xticks && draw_xlabel) + ywidth = BOTTOM_BORDER + else if (draw_xticks) + ywidth = max (2, (BOTTOM_BORDER - 2)) + else + ywidth = 0 + ywidth = ywidth * char_height * GL_TICKLABELSIZE(yap) + + # Compute amount of extra space to allow for the title block, which + # may contain more than one line. + + if (!draw_title && !draw_xticks && !draw_yticks) + yreserve = 0 + else if (!draw_title && GP_ASPECT(gp) > 0.9) + yreserve = 0 + else { + yreserve = min (MAX_SZTITLEBLOCK, + max (MIN_NTITLELINES, ntitlelines + 1) * + char_height * GP_TITLESIZE(gp)) + } + + # Set the viewport. The viewport is the largest area yielding the + # desired borders. The viewport is centered in X and positioned just + # below the title block in Y. + + WCS_SX1(w) = xwidth + WCS_SX2(w) = 1.0 - xwidth + WCS_SY1(w) = ywidth + WCS_SY2(w) = 1.0 - yreserve + + # Adjust the viewport to achieve the specified aspect ratio, if a + # nonzero aspect ratio was given. + + dev_aspect = GP_DEVASPECT(gp) # device aspect ratio + aspect = GP_ASPECT(gp) # user desired aspect ratio + + if (aspect > EPSILON) { + dx = WCS_SX2(w) - WCS_SX1(w) + dy = WCS_SY2(w) - WCS_SY1(w) + cur_aspect = dy / dx * dev_aspect + + if (cur_aspect > aspect) { + # Viewport is taller than desired. + dy = aspect / dev_aspect * dx + WCS_SY1(w) = (1.0 - dy) / 2.0 + WCS_SY2(w) = 1.0 - WCS_SY1(w) + } else { + # Viewport is not as wide as desired. + dx = dev_aspect * dy / aspect + WCS_SX1(w) = (1.0 - dx) / 2.0 + WCS_SX2(w) = 1.0 - WCS_SX1(w) + } + } + + GP_WCSSTATE(gp) = MODIFIED +end diff --git a/sys/gio/glabax/glbticlen.x b/sys/gio/glabax/glbticlen.x new file mode 100644 index 00000000..de557757 --- /dev/null +++ b/sys/gio/glabax/glbticlen.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "glabax.h" + +# GLB_TICKLEN -- Compute the length of a tick in world coordinates. All tick +# drawing is performed in world coordinates since the ticks show the world +# coordinate system. The position of a tick must be computed in world coords +# when the axis is drawn to reflect log scaling (or any other nonlinear +# scaling. Less obviously, the tick offset should be given in world coords +# so that when the tick is drawn by a GRDRAW the tick will follow a line of +# constant X or Y in world coordinates, and this line will not necessarily be +# a line of constant X or Y in NDC coordinates. + +real procedure glb_ticklen (gp, ax, ndc_length) + +pointer gp # graphics descriptor +pointer ax # axis descriptor +real ndc_length # length of tick in NDC units + +int wcs +real x, y, wx, wy + +begin + wcs = GP_WCS(gp) + call gctran (gp, AX_TICK1(ax,1), AX_TICK1(ax,2), x, y, wcs, 0) + + if (AX_HORIZONTAL(ax) == YES) + y = y + ndc_length + else + x = x + ndc_length + + call gctran (gp, x, y, wx, wy, 0, wcs) + if (AX_HORIZONTAL(ax) == YES) { + call pargr (wy - AX_TICK1(ax,2)) + return (wy - AX_TICK1(ax,2)) + } else { + call pargr (wx - AX_TICK1(ax,1)) + return (wx - AX_TICK1(ax,1)) + } +end diff --git a/sys/gio/glabax/glbtitle.x b/sys/gio/glabax/glbtitle.x new file mode 100644 index 00000000..d8c43c67 --- /dev/null +++ b/sys/gio/glabax/glbtitle.x @@ -0,0 +1,76 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "glabax.h" + +# GLB_PLOT_TITLE -- Draw plot title block. The block may contain several lines. +# Lines are plotted with center, left, or right justification, immediately +# above the top viewport boundary (not immediately above the drawn axis, +# which need not be at the viewport boundary). + +procedure glb_plot_title (gp, title, ntitlelines) + +pointer gp # graphics descriptor +char title[ARB] # title block +int ntitlelines # number of lines in title block + +int lineno, ip, wcs +real char_height, x, y, dy +pointer sp, op, lbuf, format, w +real ggetr() + +begin + if (title[1] == EOS || ntitlelines < 1) + return + + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + call salloc (format, SZ_FORMAT, TY_CHAR) + + char_height = ggetr (gp, "ch") + if (char_height < EPSILON) + char_height = DEF_CHARHEIGHT * GP_TITLESIZE(gp) + + wcs = GP_WCS(gp) + w = GP_WCSPTR (gp, wcs) + y = min (1.0 - char_height, + WCS_SY2(w) + (ntitlelines - 1 + 0.5) * char_height) + + call sprintf (Memc[format], SZ_FORMAT, "hj=%c,vj=b") + switch (GP_TITLEJUST(gp)) { + case GT_LEFT: + call pargi ('l') + x = WCS_SX1(w) + case GT_RIGHT: + call pargi ('r') + x = WCS_SX2(w) + default: + call pargi ('c') + x = (WCS_SX1(w) + WCS_SX2(w)) / 2.0 + } + + call gsetr (gp, G_TXSIZE, GP_TITLESIZE(gp)) + call gseti (gp, G_WCS, 0) + lineno = 1 + op = lbuf + + for (ip=1; title[ip] != EOS; ip=ip+1) + if (title[ip] == '\n' || (title[ip+1] == EOS && op > lbuf)) { + if (title[ip] != '\n') { + Memc[op] = title[ip] + op = op + 1 + } + Memc[op] = EOS + dy = (lineno - 1) * char_height + call gtext (gp, x, y - dy, Memc[lbuf], Memc[format]) + lineno = lineno + 1 + op = lbuf + } else { + Memc[op] = title[ip] + op = op + 1 + } + + call sfree (sp) +end diff --git a/sys/gio/glabax/glbverify.x b/sys/gio/glabax/glbverify.x new file mode 100644 index 00000000..6666b06a --- /dev/null +++ b/sys/gio/glabax/glbverify.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "glabax.h" + +# GLB_VERIFY_LOG_SCALING -- Verify that log scaling makes sense, i.e., that +# the range covered by an axis compared to its distance from the origin is +# large enough to permit log scaling. If log scaling is reasonable check if +# the window goes negative, and switch to ELOG scaling if such is the case. + +procedure glb_verify_log_scaling (gp) + +pointer gp # graphics descriptor +pointer w + +begin + w = GP_WCSPTR (gp, GP_WCS(gp)) + + # Force ELOG scaling if any data <= 0. + + if (WCS_XTRAN(w) != LINEAR) + if (WCS_WX1(w) <= 0 || WCS_WX2(w) <= 0) + WCS_XTRAN(w) = ELOG + + if (WCS_YTRAN(w) != LINEAR) + if (WCS_WY1(w) <= 0 || WCS_WY2(w) <= 0) + WCS_YTRAN(w) = ELOG + + # Set the WCS state to modified even if it wasn't. This is safe + # and in any case the WCS is changed in the main glabax routine + # shortly after we are called. + + GP_WCSSTATE(gp) = MODIFIED +end diff --git a/sys/gio/glabax/mkpkg b/sys/gio/glabax/mkpkg new file mode 100644 index 00000000..c8990e1a --- /dev/null +++ b/sys/gio/glabax/mkpkg @@ -0,0 +1,22 @@ +# Make the GLABAX axis drawing and labelling package. + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + glabax.x glabax.h + glbencode.x glabax.h + glbfind.x glabax.h + glbgrid.x glabax.h + glbgtick.x glabax.h + glblabel.x glabax.h + glbloglab.x glabax.h + glbsetax.x glabax.h + glbsetup.x + glbsview.x glabax.h + glbticlen.x glabax.h + glbtitle.x glabax.h + glbverify.x glabax.h + ; diff --git a/sys/gio/gline.x b/sys/gio/gline.x new file mode 100644 index 00000000..ee346527 --- /dev/null +++ b/sys/gio/gline.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GLINE -- Draw a line connecting two points. + +procedure gline (gp, x1, y1, x2, y2) + +pointer gp # graphics descriptor +real x1, y1 # first point +real x2, y2 # second point + +begin + call gamove (gp, x1, y1) + call gadraw (gp, x2, y2) +end diff --git a/sys/gio/gmark.x b/sys/gio/gmark.x new file mode 100644 index 00000000..a9517b79 --- /dev/null +++ b/sys/gio/gmark.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GMARK -- Draw a marker of the indicated type and size. A mark is represented +# as a polyline normalized to the unit square. Drawing a mark is a simple +# matter of drawing this normalized polyline in a window the size and position +# of the mark. While the mark window defines the transformation upon the +# normalized marker polyline, clipping is performed on the WCS viewport boundary +# (if enabled), independently of the size and position of the mark. Redrawing +# a mark with a linetype of clear will erase the mark, device permitting. +# Drawing is carried out in world coordinates, hence the marker shape will +# relect logarithmic scaling if in effect. + +procedure gmark (gp, x, y, marktype, xsize, ysize) + +pointer gp # graphics descriptor +real x, y # world coordinates of center of marker +int marktype # type of marker to be drawn +real xsize, ysize # marker size in X and Y + +int i, m, fill +int and() +include "markers.inc" + +begin + # The point marker type cannot be combined with the other types and + # is treated as a special case. The remaining markers are drawn + # using GUMARK, which draws marks represented as polygons + + if (marktype == GM_POINT || (xsize == 0 && ysize == 0)) { + call gpl_settype (gp, POLYMARKER) + call gamove (gp, x, y) + call gadraw (gp, x, y) + call gpl_settype (gp, POLYLINE) + + } else { + # Some marks can be drawn using area fill. + if (and (marktype, GM_FILL) != 0) + fill = YES + else + fill = NO + + # Draw and overlay each mark. The polylines for the standard + # marks are stored in MPX and MPY at offsets MXO and MYO. + + do i = GM_FIRSTMARK, GM_LASTMARK + if (and (marktype, 2 ** i) != 0) { + m = i - GM_FIRSTMARK + 1 + call gumark (gp, mpx[moff[m]], mpy[moff[m]], mnpts[m], + x, y, xsize, ysize, fill) + } + } +end diff --git a/sys/gio/gmftitle.x b/sys/gio/gmftitle.x new file mode 100644 index 00000000..0e7d0322 --- /dev/null +++ b/sys/gio/gmftitle.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GMFTITLE -- Insert a title (comment) into the output metacode instruction +# stream. No graphics output is generated. The purpose of the metafile +# title is to document the contents of metafiles. + +procedure gmftitle (gp, mftitle) + +pointer gp # graphics descriptor +char mftitle[ARB] # metafile title + +begin + call gpl_flush() + call gki_mftitle (GP_FD(gp), mftitle) +end diff --git a/sys/gio/gmprintf.x b/sys/gio/gmprintf.x new file mode 100644 index 00000000..9353b483 --- /dev/null +++ b/sys/gio/gmprintf.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GMPRINTF -- Formatted write a string value to a UI (user interface) +# parameter. +# +# NOTE - I don't think this code works yet. Don't use it, use gmsg. + +procedure gmprintf (gp, object, format) + +pointer gp #I graphics descriptor +char object[ARB] #I object name +char format[ARB] #I print format + +pointer sp, fmt + +begin + call smark (sp) + call salloc (fmt, SZ_LINE, TY_CHAR) + + call sprintf (Memc[fmt], SZ_LINE, "\031%s %s\035\037") + call pargstr (object) + call pargstr (format) + + call flush (STDOUT) + call printf (Memc[fmt]) + call sfree (sp) +end diff --git a/sys/gio/gmsg.x b/sys/gio/gmsg.x new file mode 100644 index 00000000..360996be --- /dev/null +++ b/sys/gio/gmsg.x @@ -0,0 +1,232 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# GMSG -- Write a string value to a UI (user interface) parameter. Another +# way to look at this is that we are sending a message to a UI object, hence +# this is called a message facility. +# +# NOTE -- This routine quotes the string with curly braces { } and prefaces +# the string with a "setValue", as required to set the value of a GUI client +# state variable. This is done here rather than build knowledge into the +# lower level i/o system about the requirements for sending messages to UI +# parameters. The low level i/o system just sends arbitrary messages to +# named UI objects; setting the value of a UI parameter object is a higher +# level abstraction layered upon the general i/o mechanism. +# +# One limitation of the UI parameter mechanism as it currently stands is that +# if the message contains curly braces, they must match up to avoid having +# the message be prematurely delimited (fortunately curly braces tend to +# match up in any valid text that uses them). So far I haven't found a way +# around this. The problem is that while Tcl allows braces to be backslash +# escaped to avoid being treated as delimiters, the backslashes are not +# removed, they are left in the message as data. Hence they cannot be +# inserted in an arbitrary string without changing the string. +# +# Messages may be arbitrarily large and may extend over multiple lines. The +# only restriction is that if the messages contain curly braces they must +# match up. + +procedure gmsg (gp, object, message) + +pointer gp #I graphics descriptor +char object[ARB] #I object name +char message[ARB] #I message text + +int flushnl, control_stream +int fstati() +bool ttygetb() + +begin + call gflush (gp) + call flush (STDOUT) + call flush (STDERR) + + control_stream = STDERR + + if (ttygetb (GP_TTY(gp), "EM")) { + flushnl = fstati (control_stream, F_FLUSHNL) + if (flushnl == YES) + call fseti (control_stream, F_FLUSHNL, NO) + + call putci (control_stream, EM) + call putline (control_stream, object) + call putci (control_stream, ' ') + call putline (control_stream, "setValue ") + + call putci (control_stream, '{') + call putline (control_stream, message) + call putci (control_stream, '}') + + call putci (control_stream, GS) + call putci (control_stream, US) + call flush (control_stream) + + if (flushnl == YES) + call fseti (control_stream, F_FLUSHNL, YES) + } +end + + +# GMSGB -- Set the value of a boolean UI parameter. + +procedure gmsgb (gp, object, value) + +pointer gp #I graphics descriptor +char object[ARB] #I object name +bool value #I value + +begin + if (value) + call gmsg (gp, object, "yes") + else + call gmsg (gp, object, "no") +end + + +# GMSGC -- Set the value of a character UI parameter. + +procedure gmsgc (gp, object, value) + +pointer gp #I graphics descriptor +char object[ARB] #I object name +char value #I value + +char buf[10] +int junk, ctocc() + +begin + junk = ctocc (value, buf, 10) + call gmsg (gp, object, buf) +end + + +# GMSGS -- Set the value of a short integer UI parameter. + +procedure gmsgs (gp, object, value) + +pointer gp #I graphics descriptor +char object[ARB] #I object name +short value #I value + +long val +char buf[32] +int junk, ltoc() + +begin + if (IS_INDEFS (value)) + call gmsg (gp, object, "INDEF") + else { + val = value + junk = ltoc (val, buf, 32) + call gmsg (gp, object, buf) + } +end + + +# GMSGI -- Set the value of an integer UI parameter. + +procedure gmsgi (gp, object, value) + +pointer gp #I graphics descriptor +char object[ARB] #I object name +int value #I value + +long val +char buf[32] +int junk, ltoc() + +begin + if (IS_INDEFI (value)) + call gmsg (gp, object, "INDEF") + else { + val = value + junk = ltoc (val, buf, 32) + call gmsg (gp, object, buf) + } +end + + +# GMSGL -- Set the value of a long integer UI parameter. + +procedure gmsgl (gp, object, value) + +pointer gp #I graphics descriptor +char object[ARB] #I object name +long value #I value + +char buf[32] +int junk, ltoc() + +begin + if (IS_INDEFL (value)) + call gmsg (gp, object, "INDEF") + else { + junk = ltoc (value, buf, 32) + call gmsg (gp, object, buf) + } +end + + +# GMSGR -- Set the value of a type real UI parameter. + +procedure gmsgr (gp, object, value) + +pointer gp #I graphics descriptor +char object[ARB] #I object name +real value #I value + +double dval +char buf[MAX_DIGITS] +int junk, dtoc() + +begin + if (IS_INDEFR (value)) + call gmsg (gp, object, "INDEF") + else { + dval = value + junk = dtoc (dval, buf, MAX_DIGITS, NDIGITS_RP, 'g', MAX_DIGITS) + call gmsg (gp, object, buf) + } +end + + +# GMSGD -- Set the value of a type double UI parameter. + +procedure gmsgd (gp, object, value) + +pointer gp #I graphics descriptor +char object[ARB] #I object name +double value #I value + +char buf[MAX_DIGITS] +int junk, dtoc() + +begin + if (IS_INDEFR (value)) + call gmsg (gp, object, "INDEF") + else { + junk = dtoc (value, buf, MAX_DIGITS, NDIGITS_DP, 'g', MAX_DIGITS) + call gmsg (gp, object, buf) + } +end + + +# GMSGX -- Set the value of a type complex UI parameter. + +procedure gmsgx (gp, object, value) + +pointer gp #I graphics descriptor +char object[ARB] #I object name +complex value #I value + +char buf[MAX_DIGITS] +int junk, xtoc() + +begin + junk = xtoc (value, buf, MAX_DIGITS, NDIGITS_RP, 'g', MAX_DIGITS/2) + call gmsg (gp, object, buf) +end diff --git a/sys/gio/gopen.x b/sys/gio/gopen.x new file mode 100644 index 00000000..7f973016 --- /dev/null +++ b/sys/gio/gopen.x @@ -0,0 +1,187 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include + +# GOPENUI -- Open a graphics stream for output to the named device on file FD. +# If a logical device name is given the actual device name is fetched from the +# environment. If a UI file is specified the named user interface definition +# file is downloaded to the graphics server. The device parameters are then +# retrieved from the graphcap entry for the device. GIO is initialized, and +# if the device is being opened in APPEND mode, the WCS set when the device +# was last read are retrieved from the CL (if output is to a standard stream) +# or from the WCS savefile for the device. + +pointer procedure gopenui (device, mode, uifname, fd) + +char device[ARB] #I logical or physical device name +int mode #I access mode: NEW_FILE or APPEND +char uifname[ARB] #I user interface specification file +int fd #I metacode output file + +pointer gp, tty +int outfd, stream_type, junk +bool close_at_end, kf_ok, vdm_device, std_stream +pointer sp, devname, envname, kfname + +bool streq() +extern gflush() +pointer ttygdes() +int envgets(), envfind(), open(), locpr(), access(), ttygets() +errchk syserr, syserrs, ttygdes +errchk greset, gki_openws, calloc + +string stdgraph "stdgraph" +string stdimage "stdimage" +string stdplot "stdplot" +string vdm "vdm" +string stdvdm "stdvdm" + +begin + call smark (sp) + call salloc (devname, SZ_FNAME, TY_CHAR) + call salloc (envname, SZ_FNAME, TY_CHAR) + call salloc (kfname, SZ_FNAME, TY_CHAR) + + call flush (STDOUT) + + # If one of the logical devices STDGRAPH, STDIMAGE, or STDPLOT is + # named look up the actual device name in the environment. The + # standard metafile "device", STDVDM, is implemented as an actual + # device with an actual graphcap entry, so we do not have to map + # its name. + + if (streq (device, stdgraph) || streq (device, stdimage) || + streq (device, stdplot)) { + if (envgets (device, Memc[devname], SZ_FNAME) <= 0) + call syserrs (SYS_ENVNF, device) + } else + call strcpy (device, Memc[devname], SZ_FNAME) + + # The special name "none" indicates that graphics is not supported + # on this stream for the local site or workstation (e.g., when using + # a nongraphics terminal). + + if (streq (Memc[devname], "none")) + switch (fd) { + case STDGRAPH: + call syserr (SYS_GGNONE) + case STDIMAGE: + call syserr (SYS_GINONE) + case STDPLOT: + call syserr (SYS_GPNONE) + default: + call syserr (SYS_GPNONE) + } + + # Fetch the graphcap entry for the device. + tty = ttygdes (Memc[devname]) + + # If the output device is "stdvdm" or "vdm" and the FD supplied by the + # user is that of a standard stream, open the standard metafile and + # append output directly to that. The metafile is always opened in + # APPEND mode regardless of the mode in which the graphics device is + # opened. + + outfd = fd + close_at_end = false + call gki_redir (fd, -1, junk, stream_type) + std_stream = (fd == STDGRAPH || fd == STDIMAGE || fd == STDPLOT) + vdm_device = (streq(device,stdvdm) || streq(device,vdm)) + + if (vdm_device && std_stream) { + # Get filename of virtual device metafile. + call strcpy (stdvdm, Memc[devname], SZ_DEVNAME) + if (envfind (stdvdm, Memc[envname], SZ_FNAME) <= 0) + call strcpy ("uparm$vdm", Memc[envname], SZ_FNAME) + + # Open VDM for appending. + iferr (outfd = open (Memc[envname], APPEND, BINARY_FILE)) { + call ttycdes (tty) + call erract (EA_ERROR) + } + close_at_end = true + + } else if (std_stream && stream_type != TY_INLINE) { + # Verify that there is a GIO kernel specified for the device before + # trying to open it via PSIOCTRL, since the latter does not return + # an error status if it fails to connect a kernel, causing the error + # to go undetected until the CL fails to connect a kernel, which + # causes an error which cannot be caught in an IFERR in the current + # process. Catching the error here is faster and works with IFERR. + # No checking for a kernel is performed if the metacode output is + # being directed to a user opened stream. + + kf_ok = false + if (ttygets (tty, "kf", Memc[kfname], SZ_FNAME) > 0) + if (streq (Memc[kfname], "cl")) + kf_ok = true + else if (access (Memc[kfname], 0,0) == YES) + kf_ok = true + + if (!kf_ok) { + call ttycdes (tty) + call syserrs (SYS_GNOKF, Memc[devname]) + } + } + + # Allocate and initialize the GIO graphics descriptor. Initialize + # GKI (the graphics kernel interface) on the stream, if the stream + # has not already been directed to a kernel. + + call calloc (gp, LEN_GDES, TY_STRUCT) + + GP_FD(gp) = outfd + GP_TTY(gp) = tty + if (close_at_end) + GP_GFLAGS(gp) = GF_CLOSEFD + + # Set the access mode; default to NEW_FILE if not specified. + GP_ACMODE(gp) = mod (mode, AW_DEFER) + if (GP_ACMODE(gp) == 0) + GP_ACMODE(gp) = NEW_FILE + + call greset (gp, GR_RESETALL) + call gki_init (outfd) + call strcpy (Memc[devname], GP_DEVNAME(gp), SZ_DEVNAME) + call strcpy (uifname, GP_UIFNAME(gp), SZ_UIFNAME) + + # Set up info for GEXFLS, called by CLGCUR to flush the graphics + # output prior to a cursor read. + + call gexfls_set (outfd, gp, locpr(gflush)) + + # Activate (physically open) the workstation, unless the defer flag + # is set, eg., mode = NEW_FILE+AW_DEFER. + + if (mode < AW_DEFER) + iferr (call gactivate (gp, 0)) { + call ttycdes (tty) + call gexfls_clear (outfd) + call mfree (gp, TY_STRUCT) + call erract (EA_ERROR) + } + + call sfree (sp) + return (gp) +end + + +# GOPEN -- Open a graphics stream for output to the named device on file FD. +# Identical to GOPENUI except that the default UI is used. + +pointer procedure gopen (device, mode, fd) + +char device[ARB] #I logical or physical device name +int mode #I access mode: NEW_FILE or APPEND +int fd #I metacode output file + +pointer gopenui() + +begin + return (gopenui (device, mode, "", fd)) +end diff --git a/sys/gio/gpagefile.x b/sys/gio/gpagefile.x new file mode 100644 index 00000000..df950e71 --- /dev/null +++ b/sys/gio/gpagefile.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GPAGEFILE -- File pager which works in or out of cursor mode. If in graphics +# mode, the workstation is deactivated, the file paged, and graphics mode later +# restored. + +procedure gpagefile (gp, fname, prompt) + +pointer gp # graphics descriptor +char fname[ARB] # name of file to be paged +char prompt[ARB] # user prompt string + +bool wsactive +int and() + +begin + wsactive = (and (GP_GFLAGS(gp), GF_WSACTIVE) != 0) + + if (wsactive) + call gdeactivate (gp, 0) + iferr (call pagefile (fname, prompt)) + call erract (EA_WARN) + if (wsactive) + call greactivate (gp, AW_PAUSE) +end diff --git a/sys/gio/gpcell.x b/sys/gio/gpcell.x new file mode 100644 index 00000000..17588647 --- /dev/null +++ b/sys/gio/gpcell.x @@ -0,0 +1,77 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GPCELL -- Put a cell array. Display a two dimensional array of pixels in the +# given window, scaling as necessary to fit the window. For maximum efficiency +# no clipping is performed. Only linear coordinate transformations are +# permitted. The cell array is defined by (x1,y1) and (x2,y2), the NDC coords +# of the corners of the display area. The graphics kernel is expected to +# map cell array pixels into device pixels by mapping the coordinates of a +# device pixel into the cell array and assigning the value of the nearest +# cell array pixel to the device pixel. In other words, the cell array is +# sampled or block replicated as necessary to fit the device window. The kernel +# is not expected to perform area integration or filtering (interpolation) +# to map cell array pixels into device pixels. In the limiting case M may +# contain a single pixel which will be replicated to fill the specified window, +# e.g., nx=ny=1, (x1,y1)=(0,0), and (x2,y2)=(1,1). +# +# +--+--+--+--Q (x2,y2) +# 4 | | | | | +# +--+--+--+--+ +# 3 | | | | | Sample Cell Array +# Y +--+--+--+--+ nx = ny = 4 +# 2 | | | | | +# +--+--+--+--+ +# 1 | | | | | +# (x1,y1) P--+--+--+--+ +# +# 1 2 3 4 X +# +# A sample 4 by 4 cell array is shown above. The coordinates of the device +# window into which the cell array is to be mapped refer to the corners P and +# Q of the first and last pixels in the cell array. + +procedure gpcell (gp, m, nx, ny, x1, y1, x2, y2) + +pointer gp # device descriptor +short m[nx,ny] # pixels +int nx, ny # size of pixel array +real x1, y1 # lower left corner of output window +real x2, y2 # upper right corner of output window + +real dy +int ly1, ly2, i +int sx1, sx2, sy1, sy2 +include "gpl.com" + +begin + # Flush any buffered polyline output. Make sure the wcs transformation + # in the cache is up to date. + + if (op > 1) + call gpl_flush() + else if (gp != gp_out || GP_WCS(gp) != wcs) + call gpl_cache (gp) + + # Transform cell window to GKI coordinates. The coordinate + # transformation must be linear. + + sx1 = (x1 - wxorigin) * xscale + mxorigin + sx2 = (x2 - wxorigin) * xscale + mxorigin + sy1 = (y1 - wyorigin) * yscale + myorigin + sy2 = (y2 - wyorigin) * yscale + myorigin + + dy = real (sy2 - sy1) / ny # height of a line in GKI coords + + # Write out the cell array, one line at a time. Take care that the + # GKI integer value of ly1 of one line is the same as the ly2 value + # of the previous line, or there will be a blank line in the output + # image. + + do i = 1, ny { + ly1 = (i-1) * dy + sy1 + ly2 = (i ) * dy + sy1 + call gki_putcellarray (GP_FD(gp), m[1,i], nx,1, sx1,ly1, sx2,ly2) + } +end diff --git a/sys/gio/gpl.com b/sys/gio/gpl.com new file mode 100644 index 00000000..76d0d5c7 --- /dev/null +++ b/sys/gio/gpl.com @@ -0,0 +1,20 @@ +# GPL.COM -- Polyline generator common. + +bool last_point_inbounds # last point was inbounds +int xtran, ytran # scaling function for X, Y axes (linear,log,,) +int op # index of next cell in polyline array +int pl_type # type of instruction (polyline, polymarker,...) +int pl_pointmode # plotting points (polymarker), not vectors +int wcs # WCS for which cache is valid +long mxorigin, myorigin # origin in world coordinates for transform +real wxorigin, wyorigin # origin in world coordinates for transform +real xscale, yscale # scale factor, world to GKI, for transform +real cx, cy # current pen position, world coords +long mx1, mx2, my1, my2 # clipping viewport, GKI coords +long xs[4], ys[4] # last point plotted (for clipping code) +pointer gp_out # device which owns current polyline +short pl[LEN_PLBUF] # output polyline buffer + +common /gplcom/ last_point_inbounds, xtran, ytran, op, pl_type, pl_pointmode, + mxorigin, myorigin, wxorigin, wyorigin, xscale, yscale, cx, cy, + mx1, mx2, my1, my2, xs, ys, gp_out, wcs, pl diff --git a/sys/gio/gplcache.x b/sys/gio/gplcache.x new file mode 100644 index 00000000..88201365 --- /dev/null +++ b/sys/gio/gplcache.x @@ -0,0 +1,101 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GPL_CACHE -- Cache the transformation parameters for a device in the GADRAW +# common. Must be called whenever the current WCS changes. We need only +# check that the WCS has not changed because anything more serious than a +# change current WCS call will cause the cache to be invalidated. + +procedure gpl_cache (gp) + +pointer gp # graphics descriptor +pointer w +real wx1, wx2, wy1, wy2 +bool fp_nondegenr() +real elogr() + +int wcsord +data wcsord /0/ +include "gpl.com" + +begin + gp_out = gp + wcs = GP_WCS(gp) + w = GP_WCSPTR (gp, wcs) + + # The WCS must be fixed to the output device (kernel) when used for + # coordinate transformations in metacode output. + + if (GP_WCSSTATE(gp) != FIXED) { + call gactivate (gp, 0) + call gpl_flush() + call gki_setwcs (GP_FD(gp), Memi[GP_WCSPTR(gp,1)], + LEN_WCS * MAX_WCS) + GP_WCSSTATE(gp) = FIXED + wcsord = wcsord + 1 + GP_WCSORD(gp) = wcsord + } + + mx1 = WCS_SX1(w) * GKI_MAXNDC + mx2 = WCS_SX2(w) * GKI_MAXNDC + my1 = WCS_SY1(w) * GKI_MAXNDC + my2 = WCS_SY2(w) * GKI_MAXNDC + + # Compute world -> GKI coordinate transformation. If log scaling is + # indicated but one or both window coords are negative, use ELOG + # scaling instead. + + mxorigin = mx1 + xtran = WCS_XTRAN(w) + + wx1 = WCS_WX1(w) + wx2 = WCS_WX2(w) + + # Ensure that the window is nondegenerate. + if (fp_nondegenr (wx1, wx2)) + ; + + if (xtran == LINEAR) { + wxorigin = wx1 + xscale = (mx2 - mx1) / (wx2 - wx1) + } else if (xtran == LOG && wx1 > 0 && wx2 > 0) { + wxorigin = log10 (wx1) + xscale = (mx2 - mx1) / (log10(wx2) - wxorigin) + } else { + wxorigin = elogr (wx1) + xscale = (mx2 - mx1) / (elogr(wx2) - wxorigin) + } + + myorigin = my1 + ytran = WCS_YTRAN(w) + + wy1 = WCS_WY1(w) + wy2 = WCS_WY2(w) + + # Ensure that the window is nondegenerate. + if (fp_nondegenr (wy1, wy2)) + ; + + if (ytran == LINEAR) { + wyorigin = wy1 + yscale = (my2 - my1) / (wy2 - wy1) + } else if (ytran == LOG && wy1 > 0 && wy2 > 0) { + wyorigin = log10 (wy1) + yscale = (my2 - my1) / (log10(wy2) - wyorigin) + } else { + wyorigin = elogr (wy1) + yscale = (my2 - my1) / (elogr(wy2) - wyorigin) + } + + # If clipping is disabled move the clipping viewport out to the + # boundary of the device. + + if (and (WCS_FLAGS(w), WF_CLIP) == 0) { + mx1 = 0 + mx2 = GKI_MAXNDC + my1 = 0 + my2 = GKI_MAXNDC + } +end diff --git a/sys/gio/gplcancel.x b/sys/gio/gplcancel.x new file mode 100644 index 00000000..416bd787 --- /dev/null +++ b/sys/gio/gplcancel.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GPL_CANCEL -- Cancel any buffered polyline output. + +procedure gpl_cancel() + +include "gpl.com" + +begin + op = 1 +end diff --git a/sys/gio/gplflush.x b/sys/gio/gplflush.x new file mode 100644 index 00000000..403adc9c --- /dev/null +++ b/sys/gio/gplflush.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GPL_FLUSH -- Flush the buffered "polyline", i.e., array of transformed and +# clipped points. For a polyline or fill area polygon there must be at least +# two points (4 cells) or it will be discarded. A single point polymarker is +# permitted. + +procedure gpl_flush() + +int fd +pointer ap +include "gpl.com" + +begin + if (op > 2 && gp_out != NULL) { + fd = GP_FD(gp_out) + + switch (pl_type) { + case POLYMARKER: + ap = GP_PMAP(gp_out) + if (PM_STATE(ap) != FIXED) { + call gki_pmset (fd, ap) + PM_STATE(ap) = FIXED + } + call gki_polymarker (fd, pl, op / 2) + + case FILLAREA: + ap = GP_FAAP(gp_out) + if (FA_STATE(ap) != FIXED) { + call gki_faset (fd, ap) + FA_STATE(ap) = FIXED + } + if (op > 4) + call gki_fillarea (fd, pl, op / 2) + + default: # (case POLYLINE) + ap = GP_PLAP(gp_out) + if (PL_STATE(ap) != FIXED) { + call gki_plset (fd, ap) + PL_STATE(ap) = FIXED + } + if (op > 4) + call gki_polyline (fd, pl, op / 2) + } + + op = 1 + } +end diff --git a/sys/gio/gpline.x b/sys/gio/gpline.x new file mode 100644 index 00000000..ed0e8439 --- /dev/null +++ b/sys/gio/gpline.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GPLINE -- Polyline. Draw a line connecting the points (X[i],Y[i]), i.e., +# move to the first point and draw a straight line from there to the second +# point, from the second to the third, and so on. + +procedure gpline (gp, x, y, npts) + +pointer gp # graphics descriptor +real x[ARB], y[ARB] # points defining the polyline +int npts +int i + +begin + call gamove (gp, x[1], y[1]) + do i = 2, npts + call gadraw (gp, x[i], y[i]) +end diff --git a/sys/gio/gploto.x b/sys/gio/gploto.x new file mode 100644 index 00000000..a76de4fd --- /dev/null +++ b/sys/gio/gploto.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GPLOTV -- Plot a vector on an open graphics device. This routine is +# provided for the convenience of the user who does not need to exercise +# fine control over the details of how the plot is generated, but who may +# wish to select an output device other than stdgraph or who may wish to +# leave the device open for annotation. + +procedure gploto (gp, v, npts, x1, x2, title) + +pointer gp # graphics descriptor +real v[ARB] # data vector +int npts # number of data points +real x1, x2 # range of X in data vector +char title[ARB] # plot title +errchk gswind, gascale, glabax + +begin + call gswind (gp, x1, x2, INDEF, INDEF) + call gascale (gp, v, npts, 2) + call glabax (gp, title, "", "") + call gvline (gp, v, npts, x1, x2) +end diff --git a/sys/gio/gplotv.x b/sys/gio/gplotv.x new file mode 100644 index 00000000..1d9239e5 --- /dev/null +++ b/sys/gio/gplotv.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GPLOTV -- Plot a vector. This routine is provided for the convenience of +# the user who does not need to exercise fine control over the details of +# how the plot is generated. + +procedure gplotv (v, npts, x1, x2, title) + +real v[ARB] # data vector +int npts # number of data points +real x1, x2 # range of X in data vector +char title[ARB] # plot title + +pointer gp +pointer gopen() +errchk gopen, gploto + +begin + gp = gopen ("stdgraph", NEW_FILE, STDGRAPH) + call gploto (gp, v, npts, x1, x2, title) + call gclose (gp) +end diff --git a/sys/gio/gplreset.x b/sys/gio/gplreset.x new file mode 100644 index 00000000..888fd99e --- /dev/null +++ b/sys/gio/gplreset.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GPL_RESET -- Reset the state of the GPL common, forcing a call to +# re-initialize the cache in the next GADRAW call. Should be called at +# GOPEN time and thereafter whenever the a WCS is modified or an polyline, +# polymarker, etc. attribute is set. + +procedure gpl_reset() + +bool first_time +include "gpl.com" +data first_time /true/ + +begin + if (first_time) { + op = 1 + first_time = false + } else + call gpl_flush() + + wcs = -1 + gp_out = NULL + pl_type = POLYLINE + last_point_inbounds = false +end diff --git a/sys/gio/gplstype.x b/sys/gio/gplstype.x new file mode 100644 index 00000000..68056abd --- /dev/null +++ b/sys/gio/gplstype.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GPL_SETTYPE -- Set type (polyline, polymarker, fillarea) of point array PL. +# Determines instruction type generated when PL is flushed. + +procedure gpl_settype (gp, type) + +pointer gp # graphics descriptor +int type # type of instruction +include "gpl.com" + +begin + if (op > 1 && pl_type != type) + call gpl_flush() + + if (type == POINTMODE) { + pl_type = POLYMARKER + pl_pointmode = YES + } else { + pl_type = type + pl_pointmode = NO + } +end diff --git a/sys/gio/gpmark.x b/sys/gio/gpmark.x new file mode 100644 index 00000000..dbe0b362 --- /dev/null +++ b/sys/gio/gpmark.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GPMARK -- Polymarker. Output at sequence of markers at the vertices of a +# polygon, all markers the same type and size. The marker type GM_POINT is +# a special case. + +procedure gpmark (gp, x, y, npts, marktype, xsize, ysize) + +pointer gp # graphics descriptor +real x[ARB], y[ARB] # vertices of polygon +int npts # number of points +int marktype # marker type +real xsize, ysize # marker size +int i + +begin + if (marktype == GM_POINT) { + call gpl_settype (gp, POINTMODE) + call gpline (gp, x, y, npts) + call gpl_settype (gp, POLYLINE) + } else { + do i = 1, npts + call gmark (gp, x[i], y[i], marktype, xsize, ysize) + } +end diff --git a/sys/gio/gqverify.x b/sys/gio/gqverify.x new file mode 100644 index 00000000..7f081f3b --- /dev/null +++ b/sys/gio/gqverify.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +define QUERY "Type `q' to verify quit, `return' to return to cursor loop:" + +# GQVERIFY -- Print a message in the status line asking the user if they really +# want to quit, returning YES if they really want to quit, NO otherwise. + +int procedure gqverify() + +int ch +int getci() + +begin + call printf (QUERY) + call flush (STDOUT) + + call fseti (STDIN, F_RAW, YES) + while (getci (STDIN, ch) != EOF) + if (ch == 'q' || ch == '\r' || ch == '\n') + break + + call printf ("\n\n") + call flush (STDOUT) + call fseti (STDIN, F_RAW, NO) + + if (ch == 'q') + return (YES) + else + return (NO) +end diff --git a/sys/gio/grdraw.x b/sys/gio/grdraw.x new file mode 100644 index 00000000..7cd44a74 --- /dev/null +++ b/sys/gio/grdraw.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GRDRAW -- Relative draw, i.e., move the pen to the specified offset from the +# current position. + +procedure grdraw (gp, x, y) + +pointer gp # graphics descriptor +real x, y # offset from current position +real cx, cy + +begin + if (IS_INDEF(x) || IS_INDEF(y)) + call gadraw (gp, x, y) + else { + call gcurpos (gp, cx, cy) + if (IS_INDEF(cx) || IS_INDEF(cy)) + call gadraw (gp, INDEF, INDEF) + else + call gadraw (gp, cx + x, cy + y) + } +end diff --git a/sys/gio/grdwcs.x b/sys/gio/grdwcs.x new file mode 100644 index 00000000..3ded4e9e --- /dev/null +++ b/sys/gio/grdwcs.x @@ -0,0 +1,106 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help savewcs +.nf __________________________________________________________________________ +SAVEWCS -- A package for saving the WCS in a file for later restoration when +a device is opened in append mode. + + gwrwcs (devname, wcs, len_wcs) save wcs in file + len = grdwcs (devname, wcs, len_wcs) read wcs from file + +Only the 16+1 WCS structures are currently saved. There is no provision for +saving the WCSSTATE and the index of the current WCS. +.endhelp _____________________________________________________________________ + + +# GWRWCS -- Save the WCS in a binary file in the user directory UPARM. +# Any existing file is overwritten. + +procedure gwrwcs (devname, wcs, len_wcs) + +char devname[ARB] # device name +int wcs[ARB] # array to be saved +int len_wcs + +pointer sp, fname +int fd +int open() +errchk open, write + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + call gwcs_mkfilename (devname, Memc[fname], SZ_FNAME) + iferr (call delete (Memc[fname])) + ; + fd = open (Memc[fname], NEW_FILE, BINARY_FILE) + call write (fd, wcs, len_wcs * SZ_INT) + call close (fd) + + call sfree (sp) +end + + +# GRDWCS -- Read the WCS from a binary file in the user directory UPARM. +# The actual number of size int elements read is returned as the function +# value. It is not an error if there is no file or the file cannot be read. + +int procedure grdwcs (devname, wcs, len_wcs) + +char devname[ARB] # device name +int wcs[ARB] # array to be returned +int len_wcs # max ints to read + +pointer sp, fname +int fd, nchars +int open(), read() +errchk read + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + call gwcs_mkfilename (devname, Memc[fname], SZ_FNAME) + iferr (fd = open (Memc[fname], READ_ONLY, BINARY_FILE)) + nchars = 0 + else { + nchars = read (fd, wcs, len_wcs * SZ_INT) + call close (fd) + } + + call sfree (sp) + return (nchars / SZ_INT) +end + + +# GWCS_MKFILENAME -- Make the filename of the WCS savefile for the named +# device. The filename is "uparm$fname.gd", where the "fname" is the +# device name with any illegal filename characters deleted. The mapping +# is not necessarily unique. + +procedure gwcs_mkfilename (devname, fname, maxch) + +char devname[ARB] # device name +char fname[ARB] # generated filename (output) +int maxch + +int ip, op, ch +int gstrcpy() + +begin + # Leave OP pointing to last char output. + op = gstrcpy ("uparm$", fname, maxch) + + for (ip=1; devname[ip] != EOS; ip=ip+1) { + ch = devname[ip] + if (IS_ALNUM(ch) || ch == '.' || ch == '_') { + op = min (maxch, op + 1) + fname[op] = ch + } + } + + fname[op+1] = EOS +end diff --git a/sys/gio/greact.x b/sys/gio/greact.x new file mode 100644 index 00000000..e201d543 --- /dev/null +++ b/sys/gio/greact.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GREACTIVATE -- Reactivate the workstation, i.e., for an interactive device +# (graphics terminal) restore the terminal to graphics mode, following a call +# to gdeactivate to do some normal terminal mode text i/o. + +procedure greactivate (gp, flags) + +pointer gp # graphics descriptor +int flags # action flags + +int and() +errchk gki_reactivatews, gactivate + +begin + call flush (STDOUT) + if (and (GP_GFLAGS(gp), GF_WSOPEN) != 0) { + # The workstation is already open - just reactivate it. + call gki_reactivatews (GP_FD(gp), flags) + if (and (GP_GFLAGS(gp), GF_WSACTIVE) == 0) + GP_GFLAGS(gp) = GP_GFLAGS(gp) + GF_WSACTIVE + } else { + # Open the workstation (implies an automatic reactivatews). + call gactivate (gp, flags) + } + + if (and (flags, AW_CLEAR) != 0) + call gfrinit (gp) +end diff --git a/sys/gio/greset.x b/sys/gio/greset.x new file mode 100644 index 00000000..1002e2b9 --- /dev/null +++ b/sys/gio/greset.x @@ -0,0 +1,238 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GRESET -- Initialize the internal state variables of GIO to their default +# values. Called upon startup and by GCANCEL and GCLEAR. + +procedure greset (gp, flags) + +pointer gp #I graphics descriptor +int flags #I flags indicating what to reset + +int color, ch, i +real char_height, aspect +bool reset_wcs, reset_gio, reset_glabax +pointer sp, glbcolor, param, w, ap, ax, ax1, ax2, ip, op + +bool streq() +real ggetr() +int envfind(), ctoi(), strncmp() +define next_ 91 +errchk ggetr + +begin + call smark (sp) + call salloc (glbcolor, SZ_LINE, TY_CHAR) + call salloc (param, SZ_FNAME, TY_CHAR) + + # Initialize for a new frame; this is always done. + call gfrinit (gp) + + reset_glabax = (and (flags, GR_RESETGLABAX) != 0) + reset_wcs = (and (flags, GR_RESETWCS) != 0) + reset_gio = (and (flags, GR_RESETGIO) != 0) + + # Reset general GIO device and drawing parameters? + if (reset_gio) { + GP_CURSOR(gp) = 1 + + # All default sizes in NDC units are scaled to the height of a + # device character. + + char_height = ggetr (gp, "ch") + if (char_height < EPSILON) + char_height = DEF_CHARHEIGHT + aspect = ggetr (gp, "ar") + if (aspect < EPSILON) + aspect = 1.0 + GP_DEVASPECT(gp) = aspect + + # Set default marker sizes. + do i = 1, 4 + GP_SZMARKER(gp,i) = (char_height * i) / 4.0 + + # Set polyline attributes. + ap = GP_PLAP(gp) + PL_LTYPE(ap) = 1 + PL_WIDTH(ap) = 1.0 + PL_COLOR(ap) = 1 + + # Set polymarker attributes. + ap = GP_PMAP(gp) + PM_LTYPE(ap) = 1 + PM_WIDTH(ap) = 1.0 + PM_COLOR(ap) = 1 + + # Set fill area attributes. + ap = GP_FAAP(gp) + FA_STYLE(ap) = 1 + FA_COLOR(ap) = 1 + + # Set default text attributes. + ap = GP_TXAP(gp) + TX_UP(ap) = 90 + TX_SIZE(ap) = 1.0 + TX_PATH(ap) = GT_RIGHT + TX_SPACING(ap) = 0.0 + TX_HJUSTIFY(ap) = GT_LEFT + TX_VJUSTIFY(ap) = GT_DOWN + TX_FONT(ap) = GT_ROMAN + TX_QUALITY(ap) = GT_NORMAL + TX_COLOR(ap) = 1 + } + + # Reset GLABAX parameters? + if (reset_glabax) { + # Set general GLABAX parameters. + GP_DRAWTITLE(gp) = YES + GP_TITLESIZE(gp) = 1.0 + GP_TITLECOLOR(gp) = 1 + GP_TITLEJUST(gp) = GT_CENTER + GP_NTITLELINES(gp) = 0 + GP_FRAMECOLOR(gp) = 0 + GP_FRAMEDRAWN(gp) = 0 + + # Set GLABAX parameters for the X and Y axes. + do i = 1, 2 { + if (i == 1) + ax = GP_XAP(gp) + else + ax = GP_YAP(gp) + + GL_DRAWAXES(ax) = 3 + GL_SETAXISPOS(ax) = NO + GL_AXISPOS1(ax) = 0.0 + GL_AXISPOS2(ax) = 0.0 + GL_DRAWGRID(ax) = NO + GL_GRIDCOLOR(ax) = 1 + GL_ROUND(ax) = NO + GL_LABELAXIS(ax) = YES + GL_AXISLABELSIZE(ax) = 1.0 + GL_AXISLABELCOLOR(ax) = 1 + GL_DRAWTICKS(ax) = YES + GL_LABELTICKS(ax) = YES + GL_NMAJOR(ax) = 6 + GL_NMINOR(ax) = 4 + GL_MAJORLENGTH(ax) = 0.6 * char_height + GL_MINORLENGTH(ax) = 0.3 * char_height + GL_MAJORWIDTH(ax) = 2.0 + GL_MINORWIDTH(ax) = 2.0 + GL_AXISWIDTH(ax) = 2.0 + GL_AXISCOLOR(ax) = 1 + GL_TICKLABELSIZE(ax) = 1.0 + GL_TICKLABELCOLOR(ax) = 1 + GL_TICKCOLOR(ax) = 1 + GL_TICKFORMAT(ax) = EOS + } + + # Correct the default tick length for the aspect ratio. + ax = GP_XAP(gp) + GL_MAJORLENGTH(ax) = GL_MAJORLENGTH(ax) / aspect + GL_MINORLENGTH(ax) = GL_MINORLENGTH(ax) / aspect + + # Set user color defaults if specified. This is a simple string + # parameter of the form "pt=i,fr=i,ax=i,..." where I is the color + # index. The actual color corresponding to this index is defined + # externally, e.g. by the graphics server. + + if (envfind ("glbcolor", Memc[glbcolor], SZ_LINE) > 0) { + ax1 = GP_XAP(gp) + ax2 = GP_YAP(gp) + + for (ip=glbcolor; Memc[ip] != EOS; ) { + # Get color parameter code. + for (op=param; Memc[ip] != EOS && + Memc[ip] != '=' && Memc[ip] != ':'; ip=ip+1) { + Memc[op] = Memc[ip] + op = op + 1 + } + Memc[op] = EOS + ch = Memc[param+2] + + # Get color index. + if (Memc[ip] == '=' || Memc[ip] == ':') + ip = ip + 1 + if (ctoi (Memc, ip, color) <= 0) + goto next_ + + # Set parameter. The two character parameter name may + # have an "x" or "y" appended to set only one axis. For + # example, "pt=4,fr=3,ax=1,tk=1,al=5,tl=6". The color + # parameter code names are as follows: + # + # pt plot title + # fr viewport frame + # gr[xy] grid between tick marks + # ax[xy] axis + # al[xy] axis label + # tk[xy] tick + # tl[xy] tick label + # + # The color codes are simple integers corresponding to + # graphics device color codes, e.g. 0, 1, 2, and so on. + + if (streq (Memc[param], "pt")) { + GP_TITLECOLOR(gp) = color + } else if (streq (Memc[param], "fr")) { + GP_FRAMECOLOR(gp) = color + } else if (strncmp (Memc[param], "gr", 2) == 0) { + if (ch == EOS || ch == 'x') + GL_GRIDCOLOR(ax1) = color + if (ch == EOS || ch == 'y') + GL_GRIDCOLOR(ax2) = color + } else if (strncmp (Memc[param], "ax", 2) == 0) { + if (ch == EOS || ch == 'x') + GL_AXISCOLOR(ax1) = color + if (ch == EOS || ch == 'y') + GL_AXISCOLOR(ax2) = color + } else if (strncmp (Memc[param], "al", 2) == 0) { + if (ch == EOS || ch == 'x') + GL_AXISLABELCOLOR(ax1) = color + if (ch == EOS || ch == 'y') + GL_AXISLABELCOLOR(ax2) = color + } else if (strncmp (Memc[param], "tk", 2) == 0) { + if (ch == EOS || ch == 'x') + GL_TICKCOLOR(ax1) = color + if (ch == EOS || ch == 'y') + GL_TICKCOLOR(ax2) = color + } else if (strncmp (Memc[param], "tl", 2) == 0) { + if (ch == EOS || ch == 'x') + GL_TICKLABELCOLOR(ax1) = color + if (ch == EOS || ch == 'y') + GL_TICKLABELCOLOR(ax2) = color + } +next_ + while (Memc[ip] != EOS && Memc[ip] != ',') + ip = ip + 1 + if (Memc[ip] == ',') + ip = ip + 1 + } + } + } + + # Reset the WCS? + if (reset_wcs) { + GP_WCS(gp) = 1 + + # Initialize the WCS to NDC coordinates. + do i = 0, MAX_WCS { + w = GP_WCSPTR(gp,i) + WCS_WX1(w) = 0.0 + WCS_WX2(w) = 1.0 + WCS_WY1(w) = 0.0 + WCS_WY2(w) = 1.0 + WCS_SX1(w) = 0.0 + WCS_SX2(w) = 1.0 + WCS_SY1(w) = 0.0 + WCS_SY2(w) = 1.0 + WCS_XTRAN(w) = LINEAR + WCS_YTRAN(w) = LINEAR + WCS_FLAGS(w) = WF_NEWFORMAT+WF_CLIP + } + } + + call sfree (sp) +end diff --git a/sys/gio/grmove.x b/sys/gio/grmove.x new file mode 100644 index 00000000..aa4e5b45 --- /dev/null +++ b/sys/gio/grmove.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GRMOVE -- Relative move, i.e., move the pen to the specified offset from the +# current position (without generating any output). + +procedure grmove (gp, x, y) + +pointer gp # graphics descriptor +real x, y # offset from current position +real cx, cy + +begin + call gpl_flush() + if (IS_INDEF(x) || IS_INDEF(y)) + call gadraw (gp, x, y) + else { + call gcurpos (gp, cx, cy) + if (!(IS_INDEF(cx) || IS_INDEF(cy))) + call gamove (gp, cx + x, cy + y) + } +end diff --git a/sys/gio/grscale.x b/sys/gio/grscale.x new file mode 100644 index 00000000..76c06ebc --- /dev/null +++ b/sys/gio/grscale.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GRSCALE -- Rescale the world coordinates of either the X or Y axis to fit the +# data vector. This is done by taking the minimum and maximum of the current +# WCS limits and the data vector. May be called repeatedly to find the range +# of a family of vectors. + +procedure grscale (gp, v, npts, axis) + +pointer gp # graphics descriptor +real v[ARB] # data vector +int npts # length of data vector +int axis # asis to be scaled (1=X, 2=Y) + +int start, i +real minval, maxval, pixval +pointer w + +begin + # Find first definite valued pixel. If entire data vector is + # indefinite we merely ignore it, since the window is presumably + # already set. + + for (start=1; start <= npts; start=start+1) + if (!IS_INDEF (v[start])) + break + if (start > npts) + return + + minval = v[start] + maxval = minval + + # Compute min and max values of data vector. + do i = start+1, npts { + pixval = v[i] + if (!IS_INDEF(pixval)) + if (pixval < minval) + minval = pixval + else if (pixval > maxval) + maxval = pixval + } + + w = GP_WCSPTR (gp, GP_WCS(gp)) + + # Update the window limits. + switch (axis) { + case 1: + WCS_WX1(w) = min (WCS_WX1(w), minval) + WCS_WX2(w) = max (WCS_WX2(w), maxval) + case 2: + WCS_WY1(w) = min (WCS_WY1(w), minval) + WCS_WY2(w) = max (WCS_WY2(w), maxval) + default: + call syserr (SYS_GSCALE) + } + + WCS_FLAGS(w) = or (WCS_FLAGS(w), WF_DEFINED) + GP_WCSSTATE(gp) = MODIFIED + call gpl_reset() +end diff --git a/sys/gio/gscan.x b/sys/gio/gscan.x new file mode 100644 index 00000000..ac8f82bd --- /dev/null +++ b/sys/gio/gscan.x @@ -0,0 +1,11 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GSCAN -- Scan commands from a string or a file. + +procedure gscan (gp, command) + +pointer gp # graphics descriptor +char command[ARB] # command to be scanned + +begin +end diff --git a/sys/gio/gscur.x b/sys/gio/gscur.x new file mode 100644 index 00000000..2892e397 --- /dev/null +++ b/sys/gio/gscur.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GSCUR -- Set the current graphics cursor to the position (x,y) in world +# coordinates. + +procedure gscur (gp, x, y) + +pointer gp # graphics descriptor +real x, y # new position for cursor +real mx, my + +begin + call gpl_flush() + call gpl_wcstogki (gp, x, y, mx, my) + call gki_setcursor (GP_FD(gp), nint(mx), nint(my), GP_CURSOR(gp)) +end diff --git a/sys/gio/gseti.x b/sys/gio/gseti.x new file mode 100644 index 00000000..f3517358 --- /dev/null +++ b/sys/gio/gseti.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GSETI -- Set any GIO parameter of type integer or real. Precision may be +# lost if the actual parameter is of type real (call GSETR instead in such +# a case). + +procedure gseti (gp, param, value) + +pointer gp # graphics descriptor +int param # parameter to be set +int value # new value for parameter + +begin + call gsetr (gp, param, real(value)) +end diff --git a/sys/gio/gsetr.x b/sys/gio/gsetr.x new file mode 100644 index 00000000..9358f046 --- /dev/null +++ b/sys/gio/gsetr.x @@ -0,0 +1,276 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# GSETR -- Set any GIO parameter of type integer or real. Real values are +# silently coerced to integer if the actual parameter value is integer. + +procedure gsetr (gp, param, rval) + +pointer gp # graphics descriptor +int param # parameter to be set +real rval # new value for parameter + +real char_height +int wcs, axes, field, ax[2], wflags, i +pointer w, p, pl, pm, tx, fa +real ggetr() + +begin + # Compute pointers to substructures once, here, to save space later. + wcs = GP_WCS(gp) + w = GP_WCSPTR(gp,wcs) + wflags = WCS_FLAGS(w) + + pl = GP_PLAP(gp) + pm = GP_PMAP(gp) + tx = GP_TXAP(gp) + fa = GP_FAAP(gp) + + switch (param) { + + # General GIO parameters. + + case G_FD: + GP_FD(gp) = nint(rval) + case G_TTY: + GP_TTY(gp) = nint(rval) + case G_WCS: + GP_WCS(gp) = nint(rval) + case G_CURSOR: + GP_CURSOR(gp) = nint(rval) + + # These parameters affect the current WCS. + + case G_XTRAN: + WCS_XTRAN(w) = nint(rval) + GP_WCSSTATE(gp) = MODIFIED + call gpl_reset() + case G_YTRAN: + WCS_YTRAN(w) = nint(rval) + GP_WCSSTATE(gp) = MODIFIED + call gpl_reset() + case G_CLIP: + if (nint(rval) == 0) + WCS_FLAGS(w) = and (wflags, not(WF_CLIP)) + else + WCS_FLAGS(w) = or (wflags, WF_CLIP) + GP_WCSSTATE(gp) = MODIFIED + call gpl_reset() + case G_RASTER: + WCS_FLAGS(w) = WF_SETRASTER (wflags, nint(rval)) + GP_WCSSTATE(gp) = MODIFIED + call gpl_reset() + + # Default marker sizes (NDC coords). + + case G_SZMARKER1: + GP_SZMARKER(gp,1) = rval + case G_SZMARKER2: + GP_SZMARKER(gp,2) = rval + case G_SZMARKER3: + GP_SZMARKER(gp,3) = rval + case G_SZMARKER4: + GP_SZMARKER(gp,4) = rval + + # Polyline attributes. + + case G_PLTYPE: + call gst_set_attribute_i (nint(rval), PL_LTYPE(pl), PL_STATE(pl)) + case G_PLWIDTH: + call gst_set_attribute_r (rval, PL_WIDTH(pl), PL_STATE(pl)) + case G_PLCOLOR: + call gst_set_attribute_i (nint(rval), PL_COLOR(pl), PL_STATE(pl)) + + # Polymarker attributes. + + case G_PMLTYPE: + call gst_set_attribute_i (nint(rval), PM_LTYPE(pm), PM_STATE(pm)) + case G_PMWIDTH: + call gst_set_attribute_r (rval, PM_WIDTH(pm), PM_STATE(pm)) + case G_PMCOLOR: + call gst_set_attribute_i (nint(rval), PM_COLOR(pm), PM_STATE(pm)) + + # Text drawing attributes. + + case G_TXUP: + call gst_set_attribute_i (nint(rval), TX_UP(tx), TX_STATE(tx)) + case G_TXSIZE: + call gst_set_attribute_r (rval, TX_SIZE(tx), TX_STATE(tx)) + case G_TXPATH: + call gst_set_attribute_i (nint(rval), TX_PATH(tx), TX_STATE(tx)) + case G_TXSPACING: + call gst_set_attribute_r (rval, TX_SPACING(tx), TX_STATE(tx)) + case G_TXHJUSTIFY: + call gst_set_attribute_i (nint(rval), TX_HJUSTIFY(tx), TX_STATE(tx)) + case G_TXVJUSTIFY: + call gst_set_attribute_i (nint(rval), TX_VJUSTIFY(tx), TX_STATE(tx)) + case G_TXFONT: + call gst_set_attribute_i (nint(rval), TX_FONT(tx), TX_STATE(tx)) + case G_TXQUALITY: + call gst_set_attribute_i (nint(rval), TX_QUALITY(tx), TX_STATE(tx)) + case G_TXCOLOR: + call gst_set_attribute_i (nint(rval), TX_COLOR(tx), TX_STATE(tx)) + + # Fill area attributes. + + case G_FASTYLE: + call gst_set_attribute_i (nint(rval), FA_STYLE(fa), FA_STATE(fa)) + case G_FACOLOR: + call gst_set_attribute_i (nint(rval), FA_COLOR(fa), FA_STATE(fa)) + + # Axis labelling parameters affecting more than one axis. + + case G_DRAWTITLE: + GP_DRAWTITLE(gp) = nint(rval) + case G_TITLESIZE: + GP_TITLESIZE(gp) = rval + case G_TITLECOLOR: + GP_TITLECOLOR(gp) = nint(rval) + case G_TITLEJUST: + GP_TITLEJUST(gp) = nint(rval) + case G_NTITLELINES: + GP_NTITLELINES(gp) = nint(rval) + case G_FRAMECOLOR: + GP_FRAMECOLOR(gp) = nint(rval) + case G_ASPECT: + GP_ASPECT(gp) = rval + + case G_CHARSIZE: + # Set the character size (height) in NDC units. This can also be + # done by querying for "ch" and setting the relative size, but the + # function is fundamental enough to be worth implementing as a + # single call. + + char_height = ggetr (gp, "ch") + if (char_height < EPSILON) + char_height = DEF_CHARHEIGHT + call gst_set_attribute_r (rval / char_height, TX_SIZE(tx), + TX_STATE(tx)) + + default: + # The GLABAX parameters for the X and Y axes may be set separately + # for each axis or simultaneously for both. The parameter codes + # are encoded as 100 (X only) 200 (Y only) or 300 (both) plus the + # code for the field in the lower digits. + + if (param < FIRST_GLABAX_PARAM || param > LAST_GLABAX_PARAM) + call syserr (SYS_GSET) + + axes = param / 100 + field = mod (param, 100) + 300 + + ax[1] = 0 + ax[2] = 0 + if (axes == 1 || axes == 3) + ax[1] = YES + if (axes == 2 || axes == 3) + ax[2] = YES + + do i = 1, 2 { + if (ax[i] == YES) { + if (i == 1) + p = GP_XAP(gp) + else + p = GP_YAP(gp) + + switch (field) { + case G_DRAWAXES: + GL_DRAWAXES(p) = nint(rval) + case G_SETAXISPOS: + GL_SETAXISPOS(p) = nint(rval) + case G_AXISPOS1: + GL_AXISPOS1(p) = rval + case G_AXISPOS2: + GL_AXISPOS2(p) = rval + case G_DRAWGRID: + GL_DRAWGRID(p) = nint(rval) + case G_GRIDCOLOR: + GL_GRIDCOLOR(p) = nint(rval) + case G_ROUND: + GL_ROUND(p) = nint(rval) + case G_LABELAXIS: + GL_LABELAXIS(p) = nint(rval) + case G_AXISLABELSIZE: + GL_AXISLABELSIZE(p) = rval + case G_AXISLABELCOLOR: + GL_AXISLABELCOLOR(p) = nint(rval) + case G_DRAWTICKS: + GL_DRAWTICKS(p) = nint(rval) + case G_LABELTICKS: + GL_LABELTICKS(p) = nint(rval) + case G_NMAJOR: + GL_NMAJOR(p) = nint(rval) + case G_NMINOR: + GL_NMINOR(p) = nint(rval) + case G_MAJORLENGTH: + GL_MAJORLENGTH(p) = rval + case G_MINORLENGTH: + GL_MINORLENGTH(p) = rval + case G_MAJORWIDTH: + GL_MAJORWIDTH(p) = rval + case G_MINORWIDTH: + GL_MINORWIDTH(p) = rval + case G_AXISWIDTH: + GL_AXISWIDTH(p) = rval + case G_AXISCOLOR: + GL_AXISCOLOR(p) = nint(rval) + case G_TICKLABELSIZE: + GL_TICKLABELSIZE(p) = rval + case G_TICKLABELCOLOR: + GL_TICKLABELCOLOR(p) = nint(rval) + case G_TICKCOLOR: + GL_TICKCOLOR(p) = nint(rval) + # case G_TICKFORMAT: + # not a real parameter + default: + call syserr (SYS_GSET) + } + } + } + } +end + + +# GST_SET_ATTRIBUTE_I -- Compare the new value of an attribute to the current +# value. If the new value is not different, exit without modifying the +# attribute packet, making no-op GSET calls efficient. If the packet must +# be modified, flush any buffered polyline output first else it will be +# written using the new attribute (this is not necessary for text attributes, +# but is harmless and it is unlikely that GSET will be called to modify a +# text attribute while in the midst of building a polyline). Set the +# parameter and flag the attribute packet as modified. + +procedure gst_set_attribute_i (new_value, value, state) + +int new_value # value in GSET argument list +int value # current value in GP struct +int state # packet state + +begin + if (new_value != value) { + call gpl_flush() + value = new_value + state = MODIFIED + } +end + + +# GST_SET_ATTRIBUTE_R -- Ditto, for real valued parameters. + +procedure gst_set_attribute_r (new_value, value, state) + +real new_value # value in GSET argument list +real value # current value in GP struct +int state # packet state + +begin + if (abs (new_value - value) > EPSILON) { + call gpl_flush() + value = new_value + state = MODIFIED + } +end diff --git a/sys/gio/gsets.x b/sys/gio/gsets.x new file mode 100644 index 00000000..ad72d000 --- /dev/null +++ b/sys/gio/gsets.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GSETS -- Set a string valued GIO parameter. + +procedure gsets (gp, param, value) + +pointer gp # graphics descriptor +int param # parmeter to be set +char value[ARB] # new value of parameter +int i +pointer gl[2] + +begin + gl[1] = GP_XAP(gp) + gl[2] = GP_YAP(gp) + + switch (param) { + case G_XTICKFORMAT: + call strcpy (value, GL_TICKFORMAT(gl[1]), SZ_TICKFORMAT) + case G_YTICKFORMAT: + call strcpy (value, GL_TICKFORMAT(gl[2]), SZ_TICKFORMAT) + case G_TICKFORMAT: + do i = 1, 2 + call strcpy (value, GL_TICKFORMAT(gl[i]), SZ_TICKFORMAT) + default: + call syserr (SYS_GSET) + } +end diff --git a/sys/gio/gstati.x b/sys/gio/gstati.x new file mode 100644 index 00000000..2298b39b --- /dev/null +++ b/sys/gio/gstati.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GSTATI -- Get any GIO parameter of type integer or real. Precision may be +# lost if the actual parameter is of type real (call GSTATR instead in such +# a case). + +int procedure gstati (gp, param) + +pointer gp # graphics descriptor +int param # parameter to be inspected + +real gstatr() + +begin + return (gstatr (gp, param)) +end diff --git a/sys/gio/gstatr.x b/sys/gio/gstatr.x new file mode 100644 index 00000000..d0ba3d8b --- /dev/null +++ b/sys/gio/gstatr.x @@ -0,0 +1,215 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# GSTATR -- Get any GIO parameter of type integer or real. Integer values are +# silently coerced to real if the actual parameter value is integer. + +real procedure gstatr (gp, param) + +pointer gp # graphics descriptor +int param # parameter to be set + +real char_height +int wcs, axes, field, ax[2], i +pointer w, p, pl, pm, tx, fa +real ggetr() + +begin + # Compute pointers to substructures once, here, to save space later. + wcs = GP_WCS(gp) + w = GP_WCSPTR(gp,wcs) + pl = GP_PLAP(gp) + pm = GP_PMAP(gp) + tx = GP_TXAP(gp) + fa = GP_FAAP(gp) + + switch (param) { + + # General GIO parameters. + + case G_FD: + return (GP_FD(gp)) + case G_TTY: + return (GP_TTY(gp)) + case G_WCS: + return (GP_WCS(gp)) + case G_CURSOR: + return (GP_CURSOR(gp)) + + # These parameters affect the current WCS. + + case G_XTRAN: + return (WCS_XTRAN(w)) + case G_YTRAN: + return (WCS_YTRAN(w)) + case G_CLIP: + return (and (WCS_FLAGS(w), WF_CLIP)) + case G_RASTER: + return (WF_RASTER (WCS_FLAGS(w))) + + # Default marker sizes (NDC coords). + + case G_SZMARKER1: + return (GP_SZMARKER(gp,1)) + case G_SZMARKER2: + return (GP_SZMARKER(gp,2)) + case G_SZMARKER3: + return (GP_SZMARKER(gp,3)) + case G_SZMARKER4: + return (GP_SZMARKER(gp,4)) + + # Polyline attributes. + + case G_PLTYPE: + return (PL_LTYPE(pl)) + case G_PLWIDTH: + return (PL_WIDTH(pl)) + case G_PLCOLOR: + return (PL_COLOR(pl)) + + # Polymarker attributes. + + case G_PMLTYPE: + return (PM_LTYPE(pm)) + case G_PMWIDTH: + return (PM_WIDTH(pm)) + case G_PMCOLOR: + return (PM_COLOR(pm)) + + # Text drawing attributes. + + case G_TXUP: + return (TX_UP(tx)) + case G_TXSIZE: + return (TX_SIZE(tx)) + case G_TXPATH: + return (TX_PATH(tx)) + case G_TXSPACING: + return (TX_SPACING(tx)) + case G_TXHJUSTIFY: + return (TX_HJUSTIFY(tx)) + case G_TXVJUSTIFY: + return (TX_VJUSTIFY(tx)) + case G_TXFONT: + return (TX_FONT(tx)) + case G_TXQUALITY: + return (TX_QUALITY(tx)) + case G_TXCOLOR: + return (TX_COLOR(tx)) + + # Fill area attributes. + + case G_FASTYLE: + return (FA_STYLE(fa)) + case G_FACOLOR: + return (FA_COLOR(fa)) + + # Axis labelling parameters affecting more than one axis. + + case G_DRAWTITLE: + return (GP_DRAWTITLE(gp)) + case G_TITLESIZE: + return (GP_TITLESIZE(gp)) + case G_TITLECOLOR: + return (GP_TITLECOLOR(gp)) + case G_NTITLELINES: + return (GP_NTITLELINES(gp)) + case G_FRAMECOLOR: + return (GP_FRAMECOLOR(gp)) + case G_ASPECT: + return (GP_ASPECT(gp)) + + case G_CHARSIZE: + # Return the current character size in NDC units. + + char_height = ggetr (gp, "ch") + if (char_height < EPSILON) + char_height = DEF_CHARHEIGHT + return (char_height * TX_SIZE(tx)) + + default: + # The GLABAX parameters for the X and Y axes may be set separately + # for each axis or simultaneously for both. The parameter codes + # are encoded as 100 (X only) 200 (Y only) or 300 (both) plus the + # code for the field in the lower digits. + + if (param < FIRST_GLABAX_PARAM || param > LAST_GLABAX_PARAM) + call syserr (SYS_GSTAT) + + axes = param / 100 + field = mod (param, 100) + 300 + + ax[1] = 0 + ax[2] = 0 + if (axes == 1 || axes == 3) + ax[1] = YES + if (axes == 2 || axes == 3) + ax[2] = YES + + do i = 1, 2 { + if (ax[i] == YES) { + if (i == 1) + p = GP_XAP(gp) + else + p = GP_YAP(gp) + + switch (field) { + case G_DRAWAXES: + return (GL_DRAWAXES(p)) + case G_SETAXISPOS: + return (GL_SETAXISPOS(p)) + case G_AXISPOS1: + return (GL_AXISPOS1(p)) + case G_AXISPOS2: + return (GL_AXISPOS2(p)) + case G_DRAWGRID: + return (GL_DRAWGRID(p)) + case G_GRIDCOLOR: + return (GL_GRIDCOLOR(p)) + case G_ROUND: + return (GL_ROUND(p)) + case G_LABELAXIS: + return (GL_LABELAXIS(p)) + case G_AXISLABELSIZE: + return (GL_AXISLABELSIZE(p)) + case G_AXISLABELCOLOR: + return (GL_AXISLABELCOLOR(p)) + case G_DRAWTICKS: + return (GL_DRAWTICKS(p)) + case G_LABELTICKS: + return (GL_LABELTICKS(p)) + case G_NMAJOR: + return (GL_NMAJOR(p)) + case G_NMINOR: + return (GL_NMINOR(p)) + case G_MAJORLENGTH: + return (GL_MAJORLENGTH(p)) + case G_MINORLENGTH: + return (GL_MINORLENGTH(p)) + case G_MAJORWIDTH: + return (GL_MAJORWIDTH(p)) + case G_MINORWIDTH: + return (GL_MINORWIDTH(p)) + case G_AXISWIDTH: + return (GL_AXISWIDTH(p)) + case G_AXISCOLOR: + return (GL_AXISCOLOR(p)) + case G_TICKLABELSIZE: + return (GL_TICKLABELSIZE(p)) + case G_TICKLABELCOLOR: + return (GL_TICKLABELCOLOR(p)) + case G_TICKCOLOR: + return (GL_TICKCOLOR(p)) + # case G_TICKFORMAT: + # not a real parameter + default: + call syserr (SYS_GSTAT) + } + } + } + } +end diff --git a/sys/gio/gstats.x b/sys/gio/gstats.x new file mode 100644 index 00000000..14fd7c35 --- /dev/null +++ b/sys/gio/gstats.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# GSTATS -- Get the value of a string valued GIO parameter. + +int procedure gstats (gp, param, outstr, maxch) + +pointer gp # graphics descriptor +int param # parmeter to be set +char outstr[ARB] # output string +int maxch +int gstrcpy() + +int i, value +pointer p[2] + +begin + p[1] = GP_XAP(gp) + p[2] = GP_XAP(gp) + + switch (param) { + case G_XTICKFORMAT: + return (gstrcpy (GL_TICKFORMAT(p[1]), value, maxch)) + case G_YTICKFORMAT: + return (gstrcpy (GL_TICKFORMAT(p[2]), value, maxch)) + case G_TICKFORMAT: + do i = 1, 2 + return (gstrcpy (GL_TICKFORMAT(p[i]), value, maxch)) + default: + call syserr (SYS_GSTAT) + } +end diff --git a/sys/gio/gsview.x b/sys/gio/gsview.x new file mode 100644 index 00000000..7ed83b31 --- /dev/null +++ b/sys/gio/gsview.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GSVIEW -- Set the viewport of the current WCS. + +procedure gsview (gp, x1, x2, y1, y2) + +pointer gp # graphics descriptor +real x1, x2 # range of NDC in X +real y1, y2 # range of NDC in Y +pointer w + +begin + w = GP_WCSPTR (gp, GP_WCS(gp)) + + WCS_SX1(w) = x1 + WCS_SX2(w) = x2 + WCS_SY1(w) = y1 + WCS_SY2(w) = y2 + + WCS_FLAGS(w) = or (WCS_FLAGS(w), WF_DEFINED) + GP_WCSSTATE(gp) = MODIFIED + call gpl_reset() +end diff --git a/sys/gio/gswind.x b/sys/gio/gswind.x new file mode 100644 index 00000000..81f7b6a3 --- /dev/null +++ b/sys/gio/gswind.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GSWIND -- Set the window into world coordinates of the current WCS. + +procedure gswind (gp, x1, x2, y1, y2) + +pointer gp # graphics descriptor +real x1, x2 # range of world coords in X +real y1, y2 # range of world coords in Y +pointer w + +begin + call gpl_flush() + w = GP_WCSPTR (gp, GP_WCS(gp)) + + if (!IS_INDEF(x1)) + WCS_WX1(w) = x1 + if (!IS_INDEF(x2)) + WCS_WX2(w) = x2 + if (!IS_INDEF(y1)) + WCS_WY1(w) = y1 + if (!IS_INDEF(y2)) + WCS_WY2(w) = y2 + + WCS_FLAGS(w) = or (WCS_FLAGS(w), WF_DEFINED) + GP_WCSSTATE(gp) = MODIFIED + call gpl_reset() +end diff --git a/sys/gio/gtext.x b/sys/gio/gtext.x new file mode 100644 index 00000000..abb26ef4 --- /dev/null +++ b/sys/gio/gtext.x @@ -0,0 +1,77 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GTEXT -- Draw text. All textual output via GIO is via this primitive. Unlike +# polyline, polymarker, fill area, and cell array output, textual output is not +# subjected to clipping by GIO. Clipping may be performed at the kernel level +# if a workstation viewport is defined. Our task here is principally to parse +# the format string and set up the text attributes, then insert the text drawing +# instruction into the GKI instruction stream. The real work of text generation +# is very device dependent and is therefore left to the kernel. + +procedure gtext (gp, x, y, text, format) + +pointer gp # graphics descriptor +real x, y # position at which text is to be drawn +char text[ARB] # text to be drawn +char format[ARB] # text drawing parameters + +int ip, i +real mx, my +pointer sp, ap, tx +bool text_attributes_modified + +begin + call smark (sp) + call salloc (ap, LEN_TX, TY_STRUCT) + + # Set up pointers to text attribute packets and initialize the + # new packet to the default values. Two text attribute packets + # are maintained in GP: TXAP, the default packet, and TXAPCUR, + # the packet last sent to the device. In what follows, AP is + # the new packet and TX is the packet last sent to the device. + # We start by initializing the new packet at AP to the default + # text drawing parameters. + + call amovi (Memi[GP_TXAP(gp)], Memi[ap], LEN_TX) + tx = GP_TXAPCUR(gp) + + # Parse the format string and set the text attributes. The code is + # more general than need be, i.e., the entire attribute name string + # is extracted but only the first character is used. Whitespace is + # permitted and ignored. + + ip = 1 + call gtxset (ap, format, ip) + + # If the old text attribute packet was never fixed always fix the + # new packet, otherwise determine whether or not any text attributes + # were actually modified and only fix the new packet if it is + # different. + + text_attributes_modified = false + for (i=2; i <= LEN_TX; i=i+1) + if (Memi[ap+i-1] != Memi[tx+i-1]) { + text_attributes_modified = true + break + } + + # Flush any buffered polyline output, and transform the text coordinates + # to GKI device coordinates. + + call gpl_flush() + call gpl_wcstogki (gp, x, y, mx, my) + + # Update text attributes if necessary. + if (text_attributes_modified || TX_STATE(tx) != FIXED) { + call amovi (Memi[ap], Memi[tx], LEN_TX) + call gki_txset (GP_FD(gp), tx) + TX_STATE(tx) = FIXED + } + + # Output text drawing instruction. + call gki_text (GP_FD(gp), nint(mx), nint(my), text) + + call sfree (sp) +end diff --git a/sys/gio/gtick.gx b/sys/gio/gtick.gx new file mode 100644 index 00000000..157fae1e --- /dev/null +++ b/sys/gio/gtick.gx @@ -0,0 +1,192 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GTICK -- Determine the best number and placement of ticks for the interval +# [x1:x2]. If log scaling is in use we try to put the ticks at positions which +# are 1.0 times some power of ten, otherwise we divide the interval an integral +# number of times and place the ticks at the interval boundaries. The basic +# algorithm is simple, but implementation is tricky due to the quirks of +# floating point computations and the desire to have the algorithm work for all +# X, and all ranges of X. For example, we might want to plot a large range +# near zero, or a small range where both X1 and X2 have a very large exponent. +# +# N.B.: this is a generic source; it may be preprocessed with the IRAF "generic" +# preprocessor to produce either a single or double precision SPP source file. + +procedure gtick$t (x1, x2, rough_nticks, logflag, x_tick1, step) + +PIXEL x1, x2 # range for which ticks are desired +int rough_nticks # approximate number of ticks desired +int logflag # nonzero if log scaling in use +PIXEL x_tick1 # x coord of first tick (output) +PIXEL step # tick spacing along X (output) + +PIXEL x, tol +int ndiv +int log +#int nticks +int expon +PIXEL gt_distance() + +begin + log = logflag + tol = EPSILON$T * 10.0 + + # If log, decrease ndiv until an x of 1.0 is obtained. If an x of 1.0 + # cannot be produced, repeat the calculation once more with ndiv fixed. + + repeat { + ndiv = max (1, rough_nticks - 1) + + repeat { + if (log == YES) + x = 1.0 + else + x = abs ((x2 - x1) / ndiv) + + # Scale approximate tick spacing to the range [1-10). Select + # a logical tick spacing, given calculated and scaled spacing. + + call fp_norm$t (x, x, expon) + if (x < 1.5) + x = 1.0 + else if (x < 2.5) + x = 2.0 + else if (x < 4.0) + x = 2.5 + else if (x < 7.5) + x = 5.0 + else { + x = 1.0 + expon = expon + 1 + } + + # Calculate the first tick and the tick increment (step size). + if (log == YES) + step = 1.0 + else + step = x * (10.0 ** expon) + + if (gt_distance (x1, step, x_tick1) / step < tol) + # x_tick1 = x1 + else if (x1 < x2 && x_tick1 < x1) + x_tick1 = x_tick1 + step + else if (x1 > x2 && x_tick1 > x1) + x_tick1 = x_tick1 - step + + if (x1 > x2) + step = -step + ndiv = ndiv - 1 + + } until (abs(abs(x) - 1.0) < tol || log == NO || ndiv == 0) + + # Terminate if not in log mode, if the tick separation is a power + # of ten and there are ndivisions tick marks, or if the tick + # separation is one magnitude and there are at least two tick marks + # within the range x1:x2. + + # if (log == NO) { + # return + # } else if (step == 1.0 || x == 1.0) { + # if (step == 1.0) + # nticks = 1 + # else + # nticks = max (2, rough_nticks - 1) + + # if (x1 > x2 && x_tick1 + nticks * step >= x2) + # return + # else if (x1 < x2 && x_tick1 + nticks * step <= x2) + # return + # else + # log = NO + # } else + # log = NO + + return + } +end + + +# GT_NDIGITS -- Calculate the number of digits of precision needed to label +# ticks in the range x1 to x2 (i.e., if x1=100000 and x2=100001, 7 digits +# will be required, whereas in many cases 1 or 2 is enough). + +int procedure gt_ndigits (x1, x2, step) + +PIXEL x1, x2 # range covered by numbers +PIXEL step # tick separation +PIXEL ratio +int n + +begin + if (x1 == x2) + n = 2 + else { + ratio = abs ((x1+x2) / (x1-x2)) + n = log10 (max (1.0, ratio)) + 2.0 + } + + return (n) +end + + +# GT_LINEARITY -- The following function returns a large number if there is +# little difference between a log scale and a linear scale for the range X1 +# to X2. if the linearity of the interval is large, there is no point in +# using a logarithmic scale. + +PIXEL procedure gt_linearity (x1, x2) + +PIXEL x1, x2 +PIXEL linearity, difflog +PIXEL elog$t() + +begin + if (x1 <= 0 || x2 <= 0) + difflog = abs (elog$t(x1) - elog$t(x2)) + else + difflog = abs (log10(x1) - log10(x2)) + + if (difflog == 0.0) + linearity = 1E10 + else + linearity = 1.0 / difflog + + return (linearity) +end + + +# GT_DISTANCE -- Compute the distance of X from the nearest integral multiple +# of "step". + +PIXEL procedure gt_distance (x, step, nearest_tick) + +PIXEL x # number to be tested +PIXEL step # tick separation +PIXEL nearest_tick # X coord of tick nearest X + +PIXEL ltick, rtick, absx +PIXEL fp_fix$t() + +begin + absx = abs (x) + + ltick = fp_fix$t (absx / step) * step + rtick = ltick + step + + if (abs(absx - ltick) < abs(rtick - absx)) { + if (x < 0) + nearest_tick = -ltick + else + nearest_tick = ltick + return (absx - ltick) + + } else { + if (x < 0) + nearest_tick = -rtick + else + nearest_tick = rtick + return (rtick - absx) + } +end diff --git a/sys/gio/gtickr.x b/sys/gio/gtickr.x new file mode 100644 index 00000000..cd227363 --- /dev/null +++ b/sys/gio/gtickr.x @@ -0,0 +1,192 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GTICK -- Determine the best number and placement of ticks for the interval +# [x1:x2]. If log scaling is in use we try to put the ticks at positions which +# are 1.0 times some power of ten, otherwise we divide the interval an integral +# number of times and place the ticks at the interval boundaries. The basic +# algorithm is simple, but implementation is tricky due to the quirks of +# floating point computations and the desire to have the algorithm work for all +# X, and all ranges of X. For example, we might want to plot a large range +# near zero, or a small range where both X1 and X2 have a very large exponent. +# +# N.B.: this is a generic source; it may be preprocessed with the IRAF "generic" +# preprocessor to produce either a single or double precision SPP source file. + +procedure gtickr (x1, x2, rough_nticks, logflag, x_tick1, step) + +real x1, x2 # range for which ticks are desired +int rough_nticks # approximate number of ticks desired +int logflag # nonzero if log scaling in use +real x_tick1 # x coord of first tick (output) +real step # tick spacing along X (output) + +real x, tol +int ndiv +int log +#int nticks +int expon +real gt_distance() + +begin + log = logflag + tol = EPSILONR * 10.0 + + # If log, decrease ndiv until an x of 1.0 is obtained. If an x of 1.0 + # cannot be produced, repeat the calculation once more with ndiv fixed. + + repeat { + ndiv = max (1, rough_nticks - 1) + + repeat { + if (log == YES) + x = 1.0 + else + x = abs ((x2 - x1) / ndiv) + + # Scale approximate tick spacing to the range [1-10). Select + # a logical tick spacing, given calculated and scaled spacing. + + call fp_normr (x, x, expon) + if (x < 1.5) + x = 1.0 + else if (x < 2.5) + x = 2.0 + else if (x < 4.0) + x = 2.5 + else if (x < 7.5) + x = 5.0 + else { + x = 1.0 + expon = expon + 1 + } + + # Calculate the first tick and the tick increment (step size). + if (log == YES) + step = 1.0 + else + step = x * (10.0 ** expon) + + if (gt_distance (x1, step, x_tick1) / step < tol) + # x_tick1 = x1 + else if (x1 < x2 && x_tick1 < x1) + x_tick1 = x_tick1 + step + else if (x1 > x2 && x_tick1 > x1) + x_tick1 = x_tick1 - step + + if (x1 > x2) + step = -step + ndiv = ndiv - 1 + + } until (abs(abs(x) - 1.0) < tol || log == NO || ndiv == 0) + + # Terminate if not in log mode, if the tick separation is a power + # of ten and there are ndivisions tick marks, or if the tick + # separation is one magnitude and there are at least two tick marks + # within the range x1:x2. + + # if (log == NO) { + # return + # } else if (step == 1.0 || x == 1.0) { + # if (step == 1.0) + # nticks = 1 + # else + # nticks = max (2, rough_nticks - 1) + + # if (x1 > x2 && x_tick1 + nticks * step >= x2) + # return + # else if (x1 < x2 && x_tick1 + nticks * step <= x2) + # return + # else + # log = NO + # } else + # log = NO + + return + } +end + + +# GT_NDIGITS -- Calculate the number of digits of precision needed to label +# ticks in the range x1 to x2 (i.e., if x1=100000 and x2=100001, 7 digits +# will be required, whereas in many cases 1 or 2 is enough). + +int procedure gt_ndigits (x1, x2, step) + +real x1, x2 # range covered by numbers +real step # tick separation +real ratio +int n + +begin + if (x1 == x2) + n = 2 + else { + ratio = abs ((x1+x2) / (x1-x2)) + n = log10 (max (1.0, ratio)) + 2.0 + } + + return (n) +end + + +# GT_LINEARITY -- The following function returns a large number if there is +# little difference between a log scale and a linear scale for the range X1 +# to X2. if the linearity of the interval is large, there is no point in +# using a logarithmic scale. + +real procedure gt_linearity (x1, x2) + +real x1, x2 +real linearity, difflog +real elogr() + +begin + if (x1 <= 0 || x2 <= 0) + difflog = abs (elogr(x1) - elogr(x2)) + else + difflog = abs (log10(x1) - log10(x2)) + + if (difflog == 0.0) + linearity = 1E10 + else + linearity = 1.0 / difflog + + return (linearity) +end + + +# GT_DISTANCE -- Compute the distance of X from the nearest integral multiple +# of "step". + +real procedure gt_distance (x, step, nearest_tick) + +real x # number to be tested +real step # tick separation +real nearest_tick # X coord of tick nearest X + +real ltick, rtick, absx +real fp_fixr() + +begin + absx = abs (x) + + ltick = fp_fixr (absx / step) * step + rtick = ltick + step + + if (abs(absx - ltick) < abs(rtick - absx)) { + if (x < 0) + nearest_tick = -ltick + else + nearest_tick = ltick + return (absx - ltick) + + } else { + if (x < 0) + nearest_tick = -rtick + else + nearest_tick = rtick + return (rtick - absx) + } +end diff --git a/sys/gio/gtxset.x b/sys/gio/gtxset.x new file mode 100644 index 00000000..de386a69 --- /dev/null +++ b/sys/gio/gtxset.x @@ -0,0 +1,144 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +define MAXCH 15 + +# GTXSET -- Parse a text drawing format string and set the values of the text +# attributes in the TX output structure. + +procedure gtxset (tx, format, ip) + +pointer tx # text attribute structure +char format[ARB] # text attribute format string +int ip # pointer into format string + +char attribute[MAXCH], value[MAXCH] +int op, tip, temp, ch +int h_v[4], v_v[4], f_v[4], q_v[4], p_v[4] +int ctoi(), ctor(), stridx() +define badformat_ 91 + +string h_c "nclr" +data h_v /GT_NORMAL, GT_CENTER, GT_LEFT, GT_RIGHT/ +string v_c "nctb" +data v_v /GT_NORMAL, GT_CENTER, GT_TOP, GT_BOTTOM/ +string f_c "rgib" +data f_v /GT_ROMAN, GT_GREEK, GT_ITALIC, GT_BOLD/ +string q_c "nlmh" +data q_v /GT_NORMAL, GT_LOW, GT_MEDIUM, GT_HIGH/ +string p_c "lrud" +data p_v /GT_LEFT, GT_RIGHT, GT_UP, GT_DOWN/ + +begin + # Parse the format string and set the text attributes. The code is + # more general than need be, i.e., the entire attribute name string + # is extracted but only the first character is used. Whitespace is + # permitted and ignored. + + for (; format[ip] != EOS; ip=ip+1) { + # Extract the next "attribute=value" construct. + while (IS_WHITE (format[ip])) + ip = ip +1 + + op = 1 + for (ch=format[ip]; ch != EOS && ch != '='; ch=format[ip]) { + if (op <= MAXCH) { + attribute[op] = format[ip] + op = op + 1 + } + ip = ip + 1 + } + attribute[op] = EOS + + if (ch == '=') + ip = ip + 1 + + op = 1 + while (IS_WHITE (format[ip])) + ip = ip +1 + ch = format[ip] + while (ch != EOS && ch != ';' && ch != ',') { + if (op <= MAXCH) { + value[op] = format[ip] + op = op + 1 + } + ip = ip + 1 + ch = format[ip] + } + value[op] = EOS + + if (attribute[1] == EOS || value[1] == EOS) + break + + # Decode the assignment and set the corresponding text attribute + # in the graphics descriptor. + + switch (attribute[1]) { + case 'u': # character up vector + tip = 1 + if (ctoi (value, tip, TX_UP(tx)) <= 0) { + TX_UP(tx) = 90 + goto badformat_ + } + + case 'p': # path + temp = stridx (value[1], p_c) + if (temp <= 0) + goto badformat_ + else + TX_PATH(tx) = p_v[temp] + + case 'c': # color + tip = 1 + if (ctoi (value, tip, TX_COLOR(tx)) <= 0) { + TX_COLOR(tx) = 1 + goto badformat_ + } + + case 's': # character size scale factor + tip = 1 + if (ctor (value, tip, TX_SIZE(tx)) <= 0) { + TX_SIZE(tx) = 1.0 + goto badformat_ + } + + case 'h': # horizontal justification + temp = stridx (value[1], h_c) + if (temp <= 0) + goto badformat_ + else + TX_HJUSTIFY(tx) = h_v[temp] + + case 'v': # vertical justification + temp = stridx (value[1], v_c) + if (temp <= 0) + goto badformat_ + else + TX_VJUSTIFY(tx) = v_v[temp] + + case 'f': # font + temp = stridx (value[1], f_c) + if (temp <= 0) + goto badformat_ + else + TX_FONT(tx) = f_v[temp] + + case 'q': # font quality + temp = stridx (value[1], q_c) + if (temp <= 0) + goto badformat_ + else + TX_QUALITY(tx) = q_v[temp] + + default: +badformat_ call eprintf ("Warning (GIO): bad gtext format '%s'\n") + call pargstr (format) + } + + if (format[ip] == EOS) + break + } +end diff --git a/sys/gio/gumark.x b/sys/gio/gumark.x new file mode 100644 index 00000000..cafb42bc --- /dev/null +++ b/sys/gio/gumark.x @@ -0,0 +1,108 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GUMARK -- Draw a user defined mark. The mark is defined by the polygon +# (x[i],y[i], i=1,npts), normalized to the unit square. This mark is mapped +# into the window at (XCEN,YCEN) of size XSIZE, YSIZE, where the mark center +# is always given in world coordinates but the size may be given in any of a +# number of ways, independently in X and Y. + +procedure gumark (gp, x, y, npts, xcen, ycen, xsize, ysize, fill) + +pointer gp # graphics descriptor +real x[ARB] # X coordinates of marker polygon (unit square) +real y[ARB] # Y coordinates of marker polygon (unit square) +int npts # number of points in marker polygon +real xcen, ycen # world coordinates of center of marker +real xsize, ysize # marker size in X and Y +int fill # draw marker using area fill + +pointer plap, pmap +bool scale_unset +int save_linetype, index, i +real x1, y1, xs, ys, dx, dy +real size[2], ndc_size[2], wcs_size[2] + +begin + plap = GP_PLAP(gp) + pmap = GP_PMAP(gp) + + # Determine the marker size in world coordinates. Marksizes 1:4 are + # "standard size" markers. A marksize of [0-1) is an explicit marker + # size in NDC coordinates, while a negative marksize is an explicit + # marker size in world coordinates. + + size[1] = xsize + size[2] = ysize + scale_unset = true + + do i = 1, 2 + if (size[i] > 0) { + if (size[i] - 1.0 > -EPSILON) { + # Use a default marker size. + index = min (MAX_SZMARKER, int(size[i])) + ndc_size[i] = GP_SZMARKER (gp, index) + + # Correct for the aspect ratio. + if (i == 1) + ndc_size[1] = ndc_size[1] * GP_DEVASPECT(gp) + } else + ndc_size[i] = size[i] + + # Convert to size in world coords. + if (scale_unset) { + # Get the scale in wcs units per ndc unit at (x,y). + call ggscale (gp, xcen, ycen, dx, dy) + scale_unset = false + } + if (i == 1) + wcs_size[1] = ndc_size[1] * abs(dx) + else + wcs_size[2] = ndc_size[2] * abs(dy) + + } else + wcs_size[i] = -size[i] + + # Set fill area instruction type if filling, otherwise set linetype + # if marker will be drawn as a polyline. Do nothing if polymarker + # linetype is same as polyline linetype. + + if (fill == YES) + call gpl_settype (gp, FILLAREA) + else { + save_linetype = PL_LTYPE(plap) + if (save_linetype != PM_LTYPE(pmap)) { + call gpl_flush() + PL_LTYPE(plap) = PM_LTYPE(pmap) + PL_STATE(plap) = MODIFIED + } + } + + # Draw the marker, scaling as necessary to fit the mark window. Final + # mark need not have the same aspect ratio as the normalized mark. + # Leave the pen positioned to the center of the marker. + + xs = wcs_size[1] + ys = wcs_size[2] + x1 = xcen - (xs / 2.0) + y1 = ycen - (ys / 2.0) + + call gamove (gp, x[1] * xs + x1, y[1] * ys + y1) + do i = 2, npts + call gadraw (gp, x[i] * xs + x1, y[i] * ys + y1) + call gamove (gp, xcen, ycen) + + # If the polyline linetype was modified restore the original value. + # Do not need to do anything if polymarker linetype was same as + # polyline linetype. + + if (fill == YES) + call gpl_settype (gp, POLYLINE) + else if (save_linetype != PM_LTYPE(pmap)) { + call gpl_flush() + PL_LTYPE(plap) = save_linetype + PL_STATE(plap) = MODIFIED + } +end diff --git a/sys/gio/gvline.x b/sys/gio/gvline.x new file mode 100644 index 00000000..929fab44 --- /dev/null +++ b/sys/gio/gvline.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GVLINE -- Vector polyline. Draw a line connecting the points (X[i],V[i]), +# where the X[i] are evenly distributed from X1 to X2. + +procedure gvline (gp, v, npts, x1, x2) + +pointer gp # graphics descriptor +real v[ARB] # Y coordinates of the polyline +int npts # number of polyline points +real x1, x2 # range of X coordinates of the polyline + +int i +real dx + +begin + if (npts > 1) { + dx = (x2 - x1) / (npts - 1) + call gamove (gp, x1, v[1]) + do i = 2, npts + call gadraw (gp, (i-1) * dx + x1, v[i]) + } +end diff --git a/sys/gio/gvmark.x b/sys/gio/gvmark.x new file mode 100644 index 00000000..219f8bae --- /dev/null +++ b/sys/gio/gvmark.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GVMARK -- Vector polymarker. Output at sequence of markers at the vertices +# of a polygon, all markers the same type and size. The polygon is given by +# the set of points (X[i],V[i]), where the X[i] are evenly distributed from X1 +# to X2. The marker type GM_POINT is a special case. + +procedure gvmark (gp, v, npts, x1, x2, marktype, xsize, ysize) + +pointer gp # graphics descriptor +real v[ARB] # Y[i] polygon +int npts # number of points +real x1, x2 # range of X[i] +int marktype # marker type +real xsize, ysize # marker size + +int i +real dx + +begin + if (npts > 1) + if (marktype == GM_POINT) { + call gpl_settype (gp, POLYMARKER) + call gvline (gp, v, npts, x1, x2) + call gpl_settype (gp, POLYLINE) + } else { + dx = (x2 - x1) / (npts - 1) + do i = 1, npts + call gmark (gp, (i-1) * dx + x1, v[i], marktype, + xsize, ysize) + } +end diff --git a/sys/gio/imdkern/README b/sys/gio/imdkern/README new file mode 100644 index 00000000..da041be0 --- /dev/null +++ b/sys/gio/imdkern/README @@ -0,0 +1,85 @@ +IMDKERN - + +This directory contains the source for the simple GIO/IMD kernel, used to +draw graphics in a display frame buffer. It uses the data stream +interface to open the frame buffer and uses code from SGI to rasterize +the graphics. + +Special graphcap entries used by this kernel: + + CI Color index of graphics pixels + FN Display frame buffer + LO Width in pixels of line size 1.0 + LS Difference in pixels between line sizes + DB Print debug messages? + + +Revision notes... +---------------- +IMDKERN notes 20 December 1989 Z. G. Levay, STScI + + + o Make private copy idskern of gio/sgikern. + + o Change "sgi" filename and procedure prefixes to "imd" throughout + the code. Change sgk.x to idk.x. Changed imd_open to imd_fopen to + aviod conflict with a procedure in libds. The files are: + + font.com, font.h, idk.com, idk.h, idk.x, imd.com, imd.h, + imdcancel.x, imdclear.x, imdclose.x, imdclws.x, imdcolor.x, + imddrawch.x, imdescape.x, imdfa.x, imdfaset.x, imdflush.x, + imdfont.x, imdfopen.x, imdgcell.x, imdinit.x, imdipl.x, + imdkern.par, imdline.x, imdopenws.x, imdpcell.x, imdpl.x, + imdplset.x, imdpm.x, imdpmset.x, imdreset.x, imdtx.x, imdtxset.x, + ltype.dat, mkpkg, t_imdkern.x, x_imdkern.x, + + o Modify mkpkg to build the task locally without updating the system + library or install the task. + + o Add global parameters "frame" and "color" to task imdkern. + Modified imd_fopen to read task parameters and pass as arguments to + imd_openws. Added these parameters to imd_openws and the call to + idk_open. + + o In idk_open, added frame and color to the calling sequence. Added + a call to imd_mapframe to open the frame buffer as an image, + changed setting the bitmap size to use the frame buffer size (via + IMIO) instead of graphcap parameters. Set the bits per bitmap word + to 8. Set the maximum bitmap size to 2048x2048 pixels. Ripped out + the code for opening the SGI metacode file, DD string manipulation, + etc. Added ttygeti calls to read the frame and color from the + graphcap in case they were passed as INDEF. + + In idk_frame, changed the code to map an input and output section + of the frame buffer (via IMIO), read the bitmap line by line, + testing each word for any on bits, and writing the color index + value to the frame buffer pixel for each on bitmap bit. Set the + I/O buffer sizes to 64 lines (somewhat arbitrarily). + + In idk_open, Changed the code to compute the x and y max (right and + top edges) of the bitmap by one pixel to draw to the edge. In + idk_linewidth, changed the code to compute the gap at the frame + edges by one pixel. + + Removed sections of code dealing with non-bitmap format, rotated or + flipped bitmaps. + + +---------------- +Installation and checkout. (12/21/89 dct) + +Installed code in gio/imdkern. +Put hooks for new task IMDKERN in the PLOT package. +Moved imdkern.par to plot, moved frame,color params to after "generic". +Deleted file imdipl.x, identical to imdpl.x. +Renamed imdfopen.x to imdopen.x for consistency with other kernels; + changed procedure name to imd_opendev to avoid name collision with imdopen. +Deleted idk.h, contains only SGI metecode defs not used in idk.x. +In t_imdkern.x, moved the clgeti's for color,frame to after the clgeti for + "generic" (required by startup protocol for graphics subkernel). For the + generic case, added initializers to set values to -1 to flag not set. + Got rid of the IS_INDEFs in idk.x. Nothing wrong with these, I just try + to avoid using INDEF in low level system code. +mkpkg - link xx_imdkern.e, not x_imdkern.e, rename in the install (this is + necessary to permit local testing of new versions, else the installed BIN + version is used). diff --git a/sys/gio/imdkern/font.com b/sys/gio/imdkern/font.com new file mode 100644 index 00000000..ec1b0ec9 --- /dev/null +++ b/sys/gio/imdkern/font.com @@ -0,0 +1,207 @@ +# CHRTAB -- Table of strokes for the printable ASCII characters. Each character +# is encoded as a series of strokes. Each stroke is expressed by a single +# integer containing the following bitfields: +# +# 2 1 +# 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 +# | | | | | | | +# | | | +---------+ +---------+ +# | | | | | +# | | | X Y +# | | | +# | | +-- pen up/down +# | +---- begin paint (not used at present) +# +------ end paint (not used at present) +# +#------------------------------------------------------------------------------ + +# Define the database. + +short chridx[96] # character index in chrtab +short chrtab[800] # stroke data to draw the characters + +# Index into CHRTAB of each printable character (starting with SP). + +data (chridx(i), i=01,05) / 1, 3, 12, 21, 30/ +data (chridx(i), i=06,10) / 45, 66, 79, 85, 92/ +data (chridx(i), i=11,15) / 99, 106, 111, 118, 121/ +data (chridx(i), i=16,20) / 128, 131, 141, 145, 154/ +data (chridx(i), i=21,25) / 168, 177, 187, 199, 203/ +data (chridx(i), i=26,30) / 221, 233, 246, 259, 263/ +data (chridx(i), i=31,35) / 268, 272, 287, 307, 314/ +data (chridx(i), i=36,40) / 327, 336, 344, 352, 359/ +data (chridx(i), i=41,45) / 371, 378, 385, 391, 398/ +data (chridx(i), i=46,50) / 402, 408, 413, 425, 433/ +data (chridx(i), i=51,55) / 445, 455, 468, 473, 480/ +data (chridx(i), i=56,60) / 484, 490, 495, 501, 506/ +data (chridx(i), i=61,65) / 511, 514, 519, 523, 526/ +data (chridx(i), i=66,70) / 529, 543, 554, 563, 574/ +data (chridx(i), i=71,75) / 585, 593, 607, 615, 625/ +data (chridx(i), i=76,80) / 638, 645, 650, 663, 671/ +data (chridx(i), i=81,85) / 681, 692, 703, 710, 723/ +data (chridx(i), i=86,90) / 731, 739, 743, 749, 754/ +data (chridx(i), i=91,95) / 759, 764, 776, 781, 793/ +data (chridx(i), i=96,96) / 801/ + +# Stroke data. + +data (chrtab(i), i=001,005) / 36, 1764, 675, 29328, 585/ +data (chrtab(i), i=006,010) / 21063, 21191, 21193, 21065, 29383/ +data (chrtab(i), i=011,015) / 1764, 355, 29023, 351, 29027/ +data (chrtab(i), i=016,020) / 931, 29599, 927, 29603, 1764/ +data (chrtab(i), i=021,025) / 603, 29066, 842, 29723, 1302/ +data (chrtab(i), i=026,030) / 28886, 143, 29839, 1764, 611/ +data (chrtab(i), i=031,035) / 29256, 78, 20810, 21322, 21581/ +data (chrtab(i), i=036,040) / 21586, 21334, 20822, 20569, 20573/ +data (chrtab(i), i=041,045) / 20833, 21345, 29789, 1764, 419/ +data (chrtab(i), i=046,050) / 20707, 20577, 20574, 20700, 20892/ +data (chrtab(i), i=051,055) / 21022, 21025, 20899, 1187, 28744/ +data (chrtab(i), i=056,060) / 717, 21194, 21320, 21512, 21642/ +data (chrtab(i), i=061,065) / 21645, 21519, 21327, 21197, 1764/ +data (chrtab(i), i=066,070) / 1160, 20700, 20704, 20835, 21027/ +data (chrtab(i), i=071,075) / 21152, 21149, 20561, 20556, 20744/ +data (chrtab(i), i=076,080) / 21192, 29841, 1764, 611, 21023/ +data (chrtab(i), i=081,085) / 21087, 21155, 21091, 1764, 739/ +data (chrtab(i), i=086,090) / 21087, 21018, 21009, 21068, 29384/ +data (chrtab(i), i=091,095) / 1764, 547, 21151, 21210, 21201/ +data (chrtab(i), i=096,100) / 21132, 29192, 1764, 93, 29774/ +data (chrtab(i), i=101,105) / 608, 29259, 78, 29789, 1764/ +data (chrtab(i), i=106,110) / 604, 29260, 84, 29780, 1764/ +data (chrtab(i), i=111,115) / 516, 21062, 21065, 21001, 21000/ +data (chrtab(i), i=116,120) / 21064, 1764, 84, 29780, 1764/ +data (chrtab(i), i=121,125) / 585, 21063, 21191, 21193, 21065/ +data (chrtab(i), i=126,130) / 21191, 1764, 72, 29859, 1764/ +data (chrtab(i), i=131,135) / 419, 20573, 20558, 20872, 21320/ +data (chrtab(i), i=136,140) / 21646, 21661, 21347, 20899, 1764/ +data (chrtab(i), i=141,145) / 221, 21155, 29320, 1764, 95/ +data (chrtab(i), i=146,150) / 20835, 21411, 21663, 21655, 20556/ +data (chrtab(i), i=151,155) / 20552, 29832, 1764, 95, 20899/ +data (chrtab(i), i=156,160) / 21347, 21663, 21658, 21334, 29270/ +data (chrtab(i), i=161,165) / 854, 5266, 21644, 21320, 20872/ +data (chrtab(i), i=166,170) / 28749, 1764, 904, 21411, 21283/ +data (chrtab(i), i=171,175) / 20561, 20559, 21391, 911, 13455/ +data (chrtab(i), i=176,180) / 1764, 136, 21320, 21645, 21652/ +data (chrtab(i), i=181,185) / 21337, 20889, 20565, 20579, 29859/ +data (chrtab(i), i=186,190) / 1764, 83, 20888, 21336, 21651/ +data (chrtab(i), i=191,195) / 21645, 21320, 20872, 20557, 20563/ +data (chrtab(i), i=196,200) / 20635, 29347, 1764, 99, 21667/ +data (chrtab(i), i=201,205) / 29064, 1764, 355, 20575, 20570/ +data (chrtab(i), i=206,210) / 20822, 20562, 20556, 20808, 21384/ +data (chrtab(i), i=211,215) / 21644, 21650, 21398, 20822, 918/ +data (chrtab(i), i=216,220) / 5274, 21663, 21411, 20835, 1764/ +data (chrtab(i), i=221,225) / 648, 21584, 21656, 21662, 21347/ +data (chrtab(i), i=226,230) / 20899, 20574, 20568, 20883, 21331/ +data (chrtab(i), i=231,235) / 21656, 1764, 602, 21210, 21207/ +data (chrtab(i), i=236,240) / 21079, 21082, 21207, 592, 21069/ +data (chrtab(i), i=241,245) / 21197, 21200, 21072, 21197, 1764/ +data (chrtab(i), i=246,250) / 602, 21146, 21143, 21079, 21082/ +data (chrtab(i), i=251,255) / 21143, 585, 21132, 21136, 21072/ +data (chrtab(i), i=256,260) / 21071, 21135, 1764, 988, 20628/ +data (chrtab(i), i=261,265) / 29644, 1764, 1112, 28824, 144/ +data (chrtab(i), i=266,270) / 29776, 1764, 156, 21460, 28812/ +data (chrtab(i), i=271,275) / 1764, 221, 20704, 20899, 21218/ +data (chrtab(i), i=276,280) / 21471, 21466, 21011, 21007, 521/ +data (chrtab(i), i=281,285) / 20999, 21127, 21129, 21001, 21127/ +data (chrtab(i), i=286,290) / 1764, 908, 20812, 20560, 20571/ +data (chrtab(i), i=291,295) / 20831, 21407, 21659, 21651, 21521/ +data (chrtab(i), i=296,300) / 21393, 21331, 21335, 21210, 21018/ +data (chrtab(i), i=301,305) / 20887, 20883, 21009, 21201, 21331/ +data (chrtab(i), i=306,310) / 1764, 72, 20963, 21219, 29768/ +data (chrtab(i), i=311,315) / 210, 5074, 1764, 99, 21411/ +data (chrtab(i), i=316,320) / 21663, 21658, 21398, 20566, 918/ +data (chrtab(i), i=321,325) / 5266, 21644, 21384, 20552, 20579/ +data (chrtab(i), i=326,330) / 1764, 1165, 21320, 20872, 20557/ +data (chrtab(i), i=331,335) / 20574, 20899, 21347, 29854, 1764/ +data (chrtab(i), i=336,340) / 99, 21347, 21662, 21645, 21320/ +data (chrtab(i), i=341,345) / 20552, 20579, 1764, 99, 20552/ +data (chrtab(i), i=346,350) / 29832, 86, 13078, 99, 29859/ +data (chrtab(i), i=351,355) / 1764, 99, 20552, 86, 13078/ +data (chrtab(i), i=356,360) / 99, 29859, 1764, 722, 21650/ +data (chrtab(i), i=361,365) / 29832, 1165, 4936, 20872, 20557/ +data (chrtab(i), i=366,370) / 20574, 20899, 21347, 29854, 1764/ +data (chrtab(i), i=371,375) / 99, 28744, 85, 5269, 1160/ +data (chrtab(i), i=376,380) / 29859, 1764, 291, 29603, 611/ +data (chrtab(i), i=381,385) / 4680, 328, 29576, 1764, 77/ +data (chrtab(i), i=386,390) / 20872, 21256, 21581, 29795, 1764/ +data (chrtab(i), i=391,395) / 99, 28744, 1160, 20887, 82/ +data (chrtab(i), i=396,400) / 13475, 1764, 99, 20552, 29832/ +data (chrtab(i), i=401,405) / 1764, 72, 20579, 21077, 21603/ +data (chrtab(i), i=406,410) / 29768, 1764, 72, 20579, 21640/ +data (chrtab(i), i=411,415) / 29859, 1764, 94, 20899, 21347/ +data (chrtab(i), i=416,420) / 21662, 21645, 21320, 20872, 20557/ +data (chrtab(i), i=421,425) / 20574, 862, 29859, 1764, 72/ +data (chrtab(i), i=426,430) / 20579, 21411, 21663, 21656, 21396/ +data (chrtab(i), i=431,435) / 20564, 1764, 94, 20557, 20872/ +data (chrtab(i), i=436,440) / 21320, 21645, 21662, 21347, 20899/ +data (chrtab(i), i=441,445) / 20574, 536, 29828, 1764, 72/ +data (chrtab(i), i=446,450) / 20579, 21411, 21663, 21657, 21398/ +data (chrtab(i), i=451,455) / 20566, 918, 13448, 1764, 76/ +data (chrtab(i), i=456,460) / 20808, 21384, 21644, 21649, 21397/ +data (chrtab(i), i=461,465) / 20822, 20570, 20575, 20835, 21411/ +data (chrtab(i), i=466,470) / 29855, 1764, 648, 21155, 99/ +data (chrtab(i), i=471,475) / 29923, 1764, 99, 20557, 20872/ +data (chrtab(i), i=476,480) / 21320, 21645, 29859, 1764, 99/ +data (chrtab(i), i=481,485) / 21064, 29795, 1764, 99, 20808/ +data (chrtab(i), i=486,490) / 21141, 21448, 29923, 1764, 99/ +data (chrtab(i), i=491,495) / 29832, 72, 29859, 1764, 99/ +data (chrtab(i), i=496,500) / 21079, 29256, 599, 13411, 1764/ +data (chrtab(i), i=501,505) / 99, 21667, 20552, 29832, 1764/ +data (chrtab(i), i=506,510) / 805, 20965, 20935, 29447, 1764/ +data (chrtab(i), i=511,515) / 99, 29832, 1764, 421, 21221/ +data (chrtab(i), i=516,520) / 21191, 29063, 1764, 288, 21091/ +data (chrtab(i), i=521,525) / 29600, 1764, 3, 29891, 1764/ +data (chrtab(i), i=526,530) / 547, 29341, 1764, 279, 21207/ +data (chrtab(i), i=531,535) / 21396, 21387, 21127, 20807, 20555/ +data (chrtab(i), i=536,540) / 20558, 20753, 21201, 21391, 907/ +data (chrtab(i), i=541,545) / 13447, 1764, 99, 28744, 76/ +data (chrtab(i), i=546,550) / 4424, 21256, 21516, 21523, 21271/ +data (chrtab(i), i=551,555) / 20823, 20563, 1764, 981, 21271/ +data (chrtab(i), i=556,560) / 20823, 20563, 20556, 20808, 21256/ +data (chrtab(i), i=561,565) / 29642, 1764, 1043, 4887, 20823/ +data (chrtab(i), i=566,570) / 20563, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=571,575) / 1032, 29731, 1764, 80, 5136/ +data (chrtab(i), i=576,580) / 21523, 21271, 20823, 20563, 20556/ +data (chrtab(i), i=581,585) / 20808, 21256, 29707, 1764, 215/ +data (chrtab(i), i=586,590) / 29591, 456, 20958, 21153, 21409/ +data (chrtab(i), i=591,595) / 29727, 1764, 67, 20800, 21248/ +data (chrtab(i), i=596,600) / 21508, 29719, 1043, 21271, 20823/ +data (chrtab(i), i=601,605) / 20563, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=606,610) / 1764, 99, 28744, 83, 4439/ +data (chrtab(i), i=611,615) / 21271, 21523, 29704, 1764, 541/ +data (chrtab(i), i=616,620) / 21019, 21147, 21149, 21021, 21147/ +data (chrtab(i), i=621,625) / 533, 21077, 29256, 1764, 541/ +data (chrtab(i), i=626,630) / 21019, 21147, 21149, 21021, 21147/ +data (chrtab(i), i=631,635) / 533, 21077, 21058, 20928, 20736/ +data (chrtab(i), i=636,640) / 28802, 1764, 99, 28744, 84/ +data (chrtab(i), i=641,645) / 29530, 342, 13320, 1764, 483/ +data (chrtab(i), i=646,650) / 21089, 21066, 29384, 1764, 87/ +data (chrtab(i), i=651,655) / 28744, 584, 21076, 84, 4375/ +data (chrtab(i), i=656,660) / 20951, 21076, 21207, 21399, 21588/ +data (chrtab(i), i=661,665) / 29768, 1764, 87, 28744, 83/ +data (chrtab(i), i=666,670) / 20823, 21271, 21523, 29704, 1764/ +data (chrtab(i), i=671,675) / 83, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=676,680) / 21523, 21271, 20823, 20563, 1764/ +data (chrtab(i), i=681,685) / 87, 28736, 83, 20823, 21271/ +data (chrtab(i), i=686,690) / 21523, 21516, 21256, 20808, 20556/ +data (chrtab(i), i=691,695) / 1764, 1047, 29696, 1036, 21256/ +data (chrtab(i), i=696,700) / 20808, 20556, 20563, 20823, 21271/ +data (chrtab(i), i=701,705) / 21523, 1764, 87, 28744, 83/ +data (chrtab(i), i=706,710) / 20823, 21271, 29716, 1764, 74/ +data (chrtab(i), i=711,715) / 20808, 21256, 21514, 21518, 21264/ +data (chrtab(i), i=716,720) / 20816, 20562, 20565, 20823, 21271/ +data (chrtab(i), i=721,725) / 21461, 1764, 279, 29591, 970/ +data (chrtab(i), i=726,730) / 21320, 21128, 21002, 21025, 1764/ +data (chrtab(i), i=731,735) / 87, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=736,740) / 1032, 29719, 1764, 151, 21064/ +data (chrtab(i), i=741,745) / 29719, 1764, 87, 20808, 21077/ +data (chrtab(i), i=746,750) / 21320, 29783, 1764, 151, 29704/ +data (chrtab(i), i=751,755) / 136, 29719, 1764, 87, 21064/ +data (chrtab(i), i=756,760) / 320, 29783, 1764, 151, 21527/ +data (chrtab(i), i=761,765) / 20616, 29704, 1764, 805, 21157/ +data (chrtab(i), i=766,770) / 21026, 21017, 20951, 20822, 20949/ +data (chrtab(i), i=771,775) / 21011, 21001, 21127, 21255, 1764/ +data (chrtab(i), i=776,780) / 611, 29273, 594, 29256, 1764/ +data (chrtab(i), i=781,785) / 485, 21093, 21218, 21209, 21271/ +data (chrtab(i), i=786,790) / 21398, 21269, 21203, 21193, 21063/ +data (chrtab(i), i=791,795) / 29127, 1764, 83, 20758, 20950/ +data (chrtab(i), i=796,800) / 21265, 21457, 29844, 1764, 0/ diff --git a/sys/gio/imdkern/font.h b/sys/gio/imdkern/font.h new file mode 100644 index 00000000..eb2e72f4 --- /dev/null +++ b/sys/gio/imdkern/font.h @@ -0,0 +1,29 @@ +# FONT.H -- Font definitions. + +define CHARACTER_START 32 +define CHARACTER_END 126 +define CHARACTER_HEIGHT 26 +define CHARACTER_WIDTH 17 + +define FONT_LEFT 0 +define FONT_CENTER 9 +define FONT_RIGHT 27 +define FONT_TOP 36 +define FONT_CAP 34 +define FONT_HALF 23 +define FONT_BASE 9 +define FONT_BOTTOM 0 +define FONT_WIDTH 27 +define FONT_HEIGHT 36 + +define COORD_X_START 7 +define COORD_Y_START 1 +define COORD_PEN_START 13 +define COORD_X_LEN 6 +define COORD_Y_LEN 6 +define COORD_PEN_LEN 1 + +define PAINT_BEGIN_START 14 +define PAINT_END_START 15 +define PAINT_BEGIN_LEN 1 +define PAINT_END_LEN 1 diff --git a/sys/gio/imdkern/idk.com b/sys/gio/imdkern/idk.com new file mode 100644 index 00000000..62e4eaf7 --- /dev/null +++ b/sys/gio/imdkern/idk.com @@ -0,0 +1,50 @@ +# IDK.COM -- The common for the IDK kernel. A common is used here for maximum +# efficiency (minimum indirection) when rasterizing vectors and encoding +# metacode. The maximum bitmap size is set at compile time in idk.h. + +# Booleans put here to avoid possible alignment problems. + +bool mf_bitmap # metafile type, metacode or bitmap +bool mf_rotate # rotate (swap x and y) +bool mf_yflip # flip y axis end for end +bool mf_update # update bitmap +bool mf_delete # delete metacode file after dispose +bool mf_debug # print kernel debugging messages +bool mf_swap2 # swap every 2 bytes on output +bool mf_swap4 # swap every 4 bytes on output +bool mf_oneperfile # store each frame in a new file + +common /idkboo/ mf_bitmap, mf_rotate, mf_yflip, mf_update, mf_delete, mf_debug, + mf_swap2, mf_swap4, mf_oneperfile + +# Everything else goes here. + +int mf_fd # image descriptor of frame buffer +int mf_frame # frame counter +char mf_fname[SZ_PATHNAME] # metafile filename +char mf_dispose[SZ_OSCMD] # host dispose command + +int mf_op # [MCODE] index into obuf +short mf_obuf[LEN_OBUF] # metacode buffer + +int mf_cx, mf_cy # [BITMAPS] current pen position +int mf_nbpb # packing factor, bits per byte +int mf_pxsize, mf_pysize # physical x, y size of bitmap, bits +int mf_wxsize, mf_wysize # x, y size of bitmap window, bits +int mf_xorigin, mf_yorigin # origin of bitmap window +real mf_xscale, mf_yscale # to convert from NDC to device coords +int mf_xmin, mf_xmax # x clipping limits +int mf_ymin, mf_ymax # y clipping limits +int mf_lenframe # frame size, words +int mf_linewidth # relative line width +int mf_lworigin # device width of line size 1.0 +real mf_lwslope # device pixels per line size increment +int mf_fbuf[LEN_FBUF] # frame buffer (BIG) +int mf_bitmask[BPW] # bit mask table +int mf_color # color index + +common /idkcom/ mf_fd, mf_frame, mf_op, mf_cx, mf_cy, mf_nbpb, mf_pxsize, + mf_pysize, mf_wxsize, mf_wysize, mf_xorigin, mf_yorigin, mf_xscale, + mf_yscale, mf_xmin, mf_xmax, mf_ymin, mf_ymax, mf_lenframe, + mf_linewidth, mf_lworigin, mf_lwslope, mf_fbuf, mf_bitmask, mf_color, + mf_obuf, mf_fname, mf_dispose diff --git a/sys/gio/imdkern/idk.x b/sys/gio/imdkern/idk.x new file mode 100644 index 00000000..4d711e12 --- /dev/null +++ b/sys/gio/imdkern/idk.x @@ -0,0 +1,509 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +.help idk +.nf --------------------------------------------------------------------------- +IDK -- Simple image display graphics interface. The purpose of this +interface is to provide a means of drawing into a graphics overlay in +an image display server via the IRAF data stream interface. The +interface works by rasterizing the GKI metacode, reading the display +frame buffer, merging the graphics raster with the frame buffer, and +writing back the raster to the frame buffer. + + g_out = idk_open (frame, color, tty) # device open + idk_close (g_out) # device close + idk_flush (g_out) # flush output + + idk_frame (g_out) # start a new frame + idk_move (g_out, x, y) # move to (x,y) + idk_draw (g_out, x, y) # draw a vector to (x,y) + idk_linewidth (g_out, width) # set line width (>=1) + +The procedures comprising the top end of the IDK interface are summarized +above and the code is included in this file. These procedures could be +rewritten by the user to talk directly to a graphics device if desired, +although the metacode file interface is likely to be simpler in most cases. + +The size of the bitmap is taken from the size of the display frame +buffer. Values of the frame buffer are set to the specified color index +for each set bitmap pixel. The final displayed color depends on the +display server. + +The following graphcap fields apply: + + DB have the kernel print debug messages during execution + LO width in device pixels of a line of size 1.0 + LS difference in device pixels between line sizes + CI color index, i.e., the frame buffer pixel value + FN display frame number + +.endhelp ---------------------------------------------------------------------- + +# NOTE -- The mf_physbit lookup table, used to map logical screen bits into +# physical bits in the bitmap (for NB != 8) is equivalenced to the mf_obuf +# array which is not otherwise used for bitmap devices. The length of the +# mf_obuf array must therefore be >= PX. + +define mf_physbit mf_obuf # union these two arrays [[[NOTE]]] +define BPW 32 # nbits in an integer +define LEN_FBUF (8192*8192/BPW) # max size bitmap / frame buffer +define LEN_OBUF 8192 # max size of buffer line +define SZ_DDSTR 256 # max size graphcap.DD +define SZ_OSCMD 256 # OS dispose command from graphcap.DD +define IOLINES 64 # image lines per i/o transfer + + +# IDK_OPEN -- Open the metacode file. Open the frame buffer as an image. +# Initialize the bitmap based on the size of the frame. + +int procedure idk_open (a_frame, a_color, tty) + +int a_color #I display device color index +int a_frame #I display buffer frame number +pointer tty #I pointer to graphcap descriptor + +real x, y +char strval[1] +int byte, off, i, j +int wcs, key, frame, color + +bool ttygetb() +real ttygetr() +int imd_mapframe(), ttygeti(), shifti(), imdrcur() +errchk imd_mapframe, ttygetr, ttygeti, ttygetb +include "idk.com" + +begin + frame = a_frame + color = a_color + + # The DB flag may be set in the graphcap entry for an IMD device to + # print debug messages during execution. + + mf_debug = ttygetb (tty, "DB") + if (mf_debug) { + call eprintf ("idk: open frame %d, color = %d\n") + call pargi (frame) + call pargi (color) + } + + mf_update = false + + # If the frame number was not specified as a parameter see if it is + # specified in the graphcap, else try to query the display to determine + # the current display frame and plot into that. + + if (frame <= 0) + iferr (frame = ttygeti (tty, "FN")) + frame = 0 + if (frame <= 0) + if (imdrcur ("stdimage", x, y, wcs, key, strval, 1, 0, NO) >= 0) + frame = max (1, wcs / 100) + else + frame = 1 + + # Find the color index in graphcap? + if (color < 0) + color = max(0, ttygeti (tty, "CI")) + + # Map the frame buffer as an image. + mf_fd = imd_mapframe (frame, READ_WRITE, YES) + + # Initialize bitmap parameters. + mf_pxsize = IM_LEN(mf_fd, 1) + mf_pysize = IM_LEN(mf_fd, 2) + mf_xorigin = 0 + mf_yorigin = 0 + mf_wxsize = IM_LEN(mf_fd, 1) - 1 + mf_wysize = IM_LEN(mf_fd, 2) - 1 + mf_nbpb = 8 + + # Line width parameters. + mf_lworigin = max (1, ttygeti (tty, "LO")) + mf_lwslope = ttygetr (tty, "LS") + + # Size of the frame buffer. + mf_lenframe = (mf_pxsize * mf_pysize + BPW-1) / BPW + + mf_color = color + mf_linewidth = mf_lworigin + + # Initial "pen" position. + mf_cx = 0 + mf_cy = 0 + + mf_xmin = mf_xorigin + mf_ymin = mf_yorigin + mf_xmax = mf_xmin + mf_wxsize + mf_ymax = mf_ymin + mf_wysize + + mf_xscale = real(mf_wxsize) / real(GKI_MAXNDC) + mf_yscale = real(mf_wysize) / real(GKI_MAXNDC) + + if (mf_lenframe > LEN_FBUF) + call error (1, "imdkern: bitmap too large") + + # Initialize the bit mask table. + do j = 1, (BPW/NBITS_BYTE) + do i = 1, NBITS_BYTE { + off = (j - 1) * NBITS_BYTE + mf_bitmask[off+i] = shifti (1, off + NBITS_BYTE - i) + } + + # Initialize the bit offset lookup table. This gives the physical + # x-offset into the lookup table of each addressable x-coordinate + # on the device. If NB is NBITS_BYTE the mapping is one-to-one. + # Note that the table contains zero-indexed bit offsets. + + do i = 1, mf_pxsize { + byte = (i - 1) / mf_nbpb + mf_physbit[i] = min (mf_pxsize, + byte * NBITS_BYTE + (i - (byte * mf_nbpb))) - 1 + } + + if (mf_debug) { + call eprintf ("bitmap [%d,%d] origin=[%d,%d] wsize=[%d,%d]\n") + call pargi (mf_pxsize); call pargi (mf_pysize) + call pargi (mf_xorigin); call pargi (mf_yorigin) + call pargi (mf_wxsize); call pargi (mf_wysize) + } + + return (mf_fd) +end + + +# IDK_CLOSE -- Update the display frame buffer and close the display. + +procedure idk_close (fd) + +int fd # output stream [NOT USED] + +errchk idk_frame, imunmap +include "idk.com" + +begin + if (mf_debug) + call eprintf ("close device\n") + + call idk_frame (mf_fd) + + if (mf_fd != NULL) { + call imunmap (mf_fd) + mf_fd = NULL + } +end + + +# IDK_FLUSH -- Flush any buffered metacode output. + +procedure idk_flush (fd) + +int fd # output stream [NOT USED] +include "idk.com" + +begin + if (mf_fd != NULL) + call imflush (mf_fd) +end + + +# IDK_FRAME -- Output a frame. Overlay the bitmap on the frame buffer. +# Map the display frame as an image section and process the bitmap line by +# line. + +procedure idk_frame (fd) + +int fd # output stream [NOT USED] + +int x1, x2, y1, y2 +int bmw # Bitmap word offset +int npix # Pixels in local I/O buffer +int fbp # Frame buffer section offset +int fbp0 +int i, j +int line +pointer ob, ib + +pointer imps2s(), imgs2s() +include "idk.com" + +begin + # Ignore frame commands if frame is empty. + if (!mf_update) + return + + if (mf_debug) { + call eprintf ("Write the frame, color = %d\n") + call pargi (mf_color) + } + + # Write the bitmap to the output frame buffer. + + y2 = 0 + for (y1=1; y2 < mf_pysize; y1=y1+IOLINES) { + # For each buffer section of the frame. + y2 = min (y1 + IOLINES-1, mf_pysize) + x1 = 1 + x2 = mf_pxsize + + # Map the frame section. + ob = imps2s (mf_fd, x1, x2, y1, y2) + ib = imgs2s (mf_fd, x1, x2, y1, y2) + + npix = mf_pxsize * (y2 - y1 + 1) + + if (ob != ib) + # Copy the input buffer to the output buffer + call amovs (Mems[ib], Mems[ob], npix) + + do line = y1, y2 { + # Each line in the local frame buffer section + fbp0 = (line - y1) * mf_pxsize + + do i = 1, mf_pxsize / BPW { + # Each word in the bitmap line. + bmw = (line - 1) * mf_pxsize / BPW + i + + if (mf_fbuf[bmw] != 0) { + do j = 1, BPW { + # Each bit in the bitmap word. + + if (and (mf_fbuf[bmw], mf_bitmask[j]) != 0) { + # An ON bit. + fbp = fbp0 + (i-1) * BPW + j + Mems[ob+fbp-1] = mf_color + } + } + } + } + } + } + + mf_update = false +end + + +# IDK_MOVE -- Output a pen move instruction. + +procedure idk_move (fd, x, y) + +int fd # output stream [NOT USED] +int x, y # point to move to + +include "idk.com" + +begin + mf_cx = x + mf_cy = y + + # Convert to zero indexed coordinates and clip at boundary. + # Allow room for line width shift near boundary. + + mf_cx = max (mf_xmin, min (mf_xmax, + int (mf_cx * mf_xscale) + mf_xorigin)) + mf_cy = max (mf_ymin, min (mf_ymax, + int (mf_cy * mf_yscale) + mf_yorigin)) +end + + +# IDK_DRAW -- Output a pen draw instruction. + +procedure idk_draw (fd, a_x, a_y) + +int fd # output stream [NOT USED] +int a_x, a_y # point to draw to + +int xshift, yshift, dx, dy +int new_x, new_y, x1, y1, x2, y2, n, i +include "idk.com" + +begin + new_x = a_x + new_y = a_y + + if (!mf_update) { + # We are called when the first drawing instruction is output for a + # new frame. We clear the bitmap. + + # Zero out all the bits in a bitmap. + call aclri (mf_fbuf, mf_lenframe) + + mf_update = true + } + + # Convert to zero indexed coordinates and clip at boundary. + # Allow room for line width shift near boundary. + + new_x = max (mf_xmin, min (mf_xmax, + int (new_x * mf_xscale) + mf_xorigin)) + new_y = max (mf_ymin, min (mf_ymax, + int (new_y * mf_yscale) + mf_yorigin)) + + if (mf_linewidth <= 1) + call idk_vector (mf_cx, mf_cy, new_x, new_y) + else { + # Redraw the vector several times with small normal shifts to + # produce a wider line. + + xshift = 0 + yshift = 0 + + if (abs (new_x - mf_cx) > abs (new_y - mf_cy)) { + dx = 0 + dy = 1 + } else { + dx = 1 + dy = 0 + } + + do i = 1, mf_linewidth { + x1 = mf_cx + xshift + y1 = mf_cy + yshift + x2 = new_x + xshift + y2 = new_y + yshift + + call idk_vector (x1, y1, x2, y2) + + n = (i + 1) / 2 + if (and (i, 1) == 0) { + xshift = dx * n + yshift = dy * n + } else { + xshift = -dx * n + yshift = -dy * n + } + } + } + + # Update the current pen position, and set the update flag so that + # the bitmap will be written to the output file. + + mf_cx = new_x + mf_cy = new_y +end + + +# IDK_VECTOR -- Write a vector (line) of unit width into the bitmap. The line +# endpoints are expressed in physical device coordinates. + +procedure idk_vector (a_x1, a_y1, a_x2, a_y2) + +int a_x1, a_y1 # start point of line +int a_x2, a_y2 # end point of line + +real dydx, dxdy +long fbit, wbit, word +int wpln, mask, dx, dy, x, y, x1, y1, x2, y2, or() +include "idk.com" + +begin + x1 = a_x1; y1 = a_y1 + x2 = a_x2; y2 = a_y2 + + dx = x2 - x1 + dy = y2 - y1 + + if (abs(dx) > abs(dy)) { + if (x1 > x2) { + x1 = a_x2; x2 = a_x1; dx = -dx + y1 = a_y2; y2 = a_y1; dy = -dy + } + + if (dy == 0 && mf_nbpb == NBITS_BYTE) { + # Somewhat optimized code for the case of a horiz. vector. + + fbit = y1 * mf_pxsize + x1 + word = fbit / BPW + wbit = and (fbit, BPW-1) + + do x = x1, x2 { + mf_fbuf[word+1] = or (mf_fbuf[word+1], mf_bitmask[wbit+1]) + wbit = wbit + 1 + if (wbit >= BPW) { + wbit = 0 + word = word + 1 + } + } + + } else { + # The general case for a mostly-X vector. + + dydx = real(dy) / real(dx) + do x = x1, x2 { + y = int ((x - x1) * dydx) + y1 + fbit = y * mf_pxsize + mf_physbit[x+1] + word = fbit / BPW + wbit = and (fbit, BPW-1) + mf_fbuf[word+1] = or (mf_fbuf[word+1], mf_bitmask[wbit+1]) + } + } + + } else if (dy != 0) { + if (y1 > y2) { + x1 = a_x2; x2 = a_x1; dx = -dx + y1 = a_y2; y2 = a_y1; dy = -dy + } + + if (dx == 0) { + # Optimized code for the case of a vertical vector. + + fbit = y1 * mf_pxsize + mf_physbit[x1+1] + word = fbit / BPW + 1 + wbit = and (fbit, BPW-1) + wpln = (mf_pxsize + BPW-1) / BPW + mask = mf_bitmask[wbit+1] + + do y = y1, y2 { + mf_fbuf[word] = or (mf_fbuf[word], mask) + word = word + wpln + } + + } else { + # The general case of a mostly-Y vector. + + dxdy = real(dx) / real(dy) + do y = y1, y2 { + x = int ((y - y1) * dxdy) + x1 + fbit = y * mf_pxsize + mf_physbit[x+1] + word = fbit / BPW + wbit = and (fbit, BPW-1) + mf_fbuf[word+1] = or (mf_fbuf[word+1], mf_bitmask[wbit+1]) + } + } + + } else { + # Plot a single point (dx=dy=0). + + fbit = y1 * mf_pxsize + mf_physbit[x1+1] + word = fbit / BPW + wbit = and (fbit, BPW-1) + mf_fbuf[word+1] = or (mf_fbuf[word+1], mf_bitmask[wbit+1]) + } +end + + +# IDK_LINEWIDTH -- Output a line width set instruction. + +procedure idk_linewidth (fd, width) + +int fd # output stream [NOT USED] +int width # new line width + +int gap +include "idk.com" + +begin + # Set the line width in device pixels. + mf_linewidth = max (1, mf_lworigin + int ((width-1) * mf_lwslope)) + + # Set the clipping limits. Allow for shifting to widen lines. + gap = mf_linewidth / 2 + mf_xmin = mf_xorigin + gap + mf_ymin = mf_yorigin + gap + mf_xmax = mf_xorigin + mf_wxsize - gap + mf_ymax = mf_yorigin + mf_wysize - gap +end diff --git a/sys/gio/imdkern/imd.com b/sys/gio/imdkern/imd.com new file mode 100644 index 00000000..12cba65e --- /dev/null +++ b/sys/gio/imdkern/imd.com @@ -0,0 +1,18 @@ +# IMD common. A common is necessary since there is no graphics descriptor +# in the argument list of the kernel procedures. The stdgraph data structures +# are designed along the lines of FIO: a small common is used to hold the time +# critical data elements, and an auxiliary dynamically allocated descriptor is +# used for everything else. + +pointer g_kt # kernel transform graphics descriptor +pointer g_tty # graphcap descriptor +int g_nframes # number of frames written +int g_maxframes # max frames per device metafile +int g_ndraw # no draw instr. in current frame +int g_in, g_out # input, output files +int g_xres, g_yres # desired device resolution +int g_frame, g_color # display frame and graphics color +char g_device[SZ_GDEVICE] # force output to named device + +common /gioimd/ g_kt, g_tty, g_nframes, g_maxframes, g_ndraw, + g_in, g_out, g_xres, g_yres, g_frame, g_color, g_device diff --git a/sys/gio/imdkern/imd.h b/sys/gio/imdkern/imd.h new file mode 100644 index 00000000..a0e5d2d5 --- /dev/null +++ b/sys/gio/imdkern/imd.h @@ -0,0 +1,77 @@ +# IMD global definitions. + +define MAX_CHARSIZES 10 # max discreet device char sizes +define SZ_SBUF 1024 # initial string buffer size +define SZ_GDEVICE 31 # maxsize forced device name +define DEF_MAXFRAMES 16 # maximum frames/metafile + +# The IMD state/device descriptor. + +define LEN_IMD 81 + +define IMD_SBUF Memi[$1] # string buffer +define IMD_SZSBUF Memi[$1+1] # size of string buffer +define IMD_NEXTCH Memi[$1+2] # next char pos in string buf +define IMD_NCHARSIZES Memi[$1+3] # number of character sizes +define IMD_POLYLINE Memi[$1+4] # device supports polyline +define IMD_POLYMARKER Memi[$1+5] # device supports polymarker +define IMD_FILLAREA Memi[$1+6] # device supports fillarea +define IMD_CELLARRAY Memi[$1+7] # device supports cell array +define IMD_XRES Memi[$1+8] # device resolution in X +define IMD_YRES Memi[$1+9] # device resolution in Y +define IMD_ZRES Memi[$1+10] # device resolution in Z +define IMD_FILLSTYLE Memi[$1+11] # number of fill styles +define IMD_ROAM Memi[$1+12] # device supports roam +define IMD_ZOOM Memi[$1+13] # device supports zoom +define IMD_SELERASE Memi[$1+14] # device has selective erase +define IMD_PIXREP Memi[$1+15] # device supports pixel replic. +define IMD_STARTFRAME Memi[$1+16] # frame advance at metafile BOF +define IMD_ENDFRAME Memi[$1+17] # frame advance at metafile EOF + # extra space +define IMD_CURSOR Memi[$1+20] # last cursor accessed +define IMD_COLOR Memi[$1+21] # last color set +define IMD_TXSIZE Memi[$1+22] # last text size set +define IMD_TXFONT Memi[$1+23] # last text font set +define IMD_TYPE Memi[$1+24] # last line type set +define IMD_WIDTH Memi[$1+25] # last line width set +define IMD_DEVNAME Memi[$1+26] # name of open device +define IMD_FRAME Memi[$1+27] # frame buffer number + # extra space +define IMD_CHARHEIGHT Memi[$1+30+$2-1] # character height +define IMD_CHARWIDTH Memi[$1+40+$2-1] # character width +define IMD_CHARSIZE Memr[P2R($1+50+$2-1)] # text sizes permitted +define IMD_PLAP ($1+60) # polyline attributes +define IMD_PMAP ($1+64) # polymarker attributes +define IMD_FAAP ($1+68) # fill area attributes +define IMD_TXAP ($1+71) # default text attributes + +# Substructure definitions. + +define LEN_PL 4 +define PL_STATE Memi[$1] # polyline attributes +define PL_LTYPE Memi[$1+1] +define PL_WIDTH Memi[$1+2] +define PL_COLOR Memi[$1+3] + +define LEN_PM 4 +define PM_STATE Memi[$1] # polymarker attributes +define PM_LTYPE Memi[$1+1] +define PM_WIDTH Memi[$1+2] +define PM_COLOR Memi[$1+3] + +define LEN_FA 3 # fill area attributes +define FA_STATE Memi[$1] +define FA_STYLE Memi[$1+1] +define FA_COLOR Memi[$1+2] + +define LEN_TX 10 # text attributes +define TX_STATE Memi[$1] +define TX_UP Memi[$1+1] +define TX_SIZE Memi[$1+2] +define TX_PATH Memi[$1+3] +define TX_SPACING Memr[P2R($1+4)] +define TX_HJUSTIFY Memi[$1+5] +define TX_VJUSTIFY Memi[$1+6] +define TX_FONT Memi[$1+7] +define TX_QUALITY Memi[$1+8] +define TX_COLOR Memi[$1+9] diff --git a/sys/gio/imdkern/imdcancel.x b/sys/gio/imdkern/imdcancel.x new file mode 100644 index 00000000..68832ae4 --- /dev/null +++ b/sys/gio/imdkern/imdcancel.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imd.h" + +# IMD_CANCEL -- Cancel any buffered output. + +procedure imd_cancel (dummy) + +int dummy # not used at present +include "imd.com" + +begin + if (g_kt == NULL) + return + call imd_reset() +end diff --git a/sys/gio/imdkern/imdclear.x b/sys/gio/imdkern/imdclear.x new file mode 100644 index 00000000..bf471998 --- /dev/null +++ b/sys/gio/imdkern/imdclear.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imd.h" + +# IMD_CLEAR -- Advance a frame on the plotter. All attribute packets are +# initialized to their default values. Redundant calls or calls immediately +# after a workstation open (before anything has been drawn) are ignored. + +procedure imd_clear (dummy) + +int dummy # not used at present + +int idk_open() +errchk idk_open +include "imd.com" + +begin + # This is a no-op if nothing has been drawn. + if (g_kt == NULL || g_ndraw == 0) + return + + # Start a new frame. This is done either by issuing the frame advance + # instruction or by starting a new metafile. Close the output file and + # start a new metafile if the maximum frame count has been reached. + # This disposes of the metafile to the system, causing the actual + # plots to be drawn. Open a new metafile ready to receive next frame. + + g_nframes = g_nframes + 1 + if (g_nframes >= g_maxframes) { + + # Does this device require a frame advance at end of metafile? + if (IMD_ENDFRAME(g_kt) == YES) + call idk_frame (g_out) + + g_nframes = 0 + call idk_close (g_out) + #g_out = idk_open (Memc[IMD_DEVNAME(g_kt)], g_tty) + g_out = idk_open (g_frame, g_color, g_tty) + + # Does this device require a frame advance at beginning of metafile? + if (IMD_STARTFRAME(g_kt) == YES) + call idk_frame (g_out) + + } else { + # Merely output frame instruction to start a new frame in the same + # metafile. + + call idk_frame (g_out) + } + + # Init kernel data structures. + call imd_reset() + g_ndraw = 0 +end diff --git a/sys/gio/imdkern/imdclose.x b/sys/gio/imdkern/imdclose.x new file mode 100644 index 00000000..7283f5db --- /dev/null +++ b/sys/gio/imdkern/imdclose.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imd.h" + +# IMD_CLOSE -- Close the IMD translation kernel. Close the spool file so +# the output is finally plotted. Free up storage. + +procedure imd_close() + +include "imd.com" + +begin + # Check for a redundant imd_close call. + if (g_kt == NULL) + return + + # If there is anything in the metafile, flush it and add a frame + # advance if required for the device. + + if (g_ndraw > 0 || g_nframes > 0) { + # Does this device require a frame advance at end of metafile? + if (IMD_ENDFRAME(g_kt) == YES) + call idk_frame (g_out) + } + + # Close output metafile, disposing of it to the host system. + call idk_close (g_out) + + # Return tty descriptor. + call ttycdes (g_tty) + + # Free kernel data structures. + call mfree (IMD_SBUF(g_kt), TY_CHAR) + call mfree (g_kt, TY_STRUCT) + + g_kt = NULL +end diff --git a/sys/gio/imdkern/imdclws.x b/sys/gio/imdkern/imdclws.x new file mode 100644 index 00000000..45072697 --- /dev/null +++ b/sys/gio/imdkern/imdclws.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imd.h" + +# IMD_CLOSEWS -- Close the named workstation. Flush the output. +# The spool file is closed only on the next plot or at gktclose time. +# If the spool file is closed here, APPEND mode would not work. + +procedure imd_closews (devname, n) + +short devname[ARB] # device name (not used) +int n # length of device name +include "imd.com" + +begin + # For the IMD kernel, all display graphics writes are in append mode, + # so we may as well shutdown completely for closews (this also ensures + # that the display is updated at closews time). + + #call idk_flush (g_out) + call imd_close() +end diff --git a/sys/gio/imdkern/imdcolor.x b/sys/gio/imdkern/imdcolor.x new file mode 100644 index 00000000..581af9a2 --- /dev/null +++ b/sys/gio/imdkern/imdcolor.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imd.h" + +# IMD_COLOR -- Set line drawing color. + +procedure imd_color (index) + +int index # index for color switch statement +include "imd.com" + +begin + # switch (index) { + # case WHITE: + # case RED: + # case GREEN: + # case BLUE: + # default: + # } +end diff --git a/sys/gio/imdkern/imddrawch.x b/sys/gio/imdkern/imddrawch.x new file mode 100644 index 00000000..17327563 --- /dev/null +++ b/sys/gio/imdkern/imddrawch.x @@ -0,0 +1,70 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "imd.h" +include "font.h" + +define ITALIC_TILT 0.30 # fraction of xsize to tilt italics at top + + +# IMD_DRAWCHAR -- Draw a character of the given size and orientation at the +# given position. + +procedure imd_drawchar (ch, x, y, xsize, ysize, orien, font) + +char ch # character to be drawn +int x, y # lower left GKI coords of character +int xsize, ysize # width, height of char in GKI units +int orien # orientation of character (0 degrees normal) +int font # desired character font + +int mx, my +real px, py, coso, sino, theta +int stroke, tab1, tab2, i, pen +int bitupk() +include "font.com" +include "imd.com" + +begin + if (ch < CHARACTER_START || ch > CHARACTER_END) + i = '?' - CHARACTER_START + 1 + else + i = ch - CHARACTER_START + 1 + + # Set the font. + call imd_font (font) + + tab1 = chridx[i] + tab2 = chridx[i+1] - 1 + + theta = -DEGTORAD(orien) + coso = cos(theta) + sino = sin(theta) + + do i = tab1, tab2 { + stroke = chrtab[i] + px = bitupk (stroke, COORD_X_START, COORD_X_LEN) + py = bitupk (stroke, COORD_Y_START, COORD_Y_LEN) + pen = bitupk (stroke, COORD_PEN_START, COORD_PEN_LEN) + + # Scale size of character. + px = px / FONT_WIDTH * xsize + py = py / FONT_HEIGHT * ysize + + # The italic font is implemented applying a tilt. + if (font == GT_ITALIC) + px = px + ((py / ysize) * xsize * ITALIC_TILT) + + # Rotate and shift. + mx = x + px * coso + py * sino + my = y - px * sino + py * coso + + # Draw the line segment or move pen. + if (pen == 0) + call idk_move (g_out, mx, my) + else + call idk_draw (g_out, mx, my) + } +end diff --git a/sys/gio/imdkern/imdescape.x b/sys/gio/imdkern/imdescape.x new file mode 100644 index 00000000..2c2c3a26 --- /dev/null +++ b/sys/gio/imdkern/imdescape.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMD_ESCAPE -- Pass a device dependent instruction on to the kernel. +# The IDK kernel does not have any escape functions at present. + +procedure imd_escape (fn, instruction, nwords) + +int fn # function code +short instruction[ARB] # instruction data words +int nwords # length of instruction + +begin +end diff --git a/sys/gio/imdkern/imdfa.x b/sys/gio/imdkern/imdfa.x new file mode 100644 index 00000000..03bf446e --- /dev/null +++ b/sys/gio/imdkern/imdfa.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imd.h" + +# IMD_FILLAREA -- Fill a closed area. + +procedure imd_fillarea (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs +include "imd.com" + +begin + # Not implemented yet. + call imd_polyline (p, npts) +end diff --git a/sys/gio/imdkern/imdfaset.x b/sys/gio/imdkern/imdfaset.x new file mode 100644 index 00000000..b790cef9 --- /dev/null +++ b/sys/gio/imdkern/imdfaset.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imd.h" + +# IMD_FASET -- Set the fillarea attributes. + +procedure imd_faset (gki) + +short gki[ARB] # attribute structure +pointer fa +include "imd.com" + +begin + fa = IMD_FAAP(g_kt) + FA_STYLE(fa) = gki[GKI_FASET_FS] + FA_COLOR(fa) = gki[GKI_FASET_CI] +end diff --git a/sys/gio/imdkern/imdflush.x b/sys/gio/imdkern/imdflush.x new file mode 100644 index 00000000..d22f04c9 --- /dev/null +++ b/sys/gio/imdkern/imdflush.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imd.h" + +# IMD_FLUSH -- Flush output. + +procedure imd_flush (dummy) + +int dummy # not used at present +include "imd.com" + +begin + call idk_flush (g_out) +end diff --git a/sys/gio/imdkern/imdfont.x b/sys/gio/imdkern/imdfont.x new file mode 100644 index 00000000..3117258b --- /dev/null +++ b/sys/gio/imdkern/imdfont.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "imd.h" + +# IMD_FONT -- Set the character font. The roman font is normal. Bold is +# implemented by increasing the vector line width; care must be taken to +# set IMD_WIDTH so that the other vector drawing procedures remember to +# change the width back. The italic font is implemented in the character +# generator by a geometric transformation. + +procedure imd_font (font) + +int font # code for font to be set +int pk2, width +include "imd.com" + +begin + width = IMD_WIDTH(g_kt) + pk2 = GKI_PACKREAL(2.0) + + if (font == GT_BOLD) { + if (width != pk2) { + call idk_linewidth (g_out, 2) + width = pk2 + } + } else + call idk_linewidth (g_out, nint (GKI_UNPACKREAL(width))) + + IMD_WIDTH(g_kt) = width +end diff --git a/sys/gio/imdkern/imdgcell.x b/sys/gio/imdkern/imdgcell.x new file mode 100644 index 00000000..0c384d70 --- /dev/null +++ b/sys/gio/imdkern/imdgcell.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMD_GETCELLARRAY -- Input a cell array, i.e., two dimensional array of pixels +# (greylevels or colors). + +procedure imd_getcellarray (nx, ny, x1,y1, x2,y2) + +int nx, ny # number of pixels in X and Y +int x1, y1 # lower left corner of input window +int x2, y2 # lower left corner of input window + +begin + # Not implemented yet. +end diff --git a/sys/gio/imdkern/imdinit.x b/sys/gio/imdkern/imdinit.x new file mode 100644 index 00000000..ceed3948 --- /dev/null +++ b/sys/gio/imdkern/imdinit.x @@ -0,0 +1,162 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "imd.h" + +# IMD_INIT -- Initialize the gkt data structures from the graphcap entry +# for the device. Called once, at OPENWS time, with the TTY pointer already +# set in the common. The companion routine IMD_RESET initializes the attribute +# packets when the frame is flushed. + +procedure imd_init (tty, devname) + +pointer tty # graphcap descriptor +char devname[ARB] # device name + +pointer nextch +int maxch, i +real char_height, char_width, char_size + +bool ttygetb() +real ttygetr() +int ttygeti(), btoi(), gstrcpy() +include "imd.com" + +begin + # Allocate the gkt descriptor and the string buffer. + if (g_kt == NULL) { + call calloc (g_kt, LEN_IMD, TY_STRUCT) + call malloc (IMD_SBUF(g_kt), SZ_SBUF, TY_CHAR) + } + + # Get the maximum frame count and the flags controlling frame advance + # at start and end of metafile. + + g_maxframes = ttygeti (tty, "MF") + if (g_maxframes == 0) + g_maxframes = DEF_MAXFRAMES + IMD_STARTFRAME(g_kt) = btoi (ttygetb (tty, "FS")) + IMD_ENDFRAME(g_kt) = btoi (ttygetb (tty, "FE")) + + # Init string buffer parameters. The first char of the string buffer + # is reserved as a null string, used for graphcap control strings + # omitted from the graphcap entry for the device. + + IMD_SZSBUF(g_kt) = SZ_SBUF + IMD_NEXTCH(g_kt) = IMD_SBUF(g_kt) + 1 + Memc[IMD_SBUF(g_kt)] = EOS + + # Get the device resolution from the graphcap entry. + + g_xres = ttygeti (tty, "xr") + if (g_xres <= 0) + g_xres = 1024 + g_yres = ttygeti (tty, "yr") + if (g_yres <= 0) + g_yres = 1024 + + # Initialize the character scaling parameters, required for text + # generation. The heights are given in NDC units in the graphcap + # file, which we convert to GKI units. Estimated values are + # supplied if the parameters are missing in the graphcap entry. + + char_height = ttygetr (tty, "ch") + if (char_height < EPSILON) + char_height = 1.0 / 35.0 + char_height = char_height * GKI_MAXNDC + + char_width = ttygetr (tty, "cw") + if (char_width < EPSILON) + char_width = 1.0 / 80.0 + char_width = char_width * GKI_MAXNDC + + # If the device has a set of discreet character sizes, get the + # size of each by fetching the parameter "tN", where the N is + # a digit specifying the text size index. Compute the height and + # width of each size character from the "ch" and "cw" parameters + # and the relative scale of character size I. + + IMD_NCHARSIZES(g_kt) = min (MAX_CHARSIZES, ttygeti (tty, "th")) + nextch = IMD_NEXTCH(g_kt) + + if (IMD_NCHARSIZES(g_kt) <= 0) { + IMD_NCHARSIZES(g_kt) = 1 + IMD_CHARSIZE(g_kt,1) = 1.0 + IMD_CHARHEIGHT(g_kt,1) = char_height + IMD_CHARWIDTH(g_kt,1) = char_width + } else { + Memc[nextch+2] = EOS + for (i=1; i <= IMD_NCHARSIZES(g_kt); i=i+1) { + Memc[nextch] = 't' + Memc[nextch+1] = TO_DIGIT(i) + char_size = ttygetr (tty, Memc[nextch]) + IMD_CHARSIZE(g_kt,i) = char_size + IMD_CHARHEIGHT(g_kt,i) = char_height * char_size + IMD_CHARWIDTH(g_kt,i) = char_width * char_size + } + } + + # Initialize the output parameters. All boolean parameters are stored + # as integer flags. All string valued parameters are stored in the + # string buffer, saving a pointer to the string in the gkt + # descriptor. If the capability does not exist the pointer is set to + # point to the null string at the beginning of the string buffer. + + IMD_POLYLINE(g_kt) = btoi (ttygetb (tty, "pl")) + IMD_POLYMARKER(g_kt) = btoi (ttygetb (tty, "pm")) + IMD_FILLAREA(g_kt) = btoi (ttygetb (tty, "fa")) + IMD_FILLSTYLE(g_kt) = ttygeti (tty, "fs") + IMD_ROAM(g_kt) = btoi (ttygetb (tty, "ro")) + IMD_ZOOM(g_kt) = btoi (ttygetb (tty, "zo")) + IMD_XRES(g_kt) = ttygeti (tty, "xr") + IMD_YRES(g_kt) = ttygeti (tty, "yr") + IMD_ZRES(g_kt) = ttygeti (tty, "zr") + IMD_CELLARRAY(g_kt) = btoi (ttygetb (tty, "ca")) + IMD_SELERASE(g_kt) = btoi (ttygetb (tty, "se")) + IMD_PIXREP(g_kt) = btoi (ttygetb (tty, "pr")) + + # Initialize the input parameters. + + IMD_CURSOR(g_kt) = 1 + + # Save the device string in the descriptor. + nextch = IMD_NEXTCH(g_kt) + IMD_DEVNAME(g_kt) = nextch + maxch = IMD_SBUF(g_kt) + SZ_SBUF - nextch + 1 + nextch = nextch + gstrcpy (devname, Memc[nextch], maxch) + 1 + IMD_NEXTCH(g_kt) = nextch +end + + +# IMD_GSTRING -- Get a string value parameter from the graphcap table, +# placing the string at the end of the string buffer. If the device does +# not have the named capability return a pointer to the null string, +# otherwise return a pointer to the string. Since pointers are used, +# rather than indices, the string buffer is fixed in size. The additional +# degree of indirection required with an index was not considered worthwhile +# in this application since the graphcap entries are never very large. + +pointer procedure imd_gstring (cap) + +char cap[ARB] # device capability to be fetched +pointer strp, nextch +int maxch, nchars +int ttygets() +include "imd.com" + +begin + nextch = IMD_NEXTCH(g_kt) + maxch = IMD_SBUF(g_kt) + SZ_SBUF - nextch + 1 + + nchars = ttygets (g_tty, cap, Memc[nextch], maxch) + if (nchars > 0) { + strp = nextch + nextch = nextch + nchars + 1 + } else + strp = IMD_SBUF(g_kt) + + IMD_NEXTCH(g_kt) = nextch + return (strp) +end diff --git a/sys/gio/imdkern/imdline.x b/sys/gio/imdkern/imdline.x new file mode 100644 index 00000000..86f32c0a --- /dev/null +++ b/sys/gio/imdkern/imdline.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imd.h" + +# IMD_LINETYPE -- Set the line type option. + +procedure imd_linetype (index) + +int index # index for line type switch statement + +int linetype +include "imd.com" + +begin + switch (index) { + case GL_CLEAR: + linetype = 0 + case GL_DASHED: + linetype = 2 + case GL_DOTTED: + linetype = 3 + case GL_DOTDASH: + linetype = 4 + default: + linetype = 1 # solid + } + + # This will be done in software in a future version of the IMD kernel. + # call idk_linetype (g_out, linetype) +end diff --git a/sys/gio/imdkern/imdopen.x b/sys/gio/imdkern/imdopen.x new file mode 100644 index 00000000..2a563360 --- /dev/null +++ b/sys/gio/imdkern/imdopen.x @@ -0,0 +1,81 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imd.h" + +# IMD_OPENDEV -- Install the IMD kernel as a graphics kernel device driver. +# The device table DD consists of an array of the entry point addresses for +# the driver procedures. If a driver does not implement a particular +# instruction the table entry for that procedure may be set to zero, causing +# the interpreter to ignore the instruction. + +procedure imd_opendev (devname, frame, color, dd) + +char devname[ARB] # nonnull for forced output to a device +int frame # display frame buffer number +int color # graphics overlay color index +int dd[ARB] # device table to be initialized + +pointer sp, devns +int len_devname +int locpr(), strlen() +extern imd_openws(), imd_closews(), imd_clear(), imd_cancel() +extern imd_flush(), imd_polyline(), imd_polymarker(), imd_text() +extern imd_fillarea(), imd_putcellarray(), imd_plset() +extern imd_pmset(), imd_txset(), imd_faset() +extern imd_escape() +include "imd.com" + +begin + call smark (sp) + call salloc (devns, SZ_FNAME, TY_SHORT) + + # Flag first pass. Save forced device name in common for OPENWS. + # Zero the frame and instruction counters. + + g_kt = NULL + g_nframes = 0 + g_ndraw = 0 + g_frame = frame + g_color = color + call strcpy (devname, g_device, SZ_GDEVICE) + + # Install the device driver. + + dd[GKI_OPENWS] = locpr (imd_openws) + dd[GKI_CLOSEWS] = locpr (imd_closews) + dd[GKI_DEACTIVATEWS] = 0 + dd[GKI_REACTIVATEWS] = 0 + dd[GKI_MFTITLE] = 0 + dd[GKI_CLEAR] = locpr (imd_clear) + dd[GKI_CANCEL] = locpr (imd_cancel) + dd[GKI_FLUSH] = locpr (imd_flush) + dd[GKI_POLYLINE] = locpr (imd_polyline) + dd[GKI_POLYMARKER] = locpr (imd_polymarker) + dd[GKI_TEXT] = locpr (imd_text) + dd[GKI_FILLAREA] = locpr (imd_fillarea) + dd[GKI_PUTCELLARRAY] = locpr (imd_putcellarray) + dd[GKI_SETCURSOR] = 0 + dd[GKI_PLSET] = locpr (imd_plset) + dd[GKI_PMSET] = locpr (imd_pmset) + dd[GKI_TXSET] = locpr (imd_txset) + dd[GKI_FASET] = locpr (imd_faset) + dd[GKI_GETCURSOR] = 0 + dd[GKI_GETCELLARRAY] = 0 + dd[GKI_ESCAPE] = locpr (imd_escape) + dd[GKI_SETWCS] = 0 + dd[GKI_GETWCS] = 0 + dd[GKI_UNKNOWN] = 0 + + # If a device was named open the workstation as well. This is + # necessary to permit processing of metacode files which do not + # contain the open workstation instruction. + + len_devname = strlen (devname) + if (len_devname > 0) { + call achtcs (devname, Mems[devns], len_devname) + call imd_openws (Mems[devns], len_devname, NEW_FILE) + } + + call sfree (sp) +end diff --git a/sys/gio/imdkern/imdopenws.x b/sys/gio/imdkern/imdopenws.x new file mode 100644 index 00000000..cdfaeee0 --- /dev/null +++ b/sys/gio/imdkern/imdopenws.x @@ -0,0 +1,98 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "imd.h" + +# IMD_OPENWS -- Open the named workstation. Once a workstation has been +# opened we leave it open until some other workstation is opened or the +# kernel is closed. Opening a workstation involves initialization of the +# kernel data structures, following by initialization of the device itself. + +procedure imd_openws (devname, n, mode) + +short devname[ARB] # device name +int n # length of device name +int mode # access mode + +pointer sp, buf +pointer ttygdes() +bool streq() +int idk_open() +bool need_open, same_dev +include "imd.com" + +begin + call smark (sp) + call salloc (buf, max (SZ_FNAME, n), TY_CHAR) + + # If a device was named when the kernel was opened then output will + # always go to that device (g_device) regardless of the device named + # in the OPENWS instruction. If no device was named (null string) + # then unpack the device name, passed as a short integer array. + + if (g_device[1] == EOS) { + call achtsc (devname, Memc[buf], n) + Memc[buf+n] = EOS + } else + call strcpy (g_device, Memc[buf], SZ_FNAME) + + # Find out if first time, and if not, if same device as before + # note that if (g_kt == NULL), then same_dev is false. + + same_dev = false + need_open = true + + if (g_kt != NULL) { + same_dev = (streq (Memc[IMD_DEVNAME(g_kt)], Memc[buf])) + if (!same_dev) { + # Does this device require a frame advance at end of metafile? + if (IMD_ENDFRAME(g_kt) == YES) + call idk_frame (g_out) + call idk_close (g_out) + } else + need_open = false + } + + # Initialize the kernel data structures. Open graphcap descriptor + # for the named device, allocate and initialize descriptor and common. + # graphcap entry for device must exist. + + if (need_open) { + if (!same_dev) { + if (g_kt != NULL) + call ttycdes (g_tty) + iferr (g_tty = ttygdes (Memc[buf])) + call erract (EA_ERROR) + + # Initialize data structures if we had to open a new device. + call imd_init (g_tty, Memc[buf]) + call imd_reset() + } + + # Open the output file. Metacode output to the device will be + # spooled and then disposed of to the device at CLOSEWS time. + + iferr (g_out = idk_open (g_frame, g_color, g_tty)) { + call ttycdes (g_tty) + call erract (EA_ERROR) + } else { + # Does this device require a frame advance at start of metafile? + if (IMD_STARTFRAME(g_kt) == YES) + call idk_frame (g_out) + g_nframes = 0 + g_ndraw = 0 + } + } + + # Clear the screen if device is being opened in new_file mode. + # This is a nop if we really opened a new device, but it will clear + # the screen if this is just a reopen of the same device in new file + # mode. + + if (mode == NEW_FILE) + call imd_clear (0) + + call sfree (sp) +end diff --git a/sys/gio/imdkern/imdpcell.x b/sys/gio/imdkern/imdpcell.x new file mode 100644 index 00000000..deb61d18 --- /dev/null +++ b/sys/gio/imdkern/imdpcell.x @@ -0,0 +1,195 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imd.h" + +define DEF_YRES 8192 # default height of device pixel in GKI units +define ZSTEP 4 # bit to be tested (step function width) + + +# IMD_PUTCELLARRAY -- Draw a cell array, i.e., two dimensional array of pixels +# (greylevels or colors). The algorithm used here maps 8 bits in into 1 bit +# out, using a step function lookup table. The result is a band-contoured +# image, where the spacing and width of the contour bands decreases as the +# rate of change of intensity in the input cell array increases. + +procedure imd_putcellarray (m, nx, ny, ax1,ay1, ax2,ay2) + +short m[nx,ny] # cell array +int nx, ny # number of pixels in X and Y +int ax1, ay1 # lower left corner of output window +int ax2, ay2 # upper right corner of output window + +bool ttygetb() +include "imd.com" + +begin + if (ttygetb (g_tty, "BI")) + call imd_bcell (m, nx, ny, ax1,ay1, ax2,ay2) + else + call imd_mcell (m, nx, ny, ax1,ay1, ax2,ay2) +end + + +# IMD_BCELL -- Put cell array, optimized for a bitmap device. In this case, +# to get the maximum resolution at maximum efficiency it is desirable for the +# main loop to be over device pixels, mapping the device pixel into the +# nearest line of the input cell array. + +procedure imd_bcell (m, nx, ny, ax1,ay1, ax2,ay2) + +short m[nx,ny] # cell array +int nx, ny # number of pixels in X and Y +int ax1, ay1 # lower left corner of output window +int ax2, ay2 # upper right corner of output window + +real dx, dy +int my, i1, i2, v, i, j, k +include "imd.com" +int and() + +begin + # Count drawing instruction, set polyline width to 1 for max y-res. + g_ndraw = g_ndraw + 1 + call idk_linewidth (g_out, 1) + IMD_WIDTH(g_kt) = 0 + + # Determine the width of a cell array pixel in GKI units. + dx = real (ax2 - ax1) / nx + + # Determine the height of a device pixel in GKI units. + if (IMD_YRES(g_kt) <= 0) + dy = GKI_MAXNDC / DEF_YRES + else + dy = max (1.0, real(GKI_MAXNDC) / real(IMD_YRES(g_kt))) + + # Process the cell array. The outer loop runs over device pixels in Y; + # each iteration writes one line of the output raster. The inner loop + # runs down a line of the cell array. + + k = 0 + for (my = ay1 + dy/2; my < ay2; my = k * dy + ay1) { + j = max(1, min(ny, int (real(my-ay1) / real(ay2-ay1) * (ny-1)) + 1)) + my = min (my, int (ay2 - dy/2)) + + for (i=1; i <= nx; ) { + do i = i, nx { + v = m[i,j] + if (and (v, ZSTEP) != 0) + break + } + + if (i <= nx) { + i1 = i + i2 = nx + do i = i1 + 1, nx { + v = m[i,j] + if (and (v, ZSTEP) == 0) { + i2 = i + break + } + } + + # The following decreases the length of dark line segments + # to make features more visible. + + if (i2 - i1 >= 2) + if (i1 > 1 && i2 < nx) { + i1 = i1 + 1 + i2 = i2 - 1 + } + + # Draw the line segment. + call idk_move (g_out, int ((i1-1) * dx + ax1), my) + call idk_draw (g_out, int (i2 * dx + ax1), my) + + if (i2 >= nx) + i = nx + 1 + } + } + + k = k + 1 + } +end + + +# IMD_MCELL -- Put cell array, optimized for a metafile device. In this case, +# it is prohibitively expensive to draw into each resolvable line of the +# output device. It is better to set the linewidth to the width of a cell +# array pixel, output the minimum number of drawing instructions, and let the +# metafile device widen the lines. + +procedure imd_mcell (m, nx, ny, ax1,ay1, ax2,ay2) + +short m[nx,ny] # cell array +int nx, ny # number of pixels in X and Y +int ax1, ay1 # lower left corner of output window +int ax2, ay2 # upper right corner of output window + +real dx, dy +int yres, my, i1, i2, v, i, j +include "imd.com" +int and() + +begin + # Count drawing instruction, clobber saved polyline width. + g_ndraw = g_ndraw + 1 + IMD_WIDTH(g_kt) = 0 + + # Determine the width and height of a cell array pixel in GKI units. + dx = real (ax2 - ax1) / nx + dy = real (ay2 - ay1) / ny + + # Set the IDK line width to the height of a pixel in the cell array. + yres = IMD_YRES(g_kt) + if (yres <= 0) + yres = DEF_YRES + call idk_linewidth (g_out, + max (1, nint (dy / (real(GKI_MAXNDC) / real(yres))))) + + # Process the cell array. The outer loop runs over lines of the input + # cell array; each iteration writes only one line of the output raster, + # but the width of the line is adjusted to the height of a pixel in + # the cell array (the resolution of the cell array should not exceed + # that of the device). + + for (j=1; j <= ny; j=j+1) { + my = int ((j - 0.5) * dy) + ay1 + + for (i=1; i <= nx; ) { + do i = i, nx { + v = m[i,j] + if (and (v, ZSTEP) != 0) + break + } + + if (i <= nx) { + i1 = i + i2 = nx + do i = i + 1, nx { + v = m[i,j] + if (and (v, ZSTEP) == 0) { + i2 = i + break + } + } + + # The following decreases the length of dark line segments + # to make features more visible. + + if (i2 - i1 >= 2) + if (i1 > 1 && i2 < nx) { + i1 = i1 + 1 + i2 = i2 - 1 + } + + # Draw the line segment. + call idk_move (g_out, int ((i1-1) * dx + ax1), my) + call idk_draw (g_out, int (i2 * dx + ax1), my) + + if (i2 >= nx) + i = nx + 1 + } + } + } +end diff --git a/sys/gio/imdkern/imdpl.x b/sys/gio/imdkern/imdpl.x new file mode 100644 index 00000000..7c94f7d2 --- /dev/null +++ b/sys/gio/imdkern/imdpl.x @@ -0,0 +1,183 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "imd.h" + +define MAX_LTYPES 3 # max software line type patterns (excl. solid) +define MAX_LSEGMENTS 4 # max line segments per pattern +define LT_OFFSET 1 # offset to be subtracted from ltype code + + +# IMD_POLYLINE -- Draw a polyline. The polyline is defined by the array of +# points P, consisting of successive (x,y) coordinate pairs. The first point +# is not plotted but rather defines the start of the polyline. The remaining +# points define line segments to be drawn. + +procedure imd_polyline (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs + +pointer pl +int x, y +int len_p, i +include "imd.com" + +begin + if (npts < 2) + return + + len_p = npts * 2 + + # Keep track of the number of drawing instructions since the last frame + # clear. + g_ndraw = g_ndraw + 1 + + # Update polyline attributes if necessary. + pl = IMD_PLAP(g_kt) + + if (IMD_WIDTH(g_kt) != PL_WIDTH(pl)) { + call idk_linewidth (g_out, nint (GKI_UNPACKREAL(PL_WIDTH(pl)))) + IMD_WIDTH(g_kt) = PL_WIDTH(pl) + } + if (IMD_COLOR(g_kt) != PL_COLOR(pl)) { + call imd_color (PL_COLOR(pl)) + IMD_COLOR(g_kt) = PL_COLOR(pl) + } + + if (PL_LTYPE(pl) == GL_CLEAR) { + # Ignore clear (erase) polylines. + ; + + } else if (PL_LTYPE(pl) != GL_SOLID) { + # Draw a dashed or dotted polyline of the indicated type. + call imd_dashline (g_out, p, npts, PL_LTYPE(pl)) + + } else { + # Draw a solid polyline (usual case, optimized). + + # Move to the first point. + x = p[1] + y = p[2] + call idk_move (g_out, x, y) + + # Draw the polyline. + for (i=3; i <= len_p; i=i+2) { + x = p[i] + y = p[i+1] + call idk_draw (g_out, x, y) + } + } +end + + +# IMD_DASHLINE -- Draw a dashed or dotted polyline using the indicated line +# style. + +procedure imd_dashline (g_out, p, npts, ltype) + +int g_out # output file +short p[ARB] # the polyline points +int npts # number of points, i.e., (x,y) pairs +int ltype # desired line type + +bool penup +int len_p, i +real vlen, vpos, seglen, dx, dy +int oldx, oldy, newx, newy, penx, peny +int imd_getseg() + +begin + len_p = npts * 2 + + oldx = p[1]; oldy = p[2] + call idk_move (g_out, oldx, oldy) + + # Process each line segment in the polyline. + do i = 3, len_p, 2 { + newx = p[i] + newy = p[i+1] + + # Compute VLEN, the length of the polyline line segment to be + # drawn, VPOS, the relative position along the line segment, + # and DX and DY, the scale factors to be applied to VPOS to get + # the x and y coordinates of a point along the line segment. + + dx = newx - oldx + dy = newy - oldy + vlen = sqrt (dx*dx + dy*dy) + if (vlen < 1.0) # GKI units + next + + dx = dx / vlen + dy = dy / vlen + vpos = 0.0 + + # For each line segment, get segments of the line type pattern + # until all of the current line segment has been drawn. The pattern + # wraps around indefinitely, following the polyline around the + # vertices with concern only for the total length traversed. + + while (vlen - vpos >= 1.0) { + seglen = imd_getseg (int (vlen - vpos), penup, ltype) + if (seglen < 1.0) + break + + vpos = vpos + seglen + penx = oldx + vpos * dx + peny = oldy + vpos * dy + + if (penup) + call idk_move (g_out, penx, peny) + else + call idk_draw (g_out, penx, peny) + } + + oldx = newx + oldy = newy + } +end + + +# IMD_GETSEG -- Get a segment of a line style pattern. The segment extends +# from the current position in the pattern to either the next penup/pendown +# breakpoint in the pattern, or to the point MAXLEN units further along in +# the pattern. When the end of the pattern is reached wrap around and +# duplicate the pattern indefinitely. + +int procedure imd_getseg (maxlen, penup, ltype) + +int maxlen # max length segment to be returned +bool penup # [out] pen up or pen down type segment? +int ltype # line type code + +int seglen, seg, lt +int p_seg[MAX_LTYPES] +int p_nseg[MAX_LTYPES] +int p_segleft[MAX_LTYPES] +bool p_penup[MAX_LTYPES,MAX_LSEGMENTS] +int p_seglen[MAX_LTYPES,MAX_LSEGMENTS] +include "ltype.dat" + +begin + lt = max (1, min (MAX_LTYPES, ltype - LT_OFFSET)) + seg = p_seg[lt] + penup = p_penup[lt,seg] + + repeat { + if (maxlen < p_segleft[lt]) { + seglen = maxlen + p_segleft[lt] = p_segleft[lt] - seglen + } else { + seglen = p_segleft[lt] + seg = seg + 1 + if (seg > p_nseg[lt]) + seg = 1 + p_seg[lt] = seg + p_segleft[lt] = p_seglen[lt,seg] + } + } until (seglen > 0) + + return (seglen) +end diff --git a/sys/gio/imdkern/imdplset.x b/sys/gio/imdkern/imdplset.x new file mode 100644 index 00000000..22743178 --- /dev/null +++ b/sys/gio/imdkern/imdplset.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imd.h" + +# IMD_PLSET -- Set the polyline attributes. The polyline width parameter is +# passed to the encoder as a packed floating point number, i.e., int(LWx100). + +procedure imd_plset (gki) + +short gki[ARB] # attribute structure +pointer pl +include "imd.com" + +begin + pl = IMD_PLAP(g_kt) + PL_LTYPE(pl) = gki[GKI_PLSET_LT] + PL_WIDTH(pl) = gki[GKI_PLSET_LW] + PL_COLOR(pl) = gki[GKI_PLSET_CI] +end diff --git a/sys/gio/imdkern/imdpm.x b/sys/gio/imdkern/imdpm.x new file mode 100644 index 00000000..d7bcddac --- /dev/null +++ b/sys/gio/imdkern/imdpm.x @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imd.h" + +# IMD_POLYMARKER -- Draw a polymarker. The polymarker is defined by the array +# of points P, consisting of successive (x,y) coordinate pairs. + +procedure imd_polymarker (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs + +pointer pm +int i, len_p +int x, y, oldx, oldy +include "imd.com" + +begin + if (npts <= 0) + return + + len_p = npts * 2 + + # Keep track of the number of drawing instructions since the last frame + # clear. + g_ndraw = g_ndraw + 1 + + # Update polymarker attributes if necessary. + + pm = IMD_PMAP(g_kt) + + if (IMD_TYPE(g_kt) != PM_LTYPE(pm)) { + call imd_linetype (PM_LTYPE(pm)) + IMD_TYPE(g_kt) = PM_LTYPE(pm) + } + if (IMD_WIDTH(g_kt) != PM_WIDTH(pm)) { + call idk_linewidth (g_out, nint (GKI_UNPACKREAL(PM_WIDTH(pm)))) + IMD_WIDTH(g_kt) = PM_WIDTH(pm) + } + if (IMD_COLOR(g_kt) != PM_COLOR(pm)) { + call imd_color (PM_COLOR(pm)) + IMD_COLOR(g_kt) = PM_COLOR(pm) + } + + # Draw the polymarker. + oldx = 0; oldy = 0 + for (i=1; i <= len_p; i=i+2) { + x = p[i]; y = p[i+1] + if (x != oldx || y != oldy) { + call idk_move (g_out, x, y) + call idk_draw (g_out, x, y) + } + oldx = x; oldy = y + } +end diff --git a/sys/gio/imdkern/imdpmset.x b/sys/gio/imdkern/imdpmset.x new file mode 100644 index 00000000..6912ef97 --- /dev/null +++ b/sys/gio/imdkern/imdpmset.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imd.h" + +# IMD_PMSET -- Set the polymarker attributes. + +procedure imd_pmset (gki) + +short gki[ARB] # attribute structure +pointer pm +include "imd.com" + +begin + pm = IMD_PMAP(g_kt) + PM_LTYPE(pm) = gki[GKI_PMSET_MT] + PM_WIDTH(pm) = gki[GKI_PMSET_MW] + PM_COLOR(pm) = gki[GKI_PMSET_CI] +end diff --git a/sys/gio/imdkern/imdreset.x b/sys/gio/imdkern/imdreset.x new file mode 100644 index 00000000..fa830e4d --- /dev/null +++ b/sys/gio/imdkern/imdreset.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "imd.h" + +# IMD_RESET -- Reset the state of the transform common, i.e., in response to +# a clear or a cancel. Initialize all attribute packets to their default +# values and set the current state of the device to undefined, forcing the +# device state to be reset when the next output instruction is executed. + +procedure imd_reset() + +pointer pl, pm, fa, tx +include "imd.com" + +begin + # Set pointers to attribute substructures. + pl = IMD_PLAP(g_kt) + pm = IMD_PMAP(g_kt) + fa = IMD_FAAP(g_kt) + tx = IMD_TXAP(g_kt) + + # Initialize the attribute packets. + PL_LTYPE(pl) = 1 + PL_WIDTH(pl) = GKI_PACKREAL(1.) + PL_COLOR(pl) = 1 + PM_LTYPE(pm) = 1 + PM_WIDTH(pm) = GKI_PACKREAL(1.) + PM_COLOR(pm) = 1 + FA_STYLE(fa) = 1 + FA_COLOR(fa) = 1 + TX_UP(tx) = 90 + TX_SIZE(tx) = GKI_PACKREAL(1.) + TX_PATH(tx) = GT_RIGHT + TX_HJUSTIFY(tx) = GT_LEFT + TX_VJUSTIFY(tx) = GT_BOTTOM + TX_FONT(tx) = GT_ROMAN + TX_COLOR(tx) = 1 + TX_SPACING(tx) = 0.0 + + # Set the device attributes to undefined, forcing them to be reset + # when the next output instruction is executed. + + IMD_TYPE(g_kt) = -1 + IMD_WIDTH(g_kt) = -1 + IMD_COLOR(g_kt) = -1 + IMD_TXSIZE(g_kt) = -1 + IMD_TXFONT(g_kt) = -1 +end diff --git a/sys/gio/imdkern/imdtx.x b/sys/gio/imdkern/imdtx.x new file mode 100644 index 00000000..afe6c50c --- /dev/null +++ b/sys/gio/imdkern/imdtx.x @@ -0,0 +1,430 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "imd.h" + +define BASECS_X 12 # Base (size 1.0) char width in GKI coords. +define BASECS_Y 12 # Base (size 1.0) char height in GKI coords. + + +# IMD_TEXT -- Draw a text string. The string is drawn at the position (X,Y) +# using the text attributes set by the last GKI_TXSET instruction. The text +# string to be drawn may contain embedded set font escape sequences of the +# form \fR (roman), \fG (greek), etc. We break the input text sequence up +# into segments at font boundaries and draw these on the output device, +# setting the text size, color, font, and position at the beginning of each +# segment. + +procedure imd_text (xc, yc, text, n) + +int xc, yc # where to draw text string +short text[ARB] # text string +int n # number of characters + +real x, y, dx, dy, tsz +int x1, x2, y1, y2, orien +int x0, y0, gki_dx, gki_dy, ch, cw +int xstart, ystart, newx, newy +int totlen, polytext, font, seglen +pointer sp, seg, ip, op, tx, first +int stx_segment() +include "imd.com" + +real g_dx, g_dy # scale GKI to window coords +int g_x1, g_y1 # origin of device window +int g_x2, g_y2 # upper right corner of device window +data g_dx /1.0/, g_dy /1.0/ +data g_x1 /0/, g_y1 /0/, g_x2 /GKI_MAXNDC/, g_y2 / GKI_MAXNDC/ + +begin + call smark (sp) + call salloc (seg, n + 2, TY_CHAR) + + # Keep track of the number of drawing instructions since the last frame + # clear. + g_ndraw = g_ndraw + 1 + + # Set pointer to the text attribute structure. + tx = IMD_TXAP(g_kt) + + # Set the text size and color if not already set. Both should be + # invalidated when the screen is cleared. Text color should be + # invalidated whenever another color is set. The text size was + # set by imd_txset, and is just a scaling factor. + + IMD_TXSIZE(g_kt) = TX_SIZE(tx) + if (TX_COLOR(tx) != IMD_COLOR(g_kt)) { + call imd_color (TX_COLOR(tx)) + IMD_COLOR(g_kt) = TX_COLOR(tx) + } + + # Set the linetype to a solid line. + if (IMD_TYPE(g_kt) != GL_SOLID) { + call imd_linetype (GL_SOLID) + IMD_TYPE(g_kt) = GL_SOLID + } + + # Break the text string into segments at font boundaries and count + # the total number of printable characters. + + totlen = stx_segment (text, n, Memc[seg], TX_FONT(tx)) + + # Compute the text drawing parameters, i.e., the coordinates of the + # first character to be drawn, the step between successive characters, + # and the polytext flag (GKI coords). + + call stx_parameters (xc,yc, totlen, x0,y0, gki_dx,gki_dy, polytext, + orien) + + # No discreet character sizes, so just scale the base sizes. + tsz = GKI_UNPACKREAL(TX_SIZE(tx)) # scale factor + ch = IMD_CHARHEIGHT(g_kt,1) * tsz + cw = IMD_CHARWIDTH(g_kt,1) * tsz + + # Draw the segments, setting the font at the beginning of each segment. + # The first segment is drawn at (X0,Y0). The separation between + # characters is DX,DY. A segment is drawn as a block if the polytext + # flag is set, otherwise each character is drawn individually. + + x = x0 * g_dx + g_x1 + y = y0 * g_dy + g_y1 + dx = gki_dx * g_dx + dy = gki_dy * g_dy + + for (ip=seg; Memc[ip] != EOS; ip=ip+1) { + # Process the font control character heading the next segment. + font = Memc[ip] + ip = ip + 1 + + # Draw the segment. + while (Memc[ip] != EOS) { + # Clip leading out of bounds characters. + for (; Memc[ip] != EOS; ip=ip+1) { + x1 = x; x2 = x1 + cw + y1 = y; y2 = y1 + ch + + if (x1 >= g_x1 && x2 <= g_x2 && y1 >= g_y1 && y2 <= g_y2) + break + else { + x = x + dx + y = y + dy + } + + if (polytext == NO) { + ip = ip + 1 + break + } + } + + # Coords of first char to be drawn. + xstart = x + ystart = y + + # Move OP to first out of bounds char. + for (op=ip; Memc[op] != EOS; op=op+1) { + x1 = x; x2 = x1 + cw + y1 = y; y2 = y1 + ch + + if (x1 <= g_x1 || x2 >= g_x2 || y1 <= g_y1 || y2 >= g_y2) + break + else { + x = x + dx + y = y + dy + } + + if (polytext == NO) { + op = op + 1 + break + } + } + + # Count number of inbounds chars. + seglen = op - ip + + # Leave OP pointing to the end of this segment. + if (polytext == NO) + op = ip + 1 + else { + while (Memc[op] != EOS) + op = op + 1 + } + + # Compute X,Y of next segment. + newx = xstart + (dx * (op - ip)) + newy = ystart + dy + + # Quit if no inbounds chars. + if (seglen == 0) { + x = newx + y = newy + ip = op + next + } + + # Output the inbounds chars. + + first = ip + x = xstart + y = ystart + + while (seglen > 0 && (polytext == YES || ip == first)) { + call imd_drawchar (Memc[ip], nint(x), nint(y), cw, ch, + orien, font) + ip = ip + 1 + seglen = seglen - 1 + x = x + dx + y = y + dy + } + + x = newx + y = newy + ip = op + } + } + + call sfree (sp) +end + + +# STX_SEGMENT -- Process the text string into segments, in the process +# converting from type short to char. The only text attribute that can +# change within a string is the font, so segments are broken by \fI, \fG, +# etc. font select sequences embedded in the text. The segments are encoded +# sequentially in the output string. The first character of each segment is +# the font number. A segment is delimited by EOS. A font number of EOS +# marks the end of the segment list. The output string is assumed to be +# large enough to hold the segmented text string. + +int procedure stx_segment (text, n, out, start_font) + +short text[ARB] # input text +int n # number of characters in text +char out[ARB] # output string +int start_font # initial font code + +int ip, op +int totlen, font + +begin + out[1] = start_font + totlen = 0 + op = 2 + + for (ip=1; ip <= n; ip=ip+1) { + if (text[ip] == '\\' && text[ip+1] == 'f') { + # Select font. + out[op] = EOS + op = op + 1 + ip = ip + 2 + + switch (text[ip]) { + case 'B': + font = GT_BOLD + case 'I': + font = GT_ITALIC + case 'G': + font = GT_GREEK + default: + font = GT_ROMAN + } + + out[op] = font + op = op + 1 + + } else { + # Deposit character in segment. + out[op] = text[ip] + op = op + 1 + totlen = totlen + 1 + } + } + + # Terminate last segment and add null segment. + + out[op] = EOS + out[op+1] = EOS + + return (totlen) +end + + +# STX_PARAMETERS -- Set the text drawing parameters, i.e., the coordinates +# of the lower left corner of the first character to be drawn, the spacing +# between characters, and the polytext flag. Input consists of the coords +# of the text string, the length of the string, and the text attributes +# defining the character size, justification in X and Y of the coordinates, +# and orientation of the string. All coordinates are in GKI units. + +procedure stx_parameters (xc, yc, totlen, x0, y0, dx, dy, polytext, orien) + +int xc, yc # coordinates at which string is to be drawn +int totlen # number of characters to be drawn +int x0, y0 # lower left corner of first char to be drawn +int dx, dy # step in X and Y between characters +int polytext # OK to output text segment all at once +int orien # rotation angle of characters + +pointer tx +int up, path +real dir, sz, ch, cw, cosv, sinv, space +real xsize, ysize, xvlen, yvlen, xu, yu, xv, yv, p, q +include "imd.com" + +begin + tx = IMD_TXAP(g_kt) + + # Get character sizes in GKI coords. + sz = GKI_UNPACKREAL (TX_SIZE(tx)) + ch = IMD_CHARHEIGHT(g_kt,1) * sz + cw = IMD_CHARWIDTH(g_kt,1) * sz + + # Compute the character rotation angle. This is independent of the + # direction in which characters are drawn. A character up vector of + # 90 degrees (normal) corresponds to a rotation angle of zero. + + up = TX_UP(tx) + orien = up - 90 + + # Determine the direction in which characters are to be plotted. + # This depends on both the character up vector and the path, which + # is defined relative to the up vector. + + path = TX_PATH(tx) + switch (path) { + case GT_UP: + dir = up + case GT_DOWN: + dir = up - 180 + case GT_LEFT: + dir = up + 90 + default: # GT_NORMAL, GT_RIGHT + dir = up - 90 + } + + # ------- DX, DY --------- + # Convert the direction vector into the step size between characters. + # Note CW and CH are in GKI coordinates, hence DX and DY are too. + # Additional spacing of some fraction of the character size is used + # if TX_SPACING is nonzero. + + dir = -DEGTORAD(dir) + cosv = cos (dir) + sinv = sin (dir) + + # Correct for spacing (unrotated). + space = (1.0 + TX_SPACING(tx)) + if (path == GT_UP || path == GT_DOWN) + p = ch * space + else + p = cw * space + q = 0 + + # Correct for rotation. + dx = p * cosv + q * sinv + dy = -p * sinv + q * cosv + + # ------- XU, YU --------- + # Determine the coordinates of the center of the first character req'd + # to justify the string, assuming dimensionless characters spaced on + # centers DX,DY apart. + + xvlen = dx * (totlen - 1) + yvlen = dy * (totlen - 1) + + switch (TX_HJUSTIFY(tx)) { + case GT_CENTER: + xu = - (xvlen / 2.0) + case GT_RIGHT: + # If right justify and drawing to the left, no offset req'd. + if (xvlen < 0) + xu = 0 + else + xu = -xvlen + default: # GT_LEFT, GT_NORMAL + # If left justify and drawing to the left, full offset right req'd. + if (xvlen < 0) + xu = -xvlen + else + xu = 0 + } + + switch (TX_VJUSTIFY(tx)) { + case GT_CENTER: + yu = - (yvlen / 2.0) + case GT_TOP: + # If top justify and drawing downward, no offset req'd. + if (yvlen < 0) + yu = 0 + else + yu = -yvlen + default: # GT_BOTTOM, GT_NORMAL + # If bottom justify and drawing downward, full offset up req'd. + if (yvlen < 0) + yu = -yvlen + else + yu = 0 + } + + # ------- XV, YV --------- + # Compute the offset from the center of a single character required + # to justify that character, given a particular character up vector. + # (This could be combined with the above case but is clearer if + # treated separately.) + + p = -DEGTORAD(orien) + cosv = cos(p) + sinv = sin(p) + + # Compute the rotated character in size X and Y. + xsize = abs ( cw * cosv + ch * sinv) + ysize = abs (-cw * sinv + ch * cosv) + + switch (TX_HJUSTIFY(tx)) { + case GT_CENTER: + xv = 0 + case GT_RIGHT: + xv = - (xsize / 2.0) + default: # GT_LEFT, GT_NORMAL + xv = xsize / 2 + } + + switch (TX_VJUSTIFY(tx)) { + case GT_CENTER: + yv = 0 + case GT_TOP: + yv = - (ysize / 2.0) + default: # GT_BOTTOM, GT_NORMAL + yv = ysize / 2 + } + + # ------- X0, Y0 --------- + # The center coordinates of the first character to be drawn are given + # by the reference position plus the string justification vector plus + # the character justification vector. + + x0 = xc + xu + xv + y0 = yc + yu + yv + + # The character drawing primitive requires the coordinates of the + # lower left corner of the character (irrespective of orientation). + # Compute the vector from the center of a character to the lower left + # corner of a character, rotate to the given orientation, and correct + # the starting coordinates by addition of this vector. + + p = - (cw / 2.0) + q = - (ch / 2.0) + + x0 = x0 + ( p * cosv + q * sinv) + y0 = y0 + (-p * sinv + q * cosv) + + # ------- POLYTEXT --------- + # Set the polytext flag. Polytext output is possible only if chars + # are to be drawn to the right with no extra spacing between chars. + + if (abs(dy) == 0 && dx == cw) + polytext = YES + else + polytext = NO +end diff --git a/sys/gio/imdkern/imdtxset.x b/sys/gio/imdkern/imdtxset.x new file mode 100644 index 00000000..9479fbdd --- /dev/null +++ b/sys/gio/imdkern/imdtxset.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "imd.h" + +# IMD_TXSET -- Set the text drawing attributes. + +procedure imd_txset (gki) + +short gki[ARB] # attribute structure + +pointer tx +include "imd.com" + +begin + tx = IMD_TXAP(g_kt) + + TX_UP(tx) = gki[GKI_TXSET_UP] + TX_PATH(tx) = gki[GKI_TXSET_P ] + TX_HJUSTIFY(tx) = gki[GKI_TXSET_HJ] + TX_VJUSTIFY(tx) = gki[GKI_TXSET_VJ] + TX_FONT(tx) = gki[GKI_TXSET_F ] + TX_QUALITY(tx) = gki[GKI_TXSET_Q ] + TX_COLOR(tx) = gki[GKI_TXSET_CI] + + TX_SPACING(tx) = GKI_UNPACKREAL (gki[GKI_TXSET_SP]) + TX_SIZE(tx) = gki[GKI_TXSET_SZ] +end diff --git a/sys/gio/imdkern/ltype.dat b/sys/gio/imdkern/ltype.dat new file mode 100644 index 00000000..caae0c18 --- /dev/null +++ b/sys/gio/imdkern/ltype.dat @@ -0,0 +1,28 @@ +# LTYPE.DAT -- Initialize the builtin line types for the IMD kernel. Data +# is given in GKI units (1.0 = 32768 units). A segment of 32 GKI units is +# resolved on a device with 1024 resolved pixels. + +data p_seg /1, 1, 1/ +data p_segleft /320, 32, 512/ + +data p_nseg[1] /2/ # PL_DASHED +data p_penup[1,1] /false/ +data p_penup[1,2] /true/ +data p_seglen[1,1] /320/ +data p_seglen[1,2] /128/ + +data p_nseg[2] /2/ # PL_DOTTED +data p_penup[2,1] /false/ +data p_penup[2,2] /true/ +data p_seglen[2,1] /32/ +data p_seglen[2,2] /128/ + +data p_nseg[3] /4/ # PL_DOTDASH +data p_penup[3,1] /false/ +data p_penup[3,2] /true/ +data p_penup[3,3] /false/ +data p_penup[3,4] /true/ +data p_seglen[3,1] /512/ +data p_seglen[3,2] /128/ +data p_seglen[3,3] /32/ +data p_seglen[3,4] /128/ diff --git a/sys/gio/imdkern/mkpkg b/sys/gio/imdkern/mkpkg new file mode 100644 index 00000000..03581bff --- /dev/null +++ b/sys/gio/imdkern/mkpkg @@ -0,0 +1,50 @@ +# Make the GIO/IMDKERN image display device graphics kernel. + +$checkout libimd.a lib$ +$update libimd.a +$checkin libimd.a lib$ +$call relink +$exit + +update: + $call relink + $call install + ; + +relink: + $omake x_imdkern.x + $link x_imdkern.o -limd -lds -lstg -o xx_imdkern.e + ; + +install: + $move xx_imdkern.e bin$x_imdkern.e + ; + +libimd.a: + idk.x idk.com + imdcancel.x imd.com imd.h + imdclear.x imd.com imd.h + imdclose.x imd.com imd.h + imdclws.x imd.h imd.com + imdcolor.x imd.com imd.h + imddrawch.x font.com font.h imd.com imd.h + imdescape.x + imdfa.x imd.com imd.h + imdfaset.x imd.com imd.h + imdflush.x imd.com imd.h + imdfont.x imd.com imd.h + imdgcell.x + imdinit.x imd.com imd.h + imdline.x imd.com imd.h + imdopen.x imd.com imd.h + imdopenws.x imd.com imd.h + imdpcell.x imd.com imd.h + imdpl.x imd.com imd.h ltype.dat + imdplset.x imd.com imd.h + imdpm.x imd.com imd.h + imdpmset.x imd.com imd.h + imdreset.x imd.com imd.h + imdtx.x imd.com imd.h + imdtxset.x imd.com imd.h + t_imdkern.x + ; diff --git a/sys/gio/imdkern/t_imdkern.x b/sys/gio/imdkern/t_imdkern.x new file mode 100644 index 00000000..ebca44bf --- /dev/null +++ b/sys/gio/imdkern/t_imdkern.x @@ -0,0 +1,89 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMDKERN -- Graphics kernel for an image display frame buffer using the +# data stream interface. The package is based on the SGI kernel. + +procedure t_imdkern() + +int fd, list, dbfd +pointer gki, sp, fname, devname, dbfname +int dev[LEN_GKIDD], deb[LEN_GKIDD] +int debug, verbose, gkiunits +int color, frame + +bool clgetb() +int clgeti(), envfind() +int clpopni(), clgfil(), open(), btoi() +int gki_fetch_next_instruction() + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (devname, SZ_FNAME, TY_CHAR) + call salloc (dbfname, SZ_PATHNAME, TY_CHAR) + + # Open list of metafiles to be decoded. + list = clpopni ("input") + + # Set parameter defaults. + debug = NO + verbose = NO + gkiunits = NO + frame = -1 + color = -1 + + # Check for global kernel debug flag. + if (envfind ("idkdebug", Memc[dbfname], SZ_PATHNAME) > 0) + iferr (dbfd = open (Memc[dbfname], APPEND, TEXT_FILE)) { + debug = NO + dbfd = 0 + } else + debug = YES + + # Get parameters. + call clgstr ("device", Memc[devname], SZ_FNAME) + if (!clgetb ("generic")) { + debug = btoi (clgetb ("debug")) + verbose = btoi (clgetb ("verbose")) + gkiunits = btoi (clgetb ("gkiunits")) + frame = clgeti ("frame") + color = clgeti ("color") + } + + if (debug == YES && dbfd == 0) + dbfd = STDERR + + # Open the graphics kernel. + call imd_opendev (Memc[devname], frame, color, dev) + call gkp_install (deb, dbfd, verbose, gkiunits) + + # Process a list of metacode files, writing the decoded metacode + # instructions on the standard output. + + while (clgfil (list, Memc[fname], SZ_FNAME) != EOF) { + # Open input file. + iferr (fd = open (Memc[fname], READ_ONLY, BINARY_FILE)) { + call erract (EA_WARN) + next + } + + # Process the metacode instruction stream. + while (gki_fetch_next_instruction (fd, gki) != EOF) { + if (debug == YES) { + call gki_execute (Mems[gki], deb) + call flush (dbfd) + } + call gki_execute (Mems[gki], dev) + } + + call close (fd) + } + + call gkp_close() + call imd_close() + call clpcls (list) + call sfree (sp) +end diff --git a/sys/gio/imdkern/x_imdkern.x b/sys/gio/imdkern/x_imdkern.x new file mode 100644 index 00000000..3cc14388 --- /dev/null +++ b/sys/gio/imdkern/x_imdkern.x @@ -0,0 +1,3 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +task imdkern = t_imdkern diff --git a/sys/gio/markers.inc b/sys/gio/markers.inc new file mode 100644 index 00000000..ef3a540f --- /dev/null +++ b/sys/gio/markers.inc @@ -0,0 +1,71 @@ +# Data declarations for the standard markers. + +real mpx[86], mpy[86] # marker polyline points +int moff[9] # offsets of the markers in mpx and mpy +int mnpts[9] # number of points in each polyline +int k # implied do-loop dummy index + +# Box. +data (mpx(k),k=01,05) /0.0, 1.0, 1.0, 0.0, 0.0/ +data (mpy(k),k=01,05) /0.0, 0.0, 1.0, 1.0, 0.0/ +data moff[1] /1/, mnpts[1] /5/ + +# Plus. +data (mpx(k),k=06,10) /0.5, 0.5, 0.5, 0.0, 1.0/ +data (mpy(k),k=06,10) /0.0, 1.0, 0.5, 0.5, 0.5/ +data moff[2] /6/, mnpts[2] /5/ + +# Cross. +data (mpx(k),k=11,15) /0.0, 1.0, 0.5, 0.0, 1.0/ +data (mpy(k),k=11,15) /0.0, 1.0, 0.5, 1.0, 0.0/ +data moff[3] /11/, mnpts[3] /5/ + +# Diamond. +data (mpx(k),k=16,20) /0.5, 1.0, 0.5, 0.0, 0.5/ +data (mpy(k),k=16,20) /0.0, 0.5, 1.0, 0.5, 0.0/ +data moff[4] /16/, mnpts[4] /5/ + +# Horizonal line. +data (mpx(k),k=21,22) /0.0, 1.0/ +data (mpy(k),k=21,22) /0.5, 0.5/ +data moff[5] /21/, mnpts[5] /2/ + +# Vertical line. +data (mpx(k),k=23,24) /0.5, 0.5/ +data (mpy(k),k=23,24) /0.0, 1.0/ +data moff[6] /23/, mnpts[6] /2/ + +# Horizontal error bar. +data (mpx(k),k=25,30) /0.0, 0.0, 0.0, 1.0, 1.0, 1.0/ +data (mpy(k),k=25,30) /0.0, 1.0, 0.5, 0.5, 1.0, 0.0/ +data moff[7] /25/, mnpts[7] /6/ + +# Vertical error bar. +data (mpx(k),k=31,36) /0.0, 1.0, 0.5, 0.5, 1.0, 0.0/ +data (mpy(k),k=31,36) /0.0, 0.0, 0.0, 1.0, 1.0, 1.0/ +data moff[8] /31/, mnpts[8] /6/ + +# Circle. +data (mpx(k),k=37,41) /1.000, 0.996, 0.984, 0.963, 0.936/ # X +data (mpx(k),k=42,46) /0.901, 0.859, 0.812, 0.759, 0.702/ +data (mpx(k),k=47,51) /0.642, 0.580, 0.516, 0.452, 0.389/ +data (mpx(k),k=52,56) /0.327, 0.269, 0.214, 0.164, 0.119/ +data (mpx(k),k=57,61) /0.081, 0.050, 0.025, 0.009, 0.001/ +data (mpx(k),k=62,66) /0.001, 0.009, 0.025, 0.050, 0.081/ +data (mpx(k),k=67,71) /0.119, 0.164, 0.214, 0.269, 0.327/ +data (mpx(k),k=72,76) /0.389, 0.452, 0.516, 0.580, 0.642/ +data (mpx(k),k=77,81) /0.702, 0.759, 0.812, 0.859, 0.901/ +data (mpx(k),k=82,86) /0.936, 0.963, 0.984, 0.996, 1.000/ + +data (mpy(k),k=37,41) /0.500, 0.564, 0.627, 0.688, 0.745/ # Y +data (mpy(k),k=42,46) /0.799, 0.848, 0.891, 0.928, 0.957/ +data (mpy(k),k=47,51) /0.979, 0.994, 1.000, 0.998, 0.987/ +data (mpy(k),k=52,56) /0.969, 0.943, 0.910, 0.870, 0.824/ +data (mpy(k),k=57,61) /0.773, 0.717, 0.658, 0.596, 0.532/ +data (mpy(k),k=62,66) /0.468, 0.404, 0.342, 0.283, 0.227/ +data (mpy(k),k=67,71) /0.176, 0.130, 0.090, 0.057, 0.031/ +data (mpy(k),k=72,76) /0.013, 0.002, 0.000, 0.006, 0.021/ +data (mpy(k),k=77,81) /0.043, 0.072, 0.109, 0.152, 0.201/ +data (mpy(k),k=82,86) /0.255, 0.312, 0.373, 0.436, 0.500/ + +data moff[9] /37/, mnpts[9] /50/ diff --git a/sys/gio/mkpkg b/sys/gio/mkpkg new file mode 100644 index 00000000..b09ae3cd --- /dev/null +++ b/sys/gio/mkpkg @@ -0,0 +1,140 @@ +# Make the GIO package. + +$checkout libex.a lib$ # default: update libex.a +$update libex.a +$checkin libex.a lib$ +$exit + +# UPDATE -- Relink and install all graphics kernels. + +update: + @stdgraph + @sgikern + @imdkern + $ifeq (USE_NSPP, yes) @nsppkern $endif + $ifeq (USE_CALCOMP, yes) @calcomp $endif + ; + + +# The following redirect sys$mkpkg to the appropriate subdirectories to +# update the libraries therein. + +libcur.a: + @cursor + ; +libgks.a: + @gks + ; +libncar.a: + @ncarutil + ; +libnspp.a: + @nspp + ; +libstg.a: + @stdgraph + ; +libsgi.a: + @sgikern + ; +libimd.a: + @imdkern + ; +libgkt.a: + @nsppkern + ; +libccp.a: + @calcomp + ; + + +# GIO portion of LIBEX. + +libex.a: + $ifeq (USE_GENERIC, yes) + $ifolder (gtickr.x, gtick.gx) + $generic -k -t r gtick.gx + $endif + $endif + + @glabax + @gki + @gim + + aelogd.x + aelogr.x + elogd.x + elogr.x + fpequald.x + fpequalr.x + fpfixd.x + fpfixr.x + fpndgr.x + fpnormd.x + fpnormr.x + gactivate.x + gadraw.x gpl.com + gamove.x gpl.com + gascale.x + gcancel.x + gclear.x + gclose.x + gctran.x + gcurpos.x gpl.com + gdeact.x + gescape.x + gfill.x + gflush.x + gframe.x + gfrinit.x + ggcell.x gpl.com + ggcur.x + ggetb.x + ggeti.x + ggetr.x + ggets.x + ggscale.x + ggview.x + ggwind.x + gline.x + gmark.x markers.inc + gmftitle.x + gmprintf.x + gmsg.x + gopen.x + gpagefile.x + gpcell.x gpl.com + gplcache.x gpl.com + gplcancel.x gpl.com + gplflush.x gpl.com + gpline.x + gploto.x + gplotv.x + gplreset.x gpl.com + gplstype.x gpl.com + gpmark.x + gqverify.x + grdraw.x + grdwcs.x + greact.x + greset.x + grmove.x + grscale.x + gscan.x + gscur.x + gseti.x + gsetr.x + gsets.x + gstati.x + gstatr.x + gstats.x + gsview.x + gswind.x + gtext.x + gtickr.x + gtxset.x + gumark.x + gvline.x + gvmark.x + wcstogki.x gpl.com + ; diff --git a/sys/gio/ncarutil/README b/sys/gio/ncarutil/README new file mode 100644 index 00000000..6ae35023 --- /dev/null +++ b/sys/gio/ncarutil/README @@ -0,0 +1,219 @@ +Directory gio$ncarutil, with subdirectories conlib, autograph and sysint, +contains the source code for the GKS based NCAR plotting utilities library. +The first public release of this software was installed in IRAF 10SEP86. +(The 3 previous installations of the NCAR Utilities were the result of NOAO +serving as a Beta release test site.) What follows is the Notes files from +the installation : + +****************************************************************************** +Notes for installation of the NCAR GKS based plotting utilities. This +release marks the end of NCAR's beta testing and is the first public release +of the new software. The changes made at NOAO have been merged into the +new source code; these changes have are marked with "+/- NOAO." The IRAF +installed NCAR library differs from the version released on tape as documented +below. Installation was begun September 2, 1986. (S. Hammond) + +Subdirectory AUTOGRAPH -- + +autograph/agback.f: + Calls blockdata agdflt as run time subroutine. +autograph/agcurv.f: + Calls blockdata agdflt as run time subroutine. +autograph/agdflt.f: + This is the block data, which has been completely rewritten as + initialization statements instead of data statements. +autograph/agexax.f: + A ftn write statement has been commented out. +autograph/agppid.f: + A string is written with f77upk/pstr instead of a ftn write statement. +autograph/agrstr.f: + Binary read, completely commented out. +autograph/agsave.f: + Binary write (opposite of agrstr.f), completely commented out. +autograph/agscan.f: + Calls blockdata agdflt as run time subroutine. + A ftn write statement has been commented out. +autograph/agsetp.f: + Calls blockdata agdflt as run time subroutine. +autograph/agstup.f: + Calls blockdata agdflt as run time subroutine. +autograph/ezmxy.f, ezmy.f, ezxy.f, ezy.f: + These four subroutines require identical changes: + Call blockdata agdflt as run time subroutine upon entering; + Call subroutine initag before returning. +autograph/idiot.f: + Call blockdata adgflt as run time subroutine. + Call plotit and initut to reinitialize before returning. +autograph/pstr.x: + This file is not on the distribution tape, it was written to + output strings that have been unpacked by f77upk. + +Subdirectory CONLIB -- + +conlib/conecd.f: + Character variables IT and CHTMP are not used and so are commented out. + The FTN internal writes are rewritten as calls to encode. +conlib/congen.f: + FTN internal write replaced with call to encode. +conlib/conop1.f,conop2.f,conop3.f,conop4.f: + These four routines now call blockdata conbdn as run time initialization. +conlib/conout.f, conot2.f: + Both these routines are no-ops in IRAF. All statements have been commented + out. +conlib/conpdv.f: + FTN internal write replaced with a call to encode. +conlib/conssd.f: + FTN write and format statement commented out. +conlib/contng.f: + FTN internal writes rewritten as calls to encode. + + +Directory NCARUTIL -- + +conran.f: + Changed values of iabove, ibelow and ibel2 to improve label placement. + Blockdata condbn rewritten as run time initialization. (conbdn.f) + Internal writes rewritten as calls to encode. + +conrec.f: + Value of NCRT changed from 4 to 2. + The contour plot labelling has been improved, with the titles being + centered in the current viewport, and the large spaces between + fields eliminated. This change involves: + 1. common block noaolb added; also used in spp calling routine. + 2. Values of LNGTHS array modified. + 3. Character*25 variable string[5] added. + 4. Default plot position is centered on current viewport. + All internal writes have been replaced with calls to encode. + Error message concerning "overflow in STLINE" is now written only + to stderr, not to stdgraph as well. + EZCNTR no longer calls frame. + Block data CONBD deleted from conrec.f source, rewritten as conbd.f + +dashsmth.f: + In two places, the blockdata DASHBD is called as an initializing subroutine. + Subroutines kurv1s and kurv2s are used for both the dashsmth and + isosrf utilities. The code is duplicated in the two fortran files. I + have put it in a separate file (kurv.f) and deleted it from both original + locations. + +gridal.f: + In two places, blockdata GRIDT is called as an initializing subroutine. + All internal FTN writes changed to calls to encode. + FTN write and format statements for error reporting deleted - used seter. + Blockdata deleted from gridal.f; rewritten in gridt.f. + +hafton.f: + Blockdata hfinit rewritten and called as run time initializing subroutine. + One internal write rewritten as call to encode. + Call to FRAME removed from EZHFTN. + +isosrf.f: + Call to FRAME removed from EZISOS + Blockdata isosrb was rewritten as run time initialization isosrb.f + Source for subroutines kurv1s and kurv2s has been deleted from isosrf.f. + (It is shared with the dashsmth utility, and has been moved to kurv.f.) + +pwrity.f: + Blockdata PWRYBD rewritten as subroutine. + FTN writes and format statements commented out. + +pwrzs.f: + Common block noaovp added, so user can control viewport. Calls to + plotit and set had to be changed because they assumed the full + viewport [1-1024] was being used for srface plots. + +srface.f: + Because user changes viewport when labelling is selected, mods had + to be made. Common block noaovp has been added, and calls to set + and plotit no longer assume the full viewport [1-1024] is being used. + Blockdata SRFABD has been rewritten as a run time initialization. + +strmln.f: + The value of uvmsg changed from 1.0E+36 to 1.0E+16 in an attempt + to make this routine run on a VAX. + +threed.f: + Blockdata threbd rewritten as run time initialization. + Subroutine pwrz completely commented out. + +velvct.f: + Blockdata veldat rewritten as run time initialization. + FTN internal write rewritten as call to encode. + + +Subdirectory SYSINT (system interface) -- + +sysint/support.f: + 1. The character size calculated by WTSTR is doubled to be readable + with the IRAF font. + 2. Subroutines SETER and E9RIN both used FTN write statements to + output information. This is now handled by passing the error + message to ULIBER, where the string gets unpacked with f77upk + and written to stderr. + 3. Blockdata UERRBD was rewritten as a run time initialization. + 4. Block data UTILBD was rewritten as a run time initialization. + A logical flag (first) was added to insure that the internal + parameters were initialized only once per load; subroutine + utilbd can be called at several points. An entry point 'utinit' + was added to reset the 'first' flag to true. + 5. In an attempt to mimic the organization of the release tape, file + support.f contains the following fortran subroutines: + SUBROUTINE ENCD (VALU,ASH,IOUT,NC,IOFFD) + SUBROUTINE ENCODE (NCHARS, FTNFMT, FTNOUT, RVAL) + SUBROUTINE ENTSR(IROLD,IRNEW) + SUBROUTINE RETSR(IROLD) + SUBROUTINE ERROF + SUBROUTINE SETER(MESSG,NERR,IOPT) + SUBROUTINE EPRIN + SUBROUTINE E9RIN(MESSG,NERR,SAVE) + SUBROUTINE FDUM + SUBROUTINE Q8QST4(NAME,LBRARY,ENTRY,VRSION) + INTEGER FUNCTION NERRO(NERR) + INTEGER FUNCTION I8SAV(ISW,IVALUE,SET) + SUBROUTINE WTSTR (PX,PY,CH,IS,IO,IC) + subroutine uerrbd + subroutine uliber (errcode, pkerrmsg, msglen) + +sysint/spps.f: + 1. Subroutine FLUSH has been renamed MCFLSH because of a name conflict. + 2. FRAME calls initut to initialize the 'first' flag in utilbd. + 3. Subroutines OPNGKS and CLSGKS have been commented out. + 4. In PLOTIT and PLOTIF the block data utilbd is called as a run time + initialization subroutine. + +**************************************************************************** + +gio$ncarutil/conrec.f Dec 23, 1986 S. Hammond + Moved the call to gsplci that set up major contours. This + statement was not being executed until after the first major line + had been drawn, resulting in the first major line not being bold. + + +*************************************************************************** +On June 1, 1987 the following copywright notice was inserted into all +FORTRAN files in the ncarutil directory tree. + +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +February 12, 1988. During Steve Rooke's port of IRAF to the HP RISC computer +several Fortran errors were caught by the HP compiler. These have been +fixed as shown: +sys/gio/ncarutil/conbdn.f + The data statement at line 244 had not been commented out. It is now. + +June 10, 1988. Made a mod to conbd.f (and in the comments to conrec.f) that +resets the point at which contour decides an image aspect ratio is "extreme". +Previously if the image axes ratio exceeded 1:4 the contour plot was square. +This limit was too restrictive and has been changed to 1:16. See related +change in pkg$plot.vport.x. diff --git a/sys/gio/ncarutil/autograph/README b/sys/gio/ncarutil/autograph/README new file mode 100644 index 00000000..befb5e42 --- /dev/null +++ b/sys/gio/ncarutil/autograph/README @@ -0,0 +1,46 @@ +AUTOGRAPH -- This directory contains the contents of the NCAR file +autograph.f, unpacked one subroutine per file. Here is the revision file +supplied by NCAR for the autograph package. For NOAO specific enhancements, +see gio$ncarutil/README. + + Revision history: + + February, 1979 Added a revision history and enhanced machine + independency. + + September, 1979 Fixed a couple of problems which caused the code to + bomb when core was pre-set to indefinites and the + 1st graph drawn was peculiar in some way and another + which caused it to set the default dashed-line-speci- + fier length wrong. Added new documentation. + + October, 1979 Changed the way IDIOT behaves when NPTS is negative. + + March, 1980 Fixed a couple of small errors, one which prevented + an error exit in AGSETP from ever being reached and + another which caused AUTOGRAPH to blow up when given + a zero or negative on a logarithmic axis. Changed + the way in which NBPF is computed by AGSTR1. + + August, 1981 Removed all calls setting the plotter intensity and + made the computation of the variable SMRL portable. + + April, 1984 Made the code strictly FORTRAN-77 compatible, taking + out all dependency on support routines (such as LOC). + This required some changes in the user interface. + + February, 1985 Put code in AGSETP to reclaim character-store space + used by character-string dash patterns when they are + redefined using binary patterns. Also changed AGGTCH + to return a single blank for a non-existent string. + + August, 1985 Put code in AGGETP so that the label-name identifier + is now returned properly. Among other things, this + cures a problem which caused the character-storage + space to be eaten up. + + December, 1985 Fixed AGSETP to zero the current-line pointer when + the current-label pointer is changed. + + January, 1986 Fixed AGAXIS to respond properly to the zeroing of + NCIM by AGCHNL. diff --git a/sys/gio/ncarutil/autograph/agaxis.f b/sys/gio/ncarutil/autograph/agaxis.f new file mode 100644 index 00000000..4c3bec73 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agaxis.f @@ -0,0 +1,1851 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C A B R I E F D E S C R I P T I O N O F A U T O G R A P H +C --------------------------------------------------------------------- +C +C Following is a brief description of the AUTOGRAPH package. For a +C complete write-up, see the document "AUTOGRAPH - THE UNABRIDGED +C WRITE-UP". +C +C +C PACKAGE AUTOGRAPH +C +C LATEST REVISION January, 1986 +C +C PURPOSE To draw graphs, each with a labelled background +C and each displaying one or more curves. +C +C ACCESS (ON THE CRAY) To use AUTOGRAPH routines on the Cray, simply +C call them; they are in the binary library +C $NCARLB, which is automatically searched. +C +C To get smoother curves, drawn using spline +C interpolation, compile DASHSMTH, from ULIB, +C to replace DASHCHAR, from $NCARLB: +C +C GETSRC,LIB=ULIB,FILE=DASHSMTH,L=DSMTH. +C CFT,I=DSMTH,L=0. +C +C AUTOGRAPH contains a routine AGPWRT, which it +C calls to draw labels. This routine just passes +C its arguments on to the system-plot-package +C routine PWRIT. To use one of the fancier +C character-drawers, like PWRITX or PWRITY, +C just compile a routine AGPWRT to replace the +C default version; it has the same arguments as +C PWRIT and may either draw the character string +C itself, or just pass the arguments on to a +C desired character-drawer. The AUTOGRAPH +C specialist has some "standard" versions of +C AGPWRT and should be consulted for help in +C avoiding pitfalls. One standard version, +C which calls PWRITX, may be obtained using the +C following JCL: +C +C GETSRC,LIB=XLIB,FILE=AGUPWRITX,L=UPWRTX. +C CFT,I=UPWRTX,L=0. +C +C USAGE Following this indented preamble are given two +C lists: one describing the AUTOGRAPH routines +C and another describing the arguments of those +C routines. +C +C "AUTOGRAPH - THE UNABRIDGED WRITE-UP" gives +C a complete write-up of AUTOGRAPH, in great +C detail and with a set of helpful examples. +C +C ENTRY POINTS Except for seven routines which are included +C in the package for historical reasons (EZY, +C EZXY, EZMY, EZMXY, IDIOT, ANOTAT, and DISPLA), +C the AUTOGRAPH routines have six-character names +C beginning with the characters 'AG'. An alpha- +C betized list follows: +C +C AGAXIS AGBACK AGBNCH AGCHAX AGCHCU AGCHIL +C AGCHNL AGCTCS AGCTKO AGCURV AGDASH AGDFLT +C AGDLCH AGDSHN AGEXAX AGEXUS AGEZSU AGFPBN +C AGFTOL AGGETC AGGETF AGGETI AGGETP AGGTCH +C AGINIT AGKURV AGLBLS AGMAXI AGMINI AGNUMB +C AGPPID AGPWRT AGQURV AGRPCH AGRSTR AGSAVE +C AGSCAN AGSETC AGSETF AGSETI AGSETP AGSRCH +C AGSTCH AGSTUP AGUTOL +C +C NOTE: The "routine" AGDFLT is a block-data +C routine specifying the default values of +C AUTOGRAPH control parameters. +C +C SPECIAL CONDITIONS Under certain conditions, AUTOGRAPH may print +C an error message (via the routine SETER) and +C stop. Each error message includes the name of +C the routine which issued it. A description of +C the condition which caused the error may be +C found in the AUTOGRAPH write-up in the NCAR +C graphics manual; look in the write-up of the +C routine which issued the error message, under +C the heading 'SPECIAL CONDITIONS'. +C +C For error messages issued by the routine +C AGNUMB, see the write-up of the routine AGSTUP. +C +C If you get an error in the routine ALOG10, it +C probably means that you are using a logarithmic +C axis and some of the coordinate data along that +C axis are zero or negative. +C +C COMMON BLOCKS The AUTOGRAPH common blocks are AGCONP, AGORIP, +C AGOCHP, AGCHR1, and AGCHR2. AGCONP contains +C the AUTOGRAPH "control parameters", primary and +C secondary, all of which are real, AGORIP other +C real and/or integer parameters, AGOCHP other +C character parameters, AGCHR1 and AGCHR2 the +C variables implementing the character-storage- +C and-retrieval scheme of AUTOGRAPH. +C +C I/O Lower-level plotting routines are called to +C produce graphical output and, when errors +C occur, error messages may be written to the +C system error file, as defined by I1MACH(4), +C either directly or by way of a call to SETER. +C +C REQUIRED ULIB AUTOGRAPH uses the software dashed-line package +C ROUTINES DASHCHAR. Of course, either of the packages +C DASHSMTH or DASHSUPR may be used instead, to +C get smoother curves. +C +C SPECIALIST Dave Kennison, Scientific Computing Division, +C National Center for Atmospheric Research +C +C LANGUAGE FORTRAN +C +C HISTORY Dave Robertson wrote the original routine +C IDIOT, which was intended to provide a simple, +C quick-and-dirty, x-y graph-drawing capability. +C In time, as it became obvious that many users +C were adapting IDIOT to more sophisticated +C tasks, Dan Anderson wrote the first AUTOGRAPH +C package, based on IDIOT. It allowed the user +C to put more than one curve on a graph, to use +C more sophisticated backgrounds, to specify +C coordinate data in a variety of ways, and to +C more easily control the scaling and positioning +C of graphs. Eventually, this package, too, was +C found wanting. In 1977, Dave Kennison entirely +C re-wrote AUTOGRAPH, with the following goals: +C to maintain the ease of use for simple graphs +C which had been the principal virtue of the +C package, to provide the user with as much +C control as possible, to incorporate desirable +C new features, and to make the package as +C portable as possible. In 1984, the package +C was again worked over by Dave Kennison, to +C make it compatible with FORTRAN-77 and +C to remove any dependency on the LOC function, +C which had proved to cause difficulties on +C certain machines. The user interface was +C changed somewhat and some new features were +C added. A GKS-compatible version was written. +C +C SPACE REQUIRED AUTOGRAPH is big; one pays a price for its +C capabilities. On the Cray, it occupies a +C little under 30000 (octal) locations. The +C required plot package routines take about +C another 7000 (octal), the (modified) PORT +C support routines about another 1000 (octal), +C and system routines (math, I/O, miscellany) +C another 30000 (octal). +C +C PORTABILITY AUTOGRAPH may be ported with few modifications +C to most systems having a FORTRAN-77 compiler. +C +C The labelled common blocks may have to be +C declared in a part of the user program which +C is always core-resident so that variables +C in them will maintain their values from one +C AUTOGRAPH-routine call to the next. Such a +C problem may arise when AUTOGRAPH is placed in +C an overlay or when some sort of memory-paging +C scheme is used. +C +C REQUIRED RESIDENT AUTOGRAPH uses the DASHCHAR routines DASHDB, +C ROUTINES DASHDC, FRSTD, LASTD, LINED, AND VECTD, the +C system-plot-package routines FRAME, GETSET, +C GETSI, LINE, PWRIT, and SET, the support +C routines ISHIFT and IOR, the (modified) +C PORT utilities SETER and I1MACH, and the +C FORTRAN-library routines ALOG10, ATAN2, COS, +C SIN, AND SQRT. +C +C --------------------------------------------------------------------- +C U S E R - C A L L A B L E A U T O G R A P H R O U T I N E S +C --------------------------------------------------------------------- +C +C Following is a list of AUTOGRAPH routines to be called by the user +C (organized by function). Each routine is described briefly. The +C arguments of the routines are described in the next section. +C +C Each of the following routines draws a complete graph with one call. +C Each is implemented by a set of calls to the lower-level AUTOGRAPH +C routines AGSTUP, AGCURV, and AGBACK (which see, below). +C +C -- EZY (YDRA,NPTS,GLAB) - draws a graph of the curve defined by the +C data points ((I,YDRA(I)),I=1,NPTS), with a graph label specified +C by GLAB. +C +C -- EZXY (XDRA,YDRA,NPTS,GLAB) - draws a graph of the curve defined by +C the data points ((XDRA(I),YDRA(I)),I=1,NPTS), with a graph label +C specified by GLAB. +C +C -- EZMY (YDRA,IDXY,MANY,NPTS,GLAB) - draws a graph of the family of +C curves defined by data points (((I,YDRA(I,J)),I=1,NPTS),J=1,MANY), +C with a graph label specified by GLAB. The order of the subscripts +C of YDRA may be reversed - see the routine DISPLA, argument LROW. +C +C -- EZMXY (XDRA,YDRA,IDXY,MANY,NPTS,GLAB) - draws a graph of the +C family of curves defined by the data points (((XDRA(I),YDRA(I,J)), +C I=1,NPTS),J=1,MANY), with a graph label specified by GLAB. XDRA +C may be doubly-subscripted and the order of the subscripts of XDRA +C and YDRA may be reversed - see the routine DISPLA, argument LROW. +C +C -- IDIOT (XDRA,YDRA,NPTS,LTYP,LDSH,LABX,LABY,LABG,LFRA) - implements +C the routine from which AUTOGRAPH grew - not recommended - provided +C for antique lovers. +C +C The following routines provide user access to the AUTOGRAPH control +C parameters (in the labelled common block AGCONP). +C +C -- ANOTAT (XLAB,YLAB,LBAC,LSET,NDSH,DSHL) - may be used to change the +C x- and y-axis (non-numeric) labels, the background type, the way +C in which graphs are positioned and scaled, and the type of dash +C patterns to be used in drawing curves. +C +C -- DISPLA (LFRA,LROW,LTYP) - may be used to specify when, if ever, +C the EZ... routines do a frame advance, how input arrays for EZMY +C and EZMXY are dimensioned, and the linear/log nature of graphs. +C +C -- AGSETP (TPGN,FURA,LURA) - a general-purpose parameter-setting +C routine, used to set the group of parameters specified by TPGN, +C using values obtained from the array (FURA(I),I=1,LURA). +C +C -- AGSETF (TPGN,FUSR) - used to set the single parameter specified by +C TPGN, giving it the floating-point value FUSR. +C +C -- AGSETI (TPGN,IUSR) - used to set the single parameter specified by +C TPGN, giving it the floating-point value FLOAT(IUSR). +C +C -- AGSETC (TPGN,CUSR) - the character string CUSR is stashed in an +C array inside AUTOGRAPH and the floating-point equivalent of an +C identifier which may be used for later retrieval of the string is +C stored as the value of the single parameter specified by TPGN. The +C single parameter must be a label name, a dash pattern, the text of +C a label line, or the line-terminator character. +C +C -- AGGETP (TPGN,FURA,LURA) - a general-purpose parameter-getting +C routine, used to get the group of parameters specified by TPGN, +C putting the result in the array (FURA(I),I=1,LURA). +C +C -- AGGETF (TPGN,FUSR) - used to get, in FUSR, the floating-point +C value of the single parameter specified by TPGN. +C +C -- AGGETI (TPGN,IUSR) - used to get, in IUSR, the integer equivalent +C of the value of the single parameter specified by TPGN. +C +C -- AGGETC (TPGN,CUSR) - used to get, in CUSR, the character string +C whose identifier is specified by the integer equivalent of the +C single parameter specified by TPGN. The single parameter must +C be a label name, a dash pattern, the text of a label line, or the +C line-terminator character. +C +C The following are lower-level routines, which may be used to draw +C graphs of many different kinds. The EZ... routines call these. They +C are intended to be called by user programs, as well. +C +C -- AGSTUP (XDRA,NVIX,IIVX,NEVX,IIEX,YDRA,NVIY,IIVY,NEVY,IIEY) - this +C routine must be called prior to the first call to either of the +C two routines AGBACK and AGCURV, to force the set-up of secondary +C parameters controlling the behavior of those routines. After any +C parameter-setting call, AGSTUP must be called again before calling +C either AGBACK or AGCURV again. AGSTUP calls the routine "SET", in +C the plot package, so that user x/y coordinates in subsequent calls +C will map properly into the plotter space. +C +C -- AGBACK - draws the background defined by the current state of the +C AUTOGRAPH control parameters. +C +C -- AGCURV (XVEC,IIEX,YVEC,IIEY,NEXY,KDSH) - draws the curve defined +C by the arguments, positioning it as specified by the current state +C of the AUTOGRAPH control parameters. +C +C The following utility routines are called by the user. +C +C -- AGSAVE (IFNO) - used to save the current state of AUTOGRAPH by +C writing the appropriate information to a specified file. Most +C commonly used to save the default state for later restoration. +C This routine should be used instead of AGGETP when the object +C is to save the whole state of AUTOGRAPH, since it saves not only +C the primary control parameters, but all of the character strings +C pointed to by the primary control parameters. It is the user's +C responsibility to position the file before calling AGSAVE. +C +C -- AGRSTR (IFNO) - used to restore a saved state of AUTOGRAPH by +C reading the appropriate information from a specified file. Most +C commonly used to restore AUTOGRAPH to its default state. It is +C the user's responsibility to position the file before calling +C AGRSTR. +C +C -- AGBNCH (IDSH) - a function, of type CHARACTER*16 (it must be +C declared as such in a user routine referencing it), whose value, +C given a 16-bit binary dash pattern, is the equivalent character +C dash pattern. +C +C -- AGDSHN (IDSH) - a function, of type CHARACTER*16 (it must be +C declared as such in a user routine referencing it), whose value, +C given an integer "n" (typically between 1 and 26) is the character +C string 'DASH/ARRAY/nnnn.', which is the name of the nth dash +C pattern parameter. To set the 13th dash pattern, for example, +C one might use "CALL AGSETC (AGDSHN(13),'$$$$$$CURVE 13$$$$$$')". +C +C The following utility routines are called by AUTOGRAPH. The versions +C included in AUTOGRAPH itself are dummies; they do nothing but RETURN. +C The user may replace one or more of these routines with versions to +C accomplish specific purposes. +C +C -- AGUTOL (IAXS,FUNS,IDMA,VINP,VOTP) - called by AUTOGRAPH to perform +C the mapping from user-system values along an axis to label-system +C values along the axis and vice-versa. This routine may be replaced +C by the user to create a desired graph. +C +C -- AGCHAX (IFLG,IAXS,IPRT,VILS) - called by AUTOGRAPH just before and +C just after the various parts of the axes are drawn. +C +C -- AGCHCU (IFLG,KDSH) - called by AUTOGRAPH just before and just after +C each curve is drawn. +C +C -- AGCHIL (IFLG,LBNM,LNNO) - called by AUTOGRAPH just before and just +C after each line of an informational label is drawn. +C +C -- AGCHNL (IAXS,VILS,CHRM,MCIM,NCIM,IPXM,CHRE,MCIE,NCIE) - called by +C AUTOGRAPH just after the character strings defining a numeric label +C have been generated. +C +C --------------------------------------------------------------------- +C D E S C R I P T I O N S O F A R G U M E N T S +C --------------------------------------------------------------------- +C +C In calls to the routines EZY, EZXY, EZMY, and EZMXY: +C +C -- XDRA is an array of x coordinates, dimensioned as implied by the +C current value of the AUTOGRAPH control parameter 'ROW.' (see the +C description of the argument LROW, below). The value of the +C AUTOGRAPH parameter 'NULL/1.' (1.E36, by default) when used as an +C x coordinate, implies a missing data point; the curve segments +C on either side of such a point are not drawn. +C +C -- YDRA is an array of y coordinates, dimensioned as implied by the +C current value of the AUTOGRAPH control parameter 'ROW.' (see the +C description of the argument LROW, below). The value of the +C AUTOGRAPH parameter 'NULL/1.' (1.E36, by default) when used as a +C y coordinate, implies a missing data point; the curve segments +C on either side of such a point are not drawn. +C +C -- IDXY is the first dimension of the arrays XDRA (if it has two +C dimensions) and YDRA. +C +C -- MANY is the number of curves to be drawn by the call to EZ... - +C normally, the second dimension of XDRA (if it has two dimensions) +C and YDRA. +C +C -- NPTS is the number of points defining each curve to be drawn by +C the routine EZ... - normally, the first (or only) dimension of +C XDRA and YDRA. +C +C -- GLAB is a character constant or a character variable, defining a +C label to be placed at the top of the graph. The string may not be +C more than 40 characters long - if it is fewer than 40 characters +C long, its last character must be a dollar sign. (The dollar sign +C is not a part of the label - it is stripped off.) The character +C string "CHAR(0)" may be used to indicate that the previous label, +C whatever it was, should continue to be used. The initial graph +C label consists of blanks. +C +C In calls to the routine ANOTAT: +C +C -- XLAB and YLAB resemble GLAB (see above) and define labels for the +C x and y axes. The default x-axis label is the single character +C X, the default y-axis label the single character Y. Note that one +C may use the string "CHAR(0)" to indicate that the x-axis (y-axis) +C label is not to be changed from what it was previously. +C +C -- LBAC, if non-zero, specifies a new value for the AUTOGRAPH control +C parameter 'BACKGROUND.', as follows: +C +C 1 - a perimeter background +C +C 2 - a grid background +C +C 3 - an axis background +C +C 4 - no background +C +C The default value of 'BACKGROUND.' is 1. +C +C -- LSET, if non-zero, specifies a new value for the AUTOGRAPH control +C parameter 'SET.'. This parameter may be negated to suspend the +C drawing of curves by the EZ... routines, so that a call to one of +C them will produce only a background. The absolute value of 'SET.' +C affects the way in which AUTOGRAPH determines the position and +C shape of the graph and the scaling of the axes, as follows: +C +C 1 - Restores the default values of the AUTOGRAPH parameters +C in question. AUTOGRAPH will set up an appropriate call +C to the plot-package routine "SET", over-riding any prior +C call to that routine. +C +C 2 - Tells AUTOGRAPH to use arguments 1-4 and 9 of the last +C "SET" call. Arguments 1-4 specify where the graph should +C fall on the plotter frame, argument 9 whether the graph +C is linear/linear, linear/log, etc. +C +C 3 - Tells AUTOGRAPH to use arguments 5-8 and 9 of the last +C "SET" call. Arguments 5-8 specify the scaling of the +C axes, argument 9 whether the graph is linear/linear, +C linear/log, etc. +C +C 4 - A combination of 2 and 3. Arguments 1-4 of the last "SET" +C call specify the position, arguments 5-8 the scaling, and +C argument 9 the linear/log nature, of the graph. +C +C (The plot-package routine "SET" is described in the NCAR Graphics +C Manual; it is not a part of AUTOGRAPH.) +C +C If the routine DISPLA is called with its argument LTYP non-zero, +C the linear/log nature of the graph will be that specified by LTYP, +C not that specified by the last "SET" call, no matter what the value +C of the control parameter 'SET.'. +C +C The default value of 'SET.' is 1. +C +C -- NDSH, if non-zero, specifies a new value of the AUTOGRAPH control +C parameter 'DASH/SELECTOR.' (and therefore a new set of dashed-line +C patterns), as described below. Note: The default value of the +C dashed-line parameters is such that all curves will be drawn using +C solid lines; if that is what you want, use a zero for NDSH. +C +C If the value of 'DASH/SELECTOR.' is negative, curves produced +C by subsequent calls to EZMY or EZMXY will be drawn using a +C set of alphabetic dashed-line patterns. The first curve drawn +C by a given call will be labelled 'A', the second 'B', ..., the +C twenty-sixth 'Z', the twenty-seventh 'A' again, and so on. +C Curves drawn by calls to EZY and EZXY will be unaffected. +C +C If the value of 'DASH/SELECTOR.' is positive, it must be less +C than or equal to 26. The next argument, DSHL, is an array +C containing NDSH dashed-line patterns. All curves produced by +C subsequent calls to EZY, EZXY, EZMY, and EZMXY will be drawn +C using the dashed-line patterns in (DSHL(I),I=1,NDSH) - the +C first curve produced by a given call will have the pattern +C specified by DSHL(1), the second that specified by DSHL(2), +C the third that specified by DSHL(3), . . . the NDSH+1st that +C specified by DSHL(1), . . . etc. Each element of DSHL must +C be a character string, in which a dollar sign stands for a +C solid-line segment, a quote stands for a gap, and other +C characters stand for themselves. See the write-up of the +C package "DASHCHAR". Binary dashed-line patterns may not be +C defined by means of a call to ANOTAT, only by means of calls +C to lower-level routines. +C +C -- DSHL (if NDSH is greater than zero) is an array of dashed-line +C patterns, as described above. +C +C In calls to the routine DISPLA: +C +C -- LFRA, if non-zero, specifies a new value for the AUTOGRAPH control +C parameter 'FRAME.'. Possible values are as follows: +C +C 1 - The EZ... routines do a frame advance after drawing. +C +C 2 - No frame advance is done by the EZ... routines. +C +C 3 - The EZ... routines do a frame advance before drawing. +C +C The default value of 'FRAME.' is 1. +C +C -- LROW, if non-zero, specifies a new value for the AUTOGRAPH control +C parameter 'ROW.'. This parameter tells AUTOGRAPH how the argument +C arrays XDRA and YDRA, in calls to the routines EZMY and EZMXY, are +C subscripted, as follows: +C +C If 'ROW.' is positive, this implies that the first subscript +C of YDRA is a point number and the second subscript is a curve +C number. If 'ROW.' is negative, the order is reversed. +C +C If the absolute value of 'ROW.' is 1, this implies that XDRA +C is singly-subscripted, by point number only. If the absolute +C value of 'ROW.' is 2 or greater, this implies that XDRA is +C doubly-subscripted, just like YDRA. +C +C The default value of 'ROW.' is 1, spicifying that XDRA is singly- +C subscripted and that YDRA is doubly-subscripted by point number +C and curve number, in that order. +C +C -- LTYP, if non-zero, specifies new values for the AUTOGRAPH control +C parameters 'X/LOGARITHMIC.' and 'Y/LOGARITHMIC.', which determine +C whether the X and Y axes are linear or logarithmic. Possible +C values are as follows: +C +C 1 - x axis linear, y axis linear +C +C 2 - x axis linear, y axis logarithmic +C +C 3 - x axis logarithmic, y axis linear +C +C 4 - x axis logarithmic, y axis logarithmic +C +C The default values of these parameters make both axes linear. +C +C If the parameters 'X/LOGARITHMIC.' and 'Y/LOGARITHMIC.' are reset +C by the routine DISPLA, they are given values which make them +C immune to being reset when 'SET.' = 2, 3, or 4 (see the discussion +C of the argument LSET, above). +C +C In calls to the routines AGSETP, AGSETF, AGSETI AGSETC, AGGETP, +C AGGETF, AGGETI, and AGGETC: +C +C -- TPGN is a character string identifying a group of AUTOGRAPH +C control parameters. It is of the form 'K1/K2/K3/ . . . /Kn.'. +C Each Ki is a keyword. The keyword K1 specifies a group of control +C parameters, K2 a subgroup of that group, K3 a subgroup of that +C subgroup, etc. See the AUTOGRAPH write-up in the graphics manual +C for a more complete description of these parameter-group names and +C the ways in which they may be abbreviated. +C +C -- FURA is an array, from which control-parameter values are to be +C taken (the routine AGSETP) or into which they are to be stored +C (the routine AGGETP). Note that the array is real; all of the +C AUTOGRAPH parameters are stored internally as reals. +C +C -- LURA is the length of the user array FURA. +C +C -- FUSR is a variable, from which a single control parameter value is +C to be taken (the routine AGSETF) or in which it is to be returned +C (the routine AGGETF). Note that the variable is real. +C +C -- IUSR is a variable, from which a single-control parameter value is +C to be taken (the routine AGSETI) or in which it is to be returned +C (the routine AGGETI). Note that, since the control parameters are +C stored internally as reals, each of the routines AGSETI and AGGETI +C does a conversion - from integer to real or vice-versa. Note also +C that AGSETI and AGGETI should only be used for parameters which +C have intrinsically integral values. +C +C -- CUSR is a character variable from which a character string is to +C be taken (the routine AGSETC) or into which it is to be retrieved +C (the routine AGGETC). The control parameter affected by the call +C contains the floating-point equivalent of an integer identifier +C returned by the routine which stashes the character string and +C tendered to the routine which retrieves it (sort of the automated +C equivalent of a hat check). Note that AGSETC and AGGETC should +C only be used for parameters which intrinsically represent character +C strings. +C +C In calls to the routine AGSTUP: +C +C -- XDRA is an array of x coordinates of user data - usually, but not +C necessarily, the same data which will later be used in calls to +C the routine AGCURV. +C +C -- NVIX is the number of vectors of data in XDRA - if XDRA is doubly- +C dimensioned, NVIX would normally have the value of its second +C dimension, if XDRA is singly-dimensioned, a 1. +C +C -- IIVX is the index increment between vectors in XDRA - if XDRA is +C doubly-dimensioned, IIVX would normally have the value of its +C first dimension, if XDRA is singly-dimensioned, a dummy value. +C +C -- NEVX is the number of elements in each data vector in XDRA - if +C XDRA is doubly-dimensioned, NEVX would normally have the value of +C its first dimension, if XDRA is singly-dimensioned, the value of +C that single dimension. +C +C -- IIEX is the index increment between elements of a data vector in +C XDRA - normally a 1. +C +C -- YDRA, NVIY, IIVY, NEVY, and IIEY are analogous to XDRA, NVIX, +C IIVX, NEVX, and IIEX, but define y-coordinate data. +C +C In calls to the routine AGCURV: +C +C -- XVEC is a vector of x coordinate data. +C +C -- IIEX is the index increment between elements in XVEC. AGCURV will +C use XVEC(1), XVEC(1+IIEX), XVEC(1+2*IIEX), etc. +C +C -- YVEC is a vector of y coordinate data. +C +C -- IIEY is the index increment between elements in YVEC. AGCURV will +C use YVEC(1), YVEC(1+IIEY), YVEC(1+2*IIEY), etc. +C +C -- NEXY is the number of points defining the curve to be drawn. +C +C -- KDSH is a dashed-line selector. Possible values are as follows: +C +C If KDSH is zero, AUTOGRAPH will assume that the user has +C called the routine DASHD (in the DASHCHAR package, which see) +C to define the dashed-line pattern to be used. +C +C If KDSH is less than zero and has absolute value M, AUTOGRAPH +C will use the Mth (modulo 26) alphabetic dashed-line pattern. +C Each of these patterns defines a solid line interrupted every +C so often by a letter of the alphabet. +C +C If KDSH is greater than zero and has the value M, AUTOGRAPH +C will use the Mth (modulo N) dashed-line pattern in the group +C of N dashed-line patterns defined by the AUTOGRAPH control +C parameters in the group named 'DASH/PATTERNS.'. The default +C values of these parameters specify solid lines. +C +C In calls to the routines AGSAVE and AGRSTR: +C +C -- IFNO is the unit number associated with a file to which a single +C unformatted logical record of data is to be written, or from which +C such a record is to be read, by AUTOGRAPH. The file is not rewound +C before being written or read; positioning it properly is the user's +C responsibility. +C +C In calls to the function AGBNCH: +C +C -- IDSH is a 16-bit binary dash pattern, the character equivalent of +C which is to be returned as the value of AGBNCH. +C +C In calls to the function AGDSHN: +C +C -- IDSH is the number of the dash pattern parameter whose name is to +C be returned as the value of the function AGDSHN. +C +C In calls to the routine AGUTOL: +C +C -- IAXS is the number of the axis. The values 1, 2, 3, and 4 imply +C the left, right, bottom, and top axes, respectively. +C +C -- FUNS is the value of the parameter 'AXIS/s/FUNCTION.' which may be +C used to select the desired mapping function for axis IAXS. It is +C recommended that the default value (zero) be used to specify the +C identity mapping. A non-zero value may be integral (1., 2., etc.) +C and serve purely to select the code to be executed or it may be the +C value of a real parameter in the equations defining the mapping. +C +C -- IDMA specifies the direction of the mapping. A value greater than +C zero indicates that VINP is a value in the user system and that +C VOTP is to be a value in the label system, a value less than zero +C the opposite. +C +C -- VINP is an input value in one coordinate system along the axis. +C +C -- VOTP is an output value in the other coordinate system along the +C axis. +C +C In calls to the routine AGCHAX: +C +C -- IFLG is zero if a particular object is about to be drawn, non-zero +C if it has just been drawn. +C +C -- IAXS is the number of the axis being drawn. The values 1, 2, 3, +C and 4 indicate the left, right, bottom, and top axes, respectively. +C +C -- IPRT indicates the part of the axis being drawn. Possible values +C are as follows: +C +C -- 1 implies the line of the axis. +C +C -- 2 implies a major tick. +C +C -- 3 implies a minor tick. +C +C -- 4 implies the mantissa of a numeric label. +C +C -- 5 implies the exponent of a numeric label. +C +C -- VILS is the value in the label system at the point where the part +C is being drawn. For IPRT = 1, VILS is zero. +C +C In calls to the routine AGCHCU: +C +C -- IFLG is zero if a particular object is about to be drawn, non-zero +C if it has just been drawn. +C +C -- KDSH is the value with which AGCURV was called, as follows: +C +C AGCURV called by Value of KDSH +C ---------------- ---------------------------------------- +C EZY 1 +C EZXY 1 +C EZMY "n" or "-n", where n is the curve number +C EZMXY "n" or "-n", where n is the curve number +C the user program the user value +C +C In calls to the routine AGCHIL: +C +C -- IFLG is zero if a particular object is about to be drawn, non-zero +C if it has just been drawn. +C +C -- LBNM is a character variable containing the name of the label being +C drawn. +C +C -- LNNO is the number of the line being drawn. +C +C In calls to the routine AGCHNL: +C +C -- IAXS is the number of the axis being drawn. The values 1, 2, 3, +C and 4 imply the left, right, bottom, and top axes, respectively. +C +C -- VILS is the value to be represented by the numeric label, in the +C label system for the axis. The value of VILS must not be altered. +C +C -- CHRM, on entry, is a character string containing the mantissa of +C the numeric label, as it will appear if AGCHNL makes no changes. +C If the numeric label includes a "times" symbol, it is represented +C by a blank in CHRM. (See IPXM, below.) CHRM may be modified. +C +C -- MCIM is the length of CHRM - the maximum number of characters that +C it will hold. The value of MCIM must not be altered. +C +C -- NCIM, on entry, is the number of meaningful characters in CHRM. If +C CHRM is changed, NCIM should be changed accordingly. +C +C -- IPXM, on entry, is zero if there is no "times" symbol in CHRM; if +C it is non-zero, it is the index of a character position in CHRM. +C If AGCHNL changes the position of the "times" symbol in CHRM, +C removes it, or adds it, the value of IPXM must be changed. +C +C -- CHRE, on entry, is a character string containing the exponent of +C the numeric label, as it will appear if AGCHNL makes no changes. +C CHRE may be modified. +C +C -- MCIE is the length of CHRE - the maximum number of characters that +C it will hold. The value of MCIE must not be altered. +C +C -- NCIE, on entry, is the number of meaningful characters in CHRE. If +C CHRE is changed, NCIE should be changed accordingly. +C +C --------------------------------------------------------------------- +C T H E A U T O G R A P H C O D E +C --------------------------------------------------------------------- +C +C Following is the AUTOGRAPH code. Routines appear in alphabetic order. +C + SUBROUTINE AGAXIS (IAXS,QTST,QSPA,WCWP,HCWP,XBGA,YBGA,XNDA,YNDA, + + QLUA,UBGA,UNDA,FUNS,QBTP,BASE,QJDP,WMJL,WMJR, + + QMNT,QNDP,WMNL,WMNR,QLTP,QLEX,QLFL,QLOF,QLOS, + + DNLA,WCLM,WCLE,RFNL,QCIM,QCIE,WNLL,WNLR,WNLB, + + WNLE) +C +C The routine AGAXIS is used to draw, tick-mark, and label an axis or, +C if ITST is non-zero, to pre-compute the amount of space which will be +C required for numeric labels when the axis is actually drawn. AGAXIS +C assumes that the last call to the plot-package routine SET was as +C follows (or the equivalent thereof): +C +C CALL SET (XLCW,XRCW,YBCW,YTCW,0.,1.,0.,1.,1) +C +C where XLCW, XRCW, YBCW, and YTCW are the coordinates of the left, +C right, bottom, and top edges of the curve window, stated as fractions +C of the appropriate edge of the plotter frame. +C +C The arguments of AGAXIS are as follows: +C +C -- IAXS is the number of the axis being drawn - 1, 2, 3, or 4, meaning +C the left, right, bottom, and top axes, respectively. +C +C -- ITST is an integer specifying what the caller wishes AGAXIS to do, +C as follows: +C +C -- If ITST .LT. 0, AGAXIS is to draw only the axis, nothing else. +C +C -- If ITST .EQ. 0, AGAXIS is to draw, tick, and label the axis. +C +C -- If ITST .GT. 0, AGAXIS is to pre-compute the amount of space +C which will be required for numeric labels. If the labels will +C not fit in the space provided, AGAXIS is instructed to take +C action as follows: +C +C -- ITST .EQ. 1 - no action. +C +C -- ITST .EQ. 2 - shrink the labels. +C +C -- ITST .EQ. 3 - re-orient the labels. +C +C -- ITST .EQ. 4 - shrink and/or re-orient the labels. +C +C -- ISPA is a 0 or a 1, specifying whether or not the axis itself is +C to be drawn. If ISPA .NE. 0, the axis is suppressed. Tick marks +C and/or labels may still be drawn. +C +C -- WCWP is the width of the curve window, in plotter units. +C +C -- HCWP is the height of the curve window, in plotter units. +C +C -- XBGA, YBGA, XNDA, and YNDA are the x and y coordinates of the ends +C of the axis. X coordinates are stated as fractions of the width, +C y coordinates as fractions of the height, of the curve window. The +C axis to be drawn must be either horizontal or vertical (at an angle +C of 0, 90, 180, or 270 degrees). The left side, right side, begin- +C ning, and end of the axis are defined from the viewpoint of a demon +C standing at (XBGA,YBGA) and staring balefully toward (XNDA,YNDA). +C +C -- LLUA, UBGA, and UNDA define the mapping of the "user" coordinate +C system (used for data-point coordinates) onto the axis. If LLUA +C is zero, the mapping is linear; if LLUA is non-zero, the mapping +C is logarithmic. UBGA is the user-system value at the beginning of +C the axis, UNDA the value at the end of the axis. The subroutine +C AGFTOL, which needs these parameters, is actually passed LLUA, +C UBEG=F(UBGA), and UDIF=F(UNDA)-F(UBGA), where F is the function +C F(X)=X or the function F(X)=ALOG10(X), depending on LLUA. +C +C -- FUNS is a function-selector, to be used in calls to AGUTOL, which +C defines the mappings from the user system to the label system and +C vice-versa for each of the four axes. The functions defined must +C be continuous, monotonic, and bounded within the user-system range +C (UBGA,UNDA) and a little bit outside that range. The positions +C of numeric labels and tick marks are chosen in the label system, +C mapped to the user system, and then onto the axis. +C +C -- NBTP and BASE specify how major ticks are to be positioned in the +C label coordinate system. See the routine AGNUMB (arguments NBTP, +C SBSE, and EXMU) for a description of these arguments. Note that +C NBTP .EQ. 0 or BASE .EQ. 0. suppresses both major tick marks and +C their labels. Note: SBSE .EQ. +BASE or -BASE, as needed. +C +C -- QJDP is the major-tick-mark dash pattern (0. .LE. QJDP .LE. 65535.) +C QJDP .LE. 0 suppresses major ticks. +C +C -- WMJL and WMJR are the distances to the left and right ends of the +C major tick marks, stated as fractions of the shortest side of the +C curve window. Values .EQ. 0 may be used to suppress one or both +C portions. Values .GE. 1 may be used to extend a given portion all +C the way to the edge of the curve window. (See routine AGCTKO.) +C +C -- NMNT is the number of minor tick marks to be placed between each +C pair of consecutive major tick marks. NMNT .EQ. 0 suppresses them. +C +C -- QNDP, WMNL, and WMNR are analogous to QJDP, WMJL, and WMJR, but +C specify minor-tick-mark characteristics. +C +C -- NLTP, NLEX, and NLFL specify the graphic form of numeric labels, as +C described in the routine AGNUMB (which see). Note that NLTP .LE. 0 +C suppresses numeric labels. +C +C -- NLOF and NLOS are first and second choices for the numeric label +C orientation. Both must be multiples of 90, specifying an angle +C measured in degrees counter-clockwise from a vector running from +C left to right in the curve window. If ITST .EQ. 0, AGAXIS uses +C NLOF if it is .GE. 0, NLOS otherwise, for the label orientation. +C If ITST .NE. 0, AGAXIS initially makes both NLOF and NLOS positive. +C Then, if ITST .GE. 3, NLOF may or may not be made negative. (To +C set the sign of NLOF or NLOS, AGAXIS adds or subtracts 360*K.) +C +C -- DNLA is the desired distance of numeric labels from the axis, +C positive to the left, negative to the right, of the axis. The +C magnitude of DNLA is the size of the gap between the axis and the +C nearest edge of a label, expressed as a fraction of the smaller +C dimension of the curve window. See also RFNL, below. +C +C -- WCLM and WCLE are the desired widths of characters in the mantissa +C or the exponent, respectively, of numeric labels, expressed as a +C fraction of the smaller dimension of the curve window. See also +C RFNL, below. +C +C -- RFNL is a reduction factor, used as a multiplier for DNLA, WCLM, +C and WCLE. If ITST .NE. 0, RFNL is initially set to 1. - then, if +C ITST .EQ. 2 or 4, it is reset as necessary to shrink the labels. +C +C -- MCIM and MCIE specify the maximum number of characters in the +C mantissa and exponent, respectively, of a numeric label. These +C are input parameters if ITST .EQ. 0, output parameters otherwise. +C +C -- WNLL, WNLR, WNLB, and WNLE are the widths of numeric-label strips +C on the left side, on the right side, at the beginning, and at the +C end, of the axis. These are both input and output parameters of +C AGAXIS. On input, they specify the amount of space available for +C numeric labels - on output, they specify the amount of space used +C (if ITST .EQ. 0) or required (if ITST .NE. 0). Each is stated as +C a fraction of either the width or the height of the curve window, +C depending on the orientation of the axis in the curve window. +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. The only ones +C actually used here are ISLD, MWCM, MWCE, and MDLA. ISLD is a solid- +C line dash pattern (sixteen one bits). MWCM, MWCE, and MDLA specify +C the minimum allowed values of the width of a character in a label +C mantissa, the width of a character in a label exponent, and the +C distance of a label from the axis. All are in plotter coordinate +C units. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C The AUTOGRAPH function AGFPBN is of type integer. +C + INTEGER AGFPBN +C +C Local data required are as follows: +C +C BFRM is a buffer in which the routine AGNUMB returns the characters of +C a label mantissa. CTMP holds a sub-string from an AGPWRT call. +C + CHARACTER*40 BFRM + CHARACTER*40 CTMP +C +C BFRE is a buffer in which the routine AGNUMB returns the characters of +C a label exponent. +C + CHARACTER*5 BFRE +C +C XMJT, YMJT, XMNT, and YMNT are used to hold x and y offsets to the +C endpoints of left-of-label and right-of-label portions of major and +C minor tick marks. +C + DIMENSION XMJT(4),YMJT(4),XMNT(4),YMNT(4) +C +C SMJP is the minimum distance allowed between major tick marks, in +C plotter coordinate units. +C + DATA SMJP / 4. / +C +C FBGM, FBGP, FNDM, and FNDP are the coordinates of points a little on +C either side of the beginning and end of the axis, as fractions of the +C distance along the axis. +C + DATA FBGM / -0.000001 / + DATA FBGP / +0.000001 / + DATA FNDM / +0.999999 / + DATA FNDP / +1.000001 / +C +C HCFW is an arithmetic statement function specifying the height of a +C character as a function of its width (not counting "white space"). +C The value of the multiplier was determined heuristically, by trying +C various values and seeing which gave the best results. +C + HCFW(WDTH)=1.25*WDTH +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C This is the initialization section of AGAXIS. +C +C Unpack integer values from floating-point arguments. +C + ITST=IFIX(QTST) + ISPA=IFIX(QSPA) + LLUA=IFIX(QLUA) + NBTP=IFIX(QBTP) + NMNT=IFIX(QMNT) + NLTP=IFIX(QLTP) + NLEX=IFIX(QLEX) + NLFL=IFIX(QLFL) + NLOF=IFIX(QLOF) + NLOS=IFIX(QLOS) + MCIM=IFIX(QCIM) + MCIE=IFIX(QCIE) +C +C Initialize the local flags which specify what entities to draw, using +C values appropriate for the following quick exit. +C + LDAX=1-ISPA + LDNL=0 + LDMN=0 +C +C If AGAXIS is to draw only the axis, exit immediately. +C + IF (ITST.LT.0) GO TO 800 +C +C If either NBTP or BASE is zeroed, exit immediately. +C + IF (NBTP.EQ.0.OR.BASE.EQ.0.) GO TO 800 +C +C Re-initialize the flag controlling the drawing of numeric labels. +C + IF (NLTP.NE.0) LDNL=1 +C +C If this is not a test run, skip. +C + IF (ITST.EQ.0) GO TO 101 +C +C This is a test run - exit if there are no numeric labels. +C + IF (LDNL.EQ.0) GO TO 800 +C +C This is a test run and the axis is to have numeric labels - initialize +C the numeric-label orientation and sizing parameters. Clobber drawing. +C + NLOF=MOD(NLOF+3600,360) + NLOS=MOD(NLOS+3600,360) + RFNL=1. + MCIM=0 + MCIE=0 + LDMJ=0 + LDMN=0 +C +C The main body of the initialization follows. +C +C Compute the length of the smaller side of the curve window, in the +C plotter coordinate system. +C + 101 SCWP=AMIN1(WCWP,HCWP) +C +C Compute a set of direction numbers for the axis, in the curve-window +C coordinate system (the change in x and y from the beginning to the +C end of the axis). +C + XDNA=XNDA-XBGA + YDNA=YNDA-YBGA +C +C Compute the length of the axis in the plotter coordinate system and +C its direction cosines. +C + XDNP=XDNA*WCWP + YDNP=YDNA*HCWP + AXLP=SQRT(XDNP*XDNP+YDNP*YDNP) + XDCA=XDNP/AXLP + YDCA=YDNP/AXLP +C +C Compute the axis orientation angle, in degrees counter-clockwise. +C + IAOR=MOD(IFIX(57.2957795130823*ATAN2(YDCA,XDCA)+3600.5),360) +C +C Compute the multiplicative constants required to convert a fraction of +C the axis length to a fraction of the width or height of the curve +C window (a distance in x or y). +C + CFAX=AXLP/WCWP + CFAY=AXLP/HCWP +C +C Compute the multiplicative constants required to convert a fraction of +C the axis length to a fraction of the along-axis and perpendicular-to- +C axis sides of the curve window. +C + CFAA=ABS(XDCA*CFAX+YDCA*CFAY) + CFAP=ABS(XDCA*CFAY+YDCA*CFAX) +C +C Compute the quantities (UBEG) and (UDIF) for AGFTOL. +C + IF (LLUA.NE.0) GO TO 102 +C + UBEG=UBGA + UDIF=UNDA-UBGA + GO TO 103 +C + 102 UBEG=ALOG10(UBGA) + UDIF=ALOG10(UNDA)-UBEG +C +C SMJT and SMNT are fractions of the axis length and specify the minimum +C space which must be available between two major ticks before the major +C ticks themselves or the minor ticks between them, respectively, may be +C drawn. +C + 103 SMJT=SMJP/AXLP + SMNT=SMJT*FLOAT(NMNT+1) +C +C Initialize the fractional numeric-label character heights. +C + FHCM=0. + FHCE=0. +C +C If the axis has no numeric labels, skip the following code. +C + IF (LDNL.EQ.0) GO TO 104 +C +C Zero the numeric-label offset. +C + FNLO=0. +C +C The numeric-label parameters are computed by an internal procedure +C (which see, below). +C + ASSIGN 104 TO JMP3 + GO TO 500 +C +C If this is a test run, skip the following code. +C + 104 IF (ITST.NE.0) GO TO 200 +C +C This is not a test run. First, set up the tick-mark parameters. +C +C Compute the multiplicative constant required to convert a fraction of +C the smaller dimension of the grid to a fraction of the axis length. +C + CSFA=SCWP/AXLP +C +C Compute the widths of the left and right portions of the numeric-label +C space as fractions of the axis length, affixing an appropriate sign. +C + FNLL=-WNLL/CFAP + FNLR=+WNLR/CFAP +C +C Compute a jump parameter to sort out the axis orientations. +C + JAOR=1+IAOR/90 +C +C The routine AGCTKO is used to compute the rest of the tick parameters. +C + CALL AGCTKO (XBGA,YBGA,XDCA,YDCA,CFAX,CFAY,CSFA,JAOR, 1,QJDP, + + WMJL,WMJR,FNLL,FNLR,MJ12,MJ34,XMJT,YMJT) +C + CALL AGCTKO (XBGA,YBGA,XDCA,YDCA,CFAX,CFAY,CSFA,JAOR,NMNT,QNDP, + + WMNL,WMNR,FNLL,FNLR,MN12,MN34,XMNT,YMNT) +C +C Set the flags controlling the drawing of tick marks. +C + LDMJ=MJ12+MJ34 + LDMN=MN12+MN34 + LDLR=-(LDMJ+LDMN) +C +C If no numeric labels are to be drawn, skip the following code. +C + IF (LDNL.EQ.0) GO TO 117 +C +C Numeric labels are to be drawn. Precompute parameters which will be +C used to position labels relative to the axis. +C +C Compute the widths and heights of the longest possible label mantissa +C and exponent, as fractions of the length of the axis. +C + FWLM=FLOAT(MCIM)*FWCM + FWLE=FLOAT(MCIE)*FWCE + FHLM=FHCM + FHLE=FHCE + IF (MCIE.EQ.0) FHLE=0. +C +C Jump on the label-to-axis orientation. +C + GO TO (105,106,107,108) , JLAO +C +C Label is at a 0-degree angle to the axis. +C + 105 FBLP=-FHLM + GO TO 109 +C +C Label is at a 90-degree angle to the axis. +C + 106 FBLA=0. + FBLQ=-FWLM-FWLE + GO TO 110 +C +C Label is at a 180-degree angle to the axis. +C + 107 FBLP=FHLM+FHLE + GO TO 109 +C +C Label is at a 270-degree angle to the axis. +C + 108 FBLA=0. + FBLQ=FWLM+FWLE + GO TO 110 +C +C Label is parallel to the axis. +C + 109 FNLW=FHLM+.5*FHLE + FBLQ=0. + GO TO 111 +C +C Label is perpendicular to the axis. +C + 110 FNLW=FWLM+FWLE + FBLP=0. +C +C If the labels will not fit in the space provided, clobber them. +C + 111 IF (.999999*FNLW.LT.FNLR-FNLL) GO TO 112 +C + LDNL=0 + GO TO 117 +C +C Jump on the signed value of the numeric-label distance from the axis. +C + 112 IF (DNLA) 113,114,115 +C +C Labels are to the right of the axis. +C + 113 FNLC=FDLA+.5*FNLW + FBLP=FDLA+.5*ABS(FBLP-FHLE) + FBLQ=FDLA+.5*ABS(FBLQ+FWLM-FWLE) + GO TO 116 +C +C Labels are centered on the axis. +C + 114 FNLC=0. + FBLP=0. + FBLQ=0. + GO TO 116 +C +C Labels are to the left of the axis. +C + 115 FNLC=-(FDLA+.5*FNLW) + FBLP=-(FDLA+.5*ABS(FBLP)) + FBLQ=-(FDLA+.5*ABS(FBLQ-FWLM+FWLE)) +C + 116 FNLO=.5*(FNLL+FNLR)-FNLC +C +C If the axis would pass through the offset labels, clobber it. +C + IF (FNLL*FNLR.LT.0.) LDAX=0 +C +C Jump to draw numeric labels and/or tick marks. +C + GO TO 200 +C +C No numeric labels are to be drawn. If no tick marks are to be drawn +C either, exit. +C + 117 IF (LDLR.EQ.0) GO TO 800 +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C The following code directs the process of tick-marking and labelling +C the axis, using the internal procedures which follow it. If the +C label-coordinate-system value 0 maps onto the axis, tick-marking and +C labelling are done in two passes, one starting at 0 and proceeding +C in a positive direction and the other starting at 0 and proceeding +C in a negative direction. If the label-coordinate-system value 0 does +C not map onto the axis, only one pass is required. +C +C First, determine the label-coordinate-system values VBGM and VNDP at +C the points FBGM and FNDP, a little beyond the ends of the axis. +C + 200 CALL AGFTOL (IAXS,1,FBGM,VBGM,DUMI,LLUA,UBEG,UDIF,FUNS,NBTP,BASE) + CALL AGFTOL (IAXS,1,FNDP,VNDP,DUMI,LLUA,UBEG,UDIF,FUNS,NBTP,BASE) +C +C If zero falls on the axis, jump to the two-pass section of the code. +C + IF (VBGM*VNDP.LE.0.) GO TO 201 +C +C We may tick-mark and label the axis in a single pass. Compute an +C appropriate starting value for the exponent/multiplier EXMU. +C + SBSE=SIGN(BASE,VBGM) + CALL AGFTOL (IAXS,2,FBGM,EBGM,DUMI,LLUA,UBEG,UDIF,FUNS,NBTP,SBSE) + CALL AGFTOL (IAXS,2,FNDP,ENDP,DUMI,LLUA,UBEG,UDIF,FUNS,NBTP,SBSE) + EXMU=AMIN1(EBGM,ENDP) + EXMU=EXMU-AMOD(EXMU,1.)+.5+SIGN(.5,EXMU) +C +C Set the numeric-label-space limits for the beginning and end of the +C axis. +C + FNLB=FBGM-WNLB/CFAA-.5*(FHCM+FHCE) + FNLE=FNDP+WNLE/CFAA+.5*(FHCM+FHCE) +C +C Jump to an internal procedure to tick-mark and label the axis. Return +C from there to the termination section of AGAXIS. +C + ASSIGN 800 TO JMP1 + GO TO 300 +C +C Tick marks and labels must be done in two passes. First, draw the +C tick mark and/or label at the zero position in the label system, using +C an internal procedure below. A number of parameters must be preset. +C + 201 CALL AGFTOL (IAXS,-1,0.,FRAX,VLCS,LLUA,UBEG,UDIF,FUNS,NBTP,BASE) +C +C Determine whether label is to be drawn or not. +C + LDLB=0 + IF (LDNL.EQ.0) GO TO 202 + LDLB=1 +C +C The mantissa portion of the label consists of the single character 0. +C + BFRM(1:1)='0' + NCIM=1 + IPXM=0 +C +C The label has no exponent portion. +C + NCIE=0 +C +C Allow the user to change the numeric label. +C + CALL AGCHNL (IAXS,VLCS,BFRM,40,NCIM,IPXM,BFRE,5,NCIE) +C +C Compute the length of the mantissa, the exponent, and the whole label. +C + FLLM=FLOAT(NCIM)*FWCM + FLLE=FLOAT(NCIE)*FWCE + FLLB=FLLM+FLLE +C +C The numeric-label space begins and ends at impossible values. +C + FNLB=-10. + FNLE=+10. +C +C Force the labeler to update FNLB, rather than FNLE. +C + FDIR=1. +C +C Jump to an internal procedure to draw the label and/or the tick mark. +C + 202 ASSIGN 203 TO JMP2 + GO TO 400 +C +C Save the position of the zero-point (FRAX, expressed as a fraction of +C the axis length) and preset the parameter DZRT, which is the minimum +C distance from the zero-point at which a major tick mark could occur, +C and the parameter DZRL, which is the minimum distance from the zero- +C point at which a label could occur. Set the label-space limit FNLE. +C Preset the internal-procedure exit parameter JMP1. +C + 203 ASSIGN 205 TO JMP1 + FZRO=FRAX + DZRT=AMAX1(SMJT,1.6*FLOAT(LDNL)*FHCM) + IF (LDNL.EQ.0) GO TO 204 + DZRL=FNLB-FZRO + FNLE=FNDP+WNLE/CFAA+.5*(FHCM+FHCE) +C +C Do the portion of the axis lying in the direction specified by DZRT. +C If it is too short, skip it entirely. +C + 204 FRAX=FZRO+DZRT + IF (FRAX.LT.FBGM.OR.FRAX.GT.FNDP) GO TO JMP1 , (205,800) +C +C Find out whether BASE must be negated for this portion. +C + CALL AGFTOL (IAXS,1,FRAX,VLCS,DUMI,LLUA,UBEG,UDIF,FUNS,NBTP,BASE) + SBSE=SIGN(BASE,VLCS) +C +C Compute a starting value of the exponent/multiplier EXMU. +C + CALL AGFTOL (IAXS,2,FRAX,EXMU,DUMI,LLUA,UBEG,UDIF,FUNS,NBTP,SBSE) + EXMU=EXMU-AMOD(EXMU,1.)+.5+SIGN(.5,EXMU) +C +C Jump to an internal procedure to draw the tick marks and/or labels. +C + GO TO 300 +C +C Set up to do the second portion of the axis, then go do it. +C + 205 ASSIGN 800 TO JMP1 + DZRT=-DZRT + IF (LDNL.EQ.0) GO TO 204 + FNLB=FBGM-WNLB/CFAA-.5*(FHCM+FHCE) + FNLE=FZRO-DZRL + GO TO 204 +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C The following is an internal procedure, exited via the assigned-go-to +C variable JMP1. Its purpose is to tick-mark and label a portion of the +C axis (perhaps the entire axis) at positions determined by consecutive +C values of the parameter EXMU. It prevents tick marks from piling up +C or passing through the label space and prevents overlapping of labels. +C Tick marks are drawn alternately from left to right or vice-versa. +C +C The caller has provided an initial value of EXMU, but we must consider +C possible minor tick marks in the interval (EXMU-1.,EXMU). +C + 300 EXMU=EXMU-1. +C +C Compute FRAX, which is the fractional distance along the axis, and +C VLCS, which is the value in the label coordinate system corresponding +C to the current value of EXMU. +C + CALL AGFTOL (IAXS,-2,EXMU,FRAX,VLCS,LLUA,UBEG,UDIF,FUNS,NBTP,SBSE) +C +C Move the current values of EXMU, FRAX, and VLCS to ELST, FLST, and +C VLST, specifying the last values of these parameters. Then increment +C EXMU by 1. and recompute FRAX and VLCS. (The loop through consecutive +C values of EXMU begins here.) +C + 301 ELST=EXMU + FLST=FRAX + VLST=VLCS +C + EXMU=EXMU+1. + CALL AGFTOL (IAXS,-2,EXMU,FRAX,VLCS,LLUA,UBEG,UDIF,FUNS,NBTP,SBSE) +C +C FDIR indicates the direction, FDST the magnitude, of step along axis. +C + FDIR=FRAX-FLST + FDST=ABS(FDIR) +C +C Draw minor tick marks, if any, in the interval (FLST,FRAX). +C + IF (LDMN.EQ.0.OR.FDST.LT.SMNT) GO TO 304 +C +C Use the dashed-line pattern for minor tick marks. +C + CALL DASHDB (AGFPBN(QNDP)) +C +C Minor tick marks are equally spaced in the label-coordinate system. +C + VINC=(VLCS-VLST)/FLOAT(NMNT+1) +C + DO 303 I=1,NMNT + VMNT=VLST+VINC*FLOAT(I) + CALL AGFTOL (IAXS,-1,VMNT,FMNT,DUMI,LLUA,UBEG,UDIF,FUNS,NBTP, + + SBSE) + IF (FMNT.LT.FBGP.OR.FMNT.GT.FNDM) GO TO 303 + XPAX=XBGA+FMNT*XDNA + YPAX=YBGA+FMNT*YDNA + LDLR=-LDLR + IF (LDLR.LT.0) GO TO 302 + CALL AGCHAX (0,IAXS,3,VMNT) + IF (MN12.NE.0) CALL LINED (XPAX+XMNT(1),YPAX+YMNT(1), + + XPAX+XMNT(2),YPAX+YMNT(2)) + IF (MN34.NE.0) CALL LINED (XPAX+XMNT(3),YPAX+YMNT(3), + + XPAX+XMNT(4),YPAX+YMNT(4)) + CALL AGCHAX (1,IAXS,3,VMNT) + GO TO 303 + 302 CALL AGCHAX (0,IAXS,3,VMNT) + IF (MN34.NE.0) CALL LINED (XPAX+XMNT(4),YPAX+YMNT(4), + + XPAX+XMNT(3),YPAX+YMNT(3)) + IF (MN12.NE.0) CALL LINED (XPAX+XMNT(2),YPAX+YMNT(2), + + XPAX+XMNT(1),YPAX+YMNT(1)) + CALL AGCHAX (1,IAXS,3,VMNT) + 303 CONTINUE +C +C If the end of the axis has been reached, return to caller. +C + 304 IF (FRAX.LT.FBGM.OR.FRAX.GT.FNDP) GO TO JMP1 , (205,800) +C +C Draw the major tick mark and/or the numeric label at FRAX. +C + IF (FDST.LT.SMJT) GO TO 301 + LDLB=0 + IF (LDNL.EQ.0) GO TO 305 + CALL AGNUMB (NBTP,SBSE,EXMU,NLTP,NLEX,NLFL,BFRM,40,NCIM,IPXM,BFRE, + + 5,NCIE) + CALL AGCHNL (IAXS,VLCS,BFRM,40,NCIM,IPXM,BFRE,5,NCIE) +C +C If this is not a test run, mantissa and exponent length are checked. +C + IF (ITST.EQ.0.AND.(NCIM.GT.MCIM.OR.NCIE.GT.MCIE)) GO TO 305 + LDLB=1 + FLLM=FLOAT(NCIM)*FWCM + FLLE=FLOAT(NCIE)*FWCE + FLLB=FLLM+FLLE +C +C Use the next internal procedure to draw the major tick and/or label. +C + 305 ASSIGN 301 TO JMP2 +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C The following is an internal procedure, exited via the assigned-go-to +C variable JMP2. Its purpose is to draw the major tick mark and/or the +C numeric label at a specified point on the axis or, if ITST is .NE. 0, +C to predict the amount of space which will be required for such items. +C +C Jump if no label is to be drawn. +C + 400 IF (LDLB.EQ.0.OR.NCIM.LE.0) GO TO 410 +C +C See if the label will fit without overlapping another label. To do +C this, first compute its fractional length along the axis (FLAA). +C + GO TO (401,402,401,402) , JLAO +C +C Label is parallel to the axis. Allow for inter-label spacing. +C + 401 FLAA=FLLB+FWCM + GO TO 403 +C +C Label is perpendicular to the axis. Ignore exponent portion. +C + 402 FLAA=1.6*FHCM +C +C Compute the fractional coordinates of the endpoints of the label +C (along the axis) and see if it will fit in the available label space. +C + 403 FLBB=FRAX-.5*FLAA + FLBE=FRAX+.5*FLAA +C + IF (FLBB.GE.FNLB.AND.FLBE.LE.FNLE) GO TO 407 +C +C Label will not fit. Omit it or, if this is a test run, see if any +C remedial action is to be taken. +C + LDLB=0 + IF (ITST.EQ.0) GO TO 411 +C +C This is a test run and we have two consecutive labels which overlap. +C See what can be done about it. +C + GO TO (424,404,406,404) , ITST +C +C We are allowed to shrink the labels. See if they are minimum-size +C already. If so, the only other possibility is to re-orient them. +C + 404 IF (IWCM.LE.MWCM.AND.IWCE.LE.MWCE.AND.IDLA.LE.MDLA) GO TO 405 +C +C If not, shrink them by an amount based on the extent of the overlap, +C reset the parameters affected, and start from square one. +C + RFNL=AMIN1(.9,FDST/(FDST+AMAX1(FNLB-FLBB,FLBE-FNLE)))*RFNL + MCIM=0 + MCIE=0 + ASSIGN 200 TO JMP3 + GO TO 500 +C +C If labels have already been shrunk to minimum size, see if we can +C re-orient them. If not, at least continue with finding the maximum +C mantissa and exponent lengths. +C + 405 IF (ITST.NE.4) GO TO 424 +C +C Try re-orienting the labels. If this has already been tried, or it it +C would be pointless, skip it, but continue with finding the maximum +C mantissa and exponent lengths. +C + 406 IF (NLOF.LT.0.OR.NLOS.EQ.NLOF.OR.JLAO.EQ.2.OR.JLAO.EQ.4) GO TO 424 +C +C If re-orienting makes sense, reset the appropriate parameters and +C start from square one. +C + NLOF=NLOF-360 + RFNL=1. + MCIM=0 + MCIE=0 + ASSIGN 200 TO JMP3 + GO TO 500 +C +C Label will fit. Update the label space limits for next time. +C + 407 IF (FDIR.GE.0.) GO TO 408 + FNLE=FLBB + GO TO 409 + 408 FNLB=FLBE +C +C If this is not just a test shot, go off and draw the tick mark/label. +C + 409 IF (ITST.EQ.0) GO TO 411 +C +C If this is a test shot, update the maximum mantissa and exponent +C lengths being generated and exit from this internal procedure. +C + MCIM=MAX0(MCIM,NCIM) + MCIE=MAX0(MCIE,NCIE) + GO TO 424 +C +C No label is to be drawn. If this is a test shot, exit from this +C internal procedure without drawing the tick mark. +C + 410 IF (ITST.NE.0) GO TO 424 +C +C Compute x and y coordinates of current axis point. +C + 411 XPAX=XBGA+FRAX*XDNA + YPAX=YBGA+FRAX*YDNA +C +C Jump if no major tick-mark is to be drawn. Otherwise, set up the +C dash pattern for major tick-marks. +C + IF (LDMJ.EQ.0) GO TO 414 + CALL DASHDB (AGFPBN(QJDP)) +C +C Flip the left-to-right/right-to-left direction flag. +C + LDLR=-LDLR +C +C Draw the first portion of the tick mark. +C + IF (LDLR) 413,414,412 +C + 412 IF (MJ12.NE.0) THEN + CALL AGCHAX (0,IAXS,2,VLCS) + CALL LINED (XPAX+XMJT(1),YPAX+YMJT(1),XPAX+XMJT(2),YPAX+YMJT(2)) + CALL AGCHAX (1,IAXS,2,VLCS) + END IF + GO TO 414 +C + 413 IF (MJ34.NE.0) THEN + CALL AGCHAX (0,IAXS,2,VLCS) + CALL LINED (XPAX+XMJT(4),YPAX+YMJT(4),XPAX+XMJT(3),YPAX+YMJT(3)) + CALL AGCHAX (1,IAXS,2,VLCS) + END IF +C +C Draw the label, if any. +C + 414 IF (LDLB.EQ.0.OR.NCIM.LE.0) GO TO 421 +C +C Compute the distances from (XPAX,YPAX) to the beginning of the label - +C along the axis (FBLA) and perpendicular to the axis (FBLP). Each is a +C directed distance whose magnitude represents a fraction of the length +C of the axis. The values depend on the label/axis orientation and the +C distance of the label from the axis. In some cases, these quantities, +C or portions of them, have already been computed. +C + GO TO (415,416,417,418) , JLAO +C +C Label is at a 0-degree angle to the axis. +C + 415 FBLA=-.5*FLLB + GO TO 419 +C +C Label is at a 90-degree angle to the axis. +C + 416 FBLP=FBLQ+FLLM + IF (DNLA.EQ.0.) FBLP=.5*FLLB + GO TO 419 +C +C Label is at a 180-degree angle to the axis. +C + 417 FBLA=.5*FLLB + GO TO 419 +C +C Label is at a 270-degree angle to the axis. +C + 418 FBLP=FBLQ-FLLM + IF (DNLA.EQ.0.) FBLP=-.5*FLLB +C +C Draw the mantissa portion of the label (excluding the "X", if any). +C + 419 DEEX=FBLA*XDCA+(FBLP+FNLO)*YDCA + DEEY=FBLA*YDCA-(FBLP+FNLO)*XDCA + CALL AGCHAX (0,IAXS,4,VLCS) + IF (IPXM.EQ.0) THEN + CALL AGPWRT (XPAX+CFAX*DEEX, + + YPAX+CFAY*DEEY,BFRM,NCIM,IWCM,NLOR,-1) + ELSE + CALL AGPWRT (XPAX+CFAX*(DEEX+(FLLM-3.*FWCM)*XDCL), + + YPAX+CFAY*(DEEY+(FLLM-3.*FWCM)*YDCL), + + BFRM,IPXM-1,IWCM,NLOR,+1) + CTMP=BFRM(IPXM+1:NCIM) + CALL AGPWRT (XPAX+CFAX*(DEEX+(FLLM-2.*FWCM)*XDCL), + + YPAX+CFAY*(DEEY+(FLLM-2.*FWCM)*YDCL), + + CTMP,NCIM-IPXM,IWCM,NLOR,-1) + END IF + DEEX=DEEX+FLLM*XDCL + DEEY=DEEY+FLLM*YDCL +C +C Draw the "X" portion of the mantissa, if it was left out above. +C + IF (IPXM.EQ.0) GO TO 420 + DEEX=DEEX-2.5*FWCM*XDCL + DEEY=DEEY-2.5*FWCM*YDCL + CALL LINE (XPAX+CFAX*(DEEX-.3*FWCM*(XDCL-YDCL)), + + YPAX+CFAY*(DEEY-.3*FWCM*(YDCL+XDCL)), + + XPAX+CFAX*(DEEX+.3*FWCM*(XDCL-YDCL)), + + YPAX+CFAY*(DEEY+.3*FWCM*(YDCL+XDCL))) + CALL LINE (XPAX+CFAX*(DEEX-.3*FWCM*(XDCL+YDCL)), + + YPAX+CFAY*(DEEY-.3*FWCM*(YDCL-XDCL)), + + XPAX+CFAX*(DEEX+.3*FWCM*(XDCL+YDCL)), + + YPAX+CFAY*(DEEY+.3*FWCM*(YDCL-XDCL))) + DEEX=DEEX+2.5*FWCM*XDCL + DEEY=DEEY+2.5*FWCM*YDCL + 420 CALL AGCHAX (1,IAXS,4,VLCS) +C +C Draw the exponent portion of the label (if it has one). +C + IF (NCIE.EQ.0) GO TO 421 + DEEX=DEEX-.5*FHCM*YDCL + DEEY=DEEY+.5*FHCM*XDCL + CALL AGCHAX (0,IAXS,5,VLCS) + CALL AGPWRT (XPAX+CFAX*DEEX,YPAX+CFAY*DEEY,BFRE,NCIE,IWCE,NLOR,-1) + CALL AGCHAX (1,IAXS,5,VLCS) +C +C Draw the second portion of the tick mark, if any. +C + 421 IF (LDLR) 423,424,422 +C + 422 IF (MJ34.NE.0) THEN + CALL AGCHAX (0,IAXS,2,VLCS) + CALL LINED (XPAX+XMJT(3),YPAX+YMJT(3),XPAX+XMJT(4),YPAX+YMJT(4)) + CALL AGCHAX (1,IAXS,2,VLCS) + END IF + GO TO 424 +C + 423 IF (MJ12.NE.0) THEN + CALL AGCHAX (0,IAXS,2,VLCS) + CALL LINED (XPAX+XMJT(2),YPAX+YMJT(2),XPAX+XMJT(1),YPAX+YMJT(1)) + CALL AGCHAX (1,IAXS,2,VLCS) + END IF +C +C Exit from internal procedure. +C + 424 GO TO JMP2 , (203,301) +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C The following is an internal procedure, exited via the assigned-go-to +C variable JMP3. Its purpose is to compute all numeric-label parameters +C required by AGAXIS. +C +C Compute the desired label orientation and its direction cosines. +C + 500 NLOR=NLOF + IF (NLOR.LT.0) NLOR=NLOS +C + XDCL=COS(.017453292519943*FLOAT(NLOR)) + YDCL=SIN(.017453292519943*FLOAT(NLOR)) +C +C Compute JLAO, which is a computed-go-to jump parameter specifying the +C label-to-axis orientation. +C + JLAO=1+MOD(NLOR-IAOR+3600,360)/90 +C +C Compute the width of a character in the label mantissa, the width of a +C character in the label exponent, and the distance of a label from the +C axis, in the plotter coordinate system. +C + IWCM=MAX0(MWCM,IFIX(RFNL*ABS(WCLM)*SCWP+.5)) + IWCE=MAX0(MWCE,IFIX(RFNL*ABS(WCLE)*SCWP+.5)) + IDLA=MAX0(MDLA,IFIX(RFNL*ABS(DNLA)*SCWP+.5)) +C +C Compute the same quantities as fractions of the axis length. +C + FWCM=FLOAT(IWCM)/AXLP + FWCE=FLOAT(IWCE)/AXLP + FDLA=FLOAT(IDLA)/AXLP +C +C Compute character heights as fractions of the axis length. +C + FHCM=HCFW(FWCM) + FHCE=HCFW(FWCE) +C +C Return to internal-procedure caller. +C + GO TO JMP3 , (104,200,801) +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C This is the termination section of AGAXIS. +C +C Update the parameters WNLL and WNLR to reflect the amount of space +C used/needed for numeric labels to the left and right of the axis. +C + 800 IF (LDNL.NE.0) GO TO 801 +C +C No numeric labels occur on the axis. Zero WNLL and WNLR and jump. +C + WNLL=0. + WNLR=0. + GO TO 815 +C +C Numeric labels do occur on the axis. Compute the space required. +C + 801 GO TO (802,803,802,803) , JLAO +C +C Labels are parallel to the axis. +C + 802 FNLW=FHCM + IF (MCIE.NE.0) FNLW=FNLW+.5*FHCE + GO TO 804 +C +C Labels are perpendicular to the axis. +C + 803 FNLW=FLOAT(MCIM)*FWCM+FLOAT(MCIE)*FWCE +C +C Jump on the numeric-label-distance-from-axis parameter DNLA. +C + 804 IF (DNLA) 805,806,807 +C +C Labels are to the right of the axis. +C + 805 FNLL=-FDLA + FNLR=+FDLA+FNLW + GO TO 808 +C +C Labels are centered on the axis. +C + 806 FNLL=+.5*FNLW + FNLR=+.5*FNLW + GO TO 808 +C +C Labels are to the left of the axis. +C + 807 FNLL=+FDLA+FNLW + FNLR=-FDLA +C +C Adjust FNLL and FNLR as implied by the numeric-label offset. +C + 808 FNLL=FNLL-FNLO + FNLR=FNLR+FNLO +C +C If this is not a test run, jump to reset WNLL and WNLR. +C + IF (ITST.EQ.0) GO TO 814 +C +C If this is a test run, see if the labels will fit. Jump if so. +C + IF (CFAP*FNLL.LE.WNLL.AND.CFAP*FNLR.LE.WNLR) GO TO 814 +C +C If the labels will not fit, we have a problem. We may or may not be +C able to do anything about it, depending on ITST. +C + GO TO (814,809,813,809) , ITST +C +C We are allowed to shrink the labels. See if they are minimum-size +C already. If so, the only other possibility is to re-orient them. +C + 809 IF (IWCM.LE.MWCM.AND.IWCE.LE.MWCE.AND.IDLA.LE.MDLA) GO TO 812 +C +C If not, shrink them by an amount based on the extent of the problem, +C reset the parameters affected and see if the problem is solved. +C + IF (WNLR+WNLL.GT.0.) GO TO 810 +C + RFNL=.000001*RFNL + GO TO 811 +C + 810 RFNL=AMIN1(.9,(WNLL+WNLR)/(CFAP*(FNLL+FNLR)))*RFNL +C + 811 ASSIGN 801 TO JMP3 + GO TO 500 +C +C If labels have already been shrunk to minimum size, see if we can +C re-orient them. If not, give up. +C + 812 IF (ITST.NE.3) GO TO 814 +C +C Try re-orienting the labels. If this has already been tried, or if it +C would be pointless, give up. +C + 813 IF (NLOF.LT.0.OR.NLOS.EQ.NLOF.OR.JLAO.EQ.1.OR.JLAO.EQ.3) GO TO 814 +C +C If re-orienting makes sense, reset the parameters affected and see if +C the problem is solved. +C + NLOF=NLOF-360 + RFNL=1. + ASSIGN 801 TO JMP3 + GO TO 500 +C +C Reset WNLL and WNLR for caller. +C + 814 WNLL=FNLL*CFAP + WNLR=FNLR*CFAP +C +C If this is a test run, we are now done. +C + 815 IF (ITST.GT.0) GO TO 816 +C +C Draw the axis, if it is to be drawn. +C + IF (LDAX.EQ.0) GO TO 816 +C + CALL DASHDB (ISLD) + CALL AGCHAX (0,IAXS,1,0.) + CALL LINED (XBGA,YBGA,XNDA,YNDA) + CALL AGCHAX (1,IAXS,1,0.) +C +C Pack up integer values which might have been changed into the +C corresponding floating-point arguments. +C + 816 QLOF=FLOAT(NLOF) + QLOS=FLOAT(NLOS) + QCIM=FLOAT(MCIM) + QCIE=FLOAT(MCIE) +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agback.f b/sys/gio/ncarutil/autograph/agback.f new file mode 100644 index 00000000..108d2b66 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agback.f @@ -0,0 +1,152 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGBACK +C +C The subroutine AGBACK is used to draw a graph background, as directed +C by the current contents of the parameter list. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C Declare the block data routine external to force it to load. +C +C +NOAO - Block data replaced with run time initialization subroutine. +C +C EXTERNAL AGDFLT + call agdflt +C +C -NOAO +C +C Do an appropriate SET call for the following routines. The call is +C equivalent to "CALL SET (XLCW,XRCW,YBCW,YTCW,0.,1.,0.,1.,1)", but +C makes the viewport cover the whole plotter frame, which avoids the +C problems resulting from clipping by GKS. +C + CALL SET (0.,1.,0.,1.,-XLCW/(XRCW-XLCW),(1.-XLCW)/(XRCW-XLCW), + + -YBCW/(YTCW-YBCW),(1.-YBCW)/(YTCW-YBCW),1) +C +C Draw the labels, if any, first. +C + IDLB=IFIX(QDLB) + IF (IDLB.EQ.0) GO TO 101 +C + LBIM=IFIX(QBIM) + CALL AGLBLS (IDLB,WCWP,HCWP,FLLB,LBIM,FLLN,DBOX,SBOX,RBOX) +C +C Now draw each of the four axes. +C + 101 I=0 +C + 102 I=I+1 +C + IF (I.EQ.5) GO TO 108 +C + IF (QDAX(I).EQ.0.) GO TO 102 +C + GO TO (103,104,105,106) , I +C +C Y axis - left. +C + 103 WNLB(1)=0.-YBGW + IF (XBGA(1)-WNLL(1).LT.DBOX(3,2).AND. + + XBGA(1)+WNLR(1).GT.DBOX(3,1)) WNLB(1)=0.-DBOX(3,4) +C + WNLE(1)=YTGW-1. + IF (XBGA(1)-WNLL(1).LT.DBOX(4,2).AND. + + XBGA(1)+WNLR(1).GT.DBOX(4,1)) WNLE(1)=DBOX(4,3)-1. +C + GO TO 107 +C +C Y axis - right. +C + 104 WNLB(2)=YTGW-1. + IF (XBGA(2)-WNLR(2).LT.DBOX(4,2).AND. + + XBGA(2)+WNLL(2).GT.DBOX(4,1)) WNLB(2)=DBOX(4,3)-1. +C + WNLE(2)=0.-YBGW + IF (XBGA(2)-WNLR(2).LT.DBOX(3,2).AND. + + XBGA(2)+WNLL(2).GT.DBOX(3,1)) WNLE(2)=0.-DBOX(3,4) +C + GO TO 107 +C +C X axis - bottom. +C + 105 WNLB(3)=XRGW-1. + IF (YBGA(3)-WNLL(3).LT.DBOX(2,4).AND. + + YBGA(3)+WNLR(3).GT.DBOX(2,3)) WNLB(3)=DBOX(2,1)-1. +C + WNLE(3)=0.-XLGW + IF (YBGA(3)-WNLL(3).LT.DBOX(1,4).AND. + + YBGA(3)+WNLR(3).GT.DBOX(1,3)) WNLE(3)=0.-DBOX(1,2) +C + GO TO 107 +C +C X axis - top. +C + 106 WNLB(4)=0.-XLGW + IF (YBGA(4)-WNLR(4).LT.DBOX(1,4).AND. + + YBGA(4)+WNLL(4).GT.DBOX(1,3)) WNLB(4)=0.-DBOX(1,2) +C + WNLE(4)=XRGW-1. + IF (YBGA(4)-WNLR(4).LT.DBOX(2,4).AND. + + YBGA(4)+WNLL(4).GT.DBOX(2,3)) WNLE(4)=DBOX(2,1)-1. +C + 107 Q=AMIN1(0.,QDAX(I)) +C + CALL AGAXIS (I,Q, + + QSPA(I),WCWP,HCWP,XBGA(I),YBGA(I),XNDA(I),YNDA(I), + + QLUA(I),UBGA(I),UNDA(I),FUNS(I),QBTP(I),BASE(I), + + QJDP(I),WMJL(I),WMJR(I),QMNT(I),QNDP(I),WMNL(I), + + WMNR(I),QLTP(I),QLEX(I),QLFL(I),QLOF(I),QLOS(I), + + DNLA(I),WCLM(I),WCLE(I),RFNL(I),QCIM(I),QCIE(I), + + WNLL(I),WNLR(I),WNLB(I),WNLE(I)) +C + GO TO 102 +C +C Do set call for user and return. +C + 108 CALL SET (XLCW,XRCW,YBCW,YTCW,XLUW,XRUW,YBUW,YTUW, + + 1+IABS(IFIX(QLUX))*2+IABS(IFIX(QLUY))) +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agbnch.f b/sys/gio/ncarutil/autograph/agbnch.f new file mode 100644 index 00000000..4aee636a --- /dev/null +++ b/sys/gio/ncarutil/autograph/agbnch.f @@ -0,0 +1,35 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + CHARACTER*16 FUNCTION AGBNCH (IDSH) +C +C The value of this function is the character-dash-pattern equivalent of +C the integer dash pattern IDSH, a string of quotes and/or dollar signs. +C Note that the support routines IAND and ISHIFT are used. +C + KDSH=IDSH +C + DO 101 I=16,1,-1 + IF (IAND(KDSH,1).EQ.0) THEN + AGBNCH(I:I)='''' + ELSE + AGBNCH(I:I)='$' + END IF + KDSH=ISHIFT(KDSH,-1) + 101 CONTINUE +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agchax.f b/sys/gio/ncarutil/autograph/agchax.f new file mode 100644 index 00000000..451bce5c --- /dev/null +++ b/sys/gio/ncarutil/autograph/agchax.f @@ -0,0 +1,41 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGCHAX (IFLG,IAXS,IPRT,VILS) +C +C The routine AGCHAX is called by AGAXIS just before and just after each +C of a selected set of objects on the axes are drawn. A user may supply +C a version to change the appearance of these objects. The arguments +C are as follows: +C +C - IFLG is zero if a particular object is about to be drawn, non-zero +C if it has just been drawn. +C +C - IAXS is the number of the axis in question. The values 1, 2, 3, and +C 4 imply the right, left, bottom, and top axes, respectively. +C +C - IPRT is an integer implying which part of the axis is being drawn. +C The value 1 implies the line itself, 2 a major tick, 3 a minor tick, +C 4 the mantissa of a label, and 5 the exponent of a label. +C +C - VILS is the value, in the label coordinate system along the axis, +C associated with the position of the object being drawn. IPRT=1 +C implies VILS=0. +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agchcu.f b/sys/gio/ncarutil/autograph/agchcu.f new file mode 100644 index 00000000..1364ad28 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agchcu.f @@ -0,0 +1,44 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGCHCU (IFLG,KDSH) +C +C The routine AGCHCU is called by AGCURV just before and just after each +C curve is drawn. The default version does nothing. A user may supply +C a version to change the appearance of the curves. The arguments are +C as follows: +C +C - IFLG is zero if a curve is about to be drawn, non-zero if a curve +C has just been drawn. +C +C - KDSH is the last argument of AGCURV, as follows: +C +C AGCURV called by Value of KDSH +C ---------------- ---------------------------------------- +C EZY 1 +C EZXY 1 +C EZMY "n" or "-n", where n is the curve number +C EZMXY "n" or "-n", where n is the curve number +C the user program the user value +C +C The sign of KDSH, when AGCURV is called by EZMY or EZMXY, indicates +C whether the "user" dash patterns or the "alphabetic" dash patterns +C were selected for use. +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agchil.f b/sys/gio/ncarutil/autograph/agchil.f new file mode 100644 index 00000000..1952cf68 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agchil.f @@ -0,0 +1,36 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGCHIL (IFLG,LBNM,LNNO) +C + CHARACTER*(*) LBNM +C +C The routine AGCHIL is called by AGLBLS just before and just after each +C informational-label line of text is drawn. The default version does +C nothing. A user may supply a version to change the appearance of the +C text lines. The arguments are as follows: +C +C - IFLG is zero if a text line is about to be drawn, non-zero if one +C has just been drawn. +C +C - LBNM is the name of the label containing the line in question. +C +C - LNNO is the number of the line. +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agchnl.f b/sys/gio/ncarutil/autograph/agchnl.f new file mode 100644 index 00000000..3b42a5f6 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agchnl.f @@ -0,0 +1,65 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGCHNL (IAXS,VILS,CHRM,MCIM,NCIM,IPXM,CHRE,MCIE,NCIE) +C + CHARACTER*(*) CHRM,CHRE +C +C The routine AGCHNL is called by AGAXIS just after it has set up the +C character strings comprising a numeric label along an axis. The +C default version does nothing. A user may supply his own version to +C change the numeric labels. For each numeric label, this routine is +C called twice by AGAXIS - once to determine how much space will be +C required when the label is actually drawn and once just before it +C is actually drawn. The arguments are as follows: +C +C - IAXS is the number of the axis being drawn. Its value is 1, 2, 3, +C or 4, implying the left, right, bottom, or top axes, respectively. +C The value of IAXS must not be altered. +C +C - VILS is the value to be represented by the numeric label, in the +C label system for the axis. The value of VILS must not be altered. +C +C - CHRM, on entry, is a character string containing the mantissa of the +C numeric label, as it will appear if AGCHNL makes no changes. If the +C numeric label includes a "times" symbol, it will be represented by +C a blank in CHRM. (See IPXM, below.) CHRM may be modified. +C +C - MCIM is the length of CHRM - the maximum number of characters that +C it will hold. The value of MCIM must not be altered. +C +C - NCIM, on entry, is the number of meaningful characters in CHRM. If +C CHRM is changed, NCIM should be changed accordingly. +C +C - IPXM, on entry, is zero if there is no "times" symbol in CHRM; if it +C is non-zero, it is the index of the appropriate character position +C in CHRM. If AGCHNL changes the position of the "times" symbol in +C CHRM, removes it, or adds it, the value of IPXM must be changed. +C +C - CHRE, on entry, is a character string containing the exponent of the +C numeric label, as it will appear if AGCHNL makes no changes. CHRE +C may be modified. +C +C - MCIE is the length of CHRE - the maximum number of characters that +C it will hold. The value of MCIE must not be altered. +C +C - NCIE, on entry, is the number of meaningful characters in CHRE. If +C CHRE is changed, NCIE should be changed accordingly. +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agctcs.f b/sys/gio/ncarutil/autograph/agctcs.f new file mode 100644 index 00000000..d9f67d5f --- /dev/null +++ b/sys/gio/ncarutil/autograph/agctcs.f @@ -0,0 +1,79 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGCTCS (TPID,ITCS) +C + CHARACTER*(*) TPID +C +C The routine AGCTCS is called by the routines AGGETC and AGSETC to +C check what type of character-string parameter is implied by the +C parameter identifier TPID and return an appropriate value of ITCS, as +C follows: +C +C -- ITCS = 0 implies that the parameter is not intrinsically of type +C character and that AGGETC/AGSETC should not have been called in +C the way that it was. +C +C -- ITCS = 1 implies a dash-pattern parameter. +C +C -- ITCS = 2 implies a label name. +C +C -- ITCS = 3 implies the line-end character. +C +C -- ITCS = 4 implies the text of some line of some label. +C +C Find out where in the parameter list the requested parameter lies. +C + CALL AGSCAN (TPID,LOPA,NIPA,IIPA) +C +C See if it's a dash pattern. +C + CALL AGSCAN ('DASH/PATT.',LODP,NIDP,IIDP) + IF (LOPA.GE.LODP.AND.LOPA.LE.LODP+NIDP-1) THEN + ITCS=1 + RETURN + END IF +C +C See if it's a label name. +C + CALL AGSCAN ('LABE/NAME.',LOLN,NILN,IILN) + IF (LOPA.EQ.LOLN) THEN + ITCS=2 + RETURN + END IF +C +C See if it's the line-end character. +C + CALL AGSCAN ('LINE/END .',LOLE,NILE,IILE) + IF (LOPA.EQ.LOLE) THEN + ITCS=3 + RETURN + END IF +C +C See if it's the text of some label line. +C + CALL AGSCAN ('LINE/BUFF/CONT.',LOLB,NILB,IILB) + IF (LOPA.GE.LOLB.AND.LOPA.LE.LOLB+NILB-1.AND. + + MOD(LOPA-LOLB,6).EQ.3) THEN + ITCS=4 + RETURN + END IF +C +C Error - type not recognizable. +C + ITCS=0 + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agctko.f b/sys/gio/ncarutil/autograph/agctko.f new file mode 100644 index 00000000..105438cc --- /dev/null +++ b/sys/gio/ncarutil/autograph/agctko.f @@ -0,0 +1,150 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGCTKO (XBGA,YBGA,XDCA,YDCA,CFAX,CFAY,CSFA,JAOR,NMMT, + + QMDP,WMML,WMMR,FNLL,FNLR,MM12,MM34,XMMT,YMMT) +C + DIMENSION XMMT(4),YMMT(4) +C +C The routine AGCTKO is used to compute the x and y offsets to the end- +C points of the left-of-label and right-of-label portions of the major +C and minor tick marks. See AGAXIS for definitions of the arguments. +C +C A note about WMML and WMMR: Each is a positive number, of the form +C (E) or (1+E), where E (=EPSILON) is .LT. 1. and is expressed as a +C fraction of the smaller side of the curve window. If the form (E) is +C used, it implies just a tick of length E; if the form (1+E) is used, +C it implies a tick long enough to reach the edge of the curve window, +C plus the length E. +C +C If the tick-mark count NMMT .EQ. 0 or the tick-mark dash pattern QMDP +C .EQ. 0 or both the left-of-axis and right-of-axis tick-mark lengths +C WMML and WMMR .EQ. 0, then no tick marks are to be drawn. +C + IF (NMMT.EQ.0.OR.QMDP.EQ.0..OR.(WMML.EQ.0..AND.WMMR.EQ.0.)) + * GO TO 115 +C +C Compute the distances of the tick mark ends from the axis as fractions +C of the axis length, using only the (EPSILON) portion of WMML and WMMR. +C + FMML=-CSFA*AMOD(WMML,1.) + FMMR=+CSFA*AMOD(WMMR,1.) +C +C If the labels overlap the axis and the (EPSILON) form was used for +C WMML or WMMR, move the tick mark to the end of the label. +C + IF (FNLL*FNLR.GE.0.) GO TO 101 +C + IF (WMML.LT.1.) FMML=FMML+FNLL +C + IF (WMMR.LT.1.) FMMR=FMMR+FNLR +C +C Compute the x and y offsets to the ends of the tick mark. +C + 101 XMML=+CFAX*FMML*YDCA + YMML=-CFAY*FMML*XDCA + XMMR=+CFAX*FMMR*YDCA + YMMR=-CFAY*FMMR*XDCA +C +C If the (1+EPSILON) form was used for WMML or WMMR, adjust XMML, YMML, +C XMMR, and YMMR as implied by the current axis orientation. +C + IF (WMML.LT.1.) GO TO 107 +C + GO TO (102,103,104,105) , JAOR +C +C Axis at 0 degrees (left to right). +C + 102 YMML=YMML+1.-YBGA + GO TO 106 +C +C Axis at 90 degrees (bottom to top). +C + 103 XMML=XMML-XBGA + GO TO 106 +C +C Axis at 180 degrees (right to left). +C + 104 YMML=YMML-YBGA + GO TO 106 +C +C Axis at 270 degrees (top to bottom). +C + 105 XMML=XMML+1.-XBGA +C + 106 FMML=(XMML+YMML)/(CFAX*YDCA-CFAY*XDCA) +C + 107 IF (WMMR.LT.1.) GO TO 113 +C + GO TO (108,109,110,111) , JAOR +C +C Axis at 0 degrees (left to right). +C + 108 YMMR=YMMR-YBGA + GO TO 112 +C +C Axis at 90 degrees (bottom to top). +C + 109 XMMR=XMMR+1.-XBGA + GO TO 112 +C +C Axis at 180 degrees (right to left). +C + 110 YMMR=YMMR+1.-YBGA + GO TO 112 +C +C Axis at 270 degrees (top to bottom). +C + 111 XMMR=XMMR-XBGA +C + 112 FMMR=(XMMR+YMMR)/(CFAX*YDCA-CFAY*XDCA) +C +C Now split the tick mark into two portions - one to the left, and one +C to the right, of the numeric label space. +C + 113 XMMT(1)=XMML + YMMT(1)=YMML + XMMT(2)=XMMR + YMMT(2)=YMMR + MM12=1 + MM34=0 + IF (FMMR.LE.FNLL.OR.FNLL.GE.FNLR) RETURN +C + MM12=0 + IF (FMML.GE.FNLL) GO TO 114 + MM12=1 + XMMT(2)=+CFAX*(FNLL-.005*CSFA)*YDCA + YMMT(2)=-CFAY*(FNLL-.005*CSFA)*XDCA +C + 114 IF (FMMR.LE.FNLR) RETURN +C + MM34=1 + XMMT(4)=XMMR + YMMT(4)=YMMR + XMMT(3)=XMML + YMMT(3)=YMML +C + IF (FMML.GE.FNLR) RETURN + XMMT(3)=+CFAX*(FNLR+.005*CSFA)*YDCA + YMMT(3)=-CFAY*(FNLR+.005*CSFA)*XDCA + RETURN +C +C No ticks to be drawn - zero the flags MM12 and MM34 to indicate this. +C + 115 MM12=0 + MM34=0 + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agcurv.f b/sys/gio/ncarutil/autograph/agcurv.f new file mode 100644 index 00000000..47624321 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agcurv.f @@ -0,0 +1,149 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGCURV (XVEC,IIEX,YVEC,IIEY,NEXY,KDSH) +C + DIMENSION XVEC(1),YVEC(1) +C +C AGCURV plots the curve defined by the points ((X(I),Y(I)),I=1,NEXY), +C where, if the primary parameter 'INVERT.' is zero, +C +C X(I)=XVEC(1+(I-1)*IIEX) (unless IIEX=0, in which case X(I)=I), and +C Y(I)=YVEC(1+(I-1)*IIEY) (unless IIEY=0, in which case Y(I)=I). +C +C If 'INVERT.' is non-zero, the definitions are interchanged, so that +C +C X(I)=YVEC(1+(I-1)*IIEY) (unless IIEY=0, in which case X(I)=I), and +C Y(I)=XVEC(1+(I-1)*IIEX) (unless IIEX=0, in which case Y(I)=I). +C +C If, for some I, X(I)=SVAL or Y(I)=SVAL, curve line segments having +C (X(I),Y(I)) as an endpoint are omitted. +C +C If the primary parameter 'WINDOW.' is zero, AGKURV is called; it does +C no windowing. If 'WINDOW.' is non-zero, AGQURV is called; it omits +C portions of the curve which fall outside the current curve window. +C +C The argument KDSH specifies the dash pattern to be used. If KDSH is +C negative, the function MOD(IABS(KDSH),26) is used to select a solid +C line interrupted by one of the alphabetic characters. If KDSH is +C zero, the user is assumed to have done his own DASHD call. If KDSH +C is positive, the function MOD(KDSH,NODP) is used to select one of the +C dash patterns in the parameter group 'DASH/PATTERNS.'. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C Declare the block data routine external to force it to load. +C +C +NOAO +C EXTERNAL AGDFLT +C -NOAO +C +C DASH receives alphabetic dash patterns. +C + CHARACTER*10 DASH +C +C ALPH contains an alphabet. +C + CHARACTER*26 ALPH +C + DATA ALPH / 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' / +C +C +NOAO - replace blockdata with run time initialization. + call agdflt +C -NOAO +C +C Check for an alphabetic dash pattern. +C + IF (KDSH.LT.0) THEN + IDSH=MOD(-KDSH-1,26)+1 + IPSN=MOD(3*IDSH-1,10)+1 + DASH='$$$$$$$$$$' + DASH(IPSN:IPSN)=ALPH(IDSH:IDSH) + CALL AGSTCH (DASH,10,IDCS) + CALL AGDASH (FLOAT(IDCS),WODQ,WOCD,SCWP) + CALL AGDLCH (IDCS) +C +C Check for a dash pattern from the group "DASH/PATTERNS." +C + ELSE IF (KDSH.GT.0) THEN + IDSH=MOD(KDSH-1,IFIX(QODP))+1 + CALL AGDASH (QDSH(IDSH),WODQ,WOCD,SCWP) +C + END IF +C +C Now that the dash pattern is determined, do the SET call. +C + CALL SET (XLCW,XRCW,YBCW,YTCW,XLUW,XRUW,YBUW,YTUW, + + 1+IABS(IFIX(QLUX))*2+IABS(IFIX(QLUY))) +C +C Give the user a chance to modify the curve (by changing line style, +C color, etc.). +C + CALL AGCHCU (0,KDSH) +C +C Decide whether AGKURV or AGQURV is to draw the curve. +C + IF (QWND.EQ.0.) THEN +C +C No windowing requested - AGKURV is used. +C + IF (QIXY.EQ.0.) THEN + CALL AGKURV (XVEC,IIEX,YVEC,IIEY,NEXY,SVAL(1)) + ELSE + CALL AGKURV (YVEC,IIEY,XVEC,IIEX,NEXY,SVAL(1)) + END IF +C + ELSE +C +C Windowing requested - AGQURV is used. +C + IF (QIXY.EQ.0.) THEN + CALL AGQURV (XVEC,IIEX,YVEC,IIEY,NEXY,SVAL(1)) + ELSE + CALL AGQURV (YVEC,IIEY,XVEC,IIEX,NEXY,SVAL(1)) + END IF +C + END IF +C +C Give the user a chance to change back what he changed above. +C + CALL AGCHCU (1,KDSH) +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agdash.f b/sys/gio/ncarutil/autograph/agdash.f new file mode 100644 index 00000000..243eb808 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agdash.f @@ -0,0 +1,69 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGDASH (DASH,WODQ,WOCD,SCWP) +C +C AGDASH sets up the DASHD call required to establish the dash pattern +C desired for the next curve. The arguments are as follows: +C +C -- DASH specifies the desired dash pattern. A positive value implies +C that a binary dash pattern is to be used, a negative value that a +C character-string dash pattern is to be used. +C +C -- WODQ is the width of the solid-line segment specified by a dollar +C sign and the gap specified by a quote, expressed as a fraction of +C the smaller side of the curve window. +C +C -- WOCD is the width of a character which is to be a part of the dash +C pattern, expressed in the same units as WODQ. +C +C -- SCWP is the length of the smaller side of the curve window, in +C plotter coordinate units. +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. The only ones +C used here are MWCD and MWDQ - the minimum widths of characters and +C spaces, respectively, in the dash pattern. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C The following common block contains other AUTOGRAPH variables, of type +C character. +C + COMMON /AGOCHP/ CHS1,CHS2 +C +c+noao +c CHARACTER*504 CHS1,CHS2 + CHARACTER*500 CHS1,CHS2 +c-noao +C +C The AUTOGRAPH function AGFPBN is of type integer. +C + INTEGER AGFPBN +C + IWCD=MAX0(MWCD,IFIX(WOCD*SCWP)) + IWDQ=MAX0(MWDQ,IFIX(WODQ*SCWP)) +C + IF (DASH.GE.0.) THEN + CALL DASHDB (AGFPBN(DASH)) + ELSE + CALL AGGTCH (IFIX(DASH),CHS1,LNC1) + CALL DASHDC (CHS1(1:LNC1),IWDQ,IWCD) + END IF +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agdflt.bd b/sys/gio/ncarutil/autograph/agdflt.bd new file mode 100644 index 00000000..ddbde9a1 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agdflt.bd @@ -0,0 +1,414 @@ +C +NOAO +C This block data has been rewritten as a run time initialization +C subroutine (see file agdflt.f). This original block data file +C is retained for reference only. +C -NOAO +C +C --------------------------------------------------------------------- +C + BLOCK DATA AGDFLT +C +C The block data subroutine AGDFLT defines the default values of those +C AUTOGRAPH parameters which can be declared in a DATA statement. See +C AGINIT for code initializing other AUTOGRAPH parameters. +C +C Following are declarations of all the AUTOGRAPH common blocks. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C The following common block contains other AUTOGRAPH variables, of +C type character. +C + COMMON /AGOCHP/ CHS1,CHS2 +C + CHARACTER*504 CHS1,CHS2 +C +C The following common blocks contain variables which are required for +C the character-storage-and-retrieval scheme of AUTOGRAPH. +C + COMMON /AGCHR1/ LNIC,INCH(2,50),LNCA,INCA +C + COMMON /AGCHR2/ CHRA(2000) +C + CHARACTER*1 CHRA +C +C --------------------------------------------------------------------- +C +C Following are declarations of default values of variables in the +C AUTOGRAPH common blocks. +C +C --------------------------------------------------------------------- +C +C QFRA defines the control parameter 'FRAME.', which specifies when, if +C ever, the EZ... routines are to call FRAME to advance to a new frame. +C + DATA QFRA / 1. / +C +C QSET defines the control parameter 'SET.', which determines how the +C last call to the plot-package routine "SET" is to affect AUTOGRAPH. +C + DATA QSET / 1. / +C +C QROW defines the control parameter 'ROW.', which determines how the x +C and y input arrays (in calls to AGSTUP and AGCURV) are to be used. +C + DATA QROW / 1. / +C +C QIXY defines the control parameter 'INVERT.', which, if set non-zero, +C causes the routines AGSTUP and AGCURV to behave as if the arguments +C defining the x and y data had been interchanged. +C + DATA QIXY / 0. / +C +C QWND defines the control parameter 'WINDOW.', which, if set non-zero, +C causes curves drawn to be scissored by the edge of the curve window. +C + DATA QWND / 0. / +C +C QBAC defines the control parameter 'BACKGROUND.', which can be given +C any of four values to set up four specific types of plot background. +C + DATA QBAC / 1. / +C +C SVAL defines the control parameters 'NULL/1.' and 'NULL/2.', which are +C used in various ways by AUTOGRAPH. +C + DATA SVAL(1) / 1E36 / , SVAL(2) / 2E36 / +C +C XLGF, XRGF, YBGF, and YTGF define the parameter-group 'GRAPH.'; they +C specify the position of the graph window within the plotter frame. +C + DATA XLGF / 0. / , XRGF / 1. / , YBGF / 0. / , YTGF / 1. / +C +C XLGD, XRGD, YBGD, and YTGD define the first four parameters in the +C group 'GRID.'; they specify the position of the grid window within +C the graph window. +C + DATA XLGD / .15 / , XRGD / .95 / , YBGD / .15 / , YTGD / .95 / +C +C SOGD defines the control parameter 'GRID/SHAPE.', which defines the +C shape of the grid window. +C + DATA SOGD / 0. / +C +C XMIN and XMAX define the control parameters 'X/MIN.' and 'X/MAX.', +C which determine how minimum and maximum values of x are to be chosen. +C Null values imply that AUTOGRAPH is to choose real values; non-null +C values are the actual values to be used (perhaps after rounding). +C + DATA XMIN / 1E36 / , XMAX / 1E36 / +C +C QLUX defines the control parameter 'X/LOG.', which is set non-zero to +C specify that the horizontal axis is to be logarithmic. +C + DATA QLUX / 0. / +C +C QOVX defines the control parameter 'X/ORDER.', which is set non-zero +C to flip the horizontal axis end-for-end. +C + DATA QOVX / 0. / +C +C QCEX defines the control parameter 'X/NICE.', which determines which, +C if either, of the horizontal axes is to have "nice" (rounded) values +C at its ends. +C + DATA QCEX / -1. / +C +C XLOW and XHGH define the control parameters 'X/SMALLEST.' and +C 'X/LARGEST.'; they come into play only when XMIN and/or XMAX are null +C and they are non-null, in which case they set limits on the range of +C x data to be considered when choosing the minimum and/or maximum. +C + DATA XLOW / 1E36 / , XHGH / 1E36 / +C +C YMIN and YMAX define the control parameters 'Y/MIN.' and 'Y/MAX.', +C which determine how minimum and maximum values of y are to be chosen. +C Null values imply that AUTOGRAPH is to choose real values; non-null +C values are the actual values to be used (perhaps after rounding). +C + DATA YMIN / 1E36 / , YMAX / 1E36 / +C +C QLUY defines the control parameter 'Y/LOG.', which is set non-zero to +C specify that the horizontal axis is to be logarithmic. +C + DATA QLUY / 0. / +C +C QOVY defines the control parameter 'Y/ORDER.', which is set non-zero +C to flip the horizontal axis end-for-end. +C + DATA QOVY / 0. / +C +C QCEY defines the control parameter 'Y/NICE.', which determines which, +C if either, of the horizontal axes is to have "nice" (rounded) values +C at its ends. +C + DATA QCEY / -1. / +C +C YLOW and YHGH define the control parameters 'Y/SMALLEST.' and +C 'Y/LARGEST.'; they come into play only when YMIN and/or YMAX are null +C and they are non-null, in which case they set limits on the range of +C y data to be considered when choosing the minimum and/or maximum. +C + DATA YLOW / 1E36 / , YHGH / 1E36 / +C +C QDAX(i) defines the control parameters 'AXIS/s/CONTROL.' (i=1 implies +C s='LEFT', i=2 implies s='RIGHT', i=3 implies s='BOTTOM', i=4 implies +C s='TOP'). Each of these specifies whether or not a given axis will +C be drawn or not and what liberties may be taken with numeric labels +C on the axis. +C + DATA QDAX(1)/ 4. / , QDAX(2)/ 4. / , QDAX(3)/ 4. / , QDAX(4)/ 4. / +C +C Each QSPA(i) defines a control parameter 'AXIS/s/LINE.', which says +C whether or not the line portion of a particular axis is to be drawn. +C + DATA QSPA(1)/ 0. / , QSPA(2)/ 0. / , QSPA(3)/ 0. / , QSPA(4)/ 0. / +C +C Each PING(i) defines a control parameter 'AXIS/s/INTERSECTION/GRID.', +C which may be used to move a particular axis to a specified position. +C + DATA PING(1)/1E36/ , PING(2)/1E36/ , PING(3)/1E36/ , PING(4)/1E36/ +C +C Each PINU(i) defines a control parameter 'AXIS/s/INTERSECTION/USER.', +C which may be used to move a particular axis to a specified position. +C + DATA PINU(1)/1E36/ , PINU(2)/1E36/ , PINU(3)/1E36/ , PINU(4)/1E36/ +C +C Each FUNS(i) defines a control parameter 'AXIS/s/FUNCTION.', which is +C used within a user-supplied version of AGUTOL to select a particular +C uset-system-to-label-system mapping for a particular axis. The +C default value selects the identity mapping. +C + DATA FUNS(1)/ 0. / , FUNS(2)/ 0. / , FUNS(3)/ 0. / , FUNS(4)/ 0. / +C +C The values of QBTD(i), BASD(i), QMJD(i), QJDP(i), WMJL(i), and WMJR(i) +C together define the control-parameter group 'AXIS/s/TICKS/MAJOR.', +C which determines the positioning and appearance of the major ticks on +C a particular axis. +C + DATA QBTD(1)/1E36/ , QBTD(2)/1E36/ , QBTD(3)/1E36/ , QBTD(4)/1E36/ + DATA BASD(1)/1E36/ , BASD(2)/1E36/ , BASD(3)/1E36/ , BASD(4)/1E36/ + DATA QMJD(1)/ 6. / , QMJD(2)/ 6. / , QMJD(3)/ 6. / , QMJD(4)/ 6. / + DATA QJDP(1)/1E36/ , QJDP(2)/1E36/ , QJDP(3)/1E36/ , QJDP(4)/1E36/ + DATA WMJL(1)/ 0. / , WMJL(2)/ 0. / , WMJL(3)/ 0. / , WMJL(4)/ 0. / + DATA WMJR(1)/.015/ , WMJR(2)/.015/ , WMJR(3)/.015/ , WMJR(4)/.015/ +C +C The values of QMND(i), QNDP(i), WMNL(i), and WMNR(i) together define +C the control-parameter group 'AXIS/s/TICKS/MINOR.', which determines +C the positioning and appearance of the major ticks on a particular +C axis. +C + DATA QMND(1)/1E36/ , QMND(2)/1E36/ , QMND(3)/1E36/ , QMND(4)/1E36/ + DATA QNDP(1)/1E36/ , QNDP(2)/1E36/ , QNDP(3)/1E36/ , QNDP(4)/1E36/ + DATA WMNL(1)/ 0. / , WMNL(2)/ 0. / , WMNL(3)/ 0. / , WMNL(4)/ 0. / + DATA WMNR(1)/.010/ , WMNR(2)/.010/ , WMNR(3)/.010/ , WMNR(4)/.010/ +C +C The values of QLTD(i), QLED(i), QLFD(i), QLOF(i), QLOS(i), DNLA(i), +C WCLM(i), and WCLE(i) together define the control-parameter group +C 'AXIS/s/NUMERIC.', which determines the positioning and appearance of +C the numeric labels on a particular axis. +C + DATA QLTD(1)/1E36/ , QLTD(2)/ 0./ , QLTD(3)/1E36/ , QLTD(4)/ 0./ + DATA QLED(1)/1E36/ , QLED(2)/1E36/ , QLED(3)/1E36/ , QLED(4)/1E36/ + DATA QLFD(1)/1E36/ , QLFD(2)/1E36/ , QLFD(3)/1E36/ , QLFD(4)/1E36/ + DATA QLOF(1)/ 0. / , QLOF(2)/ 0. / , QLOF(3)/ 0. / , QLOF(4)/ 0. / + DATA QLOS(1)/ 90./ , QLOS(2)/ 90./ , QLOS(3)/ 90./ , QLOS(4)/ 90./ + DATA DNLA(1)/.015/ , DNLA(2)/.015/ , DNLA(3)/.015/ , DNLA(4)/.015/ + DATA WCLM(1)/.015/ , WCLM(2)/.015/ , WCLM(3)/.015/ , WCLM(4)/.015/ + DATA WCLE(1)/.010/ , WCLE(2)/.010/ , WCLE(3)/.010/ , WCLE(4)/.010/ +C +C QODP defines the control parameter 'DASH/SELECTOR.', the sign of which +C determines which set of dash patterns is used by EZMY and EZMXY (the +C alphabetic set or the user-specified set); if the user-specified set +C is selected, the magnitude of QODP determines how many of them are to +C be used. +C + DATA QODP / 1. / +C +C QCDP defines the control parameter 'DASH/LENGTH.', which specifies the +C assumed length of dash patterns tendered to AUTOGRAPH. +C + DATA QCDP / 8. / +C +C WOCD and WODQ define the control parameters 'DASH/CHARACTER.' and +C 'DASH/DOLLAR-QUOTE.', which specify the widths of characters used in +C character-string dash patterns. +C + DATA WOCD / .010 / , WODQ / .010 / +C +C QDSH defines the control-parameter group 'DASH/PATTERN.'. Each value, +C if positive, defines a binary dash pattern, and, if negative, serves +C as an identifier in retrieving a character-string dash pattern. +C + DATA QDSH / 26*65535. / +C +C QDLB defines the control parameter 'LABEL/CONTROL.', which specifies +C what may be done with informational labels in response to overlap +C problems. +C + DATA QDLB /2./ +C +C QBIM defines the control parameter 'LABEL/BUFFER/LENGTH.' and must +C be equal to the second dimension of the array FLLB. +C + DATA QBIM / 8. / +C +C QBAN defines the control parameter 'LABEL/NAME.'; its value is really +C a pointer into the label list. The default value, zero, means that +C the pointer has not been set. +C + DATA QBAN / 0. / +C +C QLLN defines the control parameter 'LINE/MAXIMUM.' - the assumed +C maximum length of character strings intended for use as the text of a +C line of a label. +C + DATA QLLN /40./ +C +C TCLN defines the control parameter 'LINE/TERMINATOR.' - which is used +C to mark the end of character strings intended for use as the text of a +C line of a label. It is initialized in AGINIT. +C +C QNIM defines the control parameter 'LINE/BUFFER/LENGTH.' and must be +C equal to the second dimension of FLLN. +C + DATA QNIM / 16. / +C +C QNAN defines the control parameter 'LINE/NUMBER.'; its value is really +C a pointer into the line list. The default value, zero, says that the +C pointer has not been set. +C + DATA QNAN / 0. / +C +C (FLLB(I,1),I=1,10) and (FLLN(I,1),I=1,6) define the label to the left +C of the grid. The name, in FLLB(1,1), and the line text, in FLLN(4,1), +C must be filled in by AGINIT. +C + DATA FLLB( 1,1)/ 0./ , FLLB( 2,1)/ 0./ , FLLB( 3,1)/ 0./ , + + FLLB( 4,1)/ .5/ , FLLB( 5,1)/-.015/ , FLLB( 6,1)/ 0./ , + + FLLB( 7,1)/ 90./ , FLLB( 8,1)/ 0./ , FLLB( 9,1)/ 1./ , + + FLLB(10,1)/ 1./ , FLLN( 1,1)/+100./ , FLLN( 2,1)/ 0./ , + + FLLN( 3,1)/ .015/ , FLLN( 4,1)/ -2./ , FLLN( 5,1)/ 1./ , + + FLLN( 6,1)/ 0./ +C +C (FLLB(I,2),I=1,10) and (FLLN(I,2),I=1,6) define the label to the right +C of the grid. The name, in FLLB(1,2), and the line text, in FLLN(4,2), +C must be filled in by AGINIT. +C + DATA FLLB( 1,2)/ 0./ , FLLB( 2,2)/ 0./ , FLLB( 3,2)/ 1./ , + + FLLB( 4,2)/ .5/ , FLLB( 5,2)/+.015/ , FLLB( 6,2)/ 0./ , + + FLLB( 7,2)/ 90./ , FLLB( 8,2)/ 0./ , FLLB( 9,2)/ 1./ , + + FLLB(10,2)/ 2./ , FLLN( 1,2)/-100./ , FLLN( 2,2)/ 0./ , + + FLLN( 3,2)/ .015/ , FLLN( 4,2)/ -3./ , FLLN( 5,2)/ 0./ , + + FLLN( 6,2)/ 0./ +C +C (FLLB(I,3),I=1,10) and (FLLN(I,3),I=1,6) define the label below the +C grid. The name, in FLLB(1,3), and the line text, in FLLN(4,3), must +C be filled in by AGINIT. +C + DATA FLLB( 1,3)/ 0./ , FLLB( 2,3)/ 0./ , FLLB( 3,3)/ .5/ , + + FLLB( 4,3)/ 0./ , FLLB( 5,3)/ 0./ , FLLB( 6,3)/-.015/ , + + FLLB( 7,3)/ 0./ , FLLB( 8,3)/ 0./ , FLLB( 9,3)/ 1./ , + + FLLB(10,3)/ 3./ , FLLN( 1,3)/-100./ , FLLN( 2,3)/ 0./ , + + FLLN( 3,3)/ .015/ , FLLN( 4,3)/ -1./ , FLLN( 5,3)/ 1./ , + + FLLN( 6,3)/ 0./ +C +C (FLLB(I,4),I=1,10) and (FLLN(I,4),I=1,6) define the label above the +C grid. The name, in FLLB(1,4), and the line text, in FLLN(4,4), must +C be filled in by AGINIT. +C + DATA FLLB( 1,4)/ 0./ , FLLB( 2,4)/ 0./ , FLLB( 3,4)/ .5/ , + + FLLB( 4,4)/ 1./ , FLLB( 5,4)/ 0./ , FLLB( 6,4)/+.020/ , + + FLLB( 7,4)/ 0./ , FLLB( 8,4)/ 0./ , FLLB( 9,4)/ 1./ , + + FLLB(10,4)/ 4./ , FLLN( 1,4)/+100./ , FLLN( 2,4)/ 0./ , + + FLLN( 3,4)/ .020/ , FLLN( 4,4)/ -3./ , FLLN( 5,4)/ 0./ , + + FLLN( 6,4)/ 0./ +C +C Certain secondary parameters must be initialized to prevent bombing. +C + DATA QBTP(1)/ 0./ , QBTP(2)/ 0./ , QBTP(3)/ 0./ , QBTP(4)/ 0./ + DATA BASE(1)/ 0./ , BASE(2)/ 0./ , BASE(3)/ 0./ , BASE(4)/ 0./ + DATA QMNT(1)/ 0./ , QMNT(2)/ 0./ , QMNT(3)/ 0./ , QMNT(4)/ 0./ + DATA QLTP(1)/ 0./ , QLTP(2)/ 0./ , QLTP(3)/ 0./ , QLTP(4)/ 0./ + DATA QLEX(1)/ 0./ , QLEX(2)/ 0./ , QLEX(3)/ 0./ , QLEX(4)/ 0./ + DATA QLFL(1)/ 0./ , QLFL(2)/ 0./ , QLFL(3)/ 0./ , QLFL(4)/ 0./ + DATA QCIM(1)/ 0./ , QCIM(2)/ 0./ , QCIM(3)/ 0./ , QCIM(4)/ 0./ + DATA QCIE(1)/ 0./ , QCIE(2)/ 0./ , QCIE(3)/ 0./ , QCIE(4)/ 0./ + DATA RFNL(1)/ 0./ , RFNL(2)/ 0./ , RFNL(3)/ 0./ , RFNL(4)/ 0./ + DATA QLUA(1)/ 0./ , QLUA(2)/ 0./ , QLUA(3)/ 0./ , QLUA(4)/ 0./ +C +C SMRL and ISLD are set by the routine AGINIT (which see, below). +C +C MWCL, MWCM, MWCE, MDLA, MWCD, and MWDQ are the minimum widths of label +C characters, mantissa characters, exponent characters, label-to-axis +C distances, dash-pattern characters, and dash-pattern spaces, respect- +C ively (in the plotter coordinate system). +C + DATA MWCL /8/, MWCM /8/, MWCE /8/, MDLA /8/, MWCD /8/, MWDQ /8/ +C +C INIF is an initialization flag, set non-zero to indicate that the +C routine AGINIT has been executed to set the values of AUTOGRAPH +C parameters which, for one reason or another, cannot be preset by +C this block data routine. +C + DATA INIF / 0 / +C +C CHS1 and CHS2 are used within AUTOGRAPH when manipulating character +C strings retrieved by calls to AGGTCH. They need not be preset. +C +C LNIC is the second dimension of the array (INCH) which holds an index +C of the character strings stored by AGSTCH. +C + DATA LNIC / 50 / +C +C INCH is an index of character strings currently stored in CHRA. Each +C entry has the following format: +C +C INCH(1,I), if non-zero, is the index, in the array CHRA, of the +C first character of the Ith character string. +C +C INCH(2,I) is the length of the Ith character string. +C + DATA (INCH(1,I),I=1,50) / 50*0 / + DATA (INCH(2,I),I=1,50) / 50*0 / +C +C LNCA is the size of the array (CHRA) in which AGSTCH stores character +C strings. +C + DATA LNCA / 2000 / +C +C INCA is the index of the last character used in CHRA. +C + DATA INCA / 0 / +C +C CHRA holds character strings stored by AGSTCH. It need not be pre-set +C to anything. +C + END diff --git a/sys/gio/ncarutil/autograph/agdflt.f b/sys/gio/ncarutil/autograph/agdflt.f new file mode 100644 index 00000000..87b0ca45 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agdflt.f @@ -0,0 +1,690 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C +c +noao: blockdata rewritten to be run time initialization +c BLOCK DATA AGDFLT + subroutine agdflt +C +C The block data subroutine AGDFLT defines the default values of those +C AUTOGRAPH parameters which can be declared in a DATA statement. See +C AGINIT for code initializing other AUTOGRAPH parameters. +C +C Following are declarations of all the AUTOGRAPH common blocks. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C The following common block contains other AUTOGRAPH variables, of +C type character. +C + COMMON /AGOCHP/ CHS1,CHS2 +C +c+noao +c CHARACTER*504 CHS1,CHS2 + CHARACTER*500 CHS1,CHS2 +c-noao +C +C The following common blocks contain variables which are required for +C the character-storage-and-retrieval scheme of AUTOGRAPH. +C + COMMON /AGCHR1/ LNIC,INCH(2,50),LNCA,INCA +C + COMMON /AGCHR2/ CHRA(2000) +C + CHARACTER*1 CHRA +C +c +noao: logical flag added to prevent "over-initialization" + logical first + data first /.true./ + call utilbd + if (.not. first) return + first = .false. +c -noao +C --------------------------------------------------------------------- +C +C Following are declarations of default values of variables in the +C AUTOGRAPH common blocks. +C +C --------------------------------------------------------------------- +C +C QFRA defines the control parameter 'FRAME.', which specifies when, if +C ever, the EZ... routines are to call FRAME to advance to a new frame. +C +c DATA QFRA / 1. / + QFRA = 1. +C +C QSET defines the control parameter 'SET.', which determines how the +C last call to the plot-package routine "SET" is to affect AUTOGRAPH. +C +c DATA QSET / 1. / + QSET = 1. +C +C QROW defines the control parameter 'ROW.', which determines how the x +C and y input arrays (in calls to AGSTUP and AGCURV) are to be used. +C +c DATA QROW / 1. / + QROW = 1. +C +C QIXY defines the control parameter 'INVERT.', which, if set non-zero, +C causes the routines AGSTUP and AGCURV to behave as if the arguments +C defining the x and y data had been interchanged. +C +c DATA QIXY / 0. / + QIXY = 0. +C +C QWND defines the control parameter 'WINDOW.', which, if set non-zero, +C causes curves drawn to be scissored by the edge of the curve window. +C +c DATA QWND / 0. / + QWND = 0. +C +C QBAC defines the control parameter 'BACKGROUND.', which can be given +C any of four values to set up four specific types of plot background. +C +c DATA QBAC / 1. / + QBAC = 1. +C +C SVAL defines the control parameters 'NULL/1.' and 'NULL/2.', which are +C used in various ways by AUTOGRAPH. +C +c DATA SVAL(1) / 1E36 / , SVAL(2) / 2E36 / + SVAL(1) = 1E36 + SVAL(2) = 2E36 +C +C XLGF, XRGF, YBGF, and YTGF define the parameter-group 'GRAPH.'; they +C specify the position of the graph window within the plotter frame. +C +c DATA XLGF / 0. / , XRGF / 1. / , YBGF / 0. / , YTGF / 1. / + XLGF = 0. + XRGF = 1. + YBGF = 0. + YTGF = 1. +C +C XLGD, XRGD, YBGD, and YTGD define the first four parameters in the +C group 'GRID.'; they specify the position of the grid window within +C the graph window. +C +c DATA XLGD / .15 / , XRGD / .95 / , YBGD / .15 / , YTGD / .95 / + XLGD = .15 + XRGD = .95 + YBGD = .15 + YTGD = .95 +C +C SOGD defines the control parameter 'GRID/SHAPE.', which defines the +C shape of the grid window. +C +c DATA SOGD / 0. / + SOGD = 0. +C +C XMIN and XMAX define the control parameters 'X/MIN.' and 'X/MAX.', +C which determine how minimum and maximum values of x are to be chosen. +C Null values imply that AUTOGRAPH is to choose real values; non-null +C values are the actual values to be used (perhaps after rounding). +C +c DATA XMIN / 1E36 / , XMAX / 1E36 / + XMIN = 1E36 + XMAX = 1E36 +C +C QLUX defines the control parameter 'X/LOG.', which is set non-zero to +C specify that the horizontal axis is to be logarithmic. +C +c DATA QLUX / 0. / + QLUX = 0. +C +C QOVX defines the control parameter 'X/ORDER.', which is set non-zero +C to flip the horizontal axis end-for-end. +C +c DATA QOVX / 0. / + QOVX = 0. +C +C QCEX defines the control parameter 'X/NICE.', which determines which, +C if either, of the horizontal axes is to have "nice" (rounded) values +C at its ends. +C +c DATA QCEX / -1. / + QCEX = -1. +C +C XLOW and XHGH define the control parameters 'X/SMALLEST.' and +C 'X/LARGEST.'; they come into play only when XMIN and/or XMAX are null +C and they are non-null, in which case they set limits on the range of +C x data to be considered when choosing the minimum and/or maximum. +C +c DATA XLOW / 1E36 / , XHGH / 1E36 / + XLOW = 1E36 + XHGH = 1E36 +C +C YMIN and YMAX define the control parameters 'Y/MIN.' and 'Y/MAX.', +C which determine how minimum and maximum values of y are to be chosen. +C Null values imply that AUTOGRAPH is to choose real values; non-null +C values are the actual values to be used (perhaps after rounding). +C +c DATA YMIN / 1E36 / , YMAX / 1E36 / + YMIN = 1E36 + YMAX = 1E36 +C +C QLUY defines the control parameter 'Y/LOG.', which is set non-zero to +C specify that the horizontal axis is to be logarithmic. +C +c DATA QLUY / 0. / + QLUY = 0. +C +C QOVY defines the control parameter 'Y/ORDER.', which is set non-zero +C to flip the horizontal axis end-for-end. +C +c DATA QOVY / 0. / + QOVY = 0. +C +C QCEY defines the control parameter 'Y/NICE.', which determines which, +C if either, of the horizontal axes is to have "nice" (rounded) values +C at its ends. +C +c DATA QCEY / -1. / + QCEY = -1. +C +C YLOW and YHGH define the control parameters 'Y/SMALLEST.' and +C 'Y/LARGEST.'; they come into play only when YMIN and/or YMAX are null +C and they are non-null, in which case they set limits on the range of +C y data to be considered when choosing the minimum and/or maximum. +C +c DATA YLOW / 1E36 / , YHGH / 1E36 / + YLOW = 1E36 + YHGH = 1E36 +C +C QDAX(i) defines the control parameters 'AXIS/s/CONTROL.' (i=1 implies +C s='LEFT', i=2 implies s='RIGHT', i=3 implies s='BOTTOM', i=4 implies +C s='TOP'). Each of these specifies whether or not a given axis will +C be drawn or not and what liberties may be taken with numeric labels +C on the axis. +C +c DATA QDAX(1)/ 4. / , QDAX(2)/ 4. / , QDAX(3)/ 4. / , QDAX(4)/ 4. / + QDAX(1) = 4. + QDAX(2) = 4. + QDAX(3) = 4. + QDAX(4) = 4. +C +C Each QSPA(i) defines a control parameter 'AXIS/s/LINE.', which says +C whether or not the line portion of a particular axis is to be drawn. +C +c DATA QSPA(1)/ 0. / , QSPA(2)/ 0. / , QSPA(3)/ 0. / , QSPA(4)/ 0. / + QSPA(1) = 0. + QSPA(2) = 0. + QSPA(3) = 0. + QSPA(4) = 0. +C +C Each PING(i) defines a control parameter 'AXIS/s/INTERSECTION/GRID.', +C which may be used to move a particular axis to a specified position. +C +c DATA PING(1)/1E36/ , PING(2)/1E36/ , PING(3)/1E36/ , PING(4)/1E36/ + PING(1) = 1E36 + PING(2) = 1E36 + PING(3) = 1E36 + PING(4) = 1E36 +C +C Each PINU(i) defines a control parameter 'AXIS/s/INTERSECTION/USER.', +C which may be used to move a particular axis to a specified position. +C +c DATA PINU(1)/1E36/ , PINU(2)/1E36/ , PINU(3)/1E36/ , PINU(4)/1E36/ + PINU(1) = 1E36 + PINU(2) = 1E36 + PINU(3) = 1E36 + PINU(4) = 1E36 +C +C Each FUNS(i) defines a control parameter 'AXIS/s/FUNCTION.', which is +C used within a user-supplied version of AGUTOL to select a particular +C uset-system-to-label-system mapping for a particular axis. The +C default value selects the identity mapping. +C +c DATA FUNS(1)/ 0. / , FUNS(2)/ 0. / , FUNS(3)/ 0. / , FUNS(4)/ 0. / + FUNS(1) = 0. + FUNS(2) = 0. + FUNS(3) = 0. + FUNS(4) = 0. +C +C The values of QBTD(i), BASD(i), QMJD(i), QJDP(i), WMJL(i), and WMJR(i) +C together define the control-parameter group 'AXIS/s/TICKS/MAJOR.', +C which determines the positioning and appearance of the major ticks on +C a particular axis. +C +c DATA QBTD(1)/1E36/ , QBTD(2)/1E36/ , QBTD(3)/1E36/ , QBTD(4)/1E36/ +c DATA BASD(1)/1E36/ , BASD(2)/1E36/ , BASD(3)/1E36/ , BASD(4)/1E36/ +c DATA QMJD(1)/ 6. / , QMJD(2)/ 6. / , QMJD(3)/ 6. / , QMJD(4)/ 6. / +c DATA QJDP(1)/1E36/ , QJDP(2)/1E36/ , QJDP(3)/1E36/ , QJDP(4)/1E36/ +c DATA WMJL(1)/ 0. / , WMJL(2)/ 0. / , WMJL(3)/ 0. / , WMJL(4)/ 0. / +c DATA WMJR(1)/.015/ , WMJR(2)/.015/ , WMJR(3)/.015/ , WMJR(4)/.015/ + QBTD(1) = 1E36 + QBTD(2) = 1E36 + QBTD(3) = 1E36 + QBTD(4) = 1E36 + BASD(1) = 1E36 + BASD(2) = 1E36 + BASD(3) = 1E36 + BASD(4) = 1E36 + QMJD(1) = 6. + QMJD(2) = 6. + QMJD(3) = 6. + QMJD(4) = 6. + QJDP(1) = 1E36 + QJDP(2) = 1E36 + QJDP(3) = 1E36 + QJDP(4) = 1E36 + WMJL(1) = 0. + WMJL(2) = 0. + WMJL(3) = 0. + WMJL(4) = 0. + WMJR(1) = .015 + WMJR(2) = .015 + WMJR(3) = .015 + WMJR(4) = .015 +C +C The values of QMND(i), QNDP(i), WMNL(i), and WMNR(i) together define +C the control-parameter group 'AXIS/s/TICKS/MINOR.', which determines +C the positioning and appearance of the major ticks on a particular +C axis. +C +c DATA QMND(1)/1E36/ , QMND(2)/1E36/ , QMND(3)/1E36/ , QMND(4)/1E36/ +c DATA QNDP(1)/1E36/ , QNDP(2)/1E36/ , QNDP(3)/1E36/ , QNDP(4)/1E36/ +c DATA WMNL(1)/ 0. / , WMNL(2)/ 0. / , WMNL(3)/ 0. / , WMNL(4)/ 0. / +c DATA WMNR(1)/.010/ , WMNR(2)/.010/ , WMNR(3)/.010/ , WMNR(4)/.010/ + QMND(1) = 1E36 + QMND(2) = 1E36 + QMND(3) = 1E36 + QMND(4) = 1E36 + QNDP(1) = 1E36 + QNDP(2) = 1E36 + QNDP(3) = 1E36 + QNDP(4) = 1E36 + WMNL(1) = 0. + WMNL(2) = 0. + WMNL(3) = 0. + WMNL(4) = 0. + WMNR(1) = .010 + WMNR(2) = .010 + WMNR(3) = .010 + WMNR(4) = .010 +C +C The values of QLTD(i), QLED(i), QLFD(i), QLOF(i), QLOS(i), DNLA(i), +C WCLM(i), and WCLE(i) together define the control-parameter group +C 'AXIS/s/NUMERIC.', which determines the positioning and appearance of +C the numeric labels on a particular axis. +C +c DATA QLTD(1)/1E36/ , QLTD(2)/ 0./ , QLTD(3)/1E36/ , QLTD(4)/ 0./ +c DATA QLED(1)/1E36/ , QLED(2)/1E36/ , QLED(3)/1E36/ , QLED(4)/1E36/ +c DATA QLFD(1)/1E36/ , QLFD(2)/1E36/ , QLFD(3)/1E36/ , QLFD(4)/1E36/ +c DATA QLOF(1)/ 0. / , QLOF(2)/ 0. / , QLOF(3)/ 0. / , QLOF(4)/ 0. / +c DATA QLOS(1)/ 90./ , QLOS(2)/ 90./ , QLOS(3)/ 90./ , QLOS(4)/ 90./ +c DATA DNLA(1)/.015/ , DNLA(2)/.015/ , DNLA(3)/.015/ , DNLA(4)/.015/ +c DATA WCLM(1)/.015/ , WCLM(2)/.015/ , WCLM(3)/.015/ , WCLM(4)/.015/ +c DATA WCLE(1)/.010/ , WCLE(2)/.010/ , WCLE(3)/.010/ , WCLE(4)/.010/ + QLTD(1) = 1E36 + QLTD(2) = 0. + QLTD(3) = 1E36 + QLTD(4) = 0. + QLED(1) = 1E36 + QLED(2) = 1E36 + QLED(3) = 1E36 + QLED(4) = 1E36 + QLFD(1) = 1E36 + QLFD(2) = 1E36 + QLFD(3) = 1E36 + QLFD(4) = 1E36 + QLOF(1) = 0. + QLOF(2) = 0. + QLOF(3) = 0. + QLOF(4) = 0. + QLOS(1) = 90. + QLOS(2) = 90. + QLOS(3) = 90. + QLOS(4) = 90. + DNLA(1) = .015 + DNLA(2) = .015 + DNLA(3) = .015 + DNLA(4) = .015 + WCLM(1) = .015 + WCLM(2) = .015 + WCLM(3) = .015 + WCLM(4) = .015 + WCLE(1) = .010 + WCLE(2) = .010 + WCLE(3) = .010 + WCLE(4) = .010 +C +C QODP defines the control parameter 'DASH/SELECTOR.', the sign of which +C determines which set of dash patterns is used by EZMY and EZMXY (the +C alphabetic set or the user-specified set); if the user-specified set +C is selected, the magnitude of QODP determines how many of them are to +C be used. +C +c DATA QODP / 1. / + QODP = 1. +C +C QCDP defines the control parameter 'DASH/LENGTH.', which specifies the +C assumed length of dash patterns tendered to AUTOGRAPH. +C +c DATA QCDP / 8. / + QCDP = 8. +C +C WOCD and WODQ define the control parameters 'DASH/CHARACTER.' and +C 'DASH/DOLLAR-QUOTE.', which specify the widths of characters used in +C character-string dash patterns. +C +c DATA WOCD / .010 / , WODQ / .010 / + WOCD = .010 + WODQ = .010 +C +C QDSH defines the control-parameter group 'DASH/PATTERN.'. Each value, +C if positive, defines a binary dash pattern, and, if negative, serves +C as an identifier in retrieving a character-string dash pattern. +C +c DATA QDSH / 26*65535. / + do 20, ijk = 1, 26 + 20 QDSH(ijk) = 65535. +C +C QDLB defines the control parameter 'LABEL/CONTROL.', which specifies +C what may be done with informational labels in response to overlap +C problems. +C +c DATA QDLB /2./ + QDLB = 2. +C +C QBIM defines the control parameter 'LABEL/BUFFER/LENGTH.' and must +C be equal to the second dimension of the array FLLB. +C +c DATA QBIM / 8. / + QBIM = 8. +C +C QBAN defines the control parameter 'LABEL/NAME.'; its value is really +C a pointer into the label list. The default value, zero, means that +C the pointer has not been set. +C +c DATA QBAN / 0. / + QBAN = 0. +C +C QLLN defines the control parameter 'LINE/MAXIMUM.' - the assumed +C maximum length of character strings intended for use as the text of a +C line of a label. +C +c DATA QLLN /40./ + QLLN = 40. +C +C TCLN defines the control parameter 'LINE/TERMINATOR.' - which is used +C to mark the end of character strings intended for use as the text of a +C line of a label. It is initialized in AGINIT. +C +C QNIM defines the control parameter 'LINE/BUFFER/LENGTH.' and must be +C equal to the second dimension of FLLN. +C +c DATA QNIM / 16. / + QNIM = 16. +C +C QNAN defines the control parameter 'LINE/NUMBER.'; its value is really +C a pointer into the line list. The default value, zero, says that the +C pointer has not been set. +C +c DATA QNAN / 0. / + QNAN = 0. +C +C (FLLB(I,1),I=1,10) and (FLLN(I,1),I=1,6) define the label to the left +C of the grid. The name, in FLLB(1,1), and the line text, in FLLN(4,1), +C must be filled in by AGINIT. +C +c DATA FLLB( 1,1)/ 0./ , FLLB( 2,1)/ 0./ , FLLB( 3,1)/ 0./ , +c + FLLB( 4,1)/ .5/ , FLLB( 5,1)/-.015/ , FLLB( 6,1)/ 0./ , +c + FLLB( 7,1)/ 90./ , FLLB( 8,1)/ 0./ , FLLB( 9,1)/ 1./ , +c + FLLB(10,1)/ 1./ , FLLN( 1,1)/+100./ , FLLN( 2,1)/ 0./ , +c + FLLN( 3,1)/ .015/ , FLLN( 4,1)/ -2./ , FLLN( 5,1)/ 1./ , +c + FLLN( 6,1)/ 0./ + FLLB( 1,1) = 0. + FLLB( 2,1) = 0. + FLLB( 3,1) = 0. + FLLB( 4,1) = .5 + FLLB( 5,1) = -.015 + FLLB( 6,1) = 0. + FLLB( 7,1) = 90. + FLLB( 8,1) = 0. + FLLB( 9,1) = 1. + FLLB(10,1) = 1. + FLLN( 1,1) = +100. + FLLN( 2,1) = 0. + FLLN( 3,1) = .015 + FLLN( 4,1) = -2. + FLLN( 5,1) = 1. + FLLN( 6,1) = 0. +C +C (FLLB(I,2),I=1,10) and (FLLN(I,2),I=1,6) define the label to the right +C of the grid. The name, in FLLB(1,2), and the line text, in FLLN(4,2), +C must be filled in by AGINIT. +C +c DATA FLLB( 1,2)/ 0./ , FLLB( 2,2)/ 0./ , FLLB( 3,2)/ 1./ , +c + FLLB( 4,2)/ .5/ , FLLB( 5,2)/+.015/ , FLLB( 6,2)/ 0./ , +c + FLLB( 7,2)/ 90./ , FLLB( 8,2)/ 0./ , FLLB( 9,2)/ 1./ , +c + FLLB(10,2)/ 2./ , FLLN( 1,2)/-100./ , FLLN( 2,2)/ 0./ , +c + FLLN( 3,2)/ .015/ , FLLN( 4,2)/ -3./ , FLLN( 5,2)/ 0./ , +c + FLLN( 6,2)/ 0./ + FLLB( 1,2) = 0. + FLLB( 2,2) = 0. + FLLB( 3,2) = 1. + FLLB( 4,2) = .5 + FLLB( 5,2) = +.015 + FLLB( 6,2) = 0. + FLLB( 7,2) = 90. + FLLB( 8,2) = 0. + FLLB( 9,2) = 1. + FLLB(10,2) = 2. + FLLN( 1,2) = -100. + FLLN( 2,2) = 0. + FLLN( 3,2) = .015 + FLLN( 4,2) = -3. + FLLN( 5,2) = 0. + FLLN( 6,2) = 0. +C +C (FLLB(I,3),I=1,10) and (FLLN(I,3),I=1,6) define the label below the +C grid. The name, in FLLB(1,3), and the line text, in FLLN(4,3), must +C be filled in by AGINIT. +C +c DATA FLLB( 1,3)/ 0./ , FLLB( 2,3)/ 0./ , FLLB( 3,3)/ .5/ , +c + FLLB( 4,3)/ 0./ , FLLB( 5,3)/ 0./ , FLLB( 6,3)/-.015/ , +c + FLLB( 7,3)/ 0./ , FLLB( 8,3)/ 0./ , FLLB( 9,3)/ 1./ , +c + FLLB(10,3)/ 3./ , FLLN( 1,3)/-100./ , FLLN( 2,3)/ 0./ , +c + FLLN( 3,3)/ .015/ , FLLN( 4,3)/ -1./ , FLLN( 5,3)/ 1./ , +c + FLLN( 6,3)/ 0./ + FLLB( 1,3) = 0. + FLLB( 2,3) = 0. + FLLB( 3,3) = .5 + FLLB( 4,3) = 0. + FLLB( 5,3) = 0. + FLLB( 6,3) = -.015 + FLLB( 7,3) = 0. + FLLB( 8,3) = 0. + FLLB( 9,3) = 1. + FLLB(10,3) = 3. + FLLN( 1,3) = -100. + FLLN( 2,3) = 0. + FLLN( 3,3) = .015 + FLLN( 4,3) = -1. + FLLN( 5,3) = 1. + FLLN( 6,3) = 0. +C +C (FLLB(I,4),I=1,10) and (FLLN(I,4),I=1,6) define the label above the +C grid. The name, in FLLB(1,4), and the line text, in FLLN(4,4), must +C be filled in by AGINIT. +C +c DATA FLLB( 1,4)/ 0./ , FLLB( 2,4)/ 0./ , FLLB( 3,4)/ .5/ , +c + FLLB( 4,4)/ 1./ , FLLB( 5,4)/ 0./ , FLLB( 6,4)/+.020/ , +c + FLLB( 7,4)/ 0./ , FLLB( 8,4)/ 0./ , FLLB( 9,4)/ 1./ , +c + FLLB(10,4)/ 4./ , FLLN( 1,4)/+100./ , FLLN( 2,4)/ 0./ , +c + FLLN( 3,4)/ .020/ , FLLN( 4,4)/ -3./ , FLLN( 5,4)/ 0./ , +c + FLLN( 6,4)/ 0./ + FLLB( 1,4) = 0. + FLLB( 2,4) = 0. + FLLB( 3,4) = .5 + FLLB( 4,4) = 1. + FLLB( 5,4) = 0. + FLLB( 6,4) = +.020 + FLLB( 7,4) = 0. + FLLB( 8,4) = 0. + FLLB( 9,4) = 1. + FLLB(10,4) = 4. + FLLN( 1,4) = +100. + FLLN( 2,4) = 0. + FLLN( 3,4) = .020 + FLLN( 4,4) = -3. + FLLN( 5,4) = 0. + FLLN( 6,4) = 0. +C +C Certain secondary parameters must be initialized to prevent bombing. +C +c DATA QBTP(1)/ 0./ , QBTP(2)/ 0./ , QBTP(3)/ 0./ , QBTP(4)/ 0./ +c DATA BASE(1)/ 0./ , BASE(2)/ 0./ , BASE(3)/ 0./ , BASE(4)/ 0./ +c DATA QMNT(1)/ 0./ , QMNT(2)/ 0./ , QMNT(3)/ 0./ , QMNT(4)/ 0./ +c DATA QLTP(1)/ 0./ , QLTP(2)/ 0./ , QLTP(3)/ 0./ , QLTP(4)/ 0./ +c DATA QLEX(1)/ 0./ , QLEX(2)/ 0./ , QLEX(3)/ 0./ , QLEX(4)/ 0./ +c DATA QLFL(1)/ 0./ , QLFL(2)/ 0./ , QLFL(3)/ 0./ , QLFL(4)/ 0./ +c DATA QCIM(1)/ 0./ , QCIM(2)/ 0./ , QCIM(3)/ 0./ , QCIM(4)/ 0./ +c DATA QCIE(1)/ 0./ , QCIE(2)/ 0./ , QCIE(3)/ 0./ , QCIE(4)/ 0./ +c DATA RFNL(1)/ 0./ , RFNL(2)/ 0./ , RFNL(3)/ 0./ , RFNL(4)/ 0./ +c DATA QLUA(1)/ 0./ , QLUA(2)/ 0./ , QLUA(3)/ 0./ , QLUA(4)/ 0./ + QBTP(1) = 0. + QBTP(2) = 0. + QBTP(3) = 0. + QBTP(4) = 0. + BASE(1) = 0. + BASE(2) = 0. + BASE(3) = 0. + BASE(4) = 0. + QMNT(1) = 0. + QMNT(2) = 0. + QMNT(3) = 0. + QMNT(4) = 0. + QLTP(1) = 0. + QLTP(2) = 0. + QLTP(3) = 0. + QLTP(4) = 0. + QLEX(1) = 0. + QLEX(2) = 0. + QLEX(3) = 0. + QLEX(4) = 0. + QLFL(1) = 0. + QLFL(2) = 0. + QLFL(3) = 0. + QLFL(4) = 0. + QCIM(1) = 0. + QCIM(2) = 0. + QCIM(3) = 0. + QCIM(4) = 0. + QCIE(1) = 0. + QCIE(2) = 0. + QCIE(3) = 0. + QCIE(4) = 0. + RFNL(1) = 0. + RFNL(2) = 0. + RFNL(3) = 0. + RFNL(4) = 0. + QLUA(1) = 0. + QLUA(2) = 0. + QLUA(3) = 0. + QLUA(4) = 0. +C +C SMRL and ISLD are set by the routine AGINIT (which see, below). +C +C MWCL, MWCM, MWCE, MDLA, MWCD, and MWDQ are the minimum widths of label +C characters, mantissa characters, exponent characters, label-to-axis +C distances, dash-pattern characters, and dash-pattern spaces, respect- +C ively (in the plotter coordinate system). +C +c DATA MWCL /8/, MWCM /8/, MWCE /8/, MDLA /8/, MWCD /8/, MWDQ /8/ + MWCL = 8 + MWCM = 8 + MWCE = 8 + MDLA = 8 + MWCD = 8 + MWDQ = 8 +C +C INIF is an initialization flag, set non-zero to indicate that the +C routine AGINIT has been executed to set the values of AUTOGRAPH +C parameters which, for one reason or another, cannot be preset by +C this block data routine. +C +c DATA INIF / 0 / + INIF = 0 +C +C CHS1 and CHS2 are used within AUTOGRAPH when manipulating character +C strings retrieved by calls to AGGTCH. They need not be preset. +C +C LNIC is the second dimension of the array (INCH) which holds an index +C of the character strings stored by AGSTCH. +C +c DATA LNIC / 50 / + LNIC = 50 +C +C INCH is an index of character strings currently stored in CHRA. Each +C entry has the following format: +C +C INCH(1,I), if non-zero, is the index, in the array CHRA, of the +C first character of the Ith character string. +C +C INCH(2,I) is the length of the Ith character string. +C +c DATA (INCH(1,I),I=1,50) / 50*0 / +c DATA (INCH(2,I),I=1,50) / 50*0 / + do 10, ijk = 1, 50 + inch (1, ijk) = 0 + inch (2, ijk) = 0 + 10 continue +C +C LNCA is the size of the array (CHRA) in which AGSTCH stores character +C strings. +C +c DATA LNCA / 2000 / + LNCA = 2000 +C +C INCA is the index of the last character used in CHRA. +C +c DATA INCA / 0 / + INCA = 0 +C +C CHRA holds character strings stored by AGSTCH. It need not be pre-set +C to anything. +C + return +c + entry initag + first = .true. + END diff --git a/sys/gio/ncarutil/autograph/agdlch.f b/sys/gio/ncarutil/autograph/agdlch.f new file mode 100644 index 00000000..78a96c8f --- /dev/null +++ b/sys/gio/ncarutil/autograph/agdlch.f @@ -0,0 +1,60 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGDLCH (IDCS) +C +C This routine deletes character strings previously stored by the +C routine AGSTCH (which see). It has the following argument: +C +C -- IDCS is the identifying integer returned by AGSTCH when the string +C was stored. +C +C The following common blocks contain variables which are required for +C the character-storage-and-retrieval scheme of AUTOGRAPH. +C + COMMON /AGCHR1/ LNIC,INCH(2,50),LNCA,INCA +C + COMMON /AGCHR2/ CHRA(2000) +C + CHARACTER*1 CHRA +C +C Only if the identifier is between -LNIC and -1, inclusive, was the +C string ever stored, so that it needs to be deleted. If the string is +C the last one in CHRA, we can just set INCA to point to the position +C preceding it; otherwise, we zero out the string but don't bother to +C collapse CHRA, which will happen in AGSTCH when the space is needed +C again. In either case, the index entry in INCH is zeroed. +C + IF (IDCS.GE.(-LNIC).AND.IDCS.LE.(-1)) THEN + I=-IDCS + J=INCH(1,I) + IF (J.GT.0) THEN + K=J+INCH(2,I)-1 + IF (K.EQ.INCA) THEN + INCA=J-1 + ELSE + DO 101 L=J,K + CHRA(L)=CHAR(0) + 101 CONTINUE + END IF + INCH(1,I)=0 + END IF + END IF +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agdshn.f b/sys/gio/ncarutil/autograph/agdshn.f new file mode 100644 index 00000000..a20a5dfd --- /dev/null +++ b/sys/gio/ncarutil/autograph/agdshn.f @@ -0,0 +1,34 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + CHARACTER*16 FUNCTION AGDSHN (IDSH) +C +C The value of this function is the name of the dash pattern numbered +C IDSH - that is to say, the character string 'DASH/PATTERN/n.', where +C n is an integer between 1 and 99, equal to MAX0(1,MIN0(99,IDSH)). +C + AGDSHN='DASH/PATTERN/ .' +C + KDSH=MAX0(1,MIN0(99,IDSH)) +C + DO 101 I=15,14,-1 + AGDSHN(I:I)=CHAR(ICHAR('0')+MOD(KDSH,10)) + IF (KDSH.LE.9) GO TO 102 + KDSH=KDSH/10 + 101 CONTINUE +C + 102 RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agexax.f b/sys/gio/ncarutil/autograph/agexax.f new file mode 100644 index 00000000..b16e2319 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agexax.f @@ -0,0 +1,415 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGEXAX (IAXS,SVAL,UMIN,UMAX,NICE,QLUA,FUNS,QBTP,BASD, + + BASE,QMJD,QMND,QMNT,QLTD,QLTP,QLED,QLEX,QLFD, + + QLFL,QMIN,QMAX) +C + DIMENSION SVAL(2) +C +C The routine AGEXAX is used by AGSTUP to examine the parameters which +C determine how a given axis is tick-marked and labelled and to provide +C default values for missing ones. Its arguments are as follows: +C +C -- IAXS is the number of the axis being drawn - 1, 2, 3, or 4. +C +C -- SVAL is the array of special values. +C +C -- UMIN and UMAX are the minimum and maximum values along the axis, in +C the user coordinate system. Rounded values of UMIN and UMAX are +C returned in QMIN and QMAX if the following argument (NICE) is zero. +C +C -- NICE is a flag indicating whether rounded values of UMIN and UMAX +C are to be returned (NICE.EQ.0) or not (NICE.NE.0). +C +C -- LLUA and FUNS specify the user-system-to-label-system mapping along +C the axis. See the routine AGAXIS for a discussion of them. +C +C -- NBTP, BASD, BASE, and NMJD are used to determine the positioning of +C major tick marks in the label coordinate system. NBTP and BASE are +C described in the routine AGNUMB. BASD is the desired value of BASE +C supplied by the user. If BASD has a null value, BASE is computed +C by AGEXAX. NMJD is a user-supplied-or-defaulted parameter giving +C the approximate number of major ticks (and therefore the number of +C numeric labels) to be placed on the axis. +C +C -- NMND and NMNT are the desired and actual (to be determined) number +C of minor ticks per major division. See discussion in AGAXIS. +C +C -- NLTD, NLTP, NLED, NLEX, NLFD, and NLFL are desired and actual (to +C be determined) values of the parameters describing the form to be +C used for numeric labels. See discussion in AGNUMB. +C +C -- QMIN and QMAX are rounded values of UMIN and UMAX, returned only if +C NICE.EQ.0. +C +C The following common block contains AUTOGRAPH variables which are +C not control parameters. The only one used here is SMRL, which is a +C (machine-dependent) small real which, when added to a number in the +C range (1,10), will round it upward without seriously affecting the +C leading significant digits. The object of this is to get rid of +C strings of nines. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C The arrays BASP and NMNP specify possible default values for BASE and +C NMNT when NBTP.EQ.1. +C + DIMENSION BASP(5),NMNP(5) +C + DATA BASP(1) / 10. / , NMNP(1) / 1 / , + * BASP(2) / 5. / , NMNP(2) / 4 / , + * BASP(3) / 2. / , NMNP(3) / 1 / , + * BASP(4) / 1. / , NMNP(4) / 1 / , + * BASP(5) / .5 / , NMNP(5) / 4 / +C +C If the parameter NBTP is zero, tick marks and labels are suppressed. +C + NBTP=IFIX(QBTP) + IF (NBTP.EQ.0) RETURN +C +C Unpack integer values from floating-point arguments. +C + LLUA=IFIX(QLUA) + NMJD=IFIX(QMJD) + IF (QMND.NE.SVAL(1).AND.QMND.NE.SVAL(2)) NMND=IFIX(QMND) + NMNT=0 + IF (QLTD.NE.SVAL(1).AND.QLTD.NE.SVAL(2)) NLTD=IFIX(QLTD) + NLTP=0 + IF (QLED.NE.SVAL(1).AND.QLED.NE.SVAL(2)) NLED=IFIX(QLED) + NLEX=0 + IF (QLFD.NE.SVAL(1).AND.QLFD.NE.SVAL(2)) NLFD=IFIX(QLFD) + NLFL=0 +C +C Compute label-coordinate-system values at the ends of the axis. +C + CALL AGUTOL (IAXS,FUNS,1,UMIN,VMIN) + CALL AGUTOL (IAXS,FUNS,1,UMAX,VMAX) +C +C Error if the label-coordinate-system values are equal. +C + IF (VMIN.EQ.VMAX) GO TO 901 +C +C If a special value is specified for the parameter BASD, AGEXAX must +C pick a value for the parameter BASE. +C + IF (BASD.EQ.SVAL(1).OR.BASD.EQ.SVAL(2)) GO TO 101 +C +C The user has specified a value for the parameter BASE. If that value +C is less than or equal to zero, tick marks and labels are suppressed. +C + BASE=AMAX1(0.,BASD) + IF (BASE.EQ.0.) RETURN + NMNT=0 + GO TO 108 +C +C Pick a value for the parameter BASE, depending on the number type. +C + 101 GO TO (102,105,106) , NBTP +C +C Major ticks and labels are at numbers of the form (-) BASE * EXMU. +C + 102 NMJD=MAX0(0,NMJD) +C +C Compute an approximate value for BASE. +C + FTMP=ABS(VMAX-VMIN)/FLOAT(NMJD+1) +C +C Reduce the approximate value to the form FTMP * 10 ** ITMP. +C + ASSIGN 103 TO JMP1 + GO TO 200 +C +C Pick a reasonable value for BASE (1., 2., OR 5. * 10**ITMP). +C + 103 DO 104 I=1,5 + IF (FTMP.LT.BASP(I)) GO TO 104 + BASE=BASP(I)*SNGL(10.D0**ITMP) + NMNT=NMNP(I) + GO TO 107 + 104 CONTINUE +C +C Major ticks and labels are at numbers of the form (-) BASE * 10**EXMU. +C + 105 BASE=1. + NMNT=8 + GO TO 107 +C +C Major ticks and labels are at numbers of the form (-) BASE**EXMU. +C + 106 BASE=10. + NMNT=8 +C + 107 IF (BASD.EQ.SVAL(2)) BASD=BASE +C + 108 IF (QMND.NE.SVAL(1).AND.QMND.NE.SVAL(2)) NMNT=MAX0(0,NMND) + IF (QMND.EQ.SVAL(2)) QMND=FLOAT(NMNT) +C +C If the user wants nice values at the axis ends, reset UMIN and UMAX. +C + IF (NICE.NE.0) GO TO 115 +C + LOOP=0 +C + WMIN=VMIN + WMAX=VMAX +C + GO TO (109,110,112) , NBTP +C + 109 EMIN=VMIN/BASE+.5+SIGN(.5,VMIN-VMAX) + EMIN=EMIN-.5+SIGN(.5,EMIN)-SIGN(SMRL*EMIN,VMIN-VMAX) + WMIN=BASE*(EMIN-AMOD(EMIN,1.)) + EMAX=VMAX/BASE+.5+SIGN(.5,VMAX-VMIN) + EMAX=EMAX-.5+SIGN(.5,EMAX)-SIGN(SMRL*EMAX,VMAX-VMIN) + WMAX=BASE*(EMAX-AMOD(EMAX,1.)) + GO TO 114 +C + 110 IF (VMIN.EQ.0.) GO TO 111 + EMIN=ALOG10(ABS(VMIN)/BASE)+.5+SIGN(.5,VMIN*(VMIN-VMAX)) + EMIN=EMIN-.5+SIGN(.5,EMIN)-SIGN(SMRL*EMIN,VMIN*(VMIN-VMAX)) + WMIN=SIGN(BASE,VMIN)*10.**(EMIN-AMOD(EMIN,1.)) + 111 IF (VMAX.EQ.0.) GO TO 114 + EMAX=ALOG10(ABS(VMAX)/BASE)+.5+SIGN(.5,VMAX*(VMAX-VMIN)) + EMAX=EMAX-.5+SIGN(.5,EMAX)-SIGN(SMRL*EMAX,VMAX*(VMAX-VMIN)) + WMAX=SIGN(BASE,VMAX)*10.**(EMAX-AMOD(EMAX,1.)) + GO TO 114 +C + 112 IF (BASE.EQ.1.) GO TO 115 + IF (VMIN.EQ.0.) GO TO 113 + EMIN=ALOG10(ABS(VMIN))/ALOG10(BASE)+.5+SIGN(.5,VMIN*(VMIN-VMAX)) + EMIN=EMIN-.5+SIGN(.5,EMIN)-SIGN(SMRL*EMIN,VMIN*(VMIN-VMAX)) + WMIN=SIGN(1.,VMIN)*BASE**(EMIN-AMOD(EMIN,1.)) + 113 IF (VMAX.EQ.0.) GO TO 114 + EMAX=ALOG10(ABS(VMAX))/ALOG10(BASE)+.5+SIGN(.5,VMAX*(VMAX-VMIN)) + EMAX=EMAX-.5+SIGN(.5,EMAX)-SIGN(SMRL*EMAX,VMAX*(VMAX-VMIN)) + WMAX=SIGN(1.,VMAX)*BASE**(EMAX-AMOD(EMAX,1.)) +C +C Re-compute the user-coordinate-system minimum and maximum values. +C + 114 CALL AGUTOL (IAXS,FUNS,-1,WMIN,QMIN) + CALL AGUTOL (IAXS,FUNS,-1,WMAX,QMAX) +C +C Test for problems with nice values chosen. +C + IF (QMIN.LT.QMAX) GO TO 140 + IF (QMIN.GT.QMAX) GO TO 901 +C +C We have a pathological case - user values are clustered very close to +C a label position. See what can be done about it. +C + LOOP=LOOP+1 + IF (LOOP.GT.1) GO TO 901 +C + GO TO (137,138,139) , NBTP +C + 137 VMIN=VMIN+SIGN(BASE,VMIN-VMAX) + VMAX=VMAX+SIGN(BASE,VMAX-VMIN) + GO TO 109 +C + 138 VMIN=VMIN*10.**SIGN(1.,VMIN*(VMIN-VMAX)) + VMAX=VMAX*10.**SIGN(1.,VMAX*(VMAX-VMIN)) + GO TO 110 +C + 139 VMIN=VMIN*BASE**SIGN(1.,VMIN*(VMIN-VMAX)) + VMAX=VMAX*BASE**SIGN(1.,VMAX*(VMAX-VMIN)) + GO TO 112 +C + 140 VMIN=WMIN + VMAX=WMAX +C +C Now we examine the parameters defining the appearance of the numeric +C labels. If the numeric-label type is zero, there is no more to do. +C + 115 IF (QLTD.EQ.SVAL(1).OR.QLTD.EQ.SVAL(2)) GO TO 116 + NLTP=MAX0(0,MIN0(3,NLTD)) + IF (NLTP.EQ.0) GO TO 136 +C +C The numeric-label type (NLTP) is specified. If both the numeric-label +C exponent and numeric-label fraction-length are also specified, quit. +C + NLEX=NLED + NLFL=NLFD + IF (QLED.NE.SVAL(1).AND.QLED.NE.SVAL(2).AND. + + QLFD.NE.SVAL(1).AND.QLFD.NE.SVAL(2) ) GO TO 136 + GO TO 117 +C +C We must pick a value for the numeric-label type. Start with the dummy +C value 4 so as to jump to the proper piece of code. +C + 116 NLTP=4 +C +C Reduce the value of BASE to the form RBSE * 10**KBSE, where RBSE is +C in the range (1,10) and KBSE is an integer. +C + 117 FTMP=BASE + ASSIGN 118 TO JMP1 + GO TO 200 +C + 118 RBSE=FTMP + KBSE=ITMP +C +C Compute LBSE = the number of significant digits in RBSE. +C + ASSIGN 119 TO JMP2 + GO TO 300 +C + 119 LBSE=1+ITMP +C +C Jump depending on the value of the numeric-label type. +C + GO TO (120,128,131,132) , NLTP +C +C Scientific notation is to be used. Estimate the number of significant +C digits that are likely to be required, depending on the number type. +C + 120 GO TO (121,123,124) , NBTP +C + 121 FTMP=AMAX1(ABS(VMIN),ABS(VMAX))/BASE + ASSIGN 122 TO JMP1 + GO TO 200 +C + 122 NSIG=MAX0(1,ITMP+1+LBSE) + GO TO 125 +C + 123 NSIG=LBSE + GO TO 125 +C + 124 NSIG=10 +C +C NLEX + NLFL should be equal to NSIG. Make that the case. +C + 125 IF (QLED.NE.SVAL(1).AND.QLED.NE.SVAL(2)) GO TO 127 + IF (QLFD.EQ.SVAL(1).OR. QLFD.EQ.SVAL(2)) GO TO 126 + NLEX=NSIG-MAX0(0,NLFL) + GO TO 135 + 126 NLEX=1 + 127 NLFL=NSIG-NLEX + IF (NLFL.LE.0) NLFL=-1 + GO TO 135 +C +C Exponential notation is to be used. Compute the exponent NEXP such +C that BASE / 10**NEXP is an integer. +C + 128 NEXP=KBSE-LBSE+1 +C +C NLEX - NLFL should be equal to NEXP. Make that the case. (Note that, +C if NBTP is 3, NLEX is forced to zero.) +C + IF (NBTP.EQ.3) NLEX=0 +C + IF (QLFD.NE.SVAL(1).AND.QLFD.NE.SVAL(2)) GO TO 129 + IF (QLED.NE.SVAL(1).AND.QLED.NE.SVAL(2)) GO TO 130 + NLFL=-1 + 129 NLEX=MAX0(0,NLFL)+NEXP + GO TO 135 + 130 NLFL=NLEX-NEXP + IF (NLFL.LE.0) NLFL=-1 + GO TO 135 +C +C No-exponent notation is to be used. NLFL is the only parameter we +C need to worry about. If it is already set, quit. +C + 131 IF (QLFD.NE.SVAL(1).AND.QLFD.NE.SVAL(2)) GO TO 136 +C +C Set NLFL to the actual number of digits in the fractional portion of +C BASE. +C + NLFL=LBSE-KBSE-1 + IF (NLFL.LE.0) NLFL=-1 + GO TO 135 +C +C We must pick a value for the numeric-label type, depending on the +C number type. +C + 132 GO TO (133,134,134) , NBTP +C +C Nunbers are of the form (-) BASE * EXMU. Use labels with no exponent +C unless the use of an exponent would result in shorter labels. +C + 133 IF (MAX0(KBSE+1-LBSE,-KBSE-1).GT.4) GO TO 134 + NLTP=3 + NLFL=LBSE-KBSE-1 + IF (NLFL.LE.0) NLFL=-1 + GO TO 135 +C +C Exponential notation is used. +C + 134 NLTP=2 + NLEX=KBSE-LBSE+1 + NLFL=-1 +C +C Back-store the computed parameters, if requested, and return. +C + 135 IF (QLTD.EQ.SVAL(2)) QLTD=FLOAT(NLTP) + IF (QLED.EQ.SVAL(2)) QLED=FLOAT(NLEX) + IF (QLFD.EQ.SVAL(2)) QLFD=FLOAT(NLFL) +C +C Pack up integer values to floating-point arguments and return. +C + 136 QMNT=FLOAT(NMNT) + QLTP=FLOAT(NLTP) + QLEX=FLOAT(NLEX) + QLFL=FLOAT(NLFL) + RETURN +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C This internal procedure reduces the number (FTMP) to the range (1,10), +C returning (FTMP) and (ITMP) such that (FTMP) * 10**(ITMP) is equal to +C the original value of (FTMP). (FTMP) must be positive. +C + 200 FTM1=ALOG10(FTMP+SMRL*FTMP) + IF (FTM1.LT.0.) FTM1=FTM1-1. + ITMP=IFIX(FTM1) + FTMP=AMAX1(1.,FTMP*SNGL(10.D0**(-ITMP))) + GO TO JMP1 , (103,118,122) +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C This internal procedure counts the number of digits in the fractional +C portion of (FTMP), returning the count as the value of (ITMP). +C + 300 FTM1=AMOD(FTMP+SMRL*FTMP,1.) + FTM2=10.*SMRL*FTMP + ITMP=0 +C + 301 IF (FTM1.LT.FTM2) GO TO 302 + ITMP=ITMP+1 + IF (ITMP.GE.10) GO TO 302 + FTM1=AMOD(10.*FTM1,1.) + FTM2=10.*FTM2 + GO TO 301 +C + 302 GO TO JMP2 , (119) +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C Error exit. +C +C +NOAO - Comment out FTN write and format statement, SETER is okay. +C + 901 CONTINUE +C 901 WRITE (I1MACH(4),9001) IAXS + CALL SETER ('AGEXAX (CALLED BY AGSTUP) - USER-SYSTEM-TO-LABEL-SYST + +EM MAPPING IS NOT MONOTONIC',1,2) +C +C Formats. +C +C9001 FORMAT ('0PROBLEM WITH AXIS NUMBER',I2, +C + ' (1, 2, 3, AND 4 IMPLY LEFT, RIGHT, BOTTOM, AND TOP)') +C +C -NOAO + END diff --git a/sys/gio/ncarutil/autograph/agexus.f b/sys/gio/ncarutil/autograph/agexus.f new file mode 100644 index 00000000..7d4a274e --- /dev/null +++ b/sys/gio/ncarutil/autograph/agexus.f @@ -0,0 +1,89 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGEXUS (SVAL,ZMIN,ZMAX,ZLOW,ZHGH, + + ZDRA,NVIZ,IIVZ,NEVZ,IIEZ,UMIN,UMAX) +C + DIMENSION SVAL(2),ZDRA(1) +C +C The routine AGEXUS is used by AGSTUP to determine tentative values of +C the user-window edge coordinates. Its arguments are as follows: +C +C -- SVAL is the array of special values. +C +C -- ZMIN and ZMAX are user-supplied minimum and maximum values of the +C data x (or y) coordinates. +C +C -- ZLOW and ZHGH are, respectively, the smallest and largest data +C values to be considered in choosing the minimum and maximum, if +C those values, as given by the user, are null. +C +C -- ZDRA, NVIZ, IIVZ, NEVZ, and IIEZ specify the array of x (or y) +C data coordinates (see AGMAXI or AGMINI for complete description). +C +C -- UMIN and UMAX are returned with tentative minimum and maximum +C values for use at the appropriate user-window edges (left/right +C or bottom/top). +C +C The following common block contains AUTOGRAPH variables which are +C not control parameters. The only one used here is SMRL, which is a +C (machine-dependent) small real which, when added to a number in the +C range (1,10), will round it upward without seriously affecting the +C leading significant digits. The object of this is to get rid of +C strings of nines. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C Assume initially that the user has provided actual values to be used. +C + UMIN=ZMIN + UMAX=ZMAX +C +C If either of the values is null, replace it by a data-based value. +C + IF (UMIN.EQ.SVAL(1).OR.UMIN.EQ.SVAL(2)) + + UMIN=AGMINI(SVAL(1),ZLOW,ZDRA,NVIZ,IIVZ,NEVZ,IIEZ) + IF (UMAX.EQ.SVAL(1).OR.UMAX.EQ.SVAL(2)) + + UMAX=AGMAXI(SVAL(1),ZHGH,ZDRA,NVIZ,IIVZ,NEVZ,IIEZ) +C +C Either or both values might still be null (if the user data was null). +C + IF (UMIN.EQ.SVAL(1)) UMIN=UMAX + IF (UMAX.EQ.SVAL(1)) UMAX=UMIN +C +C Check the relative values of UMIN and UMAX for problems. +C + IF (ABS(UMIN-UMAX).LT.50.*SMRL*(ABS(UMIN)+ABS(UMAX))) GO TO 102 + IF (UMAX-UMIN) 101,102,103 + 101 IF (ZMIN.NE.SVAL(1).AND.ZMIN.NE.SVAL(2)) UMAX=UMIN + IF (ZMAX.NE.SVAL(1).AND.ZMAX.NE.SVAL(2)) UMIN=UMAX +C + 102 UMIN=UMIN-.5*ABS(UMIN) + UMAX=UMAX+.5*ABS(UMAX) + IF (UMIN.NE.UMAX) GO TO 103 + UMIN=-1. + UMAX=+1. +C +C If the user wanted these values back-stored, do it. +C + 103 IF (ZMIN.EQ.SVAL(2)) ZMIN=UMIN + IF (ZMAX.EQ.SVAL(2)) ZMAX=UMAX +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agezsu.f b/sys/gio/ncarutil/autograph/agezsu.f new file mode 100644 index 00000000..535e1811 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agezsu.f @@ -0,0 +1,104 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGEZSU (ITOC,XDRA,YDRA,IDXY,MANY,NPTS,LABG,IIVX,IIEX, + + IIVY,IIEY) +C + REAL XDRA(1),YDRA(1) + CHARACTER*(*) LABG +C +C The routine AGEZSU is used by the AUTOGRAPH routines EZY, EZXY, EZMY, +C EZMXY, and IDIOT to examine those parameters which are peculiar to the +C old version of AUTOGRAPH and to do the appropriate call to AGSTUP. +C The arguments are as follows: +C +C -- ITOC indicates which routine is calling AGEZSU, as follows: +C +C -- ITOC .EQ. 1 - call by EZY +C -- ITOC .EQ. 2 - call by EZXY +C -- ITOC .EQ. 3 - call by EZMY +C -- ITOC .EQ. 4 - call by EZMXY +C -- ITOC .EQ. 5 - call by IDIOT +C +C -- XDRA is an array of x-coordinate data. +C +C -- YDRA is an array of y-coordinate data. +C +C -- IDXY is the first dimension of YDRA. +C +C -- MANY is the number of curves defined by XDRA and YDRA. +C +C -- NPTS is the number of points per curve. +C +C -- LABG is a new header label (or the single character CHAR(0), if the +C header label is to be unchanged). +C +C -- IIVX, IIEX, IIVY, and IIEY are indexing controls for the x and y +C data arrays, computed and returned by AGEZSU for use in setting up +C calls to the routine AGCURV. +C +C Examine the frame-advance parameter. Do frame advance as appropriate. +C + CALL AGGETI ('FRAM.',IFRA) + IFRA=MAX0(1,MIN0(3,IFRA)) +C + IF (IFRA.EQ.3) CALL FRAME +C +C Set up the header label. +C + IF (ICHAR(LABG(1:1)).NE.0) THEN + CALL AGSETC ('LABE/NAME.', 'T') + CALL AGSETI ('LINE/NUMB.', 100) + CALL AGSETC ('LINE/TEXT.',LABG) + END IF +C +C Set up the AGSTUP arguments defining the coordinate-data arrays. +C + CALL AGGETI ('ROW .',IROW) + IROW=MAX0(-2,MIN0(+2,IROW)) +C + NVIY=MANY + IIVY=IDXY + NEVY=NPTS + IIEY=1 +C + IF (IROW.LE.0.AND.ITOC.GE.3.AND.ITOC.LE.4) THEN + IIVY=1 + IIEY=IDXY + END IF +C + NVIX=NVIY + IIVX=IIVY + NEVX=NEVY + IIEX=IIEY +C + IF (IABS(IROW).LE.1) THEN + NVIX=1 + IIVX=0 + NEVX=NPTS + IIEX=1 + END IF +C + IF (ITOC.EQ.1.OR.ITOC.EQ.3) IIEX=0 +C +C Do the AGSTUP call. +C + CALL AGSTUP (XDRA,NVIX,IIVX,NEVX,IIEX,YDRA,NVIY,IIVY,NEVY,IIEY) +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agfpbn.f b/sys/gio/ncarutil/autograph/agfpbn.f new file mode 100644 index 00000000..f4900b60 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agfpbn.f @@ -0,0 +1,37 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + INTEGER FUNCTION AGFPBN (FPDP) +C +C The value of AGFPBN(FPDP) is a binary dash pattern, obtained from the +C floating-point dash pattern FPDP. On machines having a word length +C greater than 16 bits, AGFPBN(FPDP) = IFIX(FPDP). On machines having +C a word length of 16 bits, this is not true. For example, when FPDP = +C 65535. (2 to the 16th minus 1), the equivalent binary dash pattern +C does not have the value 65535, but the value -1 (assuming integers +C are represented in a ones' complement format). So, the functions +C ISHIFT and IOR must be used to generate the dash pattern. +C + TEMP=FPDP + AGFPBN=0 +C + DO 101 I=1,16 + IF (AMOD(TEMP,2.).GE.1.) AGFPBN=IOR(AGFPBN,ISHIFT(1,I-1)) + TEMP=TEMP/2. + 101 CONTINUE +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agftol.f b/sys/gio/ncarutil/autograph/agftol.f new file mode 100644 index 00000000..b685f913 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agftol.f @@ -0,0 +1,119 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGFTOL (IAXS,IDMA,VINP,VOTP,VLCS,LLUA,UBEG,UDIF,FUNS, + + NBTP,SBSE) +C +C The routine AGFTOL is used by AGAXIS to map a fractional distance +C along the axis to a value in the label coordinate system or vice- +C versa. Its arguments are as follows: +C +C -- IAXS specifies which axis is being drawn. It is passed to the +C routine AGUTOL. See AGAXIS for a complete description of IAXS. +C +C -- IDMA specifies the direction of the mapping - from the fractional +C system to the label system if IDMA .GT. 0 or from the label system +C to the fractional system if IDMA .LT. 0. IDMA also specifies how +C the label-system value is given to or returned by AGFTOL. +C +C -- If ABSV(IDMA) .EQ. 1, an actual value in the label coordinate +C system (VLCS) is given to or returned by AGFTOL. +C +C -- If ABSV(IDMA) .NE. 1, a value of the exponent/multiplier EXMU +C corresponding to VLCS is given to or returned by AGFTOL. +C +C -- VINP is an input value in one coordinate system. +C +C -- VOTP is an output value in the other coordinate system. +C +C -- VLCS is an output value in the label coordinate system, returned +C no matter what the value of IDMA. +C +C -- LLUA, UBGA, and UDFA specify the mapping from the user coordinate +C system to the fractional system and vice-versa. See the routine +C AGAXIS for a complete description of these parameters. +C +C -- FUNS is a function-selector, to be used in calls to AGUTOL. It +C selects the mapping from the user coordinate system to the label +C coordinate system and vice-versa. See the routine AGAXIS for a +C complete description of this parameter. +C +C -- NBTP and SBSE specify the mapping of label-coordinate-system values +C to exponent/multiplier values and vice-versa. See the routine +C AGNUMB for a complete dexcription of these parameters. +C +C Determine desired direction of mapping. +C + IF (IDMA.GT.0) THEN +C +C Map axis fraction VINP to a label-coordinate-system value VLCS. +C + VUCS=UBEG+VINP*UDIF + IF (LLUA.NE.0) VUCS=10.**VUCS + CALL AGUTOL (IAXS,FUNS,1,VUCS,VLCS) +C +C If IDMA .EQ. 1, caller wants VLCS - otherwise, map VLCS to the +C appropriate exponent/multiplier value EXMU - return value in VOTP. +C + IF (IDMA.EQ.1) THEN + VOTP=VLCS + RETURN + END IF +C + GO TO (101,102,103) , NBTP +C + 101 VOTP=VLCS/SBSE + RETURN +C + 102 VOTP=ALOG10(VLCS/SBSE) + RETURN +C + 103 VOTP=ALOG10(ABS(VLCS))/ALOG10(ABS(SBSE)) + RETURN +C + ELSE +C +C If IDMA .EQ. -1, caller has provided VINP .EQ. VLCS, a value in the +C label coordinate system - otherwise, VINP .EQ. EXMU, the exponent/ +C multiplier needed to generate VLCS. +C + IF (IDMA.EQ.(-1)) THEN + VLCS=VINP + GO TO 107 + END IF +C + GO TO (104,105,106) , NBTP +C + 104 VLCS=SBSE*VINP + GO TO 107 +C + 105 VLCS=SBSE*10.**VINP + GO TO 107 +C + 106 VLCS=SIGN(1.,SBSE)*ABS(SBSE)**VINP +C +C Map label-system value VLCS to a user-system value VUCS. +C + 107 CALL AGUTOL (IAXS,FUNS,-1,VLCS,VUCS) +C +C Map user-system value VUCS to an axis fraction VOTP and return. +C + IF (LLUA.NE.0) VUCS=ALOG10(VUCS) + VOTP=(VUCS-UBEG)/UDIF + RETURN +C + END IF +C + END diff --git a/sys/gio/ncarutil/autograph/aggetc.f b/sys/gio/ncarutil/autograph/aggetc.f new file mode 100644 index 00000000..caf9f357 --- /dev/null +++ b/sys/gio/ncarutil/autograph/aggetc.f @@ -0,0 +1,51 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGGETC (TPID,CUSR) +C + CHARACTER*(*) TPID,CUSR +C + DIMENSION FURA(1) +C +C The routine AGGETC is used to get the character strings represented +C by the values of certain individual AUTOGRAPH parameters. TPID is a +C parameter identifier (from the caller). CUSR is a character string +C (returned to the caller). +C +C See what kind of parameter is being gotten. +C + CALL AGCTCS (TPID,ITCS) +C +C If the parameter is not intrinsically of type character, log an error. +C + IF (ITCS.EQ.0) GO TO 901 +C +C Otherwise, get the integer value of the parameter and use that to get +C the desired character string. +C + CALL AGGETP (TPID,FURA,1) + CALL AGGTCH (IFIX(FURA(1)),CUSR,LNCS) +C +C Done. +C + RETURN +C +C Error exit. +C + 901 CALL AGPPID (TPID) + CALL SETER ('AGGETC - PARAMETER TO GET IS NOT INTRINSICALLY OF TYP + +E CHARACTER',2,2) +C + END diff --git a/sys/gio/ncarutil/autograph/aggetf.f b/sys/gio/ncarutil/autograph/aggetf.f new file mode 100644 index 00000000..6391222b --- /dev/null +++ b/sys/gio/ncarutil/autograph/aggetf.f @@ -0,0 +1,28 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGGETF (TPID,FUSR) +C + CHARACTER*(*) TPID + DIMENSION FURA(1) +C +C The routine AGGETF may be used to get the real (floating-point) value +C of any single AUTOGRAPH control parameter. +C + CALL AGGETP (TPID,FURA,1) + FUSR=FURA(1) + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/aggeti.f b/sys/gio/ncarutil/autograph/aggeti.f new file mode 100644 index 00000000..31841826 --- /dev/null +++ b/sys/gio/ncarutil/autograph/aggeti.f @@ -0,0 +1,28 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGGETI (TPID,IUSR) +C + CHARACTER*(*) TPID + DIMENSION FURA(1) +C +C The routine AGGETI may be used to get the integer-equivalent value of +C any single AUTOGRAPH control parameter. +C + CALL AGGETP (TPID,FURA,1) + IUSR=IFIX(FURA(1)) + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/aggetp.f b/sys/gio/ncarutil/autograph/aggetp.f new file mode 100644 index 00000000..ac44085e --- /dev/null +++ b/sys/gio/ncarutil/autograph/aggetp.f @@ -0,0 +1,104 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGGETP (TPID,FURA,LURA) +C + CHARACTER*(*) TPID + DIMENSION FURA(1) +C +C The routine AGGETP returns to the user the AUTOGRAPH parameter(s) +C specified by the parameter identifier TPID. The arguments are as +C follows: +C +C -- TPID is the parameter identifier, a string of keywords separated +C from each other by slashes and followed by a period. +C +C -- FURA is the user array which is to receive the desired parameter(s) +C specified by TPID. +C +C -- LURA is the length of the user array FURA. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C Define the array DUMI, which allows access to the parameter list as +C an array. +C + DIMENSION DUMI(1) + EQUIVALENCE (QFRA,DUMI) +C +C If initialization has not yet been done, do it. +C + IF (INIF.EQ.0) THEN + CALL AGINIT + END IF +C +C The routine AGSCAN is called to scan the parameter identifier and to +C return three quantities describing the AUTOGRAPH parameters desired. +C + CALL AGSCAN (TPID,LOPA,NIPA,IIPA) +C +C Determine the number of elements to transfer. +C + NURA=MAX0(1,MIN0(LURA,NIPA)) +C +C Transfer the desired parameters to the user array. +C + IDMI=LOPA-IIPA +C + DO 101 IURA=1,NURA + IDMI=IDMI+IIPA + FURA(IURA)=DUMI(IDMI) + 101 CONTINUE +C +C If the current label name is being gotten, return its identifier. +C + CALL AGSCAN ('LABE/NAME.',LOLN,NILN,IILN) + IF (LOPA.EQ.LOLN.AND.NIPA.EQ.NILN.AND.QBAN.NE.0.) THEN + LBAN=IFIX(QBAN) + FURA(1)=FLLB(1,LBAN) + END IF +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/aggtch.f b/sys/gio/ncarutil/autograph/aggtch.f new file mode 100644 index 00000000..7591c670 --- /dev/null +++ b/sys/gio/ncarutil/autograph/aggtch.f @@ -0,0 +1,78 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGGTCH (IDCS,CHST,LNCS) +C + CHARACTER*(*) CHST +C +C This routine gets character strings previously stored by the routine +C AGSTCH (which see). It has the following arguments: +C +C -- IDCS is the identifying integer returned by AGSTCH when the string +C was stored. +C +C -- CHST is the character string returned. +C +C -- LNCS is the length of the character string returned in CHST. +C +C The following common blocks contain variables which are required for +C the character-storage-and-retrieval scheme of AUTOGRAPH. +C + COMMON /AGCHR1/ LNIC,INCH(2,50),LNCA,INCA +C + COMMON /AGCHR2/ CHRA(2000) +C + CHARACTER*1 CHRA +C +C First, blank-fill the character variable to be returned. +C + CHST=' ' +C +C If the identifier is less than -LNIC, the (one-character) string is +C retrieved from it. +C + IF (IDCS.LT.(-LNIC)) THEN + CHST=CHAR(-IDCS-LNIC-1) + LNCS=1 +C +C If the identifier is between -LNIC and -1, its absolute value is the +C index, in INCH, of the descriptor of the character string stored in +C CHRA. +C + ELSE IF (IDCS.LE.(-1)) THEN + I=-IDCS + J=INCH(1,I)-1 + IF (J.GE.0) THEN + LNCS=MIN0(LEN(CHST),INCH(2,I)) + DO 101 K=1,LNCS + J=J+1 + CHST(K:K)=CHRA(J) + 101 CONTINUE + ELSE + LNCS=0 + END IF +C +C In all other cases, return a single blank. +C + ELSE + LNCS=1 +C + END IF +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/aginit.f b/sys/gio/ncarutil/autograph/aginit.f new file mode 100644 index 00000000..e863e01f --- /dev/null +++ b/sys/gio/ncarutil/autograph/aginit.f @@ -0,0 +1,113 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGINIT +C +C This routine is called to initialize some machine-dependent constants. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C Fill in the names of the four pre-defined labels. +C + CALL AGSTCH ('L',1,IDCS) + FLLB(1,1)=FLOAT(IDCS) + CALL AGSTCH ('R',1,IDCS) + FLLB(1,2)=FLOAT(IDCS) + CALL AGSTCH ('B',1,IDCS) + FLLB(1,3)=FLOAT(IDCS) + CALL AGSTCH ('T',1,IDCS) + FLLB(1,4)=FLOAT(IDCS) +C +C Declare the rest of the label-definition slots to be available. +C + LBIM=IFIX(QBIM) +C + DO 101 J=5,LBIM + FLLB(1,J)=0. + 101 CONTINUE +C +C Fill in the text of the four pre-defined lines. +C + CALL AGSTCH ('Y',1,IDCS) + FLLN(4,1)=FLOAT(IDCS) + CALL AGSTCH (' ',1,IDCS) + FLLN(4,2)=FLOAT(IDCS) + CALL AGSTCH ('X',1,IDCS) + FLLN(4,3)=FLOAT(IDCS) + CALL AGSTCH (' ',1,IDCS) + FLLN(4,4)=FLOAT(IDCS) +C +C Declare the rest of the line-definition slots to be available. +C + LNIM=IFIX(QNIM) +C + DO 102 J=5,LNIM + FLLN(1,J)=SVAL(1) + 102 CONTINUE +C +C Set the value of 'LINE/TERMINATOR.' +C + CALL AGSTCH ('$',1,IDCS) + TCLN=FLOAT(IDCS) +C +C SMRL is used by AUTOGRAPH for rounding operations. +C + SMRL=10.**(3-IFIX(ALOG10(FLOAT(I1MACH(10)))*FLOAT(I1MACH(11)))) +C +C ISLD is an integer containing 16 one bits (right-justified with zero +C fill to the left). It is used to direct the DASHCHAR package to draw +C solid lines. To generate it, we start with a 15-bit mask and then +C add another bit. +C + ISLD = 32767 + ISLD = ISHIFT(ISLD,1) + ISLD = IOR(ISLD,1) +C +C Set the initialization flag to indicate initialization has been done. +C + INIF=1 +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agkurv.f b/sys/gio/ncarutil/autograph/agkurv.f new file mode 100644 index 00000000..d93f0659 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agkurv.f @@ -0,0 +1,145 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGKURV (XVEC,IIEX,YVEC,IIEY,NEXY,SVAL) +C + DIMENSION XVEC(1),YVEC(1) +C +C AGKURV plots the curve defined by the points ((X(I),Y(I)),I=1,NEXY), +C where +C +C X(I)=XVEC(1+(I-1)*IIEX) (unless IIEX=0, in which case X(I)=I), and +C Y(I)=YVEC(1+(I-1)*IIEY) (unless IIEY=0, in which case Y(I)=I). +C +C If, for some I, X(I)=SVAL or Y(I)=SVAL, curve line segments having +C (X(I),Y(I)) as an endpoint are omitted. +C +C No windowing is performed. +C +C Check first whether the number of curve points is properly specified. +C + IF (NEXY.LE.0) GO TO 901 +C +C Initialization. Pretend that the last point was point number zero. +C Set the indices for the x and y vectors accordingly. Clear the line- +C drawn-to-last-point flag. +C + INDP=0 + INDX=1-IIEX + INDY=1-IIEY + LDLP=0 +C +C Initialization. Retrieve the current curve window, user window, and +C x/y linear/logarithmic flags. +C + CALL GETSET (XLCW,XRCW,YBCW,YTCW,XLUW,XRUW,YBUW,YTUW,LTYP) +C +C Initialization. Set linear/log flag and linear-window limits for +C x-axis values. +C + IF (LTYP.EQ.1.OR.LTYP.EQ.2) THEN + LLUX=0 + XLLW=XLUW + XRLW=XRUW + ELSE + LLUX=1 + XLLW=ALOG10(XLUW) + XRLW=ALOG10(XRUW) + END IF +C +C Initialization. Set linear/log flag and linear-window limits for +C y-axis values. +C + IF (LTYP.EQ.1.OR.LTYP.EQ.3) THEN + LLUY=0 + YBLW=YBUW + YTLW=YTUW + ELSE + LLUY=1 + YBLW=ALOG10(YBUW) + YTLW=ALOG10(YTUW) + END IF +C +C Initialization. Call SET, if necessary, to define a linear mapping. +C + IF (LTYP.NE.1) + + CALL SET (XLCW,XRCW,YBCW,YTCW,XLLW,XRLW,YBLW,YTLW,1) +C +C Beginning of loop through points. Update indices and determine the +C user-space coordinates of the next point. +C + 101 IF (INDP.EQ.NEXY) GO TO 102 + INDP=INDP+1 +C + INDX=INDX+IIEX + XNXT=XVEC(INDX) + IF (IIEX.EQ.0) XNXT=FLOAT(INDP) + IF (LLUX.NE.0.AND.XNXT.LE.0.) XNXT=SVAL +C + INDY=INDY+IIEY + YNXT=YVEC(INDY) + IF (IIEY.EQ.0) YNXT=FLOAT(INDP) + IF (LLUY.NE.0.AND.YNXT.LE.0.) YNXT=SVAL +C +C Check whether (XNXT,YNXT) is a special-value point. Handle that case. +C + IF (XNXT.EQ.SVAL.OR.YNXT.EQ.SVAL) THEN + IF (LDLP.EQ.0) GO TO 101 + IF (LDLP.EQ.1) CALL VECTD (XLST,YLST) + CALL LASTD + LDLP=0 + GO TO 101 + END IF +C +C If user space is not linear/linear, modify XNXT and YNXT accordingly. +C + IF (LLUX.NE.0) XNXT=ALOG10(XNXT) + IF (LLUY.NE.0) YNXT=ALOG10(YNXT) +C +C Start or continue line. +C + IF (LDLP.EQ.0) THEN + CALL FRSTD (XNXT,YNXT) + XLST=XNXT + YLST=YNXT + ELSE + CALL VECTD (XNXT,YNXT) + END IF +C + LDLP=LDLP+1 + GO TO 101 +C +C Last point was final point. Finish up. +C + 102 IF (LDLP.NE.0) THEN + IF (LDLP.EQ.1) CALL VECTD (XLST,YLST) + CALL LASTD + END IF +C +C Restore logarithmic mapping, if appropriate. +C + IF (LTYP.NE.1) + + CALL SET (XLCW,XRCW,YBCW,YTCW,XLUW,XRUW,YBUW,YTUW,LTYP) +C +C Return to caller. +C + RETURN +C +C Error exit. +C + 901 CALL SETER ('AGKURV - NUMBER OF POINTS IS LESS THAN OR EQUAL TO ZE + +RO',3,2) +C + END diff --git a/sys/gio/ncarutil/autograph/aglbls.f b/sys/gio/ncarutil/autograph/aglbls.f new file mode 100644 index 00000000..d99b038d --- /dev/null +++ b/sys/gio/ncarutil/autograph/aglbls.f @@ -0,0 +1,616 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGLBLS (ITST,WCWP,HCWP,FLLB,LBIM,FLLN,DBOX,SBOX,RBOX) +C + DIMENSION FLLB(10,8),FLLN(6,16),DBOX(6,4),SBOX(6,4),RBOX(6) +C +C The routine AGLBLS is used (if ITST .LE. 0) to predict the amount of +C space which will be required for graph labels (excluding the numeric +C labels on the axes, which are handled by AGAXIS) or (if ITST .GT. 0) +C to actually draw the graph labels. +C +C The labels in question are defined by the label list (FLLB array) and +C the line list (FLLN array). Each label is assumed to lie in one of +C five boxes, as follows: +C +C Box 1 is to the left of the curve window. +C Box 2 is to the right of the curve window. +C Box 3 is below the curve window. +C Box 4 is above the curve window. +C Box 5 is the curve window itself. +C Box 6 is the entire plot (graph) window. +C +C A test run of AGLBLS returns two sets of box dimensions to the caller. +C DBOX contains the dimensions required if all labels are to have their +C desired sizes, SBOX the dimensions required if all labels are to have +C their smallest sizes. The caller is expected to use this information +C to determine a final set of box dimensions (stored in DBOX), and then +C call AGLBLS again to actually draw the labels in those boxes. +C +C The arguments of AGLBLS are as follows: +C +C -- ITST specifies whether the call is a test call (ITST .LE. 0) or a +C real call (ITST .GT. 0). If ABSV(ITST) .GT. 1, AGLBLS is allowed +C to shrink the labels if they would not otherwise fit in their box. +C If ABSV(ITST) .EQ. 1, shrinkage of labels is prohibited. If ITST +C .EQ. 0, labels are suppressed. +C +C -- WCWP and HCWP are the width and height of the curve window, in +C plotter-coordinate-system units. AGLBLS assumes that the last call +C to the plot package routine "SET" had arguments XLCW, XRCW, YBCW, +C YTCW, 0., 1., 0., 1., and 1 - defining the most convenient system +C of coordinates for it. +C +C -- FLLB is the array in which the label list is stored. The array is +C doubly-dimensioned. The first subscript specifies one of ten label +C attributes, the second a particular label. The attributes are as +C follows (the name ILLB(M,N) refers to a label attribute which is +C intrinsically an integer, despite being stored as a real): +C +C -- ILLB(1,N) specifies the name of label N. If ILLB(1,N) is zero, +C no label is defined. Otherwise, ILLB(1,N) is an identifier +C returned by AGSTCH when the name of the label (a character +C string) was stored away. +C +C -- ILLB(2,N) may be set non-zero to suppress label N. +C +C -- FLLB(3,N) and FLLB(4,N) are the x and y coordinates of a base- +C point relative to which label N is positioned, as fractions of +C the width and height, respectively, of the curve window. The +C position of the base-point determines the box in which label N +C is considered to lie. +C +C -- FLLB(5,N) and FLLB(6,N) are small offsets (typically about the +C size of a character width), stated as fractions of the smaller +C side of the curve window. They are used to offset the label +C base-point (after the box number is determined). Typically, +C this provides a minimum spacing between the label and one side +C of the curve window. +C +C -- ILLB(7,N) is the orientation angle of the label, in degrees +C counter-clockwise from horizontal. The base-line for label N +C is a vector emanating from the base-point at this angle. The +C specified angle must be a multiple of 90 degrees. +C +C -- ILLB(8,N) is the centering option for the label. It specifies +C how each line of the label is to be positioned relative to a +C line perpendicular to the base-line at the base-point. +C +C -- If ILLB(8,N) .LT. 0, the left edge of each line lies on +C the perpendicular. +C +C -- If ILLB(8,N) .EQ. 0, the center of each line lies on the +C perpendicular. +C +C -- If ILLB(8,N) .GT. 0, the right edge of each line lies on +C the perpendicular. +C +C -- ILLB(9,N) is the number of lines in label N. +C +C -- ILLB(10,N) is the second subscript (in the line list) of the +C first line of label N. +C +C -- LBIM is the maximum number of labels the label list will hold. +C +C -- FLLN is the array in which the line list is stored. The array is +C doubly-dimensioned. The first subscript specifies one of six line +C attributes, the second a particular line. The attributes are as +C follows (the name ILLN(M,N) refers to a line attribute which is +C intrinsically an integer, despite being stored as a real): +C +C -- ILLN(1,N) is the position number of line N. The lines of a +C label are ordered according to their position numbers, the one +C having the largest position number being top-most. Moreover, +C lines having position numbers .GT. 0 are placed above the label +C base-line, those having position numbers .EQ. 0 (of which there +C should be but one) are placed on the label base-line, and those +C having position numbers .LT. 0 are placed below the label base- +C line. The magnitudes of the position numbers have nothing to +C do with inter-line spacing - that is up to AGLBLS to determine. +C +C -- ILLN(2,N) may be set non-zero to suppress line N. +C +C -- FLLN(3,N) is the desired width of characters in the line, as a +C fraction of the smaller side of the curve window. +C +C -- ILLN(4,N) is the identifier of the character string comprising +C the text of the line, as returned by AGSTCH at the time the +C string was stored. +C +C -- ILLN(5,N) is the number of characters in the line. +C +C -- ILLN(6,N) is the index of the next line of the label. The +C lines of a label must be ordered by position number (largest +C to smallest). +C +C -- DBOX and SBOX, dimensioned 6 X 4, contain box dimensions, as dis- +C cussed above. D/SBOX(M,N) is the Nth edge-coordinate of box M, +C where N .EQ. 1 for the left edge, 2 for the right edge, 3 for the +C bottom edge, and 4 for the top edge, of the box. The first two are +C stated as fractions of the width, the second two as fractions of +C the height, of the curve window. +C +C RBOX, dimensioned 6, holds reduction factors for the sizes of the +C characters in labels in each of the six boxes. Each RBOX(M) is +C +C -- negative to specify smallest-size characters, or +C +C -- zero to specify that no reduction factor has been chosen, or +C +C -- positive, between 0. and 1. (an actual reduction factor). +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. The only one of +C interest here is MWCL, which is the minimum usable character width, +C in plotter units. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C The following common block contains other AUTOGRAPH variables, of type +C character. +C + COMMON /AGOCHP/ CHS1,CHS2 +C +c+noao +c CHARACTER*504 CHS1,CHS2 + CHARACTER*500 CHS1,CHS2 +c-noao +C +C HCFW(WDTH) specifies the height of a character as a function of width. +C + HCFW(WDTH)=2.*WDTH +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C This is the main section of AGLBLS. +C +C Compute the length of the smallest side of the curve window. +C + SCWP=AMIN1(WCWP,HCWP) +C +C Preset certain jumps in the internal procedure which follows. +C + ASSIGN 211 TO JMP1 + ASSIGN 216 TO JMP2 + ASSIGN 221 TO JMP3 +C +C Jump if this is a test run. +C + IF (ITST.LE.0) GO TO 101 +C +C This is not a test run. If the reduction factors for the six boxes +C are already set, jump directly to the plotting section; otherwise, we +C must first compute the coordinates of the six smallest-size boxes. +C + IF (RBOX(1).NE.0.) GO TO 115 + GO TO 105 +C +C This is a test run. Compute the coordinates of the edges of the six +C desired-size boxes. +C + 101 RWCL=1. + NBOX=0 + ASSIGN 102 TO JMP4 + GO TO 200 +C + 102 DBOX(NBOX,1)=XLBX + DBOX(NBOX,2)=XRBX + DBOX(NBOX,3)=YBBX + DBOX(NBOX,4)=YTBX +C + IF (NBOX.LT.6) GO TO 200 +C +C This is a test run. Compute the coordinates of the edges of the six +C smallest-size boxes, in one of two ways. +C + IF (IABS(ITST).GT.1) GO TO 105 +C +C This is a test run. Determine smallest-size boxes (no shrinking). +C + DO 104 J=1,4 + DO 103 I=1,6 + SBOX(I,J)=DBOX(I,J) + 103 CONTINUE + 104 CONTINUE + RETURN +C +C Determine smallest-size boxes (shrinking allowed). +C + 105 RWCL=0. + NBOX=0 + ASSIGN 106 TO JMP4 + GO TO 200 +C + 106 SBOX(NBOX,1)=XLBX + SBOX(NBOX,2)=XRBX + SBOX(NBOX,3)=YBBX + SBOX(NBOX,4)=YTBX +C + IF (NBOX.LT.6) GO TO 200 +C +C If this is not a test run, jump to compute reduction factors for each +C of the six boxes and then plot the labels. Otherwise, return. +C + IF (ITST.GT.0) GO TO 107 + RETURN +C +C This is not a test run. Compute reduction factors for each of the +C six boxes. +C + 107 NBOX=1 + ASSIGN 110 TO JMP4 +C +C (DBOX(NBOX,I),I=1,4) specifies the box in which the labels are to be +C drawn, (SBOX(NBOX,I),I=1,4) the minimum box in which they can be drawn +C if shrunk. Check first whether the latter is contained in the former. +C If so, we have a chance. If not, the best we can do is shrink the +C labels to minimum size and hope for the best. +C + 108 IF (SBOX(NBOX,1).LT.SBOX(NBOX,2).AND. + + DBOX(NBOX,1)-SBOX(NBOX,1).LT..0001.AND. + + SBOX(NBOX,2)-DBOX(NBOX,2).LT..0001.AND. + + DBOX(NBOX,3)-SBOX(NBOX,3).LT..0001.AND. + + SBOX(NBOX,4)-DBOX(NBOX,4).LT..0001 ) GO TO 109 +C + RBOX(NBOX)=-1. + GO TO 114 +C +C Mimimum-size labels will fit. Find the largest value of RBOX(NBOX) +C for which the labels will fit. +C + 109 RWCL=1. + DWCL=.5 + SWCL=0. + GO TO 201 +C +C See if the last value of RBOX(NBOX) gave us labels which would fit or +C not and adjust the value accordingly. +C + 110 IF (DBOX(NBOX,1)-XLBX.LT..0001.AND. + + XRBX-DBOX(NBOX,2).LT..0001.AND. + + DBOX(NBOX,3)-YBBX.LT..0001.AND. + + YTBX-DBOX(NBOX,4).LT..0001 ) GO TO 111 +C +C Labels did not fit. Adjust RBOX(NBOX) downward. +C + RWCL=RWCL-DWCL + DWCL=.5*DWCL + IF (DWCL.LT..001) RWCL=SWCL + GO TO 201 +C +C Labels did fit. Adjust RBOX(NBOX) upward, unless it is equal to 1. +C + 111 IF (RWCL.EQ.1.) GO TO 113 + SWCL=RWCL + RWCL=RWCL+DWCL + DWCL=.5*DWCL + IF (DWCL.GT..001) GO TO 201 +C +C The current value of RBOX(NBOX) is acceptable. Do next box, if any. +C + 113 IF (NBOX.GE.5) GO TO 114 +C +C Return updated box-edge coordinates for boxes 1 through 4. +C + DBOX(NBOX,1)=XLBX + DBOX(NBOX,2)=XRBX + DBOX(NBOX,3)=YBBX + DBOX(NBOX,4)=YTBX +C + 114 NBOX=NBOX+1 + IF (NBOX.LE.6) GO TO 108 +C +C We have done all we can to make the labels fit. Plot them now. +C + 115 NBOX=0 + LBIN=0 + ASSIGN 117 TO JMP3 + ASSIGN 120 TO JMP4 +C +C Get a label to chew on. +C + 116 ASSIGN 211 TO JMP1 + ASSIGN 216 TO JMP2 + GO TO 202 +C +C We have a label. Initialize the re-loop through the lines in it. +C + 117 XPLN=XPLB-DTLB*YDLB/WCWP + YPLN=YPLB+DTLB*XDLB/HCWP + PHCL=0. + LNIN=LNII + ASSIGN 118 TO JMP1 + ASSIGN 116 TO JMP2 + GO TO 210 +C +C Get ready to plot the label line. +C + 118 XPLN=XPLN+.5*(PHCL+FHCL)*YDLB/WCWP + YPLN=YPLN-.5*(PHCL+FHCL)*XDLB/HCWP + PHCL=FHCL + CALL AGGTCH (IFIX(FLLN(4,LNIN)),CHS2,LNC2) +C +C Give the user a chance to change the appearance of the label line. +C + CALL AGCHIL (0,CHS1(1:LNC1),IFIX(FLLN(1,LNIN))) +C +C Plot the label line. +C + CALL AGPWRT (XPLN,YPLN,CHS2,LNC2,IWCL,LBOR,LBCN) +C +C Give the user a chance to undo the changes he made above. +C + CALL AGCHIL (1,CHS1(1:LNC1),IFIX(FLLN(1,LNIN))) +C +C Go get the next line, if any. +C + GO TO 215 +C +C All labels are drawn. Return. +C + 120 RETURN +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C +C This internal procedure, which may be entered and exited in a number +C of different ways, is used to scan the label list and the line list +C and to return information about the labels and lines defined there. +C +C Entry occurs here to bump the box number, store away a reduction +C factor for the sizes of labels in that box, and then compute the edge +C coordinates of the box required to hold labels of the size implied by +C that reduction factor. +C + 200 NBOX=NBOX+1 +C +C Entry occurs here to do all of the above except the bumping of the box +C number. +C + 201 RBOX(NBOX)=RWCL +C +C Initialize the label-list index and the box-edge parameters. +C + LBIN=0 + XLBX=+1000. + XRBX=-1000. + YBBX=+1000. + YTBX=-1000. + IF (ITST.EQ.0) GO TO 222 +C +C This is the beginning of the loop through the labels. Entry occurs +C here to find the next label in the list and return positioning info. +C +C Increment the label index and test for end of label list. +C + 202 LBIN=LBIN+1 + IF (LBIN.GT.LBIM) GO TO 222 +C +C Skip this label if it is non-existent, suppressed, or empty. +C + IF (FLLB(1,LBIN).EQ.0..OR.FLLB(2,LBIN).NE.0. + + .OR.FLLB(9,LBIN).EQ.0.) GO TO 202 +C +C Unpack the parameters specifying the label-base-point position. +C + XBLB=FLLB(3,LBIN) + YBLB=FLLB(4,LBIN) + XOLB=FLLB(5,LBIN) + YOLB=FLLB(6,LBIN) +C +C Determine in which of five boxes the label lies: +C +C in the box to the left of the curve window. +C + LBBX=1 + IF (XBLB.EQ.0..AND.XOLB.LE.0.) GO TO 203 +C +C in the box to the right of the curve window, +C + LBBX=2 + IF (XBLB.EQ.1..AND.XOLB.GE.0.) GO TO 203 +C +C in the box below the curve window, +C + LBBX=3 + IF (YBLB.EQ.0..AND.YOLB.LE.0.) GO TO 203 +C +C in the box above the curve window, +C + LBBX=4 + IF (YBLB.EQ.1..AND.YOLB.GE.0.) GO TO 203 +C +C in the curve window, +C + LBBX=5 + IF ( (XBLB.EQ.0..AND.XOLB.GT.0.).OR. + + (XBLB.EQ.1..AND.XOLB.LT.0.).OR. + + (YBLB.EQ.0..AND.YOLB.GT.0.).OR. + + (YBLB.EQ.1..AND.YOLB.LT.0.) ) GO TO 203 +C +C or elsewhere. +C + LBBX=6 +C +C If we are interested in a particular box and this label is not in that +C box, skip it. +C + 203 IF (NBOX.NE.0.AND.LBBX.NE.NBOX) GO TO 202 +C +C On a non-test run, get the label name and length for call to AGCHIL. +C + IF (ITST.GT.0) CALL AGGTCH (IFIX(FLLB(1,LBIN)),CHS1,LNC1) +C +C Unpack the label orientation and compute its direction cosines. +C + LBOR=IFIX(FLLB(7,LBIN)) +C + XDLB=COS(.017453292519943*FLLB(7,LBIN)) + YDLB=SIN(.017453292519943*FLLB(7,LBIN)) +C +C Unpack the label-centering option. +C + LBCN=IFIX(FLLB(8,LBIN)) +C +C Unpack the index of the initial line of the label and save it. +C + LNIN=IFIX(FLLB(10,LBIN)) + LNII=LNIN +C +C If this is not a test run, modify the label-base-point position as +C needed to move the label into the actual box in which it must fit. +C + IF (ITST.LE.0) GO TO 209 +C + GO TO (204,205,206,207,208,209) , LBBX +C + 204 XBLB=XBLB+DBOX(1,2) + GO TO 209 +C + 205 XBLB=XBLB+DBOX(2,1)-1. + GO TO 209 +C + 206 YBLB=YBLB+DBOX(3,4) + GO TO 209 +C + 207 YBLB=YBLB+DBOX(4,3)-1. + GO TO 209 +C + 208 IF (XBLB.EQ.0.) XBLB=XBLB+DBOX(5,1) + IF (XBLB.EQ.1.) XBLB=XBLB+DBOX(5,2)-1. + IF (YBLB.EQ.0.) YBLB=YBLB+DBOX(5,3) + IF (YBLB.EQ.1.) YBLB=YBLB+DBOX(5,4)-1. +C +C Compute the final label-base-point position. +C + 209 XPLB=XBLB+XOLB*SCWP/WCWP + YPLB=YBLB+YOLB*SCWP/HCWP +C +C Before entering the loop through the line list, initialize the label- +C dimension parameters. +C + DLLB=0. + DRLB=0. + DBLB=0. + DTLB=0. +C +C This is the beginning of the loop through the lines in a given label. +C Entry may occur here to find the next line and return info about it. +C +C If the line is suppressed or of zero length, skip it. +C + 210 IF (FLLN(2,LNIN).NE.0..OR.FLLN(5,LNIN).LE.0.) GO TO 215 +C +C Unpack the position-number, character-width, and character-count +C parameters for the line. +C + LNPN=IFIX(FLLN(1,LNIN)) + WCLN=FLLN(3,LNIN) + LNCC=IFIX(FLLN(5,LNIN)) +C +C Compute the integer width (IWCL) and the floating-point width and +C height (FWCL and FHCL) of characters in the label. All are expressed +C in plotter-coordinate-system units. +C + IWCL=MAX0(MWCL,IFIX(RBOX(LBBX)*WCLN*SCWP+.5)) + FWCL=FLOAT(IWCL) + FHCL=HCFW(FWCL) +C +C Jump back with line information or drop through, as directed. +C + GO TO JMP1 , (118,211) +C +C Update the label-dimension parameters. +C + 211 DRLB=AMAX1(DRLB,FLOAT(LNCC)*FWCL) +C + IF (LNPN) 212,213,214 +C + 212 DBLB=DBLB+FHCL + GO TO 215 +C + 213 DBLB=DBLB+.5*FHCL + DTLB=DTLB+.5*FHCL + GO TO 215 +C + 214 DTLB=DTLB+FHCL +C +C Go to the next line in the label, if there is one. +C + 215 LNIN=IFIX(FLLN(6,LNIN)) + IF (LNIN.NE.0) GO TO 210 +C +C Jump back on end of lines or drop through, as directed. +C + GO TO JMP2 , (116,216) +C +C If all the lines in the label were either suppressed or of zero +C length, skip this label. +C + 216 IF (DRLB.EQ.0.) GO TO 202 +C +C Complete the computation of the label dimensions. The four parameters +C DLLB, DRLB, DBLB, and DTLB represent the distances from the base-point +C to the left edge, right edge, bottom edge, and top edge of the label, +C in plotter-coordinate-system units, where left, right, etc., are as +C viewed by a reader of the label. +C + IF (LBCN) 217,218,219 +C +C Left edges of lines are aligned. +C + 217 GO TO 220 +C +C Centers of lines are aligned. +C + 218 DLLB=.5*(DLLB+DRLB) + DRLB=DLLB + GO TO 220 +C +C Right edges of lines are aligned. +C + 219 SWAP=DLLB + DLLB=DRLB + DRLB=SWAP +C +C Jump back with label information or drop through, as directed. +C + 220 GO TO JMP3 , (117,221) +C +C Update the x and y coordinates of the label box edges. +C + 221 XLBX=AMIN1(XLBX,XBLB, + + XPLB-AMAX1(+DLLB*XDLB,-DRLB*XDLB,-DBLB*YDLB,+DTLB*YDLB)/WCWP) + XRBX=AMAX1(XRBX,XBLB, + + XPLB+AMAX1(-DLLB*XDLB,+DRLB*XDLB,+DBLB*YDLB,-DTLB*YDLB)/WCWP) + YBBX=AMIN1(YBBX,YBLB, + + YPLB-AMAX1(+DLLB*YDLB,-DRLB*YDLB,+DBLB*XDLB,-DTLB*XDLB)/HCWP) + YTBX=AMAX1(YTBX,YBLB, + + YPLB+AMAX1(-DLLB*YDLB,+DRLB*YDLB,-DBLB*XDLB,+DTLB*XDLB)/HCWP) +C +C Go back for the next label. +C + GO TO 202 +C +C End of label list. Jump as directed. +C + 222 GO TO JMP4 , (102,106,110,120) +C +C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* +C + END diff --git a/sys/gio/ncarutil/autograph/agmaxi.f b/sys/gio/ncarutil/autograph/agmaxi.f new file mode 100644 index 00000000..9c981e0d --- /dev/null +++ b/sys/gio/ncarutil/autograph/agmaxi.f @@ -0,0 +1,60 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + FUNCTION AGMAXI (SVAL,ZHGH,ZDRA,NVIZ,IIVZ,NEVZ,IIEZ) +C + DIMENSION ZDRA(1) +C +C The routine AGMAXI returns the maximum value of the elements in ZDRA +C specified by NVIZ, IIVZ, NEVZ, and IIEZ, skipping elements having the +C special value SVAL (or more than ZHGH, if ZHGH is not equal to SVAL). +C +C -- NVIZ is the number of vectors of data stored in ZDRA. +C +C -- IIVZ is the index increment from one data vector to the next. +C +C -- NEVZ is the number of elements per vector to be examined. +C +C -- IIEZ is the index increment from one vector element to the next. +C If IIEZ is 0, the array is ignored and NEVZ is returned. +C + AGMAXI=FLOAT(NEVZ) + IF (IIEZ.EQ.0) RETURN +C + AGMAXI=SVAL + INDZ=1-IIEZ +C + DO 103 I=1,NVIZ + IF (ZHGH.EQ.SVAL) THEN + DO 101 J=1,NEVZ + INDZ=INDZ+IIEZ + IF (ZDRA(INDZ).EQ.SVAL) GO TO 101 + IF (AGMAXI.EQ.SVAL) AGMAXI=ZDRA(INDZ) + AGMAXI=AMAX1(AGMAXI,ZDRA(INDZ)) + 101 CONTINUE + ELSE + DO 102 J=1,NEVZ + INDZ=INDZ+IIEZ + IF (ZDRA(INDZ).EQ.SVAL.OR.ZDRA(INDZ).GT.ZHGH) GO TO 102 + IF (AGMAXI.EQ.SVAL) AGMAXI=ZDRA(INDZ) + AGMAXI=AMAX1(AGMAXI,ZDRA(INDZ)) + 102 CONTINUE + END IF + INDZ=INDZ-NEVZ*IIEZ+IIVZ + 103 CONTINUE +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agmini.f b/sys/gio/ncarutil/autograph/agmini.f new file mode 100644 index 00000000..be4b6d2c --- /dev/null +++ b/sys/gio/ncarutil/autograph/agmini.f @@ -0,0 +1,60 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + FUNCTION AGMINI (SVAL,ZLOW,ZDRA,NVIZ,IIVZ,NEVZ,IIEZ) +C + DIMENSION ZDRA(1) +C +C The routine AGMINI returns the mimimum value of the elements in ZDRA +C specified by NVIZ, IIVZ, NEVZ, and IIEZ, skipping elements having the +C special value SVAL (or less than ZLOW, if ZLOW is not equal to SVAL). +C +C -- NVIZ is the number of vectors of data stored in ZDRA. +C +C -- IIVZ is the index increment from one data vector to the next. +C +C -- NEVZ is the number of elements per vector to be examined. +C +C -- IIEZ is the index increment from one vector element to the next. +C If IIEZ is 0, the array is ignored and 1. is returned. +C + AGMINI=1. + IF (IIEZ.EQ.0) RETURN +C + AGMINI=SVAL + INDZ=1-IIEZ +C + DO 103 I=1,NVIZ + IF (ZLOW.EQ.SVAL) THEN + DO 101 J=1,NEVZ + INDZ=INDZ+IIEZ + IF (ZDRA(INDZ).EQ.SVAL) GO TO 101 + IF (AGMINI.EQ.SVAL) AGMINI=ZDRA(INDZ) + AGMINI=AMIN1(AGMINI,ZDRA(INDZ)) + 101 CONTINUE + ELSE + DO 102 J=1,NEVZ + INDZ=INDZ+IIEZ + IF (ZDRA(INDZ).EQ.SVAL.OR.ZDRA(INDZ).LT.ZLOW) GO TO 102 + IF (AGMINI.EQ.SVAL) AGMINI=ZDRA(INDZ) + AGMINI=AMIN1(AGMINI,ZDRA(INDZ)) + 102 CONTINUE + END IF + INDZ=INDZ-NEVZ*IIEZ+IIVZ + 103 CONTINUE +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agnumb.f b/sys/gio/ncarutil/autograph/agnumb.f new file mode 100644 index 00000000..24469772 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agnumb.f @@ -0,0 +1,491 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGNUMB (NBTP,SBSE,EXMU , NLTP,NLEX,NLFL , + + BFRM,MCIM,NCIM,IPXM , BFRE,MCIE,NCIE) +C + CHARACTER*(*) BFRM,BFRE +C +C The routine AGNUMB converts the number specified by the arguments +C NBTP, SBSE, and EXMU to the label format specified by the arguments +C NLTP, NLEX, and NLFL, returning the characters of the mantissa in the +C buffer BFRM and the characters of the exponent in the buffer BFRE, +C ready for plotting. The arguments of AGNUMB are as follows: +C +C -- NBTP is an integer specifying the type of number to be converted. +C There are three possibilities: +C +C NBTP = 1 - number of the form SBSE * EXMU. +C +C NBTP = 2 - number of the form SBSE * 10**EXMU. +C +C NBTP = 3 - number of the form SIGN(SBSE) * ABSV(SBSE)**EXMU. +C +C -- SBSE is a base value for a set of labels. See NBTP description. +C +C -- EXMU is an exponent or a multiplier for a given label. Although it +C is a floating-point number, its value should be integral, unless +C NBTP equals 1 and/or NLTP equals 1. Using a non-integral EXMU in +C other cases will have undesirable effects. See NBTP description. +C +C -- NLTP is an integer specifying the type of label to be generated. +C There are three possibilities: +C +C -- NLTP = 1 - label is to have an exponent portion and is to be +C expressed in scientific notation. +C +C -- NLTP = 2 - label is to have an exponent portion and is to be +C expressed in a form determined by the number type NBTP. +C +C -- NLTP = 3 - label is to have no exponent portion and is to be +C expressed in a form determined by the number type NBTP. +C +C The possible label types will be described in greater detail below. +C +C -- NLEX (when used) is an integer specifying (in a manner depending on +C the values of other parameters) the value of the exponent portion +C of the label. See the detailed discussion of label types, below. +C +C -- NLFL (when used) is an integer specifying (in a manner depending on +C the values of other parameters) the length of the fractional por- +C tion of the mantissa of the label. See the detailed discussion of +C label types, below. +C +C -- BFRM is a character variable in which the mantissa portion of the +C label is to be returned. +C +C -- MCIM specifies the maximum number of characters BFRM can hold. +C +C -- NCIM is the number of characters returned in BFRM by AGNUMB. +C +C -- IPXM is the position of the character X in the mantissa. If IPXM +C is zero, the character X does not occur in the mantissa. +C +C -- BFRE, MCIE, and NCIE are analogous to BFRM, MCIM, and NCIM, but +C pertain to the exponent portion of the label. +C +C Label types: AGNUMB will produce many different types of labels, as +C directed by the various input parameters. Each of these is described +C below. The general form of a label is +C +C (-) (1/) (I) (.) (F) (X 10) (E) +C +C where the parentheses are used to mark portions which may either be +C present or absent. The minus sign is included only if the label value +C is negative. I is the integer portion of the mantissa, included only +C if its value is non-zero. The decimal point is included if the input +C parameter NLFL does not specifically direct that it should be omitted +C or if the fractional portion of the mantissa (F) is present. F is the +C fractional portion of the mantissa. The "X 10" is included if it is +C appropriate, and is considered to be a part of the mantissa; if it is +C included, a blank is actually returned for the character X, so the +C routine which plots the label should construct this character by +C drawing two short lines. E is the exponent, returned in a separate +C buffer so that it may be plotted in a superscript form. The possible +C label types are, then, as follows: +C +C -- Scientific notation - if the label type NLTP equals 1, the form +C +C (-) (I) (.) (F) X 10 (E) +C +C is used. NLEX specifies the length of I (thus also specifying the +C value of the exponent E). If NLEX is .LE. 0, I is omitted. If +C NLEX is .LT. 0 and has the absolute value N, the fraction F is +C forced to have N leading zeroes. NLFL specifies the length of F. +C If NLFL is .LE. 0, F is omitted. If NLFL is .LT. 0, the decimal +C point is omitted. If (I.F) has the value 1, (I.F X) is omitted. +C If the entire label has zero value, the character 0 is used. +C +C -- Exponential, but non-scientific notation - if the label type NLTP +C equals 2, the form used depends on the argument NBTP, as follows: +C +C -- If NBTP equals 1 (number of the form SBSE * EXMU), the form +C +C (-) (I) (.) (F) X 10 (E) +C +C is used. NLEX specifies the value of the exponent E. The +C length of F is specified by NLFL. If NLFL is .LE. 0, F is +C omitted. If NLFL is .LT. 0, the decimal point is omitted. If +C the label value is exactly 0, the character 0 is used. +C +C -- If NBTP equals 2 (number of the form SBSE*10**EXMU), the form +C +C (-) (I) (.) (F) X 10 (E) +C +C is used. The exponent E has the value NLEX+EXMU. The length +C of F is specified by NLFL. If NLFL is .LE. 0, F is omitted. +C If NLFL is .LT. 0, the decimal point is omitted. If the label +C value is exactly 0, the character 0 is used. If (I.F) has the +C value 1., then (I.F X) is omitted. +C +C -- If NBTP equals 3, specifying that the number is of the form +C SIGN(SBSE) * ABSV(SBSE)**EXMU, the form +C +C (-) (I) (.) (F) (E) +C +C is used. The exponent E has the value EXMU. The length of F +C is specified by NLFL. If NLFL is .LE. 0, F is omitted. If +C NLFL is .LT. 0, the decimal point is omitted. +C +C -- No-exponent notation - if the label type NLTP equals 3, the form +C used depends on the argument NBTP, as follows: +C +C -- If NBTP equals 1 (number of the form SBSE * EXMU), the form +C +C (-) (I) (.) (F) +C +C is used. NLFL specifies the length of F. If NLFL is .LE. 0, +C F is omitted. If NLFL is .LT. 0, the decimal point is omitted. +C If the entire label has zero value, the character 0 is used. +C +C -- If NBTP equals 2 (number of the form SBSE*10**EXMU), the form +C +C (-) (I) (.) (F) +C +C is used. The length of F is specified by the function +C +C MAX(NLFL,0)-EXMU (if EXMU is .LT. MAX(NLFL,0)) +C MIN(NLFL,0) (if EXMU is .GE. MAX(NLFL,0)) +C +C which may appear somewhat formidable, but produces a simple, +C desirable result. Suppose, for example, that SBSE = 3.6, +C NLFL = 1, and EXMU ranges from -3 to +3 - the labels produced +C are as follows: +C +C .0036 .036 .36 3.6 36. 360. 3600. +C +C NLFL may be viewed as specifying the length of F if EXMU is 0. +C If the value of the function is .LE. 0, F is omitted - if its +C value is .LT. 0, the decimal point is omitted. +C +C -- If NBTP equals 3, specifying that the number is of the form +C SIGN(SBSE) * ABSV(SBSE)**EXMU, the form +C +C (-) (I) (.) (F) +C +C is used if EXMU is positive (or zero), and the form +C +C (-) 1 / (I) (.) (F) +C +C is used if EXMU is negative. The length of F is specified by +C the function +C +C NLFL * ABSV(EXMU) (if EXMU is .NE. 0) +C MIN(NLFL,0) (if EXMU is .EQ. 0) +C +C Again, this function produces a simple result. Suppose that +C SBSE = 1.1, NLFL = 1, and EXMU ranges from -3 to +3 - the +C labels produced are as follows: +C +C 1/1.331 1/1.21 1/1.1 1. 1.1 1.21 1.331 +C +C NLFL may be viewed as specifying the length of F if EXMU is 1. +C If the value of the function is .LE. 0, F is omitted - if its +C value is .LT. 0, the decimal point is omitted. As another +C example, suppose that SBSE = 2., NLFL = -1, and EXMU ranges +C from -4 to +4. The labels produced are as follows: +C +C 1/16 1/8 1/4 1/2 1 2 4 8 16 +C +C The following common block contains AUTOGRAPH variables which are +C not control parameters. The only one used here is SMRL, which is a +C (machine-dependent) small real which, when added to a number in the +C range (1,10), will round it upward without seriously affecting the +C leading significant digits. The object of this is to get rid of +C strings of nines. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C KHAR holds single characters to be stored away in BFRM or BFRE. +C + CHARACTER*1 KHAR +C +C Zero character counters and pointers. +C + NCIM=0 + NCIE=0 + IPXM=0 +C +C Compute a jump parameter to allow a quick sorting-out of the possible +C number-type/label-type combinations below. +C + NTLT=NBTP+3*(NLTP-1) +C +C Compute the value (XMAN) from which the characters of the mantissa +C will be generated. +C + GO TO (101,102,103,101,102,104,101,102,105) , NTLT +C + 101 XMAN=SBSE*EXMU + GO TO 106 +C + 102 XMAN=SBSE*SNGL(10.D0**DBLE(EXMU)) + GO TO 106 +C + 103 XMAN=SIGN(1.,SBSE)*SNGL(DBLE(ABS(SBSE))**DBLE(EXMU)) + GO TO 106 +C + 104 XMAN=SBSE + GO TO 106 +C + 105 XMAN=SIGN(1.,SBSE)*SNGL(DBLE(ABS(SBSE))**DBLE(ABS(EXMU))) +C +C If the mantissa-generator is negative, make it positive and put a +C minus sign in the mantissa buffer. +C + 106 IF (XMAN.LT.0.) THEN + NCIM=NCIM+1 + IF (NCIM.GT.MCIM) GO TO 901 + BFRM(NCIM:NCIM)='-' + XMAN=-XMAN + END IF +C +C If the number is zero, put a zero in the mantissa buffer and quit. +C + IF (XMAN.EQ.0.) THEN + NCIM=NCIM+1 + IF (NCIM.GT.MCIM) GO TO 901 + BFRM(NCIM:NCIM)='0' + RETURN + END IF +C +C Reduce the mantissa-generator to the range (1.,10.), keeping track of +C the power of 10 required to do it. Round the result, keeping in mind +C that the rounding may kick the value past 10. . +C + IMAN=IFIX(ALOG10(XMAN)) + IF (XMAN.LT.1.) IMAN=IMAN-1 + XMAN=XMAN*SNGL(10.D0**(-IMAN))+SMRL + IF (XMAN.GE.10.) THEN + XMAN=XMAN/10. + IMAN=IMAN+1 + END IF +C +C Jump (depending on the number-type/label-type combination) to set up +C the label-generation control parameters, as follows: +C +C NDPD - number of digits to precede decimal point - if NDPD .LT. 0, +C ABS(NDPD) leading zeroes follow the decimal point, preceding +C the first digit generated from XMAN. +C NDFD - number of digits to follow decimal point - if NDFD .LT. 0, +C the decimal point is suppressed. +C IF10 - flag, set non-zero to force generation of the (X 10) portion +C of the label. +C IFEX - flag, set non-zero to force generation of an exponent. +C IVEX - value of exponent (if any) - always equals (IMAN+1) - NDPD. +C + GO TO (107,107,107,108,109,110,111,112,113) , NTLT +C +C Scientific notation. +C + 107 NDPD=NLEX + NDFD=NLFL + IF10=1 + IFEX=1 + GO TO 114 +C +C Non-scientific exponential notation for SBSE * EXMU. +C + 108 NDPD=IMAN+1-NLEX + NDFD=NLFL + IF10=1 + IFEX=1 + GO TO 114 +C +C Non-scientific exponential notation for SBSE * 10**EXMU. +C + 109 NDPD=IMAN+1-(NLEX+IFIX(EXMU+SMRL*EXMU)) + NDFD=NLFL + IF10=1 + IFEX=1 + GO TO 114 +C +C Non-scientific exponential notation for SIGN(SBSE) * ABSV(SBSE)**EXMU. +C + 110 NDPD=IMAN+1 + IMAN=IMAN+IFIX(EXMU+SMRL*EXMU) + NDFD=NLFL + IF10=0 + IFEX=1 + GO TO 115 +C +C No-exponent notation for SBSE * EXMU. +C + 111 NDPD=IMAN+1 + NDFD=NLFL + IF10=0 + IFEX=0 + GO TO 115 +C +C No-exponent notation for SBSE * 10**EXMU. +C + 112 NDPD=IMAN+1 + NDFD=MAX0(NLFL,0)-IFIX(EXMU+SMRL*EXMU) + IF (NDFD.LE.0) NDFD=MIN0(NLFL,0) + IF10=0 + IFEX=0 + GO TO 115 +C +C No-exponent notation for SIGN(SBSE) * ABSV(SBSE)**EXMU +C + 113 IF (EXMU.LT.0.) THEN + NCIM=NCIM+1 + IF (NCIM.GT.MCIM) GO TO 901 + BFRM(NCIM:NCIM)='1' + NCIM=NCIM+1 + IF (NCIM.GT.MCIM) GO TO 901 + BFRM(NCIM:NCIM)='/' + END IF +C + NDPD=IMAN+1 + NDFD=NLFL*IFIX(ABS(EXMU+SMRL*EXMU)) + IF (NDFD.EQ.0) NDFD=MIN0(NLFL,0) + IF10=0 + IFEX=0 + GO TO 115 +C +C If there is an exponent of 10 and the mantissa is precisely 1, omit +C the (I.F X) portion of the mantissa. +C + 114 IF (NDPD.NE.1) GO TO 115 + IF (IFIX(XMAN).NE.1) GO TO 115 + IF (((XMAN-1.)*10.**MAX0(0,NDFD)).GE.1.) GO TO 115 + IVEX=IMAN+1-NDPD + GO TO 123 +C +C Generate the characters of the mantissa (I.F). Check first for zero- +C or-negative-length error. +C + 115 LMAN=MAX0(NDPD,0)+1+MAX0(NDFD,-1) + IF (LMAN.LE.0) GO TO 903 +C +C Make sure the mantissa buffer is big enough to hold (I.F). +C + IF (NCIM+LMAN.GT.MCIM) GO TO 901 +C +C Compute the value of the parameter IVEX before changing NDPD. +C + IVEX=IMAN+1-NDPD +C +C Generate the digits preceding the decimal point, if any. +C + IF (NDPD.LE.0) GO TO 117 +C + ASSIGN 116 TO JUMP + GO TO 121 +C + 116 NDPD=NDPD-1 + IF (NDPD.NE.0) GO TO 121 +C +C Generate the decimal point. +C + 117 KHAR='.' + ASSIGN 118 TO JUMP + GO TO 122 +C +C Generate leading zeroes, if any, after the decimal point. +C + 118 IF (NDPD.EQ.0) GO TO 120 + KHAR='0' + ASSIGN 119 TO JUMP + GO TO 122 +C + 119 NDPD=NDPD+1 + IF (NDPD.NE.0) GO TO 122 +C +C Generate remaining fractional digits. +C + 120 ASSIGN 121 TO JUMP +C +C Generate a digit from the mantissa-generator. It is assumed that, for +C n between 1 and 9, ICHAR('n') = ICHAR('n-1') + 1 . +C + 121 IDGT=IFIX(XMAN) + KHAR=CHAR(ICHAR('0')+IDGT) + XMAN=XMAN-FLOAT(IDGT) + XMAN=XMAN*10. +C +C Store a digit from KHAR into the mantissa buffer. +C + 122 NCIM=NCIM+1 + BFRM(NCIM:NCIM)=KHAR +C +C Check whether (I.F) is complete. +C + LMAN=LMAN-1 + IF (LMAN.NE.0) GO TO JUMP , (116,118,119,121) +C +C If appropriate, leave space in the mantissa buffer for the "X" . +C + IF (IF10.EQ.0) GO TO 124 + NCIM=NCIM+1 + IF (NCIM.GT.MCIM) GO TO 901 + IPXM=NCIM + BFRM(IPXM:IPXM)=' ' +C +C If appropriate, put a "10" in the mantissa buffer. +C + 123 NCIM=NCIM+1 + IF (NCIM.GT.MCIM) GO TO 901 + BFRM(NCIM:NCIM)='1' + NCIM=NCIM+1 + IF (NCIM.GT.MCIM) GO TO 901 + BFRM(NCIM:NCIM)='0' +C +C If appropriate, generate an exponent in the exponent buffer. +C + 124 IF (IFEX.EQ.0) RETURN +C + IF (IVEX) 126,125,127 +C + 125 NCIE=NCIE+1 + IF (NCIE.GT.MCIE) GO TO 902 + BFRE(NCIE:NCIE)='0' + RETURN +C + 126 NCIE=NCIE+1 + IF (NCIE.GT.MCIE) GO TO 902 + BFRE(NCIE:NCIE)='-' + IVEX=-IVEX +C + 127 NCIE=NCIE+1 + IF (IVEX.GE.10) NCIE=NCIE+1 + IF (IVEX.GE.100) NCIE=NCIE+1 + IF (IVEX.GE.1000) NCIE=NCIE+1 + IF (NCIE.GT.MCIE) GO TO 902 +C + DO 128 I=1,4 + J=NCIE+1-I + BFRE(J:J)=CHAR(ICHAR('0')+MOD(IVEX,10)) + IVEX=IVEX/10 + IF (IVEX.EQ.0) RETURN + 128 CONTINUE +C + IF (IVEX.NE.0) GO TO 902 +C +C Done. +C + RETURN +C +C Error exits. +C + 901 CALL SETER ('AGNUMB - MANTISSA TOO LONG',4,2) +C + 902 CALL SETER ('AGNUMB - EXPONENT TOO LARGE',5,2) +C + 903 CALL SETER ('AGNUMB - ZERO-LENGTH MANTISSA',6,2) +C + END diff --git a/sys/gio/ncarutil/autograph/agppid.f b/sys/gio/ncarutil/autograph/agppid.f new file mode 100644 index 00000000..145d98d3 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agppid.f @@ -0,0 +1,65 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGPPID (TPID) +C + CHARACTER*(*) TPID +C +C The object of this routine is to print out a parameter identifier +C which has caused some kind of problem. +C +C Define a character variable to hold the print line. +C + CHARACTER*124 TEMP +C +C +NOAO + integer*2 itemp(124) +C -NOAO +C +C Set up the print line. +C + TEMP='0PARAMETER IDENTIFIER - ' +C +C Transfer characters of the parameter identifier, one at a time, until +C 100 have been transferred or a period is encountered, whichever occurs +C first. This is done so as to allow for old programs on the Cray which +C used Hollerith strings as parameter identifiers. +C + I=24 +C + DO 101 J=1,100 + I=I+1 + TEMP(I:I)=TPID(J:J) + IF (TEMP(I:I).EQ.'.') GO TO 102 + 101 CONTINUE +C +C Print the line. +C +C +NOAO - replace FTN write and format statement. +C 102 WRITE (I1MACH(4),1001) TEMP + 102 CONTINUE + call f77upk (temp, itemp, 125) + call pstr (itemp) +C +C Done. +C + RETURN +C +C Format. +C +C1001 FORMAT (A124) +C -NOAO +C + END diff --git a/sys/gio/ncarutil/autograph/agpwrt.f b/sys/gio/ncarutil/autograph/agpwrt.f new file mode 100644 index 00000000..25cc2e52 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agpwrt.f @@ -0,0 +1,31 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGPWRT (XPOS,YPOS,CHRS,NCHS,ISIZ,IORI,ICEN) +C + CHARACTER*(*) CHRS +C +C This routine just passes its arguments along to the character-drawing +C routine PWRIT, in the system plot package. By substituting his/her +C own version of AGPWRT, the user can cause a fancier character-drawer +C to be used. +C + CALL PWRIT (XPOS,YPOS,CHRS,NCHS,ISIZ,IORI,ICEN) +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agqurv.f b/sys/gio/ncarutil/autograph/agqurv.f new file mode 100644 index 00000000..dc70fc43 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agqurv.f @@ -0,0 +1,322 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGQURV (XVEC,IIEX,YVEC,IIEY,NEXY,SVAL) +C + DIMENSION XVEC(1),YVEC(1) +C +C AGQURV plots the curve defined by the points ((X(I),Y(I)),I=1,NEXY), +C where +C +C X(I)=XVEC(1+(I-1)*IIEX) (unless IIEX=0, in which case X(I)=I), and +C Y(I)=YVEC(1+(I-1)*IIEY) (unless IIEY=0, in which case Y(I)=I). +C +C If, for some I, X(I)=SVAL or Y(I)=SVAL, curve line segments having +C (X(I),Y(I)) as an endpoint are omitted. +C +C The curve drawn is windowed. Portions of the curve which would fall +C outside the current curve window, as defined by the last SET call, +C are not drawn. +C +C Check first whether the number of curve points is properly specified. +C + IF (NEXY.LE.0) GO TO 901 +C +C Initialization. Pretend that the last point was point number zero. +C Set the indices for the x and y vectors accordingly. Clear the line- +C drawn-to-last-point and last-point-outside-window flags. +C + INDP=0 + INDX=1-IIEX + INDY=1-IIEY + LDLP=0 + LPOW=0 +C +C Initialization. Retrieve the current curve window, user window, and +C x/y linear/logarithmic flags. +C + CALL GETSET (XLCW,XRCW,YBCW,YTCW,XLUW,XRUW,YBUW,YTUW,LTYP) +C +C Initialization. Set linear/log flag and linear-window limits for +C x-axis values. +C + IF (LTYP.EQ.1.OR.LTYP.EQ.2) THEN + LLUX=0 + XLLW=XLUW + XRLW=XRUW + ELSE + LLUX=1 + XLLW=ALOG10(XLUW) + XRLW=ALOG10(XRUW) + END IF +C +C Initialization. Set linear/log flag and linear-window limits for +C y-axis values. +C + IF (LTYP.EQ.1.OR.LTYP.EQ.3) THEN + LLUY=0 + YBLW=YBUW + YTLW=YTUW + ELSE + LLUY=1 + YBLW=ALOG10(YBUW) + YTLW=ALOG10(YTUW) + END IF +C +C Initialization. Call SET, if necessary, to define a linear mapping. +C (This greatly simplifies the windowing code.) +C + IF (LTYP.NE.1) + + CALL SET (XLCW,XRCW,YBCW,YTCW,XLLW,XRLW,YBLW,YTLW,1) +C +C Initialization. Compute mimimum and maximum values of x which are +C slightly outside the linear window. (Note: XLLW and XRLW will not +C be used after this.) +C + IF (XLLW.GT.XRLW) THEN + TEMP=XLLW + XLLW=XRLW + XRLW=TEMP + END IF + XEPS=.000001*(XRLW-XLLW) + XMIN=XLLW-XEPS + XMAX=XRLW+XEPS +C +C Initialization. Compute minimum and maximum values of y which are +C slightly outside the linear window. (Note: YBLW and YTLW will not +C be used after this.) +C + IF (YBLW.GT.YTLW) THEN + TEMP=YBLW + YBLW=YTLW + YTLW=TEMP + END IF + YEPS=.000001*(YTLW-YBLW) + YMIN=YBLW-YEPS + YMAX=YTLW+YEPS +C +C Beginning of loop through points. Update indices and determine the +C user-space coordinates of the next point. +C + 101 IF (INDP.EQ.NEXY) GO TO 120 + INDP=INDP+1 +C + INDX=INDX+IIEX + XNXT=XVEC(INDX) + IF (IIEX.EQ.0) XNXT=FLOAT(INDP) + IF (LLUX.NE.0.AND.XNXT.LE.0.) XNXT=SVAL +C + INDY=INDY+IIEY + YNXT=YVEC(INDY) + IF (IIEY.EQ.0) YNXT=FLOAT(INDP) + IF (LLUY.NE.0.AND.YNXT.LE.0.) YNXT=SVAL +C +C Check whether (XNXT,YNXT) is a special-value point. Handle that case. +C + IF (XNXT.EQ.SVAL.OR.YNXT.EQ.SVAL) THEN + LPOW=0 + IF (LDLP.EQ.0) GO TO 101 + IF (LDLP.EQ.1) CALL VECTD (XLST,YLST) + CALL LASTD + LDLP=0 + GO TO 101 + END IF +C +C If user space is not linear/linear, modify XNXT and YNXT accordingly. +C + IF (LLUX.NE.0) XNXT=ALOG10(XNXT) + IF (LLUY.NE.0) YNXT=ALOG10(YNXT) +C +C Set the next-point-outside-window flag to a value between -4 and +4, +C inclusive. A non-zero value indicates that the next point is outside +C the window and indicates which of eight possible areas it falls in. +C + NPOW=IFIX(3.*(SIGN(.51,XNXT-XMIN)+SIGN(.51,XNXT-XMAX))+ + + (SIGN(.51,YNXT-YMIN)+SIGN(.51,YNXT-YMAX))) +C +C There are now various possible cases, depending on whether the line- +C drawn-to-last-point flag is set or not, whether the next point is in +C the window or not, and whether the last point was in the window, not +C in the window, or non-existent (point 0 or a special-value point). +C + IF (LDLP.EQ.0) GO TO 102 + IF (NPOW.NE.0) GO TO 103 +C +C Line drawn to last point, next point inside, last point inside. +C + CALL VECTD (XNXT,YNXT) + LDLP=LDLP+1 + GO TO 119 +C + 102 IF (NPOW.NE.0) GO TO 109 + IF (LPOW.NE.0) GO TO 105 +C +C No line drawn to last point, next point inside, no last point. +C + CALL FRSTD (XNXT,YNXT) + LDLP=1 + GO TO 119 +C +C Line drawn to last point, next point outside, last point inside. +C + 103 XPIW=XLST + YPIW=YLST + XPOW=XNXT + YPOW=YNXT + ASSIGN 104 TO JUMP + GO TO 107 + 104 CALL VECTD (XPEW,YPEW) + CALL LASTD + LDLP=0 + GO TO 119 +C +C No line drawn to last point, next point inside, last point outside. +C + 105 XPIW=XNXT + YPIW=YNXT + XPOW=XLST + YPOW=YLST + ASSIGN 106 TO JUMP + GO TO 107 + 106 CALL FRSTD (XPEW,YPEW) + CALL VECTD (XNXT,YNXT) + LDLP=2 + GO TO 119 +C +C The following local procedure, given a point (XPIW,YPIW) inside the +C window and a point (XPOW,YPOW) outside the window, finds the point of +C intersection (XPEW,YPEW) of a line joining them with the window edge. +C + 107 XPEW=XPIW + YPEW=YPIW + XDIF=XPOW-XPIW + YDIF=YPOW-YPIW +C + IF (ABS(XDIF).GT.XEPS) THEN + XPEW=XMIN + IF (XDIF.GE.0.) XPEW=XMAX + YPEW=YPIW+(XPEW-XPIW)*YDIF/XDIF + IF (YPEW.GE.YMIN.AND.YPEW.LE.YMAX) GO TO 108 + END IF +C + IF (ABS(YDIF).GT.YEPS) THEN + YPEW=YMIN + IF (YDIF.GE.0.) YPEW=YMAX + XPEW=XPIW+(YPEW-YPIW)*XDIF/YDIF + END IF +C + 108 GO TO JUMP , (104,106) +C +C No line drawn to last point, next point outside. Jump if no last +C point. +C + 109 IF (LPOW.EQ.0) GO TO 119 +C +C No line drawn to last point, next point outside, last point outside. +C Check whether a portion of the line joining them lies in the window. +C + MPOW=9*LPOW+NPOW+41 +C + GO TO (119,119,119,119,119,110,119,110,110, + + 119,119,119,111,119,110,111,110,110, + + 119,119,119,111,119,119,111,111,119, + + 119,113,113,119,119,110,119,110,110, + + 119,119,119,119,119,119,119,119,119, + + 112,112,119,112,119,119,111,111,119, + + 119,113,113,119,119,113,119,119,119, + + 112,112,113,112,119,113,119,119,119, + + 112,112,119,112,119,119,119,119,119) , MPOW +C + 110 XPE1=XMIN + YPT1=YMIN + XPE2=XMAX + YPT2=YMAX + GO TO 114 +C + 111 XPE1=XMIN + YPT1=YMAX + XPE2=XMAX + YPT2=YMIN + GO TO 114 +C + 112 XPE1=XMAX + YPT1=YMAX + XPE2=XMIN + YPT2=YMIN + GO TO 114 +C + 113 XPE1=XMAX + YPT1=YMIN + XPE2=XMIN + YPT2=YMAX +C + 114 XDIF=XNXT-XLST + YDIF=YNXT-YLST +C + IF (ABS(XDIF).LE.XEPS) GO TO 116 + YPE1=YLST+(XPE1-XLST)*YDIF/XDIF + YPE2=YLST+(XPE2-XLST)*YDIF/XDIF +C + IF (ABS(YDIF).LE.YEPS) GO TO 118 + IF (YPE1.GE.YMIN.AND.YPE1.LE.YMAX) GO TO 115 + YPE1=YPT1 + XPE1=XLST+(YPE1-YLST)*XDIF/YDIF + IF (XPE1.LT.XMIN.OR.XPE1.GT.XMAX) GO TO 119 +C + 115 IF (YPE2.GE.YMIN.AND.YPE2.LE.YMAX) GO TO 118 + GO TO 117 +C + 116 YPE1=YPT1 + XPE1=XLST+(YPE1-YLST)*XDIF/YDIF + IF (XPE1.LT.XMIN.OR.XPE1.GT.XMAX) GO TO 119 +C + 117 YPE2=YPT2 + XPE2=XLST+(YPE2-YLST)*XDIF/YDIF + IF (XPE2.LT.XMIN.OR.XPE2.GT.XMAX) GO TO 119 +C + 118 CALL FRSTD (XPE1,YPE1) + CALL VECTD (XPE2,YPE2) + CALL LASTD +C +C Processing of next point is done. It becomes the last point and we +C go back for a new next point. +C + 119 LPOW=NPOW + XLST=XNXT + YLST=YNXT + GO TO 101 +C +C Last point was final point. Finish up. +C + 120 IF (LDLP.NE.0) THEN + IF (LDLP.EQ.1) CALL VECTD (XLST,YLST) + CALL LASTD + END IF +C +C Restore logarithmic mapping, if appropriate. +C + IF (LTYP.NE.1) + + CALL SET (XLCW,XRCW,YBCW,YTCW,XLUW,XRUW,YBUW,YTUW,LTYP) +C +C Return to caller. +C + RETURN +C +C Error exit. +C + 901 CALL SETER ('AGQURV - NUMBER OF POINTS IS LESS THAN OR EQUAL TO ZE + +RO',7,2) +C + END diff --git a/sys/gio/ncarutil/autograph/agrpch.f b/sys/gio/ncarutil/autograph/agrpch.f new file mode 100644 index 00000000..c37a7ae4 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agrpch.f @@ -0,0 +1,86 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGRPCH (CHST,LNCS,IDCS) +C + CHARACTER*(*) CHST +C +C This routine is used to replace a character string previously stored +C by the routine AGSTCH (which see). This could be done by an AGDLCH +C followed by an AGSTCH, and, in fact, under certain conditions, does +C exactly that. Only when it is easy to do so does AGRPCH operate more +C efficiently. Nevertheless, a user who (for example) repeatedly and +C perhaps redundantly defines x-axis labels of the same length may +C greatly benefit thereby; repeated deletes and stores would lead to +C frequent garbage collection by AGSTCH. +C +C AGRPCH has the following arguments: +C +C -- CHST is the new character string, to replace what was originally +C stored. +C +C -- LNCS is the length of the character string in CHST. +C +C -- IDCS is the identifier returned by AGSTCH when the original string +C was stored. The value of IDCS may be changed by the call. +C +C The following common blocks contain variables which are required for +C the character-storage-and-retrieval scheme of AUTOGRAPH. +C + COMMON /AGCHR1/ LNIC,INCH(2,50),LNCA,INCA +C + COMMON /AGCHR2/ CHRA(2000) +C + CHARACTER*1 CHRA +C +C If the identifier is positive or is negative but less than -LNIC, the +C original string was never stored in CHRA; just treat the replacement +C as a store and return a new value of IDCS. +C + IF (IDCS.GT.(-1).OR.IDCS.LT.(-LNIC)) THEN + CALL AGSTCH (CHST,LNCS,IDCS) +C + ELSE +C +C The absolute value of the identifier is the index, in INCH, of the +C descriptor of the character string stored in CHRA. If the new string +C is shorter than the old one, store it and zero remaining character +C positions. Otherwise, treat the replacement as a delete followed by +C a store. +C + I=-IDCS + IF (LNCS.LE.INCH(2,I)) THEN + J=INCH(1,I)-1 + DO 101 K=1,LNCS + J=J+1 + CHRA(J)=CHST(K:K) + 101 CONTINUE + DO 102 K=LNCS+1,INCH(2,I) + J=J+1 + CHRA(J)=CHAR(0) + 102 CONTINUE + INCH(2,I)=LNCS + ELSE + CALL AGDLCH (IDCS) + CALL AGSTCH (CHST,LNCS,IDCS) + END IF +C + END IF +C +C Done. +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agrstr.f b/sys/gio/ncarutil/autograph/agrstr.f new file mode 100644 index 00000000..72afc643 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agrstr.f @@ -0,0 +1,88 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +NOAO - this subroutine is a no-op in IRAF. +C --------------------------------------------------------------------- +C + SUBROUTINE AGRSTR (IFNO) +C +C This subroutine is called to restore the current state of AUTOGRAPH by +C reading all of its important variables from a record on the file which +C is associated with the unit number IFNO. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C The following common blocks contain variables which are required for +C the character-storage-and-retrieval scheme of AUTOGRAPH. +C + COMMON /AGCHR1/ LNIC,INCH(2,50),LNCA,INCA +C + COMMON /AGCHR2/ CHRA(2000) +C + CHARACTER*1 CHRA +C +C Read the record. +C +C READ (IFNO,ERR=901,END=902) +C 1 BASD,BASE,DBOX,DNLA,FLLB,FLLN,FUNS,HCWP,PING,PINU,QBAC,QBAN,QBIM, +C 2 QBTD,QBTP,QCDP,QCEX,QCEY,QCIE,QCIM,QDAX,QDLB,QDSH,QFRA,QIXY,QJDP, +C 3 QLED,QLEX,QLFD,QLFL,QLLN,QLOF,QLOS,QLTD,QLTP,QLUA,QLUX,QLUY,QMJD, +C 4 QMND,QMNT,QNAN,QNDP,QNIM,QODP,QOVX,QOVY,QROW,QSET,QSPA,QWND,RBOX, +C 5 RFNL,SBOX,SCWP,SOGD,SVAL,TCLN,UBGA,UNDA,WCLE,WCLM,WCWP,WMJL,WMJR, +C 6 WMNL,WMNR,WNLB,WNLE,WNLL,WNLR,WOCD,WODQ,XBGA,XHGH,XLCW,XLGD,XLGF, +C 7 XLGW,XLOW,XLUW,XMAX,XMIN,XNDA,XRCW,XRGD,XRGF,XRGW,XRUW,YBCW,YBGA, +C 8 YBGD,YBGF,YBGW,YBUW,YHGH,YLOW,YMAX,YMIN,YNDA,YTCW,YTGD,YTGF,YTGW, +C 9 YTUW, +C + INIF,ISLD,MDLA,MWCD,MWCE,MWCL,MWCM,MWDQ,SMRL, +C 1 INCA,INCH,LNCA,LNIC, +C 2 CHRA +C +C Done. +C + RETURN +C +C Error exits. +C +C 901 CALL SETER ('AGRSTR - ERROR ON READ',8,2) +C +C 902 CALL SETER ('AGRSTR - END-OF-FILE ON READ',9,2) +C +C -NOAO + END diff --git a/sys/gio/ncarutil/autograph/agsave.f b/sys/gio/ncarutil/autograph/agsave.f new file mode 100644 index 00000000..ef0feb7d --- /dev/null +++ b/sys/gio/ncarutil/autograph/agsave.f @@ -0,0 +1,93 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +NOAO - This routine is a no-op in IRAF. +C --------------------------------------------------------------------- +C + SUBROUTINE AGSAVE (IFNO) +C +C This subroutine is called to save the current state of AUTOGRAPH by +C writing all of its important variables as a record on the file which +C is associated with the unit number IFNO. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C The following common blocks contain variables which are required for +C the character-storage-and-retrieval scheme of AUTOGRAPH. +C + COMMON /AGCHR1/ LNIC,INCH(2,50),LNCA,INCA +C + COMMON /AGCHR2/ CHRA(2000) +C + CHARACTER*1 CHRA +C +C If initialization has not yet been done, do it. +C + IF (INIF.EQ.0) THEN + CALL AGINIT + END IF +C +C Write the record. Variables from each COMMON block are together, in +C alphabetical order. +C +C WRITE (IFNO,ERR=901) +C 1 BASD,BASE,DBOX,DNLA,FLLB,FLLN,FUNS,HCWP,PING,PINU,QBAC,QBAN,QBIM, +C 2 QBTD,QBTP,QCDP,QCEX,QCEY,QCIE,QCIM,QDAX,QDLB,QDSH,QFRA,QIXY,QJDP, +C 3 QLED,QLEX,QLFD,QLFL,QLLN,QLOF,QLOS,QLTD,QLTP,QLUA,QLUX,QLUY,QMJD, +C 4 QMND,QMNT,QNAN,QNDP,QNIM,QODP,QOVX,QOVY,QROW,QSET,QSPA,QWND,RBOX, +C 5 RFNL,SBOX,SCWP,SOGD,SVAL,TCLN,UBGA,UNDA,WCLE,WCLM,WCWP,WMJL,WMJR, +C 6 WMNL,WMNR,WNLB,WNLE,WNLL,WNLR,WOCD,WODQ,XBGA,XHGH,XLCW,XLGD,XLGF, +C 7 XLGW,XLOW,XLUW,XMAX,XMIN,XNDA,XRCW,XRGD,XRGF,XRGW,XRUW,YBCW,YBGA, +C 8 YBGD,YBGF,YBGW,YBUW,YHGH,YLOW,YMAX,YMIN,YNDA,YTCW,YTGD,YTGF,YTGW, +C 9 YTUW, +C + INIF,ISLD,MDLA,MWCD,MWCE,MWCL,MWCM,MWDQ,SMRL, +C 1 INCA,INCH,LNCA,LNIC, +C 2 CHRA +C +C Done. +C + RETURN +C +C Error exit. +C +C 901 CALL SETER ('AGSAVE - ERROR ON WRITE',10,2) +C +C -NOAO + END diff --git a/sys/gio/ncarutil/autograph/agscan.f b/sys/gio/ncarutil/autograph/agscan.f new file mode 100644 index 00000000..222db6c4 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agscan.f @@ -0,0 +1,628 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGSCAN (TPID,LOPA,NIPA,IIPA) +C + CHARACTER*(*) TPID +C +C The routine AGSCAN is used by AGGETP and AGSETP to scan a parameter +C identifier and return a description of the parameter-list items which +C are specified by that parameter identifier. It has the following +C arguments: +C +C -- TPID is the parameter identifier. +C +C -- LOPA is the index of the first parameter-list item specified. +C +C -- NIPA is the number of parameter-list items specified. +C +C -- IIPA is the index increment between one of the parameter-list items +C specified and the next (meaningless if NIPA=1). +C +C +C BEWARE BEWARE BEWARE BEWARE BEWARE BEWARE BEWARE BEWARE BEWARE BEWARE +C +C Originally, this routine used the function "LOC" to return, in LOPA, +C the base address, in core, of the specified parameter group. To some +C degree, it was thereby insulated from changes in the labelled common +C block AGCONP. With the demise of "LOC", LOPA has been re-defined and +C that insulation no longer exists. In the following code, there are +C integers which represent the indices of desired quantities in common. +C +C BEWARE BEWARE BEWARE BEWARE BEWARE BEWARE BEWARE BEWARE BEWARE BEWARE +C +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C Declare the block data routine EXTERNAL to force loading of it. +C +C +NOAO - call agdflt as run time initialization +C +C EXTERNAL AGDFLT + call agdflt +C -NOAO +C +C Initialize the parameter-identifier character index. +C + IPID=0 +C +C Initialize the value of the index increment to be returned. +C + IIPA=1 +C +C Find the first keyword in the parameter identifier. +C + CALL AGSRCH (TPID,IPID,IKWL,'PRIMFRAMSET ROW INVEWINDNULLGRAPGRIDX + + Y AXISLEFTRIGHBOTTTOP DASHLABELINESECOBACK') +C + GO TO (101,102,103,104,105,106,107,108,109,110, + + 111,113,114,114,114,114,132,133,147,155,166,901) , IKWL +C +C PRIMARY CONTROL PARAMETERS. +C + 101 LOPA=1 + NIPA=336 + GO TO 203 +C +C FRAME PARAMETER. +C + 102 LOPA=1 + GO TO 202 +C +C SET PARAMETER. +C + 103 LOPA=2 + GO TO 202 +C +C ROW PARAMETER. +C + 104 LOPA=3 + GO TO 202 +C +C X/Y INVERSION PARAMETER. +C + 105 LOPA=4 + GO TO 202 +C +C WINDOWING PARAMETER. +C + 106 LOPA=5 + GO TO 202 +C +C BACKGROUND PARAMETER. +C + 166 LOPA=6 + GO TO 202 +C +C NULL PARAMETER(S). +C + 107 LOPA=7 + NIPA=2 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'1 2 ') +C + IF (IKWL.EQ.3) GO TO 901 + GO TO 201 +C +C PLOT (GRAPH) WINDOW PARAMETERS. +C + 108 LOPA=9 + NIPA=4 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'LEFTRIGHBOTTTOP ') +C + IF (IKWL.EQ.5) GO TO 901 + GO TO 201 +C +C GRID WINDOW PARAMETERS. +C + 109 LOPA=13 + NIPA=5 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'LEFTRIGHBOTTTOP SHAP') +C + IF (IKWL.EQ.6) GO TO 901 + GO TO 201 +C +C X DATA PARAMETERS. +C + 110 LOPA=18 + GO TO 112 +C +C Y DATA PARAMETERS. +C + 111 LOPA=25 +C +C X OR Y DATA PARAMETERS. +C + 112 NIPA=7 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'MINIMAXILOGAORDENICESMALLARG') +C + IF (IKWL.EQ.8) GO TO 901 + GO TO 201 +C +C AXIS PARAMETERS. +C + 113 LOPA=32 + NIPA=92 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'LEFTRIGHBOTTTOP ') +C + IF (IKWL.EQ.5) GO TO 901 + IKWL=IKWL+12 +C +C LEFT, RIGHT, BOTTOM, OR TOP AXIS PARAMETERS. +C + 114 LOPA=19+IKWL + NIPA=23 + IIPA=4 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL, + + 'CONTLINEINTEFUNCTICKMAJOMINONUMETYPEEXPOFRACANGLOFFSWIDT') +C + GO TO (202,201,115,167,116,117,123,126,127,127,127, + + 127,127,127,901) , IKWL +C +C AXIS INTERSECTION PARAMETERS. +C + 115 LOPA=LOPA+8 + NIPA=2 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'GRIDUSER') +C + IF (IKWL.EQ.3) GO TO 901 + GO TO 201 +C +C AXIS MAPPING FUNCTION. +C + 167 LOPA=LOPA+16 + GO TO 202 +C +C AXIS TICK PARAMETERS. +C + 116 LOPA=LOPA+20 + NIPA=10 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'MAJOMINO') +C + LOPA=LOPA-20 + GO TO (117,123,901) , IKWL +C +C AXIS MAJOR-TICK PARAMETERS. +C + 117 LOPA=LOPA+20 + NIPA=6 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'SPACTYPEBASECOUNPATTLENGOUTWINWA') +C + GO TO (118,119,119,119,120,121,122,122,901) , IKWL +C +C AXIS MAJOR-TICK SPACING PARAMETERS. +C + 118 NIPA=3 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'TYPEBASECOUN') +C + IF (IKWL.EQ.4) GO TO 901 +C + GO TO 201 +C + 119 IKWL=IKWL-1 + GO TO 201 +C +C AXIS MAJOR-TICK DASH PATTERN. +C + 120 LOPA=LOPA+12 + GO TO 202 +C +C AXIS MAJOR-TICK LENGTH PARAMETERS. +C + 121 LOPA=LOPA+16 + NIPA=2 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'OUTWINWA') +C + IF (IKWL.EQ.3) GO TO 901 + GO TO 201 +C + 122 LOPA=LOPA+16 + IKWL=IKWL-6 + GO TO 201 +C +C AXIS MINOR-TICK PARAMETERS. +C + 123 LOPA=LOPA+44 + NIPA=4 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'SPACPATTLENGOUTWINWA') +C + GO TO (202,201,124,125,125,901) , IKWL +C +C AXIS MINOR-TICK LENGTH PARAMETERS. +C + 124 LOPA=LOPA+8 + NIPA=2 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'OUTWINWA') +C + IF (IKWL.EQ.3) GO TO 901 + GO TO 201 +C + 125 LOPA=LOPA+8 + IKWL=IKWL-3 + GO TO 201 +C +C AXIS NUMERIC-LABEL PARAMETERS. +C + 126 LOPA=LOPA+60 + NIPA=8 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'TYPEEXPOFRACANGLOFFSWIDT') +C + GO TO 128 +C + 127 LOPA=LOPA+60 + IKWL=IKWL-8 +C + 128 GO TO (202,201,201,129,130,131,901) ,IKWL +C +C AXIS NUMERIC-LABEL ORIENTATION ANGLE. +C + 129 LOPA=LOPA+12 + NIPA=2 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'1ST 2ND ') +C + IF (IKWL.EQ.3) GO TO 901 + GO TO 201 +C +C AXIS NUMERIC-LABEL OFFSET. +C + 130 LOPA=LOPA+20 + GO TO 202 +C +C AXIS NUMERIC-LABEL WIDTH PARAMETERS. +C + 131 LOPA=LOPA+24 + NIPA=2 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'MANTEXPO') +C + IF (IKWL.EQ.3) GO TO 901 + GO TO 201 +C +C DASH-PATTERN PARAMETERS. +C + 132 LOPA=124 + NIPA=30 + IF (TPID(IPID:IPID).EQ.'.') RETURN + JPID=IPID + CALL AGSRCH (TPID,IPID,IKWL,'SELELENGCHARDOLLPATT') + IF (IKWL.EQ.6) THEN + IPID=JPID + GO TO 168 + END IF + IF (IKWL.NE.5) GO TO 201 + 168 LOPA=LOPA+4 + NIPA=26 + IF (TPID(IPID:IPID).EQ.'.') RETURN + CALL AGSRCH (TPID,IPID,IKWL, + +'1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 1 + +7 18 19 20 21 22 23 24 25 26 ') + IF (IKWL.EQ.27) GO TO 901 + GO TO 201 +C +C LABEL PARAMETERS. +C + 133 LBIM=IFIX(QBIM) + LBAN=IFIX(QBAN) +C + LOPA=154 + NIPA=3+LBIM*10 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL, + + 'CONTBUFFNAMEDEFISUPPBASEOFFSANGLCENTLINEINDE') +C + GO TO (202,136,139,140,141,141,141,141,141,141,141,901) , IKWL +C +C LABEL BUFFER PARAMETERS. +C + 136 LOPA=155 + NIPA=1+LBIM*10 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'LENGCONTNAME') +C + GO TO (202,137,138,901) , IKWL +C +C LABEL BUFFER CONTENTS. +C + 137 LOPA=156 + NIPA=LBIM*10 + GO TO 203 +C +C LABEL BUFFER NAMES. +C + 138 LOPA=156 + NIPA=LBIM + IIPA=10 + GO TO 203 +C +C LABEL NAME. +C + 139 LOPA=236 + GO TO 202 +C +C LABEL DEFINITION. +C + 140 IF (LBAN.LT.1.OR.LBAN.GT.LBIM) GO TO 902 +C + LOPA=157+(LBAN-1)*10 + NIPA=9 + IF (TPID(IPID:IPID).EQ.'.') GO TO 203 +C + CALL AGSRCH (TPID,IPID,IKWL,'SUPPBASEOFFSANGLCENTLINEINDE') +C + GO TO 142 +C + 141 IF (LBAN.LT.1.OR.LBAN.GT.LBIM) GO TO 902 +C + LOPA=157+(LBAN-1)*10 + IKWL=IKWL-4 +C + 142 GO TO (202,143,144,146,146,146,146,901) , IKWL +C +C LABEL POSITION. +C + 143 LOPA=LOPA+1 + GO TO 145 +C +C LABEL OFFSET. +C + 144 LOPA=LOPA+3 +C +C LABEL POSITION OR OFFSET. +C + 145 NIPA=2 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'X Y ') +C + IF (IKWL.EQ.3) GO TO 901 + GO TO 201 +C +C OTHER LABEL ATTRIBUTES. +C + 146 LOPA=LOPA+5 + IKWL=IKWL-3 + GO TO 201 +C +C LINE PARAMETERS. +C + 147 LNIM=IFIX(QNIM) + LNAN=IFIX(QNAN) +C + LOPA=237 + NIPA=4+LNIM*6 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL, + + 'MAXIEND BUFFNUMBDEFISUPPCHARTEXTLENGINDE') +C + GO TO (202,201,150,152,153,154,154,154,154,154,901) , IKWL +C +C LINE BUFFER PARAMETERS. +C + 150 LOPA=239 + NIPA=1+LNIM*6 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'LENGCONT') +C + GO TO (202,151,901) , IKWL +C +C LINE BUFFER CONTENTS. +C + 151 LOPA=240 + NIPA=LNIM*6 + GO TO 203 +C +C LINE NUMBER. +C + 152 LOPA=336 + GO TO 202 +C +C LINE DEFINITION. +C + 153 IF (LNAN.LT.1.OR.LNAN.GT.LNIM) GO TO 903 +C + LOPA=241+(LNAN-1)*6 + NIPA=5 + IF (TPID(IPID:IPID).EQ.'.') GO TO 203 +C + CALL AGSRCH (TPID,IPID,IKWL,'SUPPCHARTEXTLENGINDE') +C + IF (IKWL.EQ.6) GO TO 901 + GO TO 201 +C + 154 IF (LNAN.LT.1.OR.LNAN.GT.LNIM) GO TO 903 + LOPA=241+(LNAN-1)*6 + IKWL=IKWL-5 + GO TO 201 +C +C SECONDARY CONTROL PARAMETERS. +C + 155 LOPA=337 + NIPA=149 + IF (TPID(IPID:IPID).EQ.'.') GO TO 203 +C + CALL AGSRCH (TPID,IPID,IKWL, + + 'GRAPUSERCURVDIMEAXISLEFTRIGHBOTTTOP LABE') +C + GO TO (156,157,158,159,160,161,161,161,161,165,901) , IKWL +C +C PLOT (GRAPH) WINDOW EDGES. +C + 156 LOPA=337 + NIPA=4 + GO TO 203 +C +C USER WINDOW PARAMETERS. +C + 157 LOPA=341 + NIPA=4 + GO TO 203 +C +C CURVE WINDOW PARAMETERS. +C + 158 LOPA=345 + NIPA=4 + GO TO 203 +C +C CURVE WINDOW DIMENSIONS. +C + 159 LOPA=349 + NIPA=3 + GO TO 203 +C +C AXIS PARAMETERS. +C + 160 LOPA=352 + NIPA=80 + IF (TPID(IPID:IPID).EQ.'.') GO TO 203 +C + CALL AGSRCH (TPID,IPID,IKWL,'LEFTRIGHBOTTTOP ') +C + IF (IKWL.EQ.5) GO TO 901 +C + IKWL=IKWL+5 +C +C LEFT, RIGHT, BOTTOM, OR TOP AXIS PARAMETERS. +C + 161 LOPA=346+IKWL + NIPA=20 + IIPA=4 + IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGSRCH (TPID,IPID,IKWL,'POSITICKNUME') +C + GO TO (162,163,164,901) , IKWL +C +C AXIS POSITIONING PARAMETERS. +C + 162 NIPA=6 + GO TO 203 +C +C AXIS TICK PARAMETERS. +C + 163 LOPA=LOPA+24 + NIPA=3 + GO TO 203 +C +C AXIS NUMERIC-LABEL PARAMETERS. +C + 164 LOPA=LOPA+36 + NIPA=11 + GO TO 203 +C +C LABEL BOXES. +C + 165 LOPA=432 + NIPA=54 + IF (TPID(IPID:IPID).EQ.'.') GO TO 203 +C + CALL AGSRCH (TPID,IPID,IKWL,'LEFTRIGHBOTTTOP CENTGRAP') +C + IF (IKWL.EQ.7) GO TO 901 +C + LOPA=LOPA+IKWL-1 + NIPA=9 + IIPA=6 + GO TO 203 +C +C Normal exits. +C + 201 LOPA=LOPA+(IKWL-1)*IIPA +C + 202 NIPA=1 +C + 203 IF (TPID(IPID:IPID).EQ.'.') RETURN +C + CALL AGPPID (TPID) +C +NOAO - following FTN write and fmt statements commented out, SETER is okay. +C +C WRITE (I1MACH(4),1001) + RETURN +C +C Error exits. +C + 901 CALL AGPPID (TPID) + CALL SETER ('AGGETP OR AGSETP - ILLEGAL KEYWORD USED IN PARAMETER + +IDENTIFIER',11,2) +C + 902 CALL AGPPID (TPID) + CALL SETER ('AGGETP OR AGSETP - ATTEMPT TO ACCESS LABEL ATTRIBUTES + + BEFORE SETTING LABEL NAME',12,2) +C + 903 CALL AGPPID (TPID) + CALL SETER ('AGGETP OR AGSETP - ATTEMPT TO ACCESS LINE ATTRIBUTES + +BEFORE SETTING LINE NUMBER',13,2) +C +C Formats. +C +C1001 FORMAT (' WARNING - ABOVE PARAMETER IDENTIFIER HAS TOO MANY KEYWOR +C +DS') +C +C -NOAO + END diff --git a/sys/gio/ncarutil/autograph/agsetc.f b/sys/gio/ncarutil/autograph/agsetc.f new file mode 100644 index 00000000..bced8458 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agsetc.f @@ -0,0 +1,100 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGSETC (TPID,CUSR) +C + CHARACTER*(*) TPID,CUSR +C + DIMENSION FURA(1) +C +C The routine AGSETC is used to set the values of individual AUTOGRAPH +C parameters which intrinsically represent character strings. TPID is a +C parameter identifier. CUSR is a character string. The situation is +C complicated by the fact that the character string may be either a dash +C pattern, the name of a label, the line-end character, or the text of a +C line, all of which are treated differently. +C +C Define a local variable to hold the "line-end" character. +C + CHARACTER*1 LEND +C +C See what kind of parameter is being set. +C + CALL AGCTCS (TPID,ITCS) +C +C If the parameter is not intrinsically of type character, log an error. +C + IF (ITCS.EQ.0) GO TO 901 +C +C Find the length of the string, which may or may not actually be used. +C (On the Cray, at least, it may be zero if the wrong type of argument +C was used.) +C + ILEN=LEN(CUSR) +C +C Retrieve the current (integer) value of the parameter. +C + CALL AGGETI (TPID,ITMP) +C +C Check for a dash pattern. +C + IF (ITCS.EQ.1) THEN + CALL AGGETI ('DASH/LENG.',NCHR) + IF (ILEN.GT.0.AND.ILEN.LT.NCHR) NCHR=ILEN + CALL AGRPCH (CUSR,NCHR,ITMP) +C +C Check for a label name. +C + ELSE IF (ITCS.EQ.2) THEN + CALL AGRPCH (CUSR,MAX0(1,ILEN),ITMP) +C +C Check for the line-end character. +C + ELSE IF (ITCS.EQ.3) THEN + CALL AGRPCH (CUSR,1,ITMP) +C +C Check for the text of a label. +C + ELSE IF (ITCS.EQ.4) THEN + CALL AGGETI ('LINE/MAXI.',NCHR) + IF (ILEN.GT.0) NCHR=MIN0(NCHR,ILEN) + CALL AGGETC ('LINE/END .',LEND) + DO 101 I=1,NCHR + IF (CUSR(I:I).EQ.LEND) THEN + NCHR=I-1 + GO TO 102 + END IF + 101 CONTINUE +C + 102 CALL AGRPCH (CUSR,NCHR,ITMP) +C + END IF +C +C Transfer the generated value to the list of AUTOGRAPH parameters. +C + FURA(1)=FLOAT(ITMP) + CALL AGSETP (TPID,FURA,1) +C +C Done. +C + RETURN +C +C Error exit. +C + 901 CALL AGPPID (TPID) + CALL SETER ('AGSETC - PARAMETER TO SET IS NOT INTRINSICALLY OF TYP + +E CHARACTER',14,2) +C + END diff --git a/sys/gio/ncarutil/autograph/agsetf.f b/sys/gio/ncarutil/autograph/agsetf.f new file mode 100644 index 00000000..36fca46e --- /dev/null +++ b/sys/gio/ncarutil/autograph/agsetf.f @@ -0,0 +1,28 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGSETF (TPID,FUSR) +C + CHARACTER*(*) TPID + DIMENSION FURA(1) +C +C The routine AGSETF may be used to set the real (floating-point) value +C of any single AUTOGRAPH control parameter. +C + FURA(1)=FUSR + CALL AGSETP (TPID,FURA,1) + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agseti.f b/sys/gio/ncarutil/autograph/agseti.f new file mode 100644 index 00000000..06e3b3f1 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agseti.f @@ -0,0 +1,28 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGSETI (TPID,IUSR) +C + CHARACTER*(*) TPID + DIMENSION FURA(1) +C +C The routine AGSETI may be used to set the integer-equivalent value of +C any single AUTOGRAPH control parameter. +C + FURA(1)=FLOAT(IUSR) + CALL AGSETP (TPID,FURA,1) + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agsetp.f b/sys/gio/ncarutil/autograph/agsetp.f new file mode 100644 index 00000000..95e98a6d --- /dev/null +++ b/sys/gio/ncarutil/autograph/agsetp.f @@ -0,0 +1,447 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGSETP (TPID,FURA,LURA) +C + CHARACTER*(*) TPID + DIMENSION FURA(LURA) +C +C The routine AGSETP stores user-provided values of the AUTOGRAPH +C parameters specified by the parameter identifier TPID. The arguments +C are as follows: +C +C -- TPID is the parameter identifier, a string of keywords separated +C from each other by slashes and followed by a period. +C +C -- FURA is the user array from which parameter values are to be taken. +C +C -- LURA is the length of the user array. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C The following common block contains other AUTOGRAPH variables, of type +C character. +C + COMMON /AGOCHP/ CHS1,CHS2 +C +c+noao +c CHARACTER*504 CHS1,CHS2 + CHARACTER*500 CHS1,CHS2 +c-noao +C +C Define the array DUMI, which allows access to the control-parameter +C list as an array. +C + DIMENSION DUMI(1) + EQUIVALENCE (QFRA,DUMI) +C +C +NOAO - Make sure common has been initialized. +C + call agdflt +C +C -NOAO +C If initialization has not yet been done, do it. +C + IF (INIF.EQ.0) THEN + CALL AGINIT + END IF +C +C The routine AGSCAN is called to scan the parameter identifier and to +C return three quantities describing the AUTOGRAPH parameters affected. +C + CALL AGSCAN (TPID,LOPA,NIPA,IIPA) +C +C Determine the number of values to transfer. +C + NURA=MAX0(1,MIN0(LURA,NIPA)) +C +C If character-string dash patterns are being replaced by integer dash +C patterns, reclaim the space used in the character-storage arrays. +C + CALL AGSCAN ('DASH/PATT.',LODP,NIDP,IIDP) + IF (LOPA.LE.LODP+NIDP-1.AND.LOPA+NURA-1.GE.LODP) THEN + MINI=MAX0(LOPA,LODP)-LOPA+1 + MAXI=MIN0(LOPA+NURA-1,LODP+NIDP-1)-LOPA+1 + DO 100 I=MINI,MAXI + IF (FURA(I).GT.0.) CALL AGDLCH (IFIX(DUMI(LOPA+I-1))) + 100 CONTINUE + END IF +C +C Save the current values of special values 1 and 2. +C + SVL1=SVAL(1) + SVL2=SVAL(2) +C +C Transfer the user-provided values to the parameter list. +C + IDMI=LOPA-IIPA +C + DO 101 IURA=1,NURA + IDMI=IDMI+IIPA + DUMI(IDMI)=FURA(IURA) + 101 CONTINUE +C +C If a specific item was changed, we may have a bit more work to do; +C otherwise, return to the user. +C + IF (NIPA.NE.1) RETURN +C +C If the specific item was special value 1 or 2, scan the primary list +C of parameters for other occurrences of the special value and change +C them to the new value. +C + IF (SVAL(1).NE.SVL1) THEN + SVLO=SVL1 + SVLN=SVAL(1) + GO TO 102 + END IF +C + IF (SVAL(2).NE.SVL2) THEN + SVLO=SVL2 + SVLN=SVAL(2) + GO TO 102 + END IF +C + GO TO 104 +C + 102 CALL AGSCAN ('PRIM.',LOPR,NIPR,IIPR) +C + IDMI=LOPR-IIPR +C + DO 103 I=1,NIPR + IDMI=IDMI+IIPR + IF (DUMI(IDMI).EQ.SVLO) DUMI(IDMI)=SVLN + 103 CONTINUE +C + RETURN +C +C If the specific item was the label control flag and it was set +C negative, delete all labels and lines. +C + 104 CALL AGSCAN ('LABE/CONT.',LOLC,NILC,IILC) + IF (LOPA.NE.LOLC) GO TO 107 + IF (QDLB.GE.0.) RETURN +C + QBAN=0. + QNAN=0. +C + LBIM=IFIX(QBIM) +C + DO 105 I=1,LBIM + IF (FLLB(1,I).NE.0.) THEN + CALL AGDLCH (IFIX(FLLB(1,I))) + FLLB(1,I)=0. + END IF + 105 CONTINUE +C + LNIM=IFIX(QNIM) +C + DO 106 I=1,LNIM + IF (FLLN(1,I).NE.SVAL(1)) THEN + CALL AGDLCH (IFIX(FLLN(4,I))) + FLLN(1,I)=SVAL(1) + END IF + 106 CONTINUE +C + RETURN +C +C If the specific item was the label name, reset it to an appropriate +C index in the label list, providing initial values if appropriate. +C + 107 CALL AGSCAN ('LABE/NAME.',LOLN,NILN,IILN) + IF (LOPA.NE.LOLN) GO TO 109 +C + LBAN=0 + LBIM=IFIX(QBIM) + QNAN=0. +C + CALL AGGTCH (IFIX(FURA(1)),CHS1,LCS1) +C + DO 108 I=1,LBIM + IF (LBAN.EQ.0.AND.FLLB(1,I).EQ.0.) LBAN=I + CALL AGGTCH (IFIX(FLLB(1,I)),CHS2,LCS2) + IF (LCS1.NE.LCS2) GO TO 108 + IF (CHS1(1:LCS1).NE.CHS2(1:LCS2)) GO TO 108 + QBAN=FLOAT(I) + RETURN + 108 CONTINUE +C + IF (LBAN.EQ.0) GO TO 901 +C + QBAN=FLOAT(LBAN) +C + FLLB( 1,LBAN)=FURA(1) + FLLB( 2,LBAN)=0. + FLLB( 3,LBAN)=.5 + FLLB( 4,LBAN)=.5 + FLLB( 5,LBAN)=0. + FLLB( 6,LBAN)=0. + FLLB( 7,LBAN)=0. + FLLB( 8,LBAN)=0. + FLLB( 9,LBAN)=0. + FLLB(10,LBAN)=0. +C + RETURN +C +C If the label access name is not set, skip. +C + 109 IF (QBAN.LE.0.) GO TO 122 +C + LBAN=IFIX(QBAN) + LBIM=IFIX(QBIM) + LNAN=IFIX(QNAN) + LNIM=IFIX(QNIM) +C +C If the specific item was the suppression flag for the current label +C and it was set negative, delete the label and/or its lines. +C + CALL AGSCAN ('LABE/SUPP.',LOLS,NILS,IILS) + IF (LOPA.NE.LOLS) GO TO 111 + IF (FLLB(2,LBAN).GE.0.) RETURN +C + ITMP=IFIX(FLLB(2,LBAN)) + FLLB(2,LBAN)=0. + FLLB(9,LBAN)=0. + LNIN=IFIX(FLLB(10,LBAN)) + FLLB(10,LBAN)=0. + QNAN=0. + IF (ITMP.EQ.(-1)) GO TO 110 + CALL AGDLCH (IFIX(FLLB(1,LBAN))) + FLLB(1,LBAN)=0. + QBAN=0. +C + 110 IF (LNIN.LT.1.OR.LNIN.GT.LNIM) RETURN + FLLN(1,LNIN)=SVAL(1) + CALL AGDLCH (IFIX(FLLN(4,LNIN))) + LNIN=IFIX(FLLN(6,LNIN)) + GO TO 110 +C +C If the specific item was the line number, reset it to an appropriate +C index in the line list, providing initial values if appropriate. +C + 111 CALL AGSCAN ('LINE/NUMB.',LOLN,NILN,IILN) + IF (LOPA.NE.LOLN) GO TO 118 +C + LNIL=0 + LNIN=IFIX(FLLB(10,LBAN)) +C + 112 IF (LNIN.LT.1.OR.LNIN.GT.LNIM) GO TO 115 + IF (LNAN-IFIX(FLLN(1,LNIN))) 113,114,115 +C + 113 LNIL=LNIN + LNIN=IFIX(FLLN(6,LNIN)) + GO TO 112 +C + 114 QNAN=FLOAT(LNIN) + RETURN +C + 115 DO 116 I=1,LNIM + LNIT=I + IF (FLLN(1,I).EQ.SVAL(1)) GO TO 117 + 116 CONTINUE +C + GO TO 903 +C + 117 CALL AGSTCH (' ',1,ITMP) +C + FLLN(1,LNIT)=FLOAT(LNAN) + FLLN(2,LNIT)=0. + FLLN(3,LNIT)=.015 + FLLN(4,LNIT)=ITMP + FLLN(5,LNIT)=1. + FLLN(6,LNIT)=FLOAT(LNIN) +C + LNAN=LNIT + IF (LNIL.EQ.0) FLLB(10,LBAN)=FLOAT(LNAN) + IF (LNIL.NE.0) FLLN( 6,LNIL)=FLOAT(LNAN) +C + FLLB(9,LBAN)=FLLB(9,LBAN)+1. +C + QNAN=FLOAT(LNAN) + RETURN +C +C If the line access number is not set, skip. +C + 118 IF (LNAN.LE.0) GO TO 122 +C +C If the specific item was the suppression flag for the current line and +C it was set negative, delete the line. +C + CALL AGSCAN ('LINE/SUPP.',LOLS,NILS,IILS) + IF (LOPA.NE.LOLS) GO TO 121 + IF (FLLN(2,LNAN).GE.0.) RETURN +C + LNIL=0 + LNIN=IFIX(FLLB(10,LBAN)) +C + 119 IF (LNIN.LT.1.OR.LNIN.GT.LNIM) RETURN + IF (LNAN.EQ.LNIN) GO TO 120 + LNIL=LNIN + LNIN=IFIX(FLLN(6,LNIN)) + GO TO 119 +C + 120 IF (LNIL.EQ.0) FLLB(10,LBAN)=FLLN(6,LNAN) + IF (LNIL.NE.0) FLLN( 6,LNIL)=FLLN(6,LNAN) + FLLN(1,LNAN)=SVAL(1) + CALL AGDLCH (IFIX(FLLN(4,LNAN))) + QNAN=0. + RETURN +C +C If the specific item was the text of a line, set the length of the +C line, as well. +C + 121 CALL AGSCAN ('LINE/TEXT.',LOLT,NILT,IILT) + IF (LOPA.NE.LOLT) GO TO 123 + CALL AGGTCH (IFIX(FURA(1)),CHS1,LCS1) + FLLN(5,LNAN)=FLOAT(LCS1) + RETURN +C +C See if the user is trying to get at a line of a non-existent label. +C + 122 CALL AGSCAN ('LINE/NUMB.',LOLN,NILN,IILN) + IF (LOPA.EQ.LOLN) GO TO 902 +C +C If the specific item was the background parameter, set up the back- +C ground requested by the user. +C + 123 CALL AGSCAN ('BACK.',LOBG,NIBG,IIBG) + IF (LOPA.NE.LOBG) GO TO 130 +C + QBAC=AMAX1(1.,AMIN1(4.,QBAC)) + IBAC=IFIX(QBAC) + GO TO (124,125,126,127) , IBAC +C +C Perimeter background. +C + 124 QLBC=4. + QRTC=4. + WMJI=.015 + WMNI=.010 + GO TO 128 +C +C Grid background. +C + 125 QLBC=4. + QRTC=-1. + WMJI=1. + WMNI=1. + GO TO 128 +C +C Half-axis background. +C + 126 QLBC=4. + QRTC=0. + WMJI=.015 + WMNI=.010 + GO TO 128 +C +C No background. +C + 127 QLBC=0. + QRTC=0. + WMJI=.015 + WMNI=.010 +C + 128 QDAX(1)=QLBC + QDAX(2)=QRTC + QDAX(3)=QLBC + QDAX(4)=QRTC +C + DO 129 I=1,4 + WMJR(I)=WMJI + WMNR(I)=WMNI + 129 CONTINUE +C + QDLB=FLOAT(2-2*(IBAC/4)) + RETURN +C +C If the specific item was the get-limits-from-last-SET-call parameter, +C do what is necessary. +C + 130 CALL AGSCAN ('SET .',LOSE,NISE,IISE) + IF (LOPA.NE.LOSE) GO TO 131 +C + QSET=SIGN(AMAX1(1.,AMIN1(4.,ABS(QSET))),QSET) +C + XLGD=.15 + XRGD=.95 + YBGD=.15 + YTGD=.95 + SOGD=0. +C + XMIN=SVAL(1) + XMAX=SVAL(1) + QLUX=AMIN1(QLUX,0.) + QOVX=0. + QCEX=-1. + XLOW=SVAL(1) + XHGH=SVAL(1) +C + YMIN=SVAL(1) + YMAX=SVAL(1) + QLUY=AMIN1(QLUY,0.) + QOVY=0. + QCEY=-1. + YLOW=SVAL(1) + YHGH=SVAL(1) +C + RETURN +C +C Return to caller. +C + 131 RETURN +C +C Error exits. +C + 901 CALL AGPPID (TPID) + CALL SETER ('AGSETP - LABEL LIST OVERFLOW - SEE AUTOGRAPH SPECIALI + +ST',15,2) +C + 902 CALL AGPPID (TPID) + CALL SETER ('AGSETP - ATTEMPT TO DEFINE LINE OF NON-EXISTENT LABEL + +',16,2) +C + 903 CALL AGPPID (TPID) + CALL SETER ('AGSETP - LINE LIST OVERFLOW - SEE AUTOGRAPH SPECIALIS + +T',17,2) +C + END diff --git a/sys/gio/ncarutil/autograph/agsrch.f b/sys/gio/ncarutil/autograph/agsrch.f new file mode 100644 index 00000000..366c46cc --- /dev/null +++ b/sys/gio/ncarutil/autograph/agsrch.f @@ -0,0 +1,96 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGSRCH (TPID,IPID,IKWL,TKWL) +C + CHARACTER*(*) TPID,TKWL +C +C The routine AGSRCH is used by AGSCAN to search a parameter identifier +C for the next keyword and return the index of that keyword in a list of +C keywords. It has the following arguments. +C +C -- TPID is the parameter identifier, a character string. +C +C -- IPID is the index of the last character examined in TPID. It is +C updated by AGSRCH to point to the first slash or period following +C the next keyword. +C +C -- IKWL is returned containing the index (in the keyword list) of the +C next keyword in the parameter identifier (list length, plus one, +C if the keyword is not found in the list). +C +C -- TKWL is the keyword list - 4*LKWL characters in all. +C +C ICHR is used to hold up to four characters of a keyword. +C + CHARACTER*4 ICHR +C +C LPID is the assumed maximum length of a parameter identifier. +C + DATA LPID / 100 / +C +C Compute the number of 4-character keywords in the keyword list. +C + LKWL=LEN(TKWL)/4 +C +C Find the next non-blank in the parameter identifier. +C + 101 IPID=IPID+1 + IF (IPID.GT.LPID) GO TO 107 + IF (TPID(IPID:IPID).EQ.' ') GO TO 101 +C +C Pick up at most four characters of the keyword, stopping on the first +C blank, slash, or period encountered. +C + NCHR=0 +C + 102 IF (TPID(IPID:IPID).EQ.' '.OR. + + TPID(IPID:IPID).EQ.'/'.OR. + + TPID(IPID:IPID).EQ.'.') GO TO 103 +C + NCHR=NCHR+1 + ICHR(NCHR:NCHR)=TPID(IPID:IPID) +C + IPID=IPID+1 +C + IF (NCHR.LT.4) GO TO 102 +C +C If the keyword found has zero length, error. +C + 103 IF (NCHR.EQ.0) GO TO 107 +C +C Scan ahead for the next slash or period. +C + 104 IF (TPID(IPID:IPID).EQ.'/'.OR.TPID(IPID:IPID).EQ.'.') GO TO 105 +C + IPID=IPID+1 + IF (IPID.GT.LPID) GO TO 107 + GO TO 104 +C +C Search the keyword list for the keyword found. +C + 105 DO 106 I=1,LKWL + IKWL=I + ISTR=(I-1)*4+1 + IEND=(I-1)*4+NCHR + IF (ICHR(1:NCHR).EQ.TKWL(ISTR:IEND)) RETURN + 106 CONTINUE +C +C Keyword not found - set IKWL to impossible value and return. +C + 107 IKWL=LKWL+1 + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/agstch.f b/sys/gio/ncarutil/autograph/agstch.f new file mode 100644 index 00000000..2b2906bd --- /dev/null +++ b/sys/gio/ncarutil/autograph/agstch.f @@ -0,0 +1,124 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGSTCH (CHST,LNCS,IDCS) +C + CHARACTER*(*) CHST +C +C This routine stores strings of characters for later retrieval and/or +C modification by the routines AGGTCH, AGRPCH, and AGDLCH. It has the +C following arguments: +C +C -- CHST is the character string to be stored. +C +C -- LNCS is the length of the character string in CHST. LNCS must be +C less than or equal to the value of the FORTRAN function LEN(CHST). +C +C -- IDCS is an identifying integer, returned to the caller by AGSTCH +C for later use in calls to AGGTCH, AGRPCH, and AGDLCH. If CHST is +C more than one character long, it is stashed in the array CHRA, and +C the value returned in IDCS is a negative number between -LNIC and +C -1, inclusive, the absolute value of which is the index of an entry +C in the array INCH describing where in the array CHRA the string was +C stored. If CHST is only one character long, IDCS is returned as +C the value of the FORTRAN expression -(LNIC+1+ICHAR(CHST(1:1))). +C +C The following common blocks contain variables which are required for +C the character-storage-and-retrieval scheme of AUTOGRAPH. +C + COMMON /AGCHR1/ LNIC,INCH(2,50),LNCA,INCA +C + COMMON /AGCHR2/ CHRA(2000) +C + CHARACTER*1 CHRA +C +C If the string is short enough, just embed it in a negative integer +C and return that value to the caller as the identifier of the string. +C + IF (LNCS.LE.1) THEN + IDCS=-(LNIC+1+ICHAR(CHST(1:1))) + RETURN + END IF +C +C Otherwise, the string must be stashed in CHRA and the negative of the +C index, in INCH, of its descriptor returned to the caller. Loop, on I, +C through the index of character strings. +C + DO 104 I=1,LNIC +C +C If the next entry in the index is zeroed, use it for the new string. +C + IF (INCH(1,I).EQ.0) THEN +C +C Zeroed entry found. Return the negative of its index to the user. +C + IDCS=-I +C +C If there isn't enough room for the character string at the end of the +C character-storage array, do some garbage-collecting, eliminating all +C strings of all-zero characters. +C + IF (LNCS.GT.LNCA-INCA) THEN + J=0 + K=0 + DO 102 L=1,INCA + IF (CHRA(L).EQ.CHAR(0)) THEN + IF (J.EQ.0) J=L + ELSE + IF (J.NE.0) THEN + DO 101 M=1,LNIC + IF (INCH(1,M).GT.K) INCH(1,M)=INCH(1,M)+J-L + 101 CONTINUE + J=0 + END IF + K=K+1 + CHRA(K)=CHRA(L) + END IF + 102 CONTINUE + INCA=K + END IF +C +C If there still isn't enough room for the character string at the end +C of the character-storage array, take an error exit. Otherwise, stash +C it and return. All-zero characters are changed to blanks. +C + IF (LNCS.GT.LNCA-INCA) GO TO 901 + INCH(1,I)=INCA+1 + INCH(2,I)=LNCS + DO 103 J=1,LNCS + INCA=INCA+1 + CHRA(INCA)=CHST(J:J) + IF (ICHAR(CHRA(INCA)).EQ.0) CHRA(INCA)=' ' + 103 CONTINUE + RETURN +C + END IF +C + 104 CONTINUE +C +C If no zeroed entry was found in the index of character strings, jump +C to log an error and quit. +C + GO TO 902 +C +C Error exits. +C + 901 CALL SETER ('AGSTCH - CHARACTER-STRING BUFFER OVERFLOW - SEE CONSU + +LTANT',18,2) +C + 902 CALL SETER ('AGSTCH - CHARACTER-STRING INDEX OVERFLOW - SEE CONSUL + +TANT',19,2) +C + END diff --git a/sys/gio/ncarutil/autograph/agstup.f b/sys/gio/ncarutil/autograph/agstup.f new file mode 100644 index 00000000..41a97674 --- /dev/null +++ b/sys/gio/ncarutil/autograph/agstup.f @@ -0,0 +1,543 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGSTUP (XDRA,NVIX,IIVX,NEVX,IIEX, + + YDRA,NVIY,IIVY,NEVY,IIEY) +C + DIMENSION XDRA(1),YDRA(1) +C +C The routine AGSTUP is called to examine the parameter list, to provide +C default values for missing parameters, and to check for and cope with +C label overlap problems. +C +C The arguments describe the x and y data arrays to be used for the next +C graph. See the routine AGEXUS for a description of them. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C Declare the block data routine external to force it to load. +C +C EXTERNAL AGDFLT +C +C Do statistics-gathering call. +C + LOGICAL Q8Q4 + SAVE Q8Q4 + DATA Q8Q4 /.TRUE./ + IF (Q8Q4) THEN + CALL Q8QST4('GRAPHX','AUTOGRAPH','AGSTUP','VERSION 07') + Q8Q4 = .FALSE. + ENDIF +C +C +NOAO - Block data replaced with run time initialization +C + call agdflt +C +C -NOAO +C If initialization has not yet been done, do it. +C + IF (INIF.EQ.0) THEN + CALL AGINIT + END IF +C +C Compute the width and height of the plotter frame. +C + CALL GETSI (IWFP,IHFP) + WOFP=2.**IWFP-1. + HOFP=2.**IHFP-1. +C +C Examine the get-limits-from-last-set-call parameter. +C + IF (ABS(QSET).EQ.1.) GO TO 141 +C + CALL GETSET (XLCW,XRCW,YBCW,YTCW,XMNT,XMXT,YMNT,YMXT,LILO) +C + QLUX=FLOAT((1-LILO)/2) + QLUY=FLOAT(MOD(1-LILO,2)) +C + IF (ABS(QSET).EQ.3.) GO TO 140 +C + XLGD=(XLCW-XLGF)/(XRGF-XLGF) + XRGD=(XRCW-XLGF)/(XRGF-XLGF) + YBGD=(YBCW-YBGF)/(YTGF-YBGF) + YTGD=(YTCW-YBGF)/(YTGF-YBGF) + SOGD=0. +C + IF (ABS(QSET).EQ.2.) GO TO 141 +C + 140 XMIN=AMIN1(XMNT,XMXT) + XMAX=AMAX1(XMNT,XMXT) + QOVX=0. + IF (XMNT.GT.XMXT) QOVX=1. + QCEX=0. +C + YMIN=AMIN1(YMNT,YMXT) + YMAX=AMAX1(YMNT,YMXT) + QOVY=0. + IF (YMNT.GT.YMXT) QOVY=1. + QCEY=0. +C + 141 CONTINUE +C +C Examine the graph-window parameters. +C + XLGF=AMAX1(0.,AMIN1(1.,XLGF)) + XRGF=AMAX1(0.,AMIN1(1.,XRGF)) + YBGF=AMAX1(0.,AMIN1(1.,YBGF)) + YTGF=AMAX1(0.,AMIN1(1.,YTGF)) +C + IF (XLGF.GE.XRGF.OR.YBGF.GE.YTGF) GO TO 901 +C +C Examine the grid-window parameters. +C + XLGD=AMAX1(0.,AMIN1(1.,XLGD)) + XRGD=AMAX1(0.,AMIN1(1.,XRGD)) + YBGD=AMAX1(0.,AMIN1(1.,YBGD)) + YTGD=AMAX1(0.,AMIN1(1.,YTGD)) +C + IF (XLGD.GE.XRGD.OR.YBGD.GE.YTGD) GO TO 902 +C +C Examine the user-window minima and maxima for special values. Compute +C tentative values of the user-window edge parameters. +C + QIXY=AMAX1(0.,AMIN1(1.,QIXY)) +C + IF (QIXY.NE.0.) GO TO 142 +C + CALL AGEXUS (SVAL,XMIN,XMAX,XLOW,XHGH, + + XDRA,NVIX,IIVX,NEVX,IIEX,XLUW,XRUW) + CALL AGEXUS (SVAL,YMIN,YMAX,YLOW,YHGH, + + YDRA,NVIY,IIVY,NEVY,IIEY,YBUW,YTUW) + GO TO 143 +C + 142 CALL AGEXUS (SVAL,XMIN,XMAX,XLOW,XHGH, + + YDRA,NVIY,IIVY,NEVY,IIEY,XLUW,XRUW) + CALL AGEXUS (SVAL,YMIN,YMAX,YLOW,YHGH, + + XDRA,NVIX,IIVX,NEVX,IIEX,YBUW,YTUW) +C + 143 CONTINUE +C +C Examine the user-window nice-value-at-ends parameters. INAX and INAY +C specify which axis has the nice values (if any). +C + QCEX=AMAX1(-1.,AMIN1(+1.,QCEX)) + INAX=IFIX(QCEX) + IF (INAX.NE.0) INAX=(INAX+7)/2 +C + QCEY=AMAX1(-1.,AMIN1(+1.,QCEY)) + INAY=IFIX(QCEY) + IF (INAY.NE.0) INAY=(INAY+3)/2 +C +C Examine the user-window linear-log flags. +C + QLUX=AMAX1(-1.,AMIN1(1.,QLUX)) + QLUY=AMAX1(-1.,AMIN1(1.,QLUY)) +C +C Examine the axis parameters. +C + QLUD=ABS(QLUY) + INAD=INAY + UMIN=YBUW + UMAX=YTUW + QMIN=YBUW + QMAX=YTUW +C + I=0 +C + 101 I=I+1 + IF (I.EQ.5) GO TO 104 +C + IF (I.EQ.3) THEN + QLUD=ABS(QLUX) + INAD=INAX + UMIN=XLUW + UMAX=XRUW + QMIN=XLUW + QMAX=XRUW + END IF +C + QDAX(I)=AMAX1(-1.,AMIN1(4.,QDAX(I))) + IF (QDAX(I).LE.0.) GO TO 102 + QLUA(I)=QLUD + QBTP(I)=QBTD(I) + IF (QBTD(I).EQ.SVAL(1).OR.QBTD(I).EQ.SVAL(2)) QBTP(I)=1.+QLUD + QBTP(I)=AMAX1(0.,AMIN1(3.,QBTP(I))) + IF (QBTD(I).EQ.SVAL(2)) QBTD(I)=QBTP(I) +C + CALL AGEXAX (I,SVAL,UMIN,UMAX,INAD-I,QLUD,FUNS(I),QBTP(I),BASD(I), + + BASE(I),QMJD(I),QMND(I),QMNT(I),QLTD(I),QLTP(I), + + QLED(I),QLEX(I),QLFD(I),QLFL(I),QMIN,QMAX) +C + QSPA(I)=AMAX1(0.,AMIN1(1.,QSPA(I))) + IF (QJDP(I).EQ.SVAL(1).OR.QJDP(I).EQ.SVAL(2)) QJDP(I)=65535. + IF (QNDP(I).EQ.SVAL(1).OR.QNDP(I).EQ.SVAL(2)) QNDP(I)=65535. +C + 102 IF (I.EQ.2) THEN + YBUW=QMIN + YTUW=QMAX + ELSE IF (I.EQ.4) THEN + XLUW=QMIN + XRUW=QMAX + END IF +C + GO TO 101 +C +C Examine the user-window min-max/max-min ordering parameters. Compute +C final values of the user-window edge parameters. +C + 104 QOVX=AMAX1(0.,AMIN1(1.,QOVX)) + IF (QOVX.EQ.0.) GO TO 105 + TEMP=XLUW + XLUW=XRUW + XRUW=TEMP +C + 105 QOVY=AMAX1(0.,AMIN1(1.,QOVY)) + IF (QOVY.EQ.0.) GO TO 106 + TEMP=YBUW + YBUW=YTUW + YTUW=TEMP +C +C Determine the exact size and shape of the curve window. +C + 106 XLGW=XLGF*WOFP + XRGW=XRGF*WOFP + YBGW=YBGF*HOFP + YTGW=YTGF*HOFP +C + XLCW=XLGW+XLGD*(XRGW-XLGW) + XRCW=XLGW+XRGD*(XRGW-XLGW) + YBCW=YBGW+YBGD*(YTGW-YBGW) + YTCW=YBGW+YTGD*(YTGW-YBGW) +C + WCWP=XRCW-XLCW + HCWP=YTCW-YBCW +C + ARWH=WCWP/HCWP +C + IF (SOGD) 107,115,108 +C + 107 DRWH=ABS(SOGD) + GO TO 111 +C + 108 DRWH=ABS((XRUW-XLUW)/(YTUW-YBUW)) + IF (SOGD-1.) 109,110,110 +C + 109 IF (DRWH.LT.SOGD.OR.(1./DRWH).LT.SOGD) GO TO 115 + GO TO 111 +C + 110 IF (DRWH.GT.SOGD.OR.(1./DRWH).GT.SOGD) DRWH=1. +C + 111 IF (DRWH-ARWH) 112,115,113 +C + 112 XLCW=XLCW+.5*(WCWP-HCWP*DRWH) + XRCW=XRCW-.5*(WCWP-HCWP*DRWH) + GO TO 114 +C + 113 YBCW=YBCW+.5*(HCWP-WCWP/DRWH) + YTCW=YTCW-.5*(HCWP-WCWP/DRWH) +C + 114 WCWP=XRCW-XLCW + HCWP=YTCW-YBCW +C + 115 SCWP=AMIN1(WCWP,HCWP) +C + XLGW=(XLGW-XLCW)/WCWP + XRGW=(XRGW-XLCW)/WCWP + YBGW=(YBGW-YBCW)/HCWP + YTGW=(YTGW-YBCW)/HCWP +C + XLCW=XLCW/WOFP + XRCW=XRCW/WOFP + YBCW=YBCW/HOFP + YTCW=YTCW/HOFP +C +C Make sure the number of dash patterns is in range. +C + QODP=AMAX1(-26.,AMIN1(+26.,QODP)) + IF (QODP.EQ.0.) QODP=-1. +C +C Examine the windowing parameter. +C + QWND=AMAX1(0.,AMIN1(1.,QWND)) +C +C Do a test run of the routine AGLBLS to find out how much space will be +C required for labels in each of the six label boxes. +C + QDLB=AMAX1(0.,AMIN1(2.,QDLB)) + IDLB=IFIX(QDLB) + LBIM=IFIX(QBIM) +C + CALL AGLBLS (-IDLB,WCWP,HCWP,FLLB,LBIM,FLLN,DBOX,SBOX,RBOX) +C +C Compute the desired and smallest-possible widths of the labels in +C boxes 1 and 2. +C + DWB1=AMAX1(0.,DBOX(1,2)-DBOX(1,1)) + SWB1=AMAX1(0.,SBOX(1,2)-SBOX(1,1)) + DWB2=AMAX1(0.,DBOX(2,2)-DBOX(2,1)) + SWB2=AMAX1(0.,SBOX(2,2)-SBOX(2,1)) +C +C Compute the desired and smallest-possible heights of the labels in +C boxes 3 and 4. +C + DHB3=AMAX1(0.,DBOX(3,4)-DBOX(3,3)) + SHB3=AMAX1(0.,SBOX(3,4)-SBOX(3,3)) + DHB4=AMAX1(0.,DBOX(4,4)-DBOX(4,3)) + SHB4=AMAX1(0.,SBOX(4,4)-SBOX(4,3)) +C +C Do test runs of AGAXIS for each of the four axes to see how much space +C will be required for numeric labels. +C + I=0 +C + 118 I=I+1 + IF (I.EQ.5) GO TO 128 +C + XYPI=FLOAT(1-MOD(I,2)) + IF (QDAX(I).EQ.0.) GO TO 121 + IF (PING(I).NE.SVAL(1)) XYPI=PING(I) +C + IF (I.GE.3) GO TO 119 +C + XYMN=XLGW + XYMX=XRGW + IF (PINU(I).EQ.SVAL(1)) GO TO 120 + XYPI=(PINU(I)-XLUW)/(XRUW-XLUW) + IF (QLUX.NE.0.) XYPI=(ALOG10(PINU(I))-ALOG10(XLUW))/ + + (ALOG10(XRUW)-ALOG10(XLUW)) + GO TO 120 +C + 119 XYMN=YBGW + XYMX=YTGW + IF (PINU(I).EQ.SVAL(1)) GO TO 120 + XYPI=(PINU(I)-YBUW)/(YTUW-YBUW) + IF (QLUY.NE.0.) XYPI=(ALOG10(PINU(I))-ALOG10(YBUW))/ + + (ALOG10(YTUW)-ALOG10(YBUW)) +C + 120 XYPI=AMAX1(XYMN,AMIN1(XYMX,XYPI)) +C + 121 GO TO (122,123,124,125) , I +C +C Left y axis. +C + 122 XBGA(1)=XYPI + YBGA(1)=0. + UBGA(1)=YBUW + XNDA(1)=XYPI + YNDA(1)=1. + UNDA(1)=YTUW + WNLL(1)=XYPI-XLGW-DWB1 + WNLR(1)=XRGW-XYPI-DWB2 + GO TO 126 +C +C Right y axis. +C + 123 XBGA(2)=XYPI + YBGA(2)=1. + UBGA(2)=YTUW + XNDA(2)=XYPI + YNDA(2)=0. + UNDA(2)=YBUW + WNLL(2)=XRGW-XYPI-DWB2 + WNLR(2)=XYPI-XLGW-DWB1 + GO TO 126 +C +C Bottom x axis. +C + 124 XBGA(3)=1. + YBGA(3)=XYPI + UBGA(3)=XRUW + XNDA(3)=0. + YNDA(3)=XYPI + UNDA(3)=XLUW + WNLL(3)=XYPI-YBGW-DHB3 + WNLR(3)=YTGW-XYPI-DHB4 + GO TO 126 +C +C Top x axis. +C + 125 XBGA(4)=0. + YBGA(4)=XYPI + UBGA(4)=XLUW + XNDA(4)=1. + YNDA(4)=XYPI + UNDA(4)=XRUW + WNLL(4)=YTGW-XYPI-DHB4 + WNLR(4)=XYPI-YBGW-DHB3 +C + 126 IF (QDAX(I).GT.0.) THEN + CALL AGAXIS (I,QDAX(I),QSPA(I),WCWP,HCWP,XBGA(I),YBGA(I), + + XNDA(I),YNDA(I),QLUA(I),UBGA(I),UNDA(I),FUNS(I), + + QBTP(I),BASE(I),QJDP(I),WMJL(I),WMJR(I),QMNT(I), + + QNDP(I),WMNL(I),WMNR(I),QLTP(I),QLEX(I),QLFL(I), + + QLOF(I),QLOS(I),DNLA(I),WCLM(I),WCLE(I),RFNL(I), + + QCIM(I),QCIE(I),WNLL(I),WNLR(I),10.,11.) + ELSE + WNLL(I)=0. + WNLR(I)=0. + END IF + GO TO 118 +C +C If no labels are to be drawn, AGSTUP is now done. +C + 128 IF (IDLB.EQ.0) GO TO 138 +C +C Check the label boxes, moving and/or shrinking them to prevent the +C labels in them from overlapping any portion of any axis. The labels +C on an axis may have to be moved, as well. +C +C Box 1 - to the left of the curve window. +C + IF (DBOX(1,2).GT.0.) GO TO 903 + DBOX(1,2)=AMIN1(0.,XBGA(1)-WNLL(1),XBGA(2)-WNLR(2)) + DBOX(1,1)=DBOX(1,2)-DWB1 + IF (DBOX(1,1).LT.XLGW) DBOX(1,1)=AMIN1(DBOX(1,2)-SWB1,XLGW) + IF (DBOX(1,1).GE.XLGW) GO TO 130 + DBOX(1,1)=XLGW + DBOX(1,2)=XLGW+SWB1 + TEMP=XBGA(1)-WNLL(1)-DBOX(1,2) + IF (TEMP.GE.0.) GO TO 129 + WNLL(1)=WNLL(1)+TEMP + WNLR(1)=WNLR(1)-TEMP + 129 TEMP=XBGA(2)-WNLR(2)-DBOX(1,2) + IF (TEMP.GE.0.) GO TO 130 + WNLL(2)=WNLL(2)-TEMP + WNLR(2)=WNLR(2)+TEMP +C +C Box 2 - to the right of the curve window. +C + 130 IF (DBOX(2,1).LT.1.) GO TO 904 + DBOX(2,1)=AMAX1(1.,XBGA(1)+WNLR(1),XBGA(2)+WNLL(2)) + DBOX(2,2)=DBOX(2,1)+DWB2 + IF (DBOX(2,2).GT.XRGW) DBOX(2,2)=AMAX1(DBOX(2,1)+SWB2,XRGW) + IF (DBOX(2,2).LE.XRGW) GO TO 132 + DBOX(2,1)=XRGW-SWB2 + DBOX(2,2)=XRGW + TEMP=XBGA(1)+WNLR(1)-DBOX(2,1) + IF (TEMP.LE.0.) GO TO 131 + WNLL(1)=WNLL(1)+TEMP + WNLR(1)=WNLR(1)-TEMP + 131 TEMP=XBGA(2)+WNLL(2)-DBOX(2,1) + IF (TEMP.LE.0.) GO TO 132 + WNLL(2)=WNLL(2)-TEMP + WNLR(2)=WNLR(2)+TEMP +C +C Box 3 - below the curve window. +C + 132 IF (DBOX(3,4).GT.0.) GO TO 905 + DBOX(3,4)=AMIN1(0.,YBGA(3)-WNLL(3),YBGA(4)-WNLR(4)) + DBOX(3,3)=DBOX(3,4)-DHB3 + IF (DBOX(3,3).LT.YBGW) DBOX(3,3)=AMIN1(DBOX(3,4)-SHB3,YBGW) + IF (DBOX(3,3).GE.YBGW) GO TO 134 + DBOX(3,3)=YBGW + DBOX(3,4)=YBGW+SHB3 + TEMP=YBGA(3)-WNLL(3)-DBOX(3,4) + IF (TEMP.GE.0.) GO TO 133 + WNLL(3)=WNLL(3)+TEMP + WNLR(3)=WNLR(3)-TEMP + 133 TEMP=YBGA(4)-WNLR(4)-DBOX(3,4) + IF (TEMP.GE.0.) GO TO 134 + WNLL(4)=WNLL(4)-TEMP + WNLR(4)=WNLR(4)+TEMP +C +C Box 4 - above the curve window. +C + 134 IF (DBOX(4,3).LT.1.) GO TO 906 + DBOX(4,3)=AMAX1(1.,YBGA(3)+WNLR(3),YBGA(4)+WNLL(4)) + DBOX(4,4)=DBOX(4,3)+DHB4 + IF (DBOX(4,4).GT.YTGW) DBOX(4,4)=AMAX1(DBOX(4,3)+SHB4,YTGW) + IF (DBOX(4,4).LE.YTGW) GO TO 136 + DBOX(4,3)=YTGW-SHB4 + DBOX(4,4)=YTGW + TEMP=YBGA(3)+WNLR(3)-DBOX(4,3) + IF (TEMP.LE.0.) GO TO 135 + WNLL(3)=WNLL(3)+TEMP + WNLR(3)=WNLR(3)-TEMP + 135 TEMP=YBGA(4)+WNLL(4)-DBOX(4,3) + IF (TEMP.LE.0.) GO TO 136 + WNLL(4)=WNLL(4)-TEMP + WNLR(4)=WNLR(4)+TEMP +C +C Box 5 - the curve window itself. +C + 136 IF (DBOX(5,1).LT.0..OR.DBOX(5,2).GT.1..OR. + + DBOX(5,3).LT.0..OR.DBOX(5,4).GT.1.) GO TO 907 +C + DBOX(5,1)=AMAX1(XLGW,XBGA(1)+WNLR(1)) + DBOX(5,2)=AMIN1(XRGW,XBGA(2)-WNLR(2)) + DBOX(5,3)=AMAX1(YBGW,YBGA(3)+WNLR(3)) + DBOX(5,4)=AMIN1(YTGW,YBGA(4)-WNLR(4)) +C +C Do a final check on all boxes for labels running outside the graph +C window. +C + DO 137 NBOX=1,6 + DBOX(NBOX,1)=AMAX1(XLGW,DBOX(NBOX,1)) + DBOX(NBOX,2)=AMIN1(XRGW,DBOX(NBOX,2)) + DBOX(NBOX,3)=AMAX1(YBGW,DBOX(NBOX,3)) + DBOX(NBOX,4)=AMIN1(YTGW,DBOX(NBOX,4)) + 137 CONTINUE +C +C Do a "SET" call for the user and return. +C + 138 CALL SET (XLCW,XRCW,YBCW,YTCW,XLUW,XRUW,YBUW,YTUW, + + 1+IABS(IFIX(QLUX))*2+IABS(IFIX(QLUY))) +C + RETURN +C +C Error exits. +C + 901 CALL SETER ('AGSTUP - GRAPH WINDOW IMPROPERLY SPECIFIED',20,2) +C + 902 CALL SETER ('AGSTUP - GRID WINDOW IMPROPERLY SPECIFIED',21,2) +C + 903 CALL SETER ('AGSTUP - LEFT LABELS IMPROPERLY SPECIFIED',22,2) +C + 904 CALL SETER ('AGSTUP - RIGHT LABELS IMPROPERLY SPECIFIED',23,2) +C + 905 CALL SETER ('AGSTUP - BOTTOM LABELS IMPROPERLY SPECIFIED',24,2) +C + 906 CALL SETER ('AGSTUP - TOP LABELS IMPROPERLY SPECIFIED',25,2) +C + 907 CALL SETER ('AGSTUP - INTERIOR LABELS IMPROPERLY SPECIFIED',26,2) +C + END diff --git a/sys/gio/ncarutil/autograph/agutol.f b/sys/gio/ncarutil/autograph/agutol.f new file mode 100644 index 00000000..02dbf64c --- /dev/null +++ b/sys/gio/ncarutil/autograph/agutol.f @@ -0,0 +1,49 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE AGUTOL (IAXS,FUNS,IDMA,VINP,VOTP) +C +C This routine is called to perform the mapping from the "user system" +C along an axis to the "label system" along that axis or vice-versa. It +C may be replaced by the user in order to create a desired graph. The +C arguments are as follows: +C +C -- IAXS is the index of the axis being drawn. Its value is 1, 2, 3, +C or 4, implying the left, right, bottom, or top axis, respectively. +C +C -- FUNS is the value of the parameter 'AXIS/s/FUNCTION.', which may be +C used to select the desired mapping function for axis IAXS. It is +C recommended that the default value (zero) be used to specify the +C identity mapping. A non-zero value may be integral (1., 2., etc.) +C and serve purely to select the code to be executed or it may be the +C value of a real parameter in the equations defining the mapping. +C +C -- IDMA specifies the direction of the mapping. A value greater than +C zero indicates that VINP is a value in the user system and that +C VOTP is to be a value in the label system, a value less than zero +C the opposite. +C +C -- VINP is an input value in one coordinate system along the axis. +C +C -- VOTP is an output value in the other coordinate system along the +C axis. +C +C The default routine simply defines the identity mapping for all axes. +C + VOTP=VINP +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/anotat.f b/sys/gio/ncarutil/autograph/anotat.f new file mode 100644 index 00000000..ed46025b --- /dev/null +++ b/sys/gio/ncarutil/autograph/anotat.f @@ -0,0 +1,63 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE ANOTAT (LABX,LABY,LBAC,LSET,NDSH,DSHL) +C + CHARACTER*(*) LABX,LABY,DSHL(*) +C +C The routine ANOTAT resets background annotation. +C +C Declare the type of the dash-pattern-parameter-name generator. +C + CHARACTER*16 AGDSHN +C +C Set up the x-axis label. +C + IF (ICHAR(LABX(1:1)).NE.0) THEN + CALL AGSETC ('LABE/NAME.', 'B') + CALL AGSETI ('LINE/NUMB.',-100) + CALL AGSETC ('LINE/TEXT.',LABX) + END IF +C +C Set up the y-axis label. +C + IF (ICHAR(LABY(1:1)).NE.0) THEN + CALL AGSETC ('LABE/NAME.', 'L') + CALL AGSETI ('LINE/NUMB.', 100) + CALL AGSETC ('LINE/TEXT.',LABY) + END IF +C +C Set up the background the user wants. +C + IF (LBAC.GT.0) CALL AGSETI ('BACK.',LBAC) +C +C Set the parameter ISET. +C + IF (LSET.NE.0) CALL AGSETI ('SET .',LSET) +C +C Set up the dash patterns the user wants. +C + IF (NDSH.NE.0) THEN + IDSH=MIN0(26,NDSH) + CALL AGSETI ('DASH/SELE.',IDSH) + IF (IDSH.LT.0) RETURN + DO 101 I=1,IDSH + CALL AGSETC (AGDSHN(I),DSHL(I)) + 101 CONTINUE + END IF +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/displa.f b/sys/gio/ncarutil/autograph/displa.f new file mode 100644 index 00000000..0749b29b --- /dev/null +++ b/sys/gio/ncarutil/autograph/displa.f @@ -0,0 +1,33 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE DISPLA (LFRA,LROW,LTYP) +C +C The subroutine DISPLA resets the parameters IFRA, IROW, and/or LLUX +C and LLUY. +C + IF (LFRA.NE.0) CALL AGSETI ('FRAM.', MAX0(1,MIN0(3,LFRA))) +C + IF (LROW.NE.0) CALL AGSETI ('ROW .',LROW) +C + IF (LTYP.EQ.0) RETURN +C + ITYP=MAX0(1,MIN0(4,LTYP)) + CALL AGSETI ('X/LOGA.', (1-ITYP)/2) + CALL AGSETI ('Y/LOGA.',MOD(1-ITYP,2)) +C + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/ezmxy.f b/sys/gio/ncarutil/autograph/ezmxy.f new file mode 100644 index 00000000..bc8f6352 --- /dev/null +++ b/sys/gio/ncarutil/autograph/ezmxy.f @@ -0,0 +1,67 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE EZMXY (XDRA,YDRA,IDXY,MANY,NPTS,LABG) +C + REAL XDRA(*),YDRA(*) +C + CHARACTER*(*) LABG +C +C The routine EZMXY draws many curves, each of them defined by points of +C the form (XDRA(I,J),YDRA(I,J)) or (XDRA(J,I),YDRA(J,I)) or, possibly, +C (XDRA(I),YDRA(I,J)) or (XDRA(I),YDRA(J,I)), for I = 1, 2, ... NPTS and +C for J = 1, 2, ... MANY. (YDRA is actually dimensioned IDXY by * .) +C +C Do statistics-gathering call. +C + LOGICAL Q8Q4 + SAVE Q8Q4 + DATA Q8Q4 /.TRUE./ + IF (Q8Q4) THEN + CALL Q8QST4('GRAPHX','AUTOGRAPH','EZMXY','VERSION 07') + Q8Q4 = .FALSE. + ENDIF +C +C +NOAO +C + call agdflt +C +C -NOAO + CALL AGGETI ('SET .',ISET) + CALL AGGETI ('FRAM.',IFRA) + CALL AGGETI ('DASH/SELE.',IDSH) +C + CALL AGEZSU (4,XDRA,YDRA,IDXY,MANY,NPTS,LABG,IIVX,IIEX,IIVY,IIEY) + CALL AGBACK +C + IF (ISET.LT.0) GO TO 102 +C + DO 101 I=1,MANY + INXD=1+(I-1)*IIVX + INYD=1+(I-1)*IIVY + KDSH=ISIGN(I,IDSH) + CALL AGCURV (XDRA(INXD),IIEX,YDRA(INYD),IIEY,NPTS,KDSH) + 101 CONTINUE +C + 102 IF (IFRA.EQ.1) CALL FRAME +C +C +NOAO +C + call initag +C +C -NOAO + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/ezmy.f b/sys/gio/ncarutil/autograph/ezmy.f new file mode 100644 index 00000000..e406465b --- /dev/null +++ b/sys/gio/ncarutil/autograph/ezmy.f @@ -0,0 +1,65 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE EZMY (YDRA,IDXY,MANY,NPTS,LABG) +C + REAL XDRA(1),YDRA(*) +C + CHARACTER*(*) LABG +C +C The routine EZMY draws many curves, each of them defined by points of +C the form (I,YDRA(I,J)) or (I,YDRA(J,I)), for I = 1, 2, ... NPTS and +C for J = 1, 2, ... MANY. (YDRA is actually dimensioned IDXY by * .) +C +C Do statistics-gathering call. +C + LOGICAL Q8Q4 + SAVE Q8Q4 + DATA Q8Q4 /.TRUE./ + IF (Q8Q4) THEN + CALL Q8QST4('GRAPHX','AUTOGRAPH','EZMY','VERSION 07') + Q8Q4 = .FALSE. + ENDIF +C +C +NOAO +C + call agdflt +C +C -NOAO + CALL AGGETI ('SET .',ISET) + CALL AGGETI ('FRAM.',IFRA) + CALL AGGETI ('DASH/SELE.',IDSH) +C + CALL AGEZSU (3,XDRA,YDRA,IDXY,MANY,NPTS,LABG,IIVX,IIEX,IIVY,IIEY) + CALL AGBACK +C + IF (ISET.LT.0) GO TO 102 +C + DO 101 I=1,MANY + INYD=1+(I-1)*IIVY + KDSH=ISIGN(I,IDSH) + CALL AGCURV (XDRA,0,YDRA(INYD),IIEY,NPTS,KDSH) + 101 CONTINUE +C + 102 IF (IFRA.EQ.1) CALL FRAME +C +C +NOAO +C + call initag +C +C -NOAO + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/ezxy.f b/sys/gio/ncarutil/autograph/ezxy.f new file mode 100644 index 00000000..e6ef3b5e --- /dev/null +++ b/sys/gio/ncarutil/autograph/ezxy.f @@ -0,0 +1,57 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE EZXY (XDRA,YDRA,NPTS,LABG) +C + REAL XDRA(*),YDRA(*) +C + CHARACTER*(*) LABG +C +C The routine EZXY draws one curve through the points (XDRA(I),YDRA(I)), +C for I = 1, 2, ... NPTS. +C +C Do statistics-gathering call. +C + LOGICAL Q8Q4 + SAVE Q8Q4 + DATA Q8Q4 /.TRUE./ + IF (Q8Q4) THEN + CALL Q8QST4('GRAPHX','AUTOGRAPH','EZXY','VERSION 07') + Q8Q4 = .FALSE. + ENDIF +C +C +NOAO +C + call agdflt +C +C -NOAO + CALL AGGETI ('SET .',ISET) + CALL AGGETI ('FRAM.',IFRA) +C + CALL AGEZSU (2,XDRA,YDRA,NPTS,1,NPTS,LABG,IIVX,IIEX,IIVY,IIEY) + CALL AGBACK +C + IF (ISET.GE.0) CALL AGCURV (XDRA,1,YDRA,1,NPTS,1) +C + IF (IFRA.EQ.1) CALL FRAME +C +C +NOAO +C + call initag +C +C -NOAO + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/ezy.f b/sys/gio/ncarutil/autograph/ezy.f new file mode 100644 index 00000000..3be54a03 --- /dev/null +++ b/sys/gio/ncarutil/autograph/ezy.f @@ -0,0 +1,57 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE EZY (YDRA,NPTS,LABG) +C + REAL XDRA(1),YDRA(*) +C + CHARACTER*(*) LABG +C +C The subroutine EZY draws one curve through the points (I,YDRA(I)), for +C I = 1, 2, ... NPTS. +C +C Do statistics-gathering call. +C + LOGICAL Q8Q4 + SAVE Q8Q4 + DATA Q8Q4 /.TRUE./ + IF (Q8Q4) THEN + CALL Q8QST4('GRAPHX','AUTOGRAPH','EZY','VERSION 07') + Q8Q4 = .FALSE. + ENDIF +C +C +NOAO +C + call agdflt +C +C -NOAO + CALL AGGETI ('SET .',ISET) + CALL AGGETI ('FRAM.',IFRA) +C + CALL AGEZSU (1,XDRA,YDRA,NPTS,1,NPTS,LABG,IIVX,IIEX,IIVY,IIEY) + CALL AGBACK +C + IF (ISET.GE.0) CALL AGCURV (XDRA,0,YDRA,1,NPTS,1) +C + IF (IFRA.EQ.1) CALL FRAME +C +C +NOAO +C + call initag +C +C -NOAO + RETURN +C + END diff --git a/sys/gio/ncarutil/autograph/idiot.f b/sys/gio/ncarutil/autograph/idiot.f new file mode 100644 index 00000000..0e2ce5e5 --- /dev/null +++ b/sys/gio/ncarutil/autograph/idiot.f @@ -0,0 +1,64 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C --------------------------------------------------------------------- +C + SUBROUTINE IDIOT (XDRA,YDRA,NPTS,LTYP,LDSH,LABX,LABY,LABG,LFRA) +C + REAL XDRA(*),YDRA(*) +C + INTEGER LDSH(*) +C + CHARACTER*(*) LABX,LABY,LABG +C + CHARACTER*16 AGBNCH +C +C This is an implementation of the routine from which AUTOGRAPH grew. +C It should work pretty much as the original did (if you can figure out +C what that was). +C +C Do statistics-gathering call. +C + LOGICAL Q8Q4 + SAVE Q8Q4 + DATA Q8Q4 /.TRUE./ + IF (Q8Q4) THEN + CALL Q8QST4('GRAPHX','AUTOGRAPH','IDIOT','VERSION 07') + Q8Q4 = .FALSE. + ENDIF +C +C +NOAO +C + call agdflt +C +C -NOAO + CALL ANOTAT (LABX,LABY,1,2-ISIGN(1,NPTS),1,AGBNCH(LDSH)) +C + CALL DISPLA (2-MAX0(-1,MIN0(1,LFRA)),1,LTYP) +C + CALL AGEZSU (5,XDRA,YDRA,IABS(NPTS),1,IABS(NPTS),LABG,IIVX,IIEX, + + IIVY,IIEY) + CALL AGBACK +C + CALL AGCURV (XDRA,1,YDRA,1,IABS(NPTS),1) +C + IF (LFRA.GT.0) CALL FRAME +C +C +NOAO +C + call plotit (0, 0, 2) + call initut +C +C -NOAO + RETURN + END diff --git a/sys/gio/ncarutil/autograph/mkpkg b/sys/gio/ncarutil/autograph/mkpkg new file mode 100644 index 00000000..8af0a0d4 --- /dev/null +++ b/sys/gio/ncarutil/autograph/mkpkg @@ -0,0 +1,62 @@ +# Make the NCAR AUTOGRAPH library. + +$checkout libncar.a lib$ +$update libncar.a +$checkin libncar.a lib$ +$exit + +libncar.a: + agdflt.f + agaxis.f + agback.f + agbnch.f + agchax.f + agchcu.f + agchil.f + agchnl.f + agctcs.f + agctko.f + agcurv.f + agdash.f + agdlch.f + agdshn.f + agexax.f + agexus.f + agezsu.f + agfpbn.f + agftol.f + aggetc.f + aggetf.f + aggeti.f + aggetp.f + aggtch.f + aginit.f + agkurv.f + aglbls.f + agmaxi.f + agmini.f + agnumb.f + agppid.f + agpwrt.f + agqurv.f + agrpch.f + agrstr.f + agsave.f + agscan.f + agsetc.f + agsetf.f + agseti.f + agsetp.f + agsrch.f + agstch.f + agstup.f + agutol.f + anotat.f + displa.f + ezmxy.f + ezmy.f + ezxy.f + ezy.f + idiot.f + pstr.x + ; diff --git a/sys/gio/ncarutil/autograph/pstr.x b/sys/gio/ncarutil/autograph/pstr.x new file mode 100644 index 00000000..a40c9fc1 --- /dev/null +++ b/sys/gio/ncarutil/autograph/pstr.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# PSTR -- Print a character string from a fortran program. The string is +# passed as an unpacked spp string, the result of f77upk in the calling +# program. PSTR is called by agppid.f in the autograph package. + +procedure pstr (spp_string) + +char spp_string[ARB] + +begin + call eprintf ("%s\n") + call pargstr (spp_string) +end diff --git a/sys/gio/ncarutil/conbd.f b/sys/gio/ncarutil/conbd.f new file mode 100644 index 00000000..eaaf2df5 --- /dev/null +++ b/sys/gio/ncarutil/conbd.f @@ -0,0 +1,111 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C BLOCKDATA CONBD + subroutine conbd + integer first, temp + common /conflg/ first + COMMON /CONRE1/ IOFFP ,SPVAL + COMMON /CONRE2/ IX ,IY ,IDX ,IDY , + 1 IS ,ISS ,NP ,CV , + 2 INX(8) ,INY(8) ,IR(80000) ,NR +c +noao: dimension of stline ir array increased from 20000 to 80000 6-93 + COMMON /CONRE4/ ISIZEL ,ISIZEM ,ISIZEP ,NREP, + 1 NCRT ,ILAB ,NULBLL ,IOFFD, + 2 EXT ,IOFFM ,ISOLID ,NLA, + 3 NLM ,XLT ,YBT ,SIDE + COMMON /RECINT/ IRECMJ ,IRECMN ,IRECTX +C + SAVE +C +C DATA IOFFP,SPVAL/0,0.0/ + data temp /1/ + first = temp + IOFFP = 0 + SPVAL = 0.0 +C DATA ISIZEL,ISIZEM,ISIZEP,NLA,NLM,XLT,YBT,SIDE,ISOLID,NREP,NCRT/ +C 1 1, 2, 0, 16, 40,.05,.05, .9, 1023, 6, 4 / + if (first .ne. 1) then + return + endif + + temp = 0 + +c ISIZEL = 1 +c noao: size of contour labels seemed too large. Changed from 1 to 0 + isizel = 0 + ISIZEM = 2 + ISIZEP = 0 + NLA = 16 + NLM = 40 + XLT = .05 + YBT = .05 + SIDE = .9 + ISOLID = 1023 + NREP = 4 + NCRT = 2 +C DATA EXT,IOFFD,NULBLL,IOFFM,ILAB/.25,0,3,0,1/ +C +noao value of "extreme" axes ratios changed from 1/4 to 1/16 (ShJ 6-10-88) +C EXT = .25 + EXT = .0625 +C -noao + IOFFD = 0 + NULBLL = 3 + IOFFM = 0 + ILAB = 1 +C DATA INX(1),INX(2),INX(3),INX(4),INX(5),INX(6),INX(7),INX(8)/ +C 1 -1 , -1 , 0 , 1 , 1 , 1 , 0 , -1 / + INX(1) = -1 + INX(2) = -1 + INX(3) = 0 + INX(4) = 1 + INX(5) = 1 + INX(6) = 1 + INX(7) = 0 + INX(8) = -1 +C DATA INY(1),INY(2),INY(3),INY(4),INY(5),INY(6),INY(7),INY(8)/ +C 1 0 , 1 , 1 , 1 , 0 , -1 , -1 , -1 / + INY(1) = 0 + INY(2) = 1 + INY(3) = 1 + INY(4) = 1 + INY(5) = 0 + INY(6) = -1 + INY(7) = -1 + INY(8) = -1 +C DATA NR/500/ +c +noao: dimension of stline array increased from 500 to 5000 6March87 +c +noao: dimension of stline array increased from 5000 to 20000 Jan90 +c +noao: dimension of stline array increased from 20000 to 80000 6-93 + NR = 80000 +C DATA IRECMJ,IRECMN,IRECTX/ 1 , 1 , 1/ +c +noao: value of irecmj changed so major divisions are high intensity + IRECMJ = 2 + IRECMN = 1 + IRECTX = 1 +C +C - noao +C +C REVISION HISTORY--- +C +C JANUARY 1980 ADDED REVISION HISTORY AND CHANGED LIBRARY NAME +C FROM CRAYLIB TO PORTLIB FOR MOVE TO PORTLIB +C +C MAY 1980 ARRAYS IWORK AND ENCSCR, PREVIOUSLY TOO SHORT FOR +C SHORT-WORD-LENGTH MACHINES, LENGTHENED. SOME +C DOCUMENTATION CLARIFIED AND CORRECTED. +C +C JUNE 1984 CONVERTED TO FORTRAN 77 AND TO GKS +C------------------------------------------------------------------- +C + END diff --git a/sys/gio/ncarutil/conbdn.f b/sys/gio/ncarutil/conbdn.f new file mode 100644 index 00000000..cd7ca00d --- /dev/null +++ b/sys/gio/ncarutil/conbdn.f @@ -0,0 +1,342 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +c +noao: block data conbdn changed to run time initialization +c BLOCKDATA CONBDN + subroutine conbdn +C +C +C +C COMMON DATA +C +C NOTE THE COMMON BLOCKS LISTED INCLUDE ALL THE COMMON USED BY +C THE ENTIRE CONRAN FAMILY, NOT ALL MEMBERS WILL USE ALL +C THE COMMON DATA. +C +C CONRA1 +C CL-ARRAY OF CONTOUR LEVELS +C NCL-NUMBER OF CONTOUR LEVELS +C OLDZ-Z VALUE OF LEFT NEIGHBOR TO CURRENT LOCATION +C PV-ARRAY OF PREVIOUS ROW VALUES +C HI-LARGEST CONTOUR PLOTTED +C FLO-LOWEST CONTOUR PLOTTED +C FINC-INCREMENT LEVEL BETWEEN EQUALLY SPACED CONTOURS +C CONRA2 +C REPEAT-FLAG TO TRIANGULATE AND DRAW OR JUST DRAW +C EXTRAP-PLOT DATA OUTSIDE OF CONVEX DATA HULL +C PER-PUT PERIMETER ARROUND PLOT +C MESS-FLAG TO INDICATE MESSAGE OUTPUT +C ISCALE-SCALING SWITCH +C LOOK-PLOT TRIANGLES FLAG +C PLDVLS-PLOT THE DATA VALUES FLAG +C GRD-PLOT GRID FLAG +C CON-USER SET OR PROGRAM SET CONTOURS FLAG +C CINC-USER OR PROGRAM SET INCREMENT FLAG +C CHILO-USER OR PROGRAM SET HI LOW CONTOURS +C LABON-FLAG TO CONTROL LABELING OF CONTOURS +C PMIMX-FLAG TO CONTROL THE PLOTTING OF MIN"S +C AND MAX"S +C SCALE-THE SCALE FACTOR FOR CONTOUR LINE VALUES +C AND MIN , MAX PLOTTED VALUES +C FRADV-ADVANCE FRAME BEFORE PLOTTING TRIANGUALTION +C EXTRI-ONLY PLOT TRIANGULATION +C BPSIZ-BREAKPOINT SIZE FOR DASHPATTERNS +C LISTOP-LIST OPTIONS ON UNIT6 FLAG +C CONRA3 +C IREC-PORT RECOVERABLE ERROR FLAG +C CONRA4 +C NCP-NUMBER OF DATA POINTS USED AT EACH POINT FOR +C POLYNOMIAL CONSTRUCTION. +C NCPSZ-MAX SIZE ALLOWED FOR NCP +C CONRA5 +C NIT-FLAG TO INDICATE STATUS OF SEARCH DATA BASE +C ITIPV-LAST TRIANGLE INTERPOLATION OCCURRED IN +C CONRA6 +C XST-X COORDINATE START POINT FOR CONTOURING +C YST-Y COORDINATE START POINT FOR CONTOURING +C XED-X COORDINATE END POINT FOR CONTOURING +C YED-Y COORDINATE END POINT FOR CONTOURING +C STPSZ-STEP SIZE FOR X,Y CHANGE WHEN CONTOURING +C IGRAD-NUMBER OF GRADUATIONS FOR CONTOURING(STEP SIZE) +C IG-RESET VALUE FOR IGRAD +C XRG-X RANGE OF COORDINATES +C YRG-Y RANGE OF COORDINATES +C BORD-PERCENT OF FRAME USED FOR CONTOUR PLOT +C PXST-X PLOTTER START ADDRESS FOR CONTOURS +C PYST-Y PLOTTER START ADDRESS FOR CONTOURS +C PXED-X PLOTTER END ADDRESS FOR CONTOURS +C PYED-Y PLOTTER END ADDRESS FOR CONTOURS +C ITICK-NUMBER OF TICK MARKS FOR GRIDS AND PERIMETERS +C CONRA7 +C TITLE-SWITCH TO INDICATE IF TITLE OPTION ON OR OFF +C ISTRNG-CHARACTER STRING OF TITLE +C ICNT-CHARACTER COUNT OF ISTRNG +C ITLSIZ-SIZE OF TITLE IN PWRIT UNITS +C CONRA8 +C IHIGH-DEFAULT COLOR (INTENSITY) INDEX SETTING +C INMAJ-CONTOUR LEVEL COLOR (INTENSITY) INDEX FOR MAJOR LINES +C INMIN-CONTOUR LEVEL COLOR (INTENSITY) INDEX FOR MINOR LINES +C INLAB-TITLE AND MESSAGE COLOR (INTENSITY) INDEX +C INDAT-DATA VALUE COLOR (INTENSITY) INDEX +C FORM-THE FORMAT FOR PLOTTING THE DATA VALUES +C LEN-THE NUMBER OF CHARACTERS IN THE FORMAT +C IFMT-SIZE OF THE FORMAT FIELD +C LEND-DEFAULT FORMAT LENGTH +C IFMTD-DEFAULT FORMAT FIELD SIZE +C ISIZEP-SIZE OF THE PLOTTED DATA VALUES +C CONRA9 +C X-ARRAY OF X COORDINATES OF CONTOURS DRAWN AT CURRENT CONTOUR +C LEVEL +C Y-ARRAY OF Y COORDINATES OF CONTOURS DRAWN AT CURRENT CONTOUR +C LEVEL +C NP-COUNT IN X AND Y +C MXXY-SIZE OF X AND Y +C TR-TOP RIGHT CORNER VALUE OF CURRENT CELL +C BR-BOTTOM RIGHT CORNER VALUE OF CURRENT CELL +C TL-TOP LEFT CORNER VALUE OF CURRENT CELL +C BL-BOTTOM LEFT CORNER VALUE OF CURRENT CELL +C CONV-CURRENT CONTOUR VALUE +C XN-X POSITION WHERE CONTOUR IS BEING DRAWN +C YN-Y POSITION WHERE CONTOUR IS BEING DRAWN +C ITLL-TRIANGLE WHERE TOP LEFT CORNER OF CURRENT CELL LIES +C IBLL-TRIANGLE OF BOTTOM LEFT CORNER +C ITRL-TRIANGLE OF TOP RIGHT CORNER +C IBRL-TRIANGLE OF BOTTOM LEFT CORNER +C XC-X COORDINATE OF CURRENT CELL +C YC-Y CORRDINATE OF CURRENT CELL +C ITLOC-IN CONJUNCTION WITH PV STORES THE TRIANGLE WHERE PV +C VALUE CAME FROM +C CONR10 +C NT-NUMBER OF TRIANGLES GENERATED +C NL-NUMBER OF LINE SEGMENTS +C NTNL-NT+NL +C JWIPT-POINTER INTO IWK WHERE WHERE TRIANGLE POINT NUMBERS +C ARE STORED +C JWIWL-IN IWK THE LOCATION OF A SCRATCH SPACE +C JWIWP-IN IWK THE LOCATION OF A SCRATCH SPACE +C JWIPL-IN IWK THE LOCATION OF END POINTS FOR BORDER LINE +C SEGMENTS +C IPR-IN WK THE LOCATION OF THE PARTIAL DERIVITIVES AT EACH +C DATA POINT +C ITPV-THE TRIANGLE WHERE THE PREVIOUS VALUE CAME FROM +C CONR11 +C NREP-NUMBER OF REPETITIONS OF DASH PATTERN BEFORE A LABEL +C NCRT-NUMBER OF CRT UNITS FOR A DASH MARK OR BLANK +C ISIZEL-SIZE OF CONTOUR LINE LABELS +C NDASH-ARRAY CONTAINING THE NEGATIVE VALUED CONTOUR DASH +C PATTERN +C MINGAP-NUMBER OF UNLABELED LINES BETWEEN EACH LABELED ONE +C IDASH-POSITIVE VALUED CONTOUR DASH PATTERN +C ISIZEM-SIZE OF PLOTTED MINIMUMS AND MAXIMUMS +C EDASH-EQUAL VALUED CONTOUR DASH PATTERN +C TENS-DEFAULT TENSION SETTING FOR SMOOTHING +C CONR12 +C IXMAX,IYMAX-MAXINUM X AND Y COORDINATES RELATIVE TO THE +C SCRATCH ARRAY, SCRARR +C XMAX,YMAX-MAXIMUM X AND Y COORDINATES RELATIVE TO USERS +C COORDINATE SPACE +C CONR13 +C XVS-ARRAY OF THE X COORD FOR SHIELDING +C YVS-ARRAY OF THE Y COORD FOR SHIELDING +C IXVST-POINTER (VIA LOC) TO THE USERS X ARRAY FOR SHIELDING +C IYVST-POINTER (VIA LOC) TO THE USERS Y ARRAY FOR SHIELDING +C ICOUNT-COUNT OF THE SHIELD ELEMENTS +C SPVAL-SPECIAL VALUE USED TO HALT CONTOURING AT THE SHIELD +C BOUNDRY +C SHIELD-LOGICAL FLAG TO SIGNAL STATUS OF SHIELDING +C SLDPLT-LOGICAL FLAG TO INDICTE STATUS OF SHIEDL PLOTTING +C CONR14 +C LINEAR-C1 LINAER INTERPOLATIN FLAG +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210), + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS, + 1 ISCALE ,LOOK ,PLDVLS ,GRD, + 2 CINC ,CHILO ,CON ,LABON, + 3 PMIMX ,SCALE ,FRADV ,EXTRI, + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED, + 1 STPSZ ,IGRAD ,IG ,XRG, + 2 YRG ,BORD ,PXST ,PYST, + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT, + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR, + 1 BR ,TL ,BL ,CONV, + 2 XN ,YN ,ITLL ,IBLL, + 3 ITRL ,IBRL ,XC ,YC, + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT, + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS, + 1 LOOK ,PLDVLS ,GRD ,LABON, + 2 PMIMX ,FRADV ,EXTRI ,CINC, + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT + COMMON /CONR14/LINEAR + LOGICAL LINEAR + logical first + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH + COMMON /RANINT/ IRANMJ, IRANMN, IRANTX + COMMON /RAQINT/ IRAQMJ, IRAQMN, IRAQTX + COMMON /RASINT/ IRASMJ, IRASMN, IRASTX +C + SAVE +C +C +c +noao: parameter added to avoid clobbering initialization done +c by conop[1-4]. + data first /.true./ + if (.not. first) return + first = .false. +c -noao +C +c DATA ICOUNT,SHIELD,SLDPLT,LINEAR/0,.FALSE.,.FALSE.,.FALSE./ + ICOUNT = 0 + SHIELD = .FALSE. + SLDPLT = .FALSE. + LINEAR = .FALSE. +c +c DATA REPEAT,EXTRAP,PER/.FALSE.,.FALSE.,.TRUE./ + REPEAT = .FALSE. + EXTRAP = .FALSE. + PER = .TRUE. +c +c DATA FRADV,EXTRI,BPSIZ/.TRUE.,.FALSE.,0.0/ + FRADV = .TRUE. + EXTRI = .FALSE. + BPSIZ = 0.0 +c +c DATA TITLE,MESS,LOOK/.FALSE.,.TRUE.,.FALSE./ + TITLE = .FALSE. + MESS = .TRUE. + LOOK = .FALSE. +c +c DATA PLDVLS,GRD/.FALSE.,.FALSE./ + PLDVLS = .FALSE. + GRD = .FALSE. +c +c DATA CON,CINC,CHILO/.FALSE.,.FALSE.,.FALSE./ + CON = .FALSE. + CINC = .FALSE. + CHILO = .FALSE. +c +c DATA SCALE,PMIMX/1.,.FALSE./ + SCALE = 1. + PMIMX = .FALSE. +c +c DATA ISIZEP,ISIZEM,TENS/8,15,2.5/ + ISIZEP = 8 + ISIZEM = 15 + TENS = 2.5 +c +c DATA INMAJ,INMIN,INLAB,INDAT/1, 1, 1, 1/ + INMAJ = 2 + INMIN = 1 + INLAB = 2 + INDAT = 1 +c +c DATA IRANMJ, IRANMN, IRANTX /1, 1, 1/ + IRANMJ = 2 + IRANMN = 1 + IRANTX = 1 +c +c DATA IRASMJ, IRASMN, IRASTX /1, 1, 1/ + IRASMJ = 2 + IRASMN = 1 + IRASTX = 1 +c +c DATA IRAQMJ, IRAQMN, IRAQTX /1, 1, 1/ + IRAQMJ = 2 + IRAQMN = 1 + IRAQTX = 1 +c +c DATA LABON/.TRUE./,LISTOP/.FALSE./ + LABON = .TRUE. + LISTOP = .FALSE. +c +c DATA BORD,ITICK/.9,10/ + BORD = .9 + ITICK = 10 +c +c DATA ISCALE,ITLSIZ/0,16/ + ISCALE = 0 + ITLSIZ = 16 +c +c DATA ITIPV,NIT,NCL/0,0,0/ + ITIPV = 0 + NIT = 0 + NCL = 0 +c +c DATA NCPSZ/25/ + NCPSZ = 25 +c +c DATA IHIGH/255/ + IHIGH = 255 +c +c DATA NCP /4/ + NCP = 4 +c +c DATA IREC /1/ + IREC = 1 +c +c DATA LEN,IFMT,LEND,IFMTD/0,0,7,10/ + LEN = 0 + IFMT = 0 + LEND = 7 + IFMTD = 10 +c +c DATA IGRAD,IG/40,40/ + IGRAD = 40 + IG = 40 +c +c DATA NREP,NCRT,ISIZEL,MXXY,MINGAP/6,3,9,500,3/ + NREP = 6 + NCRT = 3 + ISIZEL = 9 + MXXY = 500 + MINGAP = 3 +c +c DATA IDASH(1:1)/' '/ + IDASH(1:1) = ' ' +c +c DATA NDASH(1:1)/' '/ + NDASH(1:1) = ' ' +c +c DATA EDASH(1:1)/' '/ + EDASH(1:1) = ' ' +c +c DATA ISHFCT/9/ + ISHFCT = 9 +c +c - noao + END diff --git a/sys/gio/ncarutil/conlib/README b/sys/gio/ncarutil/conlib/README new file mode 100644 index 00000000..69f73877 --- /dev/null +++ b/sys/gio/ncarutil/conlib/README @@ -0,0 +1,3 @@ +CONLIB -- This directory contains the contents of the NCAR files concom.f and +conterp.f, unpacked one subroutine per file. The unpacking operation is +necessary to permit topological ordering of the library. diff --git a/sys/gio/ncarutil/conlib/concal.f b/sys/gio/ncarutil/conlib/concal.f new file mode 100644 index 00000000..e021fa30 --- /dev/null +++ b/sys/gio/ncarutil/conlib/concal.f @@ -0,0 +1,340 @@ + SUBROUTINE CONCAL (XD,YD,ZD,NT,IPT,NL,IPL,PDD,ITI,XII,YII,ZII, + 1 ITPV) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C THIS SUBROUTINE PERFORMS PUNCTUAL INTERPOLATION OR EXTRAPO- +C LATION, I.E., DETERMINES THE Z VALUE AT A POINT. +C THE INPUT PARAMETERS ARE +C +C XD,YD,ZD = ARRAYS CONTAINING THE X, Y, AND Z +C COORDINATES OF DATA POINTS, +C NT = NUMBER OF TRIANGLES, +C IPT = INTEGER ARRAY CONTAINING THE POINT NUMBERS OF +C THE VERTEXES OF THE TRIANGLES, +C NL = NUMBER OF BORDER LINE SEGMENTS, +C IPL = INTEGER ARRAY CONTAINING THE POINT NUMBERS OF +C THE END POINTS OF THE BORDER LINE SEGMENTS AND +C THEIR RESPECTIVE TRIANGLE NUMBERS, +C PDD = ARRAY CONTAINING THE PARTIAL DERIVATIVES AT +C THE DATA POINTS, +C ITI = TRIANGLE NUMBER OF THE TRIANGLE IN WHICH LIES +C THE POINT FOR WHICH INTERPOLATION IS TO BE +C PERFORMED, +C XII,YII = X AND Y COORDINATES OF THE POINT FOR WHICH +C INTERPOLATION IS TO BE PERFORMED. +C THE OUTPUT PARAMETER IS +C +C ZII = INTERPOLATED Z VALUE. +C +C DECLARATION STATEMENTS +C +C + DIMENSION XD(1) ,YD(1) ,ZD(1) ,IPT(1) , + 1 IPL(1) ,PDD(1) + DIMENSION X(3) ,Y(3) ,Z(3) ,PD(15) , + 1 ZU(3) ,ZV(3) ,ZUU(3) ,ZUV(3) , + 2 ZVV(3) + REAL LU ,LV + EQUIVALENCE (P5,P50) +C + SAVE +C +C PRELIMINARY PROCESSING +C + IT0 = ITI + NTL = NT+NL + IF (IT0 .LE. NTL) GO TO 100 + IL1 = IT0/NTL + IL2 = IT0-IL1*NTL + IF (IL1 .EQ. IL2) GO TO 150 + GO TO 200 +C +C CALCULATION OF ZII BY INTERPOLATION. +C CHECKS IF THE NECESSARY COEFFICIENTS HAVE BEEN CALCULATED. +C + 100 IF (IT0 .EQ. ITPV) GO TO 140 +C +C LOADS COORDINATE AND PARTIAL DERIVATIVE VALUES AT THE +C IPI 102 VERTEXES. +C IPI 103 +C + JIPT = 3*(IT0-1) + JPD = 0 + DO 120 I=1,3 + JIPT = JIPT+1 + IDP = IPT(JIPT) + X(I) = XD(IDP) + Y(I) = YD(IDP) + Z(I) = ZD(IDP) + JPDD = 5*(IDP-1) + DO 110 KPD=1,5 + JPD = JPD+1 + JPDD = JPDD+1 + PD(JPD) = PDD(JPDD) + 110 CONTINUE + 120 CONTINUE +C +C DETERMINES THE COEFFICIENTS FOR THE COORDINATE SYSTEM +C TRANSFORMATION FROM THE X-Y SYSTEM TO THE U-V SYSTEM +C AND VICE VERSA. +C + X0 = X(1) + Y0 = Y(1) + A = X(2)-X0 + B = X(3)-X0 + C = Y(2)-Y0 + D = Y(3)-Y0 + AD = A*D + BC = B*C + DLT = AD-BC + AP = D/DLT + BP = -B/DLT + CP = -C/DLT + DP = A/DLT +C +C CONVERTS THE PARTIAL DERIVATIVES AT THE VERTEXES OF THE +C TRIANGLE FOR THE U-V COORDINATE SYSTEM. +C + AA = A*A + ACT2 = 2.0*A*C + CC = C*C + AB = A*B + ADBC = AD+BC + CD = C*D + BB = B*B + BDT2 = 2.0*B*D + DD = D*D + DO 130 I=1,3 + JPD = 5*I + ZU(I) = A*PD(JPD-4)+C*PD(JPD-3) + ZV(I) = B*PD(JPD-4)+D*PD(JPD-3) + ZUU(I) = AA*PD(JPD-2)+ACT2*PD(JPD-1)+CC*PD(JPD) + ZUV(I) = AB*PD(JPD-2)+ADBC*PD(JPD-1)+CD*PD(JPD) + ZVV(I) = BB*PD(JPD-2)+BDT2*PD(JPD-1)+DD*PD(JPD) + 130 CONTINUE +C +C CALCULATES THE COEFFICIENTS OF THE POLYNOMIAL. +C + P00 = Z(1) + P10 = ZU(1) + P01 = ZV(1) + P20 = 0.5*ZUU(1) + P11 = ZUV(1) + P02 = 0.5*ZVV(1) + H1 = Z(2)-P00-P10-P20 + H2 = ZU(2)-P10-ZUU(1) + H3 = ZUU(2)-ZUU(1) + P30 = 10.0*H1-4.0*H2+0.5*H3 + P40 = -15.0*H1+7.0*H2-H3 + P50 = 6.0*H1-3.0*H2+0.5*H3 + H1 = Z(3)-P00-P01-P02 + H2 = ZV(3)-P01-ZVV(1) + H3 = ZVV(3)-ZVV(1) + P03 = 10.0*H1-4.0*H2+0.5*H3 + P04 = -15.0*H1+7.0*H2-H3 + P05 = 6.0*H1-3.0*H2+0.5*H3 + LU = SQRT(AA+CC) + LV = SQRT(BB+DD) + THXU = ATAN2(C,A) + THUV = ATAN2(D,B)-THXU + CSUV = COS(THUV) + P41 = 5.0*LV*CSUV/LU*P50 + P14 = 5.0*LU*CSUV/LV*P05 + H1 = ZV(2)-P01-P11-P41 + H2 = ZUV(2)-P11-4.0*P41 + P21 = 3.0*H1-H2 + P31 = -2.0*H1+H2 + H1 = ZU(3)-P10-P11-P14 + H2 = ZUV(3)-P11-4.0*P14 + P12 = 3.0*H1-H2 + P13 = -2.0*H1+H2 + THUS = ATAN2(D-C,B-A)-THXU + THSV = THUV-THUS + AA = SIN(THSV)/LU + BB = -COS(THSV)/LU + CC = SIN(THUS)/LV + DD = COS(THUS)/LV + AC = AA*CC + AD = AA*DD + BC = BB*CC + G1 = AA*AC*(3.0*BC+2.0*AD) + G2 = CC*AC*(3.0*AD+2.0*BC) + H1 = -AA*AA*AA*(5.0*AA*BB*P50+(4.0*BC+AD)*P41)- + 1 CC*CC*CC*(5.0*CC*DD*P05+(4.0*AD+BC)*P14) + H2 = 0.5*ZVV(2)-P02-P12 + H3 = 0.5*ZUU(3)-P20-P21 + P22 = (G1*H2+G2*H3-H1)/(G1+G2) + P32 = H2-P22 + P23 = H3-P22 + ITPV = IT0 +C +C CONVERTS XII AND YII TO U-V SYSTEM. +C + 140 DX = XII-X0 + DY = YII-Y0 + U = AP*DX+BP*DY + V = CP*DX+DP*DY +C +C EVALUATES THE POLYNOMIAL. +C + P0 = P00+V*(P01+V*(P02+V*(P03+V*(P04+V*P05)))) + P1 = P10+V*(P11+V*(P12+V*(P13+V*P14))) + P2 = P20+V*(P21+V*(P22+V*P23)) + P3 = P30+V*(P31+V*P32) + P4 = P40+V*P41 + ZII = P0+U*(P1+U*(P2+U*(P3+U*(P4+U*P5)))) + RETURN +C +C CALCULATION OF ZII BY EXTRATERPOLATION IN THE RECTANGLE. +C CHECKS IF THE NECESSARY COEFFICIENTS HAVE BEEN CALCULATED. +C + 150 IF (IT0 .EQ. ITPV) GO TO 190 +C +C LOADS COORDINATE AND PARTIAL DERIVATIVE VALUES AT THE END +C POINTS OF THE BORDER LINE SEGMENT. +C + JIPL = 3*(IL1-1) + JPD = 0 + DO 170 I=1,2 + JIPL = JIPL+1 + IDP = IPL(JIPL) + X(I) = XD(IDP) + Y(I) = YD(IDP) + Z(I) = ZD(IDP) + JPDD = 5*(IDP-1) + DO 160 KPD=1,5 + JPD = JPD+1 + JPDD = JPDD+1 + PD(JPD) = PDD(JPDD) + 160 CONTINUE + 170 CONTINUE +C +C DETERMINES THE COEFFICIENTS FOR THE COORDINATE SYSTEM +C TRANSFORMATION FROM THE X-Y SYSTEM TO THE U-V SYSTEM +C AND VICE VERSA. +C + X0 = X(1) + Y0 = Y(1) + A = Y(2)-Y(1) + B = X(2)-X(1) + C = -B + D = A + AD = A*D + BC = B*C + DLT = AD-BC + AP = D/DLT + BP = -B/DLT + CP = -BP + DP = AP +C +C CONVERTS THE PARTIAL DERIVATIVES AT THE END POINTS OF THE +C BORDER LINE SEGMENT FOR THE U-V COORDINATE SYSTEM. +C + AA = A*A + ACT2 = 2.0*A*C + CC = C*C + AB = A*B + ADBC = AD+BC + CD = C*D + BB = B*B + BDT2 = 2.0*B*D + DD = D*D + DO 180 I=1,2 + JPD = 5*I + ZU(I) = A*PD(JPD-4)+C*PD(JPD-3) + ZV(I) = B*PD(JPD-4)+D*PD(JPD-3) + ZUU(I) = AA*PD(JPD-2)+ACT2*PD(JPD-1)+CC*PD(JPD) + ZUV(I) = AB*PD(JPD-2)+ADBC*PD(JPD-1)+CD*PD(JPD) + ZVV(I) = BB*PD(JPD-2)+BDT2*PD(JPD-1)+DD*PD(JPD) + 180 CONTINUE +C +C CALCULATES THE COEFFICIENTS OF THE POLYNOMIAL. +C + P00 = Z(1) + P10 = ZU(1) + P01 = ZV(1) + P20 = 0.5*ZUU(1) + P11 = ZUV(1) + P02 = 0.5*ZVV(1) + H1 = Z(2)-P00-P01-P02 + H2 = ZV(2)-P01-ZVV(1) + H3 = ZVV(2)-ZVV(1) + P03 = 10.0*H1-4.0*H2+0.5*H3 + P04 = -15.0*H1+7.0*H2-H3 + P05 = 6.0*H1-3.0*H2+0.5*H3 + H1 = ZU(2)-P10-P11 + H2 = ZUV(2)-P11 + P12 = 3.0*H1-H2 + P13 = -2.0*H1+H2 + P21 = 0.0 + P23 = -ZUU(2)+ZUU(1) + P22 = -1.5*P23 + ITPV = IT0 +C +C CONVERTS XII AND YII TO U-V SYSTEM. +C + 190 DX = XII-X0 + DY = YII-Y0 + U = AP*DX+BP*DY + V = CP*DX+DP*DY +C +C EVALUATES THE POLYNOMIAL. +C + P0 = P00+V*(P01+V*(P02+V*(P03+V*(P04+V*P05)))) + P1 = P10+V*(P11+V*(P12+V*P13)) + P2 = P20+V*(P21+V*(P22+V*P23)) + ZII = P0+U*(P1+U*P2) + RETURN +C +C CALCULATION OF ZII BY EXTRATERPOLATION IN THE TRIANGLE. +C CHECKS IF THE NECESSARY COEFFICIENTS HAVE BEEN CALCULATED. +C + 200 IF (IT0 .EQ. ITPV) GO TO 220 +C +C LOADS COORDINATE AND PARTIAL DERIVATIVE VALUES AT THE VERTEX +C OF THE TRIANGLE. +C + JIPL = 3*IL2-2 + IDP = IPL(JIPL) + X(1) = XD(IDP) + Y(1) = YD(IDP) + Z(1) = ZD(IDP) + JPDD = 5*(IDP-1) + DO 210 KPD=1,5 + JPDD = JPDD+1 + PD(KPD) = PDD(JPDD) + 210 CONTINUE +C +C CALCULATES THE COEFFICIENTS OF THE POLYNOMIAL. +C + P00 = Z(1) + P10 = PD(1) + P01 = PD(2) + P20 = 0.5*PD(3) + P11 = PD(4) + P02 = 0.5*PD(5) + ITPV = IT0 +C +C CONVERTS XII AND YII TO U-V SYSTEM. +C + 220 U = XII-X(1) + V = YII-Y(1) +C +C EVALUATES THE POLYNOMIAL. +C + P0 = P00+V*(P01+V*P02) + P1 = P10+V*P11 + ZII = P0+U*(P1+U*P20) + RETURN + END diff --git a/sys/gio/ncarutil/conlib/concld.f b/sys/gio/ncarutil/conlib/concld.f new file mode 100644 index 00000000..6829d5fe --- /dev/null +++ b/sys/gio/ncarutil/conlib/concld.f @@ -0,0 +1,314 @@ + SUBROUTINE CONCLD (ICASE,IOOP) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500), NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + INTEGER GOOP +C + SAVE + DATA GOOP/0/ +C +C STATEMENT FUNCTIONS FOR CONTOUR PLACEMENT WITHIN CELLS +C + CX(W1,W2) = STPSZ*( (W1-CONV)/(W1-W2) ) + CY(W1,W2) = STPSZ*( (W1-CONV)/(W1-W2) ) + IC = ICASE + ICASE = 0 +C +C SPECIAL PROCESSING IF SHIELDING ACTIVATED +C + IF (.NOT.SHIELD) GO TO 1 +C +C CHECK IF ANY CELL CORNER CONTAINS A SPECIAL VALUE +C IF SO THEN FLAG AND RETURN +C + IF (TR.NE.SPVAL.AND.BR.NE.SPVAL.AND.TL.NE.SPVAL.AND.BL.NE.SPVAL) + 1 GO TO 1 +C +C SPECIAL VALUE IN CELL FLAG AND RETURN +C + ICASE = -1 + RETURN +C +C IF CURRENT BR VALUE LESS THAN CONTOUR THEN NEIGHBOR WILL BE WHERE +C CONTOUR IS DRAWN. +C + 1 CONTINUE +C + IF (BR.LT.CONV) GO TO 90 +C +C CURRENT LOCATION IS WHERE CONTOUR WILL BE DRAWN +C +C TEST FOR VERTICAL CONTOUR BREAK +C + IF (BL.GE.CONV) GO TO 60 +C +C VERTICAL CONTOUR BREAK +C +C CASE 1 LEFT NEIGHBOR LESS THAN CONTOUR LEVEL AND CURRENT +C LOCATION GE CONTOUR VALUE +C + IF (TR.GE.CONV) GO TO 40 +C +C CASE 1A CONTOUR LOWER RIGHT +C +C +C CONTOUR FROM UPPER RIGHT +C + XO = XC-CX(BR,TR) + YO = YC + YN = YC-CY(BR,BL) + XN = XC + NC = 1 + IOC = 4 + IF (IC.NE.3) GO TO 10 + ICASE = IOC + XN = XO + YN = YO + RETURN + 10 IF (IOOP.NE.GOOP) GO TO 20 + IF (IC.NE.2) GO TO 30 + 20 ICASE = NC + RETURN +C +C CASE 1B CONTOR UPPER LEFT +C + 30 XN = XC-STPSZ + YN = YC-STPSZ+CY(TL,TR) + XO = XC-STPSZ+CX(TL,BL) + YO = YC-STPSZ + IOC = 2 + NC = 3 + GO TO 180 +C +C CONTOURS FROM ABOVE AND UPPER LEFT +C + 40 IF (TL.LT.CONV) GO TO 50 +C +C CASE 1C CONTOUR LOWER LEFT +C + XO = XC-STPSZ+CX(TL,BL) + YO = YC-STPSZ + YN = YC-CY(BR,BL) + XN = XC + NC = 1 + IOC = 2 + GO TO 180 +C +C CASE 1D CONTOUR FROM ABOVE +C + 50 XO = XC-STPSZ + YO = YC-CY(TR,TL) + YN = YC-CY(BR,BL) + XN = XC + NC = 1 + IOC = 3 + GO TO 180 +C +C +C TEST FOR HORIZONTAL CONTOUR BREAK +C + 60 IF (TR.LT.CONV) GO TO 70 + IF (TL.GE.CONV) GO TO 200 +C +C CASE 2A CONTOUR UPPER LEFT +C + XO = XC-STPSZ + YO = YC-CY(TR,TL) + XN = XC-CX(BL,TL) + YN = YC-STPSZ + NC = 2 + IOC = 3 + GO TO 180 +C + 70 IF (TL.LT.CONV) GO TO 80 +C +C CASE 2B CONTOUR FROM UPPER RIGHT +C + XO = XC-STPSZ + YO = YC-STPSZ+CY(TL,TR) + XN = XC-CX(BR,TR) + YN = YC + NC = 4 + IOC = 3 + GO TO 180 +C +C CASE 2C CONTOUR FROM LEFT TO RIGHT +C + 80 XO = XC-CX(BL,TL) + YO = YC-STPSZ + XN = XC-CX(BR,TR) + YN = YC + NC = 4 + IOC = 2 + GO TO 180 +C +C +C CURRENT BR VALUE LESS THAN CONTOUR +C +C + 90 IF (BL.LT.CONV) GO TO 150 +C +C VERTICAL CONTOUR BREAK +C +C CASE 3 CURRENT SPACE LESS THAN CONTOUR LEVEL AND LEFT +C NEIGHBOR GE CONTOUR LEVEL +C + IF (TL.GE.CONV) GO TO 130 +C +C CASE 3A CONTOUR LOWER LEFT +C + XO = XC-CX(BL,TL) + YO = YC-STPSZ + YN = YC-STPSZ+CY(BL,BR) + XN = XC + NC = 1 + IOC = 2 + IF (IC.NE.3) GO TO 100 + ICASE = IOC + XN = XO + YN = YO + RETURN + 100 IF (IOOP.NE.GOOP) GO TO 110 + IF (IC.NE.4) GO TO 120 + 110 ICASE = NC + RETURN +C +C CASE 3B CONTOUR UPPERRIGHT +C + 120 XO = XC-STPSZ + YO = YC-CY(TR,TL) + XN = XC-STPSZ+CX(TR,BR) + YN = YC + NC = 4 + IOC = 3 + GO TO 180 +C + 130 IF (TR.GE.CONV) GO TO 140 +C +C CASE 3C CONTOUR FROM ABOVE +C + XO = XC-STPSZ + YO = YC-STPSZ+CY(TL,TR) + YN = YC-STPSZ+CY(BL,BR) + XN = XC + NC = 1 + IOC = 3 + GO TO 180 +C +C CASE 3D CONTOUR LOWER RIGHT +C + 140 XO = XC-STPSZ+CX(TR,BR) + YO = YC + YN = YC-STPSZ+CY(BL,BR) + XN = XC + NC = 1 + IOC = 4 + GO TO 180 +C +C +C +C TEST FOR HORIZONTAL BREAK POINT +C + 150 IF (TR.GE.CONV) GO TO 160 +C + IF (TL.LT.CONV) GO TO 200 +C +C CASE 4A CONTOUR UPPER LEFT +C + XN = XC-STPSZ+CX(TL,BL) + YN = YC-STPSZ + XO = XC-STPSZ + YO = YC-STPSZ+CY(TL,TR) + NC = 2 + IOC = 3 + GO TO 180 +C + 160 IF (TL.GE.CONV) GO TO 170 +C +C CASE 4B CONTOUR UPPER RIGHT +C + XO = XC-STPSZ + YO = YC-CY(TR,TL) + XN = XC-STPSZ+CX(TR,BR) + YN = YC + NC = 4 + IOC = 3 + GO TO 180 +C +C CASE 4C CONTOUR FROM LEFT TO RIGHT +C + 170 YO = YC-STPSZ + XO = XC-STPSZ+CX(TL,BL) + XN = XC-STPSZ+CX(TR,BR) + YN = YC + NC = 4 + IOC = 2 +C +C DRAW THE CONTOUR LINES NOT ALREADY TAKEN CARE OF +C + 180 IF (IABS(IC-NC).NE.2) GO TO 190 + ICASE = IOC + XN = XO + YN = YO + RETURN + 190 ICASE = NC + 200 RETURN + END diff --git a/sys/gio/ncarutil/conlib/concls.f b/sys/gio/ncarutil/conlib/concls.f new file mode 100644 index 00000000..02d97a4d --- /dev/null +++ b/sys/gio/ncarutil/conlib/concls.f @@ -0,0 +1,177 @@ + SUBROUTINE CONCLS (ZD,NDP) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C GENERATE CONTOUR LEVELS BASED ON THE INPUT DATA +C + DIMENSION ZD(1) +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + SAVE +C +C IF NOT USER SET COMPUTE CONTOUR LEVELS +C + IF (.NOT.CON) GO TO 150 +C +C OTHERWISE GET HI AND LOW CONTOURS FOR MESSAGE +C + HI = CL(1) + FLO = CL(1) + DO 110 I=1,NCL + IF (HI .GE. CL(I)) GO TO 100 + HI = CL(I) + GO TO 110 + 100 IF (FLO .LE. CL(I)) GO TO 110 + FLO = CL(I) + 110 CONTINUE +C +C GET INCREMENT IF EQUAL SPACED CONTOURS +C + IF (NCL .NE. 1) GO TO 120 + FINC = 0. + RETURN + 120 FINC = ABS(CL(1)-CL(2)) + IF (NCL .EQ. 2) RETURN + DO 130 I=3,NCL + IF (FINC .NE. ABS(CL(I-1)-CL(I))) GO TO 140 + 130 CONTINUE + RETURN + 140 FINC = -1. + RETURN +C +C FIND HIGHEST AND LOWEST INPUT VALUES +C + 150 IF (CHILO) GO TO 180 + FLO = ZD(1) + HI = ZD(1) + DO 170 I=2,NDP + IF (FLO .LE. ZD(I)) GO TO 160 + FLO = ZD(I) + GO TO 170 + 160 IF (HI .GE. ZD(I)) GO TO 170 + HI = ZD(I) + 170 CONTINUE +C +C CALCULATE THE CONTOUR LEVEL INTERVAL +C + 180 IF (CINC) GO TO 200 + FINC = (HI-FLO)/15. + IF (FINC .NE. 0.) GO TO 190 + CALL SETER (' CONCLS - CONSTANT INPUT FIELD',1,1) + RETURN +C +C ROUND FINC TO NICE NUMBER +C + 190 P = 10.**(IFIX(ALOG10(FINC)+500.)-500) + FINC = AINT(FINC/P+0.1)*P +C +C ROUND THE LOW VALUE TO START AT A NICE NUMBER +C + 200 IF (CHILO) GO TO 210 + FLO = AINT(FLO/FINC)*FINC +C +C COMPUTE THE CONTOUR LEVELS +C +C TEST IF BREAK POINT WITHIN RANGE OF HI TO FLO +C + 210 IF (BPSIZ.GE.FLO .AND. BPSIZ.LE.HI) GO TO 240 +C +C BREAK POINT OUT OF RANGE SO GENERATE CONTOURS BASED ON FLO +C + DO 220 I=1,30 + CV = FLO+FLOAT(I-1)*FINC + ICUR = I + CL(I) = CV + IF (CV .GE. HI) GO TO 230 + 220 CONTINUE + 230 NCL = ICUR + HI = CV + RETURN +C +C BREAK POINT WITHIN RANGE SO BASE CONTOURS ON IT +C + 240 DO 250 I=1,30 + CV = BPSIZ-FLOAT(I-1)*FINC + IND = (30-I)+1 + CL(IND) = CV + ICUR = I + IF (CV .LE. FLO) GO TO 260 + 250 CONTINUE +C +C PUT THE CONTOURS IN THE CORRECT ORDER +C + 260 DO 270 I=1,ICUR + IND = (30-ICUR)+I + CL(I) = CL(IND) + 270 CONTINUE +C +C ADD THE GREATER THAN BREAK POINT CONTOURS +C + IEND = 30-ICUR + ISAV = ICUR+1 + DO 280 I=1,IEND + CV = BPSIZ+FLOAT(I)*FINC + CL(ISAV) = CV + ISAV = ISAV+1 + IF (CV .GE. HI) GO TO 290 + 280 CONTINUE +C +C SET NUMBER OF CONTOUR LEVELS AND UPDATE THE HIGH VALUE +C + 290 NCL = ISAV-1 + HI = CV + RETURN + END diff --git a/sys/gio/ncarutil/conlib/concom.f b/sys/gio/ncarutil/conlib/concom.f new file mode 100644 index 00000000..8a5041df --- /dev/null +++ b/sys/gio/ncarutil/conlib/concom.f @@ -0,0 +1,78 @@ + FUNCTION CONCOM (XQ,YQ,XD,YD,ZD,NDP,WK,IWK,LOC) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C INTERPOLATE A GIVEN X,Y PAIR AND RETURN ITS LOCATION +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500), NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + DIMENSION XD(1) ,YD(1) ,ZD(1) ,WK(1) , + 1 IWK(1) +C + SAVE +C +C LOCATE PROPER TRIANGLE +C + CALL CONLOC (NDP,XD,YD,NT,IWK(JWIPT),NL,IWK(JWIPL),XQ,YQ,LOC, + 1 IWK(JWIWL),WK) +C +C INTERPOLATE THE LOCATION +C + CALL CONCAL (XD,YD,ZD,NT,IWK(JWIPT),NL,IWK(JWIPL),WK(IPR),LOC,XQ, + 1 YQ,TEMP,ITPV) + CONCOM = TEMP + RETURN + END diff --git a/sys/gio/ncarutil/conlib/condet.f b/sys/gio/ncarutil/conlib/condet.f new file mode 100644 index 00000000..6b3a3077 --- /dev/null +++ b/sys/gio/ncarutil/conlib/condet.f @@ -0,0 +1,128 @@ + SUBROUTINE CONDET (NDP,XD,YD,NCP,IPC) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C****************************************************************** +C* * +C* THIS FILE IS A PACKAGE OF SUPPORT ROUTINES FOR THE ULIB * +C* FILES CONRAN , CONRAQ AND CONRAS. SEE THOSE FILES FOR AN * +C* EXPLAINATION OF THE ENTRY POINTS. * +C* * +C****************************************************************** +C +C THIS SUBROUTINE SELECTS SEVERAL DATA POINTS THAT ARE CLOSEST +C TO EACH OF THE DATA POINT. +C THE INPUT PARAMETERS ARE +C NDP = NUMBER OF DATA POINTS, +C XD,YD = ARRAYS CONTAINING THE X AND Y COORDINATES +C OF DATA POINTS, +C NCP = NUMBER OF DATA POINTS CLOSEST TO EACH DATA +C POINTS. +C THE OUTPUT PARAMETER IS +C IPC = INTEGER ARRAY OF DIMENSION NCP*NDP, WHERE THE +C POINT NUMBERS OF NCP DATA POINTS CLOSEST TO +C EACH OF THE NDP DATA POINTS ARE TO BE STORED. +C THIS SUBROUTINE ARBITRARILY SETS A RESTRICTION THAT NCP MUST +C NOT EXCEED 25 WITHOUT MODIFICATION TO THE ARRAYS DSQ0 AND IPC0. +C DECLARATION STATEMENTS +C + COMMON /CONRA3/ IREC + DIMENSION XD(NDP) ,YD(NDP) ,IPC(1) + DIMENSION DSQ0(25) ,IPC0(25) +C + SAVE +C +C STATEMENT FUNCTION +C + DSQF(U1,V1,U2,V2) = (U2-U1)**2+(V2-V1)**2 +C +C CALCULATION +C + DO 220 IP1=1,NDP +C +C - SELECTS NCP POINTS. +C + X1 = XD(IP1) + Y1 = YD(IP1) + J1 = 0 + DSQMX = 0.0 + DO 110 IP2=1,NDP + IF (IP2 .EQ. IP1) GO TO 110 + DSQI = DSQF(X1,Y1,XD(IP2),YD(IP2)) + J1 = J1+1 + DSQ0(J1) = DSQI + IPC0(J1) = IP2 + IF (DSQI .LE. DSQMX) GO TO 100 + DSQMX = DSQI + JMX = J1 + 100 IF (J1 .GE. NCP) GO TO 120 + 110 CONTINUE + 120 IP2MN = IP2+1 + IF (IP2MN .GT. NDP) GO TO 150 + DO 140 IP2=IP2MN,NDP + IF (IP2 .EQ. IP1) GO TO 140 + DSQI = DSQF(X1,Y1,XD(IP2),YD(IP2)) + IF (DSQI .GE. DSQMX) GO TO 140 + DSQ0(JMX) = DSQI + IPC0(JMX) = IP2 + DSQMX = 0.0 + DO 130 J1=1,NCP + IF (DSQ0(J1) .LE. DSQMX) GO TO 130 + DSQMX = DSQ0(J1) + JMX = J1 + 130 CONTINUE + 140 CONTINUE +C +C - CHECKS IF ALL THE NCP+1 POINTS ARE COLLINEAR. +C + 150 IP2 = IPC0(1) + DX12 = XD(IP2)-X1 + DY12 = YD(IP2)-Y1 + DO 160 J3=2,NCP + IP3 = IPC0(J3) + DX13 = XD(IP3)-X1 + DY13 = YD(IP3)-Y1 + IF ((DY13*DX12-DX13*DY12) .NE. 0.0) GO TO 200 + 160 CONTINUE +C +C - SEARCHES FOR THE CLOSEST NONCOLLINEAR POINT. +C + NCLPT = 0 + DO 190 IP3=1,NDP + IF (IP3 .EQ. IP1) GO TO 190 + DO 170 J4=1,NCP + IF (IP3 .EQ. IPC0(J4)) GO TO 190 + 170 CONTINUE + DX13 = XD(IP3)-X1 + DY13 = YD(IP3)-Y1 + IF ((DY13*DX12-DX13*DY12) .EQ. 0.0) GO TO 190 + DSQI = DSQF(X1,Y1,XD(IP3),YD(IP3)) + IF (NCLPT .EQ. 0) GO TO 180 + IF (DSQI .GE. DSQMN) GO TO 190 + 180 NCLPT = 1 + DSQMN = DSQI + IP3MN = IP3 + 190 CONTINUE + DSQMX = DSQMN + IPC0(JMX) = IP3MN +C +C - REPLACES THE LOCAL ARRAY FOR THE OUTPUT ARRAY. +C + 200 J1 = (IP1-1)*NCP + DO 210 J2=1,NCP + J1 = J1+1 + IPC(J1) = IPC0(J2) + 210 CONTINUE + 220 CONTINUE + RETURN + END diff --git a/sys/gio/ncarutil/conlib/condrw.f b/sys/gio/ncarutil/conlib/condrw.f new file mode 100644 index 00000000..df47eae9 --- /dev/null +++ b/sys/gio/ncarutil/conlib/condrw.f @@ -0,0 +1,253 @@ + SUBROUTINE CONDRW (SCRARR) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C DRAW ALL CONTOURS AT THIS LEVEL +C IF NOT EXTRAPOLATING +C SEARCH CONVEX HULL FOR CONTOURS INTERSECTING IT AND DRAW THEM +C SEARCH INTERIOR AND DRAW ALL REMAINING UNDRAWN CONTOURS +C +C IF EXTRAPOLATING +C SEARCH FROM X START TO X END AND Y START TO Y END FOR ALL +C CONTOURS AT THIS LEVEL +C +C INPUT +C SCRARR SCRATCH ARRAY USED FOR FAST CONTOURING +C VIA COMMON BLOCKS BELOW +C CONV-THE CURRENT CONTOUR LEVEL +C ITLOC-THE CONVEX HULL BOUNDRIES RELATIVE TO THE SCRATCH +C ARRAY, SCRARR +C PV-REAL Y COOORDINATES OF THE CONVEX HULL RELATIVE TO THE +C USERS COORDINATE SPACE +C IXMAX,IYMAX-MAXINUM X AND Y COORDINATES RELATIVE TO THE +C SCRATCH ARRAY, SCRARR +C XMAX,YMAX-MAXIMUM X AND Y COORDINATES RELATIVE TO USERS +C COORDINATE SPACE +C +C OUTPUT +C CONTOUR LINES OUTPUT TO PLOTTER FILE +C +C NOTE +C THIS ROUTINE WILL DETECT AND CORRECT FOR CONRAN ERROR 9 +C + DIMENSION SCRARR(1) +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500), NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + SAVE +C +C +C FLAGS TO ALLOW COMPRESSION OF CONTOUR STORAGE IF IT IS EXAUSTED +C + DATA ICOMP,NOCOMP/1,0/ +C +C STATEMENT FUNCTION TO MAKE ARRAY ACCESS SEEM LIKE MATRIX ACCESS +C + SCRTCH(IXX,IYY) = SCRARR(IYY+(IXX-1)*IYMAX) +C +C CLEAR THE CONTOUR STORAGE LIST +C + NP = 0 +C +C SCAN X BOARDERS FOR INTERSECTIONS +C + JX = 2 + ICASE = 1 + X = XST+STPSZ +C +C IF NOT EXTRAPOLATING BRANCH +C + 10 IF (.NOT.EXTRAP) GO TO 20 + JY = 2 + JYE = IYMAX + Y = YST+STPSZ + GO TO 30 +C +C NOT EXTRAPOLATING +C + 20 JY = ITLOC(JX*2-1) + IF (JY.EQ.0) GO TO 60 + JYE = ITLOC(JX*2)+1 + IF (JYE.GT.IYMAX) JYE = IYMAX + Y = PV(JX*2-1) + IF (JY.GE.2) GO TO 30 + JY = 2 + Y = YST+STPSZ + 30 TL = SCRTCH(JX-1,JY-1) + BL = SCRTCH(JX,JY-1) + 40 TR = SCRTCH(JX-1,JY) + BR = SCRTCH(JX,JY) + CALL CONGEN (X,Y,NOCOMP,SCRARR,ICASE) +C +C TEST IF CONTOUR STORAGE EXAUSTED +C + IF (NERRO(NERR).NE.10) GO TO 50 + CALL EPRIN + CALL ERROF + RETURN +C +C MOVE TO NEW CELL +C + 50 TL = TR + BL = BR + JY = JY+1 + Y = Y+STPSZ + IF (JY.LE.JYE) GO TO 40 + 60 IF (JX.EQ.IXMAX) GO TO 70 + JX = IXMAX + ICASE = 3 + X = XMAX + GO TO 10 +C +C SCAN Y BOARDERS +C + 70 IPOS = 1 + ICASE = 4 + 80 JX = 3 + X = XST+STPSZ+STPSZ +C +C IF NOT EXTRAPOLATING BRANCH +C + 90 IF (.NOT.EXTRAP) GO TO 100 + JY = 2 + Y = YST+STPSZ + IF (IPOS.NE.0) GO TO 110 + JY = IYMAX + Y = YED + GO TO 110 +C +C NOT EXTRAPOLATING +C + 100 JY = ITLOC(JX*2 - IPOS ) + IF (JY.EQ.0) GO TO 120 + JY = JY + IPOS + Y = PV(JX*2 - IPOS) + STPSZ*(1*IPOS) + 110 TL = SCRTCH(JX-1,JY-1) + BL = SCRTCH(JX,JY-1) + TR = SCRTCH(JX-1,JY) + BR = SCRTCH(JX,JY) + CALL CONGEN (X,Y,NOCOMP,SCRARR,ICASE) +C +C TEST IF CONTOUR STORAGE EXAUSTED +C + IF (NERRO(NERR).NE.10) GO TO 120 + CALL EPRIN + CALL ERROF + RETURN +C +C MOVE TO NEW CELL +C + 120 JX = JX+1 + X = X+STPSZ + IF (JX.LE.IXMAX-1) GO TO 90 + IF (IPOS.EQ.0) GO TO 130 + IPOS = 0 + ICASE = 2 + GO TO 80 +C +C BOARDER SEARCH DONE CONTOUR INTERIOR +C +C INITIALIZE THE SEARCH +C + 130 JX = 3 + ICASE = 0 + X = XST+STPSZ+STPSZ + JXE = IXMAX-1 +C +C IF EXTRAPOLATING GO FROM BORDER TO BORDER +C + 140 IF (.NOT.EXTRAP) GO TO 150 + JY = 3 + JYE = IYMAX-1 + Y = YST+STPSZ+STPSZ + GO TO 160 +C +C NOT EXTRAPOLATING STAY IN HULL +C + 150 JY = ITLOC(JX*2 - 1)+2 + IF (JY.EQ.2) GO TO 190 + JYE = ITLOC(JX*2)-1 + Y = PV(JX*2 - 1)+STPSZ+STPSZ +C + 160 IF (JY.GT.JYE) GO TO 190 + TL = SCRTCH(JX-1,JY-1) + BL = SCRTCH(JX,JY-1) + 170 TR = SCRTCH(JX-1,JY) + BR = SCRTCH(JX,JY) + CALL CONGEN (X,Y,ICOMP,SCRARR,ICASE) +C +C TEST IF CONTOUR STORAGE EXAUSTED +C + IF (NERRO(NERR).NE.10) GO TO 180 + CALL EPRIN + CALL ERROF + RETURN +C +C MOVE TO NEW CELL +C + 180 JY = JY+1 + Y = Y+STPSZ + TL = TR + BL = BR + IF (JY.LE.JYE) GO TO 170 +C +C PROCESS EACH ROW OF INTERIOR +C + 190 X = X+STPSZ + JX = JX+1 + IF (JX.LE.JXE) GO TO 140 +C + RETURN + END diff --git a/sys/gio/ncarutil/conlib/condsd.f b/sys/gio/ncarutil/conlib/condsd.f new file mode 100644 index 00000000..0ea5fb43 --- /dev/null +++ b/sys/gio/ncarutil/conlib/condsd.f @@ -0,0 +1,54 @@ + SUBROUTINE CONDSD +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C DRAW THE OUTLINE OF THE SHIELD ON THE PLOT +C + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT +C + SAVE +C +C GET THE START POINT +C + XS = XVS(1) + YS = YVS(1) +C +C MOVE TO THE START OF THE OUTLINE +C + CALL FL2INT(XS,YS,IX,IY) + CALL PLOTIT(IX,IY,0) +C +C LOOP FOR ALL SHIELD ELEMENTS +C + DO 100 IC = 2,ICOUNT +C +C DRAW THE OUTLINE OF THE SHIELD +C + CALL FL2INT(XVS(IC),YVS(IC),IX,IY) + CALL PLOTIT(IX,IY,1) +C + 100 CONTINUE +C +C DRAW TO THE START +C + CALL FL2INT(XS,YS,IX,IY) + CALL PLOTIT(IX,IY,1) +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(0,0,0) + RETURN +C + END diff --git a/sys/gio/ncarutil/conlib/conecd.f b/sys/gio/ncarutil/conlib/conecd.f new file mode 100644 index 00000000..56d8a934 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conecd.f @@ -0,0 +1,178 @@ + SUBROUTINE CONECD (VAL,IOUT,NUSED) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C ENCODE A NUMBER IN THE LEAST AMOUNT OF SPACE +C ON INPUT +C VAL THE NUMBER TO BE ENCODED +C ON OUTPUT +C IOUT CHARACTER STRING FILLED WITH THE ENCODED RESULT, MUST BE ABLE TO +C HOLD UP TO 9 CHARACTERS. +C +C NUSED NUMBER OF CHARACTERS IN IOUT +C +C VALUE INPUT WILL BE SCALED BY SCALE IN CONRA2 +C +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500), NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + CHARACTER*(*) IOUT + CHARACTER*6 IFMT1 +C +C +NOAO - Variables CHTMP and IT are not used. +C +C CHARACTER*9 CHTMP +C CHARACTER*1 IT +C +C -NOAO +C + SAVE +C + V = VAL +C +C IF VAL EQUALS ZERO EASY PROCESSING +C + IF (V.NE.0.) GO TO 20 + IOUT = '0.0' + NUSED = 3 + RETURN +C +C SCALE VALUE +C + 20 V = V*SCALE +C +C GET SIZE OF NUMBER +C + LOG = IFIX(ALOG10(ABS(V))+.1) + IF (IABS(LOG).GT.4) GO TO 60 +C +C COMPUTE FLOATING POINT FIELD +C + NS = IABS(LOG)+3 + ND = 1 + IF (LOG.GT.0) GO TO 40 +C +C LOG = 0 TEST FOR FRACTIONAL PART ONLY +C + IF (ALOG10( ABS(V) ).GE.0.) GO TO 30 +C +C NUMBER LT 1 BUT GREATER THAN ZERO IN ABSOLUTE VALUE +C + NS = 4 + ND = 1 + GO TO 40 +C +C NUMBER LESS THAN 10 BUT GE 1 +C + 30 ND = 1 + NS = 4 +C +C BUILD THE FORMAT +C + 40 IF (V.LT.0) NS = NS+1 + IFMT1 = '(F . )' +C +C INSERT THE FLOATING POINT FORMAT SIZE +C +C +NOAO - Scheme for creating format has been modified because it uses +C FTN internal writes. NOAO mods are written in lower case. +C +C WRITE(IT,'(I1)')NS +C IFMT1(3:3) = IT +C WRITE(IT,'(I1)')ND +C IFMT1(5:5) = IT +C + ifmt1(1:6) = '(f . )' + ifmt1(3:3) = char (ns + ichar ('0') + 1) + ifmt1(5:5) = char (nd + ichar ('0')) +C +C ENCODE THE DESIRED NUMBER +C +C WRITE(CHTMP,IFMT1)V +C IOUT = CHTMP +C + call encode (ns, ifmt1, iout, v) + + NUSED = NS + RETURN +C +C DATA LARGER THAN A NICE SIZE FORCE IT TO BE ENCODED +C +C 60 WRITE(CHTMP,'(E8.3)')V +C IOUT = CHTMP +C + 60 call encode (8, '(E8.3)', iout, v) +C +C -NOAO + NUSED = 8 + RETURN +C +C****************************************************************** +C* * +C* REVISION HISTORY * +C* * +C* JUNE 1980 ADDED CONCOM TO ULIB * +C* AUGUST 1980 FIXED BOARDER CONTOUR DETECTION * +C* DECEMBER 1980 FIXED ERROR TRAP, CONTOUR REORDERING ALGORITHM * +C* AND ERROR MESSAGE 10 * +C* AUGUST 1983 ADDED LINEAR INTERPOLATION AND SHIELDING * +C* JULY 1984 CONVERTED TO FORTRAN77 AND GKS * +C* AUGUST 1985 DELETED (MACHINE DEPENDENT) FUNCTION LOC; CHANGED * +C* COMMON /CONR13/ * +C* * +C****************************************************************** +C + END diff --git a/sys/gio/ncarutil/conlib/congen.f b/sys/gio/ncarutil/conlib/congen.f new file mode 100644 index 00000000..c70cfe05 --- /dev/null +++ b/sys/gio/ncarutil/conlib/congen.f @@ -0,0 +1,454 @@ + SUBROUTINE CONGEN (XI,YI,IPACK,SCRARR,ICA) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C DRAW A CONTOUR AT THE CURRENT LEVEL +C +C INPUT +C XI YI LOWER RIGHT CORNER OF CELL +C IPACK-FLAG TO ALLOW REDUCTION OF COORDINATE PAIR STORAGE +C IF REQUIRED +C SCRARR-SCRATCH ARRAY OF CONTOUR VALUES +C ICA-ENTERING CASE CONDITIONS IF ANY REQUIRED +C +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C +C + DIMENSION SCRARR(1) ,IXMOV(2) ,IYMOV(2) + CHARACTER*64 IHOLD + CHARACTER*23 IVOUT + INTEGER GOOP +C + SAVE + DATA NOOP,GOOP/1,0/ +C +C STATEMENT FUNCTIONS FOR MAPPING GRAPHICS OUTPUT +C + FX(XXX,YYY) = XXX + FY(XXX,YYY) = YYY +C +C STATEMENT FUNCTION TO MAKE ARRAY ACCESS SEEM LIKE MATRIX ACCESS +C + SCRTCH(IXX,IYY) = SCRARR(IYY+(IXX-1)*IYMAX) +C +C DRAW AN ENTIRE CONTOUR LINE WHEN A POTENTIAL START POINT IS +C PROVIDED +C +C SAVE STARTING CELL +C + XCS = XI + YCS = YI +C +C TEST IF VALID START POINT +C + ICASE = ICA + XC = XI + YC = YI + CALL CONCLD (ICASE,NOOP) +C +C IF NO CONTOUR RETURN +C + IF (ICASE.EQ.-1) RETURN + IF (ICASE.EQ.0) RETURN +C +C IF CONTOUR ALREADY DRAWN RETURN +C + ILOC = IOR(ISHIFT(JX,ISHFCT),JY) + IF (NP.EQ.0) GO TO 20 +C +C TEST IF CONTOUR FOUND +C + DO 10 I=1,NP + IF (ILOC.NE.ICOORD(I)) GO TO 10 + RETURN + 10 CONTINUE +C +C GET CORRECT OLD CASE +C + 20 IC = IOC + IF (ICASE.EQ.IOC) IC = NC +C +C SET UP STRUCTURE TO START IN OTHER DIRECTION FROM HERE IF CONTOUR +C UNEXPECTLY ENDS IN THIS DIRECTION +C + IFCASE = IC + IFOCSE = ICASE + FXO = XO + FYO = YO + LOOP = 1 +C +C SET UP IC TO SIMULATE EXIT FROM A PREVIOUS CELL +C + IC = MOD(IC+2,4) +C +C IF EXTRAPOLATING PASS ON +C + IF (EXTRAP) GO TO 60 +C +C TEST IF CONTOUR EXCEEDED BORDER LIMITS +C NOTE THAT ICASER CANNOT EQUAL 3 AT THIS POINT +C + GO TO ( 30, 40, 30, 50),ICASE +C +C EXIT FROM BOTTOM +C + 30 IF (JX.GE.IXMAX) RETURN + GO TO 60 +C +C EXIT FROM LEFT +C + 40 IF (JY.LE.ITLOC(JX*2 - 1)) RETURN + GO TO 60 +C +C EXIT FROM RIGHT +C + 50 IF (JY.GE.ITLOC(JX*2 - 1)) RETURN +C +C SAVE CELL INFO IF COMMING BACK +C + 60 TRT = TR + BRT = BR + TLT = TL + BLT = BL + IX = JX + IY = JY +C +C VALID CONTOUR START FOUND +C + XX = FX(XO,YO) + CALL FRSTD (XX,FY(XO,YO)) +C +C DRAW CONTOUR IN THIS CELL +C + 70 XX = FX(XN,YN) + CALL VECTD (XX,FY(XN,YN)) + XCSTOR = XC + YCSTOR = YC + IXSTOR = IX + IYSTOR = IY + IOLDC = IC + IC = ICASE +C +C ENTER COORDINATE PAIR OF CONTOUR IN LIST +C + NP = NP+1 + IF (NP.GT.MXXY) GO TO 180 + ICOORD(NP) = ILOC +C +C BRANCH TO APPROPIATE CODE DEPENDING ON CONTOUR EXIT FROM THE CELL +C + 80 GO TO ( 90, 110, 130, 150),IC +C +C EXIT FORM BOTTOM +C END CONTOUR IF ON CONVEX HULL +C + 90 IF (EXTRAP) GO TO 100 + IF (IY.LT.ITLOC(IX*2 - 1) .OR. IY-1.GT.ITLOC(IX*2)) GO TO 360 + 100 TR = BR + TL = BL + XC = XC+STPSZ +C +C IF ON BORDER END CONTOUR +C + IX = IX+1 + IF (IX.GT.IXMAX) GO TO 360 + BR = SCRTCH(IX,IY) + BL = SCRTCH(IX,IY-1) + ILOC = IOR(ISHIFT(IX,ISHFCT),IY) +C +C BRANCH IF CONTOUR CLOSED +C + IF (IX.EQ.JX .AND. IY.EQ.JY) GO TO 170 + CALL CONCLD (ICASE,GOOP) + IF (ICASE.EQ.-1) GO TO 360 + IF (ICASE.NE.0) GO TO 70 + GO TO 230 +C +C EXIT FROM LEFT SIDE +C TEST IF IN CONVEX HULL +C + 110 IF (EXTRAP) GO TO 120 + IF (IY-1.LT.ITLOC( (IX-1)*2 - 1 ) .AND. IY-1.LT.ITLOC(IX*2 - 1)) + 1 GO TO 360 + 120 TR = TL + BR = BL + YC = YC-STPSZ +C +C IF ON BORDER END CONTOUR +C + IY = IY-1 + IF (IY.LT.2) GO TO 360 + TL = SCRTCH(IX-1,IY-1) + BL = SCRTCH(IX,IY-1) +C +C BRANCH IF CONTOUR CLOSED +C + IF (IX.EQ.JX .AND. IY.EQ.JY) GO TO 170 + ILOC = IOR(ISHIFT(IX,ISHFCT),IY) + CALL CONCLD (ICASE,GOOP) + IF (ICASE.EQ.-1) GO TO 360 + IF (ICASE.NE.0) GO TO 70 + GO TO 230 +C +C EXIT FROM TOP +C END CONTOUR IF OUT OF CONVEX HULL +C + 130 IF (EXTRAP) GO TO 140 + IF (IY.LT.ITLOC( (IX-1)*2 - 1 ) .OR. IY-1.GT.ITLOC( (IX-1)*2 )) + 1 GO TO 360 + 140 BR = TR + BL = TL + XC = XC-STPSZ +C +C END CONTOUR IF OUTSIDE OF BORDER +C + IX = IX-1 + IF (IX.LT.2) GO TO 360 + TR = SCRTCH(IX-1,IY) + TL = SCRTCH(IX-1,IY-1) + ILOC = IOR(ISHIFT(IX,ISHFCT),IY) +C +C BRANCH IF CONTOUR CLOSED +C + IF (IX.EQ.JX .AND. IY.EQ.JY) GO TO 170 + CALL CONCLD (ICASE,GOOP) + IF (ICASE.EQ.-1) GO TO 360 + IF (ICASE.NE.0) GO TO 70 + GO TO 230 +C +C EXIT FROM RIGHT SIDE +C TEST IF ON CONVEX HULL +C + 150 IF (EXTRAP) GO TO 160 + IF (IY.GT.ITLOC( (IX-1)*2 ) .AND. IY.GT.ITLOC(IX*2)) GO TO 360 + 160 TL = TR + BL = BR + YC = YC+STPSZ +C +C IF ON BORDER END CONTOUR +C + IY = IY+1 + IF (IY.GT.IYMAX) GO TO 360 + TR = SCRTCH(IX-1,IY) + BR = SCRTCH(IX,IY) + ILOC = IOR(ISHIFT(IX,ISHFCT),IY) +C +C BRANCH IF CONTOUR CLOSED +C + IF (IX.EQ.JX .AND. IY.EQ.JY) GO TO 170 + CALL CONCLD (ICASE,GOOP) + IF (ICASE.EQ.-1) GO TO 360 + IF (ICASE.NE.0) GO TO 70 + GO TO 230 +C +C END THE CONTOUR +C + 170 CALL LASTD + TR = TRT + BR = BRT + TL = TLT + BL = BLT + RETURN +C +C CONTOUR STORAGE EXCEEDED TRY PACKING +C + 180 IF (IPACK.EQ.0) GO TO 200 + NP = 0 + ITEST = IOR(ISHIFT(JX,ISHFCT),JY) + DO 190 K=1,MXXY + IF (ICOORD(K).LE.ITEST) GO TO 190 + NP = NP+1 + ICOORD(NP) = ICOORD(K) + 190 CONTINUE + IF (NP.LT.MXXY) GO TO 80 +C +C FAILURE NO MORE SPACE ABORT THIS CONTOUR LEVEL +C + 200 IHOLD(1:39) = ' CONDRW-CONTOUR STORAGE EXAUSTED LEVEL=' +C +C BLANK FILL THE ENCODE ARRAY +C + IVOUT = ' ' +C +NOAO - FTN internal write rewritten as encode for IRAF. +C +C WRITE(IVOUT,'(G13.5)')CONV + call encode (13, '(g13.5)', ivout, conv) +C +C -NOAO + IHOLD(40:62) = IVOUT + CALL SETER (IHOLD,10,IREC) + RETURN +C +C BAD TIME THE CONTOUR EXITED A CORNER OF THE CELL MUST SEARCH FOR +C NEW CELL +C + 230 IXSTP = IXSTOR + IYSTP = IYSTOR + GO TO ( 240, 250, 260, 270),IOLDC +C +C PREVIOUS CELL BOTTOM EXIT +C + 240 IXSTP = IXSTP-1 + GO TO 280 +C +C PREVIOUS CELL LEFT EXIT +C + 250 IYSTP = IYSTP+1 + GO TO 280 +C +C PREVIOUS CELL TOP EXIT +C + 260 IXSTP = IXSTP+1 + GO TO 280 +C +C PREVIOUS CELL RIGHT EXIT +C + 270 IYSTP = IYSTP-1 +C +C BRANCH TO CURRENT CELL CASE +C + 280 GO TO ( 290, 300, 310, 320),IC +C +C APPARENT BOTTOM EXIT +C + 290 IXMOV(1) = 0 + IXMOV(2) = 1 + IYMOV(1) = -1 + IYMOV(2) = 1 + GO TO 330 +C +C APPARENT LEFT EXIT +C + 300 IXMOV(1) = 1 + IXMOV(2) = -1 + IYMOV(1) = 0 + IYMOV(2) = -1 + GO TO 330 +C +C APPARENT TOP EXIT +C + 310 IXMOV(1) = 0 + IXMOV(2) = -1 + IYMOV(1) = -1 + IYMOV(2) = 1 + GO TO 330 +C +C APPARENT RIGHT EXIT +C + 320 IXMOV(1) = 1 + IXMOV(2) = -1 + IYMOV(1) = 0 + IYMOV(2) = 1 +C +C SEARCH THE POSSIBLE CELLS +C + 330 DO 350 K=1,2 + DO 340 L=1,2 + XC = XCSTOR + STPSZ*FLOAT( IXMOV(K) ) + YC = YCSTOR + STPSZ*FLOAT( IYMOV(L) ) + IX = IXSTOR+IXMOV(K) + IY = IYSTOR+IYMOV(L) + ILOC = IOR(ISHIFT(IX,ISHFCT),IY) +C +C IF BACK TO START END CONTOUR +C + IF (IX.EQ.JX .AND. IY.EQ.JY) GO TO 170 +C +C IF AT PREVIOUS CELL SKIP PROCESSING +C + IF (IX.EQ.IXSTP .AND. IY.EQ.IYSTP) GO TO 340 +C +C COMPUTE CELL VALUES +C + TL = SCRTCH(IX-1,IY-1) + BL = SCRTCH(IX,IY-1) + TR = SCRTCH(IX-1,IY) + BL = SCRTCH(IX,IY) + ICASE = IC + CALL CONCLD (ICASE,NOOP) + IF (ICASE.EQ.-1) GO TO 360 + IF (ICASE.NE.0) GO TO 70 +C +C FAILURE TRY AGAIN +C + 340 CONTINUE + 350 CONTINUE +C +C NO MORE CONTOUR TRY OTHER END OF LINE +C + 360 IF (LOOP.EQ.0) GO TO 170 + LOOP = 0 + IX = JX + IY = JY + TR = TRT + TL = TLT + BR = BRT + BL = BLT + IC = IFCASE + ICASE = IC + IOLDC = IFOCSE + XC = XI + YC = YI + IXSTOR = IX + IYSTOR = IY + YCSTOR = YI + XCSTOR = XI + XX = FX(FXO,FYO) + CALL LASTD + CALL FRSTD (XX,FY(FXO,FYO)) + GO TO ( 90, 110, 130, 150),IC + END diff --git a/sys/gio/ncarutil/conlib/conint.f b/sys/gio/ncarutil/conlib/conint.f new file mode 100644 index 00000000..84a1be82 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conint.f @@ -0,0 +1,147 @@ + SUBROUTINE CONINT (NDP,XD,YD,ZD,NCP,IPC,PD) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C THIS SUBROUTINE ESTIMATES PARTIAL DERIVATIVES OF THE FIRST AND +C SECOND ORDER AT THE DATA POINTS. +C THE INPUT PARAMETERS ARE +C +C NDP = NUMBER OF DATA POINTS, +C XD,YD,ZD = ARRAYS CONTAINING THE X, Y, AND Z COORDI- +C NATES OF DATA POINTS, +C NCP = NUMBER OF DATA POINTS TO BE USED FOR ESTIMATION +C OF PARTIAL DERIVATIVES AT EACH DATA POINT, +C IPC = INTEGER ARRAY CONTAINING THE POINT NUMBERS OF +C NCP DATA POINTS CLOSEST TO EACH OF THE NDP DATA +C POINT. +C THE OUTPUT PARAMETER IS +C +C PD = ARRAY OF DIMENSION 5*NDP, WHERE THE ESTIMATED +C +C ZX, ZY, ZXX, ZXY, AND ZYY VALUES AT THE DATA +C POINTS ARE TO BE STORED. +C DECLARATION STATEMENTS +C +C + DIMENSION XD(NDP) ,YD(NDP) ,ZD(NDP) ,IPC(1) , + 1 PD(1) + REAL NMX ,NMY ,NMZ ,NMXX , + 1 NMXY ,NMYX ,NMYY +C + SAVE +C +C PRELIMINARY PROCESSING +C +C + NCPM1 = NCP-1 +C +C ESTIMATION OF ZX AND ZY +C +C + DO 130 IP0=1,NDP + X0 = XD(IP0) + Y0 = YD(IP0) + Z0 = ZD(IP0) + NMX = 0.0 + NMY = 0.0 + NMZ = 0.0 + JIPC0 = NCP*(IP0-1) + DO 120 IC1=1,NCPM1 + JIPC = JIPC0+IC1 + IPI = IPC(JIPC) + DX1 = XD(IPI)-X0 + DY1 = YD(IPI)-Y0 + DZ1 = ZD(IPI)-Z0 + IC2MN = IC1+1 + DO 110 IC2=IC2MN,NCP + JIPC = JIPC0+IC2 + IPI = IPC(JIPC) + DX2 = XD(IPI)-X0 + DY2 = YD(IPI)-Y0 + DNMZ = DX1*DY2-DY1*DX2 + IF (DNMZ .EQ. 0.0) GO TO 110 + DZ2 = ZD(IPI)-Z0 + DNMX = DY1*DZ2-DZ1*DY2 + DNMY = DZ1*DX2-DX1*DZ2 + IF (DNMZ .GE. 0.0) GO TO 100 + DNMX = -DNMX + DNMY = -DNMY + DNMZ = -DNMZ + 100 NMX = NMX+DNMX + NMY = NMY+DNMY + NMZ = NMZ+DNMZ + 110 CONTINUE + 120 CONTINUE + JPD0 = 5*IP0 + PD(JPD0-4) = -NMX/NMZ + PD(JPD0-3) = -NMY/NMZ + 130 CONTINUE +C +C ESTIMATION OF ZXX, ZXY, AND ZYY +C +C + DO 170 IP0=1,NDP + JPD0 = JPD0+5 + X0 = XD(IP0) + JPD0 = 5*IP0 + Y0 = YD(IP0) + ZX0 = PD(JPD0-4) + ZY0 = PD(JPD0-3) + NMXX = 0.0 + NMXY = 0.0 + NMYX = 0.0 + NMYY = 0.0 + NMZ = 0.0 + JIPC0 = NCP*(IP0-1) + DO 160 IC1=1,NCPM1 + JIPC = JIPC0+IC1 + IPI = IPC(JIPC) + DX1 = XD(IPI)-X0 + DY1 = YD(IPI)-Y0 + JPD = 5*IPI + DZX1 = PD(JPD-4)-ZX0 + DZY1 = PD(JPD-3)-ZY0 + IC2MN = IC1+1 + DO 150 IC2=IC2MN,NCP + JIPC = JIPC0+IC2 + IPI = IPC(JIPC) + DX2 = XD(IPI)-X0 + DY2 = YD(IPI)-Y0 + DNMZ = DX1*DY2-DY1*DX2 + IF (DNMZ .EQ. 0.0) GO TO 150 + JPD = 5*IPI + DZX2 = PD(JPD-4)-ZX0 + DZY2 = PD(JPD-3)-ZY0 + DNMXX = DY1*DZX2-DZX1*DY2 + DNMXY = DZX1*DX2-DX1*DZX2 + DNMYX = DY1*DZY2-DZY1*DY2 + DNMYY = DZY1*DX2-DX1*DZY2 + IF (DNMZ .GE. 0.0) GO TO 140 + DNMXX = -DNMXX + DNMXY = -DNMXY + DNMYX = -DNMYX + DNMYY = -DNMYY + DNMZ = -DNMZ + 140 NMXX = NMXX+DNMXX + NMXY = NMXY+DNMXY + NMYX = NMYX+DNMYX + NMYY = NMYY+DNMYY + NMZ = NMZ+DNMZ + 150 CONTINUE + 160 CONTINUE + PD(JPD0-2) = -NMXX/NMZ + PD(JPD0-1) = -(NMXY+NMYX)/(2.0*NMZ) + PD(JPD0) = -NMYY/NMZ + 170 CONTINUE + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conlcm.f b/sys/gio/ncarutil/conlib/conlcm.f new file mode 100644 index 00000000..80791d49 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conlcm.f @@ -0,0 +1,65 @@ + FUNCTION CONLCM(X,Y,XD,YD,ZD,NDP,WK,IWK,LOC) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C COMPUTE A Z VALUE FOR A GIVEN X,Y VALUE +C NOTE THAT X,Y MUST BE INSIDE THE CONVEX HULL OF THE INPUT DATA +C INORDER FOR THIS FUNCTION TO WORK. +C +C INPUT +C X-X COORDINATE OF REQUESTED POINT +C Y-Y COORDINATE OF REQUESTED POINT +C WK-LIST OF COEFICENTS FOR LINEAR INTERPOLATION FUNCTIONS +C LOCATED BY A = WK((TRI-1)*3+1) +C B = WK((TRI-2)*3+1) +C C = WK((TRI-3)*3+1) +C +C OUTPUT +C LOC-TRIANGLE NUMBER OF REQUESTED POINT +C Z VALUE AS FUNCTION RESULT +C + DIMENSION WK(1),IWK(1),XD(1),YD(1),ZD(1) +C + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV +C + SAVE +C +C LOCATE THE TRIANGLE +C + CALL CONLOC(NDP,XD,YD,NT,IWK(JWIPT),NL,IWK(JWIPL),X,Y,LOC, + 1 IWK(JWIWL),WK) +C +C IF OUTSIDE CONVEX HULL THEN DON'T COMPUTE A VALUE +C + IF (LOC.GT.NT) RETURN +C +C GET THE VECTOR 1 VALUES FOR THE TRIANGLE +C + IVEC = (LOC-1)*3 + JWIPT + IV = IWK(IVEC) + X1 = X - XD(IV) + Y1 = Y - YD(IV) + Z1 = ZD(IV) +C +C COMPUT THE Z VALUE +C + IPOINT = (LOC-1)*3 + IPR +C + Z = (WK(IPOINT)*X1+WK(IPOINT+1)*Y1)/WK(IPOINT+2) + Z1 +C + CONLCM = Z +C + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conlin.f b/sys/gio/ncarutil/conlib/conlin.f new file mode 100644 index 00000000..f940d48c --- /dev/null +++ b/sys/gio/ncarutil/conlib/conlin.f @@ -0,0 +1,68 @@ + SUBROUTINE CONLIN(XD,YD,ZD,NT,IWK,WK) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C THIS ROUTINE GENERATES THE COORDINATES USED IN A LINEAR INTERPOLATION +C OF THE TRIANGLES CREATED FROM IRREGULARLY DISTRIBUTED DATA. +C +C INPUT +C XD-X INPUT COORDINATES] +C YD-Y INPUT COORDINATES +C ZD-Z VALUE AT INPUT X,Y +C NT-NUMBER OF TRIANGLES GENERATED +C IWK-LIST OF TRIANGLE POINTS, RELATIVE TO XD,YD +C GROUPED 3 PER TRIANGLE I.E. TRIANGLE 1 IWK(1,2,3), +C TRIANGLE 2 IWK(4,5,6) ETC. +C +C OUTPUT +C WK ARRAY OF COEFICENTS FOR LINEATION FORMUALS +C GROUPED 3 PER TRIANGLE +C POINTS ARE (TRI-1)*3 + 1,2,3 +C + DIMENSION IWK(1),WK(1),XD(1),YD(1),ZD(1) +C + SAVE +C +C LOOP FOR ALL TRIANGLES +C + DO 1000 ITRI = 1,NT +C +C GET THE POINTS OF THE TRIANGLE +C + IPOINT = (ITRI-1)*3 + IP1 = IWK(IPOINT+1) + IP2 = IWK(IPOINT+2) + IP3 = IWK(IPOINT+3) +C +C GET THE VALUES AT THE TRIANBGLE POINTS +C + X1 = XD(IP1) + Y1 = YD(IP1) + Z1 = ZD(IP1) + X2 = XD(IP2) + Y2 = YD(IP2) + Z2 = ZD(IP2) + X3 = XD(IP3) + Y3 = YD(IP3) + Z3 = ZD(IP3) +C +C COMPUTE THE INTERPLOATING COEFICIENTS +C + WK(IPOINT+1) = (Y2-Y1)*(Z3-Z1)-(Y3-Y1)*(Z2-Z1) + WK(IPOINT+2) = (X3-X1)*(Z2-Z1)-(X2-X1)*(Z3-Z1) + WK(IPOINT+3) = (X3-X1)*(Y2-Y1)-(X2-X1)*(Y3-Y1) +C + 1000 CONTINUE +C + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conloc.f b/sys/gio/ncarutil/conlib/conloc.f new file mode 100644 index 00000000..5907c9df --- /dev/null +++ b/sys/gio/ncarutil/conlib/conloc.f @@ -0,0 +1,256 @@ + SUBROUTINE CONLOC (NDP,XD,YD,NT,IPT,NL,IPL,XII,YII,ITI,IWK,WK) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C THIS SUBROUTINE LOCATES A POINT, I.E., DETERMINES TO WHAT TRI- +C ANGLE A GIVEN POINT (XII,YII) BELONGS. WHEN THE GIVEN POINT +C DOES NOT LIE INSIDE THE DATA AREA, THIS SUBROUTINE DETERMINES +C THE BORDER LINE SEGMENT WHEN THE POINT LIES IN AN OUTSIDE +C RECTANGULAR AREA, AND TWO BORDER LINE SEGMENTS WHEN THE POINT +C LIES IN AN OUTSIDE TRIANGULAR AREA. +C THE INPUT PARAMETERS ARE +C NDP = NUMBER OF DATA POINTS, +C XD,YD = ARRAYS OF DIMENSION NDP CONTAINING THE X AND Y +C COORDINATES OF THE DATA POINTS, +C NT = NUMBER OF TRIANGLES, +C IPT = INTEGER ARRAY OF DIMENSION 3*NT CONTAINING THE +C POINT NUMBERS OF THE VERTEXES OF THE TRIANGLES, +C NL = NUMBER OF BORDER LINE SEGMENTS, +C IPL = INTEGER ARRAY OF DIMENSION 3*NL CONTAINING THE +C POINT NUMBERS OF THE END POINTS OF THE BORDER +C LINE SEGMENTS AND THEIR RESPECTIVE TRIANGLE +C NUMBERS, +C XII,YII = X AND Y COORDINATES OF THE POINT TO BE +C LOCATED. +C THE OUTPUT PARAMETER IS +C ITI = TRIANGLE NUMBER, WHEN THE POINT IS INSIDE THE +C DATA AREA, OR +C TWO BORDER LINE SEGMENT NUMBERS, IL1 AND IL2, +C CODED TO IL1*(NT+NL)+IL2, WHEN THE POINT IS +C OUTSIDE THE DATA AREA. +C THE OTHER PARAMETERS ARE +C IWK = INTEGER ARRAY OF DIMENSION 18*NDP USED INTER- +C NALLY AS A WORK AREA, +C WK = ARRAY OF DIMENSION 8*NDP USED INTERNALLY AS A +C WORK AREA. +C DECLARATION STATEMENTS +C + DIMENSION XD(1) ,YD(1) ,IPT(1) ,IPL(1) , + 1 IWK(1) ,WK(1) +C +C +C + DIMENSION NTSC(9) ,IDSC(9) + COMMON /CONRA5/ NIT ,ITIPV +C + SAVE +C +C STATEMENT FUNCTIONS +C + SIDE(U1,V1,U2,V2,U3,V3) = (U1-U3)*(V2-V3)-(V1-V3)*(U2-U3) + SPDT(U1,V1,U2,V2,U3,V3) = (U1-U2)*(U3-U2)+(V1-V2)*(V3-V2) +C +C PRELIMINARY PROCESSING +C + NT0 = NT + NL0 = NL + NTL = NT0+NL0 + X0 = XII + Y0 = YII +C +C PROCESSING FOR A NEW SET OF DATA POINTS +C + IF (NIT .NE. 0) GO TO 170 + NIT = 1 +C +C - DIVIDES THE X-Y PLANE INTO NINE RECTANGULAR SECTIONS. +C + XMN = XD(1) + XMX = XMN + YMN = YD(1) + YMX = YMN + DO 100 IDP=2,NDP + XI = XD(IDP) + YI = YD(IDP) + XMN = AMIN1(XI,XMN) + XMX = AMAX1(XI,XMX) + YMN = AMIN1(YI,YMN) + YMX = AMAX1(YI,YMX) + 100 CONTINUE + XS1 = (XMN+XMN+XMX)/3.0 + XS2 = (XMN+XMX+XMX)/3.0 + YS1 = (YMN+YMN+YMX)/3.0 + YS2 = (YMN+YMX+YMX)/3.0 +C +C - DETERMINES AND STORES IN THE IWK ARRAY TRIANGLE NUMBERS OF +C - THE TRIANGLES ASSOCIATED WITH EACH OF THE NINE SECTIONS. +C + DO 110 ISC=1,9 + NTSC(ISC) = 0 + IDSC(ISC) = 0 + 110 CONTINUE + IT0T3 = 0 + JWK = 0 + DO 160 IT0=1,NT0 + IT0T3 = IT0T3+3 + I1 = IPT(IT0T3-2) + I2 = IPT(IT0T3-1) + I3 = IPT(IT0T3) + XMN = AMIN1(XD(I1),XD(I2),XD(I3)) + XMX = AMAX1(XD(I1),XD(I2),XD(I3)) + YMN = AMIN1(YD(I1),YD(I2),YD(I3)) + YMX = AMAX1(YD(I1),YD(I2),YD(I3)) + IF (YMN .GT. YS1) GO TO 120 + IF (XMN .LE. XS1) IDSC(1) = 1 + IF (XMX.GE.XS1 .AND. XMN.LE.XS2) IDSC(2) = 1 + IF (XMX .GE. XS2) IDSC(3) = 1 + 120 IF (YMX.LT.YS1 .OR. YMN.GT.YS2) GO TO 130 + IF (XMN .LE. XS1) IDSC(4) = 1 + IF (XMX.GE.XS1 .AND. XMN.LE.XS2) IDSC(5) = 1 + IF (XMX .GE. XS2) IDSC(6) = 1 + 130 IF (YMX .LT. YS2) GO TO 140 + IF (XMN .LE. XS1) IDSC(7) = 1 + IF (XMX.GE.XS1 .AND. XMN.LE.XS2) IDSC(8) = 1 + IF (XMX .GE. XS2) IDSC(9) = 1 + 140 DO 150 ISC=1,9 + IF (IDSC(ISC) .EQ. 0) GO TO 150 + JIWK = 9*NTSC(ISC)+ISC + IWK(JIWK) = IT0 + NTSC(ISC) = NTSC(ISC)+1 + IDSC(ISC) = 0 + 150 CONTINUE +C +C - STORES IN THE WK ARRAY THE MINIMUM AND MAXIMUM OF THE X AND +C - Y COORDINATE VALUES FOR EACH OF THE TRIANGLE. +C + JWK = JWK+4 + WK(JWK-3) = XMN + WK(JWK-2) = XMX + WK(JWK-1) = YMN + WK(JWK) = YMX + 160 CONTINUE + GO TO 200 +C +C CHECKS IF IN THE SAME TRIANGLE AS PREVIOUS. +C + 170 IT0 = ITIPV + IF (IT0 .GT. NT0) GO TO 180 + IT0T3 = IT0*3 + IP1 = IPT(IT0T3-2) + X1 = XD(IP1) + Y1 = YD(IP1) + IP2 = IPT(IT0T3-1) + X2 = XD(IP2) + Y2 = YD(IP2) + IF (SIDE(X1,Y1,X2,Y2,X0,Y0) .LT. 0.0) GO TO 200 + IP3 = IPT(IT0T3) + X3 = XD(IP3) + Y3 = YD(IP3) + IF (SIDE(X2,Y2,X3,Y3,X0,Y0) .LT. 0.0) GO TO 200 + IF (SIDE(X3,Y3,X1,Y1,X0,Y0) .LT. 0.0) GO TO 200 + GO TO 260 +C +C CHECKS IF ON THE SAME BORDER LINE SEGMENT. +C + 180 IL1 = IT0/NTL + IL2 = IT0-IL1*NTL + IL1T3 = IL1*3 + IP1 = IPL(IL1T3-2) + X1 = XD(IP1) + Y1 = YD(IP1) + IP2 = IPL(IL1T3-1) + X2 = XD(IP2) + Y2 = YD(IP2) + IF (IL2 .NE. IL1) GO TO 190 + IF (SPDT(X1,Y1,X2,Y2,X0,Y0) .LT. 0.0) GO TO 200 + IF (SPDT(X2,Y2,X1,Y1,X0,Y0) .LT. 0.0) GO TO 200 + IF (SIDE(X1,Y1,X2,Y2,X0,Y0) .GT. 0.0) GO TO 200 + GO TO 260 +C +C CHECKS IF BETWEEN THE SAME TWO BORDER LINE SEGMENTS. +C + 190 IF (SPDT(X1,Y1,X2,Y2,X0,Y0) .GT. 0.0) GO TO 200 + IP3 = IPL(3*IL2-1) + X3 = XD(IP3) + Y3 = YD(IP3) + IF (SPDT(X3,Y3,X2,Y2,X0,Y0) .LE. 0.0) GO TO 260 +C +C LOCATES INSIDE THE DATA AREA. +C - DETERMINES THE SECTION IN WHICH THE POINT IN QUESTION LIES. +C + 200 ISC = 1 + IF (X0 .GE. XS1) ISC = ISC+1 + IF (X0 .GE. XS2) ISC = ISC+1 + IF (Y0 .GE. YS1) ISC = ISC+3 + IF (Y0 .GE. YS2) ISC = ISC+3 +C +C - SEARCHES THROUGH THE TRIANGLES ASSOCIATED WITH THE SECTION. +C + NTSCI = NTSC(ISC) + IF (NTSCI .LE. 0) GO TO 220 + JIWK = -9+ISC + DO 210 ITSC=1,NTSCI + JIWK = JIWK+9 + IT0 = IWK(JIWK) + JWK = IT0*4 + IF (X0 .LT. WK(JWK-3)) GO TO 210 + IF (X0 .GT. WK(JWK-2)) GO TO 210 + IF (Y0 .LT. WK(JWK-1)) GO TO 210 + IF (Y0 .GT. WK(JWK)) GO TO 210 + IT0T3 = IT0*3 + IP1 = IPT(IT0T3-2) + X1 = XD(IP1) + Y1 = YD(IP1) + IP2 = IPT(IT0T3-1) + X2 = XD(IP2) + Y2 = YD(IP2) + IF (SIDE(X1,Y1,X2,Y2,X0,Y0) .LT. 0.0) GO TO 210 + IP3 = IPT(IT0T3) + X3 = XD(IP3) + Y3 = YD(IP3) + IF (SIDE(X2,Y2,X3,Y3,X0,Y0) .LT. 0.0) GO TO 210 + IF (SIDE(X3,Y3,X1,Y1,X0,Y0) .LT. 0.0) GO TO 210 + GO TO 260 + 210 CONTINUE +C +C LOCATES OUTSIDE THE DATA AREA. +C + 220 DO 240 IL1=1,NL0 + IL1T3 = IL1*3 + IP1 = IPL(IL1T3-2) + X1 = XD(IP1) + Y1 = YD(IP1) + IP2 = IPL(IL1T3-1) + X2 = XD(IP2) + Y2 = YD(IP2) + IF (SPDT(X2,Y2,X1,Y1,X0,Y0) .LT. 0.0) GO TO 240 + IF (SPDT(X1,Y1,X2,Y2,X0,Y0) .LT. 0.0) GO TO 230 + IF (SIDE(X1,Y1,X2,Y2,X0,Y0) .GT. 0.0) GO TO 240 + IL2 = IL1 + GO TO 250 + 230 IL2 = MOD(IL1,NL0)+1 + IP3 = IPL(3*IL2-1) + X3 = XD(IP3) + Y3 = YD(IP3) + IF (SPDT(X3,Y3,X2,Y2,X0,Y0) .LE. 0.0) GO TO 250 + 240 CONTINUE + IT0 = 1 + GO TO 260 + 250 IT0 = IL1*NTL+IL2 +C +C NORMAL EXIT +C + 260 ITI = IT0 + ITIPV = IT0 + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conlod.f b/sys/gio/ncarutil/conlib/conlod.f new file mode 100644 index 00000000..d7fc3804 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conlod.f @@ -0,0 +1,194 @@ + SUBROUTINE CONLOD (XD,YD,ZD,NDP,WK,IWK,SCRARR) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C****************************************************************** +C* * +C* THIS FILE IS A PACKAGE OF SUPPORT ROUTINES FOR THE ULIB * +C* FILES CONRAN AND CONRAS. SEE THOSE FILES FOR AN * +C* EXPLAINATION OF THE ENTRY POINTS. * +C* * +C****************************************************************** +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500), NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT + COMMON /CONR14/LINEAR + LOGICAL LINEAR + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + DIMENSION SCRARR(1) +C + SAVE +C +C IFR - FLAG TO REGISTER FIRST PASS IN Y DIRECTION +C +C LOAD THE SCRATCH SPACE AND CONVEX HULL POINTERS +C ITLOC IS THE LIST OF CONVEX HULL POINTERS RELATIVE TO THE SCARTCH +C SPACE. +C PV IS THE LIST OF CONVEX HULL POINTERS RELATIVE TO USER COORDINATES +C +C INITALIZE THE SPECIAL VALUE FEATURE +C + X = (XED-XST)/2. + XST + Y = (YED-YST)/2. + YST + IF(LINEAR) GO TO 1 + SPVAL = CONCOM(X,Y,XD,YD,ZD,NDP,WK,IWK,IT) + GO TO 2 + 1 SPVAL = CONLCM(X,Y,XD,YD,ZD,NDP,WK,IWK,IT) + 2 CONTINUE +C +C INITIALIZE THE SEARCH +C + IYMAX = 0 + IFR = 1 + JX = 1 + X = XST + 10 JY = 1 + Y = YST +C +C SET HULL POINTERS FOR THIS COLUMN TO NULL +C + ITLOC(JX*2-1) = 0 + ITLOC(JX*2) = 0 +C +C FLAG START OF COLUMN +C + LOOP = 1 +C +C GET INTERPOLATED VALUE +C + 20 IF (LINEAR) GO TO 3 + RVAL = CONCOM(X,Y,XD,YD,ZD,NDP,WK,IWK,IT) + GO TO 4 + 3 RVAL = CONLCM(X,Y,XD,YD,ZD,NDP,WK,IWK,IT) + 4 CONTINUE + SCRARR(JY+(JX-1)*IYMAX) = RVAL + IF (RVAL.GT.SPVAL) SPVAL = RVAL +C +C IF OUTSIDE CONVEX HULL BRANCH +C + IF (IT.GT.NTNL) GO TO 30 +C +C IF OUTSIDE TRIANGLES AND USING LINEAR INTERPLOATION THEN BRANCH +C + IF(LINEAR.AND.IT.GT.NT) GO TO 30 +C +C IF FIRST OF COLUMN IN HULL CONTINUE THROUGH +C + IF (LOOP.NE.1) GO TO 40 +C +C SET HULL POINTERS +C + PV(JX*2-1) = Y + ITLOC(JX*2-1) = JY +C +C SET FLAG TO LOOK FOR END OF HULL IN COLUMN +C + LOOP = 2 +C +C GO FOR NEXT ENTRY +C + GO TO 40 +C +C TEST FOR END OF CONVEX HULL ON THIS ROW +C + 30 IF (LOOP.NE.2) GO TO 40 +C +C END OF HULL SET POINTERS FOR END OF HULL AND FLAG IT VIA LOOP +C + LOOP = 0 + ITLOC(JX*2) = JY-1 + PV(JX*2) = Y-STPSZ +C +C GET NEXT ELEMENT IN ROW IF NOT OUTSIDE ENCLOSING RECTANGULAR +C BOARDER +C + 40 Y = Y+STPSZ + JY = JY+1 + IF (Y.LE.YED) GO TO 20 +C +C TEST FOR FIRST COLUMN +C + IF (IFR.NE.1) GO TO 50 +C +C FIRST COLUMN OVER SET MAX Y VALUES +C + IYMAX = JY-1 + YMAX = Y-STPSZ + IFR = 0 +C +C IF HULL WENT TO EDGE OF RECTANGULAR BOARDER SET HULL POINTERS HERE +C + 50 IF (LOOP.NE.2) GO TO 60 + PV(JX*2) = Y-STPSZ + ITLOC(JX*2) = JY-1 +C +C END OF COLUMN GET NEXT ONE +C + 60 X = X+STPSZ + JX = JX+1 +C +C IF NOT END OF WORK CONTINUE WITH NEXT COLUMN +C + IF (X.LE.XED) GO TO 10 +C +C END OF WORK SET MAX X VALUES +C + IXMAX = JX-1 + XMAX = X-STPSZ + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conop1.f b/sys/gio/ncarutil/conlib/conop1.f new file mode 100644 index 00000000..fc61872d --- /dev/null +++ b/sys/gio/ncarutil/conlib/conop1.f @@ -0,0 +1,465 @@ + SUBROUTINE CONOP1 (IOPT) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C SET THE CONTRAN OPTIONS +C +C INPUT +C IOPT-CHARACTER STRING OF OPTION VALUE +C +C SET COMMON DATA EQUAL TO INPUT DATA +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT + COMMON /CONR14/LINEAR + LOGICAL LINEAR + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH + COMMON /RANINT/ IRANMJ, IRANMN, IRANTX + COMMON /RAQINT/ IRAQMJ, IRAQMN, IRAQTX + COMMON /RASINT/ IRASMJ, IRASMN, IRASTX +C +C +C +C INTPR IS THE DASH PACKAGE COMMON BLOCK INTERFACE +C NP11 IS NP IN ALL OTHER INTPR DEFINITIONS; NAME CHANGE BECAUSE OF +C CONFLICT +C + COMMON /INTPR/ IPAU ,FPART ,TENSN ,NP11 , + 1 SMALL ,L1 ,ADDLR ,ADDTB , + 2 MLLINE ,ICLOSE + CHARACTER*7 IOPT + CHARACTER*2 TAG, OPT +C +C + SAVE +C +c +NOAO - initialize block data before changing any values + call conbdn +c -NOAO +C DETERMINE OPTION AND ITS VALUE +C + TAG = IOPT(1:2) + IF (IOPT(3:3) .EQ. '=') THEN + OPT = IOPT(4:5) + ELSE + OPT = IOPT(5:6) + ENDIF +C +C REP FOUND CHECK VALUE OF SWITCH +C + IF (TAG .EQ. 'RE') THEN +C +C SWITCH = ON CONTOUR SAME DATA +C + IF (OPT .EQ. 'ON') THEN + REPEAT = .TRUE. + RETURN +C +C SWITCH = OFF CONTOUR NEW DATA +C + ELSEIF (OPT .EQ. 'OF') THEN + REPEAT = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C EXTRAPOLATION FLAG +C + ELSEIF (TAG .EQ. 'EX') THEN +C +C SWITCH = ON EXTRAPOLATE WHEN CONTOURING +C + IF (OPT .EQ. 'ON') THEN + EXTRAP = .TRUE. + RETURN +C +C SWITCH = OFF INTERPOLATE ONLY +C + ELSEIF (OPT .EQ. 'OF') THEN + EXTRAP = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C PER FOUND SET PERIMETER +C + ELSEIF (TAG .EQ. 'PE') THEN +C +C SWITCH = ON DRAW PERIMETERS +C + IF (OPT .EQ. 'ON') THEN + PER = .TRUE. +C +C TURN GRID OFF, USER WANTS PERIMETER +C + GRD = .FALSE. + RETURN +C +C SWITCH = OFF DO NOT DRAW PERIMETERS +C + ELSEIF (OPT .EQ. 'OF') THEN + PER = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C DEF FOUND SET ALL OPTIONS TO DEFAULT (NO SWITCHES) +C + ELSEIF (TAG .EQ. 'DE') THEN + PER = .TRUE. + LISTOP = .FALSE. + PMIMX = .FALSE. + SCALE = 1. + TENSN = TENS + EXTRAP = .FALSE. + TITLE = .FALSE. + ITLSIZ = 16 + REPEAT = .FALSE. + MESS = .TRUE. + CON = .FALSE. + CINC = .FALSE. + CHILO = .FALSE. + IGRAD = IG + ISCALE = 0 + NCP = 4 + LOOK = .FALSE. + GRD = .FALSE. + PLDVLS = .FALSE. + INMAJ = 1 + INMIN = 1 + INDAT = 1 + INLAB = 1 + IRANMJ = 1 + IRANMN = 1 + IRANTX = 1 + IRASMJ = 1 + IRASMN = 1 + IRASTX = 1 + IRAQMJ = 1 + IRAQMN = 1 + IRAQTX = 1 + BPSIZ = 0. + LABON = .TRUE. + ISIZEL = 9 + ISIZEP = 8 + ISIZEM = 15 + FRADV = .TRUE. + EXTRI = .FALSE. + MINGAP = 3 + LINEAR = .FALSE. + ICOUNT = 0 + SHIELD = .FALSE. + SLDPLT = .FALSE. +C +C SET DEFAULT DASH PATTERN +C + IDASH = '$$$$$$$$$$' + NDASH = '$$$$$$$$$$' + EDASH = '$$$$$$$$$$' +C +C SET DEFAULT FORMAT +C + FORM = '(G10.3)' + RETURN +C +C MES FOUND TEST VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'ME') THEN +C +C ACTIVATE CONRAN MESSAGE +C + IF (OPT .EQ. 'ON') THEN + MESS = .TRUE. + RETURN +C +C TURN OFF CONRAN MESSAGE +C + ELSEIF (OPT .EQ. 'OF') THEN + MESS = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C SCALING OPTION GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'SC') THEN +C +C SET VALUE OF SCALE FLAG +C + IF (OPT .EQ. 'ON') THEN + ISCALE = 0 + RETURN + ELSEIF (OPT .EQ. 'OF') THEN + ISCALE = 1 + RETURN + ELSEIF (OPT .EQ. 'PR') THEN + ISCALE = 2 + RETURN + ELSE + GOTO 120 + ENDIF +C +C TRIANGLE FLAG GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'TR') THEN +C +C SWITCH ON +C + IF (OPT .EQ. 'ON') THEN + LOOK = .TRUE. + RETURN +C +C SWITCH OFF +C + ELSEIF (OPT .EQ. 'OF') THEN + LOOK = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C PLOT DATA VALUES FLAG GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'PD') THEN +C +C SWITCH ON +C + IF (OPT .EQ. 'ON') THEN + PLDVLS = .TRUE. + RETURN +C +C SWITCH OFF +C + ELSEIF (OPT .EQ. 'OF') THEN + PLDVLS = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C GRID OPTION ACTIVATED GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'GR') THEN +C +C SWITCH ON SET GRID FLAG +C + IF (OPT .EQ. 'ON') THEN + GRD = .TRUE. +C +C TURN PER OFF USER WANTS GRID +C + PER = .FALSE. + RETURN +C +C SWITCH OFF CLEAR GRID FLAG +C + ELSEIF (OPT .EQ. 'OF') THEN + GRD = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C LABEL PLOTTING FLAG GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'LA') THEN +C +C SWITCH ON LABEL CONTOURS +C + IF (OPT .EQ. 'ON') THEN + LABON = .TRUE. + RETURN +C +C SWITCH OFF DON"T LABEL CONTOURS +C + ELSEIF (OPT .EQ. 'OF') THEN + LABON = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C PLOT THE RELATIVE MIN"S AND MAX"S +C + ELSEIF (TAG .EQ. 'PM') THEN +C +C SWTICH ON PLOT THE INFO +C + IF (OPT .EQ. 'ON') THEN + PMIMX = .TRUE. + RETURN +C +C SWTICH OFF DO NOT PLOT THE INFO +C + ELSEIF (OPT .EQ. 'OF') THEN + PMIMX = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C ADVANCE FRAME BEFORE TRIANGULATION PLOT +C + ELSEIF (TAG .EQ. 'TF') THEN +C +C SWITCH ON ADVANCE FRAME +C + IF (OPT .EQ. 'ON') THEN + FRADV = .TRUE. + RETURN +C +C SWITCH OFF DO NOT ADVANCE FRAME +C + ELSEIF (OPT .EQ. 'OF') THEN + FRADV = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C EXIT AFTER TRIANGULATION +C + ELSEIF (TAG .EQ. 'TO') THEN +C +C SWITCH ON EXIT AFTER TRIANGULATION +C + IF (OPT .EQ. 'ON') THEN + EXTRI = .TRUE. + LOOK = .TRUE. + FRADV = .FALSE. + RETURN +C +C SWITCH OFF DO NOT EXIT AFTER TRIANGULATION +C + ELSEIF (OPT .EQ. 'OF') THEN + FRADV = .TRUE. + LOOK = .FALSE. + EXTRI = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C LIST OPTION GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'LO') THEN +C +C ON SET LIST OPTIONS FLAG +C + IF (OPT .EQ. 'ON') THEN + LISTOP = .TRUE. + RETURN +C +C TURN OFF LIST OPTIONS FLAG +C + ELSEIF (OPT .EQ. 'OF') THEN + LISTOP = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C SET THE INTERPOLATION SCHEME +C + ELSEIF (TAG .EQ. 'IT') THEN +C +C SET TO C1 SURFACE +C + IF (OPT .EQ. 'C1') THEN + LINEAR = .FALSE. + RETURN +C +C SET TO LINEAR INTERPOLATION +C + ELSEIF (OPT .EQ. 'LI') THEN + LINEAR = .TRUE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C SET THE SHIELD PLOT FLAG +C + ELSEIF (TAG .EQ. 'PS') THEN +C +C TURN ON SHIELD PLOT +C + IF (OPT .EQ. 'ON') THEN + SLDPLT = .TRUE. + RETURN +C +C TURN OFF SHIELD PLOT +C + ELSEIF (OPT .EQ. 'OF') THEN + SLDPLT = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF + ELSE + GOTO 120 + ENDIF +C +C ERROR UNDEFINED OPTION DETECTED +C + 120 CALL SETER (' CONOP1 -- UNDEFINED OPTION',1,1) + RETURN +C + END diff --git a/sys/gio/ncarutil/conlib/conop2.f b/sys/gio/ncarutil/conlib/conop2.f new file mode 100644 index 00000000..41dc27c3 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conop2.f @@ -0,0 +1,316 @@ + SUBROUTINE CONOP2 (IOPT,ISIZE) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C SET THE CONTRAN OPTIONS +C +C INPUT +C IOPT-CHARACTER STRING OF OPTION VALUE +C ISIZE- INTEGER INPUT +C +C SET COMMON DATA EQUAL TO INPUT DATA +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT + COMMON /CONR14/LINEAR + LOGICAL LINEAR + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH + COMMON /RANINT/ IRANMJ, IRANMN, IRANTX + COMMON /RAQINT/ IRAQMJ, IRAQMN, IRAQTX + COMMON /RASINT/ IRASMJ, IRASMN, IRASTX +C +C +C +C INTPR IS THE DASH PACKAGE COMMON BLOCK INTERFACE +C NP11 IS NP IN ALL OTHER INTPR DEFINITIONS; NAME CHANGE BECAUSE OF +C CONFLICT +C + COMMON /INTPR/ IPAU ,FPART ,TENSN ,NP11 , + 1 SMALL ,L1 ,ADDLR ,ADDTB , + 2 MLLINE ,ICLOSE + CHARACTER*7 IOPT + CHARACTER*2 TAG, OPT +C + SAVE +C +NOAO - initialize block data before changing any values + call conbdn +c -NOAO +C DETERMINE THE OPTION DESIRED +C + TAG = IOPT(1:2) + IF (IOPT(3:3) .EQ. '=') THEN + OPT = IOPT(4:5) + ELSE + OPT = IOPT(5:6) + ENDIF +C +C SET RESOLUTION OF VIRTUAL GRID +C + IF (TAG .EQ. 'SS') THEN +C +C SWITCH = ON SET RESOLUTION OF VIRTUAL GRID +C + IF (OPT .EQ. 'ON') THEN + IGRAD = ISIZE + RETURN +C +C SWITCH = OFF RESET RESOLUTION TO DEFAULT +C + ELSEIF (OPT .EQ. 'OF') THEN + IGRAD = IG + RETURN + ELSE + GOTO 120 + ENDIF +C +C NCP OPTION GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'NC') THEN +C +C SWITCH ON GET VALUE FOR NUMBER OF SURROUNDING DATA POINTS TO USE +C + IF (OPT .EQ. 'ON') THEN + NCP = ISIZE + RETURN +C +C SWITCH OFF SET TO DEFAULT VALUE +C + ELSEIF (OPT .EQ. 'OF') THEN + NCP = 4 + RETURN + ELSE + GOTO 120 + ENDIF +C +C INTENSITY OPTION FOUND GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'IN') THEN +C +C SWITCH OFF SET DEFAULT VALUES +C + IF (OPT .EQ. 'OF') THEN + IRANMJ = 1 + IRANMN = 1 + IRANTX = 1 + IRASMJ = 1 + IRASMN = 1 + IRASTX = 1 + IRAQMJ = 1 + IRAQMN = 1 + IRAQTX = 1 + INMAJ = 1 + INMIN = 1 + INDAT = 1 + INLAB = 1 + RETURN +C +C SET PLOTTED DATA INTENSITY +C + ELSEIF (OPT .EQ. 'DA') THEN + INDAT = ISIZE + RETURN +C +C SET TITLE AND MESSAGE INTENSITY +C + ELSEIF (OPT .EQ. 'LA') THEN + INLAB = ISIZE + IRANTX = ISIZE + IRASTX = ISIZE + IRAQTX = ISIZE + RETURN +C +C SET ALL INTENSITIES TO THE SAME VALUE +C + ELSEIF (OPT .EQ. 'AL') THEN + IRANMJ = ISIZE + IRANMN = ISIZE + IRANTX = ISIZE + IRASMJ = ISIZE + IRASMN = ISIZE + IRASTX = ISIZE + IRAQMJ = ISIZE + IRAQMN = ISIZE + IRAQTX = ISIZE + INMAJ = ISIZE + INMIN = ISIZE + INLAB = ISIZE + INDAT = ISIZE + RETURN +C +C SET MAJOR LINE INTENSITY +C + ELSEIF (OPT .EQ. 'MA') THEN + IRANMJ = ISIZE + IRASMJ = ISIZE + IRAQMJ = ISIZE + INMAJ = ISIZE + RETURN +C +C SET MINOR LINE INTENSITY +C + ELSEIF (OPT .EQ. 'MI') THEN + IRANMN = ISIZE + IRASMN = ISIZE + IRAQMN = ISIZE + INMIN = ISIZE + RETURN + ELSE + GOTO 120 + ENDIF +C +C LABEL SIZE OPTION GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'LS') THEN +C +C SWITCH ON GET USER LABEL SIZE +C + IF (OPT .EQ. 'ON') THEN + ISIZEL = ISIZE + RETURN +C +C SWITCH OFF SET LABEL SIZE TO DEFAULT +C + ELSEIF (OPT .EQ. 'OF') THEN + ISIZEL = 9 + RETURN + ELSE + GOTO 120 + ENDIF +C +C SET SIZES OF MINIMUM AND MAXIMUM LABELS +C + ELSEIF (TAG .EQ. 'SM') THEN +C +C SWTICH ON GET USERS SIZE +C + IF (OPT .EQ. 'ON') THEN + ISIZEM = ISIZE + RETURN +C +C SWTICH OFF SET TO DEFAULT VALUE +C + ELSEIF (OPT .EQ. 'OF') THEN + ISIZEM = 15 + RETURN + ELSE + GOTO 120 + ENDIF +C +C SET SIZE OF THE PLOTTED DATA +C + ELSEIF (TAG .EQ. 'SP') THEN +C +C SWTICH ON GET USERS SIZE +C + IF (OPT .EQ. 'ON') THEN + ISIZEP = ISIZE + RETURN +C +C SWTICH OFF SET TO DEFAULT +C + ELSEIF (OPT .EQ. 'OF') THEN + ISIZEP = 8 + RETURN + ELSE + GOTO 120 + ENDIF +C +C TITLE SIZE SWITCH +C + ELSEIF (TAG .EQ. 'ST') THEN +C +C SWITCH ON SET THE TITLE SIZE +C + IF (OPT .EQ. 'ON') THEN + ITLSIZ = ISIZE + RETURN +C +C SWITCH OFF SET TITLE SIZE TO DEFAULT VALUE +C + ELSEIF (OPT .EQ. 'OF') THEN + ITLSIZ = 16 + RETURN + ELSE + GOTO 120 + ENDIF +C +C MINOR LINE COUNT OPTION +C + ELSEIF (TAG .EQ. 'MI') THEN +C +C SET MINOR LINE COUNT +C + IF (OPT .EQ. 'ON') THEN + MINGAP = ISIZE+1 + RETURN +C +C SET MINOR LINE COUNT TO DEFAULT +C + ELSEIF (OPT .EQ. 'OF') THEN + MINGAP = 3 + RETURN + ELSE + GOTO 120 + ENDIF + ELSE + GOTO 120 + ENDIF +C +C ERROR UNDEFINED OPTION DETECTED +C + 120 CALL SETER (' CONOP2 - UNDEFINED OPTION',1,1) + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conop3.f b/sys/gio/ncarutil/conlib/conop3.f new file mode 100644 index 00000000..e4632478 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conop3.f @@ -0,0 +1,266 @@ + SUBROUTINE CONOP3 (IOPT,ARRAY,ISIZE) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C SET THE CONTRAN OPTIONS +C +C INPUT +C IOPT-CHARACTER STRING OF OPTION VALUE +C ARRAY- REAL ARRAY OF DIMENSION ISIZE +C ISIZE- SIZE OF ARRAY +C +C SET COMMON DATA EQUAL TO INPUT DATA +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT + COMMON /CONR14/LINEAR + LOGICAL LINEAR + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C +C +C INTPR IS THE DASH PACKAGE COMMON BLOCK INTERFACE +C NP11 IS NP IN ALL OTHER INTPR DEFINITIONS; NAME CHANGE BECAUSE OF +C CONFLICT +C + COMMON /INTPR/ IPAU ,FPART ,TENSN ,NP11 , + 1 SMALL ,L1 ,ADDLR ,ADDTB , + 2 MLLINE ,ICLOSE + DIMENSION ARRAY(ISIZE) + CHARACTER*7 IOPT + CHARACTER*2 TAG, OPT +C +C + SAVE +C +C +NOAO - initialize block data before changing any values + call conbdn +c -NOAO +C DETERMINE THE OPTION DESIRED +C + TAG = IOPT(1:2) + IF (IOPT(3:3) .EQ. '=') THEN + OPT = IOPT(4:5) + ELSE + OPT = IOPT(5:6) + ENDIF +C +C CON CONTOUR LEVELS CHECK VALUE OF SWITCH +C + IF (TAG .EQ. 'CO') THEN +C +C SWITCH = ON SET CONTOUR LEVELS +C + IF (OPT .EQ. 'ON') THEN + IF (CHILO .OR. CINC) GOTO 140 +C +C TEST IF NUMBER OF CONTOURS IS ACCEPTABLE +C + IF (ISIZE .GT. 30) + 1 CALL SETER (' CONOP3-NUMBER OF CONTOUR LEVELS EXCEEDS 30', + 2 1,1) + DO 200 I=1,ISIZE + CL(I) = ARRAY(I) + 200 CONTINUE + CON = .TRUE. + NCL = ISIZE + RETURN +C +C SWITCH = OFF CLEAR CONTOUR LEVEL ARRAY (PROGRAM SELECTS) +C + ELSEIF (OPT .EQ. 'OF') THEN + CON = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C CONTOUR HI LO OPTION FOUND GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'CH') THEN +C +C SWITCH ON SET HI AND FLO +C + IF (OPT .EQ. 'ON') THEN + IF (CON) GOTO 140 + HI = ARRAY(1) + FLO = ARRAY(2) + CHILO = .TRUE. + RETURN +C +C SWITCH OFF CLEAR FLAG +C + ELSEIF (OPT .EQ. 'OF') THEN + CHILO = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C CONTOUR INCREMENT OPTION GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'CI') THEN +C +C SWITCH ON SET INCREMENT +C + IF (OPT .EQ. 'ON') THEN + IF (CON) GOTO 140 + CINC = .TRUE. + FINC = ARRAY(1) + RETURN +C +C SWITCH OFF CLEAR FLAG +C + ELSEIF (OPT .EQ. 'OF') THEN + CINC = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C SCALE THE DATA PLOTTED ON THE CONTOURS AND MIN MAX POINTS +C + ELSEIF (TAG .EQ. 'SD') THEN +C +C SWTICH ON GET SCALE FACTOR +C + IF (OPT .EQ. 'ON') THEN + SCALE = ARRAY(1) + RETURN +C +C SWTICH OFF SET FOR NO SCALING +C + ELSEIF (OPT .EQ. 'OF') THEN + SCALE = 1. + RETURN + ELSE + GOTO 120 + ENDIF +C +C SET THE TENSION VALUE FOR SMOOTHING +C + ELSEIF (TAG .EQ. 'TE') THEN +C +C SWTICH ON SET TENSION FACTOR +C + IF (OPT .EQ. 'ON') THEN + TENSN = ARRAY(1) + RETURN +C +C SWTICH OFF SET TO DEFAULT TENSION +C + ELSEIF (OPT .EQ. 'OF') THEN + TENSN = TENS + RETURN + ELSE + GOTO 120 + ENDIF +C +C DASH PATTERN BREAK POINT SWITCH +C + ELSEIF (TAG .EQ. 'DB') THEN +C +C SWITCH ON GET USERS BREAKPOINT +C + IF (OPT .EQ. 'ON') THEN + BPSIZ = ARRAY(1) + RETURN +C +C SWITCH OFF SET TO DEFAULT +C + ELSEIF (OPT .EQ. 'OF') THEN + BPSIZ = 0. + RETURN + ELSE + GOTO 120 + ENDIF +C +C SHIELD OPTION +C + ELSEIF (TAG .EQ. 'SL') THEN +C +C TURN SHIELDING ON AND SET THE SHIELD COORD POINTERS +C + IF (OPT .EQ. 'ON') THEN + NISIZE = ISIZE/2 + CALL CONSSD(ARRAY(1),ARRAY(NISIZE+1),NISIZE) + RETURN +C +C DEACTIVATE SHIELDING +C + ELSEIF (OPT .EQ. 'OF') THEN + ICOUNT = 0 + SHIELD = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF + ELSE + GOTO 120 + ENDIF +C +C ERROR UNDEFINED OPTION DETECTED +C + 120 CALL SETER (' CONOP3-UNDEFINED OPTION',1,1) + RETURN +C +C ILLEGAL USE OF CON WITH CIL OR CHL +C + 140 CALL SETER + 1('CONOP3-ILLEGAL USE OF CON OPTION WITH CIL OR CHL OPTION', + 2 1,1) + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conop4.f b/sys/gio/ncarutil/conlib/conop4.f new file mode 100644 index 00000000..f963dcf9 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conop4.f @@ -0,0 +1,197 @@ + SUBROUTINE CONOP4 (IOPT,ARRAY,ISIZE,IFORT) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C SET THE CONTRAN OPTIONS +C +C INPUT +C IOPT -- CHARACTER STRING OF OPTION VALUE +C ARRAY -- CHARACTER INPUT DATA +C ISIZE -- INTEGER INPUT +C IFORT -- INTEGER. THIS VALUE IS USED ONLY WHEN IOPT IS +C "FMT=ON". IN THIS CASE, IFORT IS THE TOTAL NUMBER +C OF CHARACTERS TO BE PROCESSED BY THE FORMAT +C STATEMENT. FOR EXAMPLE, FOR THE FORMAT "F10.3", +C IFORT SHOULD BE SET TO 10. +C +C SET COMMON DATA EQUAL TO INPUT DATA +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT + COMMON /CONR14/LINEAR + LOGICAL LINEAR + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C +C +C INTPR IS THE DASH PACKAGE COMMON BLOCK INTERFACE +C NP11 IS NP IN ALL OTHER INTPR DEFINITIONS; NAME CHANGE BECAUSE OF +C CONFLICT +C + COMMON /INTPR/ IPAU ,FPART ,TENSN ,NP11 , + 1 SMALL ,L1 ,ADDLR ,ADDTB , + 2 MLLINE ,ICLOSE + CHARACTER*(*) ARRAY + CHARACTER*7 IOPT + CHARACTER*2 TAG, OPT +C + SAVE +C +C +NOAO - initialize block data before changing any values + call conbdn +c -NOAO +C DETERMINE THE OPTION DESIRED +C + TAG = IOPT(1:2) + IF (IOPT(3:3) .EQ. '=') THEN + OPT = IOPT(4:5) + ELSE + OPT = IOPT(5:6) + ENDIF +C +C TITLE OPTION GET VALUE OF SWITCH +C + IF (TAG .EQ. 'TL') THEN +C +C SWITCH ON GET TITLE AND COUNT FROM INPUT +C + IF (OPT .EQ. 'ON') THEN + TITLE = .TRUE. + ISTRNG = ARRAY + ICNT = ISIZE + RETURN +C +C SWITCH OFF OPTION DEACTIVATED +C + ELSEIF (OPT .EQ. 'OF') THEN + TITLE = .FALSE. + RETURN + ELSE + GOTO 120 + ENDIF +C +C CHANGE DATA VALUE FORMAT +C + ELSEIF (TAG .EQ. 'FM') THEN +C +C SWITCH ON GET USER FORMAT +C + IF (OPT .EQ. 'ON') THEN + FORM = ARRAY + LEN = ISIZE + IFMT = IFORT + RETURN +C +C SWITCH OFF SET FORMAT TO DEFAULT +C + ELSEIF (OPT .EQ. 'OF') THEN + FORM = '(G10.3)' + LEN = LEND + IFMT = IFMTD + RETURN + ELSE + GOTO 120 + ENDIF +C +C DASH PATTERN OPTION GET VALUE OF SWITCH +C + ELSEIF (TAG .EQ. 'DA') THEN +C +C SWITCH OFF DEFAULT PATTERNS +C + IF (OPT .EQ. 'OF') THEN + NDASH = '$$$$$$$$$$' + EDASH = '$$$$$$$$$$' + IDASH = '$$$$$$$$$$' + RETURN +C +C SWITCH ALL SET GTR,LSS,AND EQU TO SAME VALUE +C + ELSEIF (OPT .EQ. 'AL') THEN + IDASH = ARRAY + EDASH = ARRAY + NDASH = ARRAY + RETURN +C +C SWITCH SET TO POS CHANGE POS DASH PATTERN +C + ELSEIF (OPT .EQ. 'GT') THEN + IDASH = ARRAY + RETURN +C +C SWITCH SET TO NEG SET NEG DASH PATTERN +C + ELSEIF (OPT .EQ. 'LS') THEN + NDASH = ARRAY + RETURN +C +C SWITCH SET TO EQU SET EQUAL DASH PATTERN +C + ELSEIF (OPT .EQ. 'EQ') THEN + EDASH = ARRAY + RETURN + ELSE + GOTO 120 + ENDIF + ELSE + GOTO 120 + ENDIF +C +C ERROR UNDEFINED OPTION DETECTED +C + 120 CALL SETER (' CONOP4-UNDEFINED OPTION',1,1) + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conot2.f b/sys/gio/ncarutil/conlib/conot2.f new file mode 100644 index 00000000..f2bc6aed --- /dev/null +++ b/sys/gio/ncarutil/conlib/conot2.f @@ -0,0 +1,178 @@ + SUBROUTINE CONOT2 (IVER,IUNIT) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C + NOAO - This routine is a no-op in IRAF. +C - NOAO +C +C OUTPUT THE OPTION VALUES TO THE LINE PRINTER +C +C CONTINUE FOR CONRAN AND CONRAS +C +C +C +C COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , +C 1 FINC ,HI ,FLO +C COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , +C 1 ISCALE ,LOOK ,PLDVLS ,GRD , +C 2 CINC ,CHILO ,CON ,LABON , +C 3 PMIMX ,SCALE ,FRADV ,EXTRI , +C 4 BPSIZ ,LISTOP +C COMMON /CONRA3/ IREC +C COMMON /CONRA4/ NCP ,NCPSZ +C COMMON /CONRA5/ NIT ,ITIPV +C COMMON /CONRA6/ XST ,YST ,XED ,YED , +C 1 STPSZ ,IGRAD ,IG ,XRG , +C 2 YRG ,BORD ,PXST ,PYST , +C 3 PXED ,PYED ,ITICK +C COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ +C COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , +C 1 LEN ,IFMT ,LEND , +C 2 IFMTD ,ISIZEP ,INMIN +C COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , +C 1 BR ,TL ,BL ,CONV , +C 2 XN ,YN ,ITLL ,IBLL , +C 3 ITRL ,IBRL ,XC ,YC , +C 4 ITLOC(210) ,JX ,JY ,ILOC , +C 5 ISHFCT ,XO ,YO ,IOC ,NC +C COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , +C 1 JWIWL ,JWIWP ,JWIPL ,IPR , +C 2 ITPV +C COMMON /CONR11/ NREP ,NCRT ,ISIZEL , +C 1 MINGAP ,ISIZEM , +C 2 TENS +C COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX +C LOGICAL REPEAT ,EXTRAP ,PER ,MESS , +C 1 LOOK ,PLDVLS ,GRD ,LABON , +C 2 PMIMX ,FRADV ,EXTRI ,CINC , +C 3 TITLE ,LISTOP ,CHILO ,CON +C COMMON /CONR15/ ISTRNG +C CHARACTER*64 ISTRNG +C COMMON /CONR16/ FORM +C CHARACTER*10 FORM +C COMMON /CONR17/ NDASH, IDASH, EDASH +C CHARACTER*10 NDASH, IDASH, EDASH +C +C +C SAVE +C +C LABEL THE CONTOURS +C +C WRITE (IUNIT,1001) +C IF (LABON) GO TO 100 +C WRITE (IUNIT,1002) +C GO TO 110 +C 100 WRITE (IUNIT,1003) +C +C LABEL SIZE +C +C 110 WRITE (IUNIT,1004) ISIZEL +C +C SCALE DATA ON CONTOURS +C +C WRITE (IUNIT,1005) +C IF (SCALE .NE. 1.) GO TO 120 +C WRITE (IUNIT,1006) +C GO TO 130 +C 120 WRITE (IUNIT,1007) SCALE +C +C TENSION FACTOR +C +C 130 WRITE (IUNIT,1008) TENS +C +C PLOT RELATIVE MINS AND MAXS +C +C WRITE (IUNIT,1009) +C IF (PMIMX) GO TO 140 +C WRITE (IUNIT,1010) +C GO TO 150 +C 140 WRITE (IUNIT,1011) +C +C SIZE OF MINIMUM AND MAXIMUM LABELS +C +C 150 WRITE (IUNIT,1012) ISIZEM +C +C DASH PATTERN +C +C WRITE (IUNIT,1013) +C IF (IDASH(1:1) .EQ. ' ') GO TO 170 +C WRITE (IUNIT,1014) IDASH +C GO TO 180 +C 170 WRITE (IUNIT,1015) +C 180 IF (EDASH(1:1) .EQ. ' ') GO TO 200 +C WRITE (IUNIT,1016) EDASH +C GO TO 210 +C 200 WRITE (IUNIT,1017) +C 210 IF (NDASH(1:1) .EQ. ' ') GO TO 230 +C WRITE (IUNIT,1018) NDASH +C GO TO 240 +C 230 WRITE (IUNIT,1019) +C +C DASH PATTERN BREAK POINT +C +C 240 WRITE (IUNIT,1020) BPSIZ +C +C PRINT MINOR LINE GAP +C +C ITT = MINGAP-1 +C WRITE (IUNIT,1021) ITT +C RETURN +C +C 1001 FORMAT (5X,'LABEL THE CONTOURS, LAB=') +C 1002 FORMAT ('+',28X,'OFF') +C 1003 FORMAT ('+',28X,'ON') +C 1004 FORMAT (5X,'CONTOUR LABEL SIZE IN PWRIT UNITS, LSZ=',I4) +C 1005 FORMAT (5X,'SCALE THE DATA ON CONTOUR LINES, SDC=') +C 1006 FORMAT ('+',41X,'OFF') +C 1007 FORMAT ('+','ON, SCALE FACTOR=',G10.3) +C 1008 FORMAT (5X,'TENSION FACTOR (USED FOR SMOOTH AND SUPER), TEN=', +C 1 F6.2) +C 1009 FORMAT (5X,'PLOT RELATIVE MINIMUMS AND MAXIMUMS, PMM=') +C 1010 FORMAT ('+',45X,'OFF') +C 1011 FORMAT ('+',45X,'ON') +C 1012 FORMAT (5X,'SIZE OF MIN AND MAX LABELS IN PWRIT UNITS SML=', +C 1 I4) +C 1013 FORMAT (5X,'DASH PATTERN GTR=GREATER, EQU=EQUAL, LSS=LESS') +C 1014 FORMAT (10X,'GTR=',A10) +C 1015 FORMAT (10X,'GTR=$$$$$$$$$$') +C 1016 FORMAT (10X,'EQU=',A10) +C 1017 FORMAT (10X,'EQU=$$$$$$$$$$') +C 1018 FORMAT (10X,'LSS=',A10) +C 1019 FORMAT (10X,'LSS=$$$$$$$$$$') +C 1020 FORMAT (5X,'DASH PATTERN BREAK POINT, DBP=',G10.3) +C 1021 FORMAT (5X,'MINOR LINE COUNT=',I3) +C +C +C****************************************************************** +C* * +C* REVISION HISTORY * +C* * +C* JUNE 1980 ADDED CONTERP TO ULIB * +C* AUGUST 1980 FIXED THE FOLLOWING PROBLEMS * +C* 1.PLOTTING OF INPUT DATA VALUES * +C* 2.SETTING OF MINIMUM INTENSITY IN ALL OPTION * +C* 3.SETTING OF EQU FLAG IN CONTOUR DASH PATTERN * +C* 4.TURNING OFF OF SIZE OF PLOTTED DATA OPTION * +C* DECEMBER 1980 FIXED CONTOUR SELECTION ALGORITHM AND MOVED IN * +C* DASH PACKAGE COMMON BLOCK INTPR +C* MARCH 1981 FIXED NON-PORTABLE STATEMENT ORDERING IN CONSET * +C* APRIL 1981 FIXED OPTION LISTING ROUTINE * +C* ADDED MINOR LINE COUNT OPTION * +C* JULY 1983 ADDED LINEAR INTERPOLATION AND SHIELDING * +C* JULY 1984 CONVERTED TO STANDARD FORTRAN77 AND GKS * +C* AUGUST 1985 DELETED LOC (MACHINE DEPENDENT FUNCTION), CHANGED * +C* COMMON /CONR13/ * +C* * +C****************************************************************** +C + END diff --git a/sys/gio/ncarutil/conlib/conout.f b/sys/gio/ncarutil/conlib/conout.f new file mode 100644 index 00000000..c2684de9 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conout.f @@ -0,0 +1,350 @@ + SUBROUTINE CONOUT (IVER) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C + NOAO - This routine is a no-op in IRAF. +C - NOAO +C +C LIST OUT ALL THE CONRAN OPTION VALUES ON THE LINE PRINTER +C +C THE VALUE OF IVER DETERMINES WHICH ENTRY POINT CALLED THIS ROUTINE +C +C 1. CONRAQ +C 2. CONRAN +C 3. CONRAS +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT + COMMON /CONR14/LINEAR + LOGICAL LINEAR + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C + SAVE +C +C GET THE STANDARD OUTPUT UNIT TO WRITE THE OPTION VALUE LIST +C + IUNIT = I1MACH(2) +C +C PRINT OUT HEADER AND ALL OPTIONS WHICH APPLY TO CALLING VERSION +C +C GO TO ( 100, 110, 120),IVER +C 100 WRITE (IUNIT,1001) +C GO TO 130 +C 110 WRITE (IUNIT,1002) +C GO TO 130 +C 120 WRITE (IUNIT,1003) +C 130 WRITE (IUNIT,1004) +C +C PERIMETER +C +C WRITE (IUNIT,1005) +C IF (PER) GO TO 140 +C WRITE (IUNIT,1006) +C GO TO 150 +C 140 WRITE (IUNIT,1007) +C +C GRID +C +C 150 WRITE (IUNIT,1008) +C IF (GRD) GO TO 160 +C WRITE (IUNIT,1009) +C GO TO 170 +C 160 WRITE (IUNIT,1010) +C +C SCALING OF DATA ON FRAME +C +C 170 WRITE (IUNIT,1011) +C GO TO ( 180, 190, 200),ISCALE+1 +C 180 WRITE (IUNIT,1012) +C GO TO 210 +C 190 WRITE (IUNIT,1013) +C GO TO 210 +C 200 WRITE (IUNIT,1014) +C +C SAME DATA ANOTHER PLOT +C +C 210 WRITE (IUNIT,1015) +C IF (REPEAT) GO TO 220 +C WRITE (IUNIT,1016) +C GO TO 230 +C 220 WRITE (IUNIT,1017) +C +C SHIELDING +C +C 230 WRITE(IUNIT,2000) +C IF (SHIELD) GO TO 231 +C WRITE(IUNIT,2001) +C GO TO 232 +C 231 WRITE(IUNIT,2002) +C +C INTERPOLATION +C +C 232 WRITE(IUNIT,2003) +C IF (LINEAR) GO TO 233 +C WRITE(IUNIT,2004) +C GO TO 234 +C 233 WRITE(IUNIT,2005) +C +C PLOT THE SHIELD +C +C 234 WRITE(IUNIT,2006) +C IF (SLDPLT) GO TO 235 +C WRITE(IUNIT,2007) +C GO TO 236 +C 235 WRITE(IUNIT,2008) +C +C EXTRAPOLATION +C +C 236 WRITE (IUNIT,1018) +C IF (EXTRAP) GO TO 240 +C WRITE (IUNIT,1019) +C GO TO 250 +C 240 WRITE (IUNIT,1020) +C +C STEP SIZE OR RESOLUTION OF THE GRID +C +C 250 WRITE (IUNIT,1021) IGRAD +C +C MESSAGE AT BOTTOM OF PLOT +C +C WRITE (IUNIT,1022) +C IF (MESS) GO TO 260 +C WRITE (IUNIT,1023) +C GO TO 270 +C 260 WRITE (IUNIT,1024) +C +C TITLE AT TOP OF PLOT +C +C 270 WRITE (IUNIT,1025) +C IF (TITLE) GO TO 280 +C WRITE (IUNIT,1026) +C GO TO 290 +C 280 WRITE (IUNIT,1027) +C +C SIZE OF TITLE +C +C 290 WRITE (IUNIT,1028) ITLSIZ +C +C PRINT TITLE +C +C IF (ICNT.EQ.0 .OR. .NOT.TITLE) GO TO 310 +C ICC = 100 +C IF (ICC .GT. ICNT) ICC = ICNT +C WRITE (IUNIT,1029) ISTRNG +C +C DATA POINTS USED FOR PARTIAL DERIVATIVE ESTIMATION +C +C 310 WRITE (IUNIT,1030) NCP +C +C LOOK AT TRIANGLES SWITCH +C +C WRITE (IUNIT,1031) +C IF (LOOK) GO TO 320 +C WRITE (IUNIT,1032) +C GO TO 330 +C 320 WRITE (IUNIT,1033) +C +C ADVANCE FRAME BEFORE PLOTTING TRIANGULATION +C +C 330 WRITE (IUNIT,1034) +C IF (FRADV) GO TO 340 +C WRITE (IUNIT,1035) +C GO TO 350 +C 340 WRITE (IUNIT,1036) +C +C TRIANGLES ONLY PLOT +C +C 350 WRITE (IUNIT,1037) +C IF (EXTRI) GO TO 360 +C WRITE (IUNIT,1038) +C GO TO 370 +C 360 WRITE (IUNIT,1039) +C +C PLOT THE INPUT DATA VALUES +C +C 370 WRITE (IUNIT,1040) +C IF (PLDVLS) GO TO 380 +C WRITE (IUNIT,1041) +C GO TO 390 +C 380 WRITE (IUNIT,1042) +C +C FORMAT OF THE PLOTTED INPUT DATA +C +C 390 WRITE (IUNIT,1043) +C IF (LEN .NE. 0) GO TO 400 +C WRITE (IUNIT,1044) +C GO TO 420 +C 400 WRITE (IUNIT,1045) FORM +C +C SIZE OF THE PLOTTED DATA VALUES +C +C 420 WRITE (IUNIT,1046) ISIZEP +C +C INTENSITY SETTINGS +C +C WRITE (IUNIT,1047) +C WRITE (IUNIT,1048) INMAJ,INMIN,INLAB,INDAT +C +C DISTLAY CONTOUR SETTING +C +C WRITE (IUNIT,1049) +C IF (CON) GO TO 430 +C WRITE (IUNIT,1050) +C GO TO 440 +C 430 WRITE (IUNIT,1051) NCL,(CL(I),I=1,NCL) +C +C CONTOUR INCREMENT +C +C 440 WRITE (IUNIT,1052) +C IF (CINC) GO TO 450 +C WRITE (IUNIT,1053) +C GO TO 460 +C 450 WRITE (IUNIT,1054) FINC +C +C CONTOUR HIGH AND LOW VALUES +C +C 460 WRITE (IUNIT,1055) +C IF (CHILO) GO TO 470 +C WRITE (IUNIT,1056) +C GO TO 480 +C 470 WRITE (IUNIT,1057) HI,FLO +C +C CALL CONOT2 IF NOT QUICK VERSION +C +C 480 IF (IVER .NE. 1) CALL CONOT2 (IVER,IUNIT) +C +C THE ROUTINE CONOT2 WAS GENERATED TO ELIMINATE COMPILER ERRORS +C RESULTING FROM TOO MANY FORMAT STATEMENTS IN ONE SUBROUTINE +C +C RETURN +C +C +C1001 FORMAT (1X,'CONRAQ') +C1002 FORMAT (1X,'CONRAN') +C1003 FORMAT (1X,'CONRAS') +C1004 FORMAT ('+',6X,'-OPTION VALUE SETTINGS',/ +C 1 ,7X,'ALL NON-PWRIT VALUES APPLY TO THE UNSCALED DATA') +C1005 FORMAT (5X,'PERIMETER, PER=') +C1006 FORMAT ('+',19X,'OFF') +C1007 FORMAT ('+',19X,'ON') +C1008 FORMAT (5X,'GRID, GRD=') +C1009 FORMAT ('+',14X,'OFF') +C1010 FORMAT ('+',14X,'ON') +C1011 FORMAT (5X,'SCALING OF PLOT ON FRAME, SCA=') +C1012 FORMAT ('+',34X,'ON') +C1013 FORMAT ('+',34X,'OFF') +C1014 FORMAT ('+',34X,'PRI') +C1015 FORMAT (5X,'SAME DATA FOR ANOTHER PLOT, REP=') +C1016 FORMAT ('+',36X,'OFF') +C1017 FORMAT ('+',36X,'ON') +C1018 FORMAT (5X,'EXTRAPOLATION, EXT=') +C1019 FORMAT ('+',23X,'OFF') +C1020 FORMAT ('+',23X,'ON') +C1021 FORMAT (5X,'RESOLUTION, SSZ=',I4) +C1022 FORMAT (5X,'MESSAGE, MES=') +C1023 FORMAT ('+',17X,'OFF') +C1024 FORMAT ('+',17X,'ON') +C1025 FORMAT (5X,'TITLE, TLE=') +C1026 FORMAT ('+',15X,'OFF') +C1027 FORMAT ('+',15X,'ON') +C1028 FORMAT (5X,'TITLE SIZE IN PWRIT UNITS, STL=',I4) +C1029 FORMAT (5X,'TITLE=',A64) +C1030 FORMAT (5X,'DATA POINTS USED FOR PARTIAL DERIVATIVE', +C 1' ESTIMATION, NCP=',I4) +C1031 FORMAT (5X,'LOOK AT TRIANGLES, TRI=') +C1032 FORMAT ('+',27X,'OFF') +C1033 FORMAT ('+',27X,'ON') +C1034 FORMAT (5X,'ADVANCE FRAME BEFORE PLOTTING TRIANGULATION,', +C 1' TFR=') +C1035 FORMAT ('+',53X,'OFF') +C1036 FORMAT ('+',53X,'ON') +C1037 FORMAT (5X,'TRIANGULATION ONLY PLOT, TOP=') +C1038 FORMAT ('+',33X,'OFF') +C1039 FORMAT ('+',33X,'ON') +C1040 FORMAT (5X,'PLOT THE INPUT DATA VALUES, PDV=') +C1041 FORMAT ('+',36X,'OFF') +C1042 FORMAT ('+',36X,'ON') +C1043 FORMAT (5X,'FORMAT OF THE PLOTTED INPUT DATA, FMT=') +C1044 FORMAT ('+',42X,'(G10.3)') +C1045 FORMAT ('+',42X,A10) +C1046 FORMAT (5X,'SIZE OF THE PLOTTED DATA VALUES IN PWRIT', +C 1' UNITS, SPD=',I4) +C1047 FORMAT (5X,'COLOR (INTENSITY) INDICES FOLLOW.', +C 1' FOR CONRAQ MAJOR CONTOURS ARE ONLY USED') +C1048 FORMAT (10X,'MAJOR CONTOUR LINES, MAJ=',I4,/ +C 1 ,10X,'MINOR CONTOUR LINES, MIN=',I4,/ +C 2 ,10X,'TITLE AND MESSAGE, LAB=',I4,/ +C 3 ,10X,'PLOTTED DATA VALUES, DAT=',I4) +C1049 FORMAT (5X,'CONTOUR LEVELS, CON=') +C1050 FORMAT ('+',25X,'OFF') +C1051 FORMAT ('+',25X,'ON, NCL=',I4,' ARRAY='/(10(2X,F10.3))) +C1052 FORMAT (5X,'CONTOUR INCREMENT, CIL=') +C1053 FORMAT ('+',27X,'OFF') +C 1054 FORMAT ('+',27X,'ON, INCREMENT=',G10.3) +C 1055 FORMAT (5X,'CONTOUR HIGH AND LOW VALUES, CHL=') +C 1056 FORMAT ('+',37X,'OFF') +C 1057 FORMAT ('+',37X,'ON, HI=',G10.3,' FLO=',G10.3) +C 2000 FORMAT (5X,'SHIELDING, SLD=') +C 2001 FORMAT ('+',19X,'OFF') +C 2002 FORMAT ('+',19X,'ON') +C 2003 FORMAT (5X,'INTERPOLATION, ITP=') +C 2004 FORMAT ('+',23X,'C1 SURFACE') +C 2005 FORMAT ('+',23X,'LINEAR') +C 2006 FORMAT (5X,'PLOT THE SHIELD, SPT=') +C 2007 FORMAT ('+',25X,'OFF') +C 2008 FORMAT ('+',25X,'ON') +C + END diff --git a/sys/gio/ncarutil/conlib/conpdv.f b/sys/gio/ncarutil/conlib/conpdv.f new file mode 100644 index 00000000..49c1f61f --- /dev/null +++ b/sys/gio/ncarutil/conlib/conpdv.f @@ -0,0 +1,118 @@ + SUBROUTINE CONPDV (XD,YD,ZD,NDP) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C PLOT THE DATA VALUES ON THE CONTOUR MAP +C CURRENTLY UP TO 10 CHARACTERS FOR EACH VALUE ARE DISPLAYED +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH + COMMON /RANINT/ IRANMJ, IRANMN, IRANTX + COMMON /RAQINT/ IRAQMJ, IRAQMN, IRAQTX + COMMON /RASINT/ IRASMJ, IRASMN, IRASTX +C +C + CHARACTER*10 ISTR + DIMENSION XD(1) ,YD(1) ,ZD(1) +C + SAVE +C +C DATA TO CONVERT 0-32767 COORIDNATES TO 1-1024 VALUES +C + DATA TRANS/32./ +C +C SET INTENSITY +C + IF (INDAT .NE. 1) THEN + CALL GSTXCI (INDAT) + ELSE + CALL GSTXCI (IRANTX) + ENDIF +C +C SET FORMAT IF NONE SPECIFIED +C + IF (LEN .NE. 0) GO TO 110 + FORM = '(G10.3)' + LEN = LEND + IFMT = IFMTD +C +C LOOP AND PLOT ALL VALUES +C + 110 DO 120 K=1,NDP + CALL FL2INT (XD(K),YD(K),MX,MY) + MX = IFIX(FLOAT(MX)/TRANS)+1 + MY = IFIX(FLOAT(MY)/TRANS)+1 +C +C + NOAO - FTN internal write rewritten as call to encode for IRAF +C +C WRITE(ISTR,FORM)ZD(K) + call encode (len, form, istr, zd(k)) +C +C - NOAO +C +C POSITION STRINGS PROPERLY IF COORDS ARE IN PAU'S +C + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = CPUX(MX) + YC = CPUY(MY) +C + CALL WTSTR(XC,YC,ISTR,ISIZEP,0,0) + CALL GSELNT(ICN) + 120 CONTINUE + IF (INDAT .NE. 1) THEN + CALL GSTXCI (IRANTX) + ENDIF + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conreo.f b/sys/gio/ncarutil/conlib/conreo.f new file mode 100644 index 00000000..c029c0bb --- /dev/null +++ b/sys/gio/ncarutil/conlib/conreo.f @@ -0,0 +1,129 @@ + SUBROUTINE CONREO (MAJLNS) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C THIS ROUTINE PUTS THE MAJOR (LABELED) LEVELS IN THE BEGINNING OF CL +C AND THE MINOR (UNLABELED) LEVELS IN END OF CL. THE NUMBER OF MAJOR +C LEVELS IS RETURNED IN MAJLNS. PV IS USED AS A WORK SPACE. MINGAP IS +C THE NUMBER OF MINOR GAPS (ONE MORE THAN THE NUMBER OF MINOR LEVELS +C BETWEEN MAJOR LEVELS). +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C + SAVE +C + NL = NCL + IF (NL.LE.4 .OR. MINGAP.LE.1) GO TO 160 + NML = MINGAP-1 + IF (NL.LE.10) NML = 1 +C +C CHECK FOR BREAK POINT IN THE LIST OF CONTOURS FOR A MAJOR LINE +C + NMLP1 = NML+1 + DO 10 I=1,NL + ISAVE = I + IF (CL(I).EQ.BPSIZ) GO TO 40 + 10 CONTINUE +C +C NO BREAKPOINT FOUND SO TRY FOR A NICE NUMBER +C + L = NL/2 + L = ALOG10( ABS( CL(L) ) )+1. + Q = 10.**L + DO 30 J=1,3 + Q = Q/10. + DO 20 I=1,NL + ISAVE = I + IF (AMOD( ABS( CL(I) + 1.E-9*CL(I) )/Q,FLOAT(NMLP1) ).LE. + 1 .0001) GO TO 40 + 20 CONTINUE + 30 CONTINUE + ISAVE = NL/2 +C +C PUT MAJOR LEVELS IN PV +C + 40 ISTART = MOD(ISAVE,NMLP1) + IF (ISTART.EQ.0) ISTART = NMLP1 + NMAJL = 0 + DO 50 I=ISTART,NL,NMLP1 + NMAJL = NMAJL+1 + PV(NMAJL) = CL(I) + 50 CONTINUE + MAJLNS = NMAJL + L = NMAJL +C +C PUT MINOR LEVELS IN PV +C + IC = NML/2 + 1 + L = MAJLNS+1 + DO 100 LOOP=1,NML + IC1 = IC + DO 90 IWCH=1,2 + IF (LOOP.EQ.1) GO TO 60 + IC1 = IC+(LOOP-1) + IF (IWCH.EQ.2) IC1 = IC-(LOOP-1) + IF (IC1.GE.NMLP1) GO TO 90 + IF (IC1.LE.0) GO TO 90 + 60 DO 70 K=ISTART,NL,NMLP1 + IND = K+IC1 + IF (IND.GT.NL) GO TO 80 + PV(L) = CL(IND) + L = L+1 + 70 CONTINUE + 80 IF (LOOP.EQ.1) GO TO 100 + 90 CONTINUE + 100 CONTINUE +C +C IF MAJOR LINES DID NOT START ON THE FIRST ENTRY PICK UP THE MISSING +C LEVELS +C + IF (ISTART.EQ.1) GO TO 140 + DO 130 LOOP=1,NML + IC1 = IC + DO 120 IWCH=1,2 + IF (LOOP.EQ.1) GO TO 110 + IC1 = IC+(LOOP-1) + IF (IWCH.EQ.2) IC1 = IC-(LOOP-1) + 110 IF (IC1.GE.ISTART) GO TO 120 + IF (IC1.LE.0) GO TO 120 + PV(L) = CL(IC1) + L = L+1 + IF (LOOP.EQ.1) GO TO 130 + 120 CONTINUE + 130 CONTINUE +C +C PUT REORDERED ARRAY BACK IN ORIGINAL PLACE +C + 140 DO 150 I=1,NL + CL(I) = PV(I) + 150 CONTINUE + RETURN + 160 MAJLNS = NL + RETURN + END diff --git a/sys/gio/ncarutil/conlib/consld.f b/sys/gio/ncarutil/conlib/consld.f new file mode 100644 index 00000000..fd40e10d --- /dev/null +++ b/sys/gio/ncarutil/conlib/consld.f @@ -0,0 +1,165 @@ + SUBROUTINE CONSLD (SCRARR) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C THIS ROUTINE IS USED TO GENERATE A SHIELD WHERE CONTOUR +C DRAWING IS ALLOWED. +C +C THE ROUTINE TAKES THE SILHOUETTE INFORMATION FROM COMMON BLOCK +C CONR13 AND TRANSFORMS THIS INTO A SHIELD TO BE USED IN THE +C SCRATCH ARRAY PASSED IN BY THE USER (THE SCRATCH ARRAY HOLDS THE +C GRIDED DATA FROM THE INTERPOLATION). +C +C INPUT +C SCRARR-THE SCRATCH ARRAY HOLDING THE INTERPOLATED DATA +C +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA9/ ICOORD(500), NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT +C +C INCREASE THE RESOLUTION OF THE SHIELD PROFILE +C + DIMENSION SCRARR(1) +C + SAVE + DATA RESINC/8.0/ +C +C STATEMENT FUNCTION TO MAKE ARRAY ACCESS SEEM LIKE MATRIX ACCESS +C +C +NOAO +C These statement functions are never called. +C SCRTCH(IXX,IYY) = SCRARR(IYY+(IXX-1)*IYMAX) +C IARVL(IXX,IYY) = IYY+(IXX-1)*IYMAX +C -NOAO + IGADDR(XXX,YYY) = + 1 IFIX((YYY-YST)/STPSZ+.5)+(IFIX((XXX-XST)/STPSZ+.5))*IYMAX +C +C SET THE SPECIAL VALUE +C + SPVAL = SPVAL * 2. +C +C SET THE USER ARRAY LOCATIONS TO TEMPORARY POINTERS +C +C LOOP FOR ALL SHIELD ELEMENTS +C + DO 100 IC = 1,ICOUNT +C +C ASSIGN LINE SEGMENT END POINTS +C + X1 = XVS(IC) + Y1 = YVS(IC) + IF (IC .EQ. ICOUNT) GO TO 10 + X2 = XVS(IC+1) + Y2 = YVS(IC+1) + GO TO 15 + 10 CONTINUE + X2 = XVS(1) + Y2 = YVS(1) + 15 CONTINUE +C +C INSURE THAT ALL POINTS ARE IN THE CONVEX HULL +C + IF (X1.GT.XED) X1 = XED + IF (X1.LT.XST) X1 = XST + IF (X2.GT.XED) X2 = XED + IF (X2.LT.XST) X2 = XST + IF (Y1.GT.YED) Y1 = YED + IF (Y1.LT.YST) Y1 = YST + IF (Y2.GT.YED) Y2 = YED + IF (Y2.LT.YST) Y2 = YST +C +C SET THE START OF THE LINE SEGMENT SCRATCH LOCATION TO +C THE SPECIAL VALUE +C + II = IGADDR(X1,Y1) + SCRARR(II) = SPVAL +C +C FIND THE LENGTH OF THE LINE SEGMENT +C + DIST = SQRT(((X2-X1)**2)+((Y2-Y1)**2)) +C +C IF LENGTH SHORTER THAN STEP SIZE THEN THERE IS NOTHING TO DO +C + IF (DIST .LE. STPSZ) GO TO 100 +C +C SET UP LOOP TO SET ALL CELLS ON THE LINE SEGMENT +C + NSTPS = (DIST/STPSZ)*RESINC + XSTP = (X2-X1)/FLOAT(NSTPS) + YSTP = (Y2-Y1)/FLOAT(NSTPS) + X = X1 + Y = Y1 + DO 20 K = 1,NSTPS + X = X + XSTP + Y = Y + YSTP + II = IGADDR(X,Y) + SCRARR(II) = SPVAL + 20 CONTINUE +C + 100 CONTINUE +C +C FILL THE SHIELDED AREAS +C FOR EACH COLUMN THE ELEMENTS ARE SET TO SPVAL IF FILL IS TRUE. +C THE VALUE OF FILL IS NEGATED EVERY TIME A SPVAL IS ENCOUNTERED, +C AND THAT CELL REMAINS UNCHANGED. +C +C LOOP THROUGH THE GRID +C + DO 39 I = 1,IXMAX +C +C GET THE START AND END FOR THE COLUMN +C + IYS = (I-1)*IYMAX+1 + IYE = I*IYMAX +C +C ADVANCE IN THE FORWARD DIRECTION +C + DO 32 J = IYS,IYE +C +C IF NOT SPVAL THEN SET CELL AS APPROPIATE +C + IF (SCRARR(J).EQ.SPVAL) GO TO 33 + SCRARR(J) = SPVAL + 32 CONTINUE + GO TO 39 +C +C ADVANCE IN THE BACKWARD DIRECTION +C + 33 CONTINUE + DO 34 J = 1,IYMAX + NJ =IYE+1-J +C IF NOT SPVAL THEN SET CELL AS APPROPIATE +C + IF (SCRARR(NJ).EQ.SPVAL) GO TO 39 + SCRARR(NJ) = SPVAL + 34 CONTINUE + 39 CONTINUE +C + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conssd.f b/sys/gio/ncarutil/conlib/conssd.f new file mode 100644 index 00000000..26ac20d1 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conssd.f @@ -0,0 +1,61 @@ + SUBROUTINE CONSSD(X,Y,IC) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C THIS SUBROUTINE SETS THE SHIELDING FLAG AND CONNECTS THE +C USERS SHIELD ARRAYS TO SOME INTERNAL POINTERS +C +C INPUT +C X-X COORDINATE STRING +C Y-Y COORDINATE STRING +C IC-NUMBER OF COORDINATES +C +C NOTE THE USERS ARRAYS CANNOT BE MUCKED WITH DURING EXECUTION +C THOSE ARRAYS ARE USED DURING CONRAN EXECUTION +C + DIMENSION X(1),Y(1) + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT +C + SAVE +C +C SET COUNTER +C + ICOUNT = IC +C +C CHECK THE DIMENSION OF SHIELD ARRAYS +C + IERUNT = I1MACH(4) + IF (ICOUNT .GT. 50) THEN + CALL SETER (' CONSSD -- NUMBER OF SHIELD POINTS .GT. 50',1,1) +C +C + NOAO - FTN write and format statement commented out; SETER is enough. +C WRITE(IERUNT,1001) + ICOUNT = 50 + ENDIF +C1001 FORMAT(' ERROR 1 IN CONSSD -- NUMBER OF SHIELD POINTS .GT. 50') +C - NOAO +C +C SET THE SHIELDING FLAG TO TRUE +C + SHIELD = .TRUE. +C +C COMPUTE POINTERS FOR THE USERS SHIELDING ARRAYS +C + DO 300 I = 1,ICOUNT + XVS(I) = X(I) + 300 YVS(I) = Y(I) +C + RETURN + END diff --git a/sys/gio/ncarutil/conlib/constp.f b/sys/gio/ncarutil/conlib/constp.f new file mode 100644 index 00000000..8df0e23b --- /dev/null +++ b/sys/gio/ncarutil/conlib/constp.f @@ -0,0 +1,135 @@ + SUBROUTINE CONSTP (XD,YD,NDP) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C COMPUTE STEP SIZE IN X AND Y DIRECTION +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + DIMENSION XD(1) ,YD(1) +C + SAVE +C +C FIND SMALLEST AND LARGST X AND Y +C + XST = XD(1) + XED = XD(1) + YST = YD(1) + YED = YD(1) + DO 130 I=2,NDP + IF (XST .LE. XD(I)) GO TO 100 + XST = XD(I) + GO TO 110 + 100 IF (XED .GE. XD(I)) GO TO 110 + XED = XD(I) + 110 IF (YST .LE. YD(I)) GO TO 120 + YST = YD(I) + GO TO 130 + 120 IF (YED .GE. YD(I)) GO TO 130 + YED = YD(I) + 130 CONTINUE +C +C COMPUTE STEP SIZE +C + XRG = (ABS(XED-XST)) + YRG = (ABS(YED-YST)) + SQRG = XRG + IF (SQRG .LT. YRG) SQRG = YRG + STPSZ = SQRG/FLOAT(IGRAD-1) +C +C COMPUTE PARAMETERS FOR SET CALL +C + DIFX = XRG/SQRG + DIFY = YRG/SQRG + PXST = .5-(BORD*DIFX)/2. + PXED = .5+(BORD*DIFX)/2. + PYST = .5-(BORD*DIFY)/2. + PYED = .5+(BORD*DIFY)/2. + XRG = XRG/FLOAT(ITICK) + YRG = YRG/FLOAT(ITICK) +C +C TEST IF THE ASPECT RATIO FOR THE COORDINATES IS REASONABLE. +C REASONABLE IS CURRENTLY DEFINED AS 5 TO 1. +C IF IT IS NOT REASONABLE THEN A POOR PLOT MAY BE GENERATED +C SO IT IS NICE THE WARN THE USER WHEN THIS HAPPENS. +C + TEST = XRG/YRG + IF (TEST.LE.5. .AND. TEST.GE.0.2) RETURN +C +C WARN THE USER ON THE STANDARD OUTPUT UNIT THAT THE PLOT MAY +C NOT BE TOO GOOD. +C +C SET RECOVERY MODE +C + CALL ENTSR(IROLD,IREC) +C +C FLAG THE ERROR +C + CALL SETER(' ASPECT RATIO OF X AND Y GREATER THAN 5 TO 1', + 1 1,1) +C + CALL EPRIN +C +C CLEAR THE ERROR +C + CALL ERROF +C +C RESET USER ERROR MODE +C + CALL ENTSR(IDUM,IROLD) +C + RETURN + END diff --git a/sys/gio/ncarutil/conlib/contlk.f b/sys/gio/ncarutil/conlib/contlk.f new file mode 100644 index 00000000..201b4d07 --- /dev/null +++ b/sys/gio/ncarutil/conlib/contlk.f @@ -0,0 +1,98 @@ + SUBROUTINE CONTLK (XD,YD,NDP,IPT) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C DRAW THE TRIANGLES CREATED BY CONTNG +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C + DIMENSION XD(1) ,YD(1) ,IPT(1) +C + SAVE +C +C STATEMENT FUNCTIONS TO SCALE DATA FOR OVERLAYS +C + FX(XXX,YYY) = XXX + FY(XXX,YYY) = YYY +C +C ADVANCE PICTURE IF DESIRED +C + IF (FRADV) CALL FRAME +C +C DRAW TRIANGLES +C + DO 100 K=1,NT + I = K*3 + I1 = IPT(I) + I2 = IPT(I-1) + I3 = IPT(I-2) + XX = FX(XD(I1),YD(I1)) + CALL FL2INT (XX,FY(XD(I1),YD(I1)),MX1,MY1) + CALL PLOTIT (MX1,MY1,0) + XX = FX(XD(I2),YD(I2)) + CALL FL2INT (XX,FY(XD(I2),YD(I2)),MX,MY) + CALL PLOTIT (MX,MY,1) + XX = FX(XD(I3),YD(I3)) + CALL FL2INT (XX,FY(XD(I3),YD(I3)),MX,MY) + CALL PLOTIT (MX,MY,1) + CALL PLOTIT (MX1,MY1,1) + 100 CONTINUE +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(0,0,0) + RETURN + END diff --git a/sys/gio/ncarutil/conlib/contng.f b/sys/gio/ncarutil/conlib/contng.f new file mode 100644 index 00000000..7ebad596 --- /dev/null +++ b/sys/gio/ncarutil/conlib/contng.f @@ -0,0 +1,432 @@ + SUBROUTINE CONTNG (NDP,XD,YD,NT,IPT,NL,IPL,IWL,IWP,WK) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C THIS SUBROUTINE PERFORMS TRIANGULATION. IT DIVIDES THE X-Y +C PLANE INTO A NUMBER OF TRIANGLES ACCORDING TO GIVEN DATA +C POINTS IN THE PLANE, DETERMINES LINE SEGMENTS THAT FORM THE +C BORDER OF DATA AREA, AND DETERMINES THE TRIANGLE NUMBERS +C CORRESPONDING TO THE BORDER LINE SEGMENTS. +C AT COMPLETION, POINT NUMBERS OF THE VERTEXES OF EACH TRIANGLE +C ARE LISTED COUNTER-CLOCKWISE. POINT NUMBERS OF THE END POINTS +C OF EACH BORDER LINE SEGMENT ARE LISTED COUNTER-CLOCKWISE, +C LISTING ORDER OF THE LINE SEGMENTS BEING COUNTER-CLOCKWISE. +C THE INPUT PARAMETERS ARE +C NDP = NUMBER OF DATA POINTS, +C XD = ARRAY OF DIMENSION NDP CONTAINING THE +C X COORDINATES OF THE DATA POINTS, +C YD = ARRAY OF DIMENSION NDP CONTAINING THE +C Y COORDINATES OF THE DATA POINTS. +C THE OUTPUT PARAMETERS ARE +C NT = NUMBER OF TRIANGLES, +C IPT = ARRAY OF DIMENSION 6*NDP-15, WHERE THE POINT +C NUMBERS OF THE VERTEXES OF THE (IT)TH TRIANGLE +C ARE TO BE STORED AS THE (3*IT-2)ND, (3*IT-1)ST, +C AND (3*IT)TH ELEMENTS, IT=1,2,...,NT, +C NL = NUMBER OF BORDER LINE SEGMENTS, +C IPL = ARRAY OF DIMENSION 6*NDP, WHERE THE POINT +C NUMBERS OF THE END POINTS OF THE (IL)TH BORDER +C LINE SEGMENT AND ITS RESPECTIVE TRIANGLE NUMBER +C ARE TO BE STORED AS THE (3*IL-2)ND, (3*IL-1)ST, +C AND (3*IL)TH ELEMENTS, IL=1,2,..., NL. +C THE OTHER PARAMETERS ARE +C IWL = INTEGER ARRAY OF DIMENSION 18*NDP USED +C INTERNALLY AS A WORK AREA, +C IWP = INTEGER ARRAY OF DIMENSION NDP USED +C INTERNALLY AS A WORK AREA, +C WK = ARRAY OF DIMENSION NDP USED INTERNALLY AS A +C WORK AREA. +C DECLARATION STATEMENTS +C + SAVE +C + INTEGER CONXCH + COMMON /CONRA3/ IREC + DIMENSION XD(*) ,YD(*) ,IPT(*) ,IPL(*) , + 1 IWL(*) ,IWP(*) ,WK(*) + DIMENSION ITF(2) + CHARACTER*4 IP1C, IP2C + CHARACTER*64 ITEMP + DATA RATIO/1.0E-6/, NREP/100/ +C +C STATEMENT FUNCTIONS +C + DSQF(U1,V1,U2,V2) = (U2-U1)**2+(V2-V1)**2 + SIDE(U1,V1,U2,V2,U3,V3) = (V3-V1)*(U2-U1)-(U3-U1)*(V2-V1) +C +C PRELIMINARY PROCESSING +C + NDPM1 = NDP-1 +C +C DETERMINES THE CLOSEST PAIR OF DATA POINTS AND THEIR MIDPOINT. +C + DSQMN = DSQF(XD(1),YD(1),XD(2),YD(2)) + IPMN1 = 1 + IPMN2 = 2 + DO 140 IP1=1,NDPM1 + X1 = XD(IP1) + Y1 = YD(IP1) + IP1P1 = IP1+1 + DO 130 IP2=IP1P1,NDP + DSQI = DSQF(X1,Y1,XD(IP2),YD(IP2)) + IF (DSQI .NE. 0.) GO TO 120 +C +C ERROR, IDENTICAL INPUT DATA POINTS +C + ITEMP = ' CONTNG-IDENTICAL INPUT DATA POINTS FOUND + 1 AT AND ' +C +C + NOAO - FTN internal writes rewritten as calls to encode for IRAF +C +C WRITE(IP1C,'(I4)')IP1 +C WRITE(IP2C,'(I4)')IP2 + call encode (4, '(I4)', ip1c, ip1) + call encode (4, '(I4)', ip2c, ip2) +C - NOAO +C + CALL SETER (ITEMP,1,1) + ITEMP(46:49) = IP1C + ITEMP(55:58) = IP2C + RETURN + 120 IF (DSQI .GE. DSQMN) GO TO 130 + DSQMN = DSQI + IPMN1 = IP1 + IPMN2 = IP2 + 130 CONTINUE + 140 CONTINUE + DSQ12 = DSQMN + XDMP = (XD(IPMN1)+XD(IPMN2))/2.0 + YDMP = (YD(IPMN1)+YD(IPMN2))/2.0 +C +C SORTS THE OTHER (NDP-2) DATA POINTS IN ASCENDING ORDER OF +C DISTANCE FROM THE MIDPOINT AND STORES THE SORTED DATA POINT +C NUMBERS IN THE IWP ARRAY. +C + JP1 = 2 + DO 150 IP1=1,NDP + IF (IP1.EQ.IPMN1 .OR. IP1.EQ.IPMN2) GO TO 150 + JP1 = JP1+1 + IWP(JP1) = IP1 + WK(JP1) = DSQF(XDMP,YDMP,XD(IP1),YD(IP1)) + 150 CONTINUE + DO 170 JP1=3,NDPM1 + DSQMN = WK(JP1) + JPMN = JP1 + DO 160 JP2=JP1,NDP + IF (WK(JP2) .GE. DSQMN) GO TO 160 + DSQMN = WK(JP2) + JPMN = JP2 + 160 CONTINUE + ITS = IWP(JP1) + IWP(JP1) = IWP(JPMN) + IWP(JPMN) = ITS + WK(JPMN) = WK(JP1) + 170 CONTINUE +C +C IF NECESSARY, MODIFIES THE ORDERING IN SUCH A WAY THAT THE +C FIRST THREE DATA POINTS ARE NOT COLLINEAR. +C + AR = DSQ12*RATIO + X1 = XD(IPMN1) + Y1 = YD(IPMN1) + DX21 = XD(IPMN2)-X1 + DY21 = YD(IPMN2)-Y1 + DO 180 JP=3,NDP + IP = IWP(JP) + IF (ABS((YD(IP)-Y1)*DX21-(XD(IP)-X1)*DY21) .GT. AR) GO TO 190 + 180 CONTINUE + CALL SETER (' CONTNG - ALL COLLINEAR DATA POINTS',1,1) + 190 IF (JP .EQ. 3) GO TO 210 + JPMX = JP + JP = JPMX+1 + DO 200 JPC=4,JPMX + JP = JP-1 + IWP(JP) = IWP(JP-1) + 200 CONTINUE + IWP(3) = IP +C +C FORMS THE FIRST TRIANGLE. STORES POINT NUMBERS OF THE VER- +C TEXES OF THE TRIANGLE IN THE IPT ARRAY, AND STORES POINT NUM- +C BERS OF THE BORDER LINE SEGMENTS AND THE TRIANGLE NUMBER IN +C THE IPL ARRAY. +C + 210 IP1 = IPMN1 + IP2 = IPMN2 + IP3 = IWP(3) + IF (SIDE(XD(IP1),YD(IP1),XD(IP2),YD(IP2),XD(IP3),YD(IP3)) .GE. + 1 0.0) GO TO 220 + IP1 = IPMN2 + IP2 = IPMN1 + 220 NT0 = 1 + NTT3 = 3 + IPT(1) = IP1 + IPT(2) = IP2 + IPT(3) = IP3 + NL0 = 3 + NLT3 = 9 + IPL(1) = IP1 + IPL(2) = IP2 + IPL(3) = 1 + IPL(4) = IP2 + IPL(5) = IP3 + IPL(6) = 1 + IPL(7) = IP3 + IPL(8) = IP1 + IPL(9) = 1 +C +C ADDS THE REMAINING (NDP-3) DATA POINTS, ONE BY ONE. +C + DO 400 JP1=4,NDP + IP1 = IWP(JP1) + X1 = XD(IP1) + Y1 = YD(IP1) +C +C - DETERMINES THE VISIBLE BORDER LINE SEGMENTS. +C + IP2 = IPL(1) + JPMN = 1 + DXMN = XD(IP2)-X1 + DYMN = YD(IP2)-Y1 + DSQMN = DXMN**2+DYMN**2 + ARMN = DSQMN*RATIO + JPMX = 1 + DXMX = DXMN + DYMX = DYMN + DSQMX = DSQMN + ARMX = ARMN + DO 240 JP2=2,NL0 + IP2 = IPL(3*JP2-2) + DX = XD(IP2)-X1 + DY = YD(IP2)-Y1 + AR = DY*DXMN-DX*DYMN + IF (AR .GT. ARMN) GO TO 230 + DSQI = DX**2+DY**2 + IF (AR.GE.(-ARMN) .AND. DSQI.GE.DSQMN) GO TO 230 + JPMN = JP2 + DXMN = DX + DYMN = DY + DSQMN = DSQI + ARMN = DSQMN*RATIO + 230 AR = DY*DXMX-DX*DYMX + IF (AR .LT. (-ARMX)) GO TO 240 + DSQI = DX**2+DY**2 + IF (AR.LE.ARMX .AND. DSQI.GE.DSQMX) GO TO 240 + JPMX = JP2 + DXMX = DX + DYMX = DY + DSQMX = DSQI + ARMX = DSQMX*RATIO + 240 CONTINUE + IF (JPMX .LT. JPMN) JPMX = JPMX+NL0 + NSH = JPMN-1 + IF (NSH .LE. 0) GO TO 270 +C +C - SHIFTS (ROTATES) THE IPL ARRAY TO HAVE THE INVISIBLE BORDER +C - LINE SEGMENTS CONTAINED IN THE FIRST PART OF THE IPL ARRAY. +C + NSHT3 = NSH*3 + DO 250 JP2T3=3,NSHT3,3 + JP3T3 = JP2T3+NLT3 + IPL(JP3T3-2) = IPL(JP2T3-2) + IPL(JP3T3-1) = IPL(JP2T3-1) + IPL(JP3T3) = IPL(JP2T3) + 250 CONTINUE + DO 260 JP2T3=3,NLT3,3 + JP3T3 = JP2T3+NSHT3 + IPL(JP2T3-2) = IPL(JP3T3-2) + IPL(JP2T3-1) = IPL(JP3T3-1) + IPL(JP2T3) = IPL(JP3T3) + 260 CONTINUE + JPMX = JPMX-NSH +C +C - ADDS TRIANGLES TO THE IPT ARRAY, UPDATES BORDER LINE +C - SEGMENTS IN THE IPL ARRAY, AND SETS FLAGS FOR THE BORDER +C - LINE SEGMENTS TO BE REEXAMINED IN THE IWL ARRAY. +C + 270 JWL = 0 + DO 310 JP2=JPMX,NL0 + JP2T3 = JP2*3 + IPL1 = IPL(JP2T3-2) + IPL2 = IPL(JP2T3-1) + IT = IPL(JP2T3) +C +C - - ADDS A TRIANGLE TO THE IPT ARRAY. +C + NT0 = NT0+1 + NTT3 = NTT3+3 + IPT(NTT3-2) = IPL2 + IPT(NTT3-1) = IPL1 + IPT(NTT3) = IP1 +C +C - - UPDATES BORDER LINE SEGMENTS IN THE IPL ARRAY. +C + IF (JP2 .NE. JPMX) GO TO 280 + IPL(JP2T3-1) = IP1 + IPL(JP2T3) = NT0 + 280 IF (JP2 .NE. NL0) GO TO 290 + NLN = JPMX+1 + NLNT3 = NLN*3 + IPL(NLNT3-2) = IP1 + IPL(NLNT3-1) = IPL(1) + IPL(NLNT3) = NT0 +C +C - - DETERMINES THE VERTEX THAT DOES NOT LIE ON THE BORDER +C - - LINE SEGMENTS. +C + 290 ITT3 = IT*3 + IPTI = IPT(ITT3-2) + IF (IPTI.NE.IPL1 .AND. IPTI.NE.IPL2) GO TO 300 + IPTI = IPT(ITT3-1) + IF (IPTI.NE.IPL1 .AND. IPTI.NE.IPL2) GO TO 300 + IPTI = IPT(ITT3) +C +C - - CHECKS IF THE EXCHANGE IS NECESSARY. +C + 300 IF (CONXCH(XD,YD,IP1,IPTI,IPL1,IPL2) .EQ. 0) GO TO 310 +C +C - - MODIFIES THE IPT ARRAY WHEN NECESSARY. +C + IPT(ITT3-2) = IPTI + IPT(ITT3-1) = IPL1 + IPT(ITT3) = IP1 + IPT(NTT3-1) = IPTI + IF (JP2 .EQ. JPMX) IPL(JP2T3) = IT + IF (JP2.EQ.NL0 .AND. IPL(3).EQ.IT) IPL(3) = NT0 +C +C - - SETS FLAGS IN THE IWL ARRAY. +C + JWL = JWL+4 + IWL(JWL-3) = IPL1 + IWL(JWL-2) = IPTI + IWL(JWL-1) = IPTI + IWL(JWL) = IPL2 + 310 CONTINUE + NL0 = NLN + NLT3 = NLNT3 + NLF = JWL/2 + IF (NLF .EQ. 0) GO TO 400 +C +C - IMPROVES TRIANGULATION. +C + NTT3P3 = NTT3+3 + DO 390 IREP=1,NREP + DO 370 ILF=1,NLF + ILFT2 = ILF*2 + IPL1 = IWL(ILFT2-1) + IPL2 = IWL(ILFT2) +C +C - - LOCATES IN THE IPT ARRAY TWO TRIANGLES ON BOTH SIDES OF +C - - THE FLAGGED LINE SEGMENT. +C + NTF = 0 + DO 320 ITT3R=3,NTT3,3 + ITT3 = NTT3P3-ITT3R + IPT1 = IPT(ITT3-2) + IPT2 = IPT(ITT3-1) + IPT3 = IPT(ITT3) + IF (IPL1.NE.IPT1 .AND. IPL1.NE.IPT2 .AND. + 1 IPL1.NE.IPT3) GO TO 320 + IF (IPL2.NE.IPT1 .AND. IPL2.NE.IPT2 .AND. + 1 IPL2.NE.IPT3) GO TO 320 + NTF = NTF+1 + ITF(NTF) = ITT3/3 + IF (NTF .EQ. 2) GO TO 330 + 320 CONTINUE + IF (NTF .LT. 2) GO TO 370 +C +C - - DETERMINES THE VERTEXES OF THE TRIANGLES THAT DO NOT LIE +C - - ON THE LINE SEGMENT. +C + 330 IT1T3 = ITF(1)*3 + IPTI1 = IPT(IT1T3-2) + IF (IPTI1.NE.IPL1 .AND. IPTI1.NE.IPL2) GO TO 340 + IPTI1 = IPT(IT1T3-1) + IF (IPTI1.NE.IPL1 .AND. IPTI1.NE.IPL2) GO TO 340 + IPTI1 = IPT(IT1T3) + 340 IT2T3 = ITF(2)*3 + IPTI2 = IPT(IT2T3-2) + IF (IPTI2.NE.IPL1 .AND. IPTI2.NE.IPL2) GO TO 350 + IPTI2 = IPT(IT2T3-1) + IF (IPTI2.NE.IPL1 .AND. IPTI2.NE.IPL2) GO TO 350 + IPTI2 = IPT(IT2T3) +C +C - - CHECKS IF THE EXCHANGE IS NECESSARY. +C + 350 IF (CONXCH(XD,YD,IPTI1,IPTI2,IPL1,IPL2) .EQ. 0) + 1 GO TO 370 +C +C - - MODIFIES THE IPT ARRAY WHEN NECESSARY. +C + IPT(IT1T3-2) = IPTI1 + IPT(IT1T3-1) = IPTI2 + IPT(IT1T3) = IPL1 + IPT(IT2T3-2) = IPTI2 + IPT(IT2T3-1) = IPTI1 + IPT(IT2T3) = IPL2 +C +C - - SETS NEW FLAGS. +C + JWL = JWL+8 + IWL(JWL-7) = IPL1 + IWL(JWL-6) = IPTI1 + IWL(JWL-5) = IPTI1 + IWL(JWL-4) = IPL2 + IWL(JWL-3) = IPL2 + IWL(JWL-2) = IPTI2 + IWL(JWL-1) = IPTI2 + IWL(JWL) = IPL1 + DO 360 JLT3=3,NLT3,3 + IPLJ1 = IPL(JLT3-2) + IPLJ2 = IPL(JLT3-1) + IF ((IPLJ1.EQ.IPL1 .AND. IPLJ2.EQ.IPTI2) .OR. + 1 (IPLJ2.EQ.IPL1 .AND. IPLJ1.EQ.IPTI2)) + 2 IPL(JLT3) = ITF(1) + IF ((IPLJ1.EQ.IPL2 .AND. IPLJ2.EQ.IPTI1) .OR. + 1 (IPLJ2.EQ.IPL2 .AND. IPLJ1.EQ.IPTI1)) + 2 IPL(JLT3) = ITF(2) + 360 CONTINUE + 370 CONTINUE + NLFC = NLF + NLF = JWL/2 + IF (NLF .EQ. NLFC) GO TO 400 +C +C - - RESETS THE IWL ARRAY FOR THE NEXT ROUND. +C + JWL = 0 + JWL1MN = (NLFC+1)*2 + NLFT2 = NLF*2 + DO 380 JWL1=JWL1MN,NLFT2,2 + JWL = JWL+2 + IWL(JWL-1) = IWL(JWL1-1) + IWL(JWL) = IWL(JWL1) + 380 CONTINUE + NLF = JWL/2 + 390 CONTINUE + 400 CONTINUE +C +C REARRANGE THE IPT ARRAY SO THAT THE VERTEXES OF EACH TRIANGLE +C ARE LISTED COUNTER-CLOCKWISE. +C + DO 410 ITT3=3,NTT3,3 + IP1 = IPT(ITT3-2) + IP2 = IPT(ITT3-1) + IP3 = IPT(ITT3) + IF (SIDE(XD(IP1),YD(IP1),XD(IP2),YD(IP2),XD(IP3),YD(IP3)) .GE. + 1 0.0) GO TO 410 + IPT(ITT3-2) = IP2 + IPT(ITT3-1) = IP1 + 410 CONTINUE + NT = NT0 + NL = NL0 + RETURN + END diff --git a/sys/gio/ncarutil/conlib/conxch.f b/sys/gio/ncarutil/conlib/conxch.f new file mode 100644 index 00000000..6309f360 --- /dev/null +++ b/sys/gio/ncarutil/conlib/conxch.f @@ -0,0 +1,67 @@ + INTEGER FUNCTION CONXCH (X,Y,I1,I2,I3,I4) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C THIS FUNCTION DETERMINES WHETHER OR NOT THE EXCHANGE OF TWO +C TRIANGLES IS NECESSARY ON THE BASIS OF MAX-MIN-ANGLE CRITERION +C BY C. L. LAWSON. +C THE INPUT PARAMETERS ARE +C X,Y = ARRAYS CONTAINING THE COORDINATES OF THE DATA +C POINTS, +C I1,I2,I3,I4 = POINT NUMBERS OF FOUR POINTS P1, P2, +C P3, AND P4 THAT FORM A QUADRILATERAL +C WITH P3 AND P4 CONNECTED DIADONALLY. +C THIS FUNCTION RETURNS A VALUE 1 (ONE) WHEN AN EXCHANGE IS +C NEEDED, AND 0 (ZERO) OTHERWISE. +C DECLARATION STATEMENTS +C + DIMENSION X(1) ,Y(1) + DIMENSION X0(4) ,Y0(4) + EQUIVALENCE (C2SQ,C1SQ),(A3SQ,B2SQ),(B3SQ,A1SQ),(A4SQ,B1SQ), + 1 (B4SQ,A2SQ),(C4SQ,C3SQ) +C + SAVE +C +C STATEMENT FUNCTIONS +C +C CALCULATION +C + X0(1) = X(I1) + Y0(1) = Y(I1) + X0(2) = X(I2) + Y0(2) = Y(I2) + X0(3) = X(I3) + Y0(3) = Y(I3) + X0(4) = X(I4) + Y0(4) = Y(I4) + IDX = 0 + U3 = (Y0(2)-Y0(3))*(X0(1)-X0(3))-(X0(2)-X0(3))*(Y0(1)-Y0(3)) + U4 = (Y0(1)-Y0(4))*(X0(2)-X0(4))-(X0(1)-X0(4))*(Y0(2)-Y0(4)) + IF (U3*U4 .LE. 0.0) GO TO 100 + U1 = (Y0(3)-Y0(1))*(X0(4)-X0(1))-(X0(3)-X0(1))*(Y0(4)-Y0(1)) + U2 = (Y0(4)-Y0(2))*(X0(3)-X0(2))-(X0(4)-X0(2))*(Y0(3)-Y0(2)) + A1SQ = (X0(1)-X0(3))**2+(Y0(1)-Y0(3))**2 + B1SQ = (X0(4)-X0(1))**2+(Y0(4)-Y0(1))**2 + C1SQ = (X0(3)-X0(4))**2+(Y0(3)-Y0(4))**2 + A2SQ = (X0(2)-X0(4))**2+(Y0(2)-Y0(4))**2 + B2SQ = (X0(3)-X0(2))**2+(Y0(3)-Y0(2))**2 + C3SQ = (X0(2)-X0(1))**2+(Y0(2)-Y0(1))**2 + S1SQ = U1*U1/(C1SQ*AMAX1(A1SQ,B1SQ)) + S2SQ = U2*U2/(C2SQ*AMAX1(A2SQ,B2SQ)) + S3SQ = U3*U3/(C3SQ*AMAX1(A3SQ,B3SQ)) + S4SQ = U4*U4/(C4SQ*AMAX1(A4SQ,B4SQ)) + IF (AMIN1(S1SQ,S2SQ) .LT. AMIN1(S3SQ,S4SQ)) IDX = 1 + 100 CONXCH = IDX + RETURN +C + END diff --git a/sys/gio/ncarutil/conlib/mkpkg b/sys/gio/ncarutil/conlib/mkpkg new file mode 100644 index 00000000..5ebdc2cb --- /dev/null +++ b/sys/gio/ncarutil/conlib/mkpkg @@ -0,0 +1,37 @@ +# Update the CONCOM and CONTERP contributions to LIBNCAR. + +$checkout libncar.a lib$ +$update libncar.a +$checkin libncar.a lib$ +$exit + +libncar.a: + concal.f + concld.f + concls.f + concom.f + condet.f + condrw.f + condsd.f + conecd.f + congen.f + conint.f + conlcm.f + conlin.f + conloc.f + conlod.f + conop1.f + conop2.f + conop3.f + conop4.f + conot2.f + conout.f + conpdv.f + conreo.f + consld.f + conssd.f + constp.f + contlk.f + contng.f + conxch.f + ; diff --git a/sys/gio/ncarutil/conran.f b/sys/gio/ncarutil/conran.f new file mode 100644 index 00000000..bc23a6cc --- /dev/null +++ b/sys/gio/ncarutil/conran.f @@ -0,0 +1,1976 @@ + SUBROUTINE CONRAN (XD,YD,ZD,NDP,WK,IWK,SCRARR) +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C SUBROUTINE CONRAN(XD,YD,ZD,NDP,WK,IWK,SCRARR) +C STANDARD AND SMOOTH VERSIONS OF CONRAN +C +C DIMENSION OF XD(NDP),YD(NDP),ZD(NDP),WK(13*NDP) +C ARGUMENTS IWK((27+NCP)*NDP),SCRARR(RESOLUTION**2) +C WHERE NCP = 4 AND RESOLUTION = 40 BY +C DEFAULT. +C +C LATEST REVISION JULY 1984 +C +C OVERVIEW CONRAN PERFORMS CONTOURING OF IRREGULARLY +C DISTRIBUTED DATA. IT IS THE STANDARD AND +C SMOOTH MEMBERS OF THE CONRAN FAMILY. THIS +C VERSION WILL PLOT CONTOURS; SMOOTH THEM USING +C SPLINES UNDER TENSION (IF THE PACKAGE DASHSMTH +C IS LOADED); PLOT A PERIMETER OR GRID; TITLE THE +C PLOT; PRINT A MESSAGE GIVING THE CONTOUR INTERVALS +C BELOW THE MAP; PLOT THE INPUT DATA ON THE MAP; +C AND LABEL THE CONTOUR LINES. +C +C PURPOSE CONRAN PLOTS CONTOUR LINES USING RANDOM, +C SPARSE OR IRREGULAR DATA SETS. THE DATA IS +C TRIANGULATED AND THEN CONTOURED. CONTOURING +C IS PERFORMED USING INTERPOLATION OF THE TRI- +C ANGULATED DATA. THERE ARE TWO METHODS OF +C INTERPOLATION: C1 SURFACES AND LINEAR. +C +C USAGE CALL CONRAN(XD,YD,ZD,NDP,WK,IWK,SCRARR) +C AN OPTION SETTING ROUTINE CAN ALSO BE IN- +C VOKED, SEE WRITEUP BELOW. FRAME MUST BE +C CALLED BY THE USER. +C +C IF DIFFERENT COLORS (OR INTENSITIES) ARE TO BE +C USED FOR NORMAL INTENSITY, LOW INTENSITY OR +C TEXT OUTPUT, THEN THE VALUES IN COMMON BLOCK +C RANINT SHOULD BE CHANGED: +C +C IRANMJ COLOR INDEX FOR NORMAL (MAJOR) INTENSITY +C LINES. +C IRANMN COLOR INDEX FOR LOW INTENSITY LINES +C IRANTX COLOR INDEX FOR TEXT (LABELS) +C +C +C ARGUMENTS +C +C ON INPUT XD +C ARRAY OF DIMENSION NDP CONTAINING THE X- +C COORDINATES OF THE DATA POINTS. +C +C YD +C ARRAY OF DIMENSION NDP CONTAINING THE Y- +C COORDINATES OF THE DATA POINTS. +C +C ZD +C ARRAY OF DIMENSION NDP CONTAINING THE +C DATA VALUES AT THE POINTS. +C +C NDP +C NUMBER OF DATA POINTS (MUST BE 4 OR +C GREATER) TO BE CONTOURED. +C +C WK +C REAL WORK ARRAY OF DIMENSION AT LEAST +C 13*NDP +C +C IWK +C INTEGER WORK ARRAY. WHEN USING C1 SURFACES +C THE ARRAY MUST BE AT LEAST IWK((27+NCP)*NDP). +C WHEN USING LINEAR INTERPOLATION THE ARRAY +C MUST BE AT LEAST IWK((27+4)*NDP). +C +C SCRARR +C REAL WORK ARRAY OF DIMENSION AT LEAST +C (RESOLUTION**2) WHERE RESOLUTION IS +C DESCRIBED IN THE SSZ OPTION BELOW. RESO- +C LUTION IS 40 BY DEFAULT. +C +C ON OUTPUT ALL ARGUMENTS REMAIN UNCHANGED EXCEPT THE +C SCRATCH ARRAYS IWK, WK, AND SCRARR WHICH HAVE +C BEEN WRITTEN INTO. IF MAKING MULTIPLE RUNS +C ON THE SAME TRIANGULATION IWK AND WK MUST BE +C SAVED AND RETURNED TO THE NEXT INVOCATION OF +C CONRAN. +C +C ENTRY POINTS CONRAN, CONDET, CONINT, CONCAL, CONLOC, CONTNG, +C CONDRW, CONCLS, CONSTP, CONBDN, CONTLK +C CONPDV, CONOP1, CONOP2, CONOP3, CONOP4, +C CONXCH, CONREO, CONCOM, CONCLD, CONPMM, +C CONGEN, CONLOD, CONECD, CONOUT, CONOT2, +C CONSLD, CONLCM, CONLIN, CONDSD, CONSSD +C +C COMMON BLOCKS CONRA1, CONRA2, CONRA3, CONRA4, CONRA5, CONRA6, +C CONRA7, CONRA8, CONRA9, CONR10, CONR11, CONR12, +C CONR13, CONR14, CONR15, CONR16, CONR17, RANINT +C INTPR FROM THE DASH PACKAGE +C +C I/O PLOTS THE CONTOUR MAP AND, VIA THE ERPRT77 +C PACKAGE, OUTPUTS MESSAGES TO THE MESSAGE +C OUTPUT UNIT; AT NCAR THIS UNIT IS THE +C PRINTER. THE OPTION VALUES ARE ALL LISTED ON +C STANDARD ERPRT77 OUTPUT UNIT; AT NCAR THIS +C UNIT IS THE PRINTER. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY STANDARD VERSION: DASHCHAR, WHICH AT NCAR IS +C ROUTINES LOADED BY DEFAULT. +C SMOOTH VERSION: DASHSMTH WHICH MUST BE +C REQUESTED AT NCAR. +C BOTH VERSIONS REQUIRE CONCOM, CONTERP, GRIDAL +C THE ERPRT77 PACKAGE, AND THE SPPS. +C +C LANGUAGE FORTRAN77 +C +C HISTORY +C +C ALGORITHM THE SPARSE DATA IS TRIANGULATED AND A VIRTUAL +C GRID IS LAID OVER THE TRIANGULATED AREA. +C EACH VIRTUAL GRID POINT RECEIVES AN INTERPO- +C LATED VALUE. THE GRID IS SCANNED ONCE FOR +C EACH CONTOUR LEVEL AND ALL CONTOURS AT THAT +C LEVEL ARE PLOTTED. +C THERE ARE TWO METHODS OF INTERPOLATION. THE +C FIRST IS A SMOOTH DATA INTERPOLATION +C SCHEME BASED ON LAWSON'S C1 +C SURFACE INTERPOLATION ALGORITHM, WHICH HAS +C BEEN REFINED BY HIROSHA AKIMA. PARTS OF +C AKIMA'S ALGORITHM ARE USED IN THIS PACKAGE. +C SEE THE "REFERENCE" SECTION BELOW. +C THE SECOND IS A LINEAR INTERPOLATION SCHEME. +C WHEN DATA IS SPARSE IT IS USUALLY BETTER TO +C USE THE C1 INTERPOLATION. IF YOU HAVE DENSE +C DATA (OVER 100 POINTS) THEN THE LINEAR +C INTERPOLATION WILL GIVE THE BETTER RESULTS. +C +C PORTABILITY ANSI FORTRAN +C +C +C OPERATION CALL CONRAN (XD,YD,ZD,NDP,WK,IWK,SCRARR) +C +C FRAME MUST BE CALLED BY THE USER. +C +C CONRAN HAS MANY OPTIONS, EACH OF WHICH MAY +C BE CHANGED BY CALLING ONE OF THE FOUR +C SUBROUTINES CONOP1, CONOP2, CONOP3, OR +C CONOP4. THE NUMBER OF ARGUMENTS TO EACH +C CONOP ROUTINE IS THE SAME AS THE FINAL +C SUFFIX CHARACTER IN THE ROUTINE'S NAME. +C +C THE CONOP ROUTINES ARE CALLED BEFORE CONRAN +C IS CALLED, AND VALUES SET BY THESE CALLS +C CONTINUE TO BE IN EFFECT UNTIL THEY ARE +C CHANGED BY ANOTHER CALL TO A CONOP ROUTINE. +C +C ALL THE CONOP ROUTINES HAVE AS THEIR FIRST +C ARGUMENT A CHARACTER STRING TO IDENTIFY THE +C OPTION BEING CHANGED. THIS IS THE ONLY +C ARGUMENT TO CONOP1. CONOP2 HAS AN INTEGER +C SECOND ARGUMENT. CONOP3 HAS A REAL ARRAY (OR +C CONSTANT) AS ITS SECOND ARGUMENT AND AN +C INTEGER (USUALLY THE DIMENSION OF THE +C ARRAY) AS ITS THIRD ARGUMENT. CONOP4 HAS A +C CHARACTER STRING AS ITS SECOND ARGUMENT AND +C INTEGERS FOR THE THIRD AND FOURTH ARGUMENTS. +C +C ONLY THE FIRST TWO CHARACTERS ON EACH SIDE OF +C THE EQUAL SIGN ARE SCANNED. THEREFORE ONLY 2 +C CHARACTERS FOR EACH OPTION ARE REQUIRED ON +C INPUT TO CONOP (I.E. 'SCA=PRI' AND 'SC=PR' +C ARE EQUIVALENT.) +C +C REMEMBER, THERE MUST BE AT LEAST 4 DATA POINTS. +C THIS IS EQUAL TO THE DEFAULT NUMBER OF +C DATA POINTS TO BE USED FOR ESTIMATION OF PAR- +C TIAL DERIVATIVES AT EACH DATA POINT. +C THE ESTIMATED PARTIAL DERIVATIVES ARE +C USED FOR THE CONSTRUCTION OF THE INTERPOLAT- +C ING POLYNOMIAL'S COEFFICIENTS. +C +C LISTED BELOW ARE OPTIONS WHICH CAN ENHANCE +C YOUR PLOT. AN EXAMPLE OF AN APPROPRIATE +C CONOP CALL IS GIVEN FOR EACH OPTION. A +C COMPLETE LIST OF DEFAULT SETTINGS FOLLOWS +C THE LAST OPTION. +C +C OPTIONS +C +C CHL THIS FLAG DETERMINES HOW THE HIGH AND LOW +C CONTOUR VALUES ARE SET. THESE CONTOUR VALUES +C MAY BE SET BY THE PROGRAM OR BY THE USER. IF +C CHL=OFF, THE PROGRAM EXAMINES THE USER'S IN- +C PUT DATA AND DETERMINES BOTH THE HIGH AND LOW +C VALUES. IF CHL=ON, THE USER MUST SPECIFY THE +C DESIRED HIGH (HI) AND LOW (FLO) VALUES. +C THE DEFAULT IS CHL=OFF. +C +C IF PROGRAM SET: CALL CONOP3('CHL=OFF',0.,0) +C +C IF USER SET: CALL CONOP3('CHL=ON',ARRAY,2) +C WHERE ARRAY(1)=HI, ARRAY(2)=FLO +C +C NOTE: THE VALUES SUPPLIED FOR CONTOUR INCRE- +C MENT AND CONTOUR HIGH AND LOW VALUES ASSUMES +C THE UNSCALED DATA VALUES. SEE THE SDC FLAG, +C BELOW. +C +C EXAMPLE: CALL CONOP3('CHL=ON',ARRAY,2) +C WHERE ARRAY(1)=5020. (THE DESIRED +C HIGH CONTOUR VALUE) AND ARRAY(2)= +C 2000 (THE DESIRED LOW CONTOUR VALUE). +C THESE ARE FLOATING POINT NUMBERS. +C +C CIL THIS FLAG DETERMINES HOW THE CONTOUR INCRE- +C MENT (CINC) IS SET. THE INCREMENT IS EITHER +C CALCULATED BY THE PROGRAM (CIL=OFF) USING THE +C RANGE OF HIGH AND LOW VALUES FROM THE USER'S +C INPUT DATA, OR SET BY THE USER (CIL=ON). THE +C DEFAULT IS CIL=OFF. +C +C IF PROGRAM SET: CALL CONOP3('CIL=OFF',0.,0) +C +C IF USER SET: CALL CONOP3('CIL=ON',CINC,1) +C +C NOTE: BY DEFAULT, THE PROGRAM WILL EXAMINE +C THE USER'S INPUT DATA AND DETERMINE THE CONTOUR +C INTERVAL (CINC) AT SOME APPROPRIATE RANGE BETWEEN +C THE LEVEL OF HIGH AND LOW VALUES SUPPLIED, USUALLY +C GENERATING BETWEEN 15 AND 20 CONTOUR LEVELS. +C ELS. +C +C EXAMPLE: CALL CONOP3('CIL=ON',15.,1) +C WHERE 15. REPRESENTS THE +C CONTOUR INCREMENT DESIRED +C BY THE USER. +C +C CON THIS FLAG DETERMINES HOW THE CONTOUR LEVELS +C ARE SET. IF CON=ON, THE USER MUST SPECIFY +C THE ARRAY OF CONTOUR VALUES AND THE NUMBER OF +C CONTOUR LEVELS. A MAXIMUM OF 30 CONTOUR (NCL) +C LEVELS ARE PERMITTED. IF CON=OFF, DEFAULT +C VALUES ARE USED. IN THIS CASE, THE PROGRAM +C WILL CALCULATE THE VALUES FOR THE ARRAY AND +C NCL USING INPUT DATA. THE DEFAULT IS OFF. +C +C IF PROGRAM SET: CALL CONOP3('CON=OFF',0.,0) +C +C IF USER SET: CALL CONOP3('CON=ON',ARRAY,NCL) +C +C NOTE: THE ARRAY (ARRAY) CONTAINS THE CONTOUR +C LEVELS (FLOATING POINT ONLY) AND NCL IS THE +C NUMBER OF LEVELS. THE MAXIMUM NUMBER OF CON- +C TOUR LEVELS ALLOWED IS 30. WHEN ASSIGNING +C THE ARRAY OF CONTOUR VALUES, THE VALUES MUST +C BE ORDERED FROM SMALLEST TO LARGEST. +C +C EXAMPLE: +C DATA RLIST(1),...,RLIST(5)/1.,2.,3.,10.,12./ +C +C CALL CONOP3('CON=ON',RLIST,5) WHERE +C 'RLIST' CONTAINS THE USER SPECIFIED +C CONTOUR LEVELS, AND 5 IS THE +C NUMBER OF USER SPECIFIED CONTOUR +C LEVELS (NCL). +C +C WARNING ON CONTOUR OPTIONS: +C IT IS ILLEGAL TO USE THE CON OPTION WHEN +C EITHER CIL OR CHL ARE ACTIVATED. IF +C THIS IS DONE, THE OPTION CALL THAT DETECTED +C THE ERROR WILL NOT BE EXECUTED. +C +C DAS THIS FLAG DETERMINES WHICH CONTOURS ARE +C REPRESENTED BY DASHED LINES. THE USER SETS +C THE DASHED LINE PATTERN. THE USER MAY SPECI- +C FY THAT DASHED LINES BE USED FOR CONTOURS +C WHOSE VALUE IS LESS THAN, EQUAL TO, OR +C GREATER THAN THE DASH PATTERN BREAKPOINT (SEE +C THE DBP OPTION BELOW), WHICH IS ZERO BY +C DEFAULT. IF DAS=OFF (THE DEFAULT VALUE), ALL +C SOLID LINES ARE USED. +C +C ALL SOLID LINES: CALL CONOP4('DAS=OFF',' ',0,0) +C +C IF GREATER: CALL CONOP4('DAS=GTR',PAT,0,0) +C +C IF EQUAL: CALL CONOP4('DAS=EQU',PAT,0,0) +C +C IF LESS: CALL CONOP4('DAS=LSS',PAT,0,0) +C +C IF ALL SAME: CALL CONOP4('DAS=ALL',PAT,0,0) +C +C NOTE: PAT MUST BE A TEN CHARACTER +C STRING WITH A DOLLAR SIGN ($) FOR SOLID AND A +C SINGLE QUOTE (') FOR BLANK. RECALL THAT IN +C FORTRAN 77, IN A QUOTED STRING A SINGLE QUOTE +C IS REPRESENTED BY TWO SINGLE QUOTES (''). +C +C EXAMPLE: +C CALL CONOP4('DAS=GTR','$$$$$''$$$$',0,0) +C +C DBP THIS FLAG DETERMINES HOW THE DASH PATTERN +C BREAK POINT (BP) IS SET. IF DBP=ON, BP MUST +C BE SET BY THE USER BY SPECIFYING BP. IF +C DBP=OFF THE PROGRAM WILL SET BP TO THE +C DEFAULT VALUE WHICH IS ZERO. +C +C IF PROGRAM SET: CALL CONOP3('DBP=OFF',0.,0) +C +C IF USER SET: CALL CONOP3('DBP=ON',BP,1) +C +C NOTE: BP IS A FLOATING POINT NUMBER WHERE THE +C BREAK FOR GTR AND LSS CONTOUR DASH PATTERNS +C ARE DEFINED. BP IS ASSUMED TO BE GIVEN RELA- +C TIVE TO THE UNTRANSFORMED CONTOURS. +C +C EXAMPLE: CALL CONOP3('DBP=ON',5.,1) +C WHERE 5. IS THE USER SPECI- +C FIED BREAK POINT. +C +C DEF RESET FLAGS TO DEFAULT VALUES. ACTIVATING +C THIS OPTION SETS ALL FLAGS TO THE DEFAULT +C VALUE. DEF HAS NO 'ON' OF 'OFF' STATES. +C +C TO ACTIVATE: CALL CONOP1('DEF') +C +C EXT FLAG TO SET EXTRAPOLATION. NORMALLY ALL +C CONRAN VERSIONS WILL ONLY PLOT THE BOUNDARIES +C OF THE CONVEX HULL DEFINED BY THE USER'S DATA. +C TO HAVE THE CONTOURS FILL THE RECTANGULAR +C AREA OF THE FRAME, SET THE EXT SWITCH ON. +C THE DEFAULT IS OFF. +C +C TO TURN ON: CALL CONOP1('EXT=ON') +C +C TO TURN OFF: CALL CONOP1('EXT=OFF') +C +C FMT FLAG FOR THE FORMAT OF THE PLOTTED INPUT DATA +C VALUES. IF FMT=OFF, THE DEFAULT VALUES FOR +C FT, L, AND IF ARE USED. THE DEFAULT VALUES +C ARE: +C +C FT = '(G10.3)' +C L = 7 CHARACTERS INCLUDING THE PARENTHESES +C IF = 10 CHARACTERS PRINTED IN THE OUTPUT +C FIELD BY THE FORMAT +C +C IF FMT=ON, THE USER MUST SPECIFY VALUES FOR +C FT, L, AND IF. ALL USER SPECIFIED VALUES +C MUST BE GIVEN IN THE CORRECT FORMAT. +C +C IF PROGRAM SET: CALL CONOP4('FMT=OFF',' ',0,0) +C +C IF USER SET: CALL CONOP4('FMT=ON',FT,L,IF) +C +C NOTE: FT IS A CHARACTER STRING CONTAINING THE +C FORMAT. THE FORMAT MUST BE ENCLOSED IN +C PARENTHESES. ANY FORMAT, UP TO 10 CHARACTERS +C WHICH IS ALLOWED AT YOUR INSTALLATION WILL BE +C ACCEPTED. L IS THE NUMBER OF CHARACTERS IN +C FT. IF IS THE LENGTH OF THE FIELD CREATED BY +C THE FORMAT. +C +C EXAMPLE: CALL CONOP4('FMT=ON','(G30.2)',7,30) +C +C WARNING: CONRAN WILL NOT TEST FOR A VALID +C FORMAT. THE FORMAT IS ONLY ALLOWED TO BE +C 10 CHARACTERS LONG. +C +C GRI FLAG TO DISPLAY THE GRID. GRI IS OFF BY DEFAULT. +C +C TO TURN ON: CALL CONOP1('GRI=ON') +C +C TO TURN OFF: CALL CONOP1('GRI=OFF') +C +C NOTE: IF GRI IS ON, THE VIRTUAL GRID WILL +C BE SUPERIMPOSED OVER THE CONTOUR PLOT. +C THE X AND Y TICK INTERVALS WILL BE DISPLAYED +C UNDER THE MAP ONLY IF PER=ON. (SEE PER) +C +C INT FLAG TO DETERMINE THE INTENSITIES OF THE CON- +C TOUR LINES AND OTHER PARTS OF THE PLOT. IF +C INT=OFF, ALL INTENSITIES ARE SET TO THE DEFAULT +C VALUES. IF INT=ALL, ALL INTENSITIES ARE SET +C TO THE GIVEN VALUE, IVAL. IF INT IS SET TO +C ONE OF THE OTHER POSSIBLE OPTIONS (MAJ, MIN, +C LAB OR DAT), THE INTENSITY LEVEL FOR THAT +C OPTION IS SET TO THE GIVEN VALUE, IVAL. +C +C IF PROGRAM SET: CALL CONOP2('INT=OFF',0) +C +C ALL THE SAME: CALL CONOP2('INT=ALL',IVAL) +C +C MAJOR LINES: CALL CONOP2('INT=MAJ',IVAL) +C +C MINOR LINES: CALL CONOP2('INT=MIN',IVAL) +C +C TITLE AND MESSAGE: +C CALL CONOP2('INT=LAB',IVAL) +C +C DATA VALUES: CALL CONOP2('INT=DAT',IVAL) +C +C NOTE: 'INT=DAT' RELATES TO THE PLOTTED DATA +C VALUES AND THE PLOTTED MAXIMUMS AND MINIMUMS. +C +C NOTE: IVAL IS THE INTENSITY DESIRED. FOR AN +C EXPLANATION OF THE OPTION VALUE SETTINGS SEE +C THE OPTN ROUTINE IN THE NCAR SYSTEM PLOT +C PACKAGE DOCUMENTATION. BRIEFLY, IVAL VALUES +C RANGE FROM 0 TO 255 OR THE CHARACTER STRINGS +C 'LO' AND 'HI'. THE DEFAULT IS 'HI' EXCEPT +C FOR INT=MIN WHICH IS SET TO 'LO'. +C +C EXAMPLE: CALL CONOP2('INT=ALL',110) +C +C ITP SET THE INTERPOLATION SCHEME. +C THERE ARE TWO SCHEMES--C1 SURFACES AND LINEAR. +C THE C1 METHOD TAKES LONGER BUT WILL GIVE THE +C BEST RESULTS WHEN THE DATA IS SPARSE (LESS +C THAN 100 POINTS). THE LINEAR METHOD WILL +C PRODUCE A BETTER PLOT WHEN THERE IS A DENSE +C DATA SET. THE DEFAULT IS C1 SURFACE. +C +C FOR C1 SURFACE CALL CONOP1('ITP=C1') +C +C FOR LINEAR CALL CONOP1('ITP=LIN') +C +C LAB THIS FLAG CAN BE SET TO EITHER LABEL THE CON- +C TOURS (LAB=ON) OR NOT (LAB=OFF). THE DEFAULT +C VALUE IS LAB=ON. +C +C TO TURN ON: CALL CONOP1('LAB=ON') +C +C TO TURN OFF: CALL CONOP1('LAB=OFF') +C +C LOT FLAG TO LIST OPTIONS ON THE PRINTER. THE DE- +C FAULT VALUE IS SET TO OFF, AND NO OPTIONS +C WILL BE DISPLAYED. +C +C TO TURN ON: CALL CONOP1('LOT=ON') +C +C TO TURN OFF: CALL CONOP1('LOT=OFF') +C +C NOTE: IF USERS WANT TO PRINT THE OPTION +C VALUES, THEY SHOULD TURN THIS OPTION ON. THE +C OPTION VALUES WILL BE SENT TO THE STANDARD +C OUTPUT UNIT AS DEFINED BY THE SUPPORT +C ROUTINE I1MACH. +C +C LSZ THIS FLAG DETERMINES THE LABEL SIZE. IF +C LSZ=OFF, THE DEFAULT ISZLSZ VALUE WILL BE +C USED. IF LSZ=ON, THE USER SHOULD SPECIFY +C ISZLSZ. THE DEFAULT VALUE IS 9 PLOTTER +C ADDRESS UNITS. +C +C IF PROGRAM SET: CALL CONOP2('LSZ=OFF',0) +C +C IF USER SET: CALL CONOP2('LSZ=ON',ISZLSZ) +C +C NOTE: ISZLSZ IS THE REQUESTED CHARACTER +C SIZE IN PLOTTER ADDRESS UNITS. +C +C EXAMPLE: CALL CONOP2('LSZ=ON',4) +C WHERE 4 IS THE USER DESIRED +C INTEGER PLOTTER ADDRESS +C UNITS. +C +C MES FLAG TO PLOT A MESSAGE. THE DEFAULT IS ON. +C +C TO TURN ON: CALL CONOP1('MES=ON') +C +C TO TURN OFF: CALL CONOP1('MES=OFF') +C +C NOTE: IF MES=ON, A MESSAGE IS PRINTED BELOW +C THE PLOT GIVING CONTOUR INTERVALS AND EXECU- +C TION TIME IN SECONDS. IF PER OR GRI ARE ON, +C THE MESSAGE ALSO CONTAINS THE X AND Y TICK +C INTERVALS. +C +C NCP FLAG TO INDICATE THE NUMBER OF DATA POINTS +C USED FOR THE PARTIAL DERIVATIVE +C ESTIMATION. IF NCP=OFF, NUM IS SET TO +C 4, WHICH IS THE DEFAULT VALUE. IF NCP=ON, +C THE USER MUST SPECIFY NUM GREATER THAN OR +C EQUAL TO 2. +C +C IF PROGRAM SET: CALL CONOP2('NCP=OFF',0) +C +C IF USER SET: CALL CONOP2('NCP=ON',NUM) +C +C NOTE: NUM = NUMBER OF DATA POINTS USED FOR +C ESTIMATION. CHANGING THIS VALUE EFFECTS THE +C CONTOURS PRODUCED AND THE SIZE OF INPUT ARRAY +C IWK. +C +C EXAMPLE: CALL CONOP2('NCP=ON',3) +C +C PDV FLAG TO PLOT THE INPUT DATA VALUES. THE +C DEFAULT VALUE IS PDV=OFF. +C +C TO TURN ON: CALL CONOP1('PDV=ON') +C +C TO TURN OFF: CALL CONOP1('PDV=OFF') +C +C NOTE: IF PDV=ON, THE INPUT DATA VALUES ARE +C PLOTTED RELATIVE TO THEIR LOCATION ON THE +C CONTOUR MAP. IF YOU ONLY WISH TO SEE THE +C LOCATIONS AND NOT THE VALUES, SET PDV=ON AND +C CHANGE FMT TO PRODUCE AN ASTERISK (*) SUCH AS +C (I1). +C +C PER FLAG TO SET THE PERIMETER. THE DEFAULT VALUE +C IS PER=ON, WHICH CAUSES A PERIMETER TO BE +C DRAWN AROUND THE CONTOUR PLOT. +C +C TO TURN ON: CALL CONOP1('PER=ON') +C +C TO TURN OFF: CALL CONOP1('PER=OFF') +C +C NOTE: IF MES IS ON, THE X AND Y TICK INTERVALS +C WILL BE GIVEN. THESE ARE THE INTERVALS IN USER +C COORDINATES THAT EACH TICK MARK REPRESENTS. +C +C PMM FLAG TO PLOT RELATIVE MINIMUMS AND MAXIMUMS. +C THIS FLAG IS OFF BY DEFAULT. +C +C TO TURN OFF: CALL CONOP1('PMM=OFF') +C +C TO TURN ON: CALL CONOP1('PMM=ON') +C +C PSL FLAG WHICH SETS THE PLOT SHIELD OPTION. +C THE OUTLINE OF THE SHIELD WILL BE DRAWN ON +C THE SAME FRAME AS THE CONTOUR PLOT. +C BY DEFAULT THIS OPTION IS OFF. +C (SEE SLD OPTION). +C +C DRAW THE SHIELD: CALL CONOP1('PSL=ON') +C +C DON'T DRAW IT: CALL CONOP1('PSL=OFF') +C +C REP FLAG INDICATING THE USE OF THE SAME DATA IN +C A NEW EXECUTION. THE DEFAULT VALUE IS OFF. +C +C TO TURN ON: CALL CONOP1('REP=ON') +C +C TO TURN OFF: CALL CONOP1('REP=OFF') +C +C NOTE: IF REP=ON, THE SAME X-Y DATA AND TRIANGU- +C LATION ARE TO BE USED BUT IT IS ASSUMED +C THE USER HAS CHANGED CONTOUR VALUES OR RESOLUTION +C FOR THIS RUN. SCRATCH ARRAYS WK AND IWK MUST +C REMAIN UNCHANGED. +C +C SCA FLAG FOR SCALING OF THE PLOT ON A FRAME. +C THIS FLAG IS ON BY DEFAULT. +C +C USER SCALING: CALL CONOP1('SCA=OFF') +C +C PROGRAM SCALING: CALL CONOP1('SCA=ON') +C +C PRIOR WINDOW: CALL CONOP1('SCA=PRI') +C +C NOTE: WITH SCA=OFF, PLOTTING INSTRUCTIONS +C WILL BE ISSUED USING THE USER'S INPUT COORDI- +C NATES, UNLESS THEY ARE TRANSFORMED VIA FX AND +C FY TRANSFORMATIONS. USERS WILL FIND AN +C EXTENDED DISCUSSION IN THE "INTERFACING WITH +C OTHER GRAPHICS ROUTINES" SECTION BELOW. THE SCA +C OPTION ASSUMES THAT ALL INPUT DATA FALLS INTO +C THE CURRENT WINDOW SETTING. WITH SCA=ON, THE +C ENTRY POINT WILL ESTABLISH A VIEWPORT SO THAT +C THE USER'S PLOT WILL FIT INTO THE CENTER 90 +C PERCENT OF THE FRAME. WHEN SCA=PRI, THE +C PROGRAM MAPS THE USER'S PLOT INSTRUCTIONS INTO +C THE PORTION OF THE FRAME DEFINED BY THE +C CURRENT NORMALIZATION TRANSFORMATION. SCA=OFF +C SHOULD BE USED TO INTERFACE WITH EZMAP. +C +C SDC FLAG TO DETERMINE HOW TO SCALE THE DATA ON +C THE CONTOURS. IF SDC=OFF, THE FLOATING POINT +C VALUE IS GIVEN BY SCALE. IF SDC=ON, THE USER +C MAY SPECIFY SCALE. THE DEFAULT VALUE FOR SCALE +C IS 1. +C +C IF PROGRAM SET: CALL CONOP3('SDC=OFF',0.,0) +C +C IF USER SET: CALL CONOP3('SDC=ON',SCALE,1) +C +C NOTE: THE DATA PLOTTED ON CONTOUR LINES AND +C THE DATA PLOTTED FOR RELATIVE MINIMUMS AND +C MAXIMUMS WILL BE SCALED BY THE FLOATING POINT +C VALUE GIVEN BY SCALE. TYPICAL SCALE VALUES +C ARE 10., 100., 1000., ETC. THE ORIGINAL DATA +C VALUES ARE MULTIPLIED BY SCALE. SCALE MUST BE +C A FLOATING POINT NUMBER AND IS DISPLAYED IN THE +C MESSAGE (SEE MES). +C +C EXAMPLE: CALL CONOP2('SDC=ON',100.,1) +C +C SLD ACTIVATE OR DEACTIVATE THE SHIELDING OPTION. +C WHEN THIS OPTION IS ACTIVATED, ONLY THOSE +C CONTOURS WITHIN THE SHIELD ARE DRAWN. THE SHIELD +C IS A POLYGON SPECIFIED BY THE USER WHICH MUST +C BE GIVEN IN THE SAME COORDINATE RANGE AS THE +C THE DATA. IT MUST DEFINE ONLY ONE POLYGON. +C +C TO ACTIVATE THE SHIELD: +C CALL CONOP3('SLD=ON',ARRAY,ICSD) +C +C TO DEACTIVATE THE SHIELD: +C CALL CONOP3('SLD=OFF',0.,0) +C +C NOTE: ARRAY IS A REAL ARRAY ICSD ELEMENTS LONG. +C THE FIRST ICSD/2 ELEMENTS ARE X COORDINATES AND +C THE SECOND ICSD/2 ELEMENTS ARE Y COORDINATES. +C ICSD IS THE LENGTH OF ENTIRE ARRAY, THE +C NUMBER OF (X + Y) SHIELD COORDS. THE POLYGON +C MUST BE CLOSED, THAT IS THE FIRST AND LAST +C POINTS DESCRIBING IT MUST BE THE SAME. +C +C EXAMPLE: DIMENSION SHLD +C DATA SHLD/ 7.,10.,10.,7.,7., +C 1 7.,7.,10.,10.,7./ +C CALL CONOP3 (6HSLD=ON,SHLD,10) +C +C +C SML FLAG TO DETERMINE THE SIZE OF MINIMUM AND +C MAXIMUM CONTOUR LABELS. IF SML=OFF, THE +C ISZSML DEFAULT VALUE OF 15 IS USED. +C IF SML=ON, THE USER MUST SPECIFY ISZSML. +C +C IF PROGRAM SET: CALL CONOP2('SML=OFF',0) +C +C IF USER SET: CALL CONOP2('SML=ON',ISZSML) +C +C NOTE: ISZSML IS AN INTEGER NUMBER WHICH IS +C THE SIZE OF LABELS IN PLOTTER ADDRESS UNITS +C AS DEFINED IN THE SPPS ENTRY WTSTR. +C +C EXAMPLE: CALL CONOP2('SML=ON',12) +C +C SPD FLAG FOR THE SIZE OF THE PLOTTED INPUT DATA +C VALUES. IF SPD=OFF, THE VALUE OF ISZSPD IS +C 8, WHICH IS THE DEFAULT. IF SPD=ON, THE USER +C MUST SPECIFY ISZSPD. +C +C IF PROGRAM SET: CALL CONOP2('SPD=OFF',0) +C +C IF USER SET: CALL CONOP2('SPD=ON',ISZSPD) +C +C NOTE: ISZSPD IS AN INTEGER NUMBER GIVING THE +C SIZE TO PLOT THE DATA VALUES IN PLOTTER ADDRESS +C UNITS AS DEFINED IN THE SPPS ENTRY WTSTR. . +C +C EXAMPLE: CALL CONOP2('SPD=ON',6) +C +C SSZ FLAG TO DETERMINE THE RESOLUTION (NUMBER OF +C STEPS IN EACH DIRECTION). IF SSZ=ON, THE +C USER SETS ISTEP, OR, IF SSZ=OFF, THE PROGRAM +C WILL AUTOMATICALLY SET ISTEP AT THE DEFAULT +C VALUE OF 40. +C +C IF PROGRAM SET: CALL CONOP2('SSZ=OFF',0) +C +C IF USER SET: CALL CONOP2('SSZ=ON',ISTEP) +C +C NOTE: ISTEP IS AN INTEGER SPECIFYING THE DENSITY +C OF THE VIRTUAL GRID. IN MOST CASES, THE DEFAULT +C VALUE OF 40 PRODUCES PLEASING CONTOURS. FOR +C COARSER BUT QUICKER CONTOURS, LOWER THE +C VALUE. FOR SMOOTHER CONTOURS AT +C THE EXPENSE OF TAKING LONGER TIME, RAISE +C THE VALUE. NOTE: FOR STEP SIZES GREATER +C THAN 200 IN CONRAN, THE ARRAYS PV IN COMMON +C CONRA1 AND ITLOC IN COMMON CONRA9, MUST BE +C EXPANDED TO ABOUT 10 MORE THAN ISTEP. +C SEE CONRA1 AND CONRA9 COMMENTS BELOW FOR MORE +C INFORMATION. +C +C EXAMPLE: CALL CONOP2('SSZ=ON',25) +C THIS ISTEP VALUE WILL PRO- +C DUCE A COARSE CONTOUR. +C +C STL FLAG TO DETERMINE THE SIZE OF THE TITLE. +C ISZSTL MAY BE SET BY THE USER (STL=ON), OR +C THE PROGRAM WILL SET IT TO THE DEFAULT SIZE +C OF 16 PLOTTER ADDRESS UNITS (STL=OFF). +C +C IF PROGRAM SET: CALL CONOP2('STL=OFF',0) +C +C IF USER SET: CALL CONOP2('STL=ON',ISZSTL) +C +C NOTE: WHEN 30 OR 40 CHARACTERS ARE USED FOR +C THE TITLE, THE DEFAULT SIZE OF 16 PLOTTER +C ADDRESS UNITS WORKS WELL. FOR LONGER TITLES, +C A SMALLER TITLE SIZE IS REQUIRED. +C +C EXAMPLE: CALL CONOP2('STL=ON',13) +C +C TEN FLAG TO DETERMINE THE TENSION FACTOR APPLIED +C WHEN SMOOTHING CONTOUR LINES. THE USER MAY +C SET TENS OR ALLOW THE PROGRAM TO SET THE +C VALUE. IF USER SET, TENS MUST HAVE A VALUE +C GREATER THAN ZERO AND LESS THAN OR EQUAL TO +C 30. THE DEFAULT VALUE IS 2.5. +C +C IF PROGRAM SET: CALL CONOP3('TEN=OFF',0.,0) +C +C IF USER SET: CALL CONOP3('TEN=ON',TENS,1) +C +C NOTE: TENS IS NOT AVAILABLE IN THE STANDARD +C VERSION OF CONRAN. +C SMOOTHING OF CONTOUR LINES IS ACCOMPLISHED +C WITH SPLINES UNDER TENSION. TO ADJUST THE +C AMOUNT OF SMOOTHING APPLIED, ADJUST THE TEN- +C SION FACTOR. SETTING TENS VERY LARGE +C (I.E. 30.), EFFECTIVELY SHUTS OFF SMOOTHING. +C +C EXAMPLE: CALL CONOP3('TEN=ON',14.,1) +C +C TFR FLAG TO ADVANCE THE FRAME BEFORE TRIANGULATION. +C THE DEFAULT VALUE IS TFR=ON, WHICH MEANS THAT +C THE CONTOURS AND THE TRIANGLES WILL BE PLOTTED +C ON SEPARATE FRAMES. +C +C IF PROGRAM SET: CALL CONOP1('TFR=ON') +C +C TO TURN OFF: CALL CONOP1('TFR=OFF') +C +C NOTE: TRIANGLES ARE PLOTTED AFTER THE CON- +C TOURING IS COMPLETED. TO SEE THE TRIANGLES +C OVER THE CONTOURS, TURN THIS SWITCH OFF. +C +C TLE FLAG TO PLACE A TITLE AT THE TOP OF THE PLOT. +C IF TLE=ON, THE USER MUST SPECIFY CHARS AND +C INUM. CHARS IS THE CHARACTER STRING CONTAINING +C THE TITLE. INUM IS THE NUMBER OF CHARACTERS +C IN CHARS. THE DEFAULT VALUE IS OFF. +C +C TO TURN ON: CALL CONOP4('TLE=ON',CHARS,INUM,0) +C +C TO TURN OFF: CALL CONOP4('TLE=OFF',' ',0,0) +C +C NOTE: IF LONGER THAN 64-CHARACTER TITLES ARE +C DESIRED, THE CHARACTER VARIABLE ISTRNG FOUND +C IN CONRA7 MUST BE INCREASED APPROPRIATELY. +C +C EXAMPLE: CALL CONOP4('TLE=ON','VECTOR REVIEW' +C ,13,0) +C +C TOP FLAG TO PLOT ONLY THE TRIANGLES. +C +C TO TURN OFF: CALL CONOP1('TOP=OFF') +C +C TO TURN ON: CALL CONOP1('TOP=ON') +C +C NOTE: THE USER MAY WISH TO OVERLAY THE TRIAN- +C GLES ON SOME OTHER PLOT. 'TOP=ON' WILL +C ALLOW THAT. THIS OPTION WHEN ACTIVATED +C (TOP=ON), WILL SET TRI=ON, AND TFR=OFF. IF +C THE USER WANTS TFR=ON, IT SHOULD BE SET AFTER +C TOP IS SET. IF THE USER SETS TOP=OFF IT WILL +C SET TRI=OFF AND TFR=ON. IF THE USER WANTS TRI +C OR TFR DIFFERENT, SET THEM AFTER THE +C TOP CALL. +C +C TRI FLAG TO PLOT THE TRIANGULATION. THE DEFAULT IS +C OFF AND THEREFORE THE TRIANGLES ARE NOT DRAWN. +C +C TO TURN ON: CALL CONOP1('TRI=ON') +C +C TO TURN OFF: CALL CONOP1('TRI=OFF') +C +C NOTE: PLOTTING THE TRIANGLES WILL INDICATE TO +C THE USER WHERE GOOD AND BAD POINTS OF INTER- +C POLATION ARE OCCURRING IN THE CONTOUR MAP. +C EQUILATERAL TRIANGLES ARE OPTIMAL FOR INTER- +C POLATION. QUALITY DEGRADES AS TRIANGLES +C APPROACH A LONG AND NARROW SHAPE. THE CONVEX +C HULL OF THE TRIANGULATION IS ALSO A POOR +C POINT OF INTERPOLATION. +C +C OPTION DEFAULT BELOW ARE LISTED THE DEFAULT +C VALUES VALUES FOR THE VARIOUS OPTIONS GIVEN ABOVE. +C UNLESS THE USER SPECIFIES OTHERWISE, THESE +C VALUES WILL BE USED IN EXECUTION OF THE VARI- +C OUS OPTIONS. +C +C CHL=OFF LOT=OFF SLD=OFF +C CIL=OFF LSZ=OFF SML=OFF +C CON=OFF MES=ON SPD=OFF +C DAS=OFF NCP=OFF SPT=OFF +C DBP=OFF PDV=OFF SSZ=OFF +C EXT=OFF PER=ON STL=OFF +C FMT=OFF PMM=OFF TEN=OFF +C GRI=OFF REP=OFF TFR=ON +C ITP=C1 SCA=ON TOP=OFF +C LAB=ON SDC=OFF TRI=OFF +C +C DEFAULT VALUES FOR THE OPTION DEFAULT VALUES GIVEN ABOVE, IF +C USER SPECIFIED USED, WILL SET DEFAULT VALUES FOR THE FOLLOW- +C PARAMETERS ING PARAMETERS: +C +C PARAMETER DEFAULT +C --------- ------- +C +C ARRAY UP TO 30 CONTOUR LEVELS ALLOWED. +C VALUES ARE COMPUTED BY THE +C PROGRAM, BASED ON INPUT. +C +C BP 0. +C +C CINC COMPUTED BY THE PROGRAM BASED ON THE +C RANGE OF HI AND LO VALUES OF THE +C INPUT DATA. +C +C FLO COMPUTED BY THE PROGRAM BASED ON THE +C LOWEST UNSCALED INPUT DATA. +C +C FT (G10.3) PARENTHESES MUST BE +C INCLUDED. +C +C HI COMPUTED BY THE PROGRAM BASED ON THE +C HIGHEST UNSCALED INPUT DATA. +C +C CHARS NO TITLE +C +C IF 10 CHARACTERS +C +C INUM NO TITLE +C +C IPAT '$$$$$$$$$$' (THIS IS A 10 CHARACTER +C STRING.) +C +C ISZLSZ 9 PLOTTER ADDRESS UNITS +C +C ISZSML 15 PLOTTER ADDRESS UNITS +C +C ISZSPD 8 PLOTTER ADDRESS UNITS +C +C ISZSTL 16 PLOTTER ADDRESS UNITS +C +C ISTEP 40 +C +C IVAL 'HI' FOR ALL EXCEPT MINOR CON- +C TOUR LINES WHICH ARE 'LO'. +C +C L 7 CHARACTERS (INCLUDING BOTH +C PARENTHESES) +C +C NCL COMPUTED BY THE PROGRAM BASED ON +C INPUT DATA. UP TO 30 CONTOUR +C LEVELS ARE PERMITTED. +C +C NUM 4 DATA POINTS +C +C SCALE 1. (NO SCALING PERFORMED) +C +C TENS 2.5 +C +C ICSD 0 (NO SHIELD) +C +C OPTIONS WHICH THE SHAPE OF THE CONTOURS MAY BE MODIFIED BY +C EFFECT THE CHANGING NCP AND SSZ. NCP CONTROLS THE +C CONTOURS NUMBER OF DATA POINTS TO BE USED IN THE +C INTERPOLATION. INCREASING NCP CAUSES MORE +C OF THE SURROUNDING DATA TO INFLUENCE THE +C POINT OF INTERPOLATION. SOME DATASETS CAUSE +C DIFFICULTY WHEN TRYING TO PRODUCE MEANINGFUL +C CONTOURS (TRIANGLES WHICH ARE LONG AND NARROW). +C BY MODIFYING NCP A USER CAN FINE-TUNE A +C PLOT. INCREASING ISTEP, THE DENSITY OF THE +C VIRTUAL GRID, WILL SMOOTH OUT THE CONTOUR +C LINES AND PICK UP MORE DETAIL (NEW CONTOURS +C WILL APPEAR AS ISTEP INCREASES AND OLD ONES WILL +C SOMETIMES BREAK INTO MORE DISTINCT UNITS). +C ISTEP IS CHANGED BY THE SSD OPTION. +C +C NOTE IF NCP.GT.25, ARRAYS DSQ0 AND IPC0 IN CONDET +C MUST BE ADJUSTED ACCORDINGLY. ALSO NCPSZ IN +C CONBDN (25 BY DEFAULT), MUST BE INCREASED TO +C NCP. THE DEFAULT VALUE OF NCP, WHICH IS 4, +C PRODUCES PLEASING PICTURES IN MOST CASES. +C HOWEVER, FINE-TUNING OF THE INTERPOLATION CAN +C BE OBTAINED BY INCREASING THE SIZE OF NCP, +C WITH A CORRESPONDING LINEAR INCREASE IN WORK +C SPACE. +C +C THE INTERPOLATION METHOD USED WILL ALSO CAUSE +C DIFFERENT LOOKING CONTOURS. THE C1 METHOD +C IS RECOMMENDED WHEN THE DATA IS SPARSE. IT +C WILL SMOOTH THE DATA AND ADD TRENDS (FALSE +C HILLS AND VALLEYS). THE LINEAR METHOD IS +C RECOMMENDED WHEN DATA IS DENSE (GT 50 TO 100) +C IT WILL NOT SMOOTH THE DATA OR ADD TRENDS. +C +C INTERFACING WITH NORMALLY THE SCALING FACTOR WILL BE SET TO OFF. +C OTHER GRAPHICS IN MOST CASES MAPPING CAN BE PERFORMED BEFORE +C ROUTINES CALLING THE CONRAN ENTRY POINT, THUS SAVING THE +C USER FROM MODIFYING THE FILE. IF REASONABLE +C RESULTS CANNOT BE OBTAINED, THE STATEMENT +C FUNCTIONS, FX AND FY, WILL HAVE TO BE REPLACED. +C THE ROUTINES HAVING THESE STATEMENT FUNCTIONS +C ARE: +C +C CONDRW, CONPDV, CONTLK, CONPMS, CONGEN +C +C REFERENCES AKIMA, HIROSHA +C A METHOD OF BIVARIATE INTERPOLATION AND +C SMOOTH SURFACE FITTING FOR IRREGULARLY +C DISTRIBUTED DATA POINTS. +C ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE +C VOL 4, NO. 2, JUNE 1978, PAGES 148-159 +C LAWSON, C.L. +C SOFTWARE FOR C1 SURFACE INTERPOLATION +C JPL PUBLICATION 77-30 +C AUGUST 15, 1977 +C +C CONRAN ERROR ERROR ROUTINE MESSAGE +C MESSAGES +C 1 CONRAN INPUT PARAMETER NDP LT NCP +C 2 CONRAN NCP GT MAX SIZE OR LT 2 +C 3 CONTNG ALL COLINEAR DATA POINTS +C 4 CONTNG IDENTICAL INPUT DATA POINTS +C FOUND +C 5 CONOP UNDEFINED OPTION +C 6 CONCLS CONSTANT INPUT FIELD +C 7 CONOP INCORRECT CONOP CALL USED +C 8 CONOP ILLEGAL USE OF CON OPTION +C WITH CIL OR CHL OPTIONS +C 9 CONOP NUMBER OF CONTOUR LEVELS +C EXCEEDS 30 +C 10 CONDRW CONTOUR STORAGE EXHAUSTED +C THIS ERROR IS TRAPPED AND +C NULLIFIED BY CONRAN. IT +C SERVES TO SIGNAL THE USER +C THAT A CONTOUR LEVEL MAY NOT +C BE COMPLETE. +C 11 CONSTP ASPECT RATIO OF X AND Y +C GREATER THAN 5 TO 1. +C (THIS ERROR MAY CAUSE A POOR +C QUALITY PLOT. USUALLY THIS +C CAN BE FIXED BY MULTIPLYING +C X OR Y BY A CONSTANT FACTOR. +C IF THIS SOLUTION IS +C UNACCEPTABLE THEN INCREASING +C SSZ TO A VERY LARGE VALUE +C MAY HELP. NOTE: THIS CAN BE +C EXPENSIVE.) +C +C THE ERRORS LISTED ABOVE ARE DEFINED AS RECOVERABLE +C ERRORS SHOULD THE USER WISH TO USE THEM IN THAT +C FASHION. THE DOCUMENTATION ON THE ERPRT77 PACKAGE +C EXPLAINS HOW TO RECOVER FROM AN ERROR. +C +C NOTE: THE COMMON BLOCKS LISTED INCLUDE ALL THE COMMON USED BY +C THE ENTIRE CONRAN FAMILY. NOT ALL MEMBERS WILL USE ALL +C THE COMMON VARIABLES. +C +C CONRA1 +C CL-ARRAY OF CONTOUR LEVELS +C NCL-NUMBER OF CONTOUR LEVELS +C OLDZ-Z VALUE OF LEFT NEIGHBOR TO CURRENT LOCATION +C PV-ARRAY OF PREVIOUS ROW VALUES +C HI-LARGEST CONTOUR PLOTTED +C FLO-LOWEST CONTOUR PLOTTED +C FINC-INCREMENT LEVEL BETWEEN EQUALLY SPACED CONTOURS +C CONRA2 +C REPEAT-FLAG TO TRIANGULATE AND DRAW OR JUST DRAW +C EXTRAP-PLOT DATA OUTSIDE OF CONVEX DATA HULL +C PER-PUT PERIMETER AROUND PLOT +C MESS-FLAG TO INDICATE MESSAGE OUTPUT +C ISCALE-SCALING SWITCH +C LOOK-PLOT TRIANGLES FLAG +C PLDVLS-PLOT THE DATA VALUES FLAG +C GRD-PLOT GRID FLAG +C CON-USER SET OR PROGRAM SET CONTOURS FLAG +C CINC-USER OR PROGRAM SET INCREMENT FLAG +C CHILO-USER OR PROGRAM SET HI LOW CONTOURS +C LABON-FLAG TO CONTROL LABELING OF CONTOURS +C PMIMX-FLAG TO CONTROL THE PLOTTING OF MIN'S +C AND MAX'S +C SCALE-THE SCALE FACTOR FOR CONTOUR LINE VALUES +C AND MIN, MAX PLOTTED VALUES +C FRADV-ADVANCE FRAME BEFORE PLOTTING TRIANGULATION +C EXTRI-ONLY PLOT TRIANGULATION +C BPSIZ-BREAKPOINT SIZE FOR DASHPATTERNS +C LISTOP-LIST OPTIONS ON UNIT6 FLAG +C CONRA3 +C IRED-ERPRT77 RECOVERABLE ERROR FLAG +C CONRA4 +C NCP-NUMBER OF DATA POINTS USED AT EACH POINT FOR +C POLYNOMIAL CONSTRUCTION. +C NCPSZ-MAX SIZE ALLOWED FOR NCP +C CONRA5 +C NIT-FLAG TO INDICATE STATUS OF SEARCH DATA BASE +C ITIPV-LAST TRIANGLE INTERPOLATION OCCURRED IN +C CONRA6 +C XST-X COORDINATE START POINT FOR CONTOURING +C YST-Y COORDINATE START POINT FOR CONTOURING +C XED-X COORDINATE END POINT FOR CONTOURING +C YED-Y COORDINATE END POINT FOR CONTOURING +C STPSZ-STEP SIZE FOR X,Y CHANGE WHEN CONTOURING +C IGRAD-NUMBER OF GRADUATIONS FOR CONTOURING (STEP SIZE) +C IG-RESET VALUE FOR IGRAD +C XRG-X RANGE OF COORDINATES +C YRG-Y RANGE OF COORDINATES +C BORD-PERCENT OF FRAME USED FOR CONTOUR PLOT +C PXST-X PLOTTER START ADDRESS FOR CONTOURS +C PYST-Y PLOTTER START ADDRESS FOR CONTOURS +C PXED-X PLOTTER END ADDRESS FOR CONTOURS +C PYED-Y PLOTTER END ADDRESS FOR CONTOURS +C ITICK-NUMBER OF TICK MARKS FOR GRIDS AND PERIMETERS +C CONRA7 +C TITLE-SWITCH TO INDICATE IF TITLE OPTION ON OR OFF +C ISTRNG-CHARACTER STRING CONTAINING THE TITLE +C ICNT-CHARACTER COUNT OF ISTRNG +C ITLSIZ-SIZE OF TITLE IN PWRIT UNITS +C CONRA8 +C IHIGH-DEFAULT INTENSITY SETTING +C INMAJ-CONTOUR LEVEL INTENSITY FOR MAJOR LINES +C INMIN-CONTOUR LEVEL INTENSITY FOR MINOR LINES +C INLAB-TITLE AND MESSAGE INTENSITY +C INDAT-DATA VALUE INTENSITY +C FORM-THE FORMAT FOR PLOTTING THE DATA VALUES +C LEN-THE NUMBER OF CHARACTERS IN THE FORMAT +C IFMT-SIZE OF THE FORMAT FIELD +C LEND-DEFAULT FORMAT LENGTH +C IFMTD-DEFAULT FORMAT FIELD SIZE +C ISIZEP-SIZE OF THE PLOTTED DATA VALUES +C CONRA9 +C X-ARRAY OF X COORDINATES OF CONTOURS DRAWN AT CURRENT CONTOUR +C LEVEL +C Y-ARRAY OF Y COORDINATES OF CONTOURS DRAWN AT CURRENT CONTOUR +C LEVEL +C NP-COUNT IN X AND Y +C MXXY-SIZE OF X AND Y +C TR-TOP RIGHT CORNER VALUE OF CURRENT CELL +C BR-BOTTOM RIGHT CORNER VALUE OF CURRENT CELL +C TL-TOP LEFT CORNER VALUE OF CURRENT CELL +C BL-BOTTOM LEFT CORNER VALUE OF CURRENT CELL +C CONV-CURRENT CONTOUR VALUE +C XN-X POSITION WHERE CONTOUR IS BEING DRAWN +C YN-Y POSITION WHERE CONTOUR IS BEING DRAWN +C ITLL-TRIANGLE WHERE TOP LEFT CORNER OF CURRENT CELL LIES +C IBLL-TRIANGLE OF BOTTOM LEFT CORNER +C ITRL-TRIANGLE OF TOP RIGHT CORNER +C IBRL-TRIANGLE OF BOTTOM RIGHT CORNER +C XC-X COORDINATE OF CURRENT CELL +C YC-Y COORDINATE OF CURRENT CELL +C ITLOC-IN CONJUNCTION WITH PV STORES THE TRIANGLE WHERE PV +C VALUE CAME FROM +C CONR10 +C NT-NUMBER OF TRIANGLES GENERATED +C NL-NUMBER OF LINE SEGMENTS +C NTNL-NT+NL +C JWIPT-POINTER INTO IWK WHERE WHERE TRIANGLE POINT NUMBERS +C ARE STORED +C JWIWL-IN IWK THE LOCATION OF A SCRATCH SPACE +C JWIWP-IN IWK THE LOCATION OF A SCRATCH SPACE +C JWIPL-IN IWK THE LOCATION OF END POINTS FOR BORDER LINE +C SEGMENTS +C IPR-IN WK THE LOCATION OF THE PARTIAL DERIVATIVES AT EACH +C DATA POINT +C ITPV-THE TRIANGLE WHERE THE PREVIOUS VALUE CAME FROM +C CONR11 +C NREP-NUMBER OF REPETITIONS OF DASH PATTERN BEFORE A LABEL +C NCRT-NUMBER OF CRT UNITS FOR A DASH MARK OR BLANK +C ISIZEL-SIZE OF CONTOUR LINE LABELS +C NDASH-ARRAY CONTAINING THE NEGATIVE VALUED CONTOUR DASH +C PATTERN +C MINGAP-NUMBER OF UNLABELED LINES BETWEEN EACH LABELED ONE +C IDASH-POSITIVE VALUED CONTOUR DASH PATTERN +C ISIZEM-SIZE OF PLOTTED MINIMUMS AND MAXIMUMS +C EDASH-EQUAL VALUED CONTOUR DASH PATTERN +C TENS-DEFAULT TENSION SETTING FOR SMOOTHING +C CONR12 +C IXMAX,IYMAX-MAXIMUM X AND Y COORDINATES RELATIVE TO THE +C SCRATCH ARRAY, SCRARR +C XMAX,YMAX-MAXIMUM X AND Y COORDINATES RELATIVE TO USERS +C COORDINATE SPACE +C CONR13 +C XVS-ARRAY OF THE X COORDINATES FOR SHIELDING +C YVS-ARRAY OF THE Y COORDINATES FOR SHIELDING +C IXVST-POINTER TO THE USERS X ARRAY FOR SHIELDING +C IYVST-POINTER TO THE USERS Y ARRAY FOR SHIELDING +C ICOUNT-COUNT OF THE SHIELD ELEMENTS +C SPVAL-SPECIAL VALUE USED TO HALT CONTOURING AT THE SHIELD +C BOUNDARY +C SHIELD-LOGICAL FLAG TO SIGNAL STATUS OF SHIELDING +C SLDPLT-LOGICAL FLAG TO INDICATE STATUS OF SHIELD PLOTTING +C CONR14 +C LINEAR-C1 LINEAR INTERPOLATING FLAG +C CONR15 +C ISTRNG-TITLE OF THE PLOT +C CONR16 +C FORM-FORMAT USED FOR DATA +C CONR17 +C NDASH-DASH PATTERN USED FOR CONTOUR LINES LESS THAN BP +C IDASH-DASH PATTERN USED FOR CONTOUR LINES GREATER THAN BP +C EDASH-DASH PATTERN USED FOR CONTOUR LINES EQUAL TO THE BP +C RANINT +C IRANMJ-COLOR INDEX FOR NORMAL (MAJOR) INTENSITY LINES +C IRANMN-COLOR INDEX FOR LOW INTENSITY LINES +C IRANMJ-COLOR INDEX FOR TEXT (LABELS) +C +C +NOAO - Blockdata data conbdn rewritten as run time initialization +C Variable LNGTHS not used. +C +C EXTERNAL CONBDN +C DIMENSION LNGTHS(4), HOLD(4) + DIMENSION HOLD(4) +C - NOAO + CHARACTER*110 IWORK + CHARACTER*13 ENCSCR, ENSCRY + CHARACTER*1 ICHAR + CHARACTER*500 DPAT + REAL WIND(4), VIEW(4), NWIND(4), NVIEW(4) + DIMENSION XD(*) ,YD(*) ,ZD(*) ,WK(*) , + 1 IWK(*) ,SCRARR(*) +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD, + 1 SLDPLT + LOGICAL SHIELD,SLDPLT + COMMON /CONR14/LINEAR + LOGICAL LINEAR + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH + COMMON /RANINT/ IRANMJ, IRANMN, IRANTX + INTEGER OPLASF, OTXASF, LASF(13), OCOLI, OTEXCI + SAVE +C +C +C+NOAO - Variable LNGTHS not used. +C DATA LNGTHS(1),LNGTHS(2),LNGTHS(3),LNGTHS(4)/13,4,21,6/ +C-NOAO +C +C ICONV CONVERT FORM 0-32767 TO 1-1024 +C + DATA ICONV/32/ +C +C IABOVE AMOUNT TITLE IS PLACED ABOVE PLOT +C IBELOW, IBEL2 AMOUNT MESSAGE IS BELOW PLOT +C +C DATA IABOVE,IBELOW,IBEL2/30,-30,-45/ +C +C + NOAO - Label placement is improved by changed these values. Also, +C call the run time initialization subroutine, conbdn. +C + iabove = 30 + ibelow = -15 + ibel2 = -30 + call conbdn +C - NOAO +C +C THE FOLLOWING CALL IS FOR MONOTORING LIBRARY USE AT NCAR +C + CALL Q8QST4 ('NSSL','CONRAN','CONRAN','VERSION 01') +C +C LIST THE OPTION VALUES IF REQUESTED +C + IF (LISTOP) CALL CONOUT (2) +C +C SET SWITCH TO MAP TRIANGLES, IN CONLOC, FOR QUICK SEARCHES +C + NIT = 0 +C +C TEST TO SEE IF ENOUGH INPUT DATA +C + IF (NDP.GE.NCP) GO TO 10 + CALL SETER (' CONRAN - INPUT PARAMETER NDP LESS THAN NCP',1, + 1 IREC) + RETURN +C + 10 IF (NCPSZ.GE.NCP .AND. NCP.GE.2) GO TO 20 + CALL SETER (' CONRAN - NCP LT 2 OR GT NCPSZ',2,IREC) +C + 20 IWK(1) = NDP + IWK(2) = NCP + IWK(3) = 1 +C +C SET POLYLINE COLOR ASF TO INDIVIDUAL +C + CALL GQASF(IERR,LASF) + OPLASF = LASF(3) + LASF(3) = 1 + OTXASF = LASF(10) + LASF(10) = 1 + CALL GSASF(LASF) +C +C INQUIRE CURRENT POLYLINE AND TEXT COLOR +C + CALL GQPLCI(IERR,OCOLI) + CALL GQTXCI(IERR,OTEXCI) +C +C SET POLYLINE AND TEXT COLOR TO VALUE IN COMMON +C + CALL GSPLCI(IRANMJ) + CALL GSTXCI(IRANTX) +C +C CONSTRUCTION OF WORK SPACE POINTERS +C +C TRIANGLE POINT NUMBERS +C + JWIPT = 16 +C +C SCRATCH SPACE +C + JWIWL = 6*NDP + 1 +C +C END POINTS OF BORDER LINE SEGMENTS AND TRIANGLE NUMBER +C + JWIPL = 24*NDP + 1 +C +C POINT NUMBERS WHERE THE NCP DATA POINTS AROUND EACH POINT +C + JWIPC = 27*NDP + 1 +C +C SCRATCH SPACE +C + JWIWP = 30*NDP + 1 +C +C PARTIAL DERIVATIVES AT EACH DATA POINT +C + IPR = 8*NDP + 1 +C +C TEST IF REPEAT (JUST NEW CONTOURS OF INTERPOLATED DATA) +C OR NO REPEAT (TRIANGULATE AND CONTOUR) +C + IF (REPEAT) GO TO 30 +C +C TRIANGULATES THE X-Y PLANE. +C + CALL CONTNG (NDP,XD,YD,NT,IWK(JWIPT),NL,IWK(JWIPL),IWK(JWIWL), + 1 IWK(JWIWP),WK) + IF (NERRO(ITEMP).NE.0) RETURN +C + IWK(5) = NT + IWK(6) = NL + NTNL = NT+NL +C +C SKIP IF NOT LINEAR INTERPOLATION +C + IF (.NOT.LINEAR) GO TO 25 +C +C FIND THE COEFICENTS FOR LINER INTERPOLATION OF EACH TRIANGLE +C + CALL CONLIN(XD,YD,ZD,NT,IWK(JWIPT),WK(IPR)) + GO TO 35 +C +C +C DETERMINES NCP POINTS CLOSEST TO EACH DATA POINT. +C + 25 CALL CONDET (NDP,XD,YD,NCP,IWK(JWIPC)) +C +C ESTIMATE THE PARTIAL DERIVATIVES AT ALL DATA POINTS +C + CALL CONINT (NDP,XD,YD,ZD,NCP,IWK(JWIPC),WK(IPR)) +C +C VERIFY DATA VALUES VALID +C + 30 NT = IWK(5) + NL = IWK(6) + NTNL = NT+NL +C +C COMPUTE STEP SIZE FOR CONTOURING +C + 35 CALL CONSTP (XD,YD,NDP) +C +C SAVE ORIGINAL WINDOW, VIEWPORT OF TRANSFORMATION 1, AND ORIGINAL +C LOG SCALING FLAG. +C + CALL GQCNTN(IER,IOLDNT) + CALL GQNT(IOLDNT,IER,WIND,VIEW) + RX1 = VIEW(1) + RX2 = VIEW(2) + RY1 = VIEW(3) + RY2 = VIEW(4) +C SAVE NORMALIZATION TRANSFORMATION 1 + CALL GQNT(1,IER,WIND,VIEW) + CALL GETUSV('LS',IOLLS) +C +C DETERMINE SCALING OPTION +C + ISC = ISCALE+1 + GO TO ( 40, 60, 50),ISC +C +C CONRAN SETS SCALING FACTOR +C + 40 CALL SET(PXST,PXED,PYST,PYED,XST,XED,YST,YED,1) + GO TO 60 +C +C CONRAN PLOTS WITHIN USERS BOUNDARIES +C + 50 CALL SET(RX1,RX2,RY1,RY2,XST,XED,YST,YED,1) +C +C IF TRIANGULATION PLOT ONLY BRANCH +C + 60 IF (EXTRI) GO TO 390 +C +C GENERATE CONTOURS IF NONE SUPPLIED BY USER +C + CALL CONCLS (ZD,NDP) + IF (NERRO(ITEMP).NE.0) RETURN +C +C REORDER THE CONTOUR LINES FOR CORRECT PATTERN DISPLAY +C + MAJLNS = 0 + IF (LABON) CALL CONREO (MAJLNS) +C +C MAKE SURE INTEGER COORDINATES IN 1-1024 RANGE +C + CALL SETUSV('XF',10) + CALL SETUSV('YF',10) +C +C SET THE DASH PATTERNS TO DEFAULT IF THEY HAVE NOT BEEN SET +C +C + IF (IDASH(1:1).NE.' ') GO TO 80 +C +C SET POSITIVE CONTOUR VALUE TO DEFAULT +C + IDASH = '$$$$$$$$$$' + 80 IF (NDASH(1:1).NE.' ') GO TO 100 +C +C SET NEGATIVE CONTOUR DASH PATTERN TO DEFAULT +C + NDASH = '$$$$$$$$$$' + 100 IF (EDASH(1:1).NE.' ') GO TO 120 +C +C SET EQUAL CONTOUR DASH PATTERN TO DEFAULT +C + EDASH = '$$$$$$$$$$' +C +C INITIALIZE THE CONTOURING DATA STRUCTURE +C + 120 IF (.NOT.EXTRAP) YST = YST+STPSZ +C +C LOAD THE SCRATCH SPACE +C + CALL CONLOD (XD,YD,ZD,NDP,WK,IWK,SCRARR) +C +C PERFORM SHIELDING IF SO REQUESTED +C + IF (SHIELD) CALL CONSLD(SCRARR) +C +C ******************************************************* +C * * +C * IF THE USER NEEDS TO DIVIDE THE PROGRAM UP * +C * THIS IS THE BREAK POINT. ALL SUBROUTINES CALLED * +C * PRIOR TO THIS MESSAGE ARE NOT USED AGAIN AND * +C * ALL ROUTINES AFTER THIS MESSAGE ARE NOT USED * +C * ANY EARLIER. NOTE THIS ONLY REFEARS TO ENTRY POINTS* +C * WHICH ARE PART OF THE CONRAN PACKAGE. * +C * ALL DATA STRUCTURES AND VARIABLES MUST BE RETAINED. * +C ******************************************************* +C +C +C PLOT RELATIVE MINIMUMS AND MAXIMUMS IF REQUESTED +C + IF (PMIMX) CALL CONPMM (SCRARR) +C +C + LENDAS = NREP*10 +C +C SET THE ERROR MODE TO RECOVERY FOR THE CONTOURING STORAGE ERROR +C + CALL ENTSR (IROLD,1) +C +C DRAW THE CONTOURS +C + DO 250 I=1,NCL +C + CONV = CL(I) + IF (CONV.GE.BPSIZ) GO TO 150 +C +C SET UP NEGATIVE CONTOUR PATTERN +C + DO 140 J=1,10 + ICHAR = NDASH(J:J) + DO 130 K=1,NREP + DPAT( J+( 10*(K-1) ): J+( 10*(K-1)) ) = ICHAR + 130 CONTINUE + 140 CONTINUE + GO TO 210 +C +C SET UP POSITIVE CONTOUR DASH PATTERN +C + 150 IF (CONV.EQ.BPSIZ) GO TO 180 + DO 170 J=1,10 + ICHAR = IDASH(J:J) + DO 160 K=1,NREP + DPAT( J+( 10*(K-1) ): J+( 10*(K-1)) ) = ICHAR + 160 CONTINUE + 170 CONTINUE + GO TO 210 +C +C SET UP EQUAL CONTOUR DASH PATTERN +C + 180 DO 200 J=1,10 + ICHAR = EDASH(J:J) + DO 190 K=1,NREP + DPAT( J+( 10*(K-1) ): J+( 10*(K-1)) ) = ICHAR + 190 CONTINUE + 200 CONTINUE +C + 210 IF (I.GT.MAJLNS) GO TO 230 +C +C SET UP MAJOR LINES +C + CALL GSPLCI (IRANMJ) + CALL CONECD (CONV,IWORK,NCUSED) + NCHAR = LENDAS + NCUSED + DPAT(LENDAS+1:NCHAR) = IWORK(1:NCUSED) + GO TO 240 +C +C SET UP MINOR LINES +C + 230 NCHAR = 10 + CALL GSPLCI (IRANMN) +C +C PROCESS FOR ALL CONTOURS +C + 240 CALL DASHDC (DPAT(1:NCHAR),NCRT,ISIZEL) +C +C DRAW ALL CONTOURS AT THIS LEVEL +C + CALL CONDRW (SCRARR) +C +C GET NEXT CONTOUR LEVEL +C + 250 CONTINUE +C +C CONTOURING COMPLETED CHECK FOR OPTIONAL OUTPUTS ON PLOT +C +C FIRST SET ERROR MODE BACK TO USERS VALUE +C + CALL RETSR (IROLD) +C +C GET PLOT BOUNDRIES FOR TITLING AND MESSAGE POSITIONING +C + CALL GQCNTN(IER,ICN) + CALL GQNT(ICN,IER,NWIND,NVIEW) + XST = NWIND(1) + XED = NWIND(2) + YST = NWIND(3) + YED = NWIND(4) + CALL GETUSV('LS',LT) +C +C RESET POLYLINE COLOR INDEX TO MAJOR (NORMAL) +C + CALL GSPLCI (IRANMJ) +C +C DRAW SHIELD ON PLOT IF REQUESTED +C + IF(SLDPLT.AND.SHIELD) CALL CONDSD +C +C DRAW PERIMETER ARROUND PLOT IF DESIRED +C + IF (PER) CALL PERIM (ITICK,0,ITICK,0) +C +C DRAW GRID IF REQUESTED +C + IF (GRD) CALL GRID (ITICK,0,ITICK,0) +C +C PLOT THE DATA VALUES IF REQUESTED +C + IF (.NOT.PLDVLS) GO TO 260 + CALL CONPDV (XD,YD,ZD,NDP) +C +C OUTPUT TITLE IF REQUESTED +C + 260 IF (.NOT.TITLE) GO TO 270 + CALL GSTXCI (IRANTX) + CALL FL2INT (XED,YED,MX,MY) + MY = (MY/ICONV)+IABOVE + ILAST = 64 + DO 261 I = 64,1,-1 + IF (ISTRNG(I:I) .NE. ' ')THEN + ILAST = I + 1 + GOTO 262 + ENDIF + 261 CONTINUE + 262 CONTINUE +C +C POSITION STRINGS PROPERLY IF COORDS ARE IN PAU'S +C + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = ( NVIEW(1) + NVIEW(2)) / 2. + YC = CPUY(MY) + CALL WTSTR(XC,YC,ISTRNG(1:ILAST),ITLSIZ,0,0) + CALL GSELNT(ICN) +C +C +C OUTPUT MESSAGE IF REQUESTED +C + 270 IF (.NOT.MESS) GO TO 390 +C + CALL GSTXCI(IRANTX) + CALL FL2INT (XST,YST,MX,MY) + MY = (MY/ICONV) +C +C IF PERIMETER OR GRID PUT OUT TICK INTERVAL +C + IMSZ = 0 + IF (.NOT.PER .AND. .NOT.GRD) GO TO 300 + IWORK(1:36) = 'X INTERVAL= Y INTERVAL=' +C +C +NOAO - FTN internal writes rewritten as calls to encode. +C WRITE(ENCSCR,'(G13.5)')XRG +C WRITE(ENSCRY,'(G13.5)')YRG + call encode (13, '(f13.5)', encscr, xrg) + call encode (13, '(f13.5)', enscry, yrg) +C -NOAO + IWORK(12:24) = ENCSCR + IWORK(37:49) = ENSCRY + IMSZ = 50 + 300 IF (SCALE .EQ. 1.) GOTO 330 + IWORK(IMSZ:IMSZ+10) = ' SCALED BY ' +C +NOAO +C WRITE(ENCSCR,'(G13.5)')SCALE + call encode (13, '(f13.5)', encscr, scale) +C -NOAO + IWORK(IMSZ+11:IMSZ+23) = ENCSCR + IMSZ = 73 + 330 IF (IMSZ .NE. 0) THEN + ILAST = IMSZ + DO 291 I = IMSZ,1,-1 + IF (IWORK(I:I) .NE. ' ')THEN + ILAST = I + 1 + GOTO 292 + ENDIF + 291 CONTINUE + 292 CONTINUE +C +C POSITION STRINGS PROPERLY IF COORDS ARE IN PAU'S +C + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = ( NVIEW(1) + NVIEW(2)) / 2. + YC = CPUY(MY+IBEL2) + CALL WTSTR(XC,YC,IWORK(1:ILAST),8,0,0) + CALL GSELNT(ICN) + ENDIF +C +C PRODUCE CONTOUR INFO +C + IWORK(1:42) = 'CONTOUR FROM TO ' + IWORK(43:77) = 'CONTOUR INTERVAL OF ' + HOLD(1) = FLO + HOLD(2) = HI + HOLD(3) = FINC +C +C +NOAO +C WRITE(ENCSCR,'(G13.5)')HOLD(1) + call encode (13, '(f13.5)', encscr, hold(1)) + IWORK(13:25) = ENCSCR +C WRITE(ENCSCR,'(G13.5)')HOLD(2) + call encode (13, '(f13.5)', encscr, hold(2)) + IWORK(29:41) = ENCSCR +C WRITE(ENCSCR,'(G13.5)')HOLD(3) + call encode (13, '(f13.5)', encscr, hold(3)) + IWORK(62:74) = ENCSCR +C -NOAO +C +C IF IRREGULAR SPACED CONTOURS MODIFY CONTOUR INTERVAL STATEMENT +C + IF (FINC.GE.0.) GO TO 380 + NC = 62 + IWORK(NC:NC+15) = ' IRREGULAR ' +C + ILAST = 77 + 380 DO 381 I = 77,1,-1 + IF (IWORK(I:I) .NE. ' ')THEN + ILAST = I + 1 + GOTO 382 + ENDIF + 381 CONTINUE + 382 CONTINUE +C +C POSITION STRINGS PROPERLY IF COORDS ARE IN PAU'S +C + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = ( NVIEW(1) + NVIEW(2)) / 2. + YC = CPUY(MY+IBELOW) + CALL WTSTR(XC,YC,IWORK(1:ILAST),8,0,0) + CALL GSELNT(ICN) +C +C +C +C PLOT TRIANGLES IF REQUESTED +C + 390 IF (LOOK) THEN + CALL GSPLCI(IRANMN) + CALL CONTLK (XD,YD,NDP,IWK(JWIPT)) + CALL GSPLCI(IRANMJ) + ENDIF +C RESTORE NORMALIZATION TRANSFORMATION 1 AND LOG SCALING + IF (ISCALE .NE. 1) THEN + CALL SET(VIEW(1),VIEW(2),VIEW(3),VIEW(4), + - WIND(1),WIND(2),WIND(3),WIND(4),IOLLS) + ENDIF +C RESTORE ORIGINAL NORMALIZATION TRANSFORMATION NUMBER + CALL GSELNT (IOLDNT) +C +C RESTORE ORIGINAL COLOR +C + CALL GSPLCI(OCOLI) + CALL GSTXCI(OTEXCI) +C +C RESTORE POLYLINE COLOR ASF TO WHAT IT WAS ON ENTRY TO GRIDAL +C + LASF(10) = OTXASF + LASF(3) = OPLASF + CALL GSASF(LASF) + RETURN + END + SUBROUTINE CONPMM (SCRARR) +C +C THIS ROUTINE FINDS RELATIVE MINIMUMS AND MAXIMUMS. A RELATIVE MINIMUM +C (OR MAXIMUM) IS DEFINED TO BE THE LOWEST (OR HIGHEST) POINT WITHIN +C A CERTAIN NEIGHBORHOOD OF THE POINT. THE NEIGHBORHOOD USED HERE +C IS + OR - IXRG IN THE X DIRECTION AND + OR - IYRG IN THE Y DIRECTION. +C +C +C + COMMON /CONRA1/ CL(30) ,NCL ,OLDZ ,PV(210) , + 1 FINC ,HI ,FLO + COMMON /CONRA2/ REPEAT ,EXTRAP ,PER ,MESS , + 1 ISCALE ,LOOK ,PLDVLS ,GRD , + 2 CINC ,CHILO ,CON ,LABON , + 3 PMIMX ,SCALE ,FRADV ,EXTRI , + 4 BPSIZ ,LISTOP + COMMON /CONRA3/ IREC + COMMON /CONRA4/ NCP ,NCPSZ + COMMON /CONRA5/ NIT ,ITIPV + COMMON /CONRA6/ XST ,YST ,XED ,YED , + 1 STPSZ ,IGRAD ,IG ,XRG , + 2 YRG ,BORD ,PXST ,PYST , + 3 PXED ,PYED ,ITICK + COMMON /CONRA7/ TITLE ,ICNT ,ITLSIZ + COMMON /CONRA8/ IHIGH ,INMAJ ,INLAB ,INDAT , + 1 LEN ,IFMT ,LEND , + 2 IFMTD ,ISIZEP ,INMIN + COMMON /CONRA9/ ICOORD(500),NP ,MXXY ,TR , + 1 BR ,TL ,BL ,CONV , + 2 XN ,YN ,ITLL ,IBLL , + 3 ITRL ,IBRL ,XC ,YC , + 4 ITLOC(210) ,JX ,JY ,ILOC , + 5 ISHFCT ,XO ,YO ,IOC ,NC + COMMON /CONR10/ NT ,NL ,NTNL ,JWIPT , + 1 JWIWL ,JWIWP ,JWIPL ,IPR , + 2 ITPV + COMMON /CONR11/ NREP ,NCRT ,ISIZEL , + 1 MINGAP ,ISIZEM , + 2 TENS + COMMON /CONR12/ IXMAX ,IYMAX ,XMAX ,YMAX + LOGICAL REPEAT ,EXTRAP ,PER ,MESS , + 1 LOOK ,PLDVLS ,GRD ,LABON , + 2 PMIMX ,FRADV ,EXTRI ,CINC , + 3 TITLE ,LISTOP ,CHILO ,CON + COMMON /CONR15/ ISTRNG + CHARACTER*64 ISTRNG + COMMON /CONR16/ FORM + CHARACTER*10 FORM + COMMON /CONR17/ NDASH, IDASH, EDASH + CHARACTER*10 NDASH, IDASH, EDASH +C +C +C + DIMENSION SCRARR(*) + CHARACTER*10 IA + SAVE +C +C CONVERT FROM 0-32767 TO 1-1024 +C + DATA ICONV/32/ +C +C ACCESSING FUNCTION INTO SCRARR +C + SCRTCH(IXX,IYY) = SCRARR(IYY+(IXX-1)*IYMAX) +C +C GRAPHICS MAPPING FUNCTIONS +C + FX(XXX,YYY) = XXX + FY(XXX,YYY) = YYY +C +C MAPPING FROM INTEGER TO USER INPUT FLOATING POINT +C + CONVX(IXX) = XST + FLOAT(IXX-1)*STPSZ + CONVY(IYY) = YST + FLOAT(IYY-1)*STPSZ +C +C SET INTENSITY TO HIGH +C + IF (INDAT .NE. 1) THEN + CALL GSTXCI (INDAT) + ELSE + CALL GSTXCI (IRANTX) + ENDIF +C +C COMPUTE THE SEARCH RANGE FOR MIN AND MAX DETERMINATION +C + IXRG = MIN0(15,MAX0(2,IFIX(FLOAT(IXMAX)/8.))) + IYRG = MIN0(15,MAX0(2,IFIX(FLOAT(IYMAX)/8.))) +C +C LOOP THROUGH ALL ROWS OF THE DATA SEARCHING FOR AN IMMEDIATE MIN OR +C MAX. +C + IX = 1 +C +C SCAN A ROW +C +C IF EXTRAPOLATING DONT LIMIT ROW SCANS +C + 10 IF (.NOT.EXTRAP) GO TO 20 + IYST = 1 + IYED = IYMAX + IY = 1 + GO TO 30 +C +C NOT EXTRAPOLATING STAY IN HULL BOUNDRIES +C + 20 IYST = ITLOC(IX*2-1) + IYED = ITLOC(IX*2) + IF (IYST.EQ.0) GO TO 240 + IY = IYST + 30 VAL = SCRTCH(IX,IY) +C +C SEARCH FOR A MIN +C +C +C BRANCH IF NOT FIRST ON A ROW +C + IF (IY.NE.IYST) GO TO 40 + IF (VAL.GE.SCRTCH(IX,IY+1)) GO TO 130 + IF (VAL.GE.SCRTCH(IX,IY+2)) GO TO 130 + GO TO 60 +C +C BRANCH IF NOT LAST ON ROW +C + 40 IF (IY.NE.IYED) GO TO 50 + IF (VAL.GE.SCRTCH(IX,IY-1)) GO TO 140 + IF (VAL.GE.SCRTCH(IX,IY-2)) GO TO 140 + GO TO 60 +C +C IN MIDDLE OF ROW +C + 50 IF (VAL.GE.SCRTCH(IX,IY+1)) GO TO 150 + IF (VAL.GE.SCRTCH(IX,IY-1)) GO TO 150 +C +C POSSIBLE MIN FOUND SEARCH NEIGHBORHOOD +C + 60 IXST = MAX0(1,IX-IXRG) + IXSTOP = MIN0(IXMAX,IX+IXRG) +C +C IF NOT EXTRAPOLATING BRANCH +C + 70 IF (.NOT.EXTRAP) GO TO 80 + IYSRS = 1 + IYSRE = IYMAX + GO TO 90 +C +C NOT EXTRAPOLATING STAY IN CONVEX HULL +C + 80 IYSRS = ITLOC(IXST*2-1) + IYSRE = ITLOC(IXST*2) + IF (IYSRS.EQ.0) GO TO 120 +C + 90 IYSRS = MAX0(IYSRS,IY-IYRG) + IYSRE = MIN0(IYSRE,IY+IYRG) +C + 100 CUR = SCRTCH(IXST,IYSRS) + IF (VAL.LT.CUR) GO TO 110 + IF (VAL.GT.CUR) GO TO 230 + IF (IX.EQ.IXST .AND. IY.EQ.IYSRS) GO TO 110 + GO TO 230 +C +C SUCCESS SO FAR TRY NEXT SPACE +C + 110 IYSRS = IYSRS+1 + IF (IYSRS.LE.IYSRE) GO TO 100 + 120 IXST = IXST+1 + IF (IXST.LE.IXSTOP) GO TO 70 +C +C SUCCESS, WE HAVE FOUND A RELATIVE MIN +C + X = CONVX(IX) + Y = CONVY(IY) + X1 = FX(X,Y) + CALL FL2INT (X1,FY(X,Y),MX,MY) + MX = MX/ICONV + MY = MY/ICONV +C +C POSITION STRINGS PROPERLY IF COORDS ARE IN PAU'S +C + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = CPUX(MX) + YC = CPUY(MY) + CALL WTSTR(XC,YC,'L',ISIZEM,0,0) + CALL GSELNT(ICN) +C + CALL CONECD (VAL,IA,NC) + MY = MY - 2*ISIZEM +C +C POSITION STRINGS PROPERLY IF COORDS ARE IN PAU'S +C + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + YC = CPUY(MY) + CALL WTSTR(XC,YC,IA(1:NC),ISIZEM,0,0) + CALL GSELNT(ICN) +C + GO TO 230 +C +C SEARCH FOR A LOCAL MAXIMUM +C +C IF FIRST LOC ON A ROW +C + 130 IF (VAL.LE.SCRTCH(IX,IY+1)) GO TO 230 + IF (VAL.LE.SCRTCH(IX,IY+2)) GO TO 230 + GO TO 160 +C +C IF LAST ON ROW +C + 140 IF (VAL.LE.SCRTCH(IX,IY-1)) GO TO 230 + IF (VAL.LE.SCRTCH(IX,IY-2)) GO TO 230 + GO TO 160 +C +C IN MIDDLE OF ROW +C + 150 IF (VAL.LE.SCRTCH(IX,IY+1)) GO TO 230 + IF (VAL.LE.SCRTCH(IX,IY-1)) GO TO 230 +C +C POSSIBLE MIN FOUND SEARCH NEIGHBORHOOD +C + 160 IXST = MAX0(1,IX-IXRG) + IXSTOP = MIN0(IXMAX,IX+IXRG) + 170 IF (.NOT.EXTRAP) GO TO 180 + IYSRS = 1 + IYSRE = IYMAX + GO TO 190 +C +C NOT EXTRAPOLATING STAY IN CONVEX HULL +C + 180 IYSRS = ITLOC(IXST*2-1) + IYSRE = ITLOC(IXST*2) + IF (IYSRS.EQ.0) GO TO 220 +C + 190 IYSRS = MAX0(IYSRS,IY-IYRG) + IYSRE = MIN0(IYSRE,IY+IYRG) +C + 200 CUR = SCRTCH(IXST,IYSRS) + IF (VAL.GT.CUR) GO TO 210 + IF (VAL.LT.CUR) GO TO 230 + IF (IX.EQ.IXST .AND. IY.EQ.IYSRS) GO TO 210 + GO TO 230 +C +C SUCCESS SO FAR TRY NEXT SPACE +C + 210 IYSRS = IYSRS+1 + IF (IYSRS.LE.IYSRE) GO TO 200 + 220 IXST = IXST+1 + IF (IXST.LE.IXSTOP) GO TO 170 +C +C SUCCESS WE HAVE A MAXIMUM +C + X = CONVX(IX) + Y = CONVY(IY) + X1 = FX(X,Y) + CALL FL2INT (X1,FY(X,Y),MX,MY) + MX = MX/ICONV + MY = MY/ICONV +C +C POSITION STRINGS PROPERLY IF COORDS ARE IN PAU'S +C + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = CPUX(MX) + YC = CPUY(MY) + CALL WTSTR(XC,YC,'H',ISIZEM,0,0) + CALL GSELNT(ICN) +C + CALL CONECD (VAL,IA,NC) + MY = MY - 2*ISIZEM +C +C POSITION STRINGS PROPERLY IF COORDS ARE IN PAU'S +C + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + YC = CPUY(MY) + CALL WTSTR(XC,YC,IA(1:NC),ISIZEM,0,0) + CALL GSELNT(ICN) +C +C END OF SEARCH AT THIS LOCATION TRY NEXT +C + 230 IY = IY+1 + IF (IY.LE.IYED) GO TO 30 + 240 IX = IX+1 + IF (IX.LE.IXMAX) GO TO 10 +C + CALL GSTXCI (IRANTX) +C + RETURN +C +C****************************************************************** +C* * +C* REVISION HISTORY * +C* * +C* JUNE 1980 ADDED CONRAN TO ULIB * +C* AUGUST 1980 CHANGED ACCESS CARD DOCUMENTATION * +C* DECEMBER 1980 MODIFIED COMMENT CARD DOCUMENTATION * +C* MARCH 1983 ADDED ASPECT RATIO ERROR * +C* JULY 1983 ADDED SHIELDING AND LINEAR INTERPOLATION * +C* REMOVED 7600 ACCESS CARDS * +C* JULY 1984 CONVERTED TO STANDARD FORTRAN77 AND GKS * +C* * +C****************************************************************** +C + END diff --git a/sys/gio/ncarutil/conrec.f b/sys/gio/ncarutil/conrec.f new file mode 100644 index 00000000..b3e246c1 --- /dev/null +++ b/sys/gio/ncarutil/conrec.f @@ -0,0 +1,1313 @@ + SUBROUTINE CONREC (Z,L,M,N,FLO,HI,FINC,NSET,NHI,NDOT) +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C +C DIMENSION OF Z(L,N) +C ARGUMENTS +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE CONREC DRAWS A CONTOUR MAP FROM DATA STORED +C IN A RECTANGULAR ARRAY, LABELING THE LINES. +C +C USAGE IF THE FOLLOWING ASSUMPTIONS ARE MET, USE +C +C CALL EZCNTR (Z,M,N) +C +C ASSUMPTIONS: +C --ALL OF THE ARRAY IS TO BE CONTOURED. +C --CONTOUR LEVELS ARE PICKED +C INTERNALLY. +C --CONTOURING ROUTINE PICKS SCALE +C FACTORS. +C --HIGHS AND LOWS ARE MARKED. +C --NEGATIVE LINES ARE DRAWN WITH A +C DASHED LINE PATTERN. +C --EZCNTR CALLS FRAME AFTER DRAWING THE +C CONTOUR MAP. +C +C IF THESE ASSUMPTIONS ARE NOT MET, USE +C +C CALL CONREC (Z,L,M,N,FLO,HI,FINC,NSET, +C NHI,NDOT) +C +C ARGUMENTS +C +C ON INPUT Z +C FOR EZCNTR M BY N ARRAY TO BE CONTOURED. +C +C M +C FIRST DIMENSION OF Z. +C +C N +C SECOND DIMENSION OF Z. +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED. +C FOR EZCNTR +C +C ON INPUT Z +C FOR CONREC THE (ORIGIN OF THE) ARRAY TO BE +C CONTOURED. Z IS DIMENSIONED L BY N. +C +C L +C THE FIRST DIMENSION OF Z IN THE CALLING +C PROGRAM. +C +C M +C THE NUMBER OF DATA VALUES TO BE CONTOURED +C IN THE X-DIRECTION (THE FIRST SUBSCRIPT +C DIRECTION). WHEN PLOTTING AN ENTIRE +C ARRAY, L = M. +C +C N +C THE NUMBER OF DATA VALUES TO BE CONTOURED +C IN THE Y-DIRECTION (THE SECOND SUBSCRIPT +C DIRECTION). +C +C FLO +C THE VALUE OF THE LOWEST CONTOUR LEVEL. +C IF FLO = HI = 0., A VALUE ROUNDED UP FROM +C THE MINIMUM Z IS GENERATED BY CONREC. +C +C HI +C THE VALUE OF THE HIGHEST CONTOUR LEVEL. +C IF HI = FLO = 0., A VALUE ROUNDED DOWN +C FROM THE MAXIMUM Z IS GENERATED BY +C CONREC. +C +C FINC +C > 0 INCREMENT BETWEEN CONTOUR LEVELS. +C = 0 A VALUE, WHICH PRODUCES BETWEEN 10 +C AND 30 CONTOUR LEVELS AT NICE VALUES, +C IS GENERATED BY CONREC. +C < 0 THE NUMBER OF LEVELS GENERATED BY +C CONREC IS ABS(FINC). +C +C NSET +C FLAG TO CONTROL SCALING. +C = 0 CONREC AUTOMATICALLY SETS THE +C WINDOW AND VIEWPORT TO PROPERLY +C SCALE THE FRAME TO THE STANDARD +C CONFIGURATION. +C THE GRIDAL ENTRY PERIM IS +C CALLED AND TICK MARKS ARE PLACED +C CORRESPONDING TO THE DATA POINTS. +C > 0 CONREC ASSUMES THAT THE USER +C HAS SET THE WINDOW AND VIEWPORT +C IN SUCH A WAY AS TO PROPERLY +C SCALE THE PLOTTING +C INSTRUCTIONS GENERATED BY CONREC. +C PERIM IS NOT CALLED. +C < 0 CONREC GENERATES COORDINATES SO AS +C TO PLACE THE (UNTRANSFORMED) CONTOUR +C PLOT WITHIN THE LIMITS OF THE +C USER'S CURRENT WINDOW AND +C VIEWPORT. PERIM IS NOT CALLED. +C +C NHI +C FLAG TO CONTROL EXTRA INFORMATION ON THE +C CONTOUR PLOT. +C = 0 HIGHS AND LOWS ARE MARKED WITH AN H +C OR L AS APPROPRIATE, AND THE VALUE +C OF THE HIGH OR LOW IS PLOTTED UNDER +C THE SYMBOL. +C > 0 THE DATA VALUES ARE PLOTTED AT +C EACH Z POINT, WITH THE CENTER OF +C THE STRING INDICATING THE DATA +C POINT LOCATION. +C < 0 NEITHER OF THE ABOVE. +C +C NDOT +C A 10-BIT CONSTANT DESIGNATING THE DESIRED +C DASHED LINE PATTERN. +C IF ABS(NDOT) = 0, 1, OR 1023, SOLID LINES +C ARE DRAWN. +C > 0 NDOT PATTERN IS USED FOR ALL LINES. +C < 0 ABS(NDOT) PATTERN IS USED FOR NEGA- +C TIVE-VALUED CONTOUR LINES, AND SOLID IS +C USED FOR POSITIVE-VALUED CONTOURS. +C CONREC CONVERTS NDOT +C TO A 16-BIT PATTERN AND DASHDB IS USED. +C SEE DASHDB COMMENTS IN THE DASHLINE +C DOCUMENTATION FOR DETAILS. +C +C +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED. +C FOR CONREC +C +C +C ENTRY POINTS CONREC, CLGEN, REORD, STLINE, DRLINE, +C MINMAX, PNTVAL, CALCNT, EZCNTR, CONBD +C +C COMMON BLOCKS INTPR, RECINT, CONRE1, CONRE2, CONRE3, +C CONRE4,CONRE5 +C +C REQUIRED LIBRARY STANDARD VERSION: DASHCHAR, WHICH AT +C ROUTINES NCAR ISLOADED BY DEFAULT. +C SMOOTH VERSION: DASHSMTH WHICH MUST BE +C REQUESTED AT NCAR. +C BOTH VERSIONS REQUIRE GRIDAL, THE +C ERPRT77 PACKAGE, AND THE SPPS. +C +C I/O PLOTS CONTOUR MAP. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN 77 +C +C HISTORY REPLACES OLD CONTOURING PACKAGE CALLED +C CALCNT AT NCAR. +C +C ALGORITHM EACH LINE IS FOLLOWED TO COMPLETION. POINTS +C ALONG A LINE ARE FOUND ON BOUNDARIES OF THE +C (RECTANGULAR) CELLS. THESE POINTS ARE +C CONNECTED BY LINE SEGMENTS USING THE +C SOFTWARE DASHED LINE PACKAGE, DASHCHAR. +C DASHCHAR IS ALSO USED TO LABEL THE +C LINES. +C +C NOTE TO DRAW NON-UNIFORM CONTOUR LEVELS, SEE +C THE COMMENTS IN CLGEN. TO MAKE SPECIAL +C MODIFICATIONS FOR SPECIFIC NEEDS SEE THE +C EXPLANATION OF THE INTERNAL PARAMETERS +C BELOW. +C +C TIMING VARIES WIDELY WITH SIZE AND SMOOTHNESS OF +C Z. +C +C INTERNAL PARAMETERS NAME DEFAULT FUNCTION +C ---- ------- -------- +C +C ISIZEL 1 SIZE OF LINE LABELS, +C AS PER THE SIZE DEFINITIONS +C GIVEN IN THE SPPS +C DOCUMENTATION FOR WTSTR. +C +C ISIZEM 2 SIZE OF LABELS FOR MINIMUMS +C AND MAXIMUMS, +C AS PER THE SIZE DEFINITIONS +C GIVEN IN THE SPPS +C DOCUMENTATION FOR WTSTR. +C +C ISIZEP 0 SIZE OF LABELS FOR DATA +C POINT VALUES AS PER THE SIZE +C DEFINITIONS GIVEN IN THE SPPS +C DOCUMENTATION FOR WTSTR. +C +C NLA 16 APPROXIMATE NUMBER OF +C CONTOUR LEVELS WHEN +C INTERNALLY GENERATED. +C +C NLM 40 MAXIMUM NUMBER OF CONTOUR +C LEVELS. IF THIS IS TO BE +C INCREASED, THE DIMENSIONS +C OF CL AND RWORK IN CONREC +C MUST BE INCREASED BY THE +C SAME AMOUNT. +C +C XLT .05 LEFT HAND EDGE OF THE PLOT +C (0.0 IS THE LEFT EDGE OF +C THE FRAME AND 1.0 IS THE +C RIGHT EDGE OF THE FRAME.) +C +C YBT .05 BOTTOM EDGE OF THE PLOT +C (0.0 IS THE BOTTOM OF THE +C FRAME AND 1.0 IS THE TOP +C OF THE FRAME.) +C +C SIDE 0.9 LENGTH OF LONGER EDGE OF +C PLOT (SEE ALSO EXT). +C +C NREP 6 NUMBER OF REPETITIONS OF +C THE DASH PATTERN BETWEEN +C LINE LABELS. +C +C NCRT 2 NUMBER OF CRT UNITS PER +C ELEMENT (BIT) IN THE DASH +C PATTERN. +C +NOAO - Value of ncrt changed from 4 to 2 in conbd. +C -NOAO +C +C ILAB 1 FLAG TO CONTROL THE DRAWING +C OF LINE LABELS. +C . ILAB NON-ZERO MEANS LABEL +C THE LINES. +C . ILAB = 0 MEANS DO NOT +C LABEL THE LINES. +C +C NULBLL 3 NUMBER OF UNLABELED LINES +C BETWEEN LABELED LINES. FOR +C EXAMPLE, WHEN NULBLL = 3, +C EVERY FOURTH LEVEL IS +C LABELED. +C +C IOFFD 0 FLAG TO CONTROL +C NORMALIZATION OF LABEL +C NUMBERS. +C . IOFFD = 0 MEANS INCLUDE +C DECIMAL POINT WHEN +C POSSIBLE (DO NOT +C NORMALIZE UNLESS +C REQUIRED). +C . IOFFD NON-ZERO MEANS +C NORMALIZE ALL LABEL +C NUMBERS AND OUTPUT A +C SCALE FACTOR IN THE +C MESSAGE BELOW THE GRAPH. +C +C EXT .0625 LENGTHS OF THE SIDES OF THE +C PLOT ARE PROPORTIONAL TO M +C AND N (WHEN CONREC SETS +C THE WINDOW AND VIEWPORT). +C IN EXTREME CASES, WHEN +C MIN(M,N)/MAX(M,N) IS LESS +C THAN EXT, CONREC +C PRODUCES A SQUARE PLOT. +C +C IOFFP 0 FLAG TO CONTROL SPECIAL +C VALUE FEATURE. +C . IOFFP = 0 MEANS SPECIAL +C VALUE FEATURE NOT IN USE. +C . IOFFP NON-ZERO MEANS +C SPECIAL VALUE FEATURE IN +C USE. (SPVAL IS SET TO THE +C SPECIAL VALUE.) CONTOUR +C LINES WILL THEN BE +C OMITTED FROM ANY CELL +C WITH ANY CORNER EQUAL TO +C THE SPECIAL VALUE. +C +C SPVAL 0. CONTAINS THE SPECIAL VALUE +C WHEN IOFFP IS NON-ZERO. +C +C IOFFM 0 FLAG TO CONTROL THE MESSAGE +C BELOW THE PLOT. +C . IOFFM = 0 IF THE MESSAGE +C IS TO BE PLOTTED. +C . IOFFM NON-ZERO IF THE +C MESSAGE IS TO BE OMITTED. +C +C ISOLID 1023 DASH PATTERN FOR +C NON-NEGATIVE CONTOUR LINES. +C +C +C +NOAO - Block data conbd rewritten as run time initialization. +C EXTERNAL CONBD +C -NOAO +C + SAVE + CHARACTER*1 IGAP ,ISOL ,RCHAR + CHARACTER ENCSCR*22 ,IWORK*126 +C +NOAO - Character variable added for improved label processing. + character*25 string(5) +C -NOAO + DIMENSION LNGTHS(5) ,HOLD(5) ,WNDW(4) ,VWPRT(4) + DIMENSION Z(L,N) ,CL(40) ,RWORK(40) ,LASF(13) + COMMON /INTPR/ PAD1, FPART, PAD(8) + COMMON /CONRE1/ IOFFP ,SPVAL + COMMON /CONRE3/ IXBITS ,IYBITS + COMMON /CONRE4/ ISIZEL ,ISIZEM ,ISIZEP ,NREP , + 1 NCRT ,ILAB ,NULBLL ,IOFFD , + 2 EXT ,IOFFM ,ISOLID ,NLA , + 3 NLM ,XLT ,YBT ,SIDE + COMMON /CONRE5/ SCLY + COMMON /RECINT/ IRECMJ ,IRECMN ,IRECTX +C +NOAO - Value of LNGTHS have been changed from original defaults. Additional +C common block noaolb added for communication with calling routine. +C + common /noaolb/ hold + DATA LNGTHS(1),LNGTHS(2),LNGTHS(3),LNGTHS(4),LNGTHS(5) + 1 / 13, 4, 21, 10, 19 / + DATA ISOL, IGAP /'$', ''''/ +C +C -NOAO +C +C ISOL AND IGAP (DOLLAR-SIGN AND APOSTROPHE) ARE USED TO CONSTRUCT PAT- +C TERNS PASSED TO ROUTINE DASHDC IN THE SOFTWARE DASHED-LINE PACKAGE. +C +C +C +C +NOAO - Blockdata conbd called as run time initialization subroutine + call conbd +C -NOAO +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','CONREC','CONREC','VERSION 01') +C +C NONSMOOTHING VERSION +C +C +C +C CALL RESET FOR COMPATIBILITY WITH ALL DASH ROUTINES(EXCEPT DASHLINE) +C + CALL RESET +C +C GET NUMBER OF BITS IN INTEGER ARITHMETIC +C + IARTH = I1MACH(8) + IXBITS = 0 + DO 101 I=1,IARTH + IF (M .LE. (2**I-1)) GO TO 102 + IXBITS = I+1 + 101 CONTINUE + 102 IYBITS = 0 + DO 103 I=1,IARTH + IF (N .LE. (2**I-1)) GO TO 104 + IYBITS = I+1 + 103 CONTINUE + 104 IF ((IXBITS*IYBITS).GT.0 .AND. (IXBITS+IYBITS).LE.24) GO TO 105 +C +C REPORT ERROR NUMBER ONE +C + IWORK = 'CONREC - DIMENSION ERROR - M*N .GT. (2**IARTH) M = + + N = ' +C +NOAO +C +C WRITE (IWORK(56:62),'(I6)') M + call encode (6, '(i6)', iwork(56:62), m) +C WRITE (IWORK(73:79),'(I6)') N + call encode (6, '(i6)', iwork(73:79), n) +C -NOAO +C + CALL SETER( IWORK, 1, 1 ) + RETURN + 105 CONTINUE +C +C INQUIRE CURRENT TEXT AND LINE COLOR INDEX +C + CALL GQTXCI ( IERR, ITXCI ) + CALL GQPLCI ( IERR, IPLCI ) +C +C SET LINE AND TEXT ASF TO INDIVIDUAL +C + CALL GQASF ( IERR, LASF ) + LSV3 = LASF(3) + LSV10 = LASF(10) + LASF(3) = 1 + LASF(10) = 1 + CALL GSASF ( LASF ) +C + GL = FLO + HA = HI + GP = FINC + MX = L + NX = M + NY = N + IDASH = NDOT + NEGPOS = ISIGN(1,IDASH) + IDASH = IABS(IDASH) + IF (IDASH.EQ.0 .OR. IDASH.EQ.1) IDASH = ISOLID +C +C SET CONTOUR LEVELS. +C + CALL CLGEN (Z,MX,NX,NY,GL,HA,GP,NLA,NLM,CL,NCL,ICNST) +C +C FIND MAJOR AND MINOR LINES +C + IF (ILAB .NE. 0) CALL REORD (CL,NCL,RWORK,NML,NULBLL+1) + IF (ILAB .EQ. 0) NML = 0 +C +C SAVE CURRENT NORMALIZATION TRANS NUMBER NTORIG AND LOG SCALING FLAG +C + CALL GQCNTN ( IERR, NTORIG ) + CALL GETUSV ('LS',IOLLS) +C +C SET UP SCALING +C + CALL GETUSV ( 'YF' , IYVAL ) + SCLY = 1.0 / ISHIFT ( 1, 15 - IYVAL ) +C + IF (NSET) 106,107,111 + 106 CALL GQNT ( NTORIG,IERR,WNDW,VWPRT ) + X1 = VWPRT(1) + X2 = VWPRT(2) + Y1 = VWPRT(3) + Y2 = VWPRT(4) +C +C SAVE NORMALIZATION TRANS 1 +C + CALL GQNT (1,IERR,WNDW,VWPRT) +C +C DEFINE NORMALIZATION TRANS AND LOG SCALING +C + CALL SET(X1, X2, Y1, Y2, 1.0, FLOAT(NX), 1.0, FLOAT(NY), 1) + GO TO 111 + 107 CONTINUE + X1 = XLT + X2 = XLT+SIDE + Y1 = YBT + Y2 = YBT+SIDE + X3 = NX + Y3 = NY + IF (AMIN1(X3,Y3)/AMAX1(X3,Y3) .LT. EXT) GO TO 110 + IF (NX-NY) 108,110,109 + 108 X2 = SIDE*X3/Y3+XLT + GO TO 110 + 109 Y2 = SIDE*Y3/X3+YBT +C +C SAVE NORMALIZATION TRANS 1 +C + 110 CALL GQNT ( 1, IERR, WNDW, VWPRT ) +C +C DEFINE NORMALIZATION TRANS 1 AND LOG SCALING +C + CALL SET(X1,X2,Y1,Y2,1.0,X3,1.0,Y3,1) +C +C DRAW PERIMETER +C + CALL PERIM (NX-1,1,NY-1,1) + 111 IF (ICNST .NE. 0) GO TO 124 +C +C SET UP LABEL SCALING +C + IOFFDT = IOFFD + IF (GL.NE.0.0 .AND. (ABS(GL).LT.0.1 .OR. ABS(GL).GE.1.E5)) + 1 IOFFDT = 1 + IF (HA.NE.0.0 .AND. (ABS(HA).LT.0.1 .OR. ABS(HA).GE.1.E5)) + 1 IOFFDT = 1 + ASH = 10.**(3-IFIX(ALOG10(AMAX1(ABS(GL),ABS(HA),ABS(GP)))-5000.)- + 1 5000) + IF (IOFFDT .EQ. 0) ASH = 1. + HOLD(1) = GL + HOLD(2) = HA + HOLD(3) = GP + HOLD(4) = Z(3,3) + HOLD(5) = ASH + NCHAR = 0 + IF (IOFFM .NE. 0) GO TO 115 +C +NOAO - This label generation has been reworked to eliminate the large +C spaces in between fields of the label. +C IWORK = 'CONTOUR FROM TO CONTOUR INTERVAL +C 1 OF PT(3,3)= LABELS SCALED BY' + string(1)(1:13) = 'CONTOUR FROM ' + string(2)(1:4) = ' TO ' + string(3)(1:21) = '; CONTOUR INTERVAL = ' + string(4)(1:11) = '; PT(3,3)= ' + string(5)(1:19) = '; LABELS SCALED BY ' +C + DO 114 I=1,5 +C (NOAO) WRITE ( ENCSCR, '(G13.5)' ) HOLD(I) + call encd (hold(i), ash, encscr, nc, ioffd) + do 1113 k = 1, lngths(i) + nchar = nchar + 1 + 1113 iwork(nchar:nchar) = string(i)(k:k) +C +C (NOAO) NCHAR = NCHAR+LNGTHS(I) +C (NOAO) DO 113 J=1,13 + do 113 j = 1, nc + NCHAR = NCHAR+1 + IWORK(NCHAR:NCHAR) = ENCSCR(J:J) + 113 CONTINUE + 114 CONTINUE +C +C +NOAO IF (ASH .EQ. 1.) NCHAR = NCHAR-13-LNGTHS(5) + if (ash .eq. 1.) nchar = nchar - nc - lngths(5) +C -NOAO +C +C SET TEXT INTENSITY TO LOW, AND WRITE TITLE USING NORMALIZATION +C TRANS NUMBER 0 +C + CALL GSTXCI (IRECTX) + CALL GETUSV('LS',LSO) + CALL SETUSV('LS',1) + CALL GSELNT (0) +C +NOAO - following text output centered on current viewport +C CALL WTSTR ( 0.5, 0.015625, IWORK(1:NCHAR), 0, 0, 0 ) + CALL WTSTR ( ((x1+x2)/2.0), y1 - 0.03, IWORK(1:NCHAR), 0, 0, 0 ) +C -NOAO + CALL SETUSV('LS',LSO) + CALL GSELNT (1) +C +C +C +C * * * * * * * * * * +C * * * * * * * * * * +C +C +C PROCESS EACH LEVEL +C + 115 FPART = .5 +C + DO 123 I=1,NCL + CONTR = CL(I) + NDASH = IDASH + IF (NEGPOS.LT.0 .AND. CONTR.GE.0.) NDASH = ISOLID +C +C CHANGE 10 BIT PATTERN TO 10 CHARACTER PATTERN. +C + DO 116 J=1,10 + IBIT = IAND(ISHIFT(NDASH,(J-10)),1) + RCHAR = IGAP + IF (IBIT .NE. 0) RCHAR = ISOL + IWORK(J:J) = RCHAR + 116 CONTINUE + IF (I .GT. NML) GO TO 121 +C +C SET UP MAJOR LINE (LABELED) +C +C SET LINE INTENSITY TO HIGH +C + CALL GSPLCI ( IRECMJ ) +C +C NREP REPITITIONS OF PATTERN PER LABEL. +C + NCHAR = 10 + IF (NREP .LT. 2) GO TO 119 + DO 118 J=1,10 + NCHAR = J + RCHAR = IWORK(J:J) + DO 117 K=2,NREP + NCHAR = NCHAR+10 + IWORK(NCHAR:NCHAR) = RCHAR + 117 CONTINUE + 118 CONTINUE + 119 CONTINUE +C +C PUT IN LABEL. +C + CALL ENCD (CONTR,ASH,ENCSCR,NCUSED,IOFFDT) + DO 120 J=1,NCUSED + NCHAR = NCHAR+1 + IWORK(NCHAR:NCHAR) = ENCSCR(J:J) + 120 CONTINUE + GO TO 122 +C +C SET UP MINOR LINE (UNLABELED). +C + 121 CONTINUE +C +C SET LINE INTENSITY TO LOW +C + CALL GSPLCI ( IRECMN ) + NCHAR = 10 + 122 CALL DASHDC ( IWORK(1:NCHAR),NCRT, ISIZEL ) +C +C +C DRAW ALL LINES AT THIS LEVEL. +C + CALL STLINE (Z,MX,NX,NY,CONTR) +C +C + 123 CONTINUE +C +C FIND RELATIVE MINIMUMS AND MAXIMUMS IF WANTED, AND MARK VALUES IF +C WANTED. +C + IF (NHI .EQ. 0) CALL MINMAX (Z,MX,NX,NY,ISIZEM,ASH,IOFFDT) + IF (NHI .GT. 0) CALL MINMAX (Z,MX,NX,NY,ISIZEP,-ASH,IOFFDT) + FPART = 1. + GO TO 127 + 124 CONTINUE + IWORK = 'CONSTANT FIELD' +C +NOAO +C WRITE( ENCSCR, '(G22.14)' ) GL + i = gl + call encode (22, '(g22.14)', encscr, i) +C -NOAO + DO 126 I=1,22 + IWORK(I+14:I+14) = ENCSCR(I:I) + 126 CONTINUE +C +C WRITE TITLE USING NORMALIZATION TRNS 0 +C + CALL GETUSV('LS',LSO) + CALL SETUSV('LS',1) + CALL GSELNT (0) +C +NOAO +C CALL WTSTR ( 0.09765, 0.48825, IWORK(1:36), 3, 0, -1 ) + CALL WTSTR ( x1+0.03, (y1+y2)/2.0, IWORK(1:36), 3, 0, -1 ) +C -NOAO +C +C RESTORE NORMALIZATION TRANS 1, LINE AND TEXT INTENSITY TO ORIGINAL +C + 127 IF (NSET.LE.0) THEN + CALL SET(VWPRT(1),VWPRT(2),VWPRT(3),VWPRT(4), + - WNDW(1),WNDW(2),WNDW(3),WNDW(4),IOLLS) + END IF + CALL GSPLCI ( IPLCI ) + CALL GSTXCI ( ITXCI ) +C +C SELECT ORIGINAL NORMALIZATION TRANS NUMBER NTORIG, AND RESTORE ASF +C + CALL GSELNT ( NTORIG ) + LASF(3) = LSV3 + LASF(10) = LSV10 + CALL GSASF ( LASF ) +C + RETURN +C +C + END + SUBROUTINE CLGEN (Z,MX,NX,NNY,CCLO,CHI,CINC,NLA,NLM,CL,NCL,ICNST) + SAVE + DIMENSION CL(NLM) ,Z(MX,NNY) + COMMON /CONRE1/ IOFFP ,SPVAL +C +C CLGEN PUTS THE VALUES OF THE CONTOUR LEVELS IN CL. +C VARIABLE NAMES MATCH THOSE IN CONREC, WITH THE FOLLOWING ADDITIONS. +C NCL -NUMBER OF CONTOUR LEVELS PUT IN CL. +C ICNST -FLAG TO TELL CONREC IF A CONSTANT FIELD WAS DETECTED. +C .ICNST=0 MEANS NON-CONSTANT FIELD. +C .ICNST NON-ZERO MEANS CONSTANT FIELD. +C +C TO PRODUCE NON-UNIFORM CONTOUR LEVEL SPACING, REPLACE THE CODE IN THIS +C SUBROUTINE WITH CODE TO PRODUCE WHATEVER SPACING IS DESIRED. +C + ICNST = 0 + NY = NNY + CLO = CCLO + GLO = CLO + HA = CHI + FANC = CINC + CRAT = NLA + IF (HA-GLO) 101,102,111 + 101 GLO = HA + HA = CLO + GO TO 111 + 102 IF (GLO .NE. 0.) GO TO 120 + GLO = Z(1,1) + HA = Z(1,1) + IF (IOFFP .EQ. 0) GO TO 107 + DO 106 J=1,NY + DO 105 I=1,NX + IF (Z(I,J) .EQ. SPVAL) GO TO 105 + GLO = Z(I,J) + HA = Z(I,J) + DO 104 JJ=J,NY + DO 103 II=1,NX + IF (Z(II,JJ) .EQ. SPVAL) GO TO 103 + GLO = AMIN1(Z(II,JJ),GLO) + HA = AMAX1(Z(II,JJ),HA) + 103 CONTINUE + 104 CONTINUE + GO TO 110 + 105 CONTINUE + 106 CONTINUE + GO TO 110 + 107 DO 109 J=1,NY + DO 108 I=1,NX + GLO = AMIN1(Z(I,J),GLO) + HA = AMAX1(Z(I,J),HA) + 108 CONTINUE + 109 CONTINUE + 110 IF (GLO .GE. HA) GO TO 119 + 111 IF (FANC) 112,113,114 + 112 CRAT = AMAX1(1.,-FANC) + 113 FANC = (HA-GLO)/CRAT + P = 10.**(IFIX(ALOG10(FANC)+5000.)-5000) + FANC = AINT(FANC/P)*P + 114 IF (CHI-CLO) 116,115,116 + 115 GLO = AINT(GLO/FANC)*FANC + HA = AINT(HA/FANC)*FANC*(1.+SIGN(1.E-6,HA)) + 116 DO 117 K=1,NLM + CC = GLO+FLOAT(K-1)*FANC + IF (CC .GT. HA) GO TO 118 + KK = K + CL(K) = CC + 117 CONTINUE + 118 NCL = KK + CCLO = CL(1) + CHI = CL(NCL) + CINC = FANC + RETURN + 119 ICNST = 1 + NCL = 1 + CCLO = GLO + RETURN + 120 CL(1) = GLO + NCL = 1 + RETURN + END + SUBROUTINE DRLINE (Z,L,MM,NN) + SAVE + DIMENSION Z(L,NN) +C +C THIS ROUTINE TRACES A CONTOUR LINE WHEN GIVEN THE BEGINNING BY STLINE. +C TRANSFORMATIONS CAN BE ADDED BY DELETING THE STATEMENT FUNCTIONS FOR +C FX AND FY IN DRLINE AND MINMAX AND ADDING EXTERNAL FUNCTIONS. +C X=1. AT Z(1,J), X=FLOAT(M) AT Z(M,J). X TAKES ON NON-INTEGER VALUES. +C Y=1. AT Z(I,1), Y=FLOAT(N) AT Z(I,N). Y TAKES ON NON-INTEGER VALUES. +C + COMMON /CONRE2/ IX ,IY ,IDX ,IDY , + 1 IS ,ISS ,NP ,CV , + 2 INX(8) ,INY(8) ,IR(80000) ,NR +c + noao: dimension of ir array in conre2 changed from 500 to 20000 6March87 +c + noao: dimension of ir array in conre2 changed from 20000 to 80000 6-93 + COMMON /CONRE1/ IOFFP ,SPVAL + COMMON /CONRE3/ IXBITS ,IYBITS + LOGICAL IPEN ,IPENO + DATA IPEN,IPENO/.TRUE.,.TRUE./ +C + FX(X,Y) = X + FY(X,Y) = Y + IXYPAK(IXX,IYY) = ISHIFT(IXX,IYBITS)+IYY + C(P1,P2) = (P1-CV)/(P1-P2) +C + M = MM + N = NN + IF (IOFFP .EQ. 0) GO TO 101 + ASSIGN 110 TO JUMP1 + ASSIGN 115 TO JUMP2 + GO TO 102 + 101 ASSIGN 112 TO JUMP1 + ASSIGN 117 TO JUMP2 + 102 IX0 = IX + IY0 = IY + IS0 = IS + IF (IOFFP .EQ. 0) GO TO 103 + IX2 = IX+INX(IS) + IY2 = IY+INY(IS) + IPEN = Z(IX,IY).NE.SPVAL .AND. Z(IX2,IY2).NE.SPVAL + IPENO = IPEN + 103 IF (IDX .EQ. 0) GO TO 104 + Y = IY + ISUB = IX+IDX + X = C(Z(IX,IY),Z(ISUB,IY))*FLOAT(IDX)+FLOAT(IX) + GO TO 105 + 104 X = IX + ISUB = IY+IDY + Y = C(Z(IX,IY),Z(IX,ISUB))*FLOAT(IDY)+FLOAT(IY) + 105 CALL FRSTD (FX(X,Y),FY(X,Y)) + 106 IS = IS+1 + IF (IS .GT. 8) IS = IS-8 + IDX = INX(IS) + IDY = INY(IS) + IX2 = IX+IDX + IY2 = IY+IDY + IF (ISS .NE. 0) GO TO 107 + IF (IX2.GT.M .OR. IY2.GT.N .OR. IX2.LT.1 .OR. IY2.LT.1) GO TO 120 + 107 IF (CV-Z(IX2,IY2)) 108,108,109 + 108 IS = IS+4 + IX = IX2 + IY = IY2 + GO TO 106 + 109 IF (IS/2*2 .EQ. IS) GO TO 106 + GO TO JUMP1,(110,112) + 110 ISBIG = IS+(8-IS)/6*8 + IX3 = IX+INX(ISBIG-1) + IY3 = IY+INY(ISBIG-1) + IX4 = IX+INX(ISBIG-2) + IY4 = IY+INY(ISBIG-2) + IPENO = IPEN + IF (ISS .NE. 0) GO TO 111 + IF (IX3.GT.M .OR. IY3.GT.N .OR. IX3.LT.1 .OR. IY3.LT.1) GO TO 120 + IF (IX4.GT.M .OR. IY4.GT.N .OR. IX4.LT.1 .OR. IY4.LT.1) GO TO 120 + 111 IPEN = Z(IX,IY).NE.SPVAL .AND. Z(IX2,IY2).NE.SPVAL .AND. + 1 Z(IX3,IY3).NE.SPVAL .AND. Z(IX4,IY4).NE.SPVAL + 112 IF (IDX .EQ. 0) GO TO 113 + Y = IY + ISUB = IX+IDX + X = C(Z(IX,IY),Z(ISUB,IY))*FLOAT(IDX)+FLOAT(IX) + GO TO 114 + 113 X = IX + ISUB = IY+IDY + Y = C(Z(IX,IY),Z(IX,ISUB))*FLOAT(IDY)+FLOAT(IY) + 114 GO TO JUMP2,(115,117) + 115 IF (.NOT.IPEN) GO TO 118 + IF (IPENO) GO TO 116 +C +C END OF LINE SEGMENT +C + CALL LASTD + CALL FRSTD (FX(XOLD,YOLD),FY(XOLD,YOLD)) +C +C CONTINUE LINE SEGMENT +C + 116 CONTINUE + 117 CALL VECTD (FX(X,Y),FY(X,Y)) + 118 XOLD = X + YOLD = Y + IF (IS .NE. 1) GO TO 119 + NP = NP+1 + IF (NP .GT. NR) GO TO 120 + IR(NP) = IXYPAK(IX,IY) + 119 IF (ISS .EQ. 0) GO TO 106 + IF (IX.NE.IX0 .OR. IY.NE.IY0 .OR. IS.NE.IS0) GO TO 106 +C +C END OF LINE +C + 120 CALL LASTD + RETURN + END + SUBROUTINE MINMAX (Z,L,MM,NN,ISSIZM,AASH,JOFFDT) +C +C THIS ROUTINE FINDS RELATIVE MINIMUMS AND MAXIMUMS. A RELATIVE MINIMUM +C (OR MAXIMUM) IS DEFINED TO BE THE LOWEST (OR HIGHEST) POINT WITHIN +C A CERTAIN NEIGHBORHOOD OF THE POINT. THE NEIGHBORHOOD USED HERE +C IS + OR - MN IN THE X DIRECTION AND + OR - NM IN THE Y DIRECTION. +C +C ORIGINATOR DAVID KENNISON +C + SAVE + CHARACTER*6 IA + DIMENSION Z(L,NN) +C +C +C + COMMON /CONRE1/ IOFFP ,SPVAL + COMMON /CONRE5/ SCLY +C + FX(X,Y) = X + FY(X,Y) = Y +C + M = MM + N = NN +C +C SET UP SCALING FOR LABELS +C + SIZEM = (ISSIZM + 1)*256*SCLY + ISIZEM = ISSIZM +C + ASH = ABS(AASH) + IOFFDT = JOFFDT +C + IF (AASH .LT. 0.0) GO TO 128 +C + MN = MIN0(15,MAX0(2,IFIX(FLOAT(M)/8.))) + NM = MIN0(15,MAX0(2,IFIX(FLOAT(N)/8.))) + NM1 = N-1 + MM1 = M-1 +C +C LINE LOOP FOLLOWS - THE COMPLETE TWO-DIMENSIONAL TEST FOR A MINIMUM OR +C MAXIMUM OF THE FIELD IS ONLY PERFORMED FOR POINTS WHICH ARE MINIMA OR +C MAXIMA ALONG SOME LINE - FINDING THESE CANDIDATES IS MADE EFFICIENT BY +C USING A COUNT OF CONSECUTIVE INCREASES OR DECREASES OF THE FUNCTION +C ALONG THE LINE +C + DO 127 JP=2,NM1 +C + IM = MN-1 + IP = -1 + GO TO 126 +C +C CONTROL RETURNS TO STATEMENT 10 AS LONG AS THE FUNCTION IS INCREASING +C ALONG THE LINE - WE SEEK A POSSIBLE MAXIMUM +C + 101 IP = IP+1 + AA = AN + IF (IP .EQ. MM1) GO TO 104 + AN = Z(IP+1,JP) + IF (IOFFP.NE.0 .AND. AN.EQ.SPVAL) GO TO 125 + IF (AA-AN) 102,103,104 + 102 IM = IM+1 + GO TO 101 + 103 IM = 0 + GO TO 101 +C +C FUNCTION DECREASED - TEST FOR MAXIMUM ON LINE +C + 104 IF (IM .GE. MN) GO TO 106 + IS = MAX0(1,IP-MN) + IT = IP-IM-1 + IF (IS .GT. IT) GO TO 106 + DO 105 II=IS,IT + IF (AA .LE. Z(II,JP)) GO TO 112 + 105 CONTINUE + 106 IS = IP+2 + IT = MIN0(M,IP+MN) + IF (IS .GT. IT) GO TO 109 + DO 108 II=IS,IT + IF (IOFFP.EQ.0 .OR. Z(II,JP).NE.SPVAL) GO TO 107 + IP = II-1 + GO TO 125 + 107 IF (AA .LE. Z(II,JP)) GO TO 112 + 108 CONTINUE +C +C WE HAVE MAXIMUM ON LINE - DO TWO-DIMENSIONAL TEST FOR MAXIMUM OF FIELD +C + 109 JS = MAX0(1,JP-NM) + JT = MIN0(N,JP+NM) + IS = MAX0(1,IP-MN) + IT = MIN0(M,IP+MN) + DO 111 JK=JS,JT + IF (JK .EQ. JP) GO TO 111 + DO 110 IK=IS,IT + IF (Z(IK,JK).GE.AA .OR. + 1 (IOFFP.NE.0 .AND. Z(IK,JK).EQ.SPVAL)) GO TO 112 + 110 CONTINUE + 111 CONTINUE +C + X = FLOAT(IP) + Y = FLOAT(JP) + CALL WTSTR ( FX(X,Y),FY(X,Y),'H',ISIZEM,0,0 ) + CALL FL2INT ( FX(X,Y),FY(X,Y),IFX,IFY ) +C +C SCALE TO USER SET RESOLUTION +C + IFY = IFY*SCLY + CALL ENCD (AA,ASH,IA,NC,IOFFDT) + MY = IFY - SIZEM + TMY = CPUY ( MY ) + CALL WTSTR ( FX(X,Y),TMY,IA(1:NC),ISIZEM,0,0 ) + 112 IM = 1 + IF (IP-MM1) 113,127,127 +C +C CONTROL RETURNS TO STATEMENT 20 AS LONG AS THE FUNCTION IS DECREASING +C ALONG THE LINE - WE SEEK A POSSIBLE MINIMUM +C + 113 IP = IP+1 + AA = AN + IF (IP .EQ. MM1) GO TO 116 + AN = Z(IP+1,JP) + IF (IOFFP.NE.0 .AND. AN.EQ.SPVAL) GO TO 125 + IF (AA-AN) 116,115,114 + 114 IM = IM+1 + GO TO 113 + 115 IM = 0 + GO TO 113 +C +C FUNCTION INCREASED - TEST FOR MINIMUM ON LINE +C + 116 IF (IM .GE. MN) GO TO 118 + IS = MAX0(1,IP-MN) + IT = IP-IM-1 + IF (IS .GT. IT) GO TO 118 + DO 117 II=IS,IT + IF (AA .GE. Z(II,JP)) GO TO 124 + 117 CONTINUE + 118 IS = IP+2 + IT = MIN0(M,IP+MN) + IF (IS .GT. IT) GO TO 121 + DO 120 II=IS,IT + IF (IOFFP.EQ.0 .OR. Z(II,JP).NE.SPVAL) GO TO 119 + IP = II-1 + GO TO 125 + 119 IF (AA .GE. Z(II,JP)) GO TO 124 + 120 CONTINUE +C +C WE HAVE MINIMUM ON LINE - DO TWO-DIMENSIONAL TEST FOR MINIMUM OF FIELD +C + 121 JS = MAX0(1,JP-NM) + JT = MIN0(N,JP+NM) + IS = MAX0(1,IP-MN) + IT = MIN0(M,IP+MN) + DO 123 JK=JS,JT + IF (JK .EQ. JP) GO TO 123 + DO 122 IK=IS,IT + IF (Z(IK,JK).LE.AA .OR. + 1 (IOFFP.NE.0 .AND. Z(IK,JK).EQ.SPVAL)) GO TO 124 + 122 CONTINUE + 123 CONTINUE +C + X = FLOAT(IP) + Y = FLOAT(JP) + CALL WTSTR ( FX(X,Y),FY(X,Y),'L',ISIZEM,0,0 ) + CALL FL2INT( FX(X,Y),FY(X,Y),IFX,IFY ) + IFY = SCLY*IFY + CALL ENCD (AA,ASH,IA,NC,IOFFDT) + MY = IFY - SIZEM + TMY = CPUY ( MY ) + CALL WTSTR ( FX(X,Y),TMY,IA(1:NC),ISIZEM,0,0 ) + 124 IM = 1 + IF (IP-MM1) 101,127,127 +C +C SKIP SPECIAL VALUES ON LINE +C + 125 IM = 0 + 126 IP = IP+1 + IF (IP .GE. MM1) GO TO 127 + IF (IOFFP.NE.0 .AND. Z(IP+1,JP).EQ.SPVAL) GO TO 125 + IM = IM+1 + IF (IM .LE. MN) GO TO 126 + IM = 1 + AN = Z(IP+1,JP) + IF (Z(IP,JP)-AN) 101,103,113 +C + 127 CONTINUE +C + RETURN +C +C ****************************** ENTRY PNTVAL ************************** +C ENTRY PNTVAL (Z,L,MM,NN,ISSIZM,AASH,JOFFDT) +C + 128 CONTINUE + II = (M-1+24)/24 + JJ = (N-1+48)/48 + NIQ = 1 + NJQ = 1 + DO 130 J=NJQ,N,JJ + Y = J + DO 129 I=NIQ,M,II + X = I + ZZ = Z(I,J) + IF (IOFFP.NE.0 .AND. ZZ.EQ.SPVAL) GO TO 129 + CALL ENCD (ZZ,ASH,IA,NC,IOFFDT) + CALL WTSTR (FX(X,Y),FY(X,Y),IA(1:NC),ISIZEM,0,0 ) + 129 CONTINUE + 130 CONTINUE + RETURN + END + SUBROUTINE REORD (CL,NCL,C1,MARK,NMG) + SAVE + DIMENSION CL(NCL) ,C1(NCL) +C +C THIS ROUTINE PUTS THE MAJOR (LABELED) LEVELS IN THE BEGINNING OF CL +C AND THE MINOR (UNLABELED) LEVELS IN END OF CL. THE NUMBER OF MAJOR +C LEVELS IS RETURNED IN MARK. C1 IS USED AS A WORK SPACE. NMG IS THE +C NUMBER OF MINOR GAPS (ONE MORE THAN THE NUMBER OF MINOR LEVELS BETWEEN +C MAJOR LEVELS). +C + NL = NCL + IF (NL.LE.4 .OR. NMG.LE.1) GO TO 113 + NML = NMG-1 + IF (NL .LE. 10) NML = 1 +C +C CHECK FOR ZERO OR OTHER NICE NUMBER FOR A MAJOR LINE +C + NMLP1 = NML+1 + DO 101 I=1,NL + ISAVE = I + IF (CL(I) .EQ. 0.) GO TO 104 + 101 CONTINUE + L = NL/2 + L = ALOG10(ABS(CL(L)))+1. + Q = 10.**L + DO 103 J=1,3 + Q = Q/10. + DO 102 I=1,NL + ISAVE = I + IF (AMOD(ABS(CL(I)+1.E-9*CL(I))/Q,FLOAT(NMLP1)) .LE. .0001) + 1 GO TO 104 + 102 CONTINUE + 103 CONTINUE + ISAVE = NL/2 +C +C PUT MAJOR LEVELS IN C1 +C + 104 ISTART = MOD(ISAVE,NMLP1) + IF (ISTART .EQ. 0) ISTART = NMLP1 + NMAJL = 0 + DO 105 I=ISTART,NL,NMLP1 + NMAJL = NMAJL+1 + C1(NMAJL) = CL(I) + 105 CONTINUE + MARK = NMAJL + L = NMAJL +C +C PUT MINOR LEVELS IN C1 +C + IF (ISTART .EQ. 1) GO TO 107 + DO 106 I=2,ISTART + ISUB = L+I-1 + C1(ISUB) = CL(I-1) + 106 CONTINUE + 107 L = NMAJL+ISTART-1 + DO 109 I=2,NMAJL + DO 108 J=1,NML + L = L+1 + ISUB = ISTART+(I-2)*NMLP1+J + C1(L) = CL(ISUB) + 108 CONTINUE + 109 CONTINUE + NLML = NL-L + IF (L .EQ. NL) GO TO 111 + DO 110 I=1,NLML + L = L+1 + C1(L) = CL(L) + 110 CONTINUE +C +C PUT REORDERED ARRAY BACK IN ORIGINAL PLACE +C + 111 DO 112 I=1,NL + CL(I) = C1(I) + 112 CONTINUE + RETURN + 113 MARK = NL + RETURN + END + SUBROUTINE STLINE (Z,LL,MM,NN,CONV) + SAVE + DIMENSION Z(LL,NN) +C +C THIS ROUTINE FINDS THE BEGINNINGS OF ALL CONTOUR LINES AT LEVEL CONV. +C FIRST THE EDGES ARE SEARCHED FOR LINES INTERSECTING THE EDGE (OPEN +C LINES) THEN THE INTERIOR IS SEARCHED FOR LINES WHICH DO NOT INTERSECT +C THE EDGE (CLOSED LINES). BEGINNINGS ARE STORED IN IR TO PREVENT RE- +C TRACING OF LINES. IF IR IS FILLED, THE SEARCH IS STOPPED FOR THIS +C CONV. +C + COMMON /CONRE2/ IX ,IY ,IDX ,IDY , + 1 IS ,ISS ,NP ,CV , + 2 INX(8) ,INY(8) ,IR(80000) ,NR +c + noao: dimension of ir array in conre2 changed from 500 to 20000 6March87 +c + noao: dimension of ir array in conre2 changed from 20000 to 80000 6-93 + COMMON /CONRE3/ IXBITS ,IYBITS +C +C +C +C +C +C + IXYPAK(IXX,IYY) = ISHIFT(IXX,IYBITS)+IYY +C + L = LL + M = MM + N = NN + CV = CONV + NP = 0 + ISS = 0 + DO 102 IP1=2,M + I = IP1-1 + IF (Z(I,1).GE.CV .OR. Z(IP1,1).LT.CV) GO TO 101 + IX = IP1 + IY = 1 + IDX = -1 + IDY = 0 + IS = 1 + CALL DRLINE (Z,L,M,N) + 101 IF (Z(IP1,N).GE.CV .OR. Z(I,N).LT.CV) GO TO 102 + IX = I + IY = N + IDX = 1 + IDY = 0 + IS = 5 + CALL DRLINE (Z,L,M,N) + 102 CONTINUE + DO 104 JP1=2,N + J = JP1-1 + IF (Z(M,J).GE.CV .OR. Z(M,JP1).LT.CV) GO TO 103 + IX = M + IY = JP1 + IDX = 0 + IDY = -1 + IS = 7 + CALL DRLINE (Z,L,M,N) + 103 IF (Z(1,JP1).GE.CV .OR. Z(1,J).LT.CV) GO TO 104 + IX = 1 + IY = J + IDX = 0 + IDY = 1 + IS = 3 + CALL DRLINE (Z,L,M,N) + 104 CONTINUE + ISS = 1 + DO 108 JP1=3,N + J = JP1-1 + DO 107 IP1=2,M + I = IP1-1 + IF (Z(I,J).GE.CV .OR. Z(IP1,J).LT.CV) GO TO 107 + IXY = IXYPAK(IP1,J) + IF (NP .EQ. 0) GO TO 106 + DO 105 K=1,NP + IF (IR(K) .EQ. IXY) GO TO 107 + 105 CONTINUE + 106 NP = NP+1 + IF (NP .GT. NR) THEN +C +C THIS PRINTS AN ERROR MESSAGE IF THE LOCAL ARRAY IR IN SUBROUTINE +C STLINE HAS AN OVERFLOW +C THIS MESSAGE IS WRITTEN BOTH ON THE FRAME AND ON THE STANDARD ERROR +C UNIT +C +C +NOAO - Message is written only to stderr, not to the plotting frame. +C Error is written with uliber, not FTN write statement. +C + call uliber (1, 'STLINE (CONREC) - WORK ARRAY OVERFLOW', 80) + call uliber (1,'STLINE - ***WARNING -- PICTURE INCOMPLETE***',80) +C IUNIT = I1MACH(4) +C WRITE(IUNIT,1000) +C1000 FORMAT( +C 1' WARNING FROM ROUTINE STLINE IN CONREC--WORK ARRAY OVERFLOW') +C CALL GETSET(VXA,VXB,VYA,VYB,XA,XB,YA,YB,LTYPE) +C Y = (YB - YA) / 2. +C X = (XB - XA) / 2. +C CALL PWRIT(X,Y, +C 1'**WARNING--PICTURE INCOMPLETE**', +C 2 31,3,0,0) +C Y = Y * .7 +C CALL PWRIT(X,Y, +C 1'WORK ARRAY OVERFLOW IN STLINE', +C 2 29,3,0,0) +C -NOAO + RETURN + ENDIF + IR(NP) = IXY + IX = IP1 + IY = J + IDX = -1 + IDY = 0 + IS = 1 + CALL DRLINE (Z,L,M,N) + 107 CONTINUE + 108 CONTINUE + RETURN + END + SUBROUTINE CALCNT (Z,M,N,A1,A2,A3,I1,I2,I3) +C +C THIS ENTRY POINT IS FOR USERS WHO ARE TOO LAZY TO SWITCH OLD DECKS +C TO THE NEW CALLING SEQUENCE. +C + DIMENSION Z(M,N) + SAVE +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','CONREC','CALCNT','VERSION 01') +C + CALL CONREC (Z,M,M,N,A1,A2,A3,I1,I2,-IABS(I3)) + RETURN + END + SUBROUTINE EZCNTR (Z,M,N) +C +C CONTOURING VIA SHORTEST POSSIBLE ARGUMENT LIST +C ASSUMPTIONS -- +C ALL OF THE ARRAY IS TO BE CONTOURED, +C CONTOUR LEVELS ARE PICKED INTERNALLY, +C CONTOURING ROUTINE PICKS SCALE FACTORS, +C HIGHS AND LOWS ARE MARKED, +C NEGATIVE LINES ARE DRAWN WITH A DASHED LINE PATTERN, +C EZCNTR CALLS FRAME AFTER DRAWING THE CONTOUR MAP. +C IF THESE ASSUMPTIONS ARE NOT MET, USE CONREC. +C +C ARGUMENTS +C Z ARRAY TO BE CONTOURED +C M FIRST DIMENSION OF Z +C N SECOND DIMENSION OF Z +C + SAVE + DIMENSION Z(M,N) + DATA NSET,NHI,NDASH/0,0,682/ +C +C 682=1252B +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','CONREC','EZCNTR','VERSION 01') +C + CALL CONREC (Z,M,M,N,0.,0.,0.,NSET,NHI,-NDASH) +C +NOAO - EZCNTR no longer calls frame. +C CALL FRAME +C -NOAO + RETURN + END +C +C REVISION HISTORY--- +C +C JANUARY 1980 ADDED REVISION HISTORY AND CHANGED LIBRARY NAME +C FROM CRAYLIB TO PORTLIB FOR MOVE TO PORTLIB +C +C MAY 1980 ARRAYS IWORK AND ENCSCR, PREVIOUSLY TOO SHORT FOR +C SHORT-WORD-LENGTH MACHINES, LENGTHENED. SOME +C DOCUMENTATION CLARIFIED AND CORRECTED. +C +C JUNE 1984 CONVERTED TO FORTRAN 77 AND TO GKS +C +C JUNE 1985 ERROR HANDLING LINES ADDED; IF OVERFLOW HAPPENS TO +C WORK ARRAY IN STLINE, A WARNING MESSAGE IS WRITTEN +C BOTH ON PLOT FRAME AND ON STANDARD ERROR MESSAGE. +C------------------------------------------------------------------- +C diff --git a/sys/gio/ncarutil/dashbd.f b/sys/gio/ncarutil/dashbd.f new file mode 100644 index 00000000..cf499bc2 --- /dev/null +++ b/sys/gio/ncarutil/dashbd.f @@ -0,0 +1,143 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +c +noao: block data changed to run time initialization. Logical param +c "first" added, so initialization doesn't occur more than once. +c BLOCKDATA DASHBD + subroutine dashbd +C +C DASHBD IS USED TO INITIALIZE VARIABLES IN NAMED COMMON. +C + logical first +c + COMMON /DASHD1/ ISL, L, ISIZE, IP(100), NWDSM1, IPFLAG(100) + 1 ,MNCSTR, IGP +C + COMMON /FDFLAG/ IFLAG +C + COMMON /DDFLAG/ IFCFLG +C + COMMON /DCFLAG/ IFSTFL +C + COMMON /DFFLAG/ IFSTF2 +C + COMMON /CFFLAG/ IVCTFG +C + COMMON /DSAVE3/ IXSTOR,IYSTOR +C + COMMON /DSAVE5/ XSAVE(70), YSAVE(70), XSVN, YSVN, XSV1, YSV1, + 1 SLP1, SLPN, SSLP1, SSLPN, N, NSEG +C + COMMON /SMFLAG/ IOFFS +C + COMMON/INTPR/IPAU,FPART,TENSN,NP,SMALL,L1,ADDLR,ADDTB,MLLINE, + 1 ICLOSE +C + SAVE + data first /.true./ + if (.not. first) return + first = .false. + +C IFSTFL CONTROLS THAT FRSTD IS CALLED BEFORE VECTD IS CALLED (IN CFVLD) +C WHENEVER DASHDB OR DASHDC HAS BEEN CALLED. +C +c DATA IFSTFL /1/ + IFSTFL = 1 +C +C IVCTFG INDICATES IF VECTD IS BEING CALLED OR LASTD (IN CFVLD) +C +c DATA IVCTFG /1/ + IVCTFG = 1 +C +C ISL IS A FLAG FOR AN ALL SOLID PATTERN (+1) OR AN ALL GAP PATTERN (-1) +C +c DATA ISL /1/ + ISL = 1 +C +C IGP IS AN INTERNAL PARAMETER. IT IS DESCRIBED IN THE DOCUMENTATION +C TO THE DASHED LINE PACKAGE. +C +c DATA IGP /9/ + IGP = 9 +C +C MNCSTR IS THE MAXIMUM NUMBER OF CHARACTERS ALLOWED IN A HOLLERITH +C STRING PASSED TO DASHDC. +C +c DATA MNCSTR /15/ + MNCSTR = 15 +C +C IOFFS IS AN INTERNAL PARAMETER. +C IOFFS IS USED IN FDVDLD AND DRAWPV. +C +c DATA IOFFS /0/ + IOFFS = 0 +C +C INTERNAL PARAMETERS +C +c DATA IPAU/3/ + IPAU = 3 +c DATA FPART/1./ + FPART = 1. +c DATA TENSN/2.5/ + TENSN = 2.5 +c DATA NP/150/ + NP = 150 +c DATA SMALL/128./ + SMALL = 128. +c DATA L1/70/ + L1 = 70 +c DATA ADDLR/2./ + ADDLR = 2. +c DATA ADDTB/2./ + ADDTB = 2. +c DATA MLLINE/384/ + MLLINE = 384 +c DATA ICLOSE/6/ + ICLOSE = 6 +C +C IFSTF2 IS A FLAG TO CONTROL THAT FRSTD IS CALLED BEFORE VECTD IS +C CALLED (IN SUBROUTINE FDVDLD), WHENEVER DASHDB OR DASHDC +C HAS BEEN CALLED. +C +c DATA IFSTF2 /1/ + IFSTF2 = 1 +C +C IFLAG CONTROLS IF LASTD CAN BE CALLED DIRECTLY OR IF IT WAS JUST +C CALLED FROM BY VECTD SO THAT THIS CALL CAN BE IGNORED. +C +c DATA IFLAG /1/ + IFLAG = 1 +C +C IFCFLG IS THE FIRST CALL FLAG FOR SUBROUTINES DASHDB AND DASHDC. +C 1 = FIRST CALL TO DASHDB OR DASHDC. +C 2 = DASHDB OR DASHDC HAS BEEN CALLED BEFORE. +C +c DATA IFCFLG /1/ + IFCFLG = 1 +C +C IXSTOR AND IYSTOR CONTAIN THE CURRENT PEN POSITION. THEY ARE +C INITIALIZED TO AN IMPOSSIBLE VALUE. +C +c DATA IXSTOR,IYSTOR /-9999,-9999/ + IXSTOR = -9999 + IYSTOR = -9999 +C +C SLP1 AND SLPN ARE INITIALIZED TO AVOID THAT THEY ARE PASSED AS ACTUAL +C PARAMETERS FROM FDVDLD TO KURV1S WITHOUT BEING DEFINED. +C +c DATA SLP1,SLPN /-9999.,-9999./ + SLP1 = -9999. + SLPN = -9999. +c -noao +C + END diff --git a/sys/gio/ncarutil/dashsmth.f b/sys/gio/ncarutil/dashsmth.f new file mode 100644 index 00000000..2fe25185 --- /dev/null +++ b/sys/gio/ncarutil/dashsmth.f @@ -0,0 +1,1224 @@ + SUBROUTINE FDVDLD (IENTRY,IIX,IIY) +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C SOFTWARE DASHED LINE PACKAGE WITH CHARACTER CAPABILITY AND SMOOTHING +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE DASHSMTH IS A SOFTWARE DASHED LINE PACKAGE WITH +C SMOOTHING CAPABILITIES. DASHSMTH IS DASHCHAR +C WITH SMOOTHING FEATURES ADDED. +C +C USAGE FIRST, EITHER +C CALL DASHDB (IPAT) +C WHERE IPAT IS A 16-BIT DASH PATTERN AS +C DESCRIBED IN THE SUBROUTINE DASHDB (SEE +C DASHLINE DOCUMENTATION), OR +C CALL DASHDC (IPAT,JCRT,JSIZE) +C AS DESCRIBED BELOW. +C +C THEN, CALL ANY OF THE FOLLOWING: +C CALL CURVED (X,Y,N) +C CALL FRSTD (X,Y) +C CALL VECTD (X,Y) +C CALL LASTD +C +C LASTD IS CALLED ONLY AFTER THE LAST +C POINT OF A LINE HAS BEEN PROCESSED IN VECTD. +C +C THE FOLLOWING MAY ALSO BE CALLED, BUT NO +C SMOOTHING WILL RESULT: +C CALL LINED (XA,YA,XB,YB) +C +C +C ARGUMENTS IPAT +C ON INPUT A CHARACTER STRING OF ARBITRARY LENGTH +C TO DASHDC (60 CHARACTERS SEEMS TO BE A PRACTICAL +C LIMIT) WHICH SPECIFIES THE DASH PATTERN +C TO BE USED. A DOLLAR SIGN IN IPAT +C INDICATES SOLID; AN APOSTROPHE INDICATES +C A GAP; BLANKS ARE IGNORED. ANY CHARACTER +C IN IPAT WHICH IS NOT A DOLLAR SIGN, +C APOSTROPHE, OR BLANK IS CONSIDERED TO BE +C PART OF A LINE LABEL. EACH LINE LABEL +C CAN BE AT MOST 15 CHARACTERS IN LENGTH. +C SUFFICIENT WHITE SPACE IS RESERVED IN THE +C DASHED LINE FOR WRITING LINE LABELS. +C +C JCRT +C THE LENGTH IN PLOTTER ADDRESS UNITS PER +C $ OR APOSTROPHE. +C +C JSIZE +C IS THE SIZE OF THE PLOTTED CHARACTERS: +C . IF BETWEEN 0 AND 3 , IT IS 1., 1.5, 2. +C AND 3. TIMES AN 8 PLOTTER ADDRESS UNIT +C WIDTH. +C . IF GREATER THAN 3, IT IS THE CHARACTER +C WIDTH IN PLOTTER ADDRESS UNITS. +C +C +C ARGUMENTS TO CURVED(X,Y,N) +C OTHER LINE-DRAWING X AND Y ARE ARRAYS OF WORLD COORDINATE VALUES +C ROUTINES OF LENGTH N OR GREATER. LINE SEGMENTS OBEYING +C THE SPECIFIED DASH PATTERN ARE DRAWN TO +C CONNECT THE N POINTS. +C +C FRSTD(X,Y) +C THE CURRENT PEN POSITION IS SET TO +C THE WORLD COORDINATE VALUE (X,Y) +C +C VECTD(X,Y) +C A LINE SEGMENT IS DRAWN BETWEEN THE +C WORLD COORDINATE VALUE (X,Y) AND THE +C MOST RECENT PEN POSITION. (X,Y) THEN +C BECOMES THE MOST RECENT PEN POSITION. +C +C LINED(XA,XB,YA,YB) +C A LINE IS DRAWN BETWEEN WORLD COORDINATE +C VALUES (XA,YA) AND (XB,YB). +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED FOR ALL ROUTINES. +C +C NOTE WHEN USING FRSTD AND VECTD, LASTD MUST BE +C CALLED (NO ARGUMENTS NEEDED). LASTD SETS UP +C THE CALLS TO THE SMOOTHING ROUTINES KURV1S AND +C KURV2S. +C +C WHEN SWITCHING FROM THE REGULAR PLOTTING +C ROUTINES TO A DASHED LINE PACKAGE THE FIRST +C CALL SHOULD NOT BE TO VECTD. +C +C ENTRY POINTS DASHDB, DASHDC, CURVED, FRSTD, VECTD, LINED, +C RESET, LASTD, KURV1S, KURV2S, CFVLD, FDVDLD, +C DRAWPV, DASHBD +C +C COMMON BLOCKS INTPR, DASHD1, DASHD2, DDFLAG, DCFLAG, DSAVE1, +C DSAVE2, DSAVE3, DSAVE5, CFFLAG, SMFLAG, DFFLAG, +C FDFLAG +C +C REQUIRED LIBRARY THE ERPRT77 PACKAGE AND THE SPPS. +C ROUTINES +C +C I/O PLOTS SOLID OR DASHED LINES, POSSIBLY WITH +C CHARACTERS AT INTERVALS IN THE LINE. +C THE LINES MAY ALSO BE SMOOTHED. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C HISTORY WRITTEN IN OCTOBER 1973. +C MADE PORTABLE IN SEPTEMBER 1977 FOR USE +C WITH ALL MACHINES WHICH +C SUPPORT PLOTTERS WITH UP TO 15 BIT RESOLUTION. +C CONVERTED TO FORTRAN77 AND GKS IN JUNE, 1984. +C +C ALGORITHM POINTS FOR EACH LINE +C SEGMENT ARE PROCESSED AND PASSED TO THE +C ROUTINES, KURV1S AND KURV2S, WHICH COMPUTE +C SPLINES UNDER TENSION PASSING THROUGH THESE +C POINTS. NEW POINTS ARE GENERATED BETWEEN THE +C GIVEN POINTS, RESULTING IN SMOOTH LINES. +C +C ACCURACY PLUS OR MINUS .5 PLOTTER ADDRESS UNITS PER CALL. +C THERE IS NO CUMULATIVE ERROR. +C +C TIMING ABOUT THREE TIMES AS LONG AS DASHCHAR. +C +C +C +C +C +C +C +C +C*********************************************************************** +C +C FDVDLD RECEIVES IN ITS ARGUMENTS THE POINTS TO BE PROCESSED FOR A +C LINE SEGMENT. IT PASSES THESE POINTS TO THE ROUTINES KURV1S AND KURV2S +C WHICH COMPUTE SPLINES UNDER TENSION PASSING THROUGH THESE POINTS. +C FDVDLD THEN CALLS CFVLD TO CONNECT THE POINTS GENERATED IN KURV2S. +C + DIMENSION XP(70), YP(70), TEMP(70) +C +C THE VARIABLES IN DSAVE5 HAVE TO BE SAVED FOR THE NEXT CALL TO FDVDLD. +C + COMMON /DSAVE5/ XSAVE(70), YSAVE(70), XSVN, YSVN, XSV1, YSV1, + 1 SLP1, SLPN, SSLP1, SSLPN, N, NSEG +C +C IOFFS IS AN INTERNAL PARAMETER. IT IS INITIALIZED IN DASHBD AND +C REFERENCED IN FDVDLD AND DRAWPV. +C + COMMON /SMFLAG/ IOFFS +C +C IFSTF2 IS A FLAG TO CONTROL THAT FRSTD IS CALLED BEFORE VECTD IS +C CALLED. +C + COMMON /DFFLAG/ IFSTF2 +C +C IFLAG CONTROLS IF LASTD CAN BE CALLED DIRECTLY OR IF IT WAS JUST +C CALLED FROM BY VECTD SO THAT THIS CALL CAN BE IGNORED. +C + COMMON /FDFLAG/ IFLAG +C +C NOTE THAT THIS IFSTF2 FLAG CANNOT BE IDENTICAL TO THE IFSTFL FLAG +C IN THE ROUTINE CFVLD, BECAUSE A CALL TO THE FRSTD ENTRY OF FDVDLD DOES +C NOT ELIMINATE THE NECESSITY OF A CALL TO THE FRSTD ENTRY OF CFVLD, +C AND REVERSE. +C + COMMON/INTPR/IPAU,FPART,TENSN,NP,SMALL,L1,ADDLR,ADDTB,MLLINE, + 1 ICLOSE + SAVE +C +C +C OTHER CONSTANTS. +C + DATA PI /3.14159265358/ + DATA IDUMMY /0/ +C +C + GO TO (10,15,35),IENTRY +C +C ************************************* +C +C ENTRY FRSTD (XX,YY) +C + 10 DEG = 180./PI +C + MX = IIX + MY = IIY + IFSTF2 = 0 + SSLP1 = 0.0 + SSLPN = 0.0 + XSVN = 0.0 + YSVN = 0.0 + IF (IOFFS .GE. 1) CALL CFVLD (1,MX,MY) + IF (IOFFS .GE. 1) RETURN +C +C INITIALIZE THE POINT AND SEGMENT COUNTER +C N COUNTS THE NUMBER OF POINTS/SEGMENT +C + N = 0 +C +C NSEG = 0 FIRST SEGMENT +C NSEG = 1 MORE THAN ONE SEGMENT +C + NSEG = 0 +C +C SAVE THE X,Y COORDINATES OF THE FIRST POINT +C XSV1 CONTAINS THE X COORDINATE OF THE FIRST POINT +C OF A LINE +C YSV1 CONTAINS THE Y COORDINATE OF THE FIRST POINT +C OF A LINE +C + XSV1 = MX + YSV1 = MY + GO TO 30 +C +C ************************************* +C +C ENTRY VECTD (XX,YY) +C + 15 CONTINUE +C +C TEST FOR PREVIOUS FRSTD CALL +C + IF (IFSTF2 .EQ. 0) GO TO 20 +C +C INFORM USER - NO PREVIOUS CALL TO FRSTD. TREAT CALL AS FRSTD CALL. +C + CALL SETER(' FDVDLD- VECTD CALL OCCURS BEFORE A CALL TO FRSTD.', + - 1,1) + GO TO 10 + 20 MX = IIX + MY = IIY +C +C VECTD SAVES THE X,Y COORDINATES OF THE ACCEPTED +C POINTS ON A LINE SEGMENT +C + IF (IOFFS .GE. 1) CALL CFVLD (2,MX,MY) + IF (IOFFS .GE. 1) RETURN +C +C IF THE NEW POINT IS TOO CLOSE TO THE PREVIOUS POINT, IGNORE IT +C + IF (ABS(FLOAT(IFIX(XSVN)-MX))+ABS(FLOAT(IFIX(YSVN)-MY)) .LT. + 1 SMALL) RETURN + IFLAG = 0 + 30 N = N+1 +C +C SAVE THE X,Y COORDINATES OF EACH POINT OF THE SEGMENT +C XSAVE THE ARRAY OF X COORDINATES OF LINE SEGMENT +C YSAVE THE ARRAY OF Y COORDINATES OF LINE SEGMENT +C + XSAVE(N) = MX + YSAVE(N) = MY + XSVN = XSAVE(N) + YSVN = YSAVE(N) + IF (N .GE. L1-1) GO TO 40 + RETURN +C +C ************************************* +C +C ENTRY LASTD +C + 35 CONTINUE + IF (IFSTF2 .NE. 0) RETURN + IFSTF2 = 1 +C +C LASTD CHECKS FOR PERIODIC LINES AND SETS UP +C THE CALLS TO KURV1S AND KURV2S +C + IF (IOFFS .GE. 1) CALL CFVLD (3,IDUMMY,IDUMMY) + IF (IOFFS .GE. 1) RETURN +C +C IFLAG = 0 OK TO CALL LASTD DIRECTLY +C IFLAG = 1 LASTD WAS JUST CALLED FROM BY VECTD +C IGNORE CALL TO LASTD +C + IF (IFLAG .EQ. 1) RETURN +C +C COMPARE THE LAST POINT OF SEGMENT WITH FIRST POINT OF LINE +C + 40 IFLAG = 1 +C +C IPRD = 0 PERIODIC LINE +C IPRD = 1 NON-PERIODIC LINE +C + IPRD = 1 + IF (ABS(XSV1-XSVN)+ABS(YSV1-YSVN) .LT. SMALL) IPRD = 0 +C +C TAKE CARE OF THE CASE OF ONLY TWO DISTINCT P0INTS ON A LINE +C + IF (NSEG .GE. 1) GO TO 60 + IF (N-2) 150,140,50 + 50 IF (N .GE. 4) GO TO 60 +C + IF (IPRD .NE. 0) GO TO 60 + DX = XSAVE(2)-XSAVE(1) + DY = YSAVE(2)-YSAVE(1) + SLOPE = ATAN2(DY,DX)*DEG+90. + IF (SLOPE .GE. 360.) SLOPE = SLOPE-360. + IF (SLOPE .LE. 0.) SLOPE = SLOPE+360. + SLP1 = SLOPE + SLPN = SLOPE + ISLPSW = 0 + SIGMA = TENSN + GO TO 100 + 60 SIGMA = TENSN + IF (IPRD .GE. 1) GO TO 80 + IF (NSEG .GE. 1) GO TO 70 +C +C SET UP FLAGS FOR A 1 SEGMENT, PERIODIC LINE +C + ISLPSW = 4 + XSAVE(N) = XSV1 + YSAVE(N) = YSV1 + GO TO 100 +C +C SET UP FLAGS FOR AN N-SEGMENT, PERIODIC LINE +C + 70 SLP1 = SSLPN + SLPN = SSLP1 + ISLPSW = 0 + GO TO 100 + 80 IF (NSEG .GE. 1) GO TO 90 +C +C SET UP FLAGS FOR THE 1ST SEGMENT OF A NON-PERIODIC LINE +C + ISLPSW = 3 + GO TO 100 +C +C SET UP FLAGS FOR THE NTH SEGMENT OF A NON-PERIODIC LINE +C + 90 SLP1 = SSLPN + ISLPSW = 1 +C +C CALL THE SMOOTHING ROUTINES +C + 100 CALL KURV1S (N,XSAVE,YSAVE,SLP1,SLPN,XP,YP,TEMP,S,SIGMA,ISLPSW) +C +C DETERMINE THE NUMBER OF POINTS TO INTERPOLATE FOR EACH SEGMENT +C + IF (NSEG.GE.1 .AND. N.LT.L1-1) GO TO 110 + NPRIME = FLOAT(NP)-(S*FLOAT(NP)*.5)/32767. + IF (S .GE. 32767.) NPRIME = .5*FLOAT(NP) + NPL = AMAX1(FLOAT(NPRIME)*S/32767.,2.5) + 110 DT = 1./FLOAT(NPL) + IX = IFIX (XSAVE(1)) + IY = IFIX (YSAVE(1)) + IF (NSEG .LE. 0) GO TO 112 + CALL DRAWPV (IX,IY,0) + GO TO 114 + 112 CONTINUE + CALL CFVLD (1,IX,IY) + 114 CONTINUE + T = 0.0 + NSLPSW = 1 + IF (NSEG .GE. 1) NSLPSW = 0 + NSEG = 1 + CALL KURV2S (T,XS,YS,N,XSAVE,YSAVE,XP,YP,S,SIGMA,NSLPSW,SLP) +C +C SAVE SLOPE AT THE FIRST POINT OF THE LINE +C + IF (NSLPSW .GE. 1) SSLP1 = SLP + NSLPSW = 0 + DO 120 I=1,NPL + T = T+DT + TT = -T + IF (I .EQ. NPL) NSLPSW = 1 + CALL KURV2S (TT,XS,YS,N,XSAVE,YSAVE,XP,YP,S,SIGMA,NSLPSW,SLP) +C +C SAVE THE LAST SLOPE OF THIS LINE SEGMENT +C + IF (NSLPSW .GE. 1) SSLPN = SLP +C +C DRAW EACH PART OF THE LINE SEGMENT +C + IX = IFIX(XS) + IY = IFIX (YS) + CALL CFVLD (2,IX,IY) + 120 CONTINUE + IF (IPRD .NE. 0) GO TO 130 +C +C CONNECT THE LAST POINT WITH THE FIRST POINT OF A PERIODIC LINE +C + IX = IFIX (XSV1) + IY = IFIX (YSV1) + CALL CFVLD (2,IX,IY) +C +C BEGIN THE NEXT LINE SEGMENT WITH THE LAST POINT OF THIS SEGMENT +C + 130 XSAVE(1) = XS + YSAVE(1) = YS + N = 1 + IF (IFSTF2 .EQ. 1) CALL CFVLD (3,IDUMMY,IDUMMY) + GO TO 150 +C +C FOR THE CASE WHEN THERE ARE ONLY 2 DISTINCT POINTS ON A LINE. +C + 140 IX = IFIX (XSAVE(1)) + IY = IFIX (YSAVE(1)) + CALL CFVLD (1,IX,IY) + IX = IFIX (XSAVE(N)) + IY = IFIX (YSAVE(N)) + CALL CFVLD (2,IX,IY) + IF (IFSTF2 .EQ. 1) CALL CFVLD (3,IDUMMY,IDUMMY) +C + 150 CONTINUE + RETURN + END + SUBROUTINE RESET +C +C THIS USER ENTRY POINT IS HERE ONLY FOR COMPATIBILITY WITH USE IN +C THE CONREC FAMILY WHICH CALL RESET WHEN USED WITH DASHSUPR. +C + RETURN + END + SUBROUTINE DASHDC (IPAT,JCRT,JSIZE) +C +C +C +C +C +C + COMMON/INTPR/IPAU,FPART,TENSN,NP,SMALL,L1,ADDLR,ADDTB,MLLINE, + 1 ICLOSE +C +C USER ENTRY POINT. +C DASHDC GIVES AN INTERNAL REPRESENTATION TO THE DASH PATTERN WHICH IS +C SPECIFIED IN ITS ARGUMENTS. THIS INTERNAL REPRESENTATION IS PASSED +C TO ROUTINE CFVLD IN THE COMMON-BLOCK DASHD1. +C + CHARACTER*(*) IPAT + CHARACTER*1 IBLK, IGAP, ISOL, ICR + CHARACTER*16 IPC(100) +C +C DASHD1 AND DASHD2 ARE USED +C FOR COMMUNICATION BETWEEN THE ROUTINES DASHDB, DASHDC AND CFVLD. +C ISL, MNCSTR AND IGP ARE INITIALIZED IN DASHBD. +C + COMMON /DASHD1/ ISL, L, ISIZE, IP(100), NWDSM1, IPFLAG(100) + 1 ,MNCSTR, IGP + COMMON /DASHD2/ IPC +C +C IFCFLG IS THE FIRST CALL FLAG FOR DASHDB AND DASHDC. +C IT IS INITIALIZED IN DASHBD. +C + COMMON /DDFLAG/ IFCFLG +C +C IFSTFL CONTROLS THAT FRSTD IS CALLED BEFORE VECTD IS CALLED (IN CFVLD) +C WHENEVER DASHDB OR DASHDC HAVE BEEN CALLED. +C IT IS INITIALIZED IN DASHBD AND REFERENCED IN CFVLD. +C + COMMON /DCFLAG/ IFSTFL +C +C IFSTF2 CONTROLS THAT THE FRSTD ENTRY IS CALLED IN FDVDLD BEFORE THE +C VECTD ENTRY IS CALLED WHENEVER DASHDB OR DASHDC HAVE BEEN CALLED. +C IT IS INITIALIZED IN DASHBD AND REFERENCED IN FDVDLD. +C + COMMON /DFFLAG/ IFSTF2 +C +C LOCAL VARIABLES TO DASHDB AND DASHDC ARE SAVED IN DSAVE2 +C FOR THE NEXT CALL +C + COMMON /DSAVE2/ MASK, NCHRWD, NBWD, MNCST1 +C SAVE ALL VARIABLES + SAVE +C +C NECESSARY ON SOME MACHINES TO GET BLOCK DATA LOADED +C +C NPD IS THE NUMBER OF WORDS IN IP +C + DATA NPD/100/ +C +C INITIALIZE CHARACTER FLAGS +C + DATA IBLK,IGAP,ISOL/' ','''','$'/ +C +C +NOAO - blockdata replaced with run time initialization. +C EXTERNAL DASHBD + call dashbd +C -NOAO +C +C THE FOLLOWING CALL IS FOR LIBRARY STATISTICS GATHERING AT NCAR + CALL Q8QST4 ('GRAPHX', 'DASHSMTH', 'DASHDC', 'VERSION 1') +C +C NC IS THE NUMBER OF CHARACTERS IN IPAT +C + NC = LEN(IPAT) + IF (IFCFLG .EQ. 2) GOTO 10 +C +C CHECK IF THE CONSTANTS IN THE BLOCKDATA DASHBD ARE LOADED CORRECTLY +C + IF (MNCSTR .EQ. 15) GOTO 6 + CALL SETER('DASHDC -- BLOCKDATA DASHBD APPARRENTLY NOT LOADED CORR + 1ECTLY',1,2) + 6 CONTINUE +C +C INITIALIZATION +C + MNCST1 = MNCSTR + 1 +C +C MASK IS AN ALL SOLID PATTERN TO BE PASSED TO OPTN (65535=177777B). +C + MASK=IOR(ISHIFT(32767,1),1) +C +C + IFCFLG = 2 +C +C NCHRTS - NUMBER OF CHARS IN THIS HOLLERITH STRING. +C L - NUMBER OF WORDS IN THE FINAL PATTERN, POINTER TO IP ARRAY. +C ISL - FLAG FOR ALL SOLID PATTERN (1) OR ALL GAP PATTERN (-1). +C IFSTFL - FLAG TO CONTROL THAT FRSTD IS CALLED IN CFVLD BEFORE VECTD IS +C CALLED, WHENEVER DASHDB OR DASHDC HAVE BEEN CALLED. +C IFSTF2 - FLAG TO CONTROL THAT FRSTD IS CALLED IN FDVDLD BEFORE VECTD +C IS CALLED, WHENEVER DASHDB OR DASHDC HAVE BEEN CALLED. +C + 10 CONTINUE + NCHRTS = 0 + L = 0 + ISL = 0 + IFSTFL = 1 + IFSTF2 = 1 +C +C RETRIEVE THE RESOLUTION AS SET BY THE USER. +C + CALL GETUSV('XF',LXSAVE) + CALL GETUSV('YF',LYSAVE) +C +C IADJUS - TO ADJUST NUMBERS TO THE GIVEN RESOLUTION. +C + IADJUS = ISHIFT(1,15-LXSAVE) + ICRT = JCRT*IADJUS + ISIZE = JSIZE + CHARW = FLOAT(ISIZE*IADJUS) + IF (ISIZE .GT. 3) GO TO 30 + CHARW = 256. + FLOAT(ISIZE)*128. + IF (ISIZE .EQ. 3) CHARW = 768. +C + 30 CONTINUE + IF (ICRT .LT. 1) GO TO 230 + MODE = 2 +C +C START MAIN LOOP +C +C THIS LOOP GENERATES THE IP ARRAY (NEEDED BY CURVED,VECTD,ETC.) FROM +C THE CHARACTER STRING IN IPAT. EACH ITERATION OF THE LOOP PROCESSES +C ONE CHAR OF IPAT. A SOLID OR GAP IS CONSIDERED TO BE A TYPE 1 ENTRY, +C AND A LABEL CHARACTER IS CONSIDERED TO BE A TYPE 2 ENTRY. +C +C IN THE CODE, L IS THE NUMBER OF CHANGES IN THE LINESTYLE (FROM GAP +C TO SOLID, SOLID TO CHARACTER, ETC.) THE IP AND IPFLAG ARRAYS DESCRIBE +C THE LINE TO BE DRAWN, AND THESE ARRAYS ARE INDEXED FROM 1 TO L. THE +C RELATIONSHIP BETWEEN IP AND IPFLAG IS: +C +C IPFLAG(N) IP(N) +C --------- ----- +C 1 LENGTH (IN PLOTTER ADDRESS UNITS) OF SOLID LINE TO +C BE DRAWN. +C 0 NUMBER OF CHARACTERS TO BE PLOTTED. +C -1 LENGTH (IN PLOTTER ADDRESS UNITS) OF GAP. +C +C THE 160 LOOP HANDLES 5 CASES: +C +C 1.) CONTINUE TYPE 2 ENTRY (60-80) +C 2.) START TYPE 2 ENTRY (80-90) +C 3.) END TYPE 2 ENTRY AND START TYPE 1 ENTRY (90-160) +C 4.) START TYPE 1 ENTRY, OR SWITCH TYPE 1 ENTRY FROM SOLID TO +C GAP OR FROM GAP TO SOLID (140-160) +C 5.) CONTINUE TYPE 1 ENTRY (150-160) +C + DO 160 J=1,NC +C +C GET NEXT CHAR INTO ICR, RIGHT JUSTIFIED ZERO FILLED. +C + ICR = IPAT(J:J) +C +C MODE SPECIFIES WHAT THE LAST CHARACTER PROCESSED WAS: +C +C LAST ICR WAS $ (SOLID), MODE IS 8 +C LAST ICR WAS ' (GAP), MODE IS 2 +C LAST ICR WAS HOLLERITH CHAR, MODE IS 5 +C +C NMODE SPECIFIES WHAT THE CURRENT CHARACTER TO BE PROCESSED IS: +C +C ICR NMODE +C --- ----- +C $ 1 +C CHAR 0 +C ' -1 +C + NMODE = 0 + IF (ICR .EQ. IBLK) GO TO 160 + IF (ICR .EQ. IGAP) NMODE = -1 + IF (ICR .EQ. ISOL) NMODE = 1 + IF (L.EQ.0 .AND. NMODE.EQ.-1) MODE = 8 +C +C NGO DETERMINES WHERE TO BRANCH BASED ON CASE TO BE PROCESSED. +C COMPUTE MODE FOR NEXT ITERATION. +C + NGO = NMODE+MODE + MODE = NMODE*3+5 + GO TO (150,80,140,90,60,90,140,80,150),NGO +C +C CHAR TO CHAR +C +C CASE 1) - CONTINUE TYPE 2 ENTRY. +C + 60 IF (NCHRTS .EQ. MNCSTR) GO TO 160 + NCHRTS = NCHRTS + 1 + IP(L) = NCHRTS + IPC(L)(NCHRTS:NCHRTS) = ICR + GO TO 160 +C +C BLANK OR SOLID TO CHAR +C +C CASE 2) - START STRING ENTRY. LGBSTR POINTS TO THE GAP WHICH +C WILL CONTAIN THE STRING. +C + 80 LGBSTR = MIN0(L+1,NPD) + L = MIN0(LGBSTR+1,NPD) + IPFLAG(L) = 0 + NCHRTS = 1 + IP(L) = 1 + IPC(L)(NCHRTS:NCHRTS) = ICR + GO TO 160 +C +C CHAR TO SOLID OR GAP +C +C CASE 3) - END STRING ENTRY. ICR IS A $ OR '. +C + 90 CONTINUE + IP(LGBSTR) = CHARW*(FLOAT(NCHRTS) + .5) + IPFLAG(LGBSTR) = -1 + IF (IGP .EQ. 0) IPFLAG(LGBSTR) = 1 +C +C BLANK TO SOLID OR SOLID TO BLANK +C +C CASE 4) - START TYPE 1 ENTRY. +C + 140 L = MIN0(L+1,NPD) + IP(L) = 0 +C +C ADD TO A BLANK OR SOLID LINE +C +C CASE 5) - CONTINUE TYPE 1 ENTRY. ICR IS A $ OR '. +C ADD ICRT UNITS TO THE PLOTTER ADDRESS UNITS IN IP(L). +C NMODE INDICATES IF IT IS A GAP OR A SOLID. +C + 150 IP(L) = IP(L) + ICRT + IPFLAG(L) = NMODE + 160 CONTINUE +C +C IF LAST ICR PROCESSED WAS A LABEL CHARACTER, MUST END STRING +C ENTRY. +C + IF (NGO.NE.2 .AND. NGO.NE.5 .AND. NGO.NE.8) GO TO 220 + IP(LGBSTR) = CHARW*(FLOAT(NCHRTS)+.5) + IPFLAG(LGBSTR) = -1 + IF (IGP .EQ. 0) IPFLAG(LGBSTR) = 1 +C +C IF IP ARRAY HAS ONLY ONE TYPE 1 ENTRY, SET ISL FLAG. +C + 220 IF (L .GT. 1) RETURN + IBIG = ISHIFT(1,MAX0(LXSAVE,LYSAVE)) + IF (IP(L) .GE. IBIG) GO TO 230 + IF (IPFLAG(L)) 240,240,230 + 230 ISL = 1 + RETURN + 240 ISL = -1 + RETURN + END + SUBROUTINE DASHDB (IPAT) +C +C ARGUMENTS IPAT +C ON INPUT IPAT IS A 16-BIT DASH PATTERN. BY DEFAULT +C EACH BIT IN THE PATTERN REPRESENTS 3 PLOTTER +C ADDRESS UNITS (1=SOLID, 0=BLANK) +C +C +C +C USER ENTRY POINT. +C DASHDB GIVES AN INTERNAL REPRESENTATION TO THE DASH PATTERN WHICH IS +C SPECIFIED IN ITS ARGUMENT. THIS INTERNAL REPRESENTATION IS PASSED +C TO ROUTINE CFVLD IN THE COMMON-BLOCK DASHD1. +C + DIMENSION IPAT(1) + COMMON/INTPR/IPAU,FPART,TENSN,NP,SMALL,L1,ADDLR,ADDTB,MLLINE, + 1 ICLOSE +C +C DASHD1 IS FOR COMMUNICATION BETWEEN THE ROUTINES DASHDB AND CFVLD. +C ISL, MNCSTR AND IGP ARE INITIALIZED IN DASHBD. +C + COMMON /DASHD1/ ISL, L, ISIZE, IP(100), NWDSM1, IPFLAG(100) + 1 ,MNCSTR, IGP +C +C IFCFLG IS THE FIRST CALL FLAG FOR DASHDB. IT IS INITIALIZED IN DASHBD. +C + COMMON /DDFLAG/ IFCFLG +C +C IFSTFL CONTROLS THAT FRSTD IS CALLED BEFORE VECTD IS CALLED (IN CFVLD) +C WHENEVER DASHDB HAS BEEN CALLED. IT IS INITIALIZED IN DASHBD AND +C REFERENCED IN CFVLD. +C + COMMON /DCFLAG/ IFSTFL +C +C IFSTF2 CONTROLS THAT THE FRSTD ENTRY IS CALLED IN FDVDLD BEFORE THE +C VECTD ENTRY IS CALLED WHENEVER DASHDB OR DASHDC HAS BEEN CALLED. IT IS +C INITIALIZED IN DASHBD AND REFERENCED IN FDVDLD. +C + COMMON /DFFLAG/ IFSTF2 +C +C LOCAL VARIABLES TO DASHDB ARE SAVED IN DSAVE2 FOR THE NEXT CALL TO +C DASHDB. +C + COMMON /DSAVE2/ MASK, NCHRWD, NBWD, MNCST1 +C +C NECESSARY ON SOME MACHINES TO GET BLOCK DATA LOADED +C + SAVE +C +C +NOAO - blockdata replaced with run time initialization. +C EXTERNAL DASHBD + call dashbd +C -NOAO +C +C THE FOLLOWING CALL IS FOR LIBRARY STATISTICS GATHERING AT NCAR + CALL Q8QST4 ('GRAPHX', 'DASHSMTH', 'DASHDB', 'VERSION 1') + IF (IFCFLG .EQ. 2) GOTO 10 +C +C CHECK IF THE CONSTANTS IN THE BLOCKDATA DASHBD ARE LOADED CORRECTLY +C + IF (MNCSTR .EQ. 15) GOTO 6 + CALL SETER('DASHDB -- BLOCKDATA DASHBD APPARRENTLY NOT LOADED CORR + 1ECTLY',1,2) + 6 CONTINUE +C +C INITIALIZATION +C + MNCST1 = MNCSTR + 1 +C +C MASK IS AN ALL SOLID PATTERN +C + MASK=IOR(ISHIFT(32767,1),1) +C + IFCFLG = 2 +C +C L - NUMBER OF WORDS IN THE FINAL PATTERN, POINTER TO IP ARRAY. +C ISL - FLAG FOR ALL SOLID PATTERN (1) OR ALL GAP PATTERN (-1). +C IFSTFL - FLAG TO CONTROL THAT FRSTD IS CALLED IN CFVLD BEFORE VECTD IS +C CALLED, WHENEVER DASHDB OR DASHDC HAS BEEN CALLED. +C IFSTF2 - FLAG TO CONTROL THAT FRSTD IS CALLED IN FDVDLD BEFORE VECTD +C IS CALLED, WHENEVER DASHDB OR DASHDC HAS BEEN CALLED. +C + 10 CONTINUE + NCHRTS = 0 + L = 0 + ISL = 0 + IFSTFL = 1 + IFSTF2 = 1 +C + ICRT = IPAU*ISHIFT(1,15-10) + IF (IPAT(1) .NE. 0) GO TO 260 + ISL = -1 + RETURN + 260 IF (IPAT(1) .NE. MASK) GO TO 270 + ISL = 1 + RETURN + 270 NMODE1 = IAND(ISHIFT(IPAT(1),-15),1) + DO 290 I = 1,16 + IF (NMODE1 .NE. IAND(ISHIFT(IPAT(1),I-16),1)) GO TO 280 + NMODE1 = 1 - NMODE1 + L = L + 1 + IP(L) = 0 + IPFLAG(L) = 1 - 2*NMODE1 + 280 IP(L) = IP(L) + ICRT + 290 CONTINUE + RETURN + END + SUBROUTINE DRAWPV (IX,IY,IND) +C +C DRAWPV INTERCEPTS THE CALL TO PLOTIT TO CHECK IF THE PEN HAS TO BE +C MOVED OR IF IT IS ALREADY CLOSE ENOUGH TO THE WANTED POSITION. +C IF IND=2 NEVER MOVE PEN, JUST UPDATE VARIABLES IXSTOR AND IYSTOR. +C +C IN IXSTOR AND IYSTOR THE CURRENT POSITION OF THE PEN IS SAVED. +C + COMMON /DSAVE3/ IXSTOR,IYSTOR +C + COMMON/INTPR/IPAU,FPART,TENSN,NP,SMALL,L1,ADDLR,ADDTB,MLLINE, + 1 ICLOSE + SAVE + IIND = IND + 1 + GOTO (100,90,105), IIND +C + 90 CONTINUE +C +C DRAW LINE AND SAVE POSITION OF PEN. +C + IXSTOR = IX + IYSTOR = IY + CALL PLOTIT (IXSTOR,IYSTOR,1) + GOTO 110 +C + 100 CONTINUE +C +C CHECK IF PEN IS ALREADY CLOSE ENOUGH TO THE WANTED POSITION. +C + DIFF = FLOAT(IABS(IXSTOR-IX)+IABS(IYSTOR-IY)) + IF (DIFF .LE. FLOAT(ICLOSE)) GO TO 110 +C + IXSTOR = IX + IYSTOR = IY + CALL PLOTIT (IXSTOR,IYSTOR,0) + GOTO 110 +C + 105 CONTINUE +C +C DO NOT MOVE PEN. JUST UPDATE VARIABLES IXSTOR AND IYSTOR. +C + IXSTOR = IX + IYSTOR = IY +C + 110 CONTINUE +C + RETURN + END +C + SUBROUTINE CFVLD (IENTRY,IIX,IIY) +C +C CFVLD CONNECTS POINTS WHOSE COORDINATES ARE SUPPLIED IN THE ARGUMENTS, +C ACCORDING TO THE DASH PATTERN WHICH IS PASSED FROM ROUTINE DASHDB +C OR DASHDC IN THE COMMON-BLOCK DASHD1. +C + CHARACTER*16 IPC(100) +C + COMMON/INTPR/IPAU,FPART,TENSN,NP,SMALL,L1,ADDLR,ADDTB,MLLINE, + 1 ICLOSE +C +C THE VARIABLES IN DASHD1 AND DASHD2 ARE USED FOR COMMUNICATION WITH +C DASHDC AND DASHDB. +C + COMMON /DASHD1/ ISL, L, ISIZE, IP(100), NWDSM1, IPFLAG(100) + 1 ,MNCSTR, IGP + COMMON /DASHD2/ IPC +C +C THE VARIABLES IN DSAVE1 HAVE TO BE SAVED FOR THE NEXT CALL TO CFVLD. +C + COMMON /DSAVE1/ X,Y,X2,Y2,X3,Y3,M,BTI,IB,IX,IY +C +C THE FLAGS IFSTFL AND IVCTFG ARE INITIALIZED IN THE BLOCK DATA DASHBD. +C IFSTFL CONTROLS THAT FRSTD IS CALLED BEFORE VECTD IS CALLED. +C IVCTFG IS A FLAG TO INDICATE IF CFVLD IS BEING CALLED FROM VECTD OR +C LASTD. +C + COMMON /DCFLAG/ IFSTFL + COMMON /CFFLAG/ IVCTFG + SAVE +C +C +C CMN IS USED TO DETERMINE WHEN TO STOP DRAWING A LINE SEGMENT +C + DATA CMN/1.5/ +C +C IMPOS IS USED AS AN IMPOSSIBLE PEN POSITION. +C + DATA IMPOS /-9999/ +C +C +C ISL= -1 ALL BLANK ) FLAG TO AVOID MOST CALCULATIONS +C 0 DASHED ) IF PATTERN IS ALL SOLID OR +C 1 ALL SOLID ) ALL BLANK +C +C X,IX,Y,IY CURRENT POSITION +C X1,Y1 START OF A USER LINE SEGMENT +C X2,Y2 END OF A USER LINE SEGMENT +C X3,Y3 START OF A GAP PATTERN SEGMENT +C +C SYMBOLS,IF PRESENT ARE CENTERED IN AN IMMEDIATLY PRECEEDING +C GAP SEGMENT, OR DONE AT THE CURRENT POSITION OTHERWISE +C +C SEGMENT TYPES ARE RECOGNIZED AS FOLLOWS +C SOLID - WORD IN IP-ARRAY CONTAINS POSITIVE INTEGER, CORRESPONDING +C ELEMENT IN IPFLAG IS 1. +C GAP - WORD IN IP-ARRAY CONTAINS POSITIVE INTEGER, CORRESPONDING +C ELEMENT IN IPFLAG IS -1. +C SYMBOL - WORD IN IP-ARRAY CONTAINS CHARACTER REPRESENTATIONS. +C CORRESPONDING ELEMENT IN IPFLAG IS 0. +C SYMBOL COUNT FOR CHAR STRING IN CHAR NUMBER MNCSTR+1. +C THE IP ARRAY AND THE IPFLAG ARRAY ARE COMPOSED OF L ELEMENTS. +C +C BTI - BITS THIS INCREMENT +C BPBX,BPBY BITS PER BIT X(Y) +C +C +C BRANCH DEPENDING ON FUNCTION TO BE PERFORMED. +C + GO TO (330,305,350),IENTRY +C +C INITIALIZE VARIABLES (ENTRY FRSTD ONLY) +C + 30 CONTINUE + X = IX + Y = IY + X2 = X + X3 = X + Y2 = Y + Y3 = Y + M = 1 + IB = IPFLAG(1) + IF (IPFLAG(1) .NE. 0) GO TO 40 + IB = 0 + BTI = 0 + 40 CONTINUE + BTI = FLOAT(IP(1))*FPART + GO TO 300 +C +C MAIN LOOP START +C + 50 CONTINUE + X1 = X2 + Y1 = Y2 + MX = IIX + MY = IIY + X2 = MX + Y2 = MY + DX = X2-X1 + DY = Y2-Y1 + D = SQRT(DX*DX+DY*DY) + IF (D .LT. CMN) GO TO 190 + 60 BPBX = DX/D + BPBY = DY/D + CALL DRAWPV (IX,IY,0) + 70 BTI = BTI-D + IF (BTI) 100,100,80 +C +C LINE SEGMENT WILL FIT IN CURRENT PATTERN ELEMENT +C + 80 X = X2 + Y = Y2 + IX = X2 + IY = Y2 + IF (IB) 200,160,90 + 90 CALL DRAWPV (IX,IY,1) + GO TO 200 +C +C LINE SEGMENT WONT FIT IN CURRENT PATTERN ELEMENT +C DO IT TO END OF ELEMENT, SAVE HOW MUCH OF SEGMENT LEFT TO DO (D) +C + 100 BTI = BTI+D + D = D-BTI + X = X+BPBX*BTI + Y = Y+BPBY*BTI + IX = X+.5 + IY = Y+.5 + IF (IB) 110,160,120 + 110 CALL DRAWPV (IX,IY,0) + GO TO 130 + 120 CALL DRAWPV (IX,IY,1) +C +C GET THE NEXT PATTERN ELEMENT +C + 130 M = MOD(M,L)+1 + IB = IPFLAG(M) + IF (IB) 140,160,150 + 140 X3 = X + Y3 = Y + BTI = FLOAT(IP(M)) + GO TO 70 + 150 X3 = -1. + BTI = FLOAT(IP(M)) + GO TO 70 +C +C CHARACTER GENERATION +C + 160 S = 0. + IF (IGP .NE. 9) GO TO 162 +C + DX = X-X3 + DY = Y-Y3 + GO TO 164 +C + 162 CONTINUE + DX = X - X1 + DY = Y - Y1 + 164 CONTINUE +C + IF (DY) 170,180,170 + 170 S = ATAN2(DY,DX) + IF (ABS(S-.00005) .GT. 1.5708) S = S-SIGN(3.14159,S) + 180 IF (IGP .NE. 9) GO TO 182 +C + MX = X3 + DX*.5 + MY = Y3 + DY*.5 + LIGP = 0 + GO TO 184 +C + 182 CONTINUE + MX = X + MY = Y + LIGP = 1 +C + 184 CONTINUE + IS = IFIX(S*180./3.14 + .5) + IF (IS .LT. 0) IS = 360+IS + CALL GETUSV('XF',LXSAVE) + CALL GETUSV('YF',LYSAVE) + MX = ISHIFT (MX,LXSAVE-15) + MY = ISHIFT(MY,LYSAVE-15) + CALL WTSTR(CPUX(MX),CPUY(MY),IPC(M)(1:IP(M)),ISIZE,IS,LIGP) + CALL DRAWPV (IMPOS,IMPOS,2) + CALL DRAWPV (IX,IY,0) + GO TO 130 + 190 X2 = X1 + Y2 = Y1 + 200 CONTINUE +C +C EXIT IF CALL WAS TO VECTD. +C + IF (IVCTFG .NE. 2) GO TO 210 + IVCTFG = 1 + GO TO 300 +C +C EXIT IF NOT PLOTTING A GAP +C + 210 IF (IB .GE. 0) GO TO 300 +C +C MUST BE IN A GAP AT END OF LASTD. EXIT IF NOT A LABEL GAP. +C + MO = M + M = MOD(M,L) + 1 + IF (IPFLAG(M) .NE. 0) GO TO 300 +C +C CHECK PREVIOUS PLOTTED ELEMENT. WAS IT A GAP OR A LINE. +C + MPREV = M - 2 + IF (MPREV .LE. 0) MPREV = MPREV + L + IB = IPFLAG(MPREV) + IF (IB .GE. 0) GO TO 250 +C +C PREVIOUS ELEMENT WAS A GAP - LOOK FOR NEXT LINE. +C EXIT IF NO LINES IN PATTERN. +C + 230 CONTINUE + 240 M = MOD(M,L)+1 + IF (M .EQ. MO) GO TO 300 + IB = IPFLAG(M) + IF (IB .EQ. 0) GOTO 245 + BTI = FLOAT(IP(M)) + 245 CONTINUE +C +C IF IP(M) NOT A LINE, CONTINUE LOOKING. +C + IF (IB) 240,230,280 +C +C PREVIOUS ELEMENT WAS A LINE - LOOK FOR NEXT GAP. +C IF NO NON-LABEL GAPS IN PATTERN, GO TO 290. +C + 250 CONTINUE + 260 M = MOD(M,L)+1 + IF (M .EQ. MO) GO TO 290 + IB = IPFLAG(M) + IF (IB .EQ. 0) GOTO 265 + BTI = FLOAT(IP(M)) + 265 CONTINUE +C +C IF IP(M) NOT A GAP, CONTINUE LOOKING. +C + IF (IB) 270,250,260 +C +C FOUND A GAP. IF ITS A LABEL GAP, GO LOOK FOR NEXT GAP. +C + 270 MT = M + M = MOD(M,L)+1 + IF (IPFLAG(M) .EQ. 0) GO TO 250 + M = MT +C +C M POINTS TO NEXT ELEMENT TO PLOT. SET UP AND GO PLOT. +C + 280 X1 = X3 + Y1 = Y3 + X = X3 + Y = Y3 + IX = X+0.5 + IY = Y+0.5 + DX = X2-X1 + DY = Y2-Y1 + D = SQRT(DX*DX+DY*DY) + IF (D .GE. CMN) GO TO 60 + GO TO 300 +C +C NO NON-LABEL GAPS IN THE PATTERN - FILL IN WITH SOLID LINE. +C + 290 IX = X3+0.5 + IY = Y3+0.5 + CALL DRAWPV (IX,IY,0) + IX = X2 + IY = Y2 + CALL DRAWPV (IX,IY,1) + 300 RETURN +C +C ************************************* +C +C ENTRY VECTD (XX,YY) +C + 305 CONTINUE +C +C TEST FOR PREVIOUS CALL TO FRSTD. +C + IF (IFSTFL .EQ. 2) GO TO 310 +C +C INFORM USER - NO PREVIOUS CALL TO FRSTD. TREAT CALL AS FRSTD CALL. +C + CALL SETER ('CFVLD -- VECTD CALL OCCURS BEFORE A CALL TO FRSTD.', + - 1,1) + GO TO 330 + 310 K = 1 + IVCTFG = 2 + IF (ISL) 300,50,320 + 320 IX = IIX + IY = IIY + CALL DRAWPV (IX,IY,1) + GO TO 300 +C +C ************************************* +C +C ENTRY FRSTD (FLDX,FLDY) +C + 330 IX = IIX + IY = IIY + IFSTFL = 2 +C AVOID UNEXPECTED PEN POSITION IF CALLS TO SYSTEM PLOT PACKAGE +C ROUTINES WERE MADE. + CALL DRAWPV (IMPOS,IMPOS,2) + IF (ISL) 300,30,340 + 340 CALL DRAWPV (IX,IY,0) + GO TO 300 +C +C ************************************* +C +C ENTRY LASTD +C + 350 CONTINUE +C +C TEST FOR PREVIOUS CALL TO FRSTD +C + IF (IFSTFL .NE. 2) GO TO 300 + IFSTFL = 1 + K = 1 + IF (ISL .NE. 0) GO TO 300 + GO TO 210 + END + SUBROUTINE FRSTD (X,Y) +C USER ENTRY PPINT. + CALL FL2INT (X,Y,IIX,IIY) + CALL FDVDLD (1,IIX,IIY) + RETURN + END + SUBROUTINE VECTD (X,Y) +C USER ENTRY POINT. + CALL FL2INT (X,Y,IIX,IIY) + CALL FDVDLD (2,IIX,IIY) + RETURN + END + SUBROUTINE LASTD +C USER ENTRY POINT. SEE DOCUMENTATION FOR PURPOSE. + DATA IDUMMY /0/ + CALL FDVDLD (3,IDUMMY,IDUMMY) +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(0,0,0) + RETURN + END + SUBROUTINE CURVED (X,Y,N) +C USER ENTRY POINT. +C + DIMENSION X(N),Y(N) +C + CALL FRSTD (X(1),Y(1)) + DO 10 I=2,N + CALL VECTD (X(I),Y(I)) + 10 CONTINUE +C + CALL LASTD +C + RETURN + END + SUBROUTINE LINED (XA,YA,XB,YB) +C USER ENTRY POINT. +C + DATA IDUMMY /0/ + CALL FL2INT (XA,YA,IXA,IYA) + CALL FL2INT (XB,YB,IXB,IYB) +C + CALL CFVLD (1,IXA,IYA) + CALL CFVLD (2,IXB,IYB) + CALL CFVLD (3,IDUMMY,IDUMMY) +C + RETURN +C +C------REVISION HISTORY +C +C JUNE 1984 CONVERTED TO FORTRAN77 AND GKS +C +C DECEMBER 1979 ADDED REVISION HISTORY AND STATISTICS +C CALL +C +C----------------------------------------------------------------------- +C + END diff --git a/sys/gio/ncarutil/ezmap.f b/sys/gio/ncarutil/ezmap.f new file mode 100644 index 00000000..8d87a4d7 --- /dev/null +++ b/sys/gio/ncarutil/ezmap.f @@ -0,0 +1,4598 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C*********************************************************************** +C P A C K A G E E Z M A P - I N T R O D U C T I O N +C*********************************************************************** +C +C THIS FILE CONTAINS IMPLEMENTATION INSTRUCTIONS, A WRITE-UP, AND THE +C CODE FOR THE PACKAGE EZMAP. BANNERS LIKE THE ONE ABOVE DELIMIT THE +C MAJOR SECTIONS OF THE FILE. THE CODE ITSELF IS SEPARATED INTO THREE +C SECTIONS: USER-LEVEL ROUTINES, INTERNAL ROUTINES, AND THE BLOCK DATA +C ROUTINE WHICH DETERMINES THE DEFAULT VALUES OF INTERNAL PARAMETERS. +C WITHIN EACH SECTION, ROUTINES APPEAR IN ALPHABETICAL ORDER. +C +C*********************************************************************** +C P A C K A G E E Z M A P - I M P L E M E N T A T I O N +C*********************************************************************** +C +C THE EZMAP PACKAGE IS WRITTEN IN FORTRAN-77 AND SHOULD BE RELATIVELY +C EASY TO IMPLEMENT. THE OUTLINE DATA REQUIRED MAY BE GENERATED BY +C RUNNING THE PROGRAM +C +C PROGRAM CONVRT +C DIMENSION FLIM(4),PNTS(200) +C 1 READ (1,3,END=2) NPTS,IGID,(FLIM(I),I=1,4) +C IF (NPTS.GT.1) READ (1,4,END=2) (PNTS(I),I=1,NPTS) +C WRITE (2) NPTS,IGID,(FLIM(I),I=1,4),(PNTS(I),I=1,NPTS) +C GO TO 1 +C 2 STOP +C 3 FORMAT (2I8,4F8.3) +C 4 FORMAT (10F8.3) +C END +C +C WITH THE FILE EZMAPDAT ASSIGNED TO UNIT 1. THE OUTPUT FILE, ON UNIT +C 2, CONTAINS THE BINARY OUTLINE DATA TO BE USED BY EZMAP. THE EZMAP +C ROUTINE MAPIO (WHICH SEE) MUST THEN BE MODIFIED TO ACCESS THIS FILE. +C +C THE ROUTINE MAPCHI CONTAINS THE STATEMENTS +C +C CALL GETUSV ('IN',INTO) +C CALL SETUSV ('IN',IFIX(10000.*FLOAT(INTS(IPRT))/255.)) +C +C (TO BE EXECUTED FOR A POSITIVE VALUE OF IPRT) AND THE STATEMENT +C +C CALL SETUSV ('IN',INTO) +C +C (TO BE EXECUTED FOR A NEGATIVE VALUE OF IPRT). THESE STATEMENTS +C SET/RESET THE INTENSITY FOR VARIOUS PORTIONS OF THE MAP. IF COLOR +C IS AVAILABLE ON THE DEVICE(S) BEING DRIVEN, THESE STATEMENTS SHOULD +C BE OMITTED AND THE IMPLEMENTOR SHOULD PROVIDE A DEFAULT VERSION OF +C MAPUSR WHICH SETS/RESETS THE INTENSITY AND COLOR AS DESIRED. THIS +C DEFAULT VERSION OF MAPUSR SHOULD DECLARE THE LABELLED COMMON BLOCK +C MAPNTS AND MAKE USE OF THE CURRENT VALUES IN THE ARRAY INTS TO SET +C THE INTENSITY; IT SHOULD ALSO BE PUBLISHED TO AID USERS IN SETTING +C UP THEIR OWN VERSIONS. +C +C +C*********************************************************************** +C P A C K A G E E Z M A P - U S E R ' S G U I D E +C*********************************************************************** +C +C LATEST REVISION AUGUST, 1985 +C +C PURPOSE TO PLOT MAPS OF THE EARTH ACCORDING TO ANY +C ONE OF TEN DIFFERENT PROJECTIONS, SHOWING +C CONTINENTAL, INTERNATIONAL, AND/OR U.S. STATE +C OUTLINES, PARALLELS, AND MERIDIANS. THE +C ORIGIN AND ORIENTATION OF THE PROJECTION ARE +C SELECTED BY THE USER. POINTS ON THE EARTH +C DEFINED BY LATITUDE AND LONGITUDE ARE MAPPED +C TO POINTS IN THE PLANE OF PROJECTION - THE +C U/V PLANE. THE U AND V AXES ARE PARALLEL TO +C THE X AND Y AXES OF THE PLOTTER, RESPECTIVELY. +C A RECTANGULAR FRAME WHOSE SIDES ARE PARALLEL +C TO THE U AND V AXES IS CHOSEN AND MATERIAL +C WITHIN THAT FRAME (OR AN INSCRIBED ELLIPTICAL +C FRAME) IS PLOTTED. +C +C USAGE THE ROUTINE MAPDRW DRAWS A COMPLETE MAP, AS +C DIRECTED BY THE CURRENT VALUES OF PARAMETERS +C IN THE EZMAP PACKAGE. TO CHANGE THE VALUES +C OF THOSE PARAMETERS, AND THUS THE APPEARANCE +C OF THE MAP, ONE MAY FIRST CALL ONE OF THE +C ROUTINES MAPROJ (TO CHANGE THE PROJECTION TO +C BE USED), MAPSET (TO CHANGE WHAT PORTION OF +C THE U/V PLANE IS TO BE VIEWED), MAPPOS (TO +C CHANGE WHAT PORTION OF THE PLOTTER FRAME IS +C TO BE USED), OR ONE OF THE PARAMETER-SETTING +C ROUTINES MAPSTC, MAPSTI, MAPSTL, AND MAPSTR +C (TO CHANGE VARIOUS OTHER PARAMETERS, OF TYPES +C CHARACTER, INTEGER, LOGICAL, AND REAL). THE +C PARAMETER-RETRIEVAL ROUTINES MAPGTC, MAPGTI, +C MAPGTL, AND MAPGTR ALLOW THE USER TO RETRIEVE +C THE VALUES OF EZMAP PARAMETERS. +C +C THE ROUTINE MAPSAV ALLOWS ONE TO SAVE THE +C CURRENT STATE OF EZMAP, THE ROUTINE MAPRST TO +C RESTORE A SAVED STATE. +C +C USERS WITH SPECIAL NEEDS MAY WISH TO CALL THE +C LOWER-LEVEL ROUTINES MAPINT (TO INITIALIZE +C THE PACKAGE - IT MUST BE CALLED INITIALLY AND +C AGAIN WHENEVER CERTAIN PARAMETERS ARE CHANGED), +C MAPGRD (TO DRAW PARALLELS AND MERIDIANS), +C MAPLBL (TO LABEL THE INTERNATIONAL DATE LINE, +C THE EQUATOR, THE GREENWICH MERIDIAN, AND THE +C POLES, AND TO DRAW THE PERIMETER), AND MAPLOT +C (TO DRAW THE SELECTED GEOGRAPHIC OUTLINES). +C THESE ROUTINES ARE NORMALLY CALLED BY MAPDRW. +C +C INTENSITIES OF VARIOUS MAP PORTIONS MAY BE SET +C BY CALLS TO THE ROUTINE MAPSTI. THE ROUTINE +C MAPUSR IS CALLED BY EZMAP JUST BEFORE/AFTER +C DRAWING VARIOUS PORTIONS OF THE MAP; THE +C DEFAULT VERSION, WHICH DOES NOTHING, MAY BE +C REPLACED BY A USER VERSION WHICH SETS/RESTORES +C COLOR, SPOT SIZE, INTENSITY, DASH PATTERN, ETC. +C +C THE ROUTINE MAPEOS IS CALLED BY EZMAP ONCE FOR +C EACH OUTLINE SEGMENT. THE USER MAY SUPPLY A +C VERSION WHICH EXAMINES THE SEGMENT TO SEE IF +C IT OUGHT TO BE PLOTTED AND, IF NOT, TO DELETE +C IT. THIS MAY BE USED, FOR EXAMPLE, TO REDUCE +C THE CLUTTER IN NORTHERN CANADA. +C +C TO OVERLAY OBJECTS OF ONE'S OWN ON THE MAP +C DRAWN BY MAPDRW, ONE MAY USE ONE OR MORE OF +C THE ROUTINES MAPTRN (TO COMPUTE THE U/V +C COORDINATES OF A POINT, GIVEN ITS LATITUDE +C AND LONGITUDE), MAPIT (TO DO "PEN-UP/DOWN" +C MOVES), MAPFST (TO DO "PEN-UP" MOVES), AND +C MAPVEC (TO DO "PEN-DOWN" MOVES). +C +C THE ROUTINE SUPMAP, FROM WHICH EZMAP GREW, IS +C IMPLEMENTED WITHIN IT AND ALLOWS ONE TO DRAW +C A COMPLETE MAP WITH A SINGLE, RATHER LENGTHY, +C CALL. THE ROUTINE SUPCON, WHICH IS THE OLD +C ANALOGUE OF MAPTRN, IS ALSO IMPLEMENTED. +C +C THE OLD ROUTINE EZMAP, WHICH WAS IMPLEMENTED +C IN SUCH A WAY AS TO CAUSE PORTABILITY PROBLEMS, +C HAS BEEN REMOVED. STATISTICS INDICATED THAT +C IT WAS NOT BEING USED, ANYWAY. +C +C SEE THE WRITE-UPS OF INDIVIDUAL ROUTINES BELOW. +C +C I/O GRAPHICAL OUTPUT IS GENERATED. OUTLINE DATA +C IS READ FROM A "TAPE UNIT". +C +C ERROR CONDITIONS WHEN AN ERROR OCCURS DURING A CALL TO AN EZMAP +C ROUTINE, AN ERROR MESSAGE IS LOGGED, USING THE +C NCAR VERSION OF THE PORT ERROR ROUTINE SETERR +C (CALLED SETER); BY DEFAULT, THE PROGRAM IS THEN +C ABORTED. ERROR RECOVERY IS POSSIBLE, HOWEVER. +C INSERT THE CALL +C +C CALL ENTSR (IOLD,1) +C +C AT THE BEGINNING OF YOUR PROGRAM. THIS MAKES +C ERROR RECOVERY POSSIBLE. THEN, FOLLOWING EACH +C CALL TO AN EZMAP ROUTINE WHICH COULD CAUSE AN +C ERROR, INSERT CODE LIKE THE FOLLOWING: +C +C IF (NERRO(IERR).NE.0) THEN +C CALL EPRIN +C CALL ERROF +C END IF +C +C THE VALUE OF THE FUNCTION NERRO IS NON-ZERO IF +C SETER HAS BEEN CALLED. THE CALL TO EPRIN DUMPS +C OUT THE ERROR MESSAGE (WHICH HAS NOT YET BEEN +C PRINTED) AND THE CALL TO ERROF TURNS OFF THE +C ERROR CONDITION IN SETER. THIS DOES NOT CLEAR +C EZMAP'S ERROR FLAG, HOWEVER; IT REMAINS SET +C UNTIL AFTER THE NEXT SUCCESSFUL CALL TO MAPINT, +C PREVENTING OTHER EZMAP ROUTINES FROM TRYING TO +C EXECUTE (AND POSSIBLY BOMBING AS A RESULT). +C POSSIBLE ERROR FLAGS ARE AS FOLLOWS: +C +C 1 MAPGTC - UNKNOWN PARAMETER NAME XX +C 2 MAPGTI - UNKNOWN PARAMETER NAME XX +C 3 MAPGTL - UNKNOWN PARAMETER NAME XX +C 4 MAPGTR - UNKNOWN PARAMETER NAME XX +C 5 MAPINT - ATTEMPT TO USE NON-EXISTENT +C PROJECTION +C 6 MAPINT - ANGULAR LIMITS TOO GREAT +C 7 MAPINT - MAP HAS ZERO AREA +C 8 MAPINT - MAP LIMITS INAPPROPIATE +C 9 MAPROJ - UNKNOWN PROJECTION NAME XX +C 10 MAPSET - UNKNOWN MAP AREA SPECIFIER XX +C 11 MAPSTC - UNKNOWN OUTLINE NAME XX +C 12 MAPSTC - UNKNOWN PARAMETER NAME XX +C 13 MAPSTI - UNKNOWN PARAMETER NAME XX +C 14 MAPSTL - UNKNOWN PARAMETER NAME XX +C 15 MAPSTR - UNKNOWN PARAMETER NAME XX +C 16 MAPTRN - ATTEMPT TO USE NON-EXISTENT +C PROJECTION +C 17 MAPIO - OUTLINE DATASET IS UNREADABLE +C 18 MAPIO - EOF ENCOUNTERED IN OUTLINE +C DATASET +C 19 MAPPOS - ARGUMENTS ARE INCORRECT +C 20 MAPRST - ERROR ON READ +C 21 MAPRST - EOF ON READ +C 22 MAPSAV - ERROR ON WRITE +C +C PRECISION SINGLE. +C +C LANGUAGE FORTRAN. +C +C HISTORY IN ABOUT 1963, R. L. PARKER OF UCSD WROTE THE +C ORIGINAL CODE CALLED SUPERMAP, USING OUTLINE +C DATA GENERATED BY HERSHEY. THIS WAS ADAPTED +C FOR USE AT NCAR BY LEE, IN 1968. REVISIONS +C OCCURRED IN JANUARY OF 1969 AND MAY OF 1971. +C THE CODE WAS PUT IN STANDARD NSSL FORMAT IN +C OCTOBER OF 1973. FURTHER REVISIONS OCCURRED +C IN JULY, 1974, IN AUGUST, 1976, AND IN JULY, +C 1978. IN LATE 1984 AND EARLY 1985, THE CODE +C WAS HEAVILY REVISED TO ACHIEVE FORTRAN-77 AND +C GKS COMPATIBILITY, TO REMOVE ERRORS, AND TO +C EXPAND THE OUTLINE DATASETS. CICELY RIDLEY, +C JAY CHALMERS, AND DAVE KENNISON (THE CURRENT +C CURATOR) HAVE ALL HAD A HAND IN THE CREATION +C OF THIS PACKAGE. +C +C REFERENCES HERSHEY, A.V., "THE PLOTTING OF MAPS ON A +C CRT PRINTER." NWL REPORT NO. 1844, 1963. +C +C LEE, TSO-HWA, "STUDENTS' SUMMARY REPORTS, +C WORK-STUDY PROGRAM IN SCIENTIFIC COMPUTING". +C NCAR, 1968. +C +C PARKER, R.L., "2UCSD SUPERMAP: WORLD +C PLOTTING PACKAGE". +C +C STEERS, J.A., "AN INTRODUCTION TO THE STUDY +C OF MAP PROJECTIONS". UNIVERSITY OF LONDON +C PRESS, 1962. +C +C ACCURACY THE DEFINITION OF THE MAP PRODUCED IS LIMITED +C BY TWO FACTORS: THE RESOLUTION OF THE OUTLINE +C DATA AND THE RESOLUTION OF THE GRAPHICS +C DEVICE. +C +C DATA POINTS IN THE CONTINENTAL OUTLINES ARE +C ABOUT ONE DEGREE APART AND THE COORDINATES +C ARE ACCURATE TO .01 DEGREE. DATA POINTS IN +C U.S. STATE OUTLINES ARE ABOUT .05 DEGREES +C APART AND THE COORDINATES ARE ACCURATE TO +C .001 DEGREE. BOTH THE SPACING AND THE +C ACCURACY OT THE INTERNATIONAL BOUNDARIES +C FALLS SOMEWHERE BETWEEN THESE TWO EXTREMES. +C +C THE DICOMED HAS 15-BIT COORDINATE REGISTERS, +C BUT AN EFFECTIVE RESOLUTION OF AT MOST 1 IN +C 4096 IN BOTH X AND Y. +C +C TIMING THE MARCH, 1985, UPDATE HAS MADE EZMAP RUN +C SIGNIFICANTLY SLOWER. THIS IS MOSTLY BECAUSE +C THE DEFAULT RESOLUTION HAS BEEN INCREASED TO +C A VALUE SUITABLE FOR THE DICOMED, RATHER THAN +C THE DD80. USERS WHO ARE CONCERNED ABOUT THIS +C MAY INCREASE THE VALUES OF THE PARAMETERS 'MV' +C AND/OR 'DD' (SEE THE DESCRIPTION OF MAPSTX) +C TO DECREASE THE TIMING (AT THE EXPENSE OF PLOT +C QUALITY, OF COURSE). +C +C PORTABILITY THE CODE IS WRITTEN IN FORTRAN-77 AND SHOULD +C BE VERY PORTABLE. A BINARY DATASET CONTAINING +C OUTLINE DATA MUST BE GENERATED AND THE ROUTINE +C MAPIO MUST BE MODIFIED TO READ THAT DATASET. +C SEE THE IMPLEMENTATION INSTRUCTIONS AT THE +C BEGINNING OF THIS FILE. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P D R W - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW THE COMPLETE MAP DESCRIBED BY THE +C CURRENT VALUES OF THE EZMAP PARAMETERS. +C +C MAPDRW CALLS MAPINT (IF REQUIRED), MAPGRD, +C MAPLBL, AND MAPLOT, IN THAT ORDER. THE USER +C MAY WISH TO CALL THESE ROUTINES DIRECTLY. +C +C USAGE CALL MAPDRW +C +C ARGUMENTS NONE. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P E O S - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE MAPEOS IS CALLED BY EZMAP TO EXAMINE EACH +C SEGMENT IN THE OUTLINE DATASETS. THE DEFAULT +C VERSION DOES NOTHING. A USER-SUPPLIED VERSION +C MAY CAUSE SELECTED SEGMENTS TO BE DELETED (TO +C REDUCE THE CLUTTER IN NORTHERN CANADA, FOR +C EXAMPLE). +C +C USAGE (BY EZMAP) CALL MAPEOS (NOUT,NSEG,IGID,NPTS,PNTS) +C +C ARGUMENTS NOUT IS THE NUMBER OF THE OUTLINE DATASET FROM +C WHICH THE SEGMENT COMES, AS FOLLOWS: +C +C NOUT DATASET TO WHICH SEGMENT BELONGS. +C ---- ------------------------------------ +C 1 'CO' - CONTINENTAL OUTLINES ONLY. +C 2 'US' - U.S STATE OUTLINES ONLY. +C 3 'PS' - CONTINENTAL, U.S STATE, AND +C INTERNATIONAL OUTLINES. +C 4 'PO' - CONTINENTAL AND INTERNATIONAL +C OUTLINES. +C +C NSEG IS THE NUMBER OF THE SEGMENT WITHIN THE +C OUTLINE DATASET. +C +C IGID IDENTIFIES THE GROUP TO WHICH THE SEGMENT +C BELONGS, AS FOLLOWS: +C +C IGID GROUP TO WHICH SEGMENT BELONGS. +C ---- ------------------------------------ +C 1 CONTINENTAL OUTLINES. +C 2 U.S. STATE BOUNDARIES. +C 3 INTERNATIONAL BOUNDARIES. +C +C NPTS IS THE NUMBER OF POINTS DEFINING THE +C OUTLINE SEGMENT. NPTS MAY BE ZEROED TO +C SUPPRESS PLOTTING OF THE SEGMENT. +C +C PNTS IS AN ARRAY OF COORDINATES. PNTS(1) +C AND PNTS(2) ARE THE LATITUDE AND LONGITUDE +C OF THE FIRST POINT, PNTS(3) AND PNTS(4) THE +C LATITUDE AND LONGITUDE OF THE SECOND POINT, ... +C PNTS(2*NPTS-1) AND PNTS(2*NPTS) THE LATITUDE +C AND LONGITUDE OF THE LAST POINT. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P F S T - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW LINES ON THE MAP PRODUCED BY A CALL TO +C MAPDRW - USED IN CONJUNCTION WITH MAPVEC. +C +C USAGE CALL MAPFST (RLAT,RLON) +C +C THIS CALL IS EXACTLY EQUIVALENT TO THE CALL +C +C CALL MAPIT (RLAT,RLON,0) +C +C ARGUMENTS RLAT AND RLON ARE DEFINED AS FOR MAPIT. SEE +C THE DESCRIPTION OF MAPIT. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P G R D - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW A GRID MADE UP OF LINES OF LATITUDE AND +C LONGITUDE. IF EZMAP NEEDS INITIALIZATION OR IF +C THE ERROR FLAG 'ER' IS NON-ZERO, MAPGRD DOES +C NOTHING. +C +C USAGE CALL MAPGRD +C +C ARGUMENTS NONE. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P G T X - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO GET THE VALUES OF EZMAP PARAMETERS. +C +C USAGE CALL MAPGTC (WHCH,CVAL) +C CALL MAPGTI (WHCH,IVAL) +C CALL MAPGTL (WHCH,LVAL) +C CALL MAPGTR (WHCH,RVAL) +C +C ARGUMENTS WHCH IS A CHARACTER STRING SPECIFYING THE +C PARAMETER TO GET. +C +C CVAL, IVAL, LVAL, OR RVAL IS A VARIABLE TO +C RECEIVE THE VALUE OF THE PARAMETER SPECIFIED +C BY WHCH - OF TYPE CHARACTER, INTEGER, LOGICAL, +C OR REAL, RESPECTIVELY. +C +C ALL OF THE PARAMETERS LISTED IN THE DISCUSSION +C OF MAPSTX MAY BE RETRIEVED. THE FOLLOWING MAY +C ALSO BE RETRIEVED: +C +C WHCH TYPE MEANING +C ---- ---- ------- +C +C AREA C THE VALUE OF THE MAP LIMITS +C SPECIFIER JLTS FROM THE LAST +C CALL TO MAPSET. THE DEFAULT +C VALUE IS 'MA'. +C +C ERROR I THE CURRENT VALUE OF THE ERROR +C FLAG. DEFAULT IS ZERO. +C +C INITIALIZE I,L INITIALIZATION FLAG. IF TRUE +C (NON-ZERO), EZMAP IS IN NEED +C OF INITIALIZATION (BY MEANS OF +C A CALL MAPINT). THE DEFAULT +C VALUE IS TRUE (NON-ZERO). +C +C PROJECTION C THE VALUE OF THE PROJECTION +C SPECIFIER JPRJ FROM THE LAST +C CALL TO MAPROJ. THE DEFAULT +C VALUE IS 'CE'. +C +C PN I,R THE VALUE OF PLON FROM THE +C LAST CALL TO MAPROJ. THE +C DEFAULT VALUE IS ZERO. +C +C PT I,R THE VALUE OF PLAT FROM THE +C LAST CALL TO MAPROJ. THE +C DEFAULT VALUE IS ZERO. +C +C PN I,R "N" IS AN INTEGER BETWEEN 1 +C AND 8. RETRIEVES VALUES FROM +C THE LAST CALL TO MAPSET. P1 +C THROUGH P4 GET YOU PLM1(1), +C PLM2(1), PLM3(1), AND PLM4(1), +C WHILE P5 THROUGH P8 GET YOU +C PLM1(2), PLM2(2), PLM3(2), AND +C PLM4(2). THE DEFAULT VALUES +C ARE ALL ZERO. +C +C ROTATION I,R THE VALUE OF ROTA FROM THE +C LAST CALL TO MAPROJ. THE +C DEFAULT VALUE IS ZERO. +C +C XLEFT R THE PARAMETERS XLOW, XROW, +C XRIGHT R YBOW, AND YTOW FROM THE LAST +C YBOTTOM R CALL TO MAPPOS. DEFAULTS +C YTOP R ARE .05, .95, .05, AND .95. +C +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P I N T - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO INITIALIZE THE PACKAGE AFTER THE VALUES OF +C SOME PARAMETERS HAVE BEEN CHANGED. THE FLAG +C 'IN', WHICH MAY BE RETRIEVED BY A CALL TO +C MAPGTI OR MAPGTL, INDICATES WHETHER OR NOT +C INITIALIZATION IS REQUIRED AT A GIVEN TIME. +C (SOME PARAMETERS MAY BE RESET AT ANY TIME AND +C DO NOT REQUIRE MAPINT TO BE CALLED AGAIN.) +C +C USAGE CALL MAPINT +C +C ARGUMENTS NONE. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P I T - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW LINES ON THE MAP PRODUCED BY A CALL +C TO MAPDRW. MAPIT ATTEMPTS TO OMIT NON-VISIBLE +C PORTIONS AND TO HANDLE "CROSS-OVER" - A JUMP +C FROM ONE END OF THE MAP TO THE OTHER CAUSED +C BY THE PROJECTION'S HAVING SLIT THE GLOBE +C ALONG SOME HALF OF A GREAT CIRCLE AND LAID IT +C OPEN WITH THE TWO SIDES OF THE SLIT AT OPPOSITE +C ENDS OF THE MAP. CROSS-OVER CAN OCCUR ON +C CYLINDRICAL AND CONICAL PROJECTIONS; MAPIT +C HANDLES IT VERY WELL ON THE FORMER AND NOT SO +C WELL ON THE LATTER. +C +C THE EZMAP PARAMETER 'DL' DETERMINES WHETHER +C MAPIT DRAWS SOLID LINES OR DOTTED LINES. THE +C PARAMETERS 'DD' AND 'MV' ALSO AFFECT MAPIT'S +C BEHAVIOR. SEE THE DESCRIPTION OF THE ROUTINE +C MAPSTX, BELOW. +C +C A SEQUENCE OF CALLS TO MAPIT SHOULD BE FOLLOWED +C BY A CALL TO MAPIQ (WHICH SEE, ABOVE) TO FLUSH +C ITS BUFFERS. +C +C POINTS IN TWO CONTIGUOUS PEN-DOWN CALLS TO +C MAPIT SHOULD NOT BE FAR APART ON THE GLOBE. +C +C USAGE CALL MAPIT (RLAT,RLON,IFST) +C +C ARGUMENTS RLAT AND RLON ARE THE LATITUDE AND LONGITUDE +C OF A POINT TO WHICH THE "PEN" IS TO BE MOVED. +C BOTH ARE GIVEN IN DEGREES. RLAT MUST BE +C BETWEEN -90. AND +90., INCLUSIVE; RLON MUST BE +C BETWEEN -540. AND +540., INCLUSIVE. +C +C IFST IS 0 TO DO A "PEN-UP" MOVE, 1 TO DO A +C "PEN-DOWN" MOVE IF THE DISTANCE FROM THE LAST +C POINT TO THE NEW POINT IS GREATER THAN 'MV' +C PLOTTER UNITS, 2 OR GREATER TO DO THE MOVE +C REGARDLESS OF THE DISTANCE FROM THE LAST POINT +C TO THE NEW ONE. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P I Q - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO FLUSH MAPIT'S BUFFERS. THIS IS PARTICULARLY +C IMPORTANT BEFORE A STOP OR A CALL FRAME AND +C BEFORE CHANGING INTENSITY, DASH PATTERN, COLOR, +C ETC. +C +C USAGE CALL MAPIQ +C +C ARGUMENTS NONE. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P L B L - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO LABEL THE INTERNATIONAL DATE LINE (ID), THE +C EQUATOR (EQ), THE GREENWICH MERIDIAN (GM), AND +C THE POLES (NP AND SP), AND TO DRAW THE BORDER +C AROUND THE MAP. IF EZMAP NEEDS INITIALIZATION +C OR IF THE ERROR FLAG 'ER' IS SET, MAPLBL DOES +C NOTHING. +C +C USAGE CALL MAPLBL +C +C ARGUMENTS NONE. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P L O T - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW THE CONTINENTAL AND/OR INTERNATIONAL +C AND/OR U.S. STATE OUTLINES SELECTED BY THE +C PARAMETER 'OU'. IF EZMAP CURRENTLY NEEDS +C INITIALIZATION OR IF THE ERROR FLAG 'ER' IS +C SET, MAPLOT DOES NOTHING. +C +C USAGE CALL MAPLOT +C +C ARGUMENTS NONE. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P P O S - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO SPECIFY THE POSITION OF THE MAP ON THE +C PLOTTER FRAME. +C +C USAGE CALL MAPPOS (XLOW,XROW,YBOW,YTOW) +C +C ARGUMENTS THE ARGUMENTS ARE FRACTIONS BETWEEN 0 AND 1 +C DETERMINING THE POSITION OF A WINDOW IN THE +C PLOTTER FRAME WITHIN WHICH THE MAP IS TO BE +C DRAWN. XLOW AND XROW POSITION THE LEFT AND +C RIGHT EDGES AND ARE STATED AS FRACTIONS OF THE +C DISTANCE FROM LEFT TO RIGHT IN THE PLOTTER +C FRAME. YBOW AND YTOW POSITION THE BOTTOM AND +C TOP EDGES AND ARE STATED AS FRACTIONS OF THE +C DISTANCE FROM BOTTOM TO TOP IN THE PLOTTER +C FRAME. THE MAP IS CENTERED IN THE SPECIFIED +C WINDOW AND MADE AS LARGE AS POSSIBLE WHILE +C MAINTAINING ITS PROPER SHAPE. +C +C THE DEFAULT VALUES OF THE INTERNAL PARAMETERS +C CHANGED BY THIS ROUTINE ARE .05, .95, .05, AND +C .95, RESPECTIVELY. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P R O J - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO SPECIFY THE PROJECTION TO BE USED. +C +C USAGE CALL MAPROJ (JPRJ,PLAT,PLON,ROTA) +C +C ARGUMENTS JPRJ IS A CHARACTER VARIABLE DEFINING THE +C DESIRED PROJECTION TYPE, AS FOLLOWS: +C +C THE CONIC PROJECTION: +C +C 'LC' - LAMBERT CONFORMAL CONIC WITH TWO +C STANDARD PARALLELS. +C +C THE AZIMUTHAL PROJECTIONS: +C +C 'ST' - STEREOGRAPHIC. +C +C 'OR' - ORTHOGRAPHIC. CAUSES THE PARAMETER +C 'SA' (WHICH SEE, IN THE DESCRIPTION +C OF THE ROUTINE MAPSTX) TO BE ZEROED. +C +C 'LE' - LAMBERT EQUAL AREA. +C +C 'GN' - GNOMONIC. +C +C 'AE' - AZIMUTHAL EQUIDISTANT. +C +C 'SV' - SATELLITE-VIEW. IF THE PARAMETER +C 'SA' (WHICH SEE, IN THE DESCRIPTION +C OF THE ROUTINE MAPSTX) IS GREATER +C THAN 1 OR LESS THAN -1, IT IS LEFT +C ALONE; OTHERWISE, IT IS GIVEN THE +C VALUE 6.631. +C +C THE CYLINDRICAL PROJECTIONS: +C +C 'CE' - CYLINDRICAL EQUIDISTANT. +C +C 'ME' - MERCATOR. +C +C 'MO' - MOLLWEIDE. THE PROJECTION USED IS +C NOT ACTUALLY A TRUE MOLLWEIDE. +C +C PLAT, PLON, AND ROTA ARE REALS SPECIFYING THE +C VALUES OF ANGULAR QUANTITIES, IN DEGREES. HOW +C THEY ARE USED DEPENDS ON THE VALUE OF JPRJ, AS +C FOLLOWS: +C +C IF JPRJ IS NOT EQUAL TO 'LC': PLAT AND PLON +C DEFINE THE LATITUDE AND LONGITUDE OF THE POLE +C OF THE PROJECTION - THE POINT ON THE GLOBE +C WHICH IS TO BE PROJECTED TO THE ORIGIN OF THE +C U/V PLANE. PLAT MUST BE BETWEEN -90. AND +90., +C INCLUSIVE, POSITIVE IN THE NORTHERN HEMISPHERE, +C NEGATIVE IN THE SOUTHERN. PLON MUST BE BETWEEN +C -180. AND +180., INCLUSIVE, POSITIVE TO THE +C EAST, AND NEGATIVE TO THE WEST, OF GREENWICH. +C ROTA IS THE ANGLE BETWEEN THE V AXIS AND NORTH +C AT THE ORIGIN. IT IS TAKEN TO BE POSITIVE IF +C THE ANGULAR MOVEMENT FROM NORTH TO THE V AXIS +C IS COUNTER-CLOCKWISE, NEGATIVE OTHERWISE. IF +C THE ORIGIN IS AT THE NORTH POLE, "NORTH" IS +C CONSIDERED TO BE IN THE DIRECTION OF PLON+180. +C IF THE ORIGIN IS AT THE SOUTH POLE, "NORTH" IS +C CONSIDERED TO BE IN THE DIRECTION OF PLON. +C FOR THE CYLINDRICAL PROJECTIONS, THE AXIS OF +C THE PROJECTION IS PARALLEL TO THE V AXIS. +C +C IF JPRJ IS EQUAL TO 'LC' (LAMBERT CONFORMAL +C CONIC WITH TWO STANDARD PARALLELS): PLON +C DEFINES THE CENTRAL MERIDIAN OF THE PROJECTION, +C WHILE PLAT AND ROTA DEFINE THE TWO STANDARD +C PARALLELS. IF PLAT AND ROTA ARE EQUAL, A +C CONIC PROJECTION WITH ONE STANDARD PARALLEL +C IS USED. +C +C MORE DETAILED DESCRIPTIONS OF THE PROJECTIONS +C MAY BE FOUND IN THE GRAPHICS MANUAL, TOGETHER +C WITH HELPFUL DIAGRAMS, BUT A FEW WORDS MAY BE +C HELPFUL HERE: +C +C THE CONICAL PROJECTION MAPS THE SURFACE OF THE +C EARTH ONTO THE SURFACE OF A CONE INTERSECTING +C THE EARTH ALONG THE TWO STANDARD PARALLELS. +C THE CONE IS THEN SLIT ALONG A LINE OPPOSITE +C THE CENTRAL MERIDIAN AND OPENED UP (WITH SOME +C STRETCHING) ONTO A FLAT SURFACE. +C +C THE AZIMUTHAL PROJECTIONS MAP THE SURFACE OF +C THE EARTH (OR OF ONE HEMISPHERE OF THE EARTH) +C ONTO A PLANE WHOSE ORIGIN IS TANGENT TO IT AT +C THE POINT (PLAT,PLON). THE SEVERAL AZIMUTHAL +C PROJECTIONS DIFFER ONLY IN THE FUNCTION USED +C TO MAP THE GREAT-CIRCLE DISTANCE OF A POINT +C FROM THE POLE (PLAT,PLON) TO A LINEAR DISTANCE +C OF THE PROJECTED POINT FROM THE ORIGIN (0,0). +C THE PROJECTED IMAGE MAY BE ROTATED USING THE +C PARAMETER ROTA. +C +C THE CYLINDRICAL PROJECTIONS MAP THE SURFACE OF +C THE EARTH ONTO A CYLINDER WHICH IS TANGENT TO +C IT ALONG A GREAT CIRCLE PASSING THROUGH THE +C POINT (PLAT,PLON) AT AN ANGLE DETERMINED BY +C ROTA. THE CYLINDER IS THEN SLIT ALONG ITS +C LENGTH THROUGH THE POINT OPPOSITE (PLAT,PLON) +C AND OPENED UP ONTO THE PLANE. THE SEVERAL +C CYLINDRICAL PROJECTIONS DIFFER PRINCIPALLY IN +C THE FUNCTION USED TO MAP THE DISTANCE FROM THE +C GREAT CIRCLE OF TANGENCY TO A DISTANCE ALONG +C THE CYLINDER. IF PLAT IS ZERO AND ROTA IS +C EITHER 0. OR 180., THE CYLINDRICAL PROJECTIONS +C ARE PARTICULARLY SIMPLE TO DO AND A FASTER PATH +C THROUGH THE CODE IS USED. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P R S - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE RECALLS SET. INTENDED TO BE USED WHEN DATA +C IS TO BE PLOTTED OVER A MAP GENERATED IN A +C DIFFERENT OVERLAY (E.G., USING A FLASH BUFFER), +C AND WHEN THE SYSTEM PLOT PACKAGE DOES NOT +C RESIDE IN AN OUTER OVERLAY. +C +C USAGE CALL MAPRS +C +C ARGUMENTS NONE. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P R S T - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE RESTORES A SAVED STATE OF EZMAP. THIS IS DONE +C BY READING SAVED PARAMETER VALUES FROM A USER +C UNIT AND THEN CALLING MAPINT. SEE MAPSAV. +C +C USAGE CALL MAPRST (IFNO) +C +C ARGUMENTS IFNO IS THE NUMBER OF A UNIT FROM WHICH A +C SINGLE UNFORMATTED RECORD IS TO BE READ. IT +C IS THE USER'S RESPONSIBILITY TO POSITION THIS +C UNIT. MAPRST DOES NOT REWIND IT, EITHER BEFORE +C OR AFTER READING THE RECORD. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P S A V - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE SAVES THE CURRENT STATE OF EZMAP BY WRITING +C PARAMETER VALUES ONTO A USER UNIT. SEE MAPRST. +C +C USAGE CALL MAPSAV (IFNO) +C +C ARGUMENTS IFNO IS THE NUMBER OF A UNIT TO WHICH A SINGLE +C UNFORMATTED RECORD IS TO BE WRITTEN. IT IS THE +C USER'S RESPONSIBILITY TO POSITION THIS UNIT. +C MAPSAV DOES NOT REWIND IT, EITHER BEFORE OR +C AFTER WRITING THE RECORD. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P S E T - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO SPECIFY THE RECTANGULAR PORTION OF THE U/V +C PLANE TO BE DRAWN. +C +C USAGE CALL MAPSET (JLTS,PLM1,PLM2,PLM3,PLM4) +C +C ARGUMENTS JLTS CAN HAVE THE FOLLOWING CHARACTER VALUES. +C IT SPECIFIES ONE OF FIVE WAYS IN WHICH THE +C LIMITS OF THE MAP ARE DEFINED BY THE PARAMETERS +C PLM1, PLM2, PLM3, AND PLM4. +C +C JLTS='MA' (MAXIMUM). THE MAXIMUM USEFUL AREA +C PRODUCED BY THE PROJECTION IS PLOTTED. PLM1, +C PLM2, PLM3, AND PLM4 ARE NOT USED. +C +C JLTS='CO' (CORNERS). THE POINTS (PLM1,PLM2) +C AND (PLM3,PLM4) ARE TO BE AT OPPOSITE CORNERS +C OF THE MAP. PLM1 AND PLM3 ARE LATITUDES, IN +C DEGREES. PLM2 AND PLM4 ARE LONGITUDES, IN +C DEGREES. IF A CYLINDRICAL PROJECTION IS BEING +C USED, THE FIRST POINT SHOULD BE ON THE LEFT +C EDGE OF THE MAP AND THE SECOND POINT ON THE +C RIGHT EDGE; OTHERWISE, THE ORDER MAKES NO +C DIFFERENCE. +C +C JLTS='PO' (POINTS). PLM1, PLM2, PLM3, AND PLM4 +C ARE TWO-ELEMENT ARRAYS GIVING THE LATITUDES +C AND LONGITUDES, IN DEGREES, OF FOUR POINTS +C WHICH ARE TO BE ON THE EDGES OF THE RECTANGULAR +C MAP. IF A CYLINDRICAL PROJECTION IS BEING +C USED, THE FIRST POINT SHOULD BE ON THE LEFT +C EDGE AND THE SECOND POINT ON THE RIGHT EDGE; +C OTHERWISE, THE ORDER MAKES NO DIFFERENCE. +C NOTE THAT THE CALLING PROGRAM SHOULD INCLUDE +C THE FOLLOWING STATEMENT: +C +C DIMENSION PLM1(2),PLM2(2),PLM3(2),PLM4(2) +C +C (IN FACT, STRICT ADHERENCE TO THE FORTRAN-77 +C STANDARD REQUIRES THIS, NO MATTER WHAT THE +C VALUE OF JLTS.) +C +C JLTS='AN' (ANGLES). PLM1, PLM2, PLM3, AND PLM4 +C ARE POSITIVE ANGLES, IN DEGREES, REPRESENTING +C ANGULAR DISTANCES FROM A POINT ON THE MAP TO +C THE LEFT, RIGHT, BOTTOM, AND TOP EDGES OF THE +C MAP. FOR MOST PROJECTIONS, THESE ANGLES ARE +C MEASURED WITH THE CENTER OF THE EARTH AT THE +C VERTEX AND REPRESENT ANGULAR DISTANCES FROM THE +C POINT WHICH PROJECTS TO THE ORIGIN OF THE U/V +C PLANE; ON A SATELLITE-VIEW PROJECTION, THEY ARE +C MEASURED WITH THE SATELLITE AT THE VERTEX AND +C REPRESENT ANGULAR DEVIATIONS FROM THE LINE OF +C SIGHT. ANGULAR LIMITS ARE PARTICULARLY USEFUL +C FOR POLAR PROJECTIONS AND THE SATELLITE-VIEW +C PROJECTION; THEY ARE NOT APPROPRIATE FOR THE +C LAMBERT CONFORMAL CONIC AND AN ERROR WILL +C RESULT IF ONE ATTEMPTS TO USE JLTS='AN' WITH +C JPRJ='LC'. +C +C JLTS='LI' (LIMITS). PLM1, PLM2, PLM3, AND PLM4 +C SPECIFY THE MINIMUM VALUE OF U, THE MAXIMUM +C VALUE OF U, THE MINIMUM VALUE OF V, AND THE +C MAXIMUM VALUE OF V, RESPECTIVELY. KNOWLEDGE +C OF THE PROJECTION EQUATIONS IS NECESSARY IN +C ORDER TO USE THIS OPTION CORRECTLY. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P S T X - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO SET THE VALUES OF EZMAP PARAMETERS. +C +C USAGE CALL MAPSTC (WHCH,CVAL) +C CALL MAPSTI (WHCH,IVAL) +C CALL MAPSTL (WHCH,LVAL) +C CALL MAPSTR (WHCH,RVAL) +C +C ARGUMENTS WHCH IS A CHARACTER STRING SPECIFYING THE +C PARAMETER TO BE SET. +C +C CVAL, IVAL, LVAL, OR RVAL IS THE VALUE TO BE +C GIVEN TO THE PARAMETER SPECIFIED BY WHCH - OF +C TYPE CHARACTER, INTEGER, LOGICAL, OR REAL, +C RESPECTIVELY. +C +C SOME PARAMETERS MAY BE SET IN MORE THAN ONE +C WAY. FOR EXAMPLE, THE PARAMETER 'GR' (GRID), +C WHICH SPECIFIES THE GRID SPACING, MAY BE GIVEN +C THE VALUE 10.0 IN EITHER OF TWO WAYS: +C +C CALL MAPSTI ('GR',10) +C CALL MAPSTR ('GR',10.) +C +C THE FLAG WHICH CONTROLS DOTTING OF OUTLINES +C MAY BE TURNED ON USING EITHER OF THESE CALLS: +C +C CALL MAPSTI ('DO',1) +C CALL MAPSTL ('DO',.TRUE.) +C +C THE IMPORTANT POINT TO REMEMBER IS THAT THE +C LAST CHARACTER OF THE ROUTINE NAME IMPLIES +C THE TYPE OF THE ARGUMENT. +C +C ONLY THE FIRST TWO CHARACTERS OF WHCH ARE +C EXAMINED. FOR THE SAKE OF CODE READABILITY, +C A LONGER CHARACTER STRING MAY BE USED. +C +C BELOW IS A LIST OF ALL THE PARAMETERS WHICH +C MAY BE SET USING THESE ROUTINES. +C +C WHCH TYPE MEANING +C ---- ---- ------- +C +C DASHPATTERN I DASHED-LINE PATTERN FOR THE +C GRIDS. A 16-BIT QUANTITY. +C DEFAULT IS 21845 (OCTAL 52525 +C OR BINARY 0101010101010101). +C +C DD I,R DISTANCE BETWEEN DOTS ALONG A +C DOTTED LINE DRAWN BY MAPIT. +C THE DEFAULT VALUE IS 12 (OUT +C OF 4096; SEE 'RE', BELOW). +C +C DL I,L IF TRUE (NON-ZERO), USER CALLS +C TO MAPIT DRAW DOTTED LINES. +C DEFAULT IS FALSE (ZERO); LINES +C DRAWN BY MAPIT ARE SOLID OR +C DASHED, DEPENDING ON THE +C CURRENT STATE OF THE DASHCHAR +C PACKAGE. +C +C DOT I,L IF TRUE (NON-ZERO), OUTLINES +C ARE DOTTED. DEFAULT IS FALSE +C (ZERO); OUTLINES ARE SOLID. +C +C ELLIPTICAL I,L IF TRUE (NON-ZERO), ONLY THAT +C PART OF THE MAP WHICH FALLS +C INSIDE AN ELLIPSE INSCRIBED +C WITHIN THE NORMAL RECTANGULAR +C PERIMETER IS DRAWN. THIS IS +C PARTICULARLY APPROPRIATE FOR +C USE WITH AZIMUTHAL PROJECTIONS +C AND ANGULAR LIMITS SPECIFYING +C A SQUARE, IN WHICH CASE THE +C ELLIPSE BECOMES A CIRCLE, BUT +C IT WILL WORK FOR ANY MAP. THE +C DEFAULT VALUE IS ZERO. +C +C GD R THE DISTANCE BETWEEN POINTS +C USED TO DRAW THE GRID, IN +C DEGREES. THE DEFAULT VALUE +C IS 1.; USER VALUES MUST FALL +C BETWEEN .001 AND 10. +C +C GRID I,R THE DESIRED GRID SPACING. A +C ZERO SUPPRESSES THE GRID. THE +C DEFAULT IS 10 DEGREES. +C +C IN I "N" IS AN INTEGER BETWEEN 1 +C AND 7. EACH "IN" SPECIFIES +C THE INTENSITY OF SOME PORTION +C OF THE MAP. VALUES ARE IN THE +C RANGE 0-255. DEFAULTS ARE: +C +C N USE DEFAULT +C - ----------- ------- +C 1 PERIMETER 240 +C 2 GRID 150 +C 3 LABELS 210 +C 4 LIMBS 240 +C 5 CONTINENTS 240 +C 6 U.S. STATES 180 +C 7 COUNTRIES 210 +C +C LABEL I,L IF TRUE (NON-ZERO), LABEL THE +C MERIDIANS AND POLES. DEFAULT +C IS TRUE (NON-ZERO). +C +C LS I CONTROLS LABEL SIZE. A +C CHARACTER WIDTH, TO BE USED +C IN CALLING PWRIT. THE DEFAULT +C VALUE IS 1, WHICH GIVES A +C CHARACTER WIDTH OF 12 PLOTTER +C UNITS. +C +C MV I,R MINIMUM VECTOR LENGTH FOR +C OUTLINES. A POINT CLOSER TO +C THE PREVIOUS POINT THAN THIS +C IS OMITTED. DEFAULT VALUE IS +C 4 (OUT OF 4096; SEE 'RE', +C BELOW). +C +C OUTLINE C SAYS WHICH SET OF OUTLINE DATA +C TO USE. POSSIBLE VALUES ARE +C 'NO', FOR NO OUTLINES, 'CO', +C FOR THE CONTINENTAL OUTLINES +C (THE DEFAULT), 'US', FOR U.S. +C STATE OUTLINES, 'PS', FOR +C CONTINENTAL OUTLINES PLUS +C INTERNATIONAL OUTLINES PLUS +C U.S. STATE OUTLINES, AND 'PO', +C FOR CONTINENTAL OUTLINES PLUS +C INTERNATIONAL OUTLINES. +C DEFAULT IS 'CO'. +C +C PERIM I,L IF TRUE (NON-ZERO), DRAW THE +C PERIMETER. DEFAULT IS TRUE +C (NON-ZERO). +C +C RESOLUTION I,R THE WIDTH OF THE TARGET +C PLOTTER, IN PLOTTER UNITS. +C DEFAULT VALUE IS 4096. +C +C SATELLITE I,R IF LESS THAN -1 OR GREATER +C THAN 1, CHANGES ORTHOGRAPHIC +C PROJECTION TO SATELLITE-VIEW. +C ABSOLUTE VALUE IS THE DISTANCE +C OF SATELLITE FROM THE CENTER +C OF THE EARTH, IN MULTIPLES OF +C THE EARTH'S RADIUS. THE SIGN +C INDICATES WHETHER A NORMAL +C PROJECTION (POSITIVE) OR AN +C EXTENDED PROJECTION (NEGATIVE) +C IS TO BE USED. THE EXTENDED +C PROJECTION IS USEFUL WHEN ONE +C IS OVERLAYING CONREC OUTPUT ON +C A MAP. THE DEFAULT VALUE OF +C 'SA' IS ZERO. SEE ALSO 'S1' +C AND 'S2', BELOW. +C +C S1 AND S2 I,R USED ONLY WHEN 'SA' IS OUTSIDE +C [-1,1]. BOTH ARE ANGLES, IN +C DEGREES. 'S1' MEASURES THE +C ANGLE BETWEEN THE CENTER OF +C THE EARTH AND THE AIM POINT +C OF THE SATELLITE'S CAMERA, AS +C SEEN FROM THE SATELLITE. IF +C 'S1' IS ZERO, THE PROJECTION +C SHOWS THE EARTH AS SEEN BY A +C SATELLITE LOOKING STRAIGHT +C DOWN; CALL THIS THE "BASIC +C VIEW". IF 'S1' IS NON-ZERO, +C 'S2' MEASURES THE ANGLE FROM +C THE POSITIVE U AXIS OF THE +C BASIC VIEW TO THE LINE OP, +C WHERE O IS THE ORIGIN OF THE +C BASIC VIEW AND P IS THE +C PROJECTION OF THE DESIRED LINE +C OF SIGHT ON THE BASIC VIEW, +C POSITIVE IF MEASURED COUNTER- +C CLOCKWISE. +C +C SR R A SEARCH RADIUS, IN DEGREES. +C USED BY MAPINT IN FINDING THE +C LATITUDE/LONGITUDE RANGE OF +C THE MAP. THE DEFAULT VALUE +C IS 1.; USER VALUES MUST FALL +C BETWEEN .001 AND 10. THIS +C PARAMETER SHOULD PROBABLY NOT +C BE CHANGED EXCEPT BY ADVICE +C OF A KNOWLEDGEABLE CONSULTANT. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P T R N - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO FIND THE PROJECTION IN THE U/V PLANE OF A +C POINT WHOSE LATITUDE AND LONGITUDE ARE KNOWN. +C MAY BE CALLED AT ANY TIME AFTER EZMAP HAS BEEN +C INITIALIZED (BY CALLING MAPINT OR OTHERWISE). +C +C USAGE CALL MAPTRN (RLAT,RLON,UVAL,VVAL) +C +C ARGUMENTS RLAT AND RLON ARE THE LATITUDE AND LONGITUDE, +C RESPECTIVELY, OF A POINT ON THE GLOBE. RLAT +C MUST BE BETWEEN -90. AND +90., INCLUSIVE; RLON +C MUST BE BETWEEN -540. AND +540., INCLUSIVE. +C +C (UVAL,VVAL) IS THE PROJECTION IN THE U/V PLANE +C OF (RLAT,RLON). THE UNITS OF UVAL AND VVAL +C DEPEND ON THE PROJECTION. +C +C IF THE POINT IS NOT PROJECTABLE, UVAL IS +C RETURNED EQUAL TO 1.E12. NOTE THAT, IF +C THE POINT IS PROJECTABLE, BUT OUTSIDE THE +C BOUNDARY OF THE MAP, AS DEFINED BY THE LAST +C CALL TO MAPSET, ITS U AND V COORDINATES ARE +C STILL RETURNED BY MAPTRN. THE USER MUST DO +C THE TEST REQUIRED TO DETERMINE IF THE POINT +C IS WITHIN LIMITS, IF THAT IS NECESSARY. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P U S R - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE THE ROUTINE MAPUSR IS CALLED BY EZMAP JUST +C BEFORE AND JUST AFTER PORTIONS OF THE MAP +C ARE DRAWN. THE DEFAULT VERSION DOES NOTHING. +C (ACTUALLY, THAT'S NOT QUITE TRUE; FOR THE SAKE +C OF EFFICIENCY, THE NON-GKS VERSIONS RESETS THE +C DASH PATTERN FOR GRID LINES TO "SOLID" AND +C THEN DOES AN OPTN CALL TO MAKE THE TRANSLATOR +C GENERATE THE DESIRED PATTERN.) A USER-SUPPLIED +C VERSION MAY SET/RESET THE DOTTING PARAMETER +C 'DL', THE DASHCHAR DASH PATTERN, THE INTENSITY, +C THE COLOR, ETC., SO AS TO ACHIEVE A DESIRED +C EFFECT. +C +C USAGE (BY EZMAP) CALL MAPUSR (IPRT) +C +C ARGUMENTS IPRT, IF POSITIVE, SAYS THAT A PARTICULAR PART +C OF THE MAP IS ABOUT TO BE DRAWN, AS FOLLOWS: +C +C IPRT PART +C ---- ----------------------- +C 1 PERIMETER. +C 2 GRID. +C 3 LABELS. +C 4 LIMB LINES. +C 5 CONTINENTAL OUTLINES. +C 6 U.S. STATE OUTLINES. +C 7 INTERNATIONAL OUTLINES. +C +C IF IPRT IS NEGATIVE, IT SAYS THAT DRAWING OF +C THE LAST PART IS COMPLETE. THE ABSOLUTE VALUE +C OF IPRT WILL BE ONE OF THE ABOVE VALUES. +C CHANGED QUANTITIES SHOULD BE RESTORED. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E M A P V E C - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW LINES ON THE MAP PRODUCED BY A CALL TO +C MAPDRW - USED IN CONJUNCTION WITH MAPFST. +C +C USAGE CALL MAPVEC (RLAT,RLON) +C +C THIS CALL IS EXACTLY EQUIVALENT TO THE CALL +C +C CALL MAPIT (RLAT,RLON,1) +C +C ARGUMENTS RLAT AND RLON ARE DEFINED AS FOR MAPIT. SEE +C THE DESCRIPTION OF MAPIT. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E S U P C O N - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE TO FIND THE PROJECTION IN THE U/V PLANE OF A +C POINT WHOSE LATITUDE AND LONGITUDE ARE KNOWN. +C THIS ROUTINE IS PROVIDED FOR COMPATIBILITY +C WITH EARLIER VERSIONS OF THE PACKAGE. IF +C EFFICIENCY IS A CONSIDERATION, THE USER SHOULD +C BY-PASS THIS ROUTINE AND CALL MAPTRN DIRECTLY. +C +C USAGE CALL SUPCON (RLAT,RLON,UVAL,VVAL) +C +C THIS CALL IS EXACTLY EQUIVALENT TO THE CALL +C +C CALL MAPTRN (RLAT,RLON,UVAL,VVAL) +C +C ARGUMENTS RLAT, RLON, UVAL, AND VVAL ARE DEFINED AS FOR +C THE ROUTINE MAPTRN. SEE THE DESCRIPTION OF +C MAPTRN. +C +C----------------------------------------------------------------------- +C S U B R O U T I N E S U P M A P - D E S C R I P T I O N +C----------------------------------------------------------------------- +C +C PURPOSE AN IMPLEMENTATION OF THE ROUTINE FROM WHICH +C EZMAP GREW. A SINGLE CALL TO SUPMAP CREATES +C A MAP OF A DESIRED PORTION OF THE GLOBE, +C ACCORDING TO A DESIRED PROJECTION, WITH DESIRED +C OUTLINES DRAWN IN, AND WITH LINES OF LATITUDE +C AND LONGITUDE AT DESIRED INTERVALS. AN +C APPROPRIATE CALL TO THE ROUTINE SET IS +C PERFORMED, AND THE ROUTINE SUPCON (WHICH SEE) +C IS INITIALIZED SO THAT THE USER MAY MAP POINTS +C OF KNOWN LATITUDE AND LONGITUDE TO POINTS IN +C THE U/V PLANE AND USE THE U/V COORDINATES TO +C DRAW OBJECTS ON THE MAP PRODUCED BY SUPMAP. +C +C USAGE CALL SUPMAP (JPRJ,PLAT,PLON,ROTA,PLM1,PLM2, +C PLM3,PLM4,JLTS,JGRD,IOUT,IDOT, +C IERR) +C +C ARGUMENTS IABS(JPRJ) DEFINES THE PROJECTION TYPE, AS +C FOLLOWS (VALUES LESS THAN 1 OR GREATER THAN +C 10 ARE TREATED AS 1 OR 10, RESPECTIVELY): +C +C 1 STEREOGRAPHIC. +C 2 ORTHOGRAPHIC. +C 3 LAMBERT CONFORMAL CONIC. +C 4 LAMBERT EQUAL AREA. +C 5 GNOMONIC. +C 6 AZIMUTHAL EQUIDISTANT. +C 7 SATELLITE VIEW. +C 8 CYLINDRICAL EQUIDISTANT. +C 9 MERCATOR. +C 10 MOLLWEIDE. +C +C USING THE VALUE 2 CAUSES THE PARAMETER 'SA' TO +C BE ZEROED. USING THE VALUE 7 CAUSES 'SA' TO +C BE EXAMINED. IF IT HAS A NON-ZERO VALUE, THE +C VALUE IS LEFT ALONE. IF IT HAS A ZERO VALUE, +C ITS VALUE IS RESET TO 6.631, WHICH IS ABOUT +C RIGHT FOR A SATELLITE IN A GEOSYNCHRONOUS +C EQUATORIAL ORBIT (FOR WHATEVER THAT'S WORTH). +C +C THE SIGN OF JPRJ, WHEN IOUT IS -1, 0, OR 1, +C INDICATES WHETHER THE CONTINENTAL OUTLINES ARE +C TO BE PLOTTED OR NOT. SEE IOUT, BELOW. +C +C PLAT, PLON, AND ROTA DEFINE THE ORIGIN OF THE +C PROJECTION AND ITS ROTATION ANGLE AND ARE USED +C IN THE SAME WAY AS THEY WOULD BE IN A CALL TO +C THE ROUTINE MAPROJ (WHICH SEE). +C +C JLTS, PLM1, PLM2, PLM3, AND PLM4 SPECIFY THE +C RECTANGULAR LIMITS OF THE MAP. THESE ARGUMENTS +C ARE USED IN THE SAME WAY AS THEY WOULD BE IN +C A CALL TO MAPSET (WHICH SEE), EXCEPT THAT JLTS +C IS AN INTEGER INSTEAD OF A CHARACTER STRING. +C IABS(JLTS) MAY TAKE ON THE VALUES 1 THROUGH 5, +C AS FOLLOWS: +C +C 1 LIKE JLTS='MA' IN A CALL TO MAPSET. +C 2 LIKE JLTS='CO' IN A CALL TO MAPSET. +C 3 LIKE JLTS='LI' IN A CALL TO MAPSET. +C 4 LIKE JLTS='AN' IN A CALL TO MAPSET. +C 5 LIKE JLTS='PO' IN A CALL TO MAPSET. +C +C AT ONE TIME, THE SIGN OF JLTS SPECIFIED WHETHER +C OR NOT A LINE OF TEXT WAS TO BE WRITTEN AT THE +C BOTTOM OF THE PLOT PRODUCED. THIS LINE MAY NO +C LONGER BE WRITTEN AND THE SIGN OF JLTS IS +C THEREFORE IGNORED. +C +C MOD(IABS(JGRD),1000) IS THE VALUE, IN DEGREES, +C OF THE INTERVAL AT WHICH LINES OF LATITUDE AND +C LONGITUDE ARE TO BE PLOTTED. IF THE GIVEN +C INTERVAL IS ZERO, GRID LINES AND LABELS ARE +C NOT PLOTTED. IF JGRD IS LESS THAN ZERO, THE +C PERIMETER IS NOT PLOTTED. SET JGRD TO -1000 TO +C SUPPRESS BOTH GRID LINES AND PERIMETER AND TO +C +1000 TO SUPPRESS THE GRID LINES, BUT LEAVE THE +C PERIMETER. THE VALUE -0 MAY HAVE A MEANING ON +C ONES' COMPLEMENT MACHINES, BUT SHOULD BE +C AVOIDED; USE -1000 INSTEAD. +C +C IF IOUT HAS THE VALUE 0, U.S. STATE OUTLINES +C ARE OMITTED. IF IT HAS THE ABSOLUTE VALUE 1, +C THEY ARE PLOTTED. IN BOTH OF THESE CASES, THE +C SIGN OF JPRJ INDICATES WHETHER CONTINENTAL +C OUTLINES ARE TO BE PLOTTED (JPRJ POSITIVE) +C OR NOT (JPRJ NEGATIVE). ORIGINALLY, SUPMAP +C RECOGNIZED ONLY THESE VALUES OF IOUT; NOW, IF +C IOUT IS LESS THAN -1 OR GREATER THAN 1, THE +C SIGN OF JPRJ IS IGNORED, AND IOUT SELECTS AN +C OUTLINE GROUP, AS FOLLOWS: +C +C -2 OR LESS 'NO' (NO OUTLINES). +C 2 'CO' (CONTINENTAL OUTLINES). +C 3 'US' (U.S. STATE OUTLINES). +C 4 'PS' (CONTINENTAL OUTLINES +C PLUS INTERNATIONAL +C OUTLINES PLUS U.S. +C STATE OUTLINES). +C 5 OR GREATER 'PO' (CONTINENTAL OUTLINES +C PLUS INTERNATIONAL +C OUTLINES, BUT NO U.S. +C STATE OUTLINES). +C +C AT ONE TIME, THE SIGN OF IOUT SPECIFIED WHETHER +C OR NOT A LINE OF TEXT WAS TO BE WRITTEN ON THE +C PRINT OUTPUT. THIS MAY NO LONGER BE DONE. +C +C IDOT=0 TO GET CONTINUOUS OUTLINES, 1 TO GET +C DOTTED OUTLINES. +C +C IERR IS AN OUTPUT PARAMETER. A NON-ZERO VALUE +C INDICATES THAT AN ERROR HAS OCCURRED. +C +C*********************************************************************** +C T H E C O D E - U S E R - L E V E L R O U T I N E S +C*********************************************************************** +C + SUBROUTINE MAPDRW +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPDRW','VERSION 1') +C +C INITIALIZE THE PACKAGE, DRAW AND LABEL THE GRID, AND DRAW OUTLINES. +C + IF (INTF) CALL MAPINT + CALL MAPGRD + CALL MAPLBL + CALL MAPLOT +C + RETURN + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPEOS (NOUT,NSEG,IGID,NPTS,PNTS) + DIMENSION PNTS(*) + RETURN + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPFST (XLAT,XLON) + CALL MAPIT (XLAT,XLON,0) + RETURN + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPGRD +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM1/ IPRJ,SINO,COSO,SINR,COSR,PHOC + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMB/ IIER +C +C DEFINE LOCAL LOGICAL FLAGS. +C + LOGICAL IMF,IPF +C +C DEFINE REQUIRED CONSTANTS. +C + DATA DTOR / .017453292519943 / +C +C THE ARITHMETIC STATEMENT FUNCTIONS FLOOR AND CLING GIVE, RESPECTIVELY, +C THE "FLOOR" OF X - THE LARGEST INTEGER LESS THAN OR EQUAL TO X - AND +C THE "CEILING" OF X - THE SMALLEST INTEGER GREATER THAN OR EQUAL TO X. +C + FLOOR(X)=AINT(X+1.E4)-1.E4 + CLING(X)=-FLOOR(-X) +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPGRD','VERSION 1') +C +C IF EZMAP NEEDS INITIALIZATION OR IF AN ERROR HAS OCCURRED SINCE THE +C LAST INITIALIZATION, DO NOTHING. +C + IF (INTF) RETURN + IF (IIER.NE.0) RETURN +C +C IF THE GRID IS SUPPRESSED, DO NOTHING. +C + IF (GRID.LE.0.) RETURN +C +C RESET THE INTENSITY, DOTTING, AND DASH PATTERN FOR THE GRID. +C + CALL MAPCHI (2,0,IDSH) +C +C SET THE FLAGS IMF AND IPF, WHICH ARE TRUE IF AND ONLY IF MERIDIANS AND +C PARALLELS, RESPECTIVELY, ARE STRAIGHT LINES AND IT IS "SAFE" TO DRAW +C THEM USING LONG LINE SEGMENTS. WHAT WE HAVE TO BE SURE OF IS THAT AT +C LEAST ONE OF THE TWO ENDPOINTS OF EACH MERIDIAN, OR ITS MIDPOINT, WILL +C BE VISIBLE. (IF TWO POINTS ARE INVISIBLE, MAPIT DRAWS NOTHING, EVEN +C THOUGH THE LINE JOINING THEM MAY BE VISIBLE ALONG PART OF ITS LENGTH.) +C + IF (IPRJ.GE.1.AND.IPRJ.LE.6) THEN + IF (ELPF) THEN + IMF=(UCEN/URNG)**2+(VCEN/VRNG)**2.LT.1. + ELSE + IMF=UMIN*UMAX.LT.0..AND.VMIN*VMAX.LT.0. + END IF + IF (IPRJ.NE.1) IMF=IMF.AND.ABS(PHIA).GE.89.9999 + ELSE IF (IPRJ.EQ.10) THEN + IMF=.TRUE. + ELSE IF (IPRJ.EQ.11.AND.(.75*(VMAX-VMIN)).LE.VEPS) THEN + IMF=.TRUE. + ELSE + IMF=.FALSE. + END IF +C + IPF=IPRJ.EQ.10.OR.IPRJ.EQ.11.OR.(IPRJ.EQ.12.AND.ILTS.EQ.1) +C +C TRANSFER THE LATITUDE/LONGITUDE LIMITS COMPUTED BY MAPINT TO LOCAL, +C MODIFIABLE VARIABLES. +C + SLAT=SLAM + BLAT=BLAM + SLON=SLOM + BLON=BLOM +C +C FOR CERTAIN AZIMUTHAL PROJECTIONS CENTERED AT A POLE, THE LATITUDE +C LIMIT FURTHEST FROM THE POLE NEEDS ADJUSTMENT TO MAKE IT PROJECTABLE +C AND VISIBLE. OTHERWISE, WE HAVE TROUBLE WITH PORTIONS OF MERIDIANS +C DISAPPEARING. +C + IF (IPRJ.EQ.3.OR.IPRJ.EQ.4.OR.IPRJ.EQ.6) THEN + IF (PHIA.GT.+89.9999) THEN + SLAT=SLAT+SRCH + IF (IPRJ.EQ.3) SLAT=SLAT+SRCH + END IF + IF (PHIA.LT.-89.9999) THEN + BLAT=BLAT-SRCH + IF (IPRJ.EQ.3) BLAT=BLAT-SRCH + END IF + END IF +C +C RLON IS THE SMALLEST LONGITUDE FOR WHICH A MERIDIAN IS TO BE DRAWN, +C XLON THE BIGGEST. AVOID DRAWING A GIVEN MERIDIAN TWICE. +C + RLON=GRID*FLOOR(SLON/GRID) + XLON=GRID*CLING(BLON/GRID) + IF (XLON-RLON.GT.359.9999) THEN + IF (IPRJ.EQ.1) THEN + RLON=GRID*CLING((PHIO-179.9999)/GRID) + XLON=GRID*FLOOR((PHIO+179.9999)/GRID) + ELSE IF (IPRJ.GE.2.AND.IPRJ.LE.9) THEN + XLON=XLON-GRID + IF (XLON-RLON.GT.359.9999) XLON=XLON-GRID + END IF + END IF +C +C OLAT IS THE LATITUDE AT WHICH MERIDIANS WHICH ARE NOT MULTIPLES OF 90 +C ARE TO STOP. (EXCEPT ON CERTAIN FAST-PATH CYLINDRICAL PROJECTIONS, +C ONLY THE MERIDIANS AT LONGITUDES WHICH ARE MULTIPLES OF 90 RUN ALL +C THE WAY TO THE POLES. THIS AVOIDS A LOT OF CLUTTER.) +C + IF (IPRJ.EQ.10.OR.IPRJ.EQ.11) THEN + OLAT=90. + ELSE + OLAT=GRID*FLOOR(89.9999/GRID) + END IF +C +C DRAW THE MERIDIANS. +C + RLON=RLON-GRID + 101 RLON=RLON+GRID + XLAT=OLAT + IF (AMOD(RLON,90.).EQ.0.) XLAT=90. + RLAT=AMAX1(SLAT,-XLAT) + XLAT=AMIN1(BLAT,XLAT) + IF (IMF) THEN + DLAT=.5*(XLAT-RLAT) + ELSE + DLAT=(XLAT-RLAT)/CLING((XLAT-RLAT)/GRDR) + END IF + CALL MAPIT (RLAT,RLON,0) + 102 RLAT=RLAT+DLAT + CALL MAPIT (RLAT,RLON,1) + IF (RLAT.LT.XLAT-.9999) GO TO 102 + IF (RLON.LT.XLON-.9999) GO TO 101 +C +C ROUND THE LATITUDE LIMITS TO APPROPRIATE MULTIPLES OF GRID. +C + SLAT=GRID*FLOOR(SLAT/GRID) + IF (SLAT.LE.-90.) SLAT=SLAT+GRID + BLAT=GRID*CLING(BLAT/GRID) + IF (BLAT.GE.90.) BLAT=BLAT-GRID +C +C IF A FAST-PATH CYLINDRICAL EQUIDISTANT PROJECTION IS IN USE AND EITHER +C OR BOTH OF THE POLES IS WITHIN THE (RECTANGULAR) PERIMETER, ARRANGE +C FOR THE PARALLELS AT -90 AND/OR +90 TO BE DRAWN. +C + IF (IPRJ.EQ.10) THEN + CALL MAPTRN (-90.,PHIO,U,V) + IF (U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN.AND.V.LE.VMAX) + + SLAT=SLAT-GRID + CALL MAPTRN (90.,PHIO,U,V) + IF (U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN.AND.V.LE.VMAX) + + BLAT=BLAT+GRID + END IF +C +C DRAW THE PARALLELS. +C + XLAT=SLAT-GRID + 103 XLAT=XLAT+GRID + RLAT=AMAX1(-90.,AMIN1(90.,XLAT)) + RLON=FLOOR(SLON) + XLON=AMIN1(CLING(BLON),RLON+360.) + IF (IPF) THEN + DLON=.5*(XLON-RLON) + ELSE + DLON=(XLON-RLON)/CLING((XLON-RLON)/GRDR) + END IF + CALL MAPIT (RLAT,RLON,0) + 104 RLON=RLON+DLON + CALL MAPIT (RLAT,RLON,1) + IF (RLON.LT.XLON-.9999) GO TO 104 + IF (XLAT.LT.BLAT-.9999) GO TO 103 +C +C RESTORE THE ORIGINAL INTENSITY, DOTTING, AND DASH PATTERN. +C + CALL MAPCHI (-2,0,0) +C +C DRAW THE LIMB LINES. +C + CALL MAPLMB +C +C DONE. +C + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPGTC (WHCH,CVAL) +C + CHARACTER*(*) WHCH,CVAL +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM3/ ITPN,NOUT,NPTS,IGID,BLAG,SLAG,BLOG,SLOG,PNTS(200) + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCM5/ DDCT(5),LDCT(5),PDCT(10) + CHARACTER*2 DDCT,LDCT,PDCT + COMMON /MAPCMB/ IIER + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPGTC','VERSION 1') +C + IF (WHCH(1:2).EQ.'AR') THEN + CVAL=LDCT(ILTS) + ELSE IF (WHCH(1:2).EQ.'OU') THEN + CVAL=DDCT(NOUT+1) + ELSE IF (WHCH(1:2).EQ.'PR') THEN + CVAL=PDCT(JPRJ) + IF (JPRJ.EQ.3.AND.ABS(SALT).GT.1.) CVAL=PDCT(10) + ELSE + GO TO 901 + END IF +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=1 + CALL MAPCEM (' MAPGTC - UNKNOWN PARAMETER NAME ',WHCH,IIER,1) + CVAL=' ' + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPGTI (WHCH,IVAL) +C + CHARACTER*(*) WHCH +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL + COMMON /MAPCMB/ IIER + COMMON /MAPNTS/ INTS(7) + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPGTI','VERSION 1') +C + IF (WHCH(1:2).EQ.'DA') THEN + IVAL=IDSH + ELSE IF (WHCH(1:2).EQ.'DD') THEN + IVAL=DDTS + ELSE IF (WHCH(1:2).EQ.'DL') THEN + IVAL=IDTL + ELSE IF (WHCH(1:2).EQ.'DO') THEN + IVAL=IDOT + ELSE IF (WHCH(1:2).EQ.'EL') THEN + IVAL=0 + IF (ELPF) IVAL=1 + ELSE IF (WHCH(1:2).EQ.'ER') THEN + IVAL=IIER + ELSE IF (WHCH(1:2).EQ.'GR') THEN + IVAL=GRID + ELSE IF (WHCH(1:2).EQ.'IN') THEN + IVAL=0 + IF (INTF) IVAL=1 + ELSE IF (WHCH(1:2).EQ.'I1') THEN + IVAL=INTS(1) + ELSE IF (WHCH(1:2).EQ.'I2') THEN + IVAL=INTS(2) + ELSE IF (WHCH(1:2).EQ.'I3') THEN + IVAL=INTS(3) + ELSE IF (WHCH(1:2).EQ.'I4') THEN + IVAL=INTS(4) + ELSE IF (WHCH(1:2).EQ.'I5') THEN + IVAL=INTS(5) + ELSE IF (WHCH(1:2).EQ.'I6') THEN + IVAL=INTS(6) + ELSE IF (WHCH(1:2).EQ.'I7') THEN + IVAL=INTS(7) + ELSE IF (WHCH(1:2).EQ.'LA') THEN + IVAL=0 + IF (LBLF) IVAL=1 + ELSE IF (WHCH(1:2).EQ.'LS') THEN + IVAL=ILCW + ELSE IF (WHCH(1:2).EQ.'MV') THEN + IVAL=DPLT + ELSE IF (WHCH(1:2).EQ.'PE') THEN + IVAL=0 + IF (PRMF) IVAL=1 + ELSE IF (WHCH(1:2).EQ.'PN') THEN + IVAL=PHIO + ELSE IF (WHCH(1:2).EQ.'PT') THEN + IVAL=PHIA + ELSE IF (WHCH(1:2).EQ.'P1') THEN + IVAL=PLA1 + ELSE IF (WHCH(1:2).EQ.'P2') THEN + IVAL=PLA2 + ELSE IF (WHCH(1:2).EQ.'P3') THEN + IVAL=PLA3 + ELSE IF (WHCH(1:2).EQ.'P4') THEN + IVAL=PLA4 + ELSE IF (WHCH(1:2).EQ.'P5') THEN + IVAL=PLB1 + ELSE IF (WHCH(1:2).EQ.'P6') THEN + IVAL=PLB2 + ELSE IF (WHCH(1:2).EQ.'P7') THEN + IVAL=PLB3 + ELSE IF (WHCH(1:2).EQ.'P8') THEN + IVAL=PLB4 + ELSE IF (WHCH(1:2).EQ.'RE') THEN + IVAL=PLTR + ELSE IF (WHCH(1:2).EQ.'RO') THEN + IVAL=ROTA + ELSE IF (WHCH(1:2).EQ.'SA') THEN + IVAL=SALT + ELSE IF (WHCH(1:2).EQ.'S1') THEN + IVAL=ALFA + ELSE IF (WHCH(1:2).EQ.'S2') THEN + IVAL=BETA + ELSE + GO TO 901 + END IF +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=2 + CALL MAPCEM (' MAPGTI - UNKNOWN PARAMETER NAME ',WHCH,IIER,1) + IVAL=0 + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPGTL (WHCH,LVAL) +C + CHARACTER*(*) WHCH + LOGICAL LVAL +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMB/ IIER +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPGTL','VERSION 1') +C + IF (WHCH(1:2).EQ.'DL') THEN + LVAL=IDTL.NE.0 + ELSE IF (WHCH(1:2).EQ.'DO') THEN + LVAL=IDOT.NE.0 + ELSE IF (WHCH(1:2).EQ.'EL') THEN + LVAL=ELPF + ELSE IF (WHCH(1:2).EQ.'IN') THEN + LVAL=INTF + ELSE IF (WHCH(1:2).EQ.'LA') THEN + LVAL=LBLF + ELSE IF (WHCH(1:2).EQ.'PE') THEN + LVAL=PRMF + ELSE + GO TO 901 + END IF +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=3 + CALL MAPCEM (' MAPGTL - UNKNOWN PARAMETER NAME ',WHCH,IIER,1) + LVAL=.FALSE. + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPGTR (WHCH,RVAL) +C + CHARACTER*(*) WHCH +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL + COMMON /MAPCMB/ IIER + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPGTR','VERSION 1') +C + IF (WHCH(1:2).EQ.'DD') THEN + RVAL=DDTS + ELSE IF (WHCH(1:2).EQ.'GD') THEN + RVAL=GRDR + ELSE IF (WHCH(1:2).EQ.'GR') THEN + RVAL=GRID + ELSE IF (WHCH(1:2).EQ.'MV') THEN + RVAL=DPLT + ELSE IF (WHCH(1:2).EQ.'PN') THEN + RVAL=PHIO + ELSE IF (WHCH(1:2).EQ.'PT') THEN + RVAL=PHIA + ELSE IF (WHCH(1:2).EQ.'P1') THEN + RVAL=PLA1 + ELSE IF (WHCH(1:2).EQ.'P2') THEN + RVAL=PLA2 + ELSE IF (WHCH(1:2).EQ.'P3') THEN + RVAL=PLA3 + ELSE IF (WHCH(1:2).EQ.'P4') THEN + RVAL=PLA4 + ELSE IF (WHCH(1:2).EQ.'P5') THEN + RVAL=PLB1 + ELSE IF (WHCH(1:2).EQ.'P6') THEN + RVAL=PLB2 + ELSE IF (WHCH(1:2).EQ.'P7') THEN + RVAL=PLB3 + ELSE IF (WHCH(1:2).EQ.'P8') THEN + RVAL=PLB4 + ELSE IF (WHCH(1:2).EQ.'RE') THEN + RVAL=PLTR + ELSE IF (WHCH(1:2).EQ.'RO') THEN + RVAL=ROTA + ELSE IF (WHCH(1:2).EQ.'SA') THEN + RVAL=SALT + ELSE IF (WHCH(1:2).EQ.'S1') THEN + RVAL=ALFA + ELSE IF (WHCH(1:2).EQ.'S2') THEN + RVAL=BETA + ELSE IF (WHCH(1:2).EQ.'SR') THEN + RVAL=SRCH + ELSE IF (WHCH(1:2).EQ.'XL') THEN + RVAL=XLOW + ELSE IF (WHCH(1:2).EQ.'XR') THEN + RVAL=XROW + ELSE IF (WHCH(1:2).EQ.'YB') THEN + RVAL=YBOW + ELSE IF (WHCH(1:2).EQ.'YT') THEN + RVAL=YTOW + ELSE + GO TO 901 + END IF +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=4 + CALL MAPCEM (' MAPGTR - UNKNOWN PARAMETER NAME ',WHCH,IIER,1) + RVAL=0. + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPINT +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM1/ IPRJ,SINO,COSO,SINR,COSR,PHOC + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM + COMMON /MAPCM3/ ITPN,NOUT,NPTS,IGID,BLAG,SLAG,BLOG,SLOG,PNTS(200) + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCM7/ ULOW,UROW,VBOW,VTOW + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL + COMMON /MAPCMB/ IIER + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C SET UP ALTERNATE NAMES FOR SOME OF THE VARIABLES IN COMMON. +C + EQUIVALENCE (PHIA,FLT1),(ROTA,FLT2) +C + EQUIVALENCE (PLA1,AUMN),(PLA2,AUMX), + + (PLA3,AVMN),(PLA4,AVMX) +C +C ENSURE THAT THE BLOCK DATA ROUTINE WILL LOAD, SO THAT VARIABLES WILL +C HAVE THE PROPER DEFAULT VALUES. +C + EXTERNAL MAPBD +C +C DEFINE THE NECESSARY CONSTANTS. +C + DATA RESL / 10. / + DATA DTOR / .017453292519943 / + DATA OV90 / .011111111111111 / + DATA PI / 3.14159265358979 / + DATA RTOD / 57.2957795130823 / +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPINT','VERSION 1') +C +C CHECK FOR AN ERROR IN THE PROJECTION SPECIFIER. +C + IF (JPRJ.LE.0.OR.JPRJ.GE.10) GO TO 901 +C +C IPRJ EQUALS JPRJ UNTIL WE FIND OUT IF FAST-PATH PROJECTIONS ARE TO BE +C USED. PHOC IS JUST A COPY OF PHIO. +C + IPRJ=JPRJ + PHOC=PHIO +C + IF (IPRJ.EQ.1) THEN +C +C COMPUTE CONSTANTS FOR THE LAMBERT CONFORMAL CONIC. +C + SINO=SIGN(1.,.5*(FLT1+FLT2)) + CHI1=(90.-SINO*FLT1)*DTOR + IF (FLT1.EQ.FLT2) THEN + COSO=COS(CHI1) + ELSE + CHI2=(90.-SINO*FLT2)*DTOR + COSO=ALOG(SIN(CHI1)/SIN(CHI2))/ALOG(TAN(.5*CHI1)/TAN(.5*CHI2)) + END IF +C + ELSE +C +C COMPUTE CONSTANTS REQUIRED FOR ALL THE OTHER PROJECTIONS. +C + TMP1=ROTA*DTOR + TMP2=PHIA*DTOR + SINR=SIN(TMP1) + COSR=COS(TMP1) + SINO=SIN(TMP2) + COSO=COS(TMP2) +C +C COMPUTE CONSTANTS REQUIRED ONLY BY THE CYLINDRICAL PROJECTIONS. +C + IF (IPRJ.GE.7) THEN +C +C SEE IF FAST-PATH TRANSFORMATIONS CAN BE USED. (PLAT = 0 AND ROTA = 0 +C OR 180.) +C + IF (ABS(PHIA).GE..0001.OR.(ABS(ROTA).GE..0001.AND. + + ABS(ROTA).LE.179.9999)) THEN +C +C NO. COMPUTE CONSTANTS FOR THE ORDINARY CYLINDRICAL PROJECTIONS. +C + SINT=COSO*COSR + COST=SQRT(1.-(SINT)**2) + TMP1=SINR/COST + TMP2=SINO/COST + PHIO=PHIO-ATAN2(TMP1,-COSR*TMP2)*RTOD + PHOC=PHIO + SINR=TMP1*COSO + COSR=-TMP2 + SINO=SINT + COSO=COST +C + ELSE +C +C YES. THE FAST PATHS ARE IMPLEMENTED AS THREE ADDITIONAL PROJECTIONS. +C + IPRJ=IPRJ+3 +C + IF (ABS(ROTA).LT..0001) THEN + SINO=1. + ELSE + SINO=-1. + PHIO=PHIO+180. + PHOC=PHIO + END IF +C + COSO=0. + SINR=0. + COSR=1. +C + END IF +C + END IF +C + END IF +C +C NOW, SET UMIN, UMAX, VMIN, AND VMAX TO CORRESPOND TO THE MAXIMUM +C USEFUL AREA PRODUCED BY THE PROJECTION. +C + GO TO (101,102,101,102,102,103,104,103,105,104,103,105) , IPRJ +C +C LAMBERT CONFORMAL CONIC AND ORTHOGRAPHIC. +C + 101 IF (IPRJ.NE.3.OR.ABS(SALT).LE.1..OR.ALFA.EQ.0.) THEN + UMIN=-1. + UMAX=1. + VMIN=-1. + VMAX=1. + ELSE + TMP1=SALT*SALT*CALF*CALF-1. + TMP2=CALF*SQRT(SALT*SALT*(1.-SALF*SALF*SBET*SBET)-1.) + UMIN=SRSS*(-SALF*CBET-TMP2)/TMP1 + UMAX=SRSS*(-SALF*CBET+TMP2)/TMP1 + TMP2=CALF*SQRT(SALT*SALT*(1.-SALF*SALF*CBET*CBET)-1.) + VMIN=SRSS*(-SALF*SBET-TMP2)/TMP1 + VMAX=SRSS*(-SALF*SBET+TMP2)/TMP1 + END IF +C + GO TO 106 +C +C STEREOGRAPHIC, LAMBERT EQUAL AREA, AND GNOMONIC. +C + 102 UMIN=-2. + UMAX=2. + VMIN=-2. + VMAX=2. + GO TO 106 +C +C AZIMUTHAL EQUIDISTANT AND MERCATOR. +C + 103 UMIN=-PI + UMAX=PI + VMIN=-PI + VMAX=PI + GO TO 106 +C +C CYLINDRICAL EQUIDISTANT. +C + 104 UMIN=-180. + UMAX=180. + VMIN=-90. + VMAX=90. + GO TO 106 +C +C MOLLWEIDE. +C + 105 UMIN=-2. + UMAX=2. + VMIN=-1. + VMAX=1. +C +C COMPUTE THE QUANTITIES USED BY MAPIT IN CHECKING FOR CROSS-OVER. +C + 106 UEPS=.75*(UMAX-UMIN) + VEPS=.75*(VMAX-VMIN) +C +C AS ALWAYS, THE CONICAL PROJECTION IS THE ODDBALL. CROSS-OVER IS NOT +C DETECTED IN U AND V, BUT IN LONGITUDE, SO THE VALUE HAS TO BE SET +C DIFFERENTLY. +C + IF (IPRJ.EQ.1) UEPS=180. +C +C NOW, JUMP TO THE APPROPRIATE LIMIT-SETTING CODE. +C + GO TO (600,200,300,400,500) , ILTS +C +C ILTS=2 POINTS (PL1,PL2) AND (PL3,PL4) ARE ON OPPOSITE CORNERS +C ------ OF THE PLOT. +C + 200 E=0. + 201 CALL MAPTRN (PLA1,PLA2+E,TMP1,TMP3) + CALL MAPTRN (PLA3,PLA4-E,TMP2,TMP4) + IF (IPRJ.GE.7.AND.TMP1.GE.TMP2.AND.E.EQ.0.) THEN + E=.0001 + GO TO 201 + END IF + UMIN=AMIN1(TMP1,TMP2) + UMAX=AMAX1(TMP1,TMP2) + VMIN=AMIN1(TMP3,TMP4) + VMAX=AMAX1(TMP3,TMP4) + IF (UMAX.GE.1.E12) GO TO 904 + GO TO 600 +C +C ILTS=3 FOUR EDGE POINTS ARE GIVEN. +C ------ +C + 300 E=0. + 301 CALL MAPTRN (PLA1,PLB1+E,TMP1,TMP5) + CALL MAPTRN (PLA2,PLB2-E,TMP2,TMP6) + IF (IPRJ.GE.7.AND.TMP1.GE.TMP2.AND.E.EQ.0.) THEN + E=.0001 + GO TO 301 + END IF + CALL MAPTRN (PLA3,PLB3,TMP3,TMP7) + CALL MAPTRN (PLA4,PLB4,TMP4,TMP8) + UMIN=AMIN1(TMP1,TMP2,TMP3,TMP4) + UMAX=AMAX1(TMP1,TMP2,TMP3,TMP4) + VMIN=AMIN1(TMP5,TMP6,TMP7,TMP8) + VMAX=AMAX1(TMP5,TMP6,TMP7,TMP8) + IF (UMAX.GE.1.E12) GO TO 904 + GO TO 600 +C +C ILTS=4 ANGULAR DISTANCES ARE GIVEN. +C ------ +C + 400 CUMI=COS(AUMN*DTOR) + SUMI=SIN(AUMN*DTOR) + CUMA=COS(AUMX*DTOR) + SUMA=SIN(AUMX*DTOR) + CVMI=COS(AVMN*DTOR) + SVMI=SIN(AVMN*DTOR) + CVMA=COS(AVMX*DTOR) + SVMA=SIN(AVMX*DTOR) +C + GO TO (904,401,402,403,404,405,406,407,408,406,407,408) , IPRJ +C +C STEREOGRAPHIC. +C + 401 IF (SUMI.LT..0001) THEN + IF (CUMI.GT.0.) UMIN=0. + ELSE + UMIN=-(1.-CUMI)/SUMI + END IF + IF (SUMA.LT..0001) THEN + IF (CUMA.GT.0.) UMAX=0. + ELSE + UMAX=(1.-CUMA)/SUMA + END IF + IF (SVMI.LT..0001) THEN + IF (CVMI.GT.0.) VMIN=0. + ELSE + VMIN=-(1.-CVMI)/SVMI + END IF + IF (SVMA.LT..0001) THEN + IF (CVMA.GT.0.) VMAX=0. + ELSE + VMAX=(1.-CVMA)/SVMA + END IF + GO TO 600 +C +C ORTHOGRAPHIC. +C + 402 IF (ABS(SALT).LE.1.) THEN + IF (AMAX1(AUMN,AUMX,AVMN,AVMX).GT.90.) GO TO 902 + UMIN=-SUMI + UMAX=SUMA + VMIN=-SVMI + VMAX=SVMA + ELSE + IF (AMAX1(AUMN,AUMX,AVMN,AVMX).GE.90.) GO TO 902 + UTMP=SRSS*SALF/CALF + VTMP=0. + UCEN=UTMP*CBET-VTMP*SBET + VCEN=VTMP*CBET+UTMP*SBET + UMIN=UCEN-SRSS*CALF*SUMI/CUMI + UMAX=UCEN+SRSS*CALF*SUMA/CUMA + VMIN=VCEN-SRSS*CALF*SVMI/CVMI + VMAX=VCEN+SRSS*CALF*SVMA/CVMA + END IF + GO TO 600 +C +C LAMBERT EQUAL AREA. +C + 403 IF (SUMI.LT..0001) THEN + IF (CUMI.GT.0.) UMIN=0. + ELSE + UMIN=-2./SQRT(1.+((1.+CUMI)/SUMI)**2) + END IF + IF (SUMA.LT..0001) THEN + IF (CUMA.GT.0.) UMAX=0. + ELSE + UMAX=2./SQRT(1.+((1.+CUMA)/SUMA)**2) + END IF + IF (SVMI.LT..0001) THEN + IF (CVMI.GT.0.) VMIN=0. + ELSE + VMIN=-2./SQRT(1.+((1.+CVMI)/SVMI)**2) + END IF + IF (SVMA.LT..0001) THEN + IF (CVMA.GT.0.) VMAX=0. + ELSE + VMAX=2./SQRT(1.+((1.+CVMA)/SVMA)**2) + END IF + GO TO 600 +C +C GNOMONIC. +C + 404 IF (AMAX1(AUMN,AUMX,AVMN,AVMX).GE.89.9999) GO TO 902 + UMIN=-SUMI/CUMI + UMAX=SUMA/CUMA + VMIN=-SVMI/CVMI + VMAX=SVMA/CVMA + GO TO 600 +C +C AZIMUTHAL EQUIDISTANT. +C + 405 UMIN=-AUMN*DTOR + UMAX=AUMX*DTOR + VMIN=-AVMN*DTOR + VMAX=AVMX*DTOR + GO TO 600 +C +C CYLINDRICAL EQUIDISTANT. +C + 406 UMIN=-AUMN + UMAX=AUMX + VMIN=-AVMN + VMAX=AVMX + GO TO 600 +C +C MERCATOR. +C + 407 IF (AMAX1(AVMN,AVMX).GE.89.9999) GO TO 902 + UMIN=-AUMN*DTOR + UMAX=AUMX*DTOR + VMIN=-ALOG((1.+SVMI)/CVMI) + VMAX=ALOG((1.+SVMA)/CVMA) + GO TO 600 +C +C MOLLWEIDE. +C + 408 UMIN=-AUMN*OV90 + UMAX=AUMX*OV90 + VMIN=-SVMI + VMAX=SVMA + GO TO 600 +C +C ILTS=5 VALUES IN THE U/V PLANE ARE GIVEN. +C ------ +C + 500 UMIN=PLA1 + UMAX=PLA2 + VMIN=PLA3 + VMAX=PLA4 +C +C COMPUTE THE WIDTH AND HEIGHT OF THE PLOT. +C + 600 DU=UMAX-UMIN + DV=VMAX-VMIN +C +C ERROR IF MAP HAS ZERO AREA. +C + IF (DU.LE.0..OR.DV.LE.0.) GO TO 903 +C +C POSITION THE MAP ON THE PLOTTER FRAME. +C + IF (DU/DV.LT.(XROW-XLOW)/(YTOW-YBOW)) THEN + ULOW=.5*(XLOW+XROW)-.5*(DU/DV)*(YTOW-YBOW) + UROW=.5*(XLOW+XROW)+.5*(DU/DV)*(YTOW-YBOW) + VBOW=YBOW + VTOW=YTOW + ELSE + ULOW=XLOW + UROW=XROW + VBOW=.5*(YBOW+YTOW)-.5*(DV/DU)*(XROW-XLOW) + VTOW=.5*(YBOW+YTOW)+.5*(DV/DU)*(XROW-XLOW) + END IF +C +C ERROR IF MAP HAS ESSENTIALLY ZERO AREA. +C + IF (AMIN1(UROW-ULOW,VTOW-VBOW)*PLTR.LT.RESL) GO TO 903 +C +C DO THE REQUIRED SET CALL. +C + CALL SET (ULOW,UROW,VBOW,VTOW,UMIN,UMAX,VMIN,VMAX,1) +C +C COMPUTE THE QUANTITIES USED BY MAPIT TO SEE IF POINTS ARE FAR ENOUGH +C APART TO DRAW THE LINE BETWEEN THEM AND THE QUANTITIES USED BY MAPVP +C TO DETERMINE THE NUMBER OF DOTS TO INTERPOLATE BETWEEN TWO POINTS. +C + DSCA=(UROW-ULOW)*PLTR/DU + DPSQ=DPLT*DPLT + DSSQ=DSCA*DSCA + DBTD=DDTS/DSCA +C +C SET PARAMETERS REQUIRED IF AN ELLIPTICAL PERIMETER IS BEING USED. THE +C ELLIPSE IS MADE TO BE JUST A LITTLE BIGGER THAN AN INSCRIBED ELLIPSE +C SO AS TO AVOID ROUND-OFF PROBLEMS WHEN DRAWING THE LIMB OF CERTAIN +C PROJECTIONS. +C + UCEN=.5*(UMIN+UMAX) + VCEN=.5*(VMIN+VMAX) + URNG=.50005*(UMAX-UMIN) + VRNG=.50005*(VMAX-VMIN) +C +C NOW, COMPUTE THE LATITUDE/LONGITUDE LIMITS WHICH WILL BE REQUIRED BY +C MAPGRD AND MAPLOT, IF ANY. +C + IF (GRID.GT.0..OR.NOUT.NE.0) THEN +C +C AT FIRST, ASSUME THE WHOLE GLOBE WILL BE PROJECTED. +C + SLAM=-90. + BLAM=+90. + SLOM=PHIO-180. + BLOM=PHIO+180. +C +C JUMP IF IT'S OBVIOUS THAT REALLY IS THE CASE. +C + IF (ILTS.EQ.1.AND.(JPRJ.EQ.4.OR.JPRJ.EQ.6.OR.JPRJ.EQ.7.OR. + + JPRJ.EQ.9)) GO TO 700 +C +C OTHERWISE, THE WHOLE GLOBE IS NOT BEING PROJECTED. THE FIRST THING +C TO DO IS TO FIND A POINT (CLAT,CLON) WHOSE PROJECTION IS KNOWN TO BE +C ON THE MAP. FIRST, TRY THE POLE OF THE PROJECTION. +C + CLAT=PHIA + CLON=PHIO + CALL MAPTRN (CLAT,CLON,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX).OR. + + (ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) + + GO TO 611 +C +C IF THAT DIDN'T WORK, TRY A POINT BASED ON THE LIMITS SPECIFIER. +C + IF (ILTS.EQ.2) THEN + CLAT=.5*(PLA1+PLA3) + CLON=.5*(PLA2+PLA4) + ELSE IF (ILTS.EQ.3) THEN + TMP1=AMIN1(PLA1,PLA2,PLA3,PLA4) + TMP2=AMAX1(PLA1,PLA2,PLA3,PLA4) + TMP3=AMIN1(PLB1,PLB2,PLB3,PLB4) + TMP4=AMAX1(PLB1,PLB2,PLB3,PLB4) + CLAT=.5*(TMP1+TMP2) + CLON=.5*(TMP3+TMP4) + ELSE + GO TO 700 + END IF + CALL MAPTRN (CLAT,CLON,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX).OR. + + (ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) + + GO TO 611 + GO TO 700 +C +C ONCE WE HAVE THE LATITUDES AND LONGITUDES OF A POINT ON THE MAP, WE +C FIND THE MINIMUM AND MAXIMUM LATITUDE AND THE MINIMUM AND MAXIMUM +C LONGITUDE BY RUNNING A SEARCH POINT ABOUT ON A FINE LAT/LON GRID. +C +C FIND THE MINIMUM LATITUDE. +C + 611 RLAT=CLAT + RLON=CLON + DLON=SRCH + 612 RLAT=RLAT-SRCH + IF (RLAT.LE.-90.) GO TO 621 + 613 CALL MAPTRN (RLAT,RLON,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX).OR. + + (ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) THEN + DLON=SRCH + GO TO 612 + END IF + RLON=RLON+DLON + DLON=SIGN(ABS(DLON)+SRCH,-DLON) + IF (RLON.GT.CLON-180..AND.RLON.LT.CLON+180.) GO TO 613 + RLON=RLON+DLON + DLON=SIGN(ABS(DLON)+SRCH,-DLON) + IF (RLON.GT.CLON-180..AND.RLON.LT.CLON+180.) GO TO 613 + SLAM=RLAT +C +C FIND THE MAXIMUM LATITUDE. +C + 621 RLAT=CLAT + RLON=CLON + DLON=SRCH + 622 RLAT=RLAT+SRCH + IF (RLAT.GT.90.) GO TO 631 + 623 CALL MAPTRN (RLAT,RLON,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX).OR. + + (ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) THEN + DLON=SRCH + GO TO 622 + END IF + RLON=RLON+DLON + DLON=SIGN(ABS(DLON)+SRCH,-DLON) + IF (RLON.GT.CLON-180..AND.RLON.LT.CLON+180.) GO TO 623 + RLON=RLON+DLON + DLON=SIGN(ABS(DLON)+SRCH,-DLON) + IF (RLON.GT.CLON-180..AND.RLON.LT.CLON+180.) GO TO 623 + BLAM=RLAT +C +C FIND THE MINIMUM LONGITUDE. +C + 631 RLAT=CLAT + RLON=CLON + DLAT=SRCH + 632 RLON=RLON-SRCH + IF (RLON.LE.CLON-360.) GO TO 651 + 633 CALL MAPTRN (RLAT,RLON,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX).OR. + + (ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) THEN + DLAT=SRCH + GO TO 632 + END IF + RLAT=RLAT+DLAT + DLAT=SIGN(ABS(DLAT)+SRCH,-DLAT) + IF (RLAT.GT.-90..AND.RLAT.LT.90.) GO TO 633 + RLAT=RLAT+DLAT + DLAT=SIGN(ABS(DLAT)+SRCH,-DLAT) + IF (RLAT.GT.-90..AND.RLAT.LT.90.) GO TO 633 + SLOM=RLON-SIGN(180.,RLON+180.)+SIGN(180.,180.-RLON) +C +C FIND THE MAXIMUM LONGITUDE. +C + 641 RLAT=CLAT + RLON=CLON + DLAT=SRCH + 642 RLON=RLON+SRCH + IF (RLON.GE.CLON+360.) GO TO 651 + 643 CALL MAPTRN (RLAT,RLON,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX).OR. + + (ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) THEN + DLAT=SRCH + GO TO 642 + END IF + RLAT=RLAT+DLAT + DLAT=SIGN(ABS(DLAT)+SRCH,-DLAT) + IF (RLAT.GT.-90..AND.RLAT.LT.90.) GO TO 643 + RLAT=RLAT+DLAT + DLAT=SIGN(ABS(DLAT)+SRCH,-DLAT) + IF (RLAT.GT.-90..AND.RLAT.LT.90.) GO TO 643 + BLOM=RLON-SIGN(180.,RLON+180.)+SIGN(180.,180.-RLON) + IF (BLOM.LE.SLOM) BLOM=BLOM+360. + GO TO 700 +C + 651 SLOM=PHIO-180. + BLOM=PHIO+180. +C + END IF +C +C ZERO THE ERROR FLAG AND TURN OFF THE INITIALIZATION-REQUIRED FLAG. +C + 700 IIER=0 + INTF=.FALSE. +C +C DONE. +C + RETURN +C +C ERROR RETURNS. +C + 901 IIER=5 + CALL SETER (' MAPINT - ATTEMPT TO USE NON-EXISTENT PROJECTION', + 1 IIER,1) + RETURN +C + 902 IIER=6 + CALL SETER (' MAPINT - ANGULAR LIMITS TOO GREAT',IIER,1) + RETURN +C + 903 IIER=7 + CALL SETER (' MAPINT - MAP HAS ZERO AREA',IIER,1) + RETURN +C + 904 IIER=8 + CALL SETER (' MAPINT - MAP LIMITS INAPPROPIATE',IIER,1) + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPIT (RLAT,RLON,IFST) +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM1/ IPRJ,SINO,COSO,SINR,COSR,PHOC + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCM8/ P,Q,R + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL +C + DIMENSION CPRJ(3) +C + SAVE IVSO,POLD,QOLD,UOLD,VOLD +C + DATA CPRJ / 360.,6.28318530717959,4. / +C + DATA IVSO,POLD,QOLD,UOLD,VOLD / 0,0.,0.,0.,0. / +C +C PROJECT THE POINT (RLAT,RLON) TO (U,V). +C + CALL MAPTRN (RLAT,RLON,U,V) +C +C FOR THE SAKE OF EFFICIENCY, EXECUTE ONE OF TWO PARALLEL ALGORITHMS, +C DEPENDING ON WHETHER AN ELLIPTICAL OR A RECTANGULAR PERIMETER IS IN +C USE. (THAT WAY, WE TEST ELPF ONLY ONCE.) +C + IF (ELPF) THEN +C +C ELLIPTICAL - ASSUME THE NEW POINT IS VISIBLE UNTIL WE FIND OTHERWISE. +C + IVIS=1 +C +C SEE IF THE NEW POINT IS INVISIBLE. +C + IF (((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.GT.1.) THEN +C +C THE NEW POINT IS INVISIBLE. RESET THE VISIBILITY FLAG. +C + IVIS=0 +C +C IF THE NEW POINT IS A "FIRST POINT" OR IF THE LAST POINT WAS NOT +C VISIBLE OR IF THE NEW POINT IS INVISIBLE BECAUSE ITS PROJECTION IS +C UNDEFINED, DRAW NOTHING. THE POSSIBLE EXISTENCE OF A VISIBLE SEGMENT +C ALONG THE LINE JOINING TWO INVISIBLE POINTS IS INTENTIONALLY IGNORED, +C FOR REASONS OF EFFICIENCY. FOR THIS REASON, OBJECTS SHOULD NOT BE +C DRAWN USING LONG LINE SEGMENTS. +C + IF (IFST.EQ.0.OR.IVSO.EQ.0.OR.U.GE.1.E12) GO TO 108 +C +C OTHERWISE, THE NEW POINT IS NOT A "FIRST POINT", THE LAST POINT WAS +C VISIBLE, AND THE PROJECTION OF THE NEW POINT IS DEFINED, SO WE NEED +C TO CONTINUE THE LINE. FIRST, IF THERE'S A CROSS-OVER PROBLEM, MOVE +C THE NEW POINT TO ITS ALTERNATE POSITION. THIS MAY MAKE IT VISIBLE. +C + IF (ABS(P-POLD).GT.UEPS.OR.ABS(Q-QOLD).GT.VEPS) THEN +C + IF (JPRJ.GE.7) THEN + P=P-SIGN(CPRJ(JPRJ-6),P) + U=P + IF (JPRJ.EQ.9) U=U*SQRT(1.-V*V) + ELSE + GO TO 108 + END IF +C + IF (((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.) THEN + IVIS=1 + GO TO 107 + END IF +C + END IF +C +C IF IT'S STILL INVISIBLE, INTERPOLATE TO THE EDGE OF THE FRAME, EXTEND +C THE LINE TO THAT POINT, AND QUIT. +C + CALL MAPTRE (UOLD,VOLD,U,V,UINT,VINT) + CALL MAPVP (UOLD,VOLD,UINT,VINT) + GO TO 108 +C + END IF +C +C THE NEW POINT IS VISIBLE. IF IT'S THE FIRST POINT OF A LINE, GO START +C A NEW LINE. +C + IF (IFST.EQ.0.OR.UOLD.GE.1.E12) GO TO 106 +C +C THE NEW POINT IS VISIBLE, BUT IT'S NOT THE FIRST POINT OF A LINE. +C CHECK FOR CROSS-OVER PROBLEMS. +C + IF (ABS(P-POLD).GT.UEPS.OR.ABS(Q-QOLD).GT.VEPS) GO TO 101 +C +C THE NEW POINT IS VISIBLE, IT'S NOT THE FIRST POINT OF A LINE, AND +C THERE ARE NO CROSS-OVER PROBLEMS. IF THE OLD POINT WAS INVISIBLE, +C JUMP TO DRAW THE VISIBLE PORTION OF THE LINE FROM THE OLD POINT TO +C THE NEW ONE. +C + IF (IVSO.EQ.0) GO TO 102 +C +C THE NEW POINT IS VISIBLE, IT'S NOT THE FIRST POINT OF A LINE, THERE +C ARE NO CROSS-OVER PROBLEMS, AND THE LAST POINT WAS VISIBLE. JUMP TO +C JUST CONTINUE THE LINE. +C + GO TO 107 +C +C WE HAVE THE MOST DIFFICULT CASE. THE NEW POINT IS VISIBLE, IT'S NOT +C THE FIRST POINT OF A LINE, AND THERE IS A CROSS-OVER PROBLEM. NONE, +C ONE, OR TWO SEGMENTS MAY NEED TO BE DRAWN. +C + 101 IF (JPRJ.LT.7) GO TO 106 +C +C IF THE OLD POINT WAS VISIBLE, GENERATE THE ALTERNATE PROJECTION OF THE +C NEW POINT AND DRAW THE VISIBLE PORTION OF THE LINE SEGMENT JOINING THE +C OLD POINT TO THE ALTERNATE PROJECTION POINT. +C + IF (IVSO.NE.0) THEN +C + UTMP=P-SIGN(CPRJ(JPRJ-6),P) + VTMP=Q + IF (JPRJ.EQ.9) UTMP=UTMP*SQRT(1.-VTMP*VTMP) +C + IF (((UTMP-UCEN)/URNG)**2+((VTMP-VCEN)/VRNG)**2.GT.1.) THEN + CALL MAPTRE (UOLD,VOLD,UTMP,VTMP,UTMP,VTMP) + END IF +C + CALL MAPVP (UOLD,VOLD,UTMP,VTMP) +C + END IF +C +C NOW GENERATE AN ALTERNATE PROJECTION OF THE OLD POINT CLOSE TO THE NEW +C ONE AND DRAW THE VISIBLE PORTION OF THE LINE SEGMENT JOINING IT TO THE +C NEW POINT. +C + UOLD=POLD-SIGN(CPRJ(JPRJ-6),POLD) + IF (JPRJ.EQ.9) UOLD=UOLD*SQRT(1.-VOLD*VOLD) +C + IF (((UOLD-UCEN)/URNG)**2+((VOLD-VCEN)/VRNG)**2.LE.1.) GO TO 105 +C +C MOVE (UOLD,VOLD) BY INTERPOLATING TO THE EDGE OF THE FRAME. +C + 102 CALL MAPTRE (U,V,UOLD,VOLD,UOLD,VOLD) +C + ELSE +C +C RECTANGULAR - REPEAT THE ABOVE CODE, CHANGING THE TESTS FOR A POINT'S +C BEING INSIDE/OUTSIDE THE PERIMETER. COMMENTING WILL BE ABBREVIATED. +C + IVIS=1 +C + IF (U.LT.UMIN.OR.U.GT.UMAX.OR.V.LT.VMIN.OR.V.GT.VMAX) THEN +C + IVIS=0 +C + IF (IFST.EQ.0.OR.IVSO.EQ.0.OR.U.GE.1.E12) GO TO 108 +C + IF (ABS(P-POLD).GT.UEPS.OR.ABS(Q-QOLD).GT.VEPS) THEN +C + IF (JPRJ.GE.7) THEN + P=P-SIGN(CPRJ(JPRJ-6),P) + U=P + IF (JPRJ.EQ.9) U=U*SQRT(1.-V*V) + ELSE + GO TO 108 + END IF +C + IF (U.GE.UMIN.AND.U.LE.UMAX.AND. + + V.GE.VMIN.AND.V.LE.VMAX) THEN + IVIS=1 + GO TO 107 + END IF + END IF +C + CALL MAPTRP (UOLD,VOLD,U,V,UINT,VINT) + CALL MAPVP (UOLD,VOLD,UINT,VINT) + GO TO 108 +C + END IF +C + IF (IFST.EQ.0.OR.UOLD.GE.1.E12) GO TO 106 +C + IF (ABS(P-POLD).GT.UEPS.OR.ABS(Q-QOLD).GT.VEPS) GO TO 103 +C + IF (IVSO.EQ.0) GO TO 104 +C + GO TO 107 +C + 103 IF (JPRJ.LT.7) GO TO 106 +C + IF (IVSO.NE.0) THEN +C + UTMP=P-SIGN(CPRJ(JPRJ-6),P) + VTMP=Q + IF (JPRJ.EQ.9) UTMP=UTMP*SQRT(1.-VTMP*VTMP) +C + IF (UTMP.LT.UMIN.OR.UTMP.GT.UMAX.OR. + + VTMP.LT.VMIN.OR.VTMP.GT.VMAX) THEN + CALL MAPTRP (UOLD,VOLD,UTMP,VTMP,UTMP,VTMP) + END IF +C + CALL MAPVP (UOLD,VOLD,UTMP,VTMP) + END IF +C + UOLD=POLD-SIGN(CPRJ(JPRJ-6),POLD) + IF (JPRJ.EQ.9) UOLD=UOLD*SQRT(1.-VOLD*VOLD) +C + IF (UOLD.GE.UMIN.AND.UOLD.LE.UMAX.AND. + + VOLD.GE.VMIN.AND.VOLD.LE.VMAX) GO TO 105 +C + 104 CALL MAPTRP (U,V,UOLD,VOLD,UOLD,VOLD) +C + END IF +C +C DRAW THE VISIBLE PORTION OF THE LINE JOINING THE OLD POINT TO THE NEW. +C + 105 IF (IDTL.EQ.0) THEN + CALL FRSTD (UOLD,VOLD) + DATL=0. + END IF +C + CALL MAPVP (UOLD,VOLD,U,V) +C + GO TO 108 +C +C START A NEW LINE. +C + 106 IF (IDTL.EQ.0) THEN + CALL FRSTD (U,V) + DATL=0. + END IF +C + GO TO 108 +C +C CONTINUE THE LINE. +C + 107 IF (IFST.LT.2.AND.((U-UOLD)**2+(V-VOLD)**2)*DSSQ.LE.DPSQ) RETURN + CALL MAPVP (UOLD,VOLD,U,V) +C +C SAVE INFORMATION ABOUT THE CURRENT POINT FOR THE NEXT CALL AND QUIT. +C + 108 IVSO=IVIS + POLD=P + QOLD=Q + UOLD=U + VOLD=V +C + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPIQ +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCMP/ NPTB,XPTB(50),YPTB(50) +C +C FLUSH THE POINTS BUFFER. +C + IF (NPTB.GT.0) THEN + CALL POINTS (XPTB,YPTB,NPTB,0,0) + NPTB=0 + END IF +C +C FLUSH PLOTIT'S BUFFER, TOO. +C + CALL PLOTIT (0,0,0) +C +C DONE. +C + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPLBL +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL + COMMON /MAPCMB/ IIER +C +C DEFINE REQUIRED CONSTANTS. SIN1 AND COS1 ARE RESPECTIVELY THE SINE +C AND COSINE OF ONE DEGREE. +C + DATA SIN1 / .017452406437283 / + DATA COS1 / .999847695156390 / +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPLBL','VERSION 1') +C +C IF EZMAP NEEDS INITIALIZATION OR IF AN ERROR HAS OCCURRED SINCE THE +C LAST INITIALIZATION, DO NOTHING. +C + IF (INTF) RETURN + IF (IIER.NE.0) RETURN +C +C IF REQUESTED, LETTER KEY MERIDIANS AND POLES. +C + IF (LBLF) THEN +C +C RESET THE INTENSITY, DOTTING, AND DASH PATTERN FOR LABELLING. +C + CALL MAPCHI (3,1,0) +C +C FIRST, THE NORTH POLE. +C + CALL MAPTRN (90.,0.,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX) + + .OR.(ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) + + CALL WTSTR (U,V,'NP',ILCW,0,0) +C +C THEN, THE SOUTH POLE. +C + CALL MAPTRN (-90.,0.,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX) + + .OR.(ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) + + CALL WTSTR (U,V,'SP',ILCW,0,0) +C +C THE EQUATOR. +C + RLON=PHIO-10. + DO 101 I=1,36 + RLON=RLON+10. + CALL MAPTRN (0.,RLON,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX) + + .OR.(ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) + + GO TO 102 + 101 CONTINUE + GO TO 103 + 102 CALL WTSTR (U,V,'EQ',ILCW,0,0) +C +C THE GREENWICH MERIDIAN. +C + 103 RLAT=85. + DO 104 I=1,16 + RLAT=RLAT-10. + CALL MAPTRN (RLAT,0.,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX) + + .OR.(ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) + + GO TO 105 + 104 CONTINUE + GO TO 106 + 105 CALL WTSTR (U,V,'GM',ILCW,0,0) +C +C INTERNATIONAL DATE LINE. +C + 106 RLAT=85. + DO 107 I=1,16 + RLAT=RLAT-10. + CALL MAPTRN (RLAT,180.,U,V) + IF ((.NOT.ELPF.AND.U.GE.UMIN.AND.U.LE.UMAX.AND.V.GE.VMIN + + .AND.V.LE.VMAX) + + .OR.(ELPF.AND.((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.LE.1.)) + + GO TO 108 + 107 CONTINUE + GO TO 109 + 108 CALL WTSTR (U,V,'ID',ILCW,0,0) +C +C RESTORE THE ORIGINAL INTENSITY, DOTTING, AND DASH PATTERN. +C + 109 CALL MAPCHI (-3,0,0) +C + END IF +C +C DRAW PERIMETER, IF REQUESTED. +C + IF (PRMF) THEN +C +C RESET THE LINE INTENSITY, DOTTING, AND DASH PATTERN FOR THE PERIMETER. +C + CALL MAPCHI (1,0,IOR(ISHIFT(32767,1),1)) +C +C THE PERIMETER IS EITHER AN ELLIPSE OR A RECTANGLE, DEPENDING ON ELPF. +C + IF (ELPF) THEN + U=.9999*URNG + V=0. + DATL=0. + CALL FRSTD (UCEN+U,VCEN) + DO 110 I=1,360 + UOLD=U + VOLD=V + U=COS1*UOLD-SIN1*VOLD + V=SIN1*UOLD+COS1*VOLD + CALL MAPVP (UCEN+UOLD,VCEN+VOLD*VRNG/URNG, + + UCEN+U ,VCEN+V *VRNG/URNG) + 110 CONTINUE + ELSE + DATL=0. + UMINX=UMIN+.9999*(UMAX-UMIN) + UMAXX=UMAX-.9999*(UMAX-UMIN) + VMINX=VMIN+.9999*(VMAX-VMIN) + VMAXX=VMAX-.9999*(VMAX-VMIN) + CALL FRSTD (UMINX,VMINX) + CALL MAPVP (UMINX,VMINX,UMAXX,VMINX) + CALL MAPVP (UMAXX,VMINX,UMAXX,VMAXX) + CALL MAPVP (UMAXX,VMAXX,UMINX,VMAXX) + CALL MAPVP (UMINX,VMAXX,UMINX,VMINX) + END IF +C +C RESTORE THE ORIGINAL INTENSITY, DOTTING, AND DASH PATTERN. +C + CALL MAPCHI (-1,0,0) +C + END IF +C +C DONE. +C + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPLOT +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM + COMMON /MAPCM3/ ITPN,NOUT,NPTS,IGID,BLAG,SLAG,BLOG,SLOG,PNTS(200) + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMB/ IIER +C +C DEFINE REQUIRED CONSTANTS. +C + DATA PI / 3.14159265358979 / +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPLOT','VERSION 1') +C +C IF EZMAP NEEDS INITIALIZATION OR IF AN ERROR HAS OCCURRED SINCE THE +C LAST INITIALIZATION, DO NOTHING. +C + IF (INTF) RETURN + IF (IIER.NE.0) RETURN +C +C IF THE SELECTED OUTLINE TYPE IS "NONE", DO NOTHING. +C + IF (NOUT.LE.0) RETURN +C +C SET THE FLAG IWGF TO SAY WHETHER OR NOT THE WHOLE GLOBE IS SHOWN BY +C THE CURRENT PROJECTION. IF SO (IWGF=1), THERE'S NO NEED TO WASTE THE +C TIME REQUIRED TO CHECK EACH OUTLINE POINT GROUP FOR INTERSECTION WITH +C THE WINDOW. +C + IWGF=0 + IF (BLAM-SLAM.GT.179.9999.AND.BLOM-SLOM.GT.359.9999) IWGF=1 +C +C IGIS KEEPS TRACK OF CHANGES IN THE GROUP IDENTIFIER, SO THAT THE +C INTENSITY CAN BE CHANGED WHEN NECESSARY. +C + IGIS=0 +C +C POSITION TO THE USER-SELECTED PORTION OF THE OUTLINE DATASET. +C + CALL MAPIO (1) + NSEG=0 +C +C READ THE NEXT RECORD (GROUP OF POINTS). +C + 101 CALL MAPIO (2) + NSEG=NSEG+1 +C +C CHECK FOR THE END OF THE DESIRED DATA. +C + IF (NPTS.EQ.0) GO TO 103 +C +C IF LESS THAN THE WHOLE GLOBE IS SHOWN BY THE PROJECTION, DO A QUICK +C CHECK FOR INTERSECTION OF THE BOX SURROUNDING THE POINT GROUP WITH +C THE AREA SHOWN. +C + IF (IWGF.EQ.0) THEN + IF (SLAG.GT.BLAM.OR.BLAG.LT.SLAM) GO TO 101 + IF ((SLOG .GT.BLOM.OR.BLOG .LT.SLOM).AND. + + (SLOG-360..GT.BLOM.OR.BLOG-360..LT.SLOM).AND. + + (SLOG+360..GT.BLOM.OR.BLOG+360..LT.SLOM)) GO TO 101 + END IF +C +C SEE IF THE USER WANTS TO OMIT THIS POINT GROUP. +C + CALL MAPEOS (NOUT,NSEG,IGID,NPTS,PNTS) + IF (NPTS.LE.1) GO TO 101 +C +C IF WE'VE SWITCHED TO A NEW GROUP, SET THE INTENSITY, DOTTING, AND +C DASH PATTERN FOR THE GROUP. +C + IF (IGID.NE.IGIS) THEN + IF (IGIS.NE.0) CALL MAPCHI (-4-IGIS,0,0) + CALL MAPCHI (4+IGID,IDOT,IOR(ISHIFT(32767,1),1)) + IGIS=IGID + END IF +C +C PLOT THE GROUP. +C + CALL MAPIT (PNTS(1),PNTS(2),0) +C + DO 102 K=2,NPTS-1 + CALL MAPIT (PNTS(2*K-1),PNTS(2*K),1) + 102 CONTINUE +C + CALL MAPIT (PNTS(2*NPTS-1),PNTS(2*NPTS),2) +C +C GO GET ANOTHER GROUP. +C + GO TO 101 +C +C RESET THE INTENSITY, DOTTING, AND DASH PATTERN, IF NECESSARY. +C + 103 IF (IGIS.NE.0) CALL MAPCHI (-4-IGIS,0,0) +C +C IF THE LIMB LINES HAVE NOT ALREADY BEEN DRAWN, DO IT NOW. +C + IF (GRID.LE.0.) CALL MAPLMB +C +C DONE. +C + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPPOS (ARG1,ARG2,ARG3,ARG4) +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMB/ IIER +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPPOS','VERSION 1') +C +C CHECK THE ARGUMENTS FOR ERRORS. +C + IF (ARG1.LT.0..OR.ARG1.GE.ARG2.OR.ARG2.GT.1.) GO TO 901 + IF (ARG3.LT.0..OR.ARG3.GE.ARG4.OR.ARG4.GT.1.) GO TO 901 +C +C TRANSFER IN THE VALUES. +C + XLOW=ARG1 + XROW=ARG2 + YBOW=ARG3 + YTOW=ARG4 +C +C SET THE FLAG TO INDICATE THAT INITIALIZATION IS NOW REQUIRED. +C + INTF=.TRUE. +C +C DONE. +C + RETURN +C +C ERROR EXIT. +C + 901 IIER=19 + CALL SETER (' MAPPOS - ARGUMENTS ARE INCORRECT',IIER,1) + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPROJ (ARG1,ARG2,ARG3,ARG4) +C + CHARACTER*(*) ARG1 +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCM5/ DDCT(5),LDCT(5),PDCT(10) + CHARACTER*2 DDCT,LDCT,PDCT + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPROJ','VERSION 1') +C +C TRANSFER THE PARAMETERS DEFINING THE PROJECTION. +C + I=IDICTL(ARG1,PDCT,10) + IF (I.EQ.0) GO TO 901 +C + JPRJ=I +C + IF (JPRJ.EQ.3) THEN + CALL MAPSTR ('SA',0.) + ELSE IF (JPRJ.EQ.10) THEN + JPRJ=3 + IF (ABS(SALT).LE.1.) CALL MAPSTR ('SA',6.631) + END IF +C + PHIA=ARG2 + PHIO=ARG3 + ROTA=ARG4 +C +C SET THE FLAG TO INDICATE THAT INITIALIZATION IS NOW REQUIRED. +C + INTF=.TRUE. +C +C DONE. +C + RETURN +C +C ERROR EXIT. +C + 901 IIER=9 + CALL MAPCEM (' MAPROJ - UNKNOWN PROJECTION NAME ',ARG1,IIER,1) + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPRS +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM + COMMON /MAPCM7/ ULOW,UROW,VBOW,VTOW +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPRS','VERSION 1') +C +C RESTORE THE SET CALL. +C + CALL SET (ULOW,UROW,VBOW,VTOW,UMIN,UMAX,VMIN,VMAX,1) +C +C DONE. +C + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPRST (IFNO) +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM3/ ITPN,NOUT,NPTS,IGID,BLAG,SLAG,BLOG,SLOG,PNTS(200) + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL + COMMON /MAPCMB/ IIER + COMMON /MAPNTS/ INTS(7) + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPRST','VERSION 1') +C +C READ A RECORD OF SAVED PARAMETERS. +C + READ (IFNO,ERR=901,END=902) NOUT,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1, + + PLA2,PLA3,PLA4,PLB1,PLB2,PLB3,PLB4, + + PLTR,GRID,IDSH,IDOT,LBLF,PRMF,ELPF, + + XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH, + + ILCW,DPLT,DDTS,SALT,SSMO,SRSS,ALFA, + + BETA,SALF,CALF,SBET,CBET, + + (INTS(I),I=1,7) +C +C RE-INITIALIZE EZMAP. +C + CALL MAPINT +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=20 + CALL SETER ('MAPRST - ERROR ON READ',IIER,1) + RETURN +C + 902 IIER=21 + CALL SETER ('MAPRST - EOF ON READ',IIER,1) + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPSAV (IFNO) +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM3/ ITPN,NOUT,NPTS,IGID,BLAG,SLAG,BLOG,SLOG,PNTS(200) + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL + COMMON /MAPCMB/ IIER + COMMON /MAPNTS/ INTS(7) + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPSAV','VERSION 1') +C +C WRITE A RECORD CONTAINING ALL THE USER-SETTABLE PARAMETERS. +C + WRITE (IFNO,ERR=901) NOUT,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1, + + PLA2,PLA3,PLA4,PLB1,PLB2,PLB3,PLB4, + + PLTR,GRID,IDSH,IDOT,LBLF,PRMF,ELPF, + + XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH, + + ILCW,DPLT,DDTS,SALT,SSMO,SRSS,ALFA, + + BETA,SALF,CALF,SBET,CBET, + + (INTS(I),I=1,7) +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=22 + CALL SETER ('MAPSAV - ERROR ON WRITE',IIER,1) + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPSET (ARG1,ARG2,ARG3,ARG4,ARG5) +C + CHARACTER*(*) ARG1 + DIMENSION ARG2(2),ARG3(2),ARG4(2),ARG5(2) +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCM5/ DDCT(5),LDCT(5),PDCT(10) + CHARACTER*2 DDCT,LDCT,PDCT + COMMON /MAPCMB/ IIER +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPSET','VERSION 1') +C +C TRANSFER THE PARAMETERS DEFINING THE MAP LIMITS. +C + I=IDICTL(ARG1,LDCT,5) + IF (I.EQ.0) GO TO 901 + ILTS=I +C + PLA1=ARG2(1) + PLA2=ARG3(1) + PLA3=ARG4(1) + PLA4=ARG5(1) +C + IF (I.EQ.3) THEN + PLB1=ARG2(2) + PLB2=ARG3(2) + PLB3=ARG4(2) + PLB4=ARG5(2) + END IF +C +C SET THE FLAG TO INDICATE THAT INITIALIZATION IS NOW REQUIRED. +C + INTF=.TRUE. +C +C DONE. +C + RETURN +C +C ERROR EXIT. +C + 901 IIER=10 + CALL MAPCEM (' MAPSET - UNKNOWN MAP AREA SPECIFIER ',ARG1,IIER,1) + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPSTC (WHCH,CVAL) +C + CHARACTER*(*) WHCH,CVAL +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM3/ ITPN,NOUT,NPTS,IGID,BLAG,SLAG,BLOG,SLOG,PNTS(200) + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCM5/ DDCT(5),LDCT(5),PDCT(10) + CHARACTER*2 DDCT,LDCT,PDCT + COMMON /MAPCMB/ IIER +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPSTC','VERSION 1') +C + IF (WHCH(1:2).EQ.'OU') THEN + I=IDICTL(CVAL,DDCT,5) + IF (I.EQ.0) GO TO 901 + NOUT=I-1 + ELSE + GO TO 902 + END IF +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=11 + CALL MAPCEM (' MAPSTC - UNKNOWN OUTLINE NAME ',CVAL,IIER,1) + RETURN +C + 902 IIER=12 + CALL MAPCEM (' MAPSTC - UNKNOWN PARAMETER NAME ',WHCH,IIER,1) + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPSTI (WHCH,IVAL) +C + CHARACTER*(*) WHCH +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCM7/ ULOW,UROW,VBOW,VTOW + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL + COMMON /MAPCMB/ IIER + COMMON /MAPNTS/ INTS(7) + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPSTI','VERSION 1') +C + IF (WHCH(1:2).EQ.'DA') THEN + IDSH=IVAL + ELSE IF (WHCH(1:2).EQ.'DD') THEN + DDTS=IVAL + DBTD=DDTS/DSCA + ELSE IF (WHCH(1:2).EQ.'DL') THEN + IDTL=IVAL + ELSE IF (WHCH(1:2).EQ.'DO') THEN + IDOT=IVAL + ELSE IF (WHCH(1:2).EQ.'EL') THEN + ELPF=IVAL.NE.0 + ELSE IF (WHCH(1:2).EQ.'GR') THEN + GRID=IVAL + ELSE IF (WHCH(1:2).EQ.'I1') THEN + INTS(1)=IVAL + ELSE IF (WHCH(1:2).EQ.'I2') THEN + INTS(2)=IVAL + ELSE IF (WHCH(1:2).EQ.'I3') THEN + INTS(3)=IVAL + ELSE IF (WHCH(1:2).EQ.'I4') THEN + INTS(4)=IVAL + ELSE IF (WHCH(1:2).EQ.'I5') THEN + INTS(5)=IVAL + ELSE IF (WHCH(1:2).EQ.'I6') THEN + INTS(6)=IVAL + ELSE IF (WHCH(1:2).EQ.'I7') THEN + INTS(7)=IVAL + ELSE IF (WHCH(1:2).EQ.'LA') THEN + LBLF=IVAL.NE.0 + ELSE IF (WHCH(1:2).EQ.'LS') THEN + ILCW=IVAL + ELSE IF (WHCH(1:2).EQ.'MV') THEN + DPLT=IVAL + DPSQ=DPLT*DPLT + ELSE IF (WHCH(1:2).EQ.'PE') THEN + PRMF=IVAL.NE.0 + ELSE IF (WHCH(1:2).EQ.'RE') THEN + PLTR=IVAL + DSCA=(UROW-ULOW)*PLTR/(UMAX-UMIN) + DSSQ=DSCA*DSCA + DBTD=DDTS/DSCA + ELSE IF (WHCH(1:2).EQ.'SA') THEN + SALT=IVAL + IF (ABS(SALT).GT.1.) THEN + SSMO=SALT*SALT-1. + SRSS=SQRT(SSMO) + END IF + ELSE IF (WHCH(1:2).EQ.'S1') THEN + ALFA=IVAL + SALF=SIN(.017453292519943*ALFA) + CALF=COS(.017453292519943*ALFA) + ELSE IF (WHCH(1:2).EQ.'S2') THEN + BETA=IVAL + SBET=SIN(.017453292519943*BETA) + CBET=COS(.017453292519943*BETA) + ELSE + GO TO 901 + END IF +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=13 + CALL MAPCEM (' MAPSTI - UNKNOWN PARAMETER NAME ',WHCH,IIER,1) + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPSTL (WHCH,LVAL) +C + CHARACTER*(*) WHCH + LOGICAL LVAL +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMB/ IIER +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPSTL','VERSION 1') +C + IF (WHCH(1:2).EQ.'DL') THEN + IDTL=0 + IF (LVAL) IDTL=1 + ELSE IF (WHCH(1:2).EQ.'DO') THEN + IDOT=0 + IF (LVAL) IDOT=1 + ELSE IF (WHCH(1:2).EQ.'EL') THEN + ELPF=LVAL + ELSE IF (WHCH(1:2).EQ.'LA') THEN + LBLF=LVAL + ELSE IF (WHCH(1:2).EQ.'PE') THEN + PRMF=LVAL + ELSE + GO TO 901 + END IF +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=14 + CALL MAPCEM (' MAPSTL - UNKNOWN PARAMETER NAME ',WHCH,IIER,1) + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPSTR (WHCH,RVAL) +C + CHARACTER*(*) WHCH +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCM7/ ULOW,UROW,VBOW,VTOW + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL + COMMON /MAPCMB/ IIER + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','MAPSTR','VERSION 1') +C + IF (WHCH(1:2).EQ.'DD') THEN + DDTS=RVAL + DBTD=DDTS/DSCA + ELSE IF (WHCH(1:2).EQ.'GD') THEN + GRDR=AMAX1(.001,AMIN1(10.,RVAL)) + ELSE IF (WHCH(1:2).EQ.'GR') THEN + GRID=RVAL + ELSE IF (WHCH(1:2).EQ.'MV') THEN + DPLT=RVAL + DPSQ=DPLT*DPLT + ELSE IF (WHCH(1:2).EQ.'RE') THEN + PLTR=RVAL + DSCA=(UROW-ULOW)*PLTR/(UMAX-UMIN) + DSSQ=DSCA*DSCA + DBTD=DDTS/DSCA + ELSE IF (WHCH(1:2).EQ.'SA') THEN + SALT=RVAL + IF (ABS(SALT).GT.1.) THEN + SSMO=SALT*SALT-1. + SRSS=SQRT(SSMO) + END IF + ELSE IF (WHCH(1:2).EQ.'S1') THEN + ALFA=RVAL + SALF=SIN(.017453292519943*ALFA) + CALF=COS(.017453292519943*ALFA) + ELSE IF (WHCH(1:2).EQ.'S2') THEN + BETA=RVAL + SBET=SIN(.017453292519943*BETA) + CBET=COS(.017453292519943*BETA) + ELSE IF (WHCH(1:2).EQ.'SR') THEN + SRCH=AMAX1(.001,AMIN1(10.,RVAL)) + ELSE + GO TO 901 + END IF +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=15 + CALL MAPCEM (' MAPSTR - UNKNOWN PARAMETER NAME ',WHCH,IIER,1) + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPTRN (RLAT,RLON,U,V) +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM1/ IPRJ,SINO,COSO,SINR,COSR,PHOC + COMMON /MAPCM8/ P,Q,R + COMMON /MAPCMB/ IIER + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C DEFINE REQUIRED CONSTANTS. DTOR IS PI OVER 180, DTRH IS HALF OF DTOR +C OR PI OVER 360, AND TOPI IS 2 OVER PI. +C + DATA DTOR / .017453292519943 / + DATA DTRH / .008726646259971 / + DATA RTOD / 57.2957795130823 / + DATA TOPI / .636619772367581 / +C +C SET UP U AND V FOR THE FAST PATHS. U IS A LONGITUDE, IN DEGREES, +C BETWEEN -180. AND +180., INCLUSIVE, AND V IS A LATITUDE, IN DEGREES. +C + TMP1=RLON-PHOC + U=TMP1-SIGN(180.,TMP1+180.)+SIGN(180.,180.-TMP1) + V=RLAT +C +C TAKE FAST PATHS FOR SIMPLE CYLINDRICAL PROJECTIONS. +C + IF (IPRJ-10) 101,116,112 +C +C NO FAST PATH. SORT OUT THE LAMBERT CONFORMAL CONIC FROM THE REST. +C + 101 IF (IPRJ-1) 901,102,103 +C +C LAMBERT CONFORMAL CONIC. +C + 102 P=U + CHI=90.-SINO*RLAT + IF (CHI.GE.179.9999) GO TO 118 + R=TAN(DTRH*CHI)**COSO + U=U*COSO*DTOR + V=-R*SINO*COS(U) + U=R*SIN(U) + GO TO 117 +C +C NOT LAMBERT CONFORMAL CONIC. CALCULATE CONSTANTS COMMON TO MOST OF +C THE OTHER PROJECTIONS. +C + 103 TMP1=U*DTOR + TMP2=V*DTOR + SINPH=SIN(TMP1) + SINLA=SIN(TMP2) + COSPH=COS(TMP1) + COSLA=COS(TMP2) + TCOS=COSLA*COSPH + COSA=AMAX1(-1.,AMIN1(+1.,SINLA*SINO+TCOS*COSO)) + SINA=SQRT(1.-COSA*COSA) + IF (SINA.LT..0001) THEN + SINA=0. + IF (IPRJ.GE.7.OR.COSA.LT.0.) GO TO 118 + U=0. + V=0. + GO TO 116 + END IF + SINB=COSLA*SINPH/SINA + COSB=(SINLA*COSO-TCOS*SINO)/SINA +C +C JUMP TO CODE APPROPRIATE FOR THE CHOSEN PROJECTION. +C + GO TO (104,105,106,107,108,109,110,111) , IPRJ-1 +C +C STEREOGRAPHIC. +C + 104 IF (ABS(SINA).LT..0001) THEN + R=SINA/2. + ELSE + R=(1.-COSA)/SINA + END IF + GO TO 115 +C +C ORTHOGRAPHIC OR SATELLITE-VIEW, DEPENDING ON THE VALUE OF SALT. +C + 105 IF (ABS(SALT).LE.1.) THEN + IF (COSA.GT.0.) THEN + R=SINA + ELSE + IF (SALT.GE.0.) GO TO 118 + R=2.-SINA + END IF + GO TO 115 + ELSE + IF (COSA.GT.1./ABS(SALT)) THEN + R=SRSS*SINA/(ABS(SALT)-COSA) + ELSE + IF (SALT.GE.0.) GO TO 118 + R=2.-SRSS*SINA/(ABS(SALT)-COSA) + END IF + IF (ALFA.EQ.0.) GO TO 115 + UTM1=R*(SINB*COSR+COSB*SINR) + VTM1=R*(COSB*COSR-SINB*SINR) + UTM2=UTM1*CBET+VTM1*SBET + VTM2=VTM1*CBET-UTM1*SBET + UTM3=SRSS*UTM2/(UTM2*SALF+SRSS*CALF) + VTM3=SRSS*VTM2*CALF/(UTM2*SALF+SRSS*CALF) + U=UTM3*CBET-VTM3*SBET + V=VTM3*CBET+UTM3*SBET + GO TO 116 + END IF +C +C LAMBERT EQUAL AREA. +C + 106 IF (ABS(COSA+1.).LT.1.E-6) GO TO 118 + R=(1.+COSA)/SINA + R=2./SQRT(1.+R*R) + GO TO 115 +C +C GNOMONIC. +C + 107 IF (COSA.LE..0001) GO TO 118 + R=SINA/COSA + GO TO 115 +C +C AZIMUTHAL EQUIDISTANT. +C + 108 IF (ABS(COSA+1.).LT.1.E-6) GO TO 118 + R=ACOS(COSA) + GO TO 115 +C +C CYLINDRICAL EQUIDISTANT, ARBITRARY POLE AND ORIENTATION. +C + 109 U=ATAN2(SINB*COSR+COSB*SINR,SINB*SINR-COSB*COSR)*RTOD + V=90.-ACOS(COSA)*RTOD + GO TO 116 +C +C MERCATOR, ARBITRARY POLE AND ORIENTATION. +C + 110 U=ATAN2(SINB*COSR+COSB*SINR,SINB*SINR-COSB*COSR) + V=ALOG((1.+COSA)/SINA) + GO TO 116 +C +C MOLLWEIDE, ARBITRARY POLE AND ORIENTATION. +C + 111 U=ATAN2(SINB*COSR+COSB*SINR,SINB*SINR-COSB*COSR)*TOPI + P=U + V=COSA + U=U*SINA + GO TO 117 +C +C FAST-PATH CYLINDRICAL PROJECTIONS (WITH PLAT=ROTA=0). +C + 112 IF (IPRJ-12) 113,114,901 +C +C FAST-PATH MERCATOR. +C + 113 IF (ABS(RLAT).GT.89.9999) GO TO 118 + U=U*DTOR + V=ALOG(TAN((RLAT+90.)*DTRH)) + GO TO 116 +C +C FAST-PATH MOLLWEIDE. +C + 114 U=U/90. + V=SIN(RLAT*DTOR) + P=U + U=U*SQRT(1.-V*V) + GO TO 117 +C +C COMMON TERMINAL CODE FOR CERTAIN PROJECTIONS. +C + 115 U=R*(SINB*COSR+COSB*SINR) + V=R*(COSB*COSR-SINB*SINR) +C + 116 P=U +C + 117 Q=V +C +C NORMAL EXIT. +C + RETURN +C +C PROJECTION OF POINT IS INVISIBLE OR UNDEFINED. +C + 118 U=1.E12 + P=U + RETURN +C +C ERROR EXIT. +C + 901 IF (IIER.NE.0) GO TO 118 + IIER=16 + CALL SETER (' MAPTRN - ATTEMPT TO USE NON-EXISTENT PROJECTION', + + IIER,1) + GO TO 118 +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPUSR (IPRT) + RETURN + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPVEC (XLAT,XLON) + CALL MAPIT (XLAT,XLON,1) + RETURN + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE SUPCON (RLAT,RLON,UVAL,VVAL) + CALL MAPTRN (RLAT,RLON,UVAL,VVAL) + RETURN + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE SUPMAP (JPRJ,PLAT,PLON,ROTA,PLM1,PLM2,PLM3,PLM4,JLTS, + + JGRD,IOUT,IDOT,IERR) +C + DIMENSION PLM1(2),PLM2(2),PLM3(2),PLM4(2) +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM5/ DDCT(5),LDCT(5),PDCT(10) + CHARACTER*2 DDCT,LDCT,PDCT + COMMON /MAPCMB/ IIER +C + DIMENSION LPRJ(10),LLTS(5) +C + DATA LPRJ / 2,3,1,4,5,6,10,7,8,9 / + DATA LLTS / 1,2,5,4,3 / +C +C THE FOLLOWING CALL GATHERS STATISTICS ON LIBRARY USAGE AT NCAR. +C + CALL Q8QST4 ('GRAPHX','EZMAP','SUPMAP','VERSION 1') +C +C SET EZMAP'S GRID-SPACING PARAMETER. +C + CALL MAPSTI ('GR',MOD(IABS(JGRD),1000)) +C +C SET EZMAP'S OUTLINE-SELECTION PARAMETER. +C + IF (IABS(IOUT).EQ.0.OR.IABS(IOUT).EQ.1) THEN + I=1+2*IABS(IOUT)+(1+ISIGN(1,JPRJ))/2 + ELSE + I=MAX0(1,MIN0(5,IOUT)) + END IF +C + CALL MAPSTC ('OU',DDCT(I)) +C +C SET EZMAP'S PERIMETER-DRAWING FLAG. +C + CALL MAPSTL ('PE',JGRD.GE.0) +C +C SET EZMAP'S GRID-LINE-LABELLING FLAG. +C + CALL MAPSTL ('LA',MOD(IABS(JGRD),1000).NE.0) +C +C SET EZMAP'S DOTTED-OUTLINE FLAG. +C + CALL MAPSTI ('DO',MAX0(0,MIN0(1,IDOT))) +C +C SET EZMAP'S PROJECTION-SELECTION PARAMETERS. +C + I=MAX0(1,MIN0(10,IABS(JPRJ))) + CALL MAPROJ (PDCT(LPRJ(I)),PLAT,PLON,ROTA) +C +C SET EZMAP'S RECTANGULAR-LIMITS-SELECTION PARAMETERS. +C + I=LLTS(MAX0(1,MIN0(5,IABS(JLTS)))) + CALL MAPSET (LDCT(I),PLM1,PLM2,PLM3,PLM4) +C +C DRAW THE MAP. +C + CALL MAPDRW +C +C RETURN THE ERROR FLAG TO THE USER. +C + IERR=IIER +C +C DONE. +C + RETURN +C + END +C +C*********************************************************************** +C T H E C O D E - I N T E R N A L R O U T I N E S +C*********************************************************************** +C + SUBROUTINE MAPCEM (IEM1,IEM2,IIER,IFLG) +C + CHARACTER*(*) IEM1,IEM2 +C +C MAPCEM IS CALLED TO DO A CALL TO SETER WHEN THE ERROR MESSAGE TO BE +C PRINTED IS IN TWO PARTS WHICH NEED TO BE CONCATENATED. FORTRAN-77 +C RULES MAKE IT NECESSARY TO CONCATENATE THE TWO PARTS OF THE MESSAGE +C INTO A LOCAL CHARACTER VARIABLE. +C + CHARACTER*100 IEMC +C + IEMC=IEM1//IEM2 + CALL SETER (IEMC,IIER,IFLG) +C + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPCHI (IPRT,IDTG,IDPT) +C +C MAPCHI IS CALLED BY VARIOUS EZMAP ROUTINES TO RESET THE INTENSITY, +C DOTTING, AND DASH PATTERN BEFORE AND AFTER DRAWING PARTS OF A MAP. +C +C THE ARGUMENT IPRT, IF POSITIVE, SAYS WHICH PART OF THE MAP IS ABOUT +C TO BE DRAWN, AS FOLLOWS: +C +C IPRT PART OF MAP. +C ---- ------------ +C 1 PERIMETER. +C 2 GRID. +C 3 LABELLING. +C 4 LIMB LINES. +C 5 OUTLINE POINT GROUP, CONTINENTAL. +C 6 OUTLINE POINT GROUP, U.S. +C 7 OUTLINE POINT GROUP, COUNTRY. +C +C A CALL WITH IPRT EQUAL TO THE NEGATIVE OF ONE OF THESE VALUES ASKS +C THAT THE INTENSITY SAVED BY THE LAST CALL, WITH IPRT POSITIVE, BE +C RESTORED. +C +C WHEN IPRT IS POSITIVE, IDTG IS ZERO IF SOLID LINES ARE TO BE USED, 1 +C IF DOTTED LINES ARE TO BE USED. IF IPRT IS NEGATIVE, IDTG IS IGNORED. +C +C WHEN IPRT IS POSITIVE AND IDTG IS ZERO, IDPT IS THE DASH PATTERN TO BE +C USED. IF IPRT IS NEGATIVE OR IDTG IS NON-ZERO, IDPT IS IGNORED. +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPNTS/ INTS(7) +C +C DECLARE ONE OF THE DASH-PACKAGE COMMON BLOCKS, TOO. +C + COMMON /SMFLAG/ ISMO +C +C THE VARIABLES INTO, IDTS, AND ISMS NEED TO BE SAVED BETWEEN CALLS. +C + SAVE INTO,IDTS,ISMS +C +C FLUSH ALL BUFFERS BEFORE CHANGING ANYTHING. +C + CALL MAPIQ +C +C SET/RESET INTENSITY, DOTTING, AND DASH PATTERN. THE USER HAS THE +C LAST WORD. +C + IF (IPRT.GT.0) THEN + ISMS=ISMO + ISMO=1 + IDTS=IDTL + IDTL=IDTG + IF (IDTL.EQ.0) CALL DASHDB (IDPT) +C +C THE FOLLOWING LINES HAVE BEEN COMMENTED OUT BECAUSE THE INTENSITY +C SETTING CAUSES SOME STRANGE BEHAVIOUR ON CERTAIN TERMINALS AND +C WORKSTATIONS. +C +C CALL GETUSV ('IN',INTO) +C CALL SETUSV ('IN',IFIX(10000.*FLOAT(INTS(IPRT))/255.)) + CALL MAPUSR (IPRT) + ELSE + CALL MAPUSR (IPRT) +C +C THE FOLLOWING LINE HAVE BEEN COMMENTED OUT BECAUSE THE INTENSITY +C SETTING CAUSES SOME STRANGE BEHAVIOUR ON CERTAIN TERMINALS AND +C WORKSTATIONS. +C +C CALL SETUSV ('IN',INTO) + IF (IDTL.EQ.0) CALL DASHDB (IOR(ISHIFT(32767,1),1)) + IDTL=IDTS + ISMO=ISMS + END IF +C +C DONE. +C + RETURN +C + END +C +C----------------------------------------------------------------------- +C + INTEGER FUNCTION IDICTL (ISTR,IDCT,NDCT) +C + CHARACTER*(*) ISTR + CHARACTER*2 IDCT(NDCT) +C +C THE VALUE OF THIS FUNCTION IS THE INDEX IN THE NDCT-ELEMENT DICTIONARY +C IDCT OF THE STRING ISTR. ONLY THE FIRST TWO CHARACTERS OF ISTR AND +C IDCT(I) ARE COMPARED. IF ISTR IS NOT FOUND IN THE DICTIONARY, THE +C FUNCTION VALUE IS ZERO. +C + DO 101 I=1,NDCT + IF (ISTR(1:2).EQ.IDCT(I)) THEN + IDICTL=I + RETURN + END IF + 101 CONTINUE +C +C NOT FOUND. RETURN A ZERO. +C + IDICTL=0 + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPIO (IACT) +C +C THIS ROUTINE PERFORMS ALL POSITIONING AND INPUT OF THE OUTLINE DATASET +C FOR MAPLOT. THE ARGUMENT IACT SPECIFIES WHAT IS TO BE DONE: 1 ASKS +C THAT THE DATASET BE POSITIONED AT THE BEGINNING OF THE DESIRED "FILE", +C 2 THAT THE NEXT RECORD BE READ. +C +C FIVE LINES OF THE CODE BELOW HAVE BEEN INSERTED TO MAKE THIS ROUTINE +C RUN EFFICIENTLY ON NCAR'S CRAYS; THESE LINES SHOULD BE REMOVED BY +C ANYONE IMPLEMENTING EZMAP ON ANOTHER SYSTEM (EXCEPT PERHAPS ANOTHER +C CRAY). +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM3/ ITPN,NOUT,NPTS,IGID,BLAG,SLAG,BLOG,SLOG,PNTS(200) + COMMON /MAPCMB/ IERR +C + IF (IACT.EQ.1) THEN +C +C POSITION TO THE DESIRED "FILE" WITHIN THE DATASET. +C +C THE FOLLOWING FIVE LINES ARE FOR NCAR'S CRAYS. +C +C ITPN=6LEZMPDT +C IF (IFDNT(ITPN).EQ.0) THEN +C CALL SDACCESS (IERR,ITPN) +C IF (IERR.NE.0) GO TO 901 +C END IF +C + REWIND ITPN +C + IF (NOUT.NE.1) THEN + ITMP=NOUT + 101 READ (ITPN,END=902) NPTS,IGID,BLAG,SLAG,BLOG,SLOG, + + (PNTS(I),I=1,NPTS) + IF (NPTS.GT.1) GO TO 101 + ITMP=ITMP-1 + IF (ITMP.GT.1) GO TO 101 + END IF +C + ELSE +C +C READ THE NEXT RECORD. +C + READ (ITPN) NPTS,IGID,BLAG,SLAG,BLOG,SLOG,(PNTS(I),I=1,NPTS) + NPTS=NPTS/2 +C + END IF +C +C DONE. +C + RETURN +C +C ERROR EXITS. +C + 901 IIER=17 + CALL SETER (' MAPIO - OUTLINE DATASET IS UNREADABLE',IIER,1) + NOUT=0 + RETURN +C + 902 IIER=18 + CALL SETER (' MAPIO - EOF ENCOUNTERED IN OUTLINE DATASET',IIER,1) + NOUT=0 + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPLMB +C +C THE ROUTINE MAPLMB IS CALLED BY MAPGRD AND/OR MAPLOT TO DRAW THE LIMB +C LINES. +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM1/ IPRJ,SINO,COSO,SINR,COSR,PHOC + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C DEFINE REQUIRED CONSTANTS. SIN1 AND COS1 ARE RESPECTIVELY THE SINE +C AND COSINE OF ONE DEGREE. +C + DATA SIN1 / .017452406437283 / + DATA COS1 / .999847695156390 / + DATA PI / 3.14159265358979 / +C +C THE ARITHMETIC STATEMENT FUNCTIONS FLOOR AND CLING GIVE, RESPECTIVELY, +C THE "FLOOR" OF X - THE LARGEST INTEGER LESS THAN OR EQUAL TO X - AND +C THE "CEILING" OF X - THE SMALLEST INTEGER GREATER THAN OR EQUAL TO X. +C + FLOOR(X)=AINT(X+1.E4)-1.E4 + CLING(X)=-FLOOR(-X) +C +C RESET THE INTENSITY, DOTTING, AND DASH PATTERN FOR LIMB LINES. +C + CALL MAPCHI (4,0,IOR(ISHIFT(32767,1),1)) +C +C DRAW LIMB LINES, THE NATURE OF WHICH DEPENDS ON THE PROJECTION. +C + GO TO (101,110,104,105,110,106,110,110,107,110,110,107) , IPRJ +C +C LAMBERT CONFORMAL CONIC WITH TWO STANDARD PARALLELS. +C + 101 DLAT=GRDR + RLON=PHIO+179.9999 + K=CLING(180./DLAT) + DO 103 I=1,2 + RLAT=-90. + CALL MAPIT (RLAT,RLON,0) + DO 102 J=1,K-1 + RLAT=RLAT+DLAT + CALL MAPIT (RLAT,RLON,1) + 102 CONTINUE + RLAT=RLAT+DLAT + CALL MAPIT (RLAT,RLON,2) + RLON=PHIO-179.9999 + 103 CONTINUE + GO TO 110 +C +C ORTHOGRAPHIC (OR SATELLITE-VIEW). +C + 104 IF (ABS(SALT).LE.1..OR.ALFA.EQ.0.) THEN + URAD=1. + RVTU=1. + ELSE + DNOM=SALT*SALT*CALF*CALF-1. + URAD=SSMO*CALF/DNOM + RVTU=SQRT(DNOM)/SRSS + END IF + GO TO 108 +C +C LAMBERT EQUAL AREA. +C + 105 URAD=2. + RVTU=1. + GO TO 108 +C +C AZIMUTHAL EQUIDISTANT. +C + 106 URAD=PI + RVTU=1. + GO TO 108 +C +C MOLLWEIDE. +C + 107 URAD=2. + RVTU=0.5 +C + 108 UCIR=URAD + VCIR=0. + IVIS=-1 + DO 109 I=1,361 + IF (IPRJ.NE.3.OR.ABS(SALT).LE.1..OR.ALFA.EQ.0.) THEN + U=UCIR + V=RVTU*VCIR + ELSE + UTMP=UCIR-SRSS*SALF/DNOM + VTMP=RVTU*VCIR + U=UTMP*CBET-VTMP*SBET + V=VTMP*CBET+UTMP*SBET + END IF + IF (.NOT.ELPF.AND. + + (U.LT.UMIN.OR.U.GT.UMAX.OR.V.LT.VMIN.OR.V.GT.VMAX)) THEN + IF (IVIS.EQ.1) THEN + CALL MAPTRP (UOLD,VOLD,U,V,UEDG,VEDG) + CALL MAPVP (UOLD,VOLD,UEDG,VEDG) + END IF + IVIS=0 + ELSE IF (ELPF.AND. + + (((U-UCEN)/URNG)**2+((V-VCEN)/VRNG)**2.GT.1.)) THEN + IF (IVIS.EQ.1) THEN + CALL MAPTRE (UOLD,VOLD,U,V,UEDG,VEDG) + CALL MAPVP (UOLD,VOLD,UEDG,VEDG) + END IF + IVIS=0 + ELSE + IF (IVIS.LT.0) THEN + DATL=0. + CALL FRSTD (U,V) + IVIS=1 + ELSE + IF (IVIS.EQ.0) THEN + IF (.NOT.ELPF) CALL MAPTRP (U,V,UOLD,VOLD,UOLD,VOLD) + IF ( ELPF) CALL MAPTRE (U,V,UOLD,VOLD,UOLD,VOLD) + DATL=0. + CALL FRSTD (UOLD,VOLD) + IVIS=1 + END IF + CALL MAPVP (UOLD,VOLD,U,V) + END IF + END IF + UOLD=U + VOLD=V + UTMP=UCIR + VTMP=VCIR + UCIR=UTMP*COS1-VTMP*SIN1 + VCIR=UTMP*SIN1+VTMP*COS1 + 109 CONTINUE +C +C RESTORE THE ORIGINAL INTENSITY, DOTTING, AND DASH PATTERN. +C + 110 CALL MAPCHI (-4,0,0) +C +C DONE. +C + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPTRE (UINS,VINS,UOUT,VOUT,UINT,VINT) +C +C THIS ROUTINE FINDS THE POINT OF INTERSECTION (UINT,VINT) OF THE LINE +C FROM (UINS,VINS) TO (UOUT,VOUT) WITH THE EDGE OF AN ELLIPTICAL FRAME. +C THE FIRST POINT IS INSIDE THE FRAME AND THE SECOND OUTSIDE THE FRAME. +C +C BECAUSE MAPTRE CAN BE CALLED WITH THE SAME ACTUAL ARGUMENTS FOR UINT +C AND VINT AS FOR UOUT AND VOUT, RESPECTIVELY, UINT AND VINT MUST NOT +C BE RESET UNTIL ALL USE OF UOUT AND VOUT IS COMPLETE. +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM +C +C WHAT'S INVOLVED IS JUST A LOT OF ALGEBRA. +C + IF (ABS(UOUT-UINS).GT.ABS(VOUT-VINS)) THEN + P=(VOUT-VINS)/(UOUT-UINS) + Q=(UOUT*VINS-UINS*VOUT)/(UOUT-UINS) + A=VRNG*VRNG+P*P*URNG*URNG + B=2.*(P*Q*URNG*URNG-UCEN*VRNG*VRNG-P*URNG*URNG*VCEN) + C=UCEN*UCEN*VRNG*VRNG+Q*Q*URNG*URNG-2.*Q*URNG*URNG*VCEN+ + + URNG*URNG*VCEN*VCEN-URNG*URNG*VRNG*VRNG + UTM1=SQRT(AMAX1(B*B-4.*A*C,0.)) + UTM2=.5*(-B-UTM1)/A + IF ((UTM2-UOUT)*(UTM2-UINS).GT.0.) UTM2=.5*(-B+UTM1)/A + UINT=UTM2 + VINT=P*UINT+Q + ELSE + P=(UOUT-UINS)/(VOUT-VINS) + Q=(UINS*VOUT-UOUT*VINS)/(VOUT-VINS) + A=URNG*URNG+P*P*VRNG*VRNG + B=2.*(P*Q*VRNG*VRNG-URNG*URNG*VCEN-P*UCEN*VRNG*VRNG) + C=URNG*URNG*VCEN*VCEN+Q*Q*VRNG*VRNG-2.*Q*UCEN*VRNG*VRNG+ + + UCEN*UCEN*VRNG*VRNG-URNG*URNG*VRNG*VRNG + VTM1=SQRT(AMAX1(B*B-4.*A*C,0.)) + VTM2=.5*(-B-VTM1)/A + IF ((VTM2-VOUT)*(VTM2-VINS).GT.0.) VTM2=.5*(-B+VTM1)/A + VINT=VTM2 + UINT=P*VINT+Q + END IF +C +C DONE. +C + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPTRP (UINS,VINS,UOUT,VOUT,UINT,VINT) +C +C THIS ROUTINE FINDS THE POINT OF INTERSECTION (UINT,VINT) OF THE LINE +C FROM (UINS,VINS) TO (UOUT,VOUT) WITH THE EDGE OF A RECTANGULAR FRAME. +C THE FIRST POINT IS INSIDE THE FRAME AND THE SECOND OUTSIDE THE FRAME. +C +C BECAUSE MAPTRP CAN BE CALLED WITH THE SAME ACTUAL ARGUMENTS FOR UINT +C AND VINT AS FOR UOUT AND VOUT, RESPECTIVELY, UINT AND VINT MUST NOT +C BE RESET UNTIL ALL USE OF UOUT AND VOUT IS COMPLETE. +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM +C +C GIVEN ONE COORDINATE OF A POINT ON THE LINE JOINING (UINS,VINS) AND +C (UOUT,VOUT), THE OTHER CAN BE OBTAINED BY USING ONE OF THE FOLLOWING +C ARITHMETIC STATEMENT FUNCTIONS: +C + UFUN(V)=UINS+(V-VINS)*DU/DV + VFUN(U)=VINS+(U-UINS)*DV/DU +C +C I I +C 5 I 4 I 6 +C I I +C ----------------- +C FIRST, DETERMINE IN WHICH I I +C OF THE AREAS SHOWN THE 2 I 1 I 3 +C POINT (UOUT,VOUT) LIES. I I +C ----------------- +C I I +C 8 I 7 I 9 +C I I +C + IREA=1 + IF (UOUT-UMIN) 101,104,102 + 101 IREA=IREA+1 + GO TO 104 + 102 IF (UOUT-UMAX) 104,104,103 + 103 IREA=IREA+2 + 104 IF (VOUT-VMIN) 105,108,106 + 105 IREA=IREA+6 + GO TO 108 + 106 IF (VOUT-VMAX) 108,108,107 + 107 IREA=IREA+3 +C +C NEXT, COMPUTE THE QUANTITIES REQUIRED BY UFUN AND VFUN AND JUMP TO THE +C APPROPRIATE PIECE OF CODE FOR THE GIVEN AREA. +C + 108 DU=UOUT-UINS + DV=VOUT-VINS +C + GO TO (119,113,114,115,109,110,116,111,112) , IREA +C + 109 IF (UFUN(VMAX)-UMIN) 113,115,115 + 110 IF (UFUN(VMAX)-UMAX) 115,115,114 + 111 IF (UFUN(VMIN)-UMIN) 113,116,116 + 112 IF (UFUN(VMIN)-UMAX) 116,116,114 +C + 113 UINT=UMIN + GO TO 117 + 114 UINT=UMAX + GO TO 117 + 115 VINT=VMAX + GO TO 118 + 116 VINT=VMIN + GO TO 118 +C + 117 VINT=VFUN(UINT) + RETURN +C + 118 UINT=UFUN(VINT) + RETURN +C + 119 UINT=UOUT + VINT=VOUT + RETURN +C + END +C +C----------------------------------------------------------------------- +C + SUBROUTINE MAPVP (UOLD,VOLD,U,V) +C +C PLOT THE LINE SEGMENT FROM (UOLD,VOLD) TO (U,V), USING EITHER A SOLID +C LINE OR A DOTTED LINE (DEPENDING ON THE VALUE OF THE COMMON VARIABLE +C IDTL). +C +C DECLARE REQUIRED COMMON BLOCKS. SEE MAPBD FOR DESCRIPTIONS OF THESE +C COMMON BLOCKS AND THE VARIABLES IN THEM. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW + LOGICAL INTF,LBLF,PRMF,ELPF + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL + COMMON /MAPCMP/ NPTB,XPTB(50),YPTB(50) +C +C SELECT VECTOR OR DOT MODE. +C + IF (IDTL.EQ.0) THEN +C +C USE A SINGLE VECTOR. +C + CALL VECTD (U,V) +C + ELSE +C +C USE DOTS. DELU AND DELV ARE THE U AND V COMPONENTS OF THE VECTOR +C JOINING (UOLD,VOLD) TO (U,V) AND VLEN IS THE LENGTH OF THE VECTOR. +C + DELU=U-UOLD + DELV=V-VOLD +C + VLEN=SQRT(DELU*DELU+DELV*DELV) +C +C NOW DISTRIBUTE DOTS ALONG THE VECTOR. THE FIRST ONE IS SPACED JUST +C FAR ENOUGH ALONG IT (DATL UNITS) TO BE DBTD UNITS AWAY FROM THE LAST +C DOT ON THE PREVIOUS VECTOR AND THE REST ARE DBTD UNITS APART. +C + 101 IF (DATL.LT.VLEN) THEN + IF (NPTB.GE.50) THEN + CALL POINTS (XPTB,YPTB,NPTB,0,0) + NPTB=0 + END IF + NPTB=NPTB+1 + XPTB(NPTB)=UOLD+(DATL/VLEN)*DELU + YPTB(NPTB)=VOLD+(DATL/VLEN)*DELV + DATL=DATL+DBTD + GO TO 101 + END IF +C +C SET DATL FOR THE NEXT CALL. +C + DATL=DATL-VLEN +C + END IF +C +C DONE. +C + RETURN +C + END +C +C*********************************************************************** +C T H E B L O C K D A T A " R O U T I N E " - D E F A U L T S +C*********************************************************************** +C + BLOCK DATA MAPBD +C +C THE COMMON BLOCK MAPCM1 CONTAINS TRANSFORMATION CONSTANTS. +C + COMMON /MAPCM1/ IPRJ,SINO,COSO,SINR,COSR,PHOC +C +C THE COMMON BLOCK MAPCM2 CONTAINS AREA-SPECIFICATION VARIABLES. +C + COMMON /MAPCM2/ UMIN,UMAX,VMIN,VMAX,UEPS,VEPS,UCEN,VCEN,URNG,VRNG, + + BLAM,SLAM,BLOM,SLOM +C +C THE COMMON BLOCK MAPCM3 CONTAINS PARAMETERS HAVING TO DO WITH READING +C THE DATA FOR OUTLINES. +C + COMMON /MAPCM3/ ITPN,NOUT,NPTS,IGID,BLAG,SLAG,BLOG,SLOG,PNTS(200) +C +C THE COMMON BLOCK MAPCM4 CONTAINS MOST OF THE INPUT PARAMETERS. +C + COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4, + + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF, + + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW +C + LOGICAL INTF,LBLF,PRMF,ELPF +C +C THE COMMON BLOCK MAPCM5 CONTAINS VARIOUS LISTS ("DICTIONARIES") OF +C TWO-CHARACTER CODES REQUIRED BY EZMAP FOR PARAMETER-SETTING. +C + COMMON /MAPCM5/ DDCT(5),LDCT(5),PDCT(10) +C + CHARACTER*2 DDCT,LDCT,PDCT +C +C THE COMMON BLOCK MAPCM7 CONTAINS PARAMETERS DESCRIBING THE PORTION OF +C THE PLOTTER FRAME BEING USED. +C + COMMON /MAPCM7/ ULOW,UROW,VBOW,VTOW +C +C THE COMMON BLOCK MAPCM8 CONTAINS PARAMETERS SET BY MAPTRN AND USED BY +C MAPIT IN HANDLING "CROSS-OVER" PROBLEMS. +C + COMMON /MAPCM8/ P,Q,R +C +C THE COMMON BLOCK MAPCMA CONTAINS VALUES WHICH ARE USED TO POSITION +C DOTS ALONG DOTTED OUTLINES AND TO AVOID DRAWING VECTORS WHICH ARE +C TOO SHORT. +C + COMMON /MAPCMA/ DPLT,DDTS,DSCA,DPSQ,DSSQ,DBTD,DATL +C +C THE COMMON BLOCK MAPCMB CONTAINS THE EZMAP ERROR FLAG. +C + COMMON /MAPCMB/ IIER +C +C THE COMMON BLOCK MAPCMP CONTAINS THE BUFFERS IN WHICH THE X AND Y +C COORDINATES OF POINTS ARE COLLECTED FOR AN EVENTUAL CALL TO POINTS. +C + COMMON /MAPCMP/ NPTB,XPTB(50),YPTB(50) +C +C THE COMMON BLOCK MAPNTS CONTAINS QUANTITIES SPECIFYING THE INTENSITIES +C TO BE USED FOR VARIOUS PORTIONS OF THE PLOT. +C + COMMON /MAPNTS/ INTS(7) +C +C THE COMMON BLOCK MAPSAT CONTAINS PARAMETERS FOR THE SATELLITE-VIEW +C PROJECTION. +C + COMMON /MAPSAT/ SALT,SSMO,SRSS,ALFA,BETA,SALF,CALF,SBET,CBET +C +C +C BELOW ARE DESCRIPTIONS OF THE VARIABLES IN EACH OF THE COMMON BLOCKS, +C TOGETHER WITH DATA STATEMENTS GIVING DEFAULT VALUES TO THOSE VARIABLES +C WHICH NEED DEFAULT VARIABLES. +C +C +C VARIABLES IN MAPCM1: +C +C IPRJ IS AN INTEGER BETWEEN 1 AND 12, SPECIFYING WHAT PROJECTION IS +C CURRENTLY IN USE. THE VALUES 10, 11, AND 12 SPECIFY FAST-PATH +C VERSIONS OF THE VALUES 7, 8, AND 9, RESPECTIVELY. SINO, COSO, SINR, +C COSR, AND PHOC ARE PROJECTION VARIABLES COMPUTED BY MAPINT FOR USE BY +C MAPTRN. PHOC, AS IT HAPPENS, IS JUST A COPY OF PHIO, FROM THE COMMON +C BLOCK MAPCM4. +C +C +C VARIABLES IN MAPCM2: +C +C UMIN, UMAX, VMIN, AND VMAX SPECIFY THE LIMITS OF THE RECTANGLE TO BE +C DRAWN, IN PROJECTION SPACE. UEPS AND VEPS ARE SET BY MAPINT FOR USE +C IN MAPIT IN TESTING FOR CROSS-OVER PROBLEMS. UCEN, VCEN, URNG, AND +C VRNG ARE COMPUTED BY MAPINT FOR USE WHEN THE MAP PERIMETER IS MADE +C ELLIPTICAL (BY SETTING THE FLAG ELPF). BLAM, SLAM, BLOM, AND SLOM +C ARE RESPECTIVELY THE BIGGEST LATITUDE, THE SMALLEST LATITUDE, THE +C BIGGEST LONGITUDE, AND THE SMALLEST LONGITUDE ON THE MAP. THEY ARE +C USED IN MAPGRD AND IN MAPLOT TO MAKE THE DRAWING OF GRIDS AND OUTLINES +C MORE EFFICIENT. UMIN AND UMAX ARE GIVEN DEFAULT VALUES TO PREVENT +C IN MAPSTI AND MAPSTR FROM BLOWING UP WHEN PLTR IS SET PRIOR TO THE +C FIRST CALL TO MAPINT. +C + DATA UMIN,UMAX / 0.,1. / +C +C +C VARIABLES IN MAPCM3: +C +C ITPN IS THE UNIT NUMBER OF THE "TAPE" FROM WHICH OUTLINE DATA IS TO +C BE READ. NOUT IS THE NUMBER OF THE OUTLINE TO BE USED; THE VALUES 0 +C THROUGH 5 IMPLY 'NO', 'CO', 'US', 'PS', AND 'PO', RESPECTIVELY; THUS, +C IF NOUT IS ZERO, NO OUTLINES ARE TO BE USED, AND, IF IT IS NON-ZERO, +C IT IS THE NUMBER OF THE "FILE" TO BE READ FROM UNIT ITPN. NPTS, JUST +C AFTER A READ, IS THE NUMBER OF ELEMENTS READ INTO PNTS; IT IS THEN +C DIVIDED BY 2 TO BECOME THE NUMBER OF POINTS DEFINED BY THE GROUP JUST +C READ. IGID IS AN IDENTIFIER FOR THE GROUP, SO THAT, FOR EXAMPLE, ONE +C CAN DISTINGUISH A GROUP BELONGING TO A INTERNATIONAL BOUNDARY FROM +C ONE BELONGING TO A U.S. STATE BOUNDARY. BLAG, SLAG, BLOG, AND SLOG +C SPECIFY THE BIGGEST AND SMALLEST LATITUDE AND THE BIGGEST AND SMALLEST +C LONGITUDE OF THE POINTS IN THE GROUP, SO THAT, IN SOME CASES AT LEAST, +C ONE CAN DECIDE QUICKLY NOT TO BOTHER WITH THE GROUP. PNTS CONTAINS +C NPTS COORDINATE PAIRS, EACH CONSISTING OF A LATITUDE AND A LONGITUDE, +C IN DEGREES. +C + DATA ITPN,NOUT / 1,1 / +C +C +C VARIABLES IN MAPCM4: +C +C INTF IS A FLAG WHOSE VALUE AT ANY GIVEN TIME INDICATES WHETHER THE +C PACKAGE EZMAP IS IN NEED OF INITIALIZATION (.TRUE.) OR NOT (.FALSE). +C JPRJ IS AN INTEGER BETWEEN 1 AND 9 INDICATING THE TYPE OF PROJECTION +C CURRENTLY IN USE. PHIA, PHIO, AND ROTA ARE THE POLE LATITUDE AND +C LONGITUDE AND THE ROTATION ANGLE SPECIFIED BY THE LAST USER CALL TO +C MAPROJ. ILTS IS AN INTEGER BETWEEN 1 AND 5, SPECIFYING HOW THE LIMITS +C OF THE MAP ARE TO BE CHOSEN. PLA1-4 AND PLB1-4 ARE THE VALUES GIVEN +C BY THE USER FOR PLM1(1), PLM2(1), ..., PLM1(2), PLM2(2), ..., IN THE +C LAST CALL TO MAPSET. PLTR IS THE PLOTTER RESOLUTION - EFFECTIVELY, +C THE NUMBER OF ADDRESSABLE POINTS IN THE X DIRECTION. GRID IS THE +C DESIRED SPACING BETWEEN GRID LINES, IN DEGREES OF LATITUDE/LONGITUDE. +C IDSH IS THE DESIRED DASH PATTERN (16-BIT BINARY) FOR GRID LINES. IDOT +C IS A FLAG SELECTING SOLID OUTLINES (0) OR DOTTED OUTLINES (1). LBLF +C IS A LOGICAL FLAG INDICATING WHETHER THE INTERNATIONAL DATE LINE, THE +C EQUATOR, THE GREENWICH MERIDIAN, AND THE POLES ARE TO BE LABELLED OR +C NOT. PRMF IS A LOGICAL FLAG INDICATING WHETHER OR NOT A PERIMETER +C IS TO BE DRAWN. ELPF IS A LOGICAL FLAG INDICATING WHETHER THE MAP +C PERIMETER IS TO BE RECTANGULAR (.FALSE.) OR ELLIPTICAL (.TRUE.). +C XLOW, XROW, YBOW, AND YTOW ARE FRACTIONS BETWEEN 0. AND 1. SPECIFYING +C THE POSITION OF AREA OF THE PLOTTER FRAME IN WHICH THE MAP IS TO BE +C PUT; THE MAP IS CENTERED IN THIS AREA AND MADE AS LARGE AS POSSIBLE. +C IDTL IS A FLAG SPECIFYING THAT MAPIT SHOULD DRAW SOLID OUTLINES (0) +C OR DOTTEN OUTLINES (1). GRDR AND SRCH ARE MEASURED IN DEGREES AND +C LIE IN THE RANGE FROM .001 TO 10. GRDR SPECIFIES THE RESOLUTION WITH +C WHICH THE GRID IS TO BE DRAWN AND SRCH THE ACCURACY WITH WHICH THE +C LATITUDE/LONGITUDE LIMITS OF THE MAP ARE TO BE FOUND. ILCW IS THE +C CHARACTER WIDTH FOR CHARACTERS IN THE LABEL, AS REQUIRED FOR USE IN A +C CALL TO PWRIT. +C + DATA INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4,PLB1,PLB2 / + 1 .TRUE., 7, 0., 0., 0., 1, 0., 0., 0., 0., 0., 0. / +C + DATA PLB3,PLB4, PLTR,GRID, IDSH,IDOT, LBLF , PRMF , ELPF ,IDTL / + 1 0., 0.,4096., 10.,21845, 0,.TRUE.,.TRUE.,.FALSE., 0 / +C + DATA XLOW,XROW,YBOW,YTOW / .05,.95,.05,.95 / +C + DATA GRDR,SRCH / 1.,1. / +C + DATA ILCW / 1 / +C +C +C VARIABLES IN MAPCM5: +C +C DDCT IS THE DICTIONARY OF AVAILABLE DATASETS, LDCT THE DICTIONARY OF +C MAP LIMIT DEFINITION TYPES, AND PDCT THE DICTIONARY OF MAP PROJECTION +C NAMES. +C + DATA DDCT / 'NO','CO','US','PS','PO' / +C + DATA LDCT / 'MA','CO','PO','AN','LI' / +C + DATA PDCT / 'LC','ST','OR','LE','GN','AE','CE','ME','MO','SV' / +C +C +C VARIABLES IN MAPCM7: +C +C ULOW, UROW, VBOW, AND VTOW DEFINE THE FRACTION OF THE PLOTTER FRAME +C TO BE OCCUPIED BY THE MAP - THEY MAY BE THOUGHT OF AS THE FIRST FOUR +C ARGUMENTS OF THE SET CALL OR, IN THE GKS SCHEME, AS THE VIEWPORT. +C THEY ARE COMPUTED BY MAPINT. ULOW AND UROW ARE GIVEN DEFAULT VALUES +C TO PREVENT CODE IN MAPSTI AND MAPSTR FROM BLOWING UP WHEN PLTR IS +C SET PRIOR TO THE FIRST CALL TO MAPINT. +C + DATA ULOW,UROW / 0.,1. / +C +C +C VARIABLES IN MAPCM8: +C +C P, Q, AND R ARE SET BY MAPTRN EACH TIME IT MAPS (RLAT,RLON) TO (U,V). +C Q IS ALWAYS EQUAL TO V, BUT P IS NOT ALWAYS EQUAL TO U. INSTEAD, IT +C IS A VALUE OF U FROM AN INTERMEDIATE STEP IN THE PROJECTION PROCESS. +C FOR THE LAMBERT CONFORMAL CONIC, P IS THE DISTANCE, IN LONGITUDE, FROM +C THE CENTRAL MERIDIAN. FOR THE CYLINDRICAL PROJECTIONS, P IS A VALUE +C OF U PRIOR TO MULTIPLICATION BY A FUNCTION OF V SHRINKING THE MAP +C TOWARD A VERTICAL BISECTOR. THEY ARE ALL USED BY MAPIT, WHILE DRAWING +C LINES FROM POINT TO POINT, TO DETECT "CROSS-OVER" (A JUMP FROM ONE +C SIDE OF THE MAP TO THE OTHER, CAUSED BY THE PROJECTION'S HAVING SLIT +C THE GLOBE ALONG SOME HALF OF A GREAT CIRCLE AND LAID IT OPEN WITH THE +C TWO SIDES OF THE SLIT AT OPPOSITE ENDS OF THE MAP). +C +C +C VARIABLES IN MAPCMA: +C +C DPLT IS THE MIMIMUM VECTOR LENGTH; MAPIT REQUIRES TWO POINTS TO BE AT +C LEAST DPLT PLOTTER UNITS APART BEFORE IT WILL JOIN THEM WITH A VECTOR. +C DDTS IS THE DESIRED DISTANCE IN PLOTTER UNITS BETWEEN DOTS IN A DOTTED +C OUTLINE. THESE VALUES ARE RELATIVE TO THE "PLOTTER RESOLUTION" PLTR; +C DPLT/PLTR IS A FRACTION OF THE PLOTTER FRAME. DSCA IS THE RATIO OF +C THE LENGTH OF A VECTOR, MEASURED IN PLOTTER UNITS, TO THE LENGTH OF +C THE SAME VECTOR, MEASURED IN THE U/V PLANE. THUS, GIVEN A VECTOR OF +C LENGTH D IN THE U/V PLANE, D*DSCA IS ITS LENGTH IN PLOTTER UNITS. +C DPSQ AND DSSQ ARE THE SQUARES OF DPLT AND DSCA, RESPECTIVELY. DBTD +C IS THE DISTANCE, IN THE U/V PLANE, BETWEEN TWO DOTS DDTS PLOTTER +C UNITS APART. DPLT AND DDTS HAVE THE VALUES GIVEN BELOW AND ARE NOT +C RESET BY THE CODE; DSCA, DPSQ, DSSQ, AND DBTD ARE COMPUTED BY MAPINT. +C DSCA IS GIVEN A DEFAULT VALUE ONLY TO KEEP THE ROUTINES MAPSTI AND +C MAPSTR FROM BLOWING UP WHEN DDTS IS SET PRIOR TO ANY CALL TO MAPINT. +C DATL IS USED BY MAPIT AND MAPVP TO KEEP TRACK OF WHERE THE NEXT POINT +C ALONG A CURVE SHOULD GO. +C + DATA DPLT,DDTS,DSCA / 4.,12.,1. / +C +C +C VARIABLES IN MAPCMB: +C +C IIER IS AN ERROR FLAG, SET WHENEVER AN ERROR OCCURS DURING A CALL TO +C ONE OF THE EZMAP ROUTINES. ITS VALUE MAY BE RETRIEVED BY A CALL TO +C MAPGTI. +C + DATA IIER / 0 / +C +C +C VARIABLES IN MAPCMP: +C +C NPTB IS THE NUMBER OF POINTS WHOSE COORDINATES HAVE BEEN COLLECTED IN +C THE ARRAYS XPTB AND YPTB FOR EVENTUAL OUTPUT BY A CALL TO POINTS. +C + DATA NPTB / 0 / +C +C VARIABLES IN MAPNTS: +C +C THE ARRAY INTS SPECIFIES INTENSITIES TO BE USED FOR THE PERIMETER, FOR +C THE GRID, FOR LABELLING, FOR LIMBS, FOR THE CONTINENTAL OUTLINES, FOR +C THE U.S. STATE OUTLINES, AND FOR INTERNATIONAL POLITICAL OUTLINES. +C SEE THE ROUTINE MAPCHI. EACH ELEMENT IS AN INTEGER IN THE RANGE 0 TO +C 255, INCLUSIVE. +C + DATA INTS / 240,150,210,240,240,180,210 / +C +C +C VARIABLES IN MAPSAT: +C +C THE ABSOLUTE VALUE OF SALT, IF GREATER THAN 1, SERVES AS A FLAG THAT +C A SATELLITE-VIEW PROJECTION IS TO BE USED IN PLACE OF AN ORTHOGRAPHIC +C PROJECTION; ITS VALUE IS THE DISTANCE OF THE SATELLITE FROM THE CENTER +C OF THE EARTH, IN UNITS OF EARTH RADII. IN THIS CASE, SSMO IS THE +C SQUARE OF SALT MINUS 1 AND SRSS IS THE SQUARE ROOT OF SSMO. IF ALFA +C IS ZERO, THE PROJECTION SHOWS THE VIEW SEEN BY A SATELLITE LOOKING +C STRAIGHT AT THE CENTER OF THE EARTH; CALL THIS THE BASIC SATELLITE +C VIEW. IF ALFA IS NON-ZERO, IT AND BETA ARE ANGLES, IN DEGREES, +C DETERMINING WHERE THE LINE OF SIGHT OF THE PROJECTION IS. IF E IS +C AT THE CENTER OF THE EARTH, S IS AT THE SATELLITE, AND P IS A POINT +C ALONG THE LINE OF SIGHT, THEN ALFA MEASURES THE ANGLE ESP. IF O IS +C THE POINT AT THE ORIGIN OF THE BASIC SATELLITE VIEW AND P IS THE +C PROJECTION OF THE LINE OF SIGHT, THEN BETA MEASURES THE ANGULAR +C DISTANCE FROM THE POSITIVE U AXIS TO THE LINE OP, POSITIVE IF +C MEASURED COUNTER-CLOCKWISE. SALF, CALF, SBET, AND CBET ARE SINES +C AND COSINES OF ALFA AND BETA. THE SIGN OF SALT INDICATES WHETHER A +C NORMAL PROJECTION (POSITIVE) OR AN EXTENDED PROJECTION (NEGATIVE) +C IS TO BE USED. THE LATTER MAKES IT EASIER TO OVERLAY CONREC OUTPUT +C ON ONE OF THESE PROJECTIONS, BY PROJECTING POINTS OUT OF SIGHT AROUND +C THE LIMB TO POINT JUST OUTSIDE THE LIMB ON THE PROJECTED VIEW. +C + DATA SALT,ALFA,BETA,SALF,CALF,SBET,CBET / 0.,0.,0.,0.,1.,0.,1. / +C +C REVISION HISTORY: +C +C FEBRUARY, 1982 ADDED MODIFICATIONS SO THAT POINTS GENERATED BY THE +C DRAWING OF DOTTED CONTINENTAL OUTLINES ARE BUFFERED +C AND THEN PUT OUT WITH A CALL TO POINTS, INSTEAD OF +C BEING PUT OUT ONE AT A TIME WITH A CALL TO POINT AS +C BEFORE. THE LATTER RESULTED IN HUGE OVERHEAD IN THE +C PLOT FILE. ROUTINES MAPLOT AND MAPVP WERE MODIFIED, +C AND A NEW COMMON BLOCK MAPCMP WAS ADDED. +C +C AUGUST, 1984 CONVERTED TO FORTRAN-77 AND GKS. DELETED THE EZMAP +C ENTRY POINT. +C +C MARCH, 1985 COMPLETELY OVERHAULED THE CODE TO SIMPLIFY IT AND TO +C REMOVE KNOWN ERRORS. UPDATED THE OUTLINE DATASET +C TO REMOVE ERRORS AND TO INCLUDE INTERNATIONAL +C BOUNDARIES. IMPLEMENTED MANY CONTROLS AIMED AT +C OBVIATING THE NEED FOR SOURCE MODIFICATION BY USERS. +C +C MAY, 1985 ADDED CODE TO PREVENT PROBLEMS WHEN A SMOOTHING +C VERSION OF THE DASH PACKAGE IS LOADED. ADDED CODE +C IN MAPIT TO GET AROUND A CFT COMPILER PROBLEM. +C ADDED CODE TO DO EXTENDED ORTHOGRAPHIC AND SATELLITE- +C VIEW PROJECTIONS. +C +C JULY, 1985 FIXED A MISSING DECLARATION IN THE SUBROUTINE MAPSET +C AND LIMITED "CALL PLOTIT (0,0,0)" TO THE GKS VERSION. +C +C AUGUST, 1985 FIXED A PROBLEM IN MAPGRD WHICH CAUSED MERIDIANS ON +C MERCATOR MAPS WITH VERTICAL LIMITS TOO CLOSE TO THE +C POLES TO BE DRAWN IMPROPERLY. (THE TEST FOR CROSS- +C OVER, IN MAPIT, WAS BEING PASSED BECAUSE THE POINTS +C USED TO DRAW THE MERIDIANS WERE TOO FAR APART.) ALSO +C FIXED AN ERROR IN THE GKS CODE IN MAPCHI AND BEEFED +C UP THE IMPLEMENTORS' INSTRUCTIONS TO SAY WHAT TO DO +C WITH THAT ROUTINE WHEN COLOR IS AVAILABLE. +C +C NOVEMBER, 1985 ADDED CODE TO PREVENT GKS CLIPPING FROM DESTROYING +C PART OF THE PERIMETER. +C + END diff --git a/sys/gio/ncarutil/gridal.f b/sys/gio/ncarutil/gridal.f new file mode 100644 index 00000000..8ad31020 --- /dev/null +++ b/sys/gio/ncarutil/gridal.f @@ -0,0 +1,1583 @@ + SUBROUTINE GRIDAL(MAJRX,MINRX,MAJRY,MINRY,IXLAB,IYLAB,IGPH,X,Y) +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C LATEST REVISION JULY, 1985 +C +C PURPOSE THIS IS A PACKAGE OF ROUTINES FOR DRAWING +C GRAPH PAPER, AXES, AND OTHER BACKGROUNDS. +C +C USAGE EACH USER ENTRY POINT IN THIS PACKAGE (GRID, +C GRIDL, PERIM, PERIML, HALFAX, LABMOD, +C TICK4, AND GRIDAL) WILL BE DESCRIBED +C SEPARATELY BELOW. FIRST, HOWEVER, WE +C WILL DISCUSS HOW MAJOR AND MINOR DIVISIONS +C IN THE GRAPH PAPER ARE HANDLED BY ALL +C ENTRIES WHICH USE THEM. +C +C GRIDAL, GRID, GRIDL, PERIM, PERIML, AND +C HALFAX HAVE ARGUMENTS MAJRX,MINRX,MAJRY, +C MINRY WHICH CONTROL THE NUMBER OF MAJOR AND +C MINOR DIVISIONS IN THE GRAPH PAPER OR +C PERIMETERS. THE NUMBER OF DIVISIONS REFERS +C TO THE HOLES BETWEEN LINES RATHER THAN THE +C LINES THEMSELVES. THIS MEANS THAT THERE +C IS ALWAYS ONE MORE MAJOR DIVISION LINE THAN +C THE NUMBER OF MAJOR DIVISIONS. SIMILARLY, +C THERE IS ONE LESS MINOR DIVISION LINE THAN +C MINOR DIVISIONS (PER MAJOR DIVISION.) +C +C MAJRX,MAJRY,MINRX,MINRY HAVE DIFFERENT +C MEANINGS DEPENDING UPON WHETHER LOG +C SCALING IS IN EFFECT (SET VIA SETUSV OR +C SET IN THE SPPS PACKAGE.) +C +C FOR LINEAR SCALING, +C MAJRX AND MAJRY SPECIFY THE NUMBER OF MAJOR +C DIVISIONS ALONG THE X-AXIS OR Y-AXIS +C RESPECTIVELY, AND MINRX AND MINRY SPECIFY +C THE NUMBER OF MINOR DIVISIONS PER MAJOR +C DIVISION. +C +C FOR LOG SCALING ALONG THE X-AXIS +C EACH MAJOR DIVISION OCCURS AT A FACTOR OF +C 10**MAJRX TIMES THE PREVIOUS DIVISION. +C FOR EXAMPLE, IF THE MINIMUM X-AXIS VALUE IS +C 3., AND THE MAXIMUM X-AXIS VALUE IS 3000., +C AND MAJRX IS 1, THEN MAJOR DIVISIONS WILL +C OCCUR AT 3., 30., 300., AND 3000. SIMILARLY +C FOR MAJRY. IF LOG SCALING IS IN EFFECT ON +C THE X-AXIS AND MINRX.LE.10, THEN THERE ARE +C NINE MINOR DIVISIONS BETWEEN EACH MAJOR +C DIVISION. FOR EXAMPLE, BETWEEN 3. AND 30. +C THERE WOULD BE A MINOR DIVISION AT 6., 9., +C 12.,...,27. IF LOG SCALING IS IN EFFECT ON +C THE X-AXIS AND MINRX.GT.10, THEN THERE WILL +C BE NO MINOR SUBDIVISIONS. MINRY IS TREATED +C IN THE SAME MANNER AS MINRX. +C +C IF DIFFERENT COLORS (OR INTENSITIES) ARE TO +C BE USED FOR NORMAL INTENSITY, LOW INTENSITY, +C OR TEXT COLOR, THEN THE VALUES IN COMMON +C BLOCK GRIINT SHOULD BE CHANGED AS FOLLOWS: +C +C IGRIMJ COLOR INDEX FOR NORMAL (MAJOR) +C INTENSITY LINES. +C IGRIMN COLOR INDEX FOR LOW INTENSITY +C LINES. +C IGRITX COLOR INDEX FOR TEXT (LABELS.) +C +C WE NOW DESCRIBE EACH ENTRY IN THIS PACKAGE. +C +C----------------------------------------------------------------------- +C SUBROUTINE GRID +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW GRAPH PAPER. +C +C USAGE CALL GRID (MAJRX,MINRX,MAJRY,MINRY) +C +C DESCRIPTION THIS SUBROUTINE DRAWS GRAPH LINES IN THE PORTION +C OF THE PLOTTER SPECIFIED BY THE CURRENT VIEWPORT +C SETTING WITH THE NUMBER OF MAJOR AND MINOR +C DIVISIONS AS SPECIFIED BY THE ARGUMENTS. +C +C----------------------------------------------------------------------- +C SUBROUTINE GRIDAL +C----------------------------------------------------------------------- +C +C PURPOSE A GENERAL ENTRY POINT FOR ALL BACKGROUND ROUTINES +C WITH THE OPTION OF LINE LABELLING ON EACH AXIS. +C +C USAGE CALL GRIDAL (MAJRX,MINRX,MAJRY,MINRY,IXLAB,IYLAB, +C IGPH,X,Y) +C +C ARGUMENTS MAJRX,MINRX,MAJRY,MINRY +C MAJOR AND MINOR AXIS DIVISIONS AS DESCRIBED IN THE +C USAGE SECTION OF THE PACKAGE DOCUMENTATION ABOVE. +C +C IXLAB,IYLAB (INTEGERS) +C FLAGS FOR AXIS LABELS: +C +C IXLAB = -1 NO X-AXIS DRAWN +C NO X-AXIS LABELS +C +C = 0 X-AXIS DRAWN +C NO X-AXIS LABELS +C +C = 1 X-AXIS DRAWN +C X-AXIS LABELS +C +C IYLAB = -1 NO Y-AXIS DRAWN +C NO Y-AXIS LABELS +C +C = 0 Y-AXIS DRAWN +C NO Y-AXIS LABELS +C +C = 1 Y-AXIS DRAWN +C Y-AXIS LABELS +C +C +C IGPH +C FLAG FOR BACKGROUND TYPE: +C +C IGPH X-AXIS BACKGROUND Y-AXIS BACKGROUND +C ---- ----------------- ----------------- +C 0 GRID GRID +C 1 GRID PERIM +C 2 GRID HALFAX +C 4 PERIM GRID +C 5 PERIM PERIM +C 6 PERIM HALFAX +C 8 HALFAX GRID +C 9 HALFAX PERIM +C 10 HALFAX HALFAX +C +C X,Y +C WORLD COORDINATES OF THE INTERSECTION OF THE AXES +C IF IGPH=10 . +C +C----------------------------------------------------------------------- +C SUBROUTINE GRIDL +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW GRAPH PAPER. +C +C USAGE CALL GRIDL (MAJRX,MINRX,MAJRY,MINRY) +C +C DESCRIPTION THIS SUBROUTINE BEHAVES EXACTLY AS GRID, BUT EACH +C MAJOR DIVISION IS LABELED WITH ITS NUMERICAL VALUE. +C +C----------------------------------------------------------------------- +C SUBROUTINE HALFAX +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW ORTHOGONAL AXES. +C +C USAGE CALL HALFAX (MAJRX,MINRX,MAJRY,MINRY,X,Y,IXLAB,IYLAB) +C +C DESCRIPTION THIS SUBROUTINE DRAWS ORTHOGONAL AXES INTERSECTING +C AT COORDINATE (X,Y) WITH OPTIONAL LABELING OPTIONS AS +C SPECIFIED BY IXLAB AND IYLAB. +C +C ARGUMENTS MAJRX,MINRX,MAJRY,MINRY +C MAJOR AND MINOR DIVISION SPECIFICATIONS AS PER THE +C DESCRIPTION IN THE PACKAGE USAGE SECTION ABOVE. +C +C X,Y +C WORLD COORDINATES SPECIFYING THE INTERSECTION POINT +C OF THE X AND Y AXES. +C +C IXLAB,IYLAB (INTEGERS) +C FLAGS FOR AXIS LABELS: +C +C IXLAB = -1 NO X-AXIS DRAWN +C NO X-AXIS LABELS +C +C = 0 X-AXIS DRAWN +C NO X-AXIS LABELS +C +C = 1 X-AXIS DRAWN +C X-AXIS LABELS +C +C IYLAB = -1 NO Y-AXIS DRAWN +C NO Y-AXIS LABELS +C +C = 0 Y-AXIS DRAWN +C NO Y-AXIS LABELS +C +C = 1 Y-AXIS DRAWN +C Y-AXIS LABELS +C +C----------------------------------------------------------------------- +C SUBROUTINE LABMOD +C----------------------------------------------------------------------- +C +C PURPOSE TO ALLOW MORE COMPLETE CONTROL OVER THE APPEARANCE +C OF THE LABELS ON THE BACKGROUND PLOTS. +C +C USAGE CALL LABMOD (FMTX,FMTY,NUMX,NUMY,ISIZX,ISIZY, +C IXDEC,IYDEC,IXOR) +C +C DESCRIPTION THIS SUBROUTINE PRESETS PARAMETERS FOR THE OTHER +C BACKGROUND ROUTINES IN THIS PACKAGE. LABMOD ITSELF +C DOES NO PLOTTING AND IT MUST BE CALLED BEFORE THE +C THE BACKGROUND ROUTINES FOR WHICH IT IS PRESETTING +C PARAMETERS. +C +C ARGUMENTS FMTX,FMTY (TYPE CHARACTER) +C FORMAT SPECIFICATIONS FOR THE X-AXIS AND Y-AXIS +C NUMERICAL LABELS IN GRIDL, PERIML, GRIDAL, OR +C HALFAX. THE SPECIFICATION MUST START WITH A LEFT +C PARENTHESIS AND END WITH A RIGHT PARENTHESIS AND +C SHOULD NOT USE MORE THAN 8 CHARACTERS. ONLY +C FLOATING-POINT CONVERSIONS (F, E, AND G) SUCH AS +C FMTX='(F8.2)' AND FMTY='(E10.0)' FOR EXAMPLE. +C +C NUMX,NUMY (INTEGER) +C THE NUMBER OF CHARACTERS SPECIFIED BY FMTX AND +C FMTY. FOR THE ABOVE EXAMPLES, THESE WOULD BE +C NUMX=8 AND NUMY=10 (NOT 6 AND 7). +C +C ISIZX,ISIZY +C CHARACTER SIZE CODES FOR THE LABELS. THESE SIZE +C CODES ARE THE SAME AS THOSE FOR THE SPPS ENTRY +C PWRIT. +C +C IXDEC +C THE DECREMENT IN PLOTTER ADDRESS UNITS FROM THE +C LEFTMOST PLOTTER COORDINATE (AS SPECIFIED BY THE +C CURRENT VIEWPORT) TO THE NEAREST X-ADDRESS OF THE +C LABEL SPECIFIED BY FMTY, NUMY, AND ISIZY. FOR +C EXAMPLE, IF THE MINIMUM X-COORDINATE OF THE CURRENT +C VIEWPORT IS .1, MINX IS 102 (.1*1024). IF IXDEC +C IS 60, THE LABEL WILL START AT 42 (102-60). THE +C FOLLOWING CONVENTIONS ARE USED: +C +C O IF IXDEC=0, IT IS AUTOMATICALLY RESET TO PROPERLY +C POSITION THE Y-AXIS LABELS TO THE LEFT OF THE +C LEFT Y-AXIS, IXDEC=20 . +C +C O IF IXDEC=1, Y-AXIS LABELS WILL GO TO THE RIGHT +C OF THE GRAPH, IXDEC=-20 . +C +C WHEN EITHER HALFAX OR GRIDAL IS CALLED TO DRAW AN +C AXIS, IXDEC IS THE DISTANCE FROM THE AXIS RATHER +C THAN FROM THE MINIMUM VIEWPORT COORDINATE. +C +C IYDEC +C THE DECREMENT IN PLOTTER ADDRESS UNITS FROM THE +C MINIMUM Y-AXIS COORDINATE AS SPECIFIED BY THE +C CURRENT VIEWPORT TO THE NEAREST Y-ADDRESS OF THE +C LABEL SPECIFIED BY FMTX, NUMX, AND ISIZX. FOR +C EXAMPLE, IF THE MINIMUM Y-COORDINATE OF THE +C CURRENT VIEWPORT IS .2, MINY IS 205 (.2*1024). +C IF IYDEC=30, THE LABEL WILL END AT 205-30=175. +C THE FOLLOWING CONVENTIONS ARE USED: +C +C O IF IYDEC=0, IT IS AUTOMATICALLY RESET TO +C PROPERLY POSITION X-AXIS LABELS ALONG THE +C BOTTOM, IYDEC=20 . +C +C O IF IYDEC=1, X-AXIS LABELS WILL GO ALONG THE +C TOP OF THE GRAPH, IYDEC=-20 . +C +C IXOR (INTEGER) +C ORIENTATION OF THE X-AXIS LABELS. +C +C IXOR = 0 +X (HORIZONTAL) +C = 1 +Y (VERTICAL) +C +C IN NORMAL ORIENTATION, THE ACTUAL NUMBER OF +C NON-BLANK DIGITS IS CENTERED UNDER THE LINE +C OR TICK TO WHICH IT APPLIES. +C +C----------------------------------------------------------------------- +C SUBROUTINE PERIM +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW A PERIMETER WITH TICK MARKS. +C +C USAGE CALL PERIM (MAJRX,MINRX,MAJRY,MINRY) +C +C DESCRIPTION THIS SUBROUTINE BEHAVES JUST AS GRID EXCEPT THAT +C INTERIOR LINES ARE REPLACED WITH TICK MARKS ALONG +C THE EDGES. TICK MARKS AT MAJOR DIVISIONS ARE +C SLIGHTLY LARGER THAN TICK MARKS AT MINOR DIVISIONS. +C +C----------------------------------------------------------------------- +C SUBROUTINE PERIML +C----------------------------------------------------------------------- +C +C PURPOSE TO DRAW A PERIMETER WITH TICK MARKS AND LABELS. +C +C USAGE CALL PERIML (MAJRX,MINRX,MAJRY,MINRY) +C +C DESCRIPTION THIS SUBROUTINE BEHAVES JUST AS PERIM, BUT EACH +C MAJOR DIVISION IS LABELED WITH ITS NUMERICAL VALUE. +C +C----------------------------------------------------------------------- +C SUBROUTINE TICK4 +C----------------------------------------------------------------------- +C +C PURPOSE TO ALLOW PROGRAM CONTROL OF TICK MARK LENGTH. +C +C USAGE CALL TICK4 (LMAJX,LMINX,LMAJY,LMINY) +C +C DESCRIPTION THIS SUBROUTINE ALLOWS PROGRAM CONTROL OF TICK +C MARK LENGTH IN PERIM, PERIML, GRIDAL, AND HALFAX. +C +C ARGUMENTS LMAJX,LMAJY +C LENGTH IN PLOTTER ADDRESS UNITS OF MAJOR DIVISION +C TICK MARKS ON THE X-AXIS AND Y-AXIS RESPECTIVELY. +C THESE VALUES ARE INITIALLY SET TO 12 . +C +C MINRX,MINRY +C LENGTH IN PLOTTER ADDRESS UNITS OF MINOR DIVISION +C TICK MARKS ON THE X-AXIS AND Y-AXIS RESPECTIVELY. +C THESE VALUES ARE INITIALLY SET TO 8 . +C +C----------------------------------------------------------------------- +C +C WE NOW RESUME THE PACKAGE DOCUMENTATION. +C +C ENTRY POINTS GRID,GRIDAL,GRIDL,HALFAX,LABMOD,PERIM,PERIML,TICK4, +C TICKS,CHSTR,EXPAND,GRIDT +C +C COMMON BLOCKS LAB,CLAB,TICK,GRIINT +C +C REQUIRED THE ERPRT77 PACKAGE AND THE SPPS. +C ROUTINES +C +C I/O PLOTS BACKGROUNDS +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN 77 +C +C HISTORY WRITTEN IN JUNE, 1984. BASED ON THE NCAR SYSTEM +C PLOT PACKAGE ENTRIES HAVING THE SAME NAMES. +C + COMMON /LAB/ SIZX,SIZY,XDEC,YDEC,IXORI + COMMON /CLAB/ XFMT, YFMT + COMMON /TICK/ MAJX, MINX, MAJY, MINY + COMMON /GRIINT/ IGRIMJ, IGRIMN, IGRITX +C +C INTERNAL VARIABLES: +C +C CHUPX,CHUPY CHARACTER UP VECTOR VALUES ON ENTRY +C +C CURMAJ IF LOGMIN=.TRUE., THEN THIS IS THE +C CURRENT MAJOR TICK/GRID POSITION +C +C ICNT NORMALIZATION TRANSFORMATION NUMBER IN +C EFFECT ON ENTRY TO GRIDAL +C +C LASF(13) ASPECT SOURCE FLAG TABLE AS USED BY GKS. +C +C LGRID .TRUE. IF GRIDS ARE TO BE DRAWN ON THE +C CURRENT AXIS (OPPOSED TO TICKS) +C +C LOGMIN .TRUE. IF LOG SCALING IS IN EFFECT AND +C MINOR TICK MARKS OR GRIDS ARE DESIRED +C +C LOGVAL LINEAR OR LOG SCALING +C 1 = X LINEAR, Y LINEAR +C 2 = X LINEAR, Y LOG +C 3 = X LOG, Y LINEAR +C 4 = X LOG, Y LOG +C +C MINCNT NUMBER OF MINOR DIVISIONS PER MAJOR +C +C NERR COUNTS ERROR NUMBER +C +C NEXTMAJ IF LOGMIN=.TRUE., THEN THIS IS THE NEXT +C MAJOR TICK/GRID POSITION +C +C NWIND(4) WINDOW LIMITS IN WORLD COORDINATES +C AFTER EXPANSION +C +C OCOLI COLOR INDEX ON ENTRY TO GRIDAL +C +C OLDALH,OLDALV TEXT ALIGNMENT VALUES ON ENTRY +C (HORIZONTAL AND VERTICAL) +C +C OLDCH CHARACTER HEIGHT ON ENTRY TO GRIDAL +C +C OPLASF STORES VALUE OF POLYLINE COLOR ASF ON +C ENTRY TO GRIDAL +C +C OTXASF STORES VALUE OF TEXT COLOR ASF ON +C ENTRY TO GRIDAL +C +C OTXCOL TEXT COLOR INDEX ON ENTRY TO GRIDAL +C +C OWIND(4) WINDOW LIMITS IN WORLD COORDINATES +C ON ENTRY TO GRIDAL +C +C PY(2) 2 Y-COORDINATES FOR LINE TO BE DRAWN +C VIA GKS ROUTINE GPL +C +C PX(2) 2 X-COORDINATES FOR LINE TO BE DRAWN +C VIA GKS ROUTINE GPL +C +C START IF DRAWING TICKS/GRIDS ON X-AXIS: +C Y-COORD OF ORIGIN OF EACH LINE; +C IF DRAWING TICKS/GRIDS ON Y-AXIS: +C X-COORD OF ORIGIN OF EACH LINE +C +C TICBIG END OF MAJOR TICK LINE IN WORLD +C COORDINATES +C +C TICEND END OF MINOR TICK LINE IN WORLD +C COORDINATES +C +C TICMAJ LENGTH OF MAJOR TICKS IN WORLD +C COORDINATES +C +C TICMIN LENGTH OF MINOR TICKS IN WORLD +C COORDINATES +C +C VIEW(4) VIEWPORT LIMITS IN NDC PRIOR TO +C EXPANSION FOR LABELLING +C +C WIND(4) SAME AS IN OWIND(4) +C +C XCUR A TICK/GRID IS DRAWN AT THIS POSITION +C IF LOG SCALING IS IN EFFECT. +C +C XDEC LENGTH IN WORLD COORDINATES FROM +C X-AXIS TO LABEL +C +C XI ALOG10(X), IF LOG SCALING +C +C XINT INTERVAL BETWEEN MINOR X-AXIS +C TICKS/GRIDS IN WORLD COORDINATES +C +C XINTM INTERVAL BETWEEN MAJOR X-AXIS +C TICKS/GRIDS IN WORLD COORDINATES +C +C XMIRRO LOGICAL FLAGS FOR MIRROR-IMAGE +C +C XNUM TOTAL NUMBER OF X-AXIS TICKS/GRIDS +C WITH LINEAR SCALING +C +C XPOS IF LINEAR SCALING, KEEPS TRACK OF X-AXIS +C POSITION FOR CURRENT TICK/GRID +C +C XRANGE TOTAL RANGE IN X DIRECTION IN WORLD +C COORDINATES PRIOR TO EXPANSION FOR +C LABELLING. +C +C XRNEW RANGE IN X DIRECTION IN WORLD +C COORDINATES, AFTER EXPANSION +C +C YCUR A TICK/GRID IS DRAWN AT THIS POSITION +C IF LOG SCALING IS IN EFFECT. +C +C YDEC LENGTH IN WORLD COORDINATES FROM +C Y-AXIS TO LABEL +C +C YI ALOG10(Y), IF LOG SCALING +C +C YINTM INTERVAL BETWEEN MAJOR Y-AXIS +C TICKS/GRIDS IN WORLD COORDINATES +C +C YMIRRO PLOTTING. +C +C YNUM TOTAL NUMBER OF Y-AXIS TICKS/GRIDS +C WITH LINEAR SCALING +C +C YPOS IF LINEAR SCALING, KEEPS TRACK OF Y-AXIS +C POSITION FOR CURRENT TICK/GRID +C +C YRANGE TOTAL RANGE IN Y DIRECTION IN WORLD +C COORDINATES PRIOR TO EXPANSION FOR +C LABELLING. +C +C YRNEW RANGE IN Y DIRECTION IN WORLD +C COORDINATES, AFTER EXPANSION +C +C XLAB,YLAB IF LABELLING X-AXIS, Y-COORDINATE FOR +C FOR TEXT POSITION; +C IF LABELLING Y-AXIS, X-COORDINATE FOR +C TEXT POSITION. +C +C +C + CHARACTER*8 XFMT,YFMT + REAL WIND(4), VIEW(4), PX(2), PY(2), NWIND(4), OWIND(4) + REAL MAJX, MINX, MAJY, MINY + INTEGER TCOUNT, XTNUM, YTNUM, FIRST, LAST + INTEGER OPLASF, OTXASF, LASF(13), OCOLI, OTEXCI, OLDALH ,OLDALV + LOGICAL LGRID,LOGMIN + LOGICAL XMIRRO,YMIRRO + REAL MAJDIV, NEXTMA + CHARACTER*15 LABEL +C + DATA TICMIN,TICMAJ,XCUR,YCUR,EXCUR,EYCUR/0.,0.,0.,0.,0.,0./ +C +C +NOAO - Blockdata rewritten as run time initialization. +C EXTERNAL GRIDT + call gridt +C -NOAO +C THE FOLLOWING IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR. +C + CALL Q8QST4('GRAPHX','GRIDAL','GRIDAL','VERSION 01') + XRNEW = 0. + YRNEW = 0. +C +C INITIALIZE ERROR COUNT. +C + NERR = 0 +C +C CHECK FOR BAD VALUES OF IGPH. +C + IF (IGPH.LT.0.OR.IGPH.EQ.3.OR.IGPH.EQ.7.OR.IGPH.GT.10) THEN + NERR = NERR + 1 + CALL SETER(' GRIDAL--INVALID IGPH VALUE',NERR,2) + ENDIF +C +C GET STANDARD ERROR MESSAGE UNIT +C + IERUNT = I1MACH(4) + XMIRRO = .FALSE. + YMIRRO = .FALSE. +C +C SET POLYLINE COLOR ASF TO INDIVIDAUL. +C + CALL GQASF(IERR,LASF) + OPLASF = LASF(3) + LASF(3) = 1 + OTXASF = LASF(10) + LASF(10) = 1 + CALL GSASF(LASF) +C +C INQUIRE CURRENT POLYLINE COLOR INDEX. +C + CALL GQPLCI(IERR,OCOLI) +C +C SET POLYLINE COLOR TO THE VALUE SPECIFIED IN COMMON. +C + CALL GSPLCI(IGRIMJ) +C +C INQUIRE CURRENT NORMALIZATION TRANSFORMATION NUMBER. +C + CALL GQCNTN(IERR,ICNT) +C +C INQUIRE CURRENT WINDOW AND VIEWPORT LIMITS. +C + CALL GQNT(ICNT,IERR,WIND,VIEW) +C +C STORE WINDOW VALUES +C + DO 10 I = 1,4 + OWIND(I) = WIND(I) + 10 CONTINUE +C +C LOG OR LINEAR SCALING? +C +C 1 = X LINEAR, Y LINEAR +C 2 = X LINEAR, Y LOG +C 3 = X LOG, Y LINEAR +C 4 = X LOG, Y LOG +C + CALL GETUSV('LS',LOGVAL) +C +C ADJUST WINDOW TO ACCOUNT FOR LOG SCALING. +C + IF (LOGVAL .EQ. 2) THEN + WIND(3) = 10.**WIND(3) + WIND(4) = 10.**WIND(4) + ELSE IF (LOGVAL .EQ. 3) THEN + WIND(1) = 10.**WIND(1) + WIND(2) = 10.**WIND(2) + ELSE IF (LOGVAL .EQ. 4) THEN + WIND(1) = 10.**WIND(1) + WIND(2) = 10.**WIND(2) + WIND(3) = 10.**WIND(3) + WIND(4) = 10.**WIND(4) + ENDIF +C +C DETERMINE IF MIRROR-IMAGE MAPPING IS REQUIRED. +C + IF (WIND(1) .GT. WIND(2)) THEN + XMIRRO = .TRUE. + ENDIF + IF (WIND(3) .GT. WIND(4)) THEN + YMIRRO = .TRUE. + ENDIF +C +C IF IGPH=10, CHECK FOR X(Y) VALUES IN RANGE (IF NOT, CHANGE TO +C DEFAULT. +C + IF (IGPH .EQ. 10) THEN + XI = X + YI = Y + IF (((XI .LT. WIND(1) .OR. XI .GT. WIND(2)) .AND. .NOT. + 1 XMIRRO) .OR. (XMIRRO.AND.(XI.GT.WIND(1).OR.XI.LT.WIND(2)))) + 2 THEN + NERR = NERR + 1 + CALL SETER(' GRIDAL--X VALUE OUT OF WINDOW RANGE',NERR,1) +C +NOAO - FTN writes and format statements deleted. Call to SETER okay. +C +C WRITE(IERUNT,1001)NERR +C1001 FORMAT(' ERROR',I3,' IN GRIDAL--X VALUE OUT OF WINDOW RANGE') + CALL ERROF + XI = WIND(1) + ENDIF + IF (((YI .LT. WIND(3) .OR. YI .GT. WIND(4)) .AND. .NOT. + 1 YMIRRO).OR.(YMIRRO.AND.(YI.GT.WIND(3).OR.YI.LT.WIND(4)))) + 2 THEN + NERR = NERR + 1 + CALL SETER(' GRIDAL--Y VALUE OUT OF WINDOW RANGE',NERR,1) +C WRITE(IERUNT,1002)NERR +C1002 FORMAT(' ERROR',I3,' IN GRIDAL--Y VALUE OUT OF WINDOW RANGE') +C -NOAO + CALL ERROF + YI = WIND(3) + ENDIF + ENDIF + MX = MAJRX + MY = MAJRY + IF (LOGVAL .EQ. 4 .OR. LOGVAL .EQ. 3) THEN + IF (MX .LT. 1) MX = 1 + IF (WIND(1) .LE. 0.) THEN + NERR = NERR + 1 + CALL SETER(' GRIDAL--NON-POSITIVE WINDOW BOUNDARY WITH LOG SCA + 1LING',NERR,2) + ELSE + WIND(1) = ALOG10(WIND(1)) + ENDIF + IF (WIND(2) .LE. 0.) THEN + NERR = NERR + 1 + CALL SETER(' GRIDAL--NON-POSITIVE WINDOW BOUNDARY WITH LOG SCA + 1LING',NERR,2) + ELSE + WIND(2) = ALOG10(WIND(2)) + ENDIF + IF (IGPH .EQ. 10) THEN + XI = ALOG10(XI) + ENDIF + ENDIF +C + IF(LOGVAL .EQ. 4 .OR. LOGVAL .EQ. 2) THEN + IF (MY .LT. 1) MY = 1 + IF (WIND(3) .LE. 0.) THEN + NERR = NERR + 1 + CALL SETER(' GRIDAL--NON-POSITIVE WINDOW BOUNDARY WITH LOG SCA + 1LING',NERR,2) + ELSE + WIND(3) = ALOG10(WIND(3)) + ENDIF + IF (WIND(4) .LE. 0.) THEN + NERR = NERR + 1 + CALL SETER(' GRIDAL--NON-POSITIVE WINDOW BOUNDARY WITH LOG SCA + 1LING',NERR,2) + ELSE + WIND(4) = ALOG10(WIND(4)) + ENDIF + IF (IGPH .EQ. 10) THEN + YI = ALOG10(YI) + ENDIF + ENDIF +C +C DEFINE NORMALIZATION TRANSFORMATION NUMBER 1. +C + CALL GSWN(1,WIND(1),WIND(2),WIND(3),WIND(4)) + CALL GSVP(1,VIEW(1),VIEW(2),VIEW(3),VIEW(4)) + CALL GSELNT(1) +C +C CALCULATE X AND Y WORLD COORDINATE RANGES. +C + XRANGE = WIND(2) - WIND(1) + YRANGE = WIND(4) - WIND(3) +C +C IF LABELS ARE REQUESTED, INQUIRE AND SAVE TEXT ATTRIBUTES. +C + IF (IXLAB .EQ. 1 .OR. IYLAB .EQ. 1) THEN + CALL GQCHH(IERR,OLDCHH) + CALL GQCHUP(IERR,CHUPX,CHUPY) + CALL GQTXAL(IERR,OLDALH,OLDALV) + CALL GQTXCI (IERR,OTEXCI) + CALL GSTXCI (IGRITX) +C +C EXPAND WINDOW AND VIEWPORT FOR LABELS AND CALCULATE NEW +C X AND Y WORLD COORDINATE RANGES. +C + CALL EXPAND(NWIND) + XRNEW = NWIND(2) - NWIND(1) + YRNEW = NWIND(4) - NWIND(3) +C +C SET CHARACTER HEIGHT (1% OF Y RANGE.) +C + CHARH = SIZX * YRNEW + IF (YMIRRO) THEN + CHARH = -CHARH + ENDIF + CALL GSCHH(CHARH) + ENDIF +C + IF (IGPH .EQ. 0) GOTO 50 +C +C CALCULATE TIC LENGTH. +C +C IF NO LABELS AND TICK4 (OR TICKS) WERE NOT CALLED. +C + IF (MAJX .EQ. 0.) THEN + MAJX = .013 + MINX = .007 + TICMIN = MINX * YRANGE + TICMAJ = MAJX * YRANGE + ELSE +C +C EXPAND WINDOW IF NOT ALREADY EXPANDED. +C (IF LABMOD WAS NOT CALLED BUT TICK4(S) WAS.) +C + IF (IXLAB.NE.1 .AND. IYLAB.NE.1) THEN + CALL EXPAND (NWIND) + XRNEW = NWIND(2) - NWIND(1) + YRNEW = NWIND(4) - NWIND(3) + ENDIF + TICMIN = MINX * YRNEW + TICMAJ = MAJX * YRNEW + ENDIF +C +C **** X-AXIS TICS/GRIDS AND LABELS **** +C +C CALCULATE TIC/GRID INTERVALS ON X AXIS. +C + 50 IF (IXLAB .EQ. -1) GOTO 175 + MINCNT = MINRX + IF (LOGVAL .EQ. 1 .OR. LOGVAL .EQ. 2) THEN + LOGMIN = .FALSE. + XINTM = XRANGE/MX + XINT = XINTM + IF (MINCNT .GT. 1) THEN + XINT = XINT/MINCNT + ENDIF +C +C CALCULATE TOTAL NUMBER OF TICS/GRIDS ON AXIS. +C + XTNUM = MX * MINCNT + IF (MINCNT .EQ. 0) XTNUM = MX + ELSE + XTNUM = 50 + XCUR = 10.**OWIND(1) + MAJDIV = 10 ** MX + IF (MINCNT .LE. 10 .AND. MX .LE. 1) THEN + LOGMIN = .TRUE. + CURMAJ = XCUR + NEXTMA = XCUR * MAJDIV + XINT = (NEXTMA - CURMAJ) / 9. + MINCNT = 9 + ELSE + LOGMIN = .FALSE. + MINCNT = 1 + ENDIF + ENDIF +C + LGRID = .FALSE. + LOOP = 1 +C +C DETERMINE ORIGIN OF TICK/GRID LINES (Y COORDINATE.) +C + IF (IGPH .NE. 10) THEN + START = WIND(3) + ELSE + START = YI + ENDIF +C + XPOS = WIND(1) + PY(1) = START + TICEND = START + TICMIN + TICBIG = START + TICMAJ +C + PX(1) = XPOS + PX(2) = PX(1) +C +C DRAW LEFT-MOST TICK ON X-AXIS (IF IGPH = 10 AND +C INTERSECTION OF AXES IS NOT AT BOTTOM LEFT OF WINDOW.) +C + IF (IGPH .EQ. 10) THEN + IF (XI .NE. WIND(1)) THEN + PY(2) = TICBIG + CALL GPL(2,PX,PY) + ENDIF +C +C DRAW X-AXIS FOR IGPH = 10 +C + PX(2) = WIND(2) + PY(2) = PY(1) + CALL GPL(2,PX,PY) + PX(2) = PX(1) + ELSE +C +C DRAW Y-AXIS FOR ANY OTHER IGPH (FIRST TICK.) +C + PY(2) = WIND(4) + CALL GPL(2,PX,PY) + ENDIF +C +C TICKS OR GRIDS ? +C + IF (IGPH .EQ. 0 .OR. IGPH .EQ. 1 .OR. IGPH .EQ.2) THEN + PY(2) = WIND(4) + LGRID = .TRUE. + ELSE + PY(2) = TICEND + ENDIF +C + IF (IXLAB .EQ. 1) THEN +C +C IF VERTICAL X-AXIS LABEL ORIENTATION, THEN SET CHAR UP VECTOR +C TO BE VERTICAL AND TEXT ALIGNMENT TO (RIGHT,HALF), +C OTHERWISE TO (CENTER,TOP) +C + IF (YMIRRO) THEN + IF (IXORI .EQ. 1) THEN + CALL GSCHUP(1.,0.) + CALL GSTXAL(3,3) + ELSE + CALL GSCHUP(0.,-1.) + CALL GSTXAL(2,1) + ENDIF + ELSE + IF (IXORI .EQ. 1) THEN + CALL GSCHUP(-1.,0.) + CALL GSTXAL(3,3) + ELSE + CALL GSTXAL(2,1) + ENDIF + ENDIF + IF (XDEC.NE.0. .AND. XDEC.NE.1.) THEN + DEC = XDEC * YRNEW + ELSE + DEC = .02 * YRNEW + ENDIF + IF (XDEC .NE. 1.) THEN + XLAB = START - DEC + ELSE + IF (IGPH .NE. 10) THEN + XLAB = WIND(4)+DEC + ELSE + XLAB = YI+DEC + ENDIF +C +C IF LABELS ARE ON TOP OF THE X-AXIS, SET THE TEXT +C ALIGNMENT TO (LEFT,HALF) IF THE X-AXIS LABELS ARE +C VERTICAL, OTHERWISE TO (CENTER,BASE). +C + IF (IXORI .EQ. 1) THEN + CALL GSTXAL(1,3) + ELSE + CALL GSTXAL(2,4) + ENDIF + ENDIF + IF (LOGVAL .EQ. 1 .OR. LOGVAL .EQ. 2) THEN +C +NOAO +C WRITE(LABEL,XFMT)XPOS + call encode (10, xfmt, label, xpos) +C -NOAO + ELSE +C +NOAO +C WRITE(LABEL,XFMT)XCUR + call encode (10, yfmt, label, xcur) +C -NOAO + ENDIF + CALL CHSTR(LABEL,FIRST,LAST) + CALL GTX (XPOS,XLAB,LABEL(FIRST:LAST)) + ENDIF +C + 80 TCOUNT = 1 +C + DO 100 I = 1,XTNUM + IF (LOGVAL .EQ. 1 .OR. LOGVAL .EQ. 2) THEN + XPOS = XPOS + XINT + ELSE + IF (.NOT. LOGMIN) THEN + XCUR = XCUR * MAJDIV + ELSE + IF (TCOUNT .NE. MINCNT) THEN + XCUR = XCUR + XINT + ELSE + XCUR = XCUR + XINT + CURMAJ = NEXTMA + NEXTMA = CURMAJ * MAJDIV + XINT = (NEXTMA - CURMAJ) / 9. + ENDIF + ENDIF + IF (XCUR .GT. 10.**OWIND(2)-.1*XINT) THEN + XPOS = WIND(2) + ELSE + XPOS = ALOG10(XCUR) + ENDIF + ENDIF +C + PX(1) = XPOS + PX(2) = XPOS +C +C IF IGPH = 0,1,2,4,5,8 OR 9 AND XPOS=RIGHT AXIS, THEN +C DRAW AXIS, ELSE IF IGPH = 6 OR 10 DRAW TIC AND LABEL. +C + IF (LOGVAL .EQ. 3 .OR. LOGVAL .EQ. 4) EXCUR = 10.**OWIND(2) +C + IF ((((LOGVAL .EQ. 1.OR.LOGVAL.EQ.2) .AND. (I .EQ. XTNUM)) + 1 .OR.((LOGVAL .EQ.4 .OR.LOGVAL .EQ.3).AND.XCUR.GE.EXCUR-.1*XINT)) + 2 .AND.(IGPH.NE.6.AND.IGPH.NE.10)) THEN + IF (LOOP .EQ. 1) THEN + PY(2) = WIND(4) + CALL GPL(2,PX,PY) + IF (IXLAB .EQ. 1) THEN + IF (LOGVAL.EQ.1 .OR. LOGVAL.EQ.2) THEN +C (NOAO) WRITE(LABEL,XFMT) XPOS + call encode (10, xfmt, label, xpos) + ELSE + IF (XCUR .GT. EXCUR+.1*XINT) THEN + GOTO 101 + ELSE +C (NOAO) WRITE(LABEL,XFMT) XCUR + call encode (10, xfmt, label, xcur) + ENDIF + ENDIF + CALL CHSTR(LABEL,FIRST,LAST) + CALL GTX (XPOS,XLAB,LABEL(FIRST:LAST)) + ENDIF + ENDIF + GOTO 101 + ENDIF + IF ((LOGVAL.EQ.4 .OR. LOGVAL.EQ.3) .AND. XCUR.GT.EXCUR+.1*XINT) + 1 GOTO 101 +C +C MINOR TIC/GRID ? +C + IF (TCOUNT .NE. MINCNT .AND. MINCNT .NE. 0) THEN + IF (LGRID) THEN + CALL GSPLCI(IGRIMN) + ENDIF + CALL GPL(2,PX,PY) + IF (LGRID) THEN + CALL GSPLCI(IGRIMJ) + ENDIF + TCOUNT = TCOUNT + 1 +C +C MAJOR TIC/GRID +C + ELSE + IF (.NOT. LGRID) THEN + PY(2) = TICBIG + ENDIF + CALL GPL(2,PX,PY) +C +C LABEL. +C + IF (IXLAB .EQ. 1 .AND. LOOP .EQ. 1) THEN + IF (LOGVAL .EQ. 1 .OR. LOGVAL .EQ. 2) THEN +C (NOAO) WRITE(LABEL,XFMT)XPOS + call encode (10, xfmt, label, xpos) + ELSE +C (NOAO) WRITE(LABEL,XFMT)XCUR + call encode (10, xfmt, label, xcur) + ENDIF + CALL CHSTR(LABEL,FIRST,LAST) + CALL GTX (XPOS,XLAB,LABEL(FIRST:LAST)) + ENDIF + TCOUNT = 1 + IF (.NOT. LGRID) THEN + PY(2) = TICEND + ENDIF + ENDIF + IF ((LOGVAL .EQ. 4 .OR. LOGVAL .EQ. 3) .AND. + 1 XCUR .GE. EXCUR-.1*XINT) GOTO 101 + 100 CONTINUE + 101 CONTINUE +C +C TOP X-AXIS TICKS ? +C + IF (LOOP.EQ.1 .AND. (IGPH.EQ.4 .OR. IGPH.EQ.5 .OR. IGPH.EQ.6)) + 1 THEN + START = WIND(4) + TICEND = START - TICMIN + TICBIG = START - TICMAJ + PY(1) = START + PY(2) = TICEND + XPOS = WIND(1) + LOOP = 2 + IF (LOGVAL .EQ. 4 .OR. LOGVAL .EQ.3) THEN + XCUR = 10.**OWIND(1) + IF (LOGMIN) THEN + CURMAJ = XCUR + NEXTMA = XCUR * MAJDIV + XINT = (NEXTMA - CURMAJ) / 9. + ENDIF + ENDIF + GOTO 80 + ENDIF +C +C **** Y-AXIS TICS/GRIDS AND LABELS **** +C + 175 IF (IYLAB .EQ. -1) GOTO 999 +C +C CALCULATE Y-AXIS TICS +C + MINCNT = MINRY + IF (LOGVAL .EQ. 1 .OR. LOGVAL .EQ. 3) THEN + LOGMIN = .FALSE. + YINTM = YRANGE/MY + YINT = YINTM + IF (MINCNT .GT. 1) THEN + YINT = YINT/MINCNT + ENDIF + YTNUM = MY * MINCNT + IF (MINCNT .EQ. 0) YTNUM = MY + ELSE + YTNUM = 50 + YCUR = 10.**OWIND(3) + MAJDIV = 10 ** MY + IF (MINCNT .LE. 10 .AND. MY .LE. 1) THEN + LOGMIN = .TRUE. + CURMAJ = YCUR + NEXTMA = YCUR * MAJDIV + YINT = (NEXTMA - CURMAJ) / 9. + MINCNT = 9 + ELSE + LOGMIN = .FALSE. + MINCNT = 1 + ENDIF + ENDIF +C + LGRID = .FALSE. + LOOP = 1 +C +C DETERMINE ORIGIN OF TICK/GRID LINES (X COORDINATE.) +C + IF (IGPH .NE. 10) THEN + START = WIND(1) + ELSE + START = XI + ENDIF +C + YPOS = WIND(3) + PX(1) = START +C +C DETERMINE Y-AXIS TICK LENGTHS. +C + IF (MAJY .EQ. 0.) THEN + MAJY = .013 + MINY = .007 + ENDIF + IF (XRNEW .EQ. 0.) THEN + TICMIN = MINY * XRANGE + TICMAJ = MAJY * XRANGE + ELSE + TICMIN = MINY * XRNEW + TICMAJ = MAJY * XRNEW + ENDIF + TICEND = START + TICMIN + TICBIG = START + TICMAJ +C + PY(1) = YPOS + PY(2) = PY(1) +C +C DRAW BOTTOM-MOST TICK ON Y-AXIS IF (IGPH = 10 +C AND INTERSECTION OF AXES IS NOT AT BOTTOM LEFT +C OF WINDOW.) +C + IF (IGPH .EQ. 10) THEN + IF (YI .NE. WIND(3)) THEN + PX(2) = TICBIG + CALL GPL(2,PX,PY) + ENDIF +C +C DRAW Y-AXIS FOR IGPH = 10 +C + PY(2) = WIND(4) + PX(2) = PX(1) + CALL GPL(2,PX,PY) + PY(2) = PY(1) + ELSE +C +C DRAW X-AXIS FOR ANY OTHER IGPH (FIRST TICK.) +C + PX(2) = WIND(2) + CALL GPL(2,PX,PY) + ENDIF +C +C GRIDS OR TICS ? +C + IF ((IGPH .EQ. 0 .OR. IGPH .EQ. 4).OR. IGPH .EQ. 8) THEN + PX(2) = WIND(2) + LGRID = .TRUE. + ELSE + PX(2) = TICEND + ENDIF +C +C SET TEXT ATTRIBUTES IF Y-AXIS IS TO BE LABELLED. +C + IF (IYLAB .EQ. 1) THEN + IF (IXORI .EQ. 1) THEN + IF (YMIRRO) THEN + CALL GSCHUP(0.,-1.) + ELSE + CALL GSCHUP(0.,1.) + ENDIF + ENDIF +C +C SET TEXT ALIGNMENT TO (RIGHT,HALF) +C + CALL GSTXAL(3,3) +C +C RECALCULATE CHARACTER HEIGHT IF Y-AXIS LABELS ARE OF DIFFERENT +C SIZE FORM X-AXIS LABELS. +C + CHARH = SIZY * YRNEW + IF (YMIRRO) THEN + CHARH = -CHARH + ENDIF + CALL GSCHH(CHARH) + IF (YDEC .NE. 0. .AND. YDEC .NE. 1.) THEN + DEC = YDEC * XRNEW + ELSE + DEC = .02 * XRNEW + ENDIF + IF (YDEC .NE. 1.) THEN + YLAB = START - DEC + ELSE + IF (IGPH .NE. 10) THEN + YLAB = WIND(2)+DEC + ELSE + YLAB = XI+DEC + ENDIF +C +C SET TEXT ALIGNMENT TO (LEFT,HALF) IF LABELLING ON RIGHT OF Y-AXIS. +C + CALL GSTXAL(1,3) + ENDIF + IF (LOGVAL .EQ. 1 .OR. LOGVAL .EQ.3) THEN +C (NOAO) WRITE(LABEL,YFMT)YPOS + call encode (10, yfmt, label, ypos) + ELSE +C (NOAO) WRITE(LABEL,YFMT)YCUR + call encode (10, yfmt, label, ycur) + ENDIF + CALL CHSTR(LABEL,FIRST,LAST) + CALL GTX (YLAB,YPOS,LABEL(FIRST:LAST)) + ENDIF +C + 180 TCOUNT = 1 +C + DO 200 I = 1,YTNUM + IF (LOGVAL .EQ. 1 .OR. LOGVAL .EQ. 3) THEN + YPOS = YPOS + YINT + ELSE + IF (.NOT. LOGMIN) THEN + YCUR = YCUR * MAJDIV + ELSE + IF (TCOUNT .NE. MINCNT) THEN + YCUR = YCUR + YINT + ELSE + YCUR = YCUR + YINT + CURMAJ = NEXTMA + NEXTMA = CURMAJ * MAJDIV + YINT = (NEXTMA - CURMAJ) / 9. + ENDIF + ENDIF + IF (YCUR .GT. 10.**OWIND(4)-.1*YINT) THEN + YPOS = WIND(4) + ELSE + YPOS = ALOG10(YCUR) + ENDIF + ENDIF +C + PY(1) = YPOS + PY(2) = YPOS +C +C IF IGPH = 0,1,2,4,5,6 OR 8 AND YPOS = TOP AXIS, THEN +C DRAW AXIS, ELSE IF IGPH = 9 OR 10 DRAW TIC. +C + IF (LOGVAL .EQ. 3 .OR. LOGVAL .EQ. 4) EYCUR = 10.**OWIND(4) +C + IF ((((LOGVAL .EQ. 1.OR.LOGVAL.EQ.3) .AND. (I .EQ. YTNUM)) + 1 .OR.((LOGVAL .EQ.4 .OR.LOGVAL .EQ.2).AND.YCUR.GE.EYCUR-.1*YINT)) + 2 .AND.(IGPH.NE.9.AND.IGPH.NE.10)) THEN + IF (LOOP .EQ. 1) THEN + PX(2) = WIND(2) + CALL GPL(2,PX,PY) + IF (IYLAB .EQ. 1) THEN + IF (LOGVAL .EQ. 1 .OR. LOGVAL .EQ.3) THEN +C (NOAO) WRITE(LABEL,YFMT)YPOS + call encode (10, yfmt, label, ypos) + ELSE + IF (YCUR .GT. EYCUR+.1*YINT) THEN + GOTO 201 + ELSE +C (NOAO) WRITE(LABEL,YFMT)YCUR + call encode (10, yfmt, label, ycur) + ENDIF + ENDIF + CALL CHSTR(LABEL,FIRST,LAST) + CALL GTX (YLAB,YPOS,LABEL(FIRST:LAST)) + ENDIF + ENDIF + GOTO 201 + ENDIF + IF ((LOGVAL.EQ.4 .OR. LOGVAL.EQ.2) .AND. YCUR.GT.EYCUR+.1*YINT) + 1 GOTO 201 +C +C MINOR TIC/GRID ? +C + IF (TCOUNT .NE. MINCNT .AND. MINCNT .NE. 0) THEN + IF (LGRID) THEN + CALL GSPLCI(IGRIMN) + ENDIF + CALL GPL(2,PX,PY) + IF (LGRID) THEN + CALL GSPLCI(IGRIMJ) + ENDIF + TCOUNT = TCOUNT + 1 +C +C MAJOR TIC/GRID. +C + ELSE + IF (.NOT. LGRID) THEN + PX(2) = TICBIG + ENDIF + CALL GPL(2,PX,PY) +C +C LABEL. +C + IF (IYLAB .EQ. 1 .AND. LOOP .EQ.1) THEN + IF (LOGVAL .EQ. 1 .OR. LOGVAL .EQ.3) THEN +C (NOAO) WRITE(LABEL,YFMT)YPOS + call encode (10, yfmt, label, ypos) + ELSE +C (NOAO) WRITE(LABEL,YFMT)YCUR + call encode (10, yfmt, label, ycur) + ENDIF + CALL CHSTR(LABEL,FIRST,LAST) + CALL GTX(YLAB,YPOS,LABEL(FIRST:LAST)) + ENDIF + TCOUNT = 1 + IF (.NOT. LGRID) THEN + PX(2) = TICEND + ENDIF + ENDIF + IF ((LOGVAL .EQ. 4 .OR. LOGVAL .EQ. 2) .AND. + - YCUR .GE. EYCUR-.1*YINT) + 1 GOTO 201 + 200 CONTINUE + 201 CONTINUE +C +C RIGHT Y-AXIS TICKS ? +C + IF (LOOP .EQ. 1 .AND.(IGPH.EQ.1 .OR. IGPH .EQ. 5 .OR. + 1 IGPH .EQ. 9)) THEN + START = WIND(2) + TICEND = START - TICMIN + TICBIG = START - TICMAJ + PX(1) = START + PX(2) = TICEND + YPOS = WIND(3) + LOOP = 2 + IF (LOGVAL .EQ. 4 .OR. LOGVAL .EQ. 2) THEN + YCUR = 10.**OWIND(3) + IF (LOGMIN) THEN + CURMAJ = YCUR + NEXTMA = YCUR * MAJDIV + YINT = (NEXTMA - CURMAJ) / 9. + ENDIF + ENDIF + GOTO 180 + ENDIF +C +C RESET NORMALIZATION TRANSFORMATION TO WHAT IT WAS UPON ENTRY. +C + IF (ICNT .NE. 0) THEN + CALL GSWN(ICNT,OWIND(1),OWIND(2),OWIND(3),OWIND(4)) + CALL GSVP(ICNT,VIEW(1),VIEW(2),VIEW(3),VIEW(4)) + ENDIF + CALL GSELNT(ICNT) +C +C IF LABELS, RESTORE TEXT ATTRIBUTES. +C + IF (IXLAB .EQ. 1 .OR. IYLAB .EQ. 1) THEN + CALL GSCHH(OLDCHH) + CALL GSCHUP(CHUPX,CHUPY) + CALL GSTXAL(OLDALH,OLDALV) + CALL GSTXCI(OTEXCI) + ENDIF +C +C RESTORE ORIGINAL COLOR. +C + CALL GSPLCI(OCOLI) +C +C RESTORE POLYLINE COLOR ASF TO WHAT IS WAS ON ENTRY. +C + LASF(10) = OTXASF + LASF(3) = OPLASF + CALL GSASF(LASF) +C + 999 RETURN + END + SUBROUTINE GRID(MAJRX,MINRX,MAJRY,MINRY) +C + COMMON /LAB/ SIZX,SIZY,XDEC,YDEC,IXORI + COMMON /CLAB/ XFMT, YFMT + COMMON /TICK/ MAJX, MINX, MAJY, MINY + COMMON /GRIINT/ IGRIMJ, IGRIMN, IGRITX + CHARACTER*8 XFMT,YFMT + REAL MAJX,MINX,MAJY,MINY +C +C THE FOLLOWING IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4('GRAPHX','GRIDAL','GRID','VERSION 01') +C + CALL GRIDAL(MAJRX,MINRX,MAJRY,MINRY,0,0,0,0.,0.) + RETURN + END + SUBROUTINE GRIDL(MAJRX,MINRX,MAJRY,MINRY) +C + COMMON /LAB/ SIZX,SIZY,XDEC,YDEC,IXORI + COMMON /CLAB/ XFMT, YFMT + COMMON /TICK/ MAJX, MINX, MAJY, MINY + COMMON /GRIINT/ IGRIMJ, IGRIMN, IGRITX + CHARACTER*8 XFMT,YFMT + REAL MAJX,MINX,MAJY,MINY +C +C THE FOLLOWING IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4('GRAPHX','GRIDAL','GRIDL','VERSION 01') +C + CALL GRIDAL(MAJRX,MINRX,MAJRY,MINRY,1,1,0,0.,0.) + RETURN + END + SUBROUTINE PERIM(MAJRX,MINRX,MAJRY,MINRY) +C + COMMON /LAB/ SIZX,SIZY,XDEC,YDEC,IXORI + COMMON /CLAB/ XFMT, YFMT + COMMON /TICK/ MAJX, MINX, MAJY, MINY + COMMON /GRIINT/ IGRIMJ, IGRIMN, IGRITX + CHARACTER*8 XFMT,YFMT + REAL MAJX,MINX,MAJY,MINY +C +C THE FOLLOWING IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4('GRAPHX','GRIDAL','PERIM','VERSION 01') +C + CALL GRIDAL(MAJRX,MINRX,MAJRY,MINRY,0,0,5,0.,0.) + RETURN + END + SUBROUTINE PERIML(MAJRX,MINRX,MAJRY,MINRY) +C + COMMON /LAB/ SIZX,SIZY,XDEC,YDEC,IXORI + COMMON /CLAB/ XFMT, YFMT + COMMON /TICK/ MAJX, MINX, MAJY, MINY + COMMON /GRIINT/ IGRIMJ, IGRIMN, IGRITX + CHARACTER*8 XFMT,YFMT + REAL MAJX,MINX,MAJY,MINY +C +C THE FOLLOWING IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4('GRAPHX','GRIDAL','PERIML','VERSION 01') +C + CALL GRIDAL(MAJRX,MINRX,MAJRY,MINRY,1,1,5,0.,0.) + RETURN + END + SUBROUTINE HALFAX(MAJRX,MINRX,MAJRY,MINRY,X,Y,IXLAB,IYLAB) +C + COMMON /LAB/ SIZX,SIZY,XDEC,YDEC,IXORI + COMMON /CLAB/ XFMT, YFMT + COMMON /TICK/ MAJX, MINX, MAJY, MINY + COMMON /GRIINT/ IGRIMJ, IGRIMN, IGRITX + CHARACTER*8 XFMT,YFMT + REAL MAJX,MINX,MAJY,MINY +C +C THE FOLLOWING IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4('GRAPHX','GRIDAL','HALFAX','VERSION 01') +C + CALL GRIDAL(MAJRX,MINRX,MAJRY,MINRY,IXLAB,IYLAB,10,X,Y) + RETURN + END + SUBROUTINE LABMOD(FMTX,FMTY,NUMX,NUMY,ISIZX,ISIZY,IXDEC,IYDEC, + 1 IXOR) +C +C RESETS PARAMETERS FOR TEXT GRAPHICS FROM DEFAULT VALUES. +C + COMMON /LAB/ SIZX,SIZY,XDEC,YDEC,IXORI + COMMON /CLAB/ XFMT, YFMT + CHARACTER*8 XFMT,YFMT,FMTX,FMTY +C +C THE FOLLOWING IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4('GRAPHX','GRIDAL','LABMOD','VERSION 01') +C +C +C +NOAO - Blockdata rewritten as run time initialization. +C EXTERNAL GRIDT + call gridt +C -NOAO + XFMT = ' ' + YFMT = ' ' + XFMT = FMTX + YFMT = FMTY +C + CALL GETUSV('XF',IVAL) + XRANGE = 2. ** IVAL + CALL GETUSV('YF', IVAL) + YRANGE = 2. ** IVAL +C +C SIZX AND SIZY ARE COMPUTED TO BE PERCENTAGES OF TOTAL SCREEN +C WIDTH. +C + IF (ISIZX .GT. 3) THEN + SIZX = FLOAT(ISIZX)/XRANGE + ELSEIF (ISIZX .EQ. 3) THEN + SIZX = 24./1024. + ELSEIF (ISIZX .EQ. 2) THEN + SIZX = 16./1024. + ELSEIF (ISIZX .EQ. 1) THEN + SIZX = 12./1024. + ELSE + SIZX = 8./1024. + ENDIF +C + IF (ISIZY .GT. 3) THEN + SIZY = FLOAT(ISIZY)/XRANGE + ELSEIF (ISIZY .EQ. 3) THEN + SIZY = 24./1024. + ELSEIF (ISIZY .EQ. 2) THEN + SIZY = 16./1024. + ELSEIF (ISIZY .EQ. 1) THEN + SIZY = 12./1024. + ELSE + SIZY = 8./1024. + ENDIF +C +C CALCULATE XDEC AND YDEC AS PERCENTAGES OF TOTAL SCREEN WIDTH +C IN PLOTTER ADDRESS UNITS. +C + IF (IXDEC .EQ. 0 .OR. IXDEC .EQ. 1) THEN + YDEC = FLOAT(IXDEC) + ELSE + YDEC = FLOAT(IXDEC)/XRANGE + ENDIF + IF (IYDEC .EQ. 0 .OR. IYDEC .EQ. 1) THEN + XDEC = FLOAT(IYDEC) + ELSE + XDEC = FLOAT(IYDEC)/YRANGE + ENDIF +C + IXORI = IXOR +C + RETURN + END + SUBROUTINE TICK4(LMAJX,LMINX,LMAJY,LMINY) +C +C CHANGES TICK LENGTH FOR EACH AXIS. +C + COMMON /TICK/ MAJX, MINX, MAJY, MINY + REAL MAJX, MINX, MAJY, MINY +C +C THE FOLLOWING IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4('GRAPHX','GRIDAL','TICK4','VERSION 01') +C + CALL GETUSV('XF', IVAL) + XRANGE = 2. ** IVAL + CALL GETUSV('YF', IVAL) + YRANGE = 2. ** IVAL +C + MAJX = FLOAT(LMAJX)/YRANGE + MINX = FLOAT(LMINX)/YRANGE + MAJY = FLOAT(LMAJY)/XRANGE + MINY = FLOAT(LMINY)/XRANGE +C + RETURN + END + SUBROUTINE TICKS(LMAJ,LMIN) +C + COMMON /TICK/ MAJX,MINX,MAJY,MINY + REAL MAJX,MINX,MAJY,MINY +C +C THE FOLLOWING IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4('GRAPHX','GRIDAL','TICKS','VERSION 01') +C + CALL TICK4(LMAJ,LMIN,LMAJ,LMIN) +C + RETURN + END + SUBROUTINE CHSTR(LABEL,FIRST,LAST) +C +C THIS CALCULATES THE POSITION OF THE FIRST NON-BLANK CHARACTER +C AND THE POSITION OF THE LAST NON-BLANK CHARACTER IN LABEL. +C + INTEGER FIRST, LAST + CHARACTER*15 LABEL +C + DO 100 I = 1,15 + IF (LABEL(I:I) .NE. ' ') GOTO 200 + 100 CONTINUE + 200 FIRST = I + LAST = 15 + IF (FIRST .NE. 15) THEN + DO 300 J = FIRST+1,15 + IF (LABEL(J:J) .EQ. ' ') THEN + LAST = J-1 + GOTO 999 + ENDIF + 300 CONTINUE + 999 CONTINUE + ENDIF + RETURN + END + SUBROUTINE EXPAND(MAXW) +C +C THE WINDOW IS EXPANDED AND THE NEW WORLD COORDINATES ARE +C CALCULATED TO CORRESPOND TO THE MAXIMUM VIEWPORT. +C THE ORIGINAL ASPECT RATIO OF WORLD COORDINATES TO VIEWPORT +C COORDINATES REMAINS THE SAME. UNDER THE NEWLY-DEFINED +C NORMALIZATION TRANSFORMATION, THE WINDOW OF THE ORIGINAL +C NORMALIZATION TRANSFORMATION IS MAPPED TO THE VIEWPORT +C OF THE ORIGINAL NORMALIZATION TRANSFORMATION IN EXACTLY +C THE SAME WAY AS IN THE INITIAL NORMALIZATION TRANSFORMATION. +C + REAL MAXW(4), VIEW(4), WIND(4) + REAL LEFT +C +C INQUIRE CURRENT WINDOW AND VIEWPORT SETTINGS. +C + CALL GQCNTN(IERR,ICNT) + CALL GQNT(ICNT,IERR,WIND,VIEW) +C +C CALCULATE RATIO OF Y WORLD/VIEWPORT COORDINATES. +C + YRATIO = (WIND(4) - WIND(3))/(VIEW(4) - VIEW(3)) +C +C CALCULATE RATIO OF X WORLD/VIEWPORT COORDINATES. +C + XRATIO = (WIND(2) - WIND(1))/(VIEW(2) - VIEW(1)) +C +C GET EXPANDED LOWER LIMIT Y COORDINATE. +C + VBOTTM = VIEW(3) - 0. + BOTTOM = YRATIO * VBOTTM + MAXW(3) = WIND(3) - BOTTOM +C +C GET EXPANDED UPPER LIMIT Y COORDINATE. +C + VTOP = 1. - VIEW(4) + TOP = YRATIO * VTOP + MAXW(4) = WIND(4) + TOP +C +C GET EXPANDED LEFT LIMIT X COORDINATE. +C + VLEFT = VIEW(1) - 0. + LEFT = XRATIO * VLEFT + MAXW(1) = WIND(1) - LEFT +C +C GET EXPANDED RIGHT LIMIT X COORDINATE. +C + VRIGHT = 1. - VIEW(2) + RIGHT = XRATIO * VRIGHT + MAXW(2) = WIND(2) + RIGHT +C +C SET NEW (EXPANDED) NORMALIZATION TRANSFORMATION. +C + CALL GSWN(1,MAXW(1),MAXW(2),MAXW(3),MAXW(4)) + CALL GSVP(1, 0., 1., 0., 1. ) + CALL GSELNT(1) +C + RETURN + END diff --git a/sys/gio/ncarutil/gridt.f b/sys/gio/ncarutil/gridt.f new file mode 100644 index 00000000..eb10ddf1 --- /dev/null +++ b/sys/gio/ncarutil/gridt.f @@ -0,0 +1,65 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +c + noao: block data gridt changed to run time initialization +c BLOCK DATA GRIDT + subroutine gridt +C +C + COMMON /LAB/ SIZX,SIZY,XDEC,YDEC,IXORI + COMMON /CLAB/ XFMT, YFMT + COMMON /TICK/ MAJX, MINX, MAJY, MINY + COMMON /GRIINT/ IGRIMJ, IGRIMN, IGRITX + CHARACTER*8 XFMT,YFMT + REAL MAJX,MINX,MAJY,MINY +C +c +noao: following flag added to prevent initializing more than once + logical first + SAVE + data first /.true./ + if (.not. first) then + return + endif + first = .false. +C +c DATA XFMT,YFMT /'(E10.3) ','(E10.3) '/ + XFMT = '(E10.3) ' + YFMT = '(E10.3) ' +c +c DATA SIZX,SIZY / 0.01, 0.01 / + SIZX = 0.01 + SIZY = 0.01 +c +c DATA XDEC,YDEC / 0., 0. / + XDEC = 0. + YDEC = 0. +c +c DATA IXORI / 0 / + IXORI = 0 +c +c DATA MAJX,MINX,MAJY,MINY / 0., 0., 0., 0./ + MAJX = 0. + MINX = 0. + MAJY = 0. + MINY = 0. +c +c DATA IGRIMJ,IGRIMN,IGRITX / 1, 1, 1/ +c+noao: These values changed so major axes and labels are bold + IGRIMJ = 2 + IGRIMN = 1 + IGRITX = 2 +C - noao + END +C REVISION HISTORY--------------- +C---------------------------------------------------------- + diff --git a/sys/gio/ncarutil/hafton.f b/sys/gio/ncarutil/hafton.f new file mode 100644 index 00000000..7d597470 --- /dev/null +++ b/sys/gio/ncarutil/hafton.f @@ -0,0 +1,830 @@ + SUBROUTINE HAFTON (Z,L,M,N,FLO,HI,NLEV,NOPT,NPRM,ISPV,SPVAL) +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C SUBROUTINE HAFTON (Z,L,M,N,FLO,HI,NLEV,NOPT,NPRM,ISPV,SPVAL) +C +C +C DIMENSION OF Z(L,M) +C ARGUMENTS +C +C LATEST REVISION JULY,1984 +C +C PURPOSE HAFTON DRAWS A HALF-TONE PICTURE FROM DATA +C STORED IN A RECTANGULAR ARRAY WITH THE +C INTENSITY IN THE PICTURE PROPORTIONAL TO +C THE DATA VALUE. +C +C USAGE IF THE FOLLOWING ASSUMPTIONS ARE MET, USE +C +C CALL EZHFTN (Z,M,N) +C +C ASSUMPTIONS: +C .ALL OF THE ARRAY IS TO BE DRAWN. +C .LOWEST VALUE IN Z WILL BE AT LOWEST +C INTENSITY ON READER/PRINTER OUTPUT. +C .HIGHEST VALUE IN Z WILL BE AT +C HIGHEST INTENSITY. +C .VALUES IN BETWEEN WILL APPEAR +C LINEARLY SPACED. +C .MAXIMUM POSSIBLE NUMBER OF +C INTENSITIES ARE USED. +C .THE PICTURE WILL HAVE A PERIMETER +C DRAWN. +C .FRAME WILL BE CALLED AFTER THE +C PICTURE IS DRAWN. +C .Z IS FILLED WITH NUMBERS THAT SHOULD +C BE USED (NO MISSING VALUES). +C +C IF THESE ASSUMPTIONS ARE NOT MET, USE +C +C CALL HAFTON (Z,L,M,N,FLO,HI,NLEV, +C NOPT,NPRM,ISPV,SPVAL) +C +C ARGUMENTS +C +C ON INPUT Z +C FOR EZHFTN M BY N ARRAY TO BE USED TO GENERATE A +C HALF-TONE PLOT. +C +C M +C FIRST DIMENSION OF Z. +C +C N +C SECOND DIMENSION OF Z. +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED. +C FOR EZHFTN +C +C ON INPUT Z +C FOR HAFTON THE ORIGIN OF THE ARRAY TO BE PLOTTED. +C +C L +C THE FIRST DIMENSION OF Z IN THE CALLING +C PROGRAM. +C +C M +C THE NUMBER OF DATA VALUES TO BE PLOTTED +C IN THE X-DIRECTION (THE FIRST SUBSCRIPT +C DIRECTION). WHEN PLOTTING ALL OF AN +C ARRAY, L = M. +C +C N +C THE NUMBER OF DATA VALUES TO BE PLOTTED +C IN THE Y-DIRECTION (THE SECOND SUBSCRIPT +C DIRECTION). +C +C FLO +C THE VALUE OF Z THAT CORRESPONDS TO THE +C LOWEST INTENSITY. (WHEN NOPT.LT.0, FLO +C CORRESPONDS TO THE HIGHEST INTENSITY.) +C IF FLO=HI=0.0, MIN(Z) WILL BE USED FOR FLO. +C +C HI +C THE VALUE OF Z THAT CORRESPONDS TO THE +C HIGHEST INTENSITY. (WHEN NOPT.LT.0, HI +C CORRESPONDS TO THE LOWEST INTENSITY.) IF +C HI=FLO=0.0, MAX(Z) WILL BE USED FOR HI. +C +C NLEV +C THE NUMBER OF INTENSITY LEVELS DESIRED. +C 16 MAXIMUM. IF NLEV = 0 OR 1, 16 LEVELS +C ARE USED. +C +C NOPT +C FLAG TO CONTROL THE MAPPING OF Z ONTO THE +C INTENSITIES. THE SIGN OF NOPT CONTROLS +C THE DIRECTNESS OR INVERSENESS OF THE +C MAPPING. +C +C . NOPT POSITIVE YIELDS DIRECT MAPPING. +C THE LARGEST VALUE OF Z PRODUCES THE +C MOST DENSE DOTS. ON MECHANICAL PLOTTERS, +C LARGE VALUES OF Z WILL PRODUCE A DARK +C AREA ON THE PAPER. WITH THE FILM +C DEVELOPMENT METHODS USED AT NCAR, +C LARGE VALUES OF Z WILL PRODUCE MANY +C (WHITE) DOTS ON THE FILM, ALSO +C RESULTING IN A DARK AREA ON +C READER-PRINTER PAPER. +C . NOPT NEGATIVE YIELDS INVERSE MAPPING. +C THE SMALLEST VALUES OF Z PRODUCE THE +C MOST DENSE DOTS RESULTING IN DARK +C AREAS ON THE PAPER. +C +C THE ABSOLUTE VALUE OF NOPT DETERMINES THE +C MAPPING OF Z ONTO THE INTENSITIES. FOR +C IABS(NOPT) +C = 0 THE MAPPING IS LINEAR. FOR +C EACH INTENSITY THERE IS AN EQUAL +C RANGE IN Z VALUE. +C = 1 THE MAPPING IS LINEAR. FOR +C EACH INTENSITY THERE IS AN EQUAL +C RANGE IN Z VALUE. +C = 2 THE MAPPING IS EXPONENTIAL. FOR +C LARGER VALUES OF Z, THERE IS A +C LARGER DIFFERENCE IN INTENSITY FOR +C RELATIVELY CLOSE VALUES OF Z. DETAILS +C IN THE LARGER VALUES OF Z ARE DISPLAYED +C AT THE EXPENSE OF THE SMALLER VALUES +C OF Z. +C = 3 THE MAPPING IS LOGRITHMIC, SO +C DETAILS OF SMALLER VALUES OF Z ARE SHOWN +C AT THE EXPENSE OF LARGER VALUES OF Z. +C = 4 SINUSOIDAL MAPPING, SO MID-RANGE VALUES +C OF Z SHOW DETAILS AT THE EXPENSE OF +C EXTREME VALUES OF Z. +C = 5 ARCSINE MAPPING, SO EXTREME VALUES OF +C Z ARE SHOWN AT THE EXPENSE OF MID-RANGE +C VALUES OF Z. +C +C NPRM +C FLAG TO CONTROL THE DRAWING OF A +C PERIMETER AROUND THE HALF-TONE PICTURE. +C +C . NPRM=0: THE PERIMETER IS DRAWN WITH +C TICKS POINTING AT DATA LOCATIONS. +C (SIDE LENGTHS ARE PROPORTIONAL TO NUMBER +C OF DATA VALUES.) +C . NPRM POSITIVE: NO PERIMETER IS DRAWN. THE +C PICTURE FILLS THE FRAME. +C . NPRM NEGATIVE: THE PICTURE IS WITHIN THE +C CONFINES OF THE USER'S CURRENT VIEWPORT +C SETTING. +C +C ISPV +C FLAG TO TELL IF THE SPECIAL VALUE FEATURE +C IS BEING USED. THE SPECIAL VALUE FEATURE +C IS USED TO MARK AREAS WHERE THE DATA IS +C NOT KNOWN OR HOLES ARE WANTED IN THE +C PICTURE. +C +C . ISPV = 0: SPECIAL VALUE FEATURE NOT IN +C USE. SPVAL IS IGNORED. +C . ISPV NON-ZERO: SPECIAL VALUE FEATURE +C IN USE. SPVAL DEFINES THE SPECIAL +C VALUE. WHERE Z CONTAINS THE SPECIAL +C VALUE, NO HALF-TONE IS DRAWN. IF ISPV +C = 0 SPECIAL VALUE FEATURE NOT IN USE. +C SPVAL IS IGNORED. +C = 1 NOTHING IS DRAWN IN SPECIAL VALUE +C AREA. +C = 2 CONTIGUOUS SPECIAL VALUE AREAS ARE +C SURROUNDED BY A POLYGONAL LINE. +C = 3 SPECIAL VALUE AREAS ARE FILLED +C WITH X(S). +C = 4 SPECIAL VALUE AREAS ARE FILLED IN +C WITH THE HIGHEST INTENSITY. +C +C SPVAL +C THE VALUE USED IN Z TO DENOTE MISSING +C VALUES. THIS ARGUMENT IS IGNORED IF +C ISPV = 0. +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED. +C FOR HAFTON +C +C NOTE THIS ROUTINE PRODUCES A HUGE NUMBER OF +C PLOTTER INSTRUCTIONS PER PICTURE, AVERAGING +C OVER 100,000 LINE-DRAWS PER FRAME WHEN M = N. +C +C +C ENTRY POINTS EZHFTN, HAFTON, ZLSET, GRAY, BOUND, HFINIT +C +C COMMON BLOCKS HAFT01, HAFT02, HAFT03, HAFT04 +C +C REQUIRED LIBRARY GRIDAL, THE ERPRT77 PACKAGE AND THE SPPS. +C ROUTINES +C +C I/O PLOTS HALF-TONE PICTURE. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C HISTORY REWRITE OF PHOMAP ORIGINALLY WRITTEN BY +C M. PERRY OF HIGH ALTITUDE OBSERVATORY, +C NCAR. +C +C ALGORITHM BI-LINEAR INTERPOLATION ON PLOTTER +C (RESOLUTION-LIMITED) GRID OF NORMALIZED +C REPRESENTATION OF DATA. +C +C PORTABILITY ANSI FORTRAN 77. +C +C +C +C INTERNAL PARAMTERSS +C VALUES SET IN BLOCK DATA +C NAME DEFAULT FUNCTION +C ---- ------- ________ +C +C XLT 0.1 LEFT-HAND EDGE OF THE PLOT WHEN NSET=0. (0.0= +C LEFT EDGE OF FRAME, 1.0=RIGHT EDGE OF FRAME.) +C YBT 0.1 BOTTOM EDGE OF THE PLOT WHEN NSET=0. (0.0= +C BOTTOM OF FRAME, 1.0=TOP OF FRAME.) +C SIDE 0.8 LENGTH OF LONGER EDGE OF PLOT (SEE ALSO EXT). +C EXT .25 LENGTHS OF THE SIDES OF THE PLOT ARE PROPOR- +C TIONAL TO M AND N (WHEN NSET=0) EXCEPT IN +C EXTREME CASES, NAMELY, WHEN MIN(M,N)/MAX(M,N) +C IS LESS THAN EXT. THEN A SQUARE PLOT IS PRO- +C DUCED. WHEN A RECTANGULAR PLOT IS PRODUCED, +C THE PLOT IS CENTERED ON THE FRAME (AS LONG AS +C SIDE+2*XLT = SIDE+2*YBT=1., AS WITH THE +C DEFAULTS.) +C ALPHA 1.6 A PARAMETER TO CONTROL THE EXTREMENESS OF THE +C MAPPING FUNCTION SPECIFIED BY NOPT. (FOR +C IABS(NOPT)=0 OR 1, THE MAPPING FUNCTION IS +C LINEAR AND INDEPENDENT OF ALPHA.) FOR THE NON- +C LINEAR MAPPING FUNCTIONS, WHEN ALPHA IS CHANGED +C TO A NUMBER CLOSER TO 1., THE MAPPING FUNCTION +C BECOMES MORE LINEAR; WHEN ALPHA IS CHANGED TO +C A LARGER NUMBER, THE MAPPING FUNCTION BECOMES +C MORE EXTREME. +C MXLEV 16 MAXIMUM NUMBER OF LEVELS. LIMITED BY PLOTTER. +C NCRTG 8 NUMBER OF CRT UNITS PER GRAY-SCALE CELL. +C LIMITED BY PLOTTER. +C NCRTF 1024 NUMBER OF PLOTTER ADDRESS UNITS PER FRAME. +C IL (BELOW) AN ARRAY DEFINING WHICH OF THE AVAILABLE IN- +C TENSITIES ARE USED WHEN LESS THAN THE MAXIMUM +C NUMBER OF INTENSITIES ARE REQUESTED. +C +C +C NLEV INTENSITIES USED +C ____ ________________ +C 2 5,11, +C 3 4, 8,12, +C 4 3, 6,10,13, +C 5 2, 5, 8,11,14, +C 6 1, 4, 7, 9,12,15, +C 7 1, 4, 6, 8,10,12,15, +C 8 1, 3, 5, 7, 9,11,13,15, +C 9 1, 3, 4, 6, 8,10,12,13,15 +C 10 1, 3, 4, 6, 7, 9,10,12,13,15, +C 11 1, 2, 3, 5, 6, 8,10,11,13,14,15, +C 12 1, 2, 3, 5, 6, 7, 9,10,11,13,14,15, +C 13 1, 2, 3, 4, 6, 7, 8, 9,10,12,13,14,15 +C 14 1, 2, 3, 4, 5, 6, 7, 9,10,11,12,13,14,15, +C 15 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15, +C 16 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15 +C +C + + SAVE + DIMENSION Z(L,N) ,PX(2) ,PY(2) + DIMENSION ZLEV(16) ,VWPRT(4) ,WNDW(4) + DIMENSION VWPR2(4) ,WND2(4) + CHARACTER*11 IDUMMY +C +C + COMMON /HAFTO1/ I ,J ,INTEN + COMMON /HAFTO2/ GLO ,HA ,NOPTN ,ALPHA , + 1 NSPV ,SP ,ICNST + COMMON /HAFTO3/ XLT ,YBT ,SIDE ,EXT , + 1 IOFFM ,ALPH ,MXLEV ,NCRTG , + 2 NCRTF ,IL(135) + COMMON /HAFTO4/ NPTMAX ,NPOINT ,XPNT(50) ,YPNT(50) +C +NOAO - Blockdata rewritten as run time initialization subroutine +C +C EXTERNAL HFINIT + call hfinit +C -NOAO +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','HAFTON','HAFTON','VERSION 1') +C + NPOINT = 0 + ALPHA = ALPH + GLO = FLO + HA = HI + NLEVL = MIN0(IABS(NLEV),MXLEV) + IF (NLEVL .LE. 1) NLEVL = MXLEV + NOPTN = NOPT + IF (NOPTN .EQ. 0) NOPTN = 1 + NPRIM = NPRM + NSPV = MAX0(MIN0(ISPV,4),0) + IF (NSPV .NE. 0) SP = SPVAL + MX = L + NX = M + NY = N + CRTF = NCRTF + MSPV = 0 +C +C SET INTENSITY BOUNDARY LEVELS +C + CALL ZLSET (Z,MX,NX,NY,ZLEV,NLEVL) +C +C SET UP PERIMETER +C + X3 = NX + Y3 = NY + CALL GQCNTN (IERR,NTORIG) + CALL GETUSV('LS',IOLLS) + IF (NPRIM.LT.0) THEN + CALL GQNT (NTORIG,IERR,WNDW,VWPRT) + X1 = VWPRT(1) + X2 = VWPRT(2) + Y1 = VWPRT(3) + Y2 = VWPRT(4) + ELSE IF (NPRIM.EQ.0) THEN + X1 = XLT + X2 = XLT+SIDE + Y1 = YBT + Y2 = YBT+SIDE + IF (AMIN1(X3,Y3)/AMAX1(X3,Y3) .GE. EXT) THEN + IF (NX-NY.LT.0) THEN + X2 =SIDE*X3/Y3+XLT + X2 = (AINT(X2*CRTF/FLOAT(NCRTG))*FLOAT(NCRTG))/CRTF + ELSE IF (NX-NY.GT.0) THEN + Y2 = SIDE*Y3/X3+YBT + Y2 = (AINT(Y2*CRTF/FLOAT(NCRTG))*FLOAT(NCRTG))/CRTF + END IF + END IF + ELSE IF (NPRIM.GT.0) THEN + X1 = 0.0 + X2 = 1.0 + Y1 = 0.0 + Y2 = 1.0 + END IF + MX1 = X1*CRTF + MX2 = X2*CRTF + MY1 = Y1*CRTF + MY2 = Y2*CRTF + IF (NPRIM.GT.0) THEN + MX1 = 1 + MY1 = 1 + MX2 = NCRTF + MY2 = NCRTF + END IF +C +C SAVE NORMALIZATION TRANS 1 +C + CALL GQNT (1,IERR,WNDW,VWPRT) +C +C DEFINE NORMALIZATION TRANS 1 AND LOG SCALING FOR USE WITH PERIM +C DRAW PERIMETER IF NPRIM EQUALS 0 +C + CALL SET(X1,X2,Y1,Y2,1.0,X3,1.0,Y3,1) + IF (NPRIM .EQ. 0) CALL PERIM (NX-1,1,NY-1,1) + IF (ICNST .NE. 0) THEN + CALL GSELNT (0) + CALL WTSTR(XLT*1.1,0.5,'CONSTANT FIELD',2,0,0) + GO TO 132 + END IF +C +C FIND OFFSET FOR REFERENCE TO IL, WHICH IS TRIANGULAR +C + IOFFST = NLEVL*((NLEVL-1)/2)+MOD(NLEVL-1,2)*(NLEVL/2)-1 +C +C OUTPUT INTENSITY SCALE +C + IF (NPRIM .GT. 0) GO TO 112 + LEV = 0 + KX = (1.1*XLT+SIDE)*CRTF + KY = YBT*CRTF + NNX = KX/NCRTG + 109 LEV = LEV+1 +C +NOAO +C The following statement moved from after statement label 111 (CONTINUE) to +C here. Otherwise an extra (unlabelled) grayscale box was being drawn. +C This was (eventually) causing a [floating operand error] on a Sun-3. + IF (LEV .GT. NLEVL) GO TO 112 +C -NOAO + ISUB = IOFFST+LEV + INTEN = IL(ISUB) + IF (NOPTN .LT. 0) INTEN = MXLEV-INTEN + NNY = KY/NCRTG + DO 111 JJ=1,3 + DO 110 II=1,10 + I = NNX+II + J = NNY+JJ + CALL GRAY + 110 CONTINUE + 111 CONTINUE +C +NOAO - FTN internal write rewritten as call to encode. +C WRITE(IDUMMY,'(G11.4)') ZLEV(LEV) + call encode (11, '(g11.4)', idummy, zlev(lev)) +C -NOAO + TKX = KX + TKY = KY+38 + CALL GQNT(1,IERR,WND2,VWPR2) + CALL SET(0.,1.,0.,1.,0.,1023.,0.,1023.,1) + CALL WTSTR (TKX,TKY,IDUMMY,0,0,-1) + CALL SET(VWPR2(1),VWPR2(2),VWPR2(3),VWPR2(4), + - WND2(1),WND2(2),WND2(3),WND2(4),1) +C +C ADJUST 38 TO PLOTTER. +C + KY = KY+52 +C +C ADJUST 52 TO PLOTTER. +C + GO TO 109 +C +C STEP THROUGH PLOTTER GRID OF INTENSITY CELLS. +C + 112 IMIN = (MX1-1)/NCRTG+1 + IMAX = (MX2-1)/NCRTG + JMIN = (MY1-1)/NCRTG+1 + JMAX = (MY2-1)/NCRTG + XL = IMAX-IMIN+1 + YL = JMAX-JMIN+1 + XN = NX + YN = NY + LSRT = NLEVL/2 + DO 130 J=JMIN,JMAX +C +C FIND Y FOR THIS J AND Z FOR THIS Y. +C + YJ = (FLOAT(J-JMIN)+.5)/YL*(YN-1.)+1. + LOWY = YJ + YPART = YJ-FLOAT(LOWY) + IF (LOWY .NE. NY) GO TO 113 + LOWY = LOWY-1 + YPART = 1. + 113 IPEN = 0 + ZLFT = Z(1,LOWY)+YPART*(Z(1,LOWY+1)-Z(1,LOWY)) + ZRHT = Z(2,LOWY)+YPART*(Z(2,LOWY+1)-Z(2,LOWY)) + IF (NSPV .EQ. 0) GO TO 114 + IF (Z(1,LOWY).EQ.SP .OR. Z(2,LOWY).EQ.SP .OR. + 1 Z(1,LOWY+1).EQ.SP .OR. Z(2,LOWY+1).EQ.SP) IPEN = 1 + 114 IF (IPEN .EQ. 1) GO TO 117 +C +C FIND INT FOR THIS Z. +C + IF (ZLFT .GT. ZLEV(LSRT+1)) GO TO 116 + 115 IF (ZLFT .GE. ZLEV(LSRT)) GO TO 117 +C +C LOOK LOWER +C + IF (LSRT .LE. 1) GO TO 117 + LSRT = LSRT-1 + GO TO 115 +C +C LOOK HIGHER +C + 116 IF (LSRT .GE. NLEVL) GO TO 117 + LSRT = LSRT+1 + IF (ZLFT .GT. ZLEV(LSRT+1)) GO TO 116 +C +C OK +C + 117 IRHT = 2 + LAST = LSRT + DO 129 I=IMIN,IMAX +C +C FIND X FOR THIS I AND Z FOR THIS X AND Y. +C + IADD = 1 + XI = (FLOAT(I-IMIN)+.5)/XL*(XN-1.)+1. + LOWX = XI + XPART = XI-FLOAT(LOWX) + IF (LOWX .NE. NX) GO TO 118 + LOWX = LOWX-1 + XPART = 1. +C +C TEST FOR INTERPOLATION POSITIONING +C + 118 IF (LOWX .LT. IRHT) GO TO 119 +C +C MOVE INTERPOLATION ONE CELL TO THE RIGHT +C + ZLFT = ZRHT + IRHT = IRHT+1 + ZRHT = Z(IRHT,LOWY)+YPART*(Z(IRHT,LOWY+1)-Z(IRHT,LOWY)) + IF (NSPV .EQ. 0) GO TO 118 + IPEN = 0 + IF (Z(IRHT-1,LOWY).EQ.SP .OR. Z(IRHT,LOWY).EQ.SP .OR. + 1 Z(IRHT-1,LOWY+1).EQ.SP .OR. Z(IRHT,LOWY+1).EQ.SP) + 2 IPEN = 1 + GO TO 118 + 119 IF (IPEN .NE. 1) GO TO 123 +C +C SPECIAL VALUE AREA +C + GO TO (129,120,121,122),NSPV + 120 MSPV = 1 + GO TO 129 + 121 PX(1) = I*NCRTG + PY(1) = J*NCRTG + PX(2) = PX(1)+NCRTG-1 + PY(2) = PY(1)+NCRTG-1 + CALL GPL (2,PX,PY) + PYTMP = PY(1) + PY(1) = PY(2) + PY(2) = PYTMP + CALL GPL (2,PX,PY) +C + GO TO 129 + 122 INTEN = MXLEV + GO TO 128 + 123 ZZ = ZLFT+XPART*(ZRHT-ZLFT) +C +C TEST FOR SAME INT AS LAST TIME. +C + IF (ZZ .GT. ZLEV(LAST+1)) GO TO 126 + 124 IF (ZZ .GE. ZLEV(LAST)) GO TO 127 +C +C LOOK LOWER +C + IF (LAST .LE. 1) GO TO 125 + LAST = LAST-1 + GO TO 124 + 125 IF (ZZ .LT. ZLEV(LAST)) IADD = 0 + GO TO 127 +C +C LOOK HIGHER +C + 126 IF (LAST .GE. NLEVL) GO TO 127 + LAST = LAST+1 + IF (ZZ .GE. ZLEV(LAST+1)) GO TO 126 +C +C OK +C + 127 ISUB = LAST+IOFFST+IADD + INTEN = IL(ISUB) + IF (NOPTN .LT. 0) INTEN = MXLEV-INTEN + 128 CALL GRAY + 129 CONTINUE + 130 CONTINUE +C +C PUT OUT ANY REMAINING BUFFERED POINTS. +C + IF (NPOINT.GT.0) THEN + CALL GQNT(1,IERR,WND2,VWPR2) + CALL SET(0.,1.,0.,1.,0.,1023.,0.,1023.,1) + CALL POINTS(XPNT,YPNT,NPOINT,0,0) + CALL SET(VWPR2(1),VWPR2(2),VWPR2(3),VWPR2(4), + - WND2(1),WND2(2),WND2(3),WND2(4),1) + ENDIF +C +C CALL BOUND IF ISPV=2 AND SPECIAL VALUES WERE FOUND. +C + IF (MSPV .EQ. 1) THEN + CALL SET(X1,X2,Y1,Y2,1.0,X3,1.0,Y3,1) + CALL BOUND (Z,MX,NX,NY,SP) + END IF + 132 CONTINUE +C +C RESTORE NORMALIZATION TRANS 1 AND ORIGINAL NORMALIZATION NUMBER +C + CALL SET(VWPRT(1),VWPRT(2),VWPRT(3),VWPRT(4), + - WNDW(1),WNDW(2),WNDW(3),WNDW(4),IOLLS) + CALL SETUSV('LS',IOLLS) + CALL GSELNT (NTORIG) + RETURN +C + END + SUBROUTINE ZLSET (Z,MX,NX,NY,ZL,NLEVL) + SAVE +C + DIMENSION Z(MX,NY) ,ZL(NLEVL) +C + COMMON /HAFTO2/ GLO ,HA ,NOPTN ,ALPHA , + 1 NSPV ,SP ,ICNST +C + BIG = R1MACH(2) +C +C ZLSET PUTS THE INTENSITY LEVEL BREAK POINTS IN ZL. +C ALL ARGUMENTS ARE AS IN HAFTON. +C + LX = NX + LY = NY + NLEV = NLEVL + NOPT = IABS(NOPTN) + RALPH = 1./ALPHA + ICNST = 0 + IF (GLO.NE.0. .OR. HA.NE.0.) GO TO 106 +C +C FIND RANGE IF NOT KNOWN. +C + GLO = BIG + HA = -GLO + IF (NSPV .NE. 0) GO TO 103 + DO 102 J=1,LY + DO 101 I=1,LX + ZZ = Z(I,J) + GLO = AMIN1(ZZ,GLO) + HA = AMAX1(ZZ,HA) + 101 CONTINUE + 102 CONTINUE + GO TO 106 + 103 DO 105 J=1,LY + DO 104 I=1,LX + ZZ = Z(I,J) + IF (ZZ .EQ. SP) GO TO 104 + GLO = AMIN1(ZZ,GLO) + HA = AMAX1(ZZ,HA) + 104 CONTINUE + 105 CONTINUE +C +C FILL ZL +C + 106 DELZ = HA-GLO + IF (DELZ .EQ. 0.) GO TO 115 + DZ = DELZ/FLOAT(NLEV) + NLEVM1 = NLEV-1 + DO 114 K=1,NLEVM1 + ZNORM = FLOAT(K)/FLOAT(NLEV) + GO TO (107,108,109,110,111),NOPT +C +C NOPT=1 +C + 107 ZL(K) = GLO+FLOAT(K)*DZ + GO TO 114 +C +C NOPT=2 +C + 108 ONORM = (1.-(1.-ZNORM)**ALPHA)**RALPH + GO TO 113 +C +C NOPT=3 +C + 109 ONORM = 1.-(1.-ZNORM**ALPHA)**RALPH + GO TO 113 +C +C NOPT=4 +C + 110 ONORM = .5*(1.-(ABS(ZNORM+ZNORM-1.))**ALPHA)**RALPH + GO TO 112 +C +C NOPT=5 +C + 111 ZNORM2 = ZNORM+ZNORM + IF (ZNORM .GT. .5) ZNORM2 = 2.-ZNORM2 + ONORM = .5*(1.-(1.-ABS(ZNORM2)**ALPHA)**RALPH) + 112 IF (ZNORM .GT. .5) ONORM = 1.-ONORM + 113 ZL(K) = GLO+DELZ*ONORM + 114 CONTINUE + ZL(NLEV) = BIG + RETURN + 115 ICNST = 1 + RETURN + END + SUBROUTINE GRAY +C +C SUBROUTINE GRAY COLORS HALF-TONE CELL (I,J) WITH INTENSITY INTEN. +C THE ROUTINE ASSUMES 8X8 CELL SIZE ON A VIRTUAL SCREEN 1024X1024. +C + DIMENSION IFOT(16) ,JFOT(16) + DIMENSION WNDW(4) ,VWPRT(4) +CCC DIMENSION MX(16) ,MY(16) + COMMON /HAFTO1/ I ,J ,INTEN + COMMON /HAFTO4/ NPTMAX ,NPOINT ,XPNT(50) ,YPNT(50) + SAVE +C + DATA + 1 IFOT(1),IFOT(2),IFOT(3),IFOT(4),IFOT(5),IFOT(6),IFOT(7),IFOT(8)/ + 2 1, 5, 1, 5, 3, 7, 3, 7 / + DATA + 1 IFOT(9),IFOT(10),IFOT(11),IFOT(12),IFOT(13),IFOT(14),IFOT(15)/ + 2 3, 7, 3, 7, 1, 5, 1/, + 3 IFOT(16)/ + 4 5 / +C + DATA + 1 JFOT(1),JFOT(2),JFOT(3),JFOT(4),JFOT(5),JFOT(6),JFOT(7),JFOT(8)/ + 2 1, 5, 5, 1, 3, 7, 7, 3 / + DATA + 1 JFOT(9),JFOT(10),JFOT(11),JFOT(12),JFOT(13),JFOT(14),JFOT(15)/ + 2 1, 5, 5, 1, 3, 7, 7/, + 3 JFOT(16)/ + 4 3 / +C + IF (INTEN) 103,103,101 + 101 I1 = I*8 + J1 = J*8 + IF ((NPOINT+INTEN) .LE.NPTMAX) GO TO 1015 + CALL GQNT(1,IERR,WNDW,VWPRT) + CALL SET(0.,1.,0.,1.,0.,1023.,0.,1023.,1) + CALL POINTS(XPNT,YPNT,NPOINT,0,0) + CALL SET(VWPRT(1),VWPRT(2),VWPRT(3),VWPRT(4), + - WNDW(1),WNDW(2),WNDW(3),WNDW(4),1) + NPOINT = 0 + 1015 DO 102 I2=1,INTEN + NPOINT = NPOINT + 1 + XPNT(NPOINT) = I1+IFOT(I2) + YPNT(NPOINT) = J1+JFOT(I2) + 102 CONTINUE + 103 RETURN + END + SUBROUTINE BOUND (Z,MX,NNX,NNY,SSP) + DIMENSION Z(MX,NNY) ,PX(2) ,PY(2) +C +C BOUND DRAWS A POLYGONAL BOUNDRY AROUND ANY SPECIAL-VALUE AREAS IN Z. +C + SAVE + NX = NNX + NY = NNY +C +C VERTICAL LINES +C + SP = SSP + DO 103 IP1=3,NX + I = IP1-1 + PX(1) = I + PX(2) = I + IM1 = I-1 + DO 102 JP1=2,NY + PY(2) = JP1 + J = JP1-1 + PY(1) = J + KLEFT = 0 + IF (Z(IM1,J).EQ.SP .OR. Z(IM1,JP1).EQ.SP) KLEFT = 1 + KCENT = 0 + IF (Z(I,J).EQ.SP .OR. Z(I,JP1).EQ.SP) KCENT = 1 + KRIGT = 0 + IF (Z(IP1,J).EQ.SP .OR. Z(IP1,JP1).EQ.SP) KRIGT = 1 + JUMP = KLEFT*4+KCENT*2+KRIGT+1 + GO TO (102,101,102,102,101,102,102,102,102),JUMP + 101 CALL GPL (2,PX,PY) + 102 CONTINUE + 103 CONTINUE +C +C HORIZONTAL +C + DO 106 JP1=3,NY + J = JP1-1 + PY(1) = J + PY(2) = J + JM1 = J-1 + DO 105 IP1=2,NX + PX(2) = IP1 + I = IP1-1 + PX(1) = I + KLOWR = 0 + IF (Z(I,JM1).EQ.SP .OR. Z(IP1,JM1).EQ.SP) KLOWR = 1 + KCENT = 0 + IF (Z(I,J).EQ.SP .OR. Z(IP1,J).EQ.SP) KCENT = 1 + KUPER = 0 + IF (Z(I,JP1).EQ.SP .OR. Z(IP1,JP1).EQ.SP) KUPER = 1 + JUMP = KLOWR*4+KCENT*2+KUPER+1 + GO TO (105,104,105,105,104,105,105,105,105),JUMP + 104 CALL GPL (2,PX,PY) + 105 CONTINUE + 106 CONTINUE + RETURN + END + SUBROUTINE EZHFTN (Z,M,N) +C + DIMENSION Z(M,N) + SAVE +C +C HALF-TONE PICTURE VIA SHORTEST ARGUMENT LIST. +C ASSUMPTIONS-- +C ALL OF THE ARRAY IS TO BE DRAWN, +C LOWEST VALUE IN Z WILL BE AT LOWEST INTENSITY ON READER/PRINTER +C OUTPUT, HIGHEST VALUE IN Z WILL BE AT HIGHEST INTENSITY, VALUES IN +C BETWEEN WILL APPEAR LINEARLY SPACED, MAXIMUM POSSIBLE NUMBER OF +C INTENSITIES ARE USED, THE PICTURE WILL HAVE A PERIMETER DRAWN, +C FRAME WILL BE CALLED AFTER THE PICTURE IS DRAWN, Z IS FILLED WITH +C NUMBERS THAT SHOULD BE USED (NO UNKNOWN VALUES). +C IF THESE CONDITIONS ARE NOT MET, USE HAFTON. +C EZHFTN ARGUMENTS-- +C Z 2 DIMENSIONAL ARRAY TO BE USED TO GENERATE A HALF-TONE PLOT. +C M FIRST DIMENSION OF Z. +C N SECOND DIMENSION OF Z. +C + DATA FLO,HI,NLEV,NOPT,NPRM,ISPV,SPV/0.0,0.0,0,0,0,0,0.0/ +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','HAFTON','EZHFTN','VERSION 1') +C + CALL HAFTON (Z,M,M,N,FLO,HI,NLEV,NOPT,NPRM,ISPV,SPV) +C +C +NOAO - EZHFTN no longer calls frame. +C CALL FRAME +C -NOAO + RETURN + END +C +C----------------------------------------------------------------------- +C +C REVISION HISTORY--- +C +C JULY 1984 CONVERTED TO FORTAN 77 AND GKS +C +C MARCH 1983 INSTITUTED BUFFERING OF POINTS WITHIN ROUTINE GRAY, +C WHICH DRAMATICALLY REDUCES SIZE OF OUTPUT PLOT CODE, +C METACODE. THIS IN TURN GENERALLY IMPROVES THROUGHPUT +C OF METACODE INTERPRETERS. +C +C FEBRUARY 1979 MODIFIED CODE TO CONFORM TO FORTRAN 66 STANDARD +C +C JANUARY 1978 DELETED REFERENCES TO THE *COSY CARDS AND +C ADDED REVISION HISTORY +C +C----------------------------------------------------------------------- +C diff --git a/sys/gio/ncarutil/hfinit.f b/sys/gio/ncarutil/hfinit.f new file mode 100644 index 00000000..e64207eb --- /dev/null +++ b/sys/gio/ncarutil/hfinit.f @@ -0,0 +1,229 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +c +noao: block data hfinit changed to run time initialization +c BLOCKDATA HFINIT + subroutine hfinit +C + COMMON /HAFTO3/ XLT ,YBT ,SIDE ,EXT, + 1 IOFFM ,ALPH ,MXLEV ,NCRTG , + 2 NCRTF ,IL(135) + COMMON /HAFTO4/ NPTMAX ,NPOINT ,XPNT(50) ,YPNT(50) +C +C INITIALIZATION OF INTERNAL PARAMETERS +C +c DATA XLT, YBT,SIDE,EXT,IOFFM,ALPH,MXLEV,NCRTG,NCRTF/ +c 1 0.102,0.102,.805,.25, 0, 1.6, 16, 8, 1024/ +c +c +noao: following flag added to prevent initializing more than once + logical first + SAVE + data first /.true./ + if (.not. first) then + return + endif + first = .false. + +c +noao: call to utilbd added to make sure those parameters set by getusv +c have been set before they are retrieved. + call utilbd +c -noao + XLT = 0.102 + YBT = 0.102 + SIDE = .805 + EXT = .25 + IOFFM = 0 + ALPH = 1.6 + MXLEV = 16 + NCRTG = 8 + NCRTF = 1024 +c +c DATA IL(1),IL(2),IL(3),IL(4),IL(5),IL(6),IL(7),IL(8),IL(9),IL(10), +c 1IL(11),IL(12),IL(13),IL(14),IL(15),IL(16),IL(17),IL(18),IL(19), +c 2IL(20),IL(21),IL(22),IL(23),IL(24),IL(25),IL(26),IL(27),IL(28), +c 3IL(29),IL(30),IL(31),IL(32),IL(33),IL(34),IL(35),IL(36),IL(37), +c 4IL(38),IL(39),IL(40),IL(41),IL(42),IL(43),IL(44)/ +c 5 5,11, +c 6 4, 8,12, +c 7 3, 6,10,13, +c 8 2, 5, 8,11,14, +c 9 1, 4, 7, 9,12,15, +c + 1, 4, 6, 8,10,12,15, +c 1 1, 3, 5, 7, 9,11,13,15, +c 2 1, 3, 4, 6, 8, 10, 12, 13, 15/ +c + IL(1) = 5 + IL(2) = 11 + IL(3) = 4 + IL(4) = 8 + IL(5) = 12 + IL(6) = 3 + IL(7) = 6 + IL(8) = 10 + IL(9) = 13 + IL(10) = 2 + IL(11) = 5 + IL(12) = 8 + IL(13) = 11 + IL(14) = 14 + IL(15) = 1 + IL(16) = 4 + IL(17) = 7 + IL(18) = 9 + IL(19) = 12 + IL(20) = 15 + IL(21) = 1 + IL(22) = 4 + IL(23) = 6 + IL(24) = 8 + IL(25) = 10 + IL(26) = 12 + IL(27) = 15 + IL(28) = 1 + IL(29) = 3 + IL(30) = 5 + IL(31) = 7 + IL(32) = 9 + IL(33) = 11 + IL(34) = 13 + IL(35) = 15 + IL(36) = 1 + IL(37) = 3 + IL(38) = 4 + IL(39) = 6 + IL(40) = 8 + IL(41) = 10 + IL(42) = 12 + IL(43) = 13 + IL(44) = 15 +c +c DATA IL(45),IL(46), +c 1IL(47),IL(48),IL(49),IL(50),IL(51),IL(52),IL(53),IL(54),IL(55), +c 2IL(56),IL(57),IL(58),IL(59),IL(60),IL(61),IL(62),IL(63),IL(64), +c 3IL(65),IL(66),IL(67),IL(68),IL(69),IL(70),IL(71),IL(72),IL(73), +c 4IL(74),IL(75),IL(76),IL(77),IL(78),IL(79),IL(80),IL(81),IL(82), +c 5IL(83),IL(84),IL(85),IL(86),IL(87),IL(88),IL(89),IL(90)/ +c 6 1, 3, 4, 6, 7, 9,10,12,13,15, +c 7 1, 2, 3, 5, 6, 8,10,11,13,14,15, +c 8 1, 2, 3, 5, 6, 7, 9,10,11,13,14,15, +c 9 1, 2, 3, 4, 6, 7, 8, 9, 10, 12, 13, 14, 15/ +c + IL(45) = 1 + IL(46) = 3 + IL(47) = 4 + IL(48) = 6 + IL(49) = 7 + IL(50) = 9 + IL(51) = 10 + IL(52) = 12 + IL(53) = 13 + IL(54) = 15 + IL(55) = 1 + IL(56) = 2 + IL(57) = 3 + IL(58) = 5 + IL(59) = 6 + IL(60) = 8 + IL(61) = 10 + IL(62) = 11 + IL(63) = 13 + IL(64) = 14 + IL(65) = 15 + IL(66) = 1 + IL(67) = 2 + IL(68) = 3 + IL(69) = 5 + IL(70) = 6 + IL(71) = 7 + IL(72) = 9 + IL(73) = 10 + IL(74) = 11 + IL(75) = 13 + IL(76) = 14 + IL(77) = 15 + IL(78) = 1 + IL(79) = 2 + IL(80) = 3 + IL(81) = 4 + IL(82) = 6 + IL(83) = 7 + IL(84) = 8 + IL(85) = 9 + IL(86) = 10 + IL(87) = 12 + IL(88) = 13 + IL(89) = 14 + IL(90) = 15 +c +c DATA IL(91), +c 1IL(92),IL(93),IL(94),IL(95),IL(96),IL(97),IL(98),IL(99),IL(100), +c 2IL(101),IL(102),IL(103),IL(104),IL(105),IL(106),IL(107),IL(108), +c 3IL(109),IL(110),IL(111),IL(112),IL(113),IL(114),IL(115),IL(116), +c 4IL(117),IL(118),IL(119),IL(120),IL(121),IL(122),IL(123),IL(124), +c 5IL(125),IL(126),IL(127),IL(128),IL(129),IL(130),IL(131),IL(132), +c 6IL(133),IL(134),IL(135)/ +c 7 1, 2, 3, 4, 5, 6, 7, 9,10,11,12,13,14,15, +c 8 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15, +c 9 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15/ +c + IL(91) = 1 + IL(92) = 2 + IL(93) = 3 + IL(94) = 4 + IL(95) = 5 + IL(96) = 6 + IL(97) = 7 + IL(98) = 9 + IL(99) = 10 + IL(100) = 11 + IL(101) = 12 + IL(102) = 13 + IL(103) = 14 + IL(104) = 15 + IL(105) = 1 + IL(106) = 2 + IL(107) = 3 + IL(108) = 4 + IL(109) = 5 + IL(110) = 6 + IL(111) = 7 + IL(112) = 8 + IL(113) = 9 + IL(114) = 10 + IL(115) = 11 + IL(116) = 12 + IL(117) = 13 + IL(118) = 14 + IL(119) = 15 + IL(120) = 0 + IL(121) = 1 + IL(122) = 2 + IL(123) = 3 + IL(124) = 4 + IL(125) = 5 + IL(126) = 6 + IL(127) = 7 + IL(128) = 8 + IL(129) = 9 + IL(130) = 10 + IL(131) = 11 + IL(132) = 12 + IL(133) = 13 + IL(134) = 14 + IL(135) = 15 +c +C SIZE OF THE COORDINATE BUFFERING ARRAYS FOR POINTS BUFFERING. +c DATA NPTMAX/50/ + NPTMAX = 50 +c -noao + END diff --git a/sys/gio/ncarutil/isosrb.f b/sys/gio/ncarutil/isosrb.f new file mode 100644 index 00000000..5c1481a0 --- /dev/null +++ b/sys/gio/ncarutil/isosrb.f @@ -0,0 +1,98 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +c +noao: blockdata isosrb changed to run time initialization subroutine + subroutine isosrb +c BLOCKDATA ISOSRB +C +C BLOCK DATA +C + COMMON /ISOSR2/ LX ,NX ,NY ,ISCR(8,128), + 1 ISCA(8,128) + COMMON /ISOSR4/ RX ,RY + COMMON /ISOSR5/ NBPW ,MASK(16) ,GENDON + LOGICAL GENDON + COMMON /ISOSR6/ IX ,IY ,IDX ,IDY, + 1 IS ,ISS ,NP ,CV, + 2 INX(8) ,INY(8) ,IR(500) ,NR + COMMON /ISOSR7/ IENTRY ,IONES + COMMON /ISOSR8/ NMASK(16) ,IXOLD ,IYOLD ,IBTOLD, + 1 HBFLAG ,IOSLSN ,LRLX ,IFSX, + 2 IFSY ,FIRST ,IYDIR ,IHX, + 3 IHB ,IHS ,IHV ,IVOLD, + 4 IVAL ,IHRX ,YCHANG ,ITPD, + 5 IHF + COMMON /ISOSR9/ BIG ,IXBIT + COMMON /TEMPR/ RZERO + LOGICAL YCHANG ,HBFLAG ,FIRST ,IHF +C + logical first1 + SAVE + data first1 /.true./ + if (.not. first1) then + return + endif + first1 = .false. +c +c DATA LX,NX,NY/8,128,128/ + LX = 8 + NX = 128 + NY = 128 +c +c DATA INX(1),INX(2),INX(3),INX(4),INX(5),INX(6),INX(7),INX(8)/ +c 1 -1 , -1 , 0 , 1 , 1 , 1 , 0 , -1 / + INX(1) = -1 + INX(2) = -1 + INX(3) = 0 + INX(4) = 1 + INX(5) = 1 + INX(6) = 1 + INX(7) = 0 + INX(8) = -1 +c +c DATA INY(1),INY(2),INY(3),INY(4),INY(5),INY(6),INY(7),INY(8)/ +c 1 0 , 1 , 1 , 1 , 0 , -1 , -1 , -1 / + INY(1) = 0 + INY(2) = 1 + INY(3) = 1 + INY(4) = 1 + INY(5) = 0 + INY(6) = -1 + INY(7) = -1 + INY(8) = -1 +c +c DATA NR/500/ + NR = 500 +c +c DATA NBPW/16/ + NBPW = 16 +c +c DATA IHF/.FALSE./ + IHF = .FALSE. +C +c DATA GENDON /.FALSE./ + GENDON = .FALSE. +c +c DATA RZERO/0./ + RZERO = 0. +C +C +C RX = (NX-1)/SCREEN WIDTH FROM TRN32I +C RY = (NY-1)/SCREEN HEIGHT FROM TRN32I +C +c DATA RX,RY/.00389,.00389/ + RX = .00389 + RY = .00389 +C +c -noao + END diff --git a/sys/gio/ncarutil/isosrf.f b/sys/gio/ncarutil/isosrf.f new file mode 100644 index 00000000..7be532ee --- /dev/null +++ b/sys/gio/ncarutil/isosrf.f @@ -0,0 +1,1696 @@ + SUBROUTINE ISOSRF (T,LU,MU,LV,MV,MW,EYE,MUVWP2,SLAB,TISO,IFLAG) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C DIMENSION OF T(LU,LV,MW),EYE(3),SLAB(MUVWP2,MUVWP2) +C ARGUMENTS +C +C LATEST REVISION DECEMBER 1984 +C +C PURPOSE ISOSRF DRAWS AN APPROXIMATION OF AN ISO-VALUED +C SURFACE FROM A THREE-DIMENSIONAL ARRAY WITH +C HIDDEN LINES REMOVED. +C +C USAGE IF THE FOLLOWING ASSUMPTIONS ARE MET, USE +C +C CALL EZISOS (T,MU,MV,MW,EYE,SLAB,TISO) +C +C ASSUMPTIONS: +C -- ALL OF THE T ARRAY IS TO BE USED. +C -- IFLAG IS CHOSEN INTERNALLY. +C -- FRAME IS CALLED BY EZISOS. +C +C IF THE ASSUMPTIONS ARE NOT MET, USE +C +C CALL ISOSRF (T,LU,MU,LV,MV,MW,EYE,MUVWP2, +C SLAB,TISO,IFLAG) +C +C ARGUMENTS +C +C ON INPUT T +C THREE DIMENSIONAL ARRAY OF DATA THAT DEFINES +C THE ISO-VALUED SURFACE. +C +C LU +C FIRST DIMENSION OF T IN THE CALLING PROGRAM. +C +C MU +C THE NUMBER OF DATA VALUES OF T TO BE +C PROCESSED IN THE U DIRECTION (THE FIRST +C SUBSCRIPT DIRECTION). WHEN PROCESSING THE +C ENTIRE ARRAY, LU = MU (AND LV = MV). +C +C LV +C SECOND DIMENSION OF T IN THE CALLING PROGRAM. +C +C MV +C THE NUMBER OF DATA VALUES OF T TO BE +C PROCESSED IN THE V DIRECTION (THE SECOND +C SUBSCRIPT DIRECTION). +C +C MV +C THE NUMBER OF DATA VALUES OF T TO BE +C PROCESSED IN THE W DIRECTION (THE THIRD +C SUBSCRIPT DIRECTION). +C +C EYE +C THE POSITION OF THE EYE IN THREE-SPACE. T IS +C CONSIDERED TO BE IN A BOX WITH OPPOSITE +C CORNERS (1,1,1) AND (MU,MV,MW). THE EYE IS +C AT (EYE(1),EYE(2),EYE(3)), WHICH MUST BE +C OUTSIDE THE BOX THAT CONTAINS T. WHILE GAINING +C EXPERIENCE WITH THE ROUTINE, A GOOD CHOICE +C FOR EYE MIGHT BE (5.0*MU,3.5*MV,2.0*MW). +C +C MUVWP2 +C THE MAXIMUM OF (MU,MV,MW)+2; THAT IS, +C MUVWP2 = MAX(MU,MV,MW)+2). +C +C SLAB +C A WORK SPACE USED FOR INTERNAL STORAGE. SLAB +C MUST BE AT LEAST MUVWP2*MUVWP2 WORDS LONG. +C +C TISO +C THE ISO-VALUE USED TO DEFINE THE SURFACE. THE +C SURFACE DRAWN WILL SEPARATE VOLUMES OF T THAT +C HAVE VALUES GREATER THAN OR EQUAL TO TISO FROM +C VOLUMES OF T THAT HAVE VALUES LESS THAN TISO. +C +C IFLAG +C THIS FLAG SERVES TWO PURPOSES. +C . FIRST, THE ABSOLUTE VALUE OF IFLAG +C DETERMINES WHICH TYPES OF LINES ARE DRAWN +C TO APPROXIMATE THE SURFACE. THREE TYPES +C OF LINES ARE CONSIDERED: LINES OF +C CONSTANT U, LINES OF CONSTANT V AND LINES +C OF CONSTANT W. THE FOLLOWING TABLE LISTS +C THE TYPES OF LINES DRAWN. +C +C LINES OF CONSTANT +C ----------------- +C IABS(IFLAG) U V W +C ----------- --- --- --- +C 1 NO NO YES +C 2 NO YES NO +C 3 NO YES YES +C 4 YES NO NO +C 5 YES NO YES +C 6 YES YES NO +C 0, 7 OR MORE YES YES YES +C +C . SECOND, THE SIGN OF IFLAG DETERMINES WHAT +C IS INSIDE AND WHAT IS OUTSIDE, HENCE, +C WHICH LINES ARE VISIBLE AND WHAT IS DONE +C AT THE BOUNDARY OF T. FOR IFLAG: +C +C POSITIVE T VALUES GREATER THAN TISO ARE +C ASSUMED TO BE INSIDE THE SOLID +C FORMED BY THE DRAWN SURFACE. +C NEGATIVE T VALUES LESS THAN TISO ARE +C ASSUMED TO BE INSIDE THE SOLID +C FORMED BY THE DRAWN SURFACE. +C IF THE ALGORITHM DRAWS A CUBE, REVERSE THE +C SIGN OF IFLAG. +C +C ON OUTPUT T,LU,MU,LV,MV,MW,EYE,MUVWP2,TISO AND IFLAG ARE +C UNCHANGED. SLAB HAS BEEN WRITTEN IN. +C +C NOTE . THIS ROUTINE IS FOR LOWER RESOLUTION ARRAYS +C THAN ISOSRFHR. 40 BY 40 BY 40 IS A +C PRACTICAL MAXIMUM. +C . TRANSFORMATIONS CAN BE ACHIEVED BY +C ADJUSTING SCALING STATEMENT FUNCTIONS IN +C ISOSRF, SET3D AND TR32. +C . THE HIDDEN-LINE ALGORITHM IS NOT EXACT, SO +C VISIBILITY ERRORS CAN OCCUR. +C . THREE-DIMENSIONAL PERSPECTIVE CHARACTER +C LABELING OF ISOSRF IS POSSIBLE BY USING +C THE UTILITY PWRZI. FOR A DESCRIPTION OF +C THE USAGE, SEE THE PWRZI DOCUMENTATION. +C +C ENTRY POINTS ISOSRF, EZISOS, SET3D, TRN32I, ZEROSC, +C STCNTR, DRCNTR, TR32, FRSTS, KURV1S, KURV2S, +C FRSTC, FILLIN, DRAWI, ISOSRB, MMASK +C +C COMMON BLOCKS ISOSR1, ISOSR2, ISOSR3, ISOSR4, ISOSR5, +C ISOSR6, ISOSR7, ISOSR8, ISOSR9, TEMPR, +C PWRZ1I +C +C REQUIRED LIBRARY THE ERPRT77 PACKAGE AND THE SPPS. +C ROUTINES +C +C I/O PLOTS SURFACE +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN 77 +C +C HISTORY DEVELOPED FOR USERS OF ISOSRFHR WITH SMALLER +C ARRAYS. +C +C ALGORITHM CUTS THROUGH THE THREE-DIMENSIONAL ARRAY ARE +C CONTOURED WITH A SMOOTHING CONTOURER WHICH ALSO +C MARKS A MODEL OF THE PLOTTING PLANE. INTERIORS +C OF BOUNDARIES ARE FILLED IN AND THE RESULT IS +C .OR.ED INTO ANOTHER MODEL OF THE PLOTTING PLANE +C WHICH IS USED TO TEST SUBSEQUENT CONTOUR LINES +C FOR VISIBILITY. +C +C TIMING VARIES WIDELY WITH SIZE OF T AND THE VOLUME OF +C THE SPACE ENCLOSED BY THE SURFACE DRAWN. +C +C **NOTE** SPACE REQUIREMENTS CAN BE REDUCED BY +C CHANGING THE SIZE OF THE ARRAYS ISCR, ISCA +C (FOUND IN COMMON ISOSR2), MASK(FOUND IN +C COMMON ISOSR5) AND THE VARIABLE NBPW +C (COMMON ISOSR5). +C ISCR AND ISCA NEED 128X128 BITS. SO ON A +C 64 BIT MACHINE ISCR, ISCA CAN BE +C DIMENSIONED TO (2,128). NBPW SET IN +C SUBROUTINE MMASK SHOULD CONTAIN THE +C NUMBER OF BITS PER WORD YOU WISH TO +C UTILIZE. +C THE DIMENSION OF MASK AND NMASK SHOULD +C EQUAL THE VALUE OF NBPW. +C LS SHOULD BE SET TO THE FIRST DIMENSION +C OF ISCA AND ISCR. +C +C EXAMPLES: +C ON A 60 BIT MACHINE: +C DIMENSION ISCA(4,128), ISCR(4,128) +C DIMENSION MASK(32) +C NBPW = 32 +C ON A 64 BIT MACHINE: +C DIMENSION ISCA(2,128), ISCR(2,128) +C DIMENSION MASK(64) +C NBPW = 64 +C +C INTERNAL PARAMETERS NAME DEFAULT FUNCTION +C ---- ------- -------- +C IREF 1 FLAG TO CONTROL DRAWING OF AXES. +C .IREF=NONZERO DRAW AXES. +C .IREF=ZERO DO NOT DRAW AXES. +C +C + SAVE + DIMENSION T(LU,LV,MW),EYE(3) ,SLAB(MUVWP2,MUVWP2) +C + COMMON /ISOSR1/ ISLBT ,U ,V ,W + COMMON /ISOSR2/ LX ,NX ,NY ,ISCR(8,128), + 1 ISCA(8,128) + COMMON /ISOSR3/ ISCALE ,XMIN ,XMAX ,YMIN , + 1 YMAX ,BIGD ,R0 + COMMON /ISOSR4/ RX ,RY + COMMON /ISOSR5/ NBPW ,MASK(16) ,GENDON + COMMON /ISOSR6/ IX ,IY ,IDX ,IDY , + 1 IS ,ISS ,NP ,CV , + 2 INX(8) ,INY(8) ,IR(500) ,NR + COMMON /ISOSR7/ IENTRY ,IONES + COMMON /ISOSR9/ BIG ,IXBIT +C + LOGICAL GENDON + DATA IREF/1/ +C + AVE(A,B) = (A+B)*.5 +C +C A.S.F. FOR SCALING +C + SU(UTEMP) = UTEMP + SV(VTEMP) = VTEMP + SW(WTEMP) = WTEMP +C +C +NOAO - Blockdata ISOSRB rewritten as run time initialization +C EXTERNAL ISOSRB + call isosrb +C -NOAO +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('NSSL','ISOSRF','ISOSRF','VERSION 12') + NERR = 0 +C +C 3-SPACE U,V,W,IU,IV,IW,ETC +C 2-SPACE X,Y,IX,IY,ETC +C +C INITIALIZE MASKS +C + IF (.NOT.GENDON) CALL MMASK +C +C SET SHIFT VALUE FOR X,Y PACKING +C +C IF YOUR MACHINE HAS MORE THAN 16 BITS PER WORD THIS CHECK MAY BE +C MODIFIED +C + IF (LU .LE. 256) GO TO 10 + NERR = NERR + 1 + CALL SETER('DIMENSION OF CUBE EXCEEDS 256',NERR,2) + RETURN + 10 DO 20 J=1,30 + IF (LU .LE. 2**(J-1)) GO TO 30 + 20 CONTINUE + 30 IXBIT = J + NU = MU + NUP2 = NU+2 + NV = MV + NVP2 = NV+2 + NW = MW + NWP2 = NW+2 + FNU = NU + FNV = NV + FNW = NW + SU1 = SU(1.) + SV1 = SV(1.) + SW1 = SW(1.) + SUNU = SU(FNU) + SVNV = SV(FNV) + SWNW = SW(FNW) + AVEU = AVE(SU1,SUNU) + AVEV = AVE(SV1,SVNV) + AVEW = AVE(SW1,SWNW) + EYEU = EYE(1) + EYEV = EYE(2) + EYEW = EYE(3) + NUVWP2 = MUVWP2 + TVAL = TISO + NFLAG = IABS(IFLAG) + IF (NFLAG.EQ.0 .OR. NFLAG.GE.8) NFLAG = 7 +C +C SET UP SCALING +C + FACT = -ISIGN(1,IFLAG) + CALL SET3D (EYE,1.,FNU,1.,FNV,1.,FNW) +C +C BOUND LOWER AND LEFT EDGE OF SLAB +C + EDGE = SIGN(BIG,FACT) + DO 40 IUVW=1,NUVWP2 + SLAB(IUVW,1) = EDGE + SLAB(1,IUVW) = EDGE + 40 CONTINUE +C +C SLICES PERPENDICULAR TO U. THAT IS, V W SLICES. T OF CONSTANT U. +C + IF (NFLAG .LT. 4) GO TO 100 + CALL ZEROSC + ISLBT = -1 +C +C BOUND UPPER AND RIGHT EDGE OF SLAB. +C + DO 50 IV=2,NVP2 + SLAB(IV,NWP2) = EDGE + 50 CONTINUE + DO 60 IW=2,NWP2 + SLAB(NVP2,IW) = EDGE + 60 CONTINUE +C +C GO THRU 3-D ARRAY IN U DIRECTION. IUEW=IU EITHER WAY. +C PICK IU BASED ON EYEU. +C + DO 90 IUEW=1,NU + IU = IUEW + IF (EYEU .GT. AVEU) IU = NU+1-IUEW + U = IU +C +C LOAD THIS SLICE OF T INTO SLAB. +C + DO 80 IV=1,NV + DO 70 IW=1,NW + SLAB(IV+1,IW+1) = T(IU,IV,IW) + 70 CONTINUE + 80 CONTINUE +C +C CONTOUR THIS SLAB. +C + CALL STCNTR (SLAB,NUVWP2,NVP2,NWP2,TVAL) +C +C CONSTRUCT VISIBILITY ARRAY. +C + CALL FILLIN + 90 CONTINUE +C +C SLICES PERPENDICULAR TO V. U W SLICES. T OF CONSTANT V. +C + 100 IF (MOD(NFLAG/2,2) .EQ. 0) GO TO 160 + CALL ZEROSC + ISLBT = 0 +C +C BOUND UPPER AND RIGHT EDGE OF SLAB. +C + DO 110 IU=2,NUP2 + SLAB(IU,NWP2) = EDGE + 110 CONTINUE + DO 120 IW=2,NWP2 + SLAB(NUP2,IW) = EDGE + 120 CONTINUE +C +C GO THRU T IN V DIRECTION. IVEW=IV EITHER WAY. +C + DO 150 IVEW=1,NV + IV = IVEW + IF (EYEV .GT. AVEV) IV = NV+1-IVEW + V = IV +C +C LOAD THIS SLICE OF T INTO SLAB. +C + DO 140 IU=1,NU + DO 130 IW=1,NW + SLAB(IU+1,IW+1) = T(IU,IV,IW) + 130 CONTINUE + 140 CONTINUE +C +C CONTOUR THIS SLAB. +C + CALL STCNTR (SLAB,NUVWP2,NUP2,NWP2,TVAL) +C +C CONSTRUCT VISIBILITY ARRAY. +C + CALL FILLIN + 150 CONTINUE +C +C SLICES PERPENDICULAR TO W. U V SLICES. T OF CONSTANT W. +C + 160 IF (MOD(NFLAG,2) .EQ. 0) GO TO 220 + CALL ZEROSC +C + ISLBT = 1 +C +C BOUND UPPER AND RIGHT EDGE OF SLAB. +C + DO 170 IU=2,NUP2 + SLAB(IU,NVP2) = EDGE + 170 CONTINUE + DO 180 IV=2,NVP2 + SLAB(NUP2,IV) = EDGE + 180 CONTINUE +C +C GO THRU T IN W DIRECTION. +C + DO 210 IWEW=1,NW + IW = IWEW + IF (EYEW .GT. AVEW) IW = NW+1-IWEW + W = IW +C +C LOAD THIS SLICE OF T INTO SLAB. +C + DO 200 IU=1,NU + DO 190 IV=1,NV + SLAB(IU+1,IV+1) = T(IU,IV,IW) + 190 CONTINUE + 200 CONTINUE +C +C CONTOUR THIS SLAB. +C + CALL STCNTR (SLAB,NUVWP2,NUP2,NVP2,TVAL) +C +C CONSTRUCT VISIBILITY ARRAY. +C + CALL FILLIN + 210 CONTINUE +C +C DRAW REFERENCE PLANE EDGES AND W AXIS. +C + 220 IF (IREF .EQ. 0) RETURN + CALL TRN32I (SU1,SV1,SW1,XT,YT,DUM,2) + IF (EYEV .LT. SV1) GO TO 240 + CALL FRSTC (IFIX(XT),IFIX(YT),1) + DO 230 IU=2,NU + CALL TRN32I (SU(FLOAT(IU)),SV1,SW1,XT,YT,DUM,2) + CALL FRSTC (IFIX(XT),IFIX(YT),2) + 230 CONTINUE + GO TO 250 + 240 CALL PLOTIT (IFIX(XT),IFIX(YT),0) + CALL TRN32I (SUNU,SV1,SW1,XT,YT,DUM,2) + CALL PLOTIT (IFIX(XT),IFIX(YT),1) + 250 IF (EYEU .GT. SUNU) GO TO 270 + CALL FRSTC (IFIX(XT),IFIX(YT),1) + DO 260 IV=2,NV + CALL TRN32I (SUNU,SV(FLOAT(IV)),SW1,XT,YT,DUM,2) + CALL FRSTC (IFIX(XT),IFIX(YT),2) + 260 CONTINUE + GO TO 280 + 270 CALL PLOTIT (IFIX(XT),IFIX(YT),0) + CALL TRN32I (SUNU,SVNV,SW1,XT,YT,DUM,2) + CALL PLOTIT (IFIX(XT),IFIX(YT),1) + 280 IF (EYEV .GT. SVNV) GO TO 300 + CALL FRSTC (IFIX(XT),IFIX(YT),1) + DO 290 IUOW=2,NU + CALL TRN32I (SU(FLOAT(NU-IUOW+1)),SVNV,SW1,XT,YT,DUM,2) + CALL FRSTC (IFIX(XT),IFIX(YT),2) + 290 CONTINUE + GO TO 310 + 300 CALL PLOTIT (IFIX(XT),IFIX(YT),0) + CALL TRN32I (SU1,SVNV,SW1,XT,YT,DUM,2) + CALL PLOTIT (IFIX(XT),IFIX(YT),1) + 310 IF (EYEU .LT. SU1) GO TO 330 + CALL FRSTC (IFIX(XT),IFIX(YT),1) + DO 320 IVOW=2,NV + CALL TRN32I (SU1,SV(FLOAT(NV-IVOW+1)),SW1,XT,YT,DUM,2) + CALL FRSTC (IFIX(XT),IFIX(YT),2) + 320 CONTINUE + GO TO 340 + 330 CALL PLOTIT (IFIX(XT),IFIX(YT),0) + CALL TRN32I (SU1,SV1,SW1,XT,YT,DUM,2) + CALL PLOTIT (IFIX(XT),IFIX(YT),1) + 340 IF (EYEU.LE.SU1 .OR. EYEV.LE.SV1) GO TO 360 + CALL FRSTC (IFIX(XT),IFIX(YT),1) + DO 350 IW=2,NW + CALL TRN32I (SU1,SV1,SW(FLOAT(IW)),XT,YT,DUM,2) + CALL FRSTC (IFIX(XT),IFIX(YT),2) + 350 CONTINUE +C +NOAO - Plotit buffer needs to be flushed before returning. + call plotit (0, 0, 2) +C -NOAO + RETURN + 360 CALL PLOTIT (IFIX(XT),IFIX(YT),0) + CALL TRN32I (SU1,SV1,SWNW,XT,YT,DUM,2) + CALL PLOTIT (IFIX(XT),IFIX(YT),1) +C +NOAO - Plotit buffer needs to be flushed before returning. + call plotit (0, 0, 2) +C -NOAO + RETURN + END + SUBROUTINE EZISOS (T,MU,MV,MW,EYE,SLAB,TISO) +C + SAVE + DIMENSION T(MU,MV,MW),EYE(3) +C + DATA ANG,PI/.35,3.141592/ +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('NSSL','ISOSRF','EZISOS','VERSION 12') +C +C ARGUMENTS DESCRIBED IN ISOSRF +C +C PICK TYPES OF LINES TO DRAW +C + NU = MU + NV = MV + NW = MW + TVAL = TISO + MAX = MAX0(NU,NV,NW)+2 + ATU = NU/2 + ATV = NV/2 + ATW = NW/2 + EYEU = EYE(1) + EYEV = EYE(2) + EYEW = EYE(3) + RU = EYEU-ATU + RV = EYEV-ATV + RW = EYEW-ATW + RU2 = RU*RU + RV2 = RV*RV + RW2 = RW*RW + DU = SQRT(RV2+RW2) + DV = SQRT(RU2+RW2) + DW = SQRT(RU2+RV2) + DR = 1./SQRT(RU2+RV2+RW2) +C +C COMPUTE THE ARCCOSINE +C + TU = DU*DR + ANGU = ATAN(ABS(SQRT(1.-TU*TU)/TU)) + IF (TU .LE. 0.) ANGU = PI-ANGU + TV = DV*DR + ANGV = ATAN(ABS(SQRT(1.-TV*TV)/TV)) + IF (TV .LE. 0.) ANGV = PI-ANGV + TW = DW*DR + ANGW = ATAN(ABS(SQRT(1.-TW*TW)/TW)) + IF (TW .LE. 0.) ANGW = PI-ANGW +C +C BREAK POINT IS ABOUT 20 DEGREES OR ABOUT .35 RADIANS +C + IFLAG = 0 + IF (ANGU .GT. ANG) IFLAG = IFLAG+4 + IF (ANGV .GT. ANG) IFLAG = IFLAG+2 + IF (ANGW .GT. ANG) IFLAG = IFLAG+1 +C +C FIND SIGN OF IFLAG +C + ICNT = 0 + IF (ABS(RU) .LE. ATU) GO TO 30 + IU = 1 + IF (EYEU .GT. ATU) IU = NU + DO 20 IW=1,NW + DO 10 IV=1,NV + IF (T(IU,IV,IW) .GT. TVAL) ICNT = ICNT-2 + ICNT = ICNT+1 + 10 CONTINUE + 20 CONTINUE + 30 IF (ABS(RV) .LE. ATV) GO TO 60 + IV = 1 + IF (EYEV .GT. ATV) IV = NV + DO 50 IW=1,NW + DO 40 IU=1,NU + IF (T(IU,IV,IW) .GT. TVAL) ICNT = ICNT-2 + ICNT = ICNT+1 + 40 CONTINUE + 50 CONTINUE + 60 IF (ABS(RW) .LE. ATW) GO TO 90 + IW = 1 + IF (EYEW .GT. ATW) IW = NW + DO 80 IV=1,NV + DO 70 IU=1,NU + IF (T(IU,IV,IW) .GT. TVAL) ICNT = ICNT-2 + ICNT = ICNT+1 + 70 CONTINUE + 80 CONTINUE + 90 IFLAG = ISIGN(IFLAG,ICNT) + CALL ISOSRF (T,NU,NU,NV,NV,NW,EYE,MAX,SLAB,TVAL,IFLAG) +C +NOAO - Call to frame is suppressed. +C CALL FRAME +C -NOAO + RETURN + END + SUBROUTINE SET3D (EYE,ULO,UHI,VLO,VHI,WLO,WHI) + SAVE + COMMON /TEMPR/ RZERO +C + DIMENSION EYE(3) +C + COMMON /ISOSR3/ ISCALE ,XMIN ,XMAX ,YMIN , + 1 YMAX ,BIGD ,R0 + COMMON /PWRZ1I/ UUMIN ,UUMAX ,VVMIN ,VVMAX , + 1 WWMIN ,WWMAX ,DELCRT ,EYEU , + 2 EYEV ,EYEW +C +C + AVE(A,B) = (A+B)*.5 +C +C A.S.F. FOR SCALING +C + SU(UTEMP) = UTEMP + SV(VTEMP) = VTEMP + SW(WTEMP) = WTEMP +C +C CONSTANTS FOR PWRZ +C + UUMIN = ULO + UUMAX = UHI + VVMIN = VLO + VVMAX = VHI + WWMIN = WLO + WWMAX = WHI + EYEU = EYE(1) + EYEV = EYE(2) + EYEW = EYE(3) +C +C FIND CORNERS IN 2-SPACE FOR 3-SPACE BOX CONTAINING OBJECT +C + ISCALE = 0 + ATU = AVE(SU(UUMIN),SU(UUMAX)) + ATV = AVE(SV(VVMIN),SV(VVMAX)) + ATW = AVE(SW(WWMIN),SW(WWMAX)) + BIGD = 0. + IF (RZERO .LE. 0.) GO TO 10 +C +C RELETIVE SIZE FEATURE IN USE. +C GENERATE EYE POSITION THAT MAKES BOX HAVE MAXIMUM PROJECTED SIZE. +C + ALPHA = -(VVMIN-ATV)/(UUMIN-ATU) + VVEYE = -RZERO/SQRT(1.+ALPHA*ALPHA) + UUEYE = VVEYE*ALPHA + VVEYE = VVEYE+ATV + UUEYE = UUEYE+ATU + WWEYE = ATW + CALL TRN32I (ATU,ATV,ATW,UUEYE,VVEYE,WWEYE,1) + CALL TRN32I (UUMIN,VVMIN,ATW,XMIN,DUMM,DUMM,2) + CALL TRN32I (UUMAX,VVMIN,WWMIN,DUMM,YMIN,DUMM,2) + CALL TRN32I (UUMAX,VVMAX,ATW,XMAX,DUMM,DUMM,2) + CALL TRN32I (UUMAX,VVMIN,WWMAX,DUMM,YMAX,DUMM,2) + BIGD = SQRT((UUMAX-UUMIN)**2+(VVMAX-VVMIN)**2+(WWMAX-WWMIN)**2)*.5 + R0 = RZERO + GO TO 20 + 10 CALL TRN32I (ATU,ATV,ATW,EYE(1),EYE(2),EYE(3),1) + CALL TRN32I (SU(UUMIN),SV(VVMIN),SW(WWMIN),X1,Y1,DUM,2) + CALL TRN32I (SU(UUMIN),SV(VVMIN),SW(WWMAX),X2,Y2,DUM,2) + CALL TRN32I (SU(UUMIN),SV(VVMAX),SW(WWMIN),X3,Y3,DUM,2) + CALL TRN32I (SU(UUMIN),SV(VVMAX),SW(WWMAX),X4,Y4,DUM,2) + CALL TRN32I (SU(UUMAX),SV(VVMIN),SW(WWMIN),X5,Y5,DUM,2) + CALL TRN32I (SU(UUMAX),SV(VVMIN),SW(WWMAX),X6,Y6,DUM,2) + CALL TRN32I (SU(UUMAX),SV(VVMAX),SW(WWMIN),X7,Y7,DUM,2) + CALL TRN32I (SU(UUMAX),SV(VVMAX),SW(WWMAX),X8,Y8,DUM,2) + XMIN = AMIN1(X1,X2,X3,X4,X5,X6,X7,X8) + XMAX = AMAX1(X1,X2,X3,X4,X5,X6,X7,X8) + YMIN = AMIN1(Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8) + YMAX = AMAX1(Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8) +C +C ADD RIGHT AMOUNT TO KEEP PICTURE SQUARE +C + 20 WIDTH = XMAX-XMIN + HIGHT = YMAX-YMIN + DIF = .5*(WIDTH-HIGHT) + IF (DIF) 30, 50, 40 + 30 XMIN = XMIN+DIF + XMAX = XMAX-DIF + GO TO 50 + 40 YMIN = YMIN-DIF + YMAX = YMAX+DIF + 50 ISCALE = 1 + CALL TRN32I (ATU,ATV,ATW,EYE(1),EYE(2),EYE(3),1) + RETURN + END + SUBROUTINE TRN32I (U,V,W,XT,YT,ZT,IENT) +C +C THIS ROUTINE IMPLEMENTS THE 3-SPACE TO 2-SPACE TRANSFOR- +C MATION BY KUBER, SZABO AND GIULIERI, THE PERSPECTIVE +C REPRESENTATION OF FUNCTIONS OF TWO VARIABLES. J. ACM 15, +C 2, 193-204,1968. +C ARGUMENTS FOR SET +C U,V,W ARE THE 3-SPACE COORDINATES OF THE INTERSECTION +C OF THE LINE OF SIGHT AND THE IMAGE PLANE. THIS +C POINT CAN BE THOUGHT OF AS THE POINT LOOKED AT. +C XT,YT,ZT ARE THE 3-SPACE COORDINATES OF THE EYE POSITION. +C +C TRN32 ARGUMENTS +C U,V,W ARE THE 3-SPACE COORDINATES OF A POINT TO BE +C TRANSFORMED. +C XT,YT THE RESULTS OF THE 3-SPACE TO 2-SPACE TRANSFOR- +C MATION. WHEN ISCALE=0, XT AND YT ANR IN THE SAME +C UNITS AS U,V, AND W. WHEN ISCALE'0, XT AND YT +C ARE IN PLOTTER COORDINATES. +C ZT NOT USED. +C + SAVE + COMMON /PWRZ1I/ UUMIN ,UUMAX ,VVMIN ,VVMAX , + 1 WWMIN ,WWMAX ,DELCRT ,EYEU , + 2 EYEV ,EYEW + COMMON /ISOSR3/ ISCALE ,XMIN ,XMAX ,YMIN , + 1 YMAX ,BIGD ,R0 +C +C RANGE OF PLOTTER COORDINATES +C +C +C WARNING +C IF PLOTTER MAXIMUM VALUE RANGES (IN X OR Y DIRECTION) FALL BELOW +C 101, THEN CHANGES MUST BE MADE IN SUBROUTINE FRSTC. THE REQUIRED +C CHANGES ARE MARKED BY WARNING COMMENTS IN FRSTC. + DATA NLX,NBY,NRX,NTY/10,10,32760,32760/ + DATA PI/3.1411592/ +C +C STORE THE PARAMETERS OF THE SET CALL FOR USE +C WITH THE TRANSLATE CALL +C +C DECIDE IF SET OR TRANSLATE CALL +C + IF (IENT .NE. 1) GO TO 50 + AU = U + AV = V + AW = W + EU = XT + EV = YT + EW = ZT +C +C +C +C +C + DU = AU-EU + DV = AV-EV + DW = AW-EW + D = SQRT(DU*DU+DV*DV+DW*DW) + COSAL = DU/D + COSBE = DV/D + COSGA = DW/D +C +C COMPUTE THE ARCCOSINE +C + AL = ATAN(ABS(SQRT(1.-COSAL*COSAL)/COSAL)) + IF (COSAL .LE. 0.) AL = PI-AL + BE = ATAN(ABS(SQRT(1.-COSBE*COSBE)/COSBE)) + IF (COSBE .LE. 0.) BE = PI-BE + GA = ATAN(ABS(SQRT(1.-COSGA*COSGA)/COSGA)) + IF (COSGA .LE. 0.) GA = PI-GA + SINGA = SIN(GA) +C +C THE 3-SPACE POINT LOOKED AT IS TRANSFORMED INTO (0,0) OF +C THE 2-SPACE. THE 3-SPACE W AXIS IS TRANSFORMED INTO THE +C 2-SPACE Y AXIS. IF THE LINE OF SIGHT IS CLOSE TO PARALLEL +C TO THE 3-SPACE W AXIS, THE 3-SPACE V AXIS IS CHOSEN (IN- +C STEAD OF THE 3-SPACE W AXIS) TO BE TRANSFORMED INTO THE +C 2-SPACE Y AXIS. +C + ASSIGN 90 TO JDONE + IF (ISCALE) 10, 30, 10 + 10 X0 = XMIN + Y0 = YMIN + X1 = NLX + Y1 = NBY + X2 = NRX-NLX + Y2 = NTY-NBY + X3 = X2/(XMAX-XMIN) + Y3 = Y2/(YMAX-YMIN) + X4 = NRX + Y4 = NTY + FACT = 1. + IF (BIGD .LE. 0.) GO TO 20 + X0 = -BIGD + Y0 = -BIGD + X3 = X2/(2.*BIGD) + Y3 = Y2/(2.*BIGD) + FACT = R0/D + 20 DELCRT = X2 + ASSIGN 80 TO JDONE + 30 IF (SINGA .LT. 0.0001) GO TO 40 + R = 1./SINGA + ASSIGN 70 TO JUMP + RETURN + 40 SINBE = SIN(BE) + R = 1./SINBE + ASSIGN 60 TO JUMP + RETURN +C +C******************** ENTRY TRN32 ************************ +C ENTRY TRN32 (U,V,W,XT,YT,ZT) +C + 50 UU = U + VV = V + WW = W + Q = D/((UU-EU)*COSAL+(VV-EV)*COSBE+(WW-EW)*COSGA) + GO TO JUMP,( 60, 70) + 60 UU = ((EW+Q*(WW-EW)-AW)*COSAL-(EU+Q*(UU-EU)-AU)*COSGA)*R + VV = (EV+Q*(VV-EV)-AV)*R + GO TO JDONE,( 80, 90) + 70 UU = ((EU+Q*(UU-EU)-AU)*COSBE-(EV+Q*(VV-EV)-AV)*COSAL)*R + VV = (EW+Q*(WW-EW)-AW)*R + GO TO JDONE,( 80, 90) + 80 XT = AMIN1(X4,AMAX1(X1,X1+X3*(FACT*UU-X0))) + YT = AMIN1(Y4,AMAX1(Y1,Y1+Y3*(FACT*VV-Y0))) + RETURN + 90 XT = UU + YT = VV + RETURN + END + SUBROUTINE ZEROSC + SAVE +C + COMMON /ISOSR2/ LX ,NX ,NY ,ISCR(8,128), + 1 ISCA(8,128) +C +C ZERO BOTH SCRENE MODELS. +C + DO 20 I=1,LX + DO 10 J=1,NY + ISCR(I,J) = 0 + ISCA(I,J) = 0 + 10 CONTINUE + 20 CONTINUE + RETURN + END + SUBROUTINE STCNTR (Z,L,M,N,CONV) +C + SAVE + DIMENSION Z(L,N) +C +C THIS ROUTINE FINDS THE BEGINNINGS OF ALL CONTOUR LINES AT LEVEL CONV. +C FIRST THE EDGES ARE SEARCHED FOR LINES INTERSECTING THE EDGE (OPEN +C LINES) THEN THE INTERIOR IS SEARCHED FOR LINES WHICH DO NOT INTERSECT +C THE EDGE (CLOSED LINES). BEGINNINGS ARE STORED IN IR TO PREVENT RE- +C TRACING OF LINES. IF IR IS FILLED, THE SEARCH IS STOPPED FOR THIS +C CONV. +C + COMMON /ISOSR6/ IX ,IY ,IDX ,IDY , + 1 IS ,ISS ,NP ,CV , + 2 INX(8) ,INY(8) ,IR(500) ,NR + COMMON /ISOSR7/ IENTRY ,IONES + COMMON /ISOSR9/ BIG ,IXBIT +C +C PACK X AND Y +C + IPXY(I1,J1) = ISHIFT(I1,IXBIT)+J1 +C + IENTRY = 0 + NP = 0 + CV = CONV +C +C THE FOLLOWING CODE SHOULD BE RE-ENABLED IF THIS ROUTINE IS USED FOR +C GENERAL CONTOURING +C +C ISS=0 +C DO 2 IP1=2,M +C I=IP1-1 +C IF(Z(I,1).GE.CV.OR.Z(IP1,1).LT.CV) GO TO 1 +C IX=IP1 +C IY=1 +C IDX=-1 +C IDY=0 +C IS=1 +C CALL DRLINE(Z,L,M,N) +C 1 IF(Z(IP1,N).GE.CV.OR.Z(I,N).LT.CV) GO TO 2 +C IX=I +C IY=N +C IDX=1 +C IDY=0 +C IS=5 +C CALL DRLINE(Z,L,M,N) +C 2 CONTINUE +C DO 4 JP1=2,N +C J=JP1-1 +C IF(Z(M,J).GE.CV.OR.Z(M,JP1).LT.CV) GO TO 3 +C IX=M +C IY=JP1 +C IDX=0 +C IDY=-1 +C IS=7 +C CALL DRLINE(Z,L,M,N) +C 3 IF(Z(1,JP1).GE.CV.OR.Z(1,J).LT.CV) GO TO 4 +C IX=1 +C IY=J +C IDX=0 +C IDY=1 +C IS=3 +C CALL DRLINE(Z,L,M,N) +C 4 CONTINUE +C + ISS = 1 + DO 40 JP1=3,N + J = JP1-1 + DO 30 IP1=2,M + I = IP1-1 + IF (Z(I,J).GE.CV .OR. Z(IP1,J).LT.CV) GO TO 30 + IXY = IPXY(IP1,J) + IF (NP .EQ. 0) GO TO 20 + DO 10 K=1,NP + IF (IR(K) .EQ. IXY) GO TO 30 + 10 CONTINUE + 20 NP = NP+1 + IF (NP .GT. NR) RETURN + IR(NP) = IXY + IX = IP1 + IY = J + IDX = -1 + IDY = 0 + IS = 1 + CALL DRCNTR (Z,L,M,N) + 30 CONTINUE + 40 CONTINUE + RETURN + END + SUBROUTINE DRCNTR (Z,L,MM,NN) + SAVE +C + DIMENSION Z(L,NN) +C +C THIS ROUTINE TRACES A CONTOUR LINE WHEN GIVEN THE BEGINNING BY STLINE. +C TRANSFORMATIONS CAN BE ADDED BY DELETING THE STATEMENT FUNCTIONS FOR +C FX AND FY IN DRLINE AND MINMAX AND ADDING EXTERNAL FUNCTIONS. +C X=1. AT Z(1,J), X=FLOAT(M) AT Z(M,J). X TAKES ON NON-INTEGER VALUES. +C Y=1. AT Z(I,1), Y=FLOAT(N) AT Z(I,N). Y TAKES ON NON-INTEGER VALUES. +C + COMMON /ISOSR6/ IX ,IY ,IDX ,IDY , + 1 IS ,ISS ,NP ,CV , + 2 INX(8) ,INY(8) ,IR(500) ,NR + COMMON /ISOSR9/ BIG ,IXBIT +C + LOGICAL IPEN ,IPENO +C + DATA IOFFP,SPVAL/0,0./ + DATA IPEN,IPENO/.TRUE.,.TRUE./ +C +C PACK X AND Y +C + IPXY(I1,J1) = ISHIFT(I1,IXBIT)+J1 + FX(X1,Y1) = X1 + FY(X1,Y1) = Y1 + C(P11,P21) = (P11-CV)/(P11-P21) +C + M = MM + N = NN + IF (IOFFP .EQ. 0) GO TO 10 + ASSIGN 100 TO JUMP1 + ASSIGN 150 TO JUMP2 + GO TO 20 + 10 ASSIGN 120 TO JUMP1 + ASSIGN 160 TO JUMP2 + 20 IX0 = IX + IY0 = IY + IS0 = IS + IF (IOFFP .EQ. 0) GO TO 30 + IX2 = IX+INX(IS) + IY2 = IY+INY(IS) + IPEN = Z(IX,IY).NE.SPVAL .AND. Z(IX2,IY2).NE.SPVAL + IPENO = IPEN + 30 IF (IDX .EQ. 0) GO TO 40 + Y = IY + ISUB = IX+IDX + X = C(Z(IX,IY),Z(ISUB,IY))*FLOAT(IDX)+FLOAT(IX) + GO TO 50 + 40 X = IX + ISUB = IY+IDY + Y = C(Z(IX,IY),Z(IX,ISUB))*FLOAT(IDY)+FLOAT(IY) + 50 IF (IPEN) CALL FRSTS (FX(X,Y),FY(X,Y),1) + 60 IS = IS+1 + IF (IS .GT. 8) IS = IS-8 + IDX = INX(IS) + IDY = INY(IS) + IX2 = IX+IDX + IY2 = IY+IDY + IF (ISS .NE. 0) GO TO 70 + IF (IX2.GT.M .OR. IY2.GT.N .OR. IX2.LT.1 .OR. IY2.LT.1) GO TO 190 + 70 IF (CV-Z(IX2,IY2)) 80, 80, 90 + 80 IS = IS+4 + IX = IX2 + IY = IY2 + GO TO 60 + 90 IF (IS/2*2 .EQ. IS) GO TO 60 + GO TO JUMP1,(100,120) + 100 ISBIG = IS+(8-IS)/6*8 + IX3 = IX+INX(ISBIG-1) + IY3 = IY+INY(ISBIG-1) + IX4 = IX+INX(ISBIG-2) + IY4 = IY+INY(ISBIG-2) + IPENO = IPEN + IF (ISS .NE. 0) GO TO 110 + IF (IX3.GT.M .OR. IY3.GT.N .OR. IX3.LT.1 .OR. IY3.LT.1) GO TO 190 + IF (IX4.GT.M .OR. IY4.GT.N .OR. IX4.LT.1 .OR. IY4.LT.1) GO TO 190 + 110 IPEN = Z(IX,IY).NE.SPVAL .AND. Z(IX2,IY2).NE.SPVAL .AND. + 1 Z(IX3,IY3).NE.SPVAL .AND. Z(IX4,IY4).NE.SPVAL + 120 IF (IDX .EQ. 0) GO TO 130 + Y = IY + ISUB = IX+IDX + X = C(Z(IX,IY),Z(ISUB,IY))*FLOAT(IDX)+FLOAT(IX) + GO TO 140 + 130 X = IX + ISUB = IY+IDY + Y = C(Z(IX,IY),Z(IX,ISUB))*FLOAT(IDY)+FLOAT(IY) + 140 GO TO JUMP2,(150,160) + 150 IF (.NOT.IPEN) GO TO 170 + IF (IPENO) GO TO 160 +C +C END OF LINE SEGMENT +C + CALL FRSTS (D1,D2,3) + CALL FRSTS (FX(XOLD,YOLD),FY(XOLD,YOLD),1) +C +C CONTINUE LINE SEGMENT +C + 160 CALL FRSTS (FX(X,Y),FY(X,Y),2) + 170 XOLD = X + YOLD = Y + IF (IS .NE. 1) GO TO 180 + NP = NP+1 + IF (NP .GT. NR) GO TO 190 + IR(NP) = IPXY(IX,IY) + 180 IF (ISS .EQ. 0) GO TO 60 + IF (IX.NE.IX0 .OR. IY.NE.IY0 .OR. IS.NE.IS0) GO TO 60 +C +C END OF LINE +C + 190 CALL FRSTS (D1,D2,3) + RETURN + END + SUBROUTINE TR32 (X,Y,MX,MY) + SAVE +C + COMMON /ISOSR1/ ISLBT ,U ,V ,W +C +C A.S.F. FOR SCALING +C + SU(UTEMP) = UTEMP + SV(VTEMP) = VTEMP + SW(WTEMP) = WTEMP +C + XX = X + YY = Y + IF (ISLBT) 10, 20, 30 + 10 CALL TRN32I (SU(U),SV(XX-1.),SW(YY-1.),XT,YT,DUM,2) + GO TO 40 + 20 CALL TRN32I (SU(XX-1.),SV(V),SW(YY-1.),XT,YT,DUM,2) + GO TO 40 + 30 CALL TRN32I (SU(XX-1.),SV(YY-1.),SW(W),XT,YT,DUM,2) + 40 MX = XT + MY = YT + RETURN + END + SUBROUTINE FRSTS (XX,YY,IENT) +C +C THIS IS A SPECIAL VERSION OF THE SMOOTHING DASHED LINE PACKAGE. LINES +C ARE SMOOTHED IN THE SAME WAY, BUT NO SOFTFARE DASHED LINES ARE USED. +C CONDITIONAL PLOTTING ROUTINES ARE CALL WHICH DETERMINE THE VISIBILITY +C OF A LINE SEGMENT BEFORE PLOTTING. +C + SAVE + DIMENSION XSAVE(70) ,YSAVE(70) ,XP(70) ,YP(70) , + 1 TEMP(70) +C + COMMON /ISOSR7/ IENTRY ,IONES +C + DATA NP/150/ + DATA L1/70/ + DATA TENSN/2.5/ + DATA PI/3.14159265358/ + DATA SMALL/128./ +C + AVE(A,B) = .5*(A+B) +C +C DECIDE IF FRSTS,VECTS,LASTS CALL +C + GO TO ( 10, 20, 40),IENT + 10 DEG = 180./PI + X = XX + Y = YY + LASTFL = 0 + SSLP1 = 0.0 + SSLPN = 0.0 + XSVN = 0.0 + YSVN = 0.0 +C +C INITIALIZE THE POINT AND SEGMENT COUNTER +C N COUNTS THE NUMBER OF POINTS/SEGMENT +C + N = 0 +C +C NSEG = 0 FIRST SEGMENT +C NSEG = 1 MORE THAN ONE SEGMENT +C + NSEG = 0 + CALL TR32 (X,Y,MX,MY) +C +C SAVE THE X,Y COORDINATES OF THE FIRST POINT +C XSV1 CONTAINS THE X COORDINATE OF THE FIRST POINT +C OF A LINE +C YSV1 CONTAINS THE Y COORDINATE OF THE FIRST POINT +C OF A LINE +C + XSV1 = MX + YSV1 = MY + GO TO 30 +C +C ************************* ENTRY VECTS ************************* +C ENTRY VECTS (XX,YY) +C + 20 X = XX + Y = YY +C +C VECTS SAVES THE X,Y COORDINATES OF THE ACCEPTED +C POINTS ON A LINE SEGMENT +C + CALL TR32 (X,Y,MX,MY) +C +CIF THE NEW POINT IS TOO CLOSE TO THE PREVIOUS POINT, IGNORE IT +C + IF (ABS(FLOAT(IFIX(XSVN)-MX))+ABS(FLOAT(IFIX(YSVN)-MY)) .LT. + 1 SMALL) RETURN + IFLAG = 0 + 30 N = N+1 +C +C SAVE THE X,Y COORDINATES OF EACH POINT OF THE SEGMENT +C XSAVE THE ARRAY OF X COORDINATES OF LINE SEGMENT +C YSAVE THE ARRAY OF Y COORDINATES OF LINE SEGMENT +C + XSAVE(N) = MX + YSAVE(N) = MY + XSVN = XSAVE(N) + YSVN = YSAVE(N) + IF (N .GE. L1-1) GO TO 50 + RETURN +C +C ************************* ENTRY LASTS ************************* +C ENTRY LASTS +C + 40 LASTFL = 1 +C +C LASTS CHECKS FOR PERIODIC LINES AND SETS UP +C THE CALLS TO KURV1S AND KURV2S +C +C IFLAG = 0 OK TO CALL LASTS DIRECTLY +C IFLAG = 1 LASTS WAS JUST CALLED FROM BY VECTS +C IGNORE CALL TO LASTS +C + IF (IFLAG .EQ. 1) RETURN +C +C COMPARE THE LAST POINT OF SEGMENT WITH FIRST POINT OF LINE +C + 50 IFLAG = 1 +C +C IPRD = 0 PERIODIC LINE +C IPRD = 1 NON-PERIODIC LINE +C + IPRD = 1 + IF (ABS(XSV1-XSVN)+ABS(YSV1-YSVN) .LT. SMALL) IPRD = 0 +C +C TAKE CARE OF THE CASE OF ONLY TWO DISTINCT P0INTS ON A LINE +C + IF (NSEG .GE. 1) GO TO 70 + IF (N-2) 160,150, 60 + 60 IF (N .GE. 4) GO TO 70 + DX = XSAVE(2)-XSAVE(1) + DY = YSAVE(2)-YSAVE(1) + SLOPE = ATAN2(DY,DX)*DEG+90. + IF (SLOPE .GE. 360.) SLOPE = SLOPE-360. + IF (SLOPE .LE. 0.) SLOPE = SLOPE+360. + SLP1 = SLOPE + SLPN = SLOPE + ISLPSW = 0 + SIGMA = TENSN + GO TO 110 + 70 SIGMA = TENSN + IF (IPRD .GE. 1) GO TO 90 + IF (NSEG .GE. 1) GO TO 80 +C +C SET UP FLAGS FOR A 1 SEGMENT, PERIODIC LINE +C + ISLPSW = 4 + XSAVE(N) = XSV1 + YSAVE(N) = YSV1 + GO TO 110 +C +C SET UP FLAGS FOR AN N-SEGMENT, PERIODIC LINE +C + 80 SLP1 = SSLPN + SLPN = SSLP1 + ISLPSW = 0 + GO TO 110 + 90 IF (NSEG .GE. 1) GO TO 100 +C +C SET UP FLAGS FOR THE 1ST SEGMENT OF A NON-PERIODIC LINE +C + ISLPSW = 3 + GO TO 110 +C +C SET UP FLAGS FOR THE NTH SEGMENT OF A NON-PERIODIC LINE +C + 100 SLP1 = SSLPN + ISLPSW = 1 +C +C CALL THE SMOOTHING ROUTINES +C + 110 CALL KURV1S (N,XSAVE,YSAVE,SLP1,SLPN,XP,YP,TEMP,S,SIGMA,ISLPSW) + IF (IPRD.EQ.0 .AND. NSEG.EQ.0 .AND. S.LT.70.) GO TO 170 + IENTRY = 1 +C +C DETERMINE THE NUMBER OF POINTS TO INTERPOLATE FOR EACH SEGMENT +C + IF (NSEG.GE.1 .AND. N.LT.L1-1) GO TO 120 + NPRIME = FLOAT(NP)-(S*FLOAT(NP))/(2.*32768.) + IF (S .GE. 32768.) NPRIME = .5*FLOAT(NP) + NPL = FLOAT(NPRIME)*S/32768. + IF (NPL .LT. 2) NPL = 2 + 120 DT = 1./FLOAT(NPL) + IF (NSEG .LE. 0) CALL FRSTC (IFIX(XSAVE(1)),IFIX(YSAVE(1)),1) + T = 0.0 + NSLPSW = 1 + IF (NSEG .GE. 1) NSLPSW = 0 + NSEG = 1 + CALL KURV2S (T,XS,YS,N,XSAVE,YSAVE,XP,YP,S,SIGMA,NSLPSW,SLP) +C +C SAVE SLOPE AT THE FIRST POINT OF THE LINE +C + IF (NSLPSW .GE. 1) SSLP1 = SLP + NSLPSW = 0 + XSOLD = XSAVE(1) + YSOLD = YSAVE(1) + DO 130 I=1,NPL + T = T+DT + TT = -T + IF (I .EQ. NPL) NSLPSW = 1 + CALL KURV2S (TT,XS,YS,N,XSAVE,YSAVE,XP,YP,S,SIGMA,NSLPSW,SLP) +C +C SAVE THE LAST SLOPE OF THIS LINE SEGMENT +C + IF (NSLPSW .GE. 1) SSLPN = SLP +C +C DRAW EACH PART OF THE LINE SEGMENT +C + CALL FRSTC (IFIX(AVE(XSOLD,XS)),IFIX(AVE(YSOLD,YS)),2) + CALL FRSTC (IFIX(XS),IFIX(YS),2) + XSOLD = XS + YSOLD = YS + 130 CONTINUE + IF (IPRD .NE. 0) GO TO 140 +C +C CONNECT THE LAST POINT WITH THE FIRST POINT OF A PERIODIC LINE +C + CALL FRSTC (IFIX(AVE(XSOLD,XS)),IFIX(AVE(YSOLD,YS)),2) + CALL FRSTC (IFIX(XSV1),IFIX(YSV1),2) +C +C BEGIN THE NEXT LINE SEGMENT WITH THE LAST POINT OF THIS SEGMENT +C + 140 XSAVE(1) = XS + YSAVE(1) = YS + N = 1 + 150 CONTINUE + 160 RETURN + 170 N = 0 + RETURN + END + SUBROUTINE FRSTC (MX,MY,IENT) + SAVE +C + COMMON /ISOSR2/ LX ,NX ,NY ,ISCR(8,128), + 1 ISCA(8,128) + COMMON /ISOSR4/ RX ,RY + COMMON /ISOSR5/ NBPW ,MASK(16) ,GENDON + LOGICAL GENDON + COMMON /ISOSR8/ NMASK(16) ,IXOLD ,IYOLD ,IBTOLD , + 1 HBFLAG ,IOSLSN ,LRLX ,IFSX , + 2 IFSY ,FIRST ,IYDIR ,IHX , + 3 IHB ,IHS ,IHV ,IVOLD , + 4 IVAL ,IHRX ,YCHANG ,ITPD , + 5 IHF + LOGICAL YCHANG ,HBFLAG ,FIRST ,IHF +C +C +C DRAW LINE TO THE POINT MX,MY +C +C ENTER THE POINT INTO THE CURRENT SCREEN, ISCR, IF THE POINT CONFORMS +C TO THE SHADING ALGORITHM. +C THE POINT IS NOT ENTERED WHEN; +C 1. IT IS THE SAME POINT USED IN THE LAST CALL, RESOLUTION PROBLEM +C 2. IT IS PART OF A HORIZONTAL LINE BUT NOT AN END POINT +C 3. THE ENTIRE CONTOUR RESTS ON A HORIZONTAL PLANE +C +C WHEN DRAWING A HORIZONTAL LINE THREE CONDITIONS EXIST; +C 1. WHEN THE LINE IS A HORIZONTAL STEP ENTER ONLY THE OUTSIDE POINT. +C A HORIZONTAL STEP IS DEFINED BY THE ENTERING AND EXITING Y +C DIRECTION THAT IS THE SAME. +C 2. ENTER BOTH END POINTS OF A HORIZONTAL TURNING POINT. A HORIZONTAL +C TURNING POINT IS A LINE WITH GREATER THAN 1 HORIZONTAL BITS +C AND THE ENTERING AND EXITING Y DIRECTION IS DIFFIRENT. +C 3. WHEN THE ENTIRE CONTOUR IS A HORIZONTAL LINE NO POINTS ARE +C ENTERED. THIS CONDITION IS DETECTED BY THE STATUS OF YCHANG. +C IF IT IS TRUE THEN THE CONTOUR IS NOT A SINGLE HORIZONTAL LINE. +C +C THE PREVIOUS POINT IS ERASED IF IT IS A VERTICAL TURNING POINT. +C A VERTICAL TURNING POINT IS A HORIZONTAL LINE WITH ONLY 1 POINT +C AND THE ENTERING AND EXITING Y DIRECTION DIFFERS.THIS DATA IS +C IN THE VARIABLES IOSLSN-OLD SLOPE AND ISLSGN-NEW SLOPE. +C THE CHANGE IN SLOPE MUST BE -1 TO 1 OR 1 TO -1. +C +C OTHERWISE THE POINT IS ENTERED INTO ISCR. +C +C THE TWO ENTRY POINTS ARE REQUIRED BY THE HARDWARE DRAWING ROUTINES. +C FIRSTC IS USED FOR THE FIRST POINT ON THE CONTOUR. THE REMAINING +C POINTS ON THE SAME CONTOUR ARE ENTERED VIA VECTC. +C + DATA IONE/1/ + AVE(A,B) = (A+B)*.5 +C +C COMPUTE VISIBILITY OF THIS POINT +C +C WARNING +C IF X OR Y PLOTTER MAXIMUM VALUE RANGES FALL BELOW 101 THEN THE +C FOLLOWING TWO STATEMENTS WHICH SET IX AND IY MUST BE CHANGED. +C REPLACE THE CONSTANT 1.0 BY 0.5 IN THE STATEMENTS WHERE THE +C MAXIMUM PLOTTER VALUE IS LESS THAN 101 FOR THAT DIRECTION. THE +C PLOTTER CORDINATE RANGES ARE SET IN SET32. +C + IX = FLOAT(MX-1)*RX+1.0 + NRLX = IX + IY = FLOAT(MY-1)*RY+1.0 + IBIT = NBPW-MOD(IX,NBPW) + IX = IX/NBPW+1 + IVNOW = IAND(ISHIFT(ISCA(IX,IY),1-IBIT),IONE) +C +C DECIDE IF FRSTC OR VECTC CALL +C + IF (IENT .NE. 1) GO TO 10 +C + XOLD = MX + YOLD = MY +C +C +C SET INITIAL VALUES +C + IHF = .FALSE. + IYDIR = 0 + ITPD = 0 + IVAL = 0 + IOSLSN = 0 + IFSX = NRLX + IFSY = IY + LASTV = IVNOW + HBFLAG = .FALSE. + YCHANG = .FALSE. + CALL PLOTIT (IFIX(XOLD),IFIX(YOLD),0) + GO TO 180 +C +C**************************** ENTRY VECTC **************************** +C ENTRY VECTC (MX,MY) +C + 10 XNOW = MX + YNOW = MY + JUMP = IVNOW*2+LASTV+1 + GO TO ( 20, 30, 40, 50),JUMP +C +C BOTH VISIBLE +C + 20 CALL PLOTIT (IFIX(XNOW),IFIX(YNOW),1) + GO TO 50 +C +C JUST TURNED VISIBLE +C + 30 CALL PLOTIT (IFIX(AVE(XNOW,XOLD)),IFIX(AVE(YNOW,YOLD)),0) + GO TO 50 +C +C JUST TURNED INVISIBLE +C + 40 CALL PLOTIT (IFIX(AVE(XNOW,XOLD)),IFIX(AVE(YNOW,YOLD)),1) +C +C BOTH INVISIBLE +C + 50 XOLD = XNOW + YOLD = YNOW + LASTV = IVNOW +C +C TEST FOR RESOLUTION PROBLEM +C + IF (NRLX.EQ.LRLX .AND. IY.EQ.IYOLD) RETURN +C +C TEST FOR HORIZONTAL BITS +C + IF (IYOLD .NE. IY) GO TO 70 +C +C HORIZONTAL BITS DETECTED. SET FLAG AND EXIT. +C THIS AND THE NEXT HORIZONTAL BIT TEST IS NECESSARY FOR ISCR TO +C CONFORM TO THE SHADING ALGORITHM IN SUBROUTINE FILLIN +C +C +C IF HORIZONTAL LINE PREVIOUSLY DETECTED EXIT +C + IF (.NOT.HBFLAG) GO TO 60 +C +C IF END OF CONTOUR ON A HORIZONTAL LINE BRANCH FOR SPECIAL PROCESSING. +C + IF (NRLX.EQ.IFSX .AND. IY.EQ.IFSY) GO TO 210 + GO TO 200 +C +C SAVE SLOPE PRIOR TO HORIZONTAL LINE +C + 60 IHX = IXOLD + IHB = IBTOLD + IHS = IOSLSN + IOSLSN = 0 + HBFLAG = .TRUE. + IHRX = LRLX + IHV = IVOLD + IF (LRLX.EQ.IFSX .AND. IYOLD.EQ.IFSY) IHF = .TRUE. +C +C THIS IS THE SECOND TRAP FOR END OF CONTOUR ON A HORIZONTAL LINE. +C + IF (NRLX.EQ.IFSX .AND. IY.EQ.IFSY) GO TO 210 + GO TO 200 +C +C COMPUTE THE SLOPE TO THIS POINT +C + 70 IF (IY-IYOLD) 80, 90,100 + 80 ISLSGN = 1 + GO TO 110 + 90 ISLSGN = 0 + GO TO 120 + 100 ISLSGN = -1 + 110 IF (IYDIR .EQ. 0) IYDIR = ISLSGN + 120 CONTINUE +C +C IF PROCESS REACHES THIS CODE THE CONTOUR IS NOT CONTAINED ON A SINGLE +C HORIZONTAL PLANE, SO RECORD THIS FACT BY SETTING Y CHANGE FLAG. +C + YCHANG = .TRUE. +C +C TEST FOR END OF HORIZONTAL LINE +C + IF (.NOT.HBFLAG) GO TO 160 + HBFLAG = .FALSE. +C +C HORIZONTAL LINE JUST ENDED +C +C TEST FOR REDRAW +C + ITEMP = IAND(ISCR(IXOLD,IYOLD),MASK(IBTOLD)) + IF ((IHV .EQ. 0) .AND. (ITEMP .EQ. 0)) GO TO 130 +C +C REDRAWING ERASE THIS POINT +C + ISCR(IXOLD,IYOLD) = IAND(ISCR(IXOLD,IYOLD),NMASK(IBTOLD)) + ISCR(IHX,IYOLD) = IAND(ISCR(IHX,IYOLD),NMASK(IHB)) + GO TO 170 +C +C TEST FOR STEP PROBLEM +C + 130 IF (IHS .NE. ISLSGN) GO TO 140 +C +C STEP PROBLEM +C + GO TO 170 +C +C TURNING PROBLEM HORIZONTAL LINE IS A TURNING POINT +C + 140 CONTINUE +C +C ENTER THE TURNING POINT ONLY IF IT IS NOT THE SECOND SUCCEEDING +C EVENT IN A ROW +C + ICTPD = 1 + IF (IHRX .GT. NRLX) ICTPD = -1 + IF (ICTPD .NE. ITPD) GO TO 150 + ITPD = 0 +C +C ERASE THE FIRST POINT +C + ISCR(IHX,IYOLD) = IAND(ISCR(IHX,IYOLD),NMASK(IHB)) + GO TO 170 +C +C ENTER THE TURNING POINT +C + 150 CONTINUE + ITPD = ICTPD +C +C ENTER THE SECOND POINT +C + ISCR(IXOLD,IYOLD) = IOR(ISCR(IXOLD,IYOLD),MASK(IBTOLD)) + GO TO 170 +C +C CHECK IF PREVIOUS ENTRY WAS A VERTICAL TURNING POINT. +C IF SO ERASE IT. +C + 160 IF (ISLSGN.EQ.IOSLSN .OR. (IOSLSN.EQ.0 .OR. ISLSGN.EQ.0)) + 1 GO TO 170 + ITPD = 0 + ISCR(IXOLD,IYOLD) = IAND(ISCR(IXOLD,IYOLD),NMASK(IBTOLD)) +C + 170 IOSLSN = ISLSGN +C +C CHECK IF THIS GRID POINT PREVIOUSLY ACTIVATED +C + IVAL = IAND(ISCR(IX,IY),MASK(IBIT)) +C +C IF GRID POINTS ACTIVATED BRANCH +C + IF (IVAL .NE. 0) GO TO 190 +C +C GRID POINT NOT ACTIVATED SET AND EXIT +C + 180 CONTINUE + ISCR(IX,IY) = IOR(ISCR(IX,IY),MASK(IBIT)) + GO TO 200 +C +C THIS POINT IS BEING REDRAWN SO ERASE IT. +C (THIS IS TO CONFORM WITH THE SHADING ALGORITHM, FILLIN. +C HOWEVER IF BACK TO STARTING POINT DO NOT ERASE +C + 190 IF (NRLX.EQ.IFSX .AND. IY.EQ.IFSY) RETURN + ISCR(IX,IY) = IAND(ISCR(IX,IY),NMASK(IBIT)) +C +C + 200 IXOLD = IX + LRLX = NRLX + IYOLD = IY + IBTOLD = IBIT + IVOLD = IVAL + RETURN +C +C PERFORM THIS OPERATION WHEN A CONTOUR STARTS OR ENDS ON A HORIZONTAL +C LINE. +C + 210 CONTINUE +C +C ERASE THE FIRST POINT OF A CONTOUR WHEN IT IS PART OF A HORIZONTAL +C LINE SEGMENT AND IS NOT THE ENDPOINT OF THE SEGMENT +C + IF (.NOT.IHF) GO TO 220 + ISCR(IX,IY) = IAND(ISCR(IX,IY),NMASK(IBIT)) + 220 CONTINUE +C +C ERASE THE FIRST POINT OF A HORIZONTAL LINE SEGMENT WHEN IT ENDS +C THE CONTOUR AND IS NOT THE HIGHEST LINE SEG ON THS SIDE. +C + IF (.NOT.YCHANG) GO TO 230 + IF (IYDIR .NE. IHS) GO TO 200 + 230 ISCR(IHX,IY) = IAND(ISCR(IHX,IY),NMASK(IHB)) + GO TO 200 + END + SUBROUTINE FILLIN +C + SAVE + COMMON /ISOSR2/ LX ,NX ,NY ,ISCR(8,128), + 1 ISCA(8,128) + COMMON /ISOSR5/ NBPW ,MASK(16) ,GENDON + LOGICAL GENDON + COMMON /ISOSR7/ IENTRY ,IONES +C + IF (IENTRY .EQ. 0) RETURN +C +C THIS IS A SHADING ALGORITHM IT IS USED TO DETERMINE CONTOUR LINES +C THAT ARE HIDDEN BY THE PRESENT LINE. THE ALGORITHM PROCESSES +C HORIZONTAL ROWS. IT ASSUMES THAT THE BIT PATTERN PASSED TO IT +C HAS ONLY BITS SET TO MARK THE START AND END OF SHADING. THE +C ALGORITHM ALSO ASSUMES THAT WHEN AN ON BIT IS ENCOUNTERED THAT A +C CORRESPONDING OFF BIT IS INCLUDED IN THE SAME ROW. +C +C +C PULL OUT ROWS OF THE CONTOUR PATTERN +C + IBVAL = 0 + DO 80 IYNOW=1,NY + DO 40 IXNOW=1,LX +C +C IF NO ACTIVATED BITS BRANCH +C + ICRWD = ISCR(IXNOW,IYNOW) + IF (ICRWD .EQ. 0) GO TO 30 +C +C ACTIVATED BITS IN WORD SET SHADING FLAG +C +C CHECK BIT BY BIT FOR ON/OFF FLAGS +C + DO 20 IB=1,NBPW + IBIT = (NBPW+1)-IB +C +C +C PULL OUT THE CURRENT GRID POINT VALUE +C + IVAL = IAND(ICRWD,MASK(IBIT)) +C +C IF IVAL SET, THIS IS AN ON/OFF FLAG +C + IF (IVAL .EQ. 0) GO TO 10 +C +C FLAG BIT, ALWAYS SET +C + IBVAL = MOD(IBVAL+1,2) + GO TO 20 +C +C SHADE THE SCREEN ACCORDING TO THE STATUS OF IBVAL +C + 10 IF (IBVAL .NE. 0) ICRWD = IOR(ICRWD,MASK(IBIT)) +C + 20 CONTINUE +C +C ZERO OUT THE SCREEN +C + ISCR(IXNOW,IYNOW) = 0 + ISCA(IXNOW,IYNOW) = IOR(ICRWD,ISCA(IXNOW,IYNOW)) + GO TO 40 +C + 30 IF (IBVAL .NE. 0) ISCA(IXNOW,IYNOW) = IONES + 40 CONTINUE +C +C FIX FOR NONCORRECTABLE RUNAWAYS +C + IF (IBVAL .EQ. 0) GO TO 80 + IBVAL = 0 + DO 70 K=1,LX + ITEST = 0 + IF (IYNOW .EQ. 1) GO TO 50 + ITEST = ISCA(K,IYNOW-1) + IF (IYNOW .EQ. NY) GO TO 60 + 50 ITEST = IOR(ITEST,ISCA(K,IYNOW+1)) + 60 ISCA(K,IYNOW) = ITEST + 70 CONTINUE +C + 80 CONTINUE + RETURN + END + SUBROUTINE DRAWI (IXA,IYA,IXB,IYB) +C +C INCLUDED FOR USE BY PWRZ +C + SAVE + CALL FRSTC (IXA,IYA,1) + CALL FRSTC (IXB,IYB,2) + RETURN + END + SUBROUTINE MMASK +C +C MAKE THE MACHINE DEPENDENT MASKS USED IN THE CONTOUR DRAWING +C AND SHADING ALGORITHMS +C + SAVE + COMMON /ISOSR5/ NBPW ,MASK(16) ,GENDON + LOGICAL GENDON + COMMON /ISOSR7/ IENTRY ,IONES + COMMON /ISOSR8/ NMASK(16) ,IXOLD ,IYOLD ,IBTOLD , + 1 HBFLAG ,IOSLSN ,LRLX ,IFSX , + 2 IFSY ,FIRST ,IYDIR ,IHX , + 3 IHB ,IHS ,IHV ,IVOLD , + 4 IVAL ,IHRX ,YCHANG ,ITPD , + 5 IHF + COMMON /ISOSR9/ BIG ,IXBIT + LOGICAL YCHANG ,HBFLAG ,FIRST ,IHF + GENDON = .TRUE. + NBPW = 16 +C +C GET BIGGEST REAL NUMBER +C + BIG = R1MACH(2) +C +C MASKS TO SELECT A SPECIFIC BIT +C + DO 10 K=1,NBPW + MASK(K) = ISHIFT(1,K-1) + 10 CONTINUE +C +C GENERATE THE BIT PATTERN 177777 OCTAL +C + ITEMP1 = 0 + ITEMP = MASK(NBPW) + IST = NBPW-1 + DO 20 K=1,IST + ITEMP1 = IOR(ITEMP,ISHIFT(ITEMP1,-1)) + 20 CONTINUE + MFIX = IOR(ITEMP1,1) +C +C MASKS TO CLEAR A SPECIFIC BIT +C + DO 30 K=1,NBPW + NMASK(K) = IAND(ITEMP1,MFIX) + ITEMP1 = IOR(ISHIFT(ITEMP1,1),1) + 30 CONTINUE + IONES = MFIX + RETURN +C +C REVISION HISTORY--- +C +C JANUARY 1978 DELETED REFERENCES TO THE *COSY CARDS AND +C ADDED REVISION HISTORY +C JANUARY 1979 NEW SHADING ALGORITHM +C MARCH 1979 MADE CODE MACHINE INDEPENDENT AND CONFORM +C TO 66 FORTRAN STANDARD +C JUNE 1979 THIS VERSION PLACED ON ULIB. +C SEPTEMBER 1979 FIXED PROBLEM IN EZISOS DEALING WITH +C DETERMINATION OF VISIBILITY OF W PLANE. +C DECEMBER 1979 FIXED PROBLEM WITH PEN DOWN ON CONTOUR +C INITIALIZATION IN SUBROUTINE FRSTC +C MARCH CHANGED ROUTINE NAMES TRN32I AND DRAW TO +C TRN32I AND DRAWI TO BE CONSISTENT WITH THE +C USAGE OF THE NEW ROUTINE PWRZI. +C JUNE 1980 FIXED PROBLEM WITH ZERO INDEX COMPUTATION IN +C SUBROUTINE FRSTC. ADDED INPUT PARAMETER +C DIMENSION STATEMENT MISSING IN EZISOS. +C FIXED ERROR IN COMPUTATION OF ARCCOSINE +C IN EZISOS AND TRN32I. +C DECEMBER 1984 CONVERTED TO GKS LEVEL 0A AND STANDARD FORTRAN 77 +C----------------------------------------------------------------------- +C + END diff --git a/sys/gio/ncarutil/kurv.f b/sys/gio/ncarutil/kurv.f new file mode 100644 index 00000000..1d160b89 --- /dev/null +++ b/sys/gio/ncarutil/kurv.f @@ -0,0 +1,451 @@ + SUBROUTINE KURV1S (N,X,Y,SLOP1,SLOPN,XP,YP,TEMP,S,SIGMA,ISLPSW) +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C DIMENSION OF X(N),Y(N),XP(N),YP(N),TEMP(N) +C ARGUMENTS +C +C LATEST REVISION FEBRUARY 5, 1974 +C +C PURPOSE KURV1S DETERMINES THE PARAMETERS NECESSARY TO +C COMPUTE A SPLINE UNDER TENSION PASSING THROUGH +C A SEQUENCE OF PAIRS +C (X(1),Y(1)),...,(X(N),Y(N)) IN THE PLANE. +C THE SLOPES AT THE TWO ENDS OF THE CURVE MAY BE +C SPECIFIED OR OMITTED. FOR ACTUAL COMPUTATION +C OF POINTS ON THE CURVE IT IS NECESSARY TO CALL +C THE SUBROUTINE KURV2S. +C +C USAGE CALL KURV1S(N,X,Y,SLP1,SLPN,XP,YP,TEMP,S,SIGMA) +C +C ARGUMENTS +C +C ON INPUT N +C IS THE NUMBER OF POINTS TO BE INTERPOLATED +C (N .GE. 2). +C +C X +C IS AN ARRAY CONTAINING THE N X-COORDINATES +C OF THE POINTS. +C +C Y +C IS AN ARRAY CONTAINING THE N Y-COORDINATES +C OF THE POINTS. +C +C SLOP1 AND SLOPN +C CONTAIN THE DESIRED VALUES FOR THE SLOPE OF +C THE CURVE AT (X(1),Y(1)) AND (X(N),Y(N)), +C RESPECTIVELY. THESE QUANTITIES ARE IN +C DEGREES AND MEASURED COUNTER-CLOCKWISE +C FROM THE POSITIVE X-AXIS. IF ISLPSW IS NON- +C ZERO, ONE OR BOTH OF SLP1 AND SLPN MAY BE +C DETERMINED INTERNALLY BY KURV1S. +C +C XP AND YP +C ARE ARRAYS OF LENGTH AT LEAST N. +C +C TEMP +C IS AN ARRAY OF LENGTH AT LEAST N WHICH IS +C USED FOR SCRATCH STORAGE. +C +C SIGMA +C CONTAINS THE TENSION FACTOR. THIS IS +C NON-ZERO AND INDICATES THE CURVINESS DESIRED. +C IF ABS(SIGMA) IS VERY LARGE (E.G., 50.) THE +C RESULTING CURVE IS VERY NEARLY A POLYGONAL +C LINE. A STANDARD VALUE FOR SIGMA IS ABOUT 2. +C +C ISLPSW +C IS AN INTEGER INDICATING WHICH END SLOPES +C HAVE BEEN USER PROVIDED AND WHICH MUST BE +C COMPUTED BY KURV1S. FOR ISLPSW +C = 0 INDICATES BOTH SLOPES ARE PROVIDED, +C = 1 ONLY SLOP1 IS PROVIDED, +C = 2 ONLY SLOPN IS PROVIDED, +C = 3 NEITHER SLOP1 NOR SLOPN IS PROVIDED. +C = 4 NEITHER SLOP1 NOR SLOPN IS PROVIDED, +C BUT SLOP1=SLOPN. IN THIS CASE X(1)= +C X(N), Y(1)=Y(N) AND N.GE.3. +C ON OUTPUT XP AND YP +C CONTAIN INFORMATION ABOUT THE CURVATURE OF +C THE CURVE AT THE GIVEN NODES. +C +C S +C CONTAINS THE POLYGONAL ARCLENGTH OF THE +C CURVE. +C +C N, X, Y, SLP1, SLPN, SIGMA AND ISLPSW ARE +C UNCHANGED. +C +C ENTRY POINTS KURV1S +C +C SPECIAL CONDITIONS NONE +C +C COMMON BLOCKS NONE +C +C I/O NONE +C +C PRECISION SINGLE +C +C REQUIRED ULIB NONE +C ROUTINES +C +C SPECIALIST RUSSELL K. REW, NCAR, BOULDER, COLORADO 80302 +C +C LANGUAGE FORTRAN +C +C HISTORY ORIGINALLY WRITTEN BY A. K. CLINE, MARCH 1972. +C +C +C +C + INTEGER N + REAL X(N) ,Y(N) ,XP(N) ,YP(N) , + 1 TEMP(N) ,S ,SIGMA + SAVE +C + DATA PI /3.1415926535897932/ +C + NN = N + JSLPSW = ISLPSW + SLP1 = SLOP1 + SLPN = SLOPN + DEGRAD = PI/180. + NM1 = NN-1 + NP1 = NN+1 + DELX1 = X(2)-X(1) + DELY1 = Y(2)-Y(1) + DELS1 = SQRT(DELX1*DELX1+DELY1*DELY1) + DX1 = DELX1/DELS1 + DY1 = DELY1/DELS1 +C +C DETERMINE SLOPES IF NECESSARY +C + IF (JSLPSW .NE. 0) GO TO 70 + 10 SLPP1 = SLP1*DEGRAD + SLPPN = SLPN*DEGRAD +C +C SET UP RIGHT HAND SIDES OF TRIDIAGONAL LINEAR SYSTEM FOR XP +C AND YP +C + XP(1) = DX1-COS(SLPP1) + YP(1) = DY1-SIN(SLPP1) + + TEMP(1) = DELS1 + SS = DELS1 + IF (NN .EQ. 2) GO TO 30 + DO 20 I=2,NM1 + DELX2 = X(I+1)-X(I) + DELY2 = Y(I+1)-Y(I) + DELS2 = SQRT(DELX2*DELX2+DELY2*DELY2) + DX2 = DELX2/DELS2 + DY2 = DELY2/DELS2 + XP(I) = DX2-DX1 + YP(I) = DY2-DY1 + TEMP(I) = DELS2 + DELX1 = DELX2 + DELY1 = DELY2 + DELS1 = DELS2 + DX1 = DX2 + DY1 = DY2 +C +C ACCUMULATE POLYGONAL ARCLENGTH +C + SS = SS+DELS1 + 20 CONTINUE + 30 XP(NN) = COS(SLPPN)-DX1 + YP(NN) = SIN(SLPPN)-DY1 +C +C DENORMALIZE TENSION FACTOR +C + SIGMAP = ABS(SIGMA)*FLOAT(NN-1)/SS +C +C PERFORM FORWARD ELIMINATION ON TRIDIAGONAL SYSTEM +C + S = SS + DELS = SIGMAP*TEMP(1) + EXPS = EXP(DELS) + SINHS = .5*(EXPS-1./EXPS) + SINHIN = 1./(TEMP(1)*SINHS) + DIAG1 = SINHIN*(DELS*.5*(EXPS+1./EXPS)-SINHS) + DIAGIN = 1./DIAG1 + XP(1) = DIAGIN*XP(1) + YP(1) = DIAGIN*YP(1) + SPDIAG = SINHIN*(SINHS-DELS) + TEMP(1) = DIAGIN*SPDIAG + IF (NN .EQ. 2) GO TO 50 + DO 40 I=2,NM1 + DELS = SIGMAP*TEMP(I) + EXPS = EXP(DELS) + SINHS = .5*(EXPS-1./EXPS) + SINHIN = 1./(TEMP(I)*SINHS) + DIAG2 = SINHIN*(DELS*(.5*(EXPS+1./EXPS))-SINHS) + DIAGIN = 1./(DIAG1+DIAG2-SPDIAG*TEMP(I-1)) + XP(I) = DIAGIN*(XP(I)-SPDIAG*XP(I-1)) + YP(I) = DIAGIN*(YP(I)-SPDIAG*YP(I-1)) + SPDIAG = SINHIN*(SINHS-DELS) + TEMP(I) = DIAGIN*SPDIAG + DIAG1 = DIAG2 + 40 CONTINUE + 50 DIAGIN = 1./(DIAG1-SPDIAG*TEMP(NM1)) + XP(NN) = DIAGIN*(XP(NN)-SPDIAG*XP(NM1)) + YP(NN) = DIAGIN*(YP(NN)-SPDIAG*YP(NM1)) +C +C PERFORM BACK SUBSTITUTION +C + DO 60 I=2,NN + IBAK = NP1-I + XP(IBAK) = XP(IBAK)-TEMP(IBAK)*XP(IBAK+1) + YP(IBAK) = YP(IBAK)-TEMP(IBAK)*YP(IBAK+1) + 60 CONTINUE + RETURN + 70 IF (NN .EQ. 2) GO TO 100 +C +C IF NO SLOPES ARE GIVEN, USE SECOND ORDER INTERPOLATION ON +C INPUT DATA FOR SLOPES AT ENDPOINTS +C + IF (JSLPSW .EQ. 4) GO TO 90 + IF (JSLPSW .EQ. 2) GO TO 80 + DELNM1 = SQRT((X(NN-2)-X(NM1))**2+(Y(NN-2)-Y(NM1))**2) + DELN = SQRT((X(NM1)-X(NN))**2+(Y(NM1)-Y(NN))**2) + DELNN = DELNM1+DELN + C1 = (DELNN+DELN)/DELNN/DELN + C2 = -DELNN/DELN/DELNM1 + C3 = DELN/DELNN/DELNM1 + SX = C3*X(NN-2)+C2*X(NM1)+C1*X(NN) + SY = C3*Y(NN-2)+C2*Y(NM1)+C1*Y(NN) +C + SLPN = ATAN2(SY,SX)/DEGRAD + 80 IF (JSLPSW .EQ. 1) GO TO 10 + DELS2 = SQRT((X(3)-X(2))**2+(Y(3)-Y(2))**2) + DELS12 = DELS1+DELS2 + C1 = -(DELS12+DELS1)/DELS12/DELS1 + C2 = DELS12/DELS1/DELS2 + C3 = -DELS1/DELS12/DELS2 + SX = C1*X(1)+C2*X(2)+C3*X(3) + SY = C1*Y(1)+C2*Y(2)+C3*Y(3) +C + SLP1 = ATAN2(SY,SX)/DEGRAD + GO TO 10 + 90 DELN = SQRT((X(NM1)-X(NN))**2+(Y(NM1)-Y(NN))**2) + DELNN = DELS1+DELN + C1 = -DELS1/DELN/DELNN + C2 = (DELS1-DELN)/DELS1/DELN + C3 = DELN/DELNN/DELS1 + SX = C1*X(NM1)+C2*X(1)+C3*X(2) + SY = C1*Y(NM1)+C2*Y(1)+C3*Y(2) + IF (SX.EQ.0. .AND. SY.EQ.0.) SX = 1. + SLP1 = ATAN2(SY,SX)/DEGRAD + SLPN = SLP1 + GO TO 10 +C +C IF ONLY TWO POINTS AND NO SLOPES ARE GIVEN, USE STRAIGHT +C LINE SEGMENT FOR CURVE +C + 100 IF (JSLPSW .NE. 3) GO TO 110 + XP(1) = 0. + XP(2) = 0. + YP(1) = 0. + YP(2) = 0. +C + SLP1 = ATAN2(Y(2)-Y(1),X(2)-X(1))/DEGRAD + SLPN = SLP1 + RETURN +C + 110 IF (JSLPSW .EQ. 2) + 1 SLP1 = ATAN2(Y(2)-Y(1)-SLPN*(X(2)-X(1)), + 2 X(2)-X(1)-SLPN*(Y(2)-Y(1)))/DEGRAD +C + IF (JSLPSW .EQ. 1) + 1 SLPN = ATAN2(Y(2)-Y(1)-SLP1*(X(2)-X(1)), + 2 X(2)-X(1)-SLP1*(Y(2)-Y(1)))/DEGRAD + GO TO 10 + END + SUBROUTINE KURV2S (T,XS,YS,N,X,Y,XP,YP,S,SIGMA,NSLPSW,SLP) +C +C +C +C DIMENSION OF X(N),Y(N),XP(N),YP(N) +C ARGUMENTS +C +C LATEST REVISION OCTOBER 22, 1973 +C +C PURPOSE KURV2S PERFORMS THE MAPPING OF POINTS IN THE +C INTERVAL (0.,1.) ONTO A CURVE IN THE PLANE. +C THE SUBROUTINE KURV1S SHOULD BE CALLED EARLIER +C TO DETERMINE CERTAIN NECESSARY PARAMETERS. +C THE RESULTING CURVE HAS A PARAMETRIC +C REPRESENTATION BOTH OF WHOSE COMPONENTS ARE +C SPLINES UNDER TENSION AND FUNCTIONS OF THE +C POLYGONAL ARCLENGTH PARAMETER. +C +C ACCESS CARDS *FORTRAN,S=ULIB,N=KURV +C *COSY +C +C USAGE CALL KURV2S (T,XS,YS,N,X,Y,XP,YP,S,SIGMA) +C +C ARGUMENTS +C +C ON INPUT T +C CONTAINS A REAL VALUE OF ABSOLUTE VALUE LESS +C THAN OR EQUAL TO 1. TO BE MAPPED TO A POINT +C ON THE CURVE. THE SIGN OF T IS IGNORED AND +C THE INTERVAL (0.,1.) IS MAPPED ONTO THE +C ENTIRE CURVE. IF T IS NEGATIVE, THIS +C INDICATES THAT THE SUBROUTINE HAS BEEN CALLED +C PREVIOUSLY (WITH ALL OTHER INPUT VARIABLES +C UNALTERED) AND THAT THIS VALUE OF T EXCEEDS +C THE PREVIOUS VALUE IN ABSOLUTE VALUE. WITH +C SUCH INFORMATION THE SUBROUTINE IS ABLE TO +C MAP THE POINT MUCH MORE RAPIDLY. THUS IF THE +C USER SEEKS TO MAP A SEQUENCE OF POINTS ONTO +C THE SAME CURVE, EFFICIENCY IS GAINED BY +C ORDERING THE VALUES INCREASING IN MAGNITUDE +C AND SETTING THE SIGNS OF ALL BUT THE FIRST +C NEGATIVE. +C +C N +C CONTAINS THE NUMBER OF POINTS WHICH WERE +C INTERPOLATED TO DETERMINE THE CURVE. +C +C X AND Y +C ARRAYS CONTAINING THE X- AND Y-COORDINATES +C OF THE INTERPOLATED POINTS. +C +C XP AND YP +C ARE THE ARRAYS OUTPUT FROM KURV1 CONTAINING +C CURVATURE INFORMATION. +C +C S +C CONTAINS THE POLYGONAL ARCLENGTH OF THE +C CURVE. +C +C SIGMA +C CONTAINS THE TENSION FACTOR (ITS SIGN IS +C IGNORED). +C +C NSLPSW +C IS AN INTEGER SWITCH WHICH TURNS ON OR OFF +C THE CALCULATION OF SLP +C NSLPSW +C = 0 INDICATES THAT SLP WILL NOT BE +C CALCULATED +C = 1 SLP WILL BE CALCULATED +C +C THE PARAMETERS N, X, Y, XP, YP, S AND SIGMA +C SHOULD BE INPUT UNALTERED FROM THE OUTPUT OF +C KURV1S. +C +C ON OUTPUT XS AND YS +C CONTAIN THE X- AND Y-COORDINATES OF THE IMAGE +C POINT ON THE CURVE. +C +C SLP +C CONTAINS THE SLOPE OF THE CURVE IN DEGREES AT +C THIS POINT. +C +C T, N, X, Y, XP, YP, S AND SIGMA ARE UNALTERED. +C +C ENTRY POINTS KURV2S +C +C SPECIAL CONDITIONS NONE +C +C COMMON BLOCKS NONE +C +C I/O NONE +C +C PRECISION SINGLE +C +C REQUIRED ULIB NONE +C ROUTINES +C +C SPECIALIST RUSSELL K. REW, NCAR, BOULDER, COLORADO 80302 +C +C LANGUAGE FORTRAN +C +C HISTORY ORIGINALLY WRITTEN BY A. K. CLINE, MARCH 1972. +C +C +C +C + INTEGER N + REAL T ,XS ,YS ,X(N) , + 1 Y(N) ,XP(N) ,YP(N) ,S , + 2 SIGMA ,SLP + SAVE +C + DATA PI /3.1415926535897932/ +C +C +C DENORMALIZE SIGMA +C + SIGMAP = ABS(SIGMA)*FLOAT(N-1)/S +C +C STRETCH UNIT INTERVAL INTO ARCLENGTH DISTANCE +C + TN = ABS(T*S) +C +C FOR NEGATIVE T START SEARCH WHERE PREVIOUSLY TERMINATED, +C OTHERWISE START FROM BEGINNING +C + IF (T .LT. 0.) GO TO 10 + DEGRAD = PI/180. + I1 = 2 + XS = X(1) + YS = Y(1) + SUM = 0. + IF (T .LT. 0.) RETURN +C +C DETERMINE INTO WHICH SEGMENT TN IS MAPPED +C + 10 DO 30 I=I1,N + DELX = X(I)-X(I-1) + DELY = Y(I)-Y(I-1) + DELS = SQRT(DELX*DELX+DELY*DELY) + IF (SUM+DELS-TN) 20,40,40 + 20 SUM = SUM+DELS + 30 CONTINUE +C +C IF ABS(T) IS GREATER THAN 1., RETURN TERMINAL POINT ON +C CURVE +C + XS = X(N) + YS = Y(N) + RETURN +C +C SET UP AND PERFORM INTERPOLATION +C + 40 DEL1 = TN-SUM + DEL2 = DELS-DEL1 + EXPS1 = EXP(SIGMAP*DEL1) + SINHD1 = .5*(EXPS1-1./EXPS1) + EXPS2 = EXP(SIGMAP*DEL2) + SINHD2 = .5*(EXPS2-1./EXPS2) + EXPS = EXPS1*EXPS2 + SINHS = .5*(EXPS-1./EXPS) + XS = (XP(I)*SINHD1+XP(I-1)*SINHD2)/SINHS+ + 1 ((X(I)-XP(I))*DEL1+(X(I-1)-XP(I-1))*DEL2)/DELS + YS = (YP(I)*SINHD1+YP(I-1)*SINHD2)/SINHS+ + 1 ((Y(I)-YP(I))*DEL1+(Y(I-1)-YP(I-1))*DEL2)/DELS + I1 = I + IF (NSLPSW .EQ. 0) RETURN + COSHD1 = .5*(EXPS1+1./EXPS1)*SIGMAP + COSHD2 = .5*(EXPS2+1./EXPS2)*SIGMAP + XT = (XP(I)*COSHD1-XP(I-1)*COSHD2)/SINHS+ + 1 ((X(I)-XP(I))-(X(I-1)-XP(I-1)))/DELS + YT = (YP(I)*COSHD1-YP(I-1)*COSHD2)/SINHS+ + 1 ((Y(I)-YP(I))-(Y(I-1)-YP(I-1)))/DELS + SLP = ATAN2(YT,XT)/DEGRAD + RETURN + END diff --git a/sys/gio/ncarutil/mkpkg b/sys/gio/ncarutil/mkpkg new file mode 100644 index 00000000..20b06e09 --- /dev/null +++ b/sys/gio/ncarutil/mkpkg @@ -0,0 +1,51 @@ +# Make the NCAR utilities library libncar.a. + +$checkout libncar.a lib$ +$update libncar.a +$checkin libncar.a lib$ +$exit + +libncar.a: + @sysint + @autograph + @conlib + + conran.f # blockdata for the conrec utility + conbdn.f # blockdata for the conran utility + #conraq.f - Conran, conraq and conras form the "conran" family. + #conras.f - Conran is the only one of the 3 included in "libncar.a"; + # - the others contain duplicate entry points and blockdatas + # - and are not included. + # + conrec.f + conbd.f + #conrcqck.f - Conrcqck, conrcspr and conrec form the "conrec" family. + #conrcspr.f - Conrec is the only one of the 3 included in "libncar.a"; + # - the others contain duplicate entry points and blockdatas + # - and are not included. + #dashchar.f + #dashline.f - Like the "conrec" family above, the "dash" family contains + dashsmth.f #- duplicate entry points and blockdatas. Only dashsmth is + #- included in "libncar.a". The others are redundant. + dashbd.f # blockdata for the dashsmth utility + #dashsupr.f + #ezmapg.f + gridal.f + gridt.f #- blockdata for the gridal utility + hafton.f + hfinit.f #- blockdata for the hafton utility + isosrf.f + isosrb.f #- blockdata for the isosrf utility + kurv.f #- support routines for dashsmth and isosrf + pwrity.f + pwrzi.f + pwrzs.f + pwrzt.f + srface.f + srfabd.f #- blockdata for the srface utility + #strmln.f + threed.f + threbd.f #- blockdata for the threed utility + velvct.f + veldat.f #- blockdata for the velvct utility + ; diff --git a/sys/gio/ncarutil/pwrity.f b/sys/gio/ncarutil/pwrity.f new file mode 100644 index 00000000..5685c9b7 --- /dev/null +++ b/sys/gio/ncarutil/pwrity.f @@ -0,0 +1,604 @@ + SUBROUTINE PWRITY (X,Y,ID,N,ISIZE,ITHETA,ICNT) +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C LATEST REVISION JULY 1984 +C +C PURPOSE PWRITY IS A CHARACTER PLOTTING ROUTINE. IT HAS +C SOME FEATURES NOT FOUND IN WTSTR, BUT IS NOT AS +C FANCY AS PWRITX. +C +C +C USAGE CALL PWRITY(X,Y,ID,N,ISIZE,ITHETA,ICNT) +C +C ARGUMENTS +C +C ON INPUT X,Y +C POSITIONING COORDINATES FOR THE CHARACTERS TO +C BE DRAWN. X AND Y ARE USER WORLD COORDINATES +C AND ARE SCALED ACCORDING TO THE CURRENT +C NORMALIZATION TRANSFORMATION. ALSO, SEE ICNT. +C +C ID +C CHARACTER STRING TO BE DRAWN. +C +C N +C THE NUMBER OF CHARACTERS IN ID. +C +C ISIZE +C SIZE OF THE CHARACTER: +C . IF BETWEEN 0 AND 3, ISIZE IS CHOSEN AS +C 1., 1.5, 2., OR 3. TIMES AN 8 PLOTTER +C ADDRESS CHARACTER WIDTH. +C . IF GREATER THAN 3, ISIZE IS THE CHARACTER +C WIDTH IN PLOTTER ADDRESS UNITS. +C +C ITHETA +C ANGLE, IN DEGREES, AT WHICH THE CHARACTERS ARE +C PLOTTED (COUNTER CLOCKWISE FROM THE POSITIVE +C X AXIS.) +C +C ICNT +C CENTERING OPTION: +C = -1 (X,Y) IS THE CENTER OF THE LEFT EDGE +C OF THE FIRST CHARACTER. +C = 0 (X,Y) IS THE CENTER OF THE ENTIRE +C STRING. +C = 1 (X,Y) IS THE CENTER OD THE RIGHT EDGE +C OF THE LAST CHARACTER. +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED. +C +C ENTRY POINTS PWRY, PWRYSO, PWRYGT, PWRITY, PWRYBD +C +C COMMON BLOCKS PWRCOM +C +C REQUIRED LIBRARY THE SPPS. +C + +C +C I/O PLOTS CHARACTERS. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C HISTORY IMPLEMENTED FOR USE IN DASHCHAR. +C MADE PORTABLE IN JANUARY 1977 +C FOR USE ON COMPUTER SYSTEMS WHICH +C SUPPORT PLOTTERS WITH UP TO 15 BITS RESOLUTION. +C CONVERTED TO FORTRAN77 AND GKS IN JULY, 1984. +C +C ALGORITHM DIGITIZATIONS OF THE CHARACTERS ARE STORED +C NTERNALLY AND ADJUSTED ACCORDING TO X, Y, +C ISIZE AND ICNT, THEN PLOTTED. +C +C TIMING SLOWER THAN WTSTR, FASTER THAN PWRITX. +C +C PORTABILITY FORTRAN +C +C + SAVE + CHARACTER*(*) ID + CHARACTER*1 JCHAR(46) ,KCHAR + DIMENSION INDEX(46) ,KX(494) ,KY(494) + COMMON /PWRCOM/ USABLE + LOGICAL USABLE + LOGICAL LENTRY +C +C THE FOLLOWING DATA STATEMENTS ASSOCIATE EACH CHARACTER WITH ITS +C DIGITIZATION. THAT IS, THE DIGITIZATION FOR THE CHARACTER A STARTS +C AT KX(1) AND KY(1), WHILE B STARTS AT KX(13) AND KY(13), AND SO ON. +C + DATA JCHAR( 1),INDEX( 1)/'A', 1/ + DATA JCHAR( 2),INDEX( 2)/'B', 13/ + DATA JCHAR( 3),INDEX( 3)/'C', 28/ + DATA JCHAR( 4),INDEX( 4)/'D', 40/ + DATA JCHAR( 5),INDEX( 5)/'E', 49/ + DATA JCHAR( 6),INDEX( 6)/'F', 60/ + DATA JCHAR( 7),INDEX( 7)/'G', 68/ + DATA JCHAR( 8),INDEX( 8)/'H', 82/ + DATA JCHAR( 9),INDEX( 9)/'I', 92/ + DATA JCHAR(10),INDEX(10)/'J',104/ + DATA JCHAR(11),INDEX(11)/'K',113/ + DATA JCHAR(12),INDEX(12)/'L',123/ + DATA JCHAR(13),INDEX(13)/'M',130/ + DATA JCHAR(14),INDEX(14)/'N',137/ + DATA JCHAR(15),INDEX(15)/'O',143/ + DATA JCHAR(16),INDEX(16)/'P',157/ + DATA JCHAR(17),INDEX(17)/'Q',166/ + DATA JCHAR(18),INDEX(18)/'R',182/ + DATA JCHAR(19),INDEX(19)/'S',194/ + DATA JCHAR(20),INDEX(20)/'T',210/ + DATA JCHAR(21),INDEX(21)/'U',219/ + DATA JCHAR(22),INDEX(22)/'V',229/ + DATA JCHAR(23),INDEX(23)/'W',236/ + DATA JCHAR(24),INDEX(24)/'X',245/ + DATA JCHAR(25),INDEX(25)/'Y',252/ + DATA JCHAR(26),INDEX(26)/'Z',262/ + DATA JCHAR(27),INDEX(27)/'0',273/ + DATA JCHAR(28),INDEX(28)/'1',286/ + DATA JCHAR(29),INDEX(29)/'2',296/ + DATA JCHAR(30),INDEX(30)/'3',308/ + DATA JCHAR(31),INDEX(31)/'4',326/ + DATA JCHAR(32),INDEX(32)/'5',339/ + DATA JCHAR(33),INDEX(33)/'6',352/ + DATA JCHAR(34),INDEX(34)/'7',368/ + DATA JCHAR(35),INDEX(35)/'8',378/ + DATA JCHAR(36),INDEX(36)/'9',398/ + DATA JCHAR(37),INDEX(37)/'+',414/ + DATA JCHAR(38),INDEX(38)/'-',423/ + DATA JCHAR(39),INDEX(39)/'*',429/ + DATA JCHAR(40),INDEX(40)/'/',444/ + DATA JCHAR(41),INDEX(41)/'(',448/ + DATA JCHAR(42),INDEX(42)/')',456/ + DATA JCHAR(43),INDEX(43)/'=',464/ + DATA JCHAR(44),INDEX(44)/' ',473/ + DATA JCHAR(45),INDEX(45)/',',476/ + DATA JCHAR(46),INDEX(46)/'.',486/ +C +C THE FOLLOWING DATA STATEMENTS CONTAIN THE DIGITIZATIONS OF THE +C CHARACTERS. THE CHARACTERS ARE DIGITIZED ON A BOX 6 UNITS WIDE AND +C 7 UNITS TALL. THIS INCLUDES 2 UNITS OF WHITE SPACE TO THE RIGHT OF +C EACH CHARACTER. IF KX=7, KY IS A FLAG -- KY=0 MEANS THE FOLLOWING +C KX AND KY ARE A PEN UP MOVE (ALL OTHERS ARE PEN DOWN MOVES), AND +C KY=7 MEANS THAT THE END OF THE DIGITIZATION FOR A PARTICULAR CHARAC- +C TER HAS BEEN REACHED. +C + DATA WIDE,HIGH,WHITE/6.,7.,2./ +C + DATA KX( 1),KX( 2),KX( 3),KX( 4),KX( 5),KX( 6)/0,4,7,0,0,1/ + DATA KY( 1),KY( 2),KY( 3),KY( 4),KY( 5),KY( 6)/3,3,0,3,6,7/ + DATA KX( 7),KX( 8),KX( 9),KX( 10),KX( 11),KX( 12)/3,4,4,7,6,7/ + DATA KY( 7),KY( 8),KY( 9),KY( 10),KY( 11),KY( 12)/7,6,0,0,0,7/ + DATA KX( 13),KX( 14),KX( 15),KX( 16),KX( 17),KX( 18)/0,3,4,4,3,0/ + DATA KY( 13),KY( 14),KY( 15),KY( 16),KY( 17),KY( 18)/7,7,6,5,4,4/ + DATA KX( 19),KX( 20),KX( 21),KX( 22),KX( 23),KX( 24)/7,3,4,4,3,0/ + DATA KY( 19),KY( 20),KY( 21),KY( 22),KY( 23),KY( 24)/0,4,3,1,0,0/ + DATA KX( 25),KX( 26),KX( 27),KX( 28),KX( 29),KX( 30)/7,6,7,7,4,3/ + DATA KY( 25),KY( 26),KY( 27),KY( 28),KY( 29),KY( 30)/0,0,7,0,6,7/ + DATA KX( 31),KX( 32),KX( 33),KX( 34),KX( 35),KX( 36)/1,0,0,1,3,4/ + DATA KY( 31),KY( 32),KY( 33),KY( 34),KY( 35),KY( 36)/7,6,1,0,0,1/ + DATA KX( 37),KX( 38),KX( 39),KX( 40),KX( 41),KX( 42)/7,6,7,0,3,4/ + DATA KY( 37),KY( 38),KY( 39),KY( 40),KY( 41),KY( 42)/0,0,7,7,7,6/ + DATA KX( 43),KX( 44),KX( 45),KX( 46),KX( 47),KX( 48)/4,3,0,7,6,7/ + DATA KY( 43),KY( 44),KY( 45),KY( 46),KY( 47),KY( 48)/1,0,0,0,0,7/ + DATA KX( 49),KX( 50),KX( 51),KX( 52),KX( 53),KX( 54)/0,4,7,3,0,7/ + DATA KY( 49),KY( 50),KY( 51),KY( 52),KY( 53),KY( 54)/7,7,0,4,4,0/ + DATA KX( 55),KX( 56),KX( 57),KX( 58),KX( 59),KX( 60)/0,4,7,6,7,0/ + DATA KY( 55),KY( 56),KY( 57),KY( 58),KY( 59),KY( 60)/0,0,0,0,7,7/ + DATA KX( 61),KX( 62),KX( 63),KX( 64),KX( 65),KX( 66)/4,7,0,3,7,6/ + DATA KY( 61),KY( 62),KY( 63),KY( 64),KY( 65),KY( 66)/7,0,4,4,0,0/ + DATA KX( 67),KX( 68),KX( 69),KX( 70),KX( 71),KX( 72)/7,7,4,3,1,0/ + DATA KY( 67),KY( 68),KY( 69),KY( 70),KY( 71),KY( 72)/7,0,6,7,7,6/ + DATA KX( 73),KX( 74),KX( 75),KX( 76),KX( 77),KX( 78)/0,1,3,4,4,3/ + DATA KY( 73),KY( 74),KY( 75),KY( 76),KY( 77),KY( 78)/1,0,0,1,3,3/ + DATA KX( 79),KX( 80),KX( 81),KX( 82),KX( 83),KX( 84)/7,6,7,0,7,0/ + DATA KY( 79),KY( 80),KY( 81),KY( 82),KY( 83),KY( 84)/0,0,7,7,0,4/ + DATA KX( 85),KX( 86),KX( 87),KX( 88),KX( 89),KX( 90)/4,7,4,4,7,6/ + DATA KY( 85),KY( 86),KY( 87),KY( 88),KY( 89),KY( 90)/4,0,7,0,0,0/ + DATA KX( 91),KX( 92),KX( 93),KX( 94),KX( 95),KX( 96)/7,7,1,3,7,2/ + DATA KY( 91),KY( 92),KY( 93),KY( 94),KY( 95),KY( 96)/7,0,7,7,0,7/ + DATA KX( 97),KX( 98),KX( 99),KX(100),KX(101),KX(102)/2,7,1,3,7,6/ + DATA KY( 97),KY( 98),KY( 99),KY(100),KY(101),KY(102)/0,0,0,0,0,0/ + DATA KX(103),KX(104),KX(105),KX(106),KX(107),KX(108)/7,7,0,1,3,4/ + DATA KY(103),KY(104),KY(105),KY(106),KY(107),KY(108)/7,0,1,0,0,1/ + DATA KX(109),KX(110),KX(111),KX(112),KX(113),KX(114)/4,7,6,7,0,7/ + DATA KY(109),KY(110),KY(111),KY(112),KY(113),KY(114)/7,0,0,7,7,0/ + DATA KX(115),KX(116),KX(117),KX(118),KX(119),KX(120)/0,4,7,2,4,7/ + DATA KY(115),KY(116),KY(117),KY(118),KY(119),KY(120)/3,7,0,5,0,0/ + DATA KX(121),KX(122),KX(123),KX(124),KX(125),KX(126)/6,7,7,0,0,4/ + DATA KY(121),KY(122),KY(123),KY(124),KY(125),KY(126)/0,7,0,7,0,0/ + DATA KX(127),KX(128),KX(129),KX(130),KX(131),KX(132)/7,6,7,0,2,4/ + DATA KY(127),KY(128),KY(129),KY(130),KY(131),KY(132)/0,0,7,7,3,7/ + DATA KX(133),KX(134),KX(135),KX(136),KX(137),KX(138)/4,7,6,7,0,4/ + DATA KY(133),KY(134),KY(135),KY(136),KY(137),KY(138)/0,0,0,7,7,0/ + DATA KX(139),KX(140),KX(141),KX(142),KX(143),KX(144)/4,7,6,7,4,7/ + DATA KY(139),KY(140),KY(141),KY(142),KY(143),KY(144)/7,0,0,7,7,0/ + DATA KX(145),KX(146),KX(147),KX(148),KX(149),KX(150)/4,4,3,1,0,0/ + DATA KY(145),KY(146),KY(147),KY(148),KY(149),KY(150)/1,6,7,7,6,1/ + DATA KX(151),KX(152),KX(153),KX(154),KX(155),KX(156)/1,3,4,7,6,7/ + DATA KY(151),KY(152),KY(153),KY(154),KY(155),KY(156)/0,0,1,0,0,7/ + DATA KX(157),KX(158),KX(159),KX(160),KX(161),KX(162)/0,3,4,4,3,0/ + DATA KY(157),KY(158),KY(159),KY(160),KY(161),KY(162)/7,7,6,5,4,4/ + DATA KX(163),KX(164),KX(165),KX(166),KX(167),KX(168)/7,6,7,7,0,0/ + DATA KY(163),KY(164),KY(165),KY(166),KY(167),KY(168)/0,0,7,0,1,6/ + DATA KX(169),KX(170),KX(171),KX(172),KX(173),KX(174)/1,3,4,4,3,1/ + DATA KY(169),KY(170),KY(171),KY(172),KY(173),KY(174)/7,7,6,1,0,0/ + DATA KX(175),KX(176),KX(177),KX(178),KX(179),KX(180)/0,7,2,4,7,6/ + DATA KY(175),KY(176),KY(177),KY(178),KY(179),KY(180)/1,0,2,0,0,0/ + DATA KX(181),KX(182),KX(183),KX(184),KX(185),KX(186)/7,0,3,4,4,3/ + DATA KY(181),KY(182),KY(183),KY(184),KY(185),KY(186)/7,7,7,6,5,4/ + DATA KX(187),KX(188),KX(189),KX(190),KX(191),KX(192)/0,7,2,4,7,6/ + DATA KY(187),KY(188),KY(189),KY(190),KY(191),KY(192)/4,0,4,0,0,0/ + DATA KX(193),KX(194),KX(195),KX(196),KX(197),KX(198)/7,7,0,1,3,4/ + DATA KY(193),KY(194),KY(195),KY(196),KY(197),KY(198)/7,0,1,0,0,1/ + DATA KX(199),KX(200),KX(201),KX(202),KX(203),KX(204)/4,3,1,0,0,1/ + DATA KY(199),KY(200),KY(201),KY(202),KY(203),KY(204)/3,4,4,5,6,7/ + DATA KX(205),KX(206),KX(207),KX(208),KX(209),KX(210)/3,4,7,6,7,7/ + DATA KY(205),KY(206),KY(207),KY(208),KY(209),KY(210)/7,6,0,0,7,0/ + DATA KX(211),KX(212),KX(213),KX(214),KX(215),KX(216)/0,4,7,2,2,7/ + DATA KY(211),KY(212),KY(213),KY(214),KY(215),KY(216)/7,7,0,7,0,0/ + DATA KX(217),KX(218),KX(219),KX(220),KX(221),KX(222)/6,7,7,0,0,1/ + DATA KY(217),KY(218),KY(219),KY(220),KY(221),KY(222)/0,7,0,7,1,0/ + DATA KX(223),KX(224),KX(225),KX(226),KX(227),KX(228)/3,4,4,7,6,7/ + DATA KY(223),KY(224),KY(225),KY(226),KY(227),KY(228)/0,1,7,0,0,7/ + DATA KX(229),KX(230),KX(231),KX(232),KX(233),KX(234)/7,0,2,4,7,6/ + DATA KY(229),KY(230),KY(231),KY(232),KY(233),KY(234)/0,7,0,7,0,0/ + DATA KX(235),KX(236),KX(237),KX(238),KX(239),KX(240)/7,7,0,0,2,4/ + DATA KY(235),KY(236),KY(237),KY(238),KY(239),KY(240)/7,0,7,0,4,0/ + DATA KX(241),KX(242),KX(243),KX(244),KX(245),KX(246)/4,7,6,7,4,7/ + DATA KY(241),KY(242),KY(243),KY(244),KY(245),KY(246)/7,0,0,7,7,0/ + DATA KX(247),KX(248),KX(249),KX(250),KX(251),KX(252)/0,4,7,6,7,7/ + DATA KY(247),KY(248),KY(249),KY(250),KY(251),KY(252)/7,0,0,0,7,0/ + DATA KX(253),KX(254),KX(255),KX(256),KX(257),KX(258)/0,2,4,7,2,2/ + DATA KY(253),KY(254),KY(255),KY(256),KY(257),KY(258)/7,4,7,0,4,0/ + DATA KX(259),KX(260),KX(261),KX(262),KX(263),KX(264)/7,6,7,7,3,1/ + DATA KY(259),KY(260),KY(261),KY(262),KY(263),KY(264)/0,0,7,0,4,4/ + DATA KX(265),KX(266),KX(267),KX(268),KX(269),KX(270)/7,0,4,0,4,7/ + DATA KY(265),KY(266),KY(267),KY(268),KY(269),KY(270)/0,7,7,0,0,0/ + DATA KX(271),KX(272),KX(273),KX(274),KX(275),KX(276)/6,7,7,4,3,1/ + DATA KY(271),KY(272),KY(273),KY(274),KY(275),KY(276)/0,7,0,1,0,0/ + DATA KX(277),KX(278),KX(279),KX(280),KX(281),KX(282)/0,0,1,3,4,4/ + DATA KY(277),KY(278),KY(279),KY(280),KY(281),KY(282)/1,6,7,7,6,1/ + DATA KX(283),KX(284),KX(285),KX(286),KX(287),KX(288)/7,6,7,7,1,2/ + DATA KY(283),KY(284),KY(285),KY(286),KY(287),KY(288)/0,0,7,0,6,7/ + DATA KX(289),KX(290),KX(291),KX(292),KX(293),KX(294)/2,7,1,3,7,6/ + DATA KY(289),KY(290),KY(291),KY(292),KY(293),KY(294)/0,0,0,0,0,0/ + DATA KX(295),KX(296),KX(297),KX(298),KX(299),KX(300)/7,7,0,1,3,4/ + DATA KY(295),KY(296),KY(297),KY(298),KY(299),KY(300)/7,0,6,7,7,6/ + DATA KX(301),KX(302),KX(303),KX(304),KX(305),KX(306)/4,0,0,4,7,6/ + DATA KY(301),KY(302),KY(303),KY(304),KY(305),KY(306)/5,1,0,0,0,0/ + DATA KX(307),KX(308),KX(309),KX(310),KX(311),KX(312)/7,7,0,1,3,4/ + DATA KY(307),KY(308),KY(309),KY(310),KY(311),KY(312)/7,0,6,7,7,6/ + DATA KX(313),KX(314),KX(315),KX(316),KX(317),KX(318)/4,3,1,7,3,4/ + DATA KY(313),KY(314),KY(315),KY(316),KY(317),KY(318)/5,4,4,0,4,3/ + DATA KX(319),KX(320),KX(321),KX(322),KX(323),KX(324)/4,3,1,0,7,6/ + DATA KY(319),KY(320),KY(321),KY(322),KY(323),KY(324)/1,0,0,1,0,0/ + DATA KX(325),KX(326),KX(327),KX(328),KX(329),KX(330)/7,7,3,3,2,0/ + DATA KY(325),KY(326),KY(327),KY(328),KY(329),KY(330)/7,0,0,7,7,4/ + DATA KX(331),KX(332),KX(333),KX(334),KX(335),KX(336)/0,4,7,2,4,7/ + DATA KY(331),KY(332),KY(333),KY(334),KY(335),KY(336)/3,3,0,0,0,0/ + DATA KX(337),KX(338),KX(339),KX(340),KX(341),KX(342)/6,7,7,0,1,3/ + DATA KY(337),KY(338),KY(339),KY(340),KY(341),KY(342)/0,7,0,1,0,0/ + DATA KX(343),KX(344),KX(345),KX(346),KX(347),KX(348)/4,4,3,0,0,4/ + DATA KY(343),KY(344),KY(345),KY(346),KY(347),KY(348)/1,3,4,4,7,7/ + DATA KX(349),KX(350),KX(351),KX(352),KX(353),KX(354)/7,6,7,7,4,3/ + DATA KY(349),KY(350),KY(351),KY(352),KY(353),KY(354)/0,0,7,0,6,7/ + DATA KX(355),KX(356),KX(357),KX(358),KX(359),KX(360)/1,0,0,1,3,4/ + DATA KY(355),KY(356),KY(357),KY(358),KY(359),KY(360)/7,6,1,0,0,1/ + DATA KX(361),KX(362),KX(363),KX(364),KX(365),KX(366)/4,3,1,0,7,6/ + DATA KY(361),KY(362),KY(363),KY(364),KY(365),KY(366)/3,4,4,3,0,0/ + DATA KX(367),KX(368),KX(369),KX(370),KX(371),KX(372)/7,7,0,0,4,4/ + DATA KY(367),KY(368),KY(369),KY(370),KY(371),KY(372)/7,0,6,7,7,6/ + DATA KX(373),KX(374),KX(375),KX(376),KX(377),KX(378)/2,2,7,6,7,7/ + DATA KY(373),KY(374),KY(375),KY(376),KY(377),KY(378)/1,0,0,0,7,0/ + DATA KX(379),KX(380),KX(381),KX(382),KX(383),KX(384)/1,0,0,1,3,4/ + DATA KY(379),KY(380),KY(381),KY(382),KY(383),KY(384)/4,5,6,7,7,6/ + DATA KX(385),KX(386),KX(387),KX(388),KX(389),KX(390)/4,3,1,0,0,1/ + DATA KY(385),KY(386),KY(387),KY(388),KY(389),KY(390)/5,4,4,3,1,0/ + DATA KX(391),KX(392),KX(393),KX(394),KX(395),KX(396)/3,4,4,3,7,6/ + DATA KY(391),KY(392),KY(393),KY(394),KY(395),KY(396)/0,1,3,4,0,0/ + DATA KX(397),KX(398),KX(399),KX(400),KX(401),KX(402)/7,7,0,1,3,4/ + DATA KY(397),KY(398),KY(399),KY(400),KY(401),KY(402)/7,0,1,0,0,1/ + DATA KX(403),KX(404),KX(405),KX(406),KX(407),KX(408)/4,3,1,0,0,1/ + DATA KY(403),KY(404),KY(405),KY(406),KY(407),KY(408)/6,7,7,6,4,3/ + DATA KX(409),KX(410),KX(411),KX(412),KX(413),KX(414)/3,4,7,6,7,7/ + DATA KY(409),KY(410),KY(411),KY(412),KY(413),KY(414)/3,4,0,0,7,0/ + DATA KX(415),KX(416),KX(417),KX(418),KX(419),KX(420)/0,4,7,2,2,7/ + DATA KY(415),KY(416),KY(417),KY(418),KY(419),KY(420)/3,3,0,5,1,0/ + DATA KX(421),KX(422),KX(423),KX(424),KX(425),KX(426)/6,7,7,0,4,7/ + DATA KY(421),KY(422),KY(423),KY(424),KY(425),KY(426)/0,7,0,3,3,0/ + DATA KX(427),KX(428),KX(429),KX(430),KX(431),KX(432)/6,7,7,0,4,7/ + DATA KY(427),KY(428),KY(429),KY(430),KY(431),KY(432)/0,7,0,1,5,0/ + DATA KX(433),KX(434),KX(435),KX(436),KX(437),KX(438)/2,2,7,4,0,7/ + DATA KY(433),KY(434),KY(435),KY(436),KY(437),KY(438)/5,1,0,3,3,0/ + DATA KX(439),KX(440),KX(441),KX(442),KX(443),KX(444)/0,4,7,6,7,4/ + DATA KY(439),KY(440),KY(441),KY(442),KY(443),KY(444)/5,1,0,0,7,7/ + DATA KX(445),KX(446),KX(447),KX(448),KX(449),KX(450)/7,6,7,7,3,2/ + DATA KY(445),KY(446),KY(447),KY(448),KY(449),KY(450)/0,0,7,1,7,6/ + DATA KX(451),KX(452),KX(453),KX(454),KX(455),KX(456)/2,3,7,6,7,7/ + DATA KY(451),KY(452),KY(453),KY(454),KY(455),KY(456)/1,0,0,0,7,0/ + DATA KX(457),KX(458),KX(459),KX(460),KX(461),KX(462)/1,2,2,1,7,6/ + DATA KY(457),KY(458),KY(459),KY(460),KY(461),KY(462)/7,6,1,0,0,0/ + DATA KX(463),KX(464),KX(465),KX(466),KX(467),KX(468)/7,7,4,0,7,0/ + DATA KY(463),KY(464),KY(465),KY(466),KY(467),KY(468)/7,0,5,5,0,2/ + DATA KX(469),KX(470),KX(471),KX(472),KX(473),KX(474)/4,7,6,7,7,6/ + DATA KY(469),KY(470),KY(471),KY(472),KY(473),KY(474)/2,0,0,7,0,0/ + DATA KX(475),KX(476),KX(477),KX(478),KX(479),KX(480)/7,7,1,2,2,1/ + DATA KY(475),KY(476),KY(477),KY(478),KY(479),KY(480)/7,0,0,1,2,2/ + DATA KX(481),KX(482),KX(483),KX(484),KX(485),KX(486)/1,2,7,6,7,7/ + DATA KY(481),KY(482),KY(483),KY(484),KY(485),KY(486)/1,1,0,0,7,0/ + DATA KX(487),KX(488),KX(489),KX(490),KX(491),KX(492)/2,1,1,2,2,7/ + DATA KY(487),KY(488),KY(489),KY(490),KY(491),KY(492)/0,0,1,1,0,0/ + DATA KX(493),KX(494) /6,7 / + DATA KY(493),KY(494) /0,7 / +C +C NSIZE IS THE LENGTH OF JCHAR AND INDEX. +C LEN IS THE LENGTH OF KX AND KY. +C LENTRY TELLS IF THIS IS THE FIRTST CALL TO PWRY. +C LRES IS THE NUMBER OF BITS OF ACCURACY USED FOR INTEGER INPUT TO +C THE SYSTEM PLOT PACKAGE. +C + DATA NSIZE/46/ +c Variable LEN not used. +c DATA LEN/494/ + DATA LENTRY/.FALSE./ + DATA LRES/15/ + DATA DEGRAD/0.017453293/ + IF (USABLE) GO TO 101 +C +C THIS IS A PWRITY CALL +C + CALL Q8QST4 ('GRAPHX','PWRITY','PWRITY','VERSION 1') + 101 USABLE = .FALSE. +C +C SEE IF THIS IS THE FIRST CALL TO PWRITY. +C + IF (LENTRY) GO TO 103 +C +C MARK THAT FUTURE CALLS NEED NOT DO THIS CODE. +C + LENTRY = .TRUE. +C +C RECORD THE LOCATION OF THE BLANK SO IT CAN BE USED FOR UNKNOWN +C CHARACTERS. +C + IBLKPT = INDEX(44) +C +C SORT JCHAR MAINTAINING THE RELATIONSHIP BETWEEN JCHAR AND INDEX. +C (THAT IS, IF JCHAR(I)='B', THEN INDEX(I)=13 FROM THE ABOVE DATA STMT.) +C THIS WILL ENABLE CHARACTERS TO BE QUICKLY FOUND IN ALL SUBSEQUENT +C CALLS TO PWRY. +C + CALL PWRYSO (JCHAR,INDEX,NSIZE) +C +C ALL ONE-TIME INITIALIZATION NOW FINISHED. +C +C TRANSFORM THE INPUT COORDINATES TO INTEGER SPACE. +C + 103 CALL FL2INT (X,Y,IX,IY) +C + NN = N + IF (NN .LE. 0) GO TO 113 + FNNM1 = NN-1 + JCNT = ICNT +C +C GET USER SET RESOLUTION. +C + CALL GETUSV ('XF',LXSAVE) + CALL GETUSV ('YF',LYSAVE) +C +C PUT RELATIVE SIZE IN Q. +C + Q = ISIZE + IF (Q .LE. 3.) GO TO 104 + Q = Q/FLOAT(ISHIFT(6,LXSAVE-10)) + GO TO 105 + 104 Q = (1.+.5*(FLOAT(IFIX(Q)+IFIX(Q)/3)))*4./3. + 105 Q = Q*FLOAT(ISHIFT(1,LRES-10)) +C +C CALCULATE COMBINED TRANSFORMATION. +C + THETA = FLOAT(ITHETA)*DEGRAD + CT = Q*COS(THETA) + ST = Q*SIN(THETA) +C +C FIND PLOTTER ADDRESS COORDINATES FOR BEGINNING. +C + XC = IX + YC = IY +C +C CORRECT FOR CHARACTER DATA BEING LOWER-LEFT-HAND POSITIONED. +C + XC = XC-WHITE*CT+HIGH*.5*ST + YC = YC-WHITE*ST-HIGH*.5*CT +C +C CORRECT FOR CENTERING IF TURNED ON. +C + JCENT = MAX0(-1,MIN0(1,JCNT))+2 + GO TO (107,106,108),JCENT + 106 XC = XC-CT*FNNM1*WIDE*.5 + YC = YC-ST*FNNM1*WIDE*.5 + GO TO 109 + 107 XC = XC+CT*WHITE + YC = YC+ST*WHITE + GO TO 109 + 108 XC = XC-CT*WHITE + YC = YC-ST*WHITE + XC = XC-CT*FNNM1*WIDE + YC = YC-ST*FNNM1*WIDE +C +C SET PLOTTER TO STARTING POINT. +C + 109 CALL PLOTIT (IFIX(XC),IFIX(YC),0) +C +C PLOT ALL THE CHARACTERS IN THE INPUT STRING. +C + DO 112 K=1,NN + YB = YC + XB = XC + IP = 1 +C +C EXTRACT CHARACTER NUMBER K FROM THE STRING. +C + KCHAR = ID(K:K) +C +C FIND THE TABLE ENTRY. +C + CALL PWRYGT (KCHAR,JCHAR,INDEX,NSIZE,IPOINT) + IF (IPOINT .EQ. -1) IPOINT = IBLKPT +C +C DRAW INDIVIDUAL CHARACTER. +C + L = 0 + 110 ISUB = IPOINT+L + NX = KX(ISUB) + FNX = NX + NY = KY(ISUB) + FNY = NY + L = L+1 +C +C TEST FOR OP-CODE OR DX AND DY. +C + IF (NX .NE. 7) GO TO 111 +C +C OP-CODE +C + IP = 0 + IF (NY-7) 110,112,110 +C +C DX AND DY +C + 111 XC = XB+FNX*CT-FNY*ST + YC = YB+FNX*ST+FNY*CT +C +C CALL PLOTTING ROUTINE. MODE DETERMINED BY OP-CODE. +C + CALL PLOTIT (IFIX(XC+.5),IFIX(YC+.5),IP) + IP = 1 + GO TO 110 + 112 CONTINUE +C + 113 CONTINUE +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(0,0,0) + RETURN + END + SUBROUTINE PWRYSO (JCHAR,INDEX,NSIZE) +C +C THIS ROUTINE SORTS JCHAR WHICH IS NSIZE IN LENGTH. THE RELATIONSHIP +C BETWEEN JCHAR AND INDEX IS MAINTAINED. A BUBBLE SORT IS USED. +C JCHAR IS SORTED IN ASCENDING ORDER. +C + SAVE + CHARACTER*1 JCHAR(NSIZE) ,JTEMP ,KTEMP + DIMENSION INDEX(NSIZE) + LOGICAL LDONE +C + ISTART = 1 + ISTOP = NSIZE + ISTEP = 1 +C +C AT MOST NSIZE PASSES ARE NEEDED. +C + DO 104 NPASS=1,NSIZE + LDONE = .TRUE. + I = ISTART + 101 ISUB = I+ISTEP + IF (ISTEP*(ICHAR(JCHAR(I))-ICHAR(JCHAR(ISUB)))) 103,103,102 +C +C THEY NEED TO BE SWITCHED. +C + 102 LDONE = .FALSE. + JTEMP = JCHAR(I) + KTEMP = JCHAR(ISUB) + JCHAR(I) = KTEMP + JCHAR(ISUB) = JTEMP + ITEMP = INDEX(I) + INDEX(I) = INDEX(ISUB) + INDEX(ISUB) = ITEMP +C +C THEY DO NOT NEED TO BE SWITCHED. +C + 103 I = I+ISTEP + IF (I .NE. ISTOP) GO TO 101 +C +C IF NONE WERE SWITCHED DURING THIS PASS, WE CAN QUIT. +C + IF (LDONE) RETURN +C +C SET UP FOR THE NEXT PASS IN THE OTHER DIRECTION. +C + ISTEP = -ISTEP + ITEMP = ISTART + ISTART = ISTOP+ISTEP + ISTOP = ITEMP + 104 CONTINUE + RETURN + END + SUBROUTINE PWRYGT (KCHAR,JCHAR,INDEX,NSIZE,IPOINT) +C +C THIS ROUTINE FINDS WHERE KCHAR IS IN JCHAR AND RETURNS THE CORRES- +C PONDING INDEX IN IPOINT. BINARY HALVING IS USED. +C + SAVE + CHARACTER*1 JCHAR(NSIZE) ,KCHAR + DIMENSION INDEX(NSIZE) +C +C IT IS ASSUMED THAT JCHAR IS LESS THAT 2**9 IN LENGTH, SO IF KCHAR IS +C NOT FOUND IN 10 STEPS, THE SEARCH IS STOPPED. +C + KOUNT = 0 + IBOT = 1 + ITOP = NSIZE + I = ITOP + GO TO 102 + 101 I = (IBOT+ITOP)/2 + KOUNT = KOUNT+1 + IF (KOUNT .GT. 10) GO TO 106 + 102 IF (ICHAR(JCHAR(I))-ICHAR(KCHAR)) 103,105,104 + 103 IBOT = I + GO TO 101 + 104 ITOP = I + GO TO 101 + 105 IPOINT = INDEX(I) + RETURN +C +C IPOINT=-1 MEANS THAT KCHAR WAS NOT IN THE TABLE. +C + 106 IPOINT = -1 + RETURN + END + SUBROUTINE PWRY (X,Y,ID,N,SIZE,THETA,ICNT) +C +C PWRY IS AN OLD ENTRY POINT AND HAS BEEN REMOVED - USE PWRITY +C ENTRY POINT +C +C +NOAO - FTN writes and format statements commented out. +C WRITE (I1MACH(4),1001) +C WRITE (I1MACH(4),1002) +C STOP +C +C1001 FORMAT ('1'//////////) +C1002 FORMAT (' ****************************************'/ +C 1 ' * *'/ +C 2 ' * *'/ +C 3 ' * THE ENTRY POINT PWRY IS NO LONGER *'/ +C 4 ' * SUPPORTED. PLEASE USE THE MORE *'/ +C 5 ' * RECENT VERSION PWRITY. *'/ +C 6 ' * *'/ +C 7 ' * *'/ +C 8 ' ****************************************') +C -NOAO + END +C +NOAO - Blockdata rewritten as subroutine +C BLOCKDATA PWRYBD + subroutine pwrybd + COMMON /PWRCOM/ USABLE + LOGICAL USABLE +C DATA USABLE/.FALSE./ + usable = .false. +C -NOAO +C REVISION HISTORY------ +C FEBURARY 1979 CREATED NEW ALGORITHM PWRITY TO REPLACE PWRY +C ADDED REVISION HISTORY +C JUNE 1979 CHANGE ARGUMENT THETA IN PWRITY FROM FLOATING TO +C INTEGER, USING ITHETA AS THE NEW NAME. ITS +C MEANING IS NOW DEGREES INSTEAD OF RADIANS. +C JULY 1984 CONVERTED TO FORTRAN 77 AND GKS +C----------------------------------------------------------------------- + END diff --git a/sys/gio/ncarutil/pwrzi.f b/sys/gio/ncarutil/pwrzi.f new file mode 100644 index 00000000..d49b9ff5 --- /dev/null +++ b/sys/gio/ncarutil/pwrzi.f @@ -0,0 +1,732 @@ + SUBROUTINE PWRZI (X,Y,Z,ID,N,ISIZE,LIN3,ITOP,ICNT) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE PWRZI IS A CHARACTER PLOTTING ROUTINE FOR +C PLOTTING CHARACTERS IN THREE-SPACE WHEN USING +C ISOSRF. FOR A LARGE CLASS OF +C POSSIBLE POSITIONS, THE HIDDEN CHARACTER +C PROBLEM IS SOLVED. +C +C PWRZI WILL NOT WORK WITH ISOSRFHR. +C +C +C USAGE CALL PWRZI (X,Y,Z,ID,N,ISIZE,LINE,ITOP,ICNT) +C USE CALL PWRZI AFTER CALLING +C ISOSRF AND BEFORE CALLING FRAME. +C +C ARGUMENTS +C +C ON INPUT X,Y,Z +C POSITIONING COORDINATES FOR THE CHARACTERS +C TO BE DRAWN. THESE ARE FLOATING POINT +C NUMBERS IN THE SAME THREE-SPACE AS USED IN +C ISOSRF. +C +C ID +C CHARACTER STRING TO BE DRAWN. ID IS OF TYPE +C CHARACTER . +C +C N +C THE NUMBER OF CHARACTERS IN ID. +C +C ISIZE +C SIZE OF THE CHARACTER: +C . IF BETWEEN 0 AND 3, ISIZE IS 1., 1.5, +C 2., OR 3. TIMES A STANDARD WIDTH EQUAL +C TO 1/128TH OF THE SCREEN WIDTH. +C . IF GREATER THAN 3, ISIZE IS THE CHARACTER +C WIDTH IN PLOTTER ADDRESS UNITS. +C +C LINE +C THE DIRECTION IN WHICH THE CHARACTERS ARE TO +C BE WRITTEN. +C 1 = +X -1 = -X +C 2 = +Y -2 = -Y +C 3 = +Z -3 = -Z +C +C ITOP +C THE DIRECTION FROM THE CENTER OF THE FIRST +C CHARACTER TO THE TOP OF THE FIRST +C CHARACTER (THE POTENTIAL VALUES FOR +C ITOP ARE THE SAME AS THOSE FOR LINE AS +C GIVEN ABOVE.) NOTE THAT LINE CANNOT +C EQUAL ITOP EVEN IN ABSOLUTE VALUE. +C +C ICNT +C CENTERING OPTION. +C -1 (X,Y,Z) IS THE CENTER OF THE LEFT EDGE OF +C THE FIRST CHARACTER. +C 0 (X,Y,Z) IS THE CENTER OF THE ENTIRE +C STRING. +C 1 (X,Y,Z) IS THE CENTER OF THE RIGHT EDGE +C OF THE LAST CHARACTER. +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED. +C +C NOTE THE HIDDEN CHARACTER PROBLEM IS SOLVED +C CORRECTLY FOR CHARACTERS NEAR (BUT NOT INSIDE) +C THE THREE-SPACE OBJECT. +C +C ENTRY POINTS PWRZI, INITZI, PWRZOI, PWRZGI +C +C COMMON BLOCKS PWRZ1I,PWRZ2I +C +C I/O PLOTS CHARACTER(S) +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY ISOSRF, THE ERPRT77 PACKAGE, AND THE SPPS +C ROUTINES +C +C LANGUAGE FORTRAN +C +C HISTORY IMPLEMENTED FOR USE WITH ISOSRF. +C +C +C +C +C*********************************************************************** +C + SAVE + CHARACTER*(*) ID + CHARACTER*1 JCHAR(46) ,KCHAR + DIMENSION INDEX(46) ,KX(494) ,KY(494) + LOGICAL LENTRY +C +C THE FOLLOWING DATA STATEMENTS ASSOCIATE EACH CHARACTER WITH ITS +C DIGITIZATION. THAT IS, THE DIGITIZATION FOR THE CHARACTER A STARTS +C AT KX(1) AND KY(1), WHILE B STARTS AT KX(13) AND KY(13), AND SO ON. +C + DATA JCHAR( 1),INDEX( 1)/'A', 1/ + DATA JCHAR( 2),INDEX( 2)/'B', 13/ + DATA JCHAR( 3),INDEX( 3)/'C', 28/ + DATA JCHAR( 4),INDEX( 4)/'D', 40/ + DATA JCHAR( 5),INDEX( 5)/'E', 49/ + DATA JCHAR( 6),INDEX( 6)/'F', 60/ + DATA JCHAR( 7),INDEX( 7)/'G', 68/ + DATA JCHAR( 8),INDEX( 8)/'H', 82/ + DATA JCHAR( 9),INDEX( 9)/'I', 92/ + DATA JCHAR(10),INDEX(10)/'J',104/ + DATA JCHAR(11),INDEX(11)/'K',113/ + DATA JCHAR(12),INDEX(12)/'L',123/ + DATA JCHAR(13),INDEX(13)/'M',130/ + DATA JCHAR(14),INDEX(14)/'N',137/ + DATA JCHAR(15),INDEX(15)/'O',143/ + DATA JCHAR(16),INDEX(16)/'P',157/ + DATA JCHAR(17),INDEX(17)/'Q',166/ + DATA JCHAR(18),INDEX(18)/'R',182/ + DATA JCHAR(19),INDEX(19)/'S',194/ + DATA JCHAR(20),INDEX(20)/'T',210/ + DATA JCHAR(21),INDEX(21)/'U',219/ + DATA JCHAR(22),INDEX(22)/'V',229/ + DATA JCHAR(23),INDEX(23)/'W',236/ + DATA JCHAR(24),INDEX(24)/'X',245/ + DATA JCHAR(25),INDEX(25)/'Y',252/ + DATA JCHAR(26),INDEX(26)/'Z',262/ + DATA JCHAR(27),INDEX(27)/'0',273/ + DATA JCHAR(28),INDEX(28)/'1',286/ + DATA JCHAR(29),INDEX(29)/'2',296/ + DATA JCHAR(30),INDEX(30)/'3',308/ + DATA JCHAR(31),INDEX(31)/'4',326/ + DATA JCHAR(32),INDEX(32)/'5',339/ + DATA JCHAR(33),INDEX(33)/'6',352/ + DATA JCHAR(34),INDEX(34)/'7',368/ + DATA JCHAR(35),INDEX(35)/'8',378/ + DATA JCHAR(36),INDEX(36)/'9',398/ + DATA JCHAR(37),INDEX(37)/'+',414/ + DATA JCHAR(38),INDEX(38)/'-',423/ + DATA JCHAR(39),INDEX(39)/'*',429/ + DATA JCHAR(40),INDEX(40)/'/',444/ + DATA JCHAR(41),INDEX(41)/'(',448/ + DATA JCHAR(42),INDEX(42)/')',456/ + DATA JCHAR(43),INDEX(43)/'=',464/ + DATA JCHAR(44),INDEX(44)/' ',473/ + DATA JCHAR(45),INDEX(45)/',',476/ + DATA JCHAR(46),INDEX(46)/'.',486/ +C +C THE FOLLOWING DATA STATEMENTS CONTAIN THE DIGITIZATIONS OF THE +C CHARACTERS. THE CHARACTERS ARE DIGITIZED ON A BOX 6 UNITS WIDE AND +C 7 UNITS TALL. THIS INCLUDES 2 UNITS OF WHITE SPACE TO THE RIGHT OF +C EACH CHARACTER. IF KX=7, KY IS A FLAG -- KY=0 MEANS THE FOLLOWING +C KX AND KY ARE A PEN UP MOVE (ALL OTHERS ARE PEN DOWN MOVES), AND +C KY=7 MEANS THAT THE END OF THE DIGITIZATION FOR A PARTICULAR CHARAC- +C TER HAS BEEN REACHED. +C +c None of the following variables are used. +c DATA WIDE,HIGH,WHITE/6.,7.,2./ +C + DATA KX( 1),KX( 2),KX( 3),KX( 4),KX( 5),KX( 6)/0,4,7,0,0,1/ + DATA KY( 1),KY( 2),KY( 3),KY( 4),KY( 5),KY( 6)/3,3,0,3,6,7/ + DATA KX( 7),KX( 8),KX( 9),KX( 10),KX( 11),KX( 12)/3,4,4,7,6,7/ + DATA KY( 7),KY( 8),KY( 9),KY( 10),KY( 11),KY( 12)/7,6,0,0,0,7/ + DATA KX( 13),KX( 14),KX( 15),KX( 16),KX( 17),KX( 18)/0,3,4,4,3,0/ + DATA KY( 13),KY( 14),KY( 15),KY( 16),KY( 17),KY( 18)/7,7,6,5,4,4/ + DATA KX( 19),KX( 20),KX( 21),KX( 22),KX( 23),KX( 24)/7,3,4,4,3,0/ + DATA KY( 19),KY( 20),KY( 21),KY( 22),KY( 23),KY( 24)/0,4,3,1,0,0/ + DATA KX( 25),KX( 26),KX( 27),KX( 28),KX( 29),KX( 30)/7,6,7,7,4,3/ + DATA KY( 25),KY( 26),KY( 27),KY( 28),KY( 29),KY( 30)/0,0,7,0,6,7/ + DATA KX( 31),KX( 32),KX( 33),KX( 34),KX( 35),KX( 36)/1,0,0,1,3,4/ + DATA KY( 31),KY( 32),KY( 33),KY( 34),KY( 35),KY( 36)/7,6,1,0,0,1/ + DATA KX( 37),KX( 38),KX( 39),KX( 40),KX( 41),KX( 42)/7,6,7,0,3,4/ + DATA KY( 37),KY( 38),KY( 39),KY( 40),KY( 41),KY( 42)/0,0,7,7,7,6/ + DATA KX( 43),KX( 44),KX( 45),KX( 46),KX( 47),KX( 48)/4,3,0,7,6,7/ + DATA KY( 43),KY( 44),KY( 45),KY( 46),KY( 47),KY( 48)/1,0,0,0,0,7/ + DATA KX( 49),KX( 50),KX( 51),KX( 52),KX( 53),KX( 54)/0,4,7,3,0,7/ + DATA KY( 49),KY( 50),KY( 51),KY( 52),KY( 53),KY( 54)/7,7,0,4,4,0/ + DATA KX( 55),KX( 56),KX( 57),KX( 58),KX( 59),KX( 60)/0,4,7,6,7,0/ + DATA KY( 55),KY( 56),KY( 57),KY( 58),KY( 59),KY( 60)/0,0,0,0,7,7/ + DATA KX( 61),KX( 62),KX( 63),KX( 64),KX( 65),KX( 66)/4,7,0,3,7,6/ + DATA KY( 61),KY( 62),KY( 63),KY( 64),KY( 65),KY( 66)/7,0,4,4,0,0/ + DATA KX( 67),KX( 68),KX( 69),KX( 70),KX( 71),KX( 72)/7,7,4,3,1,0/ + DATA KY( 67),KY( 68),KY( 69),KY( 70),KY( 71),KY( 72)/7,0,6,7,7,6/ + DATA KX( 73),KX( 74),KX( 75),KX( 76),KX( 77),KX( 78)/0,1,3,4,4,3/ + DATA KY( 73),KY( 74),KY( 75),KY( 76),KY( 77),KY( 78)/1,0,0,1,3,3/ + DATA KX( 79),KX( 80),KX( 81),KX( 82),KX( 83),KX( 84)/7,6,7,0,7,0/ + DATA KY( 79),KY( 80),KY( 81),KY( 82),KY( 83),KY( 84)/0,0,7,7,0,4/ + DATA KX( 85),KX( 86),KX( 87),KX( 88),KX( 89),KX( 90)/4,7,4,4,7,6/ + DATA KY( 85),KY( 86),KY( 87),KY( 88),KY( 89),KY( 90)/4,0,7,0,0,0/ + DATA KX( 91),KX( 92),KX( 93),KX( 94),KX( 95),KX( 96)/7,7,1,3,7,2/ + DATA KY( 91),KY( 92),KY( 93),KY( 94),KY( 95),KY( 96)/7,0,7,7,0,7/ + DATA KX( 97),KX( 98),KX( 99),KX(100),KX(101),KX(102)/2,7,1,3,7,6/ + DATA KY( 97),KY( 98),KY( 99),KY(100),KY(101),KY(102)/0,0,0,0,0,0/ + DATA KX(103),KX(104),KX(105),KX(106),KX(107),KX(108)/7,7,0,1,3,4/ + DATA KY(103),KY(104),KY(105),KY(106),KY(107),KY(108)/7,0,1,0,0,1/ + DATA KX(109),KX(110),KX(111),KX(112),KX(113),KX(114)/4,7,6,7,0,7/ + DATA KY(109),KY(110),KY(111),KY(112),KY(113),KY(114)/7,0,0,7,7,0/ + DATA KX(115),KX(116),KX(117),KX(118),KX(119),KX(120)/0,4,7,2,4,7/ + DATA KY(115),KY(116),KY(117),KY(118),KY(119),KY(120)/3,7,0,5,0,0/ + DATA KX(121),KX(122),KX(123),KX(124),KX(125),KX(126)/6,7,7,0,0,4/ + DATA KY(121),KY(122),KY(123),KY(124),KY(125),KY(126)/0,7,0,7,0,0/ + DATA KX(127),KX(128),KX(129),KX(130),KX(131),KX(132)/7,6,7,0,2,4/ + DATA KY(127),KY(128),KY(129),KY(130),KY(131),KY(132)/0,0,7,7,3,7/ + DATA KX(133),KX(134),KX(135),KX(136),KX(137),KX(138)/4,7,6,7,0,4/ + DATA KY(133),KY(134),KY(135),KY(136),KY(137),KY(138)/0,0,0,7,7,0/ + DATA KX(139),KX(140),KX(141),KX(142),KX(143),KX(144)/4,7,6,7,4,7/ + DATA KY(139),KY(140),KY(141),KY(142),KY(143),KY(144)/7,0,0,7,7,0/ + DATA KX(145),KX(146),KX(147),KX(148),KX(149),KX(150)/4,4,3,1,0,0/ + DATA KY(145),KY(146),KY(147),KY(148),KY(149),KY(150)/1,6,7,7,6,1/ + DATA KX(151),KX(152),KX(153),KX(154),KX(155),KX(156)/1,3,4,7,6,7/ + DATA KY(151),KY(152),KY(153),KY(154),KY(155),KY(156)/0,0,1,0,0,7/ + DATA KX(157),KX(158),KX(159),KX(160),KX(161),KX(162)/0,3,4,4,3,0/ + DATA KY(157),KY(158),KY(159),KY(160),KY(161),KY(162)/7,7,6,5,4,4/ + DATA KX(163),KX(164),KX(165),KX(166),KX(167),KX(168)/7,6,7,7,0,0/ + DATA KY(163),KY(164),KY(165),KY(166),KY(167),KY(168)/0,0,7,0,1,6/ + DATA KX(169),KX(170),KX(171),KX(172),KX(173),KX(174)/1,3,4,4,3,1/ + DATA KY(169),KY(170),KY(171),KY(172),KY(173),KY(174)/7,7,6,1,0,0/ + DATA KX(175),KX(176),KX(177),KX(178),KX(179),KX(180)/0,7,2,4,7,6/ + DATA KY(175),KY(176),KY(177),KY(178),KY(179),KY(180)/1,0,2,0,0,0/ + DATA KX(181),KX(182),KX(183),KX(184),KX(185),KX(186)/7,0,3,4,4,3/ + DATA KY(181),KY(182),KY(183),KY(184),KY(185),KY(186)/7,7,7,6,5,4/ + DATA KX(187),KX(188),KX(189),KX(190),KX(191),KX(192)/0,7,2,4,7,6/ + DATA KY(187),KY(188),KY(189),KY(190),KY(191),KY(192)/4,0,4,0,0,0/ + DATA KX(193),KX(194),KX(195),KX(196),KX(197),KX(198)/7,7,0,1,3,4/ + DATA KY(193),KY(194),KY(195),KY(196),KY(197),KY(198)/7,0,1,0,0,1/ + DATA KX(199),KX(200),KX(201),KX(202),KX(203),KX(204)/4,3,1,0,0,1/ + DATA KY(199),KY(200),KY(201),KY(202),KY(203),KY(204)/3,4,4,5,6,7/ + DATA KX(205),KX(206),KX(207),KX(208),KX(209),KX(210)/3,4,7,6,7,7/ + DATA KY(205),KY(206),KY(207),KY(208),KY(209),KY(210)/7,6,0,0,7,0/ + DATA KX(211),KX(212),KX(213),KX(214),KX(215),KX(216)/0,4,7,2,2,7/ + DATA KY(211),KY(212),KY(213),KY(214),KY(215),KY(216)/7,7,0,7,0,0/ + DATA KX(217),KX(218),KX(219),KX(220),KX(221),KX(222)/6,7,7,0,0,1/ + DATA KY(217),KY(218),KY(219),KY(220),KY(221),KY(222)/0,7,0,7,1,0/ + DATA KX(223),KX(224),KX(225),KX(226),KX(227),KX(228)/3,4,4,7,6,7/ + DATA KY(223),KY(224),KY(225),KY(226),KY(227),KY(228)/0,1,7,0,0,7/ + DATA KX(229),KX(230),KX(231),KX(232),KX(233),KX(234)/7,0,2,4,7,6/ + DATA KY(229),KY(230),KY(231),KY(232),KY(233),KY(234)/0,7,0,7,0,0/ + DATA KX(235),KX(236),KX(237),KX(238),KX(239),KX(240)/7,7,0,0,2,4/ + DATA KY(235),KY(236),KY(237),KY(238),KY(239),KY(240)/7,0,7,0,4,0/ + DATA KX(241),KX(242),KX(243),KX(244),KX(245),KX(246)/4,7,6,7,4,7/ + DATA KY(241),KY(242),KY(243),KY(244),KY(245),KY(246)/7,0,0,7,7,0/ + DATA KX(247),KX(248),KX(249),KX(250),KX(251),KX(252)/0,4,7,6,7,7/ + DATA KY(247),KY(248),KY(249),KY(250),KY(251),KY(252)/7,0,0,0,7,0/ + DATA KX(253),KX(254),KX(255),KX(256),KX(257),KX(258)/0,2,4,7,2,2/ + DATA KY(253),KY(254),KY(255),KY(256),KY(257),KY(258)/7,4,7,0,4,0/ + DATA KX(259),KX(260),KX(261),KX(262),KX(263),KX(264)/7,6,7,7,3,1/ + DATA KY(259),KY(260),KY(261),KY(262),KY(263),KY(264)/0,0,7,0,4,4/ + DATA KX(265),KX(266),KX(267),KX(268),KX(269),KX(270)/7,0,4,0,4,7/ + DATA KY(265),KY(266),KY(267),KY(268),KY(269),KY(270)/0,7,7,0,0,0/ + DATA KX(271),KX(272),KX(273),KX(274),KX(275),KX(276)/6,7,7,4,3,1/ + DATA KY(271),KY(272),KY(273),KY(274),KY(275),KY(276)/0,7,0,1,0,0/ + DATA KX(277),KX(278),KX(279),KX(280),KX(281),KX(282)/0,0,1,3,4,4/ + DATA KY(277),KY(278),KY(279),KY(280),KY(281),KY(282)/1,6,7,7,6,1/ + DATA KX(283),KX(284),KX(285),KX(286),KX(287),KX(288)/7,6,7,7,1,2/ + DATA KY(283),KY(284),KY(285),KY(286),KY(287),KY(288)/0,0,7,0,6,7/ + DATA KX(289),KX(290),KX(291),KX(292),KX(293),KX(294)/2,7,1,3,7,6/ + DATA KY(289),KY(290),KY(291),KY(292),KY(293),KY(294)/0,0,0,0,0,0/ + DATA KX(295),KX(296),KX(297),KX(298),KX(299),KX(300)/7,7,0,1,3,4/ + DATA KY(295),KY(296),KY(297),KY(298),KY(299),KY(300)/7,0,6,7,7,6/ + DATA KX(301),KX(302),KX(303),KX(304),KX(305),KX(306)/4,0,0,4,7,6/ + DATA KY(301),KY(302),KY(303),KY(304),KY(305),KY(306)/5,1,0,0,0,0/ + DATA KX(307),KX(308),KX(309),KX(310),KX(311),KX(312)/7,7,0,1,3,4/ + DATA KY(307),KY(308),KY(309),KY(310),KY(311),KY(312)/7,0,6,7,7,6/ + DATA KX(313),KX(314),KX(315),KX(316),KX(317),KX(318)/4,3,1,7,3,4/ + DATA KY(313),KY(314),KY(315),KY(316),KY(317),KY(318)/5,4,4,0,4,3/ + DATA KX(319),KX(320),KX(321),KX(322),KX(323),KX(324)/4,3,1,0,7,6/ + DATA KY(319),KY(320),KY(321),KY(322),KY(323),KY(324)/1,0,0,1,0,0/ + DATA KX(325),KX(326),KX(327),KX(328),KX(329),KX(330)/7,7,3,3,2,0/ + DATA KY(325),KY(326),KY(327),KY(328),KY(329),KY(330)/7,0,0,7,7,4/ + DATA KX(331),KX(332),KX(333),KX(334),KX(335),KX(336)/0,4,7,2,4,7/ + DATA KY(331),KY(332),KY(333),KY(334),KY(335),KY(336)/3,3,0,0,0,0/ + DATA KX(337),KX(338),KX(339),KX(340),KX(341),KX(342)/6,7,7,0,1,3/ + DATA KY(337),KY(338),KY(339),KY(340),KY(341),KY(342)/0,7,0,1,0,0/ + DATA KX(343),KX(344),KX(345),KX(346),KX(347),KX(348)/4,4,3,0,0,4/ + DATA KY(343),KY(344),KY(345),KY(346),KY(347),KY(348)/1,3,4,4,7,7/ + DATA KX(349),KX(350),KX(351),KX(352),KX(353),KX(354)/7,6,7,7,4,3/ + DATA KY(349),KY(350),KY(351),KY(352),KY(353),KY(354)/0,0,7,0,6,7/ + DATA KX(355),KX(356),KX(357),KX(358),KX(359),KX(360)/1,0,0,1,3,4/ + DATA KY(355),KY(356),KY(357),KY(358),KY(359),KY(360)/7,6,1,0,0,1/ + DATA KX(361),KX(362),KX(363),KX(364),KX(365),KX(366)/4,3,1,0,7,6/ + DATA KY(361),KY(362),KY(363),KY(364),KY(365),KY(366)/3,4,4,3,0,0/ + DATA KX(367),KX(368),KX(369),KX(370),KX(371),KX(372)/7,7,0,0,4,4/ + DATA KY(367),KY(368),KY(369),KY(370),KY(371),KY(372)/7,0,6,7,7,6/ + DATA KX(373),KX(374),KX(375),KX(376),KX(377),KX(378)/2,2,7,6,7,7/ + DATA KY(373),KY(374),KY(375),KY(376),KY(377),KY(378)/1,0,0,0,7,0/ + DATA KX(379),KX(380),KX(381),KX(382),KX(383),KX(384)/1,0,0,1,3,4/ + DATA KY(379),KY(380),KY(381),KY(382),KY(383),KY(384)/4,5,6,7,7,6/ + DATA KX(385),KX(386),KX(387),KX(388),KX(389),KX(390)/4,3,1,0,0,1/ + DATA KY(385),KY(386),KY(387),KY(388),KY(389),KY(390)/5,4,4,3,1,0/ + DATA KX(391),KX(392),KX(393),KX(394),KX(395),KX(396)/3,4,4,3,7,6/ + DATA KY(391),KY(392),KY(393),KY(394),KY(395),KY(396)/0,1,3,4,0,0/ + DATA KX(397),KX(398),KX(399),KX(400),KX(401),KX(402)/7,7,0,1,3,4/ + DATA KY(397),KY(398),KY(399),KY(400),KY(401),KY(402)/7,0,1,0,0,1/ + DATA KX(403),KX(404),KX(405),KX(406),KX(407),KX(408)/4,3,1,0,0,1/ + DATA KY(403),KY(404),KY(405),KY(406),KY(407),KY(408)/6,7,7,6,4,3/ + DATA KX(409),KX(410),KX(411),KX(412),KX(413),KX(414)/3,4,7,6,7,7/ + DATA KY(409),KY(410),KY(411),KY(412),KY(413),KY(414)/3,4,0,0,7,0/ + DATA KX(415),KX(416),KX(417),KX(418),KX(419),KX(420)/0,4,7,2,2,7/ + DATA KY(415),KY(416),KY(417),KY(418),KY(419),KY(420)/3,3,0,5,1,0/ + DATA KX(421),KX(422),KX(423),KX(424),KX(425),KX(426)/6,7,7,0,4,7/ + DATA KY(421),KY(422),KY(423),KY(424),KY(425),KY(426)/0,7,0,3,3,0/ + DATA KX(427),KX(428),KX(429),KX(430),KX(431),KX(432)/6,7,7,0,4,7/ + DATA KY(427),KY(428),KY(429),KY(430),KY(431),KY(432)/0,7,0,1,5,0/ + DATA KX(433),KX(434),KX(435),KX(436),KX(437),KX(438)/2,2,7,4,0,7/ + DATA KY(433),KY(434),KY(435),KY(436),KY(437),KY(438)/5,1,0,3,3,0/ + DATA KX(439),KX(440),KX(441),KX(442),KX(443),KX(444)/0,4,7,6,7,4/ + DATA KY(439),KY(440),KY(441),KY(442),KY(443),KY(444)/5,1,0,0,7,7/ + DATA KX(445),KX(446),KX(447),KX(448),KX(449),KX(450)/7,6,7,7,3,2/ + DATA KY(445),KY(446),KY(447),KY(448),KY(449),KY(450)/0,0,7,1,7,6/ + DATA KX(451),KX(452),KX(453),KX(454),KX(455),KX(456)/2,3,7,6,7,7/ + DATA KY(451),KY(452),KY(453),KY(454),KY(455),KY(456)/1,0,0,0,7,0/ + DATA KX(457),KX(458),KX(459),KX(460),KX(461),KX(462)/1,2,2,1,7,6/ + DATA KY(457),KY(458),KY(459),KY(460),KY(461),KY(462)/7,6,1,0,0,0/ + DATA KX(463),KX(464),KX(465),KX(466),KX(467),KX(468)/7,7,4,0,7,0/ + DATA KY(463),KY(464),KY(465),KY(466),KY(467),KY(468)/7,0,5,5,0,2/ + DATA KX(469),KX(470),KX(471),KX(472),KX(473),KX(474)/4,7,6,7,7,6/ + DATA KY(469),KY(470),KY(471),KY(472),KY(473),KY(474)/2,0,0,7,0,0/ + DATA KX(475),KX(476),KX(477),KX(478),KX(479),KX(480)/7,7,1,2,2,1/ + DATA KY(475),KY(476),KY(477),KY(478),KY(479),KY(480)/7,0,0,1,2,2/ + DATA KX(481),KX(482),KX(483),KX(484),KX(485),KX(486)/1,2,7,6,7,7/ + DATA KY(481),KY(482),KY(483),KY(484),KY(485),KY(486)/1,1,0,0,7,0/ + DATA KX(487),KX(488),KX(489),KX(490),KX(491),KX(492)/2,1,1,2,2,7/ + DATA KY(487),KY(488),KY(489),KY(490),KY(491),KY(492)/0,0,1,1,0,0/ + DATA KX(493),KX(494) /6,7 / + DATA KY(493),KY(494) /0,7 / +C +C NSIZE IS THE LENGTH OF JCHAR AND INDEX. +C LNGTH IS THE LENGTH OF KX AND KY. +C LENTRY TELLS IF THIS IS THE FIRTST CALL TO PWRZI. +C + DATA NSIZE/46/ +c Variable LNGTH is not used. +c DATA LNGTH/494/ + DATA LENTRY/.FALSE./ + DATA ITHETA/0/ + DATA IDUM1,IDUM2,IDUM3/1,1,1/ +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','PWRZI','PWRZI','VERSION 1') +C +C SEE IF THIS IS THE FIRST CALL TO PWRZI +C + IF (LENTRY) GO TO 103 +C +C MARK THAT FUTURE CALLS NEED NOT DO THIS CODE. +C + LENTRY = .TRUE. +C +C RECORD THE LOCATION OF THE BLANK SO IT CAN BE USED FOR UNKNOWN +C CHARACTERS. +C + IBLKPT = INDEX(44) +C +C CHANGE EACH CHARACTER IN THE TABLE TO RIGHT JUSTIFIED, ZERO FILLED. +C +C +C SORT JCHAR MAINTAINING THE RELATIONSHIP BETWEEN JCHAR AND INDEX. +C (THAT IS, IF JCHAR(I)='B', THEN INDEX(I)=13 FROM THE ABOVE DATA STMT.) +C THIS WILL ENABLE CHARACTERS TO BE QUICKLY FOUND IN ALL SUBSEQUENT +C CALLS TO PWRZI. +C + CALL PWRZOI (JCHAR,INDEX,NSIZE) +C +C ALL ONE-TIME INITIALIZATION NOW FINISHED. +C + 103 CONTINUE +C + NN = N + IF (NN .LE. 0) RETURN + FNNM1 = NN-1 + JCNT = ICNT +C +C PUT RELATIVE SIZE IN Q, ADJUST FOR CURRENT PLOTTER RESOLUTION +C + CALL GETUSV ('XF',LX) + SCALE = 32. + IF (ISIZE .EQ. 0) Q = 1.3334*SCALE + IF (ISIZE .EQ. 1) Q = 2.*SCALE + IF (ISIZE .EQ. 2) Q = 2.6667*SCALE + IF (ISIZE .EQ. 3) Q = 4.*SCALE + IF (ISIZE .GT. 3) Q = FLOAT(ISIZE)*(2**(15-LX))/6. +C +C PUT ANGLE IN RADIANS IN T. +C + T = FLOAT(ITHETA)*1.5708 + 104 CONTINUE +C +C CALCULATE COMBINED TRANSFORMATION +C + CT = Q*COS(T) + ST = Q*SIN(T) +C +C FIND CRT COORDINATES OF CENTER. +C + LINEI = LIN3 + CALL INTZI (X,Y,Z,LINEI,ITOP) + IF (LINEI .EQ. 0) RETURN + IX = 0 + IY = 0 + XC = IX + YC = IY +C +C CORRECT FOR CHARACTER DATA BEING LOWER-LEFT-HAND POSITIONED. +C + XC = XC-2.*CT+3.5*ST + YC = YC-2.*ST-3.5*CT +C +C CORRECT FOR CENTERING IF TURNED ON. +C + JCNT = MAX0(-1,MIN0(1,JCNT))+2 + GO TO (108,107,109),JCNT + 107 XC = XC-CT*FNNM1*3. + YC = YC-ST*FNNM1*3. + GO TO 110 + 108 XC = XC+CT*2. + YC = YC+ST*2. + GO TO 110 + 109 XC = XC-CT*2. + YC = YC-ST*2. + XC = XC-CT*FNNM1*6. + YC = YC-ST*FNNM1*6. + 110 CALL INITZI (IFIX(XC),IFIX(YC),1,IDUM1,IDUM2,2) + CALL INITZI (IFIX(XC+CT*6.*FNNM1),IFIX(YC+ST*6.*FNNM1),2,IDUM1, + + IDUM2,2) + CALL INITZI (IFIX(XC),IFIX(YC),IDUM1,IDUM2,IDUM3,3) + DO 114 K=1,NN + XB = XC + YB = YC + IP = 1 +C +C EXTRACT CHARACTER NUMBER K FROM THE STRING. +C + KCHAR = ID(K:K) +C +C FIND THE TABLE ENTRY. +C + CALL PWRZGI (KCHAR,JCHAR,INDEX,NSIZE,IPOINT) + IF (IPOINT .EQ. -1) IPOINT = IBLKPT +C +C ALWAYS LESS THAN 20 INSTRUCTIONS. +C + DO 113 L=1,20 + ISUB = IPOINT+L-1 + NX = KX(ISUB) + FNX = NX + NY = KY(ISUB) + FNY = NY +C +C TEST FOR OP-CODE OR DX AND DY. +C + IF (NX .NE. 7) GO TO 111 +C +C OP-CODE +C + IP = 0 + IF (NY-7) 113,114,113 +C +C DX AND DY +C + 111 XC = XB+FNX*CT-FNY*ST + YC = YB+FNX*ST+FNY*CT +C +C CALL DESIRED PLOTTING ROUTINE. DETERMINED BY OP-CODES. +C + IF (IP .NE. 0) GO TO 112 + CALL INITZI (IFIX(XC+.5),IFIX(YC+.5),IDUM1,IDUM2,IDUM3,3) + IP = 1 + GO TO 113 + 112 CALL INITZI (IFIX(XC+.5),IFIX(YC+.5),IDUM1,IDUM2,IDUM3,4) + 113 CONTINUE + 114 CONTINUE +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(0,0,0) + RETURN + END + SUBROUTINE INTZI (XX,YY,ZZ,LIN3,ITOP) +C +C FORCE STORAGE OF X, Y, AND Z INTO COMMON BLOCK +C + COMMON /PWRZ2I/ X, Y, Z + DATA IDUMX,IDUMY,IDUMZ /0, 0, 0/ + X = XX + Y = YY + Z = ZZ + CALL INITZI (IDUMX,IDUMY,IDUMZ,LIN3,ITOP,1) + RETURN + END + SUBROUTINE INITZI (IX,IY,IZ,LIN3,ITOP,IENT) +C + SAVE + COMMON /PWRZ1I/ XXMIN ,XXMAX ,YYMIN ,YYMAX , + + ZZMIN ,ZZMAX ,DELCRT ,EYEX , + + EYEY ,EYEZ +C + COMMON /PWRZ2I/ X ,Y ,Z + FX(R) = R+FACTX*FLOAT(IX) + FY(R) = R+FACTY*FLOAT(IY) +C +C +C DETERMINE INITZI,VISSET,FRSTZ OR VECTZ CALL +C + GO TO (1000,2000,3000,4000),IENT + 1000 LIN = MAX0(1,MIN0(3,IABS(LIN3))) + ITO = MAX0(1,MIN0(3,IABS(ITOP))) +C +C SET UP SCALING CONSTANTS +C + DELMAX = AMAX1(XXMAX-XXMIN,YYMAX-YYMIN,ZZMAX-ZZMIN) + FACTOR = DELMAX/DELCRT + FACTX = SIGN(FACTOR,FLOAT(LIN3)) + FACTY = SIGN(FACTOR,FLOAT(ITOP)) +C +C SET UP FOR PROPER PLANE +C + JUMP1 = LIN+(ITO-1)*3 + GO TO (108,101,102,103,108,104,105,106,108),JUMP1 + 101 ASSIGN 111 TO JUMP + GO TO 107 + 102 ASSIGN 112 TO JUMP + GO TO 107 + 103 ASSIGN 113 TO JUMP + GO TO 107 + 104 ASSIGN 114 TO JUMP + GO TO 107 + 105 ASSIGN 115 TO JUMP + GO TO 107 + 106 ASSIGN 116 TO JUMP + 107 RETURN + 108 CALL SETER ('INITZI - LINE OR ITOP IMPROPER IN PWRZI CALL' ,1,1) + LIN3 = 0 + RETURN +C +C **************************** ENTRY VISSET **************************** +C ENTRY VISSET (IX,IY,IZ) +C +C +C VISSET IS CALLED ONCE FOR EACH END OF THE CHARACTER STRING +C + 2000 IVIS = -1 + ITEMP = 0 + GO TO 110 +C +C SEE IF THIS END COULD BE BEHIND THE OBJECT +C + 109 IF (EYEX.GT.XXMAX .AND. XX.GT.XXMAX) ITEMP = ITEMP+1 + IF (EYEY.GT.YYMAX .AND. YY.GT.YYMAX) ITEMP = ITEMP+1 + IF (EYEZ.GT.ZZMAX .AND. ZZ.GT.ZZMAX) ITEMP = ITEMP+1 + IF (EYEX.LT.XXMIN .AND. XX.LT.XXMIN) ITEMP = ITEMP+1 + IF (EYEY.LT.YYMIN .AND. YY.LT.YYMIN) ITEMP = ITEMP+1 + IF (EYEZ.LT.ZZMIN .AND. ZZ.LT.ZZMIN) ITEMP = ITEMP+1 + IF (IZ .EQ. 1) IVISS = ITEMP +C +C IF EITHER END CHARACTER COULD BE HIDDEN, TEST ALL LINE SEGMENTS. +C + IF (IZ .EQ. 2) IVIS = MIN0(IVISS,ITEMP) + RETURN +C +C **************************** ENTRY FRSTZ ***************************** +C ENTRY FRSTZ (IX,IY) +C + 3000 IFRST = 1 + GO TO 110 +C +C **************************** ENTRY VECTZ ***************************** +C ENTRY VECTZ (IX,IY) +C + 4000 IFRST = 0 +C +C PICK CORRECT 3-SPACE PLANE TO DRAW IN +C + 110 GO TO JUMP,(111,112,113,114,115,116) + 111 XX = FY(X) + YY = FX(Y) + ZZ = Z + GO TO 117 + 112 XX = FY(X) + YY = Y + ZZ = FX(Z) + GO TO 117 + 113 XX = FX(X) + YY = FY(Y) + ZZ = Z + GO TO 117 + 114 XX = X + YY = FY(Y) + ZZ = FX(Z) + GO TO 117 + 115 XX = FX(X) + YY = Y + ZZ = FY(Z) + GO TO 117 + 116 XX = X + YY = FX(Y) + ZZ = FY(Z) +C +C TRANSLATE TO 2-SPACE +C + 117 CALL TRN32I (XX,YY,ZZ,XT,YT,DUMMY,2) + IF (IVIS) 109,121,118 + 118 IF (IFRST) 119,120,119 +C +C IF IN FRONT, DRAW IN ANY CASE. +C + 119 CALL PLOTIT (IFIX(XT),IFIX(YT),0) + RETURN + 120 CALL PLOTIT (IFIX(XT),IFIX(YT),1) + RETURN + 121 IF (IFRST) 122,123,122 + 122 IX1 = XT + IY1 = YT + RETURN + 123 IX2 = XT + IY2 = YT +C +C IF COULD BE HIDDEN, USE HIDDEN LINE PLOTTING ENTRY IN ISOSRF +C + CALL DRAWI (IX1,IY1,IX2,IY2) + IX1 = IX2 + IY1 = IY2 + RETURN + END + SUBROUTINE PWRZOI (JCHAR,INDEX,NSIZE) +C +C THIS ROUTINE SORTS JCHAR WHICH IS NSIZE IN LENGTH. THE RELATIONSHIP +C BETWEEN JCHAR AND INDEX IS MAINTAINED. A BUBBLE SORT IS USED. +C JCHAR IS SORTED IN ASCENDING ORDER. +C + SAVE + CHARACTER*1 JCHAR(NSIZE) ,JTEMP ,KTEMP + DIMENSION INDEX(NSIZE) + LOGICAL LDONE +C + ISTART = 1 + ISTOP = NSIZE + ISTEP = 1 +C +C AT MOST NSIZE PASSES ARE NEEDED. +C + DO 104 NPASS=1,NSIZE + LDONE = .TRUE. + I = ISTART + 101 ISUB = I+ISTEP + IF (ISTEP*(ICHAR(JCHAR(I))-ICHAR(JCHAR(ISUB)))) 103,103,102 +C +C THEY NEED TO BE SWITCHED. +C + 102 LDONE = .FALSE. + JTEMP = JCHAR(I) + KTEMP = JCHAR(ISUB) + JCHAR(I) = KTEMP + JCHAR(ISUB) = JTEMP + ITEMP = INDEX(I) + INDEX(I) = INDEX(ISUB) + INDEX(ISUB) = ITEMP +C +C THEY DO NOT NEED TO BE SWITCHED. +C + 103 I = I+ISTEP + IF (I .NE. ISTOP) GO TO 101 +C +C IF NONE WERE SWITCHED DURING THIS PASS, WE CAN QUIT. +C + IF (LDONE) RETURN +C +C SET UP FOR THE NEXT PASS IN THE OTHER DIRECTION. +C + ISTEP = -ISTEP + ITEMP = ISTART + ISTART = ISTOP+ISTEP + ISTOP = ITEMP + 104 CONTINUE + RETURN + END + SUBROUTINE PWRZGI (KCHAR,JCHAR,INDEX,NSIZE,IPOINT) +C +C THIS ROUTINE FINDS WHERE KCHAR IS IN JCHAR AND RETURNS THE CORRES- +C PONDING INDEX IN IPOINT. BINARY HALVING IS USED. +C + SAVE + CHARACTER*1 JCHAR(NSIZE) ,KCHAR + DIMENSION INDEX(NSIZE) +C +C IT IS ASSUMED THAT JCHAR IS LESS THAT 2**9 IN LENGTH, SO IF KCHAR IS +C NOT FOUND IN 10 STEPS, THE SEARCH IS STOPPED. +C + KOUNT = 0 + IBOT = 1 + ITOP = NSIZE + I = ITOP + GO TO 102 + 101 I = (IBOT+ITOP)/2 + KOUNT = KOUNT+1 + IF (KOUNT .GT. 10) GO TO 106 + 102 IF (ICHAR(JCHAR(I))-ICHAR(KCHAR)) 103,105,104 + 103 IBOT = I + GO TO 101 + 104 ITOP = I + GO TO 101 + 105 IPOINT = INDEX(I) + RETURN +C +C IPOINT=-1 MEANS THAT KCHAR WAS NOT IN THE TABLE. +C + 106 IPOINT = -1 + RETURN +C +C +C +C REVISION HISTORY---------- +C +C MARCH 1980 FIRST ADDED TO ULIB AS A SEPARATE FILE TO BE +C USED IN CONJUNCTION WITH THE ULIB ROUTINE +C ISOSRF +C +C JULY 1984 CONVERTED TO GKS AND FORTRAN 77 +C------------------------------------------------------------------ + END diff --git a/sys/gio/ncarutil/pwrzs.f b/sys/gio/ncarutil/pwrzs.f new file mode 100644 index 00000000..cfda613e --- /dev/null +++ b/sys/gio/ncarutil/pwrzs.f @@ -0,0 +1,772 @@ + SUBROUTINE PWRZS (X,Y,Z,ID,N,ISIZE,LIN3,ITOP,ICNT) +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE PWRZS IS A CHARACTER PLOTTING ROUTINE FOR +C PLOTTING CHARACTERS IN THREE-SPACE WHEN USING +C SRFACE. FOR A LARGE CLASS OF +C POSSIBLE POSITIONS, THE HIDDEN CHARACTER +C PROBLEM IS SOLVED. +C +C +C +C USAGE CALL PWRZS (X,Y,Z,ID,N,ISIZE,LINE,ITOP,ICNT) +C USE CALL PWRZS AFTER CALLING +C SRFACE AND BEFORE CALLING FRAME +C NOTE: SRFACE WILL HAVE TO BE CHANGED +C TO SUPPRESS THE FRAME CALL. SEE IFR +C IN SRFACE INTERNAL PARAMETERS. +C +C ARGUMENTS +C +C ON INPUT X,Y,Z +C POSITIONING COORDINATES FOR THE CHARACTERS +C TO BE DRAWN. THESE ARE FLOATING POINT +C NUMBERS IN THE SAME THREE-SPACE AS USED IN +C SRFACE. +C +C ID +C CHARACTER STRING TO BE DRAWN +C +C N +C THE NUMBER OF CHARACTERS IN ID +C +C ISIZE +C SIZE OF THE CHARACTER +C . IF BETWEEN 0 AND 3 THE FACTOR IS 1., 1.5, +C 2., OR 3. TIMES A STANDARD WIDTH EQUAL +C TO 1/128TH OF THE SCREEN WIDTH. +C . IF GREATER THAN 3 IT IS THE CHARACTER +C WIDTH IN PLOTTER ADDRESS UNITS. +C +C LINE +C THE DIRECTION IN WHICH THE CHARACTERS ARE TO +C BE WRITTEN. +C 1 = +X -1 = -X +C 2 = +Y -2 = -Y +C 3 = +Z -3 = -Z +C +C ITOP +C THE DIRECTION FROM THE CENTER OF THE FIRST +C CHARACTER TO THE TOP OF THE FIRST +C CHARACTER. NOTE THAT LINE CANNOT +C EQUAL ITOP EVEN IN ABSOLUTE VALUE. +C +C ICNT +C CENTERING OPTION. +C -1 (X,Y,Z) IS THE CENTER OF THE LEFT EDGE OF +C THE FIRST CHARACTER. +C 0 (X,Y,Z) IS THE CENTER OF THE ENTIRE +C STRING. +C 1 (X,Y,Z) IS THE CENTER OF THE RIGHT EDGE +C OF THE LAST CHARACTER. +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED. +C +C NOTE THE HIDDEN CHARACTER PROBLEM IS SOLVED +C CORRECTLY FOR CHARACTERS NEAR (BUT NOT INSIDE) +C THE THREE-SPACE OBJECT. +C +C ENTRY POINTS PWRZS, INITZS, PWRZOS, PWRZGS +C +C COMMON BLOCKS PWRZ1S,PWRZ2S +C +C I/O PLOTS CHARACTER(S) +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY SRFACE +C ROUTINES +C +C LANGUAGE FORTRAN +C +C HISTORY IMPLEMENTED FOR USE WITH SRFACE. +C +C +C +C +C*********************************************************************** +C + SAVE + CHARACTER*(*) ID + CHARACTER*1 JCHAR(46) ,KCHAR + DIMENSION INDEX(46) ,KX(494) ,KY(494) + DIMENSION VWPRT(4) ,WNDW(4) + LOGICAL LENTRY +c +NOAO: common block added for user control of viewport + common /noaovp/ vpx1, vpx2, vpy1, vpy2 +c -NOAO +C +C +C THE FOLLOWING DATA STATEMENTS ASSOCIATE EACH CHARACTER WITH ITS +C DIGITIZATION. THAT IS, THE DIGITIZATION FOR THE CHARACTER A STARTS +C AT KX(1) AND KY(1), WHILE B STARTS AT KX(13) AND KY(13), AND SO ON. +C + DATA JCHAR( 1),INDEX( 1)/'A', 1/ + DATA JCHAR( 2),INDEX( 2)/'B', 13/ + DATA JCHAR( 3),INDEX( 3)/'C', 28/ + DATA JCHAR( 4),INDEX( 4)/'D', 40/ + DATA JCHAR( 5),INDEX( 5)/'E', 49/ + DATA JCHAR( 6),INDEX( 6)/'F', 60/ + DATA JCHAR( 7),INDEX( 7)/'G', 68/ + DATA JCHAR( 8),INDEX( 8)/'H', 82/ + DATA JCHAR( 9),INDEX( 9)/'I', 92/ + DATA JCHAR(10),INDEX(10)/'J',104/ + DATA JCHAR(11),INDEX(11)/'K',113/ + DATA JCHAR(12),INDEX(12)/'L',123/ + DATA JCHAR(13),INDEX(13)/'M',130/ + DATA JCHAR(14),INDEX(14)/'N',137/ + DATA JCHAR(15),INDEX(15)/'O',143/ + DATA JCHAR(16),INDEX(16)/'P',157/ + DATA JCHAR(17),INDEX(17)/'Q',166/ + DATA JCHAR(18),INDEX(18)/'R',182/ + DATA JCHAR(19),INDEX(19)/'S',194/ + DATA JCHAR(20),INDEX(20)/'T',210/ + DATA JCHAR(21),INDEX(21)/'U',219/ + DATA JCHAR(22),INDEX(22)/'V',229/ + DATA JCHAR(23),INDEX(23)/'W',236/ + DATA JCHAR(24),INDEX(24)/'X',245/ + DATA JCHAR(25),INDEX(25)/'Y',252/ + DATA JCHAR(26),INDEX(26)/'Z',262/ + DATA JCHAR(27),INDEX(27)/'0',273/ + DATA JCHAR(28),INDEX(28)/'1',286/ + DATA JCHAR(29),INDEX(29)/'2',296/ + DATA JCHAR(30),INDEX(30)/'3',308/ + DATA JCHAR(31),INDEX(31)/'4',326/ + DATA JCHAR(32),INDEX(32)/'5',339/ + DATA JCHAR(33),INDEX(33)/'6',352/ + DATA JCHAR(34),INDEX(34)/'7',368/ + DATA JCHAR(35),INDEX(35)/'8',378/ + DATA JCHAR(36),INDEX(36)/'9',398/ + DATA JCHAR(37),INDEX(37)/'+',414/ + DATA JCHAR(38),INDEX(38)/'-',423/ + DATA JCHAR(39),INDEX(39)/'*',429/ + DATA JCHAR(40),INDEX(40)/'/',444/ + DATA JCHAR(41),INDEX(41)/'(',448/ + DATA JCHAR(42),INDEX(42)/')',456/ + DATA JCHAR(43),INDEX(43)/'=',464/ + DATA JCHAR(44),INDEX(44)/' ',473/ + DATA JCHAR(45),INDEX(45)/',',476/ + DATA JCHAR(46),INDEX(46)/'.',486/ +C +C THE FOLLOWING DATA STATEMENTS CONTAIN THE DIGITIZATIONS OF THE +C CHARACTERS. THE CHARACTERS ARE DIGITIZED ON A BOX 6 UNITS WIDE AND +C 7 UNITS TALL. THIS INCLUDES 2 UNITS OF WHITE SPACE TO THE RIGHT OF +C EACH CHARACTER. IF KX=7, KY IS A FLAG -- KY=0 MEANS THE FOLLOWING +C KX AND KY ARE A PEN UP MOVE (ALL OTHERS ARE PEN DOWN MOVES), AND +C KY=7 MEANS THAT THE END OF THE DIGITIZATION FOR A PARTICULAR CHARAC- +C TER HAS BEEN REACHED. +C +c None of the following are used anywere. +c DATA WIDE,HIGH,WHITE/6.,7.,2./ +C + DATA KX( 1),KX( 2),KX( 3),KX( 4),KX( 5),KX( 6)/0,4,7,0,0,1/ + DATA KY( 1),KY( 2),KY( 3),KY( 4),KY( 5),KY( 6)/3,3,0,3,6,7/ + DATA KX( 7),KX( 8),KX( 9),KX( 10),KX( 11),KX( 12)/3,4,4,7,6,7/ + DATA KY( 7),KY( 8),KY( 9),KY( 10),KY( 11),KY( 12)/7,6,0,0,0,7/ + DATA KX( 13),KX( 14),KX( 15),KX( 16),KX( 17),KX( 18)/0,3,4,4,3,0/ + DATA KY( 13),KY( 14),KY( 15),KY( 16),KY( 17),KY( 18)/7,7,6,5,4,4/ + DATA KX( 19),KX( 20),KX( 21),KX( 22),KX( 23),KX( 24)/7,3,4,4,3,0/ + DATA KY( 19),KY( 20),KY( 21),KY( 22),KY( 23),KY( 24)/0,4,3,1,0,0/ + DATA KX( 25),KX( 26),KX( 27),KX( 28),KX( 29),KX( 30)/7,6,7,7,4,3/ + DATA KY( 25),KY( 26),KY( 27),KY( 28),KY( 29),KY( 30)/0,0,7,0,6,7/ + DATA KX( 31),KX( 32),KX( 33),KX( 34),KX( 35),KX( 36)/1,0,0,1,3,4/ + DATA KY( 31),KY( 32),KY( 33),KY( 34),KY( 35),KY( 36)/7,6,1,0,0,1/ + DATA KX( 37),KX( 38),KX( 39),KX( 40),KX( 41),KX( 42)/7,6,7,0,3,4/ + DATA KY( 37),KY( 38),KY( 39),KY( 40),KY( 41),KY( 42)/0,0,7,7,7,6/ + DATA KX( 43),KX( 44),KX( 45),KX( 46),KX( 47),KX( 48)/4,3,0,7,6,7/ + DATA KY( 43),KY( 44),KY( 45),KY( 46),KY( 47),KY( 48)/1,0,0,0,0,7/ + DATA KX( 49),KX( 50),KX( 51),KX( 52),KX( 53),KX( 54)/0,4,7,3,0,7/ + DATA KY( 49),KY( 50),KY( 51),KY( 52),KY( 53),KY( 54)/7,7,0,4,4,0/ + DATA KX( 55),KX( 56),KX( 57),KX( 58),KX( 59),KX( 60)/0,4,7,6,7,0/ + DATA KY( 55),KY( 56),KY( 57),KY( 58),KY( 59),KY( 60)/0,0,0,0,7,7/ + DATA KX( 61),KX( 62),KX( 63),KX( 64),KX( 65),KX( 66)/4,7,0,3,7,6/ + DATA KY( 61),KY( 62),KY( 63),KY( 64),KY( 65),KY( 66)/7,0,4,4,0,0/ + DATA KX( 67),KX( 68),KX( 69),KX( 70),KX( 71),KX( 72)/7,7,4,3,1,0/ + DATA KY( 67),KY( 68),KY( 69),KY( 70),KY( 71),KY( 72)/7,0,6,7,7,6/ + DATA KX( 73),KX( 74),KX( 75),KX( 76),KX( 77),KX( 78)/0,1,3,4,4,3/ + DATA KY( 73),KY( 74),KY( 75),KY( 76),KY( 77),KY( 78)/1,0,0,1,3,3/ + DATA KX( 79),KX( 80),KX( 81),KX( 82),KX( 83),KX( 84)/7,6,7,0,7,0/ + DATA KY( 79),KY( 80),KY( 81),KY( 82),KY( 83),KY( 84)/0,0,7,7,0,4/ + DATA KX( 85),KX( 86),KX( 87),KX( 88),KX( 89),KX( 90)/4,7,4,4,7,6/ + DATA KY( 85),KY( 86),KY( 87),KY( 88),KY( 89),KY( 90)/4,0,7,0,0,0/ + DATA KX( 91),KX( 92),KX( 93),KX( 94),KX( 95),KX( 96)/7,7,1,3,7,2/ + DATA KY( 91),KY( 92),KY( 93),KY( 94),KY( 95),KY( 96)/7,0,7,7,0,7/ + DATA KX( 97),KX( 98),KX( 99),KX(100),KX(101),KX(102)/2,7,1,3,7,6/ + DATA KY( 97),KY( 98),KY( 99),KY(100),KY(101),KY(102)/0,0,0,0,0,0/ + DATA KX(103),KX(104),KX(105),KX(106),KX(107),KX(108)/7,7,0,1,3,4/ + DATA KY(103),KY(104),KY(105),KY(106),KY(107),KY(108)/7,0,1,0,0,1/ + DATA KX(109),KX(110),KX(111),KX(112),KX(113),KX(114)/4,7,6,7,0,7/ + DATA KY(109),KY(110),KY(111),KY(112),KY(113),KY(114)/7,0,0,7,7,0/ + DATA KX(115),KX(116),KX(117),KX(118),KX(119),KX(120)/0,4,7,2,4,7/ + DATA KY(115),KY(116),KY(117),KY(118),KY(119),KY(120)/3,7,0,5,0,0/ + DATA KX(121),KX(122),KX(123),KX(124),KX(125),KX(126)/6,7,7,0,0,4/ + DATA KY(121),KY(122),KY(123),KY(124),KY(125),KY(126)/0,7,0,7,0,0/ + DATA KX(127),KX(128),KX(129),KX(130),KX(131),KX(132)/7,6,7,0,2,4/ + DATA KY(127),KY(128),KY(129),KY(130),KY(131),KY(132)/0,0,7,7,3,7/ + DATA KX(133),KX(134),KX(135),KX(136),KX(137),KX(138)/4,7,6,7,0,4/ + DATA KY(133),KY(134),KY(135),KY(136),KY(137),KY(138)/0,0,0,7,7,0/ + DATA KX(139),KX(140),KX(141),KX(142),KX(143),KX(144)/4,7,6,7,4,7/ + DATA KY(139),KY(140),KY(141),KY(142),KY(143),KY(144)/7,0,0,7,7,0/ + DATA KX(145),KX(146),KX(147),KX(148),KX(149),KX(150)/4,4,3,1,0,0/ + DATA KY(145),KY(146),KY(147),KY(148),KY(149),KY(150)/1,6,7,7,6,1/ + DATA KX(151),KX(152),KX(153),KX(154),KX(155),KX(156)/1,3,4,7,6,7/ + DATA KY(151),KY(152),KY(153),KY(154),KY(155),KY(156)/0,0,1,0,0,7/ + DATA KX(157),KX(158),KX(159),KX(160),KX(161),KX(162)/0,3,4,4,3,0/ + DATA KY(157),KY(158),KY(159),KY(160),KY(161),KY(162)/7,7,6,5,4,4/ + DATA KX(163),KX(164),KX(165),KX(166),KX(167),KX(168)/7,6,7,7,0,0/ + DATA KY(163),KY(164),KY(165),KY(166),KY(167),KY(168)/0,0,7,0,1,6/ + DATA KX(169),KX(170),KX(171),KX(172),KX(173),KX(174)/1,3,4,4,3,1/ + DATA KY(169),KY(170),KY(171),KY(172),KY(173),KY(174)/7,7,6,1,0,0/ + DATA KX(175),KX(176),KX(177),KX(178),KX(179),KX(180)/0,7,2,4,7,6/ + DATA KY(175),KY(176),KY(177),KY(178),KY(179),KY(180)/1,0,2,0,0,0/ + DATA KX(181),KX(182),KX(183),KX(184),KX(185),KX(186)/7,0,3,4,4,3/ + DATA KY(181),KY(182),KY(183),KY(184),KY(185),KY(186)/7,7,7,6,5,4/ + DATA KX(187),KX(188),KX(189),KX(190),KX(191),KX(192)/0,7,2,4,7,6/ + DATA KY(187),KY(188),KY(189),KY(190),KY(191),KY(192)/4,0,4,0,0,0/ + DATA KX(193),KX(194),KX(195),KX(196),KX(197),KX(198)/7,7,0,1,3,4/ + DATA KY(193),KY(194),KY(195),KY(196),KY(197),KY(198)/7,0,1,0,0,1/ + DATA KX(199),KX(200),KX(201),KX(202),KX(203),KX(204)/4,3,1,0,0,1/ + DATA KY(199),KY(200),KY(201),KY(202),KY(203),KY(204)/3,4,4,5,6,7/ + DATA KX(205),KX(206),KX(207),KX(208),KX(209),KX(210)/3,4,7,6,7,7/ + DATA KY(205),KY(206),KY(207),KY(208),KY(209),KY(210)/7,6,0,0,7,0/ + DATA KX(211),KX(212),KX(213),KX(214),KX(215),KX(216)/0,4,7,2,2,7/ + DATA KY(211),KY(212),KY(213),KY(214),KY(215),KY(216)/7,7,0,7,0,0/ + DATA KX(217),KX(218),KX(219),KX(220),KX(221),KX(222)/6,7,7,0,0,1/ + DATA KY(217),KY(218),KY(219),KY(220),KY(221),KY(222)/0,7,0,7,1,0/ + DATA KX(223),KX(224),KX(225),KX(226),KX(227),KX(228)/3,4,4,7,6,7/ + DATA KY(223),KY(224),KY(225),KY(226),KY(227),KY(228)/0,1,7,0,0,7/ + DATA KX(229),KX(230),KX(231),KX(232),KX(233),KX(234)/7,0,2,4,7,6/ + DATA KY(229),KY(230),KY(231),KY(232),KY(233),KY(234)/0,7,0,7,0,0/ + DATA KX(235),KX(236),KX(237),KX(238),KX(239),KX(240)/7,7,0,0,2,4/ + DATA KY(235),KY(236),KY(237),KY(238),KY(239),KY(240)/7,0,7,0,4,0/ + DATA KX(241),KX(242),KX(243),KX(244),KX(245),KX(246)/4,7,6,7,4,7/ + DATA KY(241),KY(242),KY(243),KY(244),KY(245),KY(246)/7,0,0,7,7,0/ + DATA KX(247),KX(248),KX(249),KX(250),KX(251),KX(252)/0,4,7,6,7,7/ + DATA KY(247),KY(248),KY(249),KY(250),KY(251),KY(252)/7,0,0,0,7,0/ + DATA KX(253),KX(254),KX(255),KX(256),KX(257),KX(258)/0,2,4,7,2,2/ + DATA KY(253),KY(254),KY(255),KY(256),KY(257),KY(258)/7,4,7,0,4,0/ + DATA KX(259),KX(260),KX(261),KX(262),KX(263),KX(264)/7,6,7,7,3,1/ + DATA KY(259),KY(260),KY(261),KY(262),KY(263),KY(264)/0,0,7,0,4,4/ + DATA KX(265),KX(266),KX(267),KX(268),KX(269),KX(270)/7,0,4,0,4,7/ + DATA KY(265),KY(266),KY(267),KY(268),KY(269),KY(270)/0,7,7,0,0,0/ + DATA KX(271),KX(272),KX(273),KX(274),KX(275),KX(276)/6,7,7,4,3,1/ + DATA KY(271),KY(272),KY(273),KY(274),KY(275),KY(276)/0,7,0,1,0,0/ + DATA KX(277),KX(278),KX(279),KX(280),KX(281),KX(282)/0,0,1,3,4,4/ + DATA KY(277),KY(278),KY(279),KY(280),KY(281),KY(282)/1,6,7,7,6,1/ + DATA KX(283),KX(284),KX(285),KX(286),KX(287),KX(288)/7,6,7,7,1,2/ + DATA KY(283),KY(284),KY(285),KY(286),KY(287),KY(288)/0,0,7,0,6,7/ + DATA KX(289),KX(290),KX(291),KX(292),KX(293),KX(294)/2,7,1,3,7,6/ + DATA KY(289),KY(290),KY(291),KY(292),KY(293),KY(294)/0,0,0,0,0,0/ + DATA KX(295),KX(296),KX(297),KX(298),KX(299),KX(300)/7,7,0,1,3,4/ + DATA KY(295),KY(296),KY(297),KY(298),KY(299),KY(300)/7,0,6,7,7,6/ + DATA KX(301),KX(302),KX(303),KX(304),KX(305),KX(306)/4,0,0,4,7,6/ + DATA KY(301),KY(302),KY(303),KY(304),KY(305),KY(306)/5,1,0,0,0,0/ + DATA KX(307),KX(308),KX(309),KX(310),KX(311),KX(312)/7,7,0,1,3,4/ + DATA KY(307),KY(308),KY(309),KY(310),KY(311),KY(312)/7,0,6,7,7,6/ + DATA KX(313),KX(314),KX(315),KX(316),KX(317),KX(318)/4,3,1,7,3,4/ + DATA KY(313),KY(314),KY(315),KY(316),KY(317),KY(318)/5,4,4,0,4,3/ + DATA KX(319),KX(320),KX(321),KX(322),KX(323),KX(324)/4,3,1,0,7,6/ + DATA KY(319),KY(320),KY(321),KY(322),KY(323),KY(324)/1,0,0,1,0,0/ + DATA KX(325),KX(326),KX(327),KX(328),KX(329),KX(330)/7,7,3,3,2,0/ + DATA KY(325),KY(326),KY(327),KY(328),KY(329),KY(330)/7,0,0,7,7,4/ + DATA KX(331),KX(332),KX(333),KX(334),KX(335),KX(336)/0,4,7,2,4,7/ + DATA KY(331),KY(332),KY(333),KY(334),KY(335),KY(336)/3,3,0,0,0,0/ + DATA KX(337),KX(338),KX(339),KX(340),KX(341),KX(342)/6,7,7,0,1,3/ + DATA KY(337),KY(338),KY(339),KY(340),KY(341),KY(342)/0,7,0,1,0,0/ + DATA KX(343),KX(344),KX(345),KX(346),KX(347),KX(348)/4,4,3,0,0,4/ + DATA KY(343),KY(344),KY(345),KY(346),KY(347),KY(348)/1,3,4,4,7,7/ + DATA KX(349),KX(350),KX(351),KX(352),KX(353),KX(354)/7,6,7,7,4,3/ + DATA KY(349),KY(350),KY(351),KY(352),KY(353),KY(354)/0,0,7,0,6,7/ + DATA KX(355),KX(356),KX(357),KX(358),KX(359),KX(360)/1,0,0,1,3,4/ + DATA KY(355),KY(356),KY(357),KY(358),KY(359),KY(360)/7,6,1,0,0,1/ + DATA KX(361),KX(362),KX(363),KX(364),KX(365),KX(366)/4,3,1,0,7,6/ + DATA KY(361),KY(362),KY(363),KY(364),KY(365),KY(366)/3,4,4,3,0,0/ + DATA KX(367),KX(368),KX(369),KX(370),KX(371),KX(372)/7,7,0,0,4,4/ + DATA KY(367),KY(368),KY(369),KY(370),KY(371),KY(372)/7,0,6,7,7,6/ + DATA KX(373),KX(374),KX(375),KX(376),KX(377),KX(378)/2,2,7,6,7,7/ + DATA KY(373),KY(374),KY(375),KY(376),KY(377),KY(378)/1,0,0,0,7,0/ + DATA KX(379),KX(380),KX(381),KX(382),KX(383),KX(384)/1,0,0,1,3,4/ + DATA KY(379),KY(380),KY(381),KY(382),KY(383),KY(384)/4,5,6,7,7,6/ + DATA KX(385),KX(386),KX(387),KX(388),KX(389),KX(390)/4,3,1,0,0,1/ + DATA KY(385),KY(386),KY(387),KY(388),KY(389),KY(390)/5,4,4,3,1,0/ + DATA KX(391),KX(392),KX(393),KX(394),KX(395),KX(396)/3,4,4,3,7,6/ + DATA KY(391),KY(392),KY(393),KY(394),KY(395),KY(396)/0,1,3,4,0,0/ + DATA KX(397),KX(398),KX(399),KX(400),KX(401),KX(402)/7,7,0,1,3,4/ + DATA KY(397),KY(398),KY(399),KY(400),KY(401),KY(402)/7,0,1,0,0,1/ + DATA KX(403),KX(404),KX(405),KX(406),KX(407),KX(408)/4,3,1,0,0,1/ + DATA KY(403),KY(404),KY(405),KY(406),KY(407),KY(408)/6,7,7,6,4,3/ + DATA KX(409),KX(410),KX(411),KX(412),KX(413),KX(414)/3,4,7,6,7,7/ + DATA KY(409),KY(410),KY(411),KY(412),KY(413),KY(414)/3,4,0,0,7,0/ + DATA KX(415),KX(416),KX(417),KX(418),KX(419),KX(420)/0,4,7,2,2,7/ + DATA KY(415),KY(416),KY(417),KY(418),KY(419),KY(420)/3,3,0,5,1,0/ + DATA KX(421),KX(422),KX(423),KX(424),KX(425),KX(426)/6,7,7,0,4,7/ + DATA KY(421),KY(422),KY(423),KY(424),KY(425),KY(426)/0,7,0,3,3,0/ + DATA KX(427),KX(428),KX(429),KX(430),KX(431),KX(432)/6,7,7,0,4,7/ + DATA KY(427),KY(428),KY(429),KY(430),KY(431),KY(432)/0,7,0,1,5,0/ + DATA KX(433),KX(434),KX(435),KX(436),KX(437),KX(438)/2,2,7,4,0,7/ + DATA KY(433),KY(434),KY(435),KY(436),KY(437),KY(438)/5,1,0,3,3,0/ + DATA KX(439),KX(440),KX(441),KX(442),KX(443),KX(444)/0,4,7,6,7,4/ + DATA KY(439),KY(440),KY(441),KY(442),KY(443),KY(444)/5,1,0,0,7,7/ + DATA KX(445),KX(446),KX(447),KX(448),KX(449),KX(450)/7,6,7,7,3,2/ + DATA KY(445),KY(446),KY(447),KY(448),KY(449),KY(450)/0,0,7,1,7,6/ + DATA KX(451),KX(452),KX(453),KX(454),KX(455),KX(456)/2,3,7,6,7,7/ + DATA KY(451),KY(452),KY(453),KY(454),KY(455),KY(456)/1,0,0,0,7,0/ + DATA KX(457),KX(458),KX(459),KX(460),KX(461),KX(462)/1,2,2,1,7,6/ + DATA KY(457),KY(458),KY(459),KY(460),KY(461),KY(462)/7,6,1,0,0,0/ + DATA KX(463),KX(464),KX(465),KX(466),KX(467),KX(468)/7,7,4,0,7,0/ + DATA KY(463),KY(464),KY(465),KY(466),KY(467),KY(468)/7,0,5,5,0,2/ + DATA KX(469),KX(470),KX(471),KX(472),KX(473),KX(474)/4,7,6,7,7,6/ + DATA KY(469),KY(470),KY(471),KY(472),KY(473),KY(474)/2,0,0,7,0,0/ + DATA KX(475),KX(476),KX(477),KX(478),KX(479),KX(480)/7,7,1,2,2,1/ + DATA KY(475),KY(476),KY(477),KY(478),KY(479),KY(480)/7,0,0,1,2,2/ + DATA KX(481),KX(482),KX(483),KX(484),KX(485),KX(486)/1,2,7,6,7,7/ + DATA KY(481),KY(482),KY(483),KY(484),KY(485),KY(486)/1,1,0,0,7,0/ + DATA KX(487),KX(488),KX(489),KX(490),KX(491),KX(492)/2,1,1,2,2,7/ + DATA KY(487),KY(488),KY(489),KY(490),KY(491),KY(492)/0,0,1,1,0,0/ + DATA KX(493),KX(494) /6,7 / + DATA KY(493),KY(494) /0,7 / +C +C NSIZE IS THE LENGTH OF JCHAR AND INDEX. +C LNGTH IS THE LENGTH OF KX AND KY. +C LENTRY TELLS IF THIS IS THE FIRTST CALL TO PWRZS. +C + DATA NSIZE/46/ +c Variable LNGTH never used. +c DATA LNGTH/494/ + DATA LENTRY/.FALSE./ + DATA ITHETA/0/ + DATA IDUM1,IDUM2,IDUM3/1,1,1/ +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','PWRZS','PWRZS','VERSION 1') +C +C INQUIRE CURRENT NORMALIZATION TRANS NUMBER +C + CALL GQCNTN (IERR,NTORIG) +C +C SAVE NORMALIZATION TRANS 1 AND LOG SCALING FLAG +C + CALL GQNT (1,IERR,WNDW,VWPRT) + CALL GETUSV('LS',IOLLS) +C +C DEFINE NORMALIZATION TRANS 1 FOR USE WITH DRAWS +C +c +NOAO: device viewport now user controlled through common noaovp + call set (vpx1, vpx2, vpy1, vpy2, 1., 1024., 1., 1024., 1) +c CALL SET(0.0,1.0,0.0,1.0,1.0,1024.0,1.0,1024.0,1) +c-NOAO +C +C SEE IF THIS IS THE FIRST CALL TO PWRZS +C + IF (LENTRY) GO TO 103 +C +C MARK THAT FUTURE CALLS NEED NOT DO THIS CODE. +C + LENTRY = .TRUE. +C +C RECORD THE LOCATION OF THE BLANK SO IT CAN BE USED FOR UNKNOWN +C CHARACTERS. +C + IBLKPT = INDEX(44) +C +C CHANGE EACH CHARACTER IN THE TABLE TO RIGHT JUSTIFIED, ZERO FILLED. +C +C +C SORT JCHAR MAINTAINING THE RELATIONSHIP BETWEEN JCHAR AND INDEX. +C (THAT IS, IF JCHAR(I)='B', THEN INDEX(I)=13 FROM THE ABOVE DATA STMT.) +C THIS WILL ENABLE CHARACTERS TO BE QUICKLY FOUND IN ALL SUBSEQUENT +C CALLS TO PWRZS. +C + CALL PWRZOS (JCHAR,INDEX,NSIZE) +C +C ALL ONE-TIME INITIALIZATION NOW FINISHED. +C + 103 CONTINUE +C + NN = N + IF (NN .LE. 0) RETURN + FNNM1 = NN-1 + JCNT = ICNT +C +C PUT RELATIVE SIZE IN Q, ADJUST FOR CURRENT PLOTTER RESOLUTION +C + CALL GETUSV ('XF',LX) + SCALE = 2.**(LX-10) + IF (ISIZE .EQ. 0) Q = 1.3334*SCALE + IF (ISIZE .EQ. 1) Q = 2.*SCALE + IF (ISIZE .EQ. 2) Q = 2.6667*SCALE + IF (ISIZE .EQ. 3) Q = 4.*SCALE + IF (ISIZE .GT. 3) Q = FLOAT(ISIZE)/(6.) +C +C PUT ANGLE IN RADIANS IN T. +C + T = FLOAT(ITHETA)*1.5708 + 104 CONTINUE +C +C CALCULATE COMBINED TRANSFORMATION +C + CT = Q*COS(T) + ST = Q*SIN(T) +C +C FIND CRT COORDINATES OF CENTER. +C + LINEI = LIN3 + CALL INTZS (X,Y,Z,LINEI,ITOP) + IF (LINEI .EQ. 0) RETURN + IX = 0 + IY = 0 + XC = IX + YC = IY +C +C CORRECT FOR CHARACTER DATA BEING LOWER-LEFT-HAND POSITIONED. +C + XC = XC-2.*CT+3.5*ST + YC = YC-2.*ST-3.5*CT +C +C CORRECT FOR CENTERING IF TURNED ON. +C + JCNT = MAX0(-1,MIN0(1,JCNT))+2 + GO TO (108,107,109),JCNT + 107 XC = XC-CT*FNNM1*3. + YC = YC-ST*FNNM1*3. + GO TO 110 + 108 XC = XC+CT*2. + YC = YC+ST*2. + GO TO 110 + 109 XC = XC-CT*2. + YC = YC-ST*2. + XC = XC-CT*FNNM1*6. + YC = YC-ST*FNNM1*6. + 110 CALL INITZS (IFIX(XC),IFIX(YC),1,IDUM1,IDUM2,2) + CALL INITZS (IFIX(XC+CT*6.*FNNM1),IFIX(YC+ST*6.*FNNM1),2,IDUM1, + + IDUM2,2) + CALL INITZS (IFIX(XC),IFIX(YC),IDUM1,IDUM2,IDUM3,3) + DO 114 K=1,NN + XB = XC + YB = YC + IP = 1 +C +C EXTRACT CHARACTER NUMBER K FROM THE STRING. +C + KCHAR = ID(K:K) +C +C FIND THE TABLE ENTRY. +C + CALL PWRZGS (KCHAR,JCHAR,INDEX,NSIZE,IPOINT) + IF (IPOINT .EQ. -1) IPOINT = IBLKPT +C +C ALWAYS LESS THAN 20 INSTRUCTIONS. +C + DO 113 L=1,20 + ISUB = IPOINT+L-1 + NX = KX(ISUB) + FNX = NX + NY = KY(ISUB) + FNY = NY +C +C TEST FOR OP-CODE OR DX AND DY. +C + IF (NX .NE. 7) GO TO 111 +C +C OP-CODE +C + IP = 0 + IF (NY-7) 113,114,113 +C +C DX AND DY +C + 111 XC = XB+FNX*CT-FNY*ST + YC = YB+FNX*ST+FNY*CT +C +C CALL DESIRED PLOTTING ROUTINE. DETERMINED BY OP-CODES. +C + IF (IP .NE. 0) GO TO 112 + CALL INITZS (IFIX(XC+.5),IFIX(YC+.5),IDUM1,IDUM2,IDUM3,3) + IP = 1 + GO TO 113 + 112 CALL INITZS (IFIX(XC+.5),IFIX(YC+.5),IDUM1,IDUM2,IDUM3,4) + 113 CONTINUE + 114 CONTINUE +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(0,0,0) +C +C RESTORE NORMALIZATION TRANS 1 AND LOG SCALING +C + CALL SET(VWPRT(1),VWPRT(2),VWPRT(3),VWPRT(4), + + WNDW(1),WNDW(2),WNDW(3),WNDW(4),IOLLS) + CALL GSELNT (NTORIG) + RETURN + END + SUBROUTINE INTZS (XX,YY,ZZ,LIN3,ITOP) +C +C FORCE STORAGE OF X, Y, AND Z INTO COMMON BLOCK +C + COMMON /PWRZ2S/ X, Y, Z + DATA IDUMX,IDUMY,IDUMZ /0, 0, 0/ + X = XX + Y = YY + Z = ZZ + CALL INITZS (IDUMX,IDUMY,IDUMZ,LIN3,ITOP,1) + RETURN + END + SUBROUTINE INITZS (IX,IY,IZ,LIN3,ITOP,IENT) +C + SAVE + COMMON /PWRZ1S/ XXMIN ,XXMAX ,YYMIN ,YYMAX , + + ZZMIN ,ZZMAX ,DELCRT,EYEX , + + EYEY ,EYEZ +C + COMMON /PWRZ2S/ X ,Y ,Z +c +NOAO: common block added to allow user control of device viewport. + common /noaovp/ vpx1, vpx2, vpy1, vpy2 +c -NOAO + FX(R) = R+FACTX*FLOAT(IX) + FY(R) = R+FACTY*FLOAT(IY) +C +C +C DETERMINE INITZS,VISSET,FRSTZ OR VECTZ CALL +C + GO TO (1000,2000,3000,4000),IENT + 1000 LIN = MAX0(1,MIN0(3,IABS(LIN3))) + ITO = MAX0(1,MIN0(3,IABS(ITOP))) +C +C SET UP SCALING CONSTANTS +C + DELMAX = AMAX1(XXMAX-XXMIN,YYMAX-YYMIN,ZZMAX-ZZMIN) + FACTOR = DELMAX/DELCRT + FACTX = SIGN(FACTOR,FLOAT(LIN3)) + FACTY = SIGN(FACTOR,FLOAT(ITOP)) +C +C SET UP FOR PROPER PLANE +C + JUMP1 = LIN+(ITO-1)*3 + GO TO (108,101,102,103,108,104,105,106,108),JUMP1 + 101 ASSIGN 111 TO JUMP + GO TO 107 + 102 ASSIGN 112 TO JUMP + GO TO 107 + 103 ASSIGN 113 TO JUMP + GO TO 107 + 104 ASSIGN 114 TO JUMP + GO TO 107 + 105 ASSIGN 115 TO JUMP + GO TO 107 + 106 ASSIGN 116 TO JUMP + 107 RETURN + 108 CALL SETER ('INITZS - LINE OR ITOP IMPROPER IN PWRZS CALL' ,1,1) + LIN3 = 0 + RETURN +C +C **************************** ENTRY VISSET **************************** +C ENTRY VISSET (IX,IY,IZ) +C +C +C VISSET IS CALLED ONCE FOR EACH END OF THE CHARACTER STRING +C + 2000 IVIS = -1 + ITEMP = 0 + GO TO 110 +C +C SEE IF THIS END COULD BE BEHIND THE OBJECT +C + 109 IF (EYEX.GT.XXMAX .AND. XX.GT.XXMAX) ITEMP = ITEMP+1 + IF (EYEY.GT.YYMAX .AND. YY.GT.YYMAX) ITEMP = ITEMP+1 + IF (EYEZ.GT.ZZMAX .AND. ZZ.GT.ZZMAX) ITEMP = ITEMP+1 + IF (EYEX.LT.XXMIN .AND. XX.LT.XXMIN) ITEMP = ITEMP+1 + IF (EYEY.LT.YYMIN .AND. YY.LT.YYMIN) ITEMP = ITEMP+1 + IF (EYEZ.LT.ZZMIN .AND. ZZ.LT.ZZMIN) ITEMP = ITEMP+1 + IF (IZ .EQ. 1) IVISS = ITEMP +C +C IF EITHER END CHARACTER COULD BE HIDDEN, TEST ALL LINE SEGMENTS. +C + IF (IZ .EQ. 2) IVIS = MIN0(IVISS,ITEMP) + RETURN +C +C **************************** ENTRY FRSTZ ***************************** +C ENTRY FRSTZ (IX,IY) +C + 3000 IFRST = 1 + GO TO 110 +C +C **************************** ENTRY VECTZ ***************************** +C ENTRY VECTZ (IX,IY) +C + 4000 IFRST = 0 +C +C PICK CORRECT 3-SPACE PLANE TO DRAW IN +C + 110 GO TO JUMP,(111,112,113,114,115,116) + 111 XX = FY(X) + YY = FX(Y) + ZZ = Z + GO TO 117 + 112 XX = FY(X) + YY = Y + ZZ = FX(Z) + GO TO 117 + 113 XX = FX(X) + YY = FY(Y) + ZZ = Z + GO TO 117 + 114 XX = X + YY = FY(Y) + ZZ = FX(Z) + GO TO 117 + 115 XX = FX(X) + YY = Y + ZZ = FY(Z) + GO TO 117 + 116 XX = X + YY = FX(Y) + ZZ = FY(Z) +C +C TRANSLATE TO 2-SPACE +C + 117 CALL TRN32S (XX,YY,ZZ,XT,YT,DUMMY,1) + IF (IVIS) 109,121,118 + 118 IF (IFRST) 119,120,119 +C +C IF IN FRONT, DRAW IN ANY CASE. +C +c +NOAO: Remove the assumption that window coordinates 1-1024 map to the +c full plotter metacode range 1-32768 +c + 119 zzxmc = (32768./1023.) * (vpx2 - vpx1) * (xt-1.) + (vpx1 * 32768.) + zzymc = (32768./1023.) * (vpy2 - vpy1) * (yt-1.) + (vpy1 * 32768.) + call plotit (ifix(zzxmc), ifix(zzymc), 0) +c 119 CALL PLOTIT (32*IFIX(XT),32*IFIX(YT),0) + RETURN +c + 120 zzxmc = (32768./1023.) * (vpx2 - vpx1) * (xt-1.) + (vpx1 * 32768.) + zzymc = (32768./1023.) * (vpy2 - vpy1) * (yt-1.) + (vpy1 * 32768.) + call plotit (ifix(zzxmc), ifix(zzymc), 1) +c 120 CALL PLOTIT (32*IFIX(XT),32*IFIX(YT),1) +c -NOAO + RETURN + 121 IF (IFRST) 122,123,122 + 122 IX1 = XT + IY1 = YT + RETURN + 123 IX2 = XT + IY2 = YT +C +C IF COULD BE HIDDEN, USE HIDDEN LINE PLOTTING ENTRY IN SRFACE +C + CALL DRAWS (IX1,IY1,IX2,IY2,1,0) + IX1 = IX2 + IY1 = IY2 + RETURN + END + SUBROUTINE PWRZOS (JCHAR,INDEX,NSIZE) +C +C THIS ROUTINE SORTS JCHAR WHICH IS NSIZE IN LENGTH. THE RELATIONSHIP +C BETWEEN JCHAR AND INDEX IS MAINTAINED. A BUBBLE SORT IS USED. +C JCHAR IS SORTED IN ASCENDING ORDER. +C + SAVE + CHARACTER*1 JCHAR(NSIZE) ,JTEMP ,KTEMP + DIMENSION INDEX(NSIZE) + LOGICAL LDONE +C + ISTART = 1 + ISTOP = NSIZE + ISTEP = 1 +C +C AT MOST NSIZE PASSES ARE NEEDED. +C + DO 104 NPASS=1,NSIZE + LDONE = .TRUE. + I = ISTART + 101 ISUB = I+ISTEP + IF (ISTEP*(ICHAR(JCHAR(I))-ICHAR(JCHAR(ISUB)))) 103,103,102 +C +C THEY NEED TO BE SWITCHED. +C + 102 LDONE = .FALSE. + JTEMP = JCHAR(I) + KTEMP = JCHAR(ISUB) + JCHAR(I) = KTEMP + JCHAR(ISUB) = JTEMP + ITEMP = INDEX(I) + INDEX(I) = INDEX(ISUB) + INDEX(ISUB) = ITEMP +C +C THEY DO NOT NEED TO BE SWITCHED. +C + 103 I = I+ISTEP + IF (I .NE. ISTOP) GO TO 101 +C +C IF NONE WERE SWITCHED DURING THIS PASS, WE CAN QUIT. +C + IF (LDONE) RETURN +C +C SET UP FOR THE NEXT PASS IN THE OTHER DIRECTION. +C + ISTEP = -ISTEP + ITEMP = ISTART + ISTART = ISTOP+ISTEP + ISTOP = ITEMP + 104 CONTINUE + RETURN + END + SUBROUTINE PWRZGS (KCHAR,JCHAR,INDEX,NSIZE,IPOINT) +C +C THIS ROUTINE FINDS WHERE KCHAR IS IN JCHAR AND RETURNS THE CORRES- +C PONDING INDEX IN IPOINT. BINARY HALVING IS USED. +C + SAVE + CHARACTER*1 JCHAR(NSIZE) ,KCHAR + DIMENSION INDEX(NSIZE) +C +C IT IS ASSUMED THAT JCHAR IS LESS THAT 2**9 IN LENGTH, SO IF KCHAR IS +C NOT FOUND IN 10 STEPS, THE SEARCH IS STOPPED. +C + KOUNT = 0 + IBOT = 1 + ITOP = NSIZE + I = ITOP + GO TO 102 + 101 I = (IBOT+ITOP)/2 + KOUNT = KOUNT+1 + IF (KOUNT .GT. 10) GO TO 106 + 102 IF (ICHAR(JCHAR(I))-ICHAR(KCHAR)) 103,105,104 + 103 IBOT = I + GO TO 101 + 104 ITOP = I + GO TO 101 + 105 IPOINT = INDEX(I) + RETURN +C +C IPOINT=-1 MEANS THAT KCHAR WAS NOT IN THE TABLE. +C + 106 IPOINT = -1 + RETURN +C +C +C +C REVISION HISTORY---------- +C +C MARCH 1980 FIRST ADDED TO ULIB AS A SEPARATE FILE TO BE +C USED IN CONJUNCTION WITH THE ULIB ROUTINE +C SRFACE +C +C JULY 1984 CONVERTED TO GKS AND FORTRAN 77 +C------------------------------------------------------------------ + END diff --git a/sys/gio/ncarutil/pwrzt.f b/sys/gio/ncarutil/pwrzt.f new file mode 100644 index 00000000..eea2b0d0 --- /dev/null +++ b/sys/gio/ncarutil/pwrzt.f @@ -0,0 +1,731 @@ + SUBROUTINE PWRZT (X,Y,Z,ID,N,ISIZE,LIN3,ITOP,ICNT) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE PWRZT IS A CHARACTER PLOTTING ROUTINE FOR +C PLOTTING CHARACTERS IN THREE-SPACE WHEN USING +C THREED. FOR A LARGE CLASS OF +C POSSIBLE POSITIONS, THE HIDDEN CHARACTER +C PROBLEM IS SOLVED. +C +C +C +C USAGE CALL PWRZT (X,Y,Z,ID,N,ISIZE,LINE,ITOP,ICNT) +C USE CALL PWRZT AFTER CALLING +C THREED AND BEFORE CALLING FRAME. +C +C ARGUMENTS +C +C ON INPUT X,Y,Z +C POSITIONING COORDINATES FOR THE CHARACTERS +C TO BE DRAWN. THESE ARE FLOATING POINT +C NUMBERS IN THE SAME THREE-SPACE AS USED IN +C THREED. +C +C ID +C CHARACTER STRING TO BE DRAWN. ID IS OF TYPE +C CHARACTER . +C +C N +C THE NUMBER OF CHARACTERS IN ID. +C +C ISIZE +C SIZE OF THE CHARACTER: +C . IF BETWEEN 0 AND 3, ISIZE IS 1., 1.5, +C 2., OR 3. TIMES A STANDARD WIDTH EQUAL +C TO 1/128TH OF THE SCREEN WIDTH. +C . IF GREATER THAN 3, ISIZE IS THE CHARACTER +C WIDTH IN PLOTTER ADDRESS UNITS. +C +C LINE +C THE DIRECTION IN WHICH THE CHARACTERS ARE TO +C BE WRITTEN. +C 1 = +X -1 = -X +C 2 = +Y -2 = -Y +C 3 = +Z -3 = -Z +C +C ITOP +C THE DIRECTION FROM THE CENTER OF THE FIRST +C CHARACTER TO THE TOP OF THE FIRST +C CHARACTER (THE POTENTIAL VALUES FOR +C ITOP ARE THE SAME AS THOSE FOR LINE AS +C GIVEN ABOVE.) NOTE THAT LINE CANNOT +C EQUAL ITOP EVEN IN ABSOLUTE VALUE. +C +C ICNT +C CENTERING OPTION. +C -1 (X,Y,Z) IS THE CENTER OF THE LEFT EDGE OF +C THE FIRST CHARACTER. +C 0 (X,Y,Z) IS THE CENTER OF THE ENTIRE +C STRING. +C 1 (X,Y,Z) IS THE CENTER OF THE RIGHT EDGE +C OF THE LAST CHARACTER. +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED. +C +C NOTE THE HIDDEN CHARACTER PROBLEM IS SOLVED +C CORRECTLY FOR CHARACTERS NEAR (BUT NOT INSIDE) +C THE THREE-SPACE OBJECT. +C +C ENTRY POINTS PWRZT, INITZT, PWRZOT, PWRZGT +C +C COMMON BLOCKS PWRZ1T,PWRZ2T +C +C I/O PLOTS CHARACTER(S) +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY THREED, THE ERPRT77 PACKAGE, AND THE SPPS +C ROUTINES +C +C LANGUAGE FORTRAN +C +C HISTORY IMPLEMENTED FOR USE WITH THREED. +C +C +C +C +C*********************************************************************** +C + SAVE + CHARACTER*(*) ID + CHARACTER*1 JCHAR(46) ,KCHAR + DIMENSION INDEX(46) ,KX(494) ,KY(494) + LOGICAL LENTRY +C +C THE FOLLOWING DATA STATEMENTS ASSOCIATE EACH CHARACTER WITH ITS +C DIGITIZATION. THAT IS, THE DIGITIZATION FOR THE CHARACTER A STARTS +C AT KX(1) AND KY(1), WHILE B STARTS AT KX(13) AND KY(13), AND SO ON. +C + DATA JCHAR( 1),INDEX( 1)/'A', 1/ + DATA JCHAR( 2),INDEX( 2)/'B', 13/ + DATA JCHAR( 3),INDEX( 3)/'C', 28/ + DATA JCHAR( 4),INDEX( 4)/'D', 40/ + DATA JCHAR( 5),INDEX( 5)/'E', 49/ + DATA JCHAR( 6),INDEX( 6)/'F', 60/ + DATA JCHAR( 7),INDEX( 7)/'G', 68/ + DATA JCHAR( 8),INDEX( 8)/'H', 82/ + DATA JCHAR( 9),INDEX( 9)/'I', 92/ + DATA JCHAR(10),INDEX(10)/'J',104/ + DATA JCHAR(11),INDEX(11)/'K',113/ + DATA JCHAR(12),INDEX(12)/'L',123/ + DATA JCHAR(13),INDEX(13)/'M',130/ + DATA JCHAR(14),INDEX(14)/'N',137/ + DATA JCHAR(15),INDEX(15)/'O',143/ + DATA JCHAR(16),INDEX(16)/'P',157/ + DATA JCHAR(17),INDEX(17)/'Q',166/ + DATA JCHAR(18),INDEX(18)/'R',182/ + DATA JCHAR(19),INDEX(19)/'S',194/ + DATA JCHAR(20),INDEX(20)/'T',210/ + DATA JCHAR(21),INDEX(21)/'U',219/ + DATA JCHAR(22),INDEX(22)/'V',229/ + DATA JCHAR(23),INDEX(23)/'W',236/ + DATA JCHAR(24),INDEX(24)/'X',245/ + DATA JCHAR(25),INDEX(25)/'Y',252/ + DATA JCHAR(26),INDEX(26)/'Z',262/ + DATA JCHAR(27),INDEX(27)/'0',273/ + DATA JCHAR(28),INDEX(28)/'1',286/ + DATA JCHAR(29),INDEX(29)/'2',296/ + DATA JCHAR(30),INDEX(30)/'3',308/ + DATA JCHAR(31),INDEX(31)/'4',326/ + DATA JCHAR(32),INDEX(32)/'5',339/ + DATA JCHAR(33),INDEX(33)/'6',352/ + DATA JCHAR(34),INDEX(34)/'7',368/ + DATA JCHAR(35),INDEX(35)/'8',378/ + DATA JCHAR(36),INDEX(36)/'9',398/ + DATA JCHAR(37),INDEX(37)/'+',414/ + DATA JCHAR(38),INDEX(38)/'-',423/ + DATA JCHAR(39),INDEX(39)/'*',429/ + DATA JCHAR(40),INDEX(40)/'/',444/ + DATA JCHAR(41),INDEX(41)/'(',448/ + DATA JCHAR(42),INDEX(42)/')',456/ + DATA JCHAR(43),INDEX(43)/'=',464/ + DATA JCHAR(44),INDEX(44)/' ',473/ + DATA JCHAR(45),INDEX(45)/',',476/ + DATA JCHAR(46),INDEX(46)/'.',486/ +C +C THE FOLLOWING DATA STATEMENTS CONTAIN THE DIGITIZATIONS OF THE +C CHARACTERS. THE CHARACTERS ARE DIGITIZED ON A BOX 6 UNITS WIDE AND +C 7 UNITS TALL. THIS INCLUDES 2 UNITS OF WHITE SPACE TO THE RIGHT OF +C EACH CHARACTER. IF KX=7, KY IS A FLAG -- KY=0 MEANS THE FOLLOWING +C KX AND KY ARE A PEN UP MOVE (ALL OTHERS ARE PEN DOWN MOVES), AND +C KY=7 MEANS THAT THE END OF THE DIGITIZATION FOR A PARTICULAR CHARAC- +C TER HAS BEEN REACHED. +C +c None of the following are used anywhere. +c DATA WIDE,HIGH,WHITE/6.,7.,2./ +C + DATA KX( 1),KX( 2),KX( 3),KX( 4),KX( 5),KX( 6)/0,4,7,0,0,1/ + DATA KY( 1),KY( 2),KY( 3),KY( 4),KY( 5),KY( 6)/3,3,0,3,6,7/ + DATA KX( 7),KX( 8),KX( 9),KX( 10),KX( 11),KX( 12)/3,4,4,7,6,7/ + DATA KY( 7),KY( 8),KY( 9),KY( 10),KY( 11),KY( 12)/7,6,0,0,0,7/ + DATA KX( 13),KX( 14),KX( 15),KX( 16),KX( 17),KX( 18)/0,3,4,4,3,0/ + DATA KY( 13),KY( 14),KY( 15),KY( 16),KY( 17),KY( 18)/7,7,6,5,4,4/ + DATA KX( 19),KX( 20),KX( 21),KX( 22),KX( 23),KX( 24)/7,3,4,4,3,0/ + DATA KY( 19),KY( 20),KY( 21),KY( 22),KY( 23),KY( 24)/0,4,3,1,0,0/ + DATA KX( 25),KX( 26),KX( 27),KX( 28),KX( 29),KX( 30)/7,6,7,7,4,3/ + DATA KY( 25),KY( 26),KY( 27),KY( 28),KY( 29),KY( 30)/0,0,7,0,6,7/ + DATA KX( 31),KX( 32),KX( 33),KX( 34),KX( 35),KX( 36)/1,0,0,1,3,4/ + DATA KY( 31),KY( 32),KY( 33),KY( 34),KY( 35),KY( 36)/7,6,1,0,0,1/ + DATA KX( 37),KX( 38),KX( 39),KX( 40),KX( 41),KX( 42)/7,6,7,0,3,4/ + DATA KY( 37),KY( 38),KY( 39),KY( 40),KY( 41),KY( 42)/0,0,7,7,7,6/ + DATA KX( 43),KX( 44),KX( 45),KX( 46),KX( 47),KX( 48)/4,3,0,7,6,7/ + DATA KY( 43),KY( 44),KY( 45),KY( 46),KY( 47),KY( 48)/1,0,0,0,0,7/ + DATA KX( 49),KX( 50),KX( 51),KX( 52),KX( 53),KX( 54)/0,4,7,3,0,7/ + DATA KY( 49),KY( 50),KY( 51),KY( 52),KY( 53),KY( 54)/7,7,0,4,4,0/ + DATA KX( 55),KX( 56),KX( 57),KX( 58),KX( 59),KX( 60)/0,4,7,6,7,0/ + DATA KY( 55),KY( 56),KY( 57),KY( 58),KY( 59),KY( 60)/0,0,0,0,7,7/ + DATA KX( 61),KX( 62),KX( 63),KX( 64),KX( 65),KX( 66)/4,7,0,3,7,6/ + DATA KY( 61),KY( 62),KY( 63),KY( 64),KY( 65),KY( 66)/7,0,4,4,0,0/ + DATA KX( 67),KX( 68),KX( 69),KX( 70),KX( 71),KX( 72)/7,7,4,3,1,0/ + DATA KY( 67),KY( 68),KY( 69),KY( 70),KY( 71),KY( 72)/7,0,6,7,7,6/ + DATA KX( 73),KX( 74),KX( 75),KX( 76),KX( 77),KX( 78)/0,1,3,4,4,3/ + DATA KY( 73),KY( 74),KY( 75),KY( 76),KY( 77),KY( 78)/1,0,0,1,3,3/ + DATA KX( 79),KX( 80),KX( 81),KX( 82),KX( 83),KX( 84)/7,6,7,0,7,0/ + DATA KY( 79),KY( 80),KY( 81),KY( 82),KY( 83),KY( 84)/0,0,7,7,0,4/ + DATA KX( 85),KX( 86),KX( 87),KX( 88),KX( 89),KX( 90)/4,7,4,4,7,6/ + DATA KY( 85),KY( 86),KY( 87),KY( 88),KY( 89),KY( 90)/4,0,7,0,0,0/ + DATA KX( 91),KX( 92),KX( 93),KX( 94),KX( 95),KX( 96)/7,7,1,3,7,2/ + DATA KY( 91),KY( 92),KY( 93),KY( 94),KY( 95),KY( 96)/7,0,7,7,0,7/ + DATA KX( 97),KX( 98),KX( 99),KX(100),KX(101),KX(102)/2,7,1,3,7,6/ + DATA KY( 97),KY( 98),KY( 99),KY(100),KY(101),KY(102)/0,0,0,0,0,0/ + DATA KX(103),KX(104),KX(105),KX(106),KX(107),KX(108)/7,7,0,1,3,4/ + DATA KY(103),KY(104),KY(105),KY(106),KY(107),KY(108)/7,0,1,0,0,1/ + DATA KX(109),KX(110),KX(111),KX(112),KX(113),KX(114)/4,7,6,7,0,7/ + DATA KY(109),KY(110),KY(111),KY(112),KY(113),KY(114)/7,0,0,7,7,0/ + DATA KX(115),KX(116),KX(117),KX(118),KX(119),KX(120)/0,4,7,2,4,7/ + DATA KY(115),KY(116),KY(117),KY(118),KY(119),KY(120)/3,7,0,5,0,0/ + DATA KX(121),KX(122),KX(123),KX(124),KX(125),KX(126)/6,7,7,0,0,4/ + DATA KY(121),KY(122),KY(123),KY(124),KY(125),KY(126)/0,7,0,7,0,0/ + DATA KX(127),KX(128),KX(129),KX(130),KX(131),KX(132)/7,6,7,0,2,4/ + DATA KY(127),KY(128),KY(129),KY(130),KY(131),KY(132)/0,0,7,7,3,7/ + DATA KX(133),KX(134),KX(135),KX(136),KX(137),KX(138)/4,7,6,7,0,4/ + DATA KY(133),KY(134),KY(135),KY(136),KY(137),KY(138)/0,0,0,7,7,0/ + DATA KX(139),KX(140),KX(141),KX(142),KX(143),KX(144)/4,7,6,7,4,7/ + DATA KY(139),KY(140),KY(141),KY(142),KY(143),KY(144)/7,0,0,7,7,0/ + DATA KX(145),KX(146),KX(147),KX(148),KX(149),KX(150)/4,4,3,1,0,0/ + DATA KY(145),KY(146),KY(147),KY(148),KY(149),KY(150)/1,6,7,7,6,1/ + DATA KX(151),KX(152),KX(153),KX(154),KX(155),KX(156)/1,3,4,7,6,7/ + DATA KY(151),KY(152),KY(153),KY(154),KY(155),KY(156)/0,0,1,0,0,7/ + DATA KX(157),KX(158),KX(159),KX(160),KX(161),KX(162)/0,3,4,4,3,0/ + DATA KY(157),KY(158),KY(159),KY(160),KY(161),KY(162)/7,7,6,5,4,4/ + DATA KX(163),KX(164),KX(165),KX(166),KX(167),KX(168)/7,6,7,7,0,0/ + DATA KY(163),KY(164),KY(165),KY(166),KY(167),KY(168)/0,0,7,0,1,6/ + DATA KX(169),KX(170),KX(171),KX(172),KX(173),KX(174)/1,3,4,4,3,1/ + DATA KY(169),KY(170),KY(171),KY(172),KY(173),KY(174)/7,7,6,1,0,0/ + DATA KX(175),KX(176),KX(177),KX(178),KX(179),KX(180)/0,7,2,4,7,6/ + DATA KY(175),KY(176),KY(177),KY(178),KY(179),KY(180)/1,0,2,0,0,0/ + DATA KX(181),KX(182),KX(183),KX(184),KX(185),KX(186)/7,0,3,4,4,3/ + DATA KY(181),KY(182),KY(183),KY(184),KY(185),KY(186)/7,7,7,6,5,4/ + DATA KX(187),KX(188),KX(189),KX(190),KX(191),KX(192)/0,7,2,4,7,6/ + DATA KY(187),KY(188),KY(189),KY(190),KY(191),KY(192)/4,0,4,0,0,0/ + DATA KX(193),KX(194),KX(195),KX(196),KX(197),KX(198)/7,7,0,1,3,4/ + DATA KY(193),KY(194),KY(195),KY(196),KY(197),KY(198)/7,0,1,0,0,1/ + DATA KX(199),KX(200),KX(201),KX(202),KX(203),KX(204)/4,3,1,0,0,1/ + DATA KY(199),KY(200),KY(201),KY(202),KY(203),KY(204)/3,4,4,5,6,7/ + DATA KX(205),KX(206),KX(207),KX(208),KX(209),KX(210)/3,4,7,6,7,7/ + DATA KY(205),KY(206),KY(207),KY(208),KY(209),KY(210)/7,6,0,0,7,0/ + DATA KX(211),KX(212),KX(213),KX(214),KX(215),KX(216)/0,4,7,2,2,7/ + DATA KY(211),KY(212),KY(213),KY(214),KY(215),KY(216)/7,7,0,7,0,0/ + DATA KX(217),KX(218),KX(219),KX(220),KX(221),KX(222)/6,7,7,0,0,1/ + DATA KY(217),KY(218),KY(219),KY(220),KY(221),KY(222)/0,7,0,7,1,0/ + DATA KX(223),KX(224),KX(225),KX(226),KX(227),KX(228)/3,4,4,7,6,7/ + DATA KY(223),KY(224),KY(225),KY(226),KY(227),KY(228)/0,1,7,0,0,7/ + DATA KX(229),KX(230),KX(231),KX(232),KX(233),KX(234)/7,0,2,4,7,6/ + DATA KY(229),KY(230),KY(231),KY(232),KY(233),KY(234)/0,7,0,7,0,0/ + DATA KX(235),KX(236),KX(237),KX(238),KX(239),KX(240)/7,7,0,0,2,4/ + DATA KY(235),KY(236),KY(237),KY(238),KY(239),KY(240)/7,0,7,0,4,0/ + DATA KX(241),KX(242),KX(243),KX(244),KX(245),KX(246)/4,7,6,7,4,7/ + DATA KY(241),KY(242),KY(243),KY(244),KY(245),KY(246)/7,0,0,7,7,0/ + DATA KX(247),KX(248),KX(249),KX(250),KX(251),KX(252)/0,4,7,6,7,7/ + DATA KY(247),KY(248),KY(249),KY(250),KY(251),KY(252)/7,0,0,0,7,0/ + DATA KX(253),KX(254),KX(255),KX(256),KX(257),KX(258)/0,2,4,7,2,2/ + DATA KY(253),KY(254),KY(255),KY(256),KY(257),KY(258)/7,4,7,0,4,0/ + DATA KX(259),KX(260),KX(261),KX(262),KX(263),KX(264)/7,6,7,7,3,1/ + DATA KY(259),KY(260),KY(261),KY(262),KY(263),KY(264)/0,0,7,0,4,4/ + DATA KX(265),KX(266),KX(267),KX(268),KX(269),KX(270)/7,0,4,0,4,7/ + DATA KY(265),KY(266),KY(267),KY(268),KY(269),KY(270)/0,7,7,0,0,0/ + DATA KX(271),KX(272),KX(273),KX(274),KX(275),KX(276)/6,7,7,4,3,1/ + DATA KY(271),KY(272),KY(273),KY(274),KY(275),KY(276)/0,7,0,1,0,0/ + DATA KX(277),KX(278),KX(279),KX(280),KX(281),KX(282)/0,0,1,3,4,4/ + DATA KY(277),KY(278),KY(279),KY(280),KY(281),KY(282)/1,6,7,7,6,1/ + DATA KX(283),KX(284),KX(285),KX(286),KX(287),KX(288)/7,6,7,7,1,2/ + DATA KY(283),KY(284),KY(285),KY(286),KY(287),KY(288)/0,0,7,0,6,7/ + DATA KX(289),KX(290),KX(291),KX(292),KX(293),KX(294)/2,7,1,3,7,6/ + DATA KY(289),KY(290),KY(291),KY(292),KY(293),KY(294)/0,0,0,0,0,0/ + DATA KX(295),KX(296),KX(297),KX(298),KX(299),KX(300)/7,7,0,1,3,4/ + DATA KY(295),KY(296),KY(297),KY(298),KY(299),KY(300)/7,0,6,7,7,6/ + DATA KX(301),KX(302),KX(303),KX(304),KX(305),KX(306)/4,0,0,4,7,6/ + DATA KY(301),KY(302),KY(303),KY(304),KY(305),KY(306)/5,1,0,0,0,0/ + DATA KX(307),KX(308),KX(309),KX(310),KX(311),KX(312)/7,7,0,1,3,4/ + DATA KY(307),KY(308),KY(309),KY(310),KY(311),KY(312)/7,0,6,7,7,6/ + DATA KX(313),KX(314),KX(315),KX(316),KX(317),KX(318)/4,3,1,7,3,4/ + DATA KY(313),KY(314),KY(315),KY(316),KY(317),KY(318)/5,4,4,0,4,3/ + DATA KX(319),KX(320),KX(321),KX(322),KX(323),KX(324)/4,3,1,0,7,6/ + DATA KY(319),KY(320),KY(321),KY(322),KY(323),KY(324)/1,0,0,1,0,0/ + DATA KX(325),KX(326),KX(327),KX(328),KX(329),KX(330)/7,7,3,3,2,0/ + DATA KY(325),KY(326),KY(327),KY(328),KY(329),KY(330)/7,0,0,7,7,4/ + DATA KX(331),KX(332),KX(333),KX(334),KX(335),KX(336)/0,4,7,2,4,7/ + DATA KY(331),KY(332),KY(333),KY(334),KY(335),KY(336)/3,3,0,0,0,0/ + DATA KX(337),KX(338),KX(339),KX(340),KX(341),KX(342)/6,7,7,0,1,3/ + DATA KY(337),KY(338),KY(339),KY(340),KY(341),KY(342)/0,7,0,1,0,0/ + DATA KX(343),KX(344),KX(345),KX(346),KX(347),KX(348)/4,4,3,0,0,4/ + DATA KY(343),KY(344),KY(345),KY(346),KY(347),KY(348)/1,3,4,4,7,7/ + DATA KX(349),KX(350),KX(351),KX(352),KX(353),KX(354)/7,6,7,7,4,3/ + DATA KY(349),KY(350),KY(351),KY(352),KY(353),KY(354)/0,0,7,0,6,7/ + DATA KX(355),KX(356),KX(357),KX(358),KX(359),KX(360)/1,0,0,1,3,4/ + DATA KY(355),KY(356),KY(357),KY(358),KY(359),KY(360)/7,6,1,0,0,1/ + DATA KX(361),KX(362),KX(363),KX(364),KX(365),KX(366)/4,3,1,0,7,6/ + DATA KY(361),KY(362),KY(363),KY(364),KY(365),KY(366)/3,4,4,3,0,0/ + DATA KX(367),KX(368),KX(369),KX(370),KX(371),KX(372)/7,7,0,0,4,4/ + DATA KY(367),KY(368),KY(369),KY(370),KY(371),KY(372)/7,0,6,7,7,6/ + DATA KX(373),KX(374),KX(375),KX(376),KX(377),KX(378)/2,2,7,6,7,7/ + DATA KY(373),KY(374),KY(375),KY(376),KY(377),KY(378)/1,0,0,0,7,0/ + DATA KX(379),KX(380),KX(381),KX(382),KX(383),KX(384)/1,0,0,1,3,4/ + DATA KY(379),KY(380),KY(381),KY(382),KY(383),KY(384)/4,5,6,7,7,6/ + DATA KX(385),KX(386),KX(387),KX(388),KX(389),KX(390)/4,3,1,0,0,1/ + DATA KY(385),KY(386),KY(387),KY(388),KY(389),KY(390)/5,4,4,3,1,0/ + DATA KX(391),KX(392),KX(393),KX(394),KX(395),KX(396)/3,4,4,3,7,6/ + DATA KY(391),KY(392),KY(393),KY(394),KY(395),KY(396)/0,1,3,4,0,0/ + DATA KX(397),KX(398),KX(399),KX(400),KX(401),KX(402)/7,7,0,1,3,4/ + DATA KY(397),KY(398),KY(399),KY(400),KY(401),KY(402)/7,0,1,0,0,1/ + DATA KX(403),KX(404),KX(405),KX(406),KX(407),KX(408)/4,3,1,0,0,1/ + DATA KY(403),KY(404),KY(405),KY(406),KY(407),KY(408)/6,7,7,6,4,3/ + DATA KX(409),KX(410),KX(411),KX(412),KX(413),KX(414)/3,4,7,6,7,7/ + DATA KY(409),KY(410),KY(411),KY(412),KY(413),KY(414)/3,4,0,0,7,0/ + DATA KX(415),KX(416),KX(417),KX(418),KX(419),KX(420)/0,4,7,2,2,7/ + DATA KY(415),KY(416),KY(417),KY(418),KY(419),KY(420)/3,3,0,5,1,0/ + DATA KX(421),KX(422),KX(423),KX(424),KX(425),KX(426)/6,7,7,0,4,7/ + DATA KY(421),KY(422),KY(423),KY(424),KY(425),KY(426)/0,7,0,3,3,0/ + DATA KX(427),KX(428),KX(429),KX(430),KX(431),KX(432)/6,7,7,0,4,7/ + DATA KY(427),KY(428),KY(429),KY(430),KY(431),KY(432)/0,7,0,1,5,0/ + DATA KX(433),KX(434),KX(435),KX(436),KX(437),KX(438)/2,2,7,4,0,7/ + DATA KY(433),KY(434),KY(435),KY(436),KY(437),KY(438)/5,1,0,3,3,0/ + DATA KX(439),KX(440),KX(441),KX(442),KX(443),KX(444)/0,4,7,6,7,4/ + DATA KY(439),KY(440),KY(441),KY(442),KY(443),KY(444)/5,1,0,0,7,7/ + DATA KX(445),KX(446),KX(447),KX(448),KX(449),KX(450)/7,6,7,7,3,2/ + DATA KY(445),KY(446),KY(447),KY(448),KY(449),KY(450)/0,0,7,1,7,6/ + DATA KX(451),KX(452),KX(453),KX(454),KX(455),KX(456)/2,3,7,6,7,7/ + DATA KY(451),KY(452),KY(453),KY(454),KY(455),KY(456)/1,0,0,0,7,0/ + DATA KX(457),KX(458),KX(459),KX(460),KX(461),KX(462)/1,2,2,1,7,6/ + DATA KY(457),KY(458),KY(459),KY(460),KY(461),KY(462)/7,6,1,0,0,0/ + DATA KX(463),KX(464),KX(465),KX(466),KX(467),KX(468)/7,7,4,0,7,0/ + DATA KY(463),KY(464),KY(465),KY(466),KY(467),KY(468)/7,0,5,5,0,2/ + DATA KX(469),KX(470),KX(471),KX(472),KX(473),KX(474)/4,7,6,7,7,6/ + DATA KY(469),KY(470),KY(471),KY(472),KY(473),KY(474)/2,0,0,7,0,0/ + DATA KX(475),KX(476),KX(477),KX(478),KX(479),KX(480)/7,7,1,2,2,1/ + DATA KY(475),KY(476),KY(477),KY(478),KY(479),KY(480)/7,0,0,1,2,2/ + DATA KX(481),KX(482),KX(483),KX(484),KX(485),KX(486)/1,2,7,6,7,7/ + DATA KY(481),KY(482),KY(483),KY(484),KY(485),KY(486)/1,1,0,0,7,0/ + DATA KX(487),KX(488),KX(489),KX(490),KX(491),KX(492)/2,1,1,2,2,7/ + DATA KY(487),KY(488),KY(489),KY(490),KY(491),KY(492)/0,0,1,1,0,0/ + DATA KX(493),KX(494) /6,7 / + DATA KY(493),KY(494) /0,7 / +C +C NSIZE IS THE LENGTH OF JCHAR AND INDEX. +C LNGTH IS THE LENGTH OF KX AND KY. +C LENTRY TELLS IF THIS IS THE FIRTST CALL TO PWRZT. +C + DATA NSIZE/46/ +c Variable LNGTH not used. +c DATA LNGTH/494/ + DATA LENTRY/.FALSE./ + DATA ITHETA/0/ + DATA IDUM1,IDUM2,IDUM3/1,1,1/ +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','PWRZT','PWRZT','VERSION 1') +C +C SEE IF THIS IS THE FIRST CALL TO PWRZT +C + IF (LENTRY) GO TO 103 +C +C MARK THAT FUTURE CALLS NEED NOT DO THIS CODE. +C + LENTRY = .TRUE. +C +C RECORD THE LOCATION OF THE BLANK SO IT CAN BE USED FOR UNKNOWN +C CHARACTERS. +C + IBLKPT = INDEX(44) +C +C CHANGE EACH CHARACTER IN THE TABLE TO RIGHT JUSTIFIED, ZERO FILLED. +C +C +C SORT JCHAR MAINTAINING THE RELATIONSHIP BETWEEN JCHAR AND INDEX. +C (THAT IS, IF JCHAR(I)='B', THEN INDEX(I)=13 FROM THE ABOVE DATA STMT.) +C THIS WILL ENABLE CHARACTERS TO BE QUICKLY FOUND IN ALL SUBSEQUENT +C CALLS TO PWRZT. +C + CALL PWRZOT (JCHAR,INDEX,NSIZE) +C +C ALL ONE-TIME INITIALIZATION NOW FINISHED. +C + 103 CONTINUE +C + NN = N + IF (NN .LE. 0) RETURN + FNNM1 = NN-1 + JCNT = ICNT +C +C PUT RELATIVE SIZE IN Q, ADJUST FOR CURRENT PLOTTER RESOLUTION +C + CALL GETUSV ('XF',LX) + SCALE = 2.**(LX-10) + IF (ISIZE .EQ. 0) Q = 1.3334*SCALE + IF (ISIZE .EQ. 1) Q = 2.*SCALE + IF (ISIZE .EQ. 2) Q = 2.6667*SCALE + IF (ISIZE .EQ. 3) Q = 4.*SCALE + IF (ISIZE .GT. 3) Q = FLOAT(ISIZE)/(6.) +C +C PUT ANGLE IN RADIANS IN T. +C + T = FLOAT(ITHETA)*1.5708 + 104 CONTINUE +C +C CALCULATE COMBINED TRANSFORMATION +C + CT = Q*COS(T) + ST = Q*SIN(T) +C +C FIND CRT COORDINATES OF CENTER. +C + LINEI = LIN3 + CALL INTZT (X,Y,Z,LINEI,ITOP) + IF (LINEI .EQ. 0) RETURN + IX = 0 + IY = 0 + XC = IX + YC = IY +C +C CORRECT FOR CHARACTER DATA BEING LOWER-LEFT-HAND POSITIONED. +C + XC = XC-2.*CT+3.5*ST + YC = YC-2.*ST-3.5*CT +C +C CORRECT FOR CENTERING IF TURNED ON. +C + JCNT = MAX0(-1,MIN0(1,JCNT))+2 + GO TO (108,107,109),JCNT + 107 XC = XC-CT*FNNM1*3. + YC = YC-ST*FNNM1*3. + GO TO 110 + 108 XC = XC+CT*2. + YC = YC+ST*2. + GO TO 110 + 109 XC = XC-CT*2. + YC = YC-ST*2. + XC = XC-CT*FNNM1*6. + YC = YC-ST*FNNM1*6. + 110 CALL INITZT (IFIX(XC),IFIX(YC),1,IDUM1,IDUM2,2) + CALL INITZT (IFIX(XC+CT*6.*FNNM1),IFIX(YC+ST*6.*FNNM1),2,IDUM1, + + IDUM2,2) + CALL INITZT (IFIX(XC),IFIX(YC),IDUM1,IDUM2,IDUM3,3) + DO 114 K=1,NN + XB = XC + YB = YC + IP = 1 +C +C EXTRACT CHARACTER NUMBER K FROM THE STRING. +C + KCHAR = ID(K:K) +C +C FIND THE TABLE ENTRY. +C + CALL PWRZGT (KCHAR,JCHAR,INDEX,NSIZE,IPOINT) + IF (IPOINT .EQ. -1) IPOINT = IBLKPT +C +C ALWAYS LESS THAN 20 INSTRUCTIONS. +C + DO 113 L=1,20 + ISUB = IPOINT+L-1 + NX = KX(ISUB) + FNX = NX + NY = KY(ISUB) + FNY = NY +C +C TEST FOR OP-CODE OR DX AND DY. +C + IF (NX .NE. 7) GO TO 111 +C +C OP-CODE +C + IP = 0 + IF (NY-7) 113,114,113 +C +C DX AND DY +C + 111 XC = XB+FNX*CT-FNY*ST + YC = YB+FNX*ST+FNY*CT +C +C CALL DESIRED PLOTTING ROUTINE. DETERMINED BY OP-CODES. +C + IF (IP .NE. 0) GO TO 112 + CALL INITZT (IFIX(XC+.5),IFIX(YC+.5),IDUM1,IDUM2,IDUM3,3) + IP = 1 + GO TO 113 + 112 CALL INITZT (IFIX(XC+.5),IFIX(YC+.5),IDUM1,IDUM2,IDUM3,4) + 113 CONTINUE + 114 CONTINUE +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(0,0,0) + RETURN + END + SUBROUTINE INTZT (XX,YY,ZZ,LIN3,ITOP) +C +C FORCE STORAGE OF X, Y, AND Z INTO COMMON BLOCK +C + COMMON /PWRZ2T/ X, Y, Z + DATA IDUMX,IDUMY,IDUMZ /0, 0, 0/ + X = XX + Y = YY + Z = ZZ + CALL INITZT (IDUMX,IDUMY,IDUMZ,LIN3,ITOP,1) + RETURN + END + SUBROUTINE INITZT (IX,IY,IZ,LIN3,ITOP,IENT) +C + SAVE + COMMON /PWRZ1T/ XXMIN ,XXMAX ,YYMIN ,YYMAX , + + ZZMIN ,ZZMAX ,DELCRT ,EYEX , + + EYEY ,EYEZ +C + COMMON /PWRZ2T/ X ,Y ,Z + FX(R) = R+FACTX*FLOAT(IX) + FY(R) = R+FACTY*FLOAT(IY) +C +C +C DETERMINE INITZT,VISSET,FRSTZ OR VECTZ CALL +C + GO TO (1000,2000,3000,4000),IENT + 1000 LIN = MAX0(1,MIN0(3,IABS(LIN3))) + ITO = MAX0(1,MIN0(3,IABS(ITOP))) +C +C SET UP SCALING CONSTANTS +C + DELMAX = AMAX1(XXMAX-XXMIN,YYMAX-YYMIN,ZZMAX-ZZMIN) + FACTOR = DELMAX/DELCRT + FACTX = SIGN(FACTOR,FLOAT(LIN3)) + FACTY = SIGN(FACTOR,FLOAT(ITOP)) +C +C SET UP FOR PROPER PLANE +C + JUMP1 = LIN+(ITO-1)*3 + GO TO (108,101,102,103,108,104,105,106,108),JUMP1 + 101 ASSIGN 111 TO JUMP + GO TO 107 + 102 ASSIGN 112 TO JUMP + GO TO 107 + 103 ASSIGN 113 TO JUMP + GO TO 107 + 104 ASSIGN 114 TO JUMP + GO TO 107 + 105 ASSIGN 115 TO JUMP + GO TO 107 + 106 ASSIGN 116 TO JUMP + 107 RETURN + 108 CALL SETER ('INITZT - LINE OR ITOP IMPROPER IN PWRZT CALL' ,1,1) + LIN3 = 0 + RETURN +C +C **************************** ENTRY VISSET **************************** +C ENTRY VISSET (IX,IY,IZ) +C +C +C VISSET IS CALLED ONCE FOR EACH END OF THE CHARACTER STRING +C + 2000 IVIS = -1 + ITEMP = 0 + GO TO 110 +C +C SEE IF THIS END COULD BE BEHIND THE OBJECT +C + 109 IF (EYEX.GT.XXMAX .AND. XX.GT.XXMAX) ITEMP = ITEMP+1 + IF (EYEY.GT.YYMAX .AND. YY.GT.YYMAX) ITEMP = ITEMP+1 + IF (EYEZ.GT.ZZMAX .AND. ZZ.GT.ZZMAX) ITEMP = ITEMP+1 + IF (EYEX.LT.XXMIN .AND. XX.LT.XXMIN) ITEMP = ITEMP+1 + IF (EYEY.LT.YYMIN .AND. YY.LT.YYMIN) ITEMP = ITEMP+1 + IF (EYEZ.LT.ZZMIN .AND. ZZ.LT.ZZMIN) ITEMP = ITEMP+1 + IF (IZ .EQ. 1) IVISS = ITEMP +C +C IF EITHER END CHARACTER COULD BE HIDDEN, TEST ALL LINE SEGMENTS. +C + IF (IZ .EQ. 2) IVIS = MIN0(IVISS,ITEMP) + RETURN +C +C **************************** ENTRY FRSTZ ***************************** +C ENTRY FRSTZ (IX,IY) +C + 3000 IFRST = 1 + GO TO 110 +C +C **************************** ENTRY VECTZ ***************************** +C ENTRY VECTZ (IX,IY) +C + 4000 IFRST = 0 +C +C PICK CORRECT 3-SPACE PLANE TO DRAW IN +C + 110 GO TO JUMP,(111,112,113,114,115,116) + 111 XX = FY(X) + YY = FX(Y) + ZZ = Z + GO TO 117 + 112 XX = FY(X) + YY = Y + ZZ = FX(Z) + GO TO 117 + 113 XX = FX(X) + YY = FY(Y) + ZZ = Z + GO TO 117 + 114 XX = X + YY = FY(Y) + ZZ = FX(Z) + GO TO 117 + 115 XX = FX(X) + YY = Y + ZZ = FY(Z) + GO TO 117 + 116 XX = X + YY = FX(Y) + ZZ = FY(Z) +C +C TRANSLATE TO 2-SPACE +C + 117 CALL TRN32T (XX,YY,ZZ,XT,YT,DUMMY,2) + IF (IVIS) 109,121,118 + 118 IF (IFRST) 119,120,119 +C +C IF IN FRONT, DRAW IN ANY CASE. +C + 119 CALL PLOTIT (32*IFIX(XT),32*IFIX(YT),0) + RETURN + 120 CALL PLOTIT (32*IFIX(XT),32*IFIX(YT),1) + RETURN + 121 IF (IFRST) 122,123,122 + 122 IX1 = XT + IY1 = YT + RETURN + 123 IX2 = XT + IY2 = YT +C +C IF COULD BE HIDDEN, USE HIDDEN LINE PLOTTING ENTRY IN THREED +C + CALL DRAWT (IX1,IY1,IX2,IY2) + IX1 = IX2 + IY1 = IY2 + RETURN + END + SUBROUTINE PWRZOT (JCHAR,INDEX,NSIZE) +C +C THIS ROUTINE SORTS JCHAR WHICH IS NSIZE IN LENGTH. THE RELATIONSHIP +C BETWEEN JCHAR AND INDEX IS MAINTAINED. A BUBBLE SORT IS USED. +C JCHAR IS SORTED IN ASCENDING ORDER. +C + SAVE + CHARACTER*1 JCHAR(NSIZE) ,JTEMP ,KTEMP + DIMENSION INDEX(NSIZE) + LOGICAL LDONE +C + ISTART = 1 + ISTOP = NSIZE + ISTEP = 1 +C +C AT MOST NSIZE PASSES ARE NEEDED. +C + DO 104 NPASS=1,NSIZE + LDONE = .TRUE. + I = ISTART + 101 ISUB = I+ISTEP + IF (ISTEP*(ICHAR(JCHAR(I))-ICHAR(JCHAR(ISUB)))) 103,103,102 +C +C THEY NEED TO BE SWITCHED. +C + 102 LDONE = .FALSE. + JTEMP = JCHAR(I) + KTEMP = JCHAR(ISUB) + JCHAR(I) = KTEMP + JCHAR(ISUB) = JTEMP + ITEMP = INDEX(I) + INDEX(I) = INDEX(ISUB) + INDEX(ISUB) = ITEMP +C +C THEY DO NOT NEED TO BE SWITCHED. +C + 103 I = I+ISTEP + IF (I .NE. ISTOP) GO TO 101 +C +C IF NONE WERE SWITCHED DURING THIS PASS, WE CAN QUIT. +C + IF (LDONE) RETURN +C +C SET UP FOR THE NEXT PASS IN THE OTHER DIRECTION. +C + ISTEP = -ISTEP + ITEMP = ISTART + ISTART = ISTOP+ISTEP + ISTOP = ITEMP + 104 CONTINUE + RETURN + END + SUBROUTINE PWRZGT (KCHAR,JCHAR,INDEX,NSIZE,IPOINT) +C +C THIS ROUTINE FINDS WHERE KCHAR IS IN JCHAR AND RETURNS THE CORRES- +C PONDING INDEX IN IPOINT. BINARY HALVING IS USED. +C + SAVE + CHARACTER*1 JCHAR(NSIZE) ,KCHAR + DIMENSION INDEX(NSIZE) +C +C IT IS ASSUMED THAT JCHAR IS LESS THAT 2**9 IN LENGTH, SO IF KCHAR IS +C NOT FOUND IN 10 STEPS, THE SEARCH IS STOPPED. +C + KOUNT = 0 + IBOT = 1 + ITOP = NSIZE + I = ITOP + GO TO 102 + 101 I = (IBOT+ITOP)/2 + KOUNT = KOUNT+1 + IF (KOUNT .GT. 10) GO TO 106 + 102 IF (ICHAR(JCHAR(I))-ICHAR(KCHAR)) 103,105,104 + 103 IBOT = I + GO TO 101 + 104 ITOP = I + GO TO 101 + 105 IPOINT = INDEX(I) + RETURN +C +C IPOINT=-1 MEANS THAT KCHAR WAS NOT IN THE TABLE. +C + 106 IPOINT = -1 + RETURN +C +C +C +C REVISION HISTORY---------- +C +C MARCH 1980 FIRST ADDED TO ULIB AS A SEPARATE FILE TO BE +C USED IN CONJUNCTION WITH THE ULIB ROUTINE +C THREED +C +C JULY 1984 CONVERTED TO GKS AND FORTRAN 77 +C------------------------------------------------------------------ + END diff --git a/sys/gio/ncarutil/srfabd.f b/sys/gio/ncarutil/srfabd.f new file mode 100644 index 00000000..25712c27 --- /dev/null +++ b/sys/gio/ncarutil/srfabd.f @@ -0,0 +1,89 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +c +noao: here is the changed block data +c BLOCKDATA SRFABD + subroutine srfabd +c + integer first, temp + COMMON /SRFBLK/ LIMU(1024) ,LIML(1024) ,CL(41) ,NCL, + 1 LL ,FACT ,IROT ,NDRZ, + 2 NUPPER ,NRSWT ,BIGD ,UMIN, + 3 UMAX ,VMIN ,VMAX ,RZERO, + 4 IOFFP ,NSPVAL ,SPVAL ,BIGEST + COMMON /SRFIP1/ IFR ,ISTP ,IROTS ,IDRX, + 1 IDRY ,IDRZ ,IUPPER ,ISKIRT, + 2 NCLA ,THETA ,HSKIRT ,CHI, + 3 CLO ,CINC ,ISPVAL + COMMON /SRFINT/ ISRFMJ ,ISRFMN ,ISRFTX +c +noao: common block added 4NOV85 to allow user control of viewport. + common /noaovp/ vpx1, vpx2, vpy1, vpy2 +c-noao +C +c +noao: following flag added to prevent initialization more than once + common /frstfg/ first + SAVE + data temp /1/ + first = temp + if (first .ne. 1) then + return + endif + temp = 0 +c +C +noao: by default, the full device viewport is used + vpx1 = 0.0 + vpx2 = 1.0 + vpy1 = 0.0 + vpy2 = 1.0 +c -noao +C INITIALIZATION OF INTERNAL PARAMETERS +C +c DATA ISPVAL/-999/ + ISPVAL = -999 + +c DATA IFR,ISTP,IROTS,IDRX,IDRY,IDRZ,IUPPER,ISKIRT,NCLA/ +c 1 1, 0, 0, 1, 1, 0, 0, 0, 6/ +c +noao: initial value of ifr changed to 0 to suppress frame advance. This +c function should be performed by the calling procedure. +c -noao + IFR = 0 + ISTP = 0 + IROTS = 0 + IDRX = 1 + IDRY = 1 + IDRZ = 0 + IUPPER = 0 + ISKIRT = 0 + NCLA = 6 + +c DATA THETA,HSKIRT,CHI,CLO,CINC/ +c 1 .02, 0., 0., 0., 0./ + THETA =.02 + HSKIRT = 0. + CHI = 0. + CLO = 0. + CINC = 0. + +c DATA NRSWT/0/ + NRSWT = 0 + +c DATA IOFFP,SPVAL/0,0.0/ + IOFFP = 0 + SPVAL = 0.0 + +C LINE COLOR INDEX +c DATA ISRFMJ/1/ + ISRFMJ = 1 +C +c -noao + END diff --git a/sys/gio/ncarutil/srface.f b/sys/gio/ncarutil/srface.f new file mode 100644 index 00000000..8a5981db --- /dev/null +++ b/sys/gio/ncarutil/srface.f @@ -0,0 +1,1347 @@ + SUBROUTINE SRFACE (X,Y,Z,M,MX,NX,NY,S,STEREO) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C DIMENSION OF X(NX),Y(NY),Z(MX,NY),M(2,NX,NY),S(6) +C ARGUMENTS +C +C LATEST REVISION MARCH 1984 +C +C PURPOSE SRFACE DRAWS A PERSPECTIVE PICTURE OF A +C FUNCTION OF TWO VARIABLES WITH HIDDEN LINES +C REMOVED. THE FUNCTION IS APPROXIMATED BY A +C TWO-DIMENSIONAL ARRAY OF HEIGHTS. +C +C USAGE IF THE FOLLOWING ASSUMPTIONS ARE MET, USE +C CALL EZSRFC (Z,M,N,ANGH,ANGV,WORK) +C +C ASSUMPTIONS: +C .THE ENTIRE ARRAY IS TO BE DRAWN, +C .THE DATA IS EQUALLY SPACED (IN THE +C X-Y PLANE), +C .NO STEREO PAIRS, +C .SCALING IS CHOSEN INTERNALLY. +C +C IF THESE ASSUMPTIONS ARE NOT MET USE +C CALL SRFACE (X,Y,Z,M,MX,NX,NY,S, +C STEREO) +C +C ARGUMENTS +C +C ON INPUT Z +C FOR EZSRFC THE M BY N ARRAY TO BE DRAWN. +C +C M +C THE FIRST DIMENSION OF Z. +C +C N +C THE SECOND DIMENSION OF Z. +C +C ANGH +C ANGLE IN DEGREES IN THE X-Y PLANE TO THE +C LINE OF SIGHT (COUNTER-CLOCK WISE FROM +C THE PLUS-X AXIS). +C +C ANGV +C ANGLE IN DEGREES FROM THE X-Y PLANE TO +C THE LINE OF SIGHT (POSITIVE ANGLES ARE +C ABOVE THE MIDDLE Z, NEGATIVE BELOW). +C +C WORK +C A SCRATCH STORAGE DIMENSIONED AT LEAST +C 2*M*N+M+N. +C +C ON OUTPUT Z, M, N, ANGH, ANGV ARE UNCHANGED. WORK +C FOR EZSRFC HAS BEEN WRITTEN IN. +C +C +C ARGUMENTS +C +C ON INPUT X +C FOR SRFACE A LINEAR ARRAY NX LONG CONTAINING THE X +C COORDINATES OF THE POINTS IN THE SURFACE +C APPROXIMATION. SEE NOTE, BELOW. +C +C Y +C THE LINEAR ARRAY NY LONG CONTAINING THE +C Y COORDINATES OF THE POINTS IN THE +C SURFACE APPROXIMATION. SEE NOTE, BELOW. +C +C Z +C AN ARRAY MX BY NY CONTAINING THE SURFACE +C TO BE DRAWN IN NX BY NY CELLS. +C Z(I,J) = F(X(I),Y(J)). SEE NOTE, BELOW. +C +C M +C SCRATCH ARRAY AT LEAST 2*NX*NY WORDS +C LONG. +C +C MX +C FIRST DIMENSION OF Z. +C +C NX +C NUMBER OF POINTS IN THE X DIRECTION +C IN Z. WHEN PLOTTING AN ENTIRE ARRAY, +C MX=NX. SEE APPENDIX 1 OF THE GRAPHICS +C CHAPTER FOR AN EXPLANATION OF USING THIS +C ARGUMENT LIST TO PROCESS ANY PART OF AN +C ARRAY. +C +C NY +C NUMBER OF POINTS IN THE Y DIRECTION IN Z. +C +C S +C S DEFINES THE LINE OF SIGHT. THE VIEWER'S +C EYE IS AT (S(1), S(2), S(3)) AND THE +C POINT LOOKED AT IS AT (S(4), S(5), S(6)). +C THE EYE SHOULD BE OUTSIDE THE BLOCK WITH +C OPPOSITE CORNERS (X(1), Y(1), ZMIN) AND +C (X(NX), Y(NY), ZMAX) AND THE POINT LOOKED +C AT SHOULD BE INSIDE IT. FOR A NICE +C PERSPECTIVE EFFECT, THE DISTANCE BETWEEN +C THE EYE AND THE POINT LOOKED AT SHOULD BE +C 5 TO 10 TIMES THE SIZE OF THE BLOCK. SEE +C NOTE, BELOW. +C +C STEREO +C FLAG TO INDICATE IF STEREO PAIRS ARE TO +C BE DRAWN. 0.0 MEANS NO STEREO PAIR (ONE +C PICTURE). NON-ZERO MEANS PUT OUT TWO +C PICTURES. THE VALUE OF STEREO IS THE +C RELATIVE ANGLE BETWEEN THE EYES. A VALUE +C OF 1.0 PRODUCES STANDARD SEPARATION. +C NEGATIVE STEREO REVERSES THE LEFT AND +C RIGHT FIGURES. +C +C ON OUTPUT X, Y, Z, MX, NX, NY, S, STEREO ARE +C FOR SRFACE UNCHANGED. M HAS BEEN WRITTEN IN. +C +C NOTES . THE RANGE OF Z COMPARED WITH THE RANGE +C OF X AND Y DETERMINES THE SHAPE OF THE +C PICTURE. THEY ARE ASSUMED TO BE IN THE +C SAME UNITS AND NOT WILDLY DIFFERENT IN +C MAGNITUDE. S IS ASSUMED TO BE IN THE +C SAME UNITS AS X, Y, AND Z. +C . PICTURE SIZE CAN BE MADE RELATIVE TO +C DISTANCE. SEE COMMENTS IN SETR. +C . TRN32S CAN BE USED TO TRANSLATE FROM 3 +C SPACE TO 2 SPACE. SEE COMMENTS THERE. +C . DATA WITH EXTREME DISCONTINUITIES MAY +C CAUSE VISIBILITY ERRORS. IF THIS PROBLEM +C OCCURS, USE A DISTANT EYE POSITION +C AWAY FROM THE +Z AXIS. +C . THE DEFAULT LINE COLOR IS SET TO +C COLOR INDEX 1. IF THE USER WISHES TO +C CHANGE THE LINE COLOR, HE CAN DO SO BY +C DEFINING COLOR INDEX 1 BEFORE CALLING +C SRFACE, OR BY PUTTING THE COMMON BLOCK +C SRFINT IN HIS CALLING PROGRAM AND +C DEFINING AND USING COLOR INDEX ISRFMJ +C (DEFAULTED TO 1 IN BLOCKDATA.) +C +C ENTRY POINTS SRFACE, SRFGK, EZSRFC, SETR, DRAWS, TRN32S, +C CLSET, CTCELL, SRFABD +C +C COMMON BLOCKS PWRZ1S, SRFBLK, SRFINT, SRFIP1 +C +C I/O PLOTS +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C HISTORY CONVERTED TO FORTRAN 77 AND GKS IN MARCH 1984. +C +C PREPARED FOR SIGGRAPH, AUGUST 1976. +C +C STANDARDIZED IN JANUARY 1973. +C +C WRITTEN IN DECEMBER 1971. REPLACED K.S.+G. +C ALGORITHM CALLED SOLIDS AT NCAR. +C +C +C ALGORITHM HIGHEST SO FAR IS VISIBLE FROM ABOVE. (SEE +C REFERENCE.) +C +C REFERENCE WRIGHT, T.J., A TWO SPACE SOLUTION TO THE +C HIDDEN LINE PROBLEM FOR PLOTTING A FUNCTION +C OF TWO VARIABLES. IEEE TRANS. COMP., +C PP 28-33, JANUARY 1973. +C +C ACCURACY IF THE ENDS OF A LINE SEGMENT ARE VISIBLE, +C THE MIDDLE IS ASSUMED VISIBLE. +C +C TIMING PROPORTIONAL TO NX*NY. +C +C +C INTERNAL PARAMETERS NAME DEFAULT FUNCTION +C ---- ------- -------- +C IFR 1 -1 CALL FRAME FIRST. +C 0 DO NOT CALL FRAME. +C +1 CALL FRAME WHEN DONE. +c +NOAO: The value of ifr has been changed from its default of +1 to 0. +c -NOAO +C +C ISTP 0 STEREO TYPE IF STEREO +C NON-ZERO. +C -1 ALTERNATING FRAMES, +C SLIGHTLY OFFSET (FOR +C MOVIES. IROTS = 0). +C 0 BLANK FRAME BETWEEN +C FOR STEREO SLIDE. +C IROTS = 1). +C +1 BOTH ON SAME FRAME. +C (LEFT PICTURE TO LEFT +C SIDE. IROTS = 0). +C +C IROTS 0 0 +Z IN VERTICAL PLOTTING +C DIRECTION (CINE MODE). +C +1 +Z IN HORIZONTAL +C PLOTTING DIRECTION +C (COMIC MODE). +C +C IDRX 1 +1 DRAW LINES OF CONSTANT +C X. +C 0 DO NOT. +C +C IDRY 1 +1 DRAW LINES OF CONSTANT +C Y. +C 0 DO NOT. +C +C IDRZ 0 +1 DRAW LINES OF CONSTANT +C Z (CONTOUR LINES). +C 0 DO NOT. +C +C IUPPER 0 +1 DRAW UPPER SIDE OF +C SURFACE. +C 0 DRAW BOTH SIDES. +C -1 DRAW LOWER SIDE. +C +C ISKIRT 0 +1 DRAW A SKIRT AROUND THE +C SURFACE. +C BOTTOM = HSKIRT. +C 0 DO NOT. +C +C NCLA 6 APPROXIMATE NUMBER OF +C LEVELS OF CONSTANT Z THAT +C ARE DRAWN IF LEVELS ARE NOT +C SPECIFIED. 40 LEVELS +C MAXIMUM. +C +C THETA .02 ANGLE IN RADIANS BETWEEN +C EYES FOR STEREO PAIRS. +C +C HSKIRT 0. HEIGHT OF SKIRT +C (IF ISKIRT = 1). +C +C CHI 0. HIGHEST LEVEL OF CONSTANT +C Z. +C +C CLO 0. LOWEST LEVEL OF CONSTANT Z. +C +C CINC 0. INCREMENT BETWEEN LEVELS. +C +C [IF CHI, CLO, OR CINC IS ZERO, A NICE +C VALUE IS GENERATED AUTOMATICALLY.] +C +C IOFFP 0 FLAG TO CONTROL USE OF SPECIAL +C VALUE FEATURE. DO NOT HAVE +C BOTH IOFFP=1 AND ISKIRT=1. +C 0 FEATURE NOT IN USE +C +1 FEATURE IN USE. NO LINES +C DRAWN TO DATA POINTS IN Z +C THAT ARE EQUAL TO SPVAL. +C +C SPVAL 0. SPECIAL VALUE USED TO MARK UN- +C KNOWN DATA WHEN IOFFP=1. +C +C +C + DIMENSION X(NX) ,Y(NY) ,Z(MX,NY), M(2,NX,NY), + 1 S(6) + DIMENSION WIN1(4) ,VP1(4) ,LASF(13) + COMMON /SRFINT/ ISRFMJ ,ISRFMN ,ISRFTX +c +NOAO: common block added 4NOV85 to allow user control of viewport + common /noaovp/ vpx1, vpx2, vpy1, vpy2 +c -NOAO +c +NOAO: Blockdata srfabd rewritten as run time initialization +c EXTERNAL SRFABD + call srfabd +c -NOAO + CALL Q8QST4 ('GRAPHX','SRFACE','SRFACE','VERSION 01') +C +C THIS DRIVER SAVES THE CURRENT NORMALIZATION TRANSFORMATION +C INFORMATION, DEFINES THE NORMALIZATION TRANSFORMATION +C APPROPRIATE FOR SRFGK, CALLS SRFGK, AND RESTORES THE ORIGINAL +C NORMALIZATION TRANSFORMATION. +C +C GET CURRENT NORMALIZATION TRANSFORMATION NUMBER +C + CALL GQCNTN (IER,NTORIG) +C +C STORE WINDOW AND VIEWPORT OF NORMALIZATION TRANSFORMATION 1 +C + CALL GQNT (NTORIG,IER,WIN1,VP1) + CALL GETUSV('LS',IOLLS) +C +C SET WINDOW AND VIEWPORT FOR SRFGK +C +c CALL SET(0.,1.,0.,1.,1.,1024.,1.,1024.,1) +c +NOAO: viewport limits now stored in common block noaovp + CALL SET(vpx1, vpx2, vpy1, vpy2, 1.0, 1024., 1.0, 1024., 1) +c -NOAO +C +C SET LINE COLOR TO INDIVIDUAL (SAVE CURRENT SETTING) +C + CALL GQASF (IER,LASF) + LASFSV = LASF(3) + LASF(3) = 1 + CALL GSASF(LASF) +C +C SET LINE COLOR INDEX TO COMMON VARIABLE ISRFMJ (SAVE +C CURRENT SETTING) +C + CALL GQPLCI (IER,LCISV) + CALL GSPLCI (ISRFMJ) +C +C DRAW PLOT +C + CALL SRFGK (X,Y,Z,M,MX,NX,NY,S,STEREO) +C +C RESTORE INITIAL LINE COLOR SETTINGS +C + LASF(3) = LASFSV + CALL GSASF(LASF) + CALL GSPLCI (LCISV) +C +C RESTORE ORIGINAL NORMALIZATION TRANSFORMATION +C + CALL SET(VP1(1),VP1(2),VP1(3),VP1(4),WIN1(1),WIN1(2), + - WIN1(3),WIN1(4),IOLLS) + CALL GSELNT (NTORIG) +C + RETURN + END + SUBROUTINE SRFGK (X,Y,Z,M,MX,NX,NY,S,STEREO) +C + DIMENSION X(NX) ,Y(NY) ,Z(MX,NY) ,M(2,NX,NY) , + 1 S(6) + DIMENSION MXS(2) ,MXF(2) ,MXJ(2) ,MYS(2), + 1 MYF(2) ,MYJ(2) + COMMON /SRFBLK/ LIMU(1024) ,LIML(1024) ,CL(41) ,NCL, + 1 LL ,FACT ,IROT ,NDRZ, + 2 NUPPER ,NRSWT ,BIGD ,UMIN, + 3 UMAX ,VMIN ,VMAX ,RZERO, + 4 IOFFP ,NSPVAL ,SPVAL ,BIGEST + COMMON /PWRZ1S/ XXMIN ,XXMAX ,YYMIN ,YYMAX, + 1 ZZMIN ,ZZMAX ,DELCRT ,EYEX, + 2 EYEY ,EYEZ + COMMON /SRFIP1/ IFR ,ISTP ,IROTS ,IDRX , + 1 IDRY ,IDRZ ,IUPPER ,ISKIRT, + 2 NCLA ,THETA ,HSKIRT ,CHI, + 3 CLO ,CINC ,ISPVAL +c +NOAO: + common /noaovp/ vpx1, vpx2, vpy1, vpy2 +c -NOAO +C + DATA JF, IF, LY, LX, ICNST /1, 1, 2, 2, 0/ + CALL Q8QST4 ('GRAPHX','SRFACE','SRFGK','VERSION 01') + BIGEST = R1MACH(2) + MMXX = MX + NNXX = NX + NNYY = NY + STER = STEREO + NXP1 = NNXX+1 + NYP1 = NNYY+1 + NLA = NCLA + NSPVAL = ISPVAL + NDRZ = IDRZ + IF (IDRZ .NE. 0) + 1 CALL CLSET (Z,MMXX,NNXX,NNYY,CHI,CLO,CINC,NLA,40,CL,NCL, + 2 ICNST,IOFFP,SPVAL,BIGEST) + IF (IDRZ .NE. 0) NDRZ = 1-ICNST + STHETA = SIN(STER*THETA) + CTHETA = COS(STER*THETA) + RX = S(1)-S(4) + RY = S(2)-S(5) + RZ = S(3)-S(6) + D1 = SQRT(RX*RX+RY*RY+RZ*RZ) + D2 = SQRT(RX*RX+RY*RY) + DX = 0. + DY = 0. + IF (STEREO .EQ. 0.) GO TO 20 + D1 = D1*STEREO*THETA + IF (D2 .GT. 0.) GO TO 10 + DX = D1 + GO TO 20 + 10 AGL = ATAN2(RX,-RY) + DX = D1*COS(AGL) + DY = D1*SIN(AGL) + 20 IROT = IROTS + NPIC = 1 + IF (STER .NE. 0.) NPIC = 2 + FACT = 1. + IF (NRSWT .NE. 0) FACT = RZERO/D1 + IF (ISTP.EQ.0 .AND. STER.NE.0.) IROT = 1 + DO 570 IPIC=1,NPIC + NUPPER = IUPPER + IF (IFR .LT. 0) CALL FRAME +C +C SET UP MAPING FROM FLOATING POINT 3-SPACE TO CRT SPACE. +C + SIGN1 = IPIC*2-3 + EYEX = S(1)+SIGN1*DX + POIX = S(4)+SIGN1*DX + EYEY = S(2)+SIGN1*DY + POIY = S(5)+SIGN1*DY + EYEZ = S(3) + POIZ = S(6) + LL = 0 + XEYE = EYEX + YEYE = EYEY + ZEYE = EYEZ + CALL TRN32S (POIX,POIY,POIZ,XEYE,YEYE,ZEYE,0) + LL = IPIC+2*ISTP+3 + IF (STER .EQ. 0.) LL = 1 + IF (NRSWT .NE. 0) GO TO 100 + XXMIN = X(1) + XXMAX = X(NNXX) + YYMIN = Y(1) + YYMAX = Y(NNYY) + UMIN = BIGEST + VMIN = BIGEST + ZZMIN = BIGEST + UMAX = -UMIN + VMAX = -VMIN + ZZMAX = -ZZMIN + DO 40 J=1,NNYY + DO 30 I=1,NNXX + ZZ = Z(I,J) + IF (IOFFP.EQ.1 .AND. ZZ.EQ.SPVAL) GO TO 30 + ZZMAX = AMAX1(ZZMAX,ZZ) + ZZMIN = AMIN1(ZZMIN,ZZ) + CALL TRN32S (X(I),Y(J),Z(I,J),UT,VT,DUMMY,1) + UMAX = AMAX1(UMAX,UT) + UMIN = AMIN1(UMIN,UT) + VMAX = AMAX1(VMAX,VT) + VMIN = AMIN1(VMIN,VT) + 30 CONTINUE + 40 CONTINUE + IF (ISKIRT .NE. 1) GO TO 70 + NXSTP = NNXX-1 + NYSTP = NNYY-1 + DO 60 J=1,NNYY,NYSTP + DO 50 I=1,NNXX,NXSTP + CALL TRN32S (X(I),Y(J),HSKIRT,UT,VT,DUMMY,1) + UMAX = AMAX1(UMAX,UT) + UMIN = AMIN1(UMIN,UT) + VMAX = AMAX1(VMAX,VT) + VMIN = AMIN1(VMIN,VT) + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + WIDTH = UMAX-UMIN + HIGHT = VMAX-VMIN + DIF = .5*(WIDTH-HIGHT) + IF (DIF) 80,100, 90 + 80 UMIN = UMIN+DIF + UMAX = UMAX-DIF + GO TO 100 + 90 VMIN = VMIN-DIF + VMAX = VMAX+DIF + 100 XEYE = EYEX + YEYE = EYEY + ZEYE = EYEZ + CALL TRN32S (POIX,POIY,POIZ,XEYE,YEYE,ZEYE,0) + DO 120 J=1,NNYY + DO 110 I=1,NNXX + CALL TRN32S (X(I),Y(J),Z(I,J),UT,VT,DUMMY,1) + M(1,I,J) = UT + M(2,I,J) = VT + 110 CONTINUE + 120 CONTINUE +C +C INITIALIZE UPPER AND LOWER VISIBILITY ARRAYS +C + DO 130 K=1,1024 + LIMU(K) = 0 + LIML(K) = 1024 + 130 CONTINUE +C +C FIND ORDER TO DRAW LINES +C + NXPASS = 1 + IF (S(1) .GE. X(NNXX)) GO TO 160 + IF (S(1) .LE. X(1)) GO TO 170 + DO 140 I=2,NNXX + LX = I + IF (S(1) .LE. X(I)) GO TO 150 + 140 CONTINUE + 150 MXS(1) = LX-1 + MXJ(1) = -1 + MXF(1) = 1 + MXS(2) = LX + MXJ(2) = 1 + MXF(2) = NNXX + NXPASS = 2 + GO TO 180 + 160 MXS(1) = NNXX + MXJ(1) = -1 + MXF(1) = 1 + GO TO 180 + 170 MXS(1) = 1 + MXJ(1) = 1 + MXF(1) = NNXX + 180 NYPASS = 1 + IF (S(2) .GE. Y(NNYY)) GO TO 210 + IF (S(2) .LE. Y(1)) GO TO 220 + DO 190 J=2,NNYY + LY = J + IF (S(2) .LE. Y(J)) GO TO 200 + 190 CONTINUE + 200 MYS(1) = LY-1 + MYJ(1) = -1 + MYF(1) = 1 + MYS(2) = LY + MYJ(2) = 1 + MYF(2) = NNYY + NYPASS = 2 + GO TO 230 + 210 MYS(1) = NNYY + MYJ(1) = -1 + MYF(1) = 1 + GO TO 230 + 220 MYS(1) = 1 + MYJ(1) = 1 + MYF(1) = NNYY +C +C PUT ON SKIRT ON FRONT SIDE IF WANTED +C + 230 IF (NXPASS.EQ.2 .AND. NYPASS.EQ.2) GO TO 490 + IF (ISKIRT .EQ. 0) GO TO 290 + IN = MXS(1) + IF = MXF(1) + JN = MYS(1) + JF = MYF(1) + IF (NYPASS .NE. 1) GO TO 260 + CALL TRN32S (X(1),Y(JN),HSKIRT,UX1,VX1,DUMMY,1) + CALL TRN32S (X(NNXX),Y(JN),HSKIRT,UX2,VX2,DUMMY,1) + QU = (UX2-UX1)/(X(NNXX)-X(1)) + QV = (VX2-VX1)/(X(NNXX)-X(1)) + YNOW = Y(JN) + DO 240 I=1,NNXX + CALL TRN32S (X(I),YNOW,HSKIRT,RU,RV,DUMMY,1) + CALL DRAWS (IFIX(RU),IFIX(RV),M(1,I,JN),M(2,I,JN),1,0) + 240 CONTINUE + CALL DRAWS (IFIX(UX1),IFIX(VX1),IFIX(UX2),IFIX(VX2),1,1) + IF (IDRY .NE. 0) GO TO 260 + DO 250 I=2,NNXX + CALL DRAWS (M(1,I-1,JN),M(2,I-1,JN),M(1,I,JN),M(2,I,JN),1,1) + 250 CONTINUE + 260 IF (NXPASS .NE. 1) GO TO 290 + CALL TRN32S (X(IN),Y(1),HSKIRT,UY1,VY1,DUMMY,1) + CALL TRN32S (X(IN),Y(NNYY),HSKIRT,UY2,VY2,DUMMY,1) + QU = (UY2-UY1)/(Y(NNYY)-Y(1)) + QV = (VY2-VY1)/(Y(NNYY)-Y(1)) + XNOW = X(IN) + DO 270 J=1,NNYY + CALL TRN32S (XNOW,Y(J),HSKIRT,RU,RV,DUMMY,1) + CALL DRAWS (IFIX(RU),IFIX(RV),M(1,IN,J),M(2,IN,J),1,0) + 270 CONTINUE + CALL DRAWS (IFIX(UY1),IFIX(VY1),IFIX(UY2),IFIX(VY2),1,1) + IF (IDRX .NE. 0) GO TO 290 + DO 280 J=2,NNYY + CALL DRAWS (M(1,IN,J-1),M(2,IN,J-1),M(1,IN,J),M(2,IN,J),1,1) + 280 CONTINUE +C +C PICK PROPER ALGORITHM +C + 290 LI = MXJ(1) + MI = MXS(1)-LI + NI = IABS(MI-MXF(1)) + LJ = MYJ(1) + MJ = MYS(1)-LJ + NJ = IABS(MJ-MYF(1)) +C +C WHEN LINE OF SIGHT IS NEARER TO PARALLEL TO THE X AXIS, +C HAVE J LOOP OUTER-MOST, OTHERWISE HAVE I LOOP OUTER-MOST. +C + IF (ABS(RX) .LE. ABS(RY)) GO TO 360 + IF (ISKIRT.NE.0 .OR. NYPASS.NE.1) GO TO 310 + I = MXS(1) + DO 300 J=2,NNYY + CALL DRAWS (M(1,I,J-1),M(2,I,J-1),M(1,I,J),M(2,I,J),0,1) + 300 CONTINUE + 310 DO 350 II=1,NNXX + I = MI+II*LI + IPLI = I+LI + IF (NYPASS .EQ. 1) GO TO 320 + K = MYS(1) + L = MYS(2) + IF (IDRX .NE. 0) + 1 CALL DRAWS (M(1,I,K),M(2,I,K),M(1,I,L),M(2,I,L),1,1) + IF (NDRZ.NE.0 .AND. II.NE.NI) + 1 CALL CTCELL (Z,MMXX,NNXX,NNYY,M,MIN0(I,I+LI),K) + 320 DO 340 JPASS=1,NYPASS + LJ = MYJ(JPASS) + MJ = MYS(JPASS)-LJ + NJ = IABS(MJ-MYF(JPASS)) + DO 330 JJ=1,NJ + J = MJ+JJ*LJ + JPLJ = J+LJ + IF (IDRX.NE.0 .AND. JJ.NE.NJ) + 1 CALL DRAWS (M(1,I,J),M(2,I,J),M(1,I,JPLJ), + 2 M(2,I,JPLJ),1,1) + IF (I.NE.MXF(1) .AND. IDRY.NE.0) + 1 CALL DRAWS (M(1,IPLI,J),M(2,IPLI,J),M(1,I,J), + 2 M(2,I,J),1,1) + IF (NDRZ.NE.0 .AND. JJ.NE.NJ .AND. II.NE.NNXX) + 1 CALL CTCELL (Z,MMXX,NNXX,NNYY,M,MIN0(I,I+LI), + 2 MIN0(J,J+LJ)) + 330 CONTINUE + 340 CONTINUE + 350 CONTINUE + GO TO 430 + 360 IF (ISKIRT.NE.0 .OR. NXPASS.NE.1) GO TO 380 + J = MYS(1) + DO 370 I=2,NNXX + CALL DRAWS (M(1,I-1,J),M(2,I-1,J),M(1,I,J),M(2,I,J),0,1) + 370 CONTINUE + 380 DO 420 JJ=1,NNYY + J = MJ+JJ*LJ + JPLJ = J+LJ + IF (NXPASS .EQ. 1) GO TO 390 + K = MXS(1) + L = MXS(2) + IF (IDRY .NE. 0) + 1 CALL DRAWS (M(1,K,J),M(2,K,J),M(1,L,J),M(2,L,J),1,1) + IF (NDRZ.NE.0 .AND. JJ.NE.NJ) + 1 CALL CTCELL (Z,MMXX,NNXX,NNYY,M,K,MIN0(J,J+LJ)) + 390 DO 410 IPASS=1,NXPASS + LI = MXJ(IPASS) + MI = MXS(IPASS)-LI + NI = IABS(MI-MXF(IPASS)) + DO 400 II=1,NI + I = MI+II*LI + IPLI = I+LI + IF (IDRY.NE.0 .AND. II.NE.NI) + 1 CALL DRAWS (M(1,I,J),M(2,I,J),M(1,IPLI,J), + 2 M(2,IPLI,J),1,1) + IF (J.NE.MYF(1) .AND. IDRX.NE.0) + 1 CALL DRAWS (M(1,I,JPLJ),M(2,I,JPLJ),M(1,I,J), + 2 M(2,I,J),1,1) + IF (NDRZ.NE.0 .AND. II.NE.NI .AND. JJ.NE.NNYY) + 1 CALL CTCELL (Z,MMXX,NNXX,NNYY,M,MIN0(I,I+LI), + 2 MIN0(J,J+LJ)) + 400 CONTINUE + 410 CONTINUE + 420 CONTINUE + 430 IF (ISKIRT .EQ. 0) GO TO 520 +C +C FIX UP IF SKIRT IS USED WITH LINES ONE WAY. +C + IF (IDRX .NE. 0) GO TO 460 + DO 450 IPASS=1,NXPASS + IF (NXPASS .EQ. 2) IF = 1+(IPASS-1)*(NNXX-1) + DO 440 J=2,NNYY + CALL DRAWS (M(1,IF,J-1),M(2,IF,J-1),M(1,IF,J),M(2,IF,J), + 1 1,0) + 440 CONTINUE + 450 CONTINUE + 460 IF (IDRY .NE. 0) GO TO 520 + DO 480 JPASS=1,NYPASS + IF (NYPASS .EQ. 2) JF = 1+(JPASS-1)*(NNYY-1) + DO 470 I=2,NNXX + CALL DRAWS (M(1,I-1,JF),M(2,I-1,JF),M(1,I,JF),M(2,I,JF), + 1 1,0) + 470 CONTINUE + 480 CONTINUE + GO TO 520 +C +C ALL VISIBLE IF VIEWED FROM DIRECTLY ABOVE OR BELOW. +C + 490 IF (NUPPER.GT.0 .AND. S(3).LT.S(6)) GO TO 520 + IF (NUPPER.LT.0 .AND. S(3).GT.S(6)) GO TO 520 + NUPPER = 1 + IF (S(3) .LT. S(6)) NUPPER = -1 + DO 510 I=1,NNXX + DO 500 J=1,NNYY + IF (IDRX.NE.0 .AND. J.NE.NNYY) + 1 CALL DRAWS (M(1,I,J),M(2,I,J),M(1,I,J+1),M(2,I,J+1), + 2 1,0) + IF (IDRY.NE.0 .AND. I.NE.NNXX) + 1 CALL DRAWS (M(1,I,J),M(2,I,J),M(1,I+1,J),M(2,I+1,J), + 2 1,0) + IF (IDRZ.NE.0 .AND. I.NE.NNXX .AND. J.NE.NNYY) + 1 CALL CTCELL (Z,MMXX,NNXX,NNYY,M,I,J) + 500 CONTINUE + 510 CONTINUE + 520 IF (STER .EQ. 0.) GO TO 560 + IF (ISTP) 540,530,550 + 530 CALL FRAME + 540 CALL FRAME + GO TO 570 + 550 IF (IPIC .NE. 2) GO TO 570 + 560 IF (IFR .GT. 0) CALL FRAME + 570 CONTINUE + RETURN + END + SUBROUTINE EZSRFC (Z,M,N,ANGH,ANGV,WORK) + DIMENSION Z(M,N) ,WORK(1) +C +C WORK(2*M*N+M+N) +C +C PERSPECTIVE PICTURE OF A SURFACE STORED IN A TWO DIMENSIONAL ARRAY +C VIA A VERY SHORT ARGUMENT LIST. +C +C ASSUMPTIONS-- +C THE ENTIRE ARRAY IS TO BE DRAWN, +C THE DATA IS EQUALLY SPACED (IN THE X-Y PLANE), +C NO STEREO PAIRS. +C IF THESE ASSUMPTIONS ARE NOT MET USE SRFACE. +C +C ARGUMENTS-- +C Z THE 2 DIMENSIONAL ARRAY TO BE DRAWN. +C M THE FIRST DIMENSION OF Z. +C N THE SECOND DIMENSION OF Z. +C ANGH ANGLE IN DEGREES IN THE X-Y PLANE TO THE LINE OF SIGHT +C (COUNTER-CLOCK WISE FROM THE PLUS-X AXIS). +C ANGV ANGLE IN DEGREES FROM THE X-Y PLANE TO THE LINE OF SIGHT +C (POSITIVE ANGLES ARE ABOVE THE MIDDLE Z, NEGATIVE BELOW). +C WORK A SCRATCH STORAGE DIMENSIONED AT LEAST 2*M*N+M+N. +C + COMMON /SRFBLK/ LIMU(1024) ,LIML(1024) ,CL(41) ,NCL, + 1 LL ,FACT ,IROT ,NDRZ, + 2 NUPPER ,NRSWT ,BIGD ,UMIN, + 3 UMAX ,VMIN ,VMAX ,RZERO, + 4 NOFFP ,NSPVAL ,SPV ,BIGEST + DIMENSION S(6) + DATA S(4),S(5),S(6)/0.0,0.0,0.0/ +C +C FACT1 IS THE PERSPECTIVE RATIO AND IS DEFINED TO BE THE RATIO +C MAXIMUM(LENGTH,WIDTH)/HEIGHT +C +C FACT2 IS THE RATIO (LENGTH OF LINE OF SIGHT)/MAXIMUM(LENGTH,WIDTH) +C + DATA FACT1,FACT2/2.0,5.0/ + BIGEST = R1MACH(2) +C +C FIND RANGE OF Z +C + MX = M + NY = N + ANG1 = ANGH*3.14159265358979/180. + ANG2 = ANGV*3.14159265358979/180. + FLO = BIGEST + HI = -FLO + DO 20 J=1,NY + DO 10 I=1,MX + IF (NOFFP.EQ.1 .AND. Z(I,J).EQ.SPV) GO TO 10 + HI = AMAX1(Z(I,J),HI) + FLO = AMIN1(Z(I,J),FLO) + 10 CONTINUE + 20 CONTINUE +C +C SET UP LINEAR X AND Y ARRAYS FOR SRFACE +C + DELTA = (HI-FLO)/(AMAX0(MX,NY)-1.)*FACT1 + XMIN = -(FLOAT(MX/2)*DELTA+FLOAT(MOD(MX+1,2))*DELTA) + YMIN = -(FLOAT(NY/2)*DELTA+FLOAT(MOD(NY+1,2))*DELTA) + DO 30 I=1,MX + WORK(I) = XMIN+FLOAT(I-1)*DELTA + 30 CONTINUE + DO 40 J=1,NY + K = MX+J + WORK(K) = YMIN+FLOAT(J-1)*DELTA + 40 CONTINUE +C +C SET UP EYE POSITION +C + FACTE = (HI-FLO)*FACT1*FACT2 + CANG2 = COS(ANG2) + S(1) = FACTE*CANG2*COS(ANG1) + S(2) = FACTE*CANG2*SIN(ANG1) + S(3) = FACTE*SIN(ANG2)+(FLO+HI)*.5 +C +C READY +C + CALL SRFACE (WORK(1),WORK(MX+1),Z,WORK(K+1),MX,MX,NY,S,0.) + RETURN + END + SUBROUTINE SETR (XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,R0) +C +C THIS ROUTINE ESTABLISHES CERTAIN CONSTANTS SO THAT SRFACE +C PRODUCES A PICTURE WHOSE SIZE CHANGES WITH RESPECT TO THE +C VIEWERS DISTANCE FROM THE OBJECT. IT CAN ALSO BE USED +C WHEN MAKING A MOVIE OF AN OBJECT EVOLVING IN TIME TO KEEP +C IT POSITIONED PROPERLY ON THE SCREEN, SAVING COMPUTER TIME +C IN THE BARGIN. CALL IT WITH R0 NEGATIVE TO TURN OFF THIS +C FEATURE. +C PARAMETERS +C XMIN,XMAX - RANGE OF X ARRAY THAT WILL BE PASSED TO SRFACE. +C YMIN,YMAX - SAME IDEA, BUT FOR Y. +C ZMIN,ZMAX - SAME IDEA, BUT FOR Z. IF A MOVIE IS BEING +C MADE OF AN EVOLVING Z ARRAY, ZMIN AND ZMAX +C SHOULD CONTAIN RANGE OF THE UNION OF ALL THE Z +C ARRAYS. THEY NEED NOT BE EXACT. +C R0 - DISTANCE BETWEEN OBSERVER AND POINT LOOKED AT +C WHEN THE PICTURE IS TO FILL THE SCREEN WHEN +C VIEWED FROM THE DIRECTION WHICH MAKES THE PIC- +C TURE BIGGEST. IF R0 IS NOT POSITIVE, THEN THE +C RELATIVE SIZE FEATURE IS TURNED OFF, AND SUB- +C SEQUENT PICTURES WILL FILL THE SCREEN. +C + COMMON /SRFBLK/ LIMU(1024) ,LIML(1024) ,CL(41) ,NCL, + 1 LL ,FACT ,IROT ,NDRZ, + 2 NUPPER ,NRSWT ,BIGD ,UMIN, + 3 UMAX ,VMIN ,VMAX ,RZERO, + 4 IOFFP ,NSPVAL ,SPVAL ,BIGEST + COMMON /PWRZ1S/ XXMIN ,XXMAX ,YYMIN ,YYMAX, + 1 ZZMIN ,ZZMAX ,DELCRT ,EYEX, + 2 EYEY ,EYEZ +C +C + CALL Q8QST4 ('GRAPHX','SRFACE','SETR','VERSION 01') + IF (R0) 10, 10, 20 + 10 NRSWT = 0 + RETURN + 20 NRSWT = 1 + XXMIN = XMIN + XXMAX = XMAX + YYMIN = YMIN + YYMAX = YMAX + ZZMIN = ZMIN + ZZMAX = ZMAX + RZERO = R0 + LL = 0 + XAT = (XXMAX+XXMIN)*.5 + YAT = (YYMAX+YYMIN)*.5 + ZAT = (ZZMAX+ZZMIN)*.5 + ALPHA = -(YYMIN-YAT)/(XXMIN-XAT) + YEYE = -RZERO/SQRT(1.+ALPHA*ALPHA) + XEYE = YEYE*ALPHA + YEYE = YEYE+YAT + XEYE = XEYE+XAT + ZEYE = ZAT + CALL TRN32S (XAT,YAT,ZAT,XEYE,YEYE,ZEYE,0) + XMN = XXMIN + XMX = XXMAX + YMN = YYMIN + YMX = YYMAX + ZMN = ZZMIN + ZMX = ZZMAX + CALL TRN32S (XMN,YMN,ZAT,UMN,DUMMY,DUMMIE,1) + CALL TRN32S (XMX,YMN,ZMN,DUMMY,VMN,DUMMIE,1) + CALL TRN32S (XMX,YMX,ZAT,UMX,DUMMY,DUMMIE,1) + CALL TRN32S (XMX,YMN,ZMX,DUMMY,VMX,DUMMIE,1) + UMIN = UMN + UMAX = UMX + VMIN = VMN + VMAX = VMX + BIGD = SQRT((XXMAX-XXMIN)**2+(YYMAX-YYMIN)**2+(ZZMAX-ZZMIN)**2)*.5 + RETURN + END + SUBROUTINE DRAWS (MX1,MY1,MX2,MY2,IDRAW,IMARK) +C +C THIS ROUTINE DRAWS THE VISIBLE PART OF THE LINE CONNECTING +C (MX1,MY1) AND (MX2,MY2). IF IDRAW .NE. 0, THE LINE IS DRAWN. +C IF IMARK .NE. 0, THE VISIBILITY ARRAY IS MARKED. +C + LOGICAL VIS1 ,VIS2 + DIMENSION PXS(2) ,PYS(2) + COMMON /SRFBLK/ LIMU(1024) ,LIML(1024) ,CL(41) ,NCL, + 1 LL ,FACT ,IROT ,NDRZ, + 2 NUPPER ,NRSWT ,BIGD ,UMIN, + 3 UMAX ,VMIN ,VMAX ,RZERO, + 4 IOFFP ,NSPVAL ,SPVAL ,BIGEST + DATA STEEP/5./ + DATA MX, MY /0, 0/ +C +c +NOAO: Blockdata srfabd rewritten as run time initialization +c EXTERNAL SRFABD + call srfabd +c -NOAO +C MAKE LINE LEFT TO RIGHT. +C + MMX1 = MX1 + MMY1 = MY1 + MMX2 = MX2 + MMY2 = MY2 + IF (MMX1.EQ.NSPVAL .OR. MMX2.EQ.NSPVAL) RETURN + IF (MMX1 .GT. MMX2) GO TO 10 + NX1 = MMX1 + NY1 = MMY1 + NX2 = MMX2 + NY2 = MMY2 + GO TO 20 + 10 NX1 = MMX2 + NY1 = MMY2 + NX2 = MMX1 + NY2 = MMY1 + 20 IF (NUPPER .LT. 0) GO TO 180 +C +C CHECK UPPER VISIBILITY. +C + VIS1 = NY1 .GE. (LIMU(NX1)-1) + VIS2 = NY2 .GE. (LIMU(NX2)-1) +C +C VIS1 AND VIS2 TRUE MEANS VISIBLE. +C + IF (VIS1 .AND. VIS2) GO TO 120 +C +C VIS1 AND VIS2 FALSE MEANS INVISIBLE. +C + IF (.NOT.(VIS1 .OR. VIS2)) GO TO 180 +C +C FIND CHANGE POINT. +C + IF (NX1 .EQ. NX2) GO TO 110 + DY = FLOAT(NY2-NY1)/FLOAT(NX2-NX1) + NX1P1 = NX1+1 + FNY1 = NY1 + IF (VIS1) GO TO 60 + DO 30 K=NX1P1,NX2 + MX = K + MY = FNY1+FLOAT(K-NX1)*DY + IF (MY .GT. LIMU(K)) GO TO 40 + 30 CONTINUE + 40 IF (ABS(DY) .GE. STEEP) GO TO 90 + 50 NX1 = MX + NY1 = MY + GO TO 120 + 60 DO 70 K=NX1P1,NX2 + MX = K + MY = FNY1+FLOAT(K-NX1)*DY + IF (MY .LT. LIMU(K)) GO TO 80 + 70 CONTINUE + 80 IF (ABS(DY) .GE. STEEP) GO TO 100 + NX2 = MX-1 + NY2 = MY + GO TO 120 + 90 IF (LIMU(MX) .EQ. 0) GO TO 50 + NX1 = MX + NY1 = LIMU(NX1) + GO TO 120 + 100 NX2 = MX-1 + NY2 = LIMU(NX2) + GO TO 120 + 110 IF (VIS1) NY2 = MIN0(LIMU(NX1),LIMU(NX2)) + IF (VIS2) NY1 = MIN0(LIMU(NX1),LIMU(NX2)) + 120 IF (IDRAW .EQ. 0) GO TO 150 +C +C DRAW VISIBLE PART OF LINE. +C + IF (IROT) 130,140,130 + 130 CONTINUE + PXS(1) = FLOAT(NY1) + PXS(2) = FLOAT(NY2) + PYS(1) = FLOAT(1024-NX1) + PYS(2) = FLOAT(1024-NX2) + CALL GPL (2,PXS,PYS) + GO TO 150 + 140 CONTINUE + PXS(1) = FLOAT(NX1) + PXS(2) = FLOAT(NX2) + PYS(1) = FLOAT(NY1) + PYS(2) = FLOAT(NY2) + CALL GPL (2,PXS,PYS) + 150 IF (IMARK .EQ. 0) GO TO 180 + IF (NX1 .EQ. NX2) GO TO 170 + DY = FLOAT(NY2-NY1)/FLOAT(NX2-NX1) + FNY1 = NY1 + DO 160 K=NX1,NX2 + LTEMP = FNY1+FLOAT(K-NX1)*DY + IF (LTEMP .GT. LIMU(K)) LIMU(K) = LTEMP + 160 CONTINUE + GO TO 180 + 170 LTEMP = MAX0(NY1,NY2) + IF (LTEMP .GT. LIMU(NX1)) LIMU(NX1) = LTEMP + 180 IF (NUPPER) 190,190,370 +C +C SAME IDEA AS ABOVE, BUT FOR LOWER SIDE. +C + 190 IF (MMX1 .GT. MMX2) GO TO 200 + NX1 = MMX1 + NY1 = MMY1 + NX2 = MMX2 + NY2 = MMY2 + GO TO 210 + 200 NX1 = MMX2 + NY1 = MMY2 + NX2 = MMX1 + NY2 = MMY1 + 210 VIS1 = NY1 .LE. (LIML(NX1)+1) + VIS2 = NY2 .LE. (LIML(NX2)+1) + IF (VIS1 .AND. VIS2) GO TO 310 + IF (.NOT.(VIS1 .OR. VIS2)) GO TO 370 + IF (NX1 .EQ. NX2) GO TO 300 + DY = FLOAT(NY2-NY1)/FLOAT(NX2-NX1) + NX1P1 = NX1+1 + FNY1 = NY1 + IF (VIS1) GO TO 250 + DO 220 K=NX1P1,NX2 + MX = K + MY = FNY1+FLOAT(K-NX1)*DY + IF (MY .LT. LIML(K)) GO TO 230 + 220 CONTINUE + 230 IF (ABS(DY) .GE. STEEP) GO TO 280 + 240 NX1 = MX + NY1 = MY + GO TO 310 + 250 DO 260 K=NX1P1,NX2 + MX = K + MY = FNY1+FLOAT(K-NX1)*DY + IF (MY .GT. LIML(K)) GO TO 270 + 260 CONTINUE + 270 IF (ABS(DY) .GE. STEEP) GO TO 290 + NX2 = MX-1 + NY2 = MY + GO TO 310 + 280 IF (LIML(MX) .EQ. 1024) GO TO 240 + NX1 = MX + NY1 = LIML(NX1) + GO TO 310 + 290 NX2 = MX-1 + NY2 = LIML(NX2) + GO TO 310 + 300 IF (VIS1) NY2 = MAX0(LIML(NX1),LIML(NX2)) + IF (VIS2) NY1 = MAX0(LIML(NX1),LIML(NX2)) + 310 IF (IDRAW .EQ. 0) GO TO 340 + IF (IROT) 320,330,320 + 320 CONTINUE + PXS(1) = FLOAT(NY1) + PXS(2) = FLOAT(NY2) + PYS(1) = FLOAT(1024-NX1) + PYS(2) = FLOAT(1024-NX2) + CALL GPL (2,PXS,PYS) + GO TO 340 + 330 CONTINUE + PXS(1) = FLOAT(NX1) + PXS(2) = FLOAT(NX2) + PYS(1) = FLOAT(NY1) + PYS(2) = FLOAT(NY2) + CALL GPL (2,PXS,PYS) + 340 IF (IMARK .EQ. 0) GO TO 370 + IF (NX1 .EQ. NX2) GO TO 360 + DY = FLOAT(NY2-NY1)/FLOAT(NX2-NX1) + FNY1 = NY1 + DO 350 K=NX1,NX2 + LTEMP = FNY1+FLOAT(K-NX1)*DY + IF (LTEMP .LT. LIML(K)) LIML(K) = LTEMP + 350 CONTINUE + RETURN + 360 LTEMP = MIN0(NY1,NY2) + IF (LTEMP .LT. LIML(NX1)) LIML(NX1) = LTEMP + 370 RETURN + END + SUBROUTINE TRN32S (X,Y,Z,XT,YT,ZT,IFLAG) +C +C THIS ROUTINE IMPLEMENTS THE 3-SPACE TO 2-SPACE TRANSFOR- +C MATION BY KUBER, SZABO AND GIULIERI, THE PERSPECTIVE +C REPRESENTATION OF FUNCTIONS OF TWO VARIABLES. J. ACM 15, +C 2, 193-204,1968. +C IFLAG=0 ARGUMENTS +C X,Y,Z ARE THE 3-SPACE COORDINATES OF THE INTERSECTION +C OF THE LINE OF SIGHT AND THE IMAGE PLANE. THIS +C POINT CAN BE THOUGHT OF AS THE POINT LOOKED AT. +C XT,YT,ZT ARE THE 3-SPACE COORDINATES OF THE EYE POSITION. +C +C IFLAG=1 ARGUMENTS +C X,Y,Z ARE THE 3-SPACE COORDINATES OF A POINT TO BE +C TRANSFORMED. +C XT,YT THE RESULTS OF THE 3-SPACE TO 2-SPACE TRANSFOR- +C MATION. +C USE IFIX(XT) AND IFIX(YT) IN GPL CALLS. +C ZT NOT USED. +C IF LL (IN COMMON) =0 XT AND YT ARE IN THE SAME SCALE AS X, Y, AND Z. +C + COMMON /PWRZ1S/ XXMIN ,XXMAX ,YYMIN ,YYMAX, + 1 ZZMIN ,ZZMAX ,DELCRT ,EYEX, + 2 EYEY ,EYEZ + COMMON /SRFBLK/ LIMU(1024) ,LIML(1024) ,CL(41) ,NCL, + 1 LL ,FACT ,IROT ,NDRZ, + 2 NUPPER ,NRSWT ,BIGD ,UMIN, + 3 UMAX ,VMIN ,VMAX ,RZERO, + 4 IOFFP ,NSPVAL ,SPVAL ,BIGEST + DIMENSION NLU(7) ,NRU(7) ,NBV(7) ,NTV(7) +C +C SAVE INSERTED BY BEN DOMENICO 9/8/85 BECAUSE OF ASSUMPTION THAT +C JUMP, JUMP2, AND JUMP3 ARE PRESERVED BETWEEN CALLS. +C THERE MAY BE OTHER SUCH ASSUMPTIONS AS WELL. +C + SAVE +C +C PICTURE CORNER COORDINATES FOR LL=1 +C + DATA NLU(1),NRU(1),NBV(1),NTV(1)/ 10,1014, 10,1014/ +C +C PICTURE CORNER COORDINATES FOR LL=2 +C + DATA NLU(2),NRU(2),NBV(2),NTV(2)/ 10, 924, 50, 964/ +C +C PICTURE CORNER COORDINATES FOR LL=3 +C + DATA NLU(3),NRU(3),NBV(3),NTV(3)/ 100,1014, 50, 964/ +C +C PICTURE CORNER COORDINATES FOR LL=4 +C + DATA NLU(4),NRU(4),NBV(4),NTV(4)/ 10,1014, 10,1014/ +C +C PICTURE CORNER COORDINATES FOR LL=5 +C + DATA NLU(5),NRU(5),NBV(5),NTV(5)/ 10,1014, 10,1014/ +C +C PICTURE CORNER COORDINATES FOR LL=6 +C + DATA NLU(6),NRU(6),NBV(6),NTV(6)/ 10, 512, 256, 758/ +C +C PICTURE CORNER COORDINATES FOR LL=7 +C + DATA NLU(7),NRU(7),NBV(7),NTV(7)/ 512,1014, 256, 758/ +C +C STORE THE PARAMETERS OF THE SET32 CALL FOR USE WHEN +C TRN32 IS CALLED. +C + IF (IFLAG) 40, 10, 40 + 10 CONTINUE + ASSIGN 60 TO JUMP3 + IF (IOFFP .EQ. 1) ASSIGN 50 TO JUMP3 + AX = X + AY = Y + AZ = Z + EX = XT + EY = YT + EZ = ZT +C +C AS MUCH COMPUTATION AS POSSIBLE IS DONE DURING EXECUTION +C THIS ROUTINE WHEN IFLAG=0 BECAUSE CALLS IN THAT MODE ARE INFREQUENT. +C + DX = AX-EX + DY = AY-EY + DZ = AZ-EZ + D = SQRT(DX*DX+DY*DY+DZ*DZ) + COSAL = DX/D + COSBE = DY/D + COSGA = DZ/D + SINGA = SQRT(1.-COSGA*COSGA) + ASSIGN 120 TO JUMP2 + IF (LL .EQ. 0) GO TO 20 + ASSIGN 100 TO JUMP2 + DELCRT = NRU(LL)-NLU(LL) + U0 = UMIN + V0 = VMIN + U1 = NLU(LL) + V1 = NBV(LL) + U2 = NRU(LL)-NLU(LL) + V2 = NTV(LL)-NBV(LL) + U3 = U2/(UMAX-UMIN) + V3 = V2/(VMAX-VMIN) + U4 = NRU(LL) + V4 = NTV(LL) + IF (NRSWT .EQ. 0) GO TO 20 + U0 = -BIGD + V0 = -BIGD + U3 = U2/(2.*BIGD) + V3 = V2/(2.*BIGD) +C +C THE 3-SPACE POINT LOOKED AT IS TRANSFORMED INTO (0,0) OF +C THE 2-SPACE. THE 3-SPACE Z AXIS IS TRANSFORMED INTO THE +C 2-SPACE Y AXIS. IF THE LINE OF SIGHT IS CLOSE TO PARALLEL +C TO THE 3-SPACE Z AXIS, THE 3-SPACE Y AXIS IS CHOSEN (IN- +C STEAD OF THE 3-SPACE Z AXIS) TO BE TRANSFORMED INTO THE +C 2-SPACE Y AXIS. +C + 20 IF (SINGA .LT. 0.0001) GO TO 30 + R = 1./SINGA + ASSIGN 70 TO JUMP + RETURN + 30 SINBE = SQRT(1.-COSBE*COSBE) + R = 1./SINBE + ASSIGN 80 TO JUMP + RETURN + 40 CONTINUE + XX = X + YY = Y + ZZ = Z + GO TO JUMP3,( 50, 60) + 50 IF (ZZ .EQ. SPVAL) GO TO 110 + 60 Q = D/((XX-EX)*COSAL+(YY-EY)*COSBE+(ZZ-EZ)*COSGA) + GO TO JUMP,( 70, 80) + 70 XX = ((EX+Q*(XX-EX)-AX)*COSBE-(EY+Q*(YY-EY)-AY)*COSAL)*R + YY = (EZ+Q*(ZZ-EZ)-AZ)*R + GO TO 90 + 80 XX = ((EZ+Q*(ZZ-EZ)-AZ)*COSAL-(EX+Q*(XX-EX)-AX)*COSGA)*R + YY = (EY+Q*(YY-EY)-AY)*R + 90 GO TO JUMP2,(100,120) +c + NOAO: Clipping is done at the gio level and is unnecessary here. The +c following statements were preventing labels from being positioned properly +c at the edges of the surface plot, even when the viewport had been reset. + 100 xx = u1 + u3 * (fact * xx - u0) + yy = v1 + v3 * (fact * yy - v0) +c 100 XX = AMIN1(U4,AMAX1(U1,U1+U3*(FACT*XX-U0))) +c YY = AMIN1(V4,AMAX1(V1,V1+V3*(FACT*YY-V0))) +c -NOAO + GO TO 120 + 110 XX = NSPVAL + YY = NSPVAL +C + 120 XT = XX + YT = YY + RETURN + END + SUBROUTINE CLSET (Z,MX,NX,NY,CHI,CLO,CINC,NLA,NLM,CL,NCL,ICNST, + 1 IOFFP,SPVAL,BIGEST) + DIMENSION Z(MX,NY) ,CL(NLM) + DATA KK /0/ +C +C CLSET PUTS THE VALUS OF THE CONTOUR LEVELS IN CL +C + ICNST = 0 + GLO = CLO + HA = CHI + FANC = CINC + CRAT = NLA + IF (HA-GLO) 10, 20, 50 + 10 GLO = HA + HA = CLO + GO TO 50 + 20 GLO = BIGEST + HA = -GLO + DO 40 J=1,NY + DO 30 I=1,NX + IF (IOFFP.EQ.1 .AND. Z(I,J).EQ.SPVAL) GO TO 30 + GLO = AMIN1(Z(I,J),GLO) + HA = AMAX1(Z(I,J),HA) + 30 CONTINUE + 40 CONTINUE + 50 IF (FANC) 60, 70, 90 + 60 CRAT = -FANC + 70 FANC = (HA-GLO)/CRAT + IF (FANC) 140,140, 80 + 80 P = 10.**(IFIX(ALOG10(FANC)+500.)-500) + FANC = AINT(FANC/P)*P + 90 IF (CHI-CLO) 110,100,110 + 100 GLO = AINT(GLO/FANC)*FANC + HA = AINT(HA/FANC)*FANC + 110 DO 120 K=1,NLM + CC = GLO+FLOAT(K-1)*FANC + IF (CC .GT. HA) GO TO 130 + KK = K + CL(K) = CC + 120 CONTINUE + 130 NCL = KK + RETURN + 140 ICNST = 1 + RETURN + END + SUBROUTINE CTCELL (Z,MX,NX,NY,M,I0,J0) +C +C CTCELL COMPUTES LINES OF CONSTANT Z (CONTOUR LINES) IN ONE +C CELL OF THE ARRAY Z FOR THE SRFACE PACKAGE. +C Z,MX,NX,NY ARE THE SAME AS IN SRFACE. +C M BY THE TIME CTCELL IS FIRST CALLED, M CONTAINS +C THE TWO-SPACE PLOTTER LOCATION OF EACH Z POINT. +C U(Z(I,J))=M(1,I,J). V(Z(I,J))=M(2,I,J) +C I0,J0 THE CELL Z(I0,J0) TO Z(I0+1,J0+1) IS THE ONE TO +C BE CONTOURED. +C + DIMENSION Z(MX,NY) ,M(2,NX,NY) + COMMON /SRFBLK/ LIMU(1024) ,LIML(1024) ,CL(41) ,NCL, + 1 LL ,FACT ,IROT ,NDRZ, + 2 NUPPER ,NRSWT ,BIGD ,UMIN, + 3 UMAX ,VMIN ,VMAX ,RZERO, + 4 IOFFP ,NSPVAL ,SPVAL ,BIGEST + DATA IDUB/0/ + R(HO,HU) = (HO-CV)/(HO-HU) + I1 = I0 + I1P1 = I1+1 + J1 = J0 + J1P1 = J1+1 + H1 = Z(I1,J1) + H2 = Z(I1,J1P1) + H3 = Z(I1P1,J1P1) + H4 = Z(I1P1,J1) + IF (IOFFP .NE. 1) GO TO 10 + IF (H1.EQ.SPVAL .OR. H2.EQ.SPVAL .OR. H3.EQ.SPVAL .OR. + 1 H4.EQ.SPVAL) RETURN + 10 IF (AMIN1(H1,H2,H3,H4) .GT. CL(NCL)) RETURN + DO 110 K=1,NCL +C +C FOR EACH CONTOUR LEVEL, DESIDE WHICH OF THE 16 BASIC SIT- +C UATIONS EXISTS, THEN INTERPOLATE IN TWO-SPACE TO FIND THE +C END POINTS OF THE CONTOUR LINE SEGMENT WITHIN THIS CELL. +C + CV = CL(K) + K1 = (IFIX(SIGN(1.,H1-CV))+1)/2 + K2 = (IFIX(SIGN(1.,H2-CV))+1)/2 + K3 = (IFIX(SIGN(1.,H3-CV))+1)/2 + K4 = (IFIX(SIGN(1.,H4-CV))+1)/2 + JUMP = 1+K1+K2*2+K3*4+K4*8 + GO TO (120, 30, 50, 60, 70, 20, 80, 90, 90, 80, + 1 40, 70, 60, 50, 30,110),JUMP + 20 IDUB = 1 + 30 RA = R(H1,H2) + MUA = FLOAT(M(1,I1,J1))+RA*FLOAT(M(1,I1,J1P1)-M(1,I1,J1)) + MVA = FLOAT(M(2,I1,J1))+RA*FLOAT(M(2,I1,J1P1)-M(2,I1,J1)) + RB = R(H1,H4) + MUB = FLOAT(M(1,I1,J1))+RB*FLOAT(M(1,I1P1,J1)-M(1,I1,J1)) + MVB = FLOAT(M(2,I1,J1))+RB*FLOAT(M(2,I1P1,J1)-M(2,I1,J1)) + GO TO 100 + 40 IDUB = -1 + 50 RA = R(H2,H1) + MUA = FLOAT(M(1,I1,J1P1))+RA*FLOAT(M(1,I1,J1)-M(1,I1,J1P1)) + MVA = FLOAT(M(2,I1,J1P1))+RA*FLOAT(M(2,I1,J1)-M(2,I1,J1P1)) + RB = R(H2,H3) + MUB = FLOAT(M(1,I1,J1P1))+RB*FLOAT(M(1,I1P1,J1P1)-M(1,I1,J1P1)) + MVB = FLOAT(M(2,I1,J1P1))+RB*FLOAT(M(2,I1P1,J1P1)-M(2,I1,J1P1)) + GO TO 100 + 60 RA = R(H2,H3) + MUA = FLOAT(M(1,I1,J1P1))+RA*FLOAT(M(1,I1P1,J1P1)-M(1,I1,J1P1)) + MVA = FLOAT(M(2,I1,J1P1))+RA*FLOAT(M(2,I1P1,J1P1)-M(2,I1,J1P1)) + RB = R(H1,H4) + MUB = FLOAT(M(1,I1,J1))+RB*FLOAT(M(1,I1P1,J1)-M(1,I1,J1)) + MVB = FLOAT(M(2,I1,J1))+RB*FLOAT(M(2,I1P1,J1)-M(2,I1,J1)) + GO TO 100 + 70 RA = R(H3,H2) + MUA = FLOAT(M(1,I1P1,J1P1))+ + 1 RA*FLOAT(M(1,I1,J1P1)-M(1,I1P1,J1P1)) + MVA = FLOAT(M(2,I1P1,J1P1))+ + 1 RA*FLOAT(M(2,I1,J1P1)-M(2,I1P1,J1P1)) + RB = R(H3,H4) + MUB = FLOAT(M(1,I1P1,J1P1))+ + 1 RB*FLOAT(M(1,I1P1,J1)-M(1,I1P1,J1P1)) + MVB = FLOAT(M(2,I1P1,J1P1))+ + 1 RB*FLOAT(M(2,I1P1,J1)-M(2,I1P1,J1P1)) + IDUB = 0 + GO TO 100 + 80 RA = R(H2,H1) + MUA = FLOAT(M(1,I1,J1P1))+RA*FLOAT(M(1,I1,J1)-M(1,I1,J1P1)) + MVA = FLOAT(M(2,I1,J1P1))+RA*FLOAT(M(2,I1,J1)-M(2,I1,J1P1)) + RB = R(H3,H4) + MUB = FLOAT(M(1,I1P1,J1P1))+ + 1 RB*FLOAT(M(1,I1P1,J1)-M(1,I1P1,J1P1)) + MVB = FLOAT(M(2,I1P1,J1P1))+ + 1 RB*FLOAT(M(2,I1P1,J1)-M(2,I1P1,J1P1)) + GO TO 100 + 90 RA = R(H4,H1) + MUA = FLOAT(M(1,I1P1,J1))+RA*FLOAT(M(1,I1,J1)-M(1,I1P1,J1)) + MVA = FLOAT(M(2,I1P1,J1))+RA*FLOAT(M(2,I1,J1)-M(2,I1P1,J1)) + RB = R(H4,H3) + MUB = FLOAT(M(1,I1P1,J1))+RB*FLOAT(M(1,I1P1,J1P1)-M(1,I1P1,J1)) + MVB = FLOAT(M(2,I1P1,J1))+RB*FLOAT(M(2,I1P1,J1P1)-M(2,I1P1,J1)) + IDUB = 0 + 100 CALL DRAWS (MUA,MVA,MUB,MVB,1,0) + IF (IDUB) 90,110, 70 + 110 CONTINUE + 120 RETURN + END diff --git a/sys/gio/ncarutil/strmln.f b/sys/gio/ncarutil/strmln.f new file mode 100644 index 00000000..411caed8 --- /dev/null +++ b/sys/gio/ncarutil/strmln.f @@ -0,0 +1,957 @@ + SUBROUTINE STRMLN (U,V,WORK,IMAX,IPTSX,JPTSY,NSET,IER) +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C SUBROUTINE STRMLN (U,V,WORK,IMAX,IPTSX,JPTSY,NSET,IER) +C +C DIMENSION OF U(IMAX,JPTSY) , V(IMAX,JPTSY) , +C ARGUMENTS WORK(2*IMAX*JPTSY) +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE STRMLN DRAWS A STREAMLINE REPRESENTATION OF +C THE FLOW FIELD. THE REPRESENTATION IS +C INDEPENDENT OF THE FLOW SPEED. +C +C USAGE IF THE FOLLOWING ASSUMPTIONS ARE MET, USE +C +C CALL EZSTRM (U,V,WORK,IMAX,JMAX) +C +C ASSUMPTIONS: +C --THE WHOLE ARRAY IS TO BE PROCESSED. +C --THE ARRAYS ARE DIMENSIONED +C U(IMAX,JMAX) , V(IMAX,JMAX) AND +C WORK(2*IMAX*JMAX). +C --WINDOW AND VIEWPORT ARE TO BE CHOSEN +C BY STRMLN. +C --PERIM IS TO BE CALLED. +C +C IF THESE ASSUMPTIONS ARE NOT MET, USE +C +C CALL STRMLN (U,V,WORK,IMAX,IPTSX,JPTSY, +C NSET,IER) +C +C THE USER MUST CALL FRAME IN THE CALLING +C ROUTINE. +C +C THE USER MAY CHANGE VARIOUS INTERNAL +C PARAMETERS VIA COMMON BLOCKS. SEE BELOW. +C +C ARGUMENTS +C +C ON INPUT U, V +C TWO DIMENSIONAL ARRAYS CONTAINING THE +C VELOCITY FIELDS TO BE PLOTTED. +C (NOTE: IF THE U AND V COMPONENTS +C ARE, FOR EXAMPLE, DEFINED IN CARTESIAN +C COORDINATES AND THE USER WISHES TO PLOT THEM +C ON A DIFFERENT PROJECTION (I.E., STEREO- +C GRAPHIC), THEN THE APPROPRIATE +C TRANSFORMATION MUST BE MADE TO THE U AND V +C COMPONENTS VIA THE FUNCTIONS FU AND FV +C (LOCATED IN DRWSTR). +C +C WORK +C USER PROVIDED WORK ARRAY. THE DIMENSION +C OF THIS ARRAY MUST BE .GE. 2*IMAX*JPTSY. +C CAUTION: THIS ROUTINE DOES NOT CHECK THE +C SIZE OF THE WORK ARRAY. +C +C IMAX +C THE FIRST DIMENSION OF U AND V IN THE +C CALLING PROGRAM. (X-DIRECTION) +C +C IPTSX +C THE NUMBER OF POINTS TO BE PLOTTED IN THE +C FIRST SUBSCRIPT DIRECTION. (X-DIRECTION) +C +C JPTSY +C THE NUMBER OF POINTS TO BE PLOTTED IN THE +C SECOND SUBSCRIPT DIRECTION. (Y-DIRECTION) +C +C NSET +C FLAG TO CONTROL SCALING +C > 0 STRMLN ASSUMES THAT THE WINDOW +C AND VIEWPORT HAVE BEEN SET BY THE +C USER IN SUCH A WAY AS TO PROPERLY +C SCALE THE PLOTTING INSTRUCTIONS +C GENERATED BY STRMLN. PERIM IS NOT +C CALLED. +C = 0 STRMLN WILL ESTABLISH THE WINDOW AND +C VIEWPORT TO PROPERLY SCALE THE +C PLOTTING INSTRUCTIONS TO THE STANDARD +C CONFIGURATION. PERIM IS CALLED TO DRAW +C THE BORDER. +C < 0 STRMLN ESTABLISHES THE WINDOW +C AND VIEWPORT SO AS TO PLACE THE +C STREAMLINES WITHIN THE LIMITS +C OF THE USER'S WINDOW. PERIM IS +C NOT CALLED. +C +C ON OUTPUT ONLY THE IER ARGUMENT MAY BE CHANGED. ALL +C OTHER ARGUMENTS ARE UNCHANGED. +C +C +C IER +C = 0 WHEN NO ERRORS ARE DETECTED +C = -1 WHEN THE ROUTINE IS CALLED WITH ICYC +C .NE. 0 AND THE DATA ARE NOT CYCLIC +C (ICYC IS AN INTERNAL PARAMETER +C DESCRIBED BELOW); IN THIS CASE THE +C ROUTINE WILL DRAW THE +C STREAMLINES WITH THE NON-CYCLIC +C INTERPOLATION FORMULAS. +C +C ENTRY POINTS STRMLN, DRWSTR, EZSTRM, GNEWPT, CHKCYC +C +C COMMON BLOCKS STR01, STR02, STR03, STR04 +C +C REQUIRED LIBRARY GRIDAL, GBYTES, AND THE SPPS +C ROUTINES +C +C HISTORY WRITTEN AND STANDARDIZED IN NOVEMBER 1973. +C I/O DRAWS STREAMLINES +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C HISTORY WRITTEN IN 1979. +C CONVERTED TO FORTRAN 77 AND GKS IN JUNE 1984. +C +C PORTABILITY FORTRAN 77 +C +C ALGORITHM WIND COMPONENTS ARE NORMALIZED TO THE VALUE +C OF DISPL. THE LEAST SIGNIFICANT TWO +C BITS OF THE WORK ARRAY ARE +C UTILIZED AS FLAGS FOR EACH GRID BOX. FLAG 1 +C INDICATES WHETHER ANY STREAMLINE HAS +C PREVIOUSLY PASSED THROUGH THIS BOX. FLAG 2 +C INDICATES WHETHER A DIRECTIONAL ARROW HAS +C ALREADY APPEARED IN A BOX. JUDICIOUS USE +C OF THESE FLAGS PREVENTS OVERCROWDING OF +C STREAMLINES AND DIRECTIONAL ARROWS. +C EXPERIENCE INDICATES THAT A FINAL PLEASING +C PICTURE IS PRODUCED WHEN STREAMLINES ARE +C INITIATED IN THE CENTER OF A GRID BOX. THE +C STREAMLINES ARE DRAWN IN ONE DIRECTION THEN +C IN THE OPPOSITE DIRECTION. +C +C REFERENCE THE TECHNIQUES UTILIZED HERE ARE DESCRIBED +C IN AN ARTICLE BY THOMAS WHITTAKER (U. OF +C WISCONSIN) WHICH APPEARED IN THE NOTES AND +C CORRESPONDENCE SECTION OF MONTHLY WEATHER +C REVIEW, JUNE 1977. +C +C TIMING HIGHLY VARIABLE +C IT DEPENDS ON THE COMPLEXITY OF THE +C FLOW FIELD AND THE PARAMETERS: DISPL, +C DISPC , CSTOP , INITA , INITB , ITERC , +C AND IGFLG. (SEE BELOW FOR A DISCUSSION +C OF THESE PARAMETERS.) IF ALL VALUES +C ARE DEFAULT, THEN A SIMPLE LINEAR +C FLOW FIELD FOR A 40 X 40 GRID WILL +C TAKE ABOUT 0.4 SECONDS ON THE CRAY1-A; +C A FAIRLY COMPLEX FLOW FIELD WILL TAKE ABOUT +C 1.5 SECONDS ON THE CRAY1-A. +C +C +C INTERNAL PARAMETERS +C +C NAME DEFAULT FUNCTION +C ---- ------- -------- +C +C EXT 0.25 LENGTHS OF THE SIDES OF THE +C PLOT ARE PROPORTIONAL TO +C IPTSX AND JPTSY EXCEPT IN +C THE CASE WHEN MIN(IPTSX,JPT +C / MAX(IPTSX,JPTSY) .LT. EXT; +C IN THAT CASE A SQUARE +C GRAPH IS PLOTTED. +C +C SIDE 0.90 LENGTH OF LONGER EDGE OF +C PLOT. (SEE ALSO EXT.) +C +C XLT 0.05 LEFT HAND EDGE OF THE PLOT. +C (0.0 = LEFT EDGE OF FRAME) +C (1.0 = RIGHT EDGE OF FRAME) +C +C YBT 0.05 BOTTOM EDGE OF THE PLOT. +C (0.0 = BOTTOM ; 1.0 = TOP) +C +C (YBT+SIDE AND XLT+SIDE MUST +C BE .LE. 1. ) +C +C INITA 2 USED TO PRECONDITION GRID +C BOXES TO BE ELIGIBLE TO +C START A STREAMLINE. +C FOR EXAMPLE, A VALUE OF 4 +C MEANS THAT EVERY FOURTH +C GRID BOX IS ELIGIBLE ; A +C VALUE OF 2 MEANS THAT EVERY +C OTHER GRID BOX IS ELIGIBLE. +C (SEE INITB) +C +C INITB 2 USED TO PRECONDITION GRID +C BOXES TO BE ELIGIBLE FOR +C DIRECTION ARROWS. +C IF THE USER CHANGES THE +C DEFAULT VALUES OF INITA +C AND/OR INITB, IT SHOULD +C BE DONE SUCH THAT +C MOD(INITA,INITB) = 0 . +C FOR A DENSE GRID TRY +C INITA=4 AND INITB=2 TO +C REDUCE THE CPU TIME. +C +C AROWL 0.33 LENGTH OF DIRECTION ARROW. +C FOR EXAMPLE, 0.33 MEANS +C EACH DIRECTIONAL ARROW WILL +C TAKE UP A THIRD OF A GRID +C BOX. +C +C ITERP 35 EVERY 'ITERP' ITERATIONS +C THE STREAMLINE PROGRESS +C IS CHECKED. +C +C ITERC -99 THE DEFAULT VALUE OF THIS +C PARAMETER IS SUCH THAT +C IT HAS NO EFFECT ON THE +C CODE. WHEN SET TO SOME +C POSITIVE VALUE, THE PROGRAM +C WILL CHECK FOR STREAMLINE +C CROSSOVER EVERY 'ITERC' +C ITERATIONS. (THE ROUTINE +C CURRENTLY DOES THIS EVERY +C TIME IT ENTERS A NEW GRID +C BOX.) CAUTION: WHEN +C THIS PARAMETER IS ACTIVATED +C CPU TIME WILL INCREASE. +C +C IGFLG 0 A VALUE OF ZERO MEANS THAT +C THE SIXTEEN POINT BESSEL +C INTERPOLATION FORMULA WILL +C BE UTILIZED WHERE POSSIBLE; +C WHEN NEAR THE GRID EDGES, +C QUADRATIC AND BI-LINEAR +C INTERPOLATION WILL BE +C USED. THIS MIXING OF +C INTERPOLATION SCHEMES CAN +C SOMETIMES CAUSE SLIGHT +C RAGGEDNESS NEAR THE EDGES +C OF THE PLOT. IF IGFLG.NE.0, +C THEN ONLY THE BILINEAR +C INTERPOLATION FORMULA +C IS USED; THIS WILL GENERALLY +C RESULT IN SLIGHTLY FASTER +C PLOT TIMES BUT A LESS +C PLEASING PLOT. +C +C IMSG 0 IF ZERO, THEN NO MISSING +C U AND V COMPONENTS ARE +C PRESENT. +C IF .NE. 0, STRMLN WILL +C UTILIZE THE +C BI-LINEAR INTERPOLATION +C SCHEME AND TERMINATE IF +C ANY DATA POINTS ARE MISSING. +C +C UVMSG 1.E+36 VALUE ASSIGNED TO A MISSING +C POINT. +C +C ICYC 0 ZERO MEANS THE DATA ARE +C NON-CYCLIC IN THE X +C DIRECTION. +C IF .NE 0, THE +C CYCLIC INTERPOLATION +C FORMULAS WILL BE USED. +C (NOTE: EVEN IF THE DATA +C ARE CYCLIC IN X LEAVING +C ICYC = 0 WILL DO NO HARM.) +C +C DISPL 0.33 THE WIND SPEED IS +C NORMALIZED TO THIS VALUE. +C (SEE THE DISCUSSION BELOW.) +C +C DISPC 0.67 THE CRITICAL DISPLACEMENT. +C IF AFTER 'ITERP' ITERATIONS +C THE STREAMLINE HAS NOT +C MOVED THIS DISTANCE, THE +C STREAMLINE WILL BE +C TERMINATED. +C +C CSTOP 0.50 THIS PARAMETER CONTROLS +C THE SPACING BETWEEN +C STREAMLINES. THE CHECKING +C IS DONE WHEN A NEW GRID +C BOX IS ENTERED. +C +C DISCUSSION OF ASSUME A VALUE OF 0.33 FOR DISPL. THIS +C DISPL,DISPC MEANS THAT IT WILL TAKE THREE STEPS TO MOVE +C AND CSTOP ACROSS ONE GRID BOX IF THE FLOW WAS ALL IN THE +C X DIRECTION. IF THE FLOW IS ZONAL, THEN A +C LARGER VALUE OF DISPL IS IN ORDER. +C IF THE FLOW IS HIGHLY TURBULENT, THEN +C A SMALLER VALUE IS IN ORDER. NOTE: THE SMALLER +C DISPL, THE MORE THE CPU TIME. A VALUE +C OF 2 TO 4 TIMES DISPL IS A REASONABLE VALUE +C FOR DISPC. DISPC SHOULD ALWAYS BE GREATER +C THAN DISPL. A VALUE OF 0.33 FOR CSTOP WOULD +C MEAN THAT A MAXIMUM OF THREE STREAM- +C LINES WILL BE DRAWN PER GRID BOX. THIS MAX +C WILL NORMALLY ONLY OCCUR IN AREAS OF SINGULAR +C POINTS. +C +C *************************** +C ANY OR ALL OF THE ABOVE +C PARAMETERS MAY BE CHANGED +C BY UTILIZING COMMON BLOCKS +C STR02 AND/OR STR03 +C *************************** +C +C UXSML 1.E-50 THE SMALLEST REAL NUMBER +C ON THE HOST COMPUTER. THIS +C IS SET AUTOMATICALLY BY +C R1MACH. +C +C NCHK 750 THIS PARAMETER IS LOCATED +C IN DRWSTR. IT SPECIFIES THE +C LENGTH OF THE CIRCULAR +C LISTS USED FOR CHECKING +C FOR STRMLN CROSSOVERS. +C FOR MOST PLOTS THIS NUMBER +C MAY BE REDUCED TO 500 +C OR LESS AND THE PLOTS WILL +C NOT BE ALTERED. +C +C ISKIP NUMBER OF BITS TO BE +C SKIPPED TO GET TO THE +C LEAST TWO SIGNIFICANT BITS +C IN A FLOATING POINT NUMBER. +C THE DEFAULT VALUE IS SET TO +C I1MACH(5) - 2 . THIS VALUE +C MAY HAVE TO BE CHANGED +C DEPENDING ON THE TARGET +C COMPUTER, SEE SUBROUTINE +C DRWSTR. +C +C +C + DIMENSION U(IMAX,JPTSY) ,V(IMAX,JPTSY) , + 1 WORK(1) + DIMENSION WNDW(4) ,VWPRT(4) +C + COMMON /STR01/ IS ,IEND ,JS ,JEND + 1 , IEND1 ,JEND1 ,I ,J + 2 , X ,Y ,DELX ,DELY + 3 , ICYC1 ,IMSG1 ,IGFL1 + COMMON /STR02/ EXT , SIDE , XLT , YBT + COMMON /STR03/ INITA , INITB , AROWL , ITERP , ITERC , IGFLG + 1 , IMSG , UVMSG , ICYC , DISPL , DISPC , CSTOP +C + SAVE +C + EXT = 0.25 + SIDE = 0.90 + XLT = 0.05 + YBT = 0.05 +C + INITA = 2 + INITB = 2 + AROWL = 0.33 + ITERP = 35 + ITERC = -99 + IGFLG = 0 + ICYC = 0 + IMSG = 0 +C +NOAO +C UVMSG = 1.E+36 + uvmsg = 1.E+16 +C -NOAO + DISPL = 0.33 + DISPC = 0.67 + CSTOP = 0.50 +C +C THE FOLLOWING CALL IS FOR MONITORING LIBRARY USE AT NCAR +C + CALL Q8QST4 ( 'GRAPHX', 'STRMLN', 'STRMLN', 'VERSION 01') +C + IER = 0 +C +C LOAD THE COMMUNICATION COMMON BLOCK WITH PARAMETERS +C + IS = 1 + IEND = IPTSX + JS = 1 + JEND = JPTSY + IEND1 = IEND-1 + JEND1 = JEND-1 + IEND2 = IEND-2 + JEND2 = JEND-2 + XNX = FLOAT(IEND-IS+1) + XNY = FLOAT(JEND-JS+1) + ICYC1 = ICYC + IGFL1 = IGFLG + IMSG1 = 0 +C +C IF ICYC .NE. 0 THEN CHECK TO MAKE SURE THE CYCLIC CONDITION EXISTS. +C + IF (ICYC1.NE.0) CALL CHKCYC (U,V,IMAX,JPTSY,IER) +C +C SAVE ORIGINAL NORMALIZATION TRANSFORMATION NUMBER +C + CALL GQCNTN ( IERR,NTORIG ) +C +C SET UP SCALING +C + IF (NSET) 10 , 20 , 60 + 10 CALL GETUSV ( 'LS' , ITYPE ) + CALL GQNT ( NTORIG,IERR,WNDW,VWPRT ) + CALL GETUSV('LS',IOLLS) + X1 = VWPRT(1) + X2 = VWPRT(2) + Y1 = VWPRT(3) + Y2 = VWPRT(4) + X3 = IS + X4 = IEND + Y3 = JS + Y4 = JEND + GO TO 55 +C + 20 ITYPE = 1 + X1 = XLT + X2 = (XLT+SIDE) + Y1 = YBT + Y2 = (YBT+SIDE) + X3 = IS + X4 = IEND + Y3 = JS + Y4 = JEND + IF (AMIN1(XNX,XNY)/AMAX1(XNX,XNY).LT.EXT) GO TO 50 + IF (XNX-XNY) 30, 50, 40 + 30 X2 = (SIDE*(XNX/XNY) + XLT) + GO TO 50 + 40 Y2 = (SIDE*(XNY/XNX) + YBT) + 50 CONTINUE +C +C CENTER THE PLOT +C + DX = 0.25*( 1. - (X2-X1) ) + DY = 0.25*( 1. - (Y2-Y1) ) + X1 = (XLT+DX) + X2 = (X2+DX ) + Y1 = (YBT+DY) + Y2 = (Y2+DY ) +C + 55 CONTINUE +C +C SAVE NORMALIZATION TRANSFORMATION 1 +C + CALL GQNT ( 1,IERR,WNDW,VWPRT ) +C +C DEFINE AND SELECT NORMALIZATION TRANS, SET LOG SCALING +C + CALL SET(X1,X2,Y1,Y2,X3,X4,Y3,Y4,ITYPE) +C + IF (NSET.EQ.0) CALL PERIM (1,0,1,0) +C + 60 CONTINUE +C +C DRAW THE STREAMLINES +C . BREAK THE WORK ARRAY INTO TWO PARTS. SEE DRWSTR FOR FURTHER +C . COMMENTS ON THIS. +C + CALL DRWSTR (U,V,WORK(1),WORK(IMAX*JPTSY+1),IMAX,JPTSY) +C +C RESET NORMALIATION TRANSFORMATION 1 TO ORIGINAL VALUES +C + IF (NSET .LE. 0) THEN + CALL SET(VWPRT(1),VWPRT(2),VWPRT(3),VWPRT(4), + - WNDW(1),WNDW(2),WNDW(3),WNDW(4),IOLLS) + ENDIF + CALL GSELNT (NTORIG) +C + RETURN + END + SUBROUTINE DRWSTR (U,V,UX,VY,IMAX,JPTSY) +C + PARAMETER (NCHK=750) +C +C THIS ROUTINE DRAWS THE STREAMLINES. +C . THE XCHK AND YCHK ARRAYS SERVE AS A CIRCULAR LIST. THEY +C . ARE USED TO PREVENT LINES FROM CROSSING ONE ANOTHER. +C +C THE WORK ARRAY HAS BEEN BROKEN UP INTO TWO ARRAYS FOR CLARITY. THE +C . TOP HALF OF WORK (CALLED UX) WILL HAVE THE NORMALIZED (AND +C . POSSIBLY TRANSFORMED) U COMPONENTS AND WILL BE USED FOR BOOK +C . KEEPING. THE LOWER HALF OF THE WORK ARRAY (CALLED VY) WILL +C . CONTAIN THE NORMALIZED (AND POSSIBLY TRANSFORMED) V COMPONENTS. +C + DIMENSION U(IMAX,JPTSY) ,V(IMAX,JPTSY) + 1 , UX(IMAX,JPTSY) ,VY(IMAX,JPTSY) + COMMON /STR01/ IS ,IEND ,JS ,JEND + 1 , IEND1 ,JEND1 ,I ,J + 2 , X ,Y ,DELX ,DELY + 3 , ICYC1 ,IMSG1 ,IGFL1 + COMMON /STR03/ INITA , INITB , AROWL , ITERP , ITERC , IGFLG + 1 , IMSG , UVMSG , ICYC , DISPL , DISPC , CSTOP + COMMON /STR04/ XCHK(NCHK) ,YCHK(NCHK) , NUMCHK , UXSML +C +C + SAVE +C +C STATEMENT FUNCTIONS FOR SPATIAL AND VELOCITY TRANSFORMATIONS. +C . (IF THE USER WISHES OTHER TRANSFORMATIONS REPLACE THESE STATEMENT +C . FUNCTIONS WITH THE APPROPRIATE NEW ONES, OR , IF THE TRANSFORMA- +C . TIONS ARE COMPLICATED DELETE THESE STATEMENT FUNCTIONS +C . AND ADD EXTERNAL ROUTINES WITH THE SAME NAMES TO DO THE TRANS- +C . FORMING.) +C + FX(X,Y) = X + FY(X,Y) = Y + FU(X,Y) = X + FV(X,Y) = Y +C +C INITIALIZE +C + ISKIP = I1MACH(5) - 2 + ISKIP1 = ISKIP + 1 + UXSML = R1MACH(1) +C +C + NUMCHK = NCHK + LCHK = 1 + ICHK = 1 + XCHK(1) = 0. + YCHK(1) = 0. + KFLAG = 0 + IZERO = 0 + IONE = 1 + ITWO = 2 +C +C +C COMPUTE THE X AND Y NORMALIZED (AND POSSIBLY TRANSFORMED) +C . DISPLACEMENT COMPONENTS (UX AND VY). +C + DO 40 J=JS,JEND + DO 30 I=IS,IEND + IF (U(I,J).EQ.0. .AND. V(I,J).EQ.0.) GO TO 10 + UX(I,J) = FU(U(I,J),V(I,J)) + VY(I,J) = FV(U(I,J),V(I,J)) + CON = DISPL/SQRT(UX(I,J)*UX(I,J) + VY(I,J)*VY(I,J)) + UX(I,J) = CON*UX(I,J) + VY(I,J) = CON*VY(I,J) +C + IF(UX(I,J) .EQ. 0.) UX(I,J) = CON*FU(UXSML,V(I,J)) +C + GO TO 20 + 10 CONTINUE +C +C BOOKKEEPING IS DONE IN THE LEAST SIGNIFICANT BITS OF THE UX ARRAY. +C . WHEN UX(I,J) IS EXACTLY ZERO THIS CAN PRESENT SOME PROBLEMS. +C . TO GET AROUND THIS PROBLEM SET IT TO SOME VERY SMALL NUMBER. +C + UX(I,J) = FU(UXSML,0.) + VY(I,J) = 0. +C +C MASK OUT THE LEAST SIGNIFICANT TWO BITS AS FLAGS FOR EACH GRID BOX +C . A GRID BOX IS ANY REGION SURROUNDED BY FOUR GRID POINTS. +C . FLAG 1 INDICATES WHETHER ANY STREAMLINE HAS PREVIOUSLY PASSED +C . THROUGH THIS BOX. +C . FLAG 2 INDICATES WHETHER ANY DIRECTIONAL ARROW HAS ALREADY +C . APPEARED IN THIS BOX. +C . JUDICIOUS USE OF THESE FLAGS PREVENTS OVERCROWDING OF +C . STREAMLINES AND DIRECTIONAL ARROWS. +C + 20 CALL SBYTES( UX(I,J) , IZERO , ISKIP , 2 , 0 , 1 ) +C + IF (MOD(I,INITA).NE.0 .OR. MOD(J,INITA).NE.0) + 1 CALL SBYTES( UX(I,J) , IONE , ISKIP1, 1 , 0 , 1 ) + IF (MOD(I,INITB).NE.0 .OR. MOD(J,INITB).NE.0) + 1 CALL SBYTES( UX(I,J) , IONE , ISKIP , 1 , 0 , 1 ) +C + 30 CONTINUE + 40 CONTINUE +C + 50 CONTINUE +C +C START A STREAMLINE. EXPERIENCE HAS SHOWN THAT A PLEASING PICTURE +C . WILL BE PRODUCED IF NEW STREAMLINES ARE STARTED ONLY IN GRID +C . BOXES THAT PREVIOUSLY HAVE NOT HAD OTHER STREAMLINES PASS THROUGH +C . THEM. AS LONG AS A REASONABLY DENSE PATTERN OF AVAILABLE BOXES +C . IS INITIALLY PRESCRIBED, THE ORDER OF SCANNING THE GRID PTS. FOR +C . AVAILABLE BOXES IS IMMATERIAL +C +C FIND AN AVAILABLE BOX FOR STARTING A STREAMLINE +C + IF (KFLAG.NE.0) GO TO 90 + DO 70 J=JS,JEND1 + DO 60 I=IS,IEND1 + CALL GBYTES( UX(I,J) , IUX , ISKIP , 2 , 0 , 1 ) + IF ( IAND( IUX , IONE ) .EQ. IZERO ) GO TO 80 + 60 CONTINUE + 70 CONTINUE +C +C MUST BE NO AVAILABLE BOXES FOR STARTING A STREAMLINE +C + GO TO 190 + 80 CONTINUE +C +C INITILIZE PARAMETERS FOR STARTING A STREAMLINE +C . TURN THE BOX OFF FOR STARTING A STREAMLINE +C . CHECK TO SEE IF THIS BOX HAS MISSING DATA (IMSG.NE.0). IF SO , +C . FIND A NEW STARTING BOX +C + CALL SBYTES( UX(I,J) , IONE , ISKIP1 , 1 , 0 , 1 ) + IF ( IMSG.EQ.0) GO TO 85 + IF (U(I,J).EQ.UVMSG .OR. U(I,J+1).EQ.UVMSG .OR. + 1 U(I+1,J).EQ.UVMSG .OR. U(I+1,J+1).EQ.UVMSG) GO TO 50 +C + 85 ISAV = I + JSAV = J + KFLAG = 1 + PLMN1 = +1. + GO TO 100 + 90 CONTINUE +C +C COME TO HERE TO DRAW IN THE OPPOSITE DIRECTION +C + KFLAG = 0 + PLMN1 = -1. + I = ISAV + J = JSAV + 100 CONTINUE +C +C INITIATE THE DRAWING SEQUENCE +C . START ALL STREAMLINES IN THE CENTER OF A BOX +C + NBOX = 0 + ITER = 0 + IF (KFLAG.NE.0) ICHKB = ICHK+1 + IF (ICHKB.GT.NUMCHK) ICHKB = 1 + X = FLOAT(I)+0.5 + Y = FLOAT(J)+0.5 + XBASE = X + YBASE = Y + CALL FL2INT (FX(X,Y),FY(X,Y),IFX,IFY) + CALL PLOTIT (IFX,IFY,0) + CALL GBYTES( UX(I,J) , IUX , ISKIP , 2 , 0 , 1 ) + IF ( (KFLAG.EQ.0) .OR. (IAND( IUX , ITWO ) .NE. 0 ) ) GO TO 110 +C +C GRID BOX MUST BE ELIGIBLE FOR A DIRECTIONAL ARROW +C + CALL GNEWPT (UX,VY,IMAX,JPTSY) + MFLAG = 1 + GO TO 160 +C + 110 CONTINUE +C +C PLOT LOOP +C . CHECK TO SEE IF THE STREAMLINE HAS ENTERED A NEW GRID BOX +C + IF (I.NE.IFIX(X) .OR. J.NE.IFIX(Y)) GO TO 120 +C +C MUST BE IN SAME BOX CALCULATE THE DISPLACEMENT COMPONENTS +C + CALL GNEWPT (UX,VY,IMAX,JPTSY) +C +C UPDATE THE POSITION AND DRAW THE VECTOR +C + X = X+PLMN1*DELX + Y = Y+PLMN1*DELY + CALL FL2INT (FX(X,Y),FY(X,Y),IFX,IFY) + CALL PLOTIT (IFX,IFY,1) + ITER = ITER+1 +C +C CHECK STREAMLINE PROGRESS EVERY 'ITERP' OR SO ITERATIONS +C + IF (MOD(ITER,ITERP).NE.0) GO TO 115 + IF (ABS(X-XBASE).LT.DISPC .AND. ABS(Y-YBASE).LT.DISPC ) GO TO 50 + XBASE = X + YBASE = Y + GO TO 110 + 115 CONTINUE +C +C SHOULD THE CIRCULAR LISTS BE CHECKED FOR STREAMLINE CROSSOVER +C + IF ( (ITERC.LT.0) .OR. (MOD(ITER,ITERC).NE.0) ) GO TO 110 +C +C MUST WANT THE CIRCULAR LIST CHECKED +C + GO TO 130 + 120 CONTINUE +C +C MUST HAVE ENTERED A NEW GRID BOX CHECK FOR THE FOLLOWING : +C . (1) ARE THE NEW POINTS ON THE GRID +C . (2) CHECK FOR MISSING DATA IF MSG DATA FLAG (IMSG) HAS BEEN SET. +C . (3) IS THIS BOX ELIGIBLE FOR A DIRECTIONAL ARROW +C . (4) LOCATION OF THIS ENTRY VERSUS OTHER STREAMLINE ENTRIES +C + NBOX = NBOX+1 +C +C CHECK (1) +C + IF (IFIX(X).LT.IS .OR. IFIX(X).GT.IEND1) GO TO 50 + IF (IFIX(Y).LT.JS .OR. IFIX(Y).GT.JEND1) GO TO 50 +C +C CHECK (2) +C + IF ( IMSG.EQ.0) GO TO 125 + II = IFIX(X) + JJ = IFIX(Y) + IF (U(II,JJ).EQ.UVMSG .OR. U(II,JJ+1).EQ.UVMSG .OR. + 1 U(II+1,JJ).EQ.UVMSG .OR. U(II+1,JJ+1).EQ.UVMSG) GO TO 50 + 125 CONTINUE +C +C CHECK (3) +C + CALL GBYTES( UX(I,J) , IUX , ISKIP , 2 , 0 , 1 ) + IF ( IAND( IUX , ITWO ) .NE. 0) GO TO 130 + MFLAG = 2 + GO TO 160 + 130 CONTINUE +C +C CHECK (4) +C + DO 140 LOC=1,LCHK + IF (ABS( X-XCHK(LOC) ).GT.CSTOP .OR. + 1 ABS( Y-YCHK(LOC) ).GT.CSTOP) GO TO 140 + LFLAG = 1 + IF (ICHKB.LE.ICHK .AND. LOC.GE.ICHKB .AND. LOC.LE.ICHK) LFLAG = 2 + IF (ICHKB.GE.ICHK .AND. (LOC.GE.ICHKB .OR. LOC.LE.ICHK)) LFLAG = 2 + IF (LFLAG.EQ.1) GO TO 50 + 140 CONTINUE + LCHK = MIN0(LCHK+1,NUMCHK) + ICHK = ICHK+1 + IF (ICHK.GT.NUMCHK) ICHK = 1 + XCHK(ICHK) = X + YCHK(ICHK) = Y + I = IFIX(X) + J = IFIX(Y) + CALL SBYTES( UX(I,J) , IONE , ISKIP1 , 1 , 0 , 1 ) + IF (NBOX.LT.5) GO TO 150 + ICHKB = ICHKB+1 + IF (ICHKB.GT.NUMCHK) ICHKB = 1 + 150 CONTINUE + GO TO 110 +C + 160 CONTINUE +C +C THIS SECTION DRAWS A DIRECTIONAL ARROW BASED ON THE MOST RECENT DIS- +C . PLACEMENT COMPONENTS ,DELX AND DELY, RETURNED BY GNEWPT. IN EARLIE +C . VERSIONS THIS WAS A SEPARATE SUBROUTINE (CALLED DRWDAR). IN THAT +C . CASE ,HOWEVER, FX AND FY WERE DEFINED EXTERNAL SINCE THESE +C . FUNCTIONS WERE USED BY BOTH DRWSTR AND DRWDAR. IN ORDER TO +C . MAKE ALL DEFAULT TRANSFORMATIONS STATEMENT FUNCTIONS I HAVE +C . PUT DRWDAR HERE AND I WILL USE MFLAG TO RETURN TO THE CORRECT +C . LOCATION IN THE CODE. +C + IF ( (DELX.EQ.0.) .AND. (DELY.EQ.0.) ) GO TO 50 +C + CALL SBYTES( UX(I,J) ,IONE , ISKIP , 1 ,0 , 1 ) + D = ATAN2(-DELX,DELY) + D30 = D+0.5 + 170 YY = -AROWL*COS(D30)+Y + XX = +AROWL*SIN(D30)+X + CALL FL2INT (FX(XX,YY),FY(XX,YY),IFXX,IFYY) + CALL PLOTIT (IFXX,IFYY,1) + CALL FL2INT (FX(X,Y),FY(X,Y),IFX,IFY) + CALL PLOTIT (IFX,IFY,0) + IF (D30.LT.D) GO TO 180 + D30 = D-0.5 + GO TO 170 + 180 IF (MFLAG.EQ.1) GO TO 110 + IF (MFLAG.EQ.2) GO TO 130 +C + 190 CONTINUE +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(0,0,0) + RETURN + END + SUBROUTINE GNEWPT (UX,VY,IMAX,JPTSY) +C +C INTERPOLATION ROUTINE TO CALCULATE THE DISPLACEMANT COMPONENTS +C . THE PHILOSPHY HERE IS TO UTILIZE AS MANY POINTS AS POSSIBLE +C . (WITHIN REASON) IN ORDER TO OBTAIN A PLEASING AND ACCURATE PLOT. +C . INTERPOLATION SCHEMES DESIRED BY OTHER USERS MAY EASILY BE +C . SUBSTITUTED IF DESIRED. +C + DIMENSION UX(IMAX,JPTSY) ,VY(IMAX,JPTSY) + COMMON /STR01/ IS ,IEND ,JS ,JEND + 1 , IEND1 ,JEND1 ,I ,J + 2 , X ,Y ,DELX ,DELY + 3 , ICYC1 ,IMSG1 ,IGFL1 + COMMON /STR03/ INITA , INITB , AROWL , ITERP , ITERC , IGFLG + 1 , IMSG , UVMSG , ICYC , DISPL , DISPC , CSTOP +C + SAVE +C +C FDLI - DOUBLE LINEAR INTERPOLATION FORMULA +C FBESL - BESSEL 16 PT INTERPOLATION FORMULA ( MOST USED FORMULA ) +C FQUAD - QUADRATIC INTERPOLATION FORMULA +C + FDLI(Z,Z1,Z2,Z3,DX,DY) = (1.-DX)*((1.-DY)*Z +DY*Z1) + 1 + DX *((1.-DY)*Z2+DY*Z3) + FBESL(Z,ZP1,ZP2,ZM1,DZ)=Z+DZ*(ZP1-Z+0.25*(DZ-1.)*((ZP2-ZP1-Z+ZM1) + 1 +0.666667*(DZ-0.5)*(ZP2-3.*ZP1+3.*Z-ZM1))) + FQUAD(Z,ZP1,ZM1,DZ)=Z+0.5*DZ*(ZP1-ZM1+DZ*(ZP1-2.*Z+ZM1)) +C + DX = X-AINT(X) + DY = Y-AINT(Y) +C + IF( IMSG.NE.0.OR.IGFLG.NE.0) GO TO 20 +C + IM1 = I-1 + IP2 = I+2 +C +C DETERMINE WHICH INTERPOLATION FORMULA TO USE DEPENDING ON I,J LOCATION +C . THE FIRST CHECK IS FOR I,J IN THE GRID INTERIOR. +C + IF (J.GT.JS .AND. J.LT.JEND1 .AND. I.GT.IS .AND. I.LT.IEND1) + 1 GO TO 30 + IF (J.EQ.JEND1 .AND. I.GT.IS .AND. I.LT.IEND1) GO TO 40 + IF (J.EQ.JS) GO TO 20 +C + IF (ICYC1.EQ.1) GO TO 10 +C +C MUST NOT BE CYCLIC +C + IF (I.EQ.IS) GO TO 20 + IF (I.EQ.IEND1) GO TO 50 + GO TO 20 + 10 CONTINUE +C +C MUST BE CYCLIC IN THE X DIRECTION +C + IF (I.EQ.IS .AND. J.LT.JEND1) GO TO 12 + IF (I.EQ.IEND1 .AND. J.LT.JEND1) GO TO 14 + IF (J.EQ.JEND1 .AND. I.EQ.IS) GO TO 16 + IF (J.EQ.JEND1 .AND. I.EQ.IEND1) GO TO 18 + GO TO 20 + 12 IM1 = IEND1 + GO TO 30 + 14 IP2 = IS+1 + GO TO 30 + 16 IM1 = IEND1 + GO TO 40 + 18 IP2 = IS+1 + GO TO 40 +C + 20 CONTINUE +C +C DOUBLE LINEAR INTERPOLATION FORMULA. THIS SCHEME WORKS AT ALL POINTS +C . BUT THE RESULTING STREAMLINES ARE NOT AS PLEASING AS THOSE DRAWN +C . BY FBESL OR FQUAD. CURRENTLY THIS IS USED AT THIS IS UTILIZED +C . ONLY AT CERTAIN BOUNDARY POINTS OR IF IGFLG IS NOT EQUAL TO ZERO. +C + DELX = FDLI (UX(I,J),UX(I,J+1),UX(I+1,J),UX(I+1,J+1),DX,DY) + DELY = FDLI (VY(I,J),VY(I,J+1),VY(I+1,J),VY(I+1,J+1),DX,DY) + RETURN + 30 CONTINUE +C +C USE A 16 POINT BESSEL INTERPOLATION SCHEME +C + UJM1 = FBESL (UX(I,J-1),UX(I+1,J-1),UX(IP2,J-1),UX(IM1,J-1),DX) + UJ = FBESL (UX(I,J),UX(I+1,J),UX(IP2,J),UX(IM1,J),DX) + UJP1 = FBESL (UX(I,J+1),UX(I+1,J+1),UX(IP2,J+1),UX(IM1,J+1),DX) + UJP2 = FBESL (UX(I,J+2),UX(I+1,J+2),UX(IP2,J+2),UX(IM1,J+2),DX) + DELX = FBESL (UJ,UJP1,UJP2,UJM1,DY) + VJM1 = FBESL (VY(I,J-1),VY(I+1,J-1),VY(IP2,J-1),VY(IM1,J-1),DX) + VJ = FBESL (VY(I,J),VY(I+1,J),VY(IP2,J),VY(IM1,J),DX) + VJP1 = FBESL (VY(I,J+1),VY(I+1,J+1),VY(IP2,J+1),VY(IM1,J+1),DX) + VJP2 = FBESL (VY(I,J+2),VY(I+1,J+2),VY(IP2,J+2),VY(IM1,J+2),DX) + DELY = FBESL (VJ,VJP1,VJP2,VJM1,DY) + RETURN + 40 CONTINUE +C +C 12 POINT INTERPOLATION SCHEME APPLICABLE TO ONE ROW FROM TOP BOUNDARY +C + UJM1 = FBESL (UX(I,J-1),UX(I+1,J-1),UX(IP2,J-1),UX(IM1,J-1),DX) + UJ = FBESL (UX(I,J),UX(I+1,J),UX(IP2,J),UX(IM1,J),DX) + UJP1 = FBESL (UX(I,J+1),UX(I+1,J+1),UX(IP2,J+1),UX(IM1,J+1),DX) + DELX = FQUAD (UJ,UJP1,UJM1,DY) + VJM1 = FBESL (VY(I,J-1),VY(I+1,J-1),VY(IP2,J-1),VY(IM1,J-1),DX) + VJ = FBESL (VY(I,J),VY(I+1,J),VY(IP2,J),VY(IM1,J),DX) + VJP1 = FBESL (VY(I,J+1),VY(I+1,J+1),VY(IP2,J+1),VY(IM1,J+1),DX) + DELY = FQUAD (VJ,VJP1,VJM1,DY) + RETURN + 50 CONTINUE +C +C 9 POINT INTERPOLATION SCHEME FOR USE IN THE NON-CYCLIC CASE +C . AT I=IEND1 ; JS.LT.J AND J.LE.JEND1 +C + UJP1 = FQUAD (UX(I,J+1),UX(I+1,J+1),UX(IM1,J+1),DX) + UJ = FQUAD (UX(I,J),UX(I+1,J),UX(IM1,J),DX) + UJM1 = FQUAD (UX(I,J-1),UX(I+1,J-1),UX(IM1,J-1),DX) + DELX = FQUAD (UJ,UJP1,UJM1,DY) + VJP1 = FQUAD (VY(I,J+1),VY(I+1,J+1),VY(IM1,J+1),DX) + VJ = FQUAD (VY(I,J),VY(I+1,J),VY(IM1,J),DX) + VJM1 = FQUAD (VY(I,J-1),VY(I+1,J-1),VY(IM1,J-1),DX) + DELY = FQUAD (VJ,VJP1,VJM1,DY) + RETURN + END + SUBROUTINE EZSTRM(U,V,WORK,IMAX,JMAX) +C + DIMENSION U(IMAX,JMAX) ,V(IMAX,JMAX) ,WORK(1) +C + SAVE +C +C THE FOLLOWING CALL IS FOR MONITORING LIBRARY USE AT NCAR +C + CALL Q8QST4 ( 'GRAPHX', 'STRMLN', 'EZSTRM', 'VERSION 01') +C + CALL STRMLN(U,V,WORK,IMAX,IMAX,JMAX,0,IER) + RETURN + END + SUBROUTINE CHKCYC (U,V,IMAX,JPTSY,IER) +C +C CHECK FOR CYCLIC CONDITION +C + DIMENSION U(IMAX,JPTSY) ,V(IMAX,JPTSY) + COMMON /STR01/ IS ,IEND ,JS ,JEND + 1 , IEND1 ,JEND1 ,I ,J + 2 , X ,Y ,DELX ,DELY + 3 , ICYC1 ,IMSG1 ,IGFL1 +C + SAVE + DO 10 J=JS,JEND + IF (U(IS,J).NE.U(IEND,J)) GO TO 20 + IF (V(IS,J).NE.V(IEND,J)) GO TO 20 + 10 CONTINUE +C +C MUST BE CYCLIC +C + RETURN + 20 CONTINUE +C +C MUST NOT BE CYCLIC +C . CHANGE THE PARAMETER AND SET IER = -1 +C + ICYC1 = 0 + IER = -1 + RETURN +C +C------------------------------------------------------------------ +C REVISION HISTORY +C +C OCTOBER 1979 FIRST ADDED TO ULIB +C +C OCTOBER 1980 ADDED BUGS SECTION +C +C JUNE 1984 REMOVED STATEMENT FUNCTIONS ANDF AND ORF, +C CONVERTED TO FORTRAN77 AND GKS. +C------------------------------------------------------------------- + END diff --git a/sys/gio/ncarutil/sysint/README b/sys/gio/ncarutil/sysint/README new file mode 100644 index 00000000..38d7b6f8 --- /dev/null +++ b/sys/gio/ncarutil/sysint/README @@ -0,0 +1,2 @@ +SYSINT - This directory contains the System Interface Routines needed +for implementing the GKS based NCAR plotting utilities. diff --git a/sys/gio/ncarutil/sysint/fencode.x b/sys/gio/ncarutil/sysint/fencode.x new file mode 100644 index 00000000..1e2e37d5 --- /dev/null +++ b/sys/gio/ncarutil/sysint/fencode.x @@ -0,0 +1,80 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +define SZ_FORMAT 11 + +# FENCD -- Format a real variable and return as a spp character string. +# A packed format string is passed as an input argument to define how the +# number is to be encoded. The format of the format string is: +# format string = "(cW.D)" +# where c is one of [EFGI], and where W and D are the field width and +# number of decimal places or precision, respectively. + +procedure fencd (nchars, f_format, spp_outstr, rval) + +int nchars # desired number of output chars +char f_format[SZ_FORMAT] # SPP string containing format +char spp_outstr[nchars+1] # SPP string containing encoded number +real rval # value to be encoded + +char fmtchar, outstr[MAX_DIGITS], spp_format[SZ_FORMAT+1] +int ip, op, stridxs() +real x + +begin + # Encode format string for SPRINTF, format "%w.d". Start copying + # Fortran format at char 3, which should follow the EFGI char. + + spp_format[1] = '%' + op = 2 + + if (f_format[1] != '(') + call fatal (1, "Missing lparen in Ncar ENCODE format") + for (ip=3; f_format[ip] != ')' && f_format[ip] != EOS; ip=ip+1) { + spp_format[op] = f_format[ip] + op = op + 1 + } + + # Now add the SPP format character. EFG are the same for sprintf as + # as for Fortran. The integer format is 'd' for decimal in SPP. + + fmtchar = f_format[2] + if (IS_UPPER(fmtchar)) + fmtchar = TO_LOWER (fmtchar) + + switch (fmtchar) { + case 'e', 'f', 'g': + spp_format[op] = fmtchar + case 'i': + spp_format[op] = 'd' + default: + call fatal (1, "Unknown Ncar ENCODE format code") + } + op = op + 1 + spp_format[op] = EOS + x = rval + if (rval > 0) + x = -x + + # Now encode the user supplied variable and return it as a spp + # string. + + iferr { + call sprintf (outstr, MAX_DIGITS, spp_format) + call pargr (x) + } then + call erract (EA_FATAL) + + # Let's try adding a "+" prefix to positive numbers to set if that + # makes nicer plots. Sep86 - This was not a good idea - changed to + # a blank. + + op = stridxs ("-", outstr) + if (rval > 0 && op > 0) + outstr[op] = ' ' + + call strcpy (outstr, spp_outstr, SZ_LINE) +end diff --git a/sys/gio/ncarutil/sysint/fulib.x b/sys/gio/ncarutil/sysint/fulib.x new file mode 100644 index 00000000..1951f26c --- /dev/null +++ b/sys/gio/ncarutil/sysint/fulib.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# FULIB -- Print an error message processed by fortran routine uliber. + +procedure fulib (errcode, upkmsg, msglen) + +int errcode +char upkmsg[ARB] # unpacked string +int msglen # number of chars in string + +pointer sp, sppmsg + +begin + call smark (sp) + call salloc (sppmsg, SZ_LINE, TY_CHAR) + + # Construct error message string + call sprintf (Memc[sppmsg], SZ_LINE, "ERROR %d IN %s\n") + call pargi (errcode) + call pargstr (upkmsg) + + # Call error with the constructed message + iferr (call error (errcode, Memc[sppmsg])) + call erract (EA_WARN) + + call sfree (sp) +end diff --git a/sys/gio/ncarutil/sysint/gbytes.x b/sys/gio/ncarutil/sysint/gbytes.x new file mode 100644 index 00000000..b129ffbc --- /dev/null +++ b/sys/gio/ncarutil/sysint/gbytes.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GBYTES -- Locally implemented bit unpacker for the NCAR extended metacode +# translator. 3 may 84 cliff stoll +# Required for the ncar/gks vdi metacode generator. +# +# Essentially this routine accepts an array which is a packed series of bits. +# [array BUFIN], and unpacks them into an array [array BUFOUT]. Received +# integer INDEX is the beginning bit in BUFIN where information is to be +# placed. INDEX is zero indexed. Received integer argument SIZE is the +# number of bits in each "information packet". Received argument SKIP is the +# number of bits to skip between bit packets. For more info, see page 4 of +# the NCAR "Implementaton details for the new metafile translator, version 1.0" + +procedure gbytes (bufin, bufout, index, size, skip, count) + +int bufout[ARB], bufin[ARB], index, size, skip, count +int pack +int offset +int bitupk() # Iraf function to unpack bits + +begin + for (pack = 1; pack <= count ; pack = pack+1) { + # Offset is a bit offset into the input buffer bufin. + # (offset is 1- indexed; INDEX is zero indexed) + + offset = (size + skip) * (pack - 1) + index + 1 + bufout(pack) = bitupk(bufin, offset, size) + } +end diff --git a/sys/gio/ncarutil/sysint/ishift.x b/sys/gio/ncarutil/sysint/ishift.x new file mode 100644 index 00000000..580996c0 --- /dev/null +++ b/sys/gio/ncarutil/sysint/ishift.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ISHIFT -- integer shift. To be used for calls to ISHIFT in NCAR routines. + +int procedure ishift (in_word, n) + +int in_word, n +int new_word, bit, index, i +int bitupk() + +begin + if (n > NBITS_INT) + call error (0, "n > NBITS_INT in ishift") + if (n < 0) + # Right end-off shift + new_word = bitupk (in_word, abs(n) + 1, NBITS_INT - abs(n)) + else { + # Left circular shift (rotate) + do i = 1, NBITS_INT { + index = n + i + if (index > NBITS_INT) + index = mod ((n + i), NBITS_INT) + bit = bitupk (in_word, i, 1) + call bitpak (bit, new_word, index, 1) + } + } + + return (new_word) +end + + +# IAND -- AND two integers. + +int procedure iand (a, b) + +int a, b +int and() + +begin + return (and (a, b)) +end + + +# IOR -- OR two integers. + +int procedure ior (a, b) + +int a, b +int or() + +begin + return (or (a, b)) +end diff --git a/sys/gio/ncarutil/sysint/mkpkg b/sys/gio/ncarutil/sysint/mkpkg new file mode 100644 index 00000000..f3ba6fb5 --- /dev/null +++ b/sys/gio/ncarutil/sysint/mkpkg @@ -0,0 +1,16 @@ +# Make the system interface for libncar.a. + +$checkout libncar.a lib$ +$update libncar.a +$checkin libncar.a lib$ +$exit + +libncar.a: + support.f + fencode.x + fulib.x + ishift.x + gbytes.x + sbytes.x + spps.f + ; diff --git a/sys/gio/ncarutil/sysint/sbytes.x b/sys/gio/ncarutil/sysint/sbytes.x new file mode 100644 index 00000000..4d4094c3 --- /dev/null +++ b/sys/gio/ncarutil/sysint/sbytes.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# SBYTES -- Locally implemented bit packer for the NCAR extended metacode +# translator. 3 may 84 cliff stoll +# Required for the ncar/gks vdi metacode generator. +# +# Essentially this routine accepts an array of "information packets" +# [array BUFIN], and packs them into a packed array [array BUFOUT] +# received integer argument INDEX points to the beginning bit in BUFOUT +# where information is to be placed. INDEX is zero indexed. +# received integer argument SIZE is the number of bits in each "information +# packet. received argument SKIP is the number of bits to skip between +# bit packets. For more info, see page 6 of the NCAR "Implementaton +# details for the new metafile translator, version 1.0" +# bufin is stuffed into bufout + +procedure sbytes (bufout, bufin, index, size, skip, count) + +int bufout[ARB], bufin[ARB], index, size, skip, count +int metacode_word_length +int pack +int offset + +data metacode_word_length / 16 / + +begin + if (metacode_word_length != NBITS_SHORT) + call error ( 0, " bad metacode word length in SBYTES") + + for (pack = 1; pack <= count; pack = pack + 1) { + # Offset is a bit offset into the output buffer bufout. + # (offset is 1- indexed; INDEX is zero indexed) + # see page 58 of IRAF system interface book + + offset = (size + skip) * (pack - 1) + index + 1 + call bitpak (bufin[pack], bufout, offset, size) + } +end diff --git a/sys/gio/ncarutil/sysint/spps.f b/sys/gio/ncarutil/sysint/spps.f new file mode 100644 index 00000000..4a394d9e --- /dev/null +++ b/sys/gio/ncarutil/sysint/spps.f @@ -0,0 +1,1797 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C + FUNCTION CFUX (RX) +C +C Given an x coordinate RX in the fractional system, CFUX(RX) is an x +C coordinate in the user system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=1 + IF (MI.GE.3) I=2 + CFUX=WD(I)+(RX-VP(1))/(VP(2)-VP(1))*(WD(3-I)-WD(I)) + IF (LL.GE.3) CFUX=10.**CFUX + RETURN + END + FUNCTION CFUY (RY) +C +C Given a y coordinate RY in the fractional system, CFUY(RY) is a y +C coordinate in the user system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=3 + IF (MI.EQ.2.OR.MI.GE.4) I=4 + CFUY=WD(I)+(RY-VP(3))/(VP(4)-VP(3))*(WD(7-I)-WD(I)) + IF (LL.EQ.2.OR.LL.GE.4) CFUY=10.**CFUY + RETURN + END + FUNCTION CMFX (IX) +C +C Given an x coordinate IX in the metacode system, CMFX(IX) is an x +C coordinate in the fractional system. +C + CMFX=FLOAT(IX)/32767. + RETURN + END + FUNCTION CMFY (IY) +C +C Given a y coordinate IY in the metacode system, CMFY(IY) is a y +C coordinate in the fractional system. +C + CMFY=FLOAT(IY)/32767. + RETURN + END + FUNCTION CMUX (IX) +C +C Given an x coordinate IX in the metacode system, CMUX(IX) is an x +C coordinate in the user system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=1 + IF (MI.GE.3) I=2 + CMUX=WD(I)+(FLOAT(IX)/32767.-VP(1))/(VP(2)-VP(1))*(WD(3-I)-WD(I)) + IF (LL.GE.3) CMUX=10.**CMUX + RETURN + END + FUNCTION CMUY (IY) +C +C Given a y coordinate IY in the metacode system, CMUY(IY) is a y +C coordinate in the user system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=3 + IF (MI.EQ.2.OR.MI.GE.4) I=4 + CMUY=WD(I)+(FLOAT(IY)/32767.-VP(3))/(VP(4)-VP(3))*(WD(7-I)-WD(I)) + IF (LL.EQ.2.OR.LL.GE.4) CMUY=10.**CMUY + RETURN + END + FUNCTION CPFX (IX) +C +C Given an x coordinate IX in the plotter system, CPFX(IX) is an x +C coordinate in the fractional system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + CPFX=FLOAT(IX-1)/(2.**MX-1.) + RETURN + END + FUNCTION CPFY (IY) +C +C Given a y coordinate IY in the plotter system, CPFY(IY) is a y +C coordinate in the fractional system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + CPFY=FLOAT(IY-1)/(2.**MY-1.) + RETURN + END + FUNCTION CPUX (IX) +C +C Given an x coordinate IX in the plotter system, CPUX(IX) is an x +C coordinate in the user system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=1 + IF (MI.GE.3) I=2 + CPUX=WD(I)+(FLOAT(IX-1)/(2.**MX-1.)-VP(1))/(VP(2)-VP(1))* + + (WD(3-I)-WD(I)) + IF (LL.GE.3) CPUX=10.**CPUX + RETURN + END + FUNCTION CPUY (IY) +C +C Given a y coordinate IY in the plotter system, CPUY(IY) is a y +C coordinate in the user system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=3 + IF (MI.EQ.2.OR.MI.GE.4) I=4 + CPUY=WD(I)+(FLOAT(IY-1)/(2.**MY-1.)-VP(3))/(VP(4)-VP(3))* + + (WD(7-I)-WD(I)) + IF (LL.EQ.2.OR.LL.GE.4) CPUY=10.**CPUY + RETURN + END + FUNCTION CUFX (RX) +C +C Given an x coordinate RX in the user system, CUFX(RX) is an x +C coordinate in the fractional system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=1 + IF (MI.GE.3) I=2 + IF (LL.LE.2) THEN + CUFX=(RX-WD(I))/(WD(3-I)-WD(I))*(VP(2)-VP(1))+VP(1) + ELSE + CUFX=(ALOG10(RX)-WD(I))/(WD(3-I)-WD(I))*(VP(2)-VP(1))+VP(1) + ENDIF + RETURN + END + FUNCTION CUFY (RY) +C +C Given a y coordinate RY in the user system, CUFY(RY) is a y +C coordinate in the fractional system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=3 + IF (MI.EQ.2.OR.MI.GE.4) I=4 + IF (LL.LE.1.OR.LL.EQ.3) THEN + CUFY=(RY-WD(I))/(WD(7-I)-WD(I))*(VP(4)-VP(3))+VP(3) + ELSE + CUFY=(ALOG10(RY)-WD(I))/(WD(7-I)-WD(I))*(VP(4)-VP(3))+VP(3) + ENDIF + RETURN + END + FUNCTION KFMX (RX) +C +C Given an x coordinate RX in the fractional system, KFMX(RX) is an x +C coordinate in the metacode system. +C + KFMX=IFIX(RX*32767.) + RETURN + END + FUNCTION KFMY (RY) +C +C Given a y coordinate RY in the fractional system, KFMY(RY) is a y +C coordinate in the metacode system. +C + KFMY=IFIX(RY*32767.) + RETURN + END + FUNCTION KFPX (RX) +C +C Given an x coordinate RX in the fractional system, KFPX(RX) is an x +C coordinate in the plotter system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + KFPX=1+IFIX(RX*(2.**MX-1.)) + RETURN + END + FUNCTION KFPY (RY) +C +C Given a y coordinate RY in the fractional system, KFPY(RY) is a y +C coordinate in the plotter system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + KFPY=1+IFIX(RY*(2.**MX-1.)) + RETURN + END + FUNCTION KMPX (IX) +C +C Given an x coordinate IX in the metacode system, KMPX(IX) is an x +C coordinate in the plotter system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + KMPX=1+IFIX((2.**MX-1.)*FLOAT(IX)/32767.) + RETURN + END + FUNCTION KMPY (IY) +C +C Given a y coordinate IY in the metacode system, KMPY(IY) is a y +C coordinate in the plotter system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + KMPY=1+IFIX((2.**MY-1.)*FLOAT(IY)/32767.) + RETURN + END + FUNCTION KPMX (IX) +C +C Given an x coordinate IX in the plotter system, KPMX(IX) is an x +C coordinate in the metacode system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + KPMX=IFIX(32767.*FLOAT(IX-1)/(2.**MX-1.)) + RETURN + END + FUNCTION KPMY (IY) +C +C Given a y coordinate IY in the plotter system, KPMY(IY) is a y +C coordinate in the metacode system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + KPMY=IFIX(32767.*FLOAT(IY-1)/(2.**MY-1.)) + RETURN + END + FUNCTION KUMX (RX) +C +C Given an x coordinate RX in the user system, KUMX(RX) is an x +C coordinate in the metacode system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=1 + IF (MI.GE.3) I=2 + IF (LL.LE.2) THEN + KUMX=IFIX(((RX-WD(I))/(WD(3-I)-WD(I))*(VP(2)-VP(1))+VP(1))* + + 32767.) + ELSE + KUMX=IFIX(((ALOG10(RX)-WD(I))/(WD(3-I)-WD(I))*(VP(2)-VP(1))+ + + VP(1))*32767.) + ENDIF + RETURN + END + FUNCTION KUMY (RY) +C +C Given a y coordinate RY in the user system, KUMY(RY) is a y +C coordinate in the metacode system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=3 + IF (MI.EQ.2.OR.MI.GE.4) I=4 + IF (LL.LE.1.OR.LL.EQ.3) THEN + KUMY=IFIX(((RY-WD(I))/(WD(7-I)-WD(I))*(VP(4)-VP(3))+VP(3))* + + 32767.) + ELSE + KUMY=IFIX(((ALOG10(RY)-WD(I))/(WD(7-I)-WD(I))*(VP(4)-VP(3))+ + + VP(3))*32767.) + ENDIF + RETURN + END + FUNCTION KUPX (RX) +C +C Given an x coordinate RX in the user system, KUPX(RX) is an x +C coordinate in the plotter system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=1 + IF (MI.GE.3) I=2 + IF (LL.LE.2) THEN + KUPX=1+IFIX(((RX-WD(I))/(WD(3-I)-WD(I))*(VP(2)-VP(1))+VP(1))* + + (2.**MX-1.)) + ELSE + KUPX=1+IFIX(((ALOG10(RX)-WD(I))/(WD(3-I)-WD(I))*(VP(2)-VP(1))+ + + VP(1))*(2.**MX-1.)) + ENDIF + RETURN + END + FUNCTION KUPY (RY) +C +C Given a y coordinate RY in the user system, KUPY(RY) is a y +C coordinate in the plotter system. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) + DIMENSION WD(4),VP(4) + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) + I=3 + IF (MI.EQ.2.OR.MI.GE.4) I=4 + IF (LL.LE.1.OR.LL.EQ.3) THEN + KUPY=1+IFIX(((RY-WD(I))/(WD(7-I)-WD(I))*(VP(4)-VP(3))+VP(3))* + + (2.**MY-1.)) + ELSE + KUPY=1+IFIX(((ALOG10(RY)-WD(I))/(WD(7-I)-WD(I))*(VP(4)-VP(3))+ + + VP(3))*(2.**MY-1.)) + ENDIF + RETURN + END + SUBROUTINE CLSGKS +C +C IU(6), in IUTLCM, is the current metacode unit number. +C + COMMON /IUTLCM/ IU(100) +C +C Deactivate the metacode workstation, close the workstation, and +C close GKS. +C + CALL GDAWK (IU(6)) + CALL GCLWK (IU(6)) + CALL GCLKS +C + RETURN +C + END + SUBROUTINE CURVE (PX,PY,NP) +C + DIMENSION PX(NP),PY(NP) +C +C CURVE draws the curve defined by the points (PX(I),PY(I)), for I = 1 +C to NP. All coordinates are stated in the user coordinate system. +C +C Define arrays to hold converted point coordinates when it becomes +C necessary to draw the curve piecewise. +C + DIMENSION QX(10),QY(10) +C +C If NP is less than or equal to zero, there's nothing to do. +C + IF (NP.LE.0) RETURN +C +C If NP is exactly equal to 1, just draw a point. +C + IF (NP.EQ.1) THEN + CALL POINT (PX(1),PY(1)) +C +C Otherwise, draw the curve. +C + ELSE +C +C Flush the pen-move buffer. +C + CALL PLOTIF (0.,0.,2) +C +C Save the current SET parameters. +C + CALL GETSET (F1,F2,F3,F4,F5,F6,F7,F8,LL) +C +C If the mapping defined by the last SET call was non-reversed and +C linear in both x and y, a single polyline will suffice. +C + IF (F5.LT.F6.AND.F7.LT.F8.AND.LL.EQ.1) THEN + CALL GPL (NP,PX,PY) +C +C Otherwise, piece the line together out of smaller chunks, converting +C the coordinates for each chunk as directed by the last SET call. +C + ELSE + DO 102 IP=1,NP,9 + NQ=MIN0(10,NP-IP+1) + IF (NQ.GE.2) THEN + DO 101 IQ=1,NQ + QX(IQ)=CUFX(PX(IP+IQ-1)) + QY(IQ)=CUFY(PY(IP+IQ-1)) + 101 CONTINUE + CALL SET (F1,F2,F3,F4,F1,F2,F3,F4,1) + CALL GPL (NQ,QX,QY) + CALL SET (F1,F2,F3,F4,F5,F6,F7,F8,LL) + END IF + 102 CONTINUE + END IF +C +C Update the pen position. +C + CALL FRSTPT (PX(NP),PY(NP)) +C + END IF +C +C Done. +C + RETURN +C + END + SUBROUTINE FL2INT (PX,PY,IX,IY) +C +C Given the user coordinates PX and PY of a point, FL2INT returns the +C metacode coordinates IX and IY of that point. +C +C Declare the common block containing the user state variables LL, MI, +C MX, and MY. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) +C +C Declare arrays in which to retrieve the variables defining the current +C window and viewport. +C + DIMENSION WD(4),VP(4) +C +C Get the variables defining the current window and viewport. +C + CALL GQCNTN (IE,NT) + CALL GQNT (NT,IE,WD,VP) +C +C Compute IX. +C + I=1 + IF (MI.GE.3) I=2 + IF (LL.LE.2) THEN + IX=IFIX(((PX-WD(I))/(WD(3-I)-WD(I))*(VP(2)-VP(1))+VP(1))*32767.) + ELSE + IX=IFIX(((ALOG10(PX)-WD(I))/(WD(3-I)-WD(I))* + + (VP(2)-VP(1))+VP(1))*32767.) + ENDIF +C +C Compute IY. +C + I=3 + IF (MI.EQ.2.OR.MI.GE.4) I=4 + IF (LL.LE.1.OR.LL.EQ.3) THEN + IY=IFIX(((PY-WD(I))/(WD(7-I)-WD(I))*(VP(4)-VP(3))+VP(3))*32767.) + ELSE + IY=IFIX(((ALOG10(PY)-WD(I))/(WD(7-I)-WD(I))* + + (VP(4)-VP(3))+VP(3))*32767.) + ENDIF +C +C Done. +C + RETURN +C + END +C +C +NOAO - name conflict +C +C SUBROUTINE FLUSH + subroutine mcflsh +C +C - NOAO +C +C FLUSH currently does nothing except flush the pen-move buffer. +C + CALL PLOTIF (0.,0.,2) +C +C Done. +C + RETURN +C + END + SUBROUTINE FRAME +C +C FRAME is intended to advance to a new frame. The GKS version clears +C all open workstations. +C +C First, flush the pen-move buffer. +C + CALL PLOTIF (0.,0.,2) +C +C +NOAO - Initialize utilbd 'first' flag for next plot + call initut +C +C - NOAO +C Get the number of open workstations. If there are none, we're done. +C + CALL GQOPWK (0,IE,NO,ID) + IF (NO.EQ.0) RETURN +C +C Otherwise, clear the open workstations. +C + DO 101 I=1,NO + CALL GQOPWK (I,IE,NO,ID) + CALL GCLRWK (ID,1) + 101 CONTINUE +C +C Done. +C + RETURN +C + END + SUBROUTINE FRSTPT (PX,PY) +C +C Given the user coordinates PX and PY of a point, FRSTPT generates a +C pen-up move to that point. +C + CALL PLOTIF (CUFX(PX),CUFY(PY),0) +C +C Done. +C + RETURN +C + END + SUBROUTINE GETSET (VL,VR,VB,VT,WL,WR,WB,WT,LF) +C +C GETSET returns to its caller the current values of the parameters +C defining the mapping from the user system to the fractional system +C (in GKS terminology, the mapping from world coordinates to normalized +C device coordinates). +C +C VL, VR, VB, and VT define the viewport (in the fractional system), WL, +C WR, WB, and WT the window (in the user system), and LF the nature of +C the mapping, according to the following table: +C +C 1 - x linear, y linear +C 2 - x linear, y logarithmic +C 3 - x logarithmic, y linear +C 4 - x logarithmic, y logarithmic +C +C Declare the common block containing the linear-log and mirror-imaging +C flags. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) +C +C Define variables to receive the GKS viewport and window. +C + DIMENSION VP(4),WD(4) +C +C Retrieve the number of the current GKS normalization transformation. +C + CALL GQCNTN (IE,NT) +C +C Retrieve the definition of that normalization transformation. +C + CALL GQNT (NT,IE,WD,VP) +C +C Pass the viewport definition to the caller. +C + VL=VP(1) + VR=VP(2) + VB=VP(3) + VT=VP(4) +C +C Pass the linear/log flag and a (possibly modified) window definition +C to the caller. +C + LF=LL +C + IF (LL.EQ.1.OR.LL.EQ.2) THEN + WL=WD(1) + WR=WD(2) + ELSE + WL=10.**WD(1) + WR=10.**WD(2) + END IF +C + IF (MI.GE.3) THEN + WW=WL + WL=WR + WR=WW + END IF +C + IF (LL.EQ.1.OR.LL.EQ.3) THEN + WB=WD(3) + WT=WD(4) + ELSE + WB=10.**WD(3) + WT=10.**WD(4) + END IF +C + IF (MI.EQ.2.OR.MI.GE.4) THEN + WW=WB + WB=WT + WT=WW + END IF +C + RETURN +C + END + SUBROUTINE GETSI (IX,IY) +C +C Return to the user the parameters which determine the assumed size of +C the target plotter and therefore determine how user coordinates are +C to be mapped into plotter coordinates. +C +C Declare the common block containing the scaling information. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) +C +C Set the user variables. + + IX=MX + IY=MY +C + RETURN +C + END + SUBROUTINE GETUSV (VN,IV) + CHARACTER*(*) VN +C +C This subroutine retrieves the current values of the utility state +C variables. VN is the character name of the variable and IV is +C its value. +C +C The labelled common block IUTLCM contains all of the utility state +C variables. +C + COMMON /IUTLCM/IU(100) +C +C Check for the linear-log scaling variable. +C + IF (VN(1:2).EQ.'LS') THEN + IV=IU(1) +C +C Check for the variable specifying the mirror-imaging of the axes. +C + ELSE IF (VN(1:2).EQ.'MI') THEN + IV=IU(2) +C +C Check for the variable specifying the resolution of the plotter in x. +C + ELSE IF (VN(1:2).EQ.'XF') THEN + IV=IU(3) +C +C Check for the variable specifying the resolution of the plotter in x. +C + ELSE IF (VN(1:2).EQ.'YF') THEN + IV=IU(4) +C +C Check for the variable specifying the size of the pen-move buffer. +C + ELSE IF (VN(1:2).EQ.'PB') THEN + IV=IU(5) +C +C Check for the variable specifying the metacode unit. +C + ELSE IF (VN(1:2).EQ.'MU') THEN + IV=IU(6) +C +C Check for one of the variables specifying color and intensity. +C + ELSE IF (VN(1:2).EQ.'IR') THEN + IV=IU(7) +C + ELSE IF (VN(1:2).EQ.'IG') THEN + IV=IU(8) +C + ELSE IF (VN(1:2).EQ.'IB') THEN + IV=IU(9) +C + ELSE IF (VN(1:2).EQ.'IN') THEN + IV=IU(10) +C +C Check for the variable specifying the current color index. +C + ELSE IF (VN(1:2).EQ.'II') THEN + IV=IU(11) +C +C Check for the variable specifying the maximum color index. +C + ELSE IF (VN(1:2).EQ.'IM') THEN + IV=IU(12) +C +C Check for the variable specifying the line width scale factor. +C + ELSE IF (VN(1:2).EQ.'LW') THEN + IV=IU(13) +C +C Check for the variable specifying the marker size scale factor. +C + ELSE IF (VN(1:2).EQ.'MS') THEN + IV=IU(14) +C +C Otherwise, the variable name is unknown. +C + ELSE + CALL SETER ('GETUSV - UNKNOWN VARIABLE NAME IN CALL',1,2) +C + ENDIF +C + RETURN +C + END + SUBROUTINE LINE (X1,Y1,X2,Y2) +C +C Draw a line connecting the point (X1,Y1) to the point (X2,Y2), in the +C user coordinate system. +C + CALL PLOTIF (CUFX(X1),CUFY(Y1),0) + CALL PLOTIF (CUFX(X2),CUFY(Y2),1) + RETURN + END + SUBROUTINE MXMY (IX,IY) +C +C Return to the user the coordinates of the current pen position, in the +C plotter coordinate system. +C +C In the common block PLTCM are recorded the coordinates of the last +C pen position, in the metacode coordinate system. +C + COMMON /PLTCM/ JX,JY +C +C Declare the common block containing the user state variables LL, MI, +C MX, and MY. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) +C +C Return to the user the plotter-system equivalents of the values in +C the metacode system. +C + IX=1+IFIX((2.**MX-1.)*FLOAT(JX)/32767.) + IY=1+IFIX((2.**MY-1.)*FLOAT(JY)/32767.) +C +C Done. +C + RETURN +C + END +C +C + NOAO - Following subroutine +C SUBROUTINE OPNGKS +C +C IU(6), in IUTLCM, is the current metacode unit number. +C +C COMMON /IUTLCM/ IU(100) +C +C Force all required BLOCKDATA's to load. +C +C EXTERNAL GKSBD,G01BKD,UERRBD,UTILBD +C +C GKS buffer size (a dummy for NCAR GKS.) +C +C DATA ISZ /0/ +C +C Open GKS, define a workstation, and activate the workstation. +C +C CALL GOPKS (6,ISZ) +C CALL GOPWK (IU(6),2,1) +C CALL GACWK (IU(6)) +C +C RETURN +C +C + NOAO +C +C END + SUBROUTINE PLOTIF (FX,FY,IP) +C +C Move the pen to the point (FX,FY), in the fractional cooordinate +C system. If IP is zero, do a pen-up move. If IP is one, do a pen-down +C move. If IP is two, flush the buffer. +C +C The variable IU(5), in the labelled common block IUTLCM, specifies +C the size of the pen-move buffer (between 2 and 50). +C + COMMON /IUTLCM/ IU(100) +C +C The common block VCTSEQ contains variables implementing the buffering +C of pen moves. +C + COMMON /VCTSEQ/ NQ,QX(50),QY(50),NF,IF(25) +C +C In the common block PLTCM are recorded the coordinates of the last +C pen position, in the metacode coordinate system, for MXMY. +C + COMMON /PLTCM/ JX,JY +C +C Force loading of the block data routine which initializes the contents +C of the common blocks. +C +C EXTERNAL UTILBD +C +C VP and WD hold viewport and window parameters obtained, when needed, +C from GKS. +C + DIMENSION VP(4),WD(4) +C +C + NOAO - block data utilbd has been rewritten as a run time initialization +C + call utilbd +C +C - NOAO +C Check for out-of-range values of the pen parameter. +C + IF (IP.LT.0.OR.IP.GT.2) THEN + CALL SETER ('PLOTIF - ILLEGAL VALUE FOR IPEN',1,2) + END IF +C +C If a buffer flush is requested, jump. +C + IF (IP.EQ.2) GO TO 101 +C +C Limit the given coordinates to the legal fractional range. +C + GX=AMAX1(0.,AMIN1(1.,FX)) + GY=AMAX1(0.,AMIN1(1.,FY)) +C +C Set JX and JY for a possible call to MXMY. +C + JX=KFMX(GX) + JY=KFMY(GY) +C +C If the current move is a pen-down move, or if the last one was, bump +C the pointer into the coordinate arrays and, if the current move is +C a pen-up move, make a new entry in the array IF, which records the +C positions of the pen-up moves. Note that we never get two pen-up +C moves in a row, which means that IF need be dimensioned only half as +C large as QX and QY. +C + IF (IP.NE.0.OR.IF(NF).NE.NQ) THEN + NQ=NQ+1 + IF (IP.EQ.0) THEN + NF=NF+1 + IF(NF)=NQ + END IF + END IF +C +C Save the coordinates of the point, in the fractional coordinate +C system. +C + QX(NQ)=GX + QY(NQ)=GY +C +C If the point-coordinate buffer is full, dump the buffers; otherwise, +C return. +C + IF (NQ.LT.IU(5)) RETURN +C +C Dump the buffers. If NQ is one, there's nothing to dump. All that's +C there is a single pen-up move. +C + 101 IF (NQ.LE.1) RETURN +C +C Get NT, the number of the current transformation, and, if it is not +C zero, modify the current transformation so that we can use fractional +C coordinates (normalized device coordinates, in GKS terms). +C + CALL GQCNTN (IE,NT) + IF (NT.NE.0) THEN + CALL GQNT (NT,IE,WD,VP) + CALL GSWN (NT,VP(1),VP(2),VP(3),VP(4)) + END IF +C +C Dump out a series of polylines, each one defined by a pen-up move and +C a series of pen-down moves. +C + DO 102 I=1,NF-1 + CALL GPL (IF(I+1)-IF(I),QX(IF(I)),QY(IF(I))) + 102 CONTINUE + IF (IF(NF).NE.NQ) CALL GPL (NQ-IF(NF)+1,QX(IF(I)),QY(IF(I))) +C +C Put the current transformation back the way it was. +C + IF (NT.NE.0) THEN + CALL GSWN (NT,WD(1),WD(2),WD(3),WD(4)) + END IF +C +C Move the last pen position to the beginning of the buffer and pretend +C there was a pen-up move to that position. +C + QX(1)=QX(NQ) + QY(1)=QY(NQ) + NQ=1 + IF(1)=1 + NF=1 +C +C Done. +C + RETURN +C + END + SUBROUTINE PLOTIT (IX,IY,IP) +C +C Move the pen to the point (IX,IY), in the metacode coordinate system. +C If IP is zero, do a pen-up move. If IP is one, do a pen-down move. +C If IP is two, flush the buffer. (For the sake of efficiency, the +C moves are buffered; "CALL PLOTIT (0,0,0)" will also flush the buffer.) +C +C The variable IU(5), in the labelled common block IUTLCM, specifies +C the size of the pen-move buffer (between 2 and 50). +C + COMMON /IUTLCM/ IU(100) +C +C The common block VCTSEQ contains variables implementing the buffering +C of pen moves. +C + COMMON /VCTSEQ/ NQ,QX(50),QY(50),NF,IF(25) +C +C In the common block PLTCM are recorded the coordinates of the last +C pen position, in the metacode coordinate system, for MXMY. +C + COMMON /PLTCM/ JX,JY +C +C Force loading of the block data routine which initializes the contents +C of the common blocks. +C +C EXTERNAL UTILBD +C +C VP and WD hold viewport and window parameters obtained, when needed, +C from GKS. +C + DIMENSION VP(4),WD(4) +C +C + NOAO - Blockdata utilbd has been rewritten as a run time initialization +C + call utilbd +C +C - NOAO +C Check for out-of-range values of the pen parameter. +C + IF (IP.LT.0.OR.IP.GT.2) THEN + CALL SETER ('PLOTIT - ILLEGAL VALUE FOR IPEN',1,2) + END IF +C +C If a buffer flush is requested, jump. +C + IF (IP.EQ.2) GO TO 101 +C +C Limit the given coordinates to the legal metacode range. +C + JX=MAX0(0,MIN0(32767,IX)) + JY=MAX0(0,MIN0(32767,IY)) +C +C If the current move is a pen-down move, or if the last one was, bump +C the pointer into the coordinate arrays and, if the current move is +C a pen-up move, make a new entry in the array IF, which records the +C positions of the pen-up moves. Note that we never get two pen-up +C moves in a row, which means that IF need be dimensioned only half as +C large as QX and QY. +C + IF (IP.NE.0.OR.IF(NF).NE.NQ) THEN + NQ=NQ+1 + IF (IP.EQ.0) THEN + NF=NF+1 + IF(NF)=NQ + END IF + END IF +C +C Save the coordinates of the point, in the fractional coordinate +C system. +C + QX(NQ)=FLOAT(JX)/32767. + QY(NQ)=FLOAT(JY)/32767. +C +C If all three arguments were zero, or if the point-coordinate buffer +C is full, dump the buffers; otherwise, return. +C + IF (IX.EQ.0.AND.IY.EQ.0.AND.IP.EQ.0) GO TO 101 + IF (NQ.LT.IU(5)) RETURN +C +C Dump the buffers. If NQ is one, there's nothing to dump. All that's +C there is a single pen-up move. +C + 101 IF (NQ.LE.1) RETURN +C +C Get NT, the number of the current transformation, and, if it is not +C zero, modify the current transformation so that we can use fractional +C coordinates (normalized device coordinates, in GKS terms). +C + CALL GQCNTN (IE,NT) + IF (NT.NE.0) THEN + CALL GQNT (NT,IE,WD,VP) + CALL GSWN (NT,VP(1),VP(2),VP(3),VP(4)) + END IF +C +C Dump out a series of polylines, each one defined by a pen-up move and +C a series of pen-down moves. +C + DO 102 I=1,NF-1 + CALL GPL (IF(I+1)-IF(I),QX(IF(I)),QY(IF(I))) + 102 CONTINUE + IF (IF(NF).NE.NQ) CALL GPL (NQ-IF(NF)+1,QX(IF(I)),QY(IF(I))) +C +C Put the current transformation back the way it was. +C + IF (NT.NE.0) THEN + CALL GSWN (NT,WD(1),WD(2),WD(3),WD(4)) + END IF +C +C Move the last pen position to the beginning of the buffer and pretend +C there was a pen-up move to that position. +C + QX(1)=QX(NQ) + QY(1)=QY(NQ) + NQ=1 + IF(1)=1 + NF=1 +C +C Done. +C + RETURN +C + END + SUBROUTINE POINT (PX,PY) +C +C Draws a point at (PX,PY), defined in the user coordinate system. +C + CALL PLOTIF (CUFX(PX),CUFY(PY),0) + CALL PLOTIF (CUFX(PX),CUFY(PY),1) + RETURN + END + SUBROUTINE POINTS (PX,PY,NP,IC,IL) + DIMENSION PX(NP),PY(NP) +C +C Marks the points at positions in the user coordinate system defined +C by ((PX(I),PY(I)),I=1,NP). If IC is zero, each point is marked with +C a simple point. If IC is positive, each point is marked with the +C single character defined by the FORTRAN-77 function CHAR(IC). If IC +C is negative, each point is marked with a GKS polymarker of type -IC. +C If IL is non-zero, a curve is also drawn, connecting the points. +C +C Define arrays to hold converted point coordinates when it becomes +C necessary to mark the points a few at a time. +C + DIMENSION QX(10),QY(10) +C +C Define an array to hold the aspect source flags which may need to be +C retrieved from GKS. +C + DIMENSION LA(13) + CHARACTER*1 CHRTMP +C +C If the number of points is zero or negative, there's nothing to do. +C + IF (NP.LE.0) RETURN +C +C Otherwise, flush the pen-move buffer. +C + CALL PLOTIF (0.,0.,2) +C +C Retrieve the parameters from the last SET call. +C + CALL GETSET (F1,F2,F3,F4,F5,F6,F7,F8,LL) +C +C If a linear-linear, non-mirror-imaged, mapping is being done and the +C GKS polymarkers can be used, all the points can be marked with a +C single polymarker call and joined, if requested, by a single polyline +C call. +C + IF (F5.LT.F6.AND.F7.LT.F8.AND.LL.EQ.1.AND.IC.LE.0) THEN + CALL GQASF (IE,LA) + IF (LA(4).EQ.0) THEN + CALL GQPMI (IE,IN) + CALL GSPMI (MAX0(-IC,1)) + CALL GPM (NP,PX,PY) + CALL GSPMI (IN) + ELSE + CALL GQMK (IE,IN) + CALL GSMK (MAX0(-IC,1)) + CALL GPM (NP,PX,PY) + CALL GSMK (IN) + END IF + IF (IL.NE.0.AND.NP.GE.2) CALL GPL (NP,PX,PY) +C +C Otherwise, things get complicated. We have to do batches of nine +C points at a time. (Actually, we convert ten coordinates at a time, +C so that the curve joining the points, if any, won't have gaps in it.) +C + ELSE +C +C Initially, we have to reset either the polymarker index or the text +C alignment, depending on how we're marking the points. +C + IF (IC.LE.0) THEN + CALL GQASF (IE,LA) + IF (LA(4).EQ.0) THEN + CALL GQPMI (IE,IN) + CALL GSPMI (MAX0(-IC,1)) + ELSE + CALL GQMK (IE,IN) + CALL GSMK (MAX0(-IC,1)) + END IF + ELSE + CALL GQTXAL (IE,IH,IV) + CALL GSTXAL (2,3) + END IF +C +C Loop through the points by nines. +C + DO 104 IP=1,NP,9 +C +C Fill the little point coordinate arrays with up to ten values, +C converting them from the user system to the fractional system. +C + NQ=MIN0(10,NP-IP+1) + MQ=MIN0(9,NQ) + DO 102 IQ=1,NQ + QX(IQ)=CUFX(PX(IP+IQ-1)) + QY(IQ)=CUFY(PY(IP+IQ-1)) + 102 CONTINUE +C +C Change the SET call to allow the use of fractional coordinates. +C + CALL SET (F1,F2,F3,F4,F1,F2,F3,F4,1) +C +C Crank out either a polymarker or a set of characters. +C + IF (IC.LE.0) THEN + CALL GPM (MQ,QX,QY) + ELSE + DO 103 IQ=1,MQ + CHRTMP = CHAR(IC) + CALL GTX (QX(IQ),QY(IQ),CHRTMP) + 103 CONTINUE + END IF + IF (IL.NE.0.AND.NQ.GE.2) CALL GPL (NQ,QX,QY) +C +C Put the SET parameters back the way they were. +C + CALL SET (F1,F2,F3,F4,F5,F6,F7,F8,LL) +C + 104 CONTINUE +C +C Finally, we put either the polymarker index or the text alignment +C back the way it was. +C + IF (IC.LE.0) THEN + IF (LA(4).EQ.0) THEN + CALL GSPMI (IN) + ELSE + CALL GSMK (IN) + END IF + ELSE + CALL GSTXAL (IH,IV) + END IF +C + END IF +C +C Update the pen position. +C + CALL FRSTPT (PX(NP),PY(NP)) +C +C Done. +C + RETURN +C + END + SUBROUTINE PWRIT (PX,PY,CH,NC,IS,IO,IC) + CHARACTER*(*) CH +C +C PWRIT is called to draw a character string in a specified position. +C It is just like WTSTR, but has one extra argument. NC is the number +C of characters to be written from the string CH. +C + CALL WTSTR (PX,PY,CH(1:NC),IS,IO,IC) +C +C Done. +C + RETURN +C + END + SUBROUTINE SET (VL,VR,VB,VT,WL,WR,WB,WT,LF) +C +C SET allows the user to change the current values of the parameters +C defining the mapping from the user system to the fractional system +C (in GKS terminology, the mapping from world coordinates to normalized +C device coordinates). +C +C VL, VR, VB, and VT define the viewport (in the fractional system), WL, +C WR, WB, and WT the window (in the user system), and LF the nature of +C the mapping, according to the following table: +C +C 1 - x linear, y linear +C 2 - x linear, y logarithmic +C 3 - x logarithmic, y linear +C 4 - x logarithmic, y logarithmic +C +C Declare the common block containing the linear-log and mirror-imaging +C flags. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) +C +C Flush the pen-move buffer. +C + CALL PLOTIF (0.,0.,2) +C +C Set the GKS viewport for transformation 1. +C + CALL GSVP (1,VL,VR,VB,VT) +C +C Set the utility state variable controlling linear-log mapping. +C + LL=MAX0(1,MIN0(4,LF)) +C +C Set the GKS window for transformation 1. +C + IF (WL.LT.WR) THEN + MI=1 + QL=WL + QR=WR + ELSE + MI=3 + QL=WR + QR=WL + END IF +C + IF (WB.LT.WT) THEN + QB=WB + QT=WT + ELSE + MI=MI+1 + QB=WT + QT=WB + END IF +C + IF (LL.EQ.1) THEN + CALL GSWN (1,QL,QR,QB,QT) + ELSE IF (LL.EQ.2) THEN + CALL GSWN (1,QL,QR,ALOG10(QB),ALOG10(QT)) + ELSE IF (LL.EQ.3) THEN + CALL GSWN (1,ALOG10(QL),ALOG10(QR),QB,QT) + ELSE + CALL GSWN (1,ALOG10(QL),ALOG10(QR),ALOG10(QB),ALOG10(QT)) + END IF +C +C Select transformation 1 as the current one. +C + CALL GSELNT (1) +C + RETURN +C + END + SUBROUTINE SETI (IX,IY) +C +C Allows the user to set the parameters which determine the assumed size +C of the target plotter and therefore determine how user coordinates are +C to be mapped into plotter coordinates. +C +C Declare the common block containing the scaling information. +C + COMMON /IUTLCM/ LL,MI,MX,MY,IU(96) +C +C Transfer the user's values into the common block. +C + MX=MAX0(1,MIN0(15,IX)) + MY=MAX0(1,MIN0(15,IY)) +C + RETURN +C + END + SUBROUTINE SETUSV (VN,IV) + CHARACTER*(*) VN +C +C This subroutine sets the values of various utility state variables. +C VN is the name of the variable and IV is its value. +C +C The labelled common block IUTLCM contains all of the utility state +C variables. +C + COMMON /IUTLCM/ IU(100) +C +C Define an array in which to get the GKS aspect source flags. +C + DIMENSION LF(13) +C +C Check for the linear-log scaling variable, which can take on these +C values: +C +C 1 = X linear, Y linear +C 2 = X linear, Y log +C 3 = X log , Y linear +C 4 = X log , Y log +C + IF (VN(1:2).EQ.'LS') THEN + IF (IV.LT.1.OR.IV.GT.4) THEN + CALL SETER ('SETUSV - LOG SCALE VALUE OUT OF RANGE',2,2) + END IF + IU(1)=IV +C +C Check for the mirror-imaging variable, which can take on these +C values: +C +C 1 = X normal , Y normal +C 2 = X normal , Y reversed +C 3 = X reversed, Y normal +C 4 = X reversed, Y reversed +C + ELSE IF (VN(1:2).EQ.'MI') THEN + IF (IV.LT.1.OR.IV.GT.4) THEN + CALL SETER ('SETUSV - MIRROR-IMAGING VALUE OUT OF RANGE',3,2) + END IF + IU(2)=IV +C +C Check for the scale factor setting the resolution of the plotter in +C the x direction. +C + ELSE IF (VN(1:2).EQ.'XF') THEN + IF (IV.LT.1.OR.IV.GT.15) THEN + CALL SETER ('SETUSV - X RESOLUTION OUT OF RANGE',4,2) + END IF + IU(3)=IV +C +C Check for the scale factor setting the resolution of the plotter in +C the y direction. +C + ELSE IF (VN(1:2).EQ.'YF') THEN + IF (IV.LT.1.OR.IV.GT.15) THEN + CALL SETER ('SETUSV - Y RESOLUTION OUT OF RANGE',5,2) + END IF + IU(4)=IV +C +C Check for the variable specifying the size of the pen-move buffer. +C + ELSE IF (VN(1:2).EQ.'PB') THEN + IF (IV.LT.2.OR.IV.GT.50) THEN + CALL SETER ('SETUSV - PEN-MOVE BUFFER SIZE OUT OF RANGE',6,2) + END IF + CALL PLOTIF (0.,0.,2) + IU(5)=IV +C +C Check for a metacode unit number. +C + ELSE IF (VN(1:2).EQ.'MU') THEN + IF (IV.LE.0) THEN + CALL SETER ('SETUSV - METACODE UNIT NUMBER ILLEGAL',7,2) + END IF +C +C For the moment (1/11/85), we have to deactivate and close the old +C workstation and open and activate a new one. This does allow the +C user to break up his metacode output. It does not necessarily allow +C for the resumption of output to a previously-written metacode file. +C + CALL GDAWK (IU(6)) + CALL GCLWK (IU(6)) + IU(6)=IV + CALL GOPWK (IU(6),2,1) + CALL GACWK (IU(6)) +C +C If, in the future, it becomes possible to have more than one metacode +C workstation open at once, the following code can be used instead. +C +C CALL GDAWK (IU(6)) +C IU(6)=IV +C CALL GQOPWK (0,IE,NO,ID) +C IF (NO.NE.0) THEN +C DO 101 I=1,NO +C CALL GQOPWK (I,IE,NO,ID) +C IF (ID.EQ.IU(6)) GO TO 102 +C 101 CONTINUE +C END IF +C CALL GOPWK (IU(6),2,1) +C 102 CALL GAWK (IU(6)) +C +C Check for one of the variables setting color and intensity. +C + ELSE IF (VN(1:2).EQ.'IR') THEN + IF (IV.LT.0) THEN + CALL SETER ('SETUSV - ILLEGAL VALUE OF RED INTENSITY',8,2) + END IF + IU(7)=IV +C + ELSE IF (VN(1:2).EQ.'IG') THEN + IF (IV.LT.0) THEN + CALL SETER ('SETUSV - ILLEGAL VALUE OF GREEN INTENSITY',9,2) + END IF + IU(8)=IV +C + ELSE IF (VN(1:2).EQ.'IB') THEN + IF (IV.LT.0) THEN + CALL SETER ('SETUSV - ILLEGAL VALUE OF BLUE INTENSITY',10,2) + END IF + IU(9)=IV +C + ELSE IF (VN(1:2).EQ.'IN') THEN + IF (IV.LT.0.OR.IV.GT.10000) THEN + CALL SETER ('SETUSV - ILLEGAL VALUE OF INTENSITY',11,2) + END IF + IU(10)=IV +C +C Assign the intensity-controlling variables to local variables with +C simple, meaningful names. +C + IR=IU(7) + IG=IU(8) + IB=IU(9) + IN=IU(10) + II=IU(11) + IM=IU(12) +C +C Compute the floating-point red, green, and blue intensities. +C + FR=FLOAT(IR)/FLOAT(MAX0(IR,IG,IB,1))*FLOAT(IN)/10000. + FG=FLOAT(IG)/FLOAT(MAX0(IR,IG,IB,1))*FLOAT(IN)/10000. + FB=FLOAT(IB)/FLOAT(MAX0(IR,IG,IB,1))*FLOAT(IN)/10000. +C +C Dump the pen-move buffer before changing anything. +C + CALL PLOTIF (0.,0.,2) +C +C Set the aspect source flags for all the color indices to "individual". +C + CALL GQASF (IE,LF) + LF( 3)=1 + LF( 6)=1 + LF(10)=1 + LF(13)=1 + CALL GSASF (LF) +C +C Pick a new color index and use it for polylines, polymarkers, text, +C and areas. +C + II=MOD(II,IM)+1 + IU(11)=II + CALL GSPLCI (II) + CALL GSPMCI (II) + CALL GSTXCI (II) + CALL GSFACI (II) +C +C Now, redefine the color for that color index on each open workstation. +C + CALL GQOPWK (0,IE,NO,ID) +C + DO 103 I=1,NO + CALL GQOPWK (I,IE,NO,ID) + CALL GSCR (ID,II,FR,FG,FB) + 103 CONTINUE +C +C Check for variable resetting the color index. +C + ELSE IF (VN(1:2).EQ.'II') THEN + IF (IV.LT.1.OR.IV.GT.IU(12)) THEN + CALL SETER ('SETUSV - ILLEGAL COLOR INDEX',12,2) + END IF + IU(11)=IV +C + CALL PLOTIF (0.,0.,2) +C + CALL GQASF (IE,LF) + LF( 3)=1 + LF( 6)=1 + LF(10)=1 + LF(13)=1 + CALL GSASF (LF) +C + CALL GSPLCI (IV) + CALL GSPMCI (IV) + CALL GSTXCI (IV) + CALL GSFACI (IV) +C +C Check for the variable limiting the values of color index used. +C + ELSE IF (VN(1:2).EQ.'IM') THEN + IF (IV.LT.1) THEN + CALL SETER ('SETUSV - ILLEGAL MAXIMUM COLOR INDEX',13,2) + END IF + IU(12)=IV +C +C Check for the variable setting the current line width scale factor. +C + ELSE IF (VN(1:2).EQ.'LW') THEN + IF (IV.LT.0) THEN + CALL SETER ('SETUSV - ILLEGAL LINE WIDTH SCALE FACTOR',14,2) + END IF + IU(13)=IV +C +C Dump the pen-move buffer before changing anything. +C + CALL PLOTIF (0.,0.,2) +C +C Set the aspect source flag for linewidth scale factor to "individual". +C + CALL GQASF (IE,LF) + LF(2)=1 + CALL GSASF (LF) +C +C Redefine the line width scale factor. +C + CALL GSLWSC (FLOAT(IV)/1000.) +C +C Check for the variable setting the current marker size scale factor. +C + ELSE IF (VN(1:2).EQ.'MS') THEN + IF (IV.LT.0) THEN + CALL SETER ('SETUSV - ILLEGAL MARKER SIZE SCALE FACTOR',15,2) + END IF + IU(14)=IV +C +C Set aspect source flag for marker size scale factor to "individual". +C + CALL GQASF (IE,LF) + LF(5)=1 + CALL GSASF (LF) +C +C Redefine the marker size scale factor. +C + CALL GSMKSC (FLOAT(IV)/1000.) +C +C Otherwise, the variable name is unknown. +C + ELSE + CALL SETER ('SETUSV - UNKNOWN VARIABLE NAME IN CALL',1,2) +C + ENDIF + RETURN + END + SUBROUTINE VECTOR (PX,PY) +C +C Draw a vector (line segment) from the current pen position to the new +C pen position (PX,PY), in the user coordinate system, and then make +C (PX,PY) the current pen position. +C + CALL PLOTIF (CUFX(PX),CUFY(PY),1) + RETURN + END + SUBROUTINE WTSTR (PX,PY,CH,IS,IO,IC) +C +C WTSTR is called to draw a character string in a specified position. +C +C PX and PY specify, in user coordinates, the position of a point +C relative to which a character string is to be positioned. +C +C CH is the character string to be written. +C +C IS is the desired size of the characters to be used, stated as a +C character width in the plotter coordinate system. The values 0, 1, +C 2, and 3 mean 8, 12, 16, and 24, respectively. +C +C IO is the desired orientation angle, in degrees counterclockwise from +C a horizontal vector pointing to the right. +C +C IC specifies the desired type of centering. A negative value puts +C (PX,PY) in the center of the left end of the character string, a zero +C puts (PX,PY) in the center of the whole string, and a positive value +C puts (PX,PY) in the center of the right end of the character string. +C + CHARACTER*(*) CH +C +C Define arrays in which to save the current viewport and window. +C + DIMENSION VP(4),WD(4) +C +C Flush the pen-move buffer. +C + CALL PLOTIF (0.,0.,2) +C +C Compute the coordinates of (PX,PY) in the fractional coordinate +C system (normalized device coordinates). +C + XN=CUFX(PX) + YN=CUFY(PY) +C +C Save the current window and, if necessary, redefine it so that we can +C use normalized device coordinates. +C + CALL GQCNTN (IE,NT) + IF (NT.NE.0) THEN + CALL GQNT (NT,IE,WD,VP) + CALL GSWN (NT,VP(1),VP(2),VP(3),VP(4)) + END IF +C +C Save current character height, text path, character up vector, and +C text alignment. +C + CALL GQCHH (IE,OS) + CALL GQTXP (IE,IP) + CALL GQCHUP (IE,UX,UY) + CALL GQTXAL (IE,IX,IY) +C +C Define the character height. (The final scale factor is derived from +C the default font.) +C + CALL GETUSV ('YF',MY) + YS=FLOAT(2**MY) + IF (IS.GE.0.AND.IS.LE.3) THEN + CS=FLOAT(8+4*IS+4*(IS/3))/YS + ELSE + CS=AMIN1(FLOAT(IS),YS)/YS + ENDIF +C + CS=CS*25.5/27. +C +C + NOAO - make character size readable with IRAF font + cs = cs * 2.0 +C +C - NOAO + + CALL GSCHH(CS) +C +C Define the text path. +C + CALL GSTXP (0) +C +C Define the character up vector. +C + JO=MOD(IO,360) + IF (JO.EQ.0) THEN + CALL GSCHUP (0.,1.) + ELSE IF (JO.EQ.90) THEN + CALL GSCHUP (-1.,0.) + ELSE IF (JO.EQ.180) THEN + CALL GSCHUP (0.,-1.) + ELSE IF (JO.EQ.270) THEN + CALL GSCHUP (1.,0.) + ELSE IF (JO.GT.0.AND.JO.LT.180) THEN + CALL GSCHUP (-1.,1./TAN(FLOAT(JO)*3.1415926/180.)) + ELSE + CALL GSCHUP (1.,-1./TAN(FLOAT(JO)*3.1415926/180.)) + ENDIF +C +C Define the text alignment. +C + CALL GSTXAL (IC+2,3) +C +C Plot the characters. +C + CALL GTX (XN,YN,CH) +C +C Restore the original text attributes. +C + CALL GSCHH (OS) + CALL GSTXP (IP) + CALL GSCHUP (UX,UY) + CALL GSTXAL (IX,IY) +C +C Restore the window definition. +C + IF (NT.NE.0) THEN + CALL GSWN (NT,WD(1),WD(2),WD(3),WD(4)) + END IF +C +C Update the pen position. +C + CALL FRSTPT (PX,PY) +C +C Done. +C + RETURN +C + END +c + NOAO - blockdata utilbd changed to run time initialization + subroutine utilbd +c BLOCKDATA UTILBD +C + logical first +C The common block IUTLCM contains integer utility variables which are +C user-settable by the routine SETUSV and user-retrievable by the +C routine GETUSV. +C + COMMON /IUTLCM/ IU(100) +C +C The common block VCTSEQ contains variables realizing the buffering +C scheme used by PLOTIT/F for pen moves. The dimension of QX and QY must +C be an even number greater than or equal to the value of IU(5). The +C dimension of IF must be half that of QX and QY. +C + COMMON /VCTSEQ/ NQ,QX(50),QY(50),NF,IF(25) +C +C In the common block PLTCM are recorded the coordinates of the last +C point to which a pen move was requested by a call to PLOTIT/F. +C + COMMON /PLTCM/ JX,JY +C +C IU(1) contains the log scaling parameter, which may take on the +C following possible values: +C +C 1 = linear-linear +C 2 = log-linear +C 3 = linear-log +C 4 = log-log +C +c DATA IU(1) / 1 / + IU(1) = 1 +C +C IU(2) specifies the mirror-imaging of the x and y axes, as follows: +C +C 1 = x normal, y normal +C 2 = x normal, y reversed +C 3 = x reversed, y normal +C 4 = x reversed, y reversed +C +c +NOAO - logical parameter first inserted to avoid clobbering initialization + data first /.true./ + if (.not. first) return + first = .false. +c -NOAO +c DATA IU(2) / 1 / + IU(2) = 1 +C +C IU(3) specifies the assumed resolution of the plotter in the x +C direction. Plotter x coordinates are assumed to lie between 1 and +C 2**IU(3), inclusive. +C +c DATA IU(3) / 10 / + IU(3) = 10 +C +C IU(4) specifies the assumed resolution of the plotter in the y +C direction. Plotter y coordinates are assumed to lie between 1 and +C 2**IU(4), inclusive. +C +c DATA IU(4) / 10 / + IU(4) = 10 +C +C IU(5) specifies the size of the buffers used by PLOTIT/F. Its value +C must be greater than or equal to 2 and not greater than the dimension +C of the variables QX and QY. Using the value 2 effectively turns off +C the buffering. +C +c DATA IU(5) / 50 / + IU(5) = 50 +C +C IU(6) specifies the current metacode unit, which is machine-dependent. +C At NCAR, the value "1" currently (1/11/85) causes metacode to be +C written on the file "GMETA". Eventually, it will cause output to be +C written on unit number 1. At that point, the value, on the Cray at +C least, should be changed to "4H$PLT", so that output will come out on +C the old familiar dataset. +C +c DATA IU(6) / 1 / + IU(6) = 1 +C +C IU(7), IU(8), IU(9), and IU(10) specify color and intensity, in the +C following way (letting IR=IU(7), IG=IU(8), IB=IU(9), and IN=IU(10)): +C +C The red intensity is IR/(IR+IG+IB)*IN/10000. +C The green intensity is IG/(IR+IG+IB)*IN/10000. +C The blue intensity is IB/(IR+IG+IB)*IN/10000. +C +C The GKS calls to set these intensities are executed in response to a +C "CALL SETUSV ('IN',IN)", using the existing values of IR, IG, and IB. +C Thus, to completely determine the color and the intensity, the user +C must execute four calls, as follows: +C +C CALL SETUSV ('IR',IR) +C CALL SETUSV ('IG',IG) +C CALL SETUSV ('IB',IB) +C CALL SETUSV ('IN',IN) +C +C The default values create a white line at .8 x maximum intensity. +C +c DATA IU(7) / 1 / +c DATA IU(8) / 1 / +c DATA IU(9) / 1 / + IU(7) = 1 + IU(8) = 1 + IU(9) = 1 +C +c DATA IU(10) / 8000 / + IU(10) = 8000 +C +C IU(11) and IU(12) specify, respectively, the last color index used +C and the maximum number of color indices it is permissible to use. +C +c DATA IU(11) / 0 / +c DATA IU(12) / 1 / + IU(11) = 0 + IU(12) = 1 +C +C IU(13)/1000 specifies the current line width scale factor. +C +c DATA IU(13) / 1000 / + IU(13) = 1000 +C +C IU(14)/1000 specifies the current marker size scale factor. +C +c DATA IU(14) / 1000 / + IU(14) = 1000 +C +C IU(15) through IU(100) are currently undefined. +C +C Initialization for the routine PLOTIT/F: For values of I between 1 and +C NQ, (QX(I),QY(I)) is a point to which a pen move has been requested +C by a past call to PLOTIT/F. The coordinates are stated in the fractional +C coordinate system. For values of I between 1 and NF, IF(I) is the +C index, in QX and QY, of the coordinates of a point to which a pen-up +C move was requested. NQ and NF are never allowed to be less than one. +C +c DATA NQ,QX(1),QY(1),NF,IF(1) / 1 , 0. , 0. , 1 , 1 / + NQ = 1 + QX(1) = 0. + QY(1) = 0. + NF = 1 + IF(1) = 1 +C +C JX and JY are the coordinates, in the metacode system, of the last +C point to which a pen move was requested by a call to PLOTIT/F. +C +c DATA JX,JY / 0 , 0 / + JX = 0 + JY = 0 +C +c -NOAO + return +c + entry initut + first = .true. + END diff --git a/sys/gio/ncarutil/sysint/support.f b/sys/gio/ncarutil/sysint/support.f new file mode 100644 index 00000000..84d11ba5 --- /dev/null +++ b/sys/gio/ncarutil/sysint/support.f @@ -0,0 +1,581 @@ + SUBROUTINE ENCD (VALU,ASH,IOUT,NC,IOFFD) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C +C +C ON INPUT VALU FLOATING POINT NUMBER FROM WHICH THE LABEL IS +C TO BE CREATED. +C ASH SEE IOFFD. +C IOFFD IF IOFFD .EQ. 0, A LABEL WHICH REFLECTS THE +C MAGNITUDE OF VALU IS TO BE CREATED. +C .1 .LE. ABS(VALU) .LE. 99999.49999... +C OR VALUE .EQ. 0.0. THE LABEL CREATED +C SHOULD HAVE 3 TO 5 CHARACTERS DEPENDING +C ON THE MAGNITUDE OF VALU. SEE IOUT. +C IF IOFFD .NE. 0, A LABEL WHICH DOES NOT REFLECT +C THE MAGNITUDE OF VALU IS TO BE CREATED. +C ASH IS USED AS THE NORMALIZATION FACTOR. +C 1. .LE. ASH*ABS(VALU) .LT. 1000. OR +C VALU .EQ. 0.0. THE LABEL CREATED SHOULD +C HAVE 1 TO 3 CHARACTERS, DEPENDING ON THE +C MAGNITUDE OF ASH*VALU. SEE IOUT. +C ON OUTPUT IOUT CONTAINS THE LABEL CREATED. IT SHOULD HAVE NO +C LEADING BLANKS. SEE NC. +C NC THE NUMBERS IN THE LABEL IN IOUT. SHOULD BE +C 1 TO 5. +C + SAVE + CHARACTER*11 IFMT + CHARACTER*(*) IOUT +C +C IFMT MUST HOLD 11 CHARACTERS +C + VAL = VALU + IF (IOFFD .NE. 0) GO TO 103 + IF (VAL) 101,104,101 + 101 LOG = IFIX((ALOG10(ABS(VAL))+.00001)+5000.)-5000 + V = VAL + NS = MAX0(4,MIN0(6,LOG+2)) + ND = MIN0(3,MAX0(0,2-LOG)) +c IF (VAL.LT.0) NS = NS + 1 +c + NOAO - replacing ftn i/o for iraf implementation +c 102 WRITE (IFMT,'(A2,I2,A1,I1,A1)') '(F',NS,'.',ND,')' + 102 continue + ifmt(1:6) = '(f . )' + ifmt(3:3) = char (ns + ichar ('0')) + ifmt(5:5) = char (nd + ichar ('0')) +c WRITE (IOUT,IFMT) V + call encode (ns, ifmt, iout, v) + NC = NS +c + NOAO +c The following statement was making 5 digit labels (+4800) come out +c truncated (+480) and it has been commented out. +c IF (LOG.GE.3) NC = NC - 1 +c - NOAO + RETURN + 103 NS = 4 + IF (VAL.LT.0.) NS=5 + IF (VAL.EQ.0.) NS=2 + ND = 0 + V = VAL*ASH + LOG = 100 + GO TO 102 + 104 iout(1:3) = '0.0' + nc = 3 +c 104 NS = 3 +c ND = 1 +c LOG = -100 +c V = 0. +c GO TO 102 +C +C1001 FORMAT('(F',I2,'.',I1,',1H',A1,')') +C + END +C + SUBROUTINE ENCODE (NCHARS, FTNFMT, FTNOUT, RVAL) + + INTEGER SZFMT, SZBUF + PARAMETER (SZFMT=11) + PARAMETER (SZBUF=15) + + CHARACTER*(*) FTNFMT + CHARACTER*(*) FTNOUT + INTEGER*2 SPPFMT(SZFMT), SPPOUT(SZBUF) + +C UNPACK THE FORTRAN CHARACTER STRING, CALL FENCD TO ACTUALLY ENCODE THE +C OUTPUT STRING, THEN PACK THE OUTPUT STRING INTO A FORTRAN STRING FOR RETURN +C + CALL F77UPK (FTNFMT, SPPFMT, SZFMT) + CALL FENCD (NCHARS, SPPFMT, SPPOUT, RVAL) + CALL F77PAK (SPPOUT, FTNOUT, NCHARS) + + END +C +C PACKAGE ERPRT77 DESCRIPTION OF INDIVIDUAL USER ENTRIES +C FOLLOWS THIS PACKAGE DESCRIPTION. +C +C LATEST REVISION FEBRUARY 1985 +C +C PURPOSE TO PROVIDE A PORTABLE, FORTRAN 77 ERROR +C HANDLING PACKAGE. +C +C USAGE THESE ROUTINES ARE INTENDED TO BE USED IN +C THE SAME MANNER AS THEIR SIMILARLY NAMED +C COUNTERPARTS ON THE PORT LIBRARY. EXCEPT +C FOR ROUTINE SETER, THE CALLING SEQUENCES +C OF THESE ROUTINES ARE THE SAME AS FOR +C THEIR PORT COUNTERPARTS. +C ERPRT77 ENTRY PORT ENTRY +C ------------- ---------- +C ENTSR ENTSRC +C RETSR RETSRC +C NERRO NERROR +C ERROF ERROFF +C SETER SETERR +C EPRIN EPRINT +C FDUM FDUMP +C +C I/O SOME OF THE ROUTINES PRINT ERROR MESSAGES. +C +C PRECISION NOT APPLICABLE +C +C REQUIRED LIBRARY MACHCR, WHICH IS LOADED BY DEFAULT ON +C FILES NCAR'S CRAY MACHINES. +C +C LANGUAGE FORTRAN 77 +C +C HISTORY DEVELOPED OCTOBER, 1984 AT NCAR IN BOULDER, +C COLORADO BY FRED CLARE OF THE SCIENTIFIC +C COMPUTING DIVISION BY ADAPTING THE NON- +C PROPRIETARY, ERROR HANDLING ROUTINES +C FROM THE PORT LIBRARY OF BELL LABS. +C +C PORTABILITY FULLY PORTABLE +C +C REFERENCES SEE THE MANUAL +C PORT MATHEMATICAL SUBROUTINE LIBRARY +C ESPECIALLY "ERROR HANDLING" IN SECTION 2 +C OF THE INTRODUCTION, AND THE VARIOUS +C SUBROUTINE DESCRIPTIONS. +C ****************************************************************** +C +C SUBBROUTINE ENTSR(IROLD,IRNEW) +C +C PURPOSE SAVES THE CURRENT RECOVERY MODE STATUS AND +C SETS A NEW ONE. IT ALSO CHECKS THE ERROR +C STATE, AND IF THERE IS AN ACTIVE ERROR +C STATE A MESSAGE IS PRINTED. +C +C USAGE CALL ENTSR(IROLD,IRNEW) +C +C ARGUMENTS +C +C ON INPUT IRNEW +C VALUE SPECIFIED BY USER FOR ERROR +C RECOVERY +C = 0 LEAVES RECOVERY UNCHANGED +C = 1 GIVES RECOVERY +C = 2 TURNS RECOVERY OFF +C +C ON OUTPUT IROLD +C RECEIVES THE CURRENT VALUE OF THE ERROR +C RECOVERY MODE +C +C SPECIAL CONDITIONS IF THERE IS AN ACTIVE ERROR STATE, THE +C MESSAGE IS PRINTED AND EXECUTION STOPS. +C +C ERROR STATES - +C 1 - ILLEGAL VALUE OF IRNEW. +C 2 - CALLED WHILE IN AN ERROR STATE. +C ****************************************************************** +C +C SUBROUTINE RETSR(IROLD) +C +C PURPOSE SETS THE RECOVERY MODE TO THE STATUS GIVEN +C BY THE INPUT ARGUMENT. A TEST IS THEN MADE +C TO SEE IF A CURRENT ERROR STATE EXISTS WHICH +C IS UNRECOVERABLE; IF SO, RETSR PRINTS AN +C ERROR MESSAGE AND TERMINATES THE RUN. +C +C BY CONVENTION, RETSR IS USED UPON EXIT +C FROM A SUBROUTINE TO RESTORE THE PREVIOUS +C RECOVERY MODE STATUS STORED BY ROUTINE +C ENTSR IN IROLD. +C +C USAGE CALL RETSR(IROLD) +C +C ARGUMENTS +C +C ON INPUT IROLD +C = 1 SETS FOR RECOVERY +C = 2 SETS FOR NONRECOVERY +C +C ON OUTPUT NONE +C +C SPECIAL CONDITIONS IF THE CURRENT ERROR BECOMES UNRECOVERABLE, +C THE MESSAGE IS PRINTED AND EXECUTION STOPS. +C +C ERROR STATES - +C 1 - ILLEGAL VALUE OF IROLD. +C ****************************************************************** +C +C INTEGER FUNCTION NERRO(NERR) +C +C PURPOSE PROVIDES THE CURRENT ERROR NUMBER (IF ANY) +C OR ZERO IF THE PROGRAM IS NOT IN THE +C ERROR STATE. +C +C USAGE N = NERRO(NERR) +C +C ARGUMENTS +C +C ON INPUT NONE +C +C ON OUTPUT NERR +C CURRENT VALUE OF THE ERROR NUMBER +C ****************************************************************** +C SUBROUTINE ERROF +C +C PURPOSE TURNS OFF THE ERROR STATE BY SETTING THE +C ERROR NUMBER TO ZERO +C +C USAGE CALL ERROF +C +C ARGUMENTS +C +C ON INPUT NONE +C +C ON OUTPUT NONE +C ****************************************************************** +C +C SUBROUTINE SETER(MESSG,NERR,IOPT) +C +C PURPOSE SETS THE ERROR INDICATOR AND, DEPENDING +C ON THE OPTIONS STATED BELOW, PRINTS A +C MESSAGE AND PROVIDES A DUMP. +C +C +C USAGE CALL SETER(MESSG,NERR,IOPT) +C +C ARGUMENTS +C +C ON INPUT MESSG +C HOLLERITH STRING CONTAINING THE MESSAGE +C ASSOCIATED WITH THE ERROR +C +C NERR +C THE NUMBER TO ASSIGN TO THE ERROR +C +C IOPT +C = 1 FOR A RECOVERABLE ERROR +C = 2 FOR A FATAL ERROR +C +C IF IOPT = 1 AND THE USER IS IN ERROR +C RECOVERY MODE, SETERR SIMPLY REMEMBERS +C THE ERROR MESSAGE, SETS THE ERROR NUMBER +C TO NERR, AND RETURNS. +C +C IF IOPT = 1 AND THE USER IS NOT IN ERROR +C RECOVERY MODE, SETERR PRINTS THE ERROR +C MESSAGE AND TERMINATES THE RUN. +C +C IF IOPT = 2 SETERR ALWAYS PRINTS THE ERROR +C MESSAGE, CALLS FDUM, AND TERMINATES THE RUN. +C +C ON OUTPUT NONE +C +C SPECIAL CONDITIONS CANNOT ASSIGN NERR = 0, AND CANNOT SET IOPT +C TO ANY VALUE OTHER THAN 1 OR 2. +C ****************************************************************** +C +C SUBROUTINE EPRIN +C +C PURPOSE PRINTS THE CURRENT ERROR MESSAGE IF THE +C PROGRAM IS IN THE ERROR STATE; OTHERWISE +C NOTHING IS PRINTED. +C +C USAGE CALL EPRIN +C +C ARGUMENTS +C +C ON INPUT NONE +C +C ON OUTPUT NONE +C ****************************************************************** +C +C SUBROUTINE FDUM +C +C PURPOSE TO PROVIDE A DUMMY ROUTINE WHICH SERVES +C AS A PLACEHOLDER FOR A SYMBOLIC DUMP +C ROUTINE, SHOULD IMPLEMENTORS DECIDE TO +C PROVIDE SUCH A ROUTINE. +C +C USAGE CALL EPRIN +C +C ARGUMENTS +C +C ON INPUT NONE +C +C ON OUTPUT NONE +C ****************************************************************** + SUBROUTINE ENTSR(IROLD,IRNEW) +C + LOGICAL TEMP + IF (IRNEW.LT.0 .OR. IRNEW.GT.2) + 1 CALL SETER(' ENTSR - ILLEGAL VALUE OF IRNEW',1,2) +C + TEMP = IRNEW.NE.0 + IROLD = I8SAV(2,IRNEW,TEMP) +C +C IF HAVE AN ERROR STATE, STOP EXECUTION. +C + IF (I8SAV(1,0,.FALSE.) .NE. 0) CALL SETER + 1 (' ENTSR - CALLED WHILE IN AN ERROR STATE',2,2) +C + RETURN +C + END + SUBROUTINE RETSR(IROLD) +C + IF (IROLD.LT.1 .OR. IROLD.GT.2) + 1 CALL SETER(' RETSR - ILLEGAL VALUE OF IROLD',1,2) +C + ITEMP=I8SAV(2,IROLD,.TRUE.) +C +C IF THE CURRENT ERROR IS NOW UNRECOVERABLE, PRINT AND STOP. +C + IF (IROLD.EQ.1 .OR. I8SAV(1,0,.FALSE.).EQ.0) RETURN +C + CALL EPRIN + CALL FDUM +c STOP +C + END + INTEGER FUNCTION NERRO(NERR) +C + NERRO=I8SAV(1,0,.FALSE.) + NERR=NERRO + RETURN +C + END + SUBROUTINE ERROF +C + I=I8SAV(1,0,.TRUE.) + RETURN +C + END + SUBROUTINE SETER(MESSG,NERR,IOPT) +C + CHARACTER*(*) MESSG + COMMON /UERRF/IERF +C +C THE UNIT FOR ERROR MESSAGES IS I1MACH(4) +C +c + NOAO - blockdata uerrbd changed to runtime initialization subroutine +C FORCE LOAD OF BLOCKDATA +C +c EXTERNAL UERRBD + call uerrbd +c - NOAO + IF (IERF .EQ. 0) THEN + IERF = I1MACH(4) + ENDIF +C + NMESSG = LEN(MESSG) + IF (NMESSG.GE.1) GO TO 10 +C +C A MESSAGE OF NON-POSITIVE LENGTH IS FATAL. +C +c + NOAO - FTN writes rewritten as calls to uliber for IRAF +c WRITE(IERF,9000) +c9000 FORMAT(' ERROR 1 IN SETER - MESSAGE LENGTH NOT POSITIVE.') + call uliber (1,' SETER - MESSAGE LENGTH NOT POSITIVE.', 80) +c - NOAO + GO TO 60 +C + 10 CONTINUE + IF (NERR.NE.0) GO TO 20 +C +C CANNOT TURN THE ERROR STATE OFF USING SETER. +C +c + NOAO - FTN writes rewritten as calls to uliber for IRAF +c WRITE(IERF,9001) +c9001 FORMAT(' ERROR 2 IN SETER - CANNOT HAVE NERR=0'/ +c 1 ' THE CURRENT ERROR MESSAGE FOLLOWS'/) + call uliber (2, ' SETER - CANNOT HAVE NERR=0', 80) + call uliber (2, ' SETER - THE CURRENT ERROR MSG FOLLOWS', 80) +c - NOAO + CALL E9RIN(MESSG,NERR,.TRUE.) + ITEMP=I8SAV(1,1,.TRUE.) + GO TO 50 +C +C SET LERROR AND TEST FOR A PREVIOUS UNRECOVERED ERROR. +C + 20 CONTINUE + IF (I8SAV(1,NERR,.TRUE.).EQ.0) GO TO 30 +C +c + NOAO - FTN writes rewritten as calls to uliber for IRAF +c WRITE(IERF,9002) +c9002 FORMAT(' ERROR 3 IN SETER -', +c 1 ' AN UNRECOVERED ERROR FOLLOWED BY ANOTHER ERROR.'// +c 2 ' THE PREVIOUS AND CURRENT ERROR MESSAGES FOLLOW.'///) + call uliber (3,' SETER - A SECOND UNRECOV ERROR SEEN.', 80) + call uliber (3,' SETER - THE ERROR MESSAGES FOLLOW.', 80) +c - NOAO + CALL EPRIN + CALL E9RIN(MESSG,NERR,.TRUE.) + GO TO 50 +C +C SAVE THIS MESSAGE IN CASE IT IS NOT RECOVERED FROM PROPERLY. +C + 30 CALL E9RIN(MESSG,NERR,.TRUE.) +C + IF (IOPT.EQ.1 .OR. IOPT.EQ.2) GO TO 40 +C +C MUST HAVE IOPT = 1 OR 2. +C +c + NOAO - FTN writes rewritten as calls to uliber for IRAF +c WRITE(IERF,9003) +c9003 FORMAT(' ERROR 4 IN SETER - BAD VALUE FOR IOPT'// +c 1 ' THE CURRENT ERROR MESSAGE FOLLOWS'///) + call uliber (4, ' SETER - BAD VALUE FOR IOPT', 80) + call uliber (4, ' SETER - THE CURRENT ERR MSG FOLLOWS', 80) +c - NOAO + GO TO 50 +C +C TEST FOR RECOVERY. +C + 40 CONTINUE + IF (IOPT.EQ.2) GO TO 50 +C + IF (I8SAV(2,0,.FALSE.).EQ.1) RETURN +C + CALL EPRIN + CALL FDUM +c STOP +C + 50 CALL EPRIN + 60 CALL FDUM +c STOP +C + END + SUBROUTINE EPRIN +C + CHARACTER*1 MESSG +C + CALL E9RIN(MESSG,1,.FALSE.) + RETURN +C + END + SUBROUTINE E9RIN(MESSG,NERR,SAVE) +C +C THIS ROUTINE STORES THE CURRENT ERROR MESSAGE OR PRINTS THE OLD ONE, +C IF ANY, DEPENDING ON WHETHER OR NOT SAVE = .TRUE. . +C + CHARACTER*(*) MESSG + CHARACTER*113 MESSGP + INTEGER NERRP + LOGICAL SAVE + COMMON /UERRF/IERF + SAVE MESSGP,NERRP +C +C MESSGP STORES THE FIRST 113 CHARACTERS OF THE PREVIOUS MESSAGE +C +C +C START WITH NO PREVIOUS MESSAGE. +C + DATA MESSGP/'1'/ + DATA NERRP/0/ +C + IF (.NOT.SAVE) GO TO 20 +C +C SAVE THE MESSAGE. +C + NERRP=NERR + MESSGP = MESSG +C + GO TO 30 +C + 20 IF (I8SAV(1,0,.FALSE.).EQ.0) GO TO 30 +C +C PRINT THE MESSAGE. +C +c + NOAO - FTN write rewritten as call to uliber +c WRITE(IERF,9000) NERRP,MESSGP +c9000 FORMAT(' ERROR ',I4,' IN ',A113) + call uliber (nerrp, messgp, 113) +C + 30 RETURN +C + END + INTEGER FUNCTION I8SAV(ISW,IVALUE,SET) +C +C IF (ISW = 1) I8SAV RETURNS THE CURRENT ERROR NUMBER AND +C SETS IT TO IVALUE IF SET = .TRUE. . +C +C IF (ISW = 2) I8SAV RETURNS THE CURRENT RECOVERY SWITCH AND +C SETS IT TO IVALUE IF SET = .TRUE. . +C + LOGICAL SET + INTEGER LERROR, LRECOV + SAVE LERROR,LRECOV +C +C START EXECUTION ERROR FREE AND WITH RECOVERY TURNED OFF. +C + DATA LERROR/0/ , LRECOV/2/ + IF (ISW .EQ. 1) THEN + I8SAV = LERROR + IF (SET) LERROR = IVALUE + ELSE IF (ISW .EQ. 2) THEN + I8SAV = LRECOV + IF (SET) LRECOV = IVALUE + ENDIF + RETURN + END + SUBROUTINE FDUM +C +C DUMMY ROUTINE TO BE LOCALLY IMPLEMENTED +C + RETURN + END +C + SUBROUTINE Q8QST4(NAME,LBRARY,ENTRY,VRSION) +C +C DIMENSION OF NAME(1),LBRARY(1),ENTRY(1),VRSION(1) +C ARGUMENTS +C +C LATEST REVISION MARCH 1984 +C +C PURPOSE MONITORS LIBRARY USE BY WRITING A RECORD WITH +C INFORMATION ABOUT THE CIRCUMSTANCES OF A +C LIBRARY ROUTINE CALL TO THE SYSTEM ACCOUNTING +C TAPE FOR LATER PROCESSING. +C +C NOTE--- THIS VERSION OF Q8QST4 SIMPLY RETURNS TO THE +C CALLING ROUTINE. LOCAL IMPLEMENTORS MAY WISH +C TO IMPLEMENT A VERSION OF THIS ROUTINE THAT +C MONITORS USE OF NCAR ROUTINES WITH LOCAL +C MECHANISMS. OTHERWISE IT WILL SAVE A SMALL +C AMOUNT OF SPACE AND TIME IF CALLS TO Q8QST4 ARE +C DELETED FROM ALL NSSL ROUTINES. +C + CHARACTER*(*) NAME,LBRARY,ENTRY,VRSION +C + RETURN + END +c + NOAO - Blockdata uerrbd rewritten as a runtime initialization subroutine +c BLOCKDATA UERRBD + subroutine uerrbd +c + COMMON /UERRF/IERF +C DEFAULT ERROR UNIT +c DATA IERF/0/ + IERF= 0 + END +c -NOAO + subroutine uliber (errcode, pkerrmsg, msglen) + + character*80 pkerrmsg + integer errcode, msglen + integer*2 sppmsg(81) + integer SZLINE + parameter (SZLINE=80) + +c unpack the fortran character string, call fulib to output the string. +c + call f77upk (pkerrmsg, sppmsg, SZLINE) + call fulib (errcode, sppmsg, msglen) + + end diff --git a/sys/gio/ncarutil/tests/README b/sys/gio/ncarutil/tests/README new file mode 100644 index 00000000..d74bb65f --- /dev/null +++ b/sys/gio/ncarutil/tests/README @@ -0,0 +1,2 @@ +This directory contains test routines for the NCAR utilities. The files +ending with "t.f" are the NCAR supplied fortran test routines. diff --git a/sys/gio/ncarutil/tests/auto10t.f b/sys/gio/ncarutil/tests/auto10t.f new file mode 100644 index 00000000..26109f4f --- /dev/null +++ b/sys/gio/ncarutil/tests/auto10t.f @@ -0,0 +1,262 @@ + SUBROUTINE XMPL10 +C +C Define the data arrays. +C + REAL XDRA(1201),YDRA(1201) +C +C Fill the data arrays. The independent variable represents time during +C the year (a hypothetical year with equal-length months) and is set up +C so that the minor ticks can be lengthened to delimit the months; the +C major ticks, though shortened to invisibility, will determine where +C the labels go. +C + DO 101 I=1,1201 + XDRA(I)=FLOAT(I-51) + YDRA(I)=COSH(FLOAT(I-601)/202.) + 101 CONTINUE +C +C Change the labels on the bottom and left axes. +C + CALL ANOTAT ('MONTHS OF THE YEAR$','ROMAN NUMERALS$',0,0,0,0) +C +C Fix the minimum and maximum values on both axes and prevent AUTOGRAPH +C from using rounded values at the ends of the axes. +C + CALL AGSETF ('X/MIN.',-50.) + CALL AGSETF ('X/MAX.',1150.) + CALL AGSETI ('X/NICE.',0) +C + CALL AGSETF ('Y/MIN.',1.) + CALL AGSETF ('Y/MAX.',10.) + CALL AGSETI ('Y/NICE.',0) +C +C Specify the spacing between major tick marks on all axes. Note that +C the AUTOGRAPH dummy routine AGCHNL is supplanted (below) by one which +C supplies dates for the bottom axis and Roman numerals for the left +C axis in place of the numeric labels one would otherwise get. +C + CALL AGSETI (' LEFT/MAJOR/TYPE.',1) + CALL AGSETI (' RIGHT/MAJOR/TYPE.',1) + CALL AGSETI ('BOTTOM/MAJOR/TYPE.',1) + CALL AGSETI (' TOP/MAJOR/TYPE.',1) +C + CALL AGSETF (' LEFT/MAJOR/BASE.', 1.) + CALL AGSETF (' RIGHT/MAJOR/BASE.', 1.) + CALL AGSETF ('BOTTOM/MAJOR/BASE.',100.) + CALL AGSETF (' TOP/MAJOR/BASE.',100.) +C +C Suppress minor ticks on the left and right axes. +C + CALL AGSETI (' LEFT/MINOR/SPACING.',0) + CALL AGSETI (' RIGHT/MINOR/SPACING.',0) +C +C On the bottom and top axes, put one minor tick between each pair of +C major ticks, shorten the major ticks to invisibility, and lengthen +C the minor ticks. The net effect is to make the minor ticks delimit +C the beginning and end of each month, while the major ticks, though +C invisible, cause the names of the months to be where we want them. +C + CALL AGSETI ('BOTTOM/MINOR/SPACING.',1) + CALL AGSETI (' TOP/MINOR/SPACING.',1) +C + CALL AGSETF ('BOTTOM/MAJOR/INWARD. ',0.) + CALL AGSETF ('BOTTOM/MINOR/INWARD. ',.015) + CALL AGSETF (' TOP/MAJOR/INWARD. ',0.) + CALL AGSETF (' TOP/MINOR/INWARD. ',.015) +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Draw the graph, using EZXY. +C + CALL EZXY (XDRA,YDRA,1201,'EXAMPLE 10 (MODIFIED NUMERIC LABELS)$') +C +c STOP +C + END + SUBROUTINE AGCHNL (IAXS,VILS,CHRM,MCIM,NCIM,IPXM,CHRE,MCIE,NCIE) +C + CHARACTER*(*) CHRM,CHRE +C +C The routine AGCHNL is called by AGAXIS just after it has set up the +C character strings comprising a numeric label along an axis. The +C default version does nothing. A user may supply his own version to +C change the numeric labels. For each numeric label, this routine is +C called twice by AGAXIS - once to determine how much space will be +C required when the label is actually drawn and once just before it +C is actually drawn. The arguments are as follows: +C +C - IAXS is the number of the axis being drawn. Its value is 1, 2, 3, +C or 4, implying the left, right, bottom, or top axes, respectively. +C The value of IAXS must not be altered. +C +C - VILS is the value to be represented by the numeric label, in the +C label system for the axis. The value of VILS must not be altered. +C +C - CHRM, on entry, is a character string containing the mantissa of the +C numeric label, as it will appear if AGCHNL makes no changes. If the +C numeric label includes a "times" symbol, it will be represented by +C a blank in CHRM. (See IPXM, below.) CHRM may be modified. +C +C - MCIM is the length of CHRM - the maximum number of characters that +C it will hold. The value of MCIM must not be altered. +C +C - NCIM, on entry, is the number of meaningful characters in CHRM. If +C CHRM is changed, NCIM should be changed accordingly. +C +C - IPXM, on entry, is zero if there is no "times" symbol in CHRM; if it +C is non-zero, it is the index of the appropriate character position +C in CHRM. If AGCHNL changes the position of the "times" symbol in +C CHRM, removes it, or adds it, the value of IPXM must be changed. +C +C - CHRE, on entry, is a character string containing the exponent of the +C numeric label, as it will appear if AGCHNL makes no changes. CHRE +C may be modified. +C +C - MCIE is the length of CHRE - the maximum number of characters that +C it will hold. The value of MCIE must not be altered. +C +C - NCIE, on entry, is the number of meaningful characters in CHRE. If +C CHRE is changed, NCIE should be changed accordingly. +C +C Define the names of the months for use on the bottom axis. +C + CHARACTER*3 MONS(12) + DATA MONS / 'JAN','FEB','MAR','APR','MAY','JUN', + + 'JUL','AUG','SEP','OCT','NOV','DEC'/ +C +C Modify the numeric labels on the left axis. +C + IF (IAXS.EQ.1) THEN + CALL AGCORN (IFIX(VILS),CHRM,NCIM) + IPXM=0 + NCIE=0 +C +C Modify the numeric labels on the bottom axis. +C + ELSE IF (IAXS.EQ.3) THEN + IMON=IFIX(VILS+.5)/100+1 + CHRM(1:3)=MONS(IMON) + NCIM=3 + IPXM=0 + NCIE=0 + END IF +C +C Done. +C + RETURN +C + END + SUBROUTINE AGCORN (NTGR,BCRN,NCRN) +C + CHARACTER*(*) BCRN +C +C This routine receives an integer in NTGR and returns its Roman-numeral +C equivalent - NCRN characters - in the character variable BCRN. It +C only works for integers within a limited range and it does some rather +C unorthodox things (like using zero and minus). +C +C ICH1, ICH5, and IC10 are character variables used for the single-unit, +C five-unit, and ten-unit symbols at a given level. +C + CHARACTER*1 ICH1,ICH5,IC10 +C +C Treat numbers outside the range (-4000,+4000) as infinites. +C + IF (IABS(NTGR).GE.4000) THEN + IF (NTGR.GT.0) THEN + NCRN=5 + BCRN(1:5)='(INF)' + ELSE + NCRN=6 + BCRN(1:6)='(-INF)' + END IF + RETURN + END IF +C +C Use the symbol '0' for the zero. The Romans never had it so good. +C + IF (NTGR.EQ.0) THEN + NCRN=1 + BCRN(1:1)='0' + RETURN + END IF +C +C Zero the character counter. +C + NCRN=0 +C +C Handle negative integers by prefixing a minus sign. +C + IF (NTGR.LT.0) THEN + NCRN=NCRN+1 + BCRN(NCRN:NCRN)='-' + END IF +C +C Initialize some constants. We'll check for thousands first. +C + IMOD=10000 + IDIV=1000 + ICH1='M' +C +C Find out how many thousands (hundreds, tens, units) there are and jump +C to the proper code block for each case. +C + 101 INTG=MOD(IABS(NTGR),IMOD)/IDIV +C + GO TO (107,104,104,104,102,103,103,103,103,106) , INTG+1 +C +C Four - add ICH1 followed by ICH5. +C + 102 NCRN=NCRN+1 + BCRN(NCRN:NCRN)=ICH1 +C +C Five through eight - add ICH5, followed by INTG-5 ICH1's. +C + 103 NCRN=NCRN+1 + BCRN(NCRN:NCRN)=ICH5 +C + INTG=INTG-5 + IF (INTG.LE.0) GO TO 107 +C +C One through three - add that many ICH1's. +C + 104 DO 105 I=1,INTG + NCRN=NCRN+1 + BCRN(NCRN:NCRN)=ICH1 + 105 CONTINUE +C + GO TO 107 +C +C Nine - add ICH1, followed by IC10. +C + 106 NCRN=NCRN+1 + BCRN(NCRN:NCRN)=ICH1 + NCRN=NCRN+1 + BCRN(NCRN:NCRN)=IC10 +C +C If we're done, exit. +C + 107 IF (IDIV.EQ.1) RETURN +C +C Otherwise, tool up for the next digit and loop back. +C + IMOD=IMOD/10 + IDIV=IDIV/10 + IC10=ICH1 +C + IF (IDIV.EQ.100) THEN + ICH5='D' + ICH1='C' + ELSE IF (IDIV.EQ.10) THEN + ICH5='L' + ICH1='X' + ELSE + ICH5='V' + ICH1='I' + END IF +C + GO TO 101 +C + END diff --git a/sys/gio/ncarutil/tests/autograph.x b/sys/gio/ncarutil/tests/autograph.x new file mode 100644 index 00000000..3c2ccb14 --- /dev/null +++ b/sys/gio/ncarutil/tests/autograph.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include +include + +# Test NCAR routine AUTOGRAPH - EZXY, EZMXY etc. + +procedure t_autograph() + +char device[SZ_FNAME], command[SZ_LINE] +int ierror, wkid, junk, cmd +int ctoi() +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tautog (ierror) + if (ierror == 0) + call eprintf ("Test successful\n") + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/autographt.f b/sys/gio/ncarutil/tests/autographt.f new file mode 100644 index 00000000..25b14518 --- /dev/null +++ b/sys/gio/ncarutil/tests/autographt.f @@ -0,0 +1,186 @@ + SUBROUTINE TAUTOG (IERROR) +C +C LATEST REVISION FEBRUARY 1985 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C AUTOGRAPH AND TO TEST AUTOGRAPH ON A +C SIMPLE PROBLEM +C +C USAGE CALL TAUTOG (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN ERROR PARAMETER +C = 0, IF THE TEST IS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C AUTOGRAPH TEST SUCCESSFUL . . . SEE PLOT +C TO VERIFY PERFORMANCE +C +C IS WRITTEN ON UNIT 6. +C +C IN ADDITION, FOUR (4) LABELLED FRAMES +C CONTAINING THE TWO-DIMENSIONAL PLOTS ARE +C PRODUCED ON THE MACHINE GRAPHICS DEVICE. +C TO DETERMINE IF THE TEST WAS SUCCESSFUL, +C IT IS NECESSARY TO EXAMINE THESE PLOTS. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY AUTOGRAPH +C FILES +C +C LANGUAGE FORTRAN +C +C HISTORY ORIGINALLY WRITTEN IN APRIL, 1979 AND +C CONVERTED TO FORTRAN 77 AND GKS IN FEBRUARY +C 1985. +C +C ALGORITHM TAUTOG COMPUTES DATA FOR AUTOGRAPH SUBROUTINES +C +C EZY, EZXY, EZMY, AND EZMXY, +C +C AND CALLS EACH OF THESE ROUTINES TO PRODUCE +C ONE PLOT EACH. +C +C ON THREE OF THE PLOTS, TAUTOG USES THE +C AUTOGRAPH CONTROL PARAMETER ROUTINES +C AGSETF, AGSETI, AND AGSETP TO SPECIFY +C Y-AXIS LABELS OR INTRODUCE LOG SCALING. +C +C PORTABILITY FORTRAN 77 +C + REAL X(21) ,Y1D(21) ,Y2D(21,5) +C +C X CONTAINS THE ABSCISSA VALUES FOR THE PLOTS PRODUCED BY EZXY AND +C EZMXY, Y1D CONTAINS THE ORDINATE VALUES FOR THE PLOTS PRODUCED BY +C EZXY AND EZY, AND Y2D CONTAINS THE ORDINATE VALUES FOR THE PLOTS +C PRODUCED BY EZMY AND EZMXY. +C +C +C +C +C FILL Y1D ARRAY FOR ENTRY EZY +C + DO 10 I=1,21 + Y1D(I) = EXP(-.1*FLOAT(I))*COS(FLOAT(I)*.5) + 10 CONTINUE +C +C ENTRY EZY PLOTS THE CONTENTS OF Y1D AS A FUNCTION OF THE INTEGERS +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATING EZY ENTRY OF AUTOGRAPH +C + CALL EZY (Y1D(1),21,'DEMONSTRATING EZY ENTRY OF AUTOGRAPH$') +C + +C +C +C +C FILL X AND Y1D ARRAYS FOR ENTRY EZXY +C + DO 20 I=1,21 + X(I) = FLOAT(I-1)*.314 + Y1D(I) = X(I)+COS(X(I))*2.0 + 20 CONTINUE +C +C SET AUTOGRAPH CONTROL PARAMETERS FOR Y-AXIS LABEL +C X+COS(X)*2 +C + CALL AGSETC('LABEL/NAME.','L') + CALL AGSETI('LINE/NUMBER.',100) + CALL AGSETC('LINE/TEXT.','X+COS(X)*2$') +C +C ENTRY EZXY PLOTS CONTENTS OF X-ARRAY VS. Y1D-ARRAY +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATING EZXY ENTRY OF AUTOGRAPH +C + CALL EZXY (X,Y1D,21,'DEMONSTRATING EZXY ENTRY IN AUTOGRAPH$') +C +C +C +C +C FILL Y2D ARRAY FOR ENTRY EZMY +C + DO 40 I=1,21 + T = .5*FLOAT(I-1) + DO 30 J=1,5 + Y2D(I,J) = EXP(-.5*T)*COS(T)/FLOAT(J) + 30 CONTINUE + 40 CONTINUE +C +C SET AUTOGRAPH CONTROL PARAMETERS FOR Y-AXIS LABEL +C EXP(-X/2)*COS(X)*SCALE +C + CALL AGSETC('LABEL/NAME.','L') + CALL AGSETI('LINE/NUMBER.',100) + CALL AGSETC('LINE/TEXT.','EXP(-X/2)*COS(X)*SCALE$') +C +C SET AUTOGRAPH CONTROL PARAMETER FOR SPECIFYING THAT THE +C ALPHABETIC SET OF DASHED LINE PATTERNS IS TO BE USED. +C + CALL AGSETI('DASH/SELECTOR.',-1) +C +C SET AUTOGRAPH CONTROL PARAMETER FOR SPECIFYING THAT THE +C GRAPH DRAWN IS TO BE LOGARITHMIC IN THE X-AXIS. +C + CALL AGSETI('X/LOGARITHMIC.',1) +C +C ENTRY EZMY PLOTS MULTIPLE ARRAYS AS A FUNCTION OF THE INTEGERS +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATING EZMY ENTRY OF AUTOGRAPH +C + CALL EZMY (Y2D,21,5,10,'DEMONSTRATING EZMY ENTRY OF AUTOGRAPH$') +C +C +C +C +C FILL Y2D ARRAY FOR EZMXY +C + DO 60 I=1,21 + DO 50 J=1,5 + Y2D(I,J) = X(I)**J+COS(X(I)) + 50 CONTINUE + 60 CONTINUE +C +C SET AUTOGRAPH CONTROL PARAMETERS FOR Y-AXIS LABEL +C X**J+COS(X) +C + CALL AGSETC('LABEL/NAME.','L') + CALL AGSETI('LINE/NUMBER.',100) + CALL AGSETC('LINE/TEXT.','X**J+COS(X)$') +C +C SET AUTOGRAPH CONTROL PARAMETER FOR SPECIFYING THAT THE +C ALPHABETIC SET OF DASHED LINE PATTERNS IS TO BE USED. +C + CALL AGSETI('DASH/SELECTOR.',-1) +C +C SET AUTOGRAPH CONTROL PARAMETER FOR SPECIFYING THAT THE GRAPH +C IS TO BE LINEAR IN THE X-AXIS AND LOGARITHMIC IN THE Y-AXIS. +C + CALL AGSETI('X/LOGARITHMIC.',0) + CALL AGSETI('Y/LOGARITHMIC.',1) +C +C ENTRY EZMXY PLOTS MULTIPLE ARRAYS AS A FUNCTION OF A SINGLE +C X ARRAY (OR MANY X ARRAYS) +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATING EZMXY ENTRY OF AUTOGRAPH +C + CALL EZMXY (X,Y2D,21,5,21, + + 'DEMONSTRATING EZMXY ENTRY OF AUTOGRAPH$') +C + IERROR = 0 +c WRITE (6,1001) +C + RETURN +C +c1001 FORMAT (' AUTOGRAPH TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/conran.x b/sys/gio/ncarutil/tests/conran.x new file mode 100644 index 00000000..11a4ab0d --- /dev/null +++ b/sys/gio/ncarutil/tests/conran.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +# T_CONRAN -- test NCAR contour routine CONRAN. + +procedure t_conran () + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tconan (error_code) + if (error_code == 0) + call printf ("Test successful\n") + else { + call printf ("Test was not successful. ierror = %d\n") + call pargi (error_code) + } + + call gdawk (wkid) + call gclwk (wkid) + call gclks () + +end diff --git a/sys/gio/ncarutil/tests/conrant.f b/sys/gio/ncarutil/tests/conrant.f new file mode 100644 index 00000000..a144de35 --- /dev/null +++ b/sys/gio/ncarutil/tests/conrant.f @@ -0,0 +1,97 @@ + SUBROUTINE TCONAN (IERROR) +C +C LATEST REVISION JULY 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C CONRAN, THE STANDARD ENTRY POINT OF THE +C CONRAN PACKAGE. +C +C THIS SAME SUBROUTINE CAN BE USED TO PRODUCE +C DEMO PLOTS OF THE SMOOTH VERSION OF CONRAN +C BY LOADING DASHSMTH INSTEAD OF DASHCHAR. +C +C USAGE CALL TCONAN (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C .EQ. 0, IF THE TEST WAS SUCCESSFUL, +C .NE. 0, OTHERWISE +C IF NOT ZERO THE NUMBER PRODUCED WILL +C CORRESPOND TO THE ERROR NUMBERS IN +C THE CONRAN LISTING. +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C CONRAN TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, TWO FRAMES CONTAINING THE CONTOUR +C PLOT AND TRIANGULATION OF THE DATA ARE PRODUCED +C ON THE DEFAULT GRAPHICS DEVICE UNLESS THE USER +C SPECIFIES OTHERWISE VIA JCL. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY CONRAN +C FILES CONTERP +C CONCOM +C +C LANGUAGE FORTRAN77 +C +C ALGORITHM A SPARSE DATA SET IS DEFINED VIA DATA +C STATEMENTS. OPTIONS ARE SET TO PRODUCE A +C TITLE AND DISPLAY THE TRIANGULATION GENERATED +C BY THE INTERPOLATING ROUTINES. BY DEFAULT +C A MESSAGE AT THE BOTTEM OF THE PLOT AND A +C PERIMETER ARE ALSO PRODUCED. THIS ROUTINE +C TAKES ADVANTAGE OF THE PORT ERROR HANDLING +C ROUTINES TO DETERMINE IF CONRAN TERMINATED +C NORMALLY. +C +C PORTABILITY ANSI FORTRAN77 STANDARD +C +C COMMON /RANINT/ IRANMJ, IRANMN, IRANTX +C SET UP THE SCRATCH SPACES REQUIRED BY CONRAN +C + DIMENSION WK(221),IWK(744),SCR(1600) +C +C SET UP THE ARRAYS TO DEFINE THE DATA SET +C + DIMENSION XD(17),YD(17),ZD(17) +C +C DEFINE THE DATA SET +C + DATA XD(1),XD(2),XD(3),XD(4),XD(5),XD(6),XD(7),XD(8), + 1 XD(9),XD(10),XD(11),XD(12),XD(13),XD(14),XD(15), + 2 XD(16),XD(17) + 3 /3.,3.,10.,18.,18.,10.,10.,5.,1.,15.,20., + 4 5.,15.,10.,7.,13.,16./ +C + DATA YD(1),YD(2),YD(3),YD(4),YD(5),YD(6),YD(7),YD(8), + 1 YD(9),YD(10),YD(11),YD(12),YD(13),YD(14),YD(15), + 2 YD(16),YD(17) + 3 /3.,18.,18.,3.,18.,10.,1.,5.,10.,5.,10., + 4 15.,15.,15.,20.,20.,8./ +C + DATA ZD(1),ZD(2),ZD(3),ZD(4),ZD(5),ZD(6),ZD(7),ZD(8), + 1 ZD(9),ZD(10),ZD(11),ZD(12),ZD(13),ZD(14),ZD(15), + 2 ZD(16),ZD(17) + 3 /25.,25.,25.,25.,25.,-5.,1.,1.,1.,1.,1., + 4 1.,1.,1.,1.,1.,25./ +C +C SET UP PARAMETER FOR NUMBER OF INPUT POINTS +C + DATA NDP/17/ + call conbdn +C +C SET UP TITLE FOR PLOT +C + CALL CONOP4('TLE=ON','DEMONSTRATION PLOT FOR CONRAN',29, 0) +C + CALL CONRAN(XD,YD,ZD,NDP,WK,IWK,SCR) +C + RETURN + END diff --git a/sys/gio/ncarutil/tests/conraq.x b/sys/gio/ncarutil/tests/conraq.x new file mode 100644 index 00000000..d0480e97 --- /dev/null +++ b/sys/gio/ncarutil/tests/conraq.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +# T_CONRAQ -- test NCAR contour routine CONRAQ. + +procedure t_conraq () + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tconaq (error_code) + if (error_code == 0) + call printf ("Test successful\n") + else + call printf ("Test was not successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () + +end diff --git a/sys/gio/ncarutil/tests/conraqt.f b/sys/gio/ncarutil/tests/conraqt.f new file mode 100644 index 00000000..dbf211aa --- /dev/null +++ b/sys/gio/ncarutil/tests/conraqt.f @@ -0,0 +1,139 @@ + SUBROUTINE TCONAQ (IERROR) +C +C LATEST REVISION JULY 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C CONRAQ, THE QUICK ENTRY POINT OF THE +C CONRAN PACKAGE. +C +C USAGE CALL TCONAQ (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C .EQ. 0, IF THE TEST WAS SUCCESSFUL, +C .NE. 0, OTHERWISE. +C IF NOT ZERO THE NUMBER PRODUCED WILL +C CORRESPOND TO THE ERROR NUMBERS IN +C THE CONRAQ LISTING. +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C CONRAQ TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, TWO FRAMES CONTAINING THE CONTOUR +C PLOT AND TRIANGULATION OF THE DATA ARE PRODUCED +C ON THE DEFAULT GRAPHICS DEVICE UNLESS THE USER +C SPECIFIES OTHERWISE VIA JCL. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY CONRAQ +C FILES CONTERP +C +C LANGUAGE FORTRAN77 +C +C ALGORITHM A SPARSE DATA SET IS DEFINED VIA DATA +C STATEMENTS. OPTIONS ARE SET TO PRODUCE A +C TITLE AND DISPLAY THE TRIANGULATION GENERATED +C BY THE INTERPOLATING ROUTINES. BY DEFAULT +C A MESSAGE AT THE BOTTEM OF THE PLOT AND A +C PERIMETER ARE ALSO PRODUCED. THIS ROUTINE +C TAKES ADVANTAGE OF THE PORT ERROR HANDLING +C ROUTINES TO DETERMINE IF CONRAQ TERMINATED +C NORMALLY. +C + COMMON /RAQINT/ IRAQMJ, IRAQMN, IRAQTX +C +C SET UP THE SCRATCH SPACES REQUIRED BY CONRAQ +C + DIMENSION WK(221),IWK(744) +C +C SET UP THE ARRAYS TO DEFINE THE DATA SET +C + DIMENSION XD(17),YD(17),ZD(17) +C +C DEFINE THE DATA SET +C + DATA XD(1),XD(2),XD(3),XD(4),XD(5),XD(6),XD(7),XD(8), + 1 XD(9),XD(10),XD(11),XD(12),XD(13),XD(14),XD(15), + 2 XD(16),XD(17) + 3 /3.,3.,10.,18.,18.,10.,10.,5.,1.,15.,20., + 4 5.,15.,10.,7.,13.,16./ +C + DATA YD(1),YD(2),YD(3),YD(4),YD(5),YD(6),YD(7),YD(8), + 1 YD(9),YD(10),YD(11),YD(12),YD(13),YD(14),YD(15), + 2 YD(16),YD(17) + 3 /3.,18.,18.,3.,18.,10.,1.,5.,10.,5.,10., + 4 15.,15.,15.,20.,20.,8./ +C + DATA ZD(1),ZD(2),ZD(3),ZD(4),ZD(5),ZD(6),ZD(7),ZD(8), + 1 ZD(9),ZD(10),ZD(11),ZD(12),ZD(13),ZD(14),ZD(15), + 2 ZD(16),ZD(17) + 3 /25.,25.,25.,25.,25.,-5.,1.,1.,1.,1.,1., + 4 1.,1.,1.,1.,1.,25./ +C +C SET UP PARAMETER FOR NUMBER OF INPUT POINTS +C + DATA NDP/17/ +C +C SET PORT ERROR HANDLING ROUTINE TO RECOVERY MODE +C + CALL ENTSR(IROLD,1) +C +C SET UP TITLE FOR PLOT +C + CALL CONOP4('TLE=ON','DEMONSTRATION PLOT FOR CONRAQ',29) +C +C TEST FOR ERROR +C + IF (NERRO(IERROR).NE.0) GO TO 100 +C +C NO ERROR +C +C SET OPTION TO DISPLAY THE TRIANGULATION +C + CALL CONOP1('TRI=ON') +C +C TEST FOR ERROR +C + IF (NERRO(IERROR).NE.0) GO TO 100 +C +C NO ERROR +C +C CALL CONRAQ TO CONTOUR DATA +C + CALL CONRAQ(XD,YD,ZD,NDP,WK,IWK) +C +C TEST FOR ERROR +C + IF (NERRO(IERROR).NE.0) GO TO 100 +C +C NO ERROR +C +C +C CALL FRAME, CONRAQ WILL NOT DO THIS +C +cCALL NEWFM +C +C PRINT MESSAGE EVERYTHING OK +C +c WRITE(6,10) +c10 FORMAT(1X,'CONRAQ TEST SUCCESSFUL, SEE PLOT TO VERIFY', +c 1' PERFORMANCE') +C +C + RETURN +C +C IF ERROR CALL THE PORT ERROR PRINT ROUTINE. +C THIS CALL IS NOT NECESSARY UNLESS YOU ARE IN RECOVER MODE. +C IF YOU ARE NOT IN RECOVER MODE THE ERROR MESSAGE WILL BE PRINTED +C AUTOMATICALLY. +C + 100 CALL EPRIN + RETURN +C + END diff --git a/sys/gio/ncarutil/tests/conras.x b/sys/gio/ncarutil/tests/conras.x new file mode 100644 index 00000000..d2b48dc2 --- /dev/null +++ b/sys/gio/ncarutil/tests/conras.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +# T_CONRAS -- test NCAR contour routine CONRAS. + +procedure t_conras () + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tconas (error_code) + if (error_code == 0) + call printf ("Test successful\n") + else + call printf ("Test was not successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () + +end diff --git a/sys/gio/ncarutil/tests/conrast.f b/sys/gio/ncarutil/tests/conrast.f new file mode 100644 index 00000000..c4f3ab12 --- /dev/null +++ b/sys/gio/ncarutil/tests/conrast.f @@ -0,0 +1,147 @@ + SUBROUTINE TCONAS (IERROR) +C +C LATEST REVISION AUGUST 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C CONRAS, THE SUPER ENTRY POINT OF THE +C CONRAN PACKAGE. +C +C USAGE CALL TCONAS (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C .EQ. 0, IF THE TEST WAS SUCCESSFUL, +C .NE. 0, OTHERWISE +C IF NOT ZERO THE NUMBER PRODUCED WILL +C CORRESPOND TO THE ERROR NUMBERS IN +C THE CONRAS LISTING. +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C CONRAS TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, TWO FRAMES CONTAINING THE CONTOUR +C PLOT AND TRIANGULATION OF THE DATA ARE PRODUCED +C ON THE DEFAULT GRAPHICS DEVICE UNLESS THE USER +C SPECIFIES OTHERWISE VIA JCL. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY CONRAS +C FILES CONTERP +C CONCOM +C DASHSUPR +C +C SPECIALIST FOR INFORMATION ABOUT THIS ROUTINE OR THE +C ULIB CONRAS PACKAGE, CONTACT THE SPECIALIST +C NAMED IN THE ULIB CONRAS PACKAGE. +C +C LANGUAGE FORTRAN +C +C ALGORITHM A SPARSE DATA SET IS DEFINED VIA DATA +C STATEMENTS. OPTIONS ARE SET TO PRODUCE A +C TITLE AND DISPLAY THE TRIANGULATION GENERATED +C BY THE INTERPOLATING ROUTINES. BY DEFAULT +C A MESSAGE AT THE BOTTEM OF THE PLOT AND A +C PERIMETER ARE ALSO PRODUCED. THIS ROUTINE +C TAKES ADVANTAGE OF THE PORT ERROR HANDLING +C ROUTINES TO DETERMINE IF CONRAS TERMINATED +C NORMALLY. +C +C PORTABILITY ANSI STANDARD +C +C +C SET UP THE SCRATCH SPACES REQUIRED BY CONRAS +C + DIMENSION WK(221),IWK(744),SCR(1600) +C +C SET UP THE ARRAYS TO DEFINE THE DATA SET +C + DIMENSION XD(17),YD(17),ZD(17) + COMMON /RASINT/ IRASMJ, IRASMN, IRASTX +C +C DEFINE THE DATA SET +C + DATA XD(1),XD(2),XD(3),XD(4),XD(5),XD(6),XD(7),XD(8), + 1 XD(9),XD(10),XD(11),XD(12),XD(13),XD(14),XD(15), + 2 XD(16),XD(17) + 3 /3.,3.,10.,18.,18.,10.,10.,5.,1.,15.,20., + 4 5.,15.,10.,7.,13.,16./ +C + DATA YD(1),YD(2),YD(3),YD(4),YD(5),YD(6),YD(7),YD(8), + 1 YD(9),YD(10),YD(11),YD(12),YD(13),YD(14),YD(15), + 2 YD(16),YD(17) + 3 /3.,18.,18.,3.,18.,10.,1.,5.,10.,5.,10., + 4 15.,15.,15.,20.,20.,8./ +C + DATA ZD(1),ZD(2),ZD(3),ZD(4),ZD(5),ZD(6),ZD(7),ZD(8), + 1 ZD(9),ZD(10),ZD(11),ZD(12),ZD(13),ZD(14),ZD(15), + 2 ZD(16),ZD(17) + 3 /25.,25.,25.,25.,25.,-5.,1.,1.,1.,1.,1., + 4 1.,1.,1.,1.,1.,25./ +C +C SET UP PARAMETER FOR NUMBER OF INPUT POINTS +C + DATA NDP/17/ +C +C SET PORT ERROR HANDLING ROUTINE TO RECOVERY MODE +C + CALL ENTSR(IROLD,1) +C +C SET UP TITLE FOR PLOT +C + CALL CONOP4('TLE=ON','DEMONSTRATION PLOT FOR CONRAS',29,0) +C +C TEST FOR ERROR +C + IF (NERRO(IERROR).NE.0) GO TO 100 +C +C NO ERROR +C +C SET OPTION TO DISPLAY THE TRIANGULATION +C + CALL CONOP1('TRI=ON') +C +C TEST FOR ERROR +C + IF (NERRO(IERROR).NE.0) GO TO 100 +C +C NO ERROR +C +C CALL CONRAS TO CONTOUR DATA +C + CALL CONRAS(XD,YD,ZD,NDP,WK,IWK,SCR) +C +C TEST FOR ERROR +C + IF (NERRO(IERROR).NE.0) GO TO 100 +C +C NO ERROR +C +C +C CALL FRAME, CONRAS WILL NOT DO THIS +C +c CALL NEWFM +C +C PRINT MESSAGE EVERYTHING OK +C +c WRITE(6,10) +c10 FORMAT(1X,'CONRAS TEST SUCCESSFUL, SEE PLOT TO VERIFY ', +c 1'PERFORMANCE') +C +C + RETURN +C +C IF ERROR CALL THE PORT ERROR PRINT ROUTINE. +C THIS CALL IS NOT NECESSARY UNLESS YOU ARE IN RECOVER MODE. +C IF YOU ARE NOT IN RECOVER MODE THE ERROR MESSAGE WILL BE PRINTED +C AUTOMATICALLY. +C + 100 CALL EPRIN + RETURN +C + END diff --git a/sys/gio/ncarutil/tests/conrcqckt.f b/sys/gio/ncarutil/tests/conrcqckt.f new file mode 100644 index 00000000..d9d2f827 --- /dev/null +++ b/sys/gio/ncarutil/tests/conrcqckt.f @@ -0,0 +1,114 @@ + SUBROUTINE TCNQCK (IERROR) +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C CONRECQCK AND TO TEST CONRECQCK ON A SINGLE +C PROBLEM +C +C USAGE CALL TCNQCK (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST WAS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C CONRECQCK TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, TWO FRAMES CONTAINING THE CONTOUR +C PLOT ARE PRODUCED ON THE MACHINE GRAPHICS +C DEVICE. IN ORDER TO DETERMINE IF THE TEST +C WAS SUCCESSFUL, IT IS NECESSARY TO EXAMINE +C THESE PLOTS. +C +C PRECISION SINGLE +C +C ALGORITHM THE FUNCTION +C Z(X,Y) = X + Y + 1./((X-.1)**2+Y**2+.09) +C -1./((X+.1)**2+Y**2+.09) +C FOR X = -1. TO +1. IN INCREMENTS OF .1 AND +C Y = -1.2 TO +1.2 IN INCREMENTS OF .1 +C IS COMPUTED. +C TCNQCK CALLS SUBROUTINES EZCNTR, CONREC, AND +C PWRIT TO DRAW TWO LABELLED CONTOUR PLOTS OF THE +C ARRAY Z. +C +C PORTABILITY ANSI FORTRAN77 +C +C Z CONTAINS THE VALUES TO BE PLOTTED. +C + REAL Z(21,25) +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE INTEGER COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX AND TY +C DEFINE THE CENTER OF THE TITLE STRING. +C + DATA TX/.4267/, TY/.9765/ +C +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 0 +C +C FILL TWO DIMENSIONAL ARRAY TO BE PLOTTED +C + DO 20 I=1,21 + X = .1*FLOAT(I-11) + DO 10 J=1,25 + Y = .1*FLOAT(J-13) + Z(I,J) = X+Y+1./((X-.10)**2+Y**2+.09)- + 1 1./((X+.10)**2+Y**2+.09) + 10 CONTINUE + 20 CONTINUE +C +C SELECT NORMALIZATION TRANSFORMATION 0 +C + CALL GSELNT (0) +C +C ENTRY EZCNTR REQUIRES ONLY THE ARRAY NAME AND ITS DIMENSIONS +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR EZCNTR ENTRY OF CONRECQCK +C + CALL WTSTR (TX,TY, + 1 'DEMONSTRATION PLOT FOR EZCNTR ENTRY OF CONRECQCK', + 2 2,0,0) + CALL EZCNTR (Z,21,25) +C +C +C ENTRY CONREC ALLOWS USER SPECIFICATION OF PLOT PARAMETERS, IF DESIRED +C +C IN THIS EXAMPLE, THE LOWEST CONTOUR LEVEL (-4.5), THE HIGHEST CONTOUR +C LEVEL (4.5), AND THE INCREMENT BETWEEN CONTOUR LEVELS (0.3) ARE +C SPECIFIED. +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR CONREC ENTRY OF CONRECQCK +C + CALL WTSTR (TX,TY, + 1 'DEMONSTRATION PLOT FOR CONREC ENTRY OF CONRECQCK', + 2 2,0,0) + CALL CONREC (Z,21,21,25,-4.5,4.5,.3,0,0,0) +c CALL NEWFM +C +c WRITE (6,1001) + RETURN +C +c1001 FORMAT (' CONRECQCK TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C +C--------------------------------------------------------------------- +C REVISION HISTORY +C +C JUNE 1984 CONVERTED TO FORTRAN 77 AND GKS +C +C--------------------------------------------------------------------- + END diff --git a/sys/gio/ncarutil/tests/conrcsmtht.f b/sys/gio/ncarutil/tests/conrcsmtht.f new file mode 100644 index 00000000..735d109a --- /dev/null +++ b/sys/gio/ncarutil/tests/conrcsmtht.f @@ -0,0 +1,122 @@ + SUBROUTINE TCNSMT (IERROR) +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C CONRECSMTH AND TO TEST CONRECSMTH ON A SINGLE +C PROBLEM +C +C USAGE CALL TCNSMT (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST WAS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C CONRECSMTH TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, TWO FRAMES CONTAINING THE CONTOUR +C PLOT ARE PRODUCED ON THE MACHINE GRAPHICS +C DEVICE. IN ORDER TO DETERMINE IF THE TEST +C WAS SUCCESSFUL, IT IS NECESSARY TO EXAMINE +C THESE PLOTS. +C +C PRECISION SINGLE +C +C +C LANGUAGE FORTRAN +C +C ALGORITHM THE FUNCTION +C Z(X,Y) = X + Y + 1./((X-.1)**2+Y**2+.09) +C -1./((X+.1)**2+Y**2+.09) +C FOR X = -1. TO +1. IN INCREMENTS OF .1 AND +C Y = -1.2 TO +1.2 IN INCREMENTS OF .1 +C IS COMPUTED. +C TCNSMT CALLS SUBROUTINES EZCNTR, CONREC, AND +C WTSTR TO DRAW TWO LABELLED CONTOUR PLOTS OF THE +C ARRAY Z. +C +C PORTABILITY ANSI FORTRAN77 STANDARD +C +C +C Z CONTAINS THE VALUES TO BE PLOTTED. +C + REAL Z(21,25) +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE INTEGER COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX AND TY +C DEFINE THE CENTER OF THE TITLE STRING. +C +c DATA TX/0.42676/, TY/0.97656/ + TX = 0.42676 + TY = 0.97656 +C +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 0 +C +C FILL TWO DIMENSIONAL ARRAY TO BE PLOTTED +C + DO 20 I=1,21 + X = .1*FLOAT(I-11) + DO 10 J=1,25 + Y = .1*FLOAT(J-13) + Z(I,J) = X+Y+1./((X-.10)**2+Y**2+.09)- + 1 1./((X+.10)**2+Y**2+.09) + 10 CONTINUE + 20 CONTINUE +C +C SELECT NORMAIZATION TRANS NUMBER TO WRITE TITLES +C + CALL GSELNT (0) +C +C ENTRY EZCNTR REQUIRES ONLY THE ARRAY NAME AND ITS DIMENSIONS +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR EZCNTR ENTRY OF CONRECSMTH +C + CALL WTSTR (TX,TY, + 1 'DEMONSTRATION PLOT FOR EZCNTR ENTRY OF CONRECSMTH', + 2 2,0,0) + CALL EZCNTR (Z,21,25) +C +C +C ENTRY CONREC ALLOWS USER SPECIFICATION OF PLOT PARAMETERS, IF DESIRED +C +C IN THIS EXAMPLE, THE LOWEST CONTOUR LEVEL (-4.5), THE HIGHEST CONTOUR +C LEVEL (4.5), AND THE INCREMENT BETWEEN CONTOUR LEVELS (0.3) ARE +C SPECIFIED. +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR CONREC ENTRY OF CONRECSMTH +C + CALL WTSTR (TX,TY, + 1 'DEMONSTRATION PLOT FOR CONREC ENTRY OF CONRECSMTH', + 2 2,0,0) + CALL CONREC (Z,21,21,25,-4.5,4.5,.3,0,0,0) +c CALL NEWFM +C +c WRITE (6,1001) + RETURN +C +c 1001 FORMAT (' CONRECSMTH TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C +C +C--------------------------------------------------------------------- +C +C REVISION HISTORY +C +C JUNE 1984 CONVERTED TO FORTRAN 77 AND GKS +C +C--------------------------------------------------------------------- + END diff --git a/sys/gio/ncarutil/tests/conrcsprt.f b/sys/gio/ncarutil/tests/conrcsprt.f new file mode 100644 index 00000000..484d1ccc --- /dev/null +++ b/sys/gio/ncarutil/tests/conrcsprt.f @@ -0,0 +1,110 @@ + SUBROUTINE TCNSUP (IERROR) +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C CONRECSUPR AND TO TEST CONRECSUPR ON A SINGLE +C PROBLEM +C +C USAGE CALL TCNSUP (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST WAS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C CONRECSUPR TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, TWO FRAMES CONTAINING THE CONTOUR +C PLOT ARE PRODUCED ON THE MACHINE GRAPHICS +C DEVICE. IN ORDER TO DETERMINE IF THE TEST +C WAS SUCCESSFUL, IT IS NECESSARY TO EXAMINE +C THESE PLOTS. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C ALGORITHM THE FUNCTION +C Z(X,Y) = X + Y + 1./((X-.1)**2+Y**2+.09) +C -1./((X+.1)**2+Y**2+.09) +C FOR X = -1. TO +1. IN INCREMENTS OF .1 AND +C Y = -1.2 TO +1.2 IN INCREMENTS OF .1 +C IS COMPUTED. +C TCNSUP CALLS SUBROUTINES EZCNTR, CONREC, AND +C WTSTR TO DRAW TWO LABELLED CONTOUR PLOTS OF THE +C ARRAY Z. +C +C PORTABILITY ANSI FORTRAN77 +C +C Z CONTAINS THE VALUES TO BE PLOTTED. +C + REAL Z(21,25) +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE INTEGER COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX AND TY +C DEFINE THE CENTER OF THE TITLE STRING. +C + DATA TX/0.4219/, TY/0.9765/ +C +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 0 +C +C FILL TWO DIMENSIONAL ARRAY TO BE PLOTTED +C + DO 20 I=1,21 + X = .1*FLOAT(I-11) + DO 10 J=1,25 + Y = .1*FLOAT(J-13) + Z(I,J) = X+Y+1./((X-.10)**2+Y**2+.09)- + 1 1./((X+.10)**2+Y**2+.09) + 10 CONTINUE + 20 CONTINUE +C +C SELECT NORMALIZATION TRANS NUMBER 0 +C + CALL GSELNT (0) +C +C ENTRY EZCNTR REQUIRES ONLY THE ARRAY NAME AND ITS DIMENSIONS +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR EZCNTR ENTRY OF CONRECSUPR +C + CALL WTSTR (TX,TY, + 1 'DEMONSTRATION PLOT FOR EZCNTR ENTRY OF CONRECSUPR', + 2 2,0,0) + CALL EZCNTR (Z,21,25) +C +C +C ENTRY CONREC ALLOWS USER SPECIFICATION OF PLOT PARAMETERS, IF DESIRED +C +C IN THIS EXAMPLE, THE LOWEST CONTOUR LEVEL (-4.5), THE HIGHEST CONTOUR +C LEVEL (4.5), AND THE INCREMENT BETWEEN CONTOUR LEVELS (0.3) ARE +C SPECIFIED. ALSO THE LABELLING OF THE HIGHS AND LOWS IS SUPRESSED. +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR CONREC ENTRY OF CONRECSUPR +C + CALL WTSTR (TX,TY, + 1 'DEMONSTRATION PLOT FOR CONREC ENTRY OF CONRECSUPR', + 2 2,0,0) + CALL CONREC (Z,21,21,25,-4.5,4.5,.3,0,-1,0) + CALL NEWFM +C + WRITE (6,1001) + RETURN +C + 1001 FORMAT (' CONRECSUPR TEST SUCCESSFUL',24X, + 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/conrec.x b/sys/gio/ncarutil/tests/conrec.x new file mode 100644 index 00000000..2d9adfe5 --- /dev/null +++ b/sys/gio/ncarutil/tests/conrec.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +# T_CONREC -- test NCAR contour routine CONREC. + +procedure t_conrec () + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tconre (2, error_code) + if (error_code == 0) + call printf ("Test successful\n") + else + call printf ("Test was not successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () + +end diff --git a/sys/gio/ncarutil/tests/conrect.f b/sys/gio/ncarutil/tests/conrect.f new file mode 100644 index 00000000..401aad9b --- /dev/null +++ b/sys/gio/ncarutil/tests/conrect.f @@ -0,0 +1,118 @@ + SUBROUTINE TCONRE (nplot, IERROR) +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C CONREC AND TO TEST CONREC ON A SINGLE +C PROBLEM +C +C USAGE CALL TCONRE (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST WAS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C CONREC TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, TWO FRAMES CONTAINING THE CONTOUR +C PLOT ARE PRODUCED ON THE MACHINE GRAPHICS +C DEVICE. IN ORDER TO DETERMINE IF THE TEST +C WAS SUCCESSFUL, IT IS NECESSARY TO EXAMINE +C THESE PLOTS. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C ALGORITHM THE FUNCTION +C Z(X,Y) = X + Y + 1./((X-.1)**2+Y**2+.09) +C -1./((X+.1)**2+Y**2+.09) +C FOR X = -1. TO +1. IN INCREMENTS OF .1 AND +C Y = -1.2 TO +1.2 IN INCREMENTS OF .1 +C IS COMPUTED. +C TCONRE CALL SUBROUTINES EZCNTR, CONREC, AND +C PWRIT TO DRAW TWO LABELLED CONTOUR PLOTS OF THE +C ARRAY Z. +C +C PORTABILITY FORTRAN77 +C +C +C Z CONTAINS THE VALUES TO BE PLOTTED. +C + REAL Z(21,25) +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE INTEGER COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX AND TY +C DEFINE THE CENTER OF THE TITLE STRING. +C +C DATA TX/.3955/, TY/.9765/ + data tx/.4267/, ty/.97/ +C +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 0 +C +C FILL TWO DIMENSIONAL ARRAY TO BE PLOTTED +C + DO 20 I=1,21 + X = .1*FLOAT(I-11) + DO 10 J=1,25 + Y = .1*FLOAT(J-13) + Z(I,J) = X+Y+1./((X-.10)**2+Y**2+.09)- + 1 1./((X+.10)**2+Y**2+.09) + 10 CONTINUE + 20 CONTINUE +C +C SELECT NORMALIZATION TRANSFORMATION NUMBER 0 +C + CALL GSELNT ( 0 ) +C +C ENTRY EZCNTR REQUIRES ONLY THE ARRAY NAME AND ITS DIMENSIONS +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR EZCNTR ENTRY OF CONREC +C +c +noao: flag added to plot either EZCNTR or CONREC + if (nplot .eq. 1) then + CALL WTSTR ( TX, TY, + 1 'DEMONSTRATION PLOT FOR EZCNTR ENTRY OF CONREC',2,0,0 ) + CALL EZCNTR (Z,21,25) + endif +c -noao +C +C +C ENTRY CONREC ALLOWS USER SPECIFICATION OF PLOT PARAMETERS, IF DESIRED +C +C IN THIS EXAMPLE, THE LOWEST CONTOUR LEVEL (-4.5), THE HIGHEST CONTOUR +C LEVEL (4.5), AND THE INCREMENT BETWEEN CONTOUR LEVELS (0.3) ARE +C SPECIFIED. +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR CONREC ENTRY OF CONREC +C +c +noao: flag added to plot either EZCNTR of CONREC + if (nplot .eq. 2) then + CALL WTSTR ( TX ,TY, + 1 'DEMONSTRATION PLOT FOR CONREC ENTRY OF CONREC',2,0,0 ) + CALL CONREC (Z,21,21,25,-4.5,4.5,.3,0,0,0) + endif +c -noao +c CALL NEWFM +C +C WRITE (6,1001) + RETURN +C +C1001 FORMAT (' CONREC TEST SUCCESSFUL',24X, +C 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/dashchar.x b/sys/gio/ncarutil/tests/dashchar.x new file mode 100644 index 00000000..77430f37 --- /dev/null +++ b/sys/gio/ncarutil/tests/dashchar.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +# Test NCAR routine DASHCHAR + +procedure t_dashchar() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tdashc (error_code) + + if (error_code == 0) + call printf ("Test successful\n") + else + call printf ("Test was not successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/dashchart.f b/sys/gio/ncarutil/tests/dashchart.f new file mode 100644 index 00000000..fa583b84 --- /dev/null +++ b/sys/gio/ncarutil/tests/dashchart.f @@ -0,0 +1,145 @@ + SUBROUTINE TDASHC (IERROR) +C +C LATEST REVISION MAY 1984 +C +C PURPOSE TO PROVIDE A DEMONSTRATION OF DASHCHAR +C AND TO TEST DASHCHAR ON A SIMPLE PROBLEM +C +C USAGE CALL TDASHC (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST IS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C DASHCHAR TEST SUCCESSFUL . . . SEE PLOT +C TO VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C +C IN ADDITION, ONE FRAME CONTAINING THE +C DASHED LINE PLOT IS PRODUCED ON THE +C MACHINE GRAPHICS DEVICE. TO DETERMINE +C IF THE TEST IS SUCCESSFUL, IT IS NECESSARY +C TO EXAMINE THIS PLOT. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY DASHCHAR +C FILES +C +C LANGUAGE FORTRAN +C +C ALGORITHM TDASHC UTILIZES THE SOFTWARE DASHCHAR +C SUBROUTINES DASHDB, DASHDC, FRSTD, VECTD, +C LINED AND CURVED TO DRAW FIVE CURVES ON ONE +C PICTURE USING FIVE DIFFERENT DASHCHAR +C PATTERNS. EACH CURVE IS CENTERED ABOUT +C SOLID AXIS LINES AND LABELLED WITH THE +C CHARACTER REPRESENTATION OF THE DASHCHAR +C PATTERN USED. +C +C PORTABILITY FORTRAN 77 +C +C X CONTAINS ABSCISSAE VALUES OF THE CURVE TO BE PLOTTED, Y CONTAINS +C ORDINATE VALUES OF THE CURVE TO BE PLOTTED. +C + DIMENSION X(31) ,Y(31) +C +C SELECT NORMALIZATION TRANSFORMATION 0 +C + CALL GSELNT(0) +C +C SET SOLID DASH PATTERN, 1111111111111111 (BINARY). +C BOOLEAN OPERATIONS (EMPLOYING LOCALLY-IMPLEMENTED SUPPORT +C ROUTINES) ARE USED FOR PORTABILITY TO HOSTS WITH 16 BIT +C INTEGERS. +C + ISOLID = IOR (ISHIFT (32767,1), 1) +C + DO 130 K=1,5 + CALL DASHDB (ISOLID) + ORG =1.07-0.195*K +C +C DRAW CENTRAL AXIS FOR EACH CURVE +C + CALL FRSTD (.50,ORG-0.03) + CALL VECTD (.50,ORG+0.03) + CALL LINED (.109,ORG,.891,ORG) +C +C CALL SUBROUTINE DASHDC WITH A DIFFERENT DASHED LINE AND CHARACTER +C COMBINATION FOR EACH OF FIVE CURVES +C + GO TO ( 10, 20, 30, 40, 50),K + 10 CALL DASHDC ('$''$''$''$''$''$''$''$K = 1',10,12) + GO TO 60 + 20 CALL DASHDC ('$$$$$$''$''$$$$$$K = 2',10,12) + GO TO 60 + 30 CALL DASHDC ('$$$$''$$$$''$$$$''K = 3',10,12) + GO TO 60 + 40 CALL DASHDC ('$$$$$''''''''''$$$$$K = 4',10,12) + GO TO 60 + 50 CALL DASHDC ('$$$''$$$''$$$''$$$K = 5',10,12) + 60 CONTINUE +C +C COMPUTE VALUES FOR AND DRAW THE KTH CURVE +C + DO 70 I=1,31 + THETA = FLOAT(I-1)*3.1415926535897932/15. + X(I) = 0.5+.4*COS(THETA) + Y(I) = ORG+.075*SIN(FLOAT(K)*THETA) + 70 CONTINUE + CALL CURVED (X,Y,31) +C +C LABEL EACH CURVE WITH THE APPROPRIATE CHARACTER REPRESENTATION +C OF THE DASHCHAR PATTERN. IN THE PATTERN LABELS, A AND D +C SHOULD BE INTERPRETED AS APOSTROPHE AND DOLLAR SIGN. +C +C SET TEXT ALIGNMENT TO CENTER THE STRING AT THE LEFT OF THE +C STRING AND IN THE VERTICAL CENTER +C + CALL GSTXAL(1,3) +C +C SET CHARACTER HEIGHT +C + CALL GSCHH(.012) +C + ORY = ORG+.089 + GO TO ( 80, 90,100,110,120),K + 80 CALL GTX(.1,ORY,'IPAT=DADADADADADADADK=1') + GO TO 130 + 90 CALL GTX(.1,ORY,'IPAT=DDDDDDADADDDDDDK=2') + GO TO 130 + 100 CALL GTX(.1,ORY,'IPAT=DDDDADDDDADDDDAK=3') + GO TO 130 + 110 CALL GTX(.1,ORY,'IPAT=DDDDDAAAAADDDDDK=4') + GO TO 130 + 120 CALL GTX(.1,ORY,'IPAT=DDDADDDADDDADDDK=5') +C + 130 CONTINUE +C + CALL GSTXAL(2,3) + CALL GTX (.5,.991,'DEMONSTRATION PLOT FOR DASHCHAR') + CALL GTX (.5,.015,'IN IPAT STRINGS, A AND D SHOULD BE INTERPRETED + 1AS APOSTROPHE AND DOLLAR SIGN') +C +C ADVANCE FRAME +C +c + noao: no need for clearing terminal +c CALL NEWFM +c - noao +C + IERROR = 0 +C WRITE (6,1001) +C + RETURN +C +C +C1001 FORMAT (' DASHCHAR TEST SUCCESSFUL',24X, +C 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/dashlinet.f b/sys/gio/ncarutil/tests/dashlinet.f new file mode 100644 index 00000000..c857428c --- /dev/null +++ b/sys/gio/ncarutil/tests/dashlinet.f @@ -0,0 +1,138 @@ + SUBROUTINE TDASHL (IERROR) +C +C LATEST REVISION APRIL 1984 +C +C PURPOSE TO PROVIDE A DEMONSTRATION OF DASHLINE +C AND TO TEST DASHLINE ON A SIMPLE PROBLEM +C +C USAGE CALL TDASHL (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST IS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C DASHLINE TEST SUCCESSFUL . . . SEE PLOT +C TO VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C +C IN ADDITION, ONE FRAME CONTAINING THE +C DASHED LINE PLOT IS PRODUCED ON THE +C MACHINE GRAPHICS DEVICE. TO DETERMINE +C IF THE TEST IS SUCCESSFUL, IT IS NECESSARY +C TO EXAMINE THIS PLOT. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY DASHLINE +C FILES +C +C LANGUAGE FORTRAN +C +C ALGORITHM TDASHL UTILIZES THE SOFTWARE DASHLINE +C SUBROUTINES DASHDB, FRSTD, VECTD, LINED AND +C CURVED TO DRAW FIVE CURVES ON ONE PICTURE +C USING FIVE DIFFERENT DASHLINE PATTERNS. EACH +C CURVE IS CENTERED ABOUT SOLID AXIS LINES AND +C LABELLED WITH THE BINARY REPRESENTATION OF THE +C DASHLINE PATTERN USED. +C +C PORTABILITY FORTRAN 77 +C +C X CONTAINS ABSCISSAE VALUES OF THE CURVE TO BE PLOTTED, Y CONTAINS +C COORDINATE VALUES OF THE CURVE TO BE PLOTTED. +C + DIMENSION X(31) ,Y(31) ,IPAT(5) +C +C SELECT NORMALIZATION TRANSFORMATION 0 +C + CALL GSELNT(0) +C +C SET SOLID DASH PATTERN, 1111111111111111 (BINARY). +C BOOLEAN OPERATIONS (EMPLOYING LOCALLY IMPLEMENTED +C SUPPORT ROUTINES) ARE USED. +C + ISOLID = IOR (ISHIFT (32767,1), 1) +C +C ARRAY IPAT CONTAINS 5 DIFFERENT 16-BIT DASH PATTERNS. THE PATTERNS +C CONSTRUCTED WITH BOOLEAN OPERATIONS AS ABOVE. +C THE BINARY REPRESENTATIONS OF THE PATTERNS ARE +C 0001110001111111 +C 1111000011110000 +C 1111110011111100 +C 1111111100000000 +C 1111111111111100 +C + IPAT(1) = IOR (ISHIFT ( 3647,1), 1) + IPAT(2) = ISHIFT (30840,1) + IPAT(3) = ISHIFT (32382,1) + IPAT(4) = ISHIFT (32640,1) + IPAT(5) = ISHIFT (32766,1) +C + DO 70 K=1,5 + CALL DASHDB (ISOLID) + ORG =1.07-0.195*K +C +C DRAW CENTRAL AXIS FOR EACH CURVE +C + CALL FRSTD (.50,ORG-0.03) + CALL VECTD (.50,ORG+0.03) + CALL LINED (.109,ORG,.891,ORG) + CALL DASHDB (IPAT(K)) +C +C COMPUTE VALUES FOR AND DRAW THE KTH CURVE +C + DO 10 I=1,31 + THETA = FLOAT(I-1)*3.1415926535897932/15. + X(I) = 0.5+.4*COS(THETA) + Y(I) = ORG+.075*SIN(FLOAT(K)*THETA) + 10 CONTINUE + CALL CURVED (X,Y,31) +C +C LABEL EACH CURVE WITH THE APPROPRIATE BINARY REPRESENTATION OF +C THE DASHLINE PATTERN +C +C SET TEXT ALIGNMENT TO CENTER THE STRING AT THE LEFT OF THE +C STRING AND IN THE VERTICAL CENTER +C + CALL GSTXAL(1,3) +C +C SET CHARACTER HEIGHT +C + CALL GSCHH(.012) +C + ORY = ORG+.09 + GO TO ( 20, 30, 40, 50, 60),K + 20 CALL GTX (.1,ORY,'IPAT=0001110001111111') + GO TO 70 + 30 CALL GTX (.1,ORY,'IPAT=1111000011110000') + GO TO 70 + 40 CALL GTX (.1,ORY,'IPAT=1111110011111100') + GO TO 70 + 50 CALL GTX (.1,ORY,'IPAT=1111111100000000') + GO TO 70 + 60 CALL GTX (.1,ORY,'IPAT=1111111111111100') +C + 70 CONTINUE +C + CALL GSTXAL(2,3) + CALL GTX (.5,.991,'DEMONSTRATION PLOT FOR DASHLINE') +C +C ADVANCE FRAME +C + CALL NEWFM +C + IERROR = 0 + WRITE (6,1001) +C + RETURN +C + 1001 FORMAT (' DASHLINE TEST SUCCESSFUL',24X, + 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/dashsmth.x b/sys/gio/ncarutil/tests/dashsmth.x new file mode 100644 index 00000000..4bca9807 --- /dev/null +++ b/sys/gio/ncarutil/tests/dashsmth.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +# Test NCAR routine DASHSMTH + +procedure t_dashsmth() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tdashs (error_code) + + if (error_code == 0) + call printf ("Test successful\n") + else + call printf ("Test was not successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/dashsmtht.f b/sys/gio/ncarutil/tests/dashsmtht.f new file mode 100644 index 00000000..147d5139 --- /dev/null +++ b/sys/gio/ncarutil/tests/dashsmtht.f @@ -0,0 +1,144 @@ + SUBROUTINE TDASHS (IERROR) +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE TO PROVIDE A DEMONSTRATION OF DASHSMTH +C AND TO TEST DASHSMTH ON A SIMPLE PROBLEM +C +C USAGE CALL TDASHS (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST IS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C DASHSMTH TEST SUCCESSFUL . . . SEE PLOT +C TO VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C +C IN ADDITION, ONE FRAME CONTAINING THE +C DASHED LINE PLOT IS PRODUCED ON THE +C MACHINE GRAPHICS DEVICE. TO DETERMINE +C IF THE TEST IS SUCCESSFUL, IT IS NECESSARY +C TO EXAMINE THIS PLOT. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY DASHSMTH +C FILES +C +C LANGUAGE FORTRAN +C +C ALGORITHM TDASHS UTILIZES THE SOFTWARE DASHSMTH +C SUBROUTINES DASHDB, DASHDC, FRSTD, +C VECTD, LASTD, LINED AND CURVED TO +C DRAW FIVE CURVES ON ONE PICTURE USING +C FIVE DIFFERENT DASHSMTH PATTERNS. EACH +C CURVE IS CENTERED ABOUT SOLID AXIS LINES AND +C LABELLED WITH THE CHARACTER REPRESENTATION OF +C THE DASHSMTH PATTERN USED. +C +C PORTABILITY FORTRAN 77 +C +C X CONTAINS ABSCISSAE VALUES OF THE CURVE TO BE PLOTTED, Y CONTAINS +C ORDINATE VALUES OF THE CURVE TO BE PLOTTED. +C + DIMENSION X(31) ,Y(31) +C +C SELECT NORMALIZATION TRANSFORMATION 0 +C + CALL GSELNT(0) +C +C SET SOLID DASH PATTERN, 1111111111111111 (BINARY). +C BOOLEAN OPERATIONS (EMPLOYING LOCALLY IMPLEMENTED SUPPORT +C ROUTINES) ARE USED FOR PORTABILITY TO HOSTS WITH 16 BIT +C INTEGERS. +C + ISOLID = IOR (ISHIFT (32767,1), 1) +C + DO 130 K=1,5 + CALL DASHDB (ISOLID) + ORG =1.07-0.195*K +C +C DRAW CENTRAL AXIS FOR EACH CURVE +C + CALL FRSTD (.50,ORG-0.03) + CALL VECTD (.50,ORG+0.03) + CALL LASTD + CALL LINED (.109,ORG,.891,ORG) +C +C CALL SUBROUTINE DASHDC WITH A DIFFERENT DASHED LINE AND CHARACTER +C COMBINATION FOR EACH OF FIVE CURVES +C + GO TO ( 10, 20, 30, 40, 50),K + 10 CALL DASHDC ('$''$''$''$''$''$''$''$K = 1',10,12) + GO TO 60 + 20 CALL DASHDC ('$$$$$$''$''$$$$$$K = 2',10,12) + GO TO 60 + 30 CALL DASHDC ('$$$$''$$$$''$$$$''K = 3',10,12) + GO TO 60 + 40 CALL DASHDC ('$$$$$''''''''''$$$$$K = 4',10,12) + GO TO 60 + 50 CALL DASHDC ('$$$''$$$''$$$''$$$K = 5',10,12) + 60 CONTINUE +C +C COMPUTE VALUES FOR AND DRAW THE KTH CURVE +C + DO 70 I=1,31 + THETA = FLOAT(I-1)*3.1415926535897932/15. + X(I) = 0.5+.4*COS(THETA) + Y(I) = ORG+.075*SIN(FLOAT(K)*THETA) + 70 CONTINUE + CALL CURVED (X,Y,31) +C +C LABEL EACH CURVE WITH THE APPROPRIATE CHARACTER REPRESENTATION +C OF THE DASHSMTH PATTERN. IN THE PATTERN LABELS, A AND D +C SHOULD BE INTERPRETED AS APOSTROPHE AND DOLLAR SIGN. +C +C +C SET TEXT ALIGNMENT TO CENTER THE STRING AT THE LEFT OF THE +C STRING AND IN THE VERTICAL CENTER +C + CALL GSTXAL(1,3) +C +C SET CHARACTER HEIGHT +C + CALL GSCHH(.012) +C + ORY = ORG+.089 + GO TO ( 80, 90,100,110,120),K + 80 CALL GTX(.1,ORY,'IPAT=DADADADADADADADK=1') + GO TO 130 + 90 CALL GTX(.1,ORY,'IPAT=DDDDDDADADDDDDDK=2') + GO TO 130 + 100 CALL GTX(.1,ORY,'IPAT=DDDDADDDDADDDDAK=3') + GO TO 130 + 110 CALL GTX(.1,ORY,'IPAT=DDDDDAAAAADDDDDK=4') + GO TO 130 + 120 CALL GTX(.1,ORY,'IPAT=DDDADDDADDDADDDK=5') +C + 130 CONTINUE +C + CALL GSTXAL(2,3) + CALL GTX (.5,.991,'DEMONSTRATION PLOT FOR DASHSMTH') + CALL GTX (.5,.015,'IN IPAT STRINGS, A AND D SHOULD BE INTERPRETED + 1AS APOSTROPHE AND DOLLAR SIGN') +C +C ADVANCE FRAME +C +c CALL NEWFM +C + IERROR = 0 +c WRITE (6,1001) +C + RETURN +C +c 1001 FORMAT (' DASHSMTH TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/dashsuprt.f b/sys/gio/ncarutil/tests/dashsuprt.f new file mode 100644 index 00000000..f35c9c8b --- /dev/null +++ b/sys/gio/ncarutil/tests/dashsuprt.f @@ -0,0 +1,151 @@ + SUBROUTINE TDASHP (IERROR) +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE TO PROVIDE A DEMONSTRATION OF DASHSUPR +C AND TO TEST DASHSUPR ON A SIMPLE PROBLEM +C +C USAGE CALL TDASHP (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST IS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C DASHSUPR TEST SUCCESSFUL . . . SEE PLOT +C TO VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C +C IN ADDITION, ONE FRAME CONTAINING THE +C DASHED LINE PLOT IS PRODUCED ON THE +C MACHINE GRAPHICS DEVICE. TO DETERMINE +C IF THE TEST IS SUCCESSFUL, IT IS NECESSARY +C TO EXAMINE THIS PLOT. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY DASHSUPR +C FILES +C +C LANGUAGE FORTRAN +C +C ALGORITHM TDASHP UTILIZES THE SOFTWARE DASHSUPR +C SUBROUTINES DASHDB, DASHDC, FRSTD, +C VECTD, LASTD, LINED AND CURVED TO +C DRAW FIVE CURVES ON ONE PICTURE USING +C FIVE DIFFERENT DASHSMTH PATTERNS. EACH +C CURVE IS CENTERED ABOUT SOLID AXIS LINES AND +C LABELLED WITH THE CHARACTER REPRESENTATION OF +C THE DASHSUPR PATTERN USED. +C +C PORTABILITY FORTRAN 77 +C +C X CONTAINS ABSCISSAE VALUES OF THE CURVE TO BE PLOTTED, Y CONTAINS +C ORDINATE VALUES OF THE CURVE TO BE PLOTTED. +C + DIMENSION X(31) ,Y(31) +C +C SELECT NORMALIZATION TRANSFORMATION 0 +C + CALL GSELNT(0) +C +C RESET INITIALIZES THE MODEL PICTURE ARRAY AND SHOULD BE CALLED WITH +C EACH NEW FRAME AND BEFORE THE OTHER SUBROUTINES OF THE DASHSUPR +C PACKAGE. +C + CALL RESET +C +C +C SET SOLID DASH PATTERN, 1111111111111111 (BINARY). +C BOOLEAN OPERATIONS (EMPLOYING LOCALLY IMPLEMENTED PLOT PACKAGE +C SUPPORT ROUTINES) ARE USED FOR PORTABILITY TO HOSTS WITH 16 BIT +C INTEGERS. +C + ISOLID = IOR (ISHIFT (32767,1), 1) +C + DO 130 K=1,5 + CALL DASHDB (ISOLID) + ORG =1.07-0.195*K +C +C DRAW CENTRAL AXIS FOR EACH CURVE +C + CALL FRSTD (.50,ORG-0.03) + CALL VECTD (.50,ORG+0.03) + CALL LASTD + CALL LINED (.109,ORG,.891,ORG) +C +C CALL SUBROUTINE DASHDC WITH A DIFFERENT DASHED LINE AND CHARACTER +C COMBINATION FOR EACH OF FIVE CURVES +C + GO TO ( 10, 20, 30, 40, 50),K + 10 CALL DASHDC ('$''$''$''$''$''$''$''$K = 1',10,12) + GO TO 60 + 20 CALL DASHDC ('$$$$$$''$''$$$$$$K = 2',10,12) + GO TO 60 + 30 CALL DASHDC ('$$$$''$$$$''$$$$''K = 3',10,12) + GO TO 60 + 40 CALL DASHDC ('$$$$$''''''''''$$$$$K = 4',10,12) + GO TO 60 + 50 CALL DASHDC ('$$$''$$$''$$$''$$$K = 5',10,12) + 60 CONTINUE +C +C COMPUTE VALUES FOR AND DRAW THE KTH CURVE +C + DO 70 I=1,31 + THETA = FLOAT(I-1)*3.1415926535897932/15. + X(I) = 0.5+.4*COS(THETA) + Y(I) = ORG+.075*SIN(FLOAT(K)*THETA) + 70 CONTINUE + CALL CURVED (X,Y,31) +C +C LABEL EACH CURVE WITH THE APPROPRIATE CHARACTER REPRESENTATION +C OF THE DASHSMTH PATTERN. IN THE PATTERN LABELS, A AND D +C SHOULD BE INTERPRETED AS APOSTROPHE AND DOLLAR SIGN. +C +C +C SET TEXT ALIGNMENT TO CENTER THE STRING AT THE LEFT OF THE +C STRING AND IN THE VERTICAL CENTER +C + CALL GSTXAL(1,3) +C +C SET CHARACTER HEIGHT +C + CALL GSCHH(.012) +C + ORY = ORG+.089 + GO TO ( 80, 90,100,110,120),K + 80 CALL GTX(.1,ORY,'IPAT=DADADADADADADADK=1') + GO TO 130 + 90 CALL GTX(.1,ORY,'IPAT=DDDDDDADADDDDDDK=2') + GO TO 130 + 100 CALL GTX(.1,ORY,'IPAT=DDDDADDDDADDDDAK=3') + GO TO 130 + 110 CALL GTX(.1,ORY,'IPAT=DDDDDAAAAADDDDDK=4') + GO TO 130 + 120 CALL GTX(.1,ORY,'IPAT=DDDADDDADDDADDDK=5') +C + 130 CONTINUE +C + CALL GSTXAL(2,3) + CALL GTX (.5,.991,'DEMONSTRATION PLOT FOR DASHSUPR') + CALL GTX (.5,.013,'IN IPAT STRINGS, A AND D SHOULD BE INTERPRETED + 1AS APOSTROPHE AND DOLLAR SIGN') +C +C ADVANCE FRAME +C + CALL NEWFM +C + IERROR = 0 + WRITE (6,1001) +C + RETURN +C + 1001 FORMAT (' DASHSUPR TEST SUCCESSFUL',24X, + 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/ezconrec.x b/sys/gio/ncarutil/tests/ezconrec.x new file mode 100644 index 00000000..afb0775c --- /dev/null +++ b/sys/gio/ncarutil/tests/ezconrec.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +# T_EZCONREC -- test NCAR contour routine EZCNTR. + +procedure t_ezconrec () + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tconre (1, error_code) + if (error_code == 0) + call printf ("Test successful\n") + else + call printf ("Test was not successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () + +end diff --git a/sys/gio/ncarutil/tests/ezhafton.x b/sys/gio/ncarutil/tests/ezhafton.x new file mode 100644 index 00000000..e1cbbc2c --- /dev/null +++ b/sys/gio/ncarutil/tests/ezhafton.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +procedure t_ezhafton + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call zhafto (error_code) + if (error_code == 0) + call printf ("Test successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/ezhaftont.f b/sys/gio/ncarutil/tests/ezhaftont.f new file mode 100644 index 00000000..b3fcee3b --- /dev/null +++ b/sys/gio/ncarutil/tests/ezhaftont.f @@ -0,0 +1,123 @@ + SUBROUTINE ZHAFTO (IERROR) +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C EZHAFTON AND TO TEST HAFTON ON A SINGLE +C PROBLEM +C +C USAGE CALL ZHAFTO (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST WAS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C HAFTON TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, TWO FRAMES CONTAINING THE +C HALF-TONE PLOT ARE PRODUCED ON THE MACHINE +C GRAPHICS DEVICE. IN ORDER TO DETERMINE IF THE +C TEST WAS SUCCESSFUL, IT IS NECESSARY TO EXAMINE +C THESE PLOTS. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY HAFTON +C FILES +C +C LANGUAGE ANSI FORTRAN 77 +C +C ALGORITHM THE FUNCTION +C Z(X,Y) = X + Y + 1./((X-.1)**2+Y**2+.09) +C -1./((X+.1)**2+Y**2+.09) +C FOR X = -1. TO +1. IN INCREMENTS OF .1 AND +C Y = -1.2 TO +1.2 IN INCREMENTS OF .1 +C IS COMPUTED. +C THAFTO CALLS SUBROUTINES EZHFTN AND HAFTON TO +C DRAW TWO HALF-TONE PLOTS OF THE ARRAY Z. +C +C PORTABILITY ANSI STANDARD +C +C +C Z CONTAINS THE VALUES TO BE PLOTTED. +C +C + REAL Z(21,25) +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX AND TY +C DEFINE THE CENTER OF THE LEFT EDGE OF THE TITLE STRING. +C + DATA TX/0.0762/, TY/0.9769/ +C +C SPECIFY SOME ARGUMENT VALUES FOR ROUTINE HAFTON. +C FLO CONTAINS THE LOW VALUE DESIGNATION FOR HAFTON, FHI +C CONTAINS THE HIGH VALUE DESIGNATION FOR HAFTON, NLEV +C SPECIFIES THE NUMBER OF UNIQUE LEVELS BETWEEN FLO AND FHI, THE +C ABSOLUTE VALUE OF NOPT DETERMINES THE MAPPING OF Z ONTO THE +C INTENSITIES, AND THE SIGN OF NOPT CONTROLS THE DIRECTNESS OR +C INVERSNESS OF THE MAPPING. +C + DATA FLO/-4.0/, FHI/4.0/, NLEV/8/, NOPT/-3/ +C +C + SAVE +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 0 +C +C FILL TWO DIMENSIONAL ARRAY TO BE PLOTTED +C + DO 20 I=1,21 + X = .1*FLOAT(I-11) + DO 10 J=1,25 + Y = .1*FLOAT(J-13) + Z(I,J) = X+Y+1./((X-.10)**2+Y**2+.09)- + 1 1./((X+.10)**2+Y**2+.09) + 10 CONTINUE + 20 CONTINUE +C +C SELECT NORMALIZATION TRANS 0 FOR PLOTTING TITLE +C + CALL GSELNT (0) +C +C +C +C ENTRY EZHFTN REQUIRES ONLY THE ARRAY NAME AND ITS DIMENSIONS +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR ENTRY EZHFTN OF HAFTON +C + CALL WTSTR (TX,TY, + 1 'DEMONSTRATION PLOT FOR ENTRY EZHFTN OF HAFTON',2,0,-1) + CALL EZHFTN (Z,21,25) +C +C ENTRY HAFTON ALLOWS USER SPECIFICATIONS OF PLOT PARAMETERS, IF DESIRED +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR ENTRY HAFTON OF HAFTON +C +c CALL GSELNT (0) +c CALL WTSTR (TX,TY, +c 1 'DEMONSTRATION PLOT FOR ENTRY HAFTON OF HAFTON',2,0,-1) +c CALL HAFTON (Z,21,21,25,FLO,FHI,NLEV,NOPT,0,0,0.) +c CALL NEWFM +C +c WRITE (6,1001) + RETURN +C +C +c1001 FORMAT (' HAFTON TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/ezisosrf.x b/sys/gio/ncarutil/tests/ezisosrf.x new file mode 100644 index 00000000..21257526 --- /dev/null +++ b/sys/gio/ncarutil/tests/ezisosrf.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +# Test NCAR routine EZISOSRF + +procedure t_ezisos() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tisosr (1, error_code) + if (error_code == 0) + call printf ("Test successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/ezmapg.x b/sys/gio/ncarutil/tests/ezmapg.x new file mode 100644 index 00000000..d2f7dce1 --- /dev/null +++ b/sys/gio/ncarutil/tests/ezmapg.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +# Test NCAR routine SUPMAP of the EZMAPG utility. + +procedure t_ezmapg() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tsupma (error_code) + if (error_code == 0) + call printf ("Test successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/ezmapgt.f b/sys/gio/ncarutil/tests/ezmapgt.f new file mode 100644 index 00000000..fab53ce0 --- /dev/null +++ b/sys/gio/ncarutil/tests/ezmapgt.f @@ -0,0 +1,318 @@ + SUBROUTINE TSUPMA (IERROR) +C +C LATEST REVISION AUGUST 1984 +C +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF THE +C SUPMAP AND MAPDRW ENTRYS OF EZMAPG. +C +C USAGE CALL TSUPMA (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0 IF THE TEST WAS SUCCESSFUL +C = 1 OTHERWISE +C +C I/O IF EACH CALL TO ROUTINE SUPMAP RESULTS IN +C A NORMAL SUPMAP EXIT, THE MESSAGE +C SUPMAP TEST SUCCESSFUL . . SEE PLOT TO +C VERIFY PERFORMANCE +C IS PRINTED ON UNIT 6. +C +C TEN CONTINENTAL OUTLINE PLOTS, EACH +C RESULTING FROM A DIFFERENT SPECIFIED +C PROJECTION, ARE PRODUCED ON THE MACHINE +C GRAPHICS DEVICE. +C TO DETERMINE IF THE TEST WAS SUCCESSFUL, +C IT IS NECESSARY TO EXAMINE THESE PLOTS. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY EZMAPG +C FILES +C +C LANGUAGE FORTRAN +C +C ALGORITHM SUBROUTINE TSUPMA CALLS ROUTINE SUPMAP ONCE +C FOR EACH OF THE NINE PROJECTION TYPES +C IN SUPMAP. SPECIFICALLY, THESE ARE +C STEREOGRAPHIC +C ORTHOGRAPHIC +C LAMBERT CONFORMAL CONIC WITH TWO +C STANDARD PARALLELS +C LAMBERT EQUAL AREA +C GNOMONIC +C AZIMUTHAL EQUIDISTANT +C CYLINDRICAL EQUIDISTANT +C MERCATOR +C MOLLWEIDE TYPE +C THE ROUTINE THEN DEMONSTRATES THE SATELLITE VIEW +C PROJECTION. +C +C HISTORY WRITTEN OCTOBER, 1976 +C +C PORTABILITY ANSI FORTRAN 77 +C +C +C COMMON BLOCK FOR SATELLITE VIEW PROJECTION +C + COMMON /SATMAP/ SL +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT PLOTTER GRID +C WHERE THE COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX +C AND TY DEFINE THE CENTER OF THE TITLE STRING. +C + DATA TX/0.5/, TY/0.9765/ +C +C INITIALIZE ERROR FLAG +C + IERROR = 0 +C +C CHECK PERFORMANCE CRITERION +C SPECIFY PARAMETERS BEFORE EACH SUPMAP CALL +C + IPROJ = 1 + POLAT = 80. + POLONG = -160. + ROT = 0. + PL1 = 0. + PL2 = 0. + PL3 = 0. + PL4 = 0. + JLTS = 1 + JGRID = 10 + IUSOUT = -1 + IDOT = 0 +C +C SELECT NORMALIZATION TRANS 0 TO WRITE TITLE +C + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: STEREOGRAPHIC PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) +c CALL NEWFM + IF (IER .EQ. 0) GO TO 10 +C +C SUPMAP TEST UNSUCCESSFUL +C +c WRITE (6,1001) IPROJ + IERROR = 1 + 10 CONTINUE +C +C + IPROJ = 2 + POLAT = 60. + POLONG = -120. + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: ORTHOGRAPHIC PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) +c +noao: frame advance handled by calling routine +c CALL NEWFM +c -noao + IF (IER .EQ. 0) GO TO 20 +C +C SUPMAP TEST UNSUCCESSFUL +C +c WRITE (6,1001) IPROJ + IERROR = 1 + 20 CONTINUE +C +C + IPROJ = -3 + POLAT = 45. + POLONG = -100. + ROT = 45. + PL1 = 50. + PL2 = -130. + PL3 = 20. + PL4 = -75. + JLTS = 2 + JGRID = 10 + IUSOUT = 1 + IDOT = 0 + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: LAMBERT CONFORMAL CONIC PROJECTION' + 2 ,2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) +c +noao: frame advance is handled by calling routine +c CALL NEWFM +c -noao + IF (IER .EQ. 0) GO TO 30 +C +C SUPMAP TEST UNSUCCESSFUL +C +c WRITE (6,1001) IPROJ + IERROR = 1 + 30 CONTINUE +C +C + IPROJ = 4 + POLAT = 20. + POLONG = -40. + ROT = 0. + PL1 = 0. + PL2 = 0. + PL3 = 0. + PL4 = 0. + JLTS = 1 + JGRID = 10 + IUSOUT = -1 + IDOT = 0 + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: LAMBERT EQUAL AREA PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) +c +noao: frame advance is handled by calling routine +c CALL NEWFM +c -nooa + IF (IER .EQ. 0) GO TO 40 +C +C SUPMAP TEST UNSUCCESSFUL +C +C WRITE (6,1001) IPROJ + IERROR = 1 + 40 CONTINUE +C +C + IPROJ = 5 + POLAT = 0. + POLONG = 0. + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: GNOMONIC PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) +c +noao: frame advance handled by calling routine +c CALL NEWFM +c -noao + IF (IER .EQ. 0) GO TO 50 +C +C SUPMAP TEST UNSUCCESSFUL +C +c WRITE (6,1001) IPROJ + IERROR = 1 + 50 CONTINUE +C +C + IPROJ = 6 + POLAT = -20. + POLONG = 40. + JGRID = 5 + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: AZIMUTHAL EQUIDISTANT PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) +c +noao: frame advance handled by calling routine +c CALL NEWFM +c -noao + IF (IER .EQ. 0) GO TO 60 +C +C SUPMAP TEST UNSUCCESSFUL +C +c WRITE (6,1001) IPROJ + IERROR = 1 + 60 CONTINUE +C +C + IPROJ = 8 + POLAT = -40. + POLONG = 80. + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: CYLINDRICAL EQUIDISTANT PROJECTION' + 2 ,2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) +c +noao: frame advance handled by calling routine +c CALL NEWFM +c -noao + IF (IER .EQ. 0) GO TO 70 +C +C SUPMAP TEST UNSUCCESSFUL +C +c WRITE (6,1001) IPROJ + IERROR = 1 + 70 CONTINUE +C +C + IPROJ = 9 + POLAT = -60. + POLONG = 120. + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: MERCATOR PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) +c +noao: frame advance handled by calling routine +c CALL NEWFM +c -noao + IF (IER .EQ. 0) GO TO 80 +C +C SUPMAP TEST UNSUCCESSFUL +C +c WRITE (6,1001) IPROJ + IERROR = 1 + 80 CONTINUE +C +C + IPROJ = 10 + POLAT = -80. + POLONG = 160. + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: MOLLWEIDE TYPE PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) +c +noao: frame advance handled by calling routine +c CALL NEWFM +c -noao + IF (IER .EQ. 0) GO TO 90 +C +C SUPMAP TEST UNSUCCESSFUL +C +c WRITE (6,1001) IPROJ + IERROR = 1 + 90 CONTINUE +C +C DEMONSTRATION OF SATELLITE VIEW PROJECTION +C + SL = 6.5 + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'EZMAPG DEMONSTRATION: SATELLITE VIEW PROJECTION', + 2 2,0,0) + CALL MAPROJ('OR',0.0,-135.0,0.0) + CALL MAPSET('MA',0.0,0.0,0.0,0.0) + CALL MAPDRW +c +noao: frame advance handled by calling routine +c CALL NEWFM +c -noao +C +C +c IF (IERROR .EQ. 0) WRITE (6,1002) +c IF (IERROR .EQ. 1) WRITE (6,1003) + RETURN +C +C +c1001 FORMAT (' SUPMAP RETURNED ERROR FLAG',' IPROJ=',I4/) +c1002 FORMAT(' SUPMAP TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +c1003 FORMAT (' SUPMAP TEST UNSUCCESSFUL') +C + END diff --git a/sys/gio/ncarutil/tests/ezmapt.f b/sys/gio/ncarutil/tests/ezmapt.f new file mode 100644 index 00000000..330fe6e2 --- /dev/null +++ b/sys/gio/ncarutil/tests/ezmapt.f @@ -0,0 +1,300 @@ + SUBROUTINE TSUPMA (IERROR) +C +C LATEST REVISION AUGUST 1984 +C +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF THE +C SUPMAP AND MAPDRW ENTRYS OF EZMAPG. +C +C USAGE CALL TSUPMA (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0 IF THE TEST WAS SUCCESSFUL +C = 1 OTHERWISE +C +C I/O IF EACH CALL TO ROUTINE SUPMAP RESULTS IN +C A NORMAL SUPMAP EXIT, THE MESSAGE +C SUPMAP TEST SUCCESSFUL . . SEE PLOT TO +C VERIFY PERFORMANCE +C IS PRINTED ON UNIT 6. +C +C TEN CONTINENTAL OUTLINE PLOTS, EACH +C RESULTING FROM A DIFFERENT SPECIFIED +C PROJECTION, ARE PRODUCED ON THE MACHINE +C GRAPHICS DEVICE. +C TO DETERMINE IF THE TEST WAS SUCCESSFUL, +C IT IS NECESSARY TO EXAMINE THESE PLOTS. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY EZMAPG +C FILES +C +C LANGUAGE FORTRAN +C +C ALGORITHM SUBROUTINE TSUPMA CALLS ROUTINE SUPMAP ONCE +C FOR EACH OF THE NINE PROJECTION TYPES +C IN SUPMAP. SPECIFICALLY, THESE ARE +C STEREOGRAPHIC +C ORTHOGRAPHIC +C LAMBERT CONFORMAL CONIC WITH TWO +C STANDARD PARALLELS +C LAMBERT EQUAL AREA +C GNOMONIC +C AZIMUTHAL EQUIDISTANT +C CYLINDRICAL EQUIDISTANT +C MERCATOR +C MOLLWEIDE TYPE +C THE ROUTINE THEN DEMONSTRATES THE SATELLITE VIEW +C PROJECTION. +C +C HISTORY WRITTEN OCTOBER, 1976 +C +C PORTABILITY ANSI FORTRAN 77 +C +C +C COMMON BLOCK FOR SATELLITE VIEW PROJECTION +C + COMMON /SATMAP/ SL +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT PLOTTER GRID +C WHERE THE COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX +C AND TY DEFINE THE CENTER OF THE TITLE STRING. +C + DATA TX/0.5/, TY/0.9765/ +C +C INITIALIZE ERROR FLAG +C + IERROR = 0 +C +C CHECK PERFORMANCE CRITERION +C SPECIFY PARAMETERS BEFORE EACH SUPMAP CALL +C + IPROJ = 1 + POLAT = 80. + POLONG = -160. + ROT = 0. + PL1 = 0. + PL2 = 0. + PL3 = 0. + PL4 = 0. + JLTS = 1 + JGRID = 10 + IUSOUT = -1 + IDOT = 0 +C +C SELECT NORMALIZATION TRANS 0 TO WRITE TITLE +C + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: STEREOGRAPHIC PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) + CALL FRAME + IF (IER .EQ. 0) GO TO 10 +C +C SUPMAP TEST UNSUCCESSFUL +C + WRITE (6,1001) IPROJ + IERROR = 1 + 10 CONTINUE +C +C + IPROJ = 2 + POLAT = 60. + POLONG = -120. + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: ORTHOGRAPHIC PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) + CALL FRAME + IF (IER .EQ. 0) GO TO 20 +C +C SUPMAP TEST UNSUCCESSFUL +C + WRITE (6,1001) IPROJ + IERROR = 1 + 20 CONTINUE +C +C + IPROJ = -3 + POLAT = 45. + POLONG = -100. + ROT = 45. + PL1 = 50. + PL2 = -130. + PL3 = 20. + PL4 = -75. + JLTS = 2 + JGRID = 10 + IUSOUT = 1 + IDOT = 0 + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: LAMBERT CONFORMAL CONIC PROJECTION' + 2 ,2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) + CALL FRAME + IF (IER .EQ. 0) GO TO 30 +C +C SUPMAP TEST UNSUCCESSFUL +C + WRITE (6,1001) IPROJ + IERROR = 1 + 30 CONTINUE +C +C + IPROJ = 4 + POLAT = 20. + POLONG = -40. + ROT = 0. + PL1 = 0. + PL2 = 0. + PL3 = 0. + PL4 = 0. + JLTS = 1 + JGRID = 10 + IUSOUT = 0 + IDOT = 0 + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: LAMBERT EQUAL AREA PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) + CALL FRAME + IF (IER .EQ. 0) GO TO 40 +C +C SUPMAP TEST UNSUCCESSFUL +C + WRITE (6,1001) IPROJ + IERROR = 1 + 40 CONTINUE +C +C + IPROJ = 5 + POLAT = 0. + POLONG = 0. + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: GNOMONIC PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) + CALL FRAME + IF (IER .EQ. 0) GO TO 50 +C +C SUPMAP TEST UNSUCCESSFUL +C + WRITE (6,1001) IPROJ + IERROR = 1 + 50 CONTINUE +C +C + IPROJ = 6 + POLAT = -20. + POLONG = 40. + JGRID = 5 + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: AZIMUTHAL EQUIDISTANT PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) + CALL FRAME + IF (IER .EQ. 0) GO TO 60 +C +C SUPMAP TEST UNSUCCESSFUL +C + WRITE (6,1001) IPROJ + IERROR = 1 + 60 CONTINUE +C +C + IPROJ = 8 + POLAT = -40. + POLONG = 80. + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: CYLINDRICAL EQUIDISTANT PROJECTION' + 2 ,2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) + CALL FRAME + IF (IER .EQ. 0) GO TO 70 +C +C SUPMAP TEST UNSUCCESSFUL +C + WRITE (6,1001) IPROJ + IERROR = 1 + 70 CONTINUE +C +C + IPROJ = 9 + POLAT = -60. + POLONG = 120. + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: MERCATOR PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) + CALL FRAME + IF (IER .EQ. 0) GO TO 80 +C +C SUPMAP TEST UNSUCCESSFUL +C + WRITE (6,1001) IPROJ + IERROR = 1 + 80 CONTINUE +C +C + IPROJ = 10 + POLAT = -80. + POLONG = 160. + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'SUPMAP DEMONSTRATION: MOLLWEIDE TYPE PROJECTION', + 2 2,0,0) + CALL SUPMAP (IPROJ,POLAT,POLONG,ROT,PL1,PL2,PL3,PL4,JLTS,JGRID, + 1 IUSOUT,IDOT,IER) + CALL FRAME + IF (IER .EQ. 0) GO TO 90 +C +C SUPMAP TEST UNSUCCESSFUL +C + WRITE (6,1001) IPROJ + IERROR = 1 + 90 CONTINUE +C +C DEMONSTRATION OF SATELLITE VIEW PROJECTION +C + SL = 6.5 + CALL GSELNT (0) + CALL WTSTR(TX,TY, + 1 'EZMAPG DEMONSTRATION: SATELLITE VIEW PROJECTION', + 2 2,0,0) + CALL MAPROJ('OR',0.0,-135.0,0.0) + CALL MAPSET('MA',0.0,0.0,0.0,0.0) + CALL MAPDRW + CALL FRAME +C +C + IF (IERROR .EQ. 0) WRITE (6,1002) + IF (IERROR .EQ. 1) WRITE (6,1003) + RETURN +C +C + 1001 FORMAT (' SUPMAP RETURNED ERROR FLAG',' IPROJ=',I4/) + 1002 FORMAT(' SUPMAP TEST SUCCESSFUL',24X, + 1 'SEE PLOT TO VERIFY PERFORMANCE') + 1003 FORMAT (' SUPMAP TEST UNSUCCESSFUL') +C + END diff --git a/sys/gio/ncarutil/tests/ezsurface.x b/sys/gio/ncarutil/tests/ezsurface.x new file mode 100644 index 00000000..75abf061 --- /dev/null +++ b/sys/gio/ncarutil/tests/ezsurface.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +# Test NCAR routine EZSRF. + +procedure t_ezsurface() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tsrfac (1, error_code) + if (error_code == 0) + call printf ("Test of EZSRF successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/ezvelvect.x b/sys/gio/ncarutil/tests/ezvelvect.x new file mode 100644 index 00000000..aeb5a5ab --- /dev/null +++ b/sys/gio/ncarutil/tests/ezvelvect.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +# Test NCAR routines EZVELVEC + +procedure t_ezvelvect() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tvelvc (1, error_code) + if (error_code == 0) + call printf ("Test successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/ezytst.x b/sys/gio/ncarutil/tests/ezytst.x new file mode 100644 index 00000000..b3ac1cb1 --- /dev/null +++ b/sys/gio/ncarutil/tests/ezytst.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include +include + +# Test NCAR routine AUTOGRAPH - EZXY, EZMXY etc. + +task ezytst = t_ezytst + +procedure t_ezytst() + +char device[SZ_FNAME], title[SZ_LINE] +int wkid, i +real y_vector[512] +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + # Construct vector to be plotted + do i = 1, 512 + y_vector[i] = i + + call strcpy ("TIMING TEST: 512 POINT VECTOR$", title, SZ_LINE) + call ezy (y_vector(1), 512, 'Timing Test: 512 Point Vector$') + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/hafton.x b/sys/gio/ncarutil/tests/hafton.x new file mode 100644 index 00000000..63795b22 --- /dev/null +++ b/sys/gio/ncarutil/tests/hafton.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +procedure t_hafton + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call thafto (error_code) + if (error_code == 0) + call printf ("Test successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/haftont.f b/sys/gio/ncarutil/tests/haftont.f new file mode 100644 index 00000000..b4cfe017 --- /dev/null +++ b/sys/gio/ncarutil/tests/haftont.f @@ -0,0 +1,123 @@ + SUBROUTINE THAFTO (IERROR) +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C HAFTON AND TO TEST HAFTON ON A SINGLE +C PROBLEM +C +C USAGE CALL THAFTO (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST WAS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C HAFTON TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, TWO FRAMES CONTAINING THE +C HALF-TONE PLOT ARE PRODUCED ON THE MACHINE +C GRAPHICS DEVICE. IN ORDER TO DETERMINE IF THE +C TEST WAS SUCCESSFUL, IT IS NECESSARY TO EXAMINE +C THESE PLOTS. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY HAFTON +C FILES +C +C LANGUAGE ANSI FORTRAN 77 +C +C ALGORITHM THE FUNCTION +C Z(X,Y) = X + Y + 1./((X-.1)**2+Y**2+.09) +C -1./((X+.1)**2+Y**2+.09) +C FOR X = -1. TO +1. IN INCREMENTS OF .1 AND +C Y = -1.2 TO +1.2 IN INCREMENTS OF .1 +C IS COMPUTED. +C THAFTO CALLS SUBROUTINES EZHFTN AND HAFTON TO +C DRAW TWO HALF-TONE PLOTS OF THE ARRAY Z. +C +C PORTABILITY ANSI STANDARD +C +C +C Z CONTAINS THE VALUES TO BE PLOTTED. +C +C + REAL Z(21,25) +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX AND TY +C DEFINE THE CENTER OF THE LEFT EDGE OF THE TITLE STRING. +C + DATA TX/0.0762/, TY/0.9769/ +C +C SPECIFY SOME ARGUMENT VALUES FOR ROUTINE HAFTON. +C FLO CONTAINS THE LOW VALUE DESIGNATION FOR HAFTON, FHI +C CONTAINS THE HIGH VALUE DESIGNATION FOR HAFTON, NLEV +C SPECIFIES THE NUMBER OF UNIQUE LEVELS BETWEEN FLO AND FHI, THE +C ABSOLUTE VALUE OF NOPT DETERMINES THE MAPPING OF Z ONTO THE +C INTENSITIES, AND THE SIGN OF NOPT CONTROLS THE DIRECTNESS OR +C INVERSNESS OF THE MAPPING. +C + DATA FLO/-4.0/, FHI/4.0/, NLEV/8/, NOPT/-3/ +C +C + SAVE +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 0 +C +C FILL TWO DIMENSIONAL ARRAY TO BE PLOTTED +C + DO 20 I=1,21 + X = .1*FLOAT(I-11) + DO 10 J=1,25 + Y = .1*FLOAT(J-13) + Z(I,J) = X+Y+1./((X-.10)**2+Y**2+.09)- + 1 1./((X+.10)**2+Y**2+.09) + 10 CONTINUE + 20 CONTINUE +C +C SELECT NORMALIZATION TRANS 0 FOR PLOTTING TITLE +C +c CALL GSELNT (0) +C +C +C +C ENTRY EZHFTN REQUIRES ONLY THE ARRAY NAME AND ITS DIMENSIONS +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR ENTRY EZHFTN OF HAFTON +C +c CALL WTSTR (TX,TY, +c 1 'DEMONSTRATION PLOT FOR ENTRY EZHFTN OF HAFTON',2,0,-1) +c CALL EZHFTN (Z,21,25) +C +C ENTRY HAFTON ALLOWS USER SPECIFICATIONS OF PLOT PARAMETERS, IF DESIRED +C +C THE TITLE FOR THIS PLOT IS +C +C DEMONSTRATION PLOT FOR ENTRY HAFTON OF HAFTON +C + CALL GSELNT (0) + CALL WTSTR (TX,TY, + 1 'DEMONSTRATION PLOT FOR ENTRY HAFTON OF HAFTON',2,0,-1) + CALL HAFTON (Z,21,21,25,FLO,FHI,NLEV,NOPT,0,0,0.) +c CALL NEWFM +C +c WRITE (6,1001) + RETURN +C +C +c1001 FORMAT (' HAFTON TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/isosrf.x b/sys/gio/ncarutil/tests/isosrf.x new file mode 100644 index 00000000..1216db50 --- /dev/null +++ b/sys/gio/ncarutil/tests/isosrf.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +# Test NCAR routine ISOSRFHR + +procedure t_isosrf() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tisosr (2, error_code) + if (error_code == 0) + call printf ("Test successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/isosrfhrt.f b/sys/gio/ncarutil/tests/isosrfhrt.f new file mode 100644 index 00000000..1d8fb249 --- /dev/null +++ b/sys/gio/ncarutil/tests/isosrfhrt.f @@ -0,0 +1,165 @@ + SUBROUTINE TISOHR (IERROR) +C +C LATEST REVISION JULY 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C THE ISOSRFHR PACKAGE +C +C USAGE CALL TISOHR (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C =0 IF THERE IS A NORMAL EXIT FROM THE +C ISOSRFHR ROUTINES +C =1 OTHERWISE +C +C I/O THIS ROUTINE REQUIRES UNIT IUNIT FOR SCRATCH +C PURPOSES. USERS SHOULD PUT THE UNITS LABELLED +C COMMON (SEE BELOW) IN THE CALLING PROGRAM, +C AND ALSO SET THE VALUE OF THE COMMON VARIABLE +C IUNIT IN THE CALLING PROGRAM. +C +C IF THERE IS A NORMAL EXIT FROM THE +C ISOSRFHR ROUTINES THE MESSAGE +C ISOSRFHR TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C IS PRINTED. +C +C ALSO, A SAMPLE PLOT IS +C PRODUCED ON THE MACHINE GRAPHICS +C DEVICE. ONE MUST EXAMINE THIS PLOT +C TO DETERMINE IF THE ROUTINES HAVE +C EXECUTED CORRECTLY. +C +C COMMON BLOCKS UNITS +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY ISOSRFHR +C FILES +C +C LANGUAGE FORTRAN +C +C ALGORITHM THIS SUBROUTINE USES THE ROUTINES IN +C THE PACKAGE ISOSRFHR TO DRAW A PERSPECTIVE +C DRAWING OF TWO INTERLOCKING DOUGHNUTS +C +C PORTABILITY ANSI STANDARD +C +C + DIMENSION EYE(3) ,S(4) ,IS2(4,200) , + 1 ST1(81,51,2) ,IOBJS(81,51) + COMMON /UNITS/ IUNIT +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE INTEGER COORDINATES RANGE FROM 1 TO 1024, THE VALUES IX AND IY +C DEFINE THE CENTER OF THE TITLE STRING. +C + DATA IX/448/, IY/990/ +C +C +C DEFINE THE EYE POSITION +C + DATA EYE(1), EYE(2), EYE(3) / 200., 250., 250. / +C +C DEFINE THE OVERALL DIMENSION OF THE BOX CONTAINING THE OBJECTS +C + DATA NU, NV, NW / 51, 81, 51 / +C +C SPECIFY THE DIMENSIONS OF THE MODEL OF THE IMAGE PLANE +C + DATA LX, NX, NY / 4, 180, 180 / +C +C SPECIFY CRT COORDINATES OF THE AREA WHERE THE PICTURE +C IS TO BE DRAWN +C + DATA S(1),S(2),S(3),S(4)/ 10.,1010.,10.,1010./ + DATA MV / 81 / +C +C SPECIFY THE LARGE AND SMALL RADII FOR THE INDIVIDUAL DOUGHNUTS +C + DATA RBIG1,RBIG2,RSML1,RSML2/ 20., 20., 6., 6. / +C + SAVE +C +C CALL THE INITIALIZATION ROUTINE +C + CALL INIT3D (EYE,NU,NV,NW,ST1,LX,NY,IS2,IUNIT,S) +C +C INITIALIZE THE ERRROR FLAG +C + IERROR = 1 +C +C CREATE AND PLOT DATA FOR TWO INTERLOCKING DOUGHNUTS +C + JCENT1 = FLOAT(NV)*.5-RBIG1*.5 + JCENT2 = FLOAT(NV)*.5+RBIG2*.5 + DO 70 IBKWDS=1,NU + I = NU+1-IBKWDS +C +C CREATE THE I-TH CROSS SECTION IN THE U DIRECTION OF THE +C THREE-DIMENSIONAL ARRAY AND STORE IN IOBJS AS ZEROS AND ONES +C + FIMID = I-NU/2 + DO 20 J=1,NV + FJMID1 = J-JCENT1 + FJMID2 = J-JCENT2 + DO 10 K=1,NW + FKMID = K-NW/2 + F1 = SQRT(RBIG1*RBIG1/(FJMID1*FJMID1+FKMID*FKMID+.1)) + F2 = SQRT(RBIG2*RBIG2/(FIMID*FIMID+FJMID2*FJMID2+.1)) + FIP1 = (1.-F1)*FIMID + FIP2 = (1.-F2)*FIMID + FJP1 = (1.-F1)*FJMID1 + FJP2 = (1.-F2)*FJMID2 + FKP1 = (1.-F1)*FKMID + FKP2 = (1.-F2)*FKMID + TEMP = AMIN1(FIMID**2+FJP1**2+FKP1**2-RSML1**2, + 1 FKMID**2+FIP2**2+FJP2**2-RSML2**2) + IF (TEMP .LE. 0.) IOBJS(J,K) = 1 + IF (TEMP .GT. 0.) IOBJS(J,K) = 0 + 10 CONTINUE + 20 CONTINUE +C +C SET PROPER WORDS TO 1 FOR DRAWING AXES +C + IF (I .NE. 1) GO TO 50 + DO 30 K=1,NW + IOBJS(1,K) = 1 + 30 CONTINUE + DO 40 J=1,NV + IOBJS(J,1) = 1 + 40 CONTINUE + GO TO 60 + 50 CONTINUE + IOBJS(1,1) = 1 + 60 CONTINUE +C +C CALL THE DRAW AND REMEMBER ROUTINE FOR THIS SLAB +C + CALL DANDR (NV,NW,ST1,LX,NX,NY,IS2,IUNIT,S,IOBJS,MV) + 70 CONTINUE +C +C TITLE THE PLOT +C + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = PAU2FX(IX) + YC = PAU2FY(IY) + CALL WTSTR(XC,YC,'DEMONSTRATION PLOT FOR ISOSRFHR',2,0,0) + CALL GSELNT(ICN) +C +C ADVANCE THE PLOTTING DEVICE +C +c CALL NEWFM +C + IERROR = 0 +c WRITE (6,1001) + RETURN +C +c1001 FORMAT (' ISOSRFHR TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/isosrft.f b/sys/gio/ncarutil/tests/isosrft.f new file mode 100644 index 00000000..1e99e02e --- /dev/null +++ b/sys/gio/ncarutil/tests/isosrft.f @@ -0,0 +1,137 @@ + SUBROUTINE TISOSR (nplot, IERROR) +C +C LATEST REVISION DECEMBER 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C ISOSRF AND TO TEST ISOSRF ON A SINGLE PROBLEM +C +C USAGE CALL TISOSR (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST WAS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C ISOSRF TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS WRITTEN ON UNIT 6. +C IN ADDITION, TWO FRAMES CONTAINING THE SAMPLE +C PLOTS ARE PRODUCED ON THE MACHINE GRAPHICS +C DEVICE. IN ORDER TO DETERMINE IF THE TEST +C WAS SUCCESSFUL, IT IS NECESSARY TO EXAMINE +C THESE PLOTS. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY ISOSRF FROM ULIB LIBRARY +C FILES +C +C LANGUAGE STANDARD FORTRAN77 +C +C HISTORY WRITTEN BY MEMBERS OF THE +C SCIENTIFIC COMPUTING DIVISION OF NCAR, +C BOULDER COLORADO +C +C ALGORITHM A FUNCTION OF THREE VARIABLES IS DEFINED, AND +C VALUES OF THE FUNCTION ON A THREE DIMENSIONAL +C RECTANGULAR GRID ARE STORED IN AN ARRAY. THIS +C SUBROUTINE CALLS EZISOS AND ISOSRF TO DRAW ISO- +C VALUED SURFACE PLOTS OF THE FUNCTION. +C +C PORTABILITY ANSI STANDARD +C +C + SAVE + DIMENSION T(21,31,19),SLAB(33,33),EYE(3) +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE INTEGER COORDINATES RANGE FROM 1 TO 1024, THE VALUES IX AND IY +C DEFINE THE CENTER OF THE TITLE STRING. +C + REAL IX,IY + DATA IX/.44/, IY/.95/ +C + DATA NU,NV,NW/21,31,19/ + DATA RBIG1,RBIG2,RSML1,RSML2/6.,6.,2.,2./ + DATA TISO/0./ + DATA MUVWP2/33/ + DATA IFLAG/-7/ +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 1 +C +C FILL THREE DIMENSIONAL ARRAY TO BE PLOTTED +C + JCENT1 = FLOAT(NV)*.5-RBIG1*.5 + JCENT2 = FLOAT(NV)*.5+RBIG2*.5 + DO 30 I=1,NU + FIMID = I-NU/2 + DO 20 J=1,NV + FJMID1 = J-JCENT1 + FJMID2 = J-JCENT2 + DO 10 K=1,NW + FKMID = K-NW/2 + F1 = SQRT(RBIG1*RBIG1/(FJMID1*FJMID1+FKMID*FKMID+.1)) + F2 = SQRT(RBIG2*RBIG2/(FIMID*FIMID+FJMID2*FJMID2+.1)) + FIP1 = (1.-F1)*FIMID + FIP2 = (1.-F2)*FIMID + FJP1 = (1.-F1)*FJMID1 + FJP2 = (1.-F2)*FJMID2 + FKP1 = (1.-F1)*FKMID + FKP2 = (1.-F2)*FKMID + T(I,J,K) = AMIN1(FIMID*FIMID+FJP1*FJP1+FKP1*FKP1- + 1 RSML1*RSML1, + 2 FKMID*FKMID+FIP2*FIP2+FJP2*FJP2-RSML2*RSML2) + 10 CONTINUE + 20 CONTINUE + 30 CONTINUE +C +C DEFINE EYE POSITION +C + EYE(1) = 100. + EYE(2) = 150. + EYE(3) = 125. +C +C LABEL THE PLOT TO BE DRAWN BY EZISOS +C + if (nplot .eq. 1) then + CALL GSELNT(0) + CALL WTSTR(IX,IY,'DEMONSTRATION PLOT FOR ENTRY EZISOS OF ISOSRF', + 1 2,0,0) +C +C TEST EZISOS +C + CALL EZISOS (T,NU,NV,NW,EYE,SLAB,TISO) + endif +C +C LABEL THE PLOT TO BE DRAWN BY ISOSRF +C + if (nplot .eq. 2) then + CALL GSELNT(0) + CALL WTSTR(IX,IY,'DEMONSTRATION PLOT FOR ENTRY ISOSRF OF ISOSRF', + 1 2,0,0) +C +C TEST ISOSRF WITH SUBARRAY OF T +C + MU=NU/2 + MV=NV/2 + MW=NW/2 + MUVWP2=MAX0(MU,MV,MW)+2 + CALL ISOSRF(T(MU,MV,MW),NU,MU,NV,MV,MW,EYE,MUVWP2,SLAB,TISO,IFLAG) + endif +c CALL FRAME +C + IERROR = 0 +c WRITE (6,1001) + RETURN +C +c1001 FORMAT (' ISOSRF TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/mkpkg b/sys/gio/ncarutil/tests/mkpkg new file mode 100644 index 00000000..79beff4f --- /dev/null +++ b/sys/gio/ncarutil/tests/mkpkg @@ -0,0 +1,65 @@ +# Make the x_ncartest.e executable for testing the NCAR utilities. + #conraq.x + #conraqt.f + #conras.x + #conrast.f + #conrcqckt.f + #conrcsmtht.f + #conrcsprt.f + #dashchar.x + #dashchart.f + #dashlinet.f + #dashsuprt.f + #ezmapg.x + #ezmapgt.f + #ezmapt.f + #isosrfhrt.f + +$update libpkg.a +$omake x_ncartest.x +$link x_ncartest.o libpkg.a -lncar -lgks -o /tmp2/newncar/x_ncartest.e +$exit + +libpkg.a: + auto10t.f + autograph.x + autographt.f + conran.x + conrant.f + conrec.x + conrect.f + dashsmth.x + dashsmtht.f + ezconrec.x + ezhafton.x + ezhaftont.f + ezisosrf.x + ezsurface.x + ezvelvect.x + ezytst.x + hafton.x + haftont.f + isosrf.x + isosrft.f + oldauto.x + oldautot.f + preal.x + pwrity.x + pwrityt.f + pwrzit.f + pwrzs.x + pwrzst.f + pwrztt.f + srfacet.f + srftest.x + srftestd.x + strmln.x + strmlnt.f + surface.x + threed.x + threed2.x + threed2t.f + threedt.f + velvctt.f + velvect.x + ; diff --git a/sys/gio/ncarutil/tests/oldauto.x b/sys/gio/ncarutil/tests/oldauto.x new file mode 100644 index 00000000..90287803 --- /dev/null +++ b/sys/gio/ncarutil/tests/oldauto.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include +include + +# Test NCAR routine AUTOGRAPH - EZXY, EZMXY etc. + +procedure t_oldauto() + +char device[SZ_FNAME], command[SZ_LINE] +int error_code, wkid +int ctoi() +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call exmpl1 + call exmpl2 + call exmpl3 + call exmpl4 + call exmpl5 + call exmpl6 + call exmpl7 + call exmpl8 + # call exmpl9 + call xmpl11 + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/oldautot.f b/sys/gio/ncarutil/tests/oldautot.f new file mode 100644 index 00000000..168d5f37 --- /dev/null +++ b/sys/gio/ncarutil/tests/oldautot.f @@ -0,0 +1,833 @@ + SUBROUTINE EXMPL1 +C +C Define the data array. +C + REAL YDRA(1001) +C +C Fill the data array. +C + DO 101 I=1,1001 + X=FLOAT(I)/20. + YDRA(I)=10.*(X-1.)*(X-11.)*(X-21.)*(X-31.)*(X-41.)*(X-51.) + + +2.E7*(FRAN()-.5) + 101 CONTINUE +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Draw the graph, using EZY. +C + CALL EZY (YDRA,1001,'EXAMPLE 1 (EZY)$') +C +c STOP +C + END + FUNCTION FRAN() +C +C Random-number generator. +C + DATA X / 2.7182818 / + SAVE X + X=AMOD(9821.*X+.211327,1.) + FRAN=X + RETURN + END + SUBROUTINE BNDARY +C +C Routine to draw the plotter-frame edge. +C + CALL PLOTIT ( 0, 0,0) + CALL PLOTIT (32767, 0,1) + CALL PLOTIT (32767,32767,1) + CALL PLOTIT ( 0,32767,1) + CALL PLOTIT ( 0, 0,1) + RETURN + END +c + SUBROUTINE EXMPL2 +C +C Define the data arrays. +C + REAL XDRA(4001),YDRA(4001) +C +C Fill the data arrays. +C + DO 101 I=1,4001 + THETA=.0015707963267949*FLOAT(I-1) + RHO=SIN(2.*THETA)+.05*SIN(64.*THETA) + XDRA(I)=RHO*COS(THETA) + YDRA(I)=RHO*SIN(THETA) + 101 CONTINUE +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Draw the graph, using EZXY. +C + CALL EZXY (XDRA,YDRA,4001,'EXAMPLE 2 (EZXY)$') +C +c STOP +C + END +c + SUBROUTINE EXMPL3 +C +C Define the data array. +C + REAL YDRA(100,2) +C +C Fill the data array. +C + DO 101 I=1,100 + YDRA(I,1)=COS(3.14159265358979*FLOAT(I)/25.)*FLOAT(I)**2 + YDRA(I,2)=COS(3.14159265358979*FLOAT(I)/25.)*10.**(.04*FLOAT(I)) + 101 CONTINUE +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Draw the graph, using EZMY. +C + CALL EZMY (YDRA,100,2,100,'EXAMPLE 3 (EZMY)$') +C +c STOP +C + END +c + SUBROUTINE EXMPL4 +C +C Define the data arrays. +C + REAL XDRA(201),YDRA(201,10) +C +C Fill the data arrays. +C + DO 102 I=1,201 + XDRA(I)=-1.+.02*FLOAT(I-1) + IF (I.GT.101) XDRA(I)=2.-XDRA(I) + DO 101 J=1,10 + YDRA(I,J)=FLOAT(J)*SQRT(1.000000000001-XDRA(I)**2)/10. + IF (I.GT.101) YDRA(I,J)=-YDRA(I,J) + 101 CONTINUE + 102 CONTINUE +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Draw the graph, using EZMXY. +C + CALL EZMXY (XDRA,YDRA,201,10,201,'EXAMPLE 4 (EZMXY)$') +C +c STOP +C + END +c + SUBROUTINE EXMPL5 +C +C Define the data arrays. +C + REAL XDRA(401,6),YDRA(401,6) +C +C Compute required constants. +C + PI=3.14159265358979 + PID200=PI/200. + PITTWO=2.*PI + PIT2D3=2.*PI/3. + PIT4D3=4.*PI/3. + RADOSC=SQRT(3.)/3. + RADOLC=SQRT(3.)/2. + BSSCLL=ATAN(SQRT(12.)/6.) + BSSCUL=ATAN(SQRT(143.)/7.) + BSLCLL=ATAN(SQRT(143.)/17.) + BSLCUL=ATAN(SQRT(2.0)) +C +C Fill the data arrays. +C + DO 101 I=1,401 + THETA=PID200*FLOAT(I-1) + XDRA(I,1)= -.5+RADOSC*COS(THETA) + YDRA(I,1)= RADOSC*SIN(THETA) + IF (ABS(THETA ).GE.BSSCLL.AND. + + ABS(THETA ).LE.BSSCUL) XDRA(I,1)=1.E36 + IF (ABS(THETA-PITTWO).GE.BSSCLL.AND. + + ABS(THETA-PITTWO).LE.BSSCUL) XDRA(I,1)=1.E36 + XDRA(I,2)= .5+RADOSC*COS(THETA) + YDRA(I,2)= RADOSC*SIN(THETA) + IF (ABS(THETA-PIT2D3).GE.BSSCLL.AND. + + ABS(THETA-PIT2D3).LE.BSSCUL) XDRA(I,2)=1.E36 + XDRA(I,3)= RADOSC*COS(THETA) + YDRA(I,3)=RADOLC+RADOSC*SIN(THETA) + IF (ABS(THETA-PIT4D3).GE.BSSCLL.AND. + + ABS(THETA-PIT4D3).LE.BSSCUL) XDRA(I,3)=1.E36 + XDRA(I,4)= -.5+RADOLC*COS(THETA) + YDRA(I,4)= RADOLC*SIN(THETA) + IF (ABS(THETA ).GE.BSLCLL.AND. + + ABS(THETA ).LE.BSLCUL) XDRA(I,4)=1.E36 + IF (ABS(THETA-PITTWO).GE.BSLCLL.AND. + + ABS(THETA-PITTWO).LE.BSLCUL) XDRA(I,4)=1.E36 + XDRA(I,5)= .5+RADOLC*COS(THETA) + YDRA(I,5)= RADOLC*SIN(THETA) + IF (ABS(THETA-PIT2D3).GE.BSLCLL.AND. + + ABS(THETA-PIT2D3).LE.BSLCUL) XDRA(I,5)=1.E36 + XDRA(I,6)= RADOLC*COS(THETA) + YDRA(I,6)=RADOLC+RADOLC*SIN(THETA) + IF (ABS(THETA-PIT4D3).GE.BSLCLL.AND. + + ABS(THETA-PIT4D3).LE.BSLCUL) XDRA(I,6)=1.E36 + 101 CONTINUE +C +C Specify subscripting of XDRA and YDRA. +C + CALL AGSETI ('ROW.',2) +C +C Make sure grid shape is such that one unit in x = one unit in y. +C + CALL AGSETF ('GRID/SHAPE.',2.) +C +C Turn off background, then turn labels back on. +C + CALL AGSETF ('BACKGROUND.',4.) + CALL AGSETI ('LABEL/CONTROL.',2) +C +C Turn off left label. +C + CALL AGSETC ('LABEL/NAME.','L') + CALL AGSETI ('LABEL/SUPPRESSION FLAG.',1) +C +C Change text of bottom label. +C + CALL AGSETC ('LABEL/NAME.','B') + CALL AGSETI ('LINE/NUMBER.',-100) + CALL AGSETC ('LINE/TEXT.','PURITY, BODY, AND FLAVOR$') +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Draw the graph, using EZMXY. +C + CALL EZMXY (XDRA,YDRA,401,6,401,'EXAMPLE 5 (EZMXY)$') +C +c STOP +C + END +c + SUBROUTINE EXMPL6 +C +C Define the data arrays. +C + REAL XDRA(501),YDRA(501) +C + CHARACTER*35 GLAB + CHARACTER*23 BACK(4) + CHARACTER*12 LNLG(4) + character*1 tmp +C Define the graph-window parameter array. +C + REAL GWND (4,4) +C + DATA (GWND(I,1),I=1,4) / 0.0 , 0.5 , 0.5 , 1.0 / + DATA (GWND(I,2),I=1,4) / 0.5 , 1.0 , 0.5 , 1.0 / + DATA (GWND(I,3),I=1,4) / 0.0 , 0.5 , 0.0 , 0.5 / + DATA (GWND(I,4),I=1,4) / 0.5 , 1.0 , 0.0 , 0.5 / +C +C Define variables used in setting up informational labels on the graph. +C +C + DATA BACK(1) / '(PERIMETER BACKGROUND)$' / + DATA BACK(2) / '(GRID BACKGROUND)$ ' / + DATA BACK(3) / '(HALF-AXIS BACKGROUND)$' / + DATA BACK(4) / '(NO BACKGROUND)$ ' / +C + DATA LNLG(1) / 'LINEAR$' / + DATA LNLG(2) / 'LOGARITHMIC$' / +C +C Fill the data arrays. +C + DO 101 I=1,501 + THETA=.031415926535898*FLOAT(I-1) + XDRA(I)=500.+.9*FLOAT(I-1)*COS(THETA) + YDRA(I)=500.+.9*FLOAT(I-1)*SIN(THETA) + 101 CONTINUE +C +C +C Do four graphs on the same frame, using different backgrounds. +C + DO 102 IGRF = 1,4 +C +C Suppress the frame advance. +C + CALL AGSETI ('FRAME.',2) +C +C Position the graph window. +C + CALL AGSETP ('GRAPH WINDOW.',GWND(1,IGRF),4) +C +C Declare the background type. +C + CALL AGSETI ('BACKGROUND TYPE.',IGRF) +C +C Setting the background type may have turned the informational labels +C off. In that case, turn them back on. +C + IF (IGRF.EQ.4) CALL AGSETI ('LABEL/CONTROL.',2) +C +C Set up parameters determining the linear/log nature of the axes. +C + ILLX=(IGRF-1)/2 + ILLY=MOD(IGRF-1,2) +C +C Declare the linear/log nature of the graph. +C + CALL AGSETI ('X/LOGARITHMIC.',ILLX) + CALL AGSETI ('Y/LOGARITHMIC.',ILLY) +C +C Change the x- and y-axis labels to reflect the linear/log nature of +C the graph. +C + CALL AGSETC ('LABEL/NAME.','B') + CALL AGSETI ('LINE/NUMBER.',-100) + CALL AGSETC ('LINE/TEXT.',LNLG(ILLX+1)) +C + CALL AGSETC ('LABEL/NAME.','L') + CALL AGSETI ('LINE/NUMBER.',100) + CALL AGSETC ('LINE/TEXT.',LNLG(ILLY+1)) +C +C Set up the label for the top of the graph. +C +c WRITE (GLAB,1001) IGRF,BACK(IGRF) + glab(1:35) = 'EXAMPLE 6- ' + glab(11:11) = char (igrf + ichar ('0')) + glab(13:35) = back (igrf) +C +C Draw the graph, using EZXY. +C + CALL EZXY (XDRA,YDRA,501,GLAB) +C + 102 CONTINUE +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Advance the frame. +C + CALL FRAME +C +c STOP +C +C Format for encode. +C +c1001 FORMAT ('EXAMPLE 6-',I1,' ',A23) + END +c + SUBROUTINE EXMPL7 +C +C Define the data arrays and the dash-pattern array. +C + REAL XDRA(101),YDRA(101,9) + CHARACTER*28 DSHP(9) +C +C Declare the type of the dash-pattern-name generator. +C + CHARACTER*16 AGDSHN +C +C Fill the data arrays and the dash pattern array. +C + DO 101 I=1,101 + XDRA(I)=-90.+1.8*FLOAT(I-1) + 101 CONTINUE +C + DO 103 J=1,9 +c WRITE (DSHP(J),1001) J + dshp(j) = '$$$$$$$$$$$$$$$$$$$$$ J = ' + dshp(j)(27:27) = char (j + ichar ('0')) + FJ=J + DO 102 I=1,101 + YDRA(I,J)=3.*FJ-(FJ/2700.)*XDRA(I)**2 + 102 CONTINUE + 103 CONTINUE +C +C Turn on windowing. (Some curves run outside the curve window.) +C + CALL AGSETI ('WINDOWING.',1) +C +C Move the edges of the curve window (grid). +C + CALL AGSETF ('GRID/LEFT.' ,.10) + CALL AGSETF ('GRID/RIGHT.' ,.90) + CALL AGSETF ('GRID/BOTTOM.',.10) + CALL AGSETF ('GRID/TOP.' ,.85) +C +C Set the x and y minimum and maximum. +C + CALL AGSETF ('X/MINIMUM.',-90.) + CALL AGSETF ('X/MAXIMUM.',+90.) + CALL AGSETF ('Y/MINIMUM.', 0.) + CALL AGSETF ('Y/MAXIMUM.', 18.) +C +C Set left axis parameters. +C + CALL AGSETI ('LEFT/MAJOR/TYPE.',1) + CALL AGSETF ('LEFT/MAJOR/BASE.',3.) + CALL AGSETI ('LEFT/MINOR/SPACING.',2) +C +C Set right axis parameters. +C + CALL AGSETI ('RIGHT/FUNCTION.',1) + CALL AGSETF ('RIGHT/NUMERIC/TYPE.',1.E36) +C +C Set bottom axis parameters. +C + CALL AGSETI ('BOTTOM/MAJOR/TYPE.',1) + CALL AGSETF ('BOTTOM/MAJOR/BASE.',15.) + CALL AGSETI ('BOTTOM/MINOR/SPACING.',2) +C +C Set top axis parameters. +C + CALL AGSETI ('TOP/FUNCTION.',1) + CALL AGSETF ('TOP/NUMERIC/TYPE.',1.E36) +C +C Set up the dash patterns to be used. +C + CALL AGSETI ('DASH/SELECTOR.',9) + CALL AGSETI ('DASH/LENGTH.',28) + DO 104 I=1,9 + CALL AGSETC (AGDSHN(I),DSHP(I)) + 104 CONTINUE +C +C Set up the left label. +C + CALL AGSETC ('LABEL/NAME.','L') + CALL AGSETI ('LINE/NUMBER.',100) + CALL AGSETC ('LINE/TEXT.','HEIGHT (KILOMETERS)$') +C +C Set up the right label. +C + CALL AGSETC ('LABEL/NAME.','R') + CALL AGSETI ('LINE/NUMBER.',-100) + CALL AGSETC ('LINE/TEXT.','PRESSURE (TONS/SQUARE FURLONG)$') +C +C Set up the bottom labels. +C + CALL AGSETC ('LABEL/NAME.','B') + CALL AGSETI ('LINE/NUMBER.',-100) + CALL AGSETC ('LINE/TEXT.','LATITUDE (DEGREES)$') +C + CALL AGSETC ('LABEL/NAME.','SP') + CALL AGSETF ('LABEL/BASEPOINT/X.',.000001) + CALL AGSETF ('LABEL/BASEPOINT/Y.',0.) + CALL AGSETF ('LABEL/OFFSET/Y.',-.015) + CALL AGSETI ('LINE/NUMBER.',-100) + CALL AGSETC ('LINE/TEXT.','SP$') +C + CALL AGSETC ('LABEL/NAME.','NP') + CALL AGSETF ('LABEL/BASEPOINT/X.',.999999) + CALL AGSETF ('LABEL/BASEPOINT/Y.',0.) + CALL AGSETF ('LABEL/OFFSET/Y.',-.015) + CALL AGSETI ('LINE/NUMBER.',-100) + CALL AGSETC ('LINE/TEXT.','NP$') +C +C Set up the top label. +C + CALL AGSETC ('LABEL/NAME.','T') + CALL AGSETI ('LINE/NUMBER.',80) + CALL AGSETC ('LINE/TEXT.','DISTANCE FROM EQUATOR (MILES)$') + CALL AGSETI ('LINE/NUMBER.',90) + CALL AGSETC ('LINE/TEXT.',' $') + CALL AGSETI ('LINE/NUMBER.',100) + CALL AGSETC ('LINE/TEXT.','LINES OF CONSTANT INCRUDESCENCE$') + CALL AGSETI ('LINE/NUMBER.',110) + CALL AGSETC ('LINE/TEXT.','EXAMPLE 7 (EZMXY)$') +C +C Set up centered (box 6) label. +C + CALL AGSETC ('LABEL/NAME.','EQUATOR') + CALL AGSETI ('LABEL/ANGLE.',90) + CALL AGSETI ('LINE/NUMBER.',0) + CALL AGSETC ('LINE/TEXT.','EQUATOR$') +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Draw the graph, using EZMXY. +C + CALL EZMXY (XDRA,YDRA,101,9,101,0) +C +c STOP +C +C Format for encode above. +C +c1001 FORMAT ('$$$$$$$$$$$$$$$$$$$$$''J''=''',I1,'''') +C + END +c + SUBROUTINE EXMPL8 +C +C Define the data arrays. +C + REAL XDRA(101),YDRA(4,101) +C +C Fill the data arrays. +C + DO 101 I=1,101 + XDRA(I)=-3.14159265358979+.062831853071796*FLOAT(I-1) + 101 CONTINUE +C + DO 103 I=1,4 + FLTI=I + BASE=2.*FLTI-1. + DO 102 J=1,101 + YDRA(I,J)=BASE+.75*SIN(-3.14159265358979+.062831853071796* + + FLTI*FLOAT(J-1)) + 102 CONTINUE + 103 CONTINUE +C +C Change the line-end character to a period. +C + CALL AGSETC ('LINE/END.','.') +C +C Specify labels for x and y axes. +C + CALL ANOTAT ('SINE FUNCTIONS OF T.','T.',0,0,0,0) +C +C Use a half-axis background. +C + CALL AGSETI ('BACKGROUND.',3) +C +C Move x axis to the zero point on the y axis. +C + CALL AGSETF ('BOTTOM/INTERSECTION/USER.',0.) +C +C Specify base value for spacing of major ticks on x axis. +C + CALL AGSETF ('BOTTOM/MAJOR/BASE.',1.) +C +C Run major ticks on x axis to edge of curve window. +C + CALL AGSETF ('BOTTOM/MAJOR/INWARD.',1.) + CALL AGSETF ('BOTTOM/MAJOR/OUTWARD.',1.) +C +C Position x axis minor ticks. +C + CALL AGSETI ('BOTTOM/MINOR/SPACING.',9) +C +C Run the y axis backward. +C + CALL AGSETI ('Y/ORDER.',1) +C +C Run plots full-scale in y. +C + CALL AGSETI ('Y/NICE.',0) +C +C Have AUTOGRAPH scale x and y data the same. +C + CALL AGSETF ('GRID/SHAPE.',.01) +C +C Use the alphabetic set of dashed-line patterns. +C + CALL AGSETI ('DASH/SELECTOR.',-1) +C +C Tell AUTOGRAPH how the data arrays are dimensioned. +C + CALL AGSETI ('ROW.',-1) +C +C Reverse the roles of the x and y arrays. +C + CALL AGSETI ('INVERT.',1) +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Draw the curves. +C + CALL EZMXY (XDRA,YDRA,4,4,101,'EXAMPLE 8.') +C +c STOP +C + END +c +C SUBROUTINE EXMPL9 +CC +CC Define the data arrays. +CC +C DIMENSION XDAT(400),YDAT(400) +CC +CC Fill the data arrays. +CC +C DO 101 I=1,400 +C XDAT(I)=(FLOAT(I)-1.)/399. +C 101 CONTINUE +CC +C CALL GENDAT (YDAT( 1),200,200,1,3,3,+.01,+10.) +C CALL GENDAT (YDAT(201),200,200,1,3,3,-10.,-.01) +CC +CC The y data ranges over both positive and negative values. It is +CC desired that both ranges be represented on the same graph and that +CC each be shown logarithmically, ignoring values in the range -.01 to +CC +.01, in which we're not interested. First we map each y datum into +CC its absolute value (.01 if the absolute value is too small). Then we +CC take the base-10 logarithm, add 2.0001 (so as to be sure of getting a +CC positive number), and re-attach the original sign. We can plot the +CC resulting y data on a linear y axis. +CC +C DO 102 I=1,400 +C YDAT(I)=SIGN(ALOG10(AMAX1(ABS(YDAT(I)),.01))+2.0001,YDAT(I)) +C 102 CONTINUE +CC +CC In order that the labels on the y axis should show the original values +CC of the y data, we change the user-system-to-label-system mapping on +CC both y axes and force major ticks to be spaced logarithmically in the +CC label system (which will be defined by the subroutine AGUTOL in such +CC a way as to re-create numbers in the original range). +CC +C CALL AGSETI ('LEFT/FUNCTION.',1) +C CALL AGSETI ('LEFT/MAJOR/TYPE.',2) +CC +C CALL AGSETI ('RIGHT/FUNCTION.',1) +C CALL AGSETI ('RIGHT/MAJOR/TYPE.',2) +CC +CC Change the label on the left axis to reflect what's going on. +CC +C CALL AGSETC ('LABEL/NAME.','L') +C CALL AGSETI ('LINE/NUMBER.',100) +C CALL AGSETC ('LINE/TEXT.','LOG SCALING, POSITIVE AND NEGATIVE$') +CC +CC Draw a boundary around the edge of the plotter frame. +CC +Cc CALL BNDARY +CC +CC Draw the curve. +CC +C CALL EZXY (XDAT,YDAT,400,'EXAMPLE 9$') +CC +Cc STOP +CC +C END +Cc +C SUBROUTINE GENDAT (DATA,IDIM,M,N,MLOW,MHGH,DLOW,DHGH) +CC +CC This is a routine to generate test data for two-dimensional graphics +CC routines. Given an array "DATA", dimensioned "IDIM x 1", it fills +CC the sub-array ((DATA(I,J),I=1,M),J=1,N) with a two-dimensional field +CC of data having approximately "MLOW" lows and "MHGH" highs, a minimum +CC value of exactly "DLOW" and a maximum value of exactly "DHGH". +CC +CC "MLOW" and "MHGH" are each forced to be greater than or equal to 1 +CC and less than or equal to 25. +CC +CC The function used is a sum of exponentials. +CC +C DIMENSION DATA(IDIM,1),CCNT(3,50) +CC +C FOVM=9./FLOAT(M) +C FOVN=9./FLOAT(N) +CC +C NLOW=MAX0(1,MIN0(25,MLOW)) +C NHGH=MAX0(1,MIN0(25,MHGH)) +C NCNT=NLOW+NHGH +CC +C DO 101 K=1,NCNT +C CCNT(1,K)=1.+(FLOAT(M)-1.)*FRAN() +C CCNT(2,K)=1.+(FLOAT(N)-1.)*FRAN() +C IF (K.LE.NLOW) THEN +C CCNT(3,K)=-1. +C ELSE +C CCNT(3,K)=+1. +C END IF +C 101 CONTINUE +CC +C DMIN=+1.E36 +C DMAX=-1.E36 +C DO 104 J=1,N +C DO 103 I=1,M +C DATA(I,J)=.5*(DLOW+DHGH) +C DO 102 K=1,NCNT +C DATA(I,J)=DATA(I,J) + .5 * (DHGH-DLOW) * CCNT(3,K) * +C + EXP( - ( ( FOVM*(FLOAT(I)-CCNT(1,K)) )**2 + +C + ( FOVN*(FLOAT(J)-CCNT(2,K)) )**2 ) ) +C 102 CONTINUE +C DMIN=AMIN1(DMIN,DATA(I,J)) +C DMAX=AMAX1(DMAX,DATA(I,J)) +C 103 CONTINUE +C 104 CONTINUE +CC +C DO 106 J=1,N +C DO 105 I=1,M +C DATA(I,J)=(DATA(I,J)-DMIN)/(DMAX-DMIN)*(DHGH-DLOW)+DLOW +C 105 CONTINUE +C 106 CONTINUE +CC +C RETURN +CC +C END +Cc +C SUBROUTINE XMPL10 +C RETURN +C END +Cc + SUBROUTINE XMPL11 +C +C Create a sort of histogram. +C + REAL XDRA(249),YDRA(249),WORK(204),IWRK(204) +C +C Fill the data arrays. First, we define the histogram outline. This +C will be used in the call to FILL which fills in the area under the +C histogram. +C + XDRA(1)=0. + YDRA(1)=0. +C + DO 101 I=2,100,2 + XDRA(I )=XDRA(I-1) + YDRA(I )=EXP(-16.*(FLOAT(I/2)/50.-.51)**2)+.1*FRAN() + XDRA(I+1)=XDRA(I-1)+.02 + YDRA(I+1)=YDRA(I) + 101 CONTINUE +C + XDRA(102)=1. + YDRA(102)=0. +C +C Then, we define lines separating the vertical boxes from each other. +C + NDRA=102 +C + DO 102 I=3,99,2 + XDRA(NDRA+1)=1.E36 + YDRA(NDRA+1)=1.E36 + XDRA(NDRA+2)=XDRA(I) + YDRA(NDRA+2)=0. + XDRA(NDRA+3)=XDRA(I) + YDRA(NDRA+3)=AMIN1(YDRA(I),YDRA(I+1)) + NDRA=NDRA+3 + 102 CONTINUE +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Suppress the frame advance. +C + CALL AGSETI ('FRAME.',2) +C +C Draw the graph, using EZXY. +C + CALL EZXY (XDRA,YDRA,249,'EXAMPLE 11 (HISTOGRAM)$') +C +C Use the XLIB routine FILL to fill the area defined by the data. Note +C that FILL is not a part of the AUTOGRAPH package. +C +c CALL FILLOP ('AN',45) +c CALL FILLOP ('SP',128) +c CALL FILL (XDRA,YDRA,102,WORK,204,IWRK,204) +C +C Advance the frame. +C +c CALL FRAME +C +c STOP +C + END +c + SUBROUTINE EXMPLF +C +C Define the data array. +C + DIMENSION XYCD(226) +C +C Fill the data array. +C +c READ 1001 , XYCD +C + DO 101 I=1,226 + IF (XYCD(I).EQ.1.E36) GO TO 101 + XYCD(I)=2.**((XYCD(I)-15.)/2.5) + 101 CONTINUE +C +C Specify log/log plot. +C + CALL DISPLA (0,0,4) +C +C Bump the line-maximum parameter past 42. +C + CALL AGSETI ('LINE/MAXIMUM.',50) +C +C Specify x- and y-axis labels, grid background. +C + CALL ANOTAT ('LOGARITHMIC, BASE 2, EXPONENTIAL LABELING$', + + 'LOGARITHMIC, BASE 2, NO-EXPONENT LABELING$',2,0,0,0) +C +C Specify the graph label. +C + CALL AGSETC ('LABEL/NAME.','T') + CALL AGSETI ('LINE/NUMBER.',100) + CALL AGSETC ('LINE/TEXT.','FINAL EXAMPLE$') +C +C Specify x-axis ticks and labels. +C + CALL AGSETI ('BOTTOM/MAJOR/TYPE.',3) + CALL AGSETF ('BOTTOM/MAJOR/BASE.',2.) + CALL AGSETI ('BOTTOM/NUMERIC/TYPE.',2) + CALL AGSETI ('BOTTOM/MINOR/SPACING.',4) +c CALL AGSETI ('BOTTOM/MINOR/PATTERN.',125252B) +C +C Specify y-axis ticks and labels. +C + CALL AGSETI ('LEFT/MAJOR/TYPE.',3) + CALL AGSETF ('LEFT/MAJOR/BASE.',2.) + CALL AGSETI ('LEFT/NUMERIC/TYPE.',3) + CALL AGSETI ('LEFT/MINOR/SPACING.',4) +c CALL AGSETI ('LEFT/MINOR/PATTERN.',125252B) +C +C Compute secondary control parameters. +C + CALL AGSTUP (XYCD(1),1,0,113,2,XYCD(2),1,0,113,2) +C +C Draw the background. +C + CALL AGBACK +C +C Draw the curve twice to make it darker. +C + CALL AGCURV (XYCD(1),2,XYCD(2),2,113,1) + CALL AGCURV (XYCD(1),2,XYCD(2),2,113,1) +C +C Draw a boundary around the edge of the plotter frame. +C +c CALL BNDARY +C +C Advance the frame. +C +c CALL FRAME +C +c STOP +C +C Format. +C +c1001 FORMAT (14E5.0) +C + END +C 1.8 2.1 2.7 1.6 4.2 1.5 5.7 1.9 6.3 2.9 6.5 4.7 6.0 6.7 +C 5.6 8.6 5.4 10.7 5.6 13.1 4.8 11.2 3.7 9.7 1E36 1E36 7.0 8.2 +C 7.7 10.6 8.2 12.6 8.2 14.3 8.0 15.3 7.7 15.6 7.5 15.1 7.4 14.0 +C 7.6 12.3 7.7 10.7 7.9 8.9 8.2 7.3 8.5 4.6 8.5 7.3 8.6 9.3 +C 8.8 10.2 9.1 10.5 9.4 10.1 9.6 9.1 9.9 7.8 10.3 6.9 11.1 7.0 +C 11.7 7.8 12.0 8.6 12.3 10.0 12.5 11.5 12.4 12.7 12.2 13.0 11.9 12.6 +C 11.7 11.7 11.6 10.5 11.7 9.3 12.0 8.6 12.5 8.6 13.0 9.0 13.8 10.1 +C 14.3 11.1 1E36 1E36 18.5 23.4 18.2 23.5 17.8 23.2 17.2 22.6 16.8 21.8 +C 16.0 20.2 15.8 19.5 16.0 19.3 16.6 19.6 17.8 20.6 17.3 19.1 16.9 17.3 +C 16.6 16.0 16.6 14.5 16.8 13.7 17.1 13.1 17.8 13.2 18.4 14.0 19.2 15.5 +C 19.8 16.8 20.3 18.0 20.9 20.1 21.1 18.9 21.1 17.4 21.1 18.9 21.2 19.7 +C 1.5 20.5 21.8 20.8 22.0 20.4 22.1 19.6 22.3 18.7 22.6 18.4 23.1 18.9 +C 23.6 20.0 24.1 21.7 24.7 22.9 25.3 23.9 24.7 22.9 24.4 21.6 24.4 20.6 +C 24.7 20.2 25.2 20.7 25.6 21.5 26.0 22.9 26.4 24.5 26.7 25.9 26.8 27.9 +C 26.6 30.0 26.4 30.3 26.2 30.0 25.7 28.0 25.5 26.1 25.3 24.9 25.3 23.9 +C 25.4 22.9 25.9 22.5 26.6 22.4 27.4 23.1 28.2 24.0 29.0 25.0 30.1 26.4 +C 1E36 1E36 diff --git a/sys/gio/ncarutil/tests/preal.x b/sys/gio/ncarutil/tests/preal.x new file mode 100644 index 00000000..79d33218 --- /dev/null +++ b/sys/gio/ncarutil/tests/preal.x @@ -0,0 +1,12 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +procedure preal (tval, rval) + +char tval[ARB] +real rval + +begin + call eprintf ("%s %.4f\n") + call pargstr (tval) + call pargr (rval) +end diff --git a/sys/gio/ncarutil/tests/pwrity.x b/sys/gio/ncarutil/tests/pwrity.x new file mode 100644 index 00000000..3b5c1437 --- /dev/null +++ b/sys/gio/ncarutil/tests/pwrity.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +# Test NCAR routines PWRITY + +procedure t_pwrity() + +char device[SZ_FNAME] +int error_code, wkid +int gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tpwry (error_code) + + if (error_code == 0) + call printf ("Test successful\n") + else + call printf ("Test was not successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/pwrityt.f b/sys/gio/ncarutil/tests/pwrityt.f new file mode 100644 index 00000000..5b033933 --- /dev/null +++ b/sys/gio/ncarutil/tests/pwrityt.f @@ -0,0 +1,90 @@ + SUBROUTINE TPWRY (IERROR) +C +C LATEST REVISION JULY 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C ENTRY PWRITY OF PWRITY AND +C TO TEST PWRITY ON A SIMPLE PROBLEM +C +C USAGE CALL TPWRY (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST WAS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C PWRITY TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS WRITTEN TO UNIT 6. +C IN ADDITION, ONE FRAME CONTAINING +C CHARACTER STRING PLOTS IS PRODUCED ON THE +C MACHINE GRAPHICS DEVICE. IN ORDER TO +C DETERMINE WHETHER THE TEST WAS SUCCESSFUL, +C IT IS NECESSARY TO EXAMINE THIS PLOT. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY PWRITY +C FILES +C +C LANGUAGE FORTRAN +C +C ALGORITHM TPWRY CALLS PWRITY TO PLOT VARIOUS CHARACTER +C STRINGS USING DIFFERENT PARAMETERS. +C +C PORTABILITY ANSI FORTRAN 77 +C +C +C INITIALIZE THE ERROR PARAMETER. +C + IERROR = 0 +C +C DEFINE NORMALIZATION TRANS 1 AND LOG SCALING +C + CALL GSVP (1, 0.0, 1.0, 0.0, 1.0) + CALL GSWN (1, 1.0, 1024.0, 1.0, 1024.0) + CALL GSELNT (1) + CALL SETUSV ('LS',1) +C +C LABEL FRAME +C + CALL PWRITY(512.0,950.0, + 1 'DEMONSTRATION PLOT FOR PWRITY', + 2 29,2,0,0) +C +C TEST PWRITY FOR DIFFERENT SIZE CHARACTERS. +C + CALL PWRITY (10.0,900.0,'SIZE TEST',9,0,0,-1) + CALL PWRITY (10.0,850.0,'SIZE TEST',9,1,0,-1) + CALL PWRITY (10.0,775.0,'SIZE TEST',9,2,0,-1) + CALL PWRITY (10.0,675.0,'SIZE TEST',9,3,0,-1) + CALL PWRITY (10.0,525.0,'SIZE TEST',9,4,0,-1) + CALL PWRITY (10.0,375.0,'SIZE TEST',9,5,0,-1) +C +C TEST PWRITY FOR DIFFERENT CHARACTER ORIENTATIONS. +C + CALL PWRITY (600.0,600.0,'THETA TEST',10,2,0*90,-1) + CALL PWRITY (600.0,600.0,'THETA TEST',10,2,1*90,-1) + CALL PWRITY (600.0,600.0,'THETA TEST',10,2,2*90,-1) + CALL PWRITY (600.0,600.0,'THETA TEST',10,2,3*90,-1) +C +C TEST CENTERING OPTIONS FOR PWRITY. +C + CALL PWRITY (512.0,160.0,'CENTR TEST',10,2,0,0) + CALL PWRITY (512.0,85.0,'CENTR TEST',10,2,0,-1) + CALL PWRITY (512.0,235.0,'CENTR TEST',10,2,0,1) +c +c CALL NEWFM +C +c WRITE (6,1001) + RETURN +C +c 1001 FORMAT (' PWRITY TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/pwrzit.f b/sys/gio/ncarutil/tests/pwrzit.f new file mode 100644 index 00000000..7c96e926 --- /dev/null +++ b/sys/gio/ncarutil/tests/pwrzit.f @@ -0,0 +1,132 @@ + SUBROUTINE TPWRZI (IERROR) +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C PWRZI IN CONJUNCTION WITH ISOSRF +C +C USAGE CALL TPWRZI (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST WAS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C PWRZI TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, ONE FRAME CONTAINING THE SAMPLE +C PLOT IS PRODUCED ON THE MACHINE GRAPHICS +C DEVICE. IN ORDER TO DETERMINE IF THE TEST +C WAS SUCCESSFUL, IT IS NECESSARY TO EXAMINE +C THIS PLOT. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY PWRZI, ISOSRF +C FILES +C +C +C LANGUAGE FORTRAN +C +C ALGORITHM A FUNCTION OF THREE VARIABLES IS DEFINED, AND +C VALUES OF THE FUNCTION ON A THREE DIMENSIONAL +C RECTANGULAR GRID ARE STORED IN AN ARRAY. THIS +C SUBROUTINE THEN CALLS ISOSRF TO DRAW AN +C ISO-VALUED SURFACE PLOT OF THE FUNCTION, +C THEN PWRZI IS CALLED THREE TIMES TO +C LABEL THE FRONT, SIDE, AND BACK OF THE +C PICTURE. +C +C PORTABILITY ANSI FORTRAN 77 +C +C + DIMENSION T(21,31,19),SLAB(33,33),EYE(3) +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE INTEGER COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX AND TY +C DEFINE THE CENTER OF THE TITLE STRING. +C + DATA TX/0.4375/, TY/0.9667/ +C + DATA NU,NV,NW/21,31,19/ + DATA RBIG1,RBIG2,RSML1,RSML2/6.,6.,2.,2./ + DATA TISO/0./ + DATA MUVWP2/33/ + DATA IFLAG/-7/ +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 1 +C +C FILL THREE DIMENSIONAL ARRAY TO BE PLOTTED +C + JCENT1 = FLOAT(NV)*.5-RBIG1*.5 + JCENT2 = FLOAT(NV)*.5+RBIG2*.5 + DO 30 I=1,NU + FIMID = I-NU/2 + DO 20 J=1,NV + FJMID1 = J-JCENT1 + FJMID2 = J-JCENT2 + DO 10 K=1,NW + FKMID = K-NW/2 + F1 = SQRT(RBIG1*RBIG1/(FJMID1*FJMID1+FKMID*FKMID+.1)) + F2 = SQRT(RBIG2*RBIG2/(FIMID*FIMID+FJMID2*FJMID2+.1)) + FIP1 = (1.-F1)*FIMID + FIP2 = (1.-F2)*FIMID + FJP1 = (1.-F1)*FJMID1 + FJP2 = (1.-F2)*FJMID2 + FKP1 = (1.-F1)*FKMID + FKP2 = (1.-F2)*FKMID + T(I,J,K) = AMIN1(FIMID*FIMID+FJP1*FJP1+FKP1*FKP1- + 1 RSML1*RSML1, + 2 FKMID*FKMID+FIP2*FIP2+FJP2*FJP2-RSML2*RSML2) + 10 CONTINUE + 20 CONTINUE + 30 CONTINUE +C +C DEFINE EYE POSITION +C + EYE(1) = 100. + EYE(2) = 150. + EYE(3) = 125. +C +C SELECT NORMALIZATION TRANS NUMBER 0 +C + CALL GSELNT (0) +C +C +C LABEL THE PLOT +C + CALL WTSTR (TX,TY,'DEMONSTRATION PLOT FOR PWRZI',2,0,0) +C +C TEST ISOSRF WITH SUBARRAY OF T +C + MU = NU/2 + MV = NV/2 + MW = NW/2 + MUVWP2 = MAX0(MU,MV,MW)+2 + CALL ISOSRF (T(MU,MV,MW),NU,MU,NV,MV,MW,EYE,MUVWP2,SLAB,TISO, + 1 IFLAG) + ISIZE = 35 + CALL PWRZI (5.,16.,.5,'FRONT',5,ISIZE,-1,3,0) + CALL PWRZI (11.,7.5,.5,'SIDE',4,ISIZE,2,-1,0) + CALL PWRZI (5.,1.,5.,' BACK BACK BACK BACK BACK',25,ISIZE,-1,3,0) + CALL SETUSV ('XF',10) + CALL SETUSV ('YF',10) + CALL NEWFM + IERROR = 0 +C +c WRITE (6,1001) + RETURN +C +C +c1001 FORMAT (' PWRZI TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/pwrzs.x b/sys/gio/ncarutil/tests/pwrzs.x new file mode 100644 index 00000000..f2eeec96 --- /dev/null +++ b/sys/gio/ncarutil/tests/pwrzs.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +# Test NCAR routines PWRZS + +procedure t_przs() + +char device[SZ_FNAME] +int error_code, wkid +int gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tpwrzs (error_code) + + if (error_code == 0) + call printf ("Test successful\n") + else + call printf ("Test was not successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/pwrzst.f b/sys/gio/ncarutil/tests/pwrzst.f new file mode 100644 index 00000000..4067ed86 --- /dev/null +++ b/sys/gio/ncarutil/tests/pwrzst.f @@ -0,0 +1,127 @@ + SUBROUTINE TPWRZS (IERROR) +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C PWRZS IN CONJUNCTION WITH SRFACE. +C +C USAGE CALL TPWRZS (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST WAS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST WAS SUCCESSFUL, THE MESSAGE +C +C PWRZS TEST SUCCESSFUL . . . SEE PLOT +C TO VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C IN ADDITION, ONE FRAME CONTAINING THE SAMPLE +C PLOT IS PRODUCED ON THE MACHINE GRAPHICS +C DEVICE. IN ORDER TO DETERMINE IF THE TEST +C WAS SUCCESSFUL, IT IS NECESSARY TO EXAMINE +C THIS PLOT. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY PWRZS, SRFACE +C FILES +C +C LANGUAGE FORTRAN +C +C ALGORITHM A FUNCTION OF TWO VARIABLES IS DEFINED, AND +C VALUES OF THE FUNCTION ON A TWO DIMENSIONAL +C RECTANGULAR GRID ARE STORED IN AN ARRAY. THIS +C SUBROUTINE CALLS SRFACE TO DRAW A SURFACE +C REPRESENTATION OF THE ARRAY VALUES, AND THEN +C PWRZS IS CALLED THREE TIMES TO LABEL THE +C FRONT, SIDE, AND BACK OF THE PICTURE. +C +C PORTABILITY ANSI FORTRAN 77 +C +C + DIMENSION Z(20,30) ,X(20) ,Y(30) ,MM(20,30,2), + 1 S(6) +C +C LOAD THE SRFACE COMMON BLOCK, NEEDED TO SURPRESS NEWFM CALL +C + COMMON /SRFIP1/ IFR ,ISTP ,IROTS ,IDRX , + 1 IDRY ,IDRZ ,IUPPER ,ISKIRT , + 2 NCLA ,THETA ,HSKIRT ,CHI , + 3 CLO ,CINC ,ISPVAL +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE INTEGER COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX AND +C TY DEFINE THE CENTER OF THE TITLE STRING. +C + DATA TX/0.4375/, TY/0.9667/ +C +C SPECIFY GRID LOOP INDICES, AND LINE OF SIGHT +C + DATA M/20/, N/30/ + DATA S/4.,5.,3.,0.,0.,0./ +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 1 +C +C DEFINE FUNCTION VALUES AND STORE IN Z +C + DO 10 I=1,M + X(I) = -1.+FLOAT(I-1)/FLOAT(M-1)*2. + 10 CONTINUE + DO 20 J=1,N + Y(J) = -1.+FLOAT(J-1)/FLOAT(N-1)*2. + 20 CONTINUE + DO 40 J=1,N + DO 30 I=1,M + Z(I,J) = EXP(-2.*SQRT(X(I)**2+Y(J)**2)) + 30 CONTINUE + 40 CONTINUE +C +C SET SRFACE PARAMETERS TO SURPRESS FRAME CALL AND DRAW CONTOURS + call srfabd +C + IFR = 0 + IDRZ = 1 +C +C SELECT NORMALIZATION TRANS NUMBER 0 +C + CALL GSELNT (0) +C +C LABEL THE PLOT +C + CALL WTSTR (TX,TY,'DEMONSTRATION PLOT FOR PWRZS',2,0,0) +C +C DRAW SURFACE PLOT +C + CALL SRFACE (X,Y,Z,MM,M,M,N,S,0.) +C +C PUT PWRZS LABELS ON PICTURE +C + ISIZE = 35 + CALL PWRZS (0.,1.1,0.,'FRONT',5,ISIZE,-1,3,0) + CALL PWRZS (1.1,0.,0.,'SIDE',4,ISIZE,2,-1,0) + CALL PWRZS (0.,-1.1,.2,' BACK BACK BACK BACK BACK',25,ISIZE,-1, + 1 3,0) +c CALL NEWFM +C + IERROR = 0 +c WRITE (6,1001) +C +C RESTORE SRFACE PARAMETERS TO DEFAULT +C + IFR = 1 + IDRZ = 0 +C + RETURN +C +C +c1001 FORMAT (' PWRZS TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/pwrztt.f b/sys/gio/ncarutil/tests/pwrztt.f new file mode 100644 index 00000000..dcf43638 --- /dev/null +++ b/sys/gio/ncarutil/tests/pwrztt.f @@ -0,0 +1,116 @@ + SUBROUTINE TPWRZT (IERROR) +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C PWRZT IN CONJUNCTION WITH THREED. +C +C USAGE CALL TPWRZT (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST IS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C PWRZT TEST SUCCESSFUL . . . SEE PLOT +C TO VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C +C IN ADDITION, ONE FRAME CONTAINING THE +C CHARACTER PLOT IS PRODUCED ON THE +C MACHINE GRAPHICS DEVICE. TO DETERMINE +C IF THE TEST IS SUCCESSFUL, IT IS NECESSARY +C TO EXAMINE THIS PLOT. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY PWRZT, THREED +C FILES +C +C +C LANGUAGE FORTRAN +C +C ALGORITHM TPWRZT CALLS SUBROUTINES SET3 AND LINE3 FROM +C THE ULIB THREED PACKAGE TO ESTABLISH THE +C THREE SPACE-TO-TWO SPACE TRANSFORMATION +C AND TO DRAW AXIS LINES. TPWRZT NEXT CALLS +C SUBROUTINE PWRZT FROM THE ULIB THREED +C PACKAGE TO LABEL THE AXES FOR A THREE SPACE +C PLOT. +C +C PORTABILITY ANSI FORTRAN 77 +C +C +C EYE CONTAINS THE (U,V,Z) COORDINATE OF THE EYE POSITION +C + REAL EYE(3) + DATA EYE(1), EYE(2), EYE(3) /3.5, 3.0, 5.0/ +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 1 +C +C SELECT NORMALIZATION TRANS NUMBER 0 +C + CALL GSELNT (0) +C +C SUBROUTINE SET3 ESTABLISHES THE MAPPING OF THREE SPACE COORDINATES +C ONTO THE GRAPHICS DEVICE COORDINATE SYSTEM. +C + CALL SET3 (.1,.9,.1,.9,0.,1.,0.,1.,0.,1.,EYE) +C +C THE FOLLOWING THREE CALLS TO LINE3 DRAW THE THREE SPACE AXES +C + CALL LINE3 (0.,0.,0.,0.,0.,1.) + CALL LINE3 (0.,0.,0.,0.,1.,0.) + CALL LINE3 (0.,0.,0.,1.,0.,0.) +C +C SUBROUTINE PWRZ IS USED TO LABEL EACH OF THE AXES AND THE PLOT +C ON INPUT TO PWRZ, +C THE FIRST THREE PARAMETERS AND ICNT DETERMINE THE POSITION OF THE +C CHARACTER STRING. +C ISIZE DETERMINES THE CHARACTER SIZE. +C LINE AND ITOP DETERMINE THE DIRECTION AND PLANE OF THE CHARACTERS. +C +C + ICNT = 0 + ISIZE = 30 + LINE = 2 + ITOP = 3 + CALL PWRZT (0.,.5,.1,'V-AXIS',6,ISIZE,LINE,ITOP,ICNT) +C + LINE = -1 + ITOP = 3 + CALL PWRZT (.5,0.,.1,'U-AXIS',6,ISIZE,LINE,ITOP,ICNT) +C + LINE = 3 + ITOP = -2 + CALL PWRZT (0.,.1,.5,'Z-AXIS',6,ISIZE,LINE,ITOP,ICNT) +C + LINE = 2 + ITOP = -1 + ISIZE = 30 + ICNT = -1 + CALL PWRZT (.5,.2,0.,'DEMONSTRATION OF PWRZT WITH THREED', + 1 34,ISIZE,LINE,ITOP,ICNT) +C +C A CALL TO NEWFM INDICATES THAT THE PICTURE IS COMPLETE +C + CALL NEWFM +C + IERROR = 0 +c WRITE (6,1001) +C + RETURN +C +C +C +c1001 FORMAT (' PWRZT TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/srf.com b/sys/gio/ncarutil/tests/srf.com new file mode 100644 index 00000000..d1b4288c --- /dev/null +++ b/sys/gio/ncarutil/tests/srf.com @@ -0,0 +1,4 @@ +int ifr, istp, irots, idrx, idry, idrz, iupper, iskirt, ncla, hskirt, ispval +real theta, chi, clo, cinc +common /srfip1/ ifr, istp, irots, idrx, idry, idrz, iupper, iskirt, + ncla, theta, hskirt, chi, clo, cinc, ispval diff --git a/sys/gio/ncarutil/tests/srfacet.f b/sys/gio/ncarutil/tests/srfacet.f new file mode 100644 index 00000000..4e5bad00 --- /dev/null +++ b/sys/gio/ncarutil/tests/srfacet.f @@ -0,0 +1,150 @@ + SUBROUTINE TSRFAC (nplot, IERROR) +C +C LATEST REVISION MARCH 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C SRFACE AND TO TEST SRFACE ON A SINGLE +C PROBLEM +C +C USAGE CALL TSRFAC (IERROR) +C +C ARGUMENTS +c +noao: additional input parameter +c nplot +c = 1, EZSRF is demonstrated +c = 2, SRFACE is demonstrated +c +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C = 0, IF THE TEST IS SUCCESSFUL, +C = 1, OTHERWISE +C +C I/O IF THE TEST IS SUCCESSFUL, THE MESSAGE +C +C SRFACE TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C +C IS PRINTED ON UNIT 6. +C +C IN ADDITION, TWO FRAMES CONTAINING THE +C SURFACE PLOT ARE PRODUCED ON THE MACHINE +C GRAPHICS DEVICE. IN ORDER TO DETERMINE +C IF THE TEST WAS SUCCESSFUL, IT IS +C NECESSARY TO EXAMINE THESE PLOTS. +C +C PRECISION SINGLE +C +C REQUIRED LIBRARY SRFACE +C FILES +C +C LANGUAGE FORTRAN +C +C HISTORY FIRST WRITTEN IN APRIL 1979, CONVERTED TO +C FORTRAN 77 AND GKS IN MARCH 1984. +C +C ALGORITHM THE FUNCTION +C +C Z(X,Y) = .25*(X + Y + 1./((X-.1)**2+Y**2+.09) +C - 1./((X+.1)**2+Y**2+.09)) +C +C IS EVALUATED FOR +C X = -1. TO 1. IN INCREMENTS OF .1 AND +C Y = -1.2 TO 1.2 IN INCREMENTS OF .1. +C TSRFAC CALLS SUBROUTINES EZSRFC AND SRFACE +C ONCE. EACH CALL PRODUCES A SURFACE PLOT +C OF THE ARRAY Z. +C +C PORTABILITY ANSI FORTRAN 77 +C +C XX CONTAINS THE X-DIRECTION COORDINATE VALUES FOR Z(X,Y), YY CONTAINS +C THE Y-DIRECTION COORDINATE VALUES FOR Z(X,Y), Z CONTAINS THE FUNCTION +C VALUES, S CONTAINS VALUES FOR THE LINE OF SIGHT FOR ENTRY SRFACE, +C WORK IS A WORK ARRAY, ANGH CONTAINS THE ANGLE IN DEGREES IN THE X-Y +C PLANE TO THE LINE OF SIGHT, ANGV CONTAINS THE ANGLE IN DEGREES FROM +C THE X-Y PLANE TO THE LINE OF SIGHT. +C + REAL XX(21) ,YY(25) ,Z(21,25) ,S(6) , + 1 WORK(1096) +C + DATA S(1), S(2), S(3), S(4), S(5), S(6)/ + 1 -8.0, -6.0, 3.0, 0.0, 0.0, 0.0/ +C + DATA ANGH/45./, ANGV/15./ +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE COORDINATES RANGE FROM 0. TO 1., THE VALUES CX AND CY +C DEFINE THE CENTER OF THE TITLE STRING. +C + DATA CX/.405/, CY/.97/ +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 0 +C +C FILL XX AND YY COORDINATE ARRAYS AND Z FUNCTION VALUE ARRAY +C + DO 20 I=1,21 + X = .1*FLOAT(I-11) + XX(I) = X + DO 10 J=1,25 + Y = .1*FLOAT(J-13) + YY(J) = Y + Z(I,J) = (X+Y+1./((X-.1)**2+Y**2+.09)- + 1 1./((X+.1)**2+Y**2+.09))*.25 + 10 CONTINUE + 20 CONTINUE +C +C SELECT NORMALIZATION TRANSFORMATION 0 +C + CALL GSELNT(0) +C +C EZSRFC DEMO +C +C LABEL THE PLOT FOR ENTRY EZSRFC +C +C SET TEXT ALIGNMENT TO CENTER THE STRING AT THE STRING CENTER +C AND IN THE VERTICAL CENTER +C + CALL GSTXAL(2,3) +C +C SET CHARACTER HEIGHT +C + CALL GSCHH(.016) +C +C PLOT CHARACTERS +C + if (nplot .eq. 1) then + CALL GTX(CX,CY,'DEMONSTRATION PLOT FOR EZSRFC ENTRY OF SRFACE') + CALL EZSRFC (Z,21,25,ANGH,ANGV,WORK) + endif +C +C +C SRFACE DEMO +C +C LABEL THE PLOT FOR ENTRY SRFACE +C +C SET TEXT ALIGNMENT TO CENTER THE STRING AT THE STRING CENTER +C AND IN THE VERTICAL CENTER +C + CALL GSTXAL(2,3) +C +C SET CHARACTER HEIGHT +C + CALL GSCHH(.016) +C +C PLOT CHARACTERS +C + if (nplot .eq. 2) then + CALL GTX(CX,CY,'DEMONSTRATION PLOT FOR SRFACE ENTRY OF SRFACE') + CALL SRFACE (XX,YY,Z,WORK,21,21,25,S,0.) + endif +C +c WRITE (6,1001) +C + RETURN +C +C1001 FORMAT (' SRFACE TEST SUCCESSFUL',24X, +C 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/srftest.x b/sys/gio/ncarutil/tests/srftest.x new file mode 100644 index 00000000..cf1496b7 --- /dev/null +++ b/sys/gio/ncarutil/tests/srftest.x @@ -0,0 +1,68 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +procedure srf_test() + +char temp[SZ_LINE] +real z[20,30], x[20], y[30], s[6] +int mm[20,30,2] +real tx, ty +int i, j, m, n, isize +real xt, yt, dum + +int ifr, istp, irots, idrx, idry, idrz, iupper, iskirt, ncla, hskirt, ispval +real theta, chi, clo, cinc +common /srfip1/ ifr, istp, irots, idrx, idry, idrz, iupper, iskirt, + ncla, theta, hskirt, chi, clo, cinc, ispval + +begin + # Some initialization that was originally in data statements: + tx = 0.4375 + ty = 0.9667 + m = 20 + n = 30 + s[1] = 4.0 + s[2] = 5.0 + s[3] = 3.0 + s[4] = 0.0 + s[5] = 0.0 + s[6] = 0.0 + + # Define function values and store in z + DO I=1,M + X(I) = -1.+FLOAT(I-1)/FLOAT(M-1)*2. + + DO J=1,N + Y(J) = -1.+FLOAT(J-1)/FLOAT(N-1)*2. + + DO J=1,N { + DO I=1,M + Z(I,J) = EXP(-2.*SQRT(X(I)**2+Y(J)**2)) + } + + # Initialize block data before changing parameters. + call srfabd + + IFR = 0 + IDRZ = 1 + + CALL GSELNT (0) + call f77pak ("DEMONSTRATION PLOT FOR PWRZS", temp, SZ_LINE) + CALL WTSTR (TX,TY,temp,2,0,0) + + CALL SRFACE (X,Y,Z,MM,M,M,N,S,0.) +# +# PUT PWRZS LABELS ON PICTURE +# + ISIZE = 35 + call f77pak ("FRONT", temp, SZ_LINE) + CALL PWRZS (0.,1.1,0.,temp,5,ISIZE,-1,3,0) + call f77pak ("SIDE", temp, SZ_LINE) + CALL PWRZS (1.1,0.,0.,temp,4,ISIZE,2,-1,0) + call f77pak (" BACK BACK BACK BACK BACK", temp, SZ_LINE) + CALL PWRZS (0.,-1.1,.2,temp,25,ISIZE,-1,3,0) +# +# RESTORE SRFACE PARAMETERS TO DEFAULT +# + IFR = 1 + IDRZ = 0 +end diff --git a/sys/gio/ncarutil/tests/srftestd.x b/sys/gio/ncarutil/tests/srftestd.x new file mode 100644 index 00000000..8c22ff92 --- /dev/null +++ b/sys/gio/ncarutil/tests/srftestd.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +task srftest = t_srftest + +define DUMMY 6 + +# Rewrite of pwrzs.t.f in spp to check things out. + +procedure t_srftest() + +char device[SZ_FNAME] +int error_code, wkid +int gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call srf_test() + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/strmln.x b/sys/gio/ncarutil/tests/strmln.x new file mode 100644 index 00000000..2835d211 --- /dev/null +++ b/sys/gio/ncarutil/tests/strmln.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +# Test NCAR routine STRMLN + +procedure t_strmln() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tstrml (error_code) + if (error_code == 0) + call printf ("Test successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/strmlnt.f b/sys/gio/ncarutil/tests/strmlnt.f new file mode 100644 index 00000000..f2b40c69 --- /dev/null +++ b/sys/gio/ncarutil/tests/strmlnt.f @@ -0,0 +1,101 @@ + SUBROUTINE TSTRML (IERROR) +C +C LATEST REVISION JUNE 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C ROUTINE STRMLN. +C +C USAGE CALL TSTRML (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C =0 IF THERE IS A NORMAL EXIT FROM THE +C ROUTINE STRMLN. +C =1 OTHERWISE +C +C I/O IF THERE IS A NORMAL EXIT FROM THE ROUTINE +C STRMLN THE MESSAGE +C STRMLN TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C IS PRINTED. +C +C PRECISION SINGLE +C +C +C LANGUAGE FORTRAN +C +C ALGORITHM ROUTINE TSTRML CALLS ROUTINE STRMLN TO +C PRODUCE A PLOT REPRESENTING THE FLOW AND +C MAGNITUDE OF A VECTOR FIELD. +C +C PORTABILITY FORTRAN77 +C +C +C + REAL U(21,25) ,V(21,25) ,WRK(1050) +C +C SPECIFY COORDINATES FOR PLOT TITLES. ON AN ABSTRACT GRID WHERE +C THE INTEGER COORDINATES RANGE FROM 0.0 TO 1.0, THE VALUES TX AND TY +C DEFINE THE CENTER OF THE TITLE STRING. +C + DATA TX/.5/,TY/.9765/ +C +C SET DIMENSIONS +C + DATA NH,NV/21,25/ +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 1 +C +C SPECIFY HORIZONTAL AND VERTICAL VECTOR COMPONENTS U AND V ON +C THE RECTANGULAR GRID +C + TPIMX = 2.*3.14/FLOAT(NH) + TPJMX = 2.*3.14/FLOAT(NV) + DO 20 J=1,NV + DO 10 I=1,NH + U(I,J) = SIN(TPIMX*(FLOAT(I)-1.)) + V(I,J) = SIN(TPJMX*(FLOAT(J)-1.)) + 10 CONTINUE + 20 CONTINUE +C +C SELECT NORMALIZATION TRANSFORMATION 0 +C + CALL GSELNT (0) +C +C CALL WTSTR FOR STRMLN PLOT TITLE +C + CALL WTSTR (TX,TY,'DEMONSTRATION PLOT FOR ROUTINE STRMLN',2, + 1 0,0) +C +C DEFINE NORMALIZATION TRANSFORMATION 1, AND SET UP LOG SCALING +C + CALL GSVP ( 1, 0.1, 0.9, 0.1, 0.9 ) + CALL GSWN ( 1, 1.0, 21., 1.0, 25. ) + CALL SETUSV ( 'LS' , 1 ) +C +C SELECT NORMALIZATION TRANSFORMATION 1 +C + CALL GSELNT (1) +C +C DRAW PERIMETER +C +c CALL PERIM(1,0,1,0) +C +C CALL STRMLN FOR VECTOR FIELD STREAMLINES PLOT +C + CALL STRMLN (U,V,WRK,NH,NH,NV,0,IER) +C +c CALL NEWFM +C + IERROR = 0 +c WRITE (6,1001) + RETURN +C +c1001 FORMAT (' STRMLN TEST SUCCESSFUL',24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/surface.x b/sys/gio/ncarutil/tests/surface.x new file mode 100644 index 00000000..07b25e9a --- /dev/null +++ b/sys/gio/ncarutil/tests/surface.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +# Test NCAR routines SRFACE. + +procedure t_surface() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tsrfac (2, error_code) + if (error_code == 0) + call printf ("Test of SRFACE successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/threed.x b/sys/gio/ncarutil/tests/threed.x new file mode 100644 index 00000000..a22d51da --- /dev/null +++ b/sys/gio/ncarutil/tests/threed.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +# Test NCAR routine THREED + +procedure t_threed() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tthree (error_code) + if (error_code == 0) + call printf ("Test successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/threed2.x b/sys/gio/ncarutil/tests/threed2.x new file mode 100644 index 00000000..224fd2c3 --- /dev/null +++ b/sys/gio/ncarutil/tests/threed2.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +# Test NCAR routine THREED with extra test program tst3d2 + +procedure t_threed2() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tst3d2 () + if (error_code == 0) + call printf ("Test successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/threed2t.f b/sys/gio/ncarutil/tests/threed2t.f new file mode 100644 index 00000000..baaa8f78 --- /dev/null +++ b/sys/gio/ncarutil/tests/threed2t.f @@ -0,0 +1,26 @@ + subroutine tst3d2 () + real eye(3) + dimension u(50), v(50), w(50) + data eye /5., -10., 4./ + isiz = 36 + xs = 90. / 1024. + xe = 1010. / 1024. + ys = 90. / 1024. + ye = 1010. / 1024. + call tick43 (24, 16, 24, 16, 24, 16) +c call set3 (90, 1010, 90, 1010, 0., 2., -1., 1., 0., 1., eye) + call set3 (xs, xe, ys, ye, 0., 2., -1., 1., 0., 1., eye) + do 1 i = 1, 50 + u(i) = float(i) * .04 + v(i) = sin (u(i) * 6.) * float (80 - i) / 80. + w(i) = .5 + sin (u(i) *3.141592) * .5 + 1 continue + call perim3 (2,5,1,5,1,0.) + call perim3 (2,5,1,5,2,-1.) + call perim3 (2,5,2,5,3,0.) + call pwrzt (2.1, -1., 0., 3hU->, 3, isiz, 1,3,-1) + call pwrzt (0., 1.1, 0., 3hV->, 3, isiz, 2,3,0) + call pwrzt (0., -1., 1.1, 2hW , 2, isiz, 3, -1, 0) + call fence3 (u, v, w, 50, 3, 0.) + end + diff --git a/sys/gio/ncarutil/tests/threedt.f b/sys/gio/ncarutil/tests/threedt.f new file mode 100644 index 00000000..0cb6532d --- /dev/null +++ b/sys/gio/ncarutil/tests/threedt.f @@ -0,0 +1,129 @@ + SUBROUTINE TTHREE (IERROR) +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C THE ROUTINE THREED. +C +C USAGE CALL TTHREE (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C =0 IF THERE IS A NORMAL EXIT FROM THE +C ROUTINE THREED. +C =1 OTHERWISE +C +C I/O IF THERE IS A NORMAL EXIT FROM THE ROUTINE +C THREED THE MESSAGE +C THREED TEST SUCCESSFUL . . . SEE PLOT TO +C VERIFY PERFORMANCE +C IS PRINTED. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C HISTORY ORIGINALLY WRITTEN NOVEMBER 1976 +C CONVERTED TO GKS AND FORTRAN 77 JULY 1984 +C +C ALGORITHM ROUTINE TTHREE CALLS SET3 TO ESTABLISH A +C MAPPING BETWEEN THE PLOTTER ADDRESSES AND +C THE USER'S VOLUME, AND TO INDICATE THE +C COORDINATES OF THE EYE POSITION FROM +C WHICH THE LINES TO BE DRAWN ARE VIEWED. +C NEXT, THE VOLUME PERIMETERS AND ASSOCIATED +C TICK MARKS ARE DRAWN BY CALLS TO PERIM3. +C THEN THE LINES ARE DRAWN. THESE ARE +C CERTAIN LATITUDES AND LONGITUDES OF A +C SPHERE. +C +C PORTABILITY ANSI FORTRAN 77 +C +C +C +C + REAL EYE(3),X(31),Y(31),Z(31) +C +C SPECIFY ARGUMENT VALUES TO BE USED BY ROUTINE SET3. ON AN +C ABSTRACT PLOTTER WITH AN ADDRESS RANGE OF 0. TO 1. IN EACH +C COORDINATE DIRECTION, THE VALUES RXA, RXB, RYA, AND RYB +C DEFINE THE PORTION OF THE ADDRESS SPACE TO BE USED IN MAKING +C THE PLOT. UC, UD, VC, VD, WC, WD DEFINE A VOLUME IN USER +C COORDINATES WHICH IS TO BE MAPPED ONTO THE PORTION OF THE +C VIEWING SURFACE AS SPECIFIED BY RXA, RXB, RYA, AND RYB. +C + DATA RXA/0.097656/, RXB/0.90236/, RYA/0.097656/, RYB/0.90236/ + DATA UC/-1./, UD/1./, VC/-1./, VD/1./, WC/-1./, WD/1./ + DATA EYE(1),EYE(2),EYE(3)/10.,6.,3./ + DATA TX/0.4374/, TY/0.9570/ +C +C DEFINE PI + DATA PI/3.1415926535898/ +C +C +C SELECT NORMALIZATION TRANSFORMATION 0 +C + CALL GSELNT (0) +C +C CALL SET3 TO ESTABLISH A MAPPING BETWEEN THE PLOTTER ADDRESSES +C AND THE USER'S VOLUME, AND TO INDICATE THE COORDINATES OF THE +C EYE POSITION FROM WHICH THE LINES TO BE DRAWN ARE VIEWED. +C + CALL SET3(RXA,RXB,RYA,RYB,UC,UD,VC,VD,WC,WD,EYE) +C +C CALL PERIM3 TO DRAW PERIMETER LINES AND TICK MARKS +C + CALL PERIM3(2,5,1,10,1,-1.) + CALL PERIM3(4,2,1,1,2,-1.) + CALL PERIM3(2,10,4,5,3,-1.) +C +C DEFINE AND DRAW LATITUDINAL LINES ON THE SPHERE OF RADIUS ONE +C HAVING CENTER (0.,0.,0.) +C + DO 10 J=1,18 + THETA = FLOAT(J)*PI/9. + CT = COS(THETA) + ST = SIN(THETA) + DO 20 K=1,31 + PHI = FLOAT(K-16)*PI/30. + Z(K) = SIN(PHI) + CP = COS(PHI) + X(K) = CT*CP + Y(K) = ST*CP + 20 CONTINUE + CALL CURVE3(X,Y,Z,31) + 10 CONTINUE +C +C DEFINE AND DRAW LONGITUDINAL LINES ON THE SPHERE OF RADIUS ONE +C HAVING CENTER (0.,0.,0.) +C + DO 30 K=1,5 + PHI = FLOAT(K-3)*PI/6. + SP = SIN(PHI) + CP = COS(PHI) + DO 40 J=1,31 + TUETA = FLOAT(J-1)*PI/15. + X(J) = COS(TUETA)*CP + Y(J) = SIN(TUETA)*CP + Z(J) = SP + 40 CONTINUE + CALL CURVE3(X,Y,Z,31) + 30 CONTINUE +C +C CALL WTSTR FOR THREED PLOT TITLE +C + CALL WTSTR(TX,TY,'DEMONSTRATION PLOT FOR ROUTINE THREED',2,0,0) + call pwrzt (1.,0.,-1.,'DEMONSTRATION PLOT FOR ROUTINE THREED', 37, + * 2, 2, 3, 0) +C +c CALL NEWFM +C + IERROR = 0 +c WRITE(6,1001) + RETURN +C +c1001 FORMAT(' THREED TEST SUCCESSFUL', 24X, +c 1 'SEE PLOT TO VERIFY PERFORMANCE') + END diff --git a/sys/gio/ncarutil/tests/velvctt.f b/sys/gio/ncarutil/tests/velvctt.f new file mode 100644 index 00000000..36e22d28 --- /dev/null +++ b/sys/gio/ncarutil/tests/velvctt.f @@ -0,0 +1,126 @@ + SUBROUTINE TVELVC (nplot, IERROR) +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE TO PROVIDE A SIMPLE DEMONSTRATION OF +C SUBROUTINES VELVCT AND EZVEC. +C +C USAGE CALL TVELVC (IERROR) +C +C ARGUMENTS +C +C ON OUTPUT IERROR +C AN INTEGER VARIABLE +C =0 IF THERE IS A NORMAL EXIT FROM THE +C ROUTINES VELVCT AND EZVEC +C =1 OTHERWISE +C +C I/O IF THERE IS A NORMAL EXIT FROM THE ROUTINES +C VELVCT AND EZVEC THE MESSAGE +C VELVCT TEST SUCCESSFUL . . . SEE PLOTS TO +C VERIFY PERFORMANCE +C IS PRINTED. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C HISTORY ORIGINALLY WRITTEN NOVEMBER 1976 +C +C ALGORITHM ROUTINE TVELVC CALLS ROUTINES EZVEC AND +C VELVCT ONCE. EACH CALL PRODUCES A PLOT +C REPRESENTING A VECTOR FIELD. THE VECTOR +C FIELD IS OBTAINED FROM THE FUNCTION +C Z(X,Y) = X + Y + 1./((X-.1)**2+Y**2+.09) +C -1./((X+.1)**2+Y**2+.09), +C BY USING THE DIRECTION OF THE Z GRADIENT +C VECTORS AND THE LOGARITHM OF THE ABSOLUTE +C VALUE OF THE COMPONENTS. +C +C +C +C + DIMENSION U(21,25) ,V(21,25) +C +C SPECIFY COORDS FOR PLOT TITLES +C + DATA IX/94/,IY/1000/ +C +C SPECIFY SOME OF THE ARGUMENTS IN VELVCT CALLING SEQUENCE +C + DATA FLO/0./,HI/0./,NSET/0/,LENGTH/0/,ISPV/0/,SPV/0./ +C +C INITIALIZE ERROR PARAMETER +C + IERROR = 1 +C +C SPECIFY VELOCITY FIELD FUNCTIONS U AND V +C + M = 21 + N = 25 + DO 20 I=1,M + X = .1*FLOAT(I-11) + DO 10 J=1,N + Y = .1*FLOAT(J-13) + DZDX = 1.-2.*(X-.10)/((X-.10)**2+Y**2+.09)**2+ + 1 2.*(X+.10)/((X+.10)**2+Y**2+.09)**2 + DZDY = 1.-2.*Y/((X-.10)**2+Y**2+.09)**2+ + 1 2.*Y/((X+.10)**2+Y**2+.09)**2 + UVMAG = ALOG(SQRT(DZDX*DZDX+DZDY*DZDY)) + UVDIR = ATAN2(DZDY,DZDX) + U(I,J) = UVMAG*COS(UVDIR) + V(I,J) = UVMAG*SIN(UVDIR) + 10 CONTINUE + 20 CONTINUE +C +C CALL WTSTR FOR EZVEC PLOT TITLE +C +c +noao: flag used to plot either velvct or ezvec + if (nplot .eq. 1) then + CALL GQCNTN(IERR,ICN) + CALL GSELNT(0) +c X = PAU2FX(IX) + x = cpux (ix) +c Y = PAU2FY(IY) + y = cpuy (iy) + CALL WTSTR (X,Y,'DEMONSTRATION PLOT FOR ENTRY EZVEC OF VELVCT', + 1 2,0,-1) + CALL GSELNT(ICN) +C +C CALL EZVEC FOR VELOCITY FIELD PLOT +C + CALL EZVEC (U,V,M,N) + endif +c -noao +C +C CALL VELVCT FOR VELOCITY FIELD PLOT +C +c +noao: flag used to plot either velvct or ezvec + if (nplot .eq. 2) then + CALL VELVCT (U,M,V,M,M,N,FLO,HI,NSET,LENGTH,ISPV,SPV) +C +C CALL WTSTR FOR VELVCT PLOT TITLE +C + CALL GQCNTN(IERR,ICN) + CALL GSELNT(0) +c X = PAU2FX(IX) + x = cpux (ix) +c Y = PAU2FY(IY) + y = cpuy (iy) + CALL WTSTR (X,Y, + 1 'DEMONSTRATION PLOT FOR ENTRY VELVCT OF VELVCT',2, + 2 0,-1) + CALL GSELNT(ICN) + endif +c -noao +c +c CALL NEWFM +C + IERROR = 0 +c WRITE (6,1001) + RETURN +C +c1001 FORMAT (' VELVCT TEST SUCCESSFUL',24X, +c 1 'SEE PLOTS TO VERIFY PERFORMANCE') +C + END diff --git a/sys/gio/ncarutil/tests/velvect.x b/sys/gio/ncarutil/tests/velvect.x new file mode 100644 index 00000000..d09f1c08 --- /dev/null +++ b/sys/gio/ncarutil/tests/velvect.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define DUMMY 6 + +include +include + +# Test NCAR routines VELVEC + +procedure t_velvect() + +char device[SZ_FNAME] +int error_code, wkid +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + + call gopks (STDERR) + wkid = 1 + gp = gopen (device, NEW_FILE, STDGRAPH) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call tvelvc (2, error_code) + if (error_code == 0) + call printf ("Test successful\n") + + call gdawk (wkid) + call gclwk (wkid) + call gclks () +end diff --git a/sys/gio/ncarutil/tests/x_ncartest.x b/sys/gio/ncarutil/tests/x_ncartest.x new file mode 100644 index 00000000..cc8b727f --- /dev/null +++ b/sys/gio/ncarutil/tests/x_ncartest.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# These tasks temporarily deleted: conraq = t_conraq, conras = t_conras, + #ezmapg = t_ezmapg, + +task conran = t_conran, + autograph = t_autograph, + oldauto = t_oldauto, + dashsmth = t_dashsmth, + pwrzs = t_przs, + srface = t_surface, + ezsrface = t_ezsurface, + conrec = t_conrec, + ezconrec = t_ezconrec, + hafton = t_hafton, + isosrf = t_isosrf, + ezisosrf = t_ezisos, + ezhafton = t_ezhafton, + pwrity = t_pwrity, + threed = t_threed, + threed2 = t_threed2, + velvec = t_velvect, + ezvelvec = t_ezvelvect, + strmln = t_strmln diff --git a/sys/gio/ncarutil/threbd.f b/sys/gio/ncarutil/threbd.f new file mode 100644 index 00000000..5dbce5e0 --- /dev/null +++ b/sys/gio/ncarutil/threbd.f @@ -0,0 +1,56 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +c +noao: block data threbd changed to run time initialization + subroutine threbd +c BLOCKDATA THREBD + COMMON /TEMPR/ RZERO + COMMON /SET31/ ISCALE ,XMIN ,XMAX ,YMIN, + 1 YMAX ,BIGD ,R0 ,NLX, + 2 NBY ,NRX ,NTY + COMMON /TCK31/ TMAGU ,TMINU ,TMAGV ,TMINV, + 1 TMAGW ,TMINW + COMMON /THRINT/ ITHRMJ ,ITHRMN ,ITHRTX +c +noao: following flag added to prevent over-initialization + logical first + SAVE + data first /.true./ + if (.not. first) then + return + endif + first = .false. + +c DATA RZERO/0./ + RZERO = 0. +c +c DATA NLX,NBY,NRX,NTY/10,10,1010,1010/ + NLX = 10 + NBY = 10 + NRX = 1010 + NTY = 1010 +c +c DATA TMAGU,TMINU,TMAGV,TMINV,TMAGW,TMINW/12.,8.,12.,8.,12.,8./ + TMAGU = 12. + TMINU = 8. + TMAGV = 12. + TMINV = 8. + TMAGW = 12. + TMINW = 8. +c +c DATA ITHRMJ,ITHRMN,ITHRTX/ 1,1,1/ + ITHRMJ = 2 + ITHRMN = 1 + ITHRTX = 1 +c +c -noao + END diff --git a/sys/gio/ncarutil/threed.f b/sys/gio/ncarutil/threed.f new file mode 100644 index 00000000..3b5061f4 --- /dev/null +++ b/sys/gio/ncarutil/threed.f @@ -0,0 +1,826 @@ + SUBROUTINE SET3 (XA,XB,YA,YB,ULO,UHI,VLO,VHI,WLO,WHI,EYE) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C THREE-DIMENSIONAL LINE DRAWING PACKAGE +C +C +C LATEST REVISION JULY, 1984 +C +C PURPOSE THREED IS A PACKAGE OF SUBROUTINES THAT +C PROVIDES LINE DRAWING CAPABILITIES IN +C THREE-SPACE. +C +C USAGE EACH ENTRY POINT IN THIS PACKAGE IS +C DESCRIBED BELOW. +C +C SET3 (XA,XB,YA,YB,UC,UD,VC,VD,WC,WD,EYE) +C +C XA, XB, YA, YB DEFINE THE PORTION OF THE +C PLOTTING SURFACE INTO WHICH THE USER'S +C PLOT WILL BE PLACED. THESE VALUES SHOULD +C BE IN THE RANGE 0. TO 1. FOR EXAMPLE, IF +C ONE WANTS THE PLOT TO OCCUPY THE MAXIMUM +C PLOTTING SURFACE, SET XA=0., YA=0., XB=1., +C YB=1.; IF ONE WANTS THE PLOT TO APPEAR IN +C THE LOWER LEFT CORNER OF THE PLOTTING +C SURFACE, SET XA=0., YA=0., XB=.5, YB=.5 . +C +C UC, UD, VC, VD, WC, AND WD DEFINE A +C VOLUME IN USER-COORDINATE SPACE WHICH +C WILL BE TRANSFORMED ONTO THE PLOTTING +C SURFACE DEFINED BY XA, XB, YA, YB. +C +C EYE IS AN ARRAY, 3 WORDS LONG, CONTAINING THE +C U, V, AND W COORDINATES OF THE EYE POSITION. +C ALL LINES IN THE PLOT ARE DRAWN AS VIEWED +C FROM THE EYE. EYE IS SPECIFIED IN USER +C COORDINATES AND SHOULD BE OUTSIDE THE BOX +C DEFINED BY UC, UD, VC, VC, WC, AND WD. +C +C CURVE3 (U,V,W,N) +C +C DRAWS A CURVE THROUGH N POINTS. THE +C POINTS ARE DEFINED BY THE LINEAR ARRAYS +C U, V, AND W WHICH ARE DIMENSIONED N OR +C GREATER. +C +C LINE3 (UA,VA,WA,UB,VB,WB) +C +C DRAWS A LINE CONNECTING THE COORDINATES +C (UA,VA,WA) AND (UB,VB,WB). +C +C FRST3 (U,V,W) +C +C POSITIONS THE PEN TO (U,V,W). +C +C VECT3 (U,V,W) +C +C DRAWS A LINE BETWEEN THE CURRENT PEN +C POSITION AND THE POINT (U,V,W). THE +C CURRENT PEN POSITION BECOMES (U,V,W). +C NOTE THAT A CURVE CAN BE DRAWN BY USING +C A FRST3 CALL FOLLOWED BY A SEQUENCE OF +C VECT3 CALLS. +C +C POINT3 (U,V,W) +C +C PLOTS A POINT AT (U,V,W) . +C +C PERIM3 (MAGR1,MINR1,MAGR2,MINR2,IWHICH,VAR) +C +C DRAWS A PERIMETER WITH TICK MARKS. +C +C IWHICH DESIGNATES THE NORMAL VECTOR TO THE +C PERIMETER DRAWN (1=U, 2=V, 3=W). +C +C VAR IS THE VALUE ON THE AXIS SPECIFIED BY +C INWHICH WHERE THE PERIMETER IS TO BE DRAWN. +C +C MAGR1 AND MAGR2 SPECIFY THE +C NUMBER OF MAJOR TICK MARKS TO BE DRAWN IN +C THE TWO COORDINATE DIRECTIONS. +C +C MINR1 AND MINR2 SPECIFY THE NUMBER +C OF MINOR TICKS BETWEEN EACH MAJOR TICK. +C +C MAGR1, MAGR2, MINR1 AND MINR2 +C ARE SPECIFIED BY THE NUMBER +C OF DIVISIONS(HOLES), NOT THE NUMBER OF +C TICKS. SO IF MAGR1=1, THERE WOULD BE NO +C MAJOR DIVISIONS. +C +C TICK43 (MAGU,MINU,MAGV,MINV,MAGW,MINW) +C +C TICK43 ALLOWS PROGRAM CONTROL OF TICK +C MARK LENGTH IN SUBROUTINE PERIM3. +C MAGU, MAGV, MAGW SPECIFY THE LENGTH, +C IN PLOTTER ADDRESS UNITS OF MAJOR +C DIVISION TICK MARKS ON THE U, V, AND W +C AXES. MINU, MINV, MINW SPECIFY THE LENGTH, +C IN PLOTTER ADDRESS UNITS OF MINOR +C DIVISION TICK MARKS ON THE U, V, AND +C W AXES. +C +C FENCE3 (U,V,W,N,IOREN,BOT) +C +C THIS ENTRY IS USED TO DRAW A LINE IN THREE- +C SPACE AS WELL AS A "FENCE" BETWEEN THE +C LINE AND A PLANE NORMAL TO ONE OF THE +C COORDINATE AXES. +C +C THE ARGUMENTS U, V, W AND N +C ARE THE SAME AS FOR CURVE, DESCRIBED ABOVE. +C +C IOREN SPECIFIES THE DIRECTION IN WHICH THE +C FENCE LINES ARE TO BE DRAWN (1 INDICATES +C PARALLEL TO THE U-AXIS, 2 INDICATES PARALLEL +C TO THE V-AXIS, AND 3 INDICATES PARALLEL TO +C TO THE W-AXIS.) +C +C BOT SPECIFIES WHERE THE BOTTOM OF THE FENCE +C IS TO BE DRAWN. +C IF THE FENCE LINES ARE TO BE DRAWN PARALLEL +C TO THE W-AXIS, AND BOT=2., THEN THE BOTTOM +C OF THE FENCE WOULD BE THE PLANE W=2. +C +C ON OUTPUT ALL ARGUMENTS ARE UNCHANGED. +C +C NOTES . FOR DRAWING CHARACTERS IN CONJUNCTION +C WITH THREED, USE THE COMPANION ROUTINE +C PWRZT. +C +C ENTRY POINTS FENCE3, TRN32T, FRST3, VECT3, LIN3, +C POINT3, CURVE3, PSYM3, PERIM3, LINE3W, +C DRAWT, TICK43, TICK3, THREBD +C +C COMMON BLOCKS TEMPR, SET31, PWRZ1T, TCK31, PRM31, THRINT +C +C REQUIRED LIBRARY PWRZ AND THE SPPS +C ROUTINES +C +C HISTORY WRITTEN AND STANDARDIZED IN NOVEMBER 1973. +C I/O PLOTS LINES. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C ACCURACY + OR -.5 PLOTTER ADDRESS UNITS PER CALL. +C THERE IS NO CUMULATIVE ERROR. +C +C PORTABILITY ANSI FORTRAN 77 +C +C +C +C +C + SAVE +C + COMMON /TEMPR/ RZERO +C + DIMENSION EYE(3) +C + COMMON /SET31/ ISCALE ,XMIN ,XMAX ,YMIN , + 1 YMAX ,BIGD ,R0 ,NLX , + 2 NBY ,NRX ,NTY + COMMON /PWRZ1T/ UUMIN ,UUMAX ,VVMIN ,VVMAX , + 1 WWMIN ,WWMAX ,DELCRT ,EYEU , + 2 EYEV ,EYEW +C +C + AVE(A,B) = (A+B)*.5 +C +C ARITHMETIC STATEMENT FUNCTION FOR SCALING +C + SU(UTEMP) = UTEMP + SV(VTEMP) = VTEMP + SW(WTEMP) = WTEMP +C +C +NOAO - Blockdata threbd rewritten as run time initialization. +C +C EXTERNAL THREBD + call threbd +C -NOAO +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','SET3','VERSION 1') +C +C SET UP FRAME SIZE +C + NLX = XA*1023.+1. + NRX = XB*1023.+1. + NBY = YA*1023.+1. + NTY = YB*1023.+1. +C +C CONSTANTS FOR PWRZT +C + UUMIN = ULO + UUMAX = UHI + VVMIN = VLO + VVMAX = VHI + WWMIN = WLO + WWMAX = WHI + EYEU = EYE(1) + EYEV = EYE(2) + EYEW = EYE(3) +C +C FIND CORNERS IN 2-SPACE FOR 3-SPACE BOX CONTAINING OBJECT +C + ISCALE = 0 + ATU = AVE(SU(UUMIN),SU(UUMAX)) + ATV = AVE(SV(VVMIN),SV(VVMAX)) + ATW = AVE(SW(WWMIN),SW(WWMAX)) + BIGD = 0. + IF (RZERO .LE. 0.) GO TO 10 +C +C RELATIVE SIZE FEATURE IN USE. THIS SECTION OF CODE IS NEVER +C EXECUTED UNLESS RZERO IS SET POSITIVE IN THE CALLING PROGRAM +C VIA COMMON BLOCK TEMPR. RZERO IS THE DISTANCE BETWEEN THE +C OBSERVER AND THE POINT LOOKED AT (CENTER OF THE BOX BY DEFAULT) +C WHEN THE INPUT BOX IS TO FILL THE SCREEN WHEN VIEWED FROM THE +C DIRECTION WHICH MAKES THE BOX BIGGEST. RZERO IS THUS TO +C BE USED TO DETERMINE THE SHAPE OF THE OBJECT. THIS SECTION +C OF CODE IS TO BE USED WHEN IT IS DESIRED TO KEEP THE VIEWED +C OBJECT IN RELATIVE PERSPECTIVE ACROSS FRAMES--E.G. IN MAKING +C MOVIES. +C + ALPHA = -(VVMIN-ATV)/(UUMIN-ATU) + VVEYE = -RZERO/SQRT(1.+ALPHA*ALPHA) + UUEYE = VVEYE*ALPHA + VVEYE = VVEYE+ATV + UUEYE = UUEYE+ATU + WWEYE = ATW + CALL TRN32T (ATU,ATV,ATW,UUEYE,VVEYE,WWEYE,1) + CALL TRN32T (UUMIN,VVMIN,ATW,XMIN,DUMM,DUMM,2) + CALL TRN32T (UUMAX,VVMIN,WWMIN,DUMM,YMIN,DUMM,2) + CALL TRN32T (UUMAX,VVMAX,ATW,XMAX,DUMM,DUMM,2) + CALL TRN32T (UUMAX,VVMIN,WWMAX,DUMM,YMAX,DUMM,2) + BIGD = SQRT((UUMAX-UUMIN)**2+(VVMAX-VVMIN)**2+(WWMAX-WWMIN)**2)*.5 + R0 = RZERO + GO TO 20 + 10 CALL TRN32T (ATU,ATV,ATW,EYE(1),EYE(2),EYE(3),1) + CALL TRN32T (SU(UUMIN),SV(VVMIN),SW(WWMIN),X1,Y1,DUM,2) + CALL TRN32T (SU(UUMIN),SV(VVMIN),SW(WWMAX),X2,Y2,DUM,2) + CALL TRN32T (SU(UUMIN),SV(VVMAX),SW(WWMIN),X3,Y3,DUM,2) + CALL TRN32T (SU(UUMIN),SV(VVMAX),SW(WWMAX),X4,Y4,DUM,2) + CALL TRN32T (SU(UUMAX),SV(VVMIN),SW(WWMIN),X5,Y5,DUM,2) + CALL TRN32T (SU(UUMAX),SV(VVMIN),SW(WWMAX),X6,Y6,DUM,2) + CALL TRN32T (SU(UUMAX),SV(VVMAX),SW(WWMIN),X7,Y7,DUM,2) + CALL TRN32T (SU(UUMAX),SV(VVMAX),SW(WWMAX),X8,Y8,DUM,2) + XMIN = AMIN1(X1,X2,X3,X4,X5,X6,X7,X8) + XMAX = AMAX1(X1,X2,X3,X4,X5,X6,X7,X8) + YMIN = AMIN1(Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8) + YMAX = AMAX1(Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8) +C +C ADD RIGHT AMOUNT TO KEEP PICTURE SQUARE +C + 20 WIDTH = XMAX-XMIN + HIGHT = YMAX-YMIN + DIF = .5*(WIDTH-HIGHT) + IF (DIF) 30, 50, 40 + 30 XMIN = XMIN+DIF + XMAX = XMAX-DIF + GO TO 50 + 40 YMIN = YMIN-DIF + YMAX = YMAX+DIF + 50 ISCALE = 1 + CALL TRN32T (ATU,ATV,ATW,EYE(1),EYE(2),EYE(3),1) + RETURN + END + SUBROUTINE TRN32T (U,V,W,XT,YT,ZT,IENT) +C +C THIS ROUTINE IMPLEMENTS THE 3-SPACE TO 2-SPACE TRANSFOR- +C MATION BY KUBER, SZABO AND GIULIERI, THE PERSPECTIVE +C REPRESENTATION OF FUNCTIONS OF TWO VARIABLES. J. ACM 15, +C 2, 193-204,1968. +C TRN32T ARGUMENTS +C U,V,W ARE THE 3-SPACE COORDINATES OF THE INTERSECTION +C OF THE LINE OF SIGHT AND THE IMAGE PLANE. THIS +C POINT CAN BE THOUGHT OF AS THE POINT LOOKED AT. +C XT,YT,ZT ARE THE 3-SPACE COORDINATES OF THE EYE POSITION. +C +C TRN32 ARGUMENTS +C U,V,W ARE THE 3-SPACE COORDINATES OF A POINT TO BE +C TRANSFORMED. +C XT,YT THE RESULTS OF THE 3-SPACE TO 2-SPACE TRANSFOR- +C MATION. WHEN ISCALE=0, XT AND YT ANR IN THE SAME +C UNITS AS U,V, AND W. WHEN ISCALE'0, XT AND YT +C ARE IN PLOTTER COORDINATES. +C ZT NOT USED. +C +C + SAVE +C + COMMON /PWRZ1T/ UUMIN ,UUMAX ,VVMIN ,VVMAX , + 1 WWMIN ,WWMAX ,DELCRT ,EYEU , + 2 EYEV ,EYEW + COMMON /SET31/ ISCALE ,XMIN ,XMAX ,YMIN , + 1 YMAX ,BIGD ,R0 ,NLX , + 2 NBY ,NRX ,NTY +C +C DECIDE IF SET OR TRANSLATE CALL +C + IF (IENT .NE. 1) GO TO 50 +C +C STORE THE PARAMETERS OF THE SET CALL +C FOR USE WITH THE TRANSLATION CALL +C + AU = U + AV = V + AW = W + EU = XT + EV = YT + EW = ZT +C +C +C +C +C + DU = AU-EU + DV = AV-EV + DW = AW-EW + D = SQRT(DU*DU+DV*DV+DW*DW) + COSAL = DU/D + COSBE = DV/D + COSGA = DW/D + AL = ACOS(COSAL) + BE = ACOS(COSBE) + GA = ACOS(COSGA) + SINGA = SIN(GA) +C +C THE 3-SPACE POINT LOOKED AT IS TRANSFORMED INTO (0,0) OF +C THE 2-SPACE. THE 3-SPACE W AXIS IS TRANSFORMED INTO THE +C 2-SPACE Y AXIS. IF THE LINE OF SIGHT IS CLOSE TO PARALLEL +C TO THE 3-SPACE W AXIS, THE 3-SPACE V AXIS IS CHOSEN (IN- +C STEAD OF THE 3-SPACE W AXIS) TO BE TRANSFORMED INTO THE +C 2-SPACE Y AXIS. +C + ASSIGN 90 TO JDONE + IF (ISCALE) 10, 30, 10 + 10 X0 = XMIN + Y0 = YMIN + X1 = NLX + Y1 = NBY + X2 = NRX-NLX + Y2 = NTY-NBY + X3 = X2/(XMAX-XMIN) + Y3 = Y2/(YMAX-YMIN) + X4 = NRX + Y4 = NTY + FACT = 1. + IF (BIGD .LE. 0.) GO TO 20 + X0 = -BIGD + Y0 = -BIGD + X3 = X2/(2.*BIGD) + Y3 = Y2/(2.*BIGD) + FACT = R0/D + 20 DELCRT = X2 + ASSIGN 80 TO JDONE + 30 IF (SINGA .LT. 0.0001) GO TO 40 + R = 1./SINGA + ASSIGN 70 TO JUMP + RETURN + 40 SINBE = SIN(BE) + R = 1./SINBE + ASSIGN 60 TO JUMP + RETURN +C +C******************** ENTRY TRN32 ************************ +C ENTRY TRN32 (U,V,W,XT,YT,ZT) +C + 50 UU = U + VV = V + WW = W + Q = D/((UU-EU)*COSAL+(VV-EV)*COSBE+(WW-EW)*COSGA) + GO TO JUMP,( 60, 70) + 60 UU = ((EW+Q*(WW-EW)-AW)*COSAL-(EU+Q*(UU-EU)-AU)*COSGA)*R + VV = (EV+Q*(VV-EV)-AV)*R + GO TO JDONE,( 80, 90) + 70 UU = ((EU+Q*(UU-EU)-AU)*COSBE-(EV+Q*(VV-EV)-AV)*COSAL)*R + VV = (EW+Q*(WW-EW)-AW)*R + GO TO JDONE,( 80, 90) + 80 XT = X1+X3*(FACT*UU-X0) + YT = Y1+Y3*(FACT*VV-Y0) + RETURN + 90 XT = UU + YT = VV + RETURN + END + SUBROUTINE FRST3 (U,V,W) + SAVE +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','FRST3','VERSION 1') + XDUM = 5. + CALL TRN32T (U,V,W,X,Y,XDUM,2) + CALL PLOTIT (32*IFIX(X),32*IFIX(Y),0) + RETURN + END + SUBROUTINE VECT3 (U,V,W) + SAVE +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','VECT3','VERSION 1') + CALL TRN32T (U,V,W,X,Y,ZDUM,2) + IIX = 32*IFIX(X) + IIY = 32*IFIX(Y) + CALL PLOTIT (IIX,IIY,1) +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT (IIX,IIY,0) + RETURN + END + SUBROUTINE LINE3 (UA,VA,WA,UB,VB,WB) + SAVE +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','LINE3','VERSION 1') + CALL TRN32T (UA,VA,WA,XA,YA,XDUM,2) + CALL TRN32T (UB,VB,WB,XB,YB,XDUM,2) + IIX = 32*IFIX(XB) + IIY = 32*IFIX(YB) + CALL PLOTIT (32*IFIX(XA),32*IFIX(YA),0) + CALL PLOTIT (IIX,IIY,1) +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT (IIX,IIY,0) + RETURN + END + SUBROUTINE POINT3 (U,V,W) + SAVE + DIMENSION VWPRT(4),WNDW(4) +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','POINT3','VERSION 1') +C +C INQUIRE CURRENT NORMALIZATION TRANS NUMBER +C + CALL GQCNTN (IERR,NTORIG) +C +C SAVE NORMALIZATION TRANS 1 AND CURRENT LOG SCALING +C + CALL GQNT (1,IERR,WNDW,VWPRT) + CALL GETUSV ('LS',IOLLS) +C +C DEFINE NOMALIZATION TRANS TO BE USED WITH POLYMARKER +C + CALL SET(0.0, 1.0, 0.0, 1.0, 1.0, 1024.0, 1.0, 1024.0, 1) +C +C SET MARKER TYPE TO 1 +C + CALL GSMK (1) + CALL TRN32T (U,V,W,X,Y,ZDUM,2) + PX = X + PY = Y + CALL GPM (1,PX,PY) +C +C RESTORE ORIGINAL TRANS 1 AND SELECT TRANS NUMBER NTORIG +C RESTORE LOG SCALING +C + CALL SET(VWPRT(1),VWPRT(2),VWPRT(3),VWPRT(4), + - WNDW(1),WNDW(2),WNDW(3),WNDW(4),IOLLS) + CALL GSELNT (NTORIG) + RETURN + END + SUBROUTINE CURVE3 (U,V,W,N) + SAVE + DIMENSION U(N) ,V(N) ,W(N) +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','CURVE3','VERSION 1') + CALL TRN32T (U(1),V(1),W(1),X,Y,ZDUM,2) + CALL PLOTIT (32*IFIX(X),32*IFIX(Y),0) + NN = N + IF (NN .LT. 2) RETURN + DO 10 I=2,NN + UU = U(I) + VV = V(I) + WW = W(I) + CALL TRN32T (UU,VV,WW,X,Y,ZDUM,2) + CALL PLOTIT (32*IFIX(X),32*IFIX(Y),1) + 10 CONTINUE +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(0,0,0) + RETURN + END + SUBROUTINE PSYM3 (U,V,W,ICHAR,SIZE,IDIR,ITOP,IUP) + SAVE +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','PSYM3','VERSION 1') + IF (IUP .EQ. 2) CALL VECT3 (U,V,W) + CALL PWRZ (U,V,W,ICHAR,1,SIZE,IDIR,ITOP,0) + RETURN + END + SUBROUTINE PERIM3 (MAGR1,MINI1,MAGR2,MINI2,IWHICH,VAR) + SAVE + COMMON /PWRZ1T/ UUMIN ,UUMAX ,VVMIN ,VVMAX , + 1 WWMIN ,WWMAX ,DELCRT ,EYEU , + 2 EYEV ,EYEW + COMMON /PRM31/ Q ,L + COMMON /TCK31/ TMAGU ,TMINU ,TMAGV ,TMINV , + 1 TMAGW ,TMINW +C +C THRINT COMMON BLOCK IS USED FOR SETTING COLOR INTENSITY +C + COMMON /THRINT/ ITHRMJ ,ITHRMN ,ITHRTX + DIMENSION LASF(13) +C + TICK(T) = AMAX1(UUMAX-UUMIN,VVMAX-VVMIN,WWMAX-WWMIN)*T/1024. +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','PERIM3','VERSION 1') +C +C INQUIRE LINE COLOR INDEX AND SET ASF TO INDIVIDUAL +C + CALL GQPLCI (IERR, IPLCI) + CALL GQASF (IERR, LASF) + LSV3 = LASF(3) + LASF(3) = 1 + CALL GSASF (LASF) +C + MGR1 = MAGR1 + MN1 = MINI1-1 + MGR2 = MAGR2 + MN2 = MINI2-1 + MN1P1 = MAX0(MN1+1,1) + MN2P1 = MAX0(MN2+1,1) + L = MIN0(3,MAX0(1,IWHICH)) + Q = VAR +C +C PICK BOUNDS +C + GO TO ( 10, 30, 40),L + 10 XMIN = VVMIN + XMAX = VVMAX + DELXL = TICK(TMAGU) + DELXS = TICK(TMINU) + 20 YMIN = WWMIN + YMAX = WWMAX + DELYL = TICK(TMAGW) + DELYS = TICK(TMINW) + GO TO 50 + 30 XMIN = UUMIN + XMAX = UUMAX + DELXL = TICK(TMAGU) + DELXS = TICK(TMINU) + GO TO 20 + 40 XMIN = UUMIN + XMAX = UUMAX + DELXL = TICK(TMAGU) + DELXS = TICK(TMINU) + YMIN = VVMIN + YMAX = VVMAX + DELYL = TICK(TMAGV) + DELYS = TICK(TMINV) +C +C PERIM +C + 50 CALL LINE3W (XMIN,YMIN,XMAX,YMIN) + CALL LINE3W (XMAX,YMIN,XMAX,YMAX) + CALL LINE3W (XMAX,YMAX,XMIN,YMAX) + CALL LINE3W (XMIN,YMAX,XMIN,YMIN) + IF (MGR1 .LT. 1) GO TO 90 + DX = (XMAX-XMIN)/AMAX0(MGR1*(MN1P1),1) + DO 80 I=1,MGR1 +C +C MINORS FIRST +C + IF (MN1 .LE. 0) GO TO 70 +C +C SET LINE INTENSITY TO LOW +C + CALL GSPLCI (ITHRMN) + DO 60 J=1,MN1 + X = XMIN+FLOAT(MN1P1*(I-1)+J)*DX + CALL LINE3W (X,YMIN,X,YMIN+DELYS) + CALL LINE3W (X,YMAX,X,YMAX-DELYS) + 60 CONTINUE + 70 IF (I .GE. MGR1) GO TO 90 +C +C SET LINE INTENSITY TO HIGH +C + CALL GSPLCI (ITHRMJ) + X = XMIN+FLOAT(MN1P1*I)*DX +C +C MAJORS +C + CALL LINE3W (X,YMIN,X,YMIN+DELYL) + CALL LINE3W (X,YMAX,X,YMAX-DELYL) + 80 CONTINUE + 90 IF (MGR2 .LT. 1) GO TO 130 + DY = (YMAX-YMIN)/AMAX0(MGR2*(MN2P1),1) + DO 120 J=1,MGR2 + IF (MN2 .LE. 0) GO TO 110 + DO 100 I=1,MN2 + Y = YMIN+FLOAT(MN2P1*(J-1)+I)*DY + CALL LINE3W (XMIN,Y,XMIN+DELXS,Y) +C +C SET LINE INTENSITY TO LOW +C + CALL GSPLCI (ITHRMN) + CALL LINE3W (XMAX,Y,XMAX-DELXS,Y) + 100 CONTINUE + 110 IF (J .GE. MGR2) GO TO 130 +C +C SET LINE INTENSITY TO HIGH +C + CALL GSPLCI (ITHRMJ) + Y = YMIN+FLOAT(MN2P1*J)*DY + CALL LINE3W (XMIN,Y,XMIN+DELXL,Y) + CALL LINE3W (XMAX,Y,XMAX-DELXL,Y) + 120 CONTINUE +C +C RESTORE ASF AND LINE INTENSITY TO ORIGINAL +C + 130 LASF(3) = LSV3 + CALL GSASF (LASF) + CALL GSPLCI (IPLCI) + RETURN + END + SUBROUTINE LINE3W (XA,YA,XB,YB) + SAVE + COMMON /PRM31/ Q ,L + GO TO ( 10, 30, 40),L + 10 UA = Q + UB = Q + VA = XA + VB = XB + 20 WA = YA + WB = YB + GO TO 50 + 30 UA = XA + UB = XB + VA = Q + VB = Q + GO TO 20 + 40 UA = XA + UB = XB + VA = YA + VB = YB + WA = Q + WB = Q + 50 CALL LINE3 (UA,VA,WA,UB,VB,WB) + RETURN + END + SUBROUTINE DRAWT (IXA,IYA,IXB,IYB) + SAVE + CALL PLOTIT(32*IXA,32*IYA,0) + IIX = 32*IXB + IIY = 32*IYB + CALL PLOTIT(IIX,IIY,1) +C +C FLUSH PLOTIT BUFFER +C + CALL PLOTIT(IIX,IIY,0) + RETURN + END + SUBROUTINE TICK43 (MAGU,MINU,MAGV,MINV,MAGW,MINW) + SAVE + COMMON /TCK31/ TMAGU ,TMINU ,TMAGV ,TMINV , + 1 TMAGW ,TMINW +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','TICK43','VERSION 1') + TMAGU = MAGU + TMINU = MINU + TMAGV = MAGV + TMINV = MINV + TMAGW = MAGW + TMINW = MINW + RETURN + END + SUBROUTINE TICK3 (MAG,MIN) + SAVE +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','TICK3','VERSION 1') + CALL TICK43 (MAG,MIN,MAG,MIN,MAG,MIN) + RETURN + END + SUBROUTINE FENCE3 (U,V,W,N,IOR,BOT) + SAVE + REAL U(N) ,V(N) ,W(N) + DIMENSION LASF(13) +C +C COMMON BLOCK THRINT IS USED FOR SETTING COLOR INTENSITY +C + COMMON /THRINT/ ITHRMJ ,ITHRMN ,ITHRTX +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR +C + CALL Q8QST4 ('GRAPHX','THREED','FENCE3','VERSION 1') +C +C INQUIRE LINE COLOR INDEX AND SET ASF TO INDIVIDUAL +C + CALL GQPLCI (IERR, IPLCI) + CALL GQASF (IERR, LASF) + LSV3 = LASF(3) + LASF(3) = 1 + CALL GSASF (LASF) +C + M = N + BASE = BOT + L = MAX0(1,MIN0(3,IOR)) +C +C SET LINE INTENSITY TO LOW +C + CALL GSPLCI (ITHRMN) + GO TO ( 10, 40, 70),L + 10 CALL FRST3 (BASE,V(1),W(1)) + DO 20 I=2,M + VV = V(I) + WW = W(I) + CALL VECT3 (BASE,VV,WW) + 20 CONTINUE + DO 30 I=1,M + UU = U(I) + VV = V(I) + WW = W(I) + CALL LINE3 (UU,VV,WW,BASE,VV,WW) + 30 CONTINUE + GO TO 100 + 40 CALL FRST3 (U(1),BASE,W(1)) + DO 50 I=2,M + UU = U(I) + WW = W(I) + CALL VECT3 (UU,BASE,WW) + 50 CONTINUE + DO 60 I=1,M + UU = U(I) + VV = V(I) + WW = W(I) + CALL LINE3 (UU,VV,WW,UU,BASE,WW) + 60 CONTINUE + GO TO 100 + 70 CALL FRST3 (U(1),V(1),BASE) + DO 80 I=2,M + UU = U(I) + VV = V(I) + CALL VECT3 (UU,VV,BASE) + 80 CONTINUE + DO 90 I=1,M + UU = U(I) + VV = V(I) + WW = W(I) + CALL LINE3 (UU,VV,WW,UU,VV,BASE) + 90 CONTINUE +C +C SET LINE INTENSITY TO HIGH +C + 100 CALL GSPLCI (ITHRMJ) + CALL CURVE3 (U,V,W,M) +C +C RESTORE ASF AND LINE INTENSITY TO ORIGINAL +C + LASF(3) = LSV3 + CALL GSASF (LASF) + CALL GSPLCI (IPLCI) +C + RETURN +C +C REVISION HISTORY--- +C +C JANUARY 1978 DELETED REFERENCES TO THE *COSY CARDS AND +C ADDED REVISION HISTORY +C FEBURARY 1979 MODIFIED CODE TO CONFORM TO FORTRAN 66 STANDARD +C JUNE 1979 UPDATED FILE TO INCLUDE BLOCK DATA PWRZBD AND +C CORRECT A COMMENTED OUT STATEMENT IN CURVE3. +C MARCH 1980 REMOVED THE PWRZ AND PWRITZ ENTRIES. THESE +C CAPABILITIES WERE REPLACED WITH THE NEW ULIB FILE +C PWRZT. +C JULY 1984 CONVERTED TO FORTRAN 77 AND GKS +C----------------------------------------------------------------------- +C + END + SUBROUTINE PWRZ (X,Y,Z,ID,N,ISIZE,LIN3,ITOP,ICNT) +C WRITE (6,1001) +C WRITE (6,1002) +C STOP +C +C1001 FORMAT (1H1//////////) +C1002 FORMAT (' *****************************************'/ +C 1 ' * *'/ +C 2 ' * *'/ +C 3 ' * THE ENTRY POINT PWRZ IS NO LONGER *'/ +C 4 ' * SUPPORTED. THE CAPABILITIES OF *'/ +C 5 ' * THIS OLD ENTRY ARE NOW AVAILABLE *'/ +C 6 ' * IN THE NEW PORTABLE VERSIONS *'/ +C 7 ' * *'/ +C 8 ' * PWRZS FOR USE WITH SRFACE *'/ +C 9 ' * PWRZI FOR USE WITH ISOSRF *'/ +C + ' * PWRZT FOR USE WITH THREED *'/ +C 1 ' * *'/ +C 2 ' * FOR USAGE OF THESE ROUTINES, SEE *'/ +C 3 ' * THE DOCUMENTATION FOR THE DESIRED *'/ +C 4 ' * ROUTINE. *'/ +C 5 ' * *'/ +C 6 ' * *'/ +C 7 ' *****************************************') +C + END diff --git a/sys/gio/ncarutil/veldat.f b/sys/gio/ncarutil/veldat.f new file mode 100644 index 00000000..9baef78d --- /dev/null +++ b/sys/gio/ncarutil/veldat.f @@ -0,0 +1,67 @@ +C +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +c +noao: block data veldat changed to run time initialization +c BLOCK DATA VELDAT + subroutine veldat +C +C THIS 'ROUTINE' DEFINES THE DEFAULT VALUES OF THE VELVCT PARAMETERS. +C + COMMON /VEC1/ ASH ,EXT ,ICTRFG ,ILAB, + + IOFFD ,IOFFM ,ISX ,ISY, + + RMN ,RMX ,SIDE ,SIZE, + + XLT ,YBT ,ZMN ,ZMX +C + COMMON /VEC2/ BIG ,INCX ,INCY +C +c DATA EXT / 0.25 / +c DATA ICTRFG / 1 / +c DATA ILAB / 0 / +c DATA IOFFD / 0 / +c DATA IOFFM / 0 / +c DATA RMN / 160.00 / +c DATA RMX / 6400.00 / +c DATA SIDE / 0.90 / +c DATA SIZE / 256.00 / +c DATA XLT / 0.05 / +c DATA YBT / 0.05 / +c DATA ZMX / 0.00 / +c DATA INCX / 1 / +c DATA INCY / 1 / +c +c +noao: following flag added to prevent over-initialization + logical first + SAVE + data first /.true./ + if (.not. first) then + return + endif + first = .false. + + EXT = 0.25 + ICTRFG = 1 + ILAB = 0 + IOFFD = 0 + IOFFM = 0 + RMN = 160.00 + RMX = 6400.00 + SIDE = 0.90 + SIZE = 256.00 + XLT = 0.05 + YBT = 0.05 + ZMX = 0.00 + INCX = 1 + INCY = 1 +C +c - noao + END diff --git a/sys/gio/ncarutil/velvct.f b/sys/gio/ncarutil/velvct.f new file mode 100644 index 00000000..fd8f46c7 --- /dev/null +++ b/sys/gio/ncarutil/velvct.f @@ -0,0 +1,821 @@ + SUBROUTINE VELVCT (U,LU,V,LV,M,N,FLO,HI,NSET,LENGTH,ISPV,SPV) +C +C +-----------------------------------------------------------------+ +C | | +C | Copyright (C) 1986 by UCAR | +C | University Corporation for Atmospheric Research | +C | All Rights Reserved | +C | | +C | NCARGRAPHICS Version 1.00 | +C | | +C +-----------------------------------------------------------------+ +C +C +C +C +C SUBROUTINE VELVCT (U,LU,V,LV,M,N,FLO,HI,NSET,LENGTH,ISPV,SPV) +C +C +C DIMENSION OF U(LU,N),V(LV,N),SPV(2) +C ARGUMENTS +C +C LATEST REVISION JULY 1984 +C +C PURPOSE VELVCT DRAWS A REPRESENTATION OF A TWO- +C DIMENSIONAL VELOCITY FIELD BY DRAWING ARROWS +C FROM EACH DATA LOCATION. THE LENGTH OF THE +C ARROW IS PROPORTIONAL TO THE STRENGTH OF THE +C FIELD AT THAT LOCATION AND THE DIRECTION OF +C THE ARROW INDICATES THE DIRECTION OF THE FLOW +C AT THAT LOCATION. +C +C USAGE IF THE FOLLOWING ASSUMPTIONS ARE MET, USE +C +C CALL EZVEC (U,V,M,N) +C +C ASSUMPTIONS - +C +C --THE WHOLE ARRAY IS PROCESSED. +C --THE SCALE FACTOR IS CHOSEN INTERNALLY. +C --THE PERIMETER IS DRAWN. +C --FRAME IS CALLED AFTER PLOTTING. +C --THERE ARE NO SPECIAL VALUES. +C +C IF THESE ASSUMPTIONS ARE NOT MET, USE +C +C CALL VELVCT (U,LU,V,LV,M,N,FLO,HI, +C NSET,LENGTH,ISPV,SPV) +C +C ARGUMENTS +C +C ON INPUT U,V +C +C THE (ORIGINS OF THE) TWO-DIMENSIONAL ARRAYS +C CONTAINING THE VELOCITY FIELD TO BE PLOTTED. +C THE VECTOR AT THE POINT (I,J) HAS MAGNITUDE +C SQRT(U(I,J)**2+V(I,J)**2) AND DIRECTION +C ATAN2(V(I,J),U(I,J)). OTHER REPRESENTATIONS, +C SUCH AS (R,THETA), CAN BE PLOTTED BY +C CHANGING STATEMENT FUNCTIONS IN THIS ROUTINE. +C +C LU +C +C THE FIRST DIMENSION OF U IN THE CALLING +C PROGRAM. +C +C LV +C +C THE FIRST DIMENSION OF V IN THE CALLING +C PROGRAM. +C +C M +C +C THE NUMBER OF DATA VALUES TO BE PLOTTED IN +C THE X-DIRECTION (THE FIRST SUBSCRIPT +C DIRECTION). WHEN PLOTTING THE ENTIRE ARRAY, +C LU = LV = M. +C +C N +C +C THE NUMBER OF DATA VALUES TO BE PLOTTED IN +C THE Y-DIRECTION (THE SECOND SUBSCRIPT +C DIRECTION). +C +C FLO +C +C THE MINIMUM VECTOR MAGNITUDE TO BE SHOWN. +C +C HI +C +C THE MAXIMUM VECTOR MAGNITUDE TO BE SHOWN. (A +C VALUE LESS THAN OR EQUAL TO ZERO CAUSES THE +C MAXIMUM VALUE OF SQRT(U**2+V**2) TO BE USED.) +C +C NSET +C +C FLAG TO CONTROL SCALING - +C +C IF NSET IS ZERO, VELVCT ESTABLISHES THE +C WINDOW AND VIEWPORT TO PROPERLY +C SCALE PLOTTING INSTRUCTIONS TO THE STANDARD +C CONFIGURATION. PERIM IS CALLED TO DRAW A +C BORDER. +C +C IF NSET IS GREATER THAN ZERO, VELVCT ASSUMES +C THAT THE USER HAS ESTABLISHED THE WINDOW +C AND VIEWPORT IN SUCH A WAY AS TO PROPERLY +C SCALE THE PLOTTING INSTRUCTIONS GENERATED +C BY VELVCT. PERIM IS NOT CALLED. +C +C IF NSET IS LESS THAN ZERO, VELVCT +C PLACES THE CONTOUR PLOT +C WITHIN THE LIMITS OF THE USER'S CURRENT +C WINDOW AND VIEWPORT. PERIM IS NOT CALLED. +C +C LENGTH +C +C THE LENGTH, IN PLOTTER ADDRESS UNITS (PAUS), +C OF A VECTOR HAVING MAGNITUDE HI +C (OR, IF HI=0, THE LENGTH IN PAUS +C OF THE LONGEST VECTOR). IF LENGTH=0, A +C VALUE IS CHOSEN SUCH THAT THE LONGEST VECTOR +C COULD JUST REACH TO THE TAIL OF THE NEXT +C VECTOR. IF THE HORIZONTAL AND VERTICAL +C RESOLUTIONS OF THE PLOTTER ARE DIFFERENT, +C LENGTH SHOULD BE NON-ZERO AND SPECIFIED AS A +C HORIZONTAL DISTANCE. +C +C ISPV +C +C FLAG TO CONTROL THE SPECIAL VALUE FEATURE. +C +C 0 MEANS THAT THE FEATURE IS NOT IN USE. +C +C 1 MEANS THAT IF THE VALUE OF +C U(I,J)=SPV(1) THE VECTOR WILL NOT BE +C PLOTTED. +C +C 2 MEANS THAT IF THE VALUE OF +C V(I,J)=SPV(2) THE VECTOR WILL NOT BE +C PLOTTED. +C +C 3 MEANS THAT IF EITHER U(I,J)=SPV(1) OR +C V(I,J)=SPV(2) THEN THE VECTOR WILL NOT +C BE PLOTTED. +C +C 4 MEANS THAT IF U(I,J)=SPV(1) +C AND V(I,J)=SPV(2), THE VECTOR +C WILL NOT BE PLOTTED. +C +C SPV +C +C AN ARRAY OF LENGTH 2 WHICH GIVES THE VALUE +C IN THE U ARRAY AND THE VALUE IN THE V ARRAY +C WHICH DENOTE MISSING VALUES. +C THIS ARGUMENT IS IGNORED IF ISPV=0. +C +C +C ON OUTPUT ALL ARGUMENTS REMAIN UNCHANGED. +C +C NOTE THE ENDPOINTS OF EACH ARROW DRAWN ARE (FX(X,Y), +C FY(X,Y)) AND (MXF(X,Y,U,V,SFX,SFY,MX,MY), +C MYF(X,Y,U,V,SFX,SFY,MX,MY)) WHERE X=I, Y=J, +C U=U(I,J), V=V(I,J), AND SFX AND SFY ARE SCALE +C FACTORS. HERE I IS THE X-INDEX AND J IS THE +C Y-INDEX. (MX,MY) IS THE LOCATION OF THE TAIL. +C THUS THE ACTUAL LENGTH OF THE ARROW IS +C SQRT(DX**2+DY**2) AND THE DIRECTION IS +C ATAN2(DX,DY), WHERE DX=MX-MXF(...) AND +C DY=MY-MYF(...). +C +C ENTRY POINTS VELVCT,EZVECT,DRWVEC,VELVEC,VELDAT +C +C COMMON BLOCKS VEC1,VEC2 +C +C I/O PLOTS THE VECTOR FIELD. +C +C PRECISION SINGLE +C +C LANGUAGE FORTRAN +C +C REQUIRED LIBRARY GRIDAL AND THE SPPS +C ROUTINES +C +C HISTORY WRITTEN AND STANDARDIZED IN NOVEMBER 1973. +C REVISED IN MAY, 1975, TO INCLUDE MXF AND MYF. +C REVISED IN MARCH, 1981, TO FIX CERTAIN ERRORS; +C TO USE FL2INT AND PLOTIT INSTEAD OF MXMY, +C FRSTPT, AND VECTOR; AND TO MAKE THE ARROWHEADS +C NARROWER. CONVERTED TO FORTRAN77 AND GKS +C IN JULY 1984. +C +C ALGORITHM EACH VECTOR IS EXAMINED, POSSIBLY TRANSFORMED, +C THEN PLOTTED. +C +C PORTABILITY FORTRAN77 +C +C --------------------------------------------------------------------- +C +C SPECIAL NOTE - +C +C USING THIS ROUTINE TO PUT VECTORS ON AN ARBITRARY BACKGROUND DRAWN BY +C SUPMAP IS A BIT TRICKY. THE ARITHMETIC STATEMENT FUNCTIONS FX AND FY +C ARE EASY TO REPLACE. THE PROBLEM ARISES IN REPLACING MXF AND MYF. +C THE FOLLOWING EXAMPLE MAY BE HELPFUL. (SUPMAP IS AN ENTRY POINT IN +C THE EZMAP PACKAGE.) +C +C SUPPOSE THAT WE HAVE TWO ARRAYS, CLON(36,9) AND CLAT(36,9), WHICH +C CONTAIN THE E-W AND N-S COMPONENTS OF A WIND FLOW FIELD ON THE SURFACE +C OF THE EARTH. CLON(I,J) IS THE MAGNITUDE OF THE EASTERLY FLOW. +C CLAT(I,J) IS THE MAGNITUDE OF THE NORTHERLY FLOW AT A LONGITUDE (I-1) +C *10 DEGREES EAST OF GREENWICH AND A LATITUDE (J-1)*10 DEGREES NORTH OF +C THE EQUATOR. SUPMAP IS TO BE USED TO DRAW A POLAR PROJECTION OF THE +C EARTH AND VELVCT IS TO BE USED TO SUPERIMPOSE VECTORS REPRESENTING THE +C FLOW FIELD ON IT. THE FOLLOWING STEPS WOULD BE NECESSARY: +C +C 1. CALL SUPMAP (1,90.,0.,-90.,90.,90.,90.,90.,-4,10,0,1,IER) +C TO DRAW THE MAP. +C +C 2. CALL VELVCT (CLON,36,CLAT,36,36,9,0.,0.,1,50,0,0.) TO PUT +C VECTORS ON IT. NOTICE THAT NSET HAS THE VALUE 1 TO TELL +C VELVCT THAT SUPMAP HAS DONE THE REQUIRED SET CALL. +C +C 3. IN ORDER TO ENSURE THAT STEP 2 WILL WORK PROPERLY, DELETE +C THE ARITHMETIC STATEMENT FUNCTIONS FX, FY, MXF, AND MYF +C FROM VELVCT AND INCLUDE THE FOLLOWING FUNCTIONS. +C +C FUNCTION FX(XX,YY) +C CALL MAPTRN (10.*(YY-1.),10.*(XX-1.),X,Y) +C FX=X +C RETURN +C END +C +C FUNCTION FY(XX,YY) +C CALL MAPTRN (10.*(YY-1.),10.*(XX-1.),X,Y) +C FY=Y +C RETURN +C END +C +C FUNCTION MXF(XX,YY,UU,VV,SFX,SFY,MX,MY) +C CFCT=COS(.17453292519943*(YY-1.)) +C CALL MAPTRN(10.*(YY-1.) ,10.*(XX-1.) ,X1,Y1) +C CALL MAPTRN(10.*(YY-1.)+1.E-6*VV,10.*(XX-1.)+1.E-6*UU/CFCT,X2,Y2) +C U=((X2-X1)/SQRT((X2-X1)**2+(Y2-Y1)**2))*SQRT(UU**2+VV**2) +C MXF=MX+IFIX(SFX*U) +C RETURN +C END +C +C FUNCTION MYF(XX,YY,UU,VV,SFX,SFY,MX,MY) +C CFCT=COS(.17453292519943*(YY-1.)) +C CALL MAPTRN(10.*(YY-1.) ,10.*(XX-1.) ,X1,Y1) +C CALL MAPTRN(10.*(YY-1.)+1.E-6*VV,10.*(XX-1.)+1.E-6*UU/CFCT,X2,Y2) +C V=((Y2-Y1)/SQRT((X2-X1)**2+(Y2-Y1)**2))*SQRT(UU**2+VV**2) +C MYF=MY+IFIX(SFY*V) +C RETURN +C END +C +C THE BASIC NOTION BEHIND THE CODING OF THE MXF AND MYF FUNCTIONS IS AS +C FOLLOWS. SINCE UU AND VV ARE THE LONGITUDINAL AND LATITUDINAL COMPONENTS, +C RESPECTIVELY, OF A VELOCITY VECTOR HAVING UNITS OF DISTANCE OVER TIME, +C 1.E-6*UU/COS(LATITUDE) AND 1.E-6*VV REPRESENT THE CHANGE IN LONGITUDE +C AND LATITUDE, RESPECTIVELY, OF A PARTICLE MOVING WITH THE FLOW FIELD +C FOR A VERY SHORT PERIOD OF TIME. THE ROUTINE MAPTRN IS USED TO FIND +C THE POSITION OF THE PARTICLE'S PROJECTION AT THE BEGINNING AND END OF +C THAT TINY TIME SLICE AND, THEREFORE, THE DIRECTION IN WHICH TO DRAW +C THE ARROW REPRESENTING THE VELOCITY VECTOR SO THAT IT WILL BE TANGENT +C TO A PROJECTED FLOW LINE OF THE FIELD AT THAT POINT. THE VALUES U +C AND V ARE COMPUTED SO AS TO GIVE THE ARROW THE LENGTH IMPLIED BY UU +C AND VV. (THE CODE ENSURES THAT SQRT(U**2+V**2) IS EQUAL TO +C SQRT(UU**2+VV**2).) THE LENGTH OF THE ARROW REPRESENTS THE MAGNITUDE +C OF THE VELOCITY VECTOR, UNAFFECTED BY PERSPECTIVE. THE SCALING SET +C UP BY VELVCT WILL THEREFORE BE APPROPRIATE FOR THE ARROWS DRAWN. +C +C THIS METHOD IS RATHER HEURISTIC AND HAS THREE INHERENT PROBLEMS. +C FIRST, THE CONSTANT 1.E-6 MAY NEED TO BE MADE LARGER OR SMALLER, +C DEPENDING ON THE MAGNITUDE OF YOUR U/V DATA. SECOND, THE NORTH AND +C SOUTH POLES MUST BE AVOIDED. AT EITHER POLE, CFCT GOES TO ZERO, +C GIVING A DIVISION BY ZERO; IN A SMALL REGION NEAR THE POLE, THE +C METHOD MAY TRY TO USE MAPTRN WITH A LATITUDE OUTSIDE THE RANGE +C (-90,+90). THIRD, THE PROJECTION MUST BE SET UP SO AS TO AVOID +C HAVING VECTOR BASEPOINTS AT THE EXACT EDGE OF THE MAP. VECTORS +C THERE WILL BE OF THE CORRECT LENGTH, BUT THEY MAY BE DRAWN IN THE +C WRONG DIRECTION (WHEN THE PROJECTED PARTICLE TRACK DETERMINING THE +C DIRECTION CROSSES THE EDGE AND REAPPEARS ELSEWHERE ON THE MAP). +C WITH A LITTLE CARE, THE DESIRED RESULTS MAY BE OBTAINED. +C --------------------------------------------------------------------- +C +C DECLARATIONS - +C + COMMON /VEC1/ ASH ,EXT ,ICTRFG ,ILAB , + + IOFFD ,IOFFM ,ISX ,ISY , + + RMN ,RMX ,SIDE ,SIZE , + + XLT ,YBT ,ZMN ,ZMX +C + COMMON /VEC2/ BIG ,INCX ,INCY +C +C ARGUMENT DIMENSIONS. +C + DIMENSION U(LU,N) ,V(LV,N) ,SPV(2) + CHARACTER*10 LABEL + REAL WIND(4), VIEW(4), IAR(4) +C +C --------------------------------------------------------------------- +C +C INTERNAL PARAMETERS OF VELVCT ARE AS FOLLOWS. THE DEFAULT VALUES OF +C THESE PARAMETERS ARE DECLARED IN THE BLOCK DATA ROUTINE VELDAT. +C +C NAME DEFAULT FUNCTION +C ---- ------- -------- +C +C BIG R1MACH(2) CONSTANT USED TO INITIALIZE +C POSSIBLE SEARCH FOR HI. +C +C EXT 0.25 THE LENGTHS OF THE SIDES OF THE +C PLOT ARE PROPORTIONAL TO M AND +C N WHEN NSET IS LESS THAN OR +C EQUAL TO ZERO, EXCEPT WHEN +C MIN(M,N)/MAX(M,N) IS LESS THAN +C EXT, IN WHICH CASE A SQUARE +C GRAPH IS PLOTTED. +C +C ICTRFG 1 FLAG TO CONTROL THE POSITION OF +C THE ARROW RELATIVE TO A BASE +C POINT AT (MX,MY). +C +C ZERO - CENTER AT (MX,MY) +C +C POSITIVE - TAIL AT (MX,MY) +C +C NEGATIVE - HEAD AT (MX,MY) +C +C ILAB 0 FLAG TO CONTROL THE DRAWING OF +C LINE LABELS. +C +C ZERO - DO NOT DRAW THE LABELS +C +C NON-ZERO - DRAW THE LABELS +C +C INCX 1 X-COORDINATE STEP SIZE FOR LESS +C DENSE ARRAYS. +C +C INCY 1 Y-COORDINATE STEP SIZE. +C +C IOFFD 0 FLAG TO CONTROL NORMALIZATION +C OF LABEL NUMBERS. +C +C ZERO - INCLUDE A DECIMAL POINT +C WHEN POSSIBLE +C +C NON-ZERO - NORMALIZE ALL LABEL +C NUMBERS BY ASH +C +C IOFFM 0 FLAG TO CONTROL PLOTTING OF +C THE MESSAGE BELOW THE PLOT. +C +C ZERO - PLOT THE MESSAGE +C +C NON-ZERO - DO NOT PLOT IT +C +C RMN 160. ARROW SIZE BELOW WHICH THE +C HEAD NO LONGER SHRINKS, ON A +C 2**15 X 2**15 GRID. +C +C RMX 6400. ARROW SIZE ABOVE WHICH THE +C HEAD NO LONGER GROWS LARGER, +C ON A 2**15 X 2**15 GRID. +C +C SIDE 0.90 LENGTH OF LONGER EDGE OF PLOT. +C (SEE ALSO EXT.) +C +C SIZE 256. WIDTH OF THE CHARACTERS IN +C VECTOR LABELS, ON A 2**15 X +C 2**15 GRID. +C +C XLT 0.05 LEFT HAND EDGE OF THE PLOT. +C (0 IS THE LEFT EDGE OF THE +C FRAME, 1 THE RIGHT EDGE.) +C +C YBT 0.05 BOTTOM EDGE OF THE PLOT (0 IS +C THE BOTTOM OF THE FRAME, 1 THE +C TOP OF THE FRAME.) +C +C --------------------------------------------------------------------- +C +C INTERNAL FUNCTIONS WHICH MAY BE MODIFIED FOR DATA TRANSFORMATION - +C +C SCALE COMPUTES A SCALE FACTOR USED IN THE +C DETERMINATION OF THE LENGTH OF THE +C VECTOR TO BE DRAWN. +C +C DIST COMPUTES THE LENGTH OF A VECTOR. +C +C FX RETURNS THE X INDEX AS THE +C X-COORDINATE OF THE VECTOR BASE. +C +C MXF RETURNS THE X-COORDINATE OF THE VECTOR +C HEAD. +C +C FY RETURNS THE Y INDEX AS THE +C Y-COORDINATE OF THE VECTOR BASE. +C +C MYF RETURNS THE Y-COORDINATE OF THE VECTOR +C HEAD. +C +C VLAB THE VALUE FOR THE VECTOR LABEL WHEN +C ILAB IS NON-ZERO. +C + SAVE + DIST(XX,YY) = SQRT(XX*XX+YY*YY) + FX(XX,YY) = XX + FY(XX,YY) = YY + MXF(XX,YY,UU,VV,SFXX,SFYY,MXX,MYY) = MXX+IFIX(SFXX*UU) + MYF(XX,YY,UU,VV,SFXX,SFYY,MXX,MYY) = MYY+IFIX(SFYY*VV) + SCALEX(MM,NN,INCXX,INCYY,HAA,XX1,XX2,YY1,YY2,XX3,XX4,YY3,YY4, + 1 LENN) = LENN/HAA + SCALEY(MM,NN,INCXX,INCYY,HAA,XX1,XX2,YY1,YY2,XX3,XX4,YY3,YY4, + 1 LENN) = SCALEX(MM,NN,INCXX,INCYY,HAA,XX1,XX2,YY1,YY2,XX3, + 2 XX4,YY3,YY4,LENN) + VLAB(UU,VV,II,JJ) = DIST(UU,VV) +C +C FORCE THE BLOCK DATA ROUTINE, WHICH SETS DEFAULT VARIABLES, TO LOAD. +C +NOAO - blockdata replaced with run time initialization. +C +C EXTERNAL VELDAT + call veldat +C -NOAO +C +C --------------------------------------------------------------------- +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR. +C + CALL Q8QST4 ('NSSL','VELVCT','VELVCT','VERSION 6') +C +C INITIALIZE AND TRANSFER SOME ARGUMENTS TO LOCAL VARIABLES. +C + BIG = -R1MACH(2) + MX = LU + MY = LV + NX = M + NY = N + GL = FLO + HA = HI + ISP = ISPV + NC = 0 +C +C COMPUTE CONSTANTS BASED ON THE ADDRESSABILITY OF THE PLOTTER. +C + CALL GETUSV('XF',ISX) + CALL GETUSV('YF',ISY) + ISX = 2**(15-ISX) + ISY = 2**(15-ISY) + LEN = LENGTH*ISX +C +C SET UP THE SCALING OF THE PLOT. +C + CALL GQCNTN(IERR,IOLDNT) + CALL GQNT(IOLDNT,IERR,WIND,VIEW) + X1 = VIEW(1) + X2 = VIEW(2) + Y1 = VIEW(3) + Y2 = VIEW(4) + X3 = WIND(1) + X4 = WIND(2) + Y3 = WIND(3) + Y4 = WIND(4) + CALL GETUSV('LS',IOLLS) +C +C SAVE NORMALIZATION TRANSFORMATION 1 +C + CALL GQNT(1,IERR,WIND,VIEW) +C + IF (NSET) 101,102,106 +C + 101 X3 = 1. + X4 = FLOAT(NX) + Y3 = 1. + Y4 = FLOAT(NY) + GO TO 105 +C + 102 X1 = XLT + X2 = XLT+SIDE + Y1 = YBT + Y2 = YBT+SIDE + X3 = 1. + Y3 = 1. + X4 = FLOAT(NX) + Y4 = FLOAT(NY) + IF (AMIN1(X4,Y4)/AMAX1(X4,Y4) .LT. EXT) GO TO 105 +C + IF (NX-NY) 103,105,104 + 103 X2 = XLT+SIDE*X4/Y4 + GO TO 105 + 104 Y2 = YBT+SIDE*Y4/X4 +C + 105 CALL SET(X1,X2,Y1,Y2,X3,X4,Y3,Y4,1) + IF (NSET .EQ. 0) CALL PERIM (1,0,1,0) +C +C CALCULATE A LENGTH IF NONE PROVIDED. +C + 106 IF (LEN .NE. 0) GO TO 107 + CALL FL2INT(FX(1.,1.),FY(1.,1.),MX,MY) + CALL FL2INT(FX(FLOAT(1+INCX),FLOAT(1+INCY)), + + FY(FLOAT(1+INCX),FLOAT(1+INCY)),LX,LY) + LEN = SQRT((FLOAT(MX-LX)**2+FLOAT(MY-LY)**2)/2.) +C +C SET UP SPECIAL VALUES. +C + 107 IF (ISP .EQ. 0) GO TO 108 + SPV1 = SPV(1) + SPV2 = SPV(2) + IF (ISP .EQ. 4) SPV2 = SPV(1) +C +C FIND THE MAXIMUM VECTOR LENGTH. +C + 108 IF (HA .GT. 0.) GO TO 118 +C + HA = BIG + IF (ISP .EQ. 0) GO TO 115 +C + DO 114 J=1,NY,INCY + DO 113 I=1,NX,INCX + IF (ISP-2) 109,111,110 + 109 IF (U(I,J) .EQ. SPV1) GO TO 113 + GO TO 112 + 110 IF (U(I,J) .EQ. SPV1) GO TO 113 + 111 IF (V(I,J) .EQ. SPV2) GO TO 113 + 112 HA = AMAX1(HA,DIST(U(I,J),V(I,J))) + 113 CONTINUE + 114 CONTINUE + GO TO 126 +C + 115 DO 117 J=1,NY,INCY + DO 116 I=1,NX,INCX + HA = AMAX1(HA,DIST(U(I,J),V(I,J))) + 116 CONTINUE + 117 CONTINUE +C +C BRANCH IF NULL VECTOR SIZE. +C + 126 IF (HA .LE. 0.) GO TO 125 +C +C COMPUTE SCALE FACTORS. +C + 118 SFX = SCALEX(M,N,INCX,INCY,HA,X1,X2,Y1,Y2,X3,X4,Y3,Y4,LEN) + SFY = SCALEY(M,N,INCX,INCY,HA,X1,X2,Y1,Y2,X3,X4,Y3,Y4,LEN) + IOFFDT = IOFFD + IF (GL.NE.0.0 .AND. (ABS(GL).LT.0.1 .OR. ABS(GL).GE.1.E5)) + 1 IOFFDT = 1 + IF (HA.NE.0.0 .AND. (ABS(HA).LT.0.1 .OR. ABS(HA).GE.1.E5)) + 1 IOFFDT = 1 + ASH = 1.0 + IF (IOFFDT .NE. 0) + 1 ASH = 10.**(3-IFIX(ALOG10(AMAX1(ABS(GL),ABS(HA)))-500.)-500) + IZFLG = 0 +C +C COMPUTE ZMN AND ZMX, WHICH ARE USED IN DRWVEC. +C + ZMN = LEN*(GL/HA) + ZMX = FLOAT(LEN)+.01 +C +C DRAW THE VECTORS. +C + DO 123 J=1,NY,INCY + DO 122 I=1,NX,INCX + UI = U(I,J) + VI = V(I,J) + IF (ISP-1) 121,119,120 + 119 IF (UI-SPV1) 121,122,121 + 120 IF (VI .EQ. SPV2) GO TO 122 + IF (ISP .GE. 3) GO TO 119 + 121 X = I + Y = J + CALL FL2INT(FX(X,Y),FY(X,Y),MX,MY) + LX = MAX0(1,MXF(X,Y,UI,VI,SFX,SFY,MX,MY)) + LY = MAX0(1,MYF(X,Y,UI,VI,SFX,SFY,MX,MY)) + IZFLG = 1 + IF (ILAB .NE. 0) CALL ENCD(VLAB(UI,VI,I,J),ASH,LABEL,NC, + + IOFFDT) + CALL DRWVEC (MX,MY,LX,LY,LABEL,NC) + 122 CONTINUE + 123 CONTINUE +C + IF (IZFLG .EQ. 0) GO TO 125 +C + IF (IOFFM .NE. 0) GO TO 200 +C +NOAO - FTN internal write replaced with call to encode +C WRITE(LABEL,'(E10.3)')HA + call encode (10, '(e10.3)', label, ha) +C -NOAO +C +C TURN OFF CLIPPING SO ARROW CAN BE DRAWN +C + CALL GQCLIP(IER,ICLP,IAR) + CALL GSCLIP(0) + CALL DRWVEC (28768,608,28768+LEN,608,LABEL,10) +C +C RESTORE CLIPPING +C + CALL GSCLIP(ICLP) + IX = 1+(28768+LEN/2)/ISX + IY = 1+(608-(5*ISX*MAX0(256/ISX,8))/4)/ISY + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = CPUX(IX) + YC = CPUY(IY) + CALL WTSTR (XC,YC, + + 'MAXIMUM VECTOR',MAX0(256/ISX,8),0,0) + CALL GSELNT(ICN) +C +C DONE. +C + GOTO 200 +C +C ZERO-FIELD ACTION. +C + 125 IX = 1+16384/ISX + IY = 1+16384/ISY + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = CPUX(IX) + YC = CPUY(IY) + CALL WTSTR (XC,YC, + + 'ZERO FIELD',MAX0(960/ISX,8),0,0) + CALL GSELNT(ICN) +C +C RESTORE TRANS 1 AND LOG SCALING AND ORIGINAL TRANS NUMBER +C + 200 CONTINUE + IF (NSET .LE. 0) THEN + CALL SET(VIEW(1),VIEW(2),VIEW(3),VIEW(4), + - WIND(1),WIND(2),WIND(3),WIND(4),IOLLS) + ENDIF + CALL GSELNT(IOLDNT) + RETURN + END + SUBROUTINE EZVEC (U,V,M,N) +C +C THIS SUBROUTINE IS FOR THE USER WHO WANTS A QUICK-AND-DIRTY VECTOR +C PLOT WITH DEFAULT VALUES FOR MOST OF THE ARGUMENTS. +C + SAVE +C + DIMENSION U(M,N) ,V(M,N) ,SPVAL(2) +C + DATA FLO,HI,NSET,LENGTH,ISPV,SPVAL(1),SPVAL(2) / + + 0.,0., 0, 0, 0, 0., 0. / +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR. +C + CALL Q8QST4 ('CRAYLIB','VELVCT','EZVEC','VERSION 6') +C + CALL VELVCT (U,M,V,M,M,N,FLO,HI,NSET,LENGTH,ISPV,SPVAL) +C +NOAO - call to frame is suppressed. +C CALL FRAME +C -NOAO + RETURN + END + SUBROUTINE DRWVEC (M1,M2,M3,M4,LABEL,NC) +C +C THIS ROUTINE IS CALLED TO DRAW A SINGLE ARROW. IT HAS ARGUMENTS AS +C FOLLOWS - +C +C (M1,M2) - COORDINATE OF ARROW BASE, ON A 2**15 X 2**15 GRID. +C (M3,M4) - COORDINATE OF ARROW HEAD, ON A 2**15 X 2**15 GRID. +C LABEL - CHARACTER LABEL TO BE PUT ABOVE ARROW. +C NC - NUMBER OF CHARACTERS IN LABEL. +C + SAVE +C +C + COMMON /VEC1/ ASH ,EXT ,ICTRFG ,ILAB , + + IOFFD ,IOFFM ,ISX ,ISY , + + RMN ,RMX ,SIDE ,SIZE , + + XLT ,YBT ,ZMN ,ZMX + CHARACTER*10 LABEL +C +C SOME LOCAL PARAMETERS ARE THE FOLLOWING - +C +C CL - ARROW HEAD LENGTH SCALE FACTOR - EACH SIDE OF THE ARROW +C HEAD IS THIS LONG RELATIVE TO THE LENGTH OF THE ARROW +C ST,CT - SIN AND COS OF THE ARROW HEAD ANGLE +C PI - THE CONSTANT PI +C TWOPI - TWO TIMES PI +C OHOPI - ONE HALF OF PI +C FHOPI - FIVE HALVES OF PI +C + DATA CL / .25 / + DATA ST / .382683432365090 / + DATA CT / .923879532511287 / + DATA PI / 3.14159265358979 / + DATA TWOPI / 6.28318530717959 / + DATA OHOPI / 1.57079632679489 / + DATA FHOPI / 7.85398163397448 / +C + DIST(X,Y) = SQRT(X*X+Y*Y) +C +C TRANSFER ARGUMENTS TO LOCAL VARIABLES AND COMPUTE THE VECTOR LENGTH. +C + N1 = M1 + N2 = M2 + N3 = M3 + N4 = M4 + DX = N3-N1 + DY = N4-N2 + R = DIST(DX,DY) +C +C SORT OUT POSSIBLE CASES, DEPENDING ON VECTOR LENGTH. +C + IF (R .LE. ZMN) RETURN +C + IF (R .LE. ZMX) GO TO 101 +C +C PLOT A POINT FOR VECTORS WHICH ARE TOO LONG. +C + CALL PLOTIT (N1,N2,0) + CALL PLOTIT (N1,N2,1) + CALL PLOTIT (N1,N2,0) + RETURN +C +C ADJUST THE COORDINATES OF THE VECTOR ENDPOINTS AS IMPLIED BY THE +C CENTERING OPTION. +C + 101 IF (ICTRFG) 102,103,104 +C + 102 N3 = N1 + N4 = N2 + N1 = FLOAT(N1)-DX + N2 = FLOAT(N2)-DY + GO TO 104 +C + 103 N1 = FLOAT(N1)-.5*DX + N2 = FLOAT(N2)-.5*DY + N3 = FLOAT(N3)-.5*DX + N4 = FLOAT(N4)-.5*DY +C +C DETERMINE THE COORDINATES OF THE POINTS USED TO DRAW THE ARROWHEAD. +C + 104 C1 = CL +C +C SHORT ARROWS HAVE HEADS OF A FIXED MINIMUM SIZE. +C + IF (R .LT. RMN) C1 = RMN*CL/R +C +C LONG ARROWS HAVE HEADS OF A FIXED MAXIMUM SIZE. +C + IF (R .GT. RMX) C1 = RMX*CL/R +C +C COMPUTE THE COORDINATES OF THE HEAD. +C + N5 = FLOAT(N3)-C1*(CT*DX-ST*DY) + N6 = FLOAT(N4)-C1*(CT*DY+ST*DX) + N7 = FLOAT(N3)-C1*(CT*DX+ST*DY) + N8 = FLOAT(N4)-C1*(CT*DY-ST*DX) +C +C PLOT THE ARROW. +C + CALL PLOTIT (N1,N2,0) + CALL PLOTIT (N3,N4,1) + CALL PLOTIT (N5,N6,0) + CALL PLOTIT (N3,N4,1) + CALL PLOTIT (N7,N8,1) + CALL PLOTIT (0,0,0) +C +C IF REQUESTED, PUT THE VECTOR MAGNITUDE ABOVE THE ARROW. +C + IF (NC .EQ. 0) RETURN + PHI = ATAN2(DY,DX) + IF (AMOD(PHI+FHOPI,TWOPI) .GT. PI) PHI = PHI+PI + IX = 1+IFIX(.5*FLOAT(N1+N3)+1.25* + + FLOAT(ISX*MAX0(IFIX(SIZE)/ISX,8))*COS(PHI+OHOPI))/ISX + IY = 1+IFIX(.5*FLOAT(N2+N4)+1.25* + + FLOAT(ISX*MAX0(IFIX(SIZE)/ISX,8))*SIN(PHI+OHOPI))/ISY + CALL GQCNTN(IER,ICN) + CALL GSELNT(0) + XC = CPUX(IX) + YC = CPUY(IY) + CALL WTSTR(XC,YC, + + LABEL,MAX0(IFIX(SIZE)/ISX,8), + + IFIX(57.2957795130823*PHI),0) + CALL GSELNT(ICN) + RETURN + END + SUBROUTINE VELVEC (U,LU,V,LV,M,N,FLO,HI,NSET,ISPV,SPV) +C +C THIS ROUTINE SUPPORTS USERS OF THE OLD VERSION OF THIS PACKAGE. +C + DIMENSION U(LU,N) ,V(LV,N) ,SPV(2) +C + SAVE +C +C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR. +C + CALL Q8QST4 ('CRAYLIB','VELVCT','VELVEC','VERSION 4') + CALL VELVCT (U,LU,V,LV,M,N,FLO,HI,NSET,0,ISPV,SPV) + RETURN + END +C +C REVISION HISTORY ---------------------------------------------------- +C +C FEBRUARY, 1979 ADDED REVISION HISTORY +C MODIFIED CODE TO CONFORM TO FORTRAN 66 STANDARD +C +C JULY, 1979 FIXED HI VECTOR TRAP AND MESSAGE INDICATING +C MAXIMUM VECTOR PLOTTED. +C +C DECEMBER, 1979 CHANGED THE STATISTICS CALL FROM CRAYLIB TO NSSL +C +C MARCH, 1981 FIXED SOME FRINGE-CASE ERRORS, CHANGED THE CODE TO +C USE FL2INTT AND PLOTIT INSTEAD OF MXMY, FRSTPT, AND +C VECTOR, AND MADE THE ARROWHEADS NARROWER (45 DEGREES +C APART, RATHER THAN 60 DEGREES APART) +C +C FEBRUARY, 1984 PROVIDED A DIMENSION STATEMENT FOR A VARIABLE INTO +C WHICH A TEN-CHARACTER STRING WAS BEING ENCODED. ON +C THE CRAY, WHEN THE ENCODE WAS DONE, A WORD FOLLOWING +C THE VARIABLE WAS CLOBBERED, BUT THIS APPARENTLY MADE +C NO DIFFERENCE. ON AT LEAST ONE OTHER MACHINE, THE +C CODE BLEW UP. (ERROR REPORTED BY GREG WOODS) +C +C JULY, 1984 CONVERTED TO FORTRAN77 AND GKS. +C +C --------------------------------------------------------------------- diff --git a/sys/gio/nspp/README b/sys/gio/nspp/README new file mode 100644 index 00000000..38bd1580 --- /dev/null +++ b/sys/gio/nspp/README @@ -0,0 +1,9 @@ +NSPP -- The NCAR System Plot Package. + + portlib portable NSPP modules + sysint the system interface + +Usage: + The user must supply a subroutine called WRITEB to use the library. + See gio$nsppkern for an example. The subroutine Z8ZPII should be + called before using NSPP to initialize the internal variables. diff --git a/sys/gio/nspp/mkpkg b/sys/gio/nspp/mkpkg new file mode 100644 index 00000000..3ce0021c --- /dev/null +++ b/sys/gio/nspp/mkpkg @@ -0,0 +1,11 @@ +# Make the LIBNSPP.A library for the Ncar system plot package. + +$checkout libnspp.a lib$ +$update libnspp.a +$checkin libnspp.a lib$ +$exit + +libnspp.a: + @portlib + @sysint + ; diff --git a/sys/gio/nspp/portlib/README b/sys/gio/nspp/portlib/README new file mode 100644 index 00000000..261de972 --- /dev/null +++ b/sys/gio/nspp/portlib/README @@ -0,0 +1,28 @@ +This directory contains the sources for the NCAR system plot package. +The original source is in the file "plot.4.8.sav". If any modifications +have to be made, they will be recorded here. + +REVISIONS + +04Mar84 SET --> SPPSET + The name of the SET module, used to set the device window and + user coordinate system, was changed to SPPSET. The module "set.x" + in the high level code intercepts calls by the utilities to set, + so that the transformations may be stored away in a file for recovery + by another process. + +05Mar84 Elimination of Fortran i/o + All formatted writes to mprint were commented out. + +05Mar48 Resolve library conflict + getchr --> ncgchr [collision with fio.getchar] + putchr --> ncpchr [for consistency with above] + +12Mar84 Moved most of the initialization from the block data z8zpbd into + the initialization subroutine z8zpii, called by nspp_init at + GOPEN time. + +12Dec85 SPPSET -> SET + Changed this guy back, as the high level interface to the system + plot package is no longer used. The NCAR system plot package stuff + is only used by the GIO/NCAR kernel now. diff --git a/sys/gio/nspp/portlib/axes.f b/sys/gio/nspp/portlib/axes.f new file mode 100644 index 00000000..badf7004 --- /dev/null +++ b/sys/gio/nspp/portlib/axes.f @@ -0,0 +1,6 @@ + subroutine axes (x,y) + call getset (idummy,idummy,idummy,idummy,xc,xd,yc,yd,idummy) + call line (x,yc,x,yd) + call line (xc,y,xd,y) + return + end diff --git a/sys/gio/nspp/portlib/curve.f b/sys/gio/nspp/portlib/curve.f new file mode 100644 index 00000000..265b9811 --- /dev/null +++ b/sys/gio/nspp/portlib/curve.f @@ -0,0 +1,41 @@ + subroutine curve (x,y,n) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c ray bovet patch to avoid small integers being set to 0 + integer x,y,xx,yy +c + dimension x(n) ,y(n) +c + kn = n + if (kn-1) 104,103,101 + 101 xx = x(1) + yy = y(1) + call trans + minst = 0 + call put42 + do 102 i=2,kn + xx = x(i) + yy = y(i) + call trans + minst = 1 + call put42 + 102 continue + go to 104 + 103 call point (x(1),y(1)) + 104 continue + return + end diff --git a/sys/gio/nspp/portlib/dashln.f b/sys/gio/nspp/portlib/dashln.f new file mode 100644 index 00000000..35ac6851 --- /dev/null +++ b/sys/gio/nspp/portlib/dashln.f @@ -0,0 +1,5 @@ + subroutine dashln (ipat) + jpat = ior(ishift(ipat,6),ishift(ipat,-4)) + call optn (4hdpat,jpat) + return + end diff --git a/sys/gio/nspp/portlib/fl2int.f b/sys/gio/nspp/portlib/fl2int.f new file mode 100644 index 00000000..59939aca --- /dev/null +++ b/sys/gio/nspp/portlib/fl2int.f @@ -0,0 +1,31 @@ + subroutine fl2int (x,y,imx,imy) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c ray bovet patch to avoid small integers being set to 0 + integer x,y,xx,yy +c + nx = mx + ny = my + xx = x + yy = y + call trans + imx = mx + imy = my + mx = nx + my = ny + return + end diff --git a/sys/gio/nspp/portlib/flash1.f b/sys/gio/nspp/portlib/flash1.f new file mode 100644 index 00000000..39fb31c6 --- /dev/null +++ b/sys/gio/nspp/portlib/flash1.f @@ -0,0 +1,42 @@ + subroutine flash1 (ibuf,ibufl) + dimension ibuf(ibufl) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + if (modef .eq. 1) go to 101 + mxold = -9999 + myold = -9999 + call mcflsh + mbufa = loci(ibuf) + mbufl = ibufl + modef = 1 + mnxsto = mjxmin + mnysto = mjymin + mxxsto = mjxmax + mxysto = mjymax + mjxmin = 32767 + mjymin = 32767 + mjxmax = 0 + mjymax = 0 + mbuflu = 0 + return +c + 101 call uliber (0, + 1 48h0flash1 called consecutively without flash2 call, + 2 48) + call perror + return + end diff --git a/sys/gio/nspp/portlib/flash2.f b/sys/gio/nspp/portlib/flash2.f new file mode 100644 index 00000000..0f909414 --- /dev/null +++ b/sys/gio/nspp/portlib/flash2.f @@ -0,0 +1,71 @@ + subroutine flash2 (ipoint,ibuflu) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + dimension idummy(1) + if (modef .ne. 1) go to 101 + kpoint = ipoint + if (kpoint.lt.0 .or. kpoint.gt.10) go to 102 + call flushb + nextra = 5 + ibuflu = mbuflu+nextra + if (mf2er .gt. 0) go to 103 + if (ibuflu .gt. mbufl) go to 103 + mfwa(kpoint+1) = mbufa + mlwa(kpoint+1) = mbufa+mbuflu-1 + isub = mbufa+mbuflu-loci(idummy) + idummy(isub+1) = mbuflu + idummy(isub+2) = mjxmin + idummy(isub+3) = mjymin + idummy(isub+4) = mjxmax + idummy(isub+5) = mjymax + modef = 2 + mbufa = loci(msybuf) + mbufl = msblen + mbuflu = 0 + mbprs(1) = mpair1 + mbprs(2) = mpair2 + mipair = 2 + mflcnt = 0 + mxold = -9999 + myold = -9999 + mjxmin = mnxsto + mjymin = mnysto + mjxmax = mxxsto + mjymax = mxysto + return +c + 101 call uliber (0,29h0flash2 called without flash1,29) + call perror + return + 102 continue +c write (mprint,1001) kpoint +c + call uliber (0,38h0first argument to flash2 out of range,38) + call perror + return + 103 continue + nlen = mf2er*mbufl+ibuflu +c write (mprint,1002) nlen +c + call uliber (0,23h0flash buffer too short,23) + call perror + return +c +c1001 format (27h0flash2 called with ipoint=,i5) +c1002 format (27h0flash buffer must be about,i8,11h words long) +c + end diff --git a/sys/gio/nspp/portlib/flash3.f b/sys/gio/nspp/portlib/flash3.f new file mode 100644 index 00000000..ce7f36d5 --- /dev/null +++ b/sys/gio/nspp/portlib/flash3.f @@ -0,0 +1,70 @@ + subroutine flash3 (ipoint) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + dimension idummy(1) + if (modef .lt. 2) go to 102 + kpoint = ipoint + if (kpoint.lt.0 .or. kpoint.gt.10) go to 103 + if (mfwa(kpoint+1) .eq. -9999) go to 102 + call mcflsh + isave1 = mbufa + isave2 = mbuflu + mbufa = mfwa(kpoint+1) + nlentg = mlwa(kpoint+1)-mbufa+1 + isub = mbufa+nlentg-loci(idummy) + nusrwc = idummy(isub+1) + if (nusrwc .ne. nlentg) go to 104 + modef = -3 + 101 mbuflu = min0(nlentg,msblen) + if (mbuflu .gt. 0) call preout + nlentg = nlentg-msblen + mbufa = mbufa+msblen + if (nlentg .gt. 0) go to 101 + mbufa = isave1 + mbuflu = isave2 + mxold = -9999 + myold = -9999 + modef = 3 + mjxmin = min0(mjxmin,idummy(isub+2)) + mjymin = min0(mjymin,idummy(isub+3)) + mjxmax = max0(mjxmax,idummy(isub+4)) + mjymax = max0(mjymax,idummy(isub+5)) + return + 102 continue +c write (mprint,1001) kpoint +c + call uliber (0, + 1 48h0flash3 called without call to flash1 and flash2, + 2 48) + call perror + return + 103 continue +c write (mprint,1001) kpoint +c + call uliber (0,37h0argument out of range in flash3 call,37) + call perror + return + 104 continue +c write (mprint,1001) kpoint +c + call uliber (0,37h0user flash buffer has been corrupted,37) + call perror + return +c +c1001 format (27h0flash3 called with ipoint=,i5) +c + end diff --git a/sys/gio/nspp/portlib/flash4.f b/sys/gio/nspp/portlib/flash4.f new file mode 100644 index 00000000..9fc13238 --- /dev/null +++ b/sys/gio/nspp/portlib/flash4.f @@ -0,0 +1,46 @@ + subroutine flash4 (ifw,lwd,ipoint) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + dimension ifw(1) ,lwd(1) + jfwa = loci(ifw) + jlwda = loci(lwd) + kpoint = ipoint + if (jfwa .gt. jlwda) go to 101 + if (kpoint.lt.0 .or. kpoint.gt.10) go to 102 + nextra = 5 + mfwa(kpoint+1) = jfwa + mlwa(kpoint+1) = jlwda-nextra + nwds = jlwda-jfwa + modef = 4 + return + 101 continue +c write (mprint,1001) jfwa,jlwda +c + call uliber (0,38h0loci(ifw).gt.loci(lwd) in flash4 call,38) + call perror + return + 102 continue +c write (mprint,1002) kpoint +c + call uliber (0,43h0third argument out of range in flash4 call,43) + call perror + return +c +c1001 format (10h0loci(ifw)=,i10,10x,9hloci(lwd)=,i10) +c1002 format (27h0flash4 called with ipoint=,i5) +c + end diff --git a/sys/gio/nspp/portlib/flush.f b/sys/gio/nspp/portlib/flush.f new file mode 100644 index 00000000..07ee8418 --- /dev/null +++ b/sys/gio/nspp/portlib/flush.f @@ -0,0 +1,22 @@ + subroutine mcflsh + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + if (modef .eq. 1) go to 101 + call flushb + if (mbuflu .gt. 0) call preout + 101 return + end diff --git a/sys/gio/nspp/portlib/flushb.f b/sys/gio/nspp/portlib/flushb.f new file mode 100644 index 00000000..7f88c29b --- /dev/null +++ b/sys/gio/nspp/portlib/flushb.f @@ -0,0 +1,41 @@ + subroutine flushb +c dimension idummy(1) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + external z8zpbd + if (mipair .eq. 16) go to 102 + if (mipair .eq. 0) return + if (mipair.eq.2 .and. mflcnt.eq.0) return + mipp1 = mipair+1 + do 101 i=mipp1,16 + mbprs(i) = 40992 + 101 continue + 102 if (mbufa .eq. -9999) mbufa = loci(msybuf) + mflcnt = mflcnt+1 + call packum (mbprs,16,mbufa+mbuflu) + mbuflu = mbuflu+8 + mipair = 0 + if (modef .eq. 1) go to 103 + if (mbuflu+8 .le. mbufl) return + if (mbuflu .gt. 0) call preout + return + 103 if (mod(mbuflu,msblen) .eq. 0) go to 104 + if (mbuflu+8 .le. mbufl) return + 104 continue + if (mbuflu .gt. 0) call preout + return + end diff --git a/sys/gio/nspp/portlib/frame.f b/sys/gio/nspp/portlib/frame.f new file mode 100644 index 00000000..c8396fcd --- /dev/null +++ b/sys/gio/nspp/portlib/frame.f @@ -0,0 +1,70 @@ + subroutine frame + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + if (modef .eq. 1) go to 101 + mbpair = ior(ishift(226,8),0) + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + if ((mipair+5) .gt. 16) call flushb + mbpair = ior(ishift(231,8),8) + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair = mjxmin + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair = mjymin + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair = mjxmax + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair = mjymax + mfrend = 1 + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + call flushb + if (mbuflu .gt. 0) call preout + mjxmin = 32767 + mjymin = 32767 + mjxmax = 0 + mjymax = 0 + mxold = -9999 + myold = -9999 + mop(1) = 0 + mop(2) = 204 + mop(5) = 0 + mop(3) = 0 + mop(4) = 128 + mop(7) = 8 + mop(6) = ior(1,ishift(32767,1)) + mop(8) = 0 + mop(9) = 0 + mop(10) = 0 + mfrend = 0 + return +c + 101 call uliber (0,45h0frame call illegal between flash1 and flash2, + 1 45) + call perror + return + end diff --git a/sys/gio/nspp/portlib/frstpt.f b/sys/gio/nspp/portlib/frstpt.f new file mode 100644 index 00000000..7fea3675 --- /dev/null +++ b/sys/gio/nspp/portlib/frstpt.f @@ -0,0 +1,30 @@ + subroutine frstpt (x,y) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c ray bovet patch to avoid small integers being set to 0 + integer x,y,xx,yy +c + mxold = mx + myold = my + xx = x + yy = y + call trans + if (iabs(mx-mxold)+iabs(my-myold) .eq. 0) return + minst = 0 + call put42 + return + end diff --git a/sys/gio/nspp/portlib/getopt.f b/sys/gio/nspp/portlib/getopt.f new file mode 100644 index 00000000..10474014 --- /dev/null +++ b/sys/gio/nspp/portlib/getopt.f @@ -0,0 +1,37 @@ + subroutine getopt (iopnam,iopval) + dimension iopnam(1) ,iopval(1) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c +c find index for input name +c + do 101 i=1,9 + iop = i + if (jlm2(iopnam) .eq. jlm2(mname(i))) go to 102 + 101 continue +c + call uliber (0,36hounknown name in optn or getopt call,36) + call perror + return + 102 if (iop .eq. 9) go to 103 + return + 103 do 104 i=1,3 + call ncgchr (mop(iop),3,i,jchar) + call ncpchr (iopval,3,i,jchar) + 104 continue + return + end diff --git a/sys/gio/nspp/portlib/getset.f b/sys/gio/nspp/portlib/getset.f new file mode 100644 index 00000000..7bc6b8ce --- /dev/null +++ b/sys/gio/nspp/portlib/getset.f @@ -0,0 +1,28 @@ + subroutine getset (nxa,nxb,nya,nyb,xc,xd,yc,yd,itype) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + nxa = ishift(mxa,-mshftx)+1 + nxb = ishift(mxb,-mshftx)+1 + xc = xxc + xd = xxd + nya = ishift(mya,-mshfty)+1 + nyb = ishift(myb,-mshfty)+1 + yc = yyc + yd = yyd + itype = mtype + return + end diff --git a/sys/gio/nspp/portlib/getsi.f b/sys/gio/nspp/portlib/getsi.f new file mode 100644 index 00000000..400da7b1 --- /dev/null +++ b/sys/gio/nspp/portlib/getsi.f @@ -0,0 +1,21 @@ + subroutine getsi (npowx,npowy) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + npowx = 15-mshftx + npowy = 15-mshfty + return + end diff --git a/sys/gio/nspp/portlib/grid.f b/sys/gio/nspp/portlib/grid.f new file mode 100644 index 00000000..358045fc --- /dev/null +++ b/sys/gio/nspp/portlib/grid.f @@ -0,0 +1,4 @@ + subroutine grid (magrx,minrx,magry,minry) + call gridal (magrx,minrx,magry,minry,0,0,0,1,1) + return + end diff --git a/sys/gio/nspp/portlib/gridal.f b/sys/gio/nspp/portlib/gridal.f new file mode 100644 index 00000000..814cb42e --- /dev/null +++ b/sys/gio/nspp/portlib/gridal.f @@ -0,0 +1,218 @@ + subroutine gridal (imajx,iminx,imajy,iminy,ixlab,iylab,iflg,x,y) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c +c non-compact version of gridal +c +c ray bovet ishft changed to ishfta patch + dimension nmaj(2),nmin(2),nlab(2),nflg(2),num(2) ,zza(2) , + 1 zzb(2) ,zzc(2) ,zzd(2) ,ichars(5) , + 2 ifmt(3,2) ,iz(2) ,iza(2) ,izb(2) ,imz(2) , + 3 izdec(2) ,isiz(2),imajl(2) , + 4 iminl(2) ,itype(2) ,zz(2) , + 5 ishfta(2) ,izaa(2),izbb(2),kz(4) +c ray bovet patch to avoid small integers being set to 0 + integer x,y,xx,yy +c +c +c ray bovet ishft changed to ishfta patch + equivalence (xxa,zza(1)) ,(xxb,zzb(1)) ,(xxc,zzc(1)) , + 1 (xxd,zzd(1)) ,(mfmtx(1),ifmt(1,1)), + 2 (mx,iz(1)) ,(mxa,iza(1)) ,(mxb,izb(1)) , + 3 (majx,nmaj(1)) ,(minx,nmin(1)) ,(mumx,num(1)) , + 4 (mxdec,izdec(1)) ,(msizx,isiz(1)), + 5 (mmgrx,imajl(1)) ,(mmnrx,iminl(1)) , + 6 (mtypex,itype(1)) ,(xx,kz(1)) , + 7 (xx,zz(1)) ,(mshftx,ishfta(1)) +c +c set up variables for loop +c + nmaj(1) = imajx + nmaj(2) = imajy + nmin(1) = iminx + nmin(2) = iminy + nlab(1) = ixlab + nlab(2) = iylab + nflg(1) = ishift(iflg,-2)-1 + nflg(2) = iand(iflg,3)-1 + izaa(1) = iza(1) + izaa(2) = iza(2) + izbb(1) = izb(1) + izbb(2) = izb(2) + if (nflg(1).le.0 .and. nflg(2).le.0) go to 101 + xx = x + yy = y + call trans + if (nflg(2) .gt. 0) izaa(1) = mx + if (nflg(1) .gt. 0) izaa(2) = my + if (nflg(2) .gt. 0) izbb(1) = mx + if (nflg(1) .gt. 0) izbb(2) = my + 101 continue + call optn (4hdpat,65535) + do 121 i=1,2 +c +c i=1 for x axis with ticks in y direction +c i=2 for y axis with ticks in x direction +c + if (nlab(i)) 121,102,102 + 102 continue +c +c ior.ne.0 posibility for x only +c + ixor = (2-i)*90*mxor + imaj = max0(nmaj(i),1) + imin = max0(nmin(i),1) + begin = iza(i) + biginc = float(izb(i)-iza(i))/float(imaj) + smlinc = biginc/float(imin) + start = zzc(i) + dif = (zzd(i)-zzc(i))/float(imaj) + iop = 3-i +c +c iop is the opposit axis to i +c + idec = izdec(iop) + if (idec .eq. 0) idec = izaa(iop)-izbb(iop)-655 + if (ixor .eq. i-1) go to 103 +c +c labels and axis are orthogonal +c + icent = isign(1,idec-1) + go to 104 +c +c labels and axis are parallel +c + 103 icent = 0 + 104 continue + if (itype(i) .eq. 0) go to 105 + fact = 10.**imaj + if (zzc(i) .gt. zzd(i)) fact = 1./fact + val = zzc(i)/fact + delval = val + if (imin.le.10 .and. imaj.eq.1) imin = 9 + if (imin .ne. 9) imin = 1 + imaj = abs(alog10(zzd(i)/zzc(i)))+1.0001 + 105 imajp1 = imaj+1 + iminm1 = imin-1 + do 119 j=1,imajp1 + part = j-1 +c +c draw major line or tick +c + call optn (4hintn,4hhigh) + if (itype(i) .ne. 0) go to 106 + iz(i) = begin+part*biginc + go to 107 + 106 val = val*fact + zz(i) = val + kz(iop) = 1 + call trans + delval = delval*fact + if (iz(i)-10 .gt. izb(i)) go to 120 + 107 continue + iz(iop) = izaa(iop) + minst = 0 + call put42 + if (nflg(i)) 108,109,109 + 108 iz(iop) = izb(iop) + minst = 1 + call put42 + go to 111 + 109 iz(iop) = izaa(iop)+imajl(iop) + minst = 1 + call put42 + if (nflg(i)) 110,110,111 + 110 iz(iop) = izb(iop) + minst = 0 + call put42 + iz(iop) = izb(iop)-imajl(iop) + minst = 1 + call put42 + 111 continue +c +c form label if needed +c + if (nlab(i) .le. 0) go to 112 + if (itype(i) .eq. 0) val = start+part*dif + call encode (num(i),ifmt(1,i),ichars,val) +c ray bovet ishft changed to ishfta patch + imz(i) = ishift(iz(i),-ishfta(i)) + imz(iop) = max0(1,ishift(izaa(iop)-idec,-ishfta(iop))) + njust = num(i) + if (icent .eq. 0) call justfy (ichars,num(i),njust) + call pwrit (imz(1),imz(2),ichars,njust,isiz(i),ixor,icent) +c +c put in minor ticks +c + 112 if (iminm1.le.0 .or. j.eq.imajp1) go to 119 + call optn (4hintn,3hlow) + do 118 k=1,iminm1 + if (itype(i) .ne. 0) go to 113 + iz(i) = begin+part*biginc+float(k)*smlinc + go to 114 + 113 zz(i) = val+float(k)*delval + if (zzc(i) .gt. zzd(i)) zzi = val-float(k)*delval*.1 + kz(iop) = 1 + call trans + if (iz(i) .gt. izb(i)) go to 120 + if (iz(i) .lt. iza(i)) go to 118 + 114 continue + iz(iop) = izaa(iop) + minst = 0 + call put42 + if (nflg(i)) 115,116,116 + 115 iz(iop) = izb(iop) + minst = 1 + call put42 + go to 118 + 116 iz(iop) = izaa(iop)+iminl(iop) + minst = 1 + call put42 + if (nflg(i)) 117,117,118 + 117 iz(iop) = izb(iop) + minst = 0 + call put42 + iz(iop) = izb(iop)-iminl(iop) + minst = 1 + call put42 + 118 continue + 119 continue + call optn (4hintn,4hhigh) + 120 if (nflg(iop) .lt. 0) go to 121 +c +c draw axis line +c + iz(i) = iza(i) + iz(iop) = izaa(iop) + minst = 0 + call put42 + iz(i) = izb(i) + iz(iop) = izaa(iop) + minst = 1 + call put42 + if (nflg(i) .gt. 0) go to 121 + iz(i) = iza(i) + iz(iop) = izb(iop) + minst = 0 + call put42 + iz(i) = izb(i) + iz(iop) = izb(iop) + minst = 1 + call put42 + 121 continue + return + end diff --git a/sys/gio/nspp/portlib/gridl.f b/sys/gio/nspp/portlib/gridl.f new file mode 100644 index 00000000..7de4687f --- /dev/null +++ b/sys/gio/nspp/portlib/gridl.f @@ -0,0 +1,4 @@ + subroutine gridl (magrx,minrx,magry,minry) + call gridal (magrx,minrx,magry,minry,1,1,0,1,1) + return + end diff --git a/sys/gio/nspp/portlib/halfax.f b/sys/gio/nspp/portlib/halfax.f new file mode 100644 index 00000000..c996a4dd --- /dev/null +++ b/sys/gio/nspp/portlib/halfax.f @@ -0,0 +1,4 @@ + subroutine halfax (magrx,minrx,magry,minry,x,y,ixlab,iylab) + call gridal (magrx,minrx,magry,minry,ixlab,iylab,10,x,y) + return + end diff --git a/sys/gio/nspp/portlib/jlm2.f b/sys/gio/nspp/portlib/jlm2.f new file mode 100644 index 00000000..455c1310 --- /dev/null +++ b/sys/gio/nspp/portlib/jlm2.f @@ -0,0 +1,7 @@ + function jlm2 (ichar) + dimension ichar(1) + call ncgchr (ichar,2,1,ichar1) + call ncgchr (ichar,2,2,ichar2) + jlm2 = ior(ishift(ichar1,8),ichar2) + return + end diff --git a/sys/gio/nspp/portlib/justfy.f b/sys/gio/nspp/portlib/justfy.f new file mode 100644 index 00000000..f543e539 --- /dev/null +++ b/sys/gio/nspp/portlib/justfy.f @@ -0,0 +1,14 @@ + subroutine justfy (ichar,len,newlen) + dimension ichar(1) + in = 0 + call ncgchr (1h ,1,1,iblank) + do 102 i=1,len + call ncgchr (ichar,len,i,jchar) + if (in .ne. 0) go to 101 + if (jchar .eq. iblank) go to 102 + 101 in = in+1 + call ncpchr (ichar,len,in,jchar) + 102 continue + newlen = in + return + end diff --git a/sys/gio/nspp/portlib/labmod.f b/sys/gio/nspp/portlib/labmod.f new file mode 100644 index 00000000..94110f19 --- /dev/null +++ b/sys/gio/nspp/portlib/labmod.f @@ -0,0 +1,53 @@ + subroutine labmod (ifmtx,ifmty,numx,numy,isizx,isizy,ixdec,iydec, + 1 ixor) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c ray bovet ishft changed to ishfta patch + dimension ifmtx(3) ,ifmty(3) ,idec(2),ishfta(2) + equivalence (mxdec,idec(1)),(mshftx,ishfta(1)) + do 101 i=1,10 + call ncgchr (ifmtx,10,i,ichar) + call ncpchr (mfmtx,10,i,ichar) + call ncgchr (ifmty,10,i,ichar) + call ncpchr (mfmty,10,i,ichar) + 101 continue + mumx = numx + mumy = numy + if (max0(mumx,mumy) .gt. 20) go to 103 + msizx = isizx + msizy = isizy + mxdec = ixdec + mydec = iydec + do 102 i=1,2 +c ray bovet ishft changed to ishfta patch + jdec = isign(ishift(iabs(idec(i)),ishfta(i)),idec(i)) + if (idec(i) .eq. 0) jdec = 655 + if (idec(i) .eq. 1) jdec = 0 + idec(i) = jdec + 102 continue + mxor = ixor + return + 103 continue +c write (mprint,1001) mumx,mumy +c + call uliber (0,36h0numx or numy .gt. 20 in labmod call,36) + call perror + return +c +c1001 format (6h0numx=,i5,6h numy=,i5) +c + end diff --git a/sys/gio/nspp/portlib/line.f b/sys/gio/nspp/portlib/line.f new file mode 100644 index 00000000..a88330db --- /dev/null +++ b/sys/gio/nspp/portlib/line.f @@ -0,0 +1,32 @@ + subroutine line (xa,ya,xb,yb) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c ray bovet patch to avoid small integers being set to 0 + integer xa,xb,ya,yb,xx,yy +c + xx = xa + yy = ya + call trans + minst = 0 + call put42 + xx = xb + yy = yb + call trans + minst = 1 + call put42 + return + end diff --git a/sys/gio/nspp/portlib/mkpkg b/sys/gio/nspp/portlib/mkpkg new file mode 100644 index 00000000..a77011d0 --- /dev/null +++ b/sys/gio/nspp/portlib/mkpkg @@ -0,0 +1,56 @@ +# Make the NCAR system plot package. + +$checkout libnspp.a lib$ +$update libnspp.a +$checkin libnspp.a lib$ +$exit + +libnspp.a: + axes.f + curve.f + dashln.f + fl2int.f + flash1.f + flash2.f + flash3.f + flash4.f + flush.f + flushb.f + frame.f + frstpt.f + getopt.f + getset.f + getsi.f + grid.f + gridal.f + gridl.f + halfax.f + jlm2.f + justfy.f + labmod.f + line.f + mxmy.f + option.f + optn.f + perim.f + periml.f + plotit.f + point.f + points.f + porgn.f + preout.f + pscale.f + psym.f + put42.f + putins.f + pwrit.f + pwrt.f + set.f + seti.f + tick4.f + ticks.f + trans.f + vector.f + z8zpbd.f + z8zpii.f + ; diff --git a/sys/gio/nspp/portlib/mxmy.f b/sys/gio/nspp/portlib/mxmy.f new file mode 100644 index 00000000..d0045227 --- /dev/null +++ b/sys/gio/nspp/portlib/mxmy.f @@ -0,0 +1,21 @@ + subroutine mxmy (imx,imy) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + imx = ishift(mx,-mshftx)+1 + imy = ishift(my,-mshfty)+1 + return + end diff --git a/sys/gio/nspp/portlib/option.f b/sys/gio/nspp/portlib/option.f new file mode 100644 index 00000000..059a7e40 --- /dev/null +++ b/sys/gio/nspp/portlib/option.f @@ -0,0 +1,8 @@ + subroutine option (icas,int,ital,ior) + call optn (4hcase,icas) + if (int .eq. 0) call optn (4hintn,3hlow) + if (int .eq. 1) call optn (4hintn,4hhigh) + call optn (4hfont,ital) + call optn (4horen,ior) + return + end diff --git a/sys/gio/nspp/portlib/optn.f b/sys/gio/nspp/portlib/optn.f new file mode 100644 index 00000000..965356f1 --- /dev/null +++ b/sys/gio/nspp/portlib/optn.f @@ -0,0 +1,99 @@ + subroutine optn (iopnam,iopval) + dimension iopnam(1) ,iopval(1) + dimension ichar(3) + logical skip + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c + data ihigh,ilow/2hhi,2hlo/ +c +c find index for input name +c + do 101 i=1,9 + iop = i + if (jlm2(iopnam) .eq. jlm2(mname(i))) go to 102 + 101 continue +c + call uliber (0,36hounknown name in optn or getopt call,36) + call perror + return + 102 continue + if (iop.ne.2 .and. iop.ne.9) iopv = iopval(1) +c +c if character input for intensity, change to numeric +c + if (iop .ne. 2) go to 105 + jchar = jlm2(iopval) + if (jchar .ne. jlm2(ihigh)) go to 103 + iopv = 204 + go to 105 + 103 if (jchar .ne. jlm2(ilow)) go to 104 + iopv = 127 + go to 105 + 104 iopv = iopval(1) + 105 continue +c +c reset option if necessary +c + if (iop .ne. 9) go to 107 + skip = modef .eq. 0 + do 106 i=1,3 + call ncgchr (iopval,3,i,ichar(i)) + call ncgchr (mop(iop),3,i,jchar) + skip = skip .and. (jchar .eq. ichar(i)) + call ncpchr (mop(iop),3,i,ichar(i)) + 106 continue + if (skip) go to 109 + nchar = 4 + mbpair = 1*nchar+58112 + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair = ior(ishift(iop,8),ichar(1)) + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair = ior(ishift(ichar(2),8),ichar(3)) + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + go to 109 + 107 continue + if (mop(iop).eq.iopv .and. modef.eq.0) go to 109 + mop(iop) = iopv + nchar = 2 + if (iop.eq.6 .or. iop.eq.3 .or. iop.eq.4 .or. iop.eq.7) nchar = 4 + mbpair = 1*nchar+58112 + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + if (nchar .eq. 4) go to 108 + mbpair = ior(ishift(iand(iop,255),8),iand(iopv,255)) + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + go to 109 + 108 mbpair = ishift(iop,8) + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair = iand(iopv,65535) + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + 109 return + end diff --git a/sys/gio/nspp/portlib/perim.f b/sys/gio/nspp/portlib/perim.f new file mode 100644 index 00000000..44c29212 --- /dev/null +++ b/sys/gio/nspp/portlib/perim.f @@ -0,0 +1,4 @@ + subroutine perim (magrx,minrx,magry,minry) + call gridal (magrx,minrx,magry,minry,0,0,5,1,1) + return + end diff --git a/sys/gio/nspp/portlib/periml.f b/sys/gio/nspp/portlib/periml.f new file mode 100644 index 00000000..a30b839d --- /dev/null +++ b/sys/gio/nspp/portlib/periml.f @@ -0,0 +1,4 @@ + subroutine periml (magrx,minrx,magry,minry) + call gridal (magrx,minrx,magry,minry,1,1,5,1,1) + return + end diff --git a/sys/gio/nspp/portlib/plotit.f b/sys/gio/nspp/portlib/plotit.f new file mode 100644 index 00000000..df048298 --- /dev/null +++ b/sys/gio/nspp/portlib/plotit.f @@ -0,0 +1,23 @@ + subroutine plotit (nx,ny,npen) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + mx = max0(0,min0(nx,32767)) + my = max0(0,min0(ny,32767)) + minst = max0(0,min0(1,npen)) + call put42 + return + end diff --git a/sys/gio/nspp/portlib/point.f b/sys/gio/nspp/portlib/point.f new file mode 100644 index 00000000..efca3bd0 --- /dev/null +++ b/sys/gio/nspp/portlib/point.f @@ -0,0 +1,43 @@ + subroutine point (x,y) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c ray bovet patch to avoid small integers being set to 0 + integer x,y,xx,yy +c + mbpair = 59394 + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair = 256 + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + xx = x + yy = y + call trans + minst = 0 + call put42 + mbpair = 59394 + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair = 0 + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + return + end diff --git a/sys/gio/nspp/portlib/points.f b/sys/gio/nspp/portlib/points.f new file mode 100644 index 00000000..07b11c5b --- /dev/null +++ b/sys/gio/nspp/portlib/points.f @@ -0,0 +1,57 @@ + subroutine points (x,y,n,ichar,ipen) + dimension x(n) ,y(n) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c ray bovet patch to avoid small integers being set to 0 + integer x,y,xx,yy +c + if (n .le. 0) return + mbpair = 59394 + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + if (ichar) 102,101,102 + 101 mbpair = 256 + go to 103 + 102 call ncgchr (ichar,1,1,jchar) + mbpair = 512+jchar + 103 mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + xx = x(1) + yy = y(1) + call trans + minst = 0 + call put42 + if (n .eq. 1) go to 105 + do 104 i=2,n + xx = x(i) + yy = y(i) + call trans + minst = ipen + call put42 + 104 continue + 105 mbpair = 59394 + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair = 0 + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + return + end diff --git a/sys/gio/nspp/portlib/porgn.f b/sys/gio/nspp/portlib/porgn.f new file mode 100644 index 00000000..ed2acf93 --- /dev/null +++ b/sys/gio/nspp/portlib/porgn.f @@ -0,0 +1,27 @@ + subroutine porgn (x,y) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c ray bovet patch to avoid small integers being set to 0 + integer x,y,xx,yy +c + xx = x + yy = y + call trans + xadd = mx-1 + yadd = my-1 + return + end diff --git a/sys/gio/nspp/portlib/preout.f b/sys/gio/nspp/portlib/preout.f new file mode 100644 index 00000000..ec2ead3b --- /dev/null +++ b/sys/gio/nspp/portlib/preout.f @@ -0,0 +1,116 @@ + subroutine preout + dimension idummy(1) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c +c+kpno +c Initialization moved to z8zpii.f. +c + common /nsplt1/ iclrfb ,isetfb ,ibpw ,ifwd +c data iclrfb/0/, isetfb/0/, ibpw/32/, ifwd/1/ +c-kpno +c + kbufa = mbufa +c +c entry while in flash1 mode will cause restart of filling user buffer +c if its size is exceded. otherwise it is assumed fixed-length output +c record size is exceded, so place for 4 bytes is reserved in user +c buffer, to allow proper record formatting during flash3 call. +c + if (modef .ne. 1) go to 101 + if (mbuflu+4 .le. mbufl) go to 113 + mbuflu = 0 + mf2er = mf2er+1 + go to 113 +c +c if necessary, build masks for setting and clearing new-frame flag +c + 101 if (iclrfb .ne. 0) go to 103 + iposn = ibpw*ifwd-21 + isetfb = ishift(1,iposn) + do 102 i=1,ibpw + ibit = 1 + if (i .eq. (ibpw-iposn)) ibit = 0 + iclrfb = ior(ishift(iclrfb,1),ibit) + 102 continue +c +c in flash3 mode, copy any shorter-than-record-length user buffer into +c system buffer, to avoid possible addressing error during fixed-length +c write. +c + 103 if (modef .ne. -3) go to 105 + if (mbuflu .eq. msblen) go to 105 + isub = kbufa-loci(idummy)+1 + do 104 i=1,mbuflu + msybuf(i) = idummy(isub) + isub = isub+1 + 104 continue + kbufa = loci(msybuf) +c +c compute metacode byte count and put in first 16 bits of buffer. +c *** note that we are directly manipulating the +c first 32 bits of the output buffer here *** +c + 105 mcrout = mcrout+1 + nbytes = -3+(ibpw*mbuflu-1)/8 + isub = kbufa-loci(idummy)+1 + idummy(isub) = ior(idummy(isub),ishift(nbytes,ibpw-16)) +c +c put in first-record-of-frame flag if appropriate. otherwise insure +c frame flag is zeroed. put buffer out via writeb. +c + isub = kbufa-loci(idummy)+ifwd + if (mfrlst .ne. 1) go to 106 + idummy(isub) = ior(idummy(isub),isetfb) + mfrlst = 0 + go to 107 + 106 idummy(isub) = iand(idummy(isub),iclrfb) + 107 if (mbuflu .eq. msblen) go to 109 + isub = kbufa+mbuflu-loci(idummy) + do 108 i=mbuflu,msblen + isub = isub+1 + idummy(isub) = 0 + 108 continue + 109 call writeb (kbufa,mbuflu,munit) +c +c if this is last buffer of frame, call writeb with zero-byte-count +c record, so that it may arrange that such a record follows the last +c frame of the metafile (note that mbufa points to msybuf when get here) +c + if (mfrend .ne. 1) go to 112 + mfrlst = 1 + isub = kbufa-loci(idummy) + do 110 i=1,mbuflu + isub = isub+1 + idummy(isub) = 0 + 110 continue + do 111 i=1,16 + mbprs(i) = 0 + 111 continue + mbprs(2) = ior(mpair2,2048) + call packum (mbprs,16,kbufa) + call writeb (kbufa,0,munit) +c +c finish up by reserving 4 bytes at start of next output buffer. +c + 112 mbuflu = 0 + 113 mbprs(1) = mpair1 + mbprs(2) = mpair2 + mipair = 2 + mflcnt = 0 + return + end diff --git a/sys/gio/nspp/portlib/pscale.f b/sys/gio/nspp/portlib/pscale.f new file mode 100644 index 00000000..3145d586 --- /dev/null +++ b/sys/gio/nspp/portlib/pscale.f @@ -0,0 +1,21 @@ + subroutine pscale (scalex,scaley) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + xfactr = scalex*2.**mshftx + yfactr = scaley*2.**mshfty + return + end diff --git a/sys/gio/nspp/portlib/psym.f b/sys/gio/nspp/portlib/psym.f new file mode 100644 index 00000000..c16cf020 --- /dev/null +++ b/sys/gio/nspp/portlib/psym.f @@ -0,0 +1,27 @@ + subroutine psym (x,y,ichr,isiz,icas,ip) + dimension ichr(1) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + dimension iwide(4) + data iwide(1),iwide(2),iwide(3),iwide(4)/256,384,512,768/ + if (ip-1) 102,102,101 + 101 call vector (x,y) + 102 call optn (4hcase,icas) + call getopt (5horien,iorn) + call pwrit (x,y,ichr,1,isiz,iorn,0) + return + end diff --git a/sys/gio/nspp/portlib/put42.f b/sys/gio/nspp/portlib/put42.f new file mode 100644 index 00000000..5f8aac81 --- /dev/null +++ b/sys/gio/nspp/portlib/put42.f @@ -0,0 +1,60 @@ + subroutine put42 + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + mjxmax = max0(mx,mjxmax) + mjymax = max0(my,mjymax) + mjxmin = min0(mx,mjxmin) + mjymin = min0(my,mjymin) +c +c test if increment instruction will work +c + if (iabs(mx-mxold).gt.mxmax .or. iabs(my-myold).gt.mymax) + 1 go to 101 +c +c construct increment instructions +c + incx = (mx-mxold)/mxfac+160 + incy = (my-myold)/myfac+32+minst*128 +c +c put instruction in buffer +c + mbpair = ior(ishift(incx,8),incy) + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mxold = mx + myold = my + return + 101 continue +c +c mx is first half of the instruction as it stands +c + mbpair = mx + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb +c +c my needs only pen bit +c + mbpair = my+ishift(minst,15) + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mxold = mx + myold = my + return + end diff --git a/sys/gio/nspp/portlib/putins.f b/sys/gio/nspp/portlib/putins.f new file mode 100644 index 00000000..466ebd56 --- /dev/null +++ b/sys/gio/nspp/portlib/putins.f @@ -0,0 +1,59 @@ + subroutine putins (nopcd,ins,nchar) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + dimension ins(nchar) + kopcd = nopcd + kchar = nchar +c +c put in the two header bytes +c + if (kopcd.lt.0 .or. kopcd.gt.63) go to 102 + mbpair = ior(ishift(kopcd+192,8),kchar) + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + if (kchar .eq. 0) return + if (kchar.lt.0 .or. kchar.ge.255) go to 103 +c +c put character string into instruction string +c + do 101 i=1,kchar,2 + call ncgchr (ins,kchar,i,jcharl) + call ncgchr (ins,kchar,i+1,jcharr) + mbpair = ior(ishift(jcharl,8),jcharr) + mipair = mipair+1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + 101 continue + return + 102 continue +c write (mprint,1001) kopcd +c + call uliber (0,40h0in putins call, nopcd .lt. 0 or .ge. 63,40) + call perror + return + 103 continue +c write (mprint,1002) kchar +c + call uliber (0,41h0in putins call, nchar .le. 0 or .ge. 255,41) + call perror + return +c +c1001 format (7h0nopcd=,i10) +c1002 format (7h0nchar=,i10) +c + end diff --git a/sys/gio/nspp/portlib/pwrit.f b/sys/gio/nspp/portlib/pwrit.f new file mode 100644 index 00000000..56ed0fb2 --- /dev/null +++ b/sys/gio/nspp/portlib/pwrit.f @@ -0,0 +1,95 @@ + subroutine pwrit (x,y,ichar,nchar,isize,ioren,icent) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c ray bovet patch to avoid small integers being set to 0 + integer x,y,xx,yy +c + dimension ichar(nchar) + dimension iwide(4) + data wide,high,white /6.,7.,2./ + data iwide(1),iwide(2),iwide(3),iwide(4)/256,384,512,768/ +c +c copy parameters into local variables +c + kchar = nchar + ksize = isize + koren = ioren +c +c transform character size into metacode units. +c + if (ksize .gt. 3) ksize = ishift(ksize,mshftx) + if (ksize .le. 3) ksize = iwide(ksize+1) + call optn (4hcsiz,ksize) +c +c transform orientation. +c + if (koren .lt. 0) koren = koren+360 + if (koren .ge. 0) call optn (4horen,koren) +c +c pass on centering. +c + call optn (4hcent,max0(0,min0(2,icent+1))) +c +c make coordinates global. +c + xx = x + yy = y + call trans +c +c use real variables for convenience. +c + fmx = mx + fmy = my +c +c work with radians instead of degrees. +c 2*pi/360. approximately = .0174533 +c + angle = float(koren)*.0174533 +c +c find starting point for string when considering centering option. +c + cosa = cos(angle) + sina = sin(angle) + wide2 = ksize/2 + widen = float(ksize*kchar)-float(ksize)*white/wide + if (icent) 103,101,102 + 101 fmx = fmx-cosa*widen*.5 + fmy = fmy-sina*widen*.5 + go to 103 + 102 fmx = fmx-cosa*widen + fmy = fmy-sina*widen + 103 continue + hgt2 = (3*ksize)/4 + nxul = fmx-cosa*wide2-sina*hgt2 + nyul = fmy+cosa*hgt2-sina*wide2 + nxll = fmx-cosa*wide2+sina*hgt2 + nyll = fmy-cosa*hgt2-sina*wide2 + nxur = fmx+cosa*widen+cosa*wide2-sina*hgt2 + nyur = fmy+sina*widen+cosa*hgt2+sina*wide2 + nxlr = fmx+cosa*widen+cosa*wide2+sina*hgt2 + nylr = fmy+sina*widen-cosa*hgt2+sina*wide2 + mjxmax = min0(32767,max0(mjxmax,nxul,nxll,nxur,nxlr)) + mjxmin = max0(0,min0(mjxmin,nxul,nxll,nxur,nxlr)) + mjymax = min0(32767,max0(mjymax,nyul,nyll,nyur,nylr)) + mjymin = max0(0,min0(mjymin,nyul,nyll,nyur,nylr)) + minst = 0 + call put42 + call putins (33,ichar,kchar) + mxold = -9999 + myold = -9999 + return + end diff --git a/sys/gio/nspp/portlib/pwrt.f b/sys/gio/nspp/portlib/pwrt.f new file mode 100644 index 00000000..ebb85ca5 --- /dev/null +++ b/sys/gio/nspp/portlib/pwrt.f @@ -0,0 +1,12 @@ + subroutine pwrt (x,y,chars,nchar,jsiz,jor) + dimension chars(1) + dimension jfix(4) + data jfix(1),jfix(2),jfix(3),jfix(4)/128,192,256,384/ + isiz = max0(0,min0(3,jsiz)) + call fl2int (x,y,nx,ny) + call getsi (ixsave,iysave) + nx = max0(0,ishift(nx-(1-jor)*jfix(isiz+1),ixsave-15)) + ny = max0(0,ishift(ny-jor*jfix(isiz+1),iysave-15)) + call pwrit (nx,ny,chars,nchar,isiz,jor*90,-1) + return + end diff --git a/sys/gio/nspp/portlib/set.f b/sys/gio/nspp/portlib/set.f new file mode 100644 index 00000000..a9417d90 --- /dev/null +++ b/sys/gio/nspp/portlib/set.f @@ -0,0 +1,140 @@ + subroutine set (xa,xb,ya,yb,xc,xd,yc,yd,itype) +c +c *************** KPNO -- name changed from set to sppset ********** +c + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c ray bovet patch to avoid small integers being set to 0 + integer xa,xb,ya,yb,xxa,xxb,yya,yyb,zz + logical intt + dimension zz(4) ,mz(4) ,zc(2) ,zd(2) ,zfactr(2) , + 1 zadd(2),mtypez(2) + dimension mshftz(2) + dimension mes(2) + equivalence (xxc,zc(1)) ,(xxd,zd(1)) ,(xxa,zz(1)) , + 1 (mxa,mz(1)) ,(xfactr,zfactr(1)) , + 2 (xadd,zadd(1)) ,(mtypex,mtypez(1)) , + 3 (mshftx,mshftz(1)) ,(temp,itemp) + data mes(1),mes(2)/1hx,1hy/ + xxa = xa + xxb = xb + xxc = xc + xxd = xd + yya = ya + yyb = yb + yyc = yc + yyd = yd + mtype = itype + mtypex = (mtype-1)/2 + mtypey = mod(mtype-1,2) +c +c find mxa, mxb, etc by mapping xxa, xxb, etc into integer space if they +c are not integers +c + do 103 i=1,4 + k = i + if (k .gt. 2) k = k-2 +c ray bovet patch to avoid small integers being set to 0 +c temp = zz(i) + itemp = zz(i) +c if (temp .lt. 0.0) go to 106 +c + if (.not.(intt(temp))) go to 101 + if (itemp.lt.0) go to 106 + itemp = ishift(itemp-1,mshftz(k)) + go to 102 +c ray bovet patch to avoid small integers being set to 0 +c 101 itemp = temp*32767. + 101 if(temp.lt.0.0) go to 106 + itemp = temp*32767. +c + 102 if (itemp.lt.0 .or. itemp.gt.32767) go to 107 + mz(i) = itemp + 103 continue +c +c set up parameters for translating real input from frstpt, etc. to +c integer plotting space +c + do 105 i=1,2 + prange = mz(i+2)-mz(i) + urange = zd(i)-zc(i) +c +c test for no range +c + if (urange.eq.0. .or. prange.eq.0.) go to 108 +c +c test for log scaling +c + if (mtypez(i) .eq. 0) go to 104 +c +c test for error +c + if (zc(i) .le. 0.) go to 109 + if (zd(i) .le. 0.) go to 110 + urange = alog10(zd(i)/zc(i)) + zfactr(i) = prange/urange + zadd(i) = float(mz(i))-zfactr(i)*alog10(zc(i)) + go to 105 + 104 zfactr(i) = prange/urange + zadd(i) = float(mz(i))-zfactr(i)*zc(i) + 105 continue + return +c +c error processing +c + 106 continue + if (i.gt.1 .and. i.lt.4) i = 5-i +c write (mprint,1001) i +c + call uliber (0,53h0negative values not allowed in first 4 set argu + 1ments ,53) + call perror + return + 107 continue + if (i.gt.1 .and. i.lt.4) i = 5-i +c write (mprint,1002) i +c + call uliber (0,83h0first 4 set arguments must be real between 0 an + 1d 1 or integers between 1 and 32767,83) + call perror + return + 108 continue + i1 = i*2+3 + i2 = i*2+4 +c write (mprint,1003) i1,i2 +c + call uliber (0,31h0no range in x or y in set call,31) + call perror + return + 109 continue +c 109 write (mprint,1004) mes(i) + go to 111 + 110 continue +c 110 write (mprint,1005) mes(i) +c + 111 call uliber (0,46h0non-positive argument to set with log scaling, + 1 46) + call perror + return +c +c1001 format (9h0argument,i2,9h negative) +c1002 format (9h0argument,i2,13h out of range) +c1003 format (10h0arguments,i2,4h and,i2,14h are identical) +c1004 format (1h0,a1,8hc .le. 0) +c1005 format (1h0,a1,8hd .le. 0) +c + end diff --git a/sys/gio/nspp/portlib/seti.f b/sys/gio/nspp/portlib/seti.f new file mode 100644 index 00000000..9bc9a635 --- /dev/null +++ b/sys/gio/nspp/portlib/seti.f @@ -0,0 +1,37 @@ + subroutine seti (npowx,npowy) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c +c patch by r bovet to ensure that values are <= 12 on vax +c this is necessary to ensure that intt can work. +c + ipowx = npowx + ipowy = npowy + if(ipowx.le.12) go to 10 + call uliber(0,'x power input to seti cannot exceed 12 + & on vax',80) + ipowx = 12 +10 continue + if(ipowy.le.12) go to 20 + call uliber(0,'y power input to seti cannot exceed 12 + & on vax',80) + ipowy = 12 +20 continue + mshftx = 15-ipowx + mshfty = 15-ipowy + return + end diff --git a/sys/gio/nspp/portlib/tick4.f b/sys/gio/nspp/portlib/tick4.f new file mode 100644 index 00000000..2f1d0ace --- /dev/null +++ b/sys/gio/nspp/portlib/tick4.f @@ -0,0 +1,30 @@ + subroutine tick4 (mgrx,mnrx,mgry,mnry) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c +c mmgrx(y) is the length in the x(y) direction of major tick marks +c and is therefor used on the y(x) axis (to be consistent with mx(y)dec +c of labmod). +c mgrx(y) is the length of x(y) axis major tick marks. +c similarly for mmnrx(y) and mnrx(y). +c + mmgrx = isign(ishift(iabs(mgry),mshftx),mgry) + mmgry = isign(ishift(iabs(mgrx),mshfty),mgrx) + mmnrx = isign(ishift(iabs(mnry),mshftx),mnry) + mmnry = isign(ishift(iabs(mnrx),mshfty),mnrx) + return + end diff --git a/sys/gio/nspp/portlib/ticks.f b/sys/gio/nspp/portlib/ticks.f new file mode 100644 index 00000000..96484c5d --- /dev/null +++ b/sys/gio/nspp/portlib/ticks.f @@ -0,0 +1,4 @@ + subroutine ticks (major,minor) + call tick4 (major,minor,major,minor) + return + end diff --git a/sys/gio/nspp/portlib/trans.f b/sys/gio/nspp/portlib/trans.f new file mode 100644 index 00000000..5fe0affc --- /dev/null +++ b/sys/gio/nspp/portlib/trans.f @@ -0,0 +1,52 @@ + subroutine trans + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c ray bovet patch to avoid small integers being set to 0 + integer xx,yy +c + logical intt + equivalence (zz,mz),(temp,itemp) +c ray bovet patch to avoid small integers being set to 0 +c zz = xx + mz = xx + if (intt(zz)) go to 102 + if (mtypex .eq. 0) go to 101 + if (zz .le. 0.0) + 1 call uliber (0,35h0negative argument with log scaling,35) + zz = amax1(zz,small) + zz = xfactr*alog10(zz)+xadd + go to 103 + 101 zz = xfactr*zz+xadd + go to 103 + 102 zz = float(ishift(mz-1,mshftx)) + 103 mx = max1(0.,amin1(32767.,zz)) +c ray bovet patch to avoid small integers being set to 0 +c zz = yy + mz = yy + if (intt(zz)) go to 105 + if (mtypey .eq. 0) go to 104 + if (zz .le. 0.0) + 1 call uliber (0,35h0negative argument with log scaling,35) + zz = amax1(zz,small) + zz = yfactr*alog10(zz)+yadd + go to 106 + 104 zz = yfactr*zz+yadd + go to 106 + 105 zz = float(ishift(mz-1,mshfty)) + 106 my = max1(0.,amin1(32767.,zz)) + return + end diff --git a/sys/gio/nspp/portlib/vector.f b/sys/gio/nspp/portlib/vector.f new file mode 100644 index 00000000..03b3bac8 --- /dev/null +++ b/sys/gio/nspp/portlib/vector.f @@ -0,0 +1,27 @@ + subroutine vector (x,y) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c ray bovet patch to avoid small integers being set to 0 + integer x,y,xx,yy +c + xx = x + yy = y + call trans + minst = 1 + call put42 + return + end diff --git a/sys/gio/nspp/portlib/z8zpbd.f b/sys/gio/nspp/portlib/z8zpbd.f new file mode 100644 index 00000000..4392d84a --- /dev/null +++ b/sys/gio/nspp/portlib/z8zpbd.f @@ -0,0 +1,6 @@ + subroutine z8zpbd +c +c kpno: only obvious constants are initialized in this block data. +c all other initialization occurs in z8zpii. +c + end diff --git a/sys/gio/nspp/portlib/z8zpii.f b/sys/gio/nspp/portlib/z8zpii.f new file mode 100644 index 00000000..580d9968 --- /dev/null +++ b/sys/gio/nspp/portlib/z8zpii.f @@ -0,0 +1,362 @@ + subroutine z8zpii +c+kpno +c +c All data statements changed to runtime assignment statements; routine +c changed from block data to subroutine. +c +c-kpno + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c + common /nsplt1/ iclrfb ,isetfb ,ibpw ,ifwd +c +c variables use +c --------- --- +c +c mmajx,mmajy,mminx, gridal arguments stored here so they will be in a +c mminy,mxlab,mylab, known order for insertion in the instruction +c mflg stream only when ultracompact metacode is +c being produced. +c +c mtype scaling type of the most recent set call +c +c mx,my plotter address of the pen location +c +c mxa,mya,mxb,myb plotter address corresponding to the first four +c arguments of the most recent set call. +c +c mtypex,mtypey a decoding of mtype-- 0 = linear, 1 = log +c +c xxa,yya,xxb,yyb, exact copies of the first eight parameters +c xxc,yyc,xxd,yyd of the most recent set call +c +c xfactr,yfactr,xadd, numbers computed from the most recent set call +c yadd arguments so that real valued coordinates can +c be translated to integers by +c mx = xfactr*xx + xadd +c or +c mx = xfactr*alog10(xx) + xadd +c and similarly for y. +c +c xx,yy most recent coordinate input to the plot package +c +c mfmtx,mfmty,mumx, most recent labmod inputs except that mxdec = 0 +c mumy,msizx,msizy, and mydec = 0 are decoded and mxdec = 1 and +c mxdec,mydec,mxor mydec = 1 become 0. +c +c mop(i),mname(i) option names are given in mname and their +c current values in mop +c +c mxold,myold,mxmax, all used for increment instructions only. mxold +c mymax,mxfac,myfac and myold are the plotter coordinates of the +c previous point, mxmax and mymax are the greatest +c distance an increment can move, and mxfac and +c myfac are the number of plotter units per +c increment unit (generally 1, but can be more if +c compaction is important and high resolution is +c not). +c +c modef = 0 flash routines have not been used +c = 1 most recent flash call was to flash1 +c (we are between flash1 and flash2 calls +c and the instructions should be put in the +c users buffer) +c = 2 flash1 call has been closed with a +c flash2 call +c =-3 flash3 has been entered, but not exited, +c i.e., flash3 is dumping a user buffer. +c = 3 most recent flash activity is a completed +c flash3 call. +c = 4 most recent flash call was to flash4 +c +c mf2er = 0 no flash buffer overflow +c = n counts the number of times the buffer +c was reused so the required size can be +c estimated +c +c mshftx,mshfty the power of two of the ratio between the +c resolution of the metacode address and the +c resolution the user is working in. in the +c default case, the user assumes the plotter +c is 1024 by 1024 (1024 = 2 **10). metacode +c addresses have 15 bits, so their capacity is +c 32,768. thus, the default for mshftx and mshfty +c is 5, and user integer coordinates are left +c shifted 5 to make plotter addresses. +c +c mmgrx,mmgry,mmnrx, tick mark lengths (positive values point in) +c mmnry +c +c mcrout number of metacode records that have been put +c out via preout. +c +c mflcnt used to count the number of flushb calls since +c last mbprs initialization. it is used to avoid +c empty records which could otherwise be put out. +c +c mfrend frame sets to 1 to indicate last output call of a +c frame, and resets to zero before returning. +c +c mfrlst preout manipulates, based on mfrend, so that it +c knows when a record is the first of a new frame. +c +c mjxmin,mjymin, used to keep track of the range of the plotting +c mjxmax,mjymax address on the frame being created +c +c mnxsto,mnysto used to hold mjxmin,... after flash1 call, and +c mxxsto,mxysto restore them after flash2. mjxmin,... are ac- +c cumulated anew during flash saving, and stored +c in user flash buffer after flash2 call. +c +c mpair1,mpair2 two 16-bit pairs used to initialize each output +c record, so that preout may format first 32 bits. +c they are actually put into mbprs at proper times +c +c mprint unit number for printing error messages too +c extensive to be handled by uliber +c +c msybuf buffer to hold up to a few hundred metacode +c instructions +c +c msblen word length of msybuf. +c +c mncpw the number of characters per word on the host +c computer +c +c minst holds instruction op-code for the instruction +c being formed +c +c mbufa contains the address of the buffer for the +c metacode instructions, either loci(msybuf) or +c loci(user buffer) from a flash1 call +c +c mbuflu the number of words of the buffer pointed to by +c mbufa that have been filled with metacode or +c dd80 instructions +c +c mfwa,mlwa contains the first word address and the last +c word address for the flash buffers +c +c mipair,mbprs mbprs is used to store byte pairs of metacode +c until they can be packed in an integral number +c of words and placed in the buffer pointed to by +c mbufa. mipair tells how much of mbprs has been +c used. +c +c mbufl the length of the buffer pointed to by mbufa. +c +c munit unit number for writing metacode +c +c small smallest positive number on the host computer. +c this is used when nonpositive numbers are plotted +c with log scaling. +c +c + dimension mfssx(2), mfssy(2), mnsss(9) +c + data mfssx(1)/4h(e10/ + data mfssx(2)/4h.3) / + data mfssy(1)/4h(e10/ + data mfssy(2)/4h.3) / +c + data mnsss(1)/4hcase/ + data mnsss(2)/4hintn/ + data mnsss(3)/4horen/ + data mnsss(4)/4hcsiz/ + data mnsss(5)/4hfont/ + data mnsss(6)/4hdpat/ + data mnsss(7)/4hssiz/ + data mnsss(8)/4hcent/ + data mnsss(9)/4hcolr/ +c + do 10 i = 1, 2 + mfmtx(i) = mfssx(i) +10 continue + do 11 i = 1, 2 + mfmty(i) = mfssy(i) +11 continue + do 12 i = 1, 9 + mname(i) = mnsss(i) +12 continue +c +c data iclrfb/0/, isetfb/0/, ibpw/32/, ifwd/1/ + iclrfb = 0 + isetfb = 0 + ibpw = 32 + ifwd = 1 +c +c data mtype,mtypex,mtypey/1,0,0/ + mtype = 1 + mtypex = 0 + mtypey = 0 +c +c data mx,my/0,0/ + mx = 0 + my = 0 +c +c data xxa,yya,xxb,yyb/0.,0.,1.,1./ + xxa = 0.0 + yya = 0.0 + xxb = 1.0 + yyb = 1.0 +c +c data xxc,yyc,xxd,yyd/0.,0.,1.,1./ + xxc = 0.0 + yyc = 0.0 + xxd = 1.0 + yyd = 1.0 +c +c data mxa,mya,mxb,myb/1,1,32767,32767/ + mxa = 1 + mya = 32767 + mxb = 1 + mxb = 32767 +c +c data xfactr,yfactr/32767.,32767./ + xfactr = 32767. + yfactr = 32767. +c +c data xadd,yadd/1.,1./ + xadd = 1.0 + yadd = 1.0 +c +c data mumx,mumy/10,10/ + mumx = 10 + mumy = 10 +c +c data msizx,msizy/0,0/ + msizx = 0 + msizy = 0 +c +c data mxdec,mydec/655,655/ + mxdec = 655 + mydec = 655 +c +c data mxor/0/ + mxor = 0 +c +c data mop(1)/0/ +c data mop(2)/204/ +c data mop(3)/0/ +c data mop(4)/128/ +c data mop(5)/0/ +c data mop(6)/65535/ +c data mop(7)/8/ +c data mop(8)/0/ +c data mop(9)/0/ + mop(1) = 0 + mop(2) = 204 + mop(3) = 0 + mop(4) = 128 + mop(5) = 0 + mop(6) = 65535 + mop(7) = 8 + mop(8) = 0 + mop(9) = 0 +c +c data mxold,myold/-9999,-9999/ + mxold = -9999 + myold = -9999 +c +c data mxmax,mymax/31,31/ + mxmax = 31 + mymax = 31 +c +c data mxfac,myfac/1,1/ + mxfac = 1 + myfac = 1 +c +c data mmgrx,mmgry/385,385/ + mmgrx = 385 + mmgry = 385 +c +c data mmnrx,mmnry/255,255/ + mmnrx = 255 + mmnry = 255 +c +c data modef/0/ + modef = 0 +c +c data mncpw/4/ + mncpw = 4 +c +c data mbuflu/0/ + mbuflu = 0 +c +c data msblen/360/ + msblen = 360 +c +c data mbufl/360/ + mbufl = 360 +c +c data mf2er/0/ + mf2er = 0 +c +c data mshftx,mshfty/5,5/ + mshftx = 5 + mshfty = 5 +c +c data mbufa/-9999/ + mbufa = -9999 +c +c data mflcnt/0/ + mflcnt = 0 +c +c data mfrend/0/ + mfrend = 0 +c +c data mfrlst/1/ + mfrlst = 1 +c +c data mpair1/0/ + mpair1 = 0 +c +c data mpair2/8192/ + mpair2 = 8192 +c +c data mcrout/0/ + mcrout = 0 +c +c data mbprs(1)/0/ + mbprs(1) = 0 +c +c data mbprs(2)/8192/ + mbprs(2) = 8192 +c +c data mipair/2/ + mipair = 2 +c +c data mjxmax,mjymax,mjxmin,mjymin/0,0,32767,32767/ + mjxmax = 0 + mjymax = 0 + mjxmin = 32767 + mjxmin = 32767 +c +c set to unit number for printer +c +c data mprint/6/ + mprint = 6 +c +c set to unit number for plotter +c +c data munit/8/ + munit = 8 +c set to smallest positive number on the computer +c +c data small/1.e-25/ + small = 1.e-25 + end diff --git a/sys/gio/nspp/sysint/README b/sys/gio/nspp/sysint/README new file mode 100644 index 00000000..64537d9d --- /dev/null +++ b/sys/gio/nspp/sysint/README @@ -0,0 +1 @@ +SYSINT -- System interface for the Ncar System Plot Package (NSPP) diff --git a/sys/gio/nspp/sysint/encd.f b/sys/gio/nspp/sysint/encd.f new file mode 100644 index 00000000..1dba902b --- /dev/null +++ b/sys/gio/nspp/sysint/encd.f @@ -0,0 +1,78 @@ + SUBROUTINE ENCD (VALU,ASH,IOUT,NC,IOFFD) +C +C +C +C +C ON INPUT VALU FLOATING POINT NUMBER FROM WHICH THE LABEL IS +C TO BE CREATED. +C ASH SEE IOFFD. +C IOFFD IF IOFFD .EQ. 0, A LABEL WHICH REFLECTS THE +C MAGNITUDE OF VALU IS TO BE CREATED. +C .1 .LE. ABS(VALU) .LE. 99999.49999... +C OR VALUE .EQ. 0.0. THE LABEL CREATED +C SHOULD HAVE 3 TO 5 CHARACTERS DEPENDING +C ON THE MAGNITUDE OF VALU. SEE IOUT. +C IF IOFFD .NE. 0, A LABEL WHICH DOES NOT REFLECT +C THE MAGNITUDE OF VALU IS TO BE CREATED. +C ASH IS USED AS THE NORMALIZATION FACTOR. +C 1. .LE. ASH*ABS(VALU) .LT. 1000. OR +C VALU .EQ. 0.0. THE LABEL CREATED SHOULD +C HAVE 1 TO 3 CHARACTERS, DEPENDING ON THE +C MAGNITUDE OF ASH*VALU. SEE IOUT. +C ON OUTPUT IOUT CONTAINS THE LABEL CREATED. IT SHOULD HAVE NO +C LEADING BLANKS. SEE NC. +C NC THE NUMBERS IN THE LABEL IN IOUT. SHOULD BE +C 1 TO 5. +C + SAVE + CHARACTER*11 IFMT, IOUT +C +C IFMT MUST HOLD 11 CHARACTERS +C + VAL = VALU + IF (IOFFD .NE. 0) GO TO 103 + IF (VAL) 101,104,101 + 101 LOG = IFIX((ALOG10(ABS(VAL))+.00001)+5000.)-5000 + V = VAL + NS = MAX0(4,MIN0(6,LOG+2)) + ND = MIN0(3,MAX0(0,2-LOG)) +c IF (VAL.LT.0) NS = NS + 1 +c +noao: replacing ftn i/o for iraf implementation +c 102 WRITE (IFMT,'(A2,I2,A1,I1,A1)') '(F',NS,'.',ND,')' + 102 continue +c if (len (char (ns + ichar ('0'))) .eq. 2) then +c ifmt(1:7) = '(f . )' +c ifmt(3:4) = char (ns + ichar ('0')) +c ifmt(6:6) = char (nd + ichar ('0')) +c else +c ifmt(1:6) = '(f . )' +c ifmt(3:3) = char (ns + ichar ('0')) +c ifmt(5:5) = char (nd + ichar ('0')) +c endif +c WRITE (IOUT,IFMT) V + call encode (ns, ifmt, iout, v) + NC = NS +c +noao +c The following statement was making 5 digit labels (+4800) come out +c truncated (+480) and it has been commented out. +c IF (LOG.GE.3) NC = NC - 1 +c -noao + RETURN + 103 NS = 4 + IF (VAL.LT.0.) NS=5 + IF (VAL.EQ.0.) NS=2 + ND = 0 + V = VAL*ASH + LOG = 100 + GO TO 102 + 104 iout(1:3) = '0.0' + nc = 3 +c 104 NS = 3 +c ND = 1 +c LOG = -100 +c V = 0. +c GO TO 102 +C +C1001 FORMAT('(F',I2,'.',I1,',1H',A1,')') +C + END diff --git a/sys/gio/nspp/sysint/encode.f b/sys/gio/nspp/sysint/encode.f new file mode 100644 index 00000000..e6417bee --- /dev/null +++ b/sys/gio/nspp/sysint/encode.f @@ -0,0 +1,15 @@ + subroutine encode (nchars, ftnfmt, ftnout, rval) + + character*11 ftnfmt, ftnout + integer*2 sppfmt(12), sppout(12) + integer SZFMT + parameter (SZFMT=11) + +c unpack the fortran character string, call fencd to actually encode the +c output string, then pack the output string into a fortran string for return +c + call f77upk (ftnfmt, sppfmt, SZFMT) + call fencd (nchars, sppfmt, sppout, rval) + call f77pak (sppout, ftnout, SZFMT) + + end diff --git a/sys/gio/nspp/sysint/erprt77.f b/sys/gio/nspp/sysint/erprt77.f new file mode 100644 index 00000000..a4f60e1d --- /dev/null +++ b/sys/gio/nspp/sysint/erprt77.f @@ -0,0 +1,441 @@ +C PACKAGE ERPRT77 DESCRIPTION OF INDIVIDUAL USER ENTRIES +C FOLLOWS THIS PACKAGE DESCRIPTION. +C +C LATEST REVISION FEBRUARY 1985 +C +C PURPOSE TO PROVIDE A PORTABLE, FORTRAN 77 ERROR +C HANDLING PACKAGE. +C +C USAGE THESE ROUTINES ARE INTENDED TO BE USED IN +C THE SAME MANNER AS THEIR SIMILARLY NAMED +C COUNTERPARTS ON THE PORT LIBRARY. EXCEPT +C FOR ROUTINE SETER, THE CALLING SEQUENCES +C OF THESE ROUTINES ARE THE SAME AS FOR +C THEIR PORT COUNTERPARTS. +C ERPRT77 ENTRY PORT ENTRY +C ------------- ---------- +C ENTSR ENTSRC +C RETSR RETSRC +C NERRO NERROR +C ERROF ERROFF +C SETER SETERR +C EPRIN EPRINT +C FDUM FDUMP +C +C I/O SOME OF THE ROUTINES PRINT ERROR MESSAGES. +C +C PRECISION NOT APPLICABLE +C +C REQUIRED LIBRARY MACHCR, WHICH IS LOADED BY DEFAULT ON +C FILES NCAR'S CRAY MACHINES. +C +C LANGUAGE FORTRAN 77 +C +C HISTORY DEVELOPED OCTOBER, 1984 AT NCAR IN BOULDER, +C COLORADO BY FRED CLARE OF THE SCIENTIFIC +C COMPUTING DIVISION BY ADAPTING THE NON- +C PROPRIETARY, ERROR HANDLING ROUTINES +C FROM THE PORT LIBRARY OF BELL LABS. +C +C PORTABILITY FULLY PORTABLE +C +C REFERENCES SEE THE MANUAL +C PORT MATHEMATICAL SUBROUTINE LIBRARY +C ESPECIALLY "ERROR HANDLING" IN SECTION 2 +C OF THE INTRODUCTION, AND THE VARIOUS +C SUBROUTINE DESCRIPTIONS. +C ****************************************************************** +C +C SUBBROUTINE ENTSR(IROLD,IRNEW) +C +C PURPOSE SAVES THE CURRENT RECOVERY MODE STATUS AND +C SETS A NEW ONE. IT ALSO CHECKS THE ERROR +C STATE, AND IF THERE IS AN ACTIVE ERROR +C STATE A MESSAGE IS PRINTED. +C +C USAGE CALL ENTSR(IROLD,IRNEW) +C +C ARGUMENTS +C +C ON INPUT IRNEW +C VALUE SPECIFIED BY USER FOR ERROR +C RECOVERY +C = 0 LEAVES RECOVERY UNCHANGED +C = 1 GIVES RECOVERY +C = 2 TURNS RECOVERY OFF +C +C ON OUTPUT IROLD +C RECEIVES THE CURRENT VALUE OF THE ERROR +C RECOVERY MODE +C +C SPECIAL CONDITIONS IF THERE IS AN ACTIVE ERROR STATE, THE +C MESSAGE IS PRINTED AND EXECUTION STOPS. +C +C ERROR STATES - +C 1 - ILLEGAL VALUE OF IRNEW. +C 2 - CALLED WHILE IN AN ERROR STATE. +C ****************************************************************** +C +C SUBROUTINE RETSR(IROLD) +C +C PURPOSE SETS THE RECOVERY MODE TO THE STATUS GIVEN +C BY THE INPUT ARGUMENT. A TEST IS THEN MADE +C TO SEE IF A CURRENT ERROR STATE EXISTS WHICH +C IS UNRECOVERABLE; IF SO, RETSR PRINTS AN +C ERROR MESSAGE AND TERMINATES THE RUN. +C +C BY CONVENTION, RETSR IS USED UPON EXIT +C FROM A SUBROUTINE TO RESTORE THE PREVIOUS +C RECOVERY MODE STATUS STORED BY ROUTINE +C ENTSR IN IROLD. +C +C USAGE CALL RETSR(IROLD) +C +C ARGUMENTS +C +C ON INPUT IROLD +C = 1 SETS FOR RECOVERY +C = 2 SETS FOR NONRECOVERY +C +C ON OUTPUT NONE +C +C SPECIAL CONDITIONS IF THE CURRENT ERROR BECOMES UNRECOVERABLE, +C THE MESSAGE IS PRINTED AND EXECUTION STOPS. +C +C ERROR STATES - +C 1 - ILLEGAL VALUE OF IROLD. +C ****************************************************************** +C +C INTEGER FUNCTION NERRO(NERR) +C +C PURPOSE PROVIDES THE CURRENT ERROR NUMBER (IF ANY) +C OR ZERO IF THE PROGRAM IS NOT IN THE +C ERROR STATE. +C +C USAGE N = NERRO(NERR) +C +C ARGUMENTS +C +C ON INPUT NONE +C +C ON OUTPUT NERR +C CURRENT VALUE OF THE ERROR NUMBER +C ****************************************************************** +C SUBROUTINE ERROF +C +C PURPOSE TURNS OFF THE ERROR STATE BY SETTING THE +C ERROR NUMBER TO ZERO +C +C USAGE CALL ERROF +C +C ARGUMENTS +C +C ON INPUT NONE +C +C ON OUTPUT NONE +C ****************************************************************** +C +C SUBROUTINE SETER(MESSG,NERR,IOPT) +C +C PURPOSE SETS THE ERROR INDICATOR AND, DEPENDING +C ON THE OPTIONS STATED BELOW, PRINTS A +C MESSAGE AND PROVIDES A DUMP. +C +C +C USAGE CALL SETER(MESSG,NERR,IOPT) +C +C ARGUMENTS +C +C ON INPUT MESSG +C HOLLERITH STRING CONTAINING THE MESSAGE +C ASSOCIATED WITH THE ERROR +C +C NERR +C THE NUMBER TO ASSIGN TO THE ERROR +C +C IOPT +C = 1 FOR A RECOVERABLE ERROR +C = 2 FOR A FATAL ERROR +C +C IF IOPT = 1 AND THE USER IS IN ERROR +C RECOVERY MODE, SETERR SIMPLY REMEMBERS +C THE ERROR MESSAGE, SETS THE ERROR NUMBER +C TO NERR, AND RETURNS. +C +C IF IOPT = 1 AND THE USER IS NOT IN ERROR +C RECOVERY MODE, SETERR PRINTS THE ERROR +C MESSAGE AND TERMINATES THE RUN. +C +C IF IOPT = 2 SETERR ALWAYS PRINTS THE ERROR +C MESSAGE, CALLS FDUM, AND TERMINATES THE RUN. +C +C ON OUTPUT NONE +C +C SPECIAL CONDITIONS CANNOT ASSIGN NERR = 0, AND CANNOT SET IOPT +C TO ANY VALUE OTHER THAN 1 OR 2. +C ****************************************************************** +C +C SUBROUTINE EPRIN +C +C PURPOSE PRINTS THE CURRENT ERROR MESSAGE IF THE +C PROGRAM IS IN THE ERROR STATE; OTHERWISE +C NOTHING IS PRINTED. +C +C USAGE CALL EPRIN +C +C ARGUMENTS +C +C ON INPUT NONE +C +C ON OUTPUT NONE +C ****************************************************************** +C +C SUBROUTINE FDUM +C +C PURPOSE TO PROVIDE A DUMMY ROUTINE WHICH SERVES +C AS A PLACEHOLDER FOR A SYMBOLIC DUMP +C ROUTINE, SHOULD IMPLEMENTORS DECIDE TO +C PROVIDE SUCH A ROUTINE. +C +C USAGE CALL EPRIN +C +C ARGUMENTS +C +C ON INPUT NONE +C +C ON OUTPUT NONE +C ****************************************************************** + SUBROUTINE ENTSR(IROLD,IRNEW) +C + LOGICAL TEMP + IF (IRNEW.LT.0 .OR. IRNEW.GT.2) + 1 CALL SETER(' ENTSR - ILLEGAL VALUE OF IRNEW',1,2) +C + TEMP = IRNEW.NE.0 + IROLD = I8SAV(2,IRNEW,TEMP) +C +C IF HAVE AN ERROR STATE, STOP EXECUTION. +C + IF (I8SAV(1,0,.FALSE.) .NE. 0) CALL SETER + 1 (' ENTSR - CALLED WHILE IN AN ERROR STATE',2,2) +C + RETURN +C + END + SUBROUTINE RETSR(IROLD) +C + IF (IROLD.LT.1 .OR. IROLD.GT.2) + 1 CALL SETER(' RETSR - ILLEGAL VALUE OF IROLD',1,2) +C + ITEMP=I8SAV(2,IROLD,.TRUE.) +C +C IF THE CURRENT ERROR IS NOW UNRECOVERABLE, PRINT AND STOP. +C + IF (IROLD.EQ.1 .OR. I8SAV(1,0,.FALSE.).EQ.0) RETURN +C + CALL EPRIN + CALL FDUM +c STOP +C + END + INTEGER FUNCTION NERRO(NERR) +C + NERRO=I8SAV(1,0,.FALSE.) + NERR=NERRO + RETURN +C + END + SUBROUTINE ERROF +C + I=I8SAV(1,0,.TRUE.) + RETURN +C + END + SUBROUTINE SETER(MESSG,NERR,IOPT) +C + CHARACTER*(*) MESSG + COMMON /UERRF/IERF +C +C THE UNIT FOR ERROR MESSAGES IS I1MACH(4) +C +c +noao: blockdata uerrbd changed to runtime initialization subroutine +C FORCE LOAD OF BLOCKDATA +C +c EXTERNAL UERRBD + call uerrbd +c -noao + IF (IERF .EQ. 0) THEN + IERF = I1MACH(4) + ENDIF +C + NMESSG = LEN(MESSG) + IF (NMESSG.GE.1) GO TO 10 +C +C A MESSAGE OF NON-POSITIVE LENGTH IS FATAL. +C +c +noao: FTN writes rewritten as calls to uliber for IRAF +c WRITE(IERF,9000) +c9000 FORMAT(' ERROR 1 IN SETER - MESSAGE LENGTH NOT POSITIVE.') + call uliber (1,' SETER - MESSAGE LENGTH NOT POSITIVE.', 80) +c -noao + GO TO 60 +C + 10 CONTINUE + IF (NERR.NE.0) GO TO 20 +C +C CANNOT TURN THE ERROR STATE OFF USING SETER. +C +c +noao: FTN writes rewritten as calls to uliber for IRAF +c WRITE(IERF,9001) +c9001 FORMAT(' ERROR 2 IN SETER - CANNOT HAVE NERR=0'/ +c 1 ' THE CURRENT ERROR MESSAGE FOLLOWS'/) + call uliber (2, ' SETER - CANNOT HAVE NERR=0', 80) + call uliber (2, ' SETER - THE CURRENT ERROR MSG FOLLOWS', 80) +c -noao + CALL E9RIN(MESSG,NERR,.TRUE.) + ITEMP=I8SAV(1,1,.TRUE.) + GO TO 50 +C +C SET LERROR AND TEST FOR A PREVIOUS UNRECOVERED ERROR. +C + 20 CONTINUE + IF (I8SAV(1,NERR,.TRUE.).EQ.0) GO TO 30 +C +c +noao: FTN writes rewritten as calls to uliber for IRAF +c WRITE(IERF,9002) +c9002 FORMAT(' ERROR 3 IN SETER -', +c 1 ' AN UNRECOVERED ERROR FOLLOWED BY ANOTHER ERROR.'// +c 2 ' THE PREVIOUS AND CURRENT ERROR MESSAGES FOLLOW.'///) + call uliber (3,' SETER - A SECOND UNRECOV ERROR SEEN.', 80) + call uliber (3,' SETER - THE ERROR MESSAGES FOLLOW.', 80) +c -noao + CALL EPRIN + CALL E9RIN(MESSG,NERR,.TRUE.) + GO TO 50 +C +C SAVE THIS MESSAGE IN CASE IT IS NOT RECOVERED FROM PROPERLY. +C + 30 CALL E9RIN(MESSG,NERR,.TRUE.) +C + IF (IOPT.EQ.1 .OR. IOPT.EQ.2) GO TO 40 +C +C MUST HAVE IOPT = 1 OR 2. +C +c +noao: FTN writes rewritten as calls to uliber for IRAF +c WRITE(IERF,9003) +c9003 FORMAT(' ERROR 4 IN SETER - BAD VALUE FOR IOPT'// +c 1 ' THE CURRENT ERROR MESSAGE FOLLOWS'///) + call uliber (4, ' SETER - BAD VALUE FOR IOPT', 80) + call uliber (4, ' SETER - THE CURRENT ERR MSG FOLLOWS', 80) +c -noao + GO TO 50 +C +C TEST FOR RECOVERY. +C + 40 CONTINUE + IF (IOPT.EQ.2) GO TO 50 +C + IF (I8SAV(2,0,.FALSE.).EQ.1) RETURN +C + CALL EPRIN + CALL FDUM +c STOP +C + 50 CALL EPRIN + 60 CALL FDUM +c STOP +C + END + SUBROUTINE EPRIN +C + CHARACTER*1 MESSG +C + CALL E9RIN(MESSG,1,.FALSE.) + RETURN +C + END + SUBROUTINE E9RIN(MESSG,NERR,SAVE) +C +C THIS ROUTINE STORES THE CURRENT ERROR MESSAGE OR PRINTS THE OLD ONE, +C IF ANY, DEPENDING ON WHETHER OR NOT SAVE = .TRUE. . +C + CHARACTER*(*) MESSG + CHARACTER*113 MESSGP + LOGICAL SAVE + COMMON /UERRF/IERF +C +C MESSGP STORES THE FIRST 113 CHARACTERS OF THE PREVIOUS MESSAGE +C +C +C START WITH NO PREVIOUS MESSAGE. +C +c+noao +c Moved save to before data statements. + SAVE MESSGP,NERRP +c-noao + DATA MESSGP/'1'/ + DATA NERRP/0/ +C + IF (.NOT.SAVE) GO TO 20 +C +C SAVE THE MESSAGE. +C + NERRP=NERR + MESSGP = MESSG +C + GO TO 30 +C + 20 IF (I8SAV(1,0,.FALSE.).EQ.0) GO TO 30 +C +C PRINT THE MESSAGE. +C +c +noao: FTN write rewritten as call to uliber +c WRITE(IERF,9000) NERRP,MESSGP +c9000 FORMAT(' ERROR ',I4,' IN ',A113) + call uliber (nerrp, messgp, 113) +C + 30 RETURN +C + END + INTEGER FUNCTION I8SAV(ISW,IVALUE,SET) +C +C IF (ISW = 1) I8SAV RETURNS THE CURRENT ERROR NUMBER AND +C SETS IT TO IVALUE IF SET = .TRUE. . +C +C IF (ISW = 2) I8SAV RETURNS THE CURRENT RECOVERY SWITCH AND +C SETS IT TO IVALUE IF SET = .TRUE. . +C + LOGICAL SET +C +C START EXECUTION ERROR FREE AND WITH RECOVERY TURNED OFF. +C +c+noao +c Moved save to before data statement. + SAVE LERROR,LRECOV + DATA LERROR/0/ , LRECOV/2/ +c-noao + IF (ISW .EQ. 1) THEN + I8SAV = LERROR + IF (SET) LERROR = IVALUE + ELSE IF (ISW .EQ. 2) THEN + I8SAV = LRECOV + IF (SET) LRECOV = IVALUE + ENDIF + RETURN + END + SUBROUTINE FDUM +C +C DUMMY ROUTINE TO BE LOCALLY IMPLEMENTED +C + RETURN + END +c +noao: Blockdata uerrbd rewritten as a runtime initialization subroutine +c BLOCKDATA UERRBD + subroutine uerrbd +c + COMMON /UERRF/IERF +C DEFAULT ERROR UNIT +c DATA IERF/0/ + IERF= 0 + END +c -noao diff --git a/sys/gio/nspp/sysint/fencode.x b/sys/gio/nspp/sysint/fencode.x new file mode 100644 index 00000000..fe3e37ed --- /dev/null +++ b/sys/gio/nspp/sysint/fencode.x @@ -0,0 +1,79 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +define SZ_FORMAT 11 + +# FENCD -- Format a real variable and return as a spp character string. +# A packed format string is passed as an input argument to define how the +# number is to be encoded. The format of the format string is: +# format string = "(cW.D)" +# where c is one of [EFGI], and where W and D are the field width and +# number of decimal places or precision, respectively. + +procedure fencd (nchars, f_format, spp_outstr, rval) + +int nchars # desired number of output chars +char f_format[SZ_FORMAT+1] # SPP string containing format +char spp_outstr[SZ_FORMAT+1] # SPP string containing encoded number +real rval # value to be encoded + +char fmtchar, outstr[MAX_DIGITS], spp_format[SZ_FORMAT+1] +int ip, op, stridx() +real x + +begin + # Encode format string for SPRINTF, format "%w.d". Start copying + # Fortran format at char 3, which should follow the EFGI char. + + spp_format[1] = '%' + op = 2 + + if (f_format[1] != '(') + call fatal (1, "Missing lparen in Ncar ENCODE format") + for (ip=3; f_format[ip] != ')' && f_format[ip] != EOS; ip=ip+1) { + spp_format[op] = f_format[ip] + op = op + 1 + } + + # Now add the SPP format character. EFG are the same for sprintf as + # as for Fortran. The integer format is 'd' for decimal in SPP. + + fmtchar = f_format[2] + if (IS_UPPER(fmtchar)) + fmtchar = TO_LOWER (fmtchar) + + switch (fmtchar) { + case 'e', 'f', 'g': + spp_format[op] = fmtchar + case 'i': + spp_format[op] = 'd' + default: + call fatal (1, "Unknown Ncar ENCODE format code") + } + op = op + 1 + spp_format[op] = EOS + x = rval + if (rval > 0) + x = -x + + # Now encode the user supplied variable and return it as a spp + # string. + + iferr { + call sprintf (outstr, MAX_DIGITS, spp_format) + call pargr (x) + } then + call erract (EA_FATAL) + + # Let's try adding a "+" prefix to positive numbers to set if that + # makes nicer plots. + + op = stridx ('-', outstr) + if (rval > 0 && op > 0) + outstr[op] = '+' + + call strcpy (outstr, spp_outstr, SZ_LINE) +end diff --git a/sys/gio/nspp/sysint/fulib.x b/sys/gio/nspp/sysint/fulib.x new file mode 100644 index 00000000..1951f26c --- /dev/null +++ b/sys/gio/nspp/sysint/fulib.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# FULIB -- Print an error message processed by fortran routine uliber. + +procedure fulib (errcode, upkmsg, msglen) + +int errcode +char upkmsg[ARB] # unpacked string +int msglen # number of chars in string + +pointer sp, sppmsg + +begin + call smark (sp) + call salloc (sppmsg, SZ_LINE, TY_CHAR) + + # Construct error message string + call sprintf (Memc[sppmsg], SZ_LINE, "ERROR %d IN %s\n") + call pargi (errcode) + call pargstr (upkmsg) + + # Call error with the constructed message + iferr (call error (errcode, Memc[sppmsg])) + call erract (EA_WARN) + + call sfree (sp) +end diff --git a/sys/gio/nspp/sysint/intt.x b/sys/gio/nspp/sysint/intt.x new file mode 100644 index 00000000..315248fd --- /dev/null +++ b/sys/gio/nspp/sysint/intt.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# INTT -- Test whether the argument is an integer (return true) or a real +# (return false). This works, hopefully, because legal NCAR metacode integers +# are always less than 2 ** 15, while real numbers will always appear to be +# large positive or negative integers. + +bool procedure intt (value) + +int value + +begin + return (value > 0 && value < INTT_TESTVAL) +end diff --git a/sys/gio/nspp/sysint/ishift.x b/sys/gio/nspp/sysint/ishift.x new file mode 100644 index 00000000..580996c0 --- /dev/null +++ b/sys/gio/nspp/sysint/ishift.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ISHIFT -- integer shift. To be used for calls to ISHIFT in NCAR routines. + +int procedure ishift (in_word, n) + +int in_word, n +int new_word, bit, index, i +int bitupk() + +begin + if (n > NBITS_INT) + call error (0, "n > NBITS_INT in ishift") + if (n < 0) + # Right end-off shift + new_word = bitupk (in_word, abs(n) + 1, NBITS_INT - abs(n)) + else { + # Left circular shift (rotate) + do i = 1, NBITS_INT { + index = n + i + if (index > NBITS_INT) + index = mod ((n + i), NBITS_INT) + bit = bitupk (in_word, i, 1) + call bitpak (bit, new_word, index, 1) + } + } + + return (new_word) +end + + +# IAND -- AND two integers. + +int procedure iand (a, b) + +int a, b +int and() + +begin + return (and (a, b)) +end + + +# IOR -- OR two integers. + +int procedure ior (a, b) + +int a, b +int or() + +begin + return (or (a, b)) +end diff --git a/sys/gio/nspp/sysint/loc.x b/sys/gio/nspp/sysint/loc.x new file mode 100644 index 00000000..59e509b5 --- /dev/null +++ b/sys/gio/nspp/sysint/loc.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# LOCI -- Return the zero-indexed offset of the argument in the user address +# space, in integer units. In other words, if A is an integer array, +# { loci(a[2]) - loci(a[1]) } is exactly one. +# +# NOTE -- The original NSPP (portlib) code called this function LOC, however, +# the Sun-4 Fortran compiler has an intrinsic function of the same name which +# behaves slightly differently, hence the name was changed to LOCI. + +int procedure loci (x) + +int x +int xaddr + +begin + # ZLOCVA returns the address of the variable in units of XCHAR. + + call zlocva (x, xaddr) + return (xaddr / SZ_INT) +end diff --git a/sys/gio/nspp/sysint/mcswap.x b/sys/gio/nspp/sysint/mcswap.x new file mode 100644 index 00000000..eb9cee7d --- /dev/null +++ b/sys/gio/nspp/sysint/mcswap.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# MCSWAP -- Swap the instructions in a metacode array. + +procedure mcswap (a, npix) + +int a[npix] +int npix +int i, temp + +begin + do i = 1, npix, 2 { + temp = a[i] + a[i] = a[i+1] + a[i+1] = temp + } +end diff --git a/sys/gio/nspp/sysint/mkpkg b/sys/gio/nspp/sysint/mkpkg new file mode 100644 index 00000000..b00eb46e --- /dev/null +++ b/sys/gio/nspp/sysint/mkpkg @@ -0,0 +1,24 @@ +# Make the system interface modules for libnspp.a. + +$checkout libnspp.a lib$ +$update libnspp.a +$checkin libnspp.a lib$ +$exit + +libnspp.a: + encd.f + encode.f + erprt77.f + fencode.x + fulib.x + intt.x + ishift.x + loc.x + mcswap.x + ncgchr.x + ncpchr.x + packum.x nspp.com + perror.x + q8qst4.f + uliber.f + ; diff --git a/sys/gio/nspp/sysint/ncgchr.x b/sys/gio/nspp/sysint/ncgchr.x new file mode 100644 index 00000000..5cf40b22 --- /dev/null +++ b/sys/gio/nspp/sysint/ncgchr.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# NCGCHR -- Get a single character (byte) from a packed array. Return +# a blank if the index is out of bounds. + +procedure ncgchr (ichars, len_ichars, index, char_value) + +int ichars[ARB] # packed character array +int len_ichars # length of the array +int index # index of char to be extracted +int char_value # return value + +char ch + +begin + if (index < 1 || index > len_ichars) + char_value = ' ' + else { + call chrupk (ichars, index, ch, 1, 1) + char_value = ch + } +end diff --git a/sys/gio/nspp/sysint/ncpchr.x b/sys/gio/nspp/sysint/ncpchr.x new file mode 100644 index 00000000..4312068d --- /dev/null +++ b/sys/gio/nspp/sysint/ncpchr.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# NCPCHR -- Put a single character (byte) into a packed array. Do nothing if +# the index is out of bounds. + +procedure ncpchr (ichars, len_ichars, index, char_value) + +int ichars[ARB] # packed character array +int len_ichars # length of the array +int index # index of char to be set +int char_value # value to be stored + +char ch[1] + +begin + if (index >= 1 && index <= len_ichars) { + ch[1] = char_value + call chrpak (ch, 1, ichars, index, 1) + } +end diff --git a/sys/gio/nspp/sysint/nspp.com b/sys/gio/nspp/sysint/nspp.com new file mode 100644 index 00000000..e3cac846 --- /dev/null +++ b/sys/gio/nspp/sysint/nspp.com @@ -0,0 +1,40 @@ +# NSPP.COM -- The nspp system plot package common block. + +int mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab +int mflg ,mtype ,mxa ,mya ,mxb ,myb +int mx ,my ,mtypex ,mtypey +real xxa ,yya , xxb ,yyb ,xxc ,yyc +real xxd ,yyd , xfactr ,yfactr ,xadd ,yadd +real xx ,yy + +# XX declared integer some places in nspp code !!! +# on a VAX this works, but what if float not same size as int ??? + +int mfmtx[3] ,mfmty[3] ,mumx ,mumy +int msizx ,msizy ,mxdec ,mydec ,mxor ,mop[19] +int mname[19] ,mxold ,myold ,mxmax ,mymax +int mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty +int mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst +int mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin +int mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto +int mxysto ,mprint ,msybuf[360] ,mncpw ,minst +int mbufa ,mbuflu ,mfwa[12] ,mlwa[12] +int mipair ,mbprs[16] ,mbufl ,munit ,mbswap + +real small + +common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab, + mflg ,mtype ,mxa ,mya ,mxb ,myb, + mx ,my ,mtypex ,mtypey ,xxa ,yya, + xxb ,yyb ,xxc ,yyc ,xxd ,yyd, + xfactr ,yfactr ,xadd ,yadd ,xx ,yy, + mfmtx ,mfmty ,mumx ,mumy, + msizx ,msizy ,mxdec ,mydec ,mxor ,mop, + mname ,mxold ,myold ,mxmax ,mymax, + mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty, + mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst, + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin, + mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto, + mxysto ,mprint ,msybuf ,mncpw ,minst, + mbufa ,mbuflu ,mfwa ,mlwa, + mipair ,mbprs ,mbufl ,munit ,mbswap ,small diff --git a/sys/gio/nspp/sysint/packum.x b/sys/gio/nspp/sysint/packum.x new file mode 100644 index 00000000..7991658c --- /dev/null +++ b/sys/gio/nspp/sysint/packum.x @@ -0,0 +1,43 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PACKUM -- Pack an integer array containing 16 bit quantities into a buffer. +# Each 16 bit input datum occupies one integer; the input integers may be +# any size. This implementation will work on most byte oriented machines, +# but will generate a fatal error on machines with 24, 60, etc. bit words. + +procedure packum (a, npix, bp) + +int a[ARB] # input array, one 16-bit datum per word +int npix # number of mc words +int bp # LOC pointer to output buffer + +int offset, dummy[1] +int loci() +include "nspp.com" + +begin + offset = bp - loci (dummy) + 1 + + # It is necessary to swap the order of the metacode words on some + # machines. Npix is always an even number. The swapping must be + # done here because the NSPP and MCTR code assumes that the bytes + # are ordered in a certain manner (most significant first). Thus, + # when the buffer is flushed FLUSHB will set the magic bits, and + # if we wait and swap upon output rather than here, it will set the + # bits in the wrong word. + + if (mbswap == YES) # flag set from graphcap in nsppkern + call mcswap (a, npix) + + switch (NBITS_MCWORD) { + case NBITS_SHORT: + call achtis (a, dummy[offset], npix) + case NBITS_INT: + call amovi (a, dummy[offset], npix) + default: + call fatal (1, "gio.ncar.packum: cannot pack metacode") + } +end diff --git a/sys/gio/nspp/sysint/perror.x b/sys/gio/nspp/sysint/perror.x new file mode 100644 index 00000000..6c1cb85b --- /dev/null +++ b/sys/gio/nspp/sysint/perror.x @@ -0,0 +1,9 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# PERROR -- Fatal error in NSPP. + +procedure perror() + +begin + call fatal (0, "Fatal error in Ncar system plot package") +end diff --git a/sys/gio/nspp/sysint/q8qst4.f b/sys/gio/nspp/sysint/q8qst4.f new file mode 100644 index 00000000..0b8ca796 --- /dev/null +++ b/sys/gio/nspp/sysint/q8qst4.f @@ -0,0 +1,24 @@ + SUBROUTINE Q8QST4(NAME,LBRARY,ENTRY,VRSION) +C +C DIMENSION OF NAME(1),LBRARY(1),ENTRY(1),VRSION(1) +C ARGUMENTS +C +C LATEST REVISION MARCH 1984 +C +C PURPOSE MONITORS LIBRARY USE BY WRITING A RECORD WITH +C INFORMATION ABOUT THE CIRCUMSTANCES OF A +C LIBRARY ROUTINE CALL TO THE SYSTEM ACCOUNTING +C TAPE FOR LATER PROCESSING. +C +C NOTE--- THIS VERSION OF Q8QST4 SIMPLY RETURNS TO THE +C CALLING ROUTINE. LOCAL IMPLEMENTORS MAY WISH +C TO IMPLEMENT A VERSION OF THIS ROUTINE THAT +C MONITORS USE OF NCAR ROUTINES WITH LOCAL +C MECHANISMS. OTHERWISE IT WILL SAVE A SMALL +C AMOUNT OF SPACE AND TIME IF CALLS TO Q8QST4 ARE +C DELETED FROM ALL NSSL ROUTINES. +C + CHARACTER*(*) NAME,LBRARY,ENTRY,VRSION +C + RETURN + END diff --git a/sys/gio/nspp/sysint/uliber.f b/sys/gio/nspp/sysint/uliber.f new file mode 100644 index 00000000..7dba302e --- /dev/null +++ b/sys/gio/nspp/sysint/uliber.f @@ -0,0 +1,14 @@ + subroutine uliber (errcode, pkerrmsg, msglen) + + character*80 pkerrmsg + integer errcode, msglen + integer*2 sppmsg(81) + integer SZLINE + parameter (SZLINE=80) + +c unpack the fortran character string, call fulib to output the string. +c + call f77upk (pkerrmsg, sppmsg, SZLINE) + call fulib (errcode, sppmsg, msglen) + + end diff --git a/sys/gio/nsppkern/README b/sys/gio/nsppkern/README new file mode 100644 index 00000000..0990eac0 --- /dev/null +++ b/sys/gio/nsppkern/README @@ -0,0 +1,399 @@ +This directory contains the source for the NSPP/GIO kernel, the interface +between GIO and the old Ncar system plot package and associated metacode +translators. + +Special graphcap entries used by this kernel: + + MF maximum frame count per metafile + FS frame advance req'd at start of metafile + FE frame advance req'd at end of metafile + +Rev 1.0 installed in March 1985. +---------------------------------------------------------------------------- + +Differences between Rev 1.0 and Rev 1.1 of the NSPP/GIO kernel. +Collated at installation of Rev 1.1 on 24 April 1985. +---------------------------------------------------------------------------- + +gktclose.x ++ diff gktclose.x ../nsppkern.old/gktclose.x +12,13d11 +< call frame +< call gkt_flush ++ echo gktclosews.x +gktinit.x ++ diff gktinit.x ../nsppkern.old/gktinit.x +49a50,59 +> # get the window offsets +> +> g_xoff = ttygeti (tty, "XO") +> if (g_xoff < 0) +> g_xoff = 0 +> g_yoff = ttygeti (tty, "YO") +> if (g_yoff < 0) +> g_yoff = 0 +> +> +112d121 +< GKT_PIXREP(g_kt) = btoi (ttygetb (tty, "pr")) +gktopenws.x ++ diff gktopenws.x ../nsppkern.old/gktopenws.x +98,104c98,99 +< if (mode == NEW_FILE) { +< # Frame call only if NEW_FILE and not first time open with +< # this device. This prevents frame before first data. +< if (!need_open) +< call frame +< call gkt_reset +< } +--- +> if (mode == NEW_FILE) +> call frame() ++ echo gktpcell.x +gktpcell.x ++ diff gktpcell.x ../nsppkern.old/gktpcell.x +8a9 +> +12c13 +< procedure gkt_putcellarray (m, nc, nr, ax1,ay1, ax2,ay2) +--- +> procedure gkt_putcellarray (m, nc, nr, x1,y1, x2,y2) +17,18c18,19 +< int ax1, ay1 # lower left corner of output window +< int ax2, ay2 # upper right corner of output window +--- +> int x1, y1 # lower left corner of output window +> int x2, y2 # upper right corner of output window +20d20 +< int x1,y1,x2,y2 # device coordinates +22c22 +< int nx, ny, y +--- +> int nx, ny +28c28 +< bool ca, use_orig, new_row, pr +--- +> bool ca, use_orig, new_row +31,32d30 +< real delta_y +< int xrep, yrep +43c41 +< # Determine if can do real cell array. If not, use character +--- +> # determine if can do real cell array. If not, use character +49d46 +< pr = false +53d49 +< pr = (GKT_PIXREP(g_kt) != 0) +65,66c61 +< # Input arguments (ax, ay) refer to corners of put cell array; +< # we need corners of the corresponding device array. +--- +> # find out how many real pixels we have to fill +68,73c63,66 +< x1 = ax1 +< x2 = ax2 +< y1 = ay1 +< y2 = ay2 +< call adjust(x1,x2,xres) +< call adjust(y1,y2,yres) +--- +> px1 = real(x1)/GKI_MAXNDC +> py1 = real(y1)/GKI_MAXNDC +> px2 = real(x2)/GKI_MAXNDC +> py2 = real(y2)/GKI_MAXNDC +75,79c68,69 +< # Find out how many real pixels we have to fill +< px1 = real(x1)/(GKI_MAXNDC+1) +< py1 = real(y1)/(GKI_MAXNDC+1) +< px2 = real(x2)/(GKI_MAXNDC+1) +< py2 = real(y2)/(GKI_MAXNDC+1) +--- +> nx = int( (px2 - px1) * (xres-1.0) + 1.5 ) +> ny = int( (py2 - py1) * (yres-1.0) + 1.5 ) +81,90c71 +< nx = int( px2 * xres ) - int( px1 * xres ) + 1 +< ny = int( py2 * yres ) - int( py1 * yres ) + 1 +< +< if ( ny > 1) +< delta_y = (real(y2) - real(y1))/ny +< else { +< delta_y = 0. +< } +< +< # If too many data points in input, set skip. If skip is close +--- +> # if too many data points in input, set skip. If skip is close +92,93c73,74 +< # Set block replication factors - will be > 1.0 if too few input points. +< # Cannot set to 1.0 if "close" enough, since, if > 1.0, we don't have +--- +> # set block replication factors - will be > 1.0 if too few input points. +> # cannot set to 1.0 if "close" enough, since, if > 1.0, we don't have +110c91,101 +< # Allocate storage for a row of pixels. This is quite inefficient +--- +> +> # try for the simplest case: 1:1 match with input data +> +> if ( ca && (nx == nc) && (ny == nr) ) { +> call pixels( real(x1)/GKI_MAXNDC, real(y1)/GKI_MAXNDC, +> nx, ny, m) +> call sfree(sp) +> return +> } +> +> # allocate storage for a row of pixels. This is quite inefficient +113d103 +< # need nx+1 in case nx odd ... pixels() wants to pad output. +115,116c105 +< call salloc ( cell, nx+1, TY_SHORT) +< Mems[cell + nx] = 0 +--- +> call salloc ( cell, nx, TY_SHORT) +118c107 +< # Initialize counters +--- +> # initialize counters +125c114 +< # See if we can use original data ... no massaging +--- +> # see if we can use original data ... no massaging +128c117 +< # Note that if blockx > 1.0, skip_x must be 1.0, and vv +--- +> # note that if blockx > 1.0, skip_x must be 1.0, and vv +138,152c127 +< # If device can pixel replicate, use that feature where we can +< if( pr) { +< if( (skip_x == 1.0) && ( int(blockx) == blockx) ) { +< xrep = int(blockx) +< use_orig = true +< nx = nc +< } else +< xrep = 1 +< if( (skip_y == 1.0) && ( int(blocky) == blocky) ) { +< yrep = int(blocky) +< ny = 1 +< } else +< yrep = 1 +< } +< call pixel0(1,0,xrep,0,1,yrep) +--- +> # do it +154c129 +< # Do it +--- +> for (i = 1; i <= ny; i = i + 1) { +156c131 +< for ( i = 1; i <= ny ; i = i + 1) { +--- +> # Build the row data. +158,159d132 +< # Build the row data +< +161c134 +< if ( skip_x == 1.0) { +--- +> if ( skip_x == 1.0) +163c136 +< } else { +--- +> else { +181d153 +< y = y1 + ((i - 1)*delta_y + 0.5) +183,184c155,159 +< call pixels( px1, real(y)/GKI_MAXNDC, +< nx, 1, m[element]) +--- +> if ( i == 1 ) +> call pixelr( real(x1)/GKI_MAXNDC, real(y1)/GKI_MAXNDC, +> nx, ny, m[element]) +> else +> call pixeli( 0., 0., nx, 1, m[element]) +186c161,165 +< call pixels( px1, real(y)/GKI_MAXNDC, nx, 1, Mems[cell]) +--- +> if ( i == 1 ) +> call pixelr( real(x1)/GKI_MAXNDC, real(y1)/GKI_MAXNDC, +> nx, ny, Mems[cell]) +> else +> call pixeli( 0., 0., nx, 1, Mems[cell]) +188,189c167 +< } +< else +--- +> } else +192c170 +< # Advance a row +--- +> # Advance a row. +206c184 +< # All done, restore text parameters and release storage +--- +> # all done, restore text parameters and release storage +209c187 +< call restoretx (txsave,tx) +--- +> call restoretx(txsave,tx) +212a191 +> +218d196 +< pointer savep, txp +219a198 +> pointer savep, txp +254a234 +> +258d237 +< pointer savep, txp +259a239 +> pointer savep, txp +263c243 +< # Restore values +--- +> # restore values +283a264 +> +287c268,269 +< procedure fakepc (indata, outdata, nx, scale) +--- +> procedure fakepc( indata, outdata, nx, scale) +> +298c280 +< data cdata /' ', '.', ':', '|', 'i', 'l', 'J', 'm', '#', 'S', 'B', EOS/ +--- +> data cdata /' ', '.', ':', '|', 'i', 'l', 'J', 'm', '#', 'S', 'B', EOS/ +330,374d311 +< end +< +< # ADJUST -- round/truncate putcell array corners to device coordinates +< # move up lower bound if it is above center point of device cell, +< # move down upper bound if below. Don't allow bounds to go beyond +< # resolution or below zero. Do not allow bounds to cross. Part of the +< # assumptions behind all this is that putcells will be continguous and +< # rows/columns must not be plotted twice. +< +< procedure adjust ( lower, upper, res) +< +< int lower, upper +< real res +< +< real factor +< real low, up +< +< begin +< factor = res/(GKI_MAXNDC+1) +< low = real(lower) * factor +< up = real(upper) * factor +< +< # if boundaries result in same row, return +< if ( int(low) == int(up) ) +< return +< +< # if low is in upper half of device pixel, round up +< if ( (low - int(low)) >= 0.5 ) { +< low = int(low) + 1 +< # don't go to or beyond upper bound +< if ( low < up ) { +< # ... 0.2 just for "rounding protection"; +< lower = (low + 0.2)/factor +< # if now reference same cell, return +< if ( int(low) == int(up) ) +< return +< } +< } +< +< # if "up" in bottom half of pixel, drop down one. Note that +< # due to two "==" tests above, upper will not drop below lower. +< # 0.2 means drop partway down into pixel below; calling code will +< # truncate. +< if ( (up - int(up)) < 0.5 ) +< upper = real(int(up) - 0.2)/factor ++ echo gktpl.x +gktpl.x ++ diff gktpl.x ../nsppkern.old/gktpl.x +51,52c51,52 +< x = p[1] +< y = p[2] +--- +> x = p[1] + g_xoff +> y = p[2] + g_yoff +58,59c58,59 +< x = p[i] +< y = p[i+1] +--- +> x = p[i] + g_xoff +> y = p[i+1] + g_yoff +gktpm.x ++ diff gktpm.x ../nsppkern.old/gktpm.x +48,49c48,49 +< x = p[1] +< y = p[2] +--- +> x = p[1] + g_xoff +> y = p[2] + g_yoff +63,64c63,64 +< x = p[i] +< y = p[i+1] +--- +> x = p[i] + g_xoff +> y = p[i+1] + g_yoff ++ echo gktpmset.x +gkttx.x ++ diff gkttx.x ../nsppkern.old/gkttx.x +109,110c109,110 +< call pwrity (real(x)/GKI_MAXNDC, +< real(y)/GKI_MAXNDC, Memc[pstring], seglen, +--- +> call pwrity (real(x+g_xoff)/GKI_MAXNDC, +> real(y+g_yoff)/GKI_MAXNDC, Memc[pstring], seglen, +_____________________________________________________________________________ + +25Apr85 gktpl.x + Call to optn to set line width changed to set option "inten" instead + of "spot size", which was not changing the line width. + +26Apr85 gktpm.x + Same change as one to gktpl.x + + Character size as used in gkttx.x is a floating point number, but + NCAR pwry.f uses an integer value -- the conversion was causing + centering errors as gkttx.x would calculate a "path length" for + the text based on one size, and pwry.f would use a different size + to generate the text. Changed pwry.f to use a floating point + size as an input variable, changed gkttx.x to send same. + + gktpcell.x + Moved pixel0 call inside the "if (pr) {" statment, where it should + have been. + + graphcap + Added "pr" capablility flag to dicomed entry. Changed character + height to reflect the 9 to 8 ratio that pwry uses. + + +--------------------------------------------------------------------------- +Rev 1.2 10 May 1985 Dct. + +Fairly extensive modifications made to minimize the number of frame calls +and metafiles generated. Redundant CLEAR calls or clear calls immediately +after open workstation are ignored. Multiple frames are permitted in a +metafile (formerly the metafile was disposed after each frame). Graphcap +parameters were added to control automatic frame advances at the beginning +and end of metafiles. + +--------------------------------------------------------------------------- +Rev 1.3 1 June 1985 Dct. + +[1] Fixed a bug in polymarker; was drawing polylines. + +[2] Replaced the old character generation code by all new code, using the stroke +table from the NCAR/GKS code. Replaced "pwry.f" by the much simpler +"gktdrawch.x". Largely copied the stdgraph "stgtx.x", including the clipping +logic therein. + +17-Aug-85 Dct. + Added support for the new DD graphcap parameter, used to pass device + dependent information to the device driver. This information was + formerly encoded in a table at compile time, with the table defined + in . diff --git a/sys/gio/nsppkern/font.com b/sys/gio/nsppkern/font.com new file mode 100644 index 00000000..ec1b0ec9 --- /dev/null +++ b/sys/gio/nsppkern/font.com @@ -0,0 +1,207 @@ +# CHRTAB -- Table of strokes for the printable ASCII characters. Each character +# is encoded as a series of strokes. Each stroke is expressed by a single +# integer containing the following bitfields: +# +# 2 1 +# 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 +# | | | | | | | +# | | | +---------+ +---------+ +# | | | | | +# | | | X Y +# | | | +# | | +-- pen up/down +# | +---- begin paint (not used at present) +# +------ end paint (not used at present) +# +#------------------------------------------------------------------------------ + +# Define the database. + +short chridx[96] # character index in chrtab +short chrtab[800] # stroke data to draw the characters + +# Index into CHRTAB of each printable character (starting with SP). + +data (chridx(i), i=01,05) / 1, 3, 12, 21, 30/ +data (chridx(i), i=06,10) / 45, 66, 79, 85, 92/ +data (chridx(i), i=11,15) / 99, 106, 111, 118, 121/ +data (chridx(i), i=16,20) / 128, 131, 141, 145, 154/ +data (chridx(i), i=21,25) / 168, 177, 187, 199, 203/ +data (chridx(i), i=26,30) / 221, 233, 246, 259, 263/ +data (chridx(i), i=31,35) / 268, 272, 287, 307, 314/ +data (chridx(i), i=36,40) / 327, 336, 344, 352, 359/ +data (chridx(i), i=41,45) / 371, 378, 385, 391, 398/ +data (chridx(i), i=46,50) / 402, 408, 413, 425, 433/ +data (chridx(i), i=51,55) / 445, 455, 468, 473, 480/ +data (chridx(i), i=56,60) / 484, 490, 495, 501, 506/ +data (chridx(i), i=61,65) / 511, 514, 519, 523, 526/ +data (chridx(i), i=66,70) / 529, 543, 554, 563, 574/ +data (chridx(i), i=71,75) / 585, 593, 607, 615, 625/ +data (chridx(i), i=76,80) / 638, 645, 650, 663, 671/ +data (chridx(i), i=81,85) / 681, 692, 703, 710, 723/ +data (chridx(i), i=86,90) / 731, 739, 743, 749, 754/ +data (chridx(i), i=91,95) / 759, 764, 776, 781, 793/ +data (chridx(i), i=96,96) / 801/ + +# Stroke data. + +data (chrtab(i), i=001,005) / 36, 1764, 675, 29328, 585/ +data (chrtab(i), i=006,010) / 21063, 21191, 21193, 21065, 29383/ +data (chrtab(i), i=011,015) / 1764, 355, 29023, 351, 29027/ +data (chrtab(i), i=016,020) / 931, 29599, 927, 29603, 1764/ +data (chrtab(i), i=021,025) / 603, 29066, 842, 29723, 1302/ +data (chrtab(i), i=026,030) / 28886, 143, 29839, 1764, 611/ +data (chrtab(i), i=031,035) / 29256, 78, 20810, 21322, 21581/ +data (chrtab(i), i=036,040) / 21586, 21334, 20822, 20569, 20573/ +data (chrtab(i), i=041,045) / 20833, 21345, 29789, 1764, 419/ +data (chrtab(i), i=046,050) / 20707, 20577, 20574, 20700, 20892/ +data (chrtab(i), i=051,055) / 21022, 21025, 20899, 1187, 28744/ +data (chrtab(i), i=056,060) / 717, 21194, 21320, 21512, 21642/ +data (chrtab(i), i=061,065) / 21645, 21519, 21327, 21197, 1764/ +data (chrtab(i), i=066,070) / 1160, 20700, 20704, 20835, 21027/ +data (chrtab(i), i=071,075) / 21152, 21149, 20561, 20556, 20744/ +data (chrtab(i), i=076,080) / 21192, 29841, 1764, 611, 21023/ +data (chrtab(i), i=081,085) / 21087, 21155, 21091, 1764, 739/ +data (chrtab(i), i=086,090) / 21087, 21018, 21009, 21068, 29384/ +data (chrtab(i), i=091,095) / 1764, 547, 21151, 21210, 21201/ +data (chrtab(i), i=096,100) / 21132, 29192, 1764, 93, 29774/ +data (chrtab(i), i=101,105) / 608, 29259, 78, 29789, 1764/ +data (chrtab(i), i=106,110) / 604, 29260, 84, 29780, 1764/ +data (chrtab(i), i=111,115) / 516, 21062, 21065, 21001, 21000/ +data (chrtab(i), i=116,120) / 21064, 1764, 84, 29780, 1764/ +data (chrtab(i), i=121,125) / 585, 21063, 21191, 21193, 21065/ +data (chrtab(i), i=126,130) / 21191, 1764, 72, 29859, 1764/ +data (chrtab(i), i=131,135) / 419, 20573, 20558, 20872, 21320/ +data (chrtab(i), i=136,140) / 21646, 21661, 21347, 20899, 1764/ +data (chrtab(i), i=141,145) / 221, 21155, 29320, 1764, 95/ +data (chrtab(i), i=146,150) / 20835, 21411, 21663, 21655, 20556/ +data (chrtab(i), i=151,155) / 20552, 29832, 1764, 95, 20899/ +data (chrtab(i), i=156,160) / 21347, 21663, 21658, 21334, 29270/ +data (chrtab(i), i=161,165) / 854, 5266, 21644, 21320, 20872/ +data (chrtab(i), i=166,170) / 28749, 1764, 904, 21411, 21283/ +data (chrtab(i), i=171,175) / 20561, 20559, 21391, 911, 13455/ +data (chrtab(i), i=176,180) / 1764, 136, 21320, 21645, 21652/ +data (chrtab(i), i=181,185) / 21337, 20889, 20565, 20579, 29859/ +data (chrtab(i), i=186,190) / 1764, 83, 20888, 21336, 21651/ +data (chrtab(i), i=191,195) / 21645, 21320, 20872, 20557, 20563/ +data (chrtab(i), i=196,200) / 20635, 29347, 1764, 99, 21667/ +data (chrtab(i), i=201,205) / 29064, 1764, 355, 20575, 20570/ +data (chrtab(i), i=206,210) / 20822, 20562, 20556, 20808, 21384/ +data (chrtab(i), i=211,215) / 21644, 21650, 21398, 20822, 918/ +data (chrtab(i), i=216,220) / 5274, 21663, 21411, 20835, 1764/ +data (chrtab(i), i=221,225) / 648, 21584, 21656, 21662, 21347/ +data (chrtab(i), i=226,230) / 20899, 20574, 20568, 20883, 21331/ +data (chrtab(i), i=231,235) / 21656, 1764, 602, 21210, 21207/ +data (chrtab(i), i=236,240) / 21079, 21082, 21207, 592, 21069/ +data (chrtab(i), i=241,245) / 21197, 21200, 21072, 21197, 1764/ +data (chrtab(i), i=246,250) / 602, 21146, 21143, 21079, 21082/ +data (chrtab(i), i=251,255) / 21143, 585, 21132, 21136, 21072/ +data (chrtab(i), i=256,260) / 21071, 21135, 1764, 988, 20628/ +data (chrtab(i), i=261,265) / 29644, 1764, 1112, 28824, 144/ +data (chrtab(i), i=266,270) / 29776, 1764, 156, 21460, 28812/ +data (chrtab(i), i=271,275) / 1764, 221, 20704, 20899, 21218/ +data (chrtab(i), i=276,280) / 21471, 21466, 21011, 21007, 521/ +data (chrtab(i), i=281,285) / 20999, 21127, 21129, 21001, 21127/ +data (chrtab(i), i=286,290) / 1764, 908, 20812, 20560, 20571/ +data (chrtab(i), i=291,295) / 20831, 21407, 21659, 21651, 21521/ +data (chrtab(i), i=296,300) / 21393, 21331, 21335, 21210, 21018/ +data (chrtab(i), i=301,305) / 20887, 20883, 21009, 21201, 21331/ +data (chrtab(i), i=306,310) / 1764, 72, 20963, 21219, 29768/ +data (chrtab(i), i=311,315) / 210, 5074, 1764, 99, 21411/ +data (chrtab(i), i=316,320) / 21663, 21658, 21398, 20566, 918/ +data (chrtab(i), i=321,325) / 5266, 21644, 21384, 20552, 20579/ +data (chrtab(i), i=326,330) / 1764, 1165, 21320, 20872, 20557/ +data (chrtab(i), i=331,335) / 20574, 20899, 21347, 29854, 1764/ +data (chrtab(i), i=336,340) / 99, 21347, 21662, 21645, 21320/ +data (chrtab(i), i=341,345) / 20552, 20579, 1764, 99, 20552/ +data (chrtab(i), i=346,350) / 29832, 86, 13078, 99, 29859/ +data (chrtab(i), i=351,355) / 1764, 99, 20552, 86, 13078/ +data (chrtab(i), i=356,360) / 99, 29859, 1764, 722, 21650/ +data (chrtab(i), i=361,365) / 29832, 1165, 4936, 20872, 20557/ +data (chrtab(i), i=366,370) / 20574, 20899, 21347, 29854, 1764/ +data (chrtab(i), i=371,375) / 99, 28744, 85, 5269, 1160/ +data (chrtab(i), i=376,380) / 29859, 1764, 291, 29603, 611/ +data (chrtab(i), i=381,385) / 4680, 328, 29576, 1764, 77/ +data (chrtab(i), i=386,390) / 20872, 21256, 21581, 29795, 1764/ +data (chrtab(i), i=391,395) / 99, 28744, 1160, 20887, 82/ +data (chrtab(i), i=396,400) / 13475, 1764, 99, 20552, 29832/ +data (chrtab(i), i=401,405) / 1764, 72, 20579, 21077, 21603/ +data (chrtab(i), i=406,410) / 29768, 1764, 72, 20579, 21640/ +data (chrtab(i), i=411,415) / 29859, 1764, 94, 20899, 21347/ +data (chrtab(i), i=416,420) / 21662, 21645, 21320, 20872, 20557/ +data (chrtab(i), i=421,425) / 20574, 862, 29859, 1764, 72/ +data (chrtab(i), i=426,430) / 20579, 21411, 21663, 21656, 21396/ +data (chrtab(i), i=431,435) / 20564, 1764, 94, 20557, 20872/ +data (chrtab(i), i=436,440) / 21320, 21645, 21662, 21347, 20899/ +data (chrtab(i), i=441,445) / 20574, 536, 29828, 1764, 72/ +data (chrtab(i), i=446,450) / 20579, 21411, 21663, 21657, 21398/ +data (chrtab(i), i=451,455) / 20566, 918, 13448, 1764, 76/ +data (chrtab(i), i=456,460) / 20808, 21384, 21644, 21649, 21397/ +data (chrtab(i), i=461,465) / 20822, 20570, 20575, 20835, 21411/ +data (chrtab(i), i=466,470) / 29855, 1764, 648, 21155, 99/ +data (chrtab(i), i=471,475) / 29923, 1764, 99, 20557, 20872/ +data (chrtab(i), i=476,480) / 21320, 21645, 29859, 1764, 99/ +data (chrtab(i), i=481,485) / 21064, 29795, 1764, 99, 20808/ +data (chrtab(i), i=486,490) / 21141, 21448, 29923, 1764, 99/ +data (chrtab(i), i=491,495) / 29832, 72, 29859, 1764, 99/ +data (chrtab(i), i=496,500) / 21079, 29256, 599, 13411, 1764/ +data (chrtab(i), i=501,505) / 99, 21667, 20552, 29832, 1764/ +data (chrtab(i), i=506,510) / 805, 20965, 20935, 29447, 1764/ +data (chrtab(i), i=511,515) / 99, 29832, 1764, 421, 21221/ +data (chrtab(i), i=516,520) / 21191, 29063, 1764, 288, 21091/ +data (chrtab(i), i=521,525) / 29600, 1764, 3, 29891, 1764/ +data (chrtab(i), i=526,530) / 547, 29341, 1764, 279, 21207/ +data (chrtab(i), i=531,535) / 21396, 21387, 21127, 20807, 20555/ +data (chrtab(i), i=536,540) / 20558, 20753, 21201, 21391, 907/ +data (chrtab(i), i=541,545) / 13447, 1764, 99, 28744, 76/ +data (chrtab(i), i=546,550) / 4424, 21256, 21516, 21523, 21271/ +data (chrtab(i), i=551,555) / 20823, 20563, 1764, 981, 21271/ +data (chrtab(i), i=556,560) / 20823, 20563, 20556, 20808, 21256/ +data (chrtab(i), i=561,565) / 29642, 1764, 1043, 4887, 20823/ +data (chrtab(i), i=566,570) / 20563, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=571,575) / 1032, 29731, 1764, 80, 5136/ +data (chrtab(i), i=576,580) / 21523, 21271, 20823, 20563, 20556/ +data (chrtab(i), i=581,585) / 20808, 21256, 29707, 1764, 215/ +data (chrtab(i), i=586,590) / 29591, 456, 20958, 21153, 21409/ +data (chrtab(i), i=591,595) / 29727, 1764, 67, 20800, 21248/ +data (chrtab(i), i=596,600) / 21508, 29719, 1043, 21271, 20823/ +data (chrtab(i), i=601,605) / 20563, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=606,610) / 1764, 99, 28744, 83, 4439/ +data (chrtab(i), i=611,615) / 21271, 21523, 29704, 1764, 541/ +data (chrtab(i), i=616,620) / 21019, 21147, 21149, 21021, 21147/ +data (chrtab(i), i=621,625) / 533, 21077, 29256, 1764, 541/ +data (chrtab(i), i=626,630) / 21019, 21147, 21149, 21021, 21147/ +data (chrtab(i), i=631,635) / 533, 21077, 21058, 20928, 20736/ +data (chrtab(i), i=636,640) / 28802, 1764, 99, 28744, 84/ +data (chrtab(i), i=641,645) / 29530, 342, 13320, 1764, 483/ +data (chrtab(i), i=646,650) / 21089, 21066, 29384, 1764, 87/ +data (chrtab(i), i=651,655) / 28744, 584, 21076, 84, 4375/ +data (chrtab(i), i=656,660) / 20951, 21076, 21207, 21399, 21588/ +data (chrtab(i), i=661,665) / 29768, 1764, 87, 28744, 83/ +data (chrtab(i), i=666,670) / 20823, 21271, 21523, 29704, 1764/ +data (chrtab(i), i=671,675) / 83, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=676,680) / 21523, 21271, 20823, 20563, 1764/ +data (chrtab(i), i=681,685) / 87, 28736, 83, 20823, 21271/ +data (chrtab(i), i=686,690) / 21523, 21516, 21256, 20808, 20556/ +data (chrtab(i), i=691,695) / 1764, 1047, 29696, 1036, 21256/ +data (chrtab(i), i=696,700) / 20808, 20556, 20563, 20823, 21271/ +data (chrtab(i), i=701,705) / 21523, 1764, 87, 28744, 83/ +data (chrtab(i), i=706,710) / 20823, 21271, 29716, 1764, 74/ +data (chrtab(i), i=711,715) / 20808, 21256, 21514, 21518, 21264/ +data (chrtab(i), i=716,720) / 20816, 20562, 20565, 20823, 21271/ +data (chrtab(i), i=721,725) / 21461, 1764, 279, 29591, 970/ +data (chrtab(i), i=726,730) / 21320, 21128, 21002, 21025, 1764/ +data (chrtab(i), i=731,735) / 87, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=736,740) / 1032, 29719, 1764, 151, 21064/ +data (chrtab(i), i=741,745) / 29719, 1764, 87, 20808, 21077/ +data (chrtab(i), i=746,750) / 21320, 29783, 1764, 151, 29704/ +data (chrtab(i), i=751,755) / 136, 29719, 1764, 87, 21064/ +data (chrtab(i), i=756,760) / 320, 29783, 1764, 151, 21527/ +data (chrtab(i), i=761,765) / 20616, 29704, 1764, 805, 21157/ +data (chrtab(i), i=766,770) / 21026, 21017, 20951, 20822, 20949/ +data (chrtab(i), i=771,775) / 21011, 21001, 21127, 21255, 1764/ +data (chrtab(i), i=776,780) / 611, 29273, 594, 29256, 1764/ +data (chrtab(i), i=781,785) / 485, 21093, 21218, 21209, 21271/ +data (chrtab(i), i=786,790) / 21398, 21269, 21203, 21193, 21063/ +data (chrtab(i), i=791,795) / 29127, 1764, 83, 20758, 20950/ +data (chrtab(i), i=796,800) / 21265, 21457, 29844, 1764, 0/ diff --git a/sys/gio/nsppkern/font.h b/sys/gio/nsppkern/font.h new file mode 100644 index 00000000..c33dc6ee --- /dev/null +++ b/sys/gio/nsppkern/font.h @@ -0,0 +1,29 @@ +# NCAR font definitions. + +define CHARACTER_START 32 +define CHARACTER_END 126 +define CHARACTER_HEIGHT 26 +define CHARACTER_WIDTH 17 + +define FONT_LEFT 0 +define FONT_CENTER 9 +define FONT_RIGHT 27 +define FONT_TOP 36 +define FONT_CAP 34 +define FONT_HALF 23 +define FONT_BASE 9 +define FONT_BOTTOM 0 +define FONT_WIDTH 27 +define FONT_HEIGHT 36 + +define COORD_X_START 7 +define COORD_Y_START 1 +define COORD_PEN_START 13 +define COORD_X_LEN 6 +define COORD_Y_LEN 6 +define COORD_PEN_LEN 1 + +define PAINT_BEGIN_START 14 +define PAINT_END_START 15 +define PAINT_BEGIN_LEN 1 +define PAINT_END_LEN 1 diff --git a/sys/gio/nsppkern/gkt.com b/sys/gio/nsppkern/gkt.com new file mode 100644 index 00000000..828b39bb --- /dev/null +++ b/sys/gio/nsppkern/gkt.com @@ -0,0 +1,17 @@ +# GKTRANS common. A common is necessary since there is no graphics descriptor +# in the argument list of the kernel procedures. The stdgraph data structures +# are designed along the lines of FIO: a small common is used to hold the time +# critical data elements, and an auxiliary dynamically allocated descriptor is +# used for everything else. + +pointer g_kt # kernel transform graphics descriptor +pointer g_tty # graphcap descriptor +int g_nframes # number of frames written +int g_maxframes # max frames per device metafile +int g_ndraw # no draw instr. in current frame +int g_in, g_out # input, output files +int g_xres, g_yres # desired device resolution +char g_device[SZ_GDEVICE] # force output to named device + +common /gktcom/ g_kt, g_tty, g_nframes, g_maxframes, g_ndraw, + g_in, g_out, g_xres, g_yres, g_device diff --git a/sys/gio/nsppkern/gkt.h b/sys/gio/nsppkern/gkt.h new file mode 100644 index 00000000..09ab7b80 --- /dev/null +++ b/sys/gio/nsppkern/gkt.h @@ -0,0 +1,75 @@ +# GKTRANS definitions. + +define MAX_CHARSIZES 10 # max discreet device char sizes +define SZ_SBUF 1024 # initial string buffer size +define SZ_MFRECORD (1440/SZB_CHAR) # metafile record size +define SZ_GDEVICE 31 # maxsize forced device name +define DEF_MAXFRAMES 16 # maximum frames/metafile + +# The GKTRANS state/device descriptor. + +define LEN_GKT 81 + +define GKT_SBUF Memi[$1] # string buffer +define GKT_SZSBUF Memi[$1+1] # size of string buffer +define GKT_NEXTCH Memi[$1+2] # next char pos in string buf +define GKT_NCHARSIZES Memi[$1+3] # number of character sizes +define GKT_POLYLINE Memi[$1+4] # device supports polyline +define GKT_POLYMARKER Memi[$1+5] # device supports polymarker +define GKT_FILLAREA Memi[$1+6] # device supports fillarea +define GKT_CELLARRAY Memi[$1+7] # device supports cell array +define GKT_ZRES Memi[$1+8] # device resolution in Z +define GKT_FILLSTYLE Memi[$1+9] # number of fill styles +define GKT_ROAM Memi[$1+10] # device supports roam +define GKT_ZOOM Memi[$1+11] # device supports zoom +define GKT_SELERASE Memi[$1+12] # device has selective erase +define GKT_PIXREP Memi[$1+13] # device supports pixel replic. +define GKT_STARTFRAME Memi[$1+14] # frame advance at metafile BOF +define GKT_ENDFRAME Memi[$1+15] # frame advance at metafile EOF + # extra space +define GKT_CURSOR Memi[$1+20] # last cursor accessed +define GKT_COLOR Memi[$1+21] # last color set +define GKT_TXSIZE Memi[$1+22] # last text size set +define GKT_TXFONT Memi[$1+23] # last text font set +define GKT_TYPE Memi[$1+24] # last line type set +define GKT_WIDTH Memi[$1+25] # last line width set +define GKT_DEVNAME Memi[$1+26] # name of open device + # extra space +define GKT_CHARHEIGHT Memi[$1+30+$2-1] # character height +define GKT_CHARWIDTH Memi[$1+40+$2-1] # character width +define GKT_CHARSIZE Memr[P2R($1+50+$2-1)] # text sizes permitted +define GKT_PLAP ($1+60) # polyline attributes +define GKT_PMAP ($1+64) # polymarker attributes +define GKT_FAAP ($1+68) # fill area attributes +define GKT_TXAP ($1+71) # default text attributes + +# Substructure definitions. + +define LEN_PL 4 +define PL_STATE Memi[$1] # polyline attributes +define PL_LTYPE Memi[$1+1] +define PL_WIDTH Memi[$1+2] +define PL_COLOR Memi[$1+3] + +define LEN_PM 4 +define PM_STATE Memi[$1] # polymarker attributes +define PM_LTYPE Memi[$1+1] +define PM_WIDTH Memi[$1+2] +define PM_COLOR Memi[$1+3] + +define LEN_FA 3 # fill area attributes +define FA_STATE Memi[$1] +define FA_STYLE Memi[$1+1] +define FA_COLOR Memi[$1+2] + +define LEN_TX 10 # text attributes +define TX_STATE Memi[$1] +define TX_UP Memi[$1+1] +define TX_SIZE Memi[$1+2] +define TX_PATH Memi[$1+3] +define TX_SPACING Memr[P2R($1+4)] +define TX_HJUSTIFY Memi[$1+5] +define TX_VJUSTIFY Memi[$1+6] +define TX_FONT Memi[$1+7] +define TX_QUALITY Memi[$1+8] +define TX_COLOR Memi[$1+9] diff --git a/sys/gio/nsppkern/gktcancel.x b/sys/gio/nsppkern/gktcancel.x new file mode 100644 index 00000000..17679f89 --- /dev/null +++ b/sys/gio/nsppkern/gktcancel.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gkt.h" + +# GKT_CANCEL -- Cancel any buffered output. + +procedure gkt_cancel (dummy) + +int dummy # not used at present +include "gkt.com" + +begin + if (g_kt == NULL) + return + + # First we cancel any output in the FIO stream, then + # flush the nspp buffers. This might, of course, + # put something in the FIO stream, so we cancel again. + # note the Fortran escape for "flush"...spp has a reserved + # word of the same name. + + call fseti (g_out, F_CANCEL, OK) +% call mcflsh + call fseti (g_out, F_CANCEL, OK) + call gkt_reset() +end diff --git a/sys/gio/nsppkern/gktclear.x b/sys/gio/nsppkern/gktclear.x new file mode 100644 index 00000000..4132d371 --- /dev/null +++ b/sys/gio/nsppkern/gktclear.x @@ -0,0 +1,60 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gkt.h" + +# GKT_CLEAR -- Advance a frame on the plotter. All attribute packets are +# initialized to their default values. Redundant calls or calls immediately +# after a workstation open (before anything has been drawn) are ignored. + +procedure gkt_clear (dummy) + +int dummy # not used at present + +int gkt_mfopen() +errchk gkt_mfopen +include "gkt.com" + +begin + # This is a no-op if nothing has been drawn. + if (g_kt == NULL || g_ndraw == 0) + return + + # Start a new frame. This is done either by calling NSPP to do a frame + # advance or by starting a new metafile. Close the output file and + # start a new metafile if the maximum frame count has been reached. + # This disposes of the metafile to the system, causing the actual + # plots to be drawn. Open a new metafile ready to receive next frame. + + g_nframes = g_nframes + 1 + if (g_nframes >= g_maxframes) { + + # Does this device require a frame advance at end of metafile? + if (GKT_ENDFRAME(g_kt) == YES) + call frame() + + # The call to the NSPP flush procedure must be escaped to avoid + # interpretation as the FIO flush procedure. + +% call mcflsh + + g_nframes = 0 + call close (g_out) + + g_out = gkt_mfopen (g_tty, NEW_FILE) + + # Does this device require a frame advance at beginning of metafile? + if (GKT_STARTFRAME(g_kt) == YES) + call frame() + + } else { + # Merely output NSPP frame instruction to start a new frame in + # the same metafile. + + call frame() + } + + # Init kernel data structures. + call gkt_reset() + g_ndraw = 0 +end diff --git a/sys/gio/nsppkern/gktclose.x b/sys/gio/nsppkern/gktclose.x new file mode 100644 index 00000000..9ab73c34 --- /dev/null +++ b/sys/gio/nsppkern/gktclose.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gkt.h" + +# GKT_CLOSE -- Close the nspp translation kernel. Close the spool file so +# the output is finally plotted. Free up storage. + +procedure gkt_close() + +include "gkt.com" + +begin + # If there is anything in the metafile, flush it and add a frame + # advance if required for the device. + + if (g_ndraw > 0 || g_nframes > 0) { + # Does this device require a frame advance at end of metafile? + if (GKT_ENDFRAME(g_kt) == YES) + call frame() + + # The call to the NSPP flush procedure must be escaped to avoid + # interpretation as the FIO flush procedure. + +% call mcflsh + } + + # Close output metafile, disposing of it to the host system. + call close (g_out) + + # Free kernel data structures. + call mfree (GKT_SBUF(g_kt), TY_CHAR) + call mfree (g_kt, TY_STRUCT) + + g_kt = NULL +end diff --git a/sys/gio/nsppkern/gktclws.x b/sys/gio/nsppkern/gktclws.x new file mode 100644 index 00000000..27889c7c --- /dev/null +++ b/sys/gio/nsppkern/gktclws.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gkt.h" + +# GKT_CLOSEWS -- Close the named workstation. Flush the output. +# The spool file is closed only on the next plot or at gktclose time. +# If the spool file is closed here, APPEND mode would not work. + +procedure gkt_closews (devname, n) + +short devname[ARB] # device name (not used) +int n # length of device name +include "gkt.com" + +begin + call gkt_flush (0) +end diff --git a/sys/gio/nsppkern/gktcolor.x b/sys/gio/nsppkern/gktcolor.x new file mode 100644 index 00000000..7d24368a --- /dev/null +++ b/sys/gio/nsppkern/gktcolor.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gkt.h" + +# nspp particulars +# colors +define BLACK 1 +define WHITE 2 +define RED 3 +define GREEN 4 +define BLUE 5 + +# GKT_COLOR set the color option in the nspp world + +procedure gkt_color(index) + +int index # index for color switch statement +include "gkt.com" + +begin + switch (index) { + case WHITE: + call optn (*"co", *"white") + case RED: + call optn (*"co", *"red") + case GREEN: + call optn (*"co", *"green") + case BLUE: + call optn (*"co", *"blue") + default: + call optn (*"co", *"black") + } +end diff --git a/sys/gio/nsppkern/gktdrawch.x b/sys/gio/nsppkern/gktdrawch.x new file mode 100644 index 00000000..dd7dbeb1 --- /dev/null +++ b/sys/gio/nsppkern/gktdrawch.x @@ -0,0 +1,68 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "gkt.h" +include "font.h" + +define ITALIC_TILT 0.30 # fraction of xsize to tilt italics at top + + +# GKT_DRAWCHAR -- Draw a character of the given size and orientation at the +# given position. + +procedure gkt_drawchar (ch, x, y, xsize, ysize, orien, font) + +char ch # character to be drawn +int x, y # lower left GKI coords of character +int xsize, ysize # width, height of char in GKI units +int orien # orientation of character (0 degrees normal) +int font # desired character font + +real px, py, sx, sy, coso, sino, theta +int stroke, tab1, tab2, i, pen +int bitupk() +include "font.com" + +begin + if (ch < CHARACTER_START || ch > CHARACTER_END) + i = '?' - CHARACTER_START + 1 + else + i = ch - CHARACTER_START + 1 + + # Set the font. + call gkt_font (font) + + tab1 = chridx[i] + tab2 = chridx[i+1] - 1 + + theta = -DEGTORAD(orien) + coso = cos(theta) + sino = sin(theta) + + do i = tab1, tab2 { + stroke = chrtab[i] + px = bitupk (stroke, COORD_X_START, COORD_X_LEN) + py = bitupk (stroke, COORD_Y_START, COORD_Y_LEN) + pen = bitupk (stroke, COORD_PEN_START, COORD_PEN_LEN) + + # Scale size of character. + px = px / FONT_WIDTH * xsize + py = py / FONT_HEIGHT * ysize + + # The italic font is implemented applying a tilt. + if (font == GT_ITALIC) + px = px + ((py / ysize) * xsize * ITALIC_TILT) + + # Rotate and shift. + sx = x + px * coso + py * sino + sy = y - px * sino + py * coso + + # Draw the line segment or move pen. + if (pen == 0) + call frstpt (sx / GKI_MAXNDC, sy / GKI_MAXNDC) + else + call vector (sx / GKI_MAXNDC, sy / GKI_MAXNDC) + } +end diff --git a/sys/gio/nsppkern/gktescape.x b/sys/gio/nsppkern/gktescape.x new file mode 100644 index 00000000..ad8ff494 --- /dev/null +++ b/sys/gio/nsppkern/gktescape.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GKt_ESCAPE -- Pass a device dependent instruction on to the kernel. +# The nspp kernel does not have any escape functions at present. + +procedure gkt_escape (fn, instruction, nwords) + +int fn # function code +short instruction[ARB] # instruction data words +int nwords # length of instruction + +begin +end diff --git a/sys/gio/nsppkern/gktfa.x b/sys/gio/nsppkern/gktfa.x new file mode 100644 index 00000000..4df21260 --- /dev/null +++ b/sys/gio/nsppkern/gktfa.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gkt.h" + +# GKT_FILLAREA -- Fill a closed area. + +procedure gkt_fillarea (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs +include "gkt.com" + +begin + # Not implemented yet. + call gkt_polyline (p, npts) +end diff --git a/sys/gio/nsppkern/gktfaset.x b/sys/gio/nsppkern/gktfaset.x new file mode 100644 index 00000000..f5851cb9 --- /dev/null +++ b/sys/gio/nsppkern/gktfaset.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gkt.h" + +# GKT_FASET -- Set the fillarea attributes. + +procedure gkt_faset (gki) + +short gki[ARB] # attribute structure +pointer fa +include "gkt.com" + +begin + fa = GKT_FAAP(g_kt) + FA_STYLE(fa) = gki[GKI_FASET_FS] + FA_COLOR(fa) = gki[GKI_FASET_CI] +end diff --git a/sys/gio/nsppkern/gktflush.x b/sys/gio/nsppkern/gktflush.x new file mode 100644 index 00000000..decb5300 --- /dev/null +++ b/sys/gio/nsppkern/gktflush.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gkt.h" + +# GKT_FLUSH -- Flush output. + +procedure gkt_flush (dummy) + +int dummy # not used at present +include "gkt.com" + +begin + # Since the NSPP devices are not interactive, calls to FLUSH + # are ignored. +end diff --git a/sys/gio/nsppkern/gktfont.x b/sys/gio/nsppkern/gktfont.x new file mode 100644 index 00000000..cbcb9f90 --- /dev/null +++ b/sys/gio/nsppkern/gktfont.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gkt.h" + +# GKT_FONT -- Set the character font. The roman font is normal. Bold is +# implemented by increasing the vector line width; care must be taken to +# set GKT_WIDTH so that the other vector drawing procedures remember to +# change the width back. The italic font is implemented in the character +# generator by a geometric transformation. + +procedure gkt_font (font) + +int font # code for font to be set +int pk1, pk2, width +include "gkt.com" + +begin + pk1 = GKI_PACKREAL(1.0) + pk2 = GKI_PACKREAL(2.0) + + width = GKT_WIDTH(g_kt) + + if (font == GT_BOLD) { + if (width != pk2) { + call optn (*"inten", *"high") + width = pk2 + } + } else { + if (GKI_UNPACKREAL(width) > 1.5) { + call optn (*"inten", *"low") + width = pk1 + } + } + + GKT_WIDTH(g_kt) = width +end diff --git a/sys/gio/nsppkern/gktgcell.x b/sys/gio/nsppkern/gktgcell.x new file mode 100644 index 00000000..197bf018 --- /dev/null +++ b/sys/gio/nsppkern/gktgcell.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GKT_GETCELLARRAY -- Input a cell array, i.e., two dimensional array of pixels +# (greylevels or colors). + +procedure gkt_getcellarray (nx, ny, x1,y1, x2,y2) + +int nx, ny # number of pixels in X and Y +int x1, y1 # lower left corner of input window +int x2, y2 # lower left corner of input window + +begin + # Not implemented yet. +end diff --git a/sys/gio/nsppkern/gktinit.x b/sys/gio/nsppkern/gktinit.x new file mode 100644 index 00000000..78ae0840 --- /dev/null +++ b/sys/gio/nsppkern/gktinit.x @@ -0,0 +1,194 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "gkt.h" + +# GKT_INIT -- Initialize the gkt data structures from the graphcap entry +# for the device. Called once, at OPENWS time, with the TTY pointer already +# set in the common. The companion routine GKT_RESET initializes the attribute +# packets when the frame is flushed. + +procedure gkt_init (tty, devname) + +pointer tty # graphcap descriptor +char devname[ARB] # device name + +pointer nextch +int maxch, i +real char_height, char_width, char_size + +bool ttygetb() +real ttygetr() +int ttygeti(), btoi(), gstrcpy() +include "gkt.com" +include "nspp.com" +int pow2() + +begin + # Allocate the gkt descriptor and the string buffer. + if (g_kt == NULL) { + call calloc (g_kt, LEN_GKT, TY_STRUCT) + call malloc (GKT_SBUF(g_kt), SZ_SBUF, TY_CHAR) + } + + # Get the maximum frame count and the flags controlling frame advance + # at start and end of metafile (NSPP parameters). + + g_maxframes = ttygeti (tty, "MF") + if (g_maxframes == 0) + g_maxframes = DEF_MAXFRAMES + GKT_STARTFRAME(g_kt) = btoi (ttygetb (tty, "FS")) + GKT_ENDFRAME(g_kt) = btoi (ttygetb (tty, "FE")) + + # Init string buffer parameters. The first char of the string buffer + # is reserved as a null string, used for graphcap control strings + # omitted from the graphcap entry for the device. + + GKT_SZSBUF(g_kt) = SZ_SBUF + GKT_NEXTCH(g_kt) = GKT_SBUF(g_kt) + 1 + Memc[GKT_SBUF(g_kt)] = EOS + + # Get the device resolution from the graphcap entry. + + g_xres = ttygeti (tty, "xr") + if (g_xres <= 0) + g_xres = 1024 + g_yres = ttygeti (tty, "yr") + if (g_yres <= 0) + g_yres = 1024 + + # Set up coordinate transformations. + + call seti (pow2(g_xres), pow2(g_yres)) + call set (0., 1., 0., 1., 0., 1., 0., 1., 1) + call z8zpii() + + # Set byteswap flag for output metacode. + mbswap = btoi (ttygetb (tty, "BS")) + + # Initialize the character scaling parameters, required for text + # generation. The heights are given in NDC units in the graphcap + # file, which we convert to GKI units. Estimated values are + # supplied if the parameters are missing in the graphcap entry. + + char_height = ttygetr (tty, "ch") + if (char_height < EPSILON) + char_height = 1.0 / 35.0 + char_height = char_height * GKI_MAXNDC + + char_width = ttygetr (tty, "cw") + if (char_width < EPSILON) + char_width = 1.0 / 80.0 + char_width = char_width * GKI_MAXNDC + + # If the device has a set of discreet character sizes, get the + # size of each by fetching the parameter "tN", where the N is + # a digit specifying the text size index. Compute the height and + # width of each size character from the "ch" and "cw" parameters + # and the relative scale of character size I. + # ... not relevant for nspp, but leave here anyway for now + + GKT_NCHARSIZES(g_kt) = min (MAX_CHARSIZES, ttygeti (tty, "th")) + nextch = GKT_NEXTCH(g_kt) + + if (GKT_NCHARSIZES(g_kt) <= 0) { + GKT_NCHARSIZES(g_kt) = 1 + GKT_CHARSIZE(g_kt,1) = 1.0 + GKT_CHARHEIGHT(g_kt,1) = char_height + GKT_CHARWIDTH(g_kt,1) = char_width + } else { + Memc[nextch+2] = EOS + for (i=1; i <= GKT_NCHARSIZES(g_kt); i=i+1) { + Memc[nextch] = 't' + Memc[nextch+1] = TO_DIGIT(i) + char_size = ttygetr (tty, Memc[nextch]) + GKT_CHARSIZE(g_kt,i) = char_size + GKT_CHARHEIGHT(g_kt,i) = char_height * char_size + GKT_CHARWIDTH(g_kt,i) = char_width * char_size + } + } + + # Initialize the output parameters. All boolean parameters are stored + # as integer flags. All string valued parameters are stored in the + # string buffer, saving a pointer to the string in the gkt + # descriptor. If the capability does not exist the pointer is set to + # point to the null string at the beginning of the string buffer. + + GKT_POLYLINE(g_kt) = btoi (ttygetb (tty, "pl")) + GKT_POLYMARKER(g_kt) = btoi (ttygetb (tty, "pm")) + GKT_FILLAREA(g_kt) = btoi (ttygetb (tty, "fa")) + GKT_FILLSTYLE(g_kt) = ttygeti (tty, "fs") + GKT_ROAM(g_kt) = btoi (ttygetb (tty, "ro")) + GKT_ZOOM(g_kt) = btoi (ttygetb (tty, "zo")) + GKT_ZRES(g_kt) = ttygeti (tty, "zr") + GKT_CELLARRAY(g_kt) = btoi (ttygetb (tty, "ca")) + GKT_SELERASE(g_kt) = btoi (ttygetb (tty, "se")) + GKT_PIXREP(g_kt) = btoi (ttygetb (tty, "pr")) + + # Initialize the input parameters. + + GKT_CURSOR(g_kt) = 1 + + # Save the device string in the descriptor. + nextch = GKT_NEXTCH(g_kt) + GKT_DEVNAME(g_kt) = nextch + maxch = GKT_SBUF(g_kt) + SZ_SBUF - nextch + 1 + nextch = nextch + gstrcpy (devname, Memc[nextch], maxch) + 1 + GKT_NEXTCH(g_kt) = nextch +end + + +# GKT_GSTRING -- Get a string value parameter from the graphcap table, +# placing the string at the end of the string buffer. If the device does +# not have the named capability return a pointer to the null string, +# otherwise return a pointer to the string. Since pointers are used, +# rather than indices, the string buffer is fixed in size. The additional +# degree of indirection required with an index was not considered worthwhile +# in this application since the graphcap entries are never very large. + +pointer procedure gkt_gstring (cap) + +char cap[ARB] # device capability to be fetched +pointer strp, nextch +int maxch, nchars +int ttygets() +include "gkt.com" + +begin + nextch = GKT_NEXTCH(g_kt) + maxch = GKT_SBUF(g_kt) + SZ_SBUF - nextch + 1 + + nchars = ttygets (g_tty, cap, Memc[nextch], maxch) + if (nchars > 0) { + strp = nextch + nextch = nextch + nchars + 1 + } else + strp = GKT_SBUF(g_kt) + + GKT_NEXTCH(g_kt) = nextch + return (strp) +end + + +# POW2 -- Return the integer base two exponent of the first power of two +# greater than the argument. The technique is to use successive one bit +# shift rights to determine the index of the leftmost one-bit. + +int procedure pow2 (num) + +int num +int bitshift, n, pow + +begin + bitshift = 0 + for (n=max(1,num); n > 0; n=n/2) + bitshift = bitshift + 1 + pow = bitshift - 1 + + if (num > 2 ** pow) + return (pow + 1) + else + return (pow) +end diff --git a/sys/gio/nsppkern/gktline.x b/sys/gio/nsppkern/gktline.x new file mode 100644 index 00000000..08318c91 --- /dev/null +++ b/sys/gio/nsppkern/gktline.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gkt.h" + +# GKT_LINETYPE -- Set the line type option in the nspp world. + +procedure gkt_linetype (index) + +int index # index for line type switch statement + +int linetype +include "gkt.com" + +begin + switch (index) { + case GL_CLEAR: + linetype = 0 + case GL_DASHED: + linetype = 0FF00X + case GL_DOTTED: + linetype = 08888X + case GL_DOTDASH: + linetype = 0F040X + default: + linetype = 0FFFFX # GL_SOLID and default + } + + call optn (*"dp", linetype) +end diff --git a/sys/gio/nsppkern/gktmfopen.x b/sys/gio/nsppkern/gktmfopen.x new file mode 100644 index 00000000..97ab92f9 --- /dev/null +++ b/sys/gio/nsppkern/gktmfopen.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "gkt.h" + +define SZ_DDSTR 256 + + +# GKT_MFOPEN -- Open the NSPP metacode output file. The device is connected +# to FIO as a binary file. Metacode output to the device will be spooled +# and then disposed of to the device when the file descriptor we return is +# later closed. + +int procedure gkt_mfopen (tty, mode) + +pointer tty # pointer to graphcap entry for device +int mode # access mode + +int fd +pointer sp, ddstr +int fopnbf(), ttygets() +extern zopnpl(), zardpl(), zawrpl(), zawtpl(), zsttpl(), zclspl() +errchk fopnbf + +begin + call smark (sp) + call salloc (ddstr, SZ_DDSTR, TY_CHAR) + + # The DD string is used to pass device dependent information to the + # NSPP graphics device driver. + + if (ttygets (tty, "DD", Memc[ddstr], SZ_DDSTR) <= 0) + call error (1, "nsppkern: missing DD parameter in graphcap") + + fd = fopnbf (Memc[ddstr], mode, + zopnpl, zardpl, zawrpl, zawtpl, zsttpl, zclspl) + + # Set the FIO buffer size to the size of a metafile record. + call fseti (fd, F_BUFSIZE, SZ_MFRECORD) + + call sfree (sp) + return (fd) +end diff --git a/sys/gio/nsppkern/gktopen.x b/sys/gio/nsppkern/gktopen.x new file mode 100644 index 00000000..41e3b19a --- /dev/null +++ b/sys/gio/nsppkern/gktopen.x @@ -0,0 +1,77 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gkt.h" + +# GKT_OPEN -- Install the nspp kernel as a graphics kernel device driver. +# The device table DD consists of an array of the entry point addresses for +# the driver procedures. If a driver does not implement a particular +# instruction the table entry for that procedure may be set to zero, causing +# the interpreter to ignore the instruction. + +procedure gkt_open (devname, dd) + +char devname[ARB] # nonnull for forced output to a device +int dd[ARB] # device table to be initialized + +pointer sp, devns +int len_devname +int locpr(), strlen() +extern gkt_openws(), gkt_closews(), gkt_clear(), gkt_cancel() +extern gkt_flush(), gkt_polyline(), gkt_polymarker(), gkt_text() +extern gkt_fillarea(), gkt_putcellarray(), gkt_plset() +extern gkt_pmset(), gkt_txset(), gkt_faset() +extern gkt_escape() +include "gkt.com" + +begin + call smark (sp) + call salloc (devns, SZ_FNAME, TY_SHORT) + + # Flag first pass. Save forced device name in common for OPENWS. + # Zero the frame and instruction counters. + + g_kt = NULL + g_nframes = 0 + g_ndraw = 0 + call strcpy (devname, g_device, SZ_GDEVICE) + + # Install the device driver. + + dd[GKI_OPENWS] = locpr (gkt_openws) + dd[GKI_CLOSEWS] = locpr (gkt_closews) + dd[GKI_DEACTIVATEWS] = 0 + dd[GKI_REACTIVATEWS] = 0 + dd[GKI_MFTITLE] = 0 + dd[GKI_CLEAR] = locpr (gkt_clear) + dd[GKI_CANCEL] = locpr (gkt_cancel) + dd[GKI_FLUSH] = locpr (gkt_flush) + dd[GKI_POLYLINE] = locpr (gkt_polyline) + dd[GKI_POLYMARKER] = locpr (gkt_polymarker) + dd[GKI_TEXT] = locpr (gkt_text) + dd[GKI_FILLAREA] = locpr (gkt_fillarea) + dd[GKI_PUTCELLARRAY] = locpr (gkt_putcellarray) + dd[GKI_SETCURSOR] = 0 + dd[GKI_PLSET] = locpr (gkt_plset) + dd[GKI_PMSET] = locpr (gkt_pmset) + dd[GKI_TXSET] = locpr (gkt_txset) + dd[GKI_FASET] = locpr (gkt_faset) + dd[GKI_GETCURSOR] = 0 + dd[GKI_GETCELLARRAY] = 0 + dd[GKI_ESCAPE] = locpr (gkt_escape) + dd[GKI_SETWCS] = 0 + dd[GKI_GETWCS] = 0 + dd[GKI_UNKNOWN] = 0 + + # If a device was named open the workstation as well. This is + # necessary to permit processing of metacode files which do not + # contain the open workstation instruction. + + len_devname = strlen (devname) + if (len_devname > 0) { + call achtcs (devname, Mems[devns], len_devname) + call gkt_openws (Mems[devns], len_devname, NEW_FILE) + } + + call sfree (sp) +end diff --git a/sys/gio/nsppkern/gktopenws.x b/sys/gio/nsppkern/gktopenws.x new file mode 100644 index 00000000..2ef91e3d --- /dev/null +++ b/sys/gio/nsppkern/gktopenws.x @@ -0,0 +1,104 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "gkt.h" + +# GKT_OPENWS -- Open the named workstation. Once a workstation has been +# opened we leave it open until some other workstation is opened or the +# kernel is closed. Opening a workstation involves initialization of the +# kernel data structures, following by initialization of the device itself. + +procedure gkt_openws (devname, n, mode) + +short devname[ARB] # device name +int n # length of device name +int mode # access mode + +pointer sp, buf +pointer ttygdes() +bool streq() +int gkt_mfopen() +bool need_open, same_dev + +include "gkt.com" +include "nspp.com" + +begin + call smark (sp) + call salloc (buf, max (SZ_FNAME, n), TY_CHAR) + + # If a device was named when the kernel was opened then output will + # always go to that device (g_device) regardless of the device named + # in the OPENWS instruction. If no device was named (null string) + # then unpack the device name, passed as a short integer array. + + if (g_device[1] == EOS) { + call achtsc (devname, Memc[buf], n) + Memc[buf+n] = EOS + } else + call strcpy (g_device, Memc[buf], SZ_FNAME) + + # Find out if first time, and if not, if same device as before + # note that if (g_kt == NULL), then same_dev is false. + + same_dev = false + need_open = true + + if (g_kt != NULL) { + same_dev = (streq (Memc[GKT_DEVNAME(g_kt)], Memc[buf])) + if (!same_dev) { + # Does this device require a frame advance at end of metafile? + if (GKT_ENDFRAME(g_kt) == YES) + call frame() + call close (g_out) + } else + need_open = false + } + + # Initialize the kernel data structures. Open graphcap descriptor + # for the named device, allocate and initialize descriptor and common. + # graphcap entry for device must exist. + + if (need_open) { + if (!same_dev) { + if (g_kt != NULL) + call ttycdes (g_tty) + iferr (g_tty = ttygdes (Memc[buf])) + call erract (EA_ERROR) + + # Initialize data structures if we had to open a new device. + call gkt_init (g_tty, Memc[buf]) + call gkt_reset() + } + + # Open the output file. The device is connected to FIO as a + # binary file. Metacode output to the device will be spooled + # and then disposed of to the device at CLOSEWS time. + + iferr (g_out = gkt_mfopen (g_tty, mode)) { + call ttycdes (g_tty) + call erract (EA_ERROR) + } else { + # Does this device require a frame advance at start of metafile? + if (GKT_STARTFRAME(g_kt) == YES) + call frame() + g_nframes = 0 + g_ndraw = 0 + } + + # Initialize output file descriptor in nspp common. + munit = g_out + } + + # Clear the screen if device is being opened in new_file mode. + # This is a nop if we really opened a new device, but it will clear + # the screen if this is just a reopen of the same device in new file + # mode. + + if (mode == NEW_FILE) + call gkt_clear (0) + + call sfree (sp) +end diff --git a/sys/gio/nsppkern/gktpcell.x b/sys/gio/nsppkern/gktpcell.x new file mode 100644 index 00000000..e7e0ca4a --- /dev/null +++ b/sys/gio/nsppkern/gktpcell.x @@ -0,0 +1,383 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gkt.h" + +# Number of grey scale symbols +define NSYMBOL 11 +define TSIZE (1.0/2.0) + +# GKT_PUTCELLARRAY -- Draw a cell array, i.e., two dimensional array of pixels +# (greylevels or colors). + +procedure gkt_putcellarray (m, nc, nr, ax1,ay1, ax2,ay2) + +short m[ARB] # cell array +int nc, nr # number of pixels in X and Y + # (number of columns[x], rows[y] +int ax1, ay1 # lower left corner of output window +int ax2, ay2 # upper right corner of output window + +int x1,y1,x2,y2 # device coordinates +real px1, py1, px2, py2 +int nx, ny, y +real skip_x, skip_y, sx, sy +real blockx, blocky, bcy +int i, j, startrow, element +real xres, yres +pointer sp, cell, tx, txsave +bool ca, use_orig, new_row, pr +real z_scale +real charheight, charwidth +real delta_y +int xrep, yrep + +include "gkt.com" + +begin + call smark(sp) + + # Keep track of the number of drawing instructions since the last frame + # clear. + + g_ndraw = g_ndraw + 1 + + skip_x = 1.0 + skip_y = 1.0 + blockx = 1.0 + blocky = 1.0 + + # Determine if can do real cell array. If not, use character + # sized boxes as pixels. In that case, we need to save all + # the character attributes since we will want to force default + # character size, orientation, etc. + + ca = (GKT_CELLARRAY(g_kt) != 0) + pr = false + if ( ca ) { + xres = real(g_xres) + yres = real(g_yres) + pr = (GKT_PIXREP(g_kt) != 0) + } else { + charwidth = real(GKT_CHARWIDTH(g_kt,1))*TSIZE + charheight = real(GKT_CHARHEIGHT(g_kt,1))*TSIZE + xres = real(GKI_MAXNDC)/ charwidth + yres = real(GKI_MAXNDC)/ charheight + z_scale = 1.0 / sqrt ( real(max(NSYMBOL, GKT_ZRES(g_kt))) ) + tx = GKT_TXAP(g_kt) + call salloc(txsave, LEN_TX, TY_INT) + call savetx(txsave,tx) + } + + # Input arguments (ax, ay) refer to corners of put cell array; + # we need corners of the corresponding device array. + + x1 = ax1 + x2 = ax2 + y1 = ay1 + y2 = ay2 + call adjust(x1,x2,xres) + call adjust(y1,y2,yres) + + # Find out how many real pixels we have to fill + px1 = real(x1)/(GKI_MAXNDC+1) + py1 = real(y1)/(GKI_MAXNDC+1) + px2 = real(x2)/(GKI_MAXNDC+1) + py2 = real(y2)/(GKI_MAXNDC+1) + + nx = int( px2 * xres ) - int( px1 * xres ) + 1 + ny = int( py2 * yres ) - int( py1 * yres ) + 1 + + if ( ny > 1) + delta_y = (real(y2) - real(y1))/ny + else { + delta_y = 0. + } + + # If too many data points in input, set skip. If skip is close + # enough to one, set it to one. + # Set block replication factors - will be > 1.0 if too few input points. + # Cannot set to 1.0 if "close" enough, since, if > 1.0, we don't have + # enough points and so *some* have to be replicated. + + if ( nc > nx ) { + skip_x = real(nc)/nx + if ( (skip_x - 1.0)*(nx-1) < 1.0 ) + skip_x = 1.0 + } else + blockx = real(nx)/nc + + if ( nr > ny ) { + skip_y = real(nr)/ny + if ( (skip_y - 1.0)*(ny-1) < 1.0 ) + skip_y = 1.0 + } else + blocky = real(ny)/nr + + # Allocate storage for a row of pixels. This is quite inefficient + # if the x dimension of the cell array is small, but the metacode + # won't be too much bigger (?). + # need nx+1 in case nx odd ... pixels() wants to pad output. + + call salloc ( cell, nx+1, TY_SHORT) + Mems[cell + nx] = 0 + + # Initialize counters + + sy = skip_y + bcy = blocky + startrow = 1 + element = startrow + + # See if we can use original data ... no massaging + # also set the initial value of the new_row flag, which tells + # if we have to rebuild the row data + # Note that if blockx > 1.0, skip_x must be 1.0, and vv + + if ( (skip_x == 1.0) && (blockx == 1.0) ) { + use_orig = true + new_row = false + } else { + use_orig = false + new_row = true + } + + # If device can pixel replicate, use that feature where we can + if( pr) { + if( (skip_x == 1.0) && ( int(blockx) == blockx) ) { + xrep = int(blockx) + use_orig = true + nx = nc + } else + xrep = 1 + if( (skip_y == 1.0) && ( int(blocky) == blocky) ) { + yrep = int(blocky) + ny = 1 + } else + yrep = 1 + call pixel0(1,0,xrep,0,1,yrep) + } + + # Do it + + for ( i = 1; i <= ny ; i = i + 1) { + + # Build the row data + + if ( !use_orig && new_row ) { + if ( skip_x == 1.0) { + call blockit(m[element], Mems[cell], nx, blockx) + } else { + sx = skip_x + for ( j = 1; j <= nx; j = j + 1) { + Mems[cell+j-1] = m[element] + element = startrow + int(sx+0.5) + sx = sx + skip_x + } + } + if ( !ca ) + if ( use_orig) + call fakepc(m[element], Mems[cell], nx, z_scale) + else + call fakepc(Mems[cell], Mems[cell], nx, z_scale) + } + + # Send the row data. + + if ( ca ) { + y = y1 + ((i - 1)*delta_y + 0.5) + if ( use_orig ) { + call pixels( px1, real(y)/GKI_MAXNDC, + nx, 1, m[element]) + } else { + call pixels( px1, real(y)/GKI_MAXNDC, nx, 1, Mems[cell]) + } + } + else + call gkt_text( x1, y1+(i-1)*int(charheight), Mems[cell], nx) + + # Advance a row + + element = startrow + if ( bcy <= real(i) ) { + startrow = 1 + nc * int(sy+0.5) + element = startrow + sy = sy + skip_y + bcy = bcy + blocky + new_row = true + } else { + new_row = false + } + } + + # All done, restore text parameters and release storage + + if ( !ca ) + call restoretx (txsave,tx) + call sfree(sp) +end + +# SAVETX --- save the current text parameters as pointed to by "txp" +# in the area pointed to by "savep", and then set the necessary +# defaults. + +procedure savetx (savep, txp) +pointer savep, txp + +include "gkt.com" + +begin + # save old values + + TX_UP(savep) = TX_UP(txp) + TX_SIZE(savep) = TX_SIZE(txp) + TX_PATH(savep) = TX_PATH(txp) + TX_HJUSTIFY(savep) = TX_HJUSTIFY(txp) + TX_VJUSTIFY(savep) = TX_VJUSTIFY(txp) + TX_FONT(savep) = TX_FONT(txp) + TX_COLOR(savep) = TX_COLOR(txp) + TX_SPACING(savep) = TX_SPACING(txp) + + # set new (default) ones + + TX_UP(txp) = 90 + TX_SIZE(txp) = GKI_PACKREAL(TSIZE) + TX_PATH(txp) = GT_RIGHT + TX_HJUSTIFY(txp)= GT_LEFT + TX_VJUSTIFY(txp)= GT_BOTTOM + TX_FONT(txp) = GT_ROMAN + TX_COLOR(txp) = 1 + TX_SPACING(txp) = 0.0 + + # Set the device attributes to undefined, forcing them to be reset + # when the next output instruction is executed. + + GKT_TYPE(g_kt) = -1 + GKT_WIDTH(g_kt) = -1 + GKT_COLOR(g_kt) = -1 + GKT_TXSIZE(g_kt) = -1 + GKT_TXFONT(g_kt) = -1 +end + +# RESTORETX --- restore the text parameters from the save area + +procedure restoretx (savep, txp) +pointer savep, txp + +include "gkt.com" + +begin + # Restore values + + TX_UP(txp) = TX_UP(savep) + TX_SIZE(txp) = TX_SIZE(savep) + TX_PATH(txp) = TX_PATH(savep) + TX_HJUSTIFY(txp) = TX_HJUSTIFY(savep) + TX_VJUSTIFY(txp) = TX_VJUSTIFY(savep) + TX_FONT(txp) = TX_FONT(savep) + TX_COLOR(txp) = TX_COLOR(savep) + TX_SPACING(txp) = TX_SPACING(savep) + + # Set the device attributes to undefined, forcing them to be reset + # when the next output instruction is executed. + + GKT_TYPE(g_kt) = -1 + GKT_WIDTH(g_kt) = -1 + GKT_COLOR(g_kt) = -1 + GKT_TXSIZE(g_kt) = -1 + GKT_TXFONT(g_kt) = -1 +end + +# FAKEPC --- fake putcell output by using appropriately chosen text +# characters to make grey scale. + +procedure fakepc (indata, outdata, nx, scale) +int nx # number of points in row +short indata[ARB] # input row data +short outdata[ARB] # output row data +real scale # intensity scaling factor + +include "gkt.com" + +int i +real temp +char cdata[NSYMBOL] # characters to represent intensity +data cdata /' ', '.', ':', '|', 'i', 'l', 'J', 'm', '#', 'S', 'B', EOS/ + +begin + # + for ( i = 1 ; i <= nx ; i = i + 1 ) { + temp = sqrt( max(0., real(indata[i])) ) + outdata[i] = cdata[ min( NSYMBOL, int(NSYMBOL*scale*temp)+1 ) ] + } +end + +# BLOCKIT -- block replication of data + +procedure blockit( from, to, count, factor) + +short from[ARB] # input data +short to[ARB] # output data +int count # number of output pixels +real factor # blocking factor + +int i, j +real bc + +begin + bc = factor + j = 1 + for ( i = 1; i <= count ; i = i + 1 ) { + to[i] = from[j] + if ( bc <= real(i) ) { + j = j + 1 + bc = bc + factor + } + } +end + +# ADJUST -- round/truncate putcell array corners to device coordinates +# move up lower bound if it is above center point of device cell, +# move down upper bound if below. Don't allow bounds to go beyond +# resolution or below zero. Do not allow bounds to cross. Part of the +# assumptions behind all this is that putcells will be continguous and +# rows/columns must not be plotted twice. + +procedure adjust ( lower, upper, res) + +int lower, upper +real res + +real factor +real low, up + +begin + factor = res/(GKI_MAXNDC+1) + low = real(lower) * factor + up = real(upper) * factor + + # if boundaries result in same row, return + if ( int(low) == int(up) ) + return + + # if low is in upper half of device pixel, round up + if ( (low - int(low)) >= 0.5 ) { + low = int(low) + 1 + # don't go to or beyond upper bound + if ( low < up ) { + # ... 0.2 just for "rounding protection"; + lower = (low + 0.2)/factor + # if now reference same cell, return + if ( int(low) == int(up) ) + return + } + } + + # if "up" in bottom half of pixel, drop down one. Note that + # due to two "==" tests above, upper will not drop below lower. + # 0.2 means drop partway down into pixel below; calling code will + # truncate. + if ( (up - int(up)) < 0.5 ) + upper = real(int(up) - 0.2)/factor +end diff --git a/sys/gio/nsppkern/gktpl.x b/sys/gio/nsppkern/gktpl.x new file mode 100644 index 00000000..7e7243cf --- /dev/null +++ b/sys/gio/nsppkern/gktpl.x @@ -0,0 +1,64 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gkt.h" + +# GKT_POLYLINE -- Draw a polyline. The polyline is defined by the array of +# points P, consisting of successive (x,y) coordinate pairs. The first point +# is not plotted but rather defines the start of the polyline. The remaining +# points define line segments to be drawn. + +procedure gkt_polyline (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs + +pointer pl +int i, len_p +int x,y +include "gkt.com" + +begin + if (npts <= 0) + return + + len_p = npts * 2 + + # Keep track of the number of drawing instructions since the last frame + # clear. + g_ndraw = g_ndraw + 1 + + # Update polyline attributes if necessary. + pl = GKT_PLAP(g_kt) + + if (GKT_TYPE(g_kt) != PL_LTYPE(pl)) { + call gkt_linetype (PL_LTYPE(pl)) + GKT_TYPE(g_kt) = PL_LTYPE(pl) + } + if (GKT_WIDTH(g_kt) != PL_WIDTH(pl)) { + if (GKI_UNPACKREAL(PL_WIDTH(pl)) < 1.5) + call optn (*"inten", *"low") + else + call optn (*"inten", *"high") + GKT_WIDTH(g_kt) = PL_WIDTH(pl) + } + if (GKT_COLOR(g_kt) != PL_COLOR(pl)) { + call gkt_color (PL_COLOR(pl)) + GKT_COLOR(g_kt) = PL_COLOR(pl) + } + + # Transform the first point from GKI coords to nspp coords and + # move to the transformed point. + + x = p[1] + y = p[2] + call frstpt(real(x)/GKI_MAXNDC, real(y)/GKI_MAXNDC) + + # Draw the polyline. + + for (i=3; i <= len_p; i=i+2) { + x = p[i] + y = p[i+1] + call vector (real(x)/GKI_MAXNDC, real(y)/GKI_MAXNDC) + } +end diff --git a/sys/gio/nsppkern/gktplset.x b/sys/gio/nsppkern/gktplset.x new file mode 100644 index 00000000..9342fccc --- /dev/null +++ b/sys/gio/nsppkern/gktplset.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gkt.h" + +# GKT_PLSET -- Set the polyline attributes. The polyline width parameter is +# passed to the encoder as a packed floating point number, i.e., int(LWx100). + +procedure gkt_plset (gki) + +short gki[ARB] # attribute structure +pointer pl +include "gkt.com" + +begin + pl = GKT_PLAP(g_kt) + PL_LTYPE(pl) = gki[GKI_PLSET_LT] + PL_WIDTH(pl) = gki[GKI_PLSET_LW] + PL_COLOR(pl) = gki[GKI_PLSET_CI] +end diff --git a/sys/gio/nsppkern/gktpm.x b/sys/gio/nsppkern/gktpm.x new file mode 100644 index 00000000..fe6a9a0a --- /dev/null +++ b/sys/gio/nsppkern/gktpm.x @@ -0,0 +1,64 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gkt.h" + +# Nspp particulars. +define BASELW 8 # base width of line + + +# GKT_POLYMARKER -- Draw a polymarker. The polymarker is defined by the array +# of points P, consisting of successive (x,y) coordinate pairs. + +procedure gkt_polymarker (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs + +pointer pm +int i, len_p +int x, y, oldx, oldy +include "gkt.com" + +begin + if (npts <= 0) + return + + len_p = npts * 2 + + # Keep track of the number of drawing instructions since the last frame + # clear. + g_ndraw = g_ndraw + 1 + + # Update polymarker attributes if necessary. + + pm = GKT_PMAP(g_kt) + + if (GKT_TYPE(g_kt) != PM_LTYPE(pm)) { + call gkt_linetype (PM_LTYPE(pm)) + GKT_TYPE(g_kt) = PM_LTYPE(pm) + } + if (GKT_WIDTH(g_kt) != PM_WIDTH(pm)) { + if (GKI_UNPACKREAL(PM_WIDTH(pm)) < 1.5) + call optn (*"inten", *"low") + else + call optn (*"inten", *"high") + GKT_WIDTH(g_kt) = PM_WIDTH(pm) + } + if (GKT_COLOR(g_kt) != PM_COLOR(pm)) { + call gkt_color (PM_COLOR(pm)) + GKT_COLOR(g_kt) = PM_COLOR(pm) + } + + # Get to start of marker. + call frstpt (real(x)/GKI_MAXNDC, real(y)/GKI_MAXNDC) + oldx = 0; oldy = 0 + + # Draw the polymarker. + for (i=1; i <= len_p; i=i+2) { + x = p[i]; y = p[i+1] + if (x != oldx && y != oldy) + call point (real(x)/GKI_MAXNDC, real(y)/GKI_MAXNDC) + oldx = x; oldy = y + } +end diff --git a/sys/gio/nsppkern/gktpmset.x b/sys/gio/nsppkern/gktpmset.x new file mode 100644 index 00000000..8a3ebe24 --- /dev/null +++ b/sys/gio/nsppkern/gktpmset.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "gkt.h" + +# GKT_PMSET -- Set the polymarker attributes. + +procedure gkt_pmset (gki) + +short gki[ARB] # attribute structure +pointer pm +include "gkt.com" + +begin + pm = GKT_PMAP(g_kt) + PM_LTYPE(pm) = gki[GKI_PMSET_MT] + PM_WIDTH(pm) = gki[GKI_PMSET_MW] + PM_COLOR(pm) = gki[GKI_PMSET_CI] +end diff --git a/sys/gio/nsppkern/gktreset.x b/sys/gio/nsppkern/gktreset.x new file mode 100644 index 00000000..6e34cec4 --- /dev/null +++ b/sys/gio/nsppkern/gktreset.x @@ -0,0 +1,59 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gkt.h" + +# GKT_RESET -- Reset the state of the transform common, i.e., in response to +# a clear or a cancel. Initialize all attribute packets to their default +# values and set the current state of the device to undefined, forcing the +# device state to be reset when the next output instruction is executed. + +procedure gkt_reset() + +pointer pl, pm, fa, tx +include "gkt.com" + +begin + # Set pointers to attribute substructures. + pl = GKT_PLAP(g_kt) + pm = GKT_PMAP(g_kt) + fa = GKT_FAAP(g_kt) + tx = GKT_TXAP(g_kt) + + # Initialize the attribute packets. + PL_LTYPE(pl) = 1 + PL_WIDTH(pl) = GKI_PACKREAL(1.) + PL_COLOR(pl) = 1 + PM_LTYPE(pm) = 1 + PM_WIDTH(pm) = GKI_PACKREAL(1.) + PM_COLOR(pm) = 1 + FA_STYLE(fa) = 1 + FA_COLOR(fa) = 1 + TX_UP(tx) = 90 + TX_SIZE(tx) = GKI_PACKREAL(1.) + TX_PATH(tx) = GT_RIGHT + TX_HJUSTIFY(tx) = GT_LEFT + TX_VJUSTIFY(tx) = GT_BOTTOM + TX_FONT(tx) = GT_ROMAN + TX_COLOR(tx) = 1 + TX_SPACING(tx) = 0.0 + + # Set the device attributes to undefined, forcing them to be reset + # when the next output instruction is executed. + + GKT_TYPE(g_kt) = -1 + GKT_WIDTH(g_kt) = -1 + GKT_COLOR(g_kt) = -1 + GKT_TXSIZE(g_kt) = -1 + GKT_TXFONT(g_kt) = -1 + + # Reset the nspp common. + + call z8zpii() + + # If cellarray allowed, reset pixel size to standard one. + + if (GKT_CELLARRAY(g_kt) != 0) + call pixel0 (1,0,1,0,1,1) +end diff --git a/sys/gio/nsppkern/gkttx.x b/sys/gio/nsppkern/gkttx.x new file mode 100644 index 00000000..7aaf3c31 --- /dev/null +++ b/sys/gio/nsppkern/gkttx.x @@ -0,0 +1,428 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "gkt.h" + +define BASECS_X 12 # Base (size 1.0) char width in GKI coords. +define BASECS_Y 12 # Base (size 1.0) char height in GKI coords. + + +# GKT_TEXT -- Draw a text string. The string is drawn at the position (X,Y) +# using the text attributes set by the last GKI_TXSET instruction. The text +# string to be drawn may contain embedded set font escape sequences of the +# form \fR (roman), \fG (greek), etc. We break the input text sequence up +# into segments at font boundaries and draw these on the output device, +# setting the text size, color, font, and position at the beginning of each +# segment. + +procedure gkt_text (xc, yc, text, n) + +int xc, yc # where to draw text string +short text[ARB] # text string +int n # number of characters + +real x, y, dx, dy, tsz +int x1, x2, y1, y2, orien +int x0, y0, gki_dx, gki_dy, ch, cw +int xstart, ystart, newx, newy +int totlen, polytext, font, seglen +pointer sp, seg, ip, op, tx, first +int stx_segment() +include "gkt.com" + +real g_dx, g_dy # scale GKI to window coords +int g_x1, g_y1 # origin of device window +int g_x2, g_y2 # upper right corner of device window +data g_dx /1.0/, g_dy /1.0/ +data g_x1 /0/, g_y1 /0/, g_x2 /GKI_MAXNDC/, g_y2 / GKI_MAXNDC/ + +begin + call smark (sp) + call salloc (seg, n + 2, TY_CHAR) + + # Keep track of the number of drawing instructions since the last frame + # clear. + g_ndraw = g_ndraw + 1 + + # Set pointer to the text attribute structure. + tx = GKT_TXAP(g_kt) + + # Set the text size and color if not already set. Both should be + # invalidated when the screen is cleared. Text color should be + # invalidated whenever another color is set. The text size was + # set by gkt_txset, and is just a scaling factor. + + GKT_TXSIZE(g_kt) = TX_SIZE(tx) + if (TX_COLOR(tx) != GKT_COLOR(g_kt)) { + call gkt_color (TX_COLOR(tx)) + GKT_COLOR(g_kt) = TX_COLOR(tx) + } + + # Set the linetype to a solid line, and invalidate last setting. + call gkt_linetype (GL_SOLID) + GKT_TYPE(g_kt) = -1 + + # Break the text string into segments at font boundaries and count + # the total number of printable characters. + + totlen = stx_segment (text, n, Memc[seg], TX_FONT(tx)) + + # Compute the text drawing parameters, i.e., the coordinates of the + # first character to be drawn, the step between successive characters, + # and the polytext flag (GKI coords). + + call stx_parameters (xc,yc, totlen, x0,y0, gki_dx,gki_dy, polytext, + orien) + + # For nspp, have 32767 sizes, so just scale the the base sizes. + tsz = GKI_UNPACKREAL(TX_SIZE(tx)) # scale factor + ch = GKT_CHARHEIGHT(g_kt,1) * tsz + cw = GKT_CHARWIDTH(g_kt,1) * tsz + + # Draw the segments, setting the font at the beginning of each segment. + # The first segment is drawn at (X0,Y0). The separation between + # characters is DX,DY. A segment is drawn as a block if the polytext + # flag is set, otherwise each character is drawn individually. + + x = x0 * g_dx + g_x1 + y = y0 * g_dy + g_y1 + dx = gki_dx * g_dx + dy = gki_dy * g_dy + + for (ip=seg; Memc[ip] != EOS; ip=ip+1) { + # Process the font control character heading the next segment. + font = Memc[ip] + ip = ip + 1 + + # Draw the segment. + while (Memc[ip] != EOS) { + # Clip leading out of bounds characters. + for (; Memc[ip] != EOS; ip=ip+1) { + x1 = x; x2 = x1 + cw + y1 = y; y2 = y1 + ch + + if (x1 >= g_x1 && x2 <= g_x2 && y1 >= g_y1 && y2 <= g_y2) + break + else { + x = x + dx + y = y + dy + } + + if (polytext == NO) { + ip = ip + 1 + break + } + } + + # Coords of first char to be drawn. + xstart = x + ystart = y + + # Move OP to first out of bounds char. + for (op=ip; Memc[op] != EOS; op=op+1) { + x1 = x; x2 = x1 + cw + y1 = y; y2 = y1 + ch + + if (x1 <= g_x1 || x2 >= g_x2 || y1 <= g_y1 || y2 >= g_y2) + break + else { + x = x + dx + y = y + dy + } + + if (polytext == NO) { + op = op + 1 + break + } + } + + # Count number of inbounds chars. + seglen = op - ip + + # Leave OP pointing to the end of this segment. + if (polytext == NO) + op = ip + 1 + else { + while (Memc[op] != EOS) + op = op + 1 + } + + # Compute X,Y of next segment. + newx = xstart + (dx * (op - ip)) + newy = ystart + dy + + # Quit if no inbounds chars. + if (seglen == 0) { + x = newx + y = newy + ip = op + next + } + + # Output the inbounds chars. + + first = ip + x = xstart + y = ystart + + while (seglen > 0 && (polytext == YES || ip == first)) { + call gkt_drawchar (Memc[ip], nint(x), nint(y), cw, ch, + orien, font) + ip = ip + 1 + seglen = seglen - 1 + x = x + dx + y = y + dy + } + + x = newx + y = newy + ip = op + } + } + + call sfree (sp) +end + + +# STX_SEGMENT -- Process the text string into segments, in the process +# converting from type short to char. The only text attribute that can +# change within a string is the font, so segments are broken by \fI, \fG, +# etc. font select sequences embedded in the text. The segments are encoded +# sequentially in the output string. The first character of each segment is +# the font number. A segment is delimited by EOS. A font number of EOS +# marks the end of the segment list. The output string is assumed to be +# large enough to hold the segmented text string. + +int procedure stx_segment (text, n, out, start_font) + +short text[ARB] # input text +int n # number of characters in text +char out[ARB] # output string +int start_font # initial font code + +int ip, op +int totlen, font + +begin + out[1] = start_font + totlen = 0 + op = 2 + + for (ip=1; ip <= n; ip=ip+1) { + if (text[ip] == '\\' && text[ip+1] == 'f') { + # Select font. + out[op] = EOS + op = op + 1 + ip = ip + 2 + + switch (text[ip]) { + case 'B': + font = GT_BOLD + case 'I': + font = GT_ITALIC + case 'G': + font = GT_GREEK + default: + font = GT_ROMAN + } + + out[op] = font + op = op + 1 + + } else { + # Deposit character in segment. + out[op] = text[ip] + op = op + 1 + totlen = totlen + 1 + } + } + + # Terminate last segment and add null segment. + + out[op] = EOS + out[op+1] = EOS + + return (totlen) +end + + +# STX_PARAMETERS -- Set the text drawing parameters, i.e., the coordinates +# of the lower left corner of the first character to be drawn, the spacing +# between characters, and the polytext flag. Input consists of the coords +# of the text string, the length of the string, and the text attributes +# defining the character size, justification in X and Y of the coordinates, +# and orientation of the string. All coordinates are in GKI units. + +procedure stx_parameters (xc, yc, totlen, x0, y0, dx, dy, polytext, orien) + +int xc, yc # coordinates at which string is to be drawn +int totlen # number of characters to be drawn +int x0, y0 # lower left corner of first char to be drawn +int dx, dy # step in X and Y between characters +int polytext # OK to output text segment all at once +int orien # rotation angle of characters + +pointer tx +int up, path +real dir, sz, ch, cw, cosv, sinv, space +real xsize, ysize, xvlen, yvlen, xu, yu, xv, yv, p, q +include "gkt.com" + +begin + tx = GKT_TXAP(g_kt) + + # Get character sizes in GKI(NSPP) coords. + sz = GKI_UNPACKREAL (TX_SIZE(tx)) + ch = GKT_CHARHEIGHT(g_kt,1) * sz + cw = GKT_CHARWIDTH(g_kt,1) * sz + + # Compute the character rotation angle. This is independent of the + # direction in which characters are drawn. A character up vector of + # 90 degrees (normal) corresponds to a rotation angle of zero. + + up = TX_UP(tx) + orien = up - 90 + + # Determine the direction in which characters are to be plotted. + # This depends on both the character up vector and the path, which + # is defined relative to the up vector. + + path = TX_PATH(tx) + switch (path) { + case GT_UP: + dir = up + case GT_DOWN: + dir = up - 180 + case GT_LEFT: + dir = up + 90 + default: # GT_NORMAL, GT_RIGHT + dir = up - 90 + } + + # ------- DX, DY --------- + # Convert the direction vector into the step size between characters. + # Note CW and CH are in GKI coordinates, hence DX and DY are too. + # Additional spacing of some fraction of the character size is used + # if TX_SPACING is nonzero. + + dir = -DEGTORAD(dir) + cosv = cos (dir) + sinv = sin (dir) + + # Correct for spacing (unrotated). + space = (1.0 + TX_SPACING(tx)) + if (path == GT_UP || path == GT_DOWN) + p = ch * space + else + p = cw * space + q = 0 + + # Correct for rotation. + dx = p * cosv + q * sinv + dy = -p * sinv + q * cosv + + # ------- XU, YU --------- + # Determine the coordinates of the center of the first character req'd + # to justify the string, assuming dimensionless characters spaced on + # centers DX,DY apart. + + xvlen = dx * (totlen - 1) + yvlen = dy * (totlen - 1) + + switch (TX_HJUSTIFY(tx)) { + case GT_CENTER: + xu = - (xvlen / 2.0) + case GT_RIGHT: + # If right justify and drawing to the left, no offset req'd. + if (xvlen < 0) + xu = 0 + else + xu = -xvlen + default: # GT_LEFT, GT_NORMAL + # If left justify and drawing to the left, full offset right req'd. + if (xvlen < 0) + xu = -xvlen + else + xu = 0 + } + + switch (TX_VJUSTIFY(tx)) { + case GT_CENTER: + yu = - (yvlen / 2.0) + case GT_TOP: + # If top justify and drawing downward, no offset req'd. + if (yvlen < 0) + yu = 0 + else + yu = -yvlen + default: # GT_BOTTOM, GT_NORMAL + # If bottom justify and drawing downward, full offset up req'd. + if (yvlen < 0) + yu = -yvlen + else + yu = 0 + } + + # ------- XV, YV --------- + # Compute the offset from the center of a single character required + # to justify that character, given a particular character up vector. + # (This could be combined with the above case but is clearer if + # treated separately.) + + p = -DEGTORAD(orien) + cosv = cos(p) + sinv = sin(p) + + # Compute the rotated character in size X and Y. + xsize = abs ( cw * cosv + ch * sinv) + ysize = abs (-cw * sinv + ch * cosv) + + switch (TX_HJUSTIFY(tx)) { + case GT_CENTER: + xv = 0 + case GT_RIGHT: + xv = - (xsize / 2.0) + default: # GT_LEFT, GT_NORMAL + xv = xsize / 2 + } + + switch (TX_VJUSTIFY(tx)) { + case GT_CENTER: + yv = 0 + case GT_TOP: + yv = - (ysize / 2.0) + default: # GT_BOTTOM, GT_NORMAL + yv = ysize / 2 + } + + # ------- X0, Y0 --------- + # The center coordinates of the first character to be drawn are given + # by the reference position plus the string justification vector plus + # the character justification vector. + + x0 = xc + xu + xv + y0 = yc + yu + yv + + # The character drawing primitive requires the coordinates of the + # lower left corner of the character (irrespective of orientation). + # Compute the vector from the center of a character to the lower left + # corner of a character, rotate to the given orientation, and correct + # the starting coordinates by addition of this vector. + + p = - (cw / 2.0) + q = - (ch / 2.0) + + x0 = x0 + ( p * cosv + q * sinv) + y0 = y0 + (-p * sinv + q * cosv) + + # ------- POLYTEXT --------- + # Set the polytext flag. Polytext output is possible only if chars + # are to be drawn to the right with no extra spacing between chars. + + if (abs(dy) == 0 && dx == cw) + polytext = YES + else + polytext = NO +end diff --git a/sys/gio/nsppkern/gkttxset.x b/sys/gio/nsppkern/gkttxset.x new file mode 100644 index 00000000..28ed1d32 --- /dev/null +++ b/sys/gio/nsppkern/gkttxset.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gkt.h" + +# GKT_TXSET -- Set the text drawing attributes. + +procedure gkt_txset (gki) + +short gki[ARB] # attribute structure + +pointer tx +include "gkt.com" + +begin + tx = GKT_TXAP(g_kt) + + TX_UP(tx) = gki[GKI_TXSET_UP] + TX_PATH(tx) = gki[GKI_TXSET_P ] + TX_HJUSTIFY(tx) = gki[GKI_TXSET_HJ] + TX_VJUSTIFY(tx) = gki[GKI_TXSET_VJ] + TX_FONT(tx) = gki[GKI_TXSET_F ] + TX_QUALITY(tx) = gki[GKI_TXSET_Q ] + TX_COLOR(tx) = gki[GKI_TXSET_CI] + + TX_SPACING(tx) = GKI_UNPACKREAL (gki[GKI_TXSET_SP]) + TX_SIZE(tx) = gki[GKI_TXSET_SZ] +end diff --git a/sys/gio/nsppkern/mkpkg b/sys/gio/nsppkern/mkpkg new file mode 100644 index 00000000..e9f92d6e --- /dev/null +++ b/sys/gio/nsppkern/mkpkg @@ -0,0 +1,56 @@ +# Make the NSPPKERN GIO graphics kernel. Requires LIBNSPP. Requires +# a host system metacode translation task for each device. + +$checkout libgkt.a lib$ +$update libgkt.a +$checkin libgkt.a lib$ +$call relink +$exit + +update: # update lib$x_nsppkern.e + $call relink + $call install + ; + +relink: # make x_nsppkern.e in local directory + $omake writeb.x gkt.h gkt.com + $omake x_nsppkern.x + $link x_nsppkern.o writeb.o -lgkt -lnspp + ; + +install: # install in system library + $move x_nsppkern.e bin$ + ; + +libgkt.a: + gktcancel.x gkt.com gkt.h + gktclear.x gkt.com gkt.h + gktclose.x gkt.com gkt.h + gktclws.x gkt.h gkt.com + gktcolor.x gkt.com gkt.h + gktdrawch.x font.com font.h gkt.h + gktescape.x + gktfa.x gkt.com gkt.h + gktfaset.x gkt.com gkt.h + gktflush.x gkt.com gkt.h + gktfont.x gkt.com gkt.h + gktgcell.x + gktinit.x gkt.com gkt.h nspp.com + gktline.x gkt.com gkt.h + gktmfopen.x gkt.h + gktopen.x gkt.com gkt.h + gktopenws.x gkt.com gkt.h nspp.com + gktpcell.x gkt.com gkt.h + gktpl.x gkt.com gkt.h + gktplset.x gkt.com gkt.h + gktpm.x gkt.com gkt.h + gktpmset.x gkt.com gkt.h + gktreset.x gkt.com gkt.h + gkttx.x gkt.com gkt.h + gkttxset.x gkt.com gkt.h + pixel0.f + pixels.f + t_nsppkern.x + tran16.f + writeb.x gkt.h gkt.com + ; diff --git a/sys/gio/nsppkern/nspp.com b/sys/gio/nsppkern/nspp.com new file mode 100644 index 00000000..e3cac846 --- /dev/null +++ b/sys/gio/nsppkern/nspp.com @@ -0,0 +1,40 @@ +# NSPP.COM -- The nspp system plot package common block. + +int mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab +int mflg ,mtype ,mxa ,mya ,mxb ,myb +int mx ,my ,mtypex ,mtypey +real xxa ,yya , xxb ,yyb ,xxc ,yyc +real xxd ,yyd , xfactr ,yfactr ,xadd ,yadd +real xx ,yy + +# XX declared integer some places in nspp code !!! +# on a VAX this works, but what if float not same size as int ??? + +int mfmtx[3] ,mfmty[3] ,mumx ,mumy +int msizx ,msizy ,mxdec ,mydec ,mxor ,mop[19] +int mname[19] ,mxold ,myold ,mxmax ,mymax +int mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty +int mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst +int mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin +int mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto +int mxysto ,mprint ,msybuf[360] ,mncpw ,minst +int mbufa ,mbuflu ,mfwa[12] ,mlwa[12] +int mipair ,mbprs[16] ,mbufl ,munit ,mbswap + +real small + +common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab, + mflg ,mtype ,mxa ,mya ,mxb ,myb, + mx ,my ,mtypex ,mtypey ,xxa ,yya, + xxb ,yyb ,xxc ,yyc ,xxd ,yyd, + xfactr ,yfactr ,xadd ,yadd ,xx ,yy, + mfmtx ,mfmty ,mumx ,mumy, + msizx ,msizy ,mxdec ,mydec ,mxor ,mop, + mname ,mxold ,myold ,mxmax ,mymax, + mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty, + mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst, + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin, + mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto, + mxysto ,mprint ,msybuf ,mncpw ,minst, + mbufa ,mbuflu ,mfwa ,mlwa, + mipair ,mbprs ,mbufl ,munit ,mbswap ,small diff --git a/sys/gio/nsppkern/pixel0.f b/sys/gio/nsppkern/pixel0.f new file mode 100644 index 00000000..df42b150 --- /dev/null +++ b/sys/gio/nsppkern/pixel0.f @@ -0,0 +1,58 @@ + subroutine pixel0(dx1,dy1,n1,dx2,dy2,n2) + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + data ipixop / 10/ + mbpair = ior(ishift(ior(192, ipixop), 8), 12) + mipair = mipair + 1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + xx = dx1 + yy = dy1 + call dtran16 + mx1 = mx + mbpair = mx + mipair = mipair + 1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + my1=my + mbpair=my + mipair = mipair + 1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair=n1 + mipair = mipair + 1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + xx = dx2 + yy = dy2 + call dtran16 + mbpair=mx + mipair = mipair + 1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair=my + mipair = mipair + 1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair=n2 + mipair = mipair + 1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + if(n1*n2*(mx1*my-mx*my1) .ne. 0) return + call uliber(0,35h vectors not independent in pixel0.,35) + call perror + end diff --git a/sys/gio/nsppkern/pixels.f b/sys/gio/nsppkern/pixels.f new file mode 100644 index 00000000..a7b5e039 --- /dev/null +++ b/sys/gio/nsppkern/pixels.f @@ -0,0 +1,74 @@ + subroutine pixels(x0,y0,ni,nj,inten) + integer*2 inten(1) +c assume inten is a linear array rather than 2-d. This is a change +c from the original code. +c assume nj == 1 + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small + data ipixop / 10/ + mbpair = ior(ishift(ior(192, ipixop + 1), 8), 8) + mipair = mipair + 1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + xx = x0 + yy = y0 + call tran16 + mbpair = mx + mipair = mipair + 1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair=my + mipair = mipair + 1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair=ni + mipair = mipair + 1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair=nj + mipair = mipair + 1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + nni = max0(1,(ni+iand(ni,1))) + nnj = max0(1,nj) + kmax=nni*nnj + k=0 + do 200 j=1,nnj + do 100 i=1,nni + if(mod(k,254).ne.0) goto 90 + mbpair = ior(ishift(ior(192, ipixop+2),8), min0(254,kmax-k)) + mipair = mipair + 1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair = 0 + 90 ik = iand ( i, 1) +c +c 14Nov85 mod so that arguments to ishift are of same type + itmp = inten(i) + mbpair = ior (ishift(iand(itmp,255),8*ik),mbpair) +c mbpair = ior (ishift(iand(inten(i),255),8*ik),mbpair) +c + if ( ik .ne. 0 ) go to 95 + mipair = mipair + 1 + mbprs(mipair) = mbpair + if (mipair .ge. 16) call flushb + mbpair = 0 + 95 k = k + 1 + 100 continue + 200 continue + return + end diff --git a/sys/gio/nsppkern/t_nsppkern.x b/sys/gio/nsppkern/t_nsppkern.x new file mode 100644 index 00000000..69a5ec27 --- /dev/null +++ b/sys/gio/nsppkern/t_nsppkern.x @@ -0,0 +1,67 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# NSPPKERN -- Graphics kernel for the NCAR System Plot Package graphics +# interface. + +procedure t_nsppkern() + +int fd, list +pointer gki, sp, fname, devname +int dev[LEN_GKIDD], deb[LEN_GKIDD] +int debug, verbose, gkiunits +bool clgetb() +int clpopni(), clgfil(), open(), btoi() +int gki_fetch_next_instruction() + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (devname, SZ_FNAME, TY_CHAR) + + # Open list of metafiles to be decoded. + list = clpopni ("input") + + # Get parameters. + call clgstr ("device", Memc[devname], SZ_FNAME) + if (clgetb ("generic")) { + debug = NO + verbose = NO + gkiunits = NO + } else { + debug = btoi (clgetb ("debug")) + verbose = btoi (clgetb ("verbose")) + gkiunits = btoi (clgetb ("gkiunits")) + } + + # Open the graphics kernel. + call gkt_open (Memc[devname], dev) + call gkp_install (deb, STDERR, verbose, gkiunits) + + # Process a list of metacode files, writing the decoded metacode + # instructions on the standard output. + + while (clgfil (list, Memc[fname], SZ_FNAME) != EOF) { + # Open input file. + iferr (fd = open (Memc[fname], READ_ONLY, BINARY_FILE)) { + call erract (EA_WARN) + next + } + + # Process the metacode instruction stream. + while (gki_fetch_next_instruction (fd, gki) != EOF) { + if (debug == YES) + call gki_execute (Mems[gki], deb) + call gki_execute (Mems[gki], dev) + } + + call close (fd) + } + + call gkp_close() + call gkt_close() + call clpcls (list) + call sfree (sp) +end diff --git a/sys/gio/nsppkern/tran16.f b/sys/gio/nsppkern/tran16.f new file mode 100644 index 00000000..e0503d57 --- /dev/null +++ b/sys/gio/nsppkern/tran16.f @@ -0,0 +1,64 @@ + subroutine tran16 + common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab , + 1 mflg ,mtype ,mxa ,mya ,mxb ,myb , + 2 mx ,my ,mtypex ,mtypey ,xxa ,yya , + 3 xxb ,yyb ,xxc ,yyc ,xxd ,yyd , + 4 xfactr ,yfactr ,xadd ,yadd ,xx ,yy , + 5 mfmtx(3) ,mfmty(3) ,mumx ,mumy , + 6 msizx ,msizy ,mxdec ,mydec ,mxor ,mop(19), + 7 mname(19) ,mxold ,myold ,mxmax ,mymax , + 8 mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty , + 9 mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst , + + mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin , + 1 mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto , + 2 mxysto ,mprint ,msybuf(360) ,mncpw ,minst , + 3 mbufa ,mbuflu ,mfwa(12) ,mlwa(12) , + 4 mipair ,mbprs(16) ,mbufl ,munit ,mbswap , + 5 small +c ray bovet patch to avoid small integers being set to 0 + integer xx,yy +c + logical intt + equivalence (zz,mz),(temp,itemp) +c ray bovet patch to avoid small integers being set to 0 +c zz = xx + mz = xx + if (intt(zz)) go to 102 + if (mtypex .eq. 0) go to 101 + if (zz .le. 0.0) + 1 call uliber (0,35h0negative argument with log scaling,35) + zz = amax1(zz,small) + mz = 2.0*(xfactr*alog10(zz)+xadd) + go to 103 + 101 mz = 2.0*(xfactr*zz+xadd) + go to 103 + 102 mz = ishift(mz,mshftx+1) + 103 mx = max0(0,min0(65535,mz-1)) +c ray bovet patch to avoid small integers being set to 0 +c zz = yy + mz = yy + if (intt(zz)) go to 105 + if (mtypey .eq. 0) go to 104 + if (zz .le. 0.0) + 1 call uliber (0,35h0negative argument with log scaling,35) + zz = amax1(zz,small) + mz = 2.0*(yfactr*alog10(zz)+yadd) + go to 106 + 104 mz = 2.0*(yfactr*zz+yadd) + go to 106 + 105 mz =ishift(mz,mshfty+1) + 106 my = max0(0,min0(65535,mz-1)) + return +C + entry DTRAN16 +C + zz = xx + if(intt(zz) .or. (zz .eq. 0.0)) goto 203 + mz = 2.0 * xfactr * zz + 203 mx = max0(-127,min0(127,mz)) + zz = yy + if(intt(zz) .or. (zz .eq. 0.0)) goto 206 + mz = 2.0 * yfactr * zz + 206 my = max0(-127,min0(127,mz)) + return + end diff --git a/sys/gio/nsppkern/writeb.x b/sys/gio/nsppkern/writeb.x new file mode 100644 index 00000000..dfcd82bb --- /dev/null +++ b/sys/gio/nsppkern/writeb.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gkt.h" + +.help writeb +.nf ___________________________________________________________________________ +WRITEB -- Write an NCAR metacode record. Always write a full record +regardless of the buffer length; any data beyond buflen is undefined. +If the buffer length is passed as zero, the metafile standard wants us to +write a full (zeroed) record and backspace over it, to signify end of +metafile if the physical metafile is subsequently closed. Instead of +writing the EOF record here, we leave that to the FIO close routine +for the graphics device. +.endhelp ______________________________________________________________________ + +procedure writeb (metacode_buffer, buflen, mbunit) + +int metacode_buffer # LOC pointer to metacode buffer +int buflen # number of words of metacode data +int mbunit # FIO file descriptor !! from nspp common !! + +int dummy[1], offset +int loci() +include "gkt.com" + +begin + if (buflen <= 0) + return + + # Standard NCAR pointer technique for accessing integer arrays. This + # assumes alignment of integer variables. Convert to use IRAF + # pointers if this causes problems. + + offset = metacode_buffer - loci (dummy) + 1 + + iferr (call write (mbunit, dummy[offset], SZ_MFRECORD)) + call erract (EA_FATAL) +end diff --git a/sys/gio/nsppkern/x_nsppkern.x b/sys/gio/nsppkern/x_nsppkern.x new file mode 100644 index 00000000..4b54cba2 --- /dev/null +++ b/sys/gio/nsppkern/x_nsppkern.x @@ -0,0 +1,3 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +task nsppkern = t_nsppkern diff --git a/sys/gio/nsppkern/zzdebug.x b/sys/gio/nsppkern/zzdebug.x new file mode 100644 index 00000000..b2ae6144 --- /dev/null +++ b/sys/gio/nsppkern/zzdebug.x @@ -0,0 +1,472 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "font.h" + +define XS 0.216 +define XE 0.719 +define YS 0.214 +define YE 0.929 + +task grid = t_grid, + grey = t_grey, + text = t_text, + seefont = t_seefont, + txup = t_txup, + font = t_font, + efont = t_efont + + +# GRID -- Test program for graphics plotting. A labelled grid is output. + +procedure t_grid () + +pointer gp +bool redir +char command[SZ_LINE], image[SZ_FNAME], word[SZ_LINE] +char output[SZ_FNAME], output_file[SZ_FNAME], device[SZ_FNAME] +int cmd, input_fd, stat, fd + +pointer gopen() +bool streq() +int fstati(), open(), getline(), sscan() + +begin + # If the input has been redirected, input is read from the named + # command file. If not, each image name in the input template is + # plotted. + + if (fstati (STDIN, F_REDIR) == YES) { +call eprintf ("Input has been redirected\n") + redir = true + cmd = open (STDIN, READ_ONLY, TEXT_FILE) + } + + # Loop over commands until EOF + repeat { + if (redir) { + if (getline (STDIN, command, SZ_LINE) == EOF) + break + stat = sscan (command) + call gargwrd (word, SZ_LINE) + if (!streq (word, "plot")) { + # Pixel window has been stored as WCS 2 + call gseti (gp, G_WCS, 2) + call gscan (command) + next + } else + call gargwrd (image) + } + + call clgstr ("output", output, SZ_FNAME) + if (!streq (output, "")) { + call strcpy (output, output_file, SZ_FNAME) + fd = open (output_file, NEW_FILE, BINARY_FILE) + } else + fd = open ("dev$crt", NEW_FILE, BINARY_FILE) + + call clgstr ("device", device, SZ_FNAME) + gp = gopen (device, NEW_FILE, fd) + + call gseti (gp, G_XDRAWGRID, 1) + call gseti (gp, G_YDRAWGRID, 1) + call gseti (gp, G_NMAJOR, 21) + call glabax (gp, "TEST", "NDC_X", "NDC_Y") + call gline (gp, XS, YS, XE, YS) + call gline (gp, XE, YS, XE, YE) + call gline (gp, XE, YE, XS, YE) + call gline (gp, XS, YE, XS, YS) + call gmark (gp, 0.5, 0.5, GM_CROSS, 3.0, 3.0) + call gtext (gp, XS, YS-0.1, "DICOMED crtpict film area") + call gclose (gp) + call close (fd) + } + + call clpcls (input_fd) +end + + +# GREY -- test code to generate grey scale on plotters + +procedure t_grey() + +pointer gp +real size +int i, fd, count +short celldata[1024] +char output[SZ_FNAME], device[SZ_FNAME] + +pointer gopen() +real clgetr() +int open(), clgeti() +string fmt "hj=c;vj=c" + +begin + call clgstr ("device", device, SZ_FNAME) + call clgstr ("output", output, SZ_FNAME) + + fd = open (output, NEW_FILE, BINARY_FILE) + gp = gopen (device, NEW_FILE, fd) + + size = clgetr ("size") + + call gsetr (gp, G_TXSIZE, size) + call gtext (gp, .5, .9, "! !\"#$%&'()*+,-./", fmt) + call gtext (gp, .5, .8, "1234567890", fmt) + call gtext (gp, .5, .7, "ABCDEFGHIJKLMNOPQR", fmt) + call gtext (gp, .5, .6, "STUVWXYZ[\\]^_`", fmt) + call gtext (gp, .5, .5, "abcdefghijklmnopqr", fmt) + call gtext (gp, .5, .4, "stuvwxyz{}|~", fmt) + + call gtext (gp, .5, .1, "Grey Scale Test", fmt) + + count = clgeti ( "count") + if (count > 1024) + count = 1024 + for (i=1; i <= count; i=i+1) + celldata[i] = i - 1 + + call gpcell (gp, celldata, count, 1, 0.05, 0.2, .95, 0.3) + + call gclose (gp) + call close (fd) +end + + +# TEXT -- Test character drawing. + +procedure t_text() + +char device[SZ_FNAME] +char output[SZ_FNAME] +int fd, open() +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + call clgstr ("output", output, SZ_FNAME) + + fd = open (output, NEW_FILE, BINARY_FILE) + gp = gopen (device, NEW_FILE, fd) + + call gsetr (gp, G_TXSIZE, 1.0) + + call gtext (gp, .1, .1, + "abcdefghijklmnopqrstuvwxyz", "hj=l,vj=b") + call gtext (gp, .1, .2, + "ABCDEFGHIJKLMNOPQRSTUVWXYZ", "hj=l,vj=b") + call gtext (gp, .1, .3, + "0123456789", "hj=l,vj=b") + call gtext (gp, .1, .4, + " ,./<>?;:'\"\\|[]{}!@#$%^&*()-_=+`~", "hj=l,vj=b") + + call gsetr (gp, G_TXSIZE, 2.0) + + call gtext (gp, .1, .5, + "abcdefghijklmnopqrstuvwxyz", "hj=l,vj=b") + call gtext (gp, .1, .6, + "ABCDEFGHIJKLMNOPQRSTUVWXYZ", "hj=l,vj=b") + call gtext (gp, .1, .7, + "0123456789", "hj=l,vj=b") + call gtext (gp, .1, .8, + " ,./<>?;:'\"\\|[]{}!@#$%^&*()-_=+`~", "hj=l,vj=b") + + call gclose (gp) + call close (fd) +end + + +# SEEFONT definitions. +define L .40 +define R .60 +define U .75 +define D .25 +define W (R-L) +define H (U-D) + + +# SEEFONT -- Draw a character from the font table. + +procedure t_seefont() + +char ch +pointer gp +real x, y +int wcs, key +char strval[SZ_FNAME] + +pointer gopen() +int clgcur() + +begin + gp = gopen ("stdgraph", NEW_FILE, STDGRAPH) + + call gline (gp, L, D, R, D) + call gline (gp, R, D, R, U) + call gline (gp, R, U, L, U) + call gline (gp, L, U, L, D) + + ch = 'A' + call gdrwch (gp, L, D, ch, W, H) + + while (clgcur ("gcur", x, y, wcs, key, strval, SZ_FNAME) != EOF) { + call gclear (gp) + + call gline (gp, L, D, R, D) + call gline (gp, R, D, R, U) + call gline (gp, R, U, L, U) + call gline (gp, L, U, L, D) + + ch = key + call gdrwch (gp, L, D, ch, W, H) + } + + call gclose (gp) +end + + +# GDRWCH -- Draw a character of the given size and orientation at the given +# position. + +procedure gdrwch (gp, x, y, ch, xsize, ysize) + +pointer gp # graphics descriptor +real x, y # lower left NDC coords of character +char ch # character to be drawn +real xsize, ysize # size of character in NDC units + +real px, py +int stroke, tab1, tab2, i, pen +int bitupk() +include "font.com" +common /font/ chridx, chrtab + +begin + if (ch < CHARACTER_START || ch > CHARACTER_END) + i = '?' - CHARACTER_START + 1 + else + i = ch - CHARACTER_START + 1 + + tab1 = chridx[i] + tab2 = chridx[i+1] - 1 + + do i = tab1, tab2 { + stroke = chrtab[i] + px = bitupk (stroke, COORD_X_START, COORD_X_LEN) + py = bitupk (stroke, COORD_Y_START, COORD_Y_LEN) + pen = bitupk (stroke, COORD_PEN_START, COORD_PEN_LEN) + + px = x + ((px + FONT_LEFT) / FONT_WIDTH) * xsize + py = y + ((py + FONT_BOTTOM) / FONT_HEIGHT) * ysize + + if (pen == 0) + call gamove (gp, px, py) + else + call gadraw (gp, px, py) + } +end + + +# TXUP -- Draw text strings with various character up vectors and paths. + +procedure t_txup() + +char device[SZ_FNAME] +char output[SZ_FNAME] +char text[SZ_LINE] +int fd, open(), clgeti() +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + call clgstr ("output", output, SZ_FNAME) + + fd = open (output, NEW_FILE, BINARY_FILE) + gp = gopen (device, NEW_FILE, fd) + + call clgstr ("text", text, SZ_LINE) + + call gseti (gp, G_TXHJUSTIFY, clgeti("hjustify")) + call gseti (gp, G_TXVJUSTIFY, clgeti("vjustify")) + + call gmark (gp, .1, .2, GM_CROSS, 3., 3.) + call gtext (gp, .1, .2, text, "up=0,path=right") + # -- + call gmark (gp, .2, .2, GM_CROSS, 3., 3.) + call gtext (gp, .2, .2, text, "up=45,path=right") + # -- + call gmark (gp, .3, .2, GM_CROSS, 3., 3.) + call gtext (gp, .3, .2, text, "up=90,path=right") + # -- + call gmark (gp, .4, .2, GM_CROSS, 3., 3.) + call gtext (gp, .4, .2, text, "up=135,path=right") + # -- + call gmark (gp, .5, .2, GM_CROSS, 3., 3.) + call gtext (gp, .5, .2, text, "up=180,path=right") + + call gmark (gp, .1, .4, GM_CROSS, 3., 3.) + call gtext (gp, .1, .4, text, "up=90,path=left") + # -- + call gmark (gp, .2, .4, GM_CROSS, 3., 3.) + call gtext (gp, .2, .4, text, "up=90,path=right") + # -- + call gmark (gp, .3, .4, GM_CROSS, 3., 3.) + call gtext (gp, .3, .4, text, "up=90,path=up") + # -- + call gmark (gp, .4, .4, GM_CROSS, 3., 3.) + call gtext (gp, .4, .4, text, "up=90,path=down") + + call gclose (gp) + call close (fd) +end + + +# FONT -- Test the font change escapes. + +procedure t_font() + +char device[SZ_FNAME] +char output[SZ_FNAME] +char text[SZ_LINE], format[SZ_FNAME] +int fd, i, open() +pointer gp, gopen() + +begin + call clgstr ("device", device, SZ_FNAME) + call clgstr ("output", output, SZ_FNAME) + + fd = open (output, NEW_FILE, BINARY_FILE) + gp = gopen (device, NEW_FILE, fd) + + do i = 2, 8, 2 { + call clgstr ("text", text, SZ_LINE) + call clgstr ("format", format, SZ_FNAME) + call gtext (gp, .2, i / 10.0, text, format) + } + + call gclose (gp) + call close (fd) +end + + +# EFONT -- Font editor. + +procedure t_efont() + +char cmd[SZ_LINE] +real scale +int pen, x, y, nw, w1, w2, ch, fcn +int ip, i, tab1, tab2, stroke, junk + +int bitupk(), ctoi(), ctor(), getline() +short chridx[96], chrtab[800] +common /font/ chridx, chrtab +define decode_ 91 + +begin + repeat { + # Get command. + call clgstr ("cmd", cmd, SZ_FNAME) + if (cmd[1] == 'q') + break + + # Decode function and integer arguments (range of words). + # Format "fcn [scale] ch w1 w2". + + fcn = cmd[1] + ip = 2 + + scale = 0 + if (fcn == 'x' || fcn == 'y') + if (ctor (cmd, ip, scale) <= 0) + scale = 1.0 + + while (IS_WHITE(cmd[ip])) + ip = ip + 1 + + ch = cmd[ip] + ip = ip + 1 + + if (ctoi (cmd, ip, w1) < 0) + w1 = 1 + if (ctoi (cmd, ip, w2) < 0) + w2 = w1 + + if (ch < CHARACTER_START || ch > CHARACTER_END) + next + else + i = ch - CHARACTER_START + 1 + + tab1 = chridx[i] + tab2 = chridx[i+1] - 1 + + nw = tab2 - tab1 + 1 + w1 = max(1, min(nw, w1)) + w2 = max(1, min(nw, w2)) + +call eprintf ("fcn=%c [%g], ch=%c, tab1=%d, tab2=%d, nw=%d, w1=%d, w2=%d\n") +call pargi(fcn); call pargr (scale); +call pargi(ch); call pargi(tab1); call pargi(tab2) +call pargi(nw); call pargi(w1); call pargi(w2) + + # Functions: + # + # w write codes + # r read and encode + # x scale in X + # y scale in Y + + do i = w1-1+tab1, w2-1+tab1 { + stroke = chrtab[i] + x = bitupk (stroke, COORD_X_START, COORD_X_LEN) + y = bitupk (stroke, COORD_Y_START, COORD_Y_LEN) + pen = bitupk (stroke, COORD_PEN_START, COORD_PEN_LEN) + + switch (fcn) { + case 'w': +decode_ call eprintf ("%2d %6d (%6o) %d %3d %3d\n") + call pargi (i - tab1 + 1) + call pargi (stroke) + call pargi (stroke) + call pargi (pen) + call pargi (x) + call pargi (y) + next + + case 'r': + junk = getline (STDIN, cmd) + ip = 1 + junk = ctoi (cmd, ip, pen) + junk = ctoi (cmd, ip, x) + junk = ctoi (cmd, ip, y) + call bitpak (x, stroke, COORD_X_START, COORD_X_LEN) + call bitpak (y, stroke, COORD_Y_START, COORD_Y_LEN) + call bitpak (pen, stroke, COORD_PEN_START, COORD_PEN_LEN) + chrtab[i] = stroke + goto decode_ + + case 'x': + x = x * scale + call bitpak (x, stroke, COORD_X_START, COORD_X_LEN) + call bitpak (y, stroke, COORD_Y_START, COORD_Y_LEN) + call bitpak (pen, stroke, COORD_PEN_START, COORD_PEN_LEN) + chrtab[i] = stroke + goto decode_ + + case 'y': + y = (y - FONT_BASE) * scale + FONT_BASE + call bitpak (x, stroke, COORD_X_START, COORD_X_LEN) + call bitpak (y, stroke, COORD_Y_START, COORD_Y_LEN) + call bitpak (pen, stroke, COORD_PEN_START, COORD_PEN_LEN) + chrtab[i] = stroke + goto decode_ + + default: + call eprintf ("unknown function code\n") + } + } + } +end diff --git a/sys/gio/sgikern/README b/sys/gio/sgikern/README new file mode 100644 index 00000000..e944a4be --- /dev/null +++ b/sys/gio/sgikern/README @@ -0,0 +1,12 @@ +SGIKERN - + +This directory contains the source for the simple GIO kernel, used to write +a metacode file using only the simplest possible drawing instructions. This +makes it relatively easy to implement functional (but probably suboptimal) +translators for new devices. + +Special graphcap entries used by this kernel: + + MF maximum frame count per metafile + FS frame advance req'd at start of metafile + FE frame advance req'd at end of metafile diff --git a/sys/gio/sgikern/font.com b/sys/gio/sgikern/font.com new file mode 100644 index 00000000..c26af8d6 --- /dev/null +++ b/sys/gio/sgikern/font.com @@ -0,0 +1,746 @@ +# CHRTAB -- Table of strokes for the printable ASCII characters. Each +# character is encoded as a series of strokes. Each stroke is ex- +# pressed by a single integer containing the following bitfields: +# +# 2 1 +# 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 +# | | | | | | | +# | | | +---------+ +---------+ +# | | | | | +# | | | X Y +# | | | +# | | +-- pen up/down +# | +---- begin paint (not used at present) +# +------ end paint (not used at present) +# +#---------------------------------------------------------------------------- + +# Define the database. + +short chridx[97] # character index in chrtab +short chrwid[97] # character width table +short chrtab[3363] # stroke data to draw the characters + +# Index into CHRTAB of each printable character (starting with SP) + +data (chridx(i), i=001,005) / 1, 3, 32, 49, 58/ +data (chridx(i), i=006,010) / 110, 140, 207, 228, 253/ +data (chridx(i), i=011,015) / 278, 309, 322, 343, 350/ +data (chridx(i), i=016,020) / 365, 372, 418, 438, 494/ +data (chridx(i), i=021,025) / 563, 583, 632, 696, 733/ +data (chridx(i), i=026,030) / 803, 867, 896, 931, 935/ +data (chridx(i), i=031,035) / 948, 952, 999, 1052, 1077/ +data (chridx(i), i=036,040) / 1139, 1174, 1223, 1281, 1330/ +data (chridx(i), i=041,045) / 1381, 1436, 1463, 1500, 1547/ +data (chridx(i), i=046,050) / 1583, 1626, 1653, 1703, 1748/ +data (chridx(i), i=051,055) / 1818, 1881, 1923, 1962, 1997/ +data (chridx(i), i=056,060) / 2021, 2060, 2097, 2131, 2160/ +data (chridx(i), i=061,065) / 2169, 2172, 2181, 2190, 2193/ +data (chridx(i), i=066,070) / 2214, 2263, 2303, 2335, 2378/ +data (chridx(i), i=071,075) / 2415, 2447, 2527, 2575, 2606/ +data (chridx(i), i=076,080) / 2640, 2682, 2704, 2778, 2826/ +data (chridx(i), i=081,085) / 2868, 2916, 2961, 2994, 3033/ +data (chridx(i), i=086,090) / 3052, 3086, 3108, 3140, 3173/ +data (chridx(i), i=091,095) / 3204, 3233, 3271, 3274, 3312/ +data (chridx(i), i=096,096) / 3335/ + + +# Width data. + +data (chrwid(i), i=001,005) / 21, 16, 23, 26, 25/ +data (chrwid(i), i=006,010) / 29, 31, 16, 19, 19/ +data (chrwid(i), i=011,015) / 21, 30, 16, 30, 16/ +data (chrwid(i), i=016,020) / 28, 25, 25, 25, 25/ +data (chrwid(i), i=021,025) / 25, 25, 25, 25, 25/ +data (chrwid(i), i=026,030) / 25, 16, 16, 29, 30/ +data (chrwid(i), i=031,035) / 29, 24, 32, 25, 27/ +data (chrwid(i), i=036,040) / 26, 27, 26, 25, 28/ +data (chrwid(i), i=041,045) / 29, 17, 21, 27, 23/ +data (chrwid(i), i=046,050) / 31, 29, 27, 27, 27/ +data (chrwid(i), i=051,055) / 27, 25, 25, 29, 25/ +data (chrwid(i), i=056,060) / 29, 25, 27, 25, 19/ +data (chrwid(i), i=061,065) / 19, 19, 21, 21, 16/ +data (chrwid(i), i=066,070) / 25, 26, 24, 26, 24/ +data (chrwid(i), i=071,075) / 19, 24, 28, 17, 18/ +data (chrwid(i), i=076,080) / 27, 17, 32, 28, 25/ +data (chrwid(i), i=081,085) / 26, 25, 22, 22, 20/ +data (chrwid(i), i=086,090) / 28, 23, 29, 25, 24/ +data (chrwid(i), i=091,095) / 23, 19, 13, 19, 29/ +data (chrwid(i), i=096,096) / 19/ + + +# Stroke data. + +data (chrtab(i), i=0001,0005) / 35, 0, 220, 4251, 4249/ +data (chrtab(i), i=0006,0010) / 4305, 220, 4302, 4366, 220/ +data (chrtab(i), i=0011,0015) / 4380, 4366, 284, 4443, 4441/ +data (chrtab(i), i=0016,0020) / 4369, 202, 4233, 4232, 4295/ +data (chrtab(i), i=0021,0025) / 4359, 4424, 4425, 4362, 4298/ +data (chrtab(i), i=0026,0030) / 201, 4296, 4360, 4361, 4297/ +data (chrtab(i), i=0031,0035) / 0, 220, 4251, 4245, 219/ +data (chrtab(i), i=0036,0040) / 4245, 220, 4379, 4245, 796/ +data (chrtab(i), i=0041,0045) / 4827, 4821, 795, 4821, 796/ +data (chrtab(i), i=0046,0050) / 4955, 4821, 0, 604, 4224/ +data (chrtab(i), i=0051,0055) / 988, 4608, 145, 5137, 75/ +data (chrtab(i), i=0056,0060) / 5067, 0, 416, 4483, 672/ +data (chrtab(i), i=0061,0065) / 4739, 919, 5016, 4952, 4950/ +data (chrtab(i), i=0066,0070) / 5078, 5080, 5018, 4955, 4764/ +data (chrtab(i), i=0071,0075) / 4508, 4315, 4185, 4182, 4244/ +data (chrtab(i), i=0076,0080) / 4434, 4816, 4943, 5005, 5002/ +data (chrtab(i), i=0081,0085) / 4936, 150, 4308, 4435, 4817/ +data (chrtab(i), i=0086,0090) / 4944, 5006, 219, 4249, 4247/ +data (chrtab(i), i=0091,0095) / 4309, 4436, 4818, 5008, 5070/ +data (chrtab(i), i=0096,0100) / 5067, 5001, 4936, 4743, 4487/ +data (chrtab(i), i=0101,0105) / 4296, 4233, 4171, 4173, 4301/ +data (chrtab(i), i=0106,0110) / 4299, 4235, 4236, 0, 1244/ +data (chrtab(i), i=0111,0115) / 4167, 412, 4634, 4632, 4566/ +data (chrtab(i), i=0116,0120) / 4437, 4309, 4183, 4185, 4251/ +data (chrtab(i), i=0121,0125) / 4380, 4508, 4635, 4826, 5018/ +data (chrtab(i), i=0126,0130) / 5211, 5340, 974, 4941, 4875/ +data (chrtab(i), i=0131,0135) / 4873, 4999, 5127, 5256, 5322/ +data (chrtab(i), i=0136,0140) / 5324, 5198, 5070, 0, 1299/ +data (chrtab(i), i=0141,0145) / 5396, 5332, 5330, 5458, 5460/ +data (chrtab(i), i=0146,0150) / 5397, 5333, 5268, 5202, 5069/ +data (chrtab(i), i=0151,0155) / 4938, 4808, 4679, 4423, 4296/ +data (chrtab(i), i=0156,0160) / 4234, 4237, 4303, 4691, 4821/ +data (chrtab(i), i=0161,0165) / 4887, 4889, 4827, 4700, 4571/ +data (chrtab(i), i=0166,0170) / 4505, 4502, 4563, 4688, 4939/ +data (chrtab(i), i=0171,0175) / 5128, 5255, 5383, 5449, 5450/ +data (chrtab(i), i=0176,0180) / 264, 4298, 4301, 4367, 4432/ +data (chrtab(i), i=0181,0185) / 725, 4889, 791, 4827, 475/ +data (chrtab(i), i=0186,0190) / 4503, 468, 4689, 4940, 5129/ +data (chrtab(i), i=0191,0195) / 5256, 455, 4424, 4362, 4365/ +data (chrtab(i), i=0196,0200) / 4431, 4691, 409, 4565, 4753/ +data (chrtab(i), i=0201,0205) / 5004, 5193, 5320, 5384, 5449/ +data (chrtab(i), i=0206,0210) / 0, 346, 4377, 4313, 4250/ +data (chrtab(i), i=0211,0215) / 4251, 4316, 4380, 4443, 4440/ +data (chrtab(i), i=0216,0220) / 4374, 4245, 219, 4314, 4378/ +data (chrtab(i), i=0221,0225) / 4379, 4315, 281, 4440, 346/ +data (chrtab(i), i=0226,0230) / 4374, 0, 544, 4510, 4379/ +data (chrtab(i), i=0231,0235) / 4247, 4178, 4174, 4233, 4357/ +data (chrtab(i), i=0236,0240) / 4482, 4608, 282, 4311, 4243/ +data (chrtab(i), i=0241,0245) / 4237, 4297, 4358, 414, 4444/ +data (chrtab(i), i=0246,0250) / 4377, 4307, 4301, 4359, 4420/ +data (chrtab(i), i=0251,0255) / 4482, 0, 160, 4382, 4507/ +data (chrtab(i), i=0256,0260) / 4631, 4690, 4686, 4617, 4485/ +data (chrtab(i), i=0261,0265) / 4354, 4224, 410, 4567, 4627/ +data (chrtab(i), i=0266,0270) / 4621, 4553, 4486, 286, 4444/ +data (chrtab(i), i=0271,0275) / 4505, 4563, 4557, 4487, 4420/ +data (chrtab(i), i=0276,0280) / 4354, 0, 412, 4443, 4561/ +data (chrtab(i), i=0281,0285) / 4496, 412, 4496, 412, 4571/ +data (chrtab(i), i=0286,0290) / 4433, 4496, 89, 4249, 4755/ +data (chrtab(i), i=0291,0295) / 4819, 89, 4819, 89, 4184/ +data (chrtab(i), i=0296,0300) / 4820, 4819, 729, 4761, 4243/ +data (chrtab(i), i=0301,0305) / 4179, 729, 4179, 729, 4824/ +data (chrtab(i), i=0306,0310) / 4180, 4179, 0, 665, 4744/ +data (chrtab(i), i=0311,0315) / 4808, 665, 4825, 4808, 145/ +data (chrtab(i), i=0316,0320) / 5329, 5328, 145, 4240, 5328/ +data (chrtab(i), i=0321,0325) / 0, 328, 4359, 4295, 4232/ +data (chrtab(i), i=0326,0330) / 4233, 4298, 4362, 4425, 4422/ +data (chrtab(i), i=0331,0335) / 4356, 4227, 201, 4296, 4360/ +data (chrtab(i), i=0336,0340) / 4361, 4297, 263, 4422, 328/ +data (chrtab(i), i=0341,0345) / 4356, 0, 145, 5329, 5328/ +data (chrtab(i), i=0346,0350) / 145, 4240, 5328, 0, 202/ +data (chrtab(i), i=0351,0355) / 4233, 4232, 4295, 4359, 4424/ +data (chrtab(i), i=0356,0360) / 4425, 4362, 4298, 201, 4296/ +data (chrtab(i), i=0361,0365) / 4360, 4361, 4297, 0, 1184/ +data (chrtab(i), i=0366,0370) / 4096, 4160, 1184, 5344, 4160/ +data (chrtab(i), i=0371,0375) / 0, 476, 4379, 4248, 4179/ +data (chrtab(i), i=0376,0380) / 4176, 4235, 4360, 4551, 4679/ +data (chrtab(i), i=0381,0385) / 4872, 5003, 5072, 5075, 5016/ +data (chrtab(i), i=0386,0390) / 4891, 4700, 4572, 282, 4312/ +data (chrtab(i), i=0391,0395) / 4244, 4239, 4299, 4361, 777/ +data (chrtab(i), i=0396,0400) / 4939, 5007, 5012, 4952, 4890/ +data (chrtab(i), i=0401,0405) / 476, 4443, 4377, 4308, 4303/ +data (chrtab(i), i=0406,0410) / 4362, 4424, 4551, 583, 4808/ +data (chrtab(i), i=0411,0415) / 4874, 4943, 4948, 4889, 4827/ +data (chrtab(i), i=0416,0420) / 4700, 0, 474, 4551, 538/ +data (chrtab(i), i=0421,0425) / 4616, 604, 4679, 604, 4505/ +data (chrtab(i), i=0426,0430) / 4376, 199, 4935, 456, 4423/ +data (chrtab(i), i=0431,0435) / 457, 4487, 585, 4743, 584/ +data (chrtab(i), i=0436,0440) / 4807, 0, 152, 4247, 4311/ +data (chrtab(i), i=0441,0445) / 4312, 4248, 153, 4313, 4376/ +data (chrtab(i), i=0446,0450) / 4375, 4310, 4246, 4183, 4184/ +data (chrtab(i), i=0451,0455) / 4250, 4315, 4508, 4764, 4955/ +data (chrtab(i), i=0456,0460) / 5018, 5080, 5078, 5012, 4818/ +data (chrtab(i), i=0461,0465) / 4496, 4367, 4237, 4170, 4167/ +data (chrtab(i), i=0466,0470) / 858, 5016, 5014, 4948, 668/ +data (chrtab(i), i=0471,0475) / 4891, 4952, 4950, 4884, 4754/ +data (chrtab(i), i=0476,0480) / 4496, 73, 4234, 4362, 4681/ +data (chrtab(i), i=0481,0485) / 4937, 5066, 266, 4680, 4936/ +data (chrtab(i), i=0486,0490) / 5001, 266, 4679, 4935, 5000/ +data (chrtab(i), i=0491,0495) / 5066, 5068, 0, 152, 4247/ +data (chrtab(i), i=0496,0500) / 4311, 4312, 4248, 153, 4313/ +data (chrtab(i), i=0501,0505) / 4376, 4375, 4310, 4246, 4183/ +data (chrtab(i), i=0506,0510) / 4184, 4250, 4315, 4508, 4764/ +data (chrtab(i), i=0511,0515) / 4955, 5017, 5014, 4948, 4755/ +data (chrtab(i), i=0516,0520) / 795, 4953, 4950, 4884, 604/ +data (chrtab(i), i=0521,0525) / 4827, 4889, 4886, 4820, 4691/ +data (chrtab(i), i=0526,0530) / 467, 4755, 4882, 5008, 5070/ +data (chrtab(i), i=0531,0535) / 5067, 5001, 4936, 4743, 4487/ +data (chrtab(i), i=0536,0540) / 4296, 4233, 4171, 4172, 4237/ +data (chrtab(i), i=0541,0545) / 4301, 4364, 4363, 4298, 4234/ +data (chrtab(i), i=0546,0550) / 848, 5006, 5003, 4937, 595/ +data (chrtab(i), i=0551,0555) / 4818, 4881, 4942, 4939, 4872/ +data (chrtab(i), i=0556,0560) / 4743, 140, 4235, 4299, 4300/ +data (chrtab(i), i=0561,0565) / 4236, 0, 601, 4679, 666/ +data (chrtab(i), i=0566,0570) / 4744, 732, 4807, 732, 4109/ +data (chrtab(i), i=0571,0575) / 5133, 391, 4999, 584, 4551/ +data (chrtab(i), i=0576,0580) / 585, 4615, 713, 4871, 712/ +data (chrtab(i), i=0581,0585) / 4935, 0, 220, 4178, 4308/ +data (chrtab(i), i=0586,0590) / 4501, 4693, 4884, 5010, 5071/ +data (chrtab(i), i=0591,0595) / 5069, 5002, 4872, 4679, 4487/ +data (chrtab(i), i=0596,0600) / 4296, 4233, 4171, 4172, 4237/ +data (chrtab(i), i=0601,0605) / 4301, 4364, 4363, 4298, 4234/ +data (chrtab(i), i=0606,0610) / 850, 5008, 5004, 4938, 597/ +data (chrtab(i), i=0611,0615) / 4820, 4883, 4944, 4940, 4873/ +data (chrtab(i), i=0616,0620) / 4808, 4679, 140, 4235, 4299/ +data (chrtab(i), i=0621,0625) / 4300, 4236, 220, 4956, 219/ +data (chrtab(i), i=0626,0630) / 4827, 218, 4570, 4827, 4956/ +data (chrtab(i), i=0631,0635) / 0, 793, 4888, 4952, 4953/ +data (chrtab(i), i=0636,0640) / 4889, 858, 4890, 4825, 4824/ +data (chrtab(i), i=0641,0645) / 4887, 4951, 5016, 5017, 4955/ +data (chrtab(i), i=0646,0650) / 4828, 4636, 4443, 4313, 4247/ +data (chrtab(i), i=0651,0655) / 4179, 4173, 4234, 4360, 4551/ +data (chrtab(i), i=0656,0660) / 4679, 4872, 5002, 5069, 5070/ +data (chrtab(i), i=0661,0665) / 5009, 4883, 4692, 4564, 4435/ +data (chrtab(i), i=0666,0670) / 4370, 4304, 281, 4311, 4243/ +data (chrtab(i), i=0671,0675) / 4237, 4298, 4361, 842, 5004/ +data (chrtab(i), i=0676,0680) / 5007, 4945, 540, 4507, 4442/ +data (chrtab(i), i=0681,0685) / 4376, 4308, 4301, 4362, 4424/ +data (chrtab(i), i=0686,0690) / 4551, 583, 4808, 4873, 4940/ +data (chrtab(i), i=0691,0695) / 4943, 4882, 4819, 4692, 0/ +data (chrtab(i), i=0696,0700) / 92, 4182, 988, 5081, 5014/ +data (chrtab(i), i=0701,0705) / 4753, 4687, 4619, 4615, 592/ +data (chrtab(i), i=0706,0710) / 4622, 4555, 4551, 918, 4689/ +data (chrtab(i), i=0711,0715) / 4558, 4491, 4487, 4615, 88/ +data (chrtab(i), i=0716,0720) / 4250, 4380, 4508, 4825, 4953/ +data (chrtab(i), i=0721,0725) / 5018, 5084, 218, 4379, 4507/ +data (chrtab(i), i=0726,0730) / 4634, 88, 4249, 4378, 4506/ +data (chrtab(i), i=0731,0735) / 4825, 0, 412, 4315, 4249/ +data (chrtab(i), i=0736,0740) / 4246, 4308, 4499, 4755, 4948/ +data (chrtab(i), i=0741,0745) / 5014, 5017, 4955, 4764, 4508/ +data (chrtab(i), i=0746,0750) / 283, 4313, 4310, 4372, 788/ +data (chrtab(i), i=0751,0755) / 4950, 4953, 4891, 412, 4443/ +data (chrtab(i), i=0756,0760) / 4377, 4374, 4436, 4499, 659/ +data (chrtab(i), i=0761,0765) / 4820, 4886, 4889, 4827, 4764/ +data (chrtab(i), i=0766,0770) / 403, 4306, 4241, 4175, 4171/ +data (chrtab(i), i=0771,0775) / 4233, 4296, 4487, 4743, 4936/ +data (chrtab(i), i=0776,0780) / 5001, 5067, 5071, 5009, 4946/ +data (chrtab(i), i=0781,0785) / 4755, 209, 4239, 4235, 4297/ +data (chrtab(i), i=0786,0790) / 841, 5003, 5007, 4945, 403/ +data (chrtab(i), i=0791,0795) / 4370, 4303, 4299, 4360, 4487/ +data (chrtab(i), i=0796,0800) / 647, 4872, 4939, 4943, 4882/ +data (chrtab(i), i=0801,0805) / 4755, 0, 203, 4298, 4362/ +data (chrtab(i), i=0806,0810) / 4363, 4299, 851, 4881, 4816/ +data (chrtab(i), i=0811,0815) / 4687, 4559, 4368, 4242, 4181/ +data (chrtab(i), i=0816,0820) / 4182, 4249, 4379, 4572, 4700/ +data (chrtab(i), i=0821,0825) / 4891, 5017, 5078, 5072, 5004/ +data (chrtab(i), i=0826,0830) / 4938, 4808, 4615, 4423, 4296/ +data (chrtab(i), i=0831,0835) / 4234, 4235, 4300, 4364, 4427/ +data (chrtab(i), i=0836,0840) / 4426, 4361, 4297, 210, 4244/ +data (chrtab(i), i=0841,0845) / 4247, 4313, 794, 4953, 5014/ +data (chrtab(i), i=0846,0850) / 5008, 4940, 4874, 463, 4432/ +data (chrtab(i), i=0851,0855) / 4369, 4308, 4311, 4378, 4443/ +data (chrtab(i), i=0856,0860) / 4572, 604, 4827, 4889, 4950/ +data (chrtab(i), i=0861,0865) / 4943, 4875, 4809, 4744, 4615/ +data (chrtab(i), i=0866,0870) / 0, 213, 4244, 4243, 4306/ +data (chrtab(i), i=0871,0875) / 4370, 4435, 4436, 4373, 4309/ +data (chrtab(i), i=0876,0880) / 212, 4307, 4371, 4372, 4308/ +data (chrtab(i), i=0881,0885) / 202, 4233, 4232, 4295, 4359/ +data (chrtab(i), i=0886,0890) / 4424, 4425, 4362, 4298, 201/ +data (chrtab(i), i=0891,0895) / 4296, 4360, 4361, 4297, 0/ +data (chrtab(i), i=0896,0900) / 213, 4244, 4243, 4306, 4370/ +data (chrtab(i), i=0901,0905) / 4435, 4436, 4373, 4309, 212/ +data (chrtab(i), i=0906,0910) / 4307, 4371, 4372, 4308, 328/ +data (chrtab(i), i=0911,0915) / 4359, 4295, 4232, 4233, 4298/ +data (chrtab(i), i=0916,0920) / 4362, 4425, 4422, 4356, 4227/ +data (chrtab(i), i=0921,0925) / 201, 4296, 4360, 4361, 4297/ +data (chrtab(i), i=0926,0930) / 263, 4422, 328, 4356, 0/ +data (chrtab(i), i=0931,0935) / 1177, 4240, 5255, 0, 149/ +data (chrtab(i), i=0936,0940) / 5333, 5332, 149, 4244, 5332/ +data (chrtab(i), i=0941,0945) / 141, 5325, 5324, 141, 4236/ +data (chrtab(i), i=0946,0950) / 5324, 0, 153, 5264, 4231/ +data (chrtab(i), i=0951,0955) / 0, 151, 4248, 4312, 4310/ +data (chrtab(i), i=0956,0960) / 4182, 4184, 4250, 4315, 4444/ +data (chrtab(i), i=0961,0965) / 4700, 4891, 4954, 5016, 5014/ +data (chrtab(i), i=0966,0970) / 4948, 4883, 4625, 794, 4953/ +data (chrtab(i), i=0971,0975) / 4949, 4884, 604, 4827, 4889/ +data (chrtab(i), i=0976,0980) / 4885, 4819, 4754, 465, 4558/ +data (chrtab(i), i=0981,0985) / 4622, 4625, 4561, 458, 4489/ +data (chrtab(i), i=0986,0990) / 4488, 4551, 4615, 4680, 4681/ +data (chrtab(i), i=0991,0995) / 4618, 4554, 457, 4552, 4616/ +data (chrtab(i), i=0996,1000) / 4617, 4553, 0, 1044, 5078/ +data (chrtab(i), i=1001,1005) / 4951, 4759, 4630, 4565, 4498/ +data (chrtab(i), i=1006,1010) / 4495, 4557, 4684, 4876, 5005/ +data (chrtab(i), i=1011,1015) / 5071, 663, 4629, 4562, 4559/ +data (chrtab(i), i=1016,1020) / 4621, 4684, 1047, 5071, 5069/ +data (chrtab(i), i=1021,1025) / 5196, 5324, 5454, 5521, 5523/ +data (chrtab(i), i=1026,1030) / 5462, 5400, 5274, 5147, 4956/ +data (chrtab(i), i=1031,1035) / 4764, 4571, 4442, 4312, 4246/ +data (chrtab(i), i=1036,1040) / 4179, 4176, 4237, 4299, 4425/ +data (chrtab(i), i=1041,1045) / 4552, 4743, 4935, 5128, 5257/ +data (chrtab(i), i=1046,1050) / 5322, 1111, 5135, 5133, 5196/ +data (chrtab(i), i=1051,1055) / 0, 540, 4168, 473, 4935/ +data (chrtab(i), i=1056,1060) / 537, 4999, 540, 5063, 205/ +data (chrtab(i), i=1061,1065) / 4877, 7, 4423, 647, 5191/ +data (chrtab(i), i=1066,1070) / 72, 4103, 72, 4295, 840/ +data (chrtab(i), i=1071,1075) / 4807, 841, 4871, 905, 5127/ +data (chrtab(i), i=1076,1080) / 0, 220, 4295, 283, 4360/ +data (chrtab(i), i=1081,1085) / 348, 4423, 28, 4892, 5083/ +data (chrtab(i), i=1086,1090) / 5146, 5208, 5206, 5140, 5075/ +data (chrtab(i), i=1091,1095) / 4882, 986, 5144, 5142, 5076/ +data (chrtab(i), i=1096,1100) / 796, 5019, 5081, 5077, 5011/ +data (chrtab(i), i=1101,1105) / 4882, 338, 4882, 5073, 5136/ +data (chrtab(i), i=1106,1110) / 5198, 5195, 5129, 5064, 4871/ +data (chrtab(i), i=1111,1115) / 4103, 976, 5134, 5131, 5065/ +data (chrtab(i), i=1116,1120) / 786, 5009, 5071, 5066, 5000/ +data (chrtab(i), i=1121,1125) / 4871, 92, 4315, 156, 4314/ +data (chrtab(i), i=1126,1130) / 412, 4442, 476, 4443, 200/ +data (chrtab(i), i=1131,1135) / 4167, 201, 4231, 329, 4487/ +data (chrtab(i), i=1136,1140) / 328, 4551, 0, 985, 5148/ +data (chrtab(i), i=1141,1145) / 5142, 5081, 4955, 4828, 4636/ +data (chrtab(i), i=1146,1150) / 4443, 4313, 4247, 4180, 4175/ +data (chrtab(i), i=1151,1155) / 4236, 4298, 4424, 4615, 4807/ +data (chrtab(i), i=1156,1160) / 4936, 5066, 5132, 281, 4311/ +data (chrtab(i), i=1161,1165) / 4244, 4239, 4300, 4362, 540/ +data (chrtab(i), i=1166,1170) / 4507, 4376, 4308, 4303, 4363/ +data (chrtab(i), i=1171,1175) / 4488, 4615, 0, 220, 4295/ +data (chrtab(i), i=1176,1180) / 283, 4360, 348, 4423, 28/ +data (chrtab(i), i=1181,1185) / 4764, 4955, 5081, 5143, 5204/ +data (chrtab(i), i=1186,1190) / 5199, 5132, 5066, 4936, 4743/ +data (chrtab(i), i=1191,1195) / 4103, 921, 5079, 5140, 5135/ +data (chrtab(i), i=1196,1200) / 5068, 5002, 668, 4891, 5016/ +data (chrtab(i), i=1201,1205) / 5076, 5071, 5003, 4872, 4743/ +data (chrtab(i), i=1206,1210) / 92, 4315, 156, 4314, 412/ +data (chrtab(i), i=1211,1215) / 4442, 476, 4443, 200, 4167/ +data (chrtab(i), i=1216,1220) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=1221,1225) / 4551, 0, 220, 4295, 283/ +data (chrtab(i), i=1226,1230) / 4360, 348, 4423, 28, 5148/ +data (chrtab(i), i=1231,1235) / 5142, 338, 4818, 726, 4814/ +data (chrtab(i), i=1236,1240) / 7, 5127, 5133, 92, 4315/ +data (chrtab(i), i=1241,1245) / 156, 4314, 412, 4442, 476/ +data (chrtab(i), i=1246,1250) / 4443, 732, 5147, 860, 5146/ +data (chrtab(i), i=1251,1255) / 924, 5145, 988, 5142, 726/ +data (chrtab(i), i=1256,1260) / 4754, 4814, 724, 4690, 4816/ +data (chrtab(i), i=1261,1265) / 723, 4562, 4817, 200, 4167/ +data (chrtab(i), i=1266,1270) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=1271,1275) / 4551, 711, 5128, 839, 5129/ +data (chrtab(i), i=1276,1280) / 903, 5130, 967, 5133, 0/ +data (chrtab(i), i=1281,1285) / 220, 4295, 283, 4360, 348/ +data (chrtab(i), i=1286,1290) / 4423, 28, 5148, 5142, 338/ +data (chrtab(i), i=1291,1295) / 4818, 726, 4814, 7, 4615/ +data (chrtab(i), i=1296,1300) / 92, 4315, 156, 4314, 412/ +data (chrtab(i), i=1301,1305) / 4442, 476, 4443, 732, 5147/ +data (chrtab(i), i=1306,1310) / 860, 5146, 924, 5145, 988/ +data (chrtab(i), i=1311,1315) / 5142, 726, 4754, 4814, 724/ +data (chrtab(i), i=1316,1320) / 4690, 4816, 723, 4562, 4817/ +data (chrtab(i), i=1321,1325) / 200, 4167, 201, 4231, 329/ +data (chrtab(i), i=1326,1330) / 4487, 328, 4551, 0, 985/ +data (chrtab(i), i=1331,1335) / 5148, 5142, 5081, 4955, 4828/ +data (chrtab(i), i=1336,1340) / 4636, 4443, 4313, 4247, 4180/ +data (chrtab(i), i=1341,1345) / 4175, 4236, 4298, 4424, 4615/ +data (chrtab(i), i=1346,1350) / 4807, 4936, 5064, 5127, 5135/ +data (chrtab(i), i=1351,1355) / 281, 4311, 4244, 4239, 4300/ +data (chrtab(i), i=1356,1360) / 4362, 540, 4507, 4376, 4308/ +data (chrtab(i), i=1361,1365) / 4303, 4363, 4488, 4615, 974/ +data (chrtab(i), i=1366,1370) / 5065, 911, 5001, 4936, 719/ +data (chrtab(i), i=1371,1375) / 5327, 783, 5006, 847, 5005/ +data (chrtab(i), i=1376,1380) / 1103, 5133, 1167, 5134, 0/ +data (chrtab(i), i=1381,1385) / 220, 4295, 283, 4360, 348/ +data (chrtab(i), i=1386,1390) / 4423, 988, 5063, 1051, 5128/ +data (chrtab(i), i=1391,1395) / 1116, 5191, 28, 4636, 796/ +data (chrtab(i), i=1396,1400) / 5404, 338, 5074, 7, 4615/ +data (chrtab(i), i=1401,1405) / 775, 5383, 92, 4315, 156/ +data (chrtab(i), i=1406,1410) / 4314, 412, 4442, 476, 4443/ +data (chrtab(i), i=1411,1415) / 860, 5083, 924, 5082, 1180/ +data (chrtab(i), i=1416,1420) / 5210, 1244, 5211, 200, 4167/ +data (chrtab(i), i=1421,1425) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=1426,1430) / 4551, 968, 4935, 969, 4999/ +data (chrtab(i), i=1431,1435) / 1097, 5255, 1096, 5319, 0/ +data (chrtab(i), i=1436,1440) / 220, 4295, 283, 4360, 348/ +data (chrtab(i), i=1441,1445) / 4423, 28, 4636, 7, 4615/ +data (chrtab(i), i=1446,1450) / 92, 4315, 156, 4314, 412/ +data (chrtab(i), i=1451,1455) / 4442, 476, 4443, 200, 4167/ +data (chrtab(i), i=1456,1460) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=1461,1465) / 4551, 0, 476, 4555, 4488/ +data (chrtab(i), i=1466,1470) / 4423, 539, 4619, 4552, 604/ +data (chrtab(i), i=1471,1475) / 4683, 4616, 4423, 4295, 4168/ +data (chrtab(i), i=1476,1480) / 4106, 4108, 4173, 4237, 4300/ +data (chrtab(i), i=1481,1485) / 4299, 4234, 4170, 76, 4171/ +data (chrtab(i), i=1486,1490) / 4235, 4236, 4172, 284, 4892/ +data (chrtab(i), i=1491,1495) / 348, 4571, 412, 4570, 668/ +data (chrtab(i), i=1496,1500) / 4698, 732, 4699, 0, 220/ +data (chrtab(i), i=1501,1505) / 4295, 283, 4360, 348, 4423/ +data (chrtab(i), i=1506,1510) / 1051, 4432, 530, 5063, 594/ +data (chrtab(i), i=1511,1515) / 5127, 596, 5191, 28, 4636/ +data (chrtab(i), i=1516,1520) / 860, 5340, 7, 4615, 775/ +data (chrtab(i), i=1521,1525) / 5319, 92, 4315, 156, 4314/ +data (chrtab(i), i=1526,1530) / 412, 4442, 476, 4443, 988/ +data (chrtab(i), i=1531,1535) / 5147, 1180, 5147, 200, 4167/ +data (chrtab(i), i=1536,1540) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=1541,1545) / 4551, 969, 4935, 969, 5255/ +data (chrtab(i), i=1546,1550) / 0, 220, 4295, 283, 4360/ +data (chrtab(i), i=1551,1555) / 348, 4423, 28, 4636, 7/ +data (chrtab(i), i=1556,1560) / 5063, 5069, 92, 4315, 156/ +data (chrtab(i), i=1561,1565) / 4314, 412, 4442, 476, 4443/ +data (chrtab(i), i=1566,1570) / 200, 4167, 201, 4231, 329/ +data (chrtab(i), i=1571,1575) / 4487, 328, 4551, 647, 5064/ +data (chrtab(i), i=1576,1580) / 775, 5065, 839, 5066, 903/ +data (chrtab(i), i=1581,1585) / 5069, 0, 220, 4296, 220/ +data (chrtab(i), i=1586,1590) / 4743, 284, 4746, 348, 4810/ +data (chrtab(i), i=1591,1595) / 1116, 4743, 1116, 5191, 1179/ +data (chrtab(i), i=1596,1600) / 5256, 1244, 5319, 28, 4444/ +data (chrtab(i), i=1601,1605) / 1116, 5532, 7, 4487, 903/ +data (chrtab(i), i=1606,1610) / 5511, 92, 4315, 1308, 5338/ +data (chrtab(i), i=1611,1615) / 1372, 5339, 200, 4167, 200/ +data (chrtab(i), i=1616,1620) / 4423, 1096, 5063, 1097, 5127/ +data (chrtab(i), i=1621,1625) / 1225, 5383, 1224, 5447, 0/ +data (chrtab(i), i=1626,1630) / 220, 4296, 220, 5191, 284/ +data (chrtab(i), i=1631,1635) / 5130, 348, 5194, 1115, 5191/ +data (chrtab(i), i=1636,1640) / 28, 4444, 924, 5404, 7/ +data (chrtab(i), i=1641,1645) / 4487, 92, 4315, 988, 5211/ +data (chrtab(i), i=1646,1650) / 1244, 5211, 200, 4167, 200/ +data (chrtab(i), i=1651,1655) / 4423, 0, 540, 4443, 4313/ +data (chrtab(i), i=1656,1660) / 4247, 4179, 4176, 4236, 4298/ +data (chrtab(i), i=1661,1665) / 4424, 4615, 4743, 4936, 5066/ +data (chrtab(i), i=1666,1670) / 5132, 5200, 5203, 5143, 5081/ +data (chrtab(i), i=1671,1675) / 4955, 4764, 4636, 281, 4311/ +data (chrtab(i), i=1676,1680) / 4244, 4239, 4300, 4362, 906/ +data (chrtab(i), i=1681,1685) / 5068, 5135, 5140, 5079, 5017/ +data (chrtab(i), i=1686,1690) / 540, 4507, 4376, 4308, 4303/ +data (chrtab(i), i=1691,1695) / 4363, 4488, 4615, 647, 4872/ +data (chrtab(i), i=1696,1700) / 5003, 5071, 5076, 5016, 4891/ +data (chrtab(i), i=1701,1705) / 4764, 0, 220, 4295, 283/ +data (chrtab(i), i=1706,1710) / 4360, 348, 4423, 28, 4892/ +data (chrtab(i), i=1711,1715) / 5083, 5146, 5208, 5205, 5139/ +data (chrtab(i), i=1716,1720) / 5074, 4881, 4433, 986, 5144/ +data (chrtab(i), i=1721,1725) / 5141, 5075, 796, 5019, 5081/ +data (chrtab(i), i=1726,1730) / 5076, 5010, 4881, 7, 4615/ +data (chrtab(i), i=1731,1735) / 92, 4315, 156, 4314, 412/ +data (chrtab(i), i=1736,1740) / 4442, 476, 4443, 200, 4167/ +data (chrtab(i), i=1741,1745) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=1746,1750) / 4551, 0, 540, 4443, 4313/ +data (chrtab(i), i=1751,1755) / 4247, 4179, 4176, 4236, 4298/ +data (chrtab(i), i=1756,1760) / 4424, 4615, 4743, 4936, 5066/ +data (chrtab(i), i=1761,1765) / 5132, 5200, 5203, 5143, 5081/ +data (chrtab(i), i=1766,1770) / 4955, 4764, 4636, 281, 4311/ +data (chrtab(i), i=1771,1775) / 4244, 4239, 4300, 4362, 906/ +data (chrtab(i), i=1776,1780) / 5068, 5135, 5140, 5079, 5017/ +data (chrtab(i), i=1781,1785) / 540, 4507, 4376, 4308, 4303/ +data (chrtab(i), i=1786,1790) / 4363, 4488, 4615, 647, 4872/ +data (chrtab(i), i=1791,1795) / 5003, 5071, 5076, 5016, 4891/ +data (chrtab(i), i=1796,1800) / 4764, 330, 4492, 4621, 4685/ +data (chrtab(i), i=1801,1805) / 4812, 4874, 4932, 4994, 5122/ +data (chrtab(i), i=1806,1810) / 5188, 5190, 838, 4996, 5059/ +data (chrtab(i), i=1811,1815) / 5123, 778, 4997, 5060, 5124/ +data (chrtab(i), i=1816,1820) / 5189, 0, 220, 4295, 283/ +data (chrtab(i), i=1821,1825) / 4360, 348, 4423, 28, 4892/ +data (chrtab(i), i=1826,1830) / 5083, 5146, 5208, 5206, 5140/ +data (chrtab(i), i=1831,1835) / 5075, 4882, 4434, 986, 5144/ +data (chrtab(i), i=1836,1840) / 5142, 5076, 796, 5019, 5081/ +data (chrtab(i), i=1841,1845) / 5077, 5011, 4882, 594, 4817/ +data (chrtab(i), i=1846,1850) / 4879, 5001, 5063, 5191, 5257/ +data (chrtab(i), i=1851,1855) / 5259, 907, 5065, 5128, 5192/ +data (chrtab(i), i=1856,1860) / 721, 4880, 5066, 5129, 5193/ +data (chrtab(i), i=1861,1865) / 5258, 7, 4615, 92, 4315/ +data (chrtab(i), i=1866,1870) / 156, 4314, 412, 4442, 476/ +data (chrtab(i), i=1871,1875) / 4443, 200, 4167, 201, 4231/ +data (chrtab(i), i=1876,1880) / 329, 4487, 328, 4551, 0/ +data (chrtab(i), i=1881,1885) / 921, 5084, 5078, 5017, 4891/ +data (chrtab(i), i=1886,1890) / 4700, 4508, 4315, 4185, 4182/ +data (chrtab(i), i=1891,1895) / 4244, 4434, 4816, 4943, 5005/ +data (chrtab(i), i=1896,1900) / 5002, 4936, 150, 4308, 4435/ +data (chrtab(i), i=1901,1905) / 4817, 4944, 5006, 219, 4249/ +data (chrtab(i), i=1906,1910) / 4247, 4309, 4436, 4818, 5008/ +data (chrtab(i), i=1911,1915) / 5070, 5067, 5001, 4936, 4743/ +data (chrtab(i), i=1916,1920) / 4551, 4360, 4234, 4173, 4167/ +data (chrtab(i), i=1921,1925) / 4234, 0, 28, 4118, 476/ +data (chrtab(i), i=1926,1930) / 4551, 539, 4616, 604, 4679/ +data (chrtab(i), i=1931,1935) / 1052, 5142, 28, 5148, 263/ +data (chrtab(i), i=1936,1940) / 4871, 92, 4118, 156, 4121/ +data (chrtab(i), i=1941,1945) / 220, 4122, 348, 4123, 732/ +data (chrtab(i), i=1946,1950) / 5147, 860, 5146, 924, 5145/ +data (chrtab(i), i=1951,1955) / 988, 5142, 456, 4423, 457/ +data (chrtab(i), i=1956,1960) / 4487, 585, 4743, 584, 4807/ +data (chrtab(i), i=1961,1965) / 0, 220, 4301, 4362, 4488/ +data (chrtab(i), i=1966,1970) / 4679, 4807, 5000, 5130, 5197/ +data (chrtab(i), i=1971,1975) / 5211, 283, 4364, 4426, 348/ +data (chrtab(i), i=1976,1980) / 4428, 4489, 4552, 4679, 28/ +data (chrtab(i), i=1981,1985) / 4636, 924, 5404, 92, 4315/ +data (chrtab(i), i=1986,1990) / 156, 4314, 412, 4442, 476/ +data (chrtab(i), i=1991,1995) / 4443, 988, 5211, 1244, 5211/ +data (chrtab(i), i=1996,2000) / 0, 92, 4615, 156, 4618/ +data (chrtab(i), i=2001,2005) / 4615, 220, 4682, 987, 4615/ +data (chrtab(i), i=2006,2010) / 28, 4508, 732, 5212, 28/ +data (chrtab(i), i=2011,2015) / 4250, 284, 4314, 348, 4315/ +data (chrtab(i), i=2016,2020) / 860, 5083, 1052, 5083, 0/ +data (chrtab(i), i=2021,2025) / 156, 4487, 220, 4492, 4487/ +data (chrtab(i), i=2026,2030) / 284, 4556, 668, 4556, 4487/ +data (chrtab(i), i=2031,2035) / 668, 4999, 732, 5004, 4999/ +data (chrtab(i), i=2036,2040) / 796, 5068, 1179, 5068, 4999/ +data (chrtab(i), i=2041,2045) / 28, 4572, 668, 4892, 988/ +data (chrtab(i), i=2046,2050) / 5468, 28, 4315, 92, 4314/ +data (chrtab(i), i=2051,2055) / 348, 4378, 412, 4379, 1052/ +data (chrtab(i), i=2056,2060) / 5275, 1308, 5275, 0, 92/ +data (chrtab(i), i=2061,2065) / 4935, 156, 4999, 220, 5063/ +data (chrtab(i), i=2066,2070) / 923, 4232, 28, 4508, 732/ +data (chrtab(i), i=2071,2075) / 5212, 7, 4423, 647, 5191/ +data (chrtab(i), i=2076,2080) / 28, 4314, 284, 4314, 348/ +data (chrtab(i), i=2081,2085) / 4315, 796, 5019, 1052, 5019/ +data (chrtab(i), i=2086,2090) / 136, 4103, 136, 4359, 840/ +data (chrtab(i), i=2091,2095) / 4807, 841, 4871, 841, 5127/ +data (chrtab(i), i=2096,2100) / 0, 92, 4625, 4615, 156/ +data (chrtab(i), i=2101,2105) / 4689, 4680, 220, 4753, 4743/ +data (chrtab(i), i=2106,2110) / 1051, 4753, 28, 4508, 860/ +data (chrtab(i), i=2111,2115) / 5340, 327, 4935, 28, 4251/ +data (chrtab(i), i=2116,2120) / 348, 4315, 924, 5147, 1180/ +data (chrtab(i), i=2121,2125) / 5147, 520, 4487, 521, 4551/ +data (chrtab(i), i=2126,2130) / 649, 4807, 648, 4871, 0/ +data (chrtab(i), i=2131,2135) / 988, 4188, 4182, 860, 4167/ +data (chrtab(i), i=2136,2140) / 924, 4231, 988, 4295, 71/ +data (chrtab(i), i=2141,2145) / 5063, 5069, 156, 4182, 220/ +data (chrtab(i), i=2146,2150) / 4185, 284, 4186, 412, 4187/ +data (chrtab(i), i=2151,2155) / 647, 5064, 775, 5065, 839/ +data (chrtab(i), i=2156,2160) / 5066, 903, 5069, 0, 160/ +data (chrtab(i), i=2161,2165) / 4224, 224, 4288, 160, 4704/ +data (chrtab(i), i=2166,2170) / 128, 4672, 0, 28, 4868/ +data (chrtab(i), i=2171,2175) / 0, 480, 4544, 544, 4608/ +data (chrtab(i), i=2176,2180) / 96, 4640, 64, 4608, 0/ +data (chrtab(i), i=2181,2185) / 278, 4505, 4630, 83, 4504/ +data (chrtab(i), i=2186,2190) / 4819, 408, 4487, 0, 5/ +data (chrtab(i), i=2191,2195) / 4997, 0, 348, 4315, 4249/ +data (chrtab(i), i=2196,2200) / 4246, 4309, 4373, 4438, 4439/ +data (chrtab(i), i=2201,2205) / 4376, 4312, 4247, 215, 4310/ +data (chrtab(i), i=2206,2210) / 4374, 4375, 4311, 219, 4247/ +data (chrtab(i), i=2211,2215) / 153, 4312, 0, 210, 4307/ +data (chrtab(i), i=2216,2220) / 4371, 4369, 4241, 4243, 4308/ +data (chrtab(i), i=2221,2225) / 4437, 4693, 4820, 4883, 4945/ +data (chrtab(i), i=2226,2230) / 4938, 5000, 5063, 723, 4881/ +data (chrtab(i), i=2231,2235) / 4874, 4936, 597, 4756, 4818/ +data (chrtab(i), i=2236,2240) / 4810, 4872, 5063, 5127, 720/ +data (chrtab(i), i=2241,2245) / 4751, 4430, 4237, 4171, 4170/ +data (chrtab(i), i=2246,2250) / 4232, 4423, 4615, 4744, 4810/ +data (chrtab(i), i=2251,2255) / 205, 4235, 4234, 4296, 655/ +data (chrtab(i), i=2256,2260) / 4494, 4365, 4299, 4298, 4360/ +data (chrtab(i), i=2261,2265) / 4423, 0, 220, 4295, 4360/ +data (chrtab(i), i=2266,2270) / 4488, 283, 4361, 28, 4444/ +data (chrtab(i), i=2271,2275) / 4424, 338, 4500, 4629, 4757/ +data (chrtab(i), i=2276,2280) / 4948, 5074, 5135, 5133, 5066/ +data (chrtab(i), i=2281,2285) / 4936, 4743, 4615, 4488, 4426/ +data (chrtab(i), i=2286,2290) / 914, 5072, 5068, 5002, 661/ +data (chrtab(i), i=2291,2295) / 4884, 4947, 5008, 5004, 4937/ +data (chrtab(i), i=2296,2300) / 4872, 4743, 92, 4315, 156/ +data (chrtab(i), i=2301,2305) / 4314, 0, 849, 4946, 4882/ +data (chrtab(i), i=2306,2310) / 4880, 5008, 5010, 4884, 4757/ +data (chrtab(i), i=2311,2315) / 4565, 4372, 4242, 4175, 4173/ +data (chrtab(i), i=2316,2320) / 4234, 4360, 4551, 4679, 4872/ +data (chrtab(i), i=2321,2325) / 5002, 210, 4240, 4236, 4298/ +data (chrtab(i), i=2326,2330) / 469, 4436, 4371, 4304, 4300/ +data (chrtab(i), i=2331,2335) / 4361, 4424, 4551, 0, 796/ +data (chrtab(i), i=2336,2340) / 4871, 5191, 859, 4936, 604/ +data (chrtab(i), i=2341,2345) / 5020, 4999, 786, 4820, 4693/ +data (chrtab(i), i=2346,2350) / 4565, 4372, 4242, 4175, 4173/ +data (chrtab(i), i=2351,2355) / 4234, 4360, 4551, 4679, 4808/ +data (chrtab(i), i=2356,2360) / 4874, 210, 4240, 4236, 4298/ +data (chrtab(i), i=2361,2365) / 469, 4436, 4371, 4304, 4300/ +data (chrtab(i), i=2366,2370) / 4361, 4424, 4551, 668, 4891/ +data (chrtab(i), i=2371,2375) / 732, 4890, 905, 5063, 904/ +data (chrtab(i), i=2376,2380) / 5127, 0, 207, 5007, 5009/ +data (chrtab(i), i=2381,2385) / 4947, 4884, 4693, 4565, 4372/ +data (chrtab(i), i=2386,2390) / 4242, 4175, 4173, 4234, 4360/ +data (chrtab(i), i=2391,2395) / 4551, 4679, 4872, 5002, 848/ +data (chrtab(i), i=2396,2400) / 4945, 4883, 210, 4240, 4236/ +data (chrtab(i), i=2401,2405) / 4298, 783, 4882, 4820, 4693/ +data (chrtab(i), i=2406,2410) / 469, 4436, 4371, 4304, 4300/ +data (chrtab(i), i=2411,2415) / 4361, 4424, 4551, 0, 666/ +data (chrtab(i), i=2416,2420) / 4763, 4699, 4697, 4825, 4827/ +data (chrtab(i), i=2421,2425) / 4764, 4572, 4443, 4378, 4311/ +data (chrtab(i), i=2426,2430) / 4295, 346, 4375, 4360, 476/ +data (chrtab(i), i=2431,2435) / 4507, 4441, 4423, 21, 4693/ +data (chrtab(i), i=2436,2440) / 7, 4615, 200, 4167, 201/ +data (chrtab(i), i=2441,2445) / 4231, 329, 4487, 328, 4551/ +data (chrtab(i), i=2446,2450) / 0, 852, 5011, 5076, 5013/ +data (chrtab(i), i=2451,2455) / 4949, 4820, 4755, 405, 4372/ +data (chrtab(i), i=2456,2460) / 4307, 4241, 4239, 4301, 4364/ +data (chrtab(i), i=2461,2465) / 4491, 4619, 4748, 4813, 4879/ +data (chrtab(i), i=2466,2470) / 4881, 4819, 4756, 4629, 4501/ +data (chrtab(i), i=2471,2475) / 275, 4305, 4303, 4365, 653/ +data (chrtab(i), i=2476,2480) / 4815, 4817, 4755, 405, 4436/ +data (chrtab(i), i=2481,2485) / 4370, 4366, 4428, 4491, 523/ +data (chrtab(i), i=2486,2490) / 4684, 4750, 4754, 4692, 4629/ +data (chrtab(i), i=2491,2495) / 205, 4236, 4170, 4169, 4231/ +data (chrtab(i), i=2496,2500) / 4294, 4485, 4741, 4932, 4995/ +data (chrtab(i), i=2501,2505) / 199, 4486, 4742, 4933, 73/ +data (chrtab(i), i=2506,2510) / 4232, 4423, 4743, 4934, 4996/ +data (chrtab(i), i=2511,2515) / 4995, 4929, 4736, 4352, 4161/ +data (chrtab(i), i=2516,2520) / 4099, 4100, 4166, 4359, 256/ +data (chrtab(i), i=2521,2525) / 4225, 4163, 4164, 4230, 4359/ +data (chrtab(i), i=2526,2530) / 0, 220, 4295, 283, 4360/ +data (chrtab(i), i=2531,2535) / 28, 4444, 4423, 337, 4499/ +data (chrtab(i), i=2536,2540) / 4564, 4693, 4885, 5012, 5075/ +data (chrtab(i), i=2541,2545) / 5136, 5127, 915, 5072, 5064/ +data (chrtab(i), i=2546,2550) / 789, 4948, 5009, 4999, 7/ +data (chrtab(i), i=2551,2555) / 4615, 711, 5319, 92, 4315/ +data (chrtab(i), i=2556,2560) / 156, 4314, 200, 4167, 201/ +data (chrtab(i), i=2561,2565) / 4231, 329, 4487, 328, 4551/ +data (chrtab(i), i=2566,2570) / 904, 4871, 905, 4935, 1033/ +data (chrtab(i), i=2571,2575) / 5191, 1032, 5255, 0, 220/ +data (chrtab(i), i=2576,2580) / 4314, 4442, 4444, 4316, 284/ +data (chrtab(i), i=2581,2585) / 4378, 219, 4443, 213, 4295/ +data (chrtab(i), i=2586,2590) / 276, 4360, 21, 4437, 4423/ +data (chrtab(i), i=2591,2595) / 7, 4615, 85, 4308, 149/ +data (chrtab(i), i=2596,2600) / 4307, 200, 4167, 201, 4231/ +data (chrtab(i), i=2601,2605) / 329, 4487, 328, 4551, 0/ +data (chrtab(i), i=2606,2610) / 348, 4442, 4570, 4572, 4444/ +data (chrtab(i), i=2611,2615) / 412, 4506, 347, 4571, 341/ +data (chrtab(i), i=2616,2620) / 4420, 4353, 4288, 404, 4485/ +data (chrtab(i), i=2621,2625) / 4418, 149, 4565, 4549, 4482/ +data (chrtab(i), i=2626,2630) / 4417, 4288, 4096, 4097, 4099/ +data (chrtab(i), i=2631,2635) / 4163, 4161, 4097, 4098, 213/ +data (chrtab(i), i=2636,2640) / 4436, 277, 4435, 0, 220/ +data (chrtab(i), i=2641,2645) / 4295, 283, 4360, 28, 4444/ +data (chrtab(i), i=2646,2650) / 4423, 916, 4427, 591, 5127/ +data (chrtab(i), i=2651,2655) / 590, 5063, 526, 4999, 725/ +data (chrtab(i), i=2656,2660) / 5269, 7, 4615, 711, 5255/ +data (chrtab(i), i=2661,2665) / 92, 4315, 156, 4314, 789/ +data (chrtab(i), i=2666,2670) / 5012, 1109, 5012, 200, 4167/ +data (chrtab(i), i=2671,2675) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=2676,2680) / 4551, 905, 4871, 841, 5191/ +data (chrtab(i), i=2681,2685) / 0, 220, 4295, 283, 4360/ +data (chrtab(i), i=2686,2690) / 28, 4444, 4423, 7, 4615/ +data (chrtab(i), i=2691,2695) / 92, 4315, 156, 4314, 200/ +data (chrtab(i), i=2696,2700) / 4167, 201, 4231, 329, 4487/ +data (chrtab(i), i=2701,2705) / 328, 4551, 0, 213, 4295/ +data (chrtab(i), i=2706,2710) / 276, 4360, 21, 4437, 4423/ +data (chrtab(i), i=2711,2715) / 337, 4499, 4564, 4693, 4885/ +data (chrtab(i), i=2716,2720) / 5012, 5075, 5136, 5127, 915/ +data (chrtab(i), i=2721,2725) / 5072, 5064, 789, 4948, 5009/ +data (chrtab(i), i=2726,2730) / 4999, 1041, 5203, 5268, 5397/ +data (chrtab(i), i=2731,2735) / 5589, 5716, 5779, 5840, 5831/ +data (chrtab(i), i=2736,2740) / 1619, 5776, 5768, 1493, 5652/ +data (chrtab(i), i=2741,2745) / 5713, 5703, 7, 4615, 711/ +data (chrtab(i), i=2746,2750) / 5319, 1415, 6023, 85, 4308/ +data (chrtab(i), i=2751,2755) / 149, 4307, 200, 4167, 201/ +data (chrtab(i), i=2756,2760) / 4231, 329, 4487, 328, 4551/ +data (chrtab(i), i=2761,2765) / 904, 4871, 905, 4935, 1033/ +data (chrtab(i), i=2766,2770) / 5191, 1032, 5255, 1608, 5575/ +data (chrtab(i), i=2771,2775) / 1609, 5639, 1737, 5895, 1736/ +data (chrtab(i), i=2776,2780) / 5959, 0, 213, 4295, 276/ +data (chrtab(i), i=2781,2785) / 4360, 21, 4437, 4423, 337/ +data (chrtab(i), i=2786,2790) / 4499, 4564, 4693, 4885, 5012/ +data (chrtab(i), i=2791,2795) / 5075, 5136, 5127, 915, 5072/ +data (chrtab(i), i=2796,2800) / 5064, 789, 4948, 5009, 4999/ +data (chrtab(i), i=2801,2805) / 7, 4615, 711, 5319, 85/ +data (chrtab(i), i=2806,2810) / 4308, 149, 4307, 200, 4167/ +data (chrtab(i), i=2811,2815) / 201, 4231, 329, 4487, 328/ +data (chrtab(i), i=2816,2820) / 4551, 904, 4871, 905, 4935/ +data (chrtab(i), i=2821,2825) / 1033, 5191, 1032, 5255, 0/ +data (chrtab(i), i=2826,2830) / 469, 4372, 4242, 4175, 4173/ +data (chrtab(i), i=2831,2835) / 4234, 4360, 4551, 4679, 4872/ +data (chrtab(i), i=2836,2840) / 5002, 5069, 5071, 5010, 4884/ +data (chrtab(i), i=2841,2845) / 4693, 4565, 210, 4240, 4236/ +data (chrtab(i), i=2846,2850) / 4298, 842, 5004, 5008, 4946/ +data (chrtab(i), i=2851,2855) / 469, 4436, 4371, 4304, 4300/ +data (chrtab(i), i=2856,2860) / 4361, 4424, 4551, 583, 4808/ +data (chrtab(i), i=2861,2865) / 4873, 4940, 4944, 4883, 4820/ +data (chrtab(i), i=2866,2870) / 4693, 0, 213, 4288, 276/ +data (chrtab(i), i=2871,2875) / 4353, 21, 4437, 4416, 338/ +data (chrtab(i), i=2876,2880) / 4500, 4629, 4757, 4948, 5074/ +data (chrtab(i), i=2881,2885) / 5135, 5133, 5066, 4936, 4743/ +data (chrtab(i), i=2886,2890) / 4615, 4488, 4426, 914, 5072/ +data (chrtab(i), i=2891,2895) / 5068, 5002, 661, 4884, 4947/ +data (chrtab(i), i=2896,2900) / 5008, 5004, 4937, 4872, 4743/ +data (chrtab(i), i=2901,2905) / 0, 4608, 85, 4308, 149/ +data (chrtab(i), i=2906,2910) / 4307, 193, 4160, 194, 4224/ +data (chrtab(i), i=2911,2915) / 322, 4480, 321, 4544, 0/ +data (chrtab(i), i=2916,2920) / 788, 4864, 851, 4929, 724/ +data (chrtab(i), i=2921,2925) / 4948, 5013, 4992, 786, 4820/ +data (chrtab(i), i=2926,2930) / 4693, 4565, 4372, 4242, 4175/ +data (chrtab(i), i=2931,2935) / 4173, 4234, 4360, 4551, 4679/ +data (chrtab(i), i=2936,2940) / 4808, 4874, 210, 4240, 4236/ +data (chrtab(i), i=2941,2945) / 4298, 469, 4436, 4371, 4304/ +data (chrtab(i), i=2946,2950) / 4300, 4361, 4424, 4551, 576/ +data (chrtab(i), i=2951,2955) / 5184, 769, 4736, 770, 4800/ +data (chrtab(i), i=2956,2960) / 898, 5056, 897, 5120, 0/ +data (chrtab(i), i=2961,2965) / 213, 4295, 276, 4360, 21/ +data (chrtab(i), i=2966,2970) / 4437, 4423, 787, 4884, 4820/ +data (chrtab(i), i=2971,2975) / 4818, 4946, 4948, 4885, 4757/ +data (chrtab(i), i=2976,2980) / 4628, 4498, 4431, 7, 4615/ +data (chrtab(i), i=2981,2985) / 85, 4308, 149, 4307, 200/ +data (chrtab(i), i=2986,2990) / 4167, 201, 4231, 329, 4487/ +data (chrtab(i), i=2991,2995) / 328, 4551, 0, 723, 4885/ +data (chrtab(i), i=2996,3000) / 4881, 4819, 4756, 4629, 4373/ +data (chrtab(i), i=3001,3005) / 4244, 4179, 4177, 4239, 4366/ +data (chrtab(i), i=3006,3010) / 4685, 4812, 4873, 148, 4177/ +data (chrtab(i), i=3011,3015) / 144, 4367, 4686, 4813, 780/ +data (chrtab(i), i=3016,3020) / 4808, 83, 4241, 4368, 4687/ +data (chrtab(i), i=3021,3025) / 4814, 4876, 4873, 4808, 4679/ +data (chrtab(i), i=3026,3030) / 4423, 4296, 4233, 4171, 4167/ +data (chrtab(i), i=3031,3035) / 4233, 0, 218, 4300, 4361/ +data (chrtab(i), i=3036,3040) / 4424, 4551, 4679, 4808, 4874/ +data (chrtab(i), i=3041,3045) / 282, 4363, 4425, 218, 4444/ +data (chrtab(i), i=3046,3050) / 4427, 4488, 4551, 21, 4693/ +data (chrtab(i), i=3051,3055) / 0, 213, 4300, 4361, 4424/ +data (chrtab(i), i=3056,3060) / 4551, 4743, 4872, 4937, 5003/ +data (chrtab(i), i=3061,3065) / 276, 4363, 4425, 21, 4437/ +data (chrtab(i), i=3066,3070) / 4427, 4488, 4551, 917, 4999/ +data (chrtab(i), i=3071,3075) / 5319, 980, 5064, 725, 5141/ +data (chrtab(i), i=3076,3080) / 5127, 85, 4308, 149, 4307/ +data (chrtab(i), i=3081,3085) / 1033, 5191, 1032, 5255, 0/ +data (chrtab(i), i=3086,3090) / 85, 4551, 149, 4553, 213/ +data (chrtab(i), i=3091,3095) / 4617, 852, 4617, 4551, 21/ +data (chrtab(i), i=3096,3100) / 4501, 597, 5077, 21, 4307/ +data (chrtab(i), i=3101,3105) / 341, 4308, 725, 4948, 917/ +data (chrtab(i), i=3106,3110) / 4948, 0, 149, 4487, 213/ +data (chrtab(i), i=3111,3115) / 4490, 277, 4554, 661, 4554/ +data (chrtab(i), i=3116,3120) / 4487, 661, 4999, 725, 5002/ +data (chrtab(i), i=3121,3125) / 661, 4885, 5066, 1172, 5066/ +data (chrtab(i), i=3126,3130) / 4999, 21, 4565, 981, 5461/ +data (chrtab(i), i=3131,3135) / 21, 4308, 405, 4372, 1045/ +data (chrtab(i), i=3136,3140) / 5268, 1301, 5268, 0, 149/ +data (chrtab(i), i=3141,3145) / 4871, 213, 4935, 277, 4999/ +data (chrtab(i), i=3146,3150) / 852, 4296, 21, 4565, 661/ +data (chrtab(i), i=3151,3155) / 5141, 7, 4487, 583, 5127/ +data (chrtab(i), i=3156,3160) / 85, 4308, 405, 4372, 725/ +data (chrtab(i), i=3161,3165) / 4948, 981, 4948, 200, 4167/ +data (chrtab(i), i=3166,3170) / 200, 4423, 776, 4743, 840/ +data (chrtab(i), i=3171,3175) / 5063, 0, 149, 4615, 213/ +data (chrtab(i), i=3176,3180) / 4617, 277, 4681, 916, 4681/ +data (chrtab(i), i=3181,3185) / 4483, 4353, 4224, 4096, 4097/ +data (chrtab(i), i=3186,3190) / 4099, 4163, 4161, 4097, 4098/ +data (chrtab(i), i=3191,3195) / 21, 4565, 661, 5141, 85/ +data (chrtab(i), i=3196,3200) / 4371, 405, 4372, 789, 5012/ +data (chrtab(i), i=3201,3205) / 981, 5012, 0, 725, 4167/ +data (chrtab(i), i=3206,3210) / 789, 4231, 853, 4295, 853/ +data (chrtab(i), i=3211,3215) / 4181, 4177, 71, 4935, 4939/ +data (chrtab(i), i=3216,3220) / 149, 4177, 213, 4178, 277/ +data (chrtab(i), i=3221,3225) / 4179, 405, 4180, 519, 4936/ +data (chrtab(i), i=3226,3230) / 647, 4937, 711, 4938, 775/ +data (chrtab(i), i=3231,3235) / 4939, 0, 480, 4447, 4382/ +data (chrtab(i), i=3236,3240) / 4316, 4314, 4376, 4439, 4501/ +data (chrtab(i), i=3241,3245) / 4499, 4369, 351, 4381, 4379/ +data (chrtab(i), i=3246,3250) / 4441, 4504, 4566, 4564, 4498/ +data (chrtab(i), i=3251,3255) / 4240, 4494, 4556, 4554, 4488/ +data (chrtab(i), i=3256,3260) / 4423, 4357, 4355, 4417, 271/ +data (chrtab(i), i=3261,3265) / 4493, 4491, 4425, 4360, 4294/ +data (chrtab(i), i=3266,3270) / 4292, 4354, 4417, 4544, 0/ +data (chrtab(i), i=3271,3275) / 160, 4224, 0, 224, 4447/ +data (chrtab(i), i=3276,3280) / 4510, 4572, 4570, 4504, 4439/ +data (chrtab(i), i=3281,3285) / 4373, 4371, 4497, 351, 4509/ +data (chrtab(i), i=3286,3290) / 4507, 4441, 4376, 4310, 4308/ +data (chrtab(i), i=3291,3295) / 4370, 4624, 4366, 4300, 4298/ +data (chrtab(i), i=3296,3300) / 4360, 4423, 4485, 4483, 4417/ +data (chrtab(i), i=3301,3305) / 399, 4365, 4363, 4425, 4488/ +data (chrtab(i), i=3306,3310) / 4550, 4548, 4482, 4417, 4288/ +data (chrtab(i), i=3311,3315) / 0, 77, 4175, 4242, 4371/ +data (chrtab(i), i=3316,3320) / 4499, 4626, 4879, 5006, 5134/ +data (chrtab(i), i=3321,3325) / 5263, 5329, 79, 4241, 4370/ +data (chrtab(i), i=3326,3330) / 4498, 4625, 4878, 5005, 5133/ +data (chrtab(i), i=3331,3335) / 5262, 5329, 5331, 0, 284/ +data (chrtab(i), i=3336,3340) / 4251, 4185, 4183, 4245, 4372/ +data (chrtab(i), i=3341,3345) / 4500, 4629, 4695, 4697, 4635/ +data (chrtab(i), i=3346,3350) / 4508, 4380, 284, 4185, 4245/ +data (chrtab(i), i=3351,3355) / 4500, 4695, 4635, 4380, 412/ +data (chrtab(i), i=3356,3360) / 4251, 4183, 4372, 4629, 4697/ +data (chrtab(i), i=3361,3362) / 4508, 0/ diff --git a/sys/gio/sgikern/font.h b/sys/gio/sgikern/font.h new file mode 100644 index 00000000..eb2e72f4 --- /dev/null +++ b/sys/gio/sgikern/font.h @@ -0,0 +1,29 @@ +# FONT.H -- Font definitions. + +define CHARACTER_START 32 +define CHARACTER_END 126 +define CHARACTER_HEIGHT 26 +define CHARACTER_WIDTH 17 + +define FONT_LEFT 0 +define FONT_CENTER 9 +define FONT_RIGHT 27 +define FONT_TOP 36 +define FONT_CAP 34 +define FONT_HALF 23 +define FONT_BASE 9 +define FONT_BOTTOM 0 +define FONT_WIDTH 27 +define FONT_HEIGHT 36 + +define COORD_X_START 7 +define COORD_Y_START 1 +define COORD_PEN_START 13 +define COORD_X_LEN 6 +define COORD_Y_LEN 6 +define COORD_PEN_LEN 1 + +define PAINT_BEGIN_START 14 +define PAINT_END_START 15 +define PAINT_BEGIN_LEN 1 +define PAINT_END_LEN 1 diff --git a/sys/gio/sgikern/greek.com b/sys/gio/sgikern/greek.com new file mode 100644 index 00000000..cb9fffdc --- /dev/null +++ b/sys/gio/sgikern/greek.com @@ -0,0 +1,501 @@ +# GCHTAB -- Table of strokes for the printable GREEK characters. Each +# character is encoded as a series of strokes. Each stroke is ex- +# pressed by a single integer containing the following bitfields: +# +# 2 1 +# 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 +# | | | | | | | +# | | | +---------+ +---------+ +# | | | | | +# | | | X Y +# | | | +# | | +-- pen up/down +# | +---- begin paint (not used at present) +# +------ end paint (not used at present) +# +#---------------------------------------------------------------------------- + +# Define the database. + +short gchidx[97] # character index in gchtab +short gchwid[97] # character width table +short gchtab[2140] # stroke data to draw the characters + +# Index into CHRTAB of each printable character (starting with SP) + +data (gchidx(i), i=001,005) / 1, 3, 16, 29, 38/ +data (gchidx(i), i=006,010) / 77, 107, 154, 162, 181/ +data (gchidx(i), i=011,015) / 200, 205, 212, 233, 240/ +data (gchidx(i), i=016,020) / 246, 259, 297, 306, 348/ +data (gchidx(i), i=021,025) / 392, 402, 437, 483, 510/ +data (gchidx(i), i=026,030) / 568, 614, 645, 658, 666/ +data (gchidx(i), i=031,035) / 673, 681, 688, 741, 767/ +data (gchidx(i), i=036,040) / 793, 795, 806, 821, 863/ +data (gchidx(i), i=041,045) / 874, 883, 888, 899, 901/ +data (gchidx(i), i=046,050) / 912, 921, 930, 972, 987/ +data (gchidx(i), i=051,055) / 1037, 1067, 1083, 1088, 1117/ +data (gchidx(i), i=056,060) / 1143, 1182, 1207, 1242, 1244/ +data (gchidx(i), i=061,065) / 1253, 1256, 1265, 1267, 1276/ +data (gchidx(i), i=066,070) / 1284, 1321, 1373, 1394, 1436/ +data (gchidx(i), i=071,075) / 1465, 1500, 1525, 1554, 1568/ +data (gchidx(i), i=076,080) / 1610, 1635, 1655, 1679, 1699/ +data (gchidx(i), i=081,085) / 1729, 1746, 1788, 1817, 1849/ +data (gchidx(i), i=086,090) / 1862, 1891, 1893, 1934, 1975/ +data (gchidx(i), i=091,095) / 2006, 2036, 2074, 2079, 2117/ +data (gchidx(i), i=096,096) / 2126/ + + +# Width data. + +data (gchwid(i), i=001,005) / 21, 15, 15, 26, 25/ +data (gchwid(i), i=006,010) / 29, 30, 15, 19, 19/ +data (gchwid(i), i=011,015) / 27, 29, 30, 29, 15/ +data (gchwid(i), i=016,020) / 31, 25, 25, 25, 25/ +data (gchwid(i), i=021,025) / 25, 25, 25, 25, 25/ +data (gchwid(i), i=026,030) / 25, 29, 15, 29, 31/ +data (gchwid(i), i=031,035) / 29, 31, 32, 25, 30/ +data (gchwid(i), i=036,040) / 21, 25, 29, 26, 23/ +data (gchwid(i), i=041,045) / 26, 19, 25, 21, 25/ +data (gchwid(i), i=046,050) / 21, 21, 27, 29, 27/ +data (gchwid(i), i=051,055) / 29, 26, 19, 24, 25/ +data (gchwid(i), i=056,060) / 27, 27, 28, 21, 19/ +data (gchwid(i), i=061,065) / 19, 19, 21, 31, 27/ +data (gchwid(i), i=066,070) / 28, 26, 23, 24, 23/ +data (gchwid(i), i=071,075) / 27, 25, 27, 17, 24/ +data (gchwid(i), i=076,080) / 25, 25, 28, 25, 23/ +data (gchwid(i), i=081,085) / 27, 28, 24, 26, 25/ +data (gchwid(i), i=086,090) / 25, 21, 28, 22, 28/ +data (gchwid(i), i=091,095) / 23, 19, 19, 19, 31/ +data (gchwid(i), i=096,096) / 19/ + + +# Stroke data. + +data (gchtab(i), i=0001,0005) / 35, 0, 220, 4250, 4302/ +data (gchtab(i), i=0006,0010) / 4378, 4316, 218, 4308, 201/ +data (gchtab(i), i=0011,0015) / 4232, 4295, 4360, 4297, 0/ +data (gchtab(i), i=0016,0020) / 213, 4244, 4307, 4372, 4309/ +data (gchtab(i), i=0021,0025) / 199, 4232, 4297, 4360, 4358/ +data (gchtab(i), i=0026,0030) / 4292, 4227, 0, 604, 4224/ +data (gchtab(i), i=0031,0035) / 988, 4608, 145, 5137, 75/ +data (gchtab(i), i=0036,0040) / 5067, 0, 416, 4483, 672/ +data (gchtab(i), i=0041,0045) / 4739, 921, 4952, 5015, 5080/ +data (gchtab(i), i=0046,0050) / 5081, 4955, 4764, 4508, 4315/ +data (gchtab(i), i=0051,0055) / 4185, 4183, 4245, 4308, 4435/ +data (gchtab(i), i=0056,0060) / 4817, 4944, 5070, 87, 4309/ +data (gchtab(i), i=0061,0065) / 4436, 4818, 4945, 5008, 5070/ +data (gchtab(i), i=0066,0070) / 5066, 4936, 4743, 4487, 4296/ +data (gchtab(i), i=0071,0075) / 4170, 4171, 4236, 4299, 4234/ +data (gchtab(i), i=0076,0080) / 0, 1244, 4167, 412, 4634/ +data (gchtab(i), i=0081,0085) / 4632, 4566, 4437, 4309, 4183/ +data (gchtab(i), i=0086,0090) / 4185, 4251, 4380, 4508, 4635/ +data (gchtab(i), i=0091,0095) / 4826, 5018, 5211, 5340, 974/ +data (gchtab(i), i=0096,0100) / 4941, 4875, 4873, 4999, 5127/ +data (gchtab(i), i=0101,0105) / 5256, 5322, 5324, 5198, 5070/ +data (gchtab(i), i=0106,0110) / 0, 1236, 5267, 5330, 5395/ +data (gchtab(i), i=0111,0115) / 5396, 5333, 5269, 5204, 5138/ +data (gchtab(i), i=0116,0120) / 5005, 4874, 4744, 4615, 4423/ +data (gchtab(i), i=0121,0125) / 4232, 4170, 4173, 4239, 4627/ +data (gchtab(i), i=0126,0130) / 4757, 4823, 4825, 4763, 4636/ +data (gchtab(i), i=0131,0135) / 4507, 4441, 4439, 4500, 4625/ +data (gchtab(i), i=0136,0140) / 4938, 5064, 5255, 5319, 5384/ +data (gchtab(i), i=0141,0145) / 5385, 327, 4296, 4234, 4237/ +data (gchtab(i), i=0146,0150) / 4303, 4433, 343, 4501, 5002/ +data (gchtab(i), i=0151,0155) / 5128, 5255, 0, 218, 4251/ +data (gchtab(i), i=0156,0160) / 4316, 4379, 4377, 4311, 4246/ +data (gchtab(i), i=0161,0165) / 0, 608, 4574, 4443, 4311/ +data (gchtab(i), i=0166,0170) / 4242, 4238, 4297, 4421, 4546/ +data (gchtab(i), i=0171,0175) / 4672, 478, 4442, 4375, 4306/ +data (gchtab(i), i=0176,0180) / 4302, 4361, 4422, 4546, 0/ +data (gchtab(i), i=0181,0185) / 96, 4318, 4443, 4567, 4626/ +data (gchtab(i), i=0186,0190) / 4622, 4553, 4421, 4290, 4160/ +data (gchtab(i), i=0191,0195) / 222, 4442, 4503, 4562, 4558/ +data (gchtab(i), i=0196,0200) / 4489, 4422, 4290, 0, 151/ +data (gchtab(i), i=0201,0205) / 5129, 1047, 4233, 0, 664/ +data (gchtab(i), i=0206,0210) / 4743, 144, 5264, 135, 5255/ +data (gchtab(i), i=0211,0215) / 0, 1227, 5195, 5068, 4942/ +data (gchtab(i), i=0216,0220) / 4754, 4691, 4564, 4436, 4307/ +data (gchtab(i), i=0221,0225) / 4241, 4239, 4301, 4428, 4556/ +data (gchtab(i), i=0226,0230) / 4685, 4750, 4946, 5076, 5205/ +data (gchtab(i), i=0231,0235) / 5333, 0, 664, 4743, 152/ +data (gchtab(i), i=0236,0240) / 5272, 144, 5264, 0, 201/ +data (gchtab(i), i=0241,0245) / 4232, 4295, 4360, 4297, 0/ +data (gchtab(i), i=0246,0250) / 729, 4760, 4823, 4888, 4825/ +data (gchtab(i), i=0251,0255) / 144, 5392, 713, 4744, 4807/ +data (gchtab(i), i=0256,0260) / 4872, 4809, 0, 476, 4379/ +data (gchtab(i), i=0261,0265) / 4248, 4179, 4176, 4235, 4360/ +data (gchtab(i), i=0266,0270) / 4551, 4679, 4872, 5003, 5072/ +data (gchtab(i), i=0271,0275) / 5075, 5016, 4891, 4700, 4572/ +data (gchtab(i), i=0276,0280) / 476, 4443, 4378, 4312, 4243/ +data (gchtab(i), i=0281,0285) / 4240, 4299, 4361, 4424, 4551/ +data (gchtab(i), i=0286,0290) / 583, 4808, 4873, 4939, 5008/ +data (gchtab(i), i=0291,0295) / 5011, 4952, 4890, 4827, 4700/ +data (gchtab(i), i=0296,0300) / 0, 280, 4505, 4700, 4679/ +data (gchtab(i), i=0301,0305) / 539, 4615, 263, 4935, 0/ +data (gchtab(i), i=0306,0310) / 152, 4311, 4246, 4183, 4184/ +data (gchtab(i), i=0311,0315) / 4250, 4315, 4508, 4764, 4955/ +data (gchtab(i), i=0316,0320) / 5018, 5080, 5078, 5012, 4818/ +data (gchtab(i), i=0321,0325) / 4496, 4367, 4237, 4170, 4167/ +data (gchtab(i), i=0326,0330) / 668, 4891, 4954, 5016, 5014/ +data (gchtab(i), i=0331,0335) / 4948, 4754, 4496, 73, 4234/ +data (gchtab(i), i=0336,0340) / 4362, 4680, 4872, 5001, 5066/ +data (gchtab(i), i=0341,0345) / 266, 4679, 4935, 5000, 5066/ +data (gchtab(i), i=0346,0350) / 5068, 0, 152, 4311, 4246/ +data (gchtab(i), i=0351,0355) / 4183, 4184, 4250, 4315, 4508/ +data (gchtab(i), i=0356,0360) / 4764, 4955, 5017, 5014, 4948/ +data (gchtab(i), i=0361,0365) / 4755, 4563, 668, 4891, 4953/ +data (gchtab(i), i=0366,0370) / 4950, 4884, 4755, 659, 4882/ +data (gchtab(i), i=0371,0375) / 5008, 5070, 5067, 5001, 4936/ +data (gchtab(i), i=0376,0380) / 4743, 4487, 4296, 4233, 4171/ +data (gchtab(i), i=0381,0385) / 4172, 4237, 4300, 4235, 849/ +data (gchtab(i), i=0386,0390) / 5006, 5003, 4937, 4872, 4743/ +data (gchtab(i), i=0391,0395) / 0, 666, 4743, 732, 4807/ +data (gchtab(i), i=0396,0400) / 732, 4109, 5133, 455, 4999/ +data (gchtab(i), i=0401,0405) / 0, 220, 4178, 82, 4308/ +data (gchtab(i), i=0406,0410) / 4501, 4693, 4884, 5010, 5071/ +data (gchtab(i), i=0411,0415) / 5069, 5002, 4872, 4679, 4487/ +data (gchtab(i), i=0416,0420) / 4296, 4233, 4171, 4172, 4237/ +data (gchtab(i), i=0421,0425) / 4300, 4235, 597, 4820, 4946/ +data (gchtab(i), i=0426,0430) / 5007, 5005, 4938, 4808, 4679/ +data (gchtab(i), i=0431,0435) / 220, 4956, 219, 4635, 4956/ +data (gchtab(i), i=0436,0440) / 0, 857, 4888, 4951, 5016/ +data (gchtab(i), i=0441,0445) / 5017, 4955, 4828, 4636, 4443/ +data (gchtab(i), i=0446,0450) / 4313, 4247, 4179, 4173, 4234/ +data (gchtab(i), i=0451,0455) / 4360, 4551, 4679, 4872, 5002/ +data (gchtab(i), i=0456,0460) / 5069, 5070, 5009, 4883, 4692/ +data (gchtab(i), i=0461,0465) / 4628, 4435, 4305, 4238, 540/ +data (gchtab(i), i=0466,0470) / 4507, 4377, 4311, 4243, 4237/ +data (gchtab(i), i=0471,0475) / 4298, 4424, 4551, 583, 4808/ +data (gchtab(i), i=0476,0480) / 4938, 5005, 5006, 4945, 4819/ +data (gchtab(i), i=0481,0485) / 4692, 0, 92, 4182, 88/ +data (gchtab(i), i=0486,0490) / 4250, 4380, 4508, 4825, 4953/ +data (gchtab(i), i=0491,0495) / 5018, 5084, 154, 4379, 4507/ +data (gchtab(i), i=0496,0500) / 4825, 988, 5081, 5014, 4753/ +data (gchtab(i), i=0501,0505) / 4687, 4620, 4615, 918, 4689/ +data (gchtab(i), i=0506,0510) / 4623, 4556, 4551, 0, 412/ +data (gchtab(i), i=0511,0515) / 4315, 4249, 4246, 4308, 4499/ +data (gchtab(i), i=0516,0520) / 4755, 4948, 5014, 5017, 4955/ +data (gchtab(i), i=0521,0525) / 4764, 4508, 412, 4379, 4313/ +data (gchtab(i), i=0526,0530) / 4310, 4372, 4499, 659, 4884/ +data (gchtab(i), i=0531,0535) / 4950, 4953, 4891, 4764, 403/ +data (gchtab(i), i=0536,0540) / 4306, 4241, 4175, 4171, 4233/ +data (gchtab(i), i=0541,0545) / 4296, 4487, 4743, 4936, 5001/ +data (gchtab(i), i=0546,0550) / 5067, 5071, 5009, 4946, 4755/ +data (gchtab(i), i=0551,0555) / 403, 4370, 4305, 4239, 4235/ +data (gchtab(i), i=0556,0560) / 4297, 4360, 4487, 647, 4872/ +data (gchtab(i), i=0561,0565) / 4937, 5003, 5007, 4945, 4882/ +data (gchtab(i), i=0566,0570) / 4755, 0, 917, 4946, 4816/ +data (gchtab(i), i=0571,0575) / 4623, 4559, 4368, 4242, 4181/ +data (gchtab(i), i=0576,0580) / 4182, 4249, 4379, 4572, 4700/ +data (gchtab(i), i=0581,0585) / 4891, 5017, 5078, 5072, 5004/ +data (gchtab(i), i=0586,0590) / 4938, 4808, 4615, 4423, 4296/ +data (gchtab(i), i=0591,0595) / 4234, 4235, 4300, 4363, 4298/ +data (gchtab(i), i=0596,0600) / 463, 4432, 4306, 4245, 4246/ +data (gchtab(i), i=0601,0605) / 4313, 4443, 4572, 604, 4827/ +data (gchtab(i), i=0606,0610) / 4953, 5014, 5008, 4940, 4874/ +data (gchtab(i), i=0611,0615) / 4744, 4615, 0, 1247, 5278/ +data (gchtab(i), i=0616,0620) / 5341, 5406, 5407, 5344, 5216/ +data (gchtab(i), i=0621,0625) / 5087, 4957, 4891, 4824, 4756/ +data (gchtab(i), i=0626,0630) / 4616, 4548, 4482, 926, 4956/ +data (gchtab(i), i=0631,0635) / 4888, 4748, 4680, 4613, 4547/ +data (gchtab(i), i=0636,0640) / 4417, 4288, 4160, 4097, 4098/ +data (gchtab(i), i=0641,0645) / 4163, 4226, 4161, 0, 213/ +data (gchtab(i), i=0646,0650) / 4244, 4307, 4372, 4309, 199/ +data (gchtab(i), i=0651,0655) / 4232, 4297, 4360, 4358, 4292/ +data (gchtab(i), i=0656,0660) / 4227, 0, 1180, 4245, 5262/ +data (gchtab(i), i=0661,0665) / 140, 5260, 135, 5255, 0/ +data (gchtab(i), i=0666,0670) / 149, 5397, 144, 5392, 139/ +data (gchtab(i), i=0671,0675) / 5387, 0, 156, 5269, 4238/ +data (gchtab(i), i=0676,0680) / 140, 5260, 135, 5255, 0/ +data (gchtab(i), i=0681,0685) / 1177, 4359, 147, 5395, 141/ +data (gchtab(i), i=0686,0690) / 5389, 0, 1044, 5078, 4951/ +data (gchtab(i), i=0691,0695) / 4759, 4630, 4565, 4498, 4495/ +data (gchtab(i), i=0696,0700) / 4557, 4684, 4876, 5005, 5071/ +data (gchtab(i), i=0701,0705) / 663, 4629, 4562, 4559, 4621/ +data (gchtab(i), i=0706,0710) / 4684, 1047, 5071, 5069, 5196/ +data (gchtab(i), i=0711,0715) / 5324, 5454, 5521, 5523, 5462/ +data (gchtab(i), i=0716,0720) / 5400, 5274, 5147, 4956, 4764/ +data (gchtab(i), i=0721,0725) / 4571, 4442, 4312, 4246, 4179/ +data (gchtab(i), i=0726,0730) / 4176, 4237, 4299, 4425, 4552/ +data (gchtab(i), i=0731,0735) / 4743, 4935, 5128, 5257, 5322/ +data (gchtab(i), i=0736,0740) / 1111, 5135, 5133, 5196, 0/ +data (gchtab(i), i=0741,0745) / 473, 4167, 601, 5063, 537/ +data (gchtab(i), i=0746,0750) / 4999, 205, 4877, 7, 4423/ +data (gchtab(i), i=0751,0755) / 711, 5191, 480, 4447, 4381/ +data (gchtab(i), i=0756,0760) / 4379, 4441, 4568, 4696, 4825/ +data (gchtab(i), i=0761,0765) / 4891, 4893, 4831, 4704, 4576/ +data (gchtab(i), i=0766,0770) / 0, 1295, 5325, 5196, 5068/ +data (gchtab(i), i=0771,0775) / 4941, 4878, 4690, 4627, 4500/ +data (gchtab(i), i=0776,0780) / 4372, 4243, 4177, 4175, 4237/ +data (gchtab(i), i=0781,0785) / 4364, 4492, 4621, 4686, 4882/ +data (gchtab(i), i=0786,0790) / 4947, 5076, 5204, 5331, 5393/ +data (gchtab(i), i=0791,0795) / 5391, 0, 35, 0, 540/ +data (gchtab(i), i=0796,0800) / 4103, 540, 5127, 537, 5063/ +data (gchtab(i), i=0801,0805) / 72, 5064, 7, 5127, 0/ +data (gchtab(i), i=0806,0810) / 1176, 4824, 4567, 4438, 4308/ +data (gchtab(i), i=0811,0815) / 4241, 4239, 4300, 4426, 4553/ +data (gchtab(i), i=0816,0820) / 4808, 5256, 144, 5008, 0/ +data (gchtab(i), i=0821,0825) / 540, 4615, 604, 4679, 407/ +data (gchtab(i), i=0826,0830) / 4310, 4245, 4179, 4176, 4238/ +data (gchtab(i), i=0831,0835) / 4301, 4492, 4812, 5005, 5070/ +data (gchtab(i), i=0836,0840) / 5136, 5139, 5077, 5014, 4823/ +data (gchtab(i), i=0841,0845) / 4503, 407, 4374, 4309, 4243/ +data (gchtab(i), i=0846,0850) / 4240, 4302, 4365, 4492, 716/ +data (gchtab(i), i=0851,0855) / 4941, 5006, 5072, 5075, 5013/ +data (gchtab(i), i=0856,0860) / 4950, 4823, 348, 4892, 327/ +data (gchtab(i), i=0861,0865) / 4871, 0, 220, 4295, 284/ +data (gchtab(i), i=0866,0870) / 4359, 28, 5084, 5078, 5020/ +data (gchtab(i), i=0871,0875) / 7, 4551, 0, 608, 4224/ +data (gchtab(i), i=0876,0880) / 992, 4608, 147, 5139, 77/ +data (gchtab(i), i=0881,0885) / 5069, 0, 160, 4224, 544/ +data (gchtab(i), i=0886,0890) / 4608, 0, 28, 4615, 92/ +data (gchtab(i), i=0891,0895) / 4617, 1052, 4615, 28, 5148/ +data (gchtab(i), i=0896,0900) / 91, 5083, 0, 35, 0/ +data (gchtab(i), i=0901,0905) / 540, 4167, 540, 5063, 537/ +data (gchtab(i), i=0906,0910) / 4999, 7, 4423, 711, 5191/ +data (gchtab(i), i=0911,0915) / 0, 278, 4505, 4630, 83/ +data (gchtab(i), i=0916,0920) / 4504, 4819, 408, 4487, 0/ +data (gchtab(i), i=0921,0925) / 266, 4487, 4618, 77, 4488/ +data (gchtab(i), i=0926,0930) / 4813, 409, 4488, 0, 540/ +data (gchtab(i), i=0931,0935) / 4443, 4313, 4247, 4179, 4176/ +data (gchtab(i), i=0936,0940) / 4236, 4298, 4424, 4615, 4743/ +data (gchtab(i), i=0941,0945) / 4936, 5066, 5132, 5200, 5203/ +data (gchtab(i), i=0946,0950) / 5143, 5081, 4955, 4764, 4636/ +data (gchtab(i), i=0951,0955) / 540, 4507, 4377, 4311, 4243/ +data (gchtab(i), i=0956,0960) / 4240, 4300, 4362, 4488, 4615/ +data (gchtab(i), i=0961,0965) / 647, 4872, 5002, 5068, 5136/ +data (gchtab(i), i=0966,0970) / 5139, 5079, 5017, 4891, 4764/ +data (gchtab(i), i=0971,0975) / 0, 220, 4295, 284, 4359/ +data (gchtab(i), i=0976,0980) / 1052, 5127, 1116, 5191, 28/ +data (gchtab(i), i=0981,0985) / 5404, 7, 4551, 839, 5383/ +data (gchtab(i), i=0986,0990) / 0, 540, 4443, 4313, 4247/ +data (gchtab(i), i=0991,0995) / 4179, 4176, 4236, 4298, 4424/ +data (gchtab(i), i=0996,1000) / 4615, 4743, 4936, 5066, 5132/ +data (gchtab(i), i=1001,1005) / 5200, 5203, 5143, 5081, 4955/ +data (gchtab(i), i=1006,1010) / 4764, 4636, 540, 4507, 4377/ +data (gchtab(i), i=1011,1015) / 4311, 4243, 4240, 4300, 4362/ +data (gchtab(i), i=1016,1020) / 4488, 4615, 647, 4872, 5002/ +data (gchtab(i), i=1021,1025) / 5068, 5136, 5139, 5079, 5017/ +data (gchtab(i), i=1026,1030) / 4891, 4764, 405, 4494, 789/ +data (gchtab(i), i=1031,1035) / 4878, 402, 4882, 401, 4881/ +data (gchtab(i), i=1036,1040) / 0, 1244, 4167, 412, 4634/ +data (gchtab(i), i=1041,1045) / 4632, 4566, 4437, 4309, 4183/ +data (gchtab(i), i=1046,1050) / 4185, 4251, 4380, 4508, 4635/ +data (gchtab(i), i=1051,1055) / 4826, 5018, 5211, 5340, 974/ +data (gchtab(i), i=1056,1060) / 4941, 4875, 4873, 4999, 5127/ +data (gchtab(i), i=1061,1065) / 5256, 5322, 5324, 5198, 5070/ +data (gchtab(i), i=1066,1070) / 0, 92, 4626, 4103, 28/ +data (gchtab(i), i=1071,1075) / 4562, 28, 5084, 5142, 5020/ +data (gchtab(i), i=1076,1080) / 72, 5000, 7, 5063, 5133/ +data (gchtab(i), i=1081,1085) / 4999, 0, 160, 4224, 544/ +data (gchtab(i), i=1086,1090) / 4608, 0, 23, 4121, 4187/ +data (gchtab(i), i=1091,1095) / 4252, 4380, 4443, 4505, 4565/ +data (gchtab(i), i=1096,1100) / 4551, 25, 4251, 4379, 4505/ +data (gchtab(i), i=1101,1105) / 983, 5081, 5019, 4956, 4828/ +data (gchtab(i), i=1106,1110) / 4763, 4697, 4629, 4615, 985/ +data (gchtab(i), i=1111,1115) / 4955, 4827, 4697, 263, 4807/ +data (gchtab(i), i=1116,1120) / 0, 473, 4167, 601, 5063/ +data (gchtab(i), i=1121,1125) / 537, 4999, 205, 4877, 7/ +data (gchtab(i), i=1126,1130) / 4423, 711, 5191, 480, 4447/ +data (gchtab(i), i=1131,1135) / 4381, 4379, 4441, 4568, 4696/ +data (gchtab(i), i=1136,1140) / 4825, 4891, 4893, 4831, 4704/ +data (gchtab(i), i=1141,1145) / 4576, 0, 74, 4231, 4487/ +data (gchtab(i), i=1146,1150) / 4363, 4239, 4178, 4182, 4249/ +data (gchtab(i), i=1151,1155) / 4379, 4572, 4828, 5019, 5145/ +data (gchtab(i), i=1156,1160) / 5206, 5202, 5135, 5003, 4871/ +data (gchtab(i), i=1161,1165) / 5127, 5194, 267, 4302, 4242/ +data (gchtab(i), i=1166,1170) / 4246, 4313, 4443, 4572, 732/ +data (gchtab(i), i=1171,1175) / 4955, 5081, 5142, 5138, 5070/ +data (gchtab(i), i=1176,1180) / 5003, 136, 4424, 840, 5128/ +data (gchtab(i), i=1181,1185) / 0, 157, 4184, 1117, 5144/ +data (gchtab(i), i=1186,1190) / 404, 4431, 852, 4879, 139/ +data (gchtab(i), i=1191,1195) / 4166, 1099, 5126, 155, 5147/ +data (gchtab(i), i=1196,1200) / 154, 5146, 402, 4882, 401/ +data (gchtab(i), i=1201,1205) / 4881, 137, 5129, 136, 5128/ +data (gchtab(i), i=1206,1210) / 0, 604, 4679, 668, 4743/ +data (gchtab(i), i=1211,1215) / 21, 4182, 4309, 4369, 4431/ +data (gchtab(i), i=1216,1220) / 4494, 4621, 86, 4245, 4305/ +data (gchtab(i), i=1221,1225) / 4367, 4430, 4621, 4813, 5006/ +data (gchtab(i), i=1226,1230) / 5071, 5137, 5205, 5270, 717/ +data (gchtab(i), i=1231,1235) / 4942, 5007, 5073, 5141, 5270/ +data (gchtab(i), i=1236,1240) / 5333, 412, 4956, 391, 4935/ +data (gchtab(i), i=1241,1245) / 0, 35, 0, 160, 4224/ +data (gchtab(i), i=1246,1250) / 224, 4288, 160, 4704, 128/ +data (gchtab(i), i=1251,1255) / 4672, 0, 28, 4868, 0/ +data (gchtab(i), i=1256,1260) / 480, 4544, 544, 4608, 96/ +data (gchtab(i), i=1261,1265) / 4640, 64, 4608, 0, 35/ +data (gchtab(i), i=1266,1270) / 0, 1106, 5392, 5198, 917/ +data (gchtab(i), i=1271,1275) / 5328, 5003, 144, 5328, 0/ +data (gchtab(i), i=1276,1280) / 85, 4437, 4809, 277, 4807/ +data (gchtab(i), i=1281,1285) / 1312, 4807, 0, 533, 4436/ +data (gchtab(i), i=1286,1290) / 4306, 4240, 4173, 4170, 4232/ +data (gchtab(i), i=1291,1295) / 4423, 4551, 4680, 4875, 5006/ +data (gchtab(i), i=1296,1300) / 5138, 5205, 533, 4500, 4370/ +data (gchtab(i), i=1301,1305) / 4304, 4237, 4234, 4296, 4423/ +data (gchtab(i), i=1306,1310) / 533, 4757, 4884, 4946, 5066/ +data (gchtab(i), i=1311,1315) / 5128, 5191, 661, 4820, 4882/ +data (gchtab(i), i=1316,1320) / 5002, 5064, 5191, 5255, 0/ +data (gchtab(i), i=1321,1325) / 732, 4635, 4505, 4373, 4306/ +data (gchtab(i), i=1326,1330) / 4238, 4168, 4096, 732, 4699/ +data (gchtab(i), i=1331,1335) / 4569, 4437, 4370, 4302, 4232/ +data (gchtab(i), i=1336,1340) / 4160, 732, 4956, 5083, 5146/ +data (gchtab(i), i=1341,1345) / 5143, 5077, 5012, 4819, 4563/ +data (gchtab(i), i=1346,1350) / 860, 5082, 5079, 5013, 4948/ +data (gchtab(i), i=1351,1355) / 4819, 467, 4818, 4944, 5006/ +data (gchtab(i), i=1356,1360) / 5003, 4937, 4872, 4679, 4551/ +data (gchtab(i), i=1361,1365) / 4424, 4361, 4300, 467, 4754/ +data (gchtab(i), i=1366,1370) / 4880, 4942, 4939, 4873, 4808/ +data (gchtab(i), i=1371,1375) / 4679, 0, 21, 4245, 4372/ +data (gchtab(i), i=1376,1380) / 4434, 4739, 4801, 4864, 149/ +data (gchtab(i), i=1381,1385) / 4308, 4370, 4675, 4737, 4864/ +data (gchtab(i), i=1386,1390) / 4992, 981, 5011, 4880, 4229/ +data (gchtab(i), i=1391,1395) / 4098, 4096, 0, 724, 4693/ +data (gchtab(i), i=1396,1400) / 4565, 4372, 4241, 4174, 4171/ +data (gchtab(i), i=1401,1405) / 4233, 4296, 4423, 4551, 4744/ +data (gchtab(i), i=1406,1410) / 4875, 4942, 4945, 4883, 4632/ +data (gchtab(i), i=1411,1415) / 4570, 4572, 4637, 4765, 4892/ +data (gchtab(i), i=1416,1420) / 5018, 469, 4436, 4305, 4238/ +data (gchtab(i), i=1421,1425) / 4234, 4296, 455, 4680, 4811/ +data (gchtab(i), i=1426,1430) / 4878, 4882, 4820, 4695, 4633/ +data (gchtab(i), i=1431,1435) / 4635, 4700, 4828, 5018, 0/ +data (gchtab(i), i=1436,1440) / 850, 4820, 4693, 4437, 4308/ +data (gchtab(i), i=1441,1445) / 4306, 4432, 4623, 341, 4372/ +data (gchtab(i), i=1446,1450) / 4370, 4496, 4623, 527, 4302/ +data (gchtab(i), i=1451,1455) / 4172, 4170, 4232, 4423, 4615/ +data (gchtab(i), i=1456,1460) / 4744, 4874, 527, 4366, 4236/ +data (gchtab(i), i=1461,1465) / 4234, 4296, 4423, 0, 404/ +data (gchtab(i), i=1466,1470) / 4371, 4241, 4174, 4171, 4233/ +data (gchtab(i), i=1471,1475) / 4296, 4423, 4615, 4808, 5002/ +data (gchtab(i), i=1476,1480) / 5133, 5200, 5203, 5077, 4949/ +data (gchtab(i), i=1481,1485) / 4819, 4687, 4554, 4352, 75/ +data (gchtab(i), i=1486,1490) / 4297, 4424, 4616, 4809, 5003/ +data (gchtab(i), i=1491,1495) / 5133, 1107, 5076, 4948, 4818/ +data (gchtab(i), i=1496,1500) / 4687, 4553, 4416, 0, 18/ +data (gchtab(i), i=1501,1505) / 4180, 4309, 4437, 4564, 4627/ +data (gchtab(i), i=1506,1510) / 4688, 4684, 4616, 4416, 19/ +data (gchtab(i), i=1511,1515) / 4244, 4500, 4627, 1045, 5074/ +data (gchtab(i), i=1516,1520) / 5008, 4681, 4484, 4352, 981/ +data (gchtab(i), i=1521,1525) / 5010, 4944, 4681, 0, 17/ +data (gchtab(i), i=1526,1530) / 4115, 4245, 4437, 4500, 4498/ +data (gchtab(i), i=1531,1535) / 4430, 4295, 277, 4436, 4434/ +data (gchtab(i), i=1536,1540) / 4366, 4231, 334, 4562, 4692/ +data (gchtab(i), i=1541,1545) / 4821, 4949, 5076, 5139, 5136/ +data (gchtab(i), i=1546,1550) / 5067, 4864, 853, 5075, 5072/ +data (gchtab(i), i=1551,1555) / 5003, 4800, 0, 277, 4238/ +data (gchtab(i), i=1556,1560) / 4170, 4168, 4231, 4423, 4553/ +data (gchtab(i), i=1561,1565) / 4619, 341, 4302, 4234, 4232/ +data (gchtab(i), i=1566,1570) / 4295, 0, 848, 4883, 4820/ +data (gchtab(i), i=1571,1575) / 4693, 4565, 4372, 4241, 4174/ +data (gchtab(i), i=1576,1580) / 4171, 4233, 4296, 4423, 4551/ +data (gchtab(i), i=1581,1585) / 4744, 4874, 4941, 5010, 5015/ +data (gchtab(i), i=1586,1590) / 4954, 4891, 4764, 4572, 4443/ +data (gchtab(i), i=1591,1595) / 4378, 4377, 4441, 4442, 469/ +data (gchtab(i), i=1596,1600) / 4436, 4305, 4238, 4234, 4296/ +data (gchtab(i), i=1601,1605) / 455, 4680, 4810, 4877, 4946/ +data (gchtab(i), i=1606,1610) / 4951, 4890, 4764, 0, 277/ +data (gchtab(i), i=1611,1615) / 4103, 341, 4167, 917, 5076/ +data (gchtab(i), i=1616,1620) / 5140, 5077, 4949, 4820, 4560/ +data (gchtab(i), i=1621,1625) / 4431, 4303, 335, 4558, 4680/ +data (gchtab(i), i=1626,1630) / 4743, 335, 4494, 4616, 4679/ +data (gchtab(i), i=1631,1635) / 4807, 4936, 5067, 0, 92/ +data (gchtab(i), i=1636,1640) / 4316, 4443, 4506, 4568, 4938/ +data (gchtab(i), i=1641,1645) / 5000, 5063, 220, 4442, 4504/ +data (gchtab(i), i=1646,1650) / 4874, 4936, 5063, 5127, 533/ +data (gchtab(i), i=1651,1655) / 4103, 533, 4167, 0, 341/ +data (gchtab(i), i=1656,1660) / 4096, 405, 4096, 338, 4364/ +data (gchtab(i), i=1661,1665) / 4361, 4487, 4615, 4744, 4874/ +data (gchtab(i), i=1666,1670) / 5005, 1045, 4938, 4936, 4999/ +data (gchtab(i), i=1671,1675) / 5191, 5321, 5387, 1109, 5002/ +data (gchtab(i), i=1676,1680) / 5000, 5063, 0, 277, 4231/ +data (gchtab(i), i=1681,1685) / 341, 4367, 4298, 4231, 981/ +data (gchtab(i), i=1686,1690) / 5009, 4877, 1045, 5074, 5008/ +data (gchtab(i), i=1691,1695) / 4877, 4747, 4553, 4424, 4231/ +data (gchtab(i), i=1696,1700) / 85, 4437, 0, 469, 4372/ +data (gchtab(i), i=1701,1705) / 4241, 4174, 4171, 4233, 4296/ +data (gchtab(i), i=1706,1710) / 4423, 4551, 4744, 4875, 4942/ +data (gchtab(i), i=1711,1715) / 4945, 4883, 4820, 4693, 4565/ +data (gchtab(i), i=1716,1720) / 469, 4436, 4305, 4238, 4234/ +data (gchtab(i), i=1721,1725) / 4296, 455, 4680, 4811, 4878/ +data (gchtab(i), i=1726,1730) / 4882, 4820, 0, 468, 4295/ +data (gchtab(i), i=1731,1735) / 468, 4359, 852, 4935, 852/ +data (gchtab(i), i=1736,1740) / 4999, 18, 4244, 4437, 5269/ +data (gchtab(i), i=1741,1745) / 18, 4243, 4436, 5268, 0/ +data (gchtab(i), i=1746,1750) / 17, 4115, 4245, 4437, 4500/ +data (gchtab(i), i=1751,1755) / 4498, 4429, 4426, 4488, 4551/ +data (gchtab(i), i=1756,1760) / 277, 4436, 4434, 4365, 4362/ +data (gchtab(i), i=1761,1765) / 4424, 4551, 4679, 4808, 4938/ +data (gchtab(i), i=1766,1770) / 5069, 5136, 5205, 5209, 5147/ +data (gchtab(i), i=1771,1775) / 5020, 4892, 4762, 4760, 4821/ +data (gchtab(i), i=1776,1780) / 4946, 5072, 5262, 712, 4939/ +data (gchtab(i), i=1781,1785) / 5005, 5072, 5141, 5145, 5083/ +data (gchtab(i), i=1786,1790) / 5020, 0, 140, 4297, 4360/ +data (gchtab(i), i=1791,1795) / 4487, 4615, 4808, 4939, 5006/ +data (gchtab(i), i=1796,1800) / 5009, 4947, 4884, 4757, 4629/ +data (gchtab(i), i=1801,1805) / 4436, 4305, 4238, 4096, 519/ +data (gchtab(i), i=1806,1810) / 4744, 4875, 4942, 4946, 4884/ +data (gchtab(i), i=1811,1815) / 533, 4500, 4369, 4302, 4096/ +data (gchtab(i), i=1816,1820) / 0, 1109, 4565, 4372, 4241/ +data (gchtab(i), i=1821,1825) / 4174, 4171, 4233, 4296, 4423/ +data (gchtab(i), i=1826,1830) / 4551, 4744, 4875, 4942, 4945/ +data (gchtab(i), i=1831,1835) / 4883, 4820, 4693, 469, 4436/ +data (gchtab(i), i=1836,1840) / 4305, 4238, 4234, 4296, 455/ +data (gchtab(i), i=1841,1845) / 4680, 4811, 4878, 4882, 4820/ +data (gchtab(i), i=1846,1850) / 724, 5204, 0, 596, 4487/ +data (gchtab(i), i=1851,1855) / 596, 4551, 18, 4244, 4437/ +data (gchtab(i), i=1856,1860) / 5141, 18, 4243, 4436, 5140/ +data (gchtab(i), i=1861,1865) / 0, 17, 4115, 4245, 4437/ +data (gchtab(i), i=1866,1870) / 4500, 4498, 4364, 4361, 4487/ +data (gchtab(i), i=1871,1875) / 277, 4436, 4434, 4300, 4297/ +data (gchtab(i), i=1876,1880) / 4360, 4487, 4551, 4744, 4874/ +data (gchtab(i), i=1881,1885) / 5005, 5072, 5075, 5013, 4948/ +data (gchtab(i), i=1886,1890) / 5011, 5072, 909, 5075, 0/ +data (gchtab(i), i=1891,1895) / 35, 0, 145, 4371, 4564/ +data (gchtab(i), i=1896,1900) / 4501, 4372, 4241, 4174, 4171/ +data (gchtab(i), i=1901,1905) / 4232, 4295, 4423, 4552, 4683/ +data (gchtab(i), i=1906,1910) / 4750, 75, 4233, 4296, 4424/ +data (gchtab(i), i=1911,1915) / 4553, 4683, 590, 4683, 4744/ +data (gchtab(i), i=1916,1920) / 4807, 4935, 5064, 5195, 5262/ +data (gchtab(i), i=1921,1925) / 5265, 5204, 5141, 5076, 5203/ +data (gchtab(i), i=1926,1930) / 5265, 587, 4745, 4808, 4936/ +data (gchtab(i), i=1931,1935) / 5065, 5195, 0, 604, 4571/ +data (gchtab(i), i=1936,1940) / 4506, 4505, 4568, 4759, 4951/ +data (gchtab(i), i=1941,1945) / 663, 4502, 4373, 4307, 4305/ +data (gchtab(i), i=1946,1950) / 4431, 4622, 4814, 663, 4566/ +data (gchtab(i), i=1951,1955) / 4437, 4371, 4369, 4495, 4622/ +data (gchtab(i), i=1956,1960) / 526, 4365, 4236, 4170, 4168/ +data (gchtab(i), i=1961,1965) / 4294, 4612, 4675, 4673, 4544/ +data (gchtab(i), i=1966,1970) / 4416, 526, 4429, 4300, 4234/ +data (gchtab(i), i=1971,1975) / 4232, 4358, 4612, 0, 860/ +data (gchtab(i), i=1976,1980) / 4544, 924, 4480, 17, 4115/ +data (gchtab(i), i=1981,1985) / 4245, 4437, 4500, 4498, 4429/ +data (gchtab(i), i=1986,1990) / 4426, 4552, 4744, 4873, 5068/ +data (gchtab(i), i=1991,1995) / 5199, 277, 4436, 4434, 4365/ +data (gchtab(i), i=1996,2000) / 4362, 4424, 4551, 4743, 4872/ +data (gchtab(i), i=2001,2005) / 5002, 5133, 5199, 5333, 0/ +data (gchtab(i), i=2006,2010) / 604, 4571, 4506, 4505, 4568/ +data (gchtab(i), i=2011,2015) / 4759, 5079, 5080, 4887, 4629/ +data (gchtab(i), i=2016,2020) / 4435, 4240, 4173, 4171, 4233/ +data (gchtab(i), i=2021,2025) / 4423, 4613, 4675, 4673, 4608/ +data (gchtab(i), i=2026,2030) / 4480, 4417, 662, 4499, 4304/ +data (gchtab(i), i=2031,2035) / 4237, 4235, 4297, 4423, 0/ +data (gchtab(i), i=2036,2040) / 480, 4447, 4382, 4316, 4314/ +data (gchtab(i), i=2041,2045) / 4376, 4439, 4501, 4499, 4369/ +data (gchtab(i), i=2046,2050) / 351, 4381, 4379, 4441, 4504/ +data (gchtab(i), i=2051,2055) / 4566, 4564, 4498, 4240, 4494/ +data (gchtab(i), i=2056,2060) / 4556, 4554, 4488, 4423, 4357/ +data (gchtab(i), i=2061,2065) / 4355, 4417, 271, 4493, 4491/ +data (gchtab(i), i=2066,2070) / 4425, 4360, 4294, 4292, 4354/ +data (gchtab(i), i=2071,2075) / 4417, 4544, 0, 160, 4224/ +data (gchtab(i), i=2076,2080) / 544, 4608, 0, 224, 4447/ +data (gchtab(i), i=2081,2085) / 4510, 4572, 4570, 4504, 4439/ +data (gchtab(i), i=2086,2090) / 4373, 4371, 4497, 351, 4509/ +data (gchtab(i), i=2091,2095) / 4507, 4441, 4376, 4310, 4308/ +data (gchtab(i), i=2096,2100) / 4370, 4624, 4366, 4300, 4298/ +data (gchtab(i), i=2101,2105) / 4360, 4423, 4485, 4483, 4417/ +data (gchtab(i), i=2106,2110) / 399, 4365, 4363, 4425, 4488/ +data (gchtab(i), i=2111,2115) / 4550, 4548, 4482, 4417, 4288/ +data (gchtab(i), i=2116,2120) / 0, 338, 4240, 4430, 533/ +data (gchtab(i), i=2121,2125) / 4304, 4619, 208, 5392, 0/ +data (gchtab(i), i=2126,2130) / 284, 4251, 4185, 4183, 4245/ +data (gchtab(i), i=2131,2135) / 4372, 4500, 4629, 4695, 4697/ +data (gchtab(i), i=2136,2139) / 4635, 4508, 4380, 0/ diff --git a/sys/gio/sgikern/ltype.dat b/sys/gio/sgikern/ltype.dat new file mode 100644 index 00000000..a5509e21 --- /dev/null +++ b/sys/gio/sgikern/ltype.dat @@ -0,0 +1,28 @@ +# LTYPE.DAT -- Initialize the builtin line types for the SGI kernel. Data +# is given in GKI units (1.0 = 32768 units). A segment of 32 GKI units is +# resolved on a device with 1024 resolved pixels. + +data p_seg /1, 1, 1/ +data p_segleft /320, 32, 512/ + +data p_nseg[1] /2/ # PL_DASHED +data p_penup[1,1] /false/ +data p_penup[1,2] /true/ +data p_seglen[1,1] /320/ +data p_seglen[1,2] /128/ + +data p_nseg[2] /2/ # PL_DOTTED +data p_penup[2,1] /false/ +data p_penup[2,2] /true/ +data p_seglen[2,1] /32/ +data p_seglen[2,2] /128/ + +data p_nseg[3] /4/ # PL_DOTDASH +data p_penup[3,1] /false/ +data p_penup[3,2] /true/ +data p_penup[3,3] /false/ +data p_penup[3,4] /true/ +data p_seglen[3,1] /512/ +data p_seglen[3,2] /128/ +data p_seglen[3,3] /32/ +data p_seglen[3,4] /128/ diff --git a/sys/gio/sgikern/mkpkg b/sys/gio/sgikern/mkpkg new file mode 100644 index 00000000..3dd9e943 --- /dev/null +++ b/sys/gio/sgikern/mkpkg @@ -0,0 +1,53 @@ +# Make the GIO/SGIKERN simple graphics kernel. + +$checkout libsgi.a lib$ +$update libsgi.a +$checkin libsgi.a lib$ +$call relink +$exit + +update: + $call relink + $call install + ; + +relink: + $omake x_sgikern.x + $link x_sgikern.o -lsgi + ; + +install: # install in system library + $move x_sgikern.e bin$ + ; + +libsgi.a: + sgicancel.x sgi.com sgi.h + sgiclear.x sgi.com sgi.h + sgiclose.x sgi.com sgi.h + sgiclws.x sgi.h sgi.com + sgicolor.x sgi.com sgi.h + sgidrawch.x font.com font.h greek.com sgi.com sgi.h \ + + sgiescape.x + sgifa.x sgi.com sgi.h + sgifaset.x sgi.com sgi.h + sgiflush.x sgi.com sgi.h + sgifont.x sgi.com sgi.h + sgigcell.x + sgiinit.x sgi.com sgi.h + sgiline.x sgi.com sgi.h + sgiopen.x sgi.com sgi.h + sgiopenws.x sgi.com sgi.h + sgipcell.x sgi.com sgi.h + sgipl.x ltype.dat sgi.com sgi.h + sgiplset.x sgi.com sgi.h + sgipm.x sgi.com sgi.h + sgipmset.x sgi.com sgi.h + sgireset.x sgi.com sgi.h + sgitx.x font.com font.h greek.com sgi.com sgi.h \ + + sgitxset.x sgi.com sgi.h + sgk.x sgk.com sgk.h + t_sgideco.x sgk.h + t_sgikern.x + ; diff --git a/sys/gio/sgikern/sgi.com b/sys/gio/sgikern/sgi.com new file mode 100644 index 00000000..e050183b --- /dev/null +++ b/sys/gio/sgikern/sgi.com @@ -0,0 +1,17 @@ +# SGI common. A common is necessary since there is no graphics descriptor +# in the argument list of the kernel procedures. The stdgraph data structures +# are designed along the lines of FIO: a small common is used to hold the time +# critical data elements, and an auxiliary dynamically allocated descriptor is +# used for everything else. + +pointer g_kt # kernel transform graphics descriptor +pointer g_tty # graphcap descriptor +int g_nframes # number of frames written +int g_maxframes # max frames per device metafile +int g_ndraw # no draw instr. in current frame +int g_in, g_out # input, output files +int g_xres, g_yres # desired device resolution +char g_device[SZ_GDEVICE] # force output to named device + +common /sgicom/ g_kt, g_tty, g_nframes, g_maxframes, g_ndraw, + g_in, g_out, g_xres, g_yres, g_device diff --git a/sys/gio/sgikern/sgi.h b/sys/gio/sgikern/sgi.h new file mode 100644 index 00000000..a9f1da20 --- /dev/null +++ b/sys/gio/sgikern/sgi.h @@ -0,0 +1,76 @@ +# SGI global definitions. + +define MAX_CHARSIZES 10 # max discreet device char sizes +define SZ_SBUF 1024 # initial string buffer size +define SZ_GDEVICE 31 # maxsize forced device name +define DEF_MAXFRAMES 16 # maximum frames/metafile + +# The SGI state/device descriptor. + +define LEN_SGI 81 + +define SGI_SBUF Memi[$1] # string buffer +define SGI_SZSBUF Memi[$1+1] # size of string buffer +define SGI_NEXTCH Memi[$1+2] # next char pos in string buf +define SGI_NCHARSIZES Memi[$1+3] # number of character sizes +define SGI_POLYLINE Memi[$1+4] # device supports polyline +define SGI_POLYMARKER Memi[$1+5] # device supports polymarker +define SGI_FILLAREA Memi[$1+6] # device supports fillarea +define SGI_CELLARRAY Memi[$1+7] # device supports cell array +define SGI_XRES Memi[$1+8] # device resolution in X +define SGI_YRES Memi[$1+9] # device resolution in Y +define SGI_ZRES Memi[$1+10] # device resolution in Z +define SGI_FILLSTYLE Memi[$1+11] # number of fill styles +define SGI_ROAM Memi[$1+12] # device supports roam +define SGI_ZOOM Memi[$1+13] # device supports zoom +define SGI_SELERASE Memi[$1+14] # device has selective erase +define SGI_PIXREP Memi[$1+15] # device supports pixel replic. +define SGI_STARTFRAME Memi[$1+16] # frame advance at metafile BOF +define SGI_ENDFRAME Memi[$1+17] # frame advance at metafile EOF + # extra space +define SGI_CURSOR Memi[$1+20] # last cursor accessed +define SGI_COLOR Memi[$1+21] # last color set +define SGI_TXSIZE Memi[$1+22] # last text size set +define SGI_TXFONT Memi[$1+23] # last text font set +define SGI_TYPE Memi[$1+24] # last line type set +define SGI_WIDTH Memi[$1+25] # last line width set +define SGI_DEVNAME Memi[$1+26] # name of open device + # extra space +define SGI_CHARHEIGHT Memi[$1+30+$2-1] # character height +define SGI_CHARWIDTH Memi[$1+40+$2-1] # character width +define SGI_CHARSIZE Memr[P2R($1+50+$2-1)] # text sizes permitted +define SGI_PLAP ($1+60) # polyline attributes +define SGI_PMAP ($1+64) # polymarker attributes +define SGI_FAAP ($1+68) # fill area attributes +define SGI_TXAP ($1+71) # default text attributes + +# Substructure definitions. + +define LEN_PL 4 +define PL_STATE Memi[$1] # polyline attributes +define PL_LTYPE Memi[$1+1] +define PL_WIDTH Memi[$1+2] +define PL_COLOR Memi[$1+3] + +define LEN_PM 4 +define PM_STATE Memi[$1] # polymarker attributes +define PM_LTYPE Memi[$1+1] +define PM_WIDTH Memi[$1+2] +define PM_COLOR Memi[$1+3] + +define LEN_FA 3 # fill area attributes +define FA_STATE Memi[$1] +define FA_STYLE Memi[$1+1] +define FA_COLOR Memi[$1+2] + +define LEN_TX 10 # text attributes +define TX_STATE Memi[$1] +define TX_UP Memi[$1+1] +define TX_SIZE Memi[$1+2] +define TX_PATH Memi[$1+3] +define TX_SPACING Memr[P2R($1+4)] +define TX_HJUSTIFY Memi[$1+5] +define TX_VJUSTIFY Memi[$1+6] +define TX_FONT Memi[$1+7] +define TX_QUALITY Memi[$1+8] +define TX_COLOR Memi[$1+9] diff --git a/sys/gio/sgikern/sgicancel.x b/sys/gio/sgikern/sgicancel.x new file mode 100644 index 00000000..d9249d4b --- /dev/null +++ b/sys/gio/sgikern/sgicancel.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "sgi.h" + +# SGI_CANCEL -- Cancel any buffered output. + +procedure sgi_cancel (dummy) + +int dummy # not used at present +include "sgi.com" + +begin + if (g_kt == NULL) + return + call sgi_reset() +end diff --git a/sys/gio/sgikern/sgiclear.x b/sys/gio/sgikern/sgiclear.x new file mode 100644 index 00000000..f2a63d29 --- /dev/null +++ b/sys/gio/sgikern/sgiclear.x @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "sgi.h" + +# SGI_CLEAR -- Advance a frame on the plotter. All attribute packets are +# initialized to their default values. Redundant calls or calls immediately +# after a workstation open (before anything has been drawn) are ignored. + +procedure sgi_clear (dummy) + +int dummy # not used at present + +int sgk_open() +errchk sgk_open +include "sgi.com" + +begin + # This is a no-op if nothing has been drawn. + if (g_kt == NULL || g_ndraw == 0) + return + + # Start a new frame. This is done either by issuing the frame advance + # instruction or by starting a new metafile. Close the output file and + # start a new metafile if the maximum frame count has been reached. + # This disposes of the metafile to the system, causing the actual + # plots to be drawn. Open a new metafile ready to receive next frame. + + g_nframes = g_nframes + 1 + if (g_nframes >= g_maxframes) { + + # Does this device require a frame advance at end of metafile? + if (SGI_ENDFRAME(g_kt) == YES) + call sgk_frame (g_out) + + g_nframes = 0 + call sgk_close (g_out) + g_out = sgk_open (Memc[SGI_DEVNAME(g_kt)], g_tty) + + # Does this device require a frame advance at beginning of metafile? + if (SGI_STARTFRAME(g_kt) == YES) + call sgk_frame (g_out) + + } else { + # Merely output frame instruction to start a new frame in the same + # metafile. + + call sgk_frame (g_out) + } + + # Init kernel data structures. + call sgi_reset() + g_ndraw = 0 +end diff --git a/sys/gio/sgikern/sgiclose.x b/sys/gio/sgikern/sgiclose.x new file mode 100644 index 00000000..380cd01f --- /dev/null +++ b/sys/gio/sgikern/sgiclose.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "sgi.h" + +# SGI_CLOSE -- Close the SGI translation kernel. Close the spool file so +# the output is finally plotted. Free up storage. + +procedure sgi_close() + +include "sgi.com" + +begin + # If there is anything in the metafile, flush it and add a frame + # advance if required for the device. + + if (g_ndraw > 0 || g_nframes > 0) { + # Does this device require a frame advance at end of metafile? + if (SGI_ENDFRAME(g_kt) == YES) + call sgk_frame (g_out) + } + + # Close output metafile, disposing of it to the host system. + call sgk_close (g_out) + + # Free kernel data structures. + call mfree (SGI_SBUF(g_kt), TY_CHAR) + call mfree (g_kt, TY_STRUCT) + + g_kt = NULL +end diff --git a/sys/gio/sgikern/sgiclws.x b/sys/gio/sgikern/sgiclws.x new file mode 100644 index 00000000..e7d29dd7 --- /dev/null +++ b/sys/gio/sgikern/sgiclws.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "sgi.h" + +# SGI_CLOSEWS -- Close the named workstation. Flush the output. +# The spool file is closed only on the next plot or at gktclose time. +# If the spool file is closed here, APPEND mode would not work. + +procedure sgi_closews (devname, n) + +short devname[ARB] # device name (not used) +int n # length of device name +include "sgi.com" + +begin + call sgk_flush (g_out) +end diff --git a/sys/gio/sgikern/sgicolor.x b/sys/gio/sgikern/sgicolor.x new file mode 100644 index 00000000..cdd13708 --- /dev/null +++ b/sys/gio/sgikern/sgicolor.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "sgi.h" + +# SGI_COLOR -- Set line drawing color. + +procedure sgi_color (index) + +int index # index for color switch statement +include "sgi.com" + +begin + # switch (index) { + # case WHITE: + # case RED: + # case GREEN: + # case BLUE: + # default: + # } +end diff --git a/sys/gio/sgikern/sgidrawch.x b/sys/gio/sgikern/sgidrawch.x new file mode 100644 index 00000000..ab7500ea --- /dev/null +++ b/sys/gio/sgikern/sgidrawch.x @@ -0,0 +1,84 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "sgi.h" +include "font.h" + +define ITALIC_TILT 0.30 # fraction of xsize to tilt italics at top + + +# SGI_DRAWCHAR -- Draw a character of the given size and orientation at the +# given position. + +int procedure sgi_drawchar (ch, x, y, xsize, ysize, orien, font) + +char ch # character to be drawn +int x, y # lower left GKI coords of character +int xsize, ysize # width, height of char in GKI units +int orien # orientation of character (0 degrees normal) +int font # desired character font + +int mx, my +real px, py, coso, sino, theta +int stroke, tab1, tab2, i, pen, width +int bitupk() +include "font.com" +include "greek.com" +include "sgi.com" + +begin + if (ch < CHARACTER_START || ch > CHARACTER_END) + i = '?' - CHARACTER_START + 1 + else + i = ch - CHARACTER_START + 1 + + # Set the font. + call sgi_font (font) + + if (font == GT_GREEK) { + width = gchwid[i] + tab1 = gchidx[i] + tab2 = gchidx[i+1] - 1 + } else { + width = chrwid[i] + tab1 = chridx[i] + tab2 = chridx[i+1] - 1 + } + + theta = -DEGTORAD(orien) + coso = cos(theta) + sino = sin(theta) + + do i = tab1, tab2 { + if (font == GT_GREEK) + stroke = gchtab[i] + else + stroke = chrtab[i] + + px = bitupk (stroke, COORD_X_START, COORD_X_LEN) + py = bitupk (stroke, COORD_Y_START, COORD_Y_LEN) + pen = bitupk (stroke, COORD_PEN_START, COORD_PEN_LEN) + + # Scale size of character. + px = px / width * xsize + py = py / FONT_HEIGHT * ysize + + # The italic font is implemented applying a tilt. + if (font == GT_ITALIC) + px = px + ((py / ysize) * xsize * ITALIC_TILT) + + # Rotate and shift. + mx = x + px * coso + py * sino + my = y - px * sino + py * coso + + # Draw the line segment or move pen. + if (pen == 0) + call sgk_move (g_out, mx, my) + else + call sgk_draw (g_out, mx, my) + } + + return (int(real(width) / real(FONT_WIDTH) * xsize)) +end diff --git a/sys/gio/sgikern/sgiescape.x b/sys/gio/sgikern/sgiescape.x new file mode 100644 index 00000000..ff2480cd --- /dev/null +++ b/sys/gio/sgikern/sgiescape.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# SGI_ESCAPE -- Pass a device dependent instruction on to the kernel. +# The SGK kernel does not have any escape functions at present. + +procedure sgi_escape (fn, instruction, nwords) + +int fn # function code +short instruction[ARB] # instruction data words +int nwords # length of instruction + +begin +end diff --git a/sys/gio/sgikern/sgifa.x b/sys/gio/sgikern/sgifa.x new file mode 100644 index 00000000..37793f22 --- /dev/null +++ b/sys/gio/sgikern/sgifa.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "sgi.h" + +# SGI_FILLAREA -- Fill a closed area. + +procedure sgi_fillarea (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs +include "sgi.com" + +begin + # This kernel doesn't have any real fill area capability yet; if + # fill area is enabled in the graphcap entry, just draw the outline + # of the area. + + if (SGI_FILLAREA(g_kt) == YES) + call sgi_polyline (p, npts) +end diff --git a/sys/gio/sgikern/sgifaset.x b/sys/gio/sgikern/sgifaset.x new file mode 100644 index 00000000..c3810252 --- /dev/null +++ b/sys/gio/sgikern/sgifaset.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "sgi.h" + +# SGI_FASET -- Set the fillarea attributes. + +procedure sgi_faset (gki) + +short gki[ARB] # attribute structure +pointer fa +include "sgi.com" + +begin + fa = SGI_FAAP(g_kt) + FA_STYLE(fa) = gki[GKI_FASET_FS] + FA_COLOR(fa) = gki[GKI_FASET_CI] +end diff --git a/sys/gio/sgikern/sgiflush.x b/sys/gio/sgikern/sgiflush.x new file mode 100644 index 00000000..e3e1b805 --- /dev/null +++ b/sys/gio/sgikern/sgiflush.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "sgi.h" + +# SGI_FLUSH -- Flush output. + +procedure sgi_flush (dummy) + +int dummy # not used at present +include "sgi.com" + +begin + call sgk_flush (g_out) +end diff --git a/sys/gio/sgikern/sgifont.x b/sys/gio/sgikern/sgifont.x new file mode 100644 index 00000000..808c7f56 --- /dev/null +++ b/sys/gio/sgikern/sgifont.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "sgi.h" + +# SGI_FONT -- Set the character font. The roman font is normal. Bold is +# implemented by increasing the vector line width; care must be taken to +# set SGI_WIDTH so that the other vector drawing procedures remember to +# change the width back. The italic font is implemented in the character +# generator by a geometric transformation. + +procedure sgi_font (font) + +int font # code for font to be set + +int normal, bold +int pk1, pk2, width +include "sgi.com" + +begin + width = SGI_WIDTH(g_kt) + normal = 0 + bold = 1 + + pk1 = GKI_PACKREAL(real(normal)) + pk2 = GKI_PACKREAL(real(bold)) + + if (font == GT_BOLD) { + if (width != pk2) { + call sgk_linewidth (g_out, bold) + width = pk2 + } + } else { + if (width != pk1) { + call sgk_linewidth (g_out, normal) + width = pk1 + } + } + + SGI_WIDTH(g_kt) = width +end diff --git a/sys/gio/sgikern/sgigcell.x b/sys/gio/sgikern/sgigcell.x new file mode 100644 index 00000000..4c2bfe06 --- /dev/null +++ b/sys/gio/sgikern/sgigcell.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# SGI_GETCELLARRAY -- Input a cell array, i.e., two dimensional array of pixels +# (greylevels or colors). + +procedure sgi_getcellarray (nx, ny, x1,y1, x2,y2) + +int nx, ny # number of pixels in X and Y +int x1, y1 # lower left corner of input window +int x2, y2 # lower left corner of input window + +begin + # Not implemented yet. +end diff --git a/sys/gio/sgikern/sgiinit.x b/sys/gio/sgikern/sgiinit.x new file mode 100644 index 00000000..54caf25d --- /dev/null +++ b/sys/gio/sgikern/sgiinit.x @@ -0,0 +1,162 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "sgi.h" + +# SGI_INIT -- Initialize the gkt data structures from the graphcap entry +# for the device. Called once, at OPENWS time, with the TTY pointer already +# set in the common. The companion routine SGI_RESET initializes the attribute +# packets when the frame is flushed. + +procedure sgi_init (tty, devname) + +pointer tty # graphcap descriptor +char devname[ARB] # device name + +pointer nextch +int maxch, i +real char_height, char_width, char_size + +bool ttygetb() +real ttygetr() +int ttygeti(), btoi(), gstrcpy() +include "sgi.com" + +begin + # Allocate the gkt descriptor and the string buffer. + if (g_kt == NULL) { + call calloc (g_kt, LEN_SGI, TY_STRUCT) + call malloc (SGI_SBUF(g_kt), SZ_SBUF, TY_CHAR) + } + + # Get the maximum frame count and the flags controlling frame advance + # at start and end of metafile. + + g_maxframes = ttygeti (tty, "MF") + if (g_maxframes == 0) + g_maxframes = DEF_MAXFRAMES + SGI_STARTFRAME(g_kt) = btoi (ttygetb (tty, "FS")) + SGI_ENDFRAME(g_kt) = btoi (ttygetb (tty, "FE")) + + # Init string buffer parameters. The first char of the string buffer + # is reserved as a null string, used for graphcap control strings + # omitted from the graphcap entry for the device. + + SGI_SZSBUF(g_kt) = SZ_SBUF + SGI_NEXTCH(g_kt) = SGI_SBUF(g_kt) + 1 + Memc[SGI_SBUF(g_kt)] = EOS + + # Get the device resolution from the graphcap entry. + + g_xres = ttygeti (tty, "xr") + if (g_xres <= 0) + g_xres = 1024 + g_yres = ttygeti (tty, "yr") + if (g_yres <= 0) + g_yres = 1024 + + # Initialize the character scaling parameters, required for text + # generation. The heights are given in NDC units in the graphcap + # file, which we convert to GKI units. Estimated values are + # supplied if the parameters are missing in the graphcap entry. + + char_height = ttygetr (tty, "ch") + if (char_height < EPSILON) + char_height = 1.0 / 35.0 + char_height = char_height * GKI_MAXNDC + + char_width = ttygetr (tty, "cw") + if (char_width < EPSILON) + char_width = 1.0 / 80.0 + char_width = char_width * GKI_MAXNDC + + # If the device has a set of discreet character sizes, get the + # size of each by fetching the parameter "tN", where the N is + # a digit specifying the text size index. Compute the height and + # width of each size character from the "ch" and "cw" parameters + # and the relative scale of character size I. + + SGI_NCHARSIZES(g_kt) = min (MAX_CHARSIZES, ttygeti (tty, "th")) + nextch = SGI_NEXTCH(g_kt) + + if (SGI_NCHARSIZES(g_kt) <= 0) { + SGI_NCHARSIZES(g_kt) = 1 + SGI_CHARSIZE(g_kt,1) = 1.0 + SGI_CHARHEIGHT(g_kt,1) = char_height + SGI_CHARWIDTH(g_kt,1) = char_width + } else { + Memc[nextch+2] = EOS + for (i=1; i <= SGI_NCHARSIZES(g_kt); i=i+1) { + Memc[nextch] = 't' + Memc[nextch+1] = TO_DIGIT(i) + char_size = ttygetr (tty, Memc[nextch]) + SGI_CHARSIZE(g_kt,i) = char_size + SGI_CHARHEIGHT(g_kt,i) = char_height * char_size + SGI_CHARWIDTH(g_kt,i) = char_width * char_size + } + } + + # Initialize the output parameters. All boolean parameters are stored + # as integer flags. All string valued parameters are stored in the + # string buffer, saving a pointer to the string in the gkt + # descriptor. If the capability does not exist the pointer is set to + # point to the null string at the beginning of the string buffer. + + SGI_POLYLINE(g_kt) = btoi (ttygetb (tty, "pl")) + SGI_POLYMARKER(g_kt) = btoi (ttygetb (tty, "pm")) + SGI_FILLAREA(g_kt) = btoi (ttygetb (tty, "fa")) + SGI_FILLSTYLE(g_kt) = ttygeti (tty, "fs") + SGI_ROAM(g_kt) = btoi (ttygetb (tty, "ro")) + SGI_ZOOM(g_kt) = btoi (ttygetb (tty, "zo")) + SGI_XRES(g_kt) = ttygeti (tty, "xr") + SGI_YRES(g_kt) = ttygeti (tty, "yr") + SGI_ZRES(g_kt) = ttygeti (tty, "zr") + SGI_CELLARRAY(g_kt) = btoi (ttygetb (tty, "ca")) + SGI_SELERASE(g_kt) = btoi (ttygetb (tty, "se")) + SGI_PIXREP(g_kt) = btoi (ttygetb (tty, "pr")) + + # Initialize the input parameters. + + SGI_CURSOR(g_kt) = 1 + + # Save the device string in the descriptor. + nextch = SGI_NEXTCH(g_kt) + SGI_DEVNAME(g_kt) = nextch + maxch = SGI_SBUF(g_kt) + SZ_SBUF - nextch + 1 + nextch = nextch + gstrcpy (devname, Memc[nextch], maxch) + 1 + SGI_NEXTCH(g_kt) = nextch +end + + +# SGI_GSTRING -- Get a string value parameter from the graphcap table, +# placing the string at the end of the string buffer. If the device does +# not have the named capability return a pointer to the null string, +# otherwise return a pointer to the string. Since pointers are used, +# rather than indices, the string buffer is fixed in size. The additional +# degree of indirection required with an index was not considered worthwhile +# in this application since the graphcap entries are never very large. + +pointer procedure sgi_gstring (cap) + +char cap[ARB] # device capability to be fetched +pointer strp, nextch +int maxch, nchars +int ttygets() +include "sgi.com" + +begin + nextch = SGI_NEXTCH(g_kt) + maxch = SGI_SBUF(g_kt) + SZ_SBUF - nextch + 1 + + nchars = ttygets (g_tty, cap, Memc[nextch], maxch) + if (nchars > 0) { + strp = nextch + nextch = nextch + nchars + 1 + } else + strp = SGI_SBUF(g_kt) + + SGI_NEXTCH(g_kt) = nextch + return (strp) +end diff --git a/sys/gio/sgikern/sgiline.x b/sys/gio/sgikern/sgiline.x new file mode 100644 index 00000000..086ac158 --- /dev/null +++ b/sys/gio/sgikern/sgiline.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "sgi.h" + +# SGI_LINETYPE -- Set the line type option. + +procedure sgi_linetype (index) + +int index # index for line type switch statement + +int linetype +include "sgi.com" + +begin + switch (index) { + case GL_CLEAR: + linetype = 0 + case GL_DASHED: + linetype = 2 + case GL_DOTTED: + linetype = 3 + case GL_DOTDASH: + linetype = 4 + default: + linetype = 1 # solid + } + + # This will be done in software in a future version of the SGI kernel. + # call sgk_linetype (g_out, linetype) +end diff --git a/sys/gio/sgikern/sgiopen.x b/sys/gio/sgikern/sgiopen.x new file mode 100644 index 00000000..5164ecd7 --- /dev/null +++ b/sys/gio/sgikern/sgiopen.x @@ -0,0 +1,77 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "sgi.h" + +# SGI_OPEN -- Install the SGI kernel as a graphics kernel device driver. +# The device table DD consists of an array of the entry point addresses for +# the driver procedures. If a driver does not implement a particular +# instruction the table entry for that procedure may be set to zero, causing +# the interpreter to ignore the instruction. + +procedure sgi_open (devname, dd) + +char devname[ARB] # nonnull for forced output to a device +int dd[ARB] # device table to be initialized + +pointer sp, devns +int len_devname +int locpr(), strlen() +extern sgi_openws(), sgi_closews(), sgi_clear(), sgi_cancel() +extern sgi_flush(), sgi_polyline(), sgi_polymarker(), sgi_text() +extern sgi_fillarea(), sgi_putcellarray(), sgi_plset() +extern sgi_pmset(), sgi_txset(), sgi_faset() +extern sgi_escape() +include "sgi.com" + +begin + call smark (sp) + call salloc (devns, SZ_FNAME, TY_SHORT) + + # Flag first pass. Save forced device name in common for OPENWS. + # Zero the frame and instruction counters. + + g_kt = NULL + g_nframes = 0 + g_ndraw = 0 + call strcpy (devname, g_device, SZ_GDEVICE) + + # Install the device driver. + + dd[GKI_OPENWS] = locpr (sgi_openws) + dd[GKI_CLOSEWS] = locpr (sgi_closews) + dd[GKI_DEACTIVATEWS] = 0 + dd[GKI_REACTIVATEWS] = 0 + dd[GKI_MFTITLE] = 0 + dd[GKI_CLEAR] = locpr (sgi_clear) + dd[GKI_CANCEL] = locpr (sgi_cancel) + dd[GKI_FLUSH] = locpr (sgi_flush) + dd[GKI_POLYLINE] = locpr (sgi_polyline) + dd[GKI_POLYMARKER] = locpr (sgi_polymarker) + dd[GKI_TEXT] = locpr (sgi_text) + dd[GKI_FILLAREA] = locpr (sgi_fillarea) + dd[GKI_PUTCELLARRAY] = locpr (sgi_putcellarray) + dd[GKI_SETCURSOR] = 0 + dd[GKI_PLSET] = locpr (sgi_plset) + dd[GKI_PMSET] = locpr (sgi_pmset) + dd[GKI_TXSET] = locpr (sgi_txset) + dd[GKI_FASET] = locpr (sgi_faset) + dd[GKI_GETCURSOR] = 0 + dd[GKI_GETCELLARRAY] = 0 + dd[GKI_ESCAPE] = locpr (sgi_escape) + dd[GKI_SETWCS] = 0 + dd[GKI_GETWCS] = 0 + dd[GKI_UNKNOWN] = 0 + + # If a device was named open the workstation as well. This is + # necessary to permit processing of metacode files which do not + # contain the open workstation instruction. + + len_devname = strlen (devname) + if (len_devname > 0) { + call achtcs (devname, Mems[devns], len_devname) + call sgi_openws (Mems[devns], len_devname, NEW_FILE) + } + + call sfree (sp) +end diff --git a/sys/gio/sgikern/sgiopenws.x b/sys/gio/sgikern/sgiopenws.x new file mode 100644 index 00000000..a2a5a7eb --- /dev/null +++ b/sys/gio/sgikern/sgiopenws.x @@ -0,0 +1,98 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "sgi.h" + +# SGI_OPENWS -- Open the named workstation. Once a workstation has been +# opened we leave it open until some other workstation is opened or the +# kernel is closed. Opening a workstation involves initialization of the +# kernel data structures, following by initialization of the device itself. + +procedure sgi_openws (devname, n, mode) + +short devname[ARB] # device name +int n # length of device name +int mode # access mode + +pointer sp, buf +pointer ttygdes() +bool streq() +int sgk_open() +bool need_open, same_dev +include "sgi.com" + +begin + call smark (sp) + call salloc (buf, max (SZ_FNAME, n), TY_CHAR) + + # If a device was named when the kernel was opened then output will + # always go to that device (g_device) regardless of the device named + # in the OPENWS instruction. If no device was named (null string) + # then unpack the device name, passed as a short integer array. + + if (g_device[1] == EOS) { + call achtsc (devname, Memc[buf], n) + Memc[buf+n] = EOS + } else + call strcpy (g_device, Memc[buf], SZ_FNAME) + + # Find out if first time, and if not, if same device as before + # note that if (g_kt == NULL), then same_dev is false. + + same_dev = false + need_open = true + + if (g_kt != NULL) { + same_dev = (streq (Memc[SGI_DEVNAME(g_kt)], Memc[buf])) + if (!same_dev) { + # Does this device require a frame advance at end of metafile? + if (SGI_ENDFRAME(g_kt) == YES) + call sgk_frame (g_out) + call sgk_close (g_out) + } else + need_open = false + } + + # Initialize the kernel data structures. Open graphcap descriptor + # for the named device, allocate and initialize descriptor and common. + # graphcap entry for device must exist. + + if (need_open) { + if (!same_dev) { + if (g_kt != NULL) + call ttycdes (g_tty) + iferr (g_tty = ttygdes (Memc[buf])) + call erract (EA_ERROR) + + # Initialize data structures if we had to open a new device. + call sgi_init (g_tty, Memc[buf]) + call sgi_reset() + } + + # Open the output file. Metacode output to the device will be + # spooled and then disposed of to the device at CLOSEWS time. + + iferr (g_out = sgk_open (Memc[SGI_DEVNAME(g_kt)], g_tty)) { + call ttycdes (g_tty) + call erract (EA_ERROR) + } else { + # Does this device require a frame advance at start of metafile? + if (SGI_STARTFRAME(g_kt) == YES) + call sgk_frame (g_out) + g_nframes = 0 + g_ndraw = 0 + } + } + + # Clear the screen if device is being opened in new_file mode. + # This is a nop if we really opened a new device, but it will clear + # the screen if this is just a reopen of the same device in new file + # mode. + + if (mode == NEW_FILE) + call sgi_clear (0) + + call sfree (sp) +end diff --git a/sys/gio/sgikern/sgipcell.x b/sys/gio/sgikern/sgipcell.x new file mode 100644 index 00000000..b39e6377 --- /dev/null +++ b/sys/gio/sgikern/sgipcell.x @@ -0,0 +1,195 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "sgi.h" + +define DEF_YRES 2048 # default height of device pixel in GKI units +define ZSTEP 4 # bit to be tested (step function width) + + +# SGI_PUTCELLARRAY -- Draw a cell array, i.e., two dimensional array of pixels +# (greylevels or colors). The algorithm used here maps 8 bits in into 1 bit +# out, using a step function lookup table. The result is a band-contoured +# image, where the spacing and width of the contour bands decreases as the +# rate of change of intensity in the input cell array increases. + +procedure sgi_putcellarray (m, nx, ny, ax1,ay1, ax2,ay2) + +short m[nx,ny] # cell array +int nx, ny # number of pixels in X and Y +int ax1, ay1 # lower left corner of output window +int ax2, ay2 # upper right corner of output window + +bool ttygetb() +include "sgi.com" + +begin + if (ttygetb (g_tty, "BI")) + call sgi_bcell (m, nx, ny, ax1,ay1, ax2,ay2) + else + call sgi_mcell (m, nx, ny, ax1,ay1, ax2,ay2) +end + + +# SGI_BCELL -- Put cell array, optimized for a bitmap device. In this case, +# to get the maximum resolution at maximum efficiency it is desirable for the +# main loop to be over device pixels, mapping the device pixel into the +# nearest line of the input cell array. + +procedure sgi_bcell (m, nx, ny, ax1,ay1, ax2,ay2) + +short m[nx,ny] # cell array +int nx, ny # number of pixels in X and Y +int ax1, ay1 # lower left corner of output window +int ax2, ay2 # upper right corner of output window + +real dx, dy +int my, i1, i2, v, i, j, k +include "sgi.com" +int and() + +begin + # Count drawing instruction, set polyline width to 1 for max y-res. + g_ndraw = g_ndraw + 1 + call sgk_linewidth (g_out, 1) + SGI_WIDTH(g_kt) = 0 + + # Determine the width of a cell array pixel in GKI units. + dx = real (ax2 - ax1) / nx + + # Determine the height of a device pixel in GKI units. + if (SGI_YRES(g_kt) <= 0) + dy = GKI_MAXNDC / DEF_YRES + else + dy = max (1.0, real(GKI_MAXNDC) / real(SGI_YRES(g_kt))) + + # Process the cell array. The outer loop runs over device pixels in Y; + # each iteration writes one line of the output raster. The inner loop + # runs down a line of the cell array. + + k = 0 + for (my = ay1 + dy/2; my < ay2; my = k * dy + ay1) { + j = max(1, min(ny, int (real(my-ay1) / real(ay2-ay1) * (ny-1)) + 1)) + my = min (my, int (ay2 - dy/2)) + + for (i=1; i <= nx; ) { + do i = i, nx { + v = m[i,j] + if (and (v, ZSTEP) != 0) + break + } + + if (i <= nx) { + i1 = i + i2 = nx + do i = i1 + 1, nx { + v = m[i,j] + if (and (v, ZSTEP) == 0) { + i2 = i + break + } + } + + # The following decreases the length of dark line segments + # to make features more visible. + + if (i2 - i1 >= 2) + if (i1 > 1 && i2 < nx) { + i1 = i1 + 1 + i2 = i2 - 1 + } + + # Draw the line segment. + call sgk_move (g_out, int ((i1-1) * dx + ax1), my) + call sgk_draw (g_out, int (i2 * dx + ax1), my) + + if (i2 >= nx) + i = nx + 1 + } + } + + k = k + 1 + } +end + + +# SGI_MCELL -- Put cell array, optimized for a metafile device. In this case, +# it is prohibitively expensive to draw into each resolvable line of the +# output device. It is better to set the linewidth to the width of a cell +# array pixel, output the minimum number of drawing instructions, and let the +# metafile device widen the lines. + +procedure sgi_mcell (m, nx, ny, ax1,ay1, ax2,ay2) + +short m[nx,ny] # cell array +int nx, ny # number of pixels in X and Y +int ax1, ay1 # lower left corner of output window +int ax2, ay2 # upper right corner of output window + +real dx, dy +int yres, my, i1, i2, v, i, j +include "sgi.com" +int and() + +begin + # Count drawing instruction, clobber saved polyline width. + g_ndraw = g_ndraw + 1 + SGI_WIDTH(g_kt) = 0 + + # Determine the width and height of a cell array pixel in GKI units. + dx = real (ax2 - ax1) / nx + dy = real (ay2 - ay1) / ny + + # Set the SGK line width to the height of a pixel in the cell array. + yres = SGI_YRES(g_kt) + if (yres <= 0) + yres = DEF_YRES + call sgk_linewidth (g_out, + max (1, nint (dy / (real(GKI_MAXNDC) / real(yres))))) + + # Process the cell array. The outer loop runs over lines of the input + # cell array; each iteration writes only one line of the output raster, + # but the width of the line is adjusted to the height of a pixel in + # the cell array (the resolution of the cell array should not exceed + # that of the device). + + for (j=1; j <= ny; j=j+1) { + my = int ((j - 0.5) * dy) + ay1 + + for (i=1; i <= nx; ) { + do i = i, nx { + v = m[i,j] + if (and (v, ZSTEP) != 0) + break + } + + if (i <= nx) { + i1 = i + i2 = nx + do i = i + 1, nx { + v = m[i,j] + if (and (v, ZSTEP) == 0) { + i2 = i + break + } + } + + # The following decreases the length of dark line segments + # to make features more visible. + + if (i2 - i1 >= 2) + if (i1 > 1 && i2 < nx) { + i1 = i1 + 1 + i2 = i2 - 1 + } + + # Draw the line segment. + call sgk_move (g_out, int ((i1-1) * dx + ax1), my) + call sgk_draw (g_out, int (i2 * dx + ax1), my) + + if (i2 >= nx) + i = nx + 1 + } + } + } +end diff --git a/sys/gio/sgikern/sgipl.x b/sys/gio/sgikern/sgipl.x new file mode 100644 index 00000000..e3eea44f --- /dev/null +++ b/sys/gio/sgikern/sgipl.x @@ -0,0 +1,183 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "sgi.h" + +define MAX_LTYPES 3 # max software line type patterns (excl. solid) +define MAX_LSEGMENTS 4 # max line segments per pattern +define LT_OFFSET 1 # offset to be subtracted from ltype code + + +# SGI_POLYLINE -- Draw a polyline. The polyline is defined by the array of +# points P, consisting of successive (x,y) coordinate pairs. The first point +# is not plotted but rather defines the start of the polyline. The remaining +# points define line segments to be drawn. + +procedure sgi_polyline (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs + +pointer pl +int x, y +int len_p, i +include "sgi.com" + +begin + if (npts < 2) + return + + len_p = npts * 2 + + # Keep track of the number of drawing instructions since the last frame + # clear. + g_ndraw = g_ndraw + 1 + + # Update polyline attributes if necessary. + pl = SGI_PLAP(g_kt) + + if (SGI_WIDTH(g_kt) != PL_WIDTH(pl)) { + call sgk_linewidth (g_out, nint (GKI_UNPACKREAL(PL_WIDTH(pl)))) + SGI_WIDTH(g_kt) = PL_WIDTH(pl) + } + if (SGI_COLOR(g_kt) != PL_COLOR(pl)) { + call sgi_color (PL_COLOR(pl)) + SGI_COLOR(g_kt) = PL_COLOR(pl) + } + + if (PL_LTYPE(pl) == GL_CLEAR) { + # Ignore clear (erase) polylines. + ; + + } else if (PL_LTYPE(pl) != GL_SOLID) { + # Draw a dashed or dotted polyline of the indicated type. + call sgi_dashline (g_out, p, npts, PL_LTYPE(pl)) + + } else { + # Draw a solid polyline (usual case, optimized). + + # Move to the first point. + x = p[1] + y = p[2] + call sgk_move (g_out, x, y) + + # Draw the polyline. + for (i=3; i <= len_p; i=i+2) { + x = p[i] + y = p[i+1] + call sgk_draw (g_out, x, y) + } + } +end + + +# SGI_DASHLINE -- Draw a dashed or dotted polyline using the indicated line +# style. + +procedure sgi_dashline (g_out, p, npts, ltype) + +int g_out # output file +short p[ARB] # the polyline points +int npts # number of points, i.e., (x,y) pairs +int ltype # desired line type + +bool penup +int len_p, i +real vlen, vpos, seglen, dx, dy +int oldx, oldy, newx, newy, penx, peny +int sgi_getseg() + +begin + len_p = npts * 2 + + oldx = p[1]; oldy = p[2] + call sgk_move (g_out, oldx, oldy) + + # Process each line segment in the polyline. + do i = 3, len_p, 2 { + newx = p[i] + newy = p[i+1] + + # Compute VLEN, the length of the polyline line segment to be + # drawn, VPOS, the relative position along the line segment, + # and DX and DY, the scale factors to be applied to VPOS to get + # the x and y coordinates of a point along the line segment. + + dx = newx - oldx + dy = newy - oldy + vlen = sqrt (dx*dx + dy*dy) + if (vlen < 1.0) # GKI units + next + + dx = dx / vlen + dy = dy / vlen + vpos = 0.0 + + # For each line segment, get segments of the line type pattern + # until all of the current line segment has been drawn. The pattern + # wraps around indefinitely, following the polyline around the + # vertices with concern only for the total length traversed. + + while (vlen - vpos >= 1.0) { + seglen = sgi_getseg (int (vlen - vpos), penup, ltype) + if (seglen < 1.0) + break + + vpos = vpos + seglen + penx = oldx + vpos * dx + peny = oldy + vpos * dy + + if (penup) + call sgk_move (g_out, penx, peny) + else + call sgk_draw (g_out, penx, peny) + } + + oldx = newx + oldy = newy + } +end + + +# SGI_GETSEG -- Get a segment of a line style pattern. The segment extends +# from the current position in the pattern to either the next penup/pendown +# breakpoint in the pattern, or to the point MAXLEN units further along in +# the pattern. When the end of the pattern is reached wrap around and +# duplicate the pattern indefinitely. + +int procedure sgi_getseg (maxlen, penup, ltype) + +int maxlen # max length segment to be returned +bool penup # [out] pen up or pen down type segment? +int ltype # line type code + +int seglen, seg, lt +int p_seg[MAX_LTYPES] +int p_nseg[MAX_LTYPES] +int p_segleft[MAX_LTYPES] +bool p_penup[MAX_LTYPES,MAX_LSEGMENTS] +int p_seglen[MAX_LTYPES,MAX_LSEGMENTS] +include "ltype.dat" + +begin + lt = max (1, min (MAX_LTYPES, ltype - LT_OFFSET)) + seg = p_seg[lt] + penup = p_penup[lt,seg] + + repeat { + if (maxlen < p_segleft[lt]) { + seglen = maxlen + p_segleft[lt] = p_segleft[lt] - seglen + } else { + seglen = p_segleft[lt] + seg = seg + 1 + if (seg > p_nseg[lt]) + seg = 1 + p_seg[lt] = seg + p_segleft[lt] = p_seglen[lt,seg] + } + } until (seglen > 0) + + return (seglen) +end diff --git a/sys/gio/sgikern/sgiplset.x b/sys/gio/sgikern/sgiplset.x new file mode 100644 index 00000000..30038437 --- /dev/null +++ b/sys/gio/sgikern/sgiplset.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "sgi.h" + +# SGI_PLSET -- Set the polyline attributes. The polyline width parameter is +# passed to the encoder as a packed floating point number, i.e., int(LWx100). + +procedure sgi_plset (gki) + +short gki[ARB] # attribute structure +pointer pl +include "sgi.com" + +begin + pl = SGI_PLAP(g_kt) + PL_LTYPE(pl) = gki[GKI_PLSET_LT] + PL_WIDTH(pl) = gki[GKI_PLSET_LW] + PL_COLOR(pl) = gki[GKI_PLSET_CI] +end diff --git a/sys/gio/sgikern/sgipm.x b/sys/gio/sgikern/sgipm.x new file mode 100644 index 00000000..e53f3f03 --- /dev/null +++ b/sys/gio/sgikern/sgipm.x @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "sgi.h" + +# SGI_POLYMARKER -- Draw a polymarker. The polymarker is defined by the array +# of points P, consisting of successive (x,y) coordinate pairs. + +procedure sgi_polymarker (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs + +pointer pm +int i, len_p +int x, y, oldx, oldy +include "sgi.com" + +begin + if (npts <= 0) + return + + len_p = npts * 2 + + # Keep track of the number of drawing instructions since the last frame + # clear. + g_ndraw = g_ndraw + 1 + + # Update polymarker attributes if necessary. + + pm = SGI_PMAP(g_kt) + + if (SGI_TYPE(g_kt) != PM_LTYPE(pm)) { + call sgi_linetype (PM_LTYPE(pm)) + SGI_TYPE(g_kt) = PM_LTYPE(pm) + } + if (SGI_WIDTH(g_kt) != PM_WIDTH(pm)) { + call sgk_linewidth (g_out, nint (GKI_UNPACKREAL(PM_WIDTH(pm)))) + SGI_WIDTH(g_kt) = PM_WIDTH(pm) + } + if (SGI_COLOR(g_kt) != PM_COLOR(pm)) { + call sgi_color (PM_COLOR(pm)) + SGI_COLOR(g_kt) = PM_COLOR(pm) + } + + # Draw the polymarker. + oldx = 0; oldy = 0 + for (i=1; i <= len_p; i=i+2) { + x = p[i]; y = p[i+1] + if (x != oldx || y != oldy) { + call sgk_move (g_out, x, y) + call sgk_draw (g_out, x, y) + } + oldx = x; oldy = y + } +end diff --git a/sys/gio/sgikern/sgipmset.x b/sys/gio/sgikern/sgipmset.x new file mode 100644 index 00000000..0d72392f --- /dev/null +++ b/sys/gio/sgikern/sgipmset.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "sgi.h" + +# SGI_PMSET -- Set the polymarker attributes. + +procedure sgi_pmset (gki) + +short gki[ARB] # attribute structure +pointer pm +include "sgi.com" + +begin + pm = SGI_PMAP(g_kt) + PM_LTYPE(pm) = gki[GKI_PMSET_MT] + PM_WIDTH(pm) = gki[GKI_PMSET_MW] + PM_COLOR(pm) = gki[GKI_PMSET_CI] +end diff --git a/sys/gio/sgikern/sgireset.x b/sys/gio/sgikern/sgireset.x new file mode 100644 index 00000000..a97034eb --- /dev/null +++ b/sys/gio/sgikern/sgireset.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "sgi.h" + +# SGI_RESET -- Reset the state of the transform common, i.e., in response to +# a clear or a cancel. Initialize all attribute packets to their default +# values and set the current state of the device to undefined, forcing the +# device state to be reset when the next output instruction is executed. + +procedure sgi_reset() + +pointer pl, pm, fa, tx +include "sgi.com" + +begin + # Set pointers to attribute substructures. + pl = SGI_PLAP(g_kt) + pm = SGI_PMAP(g_kt) + fa = SGI_FAAP(g_kt) + tx = SGI_TXAP(g_kt) + + # Initialize the attribute packets. + PL_LTYPE(pl) = 1 + PL_WIDTH(pl) = GKI_PACKREAL(1.) + PL_COLOR(pl) = 1 + PM_LTYPE(pm) = 1 + PM_WIDTH(pm) = GKI_PACKREAL(1.) + PM_COLOR(pm) = 1 + FA_STYLE(fa) = 1 + FA_COLOR(fa) = 1 + TX_UP(tx) = 90 + TX_SIZE(tx) = GKI_PACKREAL(1.) + TX_PATH(tx) = GT_RIGHT + TX_HJUSTIFY(tx) = GT_LEFT + TX_VJUSTIFY(tx) = GT_BOTTOM + TX_FONT(tx) = GT_ROMAN + TX_COLOR(tx) = 1 + TX_SPACING(tx) = 0.0 + + # Set the device attributes to undefined, forcing them to be reset + # when the next output instruction is executed. + + SGI_TYPE(g_kt) = -1 + SGI_WIDTH(g_kt) = -1 + SGI_COLOR(g_kt) = -1 + SGI_TXSIZE(g_kt) = -1 + SGI_TXFONT(g_kt) = -1 +end diff --git a/sys/gio/sgikern/sgitx.x b/sys/gio/sgikern/sgitx.x new file mode 100644 index 00000000..d0db5c58 --- /dev/null +++ b/sys/gio/sgikern/sgitx.x @@ -0,0 +1,459 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "sgi.h" +include "font.h" + +define BASECS_X 12 # Base (size 1.0) char width in GKI coords. +define BASECS_Y 12 # Base (size 1.0) char height in GKI coords. + + +# SGI_TEXT -- Draw a text string. The string is drawn at the position (X,Y) +# using the text attributes set by the last GKI_TXSET instruction. The text +# string to be drawn may contain embedded set font escape sequences of the +# form \fR (roman), \fG (greek), etc. We break the input text sequence up +# into segments at font boundaries and draw these on the output device, +# setting the text size, color, font, and position at the beginning of each +# segment. + +procedure sgi_text (xc, yc, text, n) + +int xc, yc # where to draw text string +short text[ARB] # text string +int n # number of characters + +real x, y, dx, dy, tsz, offset, cosv, sinv +int x1, x2, y1, y2, orien +int x0, y0, gki_dx, gki_dy, ch, cw +int xstart, ystart, newx, newy +int totlen, polytext, font, seglen, totwidth +pointer sp, seg, ip, op, tx, first +int stx_segment(), sgi_drawchar() +include "sgi.com" + +real g_dx, g_dy # scale GKI to window coords +int g_x1, g_y1 # origin of device window +int g_x2, g_y2 # upper right corner of device window +data g_dx /1.0/, g_dy /1.0/ +data g_x1 /0/, g_y1 /0/, g_x2 /GKI_MAXNDC/, g_y2 / GKI_MAXNDC/ + +begin + call smark (sp) + call salloc (seg, n + 2, TY_CHAR) + + # Keep track of the number of drawing instructions since the last frame + # clear. + g_ndraw = g_ndraw + 1 + + # Set pointer to the text attribute structure. + tx = SGI_TXAP(g_kt) + + # Set the text size and color if not already set. Both should be + # invalidated when the screen is cleared. Text color should be + # invalidated whenever another color is set. The text size was + # set by sgi_txset, and is just a scaling factor. + + SGI_TXSIZE(g_kt) = TX_SIZE(tx) + if (TX_COLOR(tx) != SGI_COLOR(g_kt)) { + call sgi_color (TX_COLOR(tx)) + SGI_COLOR(g_kt) = TX_COLOR(tx) + } + + # Set the linetype to a solid line. + if (SGI_TYPE(g_kt) != GL_SOLID) { + call sgi_linetype (GL_SOLID) + SGI_TYPE(g_kt) = GL_SOLID + } + + # No discreet character sizes, so just scale the base sizes. + tsz = GKI_UNPACKREAL(TX_SIZE(tx)) # scale factor + ch = SGI_CHARHEIGHT(g_kt,1) * tsz + cw = SGI_CHARWIDTH(g_kt,1) * tsz + + # Break the text string into segments at font boundaries and count + # the total number of printable characters. + + totlen = stx_segment (text, n, Memc[seg], TX_FONT(tx), cw, totwidth) + + # Compute the text drawing parameters, i.e., the coordinates of the + # first character to be drawn, the step between successive characters, + # and the polytext flag (GKI coords). + + call stx_parameters (xc,yc, totlen, totwidth, x0,y0, gki_dx,gki_dy, + polytext, orien) + + # Draw the segments, setting the font at the beginning of each segment. + # The first segment is drawn at (X0,Y0). The separation between + # characters is DX,DY. A segment is drawn as a block if the polytext + # flag is set, otherwise each character is drawn individually. + + x = x0 * g_dx + g_x1 + y = y0 * g_dy + g_y1 + dx = gki_dx * g_dx + dy = gki_dy * g_dy + cosv = cos (-DEGTORAD(orien)) + sinv = sin (-DEGTORAD(orien)) + + for (ip=seg; Memc[ip] != EOS; ip=ip+1) { + # Process the font control character heading the next segment. + font = Memc[ip] + ip = ip + 1 + + # Draw the segment. + while (Memc[ip] != EOS) { + # Clip leading out of bounds characters. + for (; Memc[ip] != EOS; ip=ip+1) { + x1 = x; x2 = x1 + cw + y1 = y; y2 = y1 + ch + + if (x1 >= g_x1 && x2 <= g_x2 && y1 >= g_y1 && y2 <= g_y2) + break + else { + x = x + dx + y = y + dy + } + + if (polytext == NO) { + ip = ip + 1 + break + } + } + + # Coords of first char to be drawn. + xstart = x + ystart = y + + # Move OP to first out of bounds char. + for (op=ip; Memc[op] != EOS; op=op+1) { + x1 = x; x2 = x1 + cw + y1 = y; y2 = y1 + ch + + if (x1 <= g_x1 || x2 >= g_x2 || y1 <= g_y1 || y2 >= g_y2) + break + else { + x = x + dx + y = y + dy + } + + if (polytext == NO) { + op = op + 1 + break + } + } + + # Count number of inbounds chars. + seglen = op - ip + + # Leave OP pointing to the end of this segment. + if (polytext == NO) + op = ip + 1 + else { + while (Memc[op] != EOS) + op = op + 1 + } + + # Compute X,Y of next segment. + newx = xstart + (dx * (op - ip)) + newy = ystart + dy + + # Quit if no inbounds chars. + if (seglen == 0) { + x = newx + y = newy + ip = op + next + } + + # Output the inbounds chars. + + first = ip + x = xstart + y = ystart + + while (seglen > 0 && (polytext == YES || ip == first)) { + offset = sgi_drawchar (Memc[ip], nint(x), nint(y), cw, ch, + orien, font) + ip = ip + 1 + seglen = seglen - 1 + x = x + (offset * cosv) + y = y - (offset * sinv) + } + + x = newx + y = newy + ip = op + } + } + + call sfree (sp) +end + + +# STX_SEGMENT -- Process the text string into segments, in the process +# converting from type short to char. The only text attribute that can +# change within a string is the font, so segments are broken by \fI, \fG, +# etc. font select sequences embedded in the text. The segments are encoded +# sequentially in the output string. The first character of each segment is +# the font number. A segment is delimited by EOS. A font number of EOS +# marks the end of the segment list. The output string is assumed to be +# large enough to hold the segmented text string. + +int procedure stx_segment (text, n, out, start_font, cw, totwidth) + +short text[ARB] # input text +int n # number of characters in text +char out[ARB] # output string +int start_font # initial font code +int cw # default character width +int totwidth # seg width in GKI units + +int i +int ip, op +int totlen, font + +include "font.com" +include "greek.com" + +begin + out[1] = start_font + font = start_font + totlen = 0 + totwidth = 0 + op = 2 + + for (ip=1; ip <= n; ip=ip+1) { + if (text[ip] == '\\' && text[ip+1] == 'f') { + # Select font. + out[op] = EOS + op = op + 1 + ip = ip + 2 + + switch (text[ip]) { + case 'B': + font = GT_BOLD + case 'I': + font = GT_ITALIC + case 'G': + font = GT_GREEK + default: + font = GT_ROMAN + } + + out[op] = font + op = op + 1 + + } else { + # Deposit character in segment. + if (text[ip] < CHARACTER_START || text[ip] > CHARACTER_END) + i = '?' - CHARACTER_START + 1 + else + i = text[ip] - CHARACTER_START + 1 + + if (font == GT_GREEK) { + totwidth = totwidth + + int(real(gchwid[i]) / real(FONT_WIDTH) * cw) + } else { + totwidth = totwidth + + int(real(chrwid[i]) / real(FONT_WIDTH) * cw) + } + + out[op] = text[ip] + op = op + 1 + totlen = totlen + 1 + } + } + + # Terminate last segment and add null segment. + out[op] = EOS + out[op+1] = EOS + + return (totlen) +end + + +# STX_PARAMETERS -- Set the text drawing parameters, i.e., the coordinates +# of the lower left corner of the first character to be drawn, the spacing +# between characters, and the polytext flag. Input consists of the coords +# of the text string, the length of the string, and the text attributes +# defining the character size, justification in X and Y of the coordinates, +# and orientation of the string. All coordinates are in GKI units. + +procedure stx_parameters (xc, yc, totlen, totwidth, x0, y0, dx, dy, polytext, + orien) + +int xc, yc # coordinates at which string is to be drawn +int totlen # number of characters to be drawn +int totwidth # width of characters to be drawn +int x0, y0 # lower left corner of first char to be drawn +int dx, dy # step in X and Y between characters +int polytext # OK to output text segment all at once +int orien # rotation angle of characters + +pointer tx +int up, path +real dir, sz, ch, cw, cosv, sinv, space +real xsize, ysize, xvlen, yvlen, xu, yu, xv, yv, p, q +include "sgi.com" + +begin + tx = SGI_TXAP(g_kt) + + # Get character sizes in GKI coords. + sz = GKI_UNPACKREAL (TX_SIZE(tx)) + ch = SGI_CHARHEIGHT(g_kt,1) * sz + cw = SGI_CHARWIDTH(g_kt,1) * sz + + # Compute the character rotation angle. This is independent of the + # direction in which characters are drawn. A character up vector of + # 90 degrees (normal) corresponds to a rotation angle of zero. + + up = TX_UP(tx) + orien = up - 90 + + # Determine the direction in which characters are to be plotted. + # This depends on both the character up vector and the path, which + # is defined relative to the up vector. + + path = TX_PATH(tx) + switch (path) { + case GT_UP: + dir = up + case GT_DOWN: + dir = up - 180 + case GT_LEFT: + dir = up + 90 + default: # GT_NORMAL, GT_RIGHT + dir = up - 90 + } + + # ------- DX, DY --------- + # Convert the direction vector into the step size between characters. + # Note CW and CH are in GKI coordinates, hence DX and DY are too. + # Additional spacing of some fraction of the character size is used + # if TX_SPACING is nonzero. + + dir = -DEGTORAD(dir) + cosv = cos (dir) + sinv = sin (dir) + + # Correct for spacing (unrotated). + space = (1.0 + TX_SPACING(tx)) + if (path == GT_UP || path == GT_DOWN) + p = ch * space + else + p = cw * space + q = 0 + + # Correct for rotation. + dx = p * cosv + q * sinv + dy = -p * sinv + q * cosv + + # ------- XU, YU --------- + # Determine the coordinates of the center of the first character req'd + # to justify the string, assuming dimensionless characters spaced on + # centers DX,DY apart. + + #xvlen = dx * (totlen - 1) + if (dx > 0) + xvlen = totwidth - dx + else + xvlen = 0 + yvlen = dy * (totlen - 1) + + switch (TX_HJUSTIFY(tx)) { + case GT_CENTER: + xu = - (xvlen / 2.0) + case GT_RIGHT: + # If right justify and drawing to the left, no offset req'd. + if (xvlen < 0) + xu = 0 + else + xu = -xvlen + default: # GT_LEFT, GT_NORMAL + # If left justify and drawing to the left, full offset right req'd. + if (xvlen < 0) + xu = -xvlen + else + xu = 0 + } + + switch (TX_VJUSTIFY(tx)) { + case GT_CENTER: + yu = - (yvlen / 2.0) + case GT_TOP: + # If top justify and drawing downward, no offset req'd. + if (yvlen < 0) + yu = 0 + else + yu = -yvlen + default: # GT_BOTTOM, GT_NORMAL + # If bottom justify and drawing downward, full offset up req'd. + if (yvlen < 0) + yu = -yvlen + else + yu = 0 + } + + # ------- XV, YV --------- + # Compute the offset from the center of a single character required + # to justify that character, given a particular character up vector. + # (This could be combined with the above case but is clearer if + # treated separately.) + + p = -DEGTORAD(orien) + cosv = cos(p) + sinv = sin(p) + + # Compute the rotated character in size X and Y. + xsize = abs ( cw * cosv + ch * sinv) + ysize = abs (-cw * sinv + ch * cosv) + + switch (TX_HJUSTIFY(tx)) { + case GT_CENTER: + xv = 0 + case GT_RIGHT: + xv = - (xsize / 2.0) + default: # GT_LEFT, GT_NORMAL + xv = xsize / 2 + } + + switch (TX_VJUSTIFY(tx)) { + case GT_CENTER: + yv = 0 + case GT_TOP: + yv = - (ysize / 2.0) + default: # GT_BOTTOM, GT_NORMAL + yv = ysize / 2 + } + + # ------- X0, Y0 --------- + # The center coordinates of the first character to be drawn are given + # by the reference position plus the string justification vector plus + # the character justification vector. + + x0 = xc + xu + xv + y0 = yc + yu + yv + + # The character drawing primitive requires the coordinates of the + # lower left corner of the character (irrespective of orientation). + # Compute the vector from the center of a character to the lower left + # corner of a character, rotate to the given orientation, and correct + # the starting coordinates by addition of this vector. + + p = - (cw / 2.0) + q = - (ch / 2.0) + + x0 = x0 + ( p * cosv + q * sinv) + y0 = y0 + (-p * sinv + q * cosv) + + # ------- POLYTEXT --------- + # Set the polytext flag. Polytext output is possible only if chars + # are to be drawn to the right with no extra spacing between chars. + + if (abs(dy) == 0 && dx == cw) + polytext = YES + else + polytext = NO +end diff --git a/sys/gio/sgikern/sgitxset.x b/sys/gio/sgikern/sgitxset.x new file mode 100644 index 00000000..c064d556 --- /dev/null +++ b/sys/gio/sgikern/sgitxset.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "sgi.h" + +# SGI_TXSET -- Set the text drawing attributes. + +procedure sgi_txset (gki) + +short gki[ARB] # attribute structure + +pointer tx +include "sgi.com" + +begin + tx = SGI_TXAP(g_kt) + + TX_UP(tx) = gki[GKI_TXSET_UP] + TX_PATH(tx) = gki[GKI_TXSET_P ] + TX_HJUSTIFY(tx) = gki[GKI_TXSET_HJ] + TX_VJUSTIFY(tx) = gki[GKI_TXSET_VJ] + TX_FONT(tx) = gki[GKI_TXSET_F ] + TX_QUALITY(tx) = gki[GKI_TXSET_Q ] + TX_COLOR(tx) = gki[GKI_TXSET_CI] + + TX_SPACING(tx) = GKI_UNPACKREAL (gki[GKI_TXSET_SP]) + TX_SIZE(tx) = gki[GKI_TXSET_SZ] +end diff --git a/sys/gio/sgikern/sgk.com b/sys/gio/sgikern/sgk.com new file mode 100644 index 00000000..a919e147 --- /dev/null +++ b/sys/gio/sgikern/sgk.com @@ -0,0 +1,49 @@ +# SGK.COM -- The common for the SGK kernel. A common is used here for maximum +# efficiency (minimum indirection) when rasterizing vectors and encoding +# metacode. The maximum bitmap size is set at compile time in sgk.h. + +# Booleans put here to avoid possible alignment problems. + +bool mf_bitmap # metafile type, metacode or bitmap +bool mf_rotate # rotate (swap x and y) +bool mf_yflip # flip y axis end for end +bool mf_update # update bitmap +bool mf_delete # delete metacode file after dispose +bool mf_debug # print kernel debugging messages +bool mf_swap2 # swap every 2 bytes on output +bool mf_swap4 # swap every 4 bytes on output +bool mf_oneperfile # store each frame in a new file + +common /sgkboo/ mf_bitmap, mf_rotate, mf_yflip, mf_update, mf_delete, mf_debug, + mf_swap2, mf_swap4, mf_oneperfile + +# Everything else goes here. + +int mf_fd # file descriptor of output file +int mf_frame # frame counter +char mf_fname[SZ_PATHNAME] # metafile filename +char mf_dispose[SZ_OSCMD] # host dispose command + +int mf_op # [MCODE] index into obuf +short mf_obuf[LEN_OBUF] # metacode buffer + +int mf_cx, mf_cy # [BITMAPS] current pen position +int mf_nbpb # packing factor, bits per byte +int mf_pxsize, mf_pysize # physical x, y size of bitmap, bits +int mf_wxsize, mf_wysize # x, y size of bitmap window, bits +int mf_xorigin, mf_yorigin # origin of bitmap window +real mf_xscale, mf_yscale # to convert from NDC to device coords +int mf_xmin, mf_xmax # x clipping limits +int mf_ymin, mf_ymax # y clipping limits +int mf_lenframe # frame size, words +int mf_linewidth # relative line width +int mf_lworigin # device width of line size 1.0 +real mf_lwslope # device pixels per line size increment +int mf_fbuf[LEN_FBUF] # frame buffer (BIG) +int mf_bitmask[BPW] # bit mask table + +common /sgkcom/ mf_fd, mf_frame, mf_op, mf_cx, mf_cy, mf_nbpb, mf_pxsize, + mf_pysize, mf_wxsize, mf_wysize, mf_xorigin, mf_yorigin, mf_xscale, + mf_yscale, mf_xmin, mf_xmax, mf_ymin, mf_ymax, mf_lenframe, + mf_linewidth, mf_lworigin, mf_lwslope, mf_fbuf, mf_bitmask, mf_obuf, + mf_fname, mf_dispose diff --git a/sys/gio/sgikern/sgk.h b/sys/gio/sgikern/sgk.h new file mode 100644 index 00000000..09c62d95 --- /dev/null +++ b/sys/gio/sgikern/sgk.h @@ -0,0 +1,7 @@ +# SGK.H -- SGK metacode definitions. + +define SGK_LENMCI 3 # SGK instruction length +define SGK_FRAME 1 # new frame instruction +define SGK_MOVE 2 # move pen +define SGK_DRAW 3 # draw pen +define SGK_SETLW 4 # set line width diff --git a/sys/gio/sgikern/sgk.x b/sys/gio/sgikern/sgk.x new file mode 100644 index 00000000..3ed77f76 --- /dev/null +++ b/sys/gio/sgikern/sgk.x @@ -0,0 +1,853 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "sgk.h" + +.help sgk +.nf --------------------------------------------------------------------------- +SGK -- Simple graphics device interface. The purpose of this interface is +to provide a simple means for interfacing new plotter devices to IRAF/GIO. +The interface works by writing a binary metacode file and then disposing of +it by issuing a command to the host system. + + g_out = sgk_open (device, tty) # device open + sgk_close (g_out) # device close + sgk_flush (g_out) # flush output + + sgk_frame (g_out) # start a new frame + sgk_move (g_out, x, y) # move to (x,y) + sgk_draw (g_out, x, y) # draw a vector to (x,y) + sgk_linewidth (g_out, width) # set line width (>=1) + +The procedures comprising the top end of the SGK interface are summarized +above and the code is included in this file. These procedures could be +rewritten by the user to talk directly to a graphics device if desired, +although the metacode file interface is likely to be simpler in most cases. + +The SGK kernel can produce either metacode or bitmap output. Metacode output +is normally preferred for intelligent plotters and for pen plotters. Bitmap +output is normally preferred for raster plotters. The type of output file +to be generated is selected by the graphcap entry for an SGI/SGK device. + +The METACODE FORMAT written by the SGK interface is a sequence of 16 bit integer +words containing binary opcodes and data. The metacode is extremely simple, +consisting of only two drawing instructions (pen up move and pen down draw), +a frame instruction, and an optional set line width instruction. All text is +rendered into vectors by the SGI kernel hence there are no text drawing +instructions. The SGK metacode instruction formats are summarized below. + + opcode / data words + + 1 0 0 # frame instruction + 2 X Y # move to (x,y) + 3 X Y # draw to (x,y) + 4 W 0 # set line width (>= 1, 1=normal, 2=bold) + +All opcodes and data words are 16 bit positive integers encoded in the machine +independent MII format, i.e., most significant byte first. Only 15 bits of +each 16 bit word are actually used. Coordinates are specified in the range 0 +to 32767. All instructions are zero padded to 3 words to simplify metacode +translation programs. + +The BITMAP FORMAT written by the SGK is even simpler than the metacode format. +Output consists of a binary raster file containing one or more bitmaps with no +embedded header information. All bitmaps in a raster file are of the same +size. The size is specified in the graphcap entry for the device and may be +passed to the host dispose task on the foreign task command line if desired. +Page offsets may also be passed on the command line, e.g., to position the +plot on the plotter page. + +The following graphcap fields apply to both metacode and bitmap devices. + + DD host command to dispose of metacode file ($F) + DB have the kernel print debug messages during execution + RM boolean; if present, SGK will delete metacode file + MF multiframe count (max frames per job) + NF store each frame in a new file (rather than all in one file) + RO rotate plot (swap x and y) + YF y-flip plot (flip y axis) (done after rotate) + +The following additional fields are defined for bitmap devices. + + BI boolean; presence indicates a bitmapped or raster device + LO width in device pixels of a line of size 1.0 + LS difference in device pixels between line sizes + PX physical x size (linelen) of bitmap as stored in memory, bits + PY physical y size of bitmap, i.e., number of lines in bitmap + XO,YO origin of plotting window in device pixels + XW,YW width of plotting window in device pixels + NB number of bits to be set in each 8 bit byte output + BF bit-flip each byte in bitmap (easier here than later) + BS byte swap the bitmap when output (swap every two bytes) + WS word swap the bitmap when output (swap every four bytes) + +The multiframe count (MF) limits the number of frames per job, where a job +refers to the dispose command submitted to the host to process the frames. +If the new file flag (NF) is absent, all frames will be stored in the same +physical file (this holds for both metacode and bitmap frames). If the new +file flag (NF) is set, each frame will be stored in a separate file, with +the N files having the names $F.1, $F.2, ... $F.N, where $F is the unique +(root) filename generated from the template given in the DD string. The $F +is replaced by the root filename, rather than by a list of all the filenames, +to keep the OS command to a reasonable length and to permit the use of host +file templates to perform operate upon the full set of files (and to avoid +having to choose between spaces and commas to delimit the filenames). +For example, if MF=8 and NF=yes, then "$F.[1-8]" will match the file set +on a UNIX host. The template "$F.*" is less precise but would also work. + +The output raster will consist of PY lines each of length PX bits. If PX is +chosen to be a multiple of 8, there will be PX/8 bytes per line of the output +raster. Note that the values of PX and PY are arbitrary and should be chosen +to simplify the code of the translator and maximize efficiency. In particular, +PX and PY do not in general define the maximum physical resolution of the +device, although if NB=8 the value of PX will typically approximate the +physical resolution in X. If there are multiple bitmap frames per file, +each frame will occupy an integral number of SPP char units of storage in the +output file, with the values of any extra bits at the end of the bitmap being +undefined (a char is 16 bits on most IRAF host machines). + +The plot will be rasterized in a logical window XW one-bit pixels wide and YW +pixels high. The first YO lines of the output raster will be zero, with the +plotting window beginning at line YO+1. The first XO bits of each output line +will be zeroed, with the plotting window beginning at bit XO+1. The bytes in +each output line may be bit-flipped if desired, and all of the bits in each +output byte need not be used for pixel data. If the bit packing factor NB is +set to 8 the plotting window will map into XW bits of storage of each output +line. If fewer than 8 bits are used in each output byte more than XW physical +bits of storage will be used, e.g., if NB=4, XW*2 bits of storage are required +for a line of the plotting window. The unused bits are set to zero. The +translator can later "or" a mask into the zeroed bits, flip the data bits, +or perform any other bytewise operation using simple lookup table mapping +techniques. +.endhelp ---------------------------------------------------------------------- + +# NOTE -- The mf_physbit lookup table, used to map logical screen bits into +# physical bits in the bitmap (for NB != 8) is equivalenced to the mf_obuf +# array which is not otherwise used for bitmap devices. The length of the +# mf_obuf array must therefore be >= PX. + +define mf_physbit mf_obuf # union these two arrays [[[NOTE]]] +define BPW NBITS_INT # nbits in an integer +define LEN_FBUF (2550*3300/BPW) # max size bitmap / frame buffer +define LEN_OBUF 3300 # nwords in output buffer +define SZ_DDSTR 256 # max size graphcap.DD +define SZ_OSCMD 256 # OS dispose command from graphcap.DD + + +# SGK_OPEN -- Open the metacode file. Parse the DD string from the graphcap +# entry for the device to get the file template and OS dispose command. +# Generate a unique file name and open the metacode file as a NEW_FILE. +# Save the dispose command for later. + +int procedure sgk_open (device, tty) + +char device[ARB] # device name [NOT USED] +pointer tty # pointer to graphcap descriptor + +char cap[2] +int len_nodeprefix, byte, off, op, i, j +pointer sp, raw_ddstr, ddstr, devname, spool, fname, tempfn, val, ip + +bool ttygetb() +real ttygetr() +int open(), ttygets(), ttygeti(), gstrcpy(), shifti() +errchk open, ttygets, ttygeti, ttygetb +include "sgk.com" + +begin + call smark (sp) + call salloc (raw_ddstr, SZ_DDSTR, TY_CHAR) + call salloc (ddstr, SZ_DDSTR, TY_CHAR) + call salloc (devname, SZ_FNAME, TY_CHAR) + call salloc (spool, SZ_FNAME, TY_CHAR) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (tempfn, SZ_PATHNAME, TY_CHAR) + call salloc (val, SZ_FNAME, TY_CHAR) + + # The DB flag may be set in the graphcap entry for an SGI device to + # print debug messages during execution. + + mf_debug = ttygetb (tty, "DB") + + # The DD string is used to pass device dependent information to the + # graphics device driver. + + if (ttygets (tty, "DD", Memc[raw_ddstr], SZ_DDSTR) <= 0) + call error (1, "sgikern: missing DD parameter in graphcap") + + # Expand any $(XX) graphcap parameter references in the DD string. + op = ddstr + for (ip=raw_ddstr; Memc[ip] != EOS; ip=ip+1) + if (Memc[ip] == '$' && Memc[ip+1] == '(' && Memc[ip-1] != '\\') { + # Graphcap parameter substitution. + call strcpy (Memc[ip+2], cap, 2) + if (ttygets (tty, cap, Memc[val], SZ_FNAME) <= 0) { + call eprintf ("Warning: graphcap field `%s' not found\n") + call pargstr (cap) + } else { + for (off=val; Memc[off] == '#'; off=off+1) + ; + for (; Memc[off] != EOS; off=off+1) { + Memc[op] = Memc[off] + op = op + 1 + } + } + ip = ip + 4 + + } else { + # Ordinary character. + Memc[op] = Memc[ip] + op = op + 1 + } + Memc[op] = EOS + + # Parse the DD string into the node/device name, temp file name, + # and host dispose command. + + # Get node and device name (e.g., "node!device,..."). + len_nodeprefix = 0 + ip = ddstr + for (op=devname; Memc[ip] != EOS; ip=ip+1) + if (Memc[ip] == ',') { + if (Memc[ip-1] == '\\') { + Memc[op-1] = ',' + ip = ip - 1 + } else { + ip = ip + 1 + break + } + } else { + if (Memc[ip] == FNNODE_CHAR) + len_nodeprefix = op - devname + 1 + Memc[op] = Memc[ip] + op = op + 1 + } + Memc[op] = EOS + + # Get spoolfile root name. + op = spool + gstrcpy (Memc[devname], Memc[spool], len_nodeprefix) + for (; Memc[ip] != EOS; ip=ip+1) + if (Memc[ip] == ',') { + if (Memc[ip-1] == '\\') { + Memc[op-1] = ',' + ip = ip - 1 + } else { + ip = ip + 1 + break + } + } else { + Memc[op] = Memc[ip] + op = op + 1 + } + Memc[op] = EOS + + # Get OS pathname of spoofile. + call mktemp (Memc[spool], Memc[tempfn], SZ_PATHNAME) + call fmapfn (Memc[tempfn], mf_fname, SZ_PATHNAME) + call strupk (mf_fname, mf_fname, SZ_PATHNAME) + + # Get pathname of spoolfile on the remote node. The call to + # ki_fmapfn() is currently necessary to translate the filename for + # the remote node, but may be replaced by the usual fmapfn() in a + # future version of the kernel interface. + + call ki_fmapfn (Memc[tempfn], Memc[fname], SZ_PATHNAME) + call strupk (Memc[fname], Memc[fname], SZ_PATHNAME) + + if (mf_debug) { + call eprintf ("sgk: open device %s, outfile = %s\n") + call pargstr (Memc[devname]) + call pargstr (mf_fname) + } + + # Copy OS command for disposing of metacode file into common, replacing + # all $F sequences in the command by the OS pathname of the spool file. + + op = gstrcpy (Memc[devname], mf_dispose, len_nodeprefix) + 1 + + for (; Memc[ip] != EOS; ip=ip+1) + if (Memc[ip] == '$' && Memc[ip-1] == '\\') { + # Escape a $. + mf_dispose[op-1] = '$' + + } else if (Memc[ip] == '$' && Memc[ip+1] == 'F') { + # Filename substitution. + for (i=fname; Memc[i] != EOS; i=i+1) { + mf_dispose[op] = Memc[i] + op = op + 1 + } + ip = ip + 1 + + } else { + # Ordinary character. + mf_dispose[op] = Memc[ip] + op = op + 1 + } + + mf_dispose[op] = EOS + + # Remove (delete) metacode file after issuing OS dispose command? + mf_delete = ttygetb (tty, "RM") + + # Store each frame in a new file? + mf_oneperfile = ttygetb (tty, "NF") + + mf_update = false + mf_frame = 1 + + # Open a new metacode file. + if (mf_oneperfile) + call sgk_mkfname (mf_fname, mf_frame, Memc[fname], SZ_FNAME) + else + call strcpy (mf_fname, Memc[fname], SZ_FNAME) + + if (mf_debug) { + call eprintf ("sgk: open frame %2d, outfile = %s\n") + call pargi (mf_frame) + call pargstr (Memc[fname]) + } + mf_fd = open (Memc[fname], NEW_FILE, BINARY_FILE) + + # Rotate plot (swap x,y)? Y-flip plot? + mf_rotate = ttygetb (tty, "RO") + mf_yflip = ttygetb (tty, "YF") + + # Raster (bitmap) or metacode device? + mf_bitmap = ttygetb (tty, "BI") + + if (mf_bitmap) { + # Bitmap output; initialize bitmap parameters. + + mf_pxsize = ttygeti (tty, "PX") + mf_pysize = ttygeti (tty, "PY") + mf_xorigin = ttygeti (tty, "XO") + mf_yorigin = ttygeti (tty, "YO") + mf_wxsize = ttygeti (tty, "XW") + mf_wysize = ttygeti (tty, "YW") + mf_nbpb = ttygeti (tty, "NB") + mf_swap2 = ttygetb (tty, "BS") + mf_swap4 = ttygetb (tty, "WS") + + mf_lworigin = max (1, ttygeti (tty, "LO")) + mf_lwslope = ttygetr (tty, "LS") + mf_lenframe = (mf_pxsize * mf_pysize + BPW-1) / BPW + + if (mf_wxsize == 0) + mf_wxsize = mf_pxsize - mf_xorigin + if (mf_wysize == 0) + mf_wysize = mf_pysize - mf_yorigin + if (mf_nbpb == 0) + mf_nbpb = NBITS_BYTE + + mf_linewidth = mf_lworigin + mf_cx = 0 + mf_cy = 0 + + mf_xmin = mf_xorigin + mf_ymin = mf_yorigin + mf_xmax = mf_xmin + mf_wxsize - 1 + mf_ymax = mf_ymin + mf_wysize - 1 + + mf_xscale = real(mf_wxsize) / real(GKI_MAXNDC) + mf_yscale = real(mf_wysize) / real(GKI_MAXNDC) + + if (mf_lenframe > LEN_FBUF) + call error (1, "sgikern: bitmap too large") + + # Initialize the bit mask table. If it is necessary to bit-flip + # bytes in the bitmap, we can do that here by flipping each byte + # of the word mask. Bit flipping can be done during rasterization + # at no additional cost, but is an expensive operation if done + # later with a filter. + + if (ttygetb (tty, "BF")) { + do j = 1, (BPW/NBITS_BYTE) + do i = 1, NBITS_BYTE { + off = (j - 1) * NBITS_BYTE + mf_bitmask[off+i] = shifti (1, off + NBITS_BYTE - i) + } + } else { + do i = 1, BPW + mf_bitmask[i] = shifti (1, i - 1) + } + + # Initialize the bit offset lookup table. This gives the physical + # x-offset into the lookup table of each addressable x-coordinate + # on the device. If NB is NBITS_BYTE the mapping is one-to-one. + # Note that the table contains zero-indexed bit offsets. + + do i = 1, mf_pxsize { + byte = (i - 1) / mf_nbpb + mf_physbit[i] = min (mf_pxsize, + byte * NBITS_BYTE + (i - (byte * mf_nbpb))) - 1 + } + + if (mf_debug) { + call eprintf ("bitmap [%d,%d] origin=[%d,%d] wsize=[%d,%d]\n") + call pargi (mf_pxsize); call pargi (mf_pysize) + call pargi (mf_xorigin); call pargi (mf_yorigin) + call pargi (mf_wxsize); call pargi (mf_wysize) + } + + } else { + # Metacode output; initialize the metacode output buffer. + mf_op = 1 + if (mf_debug) + call eprintf ("metafile device\n") + } + + call sfree (sp) + return (mf_fd) +end + + +# SGK_CLOSE -- Close the metacode spool file and dispose of it to a host system +# metacode translation task. Delete the spool file when the OS command +# completes, unless it has already been deleted by the task run. + +procedure sgk_close (fd) + +int fd # output stream [NOT USED] + +int i +pointer sp, fname +int oscmd() +errchk sgk_flush, close, oscmd +include "sgk.com" + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + if (mf_debug) + call eprintf ("close device\n") + + if (mf_bitmap) + call sgk_frame (mf_fd) + else + call sgk_flush (mf_fd) + + if (mf_debug) { + call eprintf ("dispose: %s\n") + call pargstr (mf_dispose) + } + + if (mf_fd != NULL) { + call close (mf_fd) + mf_fd = NULL + } + + # Send the dispose command to the host system. + if (mf_dispose[1] != EOS) + if (oscmd (mf_dispose, "", "", "") != OK) + call eprintf ("Warning: SGK graphics output dispose error\n") + + # Delete the metacode or raster file if so indicated in the graphcap + # entry for the device. + + if (mf_delete) { + if (mf_debug) { + call eprintf ("delete metafile %s\n") + call pargstr (mf_fname) + } + if (mf_oneperfile) { + do i = 1, mf_frame { + call sgk_mkfname (mf_fname, i, Memc[fname], SZ_FNAME) + iferr (call delete (Memc[fname])) + ; + } + } else iferr (call delete (mf_fname)) + ; + } + + call sfree (sp) +end + + +# SGK_FLUSH -- Flush any buffered metacode output. + +procedure sgk_flush (fd) + +int fd # output stream [NOT USED] +include "sgk.com" + +begin + if (!mf_bitmap && mf_op > 1) { + if (mf_debug) + call eprintf ("flush graphics output\n") + call miiwrites (mf_fd, mf_obuf, mf_op-1) + mf_op = 1 + } + + if (mf_fd != NULL) + call flush (mf_fd) +end + + +# SGK_FRAME -- Output a frame advance instruction. + +procedure sgk_frame (fd) + +int fd # output stream [NOT USED] +include "sgk.com" + +begin + # Ignore frame commands if frame is empty. + if (!mf_update) + return + + if (mf_debug) + call eprintf ("start a new frame\n") + + if (mf_bitmap) { + # Write the bitmap to the output raster-file. + + if (mf_swap2) + call bswap2 (mf_fbuf, 1, mf_fbuf, 1, + mf_lenframe * SZ_INT * SZB_CHAR) + if (mf_swap4) + call bswap4 (mf_fbuf, 1, mf_fbuf, 1, + mf_lenframe * SZ_INT * SZB_CHAR) + + call write (mf_fd, mf_fbuf, mf_lenframe * SZ_INT) + + } else { + # Write the SGI frame instruction to the output mcode-file. + + if (mf_op + SGK_LENMCI > LEN_OBUF) { + call miiwrites (mf_fd, mf_obuf, mf_op-1) + mf_op = 1 + } + + mf_obuf[mf_op] = SGK_FRAME + mf_obuf[mf_op+1] = 0 + mf_obuf[mf_op+2] = 0 + mf_op = mf_op + SGK_LENMCI + } + + mf_frame = mf_frame + 1 + mf_update = false +end + + +# SGK_MOVE -- Output a pen move instruction. + +procedure sgk_move (fd, x, y) + +int fd # output stream [NOT USED] +int x, y # point to move to + +include "sgk.com" + +begin + if (mf_bitmap) { + if (mf_rotate) { + mf_cx = y + mf_cy = x + } else { + mf_cx = x + mf_cy = y + } + + if (mf_yflip) + mf_cy = GKI_MAXNDC - mf_cy + + # Convert to zero indexed coordinates and clip at boundary. + # Allow room for line width shift near boundary. + + mf_cx = max (mf_xmin, min (mf_xmax, + int (mf_cx * mf_xscale) + mf_xorigin)) + mf_cy = max (mf_ymin, min (mf_ymax, + int (mf_cy * mf_yscale) + mf_yorigin)) + + } else { + if (mf_op + SGK_LENMCI > LEN_OBUF) { + call miiwrites (mf_fd, mf_obuf, mf_op-1) + mf_op = 1 + } + + mf_obuf[mf_op] = SGK_MOVE + if (mf_rotate) { + mf_obuf[mf_op+1] = y + mf_obuf[mf_op+2] = x + } else { + mf_obuf[mf_op+1] = x + mf_obuf[mf_op+2] = y + } + if (mf_yflip) + mf_obuf[mf_op+2] = GKI_MAXNDC - mf_obuf[mf_op+2] + mf_op = mf_op + SGK_LENMCI + } +end + + +# SGK_DRAW -- Output a pen draw instruction. + +procedure sgk_draw (fd, a_x, a_y) + +int fd # output stream [NOT USED] +int a_x, a_y # point to draw to + +char fname[SZ_FNAME] +int xshift, yshift, dx, dy +int new_x, new_y, x1, y1, x2, y2, n, i +int open() +errchk open, close +include "sgk.com" + +begin + if (mf_rotate) { + new_x = a_y + new_y = a_x + } else { + new_x = a_x + new_y = a_y + } + + if (mf_yflip) + new_y = GKI_MAXNDC - new_y + + if (!mf_update) { + # We are called when the first drawing instruction is output for a + # new frame. We clear the bitmap or close and open a new frame + # file here, rather than at sgk_frame() time, as we do not want + # to initialize the frame buffer or open a new frame file unless + # we are actually going to write into the frame. + + # Zero out all the bits in a bitmap. + if (mf_bitmap) + call aclri (mf_fbuf, mf_lenframe) + + # Open a new frame file if the one frame per file flag is set. + if (mf_oneperfile && mf_frame > 1) { + if (mf_fd != NULL) + call close (mf_fd) + call sgk_mkfname (mf_fname, mf_frame, fname, SZ_FNAME) + if (mf_debug) { + call eprintf ("sgk: open frame %2d, outfile = %s\n") + call pargi (mf_frame) + call pargstr (fname) + } + mf_fd = open (fname, NEW_FILE, BINARY_FILE) + } + + mf_update = true + } + + if (mf_bitmap) { + # Convert to zero indexed coordinates and clip at boundary. + # Allow room for line width shift near boundary. + + new_x = max (mf_xmin, min (mf_xmax, + int (new_x * mf_xscale) + mf_xorigin)) + new_y = max (mf_ymin, min (mf_ymax, + int (new_y * mf_yscale) + mf_yorigin)) + + if (mf_linewidth <= 1) + call sgk_vector (mf_cx, mf_cy, new_x, new_y) + else { + # Redraw the vector several times with small normal shifts to + # produce a wider line. + + xshift = 0 + yshift = 0 + + if (abs (new_x - mf_cx) > abs (new_y - mf_cy)) { + dx = 0 + dy = 1 + } else { + dx = 1 + dy = 0 + } + + do i = 1, mf_linewidth { + x1 = mf_cx + xshift + y1 = mf_cy + yshift + x2 = new_x + xshift + y2 = new_y + yshift + + call sgk_vector (x1, y1, x2, y2) + + n = (i + 1) / 2 + if (and (i, 1) == 0) { + xshift = dx * n + yshift = dy * n + } else { + xshift = -dx * n + yshift = -dy * n + } + } + } + + # Update the current pen position, and set the update flag so that + # the bitmap will be written to the output file. + + mf_cx = new_x + mf_cy = new_y + + } else { + # Output a metacode draw instruction. + if (mf_op + SGK_LENMCI > LEN_OBUF) { + call miiwrites (mf_fd, mf_obuf, mf_op-1) + mf_op = 1 + } + + mf_obuf[mf_op] = SGK_DRAW + mf_obuf[mf_op+1] = new_x + mf_obuf[mf_op+2] = new_y + mf_op = mf_op + SGK_LENMCI + } +end + + +# SGK_VECTOR -- Write a vector (line) of unit width into the bitmap. The line +# endpoints are expressed in physical device coordinates. + +procedure sgk_vector (a_x1, a_y1, a_x2, a_y2) + +int a_x1, a_y1 # start point of line +int a_x2, a_y2 # end point of line + +real dydx, dxdy +long fbit, wbit, word +int wpln, mask, dx, dy, x, y, x1, y1, x2, y2, or() +include "sgk.com" + +begin + x1 = a_x1; y1 = a_y1 + x2 = a_x2; y2 = a_y2 + + dx = x2 - x1 + dy = y2 - y1 + + if (abs(dx) > abs(dy)) { + if (x1 > x2) { + x1 = a_x2; x2 = a_x1; dx = -dx + y1 = a_y2; y2 = a_y1; dy = -dy + } + + if (dy == 0 && mf_nbpb == NBITS_BYTE) { + # Somewhat optimized code for the case of a horiz. vector. + + fbit = y1 * mf_pxsize + x1 + word = fbit / BPW + wbit = and (fbit, BPW-1) + + do x = x1, x2 { + mf_fbuf[word+1] = or (mf_fbuf[word+1], mf_bitmask[wbit+1]) + wbit = wbit + 1 + if (wbit >= BPW) { + wbit = 0 + word = word + 1 + } + } + + } else { + # The general case for a mostly-X vector. + + dydx = real(dy) / real(dx) + do x = x1, x2 { + y = int ((x - x1) * dydx) + y1 + fbit = y * mf_pxsize + mf_physbit[x+1] + word = fbit / BPW + wbit = and (fbit, BPW-1) + mf_fbuf[word+1] = or (mf_fbuf[word+1], mf_bitmask[wbit+1]) + } + } + + } else if (dy != 0) { + if (y1 > y2) { + x1 = a_x2; x2 = a_x1; dx = -dx + y1 = a_y2; y2 = a_y1; dy = -dy + } + + if (dx == 0) { + # Optimized code for the case of a vertical vector. + + fbit = y1 * mf_pxsize + mf_physbit[x1+1] + word = fbit / BPW + 1 + wbit = and (fbit, BPW-1) + wpln = (mf_pxsize + BPW-1) / BPW + mask = mf_bitmask[wbit+1] + + do y = y1, y2 { + mf_fbuf[word] = or (mf_fbuf[word], mask) + word = word + wpln + } + + } else { + # The general case of a mostly-Y vector. + + dxdy = real(dx) / real(dy) + do y = y1, y2 { + x = int ((y - y1) * dxdy) + x1 + fbit = y * mf_pxsize + mf_physbit[x+1] + word = fbit / BPW + wbit = and (fbit, BPW-1) + mf_fbuf[word+1] = or (mf_fbuf[word+1], mf_bitmask[wbit+1]) + } + } + + } else { + # Plot a single point (dx=dy=0). + + fbit = y1 * mf_pxsize + mf_physbit[x1+1] + word = fbit / BPW + wbit = and (fbit, BPW-1) + mf_fbuf[word+1] = or (mf_fbuf[word+1], mf_bitmask[wbit+1]) + } +end + + +# SGK_LINEWIDTH -- Output a line width set instruction. + +procedure sgk_linewidth (fd, width) + +int fd # output stream [NOT USED] +int width # new line width + +int gap +include "sgk.com" + +begin + if (mf_bitmap) { + # Set the line width in device pixels. + mf_linewidth = max (1, mf_lworigin + int ((width-1) * mf_lwslope)) + + # Set the clipping limits. Allow for shifting to widen lines. + gap = mf_linewidth - 1 + mf_xmin = mf_xorigin + gap + mf_ymin = mf_yorigin + gap + mf_xmax = mf_xorigin + (mf_wxsize - 1) - gap + mf_ymax = mf_yorigin + (mf_wysize - 1) - gap + + } else { + if (mf_op + SGK_LENMCI > LEN_OBUF) { + call miiwrites (mf_fd, mf_obuf, mf_op-1) + mf_op = 1 + } + + mf_obuf[mf_op] = SGK_SETLW + mf_obuf[mf_op+1] = width + mf_obuf[mf_op+2] = 0 + mf_op = mf_op + SGK_LENMCI + } +end + + +# SGK_MKFNAME -- Make the name of file N of a multiframe set. + +procedure sgk_mkfname (root, num, outstr, maxch) + +char root[ARB] # root filename +int num # file number +char outstr[maxch] # receives new filename +int maxch + +begin + call sprintf (outstr, maxch, "%s.%d") + call pargstr (root) + call pargi (num) +end diff --git a/sys/gio/sgikern/t_sgideco.x b/sys/gio/sgikern/t_sgideco.x new file mode 100644 index 00000000..57dae876 --- /dev/null +++ b/sys/gio/sgikern/t_sgideco.x @@ -0,0 +1,106 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "sgk.h" + +define LEN_MCBUF 3000 + + +# SGIDECODE -- Decode an SGI metacode file, printing the decoded metacode +# instructions on the standard output. + +procedure t_sgidecode() + +pointer sp, fname, mcbuf, ip, itop +int fd, list, verbose, gkiunits, nwords + +bool clgetb() +int clpopni(), clgfil(), clplen(), open(), btoi(), miireads() + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (mcbuf, LEN_MCBUF, TY_SHORT) + + # Open list of metafiles to be decoded. + list = clpopni ("input") + + if (clgetb ("generic")) { + verbose = NO + gkiunits = NO + } else { + verbose = btoi (clgetb ("verbose")) + gkiunits = btoi (clgetb ("gkiunits")) + } + + # Process a list of metacode files, writing the decoded metacode + # instructions on the standard output. + + while (clgfil (list, Memc[fname], SZ_FNAME) != EOF) { + # Print header if new file. + if (clplen (list) > 1) { + call printf ("\n# METAFILE `%s':\n") + call pargstr (Memc[fname]) + } + + # Open input file. + iferr (fd = open (Memc[fname], READ_ONLY, BINARY_FILE)) { + call erract (EA_WARN) + next + } + + # Process the metacode. + + itop = mcbuf + ip = mcbuf + + repeat { + if (ip >= itop) { + # Refill buffer. + nwords = miireads (fd, Mems[mcbuf], LEN_MCBUF) + if (nwords == EOF) + break + itop = mcbuf + nwords + ip = mcbuf + } + + switch (Mems[ip]) { + case SGK_FRAME: + call printf ("new_frame\n") + case SGK_MOVE: + if (gkiunits == YES) { + call printf ("move (%d, %d)\n") + call pargs (Mems[ip+1]) + call pargs (Mems[ip+2]) + } else { + call printf ("move (%0.5f, %0.5f)\n") + call pargr (real(Mems[ip+1]) / real(GKI_MAXNDC)) + call pargr (real(Mems[ip+2]) / real(GKI_MAXNDC)) + } + case SGK_DRAW: + if (gkiunits == YES) { + call printf ("draw (%d, %d)\n") + call pargs (Mems[ip+1]) + call pargs (Mems[ip+2]) + } else { + call printf ("draw (%0.5f, %0.5f)\n") + call pargr (real(Mems[ip+1]) / real(GKI_MAXNDC)) + call pargr (real(Mems[ip+2]) / real(GKI_MAXNDC)) + } + case SGK_SETLW: + call printf ("set_linewidth (%d)\n") + call pargs (Mems[ip+1]) + default: + call printf ("unknown instruction\n") + } + + ip = ip + SGK_LENMCI + } + + call close (fd) + } + + call clpcls (list) + call sfree (sp) +end diff --git a/sys/gio/sgikern/t_sgikern.x b/sys/gio/sgikern/t_sgikern.x new file mode 100644 index 00000000..359a87ad --- /dev/null +++ b/sys/gio/sgikern/t_sgikern.x @@ -0,0 +1,67 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# SGIKERN -- Generic graphics kernel for the standard plotter output. The whole +# package is copied as much as possible from the stdgraph package. + +procedure t_sgikern() + +int fd, list +pointer gki, sp, fname, devname +int dev[LEN_GKIDD], deb[LEN_GKIDD] +int debug, verbose, gkiunits +bool clgetb() +int clpopni(), clgfil(), open(), btoi() +int gki_fetch_next_instruction() + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (devname, SZ_FNAME, TY_CHAR) + + # Open list of metafiles to be decoded. + list = clpopni ("input") + + # Get parameters. + call clgstr ("device", Memc[devname], SZ_FNAME) + if (clgetb ("generic")) { + debug = NO + verbose = NO + gkiunits = NO + } else { + debug = btoi (clgetb ("debug")) + verbose = btoi (clgetb ("verbose")) + gkiunits = btoi (clgetb ("gkiunits")) + } + + # Open the graphics kernel. + call sgi_open (Memc[devname], dev) + call gkp_install (deb, STDERR, verbose, gkiunits) + + # Process a list of metacode files, writing the decoded metacode + # instructions on the standard output. + + while (clgfil (list, Memc[fname], SZ_FNAME) != EOF) { + # Open input file. + iferr (fd = open (Memc[fname], READ_ONLY, BINARY_FILE)) { + call erract (EA_WARN) + next + } + + # Process the metacode instruction stream. + while (gki_fetch_next_instruction (fd, gki) != EOF) { + if (debug == YES) + call gki_execute (Mems[gki], deb) + call gki_execute (Mems[gki], dev) + } + + call close (fd) + } + + call gkp_close() + call sgi_close() + call clpcls (list) + call sfree (sp) +end diff --git a/sys/gio/sgikern/x_sgikern.x b/sys/gio/sgikern/x_sgikern.x new file mode 100644 index 00000000..797820c2 --- /dev/null +++ b/sys/gio/sgikern/x_sgikern.x @@ -0,0 +1,5 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +task stdplot = t_sgikern, + sgikern = t_sgikern, + sgidecode = t_sgidecode diff --git a/sys/gio/stdgraph/README b/sys/gio/stdgraph/README new file mode 100644 index 00000000..6007b9b1 --- /dev/null +++ b/sys/gio/stdgraph/README @@ -0,0 +1,77 @@ +gio$stdgraph + + This directory contains the source and executables for the STDGRAPH and +GKIDECODE graphics kernels. The two kernels are implemented both as libraries +and as executable tasks. + + gkidecode This kernel is used standalone to examine GKI + metafiles. The real work is done by the GKIPRINT + library module in the GIO package. + + stdgraph A graphics kernel for graphics terminals. Implemented + both as the library "libstdg.a" and as the kernel task + STDGRAPH. The library is required for this kernel to + permit inclusion of the stdgraph kernel in the CL + process. + +Both kernels are available as CL callable tasks in the executable file +x_kernel.e. + + +GKIPRINT -- Graphics kernel for decoding metacode. This graphics kernel +formats metacode instructions into readable form and prints them on the output +file. The gkiprint kernel is useful for examining metafiles and for +debugging kernels which drive specific devices. The driver consists of the +following procedures: + + gkp_openws (devname, n, mode) + gkp_closews (devname, n) + gkp_mftitle (title, n) ** + gkp_clear (dummy) + gkp_cancel (dummy) + gkp_flush (dummy) + gkp_polyline (p, npts) + gkp_polymarker (p, npts) + gkp_text (x, y, text, n) + gkp_fillarea (p, npts) + gkp_getcellarray (m, nx, ny, x1,y1, x2,y2) + gkp_putcellarray (m, nx, ny, x1,y1, x2,y2) + gkp_setcursor (x, y, cursor) + gkp_plset (gki) + gkp_pmset (gki) + gkp_txset (gki) + gkp_faset (gki) + gkp_getcursor (cursor) + gkp_escape (fn, instruction, nwords) ** + gkp_setwcs (wcs, nwords) ** + gkp_getwcs (wcs, nwords) ** + gkp_unknown (gki) ** + +A GKI driven device driver may implement any subset of these procedures. +The starred procedures should be omitted by most drivers. In particular, +the SETWCS and GETWCS instructions are internal instructions which should +be ignored by ordinary device drivers. The procedure names may be anything, +but the arguments lists must be as shown. All coordinates are in GKI units, +0 to 32767. Character strings are passed in ASCII, one character per metacode +word. Whenever a GKI character string appears as an array argument in the +argument list of a procedure, the count N of the number of characters in the +string follows as the next argument. GKI character strings are not EOS +delimited. Polyline, polymarker, and fillarea data is passed as an array +of (x,y) points P, in GKI coordinates, defining the polyline or polygon to +be plotted. + +One additional procedure, GKP_INSTALL, is called by the main program of the +graphics kernel task to install the debugging driver, i.e., to fill the DD +array with the entry point addresses of the driver procedures. For a normal +driver this function is performed by a user supplied procedure named +GKOPEN (graphics kernel open). The user supplied kernel procedures will +be called to execute each instruction as the instructions are decoded by the +main routine. The user supplied procedure GKCLOSE will be called when +interpretation ends and the task is about to exit. + + gkopen (dd) + gkclose () + +Do not confuse GKOPEN and GKCLOSE, which open and close the graphics kernel, +with GKI_OPENWS and GKI_CLOSEWS, the metacode instructions used to direct +an opened kernel to open and close workstations. diff --git a/sys/gio/stdgraph/font.com b/sys/gio/stdgraph/font.com new file mode 100644 index 00000000..ec1b0ec9 --- /dev/null +++ b/sys/gio/stdgraph/font.com @@ -0,0 +1,207 @@ +# CHRTAB -- Table of strokes for the printable ASCII characters. Each character +# is encoded as a series of strokes. Each stroke is expressed by a single +# integer containing the following bitfields: +# +# 2 1 +# 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 +# | | | | | | | +# | | | +---------+ +---------+ +# | | | | | +# | | | X Y +# | | | +# | | +-- pen up/down +# | +---- begin paint (not used at present) +# +------ end paint (not used at present) +# +#------------------------------------------------------------------------------ + +# Define the database. + +short chridx[96] # character index in chrtab +short chrtab[800] # stroke data to draw the characters + +# Index into CHRTAB of each printable character (starting with SP). + +data (chridx(i), i=01,05) / 1, 3, 12, 21, 30/ +data (chridx(i), i=06,10) / 45, 66, 79, 85, 92/ +data (chridx(i), i=11,15) / 99, 106, 111, 118, 121/ +data (chridx(i), i=16,20) / 128, 131, 141, 145, 154/ +data (chridx(i), i=21,25) / 168, 177, 187, 199, 203/ +data (chridx(i), i=26,30) / 221, 233, 246, 259, 263/ +data (chridx(i), i=31,35) / 268, 272, 287, 307, 314/ +data (chridx(i), i=36,40) / 327, 336, 344, 352, 359/ +data (chridx(i), i=41,45) / 371, 378, 385, 391, 398/ +data (chridx(i), i=46,50) / 402, 408, 413, 425, 433/ +data (chridx(i), i=51,55) / 445, 455, 468, 473, 480/ +data (chridx(i), i=56,60) / 484, 490, 495, 501, 506/ +data (chridx(i), i=61,65) / 511, 514, 519, 523, 526/ +data (chridx(i), i=66,70) / 529, 543, 554, 563, 574/ +data (chridx(i), i=71,75) / 585, 593, 607, 615, 625/ +data (chridx(i), i=76,80) / 638, 645, 650, 663, 671/ +data (chridx(i), i=81,85) / 681, 692, 703, 710, 723/ +data (chridx(i), i=86,90) / 731, 739, 743, 749, 754/ +data (chridx(i), i=91,95) / 759, 764, 776, 781, 793/ +data (chridx(i), i=96,96) / 801/ + +# Stroke data. + +data (chrtab(i), i=001,005) / 36, 1764, 675, 29328, 585/ +data (chrtab(i), i=006,010) / 21063, 21191, 21193, 21065, 29383/ +data (chrtab(i), i=011,015) / 1764, 355, 29023, 351, 29027/ +data (chrtab(i), i=016,020) / 931, 29599, 927, 29603, 1764/ +data (chrtab(i), i=021,025) / 603, 29066, 842, 29723, 1302/ +data (chrtab(i), i=026,030) / 28886, 143, 29839, 1764, 611/ +data (chrtab(i), i=031,035) / 29256, 78, 20810, 21322, 21581/ +data (chrtab(i), i=036,040) / 21586, 21334, 20822, 20569, 20573/ +data (chrtab(i), i=041,045) / 20833, 21345, 29789, 1764, 419/ +data (chrtab(i), i=046,050) / 20707, 20577, 20574, 20700, 20892/ +data (chrtab(i), i=051,055) / 21022, 21025, 20899, 1187, 28744/ +data (chrtab(i), i=056,060) / 717, 21194, 21320, 21512, 21642/ +data (chrtab(i), i=061,065) / 21645, 21519, 21327, 21197, 1764/ +data (chrtab(i), i=066,070) / 1160, 20700, 20704, 20835, 21027/ +data (chrtab(i), i=071,075) / 21152, 21149, 20561, 20556, 20744/ +data (chrtab(i), i=076,080) / 21192, 29841, 1764, 611, 21023/ +data (chrtab(i), i=081,085) / 21087, 21155, 21091, 1764, 739/ +data (chrtab(i), i=086,090) / 21087, 21018, 21009, 21068, 29384/ +data (chrtab(i), i=091,095) / 1764, 547, 21151, 21210, 21201/ +data (chrtab(i), i=096,100) / 21132, 29192, 1764, 93, 29774/ +data (chrtab(i), i=101,105) / 608, 29259, 78, 29789, 1764/ +data (chrtab(i), i=106,110) / 604, 29260, 84, 29780, 1764/ +data (chrtab(i), i=111,115) / 516, 21062, 21065, 21001, 21000/ +data (chrtab(i), i=116,120) / 21064, 1764, 84, 29780, 1764/ +data (chrtab(i), i=121,125) / 585, 21063, 21191, 21193, 21065/ +data (chrtab(i), i=126,130) / 21191, 1764, 72, 29859, 1764/ +data (chrtab(i), i=131,135) / 419, 20573, 20558, 20872, 21320/ +data (chrtab(i), i=136,140) / 21646, 21661, 21347, 20899, 1764/ +data (chrtab(i), i=141,145) / 221, 21155, 29320, 1764, 95/ +data (chrtab(i), i=146,150) / 20835, 21411, 21663, 21655, 20556/ +data (chrtab(i), i=151,155) / 20552, 29832, 1764, 95, 20899/ +data (chrtab(i), i=156,160) / 21347, 21663, 21658, 21334, 29270/ +data (chrtab(i), i=161,165) / 854, 5266, 21644, 21320, 20872/ +data (chrtab(i), i=166,170) / 28749, 1764, 904, 21411, 21283/ +data (chrtab(i), i=171,175) / 20561, 20559, 21391, 911, 13455/ +data (chrtab(i), i=176,180) / 1764, 136, 21320, 21645, 21652/ +data (chrtab(i), i=181,185) / 21337, 20889, 20565, 20579, 29859/ +data (chrtab(i), i=186,190) / 1764, 83, 20888, 21336, 21651/ +data (chrtab(i), i=191,195) / 21645, 21320, 20872, 20557, 20563/ +data (chrtab(i), i=196,200) / 20635, 29347, 1764, 99, 21667/ +data (chrtab(i), i=201,205) / 29064, 1764, 355, 20575, 20570/ +data (chrtab(i), i=206,210) / 20822, 20562, 20556, 20808, 21384/ +data (chrtab(i), i=211,215) / 21644, 21650, 21398, 20822, 918/ +data (chrtab(i), i=216,220) / 5274, 21663, 21411, 20835, 1764/ +data (chrtab(i), i=221,225) / 648, 21584, 21656, 21662, 21347/ +data (chrtab(i), i=226,230) / 20899, 20574, 20568, 20883, 21331/ +data (chrtab(i), i=231,235) / 21656, 1764, 602, 21210, 21207/ +data (chrtab(i), i=236,240) / 21079, 21082, 21207, 592, 21069/ +data (chrtab(i), i=241,245) / 21197, 21200, 21072, 21197, 1764/ +data (chrtab(i), i=246,250) / 602, 21146, 21143, 21079, 21082/ +data (chrtab(i), i=251,255) / 21143, 585, 21132, 21136, 21072/ +data (chrtab(i), i=256,260) / 21071, 21135, 1764, 988, 20628/ +data (chrtab(i), i=261,265) / 29644, 1764, 1112, 28824, 144/ +data (chrtab(i), i=266,270) / 29776, 1764, 156, 21460, 28812/ +data (chrtab(i), i=271,275) / 1764, 221, 20704, 20899, 21218/ +data (chrtab(i), i=276,280) / 21471, 21466, 21011, 21007, 521/ +data (chrtab(i), i=281,285) / 20999, 21127, 21129, 21001, 21127/ +data (chrtab(i), i=286,290) / 1764, 908, 20812, 20560, 20571/ +data (chrtab(i), i=291,295) / 20831, 21407, 21659, 21651, 21521/ +data (chrtab(i), i=296,300) / 21393, 21331, 21335, 21210, 21018/ +data (chrtab(i), i=301,305) / 20887, 20883, 21009, 21201, 21331/ +data (chrtab(i), i=306,310) / 1764, 72, 20963, 21219, 29768/ +data (chrtab(i), i=311,315) / 210, 5074, 1764, 99, 21411/ +data (chrtab(i), i=316,320) / 21663, 21658, 21398, 20566, 918/ +data (chrtab(i), i=321,325) / 5266, 21644, 21384, 20552, 20579/ +data (chrtab(i), i=326,330) / 1764, 1165, 21320, 20872, 20557/ +data (chrtab(i), i=331,335) / 20574, 20899, 21347, 29854, 1764/ +data (chrtab(i), i=336,340) / 99, 21347, 21662, 21645, 21320/ +data (chrtab(i), i=341,345) / 20552, 20579, 1764, 99, 20552/ +data (chrtab(i), i=346,350) / 29832, 86, 13078, 99, 29859/ +data (chrtab(i), i=351,355) / 1764, 99, 20552, 86, 13078/ +data (chrtab(i), i=356,360) / 99, 29859, 1764, 722, 21650/ +data (chrtab(i), i=361,365) / 29832, 1165, 4936, 20872, 20557/ +data (chrtab(i), i=366,370) / 20574, 20899, 21347, 29854, 1764/ +data (chrtab(i), i=371,375) / 99, 28744, 85, 5269, 1160/ +data (chrtab(i), i=376,380) / 29859, 1764, 291, 29603, 611/ +data (chrtab(i), i=381,385) / 4680, 328, 29576, 1764, 77/ +data (chrtab(i), i=386,390) / 20872, 21256, 21581, 29795, 1764/ +data (chrtab(i), i=391,395) / 99, 28744, 1160, 20887, 82/ +data (chrtab(i), i=396,400) / 13475, 1764, 99, 20552, 29832/ +data (chrtab(i), i=401,405) / 1764, 72, 20579, 21077, 21603/ +data (chrtab(i), i=406,410) / 29768, 1764, 72, 20579, 21640/ +data (chrtab(i), i=411,415) / 29859, 1764, 94, 20899, 21347/ +data (chrtab(i), i=416,420) / 21662, 21645, 21320, 20872, 20557/ +data (chrtab(i), i=421,425) / 20574, 862, 29859, 1764, 72/ +data (chrtab(i), i=426,430) / 20579, 21411, 21663, 21656, 21396/ +data (chrtab(i), i=431,435) / 20564, 1764, 94, 20557, 20872/ +data (chrtab(i), i=436,440) / 21320, 21645, 21662, 21347, 20899/ +data (chrtab(i), i=441,445) / 20574, 536, 29828, 1764, 72/ +data (chrtab(i), i=446,450) / 20579, 21411, 21663, 21657, 21398/ +data (chrtab(i), i=451,455) / 20566, 918, 13448, 1764, 76/ +data (chrtab(i), i=456,460) / 20808, 21384, 21644, 21649, 21397/ +data (chrtab(i), i=461,465) / 20822, 20570, 20575, 20835, 21411/ +data (chrtab(i), i=466,470) / 29855, 1764, 648, 21155, 99/ +data (chrtab(i), i=471,475) / 29923, 1764, 99, 20557, 20872/ +data (chrtab(i), i=476,480) / 21320, 21645, 29859, 1764, 99/ +data (chrtab(i), i=481,485) / 21064, 29795, 1764, 99, 20808/ +data (chrtab(i), i=486,490) / 21141, 21448, 29923, 1764, 99/ +data (chrtab(i), i=491,495) / 29832, 72, 29859, 1764, 99/ +data (chrtab(i), i=496,500) / 21079, 29256, 599, 13411, 1764/ +data (chrtab(i), i=501,505) / 99, 21667, 20552, 29832, 1764/ +data (chrtab(i), i=506,510) / 805, 20965, 20935, 29447, 1764/ +data (chrtab(i), i=511,515) / 99, 29832, 1764, 421, 21221/ +data (chrtab(i), i=516,520) / 21191, 29063, 1764, 288, 21091/ +data (chrtab(i), i=521,525) / 29600, 1764, 3, 29891, 1764/ +data (chrtab(i), i=526,530) / 547, 29341, 1764, 279, 21207/ +data (chrtab(i), i=531,535) / 21396, 21387, 21127, 20807, 20555/ +data (chrtab(i), i=536,540) / 20558, 20753, 21201, 21391, 907/ +data (chrtab(i), i=541,545) / 13447, 1764, 99, 28744, 76/ +data (chrtab(i), i=546,550) / 4424, 21256, 21516, 21523, 21271/ +data (chrtab(i), i=551,555) / 20823, 20563, 1764, 981, 21271/ +data (chrtab(i), i=556,560) / 20823, 20563, 20556, 20808, 21256/ +data (chrtab(i), i=561,565) / 29642, 1764, 1043, 4887, 20823/ +data (chrtab(i), i=566,570) / 20563, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=571,575) / 1032, 29731, 1764, 80, 5136/ +data (chrtab(i), i=576,580) / 21523, 21271, 20823, 20563, 20556/ +data (chrtab(i), i=581,585) / 20808, 21256, 29707, 1764, 215/ +data (chrtab(i), i=586,590) / 29591, 456, 20958, 21153, 21409/ +data (chrtab(i), i=591,595) / 29727, 1764, 67, 20800, 21248/ +data (chrtab(i), i=596,600) / 21508, 29719, 1043, 21271, 20823/ +data (chrtab(i), i=601,605) / 20563, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=606,610) / 1764, 99, 28744, 83, 4439/ +data (chrtab(i), i=611,615) / 21271, 21523, 29704, 1764, 541/ +data (chrtab(i), i=616,620) / 21019, 21147, 21149, 21021, 21147/ +data (chrtab(i), i=621,625) / 533, 21077, 29256, 1764, 541/ +data (chrtab(i), i=626,630) / 21019, 21147, 21149, 21021, 21147/ +data (chrtab(i), i=631,635) / 533, 21077, 21058, 20928, 20736/ +data (chrtab(i), i=636,640) / 28802, 1764, 99, 28744, 84/ +data (chrtab(i), i=641,645) / 29530, 342, 13320, 1764, 483/ +data (chrtab(i), i=646,650) / 21089, 21066, 29384, 1764, 87/ +data (chrtab(i), i=651,655) / 28744, 584, 21076, 84, 4375/ +data (chrtab(i), i=656,660) / 20951, 21076, 21207, 21399, 21588/ +data (chrtab(i), i=661,665) / 29768, 1764, 87, 28744, 83/ +data (chrtab(i), i=666,670) / 20823, 21271, 21523, 29704, 1764/ +data (chrtab(i), i=671,675) / 83, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=676,680) / 21523, 21271, 20823, 20563, 1764/ +data (chrtab(i), i=681,685) / 87, 28736, 83, 20823, 21271/ +data (chrtab(i), i=686,690) / 21523, 21516, 21256, 20808, 20556/ +data (chrtab(i), i=691,695) / 1764, 1047, 29696, 1036, 21256/ +data (chrtab(i), i=696,700) / 20808, 20556, 20563, 20823, 21271/ +data (chrtab(i), i=701,705) / 21523, 1764, 87, 28744, 83/ +data (chrtab(i), i=706,710) / 20823, 21271, 29716, 1764, 74/ +data (chrtab(i), i=711,715) / 20808, 21256, 21514, 21518, 21264/ +data (chrtab(i), i=716,720) / 20816, 20562, 20565, 20823, 21271/ +data (chrtab(i), i=721,725) / 21461, 1764, 279, 29591, 970/ +data (chrtab(i), i=726,730) / 21320, 21128, 21002, 21025, 1764/ +data (chrtab(i), i=731,735) / 87, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=736,740) / 1032, 29719, 1764, 151, 21064/ +data (chrtab(i), i=741,745) / 29719, 1764, 87, 20808, 21077/ +data (chrtab(i), i=746,750) / 21320, 29783, 1764, 151, 29704/ +data (chrtab(i), i=751,755) / 136, 29719, 1764, 87, 21064/ +data (chrtab(i), i=756,760) / 320, 29783, 1764, 151, 21527/ +data (chrtab(i), i=761,765) / 20616, 29704, 1764, 805, 21157/ +data (chrtab(i), i=766,770) / 21026, 21017, 20951, 20822, 20949/ +data (chrtab(i), i=771,775) / 21011, 21001, 21127, 21255, 1764/ +data (chrtab(i), i=776,780) / 611, 29273, 594, 29256, 1764/ +data (chrtab(i), i=781,785) / 485, 21093, 21218, 21209, 21271/ +data (chrtab(i), i=786,790) / 21398, 21269, 21203, 21193, 21063/ +data (chrtab(i), i=791,795) / 29127, 1764, 83, 20758, 20950/ +data (chrtab(i), i=796,800) / 21265, 21457, 29844, 1764, 0/ diff --git a/sys/gio/stdgraph/font.h b/sys/gio/stdgraph/font.h new file mode 100644 index 00000000..c33dc6ee --- /dev/null +++ b/sys/gio/stdgraph/font.h @@ -0,0 +1,29 @@ +# NCAR font definitions. + +define CHARACTER_START 32 +define CHARACTER_END 126 +define CHARACTER_HEIGHT 26 +define CHARACTER_WIDTH 17 + +define FONT_LEFT 0 +define FONT_CENTER 9 +define FONT_RIGHT 27 +define FONT_TOP 36 +define FONT_CAP 34 +define FONT_HALF 23 +define FONT_BASE 9 +define FONT_BOTTOM 0 +define FONT_WIDTH 27 +define FONT_HEIGHT 36 + +define COORD_X_START 7 +define COORD_Y_START 1 +define COORD_PEN_START 13 +define COORD_X_LEN 6 +define COORD_Y_LEN 6 +define COORD_PEN_LEN 1 + +define PAINT_BEGIN_START 14 +define PAINT_END_START 15 +define PAINT_BEGIN_LEN 1 +define PAINT_END_LEN 1 diff --git a/sys/gio/stdgraph/mkpkg b/sys/gio/stdgraph/mkpkg new file mode 100644 index 00000000..8530f2c9 --- /dev/null +++ b/sys/gio/stdgraph/mkpkg @@ -0,0 +1,80 @@ +# Make the STDGRAPH GIO graphics kernel. + +$checkout libstg.a lib$ +$update libstg.a +$checkin libstg.a lib$ +$exit + +update: # update lib$x_stdgraph.e + $call relink + $call install + ; + +relink: # make x_stdgraph.e in local directory + $omake x_stdgraph.x + $link x_stdgraph.o -lstg + ; + +install: # install in system library + $move x_stdgraph.e bin$ + ; + +libstg.a: + # $set xflags = "$(xflags) -qfx" + + stgcancel.x stdgraph.com stdgraph.h + stgclear.x stdgraph.com stdgraph.h + stgclose.x stdgraph.com stdgraph.h + stgclws.x stdgraph.h stdgraph.com + stgctrl.x stdgraph.com stdgraph.h + stgdeact.x stdgraph.com stdgraph.h + stgdraw.x stdgraph.com stdgraph.h + stgdrawch.x font.com font.h stdgraph.com stdgraph.h \ + + stgencode.x stdgraph.com stdgraph.h + stgescape.x + stgfa.x stdgraph.com stdgraph.h + stgfaset.x stdgraph.com stdgraph.h + stgfilter.x stdgraph.com stdgraph.h + stgflush.x stdgraph.com stdgraph.h + stggcell.x + stggcur.x stdgraph.com stdgraph.h + stggdisab.x stdgraph.com stdgraph.h + stggim.x stdgraph.com stdgraph.h \ + + stggenab.x stdgraph.com stdgraph.h + stggrstr.x stdgraph.com stdgraph.h + stginit.x stdgraph.com stdgraph.h \ + + stglkcur.x stdgraph.com stdgraph.h + stgmove.x stdgraph.com stdgraph.h + stgonerr.x stdgraph.com stdgraph.h + stgonint.x stdgraph.h + stgopen.x stdgraph.com stdgraph.h + stgopenws.x stdgraph.com stdgraph.h \ + + stgoutput.x stdgraph.com stdgraph.h + stgoutstr.x stdgraph.com stdgraph.h + stgpcell.x stdgraph.com stdgraph.h + stgpl.x stdgraph.com stdgraph.h + stgplset.x stdgraph.com stdgraph.h + stgpm.x stdgraph.com stdgraph.h + stgpmset.x stdgraph.com stdgraph.h + stgrcur.x stdgraph.com stdgraph.h \ + + stgreact.x stdgraph.com stdgraph.h + stgres.x stdgraph.com stdgraph.h + stgreset.x stdgraph.com stdgraph.h + stgrtty.x stdgraph.com stdgraph.h + stgscur.x stdgraph.com stdgraph.h + stgtx.x stdgraph.com stdgraph.h \ + + stgtxqual.x stdgraph.com stdgraph.h + stgtxset.x stdgraph.com stdgraph.h + stgtxsize.x stdgraph.com stdgraph.h + stgunkown.x + stgwtty.x stdgraph.com stdgraph.h + t_gkideco.x + t_showcap.x stdgraph.h + t_stdgraph.x + ; diff --git a/sys/gio/stdgraph/stdgraph.com b/sys/gio/stdgraph/stdgraph.com new file mode 100644 index 00000000..3d3c43c5 --- /dev/null +++ b/sys/gio/stdgraph/stdgraph.com @@ -0,0 +1,46 @@ +# STDGRAPH common. A common is necessary since there is no graphics descriptor +# in the argument list of the kernel procedures. The stdgraph data structures +# are designed along the lines of FIO: a small common is used to hold the time +# critical data elements, and an auxiliary dynamically allocated descriptor is +# used for everything else. For maximum efficiency the polyline generation and +# coordinate transformation datums are kept in the common. + +pointer g_sg # stdgraph graphics descriptor +pointer g_tty # graphcap descriptor +pointer g_term # termcap descriptor for terminal +pointer g_pbtty # script graphcap, playback mode +int g_nopen # open count for the kernel +int g_active # workstation is open for graphics i/o +int g_enable # graphics is enabled +int g_message # message mode (output text) +pointer g_msgbuf # message buffer (input text) +int g_msgbuflen # allocated size of message buffer +int g_msglen # amount of data in message +int g_keycol # used to show keys in playback mode +int g_keyline # used to show keys in playback mode +pointer g_xy # pointer to coord encoding string +int g_stream # graphics stream (metacode) +int g_in, g_out # input, output streams to device +int g_ucaseout # stty ucaseout status flag +int g_xres, g_yres # desired device resolution +int g_dxres, g_dyres # scale down to resolution coords +real g_dx, g_dy # scale GKI to window coords +int g_x1, g_y1 # origin of device window +int g_x2, g_y2 # upper right corner of device window +int g_lastx, g_lasty # used to clip unresolved points +int g_hardchar # controls use of hardware character gen +int g_cursor # user override of logical cursor +int g_reg[NREGISTERS] # encoder registers +char g_mem[SZ_MEMORY] # encoder memory +char g_device[SZ_GDEVICE] # device name for forced device output +char g_pbdevice[SZ_GDEVICE] # device name of playback script +char g_hixy[TEK_XRES] # lookup tables for tek encoding +char g_lox[TEK_XRES] # " " +char g_loy[TEK_YRES] # " " + +common /stgcom/ g_sg, g_tty, g_term, g_pbtty, g_nopen, g_active, g_enable, + g_message, g_msgbuf, g_msgbuflen, g_msglen, + g_keycol, g_keyline, g_xy, g_stream, g_in, g_out, + g_ucaseout, g_xres, g_yres, g_dxres, g_dyres, g_dx, g_dy, g_x1, + g_y1, g_x2, g_y2, g_lastx, g_lasty, g_hardchar, g_cursor, g_reg, + g_mem, g_device, g_pbdevice, g_hixy, g_lox, g_loy diff --git a/sys/gio/stdgraph/stdgraph.h b/sys/gio/stdgraph/stdgraph.h new file mode 100644 index 00000000..de216065 --- /dev/null +++ b/sys/gio/stdgraph/stdgraph.h @@ -0,0 +1,98 @@ +# STDGRAPH definitions. + +define MAX_CHARSIZES 10 # max discreet device char sizes +define SZ_SBUF 2048 # initial string buffer size +define SZ_MEMORY 1024 # encoder memory size +define SZ_GDEVICE 256 # force output to named device +define SZ_UIFNAME 199 # user interface file name +define SZ_MSGBUF 4096 # default size message buffer +define FLUSH_MEMORY 117 # time to flush encoded polyline +define LEN_STACK 20 # encoder stack size +define NREGISTERS 12 # number of encoder registers +define E_IOP 11 # encoder i/o pointer register +define E_TOP 12 # encoder top memory register +define LONG_POLYLINE 50 # big enough to post X_INT +define PADCHAR 0 # used to gen. delays + +# The user can have private copies of UI specifications in GUIDIR. +define GUIDIR "guidir" + +# The STDGRAPH state/device descriptor. + +define LEN_SG 91 + +define SG_SBUF Memi[$1] # string buffer +define SG_SZSBUF Memi[$1+1] # size of string buffer +define SG_NEXTCH Memi[$1+2] # next char pos in string buf +define SG_NCHARSIZES Memi[$1+3] # number of character sizes +define SG_POLYLINE Memi[$1+4] # polyline output permitted +define SG_POLYMARKER Memi[$1+5] # device supports polymarker +define SG_FILLAREA Memi[$1+6] # device supports fillarea +define SG_ENCODEXY Memi[$1+7] # format for encoding coords +define SG_STARTDRAW Memi[$1+8] # pointer to DS string +define SG_ENDDRAW Memi[$1+9] # pointer to DE string +define SG_STARTMOVE Memi[$1+10] # pointer to VS string +define SG_ENDMOVE Memi[$1+11] # pointer to VE string +define SG_STARTMARK Memi[$1+12] # pointer to MS string +define SG_ENDMARK Memi[$1+13] # pointer to ME string +define SG_STARTFILL Memi[$1+14] # pointer to FS string +define SG_ENDFILL Memi[$1+15] # pointer to FE string +define SG_STARTTEXT Memi[$1+16] # start text draw +define SG_ENDTEXT Memi[$1+17] # end text draw +define SG_CURSOR Memi[$1+18] # last cursor accessed +define SG_UPDCURSOR Memi[$1+19] # update cursor pos before read +define SG_CURSOR_X Memi[$1+20] # current cursor X position +define SG_CURSOR_Y Memi[$1+21] # current cursor Y position +define SG_COLOR Memi[$1+22] # last color set +define SG_TXSIZE Memi[$1+23] # last text size set +define SG_TXFONT Memi[$1+24] # last text font set +define SG_PLTYPE Memi[$1+25] # last line type set +define SG_FASTYLE Memi[$1+26] # last fill area style set +define SG_PLWIDTH Memi[$1+27] # last line width set +define SG_DEVNAME Memi[$1+28] # name of open device +define SG_UIFNAME Memi[$1+29] # user interface file name +define SG_UIFDATE Memi[$1+30] # UI file date + # empty +define SG_CHARHEIGHT Memi[$1+40+$2-1] # character height +define SG_CHARWIDTH Memi[$1+50+$2-1] # character width +define SG_CHARSIZE Memr[P2R($1+60+$2-1)] # text sizes permitted +define SG_PLAP ($1+70) # polyline attributes +define SG_PMAP ($1+74) # polymarker attributes +define SG_FAAP ($1+78) # fill area attributes +define SG_TXAP ($1+81) # default text attributes + +# Substructure definitions. + +define LEN_PL 4 +define PL_STATE Memi[$1] # polyline attributes +define PL_LTYPE Memi[$1+1] +define PL_WIDTH Memi[$1+2] +define PL_COLOR Memi[$1+3] + +define LEN_PM 4 +define PM_STATE Memi[$1] # polymarker attributes +define PM_LTYPE Memi[$1+1] +define PM_WIDTH Memi[$1+2] +define PM_COLOR Memi[$1+3] + +define LEN_FA 3 # fill area attributes +define FA_STATE Memi[$1] +define FA_STYLE Memi[$1+1] +define FA_COLOR Memi[$1+2] + +define LEN_TX 10 # text attributes +define TX_STATE Memi[$1] +define TX_UP Memi[$1+1] +define TX_SIZE Memi[$1+2] +define TX_PATH Memi[$1+3] +define TX_SPACING Memr[P2R($1+4)] +define TX_HJUSTIFY Memi[$1+5] +define TX_VJUSTIFY Memi[$1+6] +define TX_FONT Memi[$1+7] +define TX_QUALITY Memi[$1+8] +define TX_COLOR Memi[$1+9] + +# TEK 4012 definitions for optimized tek coordinate encoding. + +define TEK_XRES 1024 +define TEK_YRES 780 diff --git a/sys/gio/stdgraph/stgcancel.x b/sys/gio/stdgraph/stgcancel.x new file mode 100644 index 00000000..d47e24df --- /dev/null +++ b/sys/gio/stdgraph/stgcancel.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stdgraph.h" + +# STG_CANCEL -- Cancel any buffered output. + +procedure stg_cancel (dummy) + +int dummy # not used at present +include "stdgraph.com" + +begin + call fseti (g_out, F_CANCEL, YES) + call stg_reset() +end diff --git a/sys/gio/stdgraph/stgclear.x b/sys/gio/stdgraph/stgclear.x new file mode 100644 index 00000000..9573c972 --- /dev/null +++ b/sys/gio/stdgraph/stgclear.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_CLEAR -- Clear the workstation screen. All attribute packets are +# initialized to their default values when the screen is cleared. + +procedure stg_clear (dummy) + +int dummy # not used at present +include "stdgraph.com" + +begin + call stg_ctrl ("CL") + call stg_reset() +end diff --git a/sys/gio/stdgraph/stgclose.x b/sys/gio/stdgraph/stgclose.x new file mode 100644 index 00000000..3d7eb70b --- /dev/null +++ b/sys/gio/stdgraph/stgclose.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_CLOSE -- Close the STDGRAPH kernel. Free all storage associated with the +# stdgraph descriptor. Note that the stdgraph kernel may be multiply opened +# (connected to two or more graphics steams, e.g., both STDGRAPH and STDIMAGE), +# hence we do not physically close down until the last stream is closed. + +procedure stg_close() + +include "stdgraph.com" + +begin + g_nopen = g_nopen - 1 + + if (g_nopen <= 0) { + call stg_deactivatews (0) + call flush (g_out) + call mfree (SG_SBUF(g_sg), TY_CHAR) + call mfree (g_sg, TY_STRUCT) + + if (g_tty != NULL) { + call ttycdes (g_tty) + g_tty = NULL + } + + if (g_term != NULL) { + call ttycdes (g_term) + g_term = NULL + } + + if (g_pbtty != NULL) { + call ttycdes (g_pbtty) + g_pbtty = NULL + } + + if (g_msgbuf != NULL) { + call mfree (g_msgbuf, TY_CHAR) + g_msgbuf = NULL + g_msgbuflen = 0 + g_msglen = 0 + } + + g_nopen = 0 + } +end diff --git a/sys/gio/stdgraph/stgclws.x b/sys/gio/stdgraph/stgclws.x new file mode 100644 index 00000000..137784cd --- /dev/null +++ b/sys/gio/stdgraph/stgclws.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stdgraph.h" + +# STG_CLOSEWS -- Close the named workstation. Output the termination string, +# if any, and flush the output. Buffer deallocation is handled by STGCLOSE. + +procedure stg_closews (devname, n) + +short devname[ARB] # device name (not used) +int n # length of device name + +include "stdgraph.com" + +begin + call stg_ctrl ("CW") + call flush (g_out) + + g_active = NO + g_enable = NO + + # Reenable stty ucaseout mode if it was set when the workstation + # was activated. + + if (g_ucaseout == YES) + call ttseti (g_out, TT_UCASEOUT, YES) +end diff --git a/sys/gio/stdgraph/stgctrl.x b/sys/gio/stdgraph/stgctrl.x new file mode 100644 index 00000000..6689de8a --- /dev/null +++ b/sys/gio/stdgraph/stgctrl.x @@ -0,0 +1,82 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +define SZ_PROGRAM 256 + +# STG_CTRL -- Fetch an encoder format string from the graphcap entry and +# use it to encode zero, one, or two integer arguments into a control string. +# Put the control string to the output device. + +procedure stg_ctrl (cap) + +char cap[ARB] # name of device capability to be encoded +pointer sp, prog +int stg_encode(), ttygets() +include "stdgraph.com" + +begin + call smark (sp) + call salloc (prog, SZ_PROGRAM, TY_CHAR) + + # Fetch the program from the graphcap file. Zero is returned if the + # device does not have the named capability, in which case the function + # is inapplicable and should be ignored. + + if (ttygets (g_tty, cap, Memc[prog], SZ_PROGRAM) > 0) { + # Encode the output string and write the encoded string to the + # output file. + g_reg[E_IOP] = 1 + if (stg_encode (Memc[prog], g_mem, g_reg) == OK) { + g_mem[g_reg[E_IOP]] = EOS + call ttyputs (g_out, g_tty, g_mem, 1) + } + } + + call sfree (sp) +end + + +# STG_CTRL1 -- Encode one integer argument. + +procedure stg_ctrl1 (cap, arg1) + +char cap[ARB] # device capability +int arg1 +include "stdgraph.com" + +begin + g_reg[1] = arg1 + call stg_ctrl (cap) +end + + +# STG_CTRL2 -- Encode two integer arguments. + +procedure stg_ctrl2 (cap, arg1, arg2) + +char cap[ARB] # device capability +int arg1, arg2 +include "stdgraph.com" + +begin + g_reg[1] = arg1 + g_reg[2] = arg2 + call stg_ctrl (cap) +end + + +# STG_CTRL3 -- Encode three integer arguments. + +procedure stg_ctrl3 (cap, arg1, arg2, arg3) + +char cap[ARB] # device capability +int arg1, arg2, arg3 +include "stdgraph.com" + +begin + g_reg[1] = arg1 + g_reg[2] = arg2 + g_reg[3] = arg3 + call stg_ctrl (cap) +end diff --git a/sys/gio/stdgraph/stgdeact.x b/sys/gio/stdgraph/stgdeact.x new file mode 100644 index 00000000..b11e4a07 --- /dev/null +++ b/sys/gio/stdgraph/stgdeact.x @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "stdgraph.h" + +# STG_DEACTIVATEWS -- Deactivate the workstation, i.e., disable graphics, +# leaving the terminal in text mode. Note that it is the CW (close +# workstation) sequence which is actually output, since the GD sequence is +# used only to write single lines of text to the status line. + +procedure stg_deactivatews (flags) + +int flags # action modifier flags + +char buf[1] +int stg_readtty(), and() +include "stdgraph.com" + +begin + if (g_out <= 0) + return + + # The g_active and g_out test permits us to be called before the + # kernel is opened and causes redundant calls to be ignored. + + if (g_active == YES) { + # Pause before deactivating? + if (and (flags, AW_PAUSE) != 0) { + call stg_putline (g_out, "\n[Hit return to continue]\n") + while (stg_readtty (STDIN, buf, 1) != EOF) + if (buf[1] == '\r' || buf[1] == '\n') + break + } + + # Deactivate the workstation. + call stgctrl ("CW") + + g_active = NO + g_enable = NO + + # Reenable stty ucaseout mode if it was set when the workstation + # was activated. + + if (g_ucaseout == YES) + call ttseti (g_out, TT_UCASEOUT, YES) + } + + # Clear the text screen? + if (and (flags, AW_CLEAR) != 0 && g_term != NULL) + call ttyclear (g_out, g_term) + + call flush (g_out) +end diff --git a/sys/gio/stdgraph/stgdraw.x b/sys/gio/stdgraph/stgdraw.x new file mode 100644 index 00000000..ae5a4ace --- /dev/null +++ b/sys/gio/stdgraph/stgdraw.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_DRAW -- Output a device draw line-segment instruction to draw from the +# current position to the position (x,y) in GKI coordinates. + +procedure stg_draw (x, y) + +int x, y # destination +int stg_encode() +include "stdgraph.com" + +begin + # Transform the first point from GKI coords to device coords and + # draw to the transformed point. + + call ttyputs (g_out, g_tty, Memc[SG_STARTDRAW(g_sg)], 1) + + g_reg[1] = x * g_dx + g_x1 + g_reg[2] = y * g_dy + g_y1 + g_reg[E_IOP] = 1 + if (stg_encode (Memc[g_xy], g_mem, g_reg) == OK) + call write (g_out, g_mem, g_reg[E_IOP] - 1) + + call ttyputs (g_out, g_tty, Memc[SG_ENDDRAW(g_sg)], 1) +end diff --git a/sys/gio/stdgraph/stgdrawch.x b/sys/gio/stdgraph/stgdrawch.x new file mode 100644 index 00000000..fd317d2b --- /dev/null +++ b/sys/gio/stdgraph/stgdrawch.x @@ -0,0 +1,144 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "stdgraph.h" +include "font.h" + +define ITALIC_TILT 0.30 # fraction of xsize to tilt italics at top +define MAXPTS 40 # max points in a char drawing polyline + + +# STG_DRAWCHAR -- Draw a character of the given size and orientation at the +# given position. + +procedure stg_drawchar (ch, x, y, xsize, ysize, orien, font) + +char ch # character to be drawn +int x, y # lower left GKI coords of character +int xsize, ysize # width, height of char in GKI units +int orien # orientation of character (0 degrees normal) +int font # desired character font + +pointer pl, tx +real px, py, coso, sino, theta +int stroke, tab1, tab2, i, pen, mx, my +int save_ltype, save_lwidth, save_color +int bitupk() +include "font.com" +include "stdgraph.com" + +begin + if (ch < CHARACTER_START || ch > CHARACTER_END) + i = '?' - CHARACTER_START + 1 + else + i = ch - CHARACTER_START + 1 + + # Set the font. + if (SG_TXFONT(g_sg) != font) { + call stg_ctrl1 ("TF", font - GT_ROMAN + 1) + SG_TXFONT(g_sg) = font + } + + # Since we will be using the polyline generator, set the polyline + # linetype to solid and save the current linetype for later restoration. + + pl = SG_PLAP(g_sg) + tx = SG_TXAP(g_sg) + save_color = PL_COLOR(pl) + save_ltype = PL_LTYPE(pl) + save_lwidth = PL_WIDTH(pl) + PL_COLOR(pl) = TX_COLOR(tx) + PL_LTYPE(pl) = GL_SOLID + PL_WIDTH(pl) = 1 + + tab1 = chridx[i] + tab2 = chridx[i+1] - 1 + + theta = -DEGTORAD(orien) + coso = cos(theta) + sino = sin(theta) + + do i = tab1, tab2 { + stroke = chrtab[i] + px = bitupk (stroke, COORD_X_START, COORD_X_LEN) + py = bitupk (stroke, COORD_Y_START, COORD_Y_LEN) + pen = bitupk (stroke, COORD_PEN_START, COORD_PEN_LEN) + + # Scale size of character. + px = px / FONT_WIDTH * xsize + py = py / FONT_HEIGHT * ysize + + # The italic font is implemented applying a tilt. + if (font == GT_ITALIC) + px = px + ((py / ysize) * xsize * ITALIC_TILT) + + # Rotate and shift. + mx = x + px * coso + py * sino + my = y - px * sino + py * coso + + # Draw the line segment or move pen. + if (pen == 0) + call sgch_move (mx, my) + else + call sgch_draw (mx, my) + } + + # Flush any remaining points. + call sgch_flush() + + # Restore polyline linetype and color. + PL_LTYPE(pl) = save_ltype + PL_WIDTH(pl) = save_lwidth + PL_COLOR(pl) = save_color +end + + +# SGCH_MOVE -- Start accumulating a new polyline. + +procedure sgch_move (mx, my) + +int mx, my +short pl[MAXPTS], op +common /sgchcm/ pl, op + +begin + call sgch_flush() + + pl[1] = mx + pl[2] = my + op = 3 +end + + +# SGCH_DRAW -- Add a point to the polyline. + +procedure sgch_draw (mx, my) + +int mx, my +short pl[MAXPTS], op +common /sgchcm/ pl, op + +begin + pl[op] = mx + pl[op+1] = my + op = min (MAXPTS, op + 2) +end + + +# SGCH_FLUSH -- Flush the polyline to the output device. + +procedure sgch_flush() + +int npts +short pl[MAXPTS], op +common /sgchcm/ pl, op + +begin + if (op > 2) { + npts = op / 2 + call stg_polyline (pl, npts) + } + op = 1 +end diff --git a/sys/gio/stdgraph/stgencode.x b/sys/gio/stdgraph/stgencode.x new file mode 100644 index 00000000..3c7a6ffb --- /dev/null +++ b/sys/gio/stdgraph/stgencode.x @@ -0,0 +1,539 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stdgraph.h" + +.help stg_encode +.nf _________________________________________________________________________ +STG_ENCODE -- Table driven binary encoder/decoder. The encoder (which can +also decode) processes a format string, also referred to as a program, to +either encode an output string or decode an input string. Internally the +encoder operates in two modes, copy mode and execute mode. In copy mode +all format characters are copied to the output except the following special +characters: + + ' escape next character (literal) + % begin a formatted output string + ( switch to execute mode (stack driven, RPN interpreter) + +An ( appearing in the format string causes a mode switch to execute mode. +In execute mode characters are metacode instructions to be executed. An +unescaped ) causes reversion to copy mode. Parens may not be nested; an +( in execute mode is an instruction to push the binary value of ( on the +stack, and an ) in copy mode is copied to the output as a character. In +execute mode the following characters are recognized as special instructions. +All other characters are instructions too, telling the encoder to push the +ASCII value of the character on the stack. + + ' escape next character (recognized everywhere) + % formatted output + ) revert to copy mode + #nnn push signed decimal integer number nnn + $ switch case construct + . pop number from stack and place in output string + , get next character from input string and push on stack + & modulus (similar to AND of low bits) + + add (similar to OR) + - subtract (similar to AND) + * multiply (shift left if pwr of 2) + / divide (shift right if pwr of 2) + < less than (0=false, 1=true) + > greater than (0=false, 1=true) + = equals (0=false, 1=true) + ; branch if: ;. The ; is at offset zero. + 0-9 push register + !N pop stack into register N + !! pop N from stack and output an N millisecond delay + +The encoder communicates with the outside world via three general purpose +data structures. + + registers 0-9 (integer only) + memory char array + program char array + +The registers are used for parameter input and output as well as for storing +intermediate results. R 1-3 are used for input and output arguments. R 4-9 +and R0 (R10) are reserved for use by the program. R11 is the i/o pointer into +encoder memory, used for character input and output. R12 should contain the +maximum memory address upon input. Memory may be used for anything but is +normally used only for the input string or output string. The program is the +format string. + +Further documentation is given in the GIO reference manual. +.endhelp _____________________________________________________________________ + +define SZ_FORMAT 10 # max length printf format +define SZ_NUMSTR 10 # encoded numeric string + +define R1 registers[1] # argument +define R2 registers[2] # argument +define R3 registers[3] # argument +define R4 registers[4] # scratch +define R5 registers[5] # scratch +define R6 registers[6] # scratch +define R7 registers[7] # scratch +define R8 registers[8] # scratch +define R9 registers[9] # scratch +define R0 registers[10] # scratch +define IOP registers[11] # i/o pointer into encoder memory +define TOP registers[12] # max memory location + +# Inline macros. + +define memory_overflow_ 1 +define stack_underflow_ 2 +define stack_overflow_ 3 + +define input {$1=memory[iop];iop=iop+1} +define output {memory[iop]=($1);iop=iop+1;if(iop>top)goto memory_overflow_} +define push {stack[sp]=($1);sp=sp+1} +define pop {sp=sp-1;$1=stack[sp]} + + +# STG_ENCODE -- Interpret a program, encoding values passed in registers into +# memory, or decoding memory into registers. + +int procedure stg_encode (program, memory, registers) + +char program[ARB] # program to be executed +char memory[ARB] # data space +int registers[NREGISTERS] # general purpose registers + +int x, y, num, ch, status +int stack[LEN_STACK] +int sp, pc, iop, top, incase +common /sgecom/ pc, sp, iop, top, incase, stack +int sge_execute() +include "stdgraph.com" + +begin + # TEK format, %t. This format deserves special treatment due to the + # prevalence of tektronix compatible graphics terminals. + + if (program[1] == '%' && program[2] == 't') { + x = R1 + y = R2 + iop = IOP + 4 + if (iop > top) + goto memory_overflow_ + + memory[iop-4] = g_hixy[y+1] + memory[iop-3] = g_loy[y+1] + memory[iop-2] = g_hixy[x+1] + memory[iop-1] = g_lox[x+1] + + IOP = iop + if (program[3] == EOS) + return (OK) + } + + # Process a general format string (as well as any chars following the + # %t format). + + incase = NO + iop = IOP + top = TOP + pc = 1 + sp = 1 + + for (ch=program[pc]; ch != EOS; ch=program[pc]) { + pc = pc + 1 + if (ch == '%' && program[pc] != EOS) { + if (program[pc] == 't') { + # Tek format again. + pc = pc + 1 + x = R1 + y = R2 + iop = iop + 4 + if (iop > top) + goto memory_overflow_ + + memory[iop-4] = g_hixy[y+1] + memory[iop-3] = g_loy[y+1] + memory[iop-2] = g_hixy[x+1] + memory[iop-1] = g_lox[x+1] + + } else { + # Extract a general format specification and use it to + # encode the number on top of the stack. + pop (num) + if (sp < 1) { + IOP = iop + return (stack_underflow_) + } else + call sge_printf (num, memory, iop, top, program, pc) + } + + } else if (ch == '(' && program[pc] != EOS) { + # Switch to execute mode. + status = sge_execute (program, memory, registers) + if (status != OK) + return (status) + + } else if (ch == '\'' && program[pc] != EOS) { + # Escape next character. + output (program[pc]) + pc = pc + 1 + + } else { + # Copy an ordinary character to the output string. + output (ch) + } + } + + IOP = iop + return (OK) + +memory_overflow_ + IOP = iop + return (memory_overflow_) +end + + +# SGE_EXECUTE -- Execute a metacode program stored in encoder memory starting +# at the location of the PC. The stack, program counter, i/o pointer, and +# registers are shared by the copy and execute mode procedures via common. + +int procedure sge_execute (program, memory, registers) + +char program[ARB] # program to be executed +char memory[ARB] # data space +int registers[NREGISTERS] # general purpose registers + +int num, ch, a, b, neg, x, y +int stack[LEN_STACK] +int sp, pc, iop, top, incase, msec, npad, baud, envgeti(), btoi() +common /sgecom/ pc, sp, iop, top, incase, stack +include "stdgraph.com" +errchk envgeti + +begin + # Execute successive single character instructions until either ) or + # EOS is seen. On a good host machine this case will be compiled as + # a vectored goto with a loop overhead of only a dozen or so machine + # instructions per loop. + + for (ch=program[pc]; ch != EOS; ch=program[pc]) { + pc = pc + 1 + + switch (ch) { + case '\'': + # Escape next character (recognized everywhere). + ch = program[pc] + if (ch != EOS) { + # Push ASCII value of character. + push (ch) + pc = pc + 1 + } + + case '%': + if (program[pc] == 't') { + # Tek format again. + pc = pc + 1 + x = R1 + y = R2 + iop = iop + 4 + if (iop > top) + goto memory_overflow_ + + memory[iop-4] = g_hixy[y+1] + memory[iop-3] = g_loy[y+1] + memory[iop-2] = g_hixy[x+1] + memory[iop-1] = g_lox[x+1] + + } else { + # Formatted output. + if (program[pc] != EOS) { + pop (num) + call sge_printf (num, memory, iop, top, program, pc) + } else + output (ch) + } + + case ')': + # End interpreter mode. + return (OK) + + case '#': + # Push signed decimal integer number. + neg = NO + if (program[pc] == '-') { + neg = YES + pc = pc + 1 + } + + num = 0 + while (IS_DIGIT (program[pc])) { + num = num * 10 + TO_INTEG (program[pc]) + pc = pc + 1 + } + + if (neg == YES) + push (-num) + else + push (num) + + case '$': + # Switch case instruction. + + if (incase == NO) { + # Pop the switch off the stack. + pop (num) + + # Search for case number 'num'. + for (ch=program[pc]; ch != EOS; ch=program[pc]) { + if (ch == '$') { + # End of switch statement. + pc = pc + 1 + incase = NO + break + + } else if (program[pc+1] == '-') { + # Range of cases. + a = TO_INTEG (ch) + b = TO_INTEG (program[pc+2]) + pc = pc + 3 + if (a <= num && num <= b) { + incase = YES + break + } + } else if (ch == 'D' || TO_INTEG(ch) == num) { + # Default or requested case. + pc = pc + 1 + incase = YES + break + + } + + # Advance to the next case. Leave pc pointing to the + # N of case $N. + + if (ch != '$' && incase == NO) { + while (program[pc] != EOS && program[pc] != '$') + pc = pc + 1 + if (program[pc] == '$') + pc = pc + 1 + } + } + + } else { + # $ encountered delimiting a case. Search forward for + # $$ or EOS. + + if (program[pc] != '$') + for (ch=program[pc]; ch != EOS; ch=program[pc]) { + pc = pc + 1 + if (ch == '$' && program[pc] == '$') + break + } + + if (program[pc] == '$') + pc = pc + 1 + + incase = NO + } + + case '.': + # Pop number from stack and place in output string as a + # binary character. + pop (num) + output (num) + + case ',': + # Get next character from input string and push on stack. + input (num) + push (num) + + case '&': + # Modulus (similar to AND of low bits). + pop (b) + pop (a) + push (mod (a, b)) + + case '+': + # Add (similar to OR). + pop (b) + pop (a) + push (a + b) + + case '-': + # Subtract (similar to AND). + pop (b) + pop (a) + push (a - b) + + case '*': + # Multiply (shift left if pwr of 2). + pop (b) + pop (a) + push (a * b) + + case '/': + # Divide (shift right if pwr of 2). + pop (b) + pop (a) + push (a / b) + + case '<': + # Less than (0=false, 1=true). + pop (b) + pop (a) + push (btoi (a < b)) + + case '>': + # Greater than (0=false, 1=true). + pop (b) + pop (a) + push (btoi (a > b)) + + case '=': + # Equals (0=false, 1=true). + pop (b) + pop (a) + push (btoi (a == b)) + + case ';': + # If 2nd value on stack is true add 1st value on stack to PC. + # Example: "12<#-8;". The ; is at offset zero. + pop (a) + pop (b) + if (b != 0) + pc = pc - 1 + a + + case '0': + # Push contents of register 0 (10). + push (R0) + case '1': + # Push contents of register 1. + push (R1) + case '2': + # Push contents of register 2. + push (R2) + case '3': + # Push contents of register 3. + push (R3) + case '4': + # Push contents of register 4. + push (R4) + case '5': + # Push contents of register 5. + push (R5) + case '6': + # Push contents of register 6. + push (R6) + case '7': + # Push contents of register 7. + push (R7) + case '8': + # Push contents of register 8. + push (R8) + case '9': + # Push contents of register 9. + push (R9) + + case '!': + if (program[pc] == '!') { + # !!: Pop stack and generate delay. + pc = pc + 1 + pop (msec) + iferr (baud = envgeti ("ttybaud")) + baud = 9600 + npad = real(msec) * (real(baud) / 8. / 1000.) + while (npad > 0) { + output (PADCHAR) + npad = npad - 1 + } + } else { + # !N: Pop stack into register N. + num = TO_INTEG (program[pc]) + if (num >= 0 && num <= 9) { + if (num == 0) + num = 10 + pop (registers[num]) + pc = pc + 1 + } else + output (ch) + } + + default: + # Push ASCII value of character. + push (ch) + } + + if (sp <= 0) + return (stack_underflow_) + if (sp > LEN_STACK) + return (stack_overflow_) + } + + return (OK) + +memory_overflow_ + return (memory_overflow_) +end + + +# SGE_PRINTF -- Process a %.. format specification. The number to be encoded +# has already been popped from the stack into the first argument. The encoded +# number is returned in memory at IOP, leaving IOP positioned to the first +# char following the encoded number. The format used to encode the number is +# extracted from the program starting at PC. PC is left pointing to the first +# character following the format. + +procedure sge_printf (number, memory, iop, top, program, pc) + +int number # number to be encoded +char memory[top] # output buffer +int iop # index of first char to be written (in/out) +int top # size of output buffer +char program[ARB] # contains printf format string +int pc # index of first char of format string (in/out) + +char format[SZ_FORMAT] +char numstr[SZ_NUMSTR] +int op, ch, junk +int gstrcpy(), itoc() + +begin + # Extract format %w.dC, a string of digits, -, or ., delimited by a + # letter. The format %w.dr is followed by a single character which + # must also be included in the format string. + + format[1] = '%' + op = 2 + for (ch=program[pc]; ch != EOS; ch=program[pc]) { + pc = pc + 1 + format[op] = ch + op = op + 1 + if (IS_LOWER(ch)) { + if (ch == 'r' && program[pc] != EOS) { + # Radix digit follows %r. + format[op] = program[pc] + op = op + 1 + pc = pc + 1 + } + break + } + } + format[op] = EOS + + # Encode the number using the extracted format string. The case of + # a simple decimal encoding is optimized. + + if (format[2] == 'd') + junk = itoc (number, numstr, SZ_NUMSTR) + else { + iferr { + call sprintf (numstr, SZ_NUMSTR, format) + call pargi (number) + } then + numstr[1] = EOS + } + + # Move the encoded number to encoder memory, advancing the i/o + # pointer and taking care not to overrun memory. Leave the iop + # pointing AT, not after, the EOS output by gstrcpy. + + iop = iop + gstrcpy (numstr, memory[iop], top - iop + 1) +end diff --git a/sys/gio/stdgraph/stgescape.x b/sys/gio/stdgraph/stgescape.x new file mode 100644 index 00000000..b52ffd0c --- /dev/null +++ b/sys/gio/stdgraph/stgescape.x @@ -0,0 +1,99 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# STGESCAPE.X -- Stdgraph kernel escape handing code. This is the interface +# between the stdgraph kernel and any supported escape packages. These driver +# routines return TRUE if they recognize the escape and it is private to the +# package, FALSE if the other escape packages may also be interested in the +# routine. +# +# stg_escape standard GKI escape entry point +# +# sge_wstran transform and output escape +# sge_spoolesc process and escape into frame buffer +# +# To add support for a new package of escapes, and entry for the driver routine +# for each family of escapes must be added to each of these procedures. + + +# STG_ESCAPE -- Pass a device dependent instruction on to the kernel. +# The stdgraph kernel does not have any escape functions at present. + +procedure stg_escape (fn, instruction, nwords) + +int fn #I function code +short instruction[ARB] #I instruction data words +int nwords #I length of instruction + +bool sgm_execute() # GIM (Gterm) imaging excapes + +begin + if (sgm_execute (fn, instruction, nwords)) + return +end + + +# SGE_WSTRAN -- Stdgraph escape handling routine called by an interactive +# client (e.g the CL in cursor mode) to apply the workstation transformation +# to a escape and execute the escape. This routine is called for all +# escapes regardless of whether any transformation is necessary, leaving +# it up to the escape code to decide what to do. + +procedure sge_wstran (fn, instruction, x1,y1, x2,y2) + +int fn #I escape sequence function opcode +short instruction[ARB] #I escape instruction data +real x1, y1 #I NDC coords of display rect +real x2, y2 #I NDC coords of display rect + +bool sgm_wstran() # GIM (Gterm) imaging excapes + +begin + if (sgm_wstran (fn, instruction, x1,y1, x2,y2)) + return +end + + +# SGE_WSENABLE -- Stdgraph escape handling routine called by an +# interactive client (e.g the CL in cursor mode) to test whether cursor mode +# scaling of graphics instructions is enabled when cursor mode zoom/pan is +# done. Cursor mode scaling may be disabled if the kernel or graphics device +# does the scaling itself. + +bool procedure sge_wsenable () + +bool enable +bool sgm_wsenable() + +begin + if (sgm_wsenable (enable)) + return (enable) +end + + +# SGE_SPOOLESC -- Stdgraph escape handling routine called by an interactive +# client (e.g the CL in cursor mode) to retain, delete, or edit an escape +# instruction stored in a frame buffer. Ordinary drawing instructions are +# normally retained. If the instruction should only be executed when issued +# it should be deleted. Sometimes an instruction is edited or replaced by +# a different one to be executed the next time the buffered graphics is drawn. +# Sometimes when an instruction is seen earlier instructions must be edited +# or deleted. This routine is called for all escapes, it is up to the escape +# code to decide what to do. The delete instruction callback is called as +# delete_fcn(tr,gki) to delete the instruction pointed to by GKI. + +procedure sge_spoolesc (tr, gki, fn, instruction, bp, buftop, delete_fcn) + +pointer tr #I arg to delete_fcn +pointer gki #I pointer to escape instruction +int fn #U escape sequence function opcode +short instruction[ARB] #U escape instruction data +pointer bp #I frame buffer pointer +pointer buftop #I top+1 of buffered data +int delete_fcn #I function called to delete an instruction + +bool sgm_spoolesc() # GIM (Gterm) imaging excapes + +begin + if (sgm_spoolesc (tr, gki, fn, instruction, bp, buftop, delete_fcn)) + return +end diff --git a/sys/gio/stdgraph/stgfa.x b/sys/gio/stdgraph/stgfa.x new file mode 100644 index 00000000..10cf4d61 --- /dev/null +++ b/sys/gio/stdgraph/stgfa.x @@ -0,0 +1,115 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_FILLAREA -- Fill a closed area. The area is defined by the array of +# points P, consisting of successive (x,y) coordinate pairs outlining the +# area to be filled. + +procedure stg_fillarea (p, npts) + +short p[ARB] #I points defining area outline +int npts #I number of points, i.e., (x,y) pairs + +pointer fa +bool tek_encoding +int lowres_x, lowres_y +int ip, n, sx, sy, len_p, iop, i +int stg_encode() +include "stdgraph.com" + +begin + if (g_enable == NO) + call stg_genab() + + len_p = npts * 2 + + # Update fillarea attributes if necessary. + + fa = SG_FAAP(g_sg) + if (SG_COLOR(g_sg) != FA_COLOR(fa)) { + call stg_ctrl1 ("FC", FA_COLOR(fa)) + SG_COLOR(g_sg) = FA_COLOR(fa) + } + if (SG_FASTYLE(g_sg) != FA_STYLE(fa)) { + call stg_ctrl1 ("FT", FA_STYLE(fa)) + SG_FASTYLE(g_sg) = FA_STYLE(fa) + } + + # Tektronix encoding is treated as a special case for max efficiency. + tek_encoding = + (Memc[g_xy] == '%' && Memc[g_xy+1] == 't' && Memc[g_xy+2] == EOS) + + # Draw the fillarea. If the startfill sequence is defined we assume + # that the device can draw a multipoint fillarea. + + if (Memc[SG_STARTFILL(g_sg)] != EOS) { + for (ip=1; ip <= len_p; ip=ip+2) { + # Output start fillarea sequence. + call ttyputs (g_out, g_tty, Memc[SG_STARTFILL(g_sg)], 1) + n = len_p + + # Encode the points of the fillarea outline (or move to the + # single point to be drawn). + + g_lastx = -1 # clip unresolved points only in the interior + g_lasty = -1 # of the area being drawn. + + g_reg[E_IOP] = 1 + do i = ip, n, 2 { + sx = p[i] + sy = p[i+1] + + # Discard the point if it is not resolved. + lowres_x = sx / g_dxres + lowres_y = sy / g_dyres + if (lowres_x == g_lastx && lowres_y == g_lasty) + next + + g_lastx = lowres_x + g_lasty = lowres_y + + # Transform point into the device window. + sx = int (sx * g_dx) + g_x1 + sy = int (sy * g_dy) + g_y1 + + # Encode the point, appending encoded bytes to g_mem. + # Tek encoding is treated as a special case since it is + # so common; the encoder is used for non-Tek encodings. + + if (tek_encoding) { + iop = g_reg[E_IOP] + 4 + g_mem[iop-4] = g_hixy[sy+1] + g_mem[iop-3] = g_loy[sy+1] + g_mem[iop-2] = g_hixy[sx+1] + g_mem[iop-1] = g_lox[sx+1] + g_reg[E_IOP] = iop + } else { + g_reg[1] = sx + g_reg[2] = sy + if (stg_encode (Memc[g_xy], g_mem, g_reg) != OK) + break + } + + # Flush buffer if nearly full. + if (g_reg[E_IOP] > FLUSH_MEMORY) { + call write (g_out, g_mem, g_reg[E_IOP] - 1) + g_reg[E_IOP] = 1 + } + } + ip = n + + # Flush any output remaining in encoder memory. + if (g_reg[E_IOP] > 1) { + call write (g_out, g_mem, g_reg[E_IOP] - 1) + g_reg[E_IOP] = 1 + } + + # Output end polymarker sequence, or draw the point. + call ttyputs (g_out, g_tty, Memc[SG_ENDFILL(g_sg)], 1) + } + } else { + # If can't do a fill area, just draw the area outline. + call stg_polyline (p, npts) + } +end diff --git a/sys/gio/stdgraph/stgfaset.x b/sys/gio/stdgraph/stgfaset.x new file mode 100644 index 00000000..d5b4c4e7 --- /dev/null +++ b/sys/gio/stdgraph/stgfaset.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stdgraph.h" + +# STG_FASET -- Set the fillarea attributes. + +procedure stg_faset (gki) + +short gki[ARB] # attribute structure +pointer fa +include "stdgraph.com" + +begin + fa = SG_FAAP(g_sg) + FA_STYLE(fa) = gki[GKI_FASET_FS] + FA_COLOR(fa) = gki[GKI_FASET_CI] +end diff --git a/sys/gio/stdgraph/stgfilter.x b/sys/gio/stdgraph/stgfilter.x new file mode 100644 index 00000000..674f190f --- /dev/null +++ b/sys/gio/stdgraph/stgfilter.x @@ -0,0 +1,165 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "stdgraph.h" + +define MAXCH 16 +define RESET "reset" + + +# SGF_POST_FILTER -- Post the stdgraph tty input filter to the VOS tty driver. +# This input filter is used to intercept and process escape sequences sent by +# the terminal to the IRAF client, to notify the client of events such as a +# terminal reset. + +procedure sgf_post_filter (fd) + +int fd #I terminal file + +int locpr() +extern sgf_ttyfilter() + +begin + # Install stdgraph filter in terminal driver. + call ttseti (fd, TT_FILTER, locpr(sgf_ttyfilter)) + call ttseti (fd, TT_FILTERKEY, ESC) + + # Register escapes with terminal. + call stg_outstr ("EZ", RESET) + call stg_outstr ("ER", "R") +end + + +# SGF_TTYFILTER -- Terminal input filter. + +procedure sgf_ttyfilter (fd, buf, maxch, status) + +int fd #I input file +char buf[ARB] #U input buffer +int maxch #I max chars in buffer +int status #U number of chars in buffer + +char escape[MAXCH] +char svbuf[MAXCH+4] +int ip, op, sp, ch, iomode + +bool streq() +int sgf_getchar(), fstati() +include "stdgraph.com" +define failed_ 91 + +begin + # Disable the filter if reading from the terminal in nonblocking + # raw mode. We shouldn't receive a stdgraph escape at such a time, + # and this code isn't prepared to deal with nonblocking i/o. This + # case occurs, e.g., during a screen size query, where the terminal + # returns an escape sequence to the client (in nonblocking raw mode). + + iomode = fstati (STDIN, F_IOMODE) + if (and (iomode, IO_NDELAY) != 0) + return + + # The escape sequence is of the form "ESC P ESC \", the ANSI + # device control string (DCS). This escape sequence is recognized by + # the vt100 terminal emulator in xgterm, which will accumulate and + # ignore the sequence. This is important because when a terminal + # (xgterm) reset occurs when IRAF is not reading from the terminal in + # raw mode, the character are echoed to the terminal and would be + # printed on the screen if not recognized by the terminal as an + # escape. By using a known escape which xgterm ignores the escape is + # transmitted without being seen by (and probably confusing) the + # user. If the reset occurs while in graphics mode and a cursor read + # is in progress, the terminal will be in raw mode and the sequence + # will not be echoed, hence the problem does not occur. + + ip = 1 + sp = 1 + ch = sgf_getchar (fd, svbuf, sp, buf, ip, maxch, status) + if (ch != ESC) + goto failed_ + ch = sgf_getchar (fd, svbuf, sp, buf, ip, maxch, status) + if (ch != 'P') + goto failed_ + + # Accumulate escape data string. + op = 1 + repeat { + ch = sgf_getchar (fd, svbuf, sp, buf, ip, maxch, status) + if (ch < 0 || op > MAXCH) + goto failed_ + if (ch == ESC) { + escape[op] = EOS + ch = sgf_getchar (fd, svbuf, sp, buf, ip, maxch, status) + break + } else { + escape[op] = ch + op = op + 1 + } + } + + # Process the escape. + if (streq (escape, RESET)) { + call stg_reset() + call ttseti (fd, TT_FILTER, NULL) + if (g_sg != NULL) + SG_UIFDATE(g_sg) = 0 + } else # add additional escapes here + goto failed_ + + # Edit the input buffer to remove the escape. + op = 1 + for ( ; ip <= status && op <= maxch; ip=ip+1) { + buf[op] = buf[ip] + op = op + 1 + } + status = op - 1 + return + +failed_ + # Unrecognized escape. Append any newly read data to the input + # buffer and return all the data. + + if (sp > 1) { + call amovc (svbuf, buf[status+1], sp - 1) + status = status + sp - 1 + } +end + + +# SGF_GETCHAR -- Get a character from the input terminal. ERR or EOF is +# returned if the input is exhausted. If reading in raw mode additional +# reads will be performed as necessary. + +int procedure sgf_getchar (fd, svbuf, sp, buf, ip, maxch, nchars) + +int fd #I input file +char svbuf[ARB] #O save chars as they are read +int sp #U pointer into save buffer +char buf[ARB] #U input buffer +int ip #I input index +int maxch #I max chars in buffer +int nchars #U number of chars in buffer + +int ch +int status + +begin + if (ip > nchars) { + if (maxch == 1) { + call zgetty (fd, svbuf[sp], maxch, status) + if (status <= 0) + return (ERR) + ch = svbuf[sp] + sp = sp + 1 + return (ch) + } else + return (EOF) + } + + ch = buf[ip] + ip = ip + 1 + + return (ch) +end diff --git a/sys/gio/stdgraph/stgflush.x b/sys/gio/stdgraph/stgflush.x new file mode 100644 index 00000000..aada3927 --- /dev/null +++ b/sys/gio/stdgraph/stgflush.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_FLUSH -- Flush output. + +procedure stg_flush (dummy) + +int dummy # not used at present +include "stdgraph.com" + +begin + call flush (g_out) +end diff --git a/sys/gio/stdgraph/stggcell.x b/sys/gio/stdgraph/stggcell.x new file mode 100644 index 00000000..2a9aea8c --- /dev/null +++ b/sys/gio/stdgraph/stggcell.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# STG_GETCELLARRAY -- Input a cell array, i.e., two dimensional array of pixels +# (greylevels or colors). + +procedure stg_getcellarray (nx, ny, x1,y1, x2,y2) + +int nx, ny # number of pixels in X and Y +int x1, y1 # lower left corner of input window +int x2, y2 # lower left corner of input window + +begin + # Not implemented yet. Won't do much for a graphics terminal, + # but should be functionional. +end diff --git a/sys/gio/stdgraph/stggcur.x b/sys/gio/stdgraph/stggcur.x new file mode 100644 index 00000000..08f2b8b7 --- /dev/null +++ b/sys/gio/stdgraph/stggcur.x @@ -0,0 +1,52 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_GETCURSOR -- Get the position of a cursor. The cursor value is returned +# as a GKI structure on the graphics metacode stream. + +procedure stg_getcursor (cursor) + +int cursor #I cursor to be read or 0 + +int cur, cn +int key, sx, sy, raster, rx, ry +include "stdgraph.com" + +begin + # If cursor=0 read the last cursor referenced, e.g., in a write. + if (cursor > 0) { + SG_CURSOR(g_sg) = cursor + cur = cursor + } else + cur = max (1, SG_CURSOR(g_sg)) + + # Restore graphics mode in case the user has forgotten the \n while + # writing to the status line. + + if (g_enable == NO) + call stg_genab() + + # If the user has locked the logical cursor override runtime selection. + if (g_cursor > 0) + cur = g_cursor + + # Restore the software cursor position before reading? + if (SG_UPDCURSOR(g_sg) == YES) { + sx = SG_CURSOR_X(g_sg) + sy = SG_CURSOR_Y(g_sg) + if (sx != 0 && sy != 0) + call stg_setcursor (sx, sy, cur) + } + + # Physically read the cursor and return value to caller. + call stg_readcursor (cur, cn, key, sx, sy, raster, rx, ry) + call gki_retcursorvalue (g_stream, cn, key, sx, sy, raster, rx, ry) + call flush (g_stream) + + # Save the new position of the cursor for next time. + if (SG_UPDCURSOR(g_sg) == YES) { + SG_CURSOR_X(g_sg) = sx + SG_CURSOR_Y(g_sg) = sy + } +end diff --git a/sys/gio/stdgraph/stggdisab.x b/sys/gio/stdgraph/stggdisab.x new file mode 100644 index 00000000..42ddec62 --- /dev/null +++ b/sys/gio/stdgraph/stggdisab.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_GDISAB -- Disable graphics, i.e., issue the GD control sequence. + +procedure stg_gdisab() + +include "stdgraph.com" + +begin + if (g_active == YES && g_out > 0) { + call stgctrl ("GD") + call flush (g_out) + g_enable = NO + } +end diff --git a/sys/gio/stdgraph/stggenab.x b/sys/gio/stdgraph/stggenab.x new file mode 100644 index 00000000..5e350e33 --- /dev/null +++ b/sys/gio/stdgraph/stggenab.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_GENAB -- Enable graphics, i.e., issue the GE control sequence. + +procedure stg_genab() + +include "stdgraph.com" + +begin + if (g_active == YES && g_out > 0) { + call stgctrl ("GE") + call flush (g_out) + g_enable = YES + } +end diff --git a/sys/gio/stdgraph/stggim.x b/sys/gio/stdgraph/stggim.x new file mode 100644 index 00000000..a71cd448 --- /dev/null +++ b/sys/gio/stdgraph/stggim.x @@ -0,0 +1,919 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include +include "stdgraph.h" + +# STGGIM.X -- GIO.GIM gterm imaging escapes for the stdgraph kernel. The +# routines in this file decode GKI escape instructions and encode serial +# byte sequences which are sent to the server to execute the instruction. +# In some cases the server returns a response which is decoded here and +# encoded as a GKI return value which is returned to the client. + +define SZ_PATBUF 512 +define MAX_ARGS 32 +define TIMEOUT 10000 + + +# SGM_EXECUTE -- Test whether the given instruction is a GIM escape, and +# if so execute it. Return true if the instruction was recognized and +# executed. + +bool procedure sgm_execute (fn, gim, nwords) + +int fn #I function code +short gim[ARB] #I instruction data words +int nwords #I length of gim + +int raster +common /sgmcom/ raster + +begin + switch (fn) { + case GKI_OPENWS, GKI_CLEAR: + call sgm_output ("RI", gim, GIM_RASTERINIT_LEN) + return (false) + + case GIM_RASTERINIT: + call sgm_output ("RI", gim, GIM_RASTERINIT_LEN) + case GIM_CREATERASTER: + call sgm_output ("CR", gim, GIM_CREATERASTER_LEN) + case GIM_DESTROYRASTER: + call sgm_output ("DR", gim, GIM_DESTROYRASTER_LEN) + case GIM_QUERYRASTER: + call sgm_queryraster (gim) + case GIM_SETRASTER: + raster = gim[GIM_SETRASTER_RN] + call sgm_output ("SR", gim, GIM_SETRASTER_LEN) + case GIM_WRITEPIXELS: + call sgm_writepixels (gim) + case GIM_READPIXELS: + call sgm_readpixels (gim) + case GIM_REFRESHPIXELS: + call sgm_output ("RX", gim, GIM_REFRESHPIXELS_LEN) + case GIM_SETPIXELS: + call sgm_output ("SP", gim, GIM_SETPIXELS_LEN) + case GIM_WRITECMAP: + call sgm_writecmap (gim) + case GIM_READCMAP: + call sgm_readcmap (gim) + case GIM_LOADCMAP: + call sgm_output ("LM", gim, GIM_LOADCMAP_LEN) + case GIM_FREECMAP: + call sgm_output ("FL", gim, GIM_FREECMAP_LEN) + case GIM_WRITEIOMAP: + call sgm_iomapwrite (gim) + case GIM_READIOMAP: + call sgm_iomapread (gim) + case GIM_INITMAPPINGS: + call sgm_output ("IM", gim, GIM_INITMAPPINGS_LEN) + case GIM_FREEMAPPING: + call sgm_output ("FM", gim, GIM_FREEMAPPING_LEN) + case GIM_COPYRASTER: + call sgm_output ("CP", gim, GIM_COPYRASTER_LEN) + case GIM_SETMAPPING: + call sgm_output ("SM", gim, GIM_SETMAPPING_LEN) + case GIM_GETMAPPING: + call sgm_getmapping (gim) + case GIM_ENABLEMAPPING: + call sgm_output ("MN", gim, GIM_ENABLEMAPPING_LEN) + case GIM_DISABLEMAPPING: + call sgm_output ("MD", gim, GIM_DISABLEMAPPING_LEN) + case GIM_REFRESHMAPPING: + call sgm_output ("RF", gim, GIM_REFRESHMAPPING_LEN) + + default: + return (false) + } + + return (true) +end + + +# SGM_WSTRAN -- Transform and output a GIM escape. Ignore escapes we +# know nothing about. TRUE is returned if the escape is one which is private +# to the GIM interface. + +bool procedure sgm_wstran (fn, gim, rx1,ry1, rx2,ry2) + +int fn #I escape sequence function opcode +short gim[ARB] #I escape instruction data +real rx1,ry1 #I NDC coords of display rect +real rx2,ry2 #I NDC coords of display rect + +real scale +pointer sp, n_gim +bool status, xflip, yflip +int width, height, dst, src, dt +int wx1, wy1, wx2, wy2, p1, p2 +int sx1, sy1, sx2, sy2, snx, sny +int dx1, dy1, dx2, dy2, dnx, dny +int n_dx1, n_dy1, n_dx2, n_dy2, n_dnx, n_dny +int n_sx1, n_sy1, n_sx2, n_sy2 +int w_dx1, w_dy1, w_dx2, w_dy2 +bool sgm_execute() +define exe_ 91 + +begin + switch (fn) { + case GIM_RASTERINIT, GIM_INITMAPPINGS, + GIM_CREATERASTER, GIM_DESTROYRASTER, GIM_QUERYRASTER, + GIM_GETMAPPING, GIM_ENABLEMAPPING, GIM_DISABLEMAPPING, + GIM_REFRESHMAPPING, GIM_FREEMAPPING, + GIM_READPIXELS, GIM_WRITEPIXELS, GIM_REFRESHPIXELS, GIM_SETPIXELS, + GIM_WRITECMAP, GIM_READCMAP, GIM_LOADCMAP, GIM_FREECMAP, + GIM_WRITEIOMAP, GIM_READIOMAP, + GIM_COPYRASTER, GIM_SETRASTER: + + # These instructions do not require any transformation. + status = sgm_execute (fn, gim, 0) + + case GIM_SETMAPPING: + # Edit setmapping instructions which write to the display window. + # Raster 0 is the display window; only display window coordinates + # are affected by the workstation transformation. + + src = gim[GIM_SETMAPPING_SR] + dst = gim[GIM_SETMAPPING_DR] + dt = gim[GIM_SETMAPPING_DT] + + if (dst == 0 && src != dst) { + call smark (sp) + call salloc (n_gim, GIM_SETMAPPING_LEN, TY_SHORT) + + xflip = false + yflip = false + + # Convert the display rect NDC coordinates to window pixels + # or GKI units, depending upon which coordinate system is + # in use. Note that for NDC the Y axis is flipped relative + # to display window pixel coordinates. + + if (dt == CT_PIXEL) { + call sgm_winsize (width, height) + wx1 = rx1 * (width - 1); wy1 = (1.0 - ry2) * (height - 1) + wx2 = rx2 * (width - 1); wy2 = (1.0 - ry1) * (height - 1) + } else { + width = GKI_MAXNDC + 1; height = GKI_MAXNDC + 1 + wx1 = rx1 * (width - 1); wy1 = ry1 * (height - 1) + wx2 = rx2 * (width - 1); wy2 = ry2 * (height - 1) + } + + sx1 = gim[GIM_SETMAPPING_SX] + snx = gim[GIM_SETMAPPING_SW] + sy1 = gim[GIM_SETMAPPING_SY] + sny = gim[GIM_SETMAPPING_SH] + sx2 = sx1 + snx - 1; sy2 = sy1 + sny - 1 + + dx1 = gim[GIM_SETMAPPING_DX] + dnx = gim[GIM_SETMAPPING_DW] + if (dnx < 0) { + dnx = -dnx + xflip = !xflip + } + dy1 = gim[GIM_SETMAPPING_DY] + dny = gim[GIM_SETMAPPING_DH] + if (dny < 0) { + dny = -dny + yflip = !yflip + } + dx2 = dx1 + dnx - 1; dy2 = dy1 + dny - 1 + + # Compute the intersection of the destination (screen) rect + # of the mapping with the region of the screen WS mapped by + # the workstation transformation. + + n_dx1 = max (wx1, dx1); n_dy1 = max (wy1, dy1) + n_dx2 = min (wx2, dx2); n_dy2 = min (wy2, dy2) + + # If the rectangles do not intersect set up a null mapping + # to temporarily disable the mapping. + + n_dnx = n_dx2 - n_dx1 + 1; n_dny = n_dy2 - n_dy1 + 1 + if (n_dnx <= 0 || n_dny <= 0) { + call amovs (gim, Mems[n_gim], GIM_SETMAPPING_LEN) + Mems[n_gim+GIM_SETMAPPING_SX-1] = 0 + Mems[n_gim+GIM_SETMAPPING_SW-1] = 0 + Mems[n_gim+GIM_SETMAPPING_SY-1] = 0 + Mems[n_gim+GIM_SETMAPPING_SH-1] = 0 + Mems[n_gim+GIM_SETMAPPING_DX-1] = 0 + Mems[n_gim+GIM_SETMAPPING_DW-1] = 0 + Mems[n_gim+GIM_SETMAPPING_DY-1] = 0 + Mems[n_gim+GIM_SETMAPPING_DH-1] = 0 + goto exe_ + } + + # Compute the source rect which maps to the new (intersection) + # destination rect. + + if (snx == 1 || dnx == 1) { + n_sx1 = sx1 + n_sx2 = sx2 + } else { + scale = real(snx - 1) / real(dnx - 1) + n_sx1 = max(0, min(GKI_MAXNDC, + nint((n_dx1 - dx1) * scale + sx1))) + n_sx2 = max(0, min(GKI_MAXNDC, + nint((n_dx2 - dx2) * scale + sx2))) + if (xflip) { + p1 = sx1 + (sx2 - n_sx2) + p2 = sx2 - (n_sx1 - sx1) + n_sx1 = p1; n_sx2 = p2 + } + } + + if (sny == 1 || dny == 1) { + n_sy1 = sy1 + n_sy2 = sy2 + } else { + scale = real(sny - 1) / real(dny - 1) + n_sy1 = max(0, min(GKI_MAXNDC, + nint((n_dy1 - dy1) * scale + sy1))) + n_sy2 = max(0, min(GKI_MAXNDC, + nint((n_dy2 - dy2) * scale + sy2))) + if (yflip) { + p1 = sy1 + (sy2 - n_sy2) + p2 = sy2 - (n_sy1 - sy1) + n_sy1 = p1; n_sy2 = p2 + } + } + + # Scale the destination rect by the amount needed to make the + # WS rect fill the full display window. + + if (wx1 == wx2) { + w_dx1 = 0 + w_dx1 = width - 1 + } else { + scale = real(width - 1) / real(wx2 - wx1) + w_dx1 = max(0, min(GKI_MAXNDC, + nint((n_dx1 - wx1) * scale))) + w_dx2 = max(0, min(GKI_MAXNDC, + nint((n_dx2 - wx1) * scale))) + } + + if (wy1 == wy2) { + w_dy1 = 0 + w_dy1 = height - 1 + } else { + scale = real(height - 1) / real(wy2 - wy1) + w_dy1 = max(0, min(GKI_MAXNDC, + nint((n_dy1 - wy1) * scale))) + w_dy2 = max(0, min(GKI_MAXNDC, + nint((n_dy2 - wy1) * scale))) + } + + # Construct the edited instruction. + call amovs (gim, Mems[n_gim], GIM_SETMAPPING_LEN) + Mems[n_gim+GIM_SETMAPPING_SX-1] = n_sx1 + Mems[n_gim+GIM_SETMAPPING_SW-1] = n_sx2 - n_sx1 + 1 + Mems[n_gim+GIM_SETMAPPING_SY-1] = n_sy1 + Mems[n_gim+GIM_SETMAPPING_SH-1] = n_sy2 - n_sy1 + 1 + Mems[n_gim+GIM_SETMAPPING_DX-1] = w_dx1 + Mems[n_gim+GIM_SETMAPPING_DY-1] = w_dy1 + + n_dnx = max(0, min(GKI_MAXNDC, w_dx2 - w_dx1 + 1)) + if (gim[GIM_SETMAPPING_DW] < 0) + n_dnx = -n_dnx + Mems[n_gim+GIM_SETMAPPING_DW-1] = n_dnx + + n_dny = max(0, min(GKI_MAXNDC, w_dy2 - w_dy1 + 1)) + if (gim[GIM_SETMAPPING_DH] < 0) + n_dny = -n_dny + Mems[n_gim+GIM_SETMAPPING_DH-1] = n_dny + +exe_ + # Execute the edited instruction. + status = sgm_execute (fn, Mems[n_gim], 0) + call sfree (sp) + + } else + status = sgm_execute (fn, gim, 0) + + default: + status = false + } + + return (status) +end + + +# SGM_WSENABLE -- Test if client scaling of graphics drawing instructions is +# enabled. For the stdgraph kernel, these transformations are disabled if +# the raster is other than zero, in which case the graphics server does the +# scaling. + +bool procedure sgm_wsenable (enable) + +bool enable +int raster +common /sgmcom/ raster + +begin + enable = (raster == 0) + return (true) +end + + +# SGM_SPOOLESC -- Process a GIM escape into a frame buffer. All GIM escapes +# are executed when first issued; we just determine whether the escapes are +# preserved in the frame buffer to be executed when the frame is redrawn. +# Ignore escapes we know nothing about. TRUE is returned if the escape is +# one which is private to the GIM interface, i.e., if the escape has been +# processed fully by sgm_spoolesc. + +bool procedure sgm_spoolesc (tr, gki, fn, gim, bp, buftop, delete_fcn) + +pointer tr #I arg to delete_fcn +pointer gki #I pointer to escape instruction +int fn #U escape sequence function opcode +short gim[ARB] #U escape instruction data +pointer bp #I frame buffer pointer +pointer buftop #I top+1 of buffered data +int delete_fcn #I function called to delete an instruction + +pointer ip, itop, esc +int nleft, length, opcode, escape, mp + +begin + switch (fn) { + case GIM_RASTERINIT, GIM_INITMAPPINGS, GIM_FREEMAPPING, + GIM_CREATERASTER, GIM_DESTROYRASTER, GIM_QUERYRASTER, + GIM_GETMAPPING, GIM_ENABLEMAPPING, GIM_DISABLEMAPPING, + GIM_REFRESHMAPPING, GIM_WRITEPIXELS, GIM_READPIXELS, + GIM_REFRESHPIXELS, GIM_SETPIXELS, GIM_COPYRASTER, + GIM_WRITEIOMAP, GIM_READIOMAP, GIM_WRITECMAP, GIM_READCMAP, + GIM_LOADCMAP, GIM_FREECMAP: + + # These escapes are only executed once. + call zcall2 (delete_fcn, tr, gki) + + case GIM_SETRASTER: + ; # Preserve this instruction. + + case GIM_SETMAPPING: + # This escape is saved in the frame buffer and rexecuted when + # the frame is redrawn. This allows the server to buffer the + # image data, but still allows the graphics to be redrawn and + # possibly rescaled in cursor mode. Rexecution of copyraster + # after a screen clear will cause any rasters created and written + # to with createraster/writepixels to be redrawn on the screen. + + ip = bp + itop = gki + + while (ip < itop) { + # Search for the beginning of the next instruction. + while (Mems[ip] != BOI && ip < itop) + ip = ip + 1 + + nleft = itop - ip + if (nleft < 3) + break + else { + length = Mems[ip+GKI_HDR_LENGTH-1] + if (length > nleft) + break + + opcode = Mems[ip+GKI_HDR_OPCODE-1] + escape = Mems[ip+GKI_ESCAPE_FN-1] + + # Disable instruction if same mapping number. + if (opcode == GKI_ESCAPE && escape == GIM_SETMAPPING) { + esc = ip + GKI_ESCAPE_DC - 1 + mp = Mems[esc+GIM_SETMAPPING_MP-1] + if (mp == gim[GIM_SETMAPPING_MP]) + Mems[ip+GKI_HDR_OPCODE-1] = GKI_UNKNOWN + } + + ip = ip + length + } + } + + default: + return (false) + } + + return (true) +end + + +# SGM_WINSIZE -- Get the graphics window size in display pixels. + +procedure sgm_winsize (width, height) + +int width, height #O window size + +short gim_query[GIM_QUERYRASTER_LEN] +short retval[GIM_RET_QRAS_LEN] + +begin + gim_query[GIM_QUERYRASTER_RN] = 0 + call sgm_query ("QR", gim_query, GIM_QUERYRASTER_LEN, + "Qr", retval, GIM_RET_QRAS_LEN) + width = retval[GIM_RET_QRAS_NX] + height = retval[GIM_RET_QRAS_NY] +end + + +# SGM Private Functions. +# --------------------------- + +# SGM_QUERYRASTER -- Return the attributes of a raster. + +procedure sgm_queryraster (gim) + +short gim[ARB] #I encoded instruction +short retval[GIM_RET_QRAS_LEN] +include "stdgraph.com" + +begin + call sgm_query ("QR", gim, GIM_QUERYRASTER_LEN, + "Qr", retval, GIM_RET_QRAS_LEN) + call write (g_stream, retval, GIM_RET_QRAS_LEN * SZ_SHORT) + call flush (g_stream) +end + + +# SGM_WRITEPIXELS -- Write a block of pixels to a raster. + +procedure sgm_writepixels (gim) + +short gim[ARB] #I encoded instruction + +char bias +pointer sp, bp +int nx, ny, npix, i +include "stdgraph.com" + +begin + # Send the write-pixels escape sequence. + call sgm_output ("WP", gim, GIM_WRITEPIXELS_LEN) + + # For the moment this code assumes 8 bit pixels. + nx = gim[GIM_WRITEPIXELS_NX] + ny = gim[GIM_WRITEPIXELS_NY] + npix = nx * ny + + call smark (sp) + call salloc (bp, npix, TY_CHAR) + bias = 040B + + # Send the pixel data encoded in printable ASCII. + call achtbc (gim[GIM_WRITEPIXELS_DATA], Memc[bp], npix) + do i = 1, npix + Memc[bp+i-1] = Memc[bp+i-1] + bias + call write (g_out, Memc[bp], npix) + call putci (g_out, GS) + + call sfree (sp) +end + + +# SGM_READPIXELS -- Read a block of pixels from a raster and return it +# to the client. + +procedure sgm_readpixels (gim) + +short gim[ARB] #I encoded instruction + +pointer sp, bp +int sv_iomode, ch +int npix, nx, ny, i +short retval[GIM_RET_RPIX_LEN] +int fstati(), getci() +include "stdgraph.com" + +begin + sv_iomode = fstati (g_in, F_IOMODE) + if (sv_iomode != IO_RAW) + call fseti (g_in, F_IOMODE, IO_RAW) + + # Send the read-pixels escape sequence. + call sgm_output ("RP", gim, GIM_READPIXELS_LEN) + call flush (g_out) + + # For the moment this code assumes 8 bit pixels. + nx = gim[GIM_READPIXELS_NX] + ny = gim[GIM_READPIXELS_NY] + npix = nx * ny + + call smark (sp) + call salloc (bp, npix, TY_CHAR) + + # Get the pixel data. This is a block of pixel data encoded as for + # writepixels (040 bias), bracked by ESC at the front and a single + # control character such as \r or \n at the end. + + while (getci (g_in, ch) != EOF) + if (ch == ESC) + break + for (i=0; getci (g_in, ch) >= 040B; ) + if (i < npix) { + Memc[bp+i] = ch - 040B + i = i + 1 + } + npix = i + + # Send the RPIX header to the client. + retval[GIM_RET_RPIX_NP] = npix + call write (g_stream, retval, GIM_RET_RPIX_LEN * SZ_SHORT) + + # Return the data to the client. + call achtcb (Memc[bp], Memc[bp], npix) + call write (g_stream, Memc[bp], (npix + SZB_CHAR-1) / SZB_CHAR) + call flush (g_stream) + + if (sv_iomode != IO_RAW) + call fseti (g_in, F_IOMODE, sv_iomode) + call sfree (sp) +end + + +# SGM_WRITECMAP -- Write to a segment of the colormap. + +procedure sgm_writecmap (gim) + +short gim[ARB] #I encoded instruction + +short mask +pointer sp, bp, op +int ncells, nchars, ip, i +include "stdgraph.com" + +begin + call smark (sp) + + # Send the write-colormap escape sequence. + call sgm_output ("WM", gim, GIM_WRITECMAP_LEN) + + # Each cell consists of a RGB triplet encoded 2 chars per color. + ncells = gim[GIM_WRITECMAP_NC] + nchars = ncells * 3 * 2 + + call salloc (bp, nchars, TY_CHAR) + ip = GIM_WRITECMAP_DATA + op = bp + + mask = 017B + do i = 1, ncells*3 { + Memc[op] = gim[ip] / 16 + 040B; op = op + 1 + Memc[op] = and (gim[ip], mask) + 040B; op = op + 1 + ip = ip + 1 + } + + call write (g_out, Memc[bp], nchars) + call putci (g_out, GS) + + call sfree (sp) +end + + +# SGM_READCMAP -- Read a segment of the colormap. + +procedure sgm_readcmap (gim) + +short gim[ARB] #I encoded instruction + +pointer sp, bp, cm, ip +int sv_iomode, ncells, nchars, ch, i +short retval[GIM_RET_RCMAP_LEN] +int fstati(), getci() +include "stdgraph.com" + +begin + sv_iomode = fstati (g_in, F_IOMODE) + if (sv_iomode != IO_RAW) + call fseti (g_in, F_IOMODE, IO_RAW) + + # Send the read-cmap escape sequence. + call sgm_output ("RM", gim, GIM_READCMAP_LEN) + call flush (g_out) + + # Each cell consists of a RGB triplet encoded 2 chars per color. + ncells = gim[GIM_READCMAP_NC] + nchars = ncells * 3 * 2 + + call smark (sp) + call salloc (bp, nchars, TY_CHAR) + call salloc (cm, ncells * 3, TY_SHORT) + + # Get the colormap data. This is a block of RGB colormap triplets + # encoded 2 bytes per color, bracked by a ESC at the front and a + # single control character such as \r or \n at the end. + + while (getci (g_in, ch) != EOF) + if (ch == ESC) + break + for (i=0; getci (g_in, ch) >= 040B; ) + if (i < nchars) { + Memc[bp+i] = ch - 040B + i = i + 1 + } + ncells = i / (3 * 2) + + # Decode the packed colormap data. + ip = bp + do i = 1, ncells * 3 { + Mems[cm+i-1] = (Memc[ip] - 040B) * 16 + (Memc[ip+1] - 040B) + ip = ip + 2 + } + + # Send the read-cmap header to the client. + retval[GIM_RET_RCMAP_NC] = ncells + call write (g_stream, retval, GIM_RET_RCMAP_LEN * SZ_SHORT) + + # Return the colormap data to the client. + call write (g_stream, Mems[cm], (ncells * 3) * SZ_SHORT) + call flush (g_stream) + + if (sv_iomode != IO_RAW) + call fseti (g_in, F_IOMODE, sv_iomode) + call sfree (sp) +end + + +# SGM_IOMAPWRITE -- Write to the iomap. + +procedure sgm_iomapwrite (gim) + +short gim[ARB] #I encoded instruction + +short mask +pointer sp, bp, op +int ncells, nchars, ip, i +include "stdgraph.com" + +begin + call smark (sp) + + # Send the write-iomap escape sequence. + call sgm_output ("WO", gim, GIM_WRITEIOMAP_LEN) + + # Each cell consists of a single short integer colormap index + # encoded 2 chars per cell. + + ncells = gim[GIM_WRITEIOMAP_NC] + nchars = ncells * 2 + + call salloc (bp, nchars, TY_CHAR) + ip = GIM_WRITEIOMAP_DATA + op = bp + + mask = 017B + do i = 1, ncells { + Memc[op] = gim[ip] / 16 + 040B; op = op + 1 + Memc[op] = and (gim[ip], mask) + 040B; op = op + 1 + ip = ip + 1 + } + + call write (g_out, Memc[bp], nchars) + call putci (g_out, GS) + + call sfree (sp) +end + + +# SGM_IOMAPREAD -- Read a segment of the iomap. + +procedure sgm_iomapread (gim) + +short gim[ARB] #I encoded instruction + +pointer sp, bp, data, ip +int sv_iomode, ncells, nchars, ch, i +short retval[GIM_RET_RIOMAP_LEN] +int fstati(), getci() +include "stdgraph.com" + +begin + sv_iomode = fstati (g_in, F_IOMODE) + if (sv_iomode != IO_RAW) + call fseti (g_in, F_IOMODE, IO_RAW) + + # Send the read-iomap escape sequence. + call sgm_output ("RO", gim, GIM_READIOMAP_LEN) + call flush (g_out) + + # The data is encoded two bytes per short integer value. + ncells = gim[GIM_READIOMAP_NC] + nchars = ncells * 2 + + call smark (sp) + call salloc (bp, nchars, TY_CHAR) + call salloc (data, ncells, TY_SHORT) + + # Get the iomap data. This is a block of iomap values encoded + # 2 bytes per value, bracked by a ESC at the front and a single + # control character such as \r or \n at the end. + + while (getci (g_in, ch) != EOF) + if (ch == ESC) + break + for (i=0; getci (g_in, ch) >= 040B; ) + if (i < nchars) { + Memc[bp+i] = ch - 040B + i = i + 1 + } + ncells = i / 2 + + # Decode the packed iomap data. + ip = bp + do i = 1, ncells { + Mems[data+i-1] = (Memc[ip] - 040B) * 16 + (Memc[ip+1] - 040B) + ip = ip + 2 + } + + # Send the read-iomap header to the client. + retval[GIM_RET_RIOMAP_NC] = ncells + call write (g_stream, retval, GIM_RET_RIOMAP_LEN * SZ_SHORT) + + # Return the iomap data to the client. + call write (g_stream, Mems[data], ncells * SZ_SHORT) + call flush (g_stream) + + if (sv_iomode != IO_RAW) + call fseti (g_in, F_IOMODE, sv_iomode) + call sfree (sp) +end + + +# SGM_GETMAPPING -- Return the attributes of a mapping. + +procedure sgm_getmapping (gim) + +short gim[ARB] #I encoded instruction +short retval[GIM_RET_GMAP_LEN] +include "stdgraph.com" + +begin + call sgm_query ("GM", gim, GIM_GETMAPPING_LEN, + "Gm", retval, GIM_RET_GMAP_LEN) + call write (g_stream, retval, GIM_RET_GMAP_LEN * SZ_SHORT) + call flush (g_stream) +end + + +# SGM_OUTPUT -- Format and output a control sequence to the graphics server +# device. + +procedure sgm_output (cap, gim, nargs) + +char cap[ARB] #I graphcap capability name +short gim[ARB] #I instruction (array of int args) +int nargs #I number of arguments + +int ival, i +pointer sp, fmt, ctrl +include "stdgraph.com" +int ttygets() +errchk ttygets + +begin + call smark (sp) + call salloc (fmt, SZ_LINE, TY_CHAR) + call salloc (ctrl, SZ_LINE, TY_CHAR) + + if (ttygets (g_tty, cap, Memc[fmt], SZ_LINE) > 0) { + call sprintf (Memc[ctrl], SZ_LINE, Memc[fmt]) + do i = 1, nargs { + # Pass the argument as an integer to avoid INDEF + # processing of -32767, a valid GKI value. + ival = gim[i] + iferr (call pargi (ival)) + ; + } + call ttyputs (g_out, g_tty, Memc[ctrl], 1) + } + + call sfree (sp) +end + + +# SGM_QUERY -- Output an inquiry control sequence to the server and read and +# decode the server's response. + +procedure sgm_query (query_cap, gim, nargs, retval_cap, retval, nout) + +char query_cap[ARB] #I server query cap name +short gim[ARB] #I query instruction (args) +int nargs #I number of args for server query +char retval_cap[ARB] #I cap name for return value format +short retval[ARB] #O decoded output arguments +int nout #I number of output arguments + +int index[MAX_ARGS] +pointer sp, ctrl, patbuf, pat, buf, ip, op +int sv_iomode, arg, ch, nchars, start, value, ival, i +int patmake(), patindex(), ttyread(), ctoi() +int ttygets(), fstati(), gstrcpy() +include "stdgraph.com" +define done_ 91 +errchk ttygets + +begin + call smark (sp) + call salloc (ctrl, SZ_LINE, TY_CHAR) + call salloc (buf, SZ_LINE, TY_CHAR) + call salloc (pat, SZ_LINE, TY_CHAR) + call salloc (patbuf, SZ_PATBUF, TY_CHAR) + + call aclrs (retval, nout) + + # Set raw mode i/o. + sv_iomode = fstati (g_in, F_IOMODE) + if (sv_iomode != IO_RAW) + call fseti (g_in, F_IOMODE, IO_RAW) + + # Pass the query on to the server. + if (ttygets (g_tty, query_cap, Memc[pat], SZ_LINE) > 0) { + call sprintf (Memc[ctrl], SZ_LINE, Memc[pat]) + do i = 1, nargs { + # Pass the argument as an integer to avoid INDEF + # processing of -32767, a valid GKI value. + ival = gim[i] + iferr (call pargi (ival)) + ; + } + call ttyputs (g_out, g_tty, Memc[ctrl], 1) + call flush (g_out) + + } else + goto done_ + + # Encode a pattern to match the server's response as given by the + # pattern in retval_cap. + + if (ttygets (g_tty, retval_cap, Memc[pat], SZ_LINE) <= 0) + goto done_ + + # Process the retval_cap string, used to specify the format of the + # string returned by the server, to map the %N fields therein into + # the pattern strings "%[0-9]*", noting the index positions of the + # pattern substrings for later decoding. + + call aclri (index, MAX_ARGS) + arg = 0 + + op = buf + for (ip=pat; Memc[ip] != EOS; ip=ip+1) { + if (Memc[ip] == '%') { + if (Memc[ip+1] == '%') { + Memc[op] = Memc[ip] + op = op + 1 + ip = ip + 1 + } else { + op = op + gstrcpy ("%[0-9]*", Memc[op], ARB) + ip = ip + 1 + + # Arguments are %1 ... %9, %a, %b, etc. + ch = Memc[ip] + if (IS_DIGIT(ch)) + i = TO_INTEG(ch) + else if (IS_UPPER(ch)) + i = ch - 'A' + 10 + else + i = ch - 'a' + 10 + + arg = arg + 1 + i = min(MAX_ARGS, max(1, i)) + index[i] = arg + } + } else if (Memc[ip] == '[') { + Memc[op] = '\\'; op = op + 1 + Memc[op] = '[' ; op = op + 1 + } else { + Memc[op] = Memc[ip] + op = op + 1 + } + } + + Memc[op] = EOS + if (patmake (Memc[buf], Memc[patbuf], SZ_PATBUF) >= SZ_PATBUF) + goto done_ + + # Scan the input stream from the server until data matching the + # response pattern is received, or a timeout occurs. + + nchars = ttyread (g_in, g_tty,Memc[buf],SZ_LINE,Memc[patbuf], TIMEOUT) + if (nchars > 0) { + do i = 1, nout { + value = 0 + if (index[i] > 0) { + start = patindex (Memc[patbuf], index[i]) + if (ctoi (Memc[buf], start, value) <= 0) + value = 0 + } + retval[i] = value + } + } +done_ + if (sv_iomode != IO_RAW) + call fseti (g_in, F_IOMODE, sv_iomode) + call sfree (sp) +end diff --git a/sys/gio/stdgraph/stggrstr.x b/sys/gio/stdgraph/stggrstr.x new file mode 100644 index 00000000..946b52d9 --- /dev/null +++ b/sys/gio/stdgraph/stggrstr.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_GRSTREAM -- Set the FD of the graphics stream, from which we shall read +# metacode instructions and to which we shall return cell arrays and cursor +# values. + +procedure stg_grstream (stream) + +int stream # FD of the new graphics stream +include "stdgraph.com" + +begin + g_stream = stream +end diff --git a/sys/gio/stdgraph/stginit.x b/sys/gio/stdgraph/stginit.x new file mode 100644 index 00000000..3e393be4 --- /dev/null +++ b/sys/gio/stdgraph/stginit.x @@ -0,0 +1,193 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "stdgraph.h" + +# STG_INIT -- Initialize the stdgraph data structures from the graphcap entry +# for the device. Called once, at OPENWS time, with the TTY pointer already +# set in the common. The companion routine STG_RESET initializes the attribute +# packets when the screen is cleared. + +procedure stg_init (tty, devname) + +pointer tty # graphcap descriptor +char devname[ARB] # device name + +pointer nextch +bool first_time +int maxch, i, junk +real char_height, char_width, char_size + +bool ttygetb() +real ttygetr() +pointer stg_gstring() +int ttygets(), ttygeti(), btoi(), stg_encode(), gstrcpy() +include "stdgraph.com" +data first_time /true/ + +begin + # One time initialization. + if (first_time) { + # Initialize the Tek 4012 coordinate encoding lookup tables. + do i = 1, TEK_XRES { + g_hixy[i] = (i-1) / 40B + 40B + g_lox[i] = mod ((i-1), 40B) + 100B + } + do i = 1, TEK_YRES + g_loy[i] = mod ((i-1), 40B) + 140B + + first_time = false + } + + # Allocate the stdgraph descriptor and the string buffer. + call calloc (g_sg, LEN_SG, TY_STRUCT) + call malloc (SG_SBUF(g_sg), SZ_SBUF, TY_CHAR) + + # Init string buffer parameters. The first char of the string buffer + # is reserved as a null string, used for graphcap control strings + # omitted from the graphcap entry for the device. + + SG_SZSBUF(g_sg) = SZ_SBUF + SG_NEXTCH(g_sg) = SG_SBUF(g_sg) + 1 + Memc[SG_SBUF(g_sg)] = EOS + + # Set the software device resolution and the coordinate transformations + # to the resolution space and from GKI to device coords. The values + # g_[xy]res were initialized when the kernel was opened by the main + # program. + + call stg_resolution (g_xres, g_yres) + + # Initialize the encoder. The graphcap parameter LR contains encoder + # instructions to perform any device dependent initialization required. + + call aclri (g_reg, NREGISTERS) + nextch = SG_NEXTCH(g_sg) + + g_reg[E_IOP] = 1 + g_reg[E_TOP] = SZ_MEMORY + if (ttygets (tty, "LR", Memc[nextch], SZ_SBUF-1) > 0) + junk = stg_encode (Memc[nextch], g_mem, g_reg) + + # If the device does not support hardware character generation, set + # txquality to high to get software character generation. + + if (!ttygetb (tty, "tx")) + g_hardchar = GT_HIGH + + # Initialize the character scaling parameters, required for text + # generation. The heights are given in NDC units in the graphcap + # file, which we convert to GKI units. Estimated values are + # supplied if the parameters are missing in the graphcap entry. + + char_height = ttygetr (tty, "ch") + if (char_height < EPSILON) + char_height = 1.0 / 35.0 + char_height = char_height * GKI_MAXNDC + + char_width = ttygetr (tty, "cw") + if (char_width < EPSILON) + char_width = 1.0 / 80.0 + char_width = char_width * GKI_MAXNDC + + # If the device has a set of discrete character sizes, get the + # size of each by fetching the parameter "tN", where the N is + # a digit specifying the text size index. Compute the height and + # width of each size character from the "ch" and "cw" parameters + # and the relative scale of character size I. + + SG_NCHARSIZES(g_sg) = min (MAX_CHARSIZES, ttygeti (tty, "th")) + nextch = SG_NEXTCH(g_sg) + + if (SG_NCHARSIZES(g_sg) <= 0) { + SG_NCHARSIZES(g_sg) = 1 + SG_CHARSIZE(g_sg,1) = 1.0 + } else { + Memc[nextch+2] = EOS + for (i=1; i <= SG_NCHARSIZES(g_sg); i=i+1) { + Memc[nextch] = 't' + Memc[nextch+1] = TO_DIGIT(i) + char_size = ttygetr (tty, Memc[nextch]) + SG_CHARSIZE(g_sg,i) = char_size + SG_CHARHEIGHT(g_sg,i) = char_height * char_size + SG_CHARWIDTH(g_sg,i) = char_width * char_size + } + } + + # Initialize the output parameters. All boolean parameters are stored + # as integer flags. All string valued parameters are stored in the + # string buffer, saving a pointer to the string in the stdgraph + # descriptor. If the capability does not exist the pointer is set to + # point to the null string at the beginning of the string buffer. + + SG_POLYLINE(g_sg) = btoi (ttygetb (tty, "PL")) + SG_POLYMARKER(g_sg) = btoi (ttygetb (tty, "pm")) + SG_FILLAREA(g_sg) = btoi (ttygetb (tty, "fa")) + + SG_ENCODEXY(g_sg) = stg_gstring ("XY") + g_xy = SG_ENCODEXY(g_sg) + + SG_STARTDRAW(g_sg) = stg_gstring ("DS") + SG_ENDDRAW(g_sg) = stg_gstring ("DE") + SG_STARTMOVE(g_sg) = stg_gstring ("VS") + SG_ENDMOVE(g_sg) = stg_gstring ("VE") + SG_STARTMARK(g_sg) = stg_gstring ("MS") + SG_ENDMARK(g_sg) = stg_gstring ("ME") + SG_STARTFILL(g_sg) = stg_gstring ("FS") + SG_ENDFILL(g_sg) = stg_gstring ("FE") + SG_STARTTEXT(g_sg) = stg_gstring ("TS") + SG_ENDTEXT(g_sg) = stg_gstring ("TE") + + # Initialize the input parameters. + SG_CURSOR(g_sg) = 0 + SG_UPDCURSOR(g_sg) = btoi (ttygetb (tty, "UC")) + SG_CURSOR_X(g_sg) = 0 + SG_CURSOR_Y(g_sg) = 0 + + # Save the device string in the descriptor. + nextch = SG_NEXTCH(g_sg) + SG_DEVNAME(g_sg) = nextch + maxch = SG_SBUF(g_sg) + SZ_SBUF - nextch + 1 + nextch = nextch + gstrcpy (devname, Memc[nextch], maxch) + 1 + + # Initialize the UIFNAME field. + SG_UIFNAME(g_sg) = nextch + Memc[nextch] = EOS + nextch = nextch + SZ_UIFNAME + 1 + SG_NEXTCH(g_sg) = nextch +end + + +# STG_GSTRING -- Get a string value parameter from the graphcap table, +# placing the string at the end of the string buffer. If the device does +# not have the named capability return a pointer to the null string, +# otherwise return a pointer to the string. Since pointers are used, +# rather than indices, the string buffer is fixed in size. The additional +# degree of indirection required with an index was not considered worthwhile +# in this application since the graphcap entries are never very large. + +pointer procedure stg_gstring (cap) + +char cap[ARB] # device capability to be fetched +pointer strp, nextch +int maxch, nchars +int ttygets() +include "stdgraph.com" + +begin + nextch = SG_NEXTCH(g_sg) + maxch = SG_SBUF(g_sg) + SZ_SBUF - nextch + 1 + + nchars = ttygets (g_tty, cap, Memc[nextch], maxch) + if (nchars > 0) { + strp = nextch + nextch = nextch + nchars + 1 + } else + strp = SG_SBUF(g_sg) + + SG_NEXTCH(g_sg) = nextch + return (strp) +end diff --git a/sys/gio/stdgraph/stglkcur.x b/sys/gio/stdgraph/stglkcur.x new file mode 100644 index 00000000..6152534b --- /dev/null +++ b/sys/gio/stdgraph/stglkcur.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stdgraph.h" + +# STG_LOCKCURSOR -- Lock the logical cursor number. Called interactively by +# cursor mode in response to a ":.cursor N" command by the user. When the +# cursor is not locked the logical cursor may be selected under program +# control. + +procedure stg_lockcursor (new_cursor) + +int new_cursor # desired new logical cursor +include "stdgraph.com" + +begin + g_cursor = new_cursor +end diff --git a/sys/gio/stdgraph/stgmove.x b/sys/gio/stdgraph/stgmove.x new file mode 100644 index 00000000..5f7396a3 --- /dev/null +++ b/sys/gio/stdgraph/stgmove.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_MOVE -- Output a device move instruction to move to the position (x,y) +# in GKI coordinates. + +procedure stg_move (x, y) + +int x, y # destination +int stg_encode() +include "stdgraph.com" + +begin + # Transform the first point from GKI coords to device coords and + # move to the transformed point. + + call ttyputs (g_out, g_tty, Memc[SG_STARTMOVE(g_sg)], 1) + + g_reg[1] = x * g_dx + g_x1 + g_reg[2] = y * g_dy + g_y1 + g_reg[E_IOP] = 1 + if (stg_encode (Memc[g_xy], g_mem, g_reg) == OK) + call write (g_out, g_mem, g_reg[E_IOP] - 1) + + call ttyputs (g_out, g_tty, Memc[SG_ENDMOVE(g_sg)], 1) +end diff --git a/sys/gio/stdgraph/stgonerr.x b/sys/gio/stdgraph/stgonerr.x new file mode 100644 index 00000000..047c6152 --- /dev/null +++ b/sys/gio/stdgraph/stgonerr.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_ONERROR -- Called when error recovery takes place to deactivate the +# stdgraph workstation, i.e., take the terminal out of graphics mode. If +# this is not done error messages will be written as vectors. + +procedure stg_onerror (errcode) + +int errcode +include "stdgraph.com" + +begin + if (g_active == YES) + call stg_deactivatews (0) +end diff --git a/sys/gio/stdgraph/stgonint.x b/sys/gio/stdgraph/stgonint.x new file mode 100644 index 00000000..2aed03ee --- /dev/null +++ b/sys/gio/stdgraph/stgonint.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "stdgraph.h" + +# STG_ONINT -- Interrupt handler for the stdgraph kernel. If an interrupt +# occurs while we are posted to an exception, branch to the last ZSVJMP. +# (This library procedure is not currently used by the kernel). + +procedure stg_onint (vex, next_handler) + +int vex # virtual exception +int next_handler # next exception handler in chain +int jmpbuf[LEN_JUMPBUF] +common /stgxin/ jmpbuf + +begin + call xer_reset() + call zdojmp (jmpbuf, vex) +end diff --git a/sys/gio/stdgraph/stgopen.x b/sys/gio/stdgraph/stgopen.x new file mode 100644 index 00000000..47fb2b61 --- /dev/null +++ b/sys/gio/stdgraph/stgopen.x @@ -0,0 +1,103 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "stdgraph.h" + +# STG_OPEN -- Install the STDGRAPH kernel as a graphics kernel device driver. +# The device table DD consists of an array of the entry point addresses for +# the driver procedures. If a driver does not implement a particular +# instruction the table entry for that procedure may be set to zero, causing +# the interpreter to ignore the instruction. + +procedure stg_open (devname, dd, in, out, xres, yres, hardchar) + +char devname[ARB] # if nonnull, force output to device +int dd[ARB] # device table to be initialized +int in # input file +int out # output file +int xres # number of resolved pixels in X +int yres # number of resolved pixels in Y +int hardchar # use hardware character generator + +bool first_time +pointer sp, devns +int len_devname +int locpr(), strlen() + +extern stg_openws(), stg_closews(), stg_clear(), stg_cancel() +extern stg_flush(), stg_polyline(), stg_polymarker(), stg_text() +extern stg_fillarea(), stg_putcellarray(), stg_setcursor(), stg_plset() +extern stg_pmset(), stg_txset(), stg_faset(), stg_getcursor() +extern stg_getcellarray(), stg_escape() +extern stg_reactivatews(), stg_deactivatews() +include "stdgraph.com" +data first_time /true/ + +begin + call smark (sp) + call salloc (devns, SZ_FNAME, TY_SHORT) + + if (first_time) { + g_nopen = 0 + g_sg = NULL + g_tty = NULL + g_term = NULL + g_pbtty = NULL + g_cursor = 0 + first_time = false + } + + g_in = in + g_out = out + g_xres = xres + g_yres = yres + g_nopen = g_nopen + 1 + g_stream = STDGRAPH + g_hardchar = hardchar + g_active = NO + g_enable = NO + g_message = NO + g_msgbuf = NULL + g_msgbuflen = 0 + g_msglen = 0 + call strcpy (devname, g_device, SZ_GDEVICE) + + # Install the device driver. + dd[GKI_OPENWS] = locpr (stg_openws) + dd[GKI_CLOSEWS] = locpr (stg_closews) + dd[GKI_REACTIVATEWS] = locpr (stg_reactivatews) + dd[GKI_DEACTIVATEWS] = locpr (stg_deactivatews) + dd[GKI_MFTITLE] = 0 + dd[GKI_CLEAR] = locpr (stg_clear) + dd[GKI_CANCEL] = locpr (stg_cancel) + dd[GKI_FLUSH] = locpr (stg_flush) + dd[GKI_POLYLINE] = locpr (stg_polyline) + dd[GKI_POLYMARKER] = locpr (stg_polymarker) + dd[GKI_TEXT] = locpr (stg_text) + dd[GKI_FILLAREA] = locpr (stg_fillarea) + dd[GKI_PUTCELLARRAY] = locpr (stg_putcellarray) + dd[GKI_SETCURSOR] = locpr (stg_setcursor) + dd[GKI_PLSET] = locpr (stg_plset) + dd[GKI_PMSET] = locpr (stg_pmset) + dd[GKI_TXSET] = locpr (stg_txset) + dd[GKI_FASET] = locpr (stg_faset) + dd[GKI_GETCURSOR] = locpr (stg_getcursor) + dd[GKI_GETCELLARRAY] = locpr (stg_getcellarray) + dd[GKI_ESCAPE] = locpr (stg_escape) + dd[GKI_SETWCS] = 0 + dd[GKI_GETWCS] = 0 + dd[GKI_UNKNOWN] = 0 + + # If a device was named open the workstation as well. This is + # necessary to permit processing of metacode files which do not + # contain the open workstation instruction. + + len_devname = strlen (devname) + if (len_devname > 0) { + call achtcs (devname, Mems[devns], len_devname) + call stg_openws (Mems[devns], len_devname, NEW_FILE) + } + + call sfree (sp) +end diff --git a/sys/gio/stdgraph/stgopenws.x b/sys/gio/stdgraph/stgopenws.x new file mode 100644 index 00000000..a70a51f7 --- /dev/null +++ b/sys/gio/stdgraph/stgopenws.x @@ -0,0 +1,220 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include "stdgraph.h" + +# STG_OPENWS -- Open the named workstation. Once a workstation has been +# opened we leave it open until some other workstation is opened or the +# kernel is closed. Opening a workstation involves initialization of the +# kernel data structures, followed by initialization of the device itself. + +procedure stg_openws (devname, n, mode) + +short devname[ARB] #I device name (actually device[,uifname]) +int n #I length of device name +int mode #I access mode + +bool reinit +long fi[LEN_FINFO] +int dummy, init_file +pointer sp, ip, op, buf, device, uifname, fname + +pointer ttygdes(), ttyodes() +bool ttygetb(), strne(), streq() +int ttygets(), open(), ttstati(), finfo(), gstrcpy() +int nowhite(), envfind(), strlen(), fnroot(), access() +extern stg_onerror() +include "stdgraph.com" +define ow_ 91 + +begin + call smark (sp) + call salloc (buf, max (SZ_PATHNAME, n), TY_CHAR) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + # Open a termcap descriptor for the terminal too, in case we need + # to talk to the terminal as a terminal. + + if (g_term == NULL) + iferr (g_term = ttyodes ("terminal")) + g_term = NULL + + # If we are appending merely reactivate the device without performing + # any initialization. + + if (g_sg != NULL && mode == APPEND) { + if (g_active == NO) { + g_ucaseout = ttstati (g_out, TT_UCASEOUT) + if (g_ucaseout == YES) + call ttseti (g_out, TT_UCASEOUT, NO) + + g_active = YES + g_enable = YES + } + goto ow_ + } + + # If a device was named when the kernel was opened then output will + # always go to that device (g_device) regardless of the device named + # in the OPENWS instruction. If no device was named (null string) + # then unpack the device name, passed as a short integer array. + + if (g_device[1] == EOS) { + call achtsc (devname, Memc[buf], n) + Memc[buf+n] = EOS + } else + call strcpy (g_device, Memc[buf], SZ_FNAME) + + # Parse the "device,uifname" specification into the two fields. + device = buf + uifname = NULL + for (ip=buf; Memc[ip] != EOS; ip=ip+1) + if (Memc[ip] == ',') { + Memc[ip] = EOS + if (Memc[ip+1] != EOS) + uifname = ip + 1 + if (nowhite (Memc[uifname], Memc[uifname], ARB) == 0) + uifname = NULL + break + } + + # If the kernel is already open for this device skip most of the + # initialization. If already open for a different device free + # storage before reinitialization. + + reinit = true + if (g_sg != NULL) + if (strne (Memc[device], Memc[SG_DEVNAME(g_sg)])) { + call mfree (SG_SBUF(g_sg), TY_CHAR) + call mfree (g_sg, TY_STRUCT) + reinit = true + } else + reinit = false + + # Reinitialize the kernel datastructures. Open graphcap descriptor + # for the named device, allocate and initialize descriptor and common. + + if (reinit) { + if (g_tty != NULL) { + call ttycdes (g_tty) + g_tty = NULL + } + + iferr (g_tty = ttygdes (Memc[device])) { + g_tty = ttygdes ("4012") + call erract (EA_WARN) + } + + # Initialize data structures. + call stg_init (g_tty, Memc[device]) + } + + call stg_reset() + + if (g_active == NO) { + # Must disable stty ucaseout mode when in graphics mode, else + # plotting commands may be modified by the terminal driver. + + g_ucaseout = ttstati (g_out, TT_UCASEOUT) + if (g_ucaseout == YES) + call ttseti (g_out, TT_UCASEOUT, NO) + + # Post ONERROR cleanup routine. + call onerror (stg_onerror) + g_active = YES + g_enable = YES + } + + # If no UI file was specified but the device has the EM capability, + # use the default UI if any specified in the graphcap entry. If the + # EM capability is missing, ignore any uifname specified when the + # device was opened. + + if (ttygetb (g_tty, "EM")) { + if (uifname == NULL) { + uifname = buf + strlen(Memc[device]) + 1 + if (ttygets (g_tty, "ED", Memc[uifname], ARB) <= 0) + uifname = NULL + } + + # If the user has a version of the named UI file in their GUIDIR, + # use that instead. + + if (envfind (GUIDIR, Memc[fname], SZ_PATHNAME) > 0) { + op = fname + strlen (Memc[fname]) + op = op + fnroot (Memc[uifname], Memc[op], + fname + SZ_PATHNAME - op) + op = op + gstrcpy (".gui", Memc[op], fname + SZ_PATHNAME - op) + if (access (Memc[fname], 0, 0) == YES) + uifname = fname + } + + # If the UI is already running and has not been modified there + # is no need to download it again. + + if (g_sg != NULL) + if (streq (Memc[uifname], Memc[SG_UIFNAME(g_sg)])) + if (finfo (Memc[uifname], fi) != ERR) + if (SG_UIFDATE(g_sg) == FI_MTIME(fi)) + uifname = NULL + } else { + # Ignore UI file if no EM capability. + Memc[SG_UIFNAME(g_sg)] = EOS + SG_UIFDATE(g_sg) = 0 + uifname = NULL + } + + # Open and Initialize the device. Output contents of UI definition + # file if any, followed by graphics device initialization file, + # if any. + + if (mode == NEW_FILE) { + # Output UI definition file. + if (uifname != NULL) { + iferr (init_file = open (Memc[uifname], READ_ONLY, TEXT_FILE)) { + call erract (EA_WARN) + call stg_ctrl ("OW") + } else { + call flush (g_out) + call stg_ctrl ("EM") + + # Download the UI. + call putline (g_out, "server ") + iferr (call fcopyo (init_file, g_out)) + call erract (EA_WARN) + call close (init_file) + + # Record particulars of active UI file. + call strcpy (Memc[uifname], Memc[SG_UIFNAME(g_sg)], + SZ_UIFNAME) + if (finfo (Memc[uifname], fi) != ERR) + SG_UIFDATE(g_sg) = FI_MTIME(fi) + call sgf_post_filter (g_out) + + call putci (g_out, US) + call flush (g_out) + } + } else + call stg_ctrl ("OW") + + # Output device graphics initialization file if any. + if (ttygets (g_tty, "IF", Memc[buf], SZ_FNAME) > 0) { + iferr (init_file = open (Memc[buf], READ_ONLY, TEXT_FILE)) + call erract (EA_WARN) + iferr (call fcopyo (init_file, g_out)) + call erract (EA_WARN) + call close (init_file) + } + + # Clear the screen if device is being opened in new_file mode. + call stg_clear (dummy) + + } else +ow_ call stg_ctrl ("OW") + + call sfree (sp) +end diff --git a/sys/gio/stdgraph/stgoutput.x b/sys/gio/stdgraph/stgoutput.x new file mode 100644 index 00000000..098af6e7 --- /dev/null +++ b/sys/gio/stdgraph/stgoutput.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_OUTPUT2 -- Encode two arguments using the program given and write the +# encoded character string to the output file. + +procedure stg_output2 (fd, program, arg1, arg2) + +int fd # output file +char program[ARB] # encoder program defining encoding +int arg1 # argument to be placed in register 1 +int arg2 # argument to be placed in register 2 + +int stg_encode() +include "stdgraph.com" + +begin + # Set up encoder. + g_reg[1] = arg1 + g_reg[2] = arg2 + g_reg[E_IOP] = 1 + + # Encode the output string and write the encoded string to the output + # file. + if (stg_encode (g_xy, g_mem, g_reg) == OK) + call write (fd, g_mem, g_reg[E_IOP] - 1) +end diff --git a/sys/gio/stdgraph/stgoutstr.x b/sys/gio/stdgraph/stgoutstr.x new file mode 100644 index 00000000..2d854e75 --- /dev/null +++ b/sys/gio/stdgraph/stgoutstr.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_OUTSTR -- Format and output a control sequence containing a string +# string argument to the output device. + +procedure stg_outstr (cap, strval) + +char cap[ARB] #I graphcap capability name +char strval[ARB] #I string data + +pointer sp, fmt, ctrl +include "stdgraph.com" +int ttygets() +errchk ttygets + +begin + call smark (sp) + call salloc (fmt, SZ_LINE, TY_CHAR) + call salloc (ctrl, SZ_LINE, TY_CHAR) + + if (ttygets (g_tty, cap, Memc[fmt], SZ_LINE) > 0) { + call sprintf (Memc[ctrl], SZ_LINE, Memc[fmt]) + call pargstr (strval) + call ttyputs (g_out, g_tty, Memc[ctrl], 1) + } + + call sfree (sp) +end diff --git a/sys/gio/stdgraph/stgpcell.x b/sys/gio/stdgraph/stgpcell.x new file mode 100644 index 00000000..476d90cf --- /dev/null +++ b/sys/gio/stdgraph/stgpcell.x @@ -0,0 +1,85 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stdgraph.h" + +define ZSTEP 4 # bit to be tested (step function width) + + +# STG_PUTCELLARRAY -- Draw a cell array, i.e., two dimensional array of pixels +# (greylevels or colors). The algorithm used here maps 8 bits in into 1 bit +# out, using a step function lookup table. The result is a band-contoured +# image, where the spacing and width of the contour bands decreases as the +# rate of change of intensity in the input cell array increases. + +procedure stg_putcellarray (m, nx, ny, ax1,ay1, ax2,ay2) + +short m[nx,ny] # cell array +int nx, ny # number of pixels in X and Y +int ax1, ay1 # lower left corner of output window +int ax2, ay2 # upper right corner of output window + +real dx, dy +int my, i1, i2, v, i, j, k +include "stdgraph.com" +int and() + +begin + # Set polyline width to 1 for max y-res. + call stg_ctrl1 ("LW", 1) + SG_PLWIDTH(g_sg) = 1 + + # Determine the width of a cell array pixel in GKI units. + dx = real (ax2 - ax1) / nx + + # Determine the height of a device pixel in GKI units. + dy = max (1.0, real(GKI_MAXNDC) / real(g_yres)) + + # Process the cell array. The outer loop runs over device pixels in Y; + # each iteration writes one line of the output raster. The inner loop + # runs down a line of the cell array. + + k = 0 + for (my = ay1 + dy/2; my < ay2; my = k * dy + ay1) { + j = max(1, min(ny, int (real(my-ay1) / real(ay2-ay1) * (ny-1)) + 1)) + my = min (my, int (ay2 - dy/2)) + + for (i=1; i <= nx; ) { + do i = i, nx { + v = m[i,j] + if (and (v, ZSTEP) != 0) + break + } + + if (i <= nx) { + i1 = i + i2 = nx + do i = i1 + 1, nx { + v = m[i,j] + if (and (v, ZSTEP) == 0) { + i2 = i + break + } + } + + # The following decreases the length of dark line segments + # to make features more visible. + + if (i2 - i1 >= 2) + if (i1 > 1 && i2 < nx) { + i1 = i1 + 1 + i2 = i2 - 1 + } + + # Draw the line segment. + call stg_move (int ((i1-1) * dx + ax1), my) + call stg_draw (int (i2 * dx + ax1), my) + + if (i2 >= nx) + i = nx + 1 + } + } + + k = k + 1 + } +end diff --git a/sys/gio/stdgraph/stgpl.x b/sys/gio/stdgraph/stgpl.x new file mode 100644 index 00000000..894a92c3 --- /dev/null +++ b/sys/gio/stdgraph/stgpl.x @@ -0,0 +1,126 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_POLYLINE -- Draw a polyline. The polyline is defined by the array of +# points P, consisting of successive (x,y) coordinate pairs. The first point +# is not plotted but rather defines the start of the polyline. The remaining +# points define line segments to be drawn. + +procedure stg_polyline (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs + +pointer pl +bool tek_encoding +int lowres_x, lowres_y +int ip, n, sx, sy, len_p, iop, i +int stg_encode() +include "stdgraph.com" + +begin + if (g_enable == NO) + call stg_genab() + + len_p = npts * 2 + + # Update polyline attributes if necessary. + + pl = SG_PLAP(g_sg) + if (SG_PLTYPE(g_sg) != PL_LTYPE(pl)) { + call stg_ctrl1 ("LT", PL_LTYPE(pl)) + SG_PLTYPE(g_sg) = PL_LTYPE(pl) + } + if (SG_PLWIDTH(g_sg) != PL_WIDTH(pl)) { + call stg_ctrl1 ("LW", PL_WIDTH(pl)) + SG_PLWIDTH(g_sg) = PL_WIDTH(pl) + } + if (SG_COLOR(g_sg) != PL_COLOR(pl)) { + call stg_ctrl1 ("LC", PL_COLOR(pl)) + SG_COLOR(g_sg) = PL_COLOR(pl) + } + + # Transform the first point from GKI coords to device coords and + # move to the transformed point. + + sx = p[1]; sy = p[2] + call stg_move (sx, sy) + + # Tektronix encoding is treated as a special case for max efficiency. + tek_encoding = + (Memc[g_xy] == '%' && Memc[g_xy+1] == 't' && Memc[g_xy+2] == EOS) + + # Draw the polyline. If the device has the "polyline" capability + # we can encode and output successive points without enclosing each + # individual point in the startdraw and enddraw strings. + + for (ip=3; ip <= len_p; ip=ip+2) { + # Output start draw sequence. + call ttyputs (g_out, g_tty, Memc[SG_STARTDRAW(g_sg)], 1) + + # Determine number of points to output. + if (SG_POLYLINE(g_sg) == YES) + n = len_p + else + n = ip + 2 + + # Encode the points of the polyline. + + g_lastx = -1 # clip unresolved points only in the interior + g_lasty = -1 # of the polyline being drawn. + + g_reg[E_IOP] = 1 + do i = ip, n, 2 { + sx = p[i] + sy = p[i+1] + + # Discard the point if it is not resolved. + lowres_x = sx / g_dxres + lowres_y = sy / g_dyres + if (lowres_x == g_lastx && lowres_y == g_lasty) + next + + g_lastx = lowres_x + g_lasty = lowres_y + + # Transform point into the device window. + sx = int (sx * g_dx) + g_x1 + sy = int (sy * g_dy) + g_y1 + + # Encode the point, appending encoded bytes to g_mem. Tek + # encoding is treated as a special case since it is so common; + # the encoder is used for non-Tek encodings. + + if (tek_encoding) { + iop = g_reg[E_IOP] + 4 + g_mem[iop-4] = g_hixy[sy+1] + g_mem[iop-3] = g_loy[sy+1] + g_mem[iop-2] = g_hixy[sx+1] + g_mem[iop-1] = g_lox[sx+1] + g_reg[E_IOP] = iop + } else { + g_reg[1] = sx + g_reg[2] = sy + if (stg_encode (Memc[g_xy], g_mem, g_reg) != OK) + break + } + + # Flush buffer if nearly full. + if (g_reg[E_IOP] > FLUSH_MEMORY) { + call write (g_out, g_mem, g_reg[E_IOP] - 1) + g_reg[E_IOP] = 1 + } + } + ip = n + + # Flush any output remaining in encoder memory. + if (g_reg[E_IOP] > 1) { + call write (g_out, g_mem, g_reg[E_IOP] - 1) + g_reg[E_IOP] = 1 + } + + # Output end draw sequence. + call ttyputs (g_out, g_tty, Memc[SG_ENDDRAW(g_sg)], 1) + } +end diff --git a/sys/gio/stdgraph/stgplset.x b/sys/gio/stdgraph/stgplset.x new file mode 100644 index 00000000..c435feb5 --- /dev/null +++ b/sys/gio/stdgraph/stgplset.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stdgraph.h" + +# STG_PLSET -- Set the polyline attributes. The polyline width parameter is +# passed to the encoder as a packed floating point number, i.e., int(LWx100). + +procedure stg_plset (gki) + +short gki[ARB] # attribute structure +pointer pl +include "stdgraph.com" + +begin + pl = SG_PLAP(g_sg) + PL_LTYPE(pl) = gki[GKI_PLSET_LT] + PL_WIDTH(pl) = max (1, nint (GKI_UNPACKREAL (gki[GKI_PLSET_LW]))) + PL_COLOR(pl) = gki[GKI_PLSET_CI] +end diff --git a/sys/gio/stdgraph/stgpm.x b/sys/gio/stdgraph/stgpm.x new file mode 100644 index 00000000..3808d63b --- /dev/null +++ b/sys/gio/stdgraph/stgpm.x @@ -0,0 +1,118 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_POLYMARKER -- Draw a polymarker. The polymarker is defined by the array +# of points P, consisting of successive (x,y) coordinate pairs, each of which +# is to be plotted as a point. If the marker start sequence MS is defined the +# polymarker will be drawn as ... , otherwise +# ther marker is draw using the polyline move and draw commands to draw each +# individual point. + +procedure stg_polymarker (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs + +pointer pm +bool tek_encoding +int lowres_x, lowres_y +int ip, n, sx, sy, len_p, iop, i +int stg_encode() +include "stdgraph.com" + +begin + if (g_enable == NO) + call stg_genab() + + len_p = npts * 2 + + # Update polymarker attributes if necessary. + + pm = SG_PMAP(g_sg) + if (SG_COLOR(g_sg) != PM_COLOR(pm)) { + call stg_ctrl1 ("MC", PM_COLOR(pm)) + SG_COLOR(g_sg) = PM_COLOR(pm) + } + + # Tektronix encoding is treated as a special case for max efficiency. + tek_encoding = + (Memc[g_xy] == '%' && Memc[g_xy+1] == 't' && Memc[g_xy+2] == EOS) + + # Draw the polymarker. If the startmark sequence is defined we assume + # that the device can draw a multipoint polymarker, else low level move + # and draw sequences are used. + + if (Memc[SG_STARTMARK(g_sg)] != EOS) { + for (ip=1; ip <= len_p; ip=ip+2) { + # Output start marker sequence [revised to use the encoder]. + call ttyputs (g_out, g_tty, Memc[SG_STARTMARK(g_sg)], 1) + n = len_p + + # Encode the points of the polymarker (or move to the single + # point to be drawn). + + g_lastx = -1 # clip unresolved points only in the interior + g_lasty = -1 # of the polymarker being drawn. + + g_reg[E_IOP] = 1 + do i = ip, n, 2 { + sx = p[i] + sy = p[i+1] + + # Discard the point if it is not resolved. + lowres_x = sx / g_dxres + lowres_y = sy / g_dyres + if (lowres_x == g_lastx && lowres_y == g_lasty) + next + + g_lastx = lowres_x + g_lasty = lowres_y + + # Transform point into the device window. + sx = int (sx * g_dx) + g_x1 + sy = int (sy * g_dy) + g_y1 + + # Encode the point, appending encoded bytes to g_mem. + # Tek encoding is treated as a special case since it is + # so common; the encoder is used for non-Tek encodings. + + if (tek_encoding) { + iop = g_reg[E_IOP] + 4 + g_mem[iop-4] = g_hixy[sy+1] + g_mem[iop-3] = g_loy[sy+1] + g_mem[iop-2] = g_hixy[sx+1] + g_mem[iop-1] = g_lox[sx+1] + g_reg[E_IOP] = iop + } else { + g_reg[1] = sx + g_reg[2] = sy + if (stg_encode (Memc[g_xy], g_mem, g_reg) != OK) + break + } + + # Flush buffer if nearly full. + if (g_reg[E_IOP] > FLUSH_MEMORY) { + call write (g_out, g_mem, g_reg[E_IOP] - 1) + g_reg[E_IOP] = 1 + } + } + ip = n + + # Flush any output remaining in encoder memory. + if (g_reg[E_IOP] > 1) { + call write (g_out, g_mem, g_reg[E_IOP] - 1) + g_reg[E_IOP] = 1 + } + + # Output end polymarker sequence, or draw the point. + call ttyputs (g_out, g_tty, Memc[SG_ENDMARK(g_sg)], 1) + } + } else { + for (ip=1; ip <= len_p; ip=ip+2) { + sx = p[ip]; sy = p[ip+1] + call stg_move (sx, sy) + call stg_draw (sx, sy) + } + } +end diff --git a/sys/gio/stdgraph/stgpmset.x b/sys/gio/stdgraph/stgpmset.x new file mode 100644 index 00000000..6651564f --- /dev/null +++ b/sys/gio/stdgraph/stgpmset.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stdgraph.h" + +# STG_PMSET -- Set the polymarker attributes. + +procedure stg_pmset (gki) + +short gki[ARB] # attribute structure +pointer pm +include "stdgraph.com" + +begin + pm = SG_PMAP(g_sg) + PM_LTYPE(pm) = gki[GKI_PMSET_MT] + PM_WIDTH(pm) = max (1, nint (GKI_UNPACKREAL (gki[GKI_PMSET_MW]))) + PM_COLOR(pm) = gki[GKI_PMSET_CI] +end diff --git a/sys/gio/stdgraph/stgrcur.x b/sys/gio/stdgraph/stgrcur.x new file mode 100644 index 00000000..e0ab890a --- /dev/null +++ b/sys/gio/stdgraph/stgrcur.x @@ -0,0 +1,425 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include +include +include "stdgraph.h" + +define MAX_LENCUR 17 +define MAX_KEYLINES 30 +define KEYSIZE 1 +define QUIT 'q' +define GO 'g' + +# STG_READCURSOR -- Physically read the cursor, returning the cursor position +# in GKI coordinates and the keystroke value as output arguments. The cursor +# value string is read in raw mode with interrupts disabled. Receipt of the +# EOF character or CR causes EOF to be returned as the key value. +# +# The cursor is described by two parameters, a pattern string (CD) and a string +# length parameter (CN). +# +# CD A pattern specifying either the delimiter sequence if +# len_curval > 0, or the entire cursor value string if +# len_curval <= 0. +# +# CN If no pattern is given, CN is the number of characters to be +# read and automatic error detection is not possible. If a +# pattern is given, a negative CN specifies the minimum number +# of characters in the cursor value string, with the pattern +# being used to match the characters in the actual cursor value +# string. A positive CN specifies a fixed length cursor value +# string, which which case the pattern is used only to determine +# when a valid cursor value string has been received. +# +# The cursor read algorithm tries to ignore unsolicited input and recover from +# bad cursor reads, or loss of hardware cursor mode during a cursor read, e.g., +# if the screen is accidentally cleared or the terminal otherwise initialized. +# +# The physical cursor read sequence is implemented by the stg_rdcursor routine. +# The purpose of the higher level routine is to support STTY playback mode. +# In playback mode, terminal input is taken from a logfile rather than from +# the physical terminal; this is used to prepare automatic scripts to test +# software and for demos. If playback mode is enabled and `verify' is enabled, +# the logged cursor position will be read, a WC will be issued to move the +# cursor to that position, and then the physical cursor will be read and the +# return value discard, returning the logged position to the calling program. +# In playback mode with `verify' disabled, we need only disable the RC +# instruction and read the logged cursor position; the physical cursor is +# never turned on. + +procedure stg_readcursor (cursor, cn, key, sx, sy, raster, rx, ry) + +int cursor #I cursor to be read +int cn #O cursor which was read +int key #O keystroke which terminated cursor read +int sx, sy #O screen coordinates of cursor in GKI units +int raster #O raster number +int rx, ry #O raster coordinates of cursor in GKI units + +short texts[4] +char textc[4], ch +pointer sp, pbdevice, tx, o_tx +int delay, nchars, mx, my, i, j, k +bool playback_mode, pbverify_mode + +bool strne() +pointer ttygdes() +int ttstati(), ttstats(), ctocc() +errchk ttygdes, syserr +include "stdgraph.com" +define samedev_ 91 + +begin + playback_mode = (ttstati (STDIN, TT_PLAYBACK) == YES) + + if (!playback_mode) { + call stg_rdcursor (g_tty, cursor, YES, + cn, key, sx, sy, raster, rx, ry) + return + } + + call smark (sp) + call salloc (pbdevice, SZ_GDEVICE, TY_CHAR) + call salloc (o_tx, LEN_TX, TY_STRUCT) + + # The playback script may have been generated on a different graphics + # terminal than the one we are playing it back on. Open the graphcap + # descriptor for the device used when the script was recorded. This + # must be used when decoding cursor input from the logfile. If device + # name not recorded in logfile, try to make do with the descriptor for + # the current stdgraph device. + + if (ttstats (STDIN, TT_GDEVICE, Memc[pbdevice], SZ_GDEVICE) <= 0) { + # Device name not recorded in logfile. + call syserr (SYS_STTYNOGDEV) + + } else if (g_pbtty == NULL || strne (g_pbdevice, Memc[pbdevice])) { + # Device name was recorded; try to load graphcap for it if not + # already loaded. + + if (g_pbtty != NULL) + call ttycdes (g_pbtty) + iferr (g_pbtty = ttygdes (Memc[pbdevice])) { + g_pbtty = NULL + call erract (EA_ERROR) + } + + call strcpy (Memc[pbdevice], g_pbdevice, SZ_GDEVICE) + } + + # Set the playback delay to 0 msec while reading the cursor, else + # the multicharacter cursor read will take forever. We issue the + # delay below, ourselves, one per cursor read. + + delay = ttstati (STDIN, TT_PBDELAY) + call ttseti (STDIN, TT_PBDELAY, 0) + + # Read the logged cursor position with RC disabled. + call stg_rdcursor (g_pbtty, cursor, NO, + cn, key, sx, sy, raster, rx, ry) + + # Determine if verify mode is set for this cursor read. This must + # be done after the call to stg_rdcursor to permit processing of + # any \{ .. \} in the logfile. + + pbverify_mode = (ttstati (STDIN, TT_PBVERIFY) == YES) + + # Set passthru mode to read/write the device directly. + call ttseti (STDIN, TT_PASSTHRU, YES) + + # Encode the logged keystroke as a character string. + if (key == EOF) { + call strcpy ("EOF", textc, 4) + nchars = 3 + } else if (key <= ' ') { + ch = key + nchars = ctocc (ch, textc, 4) + } else { + nchars = 1 + textc[1] = key + } + + # Pack the string in a short array for the GKI operator. + call achtcs (textc, texts, nchars) + + # Set the text drawing attributes. + tx = SG_TXAP(g_sg) + call amovi (Memi[tx], Memi[o_tx], LEN_TX) + TX_SIZE(tx) = KEYSIZE + TX_HJUSTIFY(tx) = GT_LEFT + TX_VJUSTIFY(tx) = GT_BOTTOM + + # Echo the key character in graphics mode on the top line of the screen, + # duplicating the text drawn at the cursor position. + + mx = nint ((g_keycol + 0.5) * SG_CHARWIDTH(g_sg,1)) + my = GKI_MAXNDC - nint ((g_keyline + 0.2) * SG_CHARHEIGHT(g_sg,KEYSIZE)) + + call stg_text (mx, my, texts, nchars) + g_keyline = g_keyline + 1 + if (g_keyline > MAX_KEYLINES) { + g_keycol = g_keycol + 1 + g_keyline = 1 + } + + # Echo the logged keystroke at the position of the cursor. This may + # not always be readable, but at least it marks the cursor position. + + call stg_text (sx, sy, texts, nchars) + + if (pbverify_mode) { + # Issue a WC to set the cursor position, and perform a normal + # cursor read in passthru mode, discarding the return value. + + call stg_setcursor (sx, sy, cursor) + call stg_rdcursor (g_tty, cursor, YES, i, i, j, k, i, j, k) + + # User wants to terminate playback mode? + if (k == QUIT || k == INTCHAR) { + call ttseti (STDIN, TT_PLAYBACK, NO) + call stg_ctrl ("GD") + call putline (STDOUT, "[playback mode terminated]") + call stg_ctrl ("GE") + call flush (STDOUT) + call zwmsec (500) + if (k == INTCHAR) + key = EOF + } else if (k == GO) + call ttseti (STDIN, TT_PBVERIFY, NO) + } else + call zwmsec (delay) + + # Restore everything modified earlier. + call ttseti (STDIN, TT_PASSTHRU, NO) + call ttseti (STDIN, TT_PBDELAY, delay) + call amovi (Memi[o_tx], Memi[tx], LEN_TX) + + call sfree (sp) +end + + +# STG_RDCURSOR -- Physically read the cursor; an internal routine called only +# by the stg_readcursor procedure. A lower level routine is needed since +# two cursor reads may be required in STTY playback mode, one to read the +# logged cursor position and another to read the physical cursor to synch +# with the user. This is the real cursor read routine; the only concession +# to playback mode is the `output_rc' switch, to disable output of the RC +# instruction to the terminal, so that the routine does only input from the +# logical device. + +procedure stg_rdcursor (tty, cursor, output_rc, cn, key, sx,sy, raster, rx,ry) + +pointer tty #I graphcap descriptor +int cursor #I cursor to be read +int output_rc #I flag to output the RC instruction +int cn #O cursor which was read +int key #O keystroke which terminated cursor read +int sx, sy #O cursor screen position in GKI coords +int raster #O raster number +int rx, ry #O cursor raster position in GKI coords + +pointer decodecur, delimcur, pattern, patbuf, sp, otop +int len_pattern, len_curval, sv_iomode, nchars, ip, op, i1, i2, ch + +bool ttygetb() +int getci(), stg_encode() +int ttygets(), ttygeti(), gstrcpy(), gpatmatch(), patmake(), fstati() +include "stdgraph.com" +define quit_ 91 + +begin + call smark (sp) + call salloc (pattern, SZ_LINE, TY_CHAR) + call salloc (patbuf, SZ_LINE, TY_CHAR) + call salloc (decodecur, SZ_LINE, TY_CHAR) + call salloc (delimcur, SZ_FNAME, TY_CHAR) + + key = EOF + + # Make sure there is a cursor before going any further. + if (!ttygetb (g_tty, "RC")) + goto quit_ + + len_curval = ttygeti (tty, "CN") + if (ttygets (tty, "SC", Memc[decodecur], SZ_LINE) <= 0) + goto quit_ + + len_pattern = 0 + if (ttygets (tty, "CD", Memc[delimcur], SZ_FNAME) > 0) + len_pattern = gstrcpy (Memc[delimcur], Memc[pattern], SZ_LINE) + + # Either len_curval or pattern must be given, preferably both. + if (len_curval == 0 && len_pattern == 0) + goto quit_ + + # Encode the cursor value pattern, which may be either a pattern + # matching the entire cursor value, or just the delimiter. The value + # of len_curval may be negative if a pattern is given, but must be + # positive otherwise. If the pattern is a delimiter string, append + # the $ metacharacter to match only at the end of the string. + + if (len_pattern > 0) { + if (len_curval > 0) { + Memc[pattern+len_pattern] = '$' + len_pattern = len_pattern + 1 + Memc[pattern+len_pattern] = EOS + } + if (patmake (Memc[pattern], Memc[patbuf], SZ_LINE) == ERR) + goto quit_ + } else if (len_curval < 0) + len_curval = -len_curval + + # Set raw mode on the input file (the graphics terminal). + call flush (STDOUT); call flush (STDERR) + sv_iomode = fstati (g_in, F_IOMODE) + if (sv_iomode != IO_RAW) + call fseti (g_in, F_IOMODE, IO_RAW) + + repeat { + # Initiate a cursor read. + if (output_rc == YES) { + call stg_ctrl1 ("RC", cursor) + call flush (g_out) + } + + # Read the cursor value string. If a pattern is given accumulate + # at least abs(len_curval) characters and stop when the pattern + # is matched, returning the last len_curval characters if + # len_curval > 0, else the matched substring. If no pattern is + # given simply accumulate len_curval characters. The number of + # characters we will accumulate in one iteration is limited to + # MAX_LENCUR to permit retransmission of the RC control sequence + # in the event that hardware cursor mode is accidentally cleared. + + for (op=1; op <= MAX_LENCUR; op=op+1) { + g_mem[op] = getci (g_in, key) + g_mem[op+1] = EOS + + if (key == EOF) { + # Turn off raw input mode and return EOF. + key = EOF + if (sv_iomode != IO_RAW) + call fseti (g_in, F_IOMODE, sv_iomode) + goto quit_ + + } else if (len_pattern > 0) { + # A pattern string was given. Once the minimum number of + # chars have been accumulated, try to match the pattern, + # which may match either the cursor string delimiter (in + # the case of a fixed length cursor value), or the entire + # cursor string (which may then be variable length). + + if (op < abs(len_curval)) + next + else if (gpatmatch (g_mem[1], Memc[patbuf], i1,i2) > 0) { + if (len_curval > 0) + ip = op - len_curval + 1 # fixed length cur + else + ip = i1 # variable length cur + break + } + + } else if (op >= len_curval) { + # No pattern was given. Terminate the cursor read once + # the len_curval characters have been accumulated. + + ip = 1 + break + } + } + + # We have received too many characters, indicating that cursor + # mode was lost and the user has been pounding on the keyboard + # trying to get the cursor back. Discard the chars, restart + # the cursor and try again. + + if (op > MAX_LENCUR) + op = -1 + + } until (op >= abs(len_curval) || len_curval == 0) + + # Decode the cursor value string and return the position and key + # as output values. Return the cursor position in GKI coordinates. + # If extra characters were typed, e.g., before the cursor was turned + # on, and the cursor has a delimiter string, the extra characters will + # have been read into low memory and we should be able to ignore them + # and still get a valid read. + + g_reg[E_IOP] = ip + call aclri (g_reg, 7) + if (stg_encode (Memc[decodecur], g_mem, g_reg) != OK) + call syserr (SYS_GGCUR) + + # Multiple cursors are not implemented yet so just echo input. + cn = cursor + + # Standard cursor value. + sx = nint ((g_reg[1] - g_x1) / g_dx) + sy = nint ((g_reg[2] - g_y1) / g_dy) + key = g_reg[3] + + # Only some devices return the following fields. Note that FX,FY + # are returned by stg_encode in GKI coordinates. + + nchars = g_reg[4] + raster = g_reg[5] + if (raster == 0) { + rx = sx + ry = sy + } else { + rx = g_reg[6] + ry = g_reg[7] + } + + # If the NCHARS field is nonzero then a data block of length nchars + # follows the cursor value struct returned by the terminal. Read this + # into the g_msgbuf message buffer. The client makes a subsequent + # call to stg_readtty to access this data, otherwise it is discarded + # in the next cursor read. + + if (nchars > 0) { + if (nchars > g_msgbuflen) { + g_msgbuflen = (nchars + SZ_MSGBUF - 1) / SZ_MSGBUF * SZ_MSGBUF + call realloc (g_msgbuf, g_msgbuflen, TY_CHAR) + } + + # We should encode this data transfer in a way that permits + # detection and recovery from lost data. For the moment, the + # following assumes that nchars of data will actually be received. + + op = g_msgbuf + otop = g_msgbuf + nchars + while (op < otop && getci (g_in, ch) != EOF) { + Memc[op] = ch + op = op + 1 + } + g_msglen = op - g_msgbuf + Memc[op] = EOS + + } else + g_msglen = 0 + + # Turn off raw input mode. + if (sv_iomode != IO_RAW) + call fseti (g_in, F_IOMODE, sv_iomode) + + # Return EOF if any EOF character (e.g., or ) or the + # interrupt character is typed. + + if (key == EOFCHAR || key == INTCHAR || key == '\004' || key == '\032') + key = EOF +quit_ + # Terminate the cursor read. + if (output_rc == YES) { + call stg_ctrl1 ("RE", cursor) + call flush (g_out) + } + + call sfree (sp) +end diff --git a/sys/gio/stdgraph/stgreact.x b/sys/gio/stdgraph/stgreact.x new file mode 100644 index 00000000..21c2a821 --- /dev/null +++ b/sys/gio/stdgraph/stgreact.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "stdgraph.h" + +# STG_REACTIVATEWS -- Reactivate the workstation, i.e., enable graphics. + +procedure stg_reactivatews (flags) + +int flags # action flags (handled by cursor mode) + +int junk +int ttstati(), ttyctrl(), and() +extern stg_onerror() +include "stdgraph.com" + +begin + if (g_active == NO) { + junk = ttyctrl (g_out, g_tty, "OW", 1) + + # Post error handler to be called if we abort. + call onerror (stg_onerror) + + g_active = YES + g_enable = YES + + # Must disable stty ucaseout mode when in graphics mode, else + # plotting commands may be modified by the terminal driver. + + g_ucaseout = ttstati (g_out, TT_UCASEOUT) + if (g_ucaseout == YES) + call ttseti (g_out, TT_UCASEOUT, NO) + + # Clear the graphics screen? + if (and (flags, AW_CLEAR) != 0) + call stg_clear (0) + + call flush (g_out) + } +end diff --git a/sys/gio/stdgraph/stgres.x b/sys/gio/stdgraph/stgres.x new file mode 100644 index 00000000..d6355bd9 --- /dev/null +++ b/sys/gio/stdgraph/stgres.x @@ -0,0 +1,85 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stdgraph.h" + +# STG_RESOLUTION -- Set the "soft" device resolution. When plotting GKI +# coordinates are transformed into a space with the indicated resolution and +# unresolved points are discarded, before transforming to device coordinates. +# We must set up both the transformation to resolution space and the +# transformation to device space. + +procedure stg_resolution (xres, yres) + +int xres # device X resolution +int yres # device Y resolution +int nx, ny +int ttygeti() +include "stdgraph.com" + +begin + if (g_tty == NULL) { + g_xres = xres + g_yres = yres + return + } + + # Set the resolution value in the stdgraph common only if a nonzero + # value is given. A value of zero does not change the resolution. + + if (xres > 0) + g_xres = xres + if (yres > 0) + g_yres = yres + + + # If we still have a zero resolution then we use the full resolution + # of the device. The 3/4 reduction in resolution is needed to clip + # points that would be unresolved due to integer truncation effects. + + if (g_xres <= 0) { + g_xres = ttygeti (g_tty, "xr") + if (g_xres <= 0) + g_xres = 1024 + g_xres = max (2, g_xres * 3 / 4) + } + if (g_yres <= 0) { + g_yres = ttygeti (g_tty, "yr") + if (g_yres <= 0) + g_yres = 1024 + g_yres = max (2, g_yres * 3 / 4) + } + + # Set up coordinate transformations. The first transformation is from + # GKI coordinates to device resolution coordinates (0:xres-1,0:yres-1) + # and is defined by xres, yres, and GKI_MAXNDC. Clipping of unresolved + # points is performed after this first transformation. The second + # transformation maps resolved points into the device window. + + # GKI -> resolution coords. + g_dxres = max (1, (GKI_MAXNDC + 1) / g_xres) + g_dyres = max (1, (GKI_MAXNDC + 1) / g_yres) + + g_x1 = ttygeti (g_tty, "X1") + g_y1 = ttygeti (g_tty, "Y1") + g_x2 = ttygeti (g_tty, "X2") + g_y2 = ttygeti (g_tty, "Y2") + nx = g_x2 - g_x1 + 1 + ny = g_y2 - g_y1 + 1 + + if (nx <= 1 || ny <= 1) { + call eprintf ("openws: illegal graphics device window\n") + nx = g_xres + ny = g_yres + } + + # GKI -> window coords. + g_dx = real (nx - 1) / GKI_MAXNDC + g_dy = real (ny - 1) / GKI_MAXNDC + + # The last point in resolution coords is used to clip unresolved + # points when drawing polylines. + + g_lastx = -1 + g_lasty = -1 +end diff --git a/sys/gio/stdgraph/stgreset.x b/sys/gio/stdgraph/stgreset.x new file mode 100644 index 00000000..0f2fd1e2 --- /dev/null +++ b/sys/gio/stdgraph/stgreset.x @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stdgraph.h" + +# STG_RESET -- Reset the state of the stdgraph common, i.e., in response to +# a clear or a cancel. Initialize all attribute packets to their default +# values and set the current state of the device to undefined, forcing the +# device state to be reset when the next output instruction is executed. + +procedure stg_reset() + +pointer pl, pm, fa, tx +include "stdgraph.com" + +begin + # Set pointers to attribute substructures. + pl = SG_PLAP(g_sg) + pm = SG_PMAP(g_sg) + fa = SG_FAAP(g_sg) + tx = SG_TXAP(g_sg) + + # Initialize the attribute packets. + PL_LTYPE(pl) = 1 + PL_WIDTH(pl) = 1 + PL_COLOR(pl) = 1 + PM_COLOR(pm) = 1 + FA_STYLE(fa) = 1 + FA_COLOR(fa) = 1 + TX_UP(tx) = 90 + TX_SIZE(tx) = 1 + TX_PATH(tx) = GT_RIGHT + TX_HJUSTIFY(tx) = GT_LEFT + TX_VJUSTIFY(tx) = GT_BOTTOM + TX_FONT(tx) = GT_ROMAN + TX_COLOR(tx) = 1 + TX_SPACING(tx) = 0.0 + + # Set the device attributes to undefined, forcing them to be reset + # when the next output instruction is executed. + + SG_COLOR(g_sg) = -1 + SG_TXSIZE(g_sg) = -1 + SG_TXFONT(g_sg) = -1 + SG_PLTYPE(g_sg) = -1 + SG_FASTYLE(g_sg) = -1 + SG_PLWIDTH(g_sg) = -1 + g_lastx = -1 + g_lasty = -1 + g_keycol = 1 + g_keyline = 1 + g_message = NO + g_msglen = 0 +end diff --git a/sys/gio/stdgraph/stgrtty.x b/sys/gio/stdgraph/stgrtty.x new file mode 100644 index 00000000..237a7c7b --- /dev/null +++ b/sys/gio/stdgraph/stgrtty.x @@ -0,0 +1,137 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "stdgraph.h" + +# STG_READTTY -- Read a line of text from the graphics terminal. +# If the workstation is currently activated the read is performed in raw mode, +# presumably with the cursor positioned to the end of a prompt string on the +# status line. The workstation will have been put into text mode and the +# cursor positioned to the status line by an immediately preceding call to +# stg_writetty, which is called by pseudofile i/o when the user task writes +# to STDOUT or STDERR while the workstation is activated. The input sequence +# terminates when the user types return or newline, causing exit with +# transmission of the GE sequence to restore the terminal to graphics mode. + +int procedure stg_readtty (fd, obuf, maxch) + +int fd #I input stream [NOT USED] +char obuf[ARB] #O output buffer +int maxch #I max chars to read + +int nchars, op, ch +int read(), getci(), fstati() +include "stdgraph.com" +errchk read, getci, ttyctrl +string delstr "\010 \010" + +begin + call flush (STDERR) + call flush (STDOUT) + + if (g_active == NO) { + # Workstation in normal text mode; normal text input. + return (read (STDIN, obuf, maxch)) + + } else if (g_msglen > 0) { + # The message data has already been transmitted and resides in + # the message buffer. + + nchars = min (maxch, g_msglen) + call amovc (Memc[g_msgbuf], obuf, nchars) + obuf[nchars+1] = EOS + g_msglen = 0 + return (nchars) + + } else { + # Workstation is activated; read status line in raw mode. + # If already in rew mode, read a single char with no echo. + # Note that genable is not automatic in raw input mode. + + if (g_enable == YES) + call stg_gdisab() + + if (fstati (g_in, F_RAW) == YES) { + if (getci (g_in, ch) == EOF) { + obuf[1] = EOS + return (EOF) + } else if (ch == '\004' || ch == '\032') { + obuf[1] = EOS + return (EOF) + } else { + obuf[1] = ch + obuf[2] = EOS + return (1) + } + } else + call fseti (g_in, F_RAW, YES) + + for (op=1; getci (g_in, ch) != EOF; op=min(maxch,op)) { + switch (ch) { + case EOF, '\004', '\032': # EOF + call stg_genab() + break + case '\n', '\r': + obuf[op] = '\n' + op = op + 1 + call putline (g_out, "\r\n") + call stg_genab() + break + case INTCHAR, '\025': # + for (; op > 1; op=op-1) + call putline (g_out, delstr) + case BS, '\177': + if (op > 1) { + call putline (g_out, delstr) + op = op - 1 + } else { + call stg_genab() + break # exit + } + default: + call putci (g_out, ch) + obuf[op] = ch + op = op + 1 + } + call flush (g_out) + } + + obuf[op] = EOS + call fseti (g_in, F_RAW, NO) + + if (op > 1) + return (op - 1) + else + return (EOF) + } +end + + +# STG_GETLINE -- Get a line of text from the graphics terminal, reading from +# the status line if the workstation is activated, and doing a normal text +# read otherwise. + +int procedure stg_getline (fd, obuf) + +int fd #I input file +char obuf[SZ_LINE] #O output buffer + +int stg_readtty() + +begin + return (stg_readtty (fd, obuf, SZ_LINE)) +end + + +# STG_MSGLEN -- This routine is called to determine if there is any message +# data buffered in the kernel, to be returned in the next call to stg_readtty. + +int procedure stg_msglen (fd) + +int fd #I input file +include "stdgraph.com" + +begin + return (g_msglen) +end diff --git a/sys/gio/stdgraph/stgscur.x b/sys/gio/stdgraph/stgscur.x new file mode 100644 index 00000000..e40d4a3d --- /dev/null +++ b/sys/gio/stdgraph/stgscur.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stdgraph.h" + +# STG_SETCURSOR -- Set the position of a cursor. + +procedure stg_setcursor (x, y, cursor) + +int x, y # new position of cursor +int cursor # cursor to be set +int mx, my, cur +include "stdgraph.com" + +begin + # If cursor=0, write the cursor last referenced. + if (cursor > 0) { + SG_CURSOR(g_sg) = cursor + cur = cursor + } else + cur = max (1, SG_CURSOR(g_sg)) + + # If the user has locked the logical cursor override runtime selection. + if (g_cursor > 0) + cur = g_cursor + + # Restore the software cursor position before reading? + if (SG_UPDCURSOR(g_sg) == YES) { + SG_CURSOR_X(g_sg) = x + SG_CURSOR_Y(g_sg) = y + } + + mx = max(g_x1, min(g_x2, nint (x * g_dx) + g_x1)) + my = max(g_y1, min(g_y2, nint (y * g_dy) + g_y1)) + + call stg_ctrl3 ("WC", mx, my, cur) +end diff --git a/sys/gio/stdgraph/stgtx.x b/sys/gio/stdgraph/stgtx.x new file mode 100644 index 00000000..ff5abae2 --- /dev/null +++ b/sys/gio/stdgraph/stgtx.x @@ -0,0 +1,528 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "stdgraph.h" + +# STG_TEXT -- Draw a text string. The string is drawn at the position (X,Y) +# using the text attributes set by the last GKI_TXSET instruction. The text +# string to be drawn may contain embedded set font escape sequences of the +# form \fR (roman), \fG (greek), etc. We break the input text sequence up +# into segments at font boundaries and draw these on the output device, +# setting the text size, color, font, and position at the beginning of each +# segment. Two levels of character quality are implemented: MEDIUM and HIGH, +# wherein characters are generated in software, and everything else, wherein +# the characters are generated by the hardware. + +procedure stg_text (xc, yc, text, n) + +int xc, yc # where to draw text string +short text[ARB] # text string +int n # number of characters + +bool hard +real x, y +int x1, x2, y1, y2, mx, my +int x0, y0, dx, dy, ch, cw, sz +int xstart, ystart, newx, newy +int totlen, polytext, font, seglen, orien, hwsz +pointer sp, seg, ip, op, tx, first +int stx_segment(), stg_encode() +include "stdgraph.com" + +begin + call smark (sp) + call salloc (seg, n + 2, TY_CHAR) + + if (g_enable == NO) + call stg_genab() + + # Set pointer to the text attribute structure. + tx = SG_TXAP(g_sg) + + # Break the text string into segments at font boundaries and count + # the total number of printable characters. + + totlen = stx_segment (text, n, Memc[seg], TX_FONT(tx)) + + # Compute the text drawing parameters, i.e., the coordinates of the + # first character to be drawn, the step between successive characters, + # and the polytext flag (GKI coords). + + call stx_parameters (xc,yc, totlen, x0,y0, dx,dy, polytext, orien) + + # Set the text size and color if not already set. Both should be + # invalidated when the screen is cleared. Text color should be + # invalidated whenever another color is set. If software (!hard) + # character generation is indicated then size 1 is simply scaled by + # the indicated factor, otherwise the text size is converted to a + # hardware size index by stg_txsize. + + call stx_chars (tx, ch, cw, hwsz, hard, orien) + sz = TX_SIZE(tx) + + if (hard) + if (SG_TXSIZE(g_sg) != sz) { + call stg_ctrl1 ("TH", hwsz) + SG_TXSIZE(g_sg) = sz + } + + if (TX_COLOR(tx) != SG_COLOR(g_sg)) { + call stg_ctrl1 ("TC", TX_COLOR(tx)) + SG_COLOR(g_sg) = TX_COLOR(tx) + } + + # Draw the segments, setting the font at the beginning of each segment. + # The first segment is drawn at (X0,Y0). The separation between + # characters is DX,DY. A segment is drawn as a block if the polytext + # flag is set, otherwise each character is drawn individually. + # All computations are in GKI coordinates. + + x = x0 + y = y0 + + for (ip=seg; Memc[ip] != EOS; ip=ip+1) { + # Process the font control character heading the next segment. + font = Memc[ip] + ip = ip + 1 + if (hard) + if (SG_TXFONT(g_sg) != font) { + call stg_ctrl1 ("TF", font - GT_ROMAN + 1) + SG_TXFONT(g_sg) = font + } + + # Draw the segment. + while (Memc[ip] != EOS) { + # Clip leading out of bounds characters. + for (; Memc[ip] != EOS; ip=ip+1) { + x1 = x; x2 = x1 + cw + y1 = y; y2 = y1 + ch + + if (x1 >= 0 && x2 <= GKI_MAXNDC && + y1 >= 0 && y2 <= GKI_MAXNDC) { + + break + + } else { + x = x + dx + y = y + dy + } + + if (polytext == NO) { + ip = ip + 1 + break + } + } + + # Coords of first char to be drawn. + xstart = x + ystart = y + + # Move OP to first out of bounds char. + for (op=ip; Memc[op] != EOS; op=op+1) { + x1 = x; x2 = x1 + cw + y1 = y; y2 = y1 + ch + + if (x1 <= 0 || x2 >= GKI_MAXNDC || + y1 <= 0 || y2 >= GKI_MAXNDC) { + + break + + } else { + x = x + dx + y = y + dy + } + + if (polytext == NO) { + op = op + 1 + break + } + } + + # Count number of inbounds chars. + seglen = op - ip + + # Leave OP pointing to the end of this segment. + if (polytext == NO) + op = ip + 1 + else { + while (Memc[op] != EOS) + op = op + 1 + } + + # Compute X,Y of next segment. + newx = xstart + (dx * (op - ip)) + newy = ystart + dy + + # Quit if no inbounds chars. + if (seglen == 0) { + x = newx + y = newy + ip = op + next + } + + # Output the inbounds chars. + if (hard) { + g_reg[1] = xstart * g_dx + g_x1 + g_reg[2] = ystart * g_dy + g_y1 + g_reg[E_IOP] = 1 + if (stg_encode (Memc[SG_STARTTEXT(g_sg)],g_mem,g_reg) == OK) + call write (g_out, g_mem, g_reg[E_IOP] - 1) + } + + first = ip + x = xstart + y = ystart + + # Draw the characters. + while (seglen > 0 && (polytext == YES || ip == first)) { + if (hard) + call putc (g_out, Memc[ip]) + else { + mx = nint(x) + my = nint(y) + call stg_drawchar (Memc[ip], mx,my, cw, ch, orien, font) + x = x + dx + y = y + dy + } + + ip = ip + 1 + seglen = seglen - 1 + } + + x = newx + y = newy + ip = op + + if (hard) { + g_reg[E_IOP] = 1 + if (stg_encode (Memc[SG_ENDTEXT(g_sg)], g_mem, g_reg) == OK) + call write (g_out, g_mem, g_reg[E_IOP] - 1) + } + } + } + + call sfree (sp) +end + + +# STX_SEGMENT -- Process the text string into segments, in the process +# converting from type short to char. The only text attribute that can +# change within a string is the font, so segments are broken by \fI, \fG, +# etc. font select sequences embedded in the text. The segments are encoded +# sequentially in the output string. The first character of each segment is +# the font number. A segment is delimited by EOS. A font number of EOS +# marks the end of the segment list. The output string is assumed to be +# large enough to hold the segmented text string. + +int procedure stx_segment (text, n, out, start_font) + +short text[ARB] # input text +int n # number of characters in text +char out[ARB] # output string +int start_font # initial font code + +int ip, op +int totlen, font + +begin + out[1] = start_font + totlen = 0 + op = 2 + + for (ip=1; ip <= n; ip=ip+1) { + if (text[ip] == '\\' && text[ip+1] == 'f') { + # Select font. + out[op] = EOS + op = op + 1 + ip = ip + 2 + + switch (text[ip]) { + case 'B': + font = GT_BOLD + case 'I': + font = GT_ITALIC + case 'G': + font = GT_GREEK + default: + font = GT_ROMAN + } + + out[op] = font + op = op + 1 + + } else { + # Deposit character in segment. + out[op] = text[ip] + op = op + 1 + totlen = totlen + 1 + } + } + + # Terminate last segment and add null segment. + + out[op] = EOS + out[op+1] = EOS + + return (totlen) +end + + +# STX_PARAMETERS -- Set the text drawing parameters, i.e., the coordinates +# of the lower left corner of the first character to be drawn, the spacing +# between characters, and the polytext flag. Input consists of the coords +# of the text string, the length of the string, and the text attributes +# defining the character size, justification in X and Y of the coordinates, +# and orientation of the string. All coordinates are in GKI units. + +procedure stx_parameters (xc, yc, totlen, x0, y0, dx, dy, polytext, orien) + +int xc, yc # coordinates at which string is to be drawn +int totlen # number of characters to be drawn +int x0, y0 # lower left corner of first char to be drawn +int dx, dy # step in X and Y between characters +int polytext # OK to output text segment all at once +int orien # rotation angle of characters + +pointer tx +bool hard +int up, path, hwsz, ch, cw, i +real dir, cosv, sinv, space +real xsize, ysize, xvlen, yvlen, xu, yu, xv, yv, p, q +include "stdgraph.com" + +begin + tx = SG_TXAP(g_sg) + + # Compute the character rotation angle. This is independent of the + # direction in which characters are drawn. A character up vector of + # 90 degrees (normal) corresponds to a rotation angle of zero. + + up = TX_UP(tx) + orien = up - 90 + + # Get character sizes in GKI(NSPP) coords. + call stx_chars (tx, ch, cw, hwsz, hard, orien) + + # Determine the direction in which characters are to be plotted. + # This depends on both the character up vector and the path, which + # is defined relative to the up vector. + + path = TX_PATH(tx) + switch (path) { + case GT_UP: + dir = up + case GT_DOWN: + dir = up - 180 + case GT_LEFT: + dir = up + 90 + default: # GT_NORMAL, GT_RIGHT + dir = up - 90 + } + + # If hardware character generation is enabled the character up vector + # is constrained to 90 degrees. Flip the direction in which characters + # will be drawn if necessary to draw from left to right or from top + # down, the readable directions. + + if (hard) { + # Constrain the up vector. + orien = 0 + + # Flip direction vector if in 2nd or 3rd quadrant. + i = nint(dir) + if (i < 0) + i = i + 360 + if (i >= 90 && i < 180) + i = i + 180 + if (i >= 360) + i = i - 360 + dir = real(i) + } + + # ------- DX, DY --------- + # Convert the direction vector into the step size between characters. + # Note CW and CH are in GKI coordinates, hence DX and DY are too. + # Additional spacing of some fraction of the character size is used + # if TX_SPACING is nonzero. + + dir = -DEGTORAD(dir) + cosv = cos (dir) + sinv = sin (dir) + + # Correct for spacing (unrotated). + space = (1.0 + TX_SPACING(tx)) + if ((path == GT_UP || path == GT_DOWN) || + (hard && abs(cosv) < .9)) { + p = ch * space + } else + p = cw * space + q = 0 + + # Correct for rotation. + dx = p * cosv + q * sinv + dy = -p * sinv + q * cosv + + # ------- XU, YU --------- + # Determine the coordinates of the center of the first character req'd + # to justify the string, assuming dimensionless characters spaced on + # centers DX,DY apart. + + xvlen = dx * (totlen - 1) + yvlen = dy * (totlen - 1) + + switch (TX_HJUSTIFY(tx)) { + case GT_CENTER: + xu = - (xvlen / 2.0) + case GT_RIGHT: + # If right justify and drawing to the left, no offset req'd. + if (xvlen < 0) + xu = 0 + else + xu = -xvlen + default: # GT_LEFT, GT_NORMAL + # If left justify and drawing to the left, full offset right req'd. + if (xvlen < 0) + xu = -xvlen + else + xu = 0 + } + + switch (TX_VJUSTIFY(tx)) { + case GT_CENTER: + yu = - (yvlen / 2.0) + case GT_TOP: + # If top justify and drawing downward, no offset req'd. + if (yvlen < 0) + yu = 0 + else + yu = -yvlen + default: # GT_BOTTOM, GT_NORMAL + # If bottom justify and drawing downward, full offset up req'd. + if (yvlen < 0) + yu = -yvlen + else + yu = 0 + } + + # ------- XV, YV --------- + # Compute the offset from the center of a single character required + # to justify that character, given a particular character up vector. + # (This could be combined with the above case but is clearer if + # treated separately.) + + p = -DEGTORAD(orien) + cosv = cos(p) + sinv = sin(p) + + # Compute the rotated character in size X and Y. + xsize = abs ( cw * cosv + ch * sinv) + ysize = abs (-cw * sinv + ch * cosv) + + switch (TX_HJUSTIFY(tx)) { + case GT_CENTER: + xv = 0 + case GT_RIGHT: + xv = - (xsize / 2.0) + default: # GT_LEFT, GT_NORMAL + xv = xsize / 2 + } + + switch (TX_VJUSTIFY(tx)) { + case GT_CENTER: + yv = 0 + case GT_TOP: + yv = - (ysize / 2.0) + default: # GT_BOTTOM, GT_NORMAL + yv = ysize / 2 + } + + # ------- X0, Y0 --------- + # The center coordinates of the first character to be drawn are given + # by the reference position plus the string justification vector plus + # the character justification vector. + + x0 = xc + xu + xv + y0 = yc + yu + yv + + # The character drawing primitive requires the coordinates of the + # lower left corner of the character (irrespective of orientation). + # Compute the vector from the center of a character to the lower left + # corner of a character, rotate to the given orientation, and correct + # the starting coordinates by addition of this vector. + + p = - (cw / 2.0) + q = - (ch / 2.0) + + x0 = x0 + ( p * cosv + q * sinv) + y0 = y0 + (-p * sinv + q * cosv) + + # ------- POLYTEXT --------- + # Set the polytext flag. Polytext output is possible only if chars + # are to be drawn to the right with no extra spacing between chars. + + if (abs(dy) == 0 && dx == cw) + polytext = YES + else + polytext = NO +end + + +# STX_CHARS -- Get the character drawing parameters, i.e., the size of a +# character in X and Y and whether or not to use the hardware character +# generator. The decision whether or not to use the hardware character +# generator is based on the text attribute QUALITY, unless overridden by +# the g_hardchar switch in common (set explicitly in cursor mode or by a +# stdgraph task parameter). + +procedure stx_chars (tx, ch, cw, hwsz, hard, orien) + +pointer tx # pointer to text attribute structure +int ch, cw # character height, width, GKI coords +int hwsz # size index if hardware character +bool hard # use/dontuse hardware character generation +int orien # rotation angle of character (0=normal) + +int sz, quality +real txsize, aspect, q +int stg_txsize() +real ttygetr() +include "stdgraph.com" + +begin + sz = TX_SIZE(tx) + if (g_hardchar == 0) + quality = TX_QUALITY(tx) + else + quality = g_hardchar + hard = (quality != GT_MEDIUM && quality != GT_HIGH) + + # Get character size in GKI units. + if (hard) { + hwsz = stg_txsize (sz) + ch = SG_CHARHEIGHT(g_sg,hwsz) + cw = SG_CHARWIDTH (g_sg,hwsz) + + } else { + # If character generation is in software scale character sizes + # by the size of the size 1 hardware character. If the character + # is rotated correct for the device aspect ratio so that the + # character comes out the same size regardless of the orientation. + + txsize = GKI_UNPACKREAL(sz) + cw = SG_CHARWIDTH (g_sg,1) * txsize + ch = SG_CHARHEIGHT(g_sg,1) * txsize + + if (orien != 0) { + aspect = ttygetr (g_tty, "ar") + if (aspect > EPSILON && abs (aspect - 1.0) > .01) { + q = 1.0 + abs(sin(real(orien))) * (aspect - 1.0) + cw = cw / q + ch = ch * q + } + } + } +end diff --git a/sys/gio/stdgraph/stgtxqual.x b/sys/gio/stdgraph/stgtxqual.x new file mode 100644 index 00000000..122cf303 --- /dev/null +++ b/sys/gio/stdgraph/stgtxqual.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stdgraph.h" + +# STG_TXQUALITY -- Select the type of character generator to be used. If the +# selected flag value is 0 this decision will be deferred to the set text +# attribute instruction at runtime (default). + +procedure stg_txquality (quality) + +int quality # text generation quality flag +include "stdgraph.com" + +begin + g_hardchar = quality +end diff --git a/sys/gio/stdgraph/stgtxset.x b/sys/gio/stdgraph/stgtxset.x new file mode 100644 index 00000000..8db3e8c3 --- /dev/null +++ b/sys/gio/stdgraph/stgtxset.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "stdgraph.h" + +# STG_TXSET -- Set the text drawing attributes. + +procedure stg_txset (gki) + +short gki[ARB] # attribute structure +pointer tx +include "stdgraph.com" + +begin + tx = SG_TXAP(g_sg) + + TX_UP(tx) = gki[GKI_TXSET_UP] + TX_PATH(tx) = gki[GKI_TXSET_P ] + TX_HJUSTIFY(tx) = gki[GKI_TXSET_HJ] + TX_VJUSTIFY(tx) = gki[GKI_TXSET_VJ] + TX_FONT(tx) = gki[GKI_TXSET_F ] + TX_QUALITY(tx) = gki[GKI_TXSET_Q ] + TX_COLOR(tx) = gki[GKI_TXSET_CI] + + # Unpack the packed-real character spacing parameter. + TX_SPACING(tx) = GKI_UNPACKREAL (gki[GKI_TXSET_SP]) + + # The character size is left as a packed real as we must defer the + # decision to use a discreet hardware character size or to draw + # characters in software. + + TX_SIZE(tx) = gki[GKI_TXSET_SZ] +end diff --git a/sys/gio/stdgraph/stgtxsize.x b/sys/gio/stdgraph/stgtxsize.x new file mode 100644 index 00000000..71829e04 --- /dev/null +++ b/sys/gio/stdgraph/stgtxsize.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stdgraph.h" + +# STG_TXSIZE -- Given the relative character size as a packed real, select +# the discreet closest device character size. + +int procedure stg_txsize (pksize) + +int pksize # packed real relative character size +int i, best_size +real txsize, diff, least_diff +include "stdgraph.com" + +begin + txsize = GKI_UNPACKREAL (pksize) + + best_size = 1 + least_diff = abs (txsize - SG_CHARSIZE(g_sg,1)) + + do i = 2, SG_NCHARSIZES(g_sg) { + diff = abs (txsize - SG_CHARSIZE(g_sg,i)) + if (diff < least_diff) { + best_size = i + least_diff = diff + } + } + + return (best_size) +end diff --git a/sys/gio/stdgraph/stgunkown.x b/sys/gio/stdgraph/stgunkown.x new file mode 100644 index 00000000..55327b62 --- /dev/null +++ b/sys/gio/stdgraph/stgunkown.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# STG_UNKNOWN -- The unknown instruction. Called by the interpreter whenever +# an unrecognized opcode is encountered. Should never be called. + +procedure stg_unknown (gki) + +short gki[ARB] # the GKI instruction +int fd, verbose +common /stgcom/ fd, verbose + +begin + call fprintf (fd, "unknown\n") +end diff --git a/sys/gio/stdgraph/stgwtty.x b/sys/gio/stdgraph/stgwtty.x new file mode 100644 index 00000000..c01bd93c --- /dev/null +++ b/sys/gio/stdgraph/stgwtty.x @@ -0,0 +1,118 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "stdgraph.h" + +# STG_WRITETTY -- Write one or more lines of text to the terminal in text +# mode. If the workstation is currently activated normal output is to the +# status line, otherwise output is to the indicated stream (STDOUT or +# STDERR). If the worstation is activated and the text to be output is +# preceded by the EM code, the text is a message being sent by GIO to a user +# interface parameter, and the text is passed on as is without formatting for +# the status line. +# +# Terminal output is directed to the status line by the GD sequence, and +# graphics output is reenabled by the GE sequence. The output text should +# consist of only a single line, but if multiple lines are present they are +# output line by line, without the trailing newline, since the status line +# can display only a single line of text. +# +# NOTE - If output occurs while in graphics mode and the output text is newline +# terminated, the GE (graphics enable) sequence is output to restore the +# terminal to graphics mode before exiting. If the text is not newline +# terminated, e.g., if it is a prompt, the workstation is left in alpha mode, +# ready for a read from STDIN. Thus one can write a prompt to STDOUT and read +# the user response from STDIN, while in graphics mode. +# +# This procedure is called by pseudofile i/o (gio/cursor/prpsio) whenever a +# task writes to STDOUT or STDERR. + +procedure stg_writetty (fd, text, nchars) + +int fd #I output stream +char text[ARB] #I text to be output +int nchars #I nchars to be written + +int ip, delim +pointer sp, lbuf, op +include "stdgraph.com" +bool ttygetb() +errchk write + +begin + if (g_active == NO) { + # Workstation not activated (normal text mode); normal text output. + call write (fd, text, nchars) + call flush (fd) + + } else if (text[1] == EM || g_message == YES) { + # Workstation is activated; the output text is a message to be + # sent to a UI parameter. The output stream is assumed to be + # flushed before and after a UI message, so we assume that the + # control codes used to bracket the message are the first and + # last characters in the output write packets. Multiple writes + # may be used to write output text, and messages can be any + # length. If the output device does not support messaging (no + # "EM" capability) the messages are discarded. + + g_message = YES + if (ttygetb (g_tty, "EM")) + call write (g_out, text, nchars) + delim = text[nchars] + if (delim == GS || delim == US) + g_message = NO + + } else { + # Workstation is activated; write to status line. Writing + # anything when graphics is enabled causes the status line to be + # cleared; newline causes a graphics enable; the string "\n\n" + # will always clear the status line and leave the terminal in + # graphics mode, regardless of the state of g_enable when issued. + + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + if (g_enable == YES) + call stg_gdisab() + + op = lbuf + for (ip=1; ip <= nchars; ip=ip+1) { + if (text[ip] == '\n') { + if (g_enable == YES) + call stg_gdisab() + if (op > lbuf) + call write (g_out, Memc[lbuf], op-lbuf) + call stg_genab() + op = lbuf + } else { + Memc[op] = text[ip] + op = min (lbuf+SZ_LINE, op+1) + } + } + + # Output a partial line, leaving graphics disabled. + if (op > lbuf) { + if (g_enable == YES) + call stg_gdisab() + call write (g_out, Memc[lbuf], op-lbuf) + } + + call flush (g_out) + call sfree (sp) + } +end + + +# STG_PUTLINE -- Output an EOS delimited line of text to the graphics terminal +# with stg_writetty. + +procedure stg_putline (fd, text) + +int fd # output file +char text[ARB] # EOS delimited line of text +int strlen() + +begin + call stg_writetty (fd, text, strlen(text)) +end diff --git a/sys/gio/stdgraph/t_gkideco.x b/sys/gio/stdgraph/t_gkideco.x new file mode 100644 index 00000000..200cf33a --- /dev/null +++ b/sys/gio/stdgraph/t_gkideco.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GKIDECODE -- Decode the contents of one or more metacode files, printing +# the decoded metacode instructions in readable form on the standard output. + +procedure t_gkidecode() + +int fd, list, verbose, gkiunits +pointer gki, sp, fname +int dd[LEN_GKIDD] + +bool clgetb() +int clpopni(), clgfil(), clplen(), open(), btoi() +int gki_fetch_next_instruction() + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + # Open list of metafiles to be decoded. + list = clpopni ("input") + + if (clgetb ("generic")) { + verbose = NO + gkiunits = NO + } else { + verbose = btoi (clgetb ("verbose")) + gkiunits = btoi (clgetb ("gkiunits")) + } + + # Set up the decoding graphics kernel. + call gkp_install (dd, STDOUT, verbose, gkiunits) + + # Process a list of metacode files, writing the decoded metacode + # instructions on the standard output. + + while (clgfil (list, Memc[fname], SZ_FNAME) != EOF) { + # Print header if new file. + if (clplen (list) > 1) { + call printf ("\n# METAFILE '%s':\n") + call pargstr (Memc[fname]) + } + + # Open input file. + iferr (fd = open (Memc[fname], READ_ONLY, BINARY_FILE)) { + call erract (EA_WARN) + next + } else + call gkp_grstream (fd) + + # Process the metacode. + while (gki_fetch_next_instruction (fd, gki) != EOF) + call gki_execute (Mems[gki], dd) + + call close (fd) + } + + call clpcls (list) + call sfree (sp) +end diff --git a/sys/gio/stdgraph/t_showcap.x b/sys/gio/stdgraph/t_showcap.x new file mode 100644 index 00000000..ddb8407c --- /dev/null +++ b/sys/gio/stdgraph/t_showcap.x @@ -0,0 +1,210 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stdgraph.h" + +define SZ_PROGRAM 256 +define MAXARGSTR 15 + + +# SHOWCAP - Show the ascii control string sent to a device to implement a +# control function. Useful for testing graphcap entries. + +procedure t_showcap() + +char cap[2] +int g_reg[NREGISTERS] +char g_mem[SZ_MEMORY] +char argstr[MAXARGSTR] +int arg1, arg2, arg3, op, len_prog, status, nchars +pointer tty, sp, prog, ip, cmd +pointer ttygdes(), ttycaps() +int stg_encode(), ctoi(), getline(), strncmp() +int ttygets(), ctowrd(), strlen() +bool ttygetb(), streq() +define getargs_ 91 + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (prog, SZ_PROGRAM, TY_CHAR) + + # Print instructions. + call printf ("cmd : `set' device\n") + call printf (" | `*' (to dump full graphcap entry\n") + call printf (" | cc [arg1 [arg2 [arg3]]]\n") + call printf (" ;\n") + call printf ("\n") + call printf ("cc : a two chararacter capcode (e.g., 'cm')\n") + call printf (" | an encoder program (non alpha first char)\n") + call printf (" ;\n") + call printf ("\n") + + # Interpret and translate control commands until EOF or "bye" + # is typed. + + tty = NULL + + repeat { + # Prompt for input. + call printf ("* ") + call flush (STDOUT) + + if (getline (STDIN, Memc[cmd]) == EOF) { + call printf ("\n") + break + } + + for (ip=cmd; IS_WHITE (Memc[ip]); ip=ip+1) + ; + + if (Memc[ip] == '\n') { + next + } else if (strncmp (Memc[ip], "set", 3) == 0) { + ip = ip + 3 + len_prog = ctowrd (Memc, ip, Memc[prog], SZ_PROGRAM) + if (tty != NULL) + call ttycdes (tty) + tty = ttygdes (Memc[prog]) + call sgc_dump (STDOUT, Memc[ttycaps(tty)], + strlen (Memc[ttycaps(tty)])) + next + } else if (Memc[ip] == '*') { + call sgc_dump (STDOUT, Memc[ttycaps(tty)], + strlen (Memc[ttycaps(tty)])) + next + } else if (!IS_ALPHA (Memc[ip])) { + len_prog = ctowrd (Memc, ip, Memc[prog], SZ_PROGRAM) + cap[1] = EOS + goto getargs_ + } else if (strncmp (Memc[ip], "bye", 3) == 0) + break + + # Parse command with optional arguments, e.g., "RC 1". + # Extract 2 character capability name (required). + + op = 1 + while (IS_ALNUM(Memc[ip])) { + cap[op] = Memc[ip] + ip = ip + 1 + op = min (2, op + 1) + } + cap[3] = EOS +getargs_ + # Argument type depends on whether encoding or decoding. + if (streq ("SC", cap)) { + nchars = ctowrd (Memc, ip, argstr, MAXARGSTR) + if (nchars == 0) { + call printf ("SC must have 1 contiguous string argument\n") + next + } + + } else { + # Extract up to three arguments (optional). + if (ctoi (Memc, ip, arg1) <= 0) + arg1 = 0 + if (ctoi (Memc, ip, arg2) <= 0) + arg2 = 0 + if (ctoi (Memc, ip, arg3) <= 0) + arg3 = 0 + } + + # Fetch the program from the graphcap file. Zero is returned if + # the device does not have the named capability, in which case + # the function is inapplicable and should be ignored. + + if (cap[1] != EOS) + if (tty == NULL) { + call printf ("use `set' to specify device name\n") + next + } else + len_prog = ttygets (tty, cap, Memc[prog], SZ_PROGRAM) + + if (len_prog > 0) { + if (Memc[prog] == '#') + call sgc_dump (STDOUT, Memc[prog+1], len_prog - 1) + else { + # Dump the program on the standard output. + if (cap[1] != EOS) { + call printf ("program: ") + call sgc_dump (STDOUT, Memc[prog], len_prog) + } + + # Set memory or registers depending on whether encoding or + # decoding. + if (streq ("SC", cap)) + call strcpy (argstr, g_mem, nchars) + + else { + g_reg[1] = arg1 + g_reg[2] = arg2 + g_reg[3] = arg3 + } + g_reg[E_IOP] = 1 + g_reg[E_TOP] = SZ_MEMORY + + # If scan_cursor, decode the input string and write the + # registers to the output file. Else, encode the output + # string and write the encoded string to the output file. + + status = stg_encode (Memc[prog], g_mem, g_reg) + if (status == OK) { + nchars = g_reg[E_IOP] - 1 + + if (streq ("SC", cap)) { + call printf ("X(R1)=%d, Y(R2)=%d, key=%c\n") + call pargi (g_reg[1]) + call pargi (g_reg[2]) + call pargi (g_reg[3]) + } else { + call printf ("encoding: ") + call sgc_dump (STDOUT, g_mem, nchars) + } + + } else + call printf ("error encoding control string\n") + call printf (" status = %d\n") + call pargi (status) + } + + } else if (len_prog == 0) + if (ttygetb (tty, cap)) + call printf ("boolean capability is true\n") + + else { + call printf ("device capability `%s' not found\n") + call pargstr (cap) + } + } + + if (tty != NULL) + call ttycdes (tty) + call sfree (sp) +end + + +# SGC_DUMP -- Dump a sequence of ascii characters in printable form. + +procedure sgc_dump (fd, data, nchars) + +int fd # output file +char data[ARB] # chars to be dumped +int nchars + +int ip +int col + +begin + col = 1 + for (ip=1; ip <= nchars; ip=ip+1) { + call putcc (fd, data[ip]) + if (data[ip] == ':' && col > 60) { + call putci (fd, '\\') + call putci (fd, '\n') + col = 1 + } else + col = col + 1 + } + + call putci (fd, '\n') +end diff --git a/sys/gio/stdgraph/t_stdgraph.x b/sys/gio/stdgraph/t_stdgraph.x new file mode 100644 index 00000000..8d6856fc --- /dev/null +++ b/sys/gio/stdgraph/t_stdgraph.x @@ -0,0 +1,110 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +define SZ_TXQUALITY 1 + +# STDGRAPH -- Graphics kernel for the standard graphics output (interactive +# graphics terminal). + +procedure t_stdgraph() + +int fd, list +char txquality[SZ_TXQUALITY] +pointer gki, sp, fname, devname +int dev[LEN_GKIDD], deb[LEN_GKIDD] +int debug, verbose, gkiunits, xres, yres, quality +bool clgetb() +int clpopni(), clgfil(), open(), btoi(), clgeti() +int gki_fetch_next_instruction() + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (devname, SZ_FNAME, TY_CHAR) + + # Open list of metafiles to be decoded. + list = clpopni ("input") + + # Get parameters. + call clgstr ("device", Memc[devname], SZ_FNAME) + + if (clgetb ("generic")) { + debug = NO + verbose = NO + gkiunits = NO + quality = 0 + xres = 0 + yres = 0 + + } else { + debug = btoi (clgetb ("debug")) + if (debug == YES) { + verbose = btoi (clgetb ("verbose")) + gkiunits = btoi (clgetb ("gkiunits")) + } + + # Get the quality parameter for the text generator. + call clgstr ("txquality", txquality, SZ_TXQUALITY) + switch (txquality[1]) { + case 'l': + quality = GT_LOW + case 'm': + quality = GT_MEDIUM + case 'h': + quality = GT_HIGH + default: + quality = 0 + } + + xres = clgeti ("xres") + yres = clgeti ("yres") + } + + # Open the graphics kernel. + + call stg_open (Memc[devname], dev, STDIN, STDOUT, xres, yres, quality) + call gkp_install (deb, STDERR, verbose, gkiunits) + + # Process a list of metacode files, writing the decoded metacode + # instructions on the standard output. + + while (clgfil (list, Memc[fname], SZ_FNAME) != EOF) { + # Open input file. + iferr (fd = open (Memc[fname], READ_ONLY, BINARY_FILE)) { + call erract (EA_WARN) + next + } else + call stg_grstream (fd) + + # Process the metacode instruction stream. + while (gki_fetch_next_instruction (fd, gki) != EOF) + switch (Mems[gki+GKI_HDR_OPCODE-1]) { + case GKI_CLOSEWS, GKI_DEACTIVATEWS, GKI_REACTIVATEWS: + # These instructions are passed directly to the kernel via + # the PSIOCTRL stream at runtime, but are ignored in + # metacode to avoid unnecessary mode switching of the + # terminal. + ; + default: + if (debug == YES) + call gki_execute (Mems[gki], deb) + call gki_execute (Mems[gki], dev) + } + + call close (fd) + } + + # Make sure we finish with CLOSEWS so that the terminal is left in + # text mode. + + call stg_closews (NULL, NULL) + + # Finish up. + call gkp_close() + call stg_close() + call clpcls (list) + call sfree (sp) +end diff --git a/sys/gio/stdgraph/x_stdgraph.x b/sys/gio/stdgraph/x_stdgraph.x new file mode 100644 index 00000000..37c5a055 --- /dev/null +++ b/sys/gio/stdgraph/x_stdgraph.x @@ -0,0 +1,5 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +task gkidecode = t_gkidecode, + stdgraph = t_stdgraph, + showcap = t_showcap diff --git a/sys/gio/stdgraph/zzdebug.x b/sys/gio/stdgraph/zzdebug.x new file mode 100644 index 00000000..ce11d4ea --- /dev/null +++ b/sys/gio/stdgraph/zzdebug.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +task slio = t_slio + +procedure t_slio() + +pointer gp +char lbuf[SZ_LINE] +real x[5], y[5] + +pointer gopen() +int getline() + +begin + x[1] = .25; y[1] = .25 + x[2] = .75; y[2] = .25 + x[3] = .75; y[3] = .75 + x[4] = .25; y[4] = .75 + x[5] = .25; y[5] = .25 + + gp = gopen ("stdgraph", NEW_FILE, STDGRAPH) + call gpline (gp, x, y, 5) + call gflush (gp) + + call putline (STDOUT, "enter text: ") + call flush (STDOUT) + + if (getline (STDIN, lbuf) != EOF) { + call zwmsec (3000) + call printf ("text = %s") + call pargstr (lbuf) + call flush (STDOUT) + } + + call zwmsec (3000) + call gclose (gp) +end diff --git a/sys/gio/wcstogki.x b/sys/gio/wcstogki.x new file mode 100644 index 00000000..e0591402 --- /dev/null +++ b/sys/gio/wcstogki.x @@ -0,0 +1,61 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GPL_WCSTOGKI -- Transform world coordinates to GKI coordinates using the +# cached transformation parameters. There are three possible types of scaling +# on either axis, linear, log, and "elog". The latter is a piecewise log +# scaling function defined for all X, i.e., for negative as well as positive +# X (see elogr.x). If a negative number is transformed with normal log +# scaling it is treated as an indefinite, i.e., plotted as a gap in the plot. + +procedure gpl_wcstogki (gp, wx, wy, mx, my) + +pointer gp # graphics device descriptor +real wx, wy # world coordinates of point +real mx, my # metacode coordinates of point + +real x, y +real elogr() +include "gpl.com" + +begin + # Update cached transformation parameters if device changes, cache + # has been invalidated, or the current WCS has been changed. + + if (gp != gp_out || GP_WCS(gp) != wcs) + call gpl_cache (gp) + + # Transform the coordinates. + + if (xtran == LINEAR) { + x = wx + } else if (xtran == LOG) { + if (wx <= 0) { + call gpl_flush() + return + } else + x = log10 (wx) + } else + x = elogr (wx) + + if (ytran == LINEAR) { + y = wy + } else if (ytran == LOG) { + if (wy <= 0) { + call gpl_flush() + return + } else + y = log10 (wy) + } else + y = elogr (wy) + + # Return real rather than int GKI coordinates to avoid digitization + # errors in a sequence of draws relative to the current pen position. + + mx = max (0.0, min (real(GKI_MAXNDC), + ((x - wxorigin) * xscale) + mxorigin)) + my = max (0.0, min (real(GKI_MAXNDC), + ((y - wyorigin) * yscale) + myorigin)) +end diff --git a/sys/gio/zzdebug.x b/sys/gio/zzdebug.x new file mode 100644 index 00000000..e806ee23 --- /dev/null +++ b/sys/gio/zzdebug.x @@ -0,0 +1,392 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +define MAXPTS 20 + +task plot1, plot2, plot3, plot4, plot5, plot6, plot7, plot8, + balls, ticks, vdm + + +procedure plot1() + +real v[5] +int i +int fd, open() +pointer gp, gopen() + +begin + do i = 1, 5 + v[i] = i ** 2 + + # iferr (call delete ("x_mc")) + # ; + # fd = open ("x_mc", NEW_FILE, BINARY_FILE) + fd = STDGRAPH + gp = gopen ("stdgraph", NEW_FILE, fd) + + call gswind (gp, 1., 5., INDEF, INDEF) + call gascale (gp, v, 5, 2) + call glabax (gp, "Y = X ** 2", "X-AXIS", "Y-AXIS") + call gvline (gp, v, 5, 1., 5.) + + call gclose (gp) + call close (fd) +end + + +procedure plot2() + +int i +real x[512], y[512] +real xc, yc, xs, ys +int fd, open() +pointer gp, gopen() + +begin + do i = 1, 512 { + x[i] = ((i - 256.0) / 16.) + if (abs(x[i]) < EPSILON) + y[i] = 1.0 + else + y[i] = sin (x[i]) / x[i] + } + + # iferr (call delete ("x_mc")) + # ; + # fd = open ("x_mc", NEW_FILE, BINARY_FILE) + fd = STDGRAPH + gp = gopen ("stdgraph", NEW_FILE, fd) + + call gascale (gp, x, 512, 1) + call gascale (gp, y, 512, 2) + call glabax (gp, "The SINC Function", "X-AXIS", "Y-AXIS") + call gpline (gp, x, y, 512) + + xc = 8 + yc = .25 + xs = 3.2 + ys = 0.1 + + do i = 1, 10 { + call gmark (gp, xc, yc, GM_CIRCLE, -xs, -ys) + xc = xc + xs / 5 + yc = yc + ys / 5 + xs = xs * 1.25 + ys = ys * 1.5 + } + + call gclose (gp) + call close (fd) +end + + +procedure plot3() + +int i +real x[512], y[512] +int fd, open() +pointer gp, gopen() + +begin + do i = 1, 512 { + x[i] = ((i - 256.0) / 8.) + if (abs(x[i]) < EPSILON) + y[i] = 1.0 + else + y[i] = sin (x[i]) / x[i] + } + + # iferr (call delete ("x_mc")) + # ; + # fd = open ("x_mc", NEW_FILE, BINARY_FILE) + fd = STDGRAPH + gp = gopen ("stdgraph", NEW_FILE, fd) + + call gseti (gp, G_DRAWGRID, YES) + call gascale (gp, x, 512, 1) + call gascale (gp, y, 512, 2) + call glabax (gp, "The SINC Function", "X-AXIS", "Y-AXIS") + call gpline (gp, x, y, 512) + + call gclose (gp) + call close (fd) +end + + +procedure plot4() + +int i +real x[512], y[512] +int fd, open() +pointer gp, gopen() + +begin + do i = 1, 512 { + x[i] = (i - 256.0) / 4. + if (abs(x[i]) < EPSILON) + y[i] = 2.0 * 1E4 + else + y[i] = (sin (x[i]) / x[i] + 1.0) * 1E4 + } + + # iferr (call delete ("x_mc")) + # ; + # fd = open ("x_mc", NEW_FILE, BINARY_FILE) + fd = STDGRAPH + gp = gopen ("stdgraph", NEW_FILE, fd) + + call gseti (gp, G_YTRAN, GW_LOG) + call gascale (gp, x, 512, 1) + call gascale (gp, y, 512, 2) + call glabax (gp, "Log of The SINC Function", "X-AXIS", "Y-AXIS") + call gpline (gp, x, y, 512) + + call gclose (gp) + call close (fd) +end + + +procedure plot5() + +int fd +int open(), clgeti() +real x1, x2, clgetr() +pointer gp, gopen() + +begin + # iferr (call delete ("x_mc")) + # ; + # fd = open ("x_mc", NEW_FILE, BINARY_FILE) + fd = STDGRAPH + gp = gopen ("stdgraph", NEW_FILE, fd) + + x1 = clgetr ("x1") + x2 = clgetr ("x2") + + call gseti (gp, G_NMINOR, clgeti ("nminor")) + call gseti (gp, G_XTRAN, GW_LOG) + call gseti (gp, G_YTRAN, GW_LOG) + call gsetr (gp, G_MINORWIDTH, 1.0) + call gswind (gp, x1, x2, 0.001, 1000.0) + call glabax (gp, "Log Scaling", "X-AXIS", "Y-AXIS") + + call gclose (gp) + call close (fd) +end + + +procedure plot6() + +int i +long seed +real size, urand() +int fd, open(), clgeti() +pointer gp, gopen() +data seed /3/ + +begin + # iferr (call delete ("x_mc")) + # ; + # fd = open ("x_mc", NEW_FILE, BINARY_FILE) + fd = STDGRAPH + gp = gopen ("stdgraph", NEW_FILE, fd) + + call gseti (gp, G_ASPECT, clgeti("aspect")) + call glabax (gp, "", "", "") + + do i = 1, 300 { + size = real (nint (urand(seed) * 4 + .5)) + call gmark (gp, urand(seed), urand(seed), GM_BOX, size, size) + } + + call gclose (gp) + call close (fd) +end + + +procedure plot7() + +int i +real x[8192], y[8192] +int fd, open() +pointer gp, gopen() + +begin + do i = 1, 8192 { + x[i] = ((i - 4096.0) / 128.) + if (abs(x[i]) < EPSILON) + y[i] = 1.0 + else + y[i] = sin (x[i]) / x[i] + y[i] = y[i] + cos ((i-1) * 0.392699) * .001 + } + + # iferr (call delete ("x_mc")) + # ; + # fd = open ("x_mc", NEW_FILE, BINARY_FILE) + fd = STDGRAPH + gp = gopen ("stdgraph", NEW_FILE, fd) + + call gseti (gp, G_DRAWGRID, YES) + call gascale (gp, x, 8192, 1) + call gascale (gp, y, 8192, 2) + call glabax (gp, "The SINC Function", "X-AXIS", "Y-AXIS") + call gpline (gp, x, y, 8192) + + call gclose (gp) + call close (fd) +end + + +procedure balls() + +int i, j, m, npts, nsteps +long seed +real p[MAXPTS,2], d[MAXPTS,2] +real urand() +int fd, open(), clgeti() +pointer gp, gopen() + +begin + npts = max(1, min(MAXPTS, clgeti ("npoints"))) + nsteps = max (10, clgeti ("nsteps")) + + # iferr (call delete ("x_mc")) + # ; + # fd = open ("x_mc", NEW_FILE, BINARY_FILE) + fd = STDGRAPH + gp = gopen ("stdgraph", NEW_FILE, fd) + + # call glabax (gp, "Bouncing Balls", "", "") + + # Set the initial conditions. + do i = 1, npts + do j = 1, 2 { + p[i,j] = urand (seed) + d[i,j] = max (0.01, urand (seed) * .1) + if (mod (i, 2) == 0) + d[i,j] = -d[i,j] + } + + # Draw the trajectories. + do m = 1, nsteps + do i = 1, npts { + call gseti (gp, G_PMLTYPE, GL_CLEAR) + call gmark (gp, p[i,1], p[i,2], GM_DIAMOND, 4., 4.) + + do j = 1, 2 { + p[i,j] = p[i,j] + d[i,j] + if (p[i,j] < 0) { + p[i,j] = -p[i,j] + d[i,j] = -d[i,j] + } else if (p[i,j] > 1) { + p[i,j] = 1 - (p[i,j] - 1) + d[i,j] = -d[i,j] + } + } + + call gseti (gp, G_PMLTYPE, GL_SOLID) + call gmark (gp, p[i,1], p[i,2], GM_DIAMOND, 4., 4.) + + call gflush (gp) + } + + call gclose (gp) + call close (fd) +end + + +procedure ticks() + +real x1, x2, p1, p2 +int rough_nticks +int logflag +real tick1, step, linearity + +bool clgetb() +int btoi(), clgeti() +real gt_linearity(), clgetr(), elogr() + +begin + x1 = clgetr ("x1") + x2 = clgetr ("x2") + rough_nticks = clgeti ("nticks") + logflag = btoi (clgetb ("log")) + + if (logflag == YES) { + p1 = elogr (x1) + p2 = elogr (x2) + } else { + p1 = x1 + p2 = x2 + } + + linearity = gt_linearity (x1, x2) + call gtickr (p1, p2, rough_nticks, logflag, tick1, step) + + call printf ("tick1=%g, step=%g, linearity=%g\n") + call pargr (tick1) + call pargr (step) + call pargr (linearity) +end + + +procedure plot8() + +int i +real x[512], y[512] +int fd +pointer gp, gopen() + +begin + do i = 1, 512 { + x[i] = ((i - 256.0) / 8.) + if (abs(x[i]) < EPSILON) + y[i] = 1.0 + else + y[i] = sin (x[i]) / x[i] + } + + fd = STDGRAPH + gp = gopen ("stdgraph", NEW_FILE, fd) + + call gseti (gp, G_DRAWAXES, 1) + call gseti (gp, G_SETAXISPOS, YES) + call gsetr (gp, G_AXISPOS1, 0.0) + + call gseti (gp, G_DRAWGRID, YES) + call gascale (gp, x, 512, 1) + call gascale (gp, y, 512, 2) + call glabax (gp, "", "", "") + call gpline (gp, x, y, 512) + call gtext (gp, -20., 0.80, "The Sinc Function", "hj=c,vj=b") + call gtext (gp, -20., 0.75, "y = sin(x) / x", "hj=c,vj=b") + + call gclose (gp) + call close (fd) +end + + +# VDM -- Test output of a plot to the virtual device metafile. + +procedure vdm() + +real v[5] +int i +pointer gp, gopen() + +begin + do i = 1, 5 + v[i] = i ** 2 + + gp = gopen ("vdm", NEW_FILE, STDGRAPH) + + call gswind (gp, 1., 5., INDEF, INDEF) + call gascale (gp, v, 5, 2) + call glabax (gp, "Y = X ** 2", "X-AXIS", "Y-AXIS") + call gvline (gp, v, 5, 1., 5.) + + call gclose (gp) +end diff --git a/sys/gty/README b/sys/gty/README new file mode 100644 index 00000000..6687b5ce --- /dev/null +++ b/sys/gty/README @@ -0,0 +1,8 @@ +# GTY -- This directory contains the generalized termcap style database +# reader. Adapted from iraf$sys/tty/. + + gty = gtyopen (termcap_file, device, ufields) + gtyclose (gty) + cp = gtycaps (gty) + pval = gtyget[bir] (gty, cap) + nchars = gtygets (gty, cap, outstr, maxch) diff --git a/sys/gty/gty.h b/sys/gty/gty.h new file mode 100644 index 00000000..72516859 --- /dev/null +++ b/sys/gty/gty.h @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GTY package definitions. + +define MAX_TC_NESTING 8 # max nesting of tc=term references + +# Mapping function used to map capcodes ("cm", etc.) into unique integers. +define ENCODE ($1[1]*128+$1[2]) + +# TTY descriptor structure. Full termcap entry is the 'caplist' string. +# The caplist is indexed at open time to permit a binary search for +# capabilities at run time. + +define T_MEMINCR 512 # increment if overflow occurs +define T_OFFCAP 415 # struct offset to caplist field +define MAX_CAPS 200 # maximum capabilities +define LEN_DEFTTY 1024 # initial length of tty structure + +define T_LEN Memi[$1] # length of tty structure +define T_OP Memi[$1+1] # offset into caplist +define T_NCAPS Memi[$1+11] # number of capabilities +define T_CAPLEN Memi[$1+12] # length of caplist, chars + # (extra space) +define T_CAPCODE Memi[$1+15] # cap code array: c1*128+c2 +define T_CAPINDEX Memi[$1+215] # cap index array +define T_CAPLIST Memc[P2C($1+415)] # termcap entry diff --git a/sys/gty/gtycaps.x b/sys/gty/gtycaps.x new file mode 100644 index 00000000..ad9b4828 --- /dev/null +++ b/sys/gty/gtycaps.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gty.h" + +# GTYCAPS -- Return a pointer to the caplist field of an open GTY descriptor. + +pointer procedure gtycaps (gty) + +pointer gty # tty descriptor + +begin + return (P2C (gty + T_OFFCAP)) +end diff --git a/sys/gty/gtyclose.x b/sys/gty/gtyclose.x new file mode 100644 index 00000000..c8ddd67d --- /dev/null +++ b/sys/gty/gtyclose.x @@ -0,0 +1,11 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GTYCLOSE -- Close the tty terminal descriptor opened with TTYOPEN. + +procedure gtyclose (tty) + +pointer tty + +begin + call mfree (tty, TY_STRUCT) +end diff --git a/sys/gty/gtygetb.x b/sys/gty/gtygetb.x new file mode 100644 index 00000000..53d5f31e --- /dev/null +++ b/sys/gty/gtygetb.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GTYGETB -- Determine whether or not a capability exists for a device. +# If there is any entry at all, the capability exists. + +bool procedure gtygetb (tty, cap) + +pointer tty # tty descriptor +char cap[ARB] # two character capability name +pointer ip +int gty_find_capability() + +begin + return (gty_find_capability (tty, cap, ip) == YES) +end diff --git a/sys/gty/gtygeti.x b/sys/gty/gtygeti.x new file mode 100644 index 00000000..9b196a7e --- /dev/null +++ b/sys/gty/gtygeti.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GTYGETI -- Get an integer valued capability. If the capability is not +# found for the device, or cannot be interpreted as an integer, zero is +# returned. Integer capabilities have the format ":xx#dd:". + +int procedure gtygeti (tty, cap) + +pointer tty # tty descriptor +char cap[ARB] # two character capability name +int ival +pointer ip +int gty_find_capability(), ctoi() + +begin + if (gty_find_capability (tty, cap, ip) == NO) + return (0) + else if (Memc[ip] != '#') + return (0) + else { + ip = ip + 1 # skip the '#' + if (ctoi (Memc, ip, ival) == 0) + return (0) + else + return (ival) + } +end diff --git a/sys/gty/gtygetr.x b/sys/gty/gtygetr.x new file mode 100644 index 00000000..fb50f3e0 --- /dev/null +++ b/sys/gty/gtygetr.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GTYGETR -- Get a real valued capability. If the capability is not +# found for the device, or cannot be interpreted as a number, zero is +# returned. Real valued capabilities have the format ":xx#num:". + +real procedure gtygetr (tty, cap) + +pointer tty # tty descriptor +char cap[ARB] # two character capability name + +char numstr[MAX_DIGITS] +int np, op +pointer ip +double dval +int gty_find_capability(), ctod() + +begin + if (gty_find_capability (tty, cap, ip) == NO) + return (0.0) + else if (Memc[ip] != '#') + return (0.0) + else { + # Extract the number into numstr. Cannot convert in place in + # the table because the ":" delimiter will by interpreted by + # ctod as for a sexagesimal number. + op = 1 + for (ip=ip+1; op <= MAX_DIGITS && Memc[ip] != ':'; ip=ip+1) { + numstr[op] = Memc[ip] + op = op + 1 + } + numstr[op] = EOS + np = 1 + if (ctod (numstr, np, dval) == 0) + return (0.0) + else + return (dval) + } +end diff --git a/sys/gty/gtygets.x b/sys/gty/gtygets.x new file mode 100644 index 00000000..1f66cf88 --- /dev/null +++ b/sys/gty/gtygets.x @@ -0,0 +1,70 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# GTYGETS -- Get the string value of a capability. Process all termcap escapes. +# These are: +# +# \E ascii esc (escape) +# ^X control-X (i.e., ^C=03B, ^Z=032B, etc.) +# \[nrtbf] newline, return, tab, backspace, formfeed +# \ddd octal value of character +# \^ the character ^ +# \\ the character \ +# +# The character ':' may not be placed directly in a capability string; it +# should be given as \072 instead. The null character is represented as \200; +# all characters are masked to 7 bits upon output by TTYPUTS, hence \200 +# is sent to the terminal as NUL. + +int procedure gtygets (tty, cap, outstr, maxch) + +pointer tty # tty descriptor +char cap[ARB] # two character capability name +char outstr[ARB] # receives cap string +int maxch # size of outstr + +char ch +pointer ip +int op, junk, temp +int gty_find_capability(), cctoc() + +begin + op = 1 + + if (gty_find_capability (tty, cap, ip) == YES) { + # Skip the '=' which follows the two character capability name. + if (Memc[ip] == '=') + ip = ip + 1 + + # Extract the string, processing all escapes. + for (ch=Memc[ip]; ch != ':'; ch=Memc[ip]) { + if (ch == '^') { + ip = ip + 1 + temp = Memc[ip] + ch = mod (temp, 40B) + } else if (ch == '\\') { + switch (Memc[ip+1]) { + case 'E': + ip = ip + 1 + ch = ESC + case '^', ':', '\\': + ip = ip + 1 + ch = Memc[ip] + default: + junk = cctoc (Memc, ip, ch) + ip = ip - 1 + } + } + + outstr[op] = ch + op = op + 1 + ip = ip + 1 + if (op >= maxch) + break + } + } + + outstr[op] = EOS + return (op-1) +end diff --git a/sys/gty/gtyindex.x b/sys/gty/gtyindex.x new file mode 100644 index 00000000..b91456ca --- /dev/null +++ b/sys/gty/gtyindex.x @@ -0,0 +1,167 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "gty.h" + +# GTY_INDEX_CAPS -- Prepare an index into the caplist string, stored in +# the tty descriptor. Each two character capability name maps into a unique +# integer code, called the capcode. We prepare a list of capcodes, keeping +# only the first such code encountered in the case of multiple entries. +# The offset of the capability in the caplist string is associated with each +# capcode. When these lists have been prepared, they are sorted to permit +# a binary search for capabilities at runtime. + +procedure gty_index_caps (tty, t_capcode, t_capindex, ncaps) + +pointer tty +int t_capcode[ARB], t_capindex[ARB] +int ncaps + +pointer ip, caplist +int i, swap, capcode, temp +int gty_encode_capability() +pointer coerce() +errchk syserr + +begin + caplist = coerce (tty + T_OFFCAP, TY_STRUCT, TY_CHAR) + ip = caplist + + # Scan the caplist and prepare the capcode and capindex lists. + for (ncaps=0; ncaps <= MAX_CAPS; ) { + # Advance to the next capability field. Normal exit occurs + # when ':' is followed immediately by EOS. + + while (Memc[ip] != ':' && Memc[ip] != EOS) + ip = ip + 1 + if (Memc[ip+1] == EOS || Memc[ip] == EOS) + break + + ip = ip + 1 # skip the ':' + capcode = gty_encode_capability (Memc[ip]) + + # Is the capcode already in the list? If not found, add it to + # the list. + for (i=1; i <= ncaps && t_capcode[i] != capcode; i=i+1) + ; + if (i > ncaps) { # not found + ncaps = ncaps + 1 + t_capcode[ncaps] = capcode + t_capindex[ncaps] = ip - caplist + 1 + } + } + + if (ncaps > MAX_CAPS) + call syserr (SYS_TTYOVFL) + + # A simple interchange sort is sufficient here, even though it would + # not be hard to interface to qsort. The longest termcap entries are + # about 50 caps, and the time req'd to sort such a short list is + # negligible compared to the time spent searching the termcap file. + + if (ncaps > 1) + repeat { + swap = 0 + do i = 1, ncaps-1 + if (t_capcode[i] > t_capcode[i+1]) { + temp = t_capcode[i] + t_capcode[i] = t_capcode[i+1] + t_capcode[i+1] = temp + temp = t_capindex[i] + t_capindex[i] = t_capindex[i+1] + t_capindex[i+1] = temp + swap = 1 + } + } until (swap == 0) +end + + +# GTY_FIND_CAPABILITY -- Search the caplist for the named capability. +# If found, return the char pointer IP to the first char of the value field, +# and YES as the function value. If the first char in the capability string +# is '@', the capability "is not present". + +int procedure gty_find_capability (tty, cap, ip) + +pointer tty # tty descriptor +char cap[ARB] # two character name of capability +pointer ip # pointer to capability string + +int capcode, capnum +int gty_binsearch(), gty_encode_capability() +pointer coerce() +errchk syserr + +begin + if (tty == NULL) + call syserr (SYS_TTYINVDES) + + capcode = gty_encode_capability (cap) + capnum = gty_binsearch (capcode, T_CAPCODE(tty), T_NCAPS(tty)) + + if (capnum > 0) { + # Add 2 to skip the two capname chars. + ip = coerce (tty + T_OFFCAP, TY_STRUCT, TY_CHAR) + + T_CAPINDEX(tty+capnum-1) - 1 + 2 + if (Memc[ip] != '@') + return (YES) + } + + return (NO) +end + + +# GTY_BINSEARCH -- Perform a binary search of the capcode array for the +# indicated capability. Return the array index of the capability if found, +# else zero. + +int procedure gty_binsearch (capcode, t_capcode, ncaps) + +int capcode +int t_capcode[ARB], ncaps +int low, high, pos, ntrips +define err_ 91 + +begin + pos = 0 + low = 1 + high = ncaps + if (high < low) + goto err_ + + # Cut range of search in half until code is found, or until range + # vanishes (high - low <= 1). If neither high or low is the one, + # code is not found in the list. + + do ntrips = 1, ncaps { + pos = (high - low) / 2 + low + if (t_capcode[low] == capcode) + return (low) + else if (t_capcode[high] == capcode) + return (high) + else if (pos == low) # (high-low)/2 == 0 + return (0) # not found + else if (t_capcode[pos] < capcode) + low = pos + else + high = pos + } + + # Search cannot fail to converge unless there is a bug in the software + # somewhere. +err_ + call syserr (SYS_TTYBINSRCH) +end + + +# GTY_ENCODE_CAPABILITY -- Encode the two character capability string +# as a unique integer value. + +int procedure gty_encode_capability (cap) + +char cap[ARB] + +begin + return (ENCODE(cap)) +end diff --git a/sys/gty/gtyopen.x b/sys/gty/gtyopen.x new file mode 100644 index 00000000..d566f2d1 --- /dev/null +++ b/sys/gty/gtyopen.x @@ -0,0 +1,305 @@ +include +include +include +include +include "gty.h" + +# GTYOPEN -- Scan the named TERMCAP style file for the entry for the named +# device, and if found allocate a TTY descriptor structure, leaving the +# termcap entry for the device in the descriptor. If any UFIELDS are given +# these will be prepended to the output device capability list, overriding +# the device file entries. If no termcap file is named (null string) then +# UFIELDS is taken as the device entry and opened on a GTY descriptor. + +pointer procedure gtyopen (termcap_file, device, ufields) + +char termcap_file[ARB] #I termcap file to be scanned +char device[ARB] #I name of device to be extracted +char ufields[ARB] #I user specified capabilities + +int nchars, ip +pointer caplist, tty, op +errchk calloc, realloc, gty_index_caps +pointer coerce() +int strlen() + +begin + # Allocate and initialize the tty descriptor structure. + call calloc (tty, LEN_DEFTTY, TY_STRUCT) + + T_LEN(tty) = LEN_DEFTTY + T_OP(tty) = 1 + + # Place any user specified capabilities in the caplist. These will + # override any values given in the file entry. + + for (ip=1; ufields[ip] != EOS && ufields[ip] != ':'; ip=ip+1) + ; + nchars = strlen (ufields[ip]) + if (nchars > 0) { + caplist = coerce (tty + T_OFFCAP, TY_STRUCT, TY_CHAR) + call strcpy (ufields[ip], Memc[caplist], T_LEN(tty) - T_OFFCAP) + op = caplist + nchars + if (Memc[op-1] == ':') + op = op - 1 + Memc[op] = EOS + T_OP(tty) = op - caplist + 1 + T_CAPLEN(tty) = T_OP(tty) + } + + # Scan the source file, if given. + if (termcap_file[1] != EOS) + iferr (call gty_scan_termcap_file (tty, termcap_file, device)) { + call mfree (tty, TY_STRUCT) + call erract (EA_ERROR) + } + + # Call realloc to return any unused space in the descriptor. + T_LEN(tty) = T_OFFCAP + (T_OP(tty) + SZ_STRUCT-1) / SZ_STRUCT + call realloc (tty, T_LEN(tty), TY_STRUCT) + + # Prepare index of fields in the descriptor, so that we can more + # efficiently search for fields later. + + call gty_index_caps (tty, T_CAPCODE(tty), T_CAPINDEX(tty), + T_NCAPS(tty)) + + return (tty) +end + + +# TTY_SCAN_TERMCAP_FILE -- Open and scan the named TERMCAP format database +# file for the named device. Fetch termcap entry, expanding any and all +# "tc" references by repeatedly rescanning file. + +procedure gty_scan_termcap_file (tty, termcap_file, devname) + +pointer tty # tty descriptor structure +char termcap_file[ARB] # termcap format file to be scanned +char devname[ARB] # termcap entry to be scanned for + +int fd, ntc +pointer sp, device, ip, op, caplist +int open(), strlen(), strncmp() +pointer coerce() +errchk open, syserrs + +begin + call smark (sp) + call salloc (device, SZ_FNAME, TY_CHAR) + + fd = open (termcap_file, READ_ONLY, TEXT_FILE) + call strcpy (devname, Memc[device], SZ_FNAME) + + ntc = 0 + repeat { + iferr (call gty_fetch_entry (fd, Memc[device], tty)) { + call close (fd) + call erract (EA_ERROR) + } + + # Back up to start of last field in entry. + caplist = coerce (tty + T_OFFCAP, TY_STRUCT, TY_CHAR) + ip = caplist + T_OP(tty)-1 - 2 + while (ip > caplist && Memc[ip] != ':') + ip = ip - 1 + + # If last field is "tc", backup op so that the tc field gets + # overwritten with the referenced entry. + + if (strncmp (Memc[ip+1], "tc", 2) == 0) { + # Check for recursive tc reference. + ntc = ntc + 1 + if (ntc > MAX_TC_NESTING) { + call close (fd) + call syserrs (SYS_TTYTC, Memc[device]) + } + + # Set op to point to the ":" in ":tc=file". + T_OP(tty) = ip - caplist + 1 + + # Get device name from tc field, and loop again to fetch new + # entry. + ip = ip + strlen (":tc=") + for (op=device; Memc[ip] != EOS && Memc[ip] != ':'; ip=ip+1) { + Memc[op] = Memc[ip] + op = op + 1 + } + Memc[op] = EOS + call seek (fd, BOFL) + } else + break + } + + call close (fd) + call sfree (sp) +end + + +# GTY_FETCH_ENTRY -- Search the termcap file for the named entry, then read +# the colon delimited capabilities list into the caplist field of the tty +# descriptor. If the caplist field fills up, allocate more space. + +procedure gty_fetch_entry (fd, device, tty) + +int fd +char device[ARB] +pointer tty + +char ch, lastch +bool device_found +pointer sp, ip, op, otop, lbuf, alias, caplist + +char getc() +bool streq() +pointer coerce() +int getline(), gty_extract_alias() +errchk getline, getc, realloc, salloc +define errtn_ 91 + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + call salloc (alias, SZ_FNAME, TY_CHAR) + + # Locate entry. First line of each termcap entry contains a list + # of aliases for the device. Only first lines and comment lines + # are left justified. + + repeat { + # Skip comment and continuation lines and blank lines. + device_found = false + + if (getc (fd, ch) == EOF) + goto errtn_ + + if (ch == '\n') { + # Skip a blank line. + next + } else if (ch == '#' || IS_WHITE (ch)) { + # Discard the rest of the line and continue. + if (getline (fd, Memc[lbuf]) == EOF) + goto errtn_ + next + } + + # Extract list of aliases. The first occurrence of ':' marks + # the end of the alias list and the beginning of the caplist. + + Memc[lbuf] = ch + op = lbuf + 1 + + for (; getc(fd,ch) != ':'; op=op+1) { + Memc[op] = ch + if (ch == EOF || ch == '\n') { + goto errtn_ + } + } + Memc[op] = EOS + + ip = lbuf + while (gty_extract_alias (Memc, ip, Memc[alias], SZ_FNAME) > 0) { + if (device[1] == EOS || streq (Memc[alias], device)) { + device_found = true + break + } else if (Memc[ip] == '|') + ip = ip + 1 # skip delimiter + } + + # Skip rest of line if no match. + if (!device_found) { + if (getline (fd, Memc[lbuf]) == EOF) { + goto errtn_ + } + } + } until (device_found) + + # Caplist begins at first ':'. Each line has some whitespace at the + # beginning which should be skipped. Escaped newline implies + # continuation. + + caplist = coerce (tty + T_OFFCAP, TY_STRUCT, TY_CHAR) + op = caplist + T_OP(tty) - 1 + otop = coerce (tty + T_LEN(tty), TY_STRUCT, TY_CHAR) + + # We are already positioned to the start of the caplist. + Memc[op] = ':' + op = op + 1 + lastch = ':' + + # Extract newline terminated caplist string. + while (getc (fd, ch) != EOF) { + if (ch == '\\') { # escaped newline? + if (getc (fd, ch) == '\n') { + while (getc (fd, ch) != EOF) + if (!IS_WHITE(ch)) + break + if (ch == EOF || ch == '\n') + goto errtn_ + # Avoid null entries ("::"). + if (ch == ':' && lastch == ':') + next + else + Memc[op] = ch + } else { # no, keep both chars + Memc[op] = '\\' + op = op + 1 + Memc[op] = ch + } + } else if (ch == '\n') { # normal exit + Memc[op] = EOS + T_OP(tty) = op - caplist + 1 + T_CAPLEN(tty) = T_OP(tty) + call sfree (sp) + return + } else + Memc[op] = ch + + # Increase size of buffer if necessary. Note that realloc may + # move the buffer, so we must recalculate op and otop. + + lastch = ch + op = op + 1 + if (op >= otop) { + T_OP(tty) = op - caplist + 1 + T_LEN(tty) = T_LEN(tty) + T_MEMINCR + call realloc (tty, T_LEN(tty), TY_STRUCT) + op = caplist + T_OP(tty) - 1 + otop = coerce (tty + T_LEN(tty), TY_STRUCT, TY_CHAR) + } + } + +errtn_ + call sfree (sp) + call syserrs (SYS_TTYDEVNF, device) +end + + +# GTY_EXTRACT_ALIAS -- Extract a device alias string from the header of +# a termcap entry. The alias string is terminated by '|' or ':'. Leave +# ip pointing at the delimiter. Return number of chars in alias string. + +int procedure gty_extract_alias (str, ip, outstr, maxch) + +char str[ARB] # first line of termcap entry +int ip # on input, first char of alias +char outstr[ARB] +int maxch + +char ch +int op + +begin + op = 1 + for (ch=str[ip]; ch != '|' && ch != ':' && ch != EOS; ch=str[ip]) { + outstr[op] = ch + op = min (maxch, op) + 1 + ip = ip + 1 + } + outstr[op] = EOS + + if (ch == EOS) + return (0) + else + return (op-1) +end diff --git a/sys/gty/mkpkg b/sys/gty/mkpkg new file mode 100644 index 00000000..20dff77f --- /dev/null +++ b/sys/gty/mkpkg @@ -0,0 +1,29 @@ +# Update the GTY portion of libsys.a. + +$checkout libsys.a lib$ +$update libsys.a +$checkin libsys.a lib$ +$exit + +zzdebug: + $checkout libsys.a lib$ + $update libsys.a + $checkin libsys.a lib$ + + #$set XFLAGS = "$(XFLAGS) -qx" + $omake zzdebug.x + $link -z zzdebug.o + ; + +libsys.a: + #$set XFLAGS = "$(XFLAGS) -qx" + + gtycaps.x gty.h + gtyclose.x + gtygetb.x + gtygeti.x + gtygetr.x + gtygets.x + gtyindex.x gty.h + gtyopen.x gty.h + ; diff --git a/sys/gty/zzdebug.x b/sys/gty/zzdebug.x new file mode 100644 index 00000000..c8171b4c --- /dev/null +++ b/sys/gty/zzdebug.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +task dump = t_dump + +# DUMP -- Dump a termcap (GTY) device entry. + +procedure t_dump() + +char fname[SZ_FNAME] +char device[SZ_FNAME] +char ufields[SZ_LINE] + +pointer gty +pointer gtyopen() +pointer gtycaps() + +begin + call clgstr ("fname", fname, SZ_FNAME) + call clgstr ("device", device, SZ_FNAME) + call clgstr ("ufields", ufields, SZ_LINE) + + gty = gtyopen (fname, device, ufields) + call printf ("%s\n") + call pargstr (Memc[gtycaps(gty)]) + call gtyclose (gty) +end diff --git a/sys/imfort/README b/sys/imfort/README new file mode 100644 index 00000000..f1fd0a60 --- /dev/null +++ b/sys/imfort/README @@ -0,0 +1,98 @@ + The IMFORT Interface + Doug Tody, September 1986 + + +1. INTRODUCTION + + The IMFORT interface is a host level Fortran programming environment for +IRAF. Fortran programs (or C programs) may be written at the host level +with full access to the facilities of the host environment, plus limited +access to the IRAF environment via the IMFORT interface. Such host level +programs may be interfaced to the IRAF CL as foreign tasks and called with +arguments on the command line, like ordinary IRAF tasks. + +The chief advantage of the IMFORT interface is that it allows existing host +Fortran programs to be interfaced to IRAF with minimum effort. The IMFORT +interface also provides a way for the scientist-user to extend the IRAF +environment with their own programs, without need to learn to use the much +more complex IRAF VOS programming environment. Of course, the VOS is a much +more powerful environment and VOS programs tend to be much more portable than +host Fortran programs, so the VOS environment should be used for large +programming projects. + +The IMFORT interface is described in detail in the document "A User's Guide +to Fortran Programming in the IRAF Environment". A summary of the interface +procedures follows. The IMFORT routines make use of the IRAF kernel for all +i/o, and of the FMTIO and VOPS packages for miscellaneous functions, hence +programs using IMFORT must be linked with LIBSYS, LIBVOPS, and LIBOS. + + +2. INTERFACE PROCEDURES + +2.1 COMMAND LINE ACCESS + + clnarg (nargs) + clrawc (outstr, ier) + clarg[cird] (argno, [cird]val, ier) + + +2.2 IMAGE ACCESS + +2.2.1 General + + imopen (f77nam, acmode, im, ier) + imopnc (nimage, o_im, n_im, ier) + imcrea (f77nam, axlen, naxis, pixtype, ier) + imclos (im, ier) + + imflsh (im, ier) + imgsiz (im, axlen, naxis, pixtype, ier) + imhcpy (o_im, n_im, ier) + impixf (im, pixfd, pixfil, pixoff, szline, ier) + + imemsg (ier, errmsg) + + +2.2.2 Image Header Keyword Access + + imacck (im, keyw) + imaddk (im, keyw, dtype, comm, ier) + imdelk (im, keyw, ier) + imtypk (im, keyw, dtype, comm, ier) + + imakw[bcdir] (im, keyw, [bcdir]val, comm, ier) + imgkw[bcdir] (im, keyw, [bcdir]val, ier) + impkw[bcdir] (im, keyw, [bcdir]val, ier) + + imokwl (im, patstr, sortit, kwl, ier) + imgnkw (kwl, outstr, ier) + imckwl (kwl, ier) + + +2.2.3 Image Pixel Access + + imgl1[rs] (im, buf, ier) + imgl2[rs] (im, buf, lineno, ier) + imgl3[rs] (im, buf, lineno, bandno, ier) + imgs1[rs] (im, buf, i1, i2, ier) + imgs2[rs] (im, buf, i1, i2, j1, j2, ier) + imgs3[rs] (im, buf, i1, i2, j1, j2, k1, k2, ier) + + impl1[rs] (im, buf, ier) + impl2[rs] (im, buf, lineno, ier) + impl3[rs] (im, buf, lineno, bandno, ier) + imps1[rs] (im, buf, i1, i2, ier) + imps2[rs] (im, buf, i1, i2, j1, j2, ier) + imps2[rs] (im, buf, i1, i2, j1, j2, k1, k2, ier) + + +2.3. BINARY FILE I/O (low level) + + bfaloc (fname, nchars, status) + fd = bfopen (fname, acmode, advice) + bfclos (fd, status) + nchars = bfbsiz (fd) + chan = bfchan (fd) + nchars = bfread (fd, buf, nchars, offset) + nchars = bfwrit (fd, buf, nchars, offset) + stat = bfflsh (fd) diff --git a/sys/imfort/bfio.x b/sys/imfort/bfio.x new file mode 100644 index 00000000..ff2d059d --- /dev/null +++ b/sys/imfort/bfio.x @@ -0,0 +1,496 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "imfort.h" + +.help bfio +.nf -------------------------------------------------------------------------- +BFIO -- Binary file i/o. + +The IMFORT interface needs its own little binary file i/o interface to deal +with the complexities of blocking and deblocking data in hardware disk blocks. +A little buffering is also desirable to reduce the number of disk transfers +required to read through an image. + + bfaloc (fname, nchars, status) + fp = bfopen (fname, acmode, advice) + + bfalcx (fname, nchars, status) + fp = bfopnx (fname, acmode, advice) + nc = bfbsiz (fp) # get block size + nc = bffsiz (fp) # get file size + chan = bfchan (fp) # get channel + bfclos (fp, status) + + stat = bfread (fp, buf, nchars, offset) # random i/o + stat = bfwrit (fp, buf, nchars, offset) + + stat = bfseek (fp, offset) # sequential i/o + stat = bfrseq (fp, buf, nchars) + stat = bfwseq (fp, buf, nchars) + + stat = bfflsh (fp) # flush buffered output + +where + fname host file name (no virtual filenames here) + acmode access mode (READ_ONLY, etc.) + advice SEQUENTIAL or RANDOM + fd file descriptor, a struct pointer + buf char user data buffer + nchars amount of data to transfer, SPP chars + offset file offset of transfer, SPP chars, 1 indexed + stat nchars transferred or ERR + +The advice parameter determines the size of the internal buffer allocated +by BFIO. A small buffer is allocated for random access, a large buffer for +sequential access. Sequential is usually best. If advice is a large number +it is taken to be the actual block size in chars. +.endhelp -------------------------------------------------------------------- + +define LEN_BFIO 10 +define BF_CHAN Memi[$1] # OS channel +define BF_ACMODE Memi[$1+1] # access mode +define BF_BUFP Memi[$1+2] # buffer pointer +define BF_BUFSIZE Memi[$1+3] # buffer capacity, chars +define BF_BUFCHARS Memi[$1+4] # amount of data in buffer +define BF_BUFOFFSET Memi[$1+5] # file offset of buffer +define BF_FILEOFFSET Memi[$1+6] # file offset for seq i/o +define BF_UPDATE Memi[$1+7] # write buffer to disk +define BF_BLKSIZE Memi[$1+8] # device block size + +define SZ_RANBUF 2048 # SPP chars +define SZ_SEQBUF 131072 +define READ 0 +define WRITE 1 + + +# BFOPEN -- Fortran callable version of BFOPNX. + +int procedure bfopen (fname, acmode, advice) + +% character*(*) fname +int acmode # SPP access mode, as in FIO +int advice # seq. or random, or bufsize in chars + +char sppname[SZ_PATHNAME] +pointer bfopnx() + +begin + call f77upk (fname, sppname, SZ_PATHNAME) + return (bfopnx (sppname, acmode, advice)) +end + + +# BFALOC -- Fortran callable version of BFALCX. + +procedure bfaloc (fname, nchars, status) + +% character*(*) fname +int nchars # size of file to be allocated +int status # receives status + +char sppname[SZ_PATHNAME] + +begin + call f77upk (fname, sppname, SZ_PATHNAME) + call strpak (sppname, sppname, SZ_PATHNAME) + call zfaloc (sppname, nchars * SZB_CHAR, status) +end + + +# BFOPNX -- Open a binary file (SPP version). + +pointer procedure bfopnx (fname, acmode, advice) + +char fname[ARB] # HOST filename +int acmode # SPP access mode, as in FIO +int advice # seq. or random, or bufsize in chars + +pointer bp, fp +long blksize +char osfn[SZ_PATHNAME] +int chan, bufsize +int bfmode() +errchk malloc + +begin + # Open or create the file. + call strpak (fname, osfn, SZ_PATHNAME) + call zopnbf (osfn, bfmode(acmode), chan) + if (chan == ERR) + return (ERR) + + # Allocate and initialize file descriptor and i/o buffer. + call malloc (fp, LEN_BFIO, TY_STRUCT) + + # Pick a buffer size. + if (advice == RANDOM) + bufsize = SZ_RANBUF + else if (advice == SEQUENTIAL) + bufsize = SZ_SEQBUF + else + bufsize = advice + + call zsttbf (chan, FSTT_BLKSIZE, blksize) + blksize = blksize / SZB_CHAR + bufsize = (bufsize + blksize - 1) / blksize * blksize + call malloc (bp, bufsize, TY_CHAR) + + BF_CHAN(fp) = chan + BF_ACMODE(fp) = acmode + BF_BUFP(fp) = bp + BF_BUFSIZE(fp) = bufsize + BF_BUFCHARS(fp) = 0 + BF_BUFOFFSET(fp) = 0 + BF_FILEOFFSET(fp) = 1 + BF_UPDATE(fp) = NO + BF_BLKSIZE(fp) = blksize + + return (fp) +end + + +# BFCLOS -- Close a BFIO binary file. + +procedure bfclos (fp, status) + +pointer fp # BFIO file descriptor +int status +int bfflsh() + +begin + if (BF_UPDATE(fp) == YES) { + status = bfflsh (fp) + if (status == ERR) + return + } + + call zclsbf (BF_CHAN(fp), status) + call mfree (BF_BUFP(fp), TY_CHAR) + call mfree (fp, TY_STRUCT) +end + + +# BFALCX -- Allocate a fixed size binary file. + +procedure bfalcx (fname, nchars, status) + +char fname[ARB] # HOST filename +int nchars # size of file to be allocated +int status # receives status + +char osfn[SZ_PATHNAME] + +begin + call strpak (fname, osfn, SZ_PATHNAME) + call zfaloc (osfn, nchars * SZB_CHAR, status) +end + + +# BFBSIZ -- Return the device block size in chars. + +int procedure bfbsiz (fp) + +pointer fp # BFIO file descriptor + +begin + return (BF_BLKSIZE(fp)) +end + + +# BFFSIZ -- Return the file size in chars. + +int procedure bffsiz (fp) + +pointer fp # BFIO file descriptor +int nbytes + +begin + call zsttbf (BF_CHAN(fp), FSTT_FILSIZE, nbytes) + if (nbytes == ERR) + return (ERR) + else + return ((nbytes + SZB_CHAR-1) / SZB_CHAR) +end + + +# BFCHAN -- Return the channel of the file. + +int procedure bfchan (fp) + +pointer fp # BFIO file descriptor + +begin + return (BF_CHAN(fp)) +end + + +# BFREAD -- Read an arbitrary number of chars from a binary file at an +# arbitrary offset. + +int procedure bfread (fp, buf, nchars, offset) + +pointer fp # BFIO file descriptor +char buf[ARB] # user data buffer +int nchars # nchars of data to be read +long offset # file offset + +pointer bp +long off, off1, off2 +int ip, op, nleft, chunk +int bffill() + +begin + off1 = BF_BUFOFFSET(fp) + off2 = off1 + BF_BUFCHARS(fp) + off = offset + nleft = nchars + op = 1 + bp = BF_BUFP(fp) + + while (nleft > 0) { + # Fault in new buffer if file offset falls outside current buffer. + if (off1 <= 0 || off < off1 || off >= off2) + if (bffill (fp, off, nleft, READ) == ERR) + return (ERR) + else { + off1 = BF_BUFOFFSET(fp) + off2 = off1 + BF_BUFCHARS(fp) + } + + # Return as much data as possible from the current buffer and + # advance all the pointers when done. + + ip = off - off1 + chunk = min (nleft, BF_BUFCHARS(fp) - ip) + if (chunk <= 0) + break + call amovc (Memc[bp+ip], buf[op], chunk) + + nleft = nleft - chunk + off = off + chunk + op = op + chunk + } + + if (nleft >= nchars) + return (EOF) + else + return (nchars - nleft) +end + + +# BFWRIT -- Write an arbitrary number of chars to a binary file at an +# arbitrary offset. + +int procedure bfwrit (fp, buf, nchars, offset) + +pointer fp # BFIO file descriptor +char buf[ARB] # user data buffer +int nchars # nchars of data to be written +long offset # file offset + +pointer bp +long off, off1, off2 +int ip, op, nleft, chunk +int bffill() + +begin + off1 = BF_BUFOFFSET(fp) + off2 = off1 + BF_BUFSIZE(fp) + off = offset + nleft = nchars + ip = 1 + bp = BF_BUFP(fp) + + while (nleft > 0) { + # Fault in new buffer if file offset falls outside current buffer. + if (off1 <= 0 || off < off1 || off >= off2) + if (bffill (fp, off, nleft, WRITE) == ERR) + return (ERR) + else { + off1 = BF_BUFOFFSET(fp) + off2 = off1 + BF_BUFSIZE(fp) + } + + # Move as much data as possible into the current buffer and + # advance all the pointers when done. + + op = off - off1 + chunk = min (nleft, BF_BUFSIZE(fp) - op) + call amovc (buf[ip], Memc[bp+op], chunk) + BF_BUFCHARS(fp) = max (BF_BUFCHARS(fp), off+chunk - off1) + BF_UPDATE(fp) = YES + + nleft = nleft - chunk + off = off + chunk + ip = ip + chunk + } + + return (nchars) +end + + +# BFRSEQ -- Sequential read from a file. Successive reads advance through +# the file. + +int procedure bfrseq (fp, buf, nchars) + +pointer fp #I BFIO file descriptor +char buf[ARB] #I user data buffer +int nchars #I nchars of data to be read + +int status +int bfread() + +begin + status = bfread (fp, buf, nchars, BF_FILEOFFSET(fp)) + if (status > 0) + BF_FILEOFFSET(fp) = BF_FILEOFFSET(fp) + status + + return (status) +end + + +# BFWSEQ -- Sequential write to a file. Successive writes advance through +# the file. + +int procedure bfwseq (fp, buf, nchars) + +pointer fp #I BFIO file descriptor +char buf[ARB] #O user data buffer +int nchars #I nchars of data to be written + +int status +int bfwrit() + +begin + status = bfwrit (fp, buf, nchars, BF_FILEOFFSET(fp)) + if (status > 0) + BF_FILEOFFSET(fp) = BF_FILEOFFSET(fp) + status + + return (status) +end + + +# BFSEEK -- Set the file offset for sequential i/o using bf[rw]seq. +# If called as bfseek(fp,0) the current file offset is returned without +# changing the file position. + +int procedure bfseek (fp, offset) + +pointer fp #I BFIO file descriptor +int offset #I desired file offset (1-indexed) + +int bffsiz() +int old_offset + +begin + old_offset = BF_FILEOFFSET(fp) + + switch (offset) { + case BOF: + BF_FILEOFFSET(fp) = 1 + case EOF: + BF_FILEOFFSET(fp) = bffsiz(fp) + 1 + default: + if (offset > 0) + BF_FILEOFFSET(fp) = offset + } + + return (old_offset) +end + + +# BFFILL -- Move the BFIO buffer so that it contains the indicated offset. +# Flush the buffer to disk first if it has been written into. + +int procedure bffill (fp, offset, nchars, rwflag) + +pointer fp # BFIO descriptor +long offset # desired file offset +int nchars # nchars that will be read/written later +int rwflag # read or write when we return? + +long bufoff +int status, bufsize +int bfflsh() + +begin + if (BF_UPDATE(fp) == YES) + if (bfflsh (fp) == ERR) + return (ERR) + + bufsize = BF_BUFSIZE(fp) + bufoff = ((offset - 1) / bufsize) * bufsize + 1 + BF_BUFOFFSET(fp) = bufoff + + # If we are being called prior to a write, and the entire buffer + # is being written into, there is no point in filling the buffer + # from the file. Also, if the file is open WRITE_ONLY, we do not + # read from the file. + + if ((BF_ACMODE(fp) == WO) || + (offset == bufoff && nchars >= bufsize && rwflag == WRITE)) + return (nchars) + + # Fill the buffer from the file. + call zardbf (BF_CHAN(fp), Memc[BF_BUFP(fp)], BF_BUFSIZE(fp) * SZB_CHAR, + (bufoff - 1) * SZB_CHAR + 1) + call zawtbf (BF_CHAN(fp), status) + + if (status == ERR) + return (ERR) + + BF_BUFCHARS(fp) = status / SZB_CHAR + return (BF_BUFCHARS(fp)) +end + + +# BFFLSH -- Flush the BFIO buffer. + +int procedure bfflsh (fp) + +pointer fp # BFIO file descriptor +int status + +begin + if (BF_UPDATE(fp) == NO) + return (OK) + else + BF_UPDATE(fp) = NO + + # Flush the buffer to the file. + call zawrbf (BF_CHAN(fp), Memc[BF_BUFP(fp)], BF_BUFCHARS(fp) * SZB_CHAR, + (BF_BUFOFFSET(fp) - 1) * SZB_CHAR + 1) + call zawtbf (BF_CHAN(fp), status) + + if (status == ERR) + return (ERR) + else + return (status / SZB_CHAR) +end + + +# BFMODE -- Map the IMFORT/BFIO access mode into the file access mode +# expected by the IRAF kernel. + +int procedure bfmode (acmode) + +int acmode # IMFORT access mode + +begin + switch (acmode) { + case RO: + return (READ_ONLY) + case WO: + return (WRITE_ONLY) + case RW: + return (READ_WRITE) + case NF: + return (NEW_FILE) + default: + return (READ_ONLY) + } +end diff --git a/sys/imfort/clargs.x b/sys/imfort/clargs.x new file mode 100644 index 00000000..c383b570 --- /dev/null +++ b/sys/imfort/clargs.x @@ -0,0 +1,232 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imfort.h" + +.help clargs +.nf -------------------------------------------------------------------------- +CLARGS.X -- Command Line Argument access package for IMFORT. + +The CLARGS package provides access to the foreign task command line, if any, +passed to the IMFORT program when it was run. The raw command line may be +obtained as a string, the individual arguments may be extracted as strings, +or arguments may be decoded as integer or floating point values. + + clnarg (nargs) # get number of command line arguments + clargc (argno, sval, ier) # get argument argno as a string + clargi (argno, ival, ier) # get argument argno as an integer + clargr (argno, rval, ier) # get argument argno as a real + clargd (argno, dval, ier) # get argument argno as a double + clrawc (cmdstr, ier) # get entire raw command line + +Command line arguments are delimited by whitespace. String arguments do not +have to be quoted; string arguments containing whitespace must be quoted. +FMTIO is used to decode numeric arguments, hence the IRAF notations are +recognized for radix specification (octal, hex) and for sexagesimal input. + +Note that a Fortran program using IMFORT may be interfaced to the IRAF CL +as a foreign task, using the CLARGS interface to pass foreign task command +line arguments to the Fortran program, allowing user written Fortran programs +to be called from within CL scripts as well as interactively. +.endhelp --------------------------------------------------------------------- + + +# CLARGC -- Return the indicated whitespace delimited command line argument +# as a string. + +procedure clargc (argno, outstr, ier) + +int argno # desired argument +% character*(*) outstr +int ier + +int u_nargs +int u_argp[MAX_ARGS] +char u_sbuf[SZ_CMDLINE] +common /argcom/ u_nargs, u_argp, u_sbuf + +begin + call cl_initargs (ier) + if (ier > 0) + return + + if (argno < 1 || argno > u_nargs) + ier = IE_NEXARG + else { + call f77pak (u_sbuf[u_argp[argno]], outstr, len(outstr)) + ier = OK + } +end + + +# CLARGI -- Return the indicated whitespace delimited command line argument +# as an integer. + +procedure clargi (argno, ival, ier) + +int argno # desired argument +int ival # integer value of argument +int ier + +double dval + +begin + call clargd (argno, dval, ier) + if (ier == OK) + ival = dval # (integer overflow if large exponent) +end + + +# CLARGR -- Return the indicated whitespace delimited command line argument +# as a real. + +procedure clargr (argno, rval, ier) + +int argno # desired argument +real rval # integer value of argument +int ier + +double dval + +begin + call clargd (argno, dval, ier) + if (ier == OK) + rval = dval +end + + +# CLARGD -- Return the indicated whitespace delimited command line argument +# as a double. + +procedure clargd (argno, dval, ier) + +int argno # desired argument +double dval # double floating value of argument +int ier + +int ip, gctod() + +int u_nargs +int u_argp[MAX_ARGS] +char u_sbuf[SZ_CMDLINE] +common /argcom/ u_nargs, u_argp, u_sbuf + +begin + call cl_initargs (ier) + if (ier > 0) + return + + if (argno < 1 || argno > u_nargs) + ier = IE_NEXARG + else { + ip = u_argp[argno] + if (gctod (u_sbuf, ip, dval) <= 0) { + ier = IE_NONNUMARG + call im_seterrop (ier, u_sbuf[ip]) + } else + ier = OK + } +end + + +# CLNARG -- Return the number of command line arguments. + +procedure clnarg (nargs) + +int nargs +int ier + +int u_nargs +int u_argp[MAX_ARGS] +char u_sbuf[SZ_CMDLINE] +common /argcom/ u_nargs, u_argp, u_sbuf + +begin + call cl_initargs (ier) + if (ier != OK) + nargs = 0 + else + nargs = u_nargs +end + + +# CL_INITARGS -- The first time we are called, read the raw command line +# and parse it into the individual argument strings in the ARGCOM common. +# After the first call the common is set and we are a no-op. + +procedure cl_initargs (ier) + +int ier + +int status, op +bool first_time +pointer sp, cmd, token, ip +data first_time /true/ +int ctowrd(), gstrcpy() + +int u_nargs +int u_argp[MAX_ARGS] +char u_sbuf[SZ_CMDLINE] +common /argcom/ u_nargs, u_argp, u_sbuf + +begin + if (!first_time) { + ier = OK + return + } + + call smark (sp) + call salloc (cmd, SZ_CMDLINE, TY_CHAR) + call salloc (token, SZ_CMDLINE, TY_CHAR) + + call zgcmdl (Memc[cmd], SZ_CMDLINE, status) + if (status <= 0) { + ier = IE_GCMDLN + call sfree (sp) + return + } + + call strupk (Memc[cmd], Memc[cmd], SZ_CMDLINE) + u_nargs = 0 + ip = cmd + op = 1 + + while (ctowrd (Memc, ip, Memc[token], SZ_CMDLINE) > 0) { + u_nargs = u_nargs + 1 + u_argp[u_nargs] = op + op = op + gstrcpy (Memc[token], u_sbuf[op], SZ_CMDLINE-op+1) + 1 + } + + ier = OK + first_time = false + call sfree (sp) +end + + +# CLRAWC -- Get the raw command line passed by the host system when the calling +# program was run. This should be the command line entered in the CL when the +# program was called, assuming that the program is implemented as a foreign task +# in the CL. + +procedure clrawc (outstr, ier) + +% character*(*) outstr +int ier + +int status +pointer sp, cmd + +begin + call smark (sp) + call salloc (cmd, SZ_CMDLINE, TY_CHAR) + + call zgcmdl (Memc[cmd], SZ_CMDLINE, status) + if (status <= 0) + ier = IE_GCMDLN + else { + call strupk (Memc[cmd], Memc[cmd], SZ_CMDLINE) + call f77pak (Memc[cmd], outstr, len(outstr)) + ier = OK + } + + call sfree (sp) +end diff --git a/sys/imfort/db/README b/sys/imfort/db/README new file mode 100644 index 00000000..1503a949 --- /dev/null +++ b/sys/imfort/db/README @@ -0,0 +1,120 @@ +IMFORT/DB -- Image header keyword access for IMFORT (20Apr86) + + This directory contains a version of the imio/db package, modified for +IMFORT. The modifications consisted of [1] elimination of calls to the +various printf routines, so that only pure code (no external dependencies +or use of VOS i/o) is linked into the Fortran program, [2] deleted imgnfn +template stuff, [3] added provision for comments when adding new keywords, +[4] changed datatype code to integer uniformly. Error checking is still +used but should be iferr-ed and turned into an IER code in the Fortran +binding. + + +Old IDBI readme docs: +---------------------------------------- + + Image Header Database Interface + dct 16-Apr-85 + +1. Overview + + This directory contains the first version of the image header database +interface. In this implementation the image header is a variable length fixed +format binary structure. The first, fixed format, part of the image header +contains the standard fields in binary and is fixed in size. This is followed +by the so called "user area", a string buffer containing a sequence of +variable length, newline delimited FITS format keyword=value header cards. +When an image is open a large user area is allocated to permit the addition +of new parameters without filling up the buffer. When the header is +subsequently updated on disk only as much disk space is used as is needed to +store the actual header. + +This format header is upwards compatible with the old image header format, +hence old images and programs do not have to be modified to use the IMIO +release supporting database accesss. In the future image headers will be +maintained under DBIO, but the routines in the image header database interface +are not exected to change. The actual disk format of images will of course +change when we switch over to the DBIO headers. + + + +2. Functions + + get,g - get the value of a field + put,p - set the value of a field + add,a - add a new field to a database + acc - determine if the named field exists + + +3. Procedures + + value = imget[bcsilrdx] (im, "field") + imgstr (im, "field", outstr, maxch) + imput[bcsilrdx] (im, "field", value) + impstr (im, "field", value) + imadd[bcsilrdx] (im, "field", def_value) + imastr (im, "field", def_value) + imaddf (im, "field", "datatype") + y/n = imaccf (im, "field") + + list = imofnl[su] (im, template) + nch = imgnfn (im, outstr, maxch) + imcfnl (im) + + + +4. Description + + New parameters will typically be added to the image header with either +one of the typed procedures IMADD_ or with the lower level procedure IMADDF. +The former procedures permit the parameter to be created and the value +initialized all in one call, while the latter only creates the parameter. +In addition, the typed IMADD_ procedures may be used to update the values +of existing parameters (it is not considered an error if the parameter +already exists). The principal limitation of the typed procedures is that +they may only be used to add or set parameters of a standard datatype. +The IMADDF procedure will permit creation of parameters with more descriptive +datatypes (domains) when the interface is recut upon DBIO. + +The value of any parameter may be fetched with one of the IMGET functions. +The IMACCF function may be used (like ACCESS for a file) to determine +whether a parameter exists. + +The database interface may be used to access any field of the image header, +including the following standard fields. Note that the nomenclature has +been changed slightly to make it more consistent with FITS. Additional +standard fields will be defined in the future. + + + keyword type description + + i_naxis i number of axes (dimensionality) + i_naxis[1-7] l length of an axis ("i_naxis1", etc.) + i_pixtype i pixel datatype (SPP integer code) + i_minpixval r minimum pixel value + i_maxpixval r maximum pixel value + i_ctime l time of image creation + i_mtime l time of last modify + i_limtime l time when limits (minmax) were last updated + i_title s title string + + +The names of the standard fields share an "i_" prefix to reduce the possibility +of collisions with data dependent keywords, to identify the standard fields in +sorted listings, to allow use of pattern matching to discriminate between the +standard fields and user fields, and so on. For the convenience of the user, +the "i_" prefix may be omitted provided the resultant name does not match the +name of a user parameter. It is however recommended that the full name be +used in all applications software. + + +5. Restrictions + + The use of FITS format as the internal format for storing fields in this +version of the interface places restrictions on the size of field names and +of the string value of string valued parameters. Field names are currently +limited to eight characters or less and case is ignored (since FITS requires +upper case). The eight character limit does not apply to the standard fields. +String values are limited to at most 68 characters. If put string is passed +a longer string it will be silently truncated. Trailing whitespace and +newlines are chopped when a string value is read. diff --git a/sys/imfort/db/idb.h b/sys/imfort/db/idb.h new file mode 100644 index 00000000..a430f01f --- /dev/null +++ b/sys/imfort/db/idb.h @@ -0,0 +1,22 @@ +# IDB.H -- Image header database interface. In this version of the interface +# the standard image header fields are maintained in binary in a fixed +# structure and the user fields are maintained in FITS format (text) in the +# a string buffer following the binary image header. + +define IDB_RECLEN 80 # length of a FITS record (card) +define IDB_STARTVALUE 10 # first column of value field +define IDB_ENDVALUE 30 # last column of value field +define IDB_LENNUMERICRECORD 80 # length of new numeric records +define IDB_LENSTRINGRECORD 80 # length of new string records + +# Standard header keywords accessible via the database interface. + +define I_CTIME 1 +define I_MTIME 2 +define I_LIMTIME 3 +define I_MINPIXVAL 4 +define I_MAXPIXVAL 5 +define I_NAXIS 6 +define I_PIXFILE 7 +define I_PIXTYPE 8 +define I_TITLE 9 diff --git a/sys/imfort/db/idbfind.x b/sys/imfort/db/idbfind.x new file mode 100644 index 00000000..cc9000ec --- /dev/null +++ b/sys/imfort/db/idbfind.x @@ -0,0 +1,124 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../imfort.h" +include "idb.h" + +# IDB_FINDRECORD -- Search the image database for a particular record given +# the key. The record number (a positive nonzero integer) is returned if +# the record is found, else 0. + +int procedure idb_findrecord (im, key, rp) + +pointer im # image descriptor +char key[ARB] # record key +pointer rp # char record pointer (output) + +pointer sp, pat, patbuf, ukey, lkey, ip, ua +int recno, nchars, lch, uch, ch, junk, i +int patmake(), patmatch(), gstrcpy() + +begin + call smark (sp) + call salloc (pat, SZ_FNAME, TY_CHAR) + call salloc (ukey, SZ_FNAME, TY_CHAR) + call salloc (lkey, SZ_FNAME, TY_CHAR) + call salloc (patbuf, SZ_LINE, TY_CHAR) + + # Search for the FIRST occurrence of a record with the given key. + # If the key is abbreviated and multiple keys are matched, the first + # record matched is used. + + ua = IM_USERAREA(im) + rp = NULL + recno = 1 + + if (IM_UABLOCKED(im) < 0) { + # At image open time this flag is set by IMMAP to -1 to indicate + # that the user area record type is not known. An IKI kernel may + # subsequently set the flag to yes/no, else we determine the + # record type by inspection the first time we are called. If the + # user area is empty the record type is set to blocked; IDB always + # writes blocked records. + + IM_UABLOCKED(im) = YES + for (ip=ua; Memc[ip] != EOS; ip=ip+1) { + for (nchars=0; Memc[ip] != EOS; nchars=nchars+1) { + if (Memc[ip] == '\n') + break + ip = ip + 1 + } + if (nchars != IDB_RECLEN) { + IM_UABLOCKED(im) = NO + break + } + } + } + + if (IM_UABLOCKED(im) == NO) { + # Variable length, newline terminated records, EOS terminated + # record group. + + call strcpy ("^{", Memc[pat], SZ_FNAME) + call strcat (key, Memc[pat], SZ_FNAME) + call strcat ("}[ =]", Memc[pat], SZ_FNAME) + junk = patmake (Memc[pat], Memc[patbuf], SZ_LINE) + + for (ip=ua; Memc[ip] != EOS; ip=ip+1) { + if (patmatch (Memc[ip], Memc[patbuf]) > 0) { + rp = ip + break + } + while (Memc[ip] != '\n' && Memc[ip] != EOS) + ip = ip + 1 + recno = recno + 1 + } + + } else { + # Fixed length (80 character), newline terminated records, EOS + # terminated record group. Simple fast search, fixed length + # records. Case insensitive keyword match. + + nchars = gstrcpy (key, Memc[lkey], SZ_FNAME) + call strlwr (Memc[lkey]) + lch = Memc[lkey] + + nchars = gstrcpy (key, Memc[ukey], SZ_FNAME) + call strupr (Memc[ukey]) + uch = Memc[ukey] + + for (ip=ua; Memc[ip] != EOS; ip=ip+IDB_RECLEN+1) { + ch = Memc[ip] + if (ch == EOS) + break + else if (ch != lch && ch != uch) + next + else { + ch = Memc[ip+nchars] + if (ch != ' ' && ch != '=') + next + } + + # First char matches; check rest of string. + do i = 1, nchars-1 { + ch = Memc[ip+i] + if (ch != Memc[lkey+i] && ch != Memc[ukey+i]) { + ch = 0 + break + } + } + if (ch != 0) { + rp = ip # match + break + } + + recno = recno + 1 + } + } + + call sfree (sp) + if (rp == NULL) + return (0) + else + return (recno) +end diff --git a/sys/imfort/db/idbgstr.x b/sys/imfort/db/idbgstr.x new file mode 100644 index 00000000..0b997884 --- /dev/null +++ b/sys/imfort/db/idbgstr.x @@ -0,0 +1,78 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "idb.h" + +define TY_STRING (-1) + +# IDB_GETSTRING -- Get the string value of a standard header parameter. If the +# actual type of the parameter is not string the value is encoded as a string. +# The length of the string is returned as the function value. ERR is returned +# if the string cannot be found. + +int procedure idb_getstring (im, key, outstr, maxch) + +pointer im # image descriptor +char key[ARB] # parameter to be returned +char outstr[ARB] # output string to receive parameter value +int maxch + +long lval +double dval +int dtype, axis +int gstrcpy(), idb_kwlookup(), idb_naxis(), ltoc(), dtoc() +define encode_ 91 + +begin + # The keywords "naxis1", "naxis2", etc. are treated as a special case. + if (idb_naxis (key, axis) == YES) + if (axis > 0) { + dtype = TY_LONG + lval = IM_LEN(im,axis) + goto encode_ + } + + switch (idb_kwlookup (key)) { + case I_CTIME: + dtype = TY_LONG + lval = IM_CTIME(im) + case I_LIMTIME: + dtype = TY_LONG + lval = IM_LIMTIME(im) + case I_MAXPIXVAL: + dtype = TY_REAL + if (IS_INDEFR (IM_MAX(im))) + dval = INDEFD + else + dval = IM_MAX(im) + case I_MINPIXVAL: + dtype = TY_REAL + if (IS_INDEFR (IM_MIN(im))) + dval = INDEFD + else + dval = IM_MIN(im) + case I_MTIME: + dtype = TY_LONG + lval = IM_MTIME(im) + case I_NAXIS: + dtype = TY_LONG + lval = IM_NDIM(im) + case I_PIXFILE: + return (gstrcpy (IM_PIXFILE(im), outstr, maxch)) + case I_PIXTYPE: + dtype = TY_LONG + lval = IM_PIXTYPE(im) + case I_TITLE: + return (gstrcpy (IM_TITLE(im), outstr, maxch)) + default: + outstr[1] = EOS + return (ERR) + } + +encode_ + if (dtype == TY_LONG) + return (ltoc (lval, outstr, maxch)) + else + return (dtoc (dval, outstr, maxch, 15, 'g', maxch)) +end diff --git a/sys/imfort/db/idbkwlu.x b/sys/imfort/db/idbkwlu.x new file mode 100644 index 00000000..4f56e033 --- /dev/null +++ b/sys/imfort/db/idbkwlu.x @@ -0,0 +1,52 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "idb.h" + +# IDB_KWLOOKUP -- Look up a keyword in the dictionary of standard header +# keywords, returning the magic integer code of the keyword or zero. + +int procedure idb_kwlookup (key) + +char key[ARB] # keyword to be looked up +int index, ip, ch +pointer sp, kwname +int strdic(), strncmp(), strlen() +string keywords "|ctime|mtime|limtime|datamin|datamax|naxis\ +|pixfile|pixtype|title|" + +begin + call smark (sp) + call salloc (kwname, SZ_FNAME, TY_CHAR) + + # Look the string up in the dictionary of standard keywords. Note that + # the "i_" prefix is omitted in the dictionary. Minimum match abbrev. + # are permitted. The order of the keywords in the dictionary must + # agree with the defined codes in the header file. A standard keyword + # is recognized with or without the "i_" prefix. + + if (key[1] == 'i' && key[2] == '_') + ip = 3 + else + ip = 1 + + # Check for a reference to one of the NAXIS keywords. + if (key[ip] == 'n') + if (strncmp (key[ip], "naxis", 5) == 0) { + ch = key[ip+5] + if (ch == EOS || IS_DIGIT(ch)) { + call sfree (sp) + return (I_NAXIS) + } + } + + # Look up keyword in dictionary. Abbreviations are not permitted. + index = strdic (key[ip], Memc[kwname], SZ_FNAME, keywords) + if (index != 0) + if (strlen(key[ip]) != strlen(Memc[kwname])) + index = 0 + + call sfree (sp) + return (index) +end diff --git a/sys/imfort/db/idbnaxis.x b/sys/imfort/db/idbnaxis.x new file mode 100644 index 00000000..3b898403 --- /dev/null +++ b/sys/imfort/db/idbnaxis.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IDB_NAXIS -- Determine if the named keyword is one of the NAXIS* keywords, +# and if so return the value of the numeric suffix. + +int procedure idb_naxis (keyw, axnum) + +char keyw[ARB] # keyword name +int axnum # receives numeric axis code (0=no suffix) + +int ch, ip +int strncmp(), ctoi() + +begin + if (strncmp (keyw, "i_naxis", 7) == 0) + ip = 8 + else if (strncmp (keyw, "naxis", 5) == 0) + ip = 6 + else + return (NO) + + ch = keyw[ip] + if (!IS_DIGIT(ch) && ch != ' ' && ch != EOS) + return (NO) + + if (ctoi (keyw, ip, axnum) <= 0) + axnum = 0 + + return (YES) +end diff --git a/sys/imfort/db/idbpstr.x b/sys/imfort/db/idbpstr.x new file mode 100644 index 00000000..35835730 --- /dev/null +++ b/sys/imfort/db/idbpstr.x @@ -0,0 +1,96 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "idb.h" + +# IDB_PUTSTRING -- Set the value of a standard header parameter given the new +# value of the parameter encoded as a string. If actual type of the parameter +# is non string the value must be decoded. ERR is returned if the key is not +# a standard header parameter or if the key is known but the value cannot be +# decoded. + +int procedure idb_putstring (im, key, strval) + +pointer im # image descriptor +char key[ARB] # parameter to be returned +char strval[ARB] # string value of parameter + +long lval +double dval +bool numeric +int ip, axis +int idb_kwlookup(), idb_naxis(), ctod() +long clktime() + +begin + ip = 1 + numeric = (ctod (strval, ip, dval) > 0) + if (numeric) { + if (IS_INDEFD (dval)) + lval = INDEFL + else if (real(MAX_LONG) < abs(dval)) + lval = INDEFL + else + lval = nint (dval) + } + + # The keywords "naxis1", "naxis2", etc. are treated as a special case. + if (idb_naxis (key, axis) == YES) + if (axis > 0) { + if (numeric) + IM_LEN(im,axis) = lval + else + return (ERR) + } + + # Lookup the keyword in the dictionary and set the value of the + # header parameter. If the parameter is string valued copy the + # string value and return immediately. + + switch (idb_kwlookup (key)) { + case I_CTIME: + if (numeric) + IM_CTIME(im) = lval + case I_LIMTIME: + if (numeric) + IM_LIMTIME(im) = lval + case I_MAXPIXVAL: + if (numeric) { + IM_MAX(im) = dval + IM_LIMTIME(im) = clktime (long(0)) + } + case I_MINPIXVAL: + if (numeric) { + IM_MIN(im) = dval + IM_LIMTIME(im) = clktime (long(0)) + } + case I_MTIME: + if (numeric) + IM_MTIME(im) = lval + case I_NAXIS: + if (numeric) + IM_NDIM(im) = lval + case I_PIXFILE: + call strcpy (strval, IM_PIXFILE(im), SZ_IMPIXFILE) + return (OK) + case I_PIXTYPE: + if (numeric) + IM_PIXTYPE(im) = lval + case I_TITLE: + call strcpy (strval, IM_TITLE(im), SZ_IMTITLE) + return (OK) + default: + return (ERR) + } + + # We make it here only if the actual keyword is numeric, so return + # ERR if the keyword value was nonnumeric. + + if (numeric) + return (OK) + else + return (ERR) +end diff --git a/sys/imfort/db/imaccf.x b/sys/imfort/db/imaccf.x new file mode 100644 index 00000000..60e4e9f3 --- /dev/null +++ b/sys/imfort/db/imaccf.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMACCF -- Test if the named field exists. NO is returned if the key is not +# found, YES otherwise. + +int procedure imaccf (im, key) + +pointer im # image descriptor +char key[ARB] # name of the new parameter +int idb_kwlookup(), idb_findrecord() +pointer rp + +begin + if ((idb_kwlookup (key) > 0) || (idb_findrecord (im, key, rp) > 0)) + return (YES) + else + return (NO) +end diff --git a/sys/imfort/db/imaddb.x b/sys/imfort/db/imaddb.x new file mode 100644 index 00000000..a3161377 --- /dev/null +++ b/sys/imfort/db/imaddb.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMADDB -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imaddb (im, key, value, comment) + +pointer im # image descriptor +char key[ARB] # parameter or field value +bool value # new or initial value of parameter +char comment[ARB] # comment describing new parameter + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, TY_BOOL, comment) + call imputb (im, key, value) +end diff --git a/sys/imfort/db/imaddd.x b/sys/imfort/db/imaddd.x new file mode 100644 index 00000000..55a6f591 --- /dev/null +++ b/sys/imfort/db/imaddd.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMADDD -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imaddd (im, key, value, comment) + +pointer im # image descriptor +char key[ARB] # parameter or field value +double value # new or initial value of parameter +char comment[ARB] # comment describing new parameter + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, TY_DOUBLE, comment) + call imputd (im, key, value) +end diff --git a/sys/imfort/db/imaddf.x b/sys/imfort/db/imaddf.x new file mode 100644 index 00000000..e6bda15e --- /dev/null +++ b/sys/imfort/db/imaddf.x @@ -0,0 +1,76 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../imfort.h" +include "idb.h" + +# IMADDF -- Add a user field to the image header. It is an error if the named +# field already exists. + +procedure imaddf (im, key, datatype, comment) + +pointer im # image descriptor +char key[ARB] # name of the new parameter +int datatype # datatype of parameter +char comment[ARB] # comment describing new parameter + +int max_lenuserarea +pointer sp, keyname, rp, ua, op +int idb_kwlookup(), idb_findrecord(), strlen() +errchk syserrs + +begin + call smark (sp) + call salloc (keyname, SZ_FNAME, TY_CHAR) + + # FITS format requires that the keyword name be upper case. + call strcpy (key, Memc[keyname], SZ_FNAME) + call strupr (Memc[keyname]) + + # Check for a redefinition. + if ((idb_kwlookup (key) > 0) || (idb_findrecord (im, key, rp) > 0)) + call syserrs (SYS_IDBREDEF, key) + + # Open the user area string for appending. If the user area is not + # empty the last character must be the newline record delimiter, + # else the new record we add will be invalid. + + max_lenuserarea = (LEN_IMDES + IM_LENHDRMEM(im) - IMU + 1) * SZ_STRUCT + ua = IM_USERAREA(im) + + for (rp=ua; Memc[rp] != EOS; rp=rp+1) + ; + if (rp - ua + IDB_RECLEN + 1 >= max_lenuserarea) + call syserrs (SYS_IDBOVFL, key) + + if (rp > ua && Memc[rp-1] != '\n') { + Memc[rp] = '\n' + rp = rp + 1 + } + + # Append the new record with an uninitialized value field. Keyword + # value pairs are encoded in FITS format. + + do op = rp, rp + IDB_RECLEN # blank fill card + Memc[op] = ' ' + + # Add the "= 'value' / comment". + call amovc (Memc[keyname], Memc[rp], strlen(Memc[keyname])) + Memc[rp+9-1] = '=' + if (datatype == TY_CHAR) { + Memc[rp+11-1] = '\'' + Memc[rp+20-1] = '\'' + } + + # Add the comment field. + Memc[rp+32-1] = '/' + call amovc (comment, Memc[rp+34-1], + min (IDB_RECLEN-34+1, strlen(comment))) + + # Terminate the card. + Memc[rp+IDB_RECLEN] = '\n' + Memc[rp+IDB_RECLEN+1] = EOS + + call sfree (sp) +end diff --git a/sys/imfort/db/imaddi.x b/sys/imfort/db/imaddi.x new file mode 100644 index 00000000..527baaf0 --- /dev/null +++ b/sys/imfort/db/imaddi.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMADDI -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imaddi (im, key, value, comment) + +pointer im # image descriptor +char key[ARB] # parameter or field value +int value # new or initial value of parameter +char comment[ARB] # comment describing new parameter + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, TY_INT, comment) + call imputi (im, key, value) +end diff --git a/sys/imfort/db/imaddl.x b/sys/imfort/db/imaddl.x new file mode 100644 index 00000000..a707eab3 --- /dev/null +++ b/sys/imfort/db/imaddl.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMADDL -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imaddl (im, key, value, comment) + +pointer im # image descriptor +char key[ARB] # parameter or field value +long value # new or initial value of parameter +char comment[ARB] # comment describing new parameter + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, TY_LONG, comment) + call imputl (im, key, value) +end diff --git a/sys/imfort/db/imaddr.x b/sys/imfort/db/imaddr.x new file mode 100644 index 00000000..ad4eee81 --- /dev/null +++ b/sys/imfort/db/imaddr.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMADDR -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imaddr (im, key, value, comment) + +pointer im # image descriptor +char key[ARB] # parameter or field value +real value # new or initial value of parameter +char comment[ARB] # comment describing new parameter + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, TY_REAL, comment) + call imputr (im, key, value) +end diff --git a/sys/imfort/db/imadds.x b/sys/imfort/db/imadds.x new file mode 100644 index 00000000..b4a01595 --- /dev/null +++ b/sys/imfort/db/imadds.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMADDS -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imadds (im, key, value, comment) + +pointer im # image descriptor +char key[ARB] # parameter or field value +short value # new or initial value of parameter +char comment[ARB] # comment describing new parameter + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, TY_SHORT, comment) + call imputs (im, key, value) +end diff --git a/sys/imfort/db/imastr.x b/sys/imfort/db/imastr.x new file mode 100644 index 00000000..03736f38 --- /dev/null +++ b/sys/imfort/db/imastr.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMASTR -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imastr (im, key, value, comment) + +pointer im # image descriptor +char key[ARB] # parameter or field value +char value[ARB] # new or initial value of parameter +char comment[ARB] # comment string +int imaccf() + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, TY_CHAR, comment) + call impstr (im, key, value) +end diff --git a/sys/imfort/db/imdelf.x b/sys/imfort/db/imdelf.x new file mode 100644 index 00000000..78be8a88 --- /dev/null +++ b/sys/imfort/db/imdelf.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "idb.h" + +# IMDELF -- Delete a user field from the image header. It is an error if the +# named field does not exist. + +procedure imdelf (im, key) + +pointer im # image descriptor +char key[ARB] # name of the new parameter + +int off +pointer rp, sp, keyname +int idb_kwlookup(), idb_findrecord(), stridxs() +errchk syserrs + +begin + call smark (sp) + call salloc (keyname, SZ_FNAME, TY_CHAR) + + # FITS format requires that the keyword name be upper case. + call strcpy (key, Memc[keyname], SZ_FNAME) + call strupr (Memc[keyname]) + + # Cannot delete standard header keywords. + if (idb_kwlookup (key) > 0) + call syserrs (SYS_IDBNODEL, key) + + # Verify that the named user field exists. + if (idb_findrecord (im, key, rp) <= 0) + call syserrs (SYS_IDBDELNXKW, key) + + # Delete the field. + off = stridxs ("\n", Memc[rp]) + if (off > 0) + call strcpy (Memc[rp+off], Memc[rp], ARB) + else + Memc[rp] = EOS + + call sfree (sp) +end diff --git a/sys/imfort/db/imgatr.x b/sys/imfort/db/imgatr.x new file mode 100644 index 00000000..5d600cfa --- /dev/null +++ b/sys/imfort/db/imgatr.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "idb.h" + +# IMGATR -- Get the attribute fields (type code and comment) of a header +# keyword. A separate, normally typed, call is required to get the keyword +# value. + +procedure imgatr (im, key, dtype, comm, maxch) + +pointer im # image descriptor +char key[ARB] # parameter to be returned +int dtype # receives datatype code +char comm[ARB] # output string to comment field +int maxch + +int op +pointer rp, ip +int idb_getstring(), idb_findrecord(), imgftype() +errchk syserrs, imgftype + +begin + # Get the field datatype. + dtype = imgftype (im, key) + + # Check for a standard header parameter first. + if (idb_getstring (im, key, comm, maxch) != ERR) { + comm[1] = EOS + return + } + + # Find the record. + if (idb_findrecord (im, key, rp) == 0) + call syserrs (SYS_IDBKEYNF, key) + + # Extract the comment field. + for (ip=rp+IDB_ENDVALUE; Memc[ip] != '/' && Memc[ip] != '\n'; ip=ip+1) + ; + if (Memc[ip] == '/') { + for (ip=ip+1; IS_WHITE(Memc[ip]); ip=ip+1) + ; + for (op=1; Memc[ip] != '\n'; ip=ip+1) { + comm[op] = Memc[ip] + op = op + 1 + } + comm[op] = EOS + } else + comm[1] = EOS +end diff --git a/sys/imfort/db/imgetb.x b/sys/imfort/db/imgetb.x new file mode 100644 index 00000000..aba16f97 --- /dev/null +++ b/sys/imfort/db/imgetb.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "idb.h" + +# IMGETB -- Get an image header parameter of type boolean. False is returned +# if the parameter cannot be found or if the value is not true. + +bool procedure imgetb (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be returned +pointer rp +pointer idb_findrecord() + +begin + if (idb_findrecord (im, key, rp) == 0) + return (false) + else + return (Memc[rp+IDB_ENDVALUE-1] == 'T') +end diff --git a/sys/imfort/db/imgetc.x b/sys/imfort/db/imgetc.x new file mode 100644 index 00000000..f56ecb9d --- /dev/null +++ b/sys/imfort/db/imgetc.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMGETC -- Get an image header parameter of type char. + +char procedure imgetc (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be returned +long imgetl() + +begin + return (imgetl (im, key)) +end diff --git a/sys/imfort/db/imgetd.x b/sys/imfort/db/imgetd.x new file mode 100644 index 00000000..01a71cb1 --- /dev/null +++ b/sys/imfort/db/imgetd.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "idb.h" + +# IMGETD -- Get an image header parameter of type double floating. If the +# named parameter is a standard parameter return the value directly, +# else scan the user area for the named parameter and decode the value. + +double procedure imgetd (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be returned + +int ip +double dval +pointer sp, sval +int ctod() +errchk syserrs, imgstr + +begin + call smark (sp) + call salloc (sval, SZ_LINE, TY_CHAR) + + ip = 1 + call imgstr (im, key, Memc[sval], SZ_LINE) + if (ctod (Memc[sval], ip, dval) == 0) + call syserrs (SYS_IDBTYPE, key) + + call sfree (sp) + return (dval) +end diff --git a/sys/imfort/db/imgeti.x b/sys/imfort/db/imgeti.x new file mode 100644 index 00000000..8da2878e --- /dev/null +++ b/sys/imfort/db/imgeti.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMGETI -- Get an image header parameter of type integer. + +int procedure imgeti (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be returned + +long lval, imgetl() +errchk imgetl + +begin + lval = imgetl (im, key) + if (IS_INDEFL(lval)) + return (INDEFI) + else + return (lval) +end diff --git a/sys/imfort/db/imgetl.x b/sys/imfort/db/imgetl.x new file mode 100644 index 00000000..817715c0 --- /dev/null +++ b/sys/imfort/db/imgetl.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMGETL -- Get an image header parameter of type long integer. + +long procedure imgetl (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be returned + +double dval, imgetd() +errchk imgetd + +begin + dval = imgetd (im, key) + if (IS_INDEFD(dval)) + return (INDEFL) + else + return (nint (dval)) +end diff --git a/sys/imfort/db/imgetr.x b/sys/imfort/db/imgetr.x new file mode 100644 index 00000000..b1c6c67a --- /dev/null +++ b/sys/imfort/db/imgetr.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMGETR -- Get an image header parameter of type real. + +real procedure imgetr (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be returned + +double dval, imgetd() +errchk imgetd + +begin + dval = imgetd (im, key) + if (IS_INDEFD(dval)) + return (INDEFR) + else + return (dval) +end diff --git a/sys/imfort/db/imgets.x b/sys/imfort/db/imgets.x new file mode 100644 index 00000000..39f2fcfd --- /dev/null +++ b/sys/imfort/db/imgets.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMGETS -- Get an image header parameter of type short integer. + +short procedure imgets (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be returned + +long lval, imgetl() +errchk imgetl + +begin + lval = imgetl (im, key) + if (IS_INDEFL(lval)) + return (INDEFS) + else + return (lval) +end diff --git a/sys/imfort/db/imgftype.x b/sys/imfort/db/imgftype.x new file mode 100644 index 00000000..246219d5 --- /dev/null +++ b/sys/imfort/db/imgftype.x @@ -0,0 +1,76 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "idb.h" + +# IMGFTYPE -- Get the datatype of a particular field of an image header. Since +# the internal format is FITS, there are four primary datatypes, boolean (T|F), +# string (quoted), integer and real. + +int procedure imgftype (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be set + +pointer rp +int axis, ch, ip +int idb_findrecord(), idb_kwlookup(), idb_naxis() +errchk syserrs + +begin + # The standard header keywords "naxis1", "naxis2", etc. are treated + # as a special case. + + if (idb_naxis (key, axis) == YES) + return (TY_LONG) + + # Handle the standard header keywords. + + switch (idb_kwlookup (key)) { + case I_CTIME: + return (TY_LONG) + case I_LIMTIME: + return (TY_LONG) + case I_MAXPIXVAL: + return (TY_REAL) + case I_MINPIXVAL: + return (TY_REAL) + case I_MTIME: + return (TY_LONG) + case I_NAXIS: + return (TY_LONG) + case I_PIXFILE: + return (TY_CHAR) + case I_PIXTYPE: + return (TY_LONG) + case I_TITLE: + return (TY_CHAR) + } + + # If we get here then the named parameter is not a standard header + # keyword. + + if (idb_findrecord (im, key, rp) > 0) { + # Check for quoted string. + ch = Memc[rp+IDB_STARTVALUE] + if (ch == '\'') + return (TY_CHAR) + + # Check for boolean field. + ch = Memc[rp+IDB_ENDVALUE-1] + if (ch == 'T' || ch == 'F') + return (TY_BOOL) + + # If field contains only digits it must be an integer. + for (ip=IDB_STARTVALUE; ip <= IDB_ENDVALUE; ip=ip+1) { + ch = Memc[rp+ip-1] + if (! (IS_DIGIT(ch) || IS_WHITE(ch))) + return (TY_REAL) + } + + return (TY_INT) + } + + call syserrs (SYS_IDBKEYNF, key) +end diff --git a/sys/imfort/db/imgnfn.x b/sys/imfort/db/imgnfn.x new file mode 100644 index 00000000..88969645 --- /dev/null +++ b/sys/imfort/db/imgnfn.x @@ -0,0 +1,338 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "../imfort.h" +include "idb.h" + +.help imgnfn +.nf -------------------------------------------------------------------------- +IMGNFN -- Template expansion for header keywords. + + list = imofnl[su] (im, template) # open list + nch = imgnfn (im, outstr, maxch) # get next field name + imcfnl (im) # close list + +IMOFNLS opens the list sorted, whereas IMOFNLU opens it unsorted. Both std. +and user header keywords are included in the list. +.endhelp --------------------------------------------------------------------- + +define MAX_FIELDS 128 +define SZ_SBUF 1024 +define LEN_FNSTRUCT (10+MAX_FIELDS) + +define FN_NENTRIES Memi[$1] # number of field names in list +define FN_NEXT Memi[$1+1] # next string to be returned +define FN_SBUF Memi[$1+2] # pointer to string buffer + # open +define FN_STRP Memi[$1+10+$2-1] # array of str ptrs +define FN_FIELDNAME Memc[FN_STRP($1,$2)] # reference a string + + +# IMGNFN -- Get the next header field name matching the given template from an +# image header database. Sorting of the field list is optional. A prior call +# to IMOFNL[SU] is necessary to open the sorted or unsorted list. + +int procedure imgnfn (fn, outstr, maxch) + +pointer fn # field name list descriptor +char outstr[ARB] # output string +int maxch + +int strnum +int gstrcpy() + +begin + strnum = FN_NEXT(fn) + if (strnum > FN_NENTRIES(fn)) + return (EOF) + FN_NEXT(fn) = strnum + 1 + + return (gstrcpy (FN_FIELDNAME(fn,strnum), outstr, maxch)) +end + + +# IMOFNLS -- Open a sorted field name list. + +pointer procedure imofnls (im, template) + +pointer im # image descriptor +char template[ARB] # field name template +pointer imofnl() + +begin + return (imofnl (im, template, YES)) +end + + +# IMOFNLU -- Open an unsorted field name list. + +pointer procedure imofnlu (im, template) + +pointer im # image descriptor +char template[ARB] # field name template +pointer imofnl() + +begin + return (imofnl (im, template, NO)) +end + + +# IMCFNL -- Close the image header field name list and return all associated +# storage. + +procedure imcfnl (fn) + +pointer fn # field name list descriptor + +begin + call mfree (FN_SBUF(fn), TY_CHAR) + call mfree (fn, TY_STRUCT) +end + + +# IMOFNL -- Open an image header field name list, either sorted or unsorted. +# A template is a list of patterns delimited by commas. + +pointer procedure imofnl (im, template, sort) + +pointer im # image descriptor +char template[ARB] # field name template +int sort # sort flag + +bool escape +int tp, nstr, ch, junk, first_string, nstrings, nmatch, i +pointer sp, ip, op, fn, kwname, sbuf, pattern, patcode, nextch +int patmake(), patmatch(), strlen() +errchk syserr + +begin + call smark (sp) + call salloc (kwname, SZ_FNAME, TY_CHAR) + call salloc (pattern, SZ_FNAME, TY_CHAR) + call salloc (patcode, SZ_LINE, TY_CHAR) + + # Allocate field list descriptor. + call calloc (fn, LEN_FNSTRUCT, TY_STRUCT) + call malloc (sbuf, SZ_SBUF, TY_CHAR) + + FN_SBUF(fn) = sbuf + nextch = sbuf + nstr = 0 + tp = 1 + + # Extract each comma delimited template, expand upon image header + # field list, sort if desired, and add strings to list. + + while (template[tp] != EOS && template[tp] != '\n') { + # Advance to next field. + while (IS_WHITE(template[tp]) || template[tp] == ',') + tp = tp + 1 + + # Extract pattern. Enclose pattern in ^{} so that the match will + # occur only at the beginning of each line and will be case + # insensitive (req'd for FITS format). + + op = pattern + Memc[op] = '^' + op = op + 1 + Memc[op] = '{' + op = op + 1 + + # A field name of the form "$", "$x", etc. is not matched against + # the actual image field list, but is included in the output field + # list as a literal. + + ch = template[tp] + escape = (ch == '$') + + while (! (IS_WHITE(ch) || ch == '\n' || ch == ',' || ch == EOS)) { + # Map "*" into "?*". + if (ch == '*') { + Memc[op] = '?' + op = op + 1 + } + + Memc[op] = ch + op = op + 1 + tp = tp + 1 + ch = template[tp] + } + + Memc[op] = '}' + op = op + 1 + Memc[op] = EOS + + # If the pattern is a literal, put it in the output list without + # matching it against the image field list. + + if (escape) { + # Omit the leading "^{" and the trailing "}". + ip = pattern + 2 + op = op - 1 + Memc[op] = EOS + call imfn_putkey (Memc[ip], FN_STRP(fn,1), nstr, nextch, sbuf) + + } else { + # Encode pattern. + junk = patmake (Memc[pattern], Memc[patcode], SZ_LINE) + + # Scan database and extract all field names matching the + # pattern. Mark number of first string for the sort. + + first_string = nstr + 1 + + # First find any standard header keywords matching the pattern. + call imfn_stdkeys (im, Memc[patcode], FN_STRP(fn,1), nstr, + nextch, sbuf) + + # Now scan the user area. + for (ip=IM_USERAREA(im); Memc[ip] != EOS; ip=ip+1) { + # Skip entries that are not keywords. + if (Memc[ip+8] != '=') + next + + # Extract keyword name. + Memc[kwname+8] = EOS + do i = 1, 8 { + ch = Memc[ip+i-1] + if (ch == ' ') { + Memc[kwname+i-1] = EOS + break + } else + Memc[kwname+i-1] = ch + } + + # Check for a match. + if (Memc[kwname] != EOS) { + # Put key in list if it matches. + nmatch = patmatch (Memc[kwname], Memc[patcode]) - 1 + if (nmatch > 0 && nmatch == strlen(Memc[kwname])) + call imfn_putkey (Memc[ip], + FN_STRP(fn,1), nstr, nextch, sbuf) + } + + # Advance to the next record. + if (IM_UABLOCKED(im) == YES) + ip = ip + IDB_RECLEN + else { + while (Memc[ip] != '\n' && Memc[ip] != EOS) + ip = ip + 1 + } + + if (Memc[ip] == EOS) + break + } + + # Sort the newly added keywords. + nstrings = nstr - first_string + 1 + if (sort == YES && nstrings > 1) + call strsrt (FN_STRP(fn,first_string), Memc, nstrings) + } + } + + FN_NENTRIES(fn) = nstr + FN_NEXT(fn) = 1 + + call sfree (sp) + return (fn) +end + + +# IMFN_STDKEYS -- Match a pattern (encoded) against the list of standard header +# keywords, both with and without the "i_" prefix. Add the full name (with i_ +# prefix) of each name matched to the keyword list. Note that by default, +# only the "user" keywords are matched in this way, although any keyword can +# be accessed if its name is known (i.e., not all keywords are visible). + +procedure imfn_stdkeys (im, patcode, strp, nstr, nextch, sbuf) + +pointer im # image descriptor +char patcode[ARB] # encoded pattern +pointer strp[ARB] # array of string pointers +int nstr # current number of strings +pointer nextch # next available char in string buffer +pointer sbuf # string buffer + +bool validfield +int ip, index +pointer sp, op, key +int patmatch() +errchk imfn_putkey + +# NOTE index values below depend upon position in this string. +string keywords "|naxis|naxis1|naxis2|naxis3|pixtype|datamin|datamax|\ +ctime|mtime|limtime|title|" + +begin + call smark (sp) + call salloc (key, SZ_FNAME, TY_CHAR) + + call strcpy ("i_", Memc[key], SZ_FNAME) + index = 1 + + for (ip=2; keywords[ip] != EOS; ip=ip+1) { + # Do not put dimensions NAXIS1, NAXIS2, etc. higher than the + # actual image dimension into the matched list. + + validfield = true + if (index >= 2 && index <= 4) + validfield = (index - 1 <= IM_NDIM(im)) + + # Extract keyword into buffer, after the "i_". + for (op=key+2; keywords[ip] != '|'; op=op+1) { + Memc[op] = keywords[ip] + ip = ip + 1 + } + Memc[op] = EOS + + if (validfield) + if (patmatch (Memc[key], patcode) > 0 || + patmatch (Memc[key+2], patcode) > 0) { + + call imfn_putkey (Memc[key], strp, nstr, nextch, sbuf) + } + + index = index + 1 + } + + call sfree (sp) +end + + +# IMFN_PUTKEY -- Put a keyword into the keyword list. + +procedure imfn_putkey (key, strp, nstr, nextch, sbuf) + +char key[ARB] # keyword name (etc.) +pointer strp[ARB] # array of string pointers +int nstr # current number of strings +pointer nextch # next available char in string buffer +pointer sbuf # string buffer + +int ch, ip +errchk syserr + +begin + # Append keyword to the string buffer. + nstr = nstr + 1 + if (nstr > MAX_FIELDS) + call syserr (SYS_IMFNOVFL) + strp[nstr] = nextch + + ip = 1 + ch = key[ip] + + while (ch != '=' && ch != ' ' && ch != EOS) { + Memc[nextch] = ch + nextch = nextch + 1 + if (nextch >= sbuf + SZ_SBUF) + call syserr (SYS_IMFNOVFL) + ip = ip + 1 + ch = key[ip] + } + + Memc[nextch] = EOS + nextch = nextch + 1 +end diff --git a/sys/imfort/db/imgstr.x b/sys/imfort/db/imgstr.x new file mode 100644 index 00000000..bf3272a5 --- /dev/null +++ b/sys/imfort/db/imgstr.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "idb.h" + +# IMGSTR -- Get an image header parameter of type string. If the named +# parameter is a standard parameter return the value directly, else scan +# the user area for the named parameter and decode the value. + +procedure imgstr (im, key, outstr, maxch) + +pointer im # image descriptor +char key[ARB] # parameter to be returned +char outstr[ARB] # output string to receive parameter value +int maxch + +pointer rp +int ip, op +int idb_getstring(), idb_findrecord(), ctowrd(), strlen() +errchk syserrs + +begin + # Check for a standard header parameter first. + if (idb_getstring (im, key, outstr, maxch) != ERR) + return + + # Find the record. + if (idb_findrecord (im, key, rp) == 0) + call syserrs (SYS_IDBKEYNF, key) + + ip = IDB_STARTVALUE + if (ctowrd (Memc[rp], ip, outstr, maxch) > 0) { + # Strip trailing whitespace. + op = strlen (outstr) + while (op > 0 && (IS_WHITE(outstr[op]) || outstr[op] == '\n')) + op = op - 1 + outstr[op+1] = EOS + } else + outstr[1] = EOS +end diff --git a/sys/imfort/db/impstr.x b/sys/imfort/db/impstr.x new file mode 100644 index 00000000..fba9f8af --- /dev/null +++ b/sys/imfort/db/impstr.x @@ -0,0 +1,72 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "idb.h" + +# IMPSTR -- Put an image header parameter of type string. If the named +# parameter is a standard parameter of type other than string, decode the +# string and set the binary value of the parameter. If the parameter is +# a nonstandard one we can do a simple string edit, since user parameters +# are stored in the user area in string form. The datatype of the parameter +# must be preserved by the edit, i.e., parameters of actual datatype string +# must be quoted and left justified and other parameters must be unquoted +# and right justified in the value field. + +procedure impstr (im, key, value) + +pointer im # image descriptor +char key[ARB] # parameter to be set +char value[ARB] # new parameter value + +pointer rp, ip, vp +int ncols, n, i +bool string_valued +int idb_putstring(), idb_findrecord(), strlen() +errchk syserrs + +begin + # Check for a standard header parameter first. + if (idb_putstring (im, key, value) != ERR) + return + + # Find the record. + if (idb_findrecord (im, key, rp) == 0) + call syserrs (SYS_IDBKEYNF, key) + + # Determine the actual datatype of the parameter. String valued + # parameters will have an apostrophe in the first nonblank column + # of the value field. + + string_valued = false + for (ip=IDB_STARTVALUE; ip <= IDB_ENDVALUE; ip=ip+1) + if (Memc[rp+ip-1] == '\'') { + string_valued = true + break + } + + vp = rp + IDB_STARTVALUE - 1 + n = strlen (value) + + # If we have a long string value, give it the whole card. + ncols = IDB_ENDVALUE - IDB_STARTVALUE + 1 + if (string_valued && n > 21 - 3) + ncols = IDB_RECLEN - IDB_STARTVALUE + 1 + + # Blank fill the value field. + do i = 1, ncols + Memc[vp+i-1] = ' ' + + # Encode the new value of the parameter in a field of width 21 + # (or larger in the case of long string values) including a leading + # blank and the quotes if string valued. + + if (string_valued) { + n = min (ncols - 3, n) + Memc[vp+2-1] = '\'' + call amovc (value, Memc[vp+3-1], n) + Memc[vp+ncols-1] = '\'' + } else { + n = min (ncols - 1, n) + call amovc (value, Memc[vp+ncols-1-n+1], n) + } +end diff --git a/sys/imfort/db/imputb.x b/sys/imfort/db/imputb.x new file mode 100644 index 00000000..a211f464 --- /dev/null +++ b/sys/imfort/db/imputb.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPUTB -- Put an image header parameter of type boolean. + +procedure imputb (im, key, bval) + +pointer im # image descriptor +char key[ARB] # parameter to be set +bool bval # parameter value +char sval[2] + +begin + if (bval) + sval[1] = 'T' + else + sval[1] = 'F' + sval[2] = EOS + + call impstr (im, key, sval) +end diff --git a/sys/imfort/db/imputd.x b/sys/imfort/db/imputd.x new file mode 100644 index 00000000..fc633c23 --- /dev/null +++ b/sys/imfort/db/imputd.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMPUTD -- Put an image header parameter of type double. + +procedure imputd (im, key, dval) + +pointer im # image descriptor +char key[ARB] # parameter to be set +double dval # double precision value + +int junk, i +pointer sp, sval +int dtoc(), strlen() + +begin + call smark (sp) + call salloc (sval, SZ_FNAME, TY_CHAR) + + # Reduce the precision of the encoded value if necessary to fit in + # the FITS value field. Start with NDIGITS_DP-1 as the precision + # estimate NDIGITS_DP is only approximate, and if we make up half a + # digit of precision the result can be 1.00000000000000001 instead + # of 1.0. + + for (i=NDIGITS_DP-1; i >= NDIGITS_RP; i=i-1) { + junk = dtoc (dval, Memc[sval], SZ_FNAME, i, 'g', SZ_FNAME) + if (strlen (Memc[sval]) < 20) + break + } + + # Write the new value to the header. + call impstr (im, key, Memc[sval]) + + call sfree (sp) +end diff --git a/sys/imfort/db/imputi.x b/sys/imfort/db/imputi.x new file mode 100644 index 00000000..a4ccdd31 --- /dev/null +++ b/sys/imfort/db/imputi.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPUTI -- Put an image header parameter of type integer. + +procedure imputi (im, key, ival) + +pointer im # image descriptor +char key[ARB] # parameter to be set +int ival # parameter value +long lval + +begin + if (IS_INDEFI (ival)) + lval = INDEFL + else + lval = ival + call imputl (im, key, lval) +end diff --git a/sys/imfort/db/imputl.x b/sys/imfort/db/imputl.x new file mode 100644 index 00000000..3af988a9 --- /dev/null +++ b/sys/imfort/db/imputl.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPUTL -- Put an image header parameter of type long integer. + +procedure imputl (im, key, lval) + +pointer im # image descriptor +char key[ARB] # parameter to be set +long lval # parameter value + +int junk +pointer sp, sval +int ltoc() + +begin + call smark (sp) + call salloc (sval, SZ_FNAME, TY_CHAR) + + junk = ltoc (lval, Memc[sval], SZ_FNAME) + call impstr (im, key, Memc[sval]) + + call sfree (sp) +end diff --git a/sys/imfort/db/imputr.x b/sys/imfort/db/imputr.x new file mode 100644 index 00000000..27668a62 --- /dev/null +++ b/sys/imfort/db/imputr.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPUTR -- Put an image header parameter of type real. + +procedure imputr (im, key, rval) + +pointer im # image descriptor +char key[ARB] # parameter to be set +real rval # parameter value +double dval + +begin + if (IS_INDEFR (rval)) + dval = INDEFD + else + dval = rval + call imputd (im, key, dval) +end diff --git a/sys/imfort/db/imputs.x b/sys/imfort/db/imputs.x new file mode 100644 index 00000000..6b0f763f --- /dev/null +++ b/sys/imfort/db/imputs.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPUTS -- Put an image header parameter of type short integer. + +procedure imputs (im, key, sval) + +pointer im # image descriptor +char key[ARB] # parameter to be set +short sval # parameter value +long lval + +begin + if (IS_INDEFS (sval)) + lval = INDEFL + else + lval = sval + call imputl (im, key, lval) +end diff --git a/sys/imfort/db/mkpkg b/sys/imfort/db/mkpkg new file mode 100644 index 00000000..4ce6acd4 --- /dev/null +++ b/sys/imfort/db/mkpkg @@ -0,0 +1,42 @@ +# Update the IMFORT image header database interface. + +$checkout libimfort.a lib$ +$update libimfort.a +$checkin libimfort.a lib$ +$exit + +libimfort.a: + idbfind.x ../imfort.h idb.h + idbgstr.x idb.h + idbkwlu.x idb.h + idbnaxis.x + idbpstr.x idb.h + imaccf.x + imaddb.x + imaddd.x + imaddf.x ../imfort.h idb.h + imaddi.x + imaddl.x + imaddr.x + imadds.x + imastr.x + imdelf.x idb.h + imgatr.x idb.h + imgetb.x idb.h + imgetc.x + imgetd.x idb.h + imgeti.x + imgetl.x + imgetr.x + imgets.x + imgftype.x idb.h + imgnfn.x ../imfort.h idb.h + imgstr.x idb.h + impstr.x idb.h + imputb.x + imputd.x + imputi.x + imputl.x + imputr.x + imputs.x + ; diff --git a/sys/imfort/doc/TODO b/sys/imfort/doc/TODO new file mode 100644 index 00000000..662fc249 --- /dev/null +++ b/sys/imfort/doc/TODO @@ -0,0 +1,3 @@ +IMFORT docs updates needed: + + o Add description of IM[SG]DIR, 'imdir' semantics. (6/1/89) diff --git a/sys/imfort/doc/bfaloc.hlp b/sys/imfort/doc/bfaloc.hlp new file mode 100644 index 00000000..470042bc --- /dev/null +++ b/sys/imfort/doc/bfaloc.hlp @@ -0,0 +1,32 @@ +.help bfaloc Sep86 imfort.bfio +.ih +NAME +bfaloc -- create and preallocate storage for a binary file +.ih +SYNOPSIS +.nf +subroutine bfaloc (fname, nchars, status) + +character*(*) fname #I host name of new file +integer nchars #I size of file in "chars" +integer status #O status return +.fi +.ih +DESCRIPTION +The \fIbfaloc\fR procedure creates a new file \fIfname\fR and preallocates +space for at least \fInchars\fR SPP char units of storage. The contents of +the file are unitialized. +.ih +RETURN VALUE +A negative status value indicates either that the file could not be created +(e.g., due to insufficient permission), or that the requested amount of space +could not be allocated. A positive or zero status indicates that the operation +succeeded. +.ih +NOTES +On some systems, storage may not physically be allocated until the file is +written into. +.ih +SEE ALSO +bfopen +.endhelp diff --git a/sys/imfort/doc/bfbsiz.hlp b/sys/imfort/doc/bfbsiz.hlp new file mode 100644 index 00000000..aeea7912 --- /dev/null +++ b/sys/imfort/doc/bfbsiz.hlp @@ -0,0 +1,22 @@ +.help bfbsiz Sep86 imfort.bfio +.ih +NAME +bfbsiz -- get the buffer size in chars of a binary file +.ih +SYNOPSIS +.nf +integer function bfbsiz (fd) + +integer fd #I BFIO file descriptor of open file +.fi +.ih +DESCRIPTION +The \fIbfbsiz\fR function is used to query the size in SPP char units of +storage of the internal BFIO file buffer. +.ih +RETURN VALUE +The size of the BFIO file buffer in chars is returned as the function value. +.ih +SEE ALSO +bffsiz, bfchan +.endhelp diff --git a/sys/imfort/doc/bfchan.hlp b/sys/imfort/doc/bfchan.hlp new file mode 100644 index 00000000..9641b971 --- /dev/null +++ b/sys/imfort/doc/bfchan.hlp @@ -0,0 +1,27 @@ +.help bfchan Sep86 imfort.bfio +.ih +NAME +bfchan -- return the kernel i/o channel of an open BFIO file +.ih +SYNOPSIS +.nf +integer function bfchan (fd) + +integer fd #I BFIO file descriptor of open file +.fi +.ih +DESCRIPTION +The \fIbfchan\fR procedure is used to get the i/o channel assigned to the +file at open time by the binary file driver in the IRAF kernel. +This may be used as input to the \fIzfiobf\fR binary file driver primitives +if the lowest possible level of binary file i/o is desired (short of talking +directly to the host system). The \fIzfiobf\fR procedures provide a direct +(unbuffered), block oriented, asynchronous binary file i/o interface. +.ih +RETURN VALUE +The i/o channel assigned to the file by the \fIzfiobf\fR binary file driver +at open time is returned as the function value. +.ih +SEE ALSO +The manual pages for the binary file driver. +.endhelp diff --git a/sys/imfort/doc/bfclos.hlp b/sys/imfort/doc/bfclos.hlp new file mode 100644 index 00000000..83b8e856 --- /dev/null +++ b/sys/imfort/doc/bfclos.hlp @@ -0,0 +1,27 @@ +.help bfclos Sep86 imfort.bfio +.ih +NAME +bfclos -- close a file opened for binary file i/o +.ih +SYNOPSIS +.nf +subroutine bfclos (fd, status) + +integer fd #I BFIO file descriptor of open file +integer status #O status return +.fi +.ih +DESCRIPTION +The \fIbfclos\fR procedure closes a file previously opened with \fIbfopen\fR, +freeing the file descriptor and any other system resources associated with the +file descriptor. The output buffer is automatically flushed before the file +is closed. +.ih +RETURN VALUE +A negative status indicates failure, e.g., either a write error occurred +when the output buffer was flushed, or the file descriptor \fIfd\fR was +invalid. +.ih +SEE ALSO +bfopen +.endhelp diff --git a/sys/imfort/doc/bfflsh.hlp b/sys/imfort/doc/bfflsh.hlp new file mode 100644 index 00000000..3dc676a0 --- /dev/null +++ b/sys/imfort/doc/bfflsh.hlp @@ -0,0 +1,26 @@ +.help bfflsh Sep86 imfort.bfio +.ih +NAME +bfflsh -- flush any buffered output data to disk +.ih +SYNOPSIS +.nf +integer function bfflsh (fd) + +integer fd #I BFIO file descriptor of open file +.fi +.ih +DESCRIPTION +The \fIbfflsh\fR procedure flushes any buffered output data to a binary +file opened for read-write access. +.ih +RETURN VALUE +A negative status indicates failure, e.g., a write error on the file. +.ih +NOTES +If the buffer has already been flushed or the file was opened for read-only +access, \fIbfflsh\fR is a no-op. +.ih +SEE ALSO +bfwrit +.endhelp diff --git a/sys/imfort/doc/bffsiz.hlp b/sys/imfort/doc/bffsiz.hlp new file mode 100644 index 00000000..4385b270 --- /dev/null +++ b/sys/imfort/doc/bffsiz.hlp @@ -0,0 +1,24 @@ +.help bffsiz Sep86 imfort.bfio +.ih +NAME +bffsiz -- get the size in chars of a binary file +.ih +SYNOPSIS +.nf +integer function bffsiz (fd) + +integer fd #I BFIO file descriptor of open file +.fi +.ih +DESCRIPTION +The \fIbffsiz\fR function is used to query the size in SPP char units of +storage of a binary file previously opened with \fIbfopen\fR. This is useful, +for example, when writing at the end of file, since the BFIO write function +requires an absolute file offset as input. +.ih +RETURN VALUE +The current size of the file in chars is returned as the function value. +.ih +SEE ALSO +bfbsiz, bfchan +.endhelp diff --git a/sys/imfort/doc/bfopen.hlp b/sys/imfort/doc/bfopen.hlp new file mode 100644 index 00000000..a345d4fa --- /dev/null +++ b/sys/imfort/doc/bfopen.hlp @@ -0,0 +1,32 @@ +.help bfopen Sep86 imfort.bfio +.ih +NAME +bfopen -- open a file for binary file i/o +.ih +SYNOPSIS +.nf +integer function bfopen (fname, acmode, advice) + +character*(*) fname #I host name of file to be opened +integer acmode #I file access mode (1=RO,3=RW,5=NF) +integer advice #I type of access (1=random,2=seq.) +.fi +.ih +DESCRIPTION +The \fIbfopen\fR procedure either opens an existing file for binary +file i/o (\fIacmode\fR 1=read-only or 3=read-write), or creates a new, +zero length file and opens it for binary file i/o with read-write +access mode (\fIacmode\fR 5=new-file). The \fIadvice\fR parameter +controls the size of the internal file buffer allocated at open time. +The possible values are 1 (random access, small buffer), or 2 (sequential +access, large buffer); anything larger is taken to be the actual size +of the buffer. Note that the size of the buffer must be an integral +multiple of the size of a disk block. +.ih +RETURN VALUE +The BFIO file descriptor (\fIfd\fR) is returned as the function value if +the file is successfully opened, otherwise a negative value is returned. +.ih +SEE ALSO +bfaloc, bfclos +.endhelp diff --git a/sys/imfort/doc/bfread.hlp b/sys/imfort/doc/bfread.hlp new file mode 100644 index 00000000..2345dfa3 --- /dev/null +++ b/sys/imfort/doc/bfread.hlp @@ -0,0 +1,31 @@ +.help bfread Sep86 imfort.bfio +.ih +NAME +bfread -- read from a binary file at the specified offset +.ih +SYNOPSIS +.nf +integer function bfread (fd, buf, nchars, offset) + +integer fd #I BFIO file descriptor of open file +typeless buf(*) #O buffer to receive file data +integer nchars #I number of SPP chars to read +integer offset #I 1-indexed char offset into file +.fi +.ih +DESCRIPTION +The \fIbfread\fR procedure reads \fInchars\fR char units of storage from +the file opened on file descriptor \fIfd\fR starting at the one-indexed +char file offset \fIoffset\fR. Any number of chars may be read starting +at any char file offset. +.ih +RETURN VALUE +The actual number of char units of storage read is returned as the function +value; a read at end of file results in zero chars being read. A negative +function value indicates that the read failed for some reason, e.g., the +file descriptor was invalid, the file offset was out of range, or an actual +physical read error occurred. +.ih +SEE ALSO +bfwrit +.endhelp diff --git a/sys/imfort/doc/bfwrit.hlp b/sys/imfort/doc/bfwrit.hlp new file mode 100644 index 00000000..510ad92f --- /dev/null +++ b/sys/imfort/doc/bfwrit.hlp @@ -0,0 +1,38 @@ +.help bfwrit Sep86 imfort.bfio +.ih +NAME +bfwrit -- write to a binary file at the specified offset +.ih +SYNOPSIS +.nf +integer function bfwrit (fd, buf, nchars, offset) + +integer fd #I BFIO file descriptor of open file +typeless buf(*) #I buffer containing file data +integer nchars #I number of SPP chars to be written +integer offset #I 1-indexed char offset into file + +.fi +.ih +DESCRIPTION +The \fIbfwrit\fR procedure writes \fInchars\fR char units of storage from +the user supplied buffer to the file opened on file descriptor \fIfd\fR +starting at the one-indexed char file offset \fIoffset\fR. Any number of +chars may be written starting at any char file offset. +.ih +RETURN VALUE +The actual number of char units of storage written is returned as the function +value; it is probably an error if this is not equal to \fInchars\fR. +A negative function value indicates that the write failed for some reason, +e.g., the file descriptor was invalid, the file offset was out of range, +or an actual physical write error occurred. +.ih +NOTES +The entire contents of the internal BFIO file buffer are always written, +even when writing at the end of file, hence it is not possible to write +odd-sized files with the BFIO interface (partial blocks can however be +read with \fIbfread\fR). +.ih +SEE ALSO +bfread +.endhelp diff --git a/sys/imfort/doc/clarg.hlp b/sys/imfort/doc/clarg.hlp new file mode 100644 index 00000000..c924ebc7 --- /dev/null +++ b/sys/imfort/doc/clarg.hlp @@ -0,0 +1,42 @@ +.help clarg Sep86 imfort +.ih +NAME +clarg -- fetch and decode the value of a command line argument +.ih +SYNOPSIS +.nf +subroutine clargc (argno, cval, ier) +subroutine clargi (argno, ival, ier) +subroutine clargr (argno, rval, ier) +subroutine clargd (argno, dval, ier) + +integer argno #I index of argument to be decoded +integer ier #O status return + +character*(*) cval #O string value of argument +integer ival #O integer value of argument +real rval #O real value of argument +doubleprecision dval #O double value of argument +.fi +.ih +DESCRIPTION +The four \fIclarg\fR procedures are used to fetch and decode the value of +the indexed command line argument; the first argument is number one. +Any argument may be returned as a string with \fIclargc\fR. +Numeric arguments are decoded using the IRAF formatted i/o primitives, +hence octal constants (`B' suffix), hex constants (`X' suffix), +and sexagesimal numbers are all legal as input. +.ih +RETURN VALUE +A status of zero indicates that the indexed argument was present on the +command line and could be decoded in the manner specified. + +.nf +IE_GCMDLN: cannot read command line string +IE_NEXARG: nonexistent command line argument referenced +IE_NONNUMARG: command line argument cannot be decoded as a number +.fi +.ih +SEE ALSO +clnarg, clrawc +.endhelp diff --git a/sys/imfort/doc/clnarg.hlp b/sys/imfort/doc/clnarg.hlp new file mode 100644 index 00000000..c7321931 --- /dev/null +++ b/sys/imfort/doc/clnarg.hlp @@ -0,0 +1,24 @@ +.help clnarg Sep86 imfort +.ih +NAME +clnarg -- get the number of arguments on the command line +.ih +SYNOPSIS +.nf +subroutine clnarg (nargs) + +integer nargs #O the number of arguments +.fi +.ih +DESCRIPTION +The \fIclnarg\fR subroutine returns the number of whitespace delimited +(or quoted) arguments given on the command line when the calling program +was invoked. +.ih +RETURN VALUE +The number of arguments, or zero if there were no arguments or if the +command line cannot be accessed for some reason (there is no error return). +.ih +SEE ALSO +clarg, clrawc +.endhelp diff --git a/sys/imfort/doc/clrawc.hlp b/sys/imfort/doc/clrawc.hlp new file mode 100644 index 00000000..09b2891d --- /dev/null +++ b/sys/imfort/doc/clrawc.hlp @@ -0,0 +1,35 @@ +.help clrawc Sep86 imfort +.ih +NAME +clrawc -- return the raw command line as a string +.ih +SYNOPSIS +.nf +subroutine clrawc (outstr, ier) + +character*(*) outstr #O receives the command line string +integer ier #O status return +.fi +.ih +DESCRIPTION +The \fIclrawc\fR procedure returns the raw command line as a string, +i.e., all the argument strings are concatenated together with spaces +between successive arguments. +.ih +RETURN VALUE +A status of zero indicates that the task was called with a nonnull command +string. An error status indicates that the program was called without any +arguments. + +IE_GCMDLN: cannot read command line string +.ih +NOTES +Normally it is preferable to use the \fIclarg\fR procedures to decode +and return the values of the individual arguments. Note that decoding +the argument list with a list-directed read against \fIoutstr\fR is in +violation of the Fortran 77 standard, and probably would not work anyhow, +since the string arguments are not quoted. +.ih +SEE ALSO +clnarg, clarg +.endhelp diff --git a/sys/imfort/doc/imacck.hlp b/sys/imfort/doc/imacck.hlp new file mode 100644 index 00000000..75e922c9 --- /dev/null +++ b/sys/imfort/doc/imacck.hlp @@ -0,0 +1,27 @@ +.help imacck Sep86 imfort +.ih +NAME +imacck -- determine if the named header keyword exists +.ih +SYNOPSIS +.nf +subroutine imacck (im, keyw, ier) + +integer im #I image descriptor of open image +character*(*) keyw #I name of keyword to be accessed +integer ier #O status return +.fi +.ih +DESCRIPTION +The \fIimacck\fR procedure is used to test if the named header keyword +can be accessed, i.e., if it exists. +.ih +RETURN VALUE +A zero status return indicates that the header does indeed have such a +keyword. + +IE_NEXKW: nonexistent header keyword referenced +.ih +SEE ALSO +imtypek, imaddk, imokwl +.endhelp diff --git a/sys/imfort/doc/imaddk.hlp b/sys/imfort/doc/imaddk.hlp new file mode 100644 index 00000000..e796d168 --- /dev/null +++ b/sys/imfort/doc/imaddk.hlp @@ -0,0 +1,55 @@ +.help imaddk Sep86 imfort +.ih +NAME +imaddk -- add a new keyword to an image header +.ih +SYNOPSIS +.nf +subroutine imaddk (im, keyw, dtype, comm, ier) + +integer im #I image descriptor of open image +character*(*) keyw #I name of the new keyword +integer dtype #I keyword datatype code +character*(*) comm #I comment string describing keyword +integer ier #O status return +.fi +.ih +DESCRIPTION +The \fIimaddk\fR procedure is used to add a new keyword to the header of +an existing, open image. The datatype of the new keyword must be specified +at creation time; the possible datatype codes for header keywords are given +in the following table. + +.nf + 1 boolean (logical) + 2 character string + 3,4,5 short integer, don't-care integer, long integer + 6,7 real or double precision floating +.fi + +A comment string may optionally be given to describ the keyword, i.e., +its function or purpose. The comment string is printed in image header +listings and is propagated onto FITS tapes. +.ih +RETURN VALUE +A zero status is returned if there is space for the new keyword, and the +keyword does not redefine an existing keyword. + +.nf +SYS_IDBREDEF: attempt to redefine an image header keyword +SYS_IDBOVFL: out of space in image header +.fi +.ih +NOTES +The precision of a keyword name is currently limited to eight characters +(longer keyword names will be silently truncated), and all user defined +keyword names are rendered into upper case. This is necessary to permit +use of the FITS image format to transport images. +An alternative to the relatively low level \fIimaddk\fR procedure is provided +by the \fIimakw\fR procedures, which will not add a new keyword if the named +keyword already exists, which also set the value of the new keyword, and which +avoid the need to use a datatype code. +.ih +SEE ALSO +imdelk, imacck, imakw +.endhelp diff --git a/sys/imfort/doc/imakw.hlp b/sys/imfort/doc/imakw.hlp new file mode 100644 index 00000000..cd447806 --- /dev/null +++ b/sys/imfort/doc/imakw.hlp @@ -0,0 +1,50 @@ +.help imakw Sep86 imfort +.ih +NAME +imakw -- add or set the value of an image header keyword +.ih +SYNOPSIS +.nf +subroutine imakwb (im, keyw, bval, comm, ier) +subroutine imakwc (im, keyw, cval, comm, ier) +subroutine imakwi (im, keyw, ival, comm, ier) +subroutine imakwr (im, keyw, rval, comm, ier) +subroutine imakwd (im, keyw, dval, comm, ier) + +integer im #I image descriptor of open image +character*(*) keyw #I name of the keyword to be set +character*(*) comm #I comment string describing keyword +integer ier #O status return + +logical bval #I logical (boolean) keyword value +character*(*) cval #I character string keyword value +integer ival #I integer keyword value +real rval #I real keyword value +doubleprecision dval #I double precision keyword value +.fi +.ih +DESCRIPTION +The \fIimakw\fR procedures are used to set the values of image header keywords. +If the named keyword does not already exist, a new keyword of the indicated +datatype is first added and then the value of the new keyword is set, +otherwise the value of the existing keyword is updated. +The comment string is used only if a new keyword is created. +Automatic datatype conversion is provided when updating the value of +an existing keyword, i.e., if the keyword already exists there is some +flexibility in the choice of the datatype of the \fIimakw\fR procedure +to be used. +.ih +RETURN VALUE +A zero status is returned if the named keyword exists, is writable, and if +the datatype coercion implied is permissible, or if the named keyword is +not found but can be added. + +.nf +SYS_IDBOVFL: out of space in image header +SYS_IDBREDEF: attempt to redefine an image header keyword +SYS_IDBTYPE: illegal header parameter data type conversion +.fi +.ih +SEE ALSO +imaddk, imacck, impkw, imgkw +.endhelp diff --git a/sys/imfort/doc/imclos.hlp b/sys/imfort/doc/imclos.hlp new file mode 100644 index 00000000..c771a961 --- /dev/null +++ b/sys/imfort/doc/imclos.hlp @@ -0,0 +1,39 @@ +.help imclos Sep86 imfort +.ih +NAME +imclos -- close an image +.ih +SYNOPSIS +.nf +subroutine imclos (im, ier) + +integer im #I image descriptor of open image +integer ier #O status return +.fi +.ih +DESCRIPTION +An image opened with \fIimopen\fR or \fIimopnc\fR should be closed with +\fIimclos\fR when the image operation is complete. The close operation +flushes any buffered output pixel data, updates the header if necessary, +closes the header and pixel files, and frees any system resources +associated with the image descriptor. +.ih +RETURN VALUE +A zero status is returned if the image descriptor is valid and the header +and pixel files could be updated and closed without any errors. + +.nf +IE_CLSHDR: error closing image header file +IE_CLSPIX: error closing image pixel file +IE_UPDHDR: error updating image header file +IE_UPDRO: image header modified but image was opened read only +.fi +.ih +NOTES +If an image is erroneously opened read-only by a program which updates the +image header, no error condition will occur until the image is closed, +hence the \fIimclos\fR status return should always be checked. +.ih +SEE ALSO +imopen, imopnc +.endhelp diff --git a/sys/imfort/doc/imcrea.hlp b/sys/imfort/doc/imcrea.hlp new file mode 100644 index 00000000..9b7381f7 --- /dev/null +++ b/sys/imfort/doc/imcrea.hlp @@ -0,0 +1,55 @@ +.help imcrea Nov86 imfort +.ih +NAME +imcrea -- create a new image +.ih +SYNOPSIS +.nf +subroutine imcrea (image, axlen, naxis, dtype, ier) + +character*(*) image #I host name of the new image +integer axlen(7) #I length of each axis +integer naxis #I number of axes +integer dtype #I pixel datatype +integer ier #O status return +.fi +.ih +DESCRIPTION +The \fIimcrea\fR procedure is used to create a new image from scratch, +using only the information passed via the command line arguments. +The image name \fIimname\fR is the host system filename of the new image, +although the extension (".imh") may be omitted if desired. The dimensionality +of the new image is given by \fInaxis\fR, and the length in pixels of each +axis is given by the first few elements of the array \fIaxlen\fR. +In the current implementation of IMFORT the dimensionality of an image +should not exceed three. There are no restrictions on the size of an image. + +The datatype to be used to store the pixels in the new image is given by +the integer code \fIdtype\fR. Only two pixel datatypes are currently +supported, i.e., \fIdtype\fR=3 for short integer pixels, and \fIdtype\fR=6 +for type real pixels. + +Both the image header file and the pixel file are created, and storage is +allocated for the pixel array in the pixel file. A subsequent call to +\fIimopen\fR is required to access the new image. The size, dimensionality, +and datatype of the new image cannot be changed once the image has been +created. +.ih +RETURN VALUE +A nonzero error code is returned if either the header file or the pixel +file cannot be created for some reason, or if any of the input arguments +are invalid. + +.nf +IE_NAXIS: wrong number of axes on image +IE_AXLEN: length of each image axis must be .ge. 1 +IE_PIXTYPE: image pixel type must be short or real +IE_CREHDR: cannot create image +IE_WRHDR: error writing to image header file +IE_ALCPIX: cannot create or allocate space for pixel file +IE_ACCPIX: error writing into pixel file during image create +.fi +.ih +SEE ALSO +imopen, imopnc, imdele, imrnam +.endhelp diff --git a/sys/imfort/doc/imdele.hlp b/sys/imfort/doc/imdele.hlp new file mode 100644 index 00000000..b80e5692 --- /dev/null +++ b/sys/imfort/doc/imdele.hlp @@ -0,0 +1,29 @@ +.help imdele Sep86 imfort +.ih +NAME +imdele -- delete an image +.ih +SYNOPSIS +.nf +subroutine imdele (image, ier) + +character*(*) image #I host name of image to be deleted +integer ier #O status return +.fi +.ih +DESCRIPTION +The \fIimdele\fR procedure deletes an image, i.e., the both the header file +and the pixel file (if any). +.ih +RETURN VALUE +A zero status is returned if the image exists and was successfully deleted. +It is not an error if there is no pixel file. + +.nf +IE_IMDELNEXIM: attempt to delete a nonexistent image +IE_IMDELETE: cannot delete image +.fi +.ih +SEE ALSO +imrnam, imcrea +.endhelp diff --git a/sys/imfort/doc/imdelk.hlp b/sys/imfort/doc/imdelk.hlp new file mode 100644 index 00000000..d654447e --- /dev/null +++ b/sys/imfort/doc/imdelk.hlp @@ -0,0 +1,36 @@ +.help imdelk Sep86 imfort +.ih +NAME +imdelk -- delete a header keyword +.ih +SYNOPSIS +.nf +subroutine imdelk (im, keyw, ier) + +integer im #I image descriptor of open image +character*(*) keyw #I name of keyword to be deleted +integer ier #O status return +.fi +.ih +DESCRIPTION +The \fIimdelk\fR procedure is used to delete a user defined image header +keyword, e.g., a keyword previously created with \fIimaddk\fR or with one +of the \fIimakw\fR procedures. +.ih +RETURN VALUE +A zero status is returned if the named keyword existed, was a user defined +keyword (rather an a protected system keyword), and was successfully deleted. + +.nf +SYS_IDBNODEL: cannot delete image header keyword +SYS_IDBDELNXKW: attempt to delete a nonexistent image header keyword +.fi +.ih +NOTES +It is not an error to delete a keyword from the header of an image opened for +read-only access, but an error status will be returned at \fIimclos\fR or +\fIimflsh\fR time since the header cannot be updated on disk. +.ih +SEE ALSO +imaddk, imakw, imacck +.endhelp diff --git a/sys/imfort/doc/imemsg.hlp b/sys/imfort/doc/imemsg.hlp new file mode 100644 index 00000000..32b1677c --- /dev/null +++ b/sys/imfort/doc/imemsg.hlp @@ -0,0 +1,31 @@ +.help imemsg Sep86 imfort +.ih +NAME +imemsg -- convert an IMFORT error code into an error message +.ih +SYNOPSIS +.nf +subroutine imemsg (ier, errmsg) + +integer ier #I an IMFORT error code +character*(*) errmsg #O the corresponding error message +.fi +.ih +DESCRIPTION +The \fIimemsg\fR procedure converts a positive integer error code, +such as is returned by the IMFORT procedures in the event of an error, +into the corresponding error message string. In cases where the error +was associated with a named object, e.g., a file or image, the operand +name will be enclosed in parenthesis and appended to the base error +message string returned to the user. +.ih +RETURN VALUE +The error message string, or "imfort error (unrecognized error code)" if +called with an unknown error code. +.ih +SEE ALSO +.nf +The individual manual pages for the symbolic names of the error codes +imfort$imfort.h and lib$syserr.h for the integer error codes. +.fi +.endhelp diff --git a/sys/imfort/doc/imflsh.hlp b/sys/imfort/doc/imflsh.hlp new file mode 100644 index 00000000..d1d184f3 --- /dev/null +++ b/sys/imfort/doc/imflsh.hlp @@ -0,0 +1,39 @@ +.help imflsh Sep86 imfort +.ih +NAME +imflsh -- flush any buffered image data to disk +.ih +SYNOPSIS +.nf +subroutine imflsh (im, ier) + +integer im #I image descriptor of open image +integer ier #O status return +.fi +.ih +DESCRIPTION +The \fIimflsh\fR procedure flushes any buffered image data to disk. Both the +image header and pixel file are updated if either has been modified since +the image was opened, or since the last call to \fIimflsh\fR. All buffered +image data is automatically flushed when an image is closed with \fIimclos\fR. +Explicit calls to \fIimflsh\fR are rarely needed since synchronization occurs +automatically when the image is closed, but may be desirable in applications +where the image will be open for a substantial period of time, increasing the +possibility of a program abort or interrupt before the image is closed. +Calling \fIimflsh\fR on an image opened for read-only access is harmless. +.ih +RETURN VALUE +A zero status is returned if no image data has been modified and an update +is not necessary, or if either the header or pixel data has been modified and +the update was successful. The most likely cause of an update failure is lack +of write permission on the image. + +.nf +IE_FLUSH: error flushing buffered data to pixel file +IE_UPDHDR: error updating image header file +IE_UPDRO: image header modified but image was opened read only +.fi +.ih +SEE ALSO +imclos +.endhelp diff --git a/sys/imfort/doc/imfort.hd b/sys/imfort/doc/imfort.hd new file mode 100644 index 00000000..c37b96cd --- /dev/null +++ b/sys/imfort/doc/imfort.hd @@ -0,0 +1,44 @@ +# Helpdir for the IMFORT package. + +zawset hlp = doc$zawset.hlp, src = os$zawset.c + +$imfort = "sys$imfort/" +$doc = "sys$imfort/doc/" + +bfaloc hlp = doc$bfaloc.hlp, src = imfort$bfaloc.x +bfbsiz hlp = doc$bfbsiz.hlp, src = imfort$bfbsiz.x +bfchan hlp = doc$bfchan.hlp, src = imfort$bfchan.x +bfclos hlp = doc$bfclos.hlp, src = imfort$bfclos.x +bfflsh hlp = doc$bfflsh.hlp, src = imfort$bfflsh.x +bffsiz hlp = doc$bffsiz.hlp, src = imfort$bffsiz.x +bfopen hlp = doc$bfopen.hlp, src = imfort$bfopen.x +bfread hlp = doc$bfread.hlp, src = imfort$bfread.x +bfwrit hlp = doc$bfwrit.hlp, src = imfort$bfwrit.x +clarg hlp = doc$clarg.hlp, src = imfort$clarg.x +clnarg hlp = doc$clnarg.hlp, src = imfort$clnarg.x +clrawc hlp = doc$clrawc.hlp, src = imfort$clrawc.x +imacck hlp = doc$imacck.hlp, src = imfort$imacck.x +imaddk hlp = doc$imaddk.hlp, src = imfort$imaddk.x +imakw hlp = doc$imakw.hlp, src = imfort$imakw.x +imclos hlp = doc$imclos.hlp, src = imfort$imclos.x +imcrea hlp = doc$imcrea.hlp, src = imfort$imcrea.x +imdele hlp = doc$imdele.hlp, src = imfort$imdele.x +imdelk hlp = doc$imdelk.hlp, src = imfort$imdelk.x +imemsg hlp = doc$imemsg.hlp, src = imfort$imemsg.x +imflsh hlp = doc$imflsh.hlp, src = imfort$imflsh.x +imgkw hlp = doc$imgkw.hlp, src = imfort$imgkw.x +imgl hlp = doc$imgl.hlp, src = imfort$imgl.x +imgs hlp = doc$imgs.hlp, src = imfort$imgs.x +imgsiz hlp = doc$imgsiz.hlp, src = imfort$imgsiz.x +imhcpy hlp = doc$imhcpy.hlp, src = imfort$imhcpy.x +imokwl hlp = doc$imokwl.hlp, src = imfort$imokwl.x +imgnkw hlp = doc$imokwl.hlp, src = imfort$imokwl.x +imckwl hlp = doc$imokwl.hlp, src = imfort$imokwl.x +imopen hlp = doc$imopen.hlp, src = imfort$imopen.x +imopnc hlp = doc$imopnc.hlp, src = imfort$imopnc.x +impixf hlp = doc$impixf.hlp, src = imfort$impixf.x +impkw hlp = doc$impkw.hlp, src = imfort$impkw.x +impl hlp = doc$impl.hlp, src = imfort$impl.x +imps hlp = doc$imps.hlp, src = imfort$imps.x +imrnam hlp = doc$imrnam.hlp, src = imfort$imrnam.x +imtypk hlp = doc$imtypk.hlp, src = imfort$imtypk.x diff --git a/sys/imfort/doc/imfort.ms b/sys/imfort/doc/imfort.ms new file mode 100644 index 00000000..cc0c1919 --- /dev/null +++ b/sys/imfort/doc/imfort.ms @@ -0,0 +1,1711 @@ +.RP +.TL +A User's Guide to Fortran Programming in IRAF +.br +The IMFORT Interface +.AU +Doug Tody +.AI +.K2 "" "" "*" +September 1986 + +.AB +The IMFORT interface is a Fortran programming environment suitable for general +Fortran programming, with special emphasis on batch image processing. +IMFORT is intended for use primarily by the scientist/user who occasionally +needs to write a program for their own personal use, but who does not program +often enough to make it worthwhile learning a larger, more complex but fully +featured programming environment. IMFORT is therefore a small interface which +is easy to learn and use, and which relies heavily upon host system (non-IRAF) +facilities which the user is assumed to already be familiar with. +Facilities are provided for accessing command line arguments, reading and +writing IRAF images, and returning output to the CL. Provisions are made +for editing, compiling, linking, and debugging programs without need to leave +the IRAF environment, making use of familiar host system editing and debugging +tools wherever possible. +.AE + +.NH +Introduction +.PP +The IMFORT interface is a library of Fortran callable subroutines which can +be called from a host system Fortran program to perform such operations as +fetching the arguments given on the command line when the task was invoked, +or accessing the header or pixel information in an IRAF image (bulk data frame). +Since the result is a host program rather than an IRAF program, only limited +access to the facilities provided by the runtime IRAF system is possible, +but on the other hand one has full access to the facilities provided by the +host system. Programs which use IMFORT may be run as ordinary host system +programs outside of IRAF, or may be interfaced to the IRAF command language +(CL) as CL callable tasks. Within the IRAF environment these user written, +non-IRAF tasks behave much like ordinary IRAF tasks, allowing background +execution, use of i/o redirection and pipes, evaluation of expressions on +the command line, programmed execution in scripts, and so on. + +.NH 2 +Who Should Use IMFORT +.PP +The most significant feature of the IMFORT interface is that it is designed +for use by \fIhost\fR Fortran programs. The scientist/user will often already +be using such programs when IRAF becomes available. IMFORT allows these +pre-existing programs to be modified to work within the IRAF environment +with a minimum of effort and with minimum changes to the existing program. +The only alternative is to rework these programs as \fIIRAF\fR programs, +but few existing Fortran programs could (or should) survive such a transition +without being completely rewritten. If the program in question is useful +enough such a rewrite might be warranted, but in most cases this will not +be practical, hence something like the IMFORT interface is clearly needed +to keep these old programs alive until they are no longer needed. +.PP +The second goal of the IMFORT interface is to provide a way for the user to +add their own programs to IRAF without having to invest a lot of time learning +the full blown IRAF programming environment. IMFORT makes it possible for +the user to begin writing useful programs within hours of their first exposure +to the system. It is possible that the IMFORT interface will provide all the +capability that some users will ever need, especially when supplemented by other +(non-IRAF) Fortran callable libraries available on the local host machine. +Programs developed in this way are bound to have portability and other +problems, but it should be up to the developer and user of the software to +decide whether these problems are worth worrying about. IMFORT is simply +a \fItool\fR, to be used as one sees fit; there is no attempt to dictate to +the user how they should write their programs. +.PP +The alternative to IMFORT, if applications programming within IRAF is the goal, +is the IRAF SPP/VOS programming environment. The SPP/VOS programming +environment is a fully featured scientific programming environment which +carefully addresses all the software engineering issues avoided by IMFORT. +The VOS is a large and complex environment and therefore takes longer to learn +than IMFORT, but it provides all the facilities needed by large applications +hence is \fIeasier\fR to use than simpler interfaces like IMFORT, if one is +faced with the already difficult task of coding a large program or package. +Furthermore, the SPP/VOS environment fully addresses the problems of +portability and device independence, critical issues for applications which +must be supported and used simultaneously on a range of machines over a +period of years, during which time the software is likely to be continually +evolving. An overview of the SPP/VOS programming environment is given in +\fIThe IRAF Data Reduction and Analysis System\fR, February 1986, by the author. +.PP +In summary, IMFORT is intended for use to interface old Fortran programs to +IRAF with a minimum of effort, and as an entry level programming environment +which new users can learn to use in a few hours. Experienced users, +professional programmers, and developers of large applications will find that +they can accomplish more with less effort once they have learned to use the +more fully featured SPP/VOS programming environment. + +.bp +.NH +Getting Started +.PP +Although programs which use IMFORT can and often will be invoked from the +host system command interpreter, it is likely that such programs will also +be used interactively in combination with the tasks provided by the standard +IRAF system. For example, the IRAF graphics and image display facilities +are likely to be used to examine the results of an image operation performed +by a user written Fortran/IMFORT program. Indeed, the standard IRAF tasks +are likely to be used for testing new IMFORT programs as well as reducing data +with old ones, so we shall assume that software development will take place +from within the IRAF environment. Since IRAF provides full access to the +facilities of the host system at all times, there is little reason not to +work from within the IRAF environment. +.PP +As a first step, let's see what is required to enter, compile, link, and +execute a small Fortran program which does nothing more than print the +message \fLhello, world!\fR on the terminal. We shall assume that the +reader has read the \fICL User's Guide\fR and is already familiar with +basic CL command entry, the OS escape facility, the editor interface and so on. +The first step is to call up the editor to enter the program into a file: +.DS +\fLcl> edit hello.f\fR +.DE +Note that the filename extension is ".f", which is what IRAF uses for +Fortran files. The extension will be mapped into the local host system +equivalent when IRAF communicates with the host system, but when working +in the IRAF environment the IRAF name should be used. +.LP +Once in the editor, enter the following program text: +.DS +\fLprogram hello +write (*,*) 'hello, world!' +stop +end\fR +.DE +The next step is to compile and link the \fLhello\fR program. This is done +by the command \fIfc\fR (\fIf\fRortran-\fIc\fRompile), which produces an +object file \fLhello.o\fR and an executable program file \fLhello.e\fR. +Note that the \fIfc\fR task is defined in the default \fIuser\fR package in +your \fLLOGIN.CL\fR file, hence a \fImkiraf\fR may be required to regenerate +the \fLLOGIN.CL\fR file if the file is old or has been modified. +.DS +\fLcl> fc hello.f\fR +.DE +Since the \fLhello\fR program is a host Fortran program, it can be executed +immediately with an OS escape, e.g., \fL!hello.e\fR on UNIX, or +\fL!run hello\fR on VMS. A better approach if the task has command line +arguments is to use the IRAF \fIforeign task\fR facility to define the +program as a new IRAF task, as we shall see in the next section. + +.NH 2 +Example 1: Plotting a function +.PP +As a slightly more complicated example, let's construct a program to compute +and plot a function using command line arguments to input the function +parameters, with output consisting of a simple ASCII table sampling the +computed function. Our example computes the Planck function, which gives the +emissivity of a blackbody as a function of wavelength and temperature. +The sample program is shown in Figure 1. Source code for this and all other +examples in this paper may be found in the IRAF directory \fLimfort$tasks\fR. + +.DS +\fL +.ps 8 +.vs 9p +c PLANCK -- Compute the Planck blackbody radiation distribution for a +c given temperature and wavelength region. +c +c usage: planck temperature lambda1 lambda2 +c +c The temperature is specified in degrees Kelvin and the wavelength +c region in microns (1u=10000A). 100 [x,y] data points defining the +c curve are output. +c ---------------------------------------------------------------------- + + program planck + + character*80 errmsg + integer nargs, ier, i + real w1, w2, dw, cm, t + real xv(100), yv(100) + +c --- Get the temperature in degrees kelvin. + call clargr (1, t, ier) + if (ier .ne. 0) then + write (*, '('' temperature (degrees kelvin): '',$)') + read (*,*) t + endif + +c --- Get the wavelength region to be computed. + call clnarg (nargs) + if (nargs .ge. 3) then + call clargr (2, w1, ier) + if (ier .ne. 0) goto 91 + call clargr (3, w2, ier) + if (ier .ne. 0) goto 91 + else + write (*, '('' start wavelength (microns): '',$)') + read (*,*) w1 + write (*, '('' end wavelength (microns): '',$)') + read (*,*) w2 + endif + +c --- Compute the blackbody curve. + dw = (w2 - w1) / 99.0 + do 10 i = 1, 100 + xv(i) = ((i-1) * dw) + w1 + cm = xv(i) * 1.0E-4 + yv(i) = (3.74185E-5 * (cm ** -5)) / + * (2.71828 ** (1.43883 / (cm * t)) - 1.0) + 10 continue + +c --- Print the curve as a table. + do 20 i = 1, 100 + write (*, '(f7.4, g12.4)') xv(i), yv(i) + 20 continue + + stop + +c --- Error exit. + 91 call imemsg (ier, errmsg) + write (*, '('' Error: '', a80)') errmsg + stop + end\fR +.DE +.vs +.ps +.sp +.ce +Figure 1. Sample program to compute the Planck function\(dd +.FS +\(ddThe trailing \fL$\fR carriage control code used in the format strings in +the \fLWRITE\fR statements in this and the other sample Fortran programs +is nonstandard Fortran and may not be available on all host machines. +Its function is to defeat the carriage-return linefeed so that the user's +response may be entered on the same line as the prompt. +.FE + +.PP +This example serves to demonstrate the use of the IMFORT \fIclarg\fR procedures +to fetch the command line arguments, and the use of i/o redirection to capture +the output to generate the plot. The command line to an IMFORT program consists +of a sequence of arguments delimited by spaces or tabs. The subroutine +\fIclnarg\fR returns the number of arguments present on the command line when +the task was called. The \fIclargr\fR, \fIclargi\fR, etc. procedures fetch +and decode the values of the individual arguments. Virtually all IMFORT +procedures include an integer output variable \fIier\fR in their argument list; +a zero status indicates success, anything else indicates failure and the actual +error code identifies the cause of the problem. The \fIimemsg\fR procedure +may be called to convert IMFORT error codes into error message strings, as in +the example. +.PP +Once the program has been entered and compiled and linked with \fIfc\fR, +we must declare the program as a foreign task to the CL. If this is not +done the program can still be run via an OS escape, but none of the advanced +CL features will be available, e.g., background execution, command line +expression evaluation, i/o redirection, and so on. The technique used to +declare a foreign task is machine dependent since it depends upon the syntax +of the host command interpreter. For example, to declare the new CL foreign +task \fIplanck\fR on a UNIX system, we enter the following command: +.DS +\fLcl> task $planck = $planck.e\fR +.DE +The same thing can be achieved on a VMS system with the following +declaration (it can be simplified by moving the VMS foreign task declaration +to your \fLLOGIN.COM\fR file): +.DS +\fLcl> task $planck = "$planck:==\\\\$\fIdisk\fP:[\fIdir\fP...]planck.exe!planck"\fR +.DE +The \fL$\fR characters are required to tell the CL that the new task does +not have a parameter file, and is a foreign task rather than a regular +IRAF task. The \fL!\fR in the VMS example is used to delimit multiple DCL +commands; the command shown defines the DCL foreign task \fIplanck\fR and +then executes it. The use of the \fItask\fR statement to declare foreign +tasks is discussed in detail in \(sc3.3. +.PP +We have written the program in such a way that the arguments will be queried +for if not given on the command line, so if we enter only the name of the +command, an interaction such as the following will occur: +.DS +\fLcl> planck +temperature (degrees kelvin): 3000 +start wavelength (microns): .1 +end wavelength (microns): 4\fR +.DE +Note that if the output of the \fIplanck\fR task is redirected this input +mechanism will \fInot\fR work, since the queries will be redirected along +with the output. Hence if we use a pipe to capture the output, as in the +following example, the arguments must be given on the command line. +.DS +\fLcl> planck 3000 0.1 4.0 | graph +.DE +This command will compute and plot the emissivity for a 3000 degree kelvin +blackbody from 0.1 to 4.0 microns (1000 to 40000 angstroms). +.PP +An interesting alternative way to implement the above program would be to +output the function curve as a line in an image, rather than as a table of +numbers. For example, a two dimensional image could be generated wherein +each line corresponds to a different temperature. \fIGraph\fR or \fIimplot\fR +could then be used to plot curves or overplot families of curves; this would +be more efficient than the technique employed in our sample program. +Image access via IMFORT is illustrated in our next example. + +.NH 2 +Example 2: Compute the range of pixel values in an image +.PP +The program shown in Figure 2 opens the named image, examines each line in +the image to determine the minimum and maximum pixel values, keeping a running +tally until the entire image has been examined (there is no provision for +detecting and ignoring bad pixels in the image). The newly computed minimum +and maximum pixel values are then updated in the image header as well as +printed on the standard output. +.DS +\fL +.ps 8 +.vs 9p +c MINMAX -- Compute the minimum and maximum pixel values in an image. +c The new values are printed as well as updated in the image header. +c +c usage: minmax image +c ---------------------------------------------------------------------- + + program minmax + + character*80 image, errmsg + real pix(4096), dmin, dmax, vmin, vmax + integer im, axlen(7), naxis, dtype, ier, j + +c --- Get image name. + call clargc (1, image, ier) + if (ier .ne. 0) then + write (*, '('' enter image name: '',$)') + read (*,*) image + endif + +c --- Open the image for readwrite access (we need to update the header). + call imopen (image, 3, im, ier) + if (ier .ne. 0) goto 91 + call imgsiz (im, axlen, naxis, dtype, ier) + if (ier .ne. 0) goto 91 + +c --- Read through the image and compute the limiting pixel values. + do 10 j = 1, axlen(2) + call imgl2r (im, pix, j, ier) + if (ier .ne. 0) goto 91 + call alimr (pix, axlen(1), vmin, vmax) + if (j .eq. 1) then + dmin = vmin + dmax = vmax + else + dmin = min (dmin, vmin) + dmax = max (dmax, vmax) + endif + 10 continue + +c --- Update the image header. + call impkwr (im, 'datamin', dmin, ier) + if (ier .ne. 0) goto 91 + call impkwr (im, 'datamax', dmax, ier) + if (ier .ne. 0) goto 91 + +c --- Clean up. + call imclos (im, ier) + if (ier .ne. 0) goto 91 + write (*, '(a20, 2 g12.5)') image, dmin, dmax + stop + +c --- Error exit. + 91 call imemsg (ier, errmsg) + write (*, '('' Error: '', a80)') errmsg + stop + end\fR +.DE +.vs +.ps +.sp +.ce +Figure 2. Compute the min and max pixel values in an image + +.PP +The program as written can only deal with images of one or two dimensions, +of pixel type short (16 bit integer) or real (32 bit floating), with a line +length not to exceed 4096 pixels per line. We could easily change the program +to deal with images of up to three dimensions, but the IMFORT interface does +not provide dynamic memory allocation facilities so there is always going +to be an upper limit on the line length if we use the simple get line i/o +procedure \fIimgl2r\fR, as shown. The use of fixed size buffers simplifies +the program, however, and is not expected to be a serious problem in most +IMFORT applications. +.PP +The \fIalimr\fR subroutine in the previous example is from the IRAF VOPS +(vector operators) package. The function of \fIalimr\fR is to compute +the limiting (min and max) pixel values in a vector of type real, the +function type being indicated by the \fIlim\fR, and the pixel datatype by +the \fIr\fR. The VOPS package provides many other such vector operators, +and is discussed further in \(sc 4.4. + +.NH 2 +Example 3: Copy an image +.PP +Our final example (Figure 3) shows how to create a new image as a copy of +some existing image. This can be used as a template to create any binary +image operator, i.e., any program which computes some transformation upon +an existing image, writing a new image as output. +.PP +By now the functioning of this procedure should be self evident. +The only thing here which is at all subtle is the subroutine \fIimopnc\fR, +used to open (create) a new copy of an existing image. The open new copy +operation creates a new image the same size and datatype as the old +image, and copies the image header of the old image to the new image. +Any user keywords in the header of the old image will be automatically +passed to the new image, without requiring that the calling program +have explicit knowledge of the contents of the image header. +.PP +Note that the program is written to work only on pixels of type real, +hence will be inefficient if used to copy images of type short-integer. +A more efficient approach for a general image copy operator would be +to add a conditional test on the variable \fLdtype\fR, executing a +different copy-loop for each datatype, to avoid having to convert from +integer to real and back again when copying a short-integer image. +The short-integer equivalents of \fIimgl3r\fR (get line, 3 dim image, +type real) and \fIimpl3r\fR (put line, 3 dim image, type real) are +called \fIimgl3s\fR and \fIimpl3s\fR. +.PP +The program as written will work for images of up to three dimensions, +even though it is written to deal with only the three dimensional case. +This works because the length of the "unused" axes in an image is +set to one when the image is created. A program passed an image of +higher dimension than it is written for will also work, but will not +process all of the data. IMFORT does not support image sections, +so only the first few lines of the image will be accessible to such +a program. + +.PP +Additional useful examples of Fortran programs using IMFORT are given in +\fLimfort$tasks\fR. These include utility programs to make test images, +print the contents of an image header, print the values of the pixels in +a subraster, and so on. You may wish to copy the source for these to your +own workspace for use as is, or for use as templates to construct similar +programs. + +.DS +\fL +.ps 8 +.vs 9p +c IMCOPY -- Copy an image. Works for images of up to three dimensions +c with a pixel type of short or real and up to 4096 pixels per line. +c +c usage: imcopy oldimage newimage +c --------------------------------------------------------------------- + + program imcopy + + real pix(4096) + character*80 oimage, nimage, errmsg + integer ncols, nlines, nbands, j, k, oim, nim + integer ier, axlen(7), naxis, dtype, nargs + +c --- Get command line arguments. + call clnarg (nargs) + if (nargs .eq. 2) then + call clargc (1, oimage, ier) + if (ier .ne. 0) goto 91 + call clargc (2, nimage, ier) + if (ier .ne. 0) goto 91 + else + write (*, '('' input image: '',$)') + read (*,*) oimage + write (*, '('' output image: '',$)') + read (*,*) nimage + endif + +c --- Open the input image and create a new-copy output image. + call imopen (oimage, 1, oim, ier) + if (ier .ne. 0) goto 91 + call imopnc (nimage, oim, nim, ier) + if (ier .ne. 0) goto 91 + +c --- Determine the size and pixel type of the image being copied. + call imgsiz (oim, axlen, naxis, dtype, ier) + if (ier .ne. 0) goto 91 + + ncols = axlen(1) + nlines = axlen(2) + nbands = axlen(3) + +c --- Copy the image. + do 15 k = 1, nbands + do 10 j = 1, nlines + call imgl3r (oim, pix, j, k, ier) + if (ier .ne. 0) goto 91 + call impl3r (nim, pix, j, k, ier) + if (ier .ne. 0) goto 91 + 10 continue + 15 continue + +c --- Clean up. + call imclos (oim, ier) + if (ier .ne. 0) goto 91 + call imclos (nim, ier) + if (ier .ne. 0) goto 91 + + stop + +c --- Error actions. + 91 call imemsg (ier, errmsg) + write (*, '('' Error: '', a80)') errmsg + stop + end\fR +.DE +.vs +.ps +.sp +.ce +Figure 3. Image copy program + +.bp +.NH +The IMFORT Programming Environment +.PP +IRAF provides a small programming environment for the development of host +Fortran programs using the IMFORT interface. This environment consists +of the general CL tools, e.g., the editor, the \fIpage\fR and \fIlprint\fR +tasks, etc., plus a few special tools, namely, the \fIfc\fR compile/link +utility and the foreign task facility. In this section we discuss these +special tools and facilities. Information is also provided for linking +to the IMFORT libraries if program development is to take place at the host +system level. +.PP +The classic third generation program development cycle (ignoring such minor +details as designing the software) is edit \(em compile/link \(em debug. +The edit phase uses the CL \fIedit\fR task, an interface to the host system +editor of choice. The compile/link phase is performed by the \fIfc\fR utility. +The debug phase is optional and is generally only necessary for large programs. +The host system debug tool is used; while IRAF does not provide a special +interface to the host debug tool, one can easily be constructed using the +foreign task facility if desired. +.PP +Programs which use the IMFORT interface are inevitably host system dependent +to some degree, since they are host programs. In the interests of providing +the user with concrete examples, the discussion in this section must therefore +delve into the specifics of certain host operating systems. We have chosen +to use UNIX and VMS in the examples, since most IRAF implementations run on +one or the other of these operating systems. The ties between the IMFORT +programming environment and the host system are quite simple, however, so it +should not be difficult to see how to modify the examples for a different host. + +.NH 2 +The FC Compile/Link Utility +.PP +The \fIfc\fR utility provides a consistent, machine independent interface to +the host system compiler and linker which is convenient and easy to use. +In addition, \fIfc\fR provides a means for linking host programs with the +IRAF libraries without having to type a lot, and without having to build +host command scripts. All of the IRAF libraries are accessible via \fIfc\fR, +not just IMFORT (\fLlib$libimfort.a\fR) and the IRAF system libraries used +by IMFORT, but all the other IRAF libraries as well, e.g., the math libraries. +.PP +The default action of \fIfc\fR is to compile and link the files listed on the +command line, i.e., source files in various languages, object modules, and +libraries. Any source files are first turned into object modules, then the +objects are linked in the order given, searching any libraries in the order +in which they are encountered on the command line (the IMFORT libraries are +searched automatically, after any libraries listed on the command line). +By default, the root name of the new executable will be the same as that of +the first file listed on the command line; a different name may be assigned +with the \fI-o\fR switch if desired. +.LP +The syntax of the \fIfc\fR command is as follows: +.DS +\fLfc [\fIswitches\fP] \fIfile\fL [\fIfile ...\fL] [-o \fIexefile\fL]\fR +.DE +The most interesting switches are as follows: +.in 0.5i +.IP \fB-c\fR +Compile but do not link. +.IP \fB-l\fIlibrary\fR +.br +Link to the named IRAF library. On a UNIX host this switch may also be +used to reference the UNIX libraries. The \fI-llibrary\fR reference +should be given in the file list at the point at which you want the +library to be searched. The \fI-l\fR causes \fIfc\fR to look in a set +of standard places for the named library; user libraries should be +referenced directly by the filename of the library. +.IP \fB-o\fR\ \fIexefile\fR +.br +Override the default name for the executable file produced by the linker. +.IP \fB-x\fR +Compile and link for debugging. +.in + +.LP +Since the \fIfc\fR command line can contain many different types of objects, +a filename extension is required to identify the object type. The IRAF +filename extensions \fImust\fR be used; these are listed in the table below. + +.TS +box center; +cb s +ci | ci +c | l. +IRAF Filename Extensions +_ +extn usage += +\.a object library +\.c C source file +\.e executable +\.f Fortran source file +\.o object module +\.s Assembler source file +\.x SPP source file +.TE + +.PP +The \fIfc\fR utility is easy to learn and use. Here are a few examples +illustrating the most common usage of the utility. To compile and link the +Fortran program \fLprog.f\fR, producing the executable program \fLprog.e\fR: +.DS +\fLcl> fc prog.f\fR +.DE +To compile the file \fLutil.f\fR to produce the object \fLutil.o\fR, +without linking anything: +.DS +\fLcl> fc -c util.f\fR +.DE +To link \fLprog.o\fR and \fLutil.o\fR, producing the executable program +\fLprog.e\fR: +.DS +\fLcl> fc prog.o util.o\fR +.DE +To do the same thing, producing an executable named \fLfoo.e\fR instead +of \fLprog.e\fR: +.DS +\fLcl> fc prog.o util.o -o foo.e\fR +.DE +To compile and link \fLprog.f\fR for debugging: +.DS +\fLcl> fc -x prog.f\fR +.DE +To link \fLprog.o\fR with the IRAF library \fLlib$libdeboor.a\fR (the DeBoor +spline package), producing the executable \fLprog.e\fR as output: +.DS +\fLcl> fc prog.o -ldeboor\fR +.DE +To do the same thing, spooling the output in the file \fLspool\fR and +running the whole thing in the background: +.DS +\fLcl> fc prog.o -ldeboor >& spool &\fR +.DE +To link instead with the library \fLlibfoo.a\fR, in the current directory +(note that in this case the library is a module and not a switch): +.DS +\fLcl> fc prog.o libfoo.a\fR +.DE +.LP +Just about any combination of switches and modules that makes sense will +work. The order of libraries in the argument list is important, as they +will be searched in the order in which they are listed on the command line. +.PP +The \fIfc\fR utility is actually just a front-end to the standard IRAF +compiler \fIxc\fR, as we shall see in \(sc3.3. See the manual page for +\fIxc\fR for additional information. + +.NH 2 +Host Level Linking to the IMFORT Libraries +.PP +In some cases it may be desirable to use host system facilities to compile +and link programs which use the IMFORT interface. The procedure for doing +this is host dependent and is completely up to the user, who no doubt will +already have a preferred technique worked out. All one needs to know in +this situation are the names of the libraries to be linked, and the order +in which they are to be linked. The libraries are as follows, using the +IRAF filenames for the libraries. All the libraries listed are referenced +internally by the IMFORT code hence are required. + +.TS +center; +l l. +lib$libimfort.a IMFORT itself +lib$libsys.a Contains certain pure code modules used by IMFORT +lib$libvops.a The VOPS vector operators library +hlib$libos.a The IRAF kernel (i/o primitives) +.TE +.LP +The host pathnames of these libraries will probably be evident, given the +host pathname of the IRAF root directory (\fIlib\fR is a subdirectory of +the IRAF root directory). If in doubt, the \fIosfn\fR intrinsic function may +be used while in the CL to print the host pathname of the desired library. +For example, +.DS +\fLcl> = osfn ("lib$libimfort.a")\fR +.DE +will cause the CL to print the host pathname of the main IMFORT library. + +.NH 2 +Calling Host Programs from the CL +.PP +Since Fortran programs which use IMFORT are host programs rather than IRAF +programs, the CL \fIforeign task\fR interface is used to connect the programs +to the CL as CL callable tasks. The foreign task interface may also be used +to provide custom CL task interfaces to other host system utilities, e.g., +the debugger or the librarian. +.PP +The function of the \fItask\fR statement in the CL is to make a new task +known to the CL. The CL must know the name of the new task, the name of +the package to which it is to be added, whether or not the new task has a +parameter file, the type of task being defined, and the name of the file in +which the task resides. At present new tasks are always added to the +"current" package. The possible types of tasks are normal IRAF executable +tasks, CL script tasks, and foreign tasks. Our interest here is only in the +forms of the task statement used to declare foreign tasks. There are two +such forms at present. The simplest is the following: +.DS +\fLtask $\fItaskname\fR [, \fL$\fItaskname\fR...]\fL = $foreign\fR +.DE +This form is used when the command to be sent to the host system to run +the task is identical to the name by which the task is known to the CL. +Note that any number of new tasks may be declared at one time with this +form of the task statement. The \fL$\fR prefixing each \fItaskname\fR +tells the CL that the task does not have a parameter file. The \fL$foreign\fR +tells the CL that the new tasks are foreign tasks and that the host command +is the same as \fItaskname\fR. For example, most systems have a system +utility \fImail\fR which is used to read or send electronic mail. +To declare the \fImail\fR task as an IRAF foreign task, we could enter +the following declaration, and then just call the \fImail\fR task from +within the CL like any other IRAF task. +.DS +\fLtask $mail = $foreign\fR +.DE +The more general form of the foreign task statement is shown below. +The host command string must be quoted if it contains blanks or any other +special characters; \fL$\fR is a reserved character and must be escaped +to be included in the command sent to the host system. +.DS +\fLtask $\fItaskname\fL = $\fIhost_command_string\fR +.DE +In this form of the task statement, the command to be sent to the host system +to execute the new IRAF task may be any string. For example, on a VMS host, +we might want to define the \fImail\fR task so that outgoing messages are +always composed in the editor. This could be set up by adding the \fL/EDIT\fR +switch to the command sent to VMS: +.DS +\fLtask $mail = $mail/edit\fR +.DE +Foreign task statements which reference user-written Fortran programs often +refer to the program by its filename. For the task to work regardless of the +current directory, either the full pathname of the executable file must be +given, or some provision must be made at the host command interpreter level +to ensure that the task can be found. +.PP +When a foreign task is called from the CL, the CL builds up the command string +to be sent to the host command interpreter by converting each command line +argument to a string and appending it to \fIhost_command_string\fR preceded +by a space. This is the principal difference between the foreign task +interface and the low level OS escape facility: in the case of a foreign task, +the command line is fully parsed, permitting general expression evaluation, +i/o redirection, background execution, minimum match abbreviations, and so on. +.PP +In most cases this simple method of composing the command to be sent to the +host system is sufficient. There are occasional cases, however, where it is +desirable to \fIembed\fR the command line arguments somewhere in the string +to be sent to the host system. A special \fIargument substitution\fR notation +is provided for this purpose. In this form of the task statement, +\fIhost_command_string\fR contains special symbols which are replaced by the +CL command line arguments to form the final host command string. +These special symbols are defined in the table below. + +.TS +center; +c l. +$0 replaced by \fItaskname\fR +$1, $2, ..., $9 replaced by the indicated argument string +$\(** replaced by the entire argument list +$(N) use host equivalent of filename argument N (1-9 or \(**) +.TE + +.PP +An example of this form of the task statement is the \fIfc\fR task discussed +in \(sc3.1. As we noted earlier, \fIfc\fR is merely a front-end to the more +general IRAF HSI command/link utility \fIxc\fR. In fact, \fIfc\fR is +implemented as a foreign task defined in the default \fIuser\fR package in +the \fLLOGIN.CL\fR file. The task declaration used to define \fIfc\fR is +shown below. The task statement shown is for UNIX; the VMS version is +identical except that the \fL-O\fR switch must be quoted else DCL will convert +it to lower case. In general, foreign task statements are necessarily +machine dependent, since their function is to send a command to the host system. +.DS +\fLtask $fc = "$xc -h -O $\(** -limfort -lsys -lvops -los"\fR +.DE +The argument substitution facility is particularly useful when the host +command template consists of several statements to be executed by the +host command interpreter in sequence each time the CL foreign task is called. +In this case, a delimiter character of some sort is required to delimit +the host command interpreter statements. Once again, this is host system +dependent, since the delimiter character to be used is defined by the syntax +of the host command interpreter. On UNIX systems the command delimiter +character is semicolon (`\fB;\fR'). VMS DCL does not allow multiple +statements to be given on a single command line, but the IRAF interface +to DCL does, using the exclamation character (`\fB!\fR'), which is the +comment character in DCL. +.PP +The \fL$()\fR form of argument substitution is useful for foreign tasks +with one or more filename arguments. The indicated argument or arguments +are taken to be IRAF virtual filenames, and are mapped into their host +filename equivalents to build up the host command string. For example, +assume that we have an IMFORT task \fIphead\fR, the function of which is +to print the header of an image in FITS format on the standard output +(there really is such a program - look in \fLimfort$tasks/phead.f\fR). +We might declare the task as follows (assuming that \fIphead\fR means +something to the host system): +.DS +\fLtask $phead = "$phead $(*)"\fR +.DE +We could then call the new task from within the CL to list the header +of, for example, the standard test image \fLdev$pix\fR, and page the output: +.DS +\fLcl> phead dev$pix | page\fR +.DE +Or we could direct the output to the line printer: +.DS +\fLcl> phead dev$pix | lpr\fR +.DE +Filename translation is available for all forms of argument substitution +symbols, e.g., \fL$(1)\fR, \fL$(2)\fR, \fL$(\(**)\fR, and so on; merely +add the parenthesis. +.PP +It is suggested that new foreign task statements, if not typed in +interactively, be added to the \fIuser\fR package in your \fLLOGIN.CL\fR file, +so that the definitions are not discarded when you log out of the CL or exit +a package. If you want to make the new tasks available to other IRAF users +they can be added to the \fIlocal\fR package by adding the task statements +to the file \fLlocal$tasks/local.cl\fR. If this becomes unwieldy the +next step is to define a new package and add it to the system; this is not +difficult to do, but it is beyond the scope of this manual to explain how +to do so. + +.NH 3 +Example 1 Revisited +.PP +Now that we are familiar with the details of the foreign task statement, +it might be useful to review the examples of foreign task statements given +in \(sc2.1, which introduced the \fIplanck\fR task. The UNIX example given +was as follows: +.DS +\fLcl> task $planck = $planck.e\fR +.DE +This is fine, but only provided the \fIplanck\fR task is called from the +directory containing the executable. To enable the executable to be called +from any directory we can use a UNIX pathname instead, e.g., +.DS +\fLcl> task $planck = $/usr/jones/iraf/tasks/planck.e\fR +.DE +Alternatively, one could place all such tasks in a certain directory, and +either define the pathname of the directory as a shell environment variable +to be referenced in the task statement, or include the task's directory in +the shell search path. There are many other possibilities, of course, but +it would be inappropriate to enumerate them here. +.LP +The VMS example given earlier was the following: +.DS +\fLcl> task $planck = "$planck:==\\\\$\fIdisk\fP:[\fIdir\fP...]planck.exe!planck"\fR +.DE +The command string at the right actually consists of two separate DCL commands +separated by the VMS/IRAF DCL command delimiter `\fB!\fR'. If we invent a +pathname for the executable, we can write down the the first command: +.DS +\fL$ planck :== $usr\\\\$2:[jones.iraf.tasks]planck.exe\fR +.DE +This is a DCL command which defines the new DCL foreign task \fIplanck\fR. +We could shorten the CL foreign task statement by moving the DCL declaration +to our DCL \fLLOGIN.COM\fR file; this has the additional benefit of allowing +the task to be called directly from DCL, but is not as self-contained. +If this were done the CL task statement could be shortened to the following. +.DS +\fLcl> task $planck = $foreign\fR +.DE +The same thing could be accomplished in Berkeley UNIX by defining a cshell +\fIalias\fR for the task in the user's \fL.cshrc\fR file. + +.NH 2 +Debugging IMFORT Programs +.PP +Programs written and called from within the IRAF environment can be debugged +using the host system debug facility without any inconvenience. The details +of how to use the debugger are highly dependent upon the host system since +the debugger is a host facility, but a few examples should help the reader +understand what is involved. +.PP +Berkeley UNIX provides two debug tools, the assembly language debugger +\fIadb\fR and the source language debugger \fIdbx\fR. Both are implemented +as UNIX tasks and are called from within the IRAF environment as tasks, +with the name of the program to be debugged as a command line argument +(this example assumes that \fIadb\fR is a defined foreign task): +.DS +\fLcl> adb planck.e\fR +.DE +The program is then run with a debugger command, passing any command line +arguments to the program as part of the debugger run-program command. +Programs do not have to be compiled in any special way to be debugged +with \fIadb\fR; programs should be compiled with \fIfc -x\fR to be debugged +with \fIdbx\fR. +.PP +In VMS, the debugger is not a separate task but rather a shareable image +which is linked directly into the program to be debugged. To debug a program, +the program must first be linked with \fIfc -x\fR. The program is then run +by simply calling it in the usual way from the CL, with any arguments given +on the command line. When the program runs it comes up initially in the +debugger, and a debugger command (\fIgo\fR) is required to execute the user +program. Note that if the program is run directly with \fLrun/debug\fR +there is no provision for passing an argument list to the task. + +.NH 2 +Calling IMFORT from Languages other than Fortran +.PP +Although our discussion and examples have concentrated exclusively on the +use of the IMFORT library in host Fortran programs, the library is in fact +language independent, i.e., it uses only low level, language independent +system facilities and can therefore be called from any language available +on the host system. The method by which Fortran subroutines and functions +are called from another language, e.g., C or assembler, is highly machine +dependent and it would be inappropriate for us to go into the details here. +Note that \fIfc\fR may be used to compile and link C or assembler programs +as well as Fortran programs. + +.NH 2 +Avoiding Library Name Collisions +.PP +Any program which uses IMFORT is being linked against the main IRAF system +libraries, which together contain some thousands of external procedure names. +Only a few hundred of these are likely to be linked into a host program, +but there is always the chance that a user program module will have the +same external name as one of the modules in the IRAF libraries. +If such a library collision should occur, at best one would get an error +message from the linker, and at worst one would end up with a program +which fails mysteriously at run time. +.PP +At present there is no utility which can search a user program for externals +and cross check these against the list of externals in the IRAF system +libraries. A database of external names is however available in the file +\fLlib$names\fR; this contains a sorted list of all the Fortran callable +external names defined by procedures in the \fIimfort\fR, \fIex\fR, \fIsys\fR, +\fIvops\fR, and \fIos\fR libraries (the \fIex\fR library is however not +searched when linking IMFORT programs). +.PP +The \fImatch\fR task may be used to check individual user external names +against the name list, or a host utility may be used for the same purpose. +For example, to determine if the module \fIsubnam\fR is present in any +of the IRAF system libraries: +.DS +\fLcl> match subnam lib$names\fR +.DE +The names database is also useful for finding the names of all the procedures +sharing a particular package prefix. For example, +.DS +\fLcl> match "^cl" lib$names | table\fR +.DE +will find all the procedures whose names begin with the prefix "cl" and +print them as a table (the \fIlists\fR package must be loaded first). + +.bp +.NH +The IMFORT Library +.PP +In this section we survey the procedures provided by the IMFORT interface, +grouped according to the function they perform. There are currently four main +groups: the command line access procedures, the image access procedures, +the vector operators (VOPS), and a small binary file i/o package. With the +exception of the VOPS procedures, all of the IMFORT routines were written +especially for IMFORT and are not called in standard IRAF programs. +The VOPS procedures are standard IRAF procedures, but are included in the +IMFORT interface because they are coded at a sufficiently low level that they +can be linked into any program, and they tend to be useful in image processing +applications such as IMFORT is designed for. +.PP +The ANSI Fortran-77 standard requires that all names in Fortran programs have +six or fewer characters. To eliminate guesswork, the names of all the IMFORT +procedures are exactly six characters long and the names adhere to a +\fBnaming convention\fR. The first one or two characters in each name +identify the package or group to which the procedure belongs, e.g., +\fIcl\fR for the command line access package, \fIim\fR for the image +access package, and so on. The package prefix is followed by the function name, +and lastly a datatype code identifying the datatype upon which the procedure +operates, in cases where multiple versions of the procedure are available for +a range of datatypes. +.DS +\fIpackage_prefix // function_code // type_suffix\fR +.DE +The type suffix codes have already been introduced in the examples. They are +the same as are used throughout IRAF. The full set is \fB[bcsilrdx]\fR, as +illustrated in the following table (not all are used in the IMFORT procedures). + +.TS +center box; +cb s s s +ci | ci | ci | ci +c | l | c | l. +Standard IRAF Datatypes +_ +suffix name code typical fortran equivalent += +b bool 1 \fLLOGICAL\fR +c char 2 \fLINTEGER\(**2\fR (non-ANSI) +s short 3 \fLINTEGER\(**2\fR (non-ANSI) +i int 4 \fLINTEGER\fR +l long 5 \fLINTEGER\(**4\fR (non-ANSI) +r real 6 \fLREAL\fR +d double 7 \fLDOUBLE PRECISION\fR +x complex 8 \fLCOMPLEX\fR +.TE +.PP +The actual mapping of IRAF datatypes into host system datatypes is machine +dependent, i.e., \fIshort\fR may not map into INTEGER\(**2 on all machines. +This should not matter since the datatype in which data is physically stored +internally is hidden from user programs by the IMFORT interface. +.PP +In cases where multiple versions of a procedure are available for operands +of different datatypes, a special nomenclature is used to refer to the class +as a whole. For example, +.DS +\fLclarg[cird] (argno, [cird]val, ier)\fR +.DE +denotes the set of four procedures \fIclargc, clargi, clargr\fR, and +\fIclargd\fR. The datatype of the output operand (\fIcval, ival\fR, etc.) +must match the type specified by the procedure name. +.PP +With the exception of the low level binary file i/o procedures (BFIO), +all IMFORT procedures are implemented as subroutines rather than functions, +for reasons of consistency and to avoid problems with mistyping of undeclared +functions by the Fortran compiler. + +.NH 2 +Command Line Access +.PP +The command line access procedures are used to decode the arguments present +on the command line when the IMFORT program was invoked. This works both +when the program is called from the IRAF CL, and when the program is called +from the host system command interpreter. The command line access procedures +are summarized in Figure 4, below. + +.TS +center; +n. +\fLclnarg (\&nargs)\fR +\fLclrawc (\&outstr, ier)\fR +\fLclarg[cird] (\&argno, [cird]val, ier)\fR +.TE +.sp +.ce +Figure 4. Command Line Access Procedures + +.PP +The \fIclnarg\fR procedure returns the number of command line arguments; +zero is returned if an error occurs or if there were no command line arguments. +The \fIclargc\fR, \fIclargi\fR, etc., procedures are used to fetch and decode +the individual arguments; \fIclargc\fR returns a character string, \fIclargi\fR +returns an integer, and so on. A nonzero \fIier\fR status indicates either +that the command line did not contain the indexed argument, or that the +argument could not be decoded in the manner specified. Character string +arguments must be quoted on the command line if they contain any blanks or +tabs, otherwise quoting is not necessary. The rarely used \fIclrawc\fR +procedure returns the entire raw command line as a string. + +.NH 2 +Image Access +.PP +The image access procedures form the bulk of the IMFORT interface. There are +three main categories of image access procedures, namely, the general image +management procedures (open, close, create, get size, etc.), the header access +procedures (used to get and put the values of header keywords), and the pixel +i/o procedures, used to read and write image data. +.PP +IMFORT currently supports images of up to three dimensions, +of type short-integer or real. +There is no builtin limit on the size of an image, although +the size of image a particular program can deal with is normally limited by +the size of a statically allocated buffer in the user program. IMFORT does +not map IRAF virtual filenames, hence host dependent names must be used when +running a program which uses IMFORT. +.PP +IMFORT currently supports only the OIF image format, and images must be +of type short-integer or real. Since normal IRAF programs support images of +up to seven disk datatypes with a dimensionality of up to seven, as well as +completely different image formats than that expected by IMFORT (e.g., STF), +if you are not careful IRAF can create images which IMFORT programs cannot +read (don't omit the error checking!). In normal use, however, +types short-integer and real are by far the most common and images with +more than two dimensions are rare, so these are not expected to be serious +limitations. + +.NH 3 +General Image Access Procedures +.PP +The general image access and management procedures are listed in Figure 5. +An image must be opened with \fIimopen\fR or \fIimopnc\fR before header access +or pixel i/o can occur. The image open procedures return an +\fIimage descriptor\fR (an integer magic number) which uniquely identifies +the image in all subsequent accesses until the image is closed. +When the operation is completed, an image must be closed with \fIimclos\fR to +flush any buffered output, update the image header, and free any resources +associated with the image descriptor. The maximum number of images which +can be open at any one time is limited by the maximum number of open file +descriptors permitted by the host operating system. +.PP +New images are created with \fIimopnc\fR and \fIimcrea\fR. The \fIimopnc\fR +procedure creates a new copy of an existing image, copying the header of +the old image to the new image but not the data. The new copy image must +be the same size and datatype as the old image. For complete control over +the attributes of a new image the \fIimcrea\fR procedure must be used. +The \fIimopnc\fR operation is equivalent to an \fIimopen\fR followed by an +\fIimgsiz\fR to determine the size and datatype of the old image, followed by +an \fIimcrea\fR to create the new image, followed by an \fIimhcpy\fR to copy +the header of the old image to the new image and then two \fIimclos\fR calls +to close both images. +.PP +Note that \fIimgsiz always returns seven elements in the output array axlen\fR, +regardless of the actual dimensionality of the image; this is so that current +programs will continue to work in the future if IMFORT is extended to support +images of dimensionality higher than three. Images may be deleted with +\fIimdele\fR, or renamed with \fIimrnam\fR; the latter may also be used to +move an image to a different directory. The \fIimflsh\fR procedure is used +to flush any buffered output pixel data to an image opened for writing. + +.TS +center; +n. +\fLimopen (\&image, acmode, im, ier) \fRacmode: 1=RO,3=RW +\fLimopnc (\&nimage, oim, nim, ier) \fRacmode: always RW +\fLimclos (\&im, ier)\fR + +\fLimcrea (\&image, axlen, naxis, dtype, ier)\fR +\fLimdele (\&image, ier)\fR +\fLimrnam (\&oldnam, newnam, ier)\fR + +\fLimflsh (\&im, ier)\fR +\fLimgsiz (\&im, axlen, naxis, dtype, ier)\fR +\fLimhcpy (\&oim, nim, ier)\fR +\fLimpixf (\&im, pixfd, pixfil, pixoff, szline, ier)\fR +.TE +.sp +.ce +Figure 5. General Image Access Procedures + +.PP +The \fIimpixf\fR procedure may be used to obtain the physical attributes +of the pixel file, i.e., the pixel file name, the one-indexed \fIchar\fR +offset to the first pixel, and the physical line length of an image as stored +in the pixel file (the image lines may be aligned on device block boundaries). +These parameters may be used to bypass the IMFORT pixel i/o procedures to +directly access the pixels if desired (aside from the blocking of lines to +fill device blocks, the pixels are stored as in a Fortran array). +The BFIO file descriptor of the open pixel file is also returned, allowing +direct access to the pixel file via BFIO if desired. If lower level (e.g., +host system) i/o facilities are to be used, \fIbfclos\fR or \fIimclos\fR +should be called to close the pixel file before reopening it with the foreign +i/o system. +.PP +Direct access to the pixel file is not recommended since it makes a program +dependent upon the details of how the pixels are stored on disk; such a +program may not work with future versions of the IMFORT interface, nor with +implementations of the IMFORT interface for different (non-OIF) physical image +storage formats. Direct access may be warranted when performing a minimum +modification hack of an old program to make it work in the IRAF environment, +or in applications with unusually demanding performance requirements, +where the (usually negligible) overhead of the BFIO buffer is unacceptable. +Note that in many applications, the reduction in disk accesses provided by +the large BFIO buffer outweighs the additional cpu cycles required for memory +to memory copies into and out of the buffer. + +.NH 3 +Image Header Keyword Access +.PP +The image header contains a small number of standard fields plus an arbitrary +number of user or application defined fields. Each image has its own header +and IMFORT does not in itself make any association between the header parameters +of different images. The header access procedures are summarized in Figure 6. +Note that the \fIimgsiz\fR procedure described in the previous section is the +most convenient way to obtain the size and datatype of an open image, although +the same thing can be achieved by a series of calls to obtain the values of +the individual keywords, using the procedures described in this section. + +.TS +center; +n. +\fLimacck (\&im, keyw, ier)\fR +\fLimaddk (\&im, keyw, dtype, comm, ier)\fR +\fLimdelk (\&im, keyw, ier)\fR +\fLimtypk (\&im, keyw, dtype, comm, ier)\fR + +\fLimakw[bcdir] (\&im, keyw, [bcdir]val, comm, ier)\fR +\fLimgkw[bcdir] (\&im, keyw, [bcdir]val, ier)\fR +\fLimpkw[bcdir] (\&im, keyw, [bcdir]val, ier)\fR + +\fLimokwl (\&im, patstr, sortit, kwl, ier)\fR +\fLimgnkw (\&kwl, outstr, ier)\fR +\fLimckwl (\&kwl, ier)\fR +.TE +.sp +.ce +Figure 6. Image Header Access Procedures + +.PP +Both the standard and user defined header parameters may be accessed via the +procedures introduced in this section. The \fIimacck\fR procedure tests for +the existence of the named keyword, returning a zero \fIier\fR if the keyword +exists. New keywords may be added to the image header with \fIimaddk\fR, +and old keywords may be deleted with \fIimdelk\fR. The datatype of a keyword +may be determined with \fIimtypk\fR. The attributes of a keyword are its +name, datatype, value, and an optional comment string describing the +significance of the parameter. The comment string is normally invisible +except when the header is listed, but may be set when a new keyword is added +to the header, or fetched with \fIimtypk\fR. +.PP +The most commonly used procedures are likely to be the \fIimgkw\fR and +\fIimpkw\fR families of procedures, used to get and put the values of named +keywords; these procedures require that the keyword already be present in +the header. The \fIimakw\fR procedures should be used instead of the +\fIimpkw\fR procedures if it is desired that a keyword be automatically added +to the header if not found, before setting the new value. Automatic datatype +conversion is performed if the requested datatype does not match the actual +datatype of the keyword. +.PP +The \fIkeyword list\fR package is the only way to obtain information from +the header without knowing in advance the names of the header keywords. +The \fIimokwl\fR procedure opens a keyword list consisting of all header +keywords matching the given pattern, returning a \fIlist descriptor\fR to +be used as input to the other procedures in the package. Successive +keyword \fInames\fR are returned in calls to \fIimgnkw\fR; a nonzero +\fIier\fR is returned when the end of the list is reached. The keyword +name is typically used as input to other procedures such as \fIimtypk\fR +or one of the \fIimgkw\fR procedures to obtain further information about +the keyword. A keyword list should be closed with \fIimckwl\fR when it is +no longer needed to free system resources associated with the list descriptor. + +.TS +center box; +cb s s +ci | ci | ci +l | c | l. +Standard Image Header User Keywords +_ +name datatype description += +naxis int number of axes (dimensionality) +naxis[1:3] int length of each axis, pixels +pixtype int pixel datatype +datamin real minimum pixel value +datamax real maximum pixel value +ctime int image creation time +mtime int image modification time +limtime int time min/max last updated +title string image title string (for plots etc.) +.TE + +.PP +The keyword list pattern string follows the usual IRAF conventions; some +useful patterns are "\(**", which matches the entire header, and "i_", which +matches only the standard header keywords (the standard header keywords are +really named "i_naxis", "i_pixtype", etc., although the "i_" may be omitted +in most cases). A pattern which does not include any pattern matching +metacharacters is taken to be a prefix string, matching all keywords whose +names start with the pattern string. +.PP +An image must be opened with read-write access for header updates to have +any effect. An attempt to update a header without write permission will +not produce an error status return until \fIimclos\fR is called to update +the header on disk (and close the image). + +.NH 3 +Image Pixel Access +.PP +The IMFORT image pixel i/o procedures are used to get and put entire image +lines to N-dimensional images, or to get and put N-dimensional subrasters +to N-dimensional images. In all cases the caller supplies a buffer into +which the pixels are to be put, or from which the pixels are to be taken. +The pixel i/o procedures are summarized in Figure 7. +.PP +As shown in the figure, there are four main classes of pixel i/o procedures, +the get-line, put-line, get-section, and put-section procedures. The get-line +and put-line procedures are special cases of the get/put section procedures, +provided for programming convenience in the usual line by line sequential +image operator (they are also slightly more efficient than the subraster +procedures for line by line i/o). It is illegal to reference out of bounds +and \fIi1\fR must be less than or equal to \fIi2\fR (IMFORT will not flip +lines); the remaining subscripts may be swapped if desired. Access may be +completely random if desired, but sequential access (in storage order) implies +fewer buffer faults and is more efficient. + +.KS +.TS +center; +n. +\fLim[gp]l1[rs] (\&im, buf, ier)\fR +\fLim[gp]l2[rs] (\&im, buf, lineno, ier)\fR +\fLim[gp]l3[rs] (\&im, buf, lineno, bandno, ier)\fR +\fLim[gp]s1[rs] (\&im, buf, i1, i2, ier)\fR +\fLim[gp]s2[rs] (\&im, buf, i1, i2, j1, j2, ier)\fR +\fLim[gp]s3[rs] (\&im, buf, i1, i2, j1, j2, k1, k2, ier)\fR +.TE +.sp +.ce +Figure 7. Image Pixel I/O Procedures +.KE + +.PP +Type short and type real versions of each i/o procedure are provided. +The type real procedures may be used to access images of either type short +or type real, with automatic datatype conversion being provided if the disk +and program datatypes do not match. The type short-integer i/o procedures +may only be used with type short images. +.PP +The user who is familiar with the type of image i/o interface which maps +the pixel array into virtual memory may wonder why IMFORT uses the more old +fashioned buffered technique. There are two major reasons why this approach +was chosen. Firstly, the virtual memory mapping technique, in common use on +VMS systems, is \fInot portable\fR. On a host which does not support the +mapping of file segments into paged memory, the entire image must be copied +into paged memory when the image is opened, then copied again when the image +operation takes place, then copied once again from memory to disk when the +image is closed. Needless to say this is very inefficient, particularly for +large images, and some of our applications deal with images 2048 or even 6000 +pixels square. +.PP +Even on a machine that supports mapping of file segments into memory, mapped +access will probably not be efficient for sequential access to large images, +since it causes the system to page heavily; data pages which will never be +used again fill up the system page caches, displacing text pages that must +then be paged back in. This happens on even the best systems, and on a system +that does not implement virtual memory efficiently, performance may suffer +greatly. +.PP +A less obvious reason is that mapping the image directly into memory violates +the principle of \fIdata independence\fR, i.e., a program which uses this +type of interface has a builtin dependence on the particular physical image +storage format in use when the program was developed. This rules out even +such simple interface features as automatic datatype conversion, and prevents +the expansion of the interface in the future, e.g., to provide such attractive +features as an image section capability (as in the real IRAF image interface), +network access to images stored on a remote node, support for pixel storage +schemes other than line storage mode (e.g., isotropic mappings or sparse image +storage), and so on. +.PP +The majority of image operations are either sequential whole-image operations +or operations upon subrasters, and are just as easily programmed with a +buffered interface as with a memory mapped interface. The very serious +drawbacks of the memory mapped interface dictate that it not be used except +in special applications that must randomly access individual pixels in an +image too large to be read in as a subraster. + +.NH 2 +Error Handling +.PP +The IMFORT error handling mechanism is extremely simple. All procedures in +which an error condition can occur return a nonzero \fIier\fR error code +if an error occurs. The value of \fIier\fR identifies which of many possible +errors actually occurred. These error codes may be converted into error +message strings with the following procedure: +.DS +\fLimemsg (\&ier, errmsg)\fR +.DE +It is suggested that every main program contain an error handling section at +the end of the program which calls \fIimemsg\fR and halts program execution +with an informative error message, as in the examples in \(sc2. +This is especially helpful when debugging new programs. + +.NH 2 +Vector Operators +.PP +The vector operators (VOPS) package is a subroutine library implementing +a large number of primitive operations upon one dimensional vectors of any +datatype. Some of the operations implemented by the VOPS routines are +non-trivial to implement, in which case the justification for a library +subroutine is clear. Even in the simplest cases, however, the use of a +VOPS procedure is advantageous because it provides scope for optimizing +all programs which use the VOPS operator, without having to modify the +calling programs. For example, if the host machine has vector hardware +or special machine instructions (e.g., the block move and bitfield instructions +of the VAX), the VOPS operator can be optimized in a machine dependent way +to take advantage of the special capabilities of the hardware, without +compromising the portability of the applications software using the procedure. +.PP +The VOPS procedures adhere to the naming convention described in \(sc4. +The package prefix is \fIa\fR, the function code is always three characters, +and the remaining one or two characters define the datatype or types upon +which the procedure operates. For example, \fIaaddr\fR performs a vector +add upon type real operands. If the character \fIk\fR is added to the +three character function name, one of the operands will be a scalar. +For example, \fIaaddkr\fR adds a scalar to a vector, with both the scalar +and the vector being of type real. +.PP +Most vector operators operate upon operands of a single datatype: one notable +exception is the \fIacht\fR (change datatype) operator, used to convert a +vector from one datatype to another. For example, \fIachtbi\fR will unpack +each byte in a byte array into an integer in the output array, providing a +capability that cannot be implemented in portable Fortran. Any datatype +suffix characters may be substituted for the \fIbi\fR, to convert a vector +from any datatype to any other datatype. +.PP +In general, there are are three main classes of vector operators, the +\fIunary\fR operators, the \fIbinary\fR operators, and the \fIprojection\fR +operators. The unary operators perform some operation upon a single input +vector, producing an output vector as the result. The binary operators +perform some operation upon two input vectors, producing an output vector +as the result. The projection operators compute some function of a single +input vector, producing a scalar function value (rather than a vector) as +the result. Unary operators typically have three arguments, binary +operators four, and projection operators two arguments and one output +function value. For example, \fIaabsi\fR is the unary absolute value +vector operator, type integer (here, \fIa\fR is the input vector, \fIb\fR +is the output vector, and \fInpix\fR is the number of vector elements): +.DS +\fLaabsi (a, b, npix)\fR +.DE +A typical example of a binary operator is the vector add operator, \fIaaddr\fR. +Here, \fIa\fR and \fIb\fR are the input vectors, and \fIc\fR is the output +vector: +.DS +\fLaaddr (a, b, c, npix)\fR +.DE +In all cases except where the output vector contains fewer elements than one +of the input vectors, the output vector may be the same as one of the input +vectors. A full range of datatypes are provided for each vector operator, +except that there are no boolean vector operators (integer is used instead), +and \fIchar\fR and \fIcomplex\fR are only partially implemented, since they +are not sensible datatypes for many vector operations. In any case, the VOPS +\fIchar\fR is the SPP char and should be avoided in Fortran programs. +.PP +Once these rules are understood, the calling sequence of a particular VOPS +operator can usually be predicted with little effort. The more complex +operators, of course, may have special arguments, and some study is typically +required to determine their exact function and how they are used. A list of +the VOPS operators currently provided is given below (the datatype suffix +characters must be added to the names shown to form the full procedure names). + +.TS +center; +n. +aabs -\& Absolute value of a vector +aadd -\& Add two vectors +aaddk -\& Add a vector and a scalar +aand -\& Bitwise boolean AND of two vectors +aandk -\& Bitwise boolean AND of a vector and a scalar +aavg -\& Compute the mean and standard deviation of a vector +abav -\& Block average a vector +abeq -\& Vector equals vector +abeqk -\& Vector equals scalar +abge -\& Vector greater than or equal to vector +abgek -\& Vector greater than or equal to scalar +abgt -\& Vector greater than vector +abgtk -\& Vector greater than scalar +able -\& Vector less than or equal to vector +ablek -\& Vector less than or equal to scalar +ablt -\& Vector less than vector +abltk -\& Vector less than scalar +abne -\& Vector not equal to vector +abnek -\& Vector not equal to scalar +abor -\& Bitwise boolean OR of two vectors +abork -\& Bitwise boolean OR of a vector and a scalar +absu -\& Block sum a vector +acht -\& Change datatype of a vector +acjgx -\& Complex conjugate of a complex vector +aclr -\& Clear (zero) a vector +acnv -\& Convolve two vectors +acnvr -\& Convolve a vector with a real kernel +adiv -\& Divide two vectors +adivk -\& Divide a vector by a scalar +adot -\& Dot product of two vectors +advz -\& Vector divide with divide by zero detection +aexp -\& Vector to a real vector exponent +aexpk -\& Vector to a real scalar exponent +afftr -\& Forward real discrete fourier transform +afftx -\& Forward complex discrete fourier transform +aglt -\& General piecewise linear transformation +ahgm -\& Accumulate the histogram of a series of vectors +ahiv -\& Compute the high (maximum) value of a vector +aiftr -\& Inverse real discrete fourier transform +aiftx -\& Inverse complex discrete fourier transform +aimg -\& Imaginary part of a complex vector +alim -\& Compute the limits (minimum and maximum values) of a vector +alln -\& Natural logarithm of a vector +alog -\& Logarithm of a vector +alov -\& Compute the low (minimum) value of a vector +altr -\& Linear transformation of a vector +alui -\& Vector lookup and interpolate (linear) +alut -\& Vector transform via lookup table +amag -\& Magnitude of two vectors (sqrt of sum of squares) +amap -\& Linear mapping of a vector with clipping +amax -\& Vector maximum of two vectors +amaxk -\& Vector maximum of a vector and a scalar +amed -\& Median value of a vector +amed3 -\& Vector median of three vectors +amed4 -\& Vector median of four vectors +amed5 -\& Vector median of five vectors +amgs -\& Magnitude squared of two vectors (sum of squares) +amin -\& Vector minimum of two vectors +amink -\& Vector minimum of a vector and a scalar +amod -\& Modulus of two vectors +amodk -\& Modulus of a vector and a scalar +amov -\& Move (copy or shift) a vector +amovk -\& Move a scalar into a vector +amul -\& Multiply two vectors +amulk -\& Multiply a vector and a scalar +aneg -\& Negate a vector (change the sign of each pixel) +anot -\& Bitwise boolean NOT of a vector +apkx -\& Pack a complex vector given the real and imaginary parts +apol -\& Polynomial evaluation +apow -\& Vector to an integer vector power +apowk -\& Vector to an integer scalar power +arav -\& Mean and standard deviation of a vector with pixel rejection +arcp -\& Reciprocal of a scalar and a vector +arcz -\& Reciprocal with detection of divide by zero +arlt -\& Vector replace pixel if less than scalar +argt -\& Vector replace pixel if greater than scalar +asel -\& Vector select from two vectors based on boolean flag vector +asok -\& Selection of the Kth smallest element of a vector +asqr -\& Square root of a vector +asrt -\& Sort a vector in order of increasing pixel value +assq -\& Sum of squares of a vector +asub -\& Subtract two vectors +asubk -\& Subtract a scalar from a vector +asum -\& Sum of a vector +aupx -\& Unpack the real and imaginary parts of a complex vector +awsu -\& Weighted sum of two vectors +awvg -\& Mean and standard deviation of a windowed vector +axor -\& Bitwise boolean XOR (exclusive or) of two vectors +axork -\& Bitwise boolean XOR (exclusive or) of a vector and a scalar +.TE + +.PP +A non-trivial example of the use of vector operators is the case of bilinear +interpolation on a two dimensional image. The value of each pixel in the +output image is a linear sum of the values of four pixels in the input image. +The obvious solution is to set up a do-loop over the pixels in each line of +the output image, computing the linear sum over four pixels from the input +image for each pixel in the output line; this is repeated for each line in the +output image. +.PP +The solution using the VOPS operators involves the \fIalui\fR (vector look up +and interpolate) and \fIawsu\fR (weighted sum) vector operators. A lookup table +defining the X-coordinate in the input image of each pixel in a line of the +output image is first generated. Then, for each line of the output image, +the two lines from the input image which will contribute to the output image +line are extracted. \fIAlui\fR is used to interpolate each line in X, then +\fIawsu\fR is used to form the weighted sum to interpolate in the Y direction. +This technique is especially efficient when bilinear interpolation is being +used to expand the image, in which case the \fIalui\fR interpolated X-vectors, +for example, are computed once but then used to generate several lines of +the output image by taking the weighted sum, a simple and fast operation. +When moving sequentially up through the image, the high X-vector becomes the +low X-vector for the next pair of input lines, hence only a single call to +\fIalui\fR is required to set up the next region. +.PP +The point of this example is that many or most image operations can be +expressed in terms of primitive one dimensional vector operations, +regardless of the dimensionality of the image being operated upon. +The resultant algorithm will often run more efficiently even on a conventional +scalar machine than the equivalent nonvectorized code, and will probably run +efficiently without modification on a vector machine. +.PP +Detailed specification sheets (manual pages) are not currently available for +the VOPS procedures. A summary of the calling sequences is given in the file +\fLvops$vops.syn\fR, which can be paged or printed by that name while in the +CL, assuming that the system has not been stripped and that the sources are +still on line. The lack of documentation is really not a problem for these +operators, since they are all fairly simple, and it is easy to page the source +file (in the \fIvops\fR directory) to determine the exact calling sequence. +For example, to examine the source for \fIawsu\fR, type +.DS +\fLcl> page vops$awsu.gx\fR +.DE +to page the generic source, regardless of the specific datatype of interest. +If you have trouble deciphering the generic source, +use \fLxc -f file.x\fR to produce the Fortran translation +of one of the type specific files in the subdirectories +\fLvops$ak\fR and \fLvops$lz\fR. + +.NH 2 +Binary File I/O (BFIO) +.PP +The IMFORT binary file i/o package (BFIO) is a small package, written +originally as an internal package for use by the IMFORT image i/o routines +for accessing header and pixel files (the VOS FIO package could not be used +in IMFORT without linking the entire IRAF/VOS runtime system into the Fortran +program). Despite its original conception as an internal package, the package +provides a useful capability and is portable, hence has been included in the +IMFORT interface definition. Nonetheless, the user should be warned that BFIO +is a fairly low level interface and some care is required to use it safely. +If other suitable facilities are available it may be better to use those, +although few interfaces will be found which are simpler or more efficient +than BFIO for randomly accessing pre-existing or preallocated binary files. +.PP +The principal capability provided by BFIO is the ability to randomly access +a binary file, reading or writing an arbitrary number of char-units of storage +at any (one-indexed) char offset in the file. The file itself is a non-record +structured file containing no embedded record manager information, +hence is suitable for access by any program, including non-Fortran programs, +and for export to other machines (this is usually not the case with a Fortran +unformatted direct access file). Unlike the mainline IMFORT procedures, +many of the BFIO procedures are integer functions returning a positive count +value if the operation is successful (e.g., the number of char units of storage +read or written), or a negative value if an error occurs. Zero is returned +for a read at end of file. + +.TS +center; +n. +\fLbfaloc (\&fname, nchars, status)\fR +\fLfd = bfopen (\&fname, acmode, advice) \fRacmode: 1=RO,3=RW,5=NF +\fLbfclos (\&fd, status) \fRadvice: 1=random,2=seq + +\fLnchars = bfread (\&fd, buf, nchars, offset)\fR +\fLnchars = bfwrit (\&fd, buf, nchars, offset)\fR + +\fLnchars = bfbsiz (\&fd)\fR +\fLnchars = bffsiz (\&fd)\fR +\fLchan = bfchan (\&fd)\fR +\fLstat = bfflsh (\&fd)\fR +.TE +.sp +.ce +Figure 8. Low Level Binary File I/O Procedures + +.PP +BFIO binary files may be preallocated with \fIbfaloc\fR, or created with +\fIbfopen\fR and then initialized by writing at the end of file. +Preallocating a file is useful when the file size is known in advance, e.g., +when creating the pixel file for a new image. The contents of a file +allocated with \fIbfaloc\fR are uninitialized. To extend a file by writing +at the end of file the file size must be known; the file size may be obtained +by calling \fIbffsiz\fR on the open file. +.PP +Before i/o to a file can occur, the file must be opened with \fIbfopen\fR. +The \fIbfopen\fR procedure returns as its function value an integer +\fIfile descriptor\fR which is used to refer to the file in all subsequent +accesses until the file is closed with \fIbfclos\fR. Binary data is read +from the file with \fIbfread\fR, and written to the file with \fIbfwrit\fR. +Any amount of data may be read or written in a single call to \fIbfread\fR +or \fIbfwrit\fR. All user level i/o is synchronous and data is buffered +internally by BFIO to minimize disk transfers and provide for the blocking +and deblocking of data into device blocks. Any buffered output data may be +flushed to disk with \fIbfflsh\fR. The function \fIbfchan\fR returns the +descriptor of the raw i/o channel as required by the IRAF binary file driver. +.PP +BFIO manages an internal buffer, necessary for efficient sequential i/o and +to hide the device block size from the user program. Larger buffers are +desirable for sequential i/o on large files; smaller buffers are best for +small files or for randomly accessing large files. The buffer size may be +set at \fIbfopen\fR time with the \fIadvice\fR parameter. An \fIadvice\fR +value of 1 implies random access and causes a small buffer to be allocated; +a value of 2 implies sequential access and causes a large buffer to be +allocated. Any other value is taken to be the actual buffer size in chars, +but care must be used since the value specified must be some multiple of the +device block size, and less than the maximum transfer size permitted by the +kernel file driver. Note that when writing at end of file, the full contents +of the internal buffer will be written, even if the entire buffer contents +were not written into in a \fIbfwrit\fR call. The buffer size in chars is +returned by \fIbfbsiz\fR. +.PP +Since BFIO is a low level interface, the file offset must always be specified +when reading from or writing to the file, even when the file is being accessed +sequentially. Contrary to what one might think, file offsets are one-indexed +in the Fortran tradition, and are specified in units of \fIchars\fR. +Do not confuse \fIchar\fR with the Fortran \fLCHARACTER\fR; \fIchar\fR is the +fundamental unit of storage in IRAF, the smallest datum which can be accessed +as an integer quantity with the host Fortran compiler, normally +\fLINTEGER\(**2\fR (16 bits or two bytes on all current IRAF hosts). + +.bp +.SH +Appendix: Manual Pages for the Imfort Procedures +.PP +This section presents the ``manual pages'' for the IMFORT and BFIO procedures. +The manual pages present the exact technical specifications of each procedure, +i.e., the procedure name and arguments (not necessarily obvious in the case of +a typed family of procedures), the datatypes and dimensions of the arguments, +and a precise description of the operation of the procedure. +Each procedure is presented on a separate page for ease of reference. +.PP +The following conventions have been devised to organize the information +presented in this section: +.RS +.IP \(bu +The manual pages are presented in alphabetical order indexed by the procedure +name. +.IP \(bu +A single manual page is used to present an entire family of procedures which +differ only in the datatype of their primary operand. The name on the manual +page is the generic name of the family, e.g., \fIclargi\fR, \fIclargr\fR, etc., +are described in the manual page \fIclarg\fR. +.IP \(bu +In some cases it makes sense to describe several related procedures with a +single manual page. An example is the keyword-list package, consisting of +the procedures \fIimokwl\fR, \fIimgnkw\fR, and \fIimckwl\fR. In such a case, +since the procedures have different names the manual page for the group is +duplicated for each procedure in the group, so that the user will not have +to guess which name the manual page is filed under. +.IP \(bu +The \fIsynopsis\fR section of each manual page defines the calling sequence of +each procedure, the datatypes and dimensions of the arguments, and notes +whether each argument is an input argument (\fL#I\fR) or an output argument +(\fL#O\fR). +.IP \(bu +The \fIreturn value\fR section describes the conditions required for +successful execution of the procedure, normally indicated by a zero status +in \fIier\fR. A symbolic list of the possible error codes is also given. +The numeric values of these error codes are defined in \fLimfort$imfort.h\fR +and in \fLlib$syserr.h\fR, but the exact numeric codes should be used only for +debugging purposes or passed on to the \fIimemsg\fR procedure to get the error +message string. The numeric error codes are likely to change in future versions +of the interface hence their values should not be "wired into" programs. +.RE +.PP +Manual pages for the VOPS procedures are not included since VOPS is not really +part of the IMFORT interface, and it is not yet clear if the VOPS procedures +are complex enough to justify the production of individual manual pages. diff --git a/sys/imfort/doc/imfort.toc b/sys/imfort/doc/imfort.toc new file mode 100644 index 00000000..b68c5b69 --- /dev/null +++ b/sys/imfort/doc/imfort.toc @@ -0,0 +1,54 @@ +.LP +.ps +2 +.ce +\fBContents\fR +.ps +.sp 3 +.sp +1.\h'|0.4i'\fBIntroduction\fP\l'|5.6i.'\0\01 +.br +\h'|0.4i'1.1.\h'|0.9i'Who Should Use IMFORT\l'|5.6i.'\0\01 +.sp +2.\h'|0.4i'\fBGetting Started\fP\l'|5.6i.'\0\03 +.br +\h'|0.4i'2.1.\h'|0.9i'Example 1: Plotting a function\l'|5.6i.'\0\03 +.br +\h'|0.4i'2.2.\h'|0.9i'Example 2: Compute the range of pixel values in an image\l'|5.6i.'\0\06 +.br +\h'|0.4i'2.3.\h'|0.9i'Example 3: Copy an image\l'|5.6i.'\0\07 +.sp +3.\h'|0.4i'\fBThe IMFORT Programming Environment\fP\l'|5.6i.'\0\09 +.br +\h'|0.4i'3.1.\h'|0.9i'The FC Compile/Link Utility\l'|5.6i.'\0\09 +.br +\h'|0.4i'3.2.\h'|0.9i'Host Level Linking to the IMFORT Libraries\l'|5.6i.'\0\11 +.br +\h'|0.4i'3.3.\h'|0.9i'Calling Host Programs from the CL\l'|5.6i.'\0\11 +.br +\h'|0.9i'3.3.1.\h'|1.5i'Example 1 Revisited\l'|5.6i.'\0\13 +.br +\h'|0.4i'3.4.\h'|0.9i'Debugging IMFORT Programs\l'|5.6i.'\0\14 +.br +\h'|0.4i'3.5.\h'|0.9i'Calling IMFORT from Languages other than Fortran\l'|5.6i.'\0\15 +.br +\h'|0.4i'3.6.\h'|0.9i'Avoiding Library Name Collisions\l'|5.6i.'\0\15 +.sp +4.\h'|0.4i'\fBThe IMFORT Library\fP\l'|5.6i.'\0\16 +.br +\h'|0.4i'4.1.\h'|0.9i'Command Line Access\l'|5.6i.'\0\17 +.br +\h'|0.4i'4.2.\h'|0.9i'Image Access\l'|5.6i.'\0\17 +.br +\h'|0.9i'4.2.1.\h'|1.5i'General Image Access Procedures\l'|5.6i.'\0\18 +.br +\h'|0.9i'4.2.2.\h'|1.5i'Image Header Keyword Access\l'|5.6i.'\0\19 +.br +\h'|0.9i'4.2.3.\h'|1.5i'Image Pixel Access\l'|5.6i.'\0\20 +.br +\h'|0.4i'4.3.\h'|0.9i'Error Handling\l'|5.6i.'\0\22 +.br +\h'|0.4i'4.4.\h'|0.9i'Vector Operators\l'|5.6i.'\0\22 +.br +\h'|0.4i'4.5.\h'|0.9i'Binary File I/O (BFIO)\l'|5.6i.'\0\26 +.sp +\h'|0.4i'\fBAppendix A:\fR Manual Pages for the IMFORT Procedures\l'|5.6i.'\0\28 diff --git a/sys/imfort/doc/imgkw.hlp b/sys/imfort/doc/imgkw.hlp new file mode 100644 index 00000000..412113da --- /dev/null +++ b/sys/imfort/doc/imgkw.hlp @@ -0,0 +1,41 @@ +.help imgkw Sep86 imfort +.ih +NAME +imgkw -- get the value of an image header keyword +.ih +SYNOPSIS +.nf +subroutine imgkwb (im, keyw, bval, ier) +subroutine imgkwc (im, keyw, cval, ier) +subroutine imgkwi (im, keyw, ival, ier) +subroutine imgkwr (im, keyw, rval, ier) +subroutine imgkwd (im, keyw, dval, ier) + +integer im #I image descriptor of open image +character*(*) keyw #I name of the keyword to be set +integer ier #O status return + +logical bval #O logical (boolean) keyword value +character*(*) cval #O character string keyword value +integer ival #O integer keyword value +real rval #O real keyword value +doubleprecision dval #O double precision keyword value +.fi +.ih +DESCRIPTION +The \fIimgkw\fR procedures are used to get the values of image header keywords. +Automatic datatype conversion is provided, hence the datatype requested need +not be an exact match to the actual datatype of the keyword. +.ih +RETURN VALUE +A zero status is returned if the named keyword exists and if the datatype +coercion implied is permissible. + +.nf +SYS_IDBKEYNF: image header keyword not found +SYS_IDBTYPE: illegal header parameter data type conversion +.fi +.ih +SEE ALSO +impkw, imaddk, imacck +.endhelp diff --git a/sys/imfort/doc/imgl.hlp b/sys/imfort/doc/imgl.hlp new file mode 100644 index 00000000..389031ae --- /dev/null +++ b/sys/imfort/doc/imgl.hlp @@ -0,0 +1,48 @@ +.help imgl Sep86 imfort +.ih +NAME +.nf +imgl -- get (read) an image line +.fi +.ih +SYNOPSIS +.nf +subroutine imgl1r (im, rbuf, ier) +subroutine imgl1s (im, sbuf, ier) +subroutine imgl2r (im, rbuf, lineno, ier) +subroutine imgl2s (im, sbuf, lineno, ier) +subroutine imgl3r (im, rbuf, lineno, bandno, ier) +subroutine imgl3s (im, sbuf, lineno, bandno, ier) + +integer im #I image descriptor of open image +real rbuf(*) #O output pixel buffer, type real +integer*2 sbuf(*) #O output pixel buffer, type short +integer lineno #I line (row) number (1:axlen(2)) +integer bandno #I band number (1:axlen(3)) +integer ier #O status return +.fi +.ih +DESCRIPTION +The \fIimgl\fR procedures are used to get a line (row) from an image. +Procedures are provided for images of from one to three dimensions, +of pixel type short integer or real. The type real procedures may be +applied to images of either type, but the type short procedures may only +be used to access images of type short. The output buffer must provide +storage for at least \fIaxlen(1)\fR pixels or a buffer overrun will occur. +.ih +RETURN VALUE +A zero status is returned if the referenced image line is in-bounds and +the actual pixel datatype of the image is one of the types permitted by +the particular operator called. + +.nf +IE_NOTSHORT: imfort short integer i/o requires a type short image +IE_PIXTYPE: image pixel type must be short or real +IE_RDPIX: error reading image pixel file +IE_YOOB: image y coordinates out of range +IE_ZOOB: image z coordinates out of range +.fi +.ih +SEE ALSO +impl, imgs, imps +.endhelp diff --git a/sys/imfort/doc/imgs.hlp b/sys/imfort/doc/imgs.hlp new file mode 100644 index 00000000..73ba756b --- /dev/null +++ b/sys/imfort/doc/imgs.hlp @@ -0,0 +1,54 @@ +.help imgs Sep86 imfort +.ih +NAME +.nf +imgs -- get (read) an image section +.fi +.ih +SYNOPSIS +.nf +subroutine imgs1r (im, rbuf, i1,i2, ier) +subroutine imgs1s (im, sbuf, i1,i2, ier) +subroutine imgs2r (im, rbuf, i1,i2, j1,j2, ier) +subroutine imgs2s (im, sbuf, i1,i2, j1,j2, ier) +subroutine imgs3r (im, rbuf, i1,i2, j1,j2, k1,k2, ier) +subroutine imgs3s (im, sbuf, i1,i2, j1,j2, k1,k2, ier) + +integer im #I image descriptor of open image +real rbuf(*) #O output pixel buffer, type real +integer*2 sbuf(*) #O output pixel buffer, type short +integer i1, i2 #I range of columns to be extracted +integer j1, j2 #I range of lines to be extracted +integer k1, k2 #I range of bands to be extracted +integer ier #O status return +.fi +.ih +DESCRIPTION +The \fIimgs\fR procedures are used to get a section (subraster) from an image. +Procedures are provided for images of from one to three dimensions, +of pixel type short integer or real. The type real procedures may be +applied to images of either type, but the type short procedures may only +be used to access images of type short. The output buffer must provide +space for at least (i1-i2+1) pixels (\fIgs1\fR), ((j2-j1+1) * (i2-i1+1)) pixels +(\fIgs2\fR), or ((k2-k1+1) * (j2-j1+1) * (i2-i1+1)) pixels (\fIgs3\fR). +The pixels are returned in Fortran storage order. The column index \fIi2\fR +must be greater than or equal to \fIi1\fR, but the remaining subscripts may +be swapped if desired. +.ih +RETURN VALUE +A zero status is returned if the referenced image section is in-bounds and +the actual pixel datatype of the image is one of the types permitted by +the particular operator called. + +.nf +IE_NOTSHORT: imfort short integer i/o requires a type short image +IE_PIXTYPE: image pixel type must be short or real +IE_RDPIX: error reading image pixel file +IE_XOOB: image x coordinates out of range or out of order +IE_YOOB: image y coordinates out of range +IE_ZOOB: image z coordinates out of range +.fi +.ih +SEE ALSO +imps, imgl, impl +.endhelp diff --git a/sys/imfort/doc/imgsiz.hlp b/sys/imfort/doc/imgsiz.hlp new file mode 100644 index 00000000..bd2e3972 --- /dev/null +++ b/sys/imfort/doc/imgsiz.hlp @@ -0,0 +1,51 @@ +.help imgsiz Sep86 imfort +.ih +NAME +imgsiz -- determine the size and datatype of an open image +.ih +SYNOPSIS +.nf +subroutine imgsiz (im, axlen, naxis, dtype, ier) + +integer im #I image descriptor of open image +integer axlen(7) #O length of each axis +integer naxis #O number of axes (dimensionality) +integer dtype #O pixel datatype +integer ier #O status return +.fi +.ih +DESCRIPTION +The \fIimgsiz\fR procedure is called to determine the dimensionality, size, +and datatype of an open image, i.e., the physical attributes of the pixel +array. Upon output, \fIaxlen\fR will contain the length of each axis of +the image, where \fIaxlen(1)\fR is the number of pixels in each image line +(the number of columns), \fIaxlen(2)\fR is the number of lines in each band +of the image, \fIaxlen(3)\fR is the number of bands, and so on. +Seven array elements are returned regardless of the actual dimensionality of +the image; the lengths of the excess axes are set to one. The logical +dimensionality of the image is returned in \fInaxis\fR. A code identifying +the datatype of the pixels is returned in \fIpixtype\fR; the range of possible +pixel datatypes is enumerated in the table below. + +.nf + 3 short integer (usually 16 bits signed) + 4 integer (generally the same as long integer) + 5 long integer (usually 32 bits signed) + 6 single precision floating (real) + 7 double precision floating + 8 complex + 11 unsigned short (16 bits unsigned) +.fi + +Note that although the image storage format may support all of these datatypes, +IMFORT is currently only capable of accessing images of type short or real. +.ih +RETURN VALUE +A zero status is returned for any valid open image, i.e., provided the image +descriptor given is valid. + +IE_MAGIC: illegal imfort image descriptor +.ih +SEE ALSO +imgkwi, imcrea +.endhelp diff --git a/sys/imfort/doc/imhcpy.hlp b/sys/imfort/doc/imhcpy.hlp new file mode 100644 index 00000000..3a36816d --- /dev/null +++ b/sys/imfort/doc/imhcpy.hlp @@ -0,0 +1,30 @@ +.help imhcpy Sep86 imfort +.ih +NAME +imhcpy -- copy an image header +.ih +SYNOPSIS +.nf +subroutine imhcpy (oim, nim, ier) + +integer oim #I image descriptor of input image +integer nim #I image descriptor of output image +integer ier #O status return +.fi +.ih +DESCRIPTION +The \fIimhcpy\fR procedure is used to copy the non-pixel fields in the header +of one image to another image, given the runtime descriptors of the two images. +The images must previously have been opened with \fIimopen\fR or \fIimopnc\fR. +The header fields which are \fInot\fR copied are those describing the physical +attributes the pixel array, i.e., the number of axes, the physical dimensions +of the image, the pixel datatype code, and the minimum and maximum pixel values. +.ih +RETURN VALUE +A zero status will be returned provided both image descriptors are valid. + +IE_MAGIC: illegal imfort image descriptor +.ih +SEE ALSO +imgsiz, imgkw, impkw +.endhelp diff --git a/sys/imfort/doc/imokwl.hlp b/sys/imfort/doc/imokwl.hlp new file mode 100644 index 00000000..6e860cb7 --- /dev/null +++ b/sys/imfort/doc/imokwl.hlp @@ -0,0 +1,65 @@ +.help imokwl,imgnkw,imckwl Sep86 imfort +.ih +NAME +.nf +imokwl -- open an image header keyword list +imgnkw -- get the next keyword from the list +imckwl -- close the keyword list +.fi +.ih +SYNOPSIS +.nf +subroutine imokwl (im, patstr, sortit, kwl, ier) + +integer im #I image descriptor of open image +character*(*) patstr #I pattern matching subset of keywords +logical sortit #I sort the list by keyword name? +integer kwl #O keyword list descriptor +integer ier #O status return + +subroutine imgnkw (kwl, outstr, ier) + +integer kwl #I keyword list descriptor +character*(*) outstr #O the next keyword name +integer ier #O status return + +subroutine imckwl (kwl, ier) + +integer kwl #I keyword list descriptor +integer ier #O status return +.fi +.ih +DESCRIPTION +The keyword list package is used to define some subset of the keywords in an +image header, and then read successive elements of the set, i.e., read back +the keyword names. The keyword names are normally used as input to +\fIimtypk\fR or one of the \fIimgkw\fR procedures to obtain additional +information about each keyword. The keyword list package is the only means +whereby a program can examine the contents of an image header without knowing +in advance the names of the individual header keywords. A typical application +of the keyword list package is listing the contents of an image header. + +The pattern string \fIpatstr\fR is used to specify the subset of header keywords +to be used to form the output list. Some useful values are "*", which returns +the names of all header keywords, and "i_", which returns the names of only the +standard header keywords. If the pattern string does not contain any pattern +matching meta-characters it is treated as a prefix string (e.g., as "^patstr*"). +.ih +RETURN VALUE +The \fIimokwl\fR procedure returns a nonzero status only if it runs out of +storage for the keyword list. It is not an error for a list to be empty. +The \fIimgnkw\fR procedure returns a nonzero status when the end of the +keyword list is reached. + +.nf +SYS_IMFNOVFL: out of space for header keyword name list +IE_EOF: end of file or list detected +.fi +.ih +NOTES +An example illustrating the use of the keyword list package may be found +in imfort$tasks/phead.f. +.ih +SEE ALSO +imtypk, imgkw +.endhelp diff --git a/sys/imfort/doc/imopen.hlp b/sys/imfort/doc/imopen.hlp new file mode 100644 index 00000000..3df3ca51 --- /dev/null +++ b/sys/imfort/doc/imopen.hlp @@ -0,0 +1,35 @@ +.help imopen Sep86 imfort +.ih +NAME +imopen -- open an existing image +.ih +SYNOPSIS +.nf +subroutine imopen (image, acmode, im, ier) + +character*(*) image #I host image to be opened +integer acmode #I access mode +integer im #O receives image descriptor +integer ier #O status code +.fi +.ih +DESCRIPTION +The \fIimopen\fR procedure is used to open an existing image for either +read only access (\fIacmode\fR=1) or read write access (\fIacmode\fR=3). +The image name must be the host system filename of the image, although +the extension may be omitted if desired. If the image open is successful +an image descriptor is returned in \fIim\fR. +.ih +RETURN VALUE +A nonzero status code is returned if the image does not exist or cannot +be opened with the indicated access mode. + +.nf +IE_OPEN: cannot open image +IE_NOTIMH: attempt to access a non-image file as an image +IE_OPNPIX: cannot open pixel file +.fi +.ih +SEE ALSO +imclos, imcrea, imopnc, imdele, imrnam +.endhelp diff --git a/sys/imfort/doc/imopnc.hlp b/sys/imfort/doc/imopnc.hlp new file mode 100644 index 00000000..b4f5d9a9 --- /dev/null +++ b/sys/imfort/doc/imopnc.hlp @@ -0,0 +1,49 @@ +.help imopnc Sep86 imfort +.ih +NAME +imopnc -- open a new copy of an existing image +.ih +SYNOPSIS +.nf +imopnc (nimage, oim, nim, ier) + +character*(*) nimage #I host name of the new image +integer oim #I image descriptor of existing image +integer nim #O image descriptor of the new image +integer ier #O status return +.fi +.ih +DESCRIPTION +The \fIimopnc\fR procedure is used to open a new copy of an existing image, +copying the non-pixel fields of the old image header to the new image. +The new image must be the same size and datatype as the old image. +The new image is created, the header information is copied, and the pixel +file is allocated, but no pixel data is copied, and the \fIdatamin\fR and +\fIdatamax\fR fields of the image header are reset to zero. The new image +is opened for read-write access and the image descriptor of the new image +is returned in \fInim\fR. +.ih +RETURN VALUE +A zero status value is returned if the operation is successful, i.e., if +\fIoim\fR is a valid image descriptor of an existing image already opened +with \fIimopen\fR or \fIimopnc\fR, the new image was successfully created, +and the header was successfully copied. + +.nf +IE_ACCPIX: error writing into pixel file during image create +IE_ALCPIX: cannot create or allocate space for pixel file +IE_CREHDR: cannot create image +IE_MAGIC: illegal imfort image descriptor +IE_OPEN: cannot open image +IE_OPNPIX: cannot open pixel file +IE_UPDHDR: error updating image header file +.fi +.ih +NOTES +If it is desired that the new image be of a different size or datatype than +the old image, the new image must be explicitly created with \fIimcrea\fR, +opened with \fIimopen\fR, and the old header copied with \fIimhcpy\fR. +.ih +SEE ALSO +imcrea, imopen, imgsiz, imhcpy, imclos +.endhelp diff --git a/sys/imfort/doc/impixf.hlp b/sys/imfort/doc/impixf.hlp new file mode 100644 index 00000000..b5ccb335 --- /dev/null +++ b/sys/imfort/doc/impixf.hlp @@ -0,0 +1,53 @@ +.help impixf Sep86 imfort +.ih +NAME +impixf -- get the physical attributes of the pixel file +.ih +SYNOPSIS +.nf +subroutine impixf (im, pixfd, pixfil, pixoff, szline, ier) + +integer im #I image descriptor of open image +integer pixfd #O BFIO file descriptor of pixel file +character*(*) pixfil #O host filename of pixel file +integer pixoff #O 1-indexed "char" offset of pixels +integer szline #O "chars" per physical image line +integer ier #O status return +.fi +.ih +DESCRIPTION +The \fIimpixf\fR procedure is used to obtain information describing the +physical layout of the pixel segment of an image in a binary disk file. +The pixel array of an image accessible via the IMFORT interface is stored +externally in the host file \fIpixfil\fR in line storage mode (as in a +Fortran array). Each line of the image is stored as a contiguous array of +pixels accessible via a BFIO \fIbfread\fR or \fIbfwrit\fR request at the +offset of the first pixel in the line. The first image line (beginning at +pixel [1,1,1,...]) is stored at the file offset given by \fIpixoff\fR. +Each line consumes exactly \fIszline\fR chars of storage; lines may be +blocked to fill an integral number of disk blocks for more efficient access, +hence \fIszline\fR is not directly computable from \fIaxlen(1)\fR. + +Since \fIimpixf\fR is called on an open image, the pixel file will already +have been opened for random access buffered binary file i/o via the BFIO +interface. The BFIO file descriptor of the open pixel file is returned in +\fIpixfd\fR. This may be used in conjunction with BFIO to directly access +the pixel data. If the pixel data is to be accessed via explicit calls +to lower level host system facilities, the image should first be closed +with \fIimclos\fR to avoid possible problems with having the same file +opened multiple times. +.ih +RETURN VALUE +A zero status is returned for any image which has a valid image descriptor. + +IE_MAGIC: illegal imfort image descriptor +.ih +NOTES +Programs which make use of the information provided by \fIimpixf\fR have +explicit knowledge of the physical image storage format and hence may not +work with future versions of the IMFORT interface supporting new physical +image storage formats. +.ih +SEE ALSO +imgsiz, imgs, imps, imgl, impl, bfread, bfwrit +.endhelp diff --git a/sys/imfort/doc/impkw.hlp b/sys/imfort/doc/impkw.hlp new file mode 100644 index 00000000..8381e828 --- /dev/null +++ b/sys/imfort/doc/impkw.hlp @@ -0,0 +1,51 @@ +.help impkw Sep86 imfort +.ih +NAME +impkw -- set the value of an image header keyword +.ih +SYNOPSIS +.nf +subroutine impkwb (im, keyw, bval, ier) +subroutine impkwc (im, keyw, cval, ier) +subroutine impkwi (im, keyw, ival, ier) +subroutine impkwr (im, keyw, rval, ier) +subroutine impkwd (im, keyw, dval, ier) + +integer im #I image descriptor of open image +character*(*) keyw #I name of the keyword to be set +integer ier #O status return + +logical bval #I logical (boolean) keyword value +character*(*) cval #I character string keyword value +integer ival #I integer keyword value +real rval #I real keyword value +doubleprecision dval #I double precision keyword value +.fi +.ih +DESCRIPTION +The \fIimpkw\fR procedures are used to set the values of existing image +header keywords. It is an error if the named keyword does not already +exist; the \fIimakw\fR procedures should be used if one wants the keyword +to be automatically added if not found, but if the keyword is known +to exist it is preferable to use the \fIimpkw\fR procedures since they +are more efficient and will detect misspelled keyword names and foreign +images. Automatic datatype conversion is provided, i.e., it is not +necessary to know the exact datatype of a keyword to update its value. +.ih +RETURN VALUE +A zero status is returned if the named keyword exists, is writable, and if +the datatype coercion implied is permissible. + +.nf +SYS_IDBKEYNF: image header keyword not found +SYS_IDBTYPE: illegal header parameter data type conversion +.fi +.ih +NOTES +It is not an error to update the value of a keyword in an image opened +for read-only access, but an error status will be returned at \fIimclos\fR or +\fIimflsh\fR time since the header cannot be updated on disk. +.ih +SEE ALSO +imacck, imakw, imgkw +.endhelp diff --git a/sys/imfort/doc/impl.hlp b/sys/imfort/doc/impl.hlp new file mode 100644 index 00000000..4081f69f --- /dev/null +++ b/sys/imfort/doc/impl.hlp @@ -0,0 +1,49 @@ +.help impl Sep86 imfort +.ih +NAME +.nf +impl -- put (rewrite) an image line +.fi +.ih +SYNOPSIS +.nf +subroutine impl1r (im, rbuf, ier) +subroutine impl1s (im, sbuf, ier) +subroutine impl2r (im, rbuf, lineno, ier) +subroutine impl2s (im, sbuf, lineno, ier) +subroutine impl3r (im, rbuf, lineno, bandno, ier) +subroutine impl3s (im, sbuf, lineno, bandno, ier) + +integer im #I image descriptor of open image +real rbuf(*) #I output pixel buffer, type real +integer*2 sbuf(*) #I output pixel buffer, type short +integer lineno #I line (row) number (1:axlen(2)) +integer bandno #I band number (1:axlen(3)) +integer ier #O status return +.fi +.ih +DESCRIPTION +The \fIimpl\fR procedures are used to rewrite a line (row) of an image. +Procedures are provided for images of from one to three dimensions, +of pixel type short integer or real. The type real procedures may be +applied to images of either type, but the type short procedures may only +be used to access images of type short. The input buffer should contain +\fIaxlen(1)\fR pixels ready to be written to the image when the \fIimpl\fR +procedure is called. +.ih +RETURN VALUE +A zero status is returned if the referenced image line is in-bounds and +the actual pixel datatype of the image is one of the types permitted by +the particular operator called. + +.nf +IE_NOTSHORT: imfort short integer i/o requires a type short image +IE_PIXTYPE: image pixel type must be short or real +IE_WRPIX: error writing image pixel file +IE_YOOB: image y coordinates out of range +IE_ZOOB: image z coordinates out of range +.fi +.ih +SEE ALSO +imgl, imgs, imps +.endhelp diff --git a/sys/imfort/doc/imps.hlp b/sys/imfort/doc/imps.hlp new file mode 100644 index 00000000..6850f052 --- /dev/null +++ b/sys/imfort/doc/imps.hlp @@ -0,0 +1,54 @@ +.help imps Sep86 imfort +.ih +NAME +.nf +imps -- put (rewrite) an image section +.fi +.ih +SYNOPSIS +.nf +subroutine imps1r (im, rbuf, i1,i2, ier) +subroutine imps1s (im, sbuf, i1,i2, ier) +subroutine imps2r (im, rbuf, i1,i2, j1,j2, ier) +subroutine imps2s (im, sbuf, i1,i2, j1,j2, ier) +subroutine imps3r (im, rbuf, i1,i2, j1,j2, k1,k2, ier) +subroutine imps3s (im, sbuf, i1,i2, j1,j2, k1,k2, ier) + +integer im #I image descriptor of open image +real rbuf(*) #I output pixel buffer, type real +integer*2 sbuf(*) #I output pixel buffer, type short +integer i1, i2 #I range of columns to be updated +integer j1, j2 #I range of lines to be updated +integer k1, k2 #I range of bands to be updated +integer ier #O status return +.fi +.ih +DESCRIPTION +The \fIimps\fR procedures are used to rewrite a section (subraster) of an image. +Procedures are provided for images of from one to three dimensions, +of pixel type short integer or real. The type real procedures may be +applied to images of either type, but the type short procedures may only +be used to access images of type short. The output buffer should contain +at least (i1-i2+1) pixels (\fIps1\fR), ((j2-j1+1) * (i2-i1+1)) pixels +(\fIps2\fR), or ((k2-k1+1) * (j2-j1+1) * (i2-i1+1)) pixels (\fIps3\fR). +The pixels are assumed to be in Fortran storage order. The column index +\fIi2\fR must be greater than or equal to \fIi1\fR, but the remaining +subscripts may be swapped if desired. +.ih +RETURN VALUE +A zero status is returned if the referenced image line is in-bounds and +the actual pixel datatype of the image is one of the types permitted by +the particular operator called. + +.nf +IE_NOTSHORT: imfort short integer i/o requires a type short image +IE_PIXTYPE: image pixel type must be short or real +IE_WRPIX: error writing image pixel file +IE_XOOB: image x coordinates out of range or out of order +IE_YOOB: image y coordinates out of range +IE_ZOOB: image z coordinates out of range +.fi +.ih +SEE ALSO +imgs, imgl, impl +.endhelp diff --git a/sys/imfort/doc/imrnam.hlp b/sys/imfort/doc/imrnam.hlp new file mode 100644 index 00000000..03ba6d6b --- /dev/null +++ b/sys/imfort/doc/imrnam.hlp @@ -0,0 +1,35 @@ +.help imrnam Sep86 imfort +.ih +NAME +imrnam -- rename an image +.ih +SYNOPSIS +.nf +subroutine imrnam (oldnam, newnam, ier) + +character*(*) oldnam #I host name of existing image +character*(*) newnam #I new host name for image +integer ier #O status return +.fi +.ih +DESCRIPTION +The \fIimrnam\fR procedure renames an image, i.e., changes the filenames +of both the header and pixel files. An image may be renamed to a different +directory if desired, in effect moving the image to the new directory. +.ih +RETURN VALUE +A zero status is returned if the image exists and was successfully renamed. + +.nf +IE_IMRNAMNEXIM: attempt to rename a nonexistent image +IE_IMRENAME: cannot rename image +.fi +.ih +NOTES +Since the filename of the pixel file associated with an image may be +saved in the image header, it is not advisable to use an ordinary file +rename operator to rename an image. +.ih +SEE ALSO +imdele, imcrea +.endhelp diff --git a/sys/imfort/doc/imtypk.hlp b/sys/imfort/doc/imtypk.hlp new file mode 100644 index 00000000..b8f3b4b0 --- /dev/null +++ b/sys/imfort/doc/imtypk.hlp @@ -0,0 +1,33 @@ +.help imtypk Sep86 imfort +.ih +NAME +imtypk -- get the type information for a header keyword +.ih +SYNOPSIS +.nf +subroutine imtypk (im, keyw, dtype, comm, ier) + +integer im #I image descriptor of open image +character*(*) keyw #I name of the new keyword +integer dtype #O keyword datatype code +character*(*) comm #O comment string describing keyword +integer ier #O status return +.fi +.ih +DESCRIPTION +The \fIimtypk\fR procedure is used to fetch the information defining +the type and usage of an image header keyword, i.e., the datatype code +and comment string. Knowledge of the keyword datatype may be required +before accessing the value of a keyword to avoid a format conversion error +if only the name of the keyword is known (e.g., when using the keyword-list +package). The \fIimtypk\fR procedure is the only means currently available +for retrieving the comment string associated with a header keyword. +.ih +RETURN VALUE +A zero status is returned if the named keyword exists. + +SYS_IDBKEYNF: image header keyword not found +.ih +SEE ALSO +imaddk, imacck +.endhelp diff --git a/sys/imfort/imacck.x b/sys/imfort/imacck.x new file mode 100644 index 00000000..ef6b3314 --- /dev/null +++ b/sys/imfort/imacck.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imfort.h" + +# IMACCK -- Test if the named keyword exists. IER=0 is returned if the +# parameter exists. + +procedure imacck (im, key, ier) + +pointer im # image descriptor +% character*(*) key +int ier + +pointer sp, kp +int imaccf() + +begin + call smark (sp) + call salloc (kp, SZ_KEYWORD, TY_CHAR) + + call f77upk (key, Memc[kp], SZ_KEYWORD) + if (imaccf (im, Memc[kp]) == YES) + ier = OK + else { + ier = IE_NEXKW + call im_seterrop (ier, Memc[kp]) + } + + call sfree (sp) +end diff --git a/sys/imfort/imaddk.x b/sys/imfort/imaddk.x new file mode 100644 index 00000000..0e6054dc --- /dev/null +++ b/sys/imfort/imaddk.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imfort.h" + +# IMADDK -- Add a new keyword to the image header. + +procedure imaddk (im, keyw, dtype, comm, ier) + +pointer im # imfort image descriptor +% character*(*) keyw +int dtype +% character*(*) comm +int ier + +pointer sp, kp, cp +int errcode() + +begin + call smark (sp) + call salloc (kp, SZ_KEYWORD, TY_CHAR) + call salloc (cp, SZ_LINE, TY_CHAR) + + call f77upk (keyw, Memc[kp], SZ_KEYWORD) + call f77upk (comm, Memc[cp], SZ_LINE) + + iferr (call imaddf (im, Memc[kp], dtype, Memc[cp])) { + ier = errcode() + call im_seterrop (ier, Memc[kp]) + } else { + ier = OK + IM_UPDATE(im) = YES + } + + call sfree (sp) +end diff --git a/sys/imfort/imakwb.x b/sys/imfort/imakwb.x new file mode 100644 index 00000000..9b857c17 --- /dev/null +++ b/sys/imfort/imakwb.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imfort.h" + +# IMAKWB -- Add a new keyword of type bool. + +procedure imakwb (im, keyw, bval, comm, ier) + +pointer im # imfort image descriptor +% character*(*) keyw +bool bval +% character*(*) comm +int ier + +pointer sp, kp, cp +int errcode() + +begin + call smark (sp) + call salloc (kp, SZ_KEYWORD, TY_CHAR) + call salloc (cp, SZ_VALSTR, TY_CHAR) + + call f77upk (keyw, Memc[kp], SZ_KEYWORD) + call f77upk (comm, Memc[cp], SZ_VALSTR) + + iferr (call imaddb (im, Memc[kp], bval, Memc[cp])) { + ier = errcode() + call im_seterrop (ier, Memc[kp]) + } else { + ier = OK + IM_UPDATE(im) = YES + } + + call sfree (sp) +end diff --git a/sys/imfort/imakwc.x b/sys/imfort/imakwc.x new file mode 100644 index 00000000..00e8f7d0 --- /dev/null +++ b/sys/imfort/imakwc.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imfort.h" + +# IMAKWC -- Add a new keyword of type string. + +procedure imakwc (im, keyw, sval, comm, ier) + +pointer im # imfort image descriptor +% character*(*) keyw +% character*(*) sval +% character*(*) comm +int ier + +pointer sp, kp, vp, cp +int errcode() + +begin + call smark (sp) + call salloc (kp, SZ_KEYWORD, TY_CHAR) + call salloc (vp, SZ_VALSTR, TY_CHAR) + call salloc (cp, SZ_VALSTR, TY_CHAR) + + call f77upk (keyw, Memc[kp], SZ_KEYWORD) + call f77upk (sval, Memc[vp], SZ_VALSTR) + call f77upk (comm, Memc[cp], SZ_VALSTR) + + iferr (call imastr (im, Memc[kp], Memc[vp], Memc[cp])) { + ier = errcode() + call im_seterrop (ier, Memc[kp]) + } else { + ier = OK + IM_UPDATE(im) = YES + } + + call sfree (sp) +end diff --git a/sys/imfort/imakwd.x b/sys/imfort/imakwd.x new file mode 100644 index 00000000..72467cd6 --- /dev/null +++ b/sys/imfort/imakwd.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imfort.h" + +# IMAKWD -- Add a new keyword of type double. + +procedure imakwd (im, keyw, dval, comm, ier) + +pointer im # imfort image descriptor +% character*(*) keyw +double dval +% character*(*) comm +int ier + +pointer sp, kp, cp +int errcode() + +begin + call smark (sp) + call salloc (kp, SZ_KEYWORD, TY_CHAR) + call salloc (cp, SZ_VALSTR, TY_CHAR) + + call f77upk (keyw, Memc[kp], SZ_KEYWORD) + call f77upk (comm, Memc[cp], SZ_VALSTR) + + iferr (call imaddd (im, Memc[kp], dval, Memc[cp])) { + ier = errcode() + call im_seterrop (ier, Memc[kp]) + } else { + ier = OK + IM_UPDATE(im) = YES + } + + call sfree (sp) +end diff --git a/sys/imfort/imakwi.x b/sys/imfort/imakwi.x new file mode 100644 index 00000000..be9e51f4 --- /dev/null +++ b/sys/imfort/imakwi.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imfort.h" + +# IMAKWI -- Add a new keyword of type int. + +procedure imakwi (im, keyw, ival, comm, ier) + +pointer im # imfort image descriptor +% character*(*) keyw +int ival +% character*(*) comm +int ier + +pointer sp, kp, cp +int errcode() + +begin + call smark (sp) + call salloc (kp, SZ_KEYWORD, TY_CHAR) + call salloc (cp, SZ_VALSTR, TY_CHAR) + + call f77upk (keyw, Memc[kp], SZ_KEYWORD) + call f77upk (comm, Memc[cp], SZ_VALSTR) + + iferr (call imaddi (im, Memc[kp], ival, Memc[cp])) { + ier = errcode() + call im_seterrop (ier, Memc[kp]) + } else { + ier = OK + IM_UPDATE(im) = YES + } + + call sfree (sp) +end diff --git a/sys/imfort/imakwr.x b/sys/imfort/imakwr.x new file mode 100644 index 00000000..5e1b9f48 --- /dev/null +++ b/sys/imfort/imakwr.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imfort.h" + +# IMAKWR -- Add a new keyword of type real. + +procedure imakwr (im, keyw, rval, comm, ier) + +pointer im # imfort image descriptor +% character*(*) keyw +real rval +% character*(*) comm +int ier + +pointer sp, kp, cp +int errcode() + +begin + call smark (sp) + call salloc (kp, SZ_KEYWORD, TY_CHAR) + call salloc (cp, SZ_VALSTR, TY_CHAR) + + call f77upk (keyw, Memc[kp], SZ_KEYWORD) + call f77upk (comm, Memc[cp], SZ_VALSTR) + + iferr (call imaddr (im, Memc[kp], rval, Memc[cp])) { + ier = errcode() + call im_seterrop (ier, Memc[kp]) + } else { + ier = OK + IM_UPDATE(im) = YES + } + + call sfree (sp) +end diff --git a/sys/imfort/imclos.x b/sys/imfort/imclos.x new file mode 100644 index 00000000..c182877a --- /dev/null +++ b/sys/imfort/imclos.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imfort.h" + +# IMCLOS -- Close an IMFORT image. If the image was opened read only the +# header file will already have been closed, otherwise it must be updated +# if it has been modified. + +procedure imclos (im, ier) + +pointer im # image descriptor +int ier # receives error status + +int status + +begin + call imflsh (im, ier) + + # Close the pixel file. + if (IM_PIXFP(im) != NULL) { + call bfclos (IM_PIXFP(im), status) + if (status == ERR && ier == OK) + ier = IE_CLSPIX + } + + # Close the header file. + if (IM_HDRFP(im) != NULL) { + call bfclos (IM_HDRFP(im), status) + if (status == ERR && ier == OK) + ier = IE_CLSHDR + } + + if (IM_LINEBUFP(im) != NULL) + call mfree (IM_LINEBUFP(im), TY_SHORT) + call mfree (im, TY_STRUCT) +end diff --git a/sys/imfort/imcrea.x b/sys/imfort/imcrea.x new file mode 100644 index 00000000..ab8e8ca9 --- /dev/null +++ b/sys/imfort/imcrea.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMCREA -- Create a new image of the indicated size and pixel type. +# Fortran callable version. + +procedure imcrea (f77nam, axlen, naxis, pixtype, ier) + +% character*(*) f77nam +int axlen[ARB] # receives axis lengths +int naxis # receives number of axes +int pixtype # receives pixel type +int ier # receives error status + +char fname[SZ_PATHNAME] + +begin + # Convert character string to SPP string. + call f77upk (f77nam, fname, SZ_PATHNAME) + call imcrex (fname, axlen, naxis, pixtype, ier) +end diff --git a/sys/imfort/imcrex.x b/sys/imfort/imcrex.x new file mode 100644 index 00000000..5a5bce1e --- /dev/null +++ b/sys/imfort/imcrex.x @@ -0,0 +1,170 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "imfort.h" +include "oif.h" + +# IMCREX -- Create a new image of the indicated size and pixel type. +# Both the header and pixel file are created at the same time. For +# simplicity we put both files in the same directory. The name of the +# pixel file is the same as that of the header file, but with the +# extension ".pix". + +procedure imcrex (image, axlen, naxis, pixtype, ier) + +char image[ARB] #I HOST filename of image +int axlen[IM_MAXDIM] #I axis lengths +int naxis #I number of axes +int pixtype #I pixel type +int ier #O receives error status + +int fp, status, ip, i +long pfsize, clktime, cputime +pointer sp, hdrfile, pixfile, osfn, root, extn, sval, im + +pointer bfopnx() +int imwrhdr(), ctoi() +define done_ 91 +define operr_ 92 +errchk calloc + +begin + call smark (sp) + call salloc (hdrfile, SZ_FNAME, TY_CHAR) + call salloc (pixfile, SZ_PATHNAME, TY_CHAR) + call salloc (osfn, SZ_PATHNAME, TY_CHAR) + call salloc (root, SZ_FNAME, TY_CHAR) + call salloc (extn, SZ_FNAME, TY_CHAR) + call salloc (sval, SZ_FNAME, TY_CHAR) + + # Verify image size and datatype operands. + ier = OK + if (naxis < 1 || naxis > MAX_NAXIS) + ier = IE_NAXIS + if (ier == OK) + do i = 1, naxis + if (axlen[i] < 1) + ier = IE_AXLEN + if (ier == OK) + if (pixtype != TY_SHORT && pixtype != TY_REAL) + ier = IE_PIXTYPE + if (ier != OK) { + call im_seterrop (ier, image) + goto done_ + } + + # Construct the name of the image header file. + call imf_parse (image, Memc[root], Memc[extn]) + if (Memc[extn] == EOS) + call strcpy (OIF_HDREXTN, Memc[extn], SZ_FNAME) + + call strcpy (Memc[root], Memc[hdrfile], SZ_FNAME) + call strcat (".", Memc[hdrfile], SZ_FNAME) + call strcat (Memc[extn], Memc[hdrfile], SZ_FNAME) + + # Check to see if the new image would overwrite an existing one. + # This is an error, unless "clobber" is defined in the user + # environment. + + call strpak (Memc[hdrfile], Memc[osfn], SZ_PATHNAME) + call zfacss (Memc[osfn], 0, 0, status) + if (status == YES) { + call strpak ("clobber", Memc[sval], SZ_FNAME) + call zgtenv (Memc[sval], Memc[sval], SZ_FNAME, status) + if (status != ERR) { + call imdelx (image, ier) + if (ier != OK) { + ier = IE_CREHDR + goto operr_ + } + } else { + ier = IE_CLOBBER + goto operr_ + } + } + + # Create the new image. + fp = bfopnx (Memc[hdrfile], NF, RANDOM) + if (fp == ERR) { + ier = IE_CREHDR +operr_ call sfree (sp) + call im_seterrop (ier, Memc[hdrfile]) + return + } + + # Allocate and initialize the image header. + call calloc (im, LEN_IMDES + LEN_IMHDR, TY_STRUCT) + call zgtime (clktime, cputime) + + call strcpy ("imhdr", IM_MAGIC(im), SZ_IMMAGIC) + call amovi (axlen, IM_LEN(im,1), naxis) + IM_ACMODE(im) = NEW_IMAGE + IM_NDIM(im) = naxis + IM_PIXTYPE(im) = pixtype + IM_HDRLEN(im) = LEN_IMHDR + IM_CTIME(im) = clktime + IM_MTIME(im) = clktime + Memc[IM_USERAREA(im)] = EOS + call imf_initoffsets (im, SZ_DEVBLK) + pfsize = IM_HGMOFF(im) - 1 + + # Get the image format version for new images. + call strpak (ENV_OIFVER, Memc[sval], SZ_FNAME) + call zgtenv (Memc[sval], Memc[sval], SZ_FNAME, status) + if (status != ERR) { + ip = 1 + call strupk (Memc[sval], Memc[sval], SZ_FNAME) + if (ctoi (Memc[sval], ip, IM_HDRVER(im)) <= 0) + IM_HDRVER(im) = DEF_VERSION + } else + IM_HDRVER(im) = DEF_VERSION + + # Get a unique pixel file name. + call aclrc (IM_HDRFILE(im), SZ_IMHDRFILE) + call strcpy (Memc[hdrfile], IM_HDRFILE(im), SZ_IMHDRFILE) + call imf_mkpixfname (im, Memc[pixfile], SZ_IMPIXFILE, ier) + if (ier != OK) + goto done_ + + # Write the image header and close the header file. + if (imwrhdr (fp, im, TY_IMHDR) == ERR) { + call bfclos (fp, status) + status = ERR + } else + call bfclos (fp, status) + + if (status == ERR) { + ier = IE_WRHDR + call im_seterrop (ier, Memc[hdrfile]) + return + } + + # Create the pixel storage file. + call bfalcx (Memc[pixfile], pfsize, status) + if (status == ERR) { + ier = IE_ALCPIX + call im_seterrop (ier, Memc[pixfile]) + goto done_ + } + + # Write the backpointing pixel header into the pixel file. + fp = bfopnx (Memc[pixfile], WO, RANDOM) + if (fp == ERR) { + status = ERR + } else if (imwrhdr (fp, im, TY_PIXHDR) == ERR) { + call bfclos (fp, status) + status = ERR + } else + call bfclos (fp, status) + + call mfree (im, TY_STRUCT) + if (status == ERR) { + ier = IE_ACCPIX + call im_seterrop (ier, Memc[pixfile]) + } else + ier = OK +done_ + call sfree (sp) +end diff --git a/sys/imfort/imdele.x b/sys/imfort/imdele.x new file mode 100644 index 00000000..9112021c --- /dev/null +++ b/sys/imfort/imdele.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMDELE -- Delete an image (both the header file and the pixel file). +# It is not an error if there is no pixel file. + +procedure imdele (image, ier) + +% character*(*) image +int ier # receives error status + +pointer sp, imname + +begin + call smark (sp) + call salloc (imname, SZ_PATHNAME, TY_CHAR) + + call f77upk (image, Memc[imname], SZ_PATHNAME) + call imdelx (Memc[imname], ier) + + call sfree (sp) +end diff --git a/sys/imfort/imdelk.x b/sys/imfort/imdelk.x new file mode 100644 index 00000000..f23c6d79 --- /dev/null +++ b/sys/imfort/imdelk.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imfort.h" + +# IMDELK -- Delete the named header keyword. + +procedure imdelk (im, keyw, ier) + +pointer im # imfort image descriptor +% character*(*) keyw +int ier + +pointer sp, kp +int errcode() + +begin + call smark (sp) + call salloc (kp, SZ_KEYWORD, TY_CHAR) + + call f77upk (keyw, Memc[kp], SZ_KEYWORD) + iferr (call imdelf (im, Memc[kp])) { + ier = errcode() + call im_seterrop (ier, Memc[kp]) + } else { + ier = OK + IM_UPDATE(im) = YES + } + + call sfree (sp) +end diff --git a/sys/imfort/imdelx.x b/sys/imfort/imdelx.x new file mode 100644 index 00000000..d49451fc --- /dev/null +++ b/sys/imfort/imdelx.x @@ -0,0 +1,76 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "imfort.h" + +# IMDELX -- Delete an image (both the header file and the pixel file). +# It is not an error if there is no pixel file. + +procedure imdelx (image, ier) + +char image[ARB] #I image to be deleted +int ier #O receives error status + +int status +pointer im, sp, hdrfile, pixfile, ip +int stridxs() +define quit_ 91 + +begin + call smark (sp) + call salloc (hdrfile, SZ_PATHNAME, TY_CHAR) + call salloc (pixfile, SZ_PATHNAME, TY_CHAR) + + # Get the OS pathnames of the header and pixel files. + + call imopnx (image, RO, im, ier) + if (ier != OK) { + ier = IE_IMDELNEXIM + goto quit_ + } else { + call strcpy (IM_HDRFILE(im), Memc[hdrfile], SZ_PATHNAME) + call imf_gpixfname (IM_PIXFILE(im), IM_HDRFILE(im), Memc[pixfile], + SZ_PATHNAME) + ip = pixfile + stridxs ("!", Memc[pixfile]) + call strcpy (Memc[ip], Memc[pixfile], SZ_PATHNAME) + call imclos (im, ier) + if (ier != OK) + goto quit_ + } + + call strpak (Memc[hdrfile], Memc[hdrfile], SZ_FNAME) + call strpak (Memc[pixfile], Memc[pixfile], SZ_PATHNAME) + + # Verify that the header file exists. + call zfacss (Memc[hdrfile], 0, 0, status) + if (status == NO) { + ier = IE_IMDELNEXIM + goto quit_ + } + + # Remove any file delete protection from the image header file. + # Do not complain if the header is not protected, or if there is + # no pixel file to be deleted. + + call zfprot (Memc[hdrfile], REMOVE_PROTECTION, status) + call zfdele (Memc[hdrfile], status) + + if (status == ERR) + ier = IE_IMDELETE + else { + call zfacss (Memc[pixfile], 0, 0, status) + if (status == NO) + ier = OK + else { + call zfdele (Memc[pixfile], status) + if (status == ERR) + ier = IE_IMDELETE + } + } + +quit_ + if (ier != OK) + call im_seterrop (ier, image) + call sfree (sp) +end diff --git a/sys/imfort/imemsg.x b/sys/imfort/imemsg.x new file mode 100644 index 00000000..68855b68 --- /dev/null +++ b/sys/imfort/imemsg.x @@ -0,0 +1,168 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "imfort.h" + +define SZ_OPNAME 64 + +# IMEMSG -- Translate an IMFORT or VOS error code into a message string. + +procedure imemsg (ier, errmsg) + +int ier # error code +% character*(*) errmsg + +pointer sp, ostr +int e_ier +char e_opname[SZ_OPNAME] +common /imemcm/ e_ier, e_opname + +begin + switch (ier) { + case IE_ACCPIX: +% errmsg = 'error writing into pixel file during image create' + case IE_ALCPIX: +% errmsg = 'cannot create or allocate space for pixel file' + case IE_CLSHDR: +% errmsg = 'error closing image header file' + case IE_CLSPIX: +% errmsg = 'error closing image pixel file' + case IE_CREHDR: +% errmsg = 'cannot create image' + case IE_FLUSH: +% errmsg = 'error flushing buffered data to pixel file' + case IE_GCMDLN: +% errmsg = 'cannot read command line string' + case IE_IMDELETE: +% errmsg = 'cannot delete image' + case IE_IMDELNEXIM: +% errmsg = 'attempt to delete a nonexistent image' + case IE_IMRENAME: +% errmsg = 'cannot rename image' + case IE_IMRNAMNEXIM: +% errmsg = 'attempt to rename a nonexistent image' + case IE_MAGIC: +% errmsg = 'illegal imfort image descriptor' + case IE_NEXARG: +% errmsg = 'nonexistent command line argument referenced' + case IE_NEXKW: +% errmsg = 'nonexistent header keyword referenced' + case IE_NONNUMARG: +% errmsg = 'cannot decode numeric argument' + case IE_NOTIMH: +% errmsg = 'attempt to access a non-image file as an image' + case IE_NOTSHORT: +% errmsg = 'image is not of type short' + case IE_OPEN: +% errmsg = 'cannot open image' + case IE_OPNPIX: +% errmsg = 'cannot open pixel file' + case IE_PIXTYPE: +% errmsg = 'image pixel type must be short or real' + case IE_RDPIX: +% errmsg = 'error reading image pixel file' + case IE_UPDHDR: +% errmsg = 'error updating image header file' + case IE_UPDRO: +% errmsg = 'image header modified but image opened read only' + case IE_WRHDR: +% errmsg = 'error writing to image header file' + case IE_WRPIX: +% errmsg = 'error writing image pixel file' + case IE_XOOB: +% errmsg = 'image x coordinates out of range or out of order' + case IE_YOOB: +% errmsg = 'image y coordinates out of range' + case IE_ZOOB: +% errmsg = 'image z coordinates out of range' + case IE_EOF: +% errmsg = 'end of file or list detected' + case IE_NAXIS: +% errmsg = 'wrong number of axes on image' + case IE_AXLEN: +% errmsg = 'length of each image axis must be .ge. 1' + case IE_MKDIR: +% errmsg = 'cannot create pixel subdirectory' + case IE_PFNNUNIQ: +% errmsg = 'cannot create unique pixel file name' + case IE_CLOBBER: +% errmsg = 'new image would overwrite existing image' + + case SYS_IDBDELNXKW: +% errmsg = 'attempt to delete unknown header keyword' + case SYS_IDBKEYNF: +% errmsg = 'image header keyword not found' + case SYS_IDBNODEL: +% errmsg = 'cannot delete image header keyword' + case SYS_IDBOVFL: +% errmsg = 'out of space in image header' + case SYS_IDBREDEF: +% errmsg = 'attempt to redefine an image header keyword' + case SYS_IDBTYPE: +% errmsg = 'illegal header parameter data type conversion' + case SYS_IMFNOVFL: +% errmsg = 'out of space for header keyword name list' + + default: +% errmsg = 'imfort error (unrecognized error code)' + } + + # If the current error code agrees with that of the most recently + # posted operand name, add the operand name to the error string. + + if (ier == e_ier && e_opname[1] != EOS) { + call smark (sp) + call salloc (ostr, SZ_LINE, TY_CHAR) + + call f77upk (errmsg, Memc[ostr], SZ_LINE) + call strcat (" (", Memc[ostr], SZ_LINE) + call strcat (e_opname, Memc[ostr], SZ_LINE) + call strcat (")", Memc[ostr], SZ_LINE) + call f77pak (Memc[ostr], errmsg, len(errmsg)) + + call sfree (sp) + } +end + + +# IM_SETERROP -- Called to set the operand name when an error occurs, so that +# it may be included in the error message string without being passed back to +# the user program. + +procedure im_seterrop (ier, opname) + +int ier # current error code +char opname[ARB] # associated operand name + +int e_ier +char e_opname[SZ_OPNAME] +common /imemcm/ e_ier, e_opname + +begin + e_ier = ier + call strcpy (opname, e_opname, SZ_OPNAME) +end + + +# IM_SETERRIM -- A variation on im_seterrop, used to set the image name as +# the error operand, given the image descriptor. + +procedure im_seterrim (ier, im) + +int ier # current error code +pointer im # image descriptor + +int junk +pointer sp, opname +int fnroot() + +begin + call smark (sp) + call salloc (opname, SZ_OPNAME, TY_CHAR) + + junk = fnroot (IM_HDRFILE(im), Memc[opname], TY_CHAR) + call im_seterrop (ier, Memc[opname]) + + call sfree (sp) +end diff --git a/sys/imfort/imfdir.x b/sys/imfort/imfdir.x new file mode 100644 index 00000000..90d9ca79 --- /dev/null +++ b/sys/imfort/imfdir.x @@ -0,0 +1,110 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "oif.h" + +# IMFDIR -- Routines for setting or retrieving the "imdir" (pixel file storage +# directory) for IMFORT. +# +# im[sg]dir (dir) # set/get imdir - F77 versions +# imsdirx (dir) # set imdir - SPP version +# nch = imgdirx (dir, maxch) # get imdir - SPP version +# +# By default, pixel files are stored in the same directory as the header file, +# using a HDR$ pathname in the image header. If the user wishes they can +# explicitly set the directory into which all further pixel files will be +# placed, until another call to the set-imdir routine. + + +# IMSDIR -- Set the value of `imdir' for imfort. + +procedure imsdir (dir) + +% character*(*) dir + +char imdir[SZ_PATHNAME] +common /imdcom/ imdir + +begin + call imdinit() + call f77upk (dir, imdir, SZ_PATHNAME) +end + + +# IMGDIR -- Get the value of `imdir' for imfort. + +procedure imgdir (dir) + +% character*(*) dir + +char imdir[SZ_PATHNAME] +common /imdcom/ imdir + +begin + call imdinit() + call f77pak (imdir, dir, len(dir)) +end + + +# IMSDIRX -- Set the value of `imdir' for imfort, SPP version. + +procedure imsdirx (dir) + +char dir[ARB] #I new value of imdir + +char imdir[SZ_PATHNAME] +common /imdcom/ imdir + +begin + call imdinit() + call strcpy (dir, imdir, SZ_PATHNAME) +end + + +# IMGDIRX -- Get the value of `imdir' for imfort, SPP version. + +int procedure imgdirx (dir, maxch) + +char dir[maxch] #O receives value of imdir +int maxch + +int gstrcpy() +char imdir[SZ_PATHNAME] +common /imdcom/ imdir + +begin + call imdinit() + return (gstrcpy (imdir, dir, maxch)) +end + + +# IMDINIT -- Runtime initialization of the imdir common. + +procedure imdinit() + +int status +char envvar[5] +bool first_time +data first_time /true/ + +char imdir[SZ_PATHNAME] +common /imdcom/ imdir + +begin + if (first_time) { + # Check the host environment for the default IMDIR. + call strpak ("imdir", envvar, 5) + call zgtenv (envvar, imdir, SZ_PATHNAME, status) + if (status < 0) { + call strpak ("IMDIR", envvar, 5) + call zgtenv (envvar, imdir, SZ_PATHNAME, status) + } + + # Use the builtin default HDR$ if not defined in host enviroment. + if (status < 0) + call strcpy (HDR, imdir, SZ_PATHNAME) + else + call strupk (imdir, imdir, SZ_PATHNAME) + + first_time = false + } +end diff --git a/sys/imfort/imfgpfn.x b/sys/imfort/imfgpfn.x new file mode 100644 index 00000000..d8fe9567 --- /dev/null +++ b/sys/imfort/imfgpfn.x @@ -0,0 +1,59 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "oif.h" + +# IMF_GPIXFNAME -- Convert a logical pixfile name into a physical pathname. + +procedure imf_gpixfname (pixfile, hdrfile, path, maxch) + +char pixfile[ARB] # pixfile name +char hdrfile[ARB] # header file name (gives hdr directory) +char path[maxch] # receives pathname +int maxch + +int ip, nchars +pointer sp, fname, op +int strncmp(), fnldir() + +begin + # Merely return pathname if not case "HDR$". + if (strncmp (pixfile, HDR, STRLEN_HDR) != 0) { + call zfpath (pixfile, path, maxch, nchars) + return + } + + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + # Get host pathname of pixel file directory. + nchars = fnldir (hdrfile, Memc[fname], SZ_PATHNAME) + call zfpath (Memc[fname], path, maxch, nchars) + + # Fold in any subdirectories from the pixfile name. + # (as in HDR$pixels/). + + op = fname + nchars = 0 + + for (ip=STRLEN_HDR+1; pixfile[ip] != EOS; ip=ip+1) { + if (pixfile[ip] == '/') { + Memc[op] = EOS + call zfsubd (path, maxch, Memc[fname], nchars) + op = fname + } else { + Memc[op] = pixfile[ip] + op = op + 1 + } + } + + # Tack on the pixel file name, which was left in the fname buf. + if (op > fname) { + Memc[op] = EOS + if (nchars > 0) + call strcpy (Memc[fname], path[nchars+1], maxch-nchars) + else + call strcat (Memc[fname], path, maxch) + } + + call sfree (sp) +end diff --git a/sys/imfort/imflsh.x b/sys/imfort/imflsh.x new file mode 100644 index 00000000..5ae36b2f --- /dev/null +++ b/sys/imfort/imflsh.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imfort.h" + +# IMFLSH -- Flush any buffered image data, i.e., synchronize the in-core +# version of an image with that on disk. + +procedure imflsh (im, ier) + +pointer im # image descriptor +int ier + +int status +int bfflsh() + +begin + ier = OK + + # Flush any buffered output pixel data. + status = bfflsh (IM_PIXFP(im)) + if (status == ERR) + ier = IE_FLUSH + + # Update the image header if it has been modified. + if (IM_HDRFP(im) != NULL) { + if (IM_UPDATE(im) == YES) { + call imf_updhdr (im, status) + if (status == ERR && ier == OK) + ier = IE_UPDHDR + } + } else if (IM_UPDATE(im) == YES && ier == OK) + ier = IE_UPDRO +end diff --git a/sys/imfort/imfmkpfn.x b/sys/imfort/imfmkpfn.x new file mode 100644 index 00000000..58fc1fea --- /dev/null +++ b/sys/imfort/imfmkpfn.x @@ -0,0 +1,137 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "imfort.h" +include "oif.h" + +# IMF_MKPIXFNAME -- Generate the pixel file name. Leave the logical pixfile +# name in the image header, and return the pathname to the pixel file in the +# output argument. + +procedure imf_mkpixfname (im, pixfile, maxch, ier) + +pointer im #I image descriptor +char pixfile[maxch] #O receives pathname to pixfile +int maxch #I max chars out +int ier #O exit status code + +int status, n +char suffix[2], hdr[STRLEN_HDR] +pointer sp, imdir, osdir, root, extn, subdir, fname, ip, op +int fnroot(), fnldir(), strncmp(), imgdirx() +string pixextn OIF_PIXEXTN +define done_ 91 + +begin + call smark (sp) + call salloc (imdir, SZ_PATHNAME, TY_CHAR) + call salloc (osdir, SZ_PATHNAME, TY_CHAR) + call salloc (root, SZ_PATHNAME, TY_CHAR) + call salloc (subdir, SZ_PATHNAME, TY_CHAR) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (extn, SZ_FNAME, TY_CHAR) + + ier = OK + + # Get the logical directory where the pixel file goes. + n = imgdirx (Memc[imdir], SZ_PATHNAME) + + # If the imdir name begins with "HDR$", put the pixfile in same + # directory as the header or in a subdirectory, else put the pixel + # file in the named directory. If the pixel file goes in a HDR + # subdirectory, create the directory if it does not already exist. + # For IMFORT programs which are subject to the whims of the host + # system, be a little forgiving about the case of the HDR$. + + call strcpy (Memc[imdir], hdr, STRLEN_HDR) + call strupr (hdr) + + if (strncmp (hdr, HDR, STRLEN_HDR) == 0) { + call amovc (HDR, Memc[imdir], STRLEN_HDR) + + ip = imdir + STRLEN_HDR + for (op=subdir; Memc[ip] != EOS && Memc[ip] != '/'; ip=ip+1) { + Memc[op] = Memc[ip] + op = op + 1 + } + Memc[op] = EOS + + # Make the subdirectory if it does not already exist. + if (Memc[subdir] != EOS) { + n = fnldir (IM_HDRFILE(im), Memc[osdir], SZ_PATHNAME) + call zfpath (Memc[osdir], Memc[fname], SZ_PATHNAME, n) + call zfsubd (Memc[fname], SZ_PATHNAME, Memc[subdir], n) + + call strpak (Memc[fname], Memc[fname], SZ_PATHNAME) + call zfacss (Memc[fname], 0, DIRECTORY_FILE, status) + + if (status == NO) { + call zfmkdr (Memc[fname], status) + if (status == ERR) { + ier = IE_MKDIR + goto done_ + } + } + } + } else + call zfpath (Memc[imdir], Memc[imdir], SZ_PATHNAME, n) + + # Make up the root name of the new pixel file. + if (fnroot (IM_HDRFILE(im), Memc[fname], SZ_PATHNAME) <= 0) + call strcpy (pixextn, Memc[fname], SZ_PATHNAME) + call strcat (".", Memc[fname], SZ_PATHNAME) + call strcat (pixextn, Memc[fname], SZ_PATHNAME) + call imf_trans (Memc[fname], Memc[root], Memc[extn]) + + # Get a unique pixel file name. If a file with the default pixel + # file name already exists in the current IMDIR, a suffix is found + # for the file which results in a unique file name (there is a + # concurrency loophole in this which can cause the uniqueness + # constraint to fail, but this is unlikely). + + suffix[1] = 'a' + suffix[2] = 'a' + suffix[3] = EOS + + for (n=0; ; n=n+1) { + # Construct filename "imdir$root.pix". + call strcpy (Memc[imdir], IM_PIXFILE(im), SZ_PATHNAME) + call strcat (Memc[root], IM_PIXFILE(im), SZ_PATHNAME) + call strcat (".", IM_PIXFILE(im), SZ_PATHNAME) + call strcat (pixextn, IM_PIXFILE(im), SZ_PATHNAME) + + call imf_gpixfname (IM_PIXFILE(im), IM_HDRFILE(im), pixfile, maxch) + + # Ensure that the filename is unique. + call strpak (pixfile, Memc[fname], SZ_PATHNAME) + call zfacss (Memc[fname], 0, 0, status) + + if (status == YES) { + if (n == 0) { + for (op=root; Memc[op] != EOS; op=op+1) + ; + } else { + if (suffix[2] == 'z') { + suffix[2] = 'a' + if (suffix[1] == 'z') { + ier = IE_PFNNUNIQ + goto done_ + } else + suffix[1] = suffix[1] + 1 + } else + suffix[2] = suffix[2] + 1 + } + + call strcpy (suffix, Memc[op], 2) + } else + break + } + +done_ + # Set the error message operand name if an error occurred. + if (ier != OK) + call im_seterrop (ier, IM_HDRFILE(im)) + + call sfree (sp) +end diff --git a/sys/imfort/imfort.h b/sys/imfort/imfort.h new file mode 100644 index 00000000..0b03100f --- /dev/null +++ b/sys/imfort/imfort.h @@ -0,0 +1,65 @@ +# IMFORT.H -- IMFORT global definitions + +define MAX_NAXIS 3 # max axes in an imfort image +define LEN_USERAREA 64000 # max space for user header keywords +define SZ_KEYWORD 8 # max chars in a keyword name (FITS) +define SZ_VALSTR 80 # max chars in a keyword record (FITS) +define SZ_CMDLINE 256 # max length host command line +define MAX_ARGS 32 # max command line arguments +define SZ_DEVBLK 256 # alignment factor for pixel file +define DEF_VERSION 2 # default file version + +define ENV_OIFVER "oifversion" # default format for new images + +define RO 1 # read only +define WO 2 # write only +define RW 3 # read write +define NF 5 # new file + +define IM_HDRFP Memi[$1] # header file descriptor +define IM_PIXFP Memi[$1+1] # pixel file descriptor +define IM_ACMODE Memi[$1+2] # image access mode +define IM_UPDATE Memi[$1+3] # need to update image header on disk +define IM_LINESIZE Memi[$1+4] # image physical line length, chars +define IM_LINEBUFP Memi[$1+5] # line buffer pointer +define IM_SZPIXEL Memi[$1+6] # pixel size, chars +define IM_SWAP Memi[$1+7] # swap pixels +define IM_LENHDRMEM Memi[$1+8] # buffer length of std hdr + user area +define IM_UABLOCKED Memi[$1+9] # is user area blocked to 80 cols/card + +define IE_ACCPIX 01 # error codes +define IE_ALCPIX 02 +define IE_CLSHDR 03 +define IE_CLSPIX 04 +define IE_CREHDR 05 +define IE_IMDELETE 06 +define IE_IMDELNEXIM 07 +define IE_IMRENAME 08 +define IE_IMRNAMNEXIM 09 +define IE_EOF 10 +define IE_FLUSH 11 +define IE_GCMDLN 12 +define IE_MAGIC 13 +define IE_NEXARG 14 +define IE_NEXKW 15 +define IE_NONNUMARG 16 +define IE_NOTIMH 17 +define IE_NOTSHORT 18 +define IE_OPEN 19 +define IE_OPNPIX 20 +define IE_PIXTYPE 21 +define IE_RDPIX 22 +define IE_UPDHDR 23 +define IE_UPDRO 24 +define IE_WRHDR 25 +define IE_WRPIX 26 +define IE_XOOB 27 +define IE_YOOB 28 +define IE_ZOOB 29 +define IE_NAXIS 30 +define IE_AXLEN 31 +define IE_MKDIR 32 +define IE_PFNNUNIQ 33 +define IE_CLOBBER 34 + +define IE_EOF 99 diff --git a/sys/imfort/imfparse.x b/sys/imfort/imfparse.x new file mode 100644 index 00000000..ebcf7484 --- /dev/null +++ b/sys/imfort/imfparse.x @@ -0,0 +1,71 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "oif.h" + +# IMF_PARSE -- Parse an image name into the root pathname and filename +# extension, if any. Only the known image type extensions are recognized +# as extensions, hence this routine cannot be used to parse general filenames. + +procedure imf_parse (image, root, extn) + +char image[ARB] # input image name +char root[SZ_PATHNAME] # output root pathname +char extn[MAX_LENEXTN] # output extension + +int delim, ip, op +pointer sp, pattern, osfn +int strmatch(), strlen() +string ex HDR_EXTENSIONS + +begin + call smark (sp) + call salloc (pattern, SZ_FNAME, TY_CHAR) + call salloc (osfn, SZ_PATHNAME, TY_CHAR) + + # Parse the image name into the root and extn fields. The portion + # of the filename excluding any directory specification is also + # escape sequence encoded. + + call imf_trans (image, root, extn) + + # Search the list of legal imagefile extensions. If the extension + # given is not found in the list, tack it back onto the root and + # return a null extension. This is necessary if we are to allow + # dot delimited fields within image names without requiring the + # user to supply the image type extension. For example, "im.c" + # and "im.c.imh" must refer to the same image - ".c" is part of + # the image name, not an image type extension. + # + # Note - EX is a string of the form "|imh|hhh|...|". (iki.h). + + if (strlen(extn) == LEN_EXTN) { + delim = ex[1] + for (ip=2; ex[ip] != EOS; ip=ip+1) { + op = pattern + while (ex[ip] != delim && ex[ip+1] != EOS) { + Memc[op] = ex[ip] + op = op + 1 + ip = ip + 1 + } + Memc[op] = EOS + if (strmatch (extn, Memc[pattern]) > 0) { + call sfree (sp) + return + } + } + } + + # Not a legal image header extension. Restore the extn field to the + # root and null the extn. Tacking on the dummy extension .foo and + # later discarding it ensures that the root name is properly encoded + # for the local host. + + if (strlen(extn) > 0) { + call strcpy (image, Memc[osfn], SZ_PATHNAME) + call strcat (".foo", Memc[osfn], SZ_PATHNAME) + call imf_trans (Memc[osfn], root, extn) + extn[1] = EOS + } + + call sfree (sp) +end diff --git a/sys/imfort/imftrans.x b/sys/imfort/imftrans.x new file mode 100644 index 00000000..f758c3da --- /dev/null +++ b/sys/imfort/imftrans.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "oif.h" + +# IMF_TRANS -- Translate a host filename into root (includes directory +# prefix) and extension fields. FIO escape sequence encoding is used on +# the portion of the filename excluding the directory prefix. Legal host +# filenames are unaffected by the translation except for case conversions, +# i.e., only constructs which are not legal in host filenames are affected +# by the translation, allowing legal host filenames to be passed through +# without change. + +procedure imf_trans (fname, root, extn) + +char fname[ARB] #I input filename +char root[SZ_PATHNAME] #O root portion of filename +char extn[MAX_LENEXTN] #O extn portion of filename + +int o_root, o_extn, ip, op +int gstrcpy() + +begin + # Copy out the directory prefix, if any, unchanged. + call zfnbrk (fname, o_root, o_extn) + op = gstrcpy (fname, root, o_root-1) + 1 + ip = o_root + + # Perform escape sequence encoding and parse into root and extn. + call vfn_encode (fname, ip, root[op], o_root, extn, o_extn) +end diff --git a/sys/imfort/imfupdhdr.x b/sys/imfort/imfupdhdr.x new file mode 100644 index 00000000..4381fe7e --- /dev/null +++ b/sys/imfort/imfupdhdr.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" +include "oif.h" + +# IMF_UPDHDR -- Update the image header. + +procedure imf_updhdr (im, status) + +pointer im # image descriptor +int status # return status + +pointer fp +int imwrhdr() + +begin + fp = IM_HDRFP(im) + if (imwrhdr (fp, im, TY_IMHDR) != ERR) + IM_UPDATE(im) = NO +end diff --git a/sys/imfort/imgkwb.x b/sys/imfort/imgkwb.x new file mode 100644 index 00000000..8aad973a --- /dev/null +++ b/sys/imfort/imgkwb.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imfort.h" + +# IMGKWB -- Return the value of the named header keyword as a boolean. + +procedure imgkwb (im, keyw, bval, ier) + +pointer im # imfort image descriptor +% character*(*) keyw +bool bval +int ier + +pointer sp, kp +bool imgetb() +int errcode() + +begin + call smark (sp) + call salloc (kp, SZ_KEYWORD, TY_CHAR) + + call f77upk (keyw, Memc[kp], SZ_KEYWORD) + iferr (bval = imgetb (im, Memc[kp])) { + ier = errcode() + call im_seterrop (ier, Memc[kp]) + } else + ier = OK + + call sfree (sp) +end diff --git a/sys/imfort/imgkwc.x b/sys/imfort/imgkwc.x new file mode 100644 index 00000000..675e2488 --- /dev/null +++ b/sys/imfort/imgkwc.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imfort.h" + +# IMGKWC -- Return the value of the named header keyword as a character +# string. + +procedure imgkwc (im, keyw, sval, ier) + +pointer im # imfort image descriptor +% character*(*) keyw +% character*(*) sval +int ier + +pointer sp, kp, vp +int errcode() + +begin + call smark (sp) + call salloc (kp, SZ_KEYWORD, TY_CHAR) + call salloc (vp, SZ_VALSTR, TY_CHAR) + + call f77upk (keyw, Memc[kp], SZ_KEYWORD) + iferr (call imgstr (im, Memc[kp], Memc[vp], SZ_VALSTR)) { + ier = errcode() + call im_seterrop (ier, Memc[kp]) + } else { + call f77pak (Memc[vp], sval, ARB) + ier = OK + } + + call sfree (sp) +end diff --git a/sys/imfort/imgkwd.x b/sys/imfort/imgkwd.x new file mode 100644 index 00000000..cd3c679d --- /dev/null +++ b/sys/imfort/imgkwd.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imfort.h" + +# IMGKWD -- Return the value of the named header keyword as a double. + +procedure imgkwd (im, keyw, dval, ier) + +pointer im # imfort image descriptor +% character*(*) keyw +double dval +int ier + +pointer sp, kp +double imgetd() +int errcode() + +begin + call smark (sp) + call salloc (kp, SZ_KEYWORD, TY_CHAR) + + call f77upk (keyw, Memc[kp], SZ_KEYWORD) + iferr (dval = imgetd (im, Memc[kp])) { + ier = errcode() + call im_seterrop (ier, Memc[kp]) + } else + ier = OK + + call sfree (sp) +end diff --git a/sys/imfort/imgkwi.x b/sys/imfort/imgkwi.x new file mode 100644 index 00000000..3c30b113 --- /dev/null +++ b/sys/imfort/imgkwi.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imfort.h" + +# IMGKWI -- Return the value of the named header keyword as an integer. + +procedure imgkwi (im, keyw, ival, ier) + +pointer im # imfort image descriptor +% character*(*) keyw +int ival +int ier + +pointer sp, kp +int imgeti(), errcode() + +begin + call smark (sp) + call salloc (kp, SZ_KEYWORD, TY_CHAR) + + call f77upk (keyw, Memc[kp], SZ_KEYWORD) + iferr (ival = imgeti (im, Memc[kp])) { + ier = errcode() + call im_seterrop (ier, Memc[kp]) + } else + ier = OK + + call sfree (sp) +end diff --git a/sys/imfort/imgkwr.x b/sys/imfort/imgkwr.x new file mode 100644 index 00000000..fb330fc4 --- /dev/null +++ b/sys/imfort/imgkwr.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imfort.h" + +# IMGKWR -- Return the value of the named header keyword as a real. + +procedure imgkwr (im, keyw, rval, ier) + +pointer im # imfort image descriptor +% character*(*) keyw +real rval +int ier + +pointer sp, kp +real imgetr() +int errcode() + +begin + call smark (sp) + call salloc (kp, SZ_KEYWORD, TY_CHAR) + + call f77upk (keyw, Memc[kp], SZ_KEYWORD) + iferr (rval = imgetr (im, Memc[kp])) { + ier = errcode() + call im_seterrop (ier, Memc[kp]) + } else + ier = OK + + call sfree (sp) +end diff --git a/sys/imfort/imgl1r.x b/sys/imfort/imgl1r.x new file mode 100644 index 00000000..43541a55 --- /dev/null +++ b/sys/imfort/imgl1r.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" + +# IMGL1R -- Get a line from an image of type short or real. Automatic +# datatype conversion from short to real is performed if necessary. +# It is illegal to reference out of bounds. + +procedure imgl1r (im, buf, ier) + +pointer im # image descriptor +real buf[ARB] # user data buffer +int ier + +long offset +int nchars, npix +int bfread() + +begin + npix = IM_LEN(im,1) + nchars = npix * IM_SZPIXEL(im) + + # Compute offset into pixel file. + offset = IM_PIXOFF(im) + + # Read one line of data. + if (nchars != bfread (IM_PIXFP(im), buf, nchars, offset)) { + ier = IE_RDPIX + call im_seterrim (ier, im) + return + } + + # Swap bytes if necessary. + call imswap (im, buf, nchars) + + # Convert the datatype if necessary. + if (IM_PIXTYPE(im) == TY_SHORT) + call achtsr (buf, buf, npix) + + ier = OK +end diff --git a/sys/imfort/imgl1s.x b/sys/imfort/imgl1s.x new file mode 100644 index 00000000..6784f637 --- /dev/null +++ b/sys/imfort/imgl1s.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" + +# IMGL1S -- Get a line from an image of type short. It is illegal to reference +# out of bounds. + +procedure imgl1s (im, buf, ier) + +pointer im # image descriptor +short buf[ARB] # user data buffer +int ier + +long offset +int nchars, npix +int bfread() + +begin + # Verify that the image is of type short. + if (IM_PIXTYPE(im) != TY_SHORT) { + ier = IE_NOTSHORT + call im_seterrim (ier, im) + return + } + + npix = IM_LEN(im,1) + nchars = npix * IM_SZPIXEL(im) + + # Compute offset into pixel file. + offset = IM_PIXOFF(im) + + # Read one line of data. + if (nchars != bfread (IM_PIXFP(im), buf, nchars, offset)) { + ier = IE_RDPIX + call im_seterrim (ier, im) + return + } + + # Swap bytes if necessary. + call imswap (im, buf, nchars) + + ier = OK +end diff --git a/sys/imfort/imgl2r.x b/sys/imfort/imgl2r.x new file mode 100644 index 00000000..5756bdfe --- /dev/null +++ b/sys/imfort/imgl2r.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" + +# IMGL2R -- Get a line from an image of type short or real. Automatic +# datatype conversion from short to real is performed if necessary. +# It is illegal to reference out of bounds. + +procedure imgl2r (im, buf, lineno, ier) + +pointer im # image descriptor +real buf[ARB] # user data buffer +int lineno # line number +int ier + +long offset +int nchars, npix +int bfread() + +begin + # Verify in bounds. + if (lineno < 1 || lineno > IM_LEN(im,2)) { + ier = IE_YOOB + call im_seterrim (ier, im) + return + } + + npix = IM_LEN(im,1) + nchars = npix * IM_SZPIXEL(im) + + # Compute offset into pixel file. + offset = IM_PIXOFF(im) + (lineno-1) * IM_LINESIZE(im) + + # Read one line of data. + if (nchars != bfread (IM_PIXFP(im), buf, nchars, offset)) { + ier = IE_RDPIX + call im_seterrim (ier, im) + return + } + + # Swap bytes if necessary. + call imswap (im, buf, nchars) + + # Convert the datatype if necessary. + if (IM_PIXTYPE(im) == TY_SHORT) + call achtsr (buf, buf, npix) + + ier = OK +end diff --git a/sys/imfort/imgl2s.x b/sys/imfort/imgl2s.x new file mode 100644 index 00000000..ea8596e1 --- /dev/null +++ b/sys/imfort/imgl2s.x @@ -0,0 +1,52 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" + +# IMGL2S -- Get a line from an image of type short. It is illegal to reference +# out of bounds. + +procedure imgl2s (im, buf, lineno, ier) + +pointer im # image descriptor +short buf[ARB] # user data buffer +int lineno # line number +int ier + +long offset +int nchars, npix +int bfread() + +begin + # Verify in bounds. + if (lineno < 1 || lineno > IM_LEN(im,2)) { + ier = IE_YOOB + call im_seterrim (ier, im) + return + } + + # Verify that the image is of type short. + if (IM_PIXTYPE(im) != TY_SHORT) { + ier = IE_NOTSHORT + call im_seterrim (ier, im) + return + } + + npix = IM_LEN(im,1) + nchars = npix * IM_SZPIXEL(im) + + # Compute offset into pixel file. + offset = IM_PIXOFF(im) + (lineno-1) * IM_LINESIZE(im) + + # Read one line of data. + if (nchars != bfread (IM_PIXFP(im), buf, nchars, offset)) { + ier = IE_RDPIX + call im_seterrim (ier, im) + return + } + + # Swap bytes if necessary. + call imswap (im, buf, nchars) + + ier = OK +end diff --git a/sys/imfort/imgl3r.x b/sys/imfort/imgl3r.x new file mode 100644 index 00000000..e705df58 --- /dev/null +++ b/sys/imfort/imgl3r.x @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" + +# IMGL3R -- Get a line from an image of type short or real. Automatic +# datatype conversion from short to real is performed if necessary. +# It is illegal to reference out of bounds. + +procedure imgl3r (im, buf, lineno, bandno, ier) + +pointer im # image descriptor +real buf[ARB] # user data buffer +int lineno # line number +int bandno # band number +int ier + +long offset +int nchars, npix +int bfread() + +begin + # Verify in bounds. + if (lineno < 1 || lineno > IM_LEN(im,2)) { + ier = IE_YOOB + call im_seterrim (ier, im) + return + } else if (bandno < 1 || bandno > IM_LEN(im,3)) { + ier = IE_ZOOB + call im_seterrim (ier, im) + return + } + + npix = IM_LEN(im,1) + nchars = npix * IM_SZPIXEL(im) + + # Compute offset into pixel file. + offset = IM_PIXOFF(im) + + ((bandno-1) * IM_LEN(im,2) + (lineno-1)) * IM_LINESIZE(im) + + # Read one line of data. + if (nchars != bfread (IM_PIXFP(im), buf, nchars, offset)) { + ier = IE_RDPIX + call im_seterrim (ier, im) + return + } + + # Swap bytes if necessary. + call imswap (im, buf, nchars) + + # Convert the datatype if necessary. + if (IM_PIXTYPE(im) == TY_SHORT) + call achtsr (buf, buf, npix) + + ier = OK +end diff --git a/sys/imfort/imgl3s.x b/sys/imfort/imgl3s.x new file mode 100644 index 00000000..48134f90 --- /dev/null +++ b/sys/imfort/imgl3s.x @@ -0,0 +1,58 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" + +# IMGL3S -- Get a line from an image of type short. It is illegal to reference +# out of bounds. + +procedure imgl3s (im, buf, lineno, bandno, ier) + +pointer im # image descriptor +short buf[ARB] # user data buffer +int lineno # line number +int bandno # band number +int ier + +long offset +int nchars, npix +int bfread() + +begin + # Verify in bounds. + if (lineno < 1 || lineno > IM_LEN(im,2)) { + ier = IE_YOOB + call im_seterrim (ier, im) + return + } else if (bandno < 1 || bandno > IM_LEN(im,3)) { + ier = IE_ZOOB + call im_seterrim (ier, im) + return + } + + # Verify that the image is of type short. + if (IM_PIXTYPE(im) != TY_SHORT) { + ier = IE_NOTSHORT + call im_seterrim (ier, im) + return + } + + npix = IM_LEN(im,1) + nchars = npix * IM_SZPIXEL(im) + + # Compute offset into pixel file. + offset = IM_PIXOFF(im) + + ((bandno-1) * IM_LEN(im,2) + (lineno-1)) * IM_LINESIZE(im) + + # Read one line of data. + if (nchars != bfread (IM_PIXFP(im), buf, nchars, offset)) { + ier = IE_RDPIX + call im_seterrim (ier, im) + return + } + + # Swap bytes if necessary. + call imswap (im, buf, nchars) + + ier = OK +end diff --git a/sys/imfort/imgs1r.x b/sys/imfort/imgs1r.x new file mode 100644 index 00000000..509cf2f1 --- /dev/null +++ b/sys/imfort/imgs1r.x @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" + +# IMGS1R -- Get a section from an image of type short or real. Automatic +# datatype conversion from short to real is performed if necessary. It is +# illegal to reference out of bounds. + +procedure imgs1r (im, buf, i1, i2, ier) + +pointer im # image descriptor +real buf[ARB] # user data buffer +int i1, i2 # first, last column +int ier + +long offset +int nchars, npix +int bfread() + +begin + # Verify in bounds. + if (i1 < 1 || i2 > IM_LEN(im,1) || i1 > i2) { + ier = IE_XOOB + call im_seterrim (ier, im) + return + } else if (IM_PIXTYPE(im) != TY_SHORT && IM_PIXTYPE(im) != TY_REAL) { + ier = IE_PIXTYPE + call im_seterrim (ier, im) + return + } + + npix = i2 - i1 + 1 + nchars = npix * IM_SZPIXEL(im) + + # Compute offset into pixel file. + offset = IM_PIXOFF(im) + (i1-1) * IM_SZPIXEL(im) + + # Read data. + if (nchars != bfread (IM_PIXFP(im), buf, nchars, offset)) { + ier = IE_RDPIX + call im_seterrim (ier, im) + return + } + + # Swap bytes if necessary. + call imswap (im, buf, nchars) + + # Convert the datatype if necessary. + if (IM_PIXTYPE(im) == TY_SHORT) + call achtsr (buf, buf, npix) + + ier = OK +end diff --git a/sys/imfort/imgs1s.x b/sys/imfort/imgs1s.x new file mode 100644 index 00000000..7ad0ba31 --- /dev/null +++ b/sys/imfort/imgs1s.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" + +# IMGS1S -- Get a section from 1 dimensional image of type short. +# No automatic datatype conversion is performed. It is illegal to reference +# out of bounds. + +procedure imgs1s (im, buf, i1, i2, ier) + +pointer im # image descriptor +short buf[ARB] # user data buffer +int i1, i2 # first, last columns +int ier + +long offset +int nchars, npix +int bfread() + +begin + # Verify in bounds. + if (i1 < 1 || i2 > IM_LEN(im,1) || i1 > i2) { + ier = IE_XOOB + call im_seterrim (ier, im) + return + } else if (IM_PIXTYPE(im) != TY_SHORT) { + ier = IE_NOTSHORT + call im_seterrim (ier, im) + return + } + + npix = i2 - i1 + 1 + nchars = npix * SZ_SHORT + + # Compute offset into pixel file. + offset = IM_PIXOFF(im) + (i1-1) * SZ_SHORT + + # Read one line of data. + if (nchars != bfread (IM_PIXFP(im), buf, nchars, offset)) { + ier = IE_RDPIX + call im_seterrim (ier, im) + return + } + + # Swap bytes if necessary. + call imswap (im, buf, nchars) + + ier = OK +end diff --git a/sys/imfort/imgs2r.x b/sys/imfort/imgs2r.x new file mode 100644 index 00000000..bac775c8 --- /dev/null +++ b/sys/imfort/imgs2r.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" + +# IMGS2R -- Get a section from an image of type short or real. Automatic +# datatype conversion from short to real is performed if necessary. It is +# illegal to reference out of bounds. + +procedure imgs2r (im, buf, i1, i2, j1, j2, ier) + +pointer im # image descriptor +real buf[ARB] # user data buffer +int i1, i2 # first, last column +int j1, j2 # line number +int ier + +long offset +int nchars, npix, j, op +int bfread() + +begin + # Verify in bounds. + if (i1 < 1 || i2 > IM_LEN(im,1) || i1 > i2) { + ier = IE_XOOB + call im_seterrim (ier, im) + return + } else if (j1 < 1 || j2 > IM_LEN(im,2) || j1 > j2) { + ier = IE_YOOB + call im_seterrim (ier, im) + return + } else if (IM_PIXTYPE(im) != TY_SHORT && IM_PIXTYPE(im) != TY_REAL) { + ier = IE_PIXTYPE + call im_seterrim (ier, im) + return + } + + npix = i2 - i1 + 1 + nchars = npix * IM_SZPIXEL(im) + op = 1 + + do j = j1, j2 { + # Compute offset into pixel file. + offset = IM_PIXOFF(im) + (j-1) * IM_LINESIZE(im) + + (i1-1) * IM_SZPIXEL(im) + + # Read one line of data. + if (nchars != bfread (IM_PIXFP(im), buf[op], nchars, offset)) { + ier = IE_RDPIX + call im_seterrim (ier, im) + return + } + + # Swap bytes if necessary. + call imswap (im, buf[op], nchars) + + # Convert the datatype if necessary. + if (IM_PIXTYPE(im) == TY_SHORT) + call achtsr (buf[op], buf[op], npix) + + op = op + npix + } + + ier = OK +end diff --git a/sys/imfort/imgs2s.x b/sys/imfort/imgs2s.x new file mode 100644 index 00000000..48b421df --- /dev/null +++ b/sys/imfort/imgs2s.x @@ -0,0 +1,61 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" + +# IMGS2S -- Get a section from 2 dimensional image of type short. +# No automatic datatype conversion is performed. It is illegal to reference +# out of bounds. + +procedure imgs2s (im, buf, i1, i2, j1, j2, ier) + +pointer im # image descriptor +short buf[ARB] # user data buffer +int i1, i2 # first, last columns +int j1, j2 # first, last lines +int ier + +long offset +int nchars, npix, op, j +int bfread() + +begin + # Verify in bounds. + if (i1 < 1 || i2 > IM_LEN(im,1) || i1 > i2) { + ier = IE_XOOB + call im_seterrim (ier, im) + return + } else if (j1 < 1 || j2 > IM_LEN(im,2) || j1 > j2) { + ier = IE_YOOB + call im_seterrim (ier, im) + return + } else if (IM_PIXTYPE(im) != TY_SHORT) { + ier = IE_NOTSHORT + call im_seterrim (ier, im) + return + } + + npix = i2 - i1 + 1 + nchars = npix * SZ_SHORT + op = 1 + + do j = j1, j2 { + # Compute offset into pixel file. + offset = IM_PIXOFF(im) + + ((j-1) * IM_LINESIZE(im) + (i1-1)) * SZ_SHORT + + # Read one line of data. + if (nchars != bfread (IM_PIXFP(im), buf[op], nchars, offset)) { + ier = IE_RDPIX + call im_seterrim (ier, im) + return + } + + # Swap bytes if necessary. + call imswap (im, buf[op], nchars) + + op = op + npix + } + + ier = OK +end diff --git a/sys/imfort/imgs3r.x b/sys/imfort/imgs3r.x new file mode 100644 index 00000000..77124a48 --- /dev/null +++ b/sys/imfort/imgs3r.x @@ -0,0 +1,72 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" + +# IMGS3R -- Get a section from an image of type short or real. Automatic +# datatype conversion from short to real is performed if necessary. It is +# illegal to reference out of bounds. + +procedure imgs3r (im, buf, i1, i2, j1, j2, k1, k2, ier) + +pointer im # image descriptor +real buf[ARB] # user data buffer +int i1, i2 # first, last column +int j1, j2 # line numbers +int k1, k2 # band numbers +int ier + +long offset +int nchars, npix, j, k, op +int bfread() + +begin + # Verify in bounds. + if (i1 < 1 || i2 > IM_LEN(im,1) || i1 > i2) { + ier = IE_XOOB + call im_seterrim (ier, im) + return + } else if (j1 < 1 || j2 > IM_LEN(im,2) || j1 > j2) { + ier = IE_YOOB + call im_seterrim (ier, im) + return + } else if (k1 < 1 || k2 > IM_LEN(im,3) || k1 > k2) { + ier = IE_ZOOB + call im_seterrim (ier, im) + return + } else if (IM_PIXTYPE(im) != TY_SHORT && IM_PIXTYPE(im) != TY_REAL) { + ier = IE_PIXTYPE + call im_seterrim (ier, im) + return + } + + npix = i2 - i1 + 1 + nchars = npix * IM_SZPIXEL(im) + op = 1 + + do k = k1, k2 { + do j = j1, j2 { + # Compute offset into pixel file. + offset = IM_PIXOFF(im) + (i1-1) * IM_SZPIXEL(im) + + ((k-1) * IM_LEN(im,2) + (j-1)) * IM_LINESIZE(im) + + # Read one line of data. + if (nchars != bfread (IM_PIXFP(im), buf[op], nchars, offset)) { + ier = IE_RDPIX + call im_seterrim (ier, im) + return + } + + # Swap bytes if necessary. + call imswap (im, buf[op], nchars) + + # Convert the datatype if necessary. + if (IM_PIXTYPE(im) == TY_SHORT) + call achtsr (buf[op], buf[op], npix) + + op = op + npix + } + } + + ier = OK +end diff --git a/sys/imfort/imgs3s.x b/sys/imfort/imgs3s.x new file mode 100644 index 00000000..83c23716 --- /dev/null +++ b/sys/imfort/imgs3s.x @@ -0,0 +1,68 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" + +# IMGS3S -- Get a section from 3 dimensional image of type short. +# No automatic datatype conversion is performed. It is illegal to reference +# out of bounds. + +procedure imgs3s (im, buf, i1, i2, j1, j2, k1, k2, ier) + +pointer im # image descriptor +short buf[ARB] # user data buffer +int i1, i2 # first, last columns +int j1, j2 # first, last lines +int k1, k2 # first, last bands +int ier + +long offset +int nchars, npix, op, j, k +int bfread() + +begin + # Verify in bounds. + if (i1 < 1 || i2 > IM_LEN(im,1) || i1 > i2) { + ier = IE_XOOB + call im_seterrim (ier, im) + return + } else if (j1 < 1 || j2 > IM_LEN(im,2) || j1 > j2) { + ier = IE_YOOB + call im_seterrim (ier, im) + return + } else if (k1 < 1 || k2 > IM_LEN(im,3) || k1 > k2) { + ier = IE_ZOOB + call im_seterrim (ier, im) + return + } else if (IM_PIXTYPE(im) != TY_SHORT) { + ier = IE_NOTSHORT + call im_seterrim (ier, im) + return + } + + npix = i2 - i1 + 1 + nchars = npix * SZ_SHORT + op = 1 + + do k = k1, k2 { + do j = j1, j2 { + # Compute offset into pixel file. + offset = IM_PIXOFF(im) + (i1-1) * SZ_SHORT + + ((k-1) * IM_LEN(im,2) + (j-1)) * IM_LINESIZE(im) + + # Read one line of data. + if (nchars != bfread (IM_PIXFP(im), buf[op], nchars, offset)) { + ier = IE_RDPIX + call im_seterrim (ier, im) + return + } + + # Swap bytes if necessary. + call imswap (im, buf[op], nchars) + + op = op + npix + } + } + + ier = OK +end diff --git a/sys/imfort/imgsiz.x b/sys/imfort/imgsiz.x new file mode 100644 index 00000000..c8161286 --- /dev/null +++ b/sys/imfort/imgsiz.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" + +# IMGSIZ -- Get the physical attributes (size and type) of an image. + +procedure imgsiz (im, axlen, naxis, pixtype, ier) + +pointer im # image descriptor +int axlen[IM_MAXDIM] # receives axis lengths +int naxis # receives number of axes +int pixtype # receives pixel type +int ier # receives error status + +bool strne() + +begin + if (strne (IM_MAGIC(im), "imhdr")) + ier = IE_MAGIC + else { + call amovl (IM_LEN(im,1), axlen, IM_MAXDIM) + naxis = IM_NDIM(im) + pixtype = IM_PIXTYPE(im) + ier = OK + } +end diff --git a/sys/imfort/imhcpy.x b/sys/imfort/imhcpy.x new file mode 100644 index 00000000..27d4321c --- /dev/null +++ b/sys/imfort/imhcpy.x @@ -0,0 +1,49 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" + +# IMHCPY -- Copy the non-pixel fields of an existing image header to a new +# image header. Only fields not set by IMCREA are copied. + +procedure imhcpy (o_im, n_im, ier) + +pointer o_im # old image +pointer n_im # new image +int ier + +int junk +pointer sp, root, o_ua, n_ua +string imhdr "imhdr" +int fnroot() +bool strne() + +begin + call smark (sp) + call salloc (root, SZ_FNAME, TY_CHAR) + + if (strne (IM_MAGIC(o_im), imhdr) || strne (IM_MAGIC(n_im), imhdr)) { + ier = IE_MAGIC + call sfree (sp) + return + } + + o_ua = IM_USERAREA(o_im) + n_ua = IM_USERAREA(n_im) + + # Copy the non-pixel fields. + call strcpy (IM_TITLE(o_im), IM_TITLE(n_im), SZ_IMTITLE) + call strcpy (IM_HISTORY(o_im), IM_HISTORY(n_im), SZ_IMHIST) + call strcpy (Memc[o_ua], Memc[n_ua], ARB) + + # Record the inheritance in the history buffer. + junk = fnroot (IM_HDRFILE(o_im), Memc[root], SZ_FNAME) + call strcat ("New copy of ", IM_HISTORY(n_im), SZ_IMHIST) + call strcat (Memc[root], IM_HISTORY(n_im), SZ_IMHIST) + call strcat ("\n", IM_HISTORY(n_im), SZ_IMHIST) + + IM_UPDATE(n_im) = YES + + ier = OK + call sfree (sp) +end diff --git a/sys/imfort/imhv1.h b/sys/imfort/imhv1.h new file mode 100644 index 00000000..a9a37874 --- /dev/null +++ b/sys/imfort/imhv1.h @@ -0,0 +1,75 @@ +# IMHV1.H -- Version 1 of the OIF binary file header (April 1988). + +define V1_MAGIC "imhdr" # file identification tag +define V1_PMAGIC "impix" # file identification tag +define V1_VERSION 1 # header version number + +define SZ_V1IMPIXFILE 79 # name of pixel storage file +define SZ_V1IMHDRFILE 79 # name of header storage file +define SZ_V1IMTITLE 79 # image title string +define SZ_V1IMHIST 511 # image history record +define SZ_V1BUNIT 9 # brightness units string +define SZ_V1CTYPE 9 # coord axes units string + +# The IMIO image header structure. + +# Parameters. +define LEN_V1IMHDR 513 # length of std header +define LEN_V1PIXHDR 183 # length of pixel file header +define V1U LEN_V1IMHDR # offset to user fields +define IM_V1USERAREA (P2C($1+V1U)) # user area (database) + +# Disk resident header. +define IM_V1MAGIC Memi[$1] # contains the string "imhdr" +define IM_V1HDRLEN Memi[$1+3] # length of image header +define IM_V1PIXTYPE Memi[$1+4] # datatype of the pixels +define IM_V1NDIM Memi[$1+5] # number of dimensions +define IM_V1LEN Meml[$1+$2+6-1] # length of the dimensions +define IM_V1PHYSLEN Meml[$1+$2+13-1] # physical length (as stored) +define IM_V1SSMTYPE Meml[$1+20] # type of subscript mapping +define IM_V1LUTOFF Meml[$1+21] # offset to subscript map luts +define IM_V1PIXOFF Meml[$1+22] # offset of the pixels +define IM_V1HGMOFF Meml[$1+23] # offset of hgm pixels +define IM_V1BLIST Meml[$1+24] # offset of bad pixel list +define IM_V1SZBLIST Meml[$1+25] # size of bad pixel list +define IM_V1NBPIX Meml[$1+26] # number of bad pixels +define IM_V1CTIME Meml[$1+27] # time of image creation +define IM_V1MTIME Meml[$1+28] # time of last modify +define IM_V1LIMTIME Meml[$1+29] # time min,max computed +define IM_V1MAX Memr[P2R($1+30)] # max pixel value +define IM_V1MIN Memr[P2R($1+31)] # min pixel value +define IM_V1HGM ($1+33) # histogram descriptor +define IM_V1CTRAN ($1+52) # coordinate transformations +define IM_V1PIXFILE Memc[P2C($1+103)] # name of pixel storage file +define IM_V1HDRFILE Memc[P2C($1+143)] # name of header storage file +define IM_V1TITLE Memc[P2C($1+183)] # image name string +define IM_V1HISTORY Memc[P2C($1+223)] # history comment string + +# The Histogram structure (field IM_HGM) +define LEN_HGMSTRUCT 20 +define HGM_TIME Meml[$1] # time when hgm was computed +define HGM_LEN Meml[$1+1] # number of bins in hgm +define HGM_NPIX Meml[$1+2] # npix used to compute hgm +define HGM_MIN Memr[P2R($1+3)] # min hgm value +define HGM_MAX Memr[P2R($1+4)] # max hgm value +define HGM_INTEGRAL Memr[P2R($1+5)] # integral of hgm +define HGM_MEAN Memr[P2R($1+6)] # mean value +define HGM_VARIANCE Memr[P2R($1+7)] # variance about mean +define HGM_SKEWNESS Memr[P2R($1+8)] # skewness of hgm +define HGM_MODE Memr[P2R($1+9)] # modal value of hgm +define HGM_LCUT Memr[P2R($1+10)] # low cutoff value +define HGM_HCUT Memr[P2R($1+11)] # high cutoff value +# next available field: ($1+12) + +# The Coordinate Transformation Structure (IM_CTRAN) +define LEN_CTSTRUCT 50 +define CT_VALID Memi[$1] # (y/n) is structure valid? +define CT_BSCALE Memr[P2R($1+1)] # pixval scale factor +define CT_BZERO Memr[P2R($1+2)] # pixval offset +define CT_CRVAL Memr[P2R($1+$2+3-1)] # value at pixel +define CT_CRPIX Memr[P2R($1+$2+10-1)] # index of pixel +define CT_CDELT Memr[P2R($1+$2+17-1)] # increment along axis +define CT_CROTA Memr[P2R($1+$2+24-1)] # rotation angle +define CT_BUNIT Memc[P2C($1+31)] # pixval ("brightness") units +define CT_CTYPE Memc[P2C($1+36)] # coord units string +# next available field: ($1+41) diff --git a/sys/imfort/imhv2.h b/sys/imfort/imhv2.h new file mode 100644 index 00000000..d7eaa1f7 --- /dev/null +++ b/sys/imfort/imhv2.h @@ -0,0 +1,43 @@ +# IMHV2.H -- Version 2 of the OIF binary file header (March 1997). + +define V2_MAGIC "imhv2" # file identification tag +define V2_PMAGIC "impv2" # file identification tag +define V2_VERSION 2 # header version + +define SZ_V2IMPIXFILE 255 # name of pixel storage file +define SZ_V2IMHDRFILE 255 # name of header storage file +define SZ_V2IMTITLE 383 # image title string +define SZ_V2IMHIST 1023 # image history record + +# The IMIO image header structure. + +# Parameters. +define LEN_V2IMHDR 1024 # length of std header +define LEN_V2PIXHDR 293 # length of pixel file header +define V2U LEN_V2IMHDR # offset to user fields +define IM_V2USERAREA (P2C($1+V2U)) # user area (database) + +# Disk resident header. +define IM_V2MAGIC Memi[$1] # contains the string "imhdr" +define IM_V2HDRLEN Memi[$1+3] # length of image header +define IM_V2PIXTYPE Memi[$1+4] # datatype of the pixels +define IM_V2SWAPPED Memi[$1+5] # pixels are byte swapped +define IM_V2NDIM Memi[$1+6] # number of dimensions +define IM_V2LEN Meml[$1+$2+7-1] # length of the dimensions +define IM_V2PHYSLEN Meml[$1+$2+14-1] # physical length (as stored) +define IM_V2SSMTYPE Meml[$1+21] # type of subscript mapping +define IM_V2LUTOFF Meml[$1+22] # offset to subscript map luts +define IM_V2PIXOFF Meml[$1+23] # offset of the pixels +define IM_V2HGMOFF Meml[$1+24] # offset of hgm pixels +define IM_V2BLIST Meml[$1+25] # offset of bad pixel list +define IM_V2SZBLIST Meml[$1+26] # size of bad pixel list +define IM_V2NBPIX Meml[$1+27] # number of bad pixels +define IM_V2CTIME Meml[$1+28] # time of image creation +define IM_V2MTIME Meml[$1+29] # time of last modify +define IM_V2LIMTIME Meml[$1+30] # time min,max computed +define IM_V2MAX Memr[P2R($1+31)] # max pixel value +define IM_V2MIN Memr[P2R($1+32)] # min pixel value +define IM_V2PIXFILE Memc[P2C($1+37)] # name of pixel storage file +define IM_V2HDRFILE Memc[P2C($1+165)] # name of header storage file +define IM_V2TITLE Memc[P2C($1+293)] # image name string +define IM_V2HISTORY Memc[P2C($1+485)] # history comment string diff --git a/sys/imfort/imioff.x b/sys/imfort/imioff.x new file mode 100644 index 00000000..9ba8c57e --- /dev/null +++ b/sys/imfort/imioff.x @@ -0,0 +1,89 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "oif.h" + +# IMF_INITOFFSETS -- Initialize the physical dimensions of a new image. +# Compute and set the absolute file offsets of the major components of the +# pixel storage file. + +procedure imf_initoffsets (im, dev_block_size) + +pointer im +int dev_block_size +long offset, temp1, temp2 +int ndim, dim, sz_pixel, lblksize, pblksize, sizeof() + +begin + sz_pixel = sizeof (IM_PIXTYPE(im)) + pblksize = max (dev_block_size, SZ_VMPAGE) + lblksize = dev_block_size + + # Allow space for the pixhdr pixel storage file header. Advance + # "offset" to the next device block boundary. + + offset = LEN_PIXHDR * SZ_MII_INT + call imf_align (offset, pblksize) + + # Set the offset of the pixel storage area. Compute the physical + # dimensions of the axes of the image. If image compression is + # selected, the logical and physical lengths of the axes will be + # the same. Otherwise, the physical length of each line of the + # image will be increased to fill an integral number of device blocks. + + IM_PIXOFF(im) = offset + call amovl (IM_LEN(im,1), IM_PHYSLEN(im,1), IM_MAXDIM) + ndim = IM_NDIM(im) + + # If ndim was not explicitly set, compute it by counting the number + # of nonzero dimensions. + + if (ndim == 0) { + for (ndim=1; IM_LEN(im,ndim) > 0 && ndim <= IM_MAXDIM; + ndim=ndim+1) + ; + ndim = ndim - 1 + IM_NDIM(im) = ndim + } + + # Set the unused higher dimensions to 1. This makes is possible to + # access the image as if it were higher dimensional, and in a way it + # truely is. + + do dim = ndim + 1, IM_MAXDIM + IM_LEN(im,dim) = 1 + + temp1 = offset + IM_LEN(im,1) * sz_pixel + temp2 = temp1 + call imf_align (temp2, lblksize) + + # Only block lines if the packing density is above a certain threshold. + if (real(temp1-offset) / real(temp2-offset) >= IM_PACKDENSITY) + IM_PHYSLEN(im,1) = (temp2 - offset) / sz_pixel + + # Set the offsets of the histogram pixels and the bad pixel list. + offset = IM_PHYSLEN(im,1) + do dim = 2, ndim + offset = offset * IM_LEN(im,dim) + offset = (offset * sz_pixel) + IM_PIXOFF(im) + call imf_align (offset, lblksize) + + IM_HGMOFF(im) = offset + IM_BLIST(im) = offset +end + + +# IMF_ALIGN -- Advance "offset" to the next block boundary. + +procedure imf_align (offset, blksize) + +long offset +int blksize, diff + +begin + diff = mod (offset-1, max (1, blksize)) + if (diff != 0) + offset = offset + (blksize - diff) +end diff --git a/sys/imfort/imokwl.x b/sys/imfort/imokwl.x new file mode 100644 index 00000000..6c215892 --- /dev/null +++ b/sys/imfort/imokwl.x @@ -0,0 +1,99 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imfort.h" + +.help imgnkw +.nf -------------------------------------------------------------------------- +IMGNKW.X -- Header keyword list package. A template is used to select some +subset of the header keywords, then successive elements are read from the list +in sequence until the end of the list is reached. + + imokwl (im, template, sortflag, kwl, ier) + imgnkw (kwl, kwname, ier) + imckwl (kwl, ier) + +Standard IRAF pattern matching is used in the template: `*' matches all header +keywords, including the standard fields ("i_" prefix). +.endhelp --------------------------------------------------------------------- + +# IMOKWL -- Open the keyword list. + +procedure imokwl (im, patstr, sortit, kwl, ier) + +pointer im # imfort image descriptor +% character*(*) patstr +bool sortit # sort the list? +pointer kwl # receives list handle +int ier + +pointer sp, pp +int errcode() +pointer imofnls(), imofnlu() + +begin + call smark (sp) + call salloc (pp, SZ_LINE, TY_CHAR) + + call f77upk (patstr, Memc[pp], SZ_LINE) + iferr { + if (sortit) + kwl = imofnls (im, Memc[pp]) + else + kwl = imofnlu (im, Memc[pp]) + } then { + ier = errcode() + } else + ier = OK + + call sfree (sp) +end + + +# IMGNKW -- Return the next keyword from the list. + +procedure imgnkw (kwl, outstr, ier) + +pointer kwl # image descriptor +% character*(*) outstr +int ier + +int nchars +pointer sp, kp, ip +pointer imgnfn() +int errcode(), strncmp() + +begin + call smark (sp) + call salloc (kp, SZ_FNAME, TY_CHAR) + + iferr (nchars = imgnfn (kwl, Memc[kp], SZ_FNAME)) { + ier = errcode() + } else if (nchars == EOF) { + call f77pak ("END", outstr, len(outstr)) + ier = IE_EOF + } else { + ip = kp + if (strncmp (Memc[kp], "i_", 2) == 0) + ip = ip + 2 + call f77pak (Memc[ip], outstr, len(outstr)) + ier = OK + } + + call sfree (sp) +end + + +# IMCKWL -- Close the keyword list. + +procedure imckwl (kwl, ier) + +pointer kwl # image descriptor +int ier +int errcode() + +begin + iferr (call imcfnl (kwl)) + ier = errcode() + else + ier = OK +end diff --git a/sys/imfort/imopen.x b/sys/imfort/imopen.x new file mode 100644 index 00000000..c8ec5f8b --- /dev/null +++ b/sys/imfort/imopen.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMOPEN -- Open an existing imagefile. Fortran callable version. + +procedure imopen (f77nam, acmode, im, ier) + +% character*(*) f77nam +int acmode # image access mode (RO, WO) +pointer im # receives image descriptor pointer +int ier # receives error status + +char fname[SZ_PATHNAME] + +begin + # Unpack character string into SPP string. + call f77upk (f77nam, fname, SZ_PATHNAME) + call imopnx (fname, acmode, im, ier) +end diff --git a/sys/imfort/imopnc.x b/sys/imfort/imopnc.x new file mode 100644 index 00000000..4b5a6155 --- /dev/null +++ b/sys/imfort/imopnc.x @@ -0,0 +1,49 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" + +# IMOPNC -- Open a new copy of an existing image, with the same dimensions, +# size, pixel type, and non-pixel header fields as the original, but without +# copying any of the pixel data. The new image is left open for read-write +# access and a descriptor for the new image is returned as an argument. + +procedure imopnc (nimage, o_im, n_im, ier) + +% character*(*) nimage +pointer o_im, n_im # old, new image descriptors +int ier + +int naxis, pixtype, junk, i +int axlen[IM_MAXDIM] +define quit_ 91 + +begin + n_im = NULL + + # Get the physical parameters of the old image. + pixtype = IM_PIXTYPE(o_im) + naxis = IM_NDIM(o_im) + do i = 1, naxis + axlen[i] = IM_LEN(o_im,i) + + # Create and open the new image. + call imcrea (nimage, axlen, naxis, pixtype, ier) + if (ier != OK) + goto quit_ + call imopen (nimage, RW, n_im, ier) + if (ier != OK) + goto quit_ + + # Pass the header of the old image to the new. + call imhcpy (o_im, n_im, ier) + if (ier != OK) + goto quit_ + + return + +quit_ + # Error recovery. + if (n_im != NULL) + call imclos (n_im, junk) +end diff --git a/sys/imfort/imopnx.x b/sys/imfort/imopnx.x new file mode 100644 index 00000000..48af54b8 --- /dev/null +++ b/sys/imfort/imopnx.x @@ -0,0 +1,126 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "imfort.h" +include "oif.h" + +# IMOPNX -- Open an existing imagefile. Only host system filenames are +# permitted, image sections are not permitted, no out of bounds references, +# and so on. + +procedure imopnx (image, acmode, im, ier) + +char image[ARB] #I HOST name of image header file +int acmode #I image access mode (RO, WO) +pointer im #O receives image descriptor pointer +int ier #O receives error status + +pointer sp, pix_fp, hdr_fp +pointer pixfile, hdrfile, root, extn, envvar, valstr +int len_hdrmem, len_ua, status, ip + +pointer bfopnx() +long clktime() +int imrdhdr(), sizeof(), stridxs(), ctoi() +errchk calloc + +begin + call smark (sp) + call salloc (hdrfile, SZ_FNAME, TY_CHAR) + call salloc (pixfile, SZ_PATHNAME, TY_CHAR) + call salloc (envvar, SZ_FNAME, TY_CHAR) + call salloc (valstr, SZ_FNAME, TY_CHAR) + call salloc (root, SZ_FNAME, TY_CHAR) + call salloc (extn, SZ_FNAME, TY_CHAR) + + # Construct name of image header file. + call imf_parse (image, Memc[root], Memc[extn]) + if (Memc[extn] == EOS) + call strcpy ("imh", Memc[extn], SZ_FNAME) + + call strcpy (Memc[root], Memc[hdrfile], SZ_FNAME) + call strcat (".", Memc[hdrfile], SZ_FNAME) + call strcat (Memc[extn], Memc[hdrfile], SZ_FNAME) + + # Open image header file. + hdr_fp = bfopnx (Memc[hdrfile], acmode, RANDOM) + if (hdr_fp == ERR) { + call sfree (sp) + ier = IE_OPEN + call im_seterrop (ier, Memc[hdrfile]) + return + } + + # Determine the user area size. + len_ua = -1 + call strpak ("min_lenuserarea", Memc[envvar], SZ_FNAME) + call zgtenv (Memc[envvar], Memc[valstr], SZ_FNAME, status) + if (status > 0) { + ip = 1 + call strupk (Memc[valstr], Memc[valstr], SZ_FNAME) + if (ctoi (Memc[valstr], ip, len_ua) <= 0) + len_ua = -1 + } + if (len_ua < 0) + len_ua = LEN_USERAREA + + # Allocate image descriptor. + len_hdrmem = LEN_IMHDR + (len_ua / SZ_MII_INT) + call calloc (im, LEN_IMDES + len_hdrmem, TY_STRUCT) + + IM_ACMODE(im) = acmode + + # Read image header into descriptor. Close the file after reading in + # the header if we are opening the image read only. + + if (imrdhdr (hdr_fp, im, len_ua, TY_IMHDR) == ERR) { + call bfclos (hdr_fp, status) + call mfree (im, TY_STRUCT) + call sfree (sp) + ier = IE_NOTIMH + call im_seterrop (ier, Memc[hdrfile]) + return + } else if (acmode == RO) { + call bfclos (hdr_fp, status) + hdr_fp = NULL + } + + # Get the name of the pixel storage file from the image header, + # strip any node name prefix, and open the file. Quit if the + # file cannot be opened. + + call strcpy (Memc[hdrfile], IM_HDRFILE(im), SZ_IMHDRFILE) + call imf_gpixfname (IM_PIXFILE(im), IM_HDRFILE(im), Memc[pixfile], + SZ_PATHNAME) + ip = pixfile + stridxs ("!", Memc[pixfile]) + pix_fp = bfopnx (Memc[ip], acmode, SEQUENTIAL) + + if (pix_fp == ERR) { + call mfree (im, TY_STRUCT) + call sfree (sp) + ier = IE_OPNPIX + call im_seterrop (ier, Memc[ip]) + return + } + + # Initialize the runtime image descriptor and return. + + IM_HDRFP(im) = hdr_fp + IM_PIXFP(im) = pix_fp + IM_LINESIZE(im) = IM_PHYSLEN(im,1) * sizeof (IM_PIXTYPE(im)) + IM_SZPIXEL(im) = sizeof (IM_PIXTYPE(im)) + IM_LENHDRMEM(im) = len_hdrmem + IM_LINEBUFP(im) = NULL + IM_UABLOCKED(im) = -1 + + # If opening the image with write permission, assume that the image + # data will be modified (invalidating datamin/datamax). + + if (acmode != RO) + IM_MTIME(im) = clktime (long(0)) + + ier = OK + call sfree (sp) +end diff --git a/sys/imfort/impixf.x b/sys/imfort/impixf.x new file mode 100644 index 00000000..a1e3beab --- /dev/null +++ b/sys/imfort/impixf.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" + +# IMPIXF -- Called on an open image to return the BFIO file descriptor of the +# pixel file, and all important physical parameters describing where and how +# the pixels are stored. This information may be used to directly access the +# pixel file, in particularly demanding applications. Both the BFIO descriptor +# and the (host) pixel file name are returned, with the expectation that the +# caller will either use BFIO to directly access the pixel file, or call BFCLOS +# to close the file, and reopen it under some other i/o package. +# +# NOTE - Use of this interface implies explicit knowledge of the physical +# storage schema, hence programs which use this information may cease to work +# in the future if the image storage format changes, e.g., if an IMFORT +# interface is implemented for some storage format other than OIF. + +procedure impixf (im, pixfd, pixfil, pixoff, szline, ier) + +pointer im # image descriptor +int pixfd # receives BFIO file descriptor of pixel file +% character*(*) pixfil +int pixoff # one-indexed char offset to the pixels +int szline # nchars used to store each image line +int ier + +pointer sp, osfn, ip +int stridxs() +bool strne() + +begin + call smark (sp) + call salloc (osfn, SZ_PATHNAME, TY_CHAR) + + if (strne (IM_MAGIC(im), "imhdr")) + ier = IE_MAGIC + else { + call imf_gpixfname (IM_PIXFILE(im), IM_HDRFILE(im), Memc[osfn], + SZ_PATHNAME) + ip = osfn + stridxs ("!", Memc[osfn]) + call f77pak (Memc[ip], pixfil, len(pixfil)) + + pixfd = IM_PIXFP(im) + pixoff = IM_PIXOFF(im) + szline = IM_LINESIZE(im) + ier = OK + } + + call sfree (sp) +end diff --git a/sys/imfort/impkwb.x b/sys/imfort/impkwb.x new file mode 100644 index 00000000..c37bde01 --- /dev/null +++ b/sys/imfort/impkwb.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imfort.h" + +# IMPKWB -- Set the value of the named header keyword as a boolean. + +procedure impkwb (im, keyw, bval, ier) + +pointer im # imfort image descriptor +% character*(*) keyw +bool bval +int ier + +pointer sp, kp +int errcode() + +begin + call smark (sp) + call salloc (kp, SZ_KEYWORD, TY_CHAR) + + call f77upk (keyw, Memc[kp], SZ_KEYWORD) + iferr (call imputb (im, Memc[kp], bval)) { + ier = errcode() + call im_seterrop (ier, Memc[kp]) + } else { + ier = OK + IM_UPDATE(im) = YES + } + + call sfree (sp) +end diff --git a/sys/imfort/impkwc.x b/sys/imfort/impkwc.x new file mode 100644 index 00000000..307f2fc5 --- /dev/null +++ b/sys/imfort/impkwc.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imfort.h" + +# IMPKWC -- Set the value of the named header keyword as a character string. + +procedure impkwc (im, keyw, sval, ier) + +pointer im # imfort image descriptor +% character*(*) keyw +% character*(*) sval +int ier + +pointer sp, kp, vp +int errcode() + +begin + call smark (sp) + call salloc (kp, SZ_KEYWORD, TY_CHAR) + call salloc (vp, SZ_VALSTR, TY_CHAR) + + call f77upk (keyw, Memc[kp], SZ_KEYWORD) + call f77upk (sval, Memc[vp], SZ_VALSTR) + iferr (call impstr (im, Memc[kp], Memc[vp])) { + ier = errcode() + call im_seterrop (ier, Memc[kp]) + } else { + ier = OK + IM_UPDATE(im) = YES + } + + call sfree (sp) +end diff --git a/sys/imfort/impkwd.x b/sys/imfort/impkwd.x new file mode 100644 index 00000000..8e6694c3 --- /dev/null +++ b/sys/imfort/impkwd.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imfort.h" + +# IMPKWD -- Set the value of the named header keyword as a double. + +procedure impkwd (im, keyw, dval, ier) + +pointer im # imfort image descriptor +% character*(*) keyw +double dval +int ier + +pointer sp, kp +int errcode() + +begin + call smark (sp) + call salloc (kp, SZ_KEYWORD, TY_CHAR) + + call f77upk (keyw, Memc[kp], SZ_KEYWORD) + iferr (call imputd (im, Memc[kp], dval)) { + ier = errcode() + call im_seterrop (ier, Memc[kp]) + } else { + ier = OK + IM_UPDATE(im) = YES + } + + call sfree (sp) +end diff --git a/sys/imfort/impkwi.x b/sys/imfort/impkwi.x new file mode 100644 index 00000000..fe9ef656 --- /dev/null +++ b/sys/imfort/impkwi.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imfort.h" + +# IMPKWI -- Set the value of the named header keyword as an integer. + +procedure impkwi (im, keyw, ival, ier) + +pointer im # imfort image descriptor +% character*(*) keyw +int ival +int ier + +pointer sp, kp +int errcode() + +begin + call smark (sp) + call salloc (kp, SZ_KEYWORD, TY_CHAR) + + call f77upk (keyw, Memc[kp], SZ_KEYWORD) + iferr (call imputi (im, Memc[kp], ival)) { + ier = errcode() + call im_seterrop (ier, Memc[kp]) + } else { + ier = OK + IM_UPDATE(im) = YES + } + + call sfree (sp) +end diff --git a/sys/imfort/impkwr.x b/sys/imfort/impkwr.x new file mode 100644 index 00000000..caacb3d7 --- /dev/null +++ b/sys/imfort/impkwr.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imfort.h" + +# IMPKWR -- Set the value of the named header keyword as a real. + +procedure impkwr (im, keyw, rval, ier) + +pointer im # imfort image descriptor +% character*(*) keyw +real rval +int ier + +pointer sp, kp +int errcode() + +begin + call smark (sp) + call salloc (kp, SZ_KEYWORD, TY_CHAR) + + call f77upk (keyw, Memc[kp], SZ_KEYWORD) + iferr (call imputr (im, Memc[kp], rval)) { + ier = errcode() + call im_seterrop (ier, Memc[kp]) + } else { + ier = OK + IM_UPDATE(im) = YES + } + + call sfree (sp) +end diff --git a/sys/imfort/impl1r.x b/sys/imfort/impl1r.x new file mode 100644 index 00000000..9c742dad --- /dev/null +++ b/sys/imfort/impl1r.x @@ -0,0 +1,59 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" + +# IMPL1R -- Put a line to an image of type short or real. Automatic +# datatype conversion from real to short is performed if necessary. +# It is illegal to reference out of bounds. + +procedure impl1r (im, buf, ier) + +pointer im # image descriptor +real buf[ARB] # user data buffer +int ier + +pointer bp +long offset +int nchars, npix +int imwpix() +errchk malloc + +begin + # Need an extra line buffer for the type conversion in this case. + if (IM_PIXTYPE(im) == TY_SHORT) { + bp = IM_LINEBUFP(im) + if (bp == NULL) { + call malloc (bp, IM_LEN(im,1), TY_SHORT) + IM_LINEBUFP(im) = bp + } + } + + npix = IM_LEN(im,1) + nchars = npix * IM_SZPIXEL(im) + + # Compute offset into pixel file. + offset = IM_PIXOFF(im) + + if (IM_PIXTYPE(im) == TY_SHORT) { + # Convert the pixels before writing to the pixel file. + call achtrs (buf, Mems[bp], npix) + + # Write one line of data. + if (nchars != imwpix (im, Mems[bp], nchars, offset, 1)) { + ier = IE_WRPIX + call im_seterrim (ier, im) + return + } + + } else { + # Write one line of data. + if (nchars != imwpix (im, buf, nchars, offset, 0)) { + ier = IE_WRPIX + call im_seterrim (ier, im) + return + } + } + + ier = OK +end diff --git a/sys/imfort/impl1s.x b/sys/imfort/impl1s.x new file mode 100644 index 00000000..9faa62d4 --- /dev/null +++ b/sys/imfort/impl1s.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" + +# IMPL1S -- Put a line to a 1 dimensional image of type short. +# No automatic datatype conversion is performed. It is illegal to reference +# out of bounds. + +procedure impl1s (im, buf, ier) + +pointer im # image descriptor +short buf[ARB] # user data buffer +int ier + +long offset +int nchars, npix +int imwpix() + +begin + # Verify the image is of type short. + if (IM_PIXTYPE(im) != TY_SHORT) { + ier = IE_NOTSHORT + call im_seterrim (ier, im) + return + } + + npix = IM_LEN(im,1) + nchars = npix * SZ_SHORT + + # Compute offset into pixel file. + offset = IM_PIXOFF(im) + + # Write one line of data. + if (nchars != imwpix (im, buf, nchars, offset, 0)) { + ier = IE_WRPIX + call im_seterrim (ier, im) + return + } + + ier = OK +end diff --git a/sys/imfort/impl2r.x b/sys/imfort/impl2r.x new file mode 100644 index 00000000..a837a92a --- /dev/null +++ b/sys/imfort/impl2r.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" + +# IMPL2R -- Put a line to an image of type short or real. Automatic +# datatype conversion from real to short is performed if necessary. +# It is illegal to reference out of bounds. + +procedure impl2r (im, buf, lineno, ier) + +pointer im # image descriptor +real buf[ARB] # user data buffer +int lineno # line number +int ier + +pointer bp +long offset +int nchars, npix +int imwpix() +errchk malloc + +begin + # Verify in bounds. + if (lineno < 1 || lineno > IM_LEN(im,2)) { + ier = IE_YOOB + call im_seterrim (ier, im) + return + } + + # Need an extra line buffer for the type conversion in this case. + if (IM_PIXTYPE(im) == TY_SHORT) { + bp = IM_LINEBUFP(im) + if (bp == NULL) { + call malloc (bp, IM_LEN(im,1), TY_SHORT) + IM_LINEBUFP(im) = bp + } + } + + npix = IM_LEN(im,1) + nchars = npix * IM_SZPIXEL(im) + + # Compute offset into pixel file. + offset = IM_PIXOFF(im) + (lineno-1) * IM_LINESIZE(im) + + if (IM_PIXTYPE(im) == TY_SHORT) { + # Convert the pixels from real to short before writing to the + # pixel file. + + call achtrs (buf, Mems[bp], npix) + + # Write one line of data. + if (nchars != imwpix (im, Mems[bp], nchars, offset, 1)) { + ier = IE_WRPIX + call im_seterrim (ier, im) + return + } + + } else { + # Write one line of data. + if (nchars != imwpix (im, buf, nchars, offset, 0)) { + ier = IE_WRPIX + call im_seterrim (ier, im) + return + } + } + + ier = OK +end diff --git a/sys/imfort/impl2s.x b/sys/imfort/impl2s.x new file mode 100644 index 00000000..27f77731 --- /dev/null +++ b/sys/imfort/impl2s.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" + +# IMPL2S -- Put a line to a 2 dimensional image of type short. +# No automatic datatype conversion is performed. It is illegal to reference +# out of bounds. + +procedure impl2s (im, buf, lineno, ier) + +pointer im # image descriptor +short buf[ARB] # user data buffer +int lineno # line number +int ier + +long offset +int nchars, npix +int imwpix() + +begin + # Verify in bounds. + if (lineno < 1 || lineno > IM_LEN(im,2)) { + ier = IE_YOOB + call im_seterrim (ier, im) + return + } + + # Verify the image is of type short. + if (IM_PIXTYPE(im) != TY_SHORT) { + ier = IE_NOTSHORT + call im_seterrim (ier, im) + return + } + + npix = IM_LEN(im,1) + nchars = npix * SZ_SHORT + + # Compute offset into pixel file. + offset = IM_PIXOFF(im) + (lineno-1) * IM_LINESIZE(im) + + # Write one line of data. + if (nchars != imwpix (im, buf, nchars, offset, 0)) { + ier = IE_WRPIX + call im_seterrim (ier, im) + return + } + + ier = OK +end diff --git a/sys/imfort/impl3r.x b/sys/imfort/impl3r.x new file mode 100644 index 00000000..2ecbd67c --- /dev/null +++ b/sys/imfort/impl3r.x @@ -0,0 +1,75 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" + +# IMPL3R -- Put a line to an image of type short or real. Automatic +# datatype conversion from real to short is performed if necessary. +# It is illegal to reference out of bounds. + +procedure impl3r (im, buf, lineno, bandno, ier) + +pointer im # image descriptor +real buf[ARB] # user data buffer +int lineno # line number +int bandno # band number +int ier + +pointer bp +long offset +int nchars, npix +int imwpix() +errchk malloc + +begin + # Verify in bounds. + if (lineno < 1 || lineno > IM_LEN(im,2)) { + ier = IE_YOOB + call im_seterrim (ier, im) + return + } else if (bandno < 1 || bandno > IM_LEN(im,3)) { + ier = IE_ZOOB + call im_seterrim (ier, im) + return + } + + # Need an extra line buffer for the type conversion in this case. + if (IM_PIXTYPE(im) == TY_SHORT) { + bp = IM_LINEBUFP(im) + if (bp == NULL) { + call malloc (bp, IM_LEN(im,1), TY_SHORT) + IM_LINEBUFP(im) = bp + } + } + + npix = IM_LEN(im,1) + nchars = npix * IM_SZPIXEL(im) + + # Compute offset into pixel file. + offset = IM_PIXOFF(im) + + ((bandno-1) * IM_LEN(im,2) + (lineno-1)) * IM_LINESIZE(im) + + if (IM_PIXTYPE(im) == TY_SHORT) { + # Convert the pixels from real to short before writing to the + # pixel file. + + call achtrs (buf, Mems[bp], npix) + + # Write one line of data. + if (nchars != imwpix (im, Mems[bp], nchars, offset, 1)) { + ier = IE_WRPIX + call im_seterrim (ier, im) + return + } + + } else { + # Write one line of data. + if (nchars != imwpix (im, buf, nchars, offset, 0)) { + ier = IE_WRPIX + call im_seterrim (ier, im) + return + } + } + + ier = OK +end diff --git a/sys/imfort/impl3s.x b/sys/imfort/impl3s.x new file mode 100644 index 00000000..5f7d48c9 --- /dev/null +++ b/sys/imfort/impl3s.x @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" + +# IMPL3S -- Put a line to a 3 dimensional image of type short. +# No automatic datatype conversion is performed. It is illegal to reference +# out of bounds. + +procedure impl3s (im, buf, lineno, bandno, ier) + +pointer im # image descriptor +short buf[ARB] # user data buffer +int lineno # line number +int bandno # band number +int ier + +long offset +int nchars, npix +int imwpix() + +begin + # Verify in bounds. + if (lineno < 1 || lineno > IM_LEN(im,2)) { + ier = IE_YOOB + call im_seterrim (ier, im) + return + } else if (bandno < 1 || bandno > IM_LEN(im,3)) { + ier = IE_ZOOB + call im_seterrim (ier, im) + return + } + + # Verify the image is of type short. + if (IM_PIXTYPE(im) != TY_SHORT) { + ier = IE_NOTSHORT + call im_seterrim (ier, im) + return + } + + npix = IM_LEN(im,1) + nchars = npix * SZ_SHORT + + # Compute offset into pixel file. + offset = IM_PIXOFF(im) + + ((bandno-1) * IM_LEN(im,2) + (lineno-1)) * IM_LINESIZE(im) + + # Write one line of data. + if (nchars != imwpix (im, buf, nchars, offset, 0)) { + ier = IE_WRPIX + call im_seterrim (ier, im) + return + } + + ier = OK +end diff --git a/sys/imfort/imps1r.x b/sys/imfort/imps1r.x new file mode 100644 index 00000000..cef58a26 --- /dev/null +++ b/sys/imfort/imps1r.x @@ -0,0 +1,73 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" + +# IMPS1R -- Put a section to an image of type short or real. Automatic +# datatype conversion from real to short is performed if necessary. +# It is illegal to reference out of bounds. + +procedure imps1r (im, buf, i1, i2, ier) + +pointer im # image descriptor +real buf[ARB] # user data buffer +int i1, i2 # first, last column +int ier + +pointer bp +long offset +int nchars, npix +int imwpix() +errchk malloc + +begin + # Verify in bounds. + if (i1 < 1 || i2 > IM_LEN(im,1) || i1 > i2) { + ier = IE_XOOB + call im_seterrim (ier, im) + return + } else if (IM_PIXTYPE(im) != TY_SHORT && IM_PIXTYPE(im) != TY_REAL) { + ier = IE_PIXTYPE + call im_seterrim (ier, im) + return + } + + # Need an extra line buffer for the type conversion in this case. + if (IM_PIXTYPE(im) == TY_SHORT) { + bp = IM_LINEBUFP(im) + if (bp == NULL) { + call malloc (bp, IM_LEN(im,1), TY_SHORT) + IM_LINEBUFP(im) = bp + } + } + + npix = (i2 - i1 + 1) + nchars = npix * IM_SZPIXEL(im) + + # Compute offset into pixel file. + offset = IM_PIXOFF(im) + (i1-1) * IM_SZPIXEL(im) + + if (IM_PIXTYPE(im) == TY_SHORT) { + # Convert the pixels from real to short before writing to the + # pixel file. + + call achtrs (buf, Mems[bp], npix) + + # Write one line of data. + if (nchars != imwpix (im, Mems[bp], nchars, offset, 1)) { + ier = IE_WRPIX + call im_seterrim (ier, im) + return + } + + } else { + # Write one line of data. + if (nchars != imwpix (im, buf, nchars, offset, 0)) { + ier = IE_WRPIX + call im_seterrim (ier, im) + return + } + } + + ier = OK +end diff --git a/sys/imfort/imps1s.x b/sys/imfort/imps1s.x new file mode 100644 index 00000000..198025fb --- /dev/null +++ b/sys/imfort/imps1s.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" + +# IMPS1S -- Put a section to a 1 dimensional image of type short. +# No automatic datatype conversion is performed. It is illegal to reference +# out of bounds. + +procedure imps1s (im, buf, i1, i2, ier) + +pointer im # image descriptor +short buf[ARB] # user data buffer +int i1, i2 # first, last columns +int ier + +long offset +int nchars, npix +int imwpix() + +begin + # Verify in bounds. + if (i1 < 1 || i2 > IM_LEN(im,1) || i1 > i2) { + ier = IE_XOOB + call im_seterrim (ier, im) + return + } else if (IM_PIXTYPE(im) != TY_SHORT) { + ier = IE_NOTSHORT + call im_seterrim (ier, im) + return + } + + npix = i2 - i1 + 1 + nchars = npix * SZ_SHORT + + # Compute offset into pixel file. + offset = IM_PIXOFF(im) + (i1-1) * SZ_SHORT + + # Write one line of data. + if (nchars != imwpix (im, buf, nchars, offset, 0)) { + ier = IE_WRPIX + call im_seterrim (ier, im) + return + } + + ier = OK +end diff --git a/sys/imfort/imps2r.x b/sys/imfort/imps2r.x new file mode 100644 index 00000000..8306e701 --- /dev/null +++ b/sys/imfort/imps2r.x @@ -0,0 +1,84 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" + +# IMPS2R -- Put a section to an image of type short or real. Automatic +# datatype conversion from real to short is performed if necessary. +# It is illegal to reference out of bounds. + +procedure imps2r (im, buf, i1, i2, j1, j2, ier) + +pointer im # image descriptor +real buf[ARB] # user data buffer +int i1, i2 # first, last column +int j1, j2 # line number +int ier + +pointer bp +long offset +int nchars, npix, ip, j +int imwpix() +errchk malloc + +begin + # Verify in bounds. + if (i1 < 1 || i2 > IM_LEN(im,1) || i1 > i2) { + ier = IE_XOOB + call im_seterrim (ier, im) + return + } else if (j1 < 1 || j2 > IM_LEN(im,2) || j1 > j2) { + ier = IE_YOOB + call im_seterrim (ier, im) + return + } else if (IM_PIXTYPE(im) != TY_SHORT && IM_PIXTYPE(im) != TY_REAL) { + ier = IE_PIXTYPE + call im_seterrim (ier, im) + return + } + + # Need an extra line buffer for the type conversion in this case. + if (IM_PIXTYPE(im) == TY_SHORT) { + bp = IM_LINEBUFP(im) + if (bp == NULL) { + call malloc (bp, IM_LEN(im,1), TY_SHORT) + IM_LINEBUFP(im) = bp + } + } + + npix = (i2 - i1 + 1) + nchars = npix * IM_SZPIXEL(im) + ip = 1 + + do j = j1, j2 { + # Compute offset into pixel file. + offset = IM_PIXOFF(im) + (j-1) * IM_LINESIZE(im) + + (i1-1) * IM_SZPIXEL(im) + + if (IM_PIXTYPE(im) == TY_SHORT) { + # Convert the pixels from real to short before writing to the + # pixel file. + + call achtrs (buf[ip], Mems[bp], npix) + + # Write one line of data. + if (nchars != imwpix (im, Mems[bp], nchars, offset, 1)) { + ier = IE_WRPIX + call im_seterrim (ier, im) + return + } + + } else { + # Write one line of data. + if (nchars != imwpix (im, buf[ip], nchars, offset, 0)) { + ier = IE_WRPIX + call im_seterrim (ier, im) + return + } + } + + ip = ip + npix + } + + ier = OK +end diff --git a/sys/imfort/imps2s.x b/sys/imfort/imps2s.x new file mode 100644 index 00000000..81ee8baa --- /dev/null +++ b/sys/imfort/imps2s.x @@ -0,0 +1,58 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" + +# IMPS2S -- Put a section to a 2 dimensional image of type short. +# No automatic datatype conversion is performed. It is illegal to reference +# out of bounds. + +procedure imps2s (im, buf, i1, i2, j1, j2, ier) + +pointer im # image descriptor +short buf[ARB] # user data buffer +int i1, i2 # first, last columns +int j1, j2 # first, last lines +int ier + +long offset +int nchars, npix, ip, j +int imwpix() + +begin + # Verify in bounds. + if (i1 < 1 || i2 > IM_LEN(im,1) || i1 > i2) { + ier = IE_XOOB + call im_seterrim (ier, im) + return + } else if (j1 < 1 || j2 > IM_LEN(im,2) || j1 > j2) { + ier = IE_YOOB + call im_seterrim (ier, im) + return + } else if (IM_PIXTYPE(im) != TY_SHORT) { + ier = IE_NOTSHORT + call im_seterrim (ier, im) + return + } + + npix = i2 - i1 + 1 + nchars = npix * SZ_SHORT + ip = 1 + + do j = j1, j2 { + # Compute offset into pixel file. + offset = IM_PIXOFF(im) + + ((j-1) * IM_LINESIZE(im) + (i1-1)) * SZ_SHORT + + # Write one line of data. + if (nchars != imwpix (im, buf[ip], nchars, offset, 0)) { + ier = IE_WRPIX + call im_seterrim (ier, im) + return + } + + ip = ip + npix + } + + ier = OK +end diff --git a/sys/imfort/imps3r.x b/sys/imfort/imps3r.x new file mode 100644 index 00000000..9b099612 --- /dev/null +++ b/sys/imfort/imps3r.x @@ -0,0 +1,91 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" + +# IMPS3R -- Put a section to an image of type short or real. Automatic +# datatype conversion from real to short is performed if necessary. +# It is illegal to reference out of bounds. + +procedure imps3r (im, buf, i1, i2, j1, j2, k1, k2, ier) + +pointer im # image descriptor +real buf[ARB] # user data buffer +int i1, i2 # first, last column +int j1, j2 # line numbers +int k1, k2 # band numbers +int ier + +pointer bp +long offset +int nchars, npix, ip, j, k +int imwpix() +errchk malloc + +begin + # Verify in bounds. + if (i1 < 1 || i2 > IM_LEN(im,1) || i1 > i2) { + ier = IE_XOOB + call im_seterrim (ier, im) + return + } else if (j1 < 1 || j2 > IM_LEN(im,2) || j1 > j2) { + ier = IE_YOOB + call im_seterrim (ier, im) + return + } else if (k1 < 1 || k2 > IM_LEN(im,3) || k1 > k2) { + ier = IE_ZOOB + call im_seterrim (ier, im) + return + } else if (IM_PIXTYPE(im) != TY_SHORT && IM_PIXTYPE(im) != TY_REAL) { + ier = IE_PIXTYPE + call im_seterrim (ier, im) + return + } + + # Need an extra line buffer for the type conversion in this case. + if (IM_PIXTYPE(im) == TY_SHORT) { + bp = IM_LINEBUFP(im) + if (bp == NULL) { + call malloc (bp, IM_LEN(im,1), TY_SHORT) + IM_LINEBUFP(im) = bp + } + } + + npix = (i2 - i1 + 1) + nchars = npix * IM_SZPIXEL(im) + ip = 1 + + do k = k1, k2 { + do j = j1, j2 { + # Compute offset into pixel file. + offset = IM_PIXOFF(im) + (i1-1) * IM_SZPIXEL(im) + + ((k-1) * IM_LEN(im,2) + (j-1)) * IM_LINESIZE(im) + + if (IM_PIXTYPE(im) == TY_SHORT) { + # Convert the pixels from real to short before writing to + # the pixel file. + + call achtrs (buf[ip], Mems[bp], npix) + + # Write one line of data. + if (nchars != imwpix (im, Mems[bp], nchars, offset, 1)) { + ier = IE_WRPIX + call im_seterrim (ier, im) + return + } + + } else { + # Write one line of data. + if (nchars != imwpix (im, buf[ip], nchars, offset, 0)) { + ier = IE_WRPIX + call im_seterrim (ier, im) + return + } + } + + ip = ip + npix + } + } + + ier = OK +end diff --git a/sys/imfort/imps3s.x b/sys/imfort/imps3s.x new file mode 100644 index 00000000..74578e92 --- /dev/null +++ b/sys/imfort/imps3s.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" + +# IMPS3S -- Put a section to a 3 dimensional image of type short. +# No automatic datatype conversion is performed. It is illegal to reference +# out of bounds. + +procedure imps3s (im, buf, i1, i2, j1, j2, k1, k2, ier) + +pointer im # image descriptor +short buf[ARB] # user data buffer +int i1, i2 # first, last columns +int j1, j2 # first, last lines +int k1, k2 # first, last bands +int ier + +long offset +int nchars, npix, ip, j, k +int imwpix() + +begin + # Verify in bounds. + if (i1 < 1 || i2 > IM_LEN(im,1) || i1 > i2) { + ier = IE_XOOB + call im_seterrim (ier, im) + return + } else if (j1 < 1 || j2 > IM_LEN(im,2) || j1 > j2) { + ier = IE_YOOB + call im_seterrim (ier, im) + return + } else if (k1 < 1 || k2 > IM_LEN(im,3) || k1 > k2) { + ier = IE_ZOOB + call im_seterrim (ier, im) + return + } else if (IM_PIXTYPE(im) != TY_SHORT) { + ier = IE_NOTSHORT + call im_seterrim (ier, im) + return + } + + npix = i2 - i1 + 1 + nchars = npix * SZ_SHORT + ip = 1 + + do k = k1, k2 { + do j = j1, j2 { + # Compute offset into pixel file. + offset = IM_PIXOFF(im) + (i1-1) * SZ_SHORT + + ((k-1) * IM_LEN(im,2) + (j-1)) * IM_LINESIZE(im) + + # Write one line of data. + if (nchars != imwpix (im, buf[ip], nchars, offset, 0)) { + ier = IE_WRPIX + call im_seterrim (ier, im) + return + } + + ip = ip + npix + } + } + + ier = OK +end diff --git a/sys/imfort/imrdhdr.x b/sys/imfort/imrdhdr.x new file mode 100644 index 00000000..74597811 --- /dev/null +++ b/sys/imfort/imrdhdr.x @@ -0,0 +1,200 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "imfort.h" +include "imhv1.h" +include "imhv2.h" +include "oif.h" + + +# IMRDHDR -- Read the image header. Either the main image header or the +# pixel file header can be read. + +int procedure imrdhdr (fp, im, uchars, htype) + +pointer fp #I header file descriptor +pointer im #I image descriptor +int uchars #I maxchars of user area data to read +int htype #I TY_IMHDR or TY_PIXHDR + +pointer sp, v1 +char immagic[SZ_IMMAGIC] +int sulen_userarea, hdrlen, nchars, status + +bool streq() +int i_miirdc(), i_miirdi(), i_miirdl(), i_miirdr() +int btoi(), bfrseq(), bfseek() + +define readerr_ 91 + +begin + # Determine the file type. + if (bfseek (fp, BOFL) == ERR) + return (ERR) + if (bfrseq (fp, immagic, SZ_IMMAGIC) != SZ_IMMAGIC) + return (ERR) + + if (htype == TY_PIXHDR && streq (immagic, V1_PMAGIC)) { + # V1 Pixel file header. + return (OK) + + } else if (htype == TY_IMHDR && streq (immagic, V1_MAGIC)) { + # Old V1 image header. + + call smark (sp) + call salloc (v1, LEN_V1IMHDR, TY_STRUCT) + + if (bfseek (fp, BOFL) == ERR) { + call sfree (sp) + return (ERR) + } + nchars = LEN_V1IMHDR * SZ_MII_INT + if (bfrseq (fp, IM_V1MAGIC(v1), nchars) != nchars) { + call sfree (sp) + return (ERR) + } + + # Initialize the output image header. + call strcpy (IMH_MAGICSTR, IM_MAGIC(im), SZ_IMMAGIC) + IM_HDRVER(im) = V1_VERSION + + # The following is the length of the user area in SU. + sulen_userarea = IM_V1HDRLEN(v1) - LEN_V1IMHDR + IM_HDRLEN(im) = LEN_IMHDR + sulen_userarea + + IM_SWAP(im) = NO + IM_SWAPPED(im) = -1 + IM_PIXTYPE(im) = IM_V1PIXTYPE(v1) + + IM_NDIM(im) = IM_V1NDIM(v1) + call amovl (IM_V1LEN(v1,1), IM_LEN(im,1), IM_MAXDIM) + call amovl (IM_V1PHYSLEN(v1,1), IM_PHYSLEN(im,1), IM_MAXDIM) + + IM_SSMTYPE(im) = IM_V1SSMTYPE(v1) + IM_LUTOFF(im) = IM_V1LUTOFF(v1) + IM_PIXOFF(im) = IM_V1PIXOFF(v1) + IM_HGMOFF(im) = IM_V1HGMOFF(v1) + IM_CTIME(im) = IM_V1CTIME(v1) + IM_MTIME(im) = IM_V1MTIME(v1) + IM_LIMTIME(im) = IM_V1LIMTIME(v1) + IM_MAX(im) = IM_V1MAX(v1) + IM_MIN(im) = IM_V1MIN(v1) + + call strcpy (IM_V1PIXFILE(v1), IM_PIXFILE(im), SZ_IMPIXFILE) + call strcpy (IM_V1HDRFILE(v1), IM_HDRFILE(im), SZ_IMHDRFILE) + call strcpy (IM_V1TITLE(v1), IM_TITLE(im), SZ_IMTITLE) + call strcpy (IM_V1HISTORY(v1), IM_HISTORY(im), SZ_IMHIST) + + # Read and output the user area. + if (uchars > 0) { + nchars = min (uchars, sulen_userarea * SZ_MII_INT) + if (bfrseq (fp, Memc[IM_USERAREA(im)], nchars) <= 0) + return (ERR) + } + + call sfree (sp) + return (OK) + } + + # Check for a new format header. + if (bfseek (fp, BOFL) == ERR) + return (ERR) + if (i_miirdc (fp, immagic, SZ_IMMAGIC) < 0) + return (ERR) + + if (htype == TY_PIXHDR && streq (immagic, V2_PMAGIC)) { + # V2 Pixel file header. + return (OK) + + } else if (htype == TY_IMHDR && streq (immagic, V2_MAGIC)) { + # Newer V2 image header. + status = ERR + + # Initialize the output image header. + call strcpy (IMH_MAGICSTR, IM_MAGIC(im), SZ_IMMAGIC) + IM_HDRVER(im) = V2_VERSION + + # "sulen_userarea" is the length of the user area in SU. + if (i_miirdi (fp, hdrlen, 1) != 1) + goto readerr_ + sulen_userarea = hdrlen - LEN_V2IMHDR + IM_HDRLEN(im) = LEN_IMHDR + sulen_userarea + + if (i_miirdi (fp, IM_PIXTYPE(im), 1) != 1) + goto readerr_ + + # Determine whether to byte swap the pixels. + if (i_miirdi (fp, IM_SWAPPED(im), 1) != 1) + goto readerr_ + + IM_SWAP(im) = NO + switch (IM_PIXTYPE(im)) { + case TY_SHORT, TY_USHORT: + IM_SWAP(im) = btoi (IM_SWAPPED(im) != BYTE_SWAP2) + case TY_INT, TY_LONG: + IM_SWAP(im) = btoi (IM_SWAPPED(im) != BYTE_SWAP4) + case TY_REAL: + if (IEEE_USED == YES) + IM_SWAP(im) = btoi (IM_SWAPPED(im) != IEEE_SWAP4) + case TY_DOUBLE: + if (IEEE_USED == YES) + IM_SWAP(im) = btoi (IM_SWAPPED(im) != IEEE_SWAP8) + } + + # Read the fixed-format fields of the header. + if (i_miirdi (fp, IM_NDIM(im), 1) < 0) + goto readerr_ + if (i_miirdi (fp, IM_LEN(im,1), IM_MAXDIM) < 0) + goto readerr_ + if (i_miirdl (fp, IM_PHYSLEN(im,1), IM_MAXDIM) < 0) + goto readerr_ + if (i_miirdl (fp, IM_SSMTYPE(im), 1) < 0) + goto readerr_ + if (i_miirdl (fp, IM_LUTOFF(im), 1) < 0) + goto readerr_ + if (i_miirdl (fp, IM_PIXOFF(im), 1) < 0) + goto readerr_ + if (i_miirdl (fp, IM_HGMOFF(im), 1) < 0) + goto readerr_ + if (i_miirdl (fp, IM_BLIST(im), 1) < 0) + goto readerr_ + if (i_miirdl (fp, IM_SZBLIST(im), 1) < 0) + goto readerr_ + if (i_miirdl (fp, IM_NBPIX(im), 1) < 0) + goto readerr_ + if (i_miirdl (fp, IM_CTIME(im), 1) < 0) + goto readerr_ + if (i_miirdl (fp, IM_MTIME(im), 1) < 0) + goto readerr_ + if (i_miirdl (fp, IM_LIMTIME(im), 1) < 0) + goto readerr_ + + if (i_miirdr (fp, IM_MAX(im), 1) < 0) + goto readerr_ + if (i_miirdr (fp, IM_MIN(im), 1) < 0) + goto readerr_ + + if (i_miirdc (fp, IM_PIXFILE(im), SZ_V2IMPIXFILE) < 0) + goto readerr_ + if (i_miirdc (fp, IM_HDRFILE(im), SZ_V2IMHDRFILE) < 0) + goto readerr_ + if (i_miirdc (fp, IM_TITLE(im), SZ_V2IMTITLE) < 0) + goto readerr_ + if (i_miirdc (fp, IM_HISTORY(im), SZ_V2IMHIST) < 0) + goto readerr_ + + # Read the variable-length user area. + if (uchars > 0) { + nchars = min (uchars, sulen_userarea * SZ_MII_INT) + if (i_miirdc (fp, Memc[IM_USERAREA(im)], nchars) < 0) + goto readerr_ + } + + status = OK +readerr_ + return (status) + } + + return (ERR) +end diff --git a/sys/imfort/imrnam.x b/sys/imfort/imrnam.x new file mode 100644 index 00000000..333ff5da --- /dev/null +++ b/sys/imfort/imrnam.x @@ -0,0 +1,144 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" +include "oif.h" + +# IMRNAM -- Rename an image (both the header and pixel files). It is not an +# error if there is no pixel file. The rename operator can be used to move +# an image to a different directory. + +procedure imrnam (oimage, nimage, ier) + +% character*(*) oimage +% character*(*) nimage +int ier + +int status +pointer sp, im, ip +pointer root, extn, osfn +pointer old_hfn, new_hfn +pointer old_pfn, new_pfn +pointer o_osfn, n_osfn + +bool strne() +int stridxs() +define quit_ 91 + +begin + call smark (sp) + call salloc (root, SZ_FNAME, TY_CHAR) + call salloc (extn, SZ_FNAME, TY_CHAR) + call salloc (old_hfn, SZ_PATHNAME, TY_CHAR) + call salloc (new_hfn, SZ_PATHNAME, TY_CHAR) + call salloc (old_pfn, SZ_PATHNAME, TY_CHAR) + call salloc (new_pfn, SZ_PATHNAME, TY_CHAR) + call salloc (n_osfn, SZ_PATHNAME, TY_CHAR) + call salloc (o_osfn, SZ_PATHNAME, TY_CHAR) + call salloc (osfn, SZ_PATHNAME, TY_CHAR) + + ier = OK + + # Construct filename of new image header file. + call f77upk (nimage, Memc[new_hfn], SZ_PATHNAME) + call imf_parse (Memc[new_hfn], Memc[root], Memc[extn]) + if (Memc[extn] == EOS) + call strcpy (OIF_HDREXTN, Memc[extn], SZ_FNAME) + + call strcpy (Memc[root], Memc[new_hfn], SZ_FNAME) + call strcat (".", Memc[new_hfn], SZ_FNAME) + call strcat (Memc[extn], Memc[new_hfn], SZ_FNAME) + + # Open existing image, make sure that it exists. + call imopen (oimage, RW, im, ier) + if (ier != OK) { + ier = IE_IMRNAMNEXIM + goto quit_ + } + + # Perform clobber checking and delete any old image with the new + # name, if clobber is enabled. + + call f77upk (oimage, Memc[o_osfn], SZ_PATHNAME) + call f77upk (nimage, Memc[n_osfn], SZ_PATHNAME) + if (strne (Memc[o_osfn], Memc[n_osfn])) { + call strpak (Memc[new_hfn], Memc[osfn], SZ_PATHNAME) + call zfacss (Memc[osfn], 0, 0, status) + if (status == YES) { + call strpak ("clobber", Memc[osfn], SZ_FNAME) + call zgtenv (Memc[osfn], Memc[osfn], SZ_FNAME, status) + if (status != ERR) { + call imdele (nimage, ier) + if (ier != OK) { + ier = IE_IMRENAME + goto quit_ + } + } else { + ier = IE_CLOBBER + call f77upk (nimage, Memc[osfn], SZ_PATHNAME) + call im_seterrop (ier, Memc[osfn]) + call sfree (sp) + return + } + } + } + + # Our task here is nontrivial as the pixel file must be renamed as + # well as the header file, e.g., since renaming the header file may + # move it to a different directory, and the PIXFILE field in the + # image header may indicate that the pixel file is in the same dir + # as the header. Must open image, get pixfile name from the header, + # and generate the new pixfile name. + + call strcpy (IM_HDRFILE(im), Memc[old_hfn], SZ_PATHNAME) + + if (IM_PIXFILE(im) != EOS) { + # Get old pixel file name. + call imf_gpixfname (IM_PIXFILE(im), IM_HDRFILE(im), + Memc[old_pfn], SZ_PATHNAME) + ip = old_pfn + stridxs ("!", Memc[old_pfn]) + call strcpy (Memc[ip], Memc[old_pfn], SZ_PATHNAME) + + # Construct the new pixel file name. + call strcpy (Memc[new_hfn], IM_HDRFILE(im), SZ_PATHNAME) + call imf_mkpixfname (im, Memc[new_pfn], SZ_PATHNAME, ier) + if (ier != OK) + goto quit_ + + ip = new_pfn + stridxs ("!", Memc[new_pfn]) + call strcpy (Memc[ip], Memc[new_pfn], SZ_PATHNAME) + + # Update the image header (save new pixel file name). + IM_UPDATE(im) = YES + + } else { + call strcpy (Memc[new_hfn], IM_HDRFILE(im), SZ_PATHNAME) + Memc[old_pfn] = EOS + } + + call imclos (im, ier) + if (ier != OK) + goto quit_ + + call strpak (Memc[old_hfn], Memc[old_hfn], SZ_PATHNAME) + call strpak (Memc[old_pfn], Memc[old_pfn], SZ_PATHNAME) + call strpak (Memc[new_hfn], Memc[new_hfn], SZ_PATHNAME) + call strpak (Memc[new_pfn], Memc[new_pfn], SZ_PATHNAME) + + # Rename the header and pixel files. It is not an error if + # there is no pixel file. + + call zfrnam (Memc[old_hfn], Memc[new_hfn], status) + if (status == ERR) + ier = IE_IMRENAME + else if (Memc[old_pfn] != EOS) { + call zfrnam (Memc[old_pfn], Memc[new_pfn], status) + if (status == ERR) + ier = IE_IMRENAME + } + +quit_ + call f77upk (oimage, Memc[old_hfn], SZ_PATHNAME) + call im_seterrop (ier, Memc[old_hfn]) + call sfree (sp) +end diff --git a/sys/imfort/imswap.x b/sys/imfort/imswap.x new file mode 100644 index 00000000..9bed0ebc --- /dev/null +++ b/sys/imfort/imswap.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imfort.h" + + +# IMSWAP -- Swap bytes in pixel data if indicated for this host and image. + +procedure imswap (im, buf, nchars) + +pointer im +char buf[ARB] +int nchars + +int nbytes + +begin + if (IM_SWAP(im) == NO) + return + + nbytes = nchars * SZB_CHAR + switch (IM_SZPIXEL(im) * SZB_CHAR) { + case 2: + call bswap2 (buf, 1, buf, 1, nbytes) + case 4: + call bswap4 (buf, 1, buf, 1, nbytes) + case 8: + call bswap8 (buf, 1, buf, 1, nbytes) + } +end diff --git a/sys/imfort/imtypk.x b/sys/imfort/imtypk.x new file mode 100644 index 00000000..03c71d21 --- /dev/null +++ b/sys/imfort/imtypk.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imfort.h" + +# IMTYPK -- Get the datatype and comment string for a keyword. + +procedure imtypk (im, keyw, dtype, comm, ier) + +pointer im # image descriptor +% character*(*) keyw +int dtype # receives datatype code +% character*(*) comm +int ier + +pointer sp, kp, cp +int errcode() + +begin + call smark (sp) + call salloc (kp, SZ_KEYWORD, TY_CHAR) + call salloc (cp, SZ_VALSTR, TY_CHAR) + + call f77upk (keyw, Memc[kp], SZ_KEYWORD) + iferr (call imgatr (im, Memc[kp], dtype, Memc[cp], len(comm))) { + ier = errcode() + call im_seterrop (ier, Memc[kp]) + } else { + call f77pak (Memc[cp], comm, len(comm)) + ier = OK + } + + call sfree (sp) +end diff --git a/sys/imfort/imwpix.x b/sys/imfort/imwpix.x new file mode 100644 index 00000000..905d2c5c --- /dev/null +++ b/sys/imfort/imwpix.x @@ -0,0 +1,53 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "imfort.h" + +# IMWPIX -- Write a block of pixels to an image. This is equivalent to +# a binary file write to the pixel file (bfwrit) except that the pixels +# are swapped if necessary. + +int procedure imwpix (im, buf, nchars, offset, inplace) + +pointer im #I image descriptor +char buf[ARB] #I pixel data +int nchars #I nchars of data to be written +int offset #I file offset in pixel file +int inplace #I nonzero if ok to modify input data buffer + +pointer sp, bp +int nbytes, status +int bfwrit() + +begin + # Just write out the data if no swapping is required. + if (IM_SWAP(im) == NO) + return (bfwrit (IM_PIXFP(im), buf, nchars, offset)) + + # Swap, but use the input buffer directly. + if (inplace != 0) { + call imswap (im, buf, nchars) + return (bfwrit (IM_PIXFP(im), buf, nchars, offset)) + } + + # We need to swap into a private buffer. + call smark (sp) + call salloc (bp, nchars, TY_CHAR) + + # Swap into the output buffer. + nbytes = nchars * SZB_CHAR + switch (IM_SZPIXEL(im) * SZB_CHAR) { + case 2: + call bswap2 (buf, 1, Memc[bp], 1, nbytes) + case 4: + call bswap4 (buf, 1, Memc[bp], 1, nbytes) + case 8: + call bswap8 (buf, 1, Memc[bp], 1, nbytes) + } + + status = bfwrit (IM_PIXFP(im), Memc[bp], nchars, offset) + + call sfree (sp) + return (status) +end diff --git a/sys/imfort/imwrhdr.x b/sys/imfort/imwrhdr.x new file mode 100644 index 00000000..a9c0176f --- /dev/null +++ b/sys/imfort/imwrhdr.x @@ -0,0 +1,256 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "imfort.h" +include "imhv1.h" +include "imhv2.h" +include "oif.h" + +# IMWRHDR -- Write an OIF image header. + +int procedure imwrhdr (fp, im, htype) + +pointer fp #I header file descriptor +pointer im #I image descriptor +int htype #I TY_IMHDR or TY_PIXHDR + +pointer sp, v1, fname +int status, hdrlen, len_userarea +int bfseek(), bfwseq(), i_miiwrc(), i_miiwri(), i_miiwrl(), i_miiwrr() +int strlen() + +define v1done_ 91 +define v2start_ 92 +define v2done_ 93 + +begin + switch (IM_HDRVER(im)) { + case V1_VERSION: + # Old V1 image header. + # ---------------------- + + status = ERR + call smark (sp) + call salloc (v1, LEN_V1IMHDR, TY_STRUCT) + + # Initialize the output image header. + switch (htype) { + case TY_IMHDR: + call strcpy (V1_MAGIC, IM_V1MAGIC(v1), SZ_IMMAGIC) + hdrlen = LEN_V1IMHDR + case TY_PIXHDR: + call strcpy (V1_PMAGIC, IM_V1MAGIC(v1), SZ_IMMAGIC) + hdrlen = LEN_V1PIXHDR + default: + goto v1done_ + } + + # The following is the length of the user area in chars. + len_userarea = strlen (Memc[IM_USERAREA(im)]) + 1 + IM_V1HDRLEN(v1) = LEN_V1IMHDR + + (len_userarea + SZ_MII_INT-1) / SZ_MII_INT + + IM_V1PIXTYPE(v1) = IM_PIXTYPE(im) + IM_V1NDIM(v1) = IM_NDIM(im) + call amovl (IM_LEN(im,1), IM_V1LEN(v1,1), IM_MAXDIM) + call amovl (IM_PHYSLEN(im,1), IM_V1PHYSLEN(v1,1), IM_MAXDIM) + + IM_V1SSMTYPE(v1) = IM_SSMTYPE(im) + IM_V1LUTOFF(v1) = IM_LUTOFF(im) + IM_V1PIXOFF(v1) = IM_PIXOFF(im) + IM_V1HGMOFF(v1) = IM_HGMOFF(im) + IM_V1CTIME(v1) = IM_CTIME(im) + IM_V1MTIME(v1) = IM_MTIME(im) + IM_V1LIMTIME(v1) = IM_LIMTIME(im) + IM_V1MAX(v1) = IM_MAX(im) + IM_V1MIN(v1) = IM_MIN(im) + + if (strlen(IM_PIXFILE(im)) > SZ_V1IMPIXFILE) + goto v1done_ + if (strlen(IM_HDRFILE(im)) > SZ_V1IMHDRFILE) + goto v1done_ + + call strcpy (IM_PIXFILE(im), IM_V1PIXFILE(v1), SZ_V1IMPIXFILE) + call strcpy (IM_HDRFILE(im), IM_V1HDRFILE(v1), SZ_V1IMHDRFILE) + call strcpy (IM_TITLE(im), IM_V1TITLE(v1), SZ_V1IMTITLE) + call strcpy (IM_HISTORY(im), IM_V1HISTORY(v1), SZ_V1IMHIST) + + # For historical reasons the pixel file header stores the host + # pathname of the header file in the PIXFILE field of the pixel + # file header. + + if (htype == TY_PIXHDR) + call fpathname (IM_HDRFILE(im), IM_V1PIXFILE(v1), + SZ_V1IMPIXFILE) + + # Write the file header. + if (bfseek (fp, BOFL) == ERR) + goto v1done_ + if (bfwseq (fp, IM_V1MAGIC(v1), hdrlen * SZ_MII_INT) == ERR) + goto v1done_ + + # Write the user area. + if (htype == TY_IMHDR) + if (bfwseq (fp, Memc[IM_USERAREA(im)], len_userarea) == ERR) + goto v1done_ + + status = OK +v1done_ + call sfree (sp) + + case V2_VERSION: + # Newer V2 image header. + # ---------------------- +v2start_ + status = ERR + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + if (bfseek (fp, BOFL) == ERR) + goto v2done_ + + # Initialize the output image header. + switch (htype) { + case TY_IMHDR: + if (i_miiwrc (fp, V2_MAGIC, SZ_IMMAGIC) == ERR) + goto v2done_ + hdrlen = LEN_V2IMHDR + case TY_PIXHDR: + if (i_miiwrc (fp, V2_PMAGIC, SZ_IMMAGIC) == ERR) + goto v2done_ + hdrlen = LEN_V2PIXHDR + default: + goto v2done_ + } + + # The following is the length of the user area in SU. + len_userarea = strlen (Memc[IM_USERAREA(im)]) + 1 + hdrlen = LEN_V2IMHDR + (len_userarea + SZ_MII_INT-1) / SZ_MII_INT + + if (i_miiwri (fp, hdrlen, 1) == ERR) + goto v2done_ + if (i_miiwri (fp, IM_PIXTYPE(im), 1) == ERR) + goto v2done_ + + # Record the byte swapping used for this image. When writing a + # new image we use the native data type of the host and don't + # swap bytes, so IM_SWAPPED is YES if the host architecture is + # byte swapped. + + switch (IM_ACMODE(im)) { + case NEW_IMAGE, NEW_COPY, TEMP_FILE: + IM_SWAPPED(im) = -1 + switch (IM_PIXTYPE(im)) { + case TY_SHORT, TY_USHORT: + IM_SWAPPED(im) = BYTE_SWAP2 + case TY_INT, TY_LONG: + IM_SWAPPED(im) = BYTE_SWAP4 + case TY_REAL: + if (IEEE_USED == YES) + IM_SWAPPED(im) = IEEE_SWAP4 + case TY_DOUBLE: + if (IEEE_USED == YES) + IM_SWAPPED(im) = IEEE_SWAP8 + } + default: + # IM_SWAPPED should already be set in header. + } + + if (i_miiwri (fp, IM_SWAPPED(im), 1) == ERR) + goto v2done_ + if (i_miiwri (fp, IM_NDIM(im), 1) == ERR) + goto v2done_ + if (i_miiwrl (fp, IM_LEN(im,1), IM_MAXDIM) == ERR) + goto v2done_ + if (i_miiwrl (fp, IM_PHYSLEN(im,1), IM_MAXDIM) == ERR) + goto v2done_ + if (i_miiwrl (fp, IM_SSMTYPE(im), 1) == ERR) + goto v2done_ + if (i_miiwrl (fp, IM_LUTOFF(im), 1) == ERR) + goto v2done_ + if (i_miiwrl (fp, IM_PIXOFF(im), 1) == ERR) + goto v2done_ + if (i_miiwrl (fp, IM_HGMOFF(im), 1) == ERR) + goto v2done_ + if (i_miiwrl (fp, IM_BLIST(im), 1) == ERR) + goto v2done_ + if (i_miiwrl (fp, IM_SZBLIST(im), 1) == ERR) + goto v2done_ + if (i_miiwrl (fp, IM_NBPIX(im), 1) == ERR) + goto v2done_ + if (i_miiwrl (fp, IM_CTIME(im), 1) == ERR) + goto v2done_ + if (i_miiwrl (fp, IM_MTIME(im), 1) == ERR) + goto v2done_ + if (i_miiwrl (fp, IM_LIMTIME(im), 1) == ERR) + goto v2done_ + if (i_miiwrr (fp, IM_MAX(im), 1) == ERR) + goto v2done_ + if (i_miiwrr (fp, IM_MIN(im), 1) == ERR) + goto v2done_ + + if (strlen(IM_PIXFILE(im)) > SZ_V2IMPIXFILE) + goto v2done_ + if (strlen(IM_HDRFILE(im)) > SZ_V2IMHDRFILE) + goto v2done_ + + # For historical reasons the pixel file header stores the host + # pathname of the header file in the PIXFILE field of the pixel + # file header. + + if (htype == TY_PIXHDR) { + call aclrc (Memc[fname], SZ_PATHNAME) + call fpathname (IM_HDRFILE(im), Memc[fname], SZ_PATHNAME) + if (i_miiwrc (fp, Memc[fname], SZ_V2IMPIXFILE) == ERR) + goto v2done_ + status = OK + goto v2done_ + } else if (i_miiwrc (fp, IM_PIXFILE(im), SZ_V2IMPIXFILE) == ERR) + goto v2done_ + + call oif_trim (IM_HDRFILE(im), SZ_V2IMHDRFILE) + if (i_miiwrc (fp, IM_HDRFILE(im), SZ_V2IMHDRFILE) == ERR) + goto v2done_ + + call oif_trim (IM_TITLE(im), SZ_V2IMTITLE) + if (i_miiwrc (fp, IM_TITLE(im), SZ_V2IMTITLE) == ERR) + goto v2done_ + + call oif_trim (IM_HISTORY(im), SZ_V2IMHIST) + if (i_miiwrc (fp, IM_HISTORY(im), SZ_V2IMHIST) == ERR) + goto v2done_ + + # Write the variable-length user area. + if (i_miiwrc (fp, Memc[IM_USERAREA(im)], len_userarea) == ERR) + goto v2done_ + + status = OK +v2done_ + call sfree (sp) + + default: + IM_HDRVER(im) = V2_VERSION + goto v2start_ + } + + return (status) +end + + +# OIF_TRIM -- Trim trailing garbage at the end of a string. This does not +# affect the value of the string, but makes the contents of the output file +# clearer when examined with file utilities. + +procedure oif_trim (s, nchars) + +char s[ARB] +int nchars + +int n +int strlen() + +begin + n = strlen(s) + 1 + call aclrc (s[n], nchars - n) +end diff --git a/sys/imfort/mii.x b/sys/imfort/mii.x new file mode 100644 index 00000000..4934a08e --- /dev/null +++ b/sys/imfort/mii.x @@ -0,0 +1,314 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + + +# MII.X -- This is a stand-alone port of the miiread/miiwrite routines from +# etc/osb, modified for IMFORT to use bfio. +# +# status = i_miirdi (fp, spp, maxelem) +# status = i_miirdl (fp, spp, maxelem) +# status = i_miirdr (fp, spp, maxelem) +# +# status = i_miiwri (fp, spp, nelem) +# status = i_miiwrl (fp, spp, nelem) +# status = i_miiwrr (fp, spp, nelem) +# +# status = i_miirdc (fp, spp, maxchars) +# status = i_miiwrc (fp, spp, nchars) + + +# MIIRDI -- Read a block of data stored externally in MII integer format. +# Data is returned in the format of the local host machine. + +int procedure i_miirdi (fp, spp, maxelem) + +pointer fp #I input file +int spp[ARB] #O receives data +int maxelem #I max number of data elements to be read + +pointer sp, bp +int pksize, nchars, nelem +int miipksize(), miinelem(), bfrseq() + +begin + pksize = miipksize (maxelem, MII_INT) + nelem = EOF + + if (pksize > maxelem * SZ_INT) { + # Read data into local buffer and unpack into user buffer. + + call smark (sp) + call salloc (bp, pksize, TY_CHAR) + + nchars = bfrseq (fp, Memc[bp], pksize) + if (nchars != EOF) { + nelem = min (maxelem, miinelem (nchars, MII_INT)) + call miiupki (Memc[bp], spp, nelem, TY_INT) + } + + call sfree (sp) + + } else { + # Read data into user buffer and unpack in place. + + nchars = bfrseq (fp, spp, pksize) + if (nchars != EOF) { + nelem = min (maxelem, miinelem (nchars, MII_INT)) + call miiupki (spp, spp, nelem, TY_INT) + } + } + + return (nelem) +end + + +# MIIRDL -- Read a block of data stored externally in MII long integer format. +# Data is returned in the format of the local host machine. + +int procedure i_miirdl (fp, spp, maxelem) + +pointer fp #I input file +long spp[ARB] #O receives data +int maxelem #I max number of data elements to be read + +pointer sp, bp +int pksize, nchars, nelem +int miipksize(), miinelem(), bfrseq() + +begin + pksize = miipksize (maxelem, MII_LONG) + nelem = EOF + + if (pksize > maxelem * SZ_LONG) { + # Read data into local buffer and unpack into user buffer. + + call smark (sp) + call salloc (bp, pksize, TY_CHAR) + + nchars = bfrseq (fp, Memc[bp], pksize) + if (nchars != EOF) { + nelem = min (maxelem, miinelem (nchars, MII_LONG)) + call miiupkl (Memc[bp], spp, nelem, TY_LONG) + } + + call sfree (sp) + + } else { + # Read data into user buffer and unpack in place. + + nchars = bfrseq (fp, spp, pksize) + if (nchars != EOF) { + nelem = min (maxelem, miinelem (nchars, MII_LONG)) + call miiupkl (spp, spp, nelem, TY_LONG) + } + } + + return (nelem) +end + + +# MIIRDR -- Read a block of data stored externally in MII real format. +# Data is returned in the format of the local host machine. + +int procedure i_miirdr (fp, spp, maxelem) + +pointer fp #I input file +real spp[ARB] #O receives data +int maxelem # max number of data elements to be read + +pointer sp, bp +int pksize, nchars, nelem +int miipksize(), miinelem(), bfrseq() + +begin + pksize = miipksize (maxelem, MII_REAL) + nelem = EOF + + if (pksize > maxelem * SZ_REAL) { + # Read data into local buffer and unpack into user buffer. + + call smark (sp) + call salloc (bp, pksize, TY_CHAR) + + nchars = bfrseq (fp, Memc[bp], pksize) + if (nchars != EOF) { + nelem = min (maxelem, miinelem (nchars, MII_REAL)) + call miiupkr (Memc[bp], spp, nelem, TY_REAL) + } + + call sfree (sp) + + } else { + # Read data into user buffer and unpack in place. + + nchars = bfrseq (fp, spp, pksize) + if (nchars != EOF) { + nelem = min (maxelem, miinelem (nchars, MII_REAL)) + call miiupkr (spp, spp, nelem, TY_REAL) + } + } + + return (nelem) +end + + +# MIIWRI -- Write a block of data to a file in MII integer format. +# The input data is in the host system native binary format. + +int procedure i_miiwri (fp, spp, nelem) + +pointer fp #I output file +int spp[ARB] #I native format data to be written +int nelem #I number of data elements to be written + +pointer sp, bp +int bufsize, status +int miipksize(), bfwseq() + +begin + status = OK + call smark (sp) + + bufsize = miipksize (nelem, MII_INT) + call salloc (bp, bufsize, TY_CHAR) + + call miipaki (spp, Memc[bp], nelem, TY_INT) + if (bfwseq (fp, Memc[bp], bufsize) == ERR) + status = ERR + + call sfree (sp) + return (status) +end + + +# MIIWRL -- Write a block of data to a file in MII long integer format. +# The input data is in the host system native binary format. + +int procedure i_miiwrl (fp, spp, nelem) + +pointer fp #I output file +long spp[ARB] #I native format data to be written +int nelem #I number of data elements to be written + +pointer sp, bp +int bufsize, status +int miipksize(), bfwseq() + +begin + status = OK + call smark (sp) + + bufsize = miipksize (nelem, MII_LONG) + call salloc (bp, bufsize, TY_CHAR) + + call miipakl (spp, Memc[bp], nelem, TY_LONG) + if (bfwseq (fp, Memc[bp], bufsize) == ERR) + status = ERR + + call sfree (sp) + return (status) +end + + +# MIIWRR -- Write a block of data to a file in MII real format. +# The input data is in the host system native binary format. + +int procedure i_miiwrr (fp, spp, nelem) + +pointer fp #I output file +real spp[ARB] #I native format data to be written +int nelem #I number of data elements to be written + +pointer sp, bp +int bufsize, status +int miipksize(), bfwseq() + +begin + status = OK + call smark (sp) + + bufsize = miipksize (nelem, MII_REAL) + call salloc (bp, bufsize, TY_CHAR) + + call miipakr (spp, Memc[bp], nelem, TY_REAL) + if (bfwseq (fp, Memc[bp], bufsize) == ERR) + status = ERR + + call sfree (sp) + return (status) +end + + +# MIIRDC -- Read a block of character data stored externally in MII format. +# Data is returned in the machine independent character format. + +int procedure i_miirdc (fp, spp, maxchars) + +pointer fp #I input file +char spp[ARB] #O receives data +int maxchars #I max number of chars to be read + +pointer sp, bp +int pksize, nchars +int miipksize(), miinelem(), bfrseq() + +begin + pksize = miipksize (maxchars, MII_BYTE) + nchars = max (maxchars, pksize) + + if (nchars > maxchars) { + # Read data into local buffer and unpack into user buffer. + + call smark (sp) + call salloc (bp, nchars, TY_CHAR) + + nchars = bfrseq (fp, Memc[bp], pksize) + if (nchars != EOF) { + nchars = min (maxchars, miinelem (nchars, MII_BYTE)) + call miiupk8 (Memc[bp], spp, nchars, TY_CHAR) + } + + call sfree (sp) + + } else { + # Read data into user buffer and unpack in place. + + nchars = bfrseq (fp, spp, pksize) + if (nchars != EOF) { + nchars = min (maxchars, miinelem (nchars, MII_BYTE)) + call miiupk8 (spp, spp, nchars, TY_CHAR) + } + } + + return (nchars) +end + + +# MIIWRC -- Write a block of character data to a file in MII format. +# The input data is assumed to be in a machine independent format. + +int procedure i_miiwrc (fp, spp, nchars) + +pointer fp #I output file +char spp[ARB] #I data to be written +int nchars #I number of chars units to be written + +pointer sp, bp +int bufsize, status +int miipksize(), bfwseq() + +begin + status = OK + call smark (sp) + + bufsize = miipksize (nchars, MII_BYTE) + call salloc (bp, bufsize, TY_CHAR) + + call miipak8 (spp, Memc[bp], nchars, TY_CHAR) + if (bfwseq (fp, Memc[bp], bufsize) == ERR) + status = ERR + + call sfree (sp) + return (status) +end diff --git a/sys/imfort/mkpkg b/sys/imfort/mkpkg new file mode 100644 index 00000000..3eb70a52 --- /dev/null +++ b/sys/imfort/mkpkg @@ -0,0 +1,85 @@ +# Make the IMFORT library. + +$checkout libimfort.a lib$ +$update libimfort.a +$checkin libimfort.a lib$ +$exit + +libimfort.a: + #$set XFLAGS = "$XFLAGS -/DBLD_KERNEL" + $set XFLAGS = "$(XFLAGS) -/DBLD_KERNEL" + @db + + bfio.x imfort.h + clargs.x imfort.h + imacck.x imfort.h + imaddk.x imfort.h + imakwb.x imfort.h + imakwc.x imfort.h + imakwd.x imfort.h + imakwi.x imfort.h + imakwr.x imfort.h + imclos.x imfort.h + imcrea.x + imcrex.x imfort.h oif.h + imdele.x + imdelk.x imfort.h + imdelx.x imfort.h + imemsg.x imfort.h + imfdir.x oif.h + imfgpfn.x oif.h + imflsh.x imfort.h + imfmkpfn.x imfort.h oif.h + imfparse.x oif.h + imftrans.x oif.h + imfupdhdr.x imfort.h oif.h + imgkwb.x imfort.h + imgkwc.x imfort.h + imgkwd.x imfort.h + imgkwi.x imfort.h + imgkwr.x imfort.h + imgl1r.x imfort.h + imgl1s.x imfort.h + imgl2r.x imfort.h + imgl2s.x imfort.h + imgl3r.x imfort.h + imgl3s.x imfort.h + imgs1r.x imfort.h + imgs1s.x imfort.h + imgs2r.x imfort.h + imgs2s.x imfort.h + imgs3r.x imfort.h + imgs3s.x imfort.h + imgsiz.x imfort.h + imhcpy.x imfort.h + imioff.x oif.h + imokwl.x imfort.h + imopen.x + imopnc.x imfort.h + imopnx.x imfort.h oif.h + impixf.x imfort.h + impkwb.x imfort.h + impkwc.x imfort.h + impkwd.x imfort.h + impkwi.x imfort.h + impkwr.x imfort.h + impl1r.x imfort.h + impl1s.x imfort.h + impl2r.x imfort.h + impl2s.x imfort.h + impl3r.x imfort.h + impl3s.x imfort.h + imps1r.x imfort.h + imps1s.x imfort.h + imps2r.x imfort.h + imps2s.x imfort.h + imps3r.x imfort.h + imps3s.x imfort.h + imrdhdr.x imfort.h imhv1.h imhv2.h oif.h + imrnam.x imfort.h oif.h + imswap.x imfort.h + imtypk.x imfort.h + imwpix.x imfort.h + imwrhdr.x imfort.h imhv1.h imhv2.h oif.h + mii.x + ; diff --git a/sys/imfort/oif.h b/sys/imfort/oif.h new file mode 100644 index 00000000..43345e09 --- /dev/null +++ b/sys/imfort/oif.h @@ -0,0 +1,16 @@ +# OIF.H -- IKI/OIF internal definitions. + +define MAX_LENEXTN 3 # max length imagefile extension +define LEN_EXTN 3 # actual length imagefile extension +define OIF_HDREXTN "imh" # imheader filename extension +define OIF_PIXEXTN "pix" # pixel file extension +define LEN_PIXHDR 512 # length of PIXHDR structure +define COMPRESS NO # disable alignment of image lines? +define DEF_VERSION 2 # default file version +define HDR_EXTENSIONS "|^imh|" # legal header file extensions + +define HDR "HDR$" # stands for header directory +define STRLEN_HDR 4 + +define TY_IMHDR 1 # main imagefile header +define TY_PIXHDR 2 # pixel file header diff --git a/sys/imfort/tasks/README b/sys/imfort/tasks/README new file mode 100644 index 00000000..9eb3e075 --- /dev/null +++ b/sys/imfort/tasks/README @@ -0,0 +1,20 @@ +IMIO$IMFORT/ZZDEBUG - + + This directory contains a set of Fortran programs used to test the IMFORT +software, and to provide real working examples illustrating the use of the +IMFORT interface in host Fortran programs. + + hello.f prints `hello, world!' + imcopy.f copy an image + imdel.f delete an image + imren.f rename an image + keyw.f test header keyword access + minmax.f update datamin, datamax + mkim.f make a test image, pix[i,j] = j * 100 + i + pcube.f print a subraster, e.g., of a MKIM test image + phead.f print an image header in FITS format + planck.f compute the planck function + readim.f test sequential read through an image + +To compile individual programs: cl> fc prog.f +To define the tasks to the CL: cl> cl < tasks.cl (edit tasks.cl first) diff --git a/sys/imfort/tasks/args.f b/sys/imfort/tasks/args.f new file mode 100644 index 00000000..b484c4cd --- /dev/null +++ b/sys/imfort/tasks/args.f @@ -0,0 +1,33 @@ +c ARGS -- Test the command line argument interface. +c +c usage: args [arg1 [arg2 ...]] +c ------------------------------------------------------------------------ + + program args + + character*80 argstr + integer nargs, ier, i + +c --- Test raw command line access. + call clrawc (argstr, ier) + if (ier .ne. 0) then + write (*, '('' clrawc returns status '', i3)') ier + else + write (*, '('' clrawc: '', a80)') argstr + endif + +c --- Test parsed command line access. + call clnarg (nargs) + write (*, '('' nargs = '', i3)') nargs + + do 10 i = 1, nargs + call clargc (i, argstr, ier) + if (ier .ne. 0) then + write (*, '('' unexpected error '', i3)') ier + else + write (*, '(i4, 2x, a70)') i, argstr + endif + 10 continue + + stop + end diff --git a/sys/imfort/tasks/hello.f b/sys/imfort/tasks/hello.f new file mode 100644 index 00000000..f1649f31 --- /dev/null +++ b/sys/imfort/tasks/hello.f @@ -0,0 +1,6 @@ +c HELLO -- Sample Fortran program to demonstate compile/link. + + program hello + write (*,*) 'hello, world!' + stop + end diff --git a/sys/imfort/tasks/imcopy.f b/sys/imfort/tasks/imcopy.f new file mode 100644 index 00000000..c81f5f05 --- /dev/null +++ b/sys/imfort/tasks/imcopy.f @@ -0,0 +1,81 @@ +c IMCOPY -- Copy an image of up to 2048 pixels per line. Works for images of +c up to three dimensions with a pixel type of either short or real. +c +c usage: imcopy oldimage newimage +c ---------------------------------------------------------------------------- + + program imcopy + + real rpix(2048) + integer*2 spix(4096) + equivalence (rpix, spix) + character*80 oimage, nimage, errmsg + integer ncols, nlines, nbands, j, k, oim, nim + integer ier, axlen(7), naxis, pixtype, nargs + +c --- Get command line arguments. + call clnarg (nargs) + if (nargs .eq. 2) then + call clargc (1, oimage, ier) + if (ier .ne. 0) goto 91 + call clargc (2, nimage, ier) + if (ier .ne. 0) goto 91 + else + write (*, '('' input image: '',$)') + read (*,*) oimage + write (*, '('' output image: '',$)') + read (*,*) nimage + endif + +c --- Open the input image. + call imopen (oimage, 1, oim, ier) + if (ier .ne. 0) goto 91 + +c --- Create a new output image with the same header and size as the +c input image. + + call imopnc (nimage, oim, nim, ier) + if (ier .ne. 0) goto 91 + +c --- Determine the size and pixel type of the image being copied. + call imgsiz (oim, axlen, naxis, pixtype, ier) + if (ier .ne. 0) goto 91 + ncols = axlen(1) + nlines = axlen(2) + nbands = axlen(3) + +c --- Copy the image. + if (pixtype .eq. 3) then + do 15 k = 1, nbands + do 10 j = 1, nlines + call imgl3s (oim, spix, j, k, ier) + if (ier .ne. 0) goto 91 + call impl3s (nim, spix, j, k, ier) + if (ier .ne. 0) goto 91 + 10 continue + 15 continue + else + do 25 k = 1, nbands + do 20 j = 1, nlines + call imgl3r (oim, rpix, j, k, ier) + if (ier .ne. 0) goto 91 + call impl3r (nim, rpix, j, k, ier) + if (ier .ne. 0) goto 91 + 20 continue + 25 continue + endif + +c --- Clean up. + call imclos (oim, ier) + if (ier .ne. 0) goto 91 + call imclos (nim, ier) + if (ier .ne. 0) goto 91 + + stop + +c -- Error actions. + 91 call imemsg (ier, errmsg) + write (*, '('' Error: '', a80)') errmsg + + stop + end diff --git a/sys/imfort/tasks/imdel.f b/sys/imfort/tasks/imdel.f new file mode 100644 index 00000000..d7b65ab9 --- /dev/null +++ b/sys/imfort/tasks/imdel.f @@ -0,0 +1,29 @@ +c IMDEL -- Delete an image. +c +c usage: imdel imagename +c ---------------------------------------------------------------------- + + program imdel + + integer ier + character*80 image, errmsg + +c --- Get the name of the image to be deleted. + call clargc (1, image, ier) + if (ier .ne. 0) then + write (*, '('' enter image name: '',$)') + read (*,*) image + endif + +c --- Delete the image. + call imdele (image, ier) + if (ier .ne. 0) goto 91 + + stop + +c --- Error exit. + 91 call imemsg (ier, errmsg) + write (*, '('' Error: '', a80)') errmsg + + stop + end diff --git a/sys/imfort/tasks/imren.f b/sys/imfort/tasks/imren.f new file mode 100644 index 00000000..ea70a1e4 --- /dev/null +++ b/sys/imfort/tasks/imren.f @@ -0,0 +1,36 @@ +c IMREN -- Rename an image. +c +c usage: imren oldname newname +c ---------------------------------------------------------------------- + + program imren + + integer nargs, ier + character*80 oname, nname, errmsg + +c --- Get the old and new names of the image to be renamed. + call clnarg (nargs) + if (nargs .ge. 2) then + call clargc (1, oname, ier) + if (ier .ne. 0) goto 91 + call clargc (2, nname, ier) + if (ier .ne. 0) goto 91 + else + write (*, '('' enter old image name: '',$)') + read (*,*) oname + write (*, '('' enter new image name: '',$)') + read (*,*) nname + endif + +c --- Rename the image. + call imrnam (oname, nname, ier) + if (ier .ne. 0) goto 91 + + stop + +c --- Error exit. + 91 call imemsg (ier, errmsg) + write (*, '('' Error: '', a80)') errmsg + + stop + end diff --git a/sys/imfort/tasks/keyw.f b/sys/imfort/tasks/keyw.f new file mode 100644 index 00000000..ee235f51 --- /dev/null +++ b/sys/imfort/tasks/keyw.f @@ -0,0 +1,116 @@ +c KEYW -- Test the image header get/put interface routines. +c +c usage: keyw imagename +c ---------------------------------------------------------------------------- + + program keyw + + character*80 image, errmsg + character*8 keywrd, option + character*80 valstr, commnt + integer ncols, nlines, dtype + integer im, ier, axlen(7), naxis + +c --- Get image name. + call clargc (1, image, ier) + if (ier .ne. 0) then + write (*, '('' enter image name: '',$)') + read (*,*) image + endif + +c --- Open the image. + call imopen (image, 3, im, ier) + if (ier .ne. 0) goto 91 + call imgsiz (im, axlen, naxis, dtype, ier) + if (ier .ne. 0) goto 91 + + ncols = axlen(1) + nlines = axlen(2) + +c --- Interpreter loop. + 10 continue + write (*, '('' enter command (quit,gkw[cir],pkw[cir],addk,delk): '',$)') + read (*,*) option + + if (option .eq. 'pkwc') then + write (*, '('' keyword name: '',$)') + read (*,*) keywrd + write (*, '('' value: '',$)') + read (*,*) valstr + call impkwc (im, keywrd, valstr, ier) + if (ier .ne. 0) goto 91 + goto 10 + + else if (option .eq. 'pkwi') then + write (*, '('' keyword name: '',$)') + read (*,*) keywrd + write (*, '('' value: '',$)') + read (*,*) ival + call impkwi (im, keywrd, ival, ier) + if (ier .ne. 0) goto 91 + goto 10 + + else if (option .eq. 'pkwr') then + write (*, '('' keyword name: '',$)') + read (*,*) keywrd + write (*, '('' value: '',$)') + read (*,*) rval + call impkwr (im, keywrd, rval, ier) + if (ier .ne. 0) goto 91 + goto 10 + + else if (option .eq. 'gkwc') then + write (*, '('' keyword name: '',$)') + read (*,*) keywrd + call imgkwc (im, keywrd, valstr, ier) + if (ier .ne. 0) goto 91 + write (*,*) 'value ', valstr + goto 10 + + else if (option .eq. 'gkwi') then + write (*, '('' keyword name: '',$)') + read (*,*) keywrd + call imgkwi (im, keywrd, ival, ier) + if (ier .ne. 0) goto 91 + write (*,*) 'value ', ival + goto 10 + + else if (option .eq. 'gkwr') then + write (*, '('' keyword name: '',$)') + read (*,*) keywrd + call imgkwr (im, keywrd, rval, ier) + if (ier .ne. 0) goto 91 + write (*,*) 'value ', rval + goto 10 + + else if (option .eq. 'addk') then + write (*, '('' keyword name: '',$)') + read (*,*) keywrd + write (*, '('' keyword datatype: '',$)') + read (*,*) dtype + write (*, '('' comment field: '',$)') + read (*,*) commnt + call imaddk (im, keywrd, dtype, commnt, ier) + if (ier .ne. 0) goto 91 + write (*,*) 'value ', rval + goto 10 + + else if (option .eq. 'delk') then + write (*, '('' keyword name: '',$)') + read (*,*) keywrd + call imdelk (im, keywrd, ier) + if (ier .ne. 0) goto 91 + goto 10 + + endif + +c --- Clean up. + call imclos (im, ier) + if (ier .ne. 0) goto 91 + + stop + 91 call imemsg (ier, errmsg) + write (*, '('' Error: '', a80)') errmsg + + stop + end diff --git a/sys/imfort/tasks/minmax.f b/sys/imfort/tasks/minmax.f new file mode 100644 index 00000000..34edaea5 --- /dev/null +++ b/sys/imfort/tasks/minmax.f @@ -0,0 +1,56 @@ +c MINMAX -- Compute the minimum and maximum pixel values in an image. +c The new values are printed as well as updated in the image header. +c +c usage: minmax image +c ---------------------------------------------------------------------- + + program minmax + + character*80 image, errmsg + real pix(8192), dmin, dmax, vmin, vmax + integer im, axlen(7), naxis, dtype, ier, j + +c --- Get image name. + call clargc (1, image, ier) + if (ier .ne. 0) then + write (*, '('' enter image name: '',$)') + read (*,*) image + endif + +c --- Open the image for readwrite access (we need to update the header). + call imopen (image, 3, im, ier) + if (ier .ne. 0) goto 91 + call imgsiz (im, axlen, naxis, dtype, ier) + if (ier .ne. 0) goto 91 + +c --- Read through the image and compute the limiting pixel values. + do 10 j = 1, axlen(2) + call imgl2r (im, pix, j, ier) + if (ier .ne. 0) goto 91 + call alimr (pix, axlen(1), vmin, vmax) + if (j .eq. 1) then + dmin = vmin + dmax = vmax + else + dmin = min (dmin, vmin) + dmax = max (dmax, vmax) + endif + 10 continue + +c --- Update the image header. + call impkwr (im, 'datamin', dmin, ier) + if (ier .ne. 0) goto 91 + call impkwr (im, 'datamax', dmax, ier) + if (ier .ne. 0) goto 91 + +c --- Clean up. + call imclos (im, ier) + if (ier .ne. 0) goto 91 + write (*, '(1x, a20, 2 g12.5)') image, dmin, dmax + stop + +c --- Error exit. + 91 call imemsg (ier, errmsg) + write (*, '('' Error: '', a80)') errmsg + stop + end diff --git a/sys/imfort/tasks/mkim.f b/sys/imfort/tasks/mkim.f new file mode 100644 index 00000000..7aec2b24 --- /dev/null +++ b/sys/imfort/tasks/mkim.f @@ -0,0 +1,75 @@ +c MKIM -- Make a two dimensional test image of type short or real. The pixel +c values go 1, 2, 3, etc. in storage order. +c +c usage: mkim image ncols nlines [dtype] [pixdir] +c +c The data type defaults to type short if not specified on the command line. +c ---------------------------------------------------------------------------- + + program mkim + + character*80 image, errmsg, pixdir + integer im, ier, axlen(7), naxis, dtype + integer nlines, ncols, i, j + real pix(8192) + +c --- Get image name. + call clargc (1, image, ier) + if (ier .ne. 0) then + write (*, '('' enter image name: '',$)') + read (*,*) image + endif + +c --- Get image size. + call clargi (2, ncols, ier) + if (ier .ne. 0) then + write (*, '('' ncols: '',$)') + read (*,*) ncols + endif + call clargi (3, nlines, ier) + if (ier .ne. 0) then + write (*, '('' nlines: '',$)') + read (*,*) nlines + endif + +c --- Get pixel datatype (optional). + call clargi (4, dtype, ier) + if (ier .ne. 0) dtype = 3 + +c --- Get pixel directory (optional). + call clargc (5, pixdir, ier) + if (ier .eq. 0) then + call imsdir (pixdir) + endif + + axlen(1) = ncols + axlen(2) = nlines + naxis = 2 + +c --- Create the image. + call imcrea (image, axlen, naxis, dtype, ier) + if (ier .ne. 0) goto 91 + +c --- Open the image for writing, and write the data. + call imopen (image, 3, im, ier) + if (ier .ne. 0) goto 91 + + do 20 j = 1, nlines + do 10 i = 1, ncols + pix(i) = (j-1) * ncols + i + 10 continue + call impl2r (im, pix, j, ier) + if (ier .ne. 0) goto 91 + 20 continue + +c --- Close the image and quit. + call imclos (im, ier) + if (ier .ne. 0) goto 91 + + stop + +c --- Error exit. + 91 call imemsg (ier, errmsg) + write (*, '('' Error: '', a80)') errmsg + stop + end diff --git a/sys/imfort/tasks/pcube.f b/sys/imfort/tasks/pcube.f new file mode 100644 index 00000000..89dd3651 --- /dev/null +++ b/sys/imfort/tasks/pcube.f @@ -0,0 +1,108 @@ +c PCUBE -- Extract a subraster (image cube) from an image and print +c the values on the standard output. This is used with a standard +c test image to verify that the IMFORT interface is working correctly. +c +c usage: pcube image i1 i2 [j1 j2 [k1 k2]] +c --------------------------------------------------------------------- + + program pcube + + character*80 image, errmsg + integer i1, i2, j1, j2, k1, k2 + integer im, ier, axlen(7), naxis, dtype, nargs + real pix(8192) + +c --- Get image name. + call clargc (1, image, ier) + if (ier .ne. 0) then + write (*, '('' enter image name: '',$)') + read (*,*) image + endif + +c --- Open the image. + call imopen (image, 1, im, ier) + if (ier .ne. 0) goto 91 + call imgsiz (im, axlen, naxis, dtype, ier) + if (ier .ne. 0) goto 91 + +c --- Get subraster coordinates. + call clnarg (nargs) + if (nargs .lt. 3) then + write (*, '('' enter subraster coordinates (i1 i2 j1 j2): '',$)') + read (*,*) i1, i2, j1, j2 + k1 = 1 + k2 = 1 + else + call clargi (2, i1, ier) + if (ier .ne. 0) goto 91 + call clargi (3, i2, ier) + if (ier .ne. 0) goto 91 + + if (nargs .ge. 5) then + call clargi (4, j1, ier) + if (ier .ne. 0) goto 91 + call clargi (5, j2, ier) + if (ier .ne. 0) goto 91 + else + j1 = 1 + j2 = 1 + endif + + if (nargs .ge. 7) then + call clargi (6, k1, ier) + if (ier .ne. 0) goto 91 + call clargi (7, k2, ier) + if (ier .ne. 0) goto 91 + else + k1 = 1 + k2 = 1 + endif + endif + +c --- Extract the subraster. + call imgs3r (im, pix, i1, i2, j1, j2, k1, k2, ier) + if (ier .ne. 0) goto 91 + +c --- Print the pixel values. + call pcuber (pix, i2-i1+1, j2-j1+1, k2-k1+1, i1,i2, j1,j2, k1,k2) + +c --- Close the input image and quit. + call imclos (im, ier) + if (ier .ne. 0) goto 91 + + stop + +c --- Error handler. + 91 call imemsg (ier, errmsg) + write (*, '('' Error: '', a80)') errmsg + stop + end + + +c PCUBER -- Print pixel values, 3d subraster, type real. +c ---------------------------------------------------------------- + + subroutine pcuber (pix, nx,ny,nz, i1,i2, j1,j2, k1,k2) + + integer nx, ny, nz + real pix(nx,ny,nz) + integer i1, i2, j1, j2, k1, k2 + integer i, j, k + + nx = i2 - i1 + 1 + ny = j2 - j1 + 1 + nz = k2 - k1 + 1 + + do 20 k = k1, k2 + write (*, '('' band '', i3)') k + + print 81, i1, i2, j1, j2 + do 10 j = 1, ny + print 82, j-1+j1, (pix(i,j,k), i = 1, nx) + 10 continue + 20 continue + + 81 format (' subraster at ', 4 i4) + 82 format (' line ', i4, 8 (1x, f7.0)) + + end diff --git a/sys/imfort/tasks/phead.f b/sys/imfort/tasks/phead.f new file mode 100644 index 00000000..4a54b584 --- /dev/null +++ b/sys/imfort/tasks/phead.f @@ -0,0 +1,155 @@ +c PHEAD -- Print the header of the named image in FITS format, one keyword +c per line. A pattern may optionally be specified to list some subset of the +c header keywords. +c +c usage: phead image [pattern] +c ---------------------------------------------------------------------------- + + program phead + + character*20 kwname + character*80 image, patstr, errmsg + integer im, kwl, ier + logical sortit + +c --- Get image name. + call clargc (1, image, ier) + if (ier .ne. 0) then + write (*, '('' enter image name: '',$)') + read (*,*) image + endif + +c --- Get pattern string (list everything if no pattern given). + call clargc (2, patstr, ier) + if (ier .ne. 0) then + patstr = '*' + endif + +c --- Open the image. + call imopen (image, 1, im, ier) + if (ier .ne. 0) goto 91 + +c --- Open the keyword list and print each keyword in FITS format on the +c standard output device. + + sortit = .false. + call imokwl (im, patstr, sortit, kwl, ier) + + 10 continue + call imgnkw (kwl, kwname, ier) + if (ier .ne. 0) goto 20 + call putkey (im, kwname, ier) + if (ier .ne. 0) goto 91 + goto 10 + 20 continue + + call imckwl (kwl, ier) + if (ier .ne. 0) goto 91 + +c --- Clean up. + call imclos (im, ier) + if (ier .ne. 0) goto 91 + + stop + +c --- Error exit. + 91 call imemsg (ier, errmsg) + write (*, '(1x, '' Error: '', a80)') errmsg + + stop + end + + +c PUTKEY -- Read the value and comment fields of the named image header +c keyword, and print the value of the keyword in FITS format on the +c standard output device. +c +c 000000000111111111122222222223333333333444444444455555555556 +c 123456789012345678901234567890123456789012345678901234567890 +c keyword = xxx / comment +c keyword = 'sval ' / comment +c +c Datatype codes: 1=bool, 2=char, 3,4,5=int, 6,7=real/double, 8=complex +c Only codes 1, 2, 4, and 6 (bool,char,int,real) are returned by IMTYPK. +c ------------------------------------------------------------------------ + + subroutine putkey (im, kwname, ier) + + integer im + character*(*) kwname + + logical bval + character*68 sval + integer ival + doubleprecision dval + + character*18 valstr + character*47 comstr + character*70 lngstr + integer nchars, dtype, ier, i + +c --- Get the keyword data type and comment information. + call imtypk (im, kwname, dtype, comstr, ier) + if (ier .ne. 0) return + +c --- Print the value of the keyword in FITS format. The format depends +c upon the datatype of the parameter. + + if (dtype .eq. 1) then + call imgkwb (im, kwname, bval, ier) + if (ier .ne. 0) return + write (*, 10) kwname, bval, comstr + 10 format (1x, a8, '= ', l20, ' / ', a47) + + else if (dtype .ge. 3 .and. dtype .le. 5) then + call imgkwi (im, kwname, ival, ier) + if (ier .ne. 0) return + write (*, 20) kwname, ival, comstr + 20 format (1x, a8, '= ', i20, ' / ', a47) + + else if (dtype .eq. 6 .or. dtype .eq. 7) then + call imgkwd (im, kwname, dval, ier) + if (ier .ne. 0) return + if (abs(dval) .lt. 1.0E6 .and. abs(dval) .ge. 1.0E-1) then + write (*, 30) kwname, dval, comstr + 30 format (1x, a8, '= ', f20.2, ' / ', a47) + else + write (*, 31) kwname, dval, comstr + 31 format (1x, a8, '= ', e20.12, ' / ', a47) + endif + + else + call imgkwc (im, kwname, sval, ier) + if (ier .ne. 0) return + + nchars = len(sval) - 1 + do 40 i = nchars, 9, -1 + if (sval(i:i) .ne. ' ') goto 41 + nchars = i - 1 + 40 continue + 41 continue + + if (nchars .le. 8) then + write (*, 45) kwname, sval, comstr + 45 format (1x, a8, '= ''', a8, '''', 10x, ' / ', a47) + else if (nchars .le. 18) then + valstr = sval + write (*, 46) kwname, valstr, comstr + 46 format (1x, a8, '= ''', a18, '''', ' / ', a47) + else + nchars = min (nchars, len(lngstr) - 2) + lngstr(1:1) = '''' + do 47 i = 1, nchars + lngstr(i+1:i+1) = sval(i:i) + 47 continue + lngstr(nchars+2:nchars+2) = '''' + do 48 i = nchars + 3, len(lngstr) + lngstr(i:i) = ' ' + 48 continue + write (*, 49) kwname, lngstr + 49 format (1x, a8, '= ', a69) + endif + endif + + ier = 0 + end diff --git a/sys/imfort/tasks/planck.f b/sys/imfort/tasks/planck.f new file mode 100644 index 00000000..520183c0 --- /dev/null +++ b/sys/imfort/tasks/planck.f @@ -0,0 +1,59 @@ +c PLANCK -- Compute the Planck blackbody radiation distribution for a +c given temperature and wavelength region. +c +c usage: planck temperature lambda1 lambda2 +c +c The temperature is specified in degrees Kelvin and the wavelength +c region in microns (1u=10000A). 100 [x,y] data points defining the +c curve are output. +c ---------------------------------------------------------------------- + + program planck + + character*80 errmsg + integer nargs, ier, i + real w1, w2, dw, cm, t + real xv(100), yv(100) + +c --- Get the temperature in degrees kelvin. + call clargr (1, t, ier) + if (ier .ne. 0) then + write (*, '('' temperature (degrees kelvin): '',$)') + read (*,*) t + endif + +c --- Get the wavelength region to be computed. + call clnarg (nargs) + if (nargs .ge. 3) then + call clargr (2, w1, ier) + if (ier .ne. 0) goto 91 + call clargr (3, w2, ier) + if (ier .ne. 0) goto 91 + else + write (*, '('' start wavelength (microns): '',$)') + read (*,*) w1 + write (*, '('' end wavelength (microns): '',$)') + read (*,*) w2 + endif + +c --- Compute the blackbody curve. + dw = (w2 - w1) / 99.0 + do 10 i = 1, 100 + xv(i) = ((i-1) * dw) + w1 + cm = xv(i) * 1.0E-4 + yv(i) = (3.74185E-5 * (cm ** -5)) / + * (2.71828 ** (1.43883 / (cm * t)) - 1.0) + 10 continue + +c --- Print the curve as a table. + do 20 i = 1, 100 + write (*, '(1x, f7.4, g12.4)') xv(i), yv(i) + 20 continue + + stop + +c --- Error exit. + 91 call imemsg (ier, errmsg) + write (*, '('' Error: '', a80)') errmsg + stop + end diff --git a/sys/imfort/tasks/readim.f b/sys/imfort/tasks/readim.f new file mode 100644 index 00000000..466da0e0 --- /dev/null +++ b/sys/imfort/tasks/readim.f @@ -0,0 +1,53 @@ +c READIM -- Read through an image and count the lines (used for timing tests). +c Tests line sequential i/o. +c +c usage: readim image +c ---------------------------------------------------------------------------- + + program readim + + character*80 image, errmsg + integer ncols, nlines, nbands, j, k + integer im, ier, axlen(7), naxis, dtype + integer*2 pix(8192) + +c --- Get image name. + call clargc (1, image, ier) + if (ier .ne. 0) then + write (*, '('' enter image name: '',$)') + read (*,*) image + endif + +c --- Open the image. + call imopen (image, 1, im, ier) + if (ier .ne. 0) goto 91 + call imgsiz (im, axlen, naxis, dtype, ier) + if (ier .ne. 0) goto 91 + + ncols = axlen(1) + nlines = axlen(2) + nbands = axlen(3) + +c --- Read through the image. + do 20 k = 1, nbands + do 10 j = 1, nlines + call imgl3s (im, pix, j, k, ier) + if (ier .ne. 0) goto 91 + 10 continue + 20 continue + +c --- Clean up. + call imclos (im, ier) + if (ier .ne. 0) goto 91 + + print 81, nlines, image + 81 format (' read ', i4, ' lines from image ', a64) + + stop + +c --- Error exit. + 91 call imemsg (ier, errmsg) + write (*, '('' Error: '', a80)') errmsg + + stop + end diff --git a/sys/imfort/tasks/tasks.unix b/sys/imfort/tasks/tasks.unix new file mode 100644 index 00000000..13aa52fb --- /dev/null +++ b/sys/imfort/tasks/tasks.unix @@ -0,0 +1,18 @@ +# Declare the IMFORT test/demo tasks as CL foreign tasks [MACHDEP]. +# Usage: uncomment the appropriate declarations, and type `cl < tasks.cl'. +# NOTE - requires that "iraf" be defined in the host environment. + +task $args = "$${iraf}sys/imfort/tasks/args.e $1 $2 $3 $4 $5" +task $hello = "$${iraf}sys/imfort/tasks/hello.e" +task $imcopy = "$${iraf}sys/imfort/tasks/imcopy.e $(*)" +task $imdel = "$${iraf}sys/imfort/tasks/imdel.e $(*)" +task $imren = "$${iraf}sys/imfort/tasks/imren.e $(*)" +task $keyw = "$${iraf}sys/imfort/tasks/keyw.e" +task $minmax = "$${iraf}sys/imfort/tasks/minmax.e $(*)" +task $mkim = "$${iraf}sys/imfort/tasks/mkim.e $(1) $2 $3 $4 $(5)" +task $pcube = "$${iraf}sys/imfort/tasks/pcube.e $(1) $2 $3 $4 $5 $6 $7" +task $phead = "$${iraf}sys/imfort/tasks/phead.e $(1) $2" +task $planck = "$${iraf}sys/imfort/tasks/planck.e" +task $readim = "$${iraf}sys/imfort/tasks/readim.e $(*)" + +keep diff --git a/sys/imfort/tasks/tasks.vms b/sys/imfort/tasks/tasks.vms new file mode 100644 index 00000000..2be943f4 --- /dev/null +++ b/sys/imfort/tasks/tasks.vms @@ -0,0 +1,17 @@ +# Declare the IMFORT test/demo tasks as CL foreign tasks [MACHDEP]. +# Usage: uncomment the appropriate declarations, and type `cl < tasks.cl'. + +task $args = "$args:==\$irafdisk:[iraf.sys.imfort.tasks]args.exe!args $1 $2 $3 $4 $5" +task $hello = "$hello:==\$irafdisk:[iraf.sys.imfort.tasks]hello.exe!hello" +task $imcopy = "$imcopy:==\$irafdisk:[iraf.sys.imfort.tasks]imcopy.exe!imcopy $(*)" +task $imdel = "$imdel:==\$irafdisk:[iraf.sys.imfort.tasks]imdel.exe!imdel $(*)" +task $imren = "$imren:==\$irafdisk:[iraf.sys.imfort.tasks]imren.exe!imren $(*)" +task $keyw = "$keyw:==\$irafdisk:[iraf.sys.imfort.tasks]keyw.exe!keyw" +task $minmax = "$minmax:==\$irafdisk:[iraf.sys.imfort.tasks]minmax.exe!minmax $(*)" +task $mkim = "$mkim:==\$irafdisk:[iraf.sys.imfort.tasks]mkim.exe!mkim $(*) $2 $3 $4" +task $pcube = "$pcube:==\$irafdisk:[iraf.sys.imfort.tasks]pcube.exe!pcube $(*) $2 $3 $4 $5 $6 $7" +task $phead = "$phead:==\$irafdisk:[iraf.sys.imfort.tasks]phead.exe!phead $(1) $2" +task $planck = "$planck:==\$irafdisk:[iraf.sys.imfort.tasks]planck.exe!planck" +task $readim = "$readim:==\$irafdisk:[iraf.sys.imfort.tasks]readim.exe!readim $(*)" + +keep diff --git a/sys/imio/README b/sys/imio/README new file mode 100644 index 00000000..2e7228bf --- /dev/null +++ b/sys/imio/README @@ -0,0 +1,210 @@ +Image i/o. Coded May 1983, D. Tody. + +This initial implementation of IMIO, described in the ".hlp" design file, +provides most of the functionality of the IMIO interface, but is not +fully optimized internally. Features include: + + (1) 7 disk datatypes (ushort, silrdx). + (2) 6 in-core datatypes (the standard silrdx). + (3) Images of up to 7 dimensions are supported internally, though + only images of up to 3 dimensions are currently supported in the + interface. + (4) Fully automatic multidimensional buffer allocation, resizing, + and deallocation. + (5) Arbitrary number of input buffers, allocated in a round robin + fashion, need not be the same size or dimension. + (5) Fully automatic type conversion. + (6) General image sections, coordinate flip, and subsampling. + (7) Both "compressed" and "block aligned" storage modes are + supported, with IMIO automatically selecting the optimal + choice during image creation. The device blocksize is a + runtime variable. + + +Planned future improvements: + + (1) Boundary extension. + (3) Optimization to the get/put line procedures to work directly + out of the FIO buffers when possible. + (3) Addition of the get/put pixel procedures. + (4) The image header is currently a simple binary file (structure). + Only one image header structure per header file is permitted. + Will be modified to use database facilities, and to permit + embedded image headers. + (5) Support for the unsigned byte disk datatype. + + +FV NOTES: I've made the following bug fixes: + +In imioff: + The setting of IM_PHYSDIM was taken outside the loop called when + IM_NDIM was zero. There is was no way to set IM_PHYSDIM in the programmer + interface. + +In imhdr.h: + The offset to the user area IMU was changed from 603 to 613. This was + a typo? + +In impnln: + The coerce statement is wrong since imgobf calls coerce to the + appropriate data type. + +In impnln: + There was a typo which did not set ve. + +------------------------ + +Review image interface. Device namining convention, use of explicit +pathnames. File read/write permissions required. Why didn't imdopen +work. + +Remove imdmap.x from system library, put in libim.a. + + +Nov 84 + Optimized line at a time i/o. Added capability to reference directly +into the FIO buffer. This greatly improved the efficiency of simple image +operations (no section, type conversion, etc.), without reducing the generality +of the interface. + + +--------------------------------------------------------------------------- +IMIO Modifications, April 1985 + + +1. Boundary Extension + + types: constant, nearest, reflect, wrap + parameters: nbndrypix, tybndry, bndrypixval + + +2. Database Access + + New fields may be added to an image with IMADD. The value of an existing +field is set with one of the IMPUT procedures; automatic type conversion will +be performed if necessary and permissible. The value of an existing field is +fetched with an IMGET procedure. The image database interface is both forward +and backward compatible, i.e., no changes are required to current programs and +the same interface (ignoring minor semantic details) will be available when +image headers are moved into DBIO. + + +Functions + + get,g - get the value of a field + put,p - set the value of a field + add,a - add a new field to a database + acc - determine if the named field exists + del - delete a field + gftype - get field datatype + gfn - get field name (matching a template) + + +Procedures + + value = imget[bcsilrdx] (im, "field") + imgstr (im, "field", outstr, maxch) + imput[bcsilrdx] (im, "field", value) + impstr (im, "field", value) + imadd[bcsilrdx] (im, "field", def_value) + imastr (im, "field", def_value) + imaddf (im, "field", "datatype") + y/n = imaccf (im, "field") + imdelf (im, "field") + type = imgftype (im, "field") + + list = imofnl[us] (im, template) + nchars/EOF = imgnfn (list, outstr, maxch) + imcfnl (list) + + +The database interface may be used to access any field of the image header, +including the following standard fields. Note that the nomenclature has +been changed slightly to make it more consistent with FITS. Additional +standard fields will be defined in the future. + + + keyword type description + + i_naxis i number of axes (dimensionality) + i_naxis[1-7] l length of an axis ("i_naxis1", etc.) + i_pixtype i pixel datatype (SPP integer code) + i_minpixval r minimum pixel value + i_maxpixval r maximum pixel value + i_ctime l time of image creation + i_mtime l time of last modify + i_limtime l time when limits (minmax) were last updated + i_title s title string + + +The following additional field names are recognized, but may disappear in the +future: + + i_history s history record (a string buffer at present) + i_pixfile s pathname of the pixel storage file + + +The names of the standard fields share an "i_" prefix to reduce the possibility +of collisions with data dependent keywords, to identify the standard fields in +sorted listings, to allow use of pattern matching to discriminate between the +standard fields and user fields, and so on. The use of the "i_" prefix is +made optional for the convenience of the interactive user, but the full name +should always be used in compiled programs. + + +3. Subfile Management (not implemented) + + A subfile B of file A is a file which is logically subordinate to A but +which is physically a separate file to the host operating system. A subfile +need not reside in the same directory as the main file. + +FIO shall provide support for subfiles as an abstract datatype. For each +ordinary file there shall optionally be zero or one subfile index files with +the same root name as the main file but with the extension .zsf. The index +file, if present, shall list the subfiles of the main file. The operations +supported by FIO for subfiles shall include the following: + + + add a subfile to index and return pathname + delete a subfile from index and return pathname + get the pathname of a subfile + delete both index entry and physical file + delete a file and all subfiles + + +It is important that FIO maintain the mapping of a subfile name to a physical +file name to permit moves, copies, renames, etc. of files and their subfiles. +Having to open the index file to get the pathname of a subfile is however +inefficient. To achieve both flexibility and efficiency the system packages +IMIO and DBIO will cache the names of subfiles to eliminate most accesses to +the index files. + + + add a subfile: + add subfile to the index + cache pathname + + open subfile: + repeat { + open subfile using cached pathname + if (file cannot be opened) { + call fio to get the pathname of the subfile + if (different from cached pathname) { + update cached pathname + next + } else + error: cannot open file + } else { + read file header and verify that this is our subfile + if (not our subfile) { + close file + call fio to get the pathname of the subfile + if (different from cached pathname) { + update cached pathname + next + } else + error: not our subfile + } else + break # success + } + } diff --git a/sys/imio/db/README b/sys/imio/db/README new file mode 100644 index 00000000..cf7f9c1c --- /dev/null +++ b/sys/imio/db/README @@ -0,0 +1,105 @@ + Image Header Database Interface + dct 16-Apr-85 + +1. Overview + + This directory contains the first version of the image header database +interface. In this implementation the image header is a variable length fixed +format binary structure. The first, fixed format, part of the image header +contains the standard fields in binary and is fixed in size. This is followed +by the so called "user area", a string buffer containing a sequence of +variable length, newline delimited FITS format keyword=value header cards. +When an image is open a large user area is allocated to permit the addition +of new parameters without filling up the buffer. When the header is +subsequently updated on disk only as much disk space is used as is needed to +store the actual header. + +This format header is upwards compatible with the old image header format, +hence old images and programs do not have to be modified to use the IMIO +release supporting database accesss. In the future image headers will be +maintained under DBIO, but the routines in the image header database interface +are not exected to change. The actual disk format of images will of course +change when we switch over to the DBIO headers. + + + +2. Functions + + get,g - get the value of a field + put,p - set the value of a field + add,a - add a new field to a database + acc - determine if the named field exists + + +3. Procedures + + value = imget[bcsilrdx] (im, "field") + imgstr (im, "field", outstr, maxch) + imput[bcsilrdx] (im, "field", value) + impstr (im, "field", value) + imadd[bcsilrdx] (im, "field", def_value) + imastr (im, "field", def_value) + imaddf (im, "field", "datatype") + y/n = imaccf (im, "field") + + list = imofnl[su] (im, template) + nch = imgnfn (im, outstr, maxch) + imcfnl (im) + + + +4. Description + + New parameters will typically be added to the image header with either +one of the typed procedures IMADD_ or with the lower level procedure IMADDF. +The former procedures permit the parameter to be created and the value +initialized all in one call, while the latter only creates the parameter. +In addition, the typed IMADD_ procedures may be used to update the values +of existing parameters (it is not considered an error if the parameter +already exists). The principal limitation of the typed procedures is that +they may only be used to add or set parameters of a standard datatype. +The IMADDF procedure will permit creation of parameters with more descriptive +datatypes (domains) when the interface is recut upon DBIO. + +The value of any parameter may be fetched with one of the IMGET functions. +The IMACCF function may be used (like ACCESS for a file) to determine +whether a parameter exists. + +The database interface may be used to access any field of the image header, +including the following standard fields. Note that the nomenclature has +been changed slightly to make it more consistent with FITS. Additional +standard fields will be defined in the future. + + + keyword type description + + i_naxis i number of axes (dimensionality) + i_naxis[1-7] l length of an axis ("i_naxis1", etc.) + i_pixtype i pixel datatype (SPP integer code) + i_minpixval r minimum pixel value + i_maxpixval r maximum pixel value + i_ctime l time of image creation + i_mtime l time of last modify + i_limtime l time when limits (minmax) were last updated + i_title s title string + + +The names of the standard fields share an "i_" prefix to reduce the possibility +of collisions with data dependent keywords, to identify the standard fields in +sorted listings, to allow use of pattern matching to discriminate between the +standard fields and user fields, and so on. For the convenience of the user, +the "i_" prefix may be omitted provided the resultant name does not match the +name of a user parameter. It is however recommended that the full name be +used in all applications software. + + +5. Restrictions + + The use of FITS format as the internal format for storing fields in this +version of the interface places restrictions on the size of field names and +of the string value of string valued parameters. Field names are currently +limited to eight characters or less and case is ignored (since FITS requires +upper case). The eight character limit does not apply to the standard fields. +String values are limited to at most 68 characters. If put string is passed +a longer string it will be silently truncated. Trailing whitespace and +newlines are chopped when a string value is read. diff --git a/sys/imio/db/idb.h b/sys/imio/db/idb.h new file mode 100644 index 00000000..327ce3d2 --- /dev/null +++ b/sys/imio/db/idb.h @@ -0,0 +1,24 @@ +# IDB.H -- Image header database interface. In this version of the interface +# the standard image header fields are maintained in binary in a fixed +# structure and the user fields are maintained in FITS format (text) in the +# a string buffer following the binary image header. + +define IDB_RECLEN 80 # length of a FITS record (card) +define IDB_STARTVALUE 10 # first column of value field +define IDB_ENDVALUE 30 # last column of value field +define IDB_LENNUMERICRECORD 80 # length of new numeric records +define IDB_LENSTRINGRECORD 80 # length of new string records +define IDB_SZFITSKEY 8 # max length FITS keyword + +# Standard header keywords accessible via the database interface. + +define I_CTIME 1 +define I_HISTORY 2 +define I_LIMTIME 3 +define I_MAXPIXVAL 4 +define I_MINPIXVAL 5 +define I_MTIME 6 +define I_NAXIS 7 +define I_PIXFILE 8 +define I_PIXTYPE 9 +define I_TITLE 10 diff --git a/sys/imio/db/idbcard.x b/sys/imio/db/idbcard.x new file mode 100644 index 00000000..38ea36fb --- /dev/null +++ b/sys/imio/db/idbcard.x @@ -0,0 +1,134 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "idb.h" + +.help IDBCARD +.nf ------------------------------------------------------------------------- +Card i/o package, for reading through the FITS area of the image header. + + idb = idb_open (im, ualen) + recno|EOF = idb_nextcard (idb, rp) + idb_close (idb) + +This is a very simple package, used only to hide the details of how to +access successive image header cards. The main routine returns a char +pointer to successive cards until the end of the header is reached. +This is convenient for efficient read access to the header; direct i/o +to the image header may be accomplished by using STROPEN to open the +header buffer on a file descriptor. + +This entire interface assumes that the header is stored in FITS format, +which is an implementation detail of the current IMIO interface. Hence, +this interface is internal to IMIO. +.endhelp -------------------------------------------------------------------- + +define LEN_IDB 6 +define IDB_IM Memi[$1] # image descriptor +define IDB_UA Memi[$1+1] # pointer to user area +define IDB_UALEN Memi[$1+2] # length of user area +define IDB_RECPTR Memi[$1+3] # current record pointer +define IDB_RECNO Memi[$1+4] # current record number +define IDB_BLOCKED Memi[$1+5] # cards blank filled? + + +# IDB_OPEN -- Open the FITS area for for card i/o. + +pointer procedure idb_open (im, ualen) + +pointer im #I image descriptor +int ualen #O size of storage area + +int n +pointer idb, ip +errchk malloc + +begin + call malloc (idb, LEN_IDB, TY_STRUCT) + + IDB_IM(idb) = im + IDB_UA(idb) = IM_USERAREA(im) + IDB_UALEN(idb) = (LEN_IMDES + IM_LENHDRMEM(im) - IMU) * SZ_STRUCT - 1 + IDB_RECPTR(idb) = IM_USERAREA(im) + IDB_RECNO(idb) = 1 + + if (IM_UABLOCKED(im) < 0) { + # At image open time this flag is set by IMMAP to -1 to indicate + # that the user area record type is not known. An IKI kernel may + # subsequently set the flag to yes/no, else we determine the + # record type by inspection the first time we are called. If the + # user area is empty the record type is set to blocked; IDB always + # writes blocked records. + + IM_UABLOCKED(im) = YES + for (ip=IM_USERAREA(im); Memc[ip] != EOS; ip=ip+1) { + for (n=0; Memc[ip] != EOS; n=n+1) { + if (Memc[ip] == '\n') + break + ip = ip + 1 + } + if (n != IDB_RECLEN) { + IM_UABLOCKED(im) = NO + break + } + } + } + + IDB_BLOCKED(idb) = IM_UABLOCKED(im) + ualen = IDB_UALEN(idb) + return (idb) +end + + +# IDB_NEXTCARD -- Return a pointer to the next card in the FITS header. +# EOF is returned at the end of the header. + +int procedure idb_nextcard (idb, recptr) + +pointer idb #I pointer to IDB descriptor +pointer recptr #O pointer to card + +int recno +pointer ip, i + +begin + # Reference current card. + recno = IDB_RECNO(idb) + recptr = IDB_RECPTR(idb) + + # Advance to the next card. + ip = recptr + if (IDB_BLOCKED(idb) == NO) { + if (Memc[ip] != EOS) # skip blank lines + ip = ip + 1 + do i = ip, ip+IDB_RECLEN + if (Memc[i] == EOS) { + ip = i + break + } else if (Memc[i] == '\n') { + ip = i + 1 + break + } + } else + ip = ip + IDB_RECLEN + 1 + + IDB_RECNO(idb) = recno + 1 + IDB_RECPTR(idb) = ip + + if (Memc[recptr] == EOS || recptr >= IDB_UA(idb) + IDB_UALEN(idb)) + return (EOF) + else + return (recno) +end + + +# IDB_CLOSE -- Free the IDB descriptor. + +procedure idb_close (idb) + +pointer idb #I pointer to IDB descriptor + +begin + call mfree (idb, TY_STRUCT) +end diff --git a/sys/imio/db/idbfind.x b/sys/imio/db/idbfind.x new file mode 100644 index 00000000..f98acb7e --- /dev/null +++ b/sys/imio/db/idbfind.x @@ -0,0 +1,145 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "idb.h" + +# IDB_FINDRECORD -- Search the image database for a particular record given +# the key. The record number (a positive nonzero integer) is returned if +# the record is found, else 0. + +int procedure idb_findrecord (im, key, rp) + +pointer im # image descriptor +char key[ARB] # record key +pointer rp # char record pointer (output) + +pointer sp, pat, patbuf, ukey, lkey, ip, ua +int recno, nchars, lch, uch, ch, junk, n, i +int patmake(), patmatch(), stridxs(), gstrcpy() + +begin + call smark (sp) + call salloc (pat, SZ_FNAME, TY_CHAR) + call salloc (ukey, SZ_FNAME, TY_CHAR) + call salloc (lkey, SZ_FNAME, TY_CHAR) + call salloc (patbuf, SZ_LINE, TY_CHAR) + + # Prepare U/L FITS keywords, truncated to 8 chars. + nchars = gstrcpy (key, Memc[lkey], IDB_SZFITSKEY) + call strlwr (Memc[lkey]) + nchars = gstrcpy (key, Memc[ukey], IDB_SZFITSKEY) + call strupr (Memc[ukey]) + + # Search for the FIRST occurrence of a record with the given key. + # If the key is abbreviated and multiple keys are matched, the first + # record matched is used. + + ua = IM_USERAREA(im) + rp = NULL + recno = 1 + + if (IM_UABLOCKED(im) < 0) { + # At image open time this flag is set by IMMAP to -1 to indicate + # that the user area record type is not known. An IKI kernel may + # subsequently set the flag to yes/no, else we determine the + # record type by inspection the first time we are called. If the + # user area is empty the record type is set to blocked; IDB always + # writes blocked records. + + IM_UABLOCKED(im) = YES + for (ip=ua; Memc[ip] != EOS; ip=ip+1) { + for (n=0; Memc[ip] != EOS; n=n+1) { + if (Memc[ip] == '\n') + break + ip = ip + 1 + } + if (n != IDB_RECLEN) { + IM_UABLOCKED(im) = NO + break + } + } + } + + if (IM_UABLOCKED(im) == NO) { + # Variable length, newline terminated records, EOS terminated + # record group. + + call sprintf (Memc[pat], SZ_FNAME, "^{%s}[ =]") + call pargstr (Memc[ukey]) + junk = patmake (Memc[pat], Memc[patbuf], SZ_LINE) + + for (ip=ua; Memc[ip] != EOS; ip=ip+1) { + if (patmatch (Memc[ip], Memc[patbuf]) > 0) { + rp = ip + break + } + #if (Memc[ip] != EOS) + # ip = ip + 1 + while (Memc[ip] != '\n' && Memc[ip] != EOS) + ip = ip + 1 + recno = recno + 1 + } + + } else { + # Fixed length (80 character), newline terminated records, EOS + # terminated record group. + + if (stridxs ("*?[]", Memc[ukey]) > 0) { + # Pattern matching search. + call sprintf (Memc[pat], SZ_FNAME, "^{%s}[ =]") + call pargstr (Memc[ukey]) + junk = patmake (Memc[pat], Memc[patbuf], SZ_LINE) + + for (ip=ua; Memc[ip] != EOS; ip=ip+IDB_RECLEN+1) { + if (patmatch (Memc[ip], Memc[patbuf]) > 0) { + rp = ip + break + } + recno = recno + 1 + } + + } else { + # Simple fast search, fixed length records. Case insensitive + # keyword match. + + lch = Memc[lkey] + uch = Memc[ukey] + + for (ip=ua; Memc[ip] != EOS; ip=ip+IDB_RECLEN+1) { + ch = Memc[ip] + if (ch == EOS) + break + else if (ch != lch && ch != uch) + next + else { + # Abbreviations are not permitted. + ch = Memc[ip+nchars] + if (ch != ' ' && ch != '=') + next + } + + # First char matches; check rest of string. + do i = 1, nchars-1 { + ch = Memc[ip+i] + if (ch != Memc[lkey+i] && ch != Memc[ukey+i]) { + ch = 0 + break + } + } + if (ch != 0) { + rp = ip # match + break + } + + recno = recno + 1 + } + } + } + + call sfree (sp) + if (rp == NULL) + return (0) + else + return (recno) +end diff --git a/sys/imio/db/idbfstr.x b/sys/imio/db/idbfstr.x new file mode 100644 index 00000000..1087ca02 --- /dev/null +++ b/sys/imio/db/idbfstr.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + + +# IDB_FILSTR -- Filter a string, removing any tabs or control characters. +# This is used to clean up strings we want to put in image headers. A count +# of the output, filtered string is returned as the function value. Tabs or +# newlines in the input are replaced by blanks. Illegal or unprintable +# control characters in the input are deleted. + +int procedure idb_filstr (s1, s2, maxch) + +char s1[ARB] #I input string +char s2[ARB] #O output string +int maxch #I max chars out + +int op, ch, i + +begin + op = 1 + + do i = 1, ARB { + ch = s1[i] + if (ch == EOS) + break + else if (ch == '\t' || ch == '\n') + ch = ' ' + else if (!IS_PRINT (ch)) + next + + s2[op] = ch + op = op + 1 + if (op > maxch) + break + } + + s2[op] = EOS + return (op - 1) +end diff --git a/sys/imio/db/idbgstr.x b/sys/imio/db/idbgstr.x new file mode 100644 index 00000000..ffa43ff9 --- /dev/null +++ b/sys/imio/db/idbgstr.x @@ -0,0 +1,85 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "idb.h" + +define TY_STRING (-1) + +# IDB_GETSTRING -- Get the string value of a standard header parameter. If the +# actual type of the parameter is not string the value is encoded as a string. +# The length of the string is returned as the function value. ERR is returned +# if the string cannot be found. + +int procedure idb_getstring (im, key, outstr, maxch) + +pointer im # image descriptor +char key[ARB] # parameter to be returned +char outstr[ARB] # output string to receive parameter value +int maxch + +long lval +real rval +int dtype, axis, ip +int gstrcpy(), idb_kwlookup(), strncmp(), ltoc(), strlen() +define encode_ 91 + +begin + # A standard keyword is recognized with or without the "i_" prefix. + if (key[1] == 'i' && key[2] == '_') + ip = 3 + else + ip = 1 + + # The keywords "naxis1", "naxis2", etc. are treated as a special case. + if (strncmp (key[ip], "naxis", 5) == 0) + if (IS_DIGIT(key[ip+5]) && key[ip+6] == EOS) { + dtype = TY_LONG + axis = TO_INTEG(key[ip+5]) + lval = IM_LEN(im,axis) + goto encode_ + } + + switch (idb_kwlookup (key[ip])) { + case I_CTIME: + dtype = TY_LONG + lval = IM_CTIME(im) + case I_HISTORY: + dtype = TY_STRING + return (gstrcpy (IM_HISTORY(im), outstr, maxch)) + case I_LIMTIME: + dtype = TY_LONG + lval = IM_LIMTIME(im) + case I_MAXPIXVAL: + dtype = TY_REAL + rval = IM_MAX(im) + case I_MINPIXVAL: + dtype = TY_REAL + rval = IM_MIN(im) + case I_MTIME: + dtype = TY_LONG + lval = IM_MTIME(im) + case I_NAXIS: + dtype = TY_LONG + lval = IM_NDIM(im) + case I_PIXFILE: + return (gstrcpy (IM_PIXFILE(im), outstr, maxch)) + case I_PIXTYPE: + dtype = TY_LONG + lval = IM_PIXTYPE(im) + case I_TITLE: + return (gstrcpy (IM_TITLE(im), outstr, maxch)) + default: + outstr[1] = EOS + return (ERR) + } + +encode_ + if (dtype == TY_LONG) + return (ltoc (lval, outstr, maxch)) + else { + call sprintf (outstr, maxch, "%g") + call pargr (rval) + return (strlen (outstr)) + } +end diff --git a/sys/imio/db/idbkwlu.x b/sys/imio/db/idbkwlu.x new file mode 100644 index 00000000..5b3ee553 --- /dev/null +++ b/sys/imio/db/idbkwlu.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IDB_KWLOOKUP -- Look up a keyword in the dictionary of standard header +# keywords, returning the magic integer code of the keyword or zero. + +int procedure idb_kwlookup (key) + +char key[ARB] # keyword to be looked up +int index, ip, ch +pointer sp, kwname +int strdic(), strncmp(), strlen() +string keywords "|ctime|history|limtime|maxpixval|minpixval|mtime|naxis\ +|pixfile|pixtype|title|" + +begin + call smark (sp) + call salloc (kwname, SZ_FNAME, TY_CHAR) + + # Look the string up in the dictionary of standard keywords. Note that + # the "i_" prefix is omitted in the dictionary. The order of the + # keywords in the dictionary must agree with the defined codes in the + # header file. A standard keyword is recognized with or without the + # "i_" prefix. + + if (key[1] == 'i' && key[2] == '_') + ip = 3 + else + ip = 1 + + # Check for a reference to one of the NAXIS keywords. + if (key[ip] == 'n') + if (strncmp (key[ip], "naxis", 5) == 0) { + ch = key[ip+5] + if (ch == EOS || (IS_DIGIT(ch) && key[ip+6] == EOS)) { + call sfree (sp) + return (7) + } + } + + # Look up keyword in dictionary. Abbreviations are not permitted. + index = strdic (key[ip], Memc[kwname], SZ_FNAME, keywords) + if (index != 0) + if (strlen(key[ip]) != strlen(Memc[kwname])) + index = 0 + + call sfree (sp) + return (index) +end diff --git a/sys/imio/db/idbpstr.x b/sys/imio/db/idbpstr.x new file mode 100644 index 00000000..e2facd75 --- /dev/null +++ b/sys/imio/db/idbpstr.x @@ -0,0 +1,101 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "idb.h" + +# IDB_PUTSTRING -- Set the value of a standard header parameter given the new +# value of the parameter encoded as a string. If actual type of the parameter +# is non string the value must be decoded. ERR is returned if the key is not +# a standard header parameter. An error action is taken if the key is known +# but the value cannot be decoded. + +int procedure idb_putstring (im, key, strval) + +pointer im # image descriptor +char key[ARB] # parameter to be returned +char strval[ARB] # string value of parameter + +double dval +bool numeric +int ip, axis +int strncmp(), gstrcpy(), idb_kwlookup(), ctod(), strlen() + +begin + # Determine if the given string value is numeric. This is true if + # it consists of a single numeric token of a reasonable length. + + ip = 1 + numeric = false + if (strlen (strval) < MAX_DIGITS) + if (ctod (strval, ip, dval) > 0) { + while (IS_WHITE (strval[ip]) || strval[ip] == '\n') + ip = ip + 1 + numeric = (strval[ip] == EOS) + } + + # A standard keyword is recognized with or without the "i_" prefix. + if (key[1] == 'i' && key[2] == '_') + ip = 3 + else + ip = 1 + + # The keywords "naxis1", "naxis2", etc. are treated as a special case. + if (strncmp (key[ip], "naxis", 5) == 0) + if (IS_DIGIT(key[ip+5]) && key[ip+6] == EOS) { + axis = TO_INTEG(key[ip+5]) + if (numeric && axis >= 1 && axis <= IM_NDIM(im)) { + IM_LEN(im,axis) = nint(dval) + return (OK) + } else + call syserrs (SYS_IDBTYPE, key) + } + + # Lookup the keyword in the dictionary and set the value of the + # header parameter. If the parameter is string valued copy the + # string value and return immediately. + + switch (idb_kwlookup (key[ip])) { + case I_CTIME: + if (numeric) + IM_CTIME(im) = nint(dval) + case I_HISTORY: + return (gstrcpy (strval, IM_HISTORY(im), SZ_IMHIST)) + case I_LIMTIME: + if (numeric) + IM_LIMTIME(im) = nint(dval) + case I_MAXPIXVAL: + if (numeric) + IM_MAX(im) = dval + case I_MINPIXVAL: + if (numeric) + IM_MIN(im) = dval + case I_MTIME: + if (numeric) + IM_MTIME(im) = nint(dval) + case I_NAXIS: + if (numeric) + IM_NDIM(im) = nint(dval) + case I_PIXFILE: + return (gstrcpy (strval, IM_PIXFILE(im), SZ_IMPIXFILE)) + case I_PIXTYPE: + if (numeric) + IM_PIXTYPE(im) = nint(dval) + case I_TITLE: + return (gstrcpy (strval, IM_TITLE(im), SZ_IMTITLE)) + default: + return (ERR) + } + + # If we make it through the switch, i.e., do not execute a return + # statement, then the key was recognized and is of a numeric datatype. + # If the value was successfully decoded as numeric then all is well, + # else the value could not be decoded and we have an error. + + if (!numeric) + call syserrs (SYS_IDBTYPE, key) + else + return (OK) +end diff --git a/sys/imio/db/imaccf.x b/sys/imio/db/imaccf.x new file mode 100644 index 00000000..60e4e9f3 --- /dev/null +++ b/sys/imio/db/imaccf.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMACCF -- Test if the named field exists. NO is returned if the key is not +# found, YES otherwise. + +int procedure imaccf (im, key) + +pointer im # image descriptor +char key[ARB] # name of the new parameter +int idb_kwlookup(), idb_findrecord() +pointer rp + +begin + if ((idb_kwlookup (key) > 0) || (idb_findrecord (im, key, rp) > 0)) + return (YES) + else + return (NO) +end diff --git a/sys/imio/db/imaddb.x b/sys/imio/db/imaddb.x new file mode 100644 index 00000000..f60f435a --- /dev/null +++ b/sys/imio/db/imaddb.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMADDB -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imaddb (im, key, value) + +pointer im # image descriptor +char key[ARB] # parameter or field value +bool value # new or initial value of parameter + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, "b") + call imputb (im, key, value) +end diff --git a/sys/imio/db/imaddd.x b/sys/imio/db/imaddd.x new file mode 100644 index 00000000..f5811b79 --- /dev/null +++ b/sys/imio/db/imaddd.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMADDD -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imaddd (im, key, value) + +pointer im # image descriptor +char key[ARB] # parameter or field value +double value # new or initial value of parameter + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, "d") + call imputd (im, key, value) +end diff --git a/sys/imio/db/imaddf.x b/sys/imio/db/imaddf.x new file mode 100644 index 00000000..e2328f78 --- /dev/null +++ b/sys/imio/db/imaddf.x @@ -0,0 +1,96 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "idb.h" + +# IMADDF -- Add a user field to the image header. It is an error if the named +# field already exists. + +procedure imaddf (im, key, datatype) + +pointer im #I image descriptor +char key[ARB] #I name of the new parameter +char datatype[ARB] #I string permits generalization to domains + +pointer rp, sp, keyname, ua, ip +int fd, max_lenuserarea, curlen, buflen, nchars +int idb_kwlookup(), idb_findrecord() +int stropen(), strlen(), idb_filstr(), nowhite() +errchk syserrs, stropen, fprintf, pargstr, pargi + +begin + call smark (sp) + call salloc (keyname, SZ_FNAME, TY_CHAR) + + # FITS format requires that the keyword name be upper case, not to + # exceed 8 characters in length. [Nov97 - This is not entirely + # correct, FITS does not require upper case, however we don't want + # to change this at this time.] + + nchars = idb_filstr (key, Memc[keyname], IDB_SZFITSKEY) + nchars = nowhite (Memc[keyname], Memc[keyname], IDB_SZFITSKEY) + call strupr (Memc[keyname]) + + # Check for a redefinition. + if ((idb_kwlookup (key) > 0) || (idb_findrecord (im, key, rp) > 0)) + call syserrs (SYS_IDBREDEF, key) + + # Open the user area string for appending. 'buflen' is the malloc-ed + # buffer length in struct units; IMU is the struct offset to the user + # area, i.e., the size of that part of the image descriptor preceding + # the user area. If the buffer fills we must allow one extra char for + # the EOS delimiter; since storage for the image descriptor was + # allocated in struct units the storage allocator will not have + # allocated space for the extra EOS char. + + ua = IM_USERAREA(im) + curlen = strlen (Memc[ua]) + buflen = LEN_IMDES + IM_LENHDRMEM(im) + max_lenuserarea = (buflen - IMU) * SZ_STRUCT - 1 + + # If the user area is not empty the last character must be the newline + # record delimiter, else the new record we add will be invalid. + + if (curlen > 0 && Memc[ua+curlen-1] != '\n') + if (curlen >= max_lenuserarea) + call syserrs (SYS_IDBOVFL, key) + else { + Memc[ua+curlen] = '\n' + curlen = curlen + 1 + Memc[ua+curlen] = EOS + } + + fd = stropen (Memc[ua+curlen], max_lenuserarea-curlen, APPEND) + + # Append the new record with an uninitialized value field. + iferr { + call fprintf (fd, "%-8s= %s%*t\n") + call pargstr (Memc[keyname]) + if (datatype[1] == 'c') { + call pargstr ("' '") + call pargi (IDB_LENSTRINGRECORD + 1) + } else { + call pargstr ("") + call pargi (IDB_LENNUMERICRECORD + 1) + } + + } then { + # Out of space in the user area. Discard the truncated card at the + # end of the buffer by backing up to the last newline and writing + # an EOS. + + call close (fd) + for (ip=ua+max_lenuserarea-1; ip > ua; ip=ip-1) + if (Memc[ip] == '\n') { + Memc[ip+1] = EOS + break + } + call syserrs (SYS_IDBOVFL, key) + } + + call close (fd) + call sfree (sp) +end diff --git a/sys/imio/db/imaddi.x b/sys/imio/db/imaddi.x new file mode 100644 index 00000000..76653e66 --- /dev/null +++ b/sys/imio/db/imaddi.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMADDI -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imaddi (im, key, value) + +pointer im # image descriptor +char key[ARB] # parameter or field value +int value # new or initial value of parameter + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, "i") + call imputi (im, key, value) +end diff --git a/sys/imio/db/imaddl.x b/sys/imio/db/imaddl.x new file mode 100644 index 00000000..9064f6c4 --- /dev/null +++ b/sys/imio/db/imaddl.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMADDL -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imaddl (im, key, value) + +pointer im # image descriptor +char key[ARB] # parameter or field value +long value # new or initial value of parameter + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, "l") + call imputl (im, key, value) +end diff --git a/sys/imio/db/imaddr.x b/sys/imio/db/imaddr.x new file mode 100644 index 00000000..e07dbb53 --- /dev/null +++ b/sys/imio/db/imaddr.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMADDR -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imaddr (im, key, value) + +pointer im # image descriptor +char key[ARB] # parameter or field value +real value # new or initial value of parameter + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, "r") + call imputr (im, key, value) +end diff --git a/sys/imio/db/imadds.x b/sys/imio/db/imadds.x new file mode 100644 index 00000000..e1b9f1a1 --- /dev/null +++ b/sys/imio/db/imadds.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMADDS -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imadds (im, key, value) + +pointer im # image descriptor +char key[ARB] # parameter or field value +short value # new or initial value of parameter + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, "s") + call imputs (im, key, value) +end diff --git a/sys/imio/db/imastr.x b/sys/imio/db/imastr.x new file mode 100644 index 00000000..d87c1828 --- /dev/null +++ b/sys/imio/db/imastr.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMASTR -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imastr (im, key, value) + +pointer im # image descriptor +char key[ARB] # parameter or field value +char value[ARB] # new or initial value of parameter + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, "c") + call impstr (im, key, value) +end diff --git a/sys/imio/db/imdelf.x b/sys/imio/db/imdelf.x new file mode 100644 index 00000000..e8365e22 --- /dev/null +++ b/sys/imio/db/imdelf.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "idb.h" + +# IMDELF -- Delete a user field from the image header. It is an error if the +# named field does not exist. + +procedure imdelf (im, key) + +pointer im # image descriptor +char key[ARB] # name of the new parameter + +int off +pointer rp, sp, keyname +int idb_kwlookup(), idb_findrecord(), stridxs() +errchk syserrs + +begin + call smark (sp) + call salloc (keyname, SZ_FNAME, TY_CHAR) + + # FITS format requires that the keyword name be upper case. + call strcpy (key, Memc[keyname], IDB_SZFITSKEY) + call strupr (Memc[keyname]) + + # Cannot delete standard header keywords. + if (idb_kwlookup (key) > 0) + call syserrs (SYS_IDBNODEL, key) + + # Verify that the named user field exists. + if (idb_findrecord (im, key, rp) <= 0) + call syserrs (SYS_IDBDELNXKW, key) + + # Delete the field. + off = stridxs ("\n", Memc[rp]) + if (off > 0) + call strcpy (Memc[rp+off], Memc[rp], ARB) + else + Memc[rp] = EOS + + call sfree (sp) +end diff --git a/sys/imio/db/imgetb.x b/sys/imio/db/imgetb.x new file mode 100644 index 00000000..cd7ed03f --- /dev/null +++ b/sys/imio/db/imgetb.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "idb.h" + +# IMGETB -- Get an image header parameter of type boolean. False is returned +# if the parameter cannot be found or if the value is not true. + +bool procedure imgetb (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be returned + +pointer rp +pointer idb_findrecord() + +begin + if (idb_findrecord (im, key, rp) == 0) + call syserrs (SYS_IDBKEYNF, key) + else + return (Memc[rp+IDB_ENDVALUE-1] == 'T') +end diff --git a/sys/imio/db/imgetc.x b/sys/imio/db/imgetc.x new file mode 100644 index 00000000..f56ecb9d --- /dev/null +++ b/sys/imio/db/imgetc.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMGETC -- Get an image header parameter of type char. + +char procedure imgetc (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be returned +long imgetl() + +begin + return (imgetl (im, key)) +end diff --git a/sys/imio/db/imgetd.x b/sys/imio/db/imgetd.x new file mode 100644 index 00000000..01a71cb1 --- /dev/null +++ b/sys/imio/db/imgetd.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "idb.h" + +# IMGETD -- Get an image header parameter of type double floating. If the +# named parameter is a standard parameter return the value directly, +# else scan the user area for the named parameter and decode the value. + +double procedure imgetd (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be returned + +int ip +double dval +pointer sp, sval +int ctod() +errchk syserrs, imgstr + +begin + call smark (sp) + call salloc (sval, SZ_LINE, TY_CHAR) + + ip = 1 + call imgstr (im, key, Memc[sval], SZ_LINE) + if (ctod (Memc[sval], ip, dval) == 0) + call syserrs (SYS_IDBTYPE, key) + + call sfree (sp) + return (dval) +end diff --git a/sys/imio/db/imgeti.x b/sys/imio/db/imgeti.x new file mode 100644 index 00000000..8da2878e --- /dev/null +++ b/sys/imio/db/imgeti.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMGETI -- Get an image header parameter of type integer. + +int procedure imgeti (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be returned + +long lval, imgetl() +errchk imgetl + +begin + lval = imgetl (im, key) + if (IS_INDEFL(lval)) + return (INDEFI) + else + return (lval) +end diff --git a/sys/imio/db/imgetl.x b/sys/imio/db/imgetl.x new file mode 100644 index 00000000..817715c0 --- /dev/null +++ b/sys/imio/db/imgetl.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMGETL -- Get an image header parameter of type long integer. + +long procedure imgetl (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be returned + +double dval, imgetd() +errchk imgetd + +begin + dval = imgetd (im, key) + if (IS_INDEFD(dval)) + return (INDEFL) + else + return (nint (dval)) +end diff --git a/sys/imio/db/imgetr.x b/sys/imio/db/imgetr.x new file mode 100644 index 00000000..b1c6c67a --- /dev/null +++ b/sys/imio/db/imgetr.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMGETR -- Get an image header parameter of type real. + +real procedure imgetr (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be returned + +double dval, imgetd() +errchk imgetd + +begin + dval = imgetd (im, key) + if (IS_INDEFD(dval)) + return (INDEFR) + else + return (dval) +end diff --git a/sys/imio/db/imgets.x b/sys/imio/db/imgets.x new file mode 100644 index 00000000..39f2fcfd --- /dev/null +++ b/sys/imio/db/imgets.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMGETS -- Get an image header parameter of type short integer. + +short procedure imgets (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be returned + +long lval, imgetl() +errchk imgetl + +begin + lval = imgetl (im, key) + if (IS_INDEFL(lval)) + return (INDEFS) + else + return (lval) +end diff --git a/sys/imio/db/imgftype.x b/sys/imio/db/imgftype.x new file mode 100644 index 00000000..12ee9048 --- /dev/null +++ b/sys/imio/db/imgftype.x @@ -0,0 +1,71 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "idb.h" + +# IMGFTYPE -- Get the datatype of a particular field of an image header. Since +# the internal format is FITS, there are four primary datatypes, boolean (T|F), +# string (quoted), integer and real. + +int procedure imgftype (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be set + +pointer rp +int ch, ip +int idb_findrecord(), idb_kwlookup() +errchk syserrs + +begin + # Check for a standard header keyword. + switch (idb_kwlookup (key)) { + case I_CTIME: + return (TY_LONG) + case I_HISTORY: + return (TY_CHAR) + case I_LIMTIME: + return (TY_LONG) + case I_MAXPIXVAL: + return (TY_REAL) + case I_MINPIXVAL: + return (TY_REAL) + case I_MTIME: + return (TY_LONG) + case I_NAXIS: + return (TY_LONG) + case I_PIXFILE: + return (TY_CHAR) + case I_PIXTYPE: + return (TY_LONG) + case I_TITLE: + return (TY_CHAR) + } + + # If we get here then the named parameter is not a standard header + # keyword. + + if (idb_findrecord (im, key, rp) > 0) { + # Check for quoted string. + ch = Memc[rp+IDB_STARTVALUE] + if (ch == '\'') + return (TY_CHAR) + + # Check for boolean field. + ch = Memc[rp+IDB_ENDVALUE-1] + if (ch == 'T' || ch == 'F') + return (TY_BOOL) + + # If field contains only digits it must be an integer. + for (ip=IDB_STARTVALUE; ip <= IDB_ENDVALUE; ip=ip+1) { + ch = Memc[rp+ip-1] + if (! (IS_DIGIT(ch) || IS_WHITE(ch))) + return (TY_REAL) + } + + return (TY_INT) + } + + call syserrs (SYS_IDBKEYNF, key) +end diff --git a/sys/imio/db/imgnfn.x b/sys/imio/db/imgnfn.x new file mode 100644 index 00000000..2dca4d9f --- /dev/null +++ b/sys/imio/db/imgnfn.x @@ -0,0 +1,339 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "idb.h" + +.help imgnfn +.nf -------------------------------------------------------------------------- +IMGNFN -- Template expansion for image header keywords. + + list = imofnl[su] (im, template) # open list + nch = imgnfn (im, outstr, maxch) # get next field name + imcfnl (im) # close list + +IMOFNLS opens the list sorted, whereas IMOFNLU opens it unsorted. Both std. +and user header keywords are included in the list. +.endhelp --------------------------------------------------------------------- + +define MAX_FIELDS 1024 +define SZ_SBUF 8192 +define LEN_FNSTRUCT (10+MAX_FIELDS) + +define FN_NENTRIES Memi[$1] # number of field names in list +define FN_NEXT Memi[$1+1] # next string to be returned +define FN_SBUF Memi[$1+2] # pointer to string buffer + # open +define FN_STRP Memi[$1+10+$2-1] # array of str ptrs +define FN_FIELDNAME Memc[FN_STRP($1,$2)] # reference a string + + +# IMGNFN -- Get the next field name matching the given template from an image +# header database. Sorting of the field list is optional. A prior call to +# IMOFNL[SU] is necessary to open the sorted or unsorted list. + +int procedure imgnfn (fn, outstr, maxch) + +pointer fn # field name list descriptor +char outstr[ARB] # output string +int maxch + +int strnum +int gstrcpy() + +begin + strnum = FN_NEXT(fn) + if (strnum > FN_NENTRIES(fn)) + return (EOF) + FN_NEXT(fn) = strnum + 1 + + return (gstrcpy (FN_FIELDNAME(fn,strnum), outstr, maxch)) +end + + +# IMOFNLS -- Open a sorted field name list. + +pointer procedure imofnls (im, template) + +pointer im # image descriptor +char template[ARB] # field name template +pointer imofnl() + +begin + return (imofnl (im, template, YES)) +end + + +# IMOFNLU -- Open an unsorted field name list. + +pointer procedure imofnlu (im, template) + +pointer im # image descriptor +char template[ARB] # field name template +pointer imofnl() + +begin + return (imofnl (im, template, NO)) +end + + +# IMCFNL -- Close the image header field name list and return all associated +# storage. + +procedure imcfnl (fn) + +pointer fn # field name list descriptor + +begin + call mfree (FN_SBUF(fn), TY_CHAR) + call mfree (fn, TY_STRUCT) +end + + +# IMOFNL -- Open an image header field name list, either sorted or unsorted. +# A template is a list of patterns delimited by commas. + +pointer procedure imofnl (im, template, sort) + +pointer im # image descriptor +char template[ARB] # field name template +int sort # sort flag + +bool escape +int tp, nstr, ch, junk, first_string, nstrings, nmatch, i +pointer sp, ip, op, fn, kwname, sbuf, pattern, patcode, nextch +int patmake(), patmatch(), strlen() +errchk syserr + +begin + call smark (sp) + call salloc (kwname, SZ_FNAME, TY_CHAR) + call salloc (pattern, SZ_FNAME, TY_CHAR) + call salloc (patcode, SZ_LINE, TY_CHAR) + + # Allocate field list descriptor. + call calloc (fn, LEN_FNSTRUCT, TY_STRUCT) + call malloc (sbuf, SZ_SBUF, TY_CHAR) + + FN_SBUF(fn) = sbuf + nextch = sbuf + nstr = 0 + tp = 1 + + # Extract each comma delimited template, expand upon image header + # field list, sort if desired, and add strings to list. + + while (template[tp] != EOS && template[tp] != '\n') { + # Advance to next field. + while (IS_WHITE(template[tp]) || template[tp] == ',') + tp = tp + 1 + + # Extract pattern. Enclose pattern in ^{} so that the match will + # occur only at the beginning of each line and will be case + # insensitive (req'd for FITS format). + + op = pattern + Memc[op] = '^' + op = op + 1 + Memc[op] = '{' + op = op + 1 + + # A field name of the form "$", "$x", etc. is not matched against + # the actual image field list, but is included in the output field + # list as a literal. + + ch = template[tp] + escape = (ch == '$') + + while (! (IS_WHITE(ch) || ch == '\n' || ch == ',' || ch == EOS)) { + # Map "*" into "?*". + if (ch == '*') { + Memc[op] = '?' + op = op + 1 + } + + Memc[op] = ch + op = op + 1 + tp = tp + 1 + ch = template[tp] + } + + Memc[op] = '}' + op = op + 1 + Memc[op] = EOS + + # If the pattern is a literal, put it in the output list without + # matching it against the image field list. + + if (escape) { + # Omit the leading "^{" and the trailing "}". + ip = pattern + 2 + op = op - 1 + Memc[op] = EOS + call imfn_putkey (Memc[ip], FN_STRP(fn,1), nstr, nextch, sbuf) + + } else { + # Encode pattern. + junk = patmake (Memc[pattern], Memc[patcode], SZ_LINE) + + # Scan database and extract all field names matching the + # pattern. Mark number of first string for the sort. + + first_string = nstr + 1 + + # First find any standard header keywords matching the pattern. + call imfn_stdkeys (im, Memc[patcode], FN_STRP(fn,1), nstr, + nextch, sbuf) + + # Now scan the user area. + for (ip=IM_USERAREA(im); Memc[ip] != EOS; ip=ip+1) { + # Skip entries that are not keywords. + if (Memc[ip+8] == '=') { + + # Extract keyword name. + Memc[kwname+8] = EOS + do i = 1, 8 { + ch = Memc[ip+i-1] + if (ch == ' ') { + Memc[kwname+i-1] = EOS + break + } else + Memc[kwname+i-1] = ch + } + + # Check for a match. + if (Memc[kwname] != EOS) { + # Put key in list if it matches. + nmatch = patmatch (Memc[kwname], Memc[patcode]) - 1 + if (nmatch > 0 && nmatch == strlen(Memc[kwname])) + call imfn_putkey (Memc[ip], + FN_STRP(fn,1), nstr, nextch, sbuf) + } + } + + # Advance to the next record. + if (IM_UABLOCKED(im) == YES) + ip = ip + IDB_RECLEN + else { + while (Memc[ip] != '\n' && Memc[ip] != EOS) + ip = ip + 1 + } + + if (Memc[ip] == EOS) + break + } + + # Sort the newly added keywords. + nstrings = nstr - first_string + 1 + if (sort == YES && nstrings > 1) + call strsrt (FN_STRP(fn,first_string), Memc, nstrings) + } + } + + FN_NENTRIES(fn) = nstr + FN_NEXT(fn) = 1 + + call sfree (sp) + return (fn) +end + + +# IMFN_STDKEYS -- Match a pattern (encoded) against the list of standard header +# keywords, both with and without the "i_" prefix. Add the full name (with i_ +# prefix) of each name matched to the keyword list. + +procedure imfn_stdkeys (im, patcode, strp, nstr, nextch, sbuf) + +pointer im # image descriptor +char patcode[ARB] # encoded pattern +pointer strp[ARB] # array of string pointers +int nstr # current number of strings +pointer nextch # next available char in string buffer +pointer sbuf # string buffer + +pointer sp, op, key +bool validfield, match +int ip, index, nmatch +int patmatch(), strlen() + +string keywords "|ctime|history|limtime|maxpixval|minpixval|mtime|naxis\ +|naxis1|naxis2|naxis3|naxis4|naxis5|naxis6|naxis7|pixfile|pixtype|title|" +errchk imfn_putkey + +begin + call smark (sp) + call salloc (key, SZ_FNAME, TY_CHAR) + + call strcpy ("i_", Memc[key], SZ_FNAME) + index = 1 + + for (ip=2; keywords[ip] != EOS; ip=ip+1) { + # Do not put dimensions NAXIS1, NAXIS2, etc. higher than the + # actual image dimension into the matched list. + + validfield = true + if (index >= 8 && index <= 14) + validfield = (index - 7 <= IM_NDIM(im)) + + # Extract keyword into buffer, after the "i_". + for (op=key+2; keywords[ip] != '|'; op=op+1) { + Memc[op] = keywords[ip] + ip = ip + 1 + } + Memc[op] = EOS + + if (validfield) { + nmatch = patmatch (Memc[key], patcode) - 1 + match = (nmatch > 0 && nmatch == strlen(Memc[key])) + if (!match) { + nmatch = patmatch (Memc[key+2], patcode) - 1 + match = (nmatch > 0 && nmatch == strlen(Memc[key+2])) + } + if (match) + call imfn_putkey (Memc[key], strp, nstr, nextch, sbuf) + } + + index = index + 1 + } + + call sfree (sp) +end + + +# IMFN_PUTKEY -- Put a keyword into the keyword list. + +procedure imfn_putkey (key, strp, nstr, nextch, sbuf) + +char key[ARB] # keyword name (etc.) +pointer strp[ARB] # array of string pointers +int nstr # current number of strings +pointer nextch # next available char in string buffer +pointer sbuf # string buffer + +int ch, ip +errchk syserr + +begin + # Append keyword to the string buffer. + nstr = nstr + 1 + if (nstr > MAX_FIELDS) + call syserr (SYS_IMFNOVFL) + strp[nstr] = nextch + + ip = 1 + ch = key[ip] + + while (ch != '=' && ch != ' ' && ch != EOS) { + Memc[nextch] = ch + nextch = nextch + 1 + if (nextch >= sbuf + SZ_SBUF) + call syserr (SYS_IMFNOVFL) + ip = ip + 1 + ch = key[ip] + } + + Memc[nextch] = EOS + nextch = nextch + 1 +end diff --git a/sys/imio/db/imgstr.x b/sys/imio/db/imgstr.x new file mode 100644 index 00000000..53a77d4c --- /dev/null +++ b/sys/imio/db/imgstr.x @@ -0,0 +1,52 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "idb.h" + +# IMGSTR -- Get an image header parameter of type string. If the named +# parameter is a standard parameter return the value directly, else scan +# the user area for the named parameter and decode the value. A special +# check is required for embedded single quotes as per the FITS standard. + +procedure imgstr (im, key, outstr, maxch) + +pointer im # image descriptor +char key[ARB] # parameter to be returned +char outstr[ARB] # output string to receive parameter value +int maxch + +pointer rp +int ip, op +int idb_getstring(), idb_findrecord(), ctowrd(), strlen() +errchk syserrs + +begin + # Check for a standard header parameter first. + if (idb_getstring (im, key, outstr, maxch) != ERR) + return + + # Find the record. + if (idb_findrecord (im, key, rp) == 0) + call syserrs (SYS_IDBKEYNF, key) + + ip = IDB_STARTVALUE + if (ctowrd (Memc[rp], ip, outstr, maxch) > 0) { + # Check for embedded single quotes which are represented as ''. + repeat { + if (Memc[rp+ip-1] != '\'') + break + call strcat ("'", outstr, maxch) + op = strlen (outstr) + 1 + if (ctowrd (Memc[rp], ip, outstr[op], maxch-op) == 0) + break + } + + # Strip trailing whitespace. + op = strlen (outstr) + while (op > 0 && (IS_WHITE(outstr[op]) || outstr[op] == '\n')) + op = op - 1 + outstr[op+1] = EOS + } else + outstr[1] = EOS +end diff --git a/sys/imio/db/impstr.x b/sys/imio/db/impstr.x new file mode 100644 index 00000000..4f4985cf --- /dev/null +++ b/sys/imio/db/impstr.x @@ -0,0 +1,120 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "idb.h" + +# IMPSTR -- Put an image header parameter of type string. If the named +# parameter is a standard parameter of type other than string, decode the +# string and set the binary value of the parameter. If the parameter is +# a nonstandard one we can do a simple string edit, since user parameters +# are stored in the user area in string form. The datatype of the parameter +# must be preserved by the edit, i.e., parameters of actual datatype string +# must be quoted and left justified and other parameters must be unquoted +# and right justified in the value field. + +procedure impstr (im, key, value) + +pointer im #I image descriptor +char key[ARB] #I parameter to be set +char value[ARB] #I new parameter value + +bool string_valued +int nchars, ch, i +pointer rp, ip, op, sp, val, start, text, cmmt +int idb_putstring(), idb_findrecord(), idb_filstr() +errchk syserrs + +begin + call smark (sp) + call salloc (val, SZ_LINE, TY_CHAR) + call salloc (text, SZ_LINE, TY_CHAR) + call salloc (cmmt, SZ_LINE, TY_CHAR) + + # Filter the value string to remove any undesirable characters. + nchars = idb_filstr (value, Memc[text], SZ_LINE) + + # Check for a standard header parameter first. + if (idb_putstring (im, key, Memc[text]) != ERR) { + call sfree (sp) + return + } + + # Find the record. + if (idb_findrecord (im, key, rp) == 0) + call syserrs (SYS_IDBKEYNF, key) + + # Determine the actual datatype of the parameter. String valued + # parameters will have an apostrophe in the first nonblank column + # of the value field. Skip the value and treat the rest of + # the line as a comment to be preserved. + + string_valued = false + for (ip=IDB_STARTVALUE; ip <= IDB_ENDVALUE; ip=ip+1) { + # Skip leading whitespace. + for (; Memc[rp+ip-1] == ' '; ip=ip+1) + ; + + if (Memc[rp+ip-1] == '\'') { + # Skip string value. + do i = ip, IDB_RECLEN { + ch = Memc[rp+i] + if (ch == '\n') + break + Memc[rp+i] = ' ' + if (ch == '\'') + break + } + + string_valued = true + break + + } else { + # Skip numeric value. + do i = ip, IDB_RECLEN { + ch = Memc[rp+i-1] + if (ch == '\n' || ch == ' ' || ch == '/') + break + Memc[rp+i-1] = ' ' + } + break + } + } + + # Skip whitespace before any comment. + for (ip = i; Memc[rp+ip-1] == ' '; ip=ip+1) + ; + + # Save comment. Include a leading space and add a / if missing. + Memc[cmmt] = ' ' + for (i = 1; Memc[rp+ip-1] != '\n'; ip=ip+1) { + if (i == 1 && Memc[rp+ip-1] != '/') { + Memc[cmmt+i] = '/' + i = i + 1 + } + Memc[cmmt+i] = Memc[rp+ip-1] + Memc[rp+ip-1] = ' ' + i = i + 1 + } + Memc[cmmt+i] = EOS + + # Encode the new value of the parameter. + if (string_valued) { + call sprintf (Memc[val], SZ_LINE, " '%-0.68s%11t'%22t%-0.68s") + call pargstr (Memc[text]) + call pargstr (Memc[cmmt]) + } else { + call sprintf (Memc[val], SZ_LINE, "%21s%-0.68s") + call pargstr (Memc[text]) + call pargstr (Memc[cmmt]) + } + + # Update the parameter value. + op = rp + IDB_STARTVALUE - 1 + start = op + for (ip=val; Memc[ip] != EOS && Memc[op] != '\n'; ip=ip+1) { + Memc[op] = Memc[ip] + op = op + 1 + } + + call sfree (sp) +end diff --git a/sys/imio/db/imputb.x b/sys/imio/db/imputb.x new file mode 100644 index 00000000..a211f464 --- /dev/null +++ b/sys/imio/db/imputb.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPUTB -- Put an image header parameter of type boolean. + +procedure imputb (im, key, bval) + +pointer im # image descriptor +char key[ARB] # parameter to be set +bool bval # parameter value +char sval[2] + +begin + if (bval) + sval[1] = 'T' + else + sval[1] = 'F' + sval[2] = EOS + + call impstr (im, key, sval) +end diff --git a/sys/imio/db/imputd.x b/sys/imio/db/imputd.x new file mode 100644 index 00000000..ccd5339a --- /dev/null +++ b/sys/imio/db/imputd.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMPUTD -- Put an image header parameter of type double. + +procedure imputd (im, key, dval) + +pointer im # image descriptor +char key[ARB] # parameter to be set +double dval # double precision value + +pointer sp, sval +int i, strlen() + +begin + call smark (sp) + call salloc (sval, SZ_FNAME, TY_CHAR) + + # Reduce the precision of the encoded value if necessary to fit in + # the FITS value field. Start with NDIGITS_DP-1 as the precision + # estimate NDIGITS_DP is only approximate, and if we make up half a + # digit of precision the result can be 1.00000000000000001 instead + # of 1.0. + + for (i=NDIGITS_DP-1; i >= NDIGITS_RP; i=i-1) { + call sprintf (Memc[sval], SZ_FNAME, "%0.*g") + call pargi (i) + call pargd (dval) + if (strlen (Memc[sval]) < 20) + break + } + + # Write the new value to the header. + call impstr (im, key, Memc[sval]) + + call sfree (sp) +end diff --git a/sys/imio/db/imputh.x b/sys/imio/db/imputh.x new file mode 100644 index 00000000..39467366 --- /dev/null +++ b/sys/imio/db/imputh.x @@ -0,0 +1,161 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "idb.h" + +define LEN_HISTSTR 70 # length of a history string on a FITS card + +# IMPUTH -- Add a FITS-like history/comment field to the image header. +# Only keywords HISTORY, COMMENT, or " " (eight spaces) are allowed! +# (At least for the present - in the future this routine will probably +# append FITS cards to a distinct FITS-table appearing as a table parameter +# in the generalized image header. Also, since it is not yet decided how +# image history will be handled in the future, there is no guarantee that +# this routine will remain unchanged - it may change or be obsoleted.) + +procedure imputh (im, key, text) + +pointer im #I image descriptor +char key[ARB] #I name of the new parameter +char text[ARB] #I the history string to be added + +pointer sp, keyname, instr, outstr, ua +int fd, max_lenuserarea, curlen, buflen, nchars +int ip, op, in_last_blank, out_last_blank + +bool streq() +int stropen(), strlen(), idb_filstr() +errchk syserrs, stropen, fprintf + +begin + call smark (sp) + call salloc (instr, SZ_LINE, TY_CHAR) + call salloc (keyname, SZ_FNAME, TY_CHAR) + call salloc (outstr, LEN_HISTSTR, TY_CHAR) + + # FITS format requires that the keyword name be upper case. + call strcpy (key, Memc[keyname], SZ_FNAME) + call strupr (Memc[keyname]) + + # Only standard FITS HISTORY keywords are allowed. + if (!(streq(Memc[keyname],"HISTORY") || + streq(Memc[keyname],"COMMENT") || + streq(Memc[keyname]," "))) { + + call eprintf ("IMPUTH: Invalid history keyword `%s' ignored\n") + call pargstr (key) + call sfree (sp) + return + } + + # Open the user area string for appending. 'buflen' is the malloc-ed + # buffer length in struct units; IMU is the struct offset to the user + # area, i.e., the size of that part of the image descriptor preceding + # the user area. If the buffer fills we must allow one extra char for + # the EOS delimiter; since storage for the image descriptor was + # allocated in struct units the storage allocator will not have + # allocated space for the extra EOS char. + + ua = IM_USERAREA(im) + curlen = strlen (Memc[ua]) + buflen = LEN_IMDES + IM_LENHDRMEM(im) + max_lenuserarea = (buflen - IMU) * SZ_STRUCT - 1 + + # If the user area is not empty the last character must be the newline + # record delimiter, else the new record we add will be invalid. + + if (curlen > 0 && Memc[ua+curlen-1] != '\n') + if (curlen >= max_lenuserarea) + call syserrs (SYS_IDBOVFL, key) + else { + Memc[ua+curlen] = '\n' + curlen = curlen + 1 + Memc[ua+curlen] = EOS + } + + # Open a file descriptor on the userarea buffer. + fd = stropen (Memc[ua+curlen], max_lenuserarea-curlen, APPEND) + + # Filter the input string to remove any undesirable characters. + nchars = idb_filstr (text, Memc[instr], SZ_LINE) + + # Append the HISTORY or COMMENT record to the user area. + iferr { + if (nchars <= LEN_HISTSTR ) { + # This is the easy case: the HISTORY string will fit in + # one record. + + call fprintf (fd, "%-8s %s%*t\n") + call pargstr (Memc[keyname]) + call pargstr (Memc[instr]) + call pargi (IDB_LENSTRINGRECORD + 1) + + } else { + # Not the simple case; break up the string into pieces that + # will fit into LEN_HISTSTR, preferably on word boundaries. + + for (ip=1; Memc[instr+ip-1] != EOS; ) { + # If no blanks are found in HISTORY string, make sure + # all of it gets output anyway. + + in_last_blank = ip + LEN_HISTSTR - 1 + out_last_blank = LEN_HISTSTR + + # Copy the string to the output buffer, marking the + # last blank found. + + do op = 1, LEN_HISTSTR { + if (IS_WHITE (Memc[instr+ip-1])) { + in_last_blank = ip + out_last_blank = op + } else if (Memc[instr+ip-1] == EOS) + break + + Memc[outstr+op-1] = Memc[instr+ip-1] + ip = ip + 1 + } + + # The output string is full; close it off properly + # and get ready for the next round (if any). + + Memc[outstr+op-1] = EOS + if (Memc[instr+ip-1] != EOS) { + # Break at last word boundary if in a word. + if (!IS_WHITE (Memc[instr+ip-1])) { + Memc[outstr+out_last_blank] = EOS + ip = in_last_blank + 1 + } + + # Skip leading whitespace on next line. + while (IS_WHITE(Memc[instr+ip-1])) + ip = ip + 1 + } + + # Write out the FITS HISTORY card. + call fprintf (fd, "%-8s %s%*t\n") + call pargstr (Memc[keyname]) + call pargstr (Memc[outstr]) + call pargi (IDB_LENSTRINGRECORD + 1) + } + } + + } then { + # Out of space in the user area. Discard the truncated card + # at the end of the buffer by backing up to the last newline and + # writing an EOS. + + call close (fd) + for (ip=ua+max_lenuserarea-1; ip > ua; ip=ip-1) + if (Memc[ip] == '\n') { + Memc[ip+1] = EOS + break + } + call syserrs (SYS_IDBOVFL, key) + } + + call close (fd) + call sfree (sp) +end diff --git a/sys/imio/db/imputi.x b/sys/imio/db/imputi.x new file mode 100644 index 00000000..8be50d16 --- /dev/null +++ b/sys/imio/db/imputi.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPUTI -- Put an image header parameter of type integer. + +procedure imputi (im, key, ival) + +pointer im # image descriptor +char key[ARB] # parameter to be set +int ival # parameter value +pointer sp, sval + +begin + call smark (sp) + call salloc (sval, SZ_FNAME, TY_CHAR) + + call sprintf (Memc[sval], SZ_FNAME, "%d") + call pargi (ival) + call impstr (im, key, Memc[sval]) + + call sfree (sp) +end diff --git a/sys/imio/db/imputl.x b/sys/imio/db/imputl.x new file mode 100644 index 00000000..3bc0d64c --- /dev/null +++ b/sys/imio/db/imputl.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPUTL -- Put an image header parameter of type long integer. + +procedure imputl (im, key, lval) + +pointer im # image descriptor +char key[ARB] # parameter to be set +long lval # parameter value +pointer sp, sval + +begin + call smark (sp) + call salloc (sval, SZ_FNAME, TY_CHAR) + + call sprintf (Memc[sval], SZ_FNAME, "%d") + call pargl (lval) + call impstr (im, key, Memc[sval]) + + call sfree (sp) +end diff --git a/sys/imio/db/imputr.x b/sys/imio/db/imputr.x new file mode 100644 index 00000000..13a5e0c3 --- /dev/null +++ b/sys/imio/db/imputr.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMPUTR -- Put an image header parameter of type real. + +procedure imputr (im, key, rval) + +pointer im # image descriptor +char key[ARB] # parameter to be set +real rval # parameter value +pointer sp, sval + +begin + call smark (sp) + call salloc (sval, SZ_FNAME, TY_CHAR) + + call sprintf (Memc[sval], SZ_FNAME, "%0.*g") + call pargi (NDIGITS_RP) + call pargr (rval) + call impstr (im, key, Memc[sval]) + + call sfree (sp) +end diff --git a/sys/imio/db/imputs.x b/sys/imio/db/imputs.x new file mode 100644 index 00000000..98fd61d8 --- /dev/null +++ b/sys/imio/db/imputs.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPUTS -- Put an image header parameter of type short integer. + +procedure imputs (im, key, value) + +pointer im # image descriptor +char key[ARB] # parameter to be set +short value # parameter value +pointer sp, sval + +begin + call smark (sp) + call salloc (sval, SZ_FNAME, TY_CHAR) + + call sprintf (Memc[sval], SZ_FNAME, "%d") + call pargs (value) + call impstr (im, key, Memc[sval]) + + call sfree (sp) +end diff --git a/sys/imio/db/imrenf.x b/sys/imio/db/imrenf.x new file mode 100644 index 00000000..3b1bf7a6 --- /dev/null +++ b/sys/imio/db/imrenf.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "idb.h" + +# IMRENF -- Rename a user field keyword. It is an error if the +# named field does not exist. + +procedure imrenf (im, oldkey, newkey) + +pointer im # image descriptor +char oldkey[ARB] # old keyword +char newkey[ARB] # new keyword + +int off +pointer rp, sp, keyname +int idb_kwlookup(), idb_findrecord(), stridxs() +errchk syserrs + +begin + call smark (sp) + call salloc (keyname, SZ_FNAME, TY_CHAR) + + # FITS format requires that the keyword name be upper case. + call strcpy (oldkey, Memc[keyname], IDB_SZFITSKEY) + call strupr (Memc[keyname]) + + # Cannot delete standard header keywords. + if (idb_kwlookup (oldkey) > 0) + call syserrs (SYS_IDBNODEL, oldkey) + + # Verify that the named user field exists. + if (idb_findrecord (im, oldkey, rp) <= 0) + call syserrs (SYS_IDBDELNXKW, oldkey) + + # Rename the keyword. + call sprintf (Memc[keyname], IDB_SZFITSKEY, "%-8.8s") + call pargstr (newkey) + call strupr (Memc[keyname]) + call amovc (Memc[keyname], Memc[rp], 8) + + call sfree (sp) +end diff --git a/sys/imio/db/mkpkg b/sys/imio/db/mkpkg new file mode 100644 index 00000000..2d8888df --- /dev/null +++ b/sys/imio/db/mkpkg @@ -0,0 +1,44 @@ +# Update the image header database interface. + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + idbcard.x idb.h + idbfind.x idb.h + idbfstr.x + idbgstr.x idb.h + idbkwlu.x + idbpstr.x idb.h + imaccf.x + imaddb.x + imaddd.x + imaddf.x idb.h + imaddi.x + imaddl.x + imaddr.x + imadds.x + imastr.x + imdelf.x idb.h + imgetb.x idb.h + imgetc.x + imgetd.x idb.h + imgeti.x + imgetl.x + imgetr.x + imgets.x + imgftype.x idb.h + imgnfn.x idb.h + imgstr.x idb.h + impstr.x idb.h + imputb.x + imputd.x + imputh.x idb.h + imputi.x + imputl.x + imputr.x + imputs.x + imrenf.x idb.h + ; diff --git a/sys/imio/dbc/README b/sys/imio/dbc/README new file mode 100644 index 00000000..4e6a89ac --- /dev/null +++ b/sys/imio/dbc/README @@ -0,0 +1,29 @@ +October 4, 2004 + +These routines represent an extension to the imio header routines manipulation. +Most of them have a new parameter which is the FITS header comment field. +The routine names have changed slighly to avoid collision and to have some +meaning; e.g. the ending 'c' for comment. + +There are a couple of new routines to handle only comments. + +Nelson Zarate + + +imakbc.x:# IMAKBC -- Add a new field to the image header and initialize to the value +imakdc.x:# IMAKDC -- Add a new field to the image header and initialize to the value +imakic.x:# IMAKIC -- Add a new field to the image header and initialize to the value +imaklc.x:# IMAKLC -- Add a new field to the image header and initialize to the value +imakrc.x:# IMAKRC -- Add a new field to the image header and initialize to the value +imaksc.x:# IMAKSC -- Add a new field to the image header and initialize to the value +imastrc.x:# IMASTRC -- Add a new field to the image header and initialize to the value +imgcom.x:# IMGCOM -- Get the comment field for a keyword. +impcom.x:# IMPCOM -- Change the comment field for a keyword. +impkbc.x:# IMPKBC -- Put an image header parameter of type boolean. +impkdc.x:# IMPKDDC -- Put an image header parameter of type double. +impkic.x:# IMPKIC -- Put an image header parameter of type integer. +impklc.x:# IMPKLC -- Put an image header parameter of type long integer. +impkrc.x:# IMPKRC -- Put an image header parameter of type real. +imdrmcom.x:# IMDRMCOM -- Remove the comment field for a keyword. +impksc.x:# IMPKSC -- Put an image header parameter of type short integer. +impstrc.x:# IMPSTRC -- Put an image header parameter of type string. If the named diff --git a/sys/imio/dbc/idbc.h b/sys/imio/dbc/idbc.h new file mode 100644 index 00000000..3c254469 --- /dev/null +++ b/sys/imio/dbc/idbc.h @@ -0,0 +1,27 @@ +# IDB.H -- Image header database interface. In this version of the interface +# the standard image header fields are maintained in binary in a fixed +# structure and the user fields are maintained in FITS format (text) in the +# a string buffer following the binary image header. + +define IDB_RECLEN 80 # length of a FITS record (card) +define IDB_STARTVALUE 10 # first column of value field +define IDB_ENDVALUE 30 # last column of value field +define IDB_LENNUMERICRECORD 80 # length of new numeric records +define IDB_LENSTRINGRECORD 80 # length of new string records +define IDB_SZFITSKEY 8 # max length FITS keyword + +# Standard header keywords accessible via the database interface. + +define I_CTIME 1 +define I_HISTORY 2 +define I_LIMTIME 3 +define I_MAXPIXVAL 4 +define I_MINPIXVAL 5 +define I_MTIME 6 +define I_NAXIS 7 +define I_PIXFILE 8 +define I_PIXTYPE 9 +define I_TITLE 10 + +define BEFORE 1 +define AFTER 2 diff --git a/sys/imio/dbc/imakbc.x b/sys/imio/dbc/imakbc.x new file mode 100644 index 00000000..2871370d --- /dev/null +++ b/sys/imio/dbc/imakbc.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMAKBC -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imakbc (im, key, value, comment) + +pointer im # image descriptor +char key[ARB] # parameter or field value +bool value # new or initial value of parameter +char comment[ARB] # comment + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, "b") + call impkbc (im, key, value, comment) +end diff --git a/sys/imio/dbc/imakbci.x b/sys/imio/dbc/imakbci.x new file mode 100644 index 00000000..3fe64116 --- /dev/null +++ b/sys/imio/dbc/imakbci.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMAKBCI -- Insert a new field to the image header after the given keyword +# and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imakbci (im, key, value, comment, pkey, baf) + +pointer im # image descriptor +char key[ARB] # parameter or field value +bool value # new or initial value of parameter +char comment[ARB] # comment +char pkey[ARB] # Pivot keyword to insert 'key' +int baf # I Insert BEFORE or AFTER + +int imaccf() +errchk imaccf, iminfi + +begin + if (imaccf (im, key) == NO) + call iminfi (im, key, pkey, "b", baf) + call impkbc (im, key, value, comment) +end diff --git a/sys/imio/dbc/imakdc.x b/sys/imio/dbc/imakdc.x new file mode 100644 index 00000000..787c496d --- /dev/null +++ b/sys/imio/dbc/imakdc.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMAKDC -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imakdc (im, key, value, comment) + +pointer im # image descriptor +char key[ARB] # parameter or field value +double value # new or initial value of parameter +char comment[ARB] # comment + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, "d") + call impkdc (im, key, value, comment) +end diff --git a/sys/imio/dbc/imakdci.x b/sys/imio/dbc/imakdci.x new file mode 100644 index 00000000..c63a9a5a --- /dev/null +++ b/sys/imio/dbc/imakdci.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMAKDCI -- Insert a new field to the image header after the given keyword +# and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imakdci (im, key, value, comment, pkey, baf) + +pointer im # image descriptor +char key[ARB] # parameter or field value +double value # new or initial value of parameter +char comment[ARB] # comment +char pkey[ARB] # Pivot keyword to insert 'key' +int baf # I Insert BEFORE or AFTER + +int imaccf() +errchk imaccf, iminfi + +begin + if (imaccf (im, key) == NO) + call iminfi (im, key, pkey, "d", baf) + call impkdc (im, key, value, comment) +end diff --git a/sys/imio/dbc/imakic.x b/sys/imio/dbc/imakic.x new file mode 100644 index 00000000..10594d2a --- /dev/null +++ b/sys/imio/dbc/imakic.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMAKIC -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imakic (im, key, value, comment) + +pointer im # image descriptor +char key[ARB] # parameter or field value +int value # new or initial value of parameter +char comment[ARB] + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, "i") + call impkic (im, key, value, comment) +end diff --git a/sys/imio/dbc/imakici.x b/sys/imio/dbc/imakici.x new file mode 100644 index 00000000..02177184 --- /dev/null +++ b/sys/imio/dbc/imakici.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMAKICI -- Insert a new field to the image header after the given keyword +# and initialize to the value given. It is not an error if the parameter +# already exists. + +procedure imakici (im, key, value, comment, pkey, baf) + +pointer im # image descriptor +char key[ARB] # parameter or field value +int value # new or initial value of parameter +char comment[ARB] +char pkey[ARB] # Pivot keyword to insert 'key' +int baf # I Insert BEFORE or AFTER + +int imaccf() +errchk imaccf, iminfi + +begin + if (imaccf (im, key) == NO) + call iminfi (im, key, pkey, "i", baf) + call impkic (im, key, value, comment) +end diff --git a/sys/imio/dbc/imaklc.x b/sys/imio/dbc/imaklc.x new file mode 100644 index 00000000..3cb323c1 --- /dev/null +++ b/sys/imio/dbc/imaklc.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMAKLC -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imaklc (im, key, value, comment) + +pointer im # image descriptor +char key[ARB] # parameter or field value +long value # new or initial value of parameter +char comment[ARB] + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, "l") + call impklc (im, key, value, comment) +end diff --git a/sys/imio/dbc/imaklci.x b/sys/imio/dbc/imaklci.x new file mode 100644 index 00000000..9b74c82f --- /dev/null +++ b/sys/imio/dbc/imaklci.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMAKLCI -- Insert a new field to the image header after the given keyword +# and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imaklci (im, key, value, comment, pkey, baf) + +pointer im # image descriptor +char key[ARB] # parameter or field value +long value # new or initial value of parameter +char comment[ARB] +char pkey[ARB] # Pivot keyword to insert 'key' +int baf # I Insert BEFORE or AFTER + +int imaccf() +errchk imaccf, iminfi + +begin + if (imaccf (im, key) == NO) + call iminfi (im, key, pkey, "l", baf) + call impklc (im, key, value, comment) +end diff --git a/sys/imio/dbc/imakrc.x b/sys/imio/dbc/imakrc.x new file mode 100644 index 00000000..ff13efdf --- /dev/null +++ b/sys/imio/dbc/imakrc.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMAKRC -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imakrc (im, key, value, comment) + +pointer im # image descriptor +char key[ARB] # parameter or field value +real value # new or initial value of parameter +char comment[ARB] + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, "r") + call impkrc (im, key, value, comment) +end diff --git a/sys/imio/dbc/imakrci.x b/sys/imio/dbc/imakrci.x new file mode 100644 index 00000000..74114d90 --- /dev/null +++ b/sys/imio/dbc/imakrci.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMAKRCI -- Insert a new field to the image header after the given keyword +# and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imakrci (im, key, value, comment, pkey, baf) + +pointer im # image descriptor +char key[ARB] # parameter or field value +real value # new or initial value of parameter +char comment[ARB] +char pkey[ARB] # Pivot keyword to insert 'key' +int baf # I Insert BEFORE or AFTER + +int imaccf() +errchk imaccf, iminfi + +begin + if (imaccf (im, key) == NO) + call iminfi (im, key, pkey, "r", baf) + call impkrc (im, key, value, comment) +end diff --git a/sys/imio/dbc/imaksc.x b/sys/imio/dbc/imaksc.x new file mode 100644 index 00000000..e6f2c4ac --- /dev/null +++ b/sys/imio/dbc/imaksc.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMAKSC -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imaksc (im, key, value, comment) + +pointer im # image descriptor +char key[ARB] # parameter or field value +short value # new or initial value of parameter +char comment[ARB] + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, "s") + call impksc (im, key, value, comment) +end diff --git a/sys/imio/dbc/imaksci.x b/sys/imio/dbc/imaksci.x new file mode 100644 index 00000000..2bed12b0 --- /dev/null +++ b/sys/imio/dbc/imaksci.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMAKSCI -- Insert a new field to the image header after the given keyword +# and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imaksci (im, key, value, comment, pkey, baf) + +pointer im # image descriptor +char key[ARB] # parameter or field value +short value # new or initial value of parameter +char comment[ARB] +char pkey[ARB] # Pivot keyword to insert 'key' +int baf # I Insert BEFORE or AFTER + +int imaccf() +errchk imaccf, iminfi + +begin + if (imaccf (im, key) == NO) + call iminfi (im, key, pkey, "s", baf) + call impksc (im, key, value, comment) +end diff --git a/sys/imio/dbc/imastrc.x b/sys/imio/dbc/imastrc.x new file mode 100644 index 00000000..4620db46 --- /dev/null +++ b/sys/imio/dbc/imastrc.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMASTRC -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imastrc (im, key, value, comment) + +pointer im # image descriptor +char key[ARB] # parameter or field value +char value[ARB] # new or initial value of parameter +char comment[ARB] # + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, "c") + call impstrc (im, key, value, comment) +end diff --git a/sys/imio/dbc/imastrci.x b/sys/imio/dbc/imastrci.x new file mode 100644 index 00000000..f5154906 --- /dev/null +++ b/sys/imio/dbc/imastrci.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMASTRCI -- Insert a new field to the image header after the given keyword +# and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imastrci (im, key, value, comment, pkey, baf) + +pointer im # image descriptor +char key[ARB] # parameter or field value +char value[ARB] # new or initial value of parameter +char comment[ARB] # +char pkey[ARB] # Pivot keyword to insert 'key' +int baf # I Insert BEFORE or AFTER + +int imaccf() +errchk imaccf, iminfi + +begin + if (imaccf (im, key) == NO) + call iminfi (im, key, pkey, "c", baf) + call impstrc (im, key, value, comment) +end diff --git a/sys/imio/dbc/imdrmcom.x b/sys/imio/dbc/imdrmcom.x new file mode 100644 index 00000000..4a10f2df --- /dev/null +++ b/sys/imio/dbc/imdrmcom.x @@ -0,0 +1,96 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "idbc.h" + +# IMDRMCOM -- Remove the comment field for a keyword. + +procedure imdrmcom (im, key) + +pointer im #I image descriptor +char key[ARB] #I parameter to be set + +bool string_valued +int ch, i, ti, j, n +pointer rp, ip, op, sp, val, start, text, cmmt +int idb_findrecord() +errchk syserrs + +begin + call smark (sp) + call salloc (val, SZ_LINE, TY_CHAR) + call salloc (text, SZ_LINE, TY_CHAR) + call salloc (cmmt, SZ_LINE, TY_CHAR) + + # Find the record. + if (idb_findrecord (im, key, rp) == 0) + call syserrs (SYS_IDBKEYNF, key) + + for (i=0; i +include +include "idbc.h" + +# IMGCOM -- Get the comment field for a keyword. + +procedure imgcom (im, key, comment) + +pointer im #I image descriptor +char key[ARB] #I parameter to be set +char comment[ARB] #O comment string + +bool string_valued +int ch, i, n, j, ic, op +pointer rp, ip, sp, buf +int idb_findrecord(), ctowrd(), stridx(), idb_getstring() +errchk syserrs + +define end_ 91 +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + # Special fields do not have comment. + if (key[1] == 'i' && key[2] == '_') { + comment[1] = EOS + return + } + + # Find the record. + if (idb_findrecord (im, key, rp) == 0) + call syserrs (SYS_IDBKEYNF, key) + + ip = IDB_STARTVALUE + if (ctowrd (Memc[rp], ip, Memc[buf], SZ_LINE) <= 0) { + comment[1] = EOS + goto end_ + } + + # Look for '/' + while (ip < IDB_RECLEN && (Memc[rp+ip] != '/')) + ip = ip + 1 + if (ip == IDB_RECLEN) { + comment[1] = EOS + goto end_ + } + op = rp+ip+1 + while (op < IDB_RECLEN+rp && (IS_WHITE(Memc[op]) || Memc[op] == '\n')) + op = op + 1 + + # Copy comment section + for (i = 1; Memc[op] != '\n' && op < IDB_RECLEN+rp; op=op+1) { + comment[i] = Memc[op] + i = i + 1 + } + # Trim + i = i - 1 + while (i >= 1 && IS_WHITE(comment[i])) + i = i - 1 + + comment[i+1] = EOS +end_ + call sfree (sp) +end diff --git a/sys/imio/dbc/iminfi.x b/sys/imio/dbc/iminfi.x new file mode 100644 index 00000000..0ddfb540 --- /dev/null +++ b/sys/imio/dbc/iminfi.x @@ -0,0 +1,111 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "idbc.h" + +# IMADDFI -- Insert a user field in the image header after the specified +# keyword. It is an error if the named field already exists. + +#procedure imaddfi (im, key, pkey, datatype, baf) +procedure iminfi (im, key, pkey, datatype, baf) + +pointer im #I image descriptor +char key[ARB] #I name of the new parameter +char pkey[ARB] #I 'key' will be inserted bef/after pkey +char datatype[ARB] #I string permits generalization to domains +int baf # I Insert BEFORE or AFTER + +pointer rp, sp, keyname, ua, ip +int fd, max_lenuserarea, curlen, buflen, nchars, piv +int idb_kwlookup(), idb_findrecord() +int strlen(), idb_filstr(), nowhite() +char card[IDB_RECLEN+1] +errchk syserrs, sprintf, pargstr, pargi + +begin + call smark (sp) + call salloc (keyname, SZ_FNAME, TY_CHAR) + + nchars = idb_filstr (key, Memc[keyname], IDB_SZFITSKEY) + nchars = nowhite (Memc[keyname], Memc[keyname], IDB_SZFITSKEY) + call strupr (Memc[keyname]) + + # Check for a redefinition. + if ((idb_kwlookup (key) > 0) || (idb_findrecord (im, key, rp) > 0)) + call syserrs (SYS_IDBREDEF, key) + + # Open the user area string for appending. 'buflen' is the malloc-ed + # buffer length in struct units; IMU is the struct offset to the user + # area, i.e., the size of that part of the image descriptor preceding + # the user area. + + ua = IM_USERAREA(im) + curlen = strlen (Memc[ua]) + buflen = LEN_IMDES + IM_LENHDRMEM(im) + max_lenuserarea = (buflen - IMU) * SZ_STRUCT - 1 + + if (curlen+81 >= max_lenuserarea) { + IM_HDRLEN(im) = LEN_IMHDR + + (curlen + 10*36*81 + SZ_STRUCT-1) / SZ_STRUCT + IM_LENHDRMEM(im) = IM_HDRLEN(im) + (SZ_UAPAD / SZ_STRUCT) + call realloc (im, IM_LENHDRMEM(im) + LEN_IMDES, TY_STRUCT) + buflen = LEN_IMDES + IM_LENHDRMEM(im) + max_lenuserarea = (buflen - IMU) * SZ_STRUCT - 1 + } + + # If the user area is not empty the last character must be the newline + # record delimiter, else the new record we add will be invalid. + + if (curlen > 0 && Memc[ua+curlen-1] != '\n') + if (curlen >= max_lenuserarea) { + call syserrs (SYS_IDBOVFL, key) + } else { + Memc[ua+curlen] = '\n' + curlen = curlen + 1 + Memc[ua+curlen] = EOS + } + + # Find keyw_after + if (idb_findrecord (im, pkey, rp) == 0) { + # Keyw not found. Append the new keyword. + rp = ua+curlen + baf = BEFORE + } else { + # Shift cards after pivot or before pivot + if (baf == AFTER) + piv = rp + else + piv = rp - IDB_RECLEN - 1 + for (ip= ua+curlen-IDB_RECLEN-1; ip>=piv; ip=ip-IDB_RECLEN-1) { + call amovc (Memc[ip], Memc[ip+IDB_RECLEN+1], IDB_RECLEN) + } + } + Memc[ua+curlen+IDB_RECLEN]='\n' + Memc[ua+curlen+IDB_RECLEN+1]=EOS + + # Form a card with keyword name and placeholder for value. + call sprintf (card, IDB_RECLEN+10, "%-8s= %s%*t\n") + call pargstr (Memc[keyname]) + if (datatype[1] == 'c') { + call pargstr ("' '") + call pargi (IDB_LENSTRINGRECORD + 1) + } else { + call pargstr ("") + call pargi (IDB_LENNUMERICRECORD + 1) + } + + # Replace keyword at the position rp+81. + if (baf == AFTER) + call amovc (card, Memc[rp+IDB_RECLEN+1], IDB_RECLEN) + else + call amovc (card, Memc[rp], IDB_RECLEN) + +#for (ip=1; ip<5; ip=ip+1) { +#call eprintf("<%40.40s>\n") +# call pargstr(Memc[rp-(2-ip)*(IDB_RECLEN+1)]) +#} + call sfree (sp) +end diff --git a/sys/imio/dbc/impcom.x b/sys/imio/dbc/impcom.x new file mode 100644 index 00000000..b110536e --- /dev/null +++ b/sys/imio/dbc/impcom.x @@ -0,0 +1,97 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "idbc.h" + +# IMPCOM -- Change the comment field for a keyword. + +procedure impcom (im, key, comment) + +pointer im #I image descriptor +char key[ARB] #I parameter to be set +char comment[ARB] #I comment string + +bool string_valued +int ch, i, ti, j +pointer rp, ip, op, sp, val, start, text, cmmt +int idb_findrecord() +errchk syserrs + +begin + call smark (sp) + call salloc (val, SZ_LINE, TY_CHAR) + call salloc (text, SZ_LINE, TY_CHAR) + call salloc (cmmt, SZ_LINE, TY_CHAR) + + # Find the record. + if (idb_findrecord (im, key, rp) == 0) + call syserrs (SYS_IDBKEYNF, key) + + # Determine the actual datatype of the parameter. String valued + # parameters will have an apostrophe in the first nonblank column + # of the value field. + + string_valued = false + ti = text + for (ip=IDB_STARTVALUE; ip <= IDB_ENDVALUE; ip=ip+1) { + # Skip leading whitespace. + for (; Memc[rp+ip-1] == ' '; ip=ip+1) { + Memc[ti] = Memc[rp+ip-1] + ti = ti + 1 + } + if (Memc[rp+ip-1] == '\'') { + # Get string value. + Memc[ti] = Memc[rp+ip-1] + ti = ti + 1 + do i = ip, IDB_RECLEN { + ch = Memc[rp+i] + Memc[ti] = ch + ti = ti + 1 + if (ch == '\n') + break + if (ch == '\'') + break + } + do j = i, IDB_ENDVALUE-2 { + Memc[ti] = ' ' ; ti=ti+1 + } + break + + } else { + # Skip numeric value. + do i = ip, IDB_RECLEN { + ch = Memc[rp+i-1] + Memc[ti] = ch + ti = ti + 1 + if (ch == '\n' || ch == ' ' || ch == '/') + break + } + if (ch == ' ') + ti = ti - 1 + do j = i, IDB_ENDVALUE { + Memc[ti] = ' ' ; ti=ti+1 + } + break + } + } + Memc[ti]=EOS + if (comment[1] != EOS) { + call strcat (" / ", Memc[ti], SZ_LINE) + for (i=1; comment[i] == ' '; i=i+1) + ; + call strcat (comment[i], Memc[ti], SZ_LINE) + } else { + do j = i, IDB_RECLEN { + Memc[ti] = ' ' ; ti=ti+1 + } + } + # Update the parameter value. + op = rp + IDB_STARTVALUE + ti-text - 1 + start = op + for (ip=ti; Memc[ip] != EOS && Memc[op] != '\n'; ip=ip+1) { + Memc[op] = Memc[ip] + op = op + 1 + } + + call sfree (sp) +end diff --git a/sys/imio/dbc/impkbc.x b/sys/imio/dbc/impkbc.x new file mode 100644 index 00000000..fb28eacd --- /dev/null +++ b/sys/imio/dbc/impkbc.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPKBC -- Put an image header parameter of type boolean. + +procedure impkbc (im, key, bval, comment) + +pointer im # image descriptor +char key[ARB] # parameter to be set +bool bval # parameter value +char comment[ARB] # +char sval[2] + +begin + if (bval) + sval[1] = 'T' + else + sval[1] = 'F' + sval[2] = EOS + + call impstrc (im, key, sval, comment) +end diff --git a/sys/imio/dbc/impkdc.x b/sys/imio/dbc/impkdc.x new file mode 100644 index 00000000..6eb671f3 --- /dev/null +++ b/sys/imio/dbc/impkdc.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMPKDDC -- Put an image header parameter of type double. + +procedure impkdc (im, key, dval, comment) + +pointer im # image descriptor +char key[ARB] # parameter to be set +double dval # double precision value +char comment[ARB] # + +pointer sp, sval +int i, strlen() + +begin + call smark (sp) + call salloc (sval, SZ_FNAME, TY_CHAR) + + # Reduce the precision of the encoded value if necessary to fit in + # the FITS value field. Start with NDIGITS_DP-1 as the precision + # estimate NDIGITS_DP is only approximate, and if we make up half a + # digit of precision the result can be 1.00000000000000001 instead + # of 1.0. + + for (i=NDIGITS_DP-1; i >= NDIGITS_RP; i=i-1) { + call sprintf (Memc[sval], SZ_FNAME, "%0.*g") + call pargi (i) + call pargd (dval) + if (strlen (Memc[sval]) < 20) + break + } + + # Write the new value to the header. + call impstrc (im, key, Memc[sval], comment) + + call sfree (sp) +end diff --git a/sys/imio/dbc/impkic.x b/sys/imio/dbc/impkic.x new file mode 100644 index 00000000..3acb0fbd --- /dev/null +++ b/sys/imio/dbc/impkic.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPKIC -- Put an image header parameter of type integer. + +procedure impkic (im, key, ival, comment) + +pointer im # image descriptor +char key[ARB] # parameter to be set +int ival # parameter value +char comment[ARB] # +pointer sp, sval + +begin + call smark (sp) + call salloc (sval, SZ_FNAME, TY_CHAR) + + call sprintf (Memc[sval], SZ_FNAME, "%d") + call pargi (ival) + call impstrc (im, key, Memc[sval], comment) + + call sfree (sp) +end diff --git a/sys/imio/dbc/impklc.x b/sys/imio/dbc/impklc.x new file mode 100644 index 00000000..7ef227ff --- /dev/null +++ b/sys/imio/dbc/impklc.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPKLC -- Put an image header parameter of type long integer. + +procedure impklc (im, key, lval, comment) + +pointer im # image descriptor +char key[ARB] # parameter to be set +long lval # parameter value +char comment[ARB] # +pointer sp, sval + +begin + call smark (sp) + call salloc (sval, SZ_FNAME, TY_CHAR) + + call sprintf (Memc[sval], SZ_FNAME, "%d") + call pargl (lval) + call impstrc (im, key, Memc[sval], comment) + + call sfree (sp) +end diff --git a/sys/imio/dbc/impkrc.x b/sys/imio/dbc/impkrc.x new file mode 100644 index 00000000..1f1459dd --- /dev/null +++ b/sys/imio/dbc/impkrc.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMPKRC -- Put an image header parameter of type real. + +procedure impkrc (im, key, rval, comment) + +pointer im # image descriptor +char key[ARB] # parameter to be set +real rval # parameter value +char comment[ARB] # +pointer sp, sval + +begin + call smark (sp) + call salloc (sval, SZ_FNAME, TY_CHAR) + + call sprintf (Memc[sval], SZ_FNAME, "%0.*g") + call pargi (NDIGITS_RP) + call pargr (rval) + call impstrc (im, key, Memc[sval], comment) + + call sfree (sp) +end diff --git a/sys/imio/dbc/impksc.x b/sys/imio/dbc/impksc.x new file mode 100644 index 00000000..0a74d0f0 --- /dev/null +++ b/sys/imio/dbc/impksc.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPKSC -- Put an image header parameter of type short integer. + +procedure impksc (im, key, value, comment) + +pointer im # image descriptor +char key[ARB] # parameter to be set +short value # parameter value +char comment[ARB] # +pointer sp, sval + +begin + call smark (sp) + call salloc (sval, SZ_FNAME, TY_CHAR) + + call sprintf (Memc[sval], SZ_FNAME, "%d") + call pargs (value) + call impstrc (im, key, Memc[sval], comment) + + call sfree (sp) +end diff --git a/sys/imio/dbc/impstrc.x b/sys/imio/dbc/impstrc.x new file mode 100644 index 00000000..0a11782e --- /dev/null +++ b/sys/imio/dbc/impstrc.x @@ -0,0 +1,117 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "idbc.h" + +# IMPSTRC -- Put an image header parameter of type string. If the named +# parameter is a standard parameter of type other than string, decode the +# string and set the binary value of the parameter. If the parameter is +# a nonstandard one we can do a simple string edit, since user parameters +# are stored in the user area in string form. The datatype of the parameter +# must be preserved by the edit, i.e., parameters of actual datatype string +# must be quoted and left justified and other parameters must be unquoted +# and right justified in the value field. + +procedure impstrc (im, key, value, comment) + +pointer im #I image descriptor +char key[ARB] #I parameter to be set +char value[ARB] #I new parameter value +char comment[ARB] #I comment string + +bool string_valued +int nchars, ch, i +pointer rp, ip, op, sp, val, start, text, cmmt, slen +int idb_putstring(), idb_findrecord(), idb_filstr(), strlen() +errchk syserrs + +begin + call smark (sp) + call salloc (val, SZ_LINE, TY_CHAR) + call salloc (text, SZ_LINE, TY_CHAR) + call salloc (cmmt, SZ_LINE, TY_CHAR) + + # Filter the value string to remove any undesirable characters. + nchars = idb_filstr (value, Memc[text], SZ_LINE) + + # Check for a standard header parameter first. + if (idb_putstring (im, key, Memc[text]) != ERR) { + call sfree (sp) + return + } + + # Find the record. + if (idb_findrecord (im, key, rp) == 0) + call syserrs (SYS_IDBKEYNF, key) + + # Determine the actual datatype of the parameter. String valued + # parameters will have an apostrophe in the first nonblank column + # of the value field. Skip the value and treat the rest of + # the line as a comment to be preserved. + + string_valued = false + for (ip=IDB_STARTVALUE; ip <= IDB_ENDVALUE; ip=ip+1) { + # Skip leading whitespace. + for (; Memc[rp+ip-1] == ' '; ip=ip+1) + ; + + if (Memc[rp+ip-1] == '\'') { + # Skip string value. + do i = ip, IDB_RECLEN { + ch = Memc[rp+i] + if (ch == '\n') + break + Memc[rp+i] = ' ' + if (ch == '\'') + break + } + + string_valued = true + break + + } else { + # Skip numeric value. + do i = ip, IDB_RECLEN { + ch = Memc[rp+i-1] + if (ch == '\n' || ch == ' ' || ch == '/') + break + Memc[rp+i-1] = ' ' + } + break + } + } + + # Skip whitespace before any comment. + for (ip = i; Memc[rp+ip-1] == ' '; ip=ip+1) + ; + + call strcpy (" / ", Memc[cmmt], IDB_RECLEN) + call strcat (comment, Memc[cmmt], IDB_RECLEN) + + # Put enough blanks to erase the old comment. + slen = strlen(Memc[cmmt]) + for (i=slen+1; i<=71-slen; i=i+1) + Memc[cmmt+i-1] = ' ' + Memc[cmmt+i-1] = EOS + + # Encode the new value of the parameter. + if (string_valued) { + call sprintf (Memc[val], SZ_LINE, " '%-0.68s%11t'%22t%-0.68s") + call pargstr (Memc[text]) + call pargstr (Memc[cmmt]) + } else { + call sprintf (Memc[val], SZ_LINE, "%21s%-0.68s") + call pargstr (Memc[text]) + call pargstr (Memc[cmmt]) + } + + # Update the parameter value. + op = rp + IDB_STARTVALUE - 1 + start = op + for (ip=val; Memc[ip] != EOS && Memc[op] != '\n'; ip=ip+1) { + Memc[op] = Memc[ip] + op = op + 1 + } + + call sfree (sp) +end diff --git a/sys/imio/dbc/imputextf.x b/sys/imio/dbc/imputextf.x new file mode 100644 index 00000000..151f13e4 --- /dev/null +++ b/sys/imio/dbc/imputextf.x @@ -0,0 +1,185 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "idbc.h" + +define LEN_HISTSTR 71 # length of a history string on a FITS card +define CLEN 81 + +# IMPUTXTF -- Insert a text file in the user area with HISTORY card. +# The file cannot have control characters in it; only the FITS standard +# character set is supported. The text is broken in records long enough +# to fit words; i.e. it tries not to split words. The file can have +# imbedded tabs and they will be expanded. + +procedure imputextf (im, file, pkey, baf) + +pointer im #I image descriptor +char file[ARB] #I the text file to be inserted and appended +char pkey[ARB] #I Pivot keyword to insert 'key' +int baf #I Insert BEFORE or AFTER + +pointer ua, rp, piv, ip, op +int max_lenuserarea, curlen, buflen, jump, nlines +int old_curlen, k, nshift +char blk + +int strlen(), idb_findrecord() +errchk syserrs + +begin + # FITS format requires that the keyword name be upper case. + + ua = IM_USERAREA(im) + curlen = strlen (Memc[ua]) + buflen = LEN_IMDES + IM_LENHDRMEM(im) + max_lenuserarea = (buflen - IMU) * SZ_STRUCT - 1 + + # Determine the number of lines before inserting into the UA + call imrartxt (ua, file, nlines, NO) + + old_curlen=curlen + curlen = curlen + nlines*CLEN + if (curlen+81 >= max_lenuserarea) { + IM_HDRLEN(im) = LEN_IMHDR + + (curlen + 10*36*CLEN + SZ_STRUCT-1) / SZ_STRUCT + IM_LENHDRMEM(im) = IM_HDRLEN(im) + (SZ_UAPAD / SZ_STRUCT) + call realloc (im, IM_LENHDRMEM(im) + LEN_IMDES, TY_STRUCT) + buflen = LEN_IMDES + IM_LENHDRMEM(im) + max_lenuserarea = (buflen - IMU) * SZ_STRUCT - 1 + ua = IM_USERAREA(im) + } + + blk=' ' + # Find pivot keyword + if (idb_findrecord (im, pkey, rp) == 0) { + # Keyw not found. Append the new keywords. + piv = ua + old_curlen + } else { + # Shift cards after or before pivot. + if (baf == AFTER) + piv = rp + CLEN + else + piv = rp + + jump=nlines*CLEN + + # Shift cards down from the pivot point. + nshift = (ua+old_curlen - piv)/CLEN + ip = ua + old_curlen + do k = 1, nshift { + ip = ip - CLEN + op = jump + ip + call amovc (Memc[ip], Memc[op], CLEN) + } + } + + # Append the HISTORY records to the user area. + call imrartxt (piv, file, nlines, YES) + +end + + +# IMRARTXT -- Internal routines to count the number of lines transfered to the +# UA as HISTORY records. + +procedure imrartxt (piv, fname, nlines, insert) + +pointer piv #I UA address to start inserting kw +char fname[ARB] +int nlines +int insert + +char line[IDB_RECLEN+1], blk, lf +pointer sp, ln, buf, urp +int ip, op, fd, in_last_blank, out_last_blank, blen, len, w, k +int save_ip +int open(), getline(), strlen() + +begin + call smark(sp) + call salloc (ln, SZ_LINE, TY_CHAR) + call salloc (buf, SZ_LINE, TY_CHAR) + + fd = open(fname, READ_ONLY, TEXT_FILE) + nlines= 0 + blk=' ' + lf='\12' + call strcpy ("HISTORY ", Memc[buf], 9) + Memc[buf+IDB_LENSTRINGRECORD]='\n' + Memc[buf+IDB_LENSTRINGRECORD+1]=EOS + urp = piv + while(getline(fd, Memc[ln]) != EOF) { + for (ip=1; Memc[ln+ip-1] != EOS; ) { + # If no blanks are found in HISTORY string, make sure + # all of it gets output anyway. + + in_last_blank = ip + LEN_HISTSTR - 1 + out_last_blank = LEN_HISTSTR + + # Copy the string to the output buffer, marking the + # last blank found. + + for (op=1; op <= LEN_HISTSTR; op=op+1) { + if (Memc[ln+ip-1] == lf) { + ip=ip+1 + } + if (IS_WHITE (Memc[ln+ip-1])) { + # Detab input text. + if (Memc[ln+ip-1] == '\t') { + if(ip-save_ip == 1) + w=8 + else + w=9-op+(op/9)*8 + for(k=0;k +include +include +include +include "idbc.h" + +# IMPHIS -- Insert a user field in the image header after the specified +# keyword. It is an error if the named field already exists. + +procedure imphis (im, key, text, pkey, baf) + +pointer im #I image descriptor +char key[ARB] #I name of the new parameter +char text[ARB] #I the history string to be added +char pkey[ARB] #I 'key' will be inserted bef/after pkey +int baf # I Insert BEFORE or AFTER + +pointer rp, sp, keyname, ua, ip, instr +int max_lenuserarea, curlen, buflen, nchars, piv +int idb_findrecord() +bool streq() +int strlen(), idb_filstr(), nowhite() +char card[IDB_RECLEN+1] +errchk syserrs, sprintf, pargstr, pargi + +begin + call smark (sp) + call salloc (keyname, SZ_FNAME, TY_CHAR) + call salloc (instr, SZ_LINE, TY_CHAR) + + nchars = idb_filstr (key, Memc[keyname], IDB_SZFITSKEY) + nchars = nowhite (Memc[keyname], Memc[keyname], IDB_SZFITSKEY) + call strupr (Memc[keyname]) + + # Only standard FITS HISTORY keywords are allowed. + if (!(streq(Memc[keyname],"HISTORY") || + streq(Memc[keyname],"COMMENT") || + streq(Memc[keyname],"ADD_BLAN"))) { + call sfree (sp) + return + } + + if (streq(Memc[keyname],"ADD_BLAN")) { + call strcpy (" ", Memc[keyname], SZ_FNAME) + } + + # Open the user area string for appending. 'buflen' is the malloc-ed + # buffer length in struct units; IMU is the struct offset to the user + # area, i.e., the size of that part of the image descriptor preceding + # the user area. + + ua = IM_USERAREA(im) + curlen = strlen (Memc[ua]) + buflen = LEN_IMDES + IM_LENHDRMEM(im) + max_lenuserarea = (buflen - IMU) * SZ_STRUCT - 1 + + if (curlen+81 >= max_lenuserarea) { + IM_HDRLEN(im) = LEN_IMHDR + + (curlen + 10*36*81 + SZ_STRUCT-1) / SZ_STRUCT + IM_LENHDRMEM(im) = IM_HDRLEN(im) + (SZ_UAPAD / SZ_STRUCT) + call realloc (im, IM_LENHDRMEM(im) + LEN_IMDES, TY_STRUCT) + buflen = LEN_IMDES + IM_LENHDRMEM(im) + max_lenuserarea = (buflen - IMU) * SZ_STRUCT - 1 + } + + # If the user area is not empty the last character must be the newline + # record delimiter, else the new record we add will be invalid. + + if (curlen > 0 && Memc[ua+curlen-1] != '\n') + if (curlen >= max_lenuserarea) { + call syserrs (SYS_IDBOVFL, key) + } else { + Memc[ua+curlen] = '\n' + curlen = curlen + 1 + Memc[ua+curlen] = EOS + } + + # Find keyw_after + if (idb_findrecord (im, pkey, rp) == 0) { + # Keyw not found. Append the new keyword. + rp = ua+curlen + baf = BEFORE + } else { + # Shift cards after pivot or before pivot + if (baf == AFTER) + piv = rp + else + piv = rp - IDB_RECLEN - 1 + for (ip= ua+curlen-IDB_RECLEN-1; ip>=piv; ip=ip-IDB_RECLEN-1) { + call amovc (Memc[ip], Memc[ip+IDB_RECLEN+1], IDB_RECLEN) + } + } + Memc[ua+curlen+IDB_RECLEN]='\n' + Memc[ua+curlen+IDB_RECLEN+1]=EOS + + # Filter the input string to remove any undesirable characters. + nchars = idb_filstr (text, Memc[instr], SZ_LINE) + + # Form a card with keyword name and placeholder for value. + call sprintf (card, IDB_RECLEN+10, "%-8s %-71s\n") + call pargstr (Memc[keyname]) + call pargstr (Memc[instr]) + + # Replace keyword at the position rp+81. + if (baf == AFTER) + call amovc (card, Memc[rp+IDB_RECLEN+1], IDB_RECLEN) + else + call amovc (card, Memc[rp], IDB_RECLEN) + + call sfree (sp) +end diff --git a/sys/imio/dbc/mkpkg b/sys/imio/dbc/mkpkg new file mode 100644 index 00000000..1997f6b6 --- /dev/null +++ b/sys/imio/dbc/mkpkg @@ -0,0 +1,36 @@ +# Update the image header database interface. + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + imakbc.x + imakbci.x + imakdc.x + imakdci.x + imakic.x + imakici.x + imaklc.x + imaklci.x + imakrc.x + imakrci.x + imaksc.x + imaksci.x + imastrc.x + imastrci.x + imgcom.x idbc.h + iminfi.x idbc.h + impcom.x idbc.h + impkbc.x + impkdc.x + impkic.x + impklc.x + impkrc.x + impksc.x + imdrmcom.x idbc.h + impstrc.x idbc.h + imputextf.x idbc.h + imputhi.x idbc.h + ; diff --git a/sys/imio/doc/IMH.hlp b/sys/imio/doc/IMH.hlp new file mode 100644 index 00000000..0599843b --- /dev/null +++ b/sys/imio/doc/IMH.hlp @@ -0,0 +1,219 @@ +.help imio Mar86 "Image I/O Modifications" +.ce +\fBImage I/O Modifications to Support Multiple Data Formats\fR +.ce +Doug Tody +.ce +March 16, 1986 + +.nh +Introduction + + The primary purpose of this revision of IMIO was to add support for +multiple disk data formats. This was done by defining a new interface +called IMH, which hides the details of how images are stored on disk from +the IMIO code. IMIO is concerned only with image i/o based on an internal +image descriptor. IMIO calls IMH to perform all imagefile management +operations, but accesses the pixel data directly using the FIO interface. +The IMH interface initially supports only the old IRAF and SDAS image formats, +but may be extended to support other formats in the future if necessary. +The IMH interface should be reusable in the future when IMIO is layered +upon DBIO. + +A secondary purpose of this revision was to make several minor enhancements +to IMIO to better support groups of images. The image template syntax +has been extended to provide a special selection syntax for specifying the +subset of the images in a group or set of groups to be operated upon. +Minor changes were made to the filenames of the files used to store IRAF +format images to make identification of the header and pixel files easier. +The image database interface (IDB) has been extended to permit the storage +of one dimensional arrays in the image header. IMIO was modified to use the +static file driver rather than the regular binary file driver to access +pixel data. + +.nh +Image Templates +.nh 2 +Image Template Syntax + + An image template is an expression used to specify the set or group of +images to be operated upon. The current image template syntax is upwards +compatible with the planned DBIO record select/project syntax. The full +syntax is as follows. + + images [,images ...] + +where \fIimages\fR is an expression built up from some combination of the +following constructs: + +.nf + @listfile take strings from a listfile + pattern expand pattern against database + str // str concatenate strings + {select} select elements from a set + [section] append image section +.fi + + +These elements may appear in any order, although not all orderings make +sense. The \fIpattern\fR string may contain any of the standard pattern +matching characters, but the pattern matching meta-characters {} (ignore +case) and [] (character class) must be escaped to avoid interpretation as +the subset selection and image section operators. An \fIimages\fR string +may contain at most one list construct, i.e., listfile reference, pattern, +or selection set. The \fIselect\fR expression is limited to a range list +at present. The range list syntax uses the : range syntax, i.e., +"from[:to[:by]]". Some examples are given below. None of templates shown +in these examples need be quoted if entered in the CL command mode. + + +.nf + pix one image + pix.0013 one image + @pics list of images + pix[*,-*] one image section + @pics[*,-*] list of image sections + pix.* all pix.whatever images in cwd + pix.*//.flat same, but append ".flat" to image name + pix.*//.flat[*,5] same, but append image section too + pix{1,4,9:21} pix.0001, pix.0004, and 9 through 21 + pix{1,4,9:21}[1:10,5] same, but append section to each one +.fi + + +Note that \fIselect\fR expressions are expanded without checking to see if the +named images actually exist. Image names are formed by concatenating the +image number encoded as a four digit string, padding with zeroes at the left +as in the examples. + +.nh 2 +Image Template Procedures + + The image template package (IMT) is an existing package. The calling +sequences are identical to those of the FNT (FIO filename template) package +and have not been changed in this release of the package. Extensive changes +have however been made internally, and the new package has been installed +in IMIO. The old package has been removed from the XTOOLS library. To use +the new version of the package, all one need do is relink. + + +.ks +.nf + list = imtopen (template) + nimages = imtlen (list) + imtrew (list) + nchars|EOF = imtgetim (list, fname, maxch) + imtclose (list) +.fi +.ke + + +An image template is expanded into a list of image names or image sections +with \fBimtopen\fR. The list is not globally sorted, however sublists +generated by pattern matching are sorted before appending the sublist to +the final list. The number of images or image sections in a list is given by +\fBimtlen\fR. Images are read sequentially from the list with \fBimtgetim\fR, +which returns EOF when the end of the list is reached. The list may be +rewound with \fBimtrew\fR. An image template list should be closed with +\fBimtclose\fR to return the buffers used to store the list and its +descriptor. + +.nh +The Image Header Access Interface (IMH) + + The image header access interface (IMH) is a new interface in this release +of IMIO. The purposes of the IMH interface are to hide knowledge of how images +are stored on disk from the rest of the system, and to make it possible to +support multiple image storage formats. IMIO is not aware that there are +multiple image storage formats. When called to open an existing image, +IMH determines the image format and calls the appropriate lower level access +procedure to read the image header. A standard set of IMH callable interface +procedures are required for each supported storage format. + +The IMH package is intended as an internal IMIO package and should not normally +be called by packages other than IMIO. + + +.ks +.nf + im = imh_open (image, acmode, o_im) # open/create header + imh_opix (im, acmode) # open/create pixels + imh_update (im) # update header + imh_close (im) # close image + + y/n = imh_access (image, type) # test if image exists + imh_delete (image) # delete an image + imh_rename (oldname, newname) # rename an image + imh_copy (oldname, newname) # copy an image +.fi +.ke + + +The \fIimh_open\fR procedure will open an existing image, create a new +image, or make a new copy of an existing image (preserving the header +of the old image but not the pixels). A pointer to an IMIO binary image +descriptor is returned; when opening an existing image, the primary +function of \fIimh_open\fR is to map the disk image header, stored in +whatever format, into the IMIO fixed format binary descriptor. + +The \fIimh_opix\fR procedure must be called after the header has been opened +before any pixel i/o can be done to the image. In the case of a new image +the size attributes of the new image are not fixed until \fIimh_opix\fR is +called (giving the high level code time to set the size parameters in the +image descriptor). It is not necessary to call \fIimh_opix\fR if only the +header of an existing image is to be accessed. + +The \fIimh_access\fR procedure is provided to test if the named image +exists (no test is made to determine if the image is also accessible). +An integer code identifying the storage format of the image, e.g., old +IRAF or SDAS, is returned in the \fItype\fR argument. Currently, the type +of an image is indicated by the filename extension of the header file. + +The \fIimh_rename\fR and \fIimh_copy\fR procedures are in principle not +required since the operations can be performed at a high level with the +procedures already provided, but the IMH operators can carry out the +operations more efficiently and without the possibility of information being +lost, since they have knowledge of the physical storage format. + +.nh +Physical Data Formats + + The only two physical (disk) data formats currently supported are the +old IRAF format and the STScI SDAS format. The IMH interface makes it +relatively straightforward for other sites to interface their local format +if necessary, or to support multiple versions of the same format. + +IMH will automatically read images stored in any of the supported formats. +When making a NEW_COPY image, IMH will generate a new image in the same +format as the existing input image. When making a NEW_IMAGE type image, +the value of the environment variable \fBimtype\fR determines the type of +image to be created. The recognized values of \fBimtype\fR are shown below. + +.ks +.nf + not defined old iraf format + imtype = "oiraf" old iraf format + imtype = "sdas" SDAS/SOGS format +.fi +.ke + +The format in which an image is stored is indicated by the filename extension +of the header file. The filename extension is not specified in image names +or templates above the IMH interface, but is visible to the user in a +directory listing. + +.ks +.nf + .imh old iraf format header + .hhh SDAS/SOGS format header +.fi +.ke + +The current IMH interface is implemented in such a way that the semantics +of the two image storage formats are essentially equivalent, i.e., applications +programs should work consistently regardless of the storage format used. +In order to achieve this, the SDAS group format is fully supported only +when reading existing group format images. On output, images stored in +SDAS format are stored in separate files (gcount=1). The IRAF image template +is more flexible than the SDAS group format, simplifies programming, and +provides much the same basic capability. diff --git a/sys/imio/doc/Notes b/sys/imio/doc/Notes new file mode 100644 index 00000000..b7f6675c --- /dev/null +++ b/sys/imio/doc/Notes @@ -0,0 +1,177 @@ +IMIO modifications to support SDAS format imagefiles +---------------------------------------------------------------- + +1. EXISTING DATA FORMATS + + +1.1 IRAF Data Format (pre-DBIO) + +Characteristics: + + o Header: binary data structure + fits card image string buffer + o Pixels: binary pixhdr + pixels (can be block aligned) + o Many datatypes supported + o One image per imagefile + o Pixel file may be stored in different directory than header file + o Header file is protected from deletion + +Disadvantages: + + o Can lose track of pixel file if header is deleted. + o Since each image is stored in a separate pair of files, + directories can be large. + o The storage format is machine dependent. + +Modifications in this release: + + o Add .imh extension to image header file + o Add .pix extension to pixel file, make root name same as that + of the header file + o If IMDIR = "", put pixel file in same directory as the header. + This avoids use a pathname in the header, hence the images + are relocatable, but forces one to work on a scratch device. + + + +1.2 SDAS Data Format + +Characteristics: + + o Images are physically stored in group format + o FITS group header + binary image headers + o Pixfile format: [pixels + group header] * ngroups + nothing is aligned on block boundaries + o Pixel and header files stored in same directory + o Header file extension .hhh, pixel file extension .hhd + +Disadvantages: + + o Images cannot be added to a group; the number of images in a + group must be specified when the group is created. + o The individual images in a group cannot be deleted; only the + entire group can be deleted. + o The format of the image headers for the individual images in + a group is fixed at create time; new parameters cannot be + added to the individual image headers (new parameters can + however be added which apply to the group as a whole). + o The images in a group must all be of the same size and datatype + (this is probably not a serious disadvantage). + o The storage format is machine dependent. + + +2. IMAGEFILE ACCESS + + o Open/create image + o Make new_copy image + o Access pixel segment + o Close image + o Test if image exists (and determine type) + o Delete image + o Rename image + + +2.1 Open Image + + generate header filename + open/create header file + allocate image descriptor + if (existing image) + read image header into descriptor + else + initialize descriptor + return pointer to descriptor + + +2.2 Access Pixel Segment + + All image size parameters must be determined at pixfile creation + time. + + if (new segment) { + fill in descriptor + if (new pixel file) + allocate pixel file + else + open pixel file r/w + update header + } else + open pixel file + + +2.3 Close Image + + if (header has been modified) + update header + close pixfile + close header + + + +3. SPECIFICATIONS + +3.1 Image Header Access + + To minimize changes to existing code, the IMIO internal data structures +will not be modified. The principal change to the structure of the existing +interface is the replacement of the direct calls to the FIO open, close, read, +write, etc. procedures called to access the image header in mass storage by +calls to a new interface IH (Image Header access). The new interface will +hide the disk image format from IMIO. Interface subroutines will be provided +only for the IRAF and SDAS image formats, although in principle the interface +will be extensible to other formats as well. + +Ideally the IH interface should be coded using only relatively low level +VOS and kernel facilities (i.e., no high level FIO, no error handling) so that +it may be used by the IMFORT interface and called from host Fortran programs, +as well as by IMIO. + + + im = ihopen (image, group, acmode) + ihopix (im) + ihclose (im) + + +IHOPEN returns the standard IMIO image descriptor, consisting of the internal +IMIO fields, the binary image header structure IMHDR, and the "user area", +a sequence of FITS card images stored in memory a string buffer, i.e., +each card image is represented as a stripped, newline delimited sequence of +characters, with an EOS following the last card. + +The GROUP argument to IHOPEN permits access to the individual elements of +a group format imagefile. Group format is supported for both imagefile +formats, the principal difference being that the individual images are +stored in separate files in the old IRAF format, and in a single pair of +images in the SDAS format. + +The individual images in a group format imagefile appear as separate, +independent images in IMIO. Several images in a group format imagefile may +be simultaneously open (the files are physically opened only once). +The group header parameters are duplicated for each image in the group. +If the images are stored in the old IRAF format on disk the values of these +parameters may vary from image to image, otherwise (SDAS format) they are +the same for all members of the group. The number of images in a group is +fixed at image creation time. + + +3.2 Image Sections and Templates + + The image section notation recognized by IMMAP may include a group +specifier (set selection expression) as well as a section specifier. +The full syntax is "image{group}[section]", e.g., + + pix{3}[*,5] + +where { is the set selection operator, and [ is the familiar array subscript +or subsection operator. + +The image template notation has also been generalized to support group format +image data. The general form of a template element is + + image{groups}[section] + +where [section] applies to each image in the group. For example, the template + + aa{4},bb{1,3:5},cc{12:15}[*,-*] + +expands as image 4 of group AA, images 1, 3, 4, and 5 of group BB, and images +12 through 15 of group CC flipped in Y. diff --git a/sys/imio/doc/bench.ms b/sys/imio/doc/bench.ms new file mode 100644 index 00000000..05717208 --- /dev/null +++ b/sys/imio/doc/bench.ms @@ -0,0 +1,73 @@ +.OM +.TO +Steve Ridgway +.FR +Doug Tody +.SU +Performance of IRAF Image I/O +.PP +As Caty reported in her memo of 15 November, the timings of the \fIimarith\fR +task were surprisingly poor, i.e., approximately 20 cpu seconds for the +addition of two 200 column by 800 line short integer images, producing a +short integer image as output (a "short" integer is 16 bits). +A look at the code for \fIimarith\fR revealed +that the internal computations were being done in double precision floating, +regardless of the datatype of the images on disk. +I was not aware of this and I appreciate having it brought to my attention. +Fixing \fIimarith\fR took several hours and nearly cut the timings in half. +.PP +When I orginally implemented IMIO I planned to eventually make three major +optimizations (as noted in the program plan and system interface reference +manual): +.RS +.LP \(bu +Optimize the special case of line by line i/o with no automatic type +conversion, image sectioning, boundary extension, etc. +.LP \(bu +Provide direct access into the FIO file buffers when possible to eliminate +the memory to memory copy to and from the IMIO and FIO buffers. +.LP \(bu +Implement a optimal static file driver for UNIX to eliminate the overhead +of copying the data through the system buffer cache, and to permit +overlapped i/o. +.RE +.LP +I have gone ahead and implemented the first two optimizations; this took +a day and the changes were entirely internal to the interface, +requiring no changes to user code and no loss of machine independence. +After these changes were made to IMIO I ran several benchmarks with the +following results. All benchmarks were for images with 16 bit integer pixels. +.TS +center box tab(|); +ci ci ci ci ci ci ci +r n n n nb n n. +operation|open/close|line ovhead|kernel op|total user time|%opt|systime +- +(c=a+b)[200,800]|.38|1.43|1.69|3.50|48%|3.82 +(c=a+b)[800,800]|.38|1.43|6.94|8.75|79%|12.16 +minmax[800,800]|.05|0.59|11.39|12.03|95%|2.66 +.TE +.PP +The columns in the table show the operation tested by the benchmark (two image +additions, each involving three images, and a computation of the minimum and +maximum of a single image), the overhead involved in opening and closing the +images (same operation on a [1,1] image), the total overhead to process the +image lines, the time consumed by the kernel operation, the total user time +for the task, the degree of optimality (ratio of time spent in the kernel +vector operation to the total time for the task), +and the system (UNIX kernel) time required. +.PP +In short, the time required by the original benchmark has decreased from +20 seconds to 3.5 seconds, disregarding the system time. In this worst +case benchmark we still manage to come within 48% of the optimal time of +1.69 seconds for a VAX 11/750. +.PP +The short integer vector addition kernel operator was hand optimized in +assembler for these benchmarks to provide a true measure of the degree +of optimality. The actual unoptimized UNIX vector addition operator is +slightly slower. +The last column, labelled "systime", shows the cpu time consumed +by the UNIX kernel moving the pixels to and from disk; this is the time +that will be eliminated by the static file driver optimization. +Once the static file driver is optimized any further optimizations +will be difficult. diff --git a/sys/imio/doc/imfort.doc b/sys/imio/doc/imfort.doc new file mode 100644 index 00000000..6eef0dc6 --- /dev/null +++ b/sys/imio/doc/imfort.doc @@ -0,0 +1,72 @@ +Jun 19: IRAF images may now be read and written from Fortran programs. + The interface is simple and efficient, but limited in capability. + If a more sophisticated interface is required one may call Fortran + subroutines from SPP main programs (templates are available for + accessing 1 and 2 dimensional images in this fashion), or program + directly in SPP. + + 1. Documentation from the source file + + IMFORT -- Fortran interface to IRAF images. This interface permits a + Fortran program to read or write an existing IRAF image. There is + currently no provision for creating new images or deleting old images + from Fortran. The interface routines are as follows: + + im = imopen (image, mode, ndim, len_axes) + imclos (im) + + imget[sr] (im, buf, x1, x2, linenum) + imput[sr] (im, buf, x1, x2, linenum) + + where + input integer im, x1, x2, linenum + input character image, mode + output integer ndim, len_axes(7) + pixel buf(*) + + imgets,imputs are for short integer (integer*2) pixels + imgetr,imputr are for real pixels + + An image must be opened with IMOPEN before it can be accessed. Legal + access modes are 'r', 'w', and 'rw'. The number of dimensions and + the length of the axes are returned in ndim and len_axes; the latter + should be dimensioned for at least 7 dimensions. All coordinates are + 1-indexed. The variable "im" is an integer. The get and put routines + will perform datatype conversion if necessary. The imget and imput + routines will abort program execution if there is an error. + + + 2. Usage + + Source files (minimal documentation in imfort.c header): + + /iraf/sys/imio/mhdr.c.h + /iraf/sys/imio/imfort.c + + Libraries: + + /usr/lib/libiraf.a -liraf on f77 cmd line + /usr/lib/libvops.a -lvops on f77 cmd line + + e.g., + f77 myprog.f -liraf -lvops -o myprog + + or if called in SPP + + cl> xc myprog.x, lib=iraf + + + 3. Example + + integer im + integer axlen(7), ndim + integer imopen + integer*2 pix(1024) + + im = imopen ('/tmp2/iraf/images/m74', 'r', ndim, axlen) + write (*,*) ndim, axlen + call imgets (im, pix, 10,15, 5) + write (*,*) pix(1), pix(5) + stop + end + diff --git a/sys/imio/doc/imio.2.ms b/sys/imio/doc/imio.2.ms new file mode 100644 index 00000000..0727179f --- /dev/null +++ b/sys/imio/doc/imio.2.ms @@ -0,0 +1,331 @@ +.DA May 7, 1985 +.OM +.TO +distribution +.FR +Doug Tody +.SU +New release of image i/o, etc. +.PP +The new release of IMIO has been installed in the system for a week now and +appears to be bug free. This memo summarizes the changes/additions in this +new version of the interface, and introduces the new "image database" tools +\fIhedit\fR and \fIhselect\fR as well. +.NH +Summary of Changes in the Current Release +.PP +The following changes or additions have been made to the IMIO interface and +the \fIimages\fR package. +.RS +.IP \(bu +IMIO now has the ability to perform (optionally) automatic boundary extension +to satisfy out of bounds pixel references. +.IP \(bu +A preliminary database interface has been added to IMIO. +.IP \(bu +Image headers are now variable length and use only the amount of disk space +required to store the header (excluding byte packing). +.IP \(bu +Two new database utility tasks \fIhedit\fR and \fIhselect\fR have been +added to the \fIimages\fR package. Both use the new library subroutine +\fIevexpr\fR, now installed in the FMTIO package. +.IP \(bu +A new task \fIimshift\fR has been added to the \fIimages\fR package to +perform shifts of two dimensional images using full two dimensional +interpolation. The related tasks \fIgeomap\fR and \fIgeotran\fR are +currently being worked on. Some filtering and convolution tasks should +also be available soon. All of these tasks use the new boundary extension +feature of IMIO. +.RE +.PP +The new release of IMIO is upward compatible with previous versions and should +require no changes to or even recompilation of existing code. The basic image +header structure is unchanged hence existing images and image headers are still +accessible. Copying of old images still on disk with \fIimcopy\fR may however +be desirable to reduce disk consumption (the old headers were wasteful of +storage). +.PP +This release of IMIO introduces some database tools and concepts which +should help us understand the role the DBIO interface and DBMS package will +play in image processing applications in the near future. The current database +interface has serious functional limitations and is inefficient for operations +which operate upon entire databases (e.g., the \fIselect\fR operation), +but does provide a basic and much needed image database capability. +.NH +Planned Future Developments +.PP +This new release of IMIO is expected to remain unchanged until DBIO is +completed, at which time a new version of the interface will be released. +This next release is expected to be upward compatible with the current +interface except in cases where the applications task has detailed knowledge +of the current image header structure. Applications which directly access +the "user area" of the current header, or which use certain header fields +such as IM_HISTORY, will have to be modified as these data structures will +change in the next release. +.PP +Applications which use only \fIimmap\fR, \fIimunmap\fR, IM_PIXTYPE, +IM_NDIM, IM_LEN, and the basic i/o procedures should not have to be changed. +The new interface will provide different facilities to do the same things +but we can probably emulate the old interface to allow plenty of time to +convert the old code. Of course, the new interface will provide new facilities +which we did not formerly have and which we will want to use, and therefore +we will eventually have to modify all existing image tasks. +.PP +Perhaps more seriously, we are not going to be able to maintain the ability +to read the existing binary image files when the DBIO version of IMIO is +released. At that time, all disk resident images will have to be processed +to FITS format and thence into the new DBIO image format. We will keep the +old binary for the FITS writer task around for an indefinite period after +the changeover to make this possible. + +.NH +Modifications to the Current Interface +.NH 2 +Boundary extension +.PP +Automatic boundary extension is useful in applications such as filtering via +convolution, since the convolution kernel will extend beyond the boundary of +the image when near the boundary, and in applications which operate upon +subrasters, for the same reason. When reading from an image with boundary +extension in effect, IMIO will generate artificial values for the out of +bounds pixels using one of the techniques listed below. When writing to an +image with boundary extension in effect, the out of bounds pixels are +discarded. +.PP +By default, an out of bounds pixel reference will result in an error message +from IMIO. Consider an image line of length 5 pixels. The statement +.DS +\fL + buf = imgs1r (im, -1, 7) +\fR +.DE +references out of bounds by 2 pixels on either end of the image line, +referencing a total of 5+2+2=9 pixels. If boundary extension is enabled +and the get section completes successfully then \fIMemr[buf]\fR will reference +the pixel at X = -1, and \fIMemr[buf+2]\fR will reference the first inbounds +pixel. +.PP +When an image is first opened zero pixels of boundary extension are +selected, and any out of bounds references will result in an error. +To enable boundary extension \fIimseti\fR must be called on the open +image to specify the number of pixels of boundary extension permitted +before an out of bounds error occurs. +.DS +\fL + include + call imseti (im, IM_NBNDRYPIX, 2) +.DE +\fR +.LP +If boundary extension is enabled the type of boundary extension desired +should also be set. The possibilities are defined in \fI\fR and +are summarized below. +.DS +\fL + BT_CONSTANT return constant if out of bounds + BT_NEAREST return nearest boundary pixel + BT_REFLECT reflect back into image + BT_WRAP wrap around to other side + BT_PROJECT project about boundary +.ce +\fR +\fBTypes of Boundary Extension\fR +.DE +.LP +The type of boundary extension is set with the imset parameter IM_TYBNDRY. +If the BT_CONSTANT option is selected the constant value should be set with +an \fIimseti\fR or \fIimsetr\fR call to set the parameter IM_BNDRYPIXVAL. +Boundary extension works for images of any dimension up to 7 (the current +IMIO limit). A single IM_NBNDRYPIX value is used for all dimensions. +This value is used only for bounds checking, hence the value should be set +to the maximum out of bounds reference expected for any dimension. +Larger values do not "cost more" than small ones. An actual out of bounds +reference is however more expensive than an inbounds reference. +.NH 2 +Image Database Interface +.PP +The image database interface is the IMIO interface to the database +containing the image headers. In this implementation the image header is +a variable length binary structure. The first, fixed format, part of the +image header contains the standard fields in binary and is fixed in size. +This is followed by the so called "user area", a string buffer containing +a sequence of variable length, newline delimited FITS format keyword=value +header cards. When an image is opened a large user area is allocated to permit +the addition of new parameters without filling up the buffer. When the +header is subsequently updated on disk only as much disk space is used as +is needed to store the actual header. +.PP +The new header format is upwards compatible with the old image header format, +hence old images and programs do not have to be modified to use the latest +release of IMIO. In the future image headers will be maintained under DBIO, +but the routines in the image header database interface described in this +section are not exected to change. +The actual disk format of images will of course change when we switch +over to the DBIO headers. While the physical storage format of header will +change completely under DBIO, the logical schema will change very little, +i.e., our mental picture of an image header will be much as it is now. +The main difference will be the consolidation of many images into a few files, +and real support in the image header for bad pixels, history, and coordinate +transformations. In addition a number of restrictions on the "user fields" +will be lifted, the remaining distinctions between the standard and user +fields will disappear, and database operations will be much more efficient +than they are now. +.NH 3 +Library Procedures +.PP +The IMIO library procedures comprising the current image database interface +are summarized in the table below. +.DS +\fL + value = imget[bcsilrd_] (im, field) + imgstr (im, field, outstr, maxch) + imput[bcsilrd_] (im, field, value) + impstr (im, field, value) + imadd[bcsilrd_] (im, field, def_value) + imastr (im, field, def_value) + imaddf (im, field, datatype) + imdelf (im, field) + y/n = imaccf (im, field) + + list = imofnl[su] (im, template) + nchars/EOF = imgnfn (list, fieldname, maxch) + imcfnl (list) + +where + pointer im, list + char[] field, outstr, datatype, template, fieldname +\fR +.ce +\fBImage Database Interface Procedures\fR +.DE +.PP +New parameters will typically be added to the image header with either +one of the typed \fIimadd\fR procedures or with the lower level \fIimaddf\fR +procedure. +The former procedures permit the parameter to be created and the value +initialized all in one call, while the latter only creates the parameter. +In addition, the typed \fIimadd\fR procedures may be used to update the values +of existing parameters, i.e., it is not considered an error if the parameter +already exists. The principal limitation of the typed procedures is that +they may only be used to add or set parameters of a standard datatype. +The \fIimaddf\fR procedure will permit creation of parameters with more +descriptive datatypes (abstract datatypes or domains) when the interface is +recut upon DBIO. There is no support in the current interface for domains. +.PP +The value of any parameter may be fetched with one of the \fIimget\fR functions. +\fIBe careful not to confuse \fBimgets\fI with \fBimgstr\fI +(or \fBimputs\fI with \fBimpstr\fI) when +fetching or storing the string value of a field\fR. Full automatic type +conversion is provided. Any field may be read or written as a string, +and the usual type conversions are permitted for the numeric datatypes. +.PP +The \fIimaccf\fR function may be used (like the FIO \fIaccess\fR procedure) +to determine whether a field exists. Fields are deleted with \fIimdelf\fR; +it is an error to attempt to delete a nonexistent field. +.PP +The field name list procedures \fIimofnl[su]\fR, \fIimgnfn\fR, +and \fIimcfnl\fR procedures are similar to the familiar file template +facilities, except that the @file notation is not supported. The template +is expanded upon an image header rather than a directory. Unsorted lists +are the most useful for image header fields. If sorting is enabled each +comma delimited pattern in the template is sorted separately, rather than +globally sorting the entire template after expansion. Minimum match is +permitted when expanding the template, another difference from file +templates. Only actual, full length field names are placed in the output +list. +.NH 3 +Standard Fields +.PP +The database interface may be used to access any field of the image header, +including the following standard fields. Note that the nomenclature has +been changed slightly to make it more consistent with FITS. Additional +standard fields will be defined in the future. These names and their +usage may change in the next release of IMIO. +.DS +\fI + keyword type description +\fL + i_ctime l time of image creation + i_history s history string buffer + i_limtime l time when limits (minmax) were last updated + i_maxpixval r maximum pixel value + i_minpixval r minimum pixel value + i_mtime l time of last modify + i_naxis i number of axes (dimensionality) + i_naxis[1-7] l length of an axis ("i_naxis1", etc.) + i_pixfile s pixel storage file + i_pixtype i pixel datatype (SPP integer code) + i_title s title string +\fR +.ce +\fBStandard Header Fields\fR +.DE +.PP +The names of the standard fields share an "i_" prefix to reduce the possibility +of collisions with user field names, to identify the standard fields in +sorted listings, to allow use of pattern matching to discriminate between the +standard fields and user fields, and so on. For the convenience of the user, +the "i_" prefix may be omitted provided the resultant name does not match the +name of a user parameter. It is however recommended that the full name be +used in all applications software. +.NH 3 +Restrictions +.PP +The use of FITS format as the internal format for storing fields in this +version of the interface places restrictions on the size of field names and +of the string value of string valued parameters. Field names are currently +limited to eight characters or less and case is ignored (since FITS requires +upper case). The eight character limit does not apply to the standard fields. +String values are limited to at most 68 characters. If put string is passed +a longer string it will be silently truncated. Trailing whitespace and +newlines are chopped when a string value is read. + +.NH +Database Utility Tasks +.PP +Two image database utility tasks have been implemented, \fIhedit\fR and +\fIhselect\fR. \fIHedit\fR is the so called header editor, used to modify, +add, or delete selected fields of selected images. The \fIhselect\fR task +is used to select images that satisfy a selection criteria given as a boolean +expression, printing a subset of the fields of these images on the standard +output in list form. Manual pages are attached. +.PP +Both of these tasks gain most of their power from use of the \fIevexpr\fR +utility procedure, now available in FMTIO. The \fIevexpr\fR procedure takes +as input an algebraic expression (character string), parses and evaluates +the expression, and returns as output the value of the expression. +.DS +\fL + include + pointer evexpr() + + o = evexpr (expr, getop, ufcn) + +where + o Is a pointer to an operand structure + expr Is a character string + getop Is either NULL or the \fIlocpr\fL address + of a user supplied procedure called during + expression evaluation to get the value of + an external operand. + ufcn Is either NULL or the \fIlocpr\fL address + of a user supplied procedure called during + expression evaluation to satisfy a call to + an external function. +\fR +.DE +The operand structure is defined in \fB\fR. The best documentation +currently available for the operators and functions provided by \fIevexpr\fR +will be found in the manual page(s) for \fIhedit\fR. Additional documentation +will be found with the sources. The expression evaluation procedure is +probably the single largest procedure in the system (in terms of kilobytes +added to an executable) and should not be used unless it is needed, but it can +greatly increase the power of a task in the right application. +.CT +IRAF +Larry Goad +George Jacoby +Richard Wolff +Steve Ridgway (fyi) +Jeanette Barnes (fyi) +Ed Anderson (fyi) diff --git a/sys/imio/doc/imio.doc b/sys/imio/doc/imio.doc new file mode 100644 index 00000000..daa72a52 --- /dev/null +++ b/sys/imio/doc/imio.doc @@ -0,0 +1,232 @@ + IRAF IMIO OVERVIEW + 7 May 1986 + + + +1. DATA MANAGEMENT ROUTINES + +include + + im = immap (image, mode, oim) + imunmap (im) + + imdelete (image) + imrename (oldname, newname) + +where + struct imhdr *im, *oim; image header/descriptor + char image[]; image name or image section + int mode; ro, wo, rw, new_image, new_copy + +important header parameters: + + im->im_naxis number of axes + im->im_axlen[i] axis lengths + im->im_pixtype pixel datatype + im->im_datamin min pixel value + im->im_datamax max pixel value + im->im_title title string + + +Existing images are normally opened either read only or read write. +New images are opened either new_image or new_copy. In the latter case, +the third argument is a pointer to the image descriptor of an existing +image, with the new image inheriting the non-data attributes of the +existing image header. This latter feature is important for data +independence. + +The IMIO interface supports images of up to naxis=7. In a sense, all images +are multidimensional, with the higher, unused axis lengths set to 1. +An N dimensional image may therefore be accessed by a program coded to +operate upon an M dimensional image. + +The image section facility greatly inceases the flexibility of the IMIO +interface. Image sections are specified as part of the image name input +to IMOPEN, and are not visible to the applications program, which sees +a somewhat smaller image, or an image of lesser dimensionality. Some examples +are shown below. + + + section refers to + + pix[] whole image + pix[i,j] the pixel value (scalar) at [i,j] + pix[*,*] whole image, two dimensions + pix[*,-*] flip y-axis + pix[*,*,b] band B of three dimensional image + pix[*,*:s] subsample in y by S + pix[*,l] line L of image + pix[c,*] column C of image + pix[i1:i2,j1:j2] subraster of image + pix[i1:i2:sx,j1:j2:sy] subraster with subsampling + + +Sections are implemented by defining a linear transformation upon the +pixel coordinates input when image i/o takes place. All image data +transfers can be represented as subrasters defined by corner points +pointed to by the vectors VS and VE, each of length NAXIS. If an image +section is specified, the IMIO i/o routines merely transform these +vectors into PVS and PVE, the physical coordinates of the referenced +subraster, before doing any i/o. + + +2. IMIO OPTIONS + + IMIO options may be set and queried with the IMSET and IMSTAT procedures, +shown below. + + imseti (im, option, int_value) + imsetr (im, option, real_value) + + int = imstati (im, option) + real = imstatr (im, option) + +The options currently supported are shown below (from ). + + +# IMSET.H -- Definitions for IMIO user settable options + +define IM_ADVICE 1 # RANDOM or SEQUENTIAL +define IM_NBUFS 2 # number of input buffers +define IM_COMPRESS 3 # align lines on device blocks? +define IM_NBNDRYPIX 4 # width of boundary region +define IM_TYBNDRY 5 # type of boundary extension +define IM_FLAGBADPIX 6 # set bad pix to INDEF +define IM_PIXFD 7 # pixfile fd (special devices) +define IM_WHEADER 8 # update image header at unmap time +define IM_BNDRYPIXVAL 9 # for option IM_CONSTANT + + +# Types of Boundary Extension + +define BT_CONSTANT 1 # return constant if out of bounds +define BT_NEAREST 2 # return nearest boundary pixel +define BT_REFLECT 3 # reflect back into image +define BT_WRAP 4 # wrap around to other side +define BT_PROJECT 5 # project about boundary + + +The most useful options are the multiple input buffers and boundary extension, +used to implement filtering operators. + + +3. IMIO I/O ROUTINES + + There are two basic approaches used in image interfaces: images may be +mapped into virtual memory, or accessed via conventional file i/o. IMIO +provides both but emphasizes the latter, since it is more portable, more +efficient for sequential image operations, and because it provides data +independence. All buffering is handled internally by the interface to +simplify the interface (externally), and to provide the control necessary +for sophisticated features and optimizations. + +IMIO currently provides three classes of i/o routines: [1] get/put line +random, [2] get/put line sequential, and [3] get/put subraster random. + + +3.1 Get/Put Line Random (for images of known dimension) + + ptr = im[gp]l[123][usilrdx] (im, line [, band [, ...]]) +e.g., + (short *) = imgl1s (im) # get line from 1d short image + (short *) = imgl2s (im, lineno) # get line from 2d short image + (real *) = imgl2r (im, lineno) # get line from 2d real image + (short *) = impl2s (im, lineno) # put line to 2d short image + (real *) = imgl3r (im, line, band) # get from 3d image + + +3.2 Get/Put Line Sequential (for images of any dimension) + + int = im[gp]nl[usilrdx] (im, ptr, v) +e.g., + (EOF?) = imgnlr (im, ptr, v) # get next line, real + (EOF?) = impnls (im, ptr, v) # put next line, short + +Here, STAT is either EOF or not EOF, with EOF being returned when the last +line of the image has been read. The output argument PTR is set to point +to the buffer containing the input pixels, or the buffer into which the +output pixels are to be written. The vector V, of length IM_MAXDIM, points +to the next line of the image to be read. It is set initially to [1,1,1,...] +by the user (assuming the entire image is to be accessed), and is automatically +updated by IMIO in each call. + + +3.3 Get/Put Subraster Random + + ptr = im[gp]s[123][usilrdx] +e.g., + (short *) = imgs2s (im, x1,x2, y1,y2) # get 2d subraster, short + (real *) = imps1r (im, x1,x2) # put 1d subraster, real + +These routines (and indeed all the i/o routines) can be used for either +sequential or random accesses. The subraster routines must be used to +reference outside the boundary in X. + + +3.4 Other I/O Routines + + Other, lower level routines are provided for unusual applications for which +the above routines are not suited. + + ptr = im[pg]gs[usilrdx] (im, vs, ve, ndim) + +The above puts/gets a general section of any dimension. The vectors VS and VE +define the starting and ending corners of the subraster to be accessed. +An IMFLUSH routine is provided for flushing the output buffer (remember the +delayed write). + + +In all cases, no buffers are allocated until i/o takes place, allowing IMSET +calls to set options after the image has been opened. In the case of a new +image (or new copy image), the pixel file is not allocated until i/o takes +place, giving the user time to set the number of axes, size of each axis, +pixel type, etc. after the image has been opened. + + +4. STORAGE FORMATS + + IMIO stores images on disk in line storage mode, like a multidimensional +Fortran array. Image lines are normally padded out to an integral number +of disk blocks to increase i/o efficiency. We store the header information +separately from the pixels, since the header is variable length. The pixel +storage file is preallocated and fixed in size. We call this a "static file". +A special FIO driver is provided for static files to provide optimal i/o. +Since the file is not dynamically extended at run time and the physical +blocks allocated for the file do not move about, it is possible to bypass +the host files system to directly access the data with a low level interface. + + +5. EXAMPLE (SPP) + + +# IMCOPY -- Copy an image. The header information is preserved. The output +# image has the same size, dimensionality, and pixel type as the input image. +# An image section may however be used to copy a subsection of the input image. + +procedure imcopy (in_image, out_image) + +char in_image[ARB] +char out_image[ARB] + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer in, out, l1, l2 +pointer immap(), imgnlr(), impnlr() + +begin + # Open/create the images. + in = immap (in_image, READ_ONLY, 0) + out = immap (out_image, NEW_COPY, im_a) + + # Initialize position vectors to line 1, column 1, band 1, ... + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + npix = IM_LEN(in,1) + + # Copy the image. + while (imgnlr (in, l1, v1) != EOF && impnlr (out, l2, v2) != EOF) + call amovr (Memr[l1], Memr[l2], npix) + + call imunmap (in) + call imunmap (out) +end diff --git a/sys/imio/doc/imio.hlp b/sys/imio/doc/imio.hlp new file mode 100644 index 00000000..8eb96159 --- /dev/null +++ b/sys/imio/doc/imio.hlp @@ -0,0 +1,1185 @@ +.help imio May83 "Image I/O Routines" +.sh +The Image Header + + The major difference between the prototype IMIO interface, and the final +interface, concerns the way in which the image header is implemented and +accessed. In the prototype version, we will simply read the entire header +into core and access it as an ordinary (dynamically allocated) structure. + + +.nf + ptr = immap (fname, mode, hdrsize/hdrptr) + imunmap (hdrptr) +.fi + + +The final resolution of how image headers are implemented depends on how +we decide to implement virtual structures in the spp language. The immap +calls, and the techniques used to access the fields of the image header, +can be expected to change. + +.sh +Pixel I/O + + The calling sequences for the i/o routines, described below, hopefully will +not have to be changed. We will eventually add GETPIX and PUTPIX statements +to the subset preprocessor language, to automatically generate the appropriate +low level calls. + +A generic, polymorphic GETPIX or PUTPIX statement is translated into a +reference to a low level Fortran function. The transformation is governed +by the following subprogram name generating function: + + +.rj (108 total) +GETPIX, PUTPIX --> im[gp][pls][123][silrdx] + + +.ks +.nf +For example (get, type real): + + ptr = imgp1r (hdrptr, x, npix) # get pixels + ptr = imgp2r (hdrptr, x, y, npix) + ptr = imgp3r (hdrptr, x, y, z, npix) + + ptr = imgl1r (hdrptr) # get line + ptr = imgl2r (hdrptr, y) + ptr = imgl3r (hdrptr, y, z) + + ptr = imgs1r (hdrptr, x1, x2) # get section + ptr = imgs2r (hdrptr, x1, x2, y1, y2) + ptr = imgs3r (hdrptr, x1, x2, y1, y2, z1, z2) +.fi +.ke + + +The IM?P?? procedures access a list of pixels, the coordinates of which +are given by the X, Y, Z, etc. arrays given as arguments. Note that random +access of individual pixels is provided as a special case (npix=1). + +The IM?L?? routines access the lines of an image, and the IM?S?? routines +operate on general, but connected, subsections of images. + + +.sh +Restrictions Imposed by the Initial Prototype: + + IMMAP, IMMAPNC, IMUNMAP will be implemented for image headers that are +simple binary structures (not self describing), subject to the restriction +that a file may contain only a single header. An arbitrary selection of user +defined fields will follow the standard header. The entire header will +be read into core and accessed as a simple incore structure. + +The pixels, and other variable size image substructures, will be stored +in separate files, as in the general plan. All of the standard data types +will be implemented in the disk space. The initial implementation will +support only type REAL pixels in program space. + +The following i/o routines will be implemented in the first release of +the prototype: + +.rj (12 total) + im[gp][sc][123][r] + +In words, we will be able to read and write lines and sections, with the +applications program manipulating type REAL pixels internally. The full +range of data types will be permitted in the image file as stored on disk. +Up to three dimensional images are permitted. + +.sh +IMSET Options + + The prototype need not provide multiple buffering and boundary extension +initially. + +.sh +Implementation + + Little effort should be made to make the prototype optimal. All +buffering will be locally allocated, and data will be copied to and from +the FIO buffers (the FIO buffers will not be directly accessed). Special +cases will not be optimized. The most general entry points are IMGGSR +and IMPGSR (get/put general section). Initially, all of the other entry +points can be defined in terms of these. + + +.ks +.nf +Structure of the input procedures (type REAL): + + imgl1r + imgl2r + imgl3r + imgs1r + imgs2r + imgs3r + imggsr + imggsc + imgibf + imopsf + calloc + imcssz + realloc + malloc + mfree + imsslv + imrdpx + imsoob + imnote + seek + read + imflip + imupkr + + (datatype dependent) | (datatype independent) +.fi +.ke + + + +The output procedures are structured somewhat differently, because the +transfer of a section occurs sometime after a "put section" returns, +rather than immediately as in the input procedures. Since the output +is buffered for a delayed write, we must have an IMFLUSH entry point, and +IMUNMAP must flush the output buffer before unmapping an image. + + +.ks +.nf +Structure of the output procedures (type REAL): + + impl1r + impl2r + impl3r + imps1r imunmap + imps2r | + imps3r | + impgsr | + imflush + imflsr + imflsh + imflip + imwrpx + imsoob + imnote + imwrite + fstatus + seek + write + impakr + + imgobf + imopsf + calloc + imcssz + realloc + malloc + mfree + + (datatype dependent) | (datatype independent) +.fi +.ke + + +.sh +Semicode for the Basic I/O Routines + + The IMGGS? and IMPGS? procedures get and put general N-dimensional +image sections of a specific datatype. There is no intrinsic limit on +the maximum number of dimensions, and the full range (8) of disk datatypes +are easily supported. The subscript for a particular dimension may run +either forward or backward. The semicode is written generically, allowing +code to be machine generated for all program space datatypes (6). + +We do not address the problems of boundary extension and multiple buffering +here, but these features can be easily added in the future. This version +of IMIO assumes that pixels are stored on disk in line storage mode, with +no interlacing of bands. + + +IMGGS? gets a general section, and converts it to the datatype indicated +by the type suffix. + + +.ks +.nf +pointer procedure imggs$t (imdes, vs, ve) + +imdes pointer to image descriptor structure +vs,ve coordinates of starting and ending points + +begin + bp = imggsc (imdes, vs, ve, TY_PIXEL, totpix) + if (imdes.pixtype != TY_PIXEL) + call imupk$t (*bp, *bp, totpix, imdes.pixtype) + return (coerce (bp, TY_CHAR, TY_PIXEL)) +end +.fi +.ke + + + +IMGGSC gets a general section from an imagefile into a buffer. Upon +exit, the buffer contains the requested section, with the pixels still +in the same datatype they were in the imagefile. The buffer is made +large enough to accommodate the pixels in either datatype. + + +.ks +.nf +pointer procedure imggsc (imdes, vs, ve, dtype, totpix) + +imdes pointer to image descriptor structure +vs,ve coordinates of starting and ending points +dtype datatype of pixels required by calling program +bp pointer to CHAR buffer to hold pixels + +begin + # Get an (input) buffer to put the pixels into. Prepare the + # section descriptor vectors V, VINC. + + bp = imgibf (imdes, vs, ve, dtype) + call imsslv (imdes, vs, ve, v, vinc, npix) + + # Extract the pixels. IMRPIX reads a contiguous array of + # pixels into the buffer at the specified offset, incrementing + # the offset when done. The pixels are type converted if + # necessary. + + offset = 0 + + repeat { + call imrdpx (imdes, *(bp+offset), v, npix) + if (vinc[1] < 0) + call imflip (*(bp+offset), npix, sizeof(imdes.pixtype)) + offset = offset + npix + + for (d=2; d <= imdes.ndim; d=d+1) { + v[d] += vinc[d] + if ((v[d] - ve[d] == vinc[d]) && d < imdes.ndim) + v[d] = vs[d] + else { + d = 0 + break + } + } + } until (d >= imdes.ndim) + + totpix = offset + return (bp) +end +.fi +.ke + + + + + +Prepare the section descriptor vectors V and VINC. V is a vector specifying +the coordinates at which the next i/o transfer will take place. VINC is +a vector specifying the loop step size. + + +.ks +.nf +procedure imsslv (imdes, vs, ve, v, vinc, npix) + +begin + # Determine the direction in which each dimension is to be + # traversed. + + do i = 1, imdes.ndim + if (vs[i] <= ve[i]) + vinc[i] = 1 + else + vinc[i] = -1 + + # Initialize the extraction vector (passed to IMRDS? to read a + # contiguous array of pixels). Compute length of a line. + + do i = 1, imdes.ndim + v[i] = vs[i] + + if (vs[1] > ve[1]) { + v[1] = ve[1] + npix = vs[1] - ve[1] + 1 + } else + npix = ve[1] - vs[1] + 1 +end +.fi +.ke + + + + + +The put-section procedure must write the contents of the output buffer +to the image, using the section parameters saved during the previous call. +The new section parameters are then saved, and the buffer pointer is +returned to the calling program. The calling program subsequently fills +the buffer, and the sequence repeats. + + +.ks +.nf +pointer procedure impgs$t (imdes, vs, ve) + +imdes pointer to image descriptor structure +vs,ve coordinates of starting and ending points + +begin + # Flush the output buffer, if appropriate. IMFLUSH calls + # one of the IMFLS? routines, which write out the section. + + call imflush (imhdr) + + # Get an (output) buffer to put the pixels into. Save the + # section parameters in the image descriptor. Save the epa + # of the typed flush procedure in the image descriptor. + + bp = imgobf (imdes, vs, ve, TY_PIXEL) + imdes.flush_epa = loc (imfls$t) + + return (bp) +end +.fi +.ke + + + +Flush the output buffer, if a put procedure has been called, and the +buffer has not yet been flushed. The output buffer is flushed automatically +whenever a put procedure is called, when an image is unmapped, or when +the applications program calls IMFLUSH. + + +.ks +.nf +procedure imfls$t (imdes) + +begin + # Ignore the flush request if the output buffer has already been + # flushed. + + if (imdes.flush == YES) { + bdes = imdes.obdes + bp = bdes.bufptr + + # Convert datatype of pixels, if necessary, and flush buffer. + if (imdes.pixtype != TY_PIXEL) + call impak$t (*bp, *bp, bdes.npix, imdes.pixtype) + call imflsh (imdes) + + imdes.flush = NO + } +end +.fi +.ke + + +.ks +.nf +procedure imflsh (imdes) + +begin + # Determine the direction in which each dimension is to be + # traversed. + + bdes = imdes.obdes + call imsslv (imdes, bdes.vs, bdes.ve, v, vinc, npix) + + # Write out the pixels. IMWRPX writes a contiguous array of + # pixels at the specified offset. + + offset = 0 + + repeat { + if (vinc[1] < 0) + call imflip (*(bp+offset), npix, sizeof(imdes.pixtype)) + call imwrpx (imdes, *(bp+offset), v, npix) + offset = offset + npix + + for (d=2; d <= imdes.ndim; d=d+1) { + v[d] += vinc[d] + if ((v[d] - ve[d] == vinc[d]) && d < imdes.ndim) + v[d] = vs[d] + else { + d = 0 + break + } + } + } until (d >= imdes.ndim) +end +.fi +.ke + + + + +Read a contiguous array of NPIX pixels, starting at the point defined by +the vector V, into the callers buffer. + + +.ks +.nf +procedure imrdpx (imdes, buf, v, npix) + +begin + # Check that the access does not reference out of bounds. + + if (imsoob (imdes, v, npix)) + call imerr (imname, subscript_out_of_range) + + # Seek to the point V in the pixel storage file. Compute size + # of transfer. + + call seek (imdes.pfd, imnote (imdes, v)) + nchars = npix * sizeof (imdes.pixtype) + + # Read in the data. + if (read (imdes.pfd, buf, nchars, junk) != nchars) + call imerr (imname, missing_pixels) +end +.fi +.ke + + + +Write a contiguous array of NPIX pixels, starting at the point defined by +the vector V, into the pixel storage file. + + +.ks +.nf +procedure imwrpx (imdes, buf, v, npix) + +begin + # Check that the access does not reference out of bounds. + + if (imsoob (imdes, v, npix)) + call imerr (imname, subscript_out_of_range) + + # Seek to the point V in the pixel storage file. Note that + # when writing to a new image, the next transfer may occur + # at a point beyond the current end of file. If so, write + # out zeros until the desired offset (which is in bounds) + # is reached. + + file_offset = imnote (imdes, v) + if (file_offset > imdes.file_size) + [write zeros until the desired offset is reached] + else + call seek (imdes.pfd, file_offset) + + # Compute size of transfer. If transferring an entire line, + # increase size of transfer to the physical line length, + # to avoid having to enblock the data. NOTE: buffer must + # be large enough to guarantee no memory violation. + + if (v[1] == 1 && npix == imdes.len[1]) + nchars = imdes.physlen[1] * sizeof (imdes.pixtype) + else + nchars = npix * sizeof (imdes.pixtype) + + call write (imdes.pfd, buf, nchars) + imdes.file_size = max (imdes.file_size, file_offset+nchars) +end +.fi +.ke + + + + +IMNOTE computes the physical offset of a particular pixel in the +pixel storage file. If the disk datatype is UBYTE, this is the offset +of the char containing the subscripted byte. + + +.ks +.nf +long procedure imnote (imdes, v) + +begin + pixel_offset = v[1] + for (i=2; i <= imdes.ndim; i=i+1) + pixel_offset += (v[i]-1) * imdes.physlen[i] + + char_offset0 = (pixel_offset-1) * sizeof (imdes.pixtype) + return (imdes.pixoff + char_offset0) +end +.fi +.ke + + + +Convert a vector of any datatype to type PIXEL ($t). The input and +output vectors may be the same, without loss of data. The input and +output datatypes may be the same, in which case no conversion is +performed. + + +.ks +.nf +procedure imupk$t (a, b, npix, dtype) + +begin + switch (dtype) { + case TY_USHORT: + call achtu$t (a, b, npix) + case TY_SHORT: + call achts$t (a, b, npix) + case TY_INT: + call achti$t (a, b, npix) + case TY_LONG: + call achtl$t (a, b, npix) + case TY_REAL: + call achtr$t (a, b, npix) + case TY_DOUBLE: + call achtd$t (a, b, npix) + case TY_COMPLEX: + call achtx$t (a, b, npix) + default: + call syserr (unknown_datatype_in_imagefile) + } +end +.fi +.ke + + + +Convert a vector of type PIXEL ($t) to any datatype. The input and +output vectors may be the same, without loss of data. The input and +output datatypes may be the same, in which case no conversion is +performed. + + +.ks +.nf +procedure impak$t (a, b, npix, dtype) + +begin + switch (dtype) { + case TY_USHORT: + call acht$tu (a, b, npix) + case TY_SHORT: + call acht$ts (a, b, npix) + case TY_INT: + call acht$ti (a, b, npix) + case TY_LONG: + call acht$tl (a, b, npix) + case TY_REAL: + call acht$tr (a, b, npix) + case TY_DOUBLE: + call acht$td (a, b, npix) + case TY_COMPLEX: + call acht$tx (a, b, npix) + default: + call syserr (unknown_datatype_in_imagefile) + } +end +.fi +.ke + + +.sh +Data Structure Management + + When an image is mapped, buffer space is allocated for a copy of +the image header, and for the image descriptor (used by IMIO while an +image is mapped). When the first i/o transfer is done on an image, +either an input or an output data buffer will be created. The size of +this buffer is governed by the size of the transfer, and by the datatypes +of the pixels on disk and in program space. + +If a new image is being written, the pixel storage file is created at +the time of the first PUTPIX operation. The physical characteristics +of the new image, defined by the image header of the new image, are +unalterable once the first i/o operation has occurred. Accordingly, +the number of dimensions, length of the dimensions, datatype of the +pixels on disk, and so on must be set (in the image header structure) +before writing to the new image. + +The only exception to this rule may be the addition of new lines to a +two dimensional image stored in line storage mode, or the addition of +new bands to a multiband image stored in band sequential (noninterlaced) +mode. It is not always possible to modify the dimensions or size of +an existing image. + +It is possible to preallocate space for an image (using FALOC). This +may result in a more nearly contiguous file, and may make writing a +new image slightly more efficient, since it will not be necessary +to write blocks of zeros in IMPGS?. Preallocation will occur +automatically in systems where it is desirable. + +.sh +Pixel Buffer Management + + There may be any number of input buffers per image, but only a single +output buffer. By default there is only a single input buffer. The input +and output buffers are distinct: the same buffer is never used for both +input and output (unlike FIO). + +The size of a buffer may range from one pixel, to the entire image (or +larger if boundary extension is in use). If multiple buffers are in use, +all buffers do not have to be the same size. The size of a buffer may +vary from one GETPIX or PUTPIX call to the next. + +If multiple input buffers are in use, buffers are allocated in a strictly +round robin fashion, one per GETPIX call. Several buffers may contain +data from the same part of the image. Once the desired number of buffers +have been filled, a buffer "goes away" with each subsequent GETPIX call. + + +IMGIBF gets an input buffer. When called to get a line or section, +the vectors VS and VE specify the subsection to be extracted. +This information is saved in the buffer descriptor, along with the +datatype of the pixels and the dimension of the section. + +When IMGIBF is called to get a list of pixels, VS and VE would have to be +replaced by a set of NPIX such vectors, to fully specify the section. +It is impractical to save this much information in the buffer descriptor, +so when creating a buffer to contain a list of pixels, VS and VE are faked +to indicate a one dimensional section of the appropriate size. + + + + +.ks +.nf +pointer procedure imgibf (imdes, vs, ve, dtype) + +imdes image descriptor +vs,ve define the number of pixels to be buffered +dtype the datatype of the pixels in the program + +begin + # If first input transfer, allocate and initialize array of + # input buffer descriptors. + + if (imdes.ibdes == NULL) { + call imopsf (imdes) + call calloc (imdes.ibdes, LEN_BDES * imdes.nbufs, TY_STRUCT) + } + + # Compute pointer to the next input buffer descriptor. + # Increment NGET, the count of the number of GETPIX calls. + + bdes = &imdes.ibdes [mod (imdes.nget, imdes.nbuf) + 1] + imdes.nget += 1 + + # Compute the size of the buffer needed. Check buffer + # descriptor to see if the old buffer is the right size. + # If so, use it, otherwise make a new one. + + nchars = imcssz (imdes, vs, ve, dtype) + + if (nchars < bdes.bufsize) + call realloc (bdes.bufptr, nchars, TY_CHAR) + else if (nchars > bdes.bufsize) { + call mfree (bdes.bufptr, TY_CHAR) + call malloc (bdes.bufptr, nchars, TY_CHAR) + } + + # Save section coordinates, datatype in buffer descriptor, and + # return buffer pointer to calling program. + + bdes.bufsize = nchars + bdes.dtype = dtype + bdes.npix = totpix + + do i = 1, imdes.ndim { + bdes.vs[i] = vs[i] + bdes.ve[i] = ve[i] + } + + return (coerce (bdes.bufptr, TY_CHAR, dtype) +end +.fi +.ke + + + + +.ks +.nf +pointer procedure imgobf (imdes, vs, ve, dtype) + +imdes image descriptor +vs,ve define the number of pixels to be buffered +dtype the datatype of the pixels in the program + +begin + # If first write, and if new image, create pixel storage file, + # otherwise open pixel storage file. Allocate and initialize + # output buffer descriptor. + + if (imdes.obdes == NULL) { + call imopsf (imdes) + call calloc (imdes.obdes, LEN_BDES, TY_STRUCT) + } + + bdes = imdes.obdes + + # Compute the size of buffer needed. Add a few extra chars + # to guarantee that there won't be a memory violation when + # writing a full physical length line. + + nchars = imcssz (imdes, vs, ve, dtype) + + (imdes.physlen[1] - imdes.len[1]) * sizeof (imdes.pixtype) + + if (nchars < bdes.bufsize) + call realloc (bdes.bufptr, nchars, TY_CHAR) + else if (nchars > bdes.bufsize) { + call mfree (bdes.bufptr, TY_CHAR) + call malloc (bdes.bufptr, nchars, TY_CHAR) + } + + # Save section coordinates, datatype of pixels in buffer + # descriptor, and return buffer pointer to calling program. + + bdes.bufsize = nchars + bdes.dtype = dtype + bdes.npix = totpix + + do i = 1, imdes.ndim { + bdes.vs[i] = vs[i] + bdes.ve[i] = ve[i] + } + + return (coerce (bdes.bufptr, TY_CHAR, dtype) +end +.fi +.ke + + + +Given two vectors describing the starting and ending coordinates +of an image section, compute and return the amount of storage needed +to contain the section. Sufficient storage must be allocated to +hold the largest datatype pixels which will occupy the buffer. + + + +.ks +.nf +long procedure imcssz (imdes, vs, ve, dtype) + +begin + pix_size = max (sizeof(imdes.pixtype), sizeof(dtype)) + npix = 0 + + do i = 1, imdes.ndim + if (vs[i] <= ve[i]) + npix *= ve[i] - vs[i] + 1 + else + npix *= vs[i] - ve[i] + 1 + + return (npix * pix_size) +end +.fi +.ke + + +.sh +Mapping and unmapping Image Structures + + An imagefile must be "mapped" to an image structure before the +structure can be accessed. The map operation associates a file with +a defined structure. + +The IMMAP procedure must allocate a buffer for the image header +structure, and for the image descriptor structure. If an existing +imagefile is being mapped, the header is copied into memory from +the imagefile. If a new image is being mapped, the header structure +is allocated and initialized. + +If an image is being mapped as a "new copy", a new header +structure is created which is a copy of the header of an image which +has already been mapped. The entire image header, including any +application specific fields, is copied. + +After copying an image header for a NEW_COPY image, the header field +containing the name of the pixel storage file is cleared. A "new copy" +image structure does not inherit any pixels. Any similar substructures +which describe the attributes of the pixels (i.e., the blank pixel +list, the histogram) must also be initialized. + +Note that the "image descriptor" buffer allocated below actually +contains the image descriptor, followed by the standard image header +(at offset IMHDR_OFF), followed by any user fields. If an existing +image structure is being mapped, the caller supplies the length of +the user area of the header as the third argument to IMMAP. + +IMMAP returns a pointer to the first field of the standard header +as the function value. The image descriptor is invisible to the +calling program. + + + +.ks +.nf +pointer procedure immap (fname, mode, hdr_arg) + +begin + # Add code here to handle section suffixes in imagefile + # name strings (e.g. "image[*,5]"). + + # Open image header file. + hfd = open (fname, mmap[mode], BINARY_FILE) + + # Allocate buffer for image descriptor/image header. Note + # the dual use of the HDR_ARG argument. + + if (mode == NEW_COPY) + sz_imhdr = hdr_arg.sz_imhdr + else + sz_imhdr = (LEN_IMHDR + int(hdr_arg)) * SZ_STRUCT + + call calloc (imdes, SZ_IMDES + sz_imhdr, TY_STRUCT) + imhdr = imdes + IMHDR_OFF + + [initialize the image descriptor, including the default + image section (optionally set by user with suffix above).] + + # Initialize the mode dependent fields of the image header. + switch (mode) { + case NEW_COPY: + call im_init_newcopy (imdes, hdr_arg) + case NEW_IMAGE: + [initialize the image header] + default: + call seek (hfd, BOFL) + n = read (hfd, Memi[imhdr], sz_imhdr) + if (n < SZ_IMHDR || strne (IM_MAGIC(imhdr), "imhdr")) { + call mfree (imdes) + call imerr (fname, file_not_an_imagefile) + } else if (mode == READ_ONLY) + call close (hfd) + } + + [initialize those fields of the image header which are not + dependent on the mode of access.] + + return (imhdr_pointer) +end +.fi +.ke + + + + +.ks +.nf +procedure imunmap (imhdr) + +begin + imdes = imhdr - IMHDR_OFF + + # Flush the output buffer, if necessary. + call imflush (imhdr) + + # Append the bad pixel list. + if (the bad pixel list has been modified) { + if (file_size < blist_offset) + [write out zeros until the offset of the bad pixel + list is reached] + [append the bad pixel list] + [free buffer space used by bad pixel list] + } + + call close (imdes.pfd) + + # Update the image header, if necessary (count of bad pixels, + # minimum and maximum pixel values, etc.). + + if (imdes.update == YES) { + if (no write permission on image) + call imerr (imname, cannot_update_imhdr) + call imuphdr (imdes) + call close (imdes.hfd) + } + + # Free buffer space. + for (i=1; i <= imdes.nbufs; i=i+1) + call mfree (imdes.ibdes[i].bufptr, TY_CHAR) + call mfree (imdes.obdes.bufptr, TY_CHAR) + call mfree (imdes, TY_STRUCT) +end +.fi +.ke + + +IMFLUSH indirectly references a typed flush procedure, the entry point +address of which was saved in the image descriptor at the time of the +last IMPGS? call. The problem here is that IMFLUSH must work properly +regardless of the data type of the pixels in the output buffer. To +ensure this, and to avoid having to link in the full matrix of 48 type +conversion routines, we call LOC in the put-section procedure to reference +the appropriate typed flush routine. + + + +.ks +.nf +procedure imflush (imhdr) + +begin + if (imdes.flush == YES) + call zcall1 (imdes.flush_epa, imdes) +end +.fi +.ke + + + +The following procedure is called by the IMGOBF and IMGIBF routines +to open the pixel storage file, during the first PUTPIX operation on +a file. + + +.ks +.nf +procedure imopsf (imdes) + +begin + switch (imdes.mode) { + case READ_ONLY, READ_WRITE, WRITE_ONLY, APPEND: + imdes.pfd = open (imdes.pixfile, imdes.mode, BINARY_FILE) + if (read (imdes.pfd, pix_hdr, SZ_PIXHDR) < SZ_IMMAGIC) + call imerr (imname, cannot_read_pixel_storage_file) + else if (strne (pix_hdr.im_magic, "impix")) + call imerr (imname, not_a_pixel_storage_file) + + case NEW_COPY, NEW_FILE, TEMP_FILE: + # Get the block size for device "imdir$", and initialize + # the physical dimensions of the image, and the absolute + # file offsets of the major components of the pixel storage + # file. + + dev_block_size = fdevblk ("imdir$") + [initialize im_physlen, im_pixels, im_hgmoff fields + in image header structure] + + # Open the new pixel storage file (preallocate space if + # enabled on local system). Call FADDLN to tell FIO that + # the pixfile is subordinate to the header file (for delete, + # copy, etc.). Save the physical pathname of the pixfile + # in the image header, in case "imdir$" changes. + + call mktemp ("imdir$im", temp, SZ_FNAME) + call fpathname (temp, imhdr.pixfile, SZ_PATHNAME) + + if (preallocation of imagefiles is enabled) + call falloc (imhdr.pixfile, sz_pixfile) + imdes.pfd = open (imdes.pixfile, NEW_FILE, BINARY_FILE) + call faddln (imdes.imname, imdes.pixfile) + + # Write small header into pixel storage file. Allows + # detection of headerless pixfiles, and reconstruction + # of header if it gets lost. + + [write pix_hdr header structure to pixel storage file] + + default: + call imerr (imname, illegal_access_mode) + } +end +.fi +.ke + + +.sh +Data Structures + + An imagefile consists of two separate files. The first file contains +the image header. In the prototype, there may be only a single header per +header file. The header consists of the standard image header, followed +by an arbitrary number of user defined fields. + +The standard part of the image header has a fixed structure. All the variable +size components of an image are stored in the pixel storage file. The +name of the pixel storage file, and the offsets to the various components +of the image, are stored in the image header. The name of the image header +file is in turn stored in the header area of the pixel storage file, +making it possible to detect headerless images. + +The pixel storage file contains a small header, followed by the pixels +(aligned on a block boundary), optionally followed by a fixed size +histogram, and a variable size bad pixel list. + + +.ks +.nf + Structure of an Imagefile + + --------- --------- + | <---- | + standard ----> header + image | + header PIXELS + | | + user histogram (optional) + fields | + | bad + \|/ pixel (optional) + ---------- list + | + \|/ + --------- +.fi +.ke + + +The image header file, which is small, will reside in the users own +directory. The pixel storage file is generated and manipulated +transparently to the applications program and the user, and resides +in the temporary files system, in the logical directory "imdir$". + +Storing the parts of an image in two separate files does cause problems. +The standard file operators, like DELETE, COPY, RENAME, and so on, +either cannot be used to manipulate imagefiles, or must know about +imagefiles. + +To solve this problem, without requiring FIO to know anything about IMIO +or VSIO data structures, two operators will be added to FIO. The first +will tell FIO that file 'A' has a subordinate file 'B' associated with +it. Any number of subordinate files may be associated with a file. +The information will be maintained as a list of file names in an invisible +text file in the same directory as file 'A'. + +The second operator will delete the link to a subordinate file. The FIO +procedures DELETE and RENAME will check for subordinate files, as will CL +utilities like COPY. + +.sh +The Standard Image Header + + The standard fields of an image header describe the physical +characteristics of the image (required to access the pixels), plus +a few derived or historic attributes, which are commonly associated +with images as used in scientific applications. + + +.ks +.nf +struct imhdr { + char im_magic[5] # contains the string "imhdr" + long im_hdrlen # length of image header + int im_pixtype # datatype of the pixels + int im_ndim # number of dimensions + long im_len[MAXDIM] # length of the dimensions + long im_physlen[MAXDIM] # physical length (as stored) + long im_pixels # offset of the pixels + long im_hgmoff # offset of hgm pixels + long im_blist # offset of bad pixel list + long im_szblist # size of bad pixel list + long im_nbpix # number of bad pixels + long im_cdate # date of image creation + long im_mdate # date of last modify + real im_max # max pixel value + real im_min # min pixel value + struct histogram im_hgm # histogram descriptor + struct coord_tran im_coord # coordinate transformations + char im_pixfile[SZ_PATHNAME] # name of pixel storage file + char im_name[SZ_IMNAME] # image name string + char im_history[SZ_IMHIST] # history comment string +} +.fi +.ke + + + +The histogram structure, if valid, tells where in the pixel storage file +the histogram is stored, and in addition summarizes the principal +attributes of the histogram. All of these quantities are directly +calculable, except for the last three. The modal value is determined +by centering on the (major) peak of the histogram. LCUT and HCUT define +an area, centered on the modal value, which contains a certain fraction +of the total integral. + + +.ks +.nf +struct histogram { + int hgm_valid # YES if histogram is valid + int hgm_len # number of bins in hgm + long hgm_npix # npix used to compute hgm + real hgm_min # min hgm value + real hgm_max # max hgm value + real hgm_integral # integral of hgm + real hgm_mean # mean value + real hgm_variance # variance about mean + real hgm_skewness # skewness of hgm + real hgm_mode # modal value of hgm + real hgm_lcut # low cutoff value + real hgm_hcut # high cutoff value +} +.fi +.ke + + + +The coordinate transformation descriptor is used to map pixel coordinates +to some user defined virtual coordinate system, (useful when displaying the +contents of an image). For lack of a significantly better scheme, we have +simply adopted the descriptor defined by the FITS standard. + + +.ks +.nf +struct coord_tran { + real im_bscale # pixval scale factor + real im_bzero # pixval offset + real im_crval[MAXDIM] # value at pixel + real im_crpix[MAXDIM] # index of pixel + real im_cdelt[MAXDIM] # increment along axis + real im_crota[MAXDIM] # rotation angle + char im_bunit[SZ_BUNIT] # pixval ("brightness") units + char im_ctype[SZ_IMCTYPE,MAXDIM] # coord units +} +.fi +.ke + + + +The image and buffer descriptors are used internally by IMIO while +doing i/o on a mapped image. The image descriptor structure is +allocated immediately before the image header, is transparent to the +applications program, and is used to maintain runtime data, which +does not belong in the image header. + + +.ks +.nf +struct image_descriptor { + long file_size # size of pixfile + long nget # number getpix calls + int nbufs # number of in buffers + int flush # flush outbuf? + int update # update header? + int pfd # pixfile fd + int hfd # header file fd + int flush_epa # epa of imfls? routine + struct buffer_descriptor *ibdes # input bufdes + struct buffer_descriptor *obdes # output bufdes + char imname[SZ_FNAME] # imagefile name +} +.fi +.ke + + + +.ks +.nf +struct buffer_descriptor { + char *bufptr # buffer pointer + int dtype # datatype of pixels + long npix # number of pixels in buf + long bufsize # buffer size, chars + long vs[MAXDIM] # section start vector + long ve[MAXDIM] # section end vector +} +.fi +.ke diff --git a/sys/imio/doc/imio.ms b/sys/imio/doc/imio.ms new file mode 100644 index 00000000..2302a8ff --- /dev/null +++ b/sys/imio/doc/imio.ms @@ -0,0 +1,295 @@ +.ce +\fBThe IRAF Image I/O Interface\fR +.ce +\fIDesign Strategies\fR +.ce +\fIStatus and Plans\fR +.sp +.ce +Doug Tody +.ce +November 1983 +.sp 3 +.NH +Introduction +.PP +Bulk data arrays are accessed in IRAF SPP programs via the Image I/O +(IMIO) interface. IMIO is used to create, read, and write IRAF +\fBimagefiles\fR. The term \fBimage\fR refers to data arrays of one, two, +or more dimensions. Each "imagefile" actually consists of two files: +the \fBheader file\fR and the \fBpixel storage file\fR. Seven disk datatypes +are currently supported. +.PP +The IMIO calling sequences are summarized in the \fIProgrammer's Crib +Sheet\fR. There is as yet no Reference Manual or User's Guide for the package. +Our intention in this document is merely to introduce IMIO, to summarize its +capabilities, and note what is planned for the future. +.NH +Structure +.PP +The basic structure of an applications program which uses IMIO is shown +below. In the current implementation of IMIO the image header is a simple +binary structure, but this will change when DBIO (the database interface) +is implemented. The pixel storage file is accessed via FIO (the IRAF File +I/O interface) which permits arbitrarily large buffers and double or multiple +buffered i/o. All buffers are dynamically allocated and deallocated using +the facilities provided by the MEMIO interface. + +.DS +.cs 1 22 +Command Language + (applications program) + IMIO + DBIO + FIO + OS | + MEMIO | (operating system) + OS | + + + (system independent) | (system dependent) +.DE +.cs 1 + +.NH +Summary of What is Provided by the Current Interface +.PP +The IMIO interface code is mostly concerned with pixel buffer allocation and +manipulation, and with mapping requests to read and write image sections +into file i/o calls. FIO handles all low level i/o. The efficiency of FIO +for sequential image access stems from the fact that the FIO buffers may +be made as large as desired transparently to the outside world (i.e., IMIO), +the number of FIO buffers is variable, and full read-ahead and write-behind +are implemented (provided the OS provides asynchronous i/o facilities). +.PP +IMIO currently provides the following functions/features: + +.RS +.IP (1) +7 disk datatypes (ushort, silrdx). +.IP (2) +6 in-core datatypes (the standard silrdx). +.IP (3) +Images of up to 7 dimensions are currently supported. The maximum +dimensionality is a sysgen parameter. +.IP (4) +Fully automatic multidimensional buffer allocation, resizing, +and deallocation. There is no fixed limit on the size of a buffer (a subraster +may actually exceed the size of the image if boundary extension is employed). +The size of an image is limited only by the resources of the machine. +.IP (5) +An arbitrary number of input buffers (default 1) may be used to access an +image. Buffers are allocated in a round robin fashion, and need not be the +same size, dimension, or datatype. This feature is especially useful for +convolutions, block averaging, and similar operators. +.IP (6) +Fully automatic type conversion on both input and output. Conversion occurs +only when data is accessed, so one need not type convert the entire image +to access a subraster. +.IP (7) +IMIO implements general image sections (described below), coordinate flip, +and subsampling. +.IP (8) +The dimensionality of the image expected by the applications code and the +actual dimension of an image need not agree. If an operator expects a one +dimensional image, for example, it may be used to operate on any line, column, +or pillar of a three dimensional image, on both input and output (see +discussion on image sections below). +.IP (9) +Both "compressed" and "block aligned" storage modes are supported, with IMIO +automatically selecting the optimal choice during image creation (if the +packing efficiency is not above a certain threshold then image lines are +not block aligned). The device blocksize is determined at runtime and +devices with different blocksizes may coexist. +.IP (10) +IMIO may be advised if i/o is to be either highly sequential or highly +random; the buffering strategy will be modified to increase i/o efficiency. +.IP (11) +Pixel storage files may reside on special devices if desired. For example, +the current \fBdisplay\fR routine accesses the image display device as a random +access imagefile via the standard IMIO interface. This was easy to do +because FIO is device independent and allows new devices to be interfaced +dynamically at run time (other examples of special "devices" are the CL, +magtapes, and strings). +.IP (12) +The image header file, which is small, is normally placed in the user's +own directory system. The pixel storage file, on the other hand, is often +very large and is normally placed in a different filesystem. This is +transparent to the user, and has the advantage that bulk data does not +have to be backed up on tape when the user disk is backed up, and throughput +is often higher because the pixel filesystem can be optimized for large +transfers and more nearly contiguous files. +.IP (13) +An image opened with the mode "new_copy" inherits the full image header +of an existing image, including all user defined fields, minus the pixels +and minus all fields which depend on the actual values of the pixels. +.RE + +.PP +The basic i/o facilities are described in the crib sheet. In short, we +have procedures to get or put pixels, lines, or sections. The put calls +are identical to the get calls and all buffer allocation and manipulation +is performed by IMIO. The pixel access routines access a list of pixels +(described by one, two, or more integer arrays giving the coordinates of +the pixels, which are fetched in storage order to minimize seeks). +An additional set of calls are available for accessing all of the lines +in an image sequentially in storage order, regardless of the dimensionality +of the image (as in the FITS reader). +.NH +Planned Enhancements to IMIO +.PP +The following enhancements are currently planned for IMIO; they are +arranged more or less with the highest priority items first. The DBIO +header, boundary extension facilities, and bad pixel list features are +of the highest priority and will be implemented within the next few months. + +.RS +.IP (1) +Replacement of the current rather rigid binary header by the highly +extensible yet efficient DBIO header. +.IP (2) +Automatic boundary extension by any of the following techniques: +nearest neighbor, reflection, projection, wrap around, indefinite, +constant, apodize. Useful for convolutions and subraster extraction +near the boundary of an image. +.IP (3) +Bad pixel list manipulation. A list of bad pixels will optionally be +associated with each image. The actual value of each "bad" pixel in the +image will be a reasonable, artificially generated value. Programs which +do not need to know about bad pixels, such as simple pointwise image +operators, will see only reasonable values. IMIO will provide routines to +merge (etc.) bad pixel lists in simple pointwise image operations. +Operators which need to be able to deal with bad pixels, such as surface +fitting routines, will advise IMIO to replace the bad pixels with the +value INDEF upon input. +.IP (4) +Implement the pixel access routines (\fBimgp__\fR and \fBimpp__\fR). +Currently only the line and section routines are implemented. The section +routines may be used to access individual pixels, but this involves quite +a bit of overhead and disk seeks are not optimized. +.IP (5) +Optimization to the get/put line procedures to work directly +out of the FIO buffers when possible for increased efficiency. +.IP (6) +IMIO (and FIO) dynamically allocate all buffers. Eventually we will add +an "advice" option permitting buffers to be allocated in a region +of memory which is \fIshared\fR with a bit-mapped array processor. +The VOPS primitives, already used extensively for vector operations, +will be interfaced to the AP and applications sofware will then make use +of the AP without modification and without introducing any device +dependence. Note that CSPI is currently marketing a 7 Mflop bit-mapped +AP for the VAX, and Masscomp provides a similar device for their 680000 based +supermicro. +.IP (6) +Support for the unsigned byte disk datatype. +.DE + +.PP +Long range improvements include language support for image sections in +the successor to the SPP (subset) language compiler, and extensions for +block storage mode of images on disk. Currently all images are stored on +disk in line storage mode (i.e., like a Fortran array). +.NH +Image Sections +.PP +Image sections are used to specify the region of an image to be operated +upon. The essential idea is that when the user passes the name of an +image to a task, a special notation is employed which specifies the section +of the image to be operated upon. The image section is decoded by IMIO +at "immap" time and is completely transparent to the applications code +(when a section is used, the image appears smaller to the applications +program). If no section is specified then the entire image is accessed. +.PP +For example, suppose we want to display the image "pix" in frame 1 of the +image display, using all the default parameters: + +.nf + cl> display pix, 1 +.fi + +This works fine as long as "pix" is a one or two dimensional image. If it +is a three dimensional image, we will see only the first band. To display +some other band, we must specify a two-dimensional \fIsection\fR of the +three dimensional image: + +.nf + cl> display pix[*,*,5], 1 + cl> display pix[5], 1 +.fi + +Either command above would display band 5 of the three dimensional image +(higher dimensional images are analogous). To display a dimensional image +with the columns flipped: + +.nf + cl> display pix[*,\(mi*], 1 +.fi + +This command flips the y-axis. To display a subraster: + +.nf + cl> display pix[30:40,310:300], 1 +.fi + +would display the indicated eleven pixel square subraster. To display a +2048 square image on a 512 square display by means of subsampling: + +.nf + cl> display pix[*:4,*:4], 1 +.fi +.NH +Use of Virtual Memory +.PP +The current implementation of IMIO does not make use of any virtual memory +facilities. We have had little incentive to do so because 4.1BSD Berkeley +UNIX does not have a very good implementation of virtual memory (few systems +do, it seems - DG/AOS, which is what CTIO runs, does not have a +good implemenation either). Various strategies can, however, be employed +to take advantage of virtual memory on a machine which provides good +virtual memory facilities. +.PP +One technique is to use IMIO to "extract a subraster" which is in fact +the entire image. The current implementation of IMIO would copy rather +than map the image, but \fIif\fR no type conversion were required, +if no section was specified, if the image was not block-aligned, +and if referencing out of bounds was not required, +IMIO could instead map the image directly into virtual memory. +This would be an easy enhancement to make to IMIO because all data is +accessed with pointers. The code fragment in the following example +demonstrates how this is done in the current version of IMIO. + +.DS +.cs 1 22 +int ncols, nlines +pointer header, raster +pointer immap(), imgs2r() + +begin + # Open or "map" the image. "Imagefile" is a file name + # or a file name with section subscript appended. + + header = immap (imagefile, READ_ONLY, 0) + + ncols = IM_LEN (header, 1) + nlines = IM_LEN (header, 2) + + # Read or map entire image into memory. Pixels are + # converted to type real if necessary. + + raster = imgs2r (header, 1, ncols, 1, nlines) + + # Call SPP or Fortran subroutine to process type real + # image. Note how the pointer "raster" is dereferenced. + + call subroutine (Memr[raster], ncols, nlines) + ... +.DE +.cs 1 + +.PP +Another, slightly different approach would be to allocate a single FIO +buffer and map it onto the entire file. This would require no modifications +to IMIO, rather one would modify the "file fault" code in FIO. +This scheme would more efficiently support random access (to image lines or +subrasters) on a virtual machine without introducing a real dependence +on virtual memory. diff --git a/sys/imio/iki/README b/sys/imio/iki/README new file mode 100644 index 00000000..14b0f3f5 --- /dev/null +++ b/sys/imio/iki/README @@ -0,0 +1,383 @@ + Image Kernel Interface (IKI) + Doug Tody + 08 May 1986 + + +1. INTRODUCTION + + The IKI is the interface between IMIO and some particular image storage +format. IMIO itself has no knowledge of the storage format. The primary +function of the IKI is to access image headers, mapping the host header +storage format into the IMIO image header descriptor and vice versa. +The IKI is responsible for all image management operations, including +opening/creating/updating headers, opening/creating pixfiles (pixel storage +files), deleting, renaming, and copying images, checking for the existence +of images, and so on. + +The IKI can support an arbitrary number of different storage formats. +Each format requires a set of format dependent driver subroutines implementing +the standard IKI functions. The IKI will dynamically select the driver to be +used to access a particular format at runtime. New drivers may be dynamically +loaded at runtime, in a way similar to that used for FIO. While IMIO directly +accesses the pixel storage file via binary FIO for efficiency reasons, the +pixfile is opened by the IKI driver, hence a special driver may be used if +desired. For example, this feature may be used to access image display frame +as a pixfile, or an image stored in archival format on an optical disk. + + +2. STRUCTURE + + The role played by the IKI and format specific IKI drivers in the image +i/o subsystem is illustrated in the figure below. + + + IMIO Format independent; primarily does i/o to + | the pixel file. The image header is read + | into a dynamically allocated descriptor at + | open time. + | + IKI Selects driver to be used. Maintains table + | of open images, handles cleanup during error + | recovery. + | + (drivers) Physically accesses/creates/deletes etc. an + image stored in a particular format. Maps + the header stored in some particular external + format into the standardized IMIO descriptor. + Responsible for opening/creating the pixfile, + returning a FIO file descriptor to IMIO, which + directly accesses the pixel data. + + +The format specific driver packages are written in SPP using only standard +VOS i/o facilities, e.g., FIO and MEMIO. This is necessary due to the use +of an SPP descriptor structure to maintain the incore version of the image +header, due to the need to return an FIO file descriptor to IMIO, and so on. +To add support for a new format, one need only add a new driver to the IKI +and relink the system. + + +3. LOGICAL SCHEMA + + The logical schema of the current IKI is highly constrained by the fact +that the IKI is an add-on to the existing IMIO interface. It is not worthwhile +in this revision to try to address the limitations/design flaws of the initial +IMIO interface, hence our intention is to add the IKI in such a way that few +changes are required to IMIO, and no changes are required to programs which +use IMIO. One or two further major revisions are planned before the final +interface is realized. The concept of the IKI is here to stay, but the current +interface attempts only to address the immediate need to support multiple +image formats with the least impact on current software. + +An image consists of a header and a pixel array stored in a random access +binary file. Images may be grouped together into an array or "cluster" of +images, with the individual images being accessed by a one indexed subscript +appended to the cluster name, e.g., "pix[3]" refers to image 3 of the cluster +"pix". To create a cluster containing more than one image a / followed by +the cluster size may be included in the cluster index, e.g., "pix[3/10]" to +create a cluster of 10 images and write into image 3. An image section may +optionally be appended to access some subset of the pixels in the image, e.g., +"pix[3][*,5]". Lastly, if the image is stored as a disk file, the filename +extension of the header file may be given to explicitly indicate the image +format (IKI driver) to be used to access the image. + +A full specification (referencing an existing image) might therefore be +"pix.hhh[3][*,5]", where the ".hhh" extension indicates that the cluster is +physically stored in an SDAS GEIS (group format) data structure, the "[3]" +indicates image 3, and the "[*,5]" is a conventional IMIO image section. +If the minimal specification "pix" were given, the IKI would determine that +"pix" was a GEIS format image, accessing the entire contents of image [1]. +As an aside, note that image sections are handled entirely by IMIO and are +not seen at the IKI level. Likewise, the cluster subscript is parsed by +IMIO and passed to the IKI as an integer argument. + + + IM_PIXTYPE int pixel type (usilrdx) + IM_NDIM int number of axes (0:7) + IM_LEN long[7] logical length of each axis (>=1) + IM_PHYSLEN long[7] physical length of each axis (>=1) + IM_CLINDEX int index of image in cluster + IM_CLSIZE int number of images in cluster + IM_PIXOFF long char file offset to the pixels + IM_CTIME long image creation time + IM_MTIME long most recent image modification time + IM_LIMTIME long time when max/min last updated + IM_MAX real maximum pixel value + IM_MIN real minimum pixel value + IM_PIXFILE char*80 pathname of pixel file (optional) + IM_TITLE char*80 image title string + + +The important fields of the IMIO image descriptor are summarized above, along +with their datatype and length in the case of arrays. This is from the original +IMIO design and has not been modified in any way, except for the addition of the +cluster fields to the runtime descriptor. The IKI drivers directly read and +write these fields in the image descriptor. + +In addition to these standard fields (for which the IKI driver must supply +reasonable values at open time) the image descriptor contains a "user area" +containing an arbitrary sequence of keyword=value parameters encoded in +FITS character format. The FITS cards are trimmed at the right and +concatenated into an EOS delimited string with newline characters delimiting +each card. All host format specific header parameters should be passed to +IMIO in the user area. In the case of group format images, the user area +will contain both the group parameters (parameters shared by the entire group +of images) and the group header parameters (parameters for the individual +image in the group specified at open time). IMIO makes no distinction +between the two types of parameters. All header parameters are available +to the high level applications code via the IMIO/IDBI interface. + + +4. IKI INTERFACE PROCEDURES + + The IMIO code calls only the IKI procedures and has no knowledge of the +IKI drivers, or of which driver has been connected to a particular image +descriptor. The high level IKI procedures are summarized below. The interface +is fairly small due to the use of the descriptor to maintain all information +describing the image, and due to the fact that IMIO directly accesses the +pixel data via FIO. + + + iki_open (im, image, group, gcount, acmode, o_im) + iki_close (im) + iki_opix (im) # open/create pixfile + iki_updhdr (im) # update image header + + iki_copy (oldname, newname) # fast copy of entire group + iki_delete (group) # delete entire group + iki_rename (oldname, newname) # rename entire group + + k = iki_access (image, acmode) # test existence, legal extn + iki_lddriver (open,close, # install new driver + opix,updhdr, access,copy,delete,rename) + + +The OPEN procedure opens or creates the indicated image in the named cluster. +In the case of a new image or new copy image, only the header is created by +the open call; the pixfile is not created until the OPIX routine is called, +allowing the high level code time to set the image dimensions, datatype, +number of groups, etc., in the image descriptor. Once OPIX has been called +to create a new group, the number of axes, size of each axis, pixel type, +etc. is fixed. + +In the case of image stored in the SDAS/GEIS group format, all of the images +in a cluster (group) must be of the same size, must have the same header +parameters, and the header parameters must be defined when the group is +created (new parameters or images cannot be added to the group later). +The first open call for a image will allocate space for all images in the +cluster, but only the indicated image will be initialized in the first call. +Multiple images may be simultaneously open in the same cluster, and the same +image may be multiply opened on independent logical FIO file descriptors. + +The high level IRAF software has little or no knowledge of the physical +association of images into clusters. In particular, the high level software +is ignorant about the SDAS/GEIS image storage format, but this need not +prevent processing of these images. The main limitations of the group +format derive from the fact that new images can neither be added to nor +deleted from to a group format cluster, and new parameters cannot be added +to a group header. To create a group format image via IMIO, one will normally +make a NEW_COPY copy of an existing group format image (to define the fields +of the group headers), specifing the number of images in the new group in +the cluster size field of the image name specification. For example, writing +to the new image "pix[3/10]" will cause a cluster of 10 images to be created +and image 3 to be initialized. Subsequent calls to write to either "pix[I]" +or "pix[I/10]" will be necessary to initialize the remaining images in the +cluster. + + +5. KERNEL PROCEDURES + + Each supported image format requires a dedicated set of kernel procedures +to be called by the IKI to access images stored in that format. The calling +sequences for these procedures are shown below. + + + xxx_open (im, root, extn, cl_index, cl_size, acmode, status) + xxx_close (im, status) + xxx_opix (im, status) + xxx_updhdr (im, status) + + xxx_access (root, extn, acmode, status) + xxx_copy (old_root, old_extn, new_root, new_extn, status) + xxx_delete (root, extn, status) + xxx_rename (old_root, old_extn, new_root, new_extn, status) + + +Here, the package prefix "xxx" is OIF for the old IRAF image format, and STF +for the STScI/SDAS GEIS format. Note that the OPEN procedure fills in selected +fields in a preallocated image descriptor rather than allocating the descriptor +itself. Image names are parsed into root, extension, cl_index, etc. fields by +the IKI or higher level code, to further simplify the kernel code. The IKI +verifies the existence or nonexistence of all operand images before calling +a kernel procedure, hence the kernel procedures need not perform these +functions. The kernel procedures should return an ERR status if they cannot +perform their function for some reason (rather than take an error action). +The locpr() entry point addresses of the kernel procedures are saved in a +runtime table maintained by the IKI. + +The syntax and semantics of the kernel procedures are discussed in detail below. +Since the interface routines have full access to the IMIO descriptors, it is +important to realize what does and does not have to be set. + + +5.1 IMAGE OPEN PRIMITIVE + +include +include +include "xxx.h" + +# XXX_OPEN -- Open/create an image. + +procedure oif_open (im, root, extn, cl_index, cl_size, acmode, status) + +pointer im # image descriptor (allocated by IMIO) +char root[ARB] # root image name +char extn[ARB] # extension, if any +int cl_index # index of image to be opened +int cl_size # number of images in cluster +int acmode # access mode +int status # return status (OK|ERR) + +begin + 1. Construct the filename of the header file and open or create the + image header file. + + 2. If opening an existing image, read the image header and fill in + the following fields of the IMIO image header descriptor. If + creating a new image set only the field IM_HDRFILE. + + IM_PIXTYPE # datatype of the pixels ** + IM_NDIM # number of dimensions ** + IM_LEN # length of the dimensions ** + + IM_CTIME # time of image creation + IM_MTIME # time of last modify + IM_LIMTIME # time min,max computed + IM_MAX # max pixel value + IM_MIN # min pixel value + IM_PIXFILE # name of pixel storage file + IM_HDRFILE # name of header storage file + IM_TITLE # image name string + IM_HISTORY # history comment string + + The really essential fields are marked with a ** at the right. + CTIME, PIXFILE, HDRFILE, TITLE, and HISTORY are for information + only. MTIME and LIMTIME are used to determine if the min/max + pixel values are up to date, and the actual values do not matter + provided the conclusion about the min/max values is correct. + + 3. If opening an existing image, call IMIO to set those fields of the + image header/descriptor describing the format in which the pixels + are stored in the pixel storage file. + + [] call imioff (im, pixoff, COMPRESS, blklen) + + where + pixoff FIO file offset of first pixel. + compress Set to NO to enable alignment of image + lines on block boundaries, to YES for + compressed byte stream image. + blklen Device block size, chars. Set to 1 to + defeat all block alignment. + + If opening a new image, this step may be left until the OPIX + primitive is called. + + 3. If the kernel procedures use their own internal descriptor, + allocate and initialize the descriptor and save a pointer to + it in IM_KDES(im). + + 4. Set return status. +end + + +5.2 OPEN PIXEL FILE PRIMITIVE + +include +include +include "xxx.h" + +# XXX_OPIX -- Open (or create) the pixel storage file. Call IMIO to set the +# file offsets and buffer sizes. + +procedure xxx_opix (im, status) + +pointer im # image descriptor +int status # return status + +begin + 1. Opening existing image: + 1.1 Open pixel file read only or read write. + + 2. Opening (creating) new image: + 2.1 Call IMIO to set the offset parameters, assuming this was not + already done in the OPEN primitive: + + [] call imioff (im, pixoff, COMPRESS, blklen) + + 2.2 Using the file size computed by imioff or determined by more + format specific means, open (falloc) the pixel storage file. + The IM_HGMOFF field of the image header is set by imioff + to the file offset of the end of the image. + + 3. Call IMIO to set the i/o buffer parameters: + + [] call imsetbuf (pfd, im) + + This sets the FIO buffer size and the IM_FAST parameter. + The buffer size should be set before doing any i/o on the + pixel file. If in doubt, skip the call and simply set + IM_FAST(im) = NO (i/o will be suboptimal but not too bad). + + 4. Save the pixfile FIO file descriptor (required for pixel i/o) + in the image descriptor: + + [] IM_PFD(im) = pfd +end + + +5.3 UPDATE HEADER PRIMITIVE + +include +include + +# XXX_UPDHDR -- Update the image header. + +procedure xxx_updhdr (im, status) + +pointer im # image descriptor +int status # return status + +begin + 1. Update the values of the standard logical image header fields + in the physical image header, e.g., PIXTYPE, NDIM, LEN, and CTIME + (for new images), MTIME, LIMTIME, MIN, MAX (any image). + + 2. Save the "user fields" in the physical image header. Some of + these may have been inserted in the user area by the kernel open + procedure, others may have been added by IRAF programs or by + the user since the image was opened. +end + + +5.4 CLOSE IMAGE PRIMITIVE + +include + +# XXX_CLOSE -- Close an image. + +procedure xxx_close (im, status) + +pointer im # image descriptor +int status + +begin + 1. If the pixel file has been opened, close it. Note that if no + pixel i/o was done to the image, the pixel file will never have + been opened. + + 2. If the header file is still open, close it. + + 3. If a special kernel descriptor was allocated at image open time + by the kernel, deallocate it. +end diff --git a/sys/imio/iki/fxf/Notes b/sys/imio/iki/fxf/Notes new file mode 100644 index 00000000..2a2fd74d --- /dev/null +++ b/sys/imio/iki/fxf/Notes @@ -0,0 +1,81 @@ +Fits kernel notes / unresolved issues +---------------------------------------------------------------------------- + +Extraneous env variables - put in fkinit + + ENV_DEFIMTYPE "imtype" + ENV_FITSCACHE "fitscache" + + +Rename + + minhdrlns + + +Cache + + hard upper limit - is this a restriction? + convert from common to dynamic descriptor + referenced: open delete rename rfits updhdr + +Extensions + should not use imtype to set extension (this is copied from STF which + also has the same problem) + +Defaults / ksection / fkinit + should overwrite be allowed in fkinit? (fxfopen) + +check on file clobber + + +---------------------------------------------------------------------------- +Extension, default image type + +imtype + The purpose of imtype is to control the types of images automatically + created by the system if no image extension is specified. + + new image - determines default image type + new copy - determines default image type if noinherit + no extn - up to kernel whether this is legal + + imtype = [(oif|fxf|plf|qpf|stf) | ] [[no]inherit] + + save format codes ("oif" etc) in driver descriptors + extensions are mapped to drivers using imextn + + +imextn + map file extensions to image type (kernel) + default extension for new images of a given type + + imextn = "oif:imh stf:hhh,??h fits:,fits,fit + + or possibly imextn = "imh:oif hhh,??h:stf fits,fit:fit + + kernels: oif fxf plf qpf stf + + iki_extninit (imtype, def_imtype, imextn, def_imextn) + iki_validextn (kernel, extn) + status = iki_getextn (kernel, index, extn, maxch) + + Initialize extension processing stuff at iki_init time - only once when + the process starts up. + + nextn + { kernel extn patbuf } + sbuf, sbufused + defimtype + inherit + +IKI - add kernel arg to: + access + copy + delete + open + rename + + + + + diff --git a/sys/imio/iki/fxf/README b/sys/imio/iki/fxf/README new file mode 100644 index 00000000..9c723b94 --- /dev/null +++ b/sys/imio/iki/fxf/README @@ -0,0 +1,5 @@ +# IKI/FXF -- Fits extension image kernel. +# There is a document describing the differents FK supported parameters: +# iraf.noao.edu/iraf/web/docs/fitsuserguide.html +# A PS file of this can be found in iraf.noao.edu/iraf/docs/fitsuserguide.ps.Z + diff --git a/sys/imio/iki/fxf/fxf.h b/sys/imio/iki/fxf/fxf.h new file mode 100644 index 00000000..c4e6188b --- /dev/null +++ b/sys/imio/iki/fxf/fxf.h @@ -0,0 +1,172 @@ +# FITS.H -- IKI/FITS internal definitions. + +define FITS_ORIGIN "NOAO-IRAF FITS Image Kernel July 2003" + +define FITS_LENEXTN 4 # max length imagefile extension +define SZ_DATATYPE 16 # size of datatype string (eg "REAL*4") +define SZ_EXTTYPE 20 # size of exttype string (eg BINTABLE) +define SZ_KEYWORD 8 # size of a FITS keyword +define SZ_EXTRASPACE (81*32) # extra space for new cards in header +define DEF_PHULINES 0 # initial allocation for PHU +define DEF_EHULINES 0 # initial allocation for EHU +define DEF_PADLINES 0 # initial value for extra lines in HU +define DEF_PLMAXLEN 32768 # default max PLIO encoded line length +define DEF_PLDEPTH 0 # default PLIO mask depth + +define FITS_BLOCK_BYTES 2880 # FITS logical block length (bytes) +define FITS_BLOCK_CHARS 1440 # FITS logical block length (spp chars) +define FITS_STARTVALUE 10 # first column of value field +define FITS_ENDVALUE 30 # last column of value field +define FITS_SZVALSTR 21 # nchars in value string +define LEN_CARD 80 # length of FITS card. +define LEN_UACARD 81 # size of a Userarea line. +define LEN_OBJECT 63 # maximum length of a FITS string value +define LEN_FORMAT 40 # maximum length of a TFORM value +define NO_KEYW -1 # indicates no keyword is present. + +define MAX_OFFSETS 100 # max number of offsets per cache entry. +define MAX_CACHE 60 # max number of cache entries. +define DEF_CACHE 10 # default number of cache entries. + +define DEF_HDREXTN "fits" # default header file extension +define ENV_FKINIT "fkinit" # FITS kernel initialization + +define DEF_ISOCUTOVER 0 # date when ISO format dates kick in +define ENV_ISOCUTOVER "isodates" # environment override for default + +define FITS_BYTE 8 # Bits in a FITS byte +define FITS_SHORT 16 # Bits in a FITS short +define FITS_LONG 32 # Bits in a FITS long +define FITS_REAL -32 # 32 Bits FITS IEEE float representation +define FITS_DOUBLE -64 # 64 Bits FITS IEEE double representation + +define COL_VALUE 11 # Starting column for parameter values +define NDEC_REAL 7 # Precision of real +define NDEC_DOUBLE 14 # Precision of double + +define FITS_LEN_CHAR (((($1) + 1439)/1440)* 1440) + +# Extension subtypes. +define FK_PLIO 1 + +# Mapping of FITS Keywords to IRAF image header. All unrecognized keywords +# are stored here. + +#define UNKNOWN Memc[($1+IMU-1)*SZ_MII_INT+1] +define UNKNOWN Memc[($1+IMU-1)*SZ_STRUCT+1] + + +# FITS image descriptor, used internally by the FITS kernel. The required +# header parameters are maintained in this descriptor, everything else is +# simply copied into the user area of the IMIO descriptor. + +define LEN_FITDES 500 +define LEN_FITBASE 400 + +define FIT_ACMODE Memi[$1] # image access mode +define FIT_PFD Memi[$1+1] # pixel file descriptor +define FIT_PIXOFF Memi[$1+2] # pixel offset +define FIT_TOTPIX Memi[$1+3] # size of image in pixfile, chars +define FIT_IO Memi[$1+4] # FITS I/O channel +define FIT_ZCNV Memi[$1+5] # set if on-the-fly conversion needed +define FIT_IOSTAT Memi[$1+6] # i/o status for zfio routines +define FIT_TFORMP Memi[$1+7] # TFORM keyword value pointer +define FIT_TTYPEP Memi[$1+8] # TTYPE keyword value pointer +define FIT_TFIELDS Memi[$1+9] # number of fields in binary table +define FIT_PCOUNT Memi[$1+10] # PCOUNT keyword value + # extra space +define FIT_BSCALE Memd[P2D($1+16)] +define FIT_BZERO Memd[P2D($1+18)] +define FIT_BITPIX Memi[$1+20] # bits per pixel +define FIT_NAXIS Memi[$1+21] # number of axes in image +define FIT_LENAXIS Memi[$1+22+$2-1]# 35:41 = [7] max +define FIT_ZBYTES Memi[$1+30] # Status value for FIT_ZCNV mode +define FIT_HFD Memi[$1+31] # Header file descriptor +define FIT_PIXTYPE Memi[$1+32] +define FIT_CACHEHDR Memi[$1+33] # Cached main header unit's address. +define FIT_CACHEHLEN Memi[$1+34] # Lenght of the above. +define FIT_IM Memi[$1+35] # Has the 'im' descriptor value +define FIT_GROUP Memi[$1+36] +define FIT_NEWIMAGE Memi[$1+37] # Newimage flag +define FIT_HDRPTR Memi[$1+38] # Header data Xtension pointer +define FIT_PIXPTR Memi[$1+39] # Pixel data Xtension pointer +define FIT_NUMOFFS Memi[$1+40] # Number of offsets in cache header. +define FIT_EOFSIZE Memi[$1+41] # Size in char of file before append. +define FIT_XTENSION Memi[$1+42] # Yes, if an Xtension has been read. +define FIT_INHERIT Memi[$1+43] # INHERIT header keyword value. +define FIT_EXTVER Memi[$1+44] # EXTVER value (integer only) +define FIT_EXPAND Memi[$1+45] # Expand the header? +define FIT_MIN Memr[P2R($1+46)]# Minimum pixel value +define FIT_MAX Memr[P2R($1+47)]# Maximum pixel value +define FIT_MTIME Meml[$1+48] # Time of last mod. for FITS unit +define FIT_SVNANR Memr[P2R($1+49)] +define FIT_SVNAND Memd[P2D($1+50)] +define FIT_SVMAPRIN Memi[$1+52] +define FIT_SVMAPROUT Memi[$1+53] +define FIT_SVMAPDIN Memi[$1+54] +define FIT_SVMAPDOUT Memi[$1+55] +define FIT_EXTEND Memi[$1+56] # FITS extend keyword +define FIT_PLMAXLEN Memi[$1+57] # PLIO maximum linelen + # extra space +define FIT_EXTTYPE Memc[P2C($1+70)] # extension type +define FIT_FILENAME Memc[P2C($1+110)] # FILENAME value +define FIT_EXTNAME Memc[P2C($1+150)] # EXTNAME value +define FIT_DATATYPE Memc[P2C($1+190)] # datatype string +define FIT_TITLE Memc[P2C($1+230)] # title string +define FIT_OBJECT Memc[P2C($1+270)] # object string +define FIT_EXTSTYPE Memc[P2C($1+310)] # FITS extension subtype + # extra space + +# The FKS terms carry the fkinit or kernel section arguments. +define FKS_APPEND Memi[$1+400] # YES, NO append an extension +define FKS_INHERIT Memi[$1+401] # YES, NO inherit the main header +define FKS_OVERWRITE Memi[$1+402] # YES, NO overwrite an extension +define FKS_DUPNAME Memi[$1+403] # YES, NO allow duplicated EXTNAME +define FKS_EXTVER Memi[$1+404] # YES, NO allow duplicated EXTNAME +define FKS_EXPAND Memi[$1+405] # YES, NO expand the header +define FKS_PHULINES Memi[$1+406] # Allocated lines in PHU +define FKS_EHULINES Memi[$1+407] # Allocated lines in EHU +define FKS_PADLINES Memi[$1+408] # Additional lines for HU +define FKS_NEWFILE Memi[$1+409] # YES, NO force newfile +define FKS_CACHESIZE Memi[$1+410] # size of header cache +define FKS_SUBTYPE Memi[$1+411] # BINTABLE subtype +define FKS_EXTNAME Memc[P2C($1+412)] # EXTNAME value + # extra space + + +# Reserved FITS keywords known to this code. + +define FK_KEYWORDS "|bitpix|datatype|end|naxis|naxisn|simple|bscale|bzero\ +|origin|iraf-tlm|filename|extend|irafname|irafmax|irafmin|datamax\ +|datamin|xtension|object|pcount|extname|extver|nextend|inherit\ +|zcmptype|tform|ttype|tfields|date|" + +define KW_BITPIX 1 +define KW_DATATYPE 2 +define KW_END 3 +define KW_NAXIS 4 +define KW_NAXISN 5 +define KW_SIMPLE 6 +define KW_BSCALE 7 +define KW_BZERO 8 +define KW_ORIGIN 9 +define KW_IRAFTLM 10 +define KW_FILENAME 11 +define KW_EXTEND 12 +define KW_IRAFNAME 13 +define KW_IRAFMAX 14 +define KW_IRAFMIN 15 +define KW_DATAMAX 16 +define KW_DATAMIN 17 +define KW_XTENSION 18 +define KW_OBJECT 19 +define KW_PCOUNT 20 +define KW_EXTNAME 21 +define KW_EXTVER 22 +define KW_NEXTEND 23 +define KW_INHERIT 24 +define KW_ZCMPTYPE 25 +define KW_TFORM 26 +define KW_TTYPE 27 +define KW_TFIELDS 28 +define KW_DATE 29 diff --git a/sys/imio/iki/fxf/fxfaccess.x b/sys/imio/iki/fxf/fxfaccess.x new file mode 100644 index 00000000..860724f0 --- /dev/null +++ b/sys/imio/iki/fxf/fxfaccess.x @@ -0,0 +1,59 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "fxf.h" + + +# FXF_ACCESS -- Test the accessibility or existence of an existing image, or +# the legality of the name of a new image. Returns status = YES or NO. + +procedure fxf_access (kernel, root, extn, acmode, status) + +int kernel #I IKI kernel +char root[ARB] #I root filename +char extn[ARB] #I extension (SET on output if none specified) +int acmode #I access mode (0 to test only existence) +int status #O status code + +int i +pointer sp, fname, kextn +int access(), iki_validextn(), iki_getextn(), btoi() + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (kextn, FITS_LENEXTN, TY_CHAR) + + # If new image, test only the legality of the given extension. + # This is used to select a kernel given the imagefile extension. + + if (acmode == NEW_IMAGE || acmode == NEW_COPY) { + status = btoi (iki_validextn (kernel, extn) > 0) + call sfree (sp) + return + } + + status = NO + + # If no extension was given, look for a file with the default + # extension, and return the actual extension if an image with the + # default extension is found. + + if (extn[1] == EOS) { + do i = 1, ARB { + if (iki_getextn (kernel, i, Memc[kextn], FITS_LENEXTN) <= 0) + break + call iki_mkfname (root, Memc[kextn], Memc[fname], SZ_PATHNAME) + if (access (Memc[fname], acmode, 0) == YES) { + call strcpy (Memc[kextn], extn, FITS_LENEXTN) + status = YES + break + } + } + } else if (iki_validextn (kernel, extn) == kernel) { + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + if (access (Memc[fname], acmode, 0) == YES) + status = YES + } + + call sfree (sp) +end diff --git a/sys/imio/iki/fxf/fxfaddpar.x b/sys/imio/iki/fxf/fxfaddpar.x new file mode 100644 index 00000000..ce7849f5 --- /dev/null +++ b/sys/imio/iki/fxf/fxfaddpar.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "fxf.h" + +# FXF_ADDPAR -- Encode a parameter in FITS format and add it to the FITS format +# IMIO userarea. + +procedure fxf_addpar (im, pname, dtype, pval) + +pointer im #I image descriptor +char pname[ARB] #I parameter name +int dtype #I SPP datatype of parameter +char pval[ARB] #I string encoded parameter value + +bool bval +real rval +double dval +short sval +long lval +int ival, ip, junk +int ctoi(), ctor(), ctod() +errchk imadds, imaddl, imaddr, imaddd, imastr + +begin + ip = 1 + + switch (dtype) { + case TY_BOOL: + bval = (pval[1] == 'T') + call imaddb (im, pname, bval) + case TY_SHORT: + junk = ctoi (pval, ip, ival) + sval = ival + call imadds (im, pname, sval) + case TY_INT, TY_LONG: + junk = ctoi (pval, ip, ival) + lval = ival + call imaddl (im, pname, lval) + case TY_REAL: + junk = ctor (pval, ip, rval) + call imaddr (im, pname, rval) + case TY_DOUBLE: + junk = ctod (pval, ip, dval) + call imaddd (im, pname, dval) + default: + call imastr (im, pname, pval) + } +end diff --git a/sys/imio/iki/fxf/fxfcache.com b/sys/imio/iki/fxf/fxfcache.com new file mode 100644 index 00000000..c38317aa --- /dev/null +++ b/sys/imio/iki/fxf/fxfcache.com @@ -0,0 +1,24 @@ +# FXFCACHE.COM -- Named common block used to cache filenames and image +# extension information. +# +# ##### This should be reimplemented to use a small package (i.e. functions) +# ##### rather than global common. rf_fname below is using a lot of memory. +# ##### Dynamic memory allocation or a packed string buffer should be used +# ##### instead. Not worth fixing though until the cache code is redone. + +int rf_cachesize +pointer rf_fit[MAX_CACHE] # FITS descriptor +pointer rf_hdrp[MAX_CACHE] # Fits headers pointer +pointer rf_pixp[MAX_CACHE] # Fits pixels pointer +pointer rf_pextn[MAX_CACHE] # EXTNAME pointer +pointer rf_pextv[MAX_CACHE] # EXTVER pointer +int rf_lru[MAX_CACHE] # Lowest value is oldest slot +long rf_time[MAX_CACHE] # Time when entry was cached +long rf_mtime[MAX_CACHE] # Modify time of file in cache +int rf_hdr[MAX_CACHE] # FITS Primary header data +int rf_fitslen[MAX_CACHE] # Size Primary header data +char rf_fname[SZ_PATHNAME,MAX_CACHE] # Header file pathname + +common /fxflcachec/ rf_time, rf_mtime +common /fxfcachec/ rf_cachesize, rf_fit, rf_hdrp, rf_pixp, rf_pextn, + rf_pextv, rf_lru, rf_hdr, rf_fitslen, rf_fname diff --git a/sys/imio/iki/fxf/fxfclose.x b/sys/imio/iki/fxf/fxfclose.x new file mode 100644 index 00000000..72313316 --- /dev/null +++ b/sys/imio/iki/fxf/fxfclose.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "fxf.h" + +# FXF_CLOSE -- Close a FITS format image. There is little for us to do, since +# IMIO will already have updated the header if necessary and flushed any pixel +# output. Neither do we have to deallocate the IMIO descriptor, since it was +# allocated by IMIO. + +procedure fxf_close (im, status) + +pointer im #I image descriptor +int status #O status value + +pointer fit +errchk close + +begin + fit = IM_KDES(im) + + # Reset the IEEE interface to its original state. + switch (IM_ACMODE(im)) { + case READ_ONLY, READ_WRITE, WRITE_ONLY: + call ieesnanr (FIT_SVNANR(fit)) + call ieesmapr (FIT_SVMAPRIN(fit), FIT_SVMAPROUT(fit)) + call ieesnand (FIT_SVNAND(fit)) + call ieesmapd (FIT_SVMAPDIN(fit), FIT_SVMAPDOUT(fit)) + default: + ; + } + + # Close the fits file. + if (IM_PFD(im) != NULL) + call close (IM_PFD(im)) + + # Deallocate the FIT descriptor. + call mfree (fit, TY_STRUCT) + + status = OK +end diff --git a/sys/imio/iki/fxf/fxfcopy.x b/sys/imio/iki/fxf/fxfcopy.x new file mode 100644 index 00000000..3fb4d51b --- /dev/null +++ b/sys/imio/iki/fxf/fxfcopy.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# FXF_COPY -- Copy an image. A special operator is provided for fast, blind +# copies of entire images. + +procedure fxf_copy (kernel, oroot, oextn, nroot, nextn, status) + +int kernel #I IKI kernel +char oroot[ARB] #I old image root name +char oextn[ARB] #I old image extn +char nroot[ARB] #I new image root name +char nextn[ARB] #I old image extn +int status + +pointer sp +pointer ohdr_fname, nhdr_fname + +begin + call smark (sp) + call salloc (ohdr_fname, SZ_PATHNAME, TY_CHAR) + call salloc (nhdr_fname, SZ_PATHNAME, TY_CHAR) + + # Generate filenames. + call iki_mkfname (oroot, oextn, Memc[ohdr_fname], SZ_PATHNAME) + call iki_mkfname (nroot, nextn, Memc[nhdr_fname], SZ_PATHNAME) + + iferr (call fcopy (Memc[ohdr_fname], Memc[nhdr_fname])) + call erract (EA_WARN) + + call sfree (sp) + status = OK +end diff --git a/sys/imio/iki/fxf/fxfctype.x b/sys/imio/iki/fxf/fxfctype.x new file mode 100644 index 00000000..f916e344 --- /dev/null +++ b/sys/imio/iki/fxf/fxfctype.x @@ -0,0 +1,72 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "fxf.h" + + +# FXF_CTYPE -- Determine the type of a FITS card. + +int procedure fxf_ctype (card, kwindex) + +char card[ARB] #I FITS card (or keyword) +int kwindex #O index number, if any + +pointer sp, kwname +char kw[SZ_KEYWORD] +int index, ch, i, ip +int strncmp(), strdic(), strlen(), ctoi() +string keywords FK_KEYWORDS + +begin + call smark (sp) + call salloc (kwname, LEN_CARD, TY_CHAR) + + # Check for a reference to one of the NAXIS keywords. + kwindex= 0 + if (card[1] == 'N') + if (strncmp (card, "NAXIS", 5) == 0) { + ch = card[6] + if (ch == EOS || (IS_DIGIT(ch) && card[7] == ' ')) { + kwindex = TO_INTEG(ch) + } + call sfree (sp) + return (KW_NAXIS) + } + + # See if it is one of the "T"-prefixed (binary table) keywords. + if (card[1] == 'T') { + ip = 6 + if (strncmp (card, "TFORM", 5) == 0) { + if (ctoi (card, ip, kwindex) < 1) + kwindex = 0 + call sfree (sp) + return (KW_TFORM) + } + if (strncmp (card, "TTYPE", 5) == 0) { + if (ctoi (card, ip, kwindex) < 1) + kwindex = 0 + call sfree (sp) + return (KW_TTYPE) + } + } + + # Get keyword name in lower case with no blanks. + do i = 1, SZ_KEYWORD { + if (IS_WHITE(card[i])) { + kw[i] = EOS + break + } else if (IS_UPPER(card[i])) + kw[i] = TO_LOWER (card[i]) + else + kw[i] = card[i] + } + + # Look up keyword in dictionary. Abbreviations are not permitted. + index = strdic (kw, Memc[kwname], LEN_CARD, keywords) + if (index != 0) + if (strlen(kw) != strlen(Memc[kwname])) + index = 0 + + call sfree (sp) + return (index) +end diff --git a/sys/imio/iki/fxf/fxfdelete.x b/sys/imio/iki/fxf/fxfdelete.x new file mode 100644 index 00000000..ae7fbffc --- /dev/null +++ b/sys/imio/iki/fxf/fxfdelete.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "fxf.h" + +# FXF_DELETE -- Delete a FITS file. NOTE: it is not possible to delete an +# individual extension at this time. + +procedure fxf_delete (kernel, root, extn, status) + +int kernel #I IKI kernel +char root[ARB] #I root filename +char extn[ARB] #I header file extension +int status #O status value + +int cindx +pointer sp, fname, im, tmp +pointer immapz() +bool streq() + +errchk syserrs +include "fxfcache.com" + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (tmp, SZ_PATHNAME, TY_CHAR) + + call fxf_init() + status = OK + + # Get the file extension if not given. + if (extn[1] == EOS) { + call fxf_access (kernel, root, extn, READ_ONLY, status) + if (status == NO) { + call sfree (sp) + status = ERR + return + } + } + + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + call strcpy (Memc[fname], Memc[tmp], SZ_PATHNAME) + call strcat ("[0]", Memc[tmp], SZ_PATHNAME) + iferr (im = immapz (Memc[tmp], READ_ONLY, 0)) + call syserrs (SYS_FXFDELMEF, Memc[fname]) + else + call imunmap (im) + + iferr (call delete (Memc[fname])) + call erract (EA_WARN) + + # Remove the image from the FITS cache if found. + do cindx=1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + if (streq (Memc[fname], rf_fname[1,cindx])) { + call mfree (rf_pextv[cindx], TY_INT) + call mfree (rf_pextn[cindx], TY_CHAR) + call mfree (rf_pixp[cindx], TY_INT) + call mfree (rf_hdrp[cindx], TY_INT) + call mfree (rf_fit[cindx], TY_STRUCT) + call mfree (rf_hdr[cindx], TY_CHAR) + rf_fit[cindx] = NULL + rf_lru[cindx] = 0 + rf_fname[1,cindx] = EOS + } + } + + status = OK + call sfree (sp) +end diff --git a/sys/imio/iki/fxf/fxfencode.x b/sys/imio/iki/fxf/fxfencode.x new file mode 100644 index 00000000..ea2e83dd --- /dev/null +++ b/sys/imio/iki/fxf/fxfencode.x @@ -0,0 +1,348 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "fxf.h" + +# FXFENCODE.X -- Routines to encode a keyword, its value and a comment into +# a FITS card. +# +# fxf_encode_axis (root, keyword, axisno) +# fxf_encode_date (ctime, datestr, szdate, format, cutover) +# +# fxf_encodeb (keyword, param, card, comment) +# fxf_encodei (keyword, param, card, comment) +# fxf_encodel (keyword, param, card, comment) +# fxf_encoder (keyword, param, card, comment, precision) +# fxf_encoded (keyword, param, card, comment, precision) +# fxf_encodec (keyword, param, maxch, card, comment) +# +# fxf_akwc (keyword, value, len, comment, pn) +# fxf_akwb (keyword, value, comment, pn) +# fxf_akwi (keyword, value, comment, pn) +# fxf_akwr (keyword, value, comment, precision, pn) +# fxf_akwd (keyword, value, comment, precision, pn) +# +# Encode_axis adds an axis number to a keyword ("rootXXX"). Encode_date +# encodes the current date as a string in the form "dd/mm/yy". + + +# FXF_ENCODEB -- Encode a boolean parameter into a FITS card. + +procedure fxf_encodeb (keyword, param, card, comment) + +char keyword[ARB] # FITS keyword +int param # integer parameter equal to YES/NO +char card[ARB] # FITS card image +char comment[ARB] # FITS comment string + +char truth + +begin + if (param == YES) + truth = 'T' + else + truth = 'F' + + call sprintf (card, LEN_CARD, "%-8.8s= %20c / %-47.47s") + call pargstr (keyword) + call pargc (truth) + call pargstr (comment) +end + + +# FXF_ENCODEI -- Encode an integer parameter into a FITS card. + +procedure fxf_encodei (keyword, param, card, comment) + +char keyword[ARB] # FITS keyword +int param # integer parameter +char card[ARB] # FITS card image +char comment[ARB] # FITS comment string + +begin + call sprintf (card, LEN_CARD, "%-8.8s= %20d / %-47.47s") + call pargstr (keyword) + call pargi (param) + call pargstr (comment) +end + + +# FXF_ENCODEL -- Encode a long parameter into a FITS card. + +procedure fxf_encodel (keyword, param, card, comment) + +char keyword[ARB] # FITS keyword +long param # long integer parameter +char card[ARB] # FITS card image +char comment[ARB] # FITS comment string + +begin + call sprintf (card, LEN_CARD, "%-8.8s= %20d / %-47.47s") + call pargstr (keyword) + call pargl (param) + call pargstr (comment) +end + + +# FXF_ENCODER -- Encode a real parameter into a FITS card. + +procedure fxf_encoder (keyword, param, card, comment, precision) + +char keyword[ARB] # FITS keyword +real param # real parameter +char card[ARB] # FITS card image +char comment[ARB] # FITS comment card +int precision # precision of real + +begin + call sprintf (card, LEN_CARD, "%-8.8s= %20.*e / %-47.47s") + call pargstr (keyword) + call pargi (precision) + call pargr (param) + call pargstr (comment) +end + + +# FXF_ENCODED -- Encode a double parameter into a FITS card. + +procedure fxf_encoded (keyword, param, card, comment, precision) + +char keyword[ARB] # FITS keyword +double param # double parameter +char card[ARB] # FITS card image +char comment[ARB] # FITS comment string +int precision # FITS precision + +begin + call sprintf (card, LEN_CARD, "%-8.8s= %20.*e / %-47.47s") + call pargstr (keyword) + call pargi (precision) + call pargd (param) + call pargstr (comment) +end + + +# FXF_ENCODE_AXIS -- Add the axis number to axis dependent keywords. + +procedure fxf_encode_axis (root, keyword, axisno) + +char root[ARB] # FITS root keyword +char keyword[ARB] # FITS keyword +int axisno # FITS axis number + +int len, strlen() + +begin + call strcpy (root, keyword, SZ_KEYWORD) + len = strlen (keyword) + call sprintf (keyword, SZ_KEYWORD, "%*.*s%d") + call pargi (-len) + call pargi (len) + call pargstr (root) + call pargi (axisno) +end + + +# FXF_ENCODEC -- Procedure to encode an IRAF string parameter into a FITS card. + +procedure fxf_encodec (keyword, param, maxch, card, comment) + +char keyword[LEN_CARD] # FITS keyword +char param[LEN_CARD] # FITS string parameter +int maxch # maximum chars in value string +char card[LEN_CARD+1] # FITS card image +char comment[LEN_CARD] # comment string + +int nblanks, maxchar, slashp + +begin + maxchar = max(8, min (maxch, LEN_OBJECT)) + slashp = 32 + nblanks = LEN_CARD - (slashp + 1) + if (maxchar >= 19) { + slashp = 1 + nblanks = max (LEN_OBJECT - maxchar - slashp+3, 1) + } + + call sprintf (card, LEN_CARD, "%-8.8s= '%*.*s' %*t/ %*.*s") + call pargstr (keyword) + call pargi (-maxchar) + call pargi (maxchar) + call pargstr (param) + call pargi (slashp) + call pargi (-nblanks) + call pargi (nblanks) + call pargstr (comment) +end + + +# FXF_ENCODE_DATE -- Encode the current date as a string value. +# +# New Y2K format: yyyy-mm-ddThh:mm:sec +# Old FITS format: dd/mm/yy +# Old TLM format: hh:mm:ss (dd/mm/yyyy) +# +# We still write the old format for dates 1999 or less. + +procedure fxf_encode_date (ctime, datestr, maxch, format, cutover) + +long ctime #I time value to be encoded +char datestr[ARB] #O string containing the date +int maxch #I number of chars in the date string +char format[ARB] #I desired date format for old dates +int cutover #I write new format for years >= cutover + +int tm[LEN_TMSTRUCT], nchars +int dtm_encode_hms() +long lsttogmt() +bool streq() + +begin + # Find out what year it is. + call brktime (ctime, tm) + + # Encode in ISO format for years >= cutover year. + + if (TM_YEAR(tm) >= cutover) { + # ISO format is used for all new date stamps. + call brktime (lsttogmt(ctime), tm) + nchars = dtm_encode_hms (datestr, maxch, + TM_YEAR(tm), TM_MONTH(tm), TM_MDAY(tm), + TM_HOUR(tm), TM_MIN(tm), double(TM_SEC(tm)), 0, 0) + + } else if (streq (format, "TLM")) { + # TLM format is for old-format DATE-TLM keywords. + call sprintf (datestr, maxch, "%02d:%02d:%02d (%02d/%02d/%d)") + call pargi (TM_HOUR(tm)) + call pargi (TM_MIN(tm)) + call pargi (TM_SEC(tm)) + call pargi (TM_MDAY(tm)) + call pargi (TM_MONTH(tm)) + call pargi (TM_YEAR(tm)) + + } else { + # The default otherwise is the old FITS format. + call sprintf (datestr, maxch, "%02d/%02d/%02d") + call pargi (TM_MDAY(tm)) + call pargi (TM_MONTH(tm)) + call pargi (mod(TM_YEAR(tm),100)) + + } +end + + +# FXF_AKWC -- Encode keyword, value and comment into a FITS card and +# append it to a buffer pointed by pn. + +procedure fxf_akwc (keyword, value, len, comment, pn) + +char keyword[SZ_KEYWORD] # keyword name +char value[ARB] # keyword value +int len # length of value +char comment[ARB] # comment +pointer pn # pointer to a char area +char card[LEN_CARD] + +begin + call fxf_encodec (keyword, value, len, card, comment) + call amovc (card, Memc[pn], LEN_CARD) + pn = pn + LEN_CARD +end + + +# FXF_AKWB -- Encode keyword, value and comment into a FITS card and +# append it to a buffer pointed by pn. + +procedure fxf_akwb (keyword, value, comment, pn) + +char keyword[SZ_KEYWORD] # I keyword name +int value # I Keyword value (YES, NO) +char comment[ARB] # I Comment +pointer pn # I/O Pointer to a char area + +pointer sp, pc + +begin + call smark (sp) + call salloc (pc, LEN_CARD, TY_CHAR) + + call fxf_encodeb (keyword, value, Memc[pc], comment) + call amovc (Memc[pc], Memc[pn], LEN_CARD) + pn = pn + LEN_CARD + + call sfree (sp) +end + + +# FXF_AKWI -- Encode keyword, value and comment into a FITS card and +# append it to a buffer pointed by pn. + +procedure fxf_akwi (keyword, value, comment, pn) + +char keyword[SZ_KEYWORD] # I keyword name +int value # I Keyword value +char comment[ARB] # I Comment +pointer pn # I/O Pointer to a char area + +pointer sp, pc + +begin + call smark (sp) + call salloc (pc, LEN_CARD, TY_CHAR) + + call fxf_encodei (keyword, value, Memc[pc], comment) + call amovc (Memc[pc], Memc[pn], LEN_CARD) + pn = pn + LEN_CARD + + call sfree (sp) +end + + +# FXF_AKWR -- Encode keyword, value and comment into a FITS card and +# append it to a buffer pointed by pn. + +procedure fxf_akwr (keyword, value, comment, precision, pn) + +char keyword[SZ_KEYWORD] # I keyword name +real value # I Keyword value +char comment[ARB] # I Comment +int precision +pointer pn # I/O Pointer to a char area + +pointer sp, pc + +begin + call smark (sp) + call salloc (pc, LEN_CARD, TY_CHAR) + + call fxf_encoder (keyword, value, Memc[pc], comment, precision) + call amovc (Memc[pc], Memc[pn], LEN_CARD) + pn = pn + LEN_CARD + + call sfree (sp) +end + + +# FXF_AKWD -- Encode keyword, value and comment into a FITS card and +# append it to a buffer pointed by pn. + +procedure fxf_akwd (keyword, value, comment, precision, pn) + +char keyword[SZ_KEYWORD] # I keyword name +double value # I Keyword value +char comment[ARB] # I Comment +int precision +pointer pn # I/O Pointer to a char area + +pointer sp, pc + +begin + call smark (sp) + call salloc (pc, LEN_CARD, TY_CHAR) + + call fxf_encoded (keyword, value, Memc[pc], comment, precision) + call amovc (Memc[pc], Memc[pn], LEN_CARD) + pn = pn + LEN_CARD + + call sfree (sp) +end diff --git a/sys/imio/iki/fxf/fxfexpandh.x b/sys/imio/iki/fxf/fxfexpandh.x new file mode 100644 index 00000000..9e00d582 --- /dev/null +++ b/sys/imio/iki/fxf/fxfexpandh.x @@ -0,0 +1,375 @@ +include +include +include +include +include +include +include "fxf.h" + +define MIN_BUFSIZE 2880 + + +# FXF_EXPANDH -- Routine to expand all the headers of a MEF file. The calling +# routine only requires that extension 'group' be expanded but when dealing +# with large MEF files with many extensions this procedure can take a long +# time if the application code wants to expand more than one header. +# fxf_expandh will expand all the headers in the file so they will have at +# least 'nlines' blank cards. + +procedure fxf_expandh (in_fd, out_fd, nlines, group, nbks, hdroff, pixoff) + +int in_fd #I input file descriptor +int out_fd #I output file descriptor +int nlines #I minimum number of blank cards +int group #I group that initiated the expansion +int nbks #I numbers of blocks to expand group 'group' +int hdroff #O new offset for beginning of 'group' +int pixoff #0 new offset for beginning of data + +pointer hd, ip, op, buf +char line[80], endl[80] +int gn, newc, k, nchars, nbk, hsize +int fxf_xaddl(), read() + +int bufsize, psize, rem, hoffset, poffset +int note(), fstati() +errchk malloc, read, write + +begin + # In case nlines is zero set a minimum > 0. + nlines = max (nlines, 10) + + # Initialize a blank line. + call amovks (" ", line, LEN_CARD) + + # Initialize END card image. + call amovc ("END", endl, 3) + call amovks (" ", endl[4], LEN_CARD-3) + + call fseti (in_fd, F_ADVICE, SEQUENTIAL) + call fseti (out_fd, F_ADVICE, SEQUENTIAL) + + bufsize = max (MIN_BUFSIZE, fstati (in_fd, F_BUFSIZE)) + call malloc (buf, bufsize, TY_CHAR) + + gn = 0 + hd = buf + + repeat { + hd = buf + if (group == gn) + hdroff = note(out_fd) + + # Read and write header information. The last block must + # have the END card and is output from this routine. + + iferr (call fxf_xhrd (in_fd, out_fd, Memc[buf], bufsize, hoffset, + poffset, hsize)) + break + + # Determine the number of cards to expand. newc is in blocks + # of 36 cards. 0, 36, 72, ... + + newc = fxf_xaddl (buf, hsize, nlines) + + # expand the given group at least one block + if (newc == 0 && nbks > 0 && group == gn) + newc = nbks * 36 + + # OP points to the top of the last block read, IP to the bottom. + op = buf + hsize - FITS_BLOCK_BYTES + ip = buf + hsize + + if (newc == 0) { + # Leave space for the END card. + ip = ip - 80 + } else { + # Write current buffer before writing blanks. + call miipak (Memc[op], Memc[op], FITS_BLOCK_BYTES, + TY_CHAR,MII_BYTE) + call write (out_fd, Memc[op], FITS_BLOCK_CHARS) + + # Use the same buffer space since we are using blanks + ip = ip - FITS_BLOCK_BYTES + op = ip + } + + # Write the blank cards. + do k = 1, newc-1 { + call amovc (line, Memc[ip], LEN_CARD) + ip = ip + LEN_CARD + if (mod (k,36) == 0) { + # We have more than one block of blanks. + call miipak (Memc[op], Memc[op], nchars, TY_CHAR, MII_BYTE) + call write (out_fd, Memc[op], FITS_BLOCK_CHARS) + + # Notice we used the same buffer space + ip = ip - FITS_BLOCK_BYTES + op = ip + } + } + + # Finally the END card. + call amovc (endl, Memc[ip], LEN_CARD) + nchars = 2880 + call miipak (Memc[op], Memc[op], nchars, TY_CHAR, MII_BYTE) + call write (out_fd, Memc[op], nchars/2) + + # Get the number of blocks of pixel data to copy. We are not + # changing anything; it is straight copy. + + psize = (hoffset - poffset) + + nbk = psize / bufsize + rem = mod(psize,bufsize) + + if (group == gn) + pixoff = note(out_fd) + + do k = 1, nbk { + nchars = read (in_fd, Memc[buf], bufsize) + call write (out_fd, Memc[buf], bufsize) + } + if (rem > 0) { + nchars = read (in_fd, Memc[buf], rem) + call write (out_fd, Memc[buf], rem) + } + gn = gn + 1 + } + + call mfree (buf, TY_CHAR) +end + + +# FXF_XHRD -- Procedure to read 2880 bytes blocks of header from 'in' +# and copy them to 'out'. The last block read contains the END card +# and is pass to the calling routine which will write it out to 'out. + +procedure fxf_xhrd (in, out, buf, bufsize, hoffset, poffset, hsize) + +int in #I Input file descriptor +int out #I output file descriptor +char buf[ARB] #I Working buffer +int bufsize #I Workign buffer size +int hoffset #O Header offset for next group +int poffset #O Data offset for current group +int hsize #O Number of cards read in header + +pointer sp, hb +int nblks, totpix, i, j, ip, nchars +int strncmp(), note(), read() +bool end_card, fxf_xn_decode_blk1() + +include "fxfcache.com" +errchk syserr, read, write + +begin + call smark (sp) + call salloc (hb, 1440, TY_CHAR) + + hoffset = note (in) + + # Read first block of header. + nchars = read (in, Memc[hb], FITS_BLOCK_CHARS) + if (nchars == EOF) { + call sfree (sp) + call syserr (SYS_FXFRFEOF) + } + + call miiupk (Memc[hb], buf, FITS_BLOCK_BYTES, MII_BYTE,TY_CHAR) + end_card = fxf_xn_decode_blk1 (buf, totpix) + if (!end_card) { + call miipak (buf, Memc[hb], FITS_BLOCK_BYTES, TY_CHAR, MII_BYTE) + call write (out, Memc[hb], FITS_BLOCK_CHARS) + } + ip = FITS_BLOCK_BYTES + 1 + + nblks = 1 + if (!end_card) { + # Continue reading header until the block with END + # which is the last before the data block. + + while (read (in, Memc[hb], FITS_BLOCK_CHARS) != EOF) { + call miiupk (Memc[hb], buf[ip], FITS_BLOCK_BYTES, + MII_BYTE,TY_CHAR) + + # Look for the END card + do i = 0, 35 { + j = ip + i*LEN_CARD + if (buf[j] == 'E') { + if (strncmp (buf[j], "END ", 8) == 0) + end_card = true + } + } + nblks = nblks + 1 + if (end_card) + break + call miipak (buf[ip], Memc[hb], FITS_BLOCK_BYTES, + TY_CHAR, MII_BYTE) + call write (out, Memc[hb], FITS_BLOCK_CHARS) + ip = ip + FITS_BLOCK_BYTES + + # If the header is really big we can run out of + # buffer space. Revert back to the beginning. + + if (ip > bufsize) { + ip = 1 + nblks = 1 + } + } + } + + hsize = nblks * 36 * LEN_CARD + + # We are at the beginning of the pixel area. + poffset = note (in) + + # Get the beginnning of the next header. + hoffset = poffset + totpix + + call sfree (sp) +end + + +# FXF_XN_DECODE_BLK1 -- Function that return true if the 1st block of a header +# contains the END card. The size of the pixel are is also returned. + +bool procedure fxf_xn_decode_blk1 (buf, datalen) + +char buf[ARB] #I header data buffer +int datalen #O length of data area in chars + +char card[LEN_CARD] +int totpix, nbytes, index, k, i, pcount, bitpix, naxis, ip +int len_axis[7] +int fxf_ctype() +bool end_card +errchk syserr, syserrs + +begin + # Read successive lines of the 1st header block + pcount = 0 + + end_card = false + do k = 0, 35 { + ip = k*LEN_CARD + 1 + + # Copy into a one line buffer, we need to EOS mark. + call strcpy (buf[ip], card, LEN_CARD) + switch (fxf_ctype (card, index)) { + case KW_END: + end_card = true + break + case KW_PCOUNT: + call fxf_geti (card, pcount) + case KW_BITPIX: + call fxf_geti (card, bitpix) + case KW_NAXIS: + if (index == 0) { + call fxf_geti (card, naxis) + if (naxis < 0 ) + call syserr (SYS_FXFRFBNAXIS) + } else + call fxf_geti (card, len_axis[index]) + default: + ; + } + } + + # Calculate the length of the data area of the current extension, + # measured in SPP chars and rounded up to an integral number of FITS + # logical blocks. + + if (naxis != 0) { + totpix = len_axis[1] + do i = 2, naxis + totpix = totpix * len_axis[i] + + # Compute the size of the data area (pixel matrix plus PCOUNT) + # in bytes. Be careful not to overflow a 32 bit integer. + + nbytes = (totpix + pcount) * (abs(bitpix) / NBITS_BYTE) + + # Round up to fill the final 2880 byte FITS logical block. + nbytes = ((nbytes + 2880-1) / 2880) * 2880 + + datalen = nbytes / SZB_CHAR + + } else + datalen = 0 + + return (end_card) +end + + +# FXF_XADDL -- Algorithm to find the number of blank cards stored in the +# input buffer. This is the number from the end of the buffer up to the +# last non blank card (excluding the END card). The function returns the +# number of extra header cards (in multiple of 36) that is necessary to +# add to the current header. + +int procedure fxf_xaddl (hd, ncua, nlines) + +pointer hd #U header area pointer +int ncua #I number of characters in the user area +int nlines #I minimum number of header lines to be added + +int ip, nbc, k, ncards, nkeyw +int strncmp() + +begin + # Go to the end of buffer and get last line pointer + ip = hd + ncua - LEN_CARD + + # See if line is blank. + nbc = 0 + while (ip > hd) { + # Check for nonblank card + do k = 0, LEN_CARD-1 + if (Memc[ip+k] != ' ') + break + + # Since we are counting from the bottom, the first keyword + # (except END) would end counting. + + if (k != LEN_CARD && k != 0) # nonblank keyw card reached + break + else if (k == 0) { + # Just bypass END and continue looking for blank cards + if (strncmp ("END ", Memc[ip], 8) == 0) { + # Clear this card as it will be written at the + # end of the output header. + call amovkc (" ", Memc[ip], LEN_CARD) + ip = ip - LEN_CARD + next + } else + break + } else + nbc = nbc + 1 + ip = ip - LEN_CARD + } + + # Calculate the number of keywords right before the last blank + # card and right after the last non-blank keyword, excluding the + # END card + + nkeyw = (ip-hd)/80 + 1 + + ncards = ncua / LEN_CARD + + # Calculate the complement with respect to 36 + ncards = ((ncards + 35)/36)*36 - ncards + nbc = nbc + ncards + + + if (nbc < nlines) { + # Lets add nlines-nbc cards to the header + ncards = nlines - nbc + + # Adjust to a 36 cards boundary. + ncards = 36 - mod (ncards, 36) + ncards + } else + ncards = 0 + + return (ncards) +end diff --git a/sys/imio/iki/fxf/fxfget.x b/sys/imio/iki/fxf/fxfget.x new file mode 100644 index 00000000..87b80d4f --- /dev/null +++ b/sys/imio/iki/fxf/fxfget.x @@ -0,0 +1,182 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "fxf.h" + +# FXFGET.X -- Procedures used to get (decode) typed values from FITS cards. +# +# fxf_get[bird] (card, value) +# fxf_gstr (card, outstr, maxch) +# fxf_getcmt (card, comment, maxch) +# fxf_gltm (time, date, limtime) +# +# The value is returned in the output argument. Zero is returned if the +# conversion fails. + + +# FXF_GETI -- Return the integer value of a FITS encoded card. + +procedure fxf_geti (card, ival) + +char card[ARB] # card to be decoded +int ival # receives integer value + +int ip, ctoi() +char sval[FITS_SZVALSTR] + +begin + call fxf_gstr (card, sval, FITS_SZVALSTR) + ip = 1 + if (ctoi (sval, ip, ival) <= 0) + ival = 0 +end + + +# FXF_GETR -- Return the real value of a FITS encoded card. + +procedure fxf_getr (card, rval) + +char card[ARB] # card to be decoded +real rval # receives integer value + +int ip, ctor() +char sval[FITS_SZVALSTR] + +begin + call fxf_gstr (card, sval, FITS_SZVALSTR) + ip = 1 + if (ctor (sval, ip, rval) <= 0) + rval = 0.0 +end + + +# FXF_GETD -- Return the double value of a FITS encoded card. + +procedure fxf_getd (card, dval) + +char card[ARB] # card to be decoded +double dval # receives integer value + +int ip, ctod() +char sval[FITS_SZVALSTR] + +begin + call fxf_gstr (card, sval, FITS_SZVALSTR) + ip = 1 + if (ctod (sval, ip, dval) <= 0) + dval = 0.0 +end + + +# FXF_GETB -- Return the boolean/integer value of a FITS encoded card. + +procedure fxf_getb (card, bval) + +char card[ARB] # card to be decoded +int bval # receives YES/NO + +char sval[FITS_SZVALSTR] + +begin + call fxf_gstr (card, sval, FITS_SZVALSTR) + if (sval[1] == 'T') + bval = YES + else + bval = NO +end + + +# FXF_GSTR -- Get the string value of a FITS encoded card. Strip leading +# and trailing whitespace and any quotes. + +procedure fxf_gstr (card, outstr, maxch) + +char card[ARB] # FITS card to be decoded +char outstr[ARB] # output string to receive parameter value +int maxch + +int ip, op +int ctowrd(), strlen() + +begin + ip = FITS_STARTVALUE + if (ctowrd (card, ip, outstr, maxch) > 0) { + # Strip trailing whitespace. + op = strlen (outstr) + while (op > 0 && (IS_WHITE(outstr[op]) || outstr[op] == '\n')) + op = op - 1 + outstr[op+1] = EOS + } else + outstr[1] = EOS +end + + +# FXF_GETCMT -- Get the comment field of a FITS encoded card. + +procedure fxf_getcmt (card, comment, maxch) + +char card[ARB] #I FITS card to be decoded +char comment[ARB] #O output string to receive comment +int maxch #I max chars out + +int ip, op +int lastch + +begin + # Find the slash which marks the beginning of the comment field. + ip = FITS_ENDVALUE + 1 + while (card[ip] != EOS && card[ip] != '\n' && card[ip] != '/') + ip = ip + 1 + + # Copy the comment to the output string, omitting the /, any + # trailing blanks, and the newline. + + lastch = 0 + do op = 1, maxch { + if (card[ip] == EOS) + break + ip = ip + 1 + comment[op] = card[ip] + if (card[ip] > ' ') + lastch = op + } + comment[lastch+1] = EOS +end + + +# FXF_GLTM -- Procedure to convert an input time stream with hh:mm:ss +# and date stream dd/mm/yy into seconds from jan 1st 1980. + +procedure fxf_gltm (time, date, limtime) + +char time[ARB], date[ARB] +int limtime + +int month_to_days[12], adays +int hr,mn,sec,days,month,year, ip, iy, days_per_year, ctoi(), i +data month_to_days / 0,31,59,90,120,151,181,212,243,273,304,334/ + +begin + + ip = 1; ip = ctoi (time, ip, hr) + ip = 1; ip = ctoi (time[4], ip, mn) + ip = 1; ip = ctoi (time[7], ip, sec) + + sec = sec + mn * 60 + hr * 3600 + + ip = 1; ip = ctoi (date, ip, days) + ip = 1; ip = ctoi (date[4], ip, month) + ip = 1; ip = ctoi (date[7], ip, year) + + days_per_year = 0 + iy = year + 1900 + do i = 1, iy - 1980 + days_per_year = days_per_year + 365 + + adays = (year - 80) / 4 + if (month > 2) + adays = adays + 1 + + days = adays + days-1 + days_per_year + month_to_days[month] + limtime = sec + days * 86400 +end diff --git a/sys/imio/iki/fxf/fxfhextn.x b/sys/imio/iki/fxf/fxfhextn.x new file mode 100644 index 00000000..7f8a879d --- /dev/null +++ b/sys/imio/iki/fxf/fxfhextn.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "fxf.h" + + +# FXF_GETHDREXTN -- Get the default header file extension. + +procedure fxf_gethdrextn (im, o_im, acmode, outstr, maxch) + +pointer im, o_im #I image descriptors +int acmode #I image access mode +char outstr[ARB] #O receives header extension +int maxch #I max chars out + +bool inherit +int kernel, old_kernel +int fnextn(), iki_getextn(), iki_getpar() + +begin + # Use the same extension as the input file if this is a new copy + # image of the same type as the input and inherit is enabled. + # If we have to get the extension using iki_getextn, the default + # extension for a new image is the first extension defined (index=1). + + kernel = IM_KERNEL(im) + + old_kernel = 0 + if (acmode == NEW_COPY && o_im != NULL) + old_kernel = IM_KERNEL(o_im) + + inherit = (iki_getpar ("inherit") == YES) + if (inherit && acmode == NEW_COPY && kernel == old_kernel) { + if (fnextn (IM_HDRFILE(im), outstr, maxch) <= 0) + call strcpy (DEF_HDREXTN, outstr, maxch) + } else if (iki_getextn (kernel, 1, outstr, maxch) < 0) + call strcpy (DEF_HDREXTN, outstr, maxch) +end diff --git a/sys/imio/iki/fxf/fxfksection.x b/sys/imio/iki/fxf/fxfksection.x new file mode 100644 index 00000000..cb37b4e5 --- /dev/null +++ b/sys/imio/iki/fxf/fxfksection.x @@ -0,0 +1,475 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include "fxf.h" + +# FXFKSECTION.X -- Routines to parse the FITS kernel section into +# parameter names and values. + +define KS_EXTNAME 1 +define KS_EXTVER 2 +define KS_APPEND 3 +define KS_NOAPPEND 4 +define KS_OVERWRITE 5 +define KS_DUPNAME 6 +define KS_INHERIT 7 +define KS_NOINHERIT 8 +define KS_NODUPNAME 9 +define KS_NOOVERWRITE 10 +define KS_EXPAND 11 +define KS_PHULINES 12 +define KS_EHULINES 13 +define KS_PADLINES 14 +define KS_NOEXPAND 15 +define KS_CACHESIZE 16 +define KS_TYPE 17 +define ERROR -2 + + +# FXF_KSECTION -- Procedure to parse and analyze a string of the form: +# +# "keyword=value,keyword+,keyword-,..." +# e.g., +# "[extname=]name,[extver=]23,append,inherit+,overwrite+,dupname-" +# +# The 'extver' numeric field is position dependent if it does not have +# the parameter name. The 'group' output variable is not -1 when specified +# as the 1st number in the section. + +procedure fxf_ksection (ksection, fit, group) + +char ksection[ARB] #I String with kernel section +pointer fit #I Fits structure pointer +int group #O Extension number + +bool extn +char outstr[LEN_CARD] +char identif[LEN_CARD] +int ip, jp, nident, nexpr, junk, nch, ty, token, ival +int lex_type, fxf_ks_lex(), ctoi(), ctotok(), lexnum() +errchk syserr, syserrs + +begin + # The default values should have been already initialized + # with a call fxf_ksinit(). + + ip = 1 + nexpr = 0 + nident = 0 + extn = false + group = -1 + identif[1] = EOS + + repeat { + # Advance to the next keyword. + token = ctotok (ksection, ip, outstr, LEN_CARD) + + switch (token) { + case TOK_EOS: + break + case TOK_NEWLINE: + break + + case TOK_NUMBER: + if (nexpr != 1 && nexpr != 2 && extn) + call syserr (SYS_FXFKSNV) + jp = 1 + ty = lexnum (outstr, jp, nch) + if (ty != LEX_DECIMAL) + call syserr (SYS_FXFKSNDEC) + jp = 1 + junk = ctoi (outstr, jp, ival) + if (nexpr == 0) { + group = ival + identif[1] = 1 + } else + FKS_EXTVER(fit) = ival + nexpr = nexpr + 1 + + case TOK_PUNCTUATION: + if (outstr[1] == ',' && identif[1] == EOS) + call syserr (SYS_FXFKSSYN) + + case TOK_STRING: + if (nexpr != 0 && nexpr != 1) + call syserr (SYS_FXFKSSVAL) + call strcpy (outstr, FKS_EXTNAME(fit), LEN_CARD) + nexpr = nexpr + 1 + extn = true + + case TOK_IDENTIFIER: + nident = nident + 1 + call strcpy (outstr, identif, LEN_CARD] + call strlwr (outstr) + lex_type = fxf_ks_lex (outstr) + + # look for =, + or - + if (lex_type > 0) { + call fxf_ks_gvalue (lex_type, ksection, ip, fit) + } else { + if (nexpr == 0 || nexpr == 1) + call strcpy (identif, FKS_EXTNAME(fit), LEN_CARD) + else + call syserr (SYS_FXFKSSVAL) + } + nexpr = nexpr + 1 + extn = true + + default: + call syserr (SYS_FXFKSSYN) + } + } +end + + +# FXF_KS_LEX -- Map an identifier into a FITS kernel parameter code. + +int procedure fxf_ks_lex (outstr) + +char outstr[ARB] + +int len, strlen(), strncmp() +errchk syserr, syserrs + +begin + len = strlen (outstr) + + # Allow for small string to be taken as extname values and not + # kernel paramaters; like 'ap' instead of 'ap(ppend)'. + if (len < 3) + return(0) + + # See if it is extname or extver. + if (strncmp (outstr, "ext", 3) == 0 && len < 8 ) { + if (len == 3) + call syserr (SYS_FXFKSEXT) + if (strncmp (outstr[4], "name", len-3) == 0) + return (KS_EXTNAME) + else if (strncmp (outstr[4], "ver", len-3) == 0) + return (KS_EXTVER) + + # Check for the "no" versions of selected keywords. + } else if (strncmp (outstr, "no", 2) == 0 && len < 12) { + if (strncmp (outstr[3], "append", len-2) == 0) + return (KS_NOAPPEND) + if (strncmp (outstr[3], "inherit", len-2) == 0) + return (KS_NOINHERIT) + if (strncmp (outstr[3], "overwrite", len-2) == 0) + return (KS_NOOVERWRITE) + if (strncmp (outstr[3], "dupname", len-2) == 0) + return (KS_NODUPNAME) + if (strncmp (outstr[3], "expand", len-2) == 0) + return (KS_NOEXPAND) + } + + # Other kernel keywords. + if (strncmp (outstr, "inherit", len) == 0) + return (KS_INHERIT) + if (strncmp (outstr, "overwrite", len) == 0) + return (KS_OVERWRITE) + if (strncmp (outstr, "dupname", len) == 0) + return (KS_DUPNAME) + if (strncmp (outstr, "append", len) == 0) + return (KS_APPEND) + if (strncmp (outstr, "noappend", len) == 0) + return (KS_NOAPPEND) + if (strncmp (outstr, "type", len) == 0) + return (KS_TYPE) + if (strncmp (outstr, "expand", len) == 0) + return (KS_EXPAND) + if (strncmp (outstr, "phulines", len) == 0) + return (KS_PHULINES) + if (strncmp (outstr, "ehulines", len) == 0) + return (KS_EHULINES) + if (strncmp (outstr, "padlines", len) == 0) + return (KS_PADLINES) + if (strncmp (outstr, "cachesize", len) == 0) + return (KS_CACHESIZE) + + return (0) # not recognized; probably a value +end + + +# FXF_KS_GVALUE -- Given a parameter code get its value at the 'ip' character +# position in the 'ksection' string. Put the values in the FKS structure. + +procedure fxf_ks_gvalue (param, ksection, ip, fit) + +int param #I parameter code +char ksection[ARB] #I Ksection +int ip #I Current parsing pointer in ksection +pointer fit #U Update the values in the FKS structure + +pointer sp, ln +int jp, token +int ctotok() +errchk syserr, syserrs + +begin + jp = ip + + call smark (sp) + call salloc (ln, LEN_CARD, TY_CHAR) + + # See if the parameter value is given as par= or '+/-' + if (ctotok (ksection, jp, Memc[ln], LEN_CARD) == TOK_OPERATOR) { + if (Memc[ln] == '=' ) { + token = ctotok (ksection, jp, Memc[ln], LEN_CARD) + if (token != TOK_IDENTIFIER && + token != TOK_STRING && token != TOK_NUMBER) { + call syserr (SYS_FXFKSSYN) + } else { + call fxf_ks_val (Memc[ln], param, fit) + ip = jp + } + } else if (Memc[ln] == '+' || Memc[ln] == '-') { + call fxf_ks_pm (Memc[ln], param, fit) + ip = jp + } + } else { + switch (param) { + case KS_APPEND: + FKS_APPEND(fit) = YES + case KS_NOAPPEND: + FKS_APPEND(fit) = NO + case KS_OVERWRITE: + FKS_OVERWRITE(fit) = YES + case KS_NOOVERWRITE: + FKS_OVERWRITE(fit) = NO + case KS_DUPNAME: + FKS_DUPNAME(fit) = YES + case KS_INHERIT: + FKS_INHERIT(fit) = YES + case KS_NOINHERIT: + FKS_INHERIT(fit) = NO + case KS_EXPAND: + FKS_EXPAND(fit) = YES + case KS_NOEXPAND: + FKS_EXPAND(fit) = NO + default: + call syserr (SYS_FXFKSSYN) + } + } + + call sfree (sp) +end + + +# FXF_KS_VALUE -- Returns the value of a parameter in the kernel section. + +procedure fxf_ks_val (outstr, param, fit) + +char outstr[ARB] #I Input string with value +int param #I Parameter code +pointer fit #U Fits kernel descriptor + +int ty, ip, ival, nchars +int lexnum(), ctoi(), strcmp() +errchk syserr, syserrs + +begin + call strlwr (outstr) + if (strcmp (outstr, "yes") == 0) + ival = YES + else if (strcmp (outstr, "no") == 0) + ival = NO + else + ival = ERROR + + switch (param) { + case KS_EXTNAME: + call strcpy (outstr, FKS_EXTNAME(fit), LEN_CARD) + + case KS_TYPE: + call strlwr (outstr) + if (strcmp ("mask", outstr) == 0) + FKS_SUBTYPE(fit) = FK_PLIO + else + call syserrs (SYS_FXFKSINVAL, "type") + case KS_EXTVER: + ip = 1 + ty = lexnum (outstr, ip, nchars) + if (ty != LEX_DECIMAL) + call syserr (SYS_FXFKSNDEC) + ip = 1 + nchars = ctoi (outstr, ip, ival) + if (nchars <= 0) + call syserrs (SYS_FXFKSINVAL, "extver") + FKS_EXTVER(fit) = ival + + case KS_APPEND: + if (ival != ERROR) + FKS_APPEND(fit) = ival + else + call syserrs (SYS_FXFKSINVAL, "append") + + case KS_OVERWRITE: + if (ival != ERROR) + FKS_OVERWRITE(fit) = ival + else + call syserrs (SYS_FXFKSINVAL, "overwrite") + + case KS_DUPNAME: + if (ival != ERROR) + FKS_DUPNAME(fit) = ival + else + call syserrs (SYS_FXFKSINVAL, "dupname") + + case KS_INHERIT: + if (ival != ERROR) + FKS_INHERIT(fit) = ival + else + call syserrs (SYS_FXFKSINVAL, "inherit") + + case KS_EXPAND: + if (ival != ERROR) + FKS_EXPAND(fit) = ival + else + call syserrs (SYS_FXFKSINVAL, "expand") + + case KS_PHULINES: + ip = 1 + ty = lexnum (outstr, ip, nchars) + if (ty != LEX_DECIMAL) + call syserr (SYS_FXFKSNDEC) + ip = 1 + nchars = ctoi (outstr, ip, ival) + if (nchars <= 0 || ival < 0) + call syserrs (SYS_FXFKSPVAL, "phulines") + FKS_PHULINES(fit) = ival + + case KS_EHULINES: + ip = 1 + ty = lexnum (outstr, ip, nchars) + if (ty != LEX_DECIMAL) + call syserr (SYS_FXFKSNDEC) + ip = 1 + nchars = ctoi (outstr, ip, ival) + if (nchars <= 0 || ival < 0) + call syserrs (SYS_FXFKSPVAL, "ehulines") + FKS_EHULINES(fit) = ival + + case KS_PADLINES: + ip = 1 + ty = lexnum (outstr, ip, nchars) + if (ty != LEX_DECIMAL) + call syserr (SYS_FXFKSNDEC) + ip = 1 + nchars = ctoi (outstr, ip, ival) + if (nchars <= 0 || ival < 0) + call syserrs (SYS_FXFKSPVAL, "padlines") + FKS_PADLINES(fit) = ival + + case KS_CACHESIZE: + ip = 1 + ty = lexnum (outstr, ip, nchars) + if (ty != LEX_DECIMAL) + call syserr (SYS_FXFKSNDEC) + ip = 1 + nchars = ctoi (outstr, ip, ival) + if (nchars <= 0 || ival < 0) + call syserrs (SYS_FXFKSPVAL, "cachesize") + FKS_CACHESIZE(fit) = ival + + default: + call syserr (SYS_FXFKSSYN) + } +end + + +# FXF_KS_PM -- Return the character YES or NO based on the value '+' or '-' + +procedure fxf_ks_pm (pm, param, fit) + +char pm[1] #I contains "+" or "-" +int param #I Parameter code +pointer fit #U Fits kernel descriptor + +int ival +errchk syserr, syserrs + +begin + if (pm[1] == '+') + ival = YES + else + ival = NO + + switch (param) { + case KS_APPEND: + FKS_APPEND(fit) = ival + case KS_OVERWRITE: + FKS_OVERWRITE(fit) = ival + case KS_DUPNAME: + FKS_DUPNAME(fit) = ival + case KS_INHERIT: + FKS_INHERIT(fit) = ival + case KS_EXPAND: + FKS_EXPAND(fit) = ival + default: + call syserr (SYS_FXFKSSYN) + } +end + + +# FXF_KS_ERRORS -- Handle an error condition in the kernel section. + +procedure fxf_ks_errors (fit, acmode) + +pointer fit #I fits kernel descriptor +int acmode #I image access mode + +int group +errchk syserr, syserrs + +begin + group = FIT_GROUP(fit) + + if (FKS_OVERWRITE(fit) == YES) { + if (FIT_NEWIMAGE(fit) == YES) + iferr (call syserrs (SYS_FOPNNEXFIL, IM_HDRFILE(FIT_IM(fit)))) + call erract (EA_WARN) + if (acmode == APPEND) + call syserrs (SYS_FXFKSNOVR, "APPEND") + if (group == -1 && + (FKS_EXTNAME(fit) == EOS && IS_INDEFL(FKS_EXTVER(fit)))) + call syserr (SYS_FXFKSOVR) + } else { + switch (acmode) { + case NEW_COPY: + if (group != -1 && FKS_APPEND(fit) == NO) + call syserr (SYS_FXFKSBOP) + case NEW_IMAGE: + if (group != -1) + call syserrs (SYS_FXFKSNEXT, "NEW_IMAGE" ) + case APPEND: + if (group != -1) + call syserrs (SYS_FXFKSNEXT, "APPEND" ) + } + } +end + + +# FXF_KSINIT -- Initialize default values for ks parameters. + +procedure fxf_ksinit (fit) + +pointer fit #I fits kernel descriptor + +begin + FKS_EXTNAME(fit) = EOS + FKS_SUBTYPE(fit) = NO + FKS_EXTVER(fit) = INDEFL + FKS_APPEND(fit) = NO + FKS_OVERWRITE(fit) = NO + FKS_DUPNAME(fit) = NO + FKS_EXPAND(fit) = YES + FKS_PHULINES(fit) = DEF_PHULINES + FKS_EHULINES(fit) = DEF_EHULINES + FKS_PADLINES(fit) = DEF_PADLINES + FKS_INHERIT(fit) = YES + FKS_CACHESIZE(fit) = DEF_CACHE +end diff --git a/sys/imio/iki/fxf/fxfmkcard.x b/sys/imio/iki/fxf/fxfmkcard.x new file mode 100644 index 00000000..81bb3ab7 --- /dev/null +++ b/sys/imio/iki/fxf/fxfmkcard.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# FXF_MK_CARD -- Fetch a single line from a string parameter, padding it to +# a maximum of maxcols characters and trimmimg the delim character. + +procedure fxf_make_card (instr, ip, card, col_out, maxcols, delim) + +char instr[ARB] #I input string +int ip #U input string pointer, updated at each call +char card[ARB] #O FITS card image +int col_out #I pointer to column in card +int maxcols #I maximum columns in card +int delim #I 1 character string delimiter + +int op + +begin + op = col_out + + # Copy string + while (op <= maxcols && instr[ip] != EOS && instr[ip] != delim) { + card[op] = instr[ip] + ip = ip + 1 + op = op + 1 + } + + # Fill remainder of card with blanks + while (op <= maxcols ) { + card[op] = ' ' + op = op + 1 + } + + if (instr[ip] == delim) + ip = ip + 1 +end diff --git a/sys/imio/iki/fxf/fxfnull.x b/sys/imio/iki/fxf/fxfnull.x new file mode 100644 index 00000000..ce3baece --- /dev/null +++ b/sys/imio/iki/fxf/fxfnull.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "fxf.h" + +# FXF_NULL -- Null driver entry point. + +procedure fxf_null() + +errchk syserr, syserrs + +begin + call syserr (SYS_FXFFKNULL) +end diff --git a/sys/imio/iki/fxf/fxfopen.x b/sys/imio/iki/fxf/fxfopen.x new file mode 100644 index 00000000..bceed618 --- /dev/null +++ b/sys/imio/iki/fxf/fxfopen.x @@ -0,0 +1,1014 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include +include +include "fxf.h" + + +# FXF_OPEN -- Open/create a FITS format image with extensions. + +procedure fxf_open (kernel, im, o_im, root, extn, ksection, group, gc_arg, + acmode, status) + +int kernel #I IKI kernel +pointer im #I image descriptor +pointer o_im #I other descriptor for NEW_COPY image +char root[ARB] #I root image name +char extn[ARB] #I extension, if any +char ksection[ARB] #I [extname,extver,overwrite,append,inherit..] +int group #I index of group to be accessed +int gc_arg #I [NOT USED] +int acmode #I access mode +int status #O status flag to calling routine + +long fi[LEN_FINFO] +int newimage, i, gn, ksinh, type, fmode +pointer sp, path, fit_extn, ua, o_fit, fit +bool pre_read, fks_extn_or_ver, dyh, fsec, plio +int fxf_check_dup_extnv(), itoc(), strcmp(), strncmp() +int open(), access(), imgeti(), fstatl(), finfo(), fxf_header_size() +pointer pl_open() + +errchk fmkcopy, calloc, open, fxf_rheader, fxf_prhdr, fxf_gaccess +errchk fxf_fclobber, fxf_ksection, fxf_alloc, syserr, syserrs +errchk fxf_check_group +define duperr_ 91 +define err_ 92 + +begin + call smark (sp) + call salloc (path, SZ_PATHNAME, TY_CHAR) + call salloc (fit_extn, FITS_LENEXTN, TY_CHAR) + call fxf_init() + ua = IM_USERAREA(im) + + fmode = acmode + + # Allocate internal FITS image descriptor. + call fxf_alloc (fit) + + IM_KDES(im) = fit + IM_HFD(im) = NULL + FIT_IM(fit) = im + call amovki (1, FIT_LENAXIS(fit,1), IM_MAXDIM) + + # Generate full header file name. + if (extn[1] == EOS) { + call fxf_gethdrextn (im, o_im, fmode, Memc[fit_extn], FITS_LENEXTN) + call iki_mkfname (root, Memc[fit_extn], Memc[path], SZ_PATHNAME) + call strcpy (Memc[fit_extn], extn, FITS_LENEXTN) + } else + call iki_mkfname (root, extn, Memc[path], SZ_PATHNAME) + + # Header and pixel filename are the same. + call strcpy (Memc[path], IM_HDRFILE(im), SZ_IMHDRFILE) + call strcpy (IM_HDRFILE(im), IM_PIXFILE(im), SZ_IMPIXFILE) + + newimage = NO + if (access (IM_HDRFILE(im), 0, 0) == NO) + newimage = YES + FIT_NEWIMAGE(fit) = newimage + + # Initialize kernel section default values. + call fxf_ksinit (fit) + + # For simplicity treat the APPEND mode as NEW_IMAGE. For the FK + # is the same. + + if (fmode == APPEND) + fmode = NEW_IMAGE + FIT_ACMODE(fit) = fmode + + # Read fkinit and ksection and check that the extension number + # specifications therein and the IMIO cluster index "group" are + # consistent. + + call fxf_check_group (im, ksection, fmode, group, ksinh) + + fks_extn_or_ver = FKS_EXTNAME(fit) != EOS || !IS_INDEFL(FKS_EXTVER(fit)) + + # Check if a file section is necessary. + fsec = (fks_extn_or_ver || group >= 0) + call fxf_gaccess (im, fsec) + + # The previous call could have changed FIT_NEWIMAGE; reset value. + newimage = FIT_NEWIMAGE(fit) + + if (fks_extn_or_ver) + FIT_GROUP(fit) = -1 + + # See if we want to write a dummy primary unit. + # + # For PLIO, if creating a new output file and we want to create a + # BINTABLE, create a dummy header. Otherwise see if a type is + # requested, in which case we would need to create a dummmy header + # if no file is present yet. + + type = 0 + if (FKS_SUBTYPE(fit) == FK_PLIO) + type = FK_PLIO + + dyh = false + if (newimage == YES && (fks_extn_or_ver || type > 0)) { + call fxf_dummy_header (im, status) + if (status == ERR) + goto err_ + newimage = NO + dyh = true + if (fmode == NEW_COPY && type == FK_PLIO) + FIT_PIXOFF(fit) = fxf_header_size(im) + FITS_BLOCK_CHARS + } + if (newimage == NO) { + if (finfo (IM_HDRFILE(im), fi) != ERR) + FIT_EOFSIZE(fit) = (FI_SIZE(fi)+SZB_CHAR-1)/SZB_CHAR + 1 + else + call syserrs (SYS_FOPEN, IM_HDRFILE(im)) + } + + if (newimage == YES) + FKS_OVERWRITE(fit) = NO + else + FIT_XTENSION(fit) = YES + + FIT_NEWIMAGE(fit) = newimage + + # If all these conditions are met then set the pre_read flag. + pre_read = (fks_extn_or_ver || + FKS_OVERWRITE(fit) == YES || FKS_INHERIT(fit) == YES) + + if (newimage == NO && fmode != READ_ONLY) { + # See that INHERIT makes sense if it has been set by + # 'fkinit' when reading a file with PHU (naxis != 0). + + if (FKS_INHERIT(fit) == YES && group != 0) { + gn = 0 + iferr (call fxf_prhdr (im, gn)) { + FKS_INHERIT(fit) = NO + + # Issue an error only if the inherit is in the filename. + if (fmode == NEW_COPY && ksinh == YES) + call syserr (SYS_FXFBADINH) + } else if (FIT_NAXIS(fit) != 0) + FKS_INHERIT(fit) = NO + + # Reset the pre_read flag. + pre_read = ((FKS_DUPNAME(fit) == NO && + FKS_INHERIT(fit) == YES) || FKS_OVERWRITE(fit) == YES) + } + + if (pre_read && fmode != NEW_COPY && !dyh) + call fxf_prhdr (im, group) + + if (access (IM_HDRFILE(im), fmode, 0) == NO) + call syserrs (SYS_FNOWRITEPERM, IM_HDRFILE(im)) + } + + switch (fmode) { + case NEW_IMAGE, APPEND: + if (newimage == NO) { + # Make sure the UA is empty when overwriting. + if (pre_read && FKS_OVERWRITE(fit) == YES) + Memc[ua] = EOS + + if (FKS_DUPNAME(fit) == NO) + if (fxf_check_dup_extnv (im, group) == YES) + goto duperr_ + } else { + # See if it is necessary to invalidate the cache entry for the + # current filename. It could happen that the user has deleted + # the filename and a new file with the same is created. + + call fxf_check_old_name (im) + } + + if (FKS_INHERIT(fit) == YES) + FIT_INHERIT(fit) = YES + + # Initialize a new copy of a PLIO image mask. + if (type == FK_PLIO) + IM_PL(im) = pl_open (NULL) + + case NEW_COPY: + # Completely new copy of an existing image. This could mean a + # new file or append a new image to an existing file. + + # Initialize a new copy of a PLIO image mask. + if (type == FK_PLIO) { + IM_PL(im) = pl_open (NULL) + if (IM_PL(o_im) != NULL) + call fxf_plpf (im) + } + + if (newimage == YES || FKS_APPEND(fit) == NO) + call fxf_check_old_name (im) + + # For a PLIO mask, make sure there are no SUBYTPE keywords in + # the UA since this will be rewritten by fxf_updhdr(). + + if (IM_PL(o_im) != NULL) + call fxf_clean_pl (im) + + if (IM_KDES(o_im) != NULL && IM_KERNEL(o_im) == IM_KERNEL(im)) { + o_fit = IM_KDES(o_im) + call strcpy (FIT_EXTTYPE(o_fit), FIT_EXTTYPE(fit), SZ_EXTTYPE) + call strcpy (FIT_EXTNAME(o_fit), FIT_EXTNAME(fit), LEN_CARD) + FIT_EXTVER(fit) = FIT_EXTVER(o_fit) + + # Reset the value of the keyword INHERIT in the new_copy + # image if the input has a no_inherit in the filename. + + FIT_INHERIT(fit) = NO + call fxf_filter_keyw (im, "INHERIT") + + # Change the value only if explicitly done in the output + # kernel section. + + if (FKS_INHERIT(fit) == YES) + FIT_INHERIT(fit) = YES + + } else { + # Reblock if old image is imh for example. + if (IM_UABLOCKED(im) != YES) + call fxf_reblock (im) + + # See if the old image have EXTNAME or EXTVER keywords. + # Notice that old image does not have to be of FITS type. + + iferr (call imgstr (o_im,"EXTNAME",FIT_EXTNAME(fit),LEN_CARD)) + FIT_EXTNAME(fit) = EOS + iferr (FIT_EXTVER(fit) = imgeti (o_im, "EXTVER")) + FIT_EXTVER(fit) = INDEFL + call strcpy ("IMAGE", FIT_EXTTYPE(fit), SZ_EXTTYPE) + } + + # Delete ORIGIN keyword, since we are going to put a new one. + call fxf_filter_keyw (im, "ORIGIN") + + # Now that we have a new_copy of the input FITS structure, + # initialize some of its members. + + FIT_HFD(fit) = NULL + FIT_NEWIMAGE(fit) = newimage + if (newimage == NO) + FIT_XTENSION(fit) = YES + FIT_ACMODE(fit) = fmode + if (FKS_APPEND(fit) != YES) + FIT_GROUP(fit) = group + FIT_BSCALE(fit) = 1.0d0 + FIT_BZERO(fit) = 0.0d0 + + if (FKS_OVERWRITE(fit) == NO) { + if (FKS_EXTNAME(fit) == EOS) + call strcpy (FIT_EXTNAME(fit), FKS_EXTNAME(fit), LEN_CARD) + else + call imastr (im, "EXTNAME", FKS_EXTNAME(fit)) + + if (IS_INDEFL(FKS_EXTVER(fit))) + FKS_EXTVER(fit) = FIT_EXTVER(fit) + else + call imaddi (im, "EXTVER", FKS_EXTVER(fit)) + + # We need to pre_read extensions headers to check for + # duplicates with these extname and extver. + + if (FKS_EXTNAME(fit) != EOS ||!IS_INDEFL(FKS_EXTVER(fit))) + pre_read = true + } + + if (newimage == NO && !dyh) { + if (pre_read) { + iferr (call fxf_prhdr (im, group)) + ; + } + + # Check for duplicated EXTNAME and/or EXTVER if any of the + # following conditions are met. + + if (FKS_DUPNAME(fit) == NO && FKS_OVERWRITE(fit) == NO && + (fks_extn_or_ver || FIT_EXTNAME(fit) != EOS || + !IS_INDEFL(FIT_EXTVER(fit)))) { + if (fxf_check_dup_extnv (im, group) == YES) + goto duperr_ + } + } + + FIT_NAXIS(fit) = IM_NDIM(im) + do i = 1, IM_NDIM(im) + FIT_LENAXIS(fit,i) = IM_LEN(im,i) + + # Inherit datatype of input template image if specified, + # otherwise default datatype to real. + + if (IM_PIXTYPE(o_im) != NULL) + IM_PIXTYPE(im) = IM_PIXTYPE(o_im) + else + IM_PIXTYPE(im) = TY_REAL + + default: + # No Overwrite allowed in READ_ONLY or READ_WRITE. + FKS_OVERWRITE(fit) = NO + + # Check that we have single FITS file. + if (!fsec && group == -1) + group = 0 + + # Open an existing image. + iferr (call fpathname (IM_HDRFILE(im), Memc[path], SZ_PATHNAME)) + goto err_ + if (fmode == READ_WRITE) + IM_HFD(im) = open (Memc[path], READ_WRITE, BINARY_FILE) + else + IM_HFD(im) = open (Memc[path], READ_ONLY, BINARY_FILE) + + iferr (call fxf_rheader (im, group, fmode)) { + call close (IM_HFD(im)) + call mfree (fit, TY_STRUCT) + call sfree (sp) + status = ERR + call erract (EA_ERROR) + } + + if (group == 0) + FIT_XTENSION(fit) = NO + else + FIT_XTENSION(fit) = YES + + # Some non-iraf fits files might have keywords that are + # imcompatible with our header. For example if hediting the header, + # make sure that they are eliminated. + + if (fmode == READ_WRITE) + call fxf_discard_keyw (im) + + FIT_EOFSIZE(fit) = fstatl (IM_HFD(im), F_FILESIZE) + 1 + + # PLIO. If we read the header of a PLIO_1 compressed image file + # then it is a PL file; now read the data. + + plio = (strncmp (FIT_EXTSTYPE(fit), "PLIO_1", 6) == 0) + if (plio) { + call fxf_plread (im) + + # We need to setup the IMIO descriptor if we need to write + # over a section; in particular IM_PFD needs to be defined. + + if (fmode == READ_WRITE) + call fxf_plpf (im) + } + + # Close the header file. + call close (IM_HFD(im)) + IM_HFD(im) = NULL + + # Do not allow the user to see any non_IMAGE extensions. + if (strcmp ("IMAGE", FIT_EXTTYPE(fit)) != 0 && + strcmp ("SIMPLE", FIT_EXTTYPE(fit)) != 0 && !plio) + call syserrs (SYS_IKIEXTN, IM_NAME(im)) + } + + FIT_HFD(fit) = IM_HFD(im) + status = OK + + call sfree (sp) + return +duperr_ + i = itoc (group, Memc[path], LEN_CARD) + call syserrs (SYS_FXFOPEXTNV, Memc[path]) +err_ + status = ERR + call mfree (fit, TY_STRUCT) + call sfree (sp) +end + + +# FXF_ALLOC -- Initialize memory for the FIT descriptor. + +procedure fxf_alloc (fit) + +pointer fit #I input fits descriptor + +errchk calloc + +begin + call calloc (fit, LEN_FITDES, TY_STRUCT) + + FIT_GROUP(fit) = -1 + FIT_PIXTYPE(fit) = NULL + FIT_BSCALE(fit) = 1.0d0 + FIT_BZERO(fit) = 0.0d0 + FIT_XTENSION(fit) = NO + FIT_INHERIT(fit) = NO + FIT_EOFSIZE(fit) = 0 + FIT_EXTNAME(fit) = EOS + FIT_EXTVER(fit) = INDEFL +end + + +# FXF_INIT -- Initialize any runtime FITS kernel descriptors to their +# process startup state. + +procedure fxf_init() + +int i +bool first_time +data first_time /true/ + +include "fxfcache.com" + +begin + # Disable the hdrcache until it is fully initialized in rfitshdr. + if (first_time) { + rf_cachesize = 0 + do i = 1, MAX_CACHE { + rf_fit[i] = 0 + } + + first_time = false + } +end + + +# FXF_KS_RDHDR -- Procedure to preread the FITS headers up to group +# 'group'. The idea is to have the offset pointers in memory since the +# can be overwritten or when no group (i.e. -1) is given and the extname or +# extver are specified. + +procedure fxf_prhdr (im, group) + +pointer im #I image descriptor +int group #I maximum group number to read + +int poff, extv +pointer fit, lim, lfit, sp, path +errchk fpathname, open, syserr, fxf_alloc, calloc +int open(), imgeti() + +begin + call smark (sp) + call salloc (path, SZ_PATHNAME, TY_CHAR) + + # We will use a local temporary imio and fit structures. +# call calloc (lim, LEN_IMDES+LEN_IMHDR+MIN_LENUSERAREA, TY_STRUCT) + call calloc (lim, LEN_IMDES+IM_LENHDRMEM(im), TY_STRUCT) + + call fxf_alloc (lfit) + + IM_KDES(lim) = lfit + fit = IM_KDES(im) + + FIT_GROUP(lfit) = group + FIT_ACMODE(lfit) = FIT_ACMODE(fit) + call strcpy (FKS_EXTNAME(fit), FKS_EXTNAME(lfit), LEN_CARD) + FKS_EXTVER(lfit) = FKS_EXTVER(fit) + + iferr (extv = imgeti (im, "EXTVER")) + extv = INDEFL + + FKS_OVERWRITE(lfit) = FKS_OVERWRITE(fit) + FKS_DUPNAME(lfit) = FKS_DUPNAME(fit) + FKS_INHERIT(lfit) = FKS_INHERIT(fit) + FKS_CACHESIZE(lfit) = FKS_CACHESIZE(fit) + + # Open an existing image. + call strcpy (IM_HDRFILE(im), IM_HDRFILE(lim), SZ_PATHNAME) + call strcpy (IM_NAME(im), IM_NAME(lim), SZ_PATHNAME) + + call fpathname (IM_HDRFILE(im), Memc[path], SZ_PATHNAME) + IM_HFD(lim) = open (Memc[path], READ_ONLY, BINARY_FILE) + + IM_LENHDRMEM(lim) = IM_LENHDRMEM(im) + + # If we want to inherit the global header we need to read + # the group specified in the filename. + + iferr (call fxf_rfitshdr (lim, group, poff)) { + call close (IM_HFD(lim)) + call mfree (lfit, TY_STRUCT) + call mfree (lim, TY_STRUCT) + call sfree (sp) + call erract (EA_ERROR) + + } else { + call close (IM_HFD(lim)) + call sfree (sp) + if (FKS_OVERWRITE(fit) == YES) + FIT_GROUP(fit) = FIT_GROUP(lfit) + group = FIT_GROUP(lfit) + + # Now set the offset pointers to the original 'fit' struct. + FIT_HDRPTR(fit) = FIT_HDRPTR(lfit) + FIT_PIXPTR(fit) = FIT_PIXPTR(lfit) + FIT_EXTEND(fit) = FIT_EXTEND(lfit) + + FIT_CACHEHDR(fit) = FIT_CACHEHDR(lfit) + FIT_CACHEHLEN(fit) = FIT_CACHEHLEN(lfit) + + FIT_NAXIS(fit) = FIT_NAXIS(lfit) + FIT_INHERIT(fit) = FIT_INHERIT(lfit) + FIT_PLMAXLEN(fit) = FIT_PLMAXLEN(lfit) + + IM_CTIME(im) = IM_CTIME(lim) + + call mfree (lfit, TY_STRUCT) + call mfree (lim, TY_STRUCT) + + if (extv != INDEFL) + call imaddi (im, "EXTVER", extv) + } +end + + +# FXF_DUMMY_HEADER -- Built a minimum Primary Fits header. This is +# necessary in case we are creating an IMAGE extension and we don't +# want to put any information in the PHU. + +procedure fxf_dummy_header (im, status) + +pointer im #I image descriptor +int status #O status flag + +char blank[1] +pointer sp, path, spp, mii, pn, n +int iso_cutover, fd, nblanks, size_rec + +int strlen(), open(), envgeti() +long clktime() + +begin + call smark (sp) + call salloc (spp, FITS_BLOCK_BYTES, TY_CHAR) + call salloc (mii, FITS_BLOCK_CHARS, TY_INT) + call salloc (path, SZ_PATHNAME, TY_CHAR) + + status = OK + + iferr { + call fpathname (IM_HDRFILE(IM), Memc[path], SZ_PATHNAME) + fd = open (Memc[path], NEW_FILE, BINARY_FILE) + } then { + call sfree (sp) + status = ERR + return + } + + pn = spp + call fxf_akwb ("SIMPLE", YES, "FITS STANDARD", pn) + call fxf_akwi ("BITPIX", 8, "Character information", pn) + call fxf_akwi ("NAXIS", 0, "No image data array present", pn) + call fxf_akwb ("EXTEND", YES, "File may contain extensions", pn) + call fxf_akwc ("ORIGIN", FITS_ORIGIN, + strlen(FITS_ORIGIN), "FITS file originator", pn) + + # Dates after iso_cutover use ISO format dates. + iferr (iso_cutover = envgeti (ENV_ISOCUTOVER)) + iso_cutover = DEF_ISOCUTOVER + + # Encode the DATE keyword. + call fxf_encode_date (clktime(long(0)), Memc[path], LEN_CARD, + "ISO", 2000) + call fxf_akwc ("DATE", Memc[path], + strlen(Memc[path]), "Date FITS file was generated", pn) + + blank[1] = ' ' + call amovkc (blank[1], Memc[pn], LEN_CARD) + call amovc ("END", Memc[pn], 3) + pn = pn + LEN_CARD + + n = pn - spp + size_rec = FITS_BLOCK_CHARS + nblanks = FITS_BLOCK_BYTES - n + call amovkc (blank[1], Memc[spp+n], nblanks) + call miipak (Memc[spp], Memi[mii], size_rec*2, TY_CHAR, MII_BYTE) + call write (fd, Memi[mii], size_rec) + + call close (fd) + + call sfree (sp) +end + + +# FXF_CHECK_DUP_EXTN_VER --- Function to check for a duplicate EXTNAME or +# EXTVER in the FITS file open with NEW_COPY mode. The filename specification +# does not have EXTNAME nor EXTVER in the ksection. +# Returns YES if there are duplicates. + +int procedure fxf_check_dup_extnv (im, group) + +pointer im #I image descriptor +int group #O extension number where there is a duplicate + +int cindx +pointer extn, extv, sp, hdrfile, fit, poff +int fxf_extnv_error() +bool streq() + +include "fxfcache.com" + +begin + call smark (sp) + call salloc (hdrfile, SZ_PATHNAME, TY_CHAR) + + call fpathname (IM_HDRFILE(im), Memc[hdrfile], SZ_PATHNAME) + fit = IM_KDES(im) + + do cindx=1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + + if (streq (Memc[hdrfile], rf_fname[1,cindx])) { + extn = rf_pextn[cindx] + extv = rf_pextv[cindx] + poff = rf_pixp[cindx] # pixel offset -1 if EOF + group = 1 + + # Now compare the input image FIT_EXT(NAME,VER) with + # the cache values of the NEW_COPY images. + + while (Memc[extn+LEN_CARD*group] != EOS || + !IS_INDEFL(Memi[extv+group]) || Memi[poff+group] != -1) { + if (fxf_extnv_error (fit, group, extn, extv) == YES) { + call sfree (sp) + if (FKS_OVERWRITE(fit) == YES) + return (NO) + else + return (YES) + } else + group = group + 1 + } + } + } + + call sfree (sp) + return (NO) +end + + +# FXF_CHECK_OLD_NAME -- Check is the filename is already in cache for a +# NEWIMAGE == YES mode; if so, make the entry obsolete. + +procedure fxf_check_old_name (im) + +pointer im #I image descriptor + +int cindx +pointer sp, hdrfile, fit +bool streq() + +include "fxfcache.com" + +begin + call smark (sp) + call salloc (hdrfile, SZ_PATHNAME, TY_CHAR) + + call fpathname (IM_HDRFILE(im), Memc[hdrfile], SZ_PATHNAME) + + fit = IM_KDES(im) + do cindx=1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + + # Verify that we have the correct file. + if (streq (Memc[hdrfile], rf_fname[1,cindx])) { + call mfree (rf_pextv[cindx], TY_INT) + call mfree (rf_pextn[cindx], TY_CHAR) + call mfree (rf_pixp[cindx], TY_INT) + call mfree (rf_hdrp[cindx], TY_INT) + call mfree (rf_fit[cindx], TY_STRUCT) + call mfree (rf_hdr[cindx], TY_CHAR) + rf_fit[cindx] = NULL + rf_mtime[cindx] = 0 # invalidate cache entry + rf_fname[1,cindx] = EOS + break + } + } + + call sfree (sp) +end + + +# FXF_REBLOCK -- If the user area is not blocked to fixed length records, e.g., +# as is possible in a new copy image, reblock it fixed length. + +procedure fxf_reblock (im) + +pointer im #I image descriptor + +pointer sp, lbuf, op, ua +int fd, spool, nlines, nchars, sz_userarea, len_hdrmem +errchk stropen, open, getline, putline, realloc, seek, fcopyo +int open(), stropen(), getline() + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + ua = IM_USERAREA(im) + fd = stropen (Memc[ua], ARB, READ_ONLY) + spool = open ("rb_spool", READ_WRITE, SPOOL_FILE) + + # Reblock into a spool file, counting the lines. + for (nlines=0; ; nlines=nlines+1) { + nchars = getline (fd, Memc[lbuf]) + if (nchars <= 0) + break + + for (op=nchars; op <= LEN_CARD; op=op+1) + Memc[lbuf+op-1] = ' ' + Memc[lbuf+LEN_CARD] = '\n' + Memc[lbuf+LEN_CARD+1] = EOS + call putline (spool, Memc[lbuf]) + } + + call close (fd) + + # Reallocate header the right size. + sz_userarea = nlines * (LEN_CARD+1) + SZ_EXTRASPACE + + IM_HDRLEN(im) = LEN_IMHDR + + (sz_userarea - SZ_EXTRASPACE + SZ_MII_INT-1) / SZ_MII_INT + len_hdrmem = LEN_IMHDR + + (sz_userarea+1 + SZ_MII_INT-1) / SZ_MII_INT + + if (IM_LENHDRMEM(im) < len_hdrmem) { + IM_LENHDRMEM(im) = len_hdrmem + call realloc (im, IM_LENHDRMEM(im) + LEN_IMDES, TY_STRUCT) + } + + # Move spooled data back to user area. + ua = IM_USERAREA(im) + fd = stropen (Memc[ua], sz_userarea, NEW_FILE) + call seek (spool, BOFL) + call fcopyo (spool, fd) + + IM_UABLOCKED(im) = YES + call close (fd) + call close (spool) + call sfree (sp) +end + + +# FXF_FCLOBBER -- Clobber an existing FITS file. We use the environment +# variable 'clobber' rather than 'imclobber' because is a file and not +# an image. + +procedure fxf_fclobber (file) + +char file #I input filename to delete + +int cindx +bool streq() +include "fxfcache.com" + +begin + iferr (call delete (file)) + call filerr (file, SYS_FCANTCLOB) + + # Remove the name from the cache. + do cindx=1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + + # Verify that we have the correct file. + if (streq (file, rf_fname[1,cindx])) { + if (rf_fit[cindx] != NULL) { + call mfree (rf_pextv[cindx], TY_INT) + call mfree (rf_pextn[cindx], TY_CHAR) + call mfree (rf_pixp[cindx], TY_INT) + call mfree (rf_hdrp[cindx], TY_INT) + call mfree (rf_fit[cindx], TY_STRUCT) + call mfree (rf_hdr[cindx], TY_CHAR) + rf_fit[cindx] = NULL + } + } + } +end + + +# FXF_ACCESS -- Check if a file section is necessary to access any +# particular extension. + +procedure fxf_gaccess (im, fsec) + +pointer im #I image descriptor +bool fsec #I true if extname,extver or group have values + +bool mef +int acmode, fit, newimage, group +bool envgetb(), fnullfile() +errchk syserr, syserrs, fxf_fclobber + +begin + fit = IM_KDES(im) + acmode = FIT_ACMODE(fit) + newimage = FIT_NEWIMAGE(fit) + + if (acmode == READ_ONLY || acmode == READ_WRITE) { + # If no file section then see if it is a MEF by prereading an + # extension. + + if (!fsec) { + group = 1 + mef = false + ifnoerr (call fxf_prhdr (im, group)) + mef = true + else { + # Flag error if the group does not exist and overwrite+. + if (FKS_OVERWRITE(fit) == YES) + call syserrs (SYS_FXFEXTNF, IM_NAME(im)) + } + # Multi-extension file but no extension was specified. + if (mef) + call syserrs (SYS_FXFOPNOEXTNV, IM_NAME(im)) + FIT_GROUP(fit) = 0 + FIT_XTENSION(fit) = NO + } + } + + switch (acmode) { + case NEW_COPY, NEW_IMAGE, APPEND: + if (envgetb ("imclobber")) { + if (newimage == NO) { + if (FKS_APPEND(fit) != YES && FKS_OVERWRITE(fit) != YES) { + # Clobber the file. + call fxf_fclobber (IM_HDRFILE(im)) + FIT_NEWIMAGE(fit) = YES + } + } + } else { + if (newimage == NO) + if (FKS_APPEND(fit) != YES && FKS_OVERWRITE(fit) != YES) { + if (!fnullfile (IM_HDRFILE(im))) + call syserrs (SYS_IKICLOB, IM_HDRFILE(im)) + } + } + default: + ; + } + +end + + +# FXF_CHECK_GROUP -- Check for group specification from fkinit, ksection +# and cluster index are equal when specifified and they are also compatible +# when (extname,extver) is in the kernel sections. + +procedure fxf_check_group (im, ksection, acmode, group, ksinh) + +pointer im #I imio descriptor +char ksection[ARB] #I kernel section +int acmode #I fits unit extension mode +int group #U extension number in the image section +int ksinh #O INHERIT value from the filename ksection + +pointer sp, ks, fit +bool fks_extn_or_ver, inherit_override +int igroup, kgroup, fgroup, tgroup, sv_inherit, newimage, append +bool fnullfile() +int envgets() + +errchk syserrs, fxf_ks_error + +begin + call smark (sp) + call salloc (ks, SZ_LINE, TY_CHAR) + + fit = IM_KDES(im) + newimage = FIT_NEWIMAGE(fit) + + # Set the FKINIT defaults; these override the builtin defaults. + fgroup = -1 + igroup = -1 + + FKS_APPEND(fit) = NO_KEYW + if (envgets (ENV_FKINIT, Memc[ks], SZ_LINE) != 0) + call fxf_ksection (Memc[ks], fit, igroup) + + append = FKS_APPEND(fit) + + sv_inherit = FKS_INHERIT(fit) + FKS_INHERIT(fit) = NO_KEYW + FKS_APPEND(fit) = NO_KEYW + + # Parse the kernel section. + call fxf_ksection (ksection, fit, kgroup) + ksinh = FKS_INHERIT(fit) + + # Check for various error conditions. + if (FKS_OVERWRITE(fit) == YES && FKS_APPEND(fit) == YES) + call syserrs (SYS_FXFKSNOVR, "append") + + if (append == NO_KEYW && FKS_APPEND(fit) == NO_KEYW) + FKS_APPEND(fit) = NO + else if (append != NO_KEYW) + FKS_APPEND(fit) = append + + if (append == YES && FKS_OVERWRITE(fit) == YES) + FKS_APPEND(fit) = NO + + if (group != -1) { + if (kgroup != -1 && group != kgroup) + call syserrs (SYS_FXFKSBADGR, IM_NAME(im)) + else if (igroup != -1 && group != igroup) + call syserrs (SYS_FXFKSBADFKIG, IM_NAME(im)) + fgroup = group + } else if (kgroup != -1) { + if (group != -1 && group != kgroup) + call syserrs (SYS_FXFKSBADGR, IM_NAME(im)) + else if (igroup != -1 && group != igroup) + call syserrs (SYS_FXFKSBADFKIG, IM_NAME(im)) + fgroup = kgroup + } else if (igroup != -1) { + if ((group != -1 && group != igroup) || + (kgroup != -1 && kgroup != igroup)) + call syserrs (SYS_FXFKSBADFKIG, IM_NAME(im)) + fgroup = igroup + } + group = fgroup + + # Pre-read the data header. This is done after processing the user + # ksection as we need to get the extname/extver if any. + # EXTNAME or EXTVER has priority when defined over group. + + fks_extn_or_ver = + (FKS_EXTNAME(fit) != EOS || !IS_INDEFL(FKS_EXTVER(fit))) + + tgroup = fgroup + if (fks_extn_or_ver) + tgroup = -1 + + if (newimage == NO && !fnullfile (IM_HDRFILE(im))) { + iferr (call fxf_prhdr (im, tgroup)) { + # If group does not exist and over+, it is an error. + if (FKS_OVERWRITE(fit) == YES) + call syserrs (SYS_FXFEXTNF, IM_NAME(im)) + else + call erract (EA_ERROR) + } + } + + if (fgroup != -1 && tgroup != fgroup && fks_extn_or_ver) + call syserrs (SYS_FXFKSBADEXN, IM_NAME(im)) + + if (fgroup == -1 && fks_extn_or_ver) + group = tgroup + + FIT_EXPAND(fit) = FKS_EXPAND(fit) + + # For overwrite we need to force group to be the kernel section + # extension number. + + if (FKS_OVERWRITE(fit) == YES) + FIT_GROUP(fit) = max(kgroup,group) + else + FIT_GROUP(fit) = group + + if (FKS_APPEND(fit) == YES) + FIT_GROUP(fit) = -1 + + # See if there are some error conditions with the ksection. + call fxf_ks_errors (fit, acmode) + + # Check to see if the user ksection sets the inherit flag. If so + # this overrides all the defaults, including the data header. + + inherit_override = (FKS_INHERIT(fit) != NO_KEYW) + if (!inherit_override) + FKS_INHERIT(fit) = sv_inherit + + # A data header has precedence over the more global fkinit. + # If inherit is disabled in the data header don't enable it here. + + if (!inherit_override && FIT_INHERIT(fit) == NO) + FKS_INHERIT(fit) = NO + + call sfree (sp) +end + + +# FXF_CLEAN_PL -- Filter PLIO keywords from the UA. + +procedure fxf_clean_pl (im) + +pointer im #I image descriptor + +begin + #### (This is incredibly inefficient...) + call fxf_filter_keyw (im, "TFORM1") + call fxf_filter_keyw (im, "TFIELDS") + call fxf_filter_keyw (im, "ZIMAGE") + call fxf_filter_keyw (im, "ZCMPTYPE") + call fxf_filter_keyw (im, "ZBITPIX") + call fxf_filter_keyw (im, "ZNAXIS") + call fxf_filter_keyw (im, "ZNAXIS1") + call fxf_filter_keyw (im, "ZNAXIS2") + call fxf_filter_keyw (im, "ZTILE1") + call fxf_filter_keyw (im, "ZTILE2") + call fxf_filter_keyw (im, "ZNAME1") + call fxf_filter_keyw (im, "ZVAL1") +end diff --git a/sys/imio/iki/fxf/fxfopix.x b/sys/imio/iki/fxf/fxfopix.x new file mode 100644 index 00000000..0401601b --- /dev/null +++ b/sys/imio/iki/fxf/fxfopix.x @@ -0,0 +1,746 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include "fxf.h" +include + +define MIN_BUFSIZE 512 + + +# FXF_OPIX -- Open (or create) the pixel storage file. + +procedure fxf_opix (im, status) + +pointer im #I image descriptor +int status #O return status + +pointer sp, fn, fit +char pathname[SZ_PATHNAME] +int compress, blklen, pixoff, filesize +int i, hdr_size, sz_pixfile, sz_fitfile, junk, npix +extern fxfzop(), fxfzrd(), fxfzwr(), fxfzwt(), fxfzst(), fxfzcl() +int strncmp(), fxf_header_size(), fxf_totpix() +int strlen(), fopnbf(), fstatl(), itoc() + +include + +define err_ 91 +define endowr_ 92 + +begin + call smark (sp) + call salloc (fn, SZ_PATHNAME, TY_CHAR) + + status = OK + fit = IM_KDES(im) + + compress = YES + blklen = 1 + pixoff = 1 + + # Tell IMIO where the pixels are. Append the 'fit' mem descriptor + # to filename so that low level zfiofit routines can use it. + + call strcpy (IM_HDRFILE(im), Memc[fn], SZ_PATHNAME) + call strcat ("_", Memc[fn], SZ_PATHNAME) + i = strlen (Memc[fn]) + junk = itoc (fit, Memc[fn+i], SZ_PATHNAME) + iferr (call fpathname (Memc[fn], pathname, SZ_PATHNAME)) + goto err_ + + if (FKS_OVERWRITE(fit) == YES) { + call fxf_overwrite_unit (fit, im) + goto endowr_ + } + + switch (IM_ACMODE(im)) { + case READ_ONLY, READ_WRITE, WRITE_ONLY: + # Turn on IEEE mapping on input only. + call ieegnanr (FIT_SVNANR(fit)) + call ieegmapr (FIT_SVMAPRIN(fit), FIT_SVMAPROUT(fit)) + call ieegnand (FIT_SVNAND(fit)) + call ieegmapd (FIT_SVMAPDIN(fit), FIT_SVMAPDOUT(fit)) + call ieesnanr (0.0) + call ieemapr (YES, NO) + call ieesnand (0.0D0) + call ieemapd (YES, NO) + + # If the FIT datatype is BYTE or SHORT with scaling then + # convert to TY_SHORT and TY_REAL respectively before + # releasing the data to the upper level calls. This is + # because IMIO does not support BYTE datatype and the need + # to scale 16 bits to 32 bits. + + # Do not open pixel portion if it is empty or is not + # an IMAGE type. + + if ((strncmp (FIT_EXTTYPE(fit), "IMAGE", 5) != 0 && + strncmp (FIT_EXTTYPE(fit), "SIMPLE", 6) != 0) || + IM_NDIM(im) <= 0) { + + goto err_ + } + + FIT_IM(fit) = im + iferr (IM_PFD(im) = fopnbf (pathname, IM_ACMODE(im), + fxfzop, fxfzrd, fxfzwr, fxfzwt, fxfzst, fxfzcl)) { + IM_PFD(im) = NULL + goto err_ + } + + FIT_TOTPIX(fit) = fxf_totpix(im) + filesize = fstatl (IM_PFD(im), F_FILESIZE) + FIT_PFD(fit) = IM_PFD(im) + + case NEW_COPY, NEW_IMAGE, APPEND: + # See if the application has set the number of dimensions. + call fxf_chk_ndim (im) + FIT_PIXTYPE(fit) = IM_PIXTYPE(im) + npix = fxf_totpix (im) + FIT_NAXIS(fit) = IM_NDIM(im) + call amovi (IM_LEN(im,1), FIT_LENAXIS(fit,1), IM_NDIM(im)) + + call fxf_discard_keyw (im) + FIT_TOTPIX(fit) = npix + + # Do not allow BSCALE and BZERO in the UA when making a new copy or + # new image if bitpix is negative. Except for ushort + + if (IM_PIXTYPE(im) != TY_USHORT) { + call fxf_filter_keyw (im, "BSCALE") + call fxf_filter_keyw (im, "BZERO") + } + + # Hdr_size is in char units. (i.e. 1440 chars per FITS block). + hdr_size = fxf_header_size (im) + + # Reset the scaling parameter because in NEW_COPY mode there + # should not be scaled pixels. The previous call will get these + # values from the input image. + + FIT_BSCALE(fit) = 1.0d0 + FIT_BZERO(fit) = 0.0d0 + + sz_pixfile = npix * pix_size[IM_PIXTYPE(im)] + + # The pixel file needs to be a multiple of 1440 chars. + sz_pixfile = FITS_LEN_CHAR (sz_pixfile) + sz_fitfile = sz_pixfile + hdr_size + + if (FIT_NEWIMAGE(fit) == YES) + call falloc (IM_PIXFILE(im), sz_fitfile) + + FIT_IM(fit) = im + + iferr (IM_PFD(im) = fopnbf (pathname, READ_WRITE, + fxfzop, fxfzrd, fxfzwr, fxfzwt, fxfzst, fxfzcl)) { + IM_PFD(im) = NULL + call erract (EA_FATAL) + goto err_ + } + + FIT_PFD(fit) = IM_PFD(im) + filesize = fstatl (IM_PFD(im), F_FILESIZE) + FIT_EOFSIZE(fit) = filesize + 1 + + if (FIT_NEWIMAGE(fit) == NO) { + # Now we are appending a new IMAGE extension. + # Write a blank header in order to append the + # pixels after it. + + pixoff = filesize + hdr_size + 1 + + # Update the offset for the blank write to follow which uses + # a local file driver tied to the IM_PFD descriptor and not + # the normal FIO. + FIT_PIXOFF(fit) = pixoff + + # Update filesize + filesize = filesize + sz_fitfile + call fxf_write_blanks (IM_PFD(im), hdr_size) + } else + pixoff = hdr_size + 1 + + FIT_PIXOFF(fit) = pixoff + call imioff (im, pixoff, compress, blklen) + + IM_HFD(im) = NULL + + default: + call imerr (IM_NAME(im), SYS_IMACMODE) + } + +endowr_ + FIT_PFD(fit) = IM_PFD(im) + FIT_HFD(fit) = IM_HFD(im) + + # The following statement is to pass the datatype at the low + # level fits read and write routines. The datatype value can + # change after the image is open. Hopefully the value of 'im' + # will remain static. + + FIT_IM(fit) = im + status = OK + + call sfree (sp) + return +err_ + status = ERR + call sfree (sp) +end + + +# FXF_HEADER_SIZE -- Function to calculate the header size that would go +# into the output file extension. + +int procedure fxf_header_size (im) + +pointer im #I Image descriptor + +bool inherit +int merge, hdr_size +pointer op, fit, sp, tb, pb +int nheader_cards, ualen, ulines, clines +int strlen() + +begin + fit = IM_KDES(im) + inherit = false + + # Fks_inherit is a combined value. + if (FKS_INHERIT(fit) == YES) + inherit = true + + call fxf_mandatory_cards (im, nheader_cards) + + if (FIT_NEWIMAGE(fit) == NO && inherit) { + # See if current UA keywords are in the global header, if not + # there put it in a spool file. At the end, the spool file size is + # the output extension header size to be use in fitupdhdr. + + # Check if the file is still in cache. We need CACHELEN and + # CACHEHDR. + + call fxf_not_incache (im) + + op = IM_USERAREA(im) + ualen = strlen (Memc[op]) + ulines = ualen / LEN_UACARD + clines = FIT_CACHEHLEN(fit) / LEN_UACARD + + call smark (sp) + call salloc (tb, ualen+1, TY_CHAR) + + merge = NO + pb = tb + + # Now select those lines from the UA (pointed by op) that are + # not in the cache and accumulate them in 'pb'. + + call fxf_match_str (op, ulines, FIT_CACHEHDR(fit), clines,merge,pb) + Memc[pb+1] = EOS + ualen = strlen (Memc[tb]) + + call sfree (sp) + + } else { + op = IM_USERAREA(im) + ualen = strlen (Memc[op]) + } + + ulines = ualen / LEN_UACARD + nheader_cards + FKS_PADLINES(fit) + + ##### Note: PHULINES is not currently used, should be implemented + ##### Not clear to me if this code here is used for the PHU since + ##### it is in opix! + + # See if the application has set a minumum number of card for the UA. + + ulines = max (ulines, FKS_EHULINES(fit)) + + # The user area contains new_lines (81 chars, LEN_UACARD). Scale to + # 80 chars (LEN_CARD). Ualen is in bytes. + + ualen = ulines * LEN_CARD + + # Calculate the number of header FITS blocks in chars. + hdr_size = FITS_LEN_CHAR (ualen / 2) + + return (hdr_size) +end + + +# FXF_BYTE_SHORT -- This routine is obsolete and has been deleted, but is +# being preserved for the V2.11.2 patch so that a new shared library version +# does not have to be created. It can be deleted in the next major release. + +procedure fxf_byte_short (im, fname) + +pointer im +char fname[ARB] + +begin +end + + +# FXF_WRITE_BLANKS --Procedure to append a blank header to an existing +# file, preparing to write data after it. + +procedure fxf_write_blanks (fd, size) + +int fd #I File descriptor +int size #I New size (chars) to allocate. + +pointer sp, bf +int nblocks,i, fits_lenc + +begin + call smark (sp) + + # Length of a FITS block (2880) in chars. + fits_lenc = FITS_BLOCK_BYTES/SZB_CHAR + call salloc (bf, fits_lenc, TY_INT) + call amovki (0, Memi[bf], fits_lenc) + + size = FITS_LEN_CHAR(size) + nblocks = size / fits_lenc + + call seek (fd, EOF) + do i = 1, nblocks + call write (fd, Memi[bf], fits_lenc) + + call sfree (sp) +end + + +# FXF_MANDATORY_CARDS -- Count the required FITS header cards. +# The cards for the Main Unit are: SIMPLE, BITPIX, NAXIS, +# EXTEND, ORIGIN, DATE, IRAF_TLM, OBJECT and END; +# 'IM_NDIM(im)', DATAMIN and DATAMAX will be put out +# only if the LIMTIME > MTIME. +# would take care of NAXISi. For an Extension unit, the cards are: +# XTENSION, BITPIX, NAXIS, PCOUNT, GCOUNT, ORIGIN, DATE, INHERIT, +# EXTNAME, IRAF_TLM, OBJECT and END; IM_NDIM(im) takes care of +# NAXISi. Same as above for DATAMIN, DATAMAX. +# If these cards are in the main header, reduce the number of +# mandatory cards that are going to be created at closing time +# (in fitupdhdr). + +procedure fxf_mandatory_cards (im, nheader_cards) + +pointer im #I im structure +int nheader_cards #O Number of mandatory cards in header. + +pointer ua +int ncards, rp, fit, acmode +int idb_findrecord() + +begin + ua = IM_USERAREA(im) + fit = IM_KDES(im) + + if (FIT_NEWIMAGE(fit) == YES) # create a PHU + ncards = 9 + IM_NDIM(im) + else # create an EHU + ncards = 12 + IM_NDIM(im) + + if (idb_findrecord (im, "PCOUNT", rp) > 0) { + if (FIT_XTENSION(fit) == YES) + ncards = ncards - 1 + else + call fxf_filter_keyw (im, "PCOUNT") + } + if (idb_findrecord (im, "GCOUNT", rp) > 0) { + if (FIT_XTENSION(fit) == YES) + ncards = ncards - 1 + else + call fxf_filter_keyw (im, "GCOUNT") + } + if (idb_findrecord (im, "EXTNAME", rp) > 0) { + if (FIT_XTENSION(fit) == YES) + ncards = ncards - 1 + else + call fxf_filter_keyw (im, "EXTNAME") + } + if (idb_findrecord (im, "INHERIT", rp) > 0) { + if (FIT_XTENSION(fit) == YES) + ncards = ncards - 1 + else + call fxf_filter_keyw (im, "INHERIT") + } + if (idb_findrecord (im, "EXTEND", rp) > 0) { + if (FIT_XTENSION(fit) == NO) { + ncards = ncards - 1 + } else { + # Delete the keyword from the UA because EXTEND is not + # recommended in XTENSION units. + + call fxf_filter_keyw (im, "EXTEND") + } + } + + if (idb_findrecord (im, "ORIGIN", rp) > 0) + ncards = ncards - 1 + if (idb_findrecord (im, "DATE", rp) > 0 ) + ncards = ncards - 1 + if (idb_findrecord (im, "IRAF-TLM", rp) > 0) + ncards = ncards - 1 + if (idb_findrecord (im, "OBJECT", rp) > 0) + ncards = ncards - 1 + + # See if we need to add one more mandatory card when an EXTVER value + # was specified when appending a new extension. + + if (FIT_NEWIMAGE(fit) == NO && idb_findrecord(im,"EXTVER",rp) == 0) { + # Keyword does not exist. + acmode = IM_ACMODE(im) + if ((acmode == NEW_IMAGE || acmode == NEW_COPY) && + FKS_EXTVER(fit) != INDEFL ) + ncards = ncards + 1 + } + + # We want to keep BSCALE and BZERO in the UA in case we are + # editing the values. Is up to the user or application + # responsability to deal with the change in pixel value when reading. + # If we are reading pixels the values will change according to the + # input BSCALE and BZERO. If we are adding BSCALE and BZERO before + # accessing any pixels, these will get scale. If adding or + # changing right before closing the image, the pixel value will be + # unchanged. + + # See if BSCALE and BZERO are in the UA for ushort, otherwise + # increase the number. + + if (IM_PIXTYPE(im) == TY_USHORT) { + if (idb_findrecord (im, "BSCALE", rp) == 0) + ncards = ncards + 1 + if (idb_findrecord (im, "BZERO", rp) == 0) + ncards = ncards + 1 + } + nheader_cards = ncards +end + + +# FXF_OVERWRITE_UNIT -- Overwrite an existent extension. A temporary file +# is created that contains the current file upto the extension before the +# one to be overwrite. + +procedure fxf_overwrite_unit (fit, im) + +pointer fit #I Fits descriptor +pointer im #I Image descriptor + +pointer sp, file, mii +int pixoff, compress, blklen, sz_fitfile, i, group, filesize +int junk, in_fd, out_fd, nblocks, nk, hdr_size, sz_pixfile +extern fxfzop(), fxfzrd(), fxfzwr(), fxfzwt(), fxfzst(), fxfzcl() +int fnroot(), open(), read(), fxf_totpix(), strncmp(), itoc() +int strlen(), fopnbf(), fstatl(), fxf_header_size() + +include + +errchk syserr, syserrs +define err_ 91 + +begin + group = FIT_GROUP(fit) + + # Do not overwrite extensions that are not IMAGE. + if (group != 0 && strncmp (FIT_EXTTYPE(fit), "IMAGE", 5) != 0 && + strncmp (FIT_EXTTYPE(fit), "SIMPLE", 6) != 0) { + + call syserr (SYS_FXFOVRBEXTN) + return + } + + call smark (sp) + call salloc (file, SZ_FNAME, TY_CHAR) + call salloc (mii, FITS_BLOCK_CHARS, TY_INT) + + junk = fnroot (IM_HDRFILE(im), Memc[file], SZ_FNAME) + + # Keep the temporary filename in IM_PIXFILE(im). + call mktemp (Memc[file], IM_PIXFILE(im), SZ_PATHNAME) + call strcat (".fits", IM_PIXFILE(im), SZ_PATHNAME) + + # If we want to overwrite the first group there is nothing + # to copy first. + + if (group != 0) { + # Copy from the old file up to hdr_off[group] into a temporary file. + in_fd = open (IM_HDRFILE(im), READ_ONLY, BINARY_FILE) + out_fd = open (IM_PIXFILE(im), NEW_FILE, BINARY_FILE) + nblocks = Memi[FIT_HDRPTR(fit)+group]/ FITS_BLOCK_CHARS + do nk = 1, nblocks { + junk = read (in_fd, Memi[mii], FITS_BLOCK_CHARS) + call write (out_fd, Memi[mii], FITS_BLOCK_CHARS) + } + call close (in_fd) + call close (out_fd) + } + + FIT_NAXIS(fit) = IM_NDIM(im) + call amovi (IM_LEN(im,1), FIT_LENAXIS(fit,1), IM_NDIM(im)) + + FIT_TOTPIX(fit) = fxf_totpix(im) + + # Do not allow BSCALE and BZERO in the UA when making a new copy or + # new image if bitpix is negative. Except for ushort. + + if (IM_PIXTYPE(im) != TY_USHORT) { + call fxf_filter_keyw (im, "BSCALE") + call fxf_filter_keyw (im, "BZERO") + } + + # The new copy header should not have the following keywords: + # GROUPS, PSIZE and that could come from a GEIS file. + + call fxf_discard_keyw (im) + hdr_size = fxf_header_size (im) + + # Reset the scaling parameter because in NEW_COPY mode there + # should not be scaled pixels. The previous call will get these + # values from the input image. + + FIT_BSCALE(fit) = 1.0d0 + FIT_BZERO(fit) = 0.0d0 + + call fpathname (IM_PIXFILE(im), Memc[file], SZ_PATHNAME) + call strcat("_", Memc[file], SZ_PATHNAME) + i = strlen(Memc[file]) + junk = itoc (fit, Memc[file+i], SZ_PATHNAME) + + # The pixel file needs to be a multiple of 1440 chars. + sz_pixfile = fxf_totpix(im) * pix_size[IM_PIXTYPE(im)] + sz_pixfile = FITS_LEN_CHAR(sz_pixfile) + sz_fitfile = sz_pixfile + hdr_size + + if (group == 0) + call falloc (IM_PIXFILE(im), sz_fitfile) + + FIT_IM(fit) = im + iferr (IM_PFD(im) = fopnbf (Memc[file], READ_WRITE, + fxfzop, fxfzrd, fxfzwr, fxfzwt, fxfzst, fxfzcl)) { + + IM_PFD(im) = NULL + goto err_ + } + + filesize = fstatl (IM_PFD(im), F_FILESIZE) + FIT_EOFSIZE(fit) = filesize + 1 + # Now write a blank header. + if (group != 0) { + call amovki (0, Memi[mii], FITS_BLOCK_CHARS) + nblocks = hdr_size/FITS_BLOCK_CHARS + FIT_HFD(fit) = -1 + + call seek (IM_PFD(im), EOF) + do nk = 1, nblocks + call write (IM_PFD(im), Memi[mii], FITS_BLOCK_CHARS) + + pixoff = filesize + hdr_size + 1 + filesize = filesize + sz_fitfile + } else + pixoff = hdr_size + 1 + + + FIT_PIXOFF(fit) = pixoff + IM_HFD(im) = NULL + + blklen = 1 + compress = YES + call imioff (im, pixoff, compress, blklen) + + FIT_PFD(fit) = IM_PFD(im) + FIT_HFD(fit) = IM_HFD(im) + + call sfree (sp) + return +err_ + call syserr (SYS_FXFOVRTOPN) + call sfree (sp) +end + + +# TOTPIX -- Calculate the total number of pixels in the image. + +int procedure fxf_totpix (im) + +pointer im #I image descriptor +int i, pix, ndim + +begin + ndim = IM_NDIM(im) + if (ndim == 0) + return (0) + + pix = IM_LEN(im,1) + do i = 2, ndim + pix = pix * IM_LEN(im,i) + + return (pix) +end + + +# FXF_DISCARD_FITS_KEYW -- Exclude certain keywords from a new copy image. + +procedure fxf_discard_keyw (im) + +pointer im #I image descriptor +pointer fit + +begin + fit = IM_KDES(im) + + call fxf_filter_keyw (im, "GROUPS") + call fxf_filter_keyw (im, "PSIZE") + call fxf_filter_keyw (im, "BLOCKED") + call fxf_filter_keyw (im, "IRAFNAME") + call fxf_filter_keyw (im, "IRAF-BPX") + call fxf_filter_keyw (im, "IRAFTYPE") + + if (FIT_NEWIMAGE(fit) == NO) + call fxf_filter_keyw (im, "EXTEND") + + # Create a PHU. + if (FIT_NEWIMAGE(fit) == YES) { + call fxf_filter_keyw (im, "PCOUNT") + call fxf_filter_keyw (im, "GCOUNT") + call fxf_filter_keyw (im, "INHERIT") + call fxf_filter_keyw (im, "EXTNAME") + call fxf_filter_keyw (im, "EXTVER") + call fxf_filter_keyw (im, "EXTLEVEL") + } +end + + +# FXF_FILTER_KEYW -- Delete the names keyword from the userarea. + +procedure fxf_filter_keyw (im, key) + +pointer im #I image descriptor +char key[ARB] #I keyword name to delete from USERAREA. + +pointer rp +int off +int idb_findrecord(), stridxs() + +begin + # Verify that the named user field exists. + if (idb_findrecord (im, key, rp) <= 0) + return + + # Delete the field. + off = stridxs ("\n", Memc[rp]) + if (off > 0) + call strcpy (Memc[rp+off], Memc[rp], ARB) + else + Memc[rp] = EOS +end + + +# FXF_FALLOC -- Preallocate space on disk by writing blanks. + +procedure fxf_falloc (fname, size) + +char fname[ARB] #I filename +int size #I size to preallocate in chars + +pointer sp, cp +int nb,i, fd +errchk open, write +int open() + +begin + call smark (sp) + call salloc (cp, FITS_BLOCK_CHARS, TY_CHAR) + + call amovkc (' ', Memc[cp], FITS_BLOCK_CHARS) + nb = size / FITS_BLOCK_CHARS + fd = open (fname, NEW_FILE, BINARY_FILE) + + do i = 1, nb + call write (fd, Memc[cp], FITS_BLOCK_CHARS) + + call flush (fd) + call close (fd) + call sfree (sp) +end + + +# FXF_CKH_NDIM -- Check that the application has indeed set the number +# of dimension, otherwise count the axes. + +procedure fxf_chk_ndim (im) + +pointer im #I imio descriptor +int ndim #I number of dimension for image + +begin + ndim = IM_NDIM(im) + + # If ndim was not explicitly set, compute it by counting the number + # of nonzero dimensions. + + if (ndim == 0) { + for (ndim=1; IM_LEN(im,ndim) > 0 && ndim <= IM_MAXDIM; ndim=ndim+1) + ; + ndim = ndim - 1 + IM_NDIM(im) = ndim + } +end + + +# FXF_NOT_INCACHE -- Procedure to find whether the file is in the +# cache. It could happen that the slot with the entry might have been +# freed to make room for another file. We want to have valid pointers +# for FIT_CACHEHDR and FIT_CACHELEN since the calling routine will use them. + +procedure fxf_not_incache (im) + +pointer im #I image descriptor + +int cindx, group, sfit[4] +pointer sp, hdrfile, fit +bool streq() + +include "fxfcache.com" + +begin + call smark (sp) + call salloc (hdrfile, SZ_PATHNAME, TY_CHAR) + + call fpathname (IM_HDRFILE(im), Memc[hdrfile], SZ_PATHNAME) + fit = IM_KDES(im) + + do cindx=1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + + if (streq (Memc[hdrfile], rf_fname[1,cindx])) { + call sfree (sp) + return + } + } + sfit[1]= FIT_NAXIS(fit) + sfit[2] = FIT_INHERIT(fit) + sfit[3] = FIT_PLMAXLEN(fit) + sfit[4] = IM_CTIME(im) + + group = max (0, FIT_GROUP(fit)) + + call fxf_prhdr(im,group) + + FIT_NAXIS(fit) = sfit[1] + FIT_INHERIT(fit) = sfit[2] + FIT_PLMAXLEN(fit) = sfit[3] + IM_CTIME(im) = sfit[4] + + call sfree (sp) + return +end + diff --git a/sys/imio/iki/fxf/fxfpak.x b/sys/imio/iki/fxf/fxfpak.x new file mode 100644 index 00000000..01db148d --- /dev/null +++ b/sys/imio/iki/fxf/fxfpak.x @@ -0,0 +1,58 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "fxf.h" + + +# FXF_PAK_DATA -- Convert npix elements of type pixtype as needed for storage +# in a FITS file. All floating point data will be converted to IEEE format. +# The input and output buffers may be the same if desired. + +procedure fxf_pak_data (ibuf, obuf, npix, pixtype) + +char ibuf[ARB] #I input data buffer +char obuf[ARB] #I output data buffer +int npix #I number of pixels in buffer +int pixtype #I input pixel datatype + +int nbytes, nchars +errchk syserr + +include + +begin + ### Possibly the MII conversion routines should be used here as + ### they handle all these datatypes (except maybe ushort). + + nchars = npix * pix_size[pixtype] + nbytes = nchars * SZB_CHAR + + switch (pixtype) { + case TY_USHORT: + call fxf_altmu (ibuf, obuf, npix) + if (BYTE_SWAP2 == YES) + call bswap2 (obuf, 1, obuf, 1, nbytes) + + case TY_SHORT: + if (BYTE_SWAP2 == YES) + call bswap2 (ibuf, 1, obuf, 1, nbytes) + else + call amovc (ibuf, obuf, nchars) + + case TY_INT, TY_LONG: + if (BYTE_SWAP4 == YES) + call bswap4 (ibuf, 1, obuf, 1, nbytes) + else + call amovc (ibuf, obuf, nchars) + + case TY_REAL: + call ieevpakr (ibuf, obuf, npix) + + case TY_DOUBLE: + call ieevpakd (ibuf, obuf, npix) + + default: + call syserr (SYS_FXFPKDTYP) + } +end diff --git a/sys/imio/iki/fxf/fxfplread.x b/sys/imio/iki/fxf/fxfplread.x new file mode 100644 index 00000000..4d4c3e83 --- /dev/null +++ b/sys/imio/iki/fxf/fxfplread.x @@ -0,0 +1,160 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include "fxf.h" + + +# FXF_PLREAD -- Read a PLIO mask stored in a FITS binary table extension +# and load it into an image descriptor. +# +# There is a builtin assumption in this code (also in fxf_plwrite) that +# masks will not be more than 3-dimensional. This could be generalized +# if necessary, but we have never seen a mask of dimensionality higher +# than 3. The dimensionality, size, and depth of the mask is preserved. + +procedure fxf_plread (im) + +pointer im #I image descriptor + +char kwname[SZ_KEYWORD] +pointer sp, fk, pl, lp, ip, ix +long data_offset, data_len, heap_offset, llen, loff +int naxes, axlen[IM_MAXDIM], depth, maxlen +int fd, i, j, nelem, nlines, v[PL_MAXDIM], maxoff, nbytes + +long note() +bool streq() +int imgeti(), pl_create(), miireadi(), miireads() +errchk imgeti, pl_create, miireadi, miireads, seek, pl_update, syserrs + +begin + call smark (sp) + + fk = IM_KDES(im) + fd = IM_HFD(im) + + # The maximum encoded line list length is (normally) passed in via + # the binary table format keywords, and stored in FIT_PLMAXLEN. + + maxlen = FIT_PLMAXLEN(fk) + if (maxlen <= 0) + maxlen = DEF_PLMAXLEN + + # Scratch buffer for encoded line lists. + call salloc (lp, maxlen, TY_SHORT) + + # Get the dimensionality and size of the stored mask. + call amovki (1, axlen, IM_MAXDIM) + naxes = imgeti (im, "ZNAXIS") + call fxf_filter_keyw (im, "ZNAXIS") + do i = 1, naxes { + call sprintf (kwname, LEN_CARD, "ZNAXIS%d") + call pargi(i) + axlen[i] = imgeti (im, kwname) + call fxf_filter_keyw (im, kwname) + call sprintf (kwname, LEN_CARD, "ZTILE%d") + call pargi(i) + call fxf_filter_keyw (im, kwname) + } + + # Get the mask depth, passed as compression algorithm parameter + # number 1 for a PLIO-compressed image. + + depth = DEF_PLDEPTH + ifnoerr (call imgstr (im, "ZNAME1", kwname, SZ_KEYWORD)) { + if (streq (kwname, "depth")) + iferr (depth = imgeti (im, "ZVAL1")) + depth = DEF_PLDEPTH + call fxf_filter_keyw (im, "ZNAME1") + call fxf_filter_keyw (im, "ZVAL1") + call fxf_filter_keyw (im, "ZBITPIX") + call fxf_filter_keyw (im, "ZIMAGE") + } + + # Create an initially empty mask of the given size. + pl = pl_create (naxes, axlen, depth) + + # Create a buffer for the line list index (maxdim 3 assumed). + nlines = axlen[3] * axlen[2] + call salloc (ix, nlines * 2, TY_INT) + + # Compute the file offsets of the table data and heap areas. The + # file position is assumed to be already positioned at the start + # of the data area of the file. + + data_offset = note (fd) + data_len = FIT_LENAXIS(fk,3) * FIT_LENAXIS(fk,2) * FIT_LENAXIS(fk,1) + heap_offset = data_offset + data_len/SZB_CHAR + + # Read the line list index from the input file. The index contains + # one entry for every line in the (possibly multidimensional) image. + # Each entry consists of two integer values, the length of the + # stored line list, and the heap offset (in bytes) of the stored list. + + nelem = miireadi (fd, Memi[ix], nlines * 2) + if (nelem != nlines * 2) + call syserrs (SYS_FXFRMASK, IM_NAME(im)) + + # Find out the maximum offset value to determine if they were + # written using the 2 byte units rather than the standard (byte unit) + + maxoff = 0 + ip = ix + do j = 1, axlen[3] { + do i = 1, axlen[2] { + maxoff = max (maxoff, Memi[ip+1]+2*Memi[ip]) + ip = ip + 2 + } + } + + if (maxoff < (FIT_PCOUNT(fk) - maxoff/2)) { + nbytes = 1 + } else { + nbytes = 2 + } + + # Read the line list data and insert it into the PLIO mask. + # pl_update will be called for each line of the mask even if multiple + # lines point to the same line list data, but pl_update will sort + # all this out and restore the multiple references as the mask is + # built. + + ip = ix + v[1] = 1 + + do j = 1, axlen[3] { + v[3] = j + do i = 1, axlen[2] { + v[2] = i + + llen = Memi[ip] + + # This offset on the table data is in byte units, convert + # to short. + + loff = Memi[ip+1] / nbytes + + call seek (fd, heap_offset + loff) + nelem = miireads (fd, Mems[lp], llen) + if (nelem != llen) + call syserrs (SYS_FXFRMASK, IM_NAME(im)) + + call pl_update (pl, v, Mems[lp]) + + ip = ip + 2 + } + } + + # Set up IMIO descriptor. + call amovl (axlen, IM_LEN(im,1), IM_MAXDIM) + call amovl (axlen, IM_PHYSLEN(im,1), IM_MAXDIM) + IM_NDIM(im) = naxes + IM_PIXTYPE(im) = TY_INT + IM_PL(im) = pl + + call sfree (sp) +end diff --git a/sys/imio/iki/fxf/fxfplwrite.x b/sys/imio/iki/fxf/fxfplwrite.x new file mode 100644 index 00000000..65909dcb --- /dev/null +++ b/sys/imio/iki/fxf/fxfplwrite.x @@ -0,0 +1,418 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include +include "fxf.h" + + +# FXFPLWRITE.X -- Routines to handle masks in FITS extensions. +# +# fxf_plwrite (im, fd) +# fxf_plinfo (im, maxlen, pcount, depth) +# fxf_pl_adj_heap (im, hdr_fd, pcount) +# fxf_copy_adj (im, in_fd, hdroff, poff, datasize) +# fxf_plpf (im) +# + + +# FXF_PLWRITE -- Write the data from a PLIO mask into the data area of a +# FITS compressed image (ZIMAGE) binary table extension. The data is +# written to the file pointed to by file descriptor FD. +# +# The data to be written consists of the data for the ZIMAGE binary table +# records, followed by the heap area of the BINTABLE extension, which +# contains the actual encoded line lists. For simplicity we assume that +# the table contains only one column, the COMPRESSED_DATA column, which is +# of type variable length integer array. Each element of this column is a +# BINTABLE variable length array descriptor which physically consists of two +# integer values: an integer giving the length of the stored array (encoded +# line list), followed by an integer (in byte unit) giving the offset of +# the array data (encoded line list) in the heap area. Multiple variable +# length array descriptors may point to the same stored array, and in +# fact PLIO uses this feature to implement compression in the Y direction +# (adjacent mask lines will point to the same encoded line list). +# The code here supports masks of up to 3 dimensions. + +procedure fxf_plwrite (im, fd) + +pointer im #I image descriptor +int fd #I output file descriptor + +int i, j, v_in[PL_MAXDIM], lp_len +int naxes, axlen[PL_MAXDIM], depth +int heap_offset, ep_off, lp_off, vararray[2] +pointer pl, lp, op, emptyline, lastline + +int pl_llen() +pointer pl_access(), pl_emptyline() +errchk pl_access + +begin + pl = IM_PL(im) + call pl_gsize (pl, naxes, axlen, depth) + + # Write the COMPRESSED_DATA table column. This is an index giving + # the length and heap offset of the encoded PLIO line list for each + # line of the image. Multiple image lines (index entries) may point + # to the same stored line list: this happens if a mask line is empty + # (the empty line) or if successive lines are all the same. For the + # sake of simplicity, only masks of up to 3 dimensions are supported. + + op = 0 + heap_offset = 0 + emptyline = pl_emptyline (pl) + ep_off = -1 + lastline = NULL + lp_off = -1 + call amovkl(long(1), v_in, PL_MAXDIM) + + do j = 1, axlen[3] { + v_in[3] = j + do i = 1, axlen[2] { + v_in[2] = i + lp = pl_access (pl, v_in) + lp_len = pl_llen (Mems[lp]) + + if (lp == emptyline && ep_off >= 0) + op = ep_off + else if (lp == lastline) + op = lp_off + else + op = heap_offset + + vararray[1] = lp_len + + # The offsets on the FITS BINTABLE is in byte unit + # as establish by the FITS standard. + + vararray[2] = op * 2 # Byte offset + + call miiwritei (fd, vararray, 2) + + lastline = lp + lp_off = op + if (lp == emptyline && ep_off < 0) + ep_off = op + + if (op == heap_offset) + heap_offset = heap_offset + lp_len + } + } + # Now write the line list data to the heap area. The logic here must + # follow that above or the line offsets won't match. + + ep_off = -1 + lp_off = -1 + lastline = NULL + + do j = 1, axlen[3] { + v_in[3] = j + do i = 1, axlen[2] { + v_in[2] = i + lp = pl_access (pl, v_in) + lp_len = pl_llen (Mems[lp]) + + if (lp == emptyline && ep_off >= 0) + next + else if (lp == lastline) + next + + call miiwrites (fd, Mems[lp], lp_len) + + lastline = lp + if (lp == emptyline && ep_off < 0) + ep_off = 0 + } + } +end + + +# FXF_PLINFO -- Examine a PLIO mask and compute the maximum length of an +# encoded line list, and the storage in bytes required to store the mask +# data in the heap area of a FITS binary table. + +procedure fxf_plinfo (im, maxlen, pcount, depth) + +pointer im #I image descriptor +int maxlen #O maximum line list length +int pcount #O storage required to store mask (bytes) +int depth #O mask depth + +int naxes, axlen[PL_MAXDIM] +int i, j, v_in[PL_MAXDIM], lp_len +int heap_offset, ep_off, lp_off +pointer pl, lp, op, emptyline, lastline + +int pl_llen() +pointer pl_access(), pl_emptyline() +errchk pl_access + +begin + pl = IM_PL(im) + call pl_gsize (pl, naxes, axlen, depth) + + op = 0 + maxlen = 0 + heap_offset = 0 + emptyline = pl_emptyline (pl) + ep_off = -1 + lastline = NULL + lp_off = -1 + call amovkl(long(1), v_in, PL_MAXDIM) + + # The following must duplicate the logic above for determining what + # gets written to the heap area. All we are doing here is computing + # the amount of heap storage required to store the compressed mask. + + do j = 1, axlen[3] { + v_in[3] = j + do i = 1, axlen[2] { + v_in[2] = i + lp = pl_access (pl, v_in) + lp_len = pl_llen (Mems[lp]) + maxlen = max (maxlen, lp_len) + + if (lp == emptyline && ep_off >= 0) + op = ep_off + else if (lp == lastline) + op = lp_off + else + op = heap_offset + + lastline = lp + lp_off = op + if (lp == emptyline && ep_off < 0) + ep_off = op + + if (op == heap_offset) + heap_offset = heap_offset + lp_len + } + } + + pcount = heap_offset * (SZ_SHORT * SZB_CHAR) +end + + +# FXF_PL_ADJ_HEAP -- Resize heap when we have a hole bigger than 2880 bytes +# or if we overwrite the next extension. + +procedure fxf_pl_adj_heap (im, hdr_fd, pcount) + +pointer im #I imio descriptor +int hdr_fd #U file descriptor +int pcount #I new heap size in bytes + +pointer fk, hdrp, pixp +int datasize, hdroff, diff, nb, group, i + +begin + fk = IM_KDES(im) + + # Calculate the size of the TABLE data. (8 bytes per line) + datasize = FIT_LENAXIS(fk,1)*FIT_LENAXIS(fk,2)* + FIT_LENAXIS(fk,3) + datasize = (datasize + pcount)/SZB_CHAR + + call fxf_not_incache(im) + hdrp = FIT_HDRPTR(fk) + pixp = FIT_PIXPTR(fk) + group = FIT_GROUP(fk) + + hdroff = Memi[hdrp+group] + + # Calculate the amount of space left or grown in the heap + # as a result of the READ-WRITE operation on the data. + + diff = datasize - (Memi[hdrp+group+1] - Memi[pixp+group]) + + # See if the new data overwrites the next unit or + # there is a hole with more than 2880 bytes. + + if ( (diff > 0) || ((-diff / 2880) > 0) ) { + + # Adjust the header and pixel offset for subsequent groups. + # Add header size. + datasize = datasize + Memi[pixp+group] - Memi[hdrp+group] + call fxf_copy_adj (im, hdr_fd, hdroff, Memi[hdrp+group+1], datasize) + + if (diff > 0) + nb = FITS_LEN_CHAR (diff) + else + nb = (diff / 1440) * 1440 + + # Update FK cache offset values + do i = group+1, FIT_NUMOFFS(fk) { + Memi[hdrp+i] = Memi[hdrp+i] + nb + if (Memi[pixp+i] > 0) { + Memi[pixp+i] = Memi[pixp+i] + nb + } else + break + } + } +end + + +# FXF_COPY_ADJ -- Make a copy of the input file extending or shrinking +# the heap area. + +procedure fxf_copy_adj (im, in_fd, hdroff, poff, datasize) + +pointer im #I Imio descriptor +int in_fd #I Input file descriptor +int hdroff #I Header offset +int poff #I Pixel offset +int datasize #I New FITS unit size + +pointer sp, tempfile, outname +int nchars, junk, inoff, out_fd, size +int fnldir(), fnroot(), open(), note() +errchk open, note, seek, close, delete, rename +errchk fxf_make_adj_copy, fxf_write_blanks + +begin + call smark (sp) + call salloc (tempfile, SZ_FNAME, TY_CHAR) + call salloc (outname, SZ_FNAME, TY_CHAR) + + nchars = fnldir (IM_HDRFILE(im), Memc[tempfile], SZ_FNAME) + junk = fnroot (IM_HDRFILE(im), Memc[tempfile+nchars], SZ_FNAME) + call mktemp (Memc[tempfile], Memc[outname], SZ_PATHNAME) + call strcat (".fits", Memc[outname], SZ_PATHNAME) + + inoff = note (in_fd) + out_fd = open (Memc[outname], NEW_FILE, BINARY_FILE) + + call fxf_make_adj_copy (in_fd, out_fd, hdroff, poff, datasize) + + # Pad to 2880 bytes block + size = note (out_fd) - 1 + size = mod(size, FITS_BLOCK_CHARS) + if (size != 0) { + size = FITS_BLOCK_CHARS - size + call fxf_write_blanks (out_fd, size) + } + + size = note (out_fd) - 1 + call close (in_fd) + call delete (IM_HDRFILE(im)) + call rename (Memc[outname], IM_HDRFILE(im)) + + in_fd = out_fd + call seek (in_fd, inoff) + call sfree (sp) +end + + +# FXF_PLPF -- Initialize IMIO dependencies when dealing with a PLIO +# image mask. + +procedure fxf_plpf (im) + +pointer im #I IMIO descriptor + +int pfd +pointer sp, imname, ref_im +int sv_acmode, sv_update, ndim, i, depth +errchk iki_opix, open +int open() + +begin + call smark (sp) + call salloc (imname, SZ_IMNAME, TY_CHAR) + + # Complete the initialization of a mask image. + ref_im = IM_PLREFIM(im) + + sv_acmode = IM_ACMODE(im) + sv_update = IM_UPDATE(im) + call strcpy (IM_NAME(im), Memc[imname], SZ_IMNAME) + + if (ref_im != NULL) { + # Create a mask the same size as the physical size of the + # reference image. Inherit any image section from the + # reference image. + + IM_NDIM(im) = IM_NDIM(ref_im) + IM_NPHYSDIM(im) = IM_NPHYSDIM(ref_im) + IM_SECTUSED(im) = IM_SECTUSED(ref_im) + call amovl (IM_LEN(ref_im,1), IM_LEN(im,1), IM_MAXDIM) + call amovl (IM_PHYSLEN(ref_im,1),IM_PHYSLEN(im,1),IM_MAXDIM) + call amovl (IM_SVLEN(ref_im,1), IM_SVLEN(im,1), IM_MAXDIM) + call amovl (IM_VMAP(ref_im,1), IM_VMAP(im,1), IM_MAXDIM) + call amovl (IM_VOFF(ref_im,1), IM_VOFF(im,1), IM_MAXDIM) + call amovl (IM_VSTEP(ref_im,1), IM_VSTEP(im,1), IM_MAXDIM) + + # Tell PMIO to use this image as the reference image. + call pm_seti (IM_PL(im), P_REFIM, im) + + } else if (sv_acmode == NEW_IMAGE || sv_acmode == NEW_COPY) { + # If ndim was not explicitly set, compute it by counting + # the number of nonzero dimensions. + + ndim = IM_NDIM(im) + if (ndim == 0) { + ndim = 1 + while (IM_LEN(im,ndim) > 0 && ndim <= IM_MAXDIM) + ndim = ndim + 1 + ndim = ndim - 1 + IM_NDIM(im) = ndim + } + + # Make sure dimension stuff makes sense. + if (ndim < 0 || ndim > IM_MAXDIM) + call imerr (IM_NAME(im), SYS_IMNDIM) + + do i = 1, ndim + if (IM_LEN(im,i) <= 0) + call imerr (IM_NAME(im), SYS_IMDIMLEN) + + # Set the unused higher dimensions to 1. This makes it + # possible to access the image as if it were higher + # dimensional, and in a way it truely is. + + do i = ndim + 1, IM_MAXDIM + IM_LEN(im,i) = 1 + + IM_NPHYSDIM(im) = ndim + call amovl (IM_LEN(im,1), IM_PHYSLEN(im,1), IM_MAXDIM) + call amovl (IM_LEN(im,1), IM_SVLEN(im,1), IM_MAXDIM) + if (sv_acmode == NEW_IMAGE) + call amovkl (long(1), IM_VSTEP(im,1), IM_MAXDIM) + + depth = PL_MAXDEPTH + if (and (IM_PLFLAGS(im), PL_BOOL) != 0) + depth = 1 + call pl_ssize (IM_PL(im), IM_NDIM(im), IM_LEN(im,1), depth) + + } + + call strcpy (Memc[imname], IM_NAME(im), SZ_IMNAME) + IM_ACMODE(im) = sv_acmode + IM_UPDATE(im) = sv_update + IM_PIXOFF(im) = 1 + IM_HGMOFF(im) = NULL + IM_BLIST(im) = NULL + IM_HFD(im) = NULL + + pfd = open ("dev$null", READ_WRITE, BINARY_FILE) + IM_PFD(im) = pfd + + # Execute this even if pixel file has already been opened. + call imsetbuf (IM_PFD(im), im) + + # "Fast i/o" in the conventional sense no IMIO buffering) + # is not permitted for mask images, since IMIO must buffer + # the pixels, which are generated at run time. + + if (IM_FAST(im) == YES) { + IM_PLFLAGS(im) = or (IM_PLFLAGS(im), PL_FAST) + IM_FAST(im) = NO + } + + call sfree (sp) +end diff --git a/sys/imio/iki/fxf/fxfrcard.x b/sys/imio/iki/fxf/fxfrcard.x new file mode 100644 index 00000000..e025283e --- /dev/null +++ b/sys/imio/iki/fxf/fxfrcard.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "fxf.h" + +# FXF_READ_CARD -- Read a FITS header card. + +int procedure fxf_read_card (fd, ibuf, obuf, ncards) + +int fd #I Input file descriptor +char ibuf[ARB] #I input buffer +char obuf[ARB] #O Output buffer +int ncards #I ncards read so far + +int ip, nchars_read +int read() +errchk read + +begin + # We read one FITS block first, read card from it until 36 + # cards have been processed, where we read again. + + if (mod (ncards, 36) == 0) { + nchars_read = read (fd, ibuf, FITS_BLOCK_CHARS) + if (nchars_read == EOF) + return (EOF) + call miiupk (ibuf, ibuf, FITS_BLOCK_BYTES, MII_BYTE, TY_CHAR) + ip = 1 + } + + call amovc (ibuf[ip], obuf, LEN_CARD) + ip = ip + LEN_CARD + + return (LEN_CARD) +end diff --git a/sys/imio/iki/fxf/fxfrdhdr.x b/sys/imio/iki/fxf/fxfrdhdr.x new file mode 100644 index 00000000..7cfc7855 --- /dev/null +++ b/sys/imio/iki/fxf/fxfrdhdr.x @@ -0,0 +1,176 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "fxf.h" + + +# FXF_RHEADER -- Read a FITS header into the image descriptor and the +# internal FITS descriptor. + +procedure fxf_rheader (im, group, acmode) + +pointer im #I image descriptor +int group #I group number to read +int acmode #I access mode + +long pixoff, mtime +pointer sp, fit, lbuf, poff +int compress, devblksz, i, impixtype +bool bfloat, lscale, lzero +bool fxf_fpl_equald() +int strncmp() + +errchk fxf_rfitshdr, realloc, syserr, syserrs + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + fit = IM_KDES(im) + + FIT_MAX(fit) = 0.0 + FIT_MIN(fit) = 0.0 + FIT_MTIME(fit) = 0.0 + FIT_IM(fit) = im + FIT_OBJECT(fit) = EOS + IM_CLSIZE(im) = 0 + + # Read the header unit number 'group', setting the values of the + # reserved fields in the FIT descriptor saving it in the FITS cache. + + call fxf_rfitshdr (im, group, poff) + + IM_MIN(im) = FIT_MIN(fit) + IM_MAX(im) = FIT_MAX(fit) + IM_MTIME(im) = FIT_MTIME(fit) + call strcpy (FIT_OBJECT(fit), IM_TITLE(im), LEN_CARD) + + # If there is no group specification in the filename, group is -1; + # new group number is in FIT_GROUP. + + group = FIT_GROUP(fit) + IM_CLINDEX(im) = group + + # Process the reserved keywords (set in the FIT descriptor) into the + # corresponding fields of the IMIO descriptor. + + if (acmode != NEW_COPY) { + IM_NDIM(im) = FIT_NAXIS(fit) # IM_NDIM + do i = 1, IM_NDIM(im) { # IM_LEN + IM_LEN(im,i) = FIT_LENAXIS(fit,i) + if (IM_LEN(im,i) == 0) { + IM_NDIM(im) = 0 + break + } + } + } + + lscale = fxf_fpl_equald (1.0d0, FIT_BSCALE(fit), 1) + lzero = fxf_fpl_equald (0.0d0, FIT_BZERO(fit), 1) + + # Determine if scaling is necessary. + bfloat = (!lscale || !lzero) + + FIT_PIXTYPE(fit) = NULL + FIT_ZCNV(fit) = NO + + switch (FIT_BITPIX(fit)) { + case 8: + FIT_PIXTYPE(fit) = TY_UBYTE + if (bfloat) + impixtype = TY_REAL + else + impixtype = TY_SHORT # convert from byte to short + FIT_ZCNV(fit) = YES + case 16: + FIT_PIXTYPE(fit) = TY_SHORT + if (bfloat) { + impixtype = TY_REAL + FIT_ZCNV(fit) = YES + } else + impixtype = TY_SHORT + + if ((strncmp ("USHORT", FIT_DATATYPE(fit), 6) == 0) || + (lscale && fxf_fpl_equald (32768.0d0, FIT_BZERO(fit),4))) { + impixtype = TY_USHORT + FIT_ZCNV(fit) = NO + } + case 32: + FIT_PIXTYPE(fit) = TY_INT + if (bfloat) + impixtype = TY_REAL + else + impixtype = TY_INT + case -32: + FIT_PIXTYPE(fit) = TY_REAL + impixtype = TY_REAL + case -64: + FIT_PIXTYPE(fit) = TY_DOUBLE + impixtype = TY_DOUBLE + default: + impixtype = ERR + } + + IM_PIXTYPE(im) = impixtype + + IM_NBPIX(im) = 0 # no. bad pixels + mtime = IM_MTIME(im) + + if (IM_MAX(im) > IM_MIN(im)) + IM_LIMTIME(im) = mtime + 1 # time max/min last updated + else + IM_LIMTIME(im) = mtime - 1 # Invalidate DATA(MIN,MAX) + IM_HISTORY(im) = EOS + + # Call up IMIO to set up the remaining image header fields used to + # define the physical offsets of the pixels in the pixfile. + + compress = YES # do not align image lines on blocks + devblksz = 1 # disable all alignment + + pixoff = Memi[poff+group] + FIT_PIXOFF(fit) = pixoff + call imioff (im, pixoff, compress, devblksz) + + call sfree (sp) +end + + +# FXF_FPL_EQUALD -- Compare 2 double precision quantities up to a precision +# given by a tolerance. + +bool procedure fxf_fpl_equald (x, y, it) + +double x, y #I Input quantities to be compare for equality +int it #I Tolerance factor of 10 to compare the values + +int ex, ey +double x1, x2, normx, normy, tol + +begin + # Check for the obvious first. + if (x == y) + return (true) + + # We can't normalize zero, so handle the zero operand cases first. + # Note that the case 0 equals 0 is handled above. + + if (x == 0.0D0 || y == 0.0D0) + return (false) + + # Normalize operands and do an epsilon compare. + call fp_normd (x, normx, ex) + call fp_normd (y, normy, ey) + + if (ex != ey) + return (false) + else { + tol = EPSILOND * 10.0D0 * it + x1 = 1.0D0 + abs (normx - normy) + x2 = 1.0D0 + tol + return (x1 <= x2) + } +end diff --git a/sys/imio/iki/fxf/fxfrename.x b/sys/imio/iki/fxf/fxfrename.x new file mode 100644 index 00000000..677c02dd --- /dev/null +++ b/sys/imio/iki/fxf/fxfrename.x @@ -0,0 +1,53 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "fxf.h" + + +# FIT_RENAME -- Rename a fits file. NOTE: There is no prevision at this +# time to rename an extension. + +procedure fxf_rename (kernel, oroot, oextn, nroot, nextn, status) + +int kernel #I IKI kernel +char oroot[ARB] #I old image root name +char oextn[ARB] #I old image extn +char nroot[ARB] #I new image root name +char nextn[ARB] #I old image extn +int status #O status value + +pointer sp +int cindx +pointer ohdr_fname, nhdr_fname +bool streq() + +include "fxfcache.com" + +begin + call smark (sp) + call salloc (ohdr_fname, SZ_PATHNAME, TY_CHAR) + call salloc (nhdr_fname, SZ_PATHNAME, TY_CHAR) + + call fxf_init() + + # Generate filenames. + call iki_mkfname (oroot, oextn, Memc[ohdr_fname], SZ_PATHNAME) + call iki_mkfname (nroot, nextn, Memc[nhdr_fname], SZ_PATHNAME) + + if (!streq (Memc[ohdr_fname], Memc[nhdr_fname])) { + iferr (call rename (Memc[ohdr_fname], Memc[nhdr_fname])) + call erract (EA_WARN) + + # Update the cache with the new name. + do cindx=1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + # Rename the cached entry. + if (streq (Memc[ohdr_fname], rf_fname[1,cindx])) + call strcpy (Memc[nhdr_fname], rf_fname[1,cindx], SZ_FNAME) + } + } + + status = OK + call sfree (sp) +end diff --git a/sys/imio/iki/fxf/fxfrfits.x b/sys/imio/iki/fxf/fxfrfits.x new file mode 100644 index 00000000..30a8d5f7 --- /dev/null +++ b/sys/imio/iki/fxf/fxfrfits.x @@ -0,0 +1,1322 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include +include +include +include +include "fxf.h" + +# FXFRFITS.X -- Routines to load FITS header in memory and set up the cache +# mechanism. + +define LEN_UACARD_100 8100 +define LEN_UACARD_5 405 + + +# FXF_RFITSHDR -- Procedure to read one or more FITS header while caching +# the primary header, set the FITS memory structure for each +# filename, the header and pixel offset from the beginning +# and the EXTNAME and EXTVER value for each extension. + +procedure fxf_rfitshdr (im, group, poff) + +pointer im #I image descriptor +int group #I Group number to read +int poff #O char offset the the pixel area in the FITS image + +long fi[LEN_FINFO] +pointer hoff,totpix, extn, extv +pointer sp, fit, o_fit, lbuf, hdrfile, hdr +int cindx, cfit, user, fitslen, offs_count +int in, spool, slot, i, nrec1440, acmode + +bool initialized, reload, extname_or_ver, ext_append +data initialized /false/ +int rf_refcount + +bool streq() +long cputime(), fstatl() + +int finfo(), open(), stropen(), getline() + +errchk putline, syserrs, seek, calloc, realloc, syserr +errchk fpathname, calloc, fxf_load_header, fxf_skip_xtn, fxf_read_xtn + +include "fxfcache.com" + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + call salloc (hdrfile, SZ_PATHNAME, TY_CHAR) + + # Initialize the header file cache on the first call. The kernel + # doesn't appear to work with the cache completely deactivated, so + # the minimum cachesize is 1. + + if (!initialized) { + rf_refcount = 0 + do i = 1, MAX_CACHE + rf_fit[i] = 0 + rf_cachesize = max(1, min(MAX_CACHE, FKS_CACHESIZE(IM_KDES(im)))) + initialized = true + } else + rf_refcount = rf_refcount + 1 + + o_fit = IM_KDES(im) + reload = false + slot = 1 + # Get file system info on the desired header file. + call fpathname (IM_HDRFILE(im), Memc[hdrfile], SZ_PATHNAME) + + if (finfo (Memc[hdrfile], fi) == ERR) + call syserrs (SYS_FOPEN, IM_HDRFILE(im)) + + acmode = FIT_ACMODE(o_fit) + ext_append = (acmode == NEW_IMAGE || acmode == NEW_COPY) + repeat { + # Search the header file cache for the named image. + do cindx = 1, rf_cachesize { + if (rf_fit[cindx] == NULL) { + slot = cindx + next + } + if (streq (Memc[hdrfile], rf_fname[1,cindx])) { + # File is in cache; is cached entry still valid? + # If we are appending extension, do not reload from + # disk. + + if (FI_MTIME(fi) != rf_mtime[cindx] && !ext_append) { + # File modify date has changed, reuse slot. + slot = cindx + break + } + + # For every non-empty file the fxf_open() call + # pre reads every PHU, so that when the fxf_rdhdr() + # comes, the cache entry is already here. + + # Return the cached header. + rf_lru[cindx] = rf_refcount + cfit = rf_fit[cindx] + FIT_XTENSION(cfit) = FIT_XTENSION(o_fit) + FIT_ACMODE(cfit) = FIT_ACMODE(o_fit) + FIT_EXPAND(cfit) = FIT_EXPAND(o_fit) + + # Load Extend value from cache header entry to + # the current fit struct entry. + + FIT_EXTEND(o_fit) = FIT_EXTEND(cfit) + + call amovi (FIT_ACMODE(cfit), FIT_ACMODE(o_fit), + LEN_FITBASE) + hoff = rf_hdrp[cindx] + poff = rf_pixp[cindx] + extn = rf_pextn[cindx] + extv = rf_pextv[cindx] + FIT_GROUP(o_fit) = group + FIT_HDRPTR(o_fit) = hoff + FIT_PIXPTR(o_fit) = poff + + extname_or_ver = (FKS_EXTNAME(o_fit) != EOS || + !IS_INDEFL (FKS_EXTVER(o_fit))) + + # If the group number or extname_or_ver has not been + # specified we need to load the group number where there + # is data i.e., FIT_NAXIS != 0. The 'cfit' structure would + # have this group number. + + if (group == -1 && !extname_or_ver) { + if (FIT_GROUP(cfit) != -1) { + group = FIT_GROUP(cfit) + FIT_GROUP(o_fit) = group + + } else if (FIT_NAXIS(cfit) != 0) { + # See if the main FITS unit has data when + # group = -1 is specified. + + group = 0 + FIT_GROUP(cfit) = 0 + FIT_GROUP(o_fit) = 0 + } + } + + # The main header has already been read at this point, + # now merge with UA. + + if (group == 0) { + hdr = rf_hdr[cindx] + fitslen = rf_fitslen[cindx] + FIT_EXTEND(o_fit) = FIT_EXTEND(cfit) + call fxf_merge_w_ua (im, hdr, fitslen) + + } else { + # Read intermediate xtension headers if not in + # hoff and poff yet. + offs_count = FIT_NUMOFFS(cfit) + call fxf_read_xtn (im, + cfit, group, hoff, poff, extn, extv) + } + + # IM_CTIME takes the value of the DATE keyword + if (IM_CTIME(im)==0) { + IM_CTIME(im) = FI_CTIME(fi) + } + + # FIT_MTIME takes the value of keyword IRAF-TLM. + # If not present use the mtime from the finfo value. + + if (FIT_MTIME(cfit) == 0) { + FIT_MTIME(cfit) = FI_MTIME(fi) + } + + # Invalidate entry if cache is disabled. + if (rf_cachesize <= 0) + rf_time[cindx] = 0 + + call sfree (sp) + return # IN CACHE + + } else { + # Keep track of least recently used slot. + if (rf_lru[cindx] < rf_lru[slot]) + slot = cindx + } + } + + # Either the image header is not in the cache, or the cached + # entry is invalid. Prepare the given cache slot and read the + # header into it. + + # Free old save buffer and descriptor. + if (rf_fit[slot] != NULL) { + call mfree (rf_pextv[slot], TY_INT) + call mfree (rf_pextn[slot], TY_CHAR) + call mfree (rf_pixp[slot], TY_INT) + call mfree (rf_hdrp[slot], TY_INT) + call mfree (rf_fit[slot], TY_STRUCT) + call mfree (rf_hdr[slot], TY_CHAR) + rf_fit[slot] = NULL + rf_lru[slot] = 0 + rf_fname[1,slot] = EOS + } + + # Allocate a spool file for the FITS data. + spool = open ("spool", NEW_FILE, SPOOL_FILE) + + # Allocate cache version of FITS descriptor. + call calloc (fit, LEN_FITBASE, TY_STRUCT) + call calloc (hoff, MAX_OFFSETS, TY_INT) + call calloc (poff, MAX_OFFSETS, TY_INT) + call calloc (extn, MAX_OFFSETS*LEN_CARD, TY_CHAR) + call calloc (extv, MAX_OFFSETS, TY_INT) + + # Initialize the entries. + call amovki (INDEFL, Memi[extv], MAX_OFFSETS) + call aclrc (Memc[extn], MAX_OFFSETS) + call amovki (-1, Memi[poff], MAX_OFFSETS) + + FIT_GROUP(fit) = -1 + FIT_HDRPTR(fit) = hoff + FIT_PIXPTR(fit) = poff + FIT_NUMOFFS(fit) = MAX_OFFSETS + FIT_ACMODE(fit) = FIT_ACMODE(o_fit) + FIT_BSCALE(fit) = 1.0d0 + FIT_BZERO(fit) = 0.0d0 + FIT_XTENSION(fit) = NO + FIT_EXTNAME(fit) = EOS + FIT_EXTVER(fit) = INDEFL + FIT_EXTEND(fit) = -3 + + # Initialize the cache entry. + call strcpy (Memc[hdrfile], rf_fname[1,slot], SZ_PATHNAME) + rf_fit[slot] = fit + rf_hdrp[slot] = hoff + rf_pixp[slot] = poff + rf_pextn[slot] = extn + rf_pextv[slot] = extv + rf_lru[slot] = rf_refcount + rf_mtime[slot] = FI_MTIME(fi) + + if (!reload) + rf_time[slot] = cputime (0) + + reload = true + + in = IM_HFD(im) + call seek (in, BOFL) + + # Read main FITS header and copy to spool fd. + FIT_IM(fit) = im + call amovki (1, FIT_LENAXIS(fit,1), IM_MAXDIM) + + call fxf_load_header (in, fit, spool, nrec1440, totpix) + + + # Record group 0 (PHU) as having just been read. + FIT_GROUP(fit) = 0 + + call seek (spool, BOFL) + fitslen = fstatl (spool, F_FILESIZE) + + # Prepare cache area to store the FITS header. + call calloc (hdr, fitslen, TY_CHAR) + user = stropen (Memc[hdr], fitslen, NEW_FILE) + rf_hdr[slot] = hdr + rf_fitslen[slot] = fitslen + FIT_CACHEHDR(fit) = hdr + FIT_CACHEHLEN(fit) = fitslen + + # Append the saved FITS cards to saved cache. + while (getline (spool, Memc[lbuf]) != EOF) + call putline (user, Memc[lbuf]) + + call close (user) + call close (spool) + + # Group 0 (i.e. Main Fits unit) + Memi[hoff] = 1 # beginning of primary h.u. + Memi[poff] = nrec1440 + 1 # first pixel data of main u. + + # Set group 1 offsets. + Memi[hoff+1] = Memi[poff] + totpix + Memi[poff+1] = -1 + } + + call sfree (sp) +end + + +# FXF_READ_XTN -- Procedure to read a FITS extension header and at the same +# time make sure that the EXTNAME and EXTVER values are not repeated +# with those in the cache. + +procedure fxf_read_xtn (im, cfit, igroup, hoff, poff, extn, extv) + +pointer im #I Image descriptor +pointer cfit #I Cached FITS descriptor +int igroup #I Group number to process +pointer hoff #I Pointer to header offsets array +pointer poff #I Pointer to pixel offsets array +pointer extn #I Pointer to extname's array +pointer extv #I Pointer to extver's array + +char messg[SZ_LINE] +pointer lfit, sp, po, ln +int spool, ig, acmode, i +int fitslen, xtn_hd, nrec1440, totpix, in, group +int strcmp(), getline() +long offset, fstatl() +int open(), fxf_extnv_error() +bool ext_append, get_group + +errchk fxf_load_header, fxf_skip_xtn, syserr, syserrs +define rxtn_ 91 + +begin + # Allocate a spool file for the FITS header. + spool = open ("FITSHDRX", READ_WRITE, SPOOL_FILE) + + lfit = IM_KDES(im) + group = FIT_GROUP(lfit) + acmode = FIT_ACMODE(lfit) + ext_append = (acmode == NEW_IMAGE || acmode == NEW_COPY) + + # If we have 'overwrite' in the ksection then look for the + # existent extname/extver we want to overwrite since we don't + # want to append. + + if (FKS_OVERWRITE(lfit) == YES) + ext_append = false + + # See if we want to look at an extension given the EXT(NAME,VER) + # field in the ksection. + + if (FKS_EXTNAME(lfit) != EOS || !IS_INDEFL (FKS_EXTVER(lfit))) { + ig = 1 + repeat { + call fseti (spool, F_CANCEL, YES) + xtn_hd = NO + + # Has last extension header been read? + if (Memi[poff+ig] <= 0) { + iferr { + call fxf_skip_xtn (im, + ig, cfit, hoff, poff, extn, extv, spool) + xtn_hd = YES + } then { + if (ext_append) { + # We have reach the end of extensions. + FIT_GROUP(lfit) = -1 # message for fxf_updhdr + return + } else { + call fxf_form_messg (lfit, messg) + call syserrs (SYS_FXFRFNEXTNV, messg) + } + } else { + # If we want to append an extension then. + if (ext_append && FKS_DUPNAME(lfit) == NO) + if (fxf_extnv_error (lfit, ig, extn, extv) == YES) { + call fxf_form_messg (lfit, messg) + call syserrs (SYS_FXFOPEXTNV, messg) + } + } + } + + if (fxf_extnv_error (lfit, ig, extn, extv) == YES) { + # We have matched either or both FKS_EXTNAME and FKS_EXTVER + # with the values in the cache. + + if (ext_append && FKS_DUPNAME(lfit) == NO) { + call fxf_form_messg (lfit, messg) + call syserrs (SYS_FXFOPEXTNV, messg) + } + group = ig + FIT_GROUP(lfit) = ig + goto rxtn_ + + } else { + ig = ig + 1 + next + } + } + + } else { + # No extname or extver specified. + # Read through the Extensions until group number is reached; + # if no number is supplied, read until EOF to load header and + # pixel offsets necessary to append and extension. + + if (igroup == -1 && FIT_GROUP(cfit) == -1) + group = MAX_INT + + # We are trying to get the first group that meets these condition. + get_group = (FIT_GROUP(cfit) == -1 && igroup == -1) + + do ig = 0, group { + xtn_hd = NO + + # Has last extension header been read? + if (Memi[poff+ig] <= 0 ) { + call fseti (spool, F_CANCEL, YES) + iferr { + call fxf_skip_xtn (im, + ig, cfit, hoff, poff, extn, extv, spool) + xtn_hd = YES + } then { + if (ext_append) { + # We have reach the end of extensions. + FIT_GROUP(lfit) = -1 # message for fxf_updhdr + return + } else { + call syserrs (SYS_FXFRFEOF, IM_NAME(im)) + return + } + } + + # Mark the first group that contains an image + # i.e. naxis != 0. + + if (FIT_NAXIS(lfit) != 0 && + strcmp ("IMAGE", FIT_EXTTYPE(lfit)) == 0) { + if (get_group) { + FIT_GROUP(cfit) = ig # save on cache fits struct + FIT_GROUP(lfit) = ig # also on current + break + } else if (FIT_GROUP(cfit) <= 0) + FIT_GROUP(cfit) = ig + } + } + } + } +rxtn_ + if (xtn_hd == NO) { + in = IM_HFD(im) + offset = Memi[hoff+group] + call seek (in, offset) + FIT_IM(lfit) = im + call fseti (spool, F_CANCEL, YES) + call fxf_load_header (in, lfit, spool, nrec1440, totpix) + } + + # If requested a non supported BINTABLE format, post an error + # message and return to the caller. + + if (strcmp(FIT_EXTTYPE(lfit), "BINTABLE") == 0) { + if (strcmp(FIT_EXTSTYPE(lfit), "PLIO_1") != 0) { + call close (spool) + call syserrs (SYS_IKIEXTN, IM_NAME(im)) + } + } + + # Merge Image Extension header to the user area. + fitslen = fstatl (spool, F_FILESIZE) + + # Copy the spool array into a static array. We cannot reliable + # get the pointer from the spool file. + call smark (sp) + call salloc (ln, LEN_UACARD, TY_CHAR) + + if (po != NULL) + call mfree(po, TY_CHAR) + call calloc (po, fitslen+1, TY_CHAR) + + i = po + call seek (spool, BOFL) + while (getline (spool, Memc[ln]) != EOF) { + + call amovc (Memc[ln], Memc[i], LEN_UACARD) + i = i + LEN_UACARD + } + Memc[i] = EOS + + # Make the user aware that they cannot use inheritance + # if the PDU contains a data array. + + if (Memi[poff] != Memi[hoff+1]) { + if (FKS_INHERIT(lfit) == YES) { + call syserr (SYS_FXFBADINH) + } + } else { + # Disable inheritance if PHDU has a DU. + if (Memi[poff+0] != Memi[hoff+1]) + FIT_INHERIT(lfit) = NO + } + + # Reset the value of FIT_INHERIT if FKS_INHERIT is set + if (FKS_INHERIT(lfit) != NO_KEYW) + FIT_INHERIT(lfit) = FKS_INHERIT(lfit) + + if (FIT_TFIELDS(lfit) > 0) { + fitslen = fitslen + FIT_TFIELDS(lfit)*LEN_UACARD + call realloc (po, fitslen, TY_CHAR) + } + + call fxf_merge_w_ua (im, po, fitslen) + + call mfree (po, TY_CHAR) + + call sfree (sp) + call close (spool) +end + + +# FXF_EXTNV_ERROR -- Integer boolean function (YES,NO) to find out if the +# value of kernel section parameter FKS_EXTNAME and FKS_EXTVER are not +# repeated in the cache pointed by extn and extv. + +int procedure fxf_extnv_error (fit, ig, extn, extv) + +pointer fit #I fit descriptor +int ig #I extension number +pointer extn, extv #I pointers to arrays for extname and extver + +bool bxtn, bxtv, bval, bxtn_eq, bxtv_eq +int fxf_strcmp_lwr() + +begin + bxtn = (FKS_EXTNAME(fit) != EOS) + bxtv = (!IS_INDEFL (FKS_EXTVER(fit))) + + if (bxtn) + bxtn_eq = + (fxf_strcmp_lwr(FKS_EXTNAME(fit), Memc[extn+LEN_CARD*ig]) == 0) + if (bxtv) + bxtv_eq = (FKS_EXTVER(fit) == Memi[extv+ig]) + + if (bxtn && bxtv) { + # Since both FKS_EXTNAME and FKS_EXTVER are defined, see if they + # repeated in the cache. + + bval = (bxtn_eq && bxtv_eq) + + } else if (bxtn && !bxtv) { + # We have a duplicated in this case when extver in the image + # header is INDEFL. + + bval = bxtn_eq + + } else if (!bxtn && bxtv) { + # If the FKS_EXTNAME is not defined (i.e. EOS) and the FKS_EXTVER + # value is the same as the cached, then we have a match. + + bval = bxtv_eq + + } else + bval = false + + if (bval) + return (YES) + else + return (NO) +end + + +# FXF_SKIP_XTN -- Skip over a FITS extension. The procedure will read the +# current extension header and calculates the respectives offset for later +# usage. + +procedure fxf_skip_xtn (im, group, cfit, hoff, poff, extn, extv, spool) + +pointer im #I image descriptor +int group #I groupheader number to read +pointer cfit #I cached fits descriptor +pointer hoff #I extension header offset +pointer poff #I extension data offset +pointer extn #I points to the array of extname +pointer extv #I points to the arrays of extver + +pointer sp, lfit, fit, hdrfile +bool streq() +int spool, in, nrec1440, totpix, i, k, cindx +long offset +errchk fxf_load_header +int strcmp() + +include "fxfcache.com" + +begin + call smark (sp) + call salloc (lfit, LEN_FITBASE, TY_STRUCT) + call salloc (hdrfile, SZ_PATHNAME, TY_CHAR) + + call seek (spool, BOFL) + fit = IM_KDES(im) + + # Allocate more memory for offsets in case we are pass MAX_OFFSETS. + if (group >= FIT_NUMOFFS(cfit)) { + FIT_NUMOFFS(cfit) = FIT_NUMOFFS(cfit) + MAX_OFFSETS + call realloc (hoff, FIT_NUMOFFS(cfit), TY_INT) + call realloc (poff, FIT_NUMOFFS(cfit), TY_INT) + call realloc (extn, FIT_NUMOFFS(cfit)*LEN_CARD, TY_CHAR) + call realloc (extv, FIT_NUMOFFS(cfit), TY_INT) + + offset = FIT_NUMOFFS(cfit) - MAX_OFFSETS + call amovki (INDEFL, Memi[extv+offset], MAX_OFFSETS) + call amovki (-1, Memi[poff+offset], MAX_OFFSETS) + + do i = 0, MAX_OFFSETS-1 { + k = (offset+i)*LEN_CARD + Memc[extn+k] = EOS + } + + # Update the fits structure with the new pointer values + call fpathname (IM_HDRFILE(im), Memc[hdrfile], SZ_PATHNAME) + fit = IM_KDES(im) + do cindx = 1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + if (streq (Memc[hdrfile], rf_fname[1,cindx])) { + rf_pextn[cindx] = extn + rf_pextv[cindx] = extv + rf_hdrp[cindx] = hoff + rf_pixp[cindx] = poff + FIT_HDRPTR(fit) = hoff + FIT_PIXPTR(fit) = poff + } + } + } + + in = IM_HFD(im) + offset = Memi[hoff+group] + + call seek (in, offset) + lfit = IM_KDES(im) + FIT_IM(lfit) = im + call fxf_load_header (in, lfit, spool, nrec1440, totpix) + + # Record the first group that has NAXIS !=0 and is an IMAGE. + if (FIT_GROUP(cfit) == -1) { + if (FIT_NAXIS(lfit) != 0 && + strcmp ("IMAGE", FIT_EXTTYPE(lfit)) == 0) + FIT_GROUP(cfit) = group + } + + Memi[poff+group] = Memi[hoff+group] + nrec1440 + # The offset for the beginning of next group. + Memi[hoff+group+1] = Memi[poff+group] + totpix + + # Mark next group pixel offset in case we are at EOF. + Memi[poff+group+1] = -1 + call strcpy (FIT_EXTNAME(lfit), Memc[extn+LEN_CARD*group], LEN_CARD) + Memi[extv+group] = FIT_EXTVER(lfit) + + call sfree (sp) +end + + +# FXF_LOAD_HEADER -- Load a FITS header from a file descriptor into a +# spool file. + +procedure fxf_load_header (in, fit, spool, nrec1440, datalen) + +int in #I input FITS header file descriptor +pointer fit #I FITS descriptor +int spool #I spool output file descriptor +int nrec1440 #O number of 1440 char records output +int datalen #O length of data area in chars + +int ncols +pointer lbuf, sp, im, stime, fb, ttp +int totpix, nchars, nbytes, index, ncards, simple, i, pcount, junk +int fxf_read_card(), fxf_ctype(), ctoi(), strsearch() +bool fxf_fpl_equald() +errchk syserr, syserrs + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + call salloc (stime, LEN_CARD, TY_CHAR) + call salloc (fb, FITS_BLOCK_BYTES, TY_CHAR) + + FIT_BSCALE(fit) = 1.0d0 + FIT_BZERO(fit) = 0.0d0 + FIT_EXTNAME(fit) = EOS + FIT_EXTVER(fit) = INDEFL + im = FIT_IM(fit) + + # Read successive lines of the FITS header. + nrec1440 = 0 + pcount = 0 + ncards = 0 + + repeat { + # Get the next input line. + nchars = fxf_read_card (in, Memc[fb], Memc[lbuf], ncards) + if (nchars == EOF) { + call close (spool) + call syserrs (SYS_FXFRFEOF, IM_NAME(im)) + } + ncards = ncards + 1 + + # A FITS header card already has 80 chars, just add the newline. + Memc[lbuf+LEN_CARD] = '\n' + Memc[lbuf+LEN_CARD+1] = EOS + + # Process the header card. + switch (fxf_ctype (Memc[lbuf], index)) { + case KW_END: + nrec1440 = FITS_LEN_CHAR(ncards*40) + break + case KW_SIMPLE: + call strcpy ("SIMPLE", FIT_EXTTYPE(fit), SZ_EXTTYPE) + call fxf_getb (Memc[lbuf], simple) + FIT_EXTEND(fit) = NO_KEYW + if (simple == NO) + call syserr (SYS_FXFRFSIMPLE) + case KW_EXTEND: + call putline (spool, Memc[lbuf]) + call fxf_getb (Memc[lbuf], FIT_EXTEND(fit)) + case KW_XTENSION: + FIT_XTENSION(fit) = YES + call fxf_gstr (Memc[lbuf], FIT_EXTTYPE(fit), SZ_EXTTYPE) + case KW_EXTNAME: + call fxf_gstr (Memc[lbuf], FIT_EXTNAME(fit), LEN_CARD) + call putline (spool, Memc[lbuf]) + case KW_EXTVER: + call fxf_geti (Memc[lbuf], FIT_EXTVER(fit)) + call putline (spool, Memc[lbuf]) + case KW_ZCMPTYPE: + call fxf_gstr (Memc[lbuf], FIT_EXTSTYPE(fit), SZ_EXTTYPE) + case KW_PCOUNT: + call fxf_geti (Memc[lbuf], pcount) + call putline (spool, Memc[lbuf]) + FIT_PCOUNT(fit) = pcount + case KW_INHERIT: + call fxf_getb (Memc[lbuf], FIT_INHERIT(fit)) + call putline (spool, Memc[lbuf]) + case KW_BITPIX: + call fxf_geti (Memc[lbuf], FIT_BITPIX(fit)) + case KW_DATATYPE: + call fxf_gstr (Memc[lbuf], FIT_DATATYPE(fit), SZ_DATATYPE) + case KW_NAXIS: + if (index == 0) { + call fxf_geti (Memc[lbuf], FIT_NAXIS(fit)) + if (FIT_NAXIS(fit) < 0 ) + call syserr (SYS_FXFRFBNAXIS) + } else + call fxf_geti (Memc[lbuf], FIT_LENAXIS(fit,index)) + case KW_BSCALE: + call fxf_getd (Memc[lbuf], FIT_BSCALE(fit)) + # If BSCALE is like 1.00000011 reset to 1.0. + if (fxf_fpl_equald (1.0d0, FIT_BSCALE(fit), 4)) + FIT_BSCALE(fit) = 1.0d0 + call putline (spool, Memc[lbuf]) + case KW_BZERO: + call fxf_getd (Memc[lbuf], FIT_BZERO(fit)) + # If BZERO is like 0.00000011 reset to 0.0. + if (fxf_fpl_equald (0.0d0, FIT_BZERO(fit), 4)) + FIT_BZERO(fit) = 0.0d0 + call putline (spool, Memc[lbuf]) + case KW_DATAMAX: + call fxf_getr (Memc[lbuf], FIT_MAX(fit)) + call putline (spool, Memc[lbuf]) + case KW_DATAMIN: + call fxf_getr (Memc[lbuf], FIT_MIN(fit)) + call putline (spool, Memc[lbuf]) + case KW_TFIELDS: + # Allocate space for TFORM and TTYPE keyword values + call fxf_geti (Memc[lbuf], ncols) + FIT_TFIELDS(fit) = ncols + if (FIT_TFORMP(fit) != NULL) { + call mfree (FIT_TFORMP(fit), TY_CHAR) + call mfree (FIT_TTYPEP(fit), TY_CHAR) + } + call calloc (FIT_TFORMP(fit), ncols*LEN_FORMAT, TY_CHAR) + call calloc (FIT_TTYPEP(fit), ncols*LEN_OBJECT, TY_CHAR) + case KW_TFORM: + call fxf_gstr (Memc[lbuf], Memc[stime], LEN_CARD) + if (index == 1) { + # PLMAXLEN is used to indicate the maximum line list + # length for PLIO masks in bintables. The syntax + # "PI(maxlen)" is used in bintables to pass the max + # vararray length for a column. + + i = strsearch (Memc[stime], "PI(") + if (i > 0) + junk = ctoi (Memc[stime], i, FIT_PLMAXLEN(fit)) + } + case KW_TTYPE: + ttp = FIT_TTYPEP(fit) + (index-1)*LEN_OBJECT + call fxf_gstr (Memc[lbuf], Memc[ttp], LEN_CARD) + case KW_OBJECT: + # Since only OBJECT can go into the header and IM_TITLE has its + # values as well, we need to save both to see which one has + # changed at closing time. + + call fxf_gstr (Memc[lbuf], FIT_OBJECT(fit), LEN_CARD) + if (FIT_OBJECT(fit) == EOS) + call strcpy (" ", FIT_OBJECT(fit), SZ_KEYWORD) + call strcpy (FIT_OBJECT(fit), FIT_TITLE(fit), LEN_CARD) + call strcpy (FIT_OBJECT(fit), IM_TITLE(im), LEN_CARD) + call putline (spool, Memc[lbuf]) + case KW_IRAFTLM: + call fxf_gstr (Memc[lbuf], Memc[stime], LEN_CARD) + call fxf_date2limtime (Memc[stime], FIT_MTIME(fit)) + call putline (spool, Memc[lbuf]) + case KW_DATE: + call fxf_gstr (Memc[lbuf], Memc[stime], LEN_CARD) + call fxf_date2limtime (Memc[stime], IM_CTIME(im)) + call putline (spool, Memc[lbuf]) + default: + call putline (spool, Memc[lbuf]) + } + } + + # Calculate the length of the data area of the current extension, + # measured in SPP chars and rounded up to an integral number of FITS + # logical blocks. + + if (FIT_NAXIS(fit) != 0) { + totpix = FIT_LENAXIS(fit,1) + do i = 2, FIT_NAXIS(fit) + totpix = totpix * FIT_LENAXIS(fit,i) + + # Compute the size of the data area (pixel matrix plus PCOUNT) + # in bytes. Be careful not to overflow a 32 bit integer. + + nbytes = (totpix + pcount) * (abs(FIT_BITPIX(fit)) / NBITS_BYTE) + + # Round up to fill the final 2880 byte FITS logical block. + nbytes = ((nbytes + 2880-1) / 2880) * 2880 + + datalen = nbytes / SZB_CHAR + + } else + datalen = 0 + + call sfree (sp) +end + + +# FXF_MERGE_W_UA -- Merge a spool user area with the im_userarea. + +procedure fxf_merge_w_ua (im, userh, fitslen) + +pointer im #I image descriptor +int userh #I pointer to user area spool +int fitslen #I length in chars of the user area + +bool inherit +pointer sp, lbuf, ua, ln +int elen, elines, nbl, i, k +int sz_userarea, merge, len_hdrmem, fit, clines, ulines +bool fxf_is_blank() +int strlen() + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + call salloc (ln, LEN_UACARD, TY_CHAR) + + fit = IM_KDES(im) + + # FIT_INHERIT has the logically combined value of the fkinit inherit's + # value, if any; the ksection value, if any and the INHERIT value in + # the extension header. + + inherit = (FIT_INHERIT(fit) == YES) + inherit = (inherit && (FIT_GROUP(fit) != 0)) + + # Reallocate the image descriptor to allow space for the spooled user + # FITS cards plus a little extra for new parameters. + + sz_userarea = fitslen + SZ_EXTRASPACE + # Add size of main header if necessary. + if (inherit) + sz_userarea = sz_userarea + FIT_CACHEHLEN(fit) + + IM_HDRLEN(im) = LEN_IMHDR + + (sz_userarea - SZ_EXTRASPACE + SZ_MII_INT-1) / SZ_MII_INT + len_hdrmem = LEN_IMHDR + + (sz_userarea+1 + SZ_MII_INT-1) / SZ_MII_INT + + if (IM_LENHDRMEM(im) < len_hdrmem) { + IM_LENHDRMEM(im) = len_hdrmem + call realloc (im, IM_LENHDRMEM(im) + LEN_IMDES, TY_STRUCT) + } + + + # Copy the extension header to the USERAREA if not inherit or copy + # the global header plus the extension header if inherit is set. + + if (fitslen > 0) { + ua = IM_USERAREA(im) + elen = fitslen + + if (inherit) { + # First, copy those cards in the global header that + # are not in the current extension header. + + clines = strlen (Memc[FIT_CACHEHDR(fit)]) + ulines = strlen (Memc[userh]) + clines = clines / LEN_UACARD + ulines = ulines / LEN_UACARD + merge = YES + call fxf_match_str (FIT_CACHEHDR(fit), + clines, userh, ulines, merge, ua) + elen = LEN_UACARD * ulines + } + + # Append the extension header to the UA. + elines = elen / LEN_UACARD + k = userh + nbl = 0 + + do i = 1, elines { + call strcpy (Memc[k], Memc[ln], LEN_UACARD) + if (fxf_is_blank (Memc[ln])) + nbl = nbl + 1 + else { + # If there are blank cards, add them. + if (nbl > 0) + call fxf_blank_lines (nbl, ua) + call amovc (Memc[ln], Memc[ua], LEN_UACARD) + ua = ua + LEN_UACARD + } + k = k + LEN_UACARD + } + + Memc[ua] = EOS + } + call sfree (sp) +end + + +# FXF_STRCMP_LWR -- Compare 2 strings in lower case mode. + +int procedure fxf_strcmp_lwr (s1, s2) + +char s1[ARB], s2[ARB] #I strings to be compare for equality + +int istat +pointer sp, l1, l2 +int strcmp() + +begin + call smark (sp) + call salloc (l1, LEN_CARD, TY_CHAR) + call salloc (l2, LEN_CARD, TY_CHAR) + + call strcpy (s1, Memc[l1], LEN_CARD) + call strcpy (s2, Memc[l2], LEN_CARD) + call strlwr(Memc[l1]) + call strlwr(Memc[l2]) + istat = strcmp (Memc[l1], Memc[l2]) + + call sfree (sp) + return (istat) +end + + +# FXF_DATE2LIMTIME -- Convert the IRAF_TLM string (used to record the IMIO +# time of last modification of the image) into a long integer limtime +# compatible with routine cnvtime(). The year must be 1980 or later. +# The input date string has one of the following forms: +# +# Old format: "hh:mm:ss (dd/mm/yyyy)" +# New (Y2K/ISO) format: "YYYY-MM-DDThh:mm:ss + +procedure fxf_date2limtime (datestr, limtime) + +char datestr[ARB] #I fixed format date string +long limtime #O output limtime (LST seconds from 1980.0) + +double dsec +int hours,minutes,seconds,day,month,year +int status, iso, flags, ip, m, d, y +int dtm_decode_hms(), btoi(), ctoi() +long gmttolst() +double jd + +begin + iso = btoi (datestr[3] != ':') + status = OK + + if (iso == YES) { + status = dtm_decode_hms (datestr, + year,month,day, hours,minutes,dsec, flags) + + # If the decoded date string is old style FITS then the HMS + # values are indefinite, and we need to set them to zero. + + if (and(flags,TF_OLDFITS) != 0) { + hours = 0 + minutes = 0 + seconds = 0 + } else { + if (IS_INDEFD(dsec)) { + hours = 0 + minutes = 0 + seconds = 0 + } else + seconds = nint(dsec) + } + } else { + ip = 1; ip = ctoi (datestr, ip, hours) + ip = 1; ip = ctoi (datestr[4], ip, minutes) + ip = 1; ip = ctoi (datestr[7], ip, seconds) + ip = 1; ip = ctoi (datestr[11], ip, day) + ip = 1; ip = ctoi (datestr[14], ip, month) + ip = 1; ip = ctoi (datestr[17], ip, year) + } + + if (status == ERR || year < 1980) { + limtime = 0 + return + } + + seconds = seconds + minutes * 60 + hours * 3600 + + # Calculate the Julian day from jan 1, 1980. Algorithm taken + # from astutil/asttools/asttimes.x. + + y = year + if (month > 2) + m = month + 1 + else { + m = month + 13 + y = y - 1 + } + + # Original: jd = int (JYEAR * y) + int (30.6001 * m) + day + 1720995 + # -723244.5 is the number of days to add to get 'jd' from jan 1, 1980. + + jd = int (365.25 * y) + int (30.6001 * m) + day - 723244.5 + if (day + 31 * (m + 12 * y) >= 588829) { + d = int (y / 100) + m = int (y / 400) + jd = jd + 2 - d + m + } + jd = jd - 0.5 + day = jd + + limtime = seconds + day * 86400 + if (iso == YES) + limtime = gmttolst (limtime) +end + + +# FIT_MATCH_STR -- FITS header pattern matching algorithm. Match mostly one +# line of lenght LEN_UACARD with the buffer pointed by str; if pattern is not +# in str, put it in the 'out' buffer. + +procedure fxf_match_str (pat, plines, str, slines, merge, po) + +pointer pat #I buffer with pattern +int plines #I number of pattern +pointer str #I string to compare the pattern with +int slines #I number of lines in str +int merge #I flag to indicate merging or unmerge +pointer po #I matching pattern accumulation pointer + +char line[LEN_UACARD] +pointer sp, pt, tpt, tst, ps, pkp +int nbl, l, k, j, i, strncmp(), nbkw, nsb, cmplen +int stridxs() + +begin + call smark (sp) + call salloc (tpt, LEN_UACARD_100+1, TY_CHAR) + call salloc (tst, LEN_UACARD_5+1, TY_CHAR) + + Memc[tpt] = EOS + Memc[tst] = EOS + + # The temporary buffer is non blank only when it has a blank + # keyword following by a comentary: + + #1) ' ' / Comment to the block of keyw + #2) KEYWORD = Value + + nbl = 0 + nbkw = 0 + pt = pat - LEN_UACARD + + for (k=1; k <= plines; k=k+1) { + pt = pt + LEN_UACARD + call strcpy (Memc[pt], line, LEN_UACARD) + + # Do not pass these keywords if merging. + if (merge == YES) { + if (strncmp (line, "COMMENT ", 8) == 0 || + strncmp (line, "HISTORY ", 8) == 0 || + strncmp (line, "OBJECT ", 8) == 0 || + strncmp (line, "EXTEND ", 8) == 0 || + strncmp (line, "ORIGIN ", 8) == 0 || + strncmp (line, "IRAF-TLM", 8) == 0 || + strncmp (line, "DATE ", 8) == 0 ) { + + next + } + } + if (line[1] == ' ') { + call fxf_accum_bufp (line, tpt, nbkw, nbl) + next + } + + if (Memc[tpt] != EOS) { + nbkw = nbkw + 1 + call strcat (line, Memc[tpt], LEN_UACARD_100) + Memc[tst] = EOS + + # Now that we have a buffer with upto 100 lines, we take its + # last 5 card and we are going to compare it with upto 5 + # lines (that can contain blank lines in between). + + pkp = tpt + LEN_UACARD*(nbkw-1) + ps = str - LEN_UACARD + nsb = 0 + + do j = 1, slines { + ps = ps + LEN_UACARD + call strcpy (Memc[ps], line, LEN_UACARD) + + if (line[1] == ' ') { + call fxf_accum_buft (line, tst, nsb) + next + + } else if (Memc[tst] != EOS) { + nsb = nsb + 1 + call strcat (line, Memc[tst], LEN_UACARD_5) + + # To begin compare the first character in the + # keyword line. + + if (Memc[pkp] == line[1]) { + if (strncmp (Memc[pkp-LEN_UACARD*(nsb-1)], + Memc[tst], LEN_UACARD*nsb) == 0) { + nsb = 0 + break + } + } + + nsb = 0 + Memc[tst] = EOS + } + } + + if (j == slines+1) { + if (nbl > 0) + call fxf_blank_lines (nbl, po) + i = tpt + do l = 1, min(100, nbkw) { + call amovc (Memc[i], Memc[po], LEN_UACARD) + i = i + LEN_UACARD + po = po + LEN_UACARD + } + } else { + pt = pt - LEN_UACARD # push back last line + k = k - 1 + } + + Memc[tpt] = EOS + nbkw = 0 + nbl = 0 + + } else { + # One line to compare. + ps = str - LEN_UACARD + cmplen = min (stridxs("=", Memc[pt]), LEN_UACARD) + if (cmplen == 0) + cmplen = LEN_UACARD + +# if (merge == YES) +# cmplen = SZ_KEYWORD + + do j = 1, slines { + ps = ps + LEN_UACARD + if (Memc[ps] == Memc[pt]) { + if (merge == NO) + cmplen = LEN_CARD + if (strncmp (Memc[ps], Memc[pt], cmplen) == 0) { + nbl = 0 + break + } + } + } + + if (j == slines+1) { + if (nbl > 0) + call fxf_blank_lines (nbl, po) + + call amovc (line, Memc[po], LEN_UACARD) + po = po + LEN_UACARD + nbl = 0 + } + } + } + + call sfree (sp) +end + + +# FXF_ACCUM_BUFP -- Accumulate blank keyword cards (No keyword and a / card +# only) and the blank lines in between. + +procedure fxf_accum_bufp (line, tpt, nbkw, nbl) + +char line[LEN_UACARD] #I input card from the pattern buffer +pointer tpt #I pointer to the buffer +int nbkw #U number of blank keyword card +int nbl #U number of blank card before the 1st bkw + +char keyw[SZ_KEYWORD] +bool fxf_is_blank() + +begin + call strcpy (line, keyw, SZ_KEYWORD) + + if (fxf_is_blank (line)) { + # Accumulate blank cards in between bkw cards. + if (nbkw > 0 && nbkw < 100) { + call strcat (line, Memc[tpt], LEN_UACARD_100) + nbkw = nbkw + 1 + } else if (nbkw >= 100) { + nbkw = nbkw - 1 + } else + nbl = nbl + 1 + + } else if (fxf_is_blank (keyw)) { + nbkw = nbkw + 1 + + # We have a blank keyword, but the card is not blank, maybe it is + # a '/ comment' card. Start accumulating upto 100 blank kwy lines. + + if (nbkw < 100) + call strcat (line, Memc[tpt], LEN_UACARD_100) + else + nbkw = nbkw - 1 + } +end + + +# FXF_ACCUM_BUFT -- Accumulate blank keyword keeping track of the blank cards. + +procedure fxf_accum_buft (line, tst, nsb) + +char line[LEN_UACARD] #I input card from the target buffer +pointer tst #I pointer to output buffer +int nsb #U number of consecutives blank cards + +char keyw[SZ_KEYWORD] +bool fxf_is_blank() + +begin + call strcpy (line, keyw, SZ_KEYWORD) + + if (fxf_is_blank (line)) { + if (nsb > 0 && nsb < 5) { + call strcat (line, Memc[tst], LEN_UACARD_5) + nsb = nsb + 1 + } else if (nsb > 4) + nsb = nsb - 1 + } else if (fxf_is_blank (keyw)) { + # We want to pick the last blank kwy only. + call strcpy (line, Memc[tst], LEN_UACARD_5) + nsb = 1 + } +end + + +# FXF_BLANK_LINES -- Write a number of blank lines into output buffer. + +procedure fxf_blank_lines (nbl, po) + +int nbl #U number of blank lines to write +pointer po #I output buffer pointer + +char blk[1] +int i + +begin + blk[1] = ' ' + do i = 1, nbl { + call amovkc (blk[1], Memc[po], LEN_UACARD) + po = po + LEN_UACARD + Memc[po-1] = '\n' + } + nbl = 0 +end + + +# FXF_IS_BLANK -- Determine is the string is blank. + +bool procedure fxf_is_blank (line) + +char line[ARB] #I input string +int i + +begin + for (i=1; IS_WHITE(line[i]); i=i+1) + ; + + if (line[i] == NULL || line[i] == '\n') + return (true) + else + return (false) +end + + +# FXF_FORM_MESSG -- Form string from extname, extver. + +procedure fxf_form_messg (fit, messg) + +pointer fit #I fits descriptor +char messg[ARB] #O string + +begin + if (!IS_INDEFL (FKS_EXTVER(fit))) { + call sprintf (messg, LEN_CARD, "'%s,%d'") + call pargstr (FKS_EXTNAME(fit)) + call pargi (FKS_EXTVER(fit)) + } else { + call sprintf (messg, LEN_CARD, "'%s'") + call pargstr (FKS_EXTNAME(fit)) + } +end diff --git a/sys/imio/iki/fxf/fxfupdhdr.x b/sys/imio/iki/fxf/fxfupdhdr.x new file mode 100644 index 00000000..40a24763 --- /dev/null +++ b/sys/imio/iki/fxf/fxfupdhdr.x @@ -0,0 +1,1478 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include +include +include +include +include "fxf.h" + +# FXFUPDHDR.X -- Routines to update the header of an image extension on +# disk. + +define SZ_DATESTR 24 + + +# FXF_UPDHDR -- Update the FITS header file. This is done by writing an +# entire new header file and then replacing the old header file with the +# new one. This is necessary since the header file is a text file and text +# files cannot be randomly updated. + +procedure fxf_updhdr (im, status) + +pointer im #I image descriptor +int status #O return status + +pointer sp, fit, mii, poff +pointer outname, fits_file, tmp1, tmp2 +bool adjust_header, overwrite, append +int i, nchars_ua, hdr_fd, group, hdr_off, size +int npad, nlines, pixoff, grp_pix_off, nbks +int acmode, in_fd, diff, hdr_acmode, in_off, nchars, subtype +int read(), fxf_hdr_offset(), access(), strncmp() +int open(), fstatl(), fnldir(), strlen(), stridxs() +bool fnullfile() + +errchk open, read, write, fxf_header_diff, fxf_write_header, fxf_make_adj_copy +errchk fxf_set_cache_time, syserr, syserrs, imerr +errchk fxf_expandh, fxf_not_incache, fxf_ren_tmp, fxf_update_extend +long clktime() + +begin + call smark (sp) + call salloc (mii, FITS_BLOCK_CHARS, TY_INT) + call salloc (fits_file, SZ_FNAME, TY_CHAR) + call salloc (outname, SZ_PATHNAME, TY_CHAR) + call salloc (tmp1, max(SZ_PATHNAME,SZ_FNAME*2), TY_CHAR) + call salloc (tmp2, max(SZ_PATHNAME,SZ_FNAME*2), TY_CHAR) + + acmode = IM_ACMODE(im) + fit = IM_KDES(im) + status = OK + + # For all intents and purposes the APPEND access mode is the same + # as NEW_IMAGE under the FK. Let's simplify the code as the user + # has requested APPEND. + + if (acmode == APPEND) + acmode = NEW_IMAGE + + if (acmode == READ_ONLY) + call imerr (IM_NAME(im), SYS_IMUPIMHDR) + + if (fnullfile (IM_HDRFILE(im))) { + call sfree (sp) + return + } + + group = FIT_GROUP(fit) + + subtype = 0 + if ((FKS_SUBTYPE(fit) == FK_PLIO || + (strncmp("PLIO_1", FIT_EXTSTYPE(fit), 6) == 0)) && + (IM_PL(im) != NULL)) + subtype = FK_PLIO + + if (FIT_EXTTYPE(fit) != EOS && group != -1) { + if (strncmp (FIT_EXTTYPE(fit), "IMAGE", 5) != 0 && + strncmp (FIT_EXTTYPE(fit), "SIMPLE", 6) != 0 && + subtype == 0) { + call syserr (SYS_FXFUPHBEXTN) + } + } + + if (FKS_OVERWRITE(fit) == YES) { + if (group == 0) { + # We are overwriting the main unit. + FIT_NEWIMAGE(fit) = YES + } + + group = -1 + acmode = NEW_IMAGE + + if (IM_PFD(im) == NULL) + call fxf_overwrite_unit (fit, im) + + call strcpy (IM_PIXFILE(im), Memc[fits_file], SZ_FNAME) + + } else + call strcpy (IM_HDRFILE(im), Memc[fits_file], SZ_FNAME) + + # Calculate the header offset corresponding to group number 'group'. + FIT_IM(fit) = im + hdr_off = fxf_hdr_offset (group, fit, IM_PFD(im), acmode) + + # If the pixfile has not been created, open new one. This could + # happen if the don't write any pixels to the data portion of the file. + + if (IM_PFD(im) == NULL && (acmode == NEW_COPY || acmode == NEW_IMAGE)) { + FIT_NAXIS(fit) = 0 + if (FIT_NEWIMAGE(fit) == YES) + hdr_acmode = NEW_FILE + else { + # We want to append a new extension with no data. + hdr_acmode = READ_WRITE + } + } else { + call close(IM_PFD(im)) + hdr_acmode = READ_WRITE + } + + append = (acmode == NEW_IMAGE || acmode == NEW_COPY) + + # Calculate header difference. The difference between the original + # header length at open time and now. The user could have added or + # deleted header keywords. + + call fxf_header_diff (im, group, acmode, hdr_off, diff, nchars_ua) + + # PLIO + if (subtype == FK_PLIO && append) + diff = 0 + + # Adjust header only when we need to expand. We fill with trailing + # blanks in case diff .gt. 0. (Reduce header size). + + adjust_header = (diff < 0) + if (adjust_header && FIT_EXPAND(fit) == NO) { + call syserr (SYS_FXFUPHEXP) + adjust_header = false + } + + overwrite = (FKS_OVERWRITE(fit) == YES) + if (adjust_header || overwrite) { + # We need to change the size of header portion in the middle of + # the file. The best thing to do is to make a copy in the output + # filename directory. + + i = strlen (IM_PIXFILE(im)) + nchars = fnldir (IM_PIXFILE(im), Memc[outname], SZ_PATHNAME) + if (nchars > 80 && i > 100) { + i = stridxs ("!", Memc[outname]) + call strcpy ("tmp$", Memc[outname+i], SZ_PATHNAME-i) + } + call strcpy (Memc[outname], Memc[tmp2], SZ_FNAME) + call mktemp ("fx", Memc[tmp1], SZ_PATHNAME) + call strcat (".fits", Memc[tmp1], SZ_PATHNAME) + call strcat ("A", Memc[outname], SZ_PATHNAME) + call strcat (Memc[tmp1], Memc[outname], SZ_PATHNAME) + call strcat ("B", Memc[tmp2], SZ_PATHNAME) + call strcat (Memc[tmp1], Memc[tmp2], SZ_PATHNAME) + in_fd = open (Memc[fits_file], READ_ONLY, BINARY_FILE) + if (access (Memc[outname], 0, 0) == YES) + call delete (Memc[outname]) + hdr_fd = open (Memc[outname], NEW_FILE, BINARY_FILE) + + # Now expand the current group at least one block of 36 cards + # and guarantee that the other groups in the file will have at + # least 'nlines' of blank cards at the end of the header unit. + + nlines= FKS_PADLINES(fit) + IM_HFD(im) = in_fd + + if (adjust_header && acmode != NEW_COPY && + FIT_XTENSION(fit) == YES) { + nbks = -diff/1440 # number of blocks to expand + call fxf_expandh (in_fd, hdr_fd, nlines, group, nbks, + hdr_off, pixoff) + nchars_ua = pixoff - hdr_off + # Reload PHU from file if necessary + call fxf_not_incache(im) + poff = FIT_PIXPTR(fit) + Memi[poff+group] = pixoff + } else { + if (append) + grp_pix_off = FIT_PIXOFF(fit) + else { + # Reload PHU from file if necessary + call fxf_not_incache(im) + grp_pix_off = Memi[FIT_PIXPTR(fit)+group] + } + call fxf_make_adj_copy (in_fd, hdr_fd, + hdr_off, grp_pix_off, nchars_ua) + } + diff = 0 + group = -1 + + # Reset the time so we can read a fresh header next time. + call fxf_set_cache_time (im, overwrite) + } else { + hdr_fd = open (Memc[fits_file], hdr_acmode, BINARY_FILE) + # Do not clear if we are creating a Bintable with type PLIO_1. + if (subtype != FK_PLIO) + IM_PFD(im) = NULL + IM_HFD(im) = NULL + } + + if (FIT_NEWIMAGE(fit) == YES) + call seek (hdr_fd, BOF) + else if (hdr_off != 0) + call seek (hdr_fd, hdr_off) + + if (acmode == NEW_COPY) + call fxf_setbitpix (im, fit) + + # Lets changed the value of FIT_MTIME that will be used as the mtime for + # this updated file. This time them will be different in other + # executable's FITS cache, hence rereading the PHU. + # We need to use FIT_MTIME since it reflec the value of keyword + # IRAF_TLM which could have just recently been modified, hence adding + # the 4 seconds. + + if (abs(FIT_MTIME(fit) - clktime(long(0))) > 60) + FIT_MTIME(fit) = clktime(long(0)) + + # We cannot use clktime() directly since the previuos value + # of FIT_MTIME might already have a 4 secs increment. + + FIT_MTIME(fit) = FIT_MTIME(fit) + 4 + + # Now write default cards and im_userarea to disk. + nchars_ua = nchars_ua + diff + call fxf_write_header (im, fit, hdr_fd, nchars_ua, group) + + size = fstatl (hdr_fd, F_FILESIZE) + npad = FITS_BLOCK_CHARS - mod(size,FITS_BLOCK_CHARS) + + # If we are appending a new extension, we need to write padding to + # 2880 bytes blocks at the end of the file. + + if (mod(npad,FITS_BLOCK_CHARS) > 0 && + (FIT_NEWIMAGE(fit) == YES || append)) { + call amovki (0, Memi[mii], npad) + call flush (hdr_fd) + call seek (hdr_fd, EOF) + call write (hdr_fd, Memi[mii], npad) + } + call flush (hdr_fd) + + # Now open the original file and skip to the beginning of (group+1) + # to begin copying into hdr_fd. (end of temporary file in tmp$). + + if (FKS_OVERWRITE(fit) == YES) { + if (overwrite) { + call close (in_fd) + if (access (IM_PIXFILE(im), 0, 0) == YES) + call delete (IM_PIXFILE(im)) + call strcpy (Memc[outname], IM_PIXFILE(im), SZ_FNAME) + } + + in_fd = open (IM_HDRFILE(im), READ_ONLY, BINARY_FILE) + group = FIT_GROUP(fit) + call fxf_not_incache (im) + in_off = Memi[FIT_HDRPTR(fit)+group+1] + call seek (hdr_fd, EOF) + call seek (in_fd, in_off) + size = FITS_BLOCK_CHARS + + while (read (in_fd, Memi[mii], size) != EOF) + call write (hdr_fd, Memi[mii], size) + + call close (hdr_fd) + call close (in_fd) + + call fxf_ren_tmp (IM_PIXFILE(im), IM_HDRFILE(im), Memc[tmp2], 1, 1) + + # Change the acmode so we can change the modification and + # this way reset the cache for this file. + + IM_ACMODE(im) = READ_WRITE + call fxf_over_delete(im) + + } else { + if (adjust_header || overwrite) + call close (in_fd) + call close (hdr_fd) + + # If the header has been expanded then rename the temp file + # to the original name. + if (adjust_header) + call fxf_ren_tmp (Memc[outname], IM_PIXFILE(im), + Memc[tmp2], 1, 1) + } + + # Make sure we reset the modification time for the cached header + # since we have written a new version. This way the header will + # be read from disk next time the file is accessed. + + if (IM_ACMODE(im) == READ_WRITE || overwrite) { + # The modification time of a file in the cache can be different + # from another mod entry in another executable. We need to make + # sure that the mod time has changed in more than a second so that + # the other executable can read the header from disk and not + # from the cache entry. The FIT_MTIME value has already been + # changed by adding 4 seconds. (See above). + + call futime (IM_HDRFILE(im), NULL, FIT_MTIME(fit)) +# call futime (IM_HDRFILE(im), NULL, clktime(long(0))+4) + } + + if (FIT_GROUP(fit) == 0 || FIT_GROUP(fit) == -1) + call fxf_set_cache_time (im, false) + + # See if we need to add or change the value of EXTEND in the PHU. + if (FIT_XTENSION(fit) == YES && + (FIT_EXTEND(fit) == NO_KEYW || FIT_EXTEND(fit) == NO)) { + call fxf_update_extend (im) + } + + call sfree (sp) +end + + +# FXF_HDR_OFFSET -- Function to calculate the header offset for group number +# 'group'. + +int procedure fxf_hdr_offset (group, fit, pfd, acmode) + +int group #I extension number +pointer fit #I fits descriptor +pointer pfd #I pixel file descriptor +int acmode #I image acmode + +int hdr_off + +begin + if (FIT_NEWIMAGE(fit) == YES) + return (0) + + # Look for the beginning of the current group. + if (group == -1) { + # We are appending or creating a new FITS IMAGE. + hdr_off = FIT_EOFSIZE(fit) + } else { + call fxf_not_incache (FIT_IM(fit)) + hdr_off = Memi[FIT_HDRPTR(fit)+group] + } + + # If pixel file descriptor is empty for a newcopy or newimage + # in an existent image then the header offset is EOF. + + if (pfd == NULL && (acmode == NEW_COPY || acmode == NEW_IMAGE)) + hdr_off = EOF + + return (hdr_off) +end + + +# FXF_HEADER_DIFF -- Get the difference between the original header at open +# time and the one at closing time. + +procedure fxf_header_diff (im, group, acmode, hdr_off, diff, ualen) + +pointer im #I image descriptor +int group #I extension number +int acmode #I emage acmode +int hdr_off #I header offset for group +int diff #O difference +int ualen #O new header length + +char temp[LEN_CARD] +pointer hoff, poff, sp, pb, tb +int ua, fit, hdr_size, pixoff, clines, ulines, len, padlines +int merge, usize, excess, nheader_cards, rp, inherit, kmax, kmin +int strlen(), imaccf(), imgeti(), strcmp(), idb_findrecord() +int btoi(), strncmp() +bool imgetb() + +errchk open, fcopyo + +begin + fit = IM_KDES(im) + inherit = NO + + FIT_INHERIT(fit) = FKS_INHERIT(fit) + + # In READ_WRITE mode get the UA value of INHERIT only if it has + # change after _open(). + + if (acmode == READ_WRITE) { + if (imaccf (im, "INHERIT") == YES) { + inherit = btoi (imgetb (im, "INHERIT")) + if (inherit != FKS_INHERIT(fit)) + FIT_INHERIT(fit) = inherit + } + } + + # Allow inheritance only for extensions. + inherit = FIT_INHERIT(fit) + if (FIT_GROUP(fit) == 0) { + inherit = NO + FIT_INHERIT(fit) = inherit + } + # Scale the pixel offset to be zero base rather than the EOF base. + if (FIT_NEWIMAGE(fit) == NO) { + pixoff = FIT_PIXOFF(fit) - FIT_EOFSIZE(fit) + } else { + if ((hdr_off == EOF || hdr_off == 0)&& + (IM_NDIM(im) == 0 || FIT_NAXIS(fit) == 0)) { + diff = 0 + return + } + pixoff = FIT_PIXOFF(fit) - 1 + } + + ua = IM_USERAREA(im) + + if (FIT_NEWIMAGE(fit) == NO && inherit == YES) { + # Form an extension header by copying cards in the UA that + # do not belong in the global header nor in the old + # extension header if the image is open READ_WRITE. + + # Check if the file is still in cache. We need CACHELEN and + # CACHEHDR. + + call fxf_not_incache (im) + + len = strlen (Memc[ua]) + ulines = len / LEN_UACARD + clines = FIT_CACHEHLEN(fit) / LEN_UACARD + + call smark (sp) + call salloc (tb, len+1, TY_CHAR) + + # Now select those lines in UA that are not in fit_cache and + # put them in 'pb'. + + pb = tb + merge = NO + call fxf_match_str (ua, ulines, + FIT_CACHEHDR(fit), clines, merge, pb) + Memc[pb] = EOS + ualen = strlen (Memc[tb]) + + # Now copy the buffer pointed by 'pb' to UA. + call strcpy (Memc[tb], Memc[ua], ualen) + + call sfree (sp) + } + + # See also fitopix.x for an explanation of this call. + call fxf_mandatory_cards (im, nheader_cards) + + kmax = idb_findrecord (im, "DATAMAX", rp) + kmin = idb_findrecord (im, "DATAMIN", rp) + + if (IM_LIMTIME(im) < IM_MTIME(im)) { + # Keywords should not be in the UA. + if (kmax > 0) + call imdelf (im, "DATAMAX") + if (kmin > 0) + call imdelf (im, "DATAMIN") + + } else { + # Now update the keywords. If they are not in the UA we need + # to increase the number of mandatory cards. + + if (kmax == 0) + nheader_cards = nheader_cards + 1 + if (kmin == 0) + nheader_cards = nheader_cards + 1 + } + + # Determine if OBJECT or IM_TITLE have changed. IM_TITLE has + # priority. + + # If FIT_OBJECT is empty, then there was no OBJECT card at read + # time. If OBJECT is present now, then it was added now. If OBJECT + # was present but not now, the keyword was deleted. + + temp[1] = EOS + if (imaccf (im, "OBJECT") == YES) { + call imgstr (im, "OBJECT", temp, LEN_CARD) + # If its value is blank, then temp will be NULL + if (temp[1] == EOS) + call strcpy (" ", temp, LEN_CARD) + } + + if (temp[1] != EOS) + call strcpy (temp, FIT_OBJECT(fit), LEN_CARD) + else + nheader_cards = nheader_cards - 1 + + if (FIT_OBJECT(fit) == EOS) { + if (strcmp (IM_TITLE(im), FIT_TITLE(fit)) != 0) { + call strcpy (IM_TITLE(im), FIT_OBJECT(fit), LEN_CARD) + # The OBJECT keyword will be added. + nheader_cards = nheader_cards + 1 + } + } else { + # See if OBJECT has been deleted from UA. + if (temp[1] == EOS) + FIT_OBJECT(fit) = EOS + if (strcmp (IM_TITLE(im), FIT_TITLE(fit)) != 0) + call strcpy (IM_TITLE(im), FIT_OBJECT(fit), LEN_CARD) + } + + + # Too many mandatory cards if we are using the PHU in READ_WRITE mode. + # Because fxf_mandatory_cards gets call with FIT_NEWIMAGE set to NO, + # i.e. an extension. (12-9=3) + + if (FIT_XTENSION(fit) == NO && FIT_NEWIMAGE(fit) == NO) + nheader_cards = nheader_cards - 3 + + if (FIT_NEWIMAGE(fit) == NO && FIT_XTENSION(fit) == YES) { + + # Now take EXTNAME and EXTVER keywords off the UA if they are in + # there. The reason being they can be out of order. + + iferr (call imgstr (im, "EXTNAME", FIT_EXTNAME(fit), LEN_CARD)) { + FIT_EXTNAME(fit) = EOS + if (FKS_EXTNAME(fit) != EOS) { + call strcpy (FKS_EXTNAME(fit), FIT_EXTNAME(fit), LEN_CARD) + } else { + # We will not create EXTNAME keyword in the output header + nheader_cards = nheader_cards - 1 + } + } else { + call imdelf (im, "EXTNAME") + nheader_cards = nheader_cards + 1 + } + + if (imaccf (im, "EXTVER") == YES) { + FIT_EXTVER(fit) = imgeti (im, "EXTVER") + call imdelf (im, "EXTVER") + nheader_cards = nheader_cards + 1 + } + if (imaccf (im, "PCOUNT") == YES) { + call imdelf (im, "PCOUNT") + nheader_cards = nheader_cards + 1 + } + if (imaccf (im, "GCOUNT") == YES) { + call imdelf (im, "GCOUNT") + nheader_cards = nheader_cards + 1 + } + + if (IS_INDEFL(FIT_EXTVER(fit)) && !IS_INDEFL(FKS_EXTVER(fit))) + FIT_EXTVER(fit) = FKS_EXTVER(fit) + } + + # Finally if we are updating a BINTABLE with a PLIO_1 mask we need + # to add 3 to the mandatory cards since TFIELDS, TTYPE1, nor + # TFORM1 are included. ### Ugh!! + # Also add the Z cards. + + if (strncmp ("PLIO_1", FIT_EXTSTYPE(fit), 6) == 0) + nheader_cards = nheader_cards + 3 + 6 + IM_NDIM(im)*2 + + # Compute current header size rounded to a header block. + usize = strlen (Memc[ua]) + len = (usize / LEN_UACARD + nheader_cards) * LEN_CARD + len = FITS_LEN_CHAR(len / 2) + + # Ask for more lines if the header can or needs to be expanded. + padlines = FKS_PADLINES(fit) + + # Here we go over the FITS header area already allocated? + if (acmode == READ_WRITE || acmode == WRITE_ONLY) { + call fxf_not_incache(im) + hoff = FIT_HDRPTR(fit) + poff = FIT_PIXPTR(fit) + hdr_size = Memi[poff+group] - Memi[hoff+group] + ualen = len + diff = hdr_size - ualen + # If the header needs to be expanded add on the pad lines. + if (diff < 0) { + ualen = (usize/LEN_UACARD + nheader_cards + padlines) * LEN_CARD + ualen = FITS_LEN_CHAR(ualen / 2) + } + diff = hdr_size - ualen + } else if ((hdr_off == EOF || hdr_off == 0) && + (IM_NDIM(im) == 0 || FIT_NAXIS(fit) == 0)) { + hdr_size = len + ualen = len + } else { + hdr_size = pixoff + # The header can expand so add on the pad lines. + ualen = (usize / LEN_UACARD + nheader_cards + padlines) * LEN_CARD + ualen = FITS_LEN_CHAR(ualen / 2) + diff = hdr_size - ualen + } + + if (diff < 0 && FIT_EXPAND(fit) == NO) { + # We need to reduce the size of the UA becuase we are not + # going to expand the header. + excess = mod (nheader_cards * 81 + usize, 1458) + excess = excess + (((-diff-1400)/1440)*1458) + Memc[ua+usize-excess] = EOS + usize = strlen (Memc[ua]) + ualen = (usize / LEN_UACARD + nheader_cards) * LEN_CARD + ualen = FITS_LEN_CHAR(ualen / 2) + } +end + + +# FXF_WRITE_HDR -- Procedure to write header unit onto the PHU or EHU. + +procedure fxf_write_header (im, fit, hdr_fd, nchars_ua, group) + +pointer im #I image structure +pointer fit #I fits structure +int hdr_fd #I FITS header file descriptor +int nchars_ua #I header size +int group #I group number + +char temp[SZ_FNAME] +bool xtension, ext_append +pointer sp, spp, mii, rp, uap +char card[LEN_CARD], blank, keyword[SZ_KEYWORD], datestr[SZ_DATESTR] +int iso_cutover, n, i, sz_rec, up, nblanks, acmode, nbk, len, poff, diff +int pos, pcount, depth, subtype, maxlen, ndim + +long clktime() +int imaccf(), strlen(), fxf_ua_card(), envgeti() +int idb_findrecord(), strncmp(), btoi() +bool fxf_fpl_equald(), imgetb(), itob() +long note() +errchk write + +begin + call smark (sp) + call salloc (spp, FITS_BLOCK_CHARS*5, TY_CHAR) + call salloc (mii, FITS_BLOCK_CHARS, TY_INT) + + # Write out the standard, reserved header parameters. + n = spp + blank = ' ' + acmode = FIT_ACMODE(fit) + ext_append = ((acmode == NEW_IMAGE || acmode == NEW_COPY) && + (FKS_EXTNAME(fit) != EOS || !IS_INDEFL (FKS_EXTVER(fit)))) + + xtension = (FIT_XTENSION(fit) == YES) + if (FIT_NEWIMAGE(fit) == YES) + xtension = false + + subtype =0 + if ((FKS_SUBTYPE(fit) == FK_PLIO || + (strncmp("PLIO_1", FIT_EXTSTYPE(fit), 6) == 0)) && + IM_PL(im) != NULL) { + + subtype = FK_PLIO + ext_append = true + } + + # PLIO. Write BINTABLE header for a PLIO mask. + if (subtype == FK_PLIO) { + + if (IM_PFD(im) != NULL) { + call fxf_plinfo (im, maxlen, pcount, depth) + + # If we old heap has change in size, we need to + # resize it. + + if (acmode == READ_WRITE && pcount != FIT_PCOUNT(fit)) + call fxf_pl_adj_heap (im, hdr_fd, pcount) + } else { + pcount = FIT_PCOUNT(fit) + depth = DEF_PLDEPTH + } + + ndim = IM_NDIM(im) + call fxf_akwc ("XTENSION", "BINTABLE", 8, "Mask extension", n) + call fxf_akwi ("BITPIX", 8, "Bits per pixel", n) + call fxf_akwi ("NAXIS", ndim, "Number of axes", n) + call fxf_akwi ("NAXIS1", 8, "Number of bytes per line", n) + do i = 2, ndim { + call fxf_encode_axis ("NAXIS", keyword, i) + call fxf_akwi (keyword, IM_LEN(im,i), "axis length", n) + } + call fxf_akwi ("PCOUNT", pcount, "Heap size in bytes", n) + call fxf_akwi ("GCOUNT", 1, "Only one group", n) + + if (imaccf (im, "TFIELDS") == NO) + call fxf_akwi ("TFIELDS", 1, "1 Column field", n) + if (imaccf (im, "TTYPE1") == NO) { + call fxf_akwc ("TTYPE1", "COMPRESSED_DATA", 16, + "Type of PLIO_1 data", n) + } + call sprintf (card, LEN_CARD, "PI(%d)") + call pargi(maxlen) + call fxf_filter_keyw (im, "TFORM1") + len = strlen (card) + call fxf_akwc ("TFORM1", card, len, "Variable word array", n) + + } else { + if (xtension) + call fxf_akwc ("XTENSION", "IMAGE", 5, "Image extension", n) + else + call fxf_akwb ("SIMPLE", YES, "Fits standard", n) + + if (FIT_NAXIS(fit) == 0 || FIT_BITPIX(fit) == 0) + call fxf_setbitpix (im, fit) + + call fxf_akwi ("BITPIX", FIT_BITPIX(fit), "Bits per pixel", n) + call fxf_akwi ("NAXIS", FIT_NAXIS(fit), "Number of axes", n) + + do i = 1, FIT_NAXIS(fit) { + call fxf_encode_axis ("NAXIS", keyword, i) + call fxf_akwi (keyword, FIT_LENAXIS(fit,i), "Axis length", n) + } + + if (xtension) { + call fxf_akwi ("PCOUNT", 0, "No 'random' parameters", n) + call fxf_akwi ("GCOUNT", 1, "Only one group", n) + } else { + if (imaccf (im, "EXTEND") == NO) + i = NO + else { + # Keyword exists but it may be in the wrong position. + # Remove it and write it now. + + i = btoi (imgetb (im, "EXTEND")) + call fxf_filter_keyw (im, "EXTEND") + } + if (FIT_EXTEND(fit) == YES) + i = YES + call fxf_akwb ("EXTEND", i, "File may contain extensions", n) + FIT_EXTEND(fit) = YES + } + } + + # Delete BSCALE and BZERO just in case the application puts them + # in the UA after the pixels have been written. The keywords + # should not be there since the FK does not allow reading pixels + # with BITPIX -32 and BSCALE and BZERO. If the application + # really wants to circumvent this restriction the code below + # will defeat that. The implications are left to the application. + # This fix is put in here to save the ST Hstio interface to be + # a victim of the fact that in v2.12 the BSCALE and BZERO keywords + # are left in the header for the user to see or change. Previous + # FK versions, the keywords were deleted from the UA. + + if ((IM_PIXTYPE(im) == TY_REAL || IM_PIXTYPE(im) == TY_DOUBLE) + && (FIT_TOTPIX(fit) > 0 && FIT_BITPIX(fit) <= 0)) { + + call fxf_filter_keyw (im, "BSCALE") + call fxf_filter_keyw (im, "BZERO") + } + + # Do not write BSCALE and BZERO if they have the default + # values (1.0, 0.0). + + if (IM_PIXTYPE(im) == TY_USHORT) { + call fxf_filter_keyw (im, "BSCALE") + call fxf_akwd ("BSCALE", 1.0d0, + "REAL = TAPE*BSCALE + BZERO", NDEC_REAL, n) + call fxf_filter_keyw (im, "BZERO") + call fxf_akwd ("BZERO", 32768.0d0, "", NDEC_REAL, n) + } else if (FIT_PIXTYPE(fit) != TY_REAL && + FIT_PIXTYPE(fit) != TY_DOUBLE && IM_ACMODE(im) != NEW_COPY) { + # Now we have TY_SHORT or TY_(INT,LONG). + # Check the keywords only if they have non_default values. + + # Do not add the keywords if they have been deleted. + if (!fxf_fpl_equald(1.0d0, FIT_BSCALE(fit), 4)) { + if ((imaccf (im, "BSCALE") == NO) && + fxf_fpl_equald (1.0d0, FIT_BSCALE(fit), 4)) { + call fxf_akwd ("BSCALE", FIT_BSCALE(fit), + "REAL = TAPE*BSCALE + BZERO", NDEC_REAL, n) + } + } + if (!fxf_fpl_equald(0.0d0, FIT_BZERO(fit), 4) ) { + if (imaccf (im, "BZERO") == NO && + fxf_fpl_equald (1.0d0, FIT_BZERO(fit), 4)) + call fxf_akwd ("BZERO", FIT_BZERO(fit), "", NDEC_REAL, n) + } + } + + uap = IM_USERAREA(im) + + if (idb_findrecord (im, "ORIGIN", rp) == 0) { + call strcpy (FITS_ORIGIN, temp, LEN_CARD) + call fxf_akwc ("ORIGIN", + temp, strlen(temp), "FITS file originator", n) + } else if (rp - uap > 10*81) { + # Out of place; do not change the value. + call imgstr (im, "ORIGIN", temp, LEN_CARD) + call fxf_filter_keyw (im, "ORIGIN") + call fxf_akwc ("ORIGIN", + temp, strlen(temp), "FITS file originator", n) + } + + if (xtension) { + # Update the cache in case these values have changed + # in the UA. + call fxf_set_extnv (im) + + if (FIT_EXTNAME(fit) != EOS) { + call strcpy (FIT_EXTNAME(fit), temp, LEN_CARD) + call fxf_akwc ("EXTNAME", + temp, strlen(temp), "Extension name", n) + } + if (!IS_INDEFL (FIT_EXTVER(fit))) { + call fxf_akwi ("EXTVER", + FIT_EXTVER(fit), "Extension version", n) + } + if (idb_findrecord (im, "INHERIT", rp) > 0) { + # See if keyword is at the begining of the UA + if (rp - uap > 11*81) { + call fxf_filter_keyw (im, "INHERIT") + call fxf_akwb ("INHERIT", + FIT_INHERIT(fit), "Inherits global header", n) + } else if (acmode != READ_WRITE) + call imputb (im, "INHERIT", itob(FIT_INHERIT(fit))) + } else { + call fxf_akwb ("INHERIT", + FIT_INHERIT(fit), "Inherits global header", n) + } + } + + # Dates after iso_cutover use ISO format dates. + iferr (iso_cutover = envgeti (ENV_ISOCUTOVER)) + iso_cutover = DEF_ISOCUTOVER + + # Encode the "DATE" keyword (records create time of imagefile). + call fxf_encode_date (clktime(long(0)), datestr, SZ_DATESTR, + "ISO", iso_cutover) + len = strlen (datestr) + + if (idb_findrecord (im, "DATE", rp) == 0) { + # Keyword is not in the UA, created with current time + call fxf_akwc ("DATE", + datestr, len, "Date FITS file was generated", n) + } else { + if (acmode == READ_WRITE) { + # Keep the old DATE, change only the IRAF-TLM keyword value + call imgstr (im, "DATE", datestr, SZ_DATESTR) + } + # See if the keyword is out of order. + if (rp - uap > 12*81) { + call fxf_filter_keyw (im, "DATE") + + call fxf_akwc ("DATE", + datestr, len, "Date FITS file was generated", n) + } else + call impstr (im, "DATE", datestr) + } + + # Encode the "IRAF_TLM" keyword (records time of last modification). + if (acmode == NEW_IMAGE || acmode == NEW_COPY) { + FIT_MTIME(fit) = IM_MTIME(im) + } + + call fxf_encode_date (FIT_MTIME(fit), datestr, SZ_DATESTR, "TLM", 2010) +# call fxf_encode_date (clktime(long(0))+4, datestr, SZ_DATESTR, "TLM", 2010) + len = strlen (datestr) + + if (idb_findrecord (im, "IRAF-TLM", rp) == 0) { + call fxf_akwc ("IRAF-TLM", + datestr, len, "Time of last modification", n) + } else if (rp - uap > 13*81) { + call fxf_filter_keyw (im, "IRAF-TLM") + call fxf_akwc ("IRAF-TLM", + datestr, len, "Time of last modification", n) + } else + call impstr (im, "IRAF-TLM", datestr) + + # Create DATA(MIN,MAX) keywords only if they have the real + # min and max of the data. + + if (IM_LIMTIME(im) >= IM_MTIME(im)) { + if (idb_findrecord (im, "DATAMIN", rp) == 0) { + call fxf_akwr ("DATAMIN", + IM_MIN(im), "Minimum data value", NDEC_REAL, n) + } else + call imputr (im, "DATAMIN", IM_MIN(im)) + + if (idb_findrecord (im, "DATAMAX", rp) == 0) { + call fxf_akwr ("DATAMAX", + IM_MAX(im), "Maximum data value",NDEC_REAL, n) + } else + call imputr (im, "DATAMAX", IM_MAX(im)) + } + + if (FIT_OBJECT(fit) != EOS) { + if (idb_findrecord (im, "OBJECT", rp) == 0) { + call fxf_akwc ("OBJECT", FIT_OBJECT(fit), + strlen (FIT_OBJECT(fit)), "Name of the object observed", n) + } else if (rp - uap > 14*81) { + call fxf_filter_keyw (im, "OBJECT") + call fxf_akwc ("OBJECT", FIT_OBJECT(fit), + strlen (FIT_OBJECT(fit)), "Name of the object observed", n) + } else + call impstr (im, "OBJECT", FIT_OBJECT(fit)) + } + + # Write Compression keywords for PLIO BINTABLE. +# if (subtype == FK_PLIO && IM_PFD(im) != NULL && ext_append) { + if (subtype == FK_PLIO) { + call fxf_akwb ("ZIMAGE", YES, "Is a compressed image", n) + call fxf_akwc ("ZCMPTYPE", "PLIO_1", 6, "IRAF image masks", n) + call fxf_akwi ("ZBITPIX", 32, "BITPIX for uncompressed image",n) + + # We use IM_NDIM and IM_LEN here because FIT_NAXIS and _LENAXIS + # are not available for NEW_IMAGE mode. + + ndim = IM_NDIM(im) + call fxf_akwi ("ZNAXIS", ndim, "NAXIS for uncompressed image",n) + do i = 1, ndim { + call fxf_encode_axis ("ZNAXIS", keyword, i) + call fxf_akwi (keyword, IM_LEN(im,i), "Axis length", n) + } + call fxf_encode_axis ("ZTILE", keyword, 1) + call fxf_akwi (keyword, IM_LEN(im,1), "Axis length", n) + do i = 2, ndim { + call fxf_encode_axis ("ZTILE", keyword, i) + call fxf_akwi (keyword, 1, "Axis length", n) + } + call fxf_encode_axis ("ZNAME", keyword, 1) + call fxf_akwc (keyword, "depth", 5, "PLIO mask depth", n) + call fxf_encode_axis ("ZVAL", keyword, 1) + call fxf_akwi (keyword, depth, "Parameter value", n) + } + + # Write the UA now. + up = 1 + nbk = 0 + n = n - spp + sz_rec = 1440 + while (fxf_ua_card (fit, im, up, card) == YES) { + call amovc (card, Memc[spp+n], LEN_CARD) + n = n + LEN_CARD + + if (n == 2880) { + nbk = nbk + 1 + call miipak (Memc[spp], Memi[mii], sz_rec*2, TY_CHAR, MII_BYTE) + call write (hdr_fd, Memi[mii], sz_rec) + n = 0 + } + } + + # Write the last record. + nblanks = 2880 - n + call amovkc (blank, Memc[spp+n], nblanks) + rp = spp+n+nblanks-LEN_CARD + + # If there are blocks of trailing blanks, write them now. + if (n > 0) + nbk = nbk + 1 + diff = nchars_ua - nbk * 1440 + if (diff > 0) { + if (n > 0) { + call miipak (Memc[spp], Memi[mii], sz_rec*2, TY_CHAR, MII_BYTE) + call write (hdr_fd, Memi[mii], sz_rec) + } + + if (group < 0) { + # We are writing blocks of blanks on a new_copy + # image which has group=-1 here. Use diff. + + nbk = diff / 1440 + } else { + pos = note (hdr_fd) + call fxf_not_incache(im) + poff = FIT_PIXPTR(fit) + nbk = (Memi[poff+group] - pos) + nbk = nbk / 1440 + } + call amovkc (blank, Memc[spp], 2880) + call miipak (Memc[spp], Memi[mii], sz_rec*2, TY_CHAR, MII_BYTE) + do i = 1, nbk-1 + call write (hdr_fd, Memi[mii], sz_rec) + + call amovkc (blank, Memc[spp], 2880) + rp = spp+2880-LEN_CARD + } + + call amovc ("END", Memc[rp], 3) + call miipak (Memc[spp], Memi[mii], sz_rec*2, TY_CHAR, MII_BYTE) + call write (hdr_fd, Memi[mii], sz_rec) + # PLIO: write the mask data to the new extension. + if (subtype == FK_PLIO && IM_PFD(im) != NULL) { + call fxf_plwrite (im, hdr_fd) + IM_PFD(im) = NULL + } + + call flush (hdr_fd) + call sfree (sp) +end + + +# FXF_UA_CARD -- Fetch a single line from the user area, trim newlines and +# pad with blanks to size LEN_CARD in order to create an unknown keyword card. +# At present user area information is assumed to be in the form of FITS card +# images, less then or equal to 80 characters and delimited by a newline. + +int procedure fxf_ua_card (fit, im, up, card) + +pointer fit #I points to the fits descriptor +pointer im #I pointer to the IRAF image +int up #I next character in the unknown string +char card[ARB] #O FITS card image + +char cval +int stat, diff +char chfetch() +int strmatch() + +begin + if (chfetch (UNKNOWN(im), up, cval) == EOS) + return (NO) + else { + up = up - 1 + stat = NO + + while (stat == NO) { + diff = up + call fxf_make_card (UNKNOWN(im), up, card, 1, LEN_CARD, '\n') + diff = up - diff + if (card[1] == EOS) + break + + if (strmatch ( card, "^GROUPS ") != 0) + stat = NO + else if (strmatch (card, "^GCOUNT ") != 0) + stat = NO + else if (strmatch (card, "^PCOUNT ") != 0) + stat = NO + else if (strmatch (card, "^BLOCKED ") != 0) + stat = NO + else if (strmatch (card, "^PSIZE ") != 0) + stat = NO + else + stat = YES + } + + return (stat) + } +end + + +# FXF_SETBITPIX -- Set the FIT_BITPIX to the pixel datatype value. + +procedure fxf_setbitpix (im, fit) + +pointer im #I image descriptor +pointer fit #I fit descriptor + +int datatype +errchk syserr, syserrs + +begin + datatype = IM_PIXTYPE(im) + + switch (datatype) { + case TY_SHORT, TY_USHORT: + FIT_BITPIX(fit) = FITS_SHORT + case TY_INT, TY_LONG: + FIT_BITPIX(fit) = FITS_LONG + case TY_REAL: + FIT_BITPIX(fit) = FITS_REAL + case TY_DOUBLE: + FIT_BITPIX(fit) = FITS_DOUBLE + default: + call flush (STDOUT) + call syserr (SYS_FXFUPHBTYP) + } +end + + +# FXF_MAKE_ADJ_COPY -- Copy a FITS file into a new one, changing the size +# of a fits header. + +procedure fxf_make_adj_copy (in_fd, out_fd, hdr_off, pixoff, chars_ua) + +int in_fd #I input FITS descriptor +int out_fd #I output FITS descriptor +int hdr_off #I offset to be beginning of the ua to be resized +int pixoff #I offset to be pixel area following hdroff +int chars_ua #I size of the new UA (user area) in units of chars + +pointer mii, sp +int nk, nblocks, junk, size_ua +errchk read, write +int read() + +begin + call smark (sp) + call salloc (mii, FITS_BLOCK_CHARS, TY_INT) + + # Number of 1440 chars block up to the beginning of the UA to change. + nblocks = hdr_off / FITS_BLOCK_CHARS + + # Copy everything up to hdroff. + call seek (in_fd, BOF) + do nk = 1, nblocks { + junk = read (in_fd, Memi[mii], FITS_BLOCK_CHARS) + call write (out_fd, Memi[mii], FITS_BLOCK_CHARS) + } + + # Size of the new UA. + size_ua = FITS_LEN_CHAR(chars_ua) + nblocks = size_ua / FITS_BLOCK_CHARS + + # Put a blank new header in the meantime. + call amovki( 0, Memi[mii], FITS_BLOCK_CHARS) + do nk = 1, nblocks + call write (out_fd, Memi[mii], FITS_BLOCK_CHARS) + + # Position after the current input header to continue + # copying. + + call flush (out_fd) + call seek (in_fd, pixoff) + call fcopyo (in_fd, out_fd) + call flush (out_fd) + call sfree (sp) +end + + +# FXF_SET_CACHE_MTIME -- Procedure to reset the modification time on the +# cached entry for the file pointed by 'im'. + +procedure fxf_set_cache_time (im, overwrite) + +pointer im #I image descriptor +bool overwrite #I invalidate entry if true + +pointer sp, hdrfile, fit +long fi[LEN_FINFO] +int finfo(), cindx +errchk syserr, syserrs +bool streq() + +include "fxfcache.com" + +begin + call smark (sp) + call salloc (hdrfile, SZ_PATHNAME, TY_CHAR) + + fit = IM_KDES(im) + + call fpathname (IM_HDRFILE(im), Memc[hdrfile], SZ_PATHNAME) + if (finfo (Memc[hdrfile], fi) == ERR) + call syserrs (SYS_FOPEN, IM_HDRFILE(im)) + + # Search the header file cache for the named image. + do cindx = 1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + + if (streq (Memc[hdrfile], rf_fname[1,cindx])) { + # Reset cache + if (IM_ACMODE(im) == READ_WRITE || overwrite) { + # Invalidate entry. + call mfree (rf_pextv[cindx], TY_INT) + call mfree (rf_pextn[cindx], TY_CHAR) + call mfree (rf_pixp[cindx], TY_INT) + call mfree (rf_hdrp[cindx], TY_INT) + call mfree (rf_fit[cindx], TY_STRUCT) + call mfree (rf_hdr[cindx], TY_CHAR) + rf_fname[1,cindx] = EOS + rf_mtime[cindx] = 0 + rf_fit[cindx] = NULL + + } else { + # While we are appending we want to keep the cache entry + # in the slot. + rf_mtime[cindx] = FI_MTIME(fi) + } + break + } + } + + call sfree (sp) +end + + +# FXF_SET_EXTNV -- Procedure to write UA value of EXTNAME and EXTVER +# into the cache slot. + +procedure fxf_set_extnv (im) + +pointer im #I image descriptor + +pointer fit, sp, hdrfile +int cindx, ig, extn, extv +errchk syserr, syserrs +bool bxtn, bxtv +bool streq() + +include "fxfcache.com" + +begin + fit = IM_KDES(im) + ig = FIT_GROUP(fit) + + call smark (sp) + call salloc (hdrfile, SZ_PATHNAME, TY_CHAR) + + # Search the header file cache for the named image. + do cindx = 1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + + if (streq (Memc[hdrfile], rf_fname[1,cindx])) { + bxtn = (FIT_EXTNAME(fit) != EOS) + bxtv = (!IS_INDEFL (FIT_EXTVER(fit))) + # Reset cache + if (IM_ACMODE(im) == READ_WRITE) { + if (bxtn) { + extn = rf_pextn[cindx] + # Just replace the value + call strcpy (FIT_EXTNAME(fit), Memc[extn+LEN_CARD*ig], + LEN_CARD) + } + if (bxtv) { + extv = rf_pextv[cindx] + # Just replace the value + Memi[extv+ig] = FIT_EXTVER(fit) + } + } + break + } + } + + call sfree (sp) +end + + +# FXF_REN_TMP -- Rename input file to output file. +# +# The output file may already exists in which case it is replaced. +# Because this operation is critical it is heavily error checked and +# has retries to deal with networking cases. + +procedure fxf_ren_tmp (in, out, tmp, ntry, nsleep) + +char in[ARB] #I file to replace output +char out[ARB] #O output file (replaced if it exists) +char tmp[ARB] #I temporary name for in until rename succeeds +int ntry #I number of retries for rename +int nsleep #I Number of seconds to sleep before retry + +int i, stat, err, access(), protect(), errget() +bool replace, prot +pointer errstr + +errchk access, protect, rename, delete, salloc + +begin +#call eprintf ("fxf_ren_tmp (%s, %s, %s, %d %d)\n") +#call pargstr (in) +#call pargstr (out) +#call pargstr (tmp) +#call pargi (ntry) +#call pargi (nsleep) + err = 0; errstr = NULL + + iferr { + # Move original output out of the way. + # Don't delete it in case of an error. + replace = (access (out, 0, 0) == YES) + prot = false + if (replace) { + prot = (protect (out, QUERY_PROTECTION) == YES) + if (prot) + stat = protect (out, REMOVE_PROTECTION) + do i = 0, max(0,ntry) { +#call eprintf ("1 rename (%s, %s)\n") +#call pargstr (out) +#call pargstr (tmp) + ifnoerr (call rename (out, tmp)) { + err = 0 + break + } + if (errstr == NULL) + call salloc (errstr, SZ_LINE, TY_CHAR) + err = errget (Memc[errstr], SZ_LINE) + if (err == 0) + err = SYS_FMKCOPY + call tsleep (nsleep) + } + if (err > 0) + call error (err, Memc[errstr]) + } + + # Now rename the input to the output. + do i = 0, max(0,ntry) { +#call eprintf ("2 rename (%s, %s)\n") +#call pargstr (in) +#call pargstr (out) + ifnoerr (call rename (in, out)) { + err = 0 + break + } + if (errstr == NULL) + call salloc (errstr, SZ_LINE, TY_CHAR) + err = errget (Memc[errstr], SZ_LINE) + if (err == 0) + err = SYS_FMKCOPY + call tsleep (nsleep) + } + if (err > 0) + call error (err, Memc[errstr]) + if (prot) + stat = protect (out, SET_PROTECTION) + + # If the rename has succeeded delete the original data. + if (replace) { +#call eprintf ("delete (%s)\n") +#call pargstr (tmp) + call delete (tmp) + } + } then + call erract (EA_ERROR) +end + + +# FXF_OVER_TMP -- Rename an entry from the cache. + +procedure fxf_over_delete (im) + +pointer im #I image descriptor + +pointer fname, sp +bool streq() +int cindx +include "fxfcache.com" + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + call fpathname (IM_HDRFILE(im), Memc[fname], SZ_PATHNAME) + + # Remove the image from the FITS cache if found. + do cindx=1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + if (streq (Memc[fname], rf_fname[1,cindx])) { + call mfree (rf_pextv[cindx], TY_INT) + call mfree (rf_pextn[cindx], TY_CHAR) + call mfree (rf_pixp[cindx], TY_INT) + call mfree (rf_hdrp[cindx], TY_INT) + call mfree (rf_fit[cindx], TY_STRUCT) + call mfree (rf_hdr[cindx], TY_CHAR) + rf_fit[cindx] = NULL + } + } + + call sfree (sp) +end + + +# FXF_UPDATE_EXTEND -- Add or change the value of the EXTEND keyword in PHU. +# Sometimes the input PHU has not been created by the FK and the EXTEND keyw +# might not be there as the standard tells when an extension is appended +# to a file. + +procedure fxf_update_extend (im) + +pointer im #I image descriptor + +pointer sp, hdrfile, tmp1, tmp2 +int fd, fdout, i, nch, nc, cfit +char line[LEN_CARD], blank, cindx +bool streq() +int open(), naxis, read(), strncmp(), fnroot() +long note() +errchk open, fxf_ren_tmp + +include "fxfcache.com" +define cfit_ 91 + +begin + call smark (sp) + call salloc (hdrfile, SZ_PATHNAME, TY_CHAR) + + fd = open (IM_HDRFILE(im), READ_WRITE, BINARY_FILE) + + # Look for EXTEND keyword and change its value in place. + nc = 0 + while (read (fd, line, 40) != EOF) { + nc = nc + 1 + call achtbc (line, line, LEN_CARD) + if (strncmp ("EXTEND ", line, 8) == 0) { + line[30] = 'T' + call seek (fd, note(fd)-40) + call achtcb (line, line, LEN_CARD) + call write (fd, line, 40) + call close (fd) + goto cfit_ + } else if (strncmp ("END ", line, 8) == 0) + break + } + + # The EXTEND card is not in the header. Insert it after the + # last NAXISi in a temporary file, rename after this. + + call salloc (tmp1, SZ_FNAME, TY_CHAR) + i = fnroot (IM_HDRFILE(im), Memc[tmp1], SZ_FNAME) + call mktemp (Memc[tmp1], Memc[tmp1], SZ_FNAME) + + fdout = open (Memc[tmp1], NEW_FILE, BINARY_FILE) + + call seek (fd, BOF) + do i = 0, nc-2 { + nch = read (fd, line, 40) + call write (fdout, line, 40) + call achtbc(line, line, LEN_CARD) + if (strncmp ("NAXIS ", line, 8) == 0) + call fxf_geti (line, naxis) + else if (strncmp ("NAXIS", line, 5) == 0){ + if ((line[6] - '0') == naxis) { + # Now create the EXTEND card in the output file. + call fxf_encodeb ("EXTEND", YES, line, + "File may contain extensions") + call achtcb (line, line , LEN_CARD) + call write (fdout, line, 40) + } + } + } + + if (mod (nc, 36) == 0) { + # We have to write one END card and 35 blank card. + blank = ' ' + call amovkc (blank, line, 80) + call amovc ("END", line, 3) + call achtcb (line, line , LEN_CARD) + call write (fdout, line, 40) + call amovkc (blank, line, 80) + call achtcb (line, line , LEN_CARD) + for (i=1; i < 36; i=i+1) + call write (fdout, line, 40) + } else { + nch = read (fd, line, 40) + call write (fdout, line, 40) + } + + # Read one more line to synchronize. + nch = read (fd, line, 40) + + # Copy the rest of the file. + call fcopyo (fd, fdout) + + call close (fd) + call close (fdout) + + call salloc (tmp2, SZ_FNAME, TY_CHAR) + call strcpy (Memc[tmp1], Memc[tmp2], SZ_FNAME) + call strcat ("A", Memc[tmp2], SZ_FNAME) + call fxf_ren_tmp (Memc[tmp1], IM_HDRFILE(im), Memc[tmp2], 1, 1) + +cfit_ + # Now reset the value in the cache + call fpathname (IM_HDRFILE(im), Memc[hdrfile], SZ_PATHNAME) + + # Search the header file cache for the named image. + do cindx = 1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + + if (streq (Memc[hdrfile], rf_fname[1,cindx])) { + # Reset cache + cfit = rf_fit[cindx] + FIT_EXTEND(cfit) = YES + break + } + } + + call sfree (sp) +end diff --git a/sys/imio/iki/fxf/fxfupk.x b/sys/imio/iki/fxf/fxfupk.x new file mode 100644 index 00000000..b6b158ae --- /dev/null +++ b/sys/imio/iki/fxf/fxfupk.x @@ -0,0 +1,155 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "fxf.h" + +# FXFUPK.X -- Routines to upack an IEEE vector into native format. +# +# fxf_unpack_data (cbuf, npix, pixtype, bscale, bzero) +# fxf_altmr (a, b, npix, bscale, bzero) +# fxf_altmd (a, b, npix, bscale, bzero) +# fxf_altmu (a, b, npix) +# fxf_astmr (a, b, npix, bscale, bzero) + +define NBITS_DOU (SZB_CHAR * SZ_DOUBLE) +define IOFF 1 + + +# FITUPK -- Unpack cbuf in place from FITS binary format to local machine type. + +procedure fxf_unpack_data (cbuf, npix, pixtype, bscale, bzero) + +char cbuf[ARB] #U buffer with input,output data +int npix #I number of pixels in buffer +int pixtype #I input pixtype +double bscale #I scale factor to applied to input data +double bzero #I offset to applied to input data + +int nchars, nbytes +bool fp_equald() +errchk syserr + +include + +begin + nchars = npix * pix_size[pixtype] + nbytes = nchars * SZB_CHAR + + switch (pixtype) { + case TY_SHORT, TY_USHORT: + if (BYTE_SWAP2 == YES) + call bswap2 (cbuf, 1, cbuf, 1, nbytes) + if (pixtype == TY_USHORT) + call fxf_altmu (cbuf, cbuf, npix) + + case TY_INT, TY_LONG: + if (BYTE_SWAP4 == YES) + call bswap4 (cbuf, 1, cbuf, 1, nbytes) + + case TY_REAL: + ### Rather than perform this test redundantly a flag should be + ### passed in from the high level code telling the routine whether + ### or not it should apply the scaling. Testing for floating + ### point equality (e.g. bscale != 1.0) is not portable. + + if (!fp_equald(bscale,1.0d0) || !fp_equald(bzero,0.0d0)) { + if (BYTE_SWAP4 == YES) + call bswap4 (cbuf, 1, cbuf, 1, nbytes) + call iscl32 (cbuf, cbuf, npix, bscale, bzero) + } else + call ieevupkr (cbuf, cbuf, npix) + + case TY_DOUBLE: + ### Same as above. + if (!fp_equald(bscale,1.0d0) || !fp_equald(bzero,0.0d0)) { + if (BYTE_SWAP4 == YES) + call bswap4 (cbuf, 1, cbuf, 1, nbytes) + call iscl64 (cbuf, cbuf, npix, bscale, bzero) + } else + call ieevupkd (cbuf, cbuf, npix) + + default: + call syserr (SYS_FXFUPKDTY) + } +end + + +# FXF_ALTMR -- Scale a real array. + +procedure fxf_altmr (a, b, npix, bscale, bzero) + +int a[ARB] #I input array +real b[ARB] #O output array +int npix #I number of pixels +double bscale, bzero #I scaling parameters + +int i + +begin + do i = 1, npix + b[i] = a[i] * bscale + bzero +end + + +# FXF_ALTMD -- Scale a double array. + +procedure fxf_altmd (a, b, npix, bscale, bzero) + +int a[ARB] #I input array +double b[ARB] #O output array +int npix #I number of pixels +double bscale, bzero #I scaling parameters + +int i + +begin + ### int and double are not the same size so if this operation is + ### to allow an in-place conversion it must go right to left instead + ### of left to right. + + do i = npix, 1, -1 + b[i] = a[i] * bscale + bzero +end + + +# FXF_ALTMU -- Scale an array to unsigned short. + +procedure fxf_altmu (a, b, npix) + +short a[ARB] #I input array +char b[ARB] #O output array +int npix #I number of pixels + +int i +pointer sp, ip + +begin + call smark (sp) + call salloc (ip, npix+1, TY_INT) + + do i = 1, npix + Memi[ip+i] = a[i] + 32768 + + call achtlu (Memi[ip+1], b, npix) + call sfree (sp) +end + + +# FXF_ASTMR -- Scale an input short array into a real. + +procedure fxf_astmr (a, b, npix, bscale, bzero) + +short a[ARB] #I input array +real b[ARB] #O output array +int npix #I number of pixels +double bscale, bzero #I scaling parameters + +int i + +begin + do i = npix, 1, -1 + b[i] = a[i] * bscale + bzero +end + + diff --git a/sys/imio/iki/fxf/mkpkg b/sys/imio/iki/fxf/mkpkg new file mode 100644 index 00000000..859d6f47 --- /dev/null +++ b/sys/imio/iki/fxf/mkpkg @@ -0,0 +1,42 @@ +# Build or update the FITS kernel. + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + fxfaccess.x fxf.h + fxfaddpar.x fxf.h + fxfclose.x fxf.h + fxfcopy.x + fxfctype.x fxf.h + fxfdelete.x fxf.h fxfcache.com + fxfencode.x fxf.h + fxfexpandh.x fxf.h fxfcache.com \ + + fxfget.x fxf.h + fxfhextn.x fxf.h + fxfksection.x fxf.h + fxfmkcard.x + fxfnull.x fxf.h + fxfopen.x fxf.h fxfcache.com \ + fxfcache.com \ + + fxfopix.x fxf.h + fxfpak.x fxf.h + fxfplread.x fxf.h + fxfplwrite.x fxf.h \ + + fxfrcard.x fxf.h + fxfrdhdr.x fxf.h + fxfrename.x fxf.h fxfcache.com + fxfrfits.x fxf.h fxfcache.com \ + + fxfupdhdr.x fxf.h \ + fxfcache.com \ + + fxfupk.x fxf.h + zfiofxf.x fxf.h \ + + ; diff --git a/sys/imio/iki/fxf/zfiofxf.x b/sys/imio/iki/fxf/zfiofxf.x new file mode 100644 index 00000000..97b36264 --- /dev/null +++ b/sys/imio/iki/fxf/zfiofxf.x @@ -0,0 +1,546 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include "fxf.h" + +# ZFIOFXF -- FITS kernel virtual file driver. This maps the actual +# FITS file into the virtual pixel file expected by IMIO. + + +# FXFZOP -- Open the file driver for i/o. The filename has appended the +# string "_nnnnn", where 'nnnnn' is the FIT descriptor to the structure +# defined in "fit.h". + +procedure fxfzop (pkfn, mode, status) + +char pkfn[ARB] #I packed virtual filename from FIO +int mode #I file access mode (ignored) +int status #O output status - i/o channel if successful + +pointer im, fit +int ip, indx, channel, strldx(), ctoi() +bool lscale, lzero, bfloat, fxf_fpl_equald() +char fname[SZ_PATHNAME] + +begin + # Separate the FIT descriptor from the file name. + call strupk (pkfn, fname, SZ_PATHNAME) + + ip = strldx ("_", fname) + indx = ip + 1 + if (ctoi (fname, indx, fit) <= 0) { + status = ERR + return + } + + # Determine if we have a Fits Kernel non supported + # data format; i.e. Bitpix -32 or -64 and BSCALE and/or + # BZERO with non default values. + + ### Only "low level" routines can be falled from a file driver: + ### high level routines like syserr cannot be used due to + ### recursion/reentrancy problems. + # We are calling syserrs at this level because we want to + # give the application the freedom to manipulate the FITS header + # at will and not imposing restriction at that level. + + im = FIT_IM(fit) + lscale = fxf_fpl_equald (1.0d0, FIT_BSCALE(fit), 1) + lzero = fxf_fpl_equald (0.0d0, FIT_BZERO(fit), 1) + + # Determine if scaling is necessary. + #bfloat = (!lscale || !lzero) + #if (bfloat && (FIT_BITPIX(fit) == -32 || FIT_BITPIX(fit) == -64)) { + # FIT_IOSTAT(fit) = ERR + # #call syserrs (SYS_FXFRDHSC,IM_HDRFILE(im)) + # status = ERR + # return + #} + + fname[ip] = EOS + call strpak (fname, fname, SZ_PATHNAME) + + # Open the file. + call zopnbf (fname, mode, channel) + if (channel == ERR) { + status = ERR + return + } + + status = fit + FIT_IO(fit) = channel +end + + +# FITZCL -- Close the FIT binary file driver. + +procedure fxfzcl (chan, status) + +int chan #I FIT i/o channel +int status #O output status + +pointer fit + +begin + fit = chan + call zclsbf (FIT_IO(fit), status) +end + + +# FXFZRD -- Read the FIT file (header and pixel data). An offset pointer +# needs to be set to point to the data portion of the file. If we are reading +# pixel data, the scale routine fxf_unpack_data is called. We need to keep +# a counter (npix_read) with the current number of pixels unpacked since we +# don't want to convert beyond the total number of pixels; where the last +# block of data read can contain zeros or garbage up to a count of 2880 bytes. + +procedure fxfzrd (chan, obuf, nbytes, boffset) + +int chan #I FIT i/o channel +char obuf[ARB] #O output buffer +int nbytes #I nbytes to be read +int boffset #I file offset at which read commences + +pointer fit, im +int ip, pixtype, nb +int status, totpix, npix +int datasizeb, pixoffb, nb_skipped, i +double dtemp +real rtemp, rscale, roffset + +include + +begin + fit = chan + im = FIT_IM(fit) + FIT_IOSTAT(fit) = OK + + totpix = IM_PHYSLEN(im,1) + do i = 2, IM_NPHYSDIM(im) + totpix = totpix * IM_PHYSLEN(im,i) + + if (FIT_ZCNV(fit) == YES) { + if (FIT_PIXTYPE(fit) != TY_REAL && FIT_PIXTYPE(fit) != TY_DOUBLE) { + call fxf_cnvpx (im, totpix, obuf, nbytes, boffset) + return + } + } + + pixtype = IM_PIXTYPE(im) + datasizeb = totpix * (pix_size[pixtype] * SZB_CHAR) + pixoffb = (FIT_PIXOFF(fit) - 1) * SZB_CHAR + 1 + + # We can read the data directly into the caller's output buffer as + # any FITS kernel input conversions are guaranteed to not make the + # data smaller. + + call zardbf (FIT_IO(fit), obuf, nbytes, boffset) + call zawtbf (FIT_IO(fit), status) + if (status == ERR) { + FIT_IOSTAT(fit) = ERR + return + } + + ### boffset is 1-indexed, so one would expect (boffset/SZB_CHAR) to + ### be ((boffset - 1) * SZB_CHAR + 1). This is off by one from what + ### is being calculated, so if PIXOFF and boffset point to the same + ### place IP will be one, which happens to be the correct array index. + ### Nonehtless expressions like this should be written out so that + ### they can be verified easily by reading them. Any modern compiler + ### will optimize the expression, we don't have to do this in the + ### source code. + + ip = FIT_PIXOFF(fit) - boffset/SZB_CHAR + if (ip <= 0) + ip = 1 + + nb_skipped = boffset - pixoffb + if (nb_skipped <= 0) + nb = min (status + nb_skipped, datasizeb) + else + nb = min (status, datasizeb - nb_skipped) + npix = max (0, nb / (pix_size[pixtype] * SZB_CHAR)) + + if (FIT_ZCNV(fit) == YES) { + if (FIT_PIXTYPE(fit) == TY_REAL) { + # This is for scaling -32 (should not be allowed) + call fxf_zaltrr(obuf[ip], npix, FIT_BSCALE(fit), FIT_BZERO(fit)) + } else if (FIT_PIXTYPE(fit) == TY_DOUBLE) { + # This is for scaling -64 data (should not be allowed) + call fxf_zaltrd(obuf[ip], npix, FIT_BSCALE(fit), FIT_BZERO(fit)) + } + } else { + call fxf_unpack_data (obuf[ip], + npix, pixtype, FIT_BSCALE(fit), FIT_BZERO(fit)) + } +end + +procedure fxf_zaltrr (data, npix, bscale, bzero) + +real data[ARB], rt +int npix +double bscale, bzero + +int i + +begin + call ieevupkr (data, data, npix) + do i = 1, npix { + data[i] = data[i] * bscale + bzero + } +end + + +procedure fxf_zaltrd (data, npix, bscale, bzero) + +double data[ARB] +int npix +double bscale, bzero + +int i + +begin + call ieevupkd (data, data, npix) + do i = 1, npix + data[i] = data[i] * bscale + bzero +end + + + +# FXFZWR -- Write to the output file. + +procedure fxfzwr (chan, ibuf, nbytes, boffset) + +int chan #I QPF i/o channel +char ibuf[ARB] #O data buffer +int nbytes #I nbytes to be written +int boffset #I file offset + +pointer fit, im, sp, obuf +bool noconvert, lscale, lzero, bfloat +int ip, op, pixtype, npix, totpix, nb, nchars, i +int datasizeb, pixoffb, nb_skipped, obufsize + +bool fxf_fpl_equald() + +include + +begin + fit = chan + im = FIT_IM(fit) + FIT_IOSTAT(fit) = OK + + # We don't have to pack the data if it is integer and we don't need + # to byte swap; the data buffer can be written directly out. + + + # Determine if we are writing into an scaled floating point data + # unit; i.e. bitpix > 0 and BSCALE or/and BZERO with non default + # values. This is an error since we are not supporting this + # combination for writing at this time. + + lscale = fxf_fpl_equald (1.0d0, FIT_BSCALE(fit), 1) + lzero = fxf_fpl_equald (0.0d0, FIT_BZERO(fit), 1) + + # Determine if scaling is necessary. + bfloat = (!lscale || !lzero) + if (bfloat && + (IM_PIXTYPE(im) == TY_REAL || IM_PIXTYPE(im) == TY_DOUBLE)) { + FIT_IOSTAT(fit) = ERR + return + } + + pixtype = IM_PIXTYPE(im) + noconvert = ((pixtype == TY_SHORT && BYTE_SWAP2 == NO) || + ((pixtype == TY_INT || pixtype == TY_LONG) && BYTE_SWAP4 == NO)) + + if (noconvert) { + call zawrbf (FIT_IO(fit), ibuf, nbytes, boffset) + return + } + + # Writing pixel data to an image is currently illegal if on-the-fly + # conversion is in effect, as on-the-fly conversion is currently only + # available for reading. + + if (FIT_ZCNV(fit) == YES) { + FIT_IOSTAT(fit) = ERR + return + } + + totpix = IM_PHYSLEN(im,1) + do i = 2, IM_NPHYSDIM(im) + totpix = totpix * IM_PHYSLEN(im,i) + + datasizeb = totpix * (pix_size[pixtype] * SZB_CHAR) + pixoffb = (FIT_PIXOFF(fit) - 1) * SZB_CHAR + 1 + + ### Same comments as for fxfzrd apply here. + ### There doesn't appear to be any support here for byte data like + ### in fxfzwr. This must mean that byte images are read-only. + ### This shouldn't be necessary, but we shouldn't try to do anything + ### about it until the fxf_byte_short issue is addressed. + + ip = FIT_PIXOFF(fit) - boffset / SZB_CHAR + if (ip <= 0) + ip = 1 + + nb_skipped = boffset - pixoffb + if (nb_skipped <= 0) + nb = min (nbytes + nb_skipped, datasizeb) + else + nb = min (nbytes, datasizeb - nb_skipped) + npix = max (0, nb / (pix_size[pixtype] * SZB_CHAR)) + + if (npix == 0) + return + + # We don't do scaling (e.g. BSCALE/BZERO) when writing. All the + # generated FITS files in this interface are ieee fits standard. + ### I didn't look into it but I don't understand this; when accessing + ### a BSCALE image read-write, it should be necessary to scale both + ### when reading and writing if the application sees TY_REAL pixels. + ### When writing a new image I suppose the application would take + ### care of any scaling. + + # Convert any pixel data in the input buffer to the binary format + # required for FITS and write it out. Any non-pixel data in the + # buffer should be left as-is. + + obufsize = (nbytes + SZB_CHAR-1) / SZB_CHAR + + call smark (sp) + call salloc (obuf, obufsize, TY_CHAR) + + # Preserve any leading non-pixel data. + op = 1 + if (ip > 1) { + nchars = min (obufsize, ip - 1) + call amovc (ibuf[1], Memc[obuf], nchars) + op = op + nchars + } + + # Convert and output the pixels. + call fxf_pak_data (ibuf[ip], Memc[obuf+op-1], npix, pixtype) + op = op + npix * pix_size[pixtype] + + # Preserve any remaining non-pixel data. + nchars = obufsize - op + 1 + if (nchars > 0) + call amovc (ibuf[op], Memc[obuf+op-1], nchars) + + # Write out the data. + call zawrbf (FIT_IO(fit), Memc[obuf], nbytes, boffset) + + call sfree (sp) +end + + +# FXFZWT -- Return the number of bytes transferred in the last i/o request. + +procedure fxfzwt (chan, status) + +int chan #I QPF i/o channel +int status #O i/o channel status + +pointer fit, im + +begin + fit = chan + im = FIT_IM(fit) + + # A file driver returns status for i/o only in the AWAIT routine; + # hence any i/o errors occurring in the FK itself are indicated by + # setting FIT_IOSTAT. Otherwise the actual i/o operation must have + # been submitted, and we call zawtbf to wait for i/o, and get status. + + if (FIT_IOSTAT(fit) != OK) + status = FIT_IOSTAT(fit) + else + call zawtbf (FIT_IO(fit), status) + + # FIT_ZBYTES has the correct number of logical bytes that need + # to be passed to fio since we are expanding the buffer size + # from byte to short or real and short to real. + + if (status > 0) { + if (FIT_PIXTYPE(fit) == TY_UBYTE) + status = FIT_ZBYTES(fit) + else if (FIT_PIXTYPE(fit) == TY_SHORT && IM_PIXTYPE(im) == TY_REAL) + status = FIT_ZBYTES(fit) + } +end + + +# FXFZST -- Query device/file parameters. + +procedure fxfzst (chan, param, value) + +int chan #I FIT i/o channel +int param #I parameter to be returned +int value #O parameter value + +pointer fit, im +int i, totpix, szb_pixel, szb_real + +include + +begin + fit = chan + im = FIT_IM(fit) + + totpix = IM_PHYSLEN(im,1) + do i = 2, IM_NPHYSDIM(im) + totpix = totpix * IM_PHYSLEN(im,i) + + szb_pixel = pix_size[IM_PIXTYPE(im)] * SZB_CHAR + szb_real = SZ_REAL * SZB_CHAR + + call zsttbf (FIT_IO(fit), param, value) + + if (param == FSTT_FILSIZE) { + switch (FIT_PIXTYPE(fit)) { + case TY_SHORT: + if (IM_PIXTYPE(im) == TY_REAL) { + value = value + int ((totpix * SZ_SHORT * SZB_CHAR) / + 2880. + .5) * 2880 + } + case TY_UBYTE: + if (IM_PIXTYPE(im) == TY_SHORT) + value = value + int (totpix/2880. + 0.5)*2880 + else if (IM_PIXTYPE(im) == TY_REAL) + value = value + int(totpix*(szb_real-1)/2880. + 0.5) * 2880 + } + } +end + + +# FXF_CNVPX -- Convert FITS type BITPIX = 8 to SHORT or REAL depending +# on the value of BSCALE, BZERO (1, 32768 is already iraf supported as ushort +# and is not treated in here). If BITPIX=16 and BSCALE and BZERO are +# non-default then the pixels are converted to REAL. + +procedure fxf_cnvpx (im, totpix, obuf, nbytes, boffset) + +pointer im #I Image descriptor +int totpix #I Total number of pixels +char obuf[ARB] #O Output data buffer +int nbytes #I Size in bytes of the output buffer +int boffset #I Byte offset into the virtual image + +pointer sp, buf, fit, op +double bscale, bzero +int ip, nelem, pfactor +int pixtype, nb, buf_size, bzoff, nboff +int status, offset, npix +int datasizeb, pixoffb, nb_skipped + +include + +begin + fit = IM_KDES(im) + bscale = FIT_BSCALE(fit) + bzero = FIT_BZERO(fit) + + ip = FIT_PIXOFF(fit) - boffset/SZB_CHAR + if (ip <= 0) + ip = 1 + + # The beginning of the data portion in bytes. + pixoffb = (FIT_PIXOFF(fit)-1) * SZB_CHAR + 1 + + # Determine the factor to applied: size(im_pixtype)/size(fit_pixtype) + if (FIT_PIXTYPE(fit) == TY_UBYTE) { + if (IM_PIXTYPE(im) == TY_REAL) + pfactor = SZ_REAL * SZB_CHAR + else # TY_SHORT + pfactor = SZB_CHAR + datasizeb = totpix + } else if (FIT_PIXTYPE(fit) == TY_SHORT) { + pfactor = SZ_REAL / SZ_SHORT + pixtype = TY_SHORT + datasizeb = totpix * (pix_size[pixtype] * SZB_CHAR) + } else { + FIT_IOSTAT(fit) = ERR + return + } + + # We need to map the virtual image of type im_pixtype to the actual + # file of type fit_pixtype. 'nbytes' is the number of bytes to read + # from the virtual image. To find out how many fit_pixtype bytes + # we need to read from disk we need to subtract the FITS + # header size (if boffset is 1) from nbytes and then divide + # the resultant value by the convertion factor. + # We then add the size of the header if necessary. + + # Determine the offset into the pixel area. + nboff = boffset - pixoffb + if (nboff > 0) { + nelem = nboff / pfactor + offset = nelem + pixoffb + } else { + # Keep the 1st boffset. + bzoff = boffset + offset = boffset + } + + # Calculates the number of elements to convert. We keep the offset from + # the beginning of the unit (bzoff) and not from file's 1st byte. + + nelem = nbytes - (pixoffb - bzoff + 1) + nelem = nelem / pfactor + buf_size = nelem + (pixoffb - bzoff + 1) + if (buf_size*pfactor > nbytes && ip == 1) + buf_size = (nbytes - 1) / pfactor + 1 + + # Allocate space for TY_SHORT + call smark(sp) + call salloc (buf, buf_size/SZB_CHAR, TY_SHORT) + + call zardbf (FIT_IO(fit), Mems[buf], buf_size, offset) + call zawtbf (FIT_IO(fit), status) + if (status == ERR) { + FIT_IOSTAT(fit) = ERR + call sfree (sp) + return + } + + # Map the number of bytes of datatype FIT_PIXTYPE to + # IM_PIXTYPE for use in zfxfwt(). + + if (status*pfactor >= nbytes) + FIT_ZBYTES(fit) = nbytes + else + FIT_ZBYTES(fit) = status * pfactor + + nb_skipped = offset - pixoffb + if (nb_skipped <= 0) + nb = min (status + nb_skipped, datasizeb) + else + nb = min (status, datasizeb - nb_skipped) + + switch (FIT_PIXTYPE(fit)) { + case TY_UBYTE: + npix = max (0, nb) + if (IM_PIXTYPE(im) == TY_SHORT) + call achtbs (Mems[buf+ip-1], obuf[ip], npix) + else { + # Scaled from byte to REAL. + call achtbl (Mems[buf+ip-1], obuf[ip], npix) + call fxf_altmr (obuf[ip], obuf[ip], npix, bscale, bzero) + } + case TY_SHORT: + op = buf + ip - 1 + npix = max (0, nb / (pix_size[pixtype] * SZB_CHAR)) + if (BYTE_SWAP2 == YES) + call bswap2 (Mems[op], 1, Mems[op], 1, npix*SZB_CHAR) + call fxf_astmr (Mems[op], obuf[ip], npix, bscale, bzero) + } + + call sfree (sp) +end diff --git a/sys/imio/iki/iki.com b/sys/imio/iki/iki.com new file mode 100644 index 00000000..1c8ef719 --- /dev/null +++ b/sys/imio/iki/iki.com @@ -0,0 +1,10 @@ +# IKI.COM -- Image Kernel Interface global common. + +int k_nkernels, k_nextn, k_sbufused, k_defimtype, k_inherit +int k_kernel[MAX_IMEXTN], k_extn[MAX_IMEXTN], k_pattern[MAX_IMEXTN] +int k_table[LEN_KERNEL,MAX_KERNELS] +char k_kname[SZ_KNAME,MAX_KERNELS] +char k_sbuf[SZ_IKISBUF] + +common /ikicom/ k_nkernels, k_nextn, k_sbufused, k_defimtype, k_inherit, + k_kernel, k_extn, k_pattern, k_table, k_kname, k_sbuf diff --git a/sys/imio/iki/iki.h b/sys/imio/iki/iki.h new file mode 100644 index 00000000..be7a6bc0 --- /dev/null +++ b/sys/imio/iki/iki.h @@ -0,0 +1,35 @@ +# IKI.H -- Image Kernel Interface global definitions. + +define MAX_KERNELS 10 # max loaded IKI kernels +define MAX_LENEXTN 4 # max length header filename extension +define MIN_LENEXTN 2 # min length header filename extension +define MAX_IMEXTN 64 # max image extension patterns +define SZ_IKISBUF 512 # string buffer for IKI common +define SZ_KNAME 4 # internal kernel name "oif,fxf,.." + +# IMTYPE specifies the default type for new images. +define ENV_IMTYPE "imtype" +define DEF_IMTYPE "oif,noinherit" + +# IMEXTN specifies the mapping between image types and file extensions. +define ENV_IMEXTN "imextn" +define DEF_IMEXTN "oif:imh fxf:fits,fit plf:pl qpf:qp stf:hhh,??h" + +# The standard test image. +define STD_TESTIMAGE "dev$pix" +define DEF_TESTIMAGE "dev$pix.imh" + +define LEN_KERNEL 9 # length of a kernel entry in k_table +define IKI_KNAME k_kname[1,$1] # image kernel name +define IKI_OPEN k_table[1,$1] # open/create image +define IKI_CLOSE k_table[2,$1] # close image +define IKI_OPIX k_table[3,$1] # open/create pixel file +define IKI_UPDHDR k_table[4,$1] # update image header +define IKI_ACCESS k_table[5,$1] # test existence or legal type +define IKI_COPY k_table[6,$1] # fast copy of entire image +define IKI_DELETE k_table[7,$1] # delete image +define IKI_RENAME k_table[8,$1] # rename image +define IKI_FLAGS k_table[9,$1] # driver flags + +# IKI driver flags. +define IKF_NOCREATE 1 # kernel cannot create new images diff --git a/sys/imio/iki/ikiaccess.x b/sys/imio/iki/ikiaccess.x new file mode 100644 index 00000000..83736b4f --- /dev/null +++ b/sys/imio/iki/ikiaccess.x @@ -0,0 +1,128 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "iki.h" + +# IKI_ACCESS -- Determine if the named image exists, and if so, return the +# the index of the IKI kernel to be used to access the image, else return 0 if +# the named image is not found. If multiple images exist with the same name +# (e.g. but with different image types) then ERR is returned. An NEW_IMAGE +# access mode may be specified to associate an extension with an image kernel +# without testing for the existence of an image. If the input image name did +# not specify an extension or what appeared to be an extension was just a . +# delimited field, we will patch up the ROOT and EXTN strings to the real +# values. + +int procedure iki_access (image, root, extn, acmode) + +char image[ARB] #I image/group name +char root[ARB] #O image/group file name +char extn[ARB] #O image/group file extension +int acmode + +bool first_time +int i, k, status, op +pointer sp, osroot, fname, textn, fextn, ip +data first_time /true/ + +bool fnullfile() +int gstrcpy(), strlen() +errchk fpathname, syserrs +include "iki.com" + +begin + call smark (sp) + call salloc (osroot, SZ_PATHNAME, TY_CHAR) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (textn, MAX_LENEXTN, TY_CHAR) + call salloc (fextn, MAX_LENEXTN, TY_CHAR) + + # The first call makes sure the IKI kernels are loaded into the kernel + # table. + + if (first_time) { + call iki_init() + first_time = false + } + + call iki_parse (image, root, extn) + if (fnullfile (root)) { + call sfree (sp) + return (1) + } + + repeat { + # Convert to absolute pathname to render names like file + # and ./file equivalent. Add a dummy file extension first + # to cause escape sequence encoding of any .DDDD etc. files + # which may be part of the root image name. + + op = gstrcpy (root, Memc[fname], SZ_PATHNAME) + call strcpy (".x", Memc[fname+op], SZ_PATHNAME-op+1) + call fpathname (Memc[fname], Memc[osroot], SZ_PATHNAME) + Memc[osroot+strlen(Memc[osroot])-2] = EOS + + # Escape any $ in the pathname since we are still in VOS land. + op = 1 + for (ip=osroot; Memc[ip] != EOS; ip=ip+1) { + if (Memc[ip] == '$' || Memc[ip] == '[') { + root[op] = '\\' + op = op + 1 + } + root[op] = Memc[ip] + op = op + 1 + } + + root[op] = EOS + + # Select an image kernel by calling the access function in each + # loaded kernel until somebody claims the image. If multiple + # kernels claim the image the image specification (name) is + # ambiguous and we don't know which image was intended, an error. + # Note that in the case of a new image, the access function + # tests only the legality of the extn. + + k = 0 + for (i=1; i <= k_nkernels; i=i+1) { + call strcpy (extn, Memc[textn], MAX_LENEXTN) + call zcall5 (IKI_ACCESS(i), i,root,Memc[textn],acmode,status) + + if (status == YES) { + if (k == 0) { + # Stop on the first access if an explicit extension + # was given. + + k = i + call strcpy (Memc[textn], Memc[fextn], MAX_LENEXTN) + if (extn[1] != EOS) + break + + } else { + # The image name is ambiguous. + call sfree (sp) + return (ERR) + } + } + } + + # Valid image using kernel K. + if (k != 0) { + call strcpy (Memc[fextn], extn, MAX_LENEXTN) + call sfree (sp) + return (k) + } + + # If the search failed and an extension was given, maybe what + # we thought was an extension was really just part of the root + # filename. Try again with the extn folded into the root. + + if (status == NO && extn[1] != EOS) { + call strcpy (image, root, SZ_PATHNAME) + extn[1] = EOS + } else + break + } + + call sfree (sp) + return (0) +end diff --git a/sys/imio/iki/ikiclose.x b/sys/imio/iki/ikiclose.x new file mode 100644 index 00000000..e4b2ced9 --- /dev/null +++ b/sys/imio/iki/ikiclose.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "iki.h" + +# IKI_CLOSE -- Physically close an image opened under the IKI. It is not +# necessary to update the image header or flush any pixel data, as IMIO will +# already have performed those functions. + +procedure iki_close (im) + +pointer im #I image descriptor + +int status +include "iki.com" + +begin + iferr (call zcall2 (IKI_CLOSE(IM_KERNEL(im)), im, status)) + status = ERR + if (status == ERR) + call syserrs (SYS_IKICLOSE, IM_NAME(im)) +end diff --git a/sys/imio/iki/ikicopy.x b/sys/imio/iki/ikicopy.x new file mode 100644 index 00000000..31df1970 --- /dev/null +++ b/sys/imio/iki/ikicopy.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "iki.h" + +# IKI_COPY -- Fast copy of an entire image or group of images. This function +# is provided at the IKI level since the kernel has explicit knowledge of the +# storage format and hence may be able to copy the image by means much simpler +# and faster way than those available to the high level software. + +procedure iki_copy (old, new) + +char old[ARB] #I name of old image +char new[ARB] #I name of new image + +int k, n, status +pointer sp, old_root, old_extn, new_root, new_extn +int iki_access() +bool streq() +errchk syserrs + +include "iki.com" + +begin + call smark (sp) + call salloc (old_root, SZ_PATHNAME, TY_CHAR) + call salloc (old_extn, MAX_LENEXTN, TY_CHAR) + call salloc (new_root, SZ_PATHNAME, TY_CHAR) + call salloc (new_extn, MAX_LENEXTN, TY_CHAR) + + # Verify that the old image exists and determine its type. + k = iki_access (old, Memc[old_root], Memc[old_extn], READ_ONLY) + if (k < 0) + call syserrs (SYS_IKIAMBIG, old) + else if (k == 0) + call syserrs (SYS_IKIIMNF, old) + + # Make sure we will not be clobbering an existing image. Ignore + # attempts to rename an image onto itself. + + n = iki_access (new, Memc[new_root], Memc[new_extn], 0) + if (n > 0) { + if (streq (Memc[old_root], Memc[new_root])) + if (streq (Memc[old_extn], Memc[new_extn])) { + call sfree (sp) + return + } + call syserrs (SYS_IKICLOB, new) + } else { + # New name is new root plus legal extn for old image. + call iki_parse (new, Memc[new_root], Memc[new_extn]) + call strcpy (Memc[old_extn], Memc[new_extn], MAX_LENEXTN) + } + + # Copy the image. + call zcall6 (IKI_COPY(k), k, Memc[old_root], Memc[old_extn], + Memc[new_root], Memc[new_extn], status) + if (status == ERR) + call syserrs (SYS_IKICOPY, old) + + call sfree (sp) +end diff --git a/sys/imio/iki/ikidelete.x b/sys/imio/iki/ikidelete.x new file mode 100644 index 00000000..a172980b --- /dev/null +++ b/sys/imio/iki/ikidelete.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "iki.h" + +# IKI_DELETE -- Delete an image or group of images. + +procedure iki_delete (image) + +char image[ARB] #I name of image + +int k, status +pointer sp, root, extn +int iki_access() +bool fnullfile() + +errchk syserrs +include "iki.com" + +begin + if (fnullfile (image)) + return + + call smark (sp) + call salloc (root, SZ_PATHNAME, TY_CHAR) + call salloc (extn, MAX_LENEXTN, TY_CHAR) + + # Verify that the image exists and determine its type. + k = iki_access (image, Memc[root], Memc[extn], 0) + if (k < 0) + call syserrs (SYS_IKIAMBIG, image) + else if (k == 0) + call syserrs (SYS_IKIIMNF, image) + + # Delete the image. + call zcall4 (IKI_DELETE(k), k, Memc[root], Memc[extn], status) + if (status == ERR) + call syserrs (SYS_IKIDEL, image) + + call sfree (sp) +end diff --git a/sys/imio/iki/ikiextn.x b/sys/imio/iki/ikiextn.x new file mode 100644 index 00000000..a5f2aa12 --- /dev/null +++ b/sys/imio/iki/ikiextn.x @@ -0,0 +1,372 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "iki.h" + +# IKIEXTN.X -- Image extension handling. This package is used to map image +# file extensions to image types and vice versa. +# +# iki_extninit (imtype, def_imtype, imextn, def_imextn) +# status = iki_validextn (kernel, extn) +# status = iki_getextn (kernel, index, extn, maxch) +# value = iki_getpar (param) +# +# iki_extninit initializes the image extension handling package. This parses +# the lists of extensions and patterns and builds an internal descriptor which +# will be used by the other routines for extension handling. iki_validextn +# tests whether a given extension is valid for a particular image kernel +# (type of image). iki_getextn is used with an index argument to get a list +# of the extensions for a particular image type. iki_getpar queries the value +# of IKI global parameters. + +define SZ_IMTYPE 128 +define SZ_IMEXTN 1024 + + +# IKI_EXTNINIT -- Initialize the image extension handling package. This is +# typically done once when IKI is first initialized. Changes to the image +# typing environment made subsequently have no effect unless the package is +# reinitialized. + +int procedure iki_extninit (env_imtype, def_imtype, env_imextn, def_imextn) + +char env_imtype[ARB] #I imtype environment variable +char def_imtype[ARB] #I default imtype value string +char env_imextn[ARB] #I imextn environment variable +char def_imextn[ARB] #I default imextn value string + +int kset[MAX_KERNELS] +pointer sp, ip, ip_save, imtype, imextn, strval +int op, delim, status, nchars, i, j, kernel +int envfind(), iki_getfield(), gstrcpy(), iki_validextn() +bool streq(), envgetb() + +include "iki.com" + +begin + call smark (sp) + call salloc (imtype, SZ_IMTYPE, TY_CHAR) + call salloc (imextn, SZ_IMEXTN, TY_CHAR) + call salloc (strval, SZ_FNAME, TY_CHAR) + + status = OK + + # Get the imtype string. The value of the env_imtype variable is used + # if the variable is found, otherwise the default is used. + + Memc[imtype] = EOS + if (env_imtype[1] != EOS) + if (envfind (env_imtype, Memc[imtype], SZ_IMTYPE) <= 0) + Memc[imtype] = EOS + if (Memc[imtype] == EOS) + call strcpy (def_imtype, Memc[imtype], SZ_IMTYPE) + + # Get the imextn string. The value of the env_imextn variable is used + # if the variable is found, otherwise the default is used. + + Memc[imextn] = EOS + if (env_imextn[1] != EOS) + if (envfind (env_imextn, Memc[imextn], SZ_IMEXTN) <= 0) + Memc[imextn] = EOS + if (Memc[imextn] == EOS) + call strcpy (def_imextn, Memc[imextn], SZ_IMEXTN) + + # Process imextn. This specifies the set of valid extensions for + # each image type. This must be done before processing imtype below, + # since iki_validextn can be used when processing imtype. The imextn + # string is of the form ":[,...] ..." where + # is the IKI kernel name (k_kname) and is a regular + # expression to be used to test for a matching file extension. + # For example, imextn = "oif:imh stf:hhh,??h fits:,fits,fit". + + k_nextn = 0 + k_sbufused = 0 + call aclri (kset, MAX_KERNELS) + + # Process the user extension string first followed by the builtin + # defaults. Anything given in the user string takes precedence + # while anything omitted uses the builtin defaults instead (if there + # is no user imextn this processes the default string twice). + + do i = 1, 2 { + if (i > 1) + call strcpy (def_imextn, Memc[imextn], SZ_IMEXTN) + + ip = imextn + while (Memc[ip] != EOS && IS_WHITE(Memc[ip])) + ip = ip + 1 + + repeat { + # Get the kernel name. + if (iki_getfield (ip, Memc[strval], SZ_FNAME, delim) <= 0) + break + call strlwr (Memc[strval]) + if (delim != ':') { + status = ERR + break + } + + # Lookup kernel. + kernel = 0 + do j = 1, k_nkernels { + if (streq (Memc[strval], k_kname[1,j])) { + kernel = j + break + } + } + if (kernel <= 0) { + status = ERR + break + } + + # Process the list of extension patterns. + op = k_sbufused + 1 + ip_save = ip + + while (iki_getfield (ip, Memc[strval], SZ_FNAME, delim) > 0) { + # call strlwr (Memc[strval]) + + # Skip it if we already have something for this kernel. + if (kset[kernel] == 0) { + # Get a new extension descriptor. + if (k_nextn >= MAX_IMEXTN) { + status = ERR + break + } else + k_nextn = k_nextn + 1 + + # Save the kernel index associated with this extension. + k_kernel[k_nextn] = kernel + + # Save the extension string. + k_extn[k_nextn] = op + nchars = gstrcpy(Memc[strval],k_sbuf[op],SZ_IKISBUF-op) + op = op + nchars + 1 + + # Save the strmatch pattern for the extension. + k_pattern[k_nextn] = op + k_sbuf[op] = '^'; op = op + 1 + nchars = gstrcpy(Memc[strval],k_sbuf[op],SZ_IKISBUF-op) + op = op + nchars + 1 + } + + ip_save = ip + if (delim != ',') + break + } + + kset[kernel] = 1 + k_sbufused = op - 1 + + } until (Memc[ip] == EOS) + } + + # Process imtype. This sets the default image type for new images. + # For example, imtype = "oif,inherit" would create OIF (.imh) images + # by default, inheriting the old image type if a newcopy image is + # being written. + + k_defimtype = 1 + k_inherit = NO + ip = imtype + kernel = 0 + + while (iki_getfield (ip, Memc[strval], SZ_FNAME, delim) > 0) { + call strlwr (Memc[strval]) + + # Check for the inherit/noinherit keywords. + if (streq (Memc[strval], "inherit")) { + k_inherit = YES + next + } + if (streq (Memc[strval], "noinherit")) { + k_inherit = NO + next + } + + # Scan the kernels to see if we have a kernel name. + if (kernel <= 0) + do i = 1, k_nkernels + if (streq (Memc[strval], k_kname[1,i])) { + kernel = i + break + } + + # Check for a valid imagefile extension. + if (kernel <= 0) + kernel = iki_validextn (0, Memc[strval]) + } + + if (kernel <= 0) + status = ERR + else + k_defimtype = kernel + + if (envgetb ("ikidebug")) + call iki_debug ("IKI debug:", STDERR, 0) + + call sfree (sp) + return (status) +end + + +# IKI_VALIDEXTN -- Determine if the given imagefile extension is valid for +# the given image kernel (image type). If kernel=0 the extensions for all +# kernels are examined. If a valid match is found the kernel index is +# returned as the function value, otherwise 0 is returned. + +int procedure iki_validextn (kernel, extn) + +int kernel #I kernel index, zero for all kernels +char extn[ARB] #I extension to be tested + +int i, ip +int strmatch() +include "iki.com" + +begin + do i = 1, k_nextn + if (kernel == 0 || k_kernel[i] == kernel) { + ip = strmatch (extn, k_sbuf[k_pattern[i]]) + if (ip > 0 && extn[ip] == EOS) + return (k_kernel[i]) + } + + return (0) +end + + +# IKI_GETEXTN -- Get an entry from the list of valid extensions (actually +# extension patterns) for the given image kernel. If kernel=0 all entries +# are returned. The kernel index for the output extension is returned as +# the function value. ERR is returned if the requested extension does not +# exist. + +int procedure iki_getextn (kernel, index, extn, maxch) + +int kernel #I kernel index, zero for all kernels +int index #I extension number (1 indexed) +char extn[ARB] #O extension +int maxch #I max chars out + +int i, n +include "iki.com" + +begin + n = 0 + do i = 1, k_nextn + if (kernel == 0 || k_kernel[i] == kernel) { + n = n + 1 + if (index == n) { + call strcpy (k_sbuf[k_extn[i]], extn, maxch) + return (k_kernel[i]) + } + } + + return (ERR) +end + + +# IKI_GETPAR -- Return the value of an IKI global parameter (integer valued). + +int procedure iki_getpar (param) + +char param[ARB] #I parameter name + +bool streq() +include "iki.com" + +begin + if (streq (param, "inherit")) + return (k_inherit) + else if (streq (param, "defimtype")) + return (k_defimtype) +end + + +# IKI_GETFIELD -- Get the next field from a punctuation or whitespace +# delimited list. The length of the field is returned as the function value. +# EOF is returned at the end of the list. Zero can be returned if a field +# is zero length, e.g. in "foo,,foo" the second field is zero length. + +int procedure iki_getfield (ip, outstr, maxch, delim) + +pointer ip #U string pointer +char outstr[ARB] #O receives string +int maxch #I max chars out +int delim #O delimiter char + +int op, ch + +begin + # Skip any leading whitespace. + while (Memc[ip] != EOS && IS_WHITE(Memc[ip])) + ip = ip + 1 + + # Check for end of list. + if (Memc[ip] == EOS || Memc[ip] == '\n') + return (EOF) + + op = 1 + for (ch=Memc[ip]; ch != EOS && !IS_WHITE(ch); ch=Memc[ip]) { + if (ch == ',' || ch == ':' || ch == ';') + break + else { + outstr[op] = ch + op = op + 1 + } + ip = ip + 1 + } + + delim = ch + if (delim != EOS) + ip = ip + 1 + + outstr[op] = EOS + return (op - 1) +end + + +# IKI_DEBUG -- Print debug information on the IKI internal data structures. + +procedure iki_debug (str, fd, flags) + +char str[ARB] #I title string +int fd #I output file +int flags #I (not used) + +int i +include "iki.com" + +begin + # Print global variables. + call fprintf (fd, "%s nkernels=%d sbufused=%d deftype=%d ") + call pargstr (str) + call pargi (k_nkernels) + call pargi (k_sbufused) + call pargi (k_defimtype) + call fprintf (fd, "inherit=%d nextn=%d\n") + call pargi (k_inherit) + call pargi (k_nextn) + + # List the installed kernels. + call fprintf (fd, "installed kernels ") + do i = 1, k_nkernels { + call fprintf (fd, "%s=%d ") + call pargstr (k_kname[1,i]) + call pargi (i) + } + call fprintf (fd, "\n") + + # Print the extension table. + do i = 1, k_nextn { + call fprintf (fd, "%6s %d (%s) %s\n") + call pargstr (k_sbuf[k_extn[i]]) + call pargi (k_kernel[i]) + call pargstr (k_kname[1,k_kernel[i]]) + call pargstr (k_sbuf[k_pattern[i]]) + } + + call flush (fd) +end diff --git a/sys/imio/iki/ikiinit.x b/sys/imio/iki/ikiinit.x new file mode 100644 index 00000000..41de76b6 --- /dev/null +++ b/sys/imio/iki/ikiinit.x @@ -0,0 +1,58 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "iki.h" + +# IKI_INIT -- Initialize the IKI kernel table, i.e., load all the standard +# kernels into the table. Additional kernels may be dynamically added at +# run time for special applications. + +procedure iki_init() + +extern oif_open(), oif_close(), oif_opix(), oif_updhdr(), + oif_access(), oif_copy(), oif_delete(), oif_rename() +extern fxf_open(), fxf_close(), fxf_opix(), fxf_updhdr(), + fxf_access(), fxf_copy(), fxf_delete(), fxf_rename() +extern plf_open(), plf_close(), plf_null(), plf_updhdr(), + plf_access(), plf_copy(), plf_delete(), plf_rename() +extern qpf_open(), qpf_close(), qpf_opix(), qpf_updhdr(), + qpf_access(), qpf_copy(), qpf_delete(), qpf_rename() +extern stf_open(), stf_close(), stf_opix(), stf_updhdr(), + stf_access(), stf_copy(), stf_delete(), stf_rname() + +bool first_time +data first_time /true/ +int iki_extninit() +include "iki.com" + +begin + if (!first_time) + return + + k_nkernels = 0 + + # Load the original IRAF format (OIF) kernel. + call iki_lddriver ("oif", oif_open, oif_close, oif_opix, oif_updhdr, + oif_access, oif_copy, oif_delete, oif_rename, 0) + + # Load the FITS image kernel (FXF). + call iki_lddriver ("fxf", fxf_open, fxf_close, fxf_opix, fxf_updhdr, + fxf_access, fxf_copy, fxf_delete, fxf_rename, 0) + + # Load the PLIO mask image mini-kernel (PLF - not a full kernel). + call iki_lddriver ("plf", plf_open, plf_close, plf_null, plf_updhdr, + plf_access, plf_copy, plf_delete, plf_rename, 0) + + # Load the QPOE photon image kernel (QPF). + call iki_lddriver ("qpf", qpf_open, qpf_close, qpf_opix, qpf_updhdr, + qpf_access, qpf_copy, qpf_delete, qpf_rename, IKF_NOCREATE) + + # Load the SDAS GEIS format (STF) kernel. + call iki_lddriver ("stf", stf_open, stf_close, stf_opix, stf_updhdr, + stf_access, stf_copy, stf_delete, stf_rname, 0) + + # Initialize the extension-based image typing mechanism. + if (iki_extninit (ENV_IMTYPE, DEF_IMTYPE, ENV_IMEXTN, DEF_IMEXTN) < 0) + ; + + first_time = false +end diff --git a/sys/imio/iki/ikildd.x b/sys/imio/iki/ikildd.x new file mode 100644 index 00000000..256e7e70 --- /dev/null +++ b/sys/imio/iki/ikildd.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "iki.h" + +# IKI_LDDRIVER -- Load an IKI kernel into the kernel table, i.e., make a new +# kernel entry in the table containing the entry point address of each of the +# kernel procedures. + +procedure iki_lddriver (kname, ex_open, ex_close, ex_opix, ex_updhdr, + ex_access, ex_copy, ex_delete, ex_rename, flags) + +char kname[ARB] +extern ex_open(), ex_close(), ex_opix(), ex_updhdr() +extern ex_access(), ex_copy(), ex_delete(), ex_rename() +int locpr() +int flags + +include "iki.com" +errchk syserr + +begin + if (k_nkernels + 1 > MAX_KERNELS) + call syserr (SYS_IKIKTBLOVFL) + else + k_nkernels = k_nkernels + 1 + + call strcpy (kname, IKI_KNAME(k_nkernels), SZ_KNAME) + IKI_OPEN(k_nkernels) = locpr (ex_open) + IKI_CLOSE(k_nkernels) = locpr (ex_close) + IKI_OPIX(k_nkernels) = locpr (ex_opix) + IKI_UPDHDR(k_nkernels) = locpr (ex_updhdr) + IKI_ACCESS(k_nkernels) = locpr (ex_access) + IKI_COPY(k_nkernels) = locpr (ex_copy) + IKI_DELETE(k_nkernels) = locpr (ex_delete) + IKI_RENAME(k_nkernels) = locpr (ex_rename) + IKI_FLAGS(k_nkernels) = flags +end diff --git a/sys/imio/iki/ikimkfn.x b/sys/imio/iki/ikimkfn.x new file mode 100644 index 00000000..a224f728 --- /dev/null +++ b/sys/imio/iki/ikimkfn.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "iki.h" + +# IKI_MKFNAME -- Manufacture a filename from the root and extension fields +# given. + +procedure iki_mkfname (root, extn, fname, maxch) + +char root[ARB] #I root filename +char extn[ARB] #I filename extension +char fname[maxch] #O output filename +int maxch #I max chars out + +int op +int gstrcpy() +bool fnullfile() + +begin + op = gstrcpy (root, fname, maxch) + 1 + if (extn[1] != EOS && !fnullfile (root)) { + fname[op] = '.' + op = op + 1 + call strcpy (extn, fname[op], maxch-op+1) + } +end diff --git a/sys/imio/iki/ikiopen.x b/sys/imio/iki/ikiopen.x new file mode 100644 index 00000000..f60a672d --- /dev/null +++ b/sys/imio/iki/ikiopen.x @@ -0,0 +1,153 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "iki.h" + +# IKI_OPEN -- Open or create an image. If opening an existing image, determine +# the type of image and open it with the corresponding kernel. If creating a +# new image, the value of the environment variable IMTYPE determines the type +# of image to be created, i.e., the kernel to be used to open the image. If +# opening a new copy image, create an image of the same type as the existing +# image. + +procedure iki_open (n_im, image, ksection, cl_index, cl_size, acmode, o_im) + +pointer n_im #I descriptor of new image (to be filled in) +char image[ARB] #I name of image or cl_index to be opened +char ksection[ARB] #I information to be passed on to kernel +int cl_index #I index of image within cl_index +int cl_size #I number of images in cl_index +int acmode #I access mode +pointer o_im #I existing image descriptor, if new_copy + +bool inherit +pointer sp, root, extn, textn, fextn +int status, clmode, i, k +errchk syserrs, zcalla +include "iki.com" + +begin + call smark (sp) + call salloc (root, SZ_PATHNAME, TY_CHAR) + call salloc (extn, MAX_LENEXTN, TY_CHAR) + call salloc (textn, MAX_LENEXTN, TY_CHAR) + call salloc (fextn, MAX_LENEXTN, TY_CHAR) + + # Compute the access mode for the ACCESS test, below. If opening an + # existing image, all we want to do here is test for the existence of + # the image. If opening a new image, use new image mode. + + if ((acmode == NEW_IMAGE || acmode == NEW_COPY)) + clmode = NEW_IMAGE + else + clmode = 0 + + # Parse the image name into the root and extn fields. + call iki_parse (image, Memc[root], Memc[extn]) + + # If we are opening a new image and an explicit extension is given + # this determines the type of image to be created. Otherwise if we + # are opening a new copy image and type inheritance is enabled, the + # new image will be the same type as the old one. Otherwise (new + # image, type not specified or inherited) the default image type + # specified by the IMTYPE mechanism is used. If opening an existing + # image the access method of each image kernel is called until a + # kernel recognizes the image. + + repeat { + # Is type inheritance permitted? + inherit = (k_inherit == YES) + if (inherit && acmode == NEW_COPY) + inherit = (and (IKI_FLAGS(IM_KERNEL(o_im)), IKF_NOCREATE) == 0) + + # Select the kernel to be used. + if (acmode == NEW_COPY && Memc[extn] == EOS && inherit) { + # Inherit the same type as an existing image. + k = IM_KERNEL(o_im) + break + + } else if (clmode == NEW_IMAGE && Memc[extn] == EOS) { + # Use the default type for new images. + k = k_defimtype + break + + } else { + # Select an image kernel by calling the access function in each + # loaded kernel until somebody claims the image. In the case + # of a new image, the access function tests only the legality + # of the extn. If no extn is given but the imagefile has an + # extension, the access procedure will fill in the extn field. + + k = 0 + for (i=1; i <= k_nkernels; i=i+1) { + call strcpy (Memc[extn], Memc[textn], MAX_LENEXTN) + call zcall5 (IKI_ACCESS(i), i, Memc[root], Memc[textn], + clmode, status) + + if (status == YES) { + if (k == 0) { + # Stop on the first match if an explicit extension + # was given. + + k = i + call strcpy (Memc[textn], Memc[fextn], MAX_LENEXTN) + if (Memc[extn] != EOS) + break + + } else if (Memc[extn] == EOS) { + # If no extension was given and we match multiple + # files then we have an ambiguous name and k=ERR. + + k = ERR + break + } + } + } + + # Update the selected extn field. + if (k > 0) + call strcpy (Memc[fextn], Memc[extn], MAX_LENEXTN) + + # If the search failed and an extension was given, maybe what + # we thought was an extension was really just part of the root + # filename. Try again with the extn folded into the root. + + if (k == 0 && Memc[extn] != EOS) { + call strcpy (image, Memc[root], SZ_PATHNAME) + Memc[extn] = EOS + } else + break + } + } + + # The image name is ambiguous; we don't know which image to open. + # This can only happen when opening an existing image and multiple + # images exist matching the name given. It is permissible to create + # multiple images with the same name but different types. + + if (k == ERR) + call syserrs (SYS_IKIAMBIG, IM_NAME(n_im)) + + # Illegal image type or image does not exist. + if (k == 0) { + if (acmode == NEW_IMAGE || acmode == NEW_COPY) + call syserrs (SYS_IKIEXTN, IM_NAME(n_im)) + else + call syserrs (SYS_IKIOPEN, IM_NAME(n_im)) + } + + # Set the image kernel (format) to be used. + IM_KERNEL(n_im) = k + + # Open/create the image. Save the kernel index in the image header + # so that subsequent IKI routines know which kernel to use. + + call zcalla (IKI_OPEN(k), k, n_im, o_im, Memc[root], Memc[extn], + ksection, cl_index, cl_size, acmode, status) + if (status == ERR) + call syserrs (SYS_IKIOPEN, IM_NAME(n_im)) + + call sfree (sp) +end diff --git a/sys/imio/iki/ikiopix.x b/sys/imio/iki/ikiopix.x new file mode 100644 index 00000000..33b3a9bc --- /dev/null +++ b/sys/imio/iki/ikiopix.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "iki.h" + +# IKI_OPIX -- Open or create the pixel storage file, if any. We are called by +# IMIO when i/o is first done to the image. In the case of a new image, IMIO +# will already have set up the IM_NDIM and IM_LEN fields of the image header. + +procedure iki_opix (im) + +pointer im #I image descriptor +int status +include "iki.com" + +begin + iferr (call zcall2 (IKI_OPIX(IM_KERNEL(im)), im, status)) + status = ERR + if (status == ERR) + call syserrs (SYS_IKIOPIX, IM_NAME(im)) +end diff --git a/sys/imio/iki/ikiparse.x b/sys/imio/iki/ikiparse.x new file mode 100644 index 00000000..3ffb7d6c --- /dev/null +++ b/sys/imio/iki/ikiparse.x @@ -0,0 +1,85 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "iki.h" + +# IKI_PARSE -- Parse an image name into the root pathname and filename +# extension, if any. Only the known image type extensions are recognized +# as extensions, hence this routine cannot be used to parse general filenames. + +procedure iki_parse (image, root, extn) + +char image[ARB] #I input image name +char root[SZ_PATHNAME] #U output root pathname +char extn[MAX_LENEXTN] #O output extension + +pointer sp, imname +int ip, op, dot +int strlen(), iki_validextn() +bool streq() + +begin + call smark (sp) + call salloc (imname, SZ_PATHNAME, TY_CHAR) + + dot = 0 + op = 1 + + # The following is a backwards-compatibility kludge. If the image + # name we are given is the canonical standard test image STD_TESTIMAGE + # ("dev$pix") replace the name with the fully qualified name + # DEF_TESTIMAGE. This is necessary to avoid ambiguous image name + # errors due to pix.imh and pix.hhh being in the same directory; these + # are well known names, neither of which can easily be changed. + + if (streq (image, STD_TESTIMAGE)) + call strcpy (DEF_TESTIMAGE, Memc[imname], SZ_PATHNAME) + else + call strcpy (image, Memc[imname], SZ_PATHNAME) + + # Copy image name to root and mark the position of the last dot. + for (ip=1; Memc[imname+ip-1] != EOS; ip=ip+1) { + root[op] = Memc[imname+ip-1] + if (root[op] == '.') + dot = op + op = op + 1 + } + + root[op] = EOS + extn[1] = EOS + + # Reject . delimited fields longer than the maximum extension length. + if (op - dot - 1 > MAX_LENEXTN) + dot = NULL + + # If found extension, chop the root and fill in the extn field. + # If no extension found, we are all done. + + if (dot == NULL) { + call sfree (sp) + return + } else { + root[dot] = EOS + call strcpy (root[dot+1], extn, MAX_LENEXTN) + } + + # Search the list of legal imagefile extensions. If the extension + # given is not found in the list, tack it back onto the root and + # return a null extension. This is necessary if we are to allow + # dot delimited fields within image names without requiring the + # user to supply the image type extension. For example, "im.c" + # and "im.c.imh" must refer to the same image - ".c" is part of + # the image name, not an image type extension. + + if (strlen(extn) >= MIN_LENEXTN) + if (iki_validextn (0, extn) > 0) { + call sfree (sp) + return + } + + # Not a legal image header extension. Restore the extn field to the + # root and null the extn. + + root[dot] = '.' + extn[1] = EOS + call sfree (sp) +end diff --git a/sys/imio/iki/ikirename.x b/sys/imio/iki/ikirename.x new file mode 100644 index 00000000..cdeff731 --- /dev/null +++ b/sys/imio/iki/ikirename.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "iki.h" + +# IKI_RENAME -- Rename an entire image or group of images. + +procedure iki_rename (old, new) + +char old[ARB] #I old name of image +char new[ARB] #I new name of image + +int k, n, status +pointer new_root, new_extn +pointer sp, old_root, old_extn + +bool streq() +int iki_access() +errchk syserrs +include "iki.com" + +begin + call smark (sp) + call salloc (old_root, SZ_PATHNAME, TY_CHAR) + call salloc (old_extn, MAX_LENEXTN, TY_CHAR) + call salloc (new_root, SZ_PATHNAME, TY_CHAR) + call salloc (new_extn, MAX_LENEXTN, TY_CHAR) + + # Verify that the old image exists and determine its type. + k = iki_access (old, Memc[old_root], Memc[old_extn], 0) + if (k < 0) + call syserrs (SYS_IKIAMBIG, old) + else if (k == 0) + call syserrs (SYS_IKIIMNF, old) + + # Determine if the old image exists. New name is new root plus + # legal extn for old image. + + n = iki_access (new, Memc[new_root], Memc[new_extn], 0) + if (n <= 0) + call iki_parse (new, Memc[new_root], Memc[new_extn]) + + # If an extension was given for the new image, verify that it is a + # valid extension for an image of the same type as the old image. + # We cannot change the image type in a rename operation. + + if (Memc[new_extn] != EOS) { + call zcall5 (IKI_ACCESS(k), k, Memc[new_root], Memc[new_extn], + NEW_FILE, status) + if (status == NO) + call strcpy (Memc[old_extn], Memc[new_extn], MAX_LENEXTN) + } else + call strcpy (Memc[old_extn], Memc[new_extn], MAX_LENEXTN) + + # Make sure we will not be clobbering an existing image. Renaming + # an image onto itself is ok; what it means to do this is up to + # the specific image kernel. + + if (n > 0) { + if (streq (Memc[old_root], Memc[new_root]) && + streq (Memc[old_extn], Memc[new_extn])) + ; # rename x -> x; let kernel decide what to do + else + call syserrs (SYS_IKICLOB, new) + } + + # Rename the image. + call zcall6 (IKI_RENAME(k), k, Memc[old_root], Memc[old_extn], + Memc[new_root], Memc[new_extn], status) + if (status == ERR) + call syserrs (SYS_IKIRENAME, old) + + call sfree (sp) +end diff --git a/sys/imio/iki/ikiupdhdr.x b/sys/imio/iki/ikiupdhdr.x new file mode 100644 index 00000000..f7ad22b8 --- /dev/null +++ b/sys/imio/iki/ikiupdhdr.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "iki.h" + +# IKI_UPDHDR -- Update the image header. + +procedure iki_updhdr (im) + +pointer im #I image descriptor + +int status +include "iki.com" + +begin + iferr (call zcall2 (IKI_UPDHDR(IM_KERNEL(im)), im, status)) + status = ERR + if (status == ERR) + call syserrs (SYS_IKIUPDHDR, IM_NAME(im)) +end diff --git a/sys/imio/iki/mkpkg b/sys/imio/iki/mkpkg new file mode 100644 index 00000000..cd8663e9 --- /dev/null +++ b/sys/imio/iki/mkpkg @@ -0,0 +1,28 @@ +# Make the Image Kernel Interface. + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + @oif # Original IRAF format + @fxf # FITS extension format + @plf # PLIO mask image mini-kernel (partial) + @qpf # QPOE photon image kernel + @stf # ST SDAS/GEIS format + + ikiaccess.x iki.com iki.h + ikiclose.x iki.com iki.h + ikicopy.x iki.com iki.h + ikidelete.x iki.com iki.h + ikiextn.x iki.com iki.h + ikiinit.x iki.com iki.h + ikildd.x iki.com iki.h + ikimkfn.x iki.h + ikiopen.x iki.com iki.h + ikiopix.x iki.com iki.h + ikiparse.x iki.h + ikirename.x iki.com iki.h + ikiupdhdr.x iki.com iki.h + ; diff --git a/sys/imio/iki/oif/README b/sys/imio/iki/oif/README new file mode 100644 index 00000000..01e30678 --- /dev/null +++ b/sys/imio/iki/oif/README @@ -0,0 +1 @@ +IKI/OIF -- IKI kernel for the old (original) IRAF image format. diff --git a/sys/imio/iki/oif/imhv1.h b/sys/imio/iki/oif/imhv1.h new file mode 100644 index 00000000..a9a37874 --- /dev/null +++ b/sys/imio/iki/oif/imhv1.h @@ -0,0 +1,75 @@ +# IMHV1.H -- Version 1 of the OIF binary file header (April 1988). + +define V1_MAGIC "imhdr" # file identification tag +define V1_PMAGIC "impix" # file identification tag +define V1_VERSION 1 # header version number + +define SZ_V1IMPIXFILE 79 # name of pixel storage file +define SZ_V1IMHDRFILE 79 # name of header storage file +define SZ_V1IMTITLE 79 # image title string +define SZ_V1IMHIST 511 # image history record +define SZ_V1BUNIT 9 # brightness units string +define SZ_V1CTYPE 9 # coord axes units string + +# The IMIO image header structure. + +# Parameters. +define LEN_V1IMHDR 513 # length of std header +define LEN_V1PIXHDR 183 # length of pixel file header +define V1U LEN_V1IMHDR # offset to user fields +define IM_V1USERAREA (P2C($1+V1U)) # user area (database) + +# Disk resident header. +define IM_V1MAGIC Memi[$1] # contains the string "imhdr" +define IM_V1HDRLEN Memi[$1+3] # length of image header +define IM_V1PIXTYPE Memi[$1+4] # datatype of the pixels +define IM_V1NDIM Memi[$1+5] # number of dimensions +define IM_V1LEN Meml[$1+$2+6-1] # length of the dimensions +define IM_V1PHYSLEN Meml[$1+$2+13-1] # physical length (as stored) +define IM_V1SSMTYPE Meml[$1+20] # type of subscript mapping +define IM_V1LUTOFF Meml[$1+21] # offset to subscript map luts +define IM_V1PIXOFF Meml[$1+22] # offset of the pixels +define IM_V1HGMOFF Meml[$1+23] # offset of hgm pixels +define IM_V1BLIST Meml[$1+24] # offset of bad pixel list +define IM_V1SZBLIST Meml[$1+25] # size of bad pixel list +define IM_V1NBPIX Meml[$1+26] # number of bad pixels +define IM_V1CTIME Meml[$1+27] # time of image creation +define IM_V1MTIME Meml[$1+28] # time of last modify +define IM_V1LIMTIME Meml[$1+29] # time min,max computed +define IM_V1MAX Memr[P2R($1+30)] # max pixel value +define IM_V1MIN Memr[P2R($1+31)] # min pixel value +define IM_V1HGM ($1+33) # histogram descriptor +define IM_V1CTRAN ($1+52) # coordinate transformations +define IM_V1PIXFILE Memc[P2C($1+103)] # name of pixel storage file +define IM_V1HDRFILE Memc[P2C($1+143)] # name of header storage file +define IM_V1TITLE Memc[P2C($1+183)] # image name string +define IM_V1HISTORY Memc[P2C($1+223)] # history comment string + +# The Histogram structure (field IM_HGM) +define LEN_HGMSTRUCT 20 +define HGM_TIME Meml[$1] # time when hgm was computed +define HGM_LEN Meml[$1+1] # number of bins in hgm +define HGM_NPIX Meml[$1+2] # npix used to compute hgm +define HGM_MIN Memr[P2R($1+3)] # min hgm value +define HGM_MAX Memr[P2R($1+4)] # max hgm value +define HGM_INTEGRAL Memr[P2R($1+5)] # integral of hgm +define HGM_MEAN Memr[P2R($1+6)] # mean value +define HGM_VARIANCE Memr[P2R($1+7)] # variance about mean +define HGM_SKEWNESS Memr[P2R($1+8)] # skewness of hgm +define HGM_MODE Memr[P2R($1+9)] # modal value of hgm +define HGM_LCUT Memr[P2R($1+10)] # low cutoff value +define HGM_HCUT Memr[P2R($1+11)] # high cutoff value +# next available field: ($1+12) + +# The Coordinate Transformation Structure (IM_CTRAN) +define LEN_CTSTRUCT 50 +define CT_VALID Memi[$1] # (y/n) is structure valid? +define CT_BSCALE Memr[P2R($1+1)] # pixval scale factor +define CT_BZERO Memr[P2R($1+2)] # pixval offset +define CT_CRVAL Memr[P2R($1+$2+3-1)] # value at pixel +define CT_CRPIX Memr[P2R($1+$2+10-1)] # index of pixel +define CT_CDELT Memr[P2R($1+$2+17-1)] # increment along axis +define CT_CROTA Memr[P2R($1+$2+24-1)] # rotation angle +define CT_BUNIT Memc[P2C($1+31)] # pixval ("brightness") units +define CT_CTYPE Memc[P2C($1+36)] # coord units string +# next available field: ($1+41) diff --git a/sys/imio/iki/oif/imhv2.h b/sys/imio/iki/oif/imhv2.h new file mode 100644 index 00000000..d7eaa1f7 --- /dev/null +++ b/sys/imio/iki/oif/imhv2.h @@ -0,0 +1,43 @@ +# IMHV2.H -- Version 2 of the OIF binary file header (March 1997). + +define V2_MAGIC "imhv2" # file identification tag +define V2_PMAGIC "impv2" # file identification tag +define V2_VERSION 2 # header version + +define SZ_V2IMPIXFILE 255 # name of pixel storage file +define SZ_V2IMHDRFILE 255 # name of header storage file +define SZ_V2IMTITLE 383 # image title string +define SZ_V2IMHIST 1023 # image history record + +# The IMIO image header structure. + +# Parameters. +define LEN_V2IMHDR 1024 # length of std header +define LEN_V2PIXHDR 293 # length of pixel file header +define V2U LEN_V2IMHDR # offset to user fields +define IM_V2USERAREA (P2C($1+V2U)) # user area (database) + +# Disk resident header. +define IM_V2MAGIC Memi[$1] # contains the string "imhdr" +define IM_V2HDRLEN Memi[$1+3] # length of image header +define IM_V2PIXTYPE Memi[$1+4] # datatype of the pixels +define IM_V2SWAPPED Memi[$1+5] # pixels are byte swapped +define IM_V2NDIM Memi[$1+6] # number of dimensions +define IM_V2LEN Meml[$1+$2+7-1] # length of the dimensions +define IM_V2PHYSLEN Meml[$1+$2+14-1] # physical length (as stored) +define IM_V2SSMTYPE Meml[$1+21] # type of subscript mapping +define IM_V2LUTOFF Meml[$1+22] # offset to subscript map luts +define IM_V2PIXOFF Meml[$1+23] # offset of the pixels +define IM_V2HGMOFF Meml[$1+24] # offset of hgm pixels +define IM_V2BLIST Meml[$1+25] # offset of bad pixel list +define IM_V2SZBLIST Meml[$1+26] # size of bad pixel list +define IM_V2NBPIX Meml[$1+27] # number of bad pixels +define IM_V2CTIME Meml[$1+28] # time of image creation +define IM_V2MTIME Meml[$1+29] # time of last modify +define IM_V2LIMTIME Meml[$1+30] # time min,max computed +define IM_V2MAX Memr[P2R($1+31)] # max pixel value +define IM_V2MIN Memr[P2R($1+32)] # min pixel value +define IM_V2PIXFILE Memc[P2C($1+37)] # name of pixel storage file +define IM_V2HDRFILE Memc[P2C($1+165)] # name of header storage file +define IM_V2TITLE Memc[P2C($1+293)] # image name string +define IM_V2HISTORY Memc[P2C($1+485)] # history comment string diff --git a/sys/imio/iki/oif/mkpkg b/sys/imio/iki/oif/mkpkg new file mode 100644 index 00000000..81a4d57e --- /dev/null +++ b/sys/imio/iki/oif/mkpkg @@ -0,0 +1,21 @@ +# Make the IKI/OIF interface (Old IRAF Format images) + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + oifaccess.x oif.h + oifclose.x + oifcopy.x oif.h + oifdelete.x + oifgpfn.x oif.h + oifmkpfn.x oif.h + oifopen.x oif.h + oifopix.x oif.h + oifrdhdr.x imhv1.h imhv2.h oif.h + oifrename.x oif.h + oifupdhdr.x oif.h + oifwrhdr.x imhv1.h imhv2.h oif.h + ; diff --git a/sys/imio/iki/oif/oif.h b/sys/imio/iki/oif/oif.h new file mode 100644 index 00000000..d1161659 --- /dev/null +++ b/sys/imio/iki/oif/oif.h @@ -0,0 +1,15 @@ +# OIF.H -- IKI/OIF internal definitions. + +define MAX_LENEXTN 3 # max length imagefile extension +define OIF_HDREXTN "imh" # image header filename extension +define OIF_PIXEXTN "pix" # image pixfile extension +define LEN_PIXHDR 512 # max length of PIXHDR structure +define COMPRESS NO # disable alignment of image lines? +define DEF_VERSION 2 # default file version + +define ENV_OIFVER "oifversion" # default format for new images +define HDR "HDR$" # stands for header directory +define STRLEN_HDR 4 + +define TY_IMHDR 1 # main imagefile header +define TY_PIXHDR 2 # pixel file header diff --git a/sys/imio/iki/oif/oifaccess.x b/sys/imio/iki/oif/oifaccess.x new file mode 100644 index 00000000..e5dfe28a --- /dev/null +++ b/sys/imio/iki/oif/oifaccess.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "oif.h" + +# OIF_ACCESS -- Test the accessibility or existence of an existing image, or +# the legality of the name of a new image. + +procedure oif_access (kernel, root, extn, acmode, status) + +int kernel #I IKI kernel +char root[ARB] #I root filename +char extn[ARB] #U extension (SET on output if none specified) +int acmode #I access mode (0 to test only existence) +int status #O status + +pointer sp, fname +int btoi(), access(), iki_validextn() +string oif_extn OIF_HDREXTN +bool strne() + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + # If new image, test only the legality of the given extension. + # This is used to select a kernel given the imagefile extension. + + if (acmode == NEW_IMAGE || acmode == NEW_COPY) { + status = btoi (iki_validextn (kernel, extn) > 0) + call sfree (sp) + return + } + + # Reject image if an invalid extension is given. + if (extn[1] != EOS && strne (extn, oif_extn)) { + status = NO + call sfree (sp) + return + } + + # Check for the imagefile. + call iki_mkfname (root, oif_extn, Memc[fname], SZ_PATHNAME) + if (access (Memc[fname], acmode, 0) == YES) { + if (extn[1] == EOS) + call strcpy (oif_extn, extn, MAX_LENEXTN) + status = YES + } else + status = NO + + call sfree (sp) +end diff --git a/sys/imio/iki/oif/oifclose.x b/sys/imio/iki/oif/oifclose.x new file mode 100644 index 00000000..8eb58b4f --- /dev/null +++ b/sys/imio/iki/oif/oifclose.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# OIF_CLOSE -- Close an OIF format image. There is little for us to do, since +# IMIO will already have updated the header if necessary and flushed any pixel +# output. Neither do we have to deallocate the IMIO descriptor, since it was +# allocated by IMIO. + +procedure oif_close (im, status) + +pointer im # image descriptor +int status + +int junk +int protect() + +begin + # Close the pixel file and header file, if open. + if (IM_PFD(im) != NULL) + call close (IM_PFD(im)) + if (IM_HFD(im) != NULL) + call close (IM_HFD(im)) + + # If we are closing a new image, set delete protection on the + # header file to prevent the user from using DELETE to delete + # the image header file, which would leave a headerless pixel + # storage file lying about somewhere. + + if (IM_ACMODE(im) == NEW_IMAGE || IM_ACMODE(im) == NEW_COPY) + iferr (junk = protect (IM_HDRFILE(im), SET_PROTECTION)) + call erract (EA_WARN) +end diff --git a/sys/imio/iki/oif/oifcopy.x b/sys/imio/iki/oif/oifcopy.x new file mode 100644 index 00000000..8a7ea41d --- /dev/null +++ b/sys/imio/iki/oif/oifcopy.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "oif.h" + +# OIF_COPY -- Copy an image. A special operator is provided for fast, blind +# copies of entire images. + +procedure oif_copy (kernel, old_root, old_extn, new_root, new_extn, status) + +int kernel #I IKI kernel +char old_root[ARB] # old image root name +char old_extn[ARB] # old image extn +char new_root[ARB] # new image root name +char new_extn[ARB] # new extn +int status + +pointer sp +pointer old_fname, new_fname + +begin + call smark (sp) + call salloc (old_fname, SZ_PATHNAME, TY_CHAR) + call salloc (new_fname, SZ_PATHNAME, TY_CHAR) + + # Get filename of old and new images. + call iki_mkfname (old_root, old_extn, Memc[old_fname], SZ_PATHNAME) + call iki_mkfname (new_root, OIF_HDREXTN, Memc[new_fname], SZ_PATHNAME) + + # For now, this is stubbed out. + status = ERR + call sfree (sp) +end diff --git a/sys/imio/iki/oif/oifdelete.x b/sys/imio/iki/oif/oifdelete.x new file mode 100644 index 00000000..758309a7 --- /dev/null +++ b/sys/imio/iki/oif/oifdelete.x @@ -0,0 +1,53 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# OIF_DELETE -- Delete an image. A special operator is required since the +# image is stored as two files. + +procedure oif_delete (kernel, root, extn, status) + +int kernel #I IKI kernel +char root[ARB] #I root filename +char extn[ARB] #U extension +int status + +int junk +pointer sp, fname, pixfile +int access(), protect() +pointer im, immapz() + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (pixfile, SZ_PATHNAME, TY_CHAR) + + # Generate filename. + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + + iferr (im = immapz (Memc[fname], READ_ONLY, 0)) { + call erract (EA_WARN) + + } else { + if (IM_PIXFILE(im) != EOS) { + call oif_gpixfname (IM_PIXFILE(im), IM_HDRFILE(im), + Memc[pixfile], SZ_PATHNAME) + if (access (Memc[pixfile],0,0) == YES) + iferr (call delete (Memc[pixfile])) + call erract (EA_WARN) + } + + call imunmap (im) + + # Do not complain if the file is not protected. + iferr (junk = protect (Memc[fname], REMOVE_PROTECTION)) + ; + iferr (call delete (Memc[fname])) + call erract (EA_WARN) + } + + call sfree (sp) + status = OK +end diff --git a/sys/imio/iki/oif/oifgpfn.x b/sys/imio/iki/oif/oifgpfn.x new file mode 100644 index 00000000..cc9a7fef --- /dev/null +++ b/sys/imio/iki/oif/oifgpfn.x @@ -0,0 +1,60 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "oif.h" + +# OIF_GPIXFNAME -- Convert a logical pixfile name into a physical pathname. + +procedure oif_gpixfname (pixfile, hdrfile, path, maxch) + +char pixfile[ARB] # pixfile name +char hdrfile[ARB] # header file name (gives hdr directory) +char path[maxch] # receives pathname +int maxch + +int ip, nchars +pointer sp, fname, op +int strncmp(), fnldir() + +begin + # Merely return pathname if not case "HDR$". + if (strncmp (pixfile, HDR, STRLEN_HDR) != 0) { + call fpathname (pixfile, path, maxch) + return + } + + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + # Get host pathname of pixel file directory. + nchars = fnldir (hdrfile, Memc[fname], SZ_PATHNAME) + call fpathname (Memc[fname], path, maxch) + + # Fold in any subdirectories from the pixfile name. + # (as in HDR$pixels/). + + op = fname + nchars = 0 + + for (ip=STRLEN_HDR+1; pixfile[ip] != EOS; ip=ip+1) { + if (pixfile[ip] == '/') { + Memc[op] = EOS + call zfsubd (path, maxch, Memc[fname], nchars) + op = fname + } else { + Memc[op] = pixfile[ip] + op = op + 1 + } + } + + # Tack on the pixel file name, which was left in the fname buf. + if (op > fname) { + Memc[op] = EOS + if (nchars > 0) + call strcpy (Memc[fname], path[nchars+1], maxch-nchars) + else + call strcat (Memc[fname], path, maxch) + } + + call sfree (sp) +end diff --git a/sys/imio/iki/oif/oifmkpfn.x b/sys/imio/iki/oif/oifmkpfn.x new file mode 100644 index 00000000..234fa706 --- /dev/null +++ b/sys/imio/iki/oif/oifmkpfn.x @@ -0,0 +1,118 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "oif.h" + +# OIF_MKPIXFNAME -- Generate the pixel file name. Leave the logical pixfile +# name in the image header, and return the pathname to the pixel file in the +# output argument. + +procedure oif_mkpixfname (im, pixfile, maxch) + +pointer im # image descriptor +char pixfile[maxch] # receives pathname to pixfile +int maxch + +char suffix[2] +int len_osdir, len_root, len_extn, n +pointer sp, imdir, osdir, root, extn, subdir, fname, ip, op + +bool fnullfile() +int fnroot(), fnldir(), access(), envgets(), strncmp() +string pixextn OIF_PIXEXTN +errchk fmkdir, imerr + +begin + # Clear junk text at the end of the filename. + call aclrc (IM_PIXFILE(im), SZ_IMPIXFILE) + + # Check for the null image. + if (fnullfile (IM_HDRFILE(im))) { + call strcpy ("dev$null", IM_PIXFILE(im), SZ_IMPIXFILE) + call strcpy (IM_PIXFILE(im), pixfile, maxch) + return + } + + call smark (sp) + call salloc (imdir, SZ_PATHNAME, TY_CHAR) + call salloc (osdir, SZ_PATHNAME, TY_CHAR) + call salloc (root, SZ_PATHNAME, TY_CHAR) + call salloc (subdir, SZ_PATHNAME, TY_CHAR) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (extn, SZ_FNAME, TY_CHAR) + + if (envgets ("imdir", Memc[imdir], SZ_PATHNAME) <= 0) + call strcpy (HDR, Memc[imdir], SZ_PATHNAME) + + if (strncmp (Memc[imdir], HDR, STRLEN_HDR) == 0) { + # Put pixfile in same directory as the header or in a subdirectory. + # In the latter case, create the directory if it does not already + # exist. + + ip = imdir + STRLEN_HDR + for (op=subdir; Memc[ip] != EOS && Memc[ip] != '/'; ip=ip+1) { + Memc[op] = Memc[ip] + op = op + 1 + } + Memc[op] = EOS + + if (Memc[subdir] != EOS) { + n = fnldir (IM_HDRFILE(im), Memc[fname], SZ_PATHNAME) + call fpathname (Memc[fname], Memc[fname], SZ_PATHNAME) + call zfsubd (Memc[fname], SZ_PATHNAME, Memc[subdir], n) + if (access (Memc[fname], 0, DIRECTORY_FILE) == NO) + call fmkdir (Memc[fname]) + } + } else + call fpathname (Memc[imdir], Memc[imdir], SZ_PATHNAME) + + # Make up the root name of the new pixel file. Take the root part of + # the header file and escape sequence encode it. We have to do this + # because it is to be concatenated to an OS directory name, which will + # prevent translation of the root file name during normal filename + # mapping. + + if (fnroot (IM_HDRFILE(im), Memc[fname], SZ_PATHNAME) <= 0) + call strcpy (pixextn, Memc[fname], SZ_PATHNAME) + call iki_mkfname (Memc[fname], pixextn, Memc[fname], SZ_PATHNAME) + call vfn_translate (Memc[fname], Memc[osdir], len_osdir, + Memc[root], len_root, Memc[extn], len_extn) + + suffix[1] = 'a' + suffix[2] = 'a' + suffix[3] = EOS + + for (n=0; ; n=n+1) { + call sprintf (IM_PIXFILE(im), SZ_PATHNAME, "%s%s.%s") + call pargstr (Memc[imdir]) + call pargstr (Memc[root]) + call pargstr (pixextn) + + call oif_gpixfname (IM_PIXFILE(im), IM_HDRFILE(im), pixfile, maxch) + + # Ensure that the filename is unique. + if (access (pixfile, 0,0) == YES) { + if (n == 0) { + for (op=root; Memc[op] != EOS; op=op+1) + ; + } else { + if (suffix[2] == 'z') { + suffix[2] = 'a' + if (suffix[1] == 'z') + call imerr (IM_NAME(im), SYS_FMKTEMP) + else + suffix[1] = suffix[1] + 1 + } else + suffix[2] = suffix[2] + 1 + } + + call strcpy (suffix, Memc[op], 2) + } else + break + } + + call sfree (sp) +end diff --git a/sys/imio/iki/oif/oifopen.x b/sys/imio/iki/oif/oifopen.x new file mode 100644 index 00000000..a280f163 --- /dev/null +++ b/sys/imio/iki/oif/oifopen.x @@ -0,0 +1,137 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include "oif.h" + +# OIF_OPEN -- Open/create an image. + +procedure oif_open (kernel, im, o_im, root, extn, ksection, cl_index, cl_size, acmode, status) + +int kernel #I IKI kernel +pointer im #I image descriptor +pointer o_im #I old image, if new_copy image +char root[ARB] #I root image name +char extn[ARB] #I extension, if any +char ksection[ARB] #I NOT USED +int cl_index #I NOT USED +int cl_size #I NOT USED +int acmode #I access mode +int status #O return value + +pointer sp, fname, pixfile +int hfd, nchars, mode, junk +int open(), oif_rdhdr(), access(), protect(), envgeti() +bool envgetb(), fnullfile() +errchk syserrs +define err_ 91 + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (pixfile, SZ_PATHNAME, TY_CHAR) + + status = OK + + # The only valid cl_index is -1 (none specified) or 1. + if (!(cl_index < 0 || cl_index == 1)) + goto err_ + + # This kernel does not permit a kernel section to be used. + if (ksection[1] != EOS) + call syserrs (SYS_IKIKSECTNS, Memc[fname]) + + # Determine access mode for header file. + if (acmode == NEW_COPY || acmode == NEW_IMAGE) + mode = NEW_FILE + else + mode = acmode + + # Generate full header file name; the extension may be either ".imh" + # or nothing, and was set earlier by oif_access(). + + if (mode == NEW_FILE && extn[1] == EOS) + call iki_mkfname (root, OIF_HDREXTN, Memc[fname], SZ_PATHNAME) + else + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + + # Delete any old image if one exists and imclobber is enabled. + if (mode == NEW_FILE && !fnullfile (Memc[fname]) && + (access (Memc[fname], 0,0) == YES)) { + + if (envgetb ("imclobber")) { + iferr (hfd = open (Memc[fname], READ_ONLY, BINARY_FILE)) { + status = ERR + goto err_ + } + nchars = LEN_IMHDR * SZ_MII_INT + if (oif_rdhdr (hfd, im, nchars, TY_IMHDR) < 0) { + status = ERR + goto err_ + } + if (IM_PIXFILE(im) != EOS) { + call oif_gpixfname (IM_PIXFILE(im), IM_HDRFILE(im), + Memc[pixfile], SZ_PATHNAME) + if (access (Memc[pixfile],0,0) == YES) + iferr (call delete (Memc[pixfile])) + call erract (EA_WARN) + } + call close (hfd) + iferr (junk = protect (Memc[fname], REMOVE_PROTECTION)) + ; + iferr (call delete (Memc[fname])) + call erract (EA_WARN) + } else + call syserrs (SYS_IKICLOB, Memc[fname]) + } + + # Open the image header file. + iferr (hfd = open (Memc[fname], mode, BINARY_FILE)) + goto err_ + + IM_HFD(im) = hfd + + # If opening an existing image, read the OIF fixed format binary + # image header into the image descriptor. If opening a new image, + # write out a generic image header so that the image can be accessed + # and deleted with imdelete should the operation be aborted before + # a full image is written. + + if (mode == NEW_FILE) { + iferr (IM_HDRVER(im) = envgeti (ENV_OIFVER)) + IM_HDRVER(im) = DEF_VERSION + call aclrc (IM_HDRFILE(im), SZ_IMHDRFILE) + call strcpy (Memc[fname], IM_HDRFILE(im), SZ_IMHDRFILE) + iferr (call oif_updhdr (im, status)) + ; + } else { + iferr { + nchars = (IM_LENHDRMEM(im) - LEN_IMHDR) * SZ_MII_INT + if (oif_rdhdr (hfd, im, nchars, TY_IMHDR) < 0) + status = ERR + else { + call aclrc (IM_HDRFILE(im), SZ_IMHDRFILE) + call strcpy (Memc[fname], IM_HDRFILE(im), SZ_IMHDRFILE) + } + } then + status = ERR + } + + # It is best to close the header file at this point for two reasons: + # to improve error recovery (if an abort occurs with a new file still + # open FIO will delete it) and to free file descriptors (important for + # applications that open many images). If the header needs to be + # updated, oif_updhdr will reopen the header file. + + call close (hfd) + IM_HFD(im) = NULL + + call sfree (sp) + return +err_ + status = ERR + call sfree (sp) +end diff --git a/sys/imio/iki/oif/oifopix.x b/sys/imio/iki/oif/oifopix.x new file mode 100644 index 00000000..c9652374 --- /dev/null +++ b/sys/imio/iki/oif/oifopix.x @@ -0,0 +1,103 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "oif.h" + +# OIF_OPIX -- Open (or create) the pixel storage file. If the image header file +# is `image.imh' the associated pixel storage file will be `imdir$image.pix', +# or some variation thereon should a collision occur. The environment variable +# IMDIR controls where the pixfile will be placed. The following classes of +# values are provided: +# +# path Put pixfile in named absolute directory regardless of +# where the header file is. +# ./ Put pixfile in the current directory at image creation +# time (special case of previous case). +# HDR$ Put pixfile in the same directory as the header file. +# HDR$subdir/ Put pixfiles in the subdirectory `subdir' of the +# directory containing the header file. IMIO will +# create the subdirectory if necessary. + +procedure oif_opix (im, status) + +pointer im # image descriptor +int status # return status + +long pixoff +pointer sp, pixhdr, pixfile +int pfd, blklen + +int open(), fdevblk(), oif_rdhdr() +errchk open, falloc, fdevblk, imerr, oif_rdhdr, oif_updhdr +errchk imioff, oif_wrhdr, oif_mkpixfname, oif_gpixfname, flush + +begin + status = OK + if (IM_PFD(im) != NULL) + return + + + call smark (sp) + call salloc (pixhdr, LEN_IMDES + LEN_PIXHDR, TY_STRUCT) + call salloc (pixfile, SZ_PATHNAME, TY_CHAR) + + switch (IM_ACMODE(im)) { + case READ_ONLY, READ_WRITE, WRITE_ONLY, APPEND: + if (IM_PIXFILE(im) == EOS) + call imerr (IM_NAME(im), SYS_IMRDPIXFILE) + + call oif_gpixfname (IM_PIXFILE(im), IM_HDRFILE(im), Memc[pixfile], + SZ_PATHNAME) + pfd = open (Memc[pixfile], IM_ACMODE(im), STATIC_FILE) + + call seek (pfd, BOFL) + if (oif_rdhdr (pfd, pixhdr, 0, TY_PIXHDR) < 0) + call imerr (IM_NAME(im), SYS_IMRDPIXFILE) + + case NEW_COPY, NEW_FILE, TEMP_FILE: + # Generate the pixel file name. + call oif_mkpixfname (im, Memc[pixfile], SZ_PATHNAME) + + # Compute the offset to the pixels in the pixfile. Allow space + # for the pixhdr pixel storage file header and start the pixels + # on the next device block boundary. + + blklen = fdevblk (Memc[pixfile]) + pixoff = LEN_PIXHDR * SZ_MII_INT + call imalign (pixoff, blklen) + + # Call IMIO to initialize the physical dimensions of the image + # and the absolute file offsets of the major components of the + # pixel storage file. + + call imioff (im, pixoff, COMPRESS, blklen) + + # Open the new pixel storage file (preallocate space if + # enabled on local system). Save the physical pathname of + # the pixfile in the image header, in case "imdir$" changes. + + if (IM_FALLOC == YES) { + call falloc (Memc[pixfile], IM_HGMOFF(im) - 1) + pfd = open (Memc[pixfile], READ_WRITE, STATIC_FILE) + } else + pfd = open (Memc[pixfile], NEW_FILE, BINARY_FILE) + + # Write small header into pixel storage file. Allows detection of + # headerless pixfiles, and reconstruction of header if it gets lost. + + call oif_wrhdr (pfd, im, TY_PIXHDR) + call flush (pfd) + + # Update the image header so that it knows about the pixel file. + call oif_updhdr (im, status) + + default: + call imerr (IM_NAME(im), SYS_IMACMODE) + } + + IM_PFD(im) = pfd + call sfree (sp) +end diff --git a/sys/imio/iki/oif/oifrdhdr.x b/sys/imio/iki/oif/oifrdhdr.x new file mode 100644 index 00000000..b11601cb --- /dev/null +++ b/sys/imio/iki/oif/oifrdhdr.x @@ -0,0 +1,196 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "imhv1.h" +include "imhv2.h" +include "oif.h" + + +# OIF_RDHDR -- Read the image header. Either the main image header or the +# pixel file header can be read. + +int procedure oif_rdhdr (fd, im, uchars, htype) + +int fd #I header file descriptor +pointer im #I image descriptor +int uchars #I maxchars of user area data to read +int htype #I TY_IMHDR or TY_PIXHDR + +pointer sp, v1 +char immagic[SZ_IMMAGIC] +int sulen_userarea, hdrlen, nchars, status + +bool streq() +int miireadc(), miireadi(), miireadl(), miireadr() +int btoi(), read() + +errchk read, miireadc, miireadi, miireadl, miireadr +define readerr_ 91 + +begin + # Determine the file type. + call seek (fd, BOFL) + if (read (fd, immagic, SZ_IMMAGIC) != SZ_IMMAGIC) + return (ERR) + + if (htype == TY_PIXHDR && streq (immagic, V1_PMAGIC)) { + # V1 Pixel file header. + return (OK) + + } else if (htype == TY_IMHDR && streq (immagic, V1_MAGIC)) { + # Old V1 image header. + + call smark (sp) + call salloc (v1, LEN_V1IMHDR, TY_STRUCT) + + call seek (fd, BOFL) + nchars = LEN_V1IMHDR * SZ_MII_INT + if (read (fd, IM_V1MAGIC(v1), nchars) != nchars) { + call sfree (sp) + return (ERR) + } + + # Initialize the output image header. + call strcpy (IMH_MAGICSTR, IM_MAGIC(im), SZ_IMMAGIC) + IM_HDRVER(im) = V1_VERSION + + # The following is the length of the user area in SU. + sulen_userarea = IM_V1HDRLEN(v1) - LEN_V1IMHDR + IM_HDRLEN(im) = LEN_IMHDR + sulen_userarea + + IM_SWAP(im) = NO + IM_SWAPPED(im) = -1 + IM_PIXTYPE(im) = IM_V1PIXTYPE(v1) + + IM_NDIM(im) = IM_V1NDIM(v1) + call amovl (IM_V1LEN(v1,1), IM_LEN(im,1), IM_MAXDIM) + call amovl (IM_V1PHYSLEN(v1,1), IM_PHYSLEN(im,1), IM_MAXDIM) + + IM_SSMTYPE(im) = IM_V1SSMTYPE(v1) + IM_LUTOFF(im) = IM_V1LUTOFF(v1) + IM_PIXOFF(im) = IM_V1PIXOFF(v1) + IM_HGMOFF(im) = IM_V1HGMOFF(v1) + IM_CTIME(im) = IM_V1CTIME(v1) + IM_MTIME(im) = IM_V1MTIME(v1) + IM_LIMTIME(im) = IM_V1LIMTIME(v1) + IM_MAX(im) = IM_V1MAX(v1) + IM_MIN(im) = IM_V1MIN(v1) + + call strcpy (IM_V1PIXFILE(v1), IM_PIXFILE(im), SZ_IMPIXFILE) + call strcpy (IM_V1HDRFILE(v1), IM_HDRFILE(im), SZ_IMHDRFILE) + call strcpy (IM_V1TITLE(v1), IM_TITLE(im), SZ_IMTITLE) + call strcpy (IM_V1HISTORY(v1), IM_HISTORY(im), SZ_IMHIST) + + # Read and output the user area. + if (uchars > 0 && sulen_userarea > 0) { + nchars = min (uchars, sulen_userarea * SZ_MII_INT) + if (read (fd, Memc[IM_USERAREA(im)], nchars) <= 0) + return (ERR) + } + + call sfree (sp) + return (OK) + } + + # Check for a new format header. + call seek (fd, BOFL) + if (miireadc (fd, immagic, SZ_IMMAGIC) < 0) + return (ERR) + + if (htype == TY_PIXHDR && streq (immagic, V2_PMAGIC)) { + # V2 Pixel file header. + return (OK) + + } else if (htype == TY_IMHDR && streq (immagic, V2_MAGIC)) { + # Newer V2 image header. + status = ERR + + # Initialize the output image header. + call strcpy (IMH_MAGICSTR, IM_MAGIC(im), SZ_IMMAGIC) + IM_HDRVER(im) = V2_VERSION + + # "sulen_userarea" is the length of the user area in SU. + if (miireadi (fd, hdrlen, 1) != 1) + goto readerr_ + sulen_userarea = hdrlen - LEN_V2IMHDR + IM_HDRLEN(im) = LEN_IMHDR + sulen_userarea + + if (miireadi (fd, IM_PIXTYPE(im), 1) != 1) + goto readerr_ + + # Determine whether to byte swap the pixels. + if (miireadi (fd, IM_SWAPPED(im), 1) != 1) + goto readerr_ + + IM_SWAP(im) = NO + switch (IM_PIXTYPE(im)) { + case TY_SHORT, TY_USHORT: + IM_SWAP(im) = btoi (IM_SWAPPED(im) != BYTE_SWAP2) + case TY_INT, TY_LONG: + IM_SWAP(im) = btoi (IM_SWAPPED(im) != BYTE_SWAP4) + case TY_REAL: + if (IEEE_USED == YES) + IM_SWAP(im) = btoi (IM_SWAPPED(im) != IEEE_SWAP4) + case TY_DOUBLE: + if (IEEE_USED == YES) + IM_SWAP(im) = btoi (IM_SWAPPED(im) != IEEE_SWAP8) + } + + # Read the fixed-format fields of the header. + if (miireadi (fd, IM_NDIM(im), 1) < 0) + goto readerr_ + if (miireadi (fd, IM_LEN(im,1), IM_MAXDIM) < 0) + goto readerr_ + if (miireadl (fd, IM_PHYSLEN(im,1), IM_MAXDIM) < 0) + goto readerr_ + if (miireadl (fd, IM_SSMTYPE(im), 1) < 0) + goto readerr_ + if (miireadl (fd, IM_LUTOFF(im), 1) < 0) + goto readerr_ + if (miireadl (fd, IM_PIXOFF(im), 1) < 0) + goto readerr_ + if (miireadl (fd, IM_HGMOFF(im), 1) < 0) + goto readerr_ + if (miireadl (fd, IM_BLIST(im), 1) < 0) + goto readerr_ + if (miireadl (fd, IM_SZBLIST(im), 1) < 0) + goto readerr_ + if (miireadl (fd, IM_NBPIX(im), 1) < 0) + goto readerr_ + if (miireadl (fd, IM_CTIME(im), 1) < 0) + goto readerr_ + if (miireadl (fd, IM_MTIME(im), 1) < 0) + goto readerr_ + if (miireadl (fd, IM_LIMTIME(im), 1) < 0) + goto readerr_ + + if (miireadr (fd, IM_MAX(im), 1) < 0) + goto readerr_ + if (miireadr (fd, IM_MIN(im), 1) < 0) + goto readerr_ + + if (miireadc (fd, IM_PIXFILE(im), SZ_V2IMPIXFILE) < 0) + goto readerr_ + if (miireadc (fd, IM_HDRFILE(im), SZ_V2IMHDRFILE) < 0) + goto readerr_ + if (miireadc (fd, IM_TITLE(im), SZ_V2IMTITLE) < 0) + goto readerr_ + if (miireadc (fd, IM_HISTORY(im), SZ_V2IMHIST) < 0) + goto readerr_ + + # Read the variable-length user area. + if (uchars > 0 && sulen_userarea > 0) { + nchars = min (uchars, sulen_userarea * SZ_MII_INT) + if (miireadc (fd, Memc[IM_USERAREA(im)], nchars) < 0) + goto readerr_ + } + + status = OK +readerr_ + return (status) + } + + return (ERR) +end diff --git a/sys/imio/iki/oif/oifrename.x b/sys/imio/iki/oif/oifrename.x new file mode 100644 index 00000000..edba1bcd --- /dev/null +++ b/sys/imio/iki/oif/oifrename.x @@ -0,0 +1,102 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "oif.h" + +# OIF_RENAME -- Rename an image. A special operator is required since the image +# is stored as two files. + +procedure oif_rename (kernel, old_root, old_extn, new_root, new_extn, status) + +int kernel #I IKI kernel +char old_root[ARB] # old image root name +char old_extn[ARB] # old image extn +char new_root[ARB] # new image root name +char new_extn[ARB] # old image extn +int status + +pointer sp, im +bool heq, peq +pointer old_hfn, new_hfn +pointer old_pfn, new_pfn +int nchars, old_rootoff, new_rootoff, junk + +bool streq() +pointer immapz() +int access(), strlen(), strncmp() +errchk immapz, rename + +begin + call smark (sp) + call salloc (old_hfn, SZ_PATHNAME, TY_CHAR) + call salloc (new_hfn, SZ_PATHNAME, TY_CHAR) + call salloc (old_pfn, SZ_PATHNAME, TY_CHAR) + call salloc (new_pfn, SZ_PATHNAME, TY_CHAR) + + # Get filenames of old and new images. + call iki_mkfname (old_root, old_extn, Memc[old_hfn], SZ_PATHNAME) + call iki_mkfname (new_root, OIF_HDREXTN, Memc[new_hfn], SZ_PATHNAME) + heq = streq (Memc[old_hfn], Memc[new_hfn]) + + # Our task here is nontrivial as the pixel file must be renamed as + # well as the header file, e.g., since renaming the header file may + # move it to a different directory, and the PIXFILE field in the + # image header may indicate that the pixel file is in the same dir + # as the header. Must open image, get pixfile name from the header, + # and generate the new pixfile name. The CURRENT value of IMDIR is + # used to generate the new pixfile name. + + im = immapz (Memc[old_hfn], READ_WRITE, 0) + + if (IM_PIXFILE(im) != EOS) { + # Get old pixel file filename. + call oif_gpixfname (IM_PIXFILE(im), Memc[old_hfn], Memc[old_pfn], + SZ_PATHNAME) + + # Get new pixel file filename. + call strcpy (Memc[new_hfn], IM_HDRFILE(im), SZ_IMHDRFILE) + call oif_mkpixfname (im, Memc[new_pfn], SZ_PATHNAME) + + # Do not change the pixel file name if the name does not change + # other than by the addition of the "aa" style suffix added by + # mkpixfname. + + peq = false + call zfnbrk (old_root, old_rootoff, junk) + call zfnbrk (new_root, new_rootoff, junk) + peq = streq (old_root[old_rootoff], new_root[new_rootoff]) + + if (peq) { + nchars = strlen (Memc[new_pfn]) - strlen ("aa.imh") + peq = (strncmp (Memc[old_pfn], Memc[new_pfn], nchars) == 0) + } + + if (peq) + IM_UPDATE(im) = NO + else { + # If the pixel file rename fails do not rename the header file + # and do not change the name of the pixel file in the header. + + iferr (call rename (Memc[old_pfn], Memc[new_pfn])) { + if (access (Memc[old_pfn], 0, 0) == YES) { + IM_UPDATE(im) = NO + call imunmap (im) + call erract (EA_ERROR) + } + } + } + + } else + call strcpy (Memc[new_hfn], IM_HDRFILE(im), SZ_IMHDRFILE) + + call strcpy (Memc[old_hfn], IM_HDRFILE(im), SZ_IMHDRFILE) + call imunmap (im) + + # Rename the header file. + if (!heq) + call rename (Memc[old_hfn], Memc[new_hfn]) + + call sfree (sp) +end diff --git a/sys/imio/iki/oif/oifupdhdr.x b/sys/imio/iki/oif/oifupdhdr.x new file mode 100644 index 00000000..516d62c1 --- /dev/null +++ b/sys/imio/iki/oif/oifupdhdr.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "oif.h" + +# OIF_UPDHDR -- Update the image header. + +procedure oif_updhdr (im, status) + +pointer im #I image descriptor +int status #O return status + +int hfd +errchk imerr, open, oif_wrhdr, flush +int open() + +begin + status = OK + hfd = IM_HFD(im) + + if (IM_ACMODE(im) == READ_ONLY) + call imerr (IM_NAME(im), SYS_IMUPIMHDR) + if (hfd == NULL) + hfd = open (IM_HDRFILE(im), READ_WRITE, BINARY_FILE) + + call oif_wrhdr (hfd, im, TY_IMHDR) + call flush (hfd) + + if (IM_HFD(im) == NULL) + call close (hfd) +end diff --git a/sys/imio/iki/oif/oifwrhdr.x b/sys/imio/iki/oif/oifwrhdr.x new file mode 100644 index 00000000..7b4e7349 --- /dev/null +++ b/sys/imio/iki/oif/oifwrhdr.x @@ -0,0 +1,233 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "imhv1.h" +include "imhv2.h" +include "oif.h" + +# OIF_WRHDR -- Write an OIF image header. + +procedure oif_wrhdr (fd, im, htype) + +int fd #I header file descriptor +pointer im #I image descriptor +int htype #I TY_IMHDR or TY_PIXHDR + +pointer sp, v1, fname +int status, hdrlen, len_userarea +errchk write, miiwritec, miiwritei, miiwritel, miiwriter +int strlen() + +define v1done_ 91 +define v2start_ 92 +define v2done_ 93 + +begin + switch (IM_HDRVER(im)) { + case V1_VERSION: + # Old V1 image header. + # ---------------------- + + status = ERR + call smark (sp) + call salloc (v1, LEN_V1IMHDR, TY_STRUCT) + + # Initialize the output image header. + switch (htype) { + case TY_IMHDR: + call strcpy (V1_MAGIC, IM_V1MAGIC(v1), SZ_IMMAGIC) + hdrlen = LEN_V1IMHDR + case TY_PIXHDR: + call strcpy (V1_PMAGIC, IM_V1MAGIC(v1), SZ_IMMAGIC) + hdrlen = LEN_V1PIXHDR + default: + goto v1done_ + } + + # The following is the length of the user area in chars. + len_userarea = strlen (Memc[IM_USERAREA(im)]) + 1 + IM_V1HDRLEN(v1) = LEN_V1IMHDR + + (len_userarea + SZ_MII_INT-1) / SZ_MII_INT + + IM_V1PIXTYPE(v1) = IM_PIXTYPE(im) + IM_V1NDIM(v1) = IM_NDIM(im) + call amovl (IM_LEN(im,1), IM_V1LEN(v1,1), IM_MAXDIM) + call amovl (IM_PHYSLEN(im,1), IM_V1PHYSLEN(v1,1), IM_MAXDIM) + + IM_V1SSMTYPE(v1) = IM_SSMTYPE(im) + IM_V1LUTOFF(v1) = IM_LUTOFF(im) + IM_V1PIXOFF(v1) = IM_PIXOFF(im) + IM_V1HGMOFF(v1) = IM_HGMOFF(im) + IM_V1CTIME(v1) = IM_CTIME(im) + IM_V1MTIME(v1) = IM_MTIME(im) + IM_V1LIMTIME(v1) = IM_LIMTIME(im) + IM_V1MAX(v1) = IM_MAX(im) + IM_V1MIN(v1) = IM_MIN(im) + + if (strlen(IM_PIXFILE(im)) > SZ_V1IMPIXFILE) + goto v1done_ + if (strlen(IM_HDRFILE(im)) > SZ_V1IMHDRFILE) + goto v1done_ + + call strcpy (IM_PIXFILE(im), IM_V1PIXFILE(v1), SZ_V1IMPIXFILE) + call strcpy (IM_HDRFILE(im), IM_V1HDRFILE(v1), SZ_V1IMHDRFILE) + call strcpy (IM_TITLE(im), IM_V1TITLE(v1), SZ_V1IMTITLE) + call strcpy (IM_HISTORY(im), IM_V1HISTORY(v1), SZ_V1IMHIST) + + # For historical reasons the pixel file header stores the host + # pathname of the header file in the PIXFILE field of the pixel + # file header. + + if (htype == TY_PIXHDR) + call fpathname (IM_HDRFILE(im), IM_V1PIXFILE(v1), + SZ_V1IMPIXFILE) + + # Write the file header. + call seek (fd, BOFL) + call write (fd, IM_V1MAGIC(v1), hdrlen * SZ_MII_INT) + + # Write the user area. + if (htype == TY_IMHDR) + call write (fd, Memc[IM_USERAREA(im)], len_userarea) + + status = OK +v1done_ + call sfree (sp) + if (status != OK) + call syserrs (SYS_IKIUPDHDR, IM_NAME(im)) + + case V2_VERSION: + # Newer V2 image header. + # ---------------------- +v2start_ + status = ERR + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + call seek (fd, BOFL) + + # Initialize the output image header. + switch (htype) { + case TY_IMHDR: + call miiwritec (fd, V2_MAGIC, SZ_IMMAGIC) + hdrlen = LEN_V2IMHDR + case TY_PIXHDR: + call miiwritec (fd, V2_PMAGIC, SZ_IMMAGIC) + hdrlen = LEN_V2PIXHDR + default: + goto v2done_ + } + + # The following is the length of the user area in SU. + len_userarea = strlen (Memc[IM_USERAREA(im)]) + 1 + hdrlen = LEN_V2IMHDR + (len_userarea + SZ_MII_INT-1) / SZ_MII_INT + + call miiwritei (fd, hdrlen, 1) + call miiwritei (fd, IM_PIXTYPE(im), 1) + + # Record the byte swapping used for this image. When writing a + # new image we use the native data type of the host and don't + # swap bytes, so IM_SWAPPED is YES if the host architecture is + # byte swapped. + + switch (IM_ACMODE(im)) { + case NEW_IMAGE, NEW_COPY, TEMP_FILE: + IM_SWAPPED(im) = -1 + switch (IM_PIXTYPE(im)) { + case TY_SHORT, TY_USHORT: + IM_SWAPPED(im) = BYTE_SWAP2 + case TY_INT, TY_LONG: + IM_SWAPPED(im) = BYTE_SWAP4 + case TY_REAL: + if (IEEE_USED == YES) + IM_SWAPPED(im) = IEEE_SWAP4 + case TY_DOUBLE: + if (IEEE_USED == YES) + IM_SWAPPED(im) = IEEE_SWAP8 + } + default: + # IM_SWAPPED should already be set in header. + } + + call miiwritei (fd, IM_SWAPPED(im), 1) + call miiwritei (fd, IM_NDIM(im), 1) + call miiwritel (fd, IM_LEN(im,1), IM_MAXDIM) + call miiwritel (fd, IM_PHYSLEN(im,1), IM_MAXDIM) + call miiwritel (fd, IM_SSMTYPE(im), 1) + call miiwritel (fd, IM_LUTOFF(im), 1) + call miiwritel (fd, IM_PIXOFF(im), 1) + call miiwritel (fd, IM_HGMOFF(im), 1) + call miiwritel (fd, IM_BLIST(im), 1) + call miiwritel (fd, IM_SZBLIST(im), 1) + call miiwritel (fd, IM_NBPIX(im), 1) + call miiwritel (fd, IM_CTIME(im), 1) + call miiwritel (fd, IM_MTIME(im), 1) + call miiwritel (fd, IM_LIMTIME(im), 1) + call miiwriter (fd, IM_MAX(im), 1) + call miiwriter (fd, IM_MIN(im), 1) + + if (strlen(IM_PIXFILE(im)) > SZ_V2IMPIXFILE) + goto v2done_ + if (strlen(IM_HDRFILE(im)) > SZ_V2IMHDRFILE) + goto v2done_ + + # For historical reasons the pixel file header stores the host + # pathname of the header file in the PIXFILE field of the pixel + # file header. + + if (htype == TY_PIXHDR) { + call aclrc (Memc[fname], SZ_PATHNAME) + call fpathname (IM_HDRFILE(im), Memc[fname], SZ_PATHNAME) + call miiwritec (fd, Memc[fname], SZ_V2IMPIXFILE) + status = OK + goto v2done_ + } else + call miiwritec (fd, IM_PIXFILE(im), SZ_V2IMPIXFILE) + + call oif_trim (IM_HDRFILE(im), SZ_V2IMHDRFILE) + call miiwritec (fd, IM_HDRFILE(im), SZ_V2IMHDRFILE) + + call oif_trim (IM_TITLE(im), SZ_V2IMTITLE) + call miiwritec (fd, IM_TITLE(im), SZ_V2IMTITLE) + + call oif_trim (IM_HISTORY(im), SZ_V2IMHIST) + call miiwritec (fd, IM_HISTORY(im), SZ_V2IMHIST) + + # Write the variable-length user area. + call miiwritec (fd, Memc[IM_USERAREA(im)], len_userarea) + + status = OK +v2done_ + call sfree (sp) + if (status != OK) + call syserrs (SYS_IKIUPDHDR, IM_NAME(im)) + + default: + IM_HDRVER(im) = V2_VERSION + goto v2start_ + } +end + + +# OIF_TRIM -- Trim trailing garbage at the end of a string. This does not +# affect the value of the string, but makes the contents of the output file +# clearer when examined with file utilities. + +procedure oif_trim (s, nchars) + +char s[ARB] +int nchars + +int n, ntrim +int strlen() + +begin + n = strlen(s) + 1 + ntrim = nchars - n + + if (ntrim > 0) + call aclrc (s[n], ntrim) +end diff --git a/sys/imio/iki/plf/README b/sys/imio/iki/plf/README new file mode 100644 index 00000000..0a2065c7 --- /dev/null +++ b/sys/imio/iki/plf/README @@ -0,0 +1,5 @@ +PLF -- Partial, IKI mini-driver for the pixel list (PLIO) image format. + +Only part of the IKI routines are implemented here. The open/close, header +access, and i/o functions are handled as a special case directly in the +IMIO code (see the impm*.x routines, and im[rd|wr]px.x). diff --git a/sys/imio/iki/plf/mkpkg b/sys/imio/iki/plf/mkpkg new file mode 100644 index 00000000..4253544e --- /dev/null +++ b/sys/imio/iki/plf/mkpkg @@ -0,0 +1,17 @@ +# Make the PLF image kernel (PLIO mask image kernel). + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + plfaccess.x plf.h + plfclose.x + plfcopy.x plf.h + plfdelete.x + plfnull.x + plfopen.x + plfrename.x plf.h + plfupdhdr.x + ; diff --git a/sys/imio/iki/plf/plf.h b/sys/imio/iki/plf/plf.h new file mode 100644 index 00000000..7fc666a9 --- /dev/null +++ b/sys/imio/iki/plf/plf.h @@ -0,0 +1,4 @@ +# PLF.H -- IKI/PLF internal definitions. + +define PLF_EXTN "pl" # image header filename extension +define MAX_LENEXTN 3 # max length imagefile extension diff --git a/sys/imio/iki/plf/plfaccess.x b/sys/imio/iki/plf/plfaccess.x new file mode 100644 index 00000000..bf4ed5a9 --- /dev/null +++ b/sys/imio/iki/plf/plfaccess.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "plf.h" + +# PLF_ACCESS -- Test the accessibility or existence of an existing image, +# or the legality of the name of a new image. + +procedure plf_access (kernel, root, extn, acmode, status) + +int kernel #I IKI kernel +char root[ARB] #I root filename +char extn[ARB] #U extension (SET on output if none specified) +int acmode #I access mode (0 to test only existence) +int status #O ok or err + +pointer sp, fname +int btoi(), access(), iki_validextn() +string plf_extn PLF_EXTN + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + # If new image, test only the legality of the given extension. + # This is used to select a kernel given the imagefile extension. + + status = NO + if (extn[1] != EOS) + status = btoi (iki_validextn (kernel, extn) > 0) + + if (acmode != NEW_IMAGE && acmode != NEW_COPY) { + if (extn[1] == EOS) { + call iki_mkfname (root, plf_extn, Memc[fname], SZ_PATHNAME) + status = access (Memc[fname], acmode, 0) + if (status != NO) + call strcpy (plf_extn, extn, MAX_LENEXTN) + } else if (status != NO) { + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + status = access (Memc[fname], acmode, 0) + } + } + + call sfree (sp) +end diff --git a/sys/imio/iki/plf/plfclose.x b/sys/imio/iki/plf/plfclose.x new file mode 100644 index 00000000..2d2454e0 --- /dev/null +++ b/sys/imio/iki/plf/plfclose.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# PLF_CLOSE -- Close a mask image. + +procedure plf_close (im, status) + +pointer im #I image descriptor +int status #O output status + +begin + if (IM_PFD(im) != NULL) + call close (IM_PFD(im)) + if (and (IM_PLFLAGS(im), PL_CLOSEPL) != 0) + call pl_close (IM_PL(im)) + + IM_PL(im) = NULL +end diff --git a/sys/imio/iki/plf/plfcopy.x b/sys/imio/iki/plf/plfcopy.x new file mode 100644 index 00000000..4cfb2b6e --- /dev/null +++ b/sys/imio/iki/plf/plfcopy.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "plf.h" + +# PLF_COPY -- Copy an image. A special operator is provided for fast, blind +# copies of entire images. + +procedure plf_copy (kernel, old_root, old_extn, new_root, new_extn, status) + +int kernel #I IKI kernel +char old_root[ARB] #I old image root name +char old_extn[ARB] #I old image extn +char new_root[ARB] #I new image root name +char new_extn[ARB] #I new extn +int status #O output status + +pointer sp +pointer oldname, newname + +begin + call smark (sp) + call salloc (oldname, SZ_PATHNAME, TY_CHAR) + call salloc (newname, SZ_PATHNAME, TY_CHAR) + + # Get filename of old and new images. + call iki_mkfname (old_root, old_extn, Memc[oldname], SZ_PATHNAME) + call iki_mkfname (new_root, PLF_EXTN, Memc[newname], SZ_PATHNAME) + + # Copy the PLIO mask save file. + iferr (call fcopy (Memc[oldname], Memc[newname])) { + call erract (EA_WARN) + status = ERR + } else + status = OK + + call sfree (sp) +end diff --git a/sys/imio/iki/plf/plfdelete.x b/sys/imio/iki/plf/plfdelete.x new file mode 100644 index 00000000..4fad68aa --- /dev/null +++ b/sys/imio/iki/plf/plfdelete.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PLF_DELETE -- Delete a PLIO mask savefile (mask image). + +procedure plf_delete (kernel, root, extn, status) + +int kernel #I IKI kernel +char root[ARB] #I root filename +char extn[ARB] #I extension +int status #O output status + +pointer sp, fname +errchk delete + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + iferr (call delete (Memc[fname])) { + call erract (EA_WARN) + status = ERR + } else + status = OK + + call sfree (sp) +end diff --git a/sys/imio/iki/plf/plfnull.x b/sys/imio/iki/plf/plfnull.x new file mode 100644 index 00000000..83ec77cd --- /dev/null +++ b/sys/imio/iki/plf/plfnull.x @@ -0,0 +1,9 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# PLF_NULL -- Null driver entry point. + +procedure plf_null() + +begin + call error (1, "PLF image kernel abort - null driver entry point") +end diff --git a/sys/imio/iki/plf/plfopen.x b/sys/imio/iki/plf/plfopen.x new file mode 100644 index 00000000..ec65d647 --- /dev/null +++ b/sys/imio/iki/plf/plfopen.x @@ -0,0 +1,90 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + + +# PLF_OPEN -- Open a PMIO mask on an image descriptor. + +procedure plf_open (kernel, im, o_im, + root, extn, ksection, cl_index, cl_size, acmode, status) + +int kernel #I IKI kernel +pointer im #I image descriptor +pointer o_im #I [not used] +char root[ARB] #I root image name +char extn[ARB] #I filename extension +char ksection[ARB] #I QPIO filter expression +int cl_index #I [not used] +int cl_size #I [not used] +int acmode #I [not used] +int status #O ok|err + +pointer sp, fname, hp, pl +int naxes, axlen[IM_MAXDIM], depth +bool envgetb(), fnullfile() +pointer pl_open() +int access() +errchk imerr + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (hp, IM_LENHDRMEM(im), TY_CHAR) + + # The only valid cl_index for a PL image is -1 (none specified) or 1. + if (!(cl_index < 0 || cl_index == 1)) { + call sfree (sp) + status = ERR + return + } + + # Get mask file name. + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + call aclrc (IM_HDRFILE(im), SZ_IMHDRFILE) + call strcpy (Memc[fname], IM_HDRFILE(im), SZ_IMHDRFILE) + + # Open an empty mask. + pl = pl_open (NULL) + + if (acmode == NEW_IMAGE || acmode == NEW_COPY) { + # Check that we will not be clobbering an existing mask. + if (!fnullfile(Memc[fname]) && access (Memc[fname], 0, 0) == YES) + if (envgetb ("imclobber")) { + iferr (call delete (Memc[fname])) + ; + } else { + call pl_close (pl) + call imerr (IM_NAME(im), SYS_IKICLOB) + } + } else { + # Load the named mask if opening an existing mask image. + iferr (call pl_loadf (pl,Memc[fname],Memc[hp],IM_LENHDRMEM(im))) { + call pl_close (pl) + call sfree (sp) + status = ERR + return + } + + # Set the image size. + call pl_gsize (pl, naxes, axlen, depth) + + IM_NDIM(im) = naxes + call amovl (axlen, IM_LEN(im,1), IM_MAXDIM) + call imioff (im, 1, YES, 1) + + # Restore the header cards. + call im_pmldhdr (im, hp) + } + + # More set up of the image descriptor. + IM_PL(im) = pl + IM_PLFLAGS(im) = PL_CLOSEPL + IM_PIXTYPE(im) = TY_INT + + status = OK + call sfree (sp) +end diff --git a/sys/imio/iki/plf/plfrename.x b/sys/imio/iki/plf/plfrename.x new file mode 100644 index 00000000..1ab47507 --- /dev/null +++ b/sys/imio/iki/plf/plfrename.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "plf.h" + +# PLF_RENAME -- Rename a PLIO mask savefile (mask image). + +procedure plf_rename (kernel, old_root, old_extn, new_root, new_extn, status) + +int kernel #I IKI kernel +char old_root[ARB] #I old image root name +char old_extn[ARB] #I old image extn +char new_root[ARB] #I new image root name +char new_extn[ARB] #I old image extn +int status #O output status + +pointer sp, oldname, newname +errchk rename + +begin + call smark (sp) + call salloc (oldname, SZ_PATHNAME, TY_CHAR) + call salloc (newname, SZ_PATHNAME, TY_CHAR) + + # Get filenames of old and new datafiles. + call iki_mkfname (old_root, old_extn, Memc[oldname], SZ_PATHNAME) + call iki_mkfname (new_root, PLF_EXTN, Memc[newname], SZ_PATHNAME) + + # Rename the datafile. + iferr (call rename (Memc[oldname], Memc[newname])) { + call erract (EA_WARN) + status = ERR + } else + status = OK + + call sfree (sp) +end diff --git a/sys/imio/iki/plf/plfupdhdr.x b/sys/imio/iki/plf/plfupdhdr.x new file mode 100644 index 00000000..e8cb8784 --- /dev/null +++ b/sys/imio/iki/plf/plfupdhdr.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# PLF_UPDHDR -- Update the image header. + +procedure plf_updhdr (im, status) + +pointer im #I image descriptor +int status #O output status + +pointer bp +int nchars, flags, sz_buf +int im_pmsvhdr() + +begin + status = OK + + flags = 0 + if (IM_ACMODE(im) == READ_WRITE) + flags = PL_UPDATE + + bp = NULL + iferr { + nchars = im_pmsvhdr (im, bp, sz_buf) + call pl_savef (IM_PL(im), IM_HDRFILE(im), Memc[bp], flags) + } then + status = ERR + + call mfree (bp, TY_CHAR) +end diff --git a/sys/imio/iki/qpf/README b/sys/imio/iki/qpf/README new file mode 100644 index 00000000..cea44538 --- /dev/null +++ b/sys/imio/iki/qpf/README @@ -0,0 +1,2 @@ +IKI/QPF -- IKI kernel for the QPOE (position ordered event file) image format. +See the QPOE source directories for additional information on QPOE. diff --git a/sys/imio/iki/qpf/mkpkg b/sys/imio/iki/qpf/mkpkg new file mode 100644 index 00000000..eb3e8efd --- /dev/null +++ b/sys/imio/iki/qpf/mkpkg @@ -0,0 +1,22 @@ +# Make the IKI/QPF interface (photon image kernel). + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + qpfaccess.x qpf.h + qpfclose.x qpf.h + qpfcopy.x qpf.h + qpfcopypar.x qpf.h + qpfdelete.x + qpfopen.x qpf.h \ + + qpfopix.x qpf.h + qpfrename.x qpf.h + qpfupdhdr.x + qpfwattr.x qpf.h + qpfwfilter.x qpf.h + zfioqp.x qpf.h + ; diff --git a/sys/imio/iki/qpf/qpf.h b/sys/imio/iki/qpf/qpf.h new file mode 100644 index 00000000..37e29cee --- /dev/null +++ b/sys/imio/iki/qpf/qpf.h @@ -0,0 +1,20 @@ +# QPF.H -- IKI/QPF internal definitions. + +define QPF_EXTN "qp" # image header filename extension +define MAX_LENEXTN 3 # max length imagefile extension +define SZ_KWNAME 8 # size of a FITS keyword name +define SZ_BIGSTR 64 # max length string per FITS card +define SZ_MAXFILTER 4096 # max size QPIO filter (for log only) + +define LEN_QPFDES 10 +define QPF_IM Memi[$1] # backpointer to image descriptor +define QPF_QP Memi[$1+1] # QPOE datafile descriptor +define QPF_IO Memi[$1+2] # QPIO descriptor +define QPF_XBLOCK Memr[P2R($1+3)] # X block factor for sampling +define QPF_YBLOCK Memr[P2R($1+4)] # Y block factor for sampling +define QPF_VS Memi[$1+5+$2-1] # start vector of active rect +define QPF_VE Memi[$1+7+$2-1] # end vector of active rect +define QPF_IOSTAT Memi[$1+9] # i/o status (byte count) + +# QPOE parameters to be omitted from the IMIO header user parameter list. +define OMIT "|naxes|axlen|datamin|datamax|cretime|modtime|limtime|" diff --git a/sys/imio/iki/qpf/qpfaccess.x b/sys/imio/iki/qpf/qpfaccess.x new file mode 100644 index 00000000..52d0b06f --- /dev/null +++ b/sys/imio/iki/qpf/qpfaccess.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "qpf.h" + +# QPF_ACCESS -- Test the accessibility or existence of an existing image, +# or the legality of the name of a new image. + +procedure qpf_access (kernel, root, extn, acmode, status) + +int kernel #I IKI kernel +char root[ARB] #I root filename +char extn[ARB] #U extension (SET on output if none specified) +int acmode #I access mode (0 to test only existence) +int status #O ok or err + +pointer sp, fname +int btoi(), qp_access(), iki_validextn() +string qpf_extn QPF_EXTN + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + # If new image, test only the legality of the given extension. + # This is used to select a kernel given the imagefile extension. + + status = NO + if (extn[1] != EOS) + status = btoi (iki_validextn (kernel, extn) > 0) + + if (acmode != NEW_IMAGE && acmode != NEW_COPY) { + if (extn[1] == EOS) { + call iki_mkfname (root, qpf_extn, Memc[fname], SZ_PATHNAME) + status = qp_access (Memc[fname], acmode) + if (status != NO) + call strcpy (qpf_extn, extn, MAX_LENEXTN) + } else if (status != NO) { + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + status = qp_access (Memc[fname], acmode) + } + } + + call sfree (sp) +end diff --git a/sys/imio/iki/qpf/qpfclose.x b/sys/imio/iki/qpf/qpfclose.x new file mode 100644 index 00000000..b4bad7b4 --- /dev/null +++ b/sys/imio/iki/qpf/qpfclose.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "qpf.h" + +# QPF_CLOSE -- Close a QPOE image. + +procedure qpf_close (im, status) + +pointer im #I image descriptor +int status #O output status + +pointer qpf + +begin + # Close the QPF virtual file driver. + if (IM_PFD(im) != NULL) + call close (IM_PFD(im)) + + # Close the various descriptors. + qpf = IM_KDES(im) + if (QPF_IO(qpf) != NULL) + call qpio_close (QPF_IO(qpf)) + if (QPF_QP(qpf) != NULL) + call qp_close (QPF_QP(qpf)) + + call mfree (qpf, TY_STRUCT) +end diff --git a/sys/imio/iki/qpf/qpfcopy.x b/sys/imio/iki/qpf/qpfcopy.x new file mode 100644 index 00000000..ebc2fa5b --- /dev/null +++ b/sys/imio/iki/qpf/qpfcopy.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpf.h" + +# QPF_COPY -- Copy an image. A special operator is provided for fast, blind +# copies of entire images. + +procedure qpf_copy (kernel, old_root, old_extn, new_root, new_extn, status) + +int kernel #I IKI kernel +char old_root[ARB] #I old image root name +char old_extn[ARB] #I old image extn +char new_root[ARB] #I new image root name +char new_extn[ARB] #I new extn +int status #O output status + +pointer sp +pointer oldname, newname +errchk qp_copy + +begin + call smark (sp) + call salloc (oldname, SZ_PATHNAME, TY_CHAR) + call salloc (newname, SZ_PATHNAME, TY_CHAR) + + # Get filename of old and new images. + call iki_mkfname (old_root, old_extn, Memc[oldname], SZ_PATHNAME) + call iki_mkfname (new_root, QPF_EXTN, Memc[newname], SZ_PATHNAME) + + # Copy the datafile. + iferr (call qp_copy (Memc[oldname], Memc[newname])) { + call erract (EA_WARN) + status = ERR + } else + status = OK + + call sfree (sp) +end diff --git a/sys/imio/iki/qpf/qpfcopypar.x b/sys/imio/iki/qpf/qpfcopypar.x new file mode 100644 index 00000000..cfa94c62 --- /dev/null +++ b/sys/imio/iki/qpf/qpfcopypar.x @@ -0,0 +1,117 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "qpf.h" + +# QPF_COPYPARAMS -- Copy parameters from the QPOE datafile header into the +# image header. Only scalar parameters are copied. + +procedure qpf_copyparams (im, qp) + +pointer im #I image descriptor +pointer qp #I QPOE descriptor + +int nelem, dtype, maxelem, flags +pointer sp, param, text, comment, datatype, fl, qpf, mw, io + +pointer qp_ofnlu(), qpio_loadwcs() +int qp_gnfn(), qp_queryf(), stridx(), strdic() +errchk qp_ofnlu, qp_gnfn, qp_queryf, imaddi, qp_geti, mw_saveim + +bool qp_getb() +short qp_gets() +int qp_geti(), qp_gstr() +real qp_getr() +double qp_getd() + +begin + call smark (sp) + call salloc (text, SZ_LINE, TY_CHAR) + call salloc (param, SZ_FNAME, TY_CHAR) + call salloc (comment, SZ_COMMENT, TY_CHAR) + call salloc (datatype, SZ_DATATYPE, TY_CHAR) + + qpf = IM_KDES(im) + + # Copy QPOE special keywords. + call imaddi (im, "NAXES", qp_geti(qp,"naxes")) + call imaddi (im, "AXLEN1", qp_geti(qp,"axlen[1]")) + call imaddi (im, "AXLEN2", qp_geti(qp,"axlen[2]")) + call imaddr (im, "XBLOCK", QPF_XBLOCK(qpf)) + call imaddr (im, "YBLOCK", QPF_YBLOCK(qpf)) + + # Output the QPOE filter. + iferr (call qpf_wfilter (qpf, im)) + call erract (EA_WARN) + + # Compute and output any filter attributes. + iferr (call qpf_wattr (qpf, im)) + call erract (EA_WARN) + + # Copy the WCS, if any. + io = QPF_IO(qpf) + if (io != NULL) + ifnoerr (mw = qpio_loadwcs (io)) { + call mw_saveim (mw, im) + call mw_close (mw) + } + + # Copy general keywords. + fl = qp_ofnlu (qp, "*") + + while (qp_gnfn (fl, Memc[param], SZ_FNAME) != EOF) { + # Get the next scalar parameter which has a nonnull value. + nelem = qp_queryf (qp, Memc[param], Memc[datatype], maxelem, + Memc[comment], flags) + if (strdic (Memc[param], Memc[text], SZ_LINE, OMIT) > 0) + next + + dtype = stridx (Memc[datatype], "bcsilrdx") + + # Make entry for a parameter which has no value, or an unprintable + # value. + + if (nelem == 0 || (nelem > 1 && dtype != TY_CHAR) || + dtype < TY_BOOL || dtype > TY_COMPLEX) { + + call sprintf (Memc[text], SZ_LINE, "%14s[%03d] %s") + call pargstr (Memc[datatype]) + call pargi (nelem) + call pargstr (Memc[comment]) + + iferr (call imastr (im, Memc[param], Memc[text])) + call erract (EA_WARN) + next + } + + # Copy parameter to image header. + iferr { + switch (dtype) { + case TY_BOOL: + call imaddb (im, Memc[param], qp_getb(qp,Memc[param])) + case TY_CHAR: + if (qp_gstr (qp, Memc[param], Memc[text], SZ_LINE) > 0) + call imastr (im, Memc[param], Memc[text]) + case TY_SHORT: + call imadds (im, Memc[param], qp_gets(qp,Memc[param])) + case TY_INT, TY_LONG: + call imaddi (im, Memc[param], qp_geti(qp,Memc[param])) + case TY_REAL: + call imaddr (im, Memc[param], qp_getr(qp,Memc[param])) + case TY_DOUBLE: + call imaddd (im, Memc[param], qp_getd(qp,Memc[param])) + case TY_COMPLEX: + ; # not supported. + } + } then { + call erract (EA_WARN) + break + } + } + + call qp_cfnl (fl) + call sfree (sp) +end diff --git a/sys/imio/iki/qpf/qpfdelete.x b/sys/imio/iki/qpf/qpfdelete.x new file mode 100644 index 00000000..c503c174 --- /dev/null +++ b/sys/imio/iki/qpf/qpfdelete.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# QPF_DELETE -- Delete a datafile. + +procedure qpf_delete (kernel, root, extn, status) + +int kernel #I IKI kernel +char root[ARB] #I root filename +char extn[ARB] #I extension +int status #O output status + +pointer sp, fname +errchk qp_delete + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + iferr (call qp_delete (Memc[fname])) { + call erract (EA_WARN) + status = ERR + } else + status = OK + + call sfree (sp) +end diff --git a/sys/imio/iki/qpf/qpfopen.x b/sys/imio/iki/qpf/qpfopen.x new file mode 100644 index 00000000..99a57df1 --- /dev/null +++ b/sys/imio/iki/qpf/qpfopen.x @@ -0,0 +1,165 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include "qpf.h" + +# QPF_OPEN -- Open a QPOE image. New QPOE images can only be written by +# calling QPOE directly; under IMIO, only READ_ONLY access is supported. + +procedure qpf_open (kernel, im, o_im, + root, extn, ksection, cl_index, cl_size, acmode, status) + +int kernel #I IKI kernel +pointer im #I image descriptor +pointer o_im #I [not used] +char root[ARB] #I root image name +char extn[ARB] #I filename extension +char ksection[ARB] #I QPIO filter expression +int cl_index #I [not used] +int cl_size #I [not used] +int acmode #I [not used] +int status #O ok|err + +int n +real xblock, yblock, tol +pointer sp, qp, io, v, fname, qpf + +pointer qp_open, qpio_open() +real qpio_statr(), qp_statr() +int qpio_getrange(), qp_geti(), qp_gstr(), qp_lenf() +define err_ 91 + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (v, SZ_FNAME, TY_CHAR) + + io = NULL + qp = NULL + qpf = NULL + tol = EPSILONR * 100 + + # The only valid cl_index for a QPOE image is -1 (none specified) or 1. + if (!(cl_index < 0 || cl_index == 1)) + goto err_ + + call malloc (qpf, LEN_QPFDES, TY_STRUCT) + + # Open the QPOE file. + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + iferr (qp = qp_open (Memc[fname], READ_ONLY, 0)) { + qp = NULL + goto err_ + } + + # Open the event list under QPIO for sampled (pixel) i/o. + iferr (io = qpio_open (qp, ksection, READ_ONLY)) + io = NULL + + # Determine the data range and pixel type. + iferr (IM_CTIME(im) = qp_geti (qp, "cretime")) + IM_CTIME(im) = 0 + iferr (IM_MTIME(im) = qp_geti (qp, "modtime")) + IM_MTIME(im) = 0 + iferr (IM_LIMTIME(im) = qp_geti (qp, "limtime")) + IM_LIMTIME(im) = 0 + + # The min and max pixel values for a sampled event file depend + # strongly on the blocking factor, which is a runtime variable. + # Ideally when the poefile is written the vectors 'datamin' and + # 'datamax' should be computed for the main event list. These + # give the min and max pixel values (counts/pixel) for each blocking + # factor from 1 to len(data[min|max]), i.e., the blocking factor + # serves as the index into these vectors. + + if (io != NULL) { + xblock = max (1.0, qpio_statr (io, QPIO_XBLOCKFACTOR)) + yblock = max (1.0, qpio_statr (io, QPIO_YBLOCKFACTOR)) + } else { + xblock = max (1.0, qp_statr (qp, QPOE_XBLOCKFACTOR)) + yblock = max (1.0, qp_statr (qp, QPOE_YBLOCKFACTOR)) + } + call strcpy ("datamax", Memc[v], SZ_FNAME) + n = qp_lenf (qp, Memc[v]) + + if (n >= max(xblock,yblock)) { + call sprintf (Memc[v+7], SZ_FNAME-7, "[%d]") + call pargi (nint((xblock+yblock)/2)) + IM_MAX(im) = qp_geti (qp, Memc[v]) + Memc[v+5] = 'i'; Memc[v+6] = 'n' + IM_MIN(im) = qp_geti (qp, Memc[v]) + } else + IM_LIMTIME(im) = 0 + + # Set the image pixel type. This is arbitrary, provided we have + # enough dynamic range to represent the maximum pixel value. + + IM_PIXTYPE(im) = TY_INT + if (IM_LIMTIME(im) != 0 && IM_LIMTIME(im) >= IM_MTIME(im)) + if (int(IM_MAX(im)) <= MAX_SHORT) + IM_PIXTYPE(im) = TY_SHORT + + # Set the image size parameters. If the user has specified a rect + # within which i/o is to occur, set the logical image size to the + # size of the rect rather than the full matrix. + + if (io != NULL) { + IM_NDIM(im) = qpio_getrange (io, QPF_VS(qpf,1), QPF_VE(qpf,1), 2) + IM_LEN(im,1) = (QPF_VE(qpf,1) - QPF_VS(qpf,1) + 1) / xblock + tol + IM_LEN(im,2) = (QPF_VE(qpf,2) - QPF_VS(qpf,2) + 1) / yblock + tol + } else { + IM_NDIM(im) = 2 + IM_LEN(im,1) = qp_geti (qp, "axlen[1]") / xblock + tol + IM_LEN(im,2) = qp_geti (qp, "axlen[2]") / yblock + tol + QPF_VS(qpf,1) = 1; QPF_VE(qpf,1) = IM_LEN(im,1) + QPF_VS(qpf,2) = 1; QPF_VE(qpf,2) = IM_LEN(im,2) + } + call imioff (im, 1, YES, 1) + + iferr (n = qp_gstr (qp, "title", IM_TITLE(im), SZ_IMTITLE)) + IM_TITLE(im) = EOS + iferr (n = qp_gstr (qp, "history", IM_HISTORY(im), SZ_IMHIST)) + IM_HISTORY(im) = EOS + + call strcpy (root, IM_HDRFILE(im), SZ_IMHDRFILE) + IM_PIXFILE(im) = EOS + IM_HFD(im) = NULL + IM_PFD(im) = NULL + + # Set up the QPF descriptor. + QPF_IM(qpf) = im + QPF_QP(qpf) = qp + QPF_IO(qpf) = io + QPF_XBLOCK(qpf) = xblock + QPF_YBLOCK(qpf) = yblock + QPF_IOSTAT(qpf) = 0 + + IM_KDES(im) = qpf + + # Copy any scalar QPOE file header parameters into the IMIO header. + iferr (call qpf_copyparams (im, qp)) + call erract (EA_WARN) + + status = OK + call sfree (sp) + return + +err_ + # Error abort. + if (io != NULL) + call qpio_close (io) + if (qp != NULL) + call qp_close (qp) + + call mfree (qpf, TY_STRUCT) + IM_KDES(im) = NULL + + status = ERR + call erract (EA_WARN) + call sfree (sp) +end diff --git a/sys/imio/iki/qpf/qpfopix.x b/sys/imio/iki/qpf/qpfopix.x new file mode 100644 index 00000000..9b5750ff --- /dev/null +++ b/sys/imio/iki/qpf/qpfopix.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "qpf.h" + +# QPF_OPIX -- Open the "pixel storage file", i.e., open the special QPF/QPOE +# virtual file driver, which samples the QPOE event list in real time to +# produce image "pixels", where each pixel contains a count of the number of +# photons mapping to that point in the output image matrix. + +procedure qpf_opix (im, status) + +pointer im #I image descriptor +int status #O return status + +pointer sp, fname, qpf +extern qpfzop(), qpfzrd(), qpfzwr(), qpfzwt(), qpfzst(), qpfzcl() +int fopnbf() + +begin + status = OK + if (IM_PFD(im) != NULL) + return + + # Verify that the QPIO open succeeded at open time; if not, the file + # may not have an event list (which is legal, but not for pixel i/o). + + qpf = IM_KDES(im) + if (QPF_IO(qpf) == NULL) { + status = ERR + return + } + + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + # Encode the QPF descriptor as a pseudo-filename to pass the descriptor + # through fopnbf to the QPF virtual binary file driver. + + call sprintf (Memc[fname], SZ_FNAME, "QPF%d") + call pargi (IM_KDES(im)) + + # Open a file descriptor for the dummy QPOE file driver, used to access + # the event list as a virtual pixel array (sampled at runtime). + + iferr (IM_PFD(im) = fopnbf (Memc[fname], READ_ONLY, + qpfzop, qpfzrd, qpfzwr, qpfzwt, qpfzst, qpfzcl)) { + + IM_PFD(im) = NULL + status = ERR + } + + call sfree (sp) +end diff --git a/sys/imio/iki/qpf/qpfrename.x b/sys/imio/iki/qpf/qpfrename.x new file mode 100644 index 00000000..70f90626 --- /dev/null +++ b/sys/imio/iki/qpf/qpfrename.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpf.h" + +# QPF_RENAME -- Rename a datafile. + +procedure qpf_rename (kernel, old_root, old_extn, new_root, new_extn, status) + +int kernel #I IKI kernel +char old_root[ARB] #I old image root name +char old_extn[ARB] #I old image extn +char new_root[ARB] #I new image root name +char new_extn[ARB] #I old image extn +int status #O output status + +pointer sp, oldname, newname +errchk qp_rename + +begin + call smark (sp) + call salloc (oldname, SZ_PATHNAME, TY_CHAR) + call salloc (newname, SZ_PATHNAME, TY_CHAR) + + # Get filenames of old and new datafiles. + call iki_mkfname (old_root, old_extn, Memc[oldname], SZ_PATHNAME) + call iki_mkfname (new_root, QPF_EXTN, Memc[newname], SZ_PATHNAME) + + # Rename the datafile. + iferr (call qp_rename (Memc[oldname], Memc[newname])) { + call erract (EA_WARN) + status = ERR + } else + status = OK + + call sfree (sp) +end diff --git a/sys/imio/iki/qpf/qpfupdhdr.x b/sys/imio/iki/qpf/qpfupdhdr.x new file mode 100644 index 00000000..9dd67ea6 --- /dev/null +++ b/sys/imio/iki/qpf/qpfupdhdr.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# QPF_UPDHDR -- Update the image header. This is a no-op for QPF since the +# datafiles can only be accessed READ_ONLY via IMIO. + +procedure qpf_updhdr (im, status) + +pointer im #I image descriptor +int status #O output status + +begin + status = OK +end diff --git a/sys/imio/iki/qpf/qpfwattr.x b/sys/imio/iki/qpf/qpfwattr.x new file mode 100644 index 00000000..b48a6793 --- /dev/null +++ b/sys/imio/iki/qpf/qpfwattr.x @@ -0,0 +1,191 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "qpf.h" + +# QPF_WATTR -- Record information about the attributes of the filter +# expression used to generate an image. Currently the only value which can be +# computed and recorded is total range (integral of the in-range intervals) of +# the range list defining an attribute, for example, the total exposure time +# defined by the time range list used to filter the data. +# +# This routine is driven by a set of optional QPOE header keywords of the +# form +# +# Keyword String Value +# +# defattrN = "integral" [:type] +# e.g. +# defattr1 "exptime = integral time:d" +# +# where param-name is the parameter name to be written to the output image +# header, "integral" is the value to be computed, and attribute-name is the +# QPEX attribute (e.g., "time") to be used for the computation. A finite +# value is returned for the integral if a range list is given for the named +# attribute and the range is closed. If the range is open on either or both +# ends, or no range expression is defined for the attribute, then INDEF is +# returned for the value of the integral. + +procedure qpf_wattr (qpf, im) + +pointer qpf #I QPF descriptor +pointer im #I image descriptor + +real r1, r2, rsum +double d1, d2, dsum +int dtype, i, j, xlen, nranges, i1, i2, isum +pointer sp, io, qp, ex, kwname, kwval, pname, funame, atname, ip, xs, xe + +bool strne() +pointer qpio_stati() +int qp_gstr(), ctowrd(), qp_accessf() +int qpex_attrli(), qpex_attrlr(), qpex_attrld() +errchk qpex_attrli, qpex_attrlr, qpex_attrld, imaddi, imaddr, imaddd + +begin + io = QPF_IO(qpf) + if (io == NULL) + return + + qp = QPF_QP(qpf) + ex = qpio_stati (io, QPIO_EX) + + call smark (sp) + call salloc (kwname, SZ_FNAME, TY_CHAR) + call salloc (kwval, SZ_LINE, TY_CHAR) + call salloc (pname, SZ_FNAME, TY_CHAR) + call salloc (funame, SZ_FNAME, TY_CHAR) + call salloc (atname, SZ_FNAME, TY_CHAR) + + # Process a sequence of "defattrN" header parameter definitions. + # Each defines a parameter to be computed and added to the output + # image header. + + do i = 1, ARB { + # Check for a parameter named "defattrN", get string value. + call sprintf (Memc[kwname], SZ_FNAME, "defattr%d") + call pargi (i) + + if (qp_accessf (qp, Memc[kwname]) == NO) + break + if (qp_gstr (qp, Memc[kwname], Memc[kwval], SZ_LINE) <= 0) + break + + # Parse string value into parameter name, function name, + # expression attribute name, and datatype. + + ip = kwval + if (ctowrd (Memc, ip, Memc[pname], SZ_FNAME) <= 0) + break + while (IS_WHITE(Memc[ip]) || Memc[ip] == '=') + ip = ip + 1 + if (ctowrd (Memc, ip, Memc[funame], SZ_FNAME) <= 0) + break + if (ctowrd (Memc, ip, Memc[atname], SZ_FNAME) <= 0) + break + + dtype = TY_INT + for (ip=atname; Memc[ip] != EOS; ip=ip+1) + if (Memc[ip] == ':') { + Memc[ip] = EOS + if (Memc[ip+1] == 'd') + dtype = TY_DOUBLE + else if (Memc[ip+1] == 'r') + dtype = TY_REAL + else + call eprintf ("QPF.defattr: datatype not recognized\n") + } + + # Verify known function type. + if (strne (Memc[funame], "integral")) { + call eprintf ("QPF.defattr: function `%s' not recognized\n") + call pargstr (Memc[funame]) + break + } + + # Compute the integral of the range list for the named attribute. + xlen = 0 + xs = NULL + xe = NULL + + switch (dtype) { + case TY_REAL: + if (ex == NULL) + nranges = 0 + else + nranges = qpex_attrlr (ex, Memc[atname], xs, xe, xlen) + + if (nranges <= 0) + rsum = INDEFR + else { + rsum = 0 + do j = 1, nranges { + r1 = Memr[xs+j-1] + r2 = Memr[xe+j-1] + if (IS_INDEFR(r1) || IS_INDEFR(r2)) { + rsum = INDEFR + break + } else + rsum = rsum + (r2 - r1) + } + } + + call mfree (xs, TY_REAL) + call mfree (xe, TY_REAL) + call imaddr (im, Memc[pname], rsum) + + case TY_DOUBLE: + if (ex == NULL) + nranges = 0 + else + nranges = qpex_attrld (ex, Memc[atname], xs, xe, xlen) + + if (nranges <= 0) + dsum = INDEFD + else { + dsum = 0 + do j = 1, nranges { + d1 = Memd[xs+j-1] + d2 = Memd[xe+j-1] + if (IS_INDEFD(d1) || IS_INDEFD(d2)) { + dsum = INDEFD + break + } else + dsum = dsum + (d2 - d1) + } + } + + call mfree (xs, TY_DOUBLE) + call mfree (xe, TY_DOUBLE) + call imaddd (im, Memc[pname], dsum) + + default: + if (ex == NULL) + nranges = 0 + else + nranges = qpex_attrli (ex, Memc[atname], xs, xe, xlen) + + if (nranges <= 0) + isum = INDEFI + else { + isum = 0 + do j = 1, nranges { + i1 = Memi[xs+j-1] + i2 = Memi[xe+j-1] + if (IS_INDEFI(i1) || IS_INDEFI(i2)) { + isum = INDEFI + break + } else + isum = isum + (i2 - i1) + } + } + + call mfree (xs, TY_INT) + call mfree (xe, TY_INT) + call imaddi (im, Memc[pname], isum) + } + } + + call sfree (sp) +end diff --git a/sys/imio/iki/qpf/qpfwfilter.x b/sys/imio/iki/qpf/qpfwfilter.x new file mode 100644 index 00000000..e521cbc6 --- /dev/null +++ b/sys/imio/iki/qpf/qpfwfilter.x @@ -0,0 +1,53 @@ +include "qpf.h" + +# QPF_WFILTER -- Record the QPIO filter used to generate an image as a series +# of FITS cards in the image header. Note: excessively long filters are +# truncated to avoid overfilling the image header. + +procedure qpf_wfilter (qpf, im) + +pointer qpf #I QPF descriptor +pointer im #I image descriptor + +int nchars, nleft, index +pointer io, sp, bp, ip, kw, strval +errchk qpio_getfilter, impstr +int qpio_getfilter() + +begin + io = QPF_IO(qpf) + if (io == NULL) + return + + call smark (sp) + call salloc (kw, SZ_KWNAME, TY_CHAR) + call salloc (bp, SZ_MAXFILTER, TY_CHAR) + call salloc (strval, SZ_BIGSTR, TY_CHAR) + + # Get the filter as as string from QPIO. + nchars = qpio_getfilter (io, Memc[bp], SZ_MAXFILTER) + + # If the filter is longer than our string buffer, write a "..." at + # the end of the filter to indicate that it is being truncated. + + if (nchars == SZ_MAXFILTER) + call strcpy ("...", Memc[bp+nchars-3], 3) + + index = 1 + ip = bp + + # Output a series of QPFILTnn cards to record the full filter. + for (nleft = nchars; nleft > 0; nleft = nleft - SZ_BIGSTR) { + call strcpy (Memc[ip], Memc[strval], SZ_BIGSTR) + call sprintf (Memc[kw], SZ_KWNAME, "QPFILT%02d") + call pargi (index) + iferr (call imaddf (im, Memc[kw], "c")) + ; + call impstr (im, Memc[kw], Memc[strval]) + + ip = ip + SZ_BIGSTR + index = index + 1 + } + + call sfree (sp) +end diff --git a/sys/imio/iki/qpf/zfioqp.x b/sys/imio/iki/qpf/zfioqp.x new file mode 100644 index 00000000..0e1c38ff --- /dev/null +++ b/sys/imio/iki/qpf/zfioqp.x @@ -0,0 +1,189 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include "qpf.h" + +# ZFIOQP -- QPF virtual file driver. This driver presents to the caller a +# virtual file space containing a two dimensional array of type short or int +# pixels, wherein each "pixel" is a count of the number of events from a +# QPOE event list which map into that pixel. An i/o request results in +# runtime filtering and sampling of the event list, mapping each event which +# passes the filter into the corresponding output pixel, and incrementing the +# value of that pixel to count the event. + +# QPFZOP -- Open the file driver for i/o on the QPIO descriptor opened at +# qpf_open time. + +procedure qpfzop (pkfn, mode, status) + +char pkfn[ARB] #I packed virtual filename from FIO +int mode #I file access mode (ignored) +int status #O output status - i/o channel if successful + +int ip +pointer sp, fn, qpf +int ctoi() + +begin + call smark (sp) + call salloc (fn, SZ_FNAME, TY_CHAR) + + # The QPF descriptor is passed encoded in the pseudo filename as + # "QPFxxxx" (decimal). Extract this and return it as the i/o + # channel for the driver. + + ip = 4 + call strupk (pkfn, Memc[fn], SZ_FNAME) + if (ctoi (Memc[fn], ip, qpf) <= 0) + status = ERR + else + status = qpf + + QPF_IOSTAT(qpf) = 0 + call sfree (sp) +end + + +# QPFZCL -- Close the QPF binary file driver. + +procedure qpfzcl (chan, status) + +int chan #I QPF i/o channel +int status #O output status + +begin + status = OK +end + + +# QPFZRD -- Read a segment of the virtual pixel array into the output buffer, +# i.e., zero the output buffer and sample the event list, accumulating counts +# in the output array. + +procedure qpfzrd (chan, obuf, nbytes, boffset) + +int chan #I QPF i/o channel +char obuf[ARB] #O output buffer +int nbytes #I nbytes to be read +int boffset #I file offset at which read commences + +pointer qpf, im, io +int vs[2], ve[2] +real xblock, yblock +int szb_pixel, ncols, pixel, nev, xoff, yoff +int qpio_readpixs(), qpio_readpixi() + +include + +begin + qpf = chan + im = QPF_IM(qpf) + io = QPF_IO(qpf) + + xblock = QPF_XBLOCK(qpf) + yblock = QPF_YBLOCK(qpf) + ncols = IM_PHYSLEN(im,1) + xoff = QPF_VS(qpf,1) + yoff = QPF_VS(qpf,2) + szb_pixel = pix_size[IM_PIXTYPE(im)] * SZB_CHAR + + # Convert boffset, nbytes to vs, ve. + pixel = (boffset - 1) / szb_pixel + vs[1] = (mod (pixel, ncols)) * xblock + xoff + vs[2] = (pixel / ncols) * yblock + yoff + + pixel = (boffset-1 + nbytes - szb_pixel) / szb_pixel + ve[1] = (mod (pixel, ncols)) * xblock + (xblock-1) + xoff + ve[2] = (pixel / ncols) * yblock + (yblock-1) + yoff + + # Call readpix to sample image into the output buffer. Zero the buffer + # first since the read is additive. + + call aclrc (obuf, nbytes / SZB_CHAR) + iferr { + switch (IM_PIXTYPE(im)) { + case TY_SHORT: + nev = qpio_readpixs (io, obuf, vs, ve, 2, xblock, yblock) + case TY_INT: + nev = qpio_readpixi (io, obuf, vs, ve, 2, xblock, yblock) + } + } then { + QPF_IOSTAT(qpf) = ERR + } else + QPF_IOSTAT(qpf) = nbytes +end + + +# QPFZWR -- Write to the virtual pixel array. QPF permits only read-only +# access, but we ignore write requests, so return OK and do nothing if this +# routine is called. + +procedure qpfzwr (chan, ibuf, nbytes, boffset) + +int chan #I QPF i/o channel +char ibuf[ARB] #O datg buffer +int nbytes #I nbytes to be written +int boffset #I file offset to write at + +pointer qpf + +begin + qpf = chan + QPF_IOSTAT(qpf) = nbytes +end + + +# QPFZWT -- Return the number of virtual bytes transferred in the last i/o +# request. + +procedure qpfzwt (chan, status) + +int chan #I QPF i/o channel +int status #O i/o channel status + +pointer qpf + +begin + qpf = chan + status = QPF_IOSTAT(qpf) +end + + +# QPFZST -- Query device/file parameters. + +procedure qpfzst (chan, param, value) + +int chan #I QPF i/o channel +int param #I parameter to be returned +int value #O parameter value + +pointer qpf, im, io +int szb_pixel, npix +int qpio_stati() + +include + +begin + qpf = chan + im = QPF_IM(qpf) + io = QPF_IO(qpf) + npix = IM_PHYSLEN(im,1) * IM_PHYSLEN(im,2) + szb_pixel = pix_size[IM_PIXTYPE(im)] * SZB_CHAR + + switch (param) { + case FSTT_BLKSIZE: + value = 1 + case FSTT_FILSIZE: + value = npix * szb_pixel + case FSTT_OPTBUFSIZE: + value = min (npix*szb_pixel, qpio_stati(io,QPIO_OPTBUFSIZE)) + case FSTT_MAXBUFSIZE: + value = npix * szb_pixel + default: + value = ERR + } +end diff --git a/sys/imio/iki/stf/README b/sys/imio/iki/stf/README new file mode 100644 index 00000000..5540110b --- /dev/null +++ b/sys/imio/iki/stf/README @@ -0,0 +1,300 @@ +IKI/STF -- IKI kernel for the STScI SDAS/GEIS image format. This format stores +images in a format which resembles FITS group format. A GROUP FORMAT IMAGE is +a set of one or more images, all of which are the same size, dimension, and +datatype, and which share a common FITS header. The individual images in a +group each has a binary GROUP PARAMETER BLOCK (GPB). The image and associated +group parameter block are commonly referred to as a GROUP. A group format +image consists of two files, the FITS format header file for the group, +and the pixel file containing the image data and GPBs. + + +1. Typical STF group format FITS image header (imname.hhh) + + SIMPLE = F / Standard STF keywords + BITPIX = 32 + DATATYPE= 'REAL*4 ' + NAXIS = 2 + NAXIS1 = 512 + NAXIS2 = 512 + GROUPS = T + PSIZE = 512 + GCOUNT = 1 + PCOUNT = 12 + + PTYPE1 = 'DATAMIN ' / Define binary group params + PSIZE1 = 32 + PDTYPE1 = 'REAL*4 ' + (etc, for a total of 3*PCOUNT entries) + + (special keywords and HISTORY cards) + + +2. Pixel file format (imname.hhd) (byte stream, no alignment, no header) + + [1].pixels + [1].group parameter block + [2].pixels + [2].group parameter block + ... + [GCOUNT].pixels + [GCOUNT].group parameter block + + +The chief problems with this format are that the FITS format header can contain +only parameters which pertain to the group as a whole, while the format of the +GPBs is fixed at image creation time. Images may be neither deleted from nor +added to a group. It is possible for parameters in the FITS header to have +the same names as parameters in the GPBs. Multiple entries for the same +keyword may appear in the FITS header and the format does not define how +these are to be handled. Although the format is general enough to support +any datatype pixels, in practice only REAL*4 can be used as the SDAS software +maps the pixfile directly into virtual memory. + +CAVEAT -- This is an awkward interface and some liberties have been taken in +the code (hidden, subtle semantics, etc.). At least we were able to confine +the bad code to this one directory; any problems can be fixed without any +changes to the rest of IMIO. All of this low level code is expected to be +thrown out when IMIO is cut over onto DBIO (the upcoming IRAF database +interface). + + +IKI/STF Pseudocode +---------------------------- + +1. Data structures: + + 1.1 IMIO image descriptor + header, pixel file descriptors + pointer to additional kernel descriptor, if any + index of IKI kernel in use + pathnames of header, pixel files + IM_NDIM, IM_LEN, etc., physical image parameters + + 1.2 STF image descriptor + Pointed to by IM_KDES field of IMIO descriptor. + Contains values of all reserved fields of STF image header, + some of which duplicate values in IMIO descriptor. + Group, gcount, size of a group in pixfile, description of + the group parameter block, i.e., for each parameter, + the offset, datatype type, name, length if array, etc. + + 1.3 IMIO user area (FITS cards) + While an image is open, the first few cards in the user area + contain the FITS encoded group parameters. + The remainder of the user area contains an exact image of + all non-reserved keyword cards found in the STF image + header (or in the header of some other type of image + when making a new_copy of an image stored in some other + format). + + +2. Major Procedures + +procedure open_image + +begin + if (mode is not new_image or new_copy) { + open_existing_image + return + } + + We are opening a new_image or new_copy image. The problem here is + that the new image might be a group within an existing group format + image. This ambiguity is resolved by a simple test on the group + index, rather than by a context dependent test on the existence of + the group format image. If the mode is new_whatever and the group + is 1, a new group format image is created, else if the group is > 1, + the indicated group is initialized in an existing group format image. + + if (group > 1) { + We are opening a new group within an existing group format image. + + Call open_existing_image to open the group without reading the + group parameter block, which has not yet been initialized. + + if (mode is new_image) + initialize GPB to pixel coords + else if (mode is new_copy) + copy old GPB to new image; transform coords if necessary + + Note that when opening a new copy of an existing image as a new + group within a group format image, it is not clear what to do + with the FITS header of the old image. Our solution is to ignore + it, and retain only the GPB, the only part of the old header + pertaining directly to the group being accessed. + + } else if (opening group 1 of a new image) { + We are creating a new group format image. + + if (mode is new_image) + open_new_image + else + open_new_copy + } +end + + +procedure open_existing_image + +begin + Allocate STF descriptor, save pointer in imio descriptor. + Open image header. + + Read header: + process reserved cards into STF descriptor + spool other cards + + Load group data block from pixfile, get datamin/datamax: + if (there is a gdb) { + open pixfile + read gdb into buffer + for (each param in gdb) { + set up parameter descriptor + format FITS card and put in imio user area + } + } + + fetch datamin, datamax from user area + + Set IM_MIN, IM_MAX, IM_LIMTIME from DATAMIN, DATAMAX. + Mark end of user area. + Copy spooled cards to user area. + (increase size of user area if necessary) + + Call imioff to set up imio pixel offset parameters +end + + +procedure open_new_image + +begin + Upon entry, the imio iminie procedure has already been called to + initialize the imio descriptor for the new image. + + Allocate STF descriptor, save pointer in imio descriptor. + Create header file from template dev$pix.hhh. + Open new image header. + + (At this point the IMIO header fields IM_NDIM, IM_LEN, etc., and + (the STF descriptor fields have not yet been set, and cannot be set + (until the image dimensions have been defined by the high level code. + (imopix() will later have to fix up the remaining header fields and + (set up the default group data block. +end + + +procedure open_new_copy + +begin + Upon entry, the imio immaky procedure has already been called to + copy the old header to the new and initialize the data + dependent fields. This will include the FITS encoded group + parameters in the user area of the old image. + + Allocate STF descriptor, save pointer in imio descriptor. + Create header file from template dev$pix.hhh. + Open new image header. + + Copy the STF descriptor of the old image to the new. Preserve + the parameter marking the end of the GPB area of the old + user area, as we do not want to write these cards when the + header is updated. + + (At this point all header information is set up, except that there + (is no pixel file and the pixfile offsets have not been set. + (Provided the image dimensions do not change, one could simply + (set the pixfile name, call imioff, and do i/o to the image. +end + + +procedure open_pixel_file + +begin + (We are called when the first i/o is done to an image. When writing + (to a new image, the user may change any of the image header attributes + (after the open and before we are called. + + if (pixel file already open) + return + else if (opening existing image) { + open pixel file + return + } + + if (opening a new image) { + Given the values of IM_NDIM and IM_LEN set by the user, set up the + STF descriptor including the default group parameter block. Add + the FITS encoded cards for the GPB to the image header. Mark the + end of the GPB cards, i.e., the start of the real user parameter + area. Ignore IM_PIXTYPE; always open an image of type real since + that is what the SDAS software requires. Set up the WCS to linear + pixel coordinates. + + } else if (opening a new_copy image) { + (The STF descriptor and GPB will already have been set up as a + (copy of the data structures used by the old image. However, + (the user may have changed the values of IM_NDIM and IM_LEN + (since the image was opened, and the value of GCOUNT set when + (the image was opened may be different than that of the old image. + + Transform the coordinate system of the old image to produce the + WCS for the new image, i.e., if an image section was used to + reference the old image. + + Make a new STF descriptor using the values of IM_NDIM and IM_LEN + given, as for a new_image, but using the WCS information for the + new image. The FITS encoded fields in the IMIO user area will be + automatically updated by the IMADD functions, or new cards added + if not present. + + Merge any additional fields from the old STF descriptor into the + new one, e.g., any instrument dependent parameters stored in the + GPB. + + (The STF and FITS encoded user area should now contain a full + (description of the GPB for the new image. + } + + Allocate the pixel file, using the GCOUNT parameter set in the + STF descriptor at stf_open time. + Open the pixel file. + + Set IM_MIN and IM_MAX to zero (not defined). + Call IMIOFF to initialize the pixel offsets. +end + + +procedure update_image_header + +begin + Update the values of DATAMIN, DATAMAX from the IMIO header fields. + + Update the binary GPB in the pixel file from the FITS encoded GPB + in the IMIO user area, using the GPB structure defined in the + STF descriptor. + + Update the STF image header file: + Open a new, empty header file using FMKCOPY and OPEN. + Format and output FITS cards for the reserved header fields, + e.g., SIMPLE, BITPIX, GCOUNT, the GPB information, etc. + Copy the user area to the new header file, excluding the + GPB cards at the beginning of the user area. + Close the new header file and replace the old header file + with the new one via a rename operation. +end + + +procedure close_image + +begin + (We assume that IMIO has already update the image header if such + (is necessary. + + if (pixel file open) + close pixel file + if (header file open) + close header file + + deallocate STF descriptor + (IMIO will deallocate the IMIO descriptor) +end diff --git a/sys/imio/iki/stf/mkpkg b/sys/imio/iki/stf/mkpkg new file mode 100644 index 00000000..b28ace96 --- /dev/null +++ b/sys/imio/iki/stf/mkpkg @@ -0,0 +1,36 @@ +# Make the IKI/STF interface (STScI SDAS/GEIS group format images) + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + #$set XFLAGS = "$(XFLAGS) -qfx" + #$set XFLAGS = "$(XFLAGS) -/pg" + + stfaccess.x stf.h + stfaddpar.x stf.h + stfclose.x stf.h + stfcopy.x stf.h + stfcopyf.x stf.h + stfctype.x stf.h + stfdelete.x stf.h + stfget.x stf.h + stfhextn.x stf.h + stfiwcs.x stf.h + stfmerge.x stf.h + stfmkpfn.x stf.h + stfnewim.x stf.h + stfopen.x stf.h + stfopix.x stf.h + stfordgpb.x stf.h + stfrdhdr.x stf.h + stfreblk.x stf.h + stfrename.x stf.h + stfrfits.x stf.h + stfrgpb.x stf.h + stfupdhdr.x stf.h + stfwfits.x stf.h + stfwgpb.x stf.h + ; diff --git a/sys/imio/iki/stf/stf.h b/sys/imio/iki/stf/stf.h new file mode 100644 index 00000000..bf99a07c --- /dev/null +++ b/sys/imio/iki/stf/stf.h @@ -0,0 +1,77 @@ +# STF.H -- IKI/STF internal definitions. + +define HDR_TEMPLATE "dev$pix.hhh" # used by fmkcopy to create new header +define MAX_LENEXTN 3 # max length imagefile extension +define STF_HDRPATTERN "^??h" # class of legal header extensions +define STF_DEFHDREXTN "hhh" # default header file extension +define STF_DEFPIXEXTN "hhd" # default pixel file extension +define ENV_DEFIMTYPE "imtype" # name of environment variable +define STF_MAXDIM 7 # max NAXIS +define MAX_CACHE 5 # max cached header files +define DEF_CACHE 3 # default size of header file cache +define ENV_STFCACHE "stfcache" # environment variable for cache size +define MAX_PCOUNT 99 # max param descriptors +define SZ_DATATYPE 16 # e.g., `REAL*4' +define SZ_KEYWORD 8 # size of a FITS keyword +define SZ_PTYPE 8 # e.g., `CRPIX1' +define SZ_PDTYPE 16 # e.g., `CHAR*8' +define SZ_COMMENT FITS_SZCOMMENT # comment string for GPB card +define SZ_EXTRASPACE (81*32) # extra space for new cards in header + +define FITS_RECLEN 80 # length of a FITS record (card) +define FITS_STARTVALUE 10 # first column of value field +define FITS_ENDVALUE 30 # last column of value field +define FITS_SZVALSTR 21 # nchars in value string +define FITS_SZCOMMENT 50 # max chars in comment, incl. / + +# STF image descriptor, used internally by the STF interface. The required +# header parameters are maintained in this descriptor, everything else is +# simply copied into the user area of the IMIO descriptor. + +define LEN_STFDES (LEN_STFBASE+MAX_PCOUNT*LEN_PDES) +define STF_CACHE STF_BITPIX # cache descriptor starting here +define STF_CACHELEN (33+STF_PCOUNT($1)*LEN_PDES) +define LEN_STFBASE 43 + +define STF_ACMODE Memi[$1] # image access mode +define STF_NEWIMAGE Memi[$1+1] # creating entire new STF format image? +define STF_GROUP Memi[$1+2] # group to be accessed +define STF_SZGROUP Memi[$1+3] # size of image+hdr in pixfile, chars +define STF_PFD Memi[$1+4] # pixfile file descriptor +define STF_GRARG Memi[$1+5] # group index given in image name + # (extra space) +define STF_BITPIX Memi[$1+10] # bits per pixel +define STF_NAXIS Memi[$1+11] # number of axes in image +define STF_GROUPS Memi[$1+12] # group format? +define STF_GCOUNT Memi[$1+13] # number of groups in STF image +define STF_PSIZE Memi[$1+14] # size of GPB, bits +define STF_PCOUNT Memi[$1+15] # number of parameters in GPB +define STF_DATATYPE Memc[P2C($1+16)]# datatype string +define STF_LENAXIS Memi[$1+35+$2-1]# 35:41 = [7] max +define STF_PDES (($1)+43+((($2)-1)*LEN_PDES)) + +# GPB Parameter descriptor. +define LEN_PDES 81 +define P_OFFSET Memi[$1] # struct offset of parameter +define P_SPPTYPE Memi[$1+1] # SPP datatype of parameter +define P_LEN Memi[$1+2] # number of elements +define P_PSIZE Memi[$1+3] # field size, bits +define P_PTYPEP (P2C($1+4)) # pointer to parameter name +define P_PTYPE Memc[P2C($1+4)] # parameter name +define P_PDTYPE Memc[P2C($1+13)]# datatype string +define P_COMMENT Memc[P2C($1+30)]# comment string + +# Reserved FITS keywords known to this code. +define KW_BITPIX 1 +define KW_DATATYPE 2 +define KW_END 3 +define KW_GCOUNT 4 +define KW_GROUPS 5 +define KW_NAXIS 6 +define KW_NAXISN 7 +define KW_PCOUNT 8 +define KW_PDTYPE 9 +define KW_PSIZE 10 +define KW_PSIZEN 11 +define KW_PTYPE 12 +define KW_SIMPLE 13 diff --git a/sys/imio/iki/stf/stfaccess.x b/sys/imio/iki/stf/stfaccess.x new file mode 100644 index 00000000..40907c69 --- /dev/null +++ b/sys/imio/iki/stf/stfaccess.x @@ -0,0 +1,58 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stf.h" + +# STF_ACCESS -- Test the accessibility or existence of an existing image, or +# the legality of the name of a new image. + +procedure stf_access (kernel, root, extn, acmode, status) + +int kernel #I IKI kernel +char root[ARB] #I root filename +char extn[ARB] #I extension (SET on output if none specified) +int acmode #I access mode (0 to test only existence) +int status #O return value + +int i +pointer sp, fname, kextn +int access(), iki_validextn(), iki_getextn(), btoi() + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (kextn, MAX_LENEXTN, TY_CHAR) + + # If new image, test only the legality of the given extension. + # This is used to select a kernel given the imagefile extension. + + if (acmode == NEW_IMAGE || acmode == NEW_COPY) { + status = btoi (iki_validextn (kernel, extn) > 0) + call sfree (sp) + return + } + + status = NO + + # If no extension was given, look for a file with the default + # extension, and return the actual extension if an image with the + # default extension is found. + + if (extn[1] == EOS) { + do i = 1, ARB { + if (iki_getextn (kernel, i, Memc[kextn], MAX_LENEXTN) <= 0) + break + call iki_mkfname (root, Memc[kextn], Memc[fname], SZ_PATHNAME) + if (access (Memc[fname], acmode, 0) == YES) { + call strcpy (Memc[kextn], extn, MAX_LENEXTN) + status = YES + break + } + } + } else if (iki_validextn (kernel, extn) == kernel) { + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + if (access (Memc[fname], acmode, 0) == YES) + status = YES + } + + call sfree (sp) +end diff --git a/sys/imio/iki/stf/stfaddpar.x b/sys/imio/iki/stf/stfaddpar.x new file mode 100644 index 00000000..65a90f80 --- /dev/null +++ b/sys/imio/iki/stf/stfaddpar.x @@ -0,0 +1,94 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "stf.h" + +# STF_ADDPAR -- Encode a parameter in FITS format and add it to the FITS format +# IMIO user area; initialize the entry for the parameter in the GPB descriptor +# as well. + +procedure stf_addpar (im, pname, dtype, plen, pval, pno) + +pointer im #I image descriptor +char pname[ARB] #I parameter name +int dtype #I SPP datatype of parameter +int plen #I length (> 1 if array) +char pval[ARB] #I string encoded initial parameter value +int pno #U parameter number + +bool bval +real rval +double dval +short sval +long lval +pointer pp, stf + +bool initparam +int ival, ip, junk +int ctoi(), ctor(), ctod(), imaccf() +errchk imadds, imaddl, imaddr, imaddd, imastr + +begin + stf = IM_KDES(im) + pp = STF_PDES(stf,pno) + ip = 1 + + call strcpy (pname, P_PTYPE(pp), SZ_PTYPE) + + # Initialize the parameter only if not already defined in header. + initparam = (imaccf (im, pname) == NO) + + switch (dtype) { + case TY_BOOL: + call strcpy ("LOGICAL*4", P_PDTYPE(pp), SZ_PDTYPE) + P_PSIZE(pp) = plen * SZ_BOOL * SZB_CHAR * NBITS_BYTE + if (initparam) { + bval = (pval[1] == 'T') + call imaddb (im, P_PTYPE(pp), bval) + } + case TY_SHORT: + call strcpy ("INTEGER*2", P_PDTYPE(pp), SZ_PDTYPE) + P_PSIZE(pp) = plen * SZ_SHORT * SZB_CHAR * NBITS_BYTE + if (initparam) { + junk = ctoi (pval, ip, ival) + sval = ival + call imadds (im, P_PTYPE(pp), sval) + } + case TY_LONG: + call strcpy ("INTEGER*4", P_PDTYPE(pp), SZ_PDTYPE) + P_PSIZE(pp) = plen * SZ_LONG * SZB_CHAR * NBITS_BYTE + if (initparam) { + junk = ctoi (pval, ip, ival) + lval = ival + call imaddl (im, P_PTYPE(pp), lval) + } + case TY_REAL: + call strcpy ("REAL*4", P_PDTYPE(pp), SZ_PDTYPE) + P_PSIZE(pp) = plen * SZ_REAL * SZB_CHAR * NBITS_BYTE + if (initparam) { + junk = ctor (pval, ip, rval) + call imaddr (im, P_PTYPE(pp), rval) + } + case TY_DOUBLE: + call strcpy ("REAL*8", P_PDTYPE(pp), SZ_PDTYPE) + P_PSIZE(pp) = plen * SZ_DOUBLE * SZB_CHAR * NBITS_BYTE + if (initparam) { + junk = ctod (pval, ip, dval) + call imaddd (im, P_PTYPE(pp), dval) + } + default: + call sprintf (P_PDTYPE(pp), SZ_PDTYPE, "CHARACTER*%d") + call pargi (plen) + P_PSIZE(pp) = plen * NBITS_BYTE + if (initparam) + call imastr (im, P_PTYPE(pp), pval) + } + + P_OFFSET(pp) = 0 + P_SPPTYPE(pp) = dtype + P_LEN(pp) = plen + + pno = pno + 1 +end diff --git a/sys/imio/iki/stf/stfclose.x b/sys/imio/iki/stf/stfclose.x new file mode 100644 index 00000000..89981578 --- /dev/null +++ b/sys/imio/iki/stf/stfclose.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "stf.h" + +# STF_CLOSE -- Close an STF format image. There is little for us to do, since +# IMIO will already have updated the header if necessary and flushed any pixel +# output. Neither do we have to deallocate the IMIO descriptor, since it was +# allocated by IMIO. + +procedure stf_close (im, status) + +pointer im # image descriptor +int status + +pointer stf +errchk close + +begin + stf = IM_KDES(im) + + # Close the pixel file and header file, if open. + if (STF_PFD(stf) != NULL) + call close (STF_PFD(stf)) + if (IM_HFD(im) != NULL) + call close (IM_HFD(im)) + + # Deallocate the STF descirptor. + call mfree (IM_KDES(im), TY_STRUCT) + status = OK +end diff --git a/sys/imio/iki/stf/stfcopy.x b/sys/imio/iki/stf/stfcopy.x new file mode 100644 index 00000000..e8643600 --- /dev/null +++ b/sys/imio/iki/stf/stfcopy.x @@ -0,0 +1,43 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stf.h" + +# STF_COPY -- Copy an image. A special operator is provided for fast, blind +# copies of entire images. + +procedure stf_copy (kernel, oroot, oextn, nroot, nextn, status) + +int kernel #I IKI kernel +char oroot[ARB] # old image root name +char oextn[ARB] # old image extn +char nroot[ARB] # new image root name +char nextn[ARB] # old image extn +int status + +pointer sp +pointer ohdr_fname, opix_fname, nhdr_fname, npix_fname + +begin + call smark (sp) + call salloc (ohdr_fname, SZ_PATHNAME, TY_CHAR) + call salloc (opix_fname, SZ_PATHNAME, TY_CHAR) + call salloc (nhdr_fname, SZ_PATHNAME, TY_CHAR) + call salloc (npix_fname, SZ_PATHNAME, TY_CHAR) + + # Generate filenames. + call iki_mkfname (oroot, oextn, Memc[ohdr_fname], SZ_PATHNAME) + call iki_mkfname (nroot, nextn, Memc[nhdr_fname], SZ_PATHNAME) + + call stf_mkpixfname (oroot, oextn, Memc[opix_fname], SZ_PATHNAME) + call stf_mkpixfname (nroot, nextn, Memc[npix_fname], SZ_PATHNAME) + + # If the header cannot be copied, leave the pixfile alone. + iferr (call fcopy (Memc[ohdr_fname], Memc[nhdr_fname])) + call erract (EA_WARN) + else iferr (call fcopy (Memc[opix_fname], Memc[npix_fname])) + call erract (EA_WARN) + + call sfree (sp) + status = OK +end diff --git a/sys/imio/iki/stf/stfcopyf.x b/sys/imio/iki/stf/stfcopyf.x new file mode 100644 index 00000000..7402c879 --- /dev/null +++ b/sys/imio/iki/stf/stfcopyf.x @@ -0,0 +1,92 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stf.h" + +define NKW 4 # number of reserved header keywords + + +# STF_COPYFITS -- Copy the spooled FITS header, separating out the GPB cards +# and returning either or both types of cards on the two output streams. + +procedure stf_copyfits (stf, spool, gpb, user) + +pointer stf #I pointer to STF descriptor +int spool #I spooled header to read +int gpb #I stream to receive GPB cards, or NULL +int user #I stream to receive user cards, or NULL + +bool keyword +int p_ch[MAX_PCOUNT+NKW] +pointer p_len[MAX_PCOUNT+NKW] +pointer p_namep[MAX_PCOUNT+NKW] +int delim, ch, npars, ngpbpars, i +pointer sp, lbuf, sbuf, pp, op, kw[NKW] +int strncmp(), getline(), strlen(), gstrcpy() +errchk getline, putline + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + call salloc (sbuf, SZ_LINE, TY_CHAR) + + # The following reserved keywords describing the GPB are added to + # the user area by stf_rdheader, and must be filtered out along with + # the group parameters. Since the number of reserved or group + # parameters is normally small (only a dozen or so typically) a + # simple 1 character - 2 thread hashing scheme is probably faster, + # and certainly simpler, than a full hash table keyword lookup. + + op = sbuf + npars = NKW + kw[1] = op; op = op + gstrcpy ("GROUPS", Memc[op], ARB) + 1 + kw[2] = op; op = op + gstrcpy ("GCOUNT", Memc[op], ARB) + 1 + kw[3] = op; op = op + gstrcpy ("PCOUNT", Memc[op], ARB) + 1 + kw[4] = op; op = op + gstrcpy ("PSIZE", Memc[op], ARB) + 1 + + do i = 1, npars { + p_namep[i] = kw[i] + p_len[i] = strlen(Memc[kw[i]]) + p_ch[i] = Memc[kw[i]+2] + } + + # Add the GPB parameters to the list of group related parameters. + ngpbpars = min (MAX_PCOUNT, STF_PCOUNT(stf)) + do i = 1, ngpbpars { + npars = npars + 1 + pp = STF_PDES(stf,i) + p_namep[npars] = P_PTYPEP(pp) + p_len[npars] = strlen(P_PTYPE(pp)) + p_ch[npars] = Memc[p_namep[npars]+2] + } + + # Determine the type of each card and copy it to the appropriate + # output stream. + + while (getline (spool, Memc[lbuf]) != EOF) { + # Does this user card redefine a reserved keyword? + keyword = false + ch = Memc[lbuf+2] + do i = 1, npars { + if (ch != p_ch[i]) + next + delim = Memc[lbuf+p_len[i]] + if (delim != ' ' && delim != '=') + next + if (strncmp (Memc[lbuf], Memc[p_namep[i]], p_len[i]) == 0) { + keyword = true + break + } + } + + # Copy the card to the appropriate stream. + if (keyword) { + if (gpb != NULL) + call putline (gpb, Memc[lbuf]) + } else { + if (user != NULL) + call putline (user, Memc[lbuf]) + } + } + + call sfree (sp) +end diff --git a/sys/imio/iki/stf/stfctype.x b/sys/imio/iki/stf/stfctype.x new file mode 100644 index 00000000..9c48f65a --- /dev/null +++ b/sys/imio/iki/stf/stfctype.x @@ -0,0 +1,85 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stf.h" + +# STF_CTYPE -- Determine the type of a FITS card. STF recognizes only those +# cards which define the image format and the group parameter block. + +int procedure stf_ctype (card, index) + +char card[ARB] #I FITS card (or keyword) +int index #O index number, if any + +int ch1, ch2, ip +int strncmp(), ctoi() + +begin + ch1 = card[1] + ch2 = card[2] + + # The set of keywords is fixed and small, so a simple brute force + # recognizer is about as good as anything. + + if (ch1 == 'B') { + if (ch2 == 'I') + if (strncmp (card, "BITPIX ", 8) == 0) + return (KW_BITPIX) # BITPIX + } else if (ch1 == 'D') { + if (ch2 == 'A') + if (strncmp (card, "DATATYPE", 8) == 0) + return (KW_DATATYPE) # DATATYPE + } else if (ch1 == 'E') { + if (ch2 == 'N') + if (card[3] == 'D' && card[4] == ' ') + return (KW_END) # END card + } else if (ch1 == 'G') { + if (ch2 == 'C') { + if (strncmp (card, "GCOUNT ", 8) == 0) + return (KW_GCOUNT) # GCOUNT + } else if (ch2 == 'R') { + if (strncmp (card, "GROUPS ", 8) == 0) + return (KW_GROUPS) # GROUPS + } + } else if (ch1 == 'N') { + if (ch2 == 'A') + if (strncmp (card, "NAXIS", 5) == 0) + if (card[6] == ' ') + return (KW_NAXIS) # NAXIS + else if (IS_DIGIT(card[6])) { + index = TO_INTEG(card[6]) + return (KW_NAXISN) # NAXISn + } + } else if (ch1 == 'P') { + if (ch2 == 'C') { + if (strncmp (card, "PCOUNT ", 8) == 0) + return (KW_PCOUNT) # PCOUNT + } else if (ch2 == 'D') { + if (strncmp (card, "PDTYPE", 6) == 0) { + ip = 7 + if (ctoi (card, ip, index) > 0) + return (KW_PDTYPE) # PDTYPEn + } + } else if (ch2 == 'S') { + if (strncmp (card, "PSIZE", 5) == 0) { + ip = 6 + if (card[ip] == ' ') + return (KW_PSIZE) + else if (ctoi (card, ip, index) > 0) + return (KW_PSIZEN) # PSIZEn + } + } else if (ch2 == 'T') { + if (strncmp (card, "PTYPE", 5) == 0) { + ip = 6 + if (ctoi (card, ip, index) > 0) + return (KW_PTYPE) # PTYPEn + } + } + } else if (ch1 == 'S') { + if (ch2 == 'I') + if (strncmp (card, "SIMPLE ", 8) == 0) + return (KW_SIMPLE) # SIMPLE + } + + return (ERR) +end diff --git a/sys/imio/iki/stf/stfdelete.x b/sys/imio/iki/stf/stfdelete.x new file mode 100644 index 00000000..dd319f12 --- /dev/null +++ b/sys/imio/iki/stf/stfdelete.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "stf.h" + +# STF_DELETE -- Delete an image. A special operator is required since the +# image is stored as two files. + +procedure stf_delete (kernel, root, extn, status) + +int kernel #I IKI kernel +char root[ARB] #I root filename +char extn[ARB] #U header file extension +int status #O return value + +pointer sp +pointer hdr_fname, pix_fname +int access() + +begin + call smark (sp) + call salloc (hdr_fname, SZ_PATHNAME, TY_CHAR) + call salloc (pix_fname, SZ_PATHNAME, TY_CHAR) + + # Generate filename. + call iki_mkfname (root, extn, Memc[hdr_fname], SZ_PATHNAME) + call stf_mkpixfname (root, extn, Memc[pix_fname], SZ_PATHNAME) + + # If the header cannot be deleted, leave the pixfile alone. + iferr (call delete (Memc[hdr_fname])) + call erract (EA_WARN) + else if (access (Memc[pix_fname],0,0) == YES) { + iferr (call delete (Memc[pix_fname])) + call erract (EA_WARN) + } + + status = OK + call sfree (sp) +end diff --git a/sys/imio/iki/stf/stfget.x b/sys/imio/iki/stf/stfget.x new file mode 100644 index 00000000..bacbc8d7 --- /dev/null +++ b/sys/imio/iki/stf/stfget.x @@ -0,0 +1,97 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stf.h" + +# STF_GETI -- Return the integer value of a FITS encoded card. + +procedure stf_geti (card, ival) + +char card[ARB] # card to be decoded +int ival # receives integer value + +int ip, ctoi() +char sval[FITS_SZVALSTR] + +begin + call stf_gets (card, sval, FITS_SZVALSTR) + ip = 1 + if (ctoi (sval, ip, ival) <= 0) + ival = 0 +end + + +# STF_GETB -- Return the boolean/integer value of a FITS encoded card. + +procedure stf_getb (card, bval) + +char card[ARB] # card to be decoded +int bval # receives YES/NO + +char sval[FITS_SZVALSTR] + +begin + call stf_gets (card, sval, FITS_SZVALSTR) + if (sval[1] == 'T') + bval = YES + else + bval = NO +end + + +# STF_GETS -- Get the string value of a FITS encoded card. Strip leading +# and trailing whitespace and any quotes. + +procedure stf_gets (card, outstr, maxch) + +char card[ARB] # FITS card to be decoded +char outstr[ARB] # output string to receive parameter value +int maxch + +int ip, op +int ctowrd(), strlen() + +begin + ip = FITS_STARTVALUE + if (ctowrd (card, ip, outstr, maxch) > 0) { + # Strip trailing whitespace. + op = strlen (outstr) + while (op > 0 && (IS_WHITE(outstr[op]) || outstr[op] == '\n')) + op = op - 1 + outstr[op+1] = EOS + } else + outstr[1] = EOS +end + + +# STF_GETCMT -- Get the comment field of a FITS encoded card. + +procedure stf_getcmt (card, comment, maxch) + +char card[ARB] #I FITS card to be decoded +char comment[ARB] #O output string to receive comment +int maxch #I max chars out + +int ip, op +int lastch + +begin + # Find the slash which marks the beginning of the comment field. + ip = FITS_ENDVALUE + 1 + while (card[ip] != EOS && card[ip] != '\n' && card[ip] != '/') + ip = ip + 1 + + # Copy the comment to the output string, omitting the /, any + # trailing blanks, and the newline. + + lastch = 0 + do op = 1, maxch { + if (card[ip] == EOS) + break + ip = ip + 1 + comment[op] = card[ip] + if (card[ip] > ' ') + lastch = op + } + comment[lastch+1] = EOS +end diff --git a/sys/imio/iki/stf/stfhextn.x b/sys/imio/iki/stf/stfhextn.x new file mode 100644 index 00000000..45e89f7a --- /dev/null +++ b/sys/imio/iki/stf/stfhextn.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "stf.h" + + +# STF_GETHDREXTN -- Get the default header file extension. + +procedure stf_gethdrextn (im, o_im, acmode, outstr, maxch) + +pointer im, o_im #I image descriptors +int acmode #I access mode +char outstr[maxch] #O receives header extension +int maxch #I max chars out + +bool inherit +int kernel, old_kernel +int fnextn(), iki_getextn(), iki_getpar() + +begin + # Use the same extension as the input file if this is a new copy + # image of the same type as the input and inherit is enabled. + # If we have to get the extension using iki_getextn, the default + # extension for a new image is the first extension defined (index=1). + + kernel = IM_KERNEL(im) + + old_kernel = 0 + if (acmode == NEW_COPY && o_im != NULL) + old_kernel = IM_KERNEL(o_im) + + inherit = (iki_getpar ("inherit") == YES) + if (inherit && acmode == NEW_COPY && kernel == old_kernel) { + if (fnextn (IM_HDRFILE(im), outstr, maxch) <= 0) + call strcpy (STF_DEFHDREXTN, outstr, maxch) + } else if (iki_getextn (kernel, 1, outstr, maxch) < 0) + call strcpy (STF_DEFHDREXTN, outstr, maxch) +end diff --git a/sys/imio/iki/stf/stfiwcs.x b/sys/imio/iki/stf/stfiwcs.x new file mode 100644 index 00000000..415b9a76 --- /dev/null +++ b/sys/imio/iki/stf/stfiwcs.x @@ -0,0 +1,60 @@ +include +include "stf.h" + +# STF_INITWCS -- Check for an unitialized WCS and set up a unitary pixel +# WCS in this case. + +procedure stf_initwcs (im) + +pointer im #I image descriptor + +real v +int ndim, i, j +bool have_wcs, wcsok +char pname[SZ_KEYWORD] +bool fp_equalr() +real imgetr() + +begin + ndim = IM_NDIM(im) + have_wcs = false + wcsok = false + + # Scan the header to determine if we have any WCS information (assume + # there is a WCS if any CDi_j cards are found) and if it has been + # initialized (at least one matrix element is nonzero). Note that + # we are checking only to see if the WCS has been initialized, not + # if it is a valid WCS. + + do j = 1, ndim { + do i = 1, ndim { + call sprintf (pname, SZ_KEYWORD, "CD%d_%d") + call pargi (i) + call pargi (j) + ifnoerr (v = imgetr (im, pname)) { + have_wcs = true + if (!fp_equalr (v, 0.0)) { + wcsok = true + break + } + } + } + if (wcsok) + break + } + + # If we found some WCS information and the CD matrix is zero, init + # the WCS. + + if (have_wcs && !wcsok) + do i = 1, ndim { + call sprintf (pname, SZ_KEYWORD, "CTYPE%d") + call pargi (i) + call imastr (im, pname, "PIXEL") + + call sprintf (pname, SZ_KEYWORD, "CD%d_%d") + call pargi (i) + call pargi (i) + call imaddr (im, pname, 1.0) + } +end diff --git a/sys/imio/iki/stf/stfmerge.x b/sys/imio/iki/stf/stfmerge.x new file mode 100644 index 00000000..a98ee877 --- /dev/null +++ b/sys/imio/iki/stf/stfmerge.x @@ -0,0 +1,105 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "stf.h" + +# STF_MERGEGPB -- Merge the non-reserved parameters from an existing GPB into +# a new GPB; called to construct a new GPB when an image is opened in new-copy +# mode. Since the new copy may not be the same size and dimension as the +# original, the reserved parameters must be set up fresh for the new copy +# image, i.e., we cannot simply copy them from the old image. Likewise, the +# WCS must be transformed if the new copy image does not geometrically overlay +# the original. +# +# NOTE: no longer called by stf_opix; save this code for future use! +# + +procedure stf_mergegpb (n_im, o_im) + +pointer n_im # new copy image +pointer o_im # image being copied + +bool match +int n_i, o_i, n, ip, axis +int up_psize +pointer sp, cd_pat, n_stf, o_stf, n_pp, o_pp +int strncmp(), strlen(), patmake(), patmatch(), ctoi() + +begin + call smark (sp) + call salloc (cd_pat, SZ_LINE, TY_CHAR) + + # Make a pattern to match the CDa_b parameter names. + if (patmake ("CD[0-9]_[0-9]", Memc[cd_pat], SZ_LINE) < 0) + ; # cannot happen + + n_stf = IM_KDES(n_im) + o_stf = IM_KDES(o_im) + + # Examine each parameter in the old GPB and make an entry for the new + # ones in the new GPB. Note that all we are doing here is defining + # the structure; the GPB data is not physically written until the new + # header is updated on disk. The FITS encoded values for the GPB + # parameters will already have been copied to the user area of the + # new image. + + up_psize = 0 + for (o_i=1; o_i <= STF_PCOUNT(o_stf); o_i=o_i+1) { + o_pp = STF_PDES(o_stf,o_i) + n = strlen (P_PTYPE(o_pp)) + + if (P_PTYPE(o_pp) == 'C') + if (strncmp (P_PTYPE(o_pp), "CRPIX", 5) == 0 || + strncmp (P_PTYPE(o_pp), "CRVAL", 5) == 0 || + strncmp (P_PTYPE(o_pp), "CTYPE", 5) == 0 || + patmatch (P_PTYPE(o_pp), Memc[cd_pat]) > 0) { + + ip = 6 + if (ctoi (P_PTYPE(o_pp), ip, axis) <= 0) + axis = IM_MAXDIM + 1 + if (axis <= STF_NAXIS(n_stf)) + next + } + + # Is there a parameter of the same name in the new descriptor? + match = false + for (n_i=1; n_i <= STF_PCOUNT(n_stf); n_i=n_i+1) { + n_pp = STF_PDES(n_stf,n_i) + if (strncmp (P_PTYPE(o_pp), P_PTYPE(n_pp), n) == 0) { + match = true + break + } + } + + # If there was no match for the parameter, add a definition for + # it to the GPB descriptor for the new image. + + if (!match) { + n = STF_PCOUNT(n_stf) + 1 + if (n > MAX_PCOUNT) + call error (4, "stf_merge: too many group parameters") + + STF_PCOUNT(n_stf) = n + up_psize = up_psize + P_PSIZE(o_pp) + n_pp = STF_PDES(n_stf,n) + + P_SPPTYPE(n_pp) = P_SPPTYPE(o_pp) + P_PSIZE(n_pp) = P_PSIZE(o_pp) + P_LEN(n_pp) = P_LEN(o_pp) + + call strcpy (P_PTYPE(o_pp), P_PTYPE(n_pp), SZ_PTYPE) + call strcpy (P_PDTYPE(o_pp), P_PDTYPE(n_pp), SZ_PDTYPE) + } + } + + # Moved the PSIZE, SZGROUP calculations here to fix error in the + # computation of PSIZE--dlb, 11/2/87 + + STF_PSIZE(n_stf) = STF_PSIZE(n_stf) + up_psize + STF_SZGROUP(n_stf) = STF_SZGROUP(n_stf) + + up_psize / (SZB_CHAR * NBITS_BYTE) + + call sfree (sp) +end diff --git a/sys/imio/iki/stf/stfmkpfn.x b/sys/imio/iki/stf/stfmkpfn.x new file mode 100644 index 00000000..4568efd8 --- /dev/null +++ b/sys/imio/iki/stf/stfmkpfn.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stf.h" + +# STF_MKPIXFNAME -- Given the root and extn fields of the image header filename, +# construct the pixel file name. The pixel file has the same root name as +# the header and the first two characters of the extension are the same as for +# the header, if a header extension was given. + +procedure stf_mkpixfname (hdr_root, hdr_extn, pixfname, maxch) + +char hdr_root[ARB] # root name of header file +char hdr_extn[ARB] # extension of header file +char pixfname[maxch] # receives pixel filename +int maxch + +int i +char pix_extn[MAX_LENEXTN] + +begin + call strcpy (STF_DEFPIXEXTN, pix_extn, MAX_LENEXTN) + if (hdr_extn[1] != EOS) { + for (i=1; i < MAX_LENEXTN; i=i+1) + pix_extn[i] = hdr_extn[i] + } + + call iki_mkfname (hdr_root, pix_extn, pixfname, maxch) +end diff --git a/sys/imio/iki/stf/stfnewim.x b/sys/imio/iki/stf/stfnewim.x new file mode 100644 index 00000000..3e8a95ed --- /dev/null +++ b/sys/imio/iki/stf/stfnewim.x @@ -0,0 +1,146 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "stf.h" + +define NBITS_CHAR (SZB_CHAR * NBITS_BYTE) + + +# STF_NEWIMAGE -- Set up the IMIO/STF descriptor for an image opened with mode +# new_image or new_copy of non-STF images. Note that the parameters GROUP +# and GCOUNT were set earlier by stf_open(). + +procedure stf_newimage (im) + +pointer im # image descriptor + +pointer stf +pointer o_im +long totpix +char pname[SZ_KEYWORD] +int old_kernel, pixtype, bitpix, nbytes, pno, ndim, i, j +errchk stf_addpar +string zero "0" +string one "1" + +include + +begin + # Get length of axes and datatype from imio descriptor; + # these may be changed by the user between image mapping + # and first i/o to pixfile so we set up the group parameter block + # and size of pixfile on first i/o operation + + stf = IM_KDES(im) + o_im = IM_OHDR(im) + ndim = IM_NDIM(im) + STF_NAXIS(stf) = ndim + do i = 1, ndim + STF_LENAXIS(stf,i) = IM_LEN(im,i) + + # Get datatype for the pixfile; stf_open has set this to datatype + # of template file if it exists, otherwise defaults to real(assuming + # the user hasn't changed it by now) + + pixtype = IM_PIXTYPE(im) + + bitpix = pix_size[pixtype] * NBITS_CHAR + nbytes = bitpix / NBITS_BYTE + + call sprintf (STF_DATATYPE(stf), SZ_DATATYPE, "%s*%d") + switch (pixtype) { + case TY_USHORT: + call pargstr ("UNSIGNED") + case TY_SHORT, TY_LONG, TY_INT: + call pargstr ("INTEGER") + case TY_REAL, TY_DOUBLE: + call pargstr ("REAL") + case TY_COMPLEX: + call pargstr ("COMPLEX") + default: + pixtype = TY_REAL + bitpix = SZ_REAL * NBITS_CHAR + nbytes = bitpix / NBITS_BYTE + call pargstr ("REAL") + } + call pargi (nbytes) + + STF_BITPIX(stf) = bitpix + + # Set the IMIO min/max fields. + + IM_MIN(im) = 0. + IM_MAX(im) = 0. + IM_LIMTIME(im) = 0 + + # For a new copy image(of an already-existing file), DO NOT add group + # parameters to the GPB, unless the original image is not an STF + # image. The following are the "standard" set of datamin/max and the + # FITS coordinate parms which SDAS files are supposed to have. + + if (IM_ACMODE(im) == NEW_COPY && o_im != NULL) + old_kernel = IM_KERNEL(o_im) + + if ((IM_ACMODE(im) == NEW_FILE) || + ((IM_ACMODE(im) == NEW_COPY) && IM_KERNEL(im) != old_kernel)) { + + # Set up the standard STF group parameter block parameters. + STF_GROUPS(stf) = YES + STF_PCOUNT(stf) = 2 + (ndim * 3) + (ndim * ndim) + STF_PSIZE(stf) = 2 * (SZ_REAL * NBITS_CHAR) + # DATAMIN/MAX + ndim * (SZ_DOUBLE * NBITS_CHAR) + # CRVALn + ndim * (SZ_REAL * NBITS_CHAR) + # CRPIXn + ndim * (8 * NBITS_BYTE) + # CTYPEn + (ndim * ndim) * (SZ_REAL * NBITS_CHAR) # CD matrix + + # Free any unneeded space in the STF descriptor. + if (STF_PCOUNT(stf) > 0) { + call realloc (stf, + LEN_STFBASE + STF_PCOUNT(stf)*LEN_PDES, TY_STRUCT) + IM_KDES(im) = stf + } + + # Set up the group data block in the STF descriptor and in + # the IMIO FITS format user area. WARNING--the STF kernel + # is implicitly assuming that the GPB related parameters + # in non-STF format images are at the beginning of the user + # area, if they are present at all. If this is not true + # then the following code will APPEND them to the user area. + # At STScI, non-STF format images are usually made from STF + # images and these parameters are at the beginning of the user + # area in that case. + + pno = 1 + call stf_addpar (im, "DATAMIN", TY_REAL, 1, zero, pno) + call stf_addpar (im, "DATAMAX", TY_REAL, 1, zero, pno) + + do i = 1, ndim { + call sprintf (pname, SZ_KEYWORD, "CRPIX%d"); call pargi (i) + call stf_addpar (im, pname, TY_REAL, 1, zero, pno) + call sprintf (pname, SZ_KEYWORD, "CRVAL%d"); call pargi (i) + call stf_addpar (im, pname, TY_DOUBLE, 1, zero, pno) + call sprintf (pname, SZ_KEYWORD, "CTYPE%d"); call pargi (i) + call stf_addpar (im, pname, TY_CHAR, 8, "PIXEL", pno) + + do j = 1, ndim { + call sprintf (pname, SZ_KEYWORD, "CD%d_%d") + call pargi (j) + call pargi (i) + if (i == j) + call stf_addpar (im, pname, TY_REAL, 1, one, pno) + else + call stf_addpar (im, pname, TY_REAL, 1, zero, pno) + } + } + } + + # Compute the size of each group in the pixel file, in chars. + totpix = IM_LEN(im,1) + do i = 2, ndim + totpix = totpix * IM_LEN(im,i) + + STF_SZGROUP(stf) = totpix * pix_size[IM_PIXTYPE(im)] + + STF_PSIZE(stf) / (SZB_CHAR * NBITS_BYTE) +end diff --git a/sys/imio/iki/stf/stfopen.x b/sys/imio/iki/stf/stfopen.x new file mode 100644 index 00000000..016c557e --- /dev/null +++ b/sys/imio/iki/stf/stfopen.x @@ -0,0 +1,225 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "stf.h" + +# STF_OPEN -- Open/create an STF group format image. + +procedure stf_open (kernel, im, o_im, + root, extn, ksection, gr_arg, gc_arg, acmode, status) + +int kernel #I IKI kernel +pointer im #I image descriptor +pointer o_im #I other descriptor for NEW_COPY image +char root[ARB] #I root image name +char extn[ARB] #I extension, if any +char ksection[ARB] #I NOT USED +int gr_arg #I index of group to be accessed +int gc_arg #I number of groups in STF image +int acmode #I access mode +int status #O return value + +bool subimage +pointer sp, fname, stf, stf_extn, ua, o_stf +int group, gcount, newimage, gpb, hdr, o_stflen + +bool fnullfile(), envgetb() +int open(), stropen(), access() +errchk stf_initwcs, fmkcopy, calloc, realloc, syserrs +define err_ 91 + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (stf_extn, MAX_LENEXTN, TY_CHAR) + + ua = IM_USERAREA(im) + + # Allocate internal STF image descriptor. + call calloc (stf, LEN_STFDES, TY_STRUCT) + IM_KDES(im) = stf + + group = max (1, gr_arg) + gcount = max (group, gc_arg) + + STF_GRARG(stf) = max (0, gr_arg) + STF_GROUP(stf) = group + STF_GCOUNT(stf) = gcount + STF_ACMODE(stf) = acmode + STF_PFD(stf) = NULL + + # If a nonzero gcount is specified when a new-image or new-copy image + # is opened (e.g., [1/10] we assume that an entire new group format + # image is to be created with the given group count. If neither the + # group or gcount values are specified we assume that a new image is + # to be created. If the gcount field is zero (e.g., [1/0] or just [1]) + # then we assume that the image already exists and that we are being + # asked to rewrite the indexed image. + + newimage = NO + if (acmode == NEW_IMAGE || acmode == NEW_COPY) + if (gc_arg > 0 || (gr_arg <= 0 && gc_arg <= 0)) + newimage = YES + STF_NEWIMAGE(stf) = newimage + + # Generate full header file name. + if (extn[1] == EOS) { + call stf_gethdrextn (im, o_im, acmode, Memc[stf_extn], MAX_LENEXTN) + call iki_mkfname (root, Memc[stf_extn], Memc[fname], SZ_PATHNAME) + call strcpy (Memc[stf_extn], extn, MAX_LENEXTN) + } else + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + + call strcpy (Memc[fname], IM_HDRFILE(im), SZ_IMHDRFILE) + + # Generate full pixel file name. + call stf_mkpixfname (root, extn, Memc[fname], SZ_PATHNAME) + call strcpy (Memc[fname], IM_PIXFILE(im), SZ_IMPIXFILE) + + # Create and open the image header file if create a new physical + # image. If opening an existing image we do not open the header file + # here since the header may already be in the STF header cache. + # Since STF header files have a weird file type on some systems (VMS) + # we must create a new header file with FMKCOPY rather than OPEN. + + if (STF_NEWIMAGE(stf) == YES && !fnullfile (IM_HDRFILE(im))) { + if (access (IM_HDRFILE(im), 0,0) == YES) { + subimage = (gr_arg > 0 && gr_arg <= gc_arg) + if (subimage || envgetb ("imclobber")) { + iferr (call delete (IM_PIXFILE(im))) + goto err_ + iferr (call delete (IM_HDRFILE(im))) + goto err_ + } else { + call mfree (stf, TY_STRUCT) + call syserrs (SYS_IKICLOB, IM_HDRFILE(im)) + } + } + iferr (call fmkcopy (HDR_TEMPLATE, IM_HDRFILE(im))) + goto err_ + iferr (IM_HFD(im) = open (IM_HDRFILE(im), READ_WRITE, TEXT_FILE)) + goto err_ + } + + # If opening an existing image, read the image header into the STF + # image descriptor. + + switch (acmode) { + case NEW_IMAGE: + # For group formatted images, open NEW_IMAGE can mean either + # creating a new group format image, or opening a new group + # within an existing group format image. The latter case is + # indicated by a group index greater than 1. If we are creating + # a new group format image, wait until the user has set up the + # dimension parameters before doing anything further (in stfopix). + + if (STF_NEWIMAGE(stf) == NO) + iferr (call stf_rdheader (im, group, acmode)) + goto err_ + + case NEW_COPY: + # Make sure the FITS encoded user area we inherited is blocked. + + ### For now, always reblock the old header as the blocked flag + ### does not seem to be reliable and a header with variable length + ### lines can cause the header update to fail. This should be + ### fixed as a reblock of the full header is expensive. + + ### if (IM_UABLOCKED(o_im) != YES) + call stf_reblock (im) + + if (STF_NEWIMAGE(stf) == NO) { + # Open new group within existing GF image. The FITS header and + # GPB structure of the image being opened must be used, but the + # default data values for the GPB parameters are inherited from + # the image being copied. + + # Filter the copied user area to retain only the GPB cards. + # Opening the user area on two string file descriptors is a + # bit tricky, but will work since fixed size cards are copied, + # and the EOS isn't written until close time. + + if (IM_KDES(o_im) != NULL && IM_KERNEL(o_im) == IM_KERNEL(im)) { + hdr = stropen (Memc[ua], ARB, READ_ONLY) + gpb = stropen (Memc[ua], ARB, NEW_FILE) + call stf_copyfits (IM_KDES(o_im), hdr, gpb, NULL) + call close (gpb) + call close (hdr) + } + + # Read in the FITS header of the new image after the inherited + # GPB data cards, and set up the STF descriptor for the new GPB + # as defined in the new FITS header. + + iferr (call stf_rdheader (im, group, acmode)) + goto err_ + + # Initialize the WCS description if this is not done by the + # inherited user header. + + call stf_initwcs (im) + + } else { + # Completely new copy of an existing image, which may or may + # not be an STF format image. IMIO has already copied the + # size parameters of the old image as well as the cards in the + # user area of the old image (but without leaving space for + # the GPB cards if not an STF image). Copy old STF descriptor + # if the old image is also an STF format image, to inherit + # GPB structure. Wait until opix time to init the rest of the + # descriptor. + + if (IM_KDES(o_im) != NULL && IM_KERNEL(o_im) == IM_KERNEL(im)) { + o_stf = IM_KDES(o_im) + o_stflen = LEN_STFBASE + STF_PCOUNT(o_stf) * LEN_PDES + call amovi (Memi[o_stf], Memi[stf], o_stflen) + STF_ACMODE(stf) = acmode + STF_GROUP(stf) = group + STF_GCOUNT(stf) = gcount + STF_NEWIMAGE(stf) = newimage + STF_PFD(stf) = NULL + if (gcount > 1) + STF_GROUPS(stf) = YES + } else + STF_GROUPS(stf) = YES + + # Inherit datatype of input template image if specified, + # otherwise default datatype to real. + + if (IM_PIXTYPE(o_im) != NULL) + IM_PIXTYPE(im) = IM_PIXTYPE(o_im) + else + IM_PIXTYPE(im) = TY_REAL + } + + default: + # Open an existing group within an existing image. + iferr (call stf_rdheader (im, group, acmode)) + goto err_ + } + + # Set group number and count for the external world if this is a group + # format image. + + if (STF_GROUPS(stf) == YES) { + IM_CLINDEX(im) = STF_GROUP(stf) + IM_CLSIZE(im) = STF_GCOUNT(stf) + } + + # Free any unneeded space in the STF descriptor. + if (STF_PCOUNT(stf) > 0) + call realloc (stf, + LEN_STFBASE + STF_PCOUNT(stf)*LEN_PDES, TY_STRUCT) + IM_KDES(im) = stf + status = OK + + call sfree (sp) + return +err_ + status = ERR + call mfree (stf, TY_STRUCT) + call sfree (sp) +end diff --git a/sys/imio/iki/stf/stfopix.x b/sys/imio/iki/stf/stfopix.x new file mode 100644 index 00000000..da353119 --- /dev/null +++ b/sys/imio/iki/stf/stfopix.x @@ -0,0 +1,202 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include "stf.h" + +define NBITS_CHAR (SZB_CHAR * NBITS_BYTE) + +# STF_OPIX -- Open (or create) the pixel storage file. If the image header file +# is `image.hhh' the associated pixel storage file will be `image.hhd' in the +# same directory as the header file. STF_PFD is set if the pixel file is +# physically open. IM_PFD is not set until we have been called by IMIO, since +# we must be called to once set up all the descriptors, even if the pixel file +# was already opened to read the GPB. +# +# dlb, 18-may-88: added code to zero out gpb's in multi-group image for groups +# other than current; prevents strange numbers and when later programs try to +# read the gpb of an otherwise uninitialized group of the image. +# dlb, 29-dec-1988: added code to get default set of GPB parameters and +# correctly initialize STF-kernel descriptor. + +procedure stf_opix (im, status) + +pointer im # image descriptor +int status # return status + +int compress, blklen +bool copy_of_stf_image +int pfd, sz_gpb, group, i +pointer stf, o_stf, o_im, ua, gpb +long sz_pixfile, pixoff, totpix, offset + +int open() +errchk open, fseti, falloc, seek, syserrs, imioff, calloc +errchk write + +include + +begin + status = OK + if (IM_PFD(im) != NULL) + return + + o_im = IM_OHDR(im) + stf = IM_KDES(im) + ua = IM_USERAREA(im) + + pfd = STF_PFD(stf) + compress = YES + blklen = 1 + pixoff = 1 + + switch (IM_ACMODE(im)) { + case READ_ONLY, READ_WRITE, WRITE_ONLY, APPEND: + if (pfd == NULL) + pfd = open (IM_PIXFILE(im), IM_ACMODE(im), BINARY_FILE) + + case NEW_COPY, NEW_FILE: + # Initialize the IMIO and STF descriptors and allocate the pixel + # file. + + if (STF_NEWIMAGE(stf) == YES) { + # Normalize IMIO header parameters for new image. + call imioff (im, pixoff, compress, blklen) + + # Set up the required GPB parameters for the new image. + # Note - this call can change the STF pointer. + + call stf_newimage (im) + stf = IM_KDES(im) + + # Save the size of the old GPB user area header if we are + # making a new copy of an old STF format image. + + copy_of_stf_image = false + if (IM_ACMODE(im) == NEW_COPY && o_im != NULL) + if (IM_KERNEL(o_im) == IM_KERNEL(im)) + copy_of_stf_image = true + + if (copy_of_stf_image) { + o_stf = IM_KDES(o_im) + STF_PCOUNT(stf) = STF_PCOUNT(o_stf) + STF_PSIZE(stf) = STF_PSIZE(o_stf) + } + +# Since the stf_mergegpb code below has been deactivated, +# there is no need to do the complex and expensive spool/copy +# operation below. (dct 1/4/90) +# ------------------------------- +# # We have to have space for the GPB data cards at the beginning +# # of the user area, so spool any existing user cards in a +# # buffer and truncate the user area at the end of the GPB. +# +# ua_fd = stropen (Memc[ua+sz_gpbhdr], ARB, READ_ONLY) +# spool = open ("opix_spool", READ_WRITE, SPOOL_FILE) +# call fcopyo (ua_fd, spool) +# call close (ua_fd) +# Memc[ua+sz_gpbhdr] = EOS +# +# # Merge any extra GPB parameters from the old image into the +# # GPB structure of the new image. The GPB data cards for +# # these parameters should already be in the user area. +# # Order the group parameters to match the ordering in the +# # old image. NOTE: since the STF now copies all relevant +# # GPB parameters from an old image into the new or +# # generates a default standard set (in stf_newimage), +# # the following is no longer necessary. Note that if we +# # eventually may add parameters to the GPB, these routines +# # will again be useful! +# +# #if (copy_of_stf_image) { +# # call stf_mergegpb (im, o_im) +# # call stf_ordergpb (o_stf, stf) +# #} +# +# # Now append the spooled user header cards to the new user +# # area following the GPB data cards, deleting any user cards +# # which redefine GPB cards in the process. +# +# call seek (spool, BOFL) +# ua_size = (IM_LENHDRMEM(im) - LEN_IMHDR) * SZ_STRUCT +# ua_fd = stropen (Memc[ua], ua_size, APPEND) +# call stf_copyfits (stf, spool, NULL, ua_fd) +# call close (ua_fd) +# call close (spool) +# +# # Compute the length of the new header +# IM_HDRLEN(im) = LEN_IMHDR + +# (strlen(Memc[ua]) + SZ_STRUCT-1) / SZ_STRUCT + + # Open the new pixel storage file (preallocate space if + # enabled on local system). Save the physical pathname of + # the pixfile in the image header, in case "imdir$" changes. + + sz_pixfile = STF_SZGROUP(stf) * STF_GCOUNT(stf) + call falloc (IM_PIXFILE(im), sz_pixfile) + + # Zero out all remaining groups of the image + # Open pixel file if not already open + + if (STF_PFD(stf) == NULL) + pfd = open (IM_PIXFILE(im), READ_WRITE, BINARY_FILE) + + # Allocate a zeroed block of memory whose length is the same + # as that of the group parameter block + + sz_gpb = STF_PSIZE(stf) / NBITS_BYTE / SZB_CHAR + call calloc (gpb, sz_gpb, TY_CHAR) + + # Zero out every group except the current one. + do group = 1, STF_GCOUNT(stf) { + if (group != STF_GROUP(stf)) { + offset = (group * STF_SZGROUP(stf) + 1) - sz_gpb + call seek (pfd, offset) + call write (pfd, Memc[gpb], sz_gpb) + } + } + + # Free the block of memory. + call mfree (gpb, TY_CHAR) + + } else { + # If we are writing to a group of an existing multigroup image, + # verify that the important image parameters have not been + # changed. + + if (STF_NAXIS(stf) != IM_NDIM(im)) + call syserrs (SYS_IMGSZNEQ, IM_NAME(im)) + do i = 1, IM_NDIM(im) + if (STF_LENAXIS(stf,i) != IM_LEN(im,i)) + call syserrs (SYS_IMGSZNEQ, IM_NAME(im)) + + # Added 5/15/87--dlb to get correct size of each data portion + # of a group if image opened NEW_COPY and input file was a + # template of a different dimensionality used to get GPB. + # Compute the size of each group in the pixel file, in chars. + + totpix = IM_LEN(im,1) + do i = 2, IM_NDIM(im) + totpix = totpix * IM_LEN(im,i) + + STF_SZGROUP(stf) = totpix * pix_size[IM_PIXTYPE(im)] + + STF_PSIZE(stf) / (SZB_CHAR * NBITS_BYTE) + } + + if (pfd == NULL) + pfd = open (IM_PIXFILE(im), READ_WRITE, BINARY_FILE) + + # Tell IMIO where the pixels are. + pixoff = (STF_GROUP(stf) - 1) * STF_SZGROUP(stf) + 1 + call imioff (im, pixoff, compress, blklen) + + default: + call imerr (IM_NAME(im), SYS_IMACMODE) + } + + STF_PFD(stf) = pfd + IM_PFD(im) = pfd +end diff --git a/sys/imio/iki/stf/stfordgpb.x b/sys/imio/iki/stf/stfordgpb.x new file mode 100644 index 00000000..7099e106 --- /dev/null +++ b/sys/imio/iki/stf/stfordgpb.x @@ -0,0 +1,64 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stf.h" + +# STF_ORDERGPB -- Order the GPB, putting the group parameters in the +# new image in the same order as in the old image. +# NOTE: no longer called by stf_opix; save this code for future use! +# + +procedure stf_ordergpb (o_stf, n_stf) + +pointer o_stf # STF descriptor of old image +pointer n_stf # STF descriptor of new image + +pointer sp, temp_pdes, pp, o_plist, n_plist +int o_pcount, n_pcount, otop, ntop, op, np, offset, sz_param, pn +bool streq() + +begin + o_pcount = STF_PCOUNT(o_stf) + n_pcount = STF_PCOUNT(n_stf) + if (o_pcount <= 0) + return + + call smark (sp) + call salloc (temp_pdes, LEN_PDES, TY_STRUCT) + + o_plist = STF_PDES(o_stf,1) + n_plist = STF_PDES(n_stf,1) + otop = (o_pcount * LEN_PDES) + ntop = (n_pcount * LEN_PDES) + + # Search the new parameter list for a parameter with the same name + # as a parameter in the old parameter list. When a match is found, + # move the new parameter into the same position as it is in the + # old parameter list. + + for (op=0; op < otop; op=op+LEN_PDES) + for (np=op; np < ntop; np=np+LEN_PDES) + if (streq (P_PTYPE(o_plist+op), P_PTYPE(n_plist+np))) { + if (op != np) { + # Swap parameters between old and new positions + call amovi (Memi[n_plist+op], Memi[temp_pdes], + LEN_PDES) + call amovi (Memi[n_plist+np], Memi[n_plist+op], + LEN_PDES) + call amovi (Memi[temp_pdes], Memi[n_plist+np], + LEN_PDES) + } + break + } + + # Update the field offsets. + offset = 0 + for (pn=1; pn <= n_pcount; pn=pn+1) { + pp = STF_PDES(n_stf,pn) + P_OFFSET(pp) = offset + sz_param = P_PSIZE(pp) / NBITS_BYTE / SZB_CHAR + offset = offset + sz_param + } + + call sfree (sp) +end diff --git a/sys/imio/iki/stf/stfrdhdr.x b/sys/imio/iki/stf/stfrdhdr.x new file mode 100644 index 00000000..2c11fec9 --- /dev/null +++ b/sys/imio/iki/stf/stfrdhdr.x @@ -0,0 +1,186 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "stf.h" + +# STF_RDHEADER -- Read the STF format image header for a single group into the +# IMIO descriptor. The standard fields are processed into the fields of the +# descriptor. The GPB binary parameters are encoded as FITS cards and placed +# in the IMIO user area, followed by all extra cards in the FITS format STF +# group header. Note that no distinction is made between the common FITS +# keywords and the GPB group parameters at the IMIO level and above. + +procedure stf_rdheader (im, group, acmode) + +pointer im # image descriptor +int group # group to be accessed +int acmode # access mode + +long pixoff +long fi[LEN_FINFO] +real datamin, datamax +pointer sp, stf, lbuf, root, extn, op +int compress, devblksz, ival, ch, i , junk +int fits, fitslen, sz_userarea, sz_gpbhdr, len_hdrmem +long totpix, mtime, ctime + +real imgetr() +int fnroot(), strlen(), finfo(), imaccf() +errchk stf_rfitshdr, stf_rgpb, open, realloc, imaddb, imaddi, imgetr + +include + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + call salloc (root, SZ_FNAME, TY_CHAR) + call salloc (extn, SZ_FNAME, TY_CHAR) + + stf = IM_KDES(im) + + # Read the FITS header, setting the values of all reserved fields + # in the STF descriptor and saving all the user FITS cards in the + # save buffer "fits". + + call stf_rfitshdr (im, fits, fitslen) + + # Process the reserved keywords (set in the STF descriptor) into the + # corresponding fields of the IMIO descriptor. + + # Set group keywords if STF_GROUPS is NO (BPS 12.06.91). + if (STF_GROUPS(stf) == NO) { + STF_GCOUNT(stf) = 1 + STF_PCOUNT(stf) = 0 + STF_PSIZE(stf) = 0 + } + + if (acmode != NEW_COPY) { + IM_NDIM(im) = STF_NAXIS(stf) # IM_NDIM + do ival = 1, IM_MAXDIM # IM_LEN + IM_LEN(im,ival) = STF_LENAXIS(stf,ival) + } + + ch = STF_DATATYPE(stf) # IM_PIXTYPE + switch (STF_BITPIX(stf)) { + case 16: + if (ch == 'U') + ival = TY_USHORT + else + ival = TY_SHORT + case 32: + if (ch == 'R') + ival = TY_REAL + else + ival = TY_LONG + case 64: + if (ch == 'R') + ival = TY_DOUBLE + else + ival = TY_COMPLEX + default: + ival = ERR + } + IM_PIXTYPE(im) = ival + + call iki_parse (IM_HDRFILE(im), Memc[root], Memc[extn]) + call stf_mkpixfname (Memc[root], Memc[extn], IM_PIXFILE(im), + SZ_IMPIXFILE) + + if (finfo (IM_PIXFILE(im), fi) != ERR) { + mtime = FI_MTIME(fi) + ctime = FI_CTIME(fi) + } + + IM_NBPIX(im) = 0 # no. bad pixels + IM_CTIME(im) = ctime # creation time + IM_MTIME(im) = mtime # modify time + IM_LIMTIME(im) = mtime - 1 # time max/min last updated + IM_UABLOCKED(im) = YES # ua cards blocked to 80 chars + + IM_HISTORY(im) = EOS + junk = fnroot (IM_HDRFILE(im), Memc[lbuf], SZ_LINE) + call strupr (Memc[lbuf]) + call sprintf (IM_TITLE(im), SZ_IMTITLE, "%s[%d/%d]") + call pargstr (Memc[lbuf]) + call pargi (STF_GROUP(stf)) + call pargi (STF_GCOUNT(stf)) + + # Compute the size of each group in the pixel file, in chars. + totpix = IM_LEN(im,1) + do i = 2, IM_NDIM(im) + totpix = totpix * IM_LEN(im,i) + + STF_SZGROUP(stf) = totpix * pix_size[IM_PIXTYPE(im)] + + STF_PSIZE(stf) / (SZB_CHAR * NBITS_BYTE) + + # Write GPB related cards to the beginning of the IMIO user area. + call imaddb (im, "GROUPS", STF_GROUPS(stf) == YES) + call imaddi (im, "GCOUNT", STF_GCOUNT(stf)) + call imaddi (im, "PCOUNT", STF_PCOUNT(stf)) + call imaddi (im, "PSIZE", STF_PSIZE(stf)) + + # Extract the group parameter block from the pixfile, encoding the + # group parameters as FITS cards and appending to the cards above. + # Get the values of DATAMIN and DATAMAX from the GPB so that we can + # update the IMIO min/max fields. + + call stf_rgpb (im, group, acmode, datamin, datamax) + + # Reallocate the image descriptor to allow space for the spooled user + # FITS cards plus a little extra for new parameters. + + sz_gpbhdr = strlen (Memc[IM_USERAREA(im)]) + sz_userarea = sz_gpbhdr + fitslen + SZ_EXTRASPACE + + IM_HDRLEN(im) = LEN_IMHDR + + (sz_userarea - SZ_EXTRASPACE + SZ_MII_INT-1) / SZ_MII_INT + len_hdrmem = LEN_IMHDR + + (sz_userarea+1 + SZ_MII_INT-1) / SZ_MII_INT + + if (IM_LENHDRMEM(im) < len_hdrmem) { + IM_LENHDRMEM(im) = len_hdrmem + call realloc (im, IM_LENHDRMEM(im) + LEN_IMDES, TY_STRUCT) + } + + # Append the saved FITS cards from the STF header to the user area. + # Any cards which redefine GPB cards were already deleted when the + # fits save buffer was created (we don't want the GPB cards since + # we already output a FITS card for each GPB parameter above). + + op = IM_USERAREA(im) + sz_gpbhdr + call amovc (Memc[fits], Memc[op], fitslen+1) + + # Set the IMIO min/max fields. If the GPB datamin >= datamax the + # values are invalidated by setting IM_LIMTIME to before the image + # modification time. Although datamin/datamax were returned by + # stg_rgpb above, we refetch the values here to pick up the values + # from the spooled main header in case there were no entries for + # these keywords in the GPB (if there are values in the GPB they + # will override those in the main header). + + if (imaccf (im, "DATAMIN") == YES) + datamin = imgetr (im, "DATAMIN") + if (imaccf (im, "DATAMAX") == YES) + datamax = imgetr (im, "DATAMAX") + + IM_MIN(im) = datamin + IM_MAX(im) = datamax + if (datamin < datamax) + IM_LIMTIME(im) = IM_MTIME(im) + 1 + else + IM_LIMTIME(im) = IM_MTIME(im) - 1 + + # Call up IMIO set set up the remaining image header fields used to + # define the physical offsets of the pixels in the pixfile. + + compress = YES # do not align image lines on blocks + devblksz = 1 # disable all alignment + + pixoff = (group - 1) * STF_SZGROUP(stf) + 1 + call imioff (im, pixoff, compress, devblksz) + + call sfree (sp) +end diff --git a/sys/imio/iki/stf/stfreblk.x b/sys/imio/iki/stf/stfreblk.x new file mode 100644 index 00000000..9519bd08 --- /dev/null +++ b/sys/imio/iki/stf/stfreblk.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "stf.h" + +# STF_REBLOCK -- If the user area is not blocked to fixed length records, e.g., +# as is possible in a new copy image, reblock it fixed length. + +procedure stf_reblock (im) + +pointer im # image descriptor + +pointer sp, lbuf, op, ua +int fd, spool, nlines, nchars, sz_userarea, len_hdrmem +errchk stropen, open, getline, putline, realloc, seek, fcopyo +int open(), stropen(), getline() + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + ua = IM_USERAREA(im) + fd = stropen (Memc[ua], ARB, READ_ONLY) + spool = open ("rb_spool", READ_WRITE, SPOOL_FILE) + + # Reblock into a spool file, counting the lines. + for (nlines=0; ; nlines=nlines+1) { + nchars = getline (fd, Memc[lbuf]) + if (nchars <= 0) + break + + for (op=nchars; op <= FITS_RECLEN; op=op+1) + Memc[lbuf+op-1] = ' ' + Memc[lbuf+FITS_RECLEN] = '\n' + Memc[lbuf+FITS_RECLEN+1] = EOS + + call putline (spool, Memc[lbuf]) + } + + call close (fd) + + # Reallocate header the right size. + sz_userarea = nlines * (FITS_RECLEN+1) + SZ_EXTRASPACE + + IM_HDRLEN(im) = LEN_IMHDR + + (sz_userarea - SZ_EXTRASPACE + SZ_MII_INT-1) / SZ_MII_INT + len_hdrmem = LEN_IMHDR + + (sz_userarea+1 + SZ_MII_INT-1) / SZ_MII_INT + + if (IM_LENHDRMEM(im) < len_hdrmem) { + IM_LENHDRMEM(im) = len_hdrmem + call realloc (im, IM_LENHDRMEM(im) + LEN_IMDES, TY_STRUCT) + } + + # Move spooled data back to user area. + ua = IM_USERAREA(im) + fd = stropen (Memc[ua], sz_userarea, NEW_FILE) + call seek (spool, BOFL) + call fcopyo (spool, fd) + + call close (fd) + call close (spool) + call sfree (sp) +end diff --git a/sys/imio/iki/stf/stfrename.x b/sys/imio/iki/stf/stfrename.x new file mode 100644 index 00000000..0d3c43fd --- /dev/null +++ b/sys/imio/iki/stf/stfrename.x @@ -0,0 +1,49 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "stf.h" + +# STF_RENAME -- Rename an image. A special operator is required since the image +# is stored as two files. +# +# [NOTE] - Name changed to `rname' rather than `rename' to avoid a name +# collision with the SYMTAB procedure `stfree' (first such collision!). + +procedure stf_rname (kernel, oroot, oextn, nroot, nextn, status) + +int kernel #I IKI kernel +char oroot[ARB] # old image root name +char oextn[ARB] # old image extn +char nroot[ARB] # new image root name +char nextn[ARB] # old image extn +int status + +pointer sp +pointer ohdr_fname, opix_fname, nhdr_fname, npix_fname +bool streq() + +begin + call smark (sp) + call salloc (ohdr_fname, SZ_PATHNAME, TY_CHAR) + call salloc (opix_fname, SZ_PATHNAME, TY_CHAR) + call salloc (nhdr_fname, SZ_PATHNAME, TY_CHAR) + call salloc (npix_fname, SZ_PATHNAME, TY_CHAR) + + # Generate filenames. + call iki_mkfname (oroot, oextn, Memc[ohdr_fname], SZ_PATHNAME) + call iki_mkfname (nroot, nextn, Memc[nhdr_fname], SZ_PATHNAME) + + if (!streq (Memc[ohdr_fname], Memc[nhdr_fname])) { + call stf_mkpixfname (oroot, oextn, Memc[opix_fname], SZ_PATHNAME) + call stf_mkpixfname (nroot, nextn, Memc[npix_fname], SZ_PATHNAME) + + # If the header cannot be renamed, don't leave the pixfile alone. + iferr (call rename (Memc[ohdr_fname], Memc[nhdr_fname])) + call erract (EA_WARN) + else iferr (call rename (Memc[opix_fname], Memc[npix_fname])) + call erract (EA_WARN) + } + + call sfree (sp) + status = OK +end diff --git a/sys/imio/iki/stf/stfrfits.x b/sys/imio/iki/stf/stfrfits.x new file mode 100644 index 00000000..8ec9e9b0 --- /dev/null +++ b/sys/imio/iki/stf/stfrfits.x @@ -0,0 +1,266 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include "stf.h" + +# STF_RFITSHDR -- Read a STF FITS image header, processing all reserved GPB +# definition keywords into the STF descriptor in the image descriptor, and +# saving the remaining cards (excluding cards which GPB keyword names) in +# in a save buffer. +# +# This routine implements a simple cache of FITS headers. If a given header +# is already in the cache and the cached entry is up to date, the cached +# spool file containing the user FITS cards and the saved STF descriptor are +# returned immediately without need to access the header file on disk. +# Otherwise, the new header is read into the oldest cache slot and the cached +# entry returned in the usual fashion. Any modifications to the header file +# which affect the file modify date will invalidate the cached entry. Note +# that multiple processes may cache the same header, so it is not permitted +# to modify the cached entry once the header file has been read. +# +# The following reserved keywords are recognized: +# +# SIMPLE BITPIX DATATYPE NAXIS* GROUPS GCOUNT PCOUNT PSIZE +# PTYPE* PDTYPE* PSIZE* +# +# All unrecognized cards, including HISTORY and COMMENT cards, blank lines, +# and any other garbage in the header, are preserved in the user area of the +# IMIO descriptor (i.e., in the spoolfile). Certain of the standard reserved +# cards (GROUPS, GCOUNT, etc.) are saved in the IMIO user area for the sake +# of the user, although the real values of these parameters are maintained only +# in the STF descriptor. + +procedure stf_rfitshdr (im, fits, fitslen) + +pointer im #I image descriptor +pointer fits #O pointer to saved FITS cards +int fitslen #O length of FITS save area + +long fi[LEN_FINFO] +pointer sp, pp, stf, o_stf, lbuf, op, hdrfile +int in, index, nchars, spool, slot, user, i + +bool streq() +long clktime(), fstatl() +int envgeti(), stf_ctype(), finfo(), getline(), open(), stropen() +errchk getline, putline, syserrs, open, seek, calloc, realloc +errchk fpathname, malloc, stf_copyfits + +bool initialized # CACHE definitions... +bool reload # reload cache +int rf_refcount # reference count +int rf_cachesize # number of cache slots +pointer rf_stf[MAX_CACHE] # STF descriptor +int rf_lru[MAX_CACHE] # lowest value is oldest slot +long rf_time[MAX_CACHE] # time when entry was cached +long rf_mtime[MAX_CACHE] # modify time of file in cache +int rf_fits[MAX_CACHE] # FITS data +int rf_fitslen[MAX_CACHE] # size of data area +char rf_fname[SZ_PATHNAME,MAX_CACHE] # header file pathname +data initialized /false/ + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + call salloc (hdrfile, SZ_PATHNAME, TY_CHAR) + + # Initialize the header file cache on the first call. + if (!initialized) { + rf_refcount = 0 + do i = 1, MAX_CACHE + rf_stf[i] = 0 + + iferr (rf_cachesize = envgeti (ENV_STFCACHE)) + rf_cachesize = DEF_CACHE + if (rf_cachesize > MAX_CACHE) { + call eprintf ("A maximum of %d STF headers may be cached\n") + call pargi (MAX_CACHE) + rf_cachesize = MAX_CACHE + } else if (rf_cachesize <= 0) + rf_cachesize = 0 + + initialized = true + } + + rf_refcount = rf_refcount + 1 + o_stf = IM_KDES(im) + reload = false + slot = 1 + + # Get file system info on the desired header file. + call fpathname (IM_HDRFILE(im), Memc[hdrfile], SZ_PATHNAME) + if (finfo (Memc[hdrfile], fi) == ERR) + call syserrs (SYS_FOPEN, IM_HDRFILE(im)) + + repeat { + # Search the header file cache for the named image. + do i = 1, max(1,rf_cachesize) { + if (rf_stf[i] == NULL) { + slot = i + next + } + + if (streq (Memc[hdrfile], rf_fname[1,i])) { + # File is in cache; is cached entry still valid? + if (FI_MTIME(fi) != rf_mtime[i]) { + # File modify date has changed, reuse slot. + slot = i + break + + } else if (!reload && clktime(rf_time[i]) < 2) { + # The file modify date has not changed, but the cache + # was loaded within the last clock "tick" (second), + # so we cannot be sure that the file was not modified. + # The cache must be reloaded, but set a flag so that + # rf_time is not changed, so that when the cache entry + # ages sufficiently it will be considered valid. + + reload = true + slot = i + break + + } else { + # Return the cached header. + rf_lru[i] = rf_refcount + call amovi (STF_CACHE(rf_stf[i]), STF_CACHE(o_stf), + STF_CACHELEN(rf_stf[i])) + fits = rf_fits[i] + fitslen = rf_fitslen[i] + + # Invalidate entry if cache is disabled. + if (rf_cachesize <= 0) + rf_time[i] = 0 + + call sfree (sp) + return # IN CACHE + } + + } else { + # Keep track of least recently used slot. + if (rf_lru[i] < rf_lru[slot]) + slot = i + } + } + + # Either the image header is not in the cache, or the cached + # entry is invalid. Prepare the given cache slot and read the + # header into it. + + # Free old save buffer and descriptor. + if (rf_stf[slot] != NULL) { + call mfree (rf_stf[slot], TY_STRUCT) + call mfree (rf_fits[slot], TY_CHAR) + } + + # Open the header file. + if (IM_HFD(im) == NULL) + in = open (Memc[hdrfile], READ_ONLY, TEXT_FILE) + else { + in = IM_HFD(im) + call seek (in, BOFL) + } + + # Allocate a spool file for the FITS data. + call sprintf (rf_fname[1,slot], SZ_PATHNAME, "STFHC#%d") + call pargi (slot) + spool = open (rf_fname[1,slot], READ_WRITE, SPOOL_FILE) + call fseti (spool, F_BUFSIZE, FI_SIZE(fi)) + + # Allocate cache version of STF descriptor. + call calloc (stf, LEN_STFDES, TY_STRUCT) + + # Initialize the cache entry. + call strcpy (Memc[hdrfile], rf_fname[1,slot], SZ_PATHNAME) + rf_stf[slot] = stf + rf_lru[slot] = rf_refcount + rf_mtime[slot] = FI_MTIME(fi) + if (!reload) + rf_time[slot] = clktime (0) + reload = true + + # Read successive lines of the FITS header. Process reserved + # keywords into the STF descriptor and spool the remaining cards + # to the fits spool file. + + repeat { + # Get the next input line. + nchars = getline (in, Memc[lbuf]) + if (nchars == EOF) + break + + # Block it out to 80 chars (plus newline) if it is not already. + if (nchars != FITS_RECLEN + 1) { + for (op=nchars; op <= FITS_RECLEN; op=op+1) + Memc[lbuf+op-1] = ' ' + Memc[lbuf+FITS_RECLEN] = '\n' + Memc[lbuf+FITS_RECLEN+1] = EOS + } + + # Process the header card. + switch (stf_ctype (Memc[lbuf], index)) { + case KW_BITPIX: + call stf_geti (Memc[lbuf], STF_BITPIX(stf)) + case KW_DATATYPE: + call stf_gets (Memc[lbuf], STF_DATATYPE(stf), SZ_DATATYPE) + case KW_END: + break + case KW_GCOUNT: + call stf_geti (Memc[lbuf], STF_GCOUNT(stf)) + case KW_GROUPS: + call stf_getb (Memc[lbuf], STF_GROUPS(stf)) + case KW_NAXIS: + call stf_geti (Memc[lbuf], STF_NAXIS(stf)) + case KW_NAXISN: + call stf_geti (Memc[lbuf], STF_LENAXIS(stf,index)) + case KW_PCOUNT: + call stf_geti (Memc[lbuf], STF_PCOUNT(stf)) + case KW_PDTYPE: + pp = STF_PDES(stf,min(index,MAX_PCOUNT)) + call stf_gets (Memc[lbuf], P_PDTYPE(pp), SZ_PDTYPE) + case KW_PSIZE: + call stf_geti (Memc[lbuf], STF_PSIZE(stf)) + case KW_PSIZEN: + pp = STF_PDES(stf,min(index,MAX_PCOUNT)) + call stf_geti (Memc[lbuf], P_PSIZE(pp)) + case KW_PTYPE: + pp = STF_PDES(stf,min(index,MAX_PCOUNT)) + call stf_gets (Memc[lbuf], P_PTYPE(pp), SZ_PTYPE) + call stf_getcmt (Memc[lbuf], P_COMMENT(pp), SZ_COMMENT) + case KW_SIMPLE: + ; + default: + call putline (spool, Memc[lbuf]) + } + } + + # Close the header file if opened locally. + if (IM_HFD(im) == NULL) + call close (in) + + # Free any unneeded space in the STF descriptor. + if (STF_PCOUNT(stf) > 0) { + call realloc (stf, + LEN_STFBASE + STF_PCOUNT(stf)*LEN_PDES, TY_STRUCT) + rf_stf[slot] = stf + } + + # Filter the spooled FITS cards to delete any cards which redefine + # GPB keywords. Store the filtered FITS data in the cache. + + call seek (spool, BOFL) + nchars = fstatl (spool, F_FILESIZE) + call malloc (fits, nchars, TY_CHAR) + user = stropen (Memc[fits], nchars, NEW_FILE) + call stf_copyfits (stf, spool, NULL, user) + + rf_fits[slot] = fits + rf_fitslen[slot] = fstatl (user, F_FILESIZE) + call close (user) + call close (spool) + } +end diff --git a/sys/imio/iki/stf/stfrgpb.x b/sys/imio/iki/stf/stfrgpb.x new file mode 100644 index 00000000..15c4da0a --- /dev/null +++ b/sys/imio/iki/stf/stfrgpb.x @@ -0,0 +1,179 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "stf.h" + +# STF_RGPB -- Read the group data block into the first few cards of the user +# area of the IMIO image header. The GPB is stored as a binary data structure +# in the STF pixfile. The values of the standard GPB parameters DATAMIN and +# DATAMAX are returned as output arguments. +# +# DLB--11/03/87: Made changes to allow i*2 and i*4 integer parameters in GPB. +# DLB--11/11/87: Changed calculation of character string length in GPB to +# avoid integer truncation error by using P_PSIZE directly. + +procedure stf_rgpb (im, group, acmode, datamin, datamax) + +pointer im # IMIO image descriptor +int group # group to be accessed +int acmode # image access mode +real datamin, datamax # min,max pixel values from GPB + +real rval +double dval +short sval +long lval, offset +bool bval, newgroup +pointer sp, stf, gpb, lbuf, pp +int pfd, pn, sz_param, sz_gpb +errchk imaddb, imadds, imaddl, imaddr, imaddd, imastr +errchk imputd, impstr, open, read +int open(), read(), imaccf() +real imgetr() + +string readerr "cannot read group data block - no such group?" +string badtype "illegal group data parameter datatype" +string nogroup "group index out of range" +define minmax_ 91 + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + stf = IM_KDES(im) + pfd = STF_PFD(stf) + + # Verify that the given group exists. + if (group < 1 || group > STF_GCOUNT(stf)) + call error (1, nogroup) + + # Skip ahead if there is no group parameter block. + if (STF_PSIZE(stf) == 0) + goto minmax_ + + # Open the pixel file if not already open. + if (pfd == NULL) { + iferr { + if (IM_ACMODE(im) == READ_ONLY) + pfd = open (IM_PIXFILE(im), READ_ONLY, BINARY_FILE) + else + pfd = open (IM_PIXFILE(im), READ_WRITE, BINARY_FILE) + STF_PFD(stf) = pfd + } then { + call eprintf ("Warning: Cannot open pixfile to read GPB (%s)\n") + call pargstr (IM_NAME(im)) + pfd = NULL + } + } + + # Allocate a buffer for the GPB. + sz_gpb = STF_PSIZE(stf) / NBITS_BYTE / SZB_CHAR + call salloc (gpb, sz_gpb, TY_CHAR) + + # Read the GPB into a buffer. The GPB is located at the very end of + # the data storage area for the group. If we are opening a new, + # uninitialized group (acmode = new_image or new_copy), do not + # physically read the GPB as it is will be uninitialized data. + + newgroup = (acmode == NEW_IMAGE || acmode == NEW_COPY || pfd == NULL) + if (newgroup) + call aclrc (Memc[gpb], sz_gpb) + else { + offset = (group * STF_SZGROUP(stf) + 1) - sz_gpb + call seek (pfd, offset) + if (read (pfd, Memc[gpb], sz_gpb) != sz_gpb) + call error (1, readerr) + } + + # Extract the binary value of each parameter in the GPB and encode it + # in FITS format in the IMIO user area. + + offset = 0 + for (pn=1; pn <= STF_PCOUNT(stf); pn=pn+1) { + pp = STF_PDES(stf,pn) + + # Fill in the unitialized fields of the GPB parameter descriptor. + P_OFFSET(pp) = offset + sz_param = P_PSIZE(pp) / NBITS_BYTE / SZB_CHAR + + switch (P_PDTYPE(pp)) { + # changed case for int to short and long--dlb 11/3/87 + case 'I': + if (sz_param == SZ_SHORT) + P_SPPTYPE(pp) = TY_SHORT + else + P_SPPTYPE(pp) = TY_LONG + P_LEN(pp) = 1 + case 'R': + if (sz_param == SZ_REAL) + P_SPPTYPE(pp) = TY_REAL + else + P_SPPTYPE(pp) = TY_DOUBLE + P_LEN(pp) = 1 + case 'C': + P_SPPTYPE(pp) = TY_CHAR + # calculate length directly from PSIZE to avoid truncation error + P_LEN(pp) = min (SZ_LINE, P_PSIZE(pp) / NBITS_BYTE) + case 'L': + P_SPPTYPE(pp) = TY_BOOL + P_LEN(pp) = 1 + default: + call error (1, badtype) + } + + # Extract the binary parameter value and add a FITS encoded card + # to the IMIO user area. In the case of a new copy image, the + # GPB values will already be in the image header, do not modify + # the parameter value, but add the parameter if it was not + # inherited from the old image. + + if (acmode != NEW_COPY || imaccf (im, P_PTYPE(pp)) == NO) { + switch (P_SPPTYPE(pp)) { + case TY_BOOL: + if (SZ_INT != SZ_INT32) + call amovc (Memc[gpb+offset], bval, SZ_INT32) + else + call amovc (Memc[gpb+offset], bval, SZ_BOOL) + call imaddb (im, P_PTYPE(pp), bval) + case TY_SHORT: + call amovc (Memc[gpb+offset], sval, SZ_SHORT) + call imadds (im, P_PTYPE(pp), sval) + case TY_LONG: + if (SZ_INT != SZ_INT32) + call amovc (Memc[gpb+offset], lval, SZ_INT32) + else + call amovc (Memc[gpb+offset], lval, SZ_LONG) + call imaddl (im, P_PTYPE(pp), lval) + case TY_REAL: + call amovc (Memc[gpb+offset], rval, SZ_REAL) + call imaddr (im, P_PTYPE(pp), rval) + case TY_DOUBLE: + call amovc (Memc[gpb+offset], dval, SZ_DOUBLE) + call imaddd (im, P_PTYPE(pp), dval) + case TY_CHAR: + call chrupk (Memc[gpb+offset], 1, Memc[lbuf], 1, P_LEN(pp)) + Memc[lbuf+P_LEN(pp)] = EOS + call imastr (im, P_PTYPE(pp), Memc[lbuf]) + default: + call error (1, badtype) + } + } + + offset = offset + sz_param + } + +minmax_ + # Return DATAMIN, DATAMAX. This is done by searching the user area so + # that ordinary keywords may be used to set datamin and datamax if the + # GPB is not used. + + datamin = 0.0; datamax = 0.0 + if (imaccf (im, "DATAMIN") == YES) + datamin = imgetr (im, "DATAMIN") + if (imaccf (im, "DATAMAX") == YES) + datamax = imgetr (im, "DATAMAX") + + call sfree (sp) +end diff --git a/sys/imio/iki/stf/stfupdhdr.x b/sys/imio/iki/stf/stfupdhdr.x new file mode 100644 index 00000000..a4519c24 --- /dev/null +++ b/sys/imio/iki/stf/stfupdhdr.x @@ -0,0 +1,60 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "stf.h" + +# STF_UPDHDR -- Update the STF/GEIS format image header. + +procedure stf_updhdr (im, status) + +pointer im # image descriptor +int status # return status + +pointer stf +int acmode +real datamin, datamax +errchk imerr, imputr, stf_wgpb + +begin + acmode = IM_ACMODE(im) + status = OK + stf = IM_KDES(im) + + if (acmode == READ_ONLY) + call imerr (IM_NAME(im), SYS_IMUPIMHDR) + + # Compute the values of DATAMIN and DATAMAX. + if (IM_LIMTIME(im) == 0 || IM_LIMTIME(im) < IM_MTIME(im)) { + datamin = 0. + datamax = 0. + } else { + datamin = IM_MIN(im) + datamax = IM_MAX(im) + } + + # Update the group parameter block. + call stf_wgpb (im, STF_GROUP(stf), datamin, datamax) + +# # Update the FITS header file, unless we are writing to a new group +# # in an existing group format image, in which case only the GPB is +# # updated. +# +# if (acmode != NEW_IMAGE && acmode != NEW_COPY) +# call stf_wfitshdr (im) +# else if (STF_NEWIMAGE(stf) == YES) +# call stf_wfitshdr (im) + + # The new strategy for FITS header updates is to always update, unless + # we are explicitly updating an existing group of a multigroup image. + # Hence, the FITS header is always updated for an STF image with only + # one group, or when writing the first group of a new STF imagefile. + # The FITS header of an existing STF multigroup image can still be + # updated, but only if the image is not opened to any particular group, + # e.g., as "pix" rather than "pix[n]", N > 0. NEW_[IMAGE|COPY] or + # READ_WRITE access to "pix[n]" will update only the GPB header. + + if (STF_NEWIMAGE(stf)==YES || STF_GCOUNT(stf)<=1 || STF_GRARG(stf)==0) + call stf_wfitshdr (im) +end diff --git a/sys/imio/iki/stf/stfwfits.x b/sys/imio/iki/stf/stfwfits.x new file mode 100644 index 00000000..c444a235 --- /dev/null +++ b/sys/imio/iki/stf/stfwfits.x @@ -0,0 +1,147 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "stf.h" + +# STF_WFITSHDR -- Update the FITS header file. This is done by writing an +# entire new header file and then replacing the old header file with the +# new one. This is necessary since the header file is a text file and text +# files cannot be randomly updated. + +procedure stf_wfitshdr (im) + +pointer im # image descriptor + +pointer sp, fname, lbuf, stf, pp +int in, out, pn, junk, i, width + +bool fnullfile() +int stropen(), open(), protect(), strlen() #ditto-dlb +errchk fmkcopy, open, stropen, fcopyo, fprintf + +begin + if (fnullfile (IM_HDRFILE(im))) + return + + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + stf = IM_KDES(im) + + # Open a new header file with a unique, temporary name. Make a copy + # of the template file rather than of the old header file. Since + # we also block header lines out to 80 chars automatically, this + # means that we can read any old text file but will always generate + # a new header file of the standard type when the header is updated. + + call mktemp (IM_HDRFILE(im), Memc[fname], SZ_FNAME) + call fmkcopy (HDR_TEMPLATE, Memc[fname]) + out = open (Memc[fname], APPEND, TEXT_FILE) + + # Write out the standard, reserved header parameters. + + call fprintf (out, "SIMPLE =%21s /%81t\n") + call pargstr ("F") + call fprintf (out, "BITPIX =%21d /%81t\n") + call pargi (STF_BITPIX(stf)) + + # We want to get the full string length or 8 characters, + # whichever is greater--6/25/87, dlb + + call fprintf (out, "DATATYPE= '%*.*s'%32t/%81t\n") + width = max(8, strlen(STF_DATATYPE(STF))) + call pargi (-width) # force left-justified field + call pargi (width) + call pargstr (STF_DATATYPE(stf)) + + call fprintf (out, "NAXIS =%21d /%81t\n") + call pargi (STF_NAXIS(stf)) + do i = 1, STF_NAXIS(stf) { + call fprintf (out, "NAXIS%d%9t=%21d /%81t\n") + call pargi (i) + call pargi (STF_LENAXIS(stf,i)) + } + + call fprintf (out, "GROUPS =%21s /%81t\n") + if (STF_GROUPS(stf) == YES) + call pargstr ("T") + else + call pargstr ("F") + + # Changed order of the following three cards to conform + # to SOGS expectations--dlb, 7/14/87 + # Only write group keywords if STF_GROUPS is YES (BPS 12.06.91) + + if (STF_GROUPS(stf) == YES) { + call fprintf (out, "GCOUNT =%21d /%81t\n") + call pargi (STF_GCOUNT(stf)) + call fprintf (out, "PCOUNT =%21d /%81t\n") + call pargi (STF_PCOUNT(stf)) + call fprintf (out, "PSIZE =%21d /%81t\n") + call pargi (STF_PSIZE(stf)) + } + + # Add cards defining the fields of the group parameter block. Each + # field requires three cards. + + for (pn=1; pn <= STF_PCOUNT(stf); pn=pn+1) { + pp = STF_PDES(stf,pn) + + # PTYPE MUST be 8 characters or less. + call fprintf (out, "PTYPE%d%9t= '%-8.8s'%32t/%s%81t\n") + call pargi (pn) + call pargstr (P_PTYPE(pp)) + call pargstr (P_COMMENT(pp)) + + # Need width for string--6/26/87, dlb + call fprintf (out, "PDTYPE%d%9t= '%-*.*s'%32t/%81t\n") + call pargi (pn) + width = max (8, strlen(P_PDTYPE(pp))) + call pargi (-width) # force left-justified field + call pargi (width) + call pargstr (P_PDTYPE(pp)) + + call fprintf (out, "PSIZE%d%9t=%21d /%81t\n") + call pargi (pn) + call pargi (P_PSIZE(pp)) + } + + # Add the contents of the IMIO user area, excluding the cards used + # to represent GPB parameters. + + in = stropen (Memc[IM_USERAREA(im)], ARB, READ_ONLY) + call stf_copyfits (stf, in, NULL, out) + call close (in) + + # End of FITS header. + call fprintf (out, "END%81t\n") + call close (out) + + # Replace the original header file with the new one, even if the + # original header is a protected file. Transfer any file protection + # to the new file. + + if (IM_HFD(im) != NULL) + call close (IM_HFD(im)) + + if (protect (IM_HDRFILE(im), QUERY_PROTECTION) == YES) { + iferr (junk = protect (IM_HDRFILE(im), REMOVE_PROTECTION)) + call erract (EA_ERROR) + iferr (junk = protect (Memc[fname], SET_PROTECTION)) + call erract (EA_ERROR) + } + + iferr (call delete (IM_HDRFILE(im))) + call erract (EA_ERROR) + iferr (call rename (Memc[fname], IM_HDRFILE(im))) + call erract (EA_ERROR) + + if (IM_HFD(im) != NULL) + IM_HFD(im) = open (IM_HDRFILE(im), READ_ONLY, TEXT_FILE) + + call sfree (sp) +end diff --git a/sys/imio/iki/stf/stfwgpb.x b/sys/imio/iki/stf/stfwgpb.x new file mode 100644 index 00000000..3a9e8fe8 --- /dev/null +++ b/sys/imio/iki/stf/stfwgpb.x @@ -0,0 +1,174 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "stf.h" + +# STF_WGPB -- Write the group parameter block data back into the pixel file. +# The GPB is described by a structure member list in the STF descriptor. +# The values of the GPB parameters are encoded as FITS cards in the user +# area of the IMIO descriptor. +# +# DLB--11/3/87: Made changes to allow i*2 and i*4 integer parameters in gpb. + +procedure stf_wgpb (im, group, datamin, datamax) + +pointer im # IMIO image descriptor +int group # group to be accessed +real datamin, datamax # new min, max pixel values + +long offset +pointer sp, stf, gpb, lbuf, pp, op +int pfd, pn, sz_param, sz_gpb, i + +int open(), strlen() +bool bval, imgetb() +# changed to short and long for short integers in gpb +short sval, imgets() +long lval, imgetl() +# +real rval, imgetr() +double dval, imgetd() +errchk open, seek +int imaccf() + +string writerr "cannot update group parameter block" +string badtype "illegal group data parameter datatype" + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + stf = IM_KDES(im) + pfd = STF_PFD(stf) + + # Not all images have group parameter blocks. + if (STF_PSIZE(stf) == 0) { + call sfree (sp) + return + } + + # Open the pixel file if not already open. + if (pfd == NULL) { + pfd = open (IM_PIXFILE(im), READ_WRITE, BINARY_FILE) + STF_PFD(stf) = pfd + } + + # Update the values of DATAMIN, DATAMAX. + if (imaccf (im, "DATAMIN") == YES && + imaccf (im, "DATAMAX") == YES) { + + iferr { + call imputr (im, "DATAMIN", datamin) + call imputr (im, "DATAMAX", datamax) + } then + call erract (EA_WARN) + } + + # Allocate a buffer for the GPB. + sz_gpb = STF_PSIZE(stf) / NBITS_BYTE / SZB_CHAR + call salloc (gpb, sz_gpb, TY_CHAR) + + # Extract the binary value of each parameter in the GPB and encode it + # in FITS format in the IMIO user area. + + offset = 0 + for (pn=1; pn <= STF_PCOUNT(stf); pn=pn+1) { + pp = STF_PDES(stf,pn) + op = gpb + offset + + # Fetch the value of the parameter from IMIO and write it into + # the GPB binary data structure. + + switch (P_SPPTYPE(pp)) { + case TY_BOOL: + iferr (bval = imgetb (im, P_PTYPE(pp))) { + call erract (EA_WARN) + bval = false + } + # Memb[(op-1)/SZ_BOOL+1] = bval + if (SZ_INT != SZ_INT32) { + call i64to32 (bval, bval, 1) + call amovc (bval, Memc[op], SZ_INT32) + } else + call amovc (bval, Memc[op], SZ_BOOL) + + # changed case for int to short and long + # to allow i*2 in gpb--dlb 11/3/87 + case TY_SHORT: + iferr (sval = imgets (im, P_PTYPE(pp))) { + call erract (EA_WARN) + sval = 0 + } + call amovc (sval, Memc[op], SZ_SHORT) + + case TY_LONG: + iferr (lval = imgetl (im, P_PTYPE(pp))) { + call erract (EA_WARN) + lval = 0 + } + if (SZ_INT != SZ_INT32) { + call i64to32 (lval, lval, 1) + call amovc (lval, Memc[op], SZ_INT32) + } else + call amovc (lval, Memc[op], SZ_LONG) + + case TY_REAL: + iferr (rval = imgetr (im, P_PTYPE(pp))) { + # Currently with MWCS, WCS cards such as CRVAL, CDi_j, + # etc. (always type real or double) are omitted from the + # header if their value is zero. Hence if the card is + # missing assume a value of zero rather than issue a + # warning. + + # call erract (EA_WARN) + rval = 0.0 + } + # Memr[(op-1)/SZ_REAL+1] = rval + call amovc (rval, Memc[op], SZ_REAL) + + case TY_DOUBLE: + iferr (dval = imgetd (im, P_PTYPE(pp))) { + # Skip warning as assume zero, as above or TY_REAL. + # call erract (EA_WARN) + dval = 0.0D0 + } + # Memd[(op-1)/SZ_DOUBLE+1] = dval + call amovc (dval, Memc[op], SZ_DOUBLE) + + case TY_CHAR: + # Blank fill the string buffer. + do i = 1, P_LEN(pp) + Memc[lbuf+i-1] = ' ' + + # Fetch the string value of the parameter. + iferr (call imgstr (im, P_PTYPE(pp), Memc[lbuf], SZ_LINE)) + call erract (EA_WARN) + + # Replace the EOS delimiter by a blank. + i = strlen (Memc[lbuf]) + Memc[lbuf+i] = ' ' + + # Pack the blank filled array into the GPB. + call chrpak (Memc[lbuf], 1, Memc[gpb+offset], 1, P_LEN(pp)) + + default: + call error (1, badtype) + } + + sz_param = P_PSIZE(pp) / NBITS_BYTE / SZB_CHAR + offset = offset + sz_param + } + + # Write the GPB into the pixfile. The GPB is located at the very end + # of the data storage area for the group. + + offset = (group * STF_SZGROUP(stf) + 1) - sz_gpb + call seek (pfd, offset) + iferr (call write (pfd, Memc[gpb], sz_gpb)) + call error (5, writerr) + + call sfree (sp) +end diff --git a/sys/imio/imaccess.x b/sys/imio/imaccess.x new file mode 100644 index 00000000..cc6d450e --- /dev/null +++ b/sys/imio/imaccess.x @@ -0,0 +1,66 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + + +# IMACCESS -- Test if an image exists and is accessible with the given access +# mode. If the access mode given is NEW_IMAGE, test if the image name given +# is legal (has a legal extension, i.e., type). YES is returned if the named +# image exists, NO if no image exists with the given name, and ERR if the +# image name is ambiguous (multiple images, e.g. of different types, exist +# with the same name). + +int procedure imaccess (image, acmode) + +char image[ARB] # image name +int acmode # access mode + +int exists, cl_index, cl_size, mode, status +pointer sp, cluster, ksection, section, root, extn, im +int iki_access() +errchk syserrs +pointer immap() + +begin + call smark (sp) + call salloc (cluster, SZ_PATHNAME, TY_CHAR) + call salloc (ksection, SZ_FNAME, TY_CHAR) + call salloc (section, SZ_FNAME, TY_CHAR) + call salloc (root, SZ_PATHNAME, TY_CHAR) + call salloc (extn, SZ_FNAME, TY_CHAR) + + call iki_init() + + call imparse (image, + Memc[cluster], SZ_PATHNAME, + Memc[ksection], SZ_FNAME, + Memc[section], SZ_FNAME, cl_index, cl_size) + + # If an image section, kernel section, or cluster index was specified + # we must actually attempt to open the image to determine if the + # object specified by the full notation exists, otherwise we can just + # call the IKI access function to determine if the cluster exists. + + if (Memc[section] != EOS || Memc[ksection] != EOS || cl_index >= 0) { + mode = acmode + if (acmode == 0) + mode = READ_ONLY + iferr (im = immap (image, mode, 0)) + exists = NO + else { + exists = YES + call imunmap (im) + } + } else { + status = iki_access (image, Memc[root], Memc[extn], acmode) + if (status > 0) + exists = YES + else if (status == 0) + exists = NO + else + call syserrs (SYS_IKIAMBIG, image) + } + + call sfree (sp) + return (exists) +end diff --git a/sys/imio/imaflp.x b/sys/imio/imaflp.x new file mode 100644 index 00000000..27aa64c1 --- /dev/null +++ b/sys/imio/imaflp.x @@ -0,0 +1,70 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMAFLP -- Flip a vector end for end. Optimized for the usual pixel types. +# Pretty slow for DOUBLE and COMPLEX on byte machines, but it is not worth +# optimizing for those cases. + +procedure imaflp (a, npix, sz_pixel) + +char a[ARB], temp +int npix, sz_pixel +int i, left, right, pixel + +begin + switch (sz_pixel) { + case SZ_SHORT: + call imflps (a, npix) + case SZ_LONG: + call imflpl (a, npix) + + default: # flip odd sized elements + left = 1 + right = ((npix-1) * sz_pixel) + 1 + + do pixel = 1, (npix + 1) / 2 { + do i = 0, sz_pixel-1 { + temp = a[right+i] + a[right+i] = a[left+i] + a[left+i] = temp + } + left = left + sz_pixel + right = right - sz_pixel + } + } +end + + +# IMFLPS -- Flip an array of SHORT sized elements. + +procedure imflps (a, npix) + +short a[npix], temp +int npix, i, right + +begin + right = npix + 1 + + do i = 1, (npix + 1) / 2 { + temp = a[right-i] + a[right-i] = a[i] + a[i] = temp + } +end + + +# IMFLPL -- Flip an array of LONG sized elements. + +procedure imflpl (a, npix) + +long a[npix], temp +int npix, i, right + +begin + right = npix + 1 + + do i = 1, (npix + 1) / 2 { + temp = a[right-i] + a[right-i] = a[i] + a[i] = temp + } +end diff --git a/sys/imio/imaplv.x b/sys/imio/imaplv.x new file mode 100644 index 00000000..36a1f315 --- /dev/null +++ b/sys/imio/imaplv.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMAPLV -- Transform the logical vector LV (which references an image section) +# into a physical vector (which references the physical image). + +procedure imaplv (im, lv, pv, ndim) + +pointer im +long lv[ndim], pv[IM_MAXDIM] +int ndim +int loff # logical offset (subscript) +int nldims # number of logical dimensions +int i, j # i = logical dim index, j = physical dim index + +begin + i = 1 + nldims = min (IM_NDIM(im), ndim) + + do j = 1, IM_NPHYSDIM(im) { + if (i <= nldims && IM_VMAP(im,i) == j) { + loff = lv[i] + i = i + 1 + } else + loff = 1 + pv[j] = IM_VOFF(im,j) + IM_VSTEP(im,j) * loff + } +end diff --git a/sys/imio/imbln1.x b/sys/imio/imbln1.x new file mode 100644 index 00000000..60b40c0c --- /dev/null +++ b/sys/imio/imbln1.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMBLN1 -- Get the length of the axes of a one dimensional subraster. +# Must be called immediately after the get or put call that created the +# buffer. + +procedure imbln1 (imdes, nx) + +pointer imdes +int nx +pointer bdes + +begin + # Get pointer to most recently used buffer descriptor. + bdes = IM_LASTBDES(imdes) + + nx = abs (BD_VE(bdes,1) - BD_VS(bdes,1)) + 1 +end diff --git a/sys/imio/imbln2.x b/sys/imio/imbln2.x new file mode 100644 index 00000000..034a1a45 --- /dev/null +++ b/sys/imio/imbln2.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMBLN2 -- Get the length of the axes of a two dimensional subraster. +# Must be called immediately after the get or put call that created the +# buffer. + +procedure imbln2 (imdes, nx, ny) + +pointer imdes +int nx, ny +int i, v[2] +pointer bdes + +begin + # Get pointer to most recently used buffer descriptor. + bdes = IM_LASTBDES(imdes) + + do i = 1, 2 + v[i] = abs (BD_VE(bdes,i) - BD_VS(bdes,i)) + 1 + + nx = v[1] + ny = v[2] +end diff --git a/sys/imio/imbln3.x b/sys/imio/imbln3.x new file mode 100644 index 00000000..8f734ce7 --- /dev/null +++ b/sys/imio/imbln3.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMBLN3 -- Get the length of the axes of a three dimensional subraster. +# Must be called immediately after the get or put call that created the +# buffer. + +procedure imbln3 (imdes, nx, ny, nz) + +pointer imdes +int nx, ny, nz +int i, v[3] +pointer bdes + +begin + # Get pointer to most recently used buffer descriptor. + bdes = IM_LASTBDES(imdes) + + do i = 1, 3 + v[i] = abs (BD_VE(bdes,i) - BD_VS(bdes,i)) + 1 + + nx = v[1] + ny = v[2] + nz = v[3] +end diff --git a/sys/imio/imbtran.x b/sys/imio/imbtran.x new file mode 100644 index 00000000..bf3ec201 --- /dev/null +++ b/sys/imio/imbtran.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMBTRAN -- Transform a point (x,y), possibly lying outside the boundary of +# the N-dimensional image, back into the image using the current boundary +# extension technique. + +procedure imbtran (im, v1, v2, ndim) + +pointer im # image descriptor +long v1[IM_MAXDIM] # input, out of bounds point +long v2[IM_MAXDIM] # transformed point (output) +int ndim # number of dimensions to transform + +int i +long vin, vmax + +begin + switch (IM_VTYBNDRY(im)) { + case BT_NEAREST: + do i = 1, ndim { + vmax = IM_SVLEN(im,i) + vin = v1[i] + + if (vin < 1) + v2[i] = 1 + else if (vin > vmax) + v2[i] = vmax + else + v2[i] = vin + } + + case BT_REFLECT: + do i = 1, ndim { + vmax = IM_SVLEN(im,i) + vin = v1[i] + + if (vin < 1) + v2[i] = 1 + (1 - vin) + else if (vin > vmax) + v2[i] = vmax - (vin - vmax) + else + v2[i] = vin + } + + case BT_WRAP: + do i = 1, ndim { + vmax = IM_SVLEN(im,i) + vin = v1[i] + + while (vin < 1) + vin = vin + vmax + while (vin > vmax) + vin = vin - vmax + v2[i] = vin + } + + default: + do i = 1, ndim + v2[i] = v1[i] + } +end diff --git a/sys/imio/imcopy.x b/sys/imio/imcopy.x new file mode 100644 index 00000000..da7c8b57 --- /dev/null +++ b/sys/imio/imcopy.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMCOPY -- Fast copy of an entire image. No fancy sections, type conversions, +# etc. are permitted if this is used. + +procedure imcopy (old, new) + +char old[ARB] # old image +char new[ARB] # new image + +begin + call iki_init() + call iki_copy (old, new) +end diff --git a/sys/imio/imcssz.x b/sys/imio/imcssz.x new file mode 100644 index 00000000..1ba356be --- /dev/null +++ b/sys/imio/imcssz.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMCSSZ -- Compute size of buffer needed to hold the section defined +# by the logical vectors VS and VE. If type conversion is needed, +# must allow space for whichever pixel is largest. If subsampling is +# in use (step size greater than one), must allow extra space for the +# unsampled data. + +long procedure imcssz (im, vs, ve, ndim, dtype, npix, rwflag) + +pointer im # image descriptor +long vs[ARB], ve[ARB] # endpoints of section +int ndim # dimensionality of section +int dtype # datatype of pixels in section +long npix # number of pixels in section (output) +int rwflag # section is to be read or written + +int step, i, sz_pixel, npix_per_line, extra_pix +long buf_size + +int sizeof() + +begin + sz_pixel = max (sizeof(IM_PIXTYPE(im)), sizeof(dtype)) + + if (IM_VMAP(im,1) == 1) + step = abs (IM_VSTEP(im,1)) + else + step = 1 + + # Compute the total number of pixels in the subraster. + + npix_per_line = abs (ve[1] - vs[1]) + 1 + npix = npix_per_line + + for (i=2; i <= ndim; i=i+1) + npix = npix * (abs (ve[i] - vs[i]) + 1) + + # If the sample step size is greater than one, but less than + # IM_MAXSTEP, allow extra space for the final unsampled line. + # If not subsampling, and the buffer is for writing, add extra + # space so that writes can be an integral number of device + # blocks in size. + + extra_pix = 0 + if (step != 1) { + if (step <= IM_MAXSTEP && rwflag == IM_READ) + extra_pix = (step - 1) * npix_per_line + } else if (rwflag == IM_WRITE) + extra_pix = (IM_PHYSLEN(im,1) - IM_SVLEN(im,1)) + + # If accessing a mask image with range list i/o, the maximum size + # range list may be larger than the size of an image line in pixels. + # Allow some extra space to permit such range lists to be read in + # without buffer overflow; a runtime error is still possible if the + # subraster contains multiple lines, and an individual range list + # exceeds the length of the line in which it must be stored. + + if (and (IM_PLFLAGS(im), PL_RLIO) != 0) + extra_pix = max (extra_pix, RL_MAXLEN(IM_PL(im)) - npix_per_line) + + buf_size = (npix + extra_pix) * sz_pixel # size buf, chars + + return (buf_size) +end diff --git a/sys/imio/imdelete.x b/sys/imio/imdelete.x new file mode 100644 index 00000000..785d5c60 --- /dev/null +++ b/sys/imio/imdelete.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMDELETE -- Delete an image. + +procedure imdelete (image) + +char image[ARB] + +char cache[SZ_FNAME], fname[SZ_FNAME], extn[SZ_FNAME] +char root[SZ_FNAME], src[SZ_FNAME] +int status, len, ip + +int envgets(), strlen(), iki_access(), imaccess() +bool streq() + +begin + # Delete a cached version of the file. + if (envgets ("cache", cache, SZ_PATHNAME) > 0) { + status = iki_access (image, root, extn, READ_ONLY) + len = strlen (root) + for (ip = len; ip > 0; ip=ip-1) { + if (root[ip] == '/') { + call strcpy (root[ip+1], root, SZ_FNAME) + break + } + } + + # Make sure the name has the image extension. + len = strlen (image) + if (! streq (extn, image[len-strlen(extn)+1])) { + call strcat (".", root, SZ_FNAME) + call strcat (extn, root, SZ_FNAME) + } + + # Note that if the file in the cache was added using + # a full path and/or image type extension, it will not + # be found in the cache and deleted. + if (status > 0) { + call fclookup (cache, image, fname, extn, SZ_FNAME) + if (fname[1] != EOS) { + call fcdelete (cache, fname) + + call fcsrc (cache, image, src, SZ_FNAME) + if (src[1] != EOS) { + call fclookup (cache, src, fname, extn, SZ_FNAME) + call fcdelete (cache, fname) + call fcdelete (cache, src) + } + } + } + } + + if (imaccess (image, READ_ONLY) == YES) { + call iki_init() + call iki_delete (image) + } +end diff --git a/sys/imio/imdmap.x b/sys/imio/imdmap.x new file mode 100644 index 00000000..9d4e7c70 --- /dev/null +++ b/sys/imio/imdmap.x @@ -0,0 +1,110 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +# IMDMAP -- Map an image display frame as an imagefile. Equivalent to +# the ordinary immap, except that the pixel storage file is the image +# frame buffer. The special pixel storage file is pre-opened with +# IMDOPEN. Upon the first pixel access, IMIO normally opens the pixfile. +# In this case, it sees that the file has already been opened (as a +# special device as it turns out), and simply uses it. + +pointer procedure imdmap (device, access_mode, imdopen) + +char device[ARB] # graphcap name of display device to be opened +int access_mode # display access mode +extern imdopen() # device FIO open procedure +int imdopen() + +int pfd, pixel_mode +pointer sp, devinfo, devname, im, tty + +bool streq(), ttygetb() +pointer immap(), ttygdes() +int ttygeti(), ttygets(), envgets(), btoi() +errchk imdopen, immap, syserrs + +begin + call smark (sp) + call salloc (devinfo, SZ_LINE, TY_CHAR) + call salloc (devname, SZ_FNAME, TY_CHAR) + + # Determine the display access mode. Write permission is always + # required, even to read from a display device. Write only mode + # is however desirable for the display, to avoid unnecessary i/o + # when faulting the file buffer. + + switch (access_mode) { + case READ_ONLY: + pixel_mode = READ_WRITE + case READ_WRITE: + pixel_mode = READ_WRITE + case WRITE_ONLY: + pixel_mode = WRITE_ONLY + default: + # Cannot create an image on a special device. + call syserrs (SYS_IMDEVOPN, device) + } + + # Open an image header for the special device. + im = immap ("dev$null", NEW_IMAGE, 0) + + # Read the graphcap entry for the device and fetch the device + # parameters. + + if (streq (device, "stdimage")) { + if (envgets ("stdimage", Memc[devname], SZ_FNAME) <= 0) { + call imunmap (im) + call syserrs (SYS_IMDEVOPN, device) + } + } else + call strcpy (device, Memc[devname], SZ_FNAME) + + iferr (tty = ttygdes (Memc[devname])) { + call imunmap (im) + call erract (EA_ERROR) + } + + if (ttygets (tty, "DD", Memc[devinfo], SZ_LINE) <= 0) { + call imunmap (im) + call ttycdes (tty) + call syserrs (SYS_IMDEVOPN, device) + } + + IM_PIXTYPE(im) = TY_SHORT + IM_LEN(im,1) = ttygeti (tty, "xr") + IM_LEN(im,2) = ttygeti (tty, "yr") + IM_LEN(im,3) = ttygeti (tty, "cn") + IM_LEN(im,4) = btoi(ttygetb (tty, "LC")) + IM_NDIM(im) = 2 + IM_MIN(im) = real (ttygeti (tty, "z0")) + IM_MAX(im) = real (ttygeti (tty, "zr") - 1.) + IM_MIN(im) + IM_LIMTIME(im) = IM_MTIME(im) + 1 + IM_PIXOFF(im) = 1 + IM_HGMOFF(im) = NULL + IM_BLIST(im) = NULL + IM_NPHYSDIM(im) = 2 + + call amovl (IM_LEN(im,1), IM_PHYSLEN(im,1), IM_MAXDIM) + call amovl (IM_LEN(im,1), IM_SVLEN(im,1), IM_MAXDIM) + + # Open the display device. + pfd = imdopen (Memc[devinfo], pixel_mode) + if (pfd == ERR) { + call imunmap (im) + call syserrs (SYS_IMDEVOPN, device) + } + + call imseti (im, IM_PIXFD, pfd) + call imseti (im, IM_WHEADER, NO) + call imsetbuf (pfd, im) + + call ttycdes (tty) + call sfree (sp) + + return (im) +end diff --git a/sys/imio/imerr.x b/sys/imio/imerr.x new file mode 100644 index 00000000..8b2aa6b2 --- /dev/null +++ b/sys/imio/imerr.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMERR -- Format an error message for the named image and call error. +# format of error message: ERROR (nnn, "message ('imname')"). + +procedure imerr (image_name, errcode) + +char image_name[ARB] +int errcode + +begin + call syserrs (errcode, image_name) +end diff --git a/sys/imio/imfls.gx b/sys/imio/imfls.gx new file mode 100644 index 00000000..49016816 --- /dev/null +++ b/sys/imio/imfls.gx @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMFLS? -- Flush the output buffer, if necessary. Convert the datatype +# of the pixels upon output, if the datatype of the pixels in the imagefile +# is different than that requested by the calling program. + +procedure imfls$t (imdes) + +pointer imdes +pointer bdes, bp +errchk imflsh + +begin + # Ignore the flush request if the output buffer has already been + # flushed. + + if (IM_FLUSH(imdes) == YES) { + bdes = IM_OBDES(imdes) + bp = BD_BUFPTR(bdes) + + # Convert datatype of pixels, if necessary, and flush buffer. + if (IM_PIXTYPE(imdes) != TY_PIXEL || SZ_INT != SZ_INT32) { + call impak$t (Memc[bp], Memc[bp], BD_NPIX(bdes), + IM_PIXTYPE(imdes)) + } + + call imflsh (imdes, bp, BD_VS(bdes,1), BD_VE(bdes,1), BD_NDIM(bdes)) + + IM_FLUSH(imdes) = NO + } +end diff --git a/sys/imio/imflsh.x b/sys/imio/imflsh.x new file mode 100644 index 00000000..c0d54d6d --- /dev/null +++ b/sys/imio/imflsh.x @@ -0,0 +1,60 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMFLSH -- Flush the output buffer to the pixel storage file (not +# dependent on the datatype of the pixels). The mapping of the subraster +# in the output buffer to the imagefile is described by the section +# descriptor vectors in the buffer descriptor. Images up to IM_MAXDIM +# dimensions are permitted, and each dimension may be accessed in either +# the forward or reverse direction. + +procedure imflsh (im, bp, vs, ve, ndim) + +pointer im # image descriptor +pointer bp # pointer to buffer containing the data +long vs[ARB], ve[ARB] # logical coordinates of section to be written +int ndim # dimensionality of the section + +pointer line +long pvs[IM_MAXDIM], pve[IM_MAXDIM] +long v[IM_MAXDIM], vinc[IM_MAXDIM] +int sz_pixel, sz_dtype, inbounds, npix, xstep +int imsinb(), imloop(), sizeof() +errchk imwrpx, imwbpx +include + +begin + sz_dtype = sizeof (IM_PIXTYPE(im)) + sz_pixel = pix_size[IM_PIXTYPE(im)] + + # Check if the section extends out of bounds. + inbounds = imsinb (im, vs, ve, ndim) + if (inbounds == ERR) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + # Map the logical section into a physical section. Prepare the + # section descriptor do-loop index and increment vectors V, VINC. + + call imaplv (im, vs, pvs, ndim) + call imaplv (im, ve, pve, ndim) + call imsslv (im, pvs, pve, v, vinc, npix) + + line = bp + + # Write the section to the output image, line segment by line segment, + # advancing through the dimensions in storage order (leftmost subscript + # varies fastest). + + repeat { + # Call IMWRPX directly if section is inbounds. + xstep = vinc[1] + if (inbounds == YES) + call imwrpx (im, Memc[line], npix, v, xstep) + else + call imwbpx (im, Memc[line], npix, v, xstep) + line = line + npix * sz_pixel + } until (imloop (v, pvs, pve, vinc, IM_NPHYSDIM(im)) == LOOP_DONE) +end diff --git a/sys/imio/imflush.x b/sys/imio/imflush.x new file mode 100644 index 00000000..32cd2bc7 --- /dev/null +++ b/sys/imio/imflush.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMFLUSH -- Flush the output buffer. The output buffer may contain +# pixels of any datatype. The entry point of the datatype specific +# flush procedure is saved in the image descriptor by IMPGS?. + +procedure imflush (imdes) + +pointer imdes + +begin + if (IM_PFD(imdes) != NULL && IM_FLUSH(imdes) == YES) { + call zcall1 (IM_FLUSHEPA(imdes), imdes) + call flush (IM_PFD(imdes)) + } +end diff --git a/sys/imio/imgclust.x b/sys/imio/imgclust.x new file mode 100644 index 00000000..ca075cfb --- /dev/null +++ b/sys/imio/imgclust.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMGCLUSTER -- Get the cluster name of an image, i.e., the name of the cluster +# to which the image belongs, minus the cluster index and image section, if any. + +procedure imgcluster (imspec, cluster, maxch) + +char imspec[ARB] # full image specification +char cluster[ARB] # receives root image name +int maxch + +int cl_index, cl_size +pointer sp, ksection, section + +begin + call smark (sp) + call salloc (ksection, SZ_FNAME, TY_CHAR) + call salloc (section, SZ_FNAME, TY_CHAR) + + call imparse (imspec, cluster, maxch, Memc[ksection], SZ_FNAME, + Memc[section], SZ_FNAME, cl_index, cl_size) + + call sfree (sp) +end diff --git a/sys/imio/imggs.gx b/sys/imio/imggs.gx new file mode 100644 index 00000000..70cc445e --- /dev/null +++ b/sys/imio/imggs.gx @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGGS? -- Get a general section. + +pointer procedure imggs$t (imdes, vs, ve, ndim) + +pointer imdes +long vs[IM_MAXDIM], ve[IM_MAXDIM] +int ndim +long totpix +pointer bp, imggsc() +errchk imggsc + +begin + bp = imggsc (imdes, vs, ve, ndim, TY_PIXEL, totpix) + if (IM_PIXTYPE(imdes) != TY_PIXEL) + call imupk$t (Mem$t[bp], Mem$t[bp], totpix, IM_PIXTYPE(imdes)) + return (bp) +end diff --git a/sys/imio/imggsc.x b/sys/imio/imggsc.x new file mode 100644 index 00000000..caccc6a3 --- /dev/null +++ b/sys/imio/imggsc.x @@ -0,0 +1,105 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# IMGGSC -- Get a general section, any datatype (called by one of the typed +# procedures, which subsequently convert the datatype of the pixels returned +# by this routine). The mapping of the subraster in the input buffer to the +# imagefile is described by the section descriptor vectors VS and VE. Images +# of up to IM_MAXDIM dimensions are permitted, and each dimension may be +# accessed in either the forward or reverse direction. + +pointer procedure imggsc (im, vs, ve, ndim, dtype, totpix) + +pointer im # image descriptor +long vs[ARB], ve[ARB] # logical coords of corners of section +int ndim # dimensionality of section +int dtype # datatype of pixels desired +long totpix # total pixels in section (output) + +bool rlio +pointer sp, px, bp, line, rl_high +long v[IM_MAXDIM], vinc[IM_MAXDIM] +long pvs[IM_MAXDIM], pve[IM_MAXDIM] +int sz_pixel, inbounds, npix, xstep, n + +pointer imgibf() +int imsinb(), imloop(), pl_p2ri(), sizeof() +errchk imgibf, imrdpx, imrbpx +include + +begin + #sz_pixel = sizeof(IM_PIXTYPE(im)) + #sz_pixel = max ( sizeof(dtype), sizeof(IM_PIXTYPE(im)) ) + #sz_pixel = pix_size[IM_PIXTYPE(im)] + sz_pixel = sizeof(IM_PIXTYPE(im)) + rlio = (and (IM_PLFLAGS(im), PL_RLIO+PL_FAST) == PL_RLIO) + + # Check that the section does not extend out of bounds. + inbounds = imsinb (im, vs, ve, ndim) + if (inbounds == ERR) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + # Get an (input) buffer to put the pixels into. Map the logical + # section into a physical section. Prepare the section descriptor + # do-loop index and increment vectors V, VINC. + + bp = imgibf (im, vs, ve, ndim, dtype) + call imaplv (im, vs, pvs, ndim) + call imaplv (im, ve, pve, ndim) + call imsslv (im, pvs, pve, v, vinc, npix) + + # A temporary pixel buffer is required for RLIO conversions. + if (rlio) { + call smark (sp) + call salloc (px, npix, TY_INT) + } + + line = bp + totpix = 0 + rl_high = bp - 1 + + # Read the section into the input buffer, line segment by line segment, + # advancing through the dimensions in storage order (leftmost subscript + # varies fastest). + + repeat { + xstep = vinc[1] + + # Convert the pixel array to a range list? (image masks). This is + # done more efficiently at a lower level if no complex geometric + # transformations are required (due to sections or OOB references). + + if (rlio) { + if (inbounds == YES) + call imrdpx (im, Memi[px], npix, v, xstep) + else + call imrbpx (im, Memi[px], npix, v, xstep) + + if (rl_high >= line) + call imerr (IM_NAME(im), SYS_IMRLOVFL) + else { + n = pl_p2ri (Memi[px], 1, Memc[line], npix) + rl_high = line + (n * RL_LENELEM * sz_pixel) - 1 + } + + } else { + if (inbounds == YES) + call imrdpx (im, Memc[line], npix, v, xstep) + else + call imrbpx (im, Memc[line], npix, v, xstep) + } + + line = line + (npix * sz_pixel) + totpix = totpix + npix + + } until (imloop (v, pvs, pve, vinc, IM_NPHYSDIM(im)) == LOOP_DONE) + + if (rlio) + call sfree (sp) + + return ((bp - 1) / sizeof(dtype) + 1) +end diff --git a/sys/imio/imgibf.x b/sys/imio/imgibf.x new file mode 100644 index 00000000..9155ae78 --- /dev/null +++ b/sys/imio/imgibf.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMGIBF -- Get an input buffer. + +pointer procedure imgibf (im, vs, ve, ndim, dtype) + +pointer im +long vs[ARB], ve[ARB] +int dtype, ndim + +pointer bdes +int i +long nget, nchars, totpix + +long imcssz() +errchk imopsf, calloc, realloc, mfree, malloc + +begin + # If first input transfer, allocate and initialize array of + # input buffer descriptors. + + if (IM_IBDES(im) == NULL) { + call imopsf (im) + call calloc (IM_IBDES(im), LEN_BDES * IM_VNBUFS(im), TY_STRUCT) + } + + # Compute pointer to the next input buffer descriptor. + # Increment NGET, the count of the number of GETPIX calls. + + nget = IM_NGET(im) + bdes = IM_IBDES(im) + mod (nget, IM_VNBUFS(im)) * LEN_BDES + IM_NGET(im) = nget + 1 + + # Compute the size of the buffer needed. Check buffer + # descriptor to see if the old buffer is the right size. + # If so, use it, otherwise make a new one. + + nchars = imcssz (im, vs, ve, ndim, dtype, totpix, IM_READ) + + if (nchars < BD_BUFSIZE(bdes)) + call realloc (BD_BUFPTR(bdes), nchars, TY_CHAR) + else if (nchars > BD_BUFSIZE(bdes)) { + call mfree (BD_BUFPTR(bdes), TY_CHAR) + call malloc (BD_BUFPTR(bdes), nchars, TY_CHAR) + } + + # Save section coordinates, datatype in buffer descriptor, and + # return buffer pointer to calling program. + + IM_LASTBDES(im) = bdes + BD_BUFSIZE(bdes) = nchars + BD_DTYPE(bdes) = dtype + BD_NPIX(bdes) = totpix + BD_NDIM(bdes) = ndim + + do i = 1, ndim { + BD_VS(bdes,i) = vs[i] + BD_VE(bdes,i) = ve[i] + } + + return (BD_BUFPTR(bdes)) # return ptr to CHAR +end diff --git a/sys/imio/imgimage.x b/sys/imio/imgimage.x new file mode 100644 index 00000000..9e81d409 --- /dev/null +++ b/sys/imio/imgimage.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMGIMAGE -- Get the name of an individual image within a cluster of images, +# i.e., the image name minus any image section. + +procedure imgimage (imspec, image, maxch) + +char imspec[ARB] # full image specification +char image[ARB] # receives image name +int maxch + +int cl_index, cl_size +pointer sp, cluster, ksection, section + +begin + call smark (sp) + call salloc (cluster, SZ_PATHNAME, TY_CHAR) + call salloc (ksection, SZ_FNAME, TY_CHAR) + call salloc (section, SZ_FNAME, TY_CHAR) + + call imparse (imspec, + Memc[cluster], SZ_PATHNAME, + Memc[ksection], SZ_FNAME, + Memc[section], SZ_FNAME, cl_index, cl_size) + + if (cl_index >= 0 && cl_size == -1) { + call sprintf (image, maxch, "%s[%d]") + call pargstr (Memc[cluster]) + call pargi (cl_index) + } else if (cl_index >= 0 && cl_size > 0) { + call sprintf (image, maxch, "%s[%d/%d]") + call pargstr (Memc[cluster]) + call pargi (cl_index) + call pargi (cl_size) + } else + call strcpy (Memc[cluster], image, maxch) + + call strcat (Memc[ksection], image, maxch) + call sfree (sp) +end diff --git a/sys/imio/imgl1.gx b/sys/imio/imgl1.gx new file mode 100644 index 00000000..5008b291 --- /dev/null +++ b/sys/imio/imgl1.gx @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMGL1? -- Get a line from an apparently one dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl1$t (im) + +pointer im +int fd, nchars +long offset +pointer bp, imggs$t(), freadp() +errchk imopsf + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_PIXEL) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + + offset = IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_PIXEL + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_PIXEL + 1) + return (bp) + } + return (imggs$t (im, long(1), IM_LEN(im,1), 1)) + } +end diff --git a/sys/imio/imgl2.gx b/sys/imio/imgl2.gx new file mode 100644 index 00000000..8dfd1751 --- /dev/null +++ b/sys/imio/imgl2.gx @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMGL2? -- Get a line from an apparently two dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl2$t (im, linenum) + +pointer im # image header pointer +int linenum # line to be read + +int fd, nchars +long vs[2], ve[2], offset +pointer bp, imggs$t(), freadp() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_PIXEL) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (linenum < 1 || linenum > IM_LEN(im,2)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (linenum - 1) * IM_PHYSLEN(im,1) * SZ_PIXEL + + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_PIXEL + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_PIXEL + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = linenum + ve[2] = linenum + + return (imggs$t (im, vs, ve, 2)) + } +end diff --git a/sys/imio/imgl3.gx b/sys/imio/imgl3.gx new file mode 100644 index 00000000..eed65b92 --- /dev/null +++ b/sys/imio/imgl3.gx @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMGL3? -- Get a line from an apparently three dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl3$t (im, line, band) + +pointer im # image header pointer +int line # line number within band +int band # band number + +int fd, nchars +long vs[3], ve[3], offset +pointer bp, imggs$t(), freadp() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_PIXEL) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (line < 1 || line > IM_LEN(im,2) || + band < 1 || band > IM_LEN(im,3)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (((band - 1) * IM_PHYSLEN(im,2) + line - 1) * + IM_PHYSLEN(im,1)) * SZ_PIXEL + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_PIXEL + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_PIXEL + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = line + ve[2] = line + vs[3] = band + ve[3] = band + + return (imggs$t (im, vs, ve, 3)) + } +end diff --git a/sys/imio/imgnl.gx b/sys/imio/imgnl.gx new file mode 100644 index 00000000..dde3d356 --- /dev/null +++ b/sys/imio/imgnl.gx @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGNL -- Get the next line from an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# to the first line to be read before the first call. Each call increments +# the leftmost subscript by one, until V equals IM_LEN, at which time EOF +# is returned. + +int procedure imgnl$t (imdes, lineptr, v) + +pointer imdes +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int npix, dtype, imgnln() +errchk imgnln + +begin + npix = imgnln (imdes, lineptr, v, TY_PIXEL) + + if (npix != EOF) { + dtype = IM_PIXTYPE(imdes) + if (dtype != TY_PIXEL) + call imupk$t (Mem$t[lineptr], Mem$t[lineptr], npix, dtype) + } + + return (npix) +end diff --git a/sys/imio/imgnln.x b/sys/imio/imgnln.x new file mode 100644 index 00000000..96bc7524 --- /dev/null +++ b/sys/imio/imgnln.x @@ -0,0 +1,105 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMGNLN -- Get the next line from an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# to the first line to be read before the first call. Each call increments +# the leftmost subscript by one, until V equals IM_LEN, at which time EOF +# is returned. + +int procedure imgnln (im, lineptr, v, dtype) + +pointer im +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int dtype # eventual datatype of pixels + +int dim, ndim, junk, sz_pixel, fd, nchars, pixtype +long lineoff, line, band, offset +long vs[IM_MAXDIM], ve[IM_MAXDIM], unit_v[IM_MAXDIM], npix + +int imloop() +pointer imggsc(), freadp() +errchk imggsc, imerr, imopsf +define retry_ 91 +define oob_ 92 +define misaligned_ 93 +include +data unit_v /IM_MAXDIM * 1/ + +begin + ndim = IM_NDIM(im) + if (ndim == 0) + return (EOF) + + npix = IM_LEN(im,1) # read entire line + pixtype = IM_PIXTYPE(im) + sz_pixel = pix_size[pixtype] + + # Perform "zero trip" check (V >= VE), before entering "loop". + if (v[ndim] > IM_LEN(im,ndim)) + return (EOF) +retry_ + if (IM_FAST(im) == YES && pixtype == dtype && ndim <= 3) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + goto retry_ + } + + # Lineoff is the dimensionless line offset in the pixel storage + # file (which we assume to be in line storage mode). + + lineoff = 0 + if (ndim > 1) { + line = v[2] + if (line < 1 || line > IM_LEN(im,2)) + goto oob_ + lineoff = line - 1 + if (ndim > 2) { + band = v[3] + if (band < 1 || band > IM_LEN(im,3)) +oob_ call imerr (IM_NAME(im), SYS_IMREFOOB) + lineoff = lineoff + (band - 1) * IM_PHYSLEN(im,2) + } + } + + # Reference directly into the FIO buffer. If the image line + # straddles a FIO block boundary freadp calls error and we must + # use a separate buffer. + + offset = lineoff * IM_PHYSLEN(im,1) * sz_pixel + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * sz_pixel + iferr (lineptr = (freadp (fd, offset, nchars) - 1) / sz_pixel + 1) + goto misaligned_ + + } else { +misaligned_ + # Prepare section descriptor vectors. + vs[1] = 1 + ve[1] = npix + do dim = 2, ndim { + vs[dim] = v[dim] + ve[dim] = v[dim] + } + + # Get the line. + lineptr = imggsc (im, vs, ve, ndim, dtype, junk) + } + + # Increment loop vector (cannot use nested loops since the dimension + # of the image is variable). Note this loop vector references + # logical section coordinates. + + if (ndim == 1) + v[1] = IM_LEN(im,1) + 1 + else if (ndim == 2 && IM_FAST(im) == YES) + v[2] = v[2] + 1 + else + junk = imloop (v, unit_v, IM_LEN(im,1), unit_v, ndim) + + return (npix) +end diff --git a/sys/imio/imgobf.x b/sys/imio/imgobf.x new file mode 100644 index 00000000..8dc5f3a1 --- /dev/null +++ b/sys/imio/imgobf.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMGOBF -- Get output buffer. + +pointer procedure imgobf (im, vs, ve, ndim, dtype) + +pointer im, bdes +int ndim, dtype, i +long vs[ndim], ve[ndim] +long nchars, totpix, imcssz(), clktime() +int sizeof() + +errchk imopsf, malloc, realloc, calloc + +include + +begin + # If first write, and if new image, create pixel storage file, + # otherwise open pixel storage file. Allocate and initialize + # output buffer descriptor. + + if (IM_OBDES(im) == NULL) { + call imopsf (im) + call calloc (IM_OBDES(im), LEN_BDES, TY_STRUCT) + IM_MTIME(im) = clktime (long(0)) + IM_SVMTIME(im) = IM_MTIME(im) + } + + bdes = IM_OBDES(im) + + # Compute the size of buffer needed. A few extra chars are added + # to guarantee that there won't be a memory violation when + # writing a full physical length line. + + nchars = imcssz (im, vs, ve, ndim, dtype, totpix, IM_WRITE) + + if (nchars < BD_BUFSIZE(bdes)) + call realloc (BD_BUFPTR(bdes), nchars, TY_CHAR) + else if (nchars > BD_BUFSIZE(bdes)) { + call mfree (BD_BUFPTR(bdes), TY_CHAR) + call malloc (BD_BUFPTR(bdes), nchars, TY_CHAR) + } + + # Save section coordinates, datatype of pixels in buffer + # descriptor, and return buffer pointer to calling program. + + IM_LASTBDES(im) = bdes + BD_BUFSIZE(bdes) = nchars + BD_DTYPE(bdes) = dtype + BD_NPIX(bdes) = totpix + BD_NDIM(bdes) = ndim + + do i = 1, ndim { + BD_VS(bdes,i) = vs[i] + BD_VE(bdes,i) = ve[i] + } + + return ((BD_BUFPTR(bdes) - 1) / sizeof(dtype) + 1) +end diff --git a/sys/imio/imgs1.gx b/sys/imio/imgs1.gx new file mode 100644 index 00000000..ab94d99b --- /dev/null +++ b/sys/imio/imgs1.gx @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGS1? -- Get a section from an apparently one dimensional image. + +pointer procedure imgs1$t (im, x1, x2) + +pointer im +int x1, x2 +pointer imggs$t(), imgl1$t() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1)) + return (imgl1$t (im)) + else + return (imggs$t (im, long(x1), long(x2), 1)) +end diff --git a/sys/imio/imgs2.gx b/sys/imio/imgs2.gx new file mode 100644 index 00000000..d62c44db --- /dev/null +++ b/sys/imio/imgs2.gx @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGS2? -- Get a section from an apparently two dimensional image. + +pointer procedure imgs2$t (im, x1, x2, y1, y2) + +pointer im +int x1, x2, y1, y2 +long vs[2], ve[2] +pointer imggs$t(), imgl2$t() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2) + return (imgl2$t (im, y1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + return (imggs$t (im, vs, ve, 2)) + } +end diff --git a/sys/imio/imgs3.gx b/sys/imio/imgs3.gx new file mode 100644 index 00000000..4179c84f --- /dev/null +++ b/sys/imio/imgs3.gx @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGS3? -- Get a section from an apparently three dimensional image. + +pointer procedure imgs3$t (im, x1, x2, y1, y2, z1, z2) + +pointer im +int x1, x2, y1, y2, z1, z2 +long vs[3], ve[3] +pointer imggs$t(), imgl3$t() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2 && z1 == z2) + return (imgl3$t (im, y1, z1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + vs[3] = z1 + ve[3] = z2 + + return (imggs$t (im, vs, ve, 3)) + } +end diff --git a/sys/imio/imgsect.x b/sys/imio/imgsect.x new file mode 100644 index 00000000..c41fa1b9 --- /dev/null +++ b/sys/imio/imgsect.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMGSECTION -- Get the image section field from an image specifcation. + +procedure imgsection (imspec, section, maxch) + +char imspec[ARB] # full image specifcation +char section[ARB] # receives image section +int maxch + +int cl_index, cl_size +pointer sp, cluster, ksection + +begin + call smark (sp) + call salloc (cluster, SZ_PATHNAME, TY_CHAR) + call salloc (ksection, SZ_FNAME, TY_CHAR) + + call imparse (imspec, Memc[cluster], SZ_PATHNAME, + Memc[ksection], SZ_FNAME, section, maxch, cl_index, cl_size) + + call sfree (sp) +end diff --git a/sys/imio/iminie.x b/sys/imio/iminie.x new file mode 100644 index 00000000..1d019131 --- /dev/null +++ b/sys/imio/iminie.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IM_INIT_NEWIMAGE -- Initialize the header of a new image. + +procedure im_init_newimage (im, len_imhdr) + +pointer im +int len_imhdr +long clktime() + +begin + call strcpy ("imhdr", IM_MAGIC(im), SZ_IMMAGIC) + IM_HDRLEN(im) = len_imhdr + IM_PIXTYPE(im) = DEF_PIXTYPE + IM_CTIME(im) = clktime (long(0)) + IM_MTIME(im) = IM_CTIME(im) + IM_TITLE(im) = EOS + IM_HISTORY(im) = EOS + Memc[IM_USERAREA(im)] = EOS +end diff --git a/sys/imio/imioff.x b/sys/imio/imioff.x new file mode 100644 index 00000000..bec668b3 --- /dev/null +++ b/sys/imio/imioff.x @@ -0,0 +1,114 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +# IMIOFF -- Initialize the physical dimensions of a new image. Compute and set +# the absolute file offsets of the major components of the pixel storage file. + +procedure imioff (im, pixoff, compress, devblksz) + +pointer im # image descriptor +long pixoff # file offset of first pixel +int compress # if set, do not align image lines +int devblksz # FIO device block size + +real impkden, envgetr() +long offset, temp1, temp2, imnote() +int ndim, dim, sz_pixel, lblksize, pblksize +errchk imerr + +include + +begin + sz_pixel = pix_size[IM_PIXTYPE(im)] + pblksize = max (devblksz, SZ_VMPAGE) + + if (compress == YES) + lblksize = 1 + else + lblksize = devblksz + + # Set the offset of the pixel storage area. Compute the physical + # dimensions of the axes of the image. If image compression is + # selected, the logical and physical lengths of the axes will be + # the same. Otherwise, the physical length of each line of the + # image will be increased to fill an integral number of device blocks. + + IM_PIXOFF(im) = pixoff + call amovl (IM_LEN(im,1), IM_PHYSLEN(im,1), IM_MAXDIM) + call amovl (IM_LEN(im,1), IM_SVLEN(im,1), IM_MAXDIM) + + ndim = IM_NDIM(im) + + # If ndim was not explicitly set, compute it by counting the number + # of nonzero dimensions. + + if (ndim == 0) { + for (ndim=1; IM_LEN(im,ndim) > 0 && ndim <= IM_MAXDIM; + ndim=ndim+1) + ; + ndim = ndim - 1 + IM_NDIM(im) = ndim + } + IM_NPHYSDIM(im) = ndim + + # Make sure dimension stuff makes sense. + if (ndim < 0 || ndim > IM_MAXDIM) + call imerr (IM_NAME(im), SYS_IMNDIM) + + do dim = 1, ndim + if (IM_LEN(im,dim) <= 0) + call imerr (IM_NAME(im), SYS_IMDIMLEN) + + # Set the unused higher dimensions to 1. This makes is possible to + # access the image as if it were higher dimensional, and in a way it + # truely is. + + do dim = ndim + 1, IM_MAXDIM + IM_LEN(im,dim) = 1 + + if (lblksize > 1) { + temp1 = pixoff + IM_LEN(im,1) * sz_pixel + temp2 = temp1 + call imalign (temp2, lblksize) + + # Only block lines if the packing density is above a certain + # threshold. Alignment is disabled if compress=YES since lblksize + # will have been set to 1. + + iferr (impkden = envgetr ("impkden")) + impkden = IM_PACKDENSITY + + if (real(temp1-pixoff) / real(temp2-pixoff) >= impkden) + IM_PHYSLEN(im,1) = (temp2 - pixoff) / sz_pixel + } + + # Set the offsets of the histogram pixels and the bad pixel list. + # The HGMOFF offset marks the end of the pixel segment. + + offset = imnote (im, IM_LEN(im,1)) + call imalign (offset, pblksize) + IM_HGMOFF(im) = offset + + offset = offset + (MAX_HGMLEN * SZ_REAL) + call imalign (offset, lblksize) + IM_BLIST(im) = offset +end + + +# IMALIGN -- Advance "offset" to the next block boundary. + +procedure imalign (offset, blksize) + +long offset +int blksize, diff + +begin + diff = mod (offset-1, max (1, blksize)) + if (diff != 0) + offset = offset + (blksize - diff) +end diff --git a/sys/imio/imisec.x b/sys/imio/imisec.x new file mode 100644 index 00000000..9a4735fe --- /dev/null +++ b/sys/imio/imisec.x @@ -0,0 +1,227 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +define FIRST 1 +define LAST MAX_LONG + +.help imisec +.nf ___________________________________________________________________________ +IMISEC -- Translate a section specification string (passed as a suffix +to the imagefile filename) into a set of logical to physical transformation +vectors. + +The image section notation is used to access portions of an image, to reduce +the dimensionality of an image, to reverse the coordinates of any of the axes +of an image, and so on. Since this facility is built into IMIO, and is +completely transparent to programs using IMIO, it significantly increases +the power and flexibility of all programs which assess images, without +complicating the applications code. + +Examples ("map (image_name, ...)": + + image_name meaning + + image[*,-*] (flip columns end for end) + image[*,*,5] (band 5 of image cube) + image[*,5,*] (x,y --> x,z) + image[x1:x2,y1:y2] (2-D subraster) + image[x1:x2:n,*] (subsample by N in x) + +If the number of dimensions specified in the section is less than the number +of physical dimensions in the image then the higher dimensions default to 1. +If the number of dimensions given is greater than the number of phyiscal +dimensions then the nonphysical excess dimensions must be set to 1. +.endhelp ______________________________________________________________________ + + +procedure imisec (imdes, section) + +pointer imdes +char section[ARB] +int ip, i, dim, nsubscripts, nphysdim, nlogdim +long x1[IM_MAXDIM], x2[IM_MAXDIM], step[IM_MAXDIM], clktime() + +begin + # Set up null mapping (default). Check for null section string, + # or null section, and return if found. + + nphysdim = IM_NDIM(imdes) + + call aclrl (IM_VOFF(imdes,1), nphysdim) + call amovkl (long(1), IM_VSTEP(imdes,1), nphysdim) + + do dim = 1, nphysdim + IM_VMAP(imdes,dim) = dim + + if (section[1] == EOS) + return + else if (section[1] != '[') + call imerr (IM_NAME(imdes), SYS_IMSYNSEC) + + ip = 2 + while (IS_WHITE(section[ip])) + ip = ip + 1 + + if (section[ip] == ']') + return + + + # Decode the section string, yielding the vectors X1, X2, and STEP, + # of length NSUBSCRIPTS. + + for (i=1; i <= IM_MAXDIM && section[ip] != ']'; i=i+1) + call im_decode_subscript (section, ip, x1[i], x2[i], step[i]) + nsubscripts = i - 1 + + + # Set the transformation vectors. If too few dimensions were given + # set the higher dimensions to 1. If too many dimensions were given + # the higher dimensions must have been set to 1 in the section. + + for (dim = nsubscripts + 1; dim <= nphysdim; dim = dim + 1) { + x1[dim] = 1 + x2[dim] = 1 + step[dim] = 1 + } + for (dim = nphysdim + 1; dim <= nsubscripts; dim = dim + 1) + if (x1[dim] != 1 || x2[dim] != 1) + call imerr (IM_NAME(imdes), SYS_IMDIMSEC) + + nlogdim = 0 + for (dim=1; dim <= nphysdim; dim=dim+1) { + # Set up transformation for a single physical dimension. + call im_ctranset (imdes, dim, x1[dim], x2[dim], step[dim]) + + # Map logical dimension onto physical dimension. + if (x1[dim] != x2[dim]) { + nlogdim = nlogdim + 1 + IM_VMAP(imdes,nlogdim) = dim + IM_LEN(imdes,nlogdim) = IM_LEN(imdes,dim) + } + } + + # Convert a zero-dimensional image into a one dimensional image + # of length one pixel (section addresses a single pixel). + + if (nlogdim == 0) { + nlogdim = 1 + IM_VMAP(imdes,1) = 1 + IM_LEN(imdes,1) = 1 + } + + IM_NDIM(imdes) = nlogdim + IM_MTIME(imdes) = clktime (long(0)) +end + + +# IM_CTRANSET -- Set the logical to physical section coordinate transformation +# coefficients VOFF and VSTEP for the axis DIM. Adjust the length of the +# logical axis IM_LEN if needed. + +procedure im_ctranset (imdes, dim, x1_arg, x2_arg, step) + +pointer imdes +int dim +long x1_arg, x2_arg, step, x1, x2, length_axis + +begin + x1 = x1_arg + if (x1_arg == LAST) + x1 = IM_LEN(imdes,dim) + x2 = x2_arg + if (x2_arg == LAST) + x2 = IM_LEN(imdes,dim) + + # Compute the number of pixels in this axis of the section, allowing + # for non-unity step sizes. Set the axis length seen by the calling + # program to this value. + + length_axis = (x2 - x1) / step + 1 + if (length_axis <= 0) + call imerr (IM_NAME(imdes), SYS_IMSTEPSEC) + else + IM_LEN(imdes,dim) = length_axis + + IM_VOFF(imdes,dim) = x1 - step + IM_VSTEP(imdes,dim) = step +end + + +# IM_DECODE_SUBSCRIPT -- Decode a single subscript expression to produce the +# range of values for that subscript (X1:X2), and the sampling step size, STEP. +# Note that X1 may be less than, greater than, or equal to X2, and STEP may +# be a positive or negative nonzero integer. Various shorthand notations are +# permitted, as is embedded whitespace. + +procedure im_decode_subscript (section, ip, x1, x2, step) + +char section[ARB] +int ip +long x1, x2, step, temp +int ctol() +define synerr_ 99 + +begin + x1 = FIRST + x2 = LAST + step = 1 + + while (IS_WHITE(section[ip])) + ip = ip + 1 + + # Get X1, X2. + if (ctol (section, ip, temp) > 0) { # [x1 + x1 = temp + if (section[ip] == ':') { + ip = ip + 1 + if (ctol (section, ip, x2) == 0) # [x1:x2 + goto synerr_ + } else + x2 = x1 + + } else if (section[ip] == '-') { + x1 = LAST # [-* + x2 = FIRST + ip = ip + 1 + if (section[ip] == '*') + ip = ip + 1 + + } else if (section[ip] == '*') # [* + ip = ip + 1 + + while (IS_WHITE(section[ip])) + ip = ip + 1 + + # Get sample step size, if give. + if (section[ip] == ':') { # ..:step + ip = ip + 1 + if (ctol (section, ip, step) == 0) + goto synerr_ + else if (step == 0) + goto synerr_ + } + + # Allow notation such as "-*:5", (or even "-:5") where the step + # is obviously supposed to be negative. + + if (x1 > x2 && step > 0) + step = -step + + while (IS_WHITE(section[ip])) + ip = ip + 1 + + if (section[ip] == ',') { + ip = ip + 1 + return + } else if (section[ip] == ']') + return + +synerr_ + # Syntax error in image section specification. + call imerr (section, SYS_IMSYNSEC) +end diff --git a/sys/imio/imloop.x b/sys/imio/imloop.x new file mode 100644 index 00000000..ffae877b --- /dev/null +++ b/sys/imio/imloop.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMLOOP -- Increment the vector V from VS to VE (nested do loops cannot +# be used because of the variable number of dimensions). Return LOOP_DONE +# when V exceeds VE. + +int procedure imloop (v, vs, ve, vinc, ndim) + +long v[ndim], vs[ndim], ve[ndim], vinc[ndim] +int ndim, dim + +begin + for (dim=2; dim <= ndim; dim=dim+1) { + v[dim] = v[dim] + vinc[dim] + + if ((vinc[dim] > 0 && v[dim] - ve[dim] > 0) || + (vinc[dim] < 0 && ve[dim] - v[dim] > 0)) { + + if (dim < ndim) + v[dim] = vs[dim] # advance to next dim + else + break + } else + return (LOOP_AGAIN) + } + + return (LOOP_DONE) +end diff --git a/sys/imio/immaky.x b/sys/imio/immaky.x new file mode 100644 index 00000000..186bfe5d --- /dev/null +++ b/sys/imio/immaky.x @@ -0,0 +1,90 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + + +# IM_MAKE_NEWCOPY -- Copy the header of an existing, mapped image to +# initialize the header of a new image. Clear all fields that describe +# the pixels (a NEW_COPY image does not inherit any pixels). + +procedure im_make_newcopy (im, o_im) + +pointer im # new copy image +pointer o_im # image being copied + +pointer mw +int strlen() +long clktime() +pointer mw_open() +bool strne(), envgetb() +errchk imerr, realloc, mw_open, mw_loadim, mw_saveim, mw_close + +begin + if (strne (IM_MAGIC(o_im), "imhdr")) + call imerr (IM_NAME(im), SYS_IMMAGNCPY) + + # Copy the old image header (all fields, including user fields). + # Note that the incore version of the old header may be shorter than + # the actual header, in which case the user fields are currently + # not copied (would require reopening old header file). This is + # unlikely, however, since a very large in memory user area is + # allocated. + + # Update the value of HDRLEN for the input image in case the + # header has grown since the image was opened. + + IM_HDRLEN(o_im) = LEN_IMHDR + + (strlen(Memc[IM_USERAREA(o_im)])+1 + SZ_STRUCT-1) / SZ_STRUCT + + # Copy the header. + if (IM_LENHDRMEM(im) < IM_HDRLEN(o_im)) { + IM_LENHDRMEM(im) = IM_HDRLEN(o_im) + (SZ_UAPAD / SZ_STRUCT) + call realloc (im, IM_LENHDRMEM(im) + LEN_IMDES, TY_STRUCT) + } + call amovi (IM_MAGIC(o_im), IM_MAGIC(im), IM_HDRLEN(o_im) + 1) + + # If the old image was opened with an image section, modify the + # WCS of the new image accordingly. The section is applied to the + # MWCS Lterm automatically when the WCS is loaded from an image, + # so all we have to do is load the WCS of the old image section, + # and store it in the new image. + + if (IM_SECTUSED(o_im) == YES) + if (!envgetb ("nomwcs")) { + iferr (mw = mw_open (NULL, IM_NPHYSDIM(o_im))) + call erract (EA_WARN) + else { + call mw_loadim (mw, o_im) + call mw_saveim (mw, im) + call mw_close (mw) + } + } + + # If the pixels of the old image were stored in byte stream mode, + # make the new image that way too. Otherwise, the physical line + # length must be recomputed, as the new image may reside on a + # device with a different block size. + + if (IM_LEN(im,1) == IM_PHYSLEN(im,1)) + IM_VCOMPRESS(im) = YES + + IM_PIXOFF(im) = NULL + IM_HGMOFF(im) = NULL + IM_BLIST(im) = NULL + IM_SZBLIST(im) = 0 + IM_NBPIX(im) = 0 + IM_LIMTIME(im) = 0 + IM_OHDR(im) = o_im + IM_PIXFILE(im) = EOS + + IM_CTIME(im) = clktime (long(0)) + IM_MTIME(im) = IM_CTIME(im) + + # Add a line to the history file (inherited from old image). + call strcat ("New copy of ", IM_HISTORY(im), SZ_IMHIST) + call strcat (IM_NAME(o_im), IM_HISTORY(im), SZ_IMHIST) + call strcat ("\n", IM_HISTORY(im), SZ_IMHIST) +end diff --git a/sys/imio/immap.x b/sys/imio/immap.x new file mode 100644 index 00000000..dc1a98ee --- /dev/null +++ b/sys/imio/immap.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMMAP -- Map an imagefile to an image structure. This is the "open" +# procedure for an imagefile. + +pointer procedure immap (imspec, acmode, hdr_arg) + +char imspec[ARB] #I image specification +int acmode #I image access mode +int hdr_arg #I length of user fields, or header pointer + +pointer immapz() +errchk iki_init + +begin + call iki_init() + return (immapz (imspec, acmode, hdr_arg)) +end diff --git a/sys/imio/immapz.x b/sys/imio/immapz.x new file mode 100644 index 00000000..71e03c8c --- /dev/null +++ b/sys/imio/immapz.x @@ -0,0 +1,189 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +# IMMAPZ -- Map an imagefile to an image structure. This is the IMIO internal +# version of the immap procedure, called once the IKI has been initialized. + +pointer procedure immapz (imspec, acmode, hdr_arg) + +char imspec[ARB] # image specification +int acmode # image access mode +int hdr_arg # length of user fields, or header pointer + +pointer sp, imname, root, cluster, ksection, section, im +char inname[SZ_PATHNAME] +int min_lenuserarea, len_imhdr, cl_index, cl_size, i, val +int btoi(), ctoi(), envfind(), fnroot(), strlen(), envgeti(), strncmp() +errchk im_make_newcopy, im_init_newimage, malloc + +begin + call smark (sp) + call salloc (imname, SZ_PATHNAME, TY_CHAR) + call salloc (cluster, SZ_PATHNAME, TY_CHAR) + call salloc (ksection, SZ_FNAME, TY_CHAR) + call salloc (section, SZ_FNAME, TY_CHAR) + call salloc (root, SZ_FNAME, TY_CHAR) + + # The user or system manager can specify the minimum user area size + # as an environment variable, if the IRAF default is too small. + + if (envfind ("min_lenuserarea", Memc[section], SZ_FNAME) > 0) { + i = 1 + if (ctoi (Memc[section], i, min_lenuserarea) <= 0) + min_lenuserarea = MIN_LENUSERAREA + } else + min_lenuserarea = MIN_LENUSERAREA + + + # If we're given a URL to an image, cache the file. + if (strncmp ("http://", imspec, 7) == 0) + call fcadd ("cache$", imspec, "", inname, SZ_PATHNAME) + else if (strncmp ("file:///localhost", imspec, 17) == 0) + call strcpy (imspec[18], inname, SZ_PATHNAME) + else if (strncmp ("file://localhost", imspec, 16) == 0) + call strcpy (imspec[17], inname, SZ_PATHNAME) + else if (strncmp ("file://", imspec, 7) == 0) + call strcpy (imspec[7], inname, SZ_PATHNAME) + else + call strcpy (imspec, inname, SZ_PATHNAME) + + + # Parse the full image specification into its component parts. + call imparse (inname, Memc[cluster],SZ_PATHNAME, + Memc[ksection],SZ_FNAME, Memc[section],SZ_FNAME, cl_index,cl_size) + + # Allocate buffer for image descriptor/image header. Note the dual + # use of the HDR_ARG argument. In the case of a new copy image, + # hdr_arg is a pointer to the image to be copied; otherwise is is the + # length of the user area in CHARS (since the user area is a string + # buffer). + + if (acmode == NEW_COPY) { + len_imhdr = max (LEN_IMHDR + min_lenuserarea / SZ_STRUCT, + IM_HDRLEN(hdr_arg) + SZ_UAPAD / SZ_STRUCT) + } else { + len_imhdr = LEN_IMHDR + + max (min_lenuserarea, int(hdr_arg)) / SZ_STRUCT + } + + call malloc (im, LEN_IMDES + len_imhdr, TY_STRUCT) + call aclri (Memi[im], LEN_IMDES + min (len_imhdr, LEN_IMHDR + 1)) + IM_LENHDRMEM(im) = len_imhdr + + # Initialize the image descriptor structure. + IM_ACMODE(im) = acmode + IM_PFD(im) = NULL + IM_HDRLEN(im) = len_imhdr + IM_UPDATE(im) = btoi (acmode != READ_ONLY) + IM_UABLOCKED(im) = -1 + + # Initialize options. + IM_VNBUFS(im) = 1 + IM_VCOMPRESS(im) = DEF_COMPRESS + IM_VADVICE(im) = DEF_ADVICE + + # Initialize the IMIO buffer size defaults. The builtin defaults + # are used unless a value is explicitly set in the environment; + # an IMSET on the open descriptor will override either. + + IM_VBUFSIZE(im) = DEF_FIOBUFSIZE + ifnoerr (val = envgeti (ENV_BUFSIZE)) + IM_VBUFSIZE(im) = val / SZB_CHAR + IM_VBUFFRAC(im) = DEF_FIOBUFFRAC + ifnoerr (val = envgeti (ENV_BUFFRAC)) + IM_VBUFFRAC(im) = val + IM_VBUFMAX(im) = DEF_MAXFIOBUFSIZE + ifnoerr (val = envgeti (ENV_BUFMAX)) + IM_VBUFMAX(im) = val + + # Set fast i/o flag to yes initially to force IMOPSF and hence IMSETBUF + # to be called when the first i/o operation occurs. + + IM_FAST(im) = YES +IM_FAST(im) = NO + + # Set the image name field, used by IMERR everywhere. + call strcpy (inname, IM_NAME(im), SZ_IMNAME) + + # Initialize the mode dependent fields of the image header. + if (acmode == NEW_COPY) + call im_make_newcopy (im, hdr_arg) + else if (acmode == NEW_IMAGE) + call im_init_newimage (im, IM_HDRLEN(im)) + + # Set the following in case it isn't set by the kernel. + call strcpy ("imhdr", IM_MAGIC(im), SZ_IMMAGIC) + + # Physically open the image and read the header. Note that IKI_OPEN + # may realloc the image descriptor if additional space is required, + # hence the pointer IM may be modified. + + iferr { + call iki_open (im, Memc[cluster], Memc[ksection], + cl_index, cl_size, acmode, hdr_arg) + } then { + call mfree (im, TY_STRUCT) + call erract (EA_ERROR) + } + + # Format a full image name specification if we have a cl_index format + # image. IM_NAME is used mainly as an image identifier in error + # messages, so truncate the string by omitting some of the leading + # pathname information if the resultant string would be excessively + # long. + + if (IM_CLSIZE(im) > 1) { + call sprintf (Memc[imname], SZ_PATHNAME, "%s[%d/%d]%s%s") + call pargstr (Memc[cluster]) + call pargi (IM_CLINDEX(im)) + call pargi (IM_CLSIZE(im)) + call pargstr (Memc[ksection]) + call pargstr (Memc[section]) + + if (strlen (Memc[imname]) > SZ_IMNAME) { + i = fnroot (Memc[cluster], Memc[root], SZ_FNAME) + call sprintf (Memc[imname], SZ_PATHNAME, "%s[%d/%d]%s%s") + call pargstr (Memc[root]) + call pargi (IM_CLINDEX(im)) + call pargi (IM_CLSIZE(im)) + call pargstr (Memc[ksection]) + call pargstr (Memc[section]) + } + + call strcpy (Memc[imname], IM_NAME(im), SZ_IMNAME) + } + + # Save those image header fields that get modified if an image section + # is specified. + + IM_NPHYSDIM(im) = IM_NDIM(im) + IM_SVMTIME(im) = IM_MTIME(im) + call amovl (IM_LEN(im,1), IM_SVLEN(im,1), IM_MAXDIM) + + # Process the image section if one was given, i.e., parse the section + # string and set up a transformation to be applied to logical input + # vectors. + + if (Memc[section] != EOS) { + if (acmode == NEW_COPY || acmode == NEW_IMAGE) { + call iki_close (im) + call mfree (im, TY_STRUCT) + call imerr (IM_NAME(im), SYS_IMSECTNEWIM) + } + call imisec (im, Memc[section]) + IM_SECTUSED(im) = YES + } else { + # IM_VOFF is already zero, because of the CALLOC. + call amovkl (long(1), IM_VSTEP(im,1), IM_MAXDIM) + do i = 1, IM_MAXDIM + IM_VMAP(im,i) = i + } + + call sfree (sp) + return (im) +end diff --git a/sys/imio/imnote.x b/sys/imio/imnote.x new file mode 100644 index 00000000..09547043 --- /dev/null +++ b/sys/imio/imnote.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMNOTE -- Given the coordinates of a pixel, return the character offset +# of that pixel in the pixel storage file. + +long procedure imnote (im, v) + +pointer im # image descriptor +long v[IM_MAXDIM] # physical coords of pixel + +int sz_pixel, i +long pixel_index, dim_offset, char_offset0 +include + +begin + sz_pixel = pix_size[IM_PIXTYPE(im)] + pixel_index = v[1] + dim_offset = 1 + + do i = 2, IM_NPHYSDIM(im) { + dim_offset = dim_offset * IM_PHYSLEN(im,i-1) + pixel_index = pixel_index + dim_offset * (v[i] - 1) + } + + char_offset0 = (pixel_index-1) * sz_pixel + return (IM_PIXOFF(im) + char_offset0) +end diff --git a/sys/imio/imopsf.x b/sys/imio/imopsf.x new file mode 100644 index 00000000..f790481a --- /dev/null +++ b/sys/imio/imopsf.x @@ -0,0 +1,140 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include + +# IMOPSF -- Open (or create) the pixel storage file. If the file has already +# been opened do nothing but set the buffer size. Until the pixel storage +# file has been opened we do not know the device block size, image line length, +# or whether IM_FAST type i/o is possible. + +procedure imopsf (im) + +pointer im + +pointer sp, imname, ref_im, pfd +int sv_acmode, sv_update, ndim, depth, i +errchk iki_opix, open +int open() + +begin + call smark (sp) + call salloc (imname, SZ_IMNAME, TY_CHAR) + + if (IM_PL(im) != NULL) { + if (IM_PFD(im) == NULL) { + # Complete the initialization of a mask image. + ref_im = IM_PLREFIM(im) + + sv_acmode = IM_ACMODE(im) + sv_update = IM_UPDATE(im) + call strcpy (IM_NAME(im), Memc[imname], SZ_IMNAME) + + if (ref_im != NULL) { + # Create a mask the same size as the physical size of the + # reference image. Inherit any image section from the + # reference image. + + IM_NDIM(im) = IM_NDIM(ref_im) + IM_NPHYSDIM(im) = IM_NPHYSDIM(ref_im) + IM_SECTUSED(im) = IM_SECTUSED(ref_im) + call amovl (IM_LEN(ref_im,1), IM_LEN(im,1), IM_MAXDIM) + call amovl (IM_PHYSLEN(ref_im,1),IM_PHYSLEN(im,1),IM_MAXDIM) + call amovl (IM_SVLEN(ref_im,1), IM_SVLEN(im,1), IM_MAXDIM) + call amovl (IM_VMAP(ref_im,1), IM_VMAP(im,1), IM_MAXDIM) + call amovl (IM_VOFF(ref_im,1), IM_VOFF(im,1), IM_MAXDIM) + call amovl (IM_VSTEP(ref_im,1), IM_VSTEP(im,1), IM_MAXDIM) + + # Tell PMIO to use this image as the reference image. + call pm_seti (IM_PL(im), P_REFIM, im) + + } else if (sv_acmode == NEW_IMAGE || sv_acmode == NEW_COPY) { + # If ndim was not explicitly set, compute it by counting + # the number of nonzero dimensions. + + ndim = IM_NDIM(im) + if (ndim == 0) { + ndim = 1 + while (IM_LEN(im,ndim) > 0 && ndim <= IM_MAXDIM) + ndim = ndim + 1 + ndim = ndim - 1 + IM_NDIM(im) = ndim + } + + # Make sure dimension stuff makes sense. + if (ndim < 0 || ndim > IM_MAXDIM) + call imerr (IM_NAME(im), SYS_IMNDIM) + + do i = 1, ndim + if (IM_LEN(im,i) <= 0) + call imerr (IM_NAME(im), SYS_IMDIMLEN) + + # Set the unused higher dimensions to 1. This makes it + # possible to access the image as if it were higher + # dimensional, and in a way it truely is. + + do i = ndim + 1, IM_MAXDIM + IM_LEN(im,i) = 1 + + IM_NPHYSDIM(im) = ndim + call amovl (IM_LEN(im,1), IM_PHYSLEN(im,1), IM_MAXDIM) + call amovl (IM_LEN(im,1), IM_SVLEN(im,1), IM_MAXDIM) + + # Initialize the empty mask to the newly determined size. + depth = PL_MAXDEPTH + if (and (IM_PLFLAGS(im), PL_BOOL) != 0) + depth = 1 + call pl_ssize (IM_PL(im), IM_NDIM(im), IM_LEN(im,1), depth) + } + + call strcpy (Memc[imname], IM_NAME(im), SZ_IMNAME) + IM_ACMODE(im) = sv_acmode + IM_UPDATE(im) = sv_update + IM_PIXOFF(im) = 1 + IM_HGMOFF(im) = NULL + IM_BLIST(im) = NULL + IM_HFD(im) = NULL + + # Do the following in two statements so that IM_PFD does + # not get set if the OPEN fails and does an error exit. + + pfd = open ("dev$null", READ_WRITE, BINARY_FILE) + IM_PFD(im) = pfd + } + + # Execute this even if pixel file has already been opened. + call imsetbuf (IM_PFD(im), im) + + # "Fast i/o" in the conventional sense no IMIO buffering) + # is not permitted for mask images, since IMIO must buffer + # the pixels, which are generated at run time. + + if (IM_FAST(im) == YES) { + IM_PLFLAGS(im) = or (IM_PLFLAGS(im), PL_FAST) + IM_FAST(im) = NO + } + + } else { + # Open the pixel file for a regular image. + if (IM_PFD(im) == NULL) + call iki_opix (im) + + # Execute this even if pixel file has already been opened. + call imsetbuf (IM_PFD(im), im) + + # If F_CLOSEFD is set on the pixel file, the host channel to the + # file will be physically closed off except when an i/o operation + # is in progress (used to conserve host file descriptors) in + # applications which must open a large number of images all at + # once). + + if (IM_VCLOSEFD(im) == YES) + call fseti (IM_PFD(im), F_CLOSEFD, YES) + } + + call sfree (sp) +end diff --git a/sys/imio/impak.gx b/sys/imio/impak.gx new file mode 100644 index 00000000..feb37f2c --- /dev/null +++ b/sys/imio/impak.gx @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPAK? -- Convert an array of pixels of a specific datatype to the +# datatype given as the final argument. + +procedure impak$t (a, b, npix, dtype) + +PIXEL a[npix] +int b[npix], npix, dtype + +pointer bp + +begin + switch (dtype) { + case TY_USHORT: + call acht$tu (a, b, npix) + case TY_SHORT: + call acht$ts (a, b, npix) + case TY_INT: + if (SZ_INT == SZ_INT32) + call acht$ti (a, b, npix) + else { + call malloc (bp, npix, TY_INT) + call acht$ti (a, Memi[bp], npix) + call ipak32 (Memi[bp], b, npix) + call mfree (bp, TY_INT) + } + case TY_LONG: + if (SZ_INT == SZ_INT32) + call acht$tl (a, b, npix) + else { + call malloc (bp, npix, TY_LONG) + call acht$tl (a, Meml[bp], npix) + call ipak32 (Meml[bp], b, npix) + call mfree (bp, TY_LONG) + } + case TY_REAL: + call acht$tr (a, b, npix) + case TY_DOUBLE: + call acht$td (a, b, npix) + case TY_COMPLEX: + call acht$tx (a, b, npix) + default: + call error (1, "Unknown datatype in imagefile") + } +end diff --git a/sys/imio/imparse.x b/sys/imio/imparse.x new file mode 100644 index 00000000..cc98070d --- /dev/null +++ b/sys/imio/imparse.x @@ -0,0 +1,155 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMPARSE -- Parse an image specification into the cluster name, cluster index, +# cluster size, kernel section, and image section fields. +# +# Syntax: cluster[cl_index/cl_size][ksection][section] +# +# where all fields are optional except the cluster name. In the limiting case +# (cl_size = 1) the cluster name and image name are the same. CL_INDEX and +# CL_SIZE must be simple nonnegative decimal integer constants, if given. The +# [ character must be escaped to be included in the filename of the cluster. +# +# NOTE -- The image specification syntax is not frozen and further changes +# are likely. Use of this routine outside IMIO is not recommended as the +# calling sequence may change. Use imgname and imgsection instead. + +procedure imparse (imspec, cluster, sz_cluster, ksection, sz_ksection, + section, sz_section, cl_index, cl_size) + +char imspec[ARB] # full image specification +char cluster[ARB] # receives cluster name +int sz_cluster # max chars in cluster name +char ksection[ARB] # receives kernel section +int sz_ksection # max chars in kernel section name +char section[ARB] # receives image section +int sz_section # max chars in image section name +int cl_index # receives cluster index (default -1) +int cl_size # receives cluster size (default -1) + +pointer sp, cp, secbuf +int ip, op, lbrack, level, ch, n +bool is_ksection, sect_out, ksect_out +int stridx() +errchk syserrs + +begin + call smark (sp) + call salloc (secbuf, SZ_LINE, TY_CHAR) + + ip = 1 + op = 1 + + # Extract cluster name. The first (unescaped) [ marks the start of + # either the cl_index subscript or a section field. + + for (ch=imspec[ip]; ch != EOS && ch != '['; ch=imspec[ip]) { + if (ch == '\\' && imspec[ip+1] == '[') { + cluster[op] = '\\' + op = op + 1 + cluster[op] = '[' + ip = ip + 1 + } else + cluster[op] = ch + + op = min (sz_cluster, op + 1) + ip = ip + 1 + } + + cluster[op] = EOS + ksection[1] = EOS + section[1] = EOS + lbrack = ip + cl_index = -1 + cl_size = -1 + + if (ch == EOS) { + call sfree (sp) + return + } + + # If we have a [...] field, determine whether it is a cl_index + # subscript or a kernel or image section. A cl_index subscript is + # anything with the syntax [ddd] or [ddd/ddd]; anything else is a + # kernel or image section. + + ip = ip + 1 + n = -1 + + for (ch=imspec[ip]; ch != EOS; ch=imspec[ip]) { + if (IS_DIGIT(ch)) { + if (n < 0) + n = 0 + n = (n * 10) + TO_INTEG(ch) + } else if (ch == '/') { + cl_index = max (n, 1) + n = -1 + } else if (ch == ']') { + ip = ip + 1 + break + } else { + # Not a cl_index subscript; must be a section. + ip = lbrack + n = -1 + break + } + ip = ip + 1 + } + + if (cl_index < 0) + cl_index = n + else + cl_size = n + + # The rest of the input string consists of the kernel and image + # sections, if any. + + sect_out = false + ksect_out = false + + while (imspec[ip] == '[') { + is_ksection = false + cp = secbuf + level = 0 + + for (ch=imspec[ip]; ch != EOS; ch=imspec[ip]) { + if (ch == '[') + level = level + 1 + else if (ch == ']') + level = level - 1 + else if (!is_ksection) + if (stridx (imspec[ip], " 0123456789+-:*,") == 0) + is_ksection = true + + Memc[cp] = ch + cp = cp + 1 + ip = ip + 1 + + if (level == 0) + break + } + Memc[cp] = EOS + + if (level != 0) + call syserrs (SYS_IMSYNSEC, imspec) + if (is_ksection) { + if (ksect_out) + call syserrs (SYS_IMSYNSEC, imspec) + call strcpy (Memc[secbuf], ksection, sz_ksection) + ksect_out = true + } else { + if (sect_out) + call syserrs (SYS_IMSYNSEC, imspec) + call strcpy (Memc[secbuf], section, sz_section) + sect_out = true + } + + while (imspec[ip] != EOS && imspec[ip] != '[') + ip = ip + 1 + } + + call sfree (sp) +end diff --git a/sys/imio/impgs.gx b/sys/imio/impgs.gx new file mode 100644 index 00000000..1aa0f432 --- /dev/null +++ b/sys/imio/impgs.gx @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMPGS? -- Put a general section of a specific datatype. + +pointer procedure impgs$t (imdes, vs, ve, ndim) + +pointer imdes +long vs[IM_MAXDIM], ve[IM_MAXDIM] +pointer bp, imgobf() +int ndim +extern imfls$t() +errchk imflush, imgobf + +begin + # Flush the output buffer, if appropriate. IMFLUSH calls + # one of the IMFLS? routines, which write out the section. + + if (IM_FLUSH(imdes) == YES) + call zcall1 (IM_FLUSHEPA(imdes), imdes) + + # Get an (output) buffer to put the pixels into. Save the + # section parameters in the image descriptor. Save the epa + # of the typed flush procedure in the image descriptor. + + bp = imgobf (imdes, vs, ve, ndim, TY_PIXEL) + call zlocpr (imfls$t, IM_FLUSHEPA(imdes)) + IM_FLUSH(imdes) = YES + + return (bp) +end diff --git a/sys/imio/impl1.gx b/sys/imio/impl1.gx new file mode 100644 index 00000000..4fe23b4b --- /dev/null +++ b/sys/imio/impl1.gx @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMPL1? -- Put a line to an apparently one dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl1$t (im) + +pointer im # image header pointer +int fd, nchars +long offset +pointer bp, impgs$t(), fwritep() +errchk imopsf + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_PIXEL) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + offset = IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_PIXEL + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_PIXEL + 1) + return (bp) + } + return (impgs$t (im, long(1), IM_LEN(im,1), 1)) + } +end diff --git a/sys/imio/impl2.gx b/sys/imio/impl2.gx new file mode 100644 index 00000000..545d2ed3 --- /dev/null +++ b/sys/imio/impl2.gx @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMPL2? -- Put a line to an apparently two dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl2$t (im, linenum) + +pointer im # image header pointer +int linenum # line to be written + +int fd, nchars +long vs[2], ve[2], offset +pointer bp, impgs$t(), fwritep() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_PIXEL) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (linenum < 1 || linenum > IM_LEN(im,2)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (linenum - 1) * IM_PHYSLEN(im,1) * SZ_PIXEL + + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_PIXEL + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_PIXEL + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = linenum + ve[2] = linenum + + return (impgs$t (im, vs, ve, 2)) + } +end diff --git a/sys/imio/impl3.gx b/sys/imio/impl3.gx new file mode 100644 index 00000000..d9ed5699 --- /dev/null +++ b/sys/imio/impl3.gx @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMPL3? -- Put a line to an apparently three dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl3$t (im, line, band) + +pointer im # image header pointer +int line # line number within band +int band # band number + +int fd, nchars +long vs[3], ve[3], offset +pointer bp, impgs$t(), fwritep() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_PIXEL) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (line < 1 || line > IM_LEN(im,2) || + band < 1 || band > IM_LEN(im,3)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (((band - 1) * IM_PHYSLEN(im,2) + line - 1) * + IM_PHYSLEN(im,1)) * SZ_PIXEL + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_PIXEL + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_PIXEL + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = line + ve[2] = line + vs[3] = band + ve[3] = band + + return (impgs$t (im, vs, ve, 3)) + } +end diff --git a/sys/imio/impmhdr.x b/sys/imio/impmhdr.x new file mode 100644 index 00000000..d8219996 --- /dev/null +++ b/sys/imio/impmhdr.x @@ -0,0 +1,331 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +.help impmhdr +.nf -------------------------------------------------------------------------- +IMPMHDR -- Routines to encode/decode an image header in a title string +such as is provided by pl_[save|load]f, so that general image headers can +be saved in .pl files. + + nchars = im_pmsvhdr (im, bufp, sz_buf) + im_pmldhdr (im, bufp) + +The information saved in the plio save file title string consist of a +series of keyword = value assignments, one per line. +.endhelp --------------------------------------------------------------------- + +define DEF_SZBUF 32768 +define INC_SZBUF 16384 +define INC_HDRMEM 8100 +define IDB_RECLEN 80 + +define KW_TITLE "$TITLE = " +define LEN_KWTITLE 9 +define KW_CTIME "$CTIME = " +define LEN_KWCTIME 9 +define KW_MTIME "$MTIME = " +define LEN_KWMTIME 9 +define KW_LIMTIME "$LIMTIME = " +define LEN_KWLIMTIME 11 +define KW_MINPIXVAL "$MINPIXVAL = " +define LEN_KWMINPIXVAL 13 +define KW_MAXPIXVAL "$MAXPIXVAL = " +define LEN_KWMAXPIXVAL 13 + + +# IM_PMSVHDR -- Save an image header in a text string as a sequence of +# keyword = value assignments, one per line. A pointer to a text buffer +# containing the encoded header is returned as the output parameter, and +# the string length in chars is returned as the function value. +# The caller should deallocate this buffer when it is no longer needed. + +int procedure im_pmsvhdr (im, bp, sz_buf) + +pointer im #I image descriptor +pointer bp #U buffer containing encoded header +int sz_buf #U allocated size of buffer, chars + +int nchars, ualen, ch, i +pointer sp, tbuf, ip, op, idb, rp +errchk malloc, realloc, idb_open +int gstrcpy(), idb_nextcard +pointer idb_open() + +begin + call smark (sp) + call salloc (tbuf, SZ_IMTITLE, TY_CHAR) + + # Allocate text buffer if the user hasn't already done so. + if (bp == NULL || sz_buf <= 0) { + sz_buf = DEF_SZBUF + call malloc (bp, sz_buf, TY_CHAR) + } + + # Store title string in buffer. + call strcpy (IM_TITLE(im), Memc[tbuf], SZ_IMTITLE) + op = bp + gstrcpy (KW_TITLE, Memc[bp], ARB) + Memc[op] = '"'; op = op + 1 + for (ip=tbuf; Memc[ip] != EOS; ip=ip+1) { + if (Memc[ip] == '"') { + Memc[op] = '\\'; op = op + 1 + } + Memc[op] = Memc[ip]; op = op + 1 + } + Memc[op] = '"'; op = op + 1 + Memc[op] = '\n'; op = op + 1 + + # Store the create time in buffer. + call sprintf (Memc[tbuf], SZ_IMTITLE, "%d") + call pargl (IM_CTIME(im)) + op = op + gstrcpy (KW_CTIME, Memc[op], ARB) + op = op + gstrcpy (Memc[tbuf], Memc[op], ARB) + Memc[op] = '\n'; op = op + 1 + + # Store the modify time in buffer. + call sprintf (Memc[tbuf], SZ_IMTITLE, "%d") + call pargl (IM_MTIME(im)) + op = op + gstrcpy (KW_MTIME, Memc[op], ARB) + op = op + gstrcpy (Memc[tbuf], Memc[op], ARB) + Memc[op] = '\n'; op = op + 1 + + # Store the limits time in buffer. + call sprintf (Memc[tbuf], SZ_IMTITLE, "%d") + call pargl (IM_LIMTIME(im)) + op = op + gstrcpy (KW_LIMTIME, Memc[op], ARB) + op = op + gstrcpy (Memc[tbuf], Memc[op], ARB) + Memc[op] = '\n'; op = op + 1 + + # Store the minimum good pixel value in buffer. + call sprintf (Memc[tbuf], SZ_IMTITLE, "%g") + call pargr (IM_MIN(im)) + op = op + gstrcpy (KW_MINPIXVAL, Memc[op], ARB) + op = op + gstrcpy (Memc[tbuf], Memc[op], ARB) + Memc[op] = '\n'; op = op + 1 + + # Store the maximum good pixel value in buffer. + call sprintf (Memc[tbuf], SZ_IMTITLE, "%g") + call pargr (IM_MAX(im)) + op = op + gstrcpy (KW_MAXPIXVAL, Memc[op], ARB) + op = op + gstrcpy (Memc[tbuf], Memc[op], ARB) + Memc[op] = '\n'; op = op + 1 + + # Copy the header cards. + idb = idb_open (im, ualen) + while (idb_nextcard (idb, rp) != EOF) { + + # Increase the size of the output buffer if it fills. + nchars = op - bp + if (sz_buf - nchars < IDB_RECLEN) { + sz_buf = sz_buf + INC_SZBUF + call realloc (bp, sz_buf, TY_CHAR) + op = bp + nchars + } + + # Copy the card, stripping any trailing whitespace. + nchars = 0 + do i = 1, IDB_RECLEN { + ch = Memc[rp+i-1] + Memc[op+i-1] = ch + if (!IS_WHITE(ch)) + nchars = i + } + + op = op + nchars + Memc[op] = '\n'; op = op + 1 + } + + # All done, terminate the string and return any extra space. + Memc[op] = EOS; op = op + 1 + nchars = op - bp + call realloc (bp, nchars, TY_CHAR) + + # Clean up. + call idb_close (idb) + call sfree (sp) + + return (nchars) +end + + +# IM_PMLDHDR -- Load the image header from a save buffer, prepared in a +# previous call to im_pmsvhdr. The saved header will overwrite any +# existing cards in the output image header. + +procedure im_pmldhdr (im, bp) + +pointer im #I image descriptor +pointer bp #I pointer to text buffer (header save buf) + +int hdrlen, sz_ua, nchars, ch, i +pointer sp, tbuf, ip, op, rp, ua +int strncmp(), ctol(), ctor() +errchk realloc + +begin + call smark (sp) + call salloc (tbuf, SZ_IMTITLE, TY_CHAR) + + # Get the image title string. + for (ip = bp; Memc[ip] != EOS;) { + if (Memc[ip] == '$') { + if (strncmp (Memc[ip], KW_TITLE, LEN_KWTITLE) == 0) { + # Advance to first character of quoted string. + ip = ip + LEN_KWTITLE + while (Memc[ip] != EOS && Memc[ip] != '"') + ip = ip + 1 + if (Memc[ip] == '"') + ip = ip + 1 + + # Extract the string. + op = tbuf + while (Memc[ip] != EOS && Memc[ip] != '"') { + if (Memc[ip] == '\\' && Memc[ip+1] == '"') + ip = ip + 1 + Memc[op] = Memc[ip] + op = min (tbuf + SZ_IMTITLE, op + 1) + ip = ip + 1 + } + + # Store in image descriptor. + Memc[op] = EOS + call strcpy (Memc[tbuf], IM_TITLE(im), SZ_IMTITLE) + + # Advance to next line. + while (Memc[ip] != EOS && Memc[ip] != '\n') + ip = ip + 1 + if (Memc[ip] == '\n') + ip = ip + 1 + + } else if (strncmp (Memc[ip], KW_CTIME, LEN_KWCTIME) == 0) { + # Decode the create time. + ip = ip + LEN_KWCTIME + rp = 1 + if (ctol (Memc[ip], rp, IM_CTIME(im)) <= 0) + IM_CTIME(im) = 0 + ip = ip + rp - 1 + + # Advance to next line. + while (Memc[ip] != EOS && Memc[ip] != '\n') + ip = ip + 1 + if (Memc[ip] == '\n') + ip = ip + 1 + + } else if (strncmp (Memc[ip], KW_MTIME, LEN_KWMTIME) == 0) { + # Decode the modify time. + ip = ip + LEN_KWMTIME + rp = 1 + if (ctol (Memc[ip], rp, IM_MTIME(im)) <= 0) + IM_MTIME(im) = 0 + ip = ip + rp - 1 + + # Advance to next line. + while (Memc[ip] != EOS && Memc[ip] != '\n') + ip = ip + 1 + if (Memc[ip] == '\n') + ip = ip + 1 + + } else if (strncmp (Memc[ip], KW_LIMTIME, LEN_KWLIMTIME) == 0) { + # Decode the limits time. + ip = ip + LEN_KWLIMTIME + rp = 1 + if (ctol (Memc[ip], rp, IM_LIMTIME(im)) <= 0) + IM_LIMTIME(im) = 0 + ip = ip + rp - 1 + + # Advance to next line. + while (Memc[ip] != EOS && Memc[ip] != '\n') + ip = ip + 1 + if (Memc[ip] == '\n') + ip = ip + 1 + + } else if (strncmp(Memc[ip],KW_MINPIXVAL,LEN_KWMINPIXVAL)==0) { + # Decode the minimum pixel value. + ip = ip + LEN_KWMINPIXVAL + rp = 1 + if (ctor (Memc[ip], rp, IM_MIN(im)) <= 0) + IM_MIN(im) = 0.0 + ip = ip + rp - 1 + + # Advance to next line. + while (Memc[ip] != EOS && Memc[ip] != '\n') + ip = ip + 1 + if (Memc[ip] == '\n') + ip = ip + 1 + + } else if (strncmp(Memc[ip],KW_MAXPIXVAL,LEN_KWMAXPIXVAL)==0) { + # Decode the maximum pixel value. + ip = ip + LEN_KWMAXPIXVAL + rp = 1 + if (ctor (Memc[ip], rp, IM_MAX(im)) <= 0) + IM_MAX(im) = 0.0 + ip = ip + rp - 1 + + # Advance to next line. + while (Memc[ip] != EOS && Memc[ip] != '\n') + ip = ip + 1 + if (Memc[ip] == '\n') + ip = ip + 1 + + } else { + # No keyword matched. Advance to next line. + while (Memc[ip] != EOS && Memc[ip] != '\n') + ip = ip + 1 + if (Memc[ip] == '\n') + ip = ip + 1 + } + } else + break + } + + # Get the header keywords. + hdrlen = LEN_IMDES + IM_LENHDRMEM(im) + sz_ua = (hdrlen - IMU) * SZ_STRUCT - 1 + ua = IM_USERAREA(im) + op = ua + + while (Memc[ip] != EOS) { + rp = op + + # Reallocate descriptor if we need more space. Since we are + # called at image map time and the descriptor pointer has not + # yet been passed out, the image descriptor can be reallocated. + + nchars = rp - ua + if (nchars + IDB_RECLEN + 2 > sz_ua) { + hdrlen = hdrlen + INC_HDRMEM + IM_LENHDRMEM(im) = IM_LENHDRMEM(im) + INC_HDRMEM + call realloc (im, hdrlen, TY_STRUCT) + sz_ua = (hdrlen - IMU) * SZ_STRUCT - 1 + ua = IM_USERAREA(im) + op = ua + nchars + } + + # Copy the saved card, leave IP positioned to past newline. + do i = 1, IDB_RECLEN + 1 { + ch = Memc[ip] + if (ch != EOS) + ip = ip + 1 + if (ch == '\n') + break + Memc[op] = ch + op = op + 1 + } + + # Blank fill the card. + while (op - rp < IDB_RECLEN) { + Memc[op] = ' ' + op = op + 1 + } + + # Add newline termination. + Memc[op] = '\n'; op = op + 1 + } + + Memc[op] = EOS + IM_UABLOCKED(im) = YES + + call sfree (sp) +end diff --git a/sys/imio/impmlne1.x b/sys/imio/impmlne1.x new file mode 100644 index 00000000..e8348349 --- /dev/null +++ b/sys/imio/impmlne1.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IM_PMLNE1 -- Pixel mask line not empty. + +bool procedure im_pmlne1 (im) + +pointer im #I image descriptor +long v[IM_MAXDIM] + +bool pm_linenotempty() + +begin + call amovkl (1, v, IM_MAXDIM) + return (pm_linenotempty (IM_PL(im), v)) +end diff --git a/sys/imio/impmlne2.x b/sys/imio/impmlne2.x new file mode 100644 index 00000000..6f15dfd1 --- /dev/null +++ b/sys/imio/impmlne2.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IM_PMLNE2 -- Pixel mask line not empty. + +bool procedure im_pmlne2 (im, lineno) + +pointer im #I image descriptor +int lineno #I line number + +long v[IM_MAXDIM] +bool pm_linenotempty() + +begin + call amovkl (1, v, IM_MAXDIM) + v[2] = lineno + + return (pm_linenotempty (IM_PL(im), v)) +end diff --git a/sys/imio/impmlne3.x b/sys/imio/impmlne3.x new file mode 100644 index 00000000..f41c8e11 --- /dev/null +++ b/sys/imio/impmlne3.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IM_PMLNE3 -- Pixel mask line not empty. + +bool procedure im_pmlne3 (im, lineno, bandno) + +pointer im #I image descriptor +int lineno #I line number +int bandno #I band number + +long v[IM_MAXDIM] +bool pm_linenotempty() + +begin + call amovkl (1, v, IM_MAXDIM) + v[2] = lineno + v[3] = bandno + + return (pm_linenotempty (IM_PL(im), v)) +end diff --git a/sys/imio/impmlnev.x b/sys/imio/impmlnev.x new file mode 100644 index 00000000..d6d03b87 --- /dev/null +++ b/sys/imio/impmlnev.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IM_PMLNEV -- Test if a mask image line is nonempty. + +bool procedure im_pmlnev (im, v) + +pointer im #I image descriptor +long v[IM_MAXDIM] #I vector coordinates of image line + +bool pm_linenotempty() + +begin + return (pm_linenotempty (IM_PL(im), v)) +end diff --git a/sys/imio/impmmap.x b/sys/imio/impmmap.x new file mode 100644 index 00000000..21ec5038 --- /dev/null +++ b/sys/imio/impmmap.x @@ -0,0 +1,92 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# IM_PMMAP -- Map a pixel list as a virtual mask image. If the mask name +# given is "BPM" (upper case) the bad pixel list for the reference image is +# opened, if the mask name is "EMPTY" an empty mask is opened, otherwise the +# mask name is taken to be the name of the file in which the mask is stored. +# If there is no bad pixel list for the image an empty mask is opened. +# If a more specialized mask is needed it should be opened or generated via +# explicit calls to the PMIO package, and then mapped onto an image descriptor +# with IM_PMMAPO. + +pointer procedure im_pmmap (mask, mode, ref_im) + +char mask[ARB] #I mask file name or "BPM" +int mode #I mode and flag bits +pointer ref_im #I reference image + +pointer sp, cluster, section, pl, im, hp +int acmode, flags, sz_svhdr, ip +pointer im_pmmapo(), im_pmopen() +int btoi(), ctoi(), envfind() +errchk im_pmopen, im_pmopen + +begin + call smark (sp) + call salloc (cluster, SZ_PATHNAME, TY_CHAR) + call salloc (section, SZ_FNAME, TY_CHAR) + + acmode = PL_ACMODE(mode) + flags = PL_FLAGS(mode) + + # If opening an existing mask, get a buffer for the saved mask image + # header. + + if (acmode != NEW_IMAGE && acmode != NEW_COPY) { + ip = 1 + if (envfind ("min_lenuserarea", Memc[section], SZ_FNAME) > 0) { + if (ctoi (Memc[section], ip, sz_svhdr) <= 0) + sz_svhdr = MIN_LENUSERAREA + } else + sz_svhdr = MIN_LENUSERAREA + call salloc (hp, sz_svhdr, TY_CHAR) + } + + # Parse the full image specification into a root name and an image + # section. + call imgimage (mask, Memc[cluster], SZ_PATHNAME) + call imgsection (mask, Memc[section], SZ_FNAME) + + # Open the mask. + pl = im_pmopen (Memc[cluster], mode, Memc[hp], sz_svhdr, ref_im) + + # Map the mask onto an image descriptor. + iferr (im = im_pmmapo (pl, ref_im)) { + call pl_close (pl) + call erract (EA_ERROR) + } else { + call strcpy (mask, IM_NAME(im), SZ_IMNAME) + if (acmode != NEW_IMAGE && acmode != NEW_COPY) + call im_pmldhdr (im, hp) + } + + # Set flag to close PL descriptor at IMUNMAP time. + IM_PLFLAGS(im) = or (IM_PLFLAGS(im), PL_CLOSEPL) + + # If we are creating a new mask of type boolean, set bool flag so + # that imopsf will make a boolean mask. + + if (acmode == NEW_IMAGE || acmode == NEW_COPY) + if (and (flags, BOOLEAN_MASK) != 0) + IM_PLFLAGS(im) = or (IM_PLFLAGS(im), PL_BOOL) + + # Set access mode for mask, and mask update at unmap flag. + IM_ACMODE(im) = acmode + IM_UPDATE(im) = btoi (acmode != READ_ONLY) + + IM_NPHYSDIM(im) = IM_NDIM(im) + call amovl (IM_LEN(im,1), IM_PHYSLEN(im,1), IM_MAXDIM) + call amovl (IM_LEN(im,1), IM_SVLEN(im,1), IM_MAXDIM) + + # Set up section transformation. + if (ref_im == NULL && Memc[section] != EOS) + call imisec (im, Memc[section]) + + call sfree (sp) + return (im) +end diff --git a/sys/imio/impmmapo.x b/sys/imio/impmmapo.x new file mode 100644 index 00000000..318ce573 --- /dev/null +++ b/sys/imio/impmmapo.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +# IM_PMMAPO -- Map an open pixel list onto an image descriptor, so that the +# pixel list may be accessed as a virtual "mask image". If a reference image +# is specified the mask image inherits any image section etc., defined for +# the reference image. + +pointer procedure im_pmmapo (pl, ref_im) + +pointer pl #I mask descriptor +pointer ref_im #I reference image or NULL + +pointer im +long axlen[IM_MAXDIM] +int naxes, depth, i +errchk syserr, immapz, pl_gsize +pointer immapz() + +begin + # Get the mask size. + call pl_gsize (pl, naxes, axlen, depth) + + # Verify the size if there is a reference image. + if (ref_im != NULL) + do i = 1, max (naxes, IM_NPHYSDIM(ref_im)) + if (IM_SVLEN(ref_im,i) != axlen[i]) + call syserr (SYS_IMPLSIZE) + + # Open an image header for the mask. + call iki_init() + im = immapz ("dev$null", NEW_IMAGE, 0) + + # Set up the image descriptor. + IM_NDIM(im) = naxes + IM_PIXTYPE(im) = TY_INT + call amovl (axlen, IM_LEN(im,1), IM_MAXDIM) + + IM_PL(im) = pl + IM_PLREFIM(im) = ref_im + IM_PLFLAGS(im) = 0 + IM_MIN(im) = 0 + IM_MAX(im) = 2 ** depth - 1 + IM_LIMTIME(im) = IM_MTIME(im) + 1 + IM_UPDATE(im) = NO + + PM_REFIM(pl) = im + if (ref_im != NULL) + PM_MAPXY(pl) = IM_SECTUSED(ref_im) + else + PM_MAPXY(pl) = NO + + # Further setup of the image descriptor is carried out by IMOPSF + # when the first i/o access occurs, as for a regular image. + + return (im) +end diff --git a/sys/imio/impmopen.x b/sys/imio/impmopen.x new file mode 100644 index 00000000..bd8a564b --- /dev/null +++ b/sys/imio/impmopen.x @@ -0,0 +1,99 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +# IM_PMOPEN -- Open an image mask. If the mask name is given is "BPM" (upper +# case) the bad pixel list for the reference image is opened, if the mask name +# is "EMPTY" an empty mask is opened, otherwise the mask name is taken to be +# the name of the file in which the mask is stored. If there is no bad pixel +# list for the image an empty mask is opened. If a more specialized mask is +# needed it should be opened or generated via explicit calls to the PMIO +# package. + +pointer procedure im_pmopen (mask, mode, title, maxch, ref_im) + +char mask[ARB] #I mask file name or "BPM" +int mode #I mode and flag bits +char title[maxch] #O mask title +int maxch #I max chars out +pointer ref_im #I reference image + +pointer sp, fname, pl, b_pl +long axlen[PL_MAXDIM], v[PL_MAXDIM] +int acmode, flags, naxes, depth + +bool streq() +pointer pl_open(), pl_create() +errchk syserr, pl_open, pl_create, pl_loadf, pl_loadim + +string s_empty "EMPTY" # the empty mask +string s_bpl "BPM" # the reference image bad pixel list + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + acmode = PL_ACMODE(mode) + flags = PL_FLAGS(mode) + + # Get mask name for the BPM for the given reference image. + if (streq (mask, s_bpl)) { + if (ref_im == NULL) + call syserr (SYS_IMPLNORI) + iferr (call imgstr (ref_im, s_bpl, Memc[fname], SZ_FNAME)) + call strcpy (s_empty, Memc[fname], SZ_FNAME) + } else + call strcpy (mask, Memc[fname], SZ_FNAME) + + pl = pl_open (NULL) + + # Open the named mask. + if (acmode != NEW_IMAGE && acmode != NEW_COPY) { + if (streq (Memc[fname], s_empty)) { + if (ref_im == NULL) { + call pl_close (pl) + call syserr (SYS_IMPLNORI) + } + call pl_ssize (pl, IM_NPHYSDIM(ref_im), IM_SVLEN(ref_im,1), 1) + } else { + iferr (call pl_loadf (pl, Memc[fname], title, maxch)) { + call pl_close (pl) + pl = pl_open (NULL) + iferr (call pl_loadim (pl, Memc[fname], title, maxch)) { + call pl_close (pl) + call erract (EA_ERROR) + } + } + } + + # Modify the mask according to the given flags, if any. + if (flags != 0) { + call pl_gsize (pl, naxes, axlen, depth) + call amovkl (1, v, PL_MAXDIM) + + if (and (flags, BOOLEAN_MASK) != 0 && depth > 1) { + b_pl = pl_create (naxes, axlen, 1) + + if (and (flags, INVERT_MASK) != 0) { + call pl_rop (pl, v, b_pl, v, axlen, PIX_SRC) + call amovkl (1, v, PL_MAXDIM) + call pl_rop (b_pl, v, b_pl, v, axlen, PIX_NOT(PIX_SRC)) + } else { + call pl_rop (pl, v, b_pl, v, axlen, PIX_SRC) + } + + call pl_close (pl) + pl = b_pl + + } else if (and (flags, INVERT_MASK) != 0) + call pl_rop (pl, v, pl, v, axlen, PIX_NOT(PIX_SRC)) + } + } + + call sfree (sp) + return (pl) +end diff --git a/sys/imio/impmsne1.x b/sys/imio/impmsne1.x new file mode 100644 index 00000000..044aee81 --- /dev/null +++ b/sys/imio/impmsne1.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IM_PMSNE1 -- Pixel mask section not empty. + +bool procedure im_pmsne1 (im, x1, x2) + +pointer im #I image descriptor +int x1, x2 #I section to be tested + +bool pm_sectnotempty() + +begin + return (pm_sectnotempty (IM_PL(im), x1, x2, 1)) +end diff --git a/sys/imio/impmsne2.x b/sys/imio/impmsne2.x new file mode 100644 index 00000000..42cb7141 --- /dev/null +++ b/sys/imio/impmsne2.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IM_PMSNE2 -- Pixel mask section not empty. + +bool procedure im_pmsne2 (im, x1, x2, y1, y2) + +pointer im #I image descriptor +int x1, x2 #I section to be tested +int y1, y2 #I section to be tested + +long vs[2], ve[2] +bool pm_sectnotempty() + +begin + vs[1] = x1; vs[2] = y1 + ve[1] = x2; ve[2] = y2 + + return (pm_sectnotempty (IM_PL(im), vs, ve, 2)) +end diff --git a/sys/imio/impmsne3.x b/sys/imio/impmsne3.x new file mode 100644 index 00000000..15a132d6 --- /dev/null +++ b/sys/imio/impmsne3.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IM_PMSNE3 -- Pixel mask section not empty. + +bool procedure im_pmsne3 (im, x1,x2, y1,y2, z1,z2) + +pointer im #I image descriptor +int x1, x2 #I section to be tested +int y1, y2 #I section to be tested +int z1, z2 #I section to be tested + +long vs[3], ve[3] +bool pm_sectnotempty() + +begin + vs[1] = x1; vs[2] = y1; vs[3] = z1 + ve[1] = x2; ve[2] = y2; ve[3] = z2 + + return (pm_sectnotempty (IM_PL(im), vs, ve, 3)) +end diff --git a/sys/imio/impmsnev.x b/sys/imio/impmsnev.x new file mode 100644 index 00000000..f50fefb6 --- /dev/null +++ b/sys/imio/impmsnev.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IM_PMSNEV -- Test if a mask image section is nonempty. + +bool procedure im_pmsnev (im, vs, ve, ndim) + +pointer im #I image descriptor +long vs[IM_MAXDIM] #I vector coordinates of start of section +long ve[IM_MAXDIM] #I vector coordinates of end of section +int ndim #I dimensionality of section + +bool pm_sectnotempty() + +begin + return (pm_sectnotempty (IM_PL(im), vs, ve, ndim)) +end diff --git a/sys/imio/impnl.gx b/sys/imio/impnl.gx new file mode 100644 index 00000000..27acdfae --- /dev/null +++ b/sys/imio/impnl.gx @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMPNL -- Put the next line to an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# before the first call to the first line to be written. Each call increments +# the leftmost subscript by one, until V equals IM_LEN, at which time EOF +# is returned. Subsequent writes are ignored. + +int procedure impnl$t (imdes, lineptr, v) + +pointer imdes +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int npix +int impnln() +extern imfls$t() +errchk impnln + +begin + if (IM_FLUSH(imdes) == YES) + call zcall1 (IM_FLUSHEPA(imdes), imdes) + + npix = impnln (imdes, lineptr, v, TY_PIXEL) + if (IM_FLUSH(imdes) == YES) + call zlocpr (imfls$t, IM_FLUSHEPA(imdes)) + + return (npix) +end diff --git a/sys/imio/impnln.x b/sys/imio/impnln.x new file mode 100644 index 00000000..f5197768 --- /dev/null +++ b/sys/imio/impnln.x @@ -0,0 +1,109 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMPNLN -- Put the next line to an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# to the first line to be written before the first call. Each call increments +# the leftmost subscript by one, until V equals IM_LEN. EOF is returned +# when the last line in the image has been written. + +int procedure impnln (im, lineptr, v, dtype) + +pointer im +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int dtype # eventual datatype of pixels + +long lineoff, line, band, offset +int dim, ndim, junk, sz_pixel, sz_dtype, fd, nchars, pixtype +long vs[IM_MAXDIM], ve[IM_MAXDIM], unit_v[IM_MAXDIM], npix + +int imloop() +pointer imgobf(), fwritep() +errchk imgobf, fwritep, imerr, imopsf +define retry_ 91 +define oob_ 92 +define misaligned_ 93 + +int sizeof() +include +data unit_v /IM_MAXDIM * 1/ + +begin + ndim = IM_NDIM(im) + if (ndim == 0) + return (EOF) + + npix = IM_LEN(im,1) # write entire line + pixtype = IM_PIXTYPE(im) + sz_pixel = pix_size[pixtype] + sz_dtype = sizeof(pixtype) + + # Perform "zero trip" check (V >= VE), before entering "loop". + if (v[ndim] > IM_LEN(im,ndim)) + return (EOF) +retry_ + if (IM_FAST(im) == YES && pixtype == dtype && ndim <= 3) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + goto retry_ + } + + # Lineoff is the dimensionless line offset in the pixel storage + # file (which we assume to be in line storage mode). + + lineoff = 0 + if (ndim > 1) { + line = v[2] + if (line < 1 || line > IM_LEN(im,2)) + goto oob_ + lineoff = line - 1 + if (ndim > 2) { + band = v[3] + if (band < 1 || band > IM_LEN(im,3)) +oob_ call imerr (IM_NAME(im), SYS_IMREFOOB) + lineoff = lineoff + (band - 1) * IM_PHYSLEN(im,2) + } + } + + # Reference directly into the FIO buffer. If the line straddles + # FIO block boundaries then fwritep will return error and we must + # use a separate buffer. + + offset = lineoff * IM_PHYSLEN(im,1) * sz_pixel + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * sz_pixel + iferr (lineptr = (fwritep (fd, offset, nchars) - 1) / sz_pixel + 1) + goto misaligned_ + + } else { +misaligned_ + # Prepare section descriptor vectors. + vs[1] = 1 + ve[1] = npix + do dim = 2, ndim { + vs[dim] = v[dim] + ve[dim] = v[dim] + } + + # Get the output line buffer. + lineptr = imgobf (im, vs, ve, ndim, dtype) + IM_FLUSH(im) = YES + } + + # Increment loop vector (cannot use nested loops since the dimension + # of the image is variable). Note this loop vector references + # logical section coordinates. + + if (ndim == 1) + v[1] = IM_LEN(im,1) + 1 + else if (ndim == 2 && IM_FAST(im) == YES) + v[2] = v[2] + 1 + else + junk = imloop (v, unit_v, IM_LEN(im,1), unit_v, ndim) + + return (npix) +end diff --git a/sys/imio/imps1.gx b/sys/imio/imps1.gx new file mode 100644 index 00000000..9e225923 --- /dev/null +++ b/sys/imio/imps1.gx @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMPS1? -- Put a section to an apparently one dimensional image. + +pointer procedure imps1$t (im, x1, x2) + +pointer im # image header pointer +int x1 # first column +int x2 # last column + +pointer impgs$t(), impl1$t() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1)) + return (impl1$t (im)) + else + return (impgs$t (im, long(x1), long(x2), 1)) +end diff --git a/sys/imio/imps2.gx b/sys/imio/imps2.gx new file mode 100644 index 00000000..ee5ac4a3 --- /dev/null +++ b/sys/imio/imps2.gx @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMPS2? -- Put a section to an apparently two dimensional image. + +pointer procedure imps2$t (im, x1, x2, y1, y2) + +pointer im +int x1, x2, y1, y2 +long vs[2], ve[2] +pointer impgs$t(), impl2$t() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2) + return (impl2$t (im, y1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + return (impgs$t (im, vs, ve, 2)) + } +end diff --git a/sys/imio/imps3.gx b/sys/imio/imps3.gx new file mode 100644 index 00000000..490ee531 --- /dev/null +++ b/sys/imio/imps3.gx @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMPS3? -- Put a section to an apparently three dimensional image. + +pointer procedure imps3$t (im, x1, x2, y1, y2, z1, z2) + +pointer im +int x1, x2, y1, y2, z1, z2 +long vs[3], ve[3] +pointer impgs$t(), impl3$t() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2 && z1 == z2) + return (impl3$t (im, y1, z1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + vs[3] = z1 + ve[3] = z2 + + return (impgs$t (im, vs, ve, 3)) + } +end diff --git a/sys/imio/imrbpx.x b/sys/imio/imrbpx.x new file mode 100644 index 00000000..ea54aeff --- /dev/null +++ b/sys/imio/imrbpx.x @@ -0,0 +1,129 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMRBPX -- Read a line segment from an image with boundary extension. The +# line segment is broken up into three parts, i.e., left, center, and right. +# The endpoints of each segment, if out of bounds, are mapped back into the +# image using the current boundary extension technique. The mapped line +# segment in physical coordinates is then extracted; if an image section is +# defined the section transformation has already been performed before we are +# called. After all three segments have been extracted the entire line +# segment is flipped if the flip flag is set. + +procedure imrbpx (im, obuf, totpix, v, vinc) + +pointer im # image descriptor +char obuf[ARB] # typeless output buffer +int totpix # total number of pixels to extract +long v[ARB] # vector pointer to start of line segment +long vinc[ARB] # step on each axis + +bool oob +char pixval[8] +int npix, ndim, sz_pixel, btype, op, off, step, xstep, imtyp, i, j, k, ncp +long xs[3], xe[3], x1, x2, p, v1[IM_MAXDIM], v2[IM_MAXDIM], linelen +errchk imrdpx +include + +begin + sz_pixel = pix_size[IM_PIXTYPE(im)] + ndim = IM_NPHYSDIM(im) + + # Cache the left and right endpoints of the line segment and the + # image line length. + + xstep = abs (IM_VSTEP(im,1)) + linelen = IM_SVLEN(im,1) + x1 = v[1] + x2 = x1 + (totpix * xstep) - 1 + + # Compute the endpoints of the line segment in the three x-regions of + # the image. + + xs[1] = x1 # left oob region + xe[1] = min (0, x2) + xs[2] = max (x1, 1) # central inbounds region + xe[2] = min (x2, linelen) + xs[3] = max (x1, linelen + 1) # right oob region + xe[3] = x2 + + # Perform bounds mapping on the entire vector. The mapping for all + # dimensions higher than the first is invariant in what follows. + + call imbtran (im, v, v1, ndim) + + # Copy V1 to V2 and determine if the whole thing is out of bounds. + oob = false + do i = 2, ndim { + p = v1[i] + v2[i] = p + if (p < 1 || p > IM_SVLEN(im,i)) + oob = true + } + + # Extract that portion of the line segment falling in each region + # into the output buffer. There are two classes of boundary extension + # techniques, those that fill the out of bounds area with a constant, + # and those that map the oob area into a vector lying within the bounds + # of the image. + + btype = IM_VTYBNDRY(im) + imtyp = IM_PIXTYPE(im) + op = 1 + + do i = 1, 3 { + # Skip to next region if there are no pixels in this region. + npix = (xe[i] - xs[i]) / xstep + 1 + if (npix <= 0) + next + + # Map the endpoints of the segment. + call imbtran (im, xs[i], v1[1], 1) + call imbtran (im, xe[i], v2[1], 1) + + # Compute the starting vector V1, step in X, and the number of + # pixels in the region allowing for subsampling. + + if (v1[1] > v2[1]) { + step = -xstep + v1[1] = v2[1] + } else + step = xstep + + # Perform the boundary extension. + ncp = sz_pixel + call aclrc (pixval, 8) + if ((i == 2 && !oob) || btype == BT_REFLECT || btype == BT_WRAP) + call imrdpx (im, obuf[op], npix, v1, step) + else { + # Use constant or value of nearest boundary pixel. + if (btype == BT_CONSTANT) + call impakr (IM_OOBPIX(im), pixval, 1, IM_PIXTYPE(im)) + else + call imrdpx (im, pixval, 1, v1, step) + + if ((imtyp == TY_INT || imtyp == TY_LONG) && + SZ_INT != SZ_INT32) { + call iupk32 (pixval, pixval, 2) + ncp = sz_pixel * 2 + } + + # Fill the output array. + off = op - 1 + do j = 1, npix { + do k = 1, ncp + obuf[off+k] = pixval[k] + off = off + ncp + } + } + + op = op + (npix * ncp) + } + + # Flip the output array if the step size in X is negative. + if (vinc[1] < 0) + call imaflp (obuf, totpix, sz_pixel) +end diff --git a/sys/imio/imrdpx.x b/sys/imio/imrdpx.x new file mode 100644 index 00000000..1c7d3564 --- /dev/null +++ b/sys/imio/imrdpx.x @@ -0,0 +1,112 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +# IMRDPX -- Read NPIX * STEP pixels, stored contiguously in the pixel storage +# file, starting with the pixel whose coordinates are given by the vector V, +# into the buffer BUF. If the step size is not unity, accumulate pixels 1, +# 1 + STEP, and so on for a total of NPIX pixels, at the start of the buffer. +# If VINC is negative, flip the array of NPIX pixels end for end. + +procedure imrdpx (im, obuf, npix, v, xstep) + +pointer im # image descriptor +char obuf[ARB] # output buffer +int npix # number of pixels to extract +long v[IM_MAXDIM] # physical coords of first pixel +int xstep # step between pixels in X (neg for a flip) + +pointer pl +long offset +int sz_pixel, nbytes, fd, op, step, nchars, n + +char zbuf[1024] + +int read() +long imnote() +errchk imerr, seek, read, pl_glpi, pl_glri +include + +begin + step = abs (xstep) + if (v[1] < 1 || ((npix-1) * step) + v[1] > IM_SVLEN(im,1)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + pl = IM_PL(im) + fd = IM_PFD(im) + offset = imnote (im, v) + sz_pixel = pix_size[IM_PIXTYPE(im)] + + # If the step size is small, read in all the data at once and + # resample. Requires a buffer STEP times larger than necessary, + # but is most efficient for small step sizes. If the step size + # is very large, read each pixel with a separate READ call (buffer + # size no larger than necessary). Most efficient technique for very + # large step sizes. + + if (pl != NULL) { + # Read from a pixel list. Range list i/o is permitted at this + # level only if no pixel conversions are required, i.e., only if + # "fast" i/o is enabled. Otherwise, we must return pixels here + # and then convert back to a range list after the conversions. + + n = ((npix-1) * step + 1) + if (and (IM_PLFLAGS(im), PL_FAST+PL_RLIO) == PL_FAST+PL_RLIO) + call pl_glri (pl, v, obuf, 0, n, PIX_SRC) + else { + call pl_glpi (pl, v, obuf, 0, n, PIX_SRC) + if (step > 1) + call imsamp (obuf, obuf, npix, sz_pixel, step) + } + + } else if (step <= IM_MAXSTEP) { + # Seek to the point V in the pixel storage file. Compute size + # of transfer. Read in the data, resample. + + call seek (fd, offset) + nchars = ((npix-1) * step + 1) * sz_pixel + + if (read (fd, obuf, nchars) != nchars) + call imerr (IM_NAME(im), SYS_IMNOPIX) + if (step > 1) + call imsamp (obuf, obuf, npix, sz_pixel, step) + + } else { + # Seek and read each pixel directly into the output buffer. + nchars = npix * sz_pixel + + for (op=1; op <= nchars; op=op+sz_pixel) { + call seek (fd, offset) + if (read (fd, obuf[op], sz_pixel) < sz_pixel) + call imerr (IM_NAME(im), SYS_IMNOPIX) + offset = offset + (sz_pixel * step) + } + } + + # Flip the pixel array end for end. + if (xstep < 0) + call imaflp (obuf, npix, sz_pixel) + + # Byte swap if necessary. + nbytes = npix * sz_pixel * SZB_CHAR + if (IM_SWAP(im) == YES) { + switch (sz_pixel * SZB_CHAR) { + case 2: + call bswap2 (obuf, 1, obuf, 1, nbytes) + case 4: + call bswap4 (obuf, 1, obuf, 1, nbytes) + case 8: + call bswap8 (obuf, 1, obuf, 1, nbytes) + } + } + + if (pl == NULL) { + if ((IM_PIXTYPE(im) == TY_INT || IM_PIXTYPE(im) == TY_LONG) && + SZ_INT != SZ_INT32) + call iupk32 (obuf, obuf, npix) + } +end diff --git a/sys/imio/imrename.x b/sys/imio/imrename.x new file mode 100644 index 00000000..9e0f08bf --- /dev/null +++ b/sys/imio/imrename.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMRENAME -- Rename an image. + +procedure imrename (old, new) + +char old[ARB] # old image name +char new[ARB] # new image name + +begin + call iki_init() + call iki_rename (old, new) +end diff --git a/sys/imio/imrmbufs.x b/sys/imio/imrmbufs.x new file mode 100644 index 00000000..1e0d7c5a --- /dev/null +++ b/sys/imio/imrmbufs.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMRMBUFS -- Free any pixel data buffers currently allocated to an image. + +procedure imrmbufs (im) + +pointer im # image descriptor + +int i +pointer ibdes, obdes + +begin + ibdes = IM_IBDES(im) + obdes = IM_OBDES(im) + + if (ibdes != NULL) { + for (i=0; i < IM_VNBUFS(im); i=i+1) + call mfree (BD_BUFPTR(ibdes + LEN_BDES * i), TY_CHAR) + call mfree (ibdes, TY_STRUCT) + } + + if (obdes != NULL) { + call mfree (BD_BUFPTR(obdes), TY_CHAR) + call mfree (obdes, TY_STRUCT) + } + + IM_IBDES(im) = NULL + IM_OBDES(im) = NULL +end diff --git a/sys/imio/imsamp.x b/sys/imio/imsamp.x new file mode 100644 index 00000000..43e144c9 --- /dev/null +++ b/sys/imio/imsamp.x @@ -0,0 +1,61 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMSAMP -- Subsample a vector. + +procedure imsamp (a, b, npix, sz_pixel, step) + +char a[ARB], b[ARB] +int npix, sz_pixel, step, i, j, in, out, delta_in + +begin + switch (sz_pixel) { + case SZ_SHORT: + call imsmps (a, b, npix, step) + case SZ_LONG: + call imsmpl (a, b, npix, step) + + default: # flip odd sized elements + in = 0 + out = 0 + delta_in = sz_pixel * step + + do j = 1, npix { + do i = 1, sz_pixel + b[out+i] = a[in+i] + in = in + delta_in + out = out + sz_pixel + } + } +end + + +# IMSMPS -- Sample an array of SHORT sized elements. + +procedure imsmps (a, b, npix, step) + +short a[ARB], b[npix] +int npix, step, ip, op + +begin + ip = 1 + do op = 1, npix { + b[op] = a[ip] + ip = ip + step + } +end + + +# IMSMPL -- Sample an array of LONG sized elements. + +procedure imsmpl (a, b, npix, step) + +long a[ARB], b[npix] +int npix, step, ip, op + +begin + ip = 1 + do op = 1, npix { + b[op] = a[ip] + ip = ip + step + } +end diff --git a/sys/imio/imsetbuf.x b/sys/imio/imsetbuf.x new file mode 100644 index 00000000..3938f30a --- /dev/null +++ b/sys/imio/imsetbuf.x @@ -0,0 +1,117 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMSETBUF -- Set the FIO file buffer size for the pixel storage file. +# We always make the buffer size equal to an integral number of image lines +# if possible. The actual number of image lines chosen depends on the +# type of access expected and the size of an image line. If image lines are +# very large the FIO buffer will be shorter than a line. We also compute +# IM_FAST, the flag determining whether or not direct access to the FIO +# buffer is permissible. + +procedure imsetbuf (fd, im) + +int fd # pixel storage file +pointer im # image header pointer + +long imsize, bufoff, blkoff +int maxlines, bufsize, szline, nlines, i +int opt_bufsize, max_bufsize, dev_blksize +int fstati(), sizeof() + +begin + IM_FAST(im) = NO + + max_bufsize = fstati (fd, F_MAXBUFSIZE) + opt_bufsize = fstati (fd, F_OPTBUFSIZE) + dev_blksize = max (1, fstati (fd, F_BLKSIZE)) + + szline = IM_PHYSLEN(im,1) * sizeof(IM_PIXTYPE(im)) + imsize = szline + do i = 2, IM_NDIM(im) + imsize = imsize * IM_PHYSLEN(im,i) + + # Compute the suggested buffer size. If bufsize is set externally + # and buffrac is disabled (zero) then we try to use the bufsize + # value given. If buffrac is enabled then we compute a bufsize + # based on this, and use the larger of this value or the default + # bufsize, but not more than DEF_MAXFIOBUFSIZE. The parameter + # buffrac specifies the size of an image buffer as a fraction, + # in percent, of the total size of the image. + # + # For example if buffrac=10, the default buffer size will be either + # "bufsize", or 10% of the full image size, whichever is larger, but + # not more than DEF_MAXFIOBUFSIZE. The intent of buffrac is to + # provide an adaptive mechanism for adjusting the size of the image + # buffers to match the image being accessed. For small images the + # buffer will be the default bufsize (or less if the image is + # smaller than this). For very large images the buffer size will + # increase until the builtin default maximum value DEF_MAXFIOBUFSIZE + # is reached. If more control is needed, buffrac can be set to zero, + # and bufsize will specify the buffer size to be used. Even if + # buffrac is enabled, bufsize can be set to a large value to force + # a large buffer to be used. + + bufsize = IM_VBUFSIZE(im) + if (IM_VBUFFRAC(im) > 0) + bufsize = max(bufsize, min(IM_VBUFMAX(im), + imsize / 100 * min(100,IM_VBUFFRAC(im)) )) + + # Compute max number of image lines that will fit in default buffer. + if (max_bufsize > 0) + nlines = min(max_bufsize,max(opt_bufsize,bufsize)) / szline + else + nlines = bufsize / szline + + # Compute final number of image lines in buffer. + if (nlines == 0) { + # Image lines are very long. Use a buffer smaller than a line. + call fseti (fd, F_ADVICE, SEQUENTIAL) + return + } else if (IM_VADVICE(im) == RANDOM) { + # Always buffer at least one line if the lines are short. + nlines = 1 + } + + # Don't make the buffer any larger than the image. + maxlines = 1 + do i = 2, IM_NDIM(im) + maxlines = maxlines * IM_PHYSLEN(im,i) + nlines = min (nlines, maxlines) + + # Tell FIO to align the first file buffer to the device block + # containing the first image line. Ideally the image line will + # start on a block boundary but this does not have to be the case. + + bufoff = (IM_PIXOFF(im) - 1) / dev_blksize * dev_blksize + 1 + blkoff = IM_PIXOFF(im) - bufoff + call fseti (fd, F_FIRSTBUFOFF, bufoff) + + # An integral number of image lines fit inside the default size + # buffer. Tell FIO the minimum size buffer to use. FIO will actually + # allocate a slightly larger buffer if bufsize is not an integral + # number of device blocks. + + bufsize = blkoff + nlines * szline + call fseti (fd, F_BUFSIZE, bufsize) + + # If a FIO buffer will hold at least two image lines, if no image + # section was given, if there is only one input line buffer, if + # we are not going to be referencing out of bounds, and the pixel + # data is properly aligned in the pixel file, then FAST i/o (directly + # into the FIO buffer) is possible provided no datatype conversion + # or byte swapping is desired or required. If all these criteria + # are true enable fast i/o. + + if ((bufsize / szline >= 2 && IM_SECTUSED(im) == NO) && + (IM_VNBUFS(im) == 1 && IM_VNBNDRYPIX(im) == 0) && + (mod (IM_PIXOFF(im), sizeof(IM_PIXTYPE(im)))) == 1 && + IM_SWAP(im) == NO) { + + IM_FAST(im) = YES +IM_FAST(im) = NO + } +end diff --git a/sys/imio/imseti.x b/sys/imio/imseti.x new file mode 100644 index 00000000..9fd0bc2d --- /dev/null +++ b/sys/imio/imseti.x @@ -0,0 +1,90 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +# IMSETI -- Set an IMIO parameter of type integer (or pointer). For +# completeness this routine can be used to set real valued parameters, but +# obviously since the input value is integer a fractional value cannot be +# set. + +procedure imseti (im, param, value) + +pointer im #I image descriptor +int param #I parameter to be set +int value #I integer value of parameter + +int i +pointer ibdes +errchk calloc + +begin + switch (param) { + case IM_ADVICE: + IM_VADVICE(im) = value + case IM_BUFSIZE: + IM_VBUFSIZE(im) = value + case IM_BUFFRAC: + IM_VBUFFRAC(im) = value + case IM_BUFMAX: + IM_VBUFMAX(im) = value + case IM_COMPRESS: + IM_VCOMPRESS(im) = value + case IM_NBNDRYPIX: + IM_VNBNDRYPIX(im) = max (0, value) + case IM_TYBNDRY: + IM_VTYBNDRY(im) = value + case IM_BNDRYPIXVAL: + IM_OOBPIX(im) = real(value) + case IM_FLAGBADPIX: + IM_VFLAGBADPIX(im) = value + case IM_PIXFD: + IM_PFD(im) = value + case IM_WHEADER: + IM_UPDATE(im) = value + + case IM_PLDES: + IM_PL(im) = value + case IM_RLIO: + # Enable/disable range list i/o (for image masks). + if (value == YES) + IM_PLFLAGS(im) = or (IM_PLFLAGS(im), PL_RLIO) + else + IM_PLFLAGS(im) = and (IM_PLFLAGS(im), not(PL_RLIO)) + + case IM_NBUFS: + # Free any existing input buffers. + ibdes = IM_IBDES(im) + if (ibdes != NULL) + for (i=0; i < IM_VNBUFS(im); i=i+1) + call mfree (BD_BUFPTR(ibdes + LEN_BDES * i), TY_CHAR) + + # Change size of buffer pool. + IM_VNBUFS(im) = value + + # Reinit input buffer descriptors. The actual input buffers will + # be reallocated upon demand. + + if (ibdes != NULL) { + call mfree (IM_IBDES(im), TY_STRUCT) + call calloc (IM_IBDES(im), LEN_BDES * IM_VNBUFS(im), TY_STRUCT) + IM_NGET(im) = 0 + } + + case IM_CANCEL: + # Free any pixel data buffers associated with an image. + call imrmbufs (im) + + case IM_CLOSEFD: + # Set F_CLOSEFD on the pixel file. + IM_VCLOSEFD(im) = value + if (IM_PFD(im) != NULL) + call fseti (IM_PFD(im), F_CLOSEFD, value) + + default: + call imerr (IM_NAME(im), SYS_IMSETUNKPAR) + } +end diff --git a/sys/imio/imsetr.x b/sys/imio/imsetr.x new file mode 100644 index 00000000..b0287458 --- /dev/null +++ b/sys/imio/imsetr.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMSETR -- Set an IMIO parameter to a real value. For completeness this +# routine can be used to set integer valued parameters, although if the +# value has a fractional part or requires more than 24 bits of precision +# the results may be unpredictable. + +procedure imsetr (im, param, value) + +pointer im #I image descriptor +int param #I parameter to be set +real value #I value of parameter + +begin + switch (param) { + case IM_BNDRYPIXVAL: + IM_OOBPIX(im) = value + default: + call imseti (im, param, nint(value)) + } +end diff --git a/sys/imio/imsinb.x b/sys/imio/imsinb.x new file mode 100644 index 00000000..d0c8eb60 --- /dev/null +++ b/sys/imio/imsinb.x @@ -0,0 +1,53 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMSINB -- Determine whether or not a section is in bounds. Out of bounds +# references are permissible if boundary extension is enabled. The actual +# dimensionality of the image need not agree with that of the section. + +int procedure imsinb (im, vs, ve, ndim) + +pointer im # image descriptor +long vs[ARB], ve[ARB] # logical section +int ndim # dimensionality of section + +int i +int lo, hi, bwidth +define oob_ 91 + +begin + # First check if the section is entirely within bounds. If this is the + # case no boundary extension will be required, making optimization + # possible. + + do i = 1, ndim { + hi = IM_LEN(im,i) + if (vs[i] < 1 || vs[i] > hi) + goto oob_ + if (ve[i] < 1 || ve[i] > hi) + goto oob_ + } + + return (YES) # section is within bounds + + # There is at least one out of bounds reference. Check that all such + # references are within NBNDRYPIX of the nearest boundary. NDIM may + # be greater than IM_NDIM, since IMIO sets the lengths of the excess + # dimensions to 1. In effect every image has up to MAXDIM dimensions. + oob_ + bwidth = IM_VNBNDRYPIX(im) + lo = 1 - bwidth + hi = 1 + bwidth + + do i = 1, ndim { + hi = IM_LEN(im,i) + bwidth + if (vs[i] < lo || vs[i] > hi) + return (ERR) # section is illegal + if (ve[i] < lo || ve[i] > hi) + return (ERR) + } + + return (NO) # section is oob but legal +end diff --git a/sys/imio/imsslv.x b/sys/imio/imsslv.x new file mode 100644 index 00000000..2cc5e2a8 --- /dev/null +++ b/sys/imio/imsslv.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMSSLV -- Given two vectors (VS, VE) defining the starting and ending +# physical coordinates of the two pixels defining an image section, +# initialize the "loop index" vector V, and the "loop increment" vector, +# VINC. Compute NPIX, the number of pixels in a line segment. + +procedure imsslv (im, vs, ve, v, vinc, npix) + +pointer im +long vs[IM_MAXDIM], ve[IM_MAXDIM] +long v[IM_MAXDIM], vinc[IM_MAXDIM], npix, step +int i + +begin + # Determine the direction in which each dimension is to be + # traversed. + + do i = 1, IM_NPHYSDIM(im) { + step = abs (IM_VSTEP(im,i)) + if (vs[i] <= ve[i]) + vinc[i] = step + else + vinc[i] = -step + } + + # Initialize the extraction vector (passed to IMRDS? to read a + # contiguous array of pixels). Compute the length of a line, + # allowing for decimation by the step size. + + do i = 1, IM_NPHYSDIM(im) + v[i] = vs[i] + + if (vs[1] > ve[1]) + v[1] = ve[1] + + npix = (ve[1] - vs[1]) / vinc[1] + 1 +end diff --git a/sys/imio/imstati.x b/sys/imio/imstati.x new file mode 100644 index 00000000..0697911b --- /dev/null +++ b/sys/imio/imstati.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# IMSTATI -- Get an IMIO option of type integer. + +int procedure imstati (im, option) + +pointer im #I image descriptor +int option #I imset option being queried + +begin + switch (option) { + case IM_ADVICE: + return (IM_VADVICE(im)) + case IM_BUFSIZE: + return (IM_VBUFSIZE(im)) + case IM_BUFFRAC: + return (IM_VBUFFRAC(im)) + case IM_BUFMAX: + return (IM_VBUFMAX(im)) + case IM_NBUFS: + return (IM_VNBUFS(im)) + case IM_COMPRESS: + return (IM_VCOMPRESS(im)) + case IM_NBNDRYPIX: + return (IM_VNBNDRYPIX(im)) + case IM_TYBNDRY: + return (IM_VTYBNDRY(im)) + case IM_FLAGBADPIX: + return (IM_VFLAGBADPIX(im)) + case IM_PIXFD: + return (IM_PFD(im)) + case IM_CLOSEFD: + return (IM_VCLOSEFD(im)) + case IM_WHEADER: + return (IM_UPDATE(im)) + case IM_PLDES: + return (IM_PL(im)) + case IM_RLIO: + if (and (IM_PLFLAGS(im), PL_RLIO) != 0) + return (YES) + else + return (NO) + default: + call imerr (IM_NAME(im), SYS_IMSTATUNKPAR) + } +end diff --git a/sys/imio/imstatr.x b/sys/imio/imstatr.x new file mode 100644 index 00000000..871cdca1 --- /dev/null +++ b/sys/imio/imstatr.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMSTATR -- Get the real value of an IMIO parameter. + +real procedure imstatr (im, param) + +pointer im #I image descriptor +int param #I parameter to be set + +int value +int imstati() +errchk imstati + +begin + switch (param) { + case IM_BNDRYPIXVAL: + return (IM_OOBPIX(im)) + default: + value = imstati (im, param) + if (IS_INDEFI (value)) + return (INDEFR) + else + return (value) + } +end diff --git a/sys/imio/imstats.x b/sys/imio/imstats.x new file mode 100644 index 00000000..4deb5096 --- /dev/null +++ b/sys/imio/imstats.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# IMSTATS -- Get an IMIO option of type string. + +procedure imstats (im, option, outstr, maxch) + +pointer im # image descriptor +int option # imset option being queried +char outstr[ARB] # output string +int maxch + +begin + switch (option) { + case IM_IMAGENAME: + call strcpy (IM_NAME(im), outstr, maxch) + default: + call imerr (IM_NAME(im), SYS_IMSTATUNKPAR) + } +end diff --git a/sys/imio/imt.x b/sys/imio/imt.x new file mode 100644 index 00000000..b508b0ae --- /dev/null +++ b/sys/imio/imt.x @@ -0,0 +1,305 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +.help imt +.nf ___________________________________________________________________________ +IMT -- Image template package. + +The image template package is based upon the filename template package, the +main difference being that the IMT package knows about the use of [] in image +names, e.g., for image sections or cluster indices. + + list = imtopenp (clparam) + + list = imtopen (template) + imtclose (list) + nchars|eof = imtgetim (list, image, maxch) + nchars|eof = imtrgetim (list, index, image, maxch) + len = imtlen (list) + imtrew (list) + +An image template consists of a comma delimited list of one or more patterns. +Each pattern consists of a filename template optionally followed by a cluster +index or image section. + + filename_template [image stuff] , ... + +In the simplest case a simple alphanumeric image or file name may be given. +Template expansion is carried out by parsing off the [] image stuff, calling +FNTOPNB to expand the filename template, and then appending the [] string to +each output filename returned by FNTGFNB. Multiple adjacent [] sequences are +permitted and are treated as one long string. + +The [ must be escaped to be included in the filename template. The escape +will be passed on, causing the [ to be passed through into the file output +filename. This prevents use of the [chars] character class notation in image +templates; the [] are either interpreted as part of the image specification, +or as part of the filename. +.endhelp _____________________________________________________________________ + +define SZ_FNT 16384 +define CH_DELIM 20B # used to flag image section + + +# IMTOPENP -- Open an image template obtained as the string value of a CL +# parameter. + +pointer procedure imtopenp (param) + +char param[ARB] # CL parameter with string value template +pointer sp, template, imt +pointer imtopen() +errchk clgstr + +begin + call smark (sp) + call salloc (template, SZ_FNT, TY_CHAR) + + call clgstr (param, Memc[template], SZ_FNT) + imt = imtopen (Memc[template]) + + call sfree (sp) + return (imt) +end + + +# IMTOPEN -- Open an image template. The filename template package is +# sophisticated enough to do all the necessary filename editing, etc., so all +# we need do is recast the image notation into a FNT edit operation, e.g., +# `*.imh[*,-*]' becomes `*.hhh%%?\[\*\,-\*]%', with the ? (CH_DELIM, actually +# an unprintable ascii code) being included to make it easy to locate the +# section string in the filenames returned by FNT. We then open the resultant +# template and perform the inverse mapping upon the filenames returned by FNT. + +pointer procedure imtopen (template) + +char template[ARB] # image template + +int sort, level, ip, ch +pointer sp, listp, fnt, op +define output {Memc[op]=$1;op=op+1} +int fntopnb(), strlen() + +begin + call smark (sp) + call salloc (fnt, max(strlen(template)*2, SZ_FNT), TY_CHAR) + + # Sorting is disabled as input and output templates, derived from the + # same database but with string editing used to modify the output list, + # may be sorted differently as sorting is performed upon the edited + # output list. + + sort = NO + + op = fnt + for (ip=1; template[ip] != EOS; ip=ip+1) { + ch = template[ip] + + if (ch == '[') { + if (ip > 1 && template[ip-1] == '!') { + # ![ -- Pass a [ to FNT (character class notation). + Memc[op-1] = '[' + + } else if (ip > 1 && template[ip-1] == '\\') { + # \[ -- The [ is part of the filename. Pass it on as an + # escape sequence to get by the FNT. + + output ('[') + + } else { + # [ -- Unescaped [. This marks the beginning of an image + # section sequence. Output `%%[...]%' and escape all + # pattern matching metacharacters until a comma template + # delimiter is encountered. Note that a comma within [] + # is not a template delimiter. + + output ('%') + output ('%') + output (CH_DELIM) + + level = 0 + for (; template[ip] != EOS; ip=ip+1) { + ch = template[ip] + if (ch == ',') { # , + if (level <= 0) + break # exit loop + else { + output ('\\') + output (ch) + } + } else if (ch == '[') { # [ + output ('\\') + output (ch) + level = level + 1 + } else if (ch == ']') { # ] + output (ch) + level = level - 1 + } else if (ch == '*') { # * + output ('\\') + output (ch) + } else # normal chars + output (ch) + } + output ('%') + ip = ip - 1 + } + + } else if (ch == '@') { + # List file reference. Output the CH_DELIM code before the @ + # to prevent further translations on the image section names + # returned from the list file, e.g., "CH_DELIM // @listfile". + + output (CH_DELIM) + output ('/') + output ('/') + output (ch) + + } else + output (ch) + } + + Memc[op] = EOS + listp = fntopnb (Memc[fnt], sort) + + call sfree (sp) + return (listp) +end + + +# IMTGETIM -- Get the next image name from the image template. FNT returns a +# filename with optional appended image section (preceded by the CH_DELIM +# character). Our job is to escape any [ in the filename part of the image +# name to avoid interpretation of these chars as image section characters by +# IMIO. The CH_DELIM is deleted and everything following is simply copied +# to the output. + +int procedure imtgetim (imt, outstr, maxch) + +pointer imt # image template descriptor +char outstr[ARB] # output string +int maxch # max chars out + +int nchars +pointer sp, buf +int fntgfnb(), imt_mapname() +errchk fntgfnb + +begin + call smark (sp) + call salloc (buf, SZ_PATHNAME, TY_CHAR) + + if (fntgfnb (imt, Memc[buf], SZ_PATHNAME) == EOF) { + outstr[1] = EOS + call sfree (sp) + return (EOF) + } + + nchars = imt_mapname (Memc[buf], outstr, maxch) + call sfree (sp) + return (nchars) +end + + +# IMTRGETIM -- Like imt_getim, but may be used to randomly access the image +# list. + +int procedure imtrgetim (imt, index, outstr, maxch) + +pointer imt # image template descriptor +int index # list element to be returned +char outstr[ARB] # output string +int maxch # max chars out + +int nchars +pointer sp, buf +int fntrfnb(), imt_mapname() +errchk fntrfnb + +begin + call smark (sp) + call salloc (buf, SZ_PATHNAME, TY_CHAR) + + if (fntrfnb (imt, index, Memc[buf], SZ_PATHNAME) == EOF) { + outstr[1] = EOS + call sfree (sp) + return (EOF) + } + + nchars = imt_mapname (Memc[buf], outstr, maxch) + call sfree (sp) + return (nchars) +end + + +# IMTLEN -- Return the number of image names in the expanded list. + +int procedure imtlen (imt) + +pointer imt # image template descriptor +int fntlenb() + +begin + return (fntlenb (imt)) +end + + +# IMTREW -- Rewind the expanded image list. + +procedure imtrew (imt) + +pointer imt # image template descriptor + +begin + call fntrewb (imt) +end + + +# IMTCLOSE -- Close an image template. + +procedure imtclose (imt) + +pointer imt # image template descriptor + +begin + call fntclsb (imt) +end + + +# IMT_MAPNAME -- Translate the string returned by FNT into an image +# specification suitable for input to IMIO. + +int procedure imt_mapname (fnt, outstr, maxch) + +char fnt[ARB] # FNT string +char outstr[ARB] # output string +int maxch + +int ip, op + +begin + op = 1 + for (ip=1; fnt[ip] != EOS; ip=ip+1) + if (fnt[ip] == '[') { + outstr[op] = '\\' + op = op + 1 + outstr[op] = '[' + op = op + 1 + + } else if (fnt[ip] == CH_DELIM) { + for (ip=ip+1; fnt[ip] != EOS; ip=ip+1) { + outstr[op] = fnt[ip] + op = op + 1 + if (op > maxch) + break + } + break + + } else { + outstr[op] = fnt[ip] + op = op + 1 + if (op > maxch) + break + } + + outstr[op] = EOS + return (op - 1) +end diff --git a/sys/imio/imt/README b/sys/imio/imt/README new file mode 100644 index 00000000..be232470 --- /dev/null +++ b/sys/imio/imt/README @@ -0,0 +1,280 @@ + + Enhanced Image List Template Package + + April 15, 2011 + + + The enhanced image list package provides new capabilities for handling +image lists, but remains backwards compatible with tasks currently using +the IMT interface. The enhancements allow for expansion of MEF files into +lists of extensions using the @-file operator, as well as selection of +images within more general lists by means of modifiers (e.g. a simple +expression such as the extname/extver or explicit extension number, or more +complex boolean expressions to allow selection by header keyword). In +addition, tables may now take the @-file operator to use a column +containing image references as an input list. + + +======================================================================== +TODO: + - Describe syntax for use with tables and selection by row values + - Describe remote image specification caching mechanism +======================================================================== + + + +Template Strings +---------------- + +The FNT template package supports the following forms of pattern strings: + + alpha, *.x, data* // .pix, [a-m]*, @list_file, nite%1%2%.1024.imh + +i.e. simple filenames, wildcard expansion in filenames, concatenation of +filenames, @files, substitution in filenames, or a comma-delimited list of +the above. The image template package (IMT) extends these patterns to +allow image names followed by a cluster index or image section in [] +brackets. These patterns remain unchanged in the new version of the +package to allow backward compatability with existing applications. Lists +of these types represent *explicit* collections of images, i.e. a +collection based on the image name (wildcards) or as a result of processing +by some task (e.g. expansion of an MEF file to create an input @-file of +expanded extension specifications). + + The enhanced version of the IMT package further abstracts the concept +of image collections to include data objects such as MEF files or tables +containing a list of image references that *implicitly* defines the list +(e.g. the expanded MEF extension specification or the complete column of +image references). Further, we allow this list (which might be quite +broad) to be refined using modifiers or selectors on the list and thus +dynamically create the list without requiring the use (and management) of +intermediate files. For example, + + + @file* expand all files beginning w/ 'file' + @file//".fits" append ".fits" to contents of 'file' + + @mef.fits expand all (image) extensions of an MEF file + @mef.fits[SCI] select SCI extensions from MEF file + @mef.fits[SCI,2][noinherit] select v2 SCI extns, add kernel param + @mef.fits[1-16x2] select range of extensions from MEF file + @mef.fits[+1-8] create a list of extensions for an MEF + + *.fits[1:100,1:100] append section to all FITS images + @@file[1:100,1:100] append section to expanded MEFs in 'file' + + *.fits[filter?='V'] select images w/ FILTER keyword containing 'V' + @*.fits[gain<3.0] select image extns where GAIN keyword < 3.0 + *.fits[filter?='V';gain<2.0] select using multiple OR's expressions + + +Template Syntax +--------------- + + The previous syntax and behavior of image templates is unchanged in +this version, new functionality is provided by (optional) new syntax now +supported in the template pattern string. Briefly, + + - wildcard filename expansion may now be applied to @-files + + - the use of an '@' operator is now permitted on MEF files. By + default, all image extensions in the file will be included in the + list, modifiers may be used to select specific extensions or to + indicate a range of extensions to be used. + + - the use of an '@@' operator to indicate expansion of the contents + of an @-file. For example, an @-file of MEF image names can be + expanded to list of all the file extensions using "@@file", whereas + just using "@file" would list the names of the MEF files as before. + + - modifier expressions enclosed in square brackets may be appended + to an image template string (or @-file) to either constrain the + list (e.g. only a range of MEF extensions, only images with a certain + keyword value, etc) or to append extra information to the image + specification (e.g. to add an image section to all images in the + list). Multiple modifier expressions may be used + + + The allowed syntax for a template string can be described roughly in +the following way: + + + [@@ | @] [extname] [;...] [] [
] + [@@ | @] [extname,extver][;...] [] [
] + [@@ | @] [index_range] [;...] [] [
] + + <-------- selectors -------> <------ modifiers -----> + + The specification may be the name of a file, and image, or a +table. The behavior of the @-file and @@-file operators will depend on +the type of but the @-file usage remains backward compatible when +used with text files. + + The use of a modifier/selection on an MEF file will automatically +trigger expansion of the extensions in the image and so an '@' operator is +not strictly required, however only those extensions matching the selection +expression will be present in the final image list. Note that the use of +index ranges and extname/extver selectors are mutually exclusive, selector +expressions may be added to either. + + +@-file Operations +----------------- + + The @-file operator is unchanged from previous versions when used with +text files of image names. Modifier/selector expressions however can now +be applied to the contents of the @-file to select from the list only those +images that match the selector expression, or to augment the name in the +list with an additional image syntax such as a section or kernel parameters. + + +@@-file Operations +------------------ + + The @@-file operator is new syntax meant to allow the contents of an +@-file to be expanded automaticaly, e.g. as if there were an @-file of +@-file names. Primarily this can be used to create a list of MEF image +names in which an @-file would return the names of the MEF, while the +@@-file syntax could be used to expand each MEF into individual extension +specifications. + + +Extension Indices +----------------- + + The [index_range] modifier may be used to specify an explicit set of +extensions to be used. Index ranges are specified as a comma-delimited +list of strings specifying individual range segments as described in the +RANGES help page. + + The use of a '+' operator before an index range indicates the range +list should be expanded without checking that the extension exists in the +MEF itself. Otherwise, only those extensions present in the MEF will be +included in the list. + + +Selection Expressions +--------------------- + + Selection expressions may be used to restrict a template list to only +those images that match some boolean expression, e.g. to provide for +selection based on a header keyword value. Expressions follow the same +guidelines as in the HSELECT task 'expr' parameter (see the help page +for details). Multiple expressions may be specified if they are separated +by a semicolon however they are evaluated as a single expression of +OR'd values rather than as individual expressions. This is significant +when considering that expressions may contain keywords not present in +all images being checked, for instance + + *.fits[filter?='V';gain<3.0] + +would evaluate as if the expression had been written + + (filter?='V' || gain < 3.0) + +If a particular image lacks either the 'filter' or 'gain' keyword the +entire expression will evaluate to false because of an error even if one +of the two clauses would otherwise have been true. + +[NOTE: This behavior will be changed in a future version.] + + + +Image Sections +-------------- + Image sections may be added to an image specification by adding a +separate modifier string. The section will be added once selection of +the list by the selector expressions is complete. An example of where +this might be used is in automatically specifying the bias section for +all images in a list, e.g. + + @mef.fits[1:128,*] all extensions in the image + @mef.fits[1-16x2][1:128,*] only 'left' amplifiers of a mosaic + @mef.fits[2-16x2][1024:1128,*] only 'right' amplifiers of a mosaic + m31*.fits[345:528,200:300] same section in all registered images + +No check is made that the image section is valid for the given image. + + +Kernel Parameters +----------------- + + A comma-delimited list of image kernel parameters may be added to any +image specification by adding the keywords to a separate modifier. For +example, + @mef.fits[1-8][noinherit,padline=30] + +would expand the file 'mef.fits' to include extensions 1 thru 8 and add the +kernel parameters, generating a list such as + + mef.fits[1][noinherit,padline=30] + mef.fits[2][noinherit,padline=30] + : : : : + mef.fits[8][noinherit,padline=30] + +No check is made to verify that the image kernel keywords are appropriate +for the image type. Supplying an incorrect kernel parameter will likely +result in the task throwing an error when opening the image. + + + +-------------------------------------------------------------------------------- + +Appendix 1: Examples + + file + file* + @file + @file* + + @file[2] extension + @file[SCI] extname + @file[SCI,2] extname+extver + + @file[2][noinherit] extension + ikiparams + @file[SCI][noinherit] extname + ikiparams + @file[SCI,2][noinherit] extname+extver + ikiparams + + @file[2][1:20,2:30] extension + section + @file[SCI][1:20,2:30] extname + section + @file[SCI,2][1:20,2:30] extname+extver + section + + @file[2][noinherit][1:20,2:30] extension + ikiparams + section + @file[SCI][noinherit][1:20,2:30] extname + ikiparams + section + @file[SCI,2][noinherit][1:20,2:30] extname+extver + ikiparams + section + + @file[noinherit] ikiparams + @file[noinherit][1:123,2:234] ikiparams + sections + + @file[1:123,2:234] sections + + @file[1:123,2:234] sections + + mef*.fits[filter?='V'] selection expression + mef*.fits[filter?='V';filter?='B'] selection expressions (OR) + mef*.fits[filter?='V'||filter?='B'] selection expressions (OR) + mef*.fits[gain>0.5&&gain<2.0] selection expressions (AND) + + Expressions will evaluate to 'false' if there is an error such as + "keyword not found", meaning that no images will match when one or + more keywords may not be present. Best to use a comma-delimited list + in this case. + + Concatenation + + @file // foo append + @file* // foo append wildcards + @file // [2] append modifiers + + foo // @file prepend + foo // @file* prepend wildcards + foo // @file[2] prepend modifiers + + Prior Behavior: + + foo // bar.fits ==> foobar.fits + foo.fits // bar ==> foobar.fits + + foo // @file1 ==> foosif1.fits,foomef1.fits + @file1 // bar ==> sif1foo.fits,mef1foo.fits + diff --git a/sys/imio/imt/fxf.h b/sys/imio/imt/fxf.h new file mode 100644 index 00000000..c4e6188b --- /dev/null +++ b/sys/imio/imt/fxf.h @@ -0,0 +1,172 @@ +# FITS.H -- IKI/FITS internal definitions. + +define FITS_ORIGIN "NOAO-IRAF FITS Image Kernel July 2003" + +define FITS_LENEXTN 4 # max length imagefile extension +define SZ_DATATYPE 16 # size of datatype string (eg "REAL*4") +define SZ_EXTTYPE 20 # size of exttype string (eg BINTABLE) +define SZ_KEYWORD 8 # size of a FITS keyword +define SZ_EXTRASPACE (81*32) # extra space for new cards in header +define DEF_PHULINES 0 # initial allocation for PHU +define DEF_EHULINES 0 # initial allocation for EHU +define DEF_PADLINES 0 # initial value for extra lines in HU +define DEF_PLMAXLEN 32768 # default max PLIO encoded line length +define DEF_PLDEPTH 0 # default PLIO mask depth + +define FITS_BLOCK_BYTES 2880 # FITS logical block length (bytes) +define FITS_BLOCK_CHARS 1440 # FITS logical block length (spp chars) +define FITS_STARTVALUE 10 # first column of value field +define FITS_ENDVALUE 30 # last column of value field +define FITS_SZVALSTR 21 # nchars in value string +define LEN_CARD 80 # length of FITS card. +define LEN_UACARD 81 # size of a Userarea line. +define LEN_OBJECT 63 # maximum length of a FITS string value +define LEN_FORMAT 40 # maximum length of a TFORM value +define NO_KEYW -1 # indicates no keyword is present. + +define MAX_OFFSETS 100 # max number of offsets per cache entry. +define MAX_CACHE 60 # max number of cache entries. +define DEF_CACHE 10 # default number of cache entries. + +define DEF_HDREXTN "fits" # default header file extension +define ENV_FKINIT "fkinit" # FITS kernel initialization + +define DEF_ISOCUTOVER 0 # date when ISO format dates kick in +define ENV_ISOCUTOVER "isodates" # environment override for default + +define FITS_BYTE 8 # Bits in a FITS byte +define FITS_SHORT 16 # Bits in a FITS short +define FITS_LONG 32 # Bits in a FITS long +define FITS_REAL -32 # 32 Bits FITS IEEE float representation +define FITS_DOUBLE -64 # 64 Bits FITS IEEE double representation + +define COL_VALUE 11 # Starting column for parameter values +define NDEC_REAL 7 # Precision of real +define NDEC_DOUBLE 14 # Precision of double + +define FITS_LEN_CHAR (((($1) + 1439)/1440)* 1440) + +# Extension subtypes. +define FK_PLIO 1 + +# Mapping of FITS Keywords to IRAF image header. All unrecognized keywords +# are stored here. + +#define UNKNOWN Memc[($1+IMU-1)*SZ_MII_INT+1] +define UNKNOWN Memc[($1+IMU-1)*SZ_STRUCT+1] + + +# FITS image descriptor, used internally by the FITS kernel. The required +# header parameters are maintained in this descriptor, everything else is +# simply copied into the user area of the IMIO descriptor. + +define LEN_FITDES 500 +define LEN_FITBASE 400 + +define FIT_ACMODE Memi[$1] # image access mode +define FIT_PFD Memi[$1+1] # pixel file descriptor +define FIT_PIXOFF Memi[$1+2] # pixel offset +define FIT_TOTPIX Memi[$1+3] # size of image in pixfile, chars +define FIT_IO Memi[$1+4] # FITS I/O channel +define FIT_ZCNV Memi[$1+5] # set if on-the-fly conversion needed +define FIT_IOSTAT Memi[$1+6] # i/o status for zfio routines +define FIT_TFORMP Memi[$1+7] # TFORM keyword value pointer +define FIT_TTYPEP Memi[$1+8] # TTYPE keyword value pointer +define FIT_TFIELDS Memi[$1+9] # number of fields in binary table +define FIT_PCOUNT Memi[$1+10] # PCOUNT keyword value + # extra space +define FIT_BSCALE Memd[P2D($1+16)] +define FIT_BZERO Memd[P2D($1+18)] +define FIT_BITPIX Memi[$1+20] # bits per pixel +define FIT_NAXIS Memi[$1+21] # number of axes in image +define FIT_LENAXIS Memi[$1+22+$2-1]# 35:41 = [7] max +define FIT_ZBYTES Memi[$1+30] # Status value for FIT_ZCNV mode +define FIT_HFD Memi[$1+31] # Header file descriptor +define FIT_PIXTYPE Memi[$1+32] +define FIT_CACHEHDR Memi[$1+33] # Cached main header unit's address. +define FIT_CACHEHLEN Memi[$1+34] # Lenght of the above. +define FIT_IM Memi[$1+35] # Has the 'im' descriptor value +define FIT_GROUP Memi[$1+36] +define FIT_NEWIMAGE Memi[$1+37] # Newimage flag +define FIT_HDRPTR Memi[$1+38] # Header data Xtension pointer +define FIT_PIXPTR Memi[$1+39] # Pixel data Xtension pointer +define FIT_NUMOFFS Memi[$1+40] # Number of offsets in cache header. +define FIT_EOFSIZE Memi[$1+41] # Size in char of file before append. +define FIT_XTENSION Memi[$1+42] # Yes, if an Xtension has been read. +define FIT_INHERIT Memi[$1+43] # INHERIT header keyword value. +define FIT_EXTVER Memi[$1+44] # EXTVER value (integer only) +define FIT_EXPAND Memi[$1+45] # Expand the header? +define FIT_MIN Memr[P2R($1+46)]# Minimum pixel value +define FIT_MAX Memr[P2R($1+47)]# Maximum pixel value +define FIT_MTIME Meml[$1+48] # Time of last mod. for FITS unit +define FIT_SVNANR Memr[P2R($1+49)] +define FIT_SVNAND Memd[P2D($1+50)] +define FIT_SVMAPRIN Memi[$1+52] +define FIT_SVMAPROUT Memi[$1+53] +define FIT_SVMAPDIN Memi[$1+54] +define FIT_SVMAPDOUT Memi[$1+55] +define FIT_EXTEND Memi[$1+56] # FITS extend keyword +define FIT_PLMAXLEN Memi[$1+57] # PLIO maximum linelen + # extra space +define FIT_EXTTYPE Memc[P2C($1+70)] # extension type +define FIT_FILENAME Memc[P2C($1+110)] # FILENAME value +define FIT_EXTNAME Memc[P2C($1+150)] # EXTNAME value +define FIT_DATATYPE Memc[P2C($1+190)] # datatype string +define FIT_TITLE Memc[P2C($1+230)] # title string +define FIT_OBJECT Memc[P2C($1+270)] # object string +define FIT_EXTSTYPE Memc[P2C($1+310)] # FITS extension subtype + # extra space + +# The FKS terms carry the fkinit or kernel section arguments. +define FKS_APPEND Memi[$1+400] # YES, NO append an extension +define FKS_INHERIT Memi[$1+401] # YES, NO inherit the main header +define FKS_OVERWRITE Memi[$1+402] # YES, NO overwrite an extension +define FKS_DUPNAME Memi[$1+403] # YES, NO allow duplicated EXTNAME +define FKS_EXTVER Memi[$1+404] # YES, NO allow duplicated EXTNAME +define FKS_EXPAND Memi[$1+405] # YES, NO expand the header +define FKS_PHULINES Memi[$1+406] # Allocated lines in PHU +define FKS_EHULINES Memi[$1+407] # Allocated lines in EHU +define FKS_PADLINES Memi[$1+408] # Additional lines for HU +define FKS_NEWFILE Memi[$1+409] # YES, NO force newfile +define FKS_CACHESIZE Memi[$1+410] # size of header cache +define FKS_SUBTYPE Memi[$1+411] # BINTABLE subtype +define FKS_EXTNAME Memc[P2C($1+412)] # EXTNAME value + # extra space + + +# Reserved FITS keywords known to this code. + +define FK_KEYWORDS "|bitpix|datatype|end|naxis|naxisn|simple|bscale|bzero\ +|origin|iraf-tlm|filename|extend|irafname|irafmax|irafmin|datamax\ +|datamin|xtension|object|pcount|extname|extver|nextend|inherit\ +|zcmptype|tform|ttype|tfields|date|" + +define KW_BITPIX 1 +define KW_DATATYPE 2 +define KW_END 3 +define KW_NAXIS 4 +define KW_NAXISN 5 +define KW_SIMPLE 6 +define KW_BSCALE 7 +define KW_BZERO 8 +define KW_ORIGIN 9 +define KW_IRAFTLM 10 +define KW_FILENAME 11 +define KW_EXTEND 12 +define KW_IRAFNAME 13 +define KW_IRAFMAX 14 +define KW_IRAFMIN 15 +define KW_DATAMAX 16 +define KW_DATAMIN 17 +define KW_XTENSION 18 +define KW_OBJECT 19 +define KW_PCOUNT 20 +define KW_EXTNAME 21 +define KW_EXTVER 22 +define KW_NEXTEND 23 +define KW_INHERIT 24 +define KW_ZCMPTYPE 25 +define KW_TFORM 26 +define KW_TTYPE 27 +define KW_TFIELDS 28 +define KW_DATE 29 diff --git a/sys/imio/imt/imt.x b/sys/imio/imt/imt.x new file mode 100644 index 00000000..64e1441c --- /dev/null +++ b/sys/imio/imt/imt.x @@ -0,0 +1,342 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +.help imt +.nf ___________________________________________________________________________ +IMT -- Image template package. + +The image template package is based upon the filename template package, the +main difference being that the IMT package knows about the use of [] in image +names, e.g., for image sections or cluster indices. + + list = imtopenp (clparam) + + list = imtopen (template) + imtclose (list) + nchars|eof = imtgetim (list, image, maxch) + nchars|eof = imtrgetim (list, index, image, maxch) + len = imtlen (list) + imtrew (list) + +An image template consists of a comma delimited list of one or more patterns. +Each pattern consists of a filename template optionally followed by a cluster +index or image section. + + filename_template [image stuff] , ... + +In the simplest case a simple alphanumeric image or file name may be given. +Template expansion is carried out by parsing off the [] image stuff, calling +FNTOPNB to expand the filename template, and then appending the [] string to +each output filename returned by FNTGFNB. Multiple adjacent [] sequences are +permitted and are treated as one long string. + +The [ must be escaped to be included in the filename template. The escape +will be passed on, causing the [ to be passed through into the file output +filename. This prevents use of the [chars] character class notation in image +templates; the [] are either interpreted as part of the image specification, +or as part of the filename. +.endhelp _____________________________________________________________________ + +define SZ_FNT 16384 +define CH_DELIM 20B # used to flag image section + + +# IMTOPENP -- Open an image template obtained as the string value of a CL +# parameter. + +pointer procedure imtopenp (param) + +char param[ARB] # CL parameter with string value template +pointer sp, template, imt +pointer imtopen() +errchk clgstr + +begin + call smark (sp) + call salloc (template, SZ_FNT, TY_CHAR) + + call clgstr (param, Memc[template], SZ_FNT) + imt = imtopen (Memc[template]) + + call sfree (sp) + return (imt) +end + + +# IMTOPEN -- Open an image template. The filename template package is +# sophisticated enough to do all the necessary filename editing, etc., so all +# we need do is recast the image notation into a FNT edit operation, e.g., +# `*.imh[*,-*]' becomes `*.hhh%%?\[\*\,-\*]%', with the ? (CH_DELIM, actually +# an unprintable ascii code) being included to make it easy to locate the +# section string in the filenames returned by FNT. We then open the resultant +# template and perform the inverse mapping upon the filenames returned by FNT. + +pointer procedure imtopen (template) + +char template[ARB] # image template + +int sort, level, ip, ch +pointer sp, listp, fnt, op +define output {Memc[op]=$1;op=op+1} + +int fntopnb(), strlen() +pointer imxopen() +bool envgetb() + +begin + # The interface is unchanged as far as the applications are + # concerned, but we'll branch here to the enhanced list processing + # if it is available. + + if (envgetb ("use_vo") && envgetb ("use_new_imt")) + return (imxopen (template)) + + + call smark (sp) + call salloc (fnt, max(strlen(template)*2, SZ_FNT), TY_CHAR) + + # Sorting is disabled as input and output templates, derived from the + # same database but with string editing used to modify the output list, + # may be sorted differently as sorting is performed upon the edited + # output list. + + sort = NO + + op = fnt + for (ip=1; template[ip] != EOS; ip=ip+1) { + ch = template[ip] + + if (ch == '[') { + if (ip > 1 && template[ip-1] == '!') { + # ![ -- Pass a [ to FNT (character class notation). + Memc[op-1] = '[' + + } else if (ip > 1 && template[ip-1] == '\\') { + # \[ -- The [ is part of the filename. Pass it on as an + # escape sequence to get by the FNT. + + output ('[') + + } else { + # [ -- Unescaped [. This marks the beginning of an image + # section sequence. Output `%%[...]%' and escape all + # pattern matching metacharacters until a comma template + # delimiter is encountered. Note that a comma within [] + # is not a template delimiter. + + output ('%') + output ('%') + output (CH_DELIM) + + level = 0 + for (; template[ip] != EOS; ip=ip+1) { + ch = template[ip] + if (ch == ',') { # , + if (level <= 0) + break # exit loop + else { + output ('\\') + output (ch) + } + } else if (ch == '[') { # [ + output ('\\') + output (ch) + level = level + 1 + } else if (ch == ']') { # ] + output (ch) + level = level - 1 + } else if (ch == '*') { # * + output ('\\') + output (ch) + } else # normal chars + output (ch) + } + output ('%') + ip = ip - 1 + } + + } else if (ch == '@') { + # List file reference. Output the CH_DELIM code before the @ + # to prevent further translations on the image section names + # returned from the list file, e.g., "CH_DELIM // @listfile". + + output (CH_DELIM) + output ('/') + output ('/') + output (ch) + + } else + output (ch) + } + + Memc[op] = EOS + + listp = fntopnb (Memc[fnt], sort) + + call sfree (sp) + return (listp) +end + + +# IMTGETIM -- Get the next image name from the image template. FNT returns a +# filename with optional appended image section (preceded by the CH_DELIM +# character). Our job is to escape any [ in the filename part of the image +# name to avoid interpretation of these chars as image section characters by +# IMIO. The CH_DELIM is deleted and everything following is simply copied +# to the output. + +int procedure imtgetim (imt, outstr, maxch) + +pointer imt # image template descriptor +char outstr[ARB] # output string +int maxch # max chars out + +int nchars +pointer sp, buf +int fntgfnb(), imt_mapname() +errchk fntgfnb + +begin + call smark (sp) + call salloc (buf, SZ_PATHNAME, TY_CHAR) + + if (fntgfnb (imt, Memc[buf], SZ_PATHNAME) == EOF) { + outstr[1] = EOS + call sfree (sp) + return (EOF) + } + + nchars = imt_mapname (Memc[buf], outstr, maxch) + call sfree (sp) + return (nchars) +end + + +# IMTRGETIM -- Like imt_getim, but may be used to randomly access the image +# list. + +int procedure imtrgetim (imt, index, outstr, maxch) + +pointer imt # image template descriptor +int index # list element to be returned +char outstr[ARB] # output string +int maxch # max chars out + +int nchars +pointer sp, buf +int fntrfnb(), imt_mapname() +errchk fntrfnb + +begin + call smark (sp) + call salloc (buf, SZ_PATHNAME, TY_CHAR) + + if (fntrfnb (imt, index, Memc[buf], SZ_PATHNAME) == EOF) { + outstr[1] = EOS + call sfree (sp) + return (EOF) + } + + nchars = imt_mapname (Memc[buf], outstr, maxch) + call sfree (sp) + return (nchars) +end + + +# IMTLEN -- Return the number of image names in the expanded list. + +int procedure imtlen (imt) + +pointer imt # image template descriptor +int fntlenb() + +begin + return (fntlenb (imt)) +end + + +# IMTREW -- Rewind the expanded image list. + +procedure imtrew (imt) + +pointer imt # image template descriptor + +begin + call fntrewb (imt) +end + + +# IMTCLOSE -- Close an image template. + +procedure imtclose (imt) + +pointer imt # image template descriptor + +begin + call fntclsb (imt) +end + + +# IMT_MAPNAME -- Translate the string returned by FNT into an image +# specification suitable for input to IMIO. + +int procedure imt_mapname (fnt, outstr, maxch) + +char fnt[ARB] # FNT string +char outstr[ARB] # output string +int maxch + +int ip, op +char url[SZ_PATHNAME], cfname[SZ_PATHNAME] + +int strncmp(), strlen() +bool envgetb() + +begin + # Check for a URL-encoded string. + + if (strncmp ("http:", fnt, 5) == 0) { + call aclrc (url, SZ_PATHNAME) + call sprintf (url, SZ_PATHNAME, "http://%s") + call pargstr (fnt[6]) + + call fcadd ("cache$", url, "", cfname, SZ_PATHNAME) + call strcpy (cfname, outstr, SZ_PATHNAME) + return (strlen (cfname)) + } + + op = 1 + for (ip=1; fnt[ip] != EOS; ip=ip+1) { + if (fnt[ip] == '[') { + outstr[op] = '\\' + op = op + 1 + outstr[op] = '[' + op = op + 1 + + } else if (fnt[ip] == CH_DELIM) { + for (ip=ip+1; fnt[ip] != EOS; ip=ip+1) { + outstr[op] = fnt[ip] + op = op + 1 + if (op > maxch) + break + } + break + + } else { + outstr[op] = fnt[ip] + op = op + 1 + if (op > maxch) + break + } + } + outstr[op] = EOS + + # FIXME + if (envgetb ("vo_prefetch") && strncmp (outstr, "cache", 5) == 0) { +# call sprintf (cfname, SZ_LINE, "%s.fits") + call sprintf (cfname, SZ_LINE, "%s") + call pargstr (outstr) + call fcwait ("cache$", cfname) + } + + return (op - 1) +end diff --git a/sys/imio/imt/imx.h b/sys/imio/imt/imx.h new file mode 100644 index 00000000..362e146f --- /dev/null +++ b/sys/imio/imt/imx.h @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + + +define SZ_FNT 32768 +define CH_DELIM 20B # used to flag image section + +define IMT_FILE 0 # file list +define IMT_IMAGE 1 # image list +define IMT_TABLE 2 # table list (ascii file) +define IMT_VOTABLE 3 # table list (XML file) +define IMT_URL 4 # file URL +define IMT_DIR 5 # directory + +define IMT_OUTPUTS "|none|list|file|" # expansion options +define IMTY_NONE 1 # No output +define IMTY_LIST 2 # List output +define IMTY_FILE 3 # File output + +define SZ_RANGE 100 # Size of extension range list +define SZ_LISTOUT 16384 # Size of extension output list + +define FIRST 1 # Default starting range +define LAST MAX_INT # Default ending range +define STEP 1 # Default step +define EOLIST -1 # End of list + diff --git a/sys/imio/imt/imx.x b/sys/imio/imt/imx.x new file mode 100644 index 00000000..ba3f7bc8 --- /dev/null +++ b/sys/imio/imt/imx.x @@ -0,0 +1,242 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "imx.h" + +define DEBUG FALSE + + +# IMXOPEN -- Open an image template using the enhanced expansion +# capabilities. This procedure is simply the entry point to the imtopen() +# method in the standard IMT interface. + +pointer procedure imxopen (template) + +char template[ARB] # image template + +int i, sort, level, ip, ch, expand, nchars, nimages, index, type +int max_fnt, fnt_len, len, flen +pointer listp, intmp, fnt, op, exp +char lfile[SZ_LINE], lexpr[SZ_LINE], likparams[SZ_LINE], lsec[SZ_LINE] +char lindex[SZ_LINE], lextname[SZ_LINE], lextver[SZ_LINE], elem[SZ_LINE] + +pointer imx_preproc (), imx_imexpand (), imx_fexpand () +pointer imx_texpand (), imx_dexpand () +int imx_filetype (), imx_parse (), imx_get_element () +int fntopnb (), strlen (), strsearch() +int sum, fntlenb() +bool envgetb() + +define output {Memc[op]=$1;op=op+1} +define escape {output('\\');output($1)} + +begin + # Pre-process the input template. + intmp = imx_preproc (template) + + if (DEBUG) { + call eprintf ("template: '%s'\npreproc: '%s'\n\n") + call pargstr (template) + call pargstr (Memc[intmp]) + } + + + fnt_len = 0 # initialize + max_fnt = SZ_FNT + call calloc (fnt, max_fnt, TY_CHAR) + + # Sorting is disabled as input and output templates, derived from the + # same database but with string editing used to modify the output list, + # may be sorted differently as sorting is performed upon the edited + # output list. + + sort = NO + + op = fnt + ip = intmp + + for (ip=intmp; Memc[ip] != EOS; ip=ip+1) { + ch = Memc[ip] + + if (ch == '[') { + if (ip > 1 && Memc[ip-1] == '!') { + # ![ -- Pass a [ to FNT (character class notation). + Memc[op-1] = '[' + + } else if (ip > 1 && Memc[ip-1] == '\\') { + # \[ -- The [ is part of the filename. Pass it on as an + # escape sequence to get by the FNT. + + output ('[') + + } else { + # [ -- Unescaped [. This marks the beginning of an image + # section sequence. Output `%%[...]%' and escape all + # pattern matching metacharacters until a comma template + # delimiter is encountered. Note that a comma within [] + # is not a template delimiter. + + output ('%') + output ('%') + output (CH_DELIM) + + level = 0 + for (; Memc[ip] != EOS; ip=ip+1) { + ch = Memc[ip] + if (ch == ',') { # , + if (level <= 0) + break # exit loop + else { + escape (ch) + } + } else if (ch == '[') { # [ + escape (ch) + level = level + 1 + } else if (ch == ']') { # ] + output (ch) + level = level - 1 + } else if (ch == '*') { # * + escape (ch) + } else # normal chars + output (ch) + } + output ('%') + ip = ip - 1 + } + + } else if (ch == '@') { + # List file reference. Output the CH_DELIM code before the @ + # to prevent further translations on the image section names + # returned from the list file, e.g., "CH_DELIM // @listfile". + + # See if we're asking to expand the contents of the file, + # e.g. as in "@@listfile" where 'listfile' contains MEFs + # or tables we later expand. + expand = NO + if (Memc[ip+1] == '@') + expand = YES + + # Break out the listfile from the filtering expression. + + index = 1 + nchars = imx_get_element (Memc[ip], index, elem, SZ_LINE) + ip = ip + strlen(elem) - 1 + + nchars = imx_parse (elem, lfile, lindex, lextname, + lextver, lexpr, lsec, likparams, SZ_LINE) + + if (DEBUG) { + call eprintf ("imtopen: lfile='%s' lexpr='%s' ip='%s'\n") + call pargstr (lfile) + call pargstr (lexpr) + call pargstr (Memc[ip]) + } + + + exp = NULL + type = imx_filetype (lfile) + switch (type) { + case IMT_IMAGE: + exp = imx_imexpand (lfile, lexpr, lindex, lextname, lextver, + likparams, lsec, nimages) + + case IMT_TABLE: + case IMT_VOTABLE: + exp = imx_texpand (lfile, type, lexpr, lindex, "", nimages) + + case IMT_FILE: + if (strsearch (lfile, "//") > 0) { + call calloc (exp, SZ_FNAME, TY_CHAR) + call strcpy (lfile, Memc[exp], SZ_FNAME) + nimages = 1 + + } else if (lfile[1] == '@' && strsearch(lfile, "//") == 0) { + exp = imx_fexpand (lfile[2], lexpr, lindex, lextname, + lextver, likparams, lsec, nimages) +# if (nimages > 0) { +# output (CH_DELIM); output ('/'); output ('/') +# } + + } else { + call calloc (exp, SZ_FNAME, TY_CHAR) + call strcpy (lfile, Memc[exp], SZ_FNAME) + nimages = 1 + } + + case IMT_DIR: + exp = imx_dexpand (lfile, lexpr, lindex, lextname, lextver, + likparams, lsec, nimages) + } + + if (DEBUG) { + call eprintf ("expand: exp='%s' len=%d nim=%d\n") + call pargstr (Memc[exp]) + call pargi (strlen(Memc[exp])) + call pargi (nimages) + } + + + # Copy to the output template string. + len = strlen (Memc[exp]) + if (nimages > 0) { + if ((fnt_len + len) >= max_fnt) { + max_fnt = max_fnt + len + 1 + if (fnt != NULL) + call realloc (fnt, max_fnt, TY_CHAR) + else + call calloc (fnt, max_fnt, TY_CHAR) + op = fnt + if (fnt_len > 0) + op = fnt + strlen (Memc[fnt]) + } + for (i=0; i < len; i=i+1) + output (Memc[exp+i]) + Memc[op+1] = EOS + fnt_len = fnt_len + strlen (Memc[exp]) + } + + if (exp != NULL) + call mfree (exp, TY_CHAR) + nimages = 0 + + } else + output (ch) + } + output ('\0') + Memc[op] = EOS + + + # Clean up the expanded template string in case there were selection + # filters that rejected images and we have extra commas in the string. + len = strlen (Memc[fnt]) + if (Memc[fnt+len-1] == ',') { # kill trailing commas + for (ip=fnt+len-1; Memc[ip] == ',' && ip >= fnt; ip=ip-1) + Memc[ip] = '\0' + } + if (Memc[fnt] == ',') { + for (ip=fnt; Memc[ip] == ','; ) # skip leading commas + ip = ip + 1 + for (op=fnt; Memc[ip] != EOS; ip=ip+1) { + Memc[op] = Memc[ip] + op = op + 1 + } + Memc[op] = '\0' + } + + if (DEBUG) { + call eprintf ("imxopen: fnt='%s'\n") + call pargstr (Memc[fnt]) + } + + + # Open the template string using the filename list. + listp = fntopnb (Memc[fnt], sort) + + # Clean up. + call mfree (fnt, TY_CHAR) + call mfree (intmp, TY_CHAR) + + return (listp) +end diff --git a/sys/imio/imt/imxbreakout.x b/sys/imio/imt/imxbreakout.x new file mode 100644 index 00000000..57a92b8a --- /dev/null +++ b/sys/imio/imt/imxbreakout.x @@ -0,0 +1,233 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + + +# IMX_BREAKOUT -- Break out the filename template from the filtering +# expression in the list item. Our input value is a single item in the +# template list, we'll logically separate image parameters, section strings +# and extension values from expressions that might be used in filtering. + +int procedure imx_breakout (item, expand, fname, expr, sec, ikparams, maxch) + +char item[ARB] #i template string ptr +int expand #i expanding contents? +char fname[ARB] #o list filename +char expr[ARB] #o filtering expression +char sec[ARB] #o section string +char ikparams[ARB] #o image kernel params +int maxch #i max chars in fname and expr + +char ch, str[SZ_LINE], sifname[SZ_LINE] +int nchars, ip, op +bool is_sif + +bool imx_issection(), imx_sifmatch() +int stridx() + +define next_str_ 99 + +begin + call aclrc (fname, maxch) + call aclrc (expr, maxch) + call aclrc (sec, maxch) + + # At the start the ip points to the '@' in the template string. + # Skip ahead to the start of the filename template string. + ip = 1 + if (expand == YES) + ip = ip + 1 + + # Copy out the filename template up to the EOS, a '[' to indicate + # the start of a filter expression, or a comma indicating the next + # item in the list. + ch = item[ip] + for (op=1; ch != EOS; op=op+1) { + fname[op] = ch + + ch = item[ip+1] + if (ch == ',' || ch == EOS) + return (ip-1) # next list item, no filter expr + else if (ch == '[') + break # break to get the filter expr + + ip = ip + 1 + } + + + # Get the string up to the closing ']' char. +next_str_ + ip = ip + 2 + ch = item[ip] + call aclrc (str, SZ_LINE) + for (op=1; ch != EOS; op=op+1) { + str[op] = ch + + ip = ip + 1 + ch = item[ip] + if (ch == ']') + break # break to get the filter expr + } + + if (imx_issection (str)) { + call strcpy (str, sec, SZ_LINE) + } else { + if (expr[1] != EOS) { + call strcat (",", expr, SZ_LINE) + call strcat (str, expr, SZ_LINE) + } else + call strcpy (str, expr, SZ_LINE) + } + + if (item[ip+1] != EOS) + goto next_str_ + + call imx_ikparams (expr, ikparams, SZ_LINE) + + # If we've found both a section and an expression, check that the + # section isn't being confused with an index list. + #if (sec[1] != EOS && expr[1] != EOS) { + # if (!is_sif && stridx (':', sec) == 0) { + # call strcat (",", expr, SZ_LINE) + # call strcat (sec, expr, SZ_LINE) + # } + #} + + if (sec[1] != EOS) { + call aclrc (sifname, SZ_LINE) + call sprintf (sifname, SZ_LINE, "%s[1][%s]") + if (fname[1] == '@') + call pargstr (fname[2]) + else + call pargstr (fname) + call pargstr (sec) + } else { + call strcpy (fname, sifname, SZ_LINE) + } + is_sif = imx_sifmatch (sifname, "yes") + + nchars = ip - 1 + return (nchars) +end + + +# IMX_ISSECTION -- Determine if the string is an image section. +# +# Note: There is a possible ambiguity here where using an image section +# that represents a single pixel (e.g. foo.fits[100,100]) which might also +# be a list of image extensions. + +bool procedure imx_issection (str) + +char str[ARB] # string to be checked + +int ip, stridxs() + +begin + for (ip=1; str[ip] != EOS; ip=ip+1) { + if (IS_ALPHA(str[ip]) || stridxs ("x()<>?", str) > 0) + return (FALSE) + } + + # Test for a range list, e.g. "[1-5]" + if (stridxs ("-,", str) > 0 && stridxs (":*", str) == 0) + return (FALSE); + + # Test for a section that flips axes, e.g. "[-*,*]" + if (stridxs ("-*:,", str) > 0) + return (TRUE); + + return (FALSE) +end + + +# IMX_IKPARMS -- Break out the image kernel params from the template list +# expression string. + +procedure imx_ikparams (expr, ikparams, maxch) + +char expr[ARB] # expression string to modify +char ikparams[ARB] # extracted image kernel params +int maxch # max size of output strings + +int ip, op, nexpr, niki +char ch, in[SZ_LINE], sub[SZ_LINE] + +bool imx_isikparam() + +begin + call aclrc (in, SZ_LINE) # initialize + call strcpy (expr, in, SZ_LINE) + nexpr = 0 + niki = 0 + + call aclrc (expr, maxch) + call aclrc (ikparams, maxch) + for (ip=1; in[ip] != EOS; ip=ip+1) { + # Copy out the sub expression, i.e. up to the comma or EOS. + call aclrc (sub, SZ_LINE) + op = 1 + while (in[ip] != EOS && in[ip] != ',' && in[ip] != ';') { + sub[op] = in[ip] + ip = ip + 1 + op = op + 1 + } + ch = in[ip] + + if (imx_isikparam (sub)) { + if (niki > 0) + call strcat (",", ikparams, maxch) + call strcat (sub, ikparams, maxch) + niki = niki + 1 + + } else { + if (nexpr > 0) + call strcat (",", expr, maxch) + call strcat (sub, expr, maxch) + nexpr = nexpr + 1 + } + + if (ch == EOS) + break + } +end + + +# IMX_ISIKPARAM -- See whether the substring refers to an image kernel param. + +bool procedure imx_isikparam (str) + +char str[ARB] # string to check + +int strncmp() + +begin + if (strncmp (str, "extname", 7) == 0 || strncmp (str, "extver", 6) == 0) + return (TRUE) + + # Check for the "no" versions of selected keywords. + else if (strncmp (str, "no", 2) == 0) { + if ((strncmp (str[3], "append", 4) == 0) || + (strncmp (str[3], "inherit", 4) == 0) || + (strncmp (str[3], "overwrite", 4) == 0) || + (strncmp (str[3], "dupname", 4) == 0) || + (strncmp (str[3], "expand", 4) == 0)) + return (TRUE) + } + + # Other kernel keywords. + if (strncmp (str, "inherit", 4) == 0 || + strncmp (str, "overwrite", 4) == 0 || + strncmp (str, "dupname", 4) == 0 || + strncmp (str, "append", 4) == 0 || + strncmp (str, "noappend", 4) == 0 || + strncmp (str, "type", 4) == 0 || + strncmp (str, "expand", 4) == 0 || + strncmp (str, "phulines", 4) == 0 || + strncmp (str, "ehulines", 4) == 0 || + strncmp (str, "padlines", 4) == 0 || + strncmp (str, "cachesize", 4) == 0) + return (TRUE) + + return (FALSE) +end diff --git a/sys/imio/imt/imxescape.x b/sys/imio/imt/imxescape.x new file mode 100644 index 00000000..92750ab7 --- /dev/null +++ b/sys/imio/imt/imxescape.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imx.h" + + +# IMX_ESCAPE -- Return a pointer to the composed file name, escaping parts +# as needed. + +pointer procedure imx_escape (in, index, extname, extver, ikparams, + section, expr, maxch) + +char in[ARB] #I File image name (without kernel or image sec) +char index[ARB] #I Range list of extension indexes +char extname[ARB] #I Pattern for extension names +char extver[ARB] #I Range list of extension versions +char ikparams[ARB] #I Image kernel parameters +char section[ARB] #I Image section +char expr[ARB] #I Selection expression +int maxch #I Print errors? + +pointer out, op +int i, len, level +char ch, peek, prev +bool init_esc + +int strlen() + +define output {Memc[op]=$1;op=op+1} +define escape {output('\\');output($1)} + +begin + len = max (SZ_LINE, strlen (in)) + call calloc (out, max (SZ_LINE, (4*len)), TY_CHAR) + + op = out + level = 0 + + init_esc = false + for (i=1; i <= len; i=i+1) { + prev = in[max(1,i)] + ch = in[i] + peek = in[i+1] + + if (ch == EOS) + break; + if (ch == '[') { + if (prev != ']' && !init_esc) { + output ('%') + output ('%') + output (CH_DELIM) + init_esc = true + } + escape (ch) + level = level + 1 + } else if (ch == ']') { + output (ch) + if (peek != '[') # closing delim + output ('%') + level = level - 1 + } else if (ch == ',') { + if (level > 0) + output('\\') + if (level == 0) + init_esc = false + output (ch) + } else if (ch == '*') + escape (ch) + else + output (ch) + } + output (EOS) + + return (out) +end diff --git a/sys/imio/imt/imxexpand.x b/sys/imio/imt/imxexpand.x new file mode 100644 index 00000000..72efb17c --- /dev/null +++ b/sys/imio/imt/imxexpand.x @@ -0,0 +1,1287 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include +include +include + +include "imx.h" +include + + +define SZ_BUF 8192 # name buffer string + + +# IMX_IMEXPAND -- Expand a template of FITS files into a list of image +# extensions. + +pointer procedure imx_imexpand (input, expr, index, extname, extver, ikparams, + section, nimages) + +char input[ARB] # List of ME file names +char expr[ARB] # Filtering expression +char index[ARB] # Range list of extension indexes +char extname[ARB] # Patterns for extension names +char extver[ARB] # Range list of extension versions +char ikparams[ARB] # Image kernel parameters +char section[ARB] # Image section parameters +int nimages # Number of output images + +int lindex # List index number? +int lname # List extension name? +int lver # List extension version? + +pointer in, out # Pointer to output string +pointer sp, sif, image, listout +int list, len, maxch + +int imx_extns(), strlen(), fntgfnb(), fntlenb() +pointer imx_escape() +bool imx_sifmatch() + +begin + call smark (sp) + call salloc (in, SZ_FNAME, TY_CHAR) + call salloc (image, SZ_FNAME, TY_CHAR) + + + lindex = YES # expansion parameters + lname = NO + lver = NO + out = NULL + len = 0 + nimages = 0 + maxch = SZ_LISTOUT + + call aclrc (Memc[in], SZ_FNAME) + if (input[1] == '@') + call strcpy (input[2], Memc[in], SZ_FNAME) + else + call strcpy (input, Memc[in], SZ_FNAME) + + # Get the list. + list = imx_extns (Memc[in], "IMAGE", index, extname, extver, + lindex, lname, lver, ikparams, section, expr, YES) + + if (list == NULL || fntlenb (list) == 0) { + call calloc (out, SZ_LINE, TY_CHAR) + call strcpy (Memc[in], Memc[out], SZ_LINE) + if (section[1] != EOS) { + call strcat ("\\[", Memc[out], maxch) + call strcat (section, Memc[out], maxch) + call strcat ("]", Memc[out], maxch) + } + if (ikparams[1] != EOS) { + call strcat ("\\[", Memc[out], maxch) + call strcat (ikparams, Memc[out], maxch) + call strcat ("]", Memc[out], maxch) + } + + if (index[1] == EOS && imx_sifmatch (Memc[out], expr)) { + nimages = 1 + sif = imx_escape (Memc[out], index, extname, extver, ikparams, + section, expr, maxch) + } else + call calloc (sif, SZ_LINE, TY_CHAR) + call mfree (out, TY_CHAR) + return (sif) + } + + # Format the output and set the number of images. + call calloc (listout, maxch, TY_CHAR) + iferr { + while (fntgfnb (list, Memc[image], SZ_FNAME) != EOF) { + nimages = nimages + 1 + if (nimages > 1) { + call strcat (",", Memc[listout], maxch) + len = len + 1 + } + if ((len + strlen (Memc[image])) >= maxch) { + maxch = maxch + SZ_LISTOUT + call realloc (listout, maxch, TY_CHAR) + } + + call strcat (Memc[image], Memc[listout], maxch) + len = len + strlen (Memc[image]) + +# if (section[1] != EOS) { +# call strcat ("[", Memc[listout], maxch) +# call strcat (section, Memc[listout], maxch) +# call strcat ("]", Memc[listout], maxch) +# len = len + strlen (section) + 2 +# } + } + + # Escape the output image specification in a form that is correct + # for the filename template interface. + + out = imx_escape (Memc[listout], index, extname, extver, ikparams, + section, expr, maxch) + + } then { + call fntclsb (list) + call sfree (sp) + call error (1, "Output list format is too long") + } + call fntclsb (list) + call sfree (sp) + + return (out) +end + + +# IMX_FEXPAND -- Expand a template of files into a list of images names. + +pointer procedure imx_fexpand (input, expr, index, extname, extver, ikparams, + section, nimages) + +char input[ARB] # List of ME file names +char expr[ARB] # Filtering expression +char index[ARB] # Range list of extension indexes +char extname[ARB] # Patterns for extension names +char extver[ARB] # Range list of extension versions +char ikparams[ARB] # Image kernel parameters +char section[ARB] # Image section parameters +int nimages # Number of output images + +pointer sp, name, exp, lexp, nexp +int fd, ip, op, len, elen, nlines, nims, maxch, nchars, level +bool do_proc +char line[SZ_LINE], buf[SZ_LINE], ch + +define output {buf[op]=$1;op=op+1} + + +int open(), getline(), strlen(), stridx() +pointer imx_imexpand() + +begin + iferr (fd = open (input, READ_ONLY, TEXT_FILE)) { + call error (1, "Cannot open @file") + return (NULL) + } + + call smark (sp) + call salloc (name, SZ_PATHNAME, TY_CHAR) + + maxch = SZ_FNT + call calloc (exp, maxch, TY_CHAR) + call aclrc (Memc[exp], maxch) + +#call eprintf ( +# "fexpand: index='%s' name='%s' ver='%s' sec='%s' ik='%s' expr='%s'\n") +# call pargstr (index) ; call pargstr (extname) ; call pargstr (extver) ; +# call pargstr (section) ; call pargstr (ikparams) ; call pargstr (expr) + + nlines = 0 + nchars = 0 + nimages = 0 + + while (getline (fd, line) > 0) { + len = strlen (line) + line[len] = EOS # kill newline + nlines = nlines + 1 + + call aclrc (Memc[name], SZ_PATHNAME) + call sprintf (Memc[name], SZ_PATHNAME, "@%s") + call pargstr (line) + + lexp = 0 + do_proc = (index[1]!=EOS || section[1]!=EOS || + expr[1]!=EOS || extname[1]!=EOS) + + if (input[1] == '@' || do_proc) { + + # We're either being asked to expand what is presumably a + # image name in the form of an @@file input, or else we've + # added image sections, expressions, etc where the correct + # output specification is the expanded image name. + + lexp = imx_imexpand (Memc[name], expr, index, extname, extver, + ikparams, section, nims) + + elen = 0 + if (lexp != NULL && Memc[lexp] != EOS) + elen = strlen (Memc[lexp]) + + # Reallocate space is the output name if needed. + #if ((nchars + elen) >= (maxch - SZ_FNAME)) { + if ((nchars + elen) >= maxch) { + call calloc (nexp, maxch + SZ_FNT, TY_CHAR) + call amovc (Memc[exp], Memc[nexp], maxch) + call mfree (exp, TY_CHAR) + maxch = maxch + SZ_FNT + exp = nexp + } + + # Create a comma-delimited list. + if (nlines > 1) + call strcat (",", Memc[exp], maxch) + if (lexp != NULL && Memc[lexp] != EOS) { + call strcat (Memc[lexp], Memc[exp], maxch) + nchars = nchars + elen + 1 + } + nimages = nimages + nims + } else { + if (nlines > 1) { + call strcat (",", Memc[exp], maxch) + nchars = nchars + 1 + } + if (stridx ('[', line) != 0) { + call aclrc (buf, SZ_LINE) + op = 1 + for (ip=1; line[ip] != EOS; ip=ip+1) { + if (line[ip] == '[') { + output ('%') + output ('%') + output (CH_DELIM) + + level = 0 + for (; line[ip] != EOS; ip=ip+1) { + ch = line[ip] + if (ch == ',') { # , + if (level <= 0) + break # exit loop + else { + output ('\\') + output (ch) + } + } else if (ch == '[') { # [ + output ('\\') + output (ch) + level = level + 1 + } else if (ch == ']') { # ] + output (ch) + level = level - 1 + } else if (ch == '*') { # * + output ('\\') + output (ch) + } else # normal chars + output (ch) + } + output ('%') + ip = ip - 1 + + break + } + buf[op] = line[ip] + op = op + 1 + } + call strcat (buf, Memc[exp], maxch) + nchars = nchars + strlen (buf) + + } else { + call strcat (line, Memc[exp], maxch) + nchars = nchars + strlen (line) + } + + nchars = nchars + len + 1 + nimages = nimages + 1 + + # Reallocate space is the output name if needed. + + if ((nchars + SZ_LINE) >= maxch) { + call calloc (nexp, maxch + SZ_FNT, TY_CHAR) + call amovc (Memc[exp], Memc[nexp], maxch) + call mfree (exp, TY_CHAR) + maxch = maxch + SZ_FNT + exp = nexp + } + } + call mfree (lexp, TY_CHAR) + } + + call close (fd) # clean up + call sfree (sp) + + return (exp) +end + + +# IMX_TEXPAND -- Expand a template of tables into a list of images. + +pointer procedure imx_texpand (input, type, expr, index, fmt, nimages) + +char input[ARB] # Input table name +int type # Table type +char expr[ARB] # Filtering expression +char index[ARB] # Range list of table rows +char fmt[ARB] # Requested file format +int nimages # Number of output images + +char fname[SZ_PATHNAME] # File name to open +char ofname[SZ_PATHNAME] +pointer sp, exp, nodename +int ip, vfd, status, delim + +pointer imx_votable(), imx_table() +int vfnopen(), vfnmapu(), strncmp(), ki_gnode() + +begin + call smark (sp) + call salloc (nodename, SZ_PATHNAME, TY_CHAR) + + exp = NULL # initialize values + nimages = 0 + + # Get the base filename without the '@' prefix. + if (input[1] == '@') + call strcpy (input[2], fname, SZ_PATHNAME) + else + call strcpy (input, fname, SZ_PATHNAME) + + # Map input VFN to OSFN. + ip = 1 + if (strncmp (fname, "http://", 7) == 0) { + call strcpy (fname, ofname, SZ_PATHNAME) + } else { + vfd = vfnopen (fname, READ_ONLY) + status = vfnmapu (vfd, ofname, SZ_PATHNAME) + call vfnclose (vfd, VFN_NOUPDATE) + + # If the file resides on the local node strip the node name, + # returning a legal host system filename as the result. + if (ki_gnode (ofname, Memc[nodename], delim) == 0) + ip = delim + 1 + } + + + # Now process the file. For a VOTable we parse the file and + # extract the acref columns as cached image names, for ascii + # tables we read the URLs directly but likewise returned the + # cache name. + + if (type == IMT_TABLE) + exp = imx_table (ofname[ip], index, nimages) + else if (type == IMT_VOTABLE) + exp = imx_votable (ofname[ip], expr, index, fmt, nimages) + + call sfree (sp) + return (exp) +end + + +# IMX_DEXPAND -- Expand a directory into a list of images. + +pointer procedure imx_dexpand (input, expr, index, extname, extver, ikparams, + sec, nimages) + +char input[ARB] # List of MEF file names +char expr[ARB] # Filtering expression +char index[ARB] # Index range +char extname[ARB] # Extension name +char extver[ARB] # Extension version +char ikparams[ARB] # IKI parameters +char sec[ARB] # Image section +int nimages # Number of output images + +pointer sp, exp, nodename, imname, listout +int dir, len, llen, nim, ip, delim, vfd, status, maxlen +char dirname[SZ_PATHNAME], ofname[SZ_PATHNAME], pdir[SZ_PATHNAME] +char fpath[SZ_PATHNAME], fname[SZ_PATHNAME] + +pointer imx_imexpand () +int vfnopen(), vfnmapu(), ki_gnode(), imx_filetype() +int strlen(), diropen(), isdirectory(), getline() + +begin + call smark (sp) + call salloc (nodename, SZ_PATHNAME, TY_CHAR) + + # Get the base filename without the '@' prefix. + if (input[1] == '@') { + if (input[2] == '@') + call strcpy (input[3], dirname, SZ_PATHNAME) + else + call strcpy (input[2], dirname, SZ_PATHNAME) + } else + call strcpy (input, dirname, SZ_PATHNAME) + + # Remove trailing '/' or '$' from dir + len = strlen (dirname) + if (dirname[len] == '/') + dirname[len] = EOS + + # Map input VFN to OSFN. + ip = 1 + vfd = vfnopen (dirname, READ_ONLY) + status = vfnmapu (vfd, ofname, SZ_PATHNAME) + call vfnclose (vfd, VFN_NOUPDATE) + + # If the file resides on the local node strip the node name, + # returning a legal host system filename as the result. + if (ki_gnode (ofname, Memc[nodename], delim) == 0) + ip = delim + 1 + + call sfree (sp) + + # Otherwise, read through the directory and remove the contents. + dir = diropen (ofname, SKIP_HIDDEN_FILES) + + maxlen = SZ_LISTOUT + call calloc (listout, SZ_LISTOUT, TY_CHAR) + llen = 0 + while (getline (dir, fname) != EOF) { + len = strlen (fname) + fname[len] = '\0' + + len = strlen (ofname) + if (ofname[len] == '/' || ofname[len] == '$') + call sprintf (fpath, SZ_PATHNAME, "%s%s") + else + call sprintf (fpath, SZ_PATHNAME, "%s/%s") + call pargstr (dirname) + call pargstr (fname) + + llen = llen + strlen (fpath) + + # We only test plain files, skip directories. + if (isdirectory (fpath, pdir, SZ_PATHNAME) > 0) + next + + if (imx_filetype (fpath) == IMT_IMAGE) { + + if (input[2] == '@') + imname = imx_imexpand (fpath, expr, index, extname, extver, + ikparams, sec, nim) + else { + call calloc (imname, SZ_PATHNAME, TY_CHAR) + call strcpy (fpath, Memc[imname], SZ_PATHNAME) + } + + if (imname != NULL && Memc[imname] != EOS) { + nimages = nimages + 1 + + if (nimages > 1) { + call strcat (",", Memc[listout], maxlen) + llen = llen + 1 + } + if ((llen + strlen (Memc[imname])) >= maxlen) { + maxlen = maxlen + SZ_LISTOUT + call realloc (listout, maxlen, TY_CHAR) + } + + call strcat (Memc[imname], Memc[listout], maxlen) + llen = llen + strlen (Memc[imname]) + + if (sec[1] != EOS) { + call strcat ("[", Memc[listout], maxlen) + call strcat (sec, Memc[listout], maxlen) + call strcat ("]", Memc[listout], maxlen) + llen = llen + strlen (sec) + 2 + } + + if (imname != NULL) + call mfree (imname, TY_CHAR) + } + } + } + + return (listout) +end + + +# IMX_FETCH -- Fetch the urls from the list. + +procedure imx_fetch (urls, istemp) + +char urls[ARB] #I file of URLS to download +bool istemp #i is input file temporary? + +char osfn[SZ_PATHNAME] +char url_osfn[SZ_PATHNAME] + +int n, envgets() +char nthreads[SZ_FNAME] + +begin + # Get the host pathname of the cache directory. + call fmapfn ("cache$", osfn, SZ_PATHNAME) + call strupk (osfn, osfn, SZ_PATHNAME) + + call fmapfn (urls, url_osfn, SZ_PATHNAME) + call strupk (url_osfn, url_osfn, SZ_PATHNAME) + + n = envgets ("vo_nthreads", nthreads, SZ_FNAME) + + # voget -B -C -D cache$ -b url -N [-t] + if (istemp) { + call vx_voget (10, "-B", "-C", "-D", osfn, "-b", "url", + "-N", nthreads, "-t", url_osfn) + } else { + call vx_voget (10, "-B", "-C", "-D", osfn, "-b", "url", + "-N", nthreads, "-B", url_osfn) + } +end + + +# IMX_VOTABLE -- Read a VOTable, extracting the column of access references +# as the image list. + +pointer procedure imx_votable (input, expr, index, fmt, nimages) + +char input[ARB] # List of ME file names +char expr[ARB] # Filtering expression +char index[ARB] # Range list of table rows +char fmt[ARB] # Requested file format +int nimages # Number of output images + +pointer vot, exp, ranges +int nranges, tfd +char tfile[SZ_PATHNAME] + +int open() +int imx_decode_ranges() +pointer imx_votselect(), votinit() +bool envgetb() + +begin + # Create a temp file for the parsed access references. + call mktemp ("tmp$vot", tfile, SZ_PATHNAME) + iferr (tfd = open (tfile, NEW_FILE, TEXT_FILE)) { + nimages = 0 + return (NULL) + } + + # Expand the index string into a range structure. + if (index[1] != EOS) { + call calloc (ranges, 3 * SZ_RANGE, TY_INT) + if (imx_decode_ranges (index, Memi[ranges], SZ_RANGE, + nranges, YES) == ERR) { + call eprintf ("error parsing range '%s'\n") + call pargstr (index) + } + } else + ranges = NULL + + # Initialize the VOT struct and parse the table. + vot = votinit (input) + + # Select the column from the VOTable with the access reference. + exp = imx_votselect (vot, tfd, fmt, ranges, nimages) + + call mfree (ranges, TY_INT) + call votclose (vot) # close the files + call close (tfd) + + # Close the temp file and pre-fetch the data if needed. + if (envgetb ("vo_prefetch")) + call imx_fetch (tfile, true) + + return (exp) +end + + +# IMX_VOTSELECT -- Select the access reference column. + +pointer procedure imx_votselect (vot, fd, fmt, ranges, nimages) + +pointer vot #i VOTable struct pointer +int fd #i filename of selected rows +char fmt[ARB] #i file format +pointer ranges #i ranges struct pointer +int nimages #o no. selected images + +pointer exp +int col, len, clen, maxlen +char acref_ucd[SZ_FNAME], imfmt[SZ_FNAME], ucd_col[SZ_FNAME] +char acref[SZ_LINE], ucd[SZ_FNAME], buf[SZ_LINE], cfname[SZ_PATHNAME] +int i, rownum, field, acref_col, acfmt_col + +int strcmp(), strsearch(), strlen(), vx_getNext() +bool imx_in_range() + +begin + # Figure out which table column we want. Note that we assume there + # is only one element. The caller may pass in a specific + # column to be used, otherwise look for for the named UCD. + + col = 0 # FIXME + call aclrc (ucd_col, SZ_FNAME) # FIXME + call strcpy ("fits", imfmt, SZ_FNAME) # FIXME + + call aclrc (acref_ucd, SZ_FNAME) + if (col > 0) { + acref_col = col + } else { + if (ucd_col[1] != EOS) + call strcpy (ucd_col, acref_ucd, SZ_FNAME) + else + call strcpy (DEF_ACREF_UCD, acref_ucd, SZ_FNAME) + + # Find the access reference column number. + i = 0 + for (field=VOT_FIELD(vot); field > 0; field=vx_getNext (field)) { + call aclrc (ucd, SZ_FNAME) + call vx_getAttr (field, "ucd", ucd, SZ_FNAME) + if (strcmp (ucd, acref_ucd) == 0) { + acref_col = i + } else if (strcmp (ucd, DEF_FORMAT_UCD) == 0) + acfmt_col = i + i = i + 1 + } + } + + maxlen = SZ_BUF + call calloc (exp, maxlen, TY_CHAR) + + # Download the files. + for (i=0; i < VOT_NROWS(vot); i=i+1) { + call vx_getTableCell (VOT_TDATA(vot), i, acfmt_col, imfmt, SZ_FNAME) + + if (fmt[1] == EOS || (fmt[1] != EOS && strsearch(imfmt, fmt) > 0)) { + call vx_getTableCell (VOT_TDATA(vot), i, acref_col, + acref, SZ_LINE) + + # Do the row selection based on the index string. + rownum = i + 1 + if (ranges != NULL && ! imx_in_range (Memi[ranges], rownum)) + next + + # Generate a unique cache filename based on the URL. + call fcname ("cache$", acref, "url", cfname, SZ_PATHNAME) + + # Append the cache name to the output string. Reallocate the + # string pointer if needed. + clen = strlen (cfname) + if ((len + clen) >= maxlen) { + maxlen = maxlen + SZ_BUF + call realloc (exp, maxlen, TY_CHAR) + } + len = len + clen + + if (nimages == 0) { + call strcpy (cfname, Memc[exp], maxlen) + } else { + call strcat (",", Memc[exp], maxlen) + call strcat (cfname, Memc[exp], maxlen) + } + call aclrc (buf, SZ_LINE) + + # Write the URL to the download file. + call fprintf (fd, "%s\n") + call pargstr (acref) + + nimages = nimages + 1 + } + } + + return (exp) +end + + +# IMX_TABLE -- Read an ASCII text table of URLs and create the list +# of files to process. We apply the list index to do row selection +# and return a list of cached filenames. + +pointer procedure imx_table (input, index, nimages) + +char input[ARB] # List of ME file names +char index[ARB] # Range list of table rows +int nimages # Number of output images + +pointer exp, ranges +int rownum, nranges, fd, len, clen, maxlen +char buf[SZ_LINE], cfname[SZ_PATHNAME] + +int open(), getline(), strlen() +int imx_decode_ranges() +bool imx_in_range(), envgetb() + +begin + call aclrc (buf, SZ_LINE) + iferr (fd = open (input, READ_ONLY, TEXT_FILE)) + call syserr (SYS_FOPEN) + + maxlen = SZ_BUF + call calloc (exp, maxlen, TY_CHAR) + + call calloc (ranges, 3 * SZ_RANGE, TY_INT) + if (index[1] != EOS) { + if (imx_decode_ranges (index, Memi[ranges], SZ_RANGE, + nranges, YES) == ERR) { + call eprintf ("error parsing range '%s'\n") + call pargstr (index) + } + } + + len = 0 + nimages = 0 + rownum = 0 + while (getline (fd, buf) != EOF) { + + # Skip comments and blank lines. + if (buf[1] == '\n' || buf[1] == '#') + next + else + rownum = rownum + 1 + + # Do the row selection based on the index string. + if (index[1] != EOS && ! imx_in_range (Memi[ranges], rownum)) + next + + # Generate a unique cache filename based on the URL. + call fcname ("cache$", buf, "url", cfname, SZ_PATHNAME) + + # Append the cache name to the output string. Reallocate the + # string pointer if needed. + clen = strlen (cfname) + if ((len + clen) >= maxlen) { + maxlen = maxlen + SZ_BUF + call realloc (exp, maxlen, TY_CHAR) + } + len = len + clen + + if (nimages == 0) { + call strcpy (cfname, Memc[exp], maxlen) + } else { + call strcat (",", Memc[exp], maxlen) + call strcat (cfname, Memc[exp], maxlen) + } + call aclrc (buf, SZ_LINE) + + nimages = nimages + 1 + } + + call mfree (ranges, TY_INT) + call close (fd) + + if (envgetb ("vo_prefetch")) + call imx_fetch (input, false) + + return (exp) +end + + +# IMX_EXTNS -- Expand a template of ME files into a list of image extensions. + +int procedure imx_extns (files, exttype, index, extname, extver, + lindex, lname, lver, ikparams, section, expr, err) + +char files[ARB] #I List of ME files +char exttype[ARB] #I Extension type string +char index[ARB] #I Range list of extension indexes +char extname[ARB] #I Patterns for extension names +char extver[ARB] #I Range list of extension versions +int lindex #I List index number? +int lname #I List extension name? +int lver #I List extension version? +char expr[ARB] #I Selection expression +char ikparams[ARB] #I Image kernel parameters +char section[ARB] #I Image section parameters +int err #I Print errors? +int list #O Image list + +int i, fd, create +pointer sp, temp, fname, imname, sec, rindex, rextver, ikp, str +int fntopnb(), fntgfnb() +int imx_decode_ranges(), nowhite(), open() +errchk open, imx_extn, delete + +begin + call smark (sp) + call salloc (temp, SZ_FNAME, TY_CHAR) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (imname, SZ_FNAME, TY_CHAR) + call salloc (sec, SZ_FNAME, TY_CHAR) + call salloc (ikp, SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Expand parameters. + list = fntopnb (files, NO) + call salloc (rindex, 3*SZ_RANGE, TY_INT) + if (imx_decode_ranges (index, Memi[rindex], SZ_RANGE, i, create) == ERR) + call error (1, "Bad index range list") + + rextver = NULL + if (nowhite (extver, Memc[str], SZ_LINE) > 0) { + call salloc (rextver, 3*SZ_RANGE, TY_INT) + if (imx_decode_ranges (Memc[str], Memi[rextver], SZ_RANGE, + i, create) == ERR) + call error (1, "Bad extension version range list") + } + + call aclrc (Memc[ikp], SZ_LINE) + i = nowhite (ikparams, Memc[ikp], SZ_LINE) + + # Expand ME files into list of image extensions in a temp file. + call mktemp ("@tmp$iraf", Memc[temp], SZ_FNAME) + fd = open (Memc[temp+1], NEW_FILE, TEXT_FILE) + while (fntgfnb (list, Memc[fname], SZ_FNAME) != EOF) { + call imgimage (Memc[fname], Memc[imname], SZ_FNAME) + call imgsection (Memc[fname], Memc[sec], SZ_FNAME) + + call imx_extn (fd, Memc[imname], exttype, expr, rindex, extname, + rextver, lindex, lname, lver, Memc[ikp], section, + create, err) + } + call fntclsb (list) + call close (fd) + + # Return list. + list = fntopnb (Memc[temp], NO) + call delete (Memc[temp+1]) + call sfree (sp) + + return (list) +end + + +# IMX_EXTN -- Expand a single ME file into a list of image extensions. +# The image extensions are written to the input file descriptor. + +procedure imx_extn (fd, fname, exttype, expr, index, extname, extver, lindex, + lname, lver, ikparams, section, create, err) + +int fd #I File descriptor for list +char fname[SZ_FNAME] #I File image name (without kernel or image sec) +char exttype[SZ_FNAME] #I File extension type +char expr[ARB] #I Selection expression +pointer index #I Range list of extension indexes +char extname[ARB] #I Pattern for extension names +pointer extver #I Range list of extension versions +int lindex #I List index number? +int lname #I List extension name? +int lver #I List extension version? +char ikparams[ARB] #I Image kernel parameters +char section[ARB] #I Image section +int create #I Create names from index range? +int err #I Print errors? + +pointer sp, image, name, type, str, im +int i, j, ver + +pointer immap() +int imx_get_next_number(), errcode(), imgeti(), stridxs(), strcmp() +bool imx_in_range(), imx_extmatch(), imx_matchexpr(), imx_sifmatch() + +begin + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (type, SZ_FNAME, TY_CHAR) + call salloc (name, SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + i = -1 + while (imx_get_next_number (Memi[index], i) != EOF) { + j = stridxs ("[", fname) + if (j > 0) { + if (i > 0) + break + call strcpy (fname, Memc[image], SZ_FNAME) + } else { + call sprintf (Memc[image], SZ_FNAME, "%s[%d]") + call pargstr (fname) + call pargi (i) + } + + if (section[1] != EOS) { + call strcat ("[", Memc[image], SZ_FNAME) + call strcat (section, Memc[image], SZ_FNAME) + call strcat ("]", Memc[image], SZ_FNAME) + } + + # We know the extension doesn't exist, generate the name. + if (create == YES) { + call fprintf (fd, "%s") + call pargstr (Memc[image]) + if (section[1] != EOS) { + call fprintf (fd, "[%s]") + call pargstr (section) + } + call fprintf (fd, "\n") + next + } + + + iferr (im = immap (Memc[image], READ_ONLY, 0)) { + switch (errcode()) { + case SYS_FXFRFEOF: + if (i == 1) { + if (extname[1] == EOS && imx_sifmatch (fname, expr)) { + call fprintf (fd, "%s\n") + call pargstr (fname) + next + } else + break + } + break + case SYS_IKIEXTN: + next + case SYS_IKIOPEN: + switch (i) { + case 0: + next + case 1: + if (err == YES) + call erract (EA_WARN) + break + default: + break + } + default: + call erract (EA_ERROR) + } + } + + + # Check the extension type. [NOT USED] + if (exttype[1] != EOS) { + iferr (call imgstr (im, "xtension", Memc[type], SZ_FNAME)) + Memc[type] = EOS + if (Memc[type] != EOS && strcmp (Memc[type], exttype) != 0) { + call imunmap (im) + next + } + } + +#call eprintf("imx_extn: name='%s' ver='%s' expr='%s' sec='%s' iki='%s'\n") +# call pargstr (extname) ; call pargstr (Memc[extver]) ; +# call pargstr (expr) ; call pargstr (section) ; +# call pargstr (ikparams) ; + + # Check the extension name. + if (extname[1] != EOS) { + iferr (call imgstr (im, "extname", Memc[name], SZ_FNAME)) + Memc[name] = EOS + if (!imx_extmatch (Memc[name], extname)) { + call imunmap (im) + next + } + } + + # Check the extension version. + if (extver != NULL) { + iferr (ver = imgeti (im, "extver")) { + call imunmap (im) + next + } + if (!imx_in_range (Memi[extver], ver)) { + call imunmap (im) + next + } + } + + # Check the selection expression. + if (expr[1] != EOS) { + if (!imx_matchexpr (im, expr)) { + call imunmap (im) + next + } + } + + + # Set the extension name and version. + if (lname == YES) { + iferr (call imgstr (im, "extname", Memc[name], SZ_LINE)) + Memc[name] = EOS + } else + Memc[name] = EOS + if (lver == YES) { + iferr (ver = imgeti (im, "extver")) + ver = INDEFI + } else + ver = INDEFI + + # Write the image name. + call fprintf (fd, fname) + if (j == 0) { + if (lindex == YES || (Memc[name] == EOS && IS_INDEFI(ver))) { + call fprintf (fd, "[%d]") + call pargi (i) + } + if (Memc[name] != EOS) { + call fprintf (fd, "[%s") + call pargstr (Memc[name]) + if (!IS_INDEFI(ver)) { + call fprintf (fd, ",%d") + call pargi (ver) + } + if (ikparams[1] != EOS) { + call fprintf (fd, ",%s") + call pargstr (ikparams) + } + call fprintf (fd, "]") + } else if (!IS_INDEFI(ver)) { + call fprintf (fd, "[extver=%d") + call pargi (ver) + if (ikparams[1] != EOS) { + call fprintf (fd, ",%s") + call pargstr (ikparams) + } + call fprintf (fd, "]") + } else if (ikparams[1] != EOS) { + call fprintf (fd, "[%s]%%") + call pargstr (ikparams) + } + } + if (section[1] != EOS) { + call fprintf (fd, "[%s]") + call pargstr (section) + } + call fprintf (fd, "\n") + + call imunmap (im) + } + + call sfree (sp) +end + + +# IMX_DECODE_RANGES -- Parse a string containing a list of integer numbers or +# ranges, delimited by either spaces or commas. Return as output a list +# of ranges defining a list of numbers, and the count of list numbers. +# Range limits must be positive nonnegative integers. ERR is returned as +# the function value if a conversion error occurs. The list of ranges is +# delimited by EOLIST. + +int procedure imx_decode_ranges (range_string, ranges, max_ranges, + nvalues, create) + +char range_string[ARB] # Range string to be decoded +int ranges[3, max_ranges] # Range array +int max_ranges # Maximum number of ranges +int nvalues # The number of values in the ranges +int create # generate range string? + +int ip, nrange, first, last, step, ctoi() + +begin + create = NO + if (range_string[1] == '+') { + ip = 2 + create = YES + } else + ip = 1 + nvalues = 0 + + do nrange = 1, max_ranges - 1 { + # Defaults to all nonnegative integers + first = FIRST + last = LAST + step = STEP + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get first limit. + # Must be a number, '-', 'x', or EOS. If not return ERR. + if (range_string[ip] == EOS) { # end of list + if (nrange == 1) { + # Null string defaults + ranges[1, 1] = first + ranges[2, 1] = last + ranges[3, 1] = step + ranges[1, 2] = EOLIST + nvalues = MAX_INT + return (OK) + } else { + ranges[1, nrange] = EOLIST + return (OK) + } + } else if (range_string[ip] == '-') + ; + else if (range_string[ip] == 'x') + ; + else if (IS_DIGIT(range_string[ip])) { # ,n.. + if (ctoi (range_string, ip, first) == 0) + return (ERR) + } else + return (ERR) + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get last limit + # Must be '-', or 'x' otherwise last = first. + if (range_string[ip] == 'x') + ; + else if (range_string[ip] == '-') { + ip = ip + 1 + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + if (range_string[ip] == EOS) + ; + else if (IS_DIGIT(range_string[ip])) { + if (ctoi (range_string, ip, last) == 0) + return (ERR) + } else if (range_string[ip] == 'x') + ; + else + return (ERR) + } else + last = first + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get step. + # Must be 'x' or assume default step. + if (range_string[ip] == 'x') { + ip = ip + 1 + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + if (range_string[ip] == EOS) + ; + else if (IS_DIGIT(range_string[ip])) { + if (ctoi (range_string, ip, step) == 0) + ; + if (step == 0) + return (ERR) + } else if (range_string[ip] == '-') + ; + else + return (ERR) + } + + # Output the range triple. + ranges[1, nrange] = first + ranges[2, nrange] = last + ranges[3, nrange] = step + nvalues = nvalues + abs (last-first) / step + 1 + } + + return (ERR) # ran out of space +end + + +# IMX_GET_NEXT_NUMBER -- Given a list of ranges and the current file number, +# find and return the next file number. Selection is done in such a way +# that list numbers are always returned in monotonically increasing order, +# regardless of the order in which the ranges are given. Duplicate entries +# are ignored. EOF is returned at the end of the list. + +int procedure imx_get_next_number (ranges, number) + +int ranges[ARB] # Range array +int number # Both input and output parameter + +int ip, first, last, step, next_number, remainder + +begin + # If number+1 is anywhere in the list, that is the next number, + # otherwise the next number is the smallest number in the list which + # is greater than number+1. + + number = number + 1 + next_number = MAX_INT + + for (ip=1; ranges[ip] != EOLIST; ip=ip+3) { + first = min (ranges[ip], ranges[ip+1]) + last = max (ranges[ip], ranges[ip+1]) + step = ranges[ip+2] + if (step == 0) + call error (1, "Step size of zero in range list") + if (number >= first && number <= last) { + remainder = mod (number - first, step) + if (remainder == 0) + return (number) + if (number - remainder + step <= last) + next_number = number - remainder + step + } else if (first > number) + next_number = min (next_number, first) + } + + if (next_number == MAX_INT) + return (EOF) + else { + number = next_number + return (number) + } +end + + +# IMX_EXTMATCH -- Match extname against a comma-delimited list of patterns. + +bool procedure imx_extmatch (extname, patterns) + +char extname[ARB] #I Extension name to match +char patterns[ARB] #I Comma-delimited list of patterns +bool stat #O Match? + +int i, j, k, sz_pat, strlen(), patmake(), patmatch(), nowhite() +pointer sp, patstr, patbuf + +begin + stat = false + + sz_pat = strlen (patterns) + if (sz_pat == 0) + return (stat) + sz_pat = sz_pat + SZ_LINE + + call smark (sp) + call salloc (patstr, sz_pat, TY_CHAR) + call salloc (patbuf, sz_pat, TY_CHAR) + + i = nowhite (patterns, Memc[patstr], sz_pat) + if (i == 0) + stat = true + else if (i == 1 && Memc[patstr] == '*') + stat = true + else { + i = 1 + for (j=i;; j=j+1) { + if (patterns[j] != ',' && patterns[j] != EOS) + next + if (j - i > 0) { + if (j-i == 1 && patterns[i] == '*') { + stat = true + break + } + call strcpy (patterns[i], Memc[patstr+1], j-i) + Memc[patstr] = '^' + Memc[patstr+j-i+1] = '$' + Memc[patstr+j-i+2] = EOS + k = patmake (Memc[patstr], Memc[patbuf], sz_pat) + if (patmatch (extname, Memc[patbuf]) > 0) { + stat = true + break + } + } + if (patterns[j] == EOS) + break + i = j + 1 + } + } + + call sfree (sp) + return (stat) +end + + +# IMX_IN_RANGE -- Test number to see if it is in range. +# If the number is INDEFI then it is mapped to the maximum integer. + +bool procedure imx_in_range (ranges, number) + +int ranges[ARB] # Range array +int number # Number to be tested against ranges + +int ip, first, last, step, num + +begin + if (IS_INDEFI (number)) + num = MAX_INT + else + num = number + + for (ip=1; ranges[ip] != NULL; ip=ip+3) { + first = min (ranges[ip], ranges[ip+1]) + last = max (ranges[ip], ranges[ip+1]) + step = ranges[ip+2] + if (num >= first && num <= last) + if (mod (num - first, step) == 0) + return (true) + } + + return (false) +end diff --git a/sys/imio/imt/imxexpr.x b/sys/imio/imt/imxexpr.x new file mode 100644 index 00000000..55c185ef --- /dev/null +++ b/sys/imio/imt/imxexpr.x @@ -0,0 +1,222 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include + +define LEN_USERAREA 28800 # allow for the largest possible header +define SZ_IMAGENAME 63 # max size of an image name +define SZ_FIELDNAME 31 # max size of a field name + +define DEBUG FALSE + + + +# IMX_MATCHEXPR -- Match the open image descriptor against the expression. + +bool procedure imx_matchexpr (im, expr) + +pointer im #I image descriptor +char expr[ARB] #I expression string + +bool stat +char val[SZ_LINE] +pointer o + +pointer imt_im # getop common +char imt_image[SZ_IMAGENAME] +char imt_field[SZ_FIELDNAME] +common /imtgop/ imt_im, imt_image, imt_field + +pointer evexpr() +extern imx_getop() +int locpr() +errchk locpr, evexpr + +begin + call aclrc (val, SZ_LINE) + call aclrc (imt_image, SZ_IMAGENAME) + call aclrc (imt_field, SZ_FIELDNAME) + + imt_im = im + if (expr[1] != EOS) { + iferr { + o = evexpr (expr, locpr (imx_getop), 0) + call imx_encodeop (o, val, SZ_LINE) + stat = O_VALB(o) + call xev_freeop (o) + call mfree (o, TY_STRUCT) + } then + stat = FALSE + + if (DEBUG) { + call eprintf ("expr = '%s' %b\n") + call pargstr (expr) ; call pargb (stat) + } + + return (stat) + } + + return (FALSE) +end + + +# IMX_SIFMATCH -- Check whether the file is a simple image matching the +# expression. + +bool procedure imx_sifmatch (fname, expr) + +char fname[ARB] #I image name +char expr[ARB] #I expression string + +pointer im +bool stat + +pointer immap() +bool imx_matchexpr (), streq() +errchk immap + +begin + if (expr[1] == EOS) + return (TRUE) + + iferr (im = immap (fname, READ_ONLY, 0)) { + return (FALSE) + } + + if (streq (expr, "yes")) + stat = TRUE + else + stat = imx_matchexpr (im, expr) + call imunmap (im) + + return (stat) +end + + +# IMX_GETOP -- Satisfy an operand request from EVEXPR. In this context, +# operand names refer to the fields of the image header. The following +# special operand names are recognized: +# +# . a string literal, returned as the string "." +# $ the value of the current field +# $F the name of the current field +# $I the name of the current image +# $T the current time, expressed as an integer +# +# The companion procedure HE_GETOPSETIMAGE is used to pass the image pointer +# and image and field names. + +procedure imx_getop (operand, o) + +char operand[ARB] # operand name +pointer o # operand (output) + +pointer imt_im # getop common +char imt_image[SZ_IMAGENAME] +char imt_field[SZ_FIELDNAME] +common /imtgop/ imt_im, imt_image, imt_field +bool streq() +long clktime() +errchk imx_getfield + +begin + if (streq (operand, ".")) { + call xev_initop (o, 1, TY_CHAR) + call strcpy (".", O_VALC(o), 1) + + } else if (streq (operand, "$")) { + call imx_getfield (imt_im, imt_field, o) + + } else if (streq (operand, "$F")) { + call xev_initop (o, SZ_FIELDNAME, TY_CHAR) + call strcpy (imt_field, O_VALC(o), SZ_FIELDNAME) + + } else if (streq (operand, "$I")) { + call xev_initop (o, SZ_IMAGENAME, TY_CHAR) + call strcpy (imt_image, O_VALC(o), SZ_IMAGENAME) + + } else if (streq (operand, "$T")) { + # Assignment of long into int may fail on some systems. Maybe + # should use type string and let database convert to long... + + call xev_initop (o, 0, TY_INT) + O_VALI(o) = clktime (long(0)) + + } else + call imx_getfield (imt_im, operand, o) +end + + +# IMX_GETFIELD -- Return the value of the named field of the image header as +# an EVEXPR type operand structure. + +procedure imx_getfield (im, field, o) + +pointer im # image descriptor +char field[ARB] # name of field to be returned +pointer o # pointer to output operand + +bool imgetb() +int ftype, imgeti(), imgftype() +real imgetr() + +begin + iferr { + ftype = imgftype (im, field) + } then { + call xev_initop (o, SZ_LINE, TY_CHAR) # keyword not found + call aclrc (O_VALC(o), SZ_LINE) + return + } + + switch (ftype) { + case TY_BOOL: + call xev_initop (o, 0, TY_BOOL) + O_VALB(o) = imgetb (im, field) + + case TY_SHORT, TY_INT, TY_LONG: + call xev_initop (o, 0, TY_INT) + O_VALI(o) = imgeti (im, field) + + case TY_REAL, TY_DOUBLE, TY_COMPLEX: + call xev_initop (o, 0, TY_REAL) + O_VALR(o) = imgetr (im, field) + + default: + call xev_initop (o, SZ_LINE, TY_CHAR) + call imgstr (im, field, O_VALC(o), SZ_LINE) + } +end + + +# IMX_ENCODEOP -- Encode an operand as returned by EVEXPR as a string. EVEXPR +# operands are restricted to the datatypes bool, int, real, and string. + +procedure imx_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 diff --git a/sys/imio/imt/imxftype.x b/sys/imio/imt/imxftype.x new file mode 100644 index 00000000..e083f032 --- /dev/null +++ b/sys/imio/imt/imxftype.x @@ -0,0 +1,119 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "imx.h" + + +# IMX_FILETYPE -- Determine the file type. + +int procedure imx_filetype (fname) + +char fname[ARB] #i file name + +char img[SZ_FNAME], name[SZ_FNAME], buf[SZ_LINE] + +int i, nchars, fd +bool is_http_list + +int errcode(), open(), read(), access(), imaccess() +int strncmp(), strsearch(), isdirectory() +pointer im, immap() + +begin + # Check for a URL. + if (strncmp ("http://", fname, 7) == 0) + return (IMT_URL) + + call aclrc (name, SZ_FNAME) + if (fname[1] == '@') + call strcpy (fname[2], name, SZ_FNAME) + else + call strcpy (fname, name, SZ_FNAME) + + # See if it is a directory. + if (isdirectory (name, buf, SZ_LINE) > 0) + return (IMT_DIR) + + # Check for concatenated strings. + if (strsearch (fname, "//") > 0) { + if (isdirectory (fname, buf, SZ_LINE) > 0) + return (IMT_DIR) + else + return (IMT_FILE) + } + + call aclrc (img, SZ_FNAME) # PHU + call sprintf (img, SZ_FNAME, "%s[0]") + call pargstr (name) + + # Get a peek at the file. + call aclrc (buf, SZ_LINE) + if (imaccess (name, READ_ONLY) == YES || + imaccess (img, READ_ONLY) == YES) { + return (IMT_IMAGE); + } else if (access (name, 0, 0) == YES) { + fd = open (name, READ_ONLY, TEXT_FILE) + nchars = read (fd, buf, SZ_LINE) + call strupr (buf) + call close (fd) + } + + # See if it might be an image of some kind. + if (strncmp (buf, "SIMPLE", 6) == 0) { + + ifnoerr (im = immap (name, READ_ONLY, 0)) { # SIF, OIF, etc + call imunmap (im) + return (IMT_IMAGE) + } + + do i = 0, 1 { # MEF + call aclrc (img, SZ_FNAME) + call sprintf (img, SZ_FNAME, "%s[%d]") + call pargstr (name) + call pargi (i) + + iferr (im = immap (img, READ_ONLY, 0)) { + switch (errcode()) { + case SYS_FXFRFEOF: + break + case SYS_IKIEXTN: + next + case SYS_IKIOPEN: + if (i == 0) + next + break + default: + call erract (EA_ERROR) + } + } else { + call imunmap (im) + return (IMT_IMAGE) + } + } + + } else { + + # If we get this far, we have a file of some kind. See if it is a + # list of URLs, a VOTable, or a plain file. + is_http_list = FALSE + fd = open (name, READ_ONLY, TEXT_FILE) + do i = 1, 10 { + call aclrc (buf, SZ_LINE) + nchars = read (fd, buf, SZ_LINE) + call strupr (buf) + if (strsearch (buf, "VOTABLE") > 0) { + call close (fd) + return (IMT_VOTABLE) + } else if (strncmp (buf, "http://", 7) == 0) + is_http_list = TRUE + } + call close (fd) + } + + if (is_http_list) + return (IMT_TABLE) + else + return (IMT_FILE) +end diff --git a/sys/imio/imt/imxparse.x b/sys/imio/imt/imxparse.x new file mode 100644 index 00000000..f26f0918 --- /dev/null +++ b/sys/imio/imt/imxparse.x @@ -0,0 +1,203 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "imx.h" + + +define IMT_INDEX 1 +define IMT_NAME 2 +define IMT_VER 3 +define IMT_EXPR 4 + +define DEBUG FALSE + + + +# IMX_PARSE -- Parse a filename to extract index ranges, extension names, +# versions and filtering expressions. + +int procedure imx_parse (input, fname, index, extname, extver, + expr, sec, ikparams, maxch) + +char input[ARB] #i template string ptr +char fname[ARB] #o file name +char index[ARB] #o index range string +char extname[ARB] #o extension name +char extver[ARB] #o extension version +char expr[ARB] #o filtering expression string +char sec[ARB] #o image section string +char ikparams[ARB] #o image kernel section params +int maxch #i max chars in string params + +pointer im +int nchars, ip, idx +char comma, lexpr[SZ_LINE], subex[SZ_LINE], name[SZ_PATHNAME] + +int imx_breakout(), imx_next_expr(), imx_expr_type(), stridx() +pointer immap() + +begin + call aclrc (expr, maxch) # initialize + call aclrc (index, maxch) + call aclrc (fname, maxch) + call aclrc (extver, maxch) + call aclrc (extname, maxch) + call aclrc (ikparams, maxch) + call aclrc (lexpr, SZ_LINE) + + + # Separate the filename from the expression string. + nchars = imx_breakout (input, NO, fname, lexpr, sec, ikparams, maxch) + + # Parse into sub-expression strings, breaking it up into the + # appropriate form depending on the contents. + if (lexpr[1] != EOS) { + ip = 1 + while (imx_next_expr (lexpr, ip, subex, maxch) != EOS) { + + if (DEBUG) { + call eprintf ("parse subex = '%s'\t\t'%s'\n") + call pargstr (subex) ; call pargstr (lexpr) + } + + switch (imx_expr_type (subex)) { + case IMT_INDEX: + call strcpy (subex, index, maxch) + case IMT_NAME: + call strcpy (subex, extname, maxch) + case IMT_VER: + comma = ',' + idx = stridx (comma, subex) + call strcpy (subex[idx+1], extver, maxch) + subex[idx] = '\0' + call strcpy (subex, extname, maxch) + case IMT_EXPR: + if (expr[1] != EOS) { + call strcat ("||", expr, maxch) + call strcat (subex, expr, maxch) + } else + call strcpy (subex, expr, maxch) + default: + call error (1, "unknown expression type") + } + + ip = ip + 1 + } + } + + if (DEBUG) { + call eprintf ("final expr = '%s' index = '%s' sec = '%s'\n") + call pargstr (expr) + call pargstr (index) + call pargstr (sec) + } + + call aclrc (name, SZ_PATHNAME) + if (fname[1] == '@') + call strcpy (fname[2], name, SZ_PATHNAME) + else + call strcpy (fname, name, SZ_PATHNAME) + if (index[1] != EOS) { + call strcat ("[", name, SZ_PATHNAME) + call strcat (index, name, SZ_PATHNAME) + call strcat ("]", name, SZ_PATHNAME) + } + if (sec[1] != EOS) { + call strcat ("[", name, SZ_PATHNAME) + call strcat (sec, name, SZ_PATHNAME) + call strcat ("]", name, SZ_PATHNAME) + } + +# iferr { +# im = immap (name, READ_ONLY, 0) +# call imunmap (im) +# } then +# ; + + return (nchars) +end + + +# IMX_NEXT_EXPR -- Get the next sub expression from the string. Expressions +# are delimited by semicolons, the location in the expression string is +# updated. + +int procedure imx_next_expr (expr, ip, subex, maxch) + +char expr[ARB] #i input expression string +int ip #u location in expr +char subex[ARB] #o sub expression string +int maxch #i max size of subexpr string + +char op + +begin + if (expr[ip] == EOS) + return (EOS) + + # Skip leading whitespace/delimiters. + while (IS_WHITE(expr[ip]) || expr[ip] == ';') + ip = ip + 1 + + op = 1 # copy until EOS or next delimiter + while (expr[ip] != EOS && expr[ip] != ';' && expr[ip] != ']') { + subex[op] = expr[ip] + ip = ip + 1 + op = op + 1 + } + subex[op] = EOS + + if (expr[ip] == ']') + ip = ip + 1 + + return (ip) +end + + +# IMX_EXPR_TYPE -- Determine the type of expression we have. A range list +# is assumed to be an extension index list; a single alphabetic word is +# assumed to be an extension name, if followed by a numeric value it also +# contains an extension version; anything else is a selection expression. + +int procedure imx_expr_type (expr) + +char expr[ARB] #i expression + +int ip, len +char ch +int strlen (), stridxs(), stridx() + +begin + len = strlen (expr) + + # [] + ch = expr[1] + if ((IS_ALNUM(expr[1]) || stridx (ch, "('\"") > 0) && + stridxs ("?=:()<>&|@", expr) != 0) + return (IMT_EXPR) + + # [extname,extver] + ch = ',' + if (IS_ALPHA(expr[1]) && IS_DIGIT(expr[len]) && stridx (ch, expr) > 0) + return (IMT_VER) + + # [extname] + if (IS_ALPHA(expr[1]) && stridx (ch, expr) == 0) + return (IMT_NAME) + + # [index] or [index_range] + if ((IS_DIGIT(expr[1])) || + ((expr[1] == '+' || expr[1] == '-') && IS_DIGIT(expr[2]))) { + for (ip=1; expr[ip] != EOS; ip = ip + 1) { + ch = expr[ip] + if (! IS_DIGIT(ch)) { + if (stridx (ch, "-x,+") == 0) + return (IMT_EXPR) + } + } + return (IMT_INDEX) + } + + return (0) +end diff --git a/sys/imio/imt/imxpreproc.x b/sys/imio/imt/imxpreproc.x new file mode 100644 index 00000000..b0faccfc --- /dev/null +++ b/sys/imio/imt/imxpreproc.x @@ -0,0 +1,539 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imx.h" + +define DEBUG FALSE +define SZ_PREFIX 2 + + +pointer procedure imx_preproc (template) + +char template[ARB] #i input template string + +pointer exp, pre, out, op, list +char file[SZ_PATHNAME] +char mods[SZ_LINE], fname[SZ_LINE] +int i, j, osize, len, llen, nmods + +define output {Memc[out+op]=$1;op=op+1} +define outstr {len=strlen($1);for(j=1;j<=len;j=j+1)output($1[j])} +define outcomma {if(($1))output(',')} + +pointer imx_fnexpand (), imx_preproc_list() +pointer fntopnb() +int fntlenb(), fntgfnb(), strlen(), strsearch(), strncmp(), imx_split() + +begin + # First Pass: Do any filename expansion in the template, maintaining + # the '@' prefix and any modifiers. The result is a comma-delimited + # list we process later to expand further. + + exp = imx_fnexpand (template) + + # Second Pass: Process the matched list to expand the '@' files and + # modifiers into a simple comma-delimited list the FNT interface + # will process. + + pre = imx_preproc_list (Memc[exp]) + + # Third Pass: Handle concatenation in the filenames. + if ((strncmp (Memc[pre],"http://",7) == 0) || + (strncmp (Memc[pre],"file://",7) == 0)) { + osize = strlen (Memc[pre]) + call calloc (out, osize, TY_CHAR) + call strcpy (Memc[pre], Memc[out], osize) + + } else if (strsearch(Memc[pre],"//") > 0 && + strsearch(Memc[pre],".fits") > 0) { + + # FIXME -- Need to handle the case of concatenation with + # a MEF file. Problem is, expanding the MEF requires we + # recursively call ourselves to expand the image so we + # need to do some restructuring. For example, + # + # foo // @mef.fits -> foomef.fits[1],foomef.fits[2], .... + # @mef.fits // foo -> meffoo.fits[1],meffoo.fits[2], .... + + call error (0, "Image expansion/concatenation not yet supported.") + + + } else if (strsearch (Memc[pre], "//") > 0) { + + nmods = imx_split (Memc[pre], fname, mods, SZ_LINE) + list = fntopnb (fname, YES) + llen = fntlenb (list) + + osize = strlen (Memc[pre]) + call calloc (out, osize * 2, TY_CHAR) + + op = 0 + for (i=0; i < llen; i=i+1) { + call aclrc (file, SZ_PATHNAME) + if (fntgfnb (list, file, SZ_PATHNAME) == EOF) + break + + if ((op + strlen (file) + strlen (mods) + 3) >= osize) { + osize = osize + SZ_LINE + call realloc (out, osize, TY_CHAR) + } + + # FIXME ??? + #outcomma (i > 0); output ('@'); outstr(file) ; outstr(mods) + outcomma (i > 0); outstr(file) ; outstr(mods) + } + output ('\0') + call fntclsb (list) + + } else { + osize = strlen (Memc[pre]) + call calloc (out, osize, TY_CHAR) + call strcpy (Memc[pre], Memc[out], osize) + } + + if (DEBUG) { + call eprintf ("pre exp = '%s'\n") ; call pargstr (Memc[exp]) + call eprintf ("pre pre = '%s'\n") ; call pargstr (Memc[pre]) + call eprintf ("pre out = '%s'\n") ; call pargstr (Memc[out]) + } + + call mfree (exp, TY_CHAR) # clean up + call mfree (pre, TY_CHAR) + + return (out) +end + + +# IMX_FNEXPAND -- Do any filename expansion in the template, maintaining the +# '@' prefix and any modifiers. The result is a comma-delimited list we +# process later to expand further. + +pointer procedure imx_fnexpand (template) + +char template[ARB] #i input template string + +pointer elem, ep, op, out, listp, sz_out, op_start, op_end +int i, j, ip, in, len, llen, nelem, fi, fo +char prefix[SZ_PREFIX], fname[SZ_PATHNAME], mods[SZ_LINE] +char left[SZ_PATHNAME], right[SZ_PATHNAME] +char file[SZ_PATHNAME], cfname[SZ_PATHNAME], osfn[SZ_PATHNAME] + +define output {Memc[op]=$1;op=op+1} +define outstr {len=strlen($1);for(j=1;j<=len;j=j+1)output($1[j])} + +int fntopnb(), fntgfnb(), fntlenb(), strlen(), stridxs(), strsearch() +int imx_get_element(), strncmp(), stridx() + +begin + # Allocate an intial string buffer. + call calloc (out, SZ_FNT, TY_CHAR) + call calloc (elem, SZ_FNT, TY_CHAR) + + in = 1 + nelem = 0 + op = out + op_start = out + op_end = out + SZ_FNT - 1 + sz_out = SZ_FNT + + while (imx_get_element (template, in, Memc[elem], SZ_FNT) != EOS) { + + ep = elem + nelem = nelem + 1 + outcomma(nelem > 1) + + call aclrc (prefix, SZ_PREFIX) + call aclrc (fname, SZ_PATHNAME) + call aclrc (mods, SZ_LINE) + + # Gather any prefix '@' symbols. + if (Memc[elem] == '@') { + for (i=1; Memc[ep] == '@'; i=i+1) { + prefix[i] = Memc[ep] + ep = ep + 1 + } + } else { + ip = stridx ('@', Memc[elem]) + if (ip > 1) { + call strcpy (Memc[elem], prefix, ip-1) + ep = elem + ip - 1 + prefix[ip] = EOS + call strcat ("//", prefix[ip], SZ_PREFIX) + } + } + + # Get the filename component up to the EOS or the modifiers. + for (i=1; Memc[ep] != '[' && Memc[ep] != EOS; i=i+1) { + fname[i] = Memc[ep] + ep = ep + 1 + } + + if (strncmp ("http://", fname, 7) == 0) { + call fmapfn ("cache$", osfn, SZ_PATHNAME) + call strupk (osfn, osfn, SZ_PATHNAME) + + #call fcadd (osfn, fname, "fits", cfname, SZ_PATHNAME) + call fcadd (osfn, fname, "", cfname, SZ_PATHNAME) + + call strcpy (cfname, fname, SZ_PATHNAME) + + } else if (strncmp ("file://", fname, 7) == 0) { + fi = 8 + if (strncmp ("file:///localhost", fname, 17) == 0) + fi = 18 + else if (strncmp ("file://localhost", fname, 16) == 0) + fi = 17 + + for (fo=1; fname[fi] != EOS; fi=fi+1) { + if (fname[fi] == '/' && fname[fi+1] == '/') + fi = fi + 1 + cfname[fo] = fname[fi] + fo = fo + 1 + } + call strcpy (cfname, fname, SZ_PATHNAME) + } + + # Get the modifier strings. + for (i=1; Memc[ep] != EOS ; i=i+1) { + mods[i] = Memc[ep] + ep = ep + 1 + } + + + if (DEBUG) { + call eprintf ("fnexp: '%s' --> '%s' '%s' '%s'\n") + call pargstr (Memc[elem]); call pargstr (prefix); + call pargstr (fname); call pargstr (mods) + } + + # Expand wildcards if needed. + if (stridxs("*?", fname) > 0) { + + # FIXME - Need to do concatenation here ...?? + if (strsearch (fname, "//") > 0) { + call aclrc (left, SZ_PATHNAME) + call aclrc (right, SZ_PATHNAME) + + # Gather the left and right side of a concatenation with + # wildcards. Expand the side with the wildcard but + # maintain the concatenation so we keep the previous + # behavior in how these processed. + for (ip=1; fname[ip] != '/'; ip=ip+1) + left[ip] = fname[ip] + ip = ip + 2 + for (i=1; fname[ip] != EOS; ip=ip+1) { + right[i] = fname[ip] + i = i + 1 + } + + if (stridxs("*?", left) > 0) { + listp = fntopnb (left, YES) + llen = fntlenb (listp) + for (i=0; i < llen; i=i+1) { + call aclrc (file, SZ_PATHNAME) + if (fntgfnb (listp, file, SZ_PATHNAME) == EOF) + break + outcomma (i > 0) + outstr(prefix) + outstr(file) ; outstr("//") ; outstr(right) + } + call fntclsb (listp) + } else { + listp = fntopnb (right, YES) + llen = fntlenb (listp) + for (i=0; i < llen; i=i+1) { + call aclrc (file, SZ_PATHNAME) + if (fntgfnb (listp, file, SZ_PATHNAME) == EOF) + break + outcomma (i > 0) + outstr(prefix) + outstr(left) ; outstr("//") ; outstr(file) + } + call fntclsb (listp) + } + next + + } else { + listp = fntopnb (fname, YES) + llen = fntlenb (listp) + for (i=0; i < llen; i=i+1) { + call aclrc (file, SZ_PATHNAME) + if (fntgfnb (listp, file, SZ_PATHNAME) == EOF) + break + outcomma ( i > 0) + outstr(prefix) ; outstr(file) ; outstr(mods) + + + # Reallocate the output string if needed. + if ((op_end - op) < SZ_FNAME || op >= op_end) { + sz_out = sz_out + SZ_FNT + len = (op - out - 1) + + call calloc (op_start, sz_out, TY_CHAR) + call amovc (Memc[out], Memc[op_start], len) + for (op=op_start; Memc[op] != EOS; ) + op = op + 1 + + op_end = op_start + sz_out + call mfree (out, TY_CHAR) + out = op_start + } + } + call fntclsb (listp) + } + + + } else { + outstr(prefix) ; outstr(fname) ; outstr(mods) + } + + call aclrc (Memc[elem], SZ_FNT) + } + output ('\0') + + call mfree (elem, TY_CHAR) + return (out) +end + + +# IMX_PREPROC_LIST -- Process the expanded filename string to open any +# @files and produce final expression strings. + +pointer procedure imx_preproc_list (template) + +char template[ARB] #i template string + +pointer tp, ip, op, itp, listp, elem +int i, lp, in, len, tend, tlen, plen, llen +int nchars, atat, nelem, in_filter +char ch, file[SZ_LINE], expr[SZ_LINE], fname[SZ_PATHNAME] +char ikparams[SZ_LINE], sec[SZ_LINE], dirname[SZ_PATHNAME] + +define output {Memc[op]=$1;op=op+1} + +int fntopnb(), fntgfnb(), fntlenb(), strlen(), stridxs(), strsearch() +int access(), imx_get_element(), imx_breakout(), isdirectory() + +begin + # Allocate an intial string buffer. + tlen = strlen (template) + plen = max(strlen(template)*2, SZ_FNT) + call calloc (tp, plen, TY_CHAR) + call calloc (itp, tlen + 1, TY_CHAR) + call calloc (elem, SZ_FNT, TY_CHAR) + + in = 1 + op = tp + nelem = 0 + while (imx_get_element (template, in, Memc[elem], SZ_FNT) != EOS) { + + # Break out the filename and expression. + nchars = imx_breakout (Memc[elem], NO, file, expr, + sec, ikparams, SZ_LINE) + + nelem = nelem + 1 + outcomma (nelem > 1) + + atat = NO + call aclrc (Memc[itp], tlen+1) + + if (stridxs("[]", Memc[elem]) > 0 && expr[1] != EOS) { + if (Memc[elem] == '@' || strsearch (Memc[elem], "//") > 0) + call sprintf (Memc[itp], tlen+1, "%s") + else + call sprintf (Memc[itp], tlen+1, "@%s") + call pargstr (Memc[elem]) + + } else if (strsearch (Memc[elem], "][") > 0) { + call sprintf (Memc[itp], tlen+1, "@%s") + call pargstr (Memc[elem]) + + } else { + # Simple filename or @file, just copy it out if it exists. + if (Memc[elem] == '@') { + if (Memc[elem+1] != '@' && access (Memc[elem+1],0,0) == NO) + if (strsearch (Memc[elem], "//") == 0) + next + if (Memc[elem+1] == '@') { + lp = 1 + atat = YES + call sprintf (Memc[itp], tlen+1, "%s") + call pargstr (Memc[elem]) + } else { + lp = 0 + for (; Memc[elem+lp] != EOS; lp=lp+1) + output (Memc[elem+lp]) + next + } + } else { + lp = 0 + for (; Memc[elem+lp] != EOS; lp=lp+1) + output (Memc[elem+lp]) + } + } + + ip = itp + tend = itp + strlen (Memc[itp]) - 1 + ch = Memc[ip] + + if (ch == '@') { # @file + + if (Memc[ip+1] == '@') { # @@file + atat = YES + ip = ip + 1 + } + + if (atat == NO) { + # No metachars, copy item entirely to output string. + in_filter = NO + while (Memc[ip] != EOS && ip <= tend) { + if (Memc[ip] == '[') in_filter = YES + if (Memc[ip] == ']') in_filter = NO + if (Memc[ip] == ',' && in_filter == NO) { + output (Memc[ip]) + ip = ip + 1 + break + } + output (Memc[ip]) + ip = ip + 1 + } + next + } + + if (atat == YES) { + if (isdirectory (file[3], dirname, SZ_PATHNAME) > 0) { + len = strlen (file) + if (file[len] != '$') + call strcat ("/", file, SZ_FNAME) + call strcat ("*.fits", file, SZ_FNAME) + listp = fntopnb (file[3], YES) + } else + listp = fntopnb (file[2], YES) + } else + listp = fntopnb (file, YES) + + llen = fntlenb (listp) + for (i=0; i < llen; i=i+1) { + call aclrc (fname, SZ_PATHNAME) + if (fntgfnb (listp, fname, SZ_PATHNAME) == EOF) + break + + if (atat == YES) + output ('@') + for (lp=1; fname[lp] != EOS; lp=lp+1) + output (fname[lp]) + if (expr[1] != EOS) { # append extension info + output ('[') + for (lp=1; expr[lp] != EOS; lp=lp+1) + output (expr[lp]) + if (ikparams[1] != EOS) { + output (',') + for (lp=1; ikparams[lp] != EOS; lp=lp+1) + output (ikparams[lp]) + } + output (']') + } + if (sec[1] != EOS) { # append any section notation + output ('[') + for (lp=1; sec[lp] != EOS; lp=lp+1) + output (sec[lp]) + output (']') + } + + outcomma (i < (llen-1)) + } + call fntclsb (listp) + ip = ip + nchars + 1 + + if (Memc[ip+1] == ',') + break + } # else + # call strcpy (Memc[elem], Memc[op], SZ_FNT) + } + + call mfree (itp, TY_CHAR) + call mfree (elem, TY_CHAR) + + return (tp) +end + + +# IMX_GET_ELEMENT -- Get the next element of a list template. + +int procedure imx_get_element (template, ip, elem, maxch) + +char template[ARB] #i input template string +int ip #u template index +char elem[ARB] #o output string buffer +int maxch #i max size of output element + +int op, level, done +char ch + +begin + op = 1 + done = 0 + level = 0 + + if (template[ip] == EOS) + return (EOS) + if (template[ip] == ',') + ip = ip + 1 + + call aclrc (elem, maxch) + while (template[ip] != EOS) { + ch = template[ip] + + if (ch == EOS || (ch == ',' && level == 0)) { + done = 1 + } else if (ch == '[') + level = level + 1 + else if (ch == ']') + level = level - 1 + + if (done == 1) { + return (ip + 1) + } else + elem[op] = ch + + ip = ip + 1 + op = op + 1 + } + + return (ip) +end + + +# IMX_SPLIT -- Split a list element into the coarse filename and modifiers + +int procedure imx_split (in, fname, mods, maxch) + +char in[ARB] #i input template string +char fname[ARB] #o filename +char mods[ARB] #o modifier strings +int maxch #i max size of output string + +int i, j, nmods + +begin + # Allocate an intial string buffer. + nmods = 0 + call aclrc (mods, maxch) + call aclrc (fname, maxch) + + + # Gather any prefix '@' symbols. + for (i=1; in[i] != '[' && in[i] != EOS && i < maxch; i=i+1) + fname[i] = in[i] + + # Get the filename component up to the EOS or the modifiers. + if (in[i] == '[') { + for (j=1; in[i] != EOS && i < maxch && j < maxch; i=i+1) { + mods[j] = in[i] + j = j + 1 + if (in[i] == '[') + nmods = nmods + 1 + } + } + + return (nmods) +end diff --git a/sys/imio/imt/mkpkg b/sys/imio/imt/mkpkg new file mode 100644 index 00000000..eca1a520 --- /dev/null +++ b/sys/imio/imt/mkpkg @@ -0,0 +1,24 @@ +# Update the IMIO portion of the LIBEX library. + +$checkout libex.a ../ +$update libex.a +$checkin libex.a ../ +$exit + +libex.a: + imt.x + imx.x imx.h + imxbreakout.x + imxparse.x imx.h + imxescape.x imx.h + imxexpand.x imx.h + imxexpr.x imx.h + imxftype.x imx.h + imxpreproc.x imx.h + ; + +test: + $call libpkg.a + $omake zzdebug.x + $link zzdebug.o libpkg.a + ; diff --git a/sys/imio/imt/t_urlget.x b/sys/imio/imt/t_urlget.x new file mode 100644 index 00000000..e0e7bf26 --- /dev/null +++ b/sys/imio/imt/t_urlget.x @@ -0,0 +1,94 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +task urlget = t_urlget + + + +# URLGET -- Do an HTTP GET of a URL to the named file. + +procedure t_urlget () + +pointer reply +char url[SZ_PATHNAME], fname[SZ_PATHNAME], extn[SZ_PATHNAME] +char cache[SZ_PATHNAME], lfname[SZ_PATHNAME] +int nread +bool use_cache, verbose + +int url_get() +bool fcaccess() + +begin + # Get the parameters + call clgstr ("url", url, SZ_PATHNAME) + + call url_to_name (url, fname, SZ_PATHNAME) + call strcpy ("", extn, SZ_PATHNAME) + call strcpy ("/tmp/cache/", cache, SZ_PATHNAME) + verbose = true + use_cache = false + + + # Tell them what we're doing. + if (verbose) { + call printf ("%s -> %s\n") + call pargstr (url) + call pargstr (fname) + call flush (STDOUT) + } + + # Retrieve the URL. + if (use_cache) { + call aclrc (lfname, SZ_FNAME); + + if (fcaccess (cache, url, "fits")) { + call fcname (cache, url, "f", lfname, SZ_PATHNAME) + if (extn[1] != EOS) { + # Add an extension to the cached file. + call strcat (".", lfname, SZ_PATHNAME) + call strcat (extn, lfname, SZ_PATHNAME) + } + } else { + # Add it to the cache, also handles the download. + call fcadd (cache, url, extn, lfname, SZ_PATHNAME) + } + call fcopy (lfname, fname) + + } else { + # Not in cache, or not using the cache, so force the download. + call calloc (reply, SZ_LINE, TY_CHAR) + nread = url_get (url, fname, reply) + call mfree (reply, TY_CHAR) + } +end + + +# URL_TO_NAME -- Generate a filename from a URL. + +procedure url_to_name (url, name, maxch) + +char url[ARB] #i URL being accessed +char name[ARB] #o output name +int maxch #i max size of output name + +int ip, strlen() +char ch + +begin + ip = strlen (url) + while (ip > 1) { + ch = url[ip] + if (ch == '/' || ch == '?' || ch == '&' || ch == ';' || ch == '=') { + call strcpy (url[ip+1], name, maxch) + return + } + ip = ip - 1 + } + + call strcpy (url[ip], name, maxch) +end diff --git a/sys/imio/imt/zzdebug.x b/sys/imio/imt/zzdebug.x new file mode 100644 index 00000000..746fc6f1 --- /dev/null +++ b/sys/imio/imt/zzdebug.x @@ -0,0 +1,227 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include "imx.h" + + +task imt = t_imt, + parse = t_parse, + fnexpand = t_fnexpand, + prelist = t_prelist, + preproc = t_preproc, + breakout = t_breakout, + imexpand = t_imexpand, + fexpand = t_fexpand + + + +# IMT -- Test the image template package. + +procedure t_imt () + +char template[SZ_LINE] +char image[SZ_FNAME] + +pointer imt, im, imtopen(), immap() +int i, imtgetim() +bool num, clgetb() + +begin + call clgstr ("in", template, SZ_LINE) + num = clgetb ("number") + + imt = imtopen (template) + + for (i=0; imtgetim (imt, image, SZ_FNAME) != EOF; i=i+1) { + + if (num) { + im = immap (image, READ_ONLY, 0) + call printf ("%3d %s %d x %d\n") + call pargi (i+1) + call pargstr (image) + call pargi (IM_LEN(im,1)) + call pargi (IM_LEN(im,2)) + call imunmap (im) + } else { + if (i > 0) + call printf (",") + call printf ("%s") + call pargstr (image) + } + } + call printf ("\n") + call printf ("Nimages = %d\n") + call pargi (i) + + call imtclose (imt) +end + + +# PARSE -- Test the image template package expression parse. + +procedure t_parse () + +char template[SZ_LINE], name[SZ_LINE], index[SZ_LINE], ikparams[SZ_LINE] +char extname[SZ_LINE], extver[SZ_LINE], expr[SZ_LINE], sec[SZ_LINE] + +int nch, imx_parse() + +begin + call clgstr ("in", template, SZ_LINE) + + nch = imx_parse (template, name, index, extname, extver, + expr, sec, ikparams, SZ_LINE) + + call eprintf ("%s\n") ; call pargstr (template) + call eprintf ("\tname\t= %s\n") ; call pargstr (name) + call eprintf ("\tindex\t= %s\n") ; call pargstr (index) + call eprintf ("\textname\t= %s\n") ; call pargstr (extname) + call eprintf ("\textver\t= %s\n") ; call pargstr (extver) + call eprintf ("\texpr\t= %s\n") ; call pargstr (expr) + call eprintf ("\tikparams\t= %s\n") ; call pargstr (ikparams) + call eprintf ("\tsec\t= %s\n") ; call pargstr (sec) +end + + +# FNEXPAND -- Test the image template package pre-processor. + +procedure t_fnexpand () + +char template[SZ_LINE] + +pointer pp, imx_fnexpand() + +begin + call clgstr ("in", template, SZ_LINE) + + pp = imx_fnexpand (template) + + call eprintf ("%s\n") + call pargstr (Memc[pp]) + call mfree (pp, TY_CHAR) +end + + +# PRELIST -- Test the image template package pre-processor. + +procedure t_prelist () + +char template[SZ_LINE] + +pointer pp, imx_preproc_list() + +begin + call clgstr ("in", template, SZ_LINE) + + pp = imx_preproc_list (template) + + call eprintf ("%s\n") + call pargstr (Memc[pp]) + call mfree (pp, TY_CHAR) +end + + +# PREPROC -- Test the image template package pre-processor. + +procedure t_preproc () + +char template[SZ_LINE] + +pointer pp, imx_preproc() + +begin + call clgstr ("in", template, SZ_LINE) + + pp = imx_preproc (template) + + call eprintf ("%s\n") + call pargstr (Memc[pp]) + call mfree (pp, TY_CHAR) +end + + +# BREAKOUT -- Test the image template package expression breakout code. + +procedure t_breakout () + +char template[SZ_LINE] + +int nchars +char image[SZ_LINE], expr[SZ_LINE], sec[SZ_LINE], ikparams[SZ_LINE] + +int imx_breakout() + +begin + call clgstr ("in", template, SZ_LINE) + + nchars = imx_breakout(template, NO, image, expr, sec, ikparams, SZ_LINE) + + call eprintf ("nchars=%d image='%s' expr='%s' sec='%s' ik='%s'\n") + call pargi (nchars) + call pargstr (image) + call pargstr (expr) + call pargstr (sec) + call pargstr (ikparams) +end + + +# IMEXPAND -- Test the MEF image expansion. + +procedure t_imexpand () + +char template[SZ_LINE] +int nimages + +pointer imt, imx_imexpand() + +begin + call clgstr ("in", template, SZ_LINE) + + imt = imx_imexpand (template, + "", # expr + "", # index + "", # extname + "", # extver + "", # ikparams + "", # sections + nimages) + + call printf ("nimages = %d\n%s\n"); + call pargi (nimages) + call pargstr (Memc[imt]) + + call mfree (imt, TY_CHAR) +end + + +# FEXPAND -- Test the filename expansion. + +procedure t_fexpand () + +char template[SZ_LINE] +int nimages + +pointer imt, imx_fexpand() + +begin + call clgstr ("in", template, SZ_LINE) + + imt = imx_fexpand (template, + "", # expr + "", # index + "", # extname + "", # extver + "", # ikparams + "", # sections + nimages) + + call printf ("nimages = %d\n%s\n"); + call pargi (nimages) + call pargstr (Memc[imt]) + + call mfree (imt, TY_CHAR) +end diff --git a/sys/imio/imunmap.x b/sys/imio/imunmap.x new file mode 100644 index 00000000..dd2290b1 --- /dev/null +++ b/sys/imio/imunmap.x @@ -0,0 +1,61 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMUNMAP -- Unmap a image. Flush the output buffer, append the bad pixel +# list, update the image header. Close all files and return buffer space. + +procedure imunmap (im) + +pointer im + +int acmode +errchk imflush, close, imerr, iki_updhdr + +begin + acmode = IM_ACMODE(im) + + # Note that if no pixel i/o occurred, the pixel storage file will + # never have been opened or created. + + if (IM_PFD(im) != NULL) + call imflush (im) + + # Update the image header, if necessary (count of bad pixels, + # minimum and maximum pixel values, etc.). + + if (IM_UPDATE(im) == YES) { + if (acmode == READ_ONLY) + call imerr (IM_NAME(im), SYS_IMUPIMHDR) + + # Restore those fields of the image header that may have been + # modified to map a section (if accessing an existing image). + + switch (acmode) { + case NEW_COPY, NEW_IMAGE: + ; # Cannot access section of new image + default: + IM_NDIM(im) = IM_NPHYSDIM(im) + IM_MTIME(im) = IM_SVMTIME(im) + call amovl (IM_SVLEN(im,1), IM_LEN(im,1), IM_NDIM(im)) + } + + # Update the image header or mask storage file. + call iki_updhdr (im) + } + + # Physically close the image. + call iki_close (im) + + # If the image is a mask image and the PL_CLOSEPL flag is set, close + # the associated mask. + + if (IM_PL(im) != NULL && and(IM_PLFLAGS(im),PL_CLOSEPL) != 0) + call pl_close (IM_PL(im)) + + # Free all buffer space allocated by IMIO. + call imrmbufs (im) + call mfree (im, TY_STRUCT) +end diff --git a/sys/imio/imupk.gx b/sys/imio/imupk.gx new file mode 100644 index 00000000..a637e39d --- /dev/null +++ b/sys/imio/imupk.gx @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMUPK? -- Convert an array of pixels of datatype DTYPE into the datatype +# specified by the IMUPK? suffix character. + +procedure imupk$t (a, b, npix, dtype) + +PIXEL b[npix] +int a[npix], npix, dtype + +pointer bp + +begin + switch (dtype) { + case TY_USHORT: + call achtu$t (a, b, npix) + case TY_SHORT: + call achts$t (a, b, npix) + case TY_INT: + call achti$t (a, b, npix) + case TY_LONG: + call achtl$t (a, b, npix) + case TY_REAL: + call achtr$t (a, b, npix) + case TY_DOUBLE: + call achtd$t (a, b, npix) + case TY_COMPLEX: + call achtx$t (a, b, npix) + default: + call error (1, "Unknown datatype in imagefile") + } +end + + diff --git a/sys/imio/imwbpx.x b/sys/imio/imwbpx.x new file mode 100644 index 00000000..23794c89 --- /dev/null +++ b/sys/imio/imwbpx.x @@ -0,0 +1,97 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMWBPX -- Write a line segment from an image with boundary extension. The +# line segment is broken up into three parts, i.e., left, center, and right. +# The left and right (out of bounds) regions are discarded, and the center +# region, if any, is written to the image. Inbounds data is conserved if a +# subraster which extends out of bounds is read and then rewritten, i.e., +# a read followed immediately by a rewrite of the same data does not modify +# the image. + +procedure imwbpx (im, ibuf, totpix, v, vinc) + +pointer im # image descriptor +char ibuf[ARB] # typeless buffer containing the data +int totpix # total number of pixels to write +long v[ARB] # vector pointer to start of line segment +long vinc[ARB] # step on each axis + +bool oob +int npix, ndim, sz_pixel, btype, ip, xstep, step, i +long xs[3], xe[3], x1, x2, p, v1[IM_MAXDIM], v2[IM_MAXDIM], linelen +errchk imwrpx +include + +begin + sz_pixel = pix_size[IM_PIXTYPE(im)] + ndim = IM_NPHYSDIM(im) + + # Flip the input array if the step size in X is negative. + if (vinc[1] < 0) + call imaflp (ibuf, totpix, sz_pixel) + + # Cache the left and right endpoints of the line segment and the + # image line length. + + xstep = abs (IM_VSTEP(im,1)) + linelen = IM_SVLEN(im,1) + x1 = v[1] + x2 = x1 + (totpix * xstep) - 1 + + # Compute the endpoints of the line segment in the three x-regions of + # the image. + + xs[1] = x1 # left oob region + xe[1] = min (0, x2) + xs[2] = max (x1, 1) # central inbounds region + xe[2] = min (x2, linelen) + xs[3] = max (x1, linelen + 1) # right oob region + xe[3] = x2 + + # Perform bounds mapping on the entire vector. The mapping for all + # dimensions higher than the first is invariant in what follows. + + call imbtran (im, v, v1, ndim) + + # Copy V1 to V2 and determine if the whole thing is out of bounds. + oob = false + do i = 2, ndim { + p = v1[i] + v2[i] = p + if (p < 1 || p > IM_SVLEN(im,i)) + oob = true + } + + btype = IM_VTYBNDRY(im) + ip = 1 + + do i = 1, 3 { + # Skip to next region if there are no pixels in this region. + npix = (xe[i] - xs[i]) / xstep + 1 + if (npix <= 0) + next + + # Map the endpoints of the segment. + call imbtran (im, xs[i], v1[1], 1) + call imbtran (im, xe[i], v2[1], 1) + + # Compute the starting vector V1, step in X, and the number of + # pixels in the region allowing for subsampling. + + if (v1[1] > v2[1]) { + step = -xstep + v1[1] = v2[1] + } else + step = xstep + + # Write the pixels if inbounds. + if (i == 2 && !oob) + call imwrpx (im, ibuf[ip], npix, v1, step) + + ip = ip + (npix * sz_pixel) + } +end diff --git a/sys/imio/imwrite.x b/sys/imio/imwrite.x new file mode 100644 index 00000000..724de8d7 --- /dev/null +++ b/sys/imio/imwrite.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +define SZ_ZBUF 50 + +# IMWRITE -- Write data to the pixel storage file. Bounds checking has +# already been performed by the time IMWRITE is called. If writing beyond +# EOF (new image), write zeros until the indicated offset is reached. + +procedure imwrite (imdes, buf, nchars, offset) + +pointer imdes +char buf[ARB] +int nchars +long offset + +int fd +char zbuf[SZ_ZBUF] +long start, i +long fstatl() +errchk write, seek, fstatl +data zbuf /SZ_ZBUF*0,0/ + +begin + fd = IM_PFD(imdes) + + # Get file size. If writing beyond end of file (file_size+1), + # write out blocks of zeros until the desired offset is reached. + # The IM_FILESIZE parameter in the image descriptor is not always + # up to date, but does provide a lower bound on the size of the pixel + # storage file. + + if (offset >= IM_FILESIZE(imdes)) + IM_FILESIZE(imdes) = fstatl (fd, F_FILESIZE) + + if (offset-1 <= IM_FILESIZE(imdes)) { + # Write within bounds of file, or at EOF. + + call seek (fd, offset) + call write (fd, buf, nchars) + + } else { + # Write beyond EOF. + + IM_FILESIZE(imdes) = fstatl (fd, F_FILESIZE) + start = IM_FILESIZE(imdes) + 1 + + call seek (fd, start) + do i = start, offset, SZ_ZBUF + call write (fd, zbuf, min (SZ_ZBUF, offset-i)) + + call write (fd, buf, nchars) + IM_FILESIZE(imdes) = fstatl (fd, F_FILESIZE) + } +end diff --git a/sys/imio/imwrpx.x b/sys/imio/imwrpx.x new file mode 100644 index 00000000..3cdd2971 --- /dev/null +++ b/sys/imio/imwrpx.x @@ -0,0 +1,139 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +# IMWRPX -- Write NPIX pixels, starting with the pixel at the coordinates +# specified by the vector V, from the buffer BUF to the pixel storage file. + +procedure imwrpx (im, buf, npix, v, xstep) + +pointer im # image descriptor +char buf[ARB] # generic buffer containing data to be written +int npix # number of pixels to be written +long v[ARB] # physical coords of first pixel to be written +int xstep # step size between output pixels + +bool rlio +long offset +pointer pl, sp, ibuf +long o_v[IM_MAXDIM] +int sz_pixel, sz_dtype, nbytes, nchars, ip, step + +int sizeof() +long imnote() +errchk imerr, imwrite +include + +begin + pl = IM_PL(im) + sz_dtype = sizeof (IM_PIXTYPE(im)) + sz_pixel = pix_size[IM_PIXTYPE(im)] + step = abs (xstep) + if (v[1] < 1 || ((npix-1) * step) + v[1] > IM_SVLEN(im,1)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + # Flip the pixel array end for end. + if (xstep < 0) + #call imaflp (buf, npix, sz_dtype) + call imaflp (buf, npix, sz_pixel) + + # Byte swap if necessary. + if (IM_SWAP(im) == YES) { + nbytes = npix * sz_dtype * SZB_CHAR + switch (sz_dtype * SZB_CHAR) { + case 2: + call bswap2 (buf, 1, buf, 1, nbytes) + case 4: + call bswap4 (buf, 1, buf, 1, nbytes) + case 8: + call bswap8 (buf, 1, buf, 1, nbytes) + } + } + + + if (pl != NULL) { + + # Need to unpack again on 64-bit systems. + if ((IM_PIXTYPE(im) == TY_INT || IM_PIXTYPE(im) == TY_LONG) && + SZ_INT != SZ_INT32) { + call iupk32 (buf, buf, npix) + } + + # Write to a pixel list. + rlio = (and (IM_PLFLAGS(im), PL_FAST+PL_RLIO) == PL_FAST+PL_RLIO) + call amovl (v, o_v, IM_MAXDIM) + nchars = npix * sz_pixel + + switch (IM_PIXTYPE(im)) { + case TY_SHORT: + if (rlio) + call pl_plrs (pl, v, buf, 0, npix, PIX_SRC) + else if (step == 1) + call pl_plps (pl, v, buf, 0, npix, PIX_SRC) + else { + do ip = 1, nchars, sz_pixel { + call pl_plpi (pl, o_v, buf[ip], 0, 1, PIX_SRC) + o_v[1] = o_v[1] + step + } + } + case TY_INT, TY_LONG: + if (rlio) + call pl_plri (pl, v, buf, 0, npix, PIX_SRC) + else if (step == 1) + call pl_plpi (pl, v, buf, 0, npix, PIX_SRC) + else { + do ip = 1, nchars, sz_pixel { + call pl_plpi (pl, o_v, buf[ip], 0, 1, PIX_SRC) + o_v[1] = o_v[1] + step + } + } + default: + call smark (sp) + call salloc (ibuf, npix, TY_INT) + + call acht (buf, Memi[ibuf], npix, IM_PIXTYPE(im), TY_INT) + if (rlio) + call pl_plri (pl, v, Memi[ibuf], 0, npix, PIX_SRC) + else if (step == 1) + call pl_plpi (pl, v, Memi[ibuf], 0, npix, PIX_SRC) + else { + do ip = 1, npix { + call pl_plpi (pl, o_v, Memi[ibuf+ip-1], 0, 1, PIX_SRC) + o_v[1] = o_v[1] + step + } + } + call sfree (sp) + } + + } else { + # Write to a file. Compute size of transfer. If transferring + # an entire line, increase size of transfer to the physical line + # length, to avoid having to enblock the data. NOTE: buffer must + # be large enough to guarantee no memory violation. + + offset = imnote (im, v) + + # If not subsampling (stepsize 1), write buffer to file in a + # single transfer. Otherwise, the pixels are not contiguous, + # and must be written individually. + + if (step == 1) { + if (v[1] == 1 && npix == IM_SVLEN(im,1)) + nchars = IM_PHYSLEN(im,1) * sz_pixel + else + nchars = npix * sz_pixel + call imwrite (im, buf, nchars, offset) + + } else { + nchars = npix * sz_pixel + for (ip=1; ip <= nchars; ip=ip+sz_pixel) { + call imwrite (im, buf[ip], sz_pixel, offset) + offset = offset + (sz_pixel * step) + } + } + } +end diff --git a/sys/imio/mkpkg b/sys/imio/mkpkg new file mode 100644 index 00000000..9daec830 --- /dev/null +++ b/sys/imio/mkpkg @@ -0,0 +1,106 @@ +# Update the IMIO portion of the LIBEX library. + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +tfiles: + $set GFLAGS = "-k -t silrdx -p tf/" + $ifolder (tf/imupkr.x, imupk.gx) $generic $(GFLAGS) imupk.gx $endif + $ifolder (tf/imps3r.x, imps3.gx) $generic $(GFLAGS) imps3.gx $endif + $ifolder (tf/imps2r.x, imps2.gx) $generic $(GFLAGS) imps2.gx $endif + $ifolder (tf/imps1r.x, imps1.gx) $generic $(GFLAGS) imps1.gx $endif + $ifolder (tf/impnlr.x, impnl.gx) $generic $(GFLAGS) impnl.gx $endif + $ifolder (tf/impl3r.x, impl3.gx) $generic $(GFLAGS) impl3.gx $endif + $ifolder (tf/impl2r.x, impl2.gx) $generic $(GFLAGS) impl2.gx $endif + $ifolder (tf/impl1r.x, impl1.gx) $generic $(GFLAGS) impl1.gx $endif + $ifolder (tf/impgsr.x, impgs.gx) $generic $(GFLAGS) impgs.gx $endif + $ifolder (tf/impakr.x, impak.gx) $generic $(GFLAGS) impak.gx $endif + $ifolder (tf/imgs3r.x, imgs3.gx) $generic $(GFLAGS) imgs3.gx $endif + $ifolder (tf/imgs2r.x, imgs2.gx) $generic $(GFLAGS) imgs2.gx $endif + $ifolder (tf/imgs1r.x, imgs1.gx) $generic $(GFLAGS) imgs1.gx $endif + $ifolder (tf/imgnlr.x, imgnl.gx) $generic $(GFLAGS) imgnl.gx $endif + $ifolder (tf/imgl3r.x, imgl3.gx) $generic $(GFLAGS) imgl3.gx $endif + $ifolder (tf/imgl2r.x, imgl2.gx) $generic $(GFLAGS) imgl2.gx $endif + $ifolder (tf/imgl1r.x, imgl1.gx) $generic $(GFLAGS) imgl1.gx $endif + $ifolder (tf/imggsr.x, imggs.gx) $generic $(GFLAGS) imggs.gx $endif + $ifolder (tf/imflsr.x, imfls.gx) $generic $(GFLAGS) imfls.gx $endif + ; + +libex.a: + # Retranslate any recently modified generic sources. + $ifeq (hostid, unix) + $call tfiles + $endif + + @tf # Update datatype expanded files. + @db # Update image database interface. + @dbc # Update image database interface (enhanced). + @iki # Update image kernel interface. + @imt # Update the image template package. + #imt.x + + imaccess.x + imaflp.x + imaplv.x + imbln1.x + imbln2.x + imbln3.x + imbtran.x + imcopy.x + imcssz.x + imdelete.x + imdmap.x + imerr.x + imflsh.x + imflush.x + imgclust.x + imggsc.x + imgibf.x + imgimage.x + imgnln.x + imgobf.x + imgsect.x + iminie.x + imioff.x + imisec.x + imloop.x + immaky.x + immap.x + immapz.x + imnote.x + imopsf.x + imparse.x + impmhdr.x + impmlne1.x + impmlne2.x + impmlne3.x + impmlnev.x + impmmap.x + impmmapo.x + impmopen.x + impmsne1.x + impmsne2.x + impmsne3.x + impmsnev.x + impnln.x + imrbpx.x + imrdpx.x + imrename.x + imrmbufs.x + imsamp.x + imsetbuf.x + imseti.x + imsetr.x + imsinb.x + imsslv.x + imstati.x + imstatr.x + imstats.x + imunmap.x + imwbpx.x + imwrite.x + imwrpx.x + zzdebug.x + ; diff --git a/sys/imio/tf/imflsd.x b/sys/imio/tf/imflsd.x new file mode 100644 index 00000000..bc12f5b5 --- /dev/null +++ b/sys/imio/tf/imflsd.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMFLS? -- Flush the output buffer, if necessary. Convert the datatype +# of the pixels upon output, if the datatype of the pixels in the imagefile +# is different than that requested by the calling program. + +procedure imflsd (imdes) + +pointer imdes +pointer bdes, bp +errchk imflsh + +begin + # Ignore the flush request if the output buffer has already been + # flushed. + + if (IM_FLUSH(imdes) == YES) { + bdes = IM_OBDES(imdes) + bp = BD_BUFPTR(bdes) + + # Convert datatype of pixels, if necessary, and flush buffer. + if (IM_PIXTYPE(imdes) != TY_DOUBLE || SZ_INT != SZ_INT32) { + call impakd (Memc[bp], Memc[bp], BD_NPIX(bdes), + IM_PIXTYPE(imdes)) + } + + call imflsh (imdes, bp, BD_VS(bdes,1), BD_VE(bdes,1), BD_NDIM(bdes)) + + IM_FLUSH(imdes) = NO + } +end diff --git a/sys/imio/tf/imflsi.x b/sys/imio/tf/imflsi.x new file mode 100644 index 00000000..b7a4b4fb --- /dev/null +++ b/sys/imio/tf/imflsi.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMFLS? -- Flush the output buffer, if necessary. Convert the datatype +# of the pixels upon output, if the datatype of the pixels in the imagefile +# is different than that requested by the calling program. + +procedure imflsi (imdes) + +pointer imdes +pointer bdes, bp +errchk imflsh + +begin + # Ignore the flush request if the output buffer has already been + # flushed. + + if (IM_FLUSH(imdes) == YES) { + bdes = IM_OBDES(imdes) + bp = BD_BUFPTR(bdes) + + # Convert datatype of pixels, if necessary, and flush buffer. + if (IM_PIXTYPE(imdes) != TY_INT || SZ_INT != SZ_INT32) { + call impaki (Memc[bp], Memc[bp], BD_NPIX(bdes), + IM_PIXTYPE(imdes)) + } + + call imflsh (imdes, bp, BD_VS(bdes,1), BD_VE(bdes,1), BD_NDIM(bdes)) + + IM_FLUSH(imdes) = NO + } +end diff --git a/sys/imio/tf/imflsl.x b/sys/imio/tf/imflsl.x new file mode 100644 index 00000000..26934cb1 --- /dev/null +++ b/sys/imio/tf/imflsl.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMFLS? -- Flush the output buffer, if necessary. Convert the datatype +# of the pixels upon output, if the datatype of the pixels in the imagefile +# is different than that requested by the calling program. + +procedure imflsl (imdes) + +pointer imdes +pointer bdes, bp +errchk imflsh + +begin + # Ignore the flush request if the output buffer has already been + # flushed. + + if (IM_FLUSH(imdes) == YES) { + bdes = IM_OBDES(imdes) + bp = BD_BUFPTR(bdes) + + # Convert datatype of pixels, if necessary, and flush buffer. + if (IM_PIXTYPE(imdes) != TY_LONG || SZ_INT != SZ_INT32) { + call impakl (Memc[bp], Memc[bp], BD_NPIX(bdes), + IM_PIXTYPE(imdes)) + } + + call imflsh (imdes, bp, BD_VS(bdes,1), BD_VE(bdes,1), BD_NDIM(bdes)) + + IM_FLUSH(imdes) = NO + } +end diff --git a/sys/imio/tf/imflsr.x b/sys/imio/tf/imflsr.x new file mode 100644 index 00000000..b19f1bcc --- /dev/null +++ b/sys/imio/tf/imflsr.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMFLS? -- Flush the output buffer, if necessary. Convert the datatype +# of the pixels upon output, if the datatype of the pixels in the imagefile +# is different than that requested by the calling program. + +procedure imflsr (imdes) + +pointer imdes +pointer bdes, bp +errchk imflsh + +begin + # Ignore the flush request if the output buffer has already been + # flushed. + + if (IM_FLUSH(imdes) == YES) { + bdes = IM_OBDES(imdes) + bp = BD_BUFPTR(bdes) + + # Convert datatype of pixels, if necessary, and flush buffer. + if (IM_PIXTYPE(imdes) != TY_REAL || SZ_INT != SZ_INT32) { + call impakr (Memc[bp], Memc[bp], BD_NPIX(bdes), + IM_PIXTYPE(imdes)) + } + + call imflsh (imdes, bp, BD_VS(bdes,1), BD_VE(bdes,1), BD_NDIM(bdes)) + + IM_FLUSH(imdes) = NO + } +end diff --git a/sys/imio/tf/imflss.x b/sys/imio/tf/imflss.x new file mode 100644 index 00000000..1034413b --- /dev/null +++ b/sys/imio/tf/imflss.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMFLS? -- Flush the output buffer, if necessary. Convert the datatype +# of the pixels upon output, if the datatype of the pixels in the imagefile +# is different than that requested by the calling program. + +procedure imflss (imdes) + +pointer imdes +pointer bdes, bp +errchk imflsh + +begin + # Ignore the flush request if the output buffer has already been + # flushed. + + if (IM_FLUSH(imdes) == YES) { + bdes = IM_OBDES(imdes) + bp = BD_BUFPTR(bdes) + + # Convert datatype of pixels, if necessary, and flush buffer. + if (IM_PIXTYPE(imdes) != TY_SHORT || SZ_INT != SZ_INT32) { + call impaks (Memc[bp], Memc[bp], BD_NPIX(bdes), + IM_PIXTYPE(imdes)) + } + + call imflsh (imdes, bp, BD_VS(bdes,1), BD_VE(bdes,1), BD_NDIM(bdes)) + + IM_FLUSH(imdes) = NO + } +end diff --git a/sys/imio/tf/imflsx.x b/sys/imio/tf/imflsx.x new file mode 100644 index 00000000..7e847ffe --- /dev/null +++ b/sys/imio/tf/imflsx.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMFLS? -- Flush the output buffer, if necessary. Convert the datatype +# of the pixels upon output, if the datatype of the pixels in the imagefile +# is different than that requested by the calling program. + +procedure imflsx (imdes) + +pointer imdes +pointer bdes, bp +errchk imflsh + +begin + # Ignore the flush request if the output buffer has already been + # flushed. + + if (IM_FLUSH(imdes) == YES) { + bdes = IM_OBDES(imdes) + bp = BD_BUFPTR(bdes) + + # Convert datatype of pixels, if necessary, and flush buffer. + if (IM_PIXTYPE(imdes) != TY_COMPLEX || SZ_INT != SZ_INT32) { + call impakx (Memc[bp], Memc[bp], BD_NPIX(bdes), + IM_PIXTYPE(imdes)) + } + + call imflsh (imdes, bp, BD_VS(bdes,1), BD_VE(bdes,1), BD_NDIM(bdes)) + + IM_FLUSH(imdes) = NO + } +end diff --git a/sys/imio/tf/imggsd.x b/sys/imio/tf/imggsd.x new file mode 100644 index 00000000..509da31b --- /dev/null +++ b/sys/imio/tf/imggsd.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGGS? -- Get a general section. + +pointer procedure imggsd (imdes, vs, ve, ndim) + +pointer imdes +long vs[IM_MAXDIM], ve[IM_MAXDIM] +int ndim +long totpix +pointer bp, imggsc() +errchk imggsc + +begin + bp = imggsc (imdes, vs, ve, ndim, TY_DOUBLE, totpix) + if (IM_PIXTYPE(imdes) != TY_DOUBLE) + call imupkd (Memd[bp], Memd[bp], totpix, IM_PIXTYPE(imdes)) + return (bp) +end diff --git a/sys/imio/tf/imggsi.x b/sys/imio/tf/imggsi.x new file mode 100644 index 00000000..9cd0e00c --- /dev/null +++ b/sys/imio/tf/imggsi.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGGS? -- Get a general section. + +pointer procedure imggsi (imdes, vs, ve, ndim) + +pointer imdes +long vs[IM_MAXDIM], ve[IM_MAXDIM] +int ndim +long totpix +pointer bp, imggsc() +errchk imggsc + +begin + bp = imggsc (imdes, vs, ve, ndim, TY_INT, totpix) + if (IM_PIXTYPE(imdes) != TY_INT) + call imupki (Memi[bp], Memi[bp], totpix, IM_PIXTYPE(imdes)) + return (bp) +end diff --git a/sys/imio/tf/imggsl.x b/sys/imio/tf/imggsl.x new file mode 100644 index 00000000..e4d2411d --- /dev/null +++ b/sys/imio/tf/imggsl.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGGS? -- Get a general section. + +pointer procedure imggsl (imdes, vs, ve, ndim) + +pointer imdes +long vs[IM_MAXDIM], ve[IM_MAXDIM] +int ndim +long totpix +pointer bp, imggsc() +errchk imggsc + +begin + bp = imggsc (imdes, vs, ve, ndim, TY_LONG, totpix) + if (IM_PIXTYPE(imdes) != TY_LONG) + call imupkl (Meml[bp], Meml[bp], totpix, IM_PIXTYPE(imdes)) + return (bp) +end diff --git a/sys/imio/tf/imggsr.x b/sys/imio/tf/imggsr.x new file mode 100644 index 00000000..37055497 --- /dev/null +++ b/sys/imio/tf/imggsr.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGGS? -- Get a general section. + +pointer procedure imggsr (imdes, vs, ve, ndim) + +pointer imdes +long vs[IM_MAXDIM], ve[IM_MAXDIM] +int ndim +long totpix +pointer bp, imggsc() +errchk imggsc + +begin + bp = imggsc (imdes, vs, ve, ndim, TY_REAL, totpix) + if (IM_PIXTYPE(imdes) != TY_REAL) + call imupkr (Memr[bp], Memr[bp], totpix, IM_PIXTYPE(imdes)) + return (bp) +end diff --git a/sys/imio/tf/imggss.x b/sys/imio/tf/imggss.x new file mode 100644 index 00000000..f6e3260e --- /dev/null +++ b/sys/imio/tf/imggss.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGGS? -- Get a general section. + +pointer procedure imggss (imdes, vs, ve, ndim) + +pointer imdes +long vs[IM_MAXDIM], ve[IM_MAXDIM] +int ndim +long totpix +pointer bp, imggsc() +errchk imggsc + +begin + bp = imggsc (imdes, vs, ve, ndim, TY_SHORT, totpix) + if (IM_PIXTYPE(imdes) != TY_SHORT) + call imupks (Mems[bp], Mems[bp], totpix, IM_PIXTYPE(imdes)) + return (bp) +end diff --git a/sys/imio/tf/imggsx.x b/sys/imio/tf/imggsx.x new file mode 100644 index 00000000..60c029c0 --- /dev/null +++ b/sys/imio/tf/imggsx.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGGS? -- Get a general section. + +pointer procedure imggsx (imdes, vs, ve, ndim) + +pointer imdes +long vs[IM_MAXDIM], ve[IM_MAXDIM] +int ndim +long totpix +pointer bp, imggsc() +errchk imggsc + +begin + bp = imggsc (imdes, vs, ve, ndim, TY_COMPLEX, totpix) + if (IM_PIXTYPE(imdes) != TY_COMPLEX) + call imupkx (Memx[bp], Memx[bp], totpix, IM_PIXTYPE(imdes)) + return (bp) +end diff --git a/sys/imio/tf/imgl1d.x b/sys/imio/tf/imgl1d.x new file mode 100644 index 00000000..eeab8586 --- /dev/null +++ b/sys/imio/tf/imgl1d.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMGL1? -- Get a line from an apparently one dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl1d (im) + +pointer im +int fd, nchars +long offset +pointer bp, imggsd(), freadp() +errchk imopsf + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_DOUBLE) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + + offset = IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_DOUBLE + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_DOUBLE + 1) + return (bp) + } + return (imggsd (im, long(1), IM_LEN(im,1), 1)) + } +end diff --git a/sys/imio/tf/imgl1i.x b/sys/imio/tf/imgl1i.x new file mode 100644 index 00000000..0de66fa2 --- /dev/null +++ b/sys/imio/tf/imgl1i.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMGL1? -- Get a line from an apparently one dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl1i (im) + +pointer im +int fd, nchars +long offset +pointer bp, imggsi(), freadp() +errchk imopsf + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_INT) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + + offset = IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_INT + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_INT + 1) + return (bp) + } + return (imggsi (im, long(1), IM_LEN(im,1), 1)) + } +end diff --git a/sys/imio/tf/imgl1l.x b/sys/imio/tf/imgl1l.x new file mode 100644 index 00000000..a996ce32 --- /dev/null +++ b/sys/imio/tf/imgl1l.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMGL1? -- Get a line from an apparently one dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl1l (im) + +pointer im +int fd, nchars +long offset +pointer bp, imggsl(), freadp() +errchk imopsf + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_LONG) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + + offset = IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_LONG + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_LONG + 1) + return (bp) + } + return (imggsl (im, long(1), IM_LEN(im,1), 1)) + } +end diff --git a/sys/imio/tf/imgl1r.x b/sys/imio/tf/imgl1r.x new file mode 100644 index 00000000..a3f20de8 --- /dev/null +++ b/sys/imio/tf/imgl1r.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMGL1? -- Get a line from an apparently one dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl1r (im) + +pointer im +int fd, nchars +long offset +pointer bp, imggsr(), freadp() +errchk imopsf + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_REAL) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + + offset = IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_REAL + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_REAL + 1) + return (bp) + } + return (imggsr (im, long(1), IM_LEN(im,1), 1)) + } +end diff --git a/sys/imio/tf/imgl1s.x b/sys/imio/tf/imgl1s.x new file mode 100644 index 00000000..bd226f31 --- /dev/null +++ b/sys/imio/tf/imgl1s.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMGL1? -- Get a line from an apparently one dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl1s (im) + +pointer im +int fd, nchars +long offset +pointer bp, imggss(), freadp() +errchk imopsf + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_SHORT) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + + offset = IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_SHORT + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_SHORT + 1) + return (bp) + } + return (imggss (im, long(1), IM_LEN(im,1), 1)) + } +end diff --git a/sys/imio/tf/imgl1x.x b/sys/imio/tf/imgl1x.x new file mode 100644 index 00000000..a7f73ac1 --- /dev/null +++ b/sys/imio/tf/imgl1x.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMGL1? -- Get a line from an apparently one dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl1x (im) + +pointer im +int fd, nchars +long offset +pointer bp, imggsx(), freadp() +errchk imopsf + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_COMPLEX) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + + offset = IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_COMPLEX + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_COMPLEX + 1) + return (bp) + } + return (imggsx (im, long(1), IM_LEN(im,1), 1)) + } +end diff --git a/sys/imio/tf/imgl2d.x b/sys/imio/tf/imgl2d.x new file mode 100644 index 00000000..dbd7858a --- /dev/null +++ b/sys/imio/tf/imgl2d.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMGL2? -- Get a line from an apparently two dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl2d (im, linenum) + +pointer im # image header pointer +int linenum # line to be read + +int fd, nchars +long vs[2], ve[2], offset +pointer bp, imggsd(), freadp() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_DOUBLE) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (linenum < 1 || linenum > IM_LEN(im,2)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (linenum - 1) * IM_PHYSLEN(im,1) * SZ_DOUBLE + + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_DOUBLE + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_DOUBLE + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = linenum + ve[2] = linenum + + return (imggsd (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imgl2i.x b/sys/imio/tf/imgl2i.x new file mode 100644 index 00000000..9592ebe9 --- /dev/null +++ b/sys/imio/tf/imgl2i.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMGL2? -- Get a line from an apparently two dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl2i (im, linenum) + +pointer im # image header pointer +int linenum # line to be read + +int fd, nchars +long vs[2], ve[2], offset +pointer bp, imggsi(), freadp() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_INT) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (linenum < 1 || linenum > IM_LEN(im,2)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (linenum - 1) * IM_PHYSLEN(im,1) * SZ_INT + + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_INT + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_INT + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = linenum + ve[2] = linenum + + return (imggsi (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imgl2l.x b/sys/imio/tf/imgl2l.x new file mode 100644 index 00000000..e3f5d523 --- /dev/null +++ b/sys/imio/tf/imgl2l.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMGL2? -- Get a line from an apparently two dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl2l (im, linenum) + +pointer im # image header pointer +int linenum # line to be read + +int fd, nchars +long vs[2], ve[2], offset +pointer bp, imggsl(), freadp() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_LONG) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (linenum < 1 || linenum > IM_LEN(im,2)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (linenum - 1) * IM_PHYSLEN(im,1) * SZ_LONG + + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_LONG + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_LONG + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = linenum + ve[2] = linenum + + return (imggsl (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imgl2r.x b/sys/imio/tf/imgl2r.x new file mode 100644 index 00000000..d487e61b --- /dev/null +++ b/sys/imio/tf/imgl2r.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMGL2? -- Get a line from an apparently two dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl2r (im, linenum) + +pointer im # image header pointer +int linenum # line to be read + +int fd, nchars +long vs[2], ve[2], offset +pointer bp, imggsr(), freadp() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_REAL) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (linenum < 1 || linenum > IM_LEN(im,2)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (linenum - 1) * IM_PHYSLEN(im,1) * SZ_REAL + + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_REAL + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_REAL + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = linenum + ve[2] = linenum + + return (imggsr (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imgl2s.x b/sys/imio/tf/imgl2s.x new file mode 100644 index 00000000..a4fd140b --- /dev/null +++ b/sys/imio/tf/imgl2s.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMGL2? -- Get a line from an apparently two dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl2s (im, linenum) + +pointer im # image header pointer +int linenum # line to be read + +int fd, nchars +long vs[2], ve[2], offset +pointer bp, imggss(), freadp() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_SHORT) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (linenum < 1 || linenum > IM_LEN(im,2)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (linenum - 1) * IM_PHYSLEN(im,1) * SZ_SHORT + + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_SHORT + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_SHORT + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = linenum + ve[2] = linenum + + return (imggss (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imgl2x.x b/sys/imio/tf/imgl2x.x new file mode 100644 index 00000000..7a97ac48 --- /dev/null +++ b/sys/imio/tf/imgl2x.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMGL2? -- Get a line from an apparently two dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl2x (im, linenum) + +pointer im # image header pointer +int linenum # line to be read + +int fd, nchars +long vs[2], ve[2], offset +pointer bp, imggsx(), freadp() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_COMPLEX) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (linenum < 1 || linenum > IM_LEN(im,2)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (linenum - 1) * IM_PHYSLEN(im,1) * SZ_COMPLEX + + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_COMPLEX + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_COMPLEX + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = linenum + ve[2] = linenum + + return (imggsx (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imgl3d.x b/sys/imio/tf/imgl3d.x new file mode 100644 index 00000000..735cc4d1 --- /dev/null +++ b/sys/imio/tf/imgl3d.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMGL3? -- Get a line from an apparently three dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl3d (im, line, band) + +pointer im # image header pointer +int line # line number within band +int band # band number + +int fd, nchars +long vs[3], ve[3], offset +pointer bp, imggsd(), freadp() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_DOUBLE) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (line < 1 || line > IM_LEN(im,2) || + band < 1 || band > IM_LEN(im,3)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (((band - 1) * IM_PHYSLEN(im,2) + line - 1) * + IM_PHYSLEN(im,1)) * SZ_DOUBLE + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_DOUBLE + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_DOUBLE + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = line + ve[2] = line + vs[3] = band + ve[3] = band + + return (imggsd (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imgl3i.x b/sys/imio/tf/imgl3i.x new file mode 100644 index 00000000..75a87d36 --- /dev/null +++ b/sys/imio/tf/imgl3i.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMGL3? -- Get a line from an apparently three dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl3i (im, line, band) + +pointer im # image header pointer +int line # line number within band +int band # band number + +int fd, nchars +long vs[3], ve[3], offset +pointer bp, imggsi(), freadp() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_INT) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (line < 1 || line > IM_LEN(im,2) || + band < 1 || band > IM_LEN(im,3)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (((band - 1) * IM_PHYSLEN(im,2) + line - 1) * + IM_PHYSLEN(im,1)) * SZ_INT + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_INT + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_INT + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = line + ve[2] = line + vs[3] = band + ve[3] = band + + return (imggsi (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imgl3l.x b/sys/imio/tf/imgl3l.x new file mode 100644 index 00000000..e18f8d3e --- /dev/null +++ b/sys/imio/tf/imgl3l.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMGL3? -- Get a line from an apparently three dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl3l (im, line, band) + +pointer im # image header pointer +int line # line number within band +int band # band number + +int fd, nchars +long vs[3], ve[3], offset +pointer bp, imggsl(), freadp() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_LONG) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (line < 1 || line > IM_LEN(im,2) || + band < 1 || band > IM_LEN(im,3)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (((band - 1) * IM_PHYSLEN(im,2) + line - 1) * + IM_PHYSLEN(im,1)) * SZ_LONG + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_LONG + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_LONG + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = line + ve[2] = line + vs[3] = band + ve[3] = band + + return (imggsl (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imgl3r.x b/sys/imio/tf/imgl3r.x new file mode 100644 index 00000000..428e55aa --- /dev/null +++ b/sys/imio/tf/imgl3r.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMGL3? -- Get a line from an apparently three dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl3r (im, line, band) + +pointer im # image header pointer +int line # line number within band +int band # band number + +int fd, nchars +long vs[3], ve[3], offset +pointer bp, imggsr(), freadp() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_REAL) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (line < 1 || line > IM_LEN(im,2) || + band < 1 || band > IM_LEN(im,3)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (((band - 1) * IM_PHYSLEN(im,2) + line - 1) * + IM_PHYSLEN(im,1)) * SZ_REAL + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_REAL + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_REAL + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = line + ve[2] = line + vs[3] = band + ve[3] = band + + return (imggsr (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imgl3s.x b/sys/imio/tf/imgl3s.x new file mode 100644 index 00000000..32cd0625 --- /dev/null +++ b/sys/imio/tf/imgl3s.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMGL3? -- Get a line from an apparently three dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl3s (im, line, band) + +pointer im # image header pointer +int line # line number within band +int band # band number + +int fd, nchars +long vs[3], ve[3], offset +pointer bp, imggss(), freadp() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_SHORT) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (line < 1 || line > IM_LEN(im,2) || + band < 1 || band > IM_LEN(im,3)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (((band - 1) * IM_PHYSLEN(im,2) + line - 1) * + IM_PHYSLEN(im,1)) * SZ_SHORT + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_SHORT + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_SHORT + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = line + ve[2] = line + vs[3] = band + ve[3] = band + + return (imggss (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imgl3x.x b/sys/imio/tf/imgl3x.x new file mode 100644 index 00000000..9ba1052d --- /dev/null +++ b/sys/imio/tf/imgl3x.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMGL3? -- Get a line from an apparently three dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl3x (im, line, band) + +pointer im # image header pointer +int line # line number within band +int band # band number + +int fd, nchars +long vs[3], ve[3], offset +pointer bp, imggsx(), freadp() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_COMPLEX) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (line < 1 || line > IM_LEN(im,2) || + band < 1 || band > IM_LEN(im,3)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (((band - 1) * IM_PHYSLEN(im,2) + line - 1) * + IM_PHYSLEN(im,1)) * SZ_COMPLEX + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_COMPLEX + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_COMPLEX + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = line + ve[2] = line + vs[3] = band + ve[3] = band + + return (imggsx (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imgnld.x b/sys/imio/tf/imgnld.x new file mode 100644 index 00000000..55b27360 --- /dev/null +++ b/sys/imio/tf/imgnld.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGNL -- Get the next line from an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# to the first line to be read before the first call. Each call increments +# the leftmost subscript by one, until V equals IM_LEN, at which time EOF +# is returned. + +int procedure imgnld (imdes, lineptr, v) + +pointer imdes +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int npix, dtype, imgnln() +errchk imgnln + +begin + npix = imgnln (imdes, lineptr, v, TY_DOUBLE) + + if (npix != EOF) { + dtype = IM_PIXTYPE(imdes) + if (dtype != TY_DOUBLE) + call imupkd (Memd[lineptr], Memd[lineptr], npix, dtype) + } + + return (npix) +end diff --git a/sys/imio/tf/imgnli.x b/sys/imio/tf/imgnli.x new file mode 100644 index 00000000..1b9ed846 --- /dev/null +++ b/sys/imio/tf/imgnli.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGNL -- Get the next line from an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# to the first line to be read before the first call. Each call increments +# the leftmost subscript by one, until V equals IM_LEN, at which time EOF +# is returned. + +int procedure imgnli (imdes, lineptr, v) + +pointer imdes +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int npix, dtype, imgnln() +errchk imgnln + +begin + npix = imgnln (imdes, lineptr, v, TY_INT) + + if (npix != EOF) { + dtype = IM_PIXTYPE(imdes) + if (dtype != TY_INT) + call imupki (Memi[lineptr], Memi[lineptr], npix, dtype) + } + + return (npix) +end diff --git a/sys/imio/tf/imgnll.x b/sys/imio/tf/imgnll.x new file mode 100644 index 00000000..81c4fc44 --- /dev/null +++ b/sys/imio/tf/imgnll.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGNL -- Get the next line from an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# to the first line to be read before the first call. Each call increments +# the leftmost subscript by one, until V equals IM_LEN, at which time EOF +# is returned. + +int procedure imgnll (imdes, lineptr, v) + +pointer imdes +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int npix, dtype, imgnln() +errchk imgnln + +begin + npix = imgnln (imdes, lineptr, v, TY_LONG) + + if (npix != EOF) { + dtype = IM_PIXTYPE(imdes) + if (dtype != TY_LONG) + call imupkl (Meml[lineptr], Meml[lineptr], npix, dtype) + } + + return (npix) +end diff --git a/sys/imio/tf/imgnlr.x b/sys/imio/tf/imgnlr.x new file mode 100644 index 00000000..b14c96bb --- /dev/null +++ b/sys/imio/tf/imgnlr.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGNL -- Get the next line from an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# to the first line to be read before the first call. Each call increments +# the leftmost subscript by one, until V equals IM_LEN, at which time EOF +# is returned. + +int procedure imgnlr (imdes, lineptr, v) + +pointer imdes +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int npix, dtype, imgnln() +errchk imgnln + +begin + npix = imgnln (imdes, lineptr, v, TY_REAL) + + if (npix != EOF) { + dtype = IM_PIXTYPE(imdes) + if (dtype != TY_REAL) + call imupkr (Memr[lineptr], Memr[lineptr], npix, dtype) + } + + return (npix) +end diff --git a/sys/imio/tf/imgnls.x b/sys/imio/tf/imgnls.x new file mode 100644 index 00000000..ce962df6 --- /dev/null +++ b/sys/imio/tf/imgnls.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGNL -- Get the next line from an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# to the first line to be read before the first call. Each call increments +# the leftmost subscript by one, until V equals IM_LEN, at which time EOF +# is returned. + +int procedure imgnls (imdes, lineptr, v) + +pointer imdes +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int npix, dtype, imgnln() +errchk imgnln + +begin + npix = imgnln (imdes, lineptr, v, TY_SHORT) + + if (npix != EOF) { + dtype = IM_PIXTYPE(imdes) + if (dtype != TY_SHORT) + call imupks (Mems[lineptr], Mems[lineptr], npix, dtype) + } + + return (npix) +end diff --git a/sys/imio/tf/imgnlx.x b/sys/imio/tf/imgnlx.x new file mode 100644 index 00000000..76075a49 --- /dev/null +++ b/sys/imio/tf/imgnlx.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGNL -- Get the next line from an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# to the first line to be read before the first call. Each call increments +# the leftmost subscript by one, until V equals IM_LEN, at which time EOF +# is returned. + +int procedure imgnlx (imdes, lineptr, v) + +pointer imdes +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int npix, dtype, imgnln() +errchk imgnln + +begin + npix = imgnln (imdes, lineptr, v, TY_COMPLEX) + + if (npix != EOF) { + dtype = IM_PIXTYPE(imdes) + if (dtype != TY_COMPLEX) + call imupkx (Memx[lineptr], Memx[lineptr], npix, dtype) + } + + return (npix) +end diff --git a/sys/imio/tf/imgs1d.x b/sys/imio/tf/imgs1d.x new file mode 100644 index 00000000..5ab52b92 --- /dev/null +++ b/sys/imio/tf/imgs1d.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGS1? -- Get a section from an apparently one dimensional image. + +pointer procedure imgs1d (im, x1, x2) + +pointer im +int x1, x2 +pointer imggsd(), imgl1d() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1)) + return (imgl1d (im)) + else + return (imggsd (im, long(x1), long(x2), 1)) +end diff --git a/sys/imio/tf/imgs1i.x b/sys/imio/tf/imgs1i.x new file mode 100644 index 00000000..ddb0a435 --- /dev/null +++ b/sys/imio/tf/imgs1i.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGS1? -- Get a section from an apparently one dimensional image. + +pointer procedure imgs1i (im, x1, x2) + +pointer im +int x1, x2 +pointer imggsi(), imgl1i() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1)) + return (imgl1i (im)) + else + return (imggsi (im, long(x1), long(x2), 1)) +end diff --git a/sys/imio/tf/imgs1l.x b/sys/imio/tf/imgs1l.x new file mode 100644 index 00000000..5f3610c9 --- /dev/null +++ b/sys/imio/tf/imgs1l.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGS1? -- Get a section from an apparently one dimensional image. + +pointer procedure imgs1l (im, x1, x2) + +pointer im +int x1, x2 +pointer imggsl(), imgl1l() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1)) + return (imgl1l (im)) + else + return (imggsl (im, long(x1), long(x2), 1)) +end diff --git a/sys/imio/tf/imgs1r.x b/sys/imio/tf/imgs1r.x new file mode 100644 index 00000000..9d5da6d4 --- /dev/null +++ b/sys/imio/tf/imgs1r.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGS1? -- Get a section from an apparently one dimensional image. + +pointer procedure imgs1r (im, x1, x2) + +pointer im +int x1, x2 +pointer imggsr(), imgl1r() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1)) + return (imgl1r (im)) + else + return (imggsr (im, long(x1), long(x2), 1)) +end diff --git a/sys/imio/tf/imgs1s.x b/sys/imio/tf/imgs1s.x new file mode 100644 index 00000000..fc15aac3 --- /dev/null +++ b/sys/imio/tf/imgs1s.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGS1? -- Get a section from an apparently one dimensional image. + +pointer procedure imgs1s (im, x1, x2) + +pointer im +int x1, x2 +pointer imggss(), imgl1s() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1)) + return (imgl1s (im)) + else + return (imggss (im, long(x1), long(x2), 1)) +end diff --git a/sys/imio/tf/imgs1x.x b/sys/imio/tf/imgs1x.x new file mode 100644 index 00000000..7bb64465 --- /dev/null +++ b/sys/imio/tf/imgs1x.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGS1? -- Get a section from an apparently one dimensional image. + +pointer procedure imgs1x (im, x1, x2) + +pointer im +int x1, x2 +pointer imggsx(), imgl1x() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1)) + return (imgl1x (im)) + else + return (imggsx (im, long(x1), long(x2), 1)) +end diff --git a/sys/imio/tf/imgs2d.x b/sys/imio/tf/imgs2d.x new file mode 100644 index 00000000..4c8f5f71 --- /dev/null +++ b/sys/imio/tf/imgs2d.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGS2? -- Get a section from an apparently two dimensional image. + +pointer procedure imgs2d (im, x1, x2, y1, y2) + +pointer im +int x1, x2, y1, y2 +long vs[2], ve[2] +pointer imggsd(), imgl2d() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2) + return (imgl2d (im, y1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + return (imggsd (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imgs2i.x b/sys/imio/tf/imgs2i.x new file mode 100644 index 00000000..fe0c8d1e --- /dev/null +++ b/sys/imio/tf/imgs2i.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGS2? -- Get a section from an apparently two dimensional image. + +pointer procedure imgs2i (im, x1, x2, y1, y2) + +pointer im +int x1, x2, y1, y2 +long vs[2], ve[2] +pointer imggsi(), imgl2i() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2) + return (imgl2i (im, y1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + return (imggsi (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imgs2l.x b/sys/imio/tf/imgs2l.x new file mode 100644 index 00000000..00fe004e --- /dev/null +++ b/sys/imio/tf/imgs2l.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGS2? -- Get a section from an apparently two dimensional image. + +pointer procedure imgs2l (im, x1, x2, y1, y2) + +pointer im +int x1, x2, y1, y2 +long vs[2], ve[2] +pointer imggsl(), imgl2l() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2) + return (imgl2l (im, y1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + return (imggsl (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imgs2r.x b/sys/imio/tf/imgs2r.x new file mode 100644 index 00000000..7847908a --- /dev/null +++ b/sys/imio/tf/imgs2r.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGS2? -- Get a section from an apparently two dimensional image. + +pointer procedure imgs2r (im, x1, x2, y1, y2) + +pointer im +int x1, x2, y1, y2 +long vs[2], ve[2] +pointer imggsr(), imgl2r() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2) + return (imgl2r (im, y1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + return (imggsr (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imgs2s.x b/sys/imio/tf/imgs2s.x new file mode 100644 index 00000000..209debe4 --- /dev/null +++ b/sys/imio/tf/imgs2s.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGS2? -- Get a section from an apparently two dimensional image. + +pointer procedure imgs2s (im, x1, x2, y1, y2) + +pointer im +int x1, x2, y1, y2 +long vs[2], ve[2] +pointer imggss(), imgl2s() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2) + return (imgl2s (im, y1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + return (imggss (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imgs2x.x b/sys/imio/tf/imgs2x.x new file mode 100644 index 00000000..3ff5bdc4 --- /dev/null +++ b/sys/imio/tf/imgs2x.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGS2? -- Get a section from an apparently two dimensional image. + +pointer procedure imgs2x (im, x1, x2, y1, y2) + +pointer im +int x1, x2, y1, y2 +long vs[2], ve[2] +pointer imggsx(), imgl2x() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2) + return (imgl2x (im, y1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + return (imggsx (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imgs3d.x b/sys/imio/tf/imgs3d.x new file mode 100644 index 00000000..32c1dab8 --- /dev/null +++ b/sys/imio/tf/imgs3d.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGS3? -- Get a section from an apparently three dimensional image. + +pointer procedure imgs3d (im, x1, x2, y1, y2, z1, z2) + +pointer im +int x1, x2, y1, y2, z1, z2 +long vs[3], ve[3] +pointer imggsd(), imgl3d() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2 && z1 == z2) + return (imgl3d (im, y1, z1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + vs[3] = z1 + ve[3] = z2 + + return (imggsd (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imgs3i.x b/sys/imio/tf/imgs3i.x new file mode 100644 index 00000000..a231130f --- /dev/null +++ b/sys/imio/tf/imgs3i.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGS3? -- Get a section from an apparently three dimensional image. + +pointer procedure imgs3i (im, x1, x2, y1, y2, z1, z2) + +pointer im +int x1, x2, y1, y2, z1, z2 +long vs[3], ve[3] +pointer imggsi(), imgl3i() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2 && z1 == z2) + return (imgl3i (im, y1, z1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + vs[3] = z1 + ve[3] = z2 + + return (imggsi (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imgs3l.x b/sys/imio/tf/imgs3l.x new file mode 100644 index 00000000..5f1294b0 --- /dev/null +++ b/sys/imio/tf/imgs3l.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGS3? -- Get a section from an apparently three dimensional image. + +pointer procedure imgs3l (im, x1, x2, y1, y2, z1, z2) + +pointer im +int x1, x2, y1, y2, z1, z2 +long vs[3], ve[3] +pointer imggsl(), imgl3l() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2 && z1 == z2) + return (imgl3l (im, y1, z1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + vs[3] = z1 + ve[3] = z2 + + return (imggsl (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imgs3r.x b/sys/imio/tf/imgs3r.x new file mode 100644 index 00000000..54bd0667 --- /dev/null +++ b/sys/imio/tf/imgs3r.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGS3? -- Get a section from an apparently three dimensional image. + +pointer procedure imgs3r (im, x1, x2, y1, y2, z1, z2) + +pointer im +int x1, x2, y1, y2, z1, z2 +long vs[3], ve[3] +pointer imggsr(), imgl3r() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2 && z1 == z2) + return (imgl3r (im, y1, z1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + vs[3] = z1 + ve[3] = z2 + + return (imggsr (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imgs3s.x b/sys/imio/tf/imgs3s.x new file mode 100644 index 00000000..b0692edb --- /dev/null +++ b/sys/imio/tf/imgs3s.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGS3? -- Get a section from an apparently three dimensional image. + +pointer procedure imgs3s (im, x1, x2, y1, y2, z1, z2) + +pointer im +int x1, x2, y1, y2, z1, z2 +long vs[3], ve[3] +pointer imggss(), imgl3s() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2 && z1 == z2) + return (imgl3s (im, y1, z1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + vs[3] = z1 + ve[3] = z2 + + return (imggss (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imgs3x.x b/sys/imio/tf/imgs3x.x new file mode 100644 index 00000000..f621fe4c --- /dev/null +++ b/sys/imio/tf/imgs3x.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMGS3? -- Get a section from an apparently three dimensional image. + +pointer procedure imgs3x (im, x1, x2, y1, y2, z1, z2) + +pointer im +int x1, x2, y1, y2, z1, z2 +long vs[3], ve[3] +pointer imggsx(), imgl3x() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2 && z1 == z2) + return (imgl3x (im, y1, z1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + vs[3] = z1 + ve[3] = z2 + + return (imggsx (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/impakd.x b/sys/imio/tf/impakd.x new file mode 100644 index 00000000..060ef4d5 --- /dev/null +++ b/sys/imio/tf/impakd.x @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPAK? -- Convert an array of pixels of a specific datatype to the +# datatype given as the final argument. + +procedure impakd (a, b, npix, dtype) + +double a[npix] +int b[npix], npix, dtype + +pointer bp + +begin + switch (dtype) { + case TY_USHORT: + call achtdu (a, b, npix) + case TY_SHORT: + call achtds (a, b, npix) + case TY_INT: + if (SZ_INT == SZ_INT32) + call achtdi (a, b, npix) + else { + call malloc (bp, npix, TY_INT) + call achtdi (a, Memi[bp], npix) + call ipak32 (Memi[bp], b, npix) + call mfree (bp, TY_INT) + } + case TY_LONG: + if (SZ_INT == SZ_INT32) + call achtdl (a, b, npix) + else { + call malloc (bp, npix, TY_LONG) + call achtdl (a, Meml[bp], npix) + call ipak32 (Meml[bp], b, npix) + call mfree (bp, TY_LONG) + } + case TY_REAL: + call achtdr (a, b, npix) + case TY_DOUBLE: + call achtdd (a, b, npix) + case TY_COMPLEX: + call achtdx (a, b, npix) + default: + call error (1, "Unknown datatype in imagefile") + } +end diff --git a/sys/imio/tf/impaki.x b/sys/imio/tf/impaki.x new file mode 100644 index 00000000..5d197add --- /dev/null +++ b/sys/imio/tf/impaki.x @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPAK? -- Convert an array of pixels of a specific datatype to the +# datatype given as the final argument. + +procedure impaki (a, b, npix, dtype) + +int a[npix] +int b[npix], npix, dtype + +pointer bp + +begin + switch (dtype) { + case TY_USHORT: + call achtiu (a, b, npix) + case TY_SHORT: + call achtis (a, b, npix) + case TY_INT: + if (SZ_INT == SZ_INT32) + call achtii (a, b, npix) + else { + call malloc (bp, npix, TY_INT) + call achtii (a, Memi[bp], npix) + call ipak32 (Memi[bp], b, npix) + call mfree (bp, TY_INT) + } + case TY_LONG: + if (SZ_INT == SZ_INT32) + call achtil (a, b, npix) + else { + call malloc (bp, npix, TY_LONG) + call achtil (a, Meml[bp], npix) + call ipak32 (Meml[bp], b, npix) + call mfree (bp, TY_LONG) + } + case TY_REAL: + call achtir (a, b, npix) + case TY_DOUBLE: + call achtid (a, b, npix) + case TY_COMPLEX: + call achtix (a, b, npix) + default: + call error (1, "Unknown datatype in imagefile") + } +end diff --git a/sys/imio/tf/impakl.x b/sys/imio/tf/impakl.x new file mode 100644 index 00000000..884f931b --- /dev/null +++ b/sys/imio/tf/impakl.x @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPAK? -- Convert an array of pixels of a specific datatype to the +# datatype given as the final argument. + +procedure impakl (a, b, npix, dtype) + +long a[npix] +int b[npix], npix, dtype + +pointer bp + +begin + switch (dtype) { + case TY_USHORT: + call achtlu (a, b, npix) + case TY_SHORT: + call achtls (a, b, npix) + case TY_INT: + if (SZ_INT == SZ_INT32) + call achtli (a, b, npix) + else { + call malloc (bp, npix, TY_INT) + call achtli (a, Memi[bp], npix) + call ipak32 (Memi[bp], b, npix) + call mfree (bp, TY_INT) + } + case TY_LONG: + if (SZ_INT == SZ_INT32) + call achtll (a, b, npix) + else { + call malloc (bp, npix, TY_LONG) + call achtll (a, Meml[bp], npix) + call ipak32 (Meml[bp], b, npix) + call mfree (bp, TY_LONG) + } + case TY_REAL: + call achtlr (a, b, npix) + case TY_DOUBLE: + call achtld (a, b, npix) + case TY_COMPLEX: + call achtlx (a, b, npix) + default: + call error (1, "Unknown datatype in imagefile") + } +end diff --git a/sys/imio/tf/impakr.x b/sys/imio/tf/impakr.x new file mode 100644 index 00000000..867554ce --- /dev/null +++ b/sys/imio/tf/impakr.x @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPAK? -- Convert an array of pixels of a specific datatype to the +# datatype given as the final argument. + +procedure impakr (a, b, npix, dtype) + +real a[npix] +int b[npix], npix, dtype + +pointer bp + +begin + switch (dtype) { + case TY_USHORT: + call achtru (a, b, npix) + case TY_SHORT: + call achtrs (a, b, npix) + case TY_INT: + if (SZ_INT == SZ_INT32) + call achtri (a, b, npix) + else { + call malloc (bp, npix, TY_INT) + call achtri (a, Memi[bp], npix) + call ipak32 (Memi[bp], b, npix) + call mfree (bp, TY_INT) + } + case TY_LONG: + if (SZ_INT == SZ_INT32) + call achtrl (a, b, npix) + else { + call malloc (bp, npix, TY_LONG) + call achtrl (a, Meml[bp], npix) + call ipak32 (Meml[bp], b, npix) + call mfree (bp, TY_LONG) + } + case TY_REAL: + call achtrr (a, b, npix) + case TY_DOUBLE: + call achtrd (a, b, npix) + case TY_COMPLEX: + call achtrx (a, b, npix) + default: + call error (1, "Unknown datatype in imagefile") + } +end diff --git a/sys/imio/tf/impaks.x b/sys/imio/tf/impaks.x new file mode 100644 index 00000000..40168707 --- /dev/null +++ b/sys/imio/tf/impaks.x @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPAK? -- Convert an array of pixels of a specific datatype to the +# datatype given as the final argument. + +procedure impaks (a, b, npix, dtype) + +short a[npix] +int b[npix], npix, dtype + +pointer bp + +begin + switch (dtype) { + case TY_USHORT: + call achtsu (a, b, npix) + case TY_SHORT: + call achtss (a, b, npix) + case TY_INT: + if (SZ_INT == SZ_INT32) + call achtsi (a, b, npix) + else { + call malloc (bp, npix, TY_INT) + call achtsi (a, Memi[bp], npix) + call ipak32 (Memi[bp], b, npix) + call mfree (bp, TY_INT) + } + case TY_LONG: + if (SZ_INT == SZ_INT32) + call achtsl (a, b, npix) + else { + call malloc (bp, npix, TY_LONG) + call achtsl (a, Meml[bp], npix) + call ipak32 (Meml[bp], b, npix) + call mfree (bp, TY_LONG) + } + case TY_REAL: + call achtsr (a, b, npix) + case TY_DOUBLE: + call achtsd (a, b, npix) + case TY_COMPLEX: + call achtsx (a, b, npix) + default: + call error (1, "Unknown datatype in imagefile") + } +end diff --git a/sys/imio/tf/impakx.x b/sys/imio/tf/impakx.x new file mode 100644 index 00000000..1bfcffb9 --- /dev/null +++ b/sys/imio/tf/impakx.x @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPAK? -- Convert an array of pixels of a specific datatype to the +# datatype given as the final argument. + +procedure impakx (a, b, npix, dtype) + +complex a[npix] +int b[npix], npix, dtype + +pointer bp + +begin + switch (dtype) { + case TY_USHORT: + call achtxu (a, b, npix) + case TY_SHORT: + call achtxs (a, b, npix) + case TY_INT: + if (SZ_INT == SZ_INT32) + call achtxi (a, b, npix) + else { + call malloc (bp, npix, TY_INT) + call achtxi (a, Memi[bp], npix) + call ipak32 (Memi[bp], b, npix) + call mfree (bp, TY_INT) + } + case TY_LONG: + if (SZ_INT == SZ_INT32) + call achtxl (a, b, npix) + else { + call malloc (bp, npix, TY_LONG) + call achtxl (a, Meml[bp], npix) + call ipak32 (Meml[bp], b, npix) + call mfree (bp, TY_LONG) + } + case TY_REAL: + call achtxr (a, b, npix) + case TY_DOUBLE: + call achtxd (a, b, npix) + case TY_COMPLEX: + call achtxx (a, b, npix) + default: + call error (1, "Unknown datatype in imagefile") + } +end diff --git a/sys/imio/tf/impgsd.x b/sys/imio/tf/impgsd.x new file mode 100644 index 00000000..c298816e --- /dev/null +++ b/sys/imio/tf/impgsd.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMPGS? -- Put a general section of a specific datatype. + +pointer procedure impgsd (imdes, vs, ve, ndim) + +pointer imdes +long vs[IM_MAXDIM], ve[IM_MAXDIM] +pointer bp, imgobf() +int ndim +extern imflsd() +errchk imflush, imgobf + +begin + # Flush the output buffer, if appropriate. IMFLUSH calls + # one of the IMFLS? routines, which write out the section. + + if (IM_FLUSH(imdes) == YES) + call zcall1 (IM_FLUSHEPA(imdes), imdes) + + # Get an (output) buffer to put the pixels into. Save the + # section parameters in the image descriptor. Save the epa + # of the typed flush procedure in the image descriptor. + + bp = imgobf (imdes, vs, ve, ndim, TY_DOUBLE) + call zlocpr (imflsd, IM_FLUSHEPA(imdes)) + IM_FLUSH(imdes) = YES + + return (bp) +end diff --git a/sys/imio/tf/impgsi.x b/sys/imio/tf/impgsi.x new file mode 100644 index 00000000..62f69105 --- /dev/null +++ b/sys/imio/tf/impgsi.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMPGS? -- Put a general section of a specific datatype. + +pointer procedure impgsi (imdes, vs, ve, ndim) + +pointer imdes +long vs[IM_MAXDIM], ve[IM_MAXDIM] +pointer bp, imgobf() +int ndim +extern imflsi() +errchk imflush, imgobf + +begin + # Flush the output buffer, if appropriate. IMFLUSH calls + # one of the IMFLS? routines, which write out the section. + + if (IM_FLUSH(imdes) == YES) + call zcall1 (IM_FLUSHEPA(imdes), imdes) + + # Get an (output) buffer to put the pixels into. Save the + # section parameters in the image descriptor. Save the epa + # of the typed flush procedure in the image descriptor. + + bp = imgobf (imdes, vs, ve, ndim, TY_INT) + call zlocpr (imflsi, IM_FLUSHEPA(imdes)) + IM_FLUSH(imdes) = YES + + return (bp) +end diff --git a/sys/imio/tf/impgsl.x b/sys/imio/tf/impgsl.x new file mode 100644 index 00000000..d791b4fd --- /dev/null +++ b/sys/imio/tf/impgsl.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMPGS? -- Put a general section of a specific datatype. + +pointer procedure impgsl (imdes, vs, ve, ndim) + +pointer imdes +long vs[IM_MAXDIM], ve[IM_MAXDIM] +pointer bp, imgobf() +int ndim +extern imflsl() +errchk imflush, imgobf + +begin + # Flush the output buffer, if appropriate. IMFLUSH calls + # one of the IMFLS? routines, which write out the section. + + if (IM_FLUSH(imdes) == YES) + call zcall1 (IM_FLUSHEPA(imdes), imdes) + + # Get an (output) buffer to put the pixels into. Save the + # section parameters in the image descriptor. Save the epa + # of the typed flush procedure in the image descriptor. + + bp = imgobf (imdes, vs, ve, ndim, TY_LONG) + call zlocpr (imflsl, IM_FLUSHEPA(imdes)) + IM_FLUSH(imdes) = YES + + return (bp) +end diff --git a/sys/imio/tf/impgsr.x b/sys/imio/tf/impgsr.x new file mode 100644 index 00000000..46938707 --- /dev/null +++ b/sys/imio/tf/impgsr.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMPGS? -- Put a general section of a specific datatype. + +pointer procedure impgsr (imdes, vs, ve, ndim) + +pointer imdes +long vs[IM_MAXDIM], ve[IM_MAXDIM] +pointer bp, imgobf() +int ndim +extern imflsr() +errchk imflush, imgobf + +begin + # Flush the output buffer, if appropriate. IMFLUSH calls + # one of the IMFLS? routines, which write out the section. + + if (IM_FLUSH(imdes) == YES) + call zcall1 (IM_FLUSHEPA(imdes), imdes) + + # Get an (output) buffer to put the pixels into. Save the + # section parameters in the image descriptor. Save the epa + # of the typed flush procedure in the image descriptor. + + bp = imgobf (imdes, vs, ve, ndim, TY_REAL) + call zlocpr (imflsr, IM_FLUSHEPA(imdes)) + IM_FLUSH(imdes) = YES + + return (bp) +end diff --git a/sys/imio/tf/impgss.x b/sys/imio/tf/impgss.x new file mode 100644 index 00000000..bcdf26e0 --- /dev/null +++ b/sys/imio/tf/impgss.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMPGS? -- Put a general section of a specific datatype. + +pointer procedure impgss (imdes, vs, ve, ndim) + +pointer imdes +long vs[IM_MAXDIM], ve[IM_MAXDIM] +pointer bp, imgobf() +int ndim +extern imflss() +errchk imflush, imgobf + +begin + # Flush the output buffer, if appropriate. IMFLUSH calls + # one of the IMFLS? routines, which write out the section. + + if (IM_FLUSH(imdes) == YES) + call zcall1 (IM_FLUSHEPA(imdes), imdes) + + # Get an (output) buffer to put the pixels into. Save the + # section parameters in the image descriptor. Save the epa + # of the typed flush procedure in the image descriptor. + + bp = imgobf (imdes, vs, ve, ndim, TY_SHORT) + call zlocpr (imflss, IM_FLUSHEPA(imdes)) + IM_FLUSH(imdes) = YES + + return (bp) +end diff --git a/sys/imio/tf/impgsx.x b/sys/imio/tf/impgsx.x new file mode 100644 index 00000000..bb56c9aa --- /dev/null +++ b/sys/imio/tf/impgsx.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMPGS? -- Put a general section of a specific datatype. + +pointer procedure impgsx (imdes, vs, ve, ndim) + +pointer imdes +long vs[IM_MAXDIM], ve[IM_MAXDIM] +pointer bp, imgobf() +int ndim +extern imflsx() +errchk imflush, imgobf + +begin + # Flush the output buffer, if appropriate. IMFLUSH calls + # one of the IMFLS? routines, which write out the section. + + if (IM_FLUSH(imdes) == YES) + call zcall1 (IM_FLUSHEPA(imdes), imdes) + + # Get an (output) buffer to put the pixels into. Save the + # section parameters in the image descriptor. Save the epa + # of the typed flush procedure in the image descriptor. + + bp = imgobf (imdes, vs, ve, ndim, TY_COMPLEX) + call zlocpr (imflsx, IM_FLUSHEPA(imdes)) + IM_FLUSH(imdes) = YES + + return (bp) +end diff --git a/sys/imio/tf/impl1d.x b/sys/imio/tf/impl1d.x new file mode 100644 index 00000000..227d25dd --- /dev/null +++ b/sys/imio/tf/impl1d.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMPL1? -- Put a line to an apparently one dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl1d (im) + +pointer im # image header pointer +int fd, nchars +long offset +pointer bp, impgsd(), fwritep() +errchk imopsf + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_DOUBLE) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + offset = IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_DOUBLE + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_DOUBLE + 1) + return (bp) + } + return (impgsd (im, long(1), IM_LEN(im,1), 1)) + } +end diff --git a/sys/imio/tf/impl1i.x b/sys/imio/tf/impl1i.x new file mode 100644 index 00000000..a81d6b73 --- /dev/null +++ b/sys/imio/tf/impl1i.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMPL1? -- Put a line to an apparently one dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl1i (im) + +pointer im # image header pointer +int fd, nchars +long offset +pointer bp, impgsi(), fwritep() +errchk imopsf + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_INT) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + offset = IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_INT + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_INT + 1) + return (bp) + } + return (impgsi (im, long(1), IM_LEN(im,1), 1)) + } +end diff --git a/sys/imio/tf/impl1l.x b/sys/imio/tf/impl1l.x new file mode 100644 index 00000000..8f9616ca --- /dev/null +++ b/sys/imio/tf/impl1l.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMPL1? -- Put a line to an apparently one dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl1l (im) + +pointer im # image header pointer +int fd, nchars +long offset +pointer bp, impgsl(), fwritep() +errchk imopsf + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_LONG) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + offset = IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_LONG + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_LONG + 1) + return (bp) + } + return (impgsl (im, long(1), IM_LEN(im,1), 1)) + } +end diff --git a/sys/imio/tf/impl1r.x b/sys/imio/tf/impl1r.x new file mode 100644 index 00000000..dc0ed92e --- /dev/null +++ b/sys/imio/tf/impl1r.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMPL1? -- Put a line to an apparently one dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl1r (im) + +pointer im # image header pointer +int fd, nchars +long offset +pointer bp, impgsr(), fwritep() +errchk imopsf + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_REAL) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + offset = IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_REAL + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_REAL + 1) + return (bp) + } + return (impgsr (im, long(1), IM_LEN(im,1), 1)) + } +end diff --git a/sys/imio/tf/impl1s.x b/sys/imio/tf/impl1s.x new file mode 100644 index 00000000..a598e92a --- /dev/null +++ b/sys/imio/tf/impl1s.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMPL1? -- Put a line to an apparently one dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl1s (im) + +pointer im # image header pointer +int fd, nchars +long offset +pointer bp, impgss(), fwritep() +errchk imopsf + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_SHORT) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + offset = IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_SHORT + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_SHORT + 1) + return (bp) + } + return (impgss (im, long(1), IM_LEN(im,1), 1)) + } +end diff --git a/sys/imio/tf/impl1x.x b/sys/imio/tf/impl1x.x new file mode 100644 index 00000000..6b141a14 --- /dev/null +++ b/sys/imio/tf/impl1x.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMPL1? -- Put a line to an apparently one dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl1x (im) + +pointer im # image header pointer +int fd, nchars +long offset +pointer bp, impgsx(), fwritep() +errchk imopsf + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_COMPLEX) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + offset = IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_COMPLEX + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_COMPLEX + 1) + return (bp) + } + return (impgsx (im, long(1), IM_LEN(im,1), 1)) + } +end diff --git a/sys/imio/tf/impl2d.x b/sys/imio/tf/impl2d.x new file mode 100644 index 00000000..cd4a1b6e --- /dev/null +++ b/sys/imio/tf/impl2d.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMPL2? -- Put a line to an apparently two dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl2d (im, linenum) + +pointer im # image header pointer +int linenum # line to be written + +int fd, nchars +long vs[2], ve[2], offset +pointer bp, impgsd(), fwritep() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_DOUBLE) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (linenum < 1 || linenum > IM_LEN(im,2)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (linenum - 1) * IM_PHYSLEN(im,1) * SZ_DOUBLE + + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_DOUBLE + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_DOUBLE + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = linenum + ve[2] = linenum + + return (impgsd (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/impl2i.x b/sys/imio/tf/impl2i.x new file mode 100644 index 00000000..9f13e4ef --- /dev/null +++ b/sys/imio/tf/impl2i.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMPL2? -- Put a line to an apparently two dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl2i (im, linenum) + +pointer im # image header pointer +int linenum # line to be written + +int fd, nchars +long vs[2], ve[2], offset +pointer bp, impgsi(), fwritep() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_INT) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (linenum < 1 || linenum > IM_LEN(im,2)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (linenum - 1) * IM_PHYSLEN(im,1) * SZ_INT + + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_INT + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_INT + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = linenum + ve[2] = linenum + + return (impgsi (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/impl2l.x b/sys/imio/tf/impl2l.x new file mode 100644 index 00000000..c42d57cf --- /dev/null +++ b/sys/imio/tf/impl2l.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMPL2? -- Put a line to an apparently two dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl2l (im, linenum) + +pointer im # image header pointer +int linenum # line to be written + +int fd, nchars +long vs[2], ve[2], offset +pointer bp, impgsl(), fwritep() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_LONG) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (linenum < 1 || linenum > IM_LEN(im,2)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (linenum - 1) * IM_PHYSLEN(im,1) * SZ_LONG + + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_LONG + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_LONG + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = linenum + ve[2] = linenum + + return (impgsl (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/impl2r.x b/sys/imio/tf/impl2r.x new file mode 100644 index 00000000..43e84370 --- /dev/null +++ b/sys/imio/tf/impl2r.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMPL2? -- Put a line to an apparently two dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl2r (im, linenum) + +pointer im # image header pointer +int linenum # line to be written + +int fd, nchars +long vs[2], ve[2], offset +pointer bp, impgsr(), fwritep() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_REAL) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (linenum < 1 || linenum > IM_LEN(im,2)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (linenum - 1) * IM_PHYSLEN(im,1) * SZ_REAL + + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_REAL + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_REAL + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = linenum + ve[2] = linenum + + return (impgsr (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/impl2s.x b/sys/imio/tf/impl2s.x new file mode 100644 index 00000000..41bc248f --- /dev/null +++ b/sys/imio/tf/impl2s.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMPL2? -- Put a line to an apparently two dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl2s (im, linenum) + +pointer im # image header pointer +int linenum # line to be written + +int fd, nchars +long vs[2], ve[2], offset +pointer bp, impgss(), fwritep() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_SHORT) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (linenum < 1 || linenum > IM_LEN(im,2)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (linenum - 1) * IM_PHYSLEN(im,1) * SZ_SHORT + + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_SHORT + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_SHORT + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = linenum + ve[2] = linenum + + return (impgss (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/impl2x.x b/sys/imio/tf/impl2x.x new file mode 100644 index 00000000..f16e9725 --- /dev/null +++ b/sys/imio/tf/impl2x.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMPL2? -- Put a line to an apparently two dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl2x (im, linenum) + +pointer im # image header pointer +int linenum # line to be written + +int fd, nchars +long vs[2], ve[2], offset +pointer bp, impgsx(), fwritep() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_COMPLEX) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (linenum < 1 || linenum > IM_LEN(im,2)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (linenum - 1) * IM_PHYSLEN(im,1) * SZ_COMPLEX + + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_COMPLEX + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_COMPLEX + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = linenum + ve[2] = linenum + + return (impgsx (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/impl3d.x b/sys/imio/tf/impl3d.x new file mode 100644 index 00000000..405ef94e --- /dev/null +++ b/sys/imio/tf/impl3d.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMPL3? -- Put a line to an apparently three dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl3d (im, line, band) + +pointer im # image header pointer +int line # line number within band +int band # band number + +int fd, nchars +long vs[3], ve[3], offset +pointer bp, impgsd(), fwritep() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_DOUBLE) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (line < 1 || line > IM_LEN(im,2) || + band < 1 || band > IM_LEN(im,3)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (((band - 1) * IM_PHYSLEN(im,2) + line - 1) * + IM_PHYSLEN(im,1)) * SZ_DOUBLE + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_DOUBLE + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_DOUBLE + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = line + ve[2] = line + vs[3] = band + ve[3] = band + + return (impgsd (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/impl3i.x b/sys/imio/tf/impl3i.x new file mode 100644 index 00000000..0e0d4cd1 --- /dev/null +++ b/sys/imio/tf/impl3i.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMPL3? -- Put a line to an apparently three dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl3i (im, line, band) + +pointer im # image header pointer +int line # line number within band +int band # band number + +int fd, nchars +long vs[3], ve[3], offset +pointer bp, impgsi(), fwritep() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_INT) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (line < 1 || line > IM_LEN(im,2) || + band < 1 || band > IM_LEN(im,3)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (((band - 1) * IM_PHYSLEN(im,2) + line - 1) * + IM_PHYSLEN(im,1)) * SZ_INT + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_INT + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_INT + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = line + ve[2] = line + vs[3] = band + ve[3] = band + + return (impgsi (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/impl3l.x b/sys/imio/tf/impl3l.x new file mode 100644 index 00000000..2471825a --- /dev/null +++ b/sys/imio/tf/impl3l.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMPL3? -- Put a line to an apparently three dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl3l (im, line, band) + +pointer im # image header pointer +int line # line number within band +int band # band number + +int fd, nchars +long vs[3], ve[3], offset +pointer bp, impgsl(), fwritep() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_LONG) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (line < 1 || line > IM_LEN(im,2) || + band < 1 || band > IM_LEN(im,3)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (((band - 1) * IM_PHYSLEN(im,2) + line - 1) * + IM_PHYSLEN(im,1)) * SZ_LONG + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_LONG + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_LONG + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = line + ve[2] = line + vs[3] = band + ve[3] = band + + return (impgsl (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/impl3r.x b/sys/imio/tf/impl3r.x new file mode 100644 index 00000000..675fd8d0 --- /dev/null +++ b/sys/imio/tf/impl3r.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMPL3? -- Put a line to an apparently three dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl3r (im, line, band) + +pointer im # image header pointer +int line # line number within band +int band # band number + +int fd, nchars +long vs[3], ve[3], offset +pointer bp, impgsr(), fwritep() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_REAL) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (line < 1 || line > IM_LEN(im,2) || + band < 1 || band > IM_LEN(im,3)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (((band - 1) * IM_PHYSLEN(im,2) + line - 1) * + IM_PHYSLEN(im,1)) * SZ_REAL + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_REAL + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_REAL + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = line + ve[2] = line + vs[3] = band + ve[3] = band + + return (impgsr (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/impl3s.x b/sys/imio/tf/impl3s.x new file mode 100644 index 00000000..63da06e2 --- /dev/null +++ b/sys/imio/tf/impl3s.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMPL3? -- Put a line to an apparently three dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl3s (im, line, band) + +pointer im # image header pointer +int line # line number within band +int band # band number + +int fd, nchars +long vs[3], ve[3], offset +pointer bp, impgss(), fwritep() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_SHORT) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (line < 1 || line > IM_LEN(im,2) || + band < 1 || band > IM_LEN(im,3)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (((band - 1) * IM_PHYSLEN(im,2) + line - 1) * + IM_PHYSLEN(im,1)) * SZ_SHORT + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_SHORT + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_SHORT + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = line + ve[2] = line + vs[3] = band + ve[3] = band + + return (impgss (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/impl3x.x b/sys/imio/tf/impl3x.x new file mode 100644 index 00000000..85b061cd --- /dev/null +++ b/sys/imio/tf/impl3x.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMPL3? -- Put a line to an apparently three dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl3x (im, line, band) + +pointer im # image header pointer +int line # line number within band +int band # band number + +int fd, nchars +long vs[3], ve[3], offset +pointer bp, impgsx(), fwritep() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_COMPLEX) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (line < 1 || line > IM_LEN(im,2) || + band < 1 || band > IM_LEN(im,3)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (((band - 1) * IM_PHYSLEN(im,2) + line - 1) * + IM_PHYSLEN(im,1)) * SZ_COMPLEX + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_COMPLEX + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_COMPLEX + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = line + ve[2] = line + vs[3] = band + ve[3] = band + + return (impgsx (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/impnld.x b/sys/imio/tf/impnld.x new file mode 100644 index 00000000..b0f9bfd5 --- /dev/null +++ b/sys/imio/tf/impnld.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMPNL -- Put the next line to an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# before the first call to the first line to be written. Each call increments +# the leftmost subscript by one, until V equals IM_LEN, at which time EOF +# is returned. Subsequent writes are ignored. + +int procedure impnld (imdes, lineptr, v) + +pointer imdes +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int npix +int impnln() +extern imflsd() +errchk impnln + +begin + if (IM_FLUSH(imdes) == YES) + call zcall1 (IM_FLUSHEPA(imdes), imdes) + + npix = impnln (imdes, lineptr, v, TY_DOUBLE) + if (IM_FLUSH(imdes) == YES) + call zlocpr (imflsd, IM_FLUSHEPA(imdes)) + + return (npix) +end diff --git a/sys/imio/tf/impnli.x b/sys/imio/tf/impnli.x new file mode 100644 index 00000000..6155a6b6 --- /dev/null +++ b/sys/imio/tf/impnli.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMPNL -- Put the next line to an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# before the first call to the first line to be written. Each call increments +# the leftmost subscript by one, until V equals IM_LEN, at which time EOF +# is returned. Subsequent writes are ignored. + +int procedure impnli (imdes, lineptr, v) + +pointer imdes +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int npix +int impnln() +extern imflsi() +errchk impnln + +begin + if (IM_FLUSH(imdes) == YES) + call zcall1 (IM_FLUSHEPA(imdes), imdes) + + npix = impnln (imdes, lineptr, v, TY_INT) + if (IM_FLUSH(imdes) == YES) + call zlocpr (imflsi, IM_FLUSHEPA(imdes)) + + return (npix) +end diff --git a/sys/imio/tf/impnll.x b/sys/imio/tf/impnll.x new file mode 100644 index 00000000..3fb29144 --- /dev/null +++ b/sys/imio/tf/impnll.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMPNL -- Put the next line to an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# before the first call to the first line to be written. Each call increments +# the leftmost subscript by one, until V equals IM_LEN, at which time EOF +# is returned. Subsequent writes are ignored. + +int procedure impnll (imdes, lineptr, v) + +pointer imdes +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int npix +int impnln() +extern imflsl() +errchk impnln + +begin + if (IM_FLUSH(imdes) == YES) + call zcall1 (IM_FLUSHEPA(imdes), imdes) + + npix = impnln (imdes, lineptr, v, TY_LONG) + if (IM_FLUSH(imdes) == YES) + call zlocpr (imflsl, IM_FLUSHEPA(imdes)) + + return (npix) +end diff --git a/sys/imio/tf/impnlr.x b/sys/imio/tf/impnlr.x new file mode 100644 index 00000000..c60c8631 --- /dev/null +++ b/sys/imio/tf/impnlr.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMPNL -- Put the next line to an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# before the first call to the first line to be written. Each call increments +# the leftmost subscript by one, until V equals IM_LEN, at which time EOF +# is returned. Subsequent writes are ignored. + +int procedure impnlr (imdes, lineptr, v) + +pointer imdes +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int npix +int impnln() +extern imflsr() +errchk impnln + +begin + if (IM_FLUSH(imdes) == YES) + call zcall1 (IM_FLUSHEPA(imdes), imdes) + + npix = impnln (imdes, lineptr, v, TY_REAL) + if (IM_FLUSH(imdes) == YES) + call zlocpr (imflsr, IM_FLUSHEPA(imdes)) + + return (npix) +end diff --git a/sys/imio/tf/impnls.x b/sys/imio/tf/impnls.x new file mode 100644 index 00000000..af85bf8a --- /dev/null +++ b/sys/imio/tf/impnls.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMPNL -- Put the next line to an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# before the first call to the first line to be written. Each call increments +# the leftmost subscript by one, until V equals IM_LEN, at which time EOF +# is returned. Subsequent writes are ignored. + +int procedure impnls (imdes, lineptr, v) + +pointer imdes +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int npix +int impnln() +extern imflss() +errchk impnln + +begin + if (IM_FLUSH(imdes) == YES) + call zcall1 (IM_FLUSHEPA(imdes), imdes) + + npix = impnln (imdes, lineptr, v, TY_SHORT) + if (IM_FLUSH(imdes) == YES) + call zlocpr (imflss, IM_FLUSHEPA(imdes)) + + return (npix) +end diff --git a/sys/imio/tf/impnlx.x b/sys/imio/tf/impnlx.x new file mode 100644 index 00000000..e76cf1f1 --- /dev/null +++ b/sys/imio/tf/impnlx.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMPNL -- Put the next line to an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# before the first call to the first line to be written. Each call increments +# the leftmost subscript by one, until V equals IM_LEN, at which time EOF +# is returned. Subsequent writes are ignored. + +int procedure impnlx (imdes, lineptr, v) + +pointer imdes +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int npix +int impnln() +extern imflsx() +errchk impnln + +begin + if (IM_FLUSH(imdes) == YES) + call zcall1 (IM_FLUSHEPA(imdes), imdes) + + npix = impnln (imdes, lineptr, v, TY_COMPLEX) + if (IM_FLUSH(imdes) == YES) + call zlocpr (imflsx, IM_FLUSHEPA(imdes)) + + return (npix) +end diff --git a/sys/imio/tf/imps1d.x b/sys/imio/tf/imps1d.x new file mode 100644 index 00000000..c8dd82b1 --- /dev/null +++ b/sys/imio/tf/imps1d.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMPS1? -- Put a section to an apparently one dimensional image. + +pointer procedure imps1d (im, x1, x2) + +pointer im # image header pointer +int x1 # first column +int x2 # last column + +pointer impgsd(), impl1d() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1)) + return (impl1d (im)) + else + return (impgsd (im, long(x1), long(x2), 1)) +end diff --git a/sys/imio/tf/imps1i.x b/sys/imio/tf/imps1i.x new file mode 100644 index 00000000..cb97a374 --- /dev/null +++ b/sys/imio/tf/imps1i.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMPS1? -- Put a section to an apparently one dimensional image. + +pointer procedure imps1i (im, x1, x2) + +pointer im # image header pointer +int x1 # first column +int x2 # last column + +pointer impgsi(), impl1i() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1)) + return (impl1i (im)) + else + return (impgsi (im, long(x1), long(x2), 1)) +end diff --git a/sys/imio/tf/imps1l.x b/sys/imio/tf/imps1l.x new file mode 100644 index 00000000..c8f5aae4 --- /dev/null +++ b/sys/imio/tf/imps1l.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMPS1? -- Put a section to an apparently one dimensional image. + +pointer procedure imps1l (im, x1, x2) + +pointer im # image header pointer +int x1 # first column +int x2 # last column + +pointer impgsl(), impl1l() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1)) + return (impl1l (im)) + else + return (impgsl (im, long(x1), long(x2), 1)) +end diff --git a/sys/imio/tf/imps1r.x b/sys/imio/tf/imps1r.x new file mode 100644 index 00000000..1bd1434c --- /dev/null +++ b/sys/imio/tf/imps1r.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMPS1? -- Put a section to an apparently one dimensional image. + +pointer procedure imps1r (im, x1, x2) + +pointer im # image header pointer +int x1 # first column +int x2 # last column + +pointer impgsr(), impl1r() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1)) + return (impl1r (im)) + else + return (impgsr (im, long(x1), long(x2), 1)) +end diff --git a/sys/imio/tf/imps1s.x b/sys/imio/tf/imps1s.x new file mode 100644 index 00000000..130e7f18 --- /dev/null +++ b/sys/imio/tf/imps1s.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMPS1? -- Put a section to an apparently one dimensional image. + +pointer procedure imps1s (im, x1, x2) + +pointer im # image header pointer +int x1 # first column +int x2 # last column + +pointer impgss(), impl1s() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1)) + return (impl1s (im)) + else + return (impgss (im, long(x1), long(x2), 1)) +end diff --git a/sys/imio/tf/imps1x.x b/sys/imio/tf/imps1x.x new file mode 100644 index 00000000..5a5c33a0 --- /dev/null +++ b/sys/imio/tf/imps1x.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMPS1? -- Put a section to an apparently one dimensional image. + +pointer procedure imps1x (im, x1, x2) + +pointer im # image header pointer +int x1 # first column +int x2 # last column + +pointer impgsx(), impl1x() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1)) + return (impl1x (im)) + else + return (impgsx (im, long(x1), long(x2), 1)) +end diff --git a/sys/imio/tf/imps2d.x b/sys/imio/tf/imps2d.x new file mode 100644 index 00000000..e3f36fd9 --- /dev/null +++ b/sys/imio/tf/imps2d.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMPS2? -- Put a section to an apparently two dimensional image. + +pointer procedure imps2d (im, x1, x2, y1, y2) + +pointer im +int x1, x2, y1, y2 +long vs[2], ve[2] +pointer impgsd(), impl2d() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2) + return (impl2d (im, y1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + return (impgsd (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imps2i.x b/sys/imio/tf/imps2i.x new file mode 100644 index 00000000..57e3f36c --- /dev/null +++ b/sys/imio/tf/imps2i.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMPS2? -- Put a section to an apparently two dimensional image. + +pointer procedure imps2i (im, x1, x2, y1, y2) + +pointer im +int x1, x2, y1, y2 +long vs[2], ve[2] +pointer impgsi(), impl2i() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2) + return (impl2i (im, y1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + return (impgsi (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imps2l.x b/sys/imio/tf/imps2l.x new file mode 100644 index 00000000..2d7bc8b7 --- /dev/null +++ b/sys/imio/tf/imps2l.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMPS2? -- Put a section to an apparently two dimensional image. + +pointer procedure imps2l (im, x1, x2, y1, y2) + +pointer im +int x1, x2, y1, y2 +long vs[2], ve[2] +pointer impgsl(), impl2l() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2) + return (impl2l (im, y1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + return (impgsl (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imps2r.x b/sys/imio/tf/imps2r.x new file mode 100644 index 00000000..ce8b2958 --- /dev/null +++ b/sys/imio/tf/imps2r.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMPS2? -- Put a section to an apparently two dimensional image. + +pointer procedure imps2r (im, x1, x2, y1, y2) + +pointer im +int x1, x2, y1, y2 +long vs[2], ve[2] +pointer impgsr(), impl2r() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2) + return (impl2r (im, y1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + return (impgsr (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imps2s.x b/sys/imio/tf/imps2s.x new file mode 100644 index 00000000..c5993a61 --- /dev/null +++ b/sys/imio/tf/imps2s.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMPS2? -- Put a section to an apparently two dimensional image. + +pointer procedure imps2s (im, x1, x2, y1, y2) + +pointer im +int x1, x2, y1, y2 +long vs[2], ve[2] +pointer impgss(), impl2s() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2) + return (impl2s (im, y1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + return (impgss (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imps2x.x b/sys/imio/tf/imps2x.x new file mode 100644 index 00000000..12db84a5 --- /dev/null +++ b/sys/imio/tf/imps2x.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMPS2? -- Put a section to an apparently two dimensional image. + +pointer procedure imps2x (im, x1, x2, y1, y2) + +pointer im +int x1, x2, y1, y2 +long vs[2], ve[2] +pointer impgsx(), impl2x() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2) + return (impl2x (im, y1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + return (impgsx (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imps3d.x b/sys/imio/tf/imps3d.x new file mode 100644 index 00000000..0cd67b5e --- /dev/null +++ b/sys/imio/tf/imps3d.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMPS3? -- Put a section to an apparently three dimensional image. + +pointer procedure imps3d (im, x1, x2, y1, y2, z1, z2) + +pointer im +int x1, x2, y1, y2, z1, z2 +long vs[3], ve[3] +pointer impgsd(), impl3d() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2 && z1 == z2) + return (impl3d (im, y1, z1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + vs[3] = z1 + ve[3] = z2 + + return (impgsd (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imps3i.x b/sys/imio/tf/imps3i.x new file mode 100644 index 00000000..9ec4a832 --- /dev/null +++ b/sys/imio/tf/imps3i.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMPS3? -- Put a section to an apparently three dimensional image. + +pointer procedure imps3i (im, x1, x2, y1, y2, z1, z2) + +pointer im +int x1, x2, y1, y2, z1, z2 +long vs[3], ve[3] +pointer impgsi(), impl3i() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2 && z1 == z2) + return (impl3i (im, y1, z1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + vs[3] = z1 + ve[3] = z2 + + return (impgsi (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imps3l.x b/sys/imio/tf/imps3l.x new file mode 100644 index 00000000..a68b2de5 --- /dev/null +++ b/sys/imio/tf/imps3l.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMPS3? -- Put a section to an apparently three dimensional image. + +pointer procedure imps3l (im, x1, x2, y1, y2, z1, z2) + +pointer im +int x1, x2, y1, y2, z1, z2 +long vs[3], ve[3] +pointer impgsl(), impl3l() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2 && z1 == z2) + return (impl3l (im, y1, z1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + vs[3] = z1 + ve[3] = z2 + + return (impgsl (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imps3r.x b/sys/imio/tf/imps3r.x new file mode 100644 index 00000000..4fcbecff --- /dev/null +++ b/sys/imio/tf/imps3r.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMPS3? -- Put a section to an apparently three dimensional image. + +pointer procedure imps3r (im, x1, x2, y1, y2, z1, z2) + +pointer im +int x1, x2, y1, y2, z1, z2 +long vs[3], ve[3] +pointer impgsr(), impl3r() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2 && z1 == z2) + return (impl3r (im, y1, z1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + vs[3] = z1 + ve[3] = z2 + + return (impgsr (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imps3s.x b/sys/imio/tf/imps3s.x new file mode 100644 index 00000000..3758b3b9 --- /dev/null +++ b/sys/imio/tf/imps3s.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMPS3? -- Put a section to an apparently three dimensional image. + +pointer procedure imps3s (im, x1, x2, y1, y2, z1, z2) + +pointer im +int x1, x2, y1, y2, z1, z2 +long vs[3], ve[3] +pointer impgss(), impl3s() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2 && z1 == z2) + return (impl3s (im, y1, z1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + vs[3] = z1 + ve[3] = z2 + + return (impgss (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imps3x.x b/sys/imio/tf/imps3x.x new file mode 100644 index 00000000..7062a3c1 --- /dev/null +++ b/sys/imio/tf/imps3x.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMPS3? -- Put a section to an apparently three dimensional image. + +pointer procedure imps3x (im, x1, x2, y1, y2, z1, z2) + +pointer im +int x1, x2, y1, y2, z1, z2 +long vs[3], ve[3] +pointer impgsx(), impl3x() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2 && z1 == z2) + return (impl3x (im, y1, z1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + vs[3] = z1 + ve[3] = z2 + + return (impgsx (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imupkd.x b/sys/imio/tf/imupkd.x new file mode 100644 index 00000000..ffbbe81e --- /dev/null +++ b/sys/imio/tf/imupkd.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMUPK? -- Convert an array of pixels of datatype DTYPE into the datatype +# specified by the IMUPK? suffix character. + +procedure imupkd (a, b, npix, dtype) + +double b[npix] +int a[npix], npix, dtype + +pointer bp + +begin + switch (dtype) { + case TY_USHORT: + call achtud (a, b, npix) + case TY_SHORT: + call achtsd (a, b, npix) + case TY_INT: + call achtid (a, b, npix) + case TY_LONG: + call achtld (a, b, npix) + case TY_REAL: + call achtrd (a, b, npix) + case TY_DOUBLE: + call achtdd (a, b, npix) + case TY_COMPLEX: + call achtxd (a, b, npix) + default: + call error (1, "Unknown datatype in imagefile") + } +end + + diff --git a/sys/imio/tf/imupki.x b/sys/imio/tf/imupki.x new file mode 100644 index 00000000..0703b22b --- /dev/null +++ b/sys/imio/tf/imupki.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMUPK? -- Convert an array of pixels of datatype DTYPE into the datatype +# specified by the IMUPK? suffix character. + +procedure imupki (a, b, npix, dtype) + +int b[npix] +int a[npix], npix, dtype + +pointer bp + +begin + switch (dtype) { + case TY_USHORT: + call achtui (a, b, npix) + case TY_SHORT: + call achtsi (a, b, npix) + case TY_INT: + call achtii (a, b, npix) + case TY_LONG: + call achtli (a, b, npix) + case TY_REAL: + call achtri (a, b, npix) + case TY_DOUBLE: + call achtdi (a, b, npix) + case TY_COMPLEX: + call achtxi (a, b, npix) + default: + call error (1, "Unknown datatype in imagefile") + } +end + + diff --git a/sys/imio/tf/imupkl.x b/sys/imio/tf/imupkl.x new file mode 100644 index 00000000..1b144e29 --- /dev/null +++ b/sys/imio/tf/imupkl.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMUPK? -- Convert an array of pixels of datatype DTYPE into the datatype +# specified by the IMUPK? suffix character. + +procedure imupkl (a, b, npix, dtype) + +long b[npix] +int a[npix], npix, dtype + +pointer bp + +begin + switch (dtype) { + case TY_USHORT: + call achtul (a, b, npix) + case TY_SHORT: + call achtsl (a, b, npix) + case TY_INT: + call achtil (a, b, npix) + case TY_LONG: + call achtll (a, b, npix) + case TY_REAL: + call achtrl (a, b, npix) + case TY_DOUBLE: + call achtdl (a, b, npix) + case TY_COMPLEX: + call achtxl (a, b, npix) + default: + call error (1, "Unknown datatype in imagefile") + } +end + + diff --git a/sys/imio/tf/imupkr.x b/sys/imio/tf/imupkr.x new file mode 100644 index 00000000..0cfccefc --- /dev/null +++ b/sys/imio/tf/imupkr.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMUPK? -- Convert an array of pixels of datatype DTYPE into the datatype +# specified by the IMUPK? suffix character. + +procedure imupkr (a, b, npix, dtype) + +real b[npix] +int a[npix], npix, dtype + +pointer bp + +begin + switch (dtype) { + case TY_USHORT: + call achtur (a, b, npix) + case TY_SHORT: + call achtsr (a, b, npix) + case TY_INT: + call achtir (a, b, npix) + case TY_LONG: + call achtlr (a, b, npix) + case TY_REAL: + call achtrr (a, b, npix) + case TY_DOUBLE: + call achtdr (a, b, npix) + case TY_COMPLEX: + call achtxr (a, b, npix) + default: + call error (1, "Unknown datatype in imagefile") + } +end + + diff --git a/sys/imio/tf/imupks.x b/sys/imio/tf/imupks.x new file mode 100644 index 00000000..93d0ad3f --- /dev/null +++ b/sys/imio/tf/imupks.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMUPK? -- Convert an array of pixels of datatype DTYPE into the datatype +# specified by the IMUPK? suffix character. + +procedure imupks (a, b, npix, dtype) + +short b[npix] +int a[npix], npix, dtype + +pointer bp + +begin + switch (dtype) { + case TY_USHORT: + call achtus (a, b, npix) + case TY_SHORT: + call achtss (a, b, npix) + case TY_INT: + call achtis (a, b, npix) + case TY_LONG: + call achtls (a, b, npix) + case TY_REAL: + call achtrs (a, b, npix) + case TY_DOUBLE: + call achtds (a, b, npix) + case TY_COMPLEX: + call achtxs (a, b, npix) + default: + call error (1, "Unknown datatype in imagefile") + } +end + + diff --git a/sys/imio/tf/imupkx.x b/sys/imio/tf/imupkx.x new file mode 100644 index 00000000..916bb73b --- /dev/null +++ b/sys/imio/tf/imupkx.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMUPK? -- Convert an array of pixels of datatype DTYPE into the datatype +# specified by the IMUPK? suffix character. + +procedure imupkx (a, b, npix, dtype) + +complex b[npix] +int a[npix], npix, dtype + +pointer bp + +begin + switch (dtype) { + case TY_USHORT: + call achtux (a, b, npix) + case TY_SHORT: + call achtsx (a, b, npix) + case TY_INT: + call achtix (a, b, npix) + case TY_LONG: + call achtlx (a, b, npix) + case TY_REAL: + call achtrx (a, b, npix) + case TY_DOUBLE: + call achtdx (a, b, npix) + case TY_COMPLEX: + call achtxx (a, b, npix) + default: + call error (1, "Unknown datatype in imagefile") + } +end + + diff --git a/sys/imio/tf/mkpkg b/sys/imio/tf/mkpkg new file mode 100644 index 00000000..a79ca832 --- /dev/null +++ b/sys/imio/tf/mkpkg @@ -0,0 +1,123 @@ +# Update the type specific (generically expanded) IMIO procedures. + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + imflsd.x + imflsi.x + imflsl.x + imflsr.x + imflss.x + imflsx.x + imggsd.x + imggsi.x + imggsl.x + imggsr.x + imggss.x + imggsx.x + imgl1d.x + imgl1i.x + imgl1l.x + imgl1r.x + imgl1s.x + imgl1x.x + imgl2d.x + imgl2i.x + imgl2l.x + imgl2r.x + imgl2s.x + imgl2x.x + imgl3d.x + imgl3i.x + imgl3l.x + imgl3r.x + imgl3s.x + imgl3x.x + imgnld.x + imgnli.x + imgnll.x + imgnlr.x + imgnls.x + imgnlx.x + imgs1d.x + imgs1i.x + imgs1l.x + imgs1r.x + imgs1s.x + imgs1x.x + imgs2d.x + imgs2i.x + imgs2l.x + imgs2r.x + imgs2s.x + imgs2x.x + imgs3d.x + imgs3i.x + imgs3l.x + imgs3r.x + imgs3s.x + imgs3x.x + impakd.x + impaki.x + impakl.x + impakr.x + impaks.x + impakx.x + impgsd.x + impgsi.x + impgsl.x + impgsr.x + impgss.x + impgsx.x + impl1d.x + impl1i.x + impl1l.x + impl1r.x + impl1s.x + impl1x.x + impl2d.x + impl2i.x + impl2l.x + impl2r.x + impl2s.x + impl2x.x + impl3d.x + impl3i.x + impl3l.x + impl3r.x + impl3s.x + impl3x.x + impnld.x + impnli.x + impnll.x + impnlr.x + impnls.x + impnlx.x + imps1d.x + imps1i.x + imps1l.x + imps1r.x + imps1s.x + imps1x.x + imps2d.x + imps2i.x + imps2l.x + imps2r.x + imps2s.x + imps2x.x + imps3d.x + imps3i.x + imps3l.x + imps3r.x + imps3s.x + imps3x.x + imupkd.x + imupki.x + imupkl.x + imupkr.x + imupks.x + imupkx.x + ; diff --git a/sys/imio/zzdebug.x b/sys/imio/zzdebug.x new file mode 100644 index 00000000..2772b27c --- /dev/null +++ b/sys/imio/zzdebug.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +task imt = t_imt + +# IMT -- Test the image template package. + +procedure t_imt() + +char template[SZ_LINE] +char image[SZ_FNAME] +pointer imt, imtopen() +int imtgetim() + +begin + call clgstr ("template", template, SZ_LINE) + imt = imtopen (template) + + while (imtgetim (imt, image, SZ_FNAME) != EOF) { + call printf ("%s\n") + call pargstr (image) + } + + call imtclose (imt) +end diff --git a/sys/ki/README b/sys/ki/README new file mode 100644 index 00000000..147ee538 --- /dev/null +++ b/sys/ki/README @@ -0,0 +1,648 @@ + Kernel Interface Package + 12-May-85 dct + (21-Aug-85) + + +1. Introduction + + The kernel interface package (KI) isolates the IRAF virtual operating +system (VOS) from the IRAF kernel, permitting access either to the local +kernel or to an IRAF kernel resident on a remote host, via an IRAF kernel +server (KS). The KI provides access to files, peripherals and devices, +and subprocesses irrespective of whether the resource is located on the +local machine or on a remote node. Since the KI is implemented on top of +the IRAF kernel the different nodes may run different native operating systems. + + + +-----------+ + | | VOS = virtual operating system + | V O S | KI = kernel interface + | | KS = kernel server + +-----------+ + | : + | + +-----------+ : +-----------+ + | | | | + | K I |=========:========| K S |==== (etc) + | | | | + +-----------+ : +-----------+ + | | + | : | + +-----------+ +-----------+ + | | : | | + | local | | remote | + | kernel | : | kernel | + | | | | + +-----------+ : +-----------+ + + : + (host1) (host2) + + + Architecture of the Kernel Interface + + +2. Conceptual Design + + The purpose of the kernel interface is to permit access to logical files, +devices, and subprocesses regardless of where such objects physically reside +in a network. This permits sharing of peripherals such as image displays and +plotters, data sharing (centralized databases), load sharing (running of +subprocesses on lightly loaded nodes), and makes such mundane operations as +copying a file between two nodes possible without developing special purpose +software and further complicating the user interface. + +By addressing these problems by implementation of an interface just above +the IRAF kernel it becomes possible to remotely access nodes running different +native operating systems, e.g., UNIX and VMS, with the IRAF kernel on each host +system resolving the differences between file formats and filenames found +on the different host systems. Full access to text files and raw peripherals +is inherent in the scheme regardless of the architecture of the host machine. +Full access to binary datafiles is possible provided the binary format is +machine independent, a desirable goal in any case. + +The kernel interface is conceived as an optional and invisible interface +between the IRAF virtual operating system and the IRAF kernel. +The specifications of the kernel are not affected by the KI, except for the +addition of a new device driver for talking to remote kernel servers. The VOS +sees the same kernel interface whether or not the system is configured with a +KI. + +A VOS call to a kernel procedure such as ZOPNBF, for example, is directed +instead to the KI procedure KOPNBF which in turn calls either the local ZOPNBF +or passes the call to a remote KS. The VOS still calls the procedure "zopnbf", +but the external name of this procedure is redefined in as "kopnbf", +permitted substitution of the KI merely by recompilation. When the file is +opened a channel descriptor is allocated within the KI telling whether the +channel is local or remote, and if remote giving the KS address on the net, +and giving the kernel channel number of the file on the node on which it +resides. The KI channel number instead of the kernel channel number is +returned to the VOS. Subsequent i/o requests on the channel are also processed +by the KI, which uses the channel descriptor to determine whether the file +is local or remote and then fulfils the request. + + +3. Other Network Interfaces + + The kernel interface is not intended to replace or compete with "real" +network implmentations such as NFS or DECNET. If the local net provides such +facilities then remote access via the host network is equivalent to a local +file reference. Few such commercial networks, however, permit equivalent +access when the different nodes run different operating systems. +Often the type of access provided by the network is restricted in some way, +e.g., NFS permits transparent access to remote files but not to remote devices. +On VMS an IRAF kernel routine which accesses an i/o channel at the QIO level +is bypassing DECNET hence can only be used to access a local device. +The kernel server approach neatly sidesteps these problems without preventing +use of the host networking facilities in cases were it is desirable to do so. + + +4. Performance + + The overhead of the KI for a local file access is one additional procedure +call per i/o request, e.g., an additional 20-30 microseconds per i/o request. +A remote file access requires encoding of the request as a KI instruction, +transmission of the instruction to the remote host, decoding of the instruction +by the remote host, a kernel access on the remote host, and in the case of a +read request transmission of the data back to the requesting node where it is +read out into the caller's buffer. Handshaking is required to return the status +value after reads and writes to a remote node, hence large transfers will +significantly reduce the overhead involved in remote file access. Large data +transfers are automatically transferred in segments by the interface code, +hence there is no builtin limit on the size of a transfer. + +A file open or process spawn requiring connection to a kernel server on a +remote host is a relatively expensive procedure since it requires spawning of +the kernel server process on the remote host. Once a process has connected to +a kernel server on a remote host that server will remain connected for the +life of the local process, with the single connection providing simultaneous +access to any number of files, devices, or child processes on the remote host. +Each local process requires its own kernel server process on the remote node. + + +5. Modifications to the Existing I/O System + + As noted above, implementation of the KI should require minimal +modifications to existing software. The specific modifications or additions +required appear to be the following: + + +additions: + + add package KI (kernel interface) + add source for the KS (kernel server) process + add KS device driver to the kernel (package OS) + add ZGHOST (get hostname) primitive to OS + add SPP and LIBC include files to map zroutine names + + +modifications: + + add reference to to VOS procedures which access kernel + finit.h: install kernel server device driver at process startup + modify filename mapping: + do not map filenames which begin with a node name + prepend CWD to relative filenames if CWD is on a remote node (?) + + +6. Filenames + + Files and processes anywhere in the network may be accessed by prepending +the node name to the VFN or OSFN of the file. In essence we have extended +the VFN filename syntax to support node names. The syntax is as follows: + + node "!" filename + +The field delimiter "!" is used because it is not used in filenames in AOS, +UNIX, or VMS. The delimiters ":" and "::", commonly used as node name +delimiters in commercial networds, were intentionally not used so that network +filenames may be specified without conflict on systems with host network +support. Typical filenames using this notation are shown below. + + 2!/dev/iis + 1!lib$motd + 3!dra0:[user.data]pic.db + +An important consideration in choosing the node delimiter character is that +it not be necessary to quote filenames in common everyday usage. It turns out +that in the CL "command mode" the character ! is only recognized as a +metacharacter when it occurs at the beginning of a command (as the OS escape), +hence quoting of filenames containing ! will not be necessary. + +The strategy for resolving such filenames is as follows. The full filename +including the nodename is passed to the filename mapping code on the local +machine. If the filename includes a nodename the filename is not mapped. +The KI receives the filename and strips off the nodename, using it to +select the node which will execute the kernel primitive. The remainder of +the filename (minus the nodename) is passed to the KS on the addressed node, +and the KS performs the filename mapping and passes the mapped filename on +to the IRAF kernel. Since the filename mapping is carried out by the KS on +the remote node the filename will be mapped in the context of the remote +machine, i.e., the mapping will depend upon the native operating system used +on the remote node. If the KS is itself configured with a kernel interface, +multiple indirection is possible, permitting gateways onto other networks, +e.g., "gateway!node!filename". + +There should be no penalty for using a self referential node name in a +filename, i.e., the system should be smart enough to ignore node names +when the node named is the local node. This permits use of the same absolute +network filenames in configuration tables on all nodes, without having to +maintain different sources on the different nodes. + +Fully functional filename mapping requires that the IRAF environment variables +used by a process on the local machine be propagated to the kernel server on +the remote machine. If this is not done then package directory references, +etc., appearing in virtual filenames will not be resolved. The kernel server +will inherit all environment variables except iraf$, since logical directory +names of the form "node!ldir$file" must be expanded relative to the iraf +root directory on the remote node. User defined logical directories should +include an explicit node name to permit access from any node. + + +6.1 External KI Procedures + + The majority of the KI procedures are internal, since the KI interface +is hidden behind the procedure redefinitions in . Other subsystems +of the VOS do however occasionally need access to the KI, and the following +procedures are provided for this purpose. + + + ki_extnode - Extract (or delimit) the node name field + ki_mapchan - Map KI channel into OS channel (or pid) and node name + + len_prefix = ki_extnode (resource, nodename, maxch, nchars) + oschan = ki_mapchan (kichan, nodename, maxch) + + +The EXTNODE function is used to extract the node name from a resource name, +e.g., to produce a simpler name as required by the low level code, or to +propagate the node name prefix to a second resource name. The MAPCHAN function +is used to convert a KI channel descriptor into the corresponding OS channel +number and node name, e.g., for output to the user (the KI channel code is +meaningless to the user). + + +7. KI Procedures + + Only those procedures in the IRAF kernel which take a filename as an operand +or which do i/o to a file (or to IPC) need be mapped by the kernel interface. +This subset of the kernel includes all the file primitives, all the device +drivers, and some exception handling procedures. + + zfacss - determine file accessibility + zfaloc - allocate a file + zfchdr - change default directory (??) + zfdele - delete a file + zfgcwd - get default directory (??) + zfinfo - get directory info on a file + zfmkcp - make a null length copy of a file + zfprot - set, remove, or query file protection + zfrnam - rename a file + zopdir - open a directory + zgfdir - get next filename from a directory + + zopdpr - open a detached process + zcldpr - close a detached process + zopcpr - open a connected subprocess + zclcpr - close a connected subprocess + zintpr - interrupt a subprocess + + zfiobf - binary file driver + zfiolp - line printer driver + zfiomt - magtape driver + zfiopl - plotter driver + zfiopr - ipc driver + zfiosf - static file driver + zfiotx - text file driver + zfioty - terminal driver + + +The basic function of a KI procedure is to determine which host is to execute +the kernel primitive, call the local or remote kernel to execute the primitive, +and return the results to the calling program. + + +7.1 Pseudocode for a KI Procedure + + Consider the common case of reading a file on a remote host. The file +open procedure must connect to the KS on the remote host, command the remote +kernel to open the file, and read back the status of the open. Whether the +file is on the local or remote node, a channel descriptor must be set up +to tell the KI i/o primitives how to access the file. + + +# KOPNBF -- KI version of ZOPNBF (open binary file). + +procedure kopnbf (osfn, mode, status) + +begin + ks = get_kernel_server (osfn) + if (ks is the local node) + call zopnbf (osfn, mode, status) + else { + encode KI instruction for zopnbf + write instruction to KS + read reply from KS + if (error on channel to KS) + return (status=ERR) + } + + set up channel descriptor (set channel codes of KS and file) +end + + +# GET_KERNEL_SERVER -- Return a channel to the kernel server controlling +# a virtual filename. + +int procedure get_kernel_server (vfn) + +begin + extract node name from vfn + if (no node name given) + return (0) + else if (node is already connected) + return (node channel) + else { + connect to the KS on the remote node + save channel of node in channel table + return (node channel) + } +end + + +# KARDBF -- KI version of ZARDBF (read from a binary file). The read will not +# be asynchronous if the file is resident on a remote node. The size of a +# transfer is not limited by the maximum block of the channel. + +procedure kardbf (chan, buf, maxchars, offset) + +begin + if (ks[chan] == 0) + call zardbf (chan, buf, maxchars, offset) + else { + encode KI instruction for ZARDBF + write KI instruction to remote kernel server + read back the KI header of the response + + if (read status ok and KI status for read ok) { + transfer data from channel directly into callers buffer, + in blocks no larger than the channel block size + save channel status for KAWTBF + } + } +end + + +7.2 Data Structures + + The data structures required by the kernel interface are small and are +statically allocated. + + +7.2.1 Host Name Table + + The host name table (HNT) lists all of the hosts in the network which the +KI can access, giving for each node the node filename of the kernel server +process on that node, and a list of aliases (node names) for the node. +The host name table is the text file "dev$hosts". The format of the file +is illustrated by the following example: + + + 1!/iraf/lib/irafks.e : 1 a vax1 aquila + 2!/iraf/lib/irafks.e : 2 b vax2 lyra + 3!usr1\:[irafx.lib]irafks.exe : 3 vax3 vela + 5!/iraf/lib/irafks.e : 5 c vax5 carina + 6!usr1\:[irafx.lib]irafks.exe : 6 vax6 draco + 11!/iraf/lib/irafks.e : 11 sun1 petunia + + +The format of an entry in this table is "server ':' aliases", where "server" +is a machine dependent, colon delimited string to be passed to the ZFIOKS +driver, and where the aliases are a sequence of null delimited logical names +by which the high level code or the user can refer to the nodes. The first +field, e.g., "server", is limited to 80 characters, the aliases to 8 characters +(longer names will be silently truncated, either limit may be increased if +necessary). Up to 8 aliases may be specified. The alias "0" will be +automatically added to the alias list of the local node by the KI; this alias +is used by the high level code to force a file to be accessed on the local node. +The local node should also include as an alias the name returned by ZGHOST. +The maximum number of nodes is a parameter. The entries may appear +in any order. + + +7.2.2 Node Descriptor Table + + For each entry in the host name table there is a corresponding entry in +the node descriptor table (NDT). The fields of the NDT are initialized +when the first filename containing a node reference is processed. When a +kernel server is opened on a node the N_KSCHAN field is set to the channel +code returned by the kernel server device driver. + + + int n_nnodes # number of nodes in table + + struct node_descriptor { + int n_kschan # KS i/o channel or NULL + int n_local # set to YES for the local node + int n_nalias # number of aliases for this node + char n_server[64] # netname!process + char n_alias[8,8] # aliases + } ndt[MAX_NODES] + + +Runtime node references are satisfied by searching the NDT for the specified +alias. If the referenced node is the local node a NULL channel number is +returned. If the N_KSCHAN field of the referenced node is null a kernel +server is spawned and the channel number of the server returned. If a kernel +server is already connected mapping an alias into a channel number is very +fast (compared to a file open). Once a server is spawned it remains connected +until the local process shuts down. + + +7.2.3 Channel Descriptor Table + + Each open file or connected subprocess requires one channel descriptor +for each i/o channel or process id. The K_KSCHAN field will contain NULL if +the channel resides on the local node. Channel descriptors are allocated at +file or device open time or process connect time and are freed at close or +disconnect time. If the channel is connected to a kernel server, the K_OSCHAN +and K_PID fields will contain the OS channel number or process id of the +resource as returned by the kernel server on the remote node. + + + struct channel_descriptor { + int k_kschan # KS channel (NULL if local node) + int k_oschan # OS channel number or PID + int k_status # status for the ZAWAIT call + } cdt[MAX_CHANNELS] + + +7.3 KII Instruction Format + + The kernel interface instruction format (KII) is the binary encoding of +the data blocks sent to and received from the remote kernel server to execute +a call to a kernel procedure. This format is machine independent, i.e., +it is defined in a way that is independent of the byte ordering, char size, +etc. used by a node. The KII format provides a machine independent interface +for the execution of all kernel subroutines as well as for text file i/o. +Binary data blocks passed via the binary file i/o procedures are not affected, +hence if a machine independent binary format is desired it must be implemented +at a level higher than the KI. + +The KII format selected is a fixed format to simplify encode/decode and +packet transfer (if the transfer medium is stream oriented fixed size packets +are simpler to extract from the stream). For media such as Ethernet +performance depends more upon the number of packets transferred than upon +the size of a packet, so there is little penalty for wasted space in a fixed +size packet. The maximum amount of information necessary to encode a kernel +procedure call is limited (the argument lists are never large) hence it is +easy to set an upper bound on the packet size. The KII packet structure is +shown below. + + struct kii_packet { + int p_opcode # instruction opcode + int p_subcode # subcode (for device drivers) + int p_arg[13] # procedure arguments + int p_sbuflen # nchars in string buffer + char p_sbuf[255] # string buffer + } + + sizeof (struct kii_packet) == ((16*4)+256) == 320 bytes + + +The OPCODE and SUBCODE fields identify the kernel procedure to be executed. +Each procedure argument is passed in the corresponding field of the ARG array; +for string arguments this field contains the offset of the string value in +the P_SBUF field. Procedure argument N is passed in field N of the ARG array. +P_SBUFLEN is the number of chars in the string buffer, including the EOS at +the end of each string. + +Before transmission of the packet over the net the packet is encoded in +a machine independent form. The 16 integer fields are converted into MII +32 bit signed integer format, and the 256 character string buffer is packed +one byte per character (only the first SBUFLEN characters are packed). The +inverse transformation is performed by the kernel server on the remote node +before accessing the contents of the packet. + +Most kernel procedures return a status value and/or data. The KII packet +structure is used both to remotely execute a kernel procedure and to return +the status value and any scalar or string output arguments. In the case of +text file i/o the text data is passed in the SBUF field. Procedures which +return a data structure (e.g., ZFINFO) may pass the data structure as a +sequence of ARG array elements, encode the structure in chararacter form +in SBUF, or pass the structure in a separate packet. In most cases a single +packet will be used for greater efficiency and to avoid the need to +explicitly encode the return value. + +The purpose of the SUBCODE field is to exploit the fact that the text and +binary file drivers each have the same set of driver procedures, each with +the same set of arguments. The OPCODE field identifies the device driver +and the SUBCODE field the driver function, e.g., OPN, ARD, AWR, AWT, etc. + + +8. KS Driver + + Connecting and disconnecting kernel servers, and all i/o to connected +kernel servers, is provided by the KS driver. To the KI in the calling +process a KS behaves like a synchronous binary file opened for readwrite +access. The driver is patterned after a binary file driver, allowing the +server process to be connected to FIO as a streaming binary file. Normally, +however, the driver procedures will be called directly by the KI. + + + zopnks (server, mode, chan) + zawrks (chan, buf, nbytes, offset) + zardks (chan, buf, maxbytes, offset) + zawtks (chan, status) + zsttks (chan, what, lvalue) + zclsks (chan, status) + + +The entry points of the KS driver are shown above. The argument SERVER is +the network pathname of the kernel server process, e.g., "2!/iraf/lib/ks.e". +There no requirement, however, that the named process be a kernel server +process. The driver will attempt to execute and set up readwrite streaming +i/o to any process, hence the KS driver may be useful for network functions +other than the kernel interface. + + +9. Kernel Server Process + + The kernel server process is an IRAF process with a standard IRAF Main +but a special ONENTRY procedure and no task dictionary (like the CL). +The server communicates with a KI via the binary streams CLIN and CLOUT, +both of which are connected to a single channel in the calling process. +The server process contains an interpreter capable of calling any kernel +procedure which does i/o. In addition, the kernel server contains enough +of FIO to map filenames and read and write CLIN and CLOUT. + + +10. Filename Mapping Details + + The system interface procedures used for filename mapping must be trapped +by the KI to deal with node pathnames. The relevant procedures are the +following: + + zfnbrk break vfn into its component parts + zfchdr change directory + zfgcwd get default directory + zfxdir extract directory prefix + zfpath convert vfn to pathname + zfsubd fold subdirectory into pathname + +The first routine, ZFNBRK, merely parses filenames into their component fields +and it should be possible for the same routine to be used on all nodes without +help from the KI. The remaining routines are fundamental to the action of +the KI. + + +10.1 Default Directory + + Normally, either the kernel or the host system keeps track of the default +directory. This remains the case when the KI is in use, provided the default +directory is on the local node. If the default directory is changed to some +different node the following actions are taken by the KI: + + [1] Extract node prefix and save in a KI common for use during filename + mapping. + + [2] Execute ZFCHDR on the remote node (minus the node prefix) to set + the node-relative default directory. + +All subsequent runtime file references are mapped as follows: + + [1] The default node prefix is prepended to all filenames which do + not include an explicit node name prefix. + + [2] Normal filename mapping is performed, i.e., filename mapping is + disabled on the local node (since the filename has a node prefix), + deferring mapping to the kernel server on the remote node. + +All normal runtime filename mapping starts with a call to ZFXDIR. If ZFXDIR +returns anything the filename is assumed to be host dependent and is not mapped. +Hence we want ZFXDIR to return the entire VFN as if it were an OSDIR name, +if the VFN includes a node prefix and the node referenced is not the local +node. ZFPATH and ZFSUBD must behave similarly. + + +10.2 Semicode + + +procedure kfchdr (osdir, status) + +begin + server = ki_connect (osdir) + + if (server == NULL) { + # Directory is on the local node. + + default node = local node + call zfchdr (osdir_minus_node_prefix, status) + + } else { + # Directory is on a remote node. + + pass zfchdr request to remote node + if (request is successful) + default node = remote node + } +end + + +procedure kfgcwd (osdir, nchars) + +begin + if (default node is the local node) + call zfgcwd to get default directory + else + pass zfgcwd request to remote node + + return (default_node // default_directory) +end + + +procedure zfxdir (vfn, osdir, maxch, nchars) + +begin + extract node name + + if (no node name specified) + node name = default node + + if (node is the local node) + pass the request to the local kernel + else + return (node // vfn) +end + + +procedure zfpath (vfn, pathname, maxch, nchars) + +begin + extract node name + + if (no node name specified) + node name = default node + + if (node is the local node) { + call zfpath to compute local pathname + return (node // pathname) + } else + return (node // vfn) +end + + +procedure zfsubd (osfn, maxch, subdir, nchars) + +begin + extract node name + + if (no node name specified) + node name = default node + + if (node is the local node) { + call zfsubd to compute local pathname + return (node // pathname) + } else + return (node // vfn // "subdir/") +end diff --git a/sys/ki/irafks.x b/sys/ki/irafks.x new file mode 100644 index 00000000..7d4598b0 --- /dev/null +++ b/sys/ki/irafks.x @@ -0,0 +1,1590 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include "ki.h" + +# KSERVER.X -- The IRAF kernel server, used to serve up kernel functions on +# a remote host. + +define DEBUG_FILE "/tmp/ks.out" # MACHDEP +#define DEBUG_FILE "iraftmp:ks.out" +define DEBUG NO +#define DEBUG YES + +define DEF_LENIOBUF 32768 # reallocated if too small +define SZ_TXBUF 1024 # handy text buffer +define LEN_BFDRIVER 8 # actually 6, but 8 is a power of 2 +define LEN_TXDRIVER 8 # no. entry points in tx driver +define MAX_BFDRIVERS 10 # max binary file devices +define MAX_TXDRIVERS 2 # max text file devices + +define LEN_BFDD (LEN_BFDRIVER*MAX_BFDRIVERS) +define LEN_TXDD (LEN_TXDRIVER*MAX_TXDRIVERS) + +define ZOPNTX txdd[($1)] # text files +define ZCLSTX txdd[($1)+1] +define ZGETTX txdd[($1)+2] +define ZPUTTX txdd[($1)+3] +define ZFLSTX txdd[($1)+4] +define ZSEKTX txdd[($1)+5] +define ZNOTTX txdd[($1)+6] +define ZSTTTX txdd[($1)+7] + +define ZOPNBF bfdd[($1)] # binary files +define ZCLSBF bfdd[($1)+1] +define ZARDBF bfdd[($1)+2] +define ZAWRBF bfdd[($1)+3] +define ZAWTBF bfdd[($1)+4] +define ZSTTBF bfdd[($1)+5] + + +# IRAFKS -- The main entry point of the iraf kernel server task. The kernel +# server program is not CL callable but is instead spawned by the OS to listen +# listen on a socket. The ONENTRY procedure gains control from the IRAF main +# at process startup, before the in task interpreter is entered. The t_irafks +# procedure is never actually called by the interpreter as the TASK statement +# suggests. The purpose of the task statement is to give us an IRAF main. + +task irafks = t_irafks +procedure t_irafks() +begin +end + + +# ONENTRY -- The real task executed by the irafks.e executable. + +int procedure onentry (prtype, bkgfile, cmd) + +int prtype #I process type flag (not used) +char bkgfile[ARB] #I bkgfilename if detached process (not used) +char cmd[ARB] #I optional command (used to flag irafks type) + +bool error_restart +int debuginit, chan, junk +char osfn[SZ_PATHNAME], debugfile[SZ_PATHNAME] + +int getpid(), open() +data error_restart /false/ +data debuginit /DEBUG/ + +int debug, spy +common /dbgcom/ debug, spy + +begin + # Debug messages can be enabled either by compiling with DEBUG=YES + # or by running the kernel server with "-d debugfile" on the command + # line (a bit of a trick using the detached process syntax). + + if (prtype == PR_DETACHED) { + debug = YES + call strcpy (bkgfile, debugfile, SZ_PATHNAME) + } else { + debug = debuginit + call strcpy (DEBUG_FILE, debugfile, SZ_PATHNAME) + } + + # If an error occurs and we go through error restart, deadlock will + # probably occur as the client may be awaiting a status packet while + # upon restart we will be awaiting a command packet. Hence if restart + # occurs, shut the kernel server down. + + if (error_restart) { + call zclsks (chan, junk) + return (PR_EXIT) + } else + error_restart = true + + # Open the network connection to the host process. + call strpak (cmd, osfn, SZ_PATHNAME) + call zopnks (osfn, READ_WRITE, chan) + + # Open the debug file if so indicated. The value of the debug flag + # should be patched before execution with a debugger if debug output + # is desired. + + if (debug == YES) { + spy = open (debugfile, APPEND, TEXT_FILE) + call fseti (spy, F_FLUSHNL, YES) + + call fprintf (spy, "[%d] -------------------------\n") + call pargi (getpid()) + call fprintf (spy, "server channel = %d\n") + call pargi (chan) + } + + # Redirect the standard input and output of the kernel server task + # to the null file to prevent deadlock if the task unexpectedly + # reads or writes the standard input or output. + + call fredir (STDIN, "dev$null", READ_ONLY, TEXT_FILE) + call fredir (STDOUT, "dev$null", WRITE_ONLY, TEXT_FILE) + call fredir (STDERR, "dev$null", WRITE_ONLY, TEXT_FILE) + + # Serve up the kernel until EOF is seen on the input stream. + if (chan != ERR) + call kserver (chan, chan, DEF_LENIOBUF) + + # Exit w/o running interpreter. + call zclsks (chan, junk) + return (PR_EXIT) +end + + +# KSERVER -- Kernel server interpreter. This procedure is called from the +# kernel server program to interpret and execute (serve up) kernel instructions +# issued by a remote host. Execution terminates when EOF is seen on the input +# channel. All i/o is all low level since the level of function implemented +# here is that of the iraf kernel. This code executes in a private subprocess +# hence we need not worry about memory usage or reentrancy. +# +# NOTE -- Avoid passing packet data to subprocedures, since the kernel +# procedures called directly or indirectly by this code may themselves use +# the local KII packet data structure. + +procedure kserver (in, out, buflen) + +int in # input channel, a binary stream +int out # output channel, a binary stream +int buflen # iobuf size or 0 + +pointer iobuf, op, top +long fi[LEN_FINFO] +char curdir[SZ_PATHNAME] +int len_iobuf, status, i, nchars, opcode, subcode, arg1, arg2, arg3 +int bfdd[LEN_BFDD], txdd[LEN_TXDD] + +char txbuf[SZ_TXBUF], queue[SZ_FNAME] +char osfn1[SZ_PATHNAME], osfn2[SZ_PATHNAME], temp[SZ_PATHNAME] +char o_str[SZ_LINE], s_str[SZ_LINE] +int ks_receive(), ks_send(), strlen(), envscan() +int diropen(), gstrcpy(), getline() +include "kii.com" +errchk ks_error +define reply_ 91 + +int debug, spy +common /dbgcom/ debug, spy + +begin + if (debug == YES) { + call fprintf (spy, "start kernel server, in=%d, out=%d\n") + call pargi (in) + call pargi (out) + } + + # Allocate a buffer for read and write requests on a channel. We always + # transfer data immediately, before accepting another request, hence + # the same buffer may be reused for all requests. + + if (buflen > 0) + len_iobuf = buflen / SZB_CHAR + else + len_iobuf = DEF_LENIOBUF / SZB_CHAR + call malloc (iobuf, len_iobuf, TY_CHAR) + + if (debug == YES) { + call fprintf (spy, "kernel server, len_iobuf=%d\n") + call pargi (len_iobuf) + } + + # Load the device drivers. + call ks_loadbf (bfdd) + call ks_loadtx (txdd) + + # Initialize our record of the current working directory. + curdir[1] = EOS + + # Enter the main interpreter loop of the kernel server, reading and + # processing kernel requests from the host until EOF is seen. The + # host is completely in control. Kernel requests are passed to the + # local kernel (or to yet another kernel server) unchanged except + # for filenames, which must be mapped in the context of the local + # machine. + + while (ks_receive (in) > 0) { + opcode = p_opcode + subcode = p_subcode + arg1 = p_arg[1] + arg2 = p_arg[2] + arg3 = p_arg[3] + + p_sbuflen = 0 + + if (debug == YES) { + call ks_op2str (opcode, subcode, o_str, s_str) + if (opcode < KI_ZFIOBF) { + call fprintf (spy, "opcode=%s, arg[] =") + call pargstr (o_str) + } else { + call fprintf (spy, "opcode=%s), subcode=%s, arg[] =") + call pargstr (o_str) + call pargstr (s_str) + } + do i = 1, 10 { + call fprintf (spy, " %d") + call pargi (p_arg[i]) + } + call fprintf (spy, "\n") + } + + switch (opcode) { + case KI_ENVINIT: + # Called shortly after process startup to pass the environment + # list to the kernel server (req'd for filename mapping). + # May also be called after process startup to add entries to + # the environment list. Note that the kernel server process, + # since it is an IRAF process, will have read the zzsetenv.def + # file to define the standard variables during process startup, + # but the client must transmit its environment list anyhow to + # set the values of any newly defined variables. + + # Get the packed environment list string. If this is small + # it is sent in the packet string buffer, otherwise the data + # follows in a separate record. + + nchars = arg1 + if (nchars <= SZ_SBUF) + status = envscan (p_sbuf) + else { + if (len_iobuf < nchars) { + call realloc (iobuf, nchars, TY_CHAR) + len_iobuf = nchars + } + + call zardks (in, Memc[iobuf], nchars, long(0)) + call zawtks (in, status) + if (status != nchars) + break + + # Unpack it and process it into the symbol table. + call strupk (Memc[iobuf], Memc[iobuf], nchars) + status = envscan (Memc[iobuf]) + } + + if (debug == YES) { + call fprintf (spy, "%d environment entries scanned\n") + call pargi (status) + } + + # Do not send a status packet back for single variable updates. + if (nchars < SZ_SBUF) + next + else if (status < 0) + break + + # The environment variables HOST, IRAF, and TMP may differ + # from node to node. The ZGTENV primitive in the local + # kernel will pick up the local values of these variables + # from the HSI global include file . This happens + # automatically if the variables are not defined in the + # environment list. The simplest way to keep them out of + # the environment list is to exclude them from the list when + # it is composed by ki_openks() on the client node, so we + # do not have to do anything here. + + case KI_SETROOT: + # Called to set the pathname of the root iraf directory on + # the local node. This need not be the same as on the client + # node hence we must override the definition of "iraf" in the + # environment list. We are passed the OS pathname of the + # server process (i.e., this process) which is assumed to be + # resident in iraf$lib on the current node. The pathname of + # iraf$ is therefore obtained by a call to ZFXDIR followed by + # a call to ZFSUBD with subdirectory "..". + + # NOTE -- This function is obsoleted by the above code which + # sets the values of HOST, IRAF, and TMP from . Leave + # it in for a while nonetheless, just in case it is called. + + call strcpy (p_sbuf[arg1], osfn1, SZ_PATHNAME) + call zfxdir (osfn1, osfn2, SZ_PATHNAME, nchars) + call zfsubd (osfn2, SZ_PATHNAME, "..", nchars) + call strcpy ("set iraf=", osfn1, SZ_PATHNAME) + call strcat (osfn2, osfn1, SZ_PATHNAME) + + status = envscan (osfn1) + + if (debug == YES) { + call fprintf (spy, "%s\n") + call pargstr (osfn1) + } + + if (status < 1) + break + + case KI_FMAPFN: + # Map a filename in the context of the server node. + call strcpy (p_sbuf[arg1], osfn1, SZ_PATHNAME) + iferr (call ks_fmapfn (osfn1, temp, SZ_PATHNAME)) + status = ERR + else { + call strupk (temp, p_sbuf, SZ_SBUF) + p_sbuflen = strlen (p_sbuf) + status = p_sbuflen + } + + case KI_ZFACSS: + # Test file accessibility and/or type. + call strcpy (p_sbuf[arg1], temp, SZ_PATHNAME) + iferr (call ks_fmapfn (temp, osfn1, SZ_PATHNAME)) + status = ERR + else + call zfacss (osfn1, arg2, arg3, status) + + case KI_ZFALOC: + # Preallocate space for a file. + call strcpy (p_sbuf[arg1], temp, SZ_PATHNAME) + iferr (call ks_fmapfn (temp, osfn1, SZ_PATHNAME)) + status = ERR + else + call zfaloc (osfn1, arg2, status) + + case KI_ZFCHDR: + # Change the default directory. + + if (debug == YES) { + call fprintf (spy, "change directory to `%s'\n") + call pargstr (p_sbuf[arg1]) + } + + call strcpy (p_sbuf[arg1], temp, SZ_PATHNAME) + iferr (call ks_fmapfn (temp, osfn1, SZ_PATHNAME)) + status = ERR + else + call zfchdr (osfn1, status) + + # Save the logical name of the new default directory, but only + # if the zfchdr request is successful. + + if (status != ERR) + call strcpy (temp, curdir, SZ_PATHNAME) + + case KI_ZFDELE: + # Delete a file. + call strcpy (p_sbuf[arg1], temp, SZ_PATHNAME) + iferr (call ks_fmapfn (temp, osfn1, SZ_PATHNAME)) + status = ERR + else + call zfdele (osfn1, status) + + case KI_ZFGCWD: + # Get the name of the current default directory. Return the + # unmapped name rather than the mapped OSFN because the client + # deals with unmapped pathnames when the file resides on a + # remote node. + + if (curdir[1] == EOS) { + call zfgcwd (osfn1, SZ_PATHNAME, status) + call strupk (osfn1, p_sbuf, SZ_SBUF) + } else + status = gstrcpy (curdir, p_sbuf, SZ_SBUF) + + p_arg[2] = 1 + p_sbuflen = strlen (p_sbuf) + + case KI_ZFINFO: + # Get directory info for a file. + call strcpy (p_sbuf[arg1], temp, SZ_PATHNAME) + iferr (call ks_fmapfn (temp, osfn1, SZ_PATHNAME)) + status = ERR + else + call zfinfo (osfn1, fi, status) + + if (status != ERR) { + # Return the integer part of the FI structure in args 2+. + do i = 1, LEN_FINFO + p_arg[i+1] = fi[i] + + # Return the owner string in the string buffer. + call strupk (FI_OWNER(fi), p_sbuf, SZ_SBUF) + p_sbuflen = strlen (p_sbuf) + } + + case KI_ZFMKCP: + # Make a null length copy of a file. + iferr { + call strcpy (p_sbuf[arg1], temp, SZ_PATHNAME) + call ks_fmapfn (temp, osfn1, SZ_PATHNAME) + call strcpy (p_sbuf[arg2], temp, SZ_PATHNAME) + call ks_fmapfn (temp, osfn2, SZ_PATHNAME) + } then { + status = ERR + } else + call zfmkcp (osfn1, osfn2, status) + + case KI_ZFMKDR: + # Make a new directory. + iferr { + call strcpy (p_sbuf[arg1], temp, SZ_PATHNAME) + call ks_fmapfn (temp, osfn1, SZ_PATHNAME) + } then { + status = ERR + } else + call zfmkdr (osfn1, status) + + case KI_ZFPROT: + # Set or query file protection. + call strcpy (p_sbuf[arg1], temp, SZ_PATHNAME) + iferr (call ks_fmapfn (temp, osfn1, SZ_PATHNAME)) + status = ERR + else + call zfprot (osfn1, arg2, status) + + case KI_ZFRNAM: + # Rename a file. + iferr { + call strcpy (p_sbuf[arg1], temp, SZ_PATHNAME) + call ks_fmapfn (temp, osfn1, SZ_PATHNAME) + call strcpy (p_sbuf[arg2], temp, SZ_PATHNAME) + call ks_fmapfn (temp, osfn2, SZ_PATHNAME) + } then { + status = ERR + } else + call zfrnam (osfn1, osfn2, status) + + case KI_ZFRMDR: + # Remove a directory. + iferr { + call strcpy (p_sbuf[arg1], temp, SZ_PATHNAME) + call ks_fmapfn (temp, osfn1, SZ_PATHNAME) + } then { + status = ERR + } else + call zfrmdr (osfn1, status) + + case KI_ZDVALL: + # Allocate or deallocate a device. + if (debug == YES) { + call fprintf (spy, "allocate `%s' flag=%d\n") + call pargstr (p_sbuf[arg1]) + call pargi (arg2) + } + call strpak (p_sbuf[arg1], temp, SZ_PATHNAME) + call zdvall (temp, arg2, status) + + case KI_ZDVOWN: + # Query device allocation. + call strpak (p_sbuf[arg1], osfn1, SZ_PATHNAME) + call zdvown (osfn1, temp, SZ_PATHNAME, status) + call strupk (temp, p_sbuf, SZ_SBUF) + p_sbuflen = strlen (p_sbuf) + + case KI_ZFUTIM: + # Update thje file modify time. + call strcpy (p_sbuf[arg1], temp, SZ_PATHNAME) + if (debug == YES) { + call fprintf (spy, "utime `%s' atime=%d mtime=%d\n") + call pargstr (temp) + call pargi (arg2) + call pargi (arg3) + } + iferr (call ks_fmapfn (temp, osfn1, SZ_PATHNAME)) + status = ERR + else + call zfutim (osfn1, arg2, arg3, status) + + case KI_ZOPDIR: + # Open a directory for reading. Since we must perform the + # inverse mapping we use the high level DIROPEN package + # rather than call the kernel directly. + + if (debug == YES) { + call fprintf (spy, "open directory `%s', mode %d\n") + call pargstr (p_sbuf[arg1]) + call pargi (arg2) + } + + call strcpy (p_sbuf[arg1], osfn1, SZ_PATHNAME) + iferr (status = diropen (osfn1, arg2)) + status = ERR + + if (debug == YES) { + call fprintf (spy, "diropen returns %d\n") + call pargi (status) + } + + case KI_ZCLDIR: + # Close a directory file. + + iferr (call close (arg1)) + status = ERR + else + status = OK + + case KI_ZGFDIR: + # Get the next filename from a directory. To reduce traffic + # on the net we return many filenames at once. The reverse + # mapping must be performed locally, returning VFN's to the + # client process. + + top = iobuf + min (len_iobuf, arg2) + op = iobuf + + # Fill the output buffer. Set argument 2 to 1 if EOF is seen + # on the directory. + + arg2 = 1 + iferr { + while (getline (arg1, Memc[op]) != EOF) { + op = op + strlen (Memc[op]) + if (op + SZ_FNAME >= top) { + arg2 = 0 + break + } + } + } then { + status = ERR + p_arg[2] = arg2 + goto reply_ + } + + # If the data is small enough return it in the string buffer, + # else return it as a second record. + + nchars = op - iobuf + if (nchars <= SZ_SBUF) { + call amovc (Memc[iobuf], p_sbuf, nchars) + p_sbuflen = nchars + status = nchars + # goto reply_ + + } else { + p_arg[1] = nchars + if (ks_send (out, opcode, subcode) == ERR) + return + + call chrpak (Memc[iobuf], 1, Memc[iobuf], 1, nchars) + call zawrks (out, Memc[iobuf], nchars, long(0)) + call zawtks (out, status) + if (status <= 0) + return + + next + } + + case KI_ZOSCMD: + # Issue a command to the local host command interpreter. + # Spool the output in a file and return the name of the + # file to the client so that it can recover the output via + # the text file i/o interface. + + call strpak (p_sbuf[arg1], txbuf, SZ_TXBUF) + call strpak ("", osfn1, SZ_PATHNAME) + call mktemp ("tmp$zos", temp, SZ_PATHNAME) + call ks_fmapfn (temp, osfn2, SZ_PATHNAME) + + call zoscmd (txbuf, osfn1, osfn2, osfn2, status) + + call strupk (osfn2, p_sbuf, SZ_SBUF) + p_sbuflen = strlen (p_sbuf) + + case KI_ZOPDPR: + # Open a detached process (submit bkg job). + iferr { + call strcpy (p_sbuf[arg1], temp, SZ_PATHNAME) + call ks_fmapfn (temp, osfn1, SZ_PATHNAME) + call strcpy (p_sbuf[arg2], temp, SZ_PATHNAME) + call ks_fmapfn (temp, osfn2, SZ_PATHNAME) + call strcpy (p_sbuf[arg3], queue, SZ_FNAME) + } then { + status = ERR + } else + call zopdpr (osfn1, osfn2, queue, status) + + case KI_ZCLDPR: + # Close a detached process. + call zcldpr (arg1, arg2, status) + + case KI_ZOPCPR: + # Open a connected subprocess. + call strcpy (p_sbuf[arg1], temp, SZ_PATHNAME) + iferr (call ks_fmapfn (temp, osfn1, SZ_PATHNAME)) + status = ERR + else { + call zopcpr (osfn1, arg2, arg3, status) + p_arg[2] = arg2 + p_arg[3] = arg3 + } + + case KI_ZCLCPR: + # Close a connected subprocess. + call zclcpr (arg1, status) + + case KI_ZINTPR: + # Interrupt a connected subprocess. + call zintpr (arg1, arg2, status) + + case KI_ZFIOBF,KI_ZFIOLP,KI_ZFIOPL,KI_ZFIOPR,KI_ZFIOSF,KI_ZFIOGD: + # Binary file drivers. + iferr (call ks_zfiobf (in, out, iobuf, len_iobuf, bfdd)) + break + else + next + + case KI_ZFIOTX, KI_ZFIOTY: + # Text file drivers. + iferr (call ks_zfiotx (in, out, iobuf, len_iobuf, txdd)) + break + else + next + + case KI_ZFIOMT: + # Magtape driver. + iferr (call ks_zfiomt (in, out, iobuf, len_iobuf)) + break + else + next + + default: + # If we receive an illegal opcode on the channel shut the + # server down immediately, as communications have almost + # certainly been irrecoverably corrupted. We should probably + # go one step further and compute a checksum on the packet + # header. + + call ks_error (opcode, "illegal opcode on channel") + } + + # Transmit response packet back to host. Shutdown if there is + # an i/o error on the socket. +reply_ + if (debug == YES) { + call fprintf (spy, "status = %d\n") + call pargi (status) + call flush (spy) + } + + p_arg[1] = status + if (ks_send (out, opcode, subcode) == ERR) + break + } + + call mfree (iobuf, TY_CHAR) + + if (debug == YES) { + call fprintf (spy, "kernel server, normal exit\n") + call flush (spy) + } +end + + +# KS_ZFIOBF -- I/O to the class of binary file devices. The i/o request is +# passed in the KII common (unpacked packet from the host via the network). + +procedure ks_zfiobf (in, out, iobuf, len_iobuf, bfdd) + +int in, out # input and output channels to host +pointer iobuf # scratch i/o buffer +int len_iobuf # current length of buffer +int bfdd[ARB] # loaded device drivers + +long lval, ks_maxbufsize +int dd, status, nchars, arg1, arg2, arg3 +char osfn[SZ_PATHNAME], temp[SZ_PATHNAME] +errchk realloc +int ks_send() +include "kii.com" +define fatal_ 91 + +int debug, spy +common /dbgcom/ debug, spy + +begin + # Determine the table offset of the device driver in the table of all + # loaded binary file device drivers. The device driver opcodes are + # assigned sequentially and KI_ZFIOBF is always first. + + dd = (p_opcode - KI_ZFIOBF) * LEN_BFDRIVER + 1 + + # Make sure the iobuffer is large enough. If a large enough buffer + # cannot be allocated something is very wrong and the server shuts + # down. + + if (p_subcode == BF_ARD || p_subcode == BF_AWR) { + nchars = (p_arg[2] + SZB_CHAR-1) / SZB_CHAR + if (len_iobuf < nchars) { + call realloc (iobuf, nchars, TY_CHAR) + len_iobuf = nchars + } + } + + arg1 = p_arg[1] + arg2 = p_arg[2] + arg3 = p_arg[3] + + switch (p_subcode) { + case BF_OPN: + # Open a binary file. + + if (debug == YES) { + call fprintf (spy, "open binary file `%s', mode %d\n") + call pargstr (p_sbuf[arg1]) + call pargi (arg2) + } + + # Do not map the filename strings of special devices, since the + # syntax of such strings may bear no resemblance to that of an + # ordinary filename. + + status = OK + if (p_opcode == KI_ZFIOBF) { + call strcpy (p_sbuf[arg1], temp, SZ_PATHNAME) + iferr (call ks_fmapfn (temp, osfn, SZ_PATHNAME)) + status = ERR + } else + call strpak (p_sbuf[arg1], osfn, SZ_PATHNAME) + + if (status != ERR) + call zcall3 (ZOPNBF(dd), osfn, arg2, status) + + case BF_CLS: + # Close a binary file. + + if (debug == YES) { + call fprintf (spy, "close %d\n") + call pargi (arg1) + } + + call zcall2 (ZCLSBF(dd), arg1, status) + + case BF_ARD: + # Read from a binary file. The read must be performed in one + # operation to preserve the record size. Overlapped i/o is + # provided by the dual process nature of the read; the actual + # device read is not performed asynchronously since we must + # complete each request before processing the next one. + + if (debug == YES) { + call fprintf (spy, "aread (%d, %d, %d)\n") + call pargi (arg1) + call pargi (arg2) + call pargi (arg3) + } + + # Read the data. + call zcall4 (ZARDBF(dd), arg1, Memc[iobuf], arg2, arg3) + call zcall2 (ZAWTBF(dd), arg1, status) + + # Send the ZAWT packet to the host followed by the data block. + # The next operation performed by the host on the channel MUST + # be completion of the i/o transfer, but the host can go off and + # do other things before completing the transfer. + + p_arg[1] = status + if (ks_send (out, p_opcode, BF_AWT) == ERR) + goto fatal_ + if (status > 0) { + call zawrks (out, Memc[iobuf], status, 0) + call zawtks (out, status) + if (status <= 0) + goto fatal_ + } + + if (debug == YES) { + call fprintf (spy, "status %d\n") + call pargi (status) + } + + return + + case BF_AWR: + # Write to a binary file. For maximum performance the write + # operation is half duplex, i.e., the ZAWT operation is ignored + # for writes to a binary file over the network. If a write + # error occurs when writing to the physical device we shutdown + # the entire kernel process, causing a FIO write error in the + # host if the next kernel server operation is another write to + # the same channel. This may cause ficticious i/o errors on + # other channels as well, but the performance gain is worth it. + + if (debug == YES) { + call fprintf (spy, "awrite (%d, %d, %d)\n") + call pargi (arg1) + call pargi (arg2) + call pargi (arg3) + } + + # Read the data from the host. + call zardks (in, Memc[iobuf], arg2, 0) + call zawtks (in, status) + if (debug == YES) { + call fprintf (spy, "read net status %d\n") + call pargi (status) + } + if (status != arg2) + goto fatal_ + + # Write the data to the output device. + # TODO - delay the call to zawtbf to overlap i/o even further. + + call zcall4 (ZAWRBF(dd), arg1, Memc[iobuf], arg2, arg3) + call zcall2 (ZAWTBF(dd), arg1, status) + if (debug == YES) { + call fprintf (spy, "write device status %d\n") + call pargi (status) + } + if (status != arg2) + goto fatal_ + + return + + case BF_AWT: + # Wait for i/o on the device channel. Not implemented as a + # discreen kernel server operation. + + status = ERR + + case BF_STT: + # Get channel status. + call zcall3 (ZSTTBF(dd), arg1, arg2, lval) + + # The max transfer size for a binary device is limited by the + # network interface as well as the device. + + if (arg2 == FSTT_MAXBUFSIZE || arg2 == FSTT_OPTBUFSIZE) { + call zsttks (out, FSTT_MAXBUFSIZE, ks_maxbufsize) + if (lval == 0) + lval = ks_maxbufsize + else if (ks_maxbufsize > 0) + lval = min (ks_maxbufsize, lval) + } + status = lval + + default: + status = ERR + } + + # Return a status packet to the host if the operation was not a read + # or a write. + + if (debug == YES) { + call fprintf (spy, "status %d\n") + call pargi (status) + } + + p_arg[1] = status + if (ks_send (out, p_opcode, p_subcode) != ERR) + return + +fatal_ + call ks_error (1, "kernel server binary file i/o error") +end + + +# KS_ZFIOTX -- I/O to the class of text file devices. The i/o request is +# passed in the KII common (unpacked packet from the host via the network). +# Text file i/o is buffered by the KI, reading and writing an integral +# number of full lines of text in each transfer. + +procedure ks_zfiotx (in, out, iobuf, len_iobuf, txdd) + +int in, out # input and output channels to host +pointer iobuf # scratch i/o buffer (not used) +int len_iobuf # current length of buffer (not used) +int txdd[ARB] # loaded device drivers + +long lval, reclen +bool buffer_full +pointer rp, nextrec +char osfn[SZ_PATHNAME], temp[SZ_PATHNAME] +int dd, status, maxch, nchars, arg1, arg2, arg3 + +int ks_send() +long ki_decode() +include "kii.com" +define fatal_ 91 + +int debug, spy +common /dbgcom/ debug, spy + +begin + # Determine the table offset of the device driver in the table of all + # loaded text file device drivers. The device driver opcodes are + # assigned sequentially and KI_ZFIOTX is always first. + + dd = (p_opcode - KI_ZFIOTX) * LEN_TXDRIVER + 1 + + arg1 = p_arg[1] + arg2 = p_arg[2] + arg3 = p_arg[3] + + switch (p_subcode) { + case TX_OPN: + # Open a text file. + + if (debug == YES) { + call fprintf (spy, "open text file `%s', mode %d\n") + call pargstr (p_sbuf[arg1]) + call pargi (arg2) + } + + call strcpy (p_sbuf[arg1], temp, SZ_PATHNAME) + iferr (call ks_fmapfn (temp, osfn, SZ_PATHNAME)) + status = ERR + else + call zcall3 (ZOPNTX(dd), osfn, arg2, status) + + case TX_CLS: + # Close a binary file. + + if (debug == YES) { + call fprintf (spy, "close text file %d\n") + call pargi (arg1) + } + + call zcall2 (ZCLSTX(dd), arg1, status) + + case TX_GET: + # Read from a text file. If the device is an ordinary text file + # (device TX) read as many lines of maximum size SZ_LINE as will + # fit in the output buffer. If the device is a terminal return + # a single line in each call. Each line is returned as a record + # with the record length and seek offset of the line included + # in the record header (buffering complicates the ZNOTTX function). + + if (debug == YES) { + call fprintf (spy, "gettx %d\n") + call pargi (arg1) + } + + rp = iobuf + + repeat { + maxch = min (arg2, SZ_LINE) + call zcall2 (ZNOTTX(dd), arg1, lval) + call zcall4 (ZGETTX(dd), arg1, Memc[R_DATA(rp)], + maxch, status) + + if (status >= 0) { + reclen = R_GETRECLEN (status) + call ki_encode (reclen, R_RECLEN(rp), NCHARS_INT) + call ki_encode (lval, R_SEKOFF(rp), NCHARS_LONG) + + rp = rp + reclen + } + + nextrec = rp + R_GETRECLEN (SZ_LINE) + buffer_full = (nextrec - iobuf > arg2) + + } until (p_opcode != KI_ZFIOTX || status <= 0 || buffer_full) + + # If the data record is small enough to fit in the packet string + # buffer, return it in the packet, else return it as a second + # record following the packet. + + if (status == ERR) + nchars = ERR + else if (status == EOF && rp == iobuf) + nchars = EOF + else { + nchars = rp - iobuf + if (nchars <= SZ_SBUF) { + call amovc (Memc[iobuf], p_sbuf, nchars) + p_sbuflen = nchars + } + } + + p_arg[1] = nchars + if (ks_send (out, p_opcode, p_subcode) == ERR) + goto fatal_ + + if (nchars > SZ_SBUF) { + call chrpak (Memc[iobuf], 1, Memc[iobuf], 1, nchars) + call zawrks (out, Memc[iobuf], nchars, long(0)) + call zawtks (out, status) + if (status != nchars) + goto fatal_ + } + + return + + case TX_PUT: + # Put a block of data to a text file. If the block is larger than + # the packet string buffer it is passed as a second record following + # the packet. + + nchars = arg2 + if (nchars <= SZ_SBUF) + call zcall4 (ZPUTTX(dd), arg1, p_sbuf, nchars, status) + else { + call zardks (in, Memc[iobuf], nchars, long(0)) + call zawtks (in, status) + if (status != nchars) + goto fatal_ + + call chrupk (Memc[iobuf], 1, Memc[iobuf], 1, nchars) + call zcall4 (ZPUTTX(dd), arg1, Memc[iobuf], nchars, status) + } + + # If an error occurs writing to a text file close the kernel + # server itself down, rather than handshaking on each packet. + + if (status == ERR) + goto fatal_ + + return + + case TX_FLS: + # Flush text file output. + call zcall2 (ZFLSTX(dd), arg1, status) + + case TX_SEK: + # Seek on a text file. + lval = ki_decode (p_sbuf, NCHARS_LONG) + call zcall3 (ZSEKTX(dd), arg1, lval, status) + + case TX_NOT: + # Note the file position of a text file. The seek offset is + # returned encoded as a char sequence in the string buffer to + # avoid problems with integer precision. + + call zcall2 (ZNOTTX(dd), arg1, lval) + call ki_encode (lval, p_sbuf, NCHARS_LONG) + p_sbuflen = NCHARS_LONG + status = lval + + case TX_STT: + # Get channel status. + + call zcall3 (ZSTTTX(dd), arg1, arg2, lval) + call ki_encode (lval, p_sbuf, NCHARS_LONG) + p_sbuflen = NCHARS_LONG + status = lval + + default: + status = ERR + } + + # Return a status/data packet to the host if the subcode did not + # specify the get or put function. + + if (debug == YES) { + call fprintf (spy, "status %d\n") + call pargi (status) + } + + p_arg[1] = status + if (ks_send (out, p_opcode, p_subcode) != ERR) + return + +fatal_ + call ks_error (1, "kernel server text file i/o error") +end + + +# KS_ZFIOMT -- I/O to the magtape device. The i/o request is passed in +# the KII common (unpacked packet from the host via the network). + +procedure ks_zfiomt (in, out, iobuf, len_iobuf) + +int in, out # input and output channels to host +pointer iobuf # scratch i/o buffer +int len_iobuf # current length of buffer + +long lval +int status, nchars, mode, dc_off, dc_len +int newfile, arg[MAX_ARGS] +char drive[SZ_FNAME] +errchk realloc +include "kii.com" +int ks_send() +define fatal_ 91 + +int debug, spy +common /dbgcom/ debug, spy + +begin + call amovi (p_arg, arg, MAX_ARGS) + + # Make sure the iobuffer is large enough. If a large enough buffer + # cannot be allocated something is very wrong and the server shuts + # down. + + if (p_subcode == MT_RD || p_subcode == MT_WR) { + nchars = (arg[2] + SZB_CHAR-1) / SZB_CHAR + if (len_iobuf < nchars) { + call realloc (iobuf, nchars, TY_CHAR) + len_iobuf = nchars + } + } + + switch (p_subcode) { + case MT_OP: + # Open a magtape device. + + mode = arg[2] + dc_off = arg[3] + dc_len = arg[4] + newfile = arg[5] + + # Get the device name string. + call strpak (p_sbuf[arg[1]], drive, SZ_PATHNAME) + + # Get the devcap string. + if (dc_len > 0 && dc_off == 0) { + call zardks (in, Memc[iobuf], dc_len+1, 0) + call zawtks (in, status) + if (status != dc_len + 1) + goto fatal_ + } else + call strpak (p_sbuf[dc_off], Memc[iobuf], len_iobuf) + + if (debug == YES) { + call fprintf (spy, + "open magtape device `%s', mode=%d, file=%d, devcap=`%s'\n") + call pargstr (p_sbuf[arg[1]]) + call pargi (mode) + call pargi (newfile) + + call strupk (Memc[iobuf], Memc[iobuf], len_iobuf) + call pargstr (Memc[iobuf]) + call strpak (Memc[iobuf], Memc[iobuf], len_iobuf) + } + + call zzopmt (drive, mode, Memc[iobuf], arg[6], newfile, status) + p_arg[2] = newfile + + case MT_CL: + # Close a binary file. + call zzclmt (arg[1], p_arg[2], status) + + case MT_RD: + # Read from a magtape file. The read must be performed in one + # operation to preserve the record size. Overlapped i/o is + # provided by the dual process nature of the read; the actual + # device read is not performed asynchronously since we must + # complete each request before processing the next one. + + # Read the data. + call zzrdmt (arg[1], Memc[iobuf], arg[2], arg[3]) + call zzwtmt (arg[1], p_arg[2], status) + + # Send the ZAWT packet to the host followed by the data block. + # The next operation performed by the host on the channel MUST + # be completion of the i/o transfer, but the host can go off and + # do other things before completing the transfer. + + p_arg[1] = status + if (ks_send (out, p_opcode, MT_WT) == ERR) + goto fatal_ + if (status > 0) { + call zawrks (out, Memc[iobuf], status, 0) + call zawtks (out, status) + if (status <= 0) + goto fatal_ + } + + return + + case MT_WR: + # Write to a magtape file. For maximum performance the write + # operation is half duplex, i.e., the ZAWT operation is ignored + # for writes to a binary file over the network. If a write + # error occurs when writing to the physical device we shutdown + # the entire kernel process, causing a FIO write error in the + # host if the next kernel server operation is another write to + # the same channel. This may cause ficticious i/o errors on + # other channels as well, but the performance gain is worth it. + + # Read the data from the host. + call zardks (in, Memc[iobuf], arg[2], 0) + call zawtks (in, status) + if (status != arg[2]) + goto fatal_ + + # Write the data to the output device. + # TODO - delay the call to zawtbf to overlap i/o even further. + + call zzwrmt (arg[1], Memc[iobuf], arg[2], arg[3]) + call zzwtmt (arg[1], p_arg[2], status) + if (status != arg[2]) + goto fatal_ + + return + + case MT_WT: + # Wait for i/o on the device channel. Not implemented as a + # discreet kernel server operation; for a read the wait status + # is returned with the data, and for a write we assume the normal + # status and break the connection if the assumption is false. + + status = ERR + + case MT_ST: + # Get device status. + call zzstmt (arg[1], arg[2], lval) + status = lval + + case MT_RW: + # Rewind a drive. + dc_off = p_arg[2] + dc_len = p_arg[3] + + # Get the device name string. + call strpak (p_sbuf[arg[1]], drive, SZ_PATHNAME) + + # Get the devcap string. + if (dc_len > 0 && dc_off == 0) { + call zardks (in, Memc[iobuf], dc_len+1, 0) + call zawtks (in, status) + if (status != dc_len + 1) + goto fatal_ + } else + call strpak (p_sbuf[dc_off], Memc[iobuf], len_iobuf) + + call zzrwmt (drive, Memc[iobuf], status) + + default: + status = ERR + } + + # Return a status packet to the host if the operation was not a read + # or a write. + + if (debug == YES) { + call fprintf (spy, "status %d\n") + call pargi (status) + } + + p_arg[1] = status + if (ks_send (out, p_opcode, p_subcode) != ERR) + return + +fatal_ + call ks_error (1, "kernel server magtape i/o error") +end + + +# KS_ERROR -- Spool error message if debug is enabled, then call error +# to kill kernel server. + +procedure ks_error (errcode, errmsg) + +int errcode +char errmsg[ARB] + +int debug, spy +common /dbgcom/ debug, spy + +begin + if (debug == YES) { + call fprintf (spy, "ERROR (%d, `%s')\n") + call pargi (errcode) + call pargstr (errmsg) + } + + call error (errcode, errmsg) +end + + +# KS_LOADBF -- Load the binary file drivers. The order in which the driver +# entry points are loaded must agree with the defines at the head of this file. + +procedure ks_loadbf (bfdd) + +int bfdd[ARB] # device table +int off, locpr() +extern zopnbf(), zclsbf(), zardbf(), zawrbf(), zawtbf(), zsttbf() +extern zopnlp(), zclslp(), zardlp(), zawrlp(), zawtlp(), zsttlp() +extern zopnpl(), zclspl(), zardpl(), zawrpl(), zawtpl(), zsttpl() +extern zardpr(), zawrpr(), zawtpr(), zsttpr() +extern zopnsf(), zclssf(), zardsf(), zawrsf(), zawtsf(), zsttsf() +extern zopngd(), zclsgd(), zardgd(), zawrgd(), zawtgd(), zsttgd() + +begin + off = (KI_ZFIOBF - KI_ZFIOBF) * LEN_BFDRIVER + bfdd[off+1] = locpr (zopnbf) + bfdd[off+2] = locpr (zclsbf) + bfdd[off+3] = locpr (zardbf) + bfdd[off+4] = locpr (zawrbf) + bfdd[off+5] = locpr (zawtbf) + bfdd[off+6] = locpr (zsttbf) + + off = (KI_ZFIOLP - KI_ZFIOBF) * LEN_BFDRIVER + bfdd[off+1] = locpr (zopnlp) + bfdd[off+2] = locpr (zclslp) + bfdd[off+3] = locpr (zardlp) + bfdd[off+4] = locpr (zawrlp) + bfdd[off+5] = locpr (zawtlp) + bfdd[off+6] = locpr (zsttlp) + + off = (KI_ZFIOPL - KI_ZFIOBF) * LEN_BFDRIVER + bfdd[off+1] = locpr (zopnpl) + bfdd[off+2] = locpr (zclspl) + bfdd[off+3] = locpr (zardpl) + bfdd[off+4] = locpr (zawrpl) + bfdd[off+5] = locpr (zawtpl) + bfdd[off+6] = locpr (zsttpl) + + off = (KI_ZFIOPR - KI_ZFIOBF) * LEN_BFDRIVER + bfdd[off+1] = 0 + bfdd[off+2] = 0 + bfdd[off+3] = locpr (zardpr) + bfdd[off+4] = locpr (zawrpr) + bfdd[off+5] = locpr (zawtpr) + bfdd[off+6] = locpr (zsttpr) + + off = (KI_ZFIOSF - KI_ZFIOBF) * LEN_BFDRIVER + bfdd[off+1] = locpr (zopnsf) + bfdd[off+2] = locpr (zclssf) + bfdd[off+3] = locpr (zardsf) + bfdd[off+4] = locpr (zawrsf) + bfdd[off+5] = locpr (zawtsf) + bfdd[off+6] = locpr (zsttsf) + + off = (KI_ZFIOGD - KI_ZFIOBF) * LEN_BFDRIVER + bfdd[off+1] = locpr (zopngd) + bfdd[off+2] = locpr (zclsgd) + bfdd[off+3] = locpr (zardgd) + bfdd[off+4] = locpr (zawrgd) + bfdd[off+5] = locpr (zawtgd) + bfdd[off+6] = locpr (zsttgd) +end + + +# KS_LOADTX -- Load the text file drivers. The order in which the driver +# entry points are loaded must agree with the defines at the head of this file. + +procedure ks_loadtx (txdd) + +int txdd[ARB] # device table +int off, locpr() +extern zopntx(), zclstx(), zgettx(), zputtx(), zflstx(), zsektx(), znottx(), + zstttx() +extern zopnty(), zclsty(), zgetty(), zputty(), zflsty(), zsekty(), znotty(), + zsttty() + +begin + off = (KI_ZFIOTX - KI_ZFIOTX) * LEN_TXDRIVER + txdd[off+1] = locpr (zopntx) + txdd[off+2] = locpr (zclstx) + txdd[off+3] = locpr (zgettx) + txdd[off+4] = locpr (zputtx) + txdd[off+5] = locpr (zflstx) + txdd[off+6] = locpr (zsektx) + txdd[off+7] = locpr (znottx) + txdd[off+8] = locpr (zstttx) + + off = (KI_ZFIOTY - KI_ZFIOTX) * LEN_TXDRIVER + txdd[off+1] = locpr (zopnty) + txdd[off+2] = locpr (zclsty) + txdd[off+3] = locpr (zgetty) + txdd[off+4] = locpr (zputty) + txdd[off+5] = locpr (zflsty) + txdd[off+6] = locpr (zsekty) + txdd[off+7] = locpr (znotty) + txdd[off+8] = locpr (zsttty) +end + + +# KS_SEND -- Encode the packet in the kii common in a machine independent form +# and send it over the network. + +int procedure ks_send (server, opcode, subcode) + +int server # channel to host +int opcode # function opcode +int subcode # function subcode (for drivers) + +int status +include "kii.com" + +int debug, spy +common /dbgcom/ debug, spy + +begin + p_opcode = opcode + p_subcode = subcode + + # Encode the packet in machine independent form, i.e., LEN_INTFIELDS + # 32 bit MII integers followed by p_sbuflen chars, one char per byte. + + call miipak32 (FIRSTINTFIELD, p_packet, LEN_INTFIELDS, TY_INT) + call chrpak (p_sbuf, 1, p_packet, LEN_INTFIELDS * 4 + 1, + min (SZ_SBUF, p_sbuflen + 1)) + + # Transmit the packet. + call zawrks (server, p_packet, SZB_PACKET, long(0)) + call zawtks (server, status) + + if (debug == YES) { + call fprintf (spy, "ks_send: status=%d\n");call pargi (status) + } + + return (status) +end + + +# KS_RECEIVE -- Read a machine independent KII packet from the network +# interface and decode it into the internal, machine dependent form in the +# kii common. This procedure differs from the procedure KI_RECEIVE in +# that it does not verify the opcode and subcode of the received packet. + +int procedure ks_receive (server) + +int server # os channel to server process +int status +include "kii.com" + +int debug, spy +common /dbgcom/ debug, spy + +begin + # Read the packet. + # [DEBUG]: call zzrdks (server, p_packet, SZB_PACKET, long(0)) + + call zardks (server, p_packet, SZB_PACKET, long(0)) + call zawtks (server, status) + + if (debug == YES && status <= 0) { + call fprintf (spy, "ERROR: ks_receive: status=%d\n") + call pargi (status) + } + + if (status <= 0) + return (status) + + # The encoded packet consists of LEN_INTFIELDS 32 bit MII integers + # followed by p_sbuflen chars, one char per byte. + + call miiupk32 (p_packet, FIRSTINTFIELD, LEN_INTFIELDS, TY_INT) + call chrupk (p_packet, LEN_INTFIELDS * 4 + 1, p_sbuf, 1, + min (SZ_SBUF, p_sbuflen + 1)) + + if (debug == YES) { + call fprintf (spy, "ks_receive: status=%d\n") ; call pargi (status) + } + + return (status) +end + + +# KS_FMAPFN -- Equivalent functionality of FMAPFN but with debug output. + +procedure ks_fmapfn (vfn, osfn, maxch) + +char vfn[ARB] # filename to be mapped +char osfn[maxch] # packed output OS filename +int maxch # max chars out + +char upk_osfn[SZ_FNAME] +errchk fmapfn +int debug, spy +common /dbgcom/ debug, spy + +begin + call fmapfn (vfn, osfn, maxch) + + if (debug == YES) { + call strupk (osfn, upk_osfn, SZ_FNAME) + + call fprintf (spy, "`%s' -> `%s'\n") + call pargstr (vfn) + call pargstr (upk_osfn) + } +end + + +procedure ks_op2str (opcode, subcode, o_str, s_str) + +int opcode #i opcode +int subcode #i opcode +char o_str[ARB] #o string containing opcode instruction +char s_str[ARB] #o string containing subcode instruction + +begin + switch (opcode) { + case KI_ENVINIT: call strcpy ("KI_ENVINIT", o_str, SZ_LINE) + case KI_SETROOT: call strcpy ("KI_SETROOT", o_str, SZ_LINE) + case KI_ZOSCMD: call strcpy ("KI_OSCMD", o_str, SZ_LINE) + case KI_FMAPFN: call strcpy ("KI_FMAPFN", o_str, SZ_LINE) + + case KI_ZFACSS: call strcpy ("KI_ZFACSS", o_str, SZ_LINE) + case KI_ZFALOC: call strcpy ("KI_ZFALOC", o_str, SZ_LINE) + case KI_ZFCHDR: call strcpy ("KI_ZFCHDR", o_str, SZ_LINE) + case KI_ZFDELE: call strcpy ("KI_ZFDELE", o_str, SZ_LINE) + case KI_ZFINFO: call strcpy ("KI_ZFINFO", o_str, SZ_LINE) + case KI_ZFGCWD: call strcpy ("KI_ZFGCWD", o_str, SZ_LINE) + case KI_ZFMKCP: call strcpy ("KI_ZFMKCP", o_str, SZ_LINE) + case KI_ZFMKDR: call strcpy ("KI_ZFMKDR", o_str, SZ_LINE) + case KI_ZFPATH: call strcpy ("KI_ZFPATH", o_str, SZ_LINE) + case KI_ZFPROT: call strcpy ("KI_ZFPROT", o_str, SZ_LINE) + case KI_ZFRNAM: call strcpy ("KI_ZFRNAM", o_str, SZ_LINE) + case KI_ZFRMDR: call strcpy ("KI_ZFRMDR", o_str, SZ_LINE) + case KI_ZFSUBD: call strcpy ("KI_ZFSUBD", o_str, SZ_LINE) + case KI_ZDVALL: call strcpy ("KI_ZDVALL", o_str, SZ_LINE) + case KI_ZDVOWN: call strcpy ("KI_ZDVOWN", o_str, SZ_LINE) + case KI_ZFUTIM: call strcpy ("KI_ZFUTIM", o_str, SZ_LINE) + + case KI_ZOPDIR: call strcpy ("KI_ZOPDIR", o_str, SZ_LINE) + case KI_ZCLDIR: call strcpy ("KI_ZCLDIR", o_str, SZ_LINE) + case KI_ZGFDIR: call strcpy ("KI_ZGFDIR", o_str, SZ_LINE) + + case KI_ZOPDPR: call strcpy ("KI_ZOPDPR", o_str, SZ_LINE) + case KI_ZCLDPR: call strcpy ("KI_ZCLDPR", o_str, SZ_LINE) + case KI_ZOPCPR: call strcpy ("KI_ZOPCPR", o_str, SZ_LINE) + case KI_ZCLCPR: call strcpy ("KI_ZCLCPR", o_str, SZ_LINE) + case KI_ZINTPR: call strcpy ("KI_ZINTPR", o_str, SZ_LINE) + + # Device driver opcodes. + case KI_ZFIOBF: call strcpy ("KI_ZFIOBF", o_str, SZ_LINE) + case KI_ZFIOLP: call strcpy ("KI_ZFIOLP", o_str, SZ_LINE) + case KI_ZFIOPL: call strcpy ("KI_ZFIOPL", o_str, SZ_LINE) + case KI_ZFIOPR: call strcpy ("KI_ZFIOPR", o_str, SZ_LINE) + case KI_ZFIOSF: call strcpy ("KI_ZFIOSF", o_str, SZ_LINE) + case KI_ZFIOGD: call strcpy ("KI_ZFIOGD", o_str, SZ_LINE) + + case KI_ZFIOTX: call strcpy ("KI_ZFIOTX", o_str, SZ_LINE) + case KI_ZFIOTY: call strcpy ("KI_ZFIOTY", o_str, SZ_LINE) + + case KI_ZFIOMT: call strcpy ("KI_ZFIOMT", o_str, SZ_LINE) + + default: call strcpy ("", o_str, SZ_LINE) + } + + + # Now convert the subcode if needed. + call aclrc (s_str, SZ_LINE) + if (opcode >= KI_ZFIOBF && opcode <= KI_ZFIOGD) { + switch (subcode) { + case BF_OPN: call strcpy ("BF_OPN", s_str, SZ_LINE) + case BF_CLS: call strcpy ("BF_CLS", s_str, SZ_LINE) + case BF_ARD: call strcpy ("BF_ARD", s_str, SZ_LINE) + case BF_AWR: call strcpy ("BF_AWR", s_str, SZ_LINE) + case BF_AWT: call strcpy ("BF_AWT", s_str, SZ_LINE) + case BF_STT: call strcpy ("BF_STT", s_str, SZ_LINE) + default: call strcpy ("", s_str, SZ_LINE) + } + + } else if (opcode >= KI_ZFIOTX || opcode <= KI_ZFIOTY) { + switch (subcode) { + case TX_OPN: call strcpy ("TX_OPN", s_str, SZ_LINE) + case TX_CLS: call strcpy ("TX_CLS", s_str, SZ_LINE) + case TX_GET: call strcpy ("TX_GET", s_str, SZ_LINE) + case TX_PUT: call strcpy ("TX_PUT", s_str, SZ_LINE) + case TX_FLS: call strcpy ("TX_FLS", s_str, SZ_LINE) + case TX_SEK: call strcpy ("TX_SEK", s_str, SZ_LINE) + case TX_NOT: call strcpy ("TX_NOT", s_str, SZ_LINE) + case TX_STT: call strcpy ("TX_STT", s_str, SZ_LINE) + default: call strcpy ("", s_str, SZ_LINE) + } + + } else if (opcode >= KI_ZFIOMT) { + switch (subcode) { + case MT_OP: call strcpy ("MT_OP", s_str, SZ_LINE) + case MT_CL: call strcpy ("MT_CL", s_str, SZ_LINE) + case MT_RD: call strcpy ("MT_RD", s_str, SZ_LINE) + case MT_WR: call strcpy ("MT_WR", s_str, SZ_LINE) + case MT_WT: call strcpy ("MT_WT", s_str, SZ_LINE) + case MT_ST: call strcpy ("MT_ST", s_str, SZ_LINE) + case MT_RW: call strcpy ("MT_RW", s_str, SZ_LINE) + default: call strcpy ("", s_str, SZ_LINE) + } + } + +end diff --git a/sys/ki/kbzard.x b/sys/ki/kbzard.x new file mode 100644 index 00000000..7370f7f9 --- /dev/null +++ b/sys/ki/kbzard.x @@ -0,0 +1,60 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KB_ZARD -- Asynchronous read from a binary device. We are called only if +# the device does not reside on the local node. In this implementation +# these reads are not actually asynchronous. This is possible but more +# complex to implement than I wanted to get into at this time, particularly +# since FIO is not yet fully asynchronous. The problem is that a node +# channel may be used to multiplex any number of requests to the remote +# node process. If an asynchronous read is pending this must be detected +# and the read completed before processing any other requests. + +procedure kb_zard (device, chan, obuf, max_bytes, loffset) + +int device # device driver code +int chan # channel assigned device +char obuf[max_bytes] # receives data +int max_bytes # max bytes to read +long loffset # file offset + +int server, status +int ki_send(), ki_receive() +include "kichan.com" +include "kii.com" + +begin + server = k_node[chan] + + if (max_bytes <= 0) { + k_status[chan] = 0 + return + } + + # Send the request to initiate the read. + + p_arg[1] = k_oschan[chan] + p_arg[2] = max_bytes + p_arg[3] = loffset + + if (ki_send (server, device, BF_ARD) == ERR) { + status = ERR + } else { + # Wait for the ZAWT packet. + if (ki_receive (server, device, BF_AWT) == ERR) + status = ERR + else + status = p_arg[1] + + # Read the data block (if any) directly into caller's buffer. + if (status > 0) { + call ks_aread (server, obuf, status) + call ks_await (server, status) + } + } + + k_status[chan] = status +end diff --git a/sys/ki/kbzawr.x b/sys/ki/kbzawr.x new file mode 100644 index 00000000..406c14ba --- /dev/null +++ b/sys/ki/kbzawr.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KB_ZAWR -- Asynchronous write to a binary device. We are called only if +# the device does not reside on the local node. + +procedure kb_zawr (device, chan, ibuf, nbytes, loffset) + +int device # device driver code +int chan # channel assigned device +char ibuf[nbytes] # receives data +int nbytes # number of bytes to write +long loffset # file offset + +int server +int ki_send() +include "kichan.com" +include "kii.com" + +begin + server = k_node[chan] + + if (nbytes <= 0) { + k_status[chan] = 0 + return + } + + # Send the request followed by the data block. We must wait for the + # write into the network channel to complete since the channel is + # multiplexed. Note that this is not the same as waiting for the + # data transfer to the physical device to complete; that transfer is + # at least partially asynchronous. + + p_arg[1] = k_oschan[chan] + p_arg[2] = nbytes + p_arg[3] = loffset + + if (ki_send (server, device, BF_AWR) == ERR) + k_status[chan] = ERR + else { + call ks_awrite (server, ibuf, nbytes) + call ks_await (server, k_status[chan]) + } +end diff --git a/sys/ki/kbzawt.x b/sys/ki/kbzawt.x new file mode 100644 index 00000000..e0d5a9d6 --- /dev/null +++ b/sys/ki/kbzawt.x @@ -0,0 +1,43 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ki.h" + +# KB_ZAWT -- Wait for i/o to a binary file. Called after an asynchronous read +# or write has been issued on a channel. We are not called unless the device +# does not reside on the local node. If the last i/o transfer was a read then +# the ZAWT packet will be followed by the data which we must copy into the +# callers buffer, using the pointer saved when the read was posted. If the +# last i/o operation was a write then we assume that the write was successful +# and merely return the number of bytes written (error checking occurs +# elsewhere). +# +# read: sendpkt, rcvpkt, readdata +# write: sendpkt, senddata [nothing] +# +# (zard|zawr) (zawt) +# +# Note that the ZAWT function is processed locally in the case of a write, +# rather than being passed to the kernel server. This makes file write +# operations a pipelined operation, significantly increasing the opportunity +# for overlapped execution and increasing the data bandwidth. If the number +# of bytes transferred to the remote device is not what is requested then the +# remote kernel server will close the entire channel down (not just the +# multiplexed channel for the device), causing a ZAWRKS error in the local +# process. +# +# NOTE -- disregard the above regarding asynchronous reads. ZARD is currently +# implemented as a synchronous read. The comments are retained here to show +# how to speed up reads when the i/o system is made fully asynchronous. + +procedure kb_zawt (device, chan, status) + +int device # device driver code +int chan # channel assigned device +int status # receives nbytes transferred or ERR + +include "kichan.com" + +begin + status = k_status[chan] +end diff --git a/sys/ki/kbzcls.x b/sys/ki/kbzcls.x new file mode 100644 index 00000000..afb1f348 --- /dev/null +++ b/sys/ki/kbzcls.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KB_ZCLS -- Close a binary device. We are called only if the device does not +# reside on the local node. + +procedure kb_zcls (device, chan, status) + +int device # device driver code +int chan # channel assigned device +int status # receives ok|err + +int server +int ki_sendrcv() +include "kichan.com" +include "kii.com" + +begin + server = k_node[chan] + p_arg[1] = k_oschan[chan] + + # If we receive error on the KS channel when trying to close a file, + # it is most likely due to a previous i/o error on the channel. Do + # not return error here because we are probably being called during + # error recovery to free the logical channel, and if we return error + # the real error will be hidden. + + if (ki_sendrcv (server, device, BF_CLS) == ERR) + status = OK + else + status = p_arg[1] + + call ki_freechan (chan) +end diff --git a/sys/ki/kbzopn.x b/sys/ki/kbzopn.x new file mode 100644 index 00000000..8a332b47 --- /dev/null +++ b/sys/ki/kbzopn.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ki.h" + +# KB_ZOPN -- Open a binary device. We are called only if the device does not +# reside on the local node. + +procedure kb_zopn (device, osfn, mode, chan) + +int device # device driver code +char osfn[ARB] # packed os filename +int mode # access mode +int chan # receives assigned channel + +int server +int ki_connect(), ki_sendrcv(), ki_getchan() +include "kii.com" + +begin + server = ki_connect (osfn) + p_arg[2] = mode + + if (ki_sendrcv (server, device, BF_OPN) == ERR) + chan = ERR + else if (p_arg[1] == ERR) + chan = ERR + else + chan = ki_getchan (server, p_arg[1]) +end diff --git a/sys/ki/kbzstt.x b/sys/ki/kbzstt.x new file mode 100644 index 00000000..0610dd7f --- /dev/null +++ b/sys/ki/kbzstt.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "ki.h" + +# KB_ZSTT -- Get file status on a binary device. We are called only if the +# device does not reside on the local node. + +procedure kb_zstt (device, chan, what, lvalue) + +int device # device driver code +int chan # channel assigned device +int what # file parameter to be returned +long lvalue # receives the parameter value + +int server, ks_maxbufsize +int ki_sendrcv() +include "kichan.com" +include "kinode.com" +include "kii.com" +data ks_maxbufsize /-1/ + +begin + server = k_node[chan] + p_arg[1] = k_oschan[chan] + p_arg[2] = what + + if (ki_sendrcv (server, device, BF_STT) == ERR) + lvalue = ERR + else { + lvalue = p_arg[1] + + # The maximum buffer (transfer) size for a device is determined + # by the the network interface or by the device, whichever is + # smaller. + + if (what == FSTT_MAXBUFSIZE || what == FSTT_OPTBUFSIZE) { + if (ks_maxbufsize < 0) + call zsttks (n_kschan[server], FSTT_MAXBUFSIZE, ks_maxbufsize) + if (lvalue == 0) + lvalue = ks_maxbufsize + else if (ks_maxbufsize > 0) + lvalue = min (lvalue, ks_maxbufsize) + } + } +end diff --git a/sys/ki/kclcpr.x b/sys/ki/kclcpr.x new file mode 100644 index 00000000..b3822c63 --- /dev/null +++ b/sys/ki/kclcpr.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KCLCPR -- Close a connected subprocess. + +procedure kclcpr (pid, exit_status) + +int pid # channel descriptor +int exit_status # exit status of the job + +int server, inchan, outchan +int ki_sendrcv() +include "kichan.com" +include "kii.com" + +begin + # Possible if an abort occurs during the open. + if (pid <= 0) { + exit_status = OK + return + } + + server = k_node[pid] + + if (server == NULL) { + call zclcpr (k_oschan[pid], exit_status) + } else { + p_arg[1] = k_oschan[pid] + p_sbuflen = 0 + + if (ki_sendrcv (server, KI_ZCLCPR, 0) == ERR) + exit_status = ERR + else + exit_status = p_arg[1] + } + + # The channel descriptor numbers of the two cds used for the i/o + # streams are encoded in the k_status field of the PID cd. + + inchan = k_status[pid] / MAX_CHANNELS + outchan = mod (k_status[pid], MAX_CHANNELS) + + # Free the 3 channel descriptors used by the subprocess. + call ki_freechan (pid) + call ki_freechan (inchan) + call ki_freechan (outchan) +end diff --git a/sys/ki/kcldir.x b/sys/ki/kcldir.x new file mode 100644 index 00000000..8f85f82f --- /dev/null +++ b/sys/ki/kcldir.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KCLDIR -- Close a directory file. + +procedure kcldir (chan, status) + +int chan # channel descriptor +int status # answer; ok or err + +int server +int ki_sendrcv() +include "kichan.com" +include "kii.com" + +begin + # Possible if an abort occurs during the open. + if (chan <= 0) { + status = OK + return + } + + server = k_node[chan] + + if (server == NULL) { + call zcldir (k_oschan[chan], status) + + } else { + p_arg[1] = k_oschan[chan] + p_sbuflen = 0 + + if (ki_sendrcv (server, KI_ZCLDIR, 0) == ERR) + status = ERR + else + status = p_arg[1] + + call mfree (k_bufp[chan], TY_STRUCT) + } + + call ki_freechan (chan) +end diff --git a/sys/ki/kcldpr.x b/sys/ki/kcldpr.x new file mode 100644 index 00000000..43060701 --- /dev/null +++ b/sys/ki/kcldpr.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KCLDPR -- Close a detached process. + +procedure kcldpr (jobcode, killflag, exit_status) + +int jobcode # channel descriptor +int killflag # kill job or just wait for it to terminate +int exit_status # exit status of the job + +int server +int ki_sendrcv() +include "kichan.com" +include "kii.com" + +begin + # Possible if an abort occurs during the open. + if (jobcode <= 0) { + exit_status = OK + return + } + + server = k_node[jobcode] + + if (server == NULL) { + call zcldpr (k_oschan[jobcode], killflag, exit_status) + + } else { + p_arg[1] = k_oschan[jobcode] + p_arg[2] = killflag + p_sbuflen = 0 + + if (ki_sendrcv (server, KI_ZCLDPR, 0) == ERR) + exit_status = ERR + else + exit_status = p_arg[1] + } + + call ki_freechan (jobcode) +end diff --git a/sys/ki/kdvall.x b/sys/ki/kdvall.x new file mode 100644 index 00000000..a198df4f --- /dev/null +++ b/sys/ki/kdvall.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ki.h" + +# KDVALL -- Allocate/deallocate a device. + +procedure kdvall (device, allflag, status) + +char device[ARB] # device name or alias list +int allflag # flag: allocate=1, deallocate=0 +int status # return status + +int server +int ki_connect(), ki_sendrcv() +include "kii.com" + +begin + server = ki_connect (device) + + if (server == NULL) { + call strpak (p_sbuf[p_arg[1]], p_sbuf, SZ_SBUF) + call zdvall (p_sbuf, allflag, status) + + } else { + p_arg[2] = allflag + if (ki_sendrcv (server, KI_ZDVALL, 0) == ERR) + status = ERR + else + status = p_arg[1] + } +end diff --git a/sys/ki/kdvown.x b/sys/ki/kdvown.x new file mode 100644 index 00000000..0b5180a7 --- /dev/null +++ b/sys/ki/kdvown.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ki.h" + +# KDVOWN -- Query device allocation; return the owner name if the device is +# allocated to someone else. + +procedure kdvown (device, owner, maxch, status) + +char device[ARB] # packed device name string +char owner[ARB] # receives owner name string +int maxch # max chars out +int status # allocation status () + +int server +int ki_connect(), ki_sendrcv() +include "kii.com" + +begin + server = ki_connect (device) + + if (server == NULL) { + call strpak (p_sbuf[p_arg[1]], p_sbuf, SZ_SBUF) + call zdvown (p_sbuf, owner, maxch, status) + + } else { + p_arg[2] = maxch + if (ki_sendrcv (server, KI_ZDVOWN, 0) == ERR) { + owner[1] = EOS + status = ERR + } else { + status = p_arg[1] + call strpak (p_sbuf, owner, maxch) + } + } +end diff --git a/sys/ki/kfacss.x b/sys/ki/kfacss.x new file mode 100644 index 00000000..5634e099 --- /dev/null +++ b/sys/ki/kfacss.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ki.h" + +# KFACSS -- Determine the accessibility and type of a file. + +procedure kfacss (osfn, mode, type, status) + +char osfn[ARB] # packed os filename +int mode # access mode or null if don't care +int type # file type or null if don't care +int status # answer; yes or no + +int server +int ki_connect(), ki_sendrcv() +include "kii.com" + +begin + server = ki_connect (osfn) + + if (server == NULL) { + call strpak (p_sbuf[p_arg[1]], p_sbuf, SZ_SBUF) + call zfacss (p_sbuf, mode, type, status) + + } else { + p_arg[2] = mode + p_arg[3] = type + + if (ki_sendrcv (server, KI_ZFACSS, 0) == ERR) + status = ERR + else + status = p_arg[1] + } +end diff --git a/sys/ki/kfaloc.x b/sys/ki/kfaloc.x new file mode 100644 index 00000000..4ba8d041 --- /dev/null +++ b/sys/ki/kfaloc.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ki.h" + +# KFALOC -- Create and preallocate space for a binary file. + +procedure kfaloc (osfn, nbytes, status) + +char osfn[ARB] # packed os filename +int nbytes # nbytes of storage to allocate +int status # answer; ok or err + +int server +int ki_connect(), ki_sendrcv() +include "kii.com" + +begin + server = ki_connect (osfn) + + if (server == NULL) { + call strpak (p_sbuf[p_arg[1]], p_sbuf, SZ_SBUF) + call zfaloc (p_sbuf, nbytes, status) + + } else { + p_arg[2] = nbytes + + if (ki_sendrcv (server, KI_ZFALOC, 0) == ERR) + status = ERR + else + status = p_arg[1] + } +end diff --git a/sys/ki/kfchdr.x b/sys/ki/kfchdr.x new file mode 100644 index 00000000..2e1b6501 --- /dev/null +++ b/sys/ki/kfchdr.x @@ -0,0 +1,61 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "ki.h" + +# KFCHDR -- Change the default directory. The default node is also set if +# the request is successful. + +procedure kfchdr (dirname, status) + +char dirname[ARB] # directory name +int status + +pointer sp, fname, defnode +int server, junk +int ki_gnode(), ki_connect(), ki_findnode() +# int ki_sendrcv() +include "kinode.com" +include "kii.com" + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (defnode, SZ_ALIAS, TY_CHAR) + + server = ki_connect (dirname) + + if (server == NULL) { + # Directory is on the local node. + + call strpak (p_sbuf[p_arg[1]], p_sbuf, SZ_SBUF) + call zfchdr (p_sbuf, status) + + } else { + # Directory is on a remote node. Pass the node relative chdir + # request on to the remote node and set the default node locally + # if the request is successful. + + # Does not work yet. + #if (ki_sendrcv (server, KI_ZFCHDR, 0) != ERR) + # status = p_arg[1] + #else + # status = ERR + + status = ERR + } + + # Update the default node if the change directory request + # is successful. + + if (status != ERR) { + call strupk (dirname, Memc[fname], SZ_PATHNAME) + junk = ki_gnode (Memc[fname], Memc[defnode], junk) + call strcpy (Memc[defnode], n_defaultnode, SZ_ALIAS) + n_default = ki_findnode (n_defaultnode) + } + + call sfree (sp) +end diff --git a/sys/ki/kfdele.x b/sys/ki/kfdele.x new file mode 100644 index 00000000..53e0822a --- /dev/null +++ b/sys/ki/kfdele.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ki.h" + +# KFDELE -- Delete a file. + +procedure kfdele (osfn, status) + +char osfn[ARB] # packed os filename +int status # answer; ok or err + +int server +int ki_connect(), ki_sendrcv() +include "kii.com" + +begin + server = ki_connect (osfn) + + if (server == NULL) { + call strpak (p_sbuf[p_arg[1]], p_sbuf, SZ_SBUF) + call zfdele (p_sbuf, status) + + } else { + if (ki_sendrcv (server, KI_ZFDELE, 0) == ERR) + status = ERR + else + status = p_arg[1] + } +end diff --git a/sys/ki/kfgcwd.x b/sys/ki/kfgcwd.x new file mode 100644 index 00000000..c142eaa8 --- /dev/null +++ b/sys/ki/kfgcwd.x @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "ki.h" + +# KFGCWD -- Get the name of the current default directory. + +procedure kfgcwd (outstr, maxch, nchars) + +char outstr[maxch] # receives pathname of directory +int maxch # max chars out +int nchars # length of returned string + +int server, op +int gstrcpy(), ki_sendrcv() +include "kinode.com" +include "kii.com" +define err_ 91 + +begin + # If the current directory resides on the local node pass the zfgcwd + # request to the local kernel, else pass it to the kernel on the remote + # (default) node. Leave the CWD in p_sbuf. + + if (n_default == NULL || n_default == n_local) { +err_ call zfgcwd (p_sbuf, SZ_SBUF, nchars) + call strupk (p_sbuf, p_sbuf, SZ_SBUF) + p_arg[2] = 1 + + } else { + # If the current directory is on a remote node then there must be + # a connected kernel server attached to that node. + + server = n_default + + if (ki_sendrcv (server, KI_ZFGCWD, 0) == ERR) { + n_default = n_local + goto err_ + } + } + + # Return node // directory. + + op = gstrcpy (n_defaultnode, outstr, maxch) + 1 + if (op > 1) { + outstr[op] = FNNODE_CHAR + op = op + 1 + } + + nchars = op + gstrcpy (p_sbuf[p_arg[2]], outstr[op], maxch-op+1) + call strpak (outstr, outstr, maxch) +end diff --git a/sys/ki/kfinfo.x b/sys/ki/kfinfo.x new file mode 100644 index 00000000..cfc0353d --- /dev/null +++ b/sys/ki/kfinfo.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KFINFO -- Get directory info on a file. + +procedure kfinfo (osfn, fi, status) + +char osfn[ARB] # packed os filename +long fi[ARB] # receives finfo structure +int status # answer; ok or err + +int server, i +int ki_connect(), ki_sendrcv() +include "kii.com" + +begin + server = ki_connect (osfn) + + if (server == NULL) { + call strpak (p_sbuf[p_arg[1]], p_sbuf, SZ_SBUF) + call zfinfo (p_sbuf, fi, status) + + } else { + if (ki_sendrcv (server, KI_ZFINFO, 0) == ERR) + status = ERR + else { + status = p_arg[1] + + # The finfo structure is returned in ARG except for the + # owner string, which is returned in sbuf. Note that we + # are passing longs in ints hence precision could conceivably + # be lost (most unlikely). + + do i = 1, FI_NINTFIELDS + fi[i] = p_arg[i+1] + call strpak (p_sbuf, FI_OWNER(fi), FI_SZOWNER) + } + } +end diff --git a/sys/ki/kfiobf.x b/sys/ki/kfiobf.x new file mode 100644 index 00000000..50d7f500 --- /dev/null +++ b/sys/ki/kfiobf.x @@ -0,0 +1,110 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KFIOBF -- Binary file driver. + +procedure kopnbf (osfn, mode, chan) + +char osfn[ARB] +int mode, chan + +int server +int ki_connect(), ki_getchan() +include "kii.com" + +begin + server = ki_connect (osfn) + + if (server == NULL) { + call strpak (p_sbuf[p_arg[1]], p_sbuf, SZ_SBUF) + call zopnbf (p_sbuf, mode, chan) + if (chan != ERR) + chan = ki_getchan (server, chan) + } else + call kb_zopn (KI_ZFIOBF, osfn, mode, chan) +end + + +procedure kclsbf (chan, status) + +int chan +int status +include "kichan.com" + +begin + # Possible if an abort occurs during the open. + if (chan <= 0) { + status = OK + return + } + + if (k_node[chan] == NULL) { + call zclsbf (k_oschan[chan], status) + call ki_freechan (chan) + } else + call kb_zcls (KI_ZFIOBF, chan, status) +end + + +procedure kardbf (chan, buf, max_bytes, offset) + +int chan +char buf[ARB] +int max_bytes +long offset +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zardbf (k_oschan[chan], buf, max_bytes, offset) + else + call kb_zard (KI_ZFIOBF, chan, buf, max_bytes, offset) +end + + +procedure kawrbf (chan, buf, nbytes, offset) + +int chan +char buf[ARB] +int nbytes +long offset +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zawrbf (k_oschan[chan], buf, nbytes, offset) + else + call kb_zawr (KI_ZFIOBF, chan, buf, nbytes, offset) +end + + +procedure kawtbf (chan, status) + +int chan +int status +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zawtbf (k_oschan[chan], status) + else + call kb_zawt (KI_ZFIOBF, chan, status) +end + + +procedure ksttbf (chan, what, lvalue) + +int chan +int what +long lvalue +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zsttbf (k_oschan[chan], what, lvalue) + else + call kb_zstt (KI_ZFIOBF, chan, what, lvalue) +end diff --git a/sys/ki/kfiogd.x b/sys/ki/kfiogd.x new file mode 100644 index 00000000..bde39350 --- /dev/null +++ b/sys/ki/kfiogd.x @@ -0,0 +1,110 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KFIOGD -- Binary graphics device file driver. + +procedure kopngd (osfn, mode, chan) + +char osfn[ARB] +int mode, chan + +int server +int ki_connect(), ki_getchan() +include "kii.com" + +begin + server = ki_connect (osfn) + + if (server == NULL) { + call strpak (p_sbuf[p_arg[1]], p_sbuf, SZ_SBUF) + call zopngd (p_sbuf, mode, chan) + if (chan != ERR) + chan = ki_getchan (server, chan) + } else + call kb_zopn (KI_ZFIOGD, osfn, mode, chan) +end + + +procedure kclsgd (chan, status) + +int chan +int status +include "kichan.com" + +begin + # Possible if an abort occurs during the open. + if (chan <= 0) { + status = OK + return + } + + if (k_node[chan] == NULL) { + call zclsgd (k_oschan[chan], status) + call ki_freechan (chan) + } else + call kb_zcls (KI_ZFIOGD, chan, status) +end + + +procedure kardgd (chan, buf, max_bytes, offset) + +int chan +char buf[ARB] +int max_bytes +long offset +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zardgd (k_oschan[chan], buf, max_bytes, offset) + else + call kb_zard (KI_ZFIOGD, chan, buf, max_bytes, offset) +end + + +procedure kawrgd (chan, buf, nbytes, offset) + +int chan +char buf[ARB] +int nbytes +long offset +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zawrgd (k_oschan[chan], buf, nbytes, offset) + else + call kb_zawr (KI_ZFIOGD, chan, buf, nbytes, offset) +end + + +procedure kawtgd (chan, status) + +int chan +int status +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zawtgd (k_oschan[chan], status) + else + call kb_zawt (KI_ZFIOGD, chan, status) +end + + +procedure ksttgd (chan, what, lvalue) + +int chan +int what +long lvalue +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zsttgd (k_oschan[chan], what, lvalue) + else + call kb_zstt (KI_ZFIOGD, chan, what, lvalue) +end diff --git a/sys/ki/kfiolp.x b/sys/ki/kfiolp.x new file mode 100644 index 00000000..7e642b00 --- /dev/null +++ b/sys/ki/kfiolp.x @@ -0,0 +1,110 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KFIOLP -- Line printer driver. + +procedure kopnlp (osfn, mode, chan) + +char osfn[ARB] +int mode, chan + +int server +int ki_connect(), ki_getchan() +include "kii.com" + +begin + server = ki_connect (osfn) + + if (server == NULL) { + call strpak (p_sbuf[p_arg[1]], p_sbuf, SZ_SBUF) + call zopnlp (p_sbuf, mode, chan) + if (chan != ERR) + chan = ki_getchan (server, chan) + } else + call kb_zopn (KI_ZFIOLP, osfn, mode, chan) +end + + +procedure kclslp (chan, status) + +int chan +int status +include "kichan.com" + +begin + # Possible if an abort occurs during the open. + if (chan <= 0) { + status = OK + return + } + + if (k_node[chan] == NULL) { + call zclslp (k_oschan[chan], status) + call ki_freechan (chan) + } else + call kb_zcls (KI_ZFIOLP, chan, status) +end + + +procedure kardlp (chan, buf, max_bytes, offset) + +int chan +char buf[ARB] +int max_bytes +long offset +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zardlp (k_oschan[chan], buf, max_bytes, offset) + else + call kb_zard (KI_ZFIOLP, chan, buf, max_bytes, offset) +end + + +procedure kawrlp (chan, buf, nbytes, offset) + +int chan +char buf[ARB] +int nbytes +long offset +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zawrlp (k_oschan[chan], buf, nbytes, offset) + else + call kb_zawr (KI_ZFIOLP, chan, buf, nbytes, offset) +end + + +procedure kawtlp (chan, status) + +int chan +int status +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zawtlp (k_oschan[chan], status) + else + call kb_zawt (KI_ZFIOLP, chan, status) +end + + +procedure ksttlp (chan, what, lvalue) + +int chan +int what +long lvalue +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zsttlp (k_oschan[chan], what, lvalue) + else + call kb_zstt (KI_ZFIOLP, chan, what, lvalue) +end diff --git a/sys/ki/kfiopl.x b/sys/ki/kfiopl.x new file mode 100644 index 00000000..346101cc --- /dev/null +++ b/sys/ki/kfiopl.x @@ -0,0 +1,110 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KFIOPL -- Plotter driver (NSPP metacode translator). + +procedure kopnpl (osfn, mode, chan) + +char osfn[ARB] +int mode, chan + +int server +int ki_connect(), ki_getchan() +include "kii.com" + +begin + server = ki_connect (osfn) + + if (server == NULL) { + call strpak (p_sbuf[p_arg[1]], p_sbuf, SZ_SBUF) + call zopnpl (p_sbuf, mode, chan) + if (chan != ERR) + chan = ki_getchan (server, chan) + } else + call kb_zopn (KI_ZFIOPL, osfn, mode, chan) +end + + +procedure kclspl (chan, status) + +int chan +int status +include "kichan.com" + +begin + # Possible if an abort occurs during the open. + if (chan <= 0) { + status = OK + return + } + + if (k_node[chan] == NULL) { + call zclspl (k_oschan[chan], status) + call ki_freechan (chan) + } else + call kb_zcls (KI_ZFIOPL, chan, status) +end + + +procedure kardpl (chan, buf, max_bytes, offset) + +int chan +char buf[ARB] +int max_bytes +long offset +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zardpl (k_oschan[chan], buf, max_bytes, offset) + else + call kb_zard (KI_ZFIOPL, chan, buf, max_bytes, offset) +end + + +procedure kawrpl (chan, buf, nbytes, offset) + +int chan +char buf[ARB] +int nbytes +long offset +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zawrpl (k_oschan[chan], buf, nbytes, offset) + else + call kb_zawr (KI_ZFIOPL, chan, buf, nbytes, offset) +end + + +procedure kawtpl (chan, status) + +int chan +int status +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zawtpl (k_oschan[chan], status) + else + call kb_zawt (KI_ZFIOPL, chan, status) +end + + +procedure ksttpl (chan, what, lvalue) + +int chan +int what +long lvalue +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zsttpl (k_oschan[chan], what, lvalue) + else + call kb_zstt (KI_ZFIOPL, chan, what, lvalue) +end diff --git a/sys/ki/kfiopr.x b/sys/ki/kfiopr.x new file mode 100644 index 00000000..2abae18e --- /dev/null +++ b/sys/ki/kfiopr.x @@ -0,0 +1,106 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KFIOPR -- IPC driver. This driver has no open and close entry points since +# these functions are provided by the ZOPCPR and ZCLCPR procedures, which also +# spawn the subprocess. + +# procedure kopnpr (osfn, mode, chan) +# +# char osfn[ARB] +# int mode, chan +# +# int server +# int ki_connect(), ki_getchan() +# include "kii.com" +# +# begin +# server = ki_connect (osfn) +# +# if (server == NULL) { +# call strpak (p_sbuf[p_arg[1]], p_sbuf, SZ_SBUF) +# call zopnpr (p_sbuf, mode, chan) +# if (chan != ERR) +# chan = ki_getchan (server, chan) +# } else +# call kb_zopn (KI_ZFIOPR, osfn, mode, chan) +# end +# +# +# procedure kclspr (chan, status) +# +# int chan +# int status +# include "kichan.com" +# +# begin +# if (k_node[chan] == NULL) { +# call zclspr (k_oschan[chan], status) +# k_oschan[chan] = NULL +# } else +# call kb_zcls (KI_ZFIOPR, chan, status) +# end + + +procedure kardpr (chan, buf, max_bytes, offset) + +int chan +char buf[ARB] +int max_bytes +long offset +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zardpr (k_oschan[chan], buf, max_bytes, offset) + else + call kb_zard (KI_ZFIOPR, chan, buf, max_bytes, offset) +end + + +procedure kawrpr (chan, buf, nbytes, offset) + +int chan +char buf[ARB] +int nbytes +long offset +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zawrpr (k_oschan[chan], buf, nbytes, offset) + else + call kb_zawr (KI_ZFIOPR, chan, buf, nbytes, offset) +end + + +procedure kawtpr (chan, status) + +int chan +int status +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zawtpr (k_oschan[chan], status) + else + call kb_zawt (KI_ZFIOPR, chan, status) +end + + +procedure ksttpr (chan, what, lvalue) + +int chan +int what +long lvalue +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zsttpr (k_oschan[chan], what, lvalue) + else + call kb_zstt (KI_ZFIOPR, chan, what, lvalue) +end diff --git a/sys/ki/kfiosf.x b/sys/ki/kfiosf.x new file mode 100644 index 00000000..c14cc13c --- /dev/null +++ b/sys/ki/kfiosf.x @@ -0,0 +1,112 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KFIOSF -- Static file driver. Since the static file driver may permit +# portions of a data file to be mapped into virtual memory, use the binary +# file driver if the file resides on a remote node. + +procedure kopnsf (osfn, mode, chan) + +char osfn[ARB] +int mode, chan + +int server +int ki_connect(), ki_getchan() +include "kii.com" + +begin + server = ki_connect (osfn) + + if (server == NULL) { + call strpak (p_sbuf[p_arg[1]], p_sbuf, SZ_SBUF) + call zopnsf (p_sbuf, mode, chan) + if (chan != ERR) + chan = ki_getchan (server, chan) + } else + call kb_zopn (KI_ZFIOBF, osfn, mode, chan) +end + + +procedure kclssf (chan, status) + +int chan +int status +include "kichan.com" + +begin + # Possible if an abort occurs during the open. + if (chan <= 0) { + status = OK + return + } + + if (k_node[chan] == NULL) { + call zclssf (k_oschan[chan], status) + call ki_freechan (chan) + } else + call kb_zcls (KI_ZFIOBF, chan, status) +end + + +procedure kardsf (chan, buf, max_bytes, offset) + +int chan +char buf[ARB] +int max_bytes +long offset +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zardsf (k_oschan[chan], buf, max_bytes, offset) + else + call kb_zard (KI_ZFIOBF, chan, buf, max_bytes, offset) +end + + +procedure kawrsf (chan, buf, nbytes, offset) + +int chan +char buf[ARB] +int nbytes +long offset +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zawrsf (k_oschan[chan], buf, nbytes, offset) + else + call kb_zawr (KI_ZFIOBF, chan, buf, nbytes, offset) +end + + +procedure kawtsf (chan, status) + +int chan +int status +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zawtsf (k_oschan[chan], status) + else + call kb_zawt (KI_ZFIOBF, chan, status) +end + + +procedure ksttsf (chan, what, lvalue) + +int chan +int what +long lvalue +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zsttsf (k_oschan[chan], what, lvalue) + else + call kb_zstt (KI_ZFIOBF, chan, what, lvalue) +end diff --git a/sys/ki/kfiotx.x b/sys/ki/kfiotx.x new file mode 100644 index 00000000..b329c674 --- /dev/null +++ b/sys/ki/kfiotx.x @@ -0,0 +1,157 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "ki.h" + +# KFIOTX -- Text file driver. + +procedure kopntx (osfn, mode, chan) + +char osfn[ARB] # packed os filename +int mode # access mode +int chan # receives channel code + +int server +int ki_connect(), ki_getchan() +include "kii.com" + +begin + server = ki_connect (osfn) + + if (server == NULL) { + call strpak (p_sbuf[p_arg[1]], p_sbuf, SZ_SBUF) + call zopntx (p_sbuf, mode, chan) + if (chan != ERR) + chan = ki_getchan (server, chan) + } else + call kt_zopn (KI_ZFIOTX, osfn, mode, chan) +end + + +procedure kclstx (chan, status) + +int chan +int status +include "kichan.com" + +begin + # Possible if an abort occurs during the open. + if (chan <= 0) { + status = OK + return + } + + if (k_node[chan] == NULL) { + call zclstx (k_oschan[chan], status) + call ki_freechan (chan) + } else + call kt_zcls (KI_ZFIOTX, chan, status) +end + + +procedure kgettx (chan, text, maxch, status) + +int chan +char text[maxch] +int maxch, status +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zgettx (k_oschan[chan], text, maxch, status) + else + call kt_zget (KI_ZFIOTX, chan, text, maxch, status) +end + + +procedure kputtx (chan, text, nchars, status) + +int chan +char text[nchars] +int nchars, status +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zputtx (k_oschan[chan], text, nchars, status) + else + call kt_zput (KI_ZFIOTX, chan, text, nchars, status) +end + + +procedure kflstx (chan, status) + +int chan +int status +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zflstx (k_oschan[chan], status) + else + call kt_zfls (KI_ZFIOTX, chan, status) +end + + +procedure ksektx (chan, loffset, status) + +int chan +long loffset +int status +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zsektx (k_oschan[chan], loffset, status) + else + call kt_zsek (KI_ZFIOTX, chan, loffset, status) +end + + +procedure knottx (chan, loffset) + +int chan +long loffset +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call znottx (k_oschan[chan], loffset) + else + call kt_znot (KI_ZFIOTX, chan, loffset) +end + + +procedure kstttx (chan, what, lvalue) + +int chan +int what +long lvalue +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zstttx (k_oschan[chan], what, lvalue) + else { + # Querying the text file status parameters is slow over the net, + # and they are essentially constants anyhow, so just return the + # expected values. + # + # call kt_zstt (KI_ZFIOTX, chan, what, lvalue) + + switch (what) { + case FSTT_BLKSIZE: + lvalue = 1 + case FSTT_FILSIZE: + lvalue = 1 + case FSTT_OPTBUFSIZE: + lvalue = SZ_LINE + case FSTT_MAXBUFSIZE: + lvalue = 0 + default: + lvalue = ERR + } + } +end diff --git a/sys/ki/kfioty.x b/sys/ki/kfioty.x new file mode 100644 index 00000000..4726f5c3 --- /dev/null +++ b/sys/ki/kfioty.x @@ -0,0 +1,138 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KFIOTY -- Terminal driver. + +procedure kopnty (osfn, mode, chan) + +char osfn[ARB] # packed os filename +int mode # access mode +int chan # receives channel code + +int server +int ki_connect(), ki_getchan() +include "kii.com" + +begin + server = ki_connect (osfn) + + if (server == NULL) { + call strpak (p_sbuf[p_arg[1]], p_sbuf, SZ_SBUF) + call zopnty (p_sbuf, mode, chan) + if (chan != ERR) + chan = ki_getchan (server, chan) + } else + call kt_zopn (KI_ZFIOTY, osfn, mode, chan) +end + + +procedure kclsty (chan, status) + +int chan +int status +include "kichan.com" + +begin + # Possible if an abort occurs during the open. + if (chan <= 0) { + status = OK + return + } + + if (k_node[chan] == NULL) { + call zclsty (k_oschan[chan], status) + call ki_freechan (chan) + } else + call kt_zcls (KI_ZFIOTY, chan, status) +end + + +procedure kgetty (chan, text, maxch, status) + +int chan +char text[maxch] +int maxch, status +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zgetty (k_oschan[chan], text, maxch, status) + else + call kt_zget (KI_ZFIOTY, chan, text, maxch, status) +end + + +procedure kputty (chan, text, nchars, status) + +int chan +char text[nchars] +int nchars, status +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zputty (k_oschan[chan], text, nchars, status) + else + call kt_zput (KI_ZFIOTY, chan, text, nchars, status) +end + + +procedure kflsty (chan, status) + +int chan +int status +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zflsty (k_oschan[chan], status) + else + call kt_zfls (KI_ZFIOTY, chan, status) +end + + +procedure ksekty (chan, loffset, status) + +int chan +long loffset +int status +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zsekty (k_oschan[chan], loffset, status) + else + call kt_zsek (KI_ZFIOTY, chan, loffset, status) +end + + +procedure knotty (chan, loffset) + +int chan +long loffset +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call znotty (k_oschan[chan], loffset) + else + call kt_znot (KI_ZFIOTY, chan, loffset) +end + + +procedure ksttty (chan, what, lvalue) + +int chan +int what +long lvalue +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zsttty (k_oschan[chan], what, lvalue) + else + call kt_zstt (KI_ZFIOTY, chan, what, lvalue) +end diff --git a/sys/ki/kfmkcp.x b/sys/ki/kfmkcp.x new file mode 100644 index 00000000..675aa1b3 --- /dev/null +++ b/sys/ki/kfmkcp.x @@ -0,0 +1,136 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ki.h" + + +# KFMKCP -- Make a null length copy of a file. The new file inherits the +# attributes of the existing file. This works provided both files are on +# the same node; since the kernel routine is atomic and must access both +# files, and the attributes are OS dependent, there is no way to inherit +# the attributes if the files reside on different nodes. + +procedure kfmkcp (old_osfn, new_osfn, status) + +char old_osfn[ARB] # packed os filename of existing file +char new_osfn[ARB] # packed os filename of new file +int status # answer; ok or err + +pointer sp, fname +int server1, server2, chan, junk, old, new +int ki_connect(), ki_sendrcv(), strlen() +include "kii.com" + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + server2 = ki_connect (new_osfn) + call strcpy (p_sbuf[p_arg[1]], Memc[fname], SZ_FNAME) + server1 = ki_connect (old_osfn) + old = p_arg[1] + + if (server1 == NULL && server2 == NULL) { + # Both files reside on the local node. + + call strpak (p_sbuf[old], p_sbuf[old], SZ_SBUF) + call strpak (Memc[fname], Memc[fname], SZ_FNAME) + call zfmkcp (p_sbuf[old], Memc[fname], status) + + } else if (server1 == server2) { + # Both files reside on the same remote node. + + new = old + strlen(p_sbuf[old])+1 + 1 + if (new + strlen(Memc[fname])+1 > SZ_SBUF) + status = ERR + else { + call strcpy (Memc[fname], p_sbuf[new], SZ_SBUF-new+1) + + p_arg[2] = new + p_sbuflen = SZ_SBUF + + if (ki_sendrcv (server1, KI_ZFMKCP, 0) == ERR) + status = ERR + else + status = p_arg[1] + } + + } else if (server1 != NULL && server2 != NULL) { + # Both files are remote. Cannot transfer all attributes; + # the best we can do is create either a text or binary file. + + call kfacss (old_osfn, 0, TEXT_FILE, status) + call strpak (Memc[fname], Memc[fname], SZ_FNAME) + + if (status == YES) { + # Create a text file. + call kopntx (new_osfn, NEW_FILE, chan) + if (chan != ERR) { + call kclstx (chan, junk) + status = chan + } else + status = ERR + } else { + # Create a binary file. + call kopnbf (new_osfn, NEW_FILE, chan) + if (chan != ERR) { + call kclsbf (chan, junk) + status = chan + } else + status = ERR + } + + } else if (server1 != NULL) { + # The existing file is remote. Cannot transfer all attributes; + # the best we can do is create either a text or binary file. + # Call ZFACSS to determine the file type of the existing file + # and create a null length text or binary file. + + call kfacss (old_osfn, 0, TEXT_FILE, status) + call strpak (Memc[fname], Memc[fname], SZ_FNAME) + + if (status == YES) { + # Create a text file. + call zopntx (Memc[fname], NEW_FILE, chan) + if (chan != ERR) { + call zclstx (chan, junk) + status = chan + } else + status = ERR + } else { + # Create a binary file. + call zopnbf (Memc[fname], NEW_FILE, chan) + if (chan != ERR) { + call zclsbf (chan, junk) + status = chan + } else + status = ERR + } + + } else { + # The new file is remote. + + call strpak (p_sbuf[old], p_sbuf[old], SZ_SBUF) + call zfacss (p_sbuf[old], 0, TEXT_FILE, status) + + if (status == YES) { + # Create a text file. + call kopntx (new_osfn, NEW_FILE, chan) + if (chan != ERR) { + call kclstx (chan, junk) + status = chan + } else + status = ERR + } else { + # Create a binary file. + call kopnbf (new_osfn, NEW_FILE, chan) + if (chan != ERR) { + call kclsbf (chan, junk) + status = chan + } else + status = ERR + } + } + + call sfree (sp) +end diff --git a/sys/ki/kfmkdr.x b/sys/ki/kfmkdr.x new file mode 100644 index 00000000..8e32ac50 --- /dev/null +++ b/sys/ki/kfmkdr.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ki.h" + +# KFMKDR -- Make a new directory. + +procedure kfmkdr (osfn, status) + +char osfn[ARB] # packed os filename of directory +int status # ok or err + +int server +int ki_connect(), ki_sendrcv() +include "kii.com" + +begin + server = ki_connect (osfn) + + if (server == NULL) { + call strpak (p_sbuf[p_arg[1]], p_sbuf, SZ_SBUF) + call zfmkdr (p_sbuf, status) + + } else { + if (ki_sendrcv (server, KI_ZFMKDR, 0) == ERR) + status = ERR + else + status = p_arg[1] + } +end diff --git a/sys/ki/kfpath.x b/sys/ki/kfpath.x new file mode 100644 index 00000000..6522e5f2 --- /dev/null +++ b/sys/ki/kfpath.x @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ki.h" + +# KFPATH -- Convert a VFN into a net pathname. The VFN may contain a node +# pathname and the final pathname will always include the node name. + +procedure kfpath (vfn, osfn, maxch, nchars) + +char vfn[ARB] # virtual filename +char osfn[maxch] # receives pathname +int maxch # max chars out +int nchars # receives length of osfn string + +int delim, op, nodeflag, junk +int ki_gnode(), gstrcpy(), ki_gethosts() +include "kinode.com" + +begin + # Read the host name table if it has not been read yet. + if (n_nnodes == 0) + junk = ki_gethosts() + + # If no VFN is given return the current working directory. + if (vfn[1] == EOS) { + call kfgcwd (osfn, maxch, nchars) + call strupk (osfn, osfn, maxch) + return + } + + # Determine what node the given VFN resides on. + nodeflag = ki_gnode (vfn, osfn, delim) + + # Append the node delimiter to the node name if there is a node name. + for (op=1; osfn[op] != EOS; op=op+1) + ; + if (op > 1) { + osfn[op] = FNNODE_CHAR + op = op + 1 + } + + if (nodeflag == LOCAL) { + # File is on the local node. Return the mapped pathname with + # the node name of the local node prepended. + + call zfpath (vfn[delim+1], osfn[op], maxch-op+1, nchars) + nchars = nchars + op - 1 + + } else { + # File is on a remote node. Do not map the filename; leave that + # to the kernel when the file is referenced at runtime. + + nchars = gstrcpy (vfn[delim+1], osfn[op], maxch-op+1) + op - 1 + } +end diff --git a/sys/ki/kfprot.x b/sys/ki/kfprot.x new file mode 100644 index 00000000..d2338d8f --- /dev/null +++ b/sys/ki/kfprot.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ki.h" + +# KFPROT -- Set or query file protection. + +procedure kfprot (osfn, protflag, status) + +char osfn[ARB] # packed os filename +int protflag # set/query flag +int status # answer; yes or no + +int server +int ki_connect(), ki_sendrcv() +include "kii.com" + +begin + server = ki_connect (osfn) + + if (server == NULL) { + call strpak (p_sbuf[p_arg[1]], p_sbuf, SZ_SBUF) + call zfprot (p_sbuf, protflag, status) + + } else { + p_arg[2] = protflag + + if (ki_sendrcv (server, KI_ZFPROT, 0) == ERR) + status = ERR + else + status = p_arg[1] + } +end diff --git a/sys/ki/kfrmdr.x b/sys/ki/kfrmdr.x new file mode 100644 index 00000000..e468a86f --- /dev/null +++ b/sys/ki/kfrmdr.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ki.h" + +# KFRMDR -- Remove a directory. + +procedure kfrmdr (osfn, status) + +char osfn[ARB] # packed os filename of directory +int status # ok or err + +int server +int ki_connect(), ki_sendrcv() +include "kii.com" + +begin + server = ki_connect (osfn) + + if (server == NULL) { + call strpak (p_sbuf[p_arg[1]], p_sbuf, SZ_SBUF) + call zfrmdr (p_sbuf, status) + + } else { + if (ki_sendrcv (server, KI_ZFRMDR, 0) == ERR) + status = ERR + else + status = p_arg[1] + } +end diff --git a/sys/ki/kfrnam.x b/sys/ki/kfrnam.x new file mode 100644 index 00000000..d2600aaa --- /dev/null +++ b/sys/ki/kfrnam.x @@ -0,0 +1,61 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ki.h" + + +# KFRNAM -- Rename a file. Both filenames must refer to the same node. + +procedure kfrnam (old_osfn, new_osfn, status) + +char old_osfn[ARB] #I packed old os filename +char new_osfn[ARB] #I packed new os filename +int status #O answer; ok or err + +pointer sp, fname +int server1, server2, old, new +int ki_connect(), ki_sendrcv(), strlen() +include "kii.com" + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + server2 = ki_connect (new_osfn) + call strcpy (p_sbuf[p_arg[1]], Memc[fname], SZ_FNAME) + server1 = ki_connect (old_osfn) + old = p_arg[1] + + if (server1 == NULL && server2 == NULL) { + # Both files reside on the local node. + + call strpak (p_sbuf[old], p_sbuf[old], SZ_SBUF) + call strpak (Memc[fname], Memc[fname], SZ_FNAME) + call zfrnam (p_sbuf[old], Memc[fname], status) + + } else if (server1 == server2) { + # Both files reside on the same remote node. Pack the two + # filenames into p_sbuf and send the request. + + new = old + strlen(p_sbuf[old])+1 + 1 + if (new + strlen(Memc[fname])+1 > SZ_SBUF) + status = ERR + else { + call strcpy (Memc[fname], p_sbuf[new], SZ_SBUF-new+1) + + p_arg[2] = new + p_sbuflen = SZ_SBUF + + if (ki_sendrcv (server1, KI_ZFRNAM, 0) == ERR) + status = ERR + else + status = p_arg[1] + } + + } else { + # One file resides on a remote node. + status = ERR + } + + call sfree (sp) +end diff --git a/sys/ki/kfsubd.x b/sys/ki/kfsubd.x new file mode 100644 index 00000000..93f2d655 --- /dev/null +++ b/sys/ki/kfsubd.x @@ -0,0 +1,52 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "ki.h" + +# KFSUBD -- Compute the net pathname of a subdirectory given the net pathname +# of the parent directory and the name of the subdirectory (the logical +# subdirectory names . and .. are supported). If the subdirectory resides on +# the local node we call the local kernel to compute the new directory pathname. +# If the directory resides on a remote node we merely append to the virtual +# pathname, leaving resolution of the final pathname to the remote kernel when +# the file is referenced at runtime. + +procedure kfsubd (osdir, maxch, subdir, nchars) + +char osdir[maxch] #RW net pathname of directory +int maxch #RO max chars out in osdir string +char subdir[ARB] #RO receives pathname +int nchars #WO receives length of osfn string + +int delim, op +char alias[SZ_ALIAS] +int ki_gnode(), gstrcat() + +begin + if (ki_gnode (osdir, alias, delim) == LOCAL) { + # Directory is on the local node. + + if (osdir[delim+1] == EOS) { + call zfgcwd (osdir[delim+1], maxch - delim, nchars) + if (nchars == ERR) + return + call strupk (osdir[delim+1], osdir[delim+1], maxch-delim) + } + call zfsubd (osdir[delim+1], maxch - delim, subdir, nchars) + if (nchars != ERR) + nchars = nchars + delim + + } else { + # File is on a remote node. Do not map the filename; leave that + # to the kernel when the file is referenced at runtime. The OSDIR + # string is assumed to be a concatenatable VFN (with node prefix). + + op = gstrcat (subdir, osdir, maxch) + 1 + if (op > 1 && osdir[op-1] != '/') { + osdir[op] = '/' + op = op + 1 + osdir[op] = EOS + } + + nchars = op - 1 + } +end diff --git a/sys/ki/kfutim.x b/sys/ki/kfutim.x new file mode 100644 index 00000000..a4b81156 --- /dev/null +++ b/sys/ki/kfutim.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ki.h" + +# KFUTIM -- Set the file access/modify times of a file. Time arguments are +# assumed to be in units of seconds from midnight on Jan 1, 1980, LST. +# +# NOTE: Since the atime/mtime values are long but the p_arg[] is just int +# this code may need to be revised if the sizes of long/int change. + +procedure kfutim (osfn, atime, mtime, status) + +char osfn[ARB] # packed os filename +long atime, mtime # access and modify times +int status # answer; ok or err + +int server +int ki_connect(), ki_sendrcv() +include "kii.com" + +begin + server = ki_connect (osfn) + + if (server == NULL) { + call strpak (p_sbuf[p_arg[1]], p_sbuf, SZ_SBUF) + call zfutim (p_sbuf, atime, mtime, status) + + } else { + p_arg[2] = atime + p_arg[3] = mtime + + if (ki_sendrcv (server, KI_ZFUTIM, 0) == ERR) + status = ERR + else + status = p_arg[1] + } +end diff --git a/sys/ki/kfxdir.x b/sys/ki/kfxdir.x new file mode 100644 index 00000000..3a4209ba --- /dev/null +++ b/sys/ki/kfxdir.x @@ -0,0 +1,76 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ki.h" + +# KFXDIR -- Extract the OSDIR prefix (if any) from a filename. If the VFN +# has a node prefix and the node named is not the local node then the entire +# filename is treated as an OSDIR name. We are called during filename mapping +# to determine if a VFN is an OSFN; returning nchars > 0 when there is a node +# name prefix causes filename mapping to be deferred until the filename is +# passed to the kernel server on the remote node. +# +# NOTE -- The "nchars" returned is the length of the osdir prefix portion of +# the VFN string, NOT the length of the returned string. ZFXDIR is used to +# test if a VFN has an OSDIR prefix and if so, to determine the string offset +# of the root field. + +procedure kfxdir (vfn, osdir, maxch, nchars) + +char vfn[ARB] # virtual filename +char osdir[maxch] # receives os directory prefix +int maxch # max chars out +int nchars # receives length of osdir prefix in VFN string + +int delim, op +int ki_gnode(), gstrcpy(), ki_gethosts() +include "kinode.com" + +begin + repeat { + if (ki_gnode (vfn, osdir, delim) == LOCAL) { + # File is on the local node. Must strip the node prefix, + # if any, before calling zfxdir, but keep the node prefix + # in the output pathname else the next operator will assume + # the default node. + + for (op=1; osdir[op] != EOS; op=op+1) + ; + if (op > 1) { + osdir[op] = FNNODE_CHAR + op = op + 1 + } + + call zfxdir (vfn[delim+1], osdir[op], maxch-op+1, nchars) + if (nchars == 0) + osdir[1] = EOS + else + nchars = nchars + delim + + break + + } else { + # Verify that the host name table has been read and if not, + # read it and try again. + + if (n_nnodes == 0) + if (ki_gethosts() != ERR) + next + + # File is on a remote node. Concatenate node name and filename + # and return the entire string as the "osdir" string, disabling + # filename mapping on the local node. + + for (op=1; osdir[op] != EOS; op=op+1) + ; + + if (op > 1) { + osdir[op] = FNNODE_CHAR + op = op + 1 + } + + nchars = gstrcpy (vfn[delim+1], osdir[op], maxch-op+1) + delim + break + } + } +end diff --git a/sys/ki/kgfdir.x b/sys/ki/kgfdir.x new file mode 100644 index 00000000..01926195 --- /dev/null +++ b/sys/ki/kgfdir.x @@ -0,0 +1,124 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KGFDIR -- Get the next filename from a directory file. Rather than make a +# call over the net to read each filename, which would be very slow, we read +# filenames in large batches and return filenames out of our internal buffer. + +procedure kgfdir (chan, osfn, maxch, status) + +int chan # channel descriptor +char osfn[maxch] # receives packed OS filename +int maxch # maxchars out +int status # answer; ok or err + +pointer dp, bp, ip, op +pointer sp, vfn, root, extn +int server, nchars, len_root, len_extn +int ki_sendrcv(), gstrcpy() +include "kichan.com" +include "kii.com" +define quit_ 91 + +begin + server = k_node[chan] + + if (server == NULL) { + call zgfdir (k_oschan[chan], osfn, maxch, status) + + } else { + call smark (sp) + call salloc (vfn, SZ_PATHNAME, TY_CHAR) + call salloc (root, SZ_FNAME, TY_CHAR) + call salloc (extn, SZ_FNAME, TY_CHAR) + + dp = k_bufp[chan] + bp = D_DATA(dp) + + if (D_IP(dp) >= D_ITOP(dp)) { + # Refill buffer. + + # If the last block of data was returned with the EOF flag + # set then the directory has been exhausted. + + if (D_EOFSEEN(dp) == YES) { + status = EOF + goto quit_ + } + + p_arg[1] = k_oschan[chan] + p_arg[2] = SZ_DIRDATA + p_sbuflen = 0 + + if (ki_sendrcv (server, KI_ZGFDIR, 0) == ERR) { + status = ERR + goto quit_ + } else if (p_arg[1] == ERR) { + status = ERR + goto quit_ + } else if (p_arg[1] <= 0) { + status = EOF + goto quit_ + } + + nchars = p_arg[1] + if (nchars <= SZ_SBUF) { + call amovc (p_sbuf, Memc[bp], nchars) + p_sbuflen = nchars + } else { + call ks_aread (server, Memc[bp], nchars) + call ks_await (server, status) + + if (status != nchars) { + status = ERR + goto quit_ + } else + call chrupk (Memc[bp], 1, Memc[bp], 1, nchars) + } + + D_IP(dp) = bp + D_ITOP(dp) = bp + nchars + D_EOFSEEN(dp) = p_arg[2] + } + + # Return the next filename from the buffer. + + for (ip=D_IP(dp); ip < D_ITOP(dp) && Memc[ip] != '\n'; ip=ip+1) + ; + Memc[ip] = EOS + + if (ip > D_IP(dp)) { + # A kernel server always returns unmapped (IRAF) filenames since + # the unmapping must be performed on the host where the files + # are. We must map these into local host filenames since that + # is what the kernel interface is supposed to return. + + call vfn_encode (Memc, D_IP(dp), + Memc[root], len_root, Memc[extn], len_extn) + if (len_extn > 0) + call vfn_map_extension (Memc[extn], Memc[extn], SZ_FNAME) + + op = vfn + gstrcpy (Memc[root], Memc[vfn], SZ_PATHNAME) + if (len_extn > 0) { + Memc[op] = '.' + op = op + 1 + op = op + gstrcpy (Memc[extn], Memc[op], ARB) + } + + # Return a packed (local) host filename. + call strpak (Memc[vfn], osfn, maxch) + } else + op = vfn + + status = op - vfn + if (status <= 0) + status = EOF + + D_IP(dp) = ip + 1 +quit_ + call sfree (sp) + } +end diff --git a/sys/ki/ki.h b/sys/ki/ki.h new file mode 100644 index 00000000..76140c8b --- /dev/null +++ b/sys/ki/ki.h @@ -0,0 +1,139 @@ +# KI.H -- IRAF Kernel Interface definitions. + +define MAX_NODES 512 # max nodes known to KI +define MAX_CHANNELS LAST_FD # requires +define MAX_INDIRECT 20 # max indirection in a route +define MAX_ALIAS 6 # maximum number of aliases per node +define SZ_ALIAS 16 # size of a node name alias +define SZ_SERVER 128 # size of a server name +define HNT_SUBDIR "dev" # parts of host name table filename +define HNT_FILENAME "hosts" # default host name table +define HNT_ENVNAME "irafhnt" # user host name table + +define READ_IN_PROGRESS (-11) # used in binary file i/o +define OSHIFT 128 # optype= (opcode * OSHIFT) + subcode +define FIRST_CHAN 4 # first available kchan. +define LOCAL 0 # node is a local node +define REMOTE 1 # node is a remote node + +# Node status flags. +define F_IOERR 01B # fatal error on kschan +define F_REUSE 02B # node descriptor may be reused + +# ZFIOTX buffer descriptor. + +define SZ_TXBUF 16386 # size of text file buffer (should be + # at least (2*LEN_SEQBUF*SZ_LINE)) +define LEN_TXBDES (5+SZ_TXBUF/SZ_STRUCT) + +define B_CI Memi[$1] # character index into current record +define B_RP Memi[$1+1] # pointer to current record +define B_ITOP Memi[$1+2] # end of input buffer +define B_OTOP Memi[$1+3] # end of output buffer +define B_BUFTOP Memi[$1+4] # end of buffer +define B_BUFPTR P2C(($1)+5) # first char of buffer + +# ZGFDIR buffer descriptor. + +define SZ_DIRDATA 2048 # amount of directory data to read +define LEN_DIRBDES (5+SZ_DIRDATA/SZ_STRUCT) + +define D_IP Memi[$1] # input pointer into dirbuf +define D_ITOP Memi[$1+1] # top of dirbuf +define D_EOFSEEN Memi[$1+2] # dirbuf contains last of data +define D_DATA P2C(($1)+5) # pointer to data area + +# Record descriptor structure (format of a line of text record in the input +# buffer when reading from a remote text file). + +define R_RECLEN Memc[$1] # encoded record length (2 chars) +define R_SEKOFF Memc[$1+2] # encoded seek offset (5 chars) +define R_DATA (($1)+7) # pointer to data text + +define NCHARS_INT 2 # nchars to encode an int +define NCHARS_LONG 5 # nchars to encode a long +define R_GETNCHARS (($1)-7) # reclen to nchars +define R_GETRECLEN (($1)+7) # nchars to reclen + +# KII instruction format. + +define LEN_INTFIELDS 16 # number of integer fields +define FIRSTINTFIELD p_opcode # first integer field in common +define MAX_ARGS 13 # max procedure arguments +define SZ_SBUF 255 # size of string buffer +define SZB_PACKET 320 # packet size, bytes + +# KII opcodes. + +define KI_ENVINIT 1 +define KI_SETROOT 2 +define KI_ZOSCMD 3 +define KI_FMAPFN 4 + +define KI_ZFACSS 10 +define KI_ZFALOC 11 +define KI_ZFCHDR 12 +define KI_ZFDELE 13 +define KI_ZFINFO 14 +define KI_ZFGCWD 15 +define KI_ZFMKCP 16 +define KI_ZFMKDR 17 +define KI_ZFPATH 18 +define KI_ZFPROT 19 +define KI_ZFRNAM 20 +define KI_ZFRMDR 21 +define KI_ZFSUBD 22 +define KI_ZDVALL 23 +define KI_ZDVOWN 24 +define KI_ZFUTIM 25 + +define KI_ZOPDIR 30 +define KI_ZCLDIR 31 +define KI_ZGFDIR 32 + +define KI_ZOPDPR 35 +define KI_ZCLDPR 36 +define KI_ZOPCPR 37 +define KI_ZCLCPR 38 +define KI_ZINTPR 39 + +# Device driver opcodes. BF must be the lowest numbered binary file driver +# and TX must be the lowest number text file driver. + +define KI_ZFIOBF 40 +define KI_ZFIOLP 41 +define KI_ZFIOPL 42 +define KI_ZFIOPR 43 +define KI_ZFIOSF 44 +define KI_ZFIOGD 45 + +define KI_ZFIOTX 50 +define KI_ZFIOTY 51 + +define KI_ZFIOMT 55 + +# KII subcodes. + +define BF_OPN 1 # binary files (BF, SF, PR, PL, etc.) +define BF_CLS 2 +define BF_ARD 3 +define BF_AWR 4 +define BF_AWT 5 +define BF_STT 6 + +define TX_OPN 1 # text files (TX, TY) +define TX_CLS 2 +define TX_GET 3 +define TX_PUT 4 +define TX_FLS 5 +define TX_SEK 6 +define TX_NOT 7 +define TX_STT 8 + +define MT_OP 1 # magtape zz-routines +define MT_CL 2 +define MT_RD 3 +define MT_WR 4 +define MT_WT 5 +define MT_ST 6 +define MT_RW 7 diff --git a/sys/ki/kichan.com b/sys/ki/kichan.com new file mode 100644 index 00000000..b810400f --- /dev/null +++ b/sys/ki/kichan.com @@ -0,0 +1,8 @@ +# KICHAN.COM -- Channel descriptor common for the kernel interface. + +int k_node[MAX_CHANNELS] # kernel server node (NULL if local) +int k_oschan[MAX_CHANNELS] # iraf kernel (host) channel or PID +int k_status[MAX_CHANNELS] # status holding word for ZSTT +pointer k_bufp[MAX_CHANNELS] # buffer pointer + +common /kichan/ k_node, k_oschan, k_status, k_bufp diff --git a/sys/ki/kiconnect.x b/sys/ki/kiconnect.x new file mode 100644 index 00000000..ed382096 --- /dev/null +++ b/sys/ki/kiconnect.x @@ -0,0 +1,115 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "ki.h" + +# KI_CONNECT -- Given a resource name (e.g., a VFN, OSFN, or any string +# which might begin with a node name prefix) extract the node name alias, +# if any, and return the node index of the kernel server for the node. +# NULL is returned if the resource does not reside on a remote node, +# if the named node is not recognized, if the resource resides on the local +# node, or if a kernel server cannot be spawned on the node. +# +# SIDE-EFFECTS: In all cases the unpacked name, minus the node name prefix, +# is left in the field P_SBUF of the kschan common, i.e., in the packet to be +# sent to the node to service the request. This stripped name should be used +# even if the resource is local since the node prefix must not be passed to the +# iraf kernel. If the resource resides on a remote node the P_ARG[1] field is +# set to 1 (the index of the string in the string buffer) and the P_SBUFLEN +# field is set to the length of the unpacked string plus 1 for the EOS. + +int procedure ki_connect (rname) + +char rname[ARB] # packed resource name, e.g., a filename + +pointer sp, sbuf, op +char alias[SZ_ALIAS] +int node, delim, junk, nlookup +int ki_findnode(), ki_openks(), ki_gnode(), ki_gethosts() +int strlen(), gstrcpy() + +include "kinode.com" +include "kichan.com" +include "kii.com" +define again_ 91 + +begin + # Read dev$hosts if it has not already been read. + if (n_nnodes == 0) + junk = ki_gethosts() + + # Unpack rname into the string buffer, search for the node character. + # The call to KI_GETHOSTS will fail during process startup until the + # environment variable "iraf" is defined. This is harmless provided + # only local files are referenced during process startup. Do not + # move this initialization code to ki_init() or the host name table + # will never be read and networking will never be turned on. Return + # immediately if no nodechar found. + # + # NOTE: we are required to always leave the unpacked, node prefix + # stripped resource name in p_sbuf, whether or not the resource is + # on a remote node. + + call strupk (rname, p_sbuf, SZ_SBUF) + nlookup = 0 +again_ + if (ki_gnode (p_sbuf, alias, delim) == LOCAL) { + p_arg[1] = delim + 1 + return (NULL) + } else + p_arg[1] = delim + 1 + + # Find node descriptor (initialized by ki_gethosts above). NULL is + # returned for ND if the node is not found or if the node is the + # local node. + + node = ki_findnode (alias) + if (node == n_local) + node = NULL + else if (n_server[1,node] == '@') { + # The node entry is a route to another node. This is an entry + # such as "node : @foo!node". We replace the "node" prefix in + # rname by whatever is to the right of the @, and repeat the + # host lookup. In the example this would have the effect of + # changing the "node!object" reference to "foo!node!object" and + # hence routing traffic for node "node" through node "foo". + # This is often done when a node is not directly reachable on + # the local network. + + call smark (sp) + call salloc (sbuf, SZ_SBUF, TY_CHAR) + + op = sbuf + gstrcpy (n_server[2,node], Memc[sbuf], SZ_SBUF) + Memc[op] = '!'; op = op + 1 + call strcpy (p_sbuf[delim+1], Memc[op], SZ_SBUF-(op-sbuf)) + call strcpy (Memc[sbuf], p_sbuf, SZ_SBUF) + + call sfree (sp) + + nlookup = nlookup + 1 + if (nlookup > MAX_INDIRECT) + node = NULL + else + goto again_ + } + + # Initialize the remainder of the packet descriptor variables dealing + # with the resource name. The node alias is left in the string buffer + # at offset 1, now terminated with an EOS. This is followed by RNAME + # minus the node name prefix. Note that RNAME may contain additional + # indirection; only the first node name is processed locally. + + if (node != NULL) { + # Resource resides on a remote node. Connect the kernel server + # if not already connected. + + p_sbuflen = strlen (p_sbuf) + if (n_kschan[node] == NULL) + if (ki_openks (node) == ERR) + node = NULL + } + + return (node) +end diff --git a/sys/ki/kiencode.x b/sys/ki/kiencode.x new file mode 100644 index 00000000..463579e4 --- /dev/null +++ b/sys/ki/kiencode.x @@ -0,0 +1,64 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# KI_ENCODE -- Encode an integer into the indicated number of chars for +# transmission between machines via a byte stream. + +procedure ki_encode (data, str, nchars) + +long data # data value to be encoded +char str[nchars] # output chars +int nchars # number of chars to be encoded + +int i +long v, nv + +begin + v = abs (data) + + do i = 1, nchars { + nv = v / 128 + str[i] = v - (nv * 128) + v = nv + } + + if (data < 0) + if (str[1] == 0) + str[1] = -128 + else + str[1] = -str[1] +end + + +# KI_DECODE -- Decode the long integer value encoded by ki_encode, returning +# the long integer value as the function value. + +long procedure ki_decode (str, nchars) + +char str[ARB] # string to be decoded +int nchars # number of chars to decode + +bool neg +int pow, i +long sum + +begin + sum = str[1] + neg = (sum < 0) + if (neg) + if (sum == -128) + sum = 0 + else + sum = -sum + + pow = 1 + + do i = 2, nchars { + pow = pow * 128 + sum = sum + (str[i] * pow) + } + + if (neg) + return (-sum) + else + return (sum) +end diff --git a/sys/ki/kienvreset.x b/sys/ki/kienvreset.x new file mode 100644 index 00000000..5a69c519 --- /dev/null +++ b/sys/ki/kienvreset.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KI_ENVRESET -- Update the value of an environment variable on all currently +# connected nodes. + +procedure ki_envreset (name, value) + +char name[ARB] #I name of environment variable +char value[ARB] #I value of environment variable + +pointer sp, buf, op +int node, junk, ch +int gstrcpy(), ki_send() +bool streq() + +include "kii.com" +include "kinode.com" +define quit_ 91 + +begin + # Do not propagate the host-specific iraf definitions "iraf", "host", + # and "tmp" over the network. + + ch = name[1] + if (ch == 'i' || ch == 'h' || ch == 't') + if (streq(name,"iraf") || streq(name,"host") || streq(name,"tmp")) + return + + call smark (sp) + call salloc (buf, SZ_COMMAND, TY_CHAR) + + # Format the SET statement to be sent to each node. + op = buf + gstrcpy ("set ", Memc[buf], SZ_COMMAND) + op = op + gstrcpy (name, Memc[op], SZ_COMMAND - 4) + Memc[op] = '='; op = op + 1 + Memc[op] = '"'; op = op + 1 + op = op + gstrcpy (value, Memc[op], SZ_COMMAND - (op - buf)) + Memc[op] = '"'; op = op + 1 + Memc[op] = '\n'; op = op + 1 + Memc[op] = EOS + + # Transmit the SET statement to each node currently running a kernel + # server process. This is done without reading back a status value + # to permit pipelining of multiple set environment packets. + + for (node=1; node <= n_nnodes; node=node+1) { + if (n_kschan[node] == NULL) + next + + # Set up control packet. + p_sbuflen = gstrcpy (Memc[buf], p_sbuf, SZ_SBUF) + p_arg[1] = p_sbuflen + + # Transmit packet. + if (ki_send (node, KI_ENVINIT, 0) == ERR) + goto quit_ + } + + call sfree (sp) + return +quit_ + call zclsks (n_kschan[node], junk) + n_kschan[node] = NULL + call sfree (sp) +end diff --git a/sys/ki/kierror.x b/sys/ki/kierror.x new file mode 100644 index 00000000..159b0707 --- /dev/null +++ b/sys/ki/kierror.x @@ -0,0 +1,66 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ki.h" + +# KI_ERROR -- Called when an i/o error occurs on the channel to a remote +# kernel server process. Note that this is not the same as an i/o error +# on a channel accessed on the remote node via the KI; when we are called +# we assume that further communications with the kernel server are impossible. +# +# Error recover strategy: +# +# We shut down the ZFIOKS channel to the server and set the error bit in the +# status word for the node. Note that we cannot return the node descriptor +# until all of the remote OS channels (pids, etc.) multiplexed to the remote +# node are closed on the local, client node. Any further i/o requests on the +# node will cause ERR to be returned without any attempt to do i/o. A connect +# request on the node will cause another kernel server to be spawned and +# another node descriptor to be allocated. If and when all kichan descriptors +# using the bad node are freed, the node descriptor will be freed. + +procedure ki_error (server) + +int server # kernel server node + +int junk, node, i +int or(), and() +include "kinode.com" + +begin + # Close the kernel server channel and set the error bit in the + # node descriptor. + + call zclsks (n_kschan[server], junk) + n_status[server] = or (n_status[server], F_IOERR) + + # Allocate a new node descriptor for use by the next connection + # on the node. If a node descriptor on which an error has occurred + # is later freed the F_REUSE bit will have been set in the status + # word (and the other bits cleared) so that we may reuse the + # descriptor. + + node = 0 + do i = 1, n_nnodes + if (and (n_status[i], F_REUSE) != 0) { + node = i + break + } + if (node == 0) { + n_nnodes = n_nnodes + 1 + if (n_nnodes > MAX_NODES) + return + node = n_nnodes + } + + # Initialize the new node descriptor. It is not necessary to transfer + # the n_local index since an i/o error cannot occur on the local node. + + n_kschan[node] = NULL + n_status[node] = 0 + n_nalias[node] = n_nalias[server] + + call strcpy (n_server[1,server], n_server[1,node], SZ_SERVER) + do i = 1, n_nalias[node] + call strcpy (n_alias[1,i,server], n_alias[1,i,node], SZ_ALIAS) +end diff --git a/sys/ki/kiextnode.x b/sys/ki/kiextnode.x new file mode 100644 index 00000000..672fcbc4 --- /dev/null +++ b/sys/ki/kiextnode.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ki.h" + +# KI_EXTNODE -- Extract the node name prefix from a resource name of the form +# "node!resource". The entire prefix is returned, i.e., "node!". The number +# of chars in the prefix string is returned as the function value; zero is +# returned if there is no node prefix. The name of the node owning the named +# resource is returned in the output string. If no node is named in the +# resource name supplied, the name of the default node (usually the local or +# host node) is returned instead. Note that the function value refers to the +# prefix string, not the string length of the nodename string. + +int procedure ki_extnode (resource, nodename, maxch, nchars) + +char resource[ARB] # name of a resource, with opt. node prefix +char nodename[maxch] # receives node name +int maxch # max chars out +int nchars # receives nchars in nodename string + +char alias[SZ_ALIAS] +int delim, op, junk, node +int ki_gnode(), ki_findnode(), gstrcpy() +include "kinode.com" + +begin + # Extract node name prefix, if any, and replace by primary alias. + junk = ki_gnode (resource, alias, delim) + if (delim > 0) { + node = ki_findnode (alias) + if (node > 0) + op = gstrcpy (n_alias[1,1,node], nodename, maxch) + 1 + else + op = gstrcpy (alias, nodename, maxch) + 1 + } else + op = 1 + + # Append the node prefix delimiter character. + if (op > 1 && op <= maxch) { + nodename[op] = FNNODE_CHAR + op = op + 1 + nodename[op] = EOS + } + + nodename[op] = EOS + nchars = op - 1 + + return (delim) +end diff --git a/sys/ki/kifchan.x b/sys/ki/kifchan.x new file mode 100644 index 00000000..199212b2 --- /dev/null +++ b/sys/ki/kifchan.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ki.h" + +# KI_FREECHAN -- Free a channel descriptor slot. Decrement the reference +# count on the associated node descriptor slot; when the ref count reaches +# zero, free the node descriptor if the error bit is set. If the error +# bit is not set the node descriptor is not freed because the kernel server +# remains connected, ready for reuse. + +procedure ki_freechan (chan) + +int chan # kichan channel descriptor + +int server, and() +include "kichan.com" +include "kinode.com" + +begin + server = k_node[chan] + + # Server=0 if local node. + if (server > 0) { + n_nrefs[server] = n_nrefs[server] - 1 + if (and (n_status[server], F_IOERR) != 0) + if (n_nrefs[server] == 0) + n_status[server] = F_IOERR + F_REUSE + } + + k_oschan[chan] = NULL +end diff --git a/sys/ki/kifmapfn.x b/sys/ki/kifmapfn.x new file mode 100644 index 00000000..3869f7c4 --- /dev/null +++ b/sys/ki/kifmapfn.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KI_FMAPFN -- Fully resolve a filename into its host equivalent, regardless +# of the node on which the file resides. This is a temporary routine. +# The filename mapping primitives should probably perform their function when +# called for a remote file, rather than defer the mapping until later as they +# do now. When this is changed, this routine will no longer be necessary and +# can be removed. The output filename is returned as a packed filename with +# the node name stripped, as for FMAPFN. + +procedure ki_fmapfn (vfn, pkosfn, maxch) + +char vfn[ARB] # network filename +char pkosfn[maxch] # receives packed, fully resolved OS filename +int maxch + +int server +int ki_connect(), ki_sendrcv() +include "kii.com" + +begin + call strpak (vfn, pkosfn, maxch) + server = ki_connect (pkosfn) + + if (server == NULL) + call fmapfn (vfn, pkosfn, maxch) + else { + p_arg[2] = maxch + if (ki_sendrcv (server, KI_FMAPFN, 0) == ERR) + call syserrs (SYS_FNOSUCHFILE, vfn) + else + call strpak (p_sbuf, pkosfn, maxch) + } +end diff --git a/sys/ki/kifndnode.x b/sys/ki/kifndnode.x new file mode 100644 index 00000000..f41e7197 --- /dev/null +++ b/sys/ki/kifndnode.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "ki.h" + +# KI_FINDNODE -- Given an alias for a node, search the node descriptor table +# and return the table index of the named node or NULL. + +int procedure ki_findnode (alias) + +char alias[ARB] # alias to search for + +int node, i +char first_char +bool streq() +int ki_gethosts(), ki_mapname(), and() +include "kinode.com" + +begin + # Read the host name table if it has not been read yet. + if (n_nnodes == 0) + if (ki_gethosts() == ERR) + return (NULL) + + # Map possible logical node name. + if (ki_mapname (alias, n_nodename, SZ_ALIAS) <= 0) + call strcpy (alias, n_nodename, SZ_ALIAS) + + # Search the node descriptor table for a node with the given alias. + # Do not use descriptors that have the IOERR flag set. + + first_char = n_nodename[1] + for (node=1; node <= n_nnodes; node=node+1) + for (i=1; i <= n_nalias[node]; i=i+1) + if (first_char == n_alias[1,i,node]) + if (streq (n_nodename, n_alias[1,i,node])) + if (and (n_status[node], F_IOERR) == 0) + return (node) + + return (NULL) +end diff --git a/sys/ki/kigchan.x b/sys/ki/kigchan.x new file mode 100644 index 00000000..aa7c4332 --- /dev/null +++ b/sys/ki/kigchan.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ki.h" + +# KI_GETCHAN -- Find the first empty slot in the channel descriptor table +# and return its index, initializing the server and oschan fields with the +# values given. + +int procedure ki_getchan (server, oschan) + +int server # kernel server node +int oschan # os channel (iraf kernel channel) + +int i +include "kichan.com" +include "kinode.com" + +begin + # Server=0 if local node. + if (server > 0) + n_nrefs[server] = n_nrefs[server] + 1 + + do i = FIRST_CHAN, MAX_CHANNELS + if (k_oschan[i] == NULL) { + # Initialize channel descriptor. + + k_node[i] = server + k_oschan[i] = oschan + k_status[i] = 0 + k_bufp[i] = NULL + + return (i) + } + + # The following cannot happen unless something is very wrong. + call sys_panic (0, "ki_getchan: out of channel slots") +end diff --git a/sys/ki/kighost.x b/sys/ki/kighost.x new file mode 100644 index 00000000..31bebc0f --- /dev/null +++ b/sys/ki/kighost.x @@ -0,0 +1,156 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ki.h" + +# KI_GETHOSTS -- Read the host name table (file) and initialize the node +# descriptor table (common). The default hosts table is the file "dev$hosts"; +# a different file may be specified with the environment variable +# "irafhostnametable". + +int procedure ki_gethosts() + +pointer sp, lbuf, osfn, ip +int chan, node, ch, op, junk, n, status, i, delim + +bool streq() +int ctowrd(), envfind(), ki_gnode() +include "kinode.com" + +begin + call smark (sp) + call salloc (osfn, SZ_PATHNAME, TY_CHAR) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + # Null selected node descriptor fields. + call aclri (n_kschan, MAX_NODES) + call aclri (n_nrefs, MAX_NODES) + call aclri (n_status, MAX_NODES) + + # Process the host name table, ignoring blank lines and comment lines, + # until EOF is reached or the maximum number of nodes is exceeded. + # The format of a line is the server name followed by the aliases. + # Since this is a startup we require that the table file reside on + # the local node (not absolutely necessary, but it simplifies things). + # Note that since we are called by a z-routine at file open time, + # we cannot use high level file i/o to read the HNT file without + # reentrancy problems. + + if (envfind (HNT_ENVNAME, Memc[osfn], SZ_PATHNAME) <= 0) { + if (envfind ("iraf", Memc[osfn], SZ_PATHNAME) <= 0) { + call sfree (sp) + return (ERR) + } + + # Strip any node prefix from the iraf$ pathname; it had better + # reference the local node. + + junk = ki_gnode (Memc[osfn], Memc[lbuf], delim) + if (delim > 0) + call strcpy (Memc[osfn+delim], Memc[osfn], SZ_PATHNAME) + + # Form filename "iraf$subdir/file". + call zfsubd (Memc[osfn], SZ_PATHNAME, HNT_SUBDIR, junk) + call strcat (HNT_FILENAME, Memc[osfn], SZ_PATHNAME) + } + + # Open the table file, a text file. + call strpak (Memc[osfn], Memc[osfn], SZ_PATHNAME) + call zopntx (Memc[osfn], READ_ONLY, chan) + if (chan == ERR) { + call sfree (sp) + return (ERR) + } + + for (node=0; node < MAX_NODES; ) { + call zgettx (chan, Memc[lbuf], SZ_LINE, status) + if (status > 0) + Memc[lbuf+status] = EOS + else + break + + # Get the next nonempty, noncomment line. + for (ip=lbuf; IS_WHITE(Memc[ip]); ip=ip+1) + ; + ch = Memc[ip] + if (ch == '\n' || ch == '#' || ch == EOS) + next + + node = node + 1 + + # Extract the whitespace delimited alias names. The list of + # aliases is terminated by a colon. + + n_nalias[node] = 0 + n = 1 + + while (ctowrd (Memc, ip, n_alias[1,n,node], SZ_ALIAS) > 0) { + while (IS_WHITE (Memc[ip])) + ip = ip + 1 + + if (Memc[ip] == ':') { + ip = ip + 1 + n_nalias[node] = n + break + } else + n = min (MAX_ALIAS, n + 1) + } + + while (IS_WHITE (Memc[ip])) + ip = ip + 1 + + # Extract the kernel server name for the node. The server name + # string may contain whitespace and is delimited by end of line. + + for (op=1; op <= SZ_SERVER; op=op+1) { + ch = Memc[ip] + if (ch == '\n' || ch == EOS) + break + + n_server[op,node] = ch + ip = ip + 1 + } + + # Strip any trailing whitespace. + while (op > 1 && IS_WHITE(n_server[op-1,node])) + op = op - 1 + + # Make sure the server string is null terminated. + n_server[op,node] = EOS + } + + n_nnodes = node + call zclstx (chan, status) + + # Flag the local node. One of the aliases must match the name returned + # by ZGHOST else the local node will be accessed like a remote node + # (you may wish to take advantage of that for debugging). The default + # node name is initialized to the local node. + + n_local = 0 + n_default = 0 + + call strcpy (n_localnode, n_defaultnode, SZ_ALIAS) + + for (node=1; node <= n_nnodes; node=node+1) + for (i=1; i <= n_nalias[node]; i=i+1) + if (streq (n_alias[1,i,node], n_localnode)) { + n_local = node + n_default = node + break + } + + if (n_local > 0) { + # Add the alias "0" to the alias list for this node. This is a + # required alias and will overwrite the last alias for the node + # if the alias list is full. + + n = n_nalias[n_local] + n = min (MAX_ALIAS, n + 1) + n_nalias[n_local] = n + call strcpy ("0", n_alias[1,n,n_local], SZ_ALIAS) + } + + call sfree (sp) + return (n_nnodes) +end diff --git a/sys/ki/kignode.x b/sys/ki/kignode.x new file mode 100644 index 00000000..96424eff --- /dev/null +++ b/sys/ki/kignode.x @@ -0,0 +1,111 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KI_GNODE -- Extract the node name prefix from a resource name. The node +# name delimiter character may be escaped to be included in the resource name. +# If the resource name does not include an explicit node name the name of the +# default node is returned. The function value is LOCAL if the resource resides +# on the local node. NOTE: We can be called before initialization of the +# node descriptor table. + +int procedure ki_gnode (rname, outstr, delim) + +char rname[ARB] # resource name +char outstr[SZ_ALIAS] # receives node name +int delim # receives offset of delim char + +int ch, nchars +int ip, op, off, i +bool streq() +int ki_mapname() +include "kinode.com" +define lookup_ 91 + +begin + nchars = 0 + delim = 0 + op = 1 + + # Skip leading whitespace. + for (off=1; IS_WHITE (rname[off]); off=off+1) + ; + + # If the first char is the node char, there can be no node prefix. + if (rname[off] == FNNODE_CHAR) { + outstr[1] = EOS + return (LOCAL) + } + + # Extract explicit node name if given. + do ip = off, off + SZ_ALIAS { + ch = rname[ip] + + if (!IS_LOWER(ch) || !IS_DIGIT(ch)) + if (ch == EOS) + break + else if (ch == FNNODE_CHAR) { + if (rname[ip-1] != '\\') { + # Have node name. + delim = ip + nchars = (op - 1) + goto lookup_ + } else + op = max (1, op - 1) + } + + outstr[op] = ch + op = op + 1 + } + + # No explicit node name given; use default node name. + do i = 1, SZ_ALIAS + 1 { + outstr[i] = n_defaultnode[i] + if (outstr[i] == EOS) { + nchars = (i - 1) + break + } + } + + +lookup_ + outstr[nchars+1] = EOS + + # Determine if the named node is the local or a remote node. This must + # work during process startup, before the network tables have been read, + # or when networking is enabled but the tables have not beed edited for + # a new host (in which case there will be no entry in the tables for + # the local node as identified by ZGHOST). + + if (nchars <= 0) { + # No output node name. + outstr[1] = EOS + return (LOCAL) + + } else if (n_local == NULL) { + # If local node is not identified in the host name table, this + # effectively disables networking. All nodes names are assumed + # to be local. + + return (LOCAL) + + } else { + # We have a node name and the local node is identified in the + # node table. Scan the aliases of the local node to see if the + # referenced node is the same. + + # Map possible logical node name. + if (ki_mapname (outstr, n_nodename, SZ_ALIAS) <= 0) + call strcpy (outstr, n_nodename, SZ_ALIAS) + + ch = n_nodename[1] + do i = 1, n_nalias[n_local] + if (n_alias[1,i,n_local] == ch) + if (streq (n_alias[1,i,n_local], n_nodename)) + return (LOCAL) + } + + return (REMOTE) +end diff --git a/sys/ki/kii.com b/sys/ki/kii.com new file mode 100644 index 00000000..cd542b3d --- /dev/null +++ b/sys/ki/kii.com @@ -0,0 +1,15 @@ +# KI common -- Contains both the packed and unpacked packet used to transmit +# and receive requests over the network. Since the packed packet is first +# in the common any overflow due to failure of the assumptions about the +# size of the packed packet in host ints will only damage the area used by +# the unpacked packet, causing no harm. + +int p_packet[SZB_PACKET/SZB_CHAR/SZ_MII_INT] # packed packet + +int p_opcode # instruction opcode +int p_subcode # subcode, if device driver +int p_arg[MAX_ARGS] # procedure arguments +int p_sbuflen # nchars in use in string buffer +char p_sbuf[SZ_SBUF] # string buffer + +common /kiicom/ p_packet, p_opcode, p_subcode, p_arg, p_sbuflen, p_sbuf diff --git a/sys/ki/kiinit.x b/sys/ki/kiinit.x new file mode 100644 index 00000000..1d7488cb --- /dev/null +++ b/sys/ki/kiinit.x @@ -0,0 +1,67 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ki.h" + +# KI_INIT -- Called by the IRAF Main during process startup to initialize +# the kernel interface to the process i/o channels. INCHAN, OUTCHAN, and +# ERRCHAN are the host system i/o channel codes for the process standard +# input, output, and error channels. DEVICE is a ZLOCPR entry point address +# (kernel level) identifing the device driver to be used. To use the KI we +# must allocate channel descriptors for the host system i/o channels, and +# the device entry point address must be mapped to the corresponding KI +# procedure. + +procedure ki_init (inchan, outchan, errchan, device, devtype) + +int inchan #RW process input channel +int outchan #RW process output channel +int errchan #RW process error output channel +int device #RW device driver epa +int devtype #R device type (not modified) + +int locpr() +extern zgettx(), zgetty(), zardbf(), zardpr() +extern kgettx(), kgetty(), kardbf(), kardpr() +include "kichan.com" +include "kinode.com" + +begin + # Initialize the ki channel descriptors. + call amovki (NULL, k_oschan, MAX_CHANNELS) + call amovki (ERR, k_status, MAX_CHANNELS) + + # Assign KI channels for the 3 OS channels. + + k_node[1] = NULL + k_oschan[1] = inchan + inchan = 1 + + k_node[2] = NULL + k_oschan[2] = outchan + outchan = 2 + + k_node[3] = NULL + k_oschan[3] = errchan + errchan = 3 + + # Map device codes. + + if ( device == locpr (zgettx)) + device = locpr (kgettx) + else if (device == locpr (zgetty)) + device = locpr (kgetty) + else if (device == locpr (zardbf)) + device = locpr (kardbf) + else if (device == locpr (zardpr)) + device = locpr (kardpr) + + # Initialize node descriptor. + + call zghost (n_localnode, SZ_ALIAS) + call strupk (n_localnode, n_localnode, SZ_ALIAS) + + n_defaultnode[1] = EOS + n_default = NULL + n_local = NULL +end diff --git a/sys/ki/kilnode.x b/sys/ki/kilnode.x new file mode 100644 index 00000000..e332e8f0 --- /dev/null +++ b/sys/ki/kilnode.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "ki.h" + +# KI_LOCALNODE -- Determine if the named node is the local node. + +int procedure ki_localnode (node) + +char node[ARB] # node name + +int ch, i +bool streq() +int ki_mapname() +include "kinode.com" + +begin + if (n_local == NULL) { + # If local node is not identified in the host name table, this + # effectively disables networking. All nodes names are assumed + # to be local. + + return (YES) + + } else { + # We have a node name and the local node is identified in the + # node table. Scan the aliases of the local node to see if the + # referenced node is the same. + + # Map possible logical node name. + if (ki_mapname (node, n_nodename, SZ_ALIAS) <= 0) + call strcpy (node, n_nodename, SZ_ALIAS) + + ch = n_nodename[1] + do i = 1, n_nalias[n_local] + if (n_alias[1,i,n_local] == ch) + if (streq (n_alias[1,i,n_local], n_nodename)) + return (YES) + } + + return (NO) +end diff --git a/sys/ki/kimapchan.x b/sys/ki/kimapchan.x new file mode 100644 index 00000000..196619d2 --- /dev/null +++ b/sys/ki/kimapchan.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "ki.h" + +# KI_MAPCHAN -- Return the OS channel number or pid and the node name of the +# resource associated with a given KI channel. This procedure may be called +# whether or not networking is enabled. + +int procedure ki_mapchan (chan, nodename, maxch) + +int chan # KI channel (ret. by kopnbf, etc.) +char nodename[maxch] # receives node name +int maxch + +int node +bool netenab +data netenab /KNET/ +include "kichan.com" +include "kinode.com" + +begin + if (netenab) { + # Networking is enabled. Every channel or pid returned to the VOS + # by the kernel is actually a KI channel index. + + node = k_node[chan] + if (node == NULL || n_nnodes == 0) + call strcpy (n_localnode, nodename, maxch) + else + call strcpy (n_alias[1,1,node], nodename, maxch) + + return (k_oschan[chan]) + + } else { + # Networking is disabled. Return the name of the local node + # and return the channel argument unchanged. + + call strcpy (n_localnode, nodename, maxch) + return (chan) + } +end diff --git a/sys/ki/kimapname.x b/sys/ki/kimapname.x new file mode 100644 index 00000000..53d5deb2 --- /dev/null +++ b/sys/ki/kimapname.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# KI_MAPNAME -- Map a logical node name to a literal node name. Logical +# node names may be defined in the environment as aliases for "hardcoded" +# hosts-file node names. To distinguish logical node names from other +# environment variables the value string must end in the node delimiter +# character "!". For example, "set alpha = foo.bar.edu!" defines logical +# node alpha to be the same as foo.tar.edu. The "!" suffix also allows +# the logical node name to be used in file references, e.g. "alpha!pathname". +# +# If the input name is a logical node name the translated value is returned +# in newname and the number of characters output is returned as the function +# value (as for envfind). If the input name is not a logical node name +# zero is returned as the function value. +# +# It might make sense to allow multiple indirection on name translations, +# but this is not currently supported. + +int procedure ki_mapname (name, newname, maxch) + +char name[ARB] #I input logical node name +char newname[ARB] #O output translated name +int maxch #I max chars out + +int nchars +int envfind() + +begin + nchars = envfind (name, newname, maxch) + if (nchars > 1) + if (newname[nchars] == '!') { + newname[nchars] = EOS + return (nchars - 1) + } + + newname[1] = EOS + return (0) +end diff --git a/sys/ki/kinode.com b/sys/ki/kinode.com new file mode 100644 index 00000000..2e0e9a16 --- /dev/null +++ b/sys/ki/kinode.com @@ -0,0 +1,18 @@ +# KINODE.COM -- Node descriptor table. Contains one entry for each node listed +# in the host name table file. + +int n_nnodes # number of nodes in table +int n_local # index of the local node +int n_default # index of the current defnode +int n_kschan[MAX_NODES] # server channel (init to NULL) +int n_nrefs[MAX_NODES] # number of k_oschan using node +int n_status[MAX_NODES] # status bits for channel +int n_nalias[MAX_NODES] # number of aliases +char n_localnode[SZ_ALIAS] # name of the local node +char n_defaultnode[SZ_ALIAS] # name of the default node +char n_nodename[SZ_ALIAS] # node name working storage +char n_server[SZ_SERVER,MAX_NODES] # kernel server names +char n_alias[SZ_ALIAS,MAX_ALIAS,MAX_NODES] # aliases for the node + +common /kinode/ n_nnodes, n_local, n_default, n_kschan, n_nrefs, n_status, + n_nalias, n_localnode, n_defaultnode, n_nodename, n_server, n_alias diff --git a/sys/ki/kintpr.x b/sys/ki/kintpr.x new file mode 100644 index 00000000..ec3b6d4f --- /dev/null +++ b/sys/ki/kintpr.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KINTPR -- Send a signal (interrupt) to a connected subprocess. + +procedure kintpr (pid, vex, status) + +int pid # process id +int vex # virtual exception +int status # exit status of the job + +int server +int ki_sendrcv() +include "kichan.com" +include "kii.com" + +begin + server = k_node[pid] + + if (server == NULL) { + call zintpr (k_oschan[pid], vex, status) + + } else { + p_arg[1] = k_oschan[pid] + p_arg[2] = vex + p_sbuflen = 0 + + if (ki_sendrcv (server, KI_ZINTPR, 0) == ERR) + status = ERR + else + status = p_arg[1] + } +end diff --git a/sys/ki/kiopenks.x b/sys/ki/kiopenks.x new file mode 100644 index 00000000..64bfb626 --- /dev/null +++ b/sys/ki/kiopenks.x @@ -0,0 +1,133 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "ki.h" + +# KI_OPENKS -- Physically open a kernel server process on a remote node. +# Spawn the process and initialize the environment list and iraf root +# directory on the remote node. The KS channel or NULL is returned as the +# function value. + +int procedure ki_openks (node) + +int node # node descriptor to open kernel on + +bool hostdep +pointer sp, ksname, env, el, valp, ip, op, sv +int show, kschan, nchars, status, junk + +pointer env_first(), env_next() +int strlen(), stridx(), strncmp() +int gstrcpy(), ki_send(), ki_receive() + +data show /NO/ +include "kii.com" +include "kinode.com" +define quit_ 91 + +begin + call smark (sp) + call salloc (ksname, SZ_FNAME, TY_CHAR) + call salloc (sv, SZB_PACKET / SZB_CHAR, TY_CHAR) + + status = ERR + + # Our caller may have already prepped a packet in the kii common, which + # we are going to clobber below. Save packet and restore when done. + + call amovc (FIRSTINTFIELD, Memc[sv], SZB_PACKET / SZB_CHAR) + + # Spawn the kernel server process. + + call strpak (n_server[1,node], Memc[ksname], SZ_FNAME) + call zopnks (Memc[ksname], READ_WRITE, kschan) + if (kschan == ERR) { + call sfree (sp) + return (ERR) + } else + n_kschan[node] = kschan + + # Read the environment list into a string buffer. Scan the list once + # to determine its size, then allocate the buffer and format a series + # of "set name=value" lines in the buffer. + # Note 4 + 1 comes from len("set ") + \n. + + nchars = 0 + for (el=env_first(valp); el != NULL; el=env_next(el,valp,show)) + nchars = nchars + strlen (Memc[valp]) + 4 + 2 + 1 + + call salloc (env, nchars, TY_CHAR) + + op = env + for (el=env_first(valp); el != NULL; el=env_next(el,valp,show)) { + # Do not pass on the values of the host dependent environment + # variables HOST, IRAF, and TMP. If we do not set the values + # here, the remote kernel will fetch the values automatically + # from the HSI global include file on the server node. + + hostdep = false + if (stridx (Memc[valp], "hit") > 0) + hostdep = ((strncmp (Memc[valp], "host=", 5) == 0) || + (strncmp (Memc[valp], "iraf=", 5) == 0) || + (strncmp (Memc[valp], "tmp=", 4) == 0)) + + if (!hostdep) { + call strcpy ("set ", Memc[op], ARB) + op = op + 4 + for (ip=valp; Memc[ip] != '='; ip=ip+1) { + Memc[op] = Memc[ip] + op = op + 1 + } + Memc[op] = '='; op = op + 1 + Memc[op] = '"'; op = op + 1 + op = op + gstrcpy (Memc[ip+1], Memc[op], ARB) + Memc[op] = '"'; op = op + 1 + Memc[op] = '\n'; op = op + 1 + } + } + + Memc[op] = EOS + + # Transmit the environment list to the server process, preceded by the + # KI_ENVINIT instruction packet. The ENVINIT function does not return + # a status (to permit pipelining of multiple setenv packets). + + p_arg[1] = nchars + if (nchars <= SZ_SBUF) + call strcpy (Memc[env], p_sbuf, nchars) + + if (ki_send (node, KI_ENVINIT, 0) == ERR) + goto quit_ + + if (nchars > SZ_SBUF) { + # Transmit the data record. + call strpak (Memc[env], Memc[env], nchars) + call zawrks (kschan, Memc[env], nchars, long(0)) + call zawtks (kschan, status) + if (status != nchars) { + status = ERR + goto quit_ + } + + # We do expect a status return for large packets. + if (ki_receive (node, KI_ENVINIT, 0) == ERR) + goto quit_ + if (p_arg[1] == ERR) + goto quit_ + } + + status = OK +quit_ + if (status == ERR) { + call zclsks (kschan, junk) + n_kschan[node] = NULL + } + + # Restore the caller's kii packet. + call amovc (Memc[sv], FIRSTINTFIELD, SZB_PACKET / SZB_CHAR) + + call sfree (sp) + return (status) +end diff --git a/sys/ki/kireceive.x b/sys/ki/kireceive.x new file mode 100644 index 00000000..2cd1e7b6 --- /dev/null +++ b/sys/ki/kireceive.x @@ -0,0 +1,71 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KI_RECEIVE -- Read a machine independent KII packet from the network +# interface and decode it into the internal, machine dependent form in the +# kii common. An error status is returned if the opcode and subcode in +# the packet do not match those expected, or if an i/o error occurs on the +# channel. + +int procedure ki_receive (server, opcode, subcode) + +int server # node index of server process +int opcode # function opcode +int subcode # function subcode (for drivers) + +int stat, ip, op, ch +int gstrcpy() +include "kii.com" +include "kinode.com" + +begin + # Read the packet. + call ks_aread (server, p_packet, SZB_PACKET) + call ks_await (server, stat) + + # Hard error on the channel to the kernel server. + if (stat == ERR) + return (ERR) + + # The encoded packet consists of LEN_INTFIELDS 32 bit MII integers + # followed by p_sbuflen chars, one char per byte. + + call miiupk32 (p_packet, FIRSTINTFIELD, LEN_INTFIELDS, TY_INT) + call chrupk (p_packet, LEN_INTFIELDS * 4 + 1, p_sbuf, 1, + max(0, min(SZ_SBUF, p_sbuflen)) + 1) + + # Check for out of band data, i.e., the data read was not a packet + # but some unsolicited message, e.g., error message, from the + # called program. If this happens, print the error message and + # return an error status. + + if (stat != SZB_PACKET || p_opcode != opcode || p_subcode != subcode) { + + # Is it a printable string? If so, print the message in the + # format "node: message". + + op = gstrcpy (n_alias[1,1,server], p_sbuf, SZ_ALIAS) + 1 + p_sbuf[op] = ':' + op = op + 1 + p_sbuf[op] = ' ' + op = op + 1 + call chrupk (p_packet, 1, p_sbuf, op, SZ_LINE) + + do ip = op, SZ_LINE { + ch = p_sbuf[ip] + if (ch == EOS) + break + else if (!IS_ASCII(ch)) + call strcpy ("out of band data on ki channel\n", p_sbuf, + SZ_LINE) + } + + call xer_putline (STDERR, p_sbuf) + return (ERR) + + } else + return (OK) +end diff --git a/sys/ki/kisend.x b/sys/ki/kisend.x new file mode 100644 index 00000000..5b3f17d4 --- /dev/null +++ b/sys/ki/kisend.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ki.h" + +# KI_SEND -- Encode the packet in the kii common in a machine independent form +# and send it over the network. + +int procedure ki_send (server, opcode, subcode) + +int server # node index of server process +int opcode # function opcode +int subcode # function subcode (for drivers) + +int status +include "kii.com" + +begin + p_opcode = opcode + p_subcode = subcode + + # Encode the packet in machine independent form, i.e., LEN_INTFIELDS + # 32 bit MII integers followed by p_sbuflen chars, one char per byte. + + call miipak32 (FIRSTINTFIELD, p_packet, LEN_INTFIELDS, TY_INT) + call chrpak (p_sbuf, 1, p_packet, LEN_INTFIELDS * 4 + 1, p_sbuflen + 1) + + # Transmit the packet. + call ks_awrite (server, p_packet, SZB_PACKET) + call ks_await (server, status) + + return (status) +end diff --git a/sys/ki/kisendrcv.x b/sys/ki/kisendrcv.x new file mode 100644 index 00000000..8a319a35 --- /dev/null +++ b/sys/ki/kisendrcv.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# KI_SENDRCV -- Encode and send a packet to a remote server process, then +# read and decode the response packet. The opcode and subcode in the +# response packet must agree with those in the packet sent. + +int procedure ki_sendrcv (server, opcode, subcode) + +int server # os channel to server process +int opcode # function opcode +int subcode # function subcode (for drivers) + +int ki_send(), ki_receive() + +begin + if (ki_send (server, opcode, subcode) == ERR) + return (ERR) + else + return (ki_receive (server, opcode, subcode)) +end diff --git a/sys/ki/kishownet.x b/sys/ki/kishownet.x new file mode 100644 index 00000000..63765aee --- /dev/null +++ b/sys/ki/kishownet.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +procedure ki_shownet (fd) + +int fd # output file + +int i, j, n +int ki_gethosts() +include "kinode.com" + +begin + if (n_nnodes == 0) + n = ki_gethosts() + + call fprintf (fd, "Local node `%s' (%d), default node `%s', ") + call pargstr (n_localnode) + call pargi (n_local) + call pargstr (n_defaultnode) + call fprintf (fd, "%d nodes in local network\n") + call pargi (n_nnodes) + + if (n_local == 0) { + call fprintf (fd, "Network interface disabled ") + call fprintf (fd, "(no entry for local node in dev$hosts)\n") + } + + if (n_nnodes == MAX_NODES) + call fprintf (fd, "HOST NAME TABLE IS FULL\n") + else if (n_nnodes <= 0) + return + + # Print node table. + call fprintf (fd, "\n NODE SERVER NREFS STATUS ALIASES\n") + do i = 1, n_nnodes { + call fprintf (fd, "%8d %6d %5d %05o ") + call pargi (i) + call pargi (n_kschan[i]) + call pargi (n_nrefs[i]) + call pargi (n_status[i]) + + do j = 1, n_nalias[i] { + call fprintf (fd, " %s") + call pargstr (n_alias[1,j,i]) + } + + call fprintf (fd, "\n") + } + +# The following should no longer be needed as ki_mapname and the +# "node!" syntax should prevent accidential aliasing of node names +# and non-network related environment variables. +# +# n = 0 +# do i = 1, n_nnodes +# do j = 1, n_nalias[i] +# if (envfind (n_alias[1,j,i], Memc[text], SZ_FNAME) > 0) { +# if (n == 0) +# call fprintf (fd, "\n") +# call fprintf (fd, +# "Warning: node name `%s' is an alias for `%s'\n") +# call pargstr (n_alias[1,j,i]) +# call pargstr (Memc[text]) +# n = n + 1 +# } +end diff --git a/sys/ki/kixnode.x b/sys/ki/kixnode.x new file mode 100644 index 00000000..acf2dec2 --- /dev/null +++ b/sys/ki/kixnode.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# KI_XNODE -- Transfer the node prefix, if any, from one resource string to +# another. If the output resource already has a node prefix it is replaced +# by the new one. The output resource string is modified in place. If the +# output string is the null string the node prefix from the input string +# is returned. If the input string is the null string the node prefix from +# the output string is deleted, leaving only the resource name. + +procedure ki_xnode (r1, r2, maxch) + +char r1[ARB] #I input resource with optional node prefix +char r2[ARB] #U output resource to append node! to +int maxch #I max chars out + +pointer sp, rt +int ip, nchars, buflen +int ki_extnode(), strlen() + +begin + call smark (sp) + buflen = strlen(r2) + SZ_FNAME + call salloc (rt, buflen, TY_CHAR) + + ip = ki_extnode (r2, Memc[rt], buflen, nchars) + 1 + call strcpy (r2[ip], Memc[rt], buflen) + ip = ki_extnode (r1, r2, maxch, nchars) + call strcpy (Memc[rt], r2[nchars+1], maxch-nchars) + + call sfree (sp) +end diff --git a/sys/ki/kopcpr.x b/sys/ki/kopcpr.x new file mode 100644 index 00000000..21497992 --- /dev/null +++ b/sys/ki/kopcpr.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KOPCPR -- Open a connected subprocess. + +procedure kopcpr (process, inchan, outchan, pid) + +char process[ARB] # packed osfn of process executable +int inchan, outchan # receives process input output channels +int pid # receives process id + +int server +int ki_connect(), ki_sendrcv(), ki_getchan() +include "kichan.com" +include "kii.com" + +begin + server = ki_connect (process) + + if (server == NULL) { + call strpak (p_sbuf[p_arg[1]], p_sbuf, SZ_SBUF) + call zopcpr (p_sbuf, inchan, outchan, pid) + } else { + if (ki_sendrcv (server, KI_ZOPCPR, 0) == ERR) + pid = ERR + else { + pid = p_arg[1] + inchan = p_arg[2] + outchan = p_arg[3] + } + } + + # Allocate 3 channel descriptors, one for the each of the i/o + # channels and another for the PID. Save the channel descriptor + # numbers of the i/o channels in the status field of the PID + # descriptor to permit freeing the lot at disconnect time. + + if (pid != ERR) { + pid = ki_getchan (server, pid) + inchan = ki_getchan (server, inchan) + outchan = ki_getchan (server, outchan) + k_status[pid] = inchan * MAX_CHANNELS + outchan + } +end diff --git a/sys/ki/kopdir.x b/sys/ki/kopdir.x new file mode 100644 index 00000000..88ee950d --- /dev/null +++ b/sys/ki/kopdir.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "ki.h" + +# KOPDIR -- Open a directory file for reading. + +procedure kopdir (osfn, chan) + +char osfn[ARB] # packed os filename or directory name +int chan # channel assigned for reading filenames + +int server +pointer dp +int ki_connect(), ki_sendrcv(), ki_getchan(), kmalloc() +include "kichan.com" +include "kii.com" + +begin + server = ki_connect (osfn) + + if (server == NULL) { + call strpak (p_sbuf[p_arg[1]], p_sbuf, SZ_SBUF) + call zopdir (p_sbuf, chan) + + } else { + p_arg[2] = PASS_HIDDEN_FILES + + if (ki_sendrcv (server, KI_ZOPDIR, 0) == ERR) + chan = ERR + else { + chan = p_arg[1] + if (kmalloc (dp, LEN_DIRBDES, TY_STRUCT) == ERR) + chan = ERR + else { + D_IP(dp) = D_DATA(dp) + D_ITOP(dp) = D_DATA(dp) + D_EOFSEEN(dp) = NO + } + } + } + + if (chan != ERR) { + chan = ki_getchan (server, chan) + if (server != NULL) + k_bufp[chan] = dp + } +end diff --git a/sys/ki/kopdpr.x b/sys/ki/kopdpr.x new file mode 100644 index 00000000..1ea62dc9 --- /dev/null +++ b/sys/ki/kopdpr.x @@ -0,0 +1,59 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ki.h" + +# KOPDPR -- Open a detached process. + +procedure kopdpr (process, bkgfile, bkgmsg, jobcode) + +char process[ARB] # packed osfn of process executable +char bkgfile[ARB] # packed osfn of bkg file +char bkgmsg[ARB] # control string for kernel +int jobcode # receives job code of process + +pointer sp, osfn, alias +int server, off, delim +int ki_connect(), ki_sendrcv(), ki_getchan(), strlen(), ki_gnode() +include "kii.com" + +begin + call smark (sp) + call salloc (osfn, SZ_PATHNAME, TY_CHAR) + call salloc (alias, SZ_ALIAS, TY_CHAR) + + server = ki_connect (process) + + if (server == NULL) { + call strpak (p_sbuf[p_arg[1]], p_sbuf, SZ_SBUF) + call strupk (bkgfile, Memc[osfn], SZ_PATHNAME) + + # The bkg file must be on the same node as the process file. + if (ki_gnode (Memc[osfn], Memc[alias], delim) == REMOTE) + jobcode = ERR + else { + call strpak (Memc[osfn+(delim+1)-1], Memc[osfn], SZ_PATHNAME) + call zopdpr (p_sbuf, Memc[osfn], bkgmsg, jobcode) + } + + } else { + # Spawning of detached processes on remote notes is not really + # supported as of yet. Add support for passing the bkgmsg; use + # node name in bkgmsg to submit bkg job to remote node. + + off = p_sbuflen + 2 + p_arg[2] = off + call strupk (bkgfile, p_sbuf[off], ARB) + p_sbuflen = off + strlen(p_sbuf[off]) + + if (ki_sendrcv (server, KI_ZOPDPR, 0) == ERR) + jobcode = ERR + else + jobcode = p_arg[1] + } + + if (jobcode != ERR) + jobcode = ki_getchan (server, jobcode) + + call sfree (sp) +end diff --git a/sys/ki/koscmd.x b/sys/ki/koscmd.x new file mode 100644 index 00000000..6a358f8d --- /dev/null +++ b/sys/ki/koscmd.x @@ -0,0 +1,108 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "ki.h" + +# KOSCMD -- Send a command to the host command interpreter on the remote +# node. The output is captured in a file and returned to the caller on +# the local host. + +procedure koscmd (oscmd, stdin_file, stdout_file, stderr_file, status) + +char oscmd[ARB] # packed host command string +char stdin_file[ARB] # packed filename of stdin file +char stdout_file[ARB] # packed filename of stdout file +char stderr_file[ARB] # packed filename of stderr file +int status + +pointer sp, remfn, locfn, lbuf, op +int server, oscmd_status, inchan, outchan, nchars +int ki_connect(), ki_sendrcv(), gstrcpy() +include "kinode.com" +include "kii.com" + +begin + server = ki_connect (oscmd) + + if (server == NULL) { + call strpak (p_sbuf[p_arg[1]], p_sbuf, SZ_SBUF) + call zoscmd (p_sbuf, stdin_file, stdout_file, stderr_file, status) + + } else { + if (ki_sendrcv (server, KI_ZOSCMD, 0) == ERR) + status = ERR + else if (p_arg[1] == ERR) + status = ERR + + else { + call smark (sp) + call salloc (remfn, SZ_PATHNAME, TY_CHAR) + call salloc (locfn, SZ_PATHNAME, TY_CHAR) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + oscmd_status = p_arg[1] + + # Construct the network pathname of the remote spool file. + op = remfn + gstrcpy (n_alias[1,1,server], Memc[remfn], ARB) + Memc[op] = FNNODE_CHAR; op = op + 1 + call strcpy (p_sbuf, Memc[op], ARB) + call strpak (Memc[remfn], Memc[remfn], SZ_PATHNAME) + + # Open the spooled output file on the remote node. + call kopntx (Memc[remfn], READ_ONLY, inchan) + if (inchan == ERR) { + status = ERR + call sfree (sp) + return + } + + # Open the output file on the local node. Currently, all + # output is sent to the designated stdout_file, and the other + # redirection files are ignored if specified. If no stdout + # file is specified, write directly to the user terminal. + + call strupk (stdout_file, Memc[locfn], SZ_PATHNAME) + if (Memc[locfn] != EOS) { + # Copy to a textfile on the local node. + + call zopntx (stdout_file, APPEND, outchan) + if (outchan == ERR) { + call kclstx (inchan, status) + status = ERR + call sfree (sp) + return + } + + repeat { + call kgettx (inchan, Memc[lbuf], SZ_LINE, nchars) + if (nchars > 0) + call zputtx (outchan, Memc[lbuf], nchars, status) + } until (nchars <= 0) + + call zclstx (outchan, status) + + } else { + # Copy to the terminal on the local node, i.e., to the + # standard error output of the calling process. + + repeat { + call kgettx (inchan, Memc[lbuf], SZ_LINE, nchars) + if (nchars > 0) { + Memc[lbuf+nchars] = EOS + call xer_putline (STDERR, Memc[lbuf]) + } + } until (nchars <= 0) + } + + # Close and delete the remote spool file. + call kclstx (inchan, status) + call kfdele (Memc[remfn], status) + + status = oscmd_status + call sfree (sp) + } + } +end diff --git a/sys/ki/ksaread.x b/sys/ki/ksaread.x new file mode 100644 index 00000000..824b1a67 --- /dev/null +++ b/sys/ki/ksaread.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "ki.h" + +# KS_AREAD -- Read from the kernel server device driver given the node +# descriptor of a kernel server channel. If the error bit is set on the +# node return error w/o doing any i/o, since the channel will have been closed. + +procedure ks_aread (server, buf, maxbytes) + +int server # node descriptor index of server +char buf[ARB] # i/o buffer +int maxbytes # maxbytes to read + +int and() +include "kinode.com" + +begin + if (and (n_status[server], F_IOERR) == 0) + call zardks (n_kschan[server], buf, maxbytes, long(0)) +end diff --git a/sys/ki/ksawait.x b/sys/ki/ksawait.x new file mode 100644 index 00000000..069826d5 --- /dev/null +++ b/sys/ki/ksawait.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "ki.h" + +# KS_AWAIT -- Wait for i/o to the kernel server device driver given the node +# descriptor of a kernel server channel. If the error bit is set on the +# node return immediately, since the channel will have been closed. + +procedure ks_await (server, status) + +int server # node descriptor index of server +int status # receives i/o status + +int and() +include "kinode.com" + +begin + if (and (n_status[server], F_IOERR) == 0) { + call zawtks (n_kschan[server], status) + if (status == ERR) + call ki_error (server) + } else + status = ERR +end diff --git a/sys/ki/ksawrite.x b/sys/ki/ksawrite.x new file mode 100644 index 00000000..20c815f5 --- /dev/null +++ b/sys/ki/ksawrite.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "ki.h" + +# KS_AWRITE -- Write to the kernel server device driver given the node +# descriptor of a kernel server channel. If the error bit is set on the +# node return error w/o doing any i/o, since the channel will have been closed. + +procedure ks_awrite (server, buf, nbytes) + +int server # node descriptor index of server +char buf[ARB] # i/o buffer +int nbytes # nbytes to write + +int and() +include "kinode.com" + +begin + if (and (n_status[server], F_IOERR) == 0) + call zawrks (n_kschan[server], buf, nbytes, long(0)) +end diff --git a/sys/ki/ktzcls.x b/sys/ki/ktzcls.x new file mode 100644 index 00000000..826ad9f7 --- /dev/null +++ b/sys/ki/ktzcls.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KT_ZCLS -- Close a text device. We are called only if the device does not +# reside on the local node. + +procedure kt_zcls (device, chan, status) + +int device # device driver code +int chan # channel assigned device +int status # receives ok|err + +int server +int ki_sendrcv() +include "kichan.com" +include "kii.com" + +begin + server = k_node[chan] + p_arg[1] = k_oschan[chan] + + # If we receive error on the KS channel when trying to close a file, + # it is most likely due to a previous i/o error on the channel. Do + # not return error here because we are probably being called during + # error recovery to free the logical channel, and if we return error + # the real error will be hidden. + + if (ki_sendrcv (server, device, TX_CLS) == ERR) + status = OK + else + status = p_arg[1] + + call mfree (k_bufp[chan], TY_STRUCT) + call ki_freechan (chan) +end diff --git a/sys/ki/ktzfls.x b/sys/ki/ktzfls.x new file mode 100644 index 00000000..e22c1a98 --- /dev/null +++ b/sys/ki/ktzfls.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KT_ZFLS -- Flush output to a text device. We are called only if the device +# does not reside on the local node. + +procedure kt_zfls (device, chan, status) + +int device # device driver code +int chan # channel assigned device +int status # receives nchars written or ERR + +int server +int ki_sendrcv() +include "kichan.com" +include "kii.com" + +begin + call ki_flushtx (device, chan, status) + if (status == ERR) + return + + server = k_node[chan] + p_arg[1] = k_oschan[chan] + + if (ki_sendrcv (server, device, TX_FLS) == ERR) + status = ERR + else + status = p_arg[1] +end diff --git a/sys/ki/ktzget.x b/sys/ki/ktzget.x new file mode 100644 index 00000000..f45ae755 --- /dev/null +++ b/sys/ki/ktzget.x @@ -0,0 +1,106 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KT_ZGET -- Get all or part of a line of text from a text device. We are +# called only if the device does not reside on the local node. + +procedure kt_zget (device, chan, obuf, maxch, status) + +int device # device driver code +int chan # channel assigned device +char obuf[maxch] # receives text +int maxch # max chars to read +int status # receives nchars read or ERR + +pointer bd, bp, ip, rp +int server, nchars, nleft, reclen +int ki_sendrcv() +long ki_decode() +include "kichan.com" +include "kii.com" + +begin + bd = k_bufp[chan] + + # Text file input is buffered; each input buffer returned by the kernel + # server may contain any number of lines of text. Each line of text + # is preceded by a record header containing the record length and seek + # offset of the line. + + if (maxch == 1 || B_RP(bd) >= B_ITOP(bd)) { + # Refill buffer. + + server = k_node[chan] + p_arg[1] = k_oschan[chan] + + # Read only one character if this is a raw mode read. + if (maxch == 1) + p_arg[2] = 1 + else + p_arg[2] = SZ_TXBUF + + if (ki_sendrcv (server, device, TX_GET) == ERR) + status = ERR + else if (p_arg[1] <= 0) + status = p_arg[1] # EOF or ERR + else { + nchars = p_arg[1] + bp = B_BUFPTR(bd) + + # If the record is small it is returned in the string buffer, + # else it is returned as a second record. Each line is + # contained entirely in a single buffer. + + if (nchars <= SZ_SBUF) + call amovc (p_sbuf, Memc[bp], nchars) + else { + call ks_aread (server, Memc[bp], nchars) + call ks_await (server, status) + + if (status != nchars) { + call ki_error (server) + B_ITOP(bd) = bp + B_OTOP(bd) = bp + status = ERR + return + } + + call chrupk (Memc[bp], 1, Memc[bp], 1, nchars) + } + + B_RP(bd) = bp + B_ITOP(bd) = bp + nchars + B_OTOP(bd) = bp + B_CI(bd) = 0 + } + } + + # Return characters from the current record until it is exhausted. + # When the current record is empty, leave the record pointer pointing + # to the start of the next record and the character index pointing + # to the first char of that record. + + rp = B_RP(bd) + ip = R_DATA(rp) + B_CI(bd) + reclen = ki_decode (R_RECLEN(rp), NCHARS_INT) + nleft = R_GETNCHARS (reclen) - B_CI(bd) + + if (maxch >= nleft) { + # Return the remainder of the buffer. + + call amovc (Memc[ip], obuf, nleft) + status = nleft + B_RP(bd) = B_RP(bd) + reclen + B_CI(bd) = 0 + + } else { + # Return a portion of the data remaining in the buffer. + + call amovc (Memc[ip], obuf, maxch) + status = maxch + B_CI(bd) = B_CI(bd) + maxch + } +end diff --git a/sys/ki/ktznot.x b/sys/ki/ktznot.x new file mode 100644 index 00000000..8185b734 --- /dev/null +++ b/sys/ki/ktznot.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KT_ZNOT -- Note the file position of a text device. We are called only if +# the device does not reside on the local node. + +procedure kt_znot (device, chan, loffset) + +int device # device driver code +int chan # channel assigned device +long loffset # receives the file offset + +pointer bd, rp +int server, status +int ki_sendrcv() +long ki_decode() +include "kichan.com" +include "kii.com" +define physnote_ 91 + +begin + bd = k_bufp[chan] + + # The buffering of text file input and output complicates the seek and + # note functions. Our solution is [1] for an output file, flush the + # output and then call the kernel server to note the file position, and + # [2] for an input file, have the kernel server note the offset of each + # input line of text in the header area of each input record. + + if (B_ITOP(bd) >= B_BUFPTR(bd)) { + # Input file. + + rp = B_RP(bd) + + # Check for end of input buffer. + if (rp >= B_ITOP(bd)) + goto physnote_ + + # If already part way into line, return offset of the next line. + if (B_CI(bd) > 0) { + rp = rp + ki_decode (R_RECLEN(rp), NCHARS_INT) + if (rp >= B_ITOP(bd)) + goto physnote_ + } + + # Decode seek offset from record header of next line to be + # read. The seek offset is encoded as a char sequence. + + loffset = ki_decode (R_SEKOFF(rp), NCHARS_LONG) + return + + } else { + # Output file. + + call ki_flushtx (device, chan, status) + if (status == ERR) + return + } + +physnote_ + + # Physically call the kernel server to note the file offset. + + server = k_node[chan] + p_arg[1] = k_oschan[chan] + + if (ki_sendrcv (server, device, TX_NOT) == ERR) + loffset = ERR + else + loffset = ki_decode (p_sbuf, NCHARS_LONG) +end diff --git a/sys/ki/ktzopn.x b/sys/ki/ktzopn.x new file mode 100644 index 00000000..8a6c14b9 --- /dev/null +++ b/sys/ki/ktzopn.x @@ -0,0 +1,52 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KT_ZOPN -- Open a text device. We are called only if the device does not +# reside on the local node. + +procedure kt_zopn (device, osfn, mode, chan) + +int device # device driver code +char osfn[ARB] # packed os filename +int mode # access mode +int chan # receives assigned channel + +pointer bd, bp +int server +int ki_connect(), ki_sendrcv(), ki_getchan(), kmalloc() +include "kichan.com" +include "kii.com" + +begin + server = ki_connect (osfn) + p_arg[2] = mode + + if (ki_sendrcv (server, device, TX_OPN) == ERR) + chan = ERR + else if (p_arg[1] == ERR) + chan = ERR + else if (kmalloc (bd, LEN_TXBDES, TY_STRUCT) == ERR) + chan = ERR + else { + chan = ki_getchan (server, p_arg[1]) + k_bufp[chan] = NULL + + # Init the text buffer and buffer descriptor. Text i/o over the + # KI is buffered, greatly reducing the number of packets sent back + # and forth between nodes and likewise increasing the bandwidth. + # Buffering at the KI layer is necessary because FIO buffers only + # one line of text at a time, leaving blocking and deblocking of + # text lines to the kernel. + + k_bufp[chan] = bd + bp = B_BUFPTR(bd) + B_RP(bd) = bp + B_CI(bd) = 0 + B_ITOP(bd) = bp + B_OTOP(bd) = bp + B_BUFTOP(bd) = bp + SZ_TXBUF + } +end diff --git a/sys/ki/ktzput.x b/sys/ki/ktzput.x new file mode 100644 index 00000000..f55380a9 --- /dev/null +++ b/sys/ki/ktzput.x @@ -0,0 +1,125 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KT_ZPUT -- Put a line of text to a text device. We are called only if the +# device does not reside on the local node. Output is buffered for greater +# bandwidth and efficiency. + +procedure kt_zput (device, chan, ibuf, nchars, status) + +int device # device driver code +int chan # channel assigned device +char ibuf[nchars] # receives text +int nchars # nchars to write +int status # receives nchars written or ERR + +pointer bd, ep +include "kichan.com" + +begin + bd = k_bufp[chan] + ep = B_RP(bd) + nchars - 1 + + # If this is the first write into the buffer, OTOP will be set to + # the beginning of the buffer and we must reset it to the end. + + if (ep >= B_OTOP(bd)) { + # Check whether there is room remaining in the buffer for the data. + # We do not break output lines across buffer boundaries. + + if (ep >= B_BUFTOP(bd)) { + call ki_flushtx (device, chan, status) + if (status == ERR) + return + + # Check for buffer too small to hold data record. This should + # not be possible if SZ_TXBUF is chosen large enough, because + # FIO will break records larger than the FIO buffer size. + + if (nchars > SZ_TXBUF) { + status = ERR + return + } + } + + B_OTOP(bd) = B_BUFTOP(bd) + } + + # Append the text data to the output buffer. + + call amovc (ibuf, Memc[B_RP(bd)], nchars) + B_RP(bd) = B_RP(bd) + nchars + status = nchars +end + + +# KI_FLUSHTX -- Flush any buffered output of a text file. Text output is +# transmitted as a stream without reading the status back after each write. +# If a write error occurs on the logical channel to the text file, the kernel +# server will shut down entirely, causing a write error on the physical +# channel to the kernel server. It is harmless if we are called when the +# output buffer is empty or contains input data. + +procedure ki_flushtx (device, chan, status) + +int device # text file device code +int chan # channel assigned device +int status # receives nchars written or ERR + +pointer bd, bp +int server, nchars +int ki_send() +include "kichan.com" +include "kii.com" + +begin + bd = k_bufp[chan] + bp = B_BUFPTR(bd) + + # OTOP will have been set to BUFTOP if the buffer was written into. + # RP may be greater than BUFPTR for input buffers, too. If there is + # nothing to flush return without taking any action and without + # changing any file pointers. + + nchars = min (B_OTOP(bd), B_RP(bd)) - bp + if (nchars <= 0) { + status = 0 + return + } + + server = k_node[chan] + p_arg[1] = k_oschan[chan] + p_arg[2] = nchars + + # If the buffer is small enough it is sent in the string buffer, + # otherwise it is sent as a second record. + + if (nchars <= SZ_SBUF) { + call amovc (Memc[bp], p_sbuf, nchars) + p_sbuflen = nchars + } else + p_sbuflen = 0 + + # Send packet. + if (ki_send (server, device, TX_PUT) == ERR) + status = ERR + else if (nchars > SZ_SBUF) { + # Send data record. + + call chrpak (Memc[bp], 1, Memc[bp], 1, nchars) + call ks_awrite (server, Memc[bp], nchars) + call ks_await (server, status) + + if (status != nchars) + status = ERR + } + + # Mark the buffer empty. + + B_RP(bd) = bp + B_ITOP(bd) = bp + B_OTOP(bd) = bp +end diff --git a/sys/ki/ktzsek.x b/sys/ki/ktzsek.x new file mode 100644 index 00000000..f8b20829 --- /dev/null +++ b/sys/ki/ktzsek.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KT_ZSEK -- Seek on a text device. We are called only if the device does not +# reside on the local node. + +procedure kt_zsek (device, chan, loffset, status) + +int device # device driver code +int chan # channel assigned device +long loffset # znottx offset to seek to +int status # receives nchars written or ERR + +pointer bd +int server +int ki_sendrcv() +include "kichan.com" +include "kii.com" + +begin + call ki_flushtx (device, chan, status) + if (status == ERR) + return + + # Discard any cached input text to force a buffer refill at the new + # offset. + + bd = k_bufp[chan] + B_RP(bd) = B_ITOP(bd) + + # Transmit the seek request to the server. + + server = k_node[chan] + p_arg[1] = k_oschan[chan] + + # The long integer seek offset is passed as an encoded char sequence + # rather than as an integer p_arg value to avoid possible loss of + # precision. + + call ki_encode (loffset, p_sbuf, NCHARS_LONG) + p_sbuflen = NCHARS_LONG + + if (ki_sendrcv (server, device, TX_SEK) == ERR) + status = ERR + else + status = p_arg[1] +end diff --git a/sys/ki/ktzstt.x b/sys/ki/ktzstt.x new file mode 100644 index 00000000..c7ca9463 --- /dev/null +++ b/sys/ki/ktzstt.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KT_ZSTT -- Get file status on a text device. We are called only if the +# device does not reside on the local node. + +procedure kt_zstt (device, chan, what, lvalue) + +int device # device driver code +int chan # channel assigned device +int what # file parameter to be returned +long lvalue # receives the parameter value + +int server +int ki_sendrcv() +long ki_decode() +include "kichan.com" +include "kii.com" + +begin + server = k_node[chan] + p_arg[1] = k_oschan[chan] + p_arg[2] = what + + if (ki_sendrcv (server, device, TX_STT) == ERR) + lvalue = ERR + else + lvalue = ki_decode (p_sbuf, NCHARS_LONG) +end diff --git a/sys/ki/kzclmt.x b/sys/ki/kzclmt.x new file mode 100644 index 00000000..6d6bbb80 --- /dev/null +++ b/sys/ki/kzclmt.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "ki.h" + +# KZCLMT -- Close a magtape file. + +procedure kzclmt (chan, devpos, status) + +int chan #I channel to be closed +int devpos[ARB] #O receives position information +int status #O close status + +int server +int ki_sendrcv() +include "kichan.com" +include "kii.com" + +begin + # Possible if an abort occurs during the open. + if (chan <= 0) { + status = OK + return + } + + if (k_node[chan] == NULL) + call zzclmt (k_oschan[chan], devpos, status) + else { + server = k_node[chan] + p_arg[1] = k_oschan[chan] + + if (ki_sendrcv (server, KI_ZFIOMT, MT_CL) == ERR) + status = ERR + else { + status = p_arg[1] + call amovi (p_arg[2], devpos, LEN_MTDEVPOS) + } + + call mfree (k_bufp[chan], TY_INT) + } + + call ki_freechan (chan) +end diff --git a/sys/ki/kzopmt.x b/sys/ki/kzopmt.x new file mode 100644 index 00000000..859c4657 --- /dev/null +++ b/sys/ki/kzopmt.x @@ -0,0 +1,90 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "ki.h" + +# KZOPMT -- Open a magtape file. + +procedure kzopmt (device, mode, devcap, devpos, newfile, chan) + +char device[ARB] #I logical device name +int mode #I access mode +char devcap[ARB] #I tapecap entry for device +int devpos[ARB] #I tape position information +int newfile #U receives new file number +int chan #O channel assigned for reading filenames + +pointer sp, bp, bd +int server, dv_len, dc_len, dc_off +int ki_connect(), ki_send(), ki_receive(), ki_getchan() +int kmalloc(), strlen() +include "kichan.com" +include "kii.com" + +begin + server = ki_connect (device) + + # We must preallocate a channel descriptor in order for error + # recovery to work, if an abort occurs during the zzopmt. + + chan = ki_getchan (server, chan) + + if (server == NULL) { + call strpak (p_sbuf[p_arg[1]], p_sbuf, SZ_SBUF) + call zzopmt (p_sbuf, mode, devcap, devpos, newfile, k_oschan[chan]) + + } else { + call smark (sp) + call salloc (bp, SZ_COMMAND, TY_CHAR) + + # Determine whether devcap string will fit in sbuf. + call strupk (devcap, Memc[bp], SZ_COMMAND) + dv_len = strlen (p_sbuf[p_arg[1]]) + dc_len = strlen (Memc[bp]) + if (p_arg[1] + dv_len+1 + dc_len > SZ_SBUF) + dc_off = 0 + else { + dc_off = p_arg[1] + dv_len + 1 + call strcpy (Memc[bp], p_sbuf[dc_off], ARB) + p_sbuflen = dc_off + dc_len + } + + # Prepare the arguments. + p_arg[2] = mode + p_arg[3] = dc_off + p_arg[4] = dc_len + p_arg[5] = newfile + call amovi (devpos, p_arg[6], LEN_MTDEVPOS) + + if (ki_send (server, KI_ZFIOMT, MT_OP) == ERR) + k_oschan[chan] = ERR + else if (dc_len > 0 && dc_off == 0) { + call ks_awrite (server, devcap, dc_len+1) + call ks_await (server, k_oschan[chan]) + } + + if (ki_receive (server, KI_ZFIOMT, MT_OP) == ERR) + k_oschan[chan] = ERR + else { + k_oschan[chan] = p_arg[1] + newfile = p_arg[2] + } + + call sfree (sp) + } + + if (k_oschan[chan] == ERR) { + call ki_freechan (chan) + chan = ERR + } else { + if (server != NULL) { + if (kmalloc (bd, LEN_MTDEVPOS, TY_INT) == ERR) { + call ki_freechan (chan) + chan = ERR + } else + k_bufp[chan] = bd + } + } +end diff --git a/sys/ki/kzrdmt.x b/sys/ki/kzrdmt.x new file mode 100644 index 00000000..7fdaf517 --- /dev/null +++ b/sys/ki/kzrdmt.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "ki.h" + +# KZRDMT -- Asynchronous read from a magtape file. + +procedure kzrdmt (chan, obuf, max_bytes, offset) + +int chan #I magtape channel +char obuf[ARB] #O buffer to receive data +int max_bytes #I max bytes to read +long offset #I file offset + +pointer bd +int server, status +int ki_send(), ki_receive() +include "kichan.com" +include "kii.com" + +begin + server = k_node[chan] + + if (server == NULL) { + call zzrdmt (k_oschan[chan], obuf, max_bytes, offset) + return + } + + # Ignore zero reads and requests on a node closed by an error. + if (max_bytes <= 0) { + k_status[chan] = 0 + return + } + + # Send the request to initiate the read. + p_arg[1] = k_oschan[chan] + p_arg[2] = max_bytes + p_arg[3] = offset + + if (ki_send (server, KI_ZFIOMT, MT_RD) == ERR) { + status = ERR + } else { + bd = k_bufp[chan] + + # Wait for the ZAWT packet. + if (ki_receive (server, KI_ZFIOMT, MT_WT) == ERR) + status = ERR + else { + status = p_arg[1] + call amovi (p_arg[2], Memi[bd], LEN_MTDEVPOS) + } + + # Read the data block (if any) directly into caller's buffer. + if (status > 0) { + call ks_aread (server, obuf, status) + call ks_await (server, status) + } + } + + k_status[chan] = status +end diff --git a/sys/ki/kzrwmt.x b/sys/ki/kzrwmt.x new file mode 100644 index 00000000..38ce6634 --- /dev/null +++ b/sys/ki/kzrwmt.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "ki.h" + +# KZRWMT -- Rewind a (nonopen) magtape drive. + +procedure kzrwmt (drive, devcap, status) + +char drive[ARB] #I packed name of drive to be rewound +char devcap[ARB] #I packed tapecap entry for device +int status #O receives status, ok|err + +pointer sp, bp +int server, dv_len, dc_len, dc_off, nbytes +int ki_connect(), ki_send(), ki_receive(), strlen() +include "kii.com" + +begin + server = ki_connect (drive) + + if (server == NULL) { + call strpak (p_sbuf[p_arg[1]], p_sbuf, SZ_SBUF) + call zzrwmt (p_sbuf, devcap, status) + + } else { + call smark (sp) + call salloc (bp, SZ_COMMAND, TY_CHAR) + + # Determine whether devcap string will fit in sbuf. + call strupk (devcap, Memc[bp], SZ_COMMAND) + dv_len = strlen (p_sbuf[p_arg[1]]) + dc_len = strlen (Memc[bp]) + if (dv_len+1 + dc_len > SZ_SBUF) { + dc_off = 0 + nbytes = (dc_len + SZB_CHAR-1) / SZB_CHAR + } else { + dc_off = dv_len + 1 + call strcpy (Memc[bp], p_sbuf[dc_off], ARB) + p_sbuflen = dc_off + dc_len + } + + # Prepare the arguments. + p_arg[2] = dc_off + p_arg[3] = dc_len + + if (ki_send (server, KI_ZFIOMT, MT_RW) == ERR) + status = ERR + else if (dc_len > 0 && dc_off == 0) { + call ks_awrite (server, devcap, nbytes) + call ks_await (server, status) + } + + if (ki_receive (server, KI_ZFIOMT, MT_RW) == ERR) + status = ERR + else + status = p_arg[1] + + call sfree (sp) + } +end diff --git a/sys/ki/kzstmt.x b/sys/ki/kzstmt.x new file mode 100644 index 00000000..2aaa0f45 --- /dev/null +++ b/sys/ki/kzstmt.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "ki.h" + +# KZSTMT -- Device status for a magtape device. + +procedure kzstmt (chan, what, lvalue) + +int chan #I active magtape channel +int what #I device parameter +long lvalue #O parameter value + +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zzstmt (k_oschan[chan], what, lvalue) + else + call kb_zstt (KI_ZFIOMT, chan, what, lvalue) +end diff --git a/sys/ki/kzwrmt.x b/sys/ki/kzwrmt.x new file mode 100644 index 00000000..74ae0dd9 --- /dev/null +++ b/sys/ki/kzwrmt.x @@ -0,0 +1,49 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KZWRMT -- Asynchronous write to a magtape file. + +procedure kzwrmt (chan, buf, nbytes, offset) + +int chan #I magtape channel +char buf[ARB] #I buffer containing data +int nbytes #I nbytes to write +long offset #I file offset + +int server +int ki_send() +include "kichan.com" +include "kii.com" + +begin + server = k_node[chan] + + if (server == NULL) { + call zzwrmt (k_oschan[chan], buf, nbytes, offset) + return + } + + # Ignore zero writes and requests on a node closed by an error. + if (nbytes <= 0) { + k_status[chan] = 0 + return + } + + # Send the request followed by the data block. We do not read anything + # back from the remote server until ZAWT is called. Set k_status[chan] + # to WRITE_IN_PROGRESS to tell ZAWT that an await call is needed. + + p_arg[1] = k_oschan[chan] + p_arg[2] = nbytes + p_arg[3] = offset + + if (ki_send (server, KI_ZFIOMT, MT_WR) == ERR) + k_status[chan] = ERR + else { + call ks_awrite (server, buf, nbytes) + call ks_await (server, k_status[chan]) + } +end diff --git a/sys/ki/kzwtmt.x b/sys/ki/kzwtmt.x new file mode 100644 index 00000000..3358d83e --- /dev/null +++ b/sys/ki/kzwtmt.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "ki.h" + +# KZWTMT -- Wait for i/o to complete on a magtape channel. + +procedure kzwtmt (chan, devpos, status) + +int chan #I active magtape channel +int devpos[ARB] #O device position structure +int status #O receives nbytes transferred or ERR + +pointer bd +include "kichan.com" + +begin + if (k_node[chan] == NULL) + call zzwtmt (k_oschan[chan], devpos, status) + else { + bd = k_bufp[chan] + status = k_status[chan] + call amovi (Memi[bd], devpos, LEN_MTDEVPOS) + } +end diff --git a/sys/ki/mkpkg b/sys/ki/mkpkg new file mode 100644 index 00000000..65a0c895 --- /dev/null +++ b/sys/ki/mkpkg @@ -0,0 +1,107 @@ +# Update the KI kernel interface. + +$checkout libsys.a lib$ +$update libsys.a +$checkin libsys.a lib$ +$exit + +update: + $call relink + $call install + ; + +relink: + $omake irafks.x\ + ki.h kii.com + $link irafks.o + ; + +install: + $move irafks.e bin$ + ; + +libsys.a: + # Do not put irafks.x in this list. + kbzard.x ki.h kichan.com kii.com + kbzawr.x ki.h kichan.com kii.com + kbzawt.x ki.h kichan.com + kbzcls.x ki.h kichan.com kii.com + kbzopn.x ki.h kii.com + kbzstt.x ki.h kichan.com kii.com kinode.com \ + + kclcpr.x ki.h kichan.com kii.com + kcldir.x ki.h kichan.com kii.com + kcldpr.x ki.h kichan.com kii.com + kdvall.x ki.h kii.com + kdvown.x ki.h kii.com + kfacss.x ki.h kii.com + kfaloc.x ki.h kii.com + kfchdr.x ki.h kii.com kinode.com + kfdele.x ki.h kii.com + kfgcwd.x ki.h kii.com kinode.com + kfinfo.x ki.h kii.com + kfiobf.x ki.h kichan.com kii.com + kfiogd.x ki.h kichan.com kii.com + kfiolp.x ki.h kichan.com kii.com + kfiopl.x ki.h kichan.com kii.com + kfiopr.x ki.h kichan.com + kfiosf.x ki.h kichan.com kii.com + kfiotx.x ki.h kichan.com kii.com + kfioty.x ki.h kichan.com kii.com + kfmkcp.x ki.h kii.com + kfmkdr.x ki.h kii.com + kfpath.x ki.h kinode.com + kfprot.x ki.h kii.com + kfrnam.x ki.h kii.com + kfrmdr.x ki.h kii.com + kfsubd.x ki.h + kfutim.x ki.h kii.com + kfxdir.x ki.h kinode.com + kgfdir.x ki.h kichan.com kii.com + kiconnect.x ki.h kichan.com kii.com kinode.com \ + + kiencode.x + kienvreset.x ki.h kii.com kinode.com + kierror.x kinode.com ki.h + kiextnode.x ki.h kinode.com + kifchan.x kichan.com kinode.com ki.h + kifmapfn.x ki.h kii.com + kifndnode.x kinode.com ki.h + kigchan.x kichan.com kinode.com ki.h + kighost.x ki.h kinode.com + kignode.x kinode.com ki.h + kiinit.x ki.h kichan.com kinode.com + kilnode.x kinode.com ki.h + kimapchan.x ki.h kichan.com kinode.com + kimapname.x + kintpr.x ki.h kichan.com kii.com + kiopenks.x ki.h kii.com kinode.com + kireceive.x ki.h kii.com kinode.com + kisend.x ki.h kii.com + kisendrcv.x + kishownet.x ki.h kinode.com + kixnode.x + kopcpr.x ki.h kichan.com kii.com + kopdir.x ki.h kichan.com kii.com + kopdpr.x ki.h kii.com + koscmd.x ki.h kii.com kinode.com \ + + ksaread.x ki.h kinode.com + ksawait.x ki.h kinode.com + ksawrite.x ki.h kinode.com + ktzcls.x ki.h kichan.com kii.com + ktzfls.x ki.h kichan.com kii.com + ktzget.x ki.h kichan.com kii.com + ktznot.x ki.h kichan.com kii.com + ktzopn.x ki.h kichan.com kii.com + ktzput.x ki.h kichan.com kii.com + ktzsek.x ki.h kichan.com kii.com + ktzstt.x ki.h kichan.com kii.com + kzclmt.x ki.h kichan.com kii.com + kzopmt.x ki.h kichan.com kii.com + kzrdmt.x ki.h kichan.com kii.com + kzrwmt.x ki.h kii.com + kzstmt.x ki.h kichan.com + kzwrmt.x ki.h kichan.com kii.com + kzwtmt.x ki.h kichan.com + ; diff --git a/sys/ki/zzdebug.x b/sys/ki/zzdebug.x new file mode 100644 index 00000000..550fcc3f --- /dev/null +++ b/sys/ki/zzdebug.x @@ -0,0 +1,120 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +task rexec = t_rexec, + rtype = t_rtype, + rread = t_rread, + encode = t_encode + +define SZ_BUF 4096 + + +# REXEC -- Execute a command on a remote node and print the resultant output on +# the standard output. Used to test the kernel server driver. + +procedure t_rexec() + +char server[SZ_LINE] +char buf[SZ_BUF] +int chan, nbytes, status + +begin + call clgstr ("server", server, SZ_LINE) + call strpak (server, server, SZ_LINE) + + call zopnks (server, READ_WRITE, chan) + if (chan == ERR) + call error (1, "cannot connect to remote server process") + + repeat { + call zardks (chan, buf, SZ_BUF, 0) + call zawtks (chan, nbytes) + + if (nbytes > 0) { + call chrupk (buf, 1, buf, 1, nbytes) + call write (STDOUT, buf, nbytes) + call flush (STDOUT) + } + } until (nbytes <= 0) + + call zclsks (chan, status) + if (status == ERR) + call error (1, "error disconnecting server process") +end + + +# RTYPE -- Type a text file possibly resident on a remote node. + +procedure t_rtype() + +char fname[SZ_FNAME] +char lbuf[SZ_LINE] +int fd +int open(), getline() + +begin + call clgstr ("file", fname, SZ_FNAME) + fd = open (fname, READ_ONLY, TEXT_FILE) + + while (getline (fd, lbuf) != EOF) { + call putline (STDOUT, lbuf) + call flush (STDOUT) + } + + call close (fd) +end + + +# RREAD -- Read a binary file. + +procedure t_rread() + +char fname[SZ_FNAME] +char dbuf[SZ_BUF] +int fd +long nchars, totchars +int open(), read() + +begin + call clgstr ("file", fname, SZ_FNAME) + fd = open (fname, READ_ONLY, BINARY_FILE) + + totchars = 0 + + repeat { + nchars = read (fd, dbuf, SZ_BUF) + if (nchars > 0) + totchars = totchars + nchars + } until (nchars == EOF) + + call close (fd) + + call printf ("read %d chars\n") + call pargi (totchars) +end + + +# ENCODE -- Test the kiencode/decode routines. + +procedure t_encode() + +int v, ip +char xnum[8] +int ki_decode(), clgeti() + +begin + repeat { + v = clgeti ("value") + call ki_encode (v, xnum, 8) + call chrpak (xnum, 1, xnum, 1, 8) + call chrupk (xnum, 1, xnum, 1, 8) + + call printf ("\t") + for (ip=1; ip <= 8; ip=ip+1) { + call printf ("%3d ") + call pargc (xnum[ip]) + } + + call printf (" --> %d\n") + call pargi (ki_decode (xnum, 8)) + } +end diff --git a/sys/ki/zzrdks.c b/sys/ki/zzrdks.c new file mode 100644 index 00000000..40229d5b --- /dev/null +++ b/sys/ki/zzrdks.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +int spoolit = 0; +int spoolfd = 0; + +/* Intercept KS intput and spool in a file for subsequent debugging. + * [MACHDEP]. This is a UNIX dependent debugging routine. To get rid of + * it, delete the file, edit the Makefile, and change the reference to + * zzrdks in irafks.x to zardks. + */ +zzrdks_ (chan, buf, maxb, off) +int *chan; +short *buf; +int *maxb; +int *off; +{ + int status; + + zardks_ (chan, buf, maxb, off); + + if (spoolit) { + if (spoolfd == 0) + spoolfd = creat ("/tmp/ks.in", 0644); + zawtks_ (chan, &status); + if (status > 0) + write (spoolfd, buf, status); + } +} diff --git a/sys/libc/Libc.hlp b/sys/libc/Libc.hlp new file mode 100644 index 00000000..e13faeea --- /dev/null +++ b/sys/libc/Libc.hlp @@ -0,0 +1,559 @@ +.help LIBC Sep84 "C Runtime Library" +.sp 2 +.ce +\fBIRAF Runtime Library for the C Language\fR +.ce +CL Interface to IRAF +.sp 3 +.nh +Introduction + + The IRAF runtime library for the C language was developed to port the +IRAF command language (CL) from UNIX to IRAF. The C runtime library (LIBC) +consists of two parts: an emulation of the standard i/o library provided +for the C language on an UNIX host, and a library of "system calls", i.e., +the C interface to the IRAF virtual operating system. + +.nh +Naming Conventions + + Providing familiar and predictable procedure names in C is complicated +by the possibility of name collisions with external names in the program +interface libraries. To solve this problem while maintaining compatibility +with UNIX the external names of all UNIX emulation procedures are assigned +in C \fIdefine\fR statements. The external name is simply the UNIX name +preceded by the prefix "u_", e.g., + + fopen() + +compiles as + + u_fopen() + +The names of the "system calls" are not compatible with those of the UNIX +system calls. Each system call maps directly to an IRAF program interface +procedure. The name of the C version is the IRAF name preceded by the +prefix "c_", e.g., + + open() + +is called in C as + + c_open() + +The "c_" names are not redefined except where necessary to produce an +external identifier unique in the first seven characters. When an external +name is redefined to make it unique in the first seven characters this +is done by application of the 4+1 rule, leaving the "c_" prefix as is. +The calling sequences of the C system calls have been kept as compatible +with the "crib sheet" versions as possible, even when a more convenient +syntax could have been used for C. + +.nh +Include Files + + C style global include files pose a problem in a portable system since +machine dependent filenames cannot be used. This problem is sidestepped +for LIBC by using the C language preprocessor to indirectly reference the +global include files via a single master include file installed in the +C system include file directory. The master include file is referenced +as . The actual include files reside in the IRAF directory system +(as does a copy of ) and hence are automatically ported with the +system. The pathname to the LIBC global include files is arbitrary, but +currently these files are stored in lib$libc. + +The technique used to access LIBC global include files in perhaps best +explained by use of a simple example from the CL: + + +.ks +.nf + #define import_spp global includes + #define import_libc + #define import_stdio + #include + + #include "config.h" local includes + #include "operand.h" + #include "param.h" + #include "task.h" +.fi +.ke + + +The include file contains preprocessor control lines which load +the include files referenced by "#define import_packagename" statements. +In addition to being portable, this technique has the benefits of ensuring +that the include files are loaded in the correct order and are not loaded +more than once. + +The include file referenced by \fIimport_libc\fR should be included in +every C source file which uses LIBC. In addition to loading the referenced +include files, also includes definitions for the IRAF root +directory IRAFDIR, the default image storage directory IMAGEDIR, and the +name of the host operating system (e.g. "UNIX" or "VMS"). + +.nh +UNIX Emulation + + All procedures in the UNIX standard i/o (stdio) package are emulated +in libc. A listing of the calling sequences of all currently implemented +procedures is given as an appendix. The syntax and semantics of these +procedures have been kept as close to those of the V7 UNIX procedures as +possible. + +.nh +IRAF Program Interface Routines + + All i/o in the CL is implemented ultimately by calls to procedures in +the IRAF program interface libraries. The UNIX emulation procedures +discussed in the previous sections, for example, are reasonably portable +C language packages which call C versions of the IRAF program interface +routines. With few exceptions the C version of each procedure maps trivially +to the corresponding program interface procedure. The main complication +arises from the need to pack and unpack character strings when calling an +SPP (Fortran) procedure from C. Read only arguments are passed by value +for the convenience of the C language progammer. + +The full program interface contains on the order of a thousand procedures +(including generics) and it would be prohibitively difficult to make them +all available in C. We have therefore included only the packages actually +used by the CL in the interface, and then only the most commonly used +procedures in each package. All files which directly reference program +interface procedures should include a reference to the C language include +file \fBirafio.h\fR. + +.nh 2 +File I/O (FIO) + + The fundamental unit of storage in both C and SPP is the \fBchar\fR, +but unfortunately a char is not necessarily the same size in both languages. +In the C version of FIO data is referenced in units of C chars (bytes), +subject to the restriction that only an \fIintegral\fR number of SPP chars +can be read and written at a time, and seeks must be aligned on a char +boundary. If a nonintegral number of SPP chars are read or written, +the interface will silently move the extra bytes necessary to fill out +an SPP char, possibly writing beyond the end of the input buffer on a read. +These problems are less serious than it might seem, however, since CL level +i/o is predominantly text only (binary file i/o is not currently used in +the CL). + +In keeping with the C language tradition, all FIO offsets are \fIzero\fR +indexed, and all integer valued procedures return ERR as the function value +in the event of an error. Pointer valued functions return NULL in the +event of an error. Although only "significant" function values are shown in the +calling sequences below, all procedures return a function value. + + +.ks +.nf +High Level FIO: + + fd = c_open (vfn, mode, type) + c_close (fd) + c_flush (fd) + + c_fseti (fd, param, value) + int = c_fstati (fd, param) + + stat = c_finfo (vfn, &fi) + y/n = c_access (vfn, mode, type) + c_delete (vfn) + c_rename (old_vfn, new_vfn) + c_mktemp (root, &fname, maxch) +.fi +.ke + + +The "low level" FIO procedures perform binary file i/o and fill and flush +the internal FIO file buffer. These procedures are called by the STDIO +package and are not intended to be called directly by general CL code. +Seeking is not implemented in STDIO due to the difficulty of implementing +\fBfseek\fR in a portable system, but is not currently required anywhere +in the CL. STDIO directly accesses the internal FIO buffer pointers +via a data structure defined in \fBirafio.h\fR. + + +.ks +.nf +Low Level FIO: + + nchars = c_read (fd, &buf, maxch) + c_write (fd, &buf, nchars) + c_seek (fd, loffset) + loffset = c_note (fd) + + ch = c_filbuf (fd) + ch = c_flsbuf (fd, ch) + FILE = c_fioptr (fd) +.fi +.ke + + +The file access modes and types are specified as in SPP, i.e., via predefined +integer constants defined in \fIirafio.h\fR (READ_ONLY, NEW_FILE, etc.). +Only a few \fBfset\fR options are implemented; these are likewise defined +in \fIirafio.h\fR. The integer constants STDIN, STDOUT, etc. refer to +FIO file descriptors, and should not be confused with \fBstdin\fR, +\fBstdout\fR, etc., which reference STDIO file pointers. + +.nh 2 +Environment Facilities + + The environment list is managed entirely by the program interface via +the ENV package. The CL calls ENV procedures to create, modify, and access +the environment list. The \fBc_propen\fR procedure in the program interface +passes the environment list on to a connected child process at process +creation time. + + +.ks +.nf + nchars = c_envgets (name, &value, maxch) + redef = c_envputs (name, &value) + c_envmark (&sp) + nredefs = c_envfree (sp) + + bool = c_envgetb (name) + int = c_envgeti (name) + c_envlist (out_fd, prefix, show_redefs) + nscan = c_envscan (input_source) +.fi +.ke + +The following (non program interface) procedure is defined and used internally +by the CL to lookup names in the environment list: + + strp = envget (name) + +.nh 3 +Implementation Notes + + The environment list is maintained as a multi-threaded linked list. This +provides the searching efficiency of a hash table plus stack like semantics +for redefinitions and for freeing blocks of variables. There are two primary +data structures internally, an array of pointers to the heads of the threads, +and a buffer containing the list elements. These data structures are +dynamically allocated and will be automatically reallocated at runtime if +overflow occurs. The number of threads determines the hashing efficiency and +is a compile time parameter. + +The \fBenvmark\fR and \fBenvfree\fR procedures +mark and free storage on the environment list stack. +All environment variables defined or redefined after a call to \fBenvmark\fR +will be deleted and storage freed by a call to \fBenvfree\fR. If a redef +is freed the next most recent definition becomes current. \fBEnvfree\fR returns +as its function value the number of redefined variables uncovered by the free +operation. The calling program must mark and free in the correct order or the +environment list may be trashed. + +The \fBenvlist\fR procedure prints the environment list on a file. +Redefined values will be printed only if so indicated. +The environment list is printed as a list of +\fBset\fR statements in most recent first order, i.e., + + +.ks +.nf + set nameN=valueN + set nameM=valueM + ... + set name1=value1 +.fi +.ke + + +The \fBenvlist\fR function is used both to inspect the environment list +and to pass the list on to a child process. +Redefined variables are omitted when passing +the list on to a child process, hence the order of definition does not matter. +The output format is "prefix name=value", where the prefix string is supplied +by the user. + +The \fBenvscan\fR function parses one or more \fBset\fR statements, +calling \fBenvputs\fR to enter the SET declarations into the environment list. +The argument is either a \fBset\fR declaration or a string of the form +"set @filename", where "filename" is the name of a file containing \fBset\fR +declarations. + +.nh 2 +Process Control + + Separate facilities are provided for \fBconnected\fR and \fBdetached\fR +processes. Virtually all process control is concerned with connected +subprocesses, i.e., subprocesses running synchronously with the CL and +communicating with the CL via bidirectional IPC channels. The only detached +process in the system is the CL itself, when spawned as a background job +by another (usually interactive) CL process. + +.nh 3 +Connected Subprocesses + + A connected subprocess is connected with \fBpropen\fR and disconnected +with \fBprclose\fR. The \fBpropen\fR procedure spawns the named process, +connects the IPC channels to FIO file descriptors, then sends commands to +the child process to initialize the environment and current working directory. +Once connected the \fIin\fR and \fIout\fR file descriptors may be reopened +with \fBfdopen\fR for UNIX style i/o to the subprocess. The \fBprclose\fR +procedure sends the "bye" (shutdown) command to the child, waits for the +child to terminate, and then returns the process termination status as the +function value. Normal exit status is OK, otherwise a positive integer +error code is returned. + + +.ks +.nf + pid = c_propen (process, in, out) + stat = c_prclose (pid) + c_prsignal (pid, signal) + c_prredir (pid, stream, new_fd) + c_prupdate (message) +.fi +.ke + + +To execute a task in a connected child process the CL writes a command to +the \fIout\fR channel with a conventional \fBfputs\fR or other STDIO call. +After starting the task the CL redirects its command input to the \fIin\fR +channel of the task; conventional \fBfgets\fR or \fBgetc\fR calls are made +to read commands from the task, until "bye" is received, signaling task +termination. + +New \fBset\fR or \fBchdir\fR statements may be broadcast to all connected +subprocesses at any time (except while actually executing a task resident +in a connected subprocess) by a call to \fBprupdate\fR. While there is no +way the CL can free space on the environment stack in a child process, it is +possible to broadcast new redefinitions to all child processes if redefinitions +should be uncovered by an \fBenvfree\fR call in the CL. + +The \fBprsignal\fR procedure is used to raise the interrupt exception X_INT +in a connected child process. When the user types interrupt (e.g. ctrl/c) +at the CL level, the CL interrupt exception handler signals the child +process containing the external task currently in execution (if any), +and then resumes processing of commands from the child. If a special exception +handler is not posted in the child it will go through error restart, +eventually sending the \fBerror\fR statement to the CL indicating abnormal +termination of the task. Note that it is permissible for a child process +to ignore the interrupt exception, or take special recovery actions if +interrupt occurs. + +.nh 4 +I/O Redirection + + Pseudofile i/o (\fBxmit\fR and \fBxfer\fR directives for the task's STDIN, +STDOUT, etc.) is handled by the program interface transparently to the CL. +By default the standard i/o streams of the child are connected to the +identical streams of the parent (the CL). If redirection of a stream +is desired the stream may be redirected in either of two ways: +.ls +.ls [1] +A stdio stream may be redirected directly at the task level in the child +process by including redirection information on the command line sent to +the child to execute the task. This is the most efficient technique, and +it should be used when appropriate, e.g., for pipes or whenever an output +stream of an external task is explicitly redirected on the CL command line. +The syntax of the task statement recognized by the IRAF Main is documented +in the \fISystem Interface Reference Manual\fR. For example, to run a task +with the standard output redirected to a pipe file: + +.ks +.nf + fprintf (out_fp, "%s %d > %s\n", + taskname, STDOUT, pipefilename); +.fi +.ke + +Pipe files, by the way, are implemented as binary files for maximum flexibility +and efficiency. This is acceptable since they are read and written only by +the system. Very high i/o bandwidths are possible using direct i/o to a binary +file. +.le + +.ls [2] +A stdio stream may be redirected at the CL level to any previously opened +FIO file, e.g., to one of the CL's standard streams, to a text or binary +file opened explicitly by the CL, or to another child process (e.g. redirection +of the standard graphics output of the child to a graphics subprocess). +This type of redirection requires the following steps by the CL: +.ls +.ls o +Open local stream to which child's stream is to be redirected. +.le +.ls o +Call \fBprredir\fR to map the child's stream to the local stream. +.le +.ls o +When the task is run, include an argument of the form "N >" on the task +command line, indicating that stream N has been redirected by the parent +process (the file name is omitted). +.le +.ls o +When the task terminates, or when the next task is run in the same process, +restore the original i/o connection with another call to \fBprredir\fR. +The default connection is established by the system only at \fBpropen\fR time. +.le +.le +.le +.le + + +The I/O redirection mechanism permits messages to be shuffled from a child +process deep in the process tree to a device owned by the CL, or from a child +process in one branch of the process tree to a process in another branch of +the tree. If raw mode is set on the STDIN stream in the child it will +automatically be passed on to the process which physically reads the raw mode +device. Asynchronous execution is possible so long as messages pass only +one way. Synchronization occurs whenever a process waits on a read. The most +complex example of the IPC i/o redirection mechanism in the current system +occurs when a science or utility task sends graphics commands via the CL to a +separate graphics task. Ignoring GKS inquires, this process is fully +asynchronous and should be acceptably efficient provided the IPC buffer size +is reasonable (1-4 Kb) and large amounts of bulk data do not have to be passed. + +.nh 3 +Detached Processes + + The CL executes commands in the background, i.e., asynchronously, by +dumping the entire run time context of the CL into a binary background +file, then spawning a detached CL process to execute the already compiled +command in the context of the parent. The run time context consists of +the dictionary and stack areas, the environment list, and various other +internal state parameters which are copied into the header area of the +bkgfile. This is a potential problem area if dynamic memory is used, +since it may not be possible to duplicate the virtual addresses of the +parent's data area in the child. + + +.ks +.nf + job = c_propdpr (process, bkgfile) + stat = c_prcldpr (job) + y/n = c_prdone (job) + c_prkill (job) + + exit = c_onentry (prytpe, bkgfile) + c_onexit (epa) +.fi +.ke + + +The CL process uses the same IRAF Main as a normal IRAF process, except that +a special \fBonentry\fR procedure is linked which serves as the CL main. +The \fBonentry\fR procedure is called by the IRAF Main during +process startup with the arguments shown; the function value returned by +\fBonentry\fR determines whether or not the interpreter in the IRAF Main +is entered. Since we do not want IRAF Main prompts from the CL process +the CL version of \fBonentry\fR always returns CL_EXIT, causing process +shutdown following execution of any procedures posted with \fBonexit\fR +during execution of \fBonentry\fR. + +A detached process opened with \fBpropdpr\fR should always be closed with +\fBprcldpr\fR if it terminates while the parent is still executing. +The \fBprdone\fR procedure may be called to determine if a background job +has terminated. A background job may be aborted with \fBprkill\fR. + +.nh 2 +Terminal Control + + The TTY interface is provided at the CL level to support screen editing. +TTY is the IRAF interface to the \fBtermcap\fR terminal capability database, +originally developed at Berkeley for UNIX by Bill Joy. + + +.ks +.nf + tty = c_ttyodes (ttyname) + c_ttycdes (tty) + c_ttyseti (tty, parameter, value) + int = c_ttystati (tty, parameter) + + bool = c_ttygetb (tty, cap) + int = c_ttygeti (tty, cap) + float = c_ttygetr (tty, cap) + nchars = c_ttygets (tty, cap, &outstr, maxch) + c_ttyctrl (fd, tty, cap, afflncnt) + c_ttyputs (fd, tty, ctrlstr, afflncnt) + + c_ttyclear (fd, tty) + c_ttyclearln (fd, tty) + c_ttygoto (fd, tty, col, line) + c_ttyinit (fd, tty) + c_ttyputline (fd, tty, text, map_cc) + c_ttyso (fd, tty, onflag) +.fi +.ke + + +Complete descriptions of TTY and \fBtermcap\fR are given elsewhere. +Briefly, the device descriptor for a particular terminal is opened +with \fBttyodes\fR, which returns a IRAF pointer (C integer) to the +binary TTY descriptor. +The terminal name may be given as "terminal", in which case \fBttyodes\fR +will look up the name of the default terminal in the environment and search +the termcap database for the entry for the named device. + +The \fBttyget\fR functions are used to read the capabilities. +Capabilities are specified by two character mnemonics (character strings), +shown as the \fIcap\fR arguments in the calling sequences above. +Control sequences may be output with \fBttyctrl\fR or with \fBttyputs\fR, +depending on whether you are willing to do a binary search for a +particular capability at run time. +The remaining high level functions make it easy to perform the more common +control functions. + +Raw mode output to a terminal device is provided by the system interface +(the newline and tab characters are exceptions). Raw mode input is +provided as an \fBfseti\fR option in FIO. To set raw mode on STDIN: + + c_fseti (STDIN, F_RAW, YES); + +While raw mode is in effect input characters are read as they are typed, +few or no control characters are recognized, and no echoing is performed. + +.nh 2 +Memory Management + + Both heap and stack storage facilities are available in the program +interface, and we have made both types of facilities available in the CL. +Note, however, that the CL does not currently use dynamic memory allocation +directly due to the difficulties such use would cause when passing the +context of the CL to a background CL (used to execute commands in the +background). The CL currently makes heavy use of pointers in the dictionary +data structures, and since the dictionary is passed to the background CL +as a binary array, it must be restored to the same base memory address or +the pointers will be meaningless. This led to the implementation of the +dictionary and stack areas as fixed size, statically allocated arrays. + +The use of a fixed size dictionary is restrictive and wasteful of storage; +a future implementation based on \fBsalloc\fR (the stack facilities) is +desirable provided the context passing problem can be solved. Note that +the environment facilities do use dynamic storage and that it is nonetheless +possible to pass the environment to a background CL, despite the internal +use of pointers in the environment management package. + + +.ks +.nf +Heap Storage (UNIX compatible): + + buf = malloc (nchars) u_malloc + buf = calloc (nchars) u_calloc + mfree (buf) u_mfree + + +Stack Storage: + + c_smark (&sp) + buf = c_salloc (nchars) + c_sfree (sp) +.fi +.ke + + +Note that the C callable versions of \fBmalloc\fR, \fBcalloc\fR, and +\fBmfree\fR emulate the comparable UNIX procedures. The storage units +are C chars, i.e., bytes. Promotion to an integral number of SPP chars +is automatic. The \fIbuf\fR argument is a C pointer. The \fIsp\fR +argument, used to mark the position of the stack pointer, is an integer. +The stack is implemented in segments allocated on the heap, hence there +is no builtin limit on the size of the stack. diff --git a/sys/libc/README b/sys/libc/README new file mode 100644 index 00000000..4801a369 --- /dev/null +++ b/sys/libc/README @@ -0,0 +1,208 @@ +LIBC -- C language binding for a portion of the IRAF VOS + UNIX emulator + +This directory contains + + [1] A subset of the routines from the UNIX stdio library. These routines + emulate the equivalent UNIX routines but are interfaced to the IRAF + program interface. + + [2] C-callable versions of a subset of the routines from the IRAF program + interface. Included are portions of the following packages: + + file i/o + formatted i/o + environment + process control + terminal control + memory management + exception handling + +The header files "irafio.h" and "names.h" should be included in all C files +which reference the C library. The include files "stdio.h" and "ctype.h" +should be used wherever they would be used in a UNIX/C system. + + +IMPORTANT NOTE: + + Routines marked VARARGS are machine dependent in that they assume a +certain ordering (left to right) for the argument list. On some machines +the ordering may be the opposite. + +TODO: Rewrite these procedures to use the UNIX macros. + + +1. LIBC Emulation of UNIX C-Library Procedures + + syntax err eof + + double = asin (x) + double = acos (x) + double = atan (x) + double = atan2 (x, y) + double = atof (str) 0. + int = atoi (str) 0 + long = atol (str) 0 + charp = calloc (nelems, elsize) NULL + clearerr (fp) + double = cos (x) + double = exp (x) + fclose (fp) EOF + FILE = fdopen (fd, modestr) NULL + bool = feof (fp) + bool = ferror (fp) + fflush (fp) EOF + ch = fgetc (fp) EOF + charp = fgets (buf, maxch, fp) NULL + fd = fileno (fp) + FILE = fopen (fname, modestr) NULL + fputc (ch, fp) EOF + fputs (str, fp) + nelem = fread (bp, szelem, nelem, fp) 0 0 + free (buf) + FILE = freopen (fname, modestr, fp) NULL + fseek (fp, offset, origin) EOF + long = ftell (fp) + nelem = fwrite (bp, szelem, nelem, fp) 0 0 + ch = getc (fp) EOF EOF + ch = getchar () EOF EOF + charp = getenv (envvar) NULL + charp = gets (buf) NULL NULL + word = getw (fp) EOF EOF + charp = index (str, ch) NULL + double = log (x) + double = log10 (x) + int = nint (x) + charp = malloc (nbytes) NULL + charp = mktemp (template) NULL + perror (prefix) + double = pow (x, y) + printf (format, argp) + fprintf (fp, format, argp) + sprintf (str, format, argp) + eprintf (format, argp) + ch = putc (ch, fp) EOF + ch = putchar (ch) EOF + puts (str) + word = putw (word, fp) EOF + qsort (array, len, isize, compar) + charp = realloc (buf, newsize) NULL + rewind (fp) EOF + charp = rindex (str, ch) + nscan = scanf (format, argp) EOF EOF + nscan = fscanf (fp, format, argp) EOF EOF + nscan = sscanf (str, format, argp) EOF EOF + setbuf (fp, buf) + setbuffer (fp, buf, size) + setlinebuf (fp) + double = sin (x) + double = sqrt (x) + charp = strcat (s1, s2) + charp = strcmp (s1, s2) + charp = strcpy (s1, s2) + int = strlen (str) + charp = strncat (s1, s2, n) + charp = strncmp (s1, s2, n) + charp = strncpy (s1, s2, n) + stat = system (cmd) + ch = ungetc (ch, fp) EOF + + + +2. System Calls + +All output parameters are shown as "&name" regardless of whether the actual +parameter is a pointer. If no ERR or EOF type is shown it is inapplicable to +the procedure. The error type "*" denotes an error action which will lead to +error recovery if not caught by calling the procedure inside an "iferr". In +general, error actions are permitted only where errors are not expected and +where we suspect that the programmer would ignore an error return code if one +were used. Fatal errors cannot be caught but "cannot happen". + + + syntax err eof + + bool = c_access (fname, mode, type) * + longsec = c_clktime (reftime) + c_close (fd) * + charp = c_cnvdate (clktime, &outstr, maxch) + charp = c_cnvtime (clktime, &outstr, maxch) + longmsec = c_cputime (reftime) + c_delete (fname) ERR + nchars = c_envfind (var, &outstr, maxch) 0 + nchars = c_envgets (var, &outstr, maxch) 0 + bool = c_envgetb (var) no=0 + ival = c_envgeti (var) * + c_envputs (var, value) * + c_envlist (fd, prefix, show_redefs) * + c_envmark (&envp) + nredefs = c_envfree (envp) + nscan = c_envscan (input_source) * + c_error (errcode, errmsg) * + c_erract (action) * + errcode = c_errget (&outstr, maxch) + c_fchdir (newdir) ERR + ch = c_filbuf (fp) EOF EOF + c_finfo (fname, fi) ERR + ch = c_flsbuf (ch, fp) EOF + c_flush (fd) * + nchars = c_fmapfn (vfn, &osfn, maxch) 0 + stat = c_fmkdir (newdir) ERR + nchars = c_fnldir (vfn, &ldir, maxch) + nchars = c_fnroot (vfn, &root, maxch) + nchars = c_fnextn (vfn, &extn, maxch) + nchars = c_fpath (vfn, &osfn, maxch) 0 + fd = c_fredir (fd, fname, mode, type) ERR + c_fseti (fd, param, value) * + ival = c_fstati (fd, param) * + int = c_getpid () + c_getuid (&outstr, maxch) * + os_chan = c_kimapchan (ki_chan, nodename, maxch) + token = c_lexnum (str, &toklen) + nchars = c_mktemp (root, &temp_filename, maxch) 0 + long = c_note (fd) * + fd = c_open (fname, mode, type) ERR + exit_stat = c_oscmd (cmd, infile, outfile, errfile) * + c_prchdir (pid, newdir) ERR + exit_stat = c_prcldpr (job) * + c_prclose (pid) * + bool = c_prdone (job) * + c_prenvset (pid, envvar, valuestr) ERR + c_prkill (job) ERR + pid = c_propdpr (process, bkgfile) NULL + pid = c_propen (process, &in, &out) NULL + c_prredir (pid, stream, new_fd) ERR + c_prsignal (pid, signal) ERR + nbytes = c_read (fd, &buf, maxbytes) * EOF + c_rename (old_fname, new_fname) ERR + charp = c_salloc (nbytes) fatal + c_smark (&sp) fatal + c_sfree (sp) fatal + bool = c_stkcmp (p1, p2) * + c_seek (fd, offset) ERR + xcharp = c_sppstr (xstr) + cstr = c_strpak (sppstr, &cstr, maxch) + xcharp = c_strupk (str, &xoutstr, maxch) + c_tsleep (nseconds) + tty(int) = c_ttyodes (ttyname) ERR + c_ttycdes (tty) * + c_ttyseti (tty, param, value) * + ival = c_ttystati (tty, param) * + bool = c_ttygetb (tty, cap) no=0 + ival = c_ttygeti (tty, cap) 0 + fval = c_ttygetr (tty, cap) 0. + nchars = c_ttygets (tty, cap, &outstr, maxch) 0 + c_ttyputs (fd, tty, cap, afflncnt) ERR + c_ttyctrl (fd, tty, cap, afflncnt) ERR + c_ttyclear (fd, tty) * + c_ttyclearln (fd, tty) * + c_ttygoto (fd, tty, col, line) * + c_ttyinit (fd, tty) * + c_ttyputline (fd, tty, line, map_cc) * + c_ttyso (fd, tty, onoff) * + c_ungetc (fd, ch) ERR + c_ungetline (fd, str) ERR + c_vfnbrk (vfn, root, extn) + nbytes = c_write (fd, buf, nbytes) * + c_xwhen (vex, new_handler, old_handler) * + c_xgmes (oscode, oserrmsg, maxch) diff --git a/sys/libc/atof.c b/sys/libc/atof.c new file mode 100644 index 00000000..df0ec7d9 --- /dev/null +++ b/sys/libc/atof.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#define import_ctype +#include + + +/* ATOF -- Ascii to double floating. Convert any legal floating point number +** into a binary double precision floating value. +*/ +double +atof (char *str) +{ + XINT ip = 1; + XDOUBLE dval; + + if (CTOD (c_sppstr(str), &ip, &dval) == 0) + return ( (double) 0); + else + return ( (double) dval); +} diff --git a/sys/libc/atoi.c b/sys/libc/atoi.c new file mode 100644 index 00000000..6df13153 --- /dev/null +++ b/sys/libc/atoi.c @@ -0,0 +1,48 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_ctype +#include + + +/* ATOI -- Ascii to integer. Convert a simple integer in decimal radix to +** a binary integer value. +*/ +int +atoi (char *str) +{ + register char *ip = str; + register int ch, ival; + int neg; + + + if (*str == EOS) + return (0); + + /* Skip leading whitespace. */ + while (isspace (*ip)) + ip++; + + /* Check for indefinite. */ + if ((ch = *ip) == 'I') + if (strncmp (ip, "INDEF", 5) == 0) + if (! (isalnum (ch = *(ip+5)) || ch == '_')) + return (INDEFI); + + /* Check for leading + or - sign. */ + neg = 0; + if (ch == '-') { + neg++; + ip++; + } else if (ch == '+') + ip++; + + /* Accumulate sequence of digits. */ + ival = 0; + while (isdigit (ch = *ip++)) + ival = ival * 10 + tointeg(ch); + + return (neg ? -ival : ival); +} diff --git a/sys/libc/atol.c b/sys/libc/atol.c new file mode 100644 index 00000000..f5780583 --- /dev/null +++ b/sys/libc/atol.c @@ -0,0 +1,49 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_ctype +#include + + +/* ATOL -- Ascii to long integer. Convert a simple integer in decimal radix to +** a binary long integer value. +*/ +long +atol (char *str) +{ + register char *ip = str; + register int ch; + register long lval; + int neg; + + + if (*str == EOS) + return (0); + + /* Skip leading whitespace. */ + while (isspace (*ip)) + ip++; + + /* Check for indefinite. */ + if ((ch = *--ip) == 'I') + if (strncmp (ip, "INDEF", 5) == 0) + if (! (isalnum (ch = *(ip+5)) || ch == '_')) + return (INDEFL); + + /* Check for leading + or - sign. */ + neg = 0; + if (ch == '-') { + neg++; + ip++; + } else if (ch == '+') + ip++; + + /* Accumulate sequence of digits. */ + lval = 0; + while (isdigit (ch = *ip++)) + lval = lval * 10 + tointeg(ch); + + return (neg ? -lval : lval); +} diff --git a/sys/libc/caccess.c b/sys/libc/caccess.c new file mode 100644 index 00000000..13b6f52e --- /dev/null +++ b/sys/libc/caccess.c @@ -0,0 +1,22 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_ACCESS -- FIO file access. +*/ +int +c_access ( + char *fname, /* name of file to be accessed */ + int mode, /* access mode */ + int type /* file type */ +) +{ + XINT x_mode = mode, x_type = type; + + return (ACCESS (c_sppstr(fname), &x_mode, &x_type)); +} diff --git a/sys/libc/calloc.c b/sys/libc/calloc.c new file mode 100644 index 00000000..f9a4f044 --- /dev/null +++ b/sys/libc/calloc.c @@ -0,0 +1,27 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* CALLOC -- Allocate memory for NELEM elements of size ELSIZE bytes per +** element. The space is initialized to all zeros. +*/ +char * +calloc ( + unsigned int nelems, + unsigned int elsize +) +{ + XINT nchars = (nelems*elsize + sizeof(XCHAR)-1) / sizeof(XCHAR); + XINT ptr, dtype = TY_CHAR; + + + iferr (CALLOC (&ptr, &nchars, &dtype)) + return (NULL); + else + return ((char *)&Memc[ptr]); +} diff --git a/sys/libc/callocate.c b/sys/libc/callocate.c new file mode 100644 index 00000000..303896c3 --- /dev/null +++ b/sys/libc/callocate.c @@ -0,0 +1,80 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_ALLOCATE -- Allocate a device (and mount it, if necessary). +*/ +int +c_allocate ( + char *device /* device to be allocated */ +) +{ + int status; + + iferr (status = XALLOCATE (c_sppstr(device))) + return (ERR); + else + return (status); +} + + +/* C_DEALLOCATE -- Deallocate a device. +*/ +int +c_deallocate ( + char *device, /* device to be allocated */ + int rewind /* rewind flag, if magtape */ +) +{ + int status; + XINT x_rewind = rewind; + + iferr (status = (int) XDEALLOCATE (c_sppstr(device), &x_rewind)) + return (ERR); + else + return (status); +} + + +/* C_DEVSTATUS -- Print the current status of the named device. +*/ +void +c_devstatus ( + char *device, /* device name */ + int out /* output file */ +) +{ + XINT x_out = out; + + XDEVSTATUS (c_sppstr(device), &x_out); +} + + +/* C_DEVOWNER -- Determine if a device is allocated, and if so return +** the name of the owner. +*/ +int +c_devowner ( + char *device, /* device to be allocated */ + char *owner, /* receives owner name string */ + int maxch +) +{ + PKCHAR x_owner[SZ_FNAME+1]; + XINT x_maxch = SZ_FNAME; + int status; + + + iferr (status = (int) XDEVOWNER(c_sppstr(device), x_owner, &x_maxch)) { + owner[0] = EOS; + return (ERR); + } else { + c_strpak (x_owner, owner, maxch); + return (status); + } +} diff --git a/sys/libc/cclktime.c b/sys/libc/cclktime.c new file mode 100644 index 00000000..ca26e56e --- /dev/null +++ b/sys/libc/cclktime.c @@ -0,0 +1,35 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_CLKTIME -- Return the clock time in long integer seconds since Jan. 1, +** 1980, minus the reference argument (0 for absolute time). +*/ +long +c_clktime ( + long reftime /* reference time */ +) +{ + XLONG x_reftime = reftime; + + return (CLKTIME (&x_reftime)); +} + + +/* C_CPUTIME -- Return the cpu time consumed by the current process and all +** subprocesses, in long integer milliseconds, minus the reference time. +*/ +long +c_cputime ( + long reftime /* reference time */ +) +{ + XLONG x_reftime = reftime; + + return (CPUTIME (&x_reftime)); +} diff --git a/sys/libc/cclose.c b/sys/libc/cclose.c new file mode 100644 index 00000000..630f097d --- /dev/null +++ b/sys/libc/cclose.c @@ -0,0 +1,23 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_CLOSE -- FIO file close. +*/ +int +c_close ( + XINT fd /* FIO file descriptor */ +) +{ + XINT x_fd = fd; + + iferr (CLOSE (&x_fd)) + return (ERR); + else + return (OK); +} diff --git a/sys/libc/ccnvdate.c b/sys/libc/ccnvdate.c new file mode 100644 index 00000000..ee97169f --- /dev/null +++ b/sys/libc/ccnvdate.c @@ -0,0 +1,25 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_CNVDATE -- Convert long integer time as returned by CLKTIME into a short +** format date string. +*/ +char * +c_cnvdate ( + long clktime, /* seconds since jan.1,1980 */ + char *outstr, /* encoded time string */ + int maxch +) +{ + XCHAR buf[SZ_LINE]; + XINT x_maxch = SZ_LINE; + + CNVDATE (&clktime, buf, &x_maxch); + return (c_strpak (buf, outstr, maxch)); +} diff --git a/sys/libc/ccnvtime.c b/sys/libc/ccnvtime.c new file mode 100644 index 00000000..4923907c --- /dev/null +++ b/sys/libc/ccnvtime.c @@ -0,0 +1,25 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_CNVTIME -- Convert long integer time as returned by CLKTIME into a long +** format date string. +*/ +char * +c_cnvtime ( + long clktime, /* seconds since jan.1,1980 */ + char *outstr, /* encoded time string */ + int maxch +) +{ + XCHAR buf[SZ_LINE]; + XINT x_maxch = SZ_LINE; + + CNVTIME (&clktime, buf, &x_maxch); + return (c_strpak (buf, outstr, maxch)); +} diff --git a/sys/libc/cdelete.c b/sys/libc/cdelete.c new file mode 100644 index 00000000..14d97926 --- /dev/null +++ b/sys/libc/cdelete.c @@ -0,0 +1,20 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + +/* C_DELETE -- FIO delete file. +*/ +int +c_delete ( + char *fname /* name of file to be opened */ +) +{ + iferr (DELETE (c_sppstr(fname))) + return (ERR); + else + return (OK); +} diff --git a/sys/libc/cenvget.c b/sys/libc/cenvget.c new file mode 100644 index 00000000..2c812226 --- /dev/null +++ b/sys/libc/cenvget.c @@ -0,0 +1,143 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* +** ENVGET[SBI] -- Assorted routines for fetching the values of environment +** variables. +** ENVPUTS -- Set or redefine the value of an environment variable. +** ENVRESET -- Reset (overwrite) the value of an environment variable. +*/ + +#define SZ_VALUESTR SZ_COMMAND + +static XCHAR valuestr[SZ_VALUESTR+1]; +static XINT len_valuestr = SZ_VALUESTR; + + +/* ENVGET -- (Near) emulation of the UNIX getenv procedure. This is a handy +** routine for looking up environment variables in C programs. The value is +** fetched into an internal static array and a pointer to this array is returned +** as the function value, else NULL if the environment variable is not found. +** The caller is responsible for using the value string before it is overwritten +** by the next call. +*/ +char * +envget ( + char *var /* environment variable name */ +) +{ + if (ENVFIND (c_sppstr(var), valuestr, &len_valuestr) < 0) + return (NULL); + else + return (c_strpak (valuestr, (char *)valuestr, len_valuestr+1)); +} + + +/* C_ENVGETS -- Fetch the string value of an environment variable into the +** output string. Return the strlen length of the output string as the +** function value. If the variable is not found and the process is being +** used interactively a query is generated. If no value is given in response +** to the query or the process is noninteractive and the variable is not +** found, zero is returned. +*/ +int +c_envgets ( + char *var, /* name of variable to be fetched */ + char *outstr, /* output string */ + int maxch /* length including EOS */ +) +{ + register int nchars; + + if ((nchars = ENVGETS (c_sppstr(var), valuestr, &len_valuestr)) < 0) + return (nchars); + else { + c_strpak (valuestr, outstr, maxch); + return (nchars > maxch ? maxch : nchars); + } +} + + +/* C_ENVFIND -- Just like ENVGETS, except that a query will not be generated +** even if working interactively. +*/ +int +c_envfind ( + char *var, /* name of variable to be fetched */ + char *outstr, /* output string */ + int maxch /* length including EOS */ +) +{ + register int nchars; + + if ((nchars = ENVFIND (c_sppstr(var), valuestr, &len_valuestr)) < 0) + return (nchars); + else { + c_strpak (valuestr, outstr, maxch); + return (nchars > maxch ? maxch : nchars); + } +} + + +/* C_ENVGETB -- Return the boolean value of an environment variable. An error +** action is taken if the variable is not found or the value string cannot +** be interpreted as a boolean value. +*/ +int +c_envgetb ( + char *var /* name of variable to be fetched */ +) +{ + return ((int) BTOI ((XINT) ENVGETB (c_sppstr(var)))); +} + + +/* C_ENVGETI -- Return the integer value of an environment variable. An error +** action is taken if the variable is not found or the value string cannot +** be interpreted as an integer value. +*/ +int +c_envgeti ( + char *var /* name of variable to be fetched */ +) +{ + return ((int) ENVGETI (c_sppstr(var))); +} + + +/* C_ENVPUTS -- Set or redefine the value of an environment variable. If the +** variable is not defined a new entry is created. If the variable is already +** defined but has a different value it is redefined, with the new definition +** having precedence over the former (redefinitions can be undone; see envmark +** and envfree). If the variable is already defined and the new definition +** has the same value, it is ignored. +** +** Arguments: set var = value +*/ +void +c_envputs ( + char *var, /* name of variable to be set */ + char *value /* value string */ +) +{ + ENVPUTS (c_sppstr(var), c_strupk (value, valuestr, SZ_VALUESTR)); +} + + +/* C_ENVRESET -- Reset (overwrite) the value of an environment variable. +** If the variable is not defined a new entry is created. +*/ +void +c_envreset ( + char *var, /* name of variable to be set */ + char *value /* value string */ +) +{ + ENVRESET (c_sppstr(var), c_strupk (value, valuestr, SZ_VALUESTR)); +} diff --git a/sys/libc/cenvlist.c b/sys/libc/cenvlist.c new file mode 100644 index 00000000..1616a4d5 --- /dev/null +++ b/sys/libc/cenvlist.c @@ -0,0 +1,32 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_ENVLIST -- List the names and values of all environment variables on the +** output file. Variables are listed in the reverse of the order in which +** they were defined. If a variable is redefined all definitions or only the +** most recent definition may be listed. Each definition appears on a separate +** line in the following format: +** +** prefix var="value" +** +** where "prefix" is the prefix string supplied as an argument, "var" is the +** name of the variable, and "value" is the value string. +*/ +void +c_envlist ( + XINT fd, /* output file */ + char *prefix, /* prefix string, e.g. "set " */ + int show_redefs /* 0=hide redefs, 1=show redefs */ +) +{ + XINT x_fd = fd, + x_show_redefs = show_redefs; + + ENVLIST (&x_fd, c_sppstr(prefix), &x_show_redefs); +} diff --git a/sys/libc/cenvmark.c b/sys/libc/cenvmark.c new file mode 100644 index 00000000..14963844 --- /dev/null +++ b/sys/libc/cenvmark.c @@ -0,0 +1,54 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* ENVMARK -- Mark the position of the "stack pointer" of the environment +** list. A subsequent call to ENVFREE will unset all set environment +** operations since the corresponding mark. +*/ +void +c_envmark ( + XINT *envp /* storage for saved stack pointer */ +) +{ + ENVMARK (envp); +} + + +/* ENVFREE -- Free or unset all environment variables set since the matching +** call to ENVMARK. The number of redefined variables uncovered by the free +** operation is returned as the function value. +*/ +int +c_envfree ( + int envp, /* marker returned by envmark */ + int userfcn /* epa of user function for redefs */ +) +{ + XINT x_envp = envp; + + return (ENVFREE (&x_envp, (XINT *)&userfcn)); +} + + +/* PRENVFREE -- Free or unset all environment variables set since the matching +** call to ENVMARK. The number of redefined variables uncovered by the free +** operation is returned as the function value. This call is equivalent to +** envfree except that it also updates the values of any uncovered redefinitions +** in the specified connected subprocesses. +*/ +int +c_prenvfree ( + int pid, /* process pid, or 0 for all subprocs */ + int envp /* marker returned by envmark */ +) +{ + XINT x_pid = pid, x_envp = envp; + + return (PRENVFREE (&x_pid, &x_envp)); +} diff --git a/sys/libc/cenvscan.c b/sys/libc/cenvscan.c new file mode 100644 index 00000000..5fef48e7 --- /dev/null +++ b/sys/libc/cenvscan.c @@ -0,0 +1,32 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_ENVSCAN -- High level command to parse and enter a SET declaration into +** the environment list, or to parse and enter a list of SET declarations from +** a text file. The single input string argument should be either a SET +** declaration, i.e., +** +** set var="value" (quotes optional) +** +** or an indirect reference to a text file containing SET declarations, e.g., +** +** @filename +** +** If a file is specified, only lines beginning with the keyword "set" will +** be decoded; all other lines are ignored. The number of SET declarations +** processed is returned as the function value. There is no fixed limit on +** the number of SET declarations for a process. +*/ +int +c_envscan ( + char *input_source +) +{ + return (ENVSCAN (c_sppstr(input_source))); +} diff --git a/sys/libc/cerract.c b/sys/libc/cerract.c new file mode 100644 index 00000000..a9c9cb2d --- /dev/null +++ b/sys/libc/cerract.c @@ -0,0 +1,21 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_ERRACT -- Take an error action. Typically called in an IFERR error +** handler to print a warning message or initiate error recovery after +** application specific cleanup actions have been taken. The actions are +** defined in import_error +*/ +void +c_erract (int action) +{ + XINT x_action = action; + + ERRACT (&x_action); +} diff --git a/sys/libc/cerrcode.c b/sys/libc/cerrcode.c new file mode 100644 index 00000000..305ab39d --- /dev/null +++ b/sys/libc/cerrcode.c @@ -0,0 +1,15 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + +/* C_ERRCODE -- Get the error code of the most recent error. +*/ +int +c_errcode ( void ) +{ + return (ERRCODE()); +} diff --git a/sys/libc/cerrget.c b/sys/libc/cerrget.c new file mode 100644 index 00000000..a62a2f67 --- /dev/null +++ b/sys/libc/cerrget.c @@ -0,0 +1,27 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_ERRGET -- Get the error code and error message string of the most +** recent error. +*/ +int +c_errget ( + char *outstr, /* error message string */ + int maxch /* max chars out, incl EOS */ +) +{ + XCHAR buf[SZ_LINE+1]; + XINT szbuf = SZ_LINE; + int errcode; + + errcode = (int) ERRGET (buf, &szbuf); + c_strpak (buf, outstr, maxch); + + return (errcode); +} diff --git a/sys/libc/cerror.c b/sys/libc/cerror.c new file mode 100644 index 00000000..214d54a8 --- /dev/null +++ b/sys/libc/cerror.c @@ -0,0 +1,20 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_ERROR -- Post an error. +*/ +void +c_error ( + int errcode, /* error code */ + char *errmsg /* error message */ +) +{ + XINT x_errcode = errcode; + ERROR (&x_errcode, c_sppstr(errmsg)); +} diff --git a/sys/libc/cfchdir.c b/sys/libc/cfchdir.c new file mode 100644 index 00000000..2dc708da --- /dev/null +++ b/sys/libc/cfchdir.c @@ -0,0 +1,19 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_FCHDIR -- Change directory. +*/ +int +c_fchdir (char *newdir) +{ + iferr (FCHDIR (c_sppstr (newdir))) + return (ERR); + else + return (OK); +} diff --git a/sys/libc/cfilbuf.c b/sys/libc/cfilbuf.c new file mode 100644 index 00000000..e37aec75 --- /dev/null +++ b/sys/libc/cfilbuf.c @@ -0,0 +1,36 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#define import_stdio +#include + + +/* C_FILBUF -- Fill the FIO file buffer. Called by the GETC macro to fill +** the file buffer when the end of the buffer is reached. The function +** value is either the first char in the refilled buffer or EOF. If the +** file is connected to a child process the filter PRFILBUF is called to +** handle the XMIT and XFER requests. +*/ +int +c_filbuf (FILE *fp) +{ + register int nchars; + XINT x_fd = fileno(fp); + XINT (*fillbuffer)(); + XINT PRFILBUF(), FILBUF(); + + + fillbuffer = ((fp->_fflags & _FIPC) ? PRFILBUF : FILBUF); + + iferr (nchars = (int) (*fillbuffer)(&x_fd)) { + fp->_fflags |= _FERR; + return (EOF); + } else if (nchars == XEOF) { + fp->_fflags |= _FEOF; + return (EOF); + } else + return (Memc[fp->_iop++] & 0377); +} diff --git a/sys/libc/cfinfo.c b/sys/libc/cfinfo.c new file mode 100644 index 00000000..7e69e5e0 --- /dev/null +++ b/sys/libc/cfinfo.c @@ -0,0 +1,30 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_xnames +#define import_finfo +#define import_libc +#include + + +/* C_FINFO -- FIO get directory info for named file. +*/ +int +c_finfo ( + char *fname, /* name of file to be opened */ + struct _finfo *fi /* finfo structure (output) */ +) +{ + register int status; + + iferr (status = (int) FINFO (c_sppstr(fname), (XLONG *)fi)) { + status = ERR; + } else if (status != XERR) { + c_strpak ((XCHAR *)fi->fi_owner, fi->fi_owner, SZ_OWNERSTR); + status = OK; + } else + status = ERR; + + return (status); +} diff --git a/sys/libc/cflsbuf.c b/sys/libc/cflsbuf.c new file mode 100644 index 00000000..9547b0c2 --- /dev/null +++ b/sys/libc/cflsbuf.c @@ -0,0 +1,43 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#define import_stdio +#include + + +/* C_FLSBUF -- Flush the FIO file buffer. Called by the PUTC macro to flush +** the file buffer when it fills. The function value returned is either the +** first char written to the buffer (passed as an argument) or EOF in the +** event of an error. +*/ +int +c_flsbuf ( + unsigned int ch, /* char which caused the fault */ + FILE *fp /* output file */ +) +{ + register int buf_not_full; + XINT fd = fileno(fp); + XINT nreserve = 1; + + + /* If we were called due to flush on newline and there is space in + * the buffer, put the ch in the buffer before flushing. + */ + buf_not_full = (fp->_iop < fp->_otop); + if (buf_not_full) + Memc[fp->_iop++] = (unsigned)ch; + + iferr (FLSBUF (&fd, &nreserve)) { + fp->_fflags |= _FERR; + return (EOF); + } + + if (!buf_not_full) + Memc[fp->_iop++] = (unsigned)ch; + + return (ch); +} diff --git a/sys/libc/cflush.c b/sys/libc/cflush.c new file mode 100644 index 00000000..7a7a029a --- /dev/null +++ b/sys/libc/cflush.c @@ -0,0 +1,20 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_FLUSH -- FIO file flush. +*/ +void +c_flush ( + XINT fd /* FIO file descriptor */ +) +{ + XINT x_fd = fd; + + FLUSH (&x_fd); +} diff --git a/sys/libc/cfmapfn.c b/sys/libc/cfmapfn.c new file mode 100644 index 00000000..0d4181a0 --- /dev/null +++ b/sys/libc/cfmapfn.c @@ -0,0 +1,36 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_FMAPFN -- Map a VFN (virtual filename) into an OSFN (host system filename). +*/ +int +c_fmapfn ( + char *vfn, /* virtual filename */ + char *osfn, /* OS filename */ + int maxch +) +{ + XCHAR x_osfn[SZ_PATHNAME+1]; + XINT sz_path = SZ_PATHNAME; + + + /* The OSFN is returned as a packed string in the XCHAR array x_osfn. + * An intermediate buffer is used to avoid char->xchar alignment + * problems of upward pointer coercion on some machines. + */ + if (maxch) + iferr (FMAPFN (c_sppstr(vfn), x_osfn, &sz_path)) + osfn[0] = EOS; + else { + (void) strncpy (osfn, (char *)x_osfn, maxch); + osfn[maxch-1] = EOS; + } + + return (strlen (osfn)); +} diff --git a/sys/libc/cfmkdir.c b/sys/libc/cfmkdir.c new file mode 100644 index 00000000..9888461d --- /dev/null +++ b/sys/libc/cfmkdir.c @@ -0,0 +1,20 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_FMKDIR -- FIO procedure to create a new directory. +*/ +int +c_fmkdir (newdir) +char *newdir; /* name of the new directory */ +{ + iferr (FMKDIR (c_sppstr(newdir))) + return (ERR); + else + return (OK); +} diff --git a/sys/libc/cfnextn.c b/sys/libc/cfnextn.c new file mode 100644 index 00000000..9917b89f --- /dev/null +++ b/sys/libc/cfnextn.c @@ -0,0 +1,26 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_FNEXTN -- Extract the filename extension substring from a filename. +*/ +int +c_fnextn ( + char *vfn, /* filename */ + char *extn, /* filename extension (output) */ + int maxch /* max chars out */ +) +{ + XCHAR spp_extn[SZ_FNAME+1]; + XINT x_maxch = SZ_FNAME, nchars; + + nchars = (int) FNEXTN (c_sppstr(vfn), spp_extn, &x_maxch); + c_strpak (spp_extn, extn, maxch); + + return (nchars); +} diff --git a/sys/libc/cfnldir.c b/sys/libc/cfnldir.c new file mode 100644 index 00000000..9b8b469c --- /dev/null +++ b/sys/libc/cfnldir.c @@ -0,0 +1,26 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_FNLDIR -- Extract the directory prefix substring from a filename. +*/ +int +c_fnldir ( + char *vfn, /* filename */ + char *ldir, /* directory prefix (output) */ + int maxch /* max chars out */ +) +{ + XCHAR spp_ldir[SZ_FNAME+1]; + XINT x_maxch = SZ_FNAME, nchars; + + nchars = FNLDIR (c_sppstr(vfn), spp_ldir, &x_maxch); + c_strpak (spp_ldir, ldir, maxch); + + return (nchars); +} diff --git a/sys/libc/cfnroot.c b/sys/libc/cfnroot.c new file mode 100644 index 00000000..78ac72bb --- /dev/null +++ b/sys/libc/cfnroot.c @@ -0,0 +1,25 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + +/* C_FNROOT -- Extract the root filename substring from a filename. +*/ +int +c_fnroot ( + char *vfn, /* filename */ + char *root, /* root filename (output) */ + int maxch /* max chars out */ +) +{ + XCHAR spp_root[SZ_FNAME+1]; + XINT x_maxch = SZ_FNAME, nchars; + + nchars = FNROOT (c_sppstr(vfn), spp_root, &x_maxch); + c_strpak (spp_root, root, maxch); + + return (nchars); +} diff --git a/sys/libc/cfpath.c b/sys/libc/cfpath.c new file mode 100644 index 00000000..b7820012 --- /dev/null +++ b/sys/libc/cfpath.c @@ -0,0 +1,34 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_FPATHNAME -- Map a VFN (virtual filename) into a pathname (filename +** specification which is independent of the current directory). +*/ +int +c_fpathname ( + char *vfn, /* virtual filename */ + char *osfn, /* OS filename */ + int maxch +) +{ + XCHAR x_osfn[SZ_PATHNAME+1]; + XINT x_maxch = SZ_PATHNAME; + + + /* The OSFN is returned as a packed string in the XCHAR array x_osfn. + * An intermediate buffer is used to avoid char->xchar alignment + * problems of upward pointer coercion on some machines. + */ + iferr (FPATHNAME (c_sppstr(vfn), x_osfn, &x_maxch)) + osfn[0] = EOS; + else + c_strpak (x_osfn, osfn, maxch); + + return (strlen (osfn)); +} diff --git a/sys/libc/cfredir.c b/sys/libc/cfredir.c new file mode 100644 index 00000000..2a4ae5b1 --- /dev/null +++ b/sys/libc/cfredir.c @@ -0,0 +1,46 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#define import_stdio +#include + + +/* C_FREDIR -- FIO redirect an open i/o stream to a named file. Most commonly +** used to redirect one of the standard i/o streams to a file. The named file +** need not be of the same type as the old stream. +*/ +int +c_fredir ( + XINT fd, /* stream to be redirected */ + char *fname, /* name of file to be opened */ + int mode, /* access mode */ + int type /* file type */ +) +{ + XINT x_fd = fd, x_type = type, x_mode = mode; + + iferr (FREDIR (&x_fd, c_sppstr(fname), &x_mode, &x_type)) + return (ERR); + else + return (fd); +} + + +/* C_FREDIRO -- FIO redirect an open i/o stream to another open stream. +*/ +int +c_frediro ( + XINT fd, /* stream to be redirected */ + XINT newfd /* where it is to be redirected */ +) +{ + XINT x_fd = fd, x_newfd = newfd; + + iferr (FREDIRO (&x_fd, &x_newfd)) + return (ERR); + else + return (fd); +} diff --git a/sys/libc/cfseti.c b/sys/libc/cfseti.c new file mode 100644 index 00000000..7d496c33 --- /dev/null +++ b/sys/libc/cfseti.c @@ -0,0 +1,22 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_FSETI -- FIO set integer file parameter. +*/ +void +c_fseti ( + XINT fd, /* FIO file descriptor */ + int param, /* param to be set */ + int value /* new value */ +) +{ + XINT x_fd = fd, x_param = param, x_value = value; + + FSETI (&x_fd, &x_param, &x_value); +} diff --git a/sys/libc/cfstati.c b/sys/libc/cfstati.c new file mode 100644 index 00000000..aacf670a --- /dev/null +++ b/sys/libc/cfstati.c @@ -0,0 +1,21 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_FSTATI -- FIO get integer file parameter. +*/ +int +c_fstati ( + XINT fd, /* FIO file descriptor */ + int param /* param to be queried */ +) +{ + XINT x_fd = fd, x_param = param; + + return (FSTATI (&x_fd, &x_param)); +} diff --git a/sys/libc/cgetpid.c b/sys/libc/cgetpid.c new file mode 100644 index 00000000..69ad6133 --- /dev/null +++ b/sys/libc/cgetpid.c @@ -0,0 +1,15 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_libc +#define import_xnames +#include + + +/* C_GETPID -- Get the process id. +*/ +int +c_getpid ( void ) +{ + return ((int) GETPID()); +} diff --git a/sys/libc/cgetuid.c b/sys/libc/cgetuid.c new file mode 100644 index 00000000..cb86f4a3 --- /dev/null +++ b/sys/libc/cgetuid.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_GETUID -- Get the user identification string (user name). +*/ +char * +c_getuid ( + char *outstr, /* user name, C string */ + int maxch /* max chars out, incl EOS */ +) +{ + XCHAR spp_uid[SZ_FNAME+1]; + XINT x_maxch = SZ_FNAME; + + + GETUID (spp_uid, &x_maxch); + return (c_strpak (spp_uid, outstr, maxch)); +} diff --git a/sys/libc/cgflush.c b/sys/libc/cgflush.c new file mode 100644 index 00000000..8d5fe072 --- /dev/null +++ b/sys/libc/cgflush.c @@ -0,0 +1,20 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_GFLUSH -- Flush any buffered graphics output. +*/ +void +c_gflush ( + int stream /* graphics stream */ +) +{ + XINT x_stream = stream; + + GTR_GFLUSH (&x_stream); +} diff --git a/sys/libc/cimaccess.c b/sys/libc/cimaccess.c new file mode 100644 index 00000000..17d2e874 --- /dev/null +++ b/sys/libc/cimaccess.c @@ -0,0 +1,28 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_IMACCESS -- IMIO test if image can be accessed (exists). 1 is returned +** if the image exists and is unique, 0 if the image does not exist, and ERR +** if the image name ambiguous and multiple images exist matching that name. +*/ +int +c_imaccess ( + char *imname, /* name of image to be accessed */ + int mode /* access mode */ +) +{ + int status; + XINT x_mode = mode; + + + iferr (status = (int) IMACCESS (c_sppstr(imname), &x_mode)) + return (ERR); + else + return (status); +} diff --git a/sys/libc/cimdrcur.c b/sys/libc/cimdrcur.c new file mode 100644 index 00000000..1ac9f85b --- /dev/null +++ b/sys/libc/cimdrcur.c @@ -0,0 +1,39 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_IMDRCUR -- Read the logical image cursor (temporary routine, will be +** phased out in a later release). +*/ +int +c_imdrcur ( + char *device, /* logical device name or "stdimage" */ + float *x, /* cursor X coordinate (out) */ + float *y, /* cursor Y coordinate (out) */ + int *wcs, /* wcs of coords (out, = frame*100+d_wcs) */ + int *key, /* keystroke which triggered read (out) */ + char *strval, /* string value, if key=':' */ + int maxch, /* max chars out */ + int d_wcs, /* 0 for frame coords, 1 for image coords */ + int pause /* true to pause for key to terminate read */ +) +{ + PKCHAR x_strval[SZ_LINE+1]; + XINT x_maxch = maxch, x_d_wcs = d_wcs, x_pause = pause; + XINT x_wcs, x_key; + + + if (IMDRCUR (c_sppstr(device), x, y, &x_wcs, &x_key, x_strval, &x_maxch, + &x_d_wcs, &x_pause) >= 0) + c_strpak (x_strval, strval, maxch); + + *wcs = x_wcs; + *key = x_key; + + return (*key = (*key == XEOF) ? EOF : *key); +} diff --git a/sys/libc/ckimapc.c b/sys/libc/ckimapc.c new file mode 100644 index 00000000..6653dd29 --- /dev/null +++ b/sys/libc/ckimapc.c @@ -0,0 +1,28 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_KIMAPCHAN -- Map a KI channel number into the corresponding OS channel +** number or pid and node name. +*/ +int +c_kimapchan ( + int chan, /* KI channel number */ + char *nodename, /* receives server node name */ + int maxch /* maxch chars out */ +) +{ + XCHAR x_nodename[SZ_FNAME+1]; + XINT ki_chan = chan, x_maxch = SZ_FNAME; + int os_chan; + + os_chan = (int) KI_MAPCHAN (&ki_chan, x_nodename, &x_maxch); + c_strpak (x_nodename, nodename, SZ_FNAME); + + return (os_chan); +} diff --git a/sys/libc/clexnum.c b/sys/libc/clexnum.c new file mode 100644 index 00000000..6e5091bc --- /dev/null +++ b/sys/libc/clexnum.c @@ -0,0 +1,54 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_ctype +#define import_lexnum +#define import_xnames +#include + + +/* LEXNUM -- Lexically analyze a string to determine if it is a legal IRAF +** style number. Returns one of the following tokens (lexnum.h): +** +** LEX_OCTAL octal number (e.g. B suffix) +** LEX_HEX hex number (e.g. X suffix) +** LEX_DECIMAL decimal number +** LEX_REAL real number (incl sexagesimal) +** LEX_NONNUM nonnumeric +** +** A numeric token is returned if any (prefix) portion of the field is +** numeric. The total number of numeric characters is also returned so +** that the application may verify that the entire field was numeric, +** if desired. +*/ +int +c_lexnum ( + char *str, /* input string */ + int *toklen /* nchars in token */ +) +{ + register char *ip; + register XCHAR *op, ch, ndigits; + PKCHAR numbuf[SZ_FNAME]; + XINT ip_start = 1, x_toklen = *toklen; + int status; + + + /* Convert number to XCHAR for lexnum. In the process check to see + * if we have a simple decimal integer constant to save a scan. + */ + for (ip=str, op=numbuf, ndigits=0; (*op++ = ch = *ip++); ) + if (isdigit (ch)) + ndigits++; + + if (ndigits == (ip - str - 1)) { + *toklen = ndigits; + return (LEX_DECIMAL); + } else { + status = LEXNUM (numbuf, &ip_start, &x_toklen); + *toklen = (int) x_toklen; + return (status); + } +} diff --git a/sys/libc/cmktemp.c b/sys/libc/cmktemp.c new file mode 100644 index 00000000..cdc9e5a7 --- /dev/null +++ b/sys/libc/cmktemp.c @@ -0,0 +1,27 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_MKTEMP -- FIO make temporary (unique) filename. +*/ +int +c_mktemp ( + char *root, /* root filename */ + char *temp_filename, /* generated filename */ + int maxch /* max chars in output filename */ +) +{ + XCHAR temp[SZ_FNAME+1]; + XINT sz_temp = SZ_FNAME; + + + iferr (MKTEMP (c_sppstr(root), temp, &sz_temp)) + return (0); + else + return (strlen (c_strpak (temp, temp_filename, maxch))); +} diff --git a/sys/libc/cndopen.c b/sys/libc/cndopen.c new file mode 100644 index 00000000..1a6920be --- /dev/null +++ b/sys/libc/cndopen.c @@ -0,0 +1,25 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_NDOPEN -- Network driver FIO file open. +*/ +int +c_ndopen ( + char *fname, /* name of file to be opened */ + int mode /* access mode */ +) +{ + int fd; + XINT x_mode = mode; + + iferr (fd = NDOPEN (c_sppstr(fname), &x_mode)) + return (ERR); + else + return (fd); +} diff --git a/sys/libc/cnote.c b/sys/libc/cnote.c new file mode 100644 index 00000000..c62a0b02 --- /dev/null +++ b/sys/libc/cnote.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#define import_fset +#include + + +/* C_NOTE -- FIO note file offset. If the actual file is a text file the +** seek offset is a magic number and is returned unchanged. If the actual +** file is a binary file the seek offset is returned as a zero-indexed byte +** offset. +*/ +long +c_note ( + XINT fd /* FIO file descriptor */ +) +{ + long xchar_offset; + XINT x_fd = fd; + + xchar_offset = (long) NOTE (&x_fd); + if (c_fstati (fd, F_TYPE) == BINARY_FILE) + return ((xchar_offset - 1) * sizeof(XCHAR)); + else + return (xchar_offset); +} diff --git a/sys/libc/copen.c b/sys/libc/copen.c new file mode 100644 index 00000000..144dc5d4 --- /dev/null +++ b/sys/libc/copen.c @@ -0,0 +1,26 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_OPEN -- FIO file open. +*/ +int +c_open ( + char *fname, /* name of file to be opened */ + int mode, /* access mode */ + int type /* file type */ +) +{ + int fd; + XINT x_mode = mode, x_type = type; + + iferr (fd = (int) OPEN (c_sppstr(fname), &x_mode, &x_type)) + return (ERR); + else + return (fd); +} diff --git a/sys/libc/coscmd.c b/sys/libc/coscmd.c new file mode 100644 index 00000000..d6185bfe --- /dev/null +++ b/sys/libc/coscmd.c @@ -0,0 +1,33 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_OSCMD -- Send a command to the host system. If the filename strings +** are nonnull the kernel will attempt to redirect the standard i/o streams +** to the indicated streams during execution of the command. OK is returned +** if execution is completes successfully, otherwise a positive integer error +** code is returned. +*/ +int +c_oscmd ( + char *cmd, /* command to be executed */ + char *infile, /* stdin file */ + char *outfile, /* stdout file */ + char *errfile /* stderr file */ +) +{ + XCHAR spp_infile[SZ_FNAME+1]; + XCHAR spp_outfile[SZ_FNAME+1]; + XCHAR spp_errfile[SZ_FNAME+1]; + + c_strupk (infile, spp_infile, SZ_FNAME); + c_strupk (outfile, spp_outfile, SZ_FNAME); + c_strupk (errfile, spp_errfile, SZ_FNAME); + + return (OSCMD (c_sppstr(cmd), spp_infile, spp_outfile, spp_errfile)); +} diff --git a/sys/libc/cpoll.c b/sys/libc/cpoll.c new file mode 100644 index 00000000..65f05274 --- /dev/null +++ b/sys/libc/cpoll.c @@ -0,0 +1,150 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_fpoll +#define import_xnames +#include + + +/* C_POLL -- LIBC binding to the FIO polling interface. +** +** fds = c_poll_open () # open a poll descriptor set +** npolls = c_poll (fds, nfds, timeout) # poll the set +** c_poll_close (fds) # free the poll descriptor set +** +** c_poll_zero (fds) # zero the poll array +** c_poll_set (fds, fd, type) # set fd to poll for type +** c_poll_clear (fds, fd, type) # unset type on fd poll +** y/n = c_poll_test (fds, fd, type) # test fd for type event +** c_poll_print (fds) # print the poll array +** N = c_poll_get_nfds (fds) # get size of descriptor set +*/ + + +/* C_POLL_OPEN -- Open a poll descriptor set. +*/ +XINT +c_poll_open ( void ) +{ + XINT fds; + + iferr ((fds = (XINT) POLL_OPEN ())) + return (NULL); + else + return (fds); +} + + +/* C_POLL -- Poll the descriptor set. +*/ +int +c_poll ( + XINT fds, /* descriptor set ptr */ + int nfds, /* no. descriptors */ + int timeout /* poll timeout */ +) +{ + XINT x_fds = fds, x_nfds = nfds, x_timeout = timeout; + + return ((int) POLL (&x_fds, &x_nfds, &x_timeout)); +} + + +/* C_POLL_CLOSE -- Close and free a poll descriptor set. +*/ +void +c_poll_close ( + XINT fds /* descriptor set ptr */ +) +{ + XINT x_fds = fds; + + POLL_CLOSE (&x_fds); +} + + +/* C_POLL_ZERO -- Zero the descriptor set. +*/ +void +c_poll_zero ( + XINT fds /* descriptor set ptr */ +) +{ + XINT x_fds = fds; + + POLL_ZERO (&x_fds); +} + + +/* C_POLL_SET -- Add a descriptor to the set, and/or modify the event type. +** The type may be a bitwise or of testable events. +*/ +void +c_poll_set ( + XINT fds, /* descriptor set ptr */ + XINT fd, /* no. descriptors */ + int type /* event type */ +) +{ + XINT x_fds = fds, x_fd = fd, x_type = type; + + POLL_SET (&x_fds, &x_fd, &x_type); +} + + +/* C_POLL_CLEAR -- Remove a descriptor or event type from the set. The type +** may be a bitwise or of testable events. If the event mask becomes NULL the +** descriptor is removed entirely from the set. +*/ +void +c_poll_clear ( + XINT fds, /* descriptor set ptr */ + XINT fd, /* no. descriptors */ + int type /* event type */ +) +{ + XINT x_fds = fds, x_fd = fd, x_type = type; + + POLL_CLEAR (&x_fds, &x_fd, &x_type); +} + + +/* C_POLL_TEST -- Test the descriptor for the given event type. +*/ +int +c_poll_test ( + XINT fds, /* descriptor set ptr */ + XINT fd, /* no. descriptors */ + int type /* event type */ +) +{ + XINT x_fds = fds, x_fd = fd, x_type = type; + + return ((int) POLL_TEST (&x_fds, &x_fd, &x_type)); +} + + +/* C_POLL_GET_NFDS -- Return the size of the descriptor set. +*/ +int +c_poll_get_nfds ( + XINT fds /* descriptor set ptr */ +) +{ + XINT x_fds = fds; + + return (POLL_GET_NFDS (&x_fds)); +} + + +/* C_POLL_PRINT -- Debug print utility. +*/ +void +c_poll_print (XINT fds) +{ + XINT x_fds = fds; + + POLL_PRINT (&x_fds); +} diff --git a/sys/libc/cprcon.c b/sys/libc/cprcon.c new file mode 100644 index 00000000..c0534a60 --- /dev/null +++ b/sys/libc/cprcon.c @@ -0,0 +1,198 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#define import_stdio +#define import_prstat +#include + + +/* CPRCON -- Connected subprocesses. A connected subprocess is an active filter +** which communicates with the parent process via an input stream and an output +** stream. A connected subprocess is logically equivalent to the user terminal. +** The set of useful operations thus far identified for connected subprocesses +** are open and close, read and write, and signal (interrupt). The read and +** write operations are provided by interfacing the IPC channels from the +** subprocess to FIO. The remaining operations are peculiar to connected +** subprocesses and are summarized below. +** +** pid = c_propen (process, in, out) +** stat = c_prclose (pid) +** stat = c_prstati (pid, param) +** c_prsignal (pid, signal) +** c_prredir (pid, stream, new_fd) +** c_prchdir (pid, newdir) +** c_prenvset (pid, envvar, valuestr) +** +** A connected subprocess must be opened either with c_propen or with the low +** level procedure PROPCPR (the latter does not require that the subprocess +** recognize the standard IPC protocol). An idle subprocess may be closed +** with c_prclose, which not only closes the process but releases important +** system resources. The c_prsignal procedure raises the X_INT (interrupt) +** exception in a subprocess, generally following receipt of a user interrupt +** by the parent process. Redirection of the child's standard i/o streams +** is provided by c_prredir. Finally, c_prchdir and c_prenvsets are used +** to update the current directory and environment in child processes. +*/ + + +/* C_PROPEN -- Open a connected subprocess, i.e., spawn the subprocess and +** connect the two IPC channels connecting the child and parent to FIO. +** The FIO streams may subsequently be opened for C style STDIO by calling +** FDOPEN, if desired. The C_PROPEN procedure sends the current environment +** and working directory to the child as part of process startup. The process +** id (PID) of the child process is returned as the function value. This +** magic integer value uniquely identifies the process to the system. +** +** N.B.: opening a child process leaves the child in the IRAF Main interpreter +** loop, with the child waiting for a command from the parent. A child process +** is capabable of performing an arbitrary number of "tasks". To get the child +** to run a task, the parent must write the name of the task to the OUT stream, +** then read from the IN stream, responding to all queries from the child until +** "bye" or "error" is received. +*/ +unsigned int +c_propen ( + char *process, /* filename of executable process */ + int *in, /* FD for reading from child */ + int *out /* FD for writing to child */ +) +{ + register unsigned int pid; + XINT x_in = *in, x_out = *out; + + iferr (pid = (unsigned int) PROPEN (c_sppstr(process), &x_in, &x_out)) + return (NULL); + else { + *in = (int) x_in; + *out = (int) x_out; + FDTOFP(*in)->_fflags |= _FIPC; + return (pid); + } +} + + +/* C_PRCLOSE -- Close a connected subprocess. The "bye" command is sent to +** the child, commanding it to shut down, and when the task terminates the +** exit status is returned as the function value. The C_PRCLOSE procedure +** must be called at process termination to free system resources. C_PRCLOSE +** is automatically called by the system if error recovery takes place in +** the parent process. Calling C_PRCLOSE is equivalent to individually +** closing the IN and OUT streams to the subprocess (which is what happens +** if system error recovery takes place). +*/ +int +c_prclose ( + unsigned int pid /* process id returned by C_PROPEN */ +) +{ + XINT x_pid = pid; + + return (PRCLOSE (&x_pid)); +} + + +/* C_PRSTATI -- Get status on a connected subprocess. See +** for a list of parameters. +*/ +int +c_prstati ( + int pid, /* process id of process */ + int param /* parameter for which value is ret */ +) +{ + XINT x_pid = pid, x_param = param; + + return (PRSTATI (&x_pid, &x_param)); +} + + +/* C_PRSIGNAL -- Send a signal, i.e., asynchronous interrupt, to a connected +** child process. Currently only the X_INT signal is implemented, and the +** second argument is not used. The value X_INT should nontheless be passed. +*/ +int +c_prsignal ( + unsigned pid, /* process id of process */ + int signal /* not used at present */ +) +{ + XINT x_pid = pid, x_signal = signal; + + iferr (PRSIGNAL (&x_pid, &x_signal)) + return (ERR); + else + return (OK); +} + + +/* C_PRREDIR -- Redirect one of the standard i/o streams of the child process. +** By default the child inherits the standard i/o streams of the parent at +** C_PROPEN time, i.e., the STDOUT of the child is connected to the STDOUT of +** the parent. If the parent's STDOUT is subsequently redirected, e.g., with +** C_FREDIR, the child's output will be redirected as well. More commonly +** one or more of the child's streams will be explicitly redirected with +** C_PRREDIR. Such redirection remains in effect for the life of the +** process, i.e., until process termination via C_PRCLOSE or until another +** call to C_PRREDIR. Note that often this is not what is desired, rather, +** one wishes to redirect a stream for the duration of a task running within +** the process. For this reason it is recommended that C_PRREDIR be called +** for each standard stream (it costs almost nothing) immediately prior to +** task execution. +** +** Example: +** fp = fopen ("tmp$spoolfile", "w"); +** if (c_prredir (pid, STDOUT, fileno(fp)) == ERR) +** ... +*/ +int +c_prredir ( + unsigned pid, /* process id of child */ + int stream, /* child's stream to be redirected */ + int new_fd /* FD of opened file in parent */ +) +{ + XINT x_pid = pid, x_stream = stream, x_new_fd = new_fd; + + iferr (PRREDIR (&x_pid, &x_stream, &x_new_fd)) + return (ERR); + else + return (OK); +} + + +/* C_PRCHDIR -- Change the current working directory of a child process. +** If pid=NULL all currently connected processes are updated. May only +** be called when the child process is idle. +*/ +int +c_prchdir ( + int pid, + char *newdir +) +{ + XINT x_pid = pid; + + return (PRCHDIR (&x_pid, c_sppstr (newdir))); +} + + +/* C_PRENVSET -- Transmit a set environment directive to the child process. +** If pid=NULL all currently connected processes are updated. May only +** be called when the child process is idle. +*/ +int +c_prenvset ( + int pid, + char *envvar, + char *value +) +{ + XCHAR spp_value[SZ_LINE]; + XINT x_pid = pid; + + c_strupk (value, spp_value, SZ_LINE); + return (PRENVSET (&x_pid, c_sppstr (envvar), spp_value)); +} diff --git a/sys/libc/cprdet.c b/sys/libc/cprdet.c new file mode 100644 index 00000000..92829723 --- /dev/null +++ b/sys/libc/cprdet.c @@ -0,0 +1,109 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* +** CPRDET -- Detached processes. A detached process is a process which runs +** asynchronously with and independently of the parent, generally without +** interprocess communication during execution. The primary example of a +** detached process in IRAF is the CL process spawned by an interactive CL +** to execute a command in the background. +** +** The parent communicates with the child by means of the "bkgfile", the name +** of which is passed by the system to the child during process startup. +** While the format and contents of the bkgfile are in general application +** dependent, the system default action is to open the bkgfile as a text file +** and read commands from it. The CL process does not make use of this +** default, but rather uses its own special format binary file to communicate +** the full runtime context of the parent to the child, partially emulating +** the UNIX fork. The system automatically deletes the bkgfile when the +** child process terminates. +** +** N.B.: The environment and cwd are not automatically passed to the child, +** as they are for a connected subprocess. The application must see to it +** that this information is passed in the bkgfile if needed by the child. +*/ + +/* C_PROPDPR -- Open a detached process. The named process is either spawned +** or queued for delayed execution (depending on the system and other factors). +** When the process eventually runs it reads the bkgfile passed by the parent +** to determine what to do. When the process terminates, either normally or +** abnormally, the system deletes the bkgfile. Deletion of the bkgfile signals +** process termination. +*/ +unsigned int +c_propdpr ( + char *process, /* filename of executable file */ + char *bkgfile, /* filename of bkgfile */ + char *bkgmsg /* control string for kernel */ +) +{ + unsigned job; + XCHAR spp_bkgfile[SZ_PATHNAME]; + XCHAR spp_bkgmsg[SZ_LINE]; + + + c_strupk (bkgfile, spp_bkgfile, SZ_PATHNAME); + c_strupk (bkgmsg, spp_bkgmsg, SZ_LINE); + iferr (job = PROPDPR (c_sppstr(process), spp_bkgfile, spp_bkgmsg)) + return (NULL); + else + return (job); +} + + +/* C_PRCLDPR -- Close a detached process. Wait (indefinitely) for process +** termination, then free all system resources allocated to the process. +** Should be called if a detached process terminated while the parent is +** still executing. The exit status of the child is returned as the function +** value; the value OK (0) indicates normal termination. A positive value +** is the error code of the error which caused abnormal process termination. +*/ +int +c_prcldpr ( + unsigned job /* job code from C_PROPDPR */ +) +{ + XINT x_job = job; + + return (PRCLDPR (&x_job)); +} + + +/* C_PRDONE -- Determine if a bkg job is still executing (function return NO) +** or has terminated (function return YES). +*/ +int +c_prdone ( + unsigned job /* job code from C_PROPDPR */ +) +{ + XINT x_job = job; + + return (PRDONE (&x_job)); +} + + +/* C_PRKILL -- Kill a bkg job. If the bkg job has begun execution it is +** killed without error recovery. If the bkg job is still sitting in a queue +** it is dequeued. C_PRKILL returns ERR for an illegal jobcode or if sufficient +** permission is not available to kill the job. C_PRCLDPR should subsequently +** be called to wait for process termination and free system resources. +*/ +int +c_prkill ( + unsigned job /* job code from C_PROPDPR */ +) +{ + XINT x_job = job; + + iferr (PRKILL (&x_job)) + return (ERR); + else + return (OK); +} diff --git a/sys/libc/cprintf.c b/sys/libc/cprintf.c new file mode 100644 index 00000000..dd317f69 --- /dev/null +++ b/sys/libc/cprintf.c @@ -0,0 +1,53 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_PRINTF -- Formatted print to STDOUT. +*/ +int +c_printf ( + char *format /* format string */ +) +{ + iferr (PRINTF (c_sppstr(format))) + return (ERR); + else + return (OK); +} + + +/* C_FPRINTF -- Formatted print to given file. +*/ +int +c_fprintf ( + XINT fd, /* output file */ + char *format /* format string */ +) +{ + XINT x_fd = fd; + + iferr (FPRINTF (&x_fd, c_sppstr(format))) + return (ERR); + else + return (OK); +} + + +void c_pargb (int ival) { XINT x_ival = ival; PARGI (&x_ival); } +void c_pargc (int ival) { XINT x_ival = ival; PARGI (&x_ival); } +void c_pargs (short sval) { XSHORT x_sval = sval; PARGS (&x_sval); } +void c_pargi (int ival) { XINT x_ival = ival; PARGI (&x_ival); } +void c_pargl (long lval) { XLONG x_lval = lval; PARGL (&x_lval); } +void c_pargr (float rval) { XREAL x_rval = rval; PARGR (&x_rval); } +void c_pargd (double dval) { XDOUBLE x_dval = dval; PARGD (&x_dval); } + + +void c_pargstr (char *strval) +{ + PARGSTR (c_sppstr(strval)); +} diff --git a/sys/libc/crcursor.c b/sys/libc/crcursor.c new file mode 100644 index 00000000..695c9668 --- /dev/null +++ b/sys/libc/crcursor.c @@ -0,0 +1,28 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_RCURSOR -- Read a cursor. +*/ +int +c_rcursor ( + int fd, /* FIO file descriptor */ + char *outstr, /* output string */ + int maxch +) +{ + XCHAR buf[SZ_LINE]; + XINT x_fd = fd, x_maxch = maxch; + int key; + + + key = (int) RCURSOR (&x_fd, buf, &x_maxch); + c_strpak (buf, outstr, maxch); + + return (key == XEOF ? EOF : key); +} diff --git a/sys/libc/crdukey.c b/sys/libc/crdukey.c new file mode 100644 index 00000000..a0b7042c --- /dev/null +++ b/sys/libc/crdukey.c @@ -0,0 +1,28 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_RDUKEY -- Read a user keystroke object from the terminal in raw mode. +*/ +int +c_rdukey ( + char *obuf, /* output buffer */ + int maxch /* maxc chars out */ +) +{ + XCHAR buf[SZ_LINE+1]; + XINT x_maxch = SZ_LINE; + int status; + + + obuf[0] = EOS; + if ((status = (int) RDUKEY (buf, &x_maxch)) > 0) + c_strpak (buf, obuf, maxch); + + return (status); +} diff --git a/sys/libc/cread.c b/sys/libc/cread.c new file mode 100644 index 00000000..8cc727a5 --- /dev/null +++ b/sys/libc/cread.c @@ -0,0 +1,70 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#define import_stdio +#define import_error +#define import_fset +#include + + +/* C_READ -- FIO read from a file. Read up to maxbytes bytes from the stream +** fd into the buffer buf. If the device associated with file fd is a record +** structured device a single record is read, and the byte count will generally +** be less than the maximum. If the physical record was larger than maxbytes +** the remainder of the record is returned in successive reads. If the actual +** file is a text file FIO XCHARs are returned as C chars. If the actual file +** is a binary file no conversion is performed, and an integral number of XCHARs +** are read. +** +** For reasons of consistency with SPP usage, EOF is returned when end of file +** is reached (fread returns 0), and an error action is taken if a file read +** error occurs. We cannot return ERR when an error occurs since ERR and EOF +** have the same value in STDIO land. IFERR may be used to catch file read +** errors. +*/ +int +c_read ( + XINT fd, /* FIO file descriptor */ + char *buf, /* output buffer */ + int maxbytes /* max bytes to read */ +) +{ + XINT x_fd = fd; + int nchars_read; + + + if (c_fstati (fd, F_TYPE) == TEXT_FILE) { + register char *op = buf; + register int ch, n = maxbytes; + register FILE *fp = FDTOFP(fd); + + while (--n >= 0 && (ch = getc(fp)) >= 0) { + *op++ = ch; + if (ch == '\n') + break; + } + if (ferror (fp)) + c_erract (EA_ERROR); + if (!(nchars_read = op - buf)) + nchars_read = XEOF; + + } else { + XINT x_maxchars = maxbytes / sizeof(XCHAR); + XCHAR *bp = (XCHAR *)buf; + + /* Verify that the pointer coercion char->XCHAR->char is legal, + * i.e., that the char pointer is aligned to an XCHAR word + * boundary if required on this machine. + */ + if (buf != (char *)bp) + c_error (1, "c_read: buffer not xchar aligned"); + + if ((nchars_read = READ (&x_fd, bp, &x_maxchars)) > 0) + nchars_read *= sizeof(XCHAR); + } + + return (nchars_read == XEOF ? EOF : nchars_read); +} diff --git a/sys/libc/crename.c b/sys/libc/crename.c new file mode 100644 index 00000000..5f5b6668 --- /dev/null +++ b/sys/libc/crename.c @@ -0,0 +1,26 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_RENAME -- FIO rename file. +*/ +int +c_rename ( + char *old_fname, /* current name of file */ + char *new_fname /* new file name */ +) +{ + XCHAR spp_new_fname[SZ_FNAME]; + int maxch = SZ_FNAME; + + c_strupk (new_fname, spp_new_fname, maxch); + iferr (RENAME (c_sppstr(old_fname), spp_new_fname)) + return (ERR); + else + return (OK); +} diff --git a/sys/libc/creopen.c b/sys/libc/creopen.c new file mode 100644 index 00000000..da38703e --- /dev/null +++ b/sys/libc/creopen.c @@ -0,0 +1,27 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_REOPEN -- Reopen a binary file. +*/ +int +c_reopen ( + XINT fd, /* FIO file descriptor */ + int mode /* access mode */ +) +{ + XINT x_fd = fd, x_mode = mode; + int new_fd; + + + iferr (new_fd = (int) REOPEN (&x_fd, &x_mode)) + return (ERR); + else + return (new_fd); +} + diff --git a/sys/libc/csalloc.c b/sys/libc/csalloc.c new file mode 100644 index 00000000..823c0bca --- /dev/null +++ b/sys/libc/csalloc.c @@ -0,0 +1,80 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + +/* +** CSALLOC -- Dynamic memory allocation on the SPP stack. +** +** c_smark (&sp) +** c_sfree (sp) +** ptr = c_salloc (nbytes) +** +** A contiguous segment of dynamic storage may be allocated with C_SALLOC, +** much as is done with the UNIX emulation procedure MALLOC. All buffer +** space allocated on the stack since a call to C_SMARK to mark the position +** of the stack pointer may be freed in a single call to C_SFREE. +** +** The stack is implemented as a linked list of a few large buffers allocated +** on the heap with MALLOC, each of which normally contains many small buffers +** allocated with individual C_SALLOC calls. Stack allocation is very +** efficient for buffers small enough to fit into a stack segment. If it is +** necessary to add a new segment to accomodate a large buffer, the expense is +** about the same as for a buffer allocation with MALLOC. +*/ + + +/* C_SALLOC -- Allocate a contiguous segment of memory on the stack. The +** contents of the buffer will be uninitialized. The buffer is guaranteed to +** have at least XDOUBLE alignment with the Mem common. One extra XCHAR +** of storage is automatically allocated for the EOS delimiter in the event +** that the buffer is used to hold a character string (thus it is not necessary +** to be forever adding +1 in calls to the memory allocator). +** +** N.B.: it is a fatal error if storage cannot be allocated on the stack, +** hence error checking is not necessary. +*/ +char * +c_salloc ( + unsigned nbytes /* nbytes of storage to be allocated */ +) +{ + XINT buf; + XINT x_nchars = nbytes, x_dtype = TY_CHAR; + + + x_nchars = (nbytes + sizeof(XCHAR)-1) / sizeof(XCHAR); + SALLOC (&buf, &x_nchars, &x_dtype); + return ((char *)&Memc[buf]); +} + + +/* C_SMARK -- Mark the position of the stack pointer. +*/ +void +c_smark ( + int *sp /* stack pointer is saved here */ +) +{ + XINT x_sp = *sp; + + SMARK (&x_sp); + *sp = x_sp; +} + + +/* C_SFREE -- Free all stack storage allocated since the stack pointer passed as +** the sole argument was marked by C_SMARK. +*/ +void +c_sfree ( + int sp /* saved stack pointer */ +) +{ + XINT x_sp = sp; + + SFREE (&x_sp); +} diff --git a/sys/libc/cseek.c b/sys/libc/cseek.c new file mode 100644 index 00000000..58cedcc3 --- /dev/null +++ b/sys/libc/cseek.c @@ -0,0 +1,42 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#define import_fset +#include + + +/* C_SEEK -- FIO seek on a file. If the actual file is a text file the +** seek offset is assumed to have been obtained by a prior call to FTELL +** and is passed on unchanged. If the actual file is a binary file the +** seek offset is a zero-indexed byte offset. This offset is converted +** to a one-indexed XCHAR offset; it is an error if the offset is not +** aligned to an XCHAR word boundary. +*/ +int +c_seek ( + XINT fd, /* FIO file descriptor */ + long offset /* file offset */ +) +{ + XLONG x_char_offset = offset; + XINT x_fd = fd; + int bypass; + + + bypass = (offset == BOFL || offset == EOFL + || c_fstati (fd, F_TYPE) == TEXT_FILE); + + if (!bypass) { + x_char_offset /= sizeof(XCHAR); + if ((x_char_offset++ * sizeof(XCHAR)) != offset) + return ((long) ERR); + } + + iferr (SEEK (&x_fd, &x_char_offset)) + return (ERR); + else + return (OK); +} diff --git a/sys/libc/csppstr.c b/sys/libc/csppstr.c new file mode 100644 index 00000000..ce7c9461 --- /dev/null +++ b/sys/libc/csppstr.c @@ -0,0 +1,31 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#include + +#define SZ_UPKSTR SZ_COMMAND +static XCHAR u_upkstr[SZ_UPKSTR+1]; + +/* C_SPPSTR -- Unpack a C string into an SPP string. This routine is offered +** as a convenient alternative to C_STRUPK for cases when the length of the +** string is known to be short and the value will be used before we are again +** called. The unpacked string is left in a static internal buffer and a +** pointer to XCHAR is returned as the function value. +*/ +XCHAR * +c_sppstr ( + char *str +) +{ + register char *ip = str; + register XCHAR *op = u_upkstr; + register int n = SZ_UPKSTR; + + while (--n >= 0 && (*op++ = *ip++) != XEOS) + ; + u_upkstr[SZ_UPKSTR] = XEOS; + + return (u_upkstr); +} diff --git a/sys/libc/cstropen.c b/sys/libc/cstropen.c new file mode 100644 index 00000000..ac7d01a8 --- /dev/null +++ b/sys/libc/cstropen.c @@ -0,0 +1,26 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_STROPEN -- FIO string-file open. +*/ +int +c_stropen ( + XCHAR *obuf, /* string file-buffer */ + int maxch, /* max chars in string */ + int mode /* file access mode */ +) +{ + XINT x_maxch = maxch, x_mode = mode; + int fd; + + iferr (fd = (int) STROPEN (obuf, &x_maxch, &x_mode)) + return (ERR); + else + return (fd); +} diff --git a/sys/libc/cstrpak.c b/sys/libc/cstrpak.c new file mode 100644 index 00000000..6236aa0d --- /dev/null +++ b/sys/libc/cstrpak.c @@ -0,0 +1,35 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#include + + +/* C_STRPAK -- Pack an SPP string (type XCHAR) into a C string in a user +** supplied buffer. Return a pointer to the output buffer. +** +** N.B.: This routine should be used in preference to STRPAK in C code +** since the output string is of type char*, rather than XCHAR*. +*/ +char * +c_strpak ( + XCHAR *sppstr, /* SPP string */ + char *cstr, /* C string */ + int maxch /* max chars out, incl EOS */ +) +{ + register XCHAR *ip = sppstr; + register char *op = cstr; + register int n = maxch-1; + + if (maxch) { + if (sizeof(XCHAR) != sizeof(char) || (char *)sppstr != cstr) { + while (--n >= 0 && (*op++ = *ip++) != EOS) + ; + cstr[maxch-1] = EOS; + } + } + + return (cstr); +} diff --git a/sys/libc/cstrupk.c b/sys/libc/cstrupk.c new file mode 100644 index 00000000..c8e26e19 --- /dev/null +++ b/sys/libc/cstrupk.c @@ -0,0 +1,41 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_libc +#define import_spp +#include + +/* C_STRUPK -- Unpack a C string into an SPP string. This procedure should +** be called from C in preference to the SPP procedure STRUPK because the +** input string is declared to be of type char, rather than as an XCHAR +** array containing packed chars as in STRUPK. The output string is however +** of type XCHAR since it is expected to be passed to an SPP procedure. A +** pointer to the output string is returned as the function value for use +** in argument lists. +*/ +XCHAR * +c_strupk ( + char *str, /* C string */ + XCHAR *outstr, /* SPP string */ + int maxch /* max chars out, incl EOS */ +) +{ + register char *ip = str; + register XCHAR *op = outstr; + register int n = maxch-1; + + + /* Is is necessary to determine the length of the string in order to + * be able to unpack the string in place, i.e., from right to left. + */ + if (maxch) + if (sizeof(char) != sizeof(XCHAR) || str != (char *)outstr) { + n = min (n, strlen(ip)); + op[n] = XEOS; + + for (n = n - 1; n >= 0; --n) + op[n] = ip[n]; + } + + return (outstr); +} diff --git a/sys/libc/ctsleep.c b/sys/libc/ctsleep.c new file mode 100644 index 00000000..9b89fe08 --- /dev/null +++ b/sys/libc/ctsleep.c @@ -0,0 +1,18 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_libc +#define import_xnames +#include + +/* C_TSLEEP -- Suspend process execution for the specified number of seconds. +*/ +void +c_tsleep ( + int nseconds +) +{ + XINT x_nsec = nseconds; + + TSLEEP (&x_nsec); +} diff --git a/sys/libc/cttset.c b/sys/libc/cttset.c new file mode 100644 index 00000000..ab252ea2 --- /dev/null +++ b/sys/libc/cttset.c @@ -0,0 +1,88 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_STTYCO -- Set terminal driver options via a command string. +*/ +void +c_sttyco ( + char *args, + XINT ttin, + XINT ttout, + XINT outfd +) +{ + XCHAR x_args[SZ_COMMAND]; + XINT x_ttin = ttin, x_ttout = ttout, x_outfd = outfd; + + c_strupk (args, x_args, SZ_COMMAND); + STTYCO (x_args, &x_ttin, &x_ttout, &x_outfd); +} + + +/* C_TTSETI -- FIO set integer terminal driver parameter. +*/ +void +c_ttseti ( + XINT fd, /* FIO file descriptor */ + int param, /* param to be set */ + int value /* new value */ +) +{ + XINT x_fd = fd, x_param = param, x_value = value; + + TTSETI (&x_fd, &x_param, &x_value); +} + + +/* C_TTSTATI -- FIO stat integer terminal driver parameter. +*/ +int +c_ttstati ( + XINT fd, /* FIO file descriptor */ + int param /* param to be set */ +) +{ + XINT x_fd = fd, x_param = param; + + return (TTSTATI (&x_fd, &x_param)); +} + +/* C_TTSETS -- FIO set string terminal driver parameter. +*/ +void +c_ttsets ( + XINT fd, /* FIO file descriptor */ + int param, /* param to be set */ + char *value /* new value */ +) +{ + XINT x_fd = fd, x_param = param; + + TTSETS (&x_fd, &x_param, c_sppstr (value)); +} + + +/* C_TTSTATS -- FIO stat string terminal driver parameter. +*/ +int +c_ttstats ( + XINT fd, /* FIO file descriptor */ + int param, /* param to be set */ + char *outstr, /* receives string value */ + int maxch +) +{ + XCHAR x_sval[SZ_LINE+1]; + XINT x_fd = fd, x_param = param, x_maxch = SZ_LINE; + int nchars; + + nchars = TTSTATS (&x_fd, &x_param, x_sval, &x_maxch); + c_strpak (x_sval, outstr, maxch); + return (maxch < nchars ? maxch : nchars); +} diff --git a/sys/libc/cttycdes.c b/sys/libc/cttycdes.c new file mode 100644 index 00000000..1d7cfc84 --- /dev/null +++ b/sys/libc/cttycdes.c @@ -0,0 +1,19 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + +/* C_TTYCDES -- Close the TTY descriptor. +*/ +void +c_ttycdes ( + XINT tty /* SPP pointer to descriptor */ +) +{ + XINT x_tty = tty; + + TTYCDES (&x_tty); +} diff --git a/sys/libc/cttyclear.c b/sys/libc/cttyclear.c new file mode 100644 index 00000000..e10c274f --- /dev/null +++ b/sys/libc/cttyclear.c @@ -0,0 +1,21 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_TTYCLEAR -- Clear the screen. +*/ +void +c_ttyclear ( + XINT fd, /* output file */ + XINT tty /* tty descriptor */ +) +{ + XINT x_fd = fd, x_tty = tty; + + TTYCLEAR (&x_fd, &x_tty); +} diff --git a/sys/libc/cttyclln.c b/sys/libc/cttyclln.c new file mode 100644 index 00000000..7a6a20ee --- /dev/null +++ b/sys/libc/cttyclln.c @@ -0,0 +1,22 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_TTYCLEARLN -- Clear the current line. The cursor is left positioned to +** the left margin. +*/ +void +c_ttyclearln ( + XINT fd, /* output file */ + XINT tty /* tty descriptor */ +) +{ + XINT x_fd = fd, x_tty = tty; + + TTYCLEARLN (&x_fd, &x_tty); +} diff --git a/sys/libc/cttyctrl.c b/sys/libc/cttyctrl.c new file mode 100644 index 00000000..8143c8e4 --- /dev/null +++ b/sys/libc/cttyctrl.c @@ -0,0 +1,27 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_TTYCTRL -- Lookup a capability in the termcap entry for a device and +** output the associated control string to the given output file. The baud +** rate (extracted from the environment at TTYODES time or set in a C_TTYSETI +** call) determines the number of pad characters output for delays. ERR is +** returned if the control sequence could not be output. +*/ +int +c_ttyctrl ( + XINT fd, /* output file */ + XINT tty, /* tty descriptor */ + char *cap, /* two char capability name */ + int afflncnt /* number of lines affected */ +) +{ + XINT x_fd = fd, x_tty = tty, x_afflncnt = afflncnt; + + return (TTYCTRL (&x_fd, &x_tty, c_sppstr(cap), &x_afflncnt)); +} diff --git a/sys/libc/cttygetb.c b/sys/libc/cttygetb.c new file mode 100644 index 00000000..cc1386bc --- /dev/null +++ b/sys/libc/cttygetb.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_TTYGETB -- Determine if the named capability exists for a device. +** Presence of the capability in the termcap entry for the device results +** in a return value of YES (=1), regardless of the actual datatype of +** the parameter. +*/ +int +c_ttygetb ( + XINT tty, /* tty descriptor */ + char *cap /* two char capability name */ +) +{ + XINT x_tty = tty; + + return ((int) BTOI ((XBOOL) TTYGETB (&x_tty, c_sppstr(cap)))); +} diff --git a/sys/libc/cttygeti.c b/sys/libc/cttygeti.c new file mode 100644 index 00000000..1011dac5 --- /dev/null +++ b/sys/libc/cttygeti.c @@ -0,0 +1,23 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_TTYGETI -- Get the value of a termcap capability of type integer. +** Zero is returned if the device does not have such a capability or if +** the the value string cannot be interpreted as an integer. +*/ +XINT +c_ttygeti ( + XINT tty, /* tty descriptor */ + char *cap /* two char capability name */ +) +{ + XINT x_tty = tty; + + return ((XINT) TTYGETI (&x_tty, c_sppstr(cap))); +} diff --git a/sys/libc/cttygetr.c b/sys/libc/cttygetr.c new file mode 100644 index 00000000..195d0e87 --- /dev/null +++ b/sys/libc/cttygetr.c @@ -0,0 +1,22 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + +/* C_TTYGETR -- Get the value of a termcap capability of type real. +** Zero is returned if the device does not have such a capability or if +** the the value string cannot be interpreted as a real. +*/ +float +c_ttygetr ( + XINT tty, /* tty descriptor */ + char *cap /* two char capability name */ +) +{ + XINT x_tty = tty; + + return ((float) TTYGETR (&x_tty, c_sppstr(cap))); +} diff --git a/sys/libc/cttygets.c b/sys/libc/cttygets.c new file mode 100644 index 00000000..04aea891 --- /dev/null +++ b/sys/libc/cttygets.c @@ -0,0 +1,34 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + +#define SZ_CAPSTR 128 +static XCHAR buf[SZ_CAPSTR]; +static XINT szbuf = 128; + + +/* C_TTYGETS -- Get the value of a termcap capability as a character string, +** suitable for subsequent output to the device with TTYPUTS (assuming the +** capability is a control function). The number of characters in the output +** string is returned as the function value. +*/ +int +c_ttygets ( + XINT tty, /* tty descriptor */ + char *cap, /* two char capability name */ + char *outstr, /* output string */ + int maxch /* max chars out, excl EOS */ +) +{ + XINT x_tty = tty; + int nchars; + + nchars = TTYGETS (&x_tty, c_sppstr(cap), buf, &szbuf); + c_strpak (buf, outstr, maxch); + + return (nchars); +} diff --git a/sys/libc/cttygoto.c b/sys/libc/cttygoto.c new file mode 100644 index 00000000..eb6f8922 --- /dev/null +++ b/sys/libc/cttygoto.c @@ -0,0 +1,23 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_TTYGOTO -- Move the cursor to the indicated X,Y position (one-indexed). +*/ +void +c_ttygoto ( + XINT fd, /* output file */ + XINT tty, /* tty descriptor */ + int col, /* x coordinate */ + int line /* y coordinate */ +) +{ + XINT x_fd = fd, x_tty = tty, x_col = col, x_line = line; + + TTYGOTO (&x_fd, &x_tty, &x_col, &x_line); +} diff --git a/sys/libc/cttyinit.c b/sys/libc/cttyinit.c new file mode 100644 index 00000000..da7da5ab --- /dev/null +++ b/sys/libc/cttyinit.c @@ -0,0 +1,22 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_TTYINIT -- Output the initialization sequence, if any, to the output +** file. +*/ +void +c_ttyinit ( + XINT fd, /* output file */ + XINT tty /* tty descriptor */ +) +{ + XINT x_fd = fd, x_tty = tty; + + TTYINIT (&x_fd, &x_tty); +} diff --git a/sys/libc/cttyodes.c b/sys/libc/cttyodes.c new file mode 100644 index 00000000..2d7a5cc3 --- /dev/null +++ b/sys/libc/cttyodes.c @@ -0,0 +1,89 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* +** CTTY -- Terminal control. The TTY package is an interface to the TERMCAP +** database, originally developed for Berkeley UNIX by Bill Joy. The termcap +** entry for a particular terminal presents in a condensed form the +** characteristics of the device, e.g., the number of line and columns on the +** screen, and how to clear the screen or move the cursor. The TTY routines +** are used to retrieve such capabilities from the database as well as to +** send the appropriate characters to a file (terminal) to perform such control +** functions. +** +** tty = c_ttyodes (ttyname) +** c_ttycdes (tty) +** c_ttyseti (tty, parameter, value) +** int = c_ttystati (tty, parameter) +** +** bool = c_ttygetb (tty, cap) +** int = c_ttygeti (tty, cap) +** float = c_ttygetr (tty, cap) +** nchars = c_ttygets (tty, cap, &outstr, maxch) +** c_ttyctrl (fd, tty, cap, afflncnt) +** c_ttyputs (fd, tty, ctrlstr, afflncnt) +** +** c_ttyclear (fd, tty) +** c_ttyclearln (fd, tty) +** c_ttygoto (fd, tty, col, line) +** c_ttyinit (fd, tty) +** c_ttyputline (fd, tty, text, map_cc) +** c_ttyso (fd, tty, onflag) +** +** +** Complete descriptions of TTY and termcap are given elsewhere. Briefly, the +** device descriptor for a particular terminal is opened with ttyodes, which +** returns a IRAF pointer (C integer) to the binary TTY descriptor. The +** terminal name may be given as "terminal", in which case ttyodes will look up +** the name of the default terminal in the environment and search the termcap +** database for the entry for the named device. +** +** The ttyget functions are used to read the capabilities. Capabilities are +** specified by two character mnemonics (character strings), shown as the cap +** arguments in the calling sequences above. Control sequences may be output +** with ttyctrl or with ttyputs, depending on whether you are willing to do a +** binary search for a particular capability at run time. The remaining high +** level functions make it easy to perform the more common control functions. +** +** Raw mode output to a terminal device is provided by the system interface +** (the newline and tab characters are exceptions). Raw mode input is provided +** as an fseti option in FIO. To set raw mode on STDIN: +** +** c_fseti (STDIN, F_RAW, YES); +** +** While raw mode is in effect input characters are read as they are typed, +** few or no control characters are recognized, and no echoing is performed. +** Raw mode is cleared whenever the newline character is sent to the terminal, +** but will be reset if by the next read if F_RAW remains set. +*/ + + +/* C_TTYODES -- Open the TTY descriptor for a particular terminal device. +** An SPP pointer to the TTY descriptor is returned as the function value. +** If the device name is given as "terminal" or "printer", the actual device +** name is taken to be the value of the environment variable of the same name. +** If the device name is the filename of a termcap format file, the entry +** for the first device in the file is loaded (this gives the user a simple +** means to supply special termcap entries). The name of the default +** termcap file is given by the environment variable "termcap". TTY maintains +** a cache of preloaded termcap device entries for frequently referenced +** devices. +*/ +XINT +c_ttyodes ( + char *ttyname /* termcap name of device */ +) +{ + XINT tty; + + iferr (tty = (XINT) TTYODES (c_sppstr (ttyname))) + return ((XINT) ERR); + else + return (tty); +} diff --git a/sys/libc/cttyputl.c b/sys/libc/cttyputl.c new file mode 100644 index 00000000..84fdf90a --- /dev/null +++ b/sys/libc/cttyputl.c @@ -0,0 +1,28 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_TTYPUTLINE -- Put a line of text to the output device. Any device +** independent control characters embedded in the text, e.g., tab, newline, +** formfeed, backspace, or the special control codes SO (enter standout mode) +** or SI (leave standout mode) are converted as necessary to drive the device. +** Unknown control codes are converted to printable sequences (e.g. ^C) if +** the map_cc flag is set. +*/ +void +c_ttyputline ( + XINT fd, /* output file */ + XINT tty, /* tty descriptor */ + char *line, /* line to be output */ + int map_cc /* map unknown ctrl chars */ +) +{ + XINT x_fd = fd, x_tty = tty, x_map_cc = map_cc; + + TTYPUTLINE (&x_fd, &x_tty, c_sppstr(line), &x_map_cc); +} diff --git a/sys/libc/cttyputs.c b/sys/libc/cttyputs.c new file mode 100644 index 00000000..4d428964 --- /dev/null +++ b/sys/libc/cttyputs.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_TTYPUTS -- Put a control sequence obtained in a prior call to C_TTYGETS +** to the output file. The baud rate (extracted from the environment at +** TTYODES time or set in a C_TTYSETI call) determines the number of pad +** characters output for delays. +*/ +int +c_ttyputs ( + XINT fd, /* output file */ + XINT tty, /* tty descriptor */ + char *cap, /* two char capability name */ + int afflncnt /* number of lines affected */ +) +{ + XINT x_fd = fd, x_tty = tty, x_afflncnt = afflncnt; + + iferr (TTYPUTS (&x_fd, &x_tty, c_sppstr(cap), &x_afflncnt)) + return (ERR); + else + return (OK); +} diff --git a/sys/libc/cttyseti.c b/sys/libc/cttyseti.c new file mode 100644 index 00000000..086dd98f --- /dev/null +++ b/sys/libc/cttyseti.c @@ -0,0 +1,22 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_TTYSETI -- Set a TTY interface parameter of type integer. +*/ +void +c_ttyseti ( + XINT tty, /* tty descriptor */ + int param, /* code of param to be set */ + int value /* value to be set */ +) +{ + XINT x_tty = tty, x_param = param, x_value = value; + + TTYSETI (&x_tty, &x_param, &x_value); +} diff --git a/sys/libc/cttyso.c b/sys/libc/cttyso.c new file mode 100644 index 00000000..3283f83f --- /dev/null +++ b/sys/libc/cttyso.c @@ -0,0 +1,23 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_TTYSO -- Turn standout mode (reverse video, underline, or upper case +** depending on the device) on or off. +*/ +void +c_ttyso ( + XINT fd, /* output file */ + XINT tty, /* tty descriptor */ + int onoff /* 1=on, 0=off */ +) +{ + XINT x_fd = fd, x_tty = tty, x_onoff = onoff; + + TTYSO (&x_fd, &x_tty, &x_onoff); +} diff --git a/sys/libc/cttystati.c b/sys/libc/cttystati.c new file mode 100644 index 00000000..9ba254c5 --- /dev/null +++ b/sys/libc/cttystati.c @@ -0,0 +1,21 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_TTYSTATI -- Return the value of a TTY integer interface parameter. +*/ +XINT +c_ttystati ( + XINT tty, /* tty descriptor */ + int param /* code of param to be set */ +) +{ + XINT x_tty = tty, x_param = param; + + return (TTYSTATI (&x_tty, &x_param)); +} diff --git a/sys/libc/ctype.c b/sys/libc/ctype.c new file mode 100644 index 00000000..4d52648c --- /dev/null +++ b/sys/libc/ctype.c @@ -0,0 +1,31 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_ctype +#include + +#ifdef vms +globaldef vms_ctype_defs; /* [MACHDEP] */ +#endif + +/* Character class associations for the ctype.h macros. +*/ +char u_ctype_[] = { + 0, + _C, _C, _C, _C, _C, _C, _C, _C, + _C, _S, _S, _S, _S, _S, _C, _C, + _C, _C, _C, _C, _C, _C, _C, _C, + _C, _C, _C, _C, _C, _C, _C, _C, + _S, _P, _P, _P, _P, _P, _P, _P, + _P, _P, _P, _P, _P, _P, _P, _P, + _N, _N, _N, _N, _N, _N, _N, _N, + _N, _N, _P, _P, _P, _P, _P, _P, + _P, _U|_X, _U|_X, _U|_X, _U|_X, _U|_X, _U|_X, _U, + _U, _U, _U, _U, _U, _U, _U, _U, + _U, _U, _U, _U, _U, _U, _U, _U, + _U, _U, _U, _P, _P, _P, _P, _P, + _P, _L|_X, _L|_X, _L|_X, _L|_X, _L|_X, _L|_X, _L, + _L, _L, _L, _L, _L, _L, _L, _L, + _L, _L, _L, _L, _L, _L, _L, _L, + _L, _L, _L, _P, _P, _P, _P, _C +}; diff --git a/sys/libc/cungetc.c b/sys/libc/cungetc.c new file mode 100644 index 00000000..d1f416ef --- /dev/null +++ b/sys/libc/cungetc.c @@ -0,0 +1,28 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_UNGETC -- Push a character back into the input stream. Pushback is last +** in first out, i.e., the last character pushed back is the first one +** read by GETC. Characters (and strings) may be pushed back until the +** FIO pushback buffer overflows. +*/ +int +c_ungetc ( + XINT fd, /* file */ + int ch /* char to be pushed */ +) +{ + XINT x_fd = fd; + XCHAR x_ch = ch; + + iferr (UNGETC (&x_fd, &x_ch)) + return (ERR); + else + return (OK); +} diff --git a/sys/libc/cungetl.c b/sys/libc/cungetl.c new file mode 100644 index 00000000..5e0fa40c --- /dev/null +++ b/sys/libc/cungetl.c @@ -0,0 +1,31 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + +#define MAX_STRLEN SZ_COMMAND + + +/* C_UNGETLINE -- Push a string back into the input stream. Pushback is last +** in first out, i.e., the last string pushed back is the first one read by +** GETC. Strings (and single characters) may be pushed back until the FIO +** pushback buffer overflows. +*/ +int +c_ungetline ( + XINT fd, /* file */ + char *str /* string to be pushed back */ +) +{ + XINT x_fd = fd; + XCHAR spp_str[MAX_STRLEN]; + + + iferr (UNGETLINE (&x_fd, c_strupk (str, spp_str, MAX_STRLEN))) + return (ERR); + else + return (OK); +} diff --git a/sys/libc/cvfnbrk.c b/sys/libc/cvfnbrk.c new file mode 100644 index 00000000..346b07fb --- /dev/null +++ b/sys/libc/cvfnbrk.c @@ -0,0 +1,30 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_knames +#include + + +/* C_VFNBRK -- Break a virtual filename (or host filename) into its component +** parts, i.e., logical directory (ldir), root, and extension. No characters +** are actually moved, rather, the offsets to the root and extn fields are +** returned as output arguments. +*/ +void +c_vfnbrk ( + char *vfn, /* virtual filename (or osfn) */ + int *root, /* offset of root field. */ + int *extn /* offset of extn field. */ +) +{ + XCHAR sppvfn[SZ_PATHNAME]; + XINT x_root = *root, x_extn = extn; + + ZFNBRK (c_strupk(vfn,sppvfn,SZ_PATHNAME), &x_root, &x_extn); + + /* Make offsets zero-indexed. */ + *root -= 1; + *extn -= 1; +} diff --git a/sys/libc/cwmsec.c b/sys/libc/cwmsec.c new file mode 100644 index 00000000..246285a1 --- /dev/null +++ b/sys/libc/cwmsec.c @@ -0,0 +1,20 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_knames +#include + + +/* C_WMSEC -- Delay for so may milliseconds. +*/ +void +c_wmsec ( + int msec /* milliseconds to delay */ +) +{ + XINT x_msec = msec; + + ZWMSEC (&x_msec); +} diff --git a/sys/libc/cwrite.c b/sys/libc/cwrite.c new file mode 100644 index 00000000..5ca7dab9 --- /dev/null +++ b/sys/libc/cwrite.c @@ -0,0 +1,51 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#define import_fset +#define import_stdio +#define import_error +#include + + +/* C_WRITE -- FIO write to a file. Write exactly nbytes bytes from the buffer +** buf to the stream fd. If the actual file is a text file C chars are output +** as XCHARs. If the actual file is a binary file no conversion is performed, +** but an integral number of XCHARs are always written. +*/ +int +c_write ( + XINT fd, /* FIO file descriptor */ + char *buf, /* buffer containing data to be written */ + int nbytes /* nbytes to be written */ +) +{ + XINT x_fd = fd; + + if (c_fstati (fd, F_TYPE) == TEXT_FILE) { + register FILE *fp = FDTOFP(fd); + register char *ip; + register int n = nbytes; + + for (ip=buf; --n >= 0; ip++) + putc (*ip, fp); + if (ferror (fp)) + c_erract (EA_ERROR); + + } else { + XINT x_nchars = (nbytes + sizeof(XCHAR)-1) / sizeof(XCHAR); + XCHAR *bp = (XCHAR *)buf; + + /* Verify that the pointer coercion char->XCHAR->char is legal, + * i.e., that the char pointer is aligned to an XCHAR word + * boundary if required on this machine. + */ + if (buf != (char *) bp) + return (ERR); + WRITE (&x_fd, bp, &x_nchars); + } + + return (nbytes); +} diff --git a/sys/libc/cxgmes.c b/sys/libc/cxgmes.c new file mode 100644 index 00000000..f8384923 --- /dev/null +++ b/sys/libc/cxgmes.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#define import_knames +#include + + +/* C_XGMES -- Fetch the machine dependent integer code and message string +** for the most recent exception. The integer code XOK is returned if +** no exception has occurred or if C_XGMES is called more than once after +** a single exception. +*/ +void +c_xgmes ( + int *oscode, /* os integer code of exception */ + char *oserrmsg, /* os error message string */ + int maxch +) +{ + PKCHAR x_oserrmsg[SZ_LINE+1]; + XINT x_oscode = *oscode, x_maxch = SZ_LINE; + + ZXGMES (&x_oscode, x_oserrmsg, &x_maxch); + (void) strncpy (oserrmsg, (char *)x_oserrmsg, maxch); + *oscode = x_oscode; +} diff --git a/sys/libc/cxonerr.c b/sys/libc/cxonerr.c new file mode 100644 index 00000000..2154851c --- /dev/null +++ b/sys/libc/cxonerr.c @@ -0,0 +1,19 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_libc +#define import_xnames +#include + + +/* C_XONERR -- Call any error handler procedures posted with ONERROR. +*/ +void +c_xonerr ( + int errcode +) +{ + XINT x_errcode = errcode; + + XONERR (&x_errcode); +} diff --git a/sys/libc/cxttysize.c b/sys/libc/cxttysize.c new file mode 100644 index 00000000..81ac4541 --- /dev/null +++ b/sys/libc/cxttysize.c @@ -0,0 +1,25 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* C_XTTYSIZE -- Get the terminal screen size, dynamically querying the +** terminal for the screen size if the terminal has this capabability (e.g., +** a workstation window). +*/ +void +c_xttysize ( + int *ncols, /* ncols (output) */ + int *nlines /* nlines (output) */ +) +{ + XINT x_ncols, x_nlines; + + XTTYSIZE (&x_ncols, &x_nlines); + *ncols = x_ncols; + *nlines = x_nlines; +} diff --git a/sys/libc/cxwhen.c b/sys/libc/cxwhen.c new file mode 100644 index 00000000..b3523dfe --- /dev/null +++ b/sys/libc/cxwhen.c @@ -0,0 +1,63 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_xnames +#define import_knames +#define import_libc +#include + + +/* CXWHEN -- Post an exception handler. The exception handler procedure +** is called when an exception occurs, unless the exception has been +** disabled. If a user exception handler has not been posted and an +** exception has not been disabled, a system default exception handler is +** called when the exception occurs. +** +** Currently only four exceptions are recognized (import_xwhen): +** +** X_INT interrupt +** X_ARITH arithmetic exception (e.g. divide by zero) +** X_ACV access violation (e.g. illegal memory reference) +** X_IPC write to IPC with no reader +** +** When an exception occurs the user supplied exception handler is called +** with the following argument list: +** +** handler (&exception, &next_handler) +** +** The first argument is the code for the virtual exception calling the user +** handler (the same handler may be posted for more than one exception). +** The second argument is set by the user handler before exiting, and +** must be either the ZLOCPR entry point address of the next exception +** handler to be called or NULL, indicating that normal execution is to +** resume. +** +** For portability reasons, only the virtual exceptions should be used to +** post exception handlers. For good diagnostic messages when an exception +** occurs it is desirable, however, to have a more precise description of +** the actual host system exception which occurred. This may be obtained +** by a call to C_XGMES. +*/ + +#define SZ_ERRMSG 64 +typedef int (*PFI)(); /* pointer to function returning int */ + + +/* C_XWHEN -- Post an exception handler for an exception, or disable the +** exception (not all exceptions can be disabled). +*/ +void +c_xwhen ( + int exception, /* code for virtual exception */ + PFI new_handler, /* new exception handler */ + PFI *old_handler /* old exception handler (output) */ +) +{ + XINT excode = exception; + XINT epa_new_handler = (XINT)new_handler; + XINT epa_old_handler; + + XWHEN (&excode, &epa_new_handler, &epa_old_handler); + *old_handler = (PFI)epa_old_handler; +} diff --git a/sys/libc/eprintf.c b/sys/libc/eprintf.c new file mode 100644 index 00000000..54cb5b8f --- /dev/null +++ b/sys/libc/eprintf.c @@ -0,0 +1,25 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_stdio +#define import_stdarg +#include + + +/* EPRINTF -- Formatted print to the standard error output. +*/ +void +eprintf (char *format, ...) +{ + va_list argp; + + extern void u_doprnt(); + + + va_start (argp, format); + u_doprnt (format, &argp, stderr); + va_end (argp); + (void) fflush (stderr); +} diff --git a/sys/libc/fclose.c b/sys/libc/fclose.c new file mode 100644 index 00000000..969c5d50 --- /dev/null +++ b/sys/libc/fclose.c @@ -0,0 +1,23 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_stdio +#define import_xnames +#include + +/* FCLOSE -- Close a file opened with fopen. +*/ +int +fclose ( + FILE *fp +) +{ + XINT x_fd = fileno(fp); + + iferr (CLOSE (&x_fd)) + return (EOF); + else + return (OK); +} diff --git a/sys/libc/fdopen.c b/sys/libc/fdopen.c new file mode 100644 index 00000000..c9e2bc9f --- /dev/null +++ b/sys/libc/fdopen.c @@ -0,0 +1,76 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_stdio +#define import_fset +#include + + +extern int c_fstati(); + + +/* FDOPEN -- Reopen a file for i/o with the STDIO package, after the file +** as already been opened by FIO. It is an error if the access modes are +** incompatible. +*/ +FILE * +fdopen ( + XINT fd, /* FIO file descriptor */ + char *mode /* STDIO access mode */ +) +{ + register int fio_mode = c_fstati (fd, F_MODE); + register int fio_type = c_fstati (fd, F_TYPE); + + + /* Verify file access mode. No mode checking is performed for the + * special file types. + */ + if (fio_type == TEXT_FILE || fio_type == BINARY_FILE) + switch (mode[0]) { + case 'r': + if (fio_mode != READ_ONLY && fio_mode != READ_WRITE) + return (NULL); + break; + + case 'w': + switch (fio_mode) { + case NEW_FILE: + case READ_WRITE: + case WRITE_ONLY: + break; + default: + return (NULL); + } + break; + + case 'a': + if (fio_mode != APPEND && fio_mode != NEW_FILE) + return (NULL); + break; + + default: + return (NULL); + } + + /* Verify file type. No checking is performed if no type is given. + */ + switch (mode[1]) { + case EOS: + break; + case 't': + if (fio_type != TEXT_FILE) + return (NULL); + break; + case 'b': + if (fio_type != BINARY_FILE) + return (NULL); + break; + default: + return (NULL); + } + + return (FDTOFP(fd)); +} diff --git a/sys/libc/fflush.c b/sys/libc/fflush.c new file mode 100644 index 00000000..14a2356a --- /dev/null +++ b/sys/libc/fflush.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_stdio +#define import_xnames +#include + + +/* FFLUSH -- Flush the output file. +*/ +int +fflush ( + FILE *fp +) +{ + XINT x_fd = fileno(fp); + + iferr (FLUSH (&x_fd)) + return (EOF); + else + return (OK); +} diff --git a/sys/libc/fgetc.c b/sys/libc/fgetc.c new file mode 100644 index 00000000..155a1111 --- /dev/null +++ b/sys/libc/fgetc.c @@ -0,0 +1,19 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_stdio +#include + + +/* FGETC -- Get a character from the input file. Offered as a functionally +** equivalent alternative to the macro GETC. +*/ +int +fgetc ( + FILE *fp +) +{ + return (getc (fp)); +} diff --git a/sys/libc/fgets.c b/sys/libc/fgets.c new file mode 100644 index 00000000..45c228c6 --- /dev/null +++ b/sys/libc/fgets.c @@ -0,0 +1,43 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_stdio +#include + + +/* FGETS -- Return a newline delimited string in the user buffer. If the +** buffer fills before newline is seen the string will not be newline +** delimited. +*/ +char * +fgets ( + char *buf, /* user supplied output buffer */ + int maxch, /* max chars out (incl EOS) */ + FILE *fp /* input file */ +) +{ + register int ch = 0, lastch = 0, n = maxch - 1; + register char *op = buf; + + while (--n >= 0 && (ch = getc (fp)) >= 0) { + lastch = ch; + if (ch == '\r') /* handle DOS-style CR-NL */ + continue; + *op++ = ch; + if (ch == '\n') + break; + } + + if (ch == EOF && op == buf) + return ((char *) NULL); + else { +#ifdef ADD_NEWLINE + if (lastch != '\n') /* handle missing NL at EOF */ + *op++ = '\n'; +#endif + *op = EOS; + return (buf); + } +} diff --git a/sys/libc/fopen.c b/sys/libc/fopen.c new file mode 100644 index 00000000..f9fe16ae --- /dev/null +++ b/sys/libc/fopen.c @@ -0,0 +1,61 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#define import_stdio +#include + + +/* FOPEN -- Open a file with the given access mode and file type. The file type +** (text or binary) is specified with an optional, non UNIX standard character +** "t" or "b" in the modestring. The default is text file if no type is given. +*/ +FILE * +fopen ( + char *fname, /* vfn of file */ + char *modestr /* access mode [and type] */ +) +{ + XINT x_filetype, x_filemode; + int fd; + + + /* Get file type. + */ + switch (modestr[1]) { + case 't': + case EOS: + x_filetype = TEXT_FILE; + break; + case 'b': + x_filetype = BINARY_FILE; + break; + default: + return (NULL); + } + + /* Determine file access mode. + */ + switch (modestr[0]) { + case 'r': + x_filemode = READ_ONLY; + break; + case 'w': + x_filemode = NEW_FILE; + break; + case 'a': + x_filemode = APPEND; + break; + default: + return (NULL); + } + + /* Open file. + */ + iferr (fd = OPEN (c_sppstr(fname), &x_filemode, &x_filetype)) + return (NULL); + else + return (FDTOFP(fd)); +} diff --git a/sys/libc/fputc.c b/sys/libc/fputc.c new file mode 100644 index 00000000..7d815206 --- /dev/null +++ b/sys/libc/fputc.c @@ -0,0 +1,20 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_stdio +#include + + +/* FPUTC -- Put a character to the output file. Offered as a functionally +** equivalent alternative to the macro PUTC. +*/ +int +fputc ( + char ch, + FILE *fp +) +{ + return (putc (ch, fp)); +} diff --git a/sys/libc/fputs.c b/sys/libc/fputs.c new file mode 100644 index 00000000..76dca159 --- /dev/null +++ b/sys/libc/fputs.c @@ -0,0 +1,22 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_stdio +#include + + +/* FPUTS -- Put a null terminated string to the output file. +*/ +void +fputs ( + char *str, /* input string */ + FILE *fp /* output file */ +) +{ + register char *ip; + + for (ip=str; *ip != EOS; ip++) + putc (*ip, fp); +} diff --git a/sys/libc/fread.c b/sys/libc/fread.c new file mode 100644 index 00000000..28f1376c --- /dev/null +++ b/sys/libc/fread.c @@ -0,0 +1,55 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_stdio +#include + + +/* FREAD -- Read a binary block of data from the input file. To be consistent +** with UNIX we must read until nelem chars have been accumulated or until +** EOF is seen. Hence, if reading from a record structured device such as a +** terminal, the read will not be terminated by end of record (newline). +** If the number of bytes (C chars) requested does not fill an integral number +** of XCHARS additional bytes will be read to fill out the last XCHAR. +*/ +int +fread ( + char *bp, /* output buffer */ + int szelem, /* nbytes per element */ + int nelem, /* nelems to read */ + FILE *fp +) +{ + register int nread, n; + int nbytes; + XINT fd = fileno (fp); + char *op = bp; + + + fd = fileno (fp); + nbytes = nelem * szelem; + nread = 0; + + if (fp == stdin) + (void) fflush (stdout); + if (szelem <= 0) + return (0); + + for (op = bp; nread < nbytes; op += n) { + iferr (n = c_read (fd, op, nbytes-nread)) { + fp->_fflags |= _FERR; + break; + } else if (n == EOF) { + fp->_fflags |= _FEOF; + break; + } else + nread += n; + } + + if (fp->_fflags & (_FEOF|_FERR)) + return (nread ? nread / szelem : 0); + else + return (nread / szelem); +} diff --git a/sys/libc/freadline.c b/sys/libc/freadline.c new file mode 100644 index 00000000..b335ee20 --- /dev/null +++ b/sys/libc/freadline.c @@ -0,0 +1,34 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_stdio +#include + + +/* FREADLINE -- Get a line from a user with editing. This is a libc + * interface to the host readline() interface. The host readline() + * returns a buffer allocated which we free here, what's returned to + * the caller is a static buffer containing the input string. + */ +char * +freadline ( + char *prompt /* user supplied output buffer */ +) +{ + char *cmd = (char *) NULL; + static char line[SZ_LINE]; + char *readline (char *prompt); + + + memset (line, 0, SZ_LINE); + if ((cmd = readline (prompt)) == (char *) NULL) { + return ((char *) NULL); + } else { + strcpy (line, cmd); /* save to static buffer */ + zfree_ ((void *) cmd); /* free readline() buffer */ + } + + return ((char *) line); +} diff --git a/sys/libc/free.c b/sys/libc/free.c new file mode 100644 index 00000000..4edd18c0 --- /dev/null +++ b/sys/libc/free.c @@ -0,0 +1,22 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* FREE -- Free a block of storage previously allocated by malloc, calloc, +** or realloc. +*/ +void +free ( + char *buf +) +{ + XINT x_ptr, x_dtype = TY_CHAR; + + x_ptr = Memcptr (buf); + MFREE (&x_ptr, &x_dtype); +} diff --git a/sys/libc/freopen.c b/sys/libc/freopen.c new file mode 100644 index 00000000..4d4ed997 --- /dev/null +++ b/sys/libc/freopen.c @@ -0,0 +1,56 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_stdio +#include + + +/* FREOPEN -- Close a stream and reopen it upon the named file. This is +** commonly used to redirect one of the standard streams stdin, stdout, +** or stderr to a named file. +*/ +FILE * +freopen ( + char *fname, /* vfn of file to be opened */ + char *modestr, /* access mode [and type] */ + FILE *fp /* stream to be reopened */ +) +{ + register XINT fd = fileno(fp); + register int status, filetype; + + + /* Determine the file type of the file to be opened. This is given + * by an optional second character in the mode string. Default is + * text file if absent. + */ + switch (modestr[1]) { + case 't': + case EOS: + filetype = TEXT_FILE; + break; + case 'b': + filetype = BINARY_FILE; + break; + default: + return (NULL); + } + + switch (modestr[0]) { + case 'r': + status = c_fredir (fd, fname, READ_ONLY, filetype); + break; + case 'w': + status = c_fredir (fd, fname, NEW_FILE, filetype); + break; + case 'a': + status = c_fredir (fd, fname, APPEND, filetype); + break; + default: + return (NULL); + } + + return (status == ERR ? NULL : fp); +} diff --git a/sys/libc/fseek.c b/sys/libc/fseek.c new file mode 100644 index 00000000..fa32466c --- /dev/null +++ b/sys/libc/fseek.c @@ -0,0 +1,93 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_stdio +#define import_fset +#include + + +/* FSEEK -- Seek on a file opened under stdio. The seek functions do not +** completely emulate the UNIX seek functions. The following restrictions +** apply: +** +** - It is only permissible to seek to the beginning of a line if the +** actual file is a text file. The seek offset must have been +** obtained by a prior call to FTELL, which returns the seek offset +** of the next line to be read or written. Seek offsets cannot be +** manufactured, e.g., as physical char offsets in the file, as is +** the case for binary files. These restrictions apply because text +** files are record structured on many systems, rather than simple +** byte stream files as in UNIX. +** +** - It is permissible to randomly seek about on a binary file, but +** seeks must be aligned on XCHAR word boundaries in the file. This +** can be guaranteed by structuring the application so that it always +** reads and writes binary data records that are an integral number +** of integers in size. If this is done the program is portable to +** any IRAF machine as well as to UNIX. Seek offsets are specified +** in units of bytes and are zero-indexed, as in C. +*/ +int +fseek ( + FILE *fp, /* operand file */ + long offset, /* offset in file */ + int mode /* 0=absolute, 1=relative, 2=from EOF */ +) +{ + register XINT fd = fileno(fp); + int text_file, stat; + long c_note(); + + + text_file = (c_fstati (fd, F_TYPE) == TEXT_FILE); + fp->_fflags &= ~_FEOF; + + if (text_file) { + switch (mode) { + case 0: + if (offset == 0L) + stat = c_seek (fd, BOFL); + else + stat = c_seek (fd, offset); + break; + case 2: + if (offset == 0L) { + stat = c_seek (fd, EOFL); + fp->_fflags |= _FEOF; + } else + stat = ERR; + break; + default: + stat = ERR; + break; + } + + } else { + /* Random seeks on (non-streaming) binary files are permitted, + * but the seek must be to an XCHAR offset. This is checked + * by c_seek, which takes a zero-indexed byte offset as argument. + */ + switch (mode) { + case 0: + stat = c_seek (fd, offset); + break; + case 1: + stat = c_seek (fd, c_note(fd) + offset); + break; + case 2: + if ((stat = c_seek (fd, EOFL)) != ERR) { + if (offset == 0L) + fp->_fflags |= _FEOF; + else + stat = c_seek (fd, c_note(fd) - offset); + } + break; + default: + stat = ERR; + } + } + + return (stat); +} diff --git a/sys/libc/ftell.c b/sys/libc/ftell.c new file mode 100644 index 00000000..be373a6d --- /dev/null +++ b/sys/libc/ftell.c @@ -0,0 +1,21 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_stdio +#include + + +/* FTELL -- Get the FSEEK offset of the current position in a file, i.e., +** the file offset at which the next read or write will occur. For a text +** file this is a magic number, for a binary file it is the zero-indexed +** offset in bytes from the beginning of the file. +*/ +long +ftell ( + FILE *fp /* operand file */ +) +{ + return (c_note (fileno(fp))); +} diff --git a/sys/libc/fwrite.c b/sys/libc/fwrite.c new file mode 100644 index 00000000..cb9e06e6 --- /dev/null +++ b/sys/libc/fwrite.c @@ -0,0 +1,36 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_stdio +#include + + +/* FWRITE -- Write a binary block of data to the output file. If the number +** of bytes (C chars) specified does not fill an integral number of XCHARS +** additional bytes will be written to fill out the last XCHAR. The actual +** number of elements written is returned as the function value. +*/ +int +fwrite ( + char *bp, /* output buffer */ + int szelem, /* nbytes per element */ + int nelem, /* nelems to read */ + FILE *fp +) +{ + register int stat; + XINT fd = fileno (fp); + + + if (szelem) { + stat = c_write (fd, bp, nelem * szelem); + if (stat == ERR) { + fp->_fflags |= _FERR; + return (0); + } else + return (stat / szelem); + } else + return (0); +} diff --git a/sys/libc/gets.c b/sys/libc/gets.c new file mode 100644 index 00000000..309efa11 --- /dev/null +++ b/sys/libc/gets.c @@ -0,0 +1,34 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_stdio +#include + + +/* GETS -- Read a newline terminated sequence from the standard input and +** return the resultant string minus the newline to the user. +*/ +char * +gets ( + char *buf /* user supplied output buffer */ +) +{ + register FILE *fp = stdin; + register char *op = buf; + register int ch; + + + while ((ch = getc (fp)) != EOF) { + if (ch == '\n') + break; + *op++ = ch; + } + *op = EOS; + + if (ch == EOF && op == buf) + return ((char *) NULL); + else + return (buf); +} diff --git a/sys/libc/getw.c b/sys/libc/getw.c new file mode 100644 index 00000000..c0dd0cf9 --- /dev/null +++ b/sys/libc/getw.c @@ -0,0 +1,28 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_stdio +#include + + +/* GETW -- Get a word (integer) from the input stream. When used in conjunction +** with PUTW this permits storage and retrieval of binary words in any file, +** albeit somewhat inefficiently. +*/ +int +getw ( + FILE *fp /* input file */ +) +{ + int word; + register char *op = (char *)&word; + register int n = sizeof (int); + + + while (--n >= 0) + *op++ = getc (fp); + + return ((fp->_fflags & (_FEOF|_FERR)) ? EOF : word); +} diff --git a/sys/libc/index.c b/sys/libc/index.c new file mode 100644 index 00000000..fa7a4917 --- /dev/null +++ b/sys/libc/index.c @@ -0,0 +1,26 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_libc +#define import_spp +#include + + +/* INDEX -- Search string STR for char CH, returning a pointer to the first +** occurrence of CH in STR or NULL. +*/ +char * +index ( + char *str, /* string to be searched */ + int ch /* character we are searching for */ +) +{ + register char *ip = str; + + do { + if (*ip == ch) + return (ip); + } while (*ip++); + + return ((char *) NULL); +} diff --git a/sys/libc/isatty.c b/sys/libc/isatty.c new file mode 100644 index 00000000..b625299a --- /dev/null +++ b/sys/libc/isatty.c @@ -0,0 +1,20 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* ISATTY -- Test if the given file is a terminal. +*/ +int +isatty ( + XINT fd +) +{ + XINT x_fd = fd; + + return (XISATTY (&x_fd)); +} diff --git a/sys/libc/libc_proto.h b/sys/libc/libc_proto.h new file mode 100644 index 00000000..52590a8e --- /dev/null +++ b/sys/libc/libc_proto.h @@ -0,0 +1,326 @@ +/* atof.c */ +extern double u_atof(char *str); +/* atoi.c */ +extern int u_atoi(char *str); +/* atol.c */ +extern long u_atol(char *str); +/* caccess.c */ +extern int c_access(char *fname, int mode, int type); +/* callocate.c */ +extern int c_allocate(char *device); +extern int c_deallocate(char *device, int u_rewind); +extern void c_devstatus(char *device, int out); +extern int c_devowner(char *device, char *owner, int maxch); +/* calloc.c */ +extern char *u_calloc(unsigned int nelems, unsigned int elsize); +/* cclktime.c */ +extern long c_clktime(long reftime); +extern long c_cputime(long reftime); +/* cclose.c */ +extern int c_close(int fd); +/* ccnvdate.c */ +extern char *c_cnvdate(long clktime, char *outstr, int maxch); +/* ccnvtime.c */ +extern char *c_cnvtime(long clktime, char *outstr, int maxch); +/* cdelete.c */ +extern int c_delete(char *fname); +/* cenvget.c */ +extern char *u_envget(char *var); +extern int c_envgs(char *var, char *outstr, int maxch); +extern int c_envfind(char *var, char *outstr, int maxch); +extern int c_envgb(char *var); +extern int c_envgi(char *var); +extern void c_envputs(char *var, char *value); +extern void c_envreset(char *var, char *value); +/* cenvlist.c */ +extern void c_envlist(int fd, char *prefix, int show_redefs); +/* cenvmark.c */ +extern void c_envmark(int *envp); +extern int c_envfree(int envp, int userfcn); +extern int c_prenvfree(int pid, int envp); +/* cenvscan.c */ +extern int c_envscan(char *input_source); +/* cerract.c */ +extern void c_erract(int action); +/* cerrcode.c */ +extern int c_errcode(void); +/* cerrget.c */ +extern int c_errget(char *outstr, int maxch); +/* cerror.c */ +extern void c_error(int errcode, char *errmsg); +/* cfchdir.c */ +extern int c_fchdir(char *newdir); +/* cfilbuf.c */ +extern int c_filbuf(struct _iobuf *fp); +/* cfinfo.c */ +extern int c_finfo(char *fname, struct _finfo *fi); +/* cflsbuf.c */ +extern int c_flsbuf(unsigned int ch, struct _iobuf *fp); +/* cflush.c */ +extern void c_flush(int fd); +/* cfmapfn.c */ +extern int c_fmapfn(char *vfn, char *osfn, int maxch); +/* cfmkdir.c */ +extern int c_fmkdir(char *newdir); +/* cfnextn.c */ +extern int c_fnextn(char *vfn, char *extn, int maxch); +/* cfnldir.c */ +extern int c_fnldir(char *vfn, char *ldir, int maxch); +/* cfnroot.c */ +extern int c_fnroot(char *vfn, char *root, int maxch); +/* cfpath.c */ +extern int c_fpathname(char *vfn, char *osfn, int maxch); +/* cfredir.c */ +extern int c_fredir(int fd, char *fname, int mode, int type); +/* cfseti.c */ +extern void c_fseti(int fd, int param, int value); +/* cfstati.c */ +extern int c_fstati(int fd, int param); +/* cgetpid.c */ +extern int c_getpid(void); +/* cgetuid.c */ +extern char *c_getuid(char *outstr, int maxch); +/* cgflush.c */ +extern void c_gflush(int stream); +/* cimaccess.c */ +extern int c_imaccess(char *imname, int mode); +/* cimdrcur.c */ +extern int c_imdrcur(char *device, float *x, float *y, int *wcs, int *key, char *strval, int maxch, int d_wcs, int pause); +/* ckimapc.c */ +extern int c_kimapchan(int chan, char *nodename, int maxch); +/* clexnum.c */ +extern int c_lexnum(char *str, int *toklen); +/* cmktemp.c */ +extern int c_mktemp(char *root, char *temp_filename, int maxch); +/* cndopen.c */ +extern int c_ndopen(char *fname, int mode); +/* cnote.c */ +extern long c_note(int fd); +/* copen.c */ +extern int c_open(char *fname, int mode, int type); +/* coscmd.c */ +extern int c_oscmd(char *cmd, char *infile, char *outfile, char *errfile); +/* cpoll.c */ +extern int c_poll_open(void); +extern int c_poll(int fds, int nfds, int timeout); +extern void c_poll_close(int fds); +extern void c_poll_zero(int fds); +extern void c_poll_set(int fds, int fd, int type); +extern void c_poll_clear(int fds, int fd, int type); +extern int c_poll_test(int fds, int fd, int type); +extern int c_poll_get_nfds(int fds); +extern void c_poll_print(int fds); +/* cprcon.c */ +extern unsigned int c_propen(char *process, int *in, int *out); +extern int c_prclose(unsigned int pid); +extern int c_prstati(int pid, int param); +extern int c_prsignal(unsigned pid, int signal); +extern int c_prredir(unsigned pid, int stream, int new_fd); +extern int c_prchdir(int pid, char *newdir); +extern int c_prenvset(int pid, char *envvar, char *value); +/* cprdet.c */ +extern unsigned int c_propdpr(char *process, char *bkgfile, char *bkgmsg); +extern int c_prcldpr(unsigned job); +extern int c_prdone(unsigned job); +extern int c_prkill(unsigned job); +/* cprintf.c */ +extern int c_printf(char *format); +extern int c_fprintf(int fd, char *format); +extern void c_pargb(int ival); +extern void c_pargc(int ival); +extern void c_pargs(short sval); +extern void c_pargi(int ival); +extern void c_pargl(long lval); +extern void c_pargr(float rval); +extern void c_pargd(double dval); +extern void c_pargstr(char *strval); +/* crcursor.c */ +extern int c_rcursor(int fd, char *outstr, int maxch); +/* crdukey.c */ +extern int c_rdukey(char *obuf, int maxch); +/* cread.c */ +extern int c_read(int fd, char *buf, int maxbytes); +/* crename.c */ +extern int c_rename(char *old_fname, char *new_fname); +/* creopen.c */ +extern int c_reopen(int fd, int mode); +/* csalloc.c */ +extern char *c_salloc(unsigned nbytes); +extern void c_smark(int *sp); +extern void c_sfree(int sp); +/* cseek.c */ +extern int c_seek(int fd, long offset); +/* csppstr.c */ +extern short *c_sppstr(char *str); +/* cstropen.c */ +extern int c_stropen(short *obuf, int maxch, int mode); +/* cstrpak.c */ +extern char *c_strpak(short *sppstr, char *cstr, int maxch); +/* cstrupk.c */ +extern short *c_strupk(char *str, short *outstr, int maxch); +/* ctsleep.c */ +extern void c_tsleep(int nseconds); +/* cttset.c */ +extern void c_sttyco(char *args, int ttin, int ttout, int outfd); +extern void c_ttseti(int fd, int param, int value); +extern int c_ttstati(int fd, int param); +extern void c_ttsets(int fd, int param, char *value); +extern int c_ttstats(int fd, int param, char *outstr, int maxch); +/* cttycdes.c */ +extern void c_ttycdes(XINT tty); +/* cttyclear.c */ +extern void c_ttycr(int fd, XINT tty); +/* cttyclln.c */ +extern void c_ttycn(int fd, XINT tty); +/* cttyctrl.c */ +extern int c_ttyctrl(int fd, XINT tty, char *cap, int afflncnt); +/* cttygetb.c */ +extern int c_ttygb(XINT tty, char *cap); +/* cttygeti.c */ +extern XINT c_ttygi(XINT tty, char *cap); +/* cttygetr.c */ +extern float c_ttygr(XINT tty, char *cap); +/* cttygets.c */ +extern int c_ttygs(XINT tty, char *cap, char *outstr, int maxch); +/* cttygoto.c */ +extern void c_ttygoto(int fd, XINT tty, int col, int line); +/* cttyinit.c */ +extern void c_ttyinit(int fd, XINT tty); +/* cttyodes.c */ +extern XINT c_ttyodes(char *ttyname); +/* cttyputl.c */ +extern void c_ttype(int fd, XINT tty, char *line, int map_cc); +/* cttyputs.c */ +extern int c_ttyps(int fd, XINT tty, char *cap, int afflncnt); +/* cttyseti.c */ +extern void c_ttyseti(XINT tty, int param, int value); +/* cttyso.c */ +extern void c_ttyso(int fd, XINT tty, int onoff); +/* cttystati.c */ +extern XINT c_ttystati(XINT tty, int param); +/* ctype.c */ +/* cungetc.c */ +extern int c_ungec(int fd, int ch); +/* cungetl.c */ +extern int c_ungetline(int fd, char *str); +/* cvfnbrk.c */ +extern void c_vfnbrk(char *vfn, int *root, int *extn); +/* cwmsec.c */ +extern void c_wmsec(int msec); +/* cwrite.c */ +extern int c_write(int fd, char *buf, int nbytes); +/* cxgmes.c */ +extern void c_xgmes(int *oscode, char *oserrmsg, int maxch); +/* cxonerr.c */ +extern void c_xonerr(int errcode); +/* cxttysize.c */ +extern void c_xttysize(int *ncols, int *nlines); +/* cxwhen.c +extern void c_xwhen(int exception, PFI new_handler, PFI *old_handler); + */ +/* eprintf.c */ +extern void u_eprintf(char *format, ...); +/* fclose.c */ +extern int u_fclose(struct _iobuf *fp); +/* fdopen.c */ +extern struct _iobuf *u_fdopen(int fd, char *mode); +/* fflush.c */ +extern int u_fflush(struct _iobuf *fp); +/* fgetc.c */ +extern int u_fgetc(struct _iobuf *fp); +/* fgets.c */ +extern char *u_fgets(char *buf, int maxch, struct _iobuf *fp); +/* fopen.c */ +extern struct _iobuf *u_fopen(char *fname, char *modestr); +/* fputc.c */ +extern int u_fputc(char ch, struct _iobuf *fp); +/* fputs.c */ +extern void u_fputs(char *str, struct _iobuf *fp); +/* fread.c */ +extern int u_fread(char *bp, int szelem, int nelem, struct _iobuf *fp); +/* free.c */ +extern void u_free(char *buf); +/* freopen.c */ +extern struct _iobuf *u_freopen(char *fname, char *modestr, struct _iobuf *fp); +/* fseek.c */ +extern int u_fseek(struct _iobuf *fp, long offset, int mode); +/* ftell.c */ +extern long u_ftell(struct _iobuf *fp); +/* fwrite.c */ +extern int u_fwrite(char *bp, int szelem, int nelem, struct _iobuf *fp); +/* gets.c */ +extern char *u_gets(char *buf); +/* getw.c */ +extern int u_getw(struct _iobuf *fp); +/* index.c */ +extern char *u_index(char *str, int ch); +/* isatty.c */ +extern int u_isatty(int fd); +/* malloc.c */ +extern char *u_malloc(unsigned nbytes); +/* mktemp.c */ +extern char *u_mktemp(char *template); +/* perror.c */ +extern void u_perror(char *prefix); +/* printf.c */ +extern void u_printf(char *format, ...); +extern void u_fprintf(struct _iobuf *fp, char *format, ...); +/* +extern void u_doprnt(char *format, va_list *argp, struct _iobuf *fp); +extern void u_doarg(struct _iobuf *fp, short *formspec, va_list **argp, int prec[], int varprec, int dtype); +*/ +/* puts.c */ +extern int u_puts(char *str); +/* putw.c */ +extern int u_putw(int word, struct _iobuf *fp); +/* qsort.c */ +extern void u_qsort(char *base, int n, int size, int (*compar)(void)); +/* realloc.c */ +extern char *u_realloc(char *buf, unsigned newsize); +/* rewind.c */ +extern long u_rewind(struct _iobuf *fp); +/* rindex.c */ +extern char *u_rindex(char *str, int ch); +/* scanf.c */ +extern int u_scanf(char *format, ...); +extern int u_fscanf(struct _iobuf *fp, char *format, ...); +extern int u_sscanf(char *str, char *format, ...); +/* setbuf.c */ +extern void u_setbuf(struct _iobuf *fp, char *buf); +extern void u_setfbf(struct _iobuf *fp, char *buf, int size); +extern void u_setlinebuf(struct _iobuf *fp); +/* spf.c */ +extern int spf_open(char *buf, int maxch); +extern void spf_close(int fd); +/* sprintf.c */ +extern char *u_sprintf(char *str, char *format, ...); +/* stgio.c */ +extern int c_stggetline(int fd, char *buf, int maxch); +extern int c_stgputline(int fd, char *buf); +/* strcat.c */ +extern char *u_strcat(char *s1, char *s2); +/* strcmp.c */ +extern int u_strcmp(char *s1, char *s2); +/* strdup.c */ +extern char *u_strdup(char *str); +/* strcpy.c */ +extern char *u_strcpy(char *s1, char *s2); +/* strlen.c */ +extern int u_strlen(char *s); +/* strncat.c */ +extern char *u_strnt(char *s1, char *s2, int n); +/* strncmp.c */ +extern int u_strnp(char *s1, char *s2, int n); +/* strncpy.c */ +extern char *u_strny(char *s1, char *s2, int n); +/* system.c */ +extern int u_system(char *cmd); +/* ungetc.c */ +extern int u_ungetc(int ch, struct _iobuf *fp); +/* zztest.c */ +extern int thello_(void); +extern int tprint_(void); +extern int tcopy_(void); +extern int tscan_(void); +extern int onint(int *code, int *old_handler); +extern int tgettk_(void); diff --git a/sys/libc/malloc.c b/sys/libc/malloc.c new file mode 100644 index 00000000..af5506cf --- /dev/null +++ b/sys/libc/malloc.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* MALLOC -- Allocate an uninitialized block of memory at least nbytes in size. +*/ +char * +malloc ( + unsigned nbytes +) +{ + XINT x_nchars = (nbytes + sizeof(XCHAR)-1) / sizeof(XCHAR); + XINT x_ptr, x_dtype = TY_CHAR; + + iferr (MALLOC (&x_ptr, &x_nchars, &x_dtype)) + return (NULL); + else + return ((char *)&Memc[x_ptr]); +} diff --git a/sys/libc/mathf.f b/sys/libc/mathf.f new file mode 100644 index 00000000..89279451 --- /dev/null +++ b/sys/libc/mathf.f @@ -0,0 +1,75 @@ +c +c MATH -- C callable math functions. This is the only portable way +c to access the Fortran intrinsic functions from C. As a local +c optimization it is possible to add defines to map these external +c names onto the local Fortran library functions, but since C is not +c generally used intensively for computations and all floating point +c is done in double precision anyway, it is probably not worth it. +c + + integer function xnint (x) + double precision x + xnint = nint (x) + end + + double precision function xexp (x) + double precision x + xexp = exp(x) + end + + double precision function xlog (x) + double precision x + xlog = log(x) + end + + double precision function xlog10 (x) + double precision x + xlog10 = log10(x) + end + + double precision function xpow (x, y) + double precision x + double precision y + xpow = x ** y + end + + double precision function xsqrt (x) + double precision x + xsqrt = sqrt(x) + end + + double precision function xsin (x) + double precision x + xsin = sin(x) + end + + double precision function xcos (x) + double precision x + xcos = cos(x) + end + + double precision function xtan (x) + double precision x + xtan = tan(x) + end + + double precision function xasin (x) + double precision x + xasin = asin(x) + end + + double precision function xacos (x) + double precision x + xacos = acos(x) + end + + double precision function xatan (x) + double precision x + xatan = atan(x) + end + + double precision function xatan2 (x, y) + double precision x + double precision y + xatan2 = atan2(x,y) + end diff --git a/sys/libc/mkpkg b/sys/libc/mkpkg new file mode 100644 index 00000000..74349a1a --- /dev/null +++ b/sys/libc/mkpkg @@ -0,0 +1,168 @@ +# Mkpkg for the IRAF runtime C library. There is an additional dependence +# on the global C include which is not shown. Those files which +# reference have an implicit dependence on the VOS include +# files and , since the LIBC stdio routines reference the +# FIO internal data structures directly. + +$checkout libc.a lib$ +$update libc.a +$checkin libc.a lib$ +$exit + +libc.a: + $set XFLAGS = "$(XFLAGS) -/Wall" + + atof.c \ + + atoi.c + atol.c + caccess.c + calloc.c + callocate.c + cclktime.c + cclose.c + ccnvdate.c + ccnvtime.c + cdelete.c + cenvget.c + cenvlist.c + cenvmark.c + cenvscan.c + cerract.c \ + + cerrcode.c + cerrget.c + cerror.c + cfchdir.c + cfilbuf.c \ + + cfinfo.c \ + + cflsbuf.c \ + + cflush.c + cfmapfn.c + cfmkdir.c + cfnextn.c + cfnldir.c + cfnroot.c + cfpath.c + cfredir.c + cfseti.c + cfstati.c + cgetpid.c + cgetuid.c + cgflush.c + cimaccess.c + cimdrcur.c + ckimapc.c + clexnum.c \ + + cmktemp.c + cnote.c + copen.c + coscmd.c + cndopen.c + cpoll.c \ + + cprcon.c \ + + cprdet.c + cprintf.c + crcursor.c + crdukey.c + cread.c \ + + crename.c + creopen.c + csalloc.c + cseek.c + csppstr.c + cstropen.c + cstrpak.c + cstrupk.c + ctsleep.c + cttset.c + cttycdes.c + cttyclear.c + cttyclln.c + cttyctrl.c + cttygetb.c + cttygeti.c + cttygetr.c + cttygets.c + cttygoto.c + cttyinit.c + cttyodes.c + cttyputl.c + cttyputs.c + cttyseti.c + cttyso.c + cttystati.c + ctype.c + cungetc.c + cungetl.c + cvfnbrk.c + cwrite.c \ + + cxgmes.c \ + + cxonerr.c + cxttysize.c + cxwhen.c \ + + cwmsec.c + eprintf.c + fclose.c \ + + fdopen.c + fflush.c \ + + fgetc.c + fgets.c + fopen.c \ + + fputc.c + fputs.c + fread.c + freadline.c + free.c + freopen.c + fseek.c + ftell.c + fwrite.c + gets.c + getw.c + index.c + isatty.c + malloc.c + mathf.f + mktemp.c + perror.c \ + + printf.c \ + + puts.c + putw.c + qsort.c + realloc.c + rewind.c + rindex.c + scanf.c + setbuf.c + stgio.c + strcat.c + strcmp.c + strdup.c + strcpy.c + strlen.c + strncat.c + strncmp.c + strncpy.c + spf.c + sprintf.c \ + + system.c + ungetc.c \ + + ; diff --git a/sys/libc/mktemp.c b/sys/libc/mktemp.c new file mode 100644 index 00000000..433e64ae --- /dev/null +++ b/sys/libc/mktemp.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#include + +/* MKTEMP -- Make a unique temporary file name. This procedure is syntactically +** equivalent to the UNIX procedure of the same name, but the XXXXXX are not +** required in the input filename. +*/ +char * +mktemp ( + char *template /* root filename, e.g., "tmp$xx" */ +) +{ + static char unique[SZ_FNAME]; + + if (c_mktemp (template, unique, SZ_FNAME) > 0) { + (void) strcpy (template, unique); + return (unique); + } else + return (NULL); +} diff --git a/sys/libc/perror.c b/sys/libc/perror.c new file mode 100644 index 00000000..53aa923a --- /dev/null +++ b/sys/libc/perror.c @@ -0,0 +1,36 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_xnames +#define import_stdio +#define import_libc +#include + +#define SZ_OSERRMSG 80 + +int sys_nerr; /* UNIX standard */ +char *sys_errlist[1]; /* UNIX standard */ +int u_oserrcode; +char u_oserrmsg[SZ_OSERRMSG+1]; + + +/* PERROR -- Print a short error message on the standard output describing +** the last system error (e.g., exception). The prefix string supplied +** as the argument is first printed, followed by an ":", followed by the +** system dependent error message describing the error. +*/ +void +perror ( + char *prefix /* prefix string */ +) +{ + u_oserrcode = c_errget (u_oserrmsg, SZ_OSERRMSG); + sys_nerr = 0; + sys_errlist[0] = u_oserrmsg; + + fputs (prefix, stderr); + fputs (": ", stderr); + fputs (u_oserrmsg, stderr); + fputc ('\n', stderr); +} diff --git a/sys/libc/printf.c b/sys/libc/printf.c new file mode 100644 index 00000000..03b155bb --- /dev/null +++ b/sys/libc/printf.c @@ -0,0 +1,245 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#define import_stdio +#define import_ctype +#define import_stdarg +#include + + +/* PRINTF -- Emulation of the UNIX printf facilities with the IRAF FMTIO +** interface as the backend. All features of the UNIX printf are supported +** without modification. Additional format codes are supported in conformance +** with the IRAF printf, e.g., hms format, variable radix, tabstops, etc., +** but these are upward compatible with standard UNIX usage. +*/ + +#define SZ_FMTSPEC 25 /* max size single format spec */ +#define SZ_OBUF SZ_COMMAND /* sz intermediate buffer */ +#define MAX_PREC 4 /* max "*" deferred args */ +#define NOARG (-1) /* % spec with no data value */ + + +/* PRINTF -- Formatted print to the standard output. +*/ +void +printf (char *format, ...) +{ + va_list argp; + void u_doprnt(); + + va_start (argp, format); + u_doprnt (format, &argp, stdout); + va_end (argp); +} + + +/* FPRINTF -- Formatted print to a file. +*/ +void +fprintf (FILE *fp, char *format, ...) +{ + va_list argp; + void u_doprnt(); + + va_start (argp, format); + u_doprnt (format, &argp, fp); + va_end (argp); +} + + +/* U_DOPRNT -- Process the format to the output file, taking arguments from +** the list pointed to by argp as % format specs are encountered in the input. +** The main point of this routine is to handle the variable number of arguments. +** The actual encoding is all handled by the IRAF FPRINF and PARG calls. +** N.B. we assume chars are stacked as ints, and floats are stacked as doubles. +*/ +void +u_doprnt ( + char *format, /* "%w.dC" etc. format spec */ + va_list *argp, /* pointer to first value arg */ + FILE *fp /* output file */ +) +{ + register int ch; /* next format char reference */ + XCHAR formspec[SZ_FMTSPEC]; /* copy of single format spec */ + XCHAR *fsp; /* pointer into formspec */ + int done, dotseen; /* one when at end of a format */ + int varprec; /* runtime precision is used */ + int prec[MAX_PREC]; /* values of prec args */ + + void u_doarg (); + + + while ( (ch = *format++) ) { + if (ch == '%') { + fsp = formspec; + *fsp++ = ch; + varprec = 0; + dotseen = 0; + done = 0; + + while (!done) { + ch = *fsp++ = *format++; + + switch (ch) { + case EOS: + --format; + done++; + break; + + case 'l': + /* arg size modifier; ignored for now */ + fsp--; + break; + + case '*': + prec[varprec++] = va_arg ((*argp), int); + break; + + case '.': + dotseen++; + break; + + case 'r': /* nonstandard UNIX */ + if ((ch = *fsp++ = *format++) == '*') { + int radix; + int radchar; + + radix = va_arg ((*argp), int); + if (radix < 0) + radchar = 'A'; + else if (radix > 9) + radchar = radix - 10 + 'A'; + else + radchar = todigit (radix); + *(fsp-1) = radchar; + } else if (ch == EOS) { + --format; + break; + } + /* fall through */ + + case 'b': /* nonstandard UNIX */ + case 'c': + case 'd': + case 'o': + case 'x': + case 'u': + *fsp = EOS; + u_doarg (fp, formspec, &argp, prec, varprec, TY_INT); + done++; + break; + + case 'E': /* ANSI emulation */ + *(fsp-1) = 'e'; + goto rval; + case 'G': /* ANSI emulation */ + *(fsp-1) = 'g'; + goto rval; + + case 'z': /* nonstandard UNIX */ + case 'h': /* nonstandard UNIX */ + case 'H': /* nonstandard UNIX */ + case 'm': /* nonstandard UNIX */ + case 'M': /* nonstandard UNIX */ + case 'e': + case 'f': + case 'g': + /* If no precision was specified, default to 14 digits + * for %[efgz] and 3 digits for %[hm]. + */ +rval: if (!dotseen) { + *(fsp-1) = '.'; + if (ch == 'h' || ch == 'm' || + ch == 'H' || ch == 'M') { + *fsp++ = '3'; + } else { + *fsp++ = '1'; + *fsp++ = '4'; + } + *fsp++ = ch; + } + + *fsp = XEOS; + u_doarg (fp, formspec, &argp, prec, varprec, TY_DOUBLE); + done++; + break; + + case 's': + *fsp = EOS; + u_doarg (fp, formspec, &argp, prec, varprec, TY_CHAR); + done++; + break; + + case 't': /* nonstandard UNIX */ + case 'w': /* nonstandard UNIX */ + *fsp = EOS; + u_doarg (fp, formspec, &argp, prec, varprec, NOARG); + done++; + break; + + case '%': + putc (ch, fp); + done++; + break; + } + } + + } else + putc (ch, fp); + } +} + + +/* U_DOARG -- Encode a single argument acording to the simplified format +** specification given by formspec. This is the interface to the IRAF +** formatted output procedures. +*/ +void +u_doarg (fp, formspec, argp, prec, varprec, dtype) +FILE *fp; /* output file */ +XCHAR *formspec; /* format string */ +va_list **argp; /* pointer to data value */ +int prec[]; /* varprec args, if any */ +int varprec; /* number of varprec args */ +int dtype; /* datatype of data value */ +{ + register int p; + XCHAR sbuf[SZ_OBUF+1]; + XINT fd = fileno (fp); + XINT ival; + XDOUBLE dval; + char *cptr; + + + /* Pass format string and any variable precision arguments. + */ + FPRINTF (&fd, formspec); + for (p=0; p < varprec; p++) { + ival = prec[p]; + PARGI (&ival); + } + + /* Pass the data value to be encoded, bump argument pointer by the + * size of the data object. If there is no data value the case + * is a no-op. + */ + switch (dtype) { + case TY_INT: + ival = va_arg ((**argp), int); + PARGI (&ival); + break; + case TY_DOUBLE: + dval = va_arg ((**argp), double); + PARGD (&dval); + break; + case TY_CHAR: + cptr = va_arg ((**argp), char *); + PARGSTR (c_strupk (cptr, sbuf, SZ_OBUF)); + break; + } +} diff --git a/sys/libc/puts.c b/sys/libc/puts.c new file mode 100644 index 00000000..246b7bf6 --- /dev/null +++ b/sys/libc/puts.c @@ -0,0 +1,25 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_stdio +#include + + +/* PUTS -- Put a null terminated string to the standard output, followed by a +** newline. +*/ +int +puts ( + char *str /* input string */ +) +{ + register FILE *fp = stdout; + register char *ip; + + + for (ip=str; *ip != EOS; ip++) + putc (*ip, fp); + return (putc ('\n', fp)); +} diff --git a/sys/libc/putw.c b/sys/libc/putw.c new file mode 100644 index 00000000..d5cf6d8a --- /dev/null +++ b/sys/libc/putw.c @@ -0,0 +1,27 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_stdio +#include + +/* PUTW -- Put a word (integer) to the output stream. When used in conjunction +** with GETW this permits storage and retrieval of binary words to any file, +** albeit somewhat inefficiently. +*/ +int +putw ( + int word, /* data word to be output */ + FILE *fp /* output file */ +) +{ + register char *ip; + register int n = sizeof (int); + + + for (ip=(char *)&word; --n >= 0; ip++) + putc (*ip, fp); + + return (ferror(fp) ? EOF : word); +} diff --git a/sys/libc/qsort.c b/sys/libc/qsort.c new file mode 100644 index 00000000..345fc3bd --- /dev/null +++ b/sys/libc/qsort.c @@ -0,0 +1,221 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +/* +** Copyright (c) 1980 Regents of the University of California. +** All rights reserved. +** +** Redistribution and use in source and binary forms are permitted +** provided that the above copyright notice and this paragraph are +** duplicated in all such forms and that any documentation, +** advertising materials, and other materials related to such +** distribution and use acknowledge that the software was developed +** by the University of California, Berkeley. The name of the +** University may not be used to endorse or promote products derived +** from this software without specific prior written permission. +** THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR +** IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED +** WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. +*/ + +#define import_libc +#include + +/* +** QSORT -- Quicker sort. Adapted from the BSD sources. +*/ + +#define THRESH 4 /* threshold for insertion */ +#define MTHRESH 6 /* threshold for median */ + +static int (*qcmp)(); /* the comparison routine */ +static int qsz; /* size of each record */ +static int thresh; /* THRESHold in chars */ +static int mthresh; /* MTHRESHold in chars */ +static void qst(); + + +/* QSORT -- First, set up some global parameters for qst to share. Then, +** quicksort with qst(), and then a cleanup insertion sort ourselves. +** Sound simple? It's not... +*/ +void +qsort ( + char *base, + int n, + int size, + int (*compar)() +) +{ + register char c, *i, *j, *lo, *hi; + char *minval, *maxval; + + + if (n <= 1) + return; + + qsz = size; + qcmp = compar; + thresh = qsz * THRESH; + mthresh = qsz * MTHRESH; + maxval = base + n * qsz; + + if (n >= THRESH) { + qst (base, maxval); + hi = base + thresh; + } else + hi = maxval; + + /* First put smallest element, which must be in the first THRESH, in + * the first position as a sentinel. This is done just by searching + * the first THRESH elements (or the first n if n < THRESH), finding + * the min, and swapping it into the first position. + */ + for (j=lo=base; (lo += qsz) < hi; ) + if ((*qcmp)(j, lo) > 0) + j = lo; + if (j != base) { + /* Swap j into place */ + for (i=base, hi=base+qsz; i < hi; ) { + c = *j; + *j++ = *i; + *i++ = c; + } + } + + /* With our sentinel in place, we now run the following hyper-fast + * insertion sort. For each remaining element, min, from [1] to [n-1], + * set hi to the index of the element AFTER which this one goes. + * Then, do the standard insertion sort shift on a character at a time + * basis for each element in the frob. + */ + for (minval=base; (hi = minval += qsz) < maxval; ) { + while ((*qcmp) (hi -= qsz, minval) > 0) + /* void */; + if ((hi += qsz) != minval) { + for (lo = minval + qsz; --lo >= minval; ) { + c = *lo; + for (i=j=lo; (j -= qsz) >= hi; i=j) + *i = *j; + *i = c; + } + } + } +} + + +/* QST -- Do a quicksort. + * First, find the median element, and put that one in the first place as the + * discriminator. (This "median" is just the median of the first, last and + * middle elements). (Using this median instead of the first element is a big + * win). Then, the usual partitioning/swapping, followed by moving the + * discriminator into the right place. Then, figure out the sizes of the two + * partions, do the smaller one recursively and the larger one via a repeat of + * this code. Stopping when there are less than THRESH elements in a partition + * and cleaning up with an insertion sort (in our caller) is a huge win. + * All data swaps are done in-line, which is space-losing but time-saving. + * (And there are only three places where this is done). + */ +static void +qst ( + char *base, + char *maxval +) +{ + register char c, *i, *j, *jj; + register int ii; + char *mid, *tmp; + int lo, hi; + + /* At the top here, lo is the number of characters of elements in the + * current partition. (Which should be maxval - base). + * Find the median of the first, last, and middle element and make + * that the middle element. Set j to largest of first and middle. + * If maxval is larger than that guy, then it's that guy, else compare + * maxval with loser of first and take larger. Things are set up to + * prefer the middle, then the first in case of ties. + */ + lo = maxval - base; /* number of elements as chars */ + + do { + mid = i = base + qsz * ((lo / qsz) >> 1); + if (lo >= mthresh) { + j = ((*qcmp)((jj = base), i) > 0 ? jj : i); + if ((*qcmp)(j, (tmp = maxval - qsz)) > 0) { + /* switch to first loser */ + j = (j == jj ? i : jj); + if ((*qcmp)(j, tmp) < 0) + j = tmp; + } + if (j != i) { + ii = qsz; + do { + c = *i; + *i++ = *j; + *j++ = c; + } while (--ii); + } + } + + /* Semi-standard quicksort partitioning/swapping + */ + for (i = base, j = maxval - qsz; ; ) { + while (i < mid && (*qcmp)(i, mid) <= 0) + i += qsz; + while (j > mid) { + if ((*qcmp)(mid, j) <= 0) { + j -= qsz; + continue; + } + tmp = i + qsz; /* value of i after swap */ + if (i == mid) { + /* j <-> mid, new mid is j */ + mid = jj = j; + } else { + /* i <-> j */ + jj = j; + j -= qsz; + } + goto swap; + } + + if (i == mid) { + break; + } else { + /* i <-> mid, new mid is i */ + jj = mid; + tmp = mid = i; /* value of i after swap */ + j -= qsz; + } + + swap: + ii = qsz; + do { + c = *i; + *i++ = *jj; + *jj++ = c; + } while (--ii); + i = tmp; + } + + /* Look at sizes of the two partitions, do the smaller + * one first by recursion, then do the larger one by + * making sure lo is its size, base and maxval are update + * correctly, and branching back. But only repeat + * (recursively or by branching) if the partition is + * of at least size THRESH. + */ + i = (j = mid) + qsz; + if ((lo = j - base) <= (hi = maxval - i)) { + if (lo >= thresh) + qst(base, j); + base = i; + lo = hi; + } else { + if (hi >= thresh) + qst(i, maxval); + maxval = j; + } + + } while (lo >= thresh); +} diff --git a/sys/libc/realloc.c b/sys/libc/realloc.c new file mode 100644 index 00000000..21446345 --- /dev/null +++ b/sys/libc/realloc.c @@ -0,0 +1,28 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* REALLOC -- Reallocate a buffer, i.e., change the size of an already +** allocated buffer. If necessary the buffer is moved, preserving any +** data in the buffer. +*/ +char * +realloc ( + char *buf, + unsigned newsize +) +{ + XINT x_nchars = (newsize + sizeof(XCHAR)-1) / sizeof(XCHAR); + XINT x_ptr, x_dtype = TY_CHAR; + + x_ptr = buf ? Memcptr(buf) : NULL; + iferr (REALLOC (&x_ptr, &x_nchars, &x_dtype)) + return (NULL); + else + return ((char *)&Memc[x_ptr]); +} diff --git a/sys/libc/rewind.c b/sys/libc/rewind.c new file mode 100644 index 00000000..0185916c --- /dev/null +++ b/sys/libc/rewind.c @@ -0,0 +1,19 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_stdio +#include + + +/* REWIND -- Position the named stream to beginning of file, i.e., arrange +** for the next read or write to read or write the first byte of the file. +*/ +long +rewind ( + FILE *fp /* operand file */ +) +{ + return ((long) fseek (fp, 0L, 0)); +} diff --git a/sys/libc/rindex.c b/sys/libc/rindex.c new file mode 100644 index 00000000..74169120 --- /dev/null +++ b/sys/libc/rindex.c @@ -0,0 +1,27 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_libc +#define import_spp +#include + + +/* RINDEX -- Search string STR for char CH, returning a pointer to the last +** occurrence of CH in STR or NULL. +*/ +char * +rindex ( + char *str, /* string to be searched */ + int ch /* character we are searching for */ +) +{ + register char *ip = str; + register char *last = NULL; + + do { + if (*ip == ch) + last = ip; + } while (*ip++); + + return (last); +} diff --git a/sys/libc/scanf.c b/sys/libc/scanf.c new file mode 100644 index 00000000..1ada2000 --- /dev/null +++ b/sys/libc/scanf.c @@ -0,0 +1,558 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_stdio +#define import_ctype +#define import_stdarg +#include + + +/* +** SCANF -- Formatted input. The syntax of the calls and of the format strings +** are UNIX standard, but the lexical forms of numbers recognized are IRAF +** standard. +*/ + +#define SCAN_STRING 0 +#define SCAN_FILE 1 +#define SZ_NUMBUF 256 /* maximum numeric field len */ +#define SZ_UCC 128 /* maximum size user char class */ +#define HUGE 999 +#define ISHEX(c) ((c >= 'a' && c <= 'f') || (c >= 'A' && c <= 'F')) + +struct _format { + int f_type; /* field type (doxscef[%) */ + int f_skipfield; /* skip next field scanned */ + int f_width; /* max chars in field */ + int f_longword; /* output longword */ + int f_halfword; /* output halfword */ + int f_delimset; /* ucc chars are delimiters */ + char f_ucc[SZ_UCC+1]; +}; + +/* Character input including pushback. Character input may come either from +** a file or from a string, depending on the value of the "intype" flag. +** We cannot open the string as a file because file buffer characters are +** of type XCHAR. +*/ +struct _input { + int i_type; /* file input if !0, else str */ + int i_nchars; /* nchars read thus far */ + union { + FILE *fp; /* file pointer if file */ + char *ip; /* char pointer if string */ + } u; +}; + +#define input()\ + (in->i_nchars++, in->i_type ? (int)getc(in->u.fp) : (int)*in->u.ip++) +#define unput(ch)\ + (in->i_nchars--, in->i_type ? ungetc((ch),in->u.fp) : (int)(*--(in->u.ip))) +#define ateof()\ + (in->i_type ? feof(in->u.fp) : *(in->u.ip-1) == EOS) + + +static int u_doscan (struct _input *in, char *format, va_list *argp); +static char *u_crackformat (char *format, struct _format *fmt); +static int u_scannum (struct _input *in, va_list **argp, + struct _format *fmt, int *eofflag); +static char *u_setucc (char *format, struct _format *fmt); +static int u_scanstr (struct _input *in, va_list **argp, + struct _format *fmt, int *eofflag); + + + +/* SCANF -- Scan the standard input. The output arguments must be +** pointers. The number of fields successfully converted is returned as +** the function value. EOF is returned for a scan at EOF. +*/ +int +scanf (char *format, ...) +{ + va_list argp; + struct _input in; + int status; + + extern int u_doscan(); + + + va_start (argp, format); + in.i_type = SCAN_FILE; + in.i_nchars = 0; + in.u.fp = stdin; + + status = u_doscan (&in, format, &argp); + va_end (argp); + return (status); +} + + +/* FSCANF -- Formatted scan from a file. +*/ +int +fscanf (FILE *fp, char *format, ...) +{ + va_list argp; + int status; + struct _input in; + + extern int u_doscan(); + + + va_start (argp, format); + in.i_type = SCAN_FILE; + in.i_nchars = 0; + in.u.fp = fp; + + status = u_doscan (&in, format, &argp); + + va_end (argp); + return (status); +} + + +/* SSCANF -- Formatted scan from a string. +*/ +int +sscanf (char *str, char *format, ...) +{ + va_list argp; + struct _input in; + int status; + + extern int u_doscan(); + + + va_start (argp, format); + in.i_type = SCAN_STRING; + in.i_nchars = 0; + in.u.ip = str; + + status = u_doscan (&in, format, &argp); + + va_end (argp); + return (status); +} + + +/* U_DOSCAN -- Step along the format string, processing each %[*][w][lh]C +** field specification and returning each argument using the pointer +** supplied in the argument list. Ordinary characters appearing in the format +** string must match actual characters in the input stream. Input may be +** taken from either a string or a file. The technique used to handle the +** variable number of arguments is machine dependent. +*/ +static int +u_doscan ( + struct _input *in, /* input descriptor */ + char *format, /* format string */ + va_list *argp /* pointer to first argument */ +) +{ + register int ch; + struct _format fmt; + int nscan = 0, match; + int eofflag = 0; + char *u_crackformat(), *u_setucc(); + int u_scanstr(), u_scannum(); + + + while ( (ch = *format++) ) { + if (ch == '%' && *format != '%') { + /* Parse format specification. + */ + format = u_crackformat (format, &fmt); + + /* Extract, decode, and output the next field according to + * the field specification just generated. + */ + ch = *format++; + if (ch == 'n') { + *(va_arg ((*argp), int *)) = in->i_nchars; + continue; + } else if (ch == '[') { + format = u_setucc (format, &fmt); + } else if (isupper (ch)) { + fmt.f_longword++; + ch = tolower (ch); + } + if (ch <= 0) + return (EOF); + fmt.f_type = ch; + + if (ch == 's' || ch == 'c' || ch == '[') + match = u_scanstr (in, &argp, &fmt, &eofflag); + else + match = u_scannum (in, &argp, &fmt, &eofflag); + + if (match && !fmt.f_skipfield) + nscan++; + if (eofflag) + break; + + } else if (isspace (ch)) { + /* Skip optional whitespace. */ + while (isspace (ch = input())) + ; + if (ateof()) { + eofflag++; + break; + } + unput (ch); + + } else { + /* Match normal character. */ + if (ch == '%') + format++; + match = ch; + if (match != (ch = input())) { + if (ateof()) + eofflag++; + else + unput (ch); + break; + } + } + } + + if (eofflag) + return (nscan ? nscan : EOF); + else + return (nscan); +} + + + +/* U_CRACKFORMAT -- Decode a %[*][w][lh]C input field format specification, + * returning the decoded format parameters in the output structure fmt. + * The number of format characters is returned as the function value. The + * format string pointer is left pointing at the C character. + */ +static char * +u_crackformat ( + char *format, /* pointer to %+1 in format string */ + struct _format *fmt /* output format descriptor */ +) +{ + register int ch; + register int width = 0; + + + fmt->f_skipfield = 0; + fmt->f_longword = 0; + fmt->f_halfword = 0; + + /* Skip output if "*" present. */ + ch = *format++; + if (ch == '*') { + fmt->f_skipfield++; + ch = *format++; + } + + /* Get max field width, if any. */ + while (isdigit (ch)) { + width = width * 10 + tointeg (ch); + ch = *format++; + } + fmt->f_width = (width == 0) ? HUGE : width; + + /* Datatype size modifier. */ + if (ch == 'l') { + fmt->f_longword++; + ch = *format++; + } else if (ch == 'h') { + fmt->f_halfword++; + ch = *format++; + } + + return (--format); +} + + +/* U_SCANNUM -- Extract a numeric token from the input stream. The lexical +** range of numbers recognized is as follows (ignoring leading +-): +** +** INDEF all types +** [0-7]+ o +** [0-9]+ d +** [0-9][0-9a-fA-F]* x +** '.'[0-9]+([eEdD]([+-])?[0-9]+)? f,e +** [0-9][0-9:]'.'[0-9]+([eEdD]([+-])?[0-9]+)? f,e (sexagesimal) +** +** If the conversion fails the token is pushed back into the input, ready +** to be rescanned. Argp is bumped if skipfield is false whether or not +** a legal number is matched (else one might assign a string to a pointer +** to int in the next format, overruning memory). If the match fails 0 is +** output to argp and 0 is returned as the function value, indicating no +** match. +*/ +static int +u_scannum ( + struct _input *in, /* input descriptor */ + va_list **argp, /* where output goes */ + struct _format *fmt, /* format descriptor */ + int *eofflag /* set to 1 on output if end of input */ +) +{ + char numbuf[SZ_NUMBUF+1]; + register int ch; + register long num = 0; + register char *op = numbuf; + int floating = 0, radix=10, n; + int neg=0, ndigits=0, match=1; + int dotseen=0, expseen=0; + + + ch = fmt->f_type; + n = fmt->f_width; + + if (ch == 'd') + radix = 10; + else if (ch == 'o') + radix = 8; + else if (ch == 'x') + radix = 16; + else if ( (floating = (ch == 'f' || ch == 'e' || ch == 'g') )) { + radix = 10; + dotseen = expseen = 0; + } + + while (isspace ( (ch = input()) )) + ; + + if (ch == '-' || ch == '+') { + if (ch == '-') { + neg++; + *op++ = ch; + } + ch = input(); + --n; + } + + /* Check for INDEF. Abbreviations are not permitted; if the match + * fails the input must be restored. + */ + if (ch == 'I' && op == numbuf && n >= 5) { + char *ip = "INDEF"; + + for (n=5; --n >= 0 && (ch == *ip++); ch=input()) + *op++ = ch; + *op = EOS; + if (!ateof()) + unput (ch); + + if (n < 0) { + /* If the 6th char is not a legal character in an identifier + * then we have a match. + */ + if (! (isalnum (ch) || ch == '_')) { + if (fmt->f_skipfield) + return (1); + else if (floating) + goto out_; + else { + if (fmt->f_longword) + *(va_arg ((**argp), long *)) = INDEFL; + else if (fmt->f_halfword) + *(va_arg ((**argp), short *)) = INDEFS; + else + *(va_arg ((**argp), int *)) = INDEFI; + return (1); + } + } + } + + /* No match; neither INDEF nor a number. Push back chars and exit. + * (the FIO ungetc may be called repeatedly). + */ + for (--op; op >= numbuf; --op) + unput (*op); + + match = 0; + num = 0; + numbuf[0] = '0'; + goto out_; + } + + /* Extract token into numbuf. If the token contains only digits it + * will have been converted to binary and left in the variable num. + */ + for (*op++ = ch; --n >= 0; *op++ = ch = input()) { + if (isdigit (ch)) { + ch = tointeg (ch); + if (ch >= radix) + break; + ndigits++; + num = num * radix + ch; + + } else if (radix == 16 && ISHEX(ch)) { + if (isupper (ch)) + ch = tolower (ch); + ndigits++; + num = num * 16 + ch - 'a' + 10; + + } else if (ch == '.') { + if (!floating || dotseen) + break; + dotseen++; + } else if (ch == ':') { + if (!floating || ndigits == 0 || dotseen || expseen) + break; + + } else if (ch == 'e' || ch == 'E' || ch == 'd' || ch == 'D') { + if (!floating || expseen || (ndigits == 0 && !dotseen)) + break; + expseen++; + *op++ = ch = input(); + if (! (ch == '+' || ch == '-' || isdigit(ch))) + break; + + } else + break; + } + + *--op = EOS; + if (ateof()) + *eofflag = 1; + else + unput (ch); + + if (ndigits == 0) + match = 0; /* not a number */ + if (neg) + num = -num; +out_: + if (fmt->f_skipfield) + return (match); + + /* Output value. + */ + if (floating) { + float rval; + double dval, atof(); + + if (fmt->f_longword) { + *(va_arg ((**argp), double *)) = atof (numbuf); + } else if (fmt->f_halfword) { + dval = atof (numbuf); + rval = (dval == INDEFD) ? INDEFR : dval; + *(va_arg ((**argp), float *)) = rval; + } else + *(va_arg ((**argp), double *)) = atof (numbuf); + } else { + if (fmt->f_longword) + *(va_arg ((**argp), long *)) = num; + else if (fmt->f_halfword) + *(va_arg ((**argp), short *)) = num; + else + *(va_arg ((**argp), int *)) = num; + } + + return (match); +} + + +/* U_SETUCC -- Extract a user defined character class from the format string. +** A full 128 char table is not used since it is more expensive to prepare +** than it is worth for small sets. +*/ +static char * +u_setucc ( + char *format, + struct _format *fmt +) +{ + register char *op = fmt->f_ucc; + register int n = SZ_UCC; + + fmt->f_delimset = (*format == '^') ? *format++ : 0; + while (--n && *format && (*op = *format++) != ']') { + if (*op == '\\' && *format == ']') + *op = *format++; + op++; + } + *op = EOS; + + return (format); +} + + + +/* U_SCANSTR -- Extract a whitespace delimited sequence of characters. +*/ +static int +u_scanstr ( + struct _input *in, /* input descriptor */ + va_list **argp, /* output arglist */ + struct _format *fmt, /* numeric format expected */ + int *eofflag /* set to 1 on output if end of input */ +) +{ + register int ch, n; + register char *ip, *op; + int delimset; + char *ucc = ""; + + + op = fmt->f_skipfield ? (char *)NULL : va_arg ((**argp), char *); + ch = fmt->f_type; + n = fmt->f_width; + if (ch == 'c' && n == HUGE) + n = 1; + + /* Set up character class to be matched. + */ + delimset = 1; + if (ch == 'c') + ucc = ""; + else if (ch == 's') + ucc = " \t\n"; + else if (ch == '[') { + ucc = fmt->f_ucc; + delimset = fmt->f_delimset; + } + + /* Skip leading whitespace only for format %s. + */ + if (ch == 's') { + while (isspace (ch = input())) + ; + } else + ch = input(); + + /* Extract chars matching set into output buffer. + */ + while (--n >= 0 && (ch > 0 || !ateof())) { + /* Is char in set ucc. */ + for (ip=ucc; *ip != EOS; ip++) + if (ch == *ip) { + if (delimset) + goto done_; + if (op) + *op++ = ch; + goto next_; + } + + /* Char not in set if we get here. */ + if (delimset) { + if (op) + *op++ = ch; + } else + break; +next_: + ch = input(); + } +done_: + if (ateof()) + *eofflag = 1; + else { + unput (ch); + } + + if (op && fmt->f_type != 'c') + *op = EOS; + + return (1); +} diff --git a/sys/libc/setbuf.c b/sys/libc/setbuf.c new file mode 100644 index 00000000..845c9f9d --- /dev/null +++ b/sys/libc/setbuf.c @@ -0,0 +1,68 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_stdio +#define import_fset +#include + + +/* SETBUF -- Assign a buffer to be used by the i/o system to access a file. +** Should be called after opening the file but before doing any i/o. +*/ +void +setbuf ( + FILE *fp, + char *buf +) +{ + void setbuffer(); + + setbuffer (fp, buf, BUFSIZ); +} + + +/* SETBUFFER -- Assign a buffer of arbitrary size to be used by the i/o system +** to access a file. Should be called after opening the file but before doing +** any i/o. If the the pointer buf has the value NULL, i/o is unbuffered +** (or as close to unbuffered as we can manage). +*/ +void +setbuffer ( + FILE *fp, + char *buf, + int size +) +{ + register XINT fd = fileno(fp); + + + if (buf == NULL) + c_fseti (fd, F_BUFSIZE, 1); + else { + c_fseti (fd, F_BUFPTR, Memcptr(buf)); + c_fseti (fd, F_BUFSIZE, size); + } +} + + +/* SETLINEBUF -- Set line buffered mode for a file. A line buffered file + * buffers each line and flushes it to the output device when newline is + * seen. We may be even after doing i/o to the file. + */ +void +setlinebuf ( + FILE *fp +) +{ + register XINT fd = fileno(fp); + + extern int c_fstati(); + extern void c_fseti(); + + + if (c_fstati (fd, F_BUFSIZE) < SZ_LINE) + c_fseti (fd, F_BUFSIZE, SZ_LINE); + c_fseti (fd, F_FLUSHNL, YES); +} diff --git a/sys/libc/spf.c b/sys/libc/spf.c new file mode 100644 index 00000000..2953ed76 --- /dev/null +++ b/sys/libc/spf.c @@ -0,0 +1,65 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* +** SPF.C -- String spoolfile utility package. Used to capture in a string +** buffer the output of a routine set up to write to a file. +** +** Example: +** +** fd = spf_open (buf, maxch) +** fprop (pp, fdopen(fd,"w")); +** spf_close (fd); +** +** leaves the output of the fprop() function in the user buffer "buf". +*/ + +static XCHAR *spf_buf; +static char *spf_userbuf; +static int spf_maxch; + + +/* SPF_OPEN -- Spoolfile open. Open a string spoolfile to be written into as +** a file, using ordinary file i/o. Only one such file can be open at a time. +*/ +int +spf_open ( + char *buf, /* user string buffer */ + int maxch /* max chars of storage */ +) +{ + XINT x_maxch = maxch, x_mode = NEW_FILE; + char *malloc(); + + + spf_userbuf = buf; + spf_maxch = maxch; + + /* Malloc always returns a buffer which aligned to at least XCHAR. */ + spf_buf = (XCHAR *) malloc ((maxch + 1) * sizeof(XCHAR)); + + return (STROPEN (spf_buf, &x_maxch, &x_mode)); +} + + +/* SPF_CLOSE -- Close the spoolfile string, which should have been written +** into via file i/o while the string was open. This leaves SPP chars in +** the string; pack the string and return a pointer to the string. +*/ +void +spf_close ( + XINT fd /* file descriptor of stringbuf */ +) +{ + XINT x_fd = fd; + + CLOSE (&x_fd); + c_strpak (spf_buf, spf_userbuf, spf_maxch); + free ((char *)spf_buf); +} diff --git a/sys/libc/sprintf.c b/sys/libc/sprintf.c new file mode 100644 index 00000000..24d408a0 --- /dev/null +++ b/sys/libc/sprintf.c @@ -0,0 +1,58 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#define import_stdio +#define import_stdarg +#include + +#define SZ_OBUF SZ_COMMAND /* sz intermediate buffer */ + + +/* SPRINTF -- Formatted print to a string. If char and XCHAR are the +** same size we open the output string as a file and write directly into +** it. Otherwise we must write into an intermediate buffer, then pack +** XCHAR into the char output string. This is not as bad as it sounds +** as the operation is negligible compared to the encoding operation. +*/ +char * +sprintf (char *str, char *format, ...) +{ + register XCHAR *ip; + register char *op; + XCHAR obuf[SZ_OBUF], *fiobuf; + XINT x_fd, x_maxch = SZ_OBUF, x_mode = NEW_FILE; + va_list argp; + + extern int u_doprnt(); + + + va_start (argp, format); + + /* Select output buffer. */ + if (sizeof (XCHAR) == sizeof (char)) + fiobuf = (XCHAR *)str; + else + fiobuf = obuf; + + /* Make it the file buffer. Call FIO to open the string as a file. + */ + x_fd = STROPEN (fiobuf, &x_maxch, &x_mode); + + /* Format the data into obuf. */ + u_doprnt (format, &argp, FDTOFP(x_fd)); + + /* FIO does not write the EOS until the string file is closed. + * Move obuf to str if it is not already there. + */ + CLOSE (&x_fd); + if (fiobuf == obuf) + for (ip=obuf, op=str; (*op++ = *ip++) != EOS; ) + ; + + va_end (argp); + + return (str); +} diff --git a/sys/libc/stgio.c b/sys/libc/stgio.c new file mode 100644 index 00000000..498a020a --- /dev/null +++ b/sys/libc/stgio.c @@ -0,0 +1,60 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#include + + +/* STGIO.C -- STDGRAPH graphics terminal i/o interface. This is a C binding +** for the VOS STDGRAPH graphics kernel text i/o routines. These are used to +** do direct i/o to the graphics terminal, whether or not the terminal is in +** graphics mode. When the terminal is not in graphics mode, i.e., when the +** "workstation is deactivated", these routines are equivalent to the FIO +** putline and getline procedures. +** +** nchars|EOF = c_stggetline (STDIN, buf) +** c_stgputline (STDOUT, buf) +*/ + + +/* C_STGGETLINE -- Get a line of text from the graphics terminal. +*/ +int +c_stggetline ( + XINT fd, /* input stream */ + char *buf, /* user string buffer */ + int maxch /* max bufer size */ +) +{ + XCHAR xbuf[maxch+1]; + XINT x_fd = fd; + int status; + + iferr (status = STG_GETLINE (&x_fd, xbuf)) + return (EOF); + else { + c_strpak (xbuf, buf, maxch); + return (status); + } +} + + +/* C_STGPUTLINE -- Put a line of text to the graphics terminal. +*/ +int +c_stgputline ( + XINT fd, /* input stream */ + char *buf /* user string buffer */ +) +{ + XCHAR xbuf[SZ_LINE+1]; + XINT x_fd = fd; + + c_strupk (buf, xbuf, SZ_LINE); + iferr (STG_PUTLINE (&x_fd, xbuf)) + return (ERR); + else + return (OK); +} diff --git a/sys/libc/strcat.c b/sys/libc/strcat.c new file mode 100644 index 00000000..49798ba0 --- /dev/null +++ b/sys/libc/strcat.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_libc +#include + + +/* STRCAT -- Concatenate S2 onto S1. +*/ +char * +strcat ( + char *s1, /* output string */ + char *s2 /* string to be appended */ +) +{ + register char *ip, *op; + + for (op=s1; *op++; ) + ; + for (--op, ip=s2; (*op++ = *ip++); ) + ; + + return (s1); +} diff --git a/sys/libc/strcmp.c b/sys/libc/strcmp.c new file mode 100644 index 00000000..7b7dc54a --- /dev/null +++ b/sys/libc/strcmp.c @@ -0,0 +1,22 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_libc +#include + + +/* STRCMP -- Compare two strings. -N is returned if S1 < S2, 0 if S1 == S2, +** and +N if S1 > S2. +*/ +int +strcmp ( + char *s1, + char *s2 +) +{ + while (*s1 == *s2++) + if (*s1++ == '\0') + return (0); + + return (*s1 - *--s2); +} diff --git a/sys/libc/strcpy.c b/sys/libc/strcpy.c new file mode 100644 index 00000000..cbc072f0 --- /dev/null +++ b/sys/libc/strcpy.c @@ -0,0 +1,21 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_libc +#include + +/* STRCPY -- Copy string S2 to S1. +*/ +char * +strcpy ( + char *s1, /* output string */ + char *s2 /* string to be moved */ +) +{ + register char *ip, *op; + + for (ip=s2, op=s1; (*op++ = *ip++); ) + ; + + return (s1); +} diff --git a/sys/libc/strdup.c b/sys/libc/strdup.c new file mode 100644 index 00000000..4568d89f --- /dev/null +++ b/sys/libc/strdup.c @@ -0,0 +1,22 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_libc +#include + +/* STRDUP -- Save a copy of a string. +*/ +char * +strdup ( + char *str /* string to copy */ +) +{ + register char *ip, *op, *out; + int len = strlen (str); + + out = calloc (1, strlen (str) + 1); + for (ip=str, op=out; (*op++ = *ip++); ) + ; + + return (out); +} diff --git a/sys/libc/strlen.c b/sys/libc/strlen.c new file mode 100644 index 00000000..c6c2f813 --- /dev/null +++ b/sys/libc/strlen.c @@ -0,0 +1,21 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_libc +#include + + +/* STRLEN -- Length of a string. +*/ +int +strlen ( + char *s +) +{ + register char *ip=s; + + while (*ip++) + ; + + return (ip - s - 1); +} diff --git a/sys/libc/strncat.c b/sys/libc/strncat.c new file mode 100644 index 00000000..9deae4eb --- /dev/null +++ b/sys/libc/strncat.c @@ -0,0 +1,26 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_libc +#include + + +/* STRNCAT -- Concatenate at most N chars from S2 onto S1. +*/ +char * +strncat ( + char *s1, /* output string */ + char *s2, /* string to be appended */ + int n /* max length of S1 */ +) +{ + register char *ip, *op; + + for (op=s1; *op++; ) + ; + for (--op, ip=s2; (*op++ = *ip++) && --n >= 0; ) + ; + *--op = '\0'; + + return (s1); +} diff --git a/sys/libc/strncmp.c b/sys/libc/strncmp.c new file mode 100644 index 00000000..089df283 --- /dev/null +++ b/sys/libc/strncmp.c @@ -0,0 +1,22 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_libc +#include + +/* STRNCMP -- Compare up to the first N characters of two strings. -N is +** returned if S1 < S2, 0 if S1 == S2, and +N if S1 > S2. +*/ +int +strncmp ( + char *s1, + char *s2, + int n +) +{ + while (--n >= 0 && *s1 == *s2++) + if (*s1++ == '\0') + return (0); + + return (n < 0 ? 0 : *s1 - *--s2); +} diff --git a/sys/libc/strncpy.c b/sys/libc/strncpy.c new file mode 100644 index 00000000..79e99495 --- /dev/null +++ b/sys/libc/strncpy.c @@ -0,0 +1,27 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_libc +#include + + +/* STRNCPY -- Copy exactly N characters from S2 to S1, truncating or null +** padding S2; the output string may not be null terminated if the length +** of S2 is N or more. +*/ +char * +strncpy ( + char *s1, /* output string */ + char *s2, /* string to be moved */ + int n +) +{ + register char *ip, *op; + + for (ip=s2, op=s1; --n >= 0 && (*op++ = *ip++); ) + ; + while (--n >= 0) + *op++ = '\0'; + + return (s1); +} diff --git a/sys/libc/system.c b/sys/libc/system.c new file mode 100644 index 00000000..44265864 --- /dev/null +++ b/sys/libc/system.c @@ -0,0 +1,26 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_knames +#include + + +/* SYSTEM -- Send a command to the host system. OK is returned if the command +** executes properly, else a positive integer error code identifying the error +** which occurred. +*/ +int +system ( + char *cmd /* command to be sent to host system */ +) +{ + PKCHAR nullstr[1]; + XINT status; + + nullstr[0] = EOS; + ZOSCMD (cmd, nullstr, nullstr, nullstr, &status); + + return ((int) status); +} diff --git a/sys/libc/ungetc.c b/sys/libc/ungetc.c new file mode 100644 index 00000000..2773f4e1 --- /dev/null +++ b/sys/libc/ungetc.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. +*/ + +#define import_spp +#define import_libc +#define import_xnames +#define import_stdio +#include + + +/* UNGETC -- Push a character back into the input stream. Pushback is last +** in first out, i.e., the last character pushed back is the first one +** read by GETC. Characters (and strings) may be pushed back until the +** FIO pushback buffer overflows. +*/ +int +ungetc ( + int ch, + FILE *fp +) +{ + XINT x_fd = fileno(fp); + XCHAR x_ch = ch; + + iferr (UNGETC (&x_fd, &x_ch)) + return (EOF); + else + return (ch); +} diff --git a/sys/libc/zzdebug.x b/sys/libc/zzdebug.x new file mode 100644 index 00000000..88cf9551 --- /dev/null +++ b/sys/libc/zzdebug.x @@ -0,0 +1,7 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +task hello = t_hello, + print = t_print, + copy = t_copy, + scan = t_scan, + gettok = t_gettok diff --git a/sys/libc/zztest.c b/sys/libc/zztest.c new file mode 100644 index 00000000..b43fe705 --- /dev/null +++ b/sys/libc/zztest.c @@ -0,0 +1,98 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_libc +#define import_stdio +#define import_spp +#define import_error +#define import_xwhen +#include + +thello_() +{ + fputs ("hello, world\n", stdout); +} + + +tprint_() +{ + char buf[128]; + + sprintf (buf, "\tabcdef %0*d[%-5.2s], %h\n", 5, 99, "wxyz", 12.5); + fputs (buf, stdout); +} + + +tcopy_() +{ + FILE *in, *out; + int ch; + + if ((in = fopen ("junk", "r")) == NULL) + c_erract (EA_ERROR); + if ((out = fopen ("junk2", "wb")) == NULL) + c_erract (EA_ERROR); + + while ((ch = getc (in)) != EOF) + putc (ch, out); + + fclose (in); + fclose (out); +} + + +tscan_() +{ + char buf[SZ_LINE]; + char str[SZ_LINE]; + char cval; + int ival, nscan, n1, n2; + int onint(), oldint; + double dval; + + c_xwhen (X_INT, onint, &oldint); + + printf (">> \n"); + fflush (stdout); + + while (fgets (buf, SZ_LINE, stdin) != NULL) { + nscan = sscanf (buf, + "%n%c %*s %d %lg %s%n", &n1, &cval, &ival, &dval, str, &n2); + printf ("nscan=%d: %d '%c' %d %g '%s' %d\n", + nscan, n1, cval, ival, dval, str, n2); + printf (">> \n"); + fflush (stdout); + } + + eprintf ("all done\n"); +} + + +onint (code, old_handler) +int *code; /* NOTUSED */ +int *old_handler; +{ + write (2, "\7", 1); + *old_handler = 0; +} + + +tgettk_() +{ + XCHAR fname[SZ_FNAME+1]; + char token[SZ_LINE+1], delim; + int maxch = SZ_FNAME; + FILE *fp; + + clgstr_ (c_sppstr("fname"), fname, &maxch); + c_strpak (fname, token, maxch); + + fp = fopen (token, "r"); + if (fp == NULL) + c_erract (EA_ERROR); + + while (fscanf (fp, " %[^ \t\n,:()!^&+-*/;|?<>]%c", token,&delim) != EOF) + eprintf ("%s\n%c\n", token, delim); + + fclose (fp); +} diff --git a/sys/memdbg/README b/sys/memdbg/README new file mode 100644 index 00000000..1632e355 --- /dev/null +++ b/sys/memdbg/README @@ -0,0 +1,107 @@ +MEMDBG -- Debug version of MEMIO. + +This library may be linked with an application to perform runtime checks on +the memory allocation subsystem to check for memory leaks. This library is +used only for debugging and is not supported on all IRAF host systems. + +To use this package link the iraf process with the flags + + -z -lmemdbg + +e.g. + xc -c zz.x; xc -z -o zz.e zz.o -lmemdbg + +or include -lmemdbg on the $link line in the mkpkg file. + +It may be desirable to edit the IRAF source code to insert MEMLOG messages +or change the logging defaults. The following routines are provided for this +purpose. + + memlog (message) + memlog1 (message, arg1) + memlog2 (message, arg1, arg2) + memlogs (message, strarg) + memlev (loglevel) + +MEMLOG logs a simple message string. MEMLOG[12] allow one or two integer +arguments. MEMLOGS allows one string argument. + +The debug level may be set with MEMLEV, as follows: + + level = 1 log malloc/realloc/mfree calls + level = 2 log smark/sfree calls + level = 3 log both types of calls + +The default debug level is 3. + +Run one or more IRAF tasks in the process you want to debug and then type +flpr to exit the process (debug logging is process level and ALL calls during +the process lifetime are logged). When the IRAF process is run a file + + mem.log + +will be left in the current directory. This contains a long sequence of lines +such as the following: + + 215738 00000696 18d74 A 1 malloc 572 type 10 + 21929d 00000697 59e34 A 2 smark + 21929d 00000698 5a0aa F 2 sfree + +The columns are as follows. + + bufadr Buffer address for malloc, mfree, smark, etc. + seqno Sequence number - order in which the calls were made + retadr Return address - identifies routine which made the call + action Action code - A (alloc), R (realloc), F (free) + class Class of allocator (1=malloc/mfree, 2=smark/sfree) + comment Describes the type of call, may give extra info + +This is just the raw debug output. To check the debug output to see if there +are any calls that don't match up, the task MEMCHK in SOFTOOLS is used, e.g., + + cl> sort mem.log | memchk | sort col=2 > mem.log2 + +This can also be run at the host level as follows. + + % sort mem.log | x_softools.e memchk fname=STDIN passall+ | sort +1 > ... + +This may take a while for very large (> 10K lines) mem.log files. The +output file will look like the input file except that any bad calls will be +flagged with the string "####" at the end of the line. + +The RETADR field (printed in hex) can be used to determine what IRAF procedure +made a particular call. On a Sun one can run + + % nm -n x_whatever.e + +To list the symbol table sorted by address. The routine which made the call +will be the .text routine with the greatest address which is less than +retadr, i.e., retadr is an address within the text of the calling procedure. + +On a SysV system NM produces "pretty" output and is harder to use. The +following command produces the necessary sorted list on my A/UX system. + + % nm -e -x imexpr.e | sort -t\| +1 + +Another way to do this is to let a debugger look up the symbol in the +symbol table for us. Here is an example using adb. + + % adb zz.e + 0x25f0?i + _foo_+0x28: call _xmallc_ + +In this example the value of retadr is 0x25f0, the executable is the file +zz.e, and the procedure which called the MEMIO (MEMDBG) routine malloc +was "foo" according to adb. + +Note that memory debug logging starts during process startup and the first +messages logged will record the MEMIO calls made by the system code. It is +normal for the system code to allocate some buffers which are used for the +lifetime of the process hence are never freed. A simple way to determine +where the system MEMIO calls end and your task execution begins is to put a +call such as + + call memlog ("--------- start task -----------") + +in the first executable line of your IRAF task. Comments such as this will +be preserved in the mem.log file. diff --git a/sys/memdbg/begmem.x b/sys/memdbg/begmem.x new file mode 100644 index 00000000..e61f6e1e --- /dev/null +++ b/sys/memdbg/begmem.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help begmem, fixmem +.nf ___________________________________________________________________________ +BEGMEM, FIXMEM -- Try to get/release physical memory for a process. The +actual amount of physical memory available (in chars) is returned. On a +machine with virtual memory, these routines adjust the working set size. + +On any machine, BEGMEM may be used to determine the amount of available +physical memory, to tune algorithms for optimum performance. BEGMEM returns +as its function value the actual working set size of the process after +the adjustment (or the current working set size if "best_size" is zero). +On some systems this represents a soft limit on the actual amount of memory +which can be used; it is a guarantee that at least that much space is +available. Some systems will allow the actual working set to dynamically +exceed this value at runtime if the process pages heavily. The hard limit +on the working set of a process is given by the "max_size" parameter. + +Note that the working set must include space not only for a task specific +data buffers, but also for all other process data buffers and for the text +(instruction space) of the code being executed. There is no easy way to +determine this, hence the application is expected to estimate it. A typical +value for the base text+data size required to execute a program is 150Kb. +.endhelp ______________________________________________________________________ + + +# BEGMEM -- Attempt to the adjust the amount of physical memory allocated +# to a process. Save the old memory size in OLD_SIZE, so that memory may +# later be restored with FIXMEM. The new working set size is returned as +# the function value and the hard limit on the working set size is returned +# in MAX_SIZE. In general, the process can be expected to page, possibly +# heavily, or swap out if the working set size is exceeded. All sizes are +# returned in SPP chars. If BEST_SIZE is zero the working set size is not +# changed, i.e., the current working set parameters are returned. + +int procedure begmem (best_size, old_size, max_size) + +int best_size # desired working set size +int old_size # former working set size +int max_size # max physical memory available to this process + +int new_size + +begin + call zawset (best_size * SZB_CHAR, new_size, old_size, max_size) + new_size = new_size / SZB_CHAR + old_size = old_size / SZB_CHAR + max_size = max_size / SZB_CHAR + + return (new_size) +end + + +# FIXMEM -- Restore the original working set size. + +procedure fixmem (old_size) + +int old_size +int j1, j2, j3 + +begin + call zawset (old_size * SZB_CHAR, j1, j2, j3) +end diff --git a/sys/memdbg/calloc.x b/sys/memdbg/calloc.x new file mode 100644 index 00000000..c1b7ffb4 --- /dev/null +++ b/sys/memdbg/calloc.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CALLOC -- Allocate and zero a block of memory. + +procedure calloc (ubufp, buflen, dtype) + +pointer ubufp # user buffer pointer [OUTPUT] +int buflen # nelements of space required, +int dtype # of this data type + +pointer char_ptr +pointer coerce() +int sizeof() +errchk malloc + +begin + call malloc (ubufp, buflen, dtype) + char_ptr = coerce (ubufp, dtype, TY_CHAR) + call aclrc (Memc[char_ptr], buflen * sizeof (dtype)) +end diff --git a/sys/memdbg/coerce.x b/sys/memdbg/coerce.x new file mode 100644 index 00000000..7d42f3bf --- /dev/null +++ b/sys/memdbg/coerce.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# COERCE -- Coerce a pointer from one datatype to another, choosing the +# next larger element for t2 in the event that t1 is not aligned with t2. + +pointer procedure coerce (ptr, type1, type2) + +pointer ptr # input pointer +int type1, type2 # from, to data types +int n +pointer p +include + +begin + p = ptr - 1 + if (type1 == TY_CHAR) + return (p / ty_size[type2] + 1) + else if (type2 == TY_CHAR) + return (p * ty_size[type1] + 1) + else { + p = p * ty_size[type1] # ptr to char + n = ty_size[type2] + return (((p + n-1) / n) + 1) + } +end diff --git a/sys/memdbg/kmalloc.x b/sys/memdbg/kmalloc.x new file mode 100644 index 00000000..39f21ae0 --- /dev/null +++ b/sys/memdbg/kmalloc.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# KMALLOC -- Allocate space on the heap. Equivalent to MALLOC, except that a +# memory allocation failure is indicated by returning ERR as the function value. + +int procedure kmalloc (ubufp, nelems, dtype) + +pointer ubufp # user buffer pointer (output) +int nelems # number of elements of storage required +int dtype # datatype of the storage elements + +int sz_align, fwa_align +int malloc1() +int zrtadr() +include "memdbg.com" + +begin + retaddr = zrtadr() + sz_align = SZ_MEMALIGN + call zlocva (Memc, fwa_align) + return (malloc1 (ubufp, nelems, dtype, sz_align, fwa_align)) +end diff --git a/sys/memdbg/krealloc.x b/sys/memdbg/krealloc.x new file mode 100644 index 00000000..7d61b998 --- /dev/null +++ b/sys/memdbg/krealloc.x @@ -0,0 +1,118 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# KREALLOC -- Change the size of a previously allocated buffer, moving the +# buffer if necessary. If there is no old buffer (NULL pointer) simply +# allocate a new buffer. This routine is equivalent to REALLOC except that it +# merely returns ERR as the function value if an error occurs. +# +# Buffer reallocation or resizing can always be implemented by allocating a new +# buffer, copying the contents of the old buffer to the new buffer, and then +# deleting the old buffer. Nonetheless we use a OS entry point to do the actual +# reallocation, because often it will be possible to change the size of a buffer +# without moving it, particularly when decreasing the size of the buffer. +# +# Allowing the OS to move a buffer causes problems due to the difference in +# alignment criteria imposed by the IRAF pointer scheme, which enforces +# stringent alignment criteria, versus OS memory allocation schemes which +# typically only align on word or longword boundaries. Therefore we must +# check the offset of the data area after reallocation, possibly shifting +# the contents of data area up or down a few chars to reestablish alignment +# with Mem. + +int procedure krealloc (ptr, a_nelems, a_dtype) + +pointer ptr # buffer to be reallocated +int a_nelems # new size of buffer +int a_dtype # buffer datatype + +pointer dataptr +int nelems, dtype, nchars, old_fwa, new_fwa +int char_shift, old_char_offset, new_char_offset +int status, locbuf, loc_Mem + +int mgtfwa(), sizeof(), kmalloc() +pointer mgdptr(), msvfwa(), coerce() +data loc_Mem /NULL/ +int zrtadr() +include "memdbg.com" + +begin + # Copy over the number of elements and the data type in case they are + # located in the block of memory we are reallocating. + + nelems = a_nelems + dtype = a_dtype + + if (ptr == NULL) { + return (kmalloc (ptr, nelems, dtype)) + + } else { + if (dtype == TY_CHAR) + nchars = nelems + 1 + SZ_INT + SZ_MEMALIGN + else + nchars = nelems * sizeof(dtype) + SZ_INT + SZ_MEMALIGN + old_fwa = mgtfwa (ptr, dtype) + new_fwa = old_fwa + + # Change the buffer size; any error is fatal. + call zraloc (new_fwa, nchars * SZB_CHAR, status) + if (status == ERR) { + ptr = NULL + return (ERR) + } + + if (retaddr == 0) + retaddr = zrtadr() + if (new_fwa != old_fwa) { + call zmemlg (old_fwa, retaddr, 'F', 1, + "realloc frees old buf", 0, 0) + call zmemlg (new_fwa, retaddr, 'A', 1, + "realloc allocs new buf", nelems * sizeof(dtype), 0) + } else { + call zmemlg (old_fwa, retaddr, 'R', 1, + "realloc %d", nelems * sizeof(dtype), 0) + } + retaddr = 0 + + # Compute the char offset of the old data area within the original + # buffer; zraloc() guarantees that the old data will have the same + # offset in the new buffer. Compute the char offset of the new + # data area. These need not be the same due to the OS allocating + # the new buffer to alignment criteria less than those required + # by MEMIO. + + call zlocva (Memc[coerce(ptr,dtype,TY_CHAR)], locbuf) + old_char_offset = (locbuf - old_fwa) + + # We must compute a pointer to the data area within the new + # buffer before we can compute the char offset of the new data + # area within the new buffer. + + if (loc_Mem == NULL) + call zlocva (Memc, loc_Mem) + + dataptr = mgdptr (new_fwa, TY_CHAR, SZ_MEMALIGN, loc_Mem) + call zlocva (Memc[dataptr], locbuf) + new_char_offset = (locbuf - new_fwa) + + # Shift the old data to satisfy the new alignment criteria, + # if necessary. + + char_shift = (new_char_offset - old_char_offset) + if (char_shift != 0) { + call amovc (Memc[dataptr - char_shift], Memc[dataptr], + nelems * sizeof(dtype)) + } + + # Save the fwa of the OS buffer in the buffer header, and return + # new pointer to user. + + ptr = msvfwa (new_fwa, dtype, SZ_MEMALIGN, loc_Mem) + } + + return (OK) +end diff --git a/sys/memdbg/malloc.x b/sys/memdbg/malloc.x new file mode 100644 index 00000000..4e5affba --- /dev/null +++ b/sys/memdbg/malloc.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# MALLOC -- Allocate space on the heap. An array of at least NELEMS elements +# of data type DTYPE is allocated, aligned to SZ_MEMALIGN (the biggest type) +# with the global common Mem. + +procedure malloc (ubufp, nelems, dtype) + +pointer ubufp # user buffer pointer (output) +int nelems # number of elements of storage required +int dtype # datatype of the storage elements + +extern kmalloc(), krealloc(), mfree(), realloc(), salloc(), vmalloc() +int first_time, locpr() + +int sz_align, fwa_align +int malloc1() +int zrtadr() +include "memdbg.com" +data first_time /0/ + +begin + # Reference the other MEMDEBUG routines to force them to be loaded. + if (first_time == 0) { + retaddr = locpr (kmalloc) + retaddr = locpr (krealloc) + retaddr = locpr (mfree) + retaddr = locpr (realloc) + retaddr = locpr (salloc) + retaddr = locpr (vmalloc) + first_time = 1 + } + + retaddr = zrtadr() + sz_align = SZ_MEMALIGN + call zlocva (Memc, fwa_align) + if (malloc1 (ubufp, nelems, dtype, sz_align, fwa_align) == ERR) + call syserr (SYS_MFULL) +end diff --git a/sys/memdbg/malloc1.x b/sys/memdbg/malloc1.x new file mode 100644 index 00000000..02682a59 --- /dev/null +++ b/sys/memdbg/malloc1.x @@ -0,0 +1,92 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help malloc1 +.nf ------------------------------------------------------------------------- +MEMIO -- Internal data structures. + +If "p" is the pointer returned by malloc, the first element of storage is +referenced by the expression "Mem_[p]", where the underscore is replaced +by the appropriate type suffix. A pointer to an object of one data type +is NOT equivalent to a pointer to another data type, even if both pointers +reference the same physical address. + +The actual physical address of the physical buffer area allocated is stored +in the integer cell immediately preceeding the buffer returned to the user. +If this cell is corrupted, the condition will later be detected, and a fatal +error ("memory corrupted") will result. + +For example, for a machine with a 4 byte integer, the first part of the +buffer area might appear as follows (the first few unused cells may or +may not be needed to satisfy the alignment criteria): + + offset allocation + + 0 start of the physical buffer (from zmaloc) + 1 + 2 + 3 + 4 byte 1 of saved fwa (address of cell 0) + 5 byte 2 " " " + 6 byte 3 " " " + 7 byte 4 " " " + 8 first cell available to user (maximum alignment) + +MALLOC, given the CHAR address of the buffer allocated by the z-routine, +adds space for the saved fwa (an integer), and determines the address of the +next cell which is sufficiently aligned, relative to the Mem common. This +cell marks the start of the user buffer area. The buffer fwa is saved in the +integer location immediately preceding the "first cell". + +MFREE, called with a pointer to the buffer to be returned, fetches the location +of the physical buffer from the save area. If this does not agree with the +buffer pointer, either (1) the buffer pointer is invalid or of the wrong +datatype, or (2), the save area has been overwritten (memory has been +corrupted). If everything checks out, the buffer fwa is passed to a z-routine +to free the physical buffer space. + +TODO: - Add debugging routine to summarize allocated buffer space and + check for buffer overruns (add sentinel at end of buffer). + - Keep track of buffers allocated while a program is running and + return at program termination, like closing open files. +.endhelp --------------------------------------------------------------------- + + +# MALLOC1 -- Low level procedure which does the actual buffer allocation. + +int procedure malloc1 (output_pointer, nelems, dtype, sz_align, fwa_align) + +pointer output_pointer # buffer pointer (output) +int nelems # number of elements of storage required +int dtype # datatype of the storage elements +int sz_align # number of chars of alignment required +int fwa_align # address to which buffer is to be aligned + +int fwa, nchars, status +int sizeof() +pointer msvfwa() +int zrtadr() +include "memdbg.com" + +begin + if (dtype == TY_CHAR) + nchars = nelems + 1 + SZ_INT + sz_align # add space for EOS + else + nchars = nelems * sizeof (dtype) + SZ_INT + sz_align + + call zmaloc (fwa, nchars * SZB_CHAR, status) + + if (retaddr == 0) + retaddr = zrtadr() + call zmemlg (fwa, retaddr, 'A', 1, + "malloc %d type %d", nelems * sizeof(dtype), dtype) + retaddr = 0 + + if (status == ERR) + return (ERR) + else { + output_pointer = msvfwa (fwa, dtype, sz_align, fwa_align) + return (OK) + } +end diff --git a/sys/memdbg/memdbg.com b/sys/memdbg/memdbg.com new file mode 100644 index 00000000..f6688943 --- /dev/null +++ b/sys/memdbg/memdbg.com @@ -0,0 +1,4 @@ +# MEMDBG.COM -- Memory debug common. + +int retaddr +common /memdbg/ retaddr diff --git a/sys/memdbg/memlog.c b/sys/memdbg/memlog.c new file mode 100644 index 00000000..c8e84281 --- /dev/null +++ b/sys/memdbg/memlog.c @@ -0,0 +1,175 @@ +#include + +/* MEMLOG -- SPP callable routines for logging MEMIO debug messages and + * user application messages in sequence to the mem.log file. + * + * memlog (message) + * memlog1 (message, arg1) + * memlog2 (message, arg1, arg2) + * memlogs (message, strarg) + * memlev (loglevel) + * + * Memlog logs a simple message string. Memlog[12] allow one or two integer + * arguments. Memlogs allows one string argument. + */ + +#define FNAME "mem.log" +#define XCHAR short + +static FILE *fp = NULL; +static int loglevel = 3; +static int number = 0; + +#define LOG_MALLOC 0001 +#define LOG_SALLOC 0002 + +static void memput(); + + +/* MEMLOG -- User routine to log a message in sequence to the memio debug + * log file. + */ +memlog_ (message) +XCHAR *message; +{ + register XCHAR *ip; + register char *op; + char p_message[1024]; + + for (ip=message, op=p_message; *op++ = *ip++; ) + ; + memput (p_message); +} + + +/* MEMLEV -- Set the logging level. + */ +memlev_ (level) +int *level; +{ + loglevel = *level; +} + + +/* MEMLOG1 -- User routine to log a message in sequence to the memio debug + * log file. + */ +memlo1_ (format, arg1) +XCHAR *format; +int *arg1; +{ + register XCHAR *ip; + register char *op; + char p_format[1024]; + char message[1024]; + + /* Output user message. */ + for (ip=format, op=p_format; *op++ = *ip++; ) + ; + sprintf (message, p_format, *arg1); + memput (message); +} + + +/* MEMLOG2 -- User routine to log a message in sequence to the memio debug + * log file. + */ +memlo2_ (format, arg1, arg2) +XCHAR *format; +int *arg1; +int *arg2; +{ + register XCHAR *ip; + register char *op; + char p_format[1024]; + char message[1024]; + + /* Output user message. */ + for (ip=format, op=p_format; *op++ = *ip++; ) + ; + sprintf (message, p_format, *arg1, *arg2); + memput (message); +} + + +/* MEMLOGS -- User routine to log a message in sequence to the memio debug + * log file. + */ +memlos_ (format, strarg) +XCHAR *format; +XCHAR *strarg; +{ + register XCHAR *ip; + register char *op; + char p_format[1024]; + char p_strarg[1024]; + char message[1024]; + + /* Output user message. */ + for (ip=format, op=p_format; *op++ = *ip++; ) + ; + for (ip=strarg, op=p_strarg; *op++ = *ip++; ) + ; + sprintf (message, p_format, p_strarg); + memput (message); +} + + +/* MEMPUT -- Log a message in sequence to the memio debug log file. + */ +static void +memput (message) +char *message; +{ + /* Open logfile. */ + if (fp == NULL) { + unlink (FNAME); + if ((fp = fopen (FNAME, "a")) == NULL) + return; + } + + /* Output sequence number. */ + fprintf (fp, "%10s %08d %8s - - ", + "------", number++, "------"); + + /* Output message. */ + fprintf (fp, message); + fprintf (fp, "\n"); + + fflush (fp); +} + + +/* ZMEMLG -- Used internally by the MEMIO routines. + */ +zmemlg_ (addr, retaddr, action, class, format, arg1, arg2) +int *addr, *retaddr; +int *action, *class; +XCHAR *format; +int *arg1, *arg2; +{ + register XCHAR *ip; + register char *op; + char p_format[1024]; + char s_action[2]; + + if (!(loglevel & *class)) + return; + + for (ip=format, op=p_format; *op++ = *ip++; ) + ; + s_action[0] = *action; + s_action[1] = '\0'; + + if (fp == NULL) { + unlink (FNAME); + if ((fp = fopen (FNAME, "a")) == NULL) + return; + } + + fprintf (fp, "%10x %08d %8x %s %d ", + *addr, number++, *retaddr, s_action, *class); + fprintf (fp, p_format, *arg1, *arg2); + fprintf (fp, "\n"); + fflush (fp); +} diff --git a/sys/memdbg/mfree.x b/sys/memdbg/mfree.x new file mode 100644 index 00000000..e3dbef97 --- /dev/null +++ b/sys/memdbg/mfree.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MFREE -- Free a previously allocated buffer. If the buffer has already been +# returned (NULL pointer), ignore the request. Once the buffer has been +# returned, the old pointer value is of not useful (and invalid), so set it +# to NULL. + +procedure mfree (ptr, dtype) + +pointer ptr +int fwa, dtype, status +int mgtfwa() +errchk mgtfwa +int zrtadr() +include "memdbg.com" + +begin + if (ptr != NULL) { + fwa = mgtfwa (ptr, dtype) + call zmemlg (fwa, zrtadr(), 'F', 1, "mfree", 0, 0) + retaddr = 0 + + call zmfree (fwa, status) + if (status == ERR) + call sys_panic (SYS_MCORRUPTED, "Memory has been corrupted") + + ptr = NULL + } +end diff --git a/sys/memdbg/mgdptr.x b/sys/memdbg/mgdptr.x new file mode 100644 index 00000000..4c6cce22 --- /dev/null +++ b/sys/memdbg/mgdptr.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# MGDPTR -- Given the fwa of a memory area, compute a pointer to the start +# of the data area which satisfies the desired alignment criteria. Memory +# is allocated in units of chars, and ZLOCVA, ZMALOC, etc., return pointers +# in units of chars. + +pointer procedure mgdptr (fwa, dtype, sz_align, fwa_align) + +int fwa, dtype, sz_align, fwa_align +long bufadr +pointer bufptr +int modulus, loc_Mem +int sizeof() +data loc_Mem /NULL/ + +begin + # Compute the address of the start of the user buffer area, which + # must be aligned with fwa_align (usually Mem) for all data types. + + if (loc_Mem == NULL) + call zlocva (Memc, loc_Mem) + bufadr = fwa + SZ_INT + + modulus = mod (bufadr - fwa_align, sz_align) + if (modulus != 0) + bufadr = bufadr + (sz_align - modulus) + + # Compute the buffer pointer for the desired datatype. + bufptr = (bufadr - loc_Mem) / sizeof(dtype) + 1 + + return (bufptr) +end diff --git a/sys/memdbg/mgtfwa.x b/sys/memdbg/mgtfwa.x new file mode 100644 index 00000000..9b39f6eb --- /dev/null +++ b/sys/memdbg/mgtfwa.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# MGTFWA -- Given a user buffer pointer, retrieve physical address of buffer. +# If physical address of buffer does not seem reasonable, memory has probably +# been overwritten, a fatal error. + +int procedure mgtfwa (ptr, dtype) + +pointer ptr, bufptr +int dtype +int locbuf, fwa +int coerce() + +begin + bufptr = coerce (ptr, dtype, TY_INT) + fwa = Memi[bufptr-1] + call zlocva (Memi[bufptr-1], locbuf) + + if (abs (locbuf - fwa) > SZ_VMEMALIGN) + call sys_panic (SYS_MCORRUPTED, "Memory has been corrupted") + + return (fwa) +end diff --git a/sys/memdbg/mkpkg b/sys/memdbg/mkpkg new file mode 100644 index 00000000..985d6bdf --- /dev/null +++ b/sys/memdbg/mkpkg @@ -0,0 +1,27 @@ +# Memory i/o (MEMIO) portion of the system library. + +$checkout libmemdbg.a lib$ +$update libmemdbg.a +$checkin libmemdbg.a lib$ +$exit + +libmemdbg.a: + zrtadr.c + memlog.c + + begmem.x + calloc.x + coerce.x + kmalloc.x memdbg.com + krealloc.x memdbg.com + malloc.x memdbg.com + malloc1.x memdbg.com + mfree.x memdbg.com + mgdptr.x + mgtfwa.x + msvfwa.x + realloc.x memdbg.com + salloc.x memdbg.com + sizeof.x + vmalloc.x memdbg.com + ; diff --git a/sys/memdbg/msvfwa.x b/sys/memdbg/msvfwa.x new file mode 100644 index 00000000..d5df074d --- /dev/null +++ b/sys/memdbg/msvfwa.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# MSVFWA -- Determine the buffer address which satisfies the maximum alignment +# criteria, save the buffer fwa in the integer cell immediately preceding +# this, and return a pointer to the user area of the buffer. + +pointer procedure msvfwa (fwa, dtype, sz_align, fwa_align) + +int fwa, dtype, sz_align, fwa_align +pointer bufptr, mgdptr() +int coerce() + +begin + # Compute the pointer to the data area which satisfies the desired + # alignment criteria. Store the fwa of the actual OS allocated buffer + # in the integer cell preceeding the data area. + + bufptr = mgdptr (fwa, TY_INT, sz_align, fwa_align) + Memi[bufptr-1] = fwa + + # Return pointer of type dtype to the first cell of the data area. + return (coerce (bufptr, TY_INT, dtype)) +end diff --git a/sys/memdbg/realloc.x b/sys/memdbg/realloc.x new file mode 100644 index 00000000..a3d1c866 --- /dev/null +++ b/sys/memdbg/realloc.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# REALLOC -- Change the size of a previously allocated buffer, moving the +# buffer if necessary. If there is no old buffer (NULL pointer) simply +# allocate a new buffer. + +procedure realloc (ubufp, nelems, dtype) + +pointer ubufp # buffer to be reallocated +int nelems # new size of buffer +int dtype # buffer datatype + +int krealloc() +int zrtadr() +include "memdbg.com" + +begin + retaddr = zrtadr() + if (krealloc (ubufp, nelems, dtype) == ERR) { + ubufp = NULL + call syserr (SYS_MFULL) + } +end diff --git a/sys/memdbg/salloc.x b/sys/memdbg/salloc.x new file mode 100644 index 00000000..7895b837 --- /dev/null +++ b/sys/memdbg/salloc.x @@ -0,0 +1,164 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# SALLOC.X -- Stack management routines. Stack storage is allocated in +# segments. Space for each segment is dynamically allocated on the heap. +# Each segment contains a pointer to the previous segment to permit +# reclamation of the space (see "Mem.hlp" for additional details). +# This is a low level facility, hence any failure to allocate or deallocate +# stack storage is fatal. + + +# Segment header structure. The header size parameter SZ_STKHDR is defined +# in because it is potentially machine dependent. SZ_STKHDR +# must be chosen such that the maximum alignment criteria is maintained. + +define SH_BASE Memi[$1] # char pointer to base of segment +define SH_TOP Memi[$1+1] # char pointer to top of segment + 1 +define SH_OLDSEG Memi[$1+2] # struct pointer to header of prev.seg. + + +# SALLOC -- Allocate space on the stack. + +procedure salloc (output_pointer, nelem, datatype) + +pointer output_pointer # buffer pointer (output) +int nelem # number of elements of storage required +int datatype # datatype of the storage elements + +int nchars, dtype +include +pointer sp, cur_seg +common /salcom/ sp, cur_seg + +begin + dtype = datatype + if (dtype < 1 || dtype > MAX_DTYPE) + call sys_panic (500, "salloc: bad datatype code") + + # Align stack pointer for any data type. Compute amount of + # storage to be allocated. Always add space for at least one + # extra char for the EOS in case a string is stored in the buffer. + + sp = (sp + SZ_MEMALIGN-1) / SZ_MEMALIGN * SZ_MEMALIGN + 1 + if (dtype == TY_CHAR) + nchars = nelem + 1 # add space for EOS + else + nchars = nelem * ty_size[dtype] + 1 + + # Check for stack overflow, add new segment if out of room. + # Since SMARK must be called before SALLOC, cur_seg cannot be + # null, but we check anyhow. + + if (cur_seg == NULL || sp + nchars >= SH_TOP(cur_seg)) + call stk_mkseg (cur_seg, sp, nchars) + + if (dtype == TY_CHAR) + output_pointer = sp + else + output_pointer = (sp-1) / ty_size[dtype] + 1 + + sp = sp + nchars # bump stack pointer +end + + +# SMARK -- Mark the position of the stack pointer, so that stack space +# can be freed by a subsequent call to SFREE. This routine also performs +# initialization of the stack, since it the very first routine called +# during task startup. + +procedure smark (old_sp) + +pointer old_sp # value of the stack pointer (output) +bool first_time +pointer sp, cur_seg +common /salcom/ sp, cur_seg +data first_time /true/ +include "memdbg.com" +int zrtadr() + +begin + if (first_time) { + sp = NULL + cur_seg = NULL + call stk_mkseg (cur_seg, sp, SZ_STACK) + first_time = false + } + + call zmemlg (sp, zrtadr(), 'A', 2, " smark", 0, 0) + retaddr = 0 + old_sp = sp +end + + +# SFREE -- Free space on the stack. Return whole segments until segment +# containing the old stack pointer is reached. + +procedure sfree (old_sp) + +pointer old_sp # previous value of the stack pointer + +pointer old_seg +pointer sp, cur_seg +common /salcom/ sp, cur_seg +include "memdbg.com" +int zrtadr() + +begin + # The following is needed to avoid recursion when SFREE is called + # by the IRAF main during processing of SYS_MSSTKUNFL. + + if (cur_seg == NULL) + return + + call zmemlg (old_sp, zrtadr(), 'F', 2, " sfree", 0, 0) + retaddr = 0 + + # If the stack underflows (probably because of an invalid pointer) + # it is a fatal error. + + while (old_sp < SH_BASE(cur_seg) || old_sp > SH_TOP(cur_seg)) { + if (SH_OLDSEG(cur_seg) == NULL) + call sys_panic (SYS_MSSTKUNFL, "Salloc underflow") + + old_seg = SH_OLDSEG(cur_seg) # discard segment + call mfree (cur_seg, TY_STRUCT) + cur_seg = old_seg + } + + sp = old_sp # pop stack +end + + +# STK_MKSEG -- Create and add a new stack segment (link at head of the +# segment list). Called during initialization, and upon stack overflow. + +procedure stk_mkseg (cur_seg, sp, segment_size) + +pointer cur_seg # current segment +pointer sp # salloc stack pointer +int segment_size # size of new stack segment + +int nchars, new_seg +pointer coerce() +int kmalloc() + +begin + # Compute size of new segment, allocate the buffer. + nchars = max (SZ_STACK, segment_size) + SZ_STKHDR + if (kmalloc (new_seg, nchars / SZ_STRUCT, TY_STRUCT) == ERR) + call sys_panic (SYS_MFULL, "Out of memory") + + # Output new stack pointer. + sp = coerce (new_seg, TY_STRUCT, TY_CHAR) + SZ_STKHDR + + # Set up the segment descriptor. + SH_BASE(new_seg) = sp + SH_TOP(new_seg) = sp - SZ_STKHDR + nchars + SH_OLDSEG(new_seg) = cur_seg + + # Make new segment the current segment. + cur_seg = new_seg +end diff --git a/sys/memdbg/sizeof.x b/sys/memdbg/sizeof.x new file mode 100644 index 00000000..3b4977fe --- /dev/null +++ b/sys/memdbg/sizeof.x @@ -0,0 +1,12 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# SIZEOF -- Return the size in chars of one of the fundamental datatypes. + +int procedure sizeof (dtype) + +int dtype +include + +begin + return (ty_size[dtype]) +end diff --git a/sys/memdbg/vmalloc.x b/sys/memdbg/vmalloc.x new file mode 100644 index 00000000..5b1dc7d0 --- /dev/null +++ b/sys/memdbg/vmalloc.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# VMALLOC -- Like malloc, but force the buffer to be aligned on a virtual +# memory page boundary. This feature can be used, e.g., in 4.XBSD UNIX +# to "bypass" the system buffer cache (to avoid copying file data from the +# system cache into the file buffer). VMALLOC can be made equivalent to MALLOC +# via the parameters in , if the local machine which does not have +# virtual memory. + +procedure vmalloc (ubufp, nelems, dtype) + +pointer ubufp # user buffer pointer (output) +int nelems # number of elements of storage required +int dtype # datatype of the storage elements + +int sz_align, fwa_align +int malloc1() +int zrtadr() +include "memdbg.com" + +begin + retaddr = zrtadr() + sz_align = SZ_VMEMALIGN + fwa_align = VMEM_BASE + if (malloc1 (ubufp, nelems, dtype, sz_align, fwa_align) == ERR) + call syserr (SYS_MFULL) +end diff --git a/sys/memdbg/zrtadr.c b/sys/memdbg/zrtadr.c new file mode 100644 index 00000000..7bf9dc2f --- /dev/null +++ b/sys/memdbg/zrtadr.c @@ -0,0 +1,14 @@ +/* ZRTADR -- Return the program address from which the routine calling zrtadr + * was called. If zrtadr is called in procedure B and B is called from + * procedure A, the address returned by zrtadr will be the address in A + * following the call to procedure B. This can be used to determine which + * procedure called B. + * + * This is a portable stub for the actual routine, which is machine dependent + * and normally written in assembler. + */ + +zrtadr_() +{ + return (0); +} diff --git a/sys/memdbg/zzdebug.x b/sys/memdbg/zzdebug.x new file mode 100644 index 00000000..57fb1874 --- /dev/null +++ b/sys/memdbg/zzdebug.x @@ -0,0 +1,190 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ZZDEBUG.X -- Debug MEMIO. + +task memchk = t_memchk, + stack = t_stack, + realloc = t_realloc + + +# MEMCHK -- Scan the mem.log output produced by the debug version of MEMIO +# (this must be sorted first) and check for memory which is allocated but +# never freed. + +procedure t_memchk() + +int fd, ip +bool passall, mark +int addr, retaddr, seqno, action, class +int old_addr, old_seqno, old_action +char lbuf[SZ_LINE], old_lbuf[SZ_LINE] +char descr[SZ_LINE], old_descr[SZ_LINE] +char tokbuf[SZ_FNAME], fname[SZ_FNAME] + +bool clgetb() +int open(), getline(), nscan(), gctol() +define print_ 91 + +begin + call clgstr ("fname", fname, SZ_FNAME) + fd = open (fname, READ_ONLY, TEXT_FILE) + + passall = clgetb ("passall") + old_addr = 0 + old_action = 0 + + while (getline (fd, lbuf) != EOF) { + # Scan next line. + call sscan (lbuf) + call gargwrd (tokbuf, SZ_FNAME) + ip = 1; ip = gctol (tokbuf, ip, addr, 16) + call gargi (seqno) + call gargwrd (tokbuf, SZ_FNAME) + ip = 1; ip = gctol (tokbuf, ip, retaddr, 16) + call gargwrd (tokbuf, SZ_FNAME) + action = tokbuf[1] + call gargi (class) + call gargstr (descr, SZ_LINE) + + if (nscan() < 4) { + if (passall) + call putline (STDOUT, lbuf) + next + } + + if (addr != old_addr) { + # Starting a log for a new buffer address. + if (old_lbuf[1] != EOS) { + if (IS_ALPHA(old_action) && old_action != 'F') { + ip = 1 + while (old_lbuf[ip] != '\n' && old_lbuf[ip] != EOS) + ip = ip + 1 + old_lbuf[ip] = EOS + call printf ("%s %70t####\n") + call pargstr (old_lbuf) + + } else if (passall) + call putline (STDOUT, old_lbuf) + } + + } else { + # Verify operation on a particular buffer address. + + if (old_lbuf[1] != EOS && passall) + call putline (STDOUT, old_lbuf) + + mark = false + if (IS_ALPHA(action) && class == 1) + switch (old_action) { + case 'A', 'R': + if (action != 'R' && action != 'F') + mark = true + case 'F': + if (action != 'A') + mark = true + } + + if (mark) { + ip = 1 + while (lbuf[ip] != '\n' && lbuf[ip] != EOS) + ip = ip + 1 + lbuf[ip] = EOS + call printf ("%s %70t####\n") + call pargstr (lbuf) + lbuf[1] = EOS + } + } + + old_addr = addr + old_seqno = seqno + old_action = action + call strcpy (descr, old_descr, SZ_LINE) + call strcpy (lbuf, old_lbuf, SZ_LINE) + } + + if (old_lbuf[1] != EOS && passall) + call putline (STDOUT, old_lbuf) +end + + +# STACK -- Test the SALLOC routine, which allocates storage on the stack. + +procedure t_stack + +int bufsize +pointer sp, junk +int clglpi() + +begin + call smark (sp) + + while (clglpi ("buffer_size", bufsize) != EOF) { + call salloc (junk, bufsize, TY_CHAR) + call printf ("buffer pointer=%d, size=%d\n") + call pargi (junk) + call pargi (bufsize) + call flush (STDOUT) + } + + call sfree (sp) +end + + +# REALLOC -- Test the REALLOC procedure, used to change the size of a buffer. +# Work with two buffers, so that memory can be fragmented, forcing buffers +# to move. + +procedure t_realloc() + +pointer a, b +int sza, new_sza, szb, new_szb +int clgeti() + +begin + call malloc (a, SZ_LINE, TY_CHAR) + call strcpy ("abcdefghijk", Memc[a], ARB) + sza = SZ_LINE + call malloc (b, SZ_LINE, TY_CHAR) + call strcpy ("0123456789", Memc[b], ARB) + szb = SZ_LINE + + call eprintf ("a is at %d, size %d: %s\n") + call pargi (a) + call pargi (sza) + call pargstr (Memc[a]) + call eprintf ("b is at %d, size %d: %s\n") + call pargi (b) + call pargi (szb) + call pargstr (Memc[b]) + call eprintf ("-------------------------------\n") + + repeat { + new_sza = clgeti ("a_bufsize") + if (new_sza == 0) + return + call x_realloc (a, new_sza, TY_CHAR) + new_szb = clgeti ("b_bufsize") + if (new_szb == 0) + return + call x_realloc (b, new_szb, TY_CHAR) + + call eprintf ("a buf %d, size %d --> %d: %s\n") + call pargi (a) + call pargi (sza) + call pargi (new_sza) + call pargstr (Memc[a]) + call eprintf ("b buf %d, size %d --> %d: %s\n") + call pargi (b) + call pargi (szb) + call pargi (new_szb) + call pargstr (Memc[b]) + + sza = new_sza + szb = new_szb + } + + call mfree (a, TY_CHAR) + call mfree (b, TY_CHAR) +end diff --git a/sys/memio/README b/sys/memio/README new file mode 100644 index 00000000..597f1114 --- /dev/null +++ b/sys/memio/README @@ -0,0 +1 @@ +MEMIO -- Memory allocation and management facilities. diff --git a/sys/memio/begmem.x b/sys/memio/begmem.x new file mode 100644 index 00000000..e61f6e1e --- /dev/null +++ b/sys/memio/begmem.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help begmem, fixmem +.nf ___________________________________________________________________________ +BEGMEM, FIXMEM -- Try to get/release physical memory for a process. The +actual amount of physical memory available (in chars) is returned. On a +machine with virtual memory, these routines adjust the working set size. + +On any machine, BEGMEM may be used to determine the amount of available +physical memory, to tune algorithms for optimum performance. BEGMEM returns +as its function value the actual working set size of the process after +the adjustment (or the current working set size if "best_size" is zero). +On some systems this represents a soft limit on the actual amount of memory +which can be used; it is a guarantee that at least that much space is +available. Some systems will allow the actual working set to dynamically +exceed this value at runtime if the process pages heavily. The hard limit +on the working set of a process is given by the "max_size" parameter. + +Note that the working set must include space not only for a task specific +data buffers, but also for all other process data buffers and for the text +(instruction space) of the code being executed. There is no easy way to +determine this, hence the application is expected to estimate it. A typical +value for the base text+data size required to execute a program is 150Kb. +.endhelp ______________________________________________________________________ + + +# BEGMEM -- Attempt to the adjust the amount of physical memory allocated +# to a process. Save the old memory size in OLD_SIZE, so that memory may +# later be restored with FIXMEM. The new working set size is returned as +# the function value and the hard limit on the working set size is returned +# in MAX_SIZE. In general, the process can be expected to page, possibly +# heavily, or swap out if the working set size is exceeded. All sizes are +# returned in SPP chars. If BEST_SIZE is zero the working set size is not +# changed, i.e., the current working set parameters are returned. + +int procedure begmem (best_size, old_size, max_size) + +int best_size # desired working set size +int old_size # former working set size +int max_size # max physical memory available to this process + +int new_size + +begin + call zawset (best_size * SZB_CHAR, new_size, old_size, max_size) + new_size = new_size / SZB_CHAR + old_size = old_size / SZB_CHAR + max_size = max_size / SZB_CHAR + + return (new_size) +end + + +# FIXMEM -- Restore the original working set size. + +procedure fixmem (old_size) + +int old_size +int j1, j2, j3 + +begin + call zawset (old_size * SZB_CHAR, j1, j2, j3) +end diff --git a/sys/memio/calloc.x b/sys/memio/calloc.x new file mode 100644 index 00000000..c1b7ffb4 --- /dev/null +++ b/sys/memio/calloc.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CALLOC -- Allocate and zero a block of memory. + +procedure calloc (ubufp, buflen, dtype) + +pointer ubufp # user buffer pointer [OUTPUT] +int buflen # nelements of space required, +int dtype # of this data type + +pointer char_ptr +pointer coerce() +int sizeof() +errchk malloc + +begin + call malloc (ubufp, buflen, dtype) + char_ptr = coerce (ubufp, dtype, TY_CHAR) + call aclrc (Memc[char_ptr], buflen * sizeof (dtype)) +end diff --git a/sys/memio/coerce.x b/sys/memio/coerce.x new file mode 100644 index 00000000..7d42f3bf --- /dev/null +++ b/sys/memio/coerce.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# COERCE -- Coerce a pointer from one datatype to another, choosing the +# next larger element for t2 in the event that t1 is not aligned with t2. + +pointer procedure coerce (ptr, type1, type2) + +pointer ptr # input pointer +int type1, type2 # from, to data types +int n +pointer p +include + +begin + p = ptr - 1 + if (type1 == TY_CHAR) + return (p / ty_size[type2] + 1) + else if (type2 == TY_CHAR) + return (p * ty_size[type1] + 1) + else { + p = p * ty_size[type1] # ptr to char + n = ty_size[type2] + return (((p + n-1) / n) + 1) + } +end diff --git a/sys/memio/doc/memio.hlp b/sys/memio/doc/memio.hlp new file mode 100644 index 00000000..1bc5c0a0 --- /dev/null +++ b/sys/memio/doc/memio.hlp @@ -0,0 +1,308 @@ +.help memio Feb83 "Dynamic Memory Management Routines" +.sh +Introduction + + The memory management routines manage both a stack and a heap. +Storage for the stack may be fragmented, and chunks of stack storage are +allocated dynamically from the heap as needed. Programs may allocate +heap storage directly if desired, for large or semipermanent buffers. +Stack storage is intended for use with small buffers, where the overhead +of allocating and deallocating space must be kept to a minimum. + + +.ks +.nf +heap routines: + + malloc (ptr, number_of_elements, data_type) + calloc (ptr, number_of_elements, data_type) + realloc (ptr, number_of_elements, data_type) + mfree (ptr, data_type) + + +stack routines: + + salloc (ptr, number_of_elements, data_type) + smark (ptr) + sfree (ptr) +.fi +.ke + + +MALLOC allocates space on the heap. CALLOC does the same, and fills the buffer +with zeroes. REALLOC is used to change the size of a previously allocated +buffer, copying the contents of the buffer if necessary. MFREE frees space +allocated by a prior call to MALLOC, CALLOC, or REALLOC. + +Space is allocated on the stack with SALLOC. SMARK should be called before +SALLOC, to mark the position of the stack pointer. SFREE returns all space +allocated on the stack since the matching call to SMARK. + + +.KS +Example: +.nf + pointer buf, sp + + begin + call smark (sp) + call salloc (buf, SZ_BUF, TY_CHAR) + while (getline (fd, Memc[buf]) != EOF) { + (code to use buffer ...) + } + call sfree (sp) +.fi +.KE + + +These routines will generate an error abort if memory cannot be allocated +for some reason. + +.sh +Heap Management + + Since many operating systems provide heap management facilities, +MALLOC and MFREE consist of little more than calls to Z routines to +allocate and free blocks of memory. The main function of MALLOC is +to convert the physical buffer address returned by the Z routine into +a pointer of the requested type. + +The pointer returned to the calling routine does not point at the beginning +of the physical buffer, but at a location a few bytes into the buffer. +The physical address of the buffer is stored in the buffer, immediately +before the cell pointed to by the pointer returned by MALLOC. The +stored address must be intact when MFREE is later called to deallocate +the buffer, or a "Memory corrupted" error diagnostic will result. + +The Z routines required to manage the heap are the following: + +.KS +.nf + zmget (bufadr, nbytes) + zmrget (bufadr, nbytes) + zmfree (buf_addr) +.fi +.KE + +The "get" routines should return NULL as the buffer address if space +cannot be allocated for some reason. + +.sh +Stack Management + + The heap management routines have quite a bit of overhead associated +with them, which precludes their use in certain applications. In addition, +the heap can be most efficiently managed when it contains few buffers. +The stack provides an efficient mechanism for parceling out small amounts +of storage, which can later all be freed with a single call. + +The main use of the stack is to provide automatic storage for local +arrays in procedures. The preprocessor compiles code which makes calls +to the stack management routines whenever an array is declared with the +storage calls AUTO, or whenever the ALLOC statement is used in a procedure. + + +.KS +.nf + auto char lbuf[SZ_LINE] + real x[n], y[n] + int n + + begin + alloc (x[npix], y[npix]) + + while (getline (fd, lbuf) != EOF) { + ... +.fi +.KE + + +The AUTO storage class and the ALLOC statement are provided in the full +preprocessor, but not in the subset preprocessor. The following subset +preprocessor code is functionally equivalent to the code show above: + + +.KS +.nf + pointer lbuf, x, y, sp + int n, getline() + + begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + n = npix + call salloc (x, n, TY_REAL) + call salloc (y, n, TY_REAL) + + while (getline (fd, Memc[lbuf]) != EOF) { + ... + + call sfree (sp) +.fi +.KE + +.sh +Semicode for Stack Management + + At any given time, the "stack" is a contiguous buffer of a certain size. +Stack overflow is handled by calling MALLOC to allocate another stack segment. +A pointer to the previous stack segment is kept in each new stack segment, +to permit reclamation of stack space. + + + + +.KS +.nf + salloc smark sfree + + + + stack_overflow + + + + malloc realloc mfree + + + + zmget zmrget zmfree + + + + Structure of the Memory Management Routines +.fi +.KE + + + + +.tp 5 +.nf +procedure salloc (bufptr, nelements, data_type) + +bufptr: upon output, contains pointer to the allocated space +nelements: number of elements of space to be allocated +data_type: data type of the elements and of the buffer pointer + +begin + # align stack pointer for the specified data type, + # compute amount of storage to be allocated + + if (data_type == TY_CHAR) + nchars = nelements + else { + sp = sp + mod (sp-1, sizeof(data_type)) + nchars = nelements * sizeof(data_type) + } + + if (sp + nchars > stack_top) # see if room + call stack_overflow (nchars) + + if (data_type == TY_CHAR) # return pointer + bufptr = sp + else + bufptr = (sp-1) / sizeof(data_type) + 1 + + sp = sp + nchars # bump stack ptr + return +end + + + + +.tp 5 +procedure sfree (old_sp) # pop the stack + +begin + # return entire segments until segment containing the old + # stack pointer is reached + + while (old_sp < stack_base || old_sp > stack_top) { + if (this is the first stack segment) + fatal error, invalid value for old_sp + stack_base = old_segment.stack_base + stack_top = old_segment.stack_top + mfree (segment_pointer, TY_CHAR) + segment_pointer = old_segment + } + + sp = old_sp +end + + + + +.tp 5 +procedure smark (old_sp) # save stack pointer + +begin + old_sp = sp +end + + + + +.tp 5 +procedure stack_overflow (nchars_needed) # increase stk size + +begin + # allocate storage for new segment + segment_size = max (SZ_STACK, nchars_needed + SZ_STKHDR) + malloc (new_segment, segment_size, TY_CHAR) + + # initialize header for the new segment + new_segment.old_segment = segment_pointer + new_segment.stack_base = new_segment + SZ_STKHDR + new_segment.stack_top = new_segment + segment_size + + # make new segment the current segment + segment_pointer = new_segment + stack_base = new_segment.stack_base + stack_top = new_segment.stack_top + sp = stack_base +end + + +.fi +The segment header contains fields describing the location and size of +the segment, plus a link pointer to the previous segment in the list. + + +.KS +.nf + struct stack_header { + char *stack_base + char *stack_top + struct stack_header *old_segment + } +.fi +.KE + +.sh +Pointers and Addresses + + Pointers are indices into (one indexed) Fortran arrays. A pointer to +an object of one datatype will in general have a different value than a +pointer to an object of a different datatype, even if the objects are stored +at the same physical address. Pointers have strict alignment requirements, +and it is not always possible to coerce the type of a pointer. For this +reason, the pointers returned by MALLOC and SALLOC are always aligned for +all data types, regardless of the data type requested. + +The IRAF system code must occasionally manipulate and store true physical +addresses, obtained with the function LOC. The problem with physical +addresses is that they are unsigned integers, but Fortran does not provide +any unsigned data types. Thus, comparisons of addresses are difficult +in Fortran. + +A second LOC primitive is provided for use in routines which must compare +addresses. LOCC returns the address of the object passed as argument, +right shifted to the size of a CHAR. Thus, the difference between LOCC(a[1]) +and LOCC(a[n]) is the size of the N element array A in chars. + +The relationship between chars, bytes, and machine addresses is machine +dependent. Bytes seem to be the smallest units. Some machines are byte +addressable, others are word addressable. The size of a CHAR in machine +bytes is given by the constant SZB_CHAR. The size of a machine word in +machine bytes is given by the constant SZB_WORD. diff --git a/sys/memio/kmalloc.x b/sys/memio/kmalloc.x new file mode 100644 index 00000000..7bfc4ee0 --- /dev/null +++ b/sys/memio/kmalloc.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# KMALLOC -- Allocate space on the heap. Equivalent to MALLOC, except that a +# memory allocation failure is indicated by returning ERR as the function value. + +int procedure kmalloc (ubufp, nelems, dtype) + +pointer ubufp # user buffer pointer (output) +int nelems # number of elements of storage required +int dtype # datatype of the storage elements + +int sz_align, fwa_align +int malloc1() + +begin + sz_align = SZ_MEMALIGN + call zlocva (Memc, fwa_align) + return (malloc1 (ubufp, nelems, dtype, sz_align, fwa_align)) +end diff --git a/sys/memio/krealloc.x b/sys/memio/krealloc.x new file mode 100644 index 00000000..5c6198c8 --- /dev/null +++ b/sys/memio/krealloc.x @@ -0,0 +1,103 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# KREALLOC -- Change the size of a previously allocated buffer, moving the +# buffer if necessary. If there is no old buffer (NULL pointer) simply +# allocate a new buffer. This routine is equivalent to REALLOC except that it +# merely returns ERR as the function value if an error occurs. +# +# Buffer reallocation or resizing can always be implemented by allocating a new +# buffer, copying the contents of the old buffer to the new buffer, and then +# deleting the old buffer. Nonetheless we use a OS entry point to do the actual +# reallocation, because often it will be possible to change the size of a buffer +# without moving it, particularly when decreasing the size of the buffer. +# +# Allowing the OS to move a buffer causes problems due to the difference in +# alignment criteria imposed by the IRAF pointer scheme, which enforces +# stringent alignment criteria, versus OS memory allocation schemes which +# typically only align on word or longword boundaries. Therefore we must +# check the offset of the data area after reallocation, possibly shifting +# the contents of data area up or down a few chars to reestablish alignment +# with Mem. + +int procedure krealloc (ptr, a_nelems, a_dtype) + +pointer ptr # buffer to be reallocated +int a_nelems # new size of buffer +int a_dtype # buffer datatype + +pointer dataptr +int nelems, dtype, nchars, old_fwa, new_fwa +int char_shift, old_char_offset, new_char_offset +int status, locbuf, loc_Mem + +int mgtfwa(), sizeof(), kmalloc() +pointer mgdptr(), msvfwa(), coerce() +data loc_Mem /NULL/ + +begin + # Copy over the number of elements and the data type in case they are + # located in the block of memory we are reallocating. + + nelems = a_nelems + dtype = a_dtype + + if (ptr == NULL) { + return (kmalloc (ptr, nelems, dtype)) + + } else { + if (dtype == TY_CHAR) + nchars = nelems + 1 + SZ_INT + SZ_MEMALIGN + else + nchars = nelems * sizeof(dtype) + SZ_INT + SZ_MEMALIGN + old_fwa = mgtfwa (ptr, dtype) + new_fwa = old_fwa + + # Change the buffer size; any error is fatal. + call zraloc (new_fwa, nchars * SZB_CHAR, status) + if (status == ERR) { + ptr = NULL + return (ERR) + } + + # Compute the char offset of the old data area within the original + # buffer; zraloc() guarantees that the old data will have the same + # offset in the new buffer. Compute the char offset of the new + # data area. These need not be the same due to the OS allocating + # the new buffer to alignment criteria less than those required + # by MEMIO. + + call zlocva (Memc[coerce(ptr,dtype,TY_CHAR)], locbuf) + old_char_offset = (locbuf - old_fwa) + + # We must compute a pointer to the data area within the new + # buffer before we can compute the char offset of the new data + # area within the new buffer. + + if (loc_Mem == NULL) + call zlocva (Memc, loc_Mem) + + dataptr = mgdptr (new_fwa, TY_CHAR, SZ_MEMALIGN, loc_Mem) + call zlocva (Memc[dataptr], locbuf) + new_char_offset = (locbuf - new_fwa) + + # Shift the old data to satisfy the new alignment criteria, + # if necessary. + + char_shift = (new_char_offset - old_char_offset) + if (char_shift != 0) { + call amovc (Memc[dataptr - char_shift], Memc[dataptr], + nelems * sizeof(dtype)) + } + + # Save the fwa of the OS buffer in the buffer header, and return + # new pointer to user. + + ptr = msvfwa (new_fwa, dtype, SZ_MEMALIGN, loc_Mem) + } + + return (OK) +end diff --git a/sys/memio/malloc.x b/sys/memio/malloc.x new file mode 100644 index 00000000..d5886c36 --- /dev/null +++ b/sys/memio/malloc.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# MALLOC -- Allocate space on the heap. An array of at least NELEMS elements +# of data type DTYPE is allocated, aligned to SZ_MEMALIGN (the biggest type) +# with the global common Mem. + +procedure malloc (ubufp, nelems, dtype) + +pointer ubufp # user buffer pointer (output) +int nelems # number of elements of storage required +int dtype # datatype of the storage elements + +int sz_align, fwa_align +int malloc1() + +begin + sz_align = SZ_MEMALIGN + call zlocva (Memc, fwa_align) + if (malloc1 (ubufp, nelems, dtype, sz_align, fwa_align) == ERR) + call syserr (SYS_MFULL) +end diff --git a/sys/memio/malloc1.x b/sys/memio/malloc1.x new file mode 100644 index 00000000..33001ff1 --- /dev/null +++ b/sys/memio/malloc1.x @@ -0,0 +1,84 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help malloc1 +.nf ------------------------------------------------------------------------- +MEMIO -- Internal data structures. + +If "p" is the pointer returned by malloc, the first element of storage is +referenced by the expression "Mem_[p]", where the underscore is replaced +by the appropriate type suffix. A pointer to an object of one data type +is NOT equivalent to a pointer to another data type, even if both pointers +reference the same physical address. + +The actual physical address of the physical buffer area allocated is stored +in the integer cell immediately preceeding the buffer returned to the user. +If this cell is corrupted, the condition will later be detected, and a fatal +error ("memory corrupted") will result. + +For example, for a machine with a 4 byte integer, the first part of the +buffer area might appear as follows (the first few unused cells may or +may not be needed to satisfy the alignment criteria): + + offset allocation + + 0 start of the physical buffer (from zmaloc) + 1 + 2 + 3 + 4 byte 1 of saved fwa (address of cell 0) + 5 byte 2 " " " + 6 byte 3 " " " + 7 byte 4 " " " + 8 first cell available to user (maximum alignment) + +MALLOC, given the CHAR address of the buffer allocated by the z-routine, +adds space for the saved fwa (an integer), and determines the address of the +next cell which is sufficiently aligned, relative to the Mem common. This +cell marks the start of the user buffer area. The buffer fwa is saved in the +integer location immediately preceding the "first cell". + +MFREE, called with a pointer to the buffer to be returned, fetches the location +of the physical buffer from the save area. If this does not agree with the +buffer pointer, either (1) the buffer pointer is invalid or of the wrong +datatype, or (2), the save area has been overwritten (memory has been +corrupted). If everything checks out, the buffer fwa is passed to a z-routine +to free the physical buffer space. + +TODO: - Add debugging routine to summarize allocated buffer space and + check for buffer overruns (add sentinel at end of buffer). + - Keep track of buffers allocated while a program is running and + return at program termination, like closing open files. +.endhelp --------------------------------------------------------------------- + + +# MALLOC1 -- Low level procedure which does the actual buffer allocation. + +int procedure malloc1 (output_pointer, nelems, dtype, sz_align, fwa_align) + +pointer output_pointer # buffer pointer (output) +int nelems # number of elements of storage required +int dtype # datatype of the storage elements +int sz_align # number of chars of alignment required +int fwa_align # address to which buffer is to be aligned + +int fwa, nchars, status +int sizeof() +pointer msvfwa() + +begin + if (dtype == TY_CHAR) + nchars = nelems + 1 + SZ_INT + sz_align # add space for EOS + else + nchars = nelems * sizeof (dtype) + SZ_INT + sz_align + + call zmaloc (fwa, nchars * SZB_CHAR, status) + + if (status == ERR) + return (ERR) + else { + output_pointer = msvfwa (fwa, dtype, sz_align, fwa_align) + return (OK) + } +end diff --git a/sys/memio/mfree.x b/sys/memio/mfree.x new file mode 100644 index 00000000..f7c83f1d --- /dev/null +++ b/sys/memio/mfree.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MFREE -- Free a previously allocated buffer. If the buffer has already been +# returned (NULL pointer), ignore the request. Once the buffer has been +# returned, the old pointer value is of not useful (and invalid), so set it +# to NULL. + +procedure mfree (ptr, dtype) + +pointer ptr +int fwa, dtype, status +int mgtfwa() +errchk mgtfwa + +begin + if (ptr != NULL) { + fwa = mgtfwa (ptr, dtype) + + call zmfree (fwa, status) + if (status == ERR) + call sys_panic (SYS_MCORRUPTED, "Memory has been corrupted") + + ptr = NULL + } +end diff --git a/sys/memio/mgdptr.x b/sys/memio/mgdptr.x new file mode 100644 index 00000000..4efc628c --- /dev/null +++ b/sys/memio/mgdptr.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# MGDPTR -- Given the fwa of a memory area, compute a pointer to the start +# of the data area which satisfies the desired alignment criteria. Memory +# is allocated in units of chars, and ZLOCVA, ZMALOC, etc., return pointers +# in units of chars. + +pointer procedure mgdptr (fwa, dtype, sz_align, fwa_align) + +int fwa, dtype, sz_align, fwa_align +#long bufadr +int bufadr +pointer bufptr +int modulus, loc_Mem +int sizeof() +data loc_Mem /NULL/ + +begin + # Compute the address of the start of the user buffer area, which + # must be aligned with fwa_align (usually Mem) for all data types. + + if (loc_Mem == NULL) + call zlocva (Memc, loc_Mem) + bufadr = fwa + SZ_INT + + modulus = mod (bufadr - fwa_align, sz_align) + if (modulus != 0) + bufadr = bufadr + (sz_align - modulus) + + # Compute the buffer pointer for the desired datatype. + bufptr = (bufadr - loc_Mem) / sizeof(dtype) + 1 + + return (bufptr) +end diff --git a/sys/memio/mgtfwa.x b/sys/memio/mgtfwa.x new file mode 100644 index 00000000..9b39f6eb --- /dev/null +++ b/sys/memio/mgtfwa.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# MGTFWA -- Given a user buffer pointer, retrieve physical address of buffer. +# If physical address of buffer does not seem reasonable, memory has probably +# been overwritten, a fatal error. + +int procedure mgtfwa (ptr, dtype) + +pointer ptr, bufptr +int dtype +int locbuf, fwa +int coerce() + +begin + bufptr = coerce (ptr, dtype, TY_INT) + fwa = Memi[bufptr-1] + call zlocva (Memi[bufptr-1], locbuf) + + if (abs (locbuf - fwa) > SZ_VMEMALIGN) + call sys_panic (SYS_MCORRUPTED, "Memory has been corrupted") + + return (fwa) +end diff --git a/sys/memio/mkpkg b/sys/memio/mkpkg new file mode 100644 index 00000000..c9c86f23 --- /dev/null +++ b/sys/memio/mkpkg @@ -0,0 +1,24 @@ +# Memory i/o (MEMIO) portion of the system library. + +$checkout libsys.a lib$ +$update libsys.a +$checkin libsys.a lib$ +$exit + +libsys.a: + begmem.x + calloc.x + coerce.x + kmalloc.x + krealloc.x + malloc.x + malloc1.x + mfree.x + mgdptr.x + mgtfwa.x + msvfwa.x + realloc.x + salloc.x + sizeof.x + vmalloc.x + ; diff --git a/sys/memio/msvfwa.x b/sys/memio/msvfwa.x new file mode 100644 index 00000000..d5df074d --- /dev/null +++ b/sys/memio/msvfwa.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# MSVFWA -- Determine the buffer address which satisfies the maximum alignment +# criteria, save the buffer fwa in the integer cell immediately preceding +# this, and return a pointer to the user area of the buffer. + +pointer procedure msvfwa (fwa, dtype, sz_align, fwa_align) + +int fwa, dtype, sz_align, fwa_align +pointer bufptr, mgdptr() +int coerce() + +begin + # Compute the pointer to the data area which satisfies the desired + # alignment criteria. Store the fwa of the actual OS allocated buffer + # in the integer cell preceeding the data area. + + bufptr = mgdptr (fwa, TY_INT, sz_align, fwa_align) + Memi[bufptr-1] = fwa + + # Return pointer of type dtype to the first cell of the data area. + return (coerce (bufptr, TY_INT, dtype)) +end diff --git a/sys/memio/realloc.x b/sys/memio/realloc.x new file mode 100644 index 00000000..40229b8f --- /dev/null +++ b/sys/memio/realloc.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# REALLOC -- Change the size of a previously allocated buffer, moving the +# buffer if necessary. If there is no old buffer (NULL pointer) simply +# allocate a new buffer. + +procedure realloc (ubufp, nelems, dtype) + +pointer ubufp # buffer to be reallocated +int nelems # new size of buffer +int dtype # buffer datatype + +int krealloc() + +begin + if (krealloc (ubufp, nelems, dtype) == ERR) { + ubufp = NULL + call syserr (SYS_MFULL) + } +end diff --git a/sys/memio/salloc.x b/sys/memio/salloc.x new file mode 100644 index 00000000..34f06217 --- /dev/null +++ b/sys/memio/salloc.x @@ -0,0 +1,155 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# SALLOC.X -- Stack management routines. Stack storage is allocated in +# segments. Space for each segment is dynamically allocated on the heap. +# Each segment contains a pointer to the previous segment to permit +# reclamation of the space (see "Mem.hlp" for additional details). +# This is a low level facility, hence any failure to allocate or deallocate +# stack storage is fatal. + + +# Segment header structure. The header size parameter SZ_STKHDR is defined +# in because it is potentially machine dependent. SZ_STKHDR +# must be chosen such that the maximum alignment criteria is maintained. + +define SH_BASE Memi[$1] # char pointer to base of segment +define SH_TOP Memi[$1+1] # char pointer to top of segment + 1 +define SH_OLDSEG Memi[$1+2] # struct pointer to header of prev.seg. + + +# SALLOC -- Allocate space on the stack. + +procedure salloc (output_pointer, nelem, datatype) + +pointer output_pointer # buffer pointer (output) +int nelem # number of elements of storage required +int datatype # datatype of the storage elements + +int nchars, dtype +include +pointer sp, cur_seg +common /salcom/ sp, cur_seg + +begin + dtype = datatype + if (dtype < 1 || dtype > MAX_DTYPE) + call sys_panic (500, "salloc: bad datatype code") + + # Align stack pointer for any data type. Compute amount of + # storage to be allocated. Always add space for at least one + # extra char for the EOS in case a string is stored in the buffer. + + sp = (sp + SZ_MEMALIGN-1) / SZ_MEMALIGN * SZ_MEMALIGN + 1 + if (dtype == TY_CHAR) + nchars = nelem + 1 # add space for EOS + else + nchars = nelem * ty_size[dtype] + 1 + + # Check for stack overflow, add new segment if out of room. + # Since SMARK must be called before SALLOC, cur_seg cannot be + # null, but we check anyhow. + + if (cur_seg == NULL || sp + nchars >= SH_TOP(cur_seg)) + call stk_mkseg (cur_seg, sp, nchars) + + if (dtype == TY_CHAR) + output_pointer = sp + else + output_pointer = (sp-1) / ty_size[dtype] + 1 + + sp = sp + nchars # bump stack pointer +end + + +# SMARK -- Mark the position of the stack pointer, so that stack space +# can be freed by a subsequent call to SFREE. This routine also performs +# initialization of the stack, since it the very first routine called +# during task startup. + +procedure smark (old_sp) + +pointer old_sp # value of the stack pointer (output) +bool first_time +pointer sp, cur_seg +common /salcom/ sp, cur_seg +data first_time /true/ + +begin + if (first_time) { + sp = NULL + cur_seg = NULL + call stk_mkseg (cur_seg, sp, SZ_STACK) + first_time = false + } + + old_sp = sp +end + + +# SFREE -- Free space on the stack. Return whole segments until segment +# containing the old stack pointer is reached. + +procedure sfree (old_sp) + +pointer old_sp # previous value of the stack pointer + +pointer old_seg +pointer sp, cur_seg +common /salcom/ sp, cur_seg + +begin + # The following is needed to avoid recursion when SFREE is called + # by the IRAF main during processing of SYS_MSSTKUNFL. + + if (cur_seg == NULL) + return + + # If the stack underflows (probably because of an invalid pointer) + # it is a fatal error. + + while (old_sp < SH_BASE(cur_seg) || old_sp > SH_TOP(cur_seg)) { + if (SH_OLDSEG(cur_seg) == NULL) + call sys_panic (SYS_MSSTKUNFL, "Salloc underflow") + + old_seg = SH_OLDSEG(cur_seg) # discard segment + call mfree (cur_seg, TY_STRUCT) + cur_seg = old_seg + } + + sp = old_sp # pop stack +end + + +# STK_MKSEG -- Create and add a new stack segment (link at head of the +# segment list). Called during initialization, and upon stack overflow. + +procedure stk_mkseg (cur_seg, sp, segment_size) + +pointer cur_seg # current segment +pointer sp # salloc stack pointer +int segment_size # size of new stack segment + +int nchars, new_seg +pointer coerce() +int kmalloc() + +begin + # Compute size of new segment, allocate the buffer. + nchars = max (SZ_STACK, segment_size) + SZ_STKHDR + if (kmalloc (new_seg, nchars / SZ_STRUCT, TY_STRUCT) == ERR) + call sys_panic (SYS_MFULL, "Out of memory") + + # Output new stack pointer. + sp = coerce (new_seg, TY_STRUCT, TY_CHAR) + SZ_STKHDR + + # Set up the segment descriptor. + SH_BASE(new_seg) = sp + SH_TOP(new_seg) = sp - SZ_STKHDR + nchars + SH_OLDSEG(new_seg) = cur_seg + + # Make new segment the current segment. + cur_seg = new_seg +end diff --git a/sys/memio/sizeof.x b/sys/memio/sizeof.x new file mode 100644 index 00000000..3b4977fe --- /dev/null +++ b/sys/memio/sizeof.x @@ -0,0 +1,12 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# SIZEOF -- Return the size in chars of one of the fundamental datatypes. + +int procedure sizeof (dtype) + +int dtype +include + +begin + return (ty_size[dtype]) +end diff --git a/sys/memio/vmalloc.x b/sys/memio/vmalloc.x new file mode 100644 index 00000000..25e2de0d --- /dev/null +++ b/sys/memio/vmalloc.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# VMALLOC -- Like malloc, but force the buffer to be aligned on a virtual +# memory page boundary. This feature can be used, e.g., in 4.XBSD UNIX +# to "bypass" the system buffer cache (to avoid copying file data from the +# system cache into the file buffer). VMALLOC can be made equivalent to MALLOC +# via the parameters in , if the local machine which does not have +# virtual memory. + +procedure vmalloc (ubufp, nelems, dtype) + +pointer ubufp # user buffer pointer (output) +int nelems # number of elements of storage required +int dtype # datatype of the storage elements + +int sz_align, fwa_align +int malloc1() + +begin + sz_align = SZ_VMEMALIGN + fwa_align = VMEM_BASE + if (malloc1 (ubufp, nelems, dtype, sz_align, fwa_align) == ERR) + call syserr (SYS_MFULL) +end diff --git a/sys/memio/zzdebug.c b/sys/memio/zzdebug.c new file mode 100644 index 00000000..35b0f7ad --- /dev/null +++ b/sys/memio/zzdebug.c @@ -0,0 +1,366 @@ +/* zzdebug.x -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" + +/* Common Block Declarations */ + +struct { + logical xerflg, xerpad[84]; +} xercom_; + +#define xercom_1 xercom_ + +struct { + doublereal memd[1]; +} mem_; + +#define mem_1 mem_ + +/* Table of constant values */ + +static integer c__4 = 4; +static integer c__1 = 1; +static integer c__0 = 0; +static integer c__2 = 2; +static integer c__1023 = 1023; +static integer c_b46 = 999999999; + +integer sysruk_(task, cmd, rukarf, rukint) +shortint *task, *cmd; +integer *rukarf, *rukint; +{ + /* Initialized data */ + + static shortint dict[14] = { 115,116,97,99,107,0,114,101,97,108,108,111, + 99,0 }; + static shortint st0009[29] = { 105,110,118,97,108,105,100,32,115,101,116, + 32,115,116,97,116,101,109,101,110,116,58,32,39,37,115,39,10,0 }; + static shortint st0010[25] = { 105,110,118,97,108,105,100,32,83,69,84,32, + 105,110,32,73,82,65,70,32,77,97,105,110,0 }; + static integer dp[3] = { 1,7,0 }; + static integer lmarg = 5; + static integer maxch = 0; + static integer ncol = 0; + static integer rukean = 3; + static integer ntasks = 0; + static shortint st0001[9] = { 116,116,121,110,99,111,108,115,0 }; + static shortint st0002[6] = { 99,104,100,105,114,0 }; + static shortint st0003[3] = { 99,100,0 }; + static shortint st0004[6] = { 104,111,109,101,36,0 }; + static shortint st0005[6] = { 72,79,77,69,36,0 }; + static shortint st0006[4] = { 115,101,116,0 }; + static shortint st0007[6] = { 114,101,115,101,116,0 }; + static shortint st0008[2] = { 9,0 }; + + /* System generated locals */ + integer ret_val; + + /* Local variables */ + static integer i__, rmarg; + extern logical streq_(); + extern /* Subroutine */ integer trealc_(); + extern integer envgei_(); + extern /* Subroutine */ integer xfchdr_(), erract_(), eprinf_(), tstack_() + ; + extern integer envscn_(); + extern /* Subroutine */ integer xffluh_(), pargsr_(), envlit_(), syspac_() + , xerpsh_(), strtbl_(); + extern logical xerpop_(); + extern /* Subroutine */ integer zzepro_(); + + /* Parameter adjustments */ + --cmd; + --task; + + /* Function Body */ + if (! (ntasks == 0)) { + goto L110; + } + i__ = 1; +L120: + if (! (dp[i__ - 1] != 0)) { + goto L122; + } +/* L121: */ + ++i__; + goto L120; +L122: + ntasks = i__ - 1; +L110: + if (! (task[1] == 63)) { + goto L130; + } + xerpsh_(); + rmarg = envgei_(st0001); + if (! xerpop_()) { + goto L140; + } + rmarg = 80; +L140: + strtbl_(&c__4, dict, dp, &ntasks, &lmarg, &rmarg, &maxch, &ncol); + ret_val = 0; + goto L100; +L130: + if (! (streq_(&task[1], st0002) || streq_(&task[1], st0003))) { + goto L150; + } + xerpsh_(); + if (! (cmd[*rukarf] == 0)) { + goto L170; + } + xerpsh_(); + xfchdr_(st0004); + if (! xerpop_()) { + goto L180; + } + xfchdr_(st0005); +L180: + goto L171; +L170: + xfchdr_(&cmd[*rukarf]); +L171: +/* L162: */ + if (! xerpop_()) { + goto L160; + } + if (! (*rukint == 1)) { + goto L190; + } + erract_(&rukean); + if (xercom_1.xerflg) { + goto L100; + } + goto L191; +L190: +L191: +L160: + ret_val = 0; + goto L100; +L150: + if (! (streq_(&task[1], st0006) || streq_(&task[1], st0007))) { + goto L200; + } + xerpsh_(); + if (! (cmd[*rukarf] == 0)) { + goto L220; + } + envlit_(&c__4, st0008, &c__1); + xffluh_(&c__4); + goto L221; +L220: + if (! (envscn_(&cmd[1]) <= 0)) { + goto L230; + } + if (! (*rukint == 1)) { + goto L240; + } + eprinf_(st0009); + pargsr_(&cmd[1]); + goto L241; +L240: + goto L91; +L241: +L230: +L221: +/* L212: */ + if (! xerpop_()) { + goto L210; + } + if (! (*rukint == 1)) { + goto L250; + } + erract_(&rukean); + if (xercom_1.xerflg) { + goto L100; + } + goto L251; +L250: +L91: + syspac_(&c__0, st0010); +L251: +L210: + ret_val = 0; + goto L100; +L200: +/* L151: */ +/* L131: */ + if (! streq_(&task[1], &dict[dp[0] - 1])) { + goto L260; + } + tstack_(); + ret_val = 0; + goto L100; +L260: + if (! streq_(&task[1], &dict[dp[1] - 1])) { + goto L270; + } + trealc_(); + ret_val = 0; + goto L100; +L270: + ret_val = -1; + goto L100; +L100: + zzepro_(); + return ret_val; +} /* sysruk_ */ + +/* Subroutine */ integer tstack_() +{ + /* Initialized data */ + + static shortint st0001[12] = { 98,117,102,102,101,114,95,115,105,122,101, + 0 }; + static shortint st0002[28] = { 98,117,102,102,101,114,32,112,111,105,110, + 116,101,114,61,37,100,44,32,115,105,122,101,61,37,100,10,0 }; + + /* Local variables */ + static integer sp; +#define memb ((logical *)&mem_1) +#define memc ((shortint *)&mem_1) +#define memi ((integer *)&mem_1) +#define meml ((integer *)&mem_1) +#define memr ((real *)&mem_1) +#define mems ((shortint *)&mem_1) +#define memx ((complex *)&mem_1) + static integer junk; + extern /* Subroutine */ integer pargi_(), sfree_(), smark_(); + extern integer clglpi_(); + static integer bufsie; + extern /* Subroutine */ integer salloc_(), xffluh_(), xprinf_(), zzepro_() + ; + + smark_(&sp); +L110: + if (! (clglpi_(st0001, &bufsie) != -2)) { + goto L111; + } + salloc_(&junk, &bufsie, &c__2); + xprinf_(st0002); + pargi_(&junk); + pargi_(&bufsie); + xffluh_(&c__4); + goto L110; +L111: + sfree_(&sp); +/* L100: */ + zzepro_(); + return 0; +} /* tstack_ */ + +#undef memx +#undef mems +#undef memr +#undef meml +#undef memi +#undef memc +#undef memb + + +/* Subroutine */ integer trealc_() +{ + /* Initialized data */ + + static shortint st0001[12] = { 97,98,99,100,101,102,103,104,105,106,107,0 + }; + static shortint st0002[11] = { 48,49,50,51,52,53,54,55,56,57,0 }; + static shortint st0003[25] = { 97,32,105,115,32,97,116,32,37,100,44,32, + 115,105,122,101,32,37,100,58,32,37,115,10,0 }; + static shortint st0004[25] = { 98,32,105,115,32,97,116,32,37,100,44,32, + 115,105,122,101,32,37,100,58,32,37,115,10,0 }; + static shortint st0005[33] = { 45,45,45,45,45,45,45,45,45,45,45,45,45,45, + 45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,45,10,0 }; + static shortint st0006[10] = { 97,95,98,117,102,115,105,122,101,0 }; + static shortint st0007[10] = { 98,95,98,117,102,115,105,122,101,0 }; + static shortint st0008[30] = { 97,32,98,117,102,32,37,100,44,32,115,105, + 122,101,32,37,100,32,45,45,62,32,37,100,58,32,37,115,10,0 }; + static shortint st0009[30] = { 98,32,98,117,102,32,37,100,44,32,115,105, + 122,101,32,37,100,32,45,45,62,32,37,100,58,32,37,115,10,0 }; + + /* Local variables */ + static integer a, b, sza, szb; +#define memb ((logical *)&mem_1) +#define memc ((shortint *)&mem_1) +#define memi ((integer *)&mem_1) +#define meml ((integer *)&mem_1) +#define memr ((real *)&mem_1) +#define mems ((shortint *)&mem_1) +#define memx ((complex *)&mem_1) + extern /* Subroutine */ integer pargi_(); + extern integer clgeti_(); + extern /* Subroutine */ integer xrealc_(), xmallc_(), eprinf_(), xmfree_() + , pargsr_(); + static integer newsza, newszb; + extern /* Subroutine */ integer zzepro_(), xstrcy_(); + + xmallc_(&a, &c__1023, &c__2); + xstrcy_(st0001, &memc[a - 1], &c_b46); + sza = 1023; + xmallc_(&b, &c__1023, &c__2); + xstrcy_(st0002, &memc[b - 1], &c_b46); + szb = 1023; + eprinf_(st0003); + pargi_(&a); + pargi_(&sza); + pargsr_(&memc[a - 1]); + eprinf_(st0004); + pargi_(&b); + pargi_(&szb); + pargsr_(&memc[b - 1]); + eprinf_(st0005); +L110: + newsza = clgeti_(st0006); + if (! (newsza == 0)) { + goto L120; + } + goto L100; +L120: + xrealc_(&a, &newsza, &c__2); + newszb = clgeti_(st0007); + if (! (newszb == 0)) { + goto L130; + } + goto L100; +L130: + xrealc_(&b, &newszb, &c__2); + eprinf_(st0008); + pargi_(&a); + pargi_(&sza); + pargi_(&newsza); + pargsr_(&memc[a - 1]); + eprinf_(st0009); + pargi_(&b); + pargi_(&szb); + pargi_(&newszb); + pargsr_(&memc[b - 1]); + sza = newsza; + szb = newszb; +/* L111: */ + goto L110; +/* L112: */ + xmfree_(&a, &c__2); + xmfree_(&b, &c__2); +L100: + zzepro_(); + return 0; +} /* trealc_ */ + +#undef memx +#undef mems +#undef memr +#undef meml +#undef memi +#undef memc +#undef memb + + diff --git a/sys/memio/zzdebug.x b/sys/memio/zzdebug.x new file mode 100644 index 00000000..556c4fa1 --- /dev/null +++ b/sys/memio/zzdebug.x @@ -0,0 +1,86 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# Debug MEMIO. + +task stack=t_stack, realloc=t_realloc + + +# Test the SALLOC routine, which allocates storage on the stack. + +procedure t_stack + +int bufsize +pointer sp, junk +int clglpi() + +begin + call smark (sp) + + while (clglpi ("buffer_size", bufsize) != EOF) { + call salloc (junk, bufsize, TY_CHAR) + call printf ("buffer pointer=%d, size=%d\n") + call pargi (junk) + call pargi (bufsize) + call flush (STDOUT) + } + + call sfree (sp) +end + + +# Test the REALLOC procedure, used to change the size of a buffer. +# Work with two buffers, so that memory can be fragmented, forcing buffers +# to move. + +procedure t_realloc() + +pointer a, b +int sza, new_sza, szb, new_szb +int clgeti() + +begin + call malloc (a, SZ_LINE, TY_CHAR) + call strcpy ("abcdefghijk", Memc[a], ARB) + sza = SZ_LINE + call malloc (b, SZ_LINE, TY_CHAR) + call strcpy ("0123456789", Memc[b], ARB) + szb = SZ_LINE + + call eprintf ("a is at %d, size %d: %s\n") + call pargi (a) + call pargi (sza) + call pargstr (Memc[a]) + call eprintf ("b is at %d, size %d: %s\n") + call pargi (b) + call pargi (szb) + call pargstr (Memc[b]) + call eprintf ("-------------------------------\n") + + repeat { + new_sza = clgeti ("a_bufsize") + if (new_sza == 0) + return + call x_realloc (a, new_sza, TY_CHAR) + new_szb = clgeti ("b_bufsize") + if (new_szb == 0) + return + call x_realloc (b, new_szb, TY_CHAR) + + call eprintf ("a buf %d, size %d --> %d: %s\n") + call pargi (a) + call pargi (sza) + call pargi (new_sza) + call pargstr (Memc[a]) + call eprintf ("b buf %d, size %d --> %d: %s\n") + call pargi (b) + call pargi (szb) + call pargi (new_szb) + call pargstr (Memc[b]) + + sza = new_sza + szb = new_szb + } + + call mfree (a, TY_CHAR) + call mfree (b, TY_CHAR) +end diff --git a/sys/mkpkg b/sys/mkpkg new file mode 100644 index 00000000..2a911439 --- /dev/null +++ b/sys/mkpkg @@ -0,0 +1,274 @@ +# Make the IRAF Virtual Operating System (VOS). (07-May-83 Dct). +# Revised to use the new MKPKG facilities (12Dec85 Dct). + +$ifeq (hostid, unix) !(clear;date) $endif +$call sysgen +$echo "-------------- (done) ----------------" +$ifeq (hostid, unix) !(date) $endif +$exit + +# UPDATE -- Update the system executables in lib$ + +update: + $echo "-------------- GIO ----------------" + @gio + $echo "-------------- KI ----------------" + @ki + $echo "-------------- TTY ----------------" + @tty + ; + +# SUMMARY -- [UNIX] mkpkg summary: output a summary of the spooled mkpkg +# output, omitting most of the mundane chatter. Used to scan large spool +# files for errors. + +summary: + $ifeq (HOSTID, unix) + ! grep -v ':$$' spool | grep -v '^xc' | grep -v '^ar'\ + | grep -v '^check file' + $else + $echo "mkpkg summary only available on a UNIX system" + $endif + ; + +# SYSGEN -- Update the system libraries (VOS). Note that the system library +# for the iraf kernel (libos.a) is maintained in host$. + +sysgen: + $call sys + $call ex + $call vops + $call cur + $call stg + $ifeq (USE_LIBMAIN, yes) $call libmain $endif + $call libc + $call imfort + $call gks + $call ncar + $call sgi + $call imd + + # Not all systems want the NCAR/NSPP and CALCOMP graphics kernels. + $ifeq (USE_NSPP, yes) + $call nspp + $call gkt + $endif + $ifeq (USE_CALCOMP, yes) + $call ccp + $endif + + # DS is required for cursor readback by the CL. + $call ds + + # MEMIO debug library. + $call memdbg + + $purge lib$ + ; + +sys: + $echo "-------------- LIBSYS ----------------" + $checkout libsys.a lib$ + $update libsys.a + $checkin libsys.a lib$ + ; +ex: + $echo "-------------- LIBEX -----------------" + $checkout libex.a lib$ + $update libex.a + $checkin libex.a lib$ + ; +vops: + $echo "-------------- LIBVOPS ---------------" + $checkout libvops.a lib$ + $update libvops.a + $checkin libvops.a lib$ + ; +cur: + $echo "-------------- LIBCUR ----------------" + $checkout libcur.a lib$ + $update libcur.a + $checkin libcur.a lib$ + ; +stg: + $echo "-------------- LIBSTG ----------------" + $checkout libstg.a lib$ + $update libstg.a + $checkin libstg.a lib$ + ; +libmain: + $echo "-------------- LIBMAIN.O -------------" + $ifolder (bin$libmain.o, host$os/zmain.c) + $call libmain.o + $else + $echo "Libmain.o is up to date" + $endif + ; +libc: + $echo "-------------- LIBC ------------------" + $checkout libc.a lib$ + $update libc.a + $checkin libc.a lib$ + ; +imfort: + $echo "-------------- IMFORT ----------------" + $checkout libimfort.a lib$ + $update libimfort.a + $checkin libimfort.a lib$ + ; +gks: + $echo "-------------- LIBGKS ----------------" + $checkout libgks.a lib$ + $update libgks.a + $checkin libgks.a lib$ + ; +sgi: + $echo "-------------- LIBSGI ----------------" + $checkout libsgi.a lib$ + $update libsgi.a + $checkin libsgi.a lib$ + ; +imd: + $echo "-------------- LIBIMD ----------------" + $checkout libimd.a lib$ + $update libimd.a + $checkin libimd.a lib$ + ; +ds: + $echo "-------------- LIBDS ----------------" + $checkout libds.a lib$ + $update libds.a + $checkin libds.a lib$ + ; +ncar: + $echo "-------------- LIBNCAR ---------------" + $checkout libncar.a lib$ + $update libncar.a + $checkin libncar.a lib$ + ; +nspp: + $echo "-------------- LIBNSPP ---------------" + $checkout libnspp.a lib$ + $update libnspp.a + $checkin libnspp.a lib$ + ; +gkt: + $echo "-------------- LIBGKT ----------------" + $checkout libgkt.a lib$ + $update libgkt.a + $checkin libgkt.a lib$ + ; +ccp: + $echo "-------------- LIBCCP ----------------" + $checkout libccp.a lib$ + $update libccp.a + $checkin libccp.a lib$ + ; +ds: + $echo "-------------- LIBDS ----------------" + $checkout libds.a lib$ + $update libds.a + $checkin libds.a lib$ + ; +memdbg: + $echo "-------------- LIBMEMDBG ------------" + $checkout libmemdbg.a lib$ + $update libmemdbg.a + $checkin libmemdbg.a lib$ + ; + +libsys.a: # Core system + @fio + @fmio + @fmtio + @clio + @etc + @gty + #@memio + @nmemio + @mtio + @symtab + @tty + @ki + @psio + + @host$gdev/ # HSI graphics device drivers + ; + +libex.a: # High level system stuff + @gio + @imio + @plio + @pmio + @qpoe + @mwcs + ; + +libvops.a: + @vops # Vector operators + @osb # Bit and byte primitives + ; + +libcur.a: + @gio # Cursor mode + ; + +libmain.o: # The root object module + $set XFLAGS = "-c $(HSI_XF)" + $checkout zmain.c host$os/ + $omake zmain.c + $iffile (bin$libsys.a) # store all binaries in BIN? + $move zmain.o bin$libmain.o + $else + $move zmain.o lib$libmain.o + $endif + $delete zmain.c + ; + +libc.a: + @libc + ; + +libimfort.a: + @imfort + ; + +libgks.a: # GKS emulator + @gio + ; + +libncar.a: # NCAR graphics utilities + @gio + ; + +libnspp.a: # Old NCAR System Plot Package (NSPP) + @gio + ; + +libstg.a: # The STDGRAPH graphics kernel + @gio + ; + +libsgi.a: # The SGI (simple graphics) kernel + @gio + ; + +libimd.a: # The IMD (image device) kernel + @gio + ; + +libgkt.a: # The NSPP graphics kernel + @gio + ; + +libccp.a: # The CALCOMP graphics kernel + @gio + ; + +libds.a: # The DS display interface library + @pkg$images/tv/display/mkpkg + ; + +libmemdbg.a: # The MEMIO debug library + @memdbg + ; diff --git a/sys/mtio/README b/sys/mtio/README new file mode 100644 index 00000000..143917e6 --- /dev/null +++ b/sys/mtio/README @@ -0,0 +1,45 @@ +MTIO -- Magtape i/o. This directory contains the FIO device driver for the +magtape devices plus MTOPEN (used to open a magtape device and hook it to +FIO) plus a few other routines. See ./doc for additional info. + + +USER ROUTINES + + yes|no = mtfile (fname) # Is fname a magtape device? + yes|no = mtneedfileno (mtname) # No file number given? + gty = mtcap (mtname) + mtfname (mtname, file, outstr, maxch) + + mtparse (mtname, device, fileno, recno, attrl, maxch) + mtencode (mtname, maxch, device, fileno, recno, attrl) + + fd = mtopen (mtname, acmode, bufsize) + mtrewind (mtname, initcache) + mtposition (mtname, file, record) + + Use CLOSE to close a file descriptor opened with mtopen. + Use GTYCLOSE to close a termcap descriptor opened with mtcap. + MTNAME is the full magtape device specification, i.e, "mt[...]". + + + +SYSTEM ROUTINES + + mtallocate (mtname) + mtdeallocate (mtname, rewind_tape) + mtstatus (out, mtname) + mtclean (level, stale, out) + + + +FIO DRIVER + + zopnmt (iodev, acmode, mtchan) + zclsmt (mtchan, status) + zardmt (mtchan, buf, maxbytes, offset) + zawrmt (mtchan, buf, nbytes, offset) + zawtmt (mtchan, status) + zsttmt (mtchan, what, lvalue) + + +All other procedures are internal to the interface. diff --git a/sys/mtio/doc/mtio.hlp b/sys/mtio/doc/mtio.hlp new file mode 100644 index 00000000..e00643a5 --- /dev/null +++ b/sys/mtio/doc/mtio.hlp @@ -0,0 +1,814 @@ +.help mtio Aug83 "Magnetic Tape I/O" +.sh +1. Introduction + + This document describes the Magnetic Tape I/O (MTIO) package, +i.e., the interface by which IRAF programs access magnetic tapes. +Included are the requirements and specifications for the package, +and a discussion of the interface between MTIO and FIO. + +.sh +2. MTIO Requirements +.ls 4 +.ls (1) +The machine independent part of the MTIO package shall be written in +the SPP language in compliance with the standards and conventions of IRAF. +.le +.ls (2) +The MTIO package shall provide a single interface to all magtape +devices on all IRAF target machines. +.le +.ls (3) +MTIO shall interface to FIO, making it possible to read and write a magtape +file via the FIO interface in a device independent fashion. +.le +.ls (4) +All functions shall take an error action if a hardware error occurs, +or if an illegal function is requested. +No hardware exception or trap shall occur while accessing a magtape +file via MTIO which is not caught by MTIO and converted into an +IRAF error action. +.le +.ls (5) +All error actions shall be defined symbolically in the system error +code file . The MTIO error messages shall have the +form SYS_MT, i.e., SYS_MTOPEN. The error message strings +shall be placed in the system error message file, "syserrmsg". +.le +.ls (6) +The MTIO code shall be divided into a machine independent part and +a machine dependent part. All machine independent function and error +checking shall be done in the machine independent part, to minimize +the size and complexity of the machine dependent part, and therefore +maximize the transportability of the package. +.le +.ls (7) +MTIO shall interface to FIO by implementing the standard FIO binary file +z-routines ZOPNMT, ZCLSMT, ZARDMT, ZAWRMT, ZAWTMT, and ZSTTMT. +The specifications for these routines are given elsewhere. +.le + +.sh +3. MTIO Specifications + + A magtape file is opened with MTOPEN and then accessed as a binary +file via the device independent FIO interface. Upon input, FIO merges +all tape records together into a binary byte stream. Upon output, +FIO writes records equal in size to the FIO buffers, unless FLUSH or +CLOSE is called, causing a partially filled buffer to be flushed to tape. +The data within a tape file may not be randomly accessed; only sequential +accesses are permitted. When i/o is complete, CLOSE should be called +to close the file and return all buffer space. + + fd = mtopen (filename, access_mode, buf_size) + +The format of a nonblank magnetic tape consists of beginning-of-tape (BOT), +followed by zero or more files, followed by end-of-tape (EOT). +Each file consists of one or more records, followed by a tape mark (EOF). +EOT is defined as two consecutive tape marks, i.e., as a file containing +zero records. MTIO knows nothing about labeled tapes. + +Tape records need not all be the same length, but for transportability +reasons records should be an integral number of computer words in length, +and very short records should be avoided (short records are used by some +operating systems for special purposes). The term "computer word" +is not well defined; the size of a tape record in bytes should be evenly +divisible by 2, 4, or 8, where the transportability increases with the +size of the divisor. To avoid loss of data when reading a tape, +the FIO buffer must be at least as large as the longest record on the tape. + +.sh +3.1 Opening a Magtape + + MTOPEN opens a file on the named magtape device. The following +device naming convention determines the tape drive and density: + + mt[a-z][800|1600|6250] + +The letter in the second field determines which drive is to be used, +and the third field, which is optional, determines the density. +If the density is not specified, a system or drive dependent default +density will be selected. Thus, to access a file on drive A at 1600 bpi, +one would open the file "mta1600". + +The significance of the terms "drive A", "drive B", etc., is installation +dependent, and need not imply distinct physical drives. A tape drive may +have to be allocated before it can be opened by MTIO; MTIO does not attempt +to allocate devices. + +The device name may optionally be followed by a subscript specifying +the index of the file to which the tape is to be positioned. +Thus, opening "mta[3]" causes device A to be opened with the default +density, positioned to BOF of the third file on the tape. +The field N, as in "mta[N]" may have the following values: + +.ls 4 +.ls 12 absent +If the entire subscript is absent, or if N is absent the tape is opened +at the current position, i.e., the tape is not physically moved. +.le +.ls N >= 1 +If an integer number greater than or equal to 1 (one) is given, +the tape is opened positioned to that file. +.le +.ls N == EOT +If the file number is given as "EOT" or as "eot", the tape is opened +positioned at EOT. +.le +.le + +If called with a non "mt"-prefixed file name, MTOPEN assumes that the file +is a regular disk resident binary file, and attempts to open the named +file. A program which normally reads directly from a magtape device may +therefore be used to read from a regular binary file, or from the +standard input (the special file "STDIN"). + +The following access modes are recognized by MTOPEN: +.ls 4 +.ls 12 READ_ONLY +The device is opened for reading, positioned to the beginning of +a file, BOT, EOT, or to the "current position". +Any attempt to write to the device will cause an error. +.le +.ls WRITE_ONLY +The device is opened for writing, positioned to the beginning of a file, +BOT, EOT, or to the "current position". When the file is subsequently +closed, a new EOT mark will be written. Existing tape files may be overwritten. +.le +.ls APPEND +The device is opened for writing, positioned at the end of tape (EOT). +Append mode must not be used with blank tapes. Note that the significance +of APPEND mode is different for MTOPEN than for a regular file open; +the tape is to be extended by adding a new file, whereas in FIO it is +the file itself which is extended. +.le +.ls NEW_TAPE +The device is opened for writing, positioned at BOT. Any existing +data on the tape is overwritten. Recommended mode for blank tapes. +.le +.le + +FIO can read any tape with a maximum record size less than or equal +to the buffer size. In buffered mode, FIO normally writes records equal +in size to the FIO internal buffers. Smaller records may be written if +FLUSH or CLOSE is called; records of any size may be written in unbuffered +mode. + +The third argument to MTOPEN is used to set the FIO buffer size. +If the buffer size is given as zero, a default value is used. +The default value chosen depends on the mode of access and upon the +maximum record size permitted by the host system. MTOPEN will automatically +allocate the maximum size FIO buffer if the tape is opened for reading. +The FIO buffer size may be changed in an FSET call anytime before +the first buffered i/o on the file. + +.sh +3.2 Ordinary I/O to a Magtape Device + + Seeks are not permitted on magtape files. A tape may be opened for +reading or for writing, but not for both at the same time. A magtape +device is much like the standard input and output; STDIN is read only, +STDOUT is write only, and seeking is not permitted on either. STDIN +differs from ordinary files in that data may continue to be read after +an EOF; the same is true of magtape files. If a read returning EOF is +followed by another read on a magtape device, the second read will +access the first record of the next file. Once EOT is reached, every +read will return EOF. There is no way to advance beyond EOT on a read. +An EOF mark may only be written by closing the tape (see next section). + +.sh +3.3 Closing a Magtape + + The CLOSE function is called either explicitly by the user task, +or implicilty by the IRAF main upon normal or abnormal task termination. +If the file was opened for writing, CLOSE flushes the output buffer and +writes an EOT mark at the current position. A file opened for writing +is left positioned ready to write the first record of the next file on +the tape (i.e., after the EOF of the file just written). A file opened +for reading, if closed immediately after reading EOF, is left positioned +ready to read or write the first record of the next file on the tape. + +.sh +3.4 Bytes and Records + + Upon input, the size of a record will be rounded up to an integral +number of "chars". No data will be lost, but one or more extra bytes of +data may be added. A tape conversion program which must deal with +odd-sized records must know the size of tape records to properly extract +the data. FIO cannot write odd-sized records. + +The binary i/o routines do not transform the data in any way, +including byte swapping. If byte swapping is necessary, the conversion +program must do the byte swapping explicitly. The predefined machine +constants BYTE_SWAP and WORD_SWAP indicate whether byte or word swapping +is necessary on the local machine (word swapping refers to the two 16 bit +words in a long integer). Floating point data should not be stored in +binary on tape, unless the tape is to be read only by the machine which +wrote it. + +Routines are available elsewhere in the PI for manipulating bytes. +The routines BYTMOV, BYTSWP, and BYTPAK are particularly useful for cracking +foreign tapes. + +.sh +3.5 Low level I/O to a Magtape + + The asynchronous, unbuffered FIO routines AREAD, AWRITE, and AWAIT +may be used to perform record i/o on a magtape. A single tape record +is read or written by each call; the FIO buffer is not used. AWAIT must +be called after each read or write, before initiating the next i/o transfer. +Although in general it is unwise to mix buffered and unbuffered i/o on +the same file, it is safe to perform one or more unbuffered transfers +immediately after opening a file, before performing any buffered i/o. + +If an application must do something peculiar, like write an odd-sized +record, the MTIO z-routines may be called directly. The z-routines transfer +data in units of machine bytes. + +.sh +3.6 CL level tape commands + + The four routines ALLOCATE, DEALLOCATE, REWIND and MTSTATUS will be +available at the CL level. A tape drive ("mta", "mtb", etc.) must be +explicitly allocated before it can be accessed with MTOPEN. +A drive may be allocated to only one user at a time. MTIO keeps track +of the position of an allocated tape; once a drive has been allocated, +the tape must not be manually positioned by the user. Tapes can be +changed without reallocating the drive provided REWIND is first used to +rewind the tape. DEALLOCATE automatically rewinds the tape before +deallocating the drive. MTSTATUS tells whether or not a particular drive +has been allocated, and if so, gives the name of the owner, the density, +whether not the device is physically open, and so on. + +.sh +3.6 Example + + The following program reads an ASCII card image file from the +input tape and converts it to an ordinary text stream, which is written +to the standard output. This program is insensitive to the number of +cards per tape record, and may be used to read card image disk files +as well as tape files. + +The following CL commands might be entered to read the second card image +file on the 800 bpi input tape into file "myfile", converting to lower case: + +.ks +.nf + cl> allocate mta + cl> rcardimage "mta800[2]" | lcase > myfile +.fi +.ke + + +The source for the program "rcardimage" follows: + + +.ks +.nf +# RCARDIMAGE -- CL callable task which reads a card image +# file, writing the converted cards to the standard output. + +procedure rcardimage() + +char filename[SZ_FNAME] +int input, mtopen() + +begin + call clgstr ("filename", filename, SZ_FNAME) + input = mtopen (filename, READ_ONLY, 0) + call read_card_image_file (input, STDOUT) + call close (input) +end +.fi +.ke + + + +.ks +.nf +define SZ_CARD 80 + +# READ_CARD_IMAGE_FILE -- Read the named card image file, convert +# to a regular character stream, and write to the output file. + +procedure read_card_image_file (input, output) + +int input, output # input, output files +char cardbuf[SZ_CARD] # raw card +char linebuf[SZ_CARD+1] # add 1 char for newline +int last_char +int read() +errchk read, putline + +begin + # Read successive cards until EOF is reached. Unpack the + # card, strip trailing whitespace, and write the processed + # line to the output file. + + while (read (input, cardbuf, SZ_CARD) != EOF) { + call chrupk (cardbuf, 1, linebuf, 1, SZ_CARD) + + # Strip trailing whitespace, add newline. + last_char = 0 + for (ip=1; ip <= SZ_CARD; ip=ip+1) + if (! IS_WHITE (linebuf[ip])) + last_char = ip + + linebuf[last_char+1] = '\n' + linebuf[last_char+2] = EOS + + call putline (output, linebuf) + } +end +.fi +.ke +.endhelp + + +.helpsys mtio Nov83 "MTIO Interface Detailed Design" +.sh +Strategies for Interfacing MTIO + + The specifications for MTIO have been kept as simple as possible for maximum +machine independence. There is only one high level call, MTOPEN, which is +used to open the device; it does little more than call FIO. Thereafter +everything is done through the six FIO z-routines: + +.nf + zopnmt (filespec, access_mode; channel|ERR) + zclsmt (channel) + zardmt (channel, buffer, maxbytes, one_indexed_byte_offset) + zawrmt (channel, buffer, nbytes, one_indexed_byte_offset) + zawtmt (channel; nbytes|ERR) + zsttmt (channel, parameter; long_value) +.fi + +These z-routines may be written in any language so long as they are SPP (i.e., +Fortran) callable. The "filespec" argument is a packed string. The access +modes and ERR code are system constants defined in . Channel may be +anything you wish. The file offsets will always be zero since the magtape +device is a streaming (sequential) device. + +Be sure that the z-routines, if written partially in the SPP language, do not +make calls to high level program interface routines, especially any which do +i/o. Doing so violates the reentrancy restrictions of the SPP language (and +of Fortran). It may also lead to problems with the way libraries are searched. +More explicitly, any calls to error or iferr, to any of the FIO routines, or to +any of the printf or scan routines are absolutely forbidden. It is ok to use +the string primitives (because they do not do any i/o or call error), but it +is best to avoid even those if possible. It is perfectly all right to call +other z-routines provided they do not directly or indirectly call you back +(none will call mtio). + +.sh +Virtual Device Model + + Though in general the z-routines may have to be completely rewritten for +a new OS, in fact many systems have functionally similar primitive magtape +interfaces. If your system can be described by the model defined below, +the "z?*.x" files in this directory can be used unchanged, and all you need to +provide are the equivalents of the "zz" prefixed files. + + Basically, the model requires that the zz-routine which opens the magtape +be capable of positioning the tape to the first record of any file, given the +file number to which the tape is positioned at open time. The high level MTIO +interface code is charged with keeping track of the position of the tape at +all times, including while the tape is closed. The high level code does not +explicitly move the tape, though it does implicitly move it during open and when +it commands an i/o operation. The high level code assumes nothing about tape +motions; all zz-primitives return status values stating how many records or +files the tape moved in the last operation. Thus, the details of the function +of a zz-routine can vary depending on the system, without requiring +modifications to the z-routines. + +.ls 4 +.ls (1) +The following open/close primitives are required. ZZOPMT opens a tape +drive positioned ready to read or write the first record of the specified +file. +.ls zzopmt (drive,density,acmode, oldrec,oldfile; newfile; oschan|ERR) +.br +.ls 10 drive +Logical drive number (1,2,3,...). +.le +.ls density +Drive density. A positive integer, i.e., 800, 1600 or 6250. A value +of zero implies that an OS default density is to be selected. +.le +.ls acmode +Access mode. Read_only or write_only. Modes new_file and append are +dealt with by the "newfile" file number parameter. +.le +.ls oldrecord +The number of the record to which we are currently positioned in the +oldfile. We have to know this to know whether or not the file has to +be rewound. The first record is number one. +.le +.ls oldfile +The number of the file to which the tape is currently positioned. +.le +.ls newfile +The number of the file to be opened, where 1 specifies that the tape is +to be rewound. If newfile <= 0, open at EOT. On output, contains the +actual file number of the new file; this may differ from the requested +value if EOT is encountered. It is not an error (as far as the zz-routine +is concerned) to attempt to position to a file beyond EOT. +.le +.ls oschan +The channel number by which the file is to be referred in calls to the +other zz-routines, or ERR if the file cannot be opened. ZZOPMT should +set oschan IMMEDIATELY AFTER PHYSICALLY OPENING THE DEVICE, so that the +error recovery code can close the file if an interrupt occurs. +.le +.le + +.ls 4 zzclmt (oschan, access_mode; nfile) +Close tape. Write a new EOT at the current position if writing. +Returns the file number increment (in the event that a file mark or two +has to be written). +.le +.le + +.ls (2) +The following i/o primitives are required. +.ls zzrdmt (oschan, buf, maxbytes) +Initiate a read of up to maxbytes bytes from the next tape +record into buffer buf. It is not an error if fewer than "maxbytes" +bytes are read; in fact maxbytes will normally be larger than the largest +record on the tape. In general it is difficult to tell if the tape record +was larger than maxbytes; the user code should select a large maxbytes and +consider it an error if the full maxbytes are read. If EOF is encountered, +return a zero byte count in the next call to zzwtmt. +.le +.ls zzwrmt (oschan, buf, nbytes) +Initiate a write of "nbytes" bytes to the tape. It is an error +if all data is not written. +.le +.ls zzwtmt (oschan; nbytes|ERR, nrecord, nfile) +Wait for i/o to complete, and return the number of bytes read or +written in the last transfer; return 0 if we read a tape mark. +Keep returning the same thing in redundant calls. If an error +occurs the error status should be cleared when the next i/o +transfer is initiated. Return nrecord=1 for each tape record read, +but not for file marks. Return nfile=1 if a filemark is skipped. +A read of 0 bytes signifies that EOF was seen, but does not necessarily +imply that a tape mark has been skipped. +.le +.le +.le + +.sh +Program Structure + + The drive must be allocated before MTOPEN is called; MTOPEN verifies +that the drive has been allocated and then calls FIO to install the magtape +device and open the desired file on the drive. Allocating a file involves +a call to the OS to allocate and/or mount the device, followed by creation +of the device lock file in the dev$ directory. The lock file is used to +indicate that the drive has been allocated, and to keep track of the tape +position when the drive is closed. + + +.ks +.nf + mtopen + mt_parse_filespec + mt_get_tape_position + various FIO routines + fopnbf + zopnmt + zzopmt + zsttmt + fset [to set buffer size] + + + Structure of the MTOPEN Procedure +.fi +.ke + + +The ZCLSMT procedure is called by CLOSE to close a file opened with MTOPEN. +CLOSE may be called by the user, by the IRAF main if the task completes w/o +closing the file, or during error recovery. An error occurring during MTOPEN +may result in a call to CLOSE. We do not have to worry about reentrancy here +because none of the MTIO z-routines called by ZOPNMT call error (they will +return an ERR status to FOPNBF and therefore terminate before ZCLSMT is called). + + +.ks +.nf + close + zclsmt + mt_update_lockfile + smark,salloc,sfree + fvfn_to_osfn + mktemp + zopntx + zputtx + zclstx + zfdele + zfrnam + fatal + zzclmt + + + Structure of the ZCLSMT procedure +.fi +.ke + + +The i/o procedures keep track of the number of records read or written and +ensure that we do not read past EOF or EOT. We need to keep track of the +number of records written so that we can detect a null file write. + + +.ks +.nf + aread awrite + zardmt zawrmt + zzrdmt zzwrmt + + + await + zawtmt + zzwtmt + + + Structure of the I/O Procedures +.fi +.ke + + +The final routine is the ZSTTMT status procedure. This routine is self +contained, except that access to the MTIO common is required to get the +access mode (which determines the default buffer size). + + +.sh +Semicode + + We do as much of the work in MTOPEN as we can, since it is the only +high level, machine independent routine we have (we can call anything in this +routine without reentrancy problems). We check that the drive has been +allocated (to us), allocate an mtio device descriptor, check that the same +drive has not been reopened, parse the filespec and save the pieces in the +descriptor (for later use by ZOPNMT), read in the current tape position from +the lock file, and then call fopnbf which in turn calls ZOPNMT to open the +drive and position to the desired file. + + +.tp 8 +.nf +int procedure mtopen (filespec, access_mode, bufsize) + +begin + if (file not mt-prefixed) { + call open to open regular binary file + return (file descriptor returned by open) + } + + get mtio device descriptor slot but do not allocate it yet + if (slots all taken) + error: magtape device multiply opened (filespec) + call mt_parse_filespec to break out drivename, density, + filenumber and set up mtio device descriptor + if (drive is already open) + error: magtape device multiply opened (filespec) + check that the named drive has been allocated to us + if (drive not allocated to us) + error: magtape not allocated (filespec) + decode lock file to get old position of drive, save in + device descriptor + + call fopnbf to install the magtape device and open file + if (bufsize is nonzero) + call fset to set non-default FIO buffer size + + return (file descriptor) +end +.fi + + +ZOPNMT is passed a mostly initialized magtape file descriptor in the mtio +common by MTOPEN. The "filespec" string is not actually used by ZOPNMT. +We physically open the file and set up the remaining fields in the tape file +descriptor. NOTE: if an interrupt occurs during the call to ZZOPMT, +ZCLSMT will be called to perform error recovery. If this happens the +position of the tape is undefined. + + +.ks +.nf +procedure zopnmt (filespec, access_mode; chan|ERR) + +[we are passed the mtio file descriptor in the mtio common] + +begin + set flag for ZCLSMT in case we are interrupted + call ZZOPMT to open tape positioned to the beginning of the + indicated file. + + if (cannot open tape) + return (chan = ERR) + if (actual file < requested file) + if (reading) + set at-eof flag and at_eot flag, so that reads return EOF + else { + call zzclmt to close device + return (mtchan = ERR) + } + + save oschan in descriptor + save actual file number in descriptor + initialize the remaining descriptor fields + + return (chan = mtio descriptor index) +end +.fi +.ke + + +Opening a file for writing and then immediately closing it poses problems. +There is no way to write a zero-length file on an unlabeled tape. We cannot +just write a tape mark because that might mean writing a spurious double +tapemark (false EOT) in the middle of the tape. We could just ignore the +request and not write any file, but that is not quite right either (if a +disk file is opened for writing and then immediately closed, a file is +still created). We compromise by writing a single short record containing +the packed ASCII character string "NULLFILE". The actual length of the +physical nullfile record is machine dependent. + +We may or may not need to bump the file counter when the file is closed; +the OS tells us which. If we have just written a file and ZZCLMT must +write a tape mark, for example, we might be left positioned before EOT, +between the tape marks, or (unlikely) after the tape marks. + +If an error (i.e., console interrupt) occurs while the tape is being +positioned by ZZOPMT, we will be called by the error recovery system +with a garbage mtchan argument. We must be able to detect this type +of call and modify the lock file, marking the position of the tape +as UNDEFINED. The next open call will then automatically rewind the +tape, ensuring accurate positioning. In a normal close we write out +a lockfile identifying the file and record to which the tape is positioned. + + +.ks +.nf +procedure zclsmt (mtchan) + +begin + if (error recovery in progress for ZOPNMT) + mark current position as undefined + else { + if (file was opened for writing but nothing was written) + write out "null file" short record + + call zzclmt (oschan, access_mode; nfiles) + file += nfiles + if (nfiles > 0) + record = 1 + } + + call mt_update_lockfile to save tape status, position + deallocate the mtio device descriptor slot +end +.fi +.ke + + +Ignore all read requests once EOF or EOT has been reached. The only operation +possible at that point is to close the device; there is no rewind or backskip +function for a streaming device. We do not "know" what would happen if we +called ZZRDMT after reaching EOF; this is OS dependent, and we do not want +to require any particular behavior (some systems would return the first +record of the next file, others would keep returning EOF). + + +.ks +.nf +procedure zardmt (mtchan, buf, maxbytes, offset) + +begin + if (not at EOF or EOT) + call zzrdmt (oschan, buf, maxbytes) +end +.fi +.ke + + +We cannot hit EOF or EOT on a write, so merely post the request and return. +Ignore the "offset" parameter since magtape is a streaming device. + + +.ks +.nf +procedure zawrmt (mtchan, buf, nbytes, offset) + +begin + call zzwrmt (oschan, buf, nbytes) +end +.fi +.ke + + +FIO insures that ZAWTMT is called once and only once after every asynchronous +i/o read or write request. Once we hit EOF or EOT on a read, we return +EOF (nchars = 0) on every subsequent request until the file is closed. +After each real data transfer we update the record,file counters as +directed by the OS. + + +.ks +.nf +procedure zawtmt (mtchan; status) + +begin + if (reading and at EOF or EOT) + return (status = 0) + + call zzwtmt (oschan, nchars, nrecords_skipped, nfiles_skipped) + if (nfiles_skipped > 0) { + set at-EOF flag + record = 1 + } + + file += nfiles_skipped # keep track of position + record += nrecords_skipped + nrecords += nrecords_skipped # count records rd|wr + + status = nchars +end +.fi +.ke + +.sh +Error Recovery + + Error recovery during magtape operations is tricky since we are trying +to keep track of the position of the drive. If an error occurs while the +tape is being positioned by ZZOPMT we must detect the condition and mark the +position of the tape as indefinite (forcing a rewind on the next open). +If an interrupt occurs while positioning to EOT for a write, we do not +want ZZCLMT to write the new EOT mark somewhere in the middle of the tape, +truncating the tape. + + Interrupts or other errors while reading or writing are comparatively +harmless. Interrupting a write results in a short but otherwise normal +file on the tape; interrupting a read leaves us positioned to some +arbitrary record within the file (harmless). Conceivably a read +could be interrupted just as we were reading a tape mark, causing the +file position to be lost. We have not protected against this. + +.sh +Data Structures + + The mtio device descriptor structure describes the status of each magtape +device in use. The maximum number of magtape files which can be open at one +time is the maximum number of tape drives. Only one file can be open on each +drive at a time. + + +.ks +.nf + struct mtiodes { + int mt_drive # 1,2, etc. (c.t. a,b,...) + int mt_density # 0,800,1600,6250, etc. + int mt_oldfile # file number at open time + int mt_oldrecord # record number at open time + int mt_file # file being accessed (0=EOT) + int mt_record # next record to be accessed + int mt_nrecords # nrecords read/written + int mt_acmode # access mode + int mt_oschan # OS channel number + int mt_ateof # true when at EOF + int mt_ateot # true when at EOT + } mtiocom[MAX_TAPES] +.fi +.ke + + +When a device is allocated, a lock file is created in the system logical device +directory "dev$". For example, the lock file for magtape unit A is the +file "dev$mta.lok". This is a human readable text file; it is typed out on +the terminal when the user types "devstatus mta". The lock file is updated +when the drive is closed and deleted when the drive is deallocated. The drive +is automatically deallocated when the user logs out of the CL. + + +.ks +.nf +Sample Lock File: + + # Magtape unit 'mta' allocated to 'user' Sun 20:06:13 27-Nov-83 + current file = 4 + current record = 1 + 72 records read, EOF seen +.fi +.ke + + +The preliminary comments are written when the lock file is created, i.e., +when the device is allocated. Any number of comment lines are permitted. +They are merely copied when ZCLSMT updates the lock file. The remaining +records are written by ZCLSMT to record the current position of the tape, +and to inform the user of the device status. diff --git a/sys/mtio/doc/newdriver.notes b/sys/mtio/doc/newdriver.notes new file mode 100644 index 00000000..3ef2ca7f --- /dev/null +++ b/sys/mtio/doc/newdriver.notes @@ -0,0 +1,517 @@ + NEW IRAF MAGTAPE DRIVER + October 1991 + (design notes) + + +1. User Interface + +1.1 Magtape Specification + + Old format: + + mtX.density[file.record] + + New format: + + mtX['['file[.record][:(param|param@|param=value):...]']'] + + e.g., + + mtexb1[4:nb:se@:ts=1200:so=/dev/ttya8] + + mtX is used only as an index into the devices file, and is not + parsed. The tape density is no longer singled out as a special + parameter. If any parameters are specified, these parameters + override those given in the tapecap file entry. + + +1.2 TAPECAP file + + Current Format: + + irafname [%NNNN] device aliases + e.g., mtb.9 nrst8 rst8 nrst0 rst0 + + Revised Format: + + name[|alias|...]:cap=value:...:[tc=name:] + + Device parameters are specified in termcap file format. + + mta|mtexb1|Exabyte drive 1:\ + :dv=nrst0:rd=rst0:\ + :al=rst0,rst8,rst16,rst24,nrst0,nrst8,nrst16,nrst24:\ + :tc=exb-sunst: + exb-sunst|Exabyte via SunOS ST driver:\ + :bs#0:dt=Exabyte:fs#2200:mr#65535: + + This feature will use the new GTY interface. Modifications are + required to 1) allow specification of parameters at open time which + will override those given in the file, and 2) make the use of a # + for numeric parameters optional (accept either # or =). + + +1.3 I/O Monitoring + + Device and tape type and capacity are given in tapecap. + Keep track of tape usage along with file position in lock file. + Lock file provides simple means to track usage. A real time + display may optionally be provided by the driver writing to + a tape monitoring window via a file or socket, with the name + given in tapecap or on the command line. + + +2. Code Changes + + OS,KI + zfiomt.c - all host versions are affected as calling sequence + has changed. Network interface is affected (new tape system + and old iraf kernel servers are incompatible). + + The UNIX version of the new driver needs additional code to + optionally log status information to a file or special file. + Support for tcp/ip status logging as well? + + ETC + Device allocation code is affected by the devices file syntax + changes. + + MTIO + Must be changed to reflect magtape specfication and devices file + specification changes, i.e., the density parameter is omitted, + the device name is not quite the same thing, and a general + device parameter mechanism is added. + + The feature to keep track of the amount of tape used is device + and host independent (given adequate parameterization in the + devices file) hence can be implemented in MTIO. Output to the + user, and preservation of tape usage status over device closes, + will be via the .lok file and DEVSTATUS. + + The MTIO driver Z routines seem largely unaffected, except for + the status routine and the i/o routines, which need support added + for blocked devices. + + +3. Device Driver + +3.1. Device Classes + + generic generic device (open/close/read/write) + reel 800,1600,6250 bpi 1/2inch reel tape + cartridge various QIC formats - fixed size blocks + exabyte variable size blocks + dat variable size blocks + + +3.2. Device Parameters + +[[NOT KEPT UP TO DATE - refer to os$zfiomt.c for latest version. ]]]] + + CODE TYPE DEFAULT DESCRIPTION + + bs i 0 device block size (0 if variable) + dn i none density (bpi) + dt s generic drive type + fs i 0 filemark size (Kb) + mr i 65535 maximum record size + or i 63360 optimum record size + rs i 0 record gap size (bytes) + ts i 0 tape capacity (Mb) + tt s unknown tape type + + al s none device allocation info + dv s required no-rewind device file + rd s none rewind device file + so s none status output device file or socket + + bo b no BSF positions to BOF + fc b no device does a FSF on CLRO + ir b no treat all read errors as EOF + nb b no device cannot backspace + nf b no rewind and space forward to backspace file + np b no disable all positioning ioctls + ow b no backspace and overwrite EOT at append + re b no read at EOT returns ERR + rf b no use BSR,FSR to space over filemarks + se b no device will position past EOT in a read + sk b no skip record forward after a read error + wc b no OPWR-CLWR at EOF writes null file + + bf i builtin BSF ioctl code + br i builtin BSR ioctl code + ct i builtin MTIOCTOP code + ff i builtin FSF ioctl code + fr i builtin FSR ioctl code + ri i builtin REW ioctl code + + +3.3. Host Level Device Operations + + open (FILE I/O OPERATIONS) + close + read + write + wait (not used) + + FSR (POSITIONING IOCTLS) + BSR + FSF + BSF + REW + + WEOF (not used) + EOM (not used) (SunOS - space to end of media) + + +3.4. Device Characteristics + + open No known system/device dependencies. + + close For a tape opened read-only, close positions to after + the filemark of the current file on some SysV systems. + This makes it impossible to rewind a device opened + no-rewind (after the open/rewind/close the tape is + left at the beginning of the second file). On such + systems the tape can only be rewound (left rewound + at close) by opening and closing the rewind device. + + It is assumed that when a tape opened for writing is + closed an EOT mark is written, and the tape is left + positioned after the filemark of the last file + written, ready to write the next file (true on all + known systems, with some variations in how the EOT + is represented). + + read A read where the record size exceeds the size of the + read request is assumed to be an error. + + A read at end of file should return a zero byte + count and leave the file positioned after the file + mark. Some devices may return ERR when a tape mark + is read. + + If the device block size is zero it is assumed that + records can be any size up to the max record size, + and that successive records can vary in size. + + If the device block size is nonzero it is assumed + that the byte count for read and write requests (the + record size) should be a multiple of the device + block size. Multiple physical device blocks are + read or written to satisfy an i/o request. On a + read, all notion of the record size is lost, i.e., + a read of N blocks will return N blocks regardless + of the blocking factor used in a write. + + A read at EOT may leave the tape positioned after + the file mark just read or may result in a zero byte + count being returned with no affect on the tape + position. + + Following a read error when reading a data record the + tape may be left 1) before the bad record, 2) after + the bad record, 3) in an undefined position, e.g., + partway through the record. + + write For variable record devices each write is assumed + to write a tape record the size of the output buffer. + For fixed block devices it is assumed that the size + of the write request must be an integral multiple of + the block size, and that multiple physical device + blocks will be written to satisfy the request. + + wait Wait (asynchronous i/o) is not currently used and + is emulated in the driver. Some systems (Ultrix + and SunOS 4.1) provide facilities for multi-buffered + asynchronous i/o which the iraf driver may make use + of in the future. + + FSR Forward skip record. Some systems permit a FSR over + a filemark and some do not. + + BSR Backward skip record. Some systems permit a BSR over + a filemark and some do not. + + FSF Forward skip file. The tape is assumed to be left + positioned after the filemark and before the first + record of the next file. + + BSF Backward skip file. Some systems leave the tape + positioned on the BOT side of the filemark, others + leave the tape positioned to just before the first + record of the file following the filemark. A BSF with + a zero count may or may not rewind the current file. + + REW Rewinds the tape, leaving the tape positioned to BOT. + No known system/device dependencies. See the note + on the "close" operation, above. + + WEOF Not currently used. + + +3.5. Driver Options + + overwrite filemark (reel tapes only) + disable all backspace operations + skip record forward after a read error + i/o logging to specified output device + + +3.6. Driver Functions + + ZZOPMT - open and position to desired file + zmtopen + zmtclose + zmtposition + zmtrew + zmtfsf + zmtbsf + zmtfsr + zmtbsr + + ZZCLMT - close + zmtclose + + ZZRDMT - read next record + read + zmtbsf + + ZZWRMT - write record + write + + ZZWTMT - wait for i/o and return byte count + + ZZRWMT - rewind tape + zmtopen + zmtclose + + ZZSTMT - return device parameters + + +3.7. Notes on Specific Devices + +3.7.1 Device Characteristics + +3.7.2 Exabyte Drivers + + SunOS 4.1 ST Driver + BSF positions to BOT side of filemark (conventional behavior). + Driver does not allow positioning to after EOT. + Bug where driver loses track of file position is fixed. + + SunOS 4.0.3 ST Driver + BSF positions to first record of file following file mark. + BSF 0 rewinds the current file. + Driver does not allow positioning to after EOT, i.e., when + positioning to EOT, after two successive zero reads, + it is NOT necessary to backspace over the filemark. + Driver tries to keep track of current file position but has + a bug which causes it to zero its counter when appending + a file to a tape within open/close. + This bug has two ramifications: + o Will not position to a file before where it thinks + BOT is. + o Will rewind to get to file it thinks is at BOT. + + Earlier (SunOS 3.X) Sun drivers defaulted to fixed block mode, and + probably had other significant differences from the current + round of drivers. + + Ciprico RT Driver + Both fixed and variable block device entries. + rfsd_pr_errlog can get set to 1|2|8 in driver (/dev/mem) to + turn on status messages. Variable is commonly set to 2 + to get tape position readouts, but this will interfere + with iraf networking. + BSF positions to BOT side of filemark (conventional behavior). + EOT is indicated by two file marks, and a read of the second mark + will leave the tape positioned to after the mark, requiring + a backspace to position to EOT (conventional behavior). + Status (NOP) ioctl implemented, but file/record count always zero. + + Sparcstation (4.1) ST driver + BSR over a filemark confuses the driver - looks like it thinks + it saw the EOF when reading in the forward direction. + The next read returns EOF and then the real EOF is read, + so 2 EOFs in a row are seen (looks like EOT). The file + count in the driver gets messed up. + BSF causes all subsequent reads to return immediately with ERR. + One (sometimes two!) REW ioctls are required to clear. + FSF and FSR work. + + R-Squared driver for Exabyte (Sun-3 running 4.1) + Opens drive in fixed block mode. + Read at EOF returns IOERR (driver bug). + Status (NOP) ioctl not implemented. + + +3.8. Pseudocode for Driver Functions + + +# ZZOPMT -- Open the magtape device and position to the given file. + +procedure zzopmt (device, acmode, oldrec, oldfile, newfile, chan) +begin + # Open device for positioning. + open no-rewind raw device read-only + + # Do not move the tape if opened newfile=0. + if (newfile != 0) { + # Rewind to get to known position if position uncertain. + if (current position unknown) { + rewind tape + oldrec = 1 + oldfile = 1 + } + + # Position to given file. + newfile = zmtfpos (chan, oldfile, oldrec, newfile) + } + + # Reopen if necessary for i/o. + if (need write access) + reopen device for writing +end + + +# ZZCLMT -- Close the magtape device. + +procedure zzclmt (chan, acmode, nrecords, nfiles, status) +begin + close device + + nfiles = 0 + nrecords = 0 + + if (acmode == read && device: FSF on close read-only) + nfiles = 1 + else if (acmode == write && !(at BOF && device: no EOF if no write)) + nfiles = 1 +end + + +# ZZRDMT -- Initiate a read of the next tape record into the user buffer. + +procedure zzrdmt (chan, buf, maxbytes) +begin + physically read tape + save read status for zzwtmt +end + + +# ZZWRMT -- Initiate a write of the next tape record. + +procedure zzwrmt (chan, buf, nbytes) +begin + physically write record + save write status for zzwtmt +end + + +# ZZWTMT -- Wait for i/o to complete and return the byte count and the +# change to the tape position in files and records. + +procedure zzwtmt (chan, nrecords, nfiles, nbytes) +begin + nrecords = 0 + nfiles = 0 + + if (io error) { + nbytes = ERR + } else if (read 0 bytes) { + if (at BOF) { + # At EOT. + if (device: read at EOT will go past EOT) + if (device: cannot backspace) { + zmtrew() + nfiles = -ARB + nrecords = -ARB + } else + zmtbsf (1) + } else + nfiles = 1 + } else { + nrecords = 1 + clear at BOF flag + } +end + + +# ZZRWMT -- Rewind the named device. + +procedure zzrwmt (device, status) +begin + if (device: rewind device specified) + close (open (rewind-at-close device read-only)) + else { + open no rewind device + zmtrew + close + } +end + + +# ZMTFPOS -- Position to the indicated file. + +int procedure zmtfpos (chan, oldfile, oldrec, newfile) +begin + # Already positioned to desired file; don't do anything. + if (newfile == oldfile && oldrec == 1) + return (newfile) + + # Move the tape. + if (newfile == 1) { + # Rewind. + zzrwmt() + } else if (newfile <= oldfile && newfile != EOT) { + # Backspace to desired file. + if (device: cannot backspace) { + zmtrew() + oldfile = 1 + oldrec = 1 + goto fwd_ + } else if (device: BSF positions to BOF) { + zmtbsf (oldfile - newfile) + } else { + zmtbsf (oldfile - newfile + 1) + zmtfsf (1) + } + } else { + # Space forward to desired file or EOT. +fwd_ while (oldfile < newfile || newfile == EOT) { + n = read (next record) + if (n == 0 && oldrec == 1) { + # At EOT. + if (device: read at EOT will go past EOT) { + if (device: cannot backspace) { + newfile = oldfile + zmtrew() + oldfile = 1 + oldrec = 1 + goto fwd_ + } else + zmtbsf (1) + } + if (writing && device: overwrite EOF) { + if (!device: cannot backspace) { + if (device: BSF positions to BOF) + zmtbsf (0) + else { + zmtbsf (1) + zmtfsf (1) + } + } + } + break + } else if (n > 0) + zmtfsf (1) + + oldfile++ + oldrec = 1 + } + newfile = oldfile + } + + return (newfile) +end diff --git a/sys/mtio/mkpkg b/sys/mtio/mkpkg new file mode 100644 index 00000000..2c0ce77f --- /dev/null +++ b/sys/mtio/mkpkg @@ -0,0 +1,48 @@ +# Make the MTIO routines. + +$checkout libsys.a lib$ +$update libsys.a +$checkin libsys.a lib$ +$exit + +zzdebug: + $checkout libsys.a lib$ + $update libsys.a + $checkin libsys.a lib$ + + #$set XFLAGS = "$(XFLAGS) -qx" + $omake zzdebug.x + $link -z zzdebug.o + ; + +libsys.a: + #$set XFLAGS = "$(XFLAGS) -qx" + + mtalloc.x mtio.h + mtcache.x mtcache.com mtio.com mtio.h + mtcap.x mtio.h + mtclean.x mtio.h + mtdealloc.x + mtdevall.x + mtencode.x + mtfile.x + mtfname.x mtio.h + mtglock.x mtio.h + mtgtyopen.x mtio.h + mtlocknam.x mtio.h + mtneedf.x mtio.h + mtopen.x mtio.com mtio.h + mtparse.x mtio.h + mtpos.x mtio.h + mtrdlock.x mtio.com mtio.h + mtrewind.x mtio.h + mtskip.x + mtstatus.x + mtupdlock.x mtio.com mtio.h + zardmt.x mtio.com mtio.h + zawrmt.x mtio.com mtio.h + zawtmt.x mtio.com mtio.h + zclsmt.x mtio.com mtio.h + zopnmt.x mtio.com mtio.h + zsttmt.x mtio.com mtio.h + ; diff --git a/sys/mtio/mtalloc.x b/sys/mtio/mtalloc.x new file mode 100644 index 00000000..2e21be1c --- /dev/null +++ b/sys/mtio/mtalloc.x @@ -0,0 +1,64 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mtio.h" + +# MTALLOCATE -- "Allocate" a tape drive by writing the lock file. We do +# not actually call the OS to physically allocate the drive; that is done +# by our caller (e.g., xallocate, in etc$xalloc.x). The lock file is no longer +# used to gain exclusive access to the device; it is now used only to keep +# track of the tape position after process termination. + +procedure mtallocate (mtname) + +char mtname[ARB] #I device name + +int fd, junk +pointer sp, lockfile, mtowner, userid, timestr, device +errchk open, mtparse +long clktime() +int open() + +begin + call smark (sp) + call salloc (device, SZ_FNAME, TY_CHAR) + call salloc (lockfile, SZ_FNAME, TY_CHAR) + call salloc (mtowner, SZ_FNAME, TY_CHAR) + call salloc (userid, SZ_FNAME, TY_CHAR) + call salloc (timestr, SZ_TIME, TY_CHAR) + + # Get name of lockfile used by the given device. + call mtparse (mtname, Memc[device], SZ_FNAME, junk, junk, junk, 0) + call mt_glock (mtname, Memc[lockfile], SZ_FNAME) + + # Open lock file and write out unit, owner, time allocated, etc. + # Overwrite any existing lockfile. We are called only after + # physically allocating the device at the host system level + # (and are not called if the device is already allocated), so this + # is safe. + + iferr (call delete (Memc[lockfile])) + ; + fd = open (Memc[lockfile], NEW_FILE, TEXT_FILE) + + call cnvtime (clktime(long(0)), Memc[timestr], SZ_TIME) + call getuid (Memc[userid], SZ_FNAME) + + call fprintf (fd, "# Magtape unit %s status %s user %s\n") + call pargstr (Memc[device]) + call pargstr (Memc[timestr]) + call pargstr (Memc[userid]) + + # Assume initially that the tape position is undefined. This will + # cause the tape to be rewound on the first open, and thereafter + # the position will be defined unless an i/o error occurs. + + call fprintf (fd, "file = -1\n") + call fprintf (fd, "record = -1\n") + call fprintf (fd, "nfiles = 0\n") + call fprintf (fd, "tapeused = 0 Kb\n") + call fprintf (fd, "pflags = 0\n") + + call close (fd) + call sfree (sp) +end diff --git a/sys/mtio/mtcache.com b/sys/mtio/mtcache.com new file mode 100644 index 00000000..b3533f3f --- /dev/null +++ b/sys/mtio/mtcache.com @@ -0,0 +1,9 @@ +# MTIO savepos cache. + +int c_modified[SZ_CACHE] +int c_mtdes[LEN_DEVPOS,SZ_CACHE] +char c_device[SZ_DEVICE,SZ_CACHE] +char c_iodev[SZ_IODEV,SZ_CACHE] +char c_lkname[SZ_LKNAME,SZ_CACHE] + +common /mtcacm/ c_modified, c_mtdes, c_device, c_iodev, c_lkname diff --git a/sys/mtio/mtcache.x b/sys/mtio/mtcache.x new file mode 100644 index 00000000..87b68bdb --- /dev/null +++ b/sys/mtio/mtcache.x @@ -0,0 +1,199 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "mtio.h" + +.help mtcache +.nf _________________________________________________________________________ +MTCACHE -- Cache the magtape position (file and record) between file opens. +The lock file is used for permanent storage, but is only read and written +when necessary. When multiple tape files are accessed by a single task the +tape position is kept in the cache between successive MTOPEN - CLOSE file +accesses. + + mt_getpos (mtname, mt) + mt_savepos (mt) + mt_sync (status) + mt_clrcache () + +SAVEPOS updates the tape descriptor in the cache; SYNC updates the cache +on disk in the lock file. SYNC is automatically called at task termination +time (including during abnormal termination), but is not normally called +when a tape file is closed. + +ERROR RECOVERY is a bit tricky. If error recovery takes place the ONERROR +procedures are called first thing, before FIO cleanup takes place. That means +that SYNC will be called while the magtape channel is still open, and before +SAVEPOS has been called by ZCLSMT (which is called by fio_cleanup which is +called by the main). If an error occurs on a magtape channel we want to +record an undefined file position. We must see that SAVEPOS is called at +file open time to mark the cache for updating, causing SYNC to write an +undefined position lock file when the error occurs. ZCLSMT, when called +during error recovery, should set the position to undefined but need not +sync the cache. + +The cache is invalidated at process startup time and at SYNC time in case +the user loads a new tape or runs a different magtape process while the +current process is idling between tasks. In other words, the cache is only +valid while the task using it is executing. +.endhelp ___________________________________________________________________ + +define SZ_CACHE MT_MAXTAPES + + +# MT_GETPOS -- Return the device position descriptor of a drive given its +# unit number. + +procedure mt_getpos (mtname, mt) + +char mtname[ARB] #I device name +int mt #I MTIO descriptor + +int slot +bool streq() +include "mtcache.com" +include "mtio.com" + +begin + # First look in the cache. + for (slot=1; slot <= SZ_CACHE; slot=slot+1) + if (streq (MT_LKNAME(mt), c_lkname[1,slot])) { + call amovi (c_mtdes[1,slot], MT_DEVPOS(mt), LEN_DEVPOS) + call strcpy (c_device[1,slot], MT_DEVICE(mt), SZ_DEVICE) + call strcpy (c_lkname[1,slot], MT_LKNAME(mt), SZ_LKNAME) + call strcpy (c_iodev[1,slot], MT_IODEV(mt), SZ_IODEV) + return + } + + # Get the current position from the lock file, if there is one. + call mt_read_lockfile (mtname, mt) +end + + +# MT_SAVEPOS -- Save the current position in the cache. The entire descriptor +# is saved since most of the information therein is needed for SYNC, even +# though only a portion of the information will be used by GETPOS. + +procedure mt_savepos (mt) + +int mt #I MTIO descriptor + +int prev, slot +bool streq(), strne() +extern mt_sync() +include "mtcache.com" +include "mtio.com" +data prev /0/ +define cache_ 91 + +begin + # Post termination handler to sync the cache at task termination time. + call onerror (mt_sync) + + # Do not update the cache if the file position is undefined. + if (MT_FILNO(mt) <= 0) + return + + # Are we updating an entry already in the cache? + for (slot=1; slot <= SZ_CACHE; slot=slot+1) + if (streq (MT_LKNAME(mt), c_lkname[1,slot])) + goto cache_ + + # Add the entry to the cache. Resync the contents of the old slot + # if it is for a different drive and has been modified since it was + # last synced. + + slot = prev + 1 + if (slot > SZ_CACHE) + slot = 1 + prev = slot + + if (c_modified[slot] == YES && strne(MT_LKNAME(mt),c_lkname[1,slot])) { + call amovi (c_mtdes[1,slot], MT_DEVPOS(0), LEN_DEVPOS) + call strcpy (c_device[1,slot], MT_DEVICE(0), SZ_DEVICE) + call strcpy (c_lkname[1,slot], MT_LKNAME(0), SZ_LKNAME) + call strcpy (c_iodev[1,slot], MT_IODEV(0), SZ_IODEV) + call mt_update_lockfile (0) + } + +cache_ + call amovi (MT_DEVPOS(mt), c_mtdes[1,slot], LEN_DEVPOS) + call strcpy (MT_DEVICE(mt), c_device[1,slot], SZ_DEVICE) + call strcpy (MT_LKNAME(mt), c_lkname[1,slot], SZ_LKNAME) + call strcpy (MT_IODEV(mt), c_iodev[1,slot], SZ_IODEV) + c_modified[slot] = YES +end + + +# MT_SYNC -- Update all modified entries in the cache. Set the position to +# undefined (file=-1) if we are called during error recovery. We are called +# at task termination by the IRAF Main. + +procedure mt_sync (status) + +int status #I task termination status + +int slot +include "mtcache.com" +include "mtio.com" + +begin + # Update the .lok files of any active devices. + for (slot=1; slot <= SZ_CACHE; slot=slot+1) { + if (c_modified[slot] == YES) { + # If called during error recovery mark the file position undef. + if (status != OK) { + call amovi (c_mtdes[1,slot], MT_DEVPOS(0), LEN_DEVPOS) + MT_FILNO(0) = -1 + MT_RECNO(0) = -1 + call amovi (MT_DEVPOS(0), c_mtdes[1,slot], LEN_DEVPOS) + } + + # Update the lockfile. + call amovi (c_mtdes[1,slot], MT_DEVPOS(0), LEN_DEVPOS) + call strcpy (c_device[1,slot], MT_DEVICE(0), SZ_DEVICE) + call strcpy (c_lkname[1,slot], MT_LKNAME(0), SZ_LKNAME) + call strcpy (c_iodev[1,slot], MT_IODEV(0), SZ_IODEV) + + # Ignore errors if we are called during error recovery. + iferr (call mt_update_lockfile (0)) + if (status == OK) + call erract (EA_ERROR) + + c_modified[slot] = NO + c_device[1,slot] = EOS + } + } + + # Invalidate the cache when a task terminates. + call mt_clrcache() + + # If we are called during error recovery, set the file position for + # all open tapes to undefined to prevent mt_savepos from being called + # by zclsmt when the tape file is closed during error recovery. + + if (status != OK) + do slot = 1, MT_MAXTAPES { + MT_FILNO(slot) = -1 + MT_RECNO(slot) = -1 + } +end + + +# MT_CLRCACHE -- Initialize the cache. + +procedure mt_clrcache() + +int slot +include "mtcache.com" + +begin + for (slot=1; slot <= SZ_CACHE; slot=slot+1) { + c_modified[slot] = NO + c_device[1,slot] = EOS + c_lkname[1,slot] = EOS + c_iodev[1,slot] = EOS + call aclri (c_mtdes[1,slot], LEN_DEVPOS) + } +end diff --git a/sys/mtio/mtcap.x b/sys/mtio/mtcap.x new file mode 100644 index 00000000..d3f859fa --- /dev/null +++ b/sys/mtio/mtcap.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "mtio.h" + +# MTCAP -- Return the tapecap descriptor for the given magtape device. The +# device is specified by the full specification (as passed to mtopen), hence +# there may be tapecap attributes in the device specification which override +# those in the tapecap file. + +pointer procedure mtcap (mtname) + +char mtname[ARB] #I magtape device specification + +int fileno, recno +pointer sp, device, devcap, cache_gty, gty +pointer mt_gtyopen(), gtycaps(), gtyopen() +errchk mtparse, mt_gtyopen + +begin + call smark (sp) + call salloc (device, SZ_DEVICE, TY_CHAR) + call salloc (devcap, SZ_DEVCAP, TY_CHAR) + + call mtparse (mtname, Memc[device], SZ_DEVICE, fileno, recno, + Memc[devcap], SZ_DEVCAP) + + # Do not return the cached MTIO device entry, as we do not want the + # application to close this with gtyclose. Open a new GTY descriptor + # using the capabilities in the cached entry. + + cache_gty = mt_gtyopen (Memc[device], Memc[devcap]) + gty = gtyopen ("", "", Memc[gtycaps(cache_gty)]) + + call sfree (sp) + return (gty) +end diff --git a/sys/mtio/mtclean.x b/sys/mtio/mtclean.x new file mode 100644 index 00000000..5de01a7e --- /dev/null +++ b/sys/mtio/mtclean.x @@ -0,0 +1,110 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "mtio.h" + +# MTCLEAN -- Clean the lock file area. This routine is called periodically +# by the system (e.g. during CL startup) to scan the lock file area and +# deleted old lock files. This prevents old lock files which are no longer +# valid from erroneously being used to indicate the current tape position. +# +# What mtclean does is similar to "delete tmp$mt*.lok" except that, since all +# users store lok files in the same area, we don't want to delete all the +# files indiscriminately. The default action is to delete only files for +# unallocated devices, or for devices allocated to the current user for which +# the lok file is more than STALE seconds old. It is harmless to delete a +# lok file unnecessarily in that MTIO will recover automatically, but doing +# so will force the tape to be rewound to regain a known position. + +procedure mtclean (level, stale, out) + +int level #I 0 for default; 1 to delete all .lok files +int stale #I delete lok file if older than stale seconds +int out #I if nonzero, print messages to this file + +int fd, status +pointer list, ip, cp, device +pointer sp, fname, owner, template, lbuf +long fi[LEN_FINFO] + +pointer fntopn() +long clktime() +int gstrmatch(), xdevowner() +int open(), getline(), finfo(), fntgfn() +define del_ 91 + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (owner, SZ_FNAME, TY_CHAR) + call salloc (template, SZ_FNAME, TY_CHAR) + + # Get file name template matching all lock files. + call sprintf (Memc[template], SZ_FNAME, "%s%s*%s") + call pargstr (LOCKLDIR) + call pargstr (LOCKFILE) + call pargstr (LOCKEXTN) + + # Open a file list. + list = fntopn (Memc[template]) + + # Examine each file in turn and delete if delete criteria satisfied. + while (fntgfn (list, Memc[fname], SZ_FNAME) != EOF) { + + # If level is nonzero (force-delete) delete unconditionally. + if (level != 0) + goto del_ + + # Open lok file and get device name. + iferr (fd = open (Memc[fname], READ_ONLY, TEXT_FILE)) + next + if (getline (fd, Memc[lbuf]) == EOF) { + call close (fd) + goto del_ + } + if (gstrmatch (Memc[lbuf], "unit ", status, ip) <= 0) { + call close (fd) + goto del_ + } + device = lbuf + ip + for (cp=device; Memc[cp] != EOS && Memc[cp] != ' '; cp=cp+1) + ; + Memc[cp] = EOS + call close (fd) + + # Determine if the device is currently allocated. If the device + # is not allocated delete the lok file unconditionally. If the + # device is allocated to someone else leave the lok file alone. + # If the lok file is allocated to the current user delete it if + # the file is older than the stale value. + + status = xdevowner (Memc[device], Memc[owner], SZ_FNAME) + switch (status) { + case DV_DEVFREE: + goto del_ + + case DV_DEVINUSE: + # Do nothing. + + case DV_DEVALLOC: + # Delete the file if older than the stale value. + if (finfo (Memc[fname], fi) == ERR) + goto del_ + + if (clktime(FI_MTIME(fi)) > stale) { + # Delete the file. +del_ if (out != NULL) { + call fprintf (out, "delete lok file %s\n") + call pargstr (Memc[fname]) + } + iferr (call delete (Memc[fname])) + ; + } + } + } + + call fntcls (list) + call sfree (sp) +end diff --git a/sys/mtio/mtdealloc.x b/sys/mtio/mtdealloc.x new file mode 100644 index 00000000..2f98a972 --- /dev/null +++ b/sys/mtio/mtdealloc.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MTDEALLOCATE -- Deallocate a previously allocated tape drive. To deallocate +# a drive we try to rewind (any errors, such as drive offline, will result in a +# warning message), and then delete the lockfile. We do not call up the OS to +# deallocate the drive; that is done at a higher level, usually XDEALLOCATE +# (in etc$xalloc.x). + +procedure mtdeallocate (mtname, rewind_tape) + +char mtname[ARB] #I magtape specification +int rewind_tape #I rewind before deallocating drive + +pointer sp, lockfile +errchk mt_glock, syserrs + +begin + call smark (sp) + call salloc (lockfile, SZ_FNAME, TY_CHAR) + + if (rewind_tape == YES) + iferr (call mtrewind (mtname, NO)) + call erract (EA_WARN) + + call mt_sync (OK) + + call mt_glock (mtname, Memc[lockfile], SZ_FNAME) + iferr (call delete (Memc[lockfile])) + ; + + call mt_clrcache() + call sfree (sp) +end diff --git a/sys/mtio/mtdevall.x b/sys/mtio/mtdevall.x new file mode 100644 index 00000000..3f5620d8 --- /dev/null +++ b/sys/mtio/mtdevall.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# MT_DEVALLOCATED -- Verify that the named host magtape device is allocated. +# The IRAF device name must already have been translated to a host device +# name before we are called. + +int procedure mt_devallocated (iodev) + +char iodev[ARB] #I host name of device +pointer sp, pk_iodev, pk_owner +int status + +begin + call smark (sp) + call salloc (pk_iodev, SZ_FNAME, TY_CHAR) + call salloc (pk_owner, SZ_FNAME, TY_CHAR) + + # The following assumes that the node! prefix is in iodev. + call strpak (iodev, Memc[pk_iodev], SZ_FNAME) + call zdvown (Memc[pk_iodev], Memc[pk_owner], SZ_FNAME, status) + + call sfree (sp) + if (status == DV_DEVALLOC) + return (YES) + else + return (NO) +end diff --git a/sys/mtio/mtencode.x b/sys/mtio/mtencode.x new file mode 100644 index 00000000..b6bf6b0f --- /dev/null +++ b/sys/mtio/mtencode.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# MTENCODE -- Construct a full magtape device specification. This routine is +# the opposite of MTPARSE. If the file and record numbers are to be omitted +# from the output mtname they should be passed as ERR. + +procedure mtencode (outstr, maxch, device, fileno, recno, attrl) + +char outstr[ARB] #O magtape device specification +int maxch #I max chars out +char device[ARB] #I device name (incl node) +int fileno, recno #I file and record numbers, or ERR +char attrl[ARB] #I tapecap attributes + +int op +int gstrcpy() +int itoc() + +begin + if (fileno != ERR || recno != ERR || attrl[1] != EOS) { + op = gstrcpy (device, outstr, maxch) + 1 + outstr[op] = '['; op = op + 1 + if (fileno != ERR) { + if (fileno == EOT) + op = op + gstrcpy ("EOT", outstr[op], maxch-op+1) + else + op = op + itoc (fileno, outstr[op], maxch-op+1) + } + if (recno != ERR) { + outstr[op] = '.'; op = op + 1 + op = op + itoc (recno, outstr[op], maxch-op+1) + } + if (attrl[1] != EOS) { + if (attrl[1] != ':') { + outstr[op] = ':' + op = op + 1 + } + op = op + gstrcpy (attrl, outstr[op], maxch-op+1) + } + outstr[op] = ']'; op = op + 1 + outstr[op] = EOS + } else + call strcpy (device, outstr, maxch) +end diff --git a/sys/mtio/mtfile.x b/sys/mtio/mtfile.x new file mode 100644 index 00000000..c07a550b --- /dev/null +++ b/sys/mtio/mtfile.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define SZ_NODENAME 9 + +# MTFILE -- Test a filename to see if it is the name of a magtape file. +# A magtape file is characterized by the filename prefix "mt" (ingnoring +# the nodename prefix if any). + +int procedure mtfile (fname) + +char fname[ARB] #I filename to be tested + +int ip, junk +char nodename[SZ_NODENAME] +int ki_extnode() + +begin + ip = ki_extnode (fname, nodename, SZ_NODENAME, junk) + 1 + + if (fname[ip] == 'm' && fname[ip+1] == 't') + return (YES) + else + return (NO) +end diff --git a/sys/mtio/mtfname.x b/sys/mtio/mtfname.x new file mode 100644 index 00000000..7bb92408 --- /dev/null +++ b/sys/mtio/mtfname.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "mtio.h" + +# MTFNAME -- Edit the input mtname (magtape file specification) to reference +# the numbered file. The edited mtname is returned in the output string. + +procedure mtfname (mtname, fileno, outstr, maxch) + +char mtname[ARB] #I magtape device specification +int fileno #I desired file number +char outstr[ARB] #O output mtname string +int maxch #I maxch chars out + +int ofileno, orecno +pointer sp, device, devcap + +begin + call smark (sp) + call salloc (device, SZ_DEVICE, TY_CHAR) + call salloc (devcap, SZ_DEVCAP, TY_CHAR) + + call mtparse (mtname, Memc[device], SZ_DEVICE, ofileno, orecno, + Memc[devcap], SZ_DEVCAP) + call mtencode (outstr, maxch, + Memc[device], fileno, orecno, Memc[devcap]) + + call sfree (sp) +end diff --git a/sys/mtio/mtglock.x b/sys/mtio/mtglock.x new file mode 100644 index 00000000..a1abfef5 --- /dev/null +++ b/sys/mtio/mtglock.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mtio.h" + +# MT_GLOCK -- Return the lockfile name for the given magtape device +# specification. There can be many logical devices, defined in the tapecap +# file, which refer to the same physical device. All entries for the same +# physical device share the same i/o device file and lock file. If the +# physical device is on a remote node the tapecap file on that node should +# be accessed, and the node name must be included in the lockfile file name, +# although the lock file is always written on the local node. + +procedure mt_glock (mtname, lockfile, maxch) + +char mtname[ARB] #I full magtape device spec +char lockfile[ARB] #O receives lockfile name +int maxch #I max chars out + +int filno, recno +pointer sp, lkname, device, devcap, gty +errchk mt_gtyopen, syserrs +int gtygets() +pointer mt_gtyopen() + +begin + call smark (sp) + call salloc (lkname, SZ_FNAME, TY_CHAR) + call salloc (device, SZ_FNAME, TY_CHAR) + call salloc (devcap, SZ_DEVCAP, TY_CHAR) + + call mtparse (mtname, + Memc[device], SZ_FNAME, filno, recno, Memc[devcap], SZ_DEVCAP) + + # The "lk" capability specifies the lock file root name. + gty = mt_gtyopen (Memc[device], Memc[devcap]) + if (gtygets (gty, "lk", Memc[lkname], SZ_FNAME) <= 0) { + call eprintf ("missing `lk' parameter in tapecap entry for %s\n") + call pargstr (mtname) + call syserrs (SYS_MTTAPECAP, mtname) + } + + call ki_xnode (Memc[device], Memc[lkname], SZ_FNAME) + call mt_lockname (Memc[lkname], lockfile, maxch) + + call sfree (sp) +end diff --git a/sys/mtio/mtgtyopen.x b/sys/mtio/mtgtyopen.x new file mode 100644 index 00000000..489fba2d --- /dev/null +++ b/sys/mtio/mtgtyopen.x @@ -0,0 +1,129 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mtio.h" + +# MT_GTYOPEN -- Given a logical device name, open the tapecap file and extract +# the entry for the named device into an open GTY descriptor. The descriptor +# pointer is returned as the function value. The last entry accessed is +# cached indefinitely so that repeated references cause the tapecap file to +# be scanned only once. +# +# The tapecap file may be defined in the user environment, otherwise it +# defaults to the compiled in default TAPECAP (dev$tapecap). The format +# of the "tapecap" environment variable is "filename[:devcap]", e.g. +# +# home$tapecap:so +# +# +# would cause the file home$tapecap to be used as the tapecap file, adding the +# device capabilities :so to each tapecap device access (any devcap fields +# given on the command line will override these). Either the filename or +# devcap field may be omitted. For example, reset tapecap = ":so" causes +# the default tapecap file dev$tapecap to be used, but enables status output +# logging in each magtape access. + +pointer procedure mt_gtyopen (device, ufields) + +char device[ARB] #I local device name (incl node) +char ufields[ARB] #I optional user tapecap fields + +int len_ufields, junk +char c_device[SZ_DEVICE] +char c_ufields[SZ_DEVCAP] +bool first_time, capseen, remote +pointer c_gty, gty, sp, tapecap, devcap, ip, op +pointer fname, dname, nname, tname + +bool streq() +pointer gtyopen() +int envfind(), stridxs(), strlen(), gstrcpy(), ki_gnode() +errchk gtyopen, syserrs +data first_time /true/ + +begin + # First time initialization. + if (first_time) { + c_gty = NULL + first_time = false + } + + # Check the cache. + if (c_gty != NULL && streq(device,c_device) && streq(ufields,c_ufields)) + return (c_gty) + + # Cache miss. Free the old descriptor. + if (c_gty != NULL) + call gtyclose (c_gty) + + call smark (sp) + call salloc (tapecap, SZ_DEVCAP, TY_CHAR) + call salloc (devcap, SZ_DEVCAP, TY_CHAR) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (tname, SZ_PATHNAME, TY_CHAR) + call salloc (dname, SZ_FNAME, TY_CHAR) + call salloc (nname, SZ_FNAME, TY_CHAR) + + # Get tapecap definition. + if (envfind ("tapecap", Memc[tapecap], SZ_DEVCAP) <= 0) + call strcpy (TAPECAP, Memc[tapecap], SZ_DEVCAP) + + # Parse into filename and devcap fields. + op = fname + capseen = false + len_ufields = gstrcpy (ufields, Memc[devcap], SZ_DEVCAP) + for (ip=tapecap; Memc[ip] != EOS; ip=ip+1) { + if (Memc[ip] == ':' && !capseen) { + Memc[op] = EOS + op = devcap + len_ufields + capseen = true + } + Memc[op] = Memc[ip] + op = op + 1 + } + Memc[op] = EOS + + # Supply default filename if none given. + if (Memc[fname] == EOS) + call strcpy (TAPECAP, Memc[fname], SZ_PATHNAME) + + # If no node is specified for the tapecap file, access the tapecap + # file on the same node as the magtape device file. + + if (stridxs ("!", Memc[fname]) <= 0) + call ki_xnode (device, Memc[fname], SZ_PATHNAME) + + # Get the node name the device is on. + remote = (ki_gnode (Memc[fname], Memc[nname], junk) != 0) + + # Get the tapecap device name minus any node prefix. + call strcpy (device, Memc[dname], SZ_FNAME) + call ki_xnode ("", Memc[dname], SZ_FNAME) + + # Open the tapecap entry. Try "tapecap." first then "tapecap". + # is the hostname of the host the tape device is on, i.e. the + # network server on which the drive is located. The "tapecap." + # feature allows a shared common IRAF installation to support distinct + # tapecap files for different servers, falling back on the standard + # tapecap file if no node-specific file is found. + + call strcpy (Memc[fname], Memc[tname], SZ_PATHNAME) + call strcat (".", Memc[tname], SZ_PATHNAME) + call strcat (Memc[nname], Memc[tname], SZ_PATHNAME) + + iferr (gty = gtyopen (Memc[tname], Memc[dname], Memc[devcap])) + iferr (gty = gtyopen (Memc[fname], Memc[dname], Memc[devcap])) + call syserrs (SYS_MTTAPECAP, device) + if (gty == NULL) + call syserrs (SYS_MTTAPECAP, device) + + # Update the cache. + if (strlen(ufields) <= SZ_DEVCAP) { + call strcpy (device, c_device, SZ_DEVICE) + call strcpy (Memc[devcap], c_ufields, SZ_DEVCAP) + c_gty = gty + } + + call sfree (sp) + return (gty) +end diff --git a/sys/mtio/mtio.com b/sys/mtio/mtio.com new file mode 100644 index 00000000..8accab3b --- /dev/null +++ b/sys/mtio/mtio.com @@ -0,0 +1,9 @@ +# The MTIO Common. + +int new_mtchan # flag newly opened channel +int mtdev[LEN_MTIODES,MT_MAXTAPES+1] # integer fields +char mtnam[SZ_DEVICE,MT_MAXTAPES+1] # array of drive names +char mtosn[SZ_IODEV,MT_MAXTAPES+1] # host name for device +char mtlkn[SZ_LKNAME,MT_MAXTAPES+1] # lock file name + +common /mtiocom/ new_mtchan, mtdev, mtnam, mtosn, mtlkn diff --git a/sys/mtio/mtio.h b/sys/mtio/mtio.h new file mode 100644 index 00000000..a400a88a --- /dev/null +++ b/sys/mtio/mtio.h @@ -0,0 +1,42 @@ +# MTIO.H -- Magtape i/o interface definitions. Note that the system config +# file contains additional definitions (i.e., MT_MAXTAPES). + +define TAPECAP "dev$tapecap" # default tapecap file +define LOCKLDIR "tmp$" # where the lock file goes +define LOCKFILE "mt" # root lockfile name +define LOCKEXTN ".lok" # lockfile extension +define MT_MAGIC (-5417) # was zopnmt called by mtopen? +define SZ_DEVICE 79 # max length of drive name +define SZ_IODEV 79 # max length host device name +define SZ_LKNAME 79 # max length lock file mame +define SZ_DEVCAP 512 # max command line tapecap chars + +# MTIO device descriptor structure. The device descriptor is implemented +# as the two dimensional integer array MTDEV, defined in the mtio common. +# The DEVPOS substructure must agree with the driver, os$zfiomt.c. + +define MT_DEVICE mtnam[1,$1+1] # drive name +define MT_IODEV mtosn[1,$1+1] # i/o device +define MT_LKNAME mtlkn[1,$1+1] # lock file name + +define LEN_MTIODES 11 +define MT_DEVPOS MT_FILNO # devpos struct (passed to driver) +define LEN_DEVPOS 5 + +define MT_OSCHAN mtdev[1,$1+1] # OS channel or 0 +define MT_ACMODE mtdev[2,$1+1] # new access mode +define MT_DEVCAP mtdev[3,$1+1] # pointer to tapecap entry for device +define MT_FILE mtdev[4,$1+1] # new file number +define MT_RECORD mtdev[5,$1+1] # new record number +define MT_ATEOF mtdev[6,$1+1] # reached end of file on a read +define MT_FILNO mtdev[7,$1+1] # old file number at open +define MT_RECNO mtdev[8,$1+1] # old record number at open +define MT_NFILES mtdev[9,$1+1] # nfiles on tape +define MT_TAPEUSED mtdev[10,$1+1] # total tape used, bytes +define MT_PFLAGS mtdev[11,$1+1] # i/o flags returned by driver + +# PFLAGS bitflags. +define MF_ERR 001B # i/o error in last operation +define MF_EOF 002B # tape mark seen in last operation +define MF_EOT 004B # end of tape seen in last op +define MF_EOR 010B # last op was a record advance diff --git a/sys/mtio/mtlocknam.x b/sys/mtio/mtlocknam.x new file mode 100644 index 00000000..0820645a --- /dev/null +++ b/sys/mtio/mtlocknam.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "mtio.h" + +# MT_LOCKNAME -- Generate the file name of the magtape lock file, given the +# logical drive name. We are called from a z-routine, so do not use any high +# level i/o routines. The generated lockfile name is of the form +# +# [node!]dir$mta.lok +# +# The lock file is maintained on the same node as the drive to which it +# refers. + +procedure mt_lockname (device, lockfile, maxch) + +char device[ARB] #I device name +char lockfile[maxch] #O receives generated lockfile name +int maxch #I max chars out + +int ip, op +int gstrcpy(), strlen() + +begin + lockfile[1] = EOS + + # Copy the node name prefix, if any. + call ki_xnode (device, lockfile, maxch) + op = strlen (lockfile) + 1 + ip = op + + # Add the directory name prefix, "mt", and device name. + op = op + gstrcpy (LOCKLDIR, lockfile[op], maxch-op+1) + op = op + gstrcpy (LOCKFILE, lockfile[op], maxch-op+1) + op = op + gstrcpy (device[ip], lockfile[op], maxch-op+1) + + # Add file extension. + op = op + gstrcpy (LOCKEXTN, lockfile[op], maxch-op+1) +end diff --git a/sys/mtio/mtneedf.x b/sys/mtio/mtneedf.x new file mode 100644 index 00000000..9c334949 --- /dev/null +++ b/sys/mtio/mtneedf.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "mtio.h" + +# MTNEEDFILENO -- Returns YES if no file number is specified in mtname, or +# NO if a file is specified. + +int procedure mtneedfileno (mtname) + +char mtname[ARB] #I magtape device specification + +int fileno, recno +pointer sp, device, devcap +int btoi() + +begin + call smark (sp) + call salloc (device, SZ_DEVICE, TY_CHAR) + call salloc (devcap, SZ_DEVCAP, TY_CHAR) + + call mtparse (mtname, Memc[device], SZ_DEVICE, fileno, recno, + Memc[devcap], SZ_DEVCAP) + + call sfree (sp) + return (btoi(fileno == ERR)) +end diff --git a/sys/mtio/mtopen.x b/sys/mtio/mtopen.x new file mode 100644 index 00000000..fc5d6c4f --- /dev/null +++ b/sys/mtio/mtopen.x @@ -0,0 +1,188 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include "mtio.h" + +# MTOPEN -- Open a magtape file, or a regular binary file if the file name is +# not "mt" prefixed. Access modes are restricted to read_only, write_only, +# append, and new_tape. The buffer size argument specifies the size of the +# FIO buffer used to access the tape; a system and device dependent default +# is supplied if the buffer size is given as zero. If the device is a fixed +# block size device the buffer size will be adjusted to an integral multiple +# of the device block size. For variable size record devices, the buffer size +# determines the size of the tape record on a write, or the maximum record +# size on a read. +# +# The device to be accessed is specified as follows: +# +# [node!] mtX [ '[' file[.record] [:attr-list] ']' ] +# +# for example, +# +# mtexb1[4:nb:se@:ts=1200:so=/dev/ttya8] +# +# The "mt" prefix is required for the object to be considered a magtape device +# reference. The device name returned is "mtX" as shown above; there must be +# an entry for device mtX in the tapecap file in DEV. +# +# The file and record numbers are optional. Files and records are numbered +# starting with 1. A sequence such as "mtX[eot]" will cause the tape to be +# positioned to end of tape. "mtX[0]" causes the tape to be opened at the +# current position, i.e., without being moved. +# +# The optional attr-list field consists of a sequence of colon-delimited +# tapecap fields. These will override any values given in the tapecap entry +# for the device. The syntax for attr-list is the same as in tapecap. +# +# If the filespec does not have the prefix "mt", we assume that the file is +# a regular binary file and try to open that. If a tape file is specified +# then the drive must be allocated before we are called. We allocate and +# initialize an MTIO file descriptor and call FOPNBF to install the magtape +# device in FIO and open the device/file. + +int procedure mtopen (mtname, acmode, bufsize) + +char mtname[ARB] #I device to be opened +int acmode #I access mode +int bufsize #I fio buffer size (record size) or 0 + +bool first_time +pointer sp, devcap, fname, gty +int mt, fd, nskip, new_file, new_record + +bool streq() +pointer mt_gtyopen(), gtycaps() +int open(), fopnbf(), gtygets(), access() +int mt_skip_record(), mtfile(), mt_devallocated() +extern zopnmt(), zardmt(), zawrmt(), zawtmt(), zsttmt(), zclsmt() + +errchk open, fopnbf, fseti, syserrs, mtparse +errchk mt_getpos, mt_skip_record, mt_gtyopen, gtygets, mt_glock, mtallocate +data first_time /true/ +include "mtio.com" + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (devcap, SZ_DEVCAP, TY_CHAR) + + # Runtime initialization of the mtio file descriptor common. + # Make each file descriptor available for use. + + if (first_time) { + call mt_clrcache() + do mt = 1, MT_MAXTAPES + MT_OSCHAN(mt) = NULL + first_time = false + } + + # If regular binary file, we are done. + if (mtfile(mtname) == NO) { + call sfree (sp) + return (open (mtname, acmode, BINARY_FILE)) + } + + # Get mtio file descriptor slot, but do not allocate it until + # we are ready to open the file. + + for (mt=1; mt <= MT_MAXTAPES && MT_OSCHAN(mt) != NULL; mt=mt+1) + ; + if (mt > MT_MAXTAPES) + call syserrs (SYS_MTMULTOPEN, mtname) + + # Break mtname into drive name, file and record number, etc. + call mtparse (mtname, MT_DEVICE(mt), SZ_DEVICE, + new_file, new_record, Memc[devcap], SZ_DEVCAP) + if (new_record == ERR) + new_record = 1 + + # Get tapecap info. + gty = mt_gtyopen (MT_DEVICE(mt), Memc[devcap]) + MT_DEVCAP(mt) = gtycaps (gty) + if (gtygets (gty, "dv", MT_IODEV(mt), SZ_IODEV) <= 0) { + call eprintf ("missing `dv' parameter in tapecap entry for %s\n") + call pargstr (mtname) + call syserrs (SYS_MTTAPECAP, mtname) + } + call ki_xnode (MT_DEVICE(mt), MT_IODEV(mt), SZ_IODEV) + + # If the device has not been allocated, at least write out the + # lock file. This will not physically allocate the device, but + # the lock file is required to be able to access the device. + + call mt_glock (mtname, MT_LKNAME(mt), SZ_LKNAME) + if (mt_devallocated (MT_IODEV(mt)) == NO) + if (access (MT_LKNAME(mt), 0,0) == NO) + call mtallocate (mtname) + + # Get current tape position. + call mt_getpos (mtname, mt) + + MT_FILE(mt) = new_file + MT_RECORD(mt) = new_record + MT_ATEOF(mt) = NO + + # If tape is opened for writing but no file number is given, default + # to EOT. Defaulting to current file or BOT could result in + # destruction of the tape. Note that this default WILL RESULT IN TAPE + # RUNAWAY if used on a blank tape. Blank tapes must be explicitly + # written at file [1], or opened with access mode NEW_TAPE. + + if ((acmode == WRITE_ONLY && MT_FILE(mt) == -1) || (acmode == APPEND)) { + MT_FILE(mt) = EOT + MT_RECORD(mt) = 1 + } else if (acmode == NEW_TAPE) { + MT_FILE(mt) = 1 + MT_RECORD(mt) = 1 + } + + # Make sure that we are not reopening a drive which is already open. + for (fd=1; fd <= MT_MAXTAPES; fd=fd+1) + if (fd != mt && MT_OSCHAN(fd) != NULL) + if (streq (MT_DEVICE(fd), MT_DEVICE(mt))) + call syserrs (SYS_MTMULTOPEN, mtname) + + # Initialize the remaining fields in the file descriptor and open the + # device. ZOPNMT will position the tape. Note that we pass the index + # of the new mtio descriptor slot to ZOPNMT in the common. This is a + # bit ugly, but is safe enough, since we know that FOPNBF is going to + # call ZOPNMT. + + switch (acmode) { + case READ_ONLY: + MT_ACMODE(mt) = READ_ONLY + case WRITE_ONLY, APPEND, NEW_TAPE: + MT_ACMODE(mt) = WRITE_ONLY + default: + call syserrs (SYS_MTACMODE, mtname) + } + + new_mtchan = mt + fd = fopnbf (MT_IODEV(mt), acmode, + zopnmt, zardmt, zawrmt, zawtmt, zsttmt, zclsmt) + + # Set the file buffer size (record size for variable block devices). + if (bufsize > 0) + call fseti (fd, F_BUFSIZE, bufsize) + + # If the user specified a record offset, skip records up to there. + # Zero means leave positioned to old record. + + if (MT_RECORD(mt) == 0) + MT_RECORD(mt) = MT_RECNO(mt) + if (MT_RECORD(mt) > 1) { + nskip = MT_RECORD(mt) - 1 + MT_RECORD(mt) = 1 + if (mt_skip_record (fd, nskip) != nskip) + call syserrs (SYS_MTSKIPREC, mtname) + } + + call mt_savepos (mt) + + call sfree (sp) + return (fd) +end diff --git a/sys/mtio/mtparse.x b/sys/mtio/mtparse.x new file mode 100644 index 00000000..27622280 --- /dev/null +++ b/sys/mtio/mtparse.x @@ -0,0 +1,126 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "mtio.h" + +# MTPARSE -- Decode a virtual magtape file specification, returning the device +# name, file and record to which the drive is to be positioned, and any special +# device attributes (these will override the device defaults). The file and +# record fields are returned as ERR if missing. Only the drive name field is +# required. +# +# Magtape device syntax: +# +# [node!] mtX [ '[' file[.record] [:attr-list] ']' ] +# +# for example, +# +# mtexb1[4:nb:se@:ts=1200:so=/dev/ttya8] +# +# The "mt" prefix is required for the object to be considered a magtape +# device reference. The device name returned is "mtX" as shown above; there +# must be an entry for device mtX in the tapecap file in DEV. +# +# The file and record numbers are optional. Files and records are numbered +# starting with 1. A sequence such as "mtX[eot]" will cause the tape to be +# positioned to end of tape. "mtX[0]" causes the tape to be opened at the +# current position, i.e., without being moved. +# +# The optional attr-list field consists of a sequence of colon-delimited +# tapecap fields. These will override any values given in the tapecap +# entry for the device. The syntax for attr-list is the same as in tapecap. + +procedure mtparse (mtname, device, sz_device, file, record, attrl, sz_attrl) + +char mtname[ARB] #I device specification +char device[ARB] #O device name as in tapecap +int sz_device #I max chars in device name +int file #O file number or -1 +int record #O record number or -1 +char attrl[ARB] #O attribute list +int sz_attrl #I max char in attribute list + +char eotstr[3] +int ip, op, nchars, ival +int ctoi(), strncmp(), ki_extnode() +bool streq() +define bad_ 91 + +begin + # Extract the node name, if any, from the mtname. + ip = ki_extnode (mtname, device, sz_device, nchars) + 1 + op = nchars + 1 + + # Verify that this is a magtape device specification. + if (strncmp (mtname[ip], "mt", 2) != 0) + goto bad_ + + # Extract the device name field. + while (mtname[ip] != EOS && mtname[ip] != '[') { + device[op] = mtname[ip] + op = min (sz_device, op + 1) + ip = ip + 1 + } + device[op] = EOS + + file = ERR + record = ERR + attrl[1] = EOS + + # Process the [...] part of the device specification. + if (mtname[ip] == '[') { + ip = ip + 1 + + # Get the file number. + if (ctoi (mtname, ip, ival) > 0) { + file = ival + if (file < 0) + goto bad_ + } else if (IS_ALPHA(mtname[ip])) { + call strcpy (mtname[ip], eotstr, 3) + call strlwr (eotstr) + if (streq (eotstr, "eot")) { + file = EOT + ip = ip + 3 + } else + goto bad_ + } + + # Get the record number. + if (mtname[ip] == '.' || mtname[ip] == ',') { + ip = ip + 1 + if (mtname[ip] == ']') + record = ERR + else if (ctoi (mtname, ip, ival) > 0) { + record = ival + if (record < 0) + goto bad_ + } + } + + # Get the device attribute list. + op = 1 + if (mtname[ip] == ':') { + attrl[op] = mtname[ip] + op = max(1, min(sz_attrl, op + 1)) + ip = ip + 1 + + while (mtname[ip] != EOS && mtname[ip] != ']') { + attrl[op] = mtname[ip] + op = max(1, min(sz_attrl, op + 1)) + ip = ip + 1 + } + } + attrl[op] = EOS + + # Check for the ']' terminator. + if (mtname[ip] != ']') + goto bad_ + } + + return +bad_ + call syserrs (SYS_MTFILSPEC, mtname) +end diff --git a/sys/mtio/mtpos.x b/sys/mtio/mtpos.x new file mode 100644 index 00000000..f88946ae --- /dev/null +++ b/sys/mtio/mtpos.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "mtio.h" + +# MTPOSITION -- Position the device to the indicated file and record. +# We are called to position the device by device name, not to position +# an open magtape file. + +procedure mtposition (mtname, file, record) + +char mtname[ARB] #I device to be positioned +int file #I desired file number +int record #I desired record number + +int junk +pointer sp, mtspec, device, devcap +errchk mtparse, mtopen +int mtopen() + +begin + call smark (sp) + call salloc (device, SZ_FNAME, TY_CHAR) + call salloc (mtspec, SZ_FNAME, TY_CHAR) + call salloc (devcap, SZ_DEVCAP, TY_CHAR) + + # Get device name (including node! prefix) from mtname. + call mtparse (mtname, + Memc[device], SZ_FNAME, junk, junk, Memc[devcap], SZ_DEVCAP) + + # Encode new mtname and open device to position to desired file. + # Note that we do not return until positioning is complete. Thus, + # "mtposition(device,1)" is a rewind with wait. + + call mtencode (Memc[mtspec], SZ_FNAME, + Memc[device], file, record, Memc[devcap]) + call close (mtopen (Memc[mtspec], READ_ONLY, 1)) + + call sfree (sp) +end diff --git a/sys/mtio/mtrdlock.x b/sys/mtio/mtrdlock.x new file mode 100644 index 00000000..774fab19 --- /dev/null +++ b/sys/mtio/mtrdlock.x @@ -0,0 +1,93 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mtio.h" + +# MT_READ_LOCKFILE -- Read the magtape lock file to determine the current +# position of the tape (the lock file is used to record the tape position +# while the device is closed). If the lock file cannot be accessed or an +# error occurs in reading it, return an undefined tape position. + +procedure mt_read_lockfile (mtname, mt) + +char mtname[ARB] #I device name +int mt #I MTIO descriptor + +int fd, ip +pointer sp, lockfile, lbuf +int strmatch(), stridxs(), ctoi(), open(), getline() +errchk open, getline +include "mtio.com" +define err_ 91 + +begin + call smark (sp) + call salloc (lockfile, SZ_FNAME, TY_CHAR) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + # If the lock file cannot be accessed, return an undefined tape + # position but do not abort. + + #call mt_lockname (MT_LKNAME(mt), Memc[lockfile], SZ_FNAME) + call strcpy (MT_LKNAME(mt), Memc[lockfile], SZ_FNAME) + iferr (fd = open (Memc[lockfile], READ_ONLY, TEXT_FILE)) { + fd = ERR + goto err_ + } + + # Get file number. + repeat { + if (getline (fd, Memc[lbuf]) == EOF) + goto err_ + } until (strmatch (Memc[lbuf], "^file") > 0) + ip = stridxs ("=", Memc[lbuf]) + 1 + if (ctoi (Memc[lbuf], ip, MT_FILNO(mt)) == 0) + goto err_ + + # Get record number. + if (getline (fd, Memc[lbuf]) == EOF) + goto err_ + ip = stridxs ("=", Memc[lbuf]) + 1 + if (ctoi (Memc[lbuf], ip, MT_RECNO(mt)) == 0) + goto err_ + + # Get total files on tape. + if (getline (fd, Memc[lbuf]) == EOF) + goto err_ + ip = stridxs ("=", Memc[lbuf]) + 1 + if (ctoi (Memc[lbuf], ip, MT_NFILES(mt)) == 0) + goto err_ + + # Get amount of tape used. + if (getline (fd, Memc[lbuf]) == EOF) + goto err_ + ip = stridxs ("=", Memc[lbuf]) + 1 + if (ctoi (Memc[lbuf], ip, MT_TAPEUSED(mt)) == 0) + goto err_ + + # Get pflags. + if (getline (fd, Memc[lbuf]) == EOF) + goto err_ + ip = stridxs ("=", Memc[lbuf]) + 1 + if (ctoi (Memc[lbuf], ip, MT_PFLAGS(mt)) == 0) + goto err_ + + call close (fd) + call sfree (sp) + + return +err_ + if (fd != ERR) + call close (fd) + + # Write a new lock file so that we can update the tape position + # later (the file must exist after the drive is opened). + + call mtallocate (mtname) + + # Return an undefined tape position. + MT_FILNO(mt) = -1 + MT_RECNO(mt) = -1 + + call sfree (sp) +end diff --git a/sys/mtio/mtrewind.x b/sys/mtio/mtrewind.x new file mode 100644 index 00000000..b7efcddb --- /dev/null +++ b/sys/mtio/mtrewind.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mtio.h" + +# MTREWIND -- Rewind the named magtape device. This is a synchronous +# rewind. Rewind not only rewinds the device, it also initializes the +# MTIO view of what is on the tape (number of files, total bytes used). +# Hence, if the drive is left allocated but the tape is changed, or if +# the position cache becomes inaccurate for any reason, a rewind will +# initialize things without having to deallocate and reallocate the drive. + +procedure mtrewind (mtname, initcache) + +char mtname[ARB] #I device to be rewound +int initcache #I discard positional information? + +pointer sp, fname +int fd, mtopen() +errchk mtfname + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + # Init position cache. + if (initcache == YES) { + call mt_glock (mtname, Memc[fname], SZ_FNAME) + iferr (call delete (Memc[fname])) + ; + } + + # Rewind device. + call mtfname (mtname, 1, Memc[fname], SZ_FNAME) + iferr (fd = mtopen (Memc[fname], READ_ONLY, 0)) + call erract (EA_WARN) + else + call close (fd) + + call sfree (sp) +end diff --git a/sys/mtio/mtskip.x b/sys/mtio/mtskip.x new file mode 100644 index 00000000..f51948a4 --- /dev/null +++ b/sys/mtio/mtskip.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MT_SKIP_RECORD -- Skip records on an opened file. Return the actual number +# of records skipped; stop if EOF is reached. + +int procedure mt_skip_record (fd, nrecords) + +int fd #I magtape device +int nrecords #I number of records to skip + +pointer sp, buf +int n, bufsize +errchk aread, await +int await(), fstati() + +begin + call smark (sp) + bufsize = fstati (fd, F_BUFSIZE) + call salloc (buf, bufsize, TY_CHAR) + + for (n=1; n <= nrecords; n=n+1) { + call aread (fd, Memc[buf], bufsize, 0) + if (await (fd) == EOF) + break + } + + call sfree (sp) + return (n-1) +end diff --git a/sys/mtio/mtstatus.x b/sys/mtio/mtstatus.x new file mode 100644 index 00000000..967d25df --- /dev/null +++ b/sys/mtio/mtstatus.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# MTSTATUS -- Print the status of an allocated magtape device, i.e., print the +# lock file as a text file. Called by the DEVSTATUS task. + +procedure mtstatus (out, mtname) + +int out #I output file +char mtname[ARB] #I magtape specification + +int in +pointer sp, lockfile +errchk open, fcopyo +int open(), access() + +begin + call smark (sp) + call salloc (lockfile, SZ_FNAME, TY_CHAR) + + call mt_sync (OK) + + call mt_glock (mtname, Memc[lockfile], SZ_FNAME) + if (access (Memc[lockfile], 0, 0) == NO) { + call fprintf (out, "tape position for %s is undefined\n") + call pargstr (mtname) + } else { + # Print the lockfile. + in = open (Memc[lockfile], READ_ONLY, TEXT_FILE) + call fcopyo (in, out) + call close (in) + } + + call sfree (sp) +end diff --git a/sys/mtio/mtupdlock.x b/sys/mtio/mtupdlock.x new file mode 100644 index 00000000..654d3cbc --- /dev/null +++ b/sys/mtio/mtupdlock.x @@ -0,0 +1,188 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "mtio.h" + +# MT_UPDATE_LOCKFILE -- Update the current file position in the lockfile. +# This information is returned by the host specific driver at close time. +# We are called from a z-routine so we must access the lockfile using only +# low level OS interface routines to avoid recursion. We may be called during +# error recovery (as well as from a z-routine), so any errors are fatal. + +procedure mt_update_lockfile (mt) + +int mt #I device slot + +extern mt_sync() +pointer sp, lockfile, tempfile, lbuf, ip, op, extn +int old_lockfile, new_lockfile, junk, status, nlines +errchk fmapfn +include "mtio.com" +define oline_ 91 +define err_ 92 + +begin + call smark (sp) + call salloc (lockfile, SZ_PATHNAME, TY_CHAR) + call salloc (tempfile, SZ_PATHNAME, TY_CHAR) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + # Catch any errors in the following section and convert them + # into fatal errors. + + iferr { + # Try to avoid generating any non-host legal filenames in the + # following code, to avoid any need to access the VFN mapping + # file. Generate temp file in the same directory on the same + # node as the lockfile so that we can easily rename the tempfile + # to be the new lockfile. + + #call mt_lockname (MT_LKNAME(mt), Memc[lockfile], SZ_PATHNAME) + call strcpy (MT_LKNAME(mt), Memc[lockfile], SZ_PATHNAME) + + # Make tempfile name. + extn = NULL + op = tempfile + for (ip=lockfile; Memc[ip] != EOS; ip=ip+1) { + if (Memc[ip] == '.') + extn = op + Memc[op] = Memc[ip] + op = op + 1 + } + + if (extn == NULL) + extn = op + call strcpy (".tlk", Memc[extn], 4) + + # Map the filenames. + call fmapfn (Memc[tempfile], Memc[tempfile], SZ_PATHNAME) + call fmapfn (Memc[lockfile], Memc[lockfile], SZ_PATHNAME) + + } then + goto err_ + + # Overwrite any existing tempfile. + call zfdele (Memc[tempfile], junk) + call zopntx (Memc[tempfile], NEW_FILE, new_lockfile) + if (new_lockfile == ERR) + goto err_ + + # Open old lockfile, if any, and copy the comments section. + call zopntx (Memc[lockfile], READ_ONLY, old_lockfile) + if (old_lockfile == ERR) { +oline_ call strcpy ("# Magtape unit ", Memc[lbuf], SZ_LINE) + call strcat (MT_DEVICE(mt), Memc[lbuf], SZ_LINE) + call strcat (" status\n", Memc[lbuf], SZ_LINE) + call mt_putline (new_lockfile, Memc[lbuf]) + } else { + nlines = 0 + repeat { + call zgettx (old_lockfile, Memc[lbuf], SZ_LINE, status) + if (status <= 0) { + if (nlines == 0) { + call zclstx (old_lockfile, status) + goto oline_ + } else + break + } else + nlines = nlines + 1 + Memc[lbuf+status] = EOS + if (Memc[lbuf] == '#') + call mt_putline (new_lockfile, Memc[lbuf]) + } until (Memc[lbuf] != '#') + call zclstx (old_lockfile, status) + } + + # Everything else we write from here on is new stuff. Discard rest + # of old lockfile. + + # Save current file and record numbers. + if (MT_FILNO(mt) == -1) + MT_RECNO(mt) = -1 + call mt_savekeyword (new_lockfile, "file", MT_FILNO(mt)) + if (MT_NFILES(mt) > 0 && (MT_FILNO(mt) == MT_NFILES(mt) + 1)) + call mt_putline (new_lockfile, " (EOT)") + call mt_putline (new_lockfile, "\n") + call mt_savekeyword (new_lockfile, "record", MT_RECNO(mt)) + call mt_putline (new_lockfile, "\n") + call mt_savekeyword (new_lockfile, "nfiles", MT_NFILES(mt)) + call mt_putline (new_lockfile, "\n") + call mt_savekeyword (new_lockfile, "tapeused", MT_TAPEUSED(mt)) + call mt_putline (new_lockfile, "\n") + call mt_savekeyword (new_lockfile, "pflags", MT_PFLAGS(mt)) + call mt_putline (new_lockfile, "\n") + + # Install the new lockfile. + call zflstx (new_lockfile, status) + if (status == ERR) + goto err_ + call zclstx (new_lockfile, status) + if (status == ERR) + goto err_ + + call zfdele (Memc[lockfile], status) + call zfrnam (Memc[tempfile], Memc[lockfile], status) + if (status == ERR) + goto err_ + + call sfree (sp) + return + +err_ + # If an error of any sort occurs, it is fatal. + call onerror_remove (mt_sync) + call zfdele (Memc[tempfile], status) + call zfdele (Memc[lockfile], status) + call fatal (0, "Fatal error writing magtape device lockfile") +end + + +# MT_SAVEKEYWORD -- Write a "keyword = value" status line into the lockfile. + +procedure mt_savekeyword (fd, keyword, value) + +int fd # output file +char keyword[ARB] # name of keyword +int value # value of keyword +char numbuf[MAX_DIGITS] +int junk, itoc() + +begin + junk = itoc (value, numbuf, MAX_DIGITS) + + call mt_putline (fd, keyword) + call mt_putline (fd, " = ") + call mt_putline (fd, numbuf) +end + + +# MT_PUTLINE -- Put a text string to the lockfile. Do not write line +# to lockfile until a newline is seen. + +procedure mt_putline (fd, text) + +int fd +char text[ARB] + +extern mt_sync() +char lbuf[SZ_LINE] +int ip, op, status +data op /1/ + +begin + for (ip=1; text[ip] != EOS; ip=ip+1) { + lbuf[op] = text[ip] + op = min (SZ_LINE, op) + 1 + if (text[ip] == '\n') { + call zputtx (fd, lbuf, op-1, status) + if (status == ERR) { + call onerror_remove (mt_sync) + call fatal (0, + "Fatal error writing magtape device lockfile") + } + op = 1 + } + } +end diff --git a/sys/mtio/zardmt.x b/sys/mtio/zardmt.x new file mode 100644 index 00000000..ac5833be --- /dev/null +++ b/sys/mtio/zardmt.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "mtio.h" + +# ZARDMT -- MTIO asynchronous read primitive. Initiate a read of up to +# maxbytes bytes into the user buffer. + +procedure zardmt (mtchan, buf, maxbytes, offset) + +int mtchan #I i/o channel +char buf[ARB] #O output data buffer +int maxbytes #I max bytes to read +long offset #I file offset + +include "mtio.com" + +begin + if (MT_ATEOF(mtchan) == NO) + call zzrdmt (MT_OSCHAN(mtchan), buf, maxbytes, offset) +end diff --git a/sys/mtio/zawrmt.x b/sys/mtio/zawrmt.x new file mode 100644 index 00000000..5caf2b70 --- /dev/null +++ b/sys/mtio/zawrmt.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "mtio.h" + +# ZAWRMT -- MTIO asynchronous write primitive. Initiate a write of nbytes +# bytes to the tape. + +procedure zawrmt (mtchan, buf, nbytes, offset) + +int mtchan #I i/o channel +char buf[ARB] #I data to be written +int nbytes #I number of bytes of data +long offset #I file offset + +include "mtio.com" + +begin + call zzwrmt (MT_OSCHAN(mtchan), buf, nbytes, offset) +end diff --git a/sys/mtio/zawtmt.x b/sys/mtio/zawtmt.x new file mode 100644 index 00000000..5599a81e --- /dev/null +++ b/sys/mtio/zawtmt.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "mtio.h" + +# ZAWTMT -- Wait for the last i/o transfer to complete, update tape position +# counters, return nbytes|status to caller. + +procedure zawtmt (mtchan, status) + +int mtchan #I i/o channel +int status #O status (nbytes transferred or ERR) + +include "mtio.com" + +begin + # The "sticky" EOF should not be necessary but is needed due to the + # way FIO behaves when it hits EOF on a blocked file. In some + # circumstances (depends upon the file length) two reads are made and + # if the second read does not return zero EOF will not be detected. + + if (MT_ATEOF(mtchan) == YES) + status = 0 + else { + call zzwtmt (MT_OSCHAN(mtchan), MT_DEVPOS(mtchan), status) + if (status == 0) + MT_ATEOF(mtchan) = YES + } +end diff --git a/sys/mtio/zclsmt.x b/sys/mtio/zclsmt.x new file mode 100644 index 00000000..7c4dcbf7 --- /dev/null +++ b/sys/mtio/zclsmt.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "mtio.h" + +# ZCLSMT -- Close a magtape file and device. Update lockfile so that we +# will know where the tape is positioned next time we open the device. +# Deallocate the mtio descriptor so that it may be reused again. +# +# We are being called during error recovery if "new_mtchan" is not null. +# If MT_OSCHAN has also been set, then ZZOPMT was interrupted, probably while +# trying to position the tape, and the position of the tape is indefinite. +# Close the tape with acmode=read so that no tape marks are written, and write +# the lockfile with file = -1 to signify that the position is indefinite. + +procedure zclsmt (mtchan, status) + +int mtchan #I i/o channel +int status #O close status + +int mt +bool error_recovery +include "mtio.com" + +begin + # Called by error recovery while positioning tape? (during open) + if (new_mtchan != NULL) { + mt = new_mtchan + if (MT_OSCHAN(mt) != NULL) + call zzclmt (MT_OSCHAN(mt), MT_DEVPOS(mt), status) + + call mt_savepos (mt) + call mt_sync (ERR) + new_mtchan = NULL + + } else { + mt = mtchan + + # If a task aborts while a tape file is open, mt_sync will + # already have been called to update the position, + # and the current file will have been set to undefined (-1). + + error_recovery = (MT_FILNO(mt) == -1) + + # Close device. This clobbers MT_FILNO (see above). + call zzclmt (MT_OSCHAN(mt), MT_DEVPOS(mt), status) + + # Update the tape position if not recovering from an abort. + if (!error_recovery) + call mt_savepos (mt) + } + + MT_OSCHAN(mt) = NULL +end diff --git a/sys/mtio/zopnmt.x b/sys/mtio/zopnmt.x new file mode 100644 index 00000000..1c55e1ae --- /dev/null +++ b/sys/mtio/zopnmt.x @@ -0,0 +1,58 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "mtio.h" + +# ZOPNMT -- Open magtape device at the specifed file. We are called indirectly +# by MTOPEN (via fopnbf), which sets up a new mtio device decriptor pointed +# to by NEW_MTCHAN, and passes it via the mtio common. + +procedure zopnmt (iodev, acmode, mtchan) + +char iodev[ARB] #I PACKED i/o device name string +int acmode #I file access mode +int mtchan #O return value (mt descriptor index) + +int mt +pointer sp, pk_devcap +include "mtio.com" +define err_ 91 + +begin + call smark (sp) + call salloc (pk_devcap, SZ_DEVCAP, TY_CHAR) + + # Pick up index of mt descriptor slot set up by MTOPEN. Make sure + # that we were called by MTOPEN and not somebody else. + + mt = new_mtchan + if (mt < 1 || mt > MT_MAXTAPES) + goto err_ + + # Open the device. + call strpak (Memc[MT_DEVCAP(mt)], Memc[pk_devcap], SZ_DEVCAP) + call zzopmt (iodev, MT_ACMODE(mt), Memc[pk_devcap], MT_DEVPOS(mt), + MT_FILE(mt), MT_OSCHAN(mt)) + if (MT_OSCHAN(mt) == ERR) + goto err_ + + # If "new_mtchan" is nonzero when ZCLSMT is called, it implies that + # CLOSE was called during error recovery due to an interrupt of ZZOPMT + # and the position of the tape is undefined. Clear the flag since the + # open is now complete and we were not interrupted. + + new_mtchan = NULL + MT_FILNO(mt) = MT_FILE(mt) + call mt_savepos (mt) + + mtchan = mt + call sfree (sp) + return + +err_ + # Z-routines can only return ERR in the event of an error. + MT_OSCHAN(mt) = NULL + call sfree (sp) + mtchan = ERR +end diff --git a/sys/mtio/zsttmt.x b/sys/mtio/zsttmt.x new file mode 100644 index 00000000..252c9735 --- /dev/null +++ b/sys/mtio/zsttmt.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "mtio.h" + +# ZSTTMT -- Get magtape device or device driver parameters and settings. + +procedure zsttmt (mtchan, what, lvalue) + +int mtchan #I mtio descriptor +int what #I status parameter to be returned +long lvalue #O returned status value + +include "mtio.com" + +begin + call zzstmt (MT_OSCHAN(mtchan), what, lvalue) +end diff --git a/sys/mtio/zzdebug.x b/sys/mtio/zzdebug.x new file mode 100644 index 00000000..cf02e610 --- /dev/null +++ b/sys/mtio/zzdebug.x @@ -0,0 +1,357 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +task alloc = t_allocate, + dealloc = t_deallocate, + status = t_status, + mtpos = t_mtposition, + wtestfile = t_wtestfile, + mtexamine = t_mtexamine, + mtcopy = t_mtcopy, + rew = t_rewind + + +.help testmtio +.nf __________________________________________________________________________ +MTIO test routines. Assorted routines for verification of MTIO. + + alloc Allocate a drive. + + dealloc Deallocate a drive. + + status Print drive status + + mtpos Position to the indicated file and record. + + wtestfile Writes a test file. The number of records and the + range of record sizes may be specified. The contents + of a record are determined by its size. + + mtexamine Examines the structure of a tape. Tells the number of + files on the tape, the number of records in each file, + the sizes of the records, and optionally dumps the + contents of an indicated range of records from each + file. + + mtcopy Fast binary copy. Copies a binary disk or tape file + to a binary disk or tape file using all the FIO + defaults. +.endhelp _____________________________________________________________________ + + +# ALLOCATE -- Allocate a drive. + +procedure t_allocate() + +int junk, status +char drive[SZ_FNAME] +char owner[SZ_FNAME] +int xallocate(), xdevowner() + +begin + call clgstr ("drive", drive, SZ_FNAME) + status = xallocate (drive) + + switch (status) { + case OK: + call printf ("device allocated successfully\n") + case ERR: + call printf ("cannot allocate device\n") + case DV_DEVFREE: + call printf ("device is free and may be allocated\n") + case DV_DEVALLOC: + call printf ("device is already allocated\n") + case DV_DEVINUSE: + junk = xdevowner ("drive", owner, SZ_FNAME) + call printf ("device is already allocated to `%s'\n") + call pargstr (owner) + case DV_DEVNOTFOUND: + call printf ("device not found\n") + default: + call printf ("unknown status %d\n") + call pargi (status) + } +end + + +# DEALLOCATE -- Deallocate a drive. + +procedure t_deallocate() + +int junk, status +char drive[SZ_FNAME] +char owner[SZ_FNAME] + +bool clgetb() +int xdeallocate(), xdevowner() + +begin + call clgstr ("drive", drive, SZ_FNAME) + status = xdeallocate (drive, clgetb ("rewind")) + + switch (status) { + case OK: + call printf ("device deallocated successfully\n") + case ERR: + call printf ("cannot deallocate device\n") + case DV_DEVFREE: + call printf ("device is free and may be allocated\n") + case DV_DEVALLOC: + call printf ("device is already allocated\n") + case DV_DEVINUSE: + junk = xdevowner ("drive", owner, SZ_FNAME) + call printf ("device is already allocated to `%s'\n") + call pargstr (owner) + case DV_DEVNOTFOUND: + call printf ("device not found\n") + default: + call printf ("unknown status %d\n") + call pargi (status) + } +end + + +# STATUS -- Print drive status. + +procedure t_status() + +int status +char drive[SZ_FNAME] +char owner[SZ_FNAME] +int xdevowner() + +begin + call clgstr ("drive", drive, SZ_FNAME) + status = xdevowner (drive, owner, SZ_FNAME) + + switch (status) { + case OK: + call printf ("device deallocated successfully\n") + case ERR: + call printf ("cannot deallocate device\n") + case DV_DEVFREE: + call printf ("device is free and may be allocated\n") + case DV_DEVALLOC: + call printf ("device is already allocated\n") + case DV_DEVINUSE: + call printf ("device is allocated to `%s'\n") + call pargstr (owner) + case DV_DEVNOTFOUND: + call printf ("device not found\n") + default: + call printf ("unknown status %d\n") + call pargi (status) + } +end + + +# MTPOS -- Position to the indicated file and record. + +procedure t_mtposition() + +char drive[SZ_FNAME] +int clgeti() + +begin + call clgstr ("drive", drive, SZ_FNAME) + call mtposition (drive, clgeti("file"), clgeti("record")) +end + + +# WTESTFILE -- Write a test file to the tape. Specify file [1] to write to +# a new tape. If no file number is given, the file is appended to the tape. +# Specify the number of records to be written and the range of sizes in bytes +# of the records. Each byte of a record will contain the size of the record +# modulus 256. + +procedure t_wtestfile() + +char mtname[SZ_FNAME] +int nrecords +int min_recsize, max_recsize + +pointer buf +long seed +int fd, i, recsize, oschan, status +int clgeti(), mtopen(), fstati() +real urand() +data seed /123/ + +begin + # Get tapefile name and open file for writing. + call clgstr ("mtname", mtname, SZ_FNAME) + fd = mtopen (mtname, WRITE_ONLY, 1) + oschan = fstati (fd, F_CHANNEL) + + nrecords = max (0, clgeti ("nrecords")) + min_recsize = max (1, clgeti ("min_recsize")) + max_recsize = max (min_recsize, clgeti ("max_recsize")) + + call calloc (buf, max_recsize, TY_CHAR) + + # Records are written by directly calling ZAWRMT, so that we can + # write odd size records. + + do i = 1, nrecords { + recsize = int ((max_recsize - min_recsize) * urand (seed)) + + min_recsize + call zawrmt (oschan, Memc[buf], recsize, 0) + call zawtmt (oschan, status) + if (status == ERR) + call error (1, "write error") + } + + call mfree (buf, TY_CHAR) + call close (fd) +end + + +# MTEXAMINE -- Examine the structure of a tape filesystem or a file. If no file +# number is given, all files are examined. + +procedure t_mtexamine() + +int fileno, nrecords +char mtname[SZ_FNAME], mtfile[SZ_FNAME] +int strlen(), mt_examine() + +begin + call clgstr ("mtname", mtname, SZ_FNAME) + call fseti (STDOUT, F_FLUSHNL, YES) + + if (mtname[strlen(mtname)] == ']') { + call strcpy (mtname, mtfile, SZ_FNAME) + nrecords = mt_examine (STDOUT, mtname) + + } else { + fileno = 1 + repeat { + call sprintf (mtfile, SZ_FNAME, "%s[%d]") + call pargstr (mtname) + call pargi (fileno) + fileno = fileno + 1 + } until (mt_examine (STDOUT, mtfile) == 0) + } +end + + +# MT_EXAMINE -- Examine a magtape file. Print file number, then count +# successive records. When the record size changes, print the number of +# records encountered with the old size. When all done, print the total +# number of records and bytes. Return the number of records in the file. + +int procedure mt_examine (out, mtfile) + +int out # output stream +char mtfile[ARB] # magtape file to be examined + +pointer buf +int in, nrecords, totrecords, totbytes, bufsize, recsize, last_recsize +errchk mtopen, read, fstati, printf, pargi +int mtopen(), read(), fstati() + +begin + in = mtopen (mtfile, READ_ONLY, 0) + bufsize = fstati (in, F_BUFSIZE) + call malloc (buf, bufsize, TY_CHAR) + + call fprintf (out, " File %s:\n") + call pargstr (mtfile) + + totrecords = 0 + nrecords = 0 + totbytes = 0 + last_recsize = 0 + + # Describe record composition of file. + while (read (in, Memc[buf], bufsize) != EOF) { + recsize = fstati (in, F_SZBBLK) + if (nrecords == 0) { # first record + nrecords = 1 + last_recsize = recsize + } else if (recsize == last_recsize) { + nrecords = nrecords + 1 + } else { + call fprintf (out, "\t%d %d-byte records\n") + call pargi (nrecords) + call pargi (last_recsize) + nrecords = 1 + last_recsize = recsize + } + totrecords = totrecords + 1 + totbytes = totbytes + recsize + } + + if (nrecords > 0) { + call fprintf (out, "\t%d %d-byte records\n") + call pargi (nrecords) + call pargi (last_recsize) + } + + # Print total count of records, bytes. + call fprintf (out, "\tTotal %d records, %d bytes\n") + call pargi (totrecords) + call pargi (totbytes) + + call mfree (buf, TY_CHAR) + call close (in) + + return (totrecords) +end + + +# MTCOPY -- Copy a binary file from magtape or disk to magtape or disk, +# using all the default FIO and MTIO pararameters. If the output file is +# a magtape, all records (except possibly the last record in the file) will +# be the same size. If input tape records are not commensurate with the size +# of a CHAR they will be zero-padded to an integral number of chars upon +# input. + +procedure t_mtcopy() + +pointer buf +int in, out, bufsize, acmode +char infile[SZ_FNAME], outfile[SZ_FNAME] +int mtopen(), fstati(), read(), mtfile() + +begin + call clgstr ("infile", infile, SZ_FNAME) + call clgstr ("outfile", outfile, SZ_FNAME) + + in = mtopen (infile, READ_ONLY, 0) + + # If output file is a disk file, create a new file, but do not + # create a new tape if writing to tape. + + acmode = NEW_FILE + if (mtfile(outfile) == YES) + acmode = WRITE_ONLY + out = mtopen (outfile, acmode, 0) + + bufsize = fstati (in, F_BUFSIZE) + call malloc (buf, bufsize, TY_CHAR) + + while (read (in, Memc[buf], bufsize) != EOF) + call write (out, Memc[buf], fstati (in, F_NCHARS)) + + call mfree (buf, TY_CHAR) + call close (in) + call close (out) +end + + +# REWIND -- Rewind the tape. + +procedure t_rewind() + +char mtname[SZ_FNAME] +bool clgetb() +int btoi() + +begin + call clgstr ("mtname", mtname, SZ_FNAME) + call mtrewind (mtname, btoi(clgetb("initialize"))) +end diff --git a/sys/mwcs/MWCS.hlp b/sys/mwcs/MWCS.hlp new file mode 100644 index 00000000..4f77144f --- /dev/null +++ b/sys/mwcs/MWCS.hlp @@ -0,0 +1,1026 @@ +.help MWCS Oct89 "Mini-WCS Interface" + +.ce +\fBMini-WCS Interface\fR +.ce +Doug Tody +.ce +October 1989 + + +.nh +Introduction + + The mini-WCS interface represents a first cut at the general problem +of representing a linear or nonlinear world coordinate system (WCS). +While some of the harder problems are avoided and the general WCS problem +remains to be solved, the current interface should be largely upwards +compatible with future versions of the interface. The main items omitted +from this initial version of the interface are support for general nonlinear +world coordinate systems, particularly support for modeling of geometric +distortions and arbitrary application defined coordinate mapping functions. +Limited support is provided for the projective geometries. + +.nh +WCS Definition +.nh 2 +Linear Transformations + + Any linear transformation consisting of some combination of a shift, +rotate, axis-flip, scale change, etc. can be expressed as + +.ks +.nf + |x'| |a b| |x| |u| + | | = | | * | | + | | [2.1] + |y'| |c d| |y| |v| +.fi +.ke + +where [x,y] are the input coordinates, [x',y'] are the transformed +coordinates, [a,b,c,d] is a rotation matrix, and [u,v] is a shift vector. + +For example, the X term of a combination of a rotation about a point [x0,y0] +plus a shift to an offset [x1,y1] may be expressed as + +.ks +.nf + x' = a(x - x0) + b(y - y0) + x1 + = ax - ax0 + by - by0 + x1 + = ax + by + u +.fi +.ke +whence +.nf + u = x1 - ax0 - by0 +and [2.2] + v = y1 - cx0 - dy0 +.fi + +Another way of expressing this is to note that [U,V] is the transform +of the origin [x,y]=[0,0] of the original coordinate system. +There is nothing special about the rotation point; a rotation about +any point [x,y] is equivalent to a rotation about the origin followed +by a translation equal to the distance of the rotation point from the origin. + +The inverse transformation is given by + +.nf + |x| | -1| / |x'| |u| \ + | | = | A | * < | | - | | > [2.3] + |y| | | \ |y'| |v| / +.fi + +where A**(-1) is the inverse of the rotation matrix [a,b,c,d]. + +.nh 2 +World Coordinate Systems + + A world coordinate system (WCS) defines the transformation between +a physical coordinate system (e.g., pixel coordinates in a reference image), +and world coordinates expressed in some arbitrary units. A two dimensional +WCS can be expressed as + +.ks +.nf + (x',y') = F (l,m, Wx,Wy) + (l,m) = [CD] * (x-Rx, y-Ry) [2.4] + +where + + x,y Are the coordinates of a point in the physical system. + l,m Is a linearly transformed representation of the point. + x',y' Are the coordinates of the same point in the world system. + F Is the WCS function, possibly a nonlinear function. + Rx,Ry Define the reference point in the physical system. + Wx,Wy Are the world coordinates of the reference point. + [CD] Is the coefficient determination (CD) matrix. +.fi +.ke + +The notation [CD]*(x,y) denotes a matrix multiply of the CD matrix [CD] and +the vector (x,y), i.e., a linear transformation of the vector (x,y). +If the WCS contains a nonlinear component, as for a sky projection, +this is described by the function F in terms of the intermediate +coordinates (l,m), e.g., the displacement in degrees from the reference +point. Separation of the WCS into linear and nonlinear components allows +full specification of linear systems using only the basic interface, +and simplifies the representation of the nonlinear part of the WCS. +The nonlinear component itself (F) may be an object of arbitrary complexity. + +In the case of a simple 2D linear WCS with no rotation this reduces to + +.ks +.nf + x' = (x - Rx) * CD[1,1] + Wx + y' = (y - Ry) * CD[2,2] + Wy +.fi +.ke + +In the general case the world system may be rotated with respect to the +physical system (original image matrix), hence the WCS must include a +rotation term. Specifying this as a general linear transformation expressed +as a matrix multiplication allows the representation of such transformations +as conversion between skewed and cartesian coordinates as well as the +more conventional rotation and scale transformation. + +The CD matrix representation (developed by STScI and now also associated +with FITS), in addition to allowing specification of a linear transformation, +is responsible for converting between the coordinate units used in the +physical system and those used in the world system (more precisely, +in the general case the units of (l,m) may differ from those of the +world system, since F can also change the units). +It is even possible for the world system to use different units on +different axes, so long as a rotation is not defined between axes with +different units. + +For example, if the WCS is used to describe an image cube, following +application of the CD matrix axes 1 and 2 might have units of arc seconds, +and axis 3 frequency. In this case rotation would be defined only between +axes 1 and 2, i.e., the off-diagonal CD matrix terms CD[1:2,3] and CD[3,1:2] +must be zero, with CD[3,3] giving the scale for axis 3 independently of any +rotation between axes 1 and 2. This restriction on rotation between +dissimilar axes applies only to the world system described by the CD matrix. +As we shall see in the next section, when the WCS refers to an image, +arbitrary rotations of the raw pixel matrix are still possible by using +a separate pixel space transformation to describe transformations +of the image matrix. + +.nh 3 +WCS Rotation Between Dissimilar Axes + + To see why rotation between dissimilar axes is disallowed in some +circumstances, note that the CD matrix, since it combines a rotation +(or other pixel space linear transformation) and units conversion in one +operation, can be expressed as follows in the case of a two dimensional system. + +The CD matrix is used as follows: + +.ks +.nf + | l | | | | x | + | | = | CD | * | | + | m | | | | y | +.fi +.ke + +The CD matrix is constructed as follows: + +.ks +.nf + | | | Dx 0 | | a b | + | CD | = | | * | | + | | | 0 Dy | | c d | +.fi +.ke + +where (Dx,Dy) is the units conversion matrix, and (a,b,c,d) is the +rotation matrix. This is a completely general representation, i.e., +any linear transformation may be specified by the matrix (a,b,c,d) +and combined with the units conversion matrix, since the rotation +matrix rotates the physical system to align the axes with those of +the world coordinate system. + +The problem comes if we try to \fIrotate the CD matrix\fR. +Although the CD matrix can express any +rotation between the physical and world system, once the CD matrix +has been formed the units conversion and rotation matrices cannot +be recovered. In general, further rotation of the system described by +the CD matrix requires that we rotate the matrix (a,b,c,d), rather than +the CD matrix itself. The only exception occurs when Dx=Dy (similar axes), +in which case the CD matrix and rotation matrix are equivalent except +for a constant. Hence, rotations between dissimilar axes of the system +described by the (already formed) CD matrix are disallowed. A special +case is rotation is some multiple of 90 degrees, which can be represented +by an axis swap or flip. + +.nh 2 +MWCS Coordinate System Representation + + The coordinate system representation used by the MWCS interface consists of +two components called the \fBLterm\fR and \fBWterm\fR, specifying independent +logical and world transformations relative to a physical, cartesian coordinate +system. Three types of coordinate systems are defined, as outlined below. + +.ls +.ls PHYSICAL +The physical coordinate system is the raw coordinate system of the data. +In the case of an image, the physical coordinate system refers to the pixel +coordinates of the original data frame. All other coordinates systems are +defined in terms of the physical system (reference frame). +.le +.ls LOGICAL +The logical coordinate system is defined by the \fILterm\fR in terms of the +physical coordinate system. In the case of an image, the logical coordinate +system specifies raw pixel coordinates relative to some image section or +derived image, i.e., the coordinates used for image i/o. In the MWCS the +Lterm specifies a simple linear transformation, in pixel units, between +the original physical image matrix and the current image section. +.le +.ls WORLD +The world coordinate system is defined by the \fIWterm\fR in terms of the +physical coordinate system. Any number of different kinds of world coordinate +systems are conceivable. Examples are the tangent (gnonomic) projection, +specifying right ascension and declination relative to the original data +image, or any linear WCS, e.g., a linear dispersion relation for spectral +data. Multiple world coordinate systems may be simultaneously defined in +terms of the same physical system. +.le +.le + +The following observations apply to the behavior of MWCS as applied +to image data. +.ls +.ls 4 1. +Any linear transformation of the image matrix (shift, scale change, +axis flip, etc.) affects only the Lterm. The revised MWCS for the new +image or image section may be computed merely by doing a linear +transformation of the Lterm. +.le +.ls 4 2. +If multiple world coordinate systems are associated with an image, +all share the same Lterm. +.le +.ls 4 3. +Geometric distortion of an image (not currently supported by MWCS) is +a pixel space operation, i.e. a generalization of the Lterm, hence is +independent of the WCS. +.le +.le + +In general, the physical and world coordinate systems are defined whenever +a new image is created, e.g., by a task such as RFITS. A new-copy type +operation, such as most transformations performed by IMAGES tasks, affects +only the Lterm. + +Although we normally speak in terms of images, MWCS is not +limited to applications involving images. For example, the physical +coordinate system could just as well be a graphics frame buffer, and the +logical coordinate system a pixrect. A greyscale transformation is +an example of a non-image WCS. MWCS, or the successor interface, +will eventually be used in GIO, e.g., for cursor readback. + +Since the Wterm includes the CD matrix, which defines a linear +transformation, and linear transformations can be combined, in principle +it is possible to combine the Lterm and Wterm to define a single +transformation from logical to world coordinates. In practice this +can run into problems, as not all pixel space rotations may be +representable by the CD matrix (since the latter may define different +world space units on different axes). Furthermore, if multiple WCS +are defined, and the WCS are defined in terms of the logical system, +it would be inefficient to have to transform each WCS to the new logical +system each time a linear transformation of the data is performed +(e.g., every time an image is opened with an image section). + +For images, the common coordinate transformations are image section (logical) +coordinates to world coordinates and vice versa, and section coordinates +to physical coordinates and vice versa. The physical coordinate system +can be regarded as a special case of a world coordinate system (the "pixel" +coordinate system) defined relative to logical image section coordinates. + +For example, to convert IMIO image coordinates to world coordinates, +the interface will first apply the inverse of the Lterm to determine the +coordinates in the physical system, then apply the Wterm for the desired WCS +to compute the world coordinates. If the Wterm is linear and the Lterm +does not define any rotations between dissimilar axes, the two operations +can be combined for a more efficient coordinate transformation. + +An arbitrary number of world coordinate systems may be defined over the +same domain in the physical coordinate system. Every WCS has a name +uniquely specifying the WCS type. A WCS may also have attributes such as +units, axis labels, and numeric output formats specified independently for +each axis, as well as arbitrary user defined WCS attributes. + +.nh 3 +Lterm Representation + + The Lterm is defined by the terms of a general linear transformation, +as shown in equation [2.1]. For example, in the case of a 2D system the +following quantities must be given to define the Lterm. + +.ks +.nf + [CD] = [a,b,c,d] rotation matrix + tv[] = [u,v] translation vector +.fi +.ke + +This defines the transformation between the physical and logical coordinate +systems, i.e., applying the transformation to a pair of physical coordinates +[x,y] yields the corresponding logical coordinates [x',y']. MWCS will +automatically compute the inverse transformation when asked to convert +between logical coordinates and physical or world coordinates. + +.nh 3 +Wterm Representation + + The Wterm defines the transformation between the physical system and +some arbitrary world coordinate system. The Wterm is defined by the +following quantities: + +.nf + R[] reference coordinates in physical system + W[] world coordinates at the reference point + [CD] coordinate determination matrix + wtype type of WCS (function name string) + wattr WCS attributes (string, opaque outside interface) +.fi + +The point R, also known as the \fIreference pixel\fR when dealing +with image data, defines the origin of the world coordinate system in +the physical system. The world coordinates at the reference point are +given by the vector W (at least for a linear WCS; in general the meaning +of the W term depends upon the WCS type). The CD matrix defines any +rotation between the physical and world systems, as well as the scale +conversion needed to convert between physical and world (or linear world) +coordinates. + +Although the function name or type \fIwtype\fR is +accessible to applications, the details of what the WCS means, and how +it is evaluated, are intended to be internal to the interface, hence +the use of strings to pass in the WCS information. Functions complex +enough to require coefficients should pass the extra information in via +the \fIwattr\fR term. WCS attributes such as the axis units and labels +are also passed in via \fIwattr\fR. + +In the general case there may be any number of different WCS types. +In the case of MWCS, however, only a predefined set of WCS types are +supported, since the code for each WCS is wired into the interface. +The predefined WCS types (as selected by \fIwtype\fR) are the following. + +.ks +.nf + \fIWtype\fR \fIDescription\fR + + linear simple linear WCS + sampled sampled WCS function + (TAN etc.) the sky projections +.fi +.ke + +A \fIlinear\fR WCS is specified by the physical and world coordinates of the +reference point, and the row or rows of the CD matrix pertaining to the axes +to which the WCS is assigned. A linear WCS is completely specified by the +linear term of the standard WCS representation. + +A \fIsampled\fR WCS is specified by an array of (physical, world) coordinate +pairs, i.e., an array of reference points, sampling the linear WCS function +for that axis. In the limiting case, for sampled (pixel) data, there is one +(physical, world) point on the WCS curve for each data point. If the WCS +function is smooth a coarser sampling can be used to approximate the curve, +using some form of interpolation to evaluate the function. In the MWCS, +a sampled function must be one-dimensional, i.e., associated with a single +axis (higher dimensional surfaces can be represented so long as the axes +are independent). + +Note that the sampled function is expressed in terms of the \fIoffset\fR +from the reference point in both the physical and world systems. +Any analytic function, e.g., polynomial or spline, can be sampled and +later reconstructed from the sampled curve with no significant error, +provided the function type and order are known and there are sufficient +sample points to determine the system. +The advantage of the sampled representation is that it is independent of +the function type, and can be used to fit any analytic function when the +time comes to evaluate the curve. + +The sky projections are a special case used with astronomical direct images. +The principal example is the gnomonic projection, the projection of the +celestial sphere onto a plane tangent at the reference point. +The sky projections are completely specified by the reference point and the +standard CD matrix, plus the WCS name which specifies the type of projection, +e.g., "gnomonic", "sine", "arc", and so on. + +The WCS attributes which can be set by the \fIwattr\fR string consist of +a number of standard attributes, plus an arbitrary number of additional +WCS specific attributes. Examples of standard attributes include "system", +"wtype", "units", "label", etc. A list of the standard WCS attributes is +given in section 3.3.1. + +.nh +Interface Overview + + The MWCS interface is a stand-alone interface implementing the linear +and world coordinate transformation abstractions. While the interface +is designed with the typical application to image data in mind, MWCS is +intended as a general coordinate transformation facility for use with any +type of data, as an embedded interface in other software, including system +interfaces such as IMIO and GIO as well as user applications. + +.nh 2 +Object Creation and Storage + + The MWCS interface routines used to create or access MWCS objects, or +save and restore MWCS objects in external storage, are summarized below. + +.nf + mw = mw_open (bufptr|NULL, ndim) + mw = mw_openim (im) + mw = mw_newcopy (mw) + mw_close (mw) + + mw_load (mw, bufptr) + len = mw_save (mw, bufptr, buflen) + mw_[load|save]im (mw, im) +.fi + +A new MWCS object, initialized either to a unitary transformation of +dimension \fIndim\fR or to the encoded MWCS in the input buffer, +is created with \fImw_open\fR. A MWCS object is be +created and initialized from an image with \fImw_openim\fR; if the referenced +image does not currently have any WCS information associated with it, +a unitary pixel WCS will be created. The \fImw_newcopy\fR operation +creates a new MWCS object as a copy of an existing one, as one might wish +to do prior to modifying a WCS. When a descriptor is no longer needed it +should be returned with \fImw_close\fR. + +A MWCS object (descriptor) is a memory object. To encode a MWCS in an opaque +machine independent binary array, e.g., for storage in a file or transmission +through a datastream, \fImw_save\fR is called with the \fIchar\fR pointer of +the buffer in which the encoded MWCS is to be placed. If the buffer pointer is +NULL a buffer will be created and the pointer returned, and if a valid buffer +is passed it will be resized as necessary to store the encoded object. +An encoded MWCS object is reloaded into a descriptor with \fImw_load\fR. +A MWCS may be stored or updated in an image header with \fImw_saveim\fR, +or loaded from the image header into a descriptor with \fImw_loadim\fR. +These are the only interface routines with knowledge of the parameter names, +etc., used to store WCS information in image headers. + +.nh 2 +Coordinate Transformation Procedures + + The MWCS procedures used to perform coordinate transformations, +and to modify or examine the Lterm and Wterm, are summarized below. + +.nf + ct = mw_sctran (mw, system1, system2, axes) + ndim = mw_gctran[r|d] (ct, ltm, ltv, axtype1, axtype2, maxdim) + mw_ctfree (ct) + + x2 = mw_c1tran[r|d] (ct, x1) + mw_v1tran[r|d] (ct, x1, x2, npts) + mw_c2tran[r|d] (ct, x1,y1, x2,y2) + mw_v2tran[r|d] (ct, x1,y1, x2,y2, npts) + mw_ctran[r|d] (ct, p1, p2, ndim) + mw_vtran[r|d] (ct, v1, v2, ndim, npts) +.fi + +The procedures \fImw_[cv][12]tran[rd]\fR perform coordinate +transformations for individual coordinates or coordinate vectors, +for one or two dimensional systems, for coordinates of type real or double. +The general N dimensional case is handled by the \fImw_[cv]tran[rd]\fR +procedures, which transform \fIndim\fR-dimensional points (\fImw_ctran\fR) +or point vectors (\fImw_vtran\fR). A single point is specified as a +vector of length \fIndim\fR; a point vector is expressed as an array of +points, i.e., a 2-dimensional array V[I,J], where the index I refers to +the axis within a point vector, and where the index J refers to the point. +The notation V[1,j] references the 1-dimensional point vector for point J. + +The direction of the transformation, and the axes for which the transformation +is to be performed, is determined by a prior call to \fImw_sctran\fR, +which specifies the input and output coordinate systems, and performs the +initialization necessary for efficient evaluation of a series of +transformations. A pointer to the optimized transformation descriptor is +returned, to allow two or more transformations to be prepared and used +simultaneously without having to repeat the setup, which can be considerably +more expensive than coordinate evaluation. The transformation descriptor +should be freed when no longer needed, else it will be freed automatically +when the MWCS is closed. + +A coordinate system is specified to \fImw_sctran\fR by its name. +The following standard systems are predefined. +Additional WCS names may be defined by the application. + +.ks +.nf + "logical" The logical system + "physical" The physical system + "world" The default world system + (user-wcs) User defined systems +.fi +.ke + +Strings are used to specify the coordinate systems in order to allow user +defined and named systems to be added at runtime. +The use of a setup procedure to specify the desired transformation allows +new types of coordinate transformations to be easily added, for example +mixed conversions, as for a 2-dimensional system where the X and Y components +of a coordinate pair belong to different coordinate systems, or computation +of the derivative at a point. In MWCS, only simple conversions between any +two of the physical, logical, and world coordinate systems are supported. + +Specification of the axes for which the coordinate transformation is desired +is necessary for the more complex systems, since there may be different, +often quite independent coordinate systems defined on different axes. +The axes for which the transformation is to be prepared are specified as +a bitmask. The default, if the mask is zero, is to use axes starting with +1, up to the number required to satisfy the given dimension transformation. + +For example, to convert two dimensional image coordinates (section relative) +to world coordinates in the default WCS: + +.nf + call mw_sctran (mw, "logical", "world", 3B) + call mw_c2tranr (mw, px,py, wx,wy) +.fi + +Multiple independent world coordinate systems may be defined relative to +the same physical system. Most applications, however, are best written +as if there were only one world system, with the coordinate system to be +used being switched about transparently to the application. For this +reason there is no WCS number argument to the MWCS procedures, and +the "world" system specifies the \fIcurrent default\fR WCS. If a MWCS object +defines multiple world coordinate systems, a \fImw_ssystem\fR call is used +to select the WCS to be used. This could be used, for example, to change +the units appearing on plots in a graphics application, transparently +to the application. + +.nh 2 +Coordinate System Specification + + The MWCS procedures used to enter, modify, or inspect the MWCS +logical and world coordinate transformations are summarized in the figure +below. + +The procedures \fImw_[sg]lterm\fR are used to directly enter +or inspect the Lterm, which consists of the linear transformation matrix +\fIltm\fR and the translation vector \fItv\fR, both of dimension \fIndim\fR, +defining the transformation from the physical system to the logical system. +If the logical system undergoes successive linear transformations, +\fImw_translate\fR may be used to translate, rather than replace, +the current Lterm, where the given transformation matrix and translation +vector refer to the relative transformation undergone by the logical system. +This will always work since the Lterm is initialized to the identity matrix +when a new MWCS object is created. The routines \fImw_rotate\fR, +\fImw_scale\fR, and \fImw_shift\fR provide a convenient front-end to +\fImw_translate\fR for the more common types of translations. + +Specification of the Wterm is somewhat more complicated. The Wterm for +a new WCS should first be created and initialized for a system of the given +dimensionality with \fImw_newsystem\fR. The linear portion of the Wterm, +i.e., the CD matrix and the coordinates of the reference point +in the physical and world systems, and the WCS dimension, may then be entered +with \fImw_swterm\fR and queried with \fImw_gwterm\fR. + +.nf + mw_[s|g]lterm[r|d] (mw, ltm, ltv, ndim) + mw_translate[r|d] (mw, ltv_1, ltm, ltv_2, ndim) + mw_rotate (mw, theta, center, axes) + mw_scale (mw, scale, axes) + mw_shift (mw, shift, axes) + + mw_newsystem (mw, system, ndim) + mw_[s|g]system (mw, system[, maxch]) + mw_[s|g]axmap (mw, axno, axval, ndim) + mw_bindphys (mw) + + mw_[s|g]wterm[r|d] (mw, r, w, cd, ndim) + mw_swtype (mw, axis, naxes, wtype, wattr) + mw_[s|g]wsamp[r|d] (mw, axis, pv, wv, npts) + mw_[s|g]wattrs (mw, axis, attribute, valstr[, maxch]) +.fi + +The world portion of the Wterm is unusual in that the type of WCS may be +specified independently for each axis. The WCS function type \fIwtype\fR, +and any attributes \fIwattr\fR, are specified for the indicated \fIaxes\fR +with \fImw_swtype\fR. The axes specified are those required to evaluate +the named function. + +In the case of an axis of type "sampled", the sampled WCS function must +also be entered via a call to \fImw_swsamp\fR, and may later be retrieved +with \fImw_gwsamp\fR. The WCS function is defined as an \fIoffset\fR from +the reference point in both the physical and world systems, e.g., +the vector \fIWv\fR will be added to the world coordinates +produced by interpolating the sampled function (this can of course be +defeated by setting R or W to zero). + +A WCS always has a number of predefined \fIattributes\fR, and may also +have any number of user defined, or WCS specific, attributes. These are +defined when the WCS is created, in the \fIwattr\fR argument input to +\fImw_swtype\fR, or in a subsequent call to \fImw_swattrs\fR. The WCS +attributes for a specific axis may be queried with the function +\fImw_gwattrs\fR. Attribute values may be modified, or new attributes defined, +with \fImw_swattrs\fR. The issue of WCS attributes is discussed further +in the next section. + +.nh 3 +WCS Types and Attributes + + The WCS attributes which can be set by the \fIwattr\fR term consist of +a number of standard attributes, plus an arbitrary number of additional +WCS specific (application defined) attributes. The following standard +attributes are reserved (but not necessarily defined) for each WCS: + +.nf + "units" axis units ("pixels", etc.) + "label" axis label, for plots + "format" axis numeric format, for tick labels + "wtype" WCS type, e.g., "linear" +.fi + +In addition, the following are defined for the entire WCS, +regardless of the axis: + +.nf + "system" system name (logical, physical, etc.) + "object" external object with which WCS is associated +.fi + +For example, to determine the WCS type for axis 1: + + call mw_gwattrs (mw, 1, "wtype", wtype, SZ_WTYPE) + +The (world coordinate) system name \fIsystem\fR is what is used, e.g., +to select a WCS in a call to \fImw_ssystem\fR, or define a coordinate +transformation in a call to \fImw_sctran\fR. Note that the system name +"world" is actually only an alias for the \fIdefault world system\fR. +This may be any primary system, i.e., the logical or physical system, +or a user defined world system. The initial default world system may +be specified by the user by predefining the environment variable +\fBdefwcs\fR, otherwise the first-defined user world system is used, +else the physical system is used. + +If the MWCS is associated with an image then the "object" attribute of +the physical system will return the name of the image or image section +defined as the physical coordinate system for the MWCS. +This is not necessarily the full image, e.g., in the case of +a multidimensional image, the physical system might be any 2D plane of the +image. In the case of an event file image, the image name may include a +filter or blocking factor. References back to the raw data image based on +MWCS physical coordinates will work so long as the raw image is opened +using the name returned by the interface. If the image is already open +and was accessed by descriptor via MWCS, the descriptor may be retrieved +by a \fImw_stati\fR call to fetch MW_IMDES. + +All MWCS coordinate systems have the standard attributes, with default values +being supplied by the interface if not set by the application. In particular, +the logical and physical coordinate systems have attributes and may be +treated as a special case of a world coordinate system by the application. + +.nh 3 +Axis Mapping + + The coordinate transformation procedures (section 3.2) include support +for a feature called \fIaxis mapping\fR, used to implement \fIdimensional +reduction\fR. A example of dimensional reduction occurs in IMIO, when +an image section is used to specify a subraster of an image of dimension +less than the full physical image. For example, the section might specify +a 1 dimensional line or column of a 2 or higher dimensional image, or a +2 dimensional section of a 3 dimensional image. When this occurs the +applications sees a logical image of dimension equal to that of the image +section, since logically an image section \fIis\fR an image. + +Dimensional reduction is implemented in MWCS by a transformation on the +input and output coordinate vectors. The internal MWCS coordinate system +is unaffected by either dimensional reduction or axis mapping; axis mapping +affects only the view of the WCS as seen by the application using the +coordinate transformation procedures. + +For example, if the physical image is an image cube and we access the +logical image section "[*,5,*]", an axis mapping may be set up which +maps \fIphysical\fR axis 1 to logical axis 1, physical axis 2 to the +constant 5, and physical axis 3 to logical axis 2. The internal system +remains 3 dimensional, but the application sees a 2 dimensional system. +Upon input, the missing axis y=5 is added to the 2 dimensional input +coordinate vectors, producing a 3 dimensional coordinate vector for +internal use. During output axis 2 is dropped and replaced by axis 3. + +The axis map is entered with \fImw_saxmap\fR and queried with \fImw_gaxmap\fR. +Here, \fIaxno\fR is a vector, with \fIaxno[i]\fR specifying the logical axis +to be mapped onto physical axis I. If zero is specified the constant +\fIaxval[i]\fR is used instead. Axis mapping may be enabled or disabled +with a call to \fImw_seti\fR. + +Axis mapping affects all of the coordinate transformation procedures, +plus \fImw_translate\fR (since it defines a translation in terms of the +logical system), and all of the coordinate system specification procedures +having an "axis" parameter, e.g., \fImw_gwattrs\fR. +Axis mapping is not used with those procedures which directly access or +modify the physical or world systems (e.g., \fImw_slterm\fR or +\fImw_swterm\fR) since full knowledge of the physical system is necessary +for such operations. + +.nh 3 +Binding the Physical System + + Recall that all coordinate systems are defined in terms of the physical +system, and that the Lterm defines the mapping between the physical system +and the logical system. Transformations of the logical system leave the +physical and world systems unaffected. The only exception to this is the +procedure \fImw_bindphys\fR, which binds the physical system to the current +logical system, i.e., makes the current logical system the new physical system. +This involves a transformation of the linear term (CD matrix) of each world +system, since a world system is defined in terms of the physical system, +and initialization of the Lterm to (normally) the identity matrix and zero +translation vector. This operation is irreversible, i.e., once +\fImw_bindphys\fR is executed the original physical system is lost. + +In the case of an MWCS which is associated with an image opened with an image +section, the new physical system is not strictly speaking the logical system, +but the image matrix of the image being accessed, i.e,. the current image +ignoring the image section. Hence, following a call to \fImw_bindphys\fR, +the Lterm will always describe the translation between the physical image +matrix currently being accessed, and the logical system (image section). + +.nh 2 +Set/Stat Procedures + + The MWCS status procedures, used to query or set the MWCS parameters, +are as follows. + +.nf + mw_seti (mw, what, ival) + ival = mw_stati (mw, what) + mw_show (mw, outfd, what) +.fi + +The currently defined interface parameters are the following. + +.nf + Name Type Description + + MW_AXMAP b enable or disable axis mapping + MW_IMDES i descriptor of associated image + MW_INTERP i interpolator type for sampled wcs + MW_NDIM i dimensionality of logical system + MW_NPHYSDIM i dimensionality of physical system + MW_NWCS i number of wcs defined + MW_WCS i currently active wcs +.fi + +MW_NDIM may differ from MW_NPHYSDIM if dimensional reduction has been +specified and axis mapping is enabled. MW_NWCS returns the number of +WCS currently defined; at least two WCS are always defined, i.e., the +logical and physical systems (the world system will default to the +physical system if not otherwise defined). The index of the current +default WCS is given by MW_WCS. In the case of a sampled WCS, the +interpolator type used by the coordinate transformation procedures is +specified by MW_INTERP. + +.nh 2 +Utility Routines + + The following routines are used internally within the interface to +compile or evaluate transformations, and may be useful in applications +code as well. + +.nf + mw_invert[r|d] (o_ltm, n_ltm, ndim) + mw_mmul[r|d] (ltm_1, ltm_2, ltm_out, ndim) + mw_vmul[r|d] (ltm, ltv_in, ltv_out, ndim) + mw_glt[r|d] (v1, v2, ltm, ltv, ndim) +.fi + +These routines perform matrix inversion, multiplication of a matrix by another +matrix, multiplication of a vector by a matrix, and general linear +transformation (matrix multiply and addition of translation vector). + +.nh 2 +Datatypes and Precision + + All floating point data is stored internally in MWCS using double +precision. Most of the interface procedures have both type real and type +double versions, e.g., for entering Lterm or Wterm data. +The single precision versions should be normally used unless double +precision is required to represent the data. + +Although all floating point data is stored internally as type double, +coordinate transformations performed at runtime may be carried out using +either single or double precision computations, depending upon, e.g., whether +\fImw_ctranr\fR or \fImw_ctrand\fR is called to perform the transformation. +What happens is that when the transformation is compiled by \fImw_sctran\fR, +two transformation descriptors are prepared, one for type real and the other +for type double, with the appropriate descriptor being selected at runtime +to carry out the transformation. Hence the precision appropriate for the +problem at hand can be employed without requiring that the worst case +precision be used for all applications. + +.nh +IMIO Interface to MWCS +.nh 2 +Image Header Representation + + When MWCS is used with image data, the encoded MWCS object is stored +in the image header, and loaded into an MWCS descriptor when the image is +accessed by an applications program. The format in which the MWCS is +stored in the image header depends upon the type of image. If the image +has a "flex-header" (as for QPOE and the new image structures) the MWCS +is encoded in a machine independent binary format and stored in the image +header as a variable length byte array. This provides full generality +and is the most efficient approach. + +For the older image formats which use a FITS header (OIF and STF) it is +necessary to encode the MWCS as a series of FITS cards. The proposed FITS +WCS format, already in use for STF format images (with minor deviations +from the standard), is used to represent the MWCS Wterm. Additional FITS +cards are necessary to represent the Lterm. The (P,W) array for sampled +WCS can also be represented in a FITS header, although this is awkward and +inefficient if the number of samples is large. + +The FITS header keywords used to represent the Wterm, Lterm, and sampled +WCS are the following. + +.nf + WCSDIM WCS dimension (may differ from image) + + CTYPEn coordinate type + CRPIXn reference pixel + CRVALn world coords of reference pixel + CDi_j CD matrix + + CDELTn CDi_i if CD matrix not used (input only) + CROTA2 rotation angle if CD matrix not used + + LTVi Lterm translation vector + LTMi_j Lterm rotation matrix + + WSVi_LEN Number of sample points for axis I + WSVi_jjj Sampled WCS array for axis I + + WATi_jjj WCS attributes for axis I +.fi + +Contrary to MWCS convention, the WCS stored in a FITS format header +defines the transformation from the logical system (image matrix) +to the world system, rather than the physical system. The MWCS Wterm +is computed from the FITS representation by transforming the FITS WCS +by the stored Lterm when the stored MWCS is loaded. + +The name format CDi_j varies slightly from the proposed FITS standard, but is +backwards compatible with STF (and more readable than the FITS nomenclature). +The keywords LTVECn, LTi_j, WSVi_LEN, WSVi_jjj, and WATi_jjj are peculiar +to MWCS. A sampled WCS is represented as a series of WSVi_jjj cards, +wherein the sample points are stored as character strings, storing as +many sample points as possible on each card, ignoring the card boundaries +(i.e., a card may end in the middle of a number). WCS attributes are likewise +encoded as a series of WATi_jjj cards, giving the attributes for axis I as +string data of the form "attribute = value", ignoring card boundaries. +Multiple world coordinate systems (other than the physical and one world +system) cannot be used with old format image headers. + +.nh 2 +Handling of the WCS by IMIO + + When an image is opened by IMIO the image header is read, an MWCS +descriptor is opened, and the stored MWCS is loaded into the MWCS descriptor +from the image header. If an image section has been opened the Lterm +is then updated to reflect the additional linear transformation defined +by the section. The correct logical to physical or world transformation +is then seen at the IMIO level, and will be propagated to a new image +in a NEW_COPY image operation when the MWCS is copied to the new image. + +In the case of an image format which uses a FITS header, application of +the section transform during an image open \fIdoes not\fR include updating +of the FITS representation of the WCS. There are two problems with doing +so: all this editing of the FITS image of the header is inefficient +unless absolutely necessary, and more seriously, if the image is opened +READ_WRITE with an image section and the header is later updated, the +stored WCS will be incorrect. So, while the WCS as represented by the +MWCS will always be correct, the FITS header parameters will reflect +the WCS of the raw image ignoring the image section. If it is necessary +for some reason to update the FITS header in memory to reflect the image +section, \fImw_saveim\fR may be called to perform the udpate. + +Propagation of the correct logical system in a NEW_COPY operation works +because once the FITS header is copied, \fImw_saveim\fR is called to +edit the header of the new image. + +.nh +Implementation +.nh 2 +Restrictions + + Since there was not time to solve the general WCS problem with the MWCS +interface, several restrictions were accepted for this version. These are +the following. +.ls +.ls o +All WCS functions are built in (hard coded), hence the interface is not +extensible at runtime and the only way to support new applications is +through modification of the interface (by adding new function drivers). +.le +.ls o +There is no support for modeling geometric distortions, except possibly +in one dimension. +.le +.ls o +There is no provision for storing more than one world coordinate system +in FITS oriented image headers, although multiple WCS are supported internally +by the interface, and are preserved and restored across \fImw_save\fR and +\fImw_load\fR operations. +.le +.ls o +Coordinate transforms involving dependent axes must includes all such axes +explicitly in the transform. Dependent axes are axes which are related, +either by a rotation, or by a WCS function. Operations which could subset +dependent axis groups, and which are therefore disallowed, include setting +up a transform with an AXES bitmap which excludes dependent axes, or more +importantly, an image section involving dimensional reduction, where the +axis to be removed is not independent. This could happen, for example, +if a two-dimensional image were rotated and one tried to open a +one-dimensional section of the rotated image. +.le +.le + +All these problems can be solved given enough time, although the last problem +mentioned becomes very complicated (perhaps intractable) when nonlinear world +systems of dimension greater than three are involved. + +.nh 2 +Function Drivers + + World coordinate systems are implemented in MWCS by providing something +called a \fIfunction driver\fR for each function type, as specified by the +\fIwtype\fR argument to \fImw_swtype\fR. The \fIwtype\fR is the name of +the function, and the name of the function driver. + +A function driver consists of the following procedures. A given driver +need not implement all driver procedures; procedures which are not used +by a driver are set to NULL in the function driver table. + +.nf + operation syntax + + FN_INIT wf_FCN_init (fc, dir) + FN_DESTROY wf_FCN_destroy (fc) + FN_FWD wf_FCN_fwd (fc, pv, wv) + FN_INV wf_FCN_inv (fc, wv, pv) +.fi + +where FCN is replaced by a 3 letter abbreviation for the function name, +e.g., "smp" for the sampled WCS function, "tan" for the tangent plane +projection etc. This is only a suggested naming convention; the actual +driver procedure names are arbitrary so long as name conflicts are +avoided. + +The argument FC to each driver procedure is a pointer to the function call +descriptor set up by \fImw_sctran\fR. This consists of a number of standard +fields followed by an area which is reserved for fields which are private +to the function driver. During compilation of a transformation, the function +driver initialization procedure FN_INIT will be called to perform any function +dependent initialization, e.g., processing of the attribute list for the +axes assigned to the function, to input any function specific parameters. + +During runtime evaluation of a function call, FN_FWD will be called for a +forward transformation (physical to world), and FN_INV for an inverse +transformation (world to physical). Note that the linear portion of the +WCS, i.e., the CD matrix and all other linear terms except W (the CRVAL +vector) are handled the same for all WCS functions, outside of the driver. +Hence when the driver is called for a forward transformation, for example, +the CD matrix and R vector (defining the reference point) will already +have been applied to the input vector PV. + +To fully understand how function drivers are implemented it is probably +simplest to study the existing drivers. + +.tp 40 +.sh +Appendix A: Interface Summary + +.nf + mw = mw_open (bufptr|NULL, ndim) + mw = mw_openim (im) + mw = mw_newcopy (mw) + mw_close (mw) + + mw_load (mw, bufptr) + len = mw_save (mw, bufptr, buflen) + mw_[load|save]im (mw, im) + + ct = mw_sctran (mw, system1, system2, axes) + ndim = mw_gctran[r|d] (ct, ltm, ltv, axtype1, axtype2, maxdim) + mw_ctfree (ct) + + x2 = mw_c1tran[r|d] (ct, x1) + mw_v1tran[r|d] (ct, x1, x2, npts) + mw_c2tran[r|d] (ct, x1,y1, x2,y2) + mw_v2tran[r|d] (ct, x1,y1, x2,y2, npts) + mw_ctran[r|d] (ct, p1, p2, ndim) + mw_vtran[r|d] (ct, v1, v2, ndim, npts) + + mw_[s|g]lterm[r|d] (mw, ltm, ltv, ndim) + mw_translate[r|d] (mw, ltv_1, ltm, ltv_2, ndim) + mw_rotate (mw, theta, center, axes) + mw_scale (mw, scale, axes) + mw_shift (mw, shift, axes) + + mw_newsystem (mw, system, ndim) + mw_[s|g]system (mw, system[, maxch]) + mw_[s|g]axmap (mw, axno, axval, ndim) + mw_bindphys (mw) + + mw_[s|g]wterm[r|d] (mw, r, w, cd, ndim) + mw_swtype (mw, axis, naxes, wtype, wattr) + mw_[s|g]wsamp[r|d] (mw, axis, pv, wv, npts) + mw_[s|g]wattrs (mw, axis, attribute, valstr[, maxch]) + + mw_invert[r|d] (o_ltm, n_ltm, ndim) + mw_mmul[r|d] (ltm_1, ltm_2, ltm_out, ndim) + mw_vmul[r|d] (ltm, ltv_in, ltv_out, ndim) + mw_glt[r|d] (v1, v2, ltm, ltv, ndim) + + mw_seti (mw, what, ival) + ival = mw_stati (mw, what) + mw_show (mw, outfd, what) +.fi +.sp +.endhelp diff --git a/sys/mwcs/README b/sys/mwcs/README new file mode 100644 index 00000000..10f44b60 --- /dev/null +++ b/sys/mwcs/README @@ -0,0 +1,47 @@ +MWCS Interface Summary + + + mw = mw_open (bufptr|NULL, ndim) + mw = mw_openim (im) + mw = mw_newcopy (mw) + mw_close (mw) + + mw_load (mw, bufptr) + len = mw_save (mw, bufptr, buflen) + mw_[load|save]im (mw, im) + + ct = mw_sctran (mw, system1, system2, axes) + ndim = mw_gctran[r|d] (ct, ltm, ltv, axtype1, axtype2, maxdim) + mw_ctfree (ct) + + x2 = mw_c1tran[r|d] (ct, x1) + mw_v1tran[r|d] (ct, x1, x2, npts) + mw_c2tran[r|d] (ct, x1,y1, x2,y2) + mw_v2tran[r|d] (ct, x1,y1, x2,y2, npts) + mw_ctran[r|d] (ct, p1, p2, ndim) + mw_vtran[r|d] (ct, v1, v2, ndim, npts) + + mw_[s|g]lterm[r|d] (mw, ltm, ltv, ndim) + mw_translate[r|d] (mw, ltv_1, ltm, ltv_2, ndim) + mw_rotate (mw, theta, center, axes) + mw_scale (mw, scale, axes) + mw_shift (mw, shift, axes) + + mw_newsystem (mw, system, ndim) + mw_[s|g]system (mw, system[, maxch]) + mw_[s|g]axmap (mw, axno, axval, ndim) + mw_bindphys (mw) + + mw_[s|g]wterm[r|d] (mw, r, w, cd, ndim) + mw_swtype (mw, axis, naxes, wtype, wattr) + mw_[s|g]wsamp[r|d] (mw, axis, pv, wv, npts) + mw_[s|g]wattrs (mw, axis, attribute, valstr[, maxch]) + + mw_invert[r|d] (o_ltm, n_ltm, ndim) + mw_mmul[r|d] (ltm_1, ltm_2, ltm_out, ndim) + mw_vmul[r|d] (ltm, ltv_in, ltv_out, ndim) + mw_glt[r|d] (v1, v2, ltm, ltv, ndim) + + mw_seti (mw, what, ival) + ival = mw_stati (mw, what) + mw_show (mw, outfd, what) diff --git a/sys/mwcs/gen/mkpkg b/sys/mwcs/gen/mkpkg new file mode 100644 index 00000000..bc8fe837 --- /dev/null +++ b/sys/mwcs/gen/mkpkg @@ -0,0 +1,29 @@ +# Make the generic portion of MWCS. + +$checkout libex.a lib$ +$udate libex.a +$checkin libex.a lib$ +$exit + +libex.a: + mwc1trand.x ../mwcs.h + mwc1tranr.x ../mwcs.h + mwc2trand.x ../mwcs.h + mwc2tranr.x ../mwcs.h + mwctrand.x ../mwcs.h + mwctranr.x ../mwcs.h + mwgctrand.x ../mwcs.h + mwgctranr.x ../mwcs.h + mwltrand.x + mwltranr.x + mwmmuld.x + mwmmulr.x + mwv1trand.x ../mwcs.h + mwv1tranr.x ../mwcs.h + mwv2trand.x ../mwcs.h + mwv2tranr.x ../mwcs.h + mwvmuld.x + mwvmulr.x + mwvtrand.x + mwvtranr.x + ; diff --git a/sys/mwcs/gen/mwc1trand.x b/sys/mwcs/gen/mwc1trand.x new file mode 100644 index 00000000..af46e02d --- /dev/null +++ b/sys/mwcs/gen/mwc1trand.x @@ -0,0 +1,24 @@ +include "../mwcs.h" + +# MW_C1TRAN -- Optimized 1D coordinate transformation. + +double procedure mw_c1trand (a_ct, x) + +pointer a_ct #I pointer to CTRAN descriptor +double x #I coordinates in input system + +double y +pointer ct + +begin + # Get real or double version of descriptor. + ct = CT_D(a_ct) + + # Perform the transformation; LNR is a simple linear transformation. + if (CT_TYPE(ct) == LNR) { + return (Memd[CT_LTM(ct)] * x + Memd[CT_LTV(ct)]) + } else { + call mw_ctrand (a_ct, x, y, 1) + return (y) + } +end diff --git a/sys/mwcs/gen/mwc1tranr.x b/sys/mwcs/gen/mwc1tranr.x new file mode 100644 index 00000000..06ad0bf7 --- /dev/null +++ b/sys/mwcs/gen/mwc1tranr.x @@ -0,0 +1,24 @@ +include "../mwcs.h" + +# MW_C1TRAN -- Optimized 1D coordinate transformation. + +real procedure mw_c1tranr (a_ct, x) + +pointer a_ct #I pointer to CTRAN descriptor +real x #I coordinates in input system + +real y +pointer ct + +begin + # Get real or double version of descriptor. + ct = CT_R(a_ct) + + # Perform the transformation; LNR is a simple linear transformation. + if (CT_TYPE(ct) == LNR) { + return (Memr[CT_LTM(ct)] * x + Memr[CT_LTV(ct)]) + } else { + call mw_ctranr (a_ct, x, y, 1) + return (y) + } +end diff --git a/sys/mwcs/gen/mwc2trand.x b/sys/mwcs/gen/mwc2trand.x new file mode 100644 index 00000000..0cb156bd --- /dev/null +++ b/sys/mwcs/gen/mwc2trand.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../mwcs.h" + +# MW_C2TRAN -- Optimized 2D coordinate transformation. + +procedure mw_c2trand (a_ct, x1,y1, x2,y2) + +pointer a_ct #I pointer to CTRAN descriptor +double x1,y1 #I coordinates in input system +double x2,y2 #O coordinates in output system + +pointer ct, ltm, ltv +double p1[2], p2[2] + +begin + # Get real or double version of descriptor. + ct = CT_D(a_ct) + + ltm = CT_LTM(ct) + ltv = CT_LTV(ct) + + if (CT_TYPE(ct) == LNR) { + # Simple linear, nonrotated transformation. + x2 = Memd[ltm ] * x1 + Memd[ltv ] + y2 = Memd[ltm+3] * y1 + Memd[ltv+1] + } else if (CT_TYPE(ct) == LRO) { + # Linear, rotated transformation. + p1[1] = x1; p1[2] = y1 + x2 = Memd[ltm ] * p1[1] + Memd[ltm+1] * p1[2] + Memd[ltv ] + y2 = Memd[ltm+2] * p1[1] + Memd[ltm+3] * p1[2] + Memd[ltv+1] + } else { + # General case involving one or more functional terms. + p1[1] = x1; p1[2] = y1 + call mw_ctrand (a_ct, p1, p2, 2) + x2 = p2[1]; y2 = p2[2] + } +end diff --git a/sys/mwcs/gen/mwc2tranr.x b/sys/mwcs/gen/mwc2tranr.x new file mode 100644 index 00000000..ef5b5ef7 --- /dev/null +++ b/sys/mwcs/gen/mwc2tranr.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../mwcs.h" + +# MW_C2TRAN -- Optimized 2D coordinate transformation. + +procedure mw_c2tranr (a_ct, x1,y1, x2,y2) + +pointer a_ct #I pointer to CTRAN descriptor +real x1,y1 #I coordinates in input system +real x2,y2 #O coordinates in output system + +pointer ct, ltm, ltv +real p1[2], p2[2] + +begin + # Get real or double version of descriptor. + ct = CT_R(a_ct) + + ltm = CT_LTM(ct) + ltv = CT_LTV(ct) + + if (CT_TYPE(ct) == LNR) { + # Simple linear, nonrotated transformation. + x2 = Memr[ltm ] * x1 + Memr[ltv ] + y2 = Memr[ltm+3] * y1 + Memr[ltv+1] + } else if (CT_TYPE(ct) == LRO) { + # Linear, rotated transformation. + p1[1] = x1; p1[2] = y1 + x2 = Memr[ltm ] * p1[1] + Memr[ltm+1] * p1[2] + Memr[ltv ] + y2 = Memr[ltm+2] * p1[1] + Memr[ltm+3] * p1[2] + Memr[ltv+1] + } else { + # General case involving one or more functional terms. + p1[1] = x1; p1[2] = y1 + call mw_ctranr (a_ct, p1, p2, 2) + x2 = p2[1]; y2 = p2[2] + } +end diff --git a/sys/mwcs/gen/mwctrand.x b/sys/mwcs/gen/mwctrand.x new file mode 100644 index 00000000..70e575cc --- /dev/null +++ b/sys/mwcs/gen/mwctrand.x @@ -0,0 +1,97 @@ +include "../mwcs.h" + +# MW_CTRAN -- Transform a single N-dimensional point, using the optimized +# transformation set up by a prior call to MW_SCTRAN. + +procedure mw_ctrand (a_ct, p1, p2, ndim) + +pointer a_ct #I pointer to CTRAN descriptor +double p1[ndim] #I coordinates of point in input system +double p2[ndim] #O coordinates of point in output system +int ndim #I dimensionality of point + +int naxes, i, j +pointer ct, fc, ltm, ltv, d_ct +double v1[MAX_DIM], v2[MAX_DIM], iv[MAX_DIM], ov[MAX_DIM] +errchk zcall3 + +begin + # Get real or double version of descriptor. + ct = CT_D(a_ct) + + ltm = CT_LTM(ct) + ltv = CT_LTV(ct) + + # Specially optimized cases. + if (CT_TYPE(ct) == LNR) { + # Simple linear, nonrotated transformation. + do i = 1, ndim + p2[i] = Memd[ltm+(i-1)*(ndim+1)] * p1[i] + Memd[ltv+i-1] + return + } else if (CT_TYPE(ct) == LRO) { + # Simple linear, rotated transformation. + call mw_ltrand (p1, p2, Memd[ltm], Memd[ltv], ndim) + return + } + + # If we get here the transformation involves a call to one or more + # WCS functions. In this general case, the transformation consists + # of zero or more calls to WCS functions to transform the input + # world coordinates to the linear input system, followed by a general + # linear transformation to the linear output system, followed by zero + # or more calls to WCS functions to do the forward transformation + # to generate the final output world coordinates. The WCS function + # calls are always evaluated in double precision. + + # Make zero or more WCS function calls for the different axes of the + # input system (inverse transform). + + call achtdd (p1, iv, ndim) + do j = 1, CT_NCALLI(ct) { + # Get pointer to function call descriptor. + fc = CT_FCI(ct,j) + naxes = FC_NAXES(fc) + + # Extract the coordinate vector for the function call. + do i = 1, naxes + v1[i] = p1[FC_AXIS(fc,i)] + + # Call the WCS function. + call zcall3 (FC_FCN(fc), fc, v1, v2) + + # Edit the vector IV, replacing the entries associated with + # the WCS function by the transformed values. + + do i = 1, naxes + iv[FC_AXIS(fc,i)] = v2[i] + } + + # Apply the general linear transformation. We may as well do this in + # double since we already have to use double for the function calls. + + d_ct = CT_D(a_ct) + call mw_ltrand (iv, ov, Memd[CT_LTM(d_ct)], Memd[CT_LTV(d_ct)], ndim) + + # Make zero or more WCS function calls for the different axes of the + # output system (forward transform to final world system). + + call achtdd (ov, p2, ndim) + do j = 1, CT_NCALLO(ct) { + # Get pointer to function call descriptor. + fc = CT_FCO(ct,j) + naxes = FC_NAXES(fc) + + # Extract the coordinate vector for the function call. + do i = 1, naxes + v1[i] = ov[FC_AXIS(fc,i)] + + # Call the WCS function. + call zcall3 (FC_FCN(fc), fc, v1, v2) + + # Edit the final output vector, replacing the entries for the + # function axes by their transformed values. + + do i = 1, naxes + p2[FC_AXIS(fc,i)] = v2[i] + } +end diff --git a/sys/mwcs/gen/mwctranr.x b/sys/mwcs/gen/mwctranr.x new file mode 100644 index 00000000..0574a563 --- /dev/null +++ b/sys/mwcs/gen/mwctranr.x @@ -0,0 +1,97 @@ +include "../mwcs.h" + +# MW_CTRAN -- Transform a single N-dimensional point, using the optimized +# transformation set up by a prior call to MW_SCTRAN. + +procedure mw_ctranr (a_ct, p1, p2, ndim) + +pointer a_ct #I pointer to CTRAN descriptor +real p1[ndim] #I coordinates of point in input system +real p2[ndim] #O coordinates of point in output system +int ndim #I dimensionality of point + +int naxes, i, j +pointer ct, fc, ltm, ltv, d_ct +double v1[MAX_DIM], v2[MAX_DIM], iv[MAX_DIM], ov[MAX_DIM] +errchk zcall3 + +begin + # Get real or double version of descriptor. + ct = CT_R(a_ct) + + ltm = CT_LTM(ct) + ltv = CT_LTV(ct) + + # Specially optimized cases. + if (CT_TYPE(ct) == LNR) { + # Simple linear, nonrotated transformation. + do i = 1, ndim + p2[i] = Memr[ltm+(i-1)*(ndim+1)] * p1[i] + Memr[ltv+i-1] + return + } else if (CT_TYPE(ct) == LRO) { + # Simple linear, rotated transformation. + call mw_ltranr (p1, p2, Memr[ltm], Memr[ltv], ndim) + return + } + + # If we get here the transformation involves a call to one or more + # WCS functions. In this general case, the transformation consists + # of zero or more calls to WCS functions to transform the input + # world coordinates to the linear input system, followed by a general + # linear transformation to the linear output system, followed by zero + # or more calls to WCS functions to do the forward transformation + # to generate the final output world coordinates. The WCS function + # calls are always evaluated in double precision. + + # Make zero or more WCS function calls for the different axes of the + # input system (inverse transform). + + call achtrd (p1, iv, ndim) + do j = 1, CT_NCALLI(ct) { + # Get pointer to function call descriptor. + fc = CT_FCI(ct,j) + naxes = FC_NAXES(fc) + + # Extract the coordinate vector for the function call. + do i = 1, naxes + v1[i] = p1[FC_AXIS(fc,i)] + + # Call the WCS function. + call zcall3 (FC_FCN(fc), fc, v1, v2) + + # Edit the vector IV, replacing the entries associated with + # the WCS function by the transformed values. + + do i = 1, naxes + iv[FC_AXIS(fc,i)] = v2[i] + } + + # Apply the general linear transformation. We may as well do this in + # double since we already have to use double for the function calls. + + d_ct = CT_D(a_ct) + call mw_ltrand (iv, ov, Memd[CT_LTM(d_ct)], Memd[CT_LTV(d_ct)], ndim) + + # Make zero or more WCS function calls for the different axes of the + # output system (forward transform to final world system). + + call achtdr (ov, p2, ndim) + do j = 1, CT_NCALLO(ct) { + # Get pointer to function call descriptor. + fc = CT_FCO(ct,j) + naxes = FC_NAXES(fc) + + # Extract the coordinate vector for the function call. + do i = 1, naxes + v1[i] = ov[FC_AXIS(fc,i)] + + # Call the WCS function. + call zcall3 (FC_FCN(fc), fc, v1, v2) + + # Edit the final output vector, replacing the entries for the + # function axes by their transformed values. + + do i = 1, naxes + p2[FC_AXIS(fc,i)] = v2[i] + } +end diff --git a/sys/mwcs/gen/mwgctrand.x b/sys/mwcs/gen/mwgctrand.x new file mode 100644 index 00000000..cfdca886 --- /dev/null +++ b/sys/mwcs/gen/mwgctrand.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../mwcs.h" + +# MW_GCTRAN -- Get a coordinate transformation compiled in a previous call +# to mw_sctran. When the transformation is compiled, it is specified by +# naming the input and output systems and the axes over which the transform +# is to be performed. Rather than return this information, which the +# application already knows, we return the actual transform, i.e., the +# linear transformation matrix and translation vector comprising the linear +# portion of the transform, and axis class arrays for the input and output +# systems defining the axis types. If the axis types are all zero, there +# are no WCS function calls for any axis in either system, and the +# transformation is completely linear (hence computable by the application +# if desired, e.g., with mw_ltr). + +int procedure mw_gctrand (a_ct, o_ltm, o_ltv, axtype1, axtype2, maxdim) + +pointer a_ct #I pointer to CTRAN descriptor +double o_ltm[ARB] #O linear tranformation matrix +double o_ltv[ARB] #O translation matrix +int axtype1[ARB] #O axis types for input system +int axtype2[ARB] #O axis types for output system +int maxdim #I how much stuff to return + +pointer ct +int pdim, ndim, i, j + +begin + ct = CT_D(a_ct) + pdim = CT_NDIM(ct) + ndim = min (pdim, maxdim) + + # Output the goods. + do j = 1, ndim { + axtype1[j] = WCS_AXCLASS(CT_WCSI(ct),j) + axtype2[j] = WCS_AXCLASS(CT_WCSO(ct),j) + o_ltv[j] = Memd[CT_LTV(ct)+(j-1)] + do i = 1, ndim + o_ltm[(j-1)*ndim+i] = Memd[CT_LTM(ct)+(j-1)*pdim+(i-1)] + } + + return (pdim) +end diff --git a/sys/mwcs/gen/mwgctranr.x b/sys/mwcs/gen/mwgctranr.x new file mode 100644 index 00000000..7825c6df --- /dev/null +++ b/sys/mwcs/gen/mwgctranr.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../mwcs.h" + +# MW_GCTRAN -- Get a coordinate transformation compiled in a previous call +# to mw_sctran. When the transformation is compiled, it is specified by +# naming the input and output systems and the axes over which the transform +# is to be performed. Rather than return this information, which the +# application already knows, we return the actual transform, i.e., the +# linear transformation matrix and translation vector comprising the linear +# portion of the transform, and axis class arrays for the input and output +# systems defining the axis types. If the axis types are all zero, there +# are no WCS function calls for any axis in either system, and the +# transformation is completely linear (hence computable by the application +# if desired, e.g., with mw_ltr). + +int procedure mw_gctranr (a_ct, o_ltm, o_ltv, axtype1, axtype2, maxdim) + +pointer a_ct #I pointer to CTRAN descriptor +real o_ltm[ARB] #O linear tranformation matrix +real o_ltv[ARB] #O translation matrix +int axtype1[ARB] #O axis types for input system +int axtype2[ARB] #O axis types for output system +int maxdim #I how much stuff to return + +pointer ct +int pdim, ndim, i, j + +begin + ct = CT_R(a_ct) + pdim = CT_NDIM(ct) + ndim = min (pdim, maxdim) + + # Output the goods. + do j = 1, ndim { + axtype1[j] = WCS_AXCLASS(CT_WCSI(ct),j) + axtype2[j] = WCS_AXCLASS(CT_WCSO(ct),j) + o_ltv[j] = Memr[CT_LTV(ct)+(j-1)] + do i = 1, ndim + o_ltm[(j-1)*ndim+i] = Memr[CT_LTM(ct)+(j-1)*pdim+(i-1)] + } + + return (pdim) +end diff --git a/sys/mwcs/gen/mwltrand.x b/sys/mwcs/gen/mwltrand.x new file mode 100644 index 00000000..d35670c7 --- /dev/null +++ b/sys/mwcs/gen/mwltrand.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../mwcs.h" + +# MW_LTRAN -- Perform a general N-dimensional linear transformation, i.e., +# matrix multiply and translation. + +procedure mw_ltrand (p1, p2, ltm, ltv, ndim) + +double p1[ndim] #I input point +double p2[ndim] #O transformed output point +double ltm[ndim,ndim] #I linear transformation matrix +double ltv[ndim] #I linear translation vector +int ndim #I dimension of system + +int i, j +double p3[MAX_DIM] + +begin + call amovd (p1, p3, ndim) + do j = 1, ndim { + p2[j] = ltv[j] + do i = 1, ndim + p2[j] = p2[j] + ltm[i,j] * p3[i] + } +end diff --git a/sys/mwcs/gen/mwltranr.x b/sys/mwcs/gen/mwltranr.x new file mode 100644 index 00000000..9cafe4d2 --- /dev/null +++ b/sys/mwcs/gen/mwltranr.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../mwcs.h" + +# MW_LTRAN -- Perform a general N-dimensional linear transformation, i.e., +# matrix multiply and translation. + +procedure mw_ltranr (p1, p2, ltm, ltv, ndim) + +real p1[ndim] #I input point +real p2[ndim] #O transformed output point +real ltm[ndim,ndim] #I linear transformation matrix +real ltv[ndim] #I linear translation vector +int ndim #I dimension of system + +int i, j +real p3[MAX_DIM] + +begin + call amovr (p1, p3, ndim) + do j = 1, ndim { + p2[j] = ltv[j] + do i = 1, ndim + p2[j] = p2[j] + ltm[i,j] * p3[i] + } +end diff --git a/sys/mwcs/gen/mwmmuld.x b/sys/mwcs/gen/mwmmuld.x new file mode 100644 index 00000000..ae35f082 --- /dev/null +++ b/sys/mwcs/gen/mwmmuld.x @@ -0,0 +1,21 @@ +# MW_MMUL -- Matrix multiply. + +procedure mw_mmuld (a, b, c, ndim) + +double a[ndim,ndim] #I left input matrix +double b[ndim,ndim] #I right input matrix +double c[ndim,ndim] #O output matrix +int ndim #I dimensionality of system + +int i, j, k +double v + +begin + do j = 1, ndim + do i = 1, ndim { + v = 0 + do k = 1, ndim + v = v + a[k,j] * b[i,k] + c[i,j] = v + } +end diff --git a/sys/mwcs/gen/mwmmulr.x b/sys/mwcs/gen/mwmmulr.x new file mode 100644 index 00000000..83e14d2c --- /dev/null +++ b/sys/mwcs/gen/mwmmulr.x @@ -0,0 +1,21 @@ +# MW_MMUL -- Matrix multiply. + +procedure mw_mmulr (a, b, c, ndim) + +real a[ndim,ndim] #I left input matrix +real b[ndim,ndim] #I right input matrix +real c[ndim,ndim] #O output matrix +int ndim #I dimensionality of system + +int i, j, k +real v + +begin + do j = 1, ndim + do i = 1, ndim { + v = 0 + do k = 1, ndim + v = v + a[k,j] * b[i,k] + c[i,j] = v + } +end diff --git a/sys/mwcs/gen/mwv1trand.x b/sys/mwcs/gen/mwv1trand.x new file mode 100644 index 00000000..3c3ac124 --- /dev/null +++ b/sys/mwcs/gen/mwv1trand.x @@ -0,0 +1,32 @@ +include "../mwcs.h" + +# MW_V1TRAN -- Optimized 1D coordinate transformation for an array of points. + +procedure mw_v1trand (a_ct, x1, x2, npts) + +pointer a_ct #I pointer to CTRAN descriptor +double x1[ARB] #I coordinates in input system +double x2[ARB] #O coordinates in output system +int npts + +int i +pointer ct +double scale, offset +errchk mw_ctrand + +begin + # Get real or double version of descriptor. + ct = CT_D(a_ct) + + scale = Memd[CT_LTM(ct)] + offset = Memd[CT_LTV(ct)] + + # Perform the transformation; case LNR is a simple linear transform. + if (CT_TYPE(ct) == LNR) { + do i = 1, npts + x2[i] = scale * x1[i] + offset + } else { + do i = 1, npts + call mw_ctrand (a_ct, x1[i], x2[i], 1) + } +end diff --git a/sys/mwcs/gen/mwv1tranr.x b/sys/mwcs/gen/mwv1tranr.x new file mode 100644 index 00000000..045f6a33 --- /dev/null +++ b/sys/mwcs/gen/mwv1tranr.x @@ -0,0 +1,32 @@ +include "../mwcs.h" + +# MW_V1TRAN -- Optimized 1D coordinate transformation for an array of points. + +procedure mw_v1tranr (a_ct, x1, x2, npts) + +pointer a_ct #I pointer to CTRAN descriptor +real x1[ARB] #I coordinates in input system +real x2[ARB] #O coordinates in output system +int npts + +int i +pointer ct +real scale, offset +errchk mw_ctranr + +begin + # Get real or double version of descriptor. + ct = CT_R(a_ct) + + scale = Memr[CT_LTM(ct)] + offset = Memr[CT_LTV(ct)] + + # Perform the transformation; case LNR is a simple linear transform. + if (CT_TYPE(ct) == LNR) { + do i = 1, npts + x2[i] = scale * x1[i] + offset + } else { + do i = 1, npts + call mw_ctranr (a_ct, x1[i], x2[i], 1) + } +end diff --git a/sys/mwcs/gen/mwv2trand.x b/sys/mwcs/gen/mwv2trand.x new file mode 100644 index 00000000..3a1cf329 --- /dev/null +++ b/sys/mwcs/gen/mwv2trand.x @@ -0,0 +1,49 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../mwcs.h" + +# MW_V2TRAN -- Optimized 2D coordinate transformation for an array of points. + +procedure mw_v2trand (a_ct, x1,y1, x2,y2, npts) + +pointer a_ct #I pointer to CTRAN descriptor +double x1[ARB],y1[ARB] #I coordinates in input system +double x2[ARB],y2[ARB] #O coordinates in output system +int npts + +int i +pointer ct, ltm, ltv +double p1[2], p2[2] +errchk mw_ctrand + +begin + # Get real or double version of descriptor. + ct = CT_D(a_ct) + + ltm = CT_LTM(ct) + ltv = CT_LTV(ct) + + if (CT_TYPE(ct) == LNR) { + # Simple linear, nonrotated transformation. + do i = 1, npts { + x2[i] = Memd[ltm ] * x1[i] + Memd[ltv ] + y2[i] = Memd[ltm+3] * y1[i] + Memd[ltv+1] + } + } else if (CT_TYPE(ct) == LRO) { + # Linear, rotated transformation. + do i = 1, npts { + p1[1] = x1[i]; p1[2] = y1[i] + x2[i] = Memd[ltm ] * p1[1] + Memd[ltm+1] * p2[1] + + Memd[ltv ] + y2[i] = Memd[ltm+2] * p1[1] + Memd[ltm+3] * p2[1] + + Memd[ltv+1] + } + } else { + # General case involving one or more functional terms. + do i = 1, npts { + p1[1] = x1[i]; p1[2] = y1[i] + call mw_ctrand (a_ct, p1, p2, 2) + x2[i] = p2[1]; y2[i] = p2[2] + } + } +end diff --git a/sys/mwcs/gen/mwv2tranr.x b/sys/mwcs/gen/mwv2tranr.x new file mode 100644 index 00000000..dc2fe58f --- /dev/null +++ b/sys/mwcs/gen/mwv2tranr.x @@ -0,0 +1,49 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../mwcs.h" + +# MW_V2TRAN -- Optimized 2D coordinate transformation for an array of points. + +procedure mw_v2tranr (a_ct, x1,y1, x2,y2, npts) + +pointer a_ct #I pointer to CTRAN descriptor +real x1[ARB],y1[ARB] #I coordinates in input system +real x2[ARB],y2[ARB] #O coordinates in output system +int npts + +int i +pointer ct, ltm, ltv +real p1[2], p2[2] +errchk mw_ctranr + +begin + # Get real or double version of descriptor. + ct = CT_R(a_ct) + + ltm = CT_LTM(ct) + ltv = CT_LTV(ct) + + if (CT_TYPE(ct) == LNR) { + # Simple linear, nonrotated transformation. + do i = 1, npts { + x2[i] = Memr[ltm ] * x1[i] + Memr[ltv ] + y2[i] = Memr[ltm+3] * y1[i] + Memr[ltv+1] + } + } else if (CT_TYPE(ct) == LRO) { + # Linear, rotated transformation. + do i = 1, npts { + p1[1] = x1[i]; p1[2] = y1[i] + x2[i] = Memr[ltm ] * p1[1] + Memr[ltm+1] * p2[1] + + Memr[ltv ] + y2[i] = Memr[ltm+2] * p1[1] + Memr[ltm+3] * p2[1] + + Memr[ltv+1] + } + } else { + # General case involving one or more functional terms. + do i = 1, npts { + p1[1] = x1[i]; p1[2] = y1[i] + call mw_ctranr (a_ct, p1, p2, 2) + x2[i] = p2[1]; y2[i] = p2[2] + } + } +end diff --git a/sys/mwcs/gen/mwvmuld.x b/sys/mwcs/gen/mwvmuld.x new file mode 100644 index 00000000..0af8dfa7 --- /dev/null +++ b/sys/mwcs/gen/mwvmuld.x @@ -0,0 +1,20 @@ +# MW_VMUL -- Vector multiply. + +procedure mw_vmuld (a, b, c, ndim) + +double a[ndim,ndim] #I input matrix +double b[ndim] #I input vector +double c[ndim] #O output vector +int ndim #I system dimension + +int i, j +double v + +begin + do j = 1, ndim { + v = 0 + do i = 1, ndim + v = v + a[i,j] * b[i] + c[j] = v + } +end diff --git a/sys/mwcs/gen/mwvmulr.x b/sys/mwcs/gen/mwvmulr.x new file mode 100644 index 00000000..54a0776e --- /dev/null +++ b/sys/mwcs/gen/mwvmulr.x @@ -0,0 +1,20 @@ +# MW_VMUL -- Vector multiply. + +procedure mw_vmulr (a, b, c, ndim) + +real a[ndim,ndim] #I input matrix +real b[ndim] #I input vector +real c[ndim] #O output vector +int ndim #I system dimension + +int i, j +real v + +begin + do j = 1, ndim { + v = 0 + do i = 1, ndim + v = v + a[i,j] * b[i] + c[j] = v + } +end diff --git a/sys/mwcs/gen/mwvtrand.x b/sys/mwcs/gen/mwvtrand.x new file mode 100644 index 00000000..1a1cb662 --- /dev/null +++ b/sys/mwcs/gen/mwvtrand.x @@ -0,0 +1,18 @@ +# MW_VTRAN -- Transform an array of N-dimensional points, expressed as a +# 2D vector where v[1,i] is point I of vector V. + +procedure mw_vtrand (ct, v1, v2, ndim, npts) + +pointer ct #I pointer to CTRAN descriptor +double v1[ndim,npts] #I points to be transformed +double v2[ndim,npts] #O vector to get the transformed points +int ndim #I dimensionality of each point +int npts #I number of points + +int i +errchk mw_ctrand + +begin + do i = 1, npts + call mw_ctrand (ct, v1[1,i], v2[1,i], ndim) +end diff --git a/sys/mwcs/gen/mwvtranr.x b/sys/mwcs/gen/mwvtranr.x new file mode 100644 index 00000000..ca705c8b --- /dev/null +++ b/sys/mwcs/gen/mwvtranr.x @@ -0,0 +1,18 @@ +# MW_VTRAN -- Transform an array of N-dimensional points, expressed as a +# 2D vector where v[1,i] is point I of vector V. + +procedure mw_vtranr (ct, v1, v2, ndim, npts) + +pointer ct #I pointer to CTRAN descriptor +real v1[ndim,npts] #I points to be transformed +real v2[ndim,npts] #O vector to get the transformed points +int ndim #I dimensionality of each point +int npts #I number of points + +int i +errchk mw_ctranr + +begin + do i = 1, npts + call mw_ctranr (ct, v1[1,i], v2[1,i], ndim) +end diff --git a/sys/mwcs/imwcs.h b/sys/mwcs/imwcs.h new file mode 100644 index 00000000..6266a1d1 --- /dev/null +++ b/sys/mwcs/imwcs.h @@ -0,0 +1,67 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMWCS.H -- Definitions used by MW_SAVEIM and MW_LOADIM to encode and +# decode the FITS (image header) version of a MWCS. + +define DEF_MAXCARDS 128 # initial number of card descriptors +define INC_MAXCARDS 128 # increment if overflow occurs +define IDB_STARTVALUE 10 # column at which data field begins +define MAX_FITSCOLS 68 # max chars of data per FITS card +define DEF_BIGBUF 680 # initial size of "big" FITS buffer +define INC_BIGBUF 680 # initial size of "big" FITS buffer +define SZ_KWNAME 8 # size of FITS keyword +define SZ_VALSTR 21 # size of FITS value string +define SZ_SBUF 163840 # string buffer size (2048 WCS cards) +define SZ_OBUF 680 # biggest "attribute = value" string +define SZ_CARD 80 # card width, chars +define SZ_BIGSTR MAX_FITSCOLS # max size FITS string (one card) + +# WCS FITS main descriptor. +define LEN_IMWCS 310 +define IW_IM Memi[$1] # image descriptor +define IW_NDIM Memi[$1+1] # image dimension +define IW_NCARDS Memi[$1+2] # number of WCS cards +define IW_CBUF Memi[$1+3] # card descriptors +define IW_MAXCARDS Memi[$1+4] # CBUF allocated length, cards +define IW_SBUF Memi[$1+5] # string buffer +define IW_SBUFLEN Memi[$1+6] # SBUF allocated length, chars +define IW_SBUFOP Memi[$1+7] # current offset in sbuf +define IW_CARD (IW_CBUF($1)+(($2)-1)*LEN_CDES) + # (avail) +define IW_CROTA Memr[P2R($1+9)] # obsolete +define IW_CTYPE Memi[$1+10+($2)-1] # axtype (strp) +define IW_CRPIX Memd[P2D($1+20)+($2)-1] # CRPIXi +define IW_CRVAL Memd[P2D($1+40)+($2)-1] # CRVALi +define IW_CDELT Memd[P2D($1+60)+($2)-1] # CDELTi +define IW_CD Memd[P2D($1+80)+(($3)-1)*7+($2)-1] # CDi_j +define IW_LTV Memd[P2D($1+180)+($2)-1] # LTVi +define IW_LTM Memd[P2D($1+200)+(($3)-1)*7+($2)-1] # LTMi_j +define IW_WSVLEN Memi[$1+300+($2)-1] # WSVi_LEN + +# WCS FITS card descriptor. +define LEN_CDES 6 +define C_TYPE Memi[$1] # card type +define C_AXIS Memi[$1+1] # wcs axis +define C_INDEX Memi[$1+2] # card number on axis +define C_CARDNO Memi[$1+3] # card number in header +define C_UPDATED Memi[$1+4] # card has been updated +define C_RP Memi[$1+5] # pointer to card + +# Card types. +define TY_CTYPE 1 +define TY_CDELT 2 +define TY_CROTA 3 +define TY_CRPIX 4 +define TY_CRVAL 5 +define TY_CD 6 +define TY_LTV 7 +define TY_LTM 8 +define TY_WATDATA 9 +define TY_WSVLEN 10 +define TY_WSVDATA 11 +define TY_WCSDIM 12 +define TY_WAXMAP 13 + +# IW_RFITS definitions. +define RF_REFERENCE 0 # reference directly into header +define RF_COPY 1 # reference copies of header cards diff --git a/sys/mwcs/iwcfits.x b/sys/mwcs/iwcfits.x new file mode 100644 index 00000000..61e90b93 --- /dev/null +++ b/sys/mwcs/iwcfits.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imwcs.h" + +# IW_CFITS -- Close (free) an IMWCS descriptor allocated previously by +# IW_RFITS. + +procedure iw_cfits (iw) + +pointer iw #I pointer to IMWCS descriptor + +begin + if (IW_CBUF(iw) != NULL) + call mfree (IW_CBUF(iw), TY_STRUCT) + if (IW_SBUF(iw) != NULL) + call mfree (IW_SBUF(iw), TY_CHAR) + call mfree (iw, TY_STRUCT) +end diff --git a/sys/mwcs/iwctype.x b/sys/mwcs/iwctype.x new file mode 100644 index 00000000..b37494ba --- /dev/null +++ b/sys/mwcs/iwctype.x @@ -0,0 +1,126 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imwcs.h" + +# IW_CARDTYPE -- Examine a FITS card to see if it is a WCS specification card, +# and if so, return the card type, axis number, and index number. ERR is +# return if the card is not a WCS card. + +int procedure iw_cardtype (card, type, axis, index) + +char card[ARB] #I card to be examined +int type #O card type +int axis #O axis number or ERR +int index #O index number or ERR + +int ch1, ch2, ip +int strncmp(), ctoi() + +begin + ch1 = card[1] + ch2 = card[2] + type = ERR + ip = 6 + + # This is hardcoded for the sake of efficiency. + if (ch1 == 'C') { + if (ch2 == 'D') { + if (IS_DIGIT (card[3])) { + # CDi_j + type = TY_CD + axis = TO_INTEG (card[5]) + index = TO_INTEG (card[3]) + if (card[6] != ' ') + type = ERR + } else if (strncmp (card, "CDELT", 5) == 0) { + # CDELTi + type = TY_CDELT + axis = TO_INTEG (card[6]) + index = ERR + if (card[7] != ' ') + type = ERR + } + } else if (ch2 == 'R') { + if (strncmp (card, "CROTA2", 6) == 0) { + # CROTA2 + type = TY_CROTA + axis = ERR + index = ERR + } else if (strncmp (card, "CRPIX", 5) == 0) { + # CRPIXi + type = TY_CRPIX + axis = TO_INTEG (card[6]) + index = ERR + if (card[7] != ' ') + type = ERR + } else if (strncmp (card, "CRVAL", 5) == 0) { + # CRVALi + type = TY_CRVAL + axis = TO_INTEG (card[6]) + index = ERR + if (card[7] != ' ') + type = ERR + } + } else if (ch2 == 'T') { + if (strncmp (card, "CTYPE", 5) == 0) { + # CTYPEi + type = TY_CTYPE + axis = TO_INTEG (card[6]) + index = ERR + if (card[7] != ' ') + type = ERR + } + } + } else if (ch1 == 'L' && ch2 == 'T') { + if (card[3] == 'V' && IS_DIGIT (card[4])) { + type = TY_LTV + axis = TO_INTEG (card[4]) + index = ERR + } else if (card[3] == 'M' && IS_DIGIT (card[4])) { + type = TY_LTM + axis = TO_INTEG (card[4]) + index = TO_INTEG (card[6]) + } + } else if (ch1 == 'W') { + if (ch2 == 'A') { + if (card[3] == 'T' && IS_DIGIT (card[4])) { + type = TY_WATDATA + axis = TO_INTEG (card[4]) + if (IS_DIGIT(card[5])) + ip = 5 + if (ctoi (card, ip, index) <= 0) + type = ERR + } else if (strncmp (card, "WAXMAP", 6) == 0) { + type = TY_WAXMAP + axis = ERR + ip = 7 + if (ctoi (card, ip, index) <= 0) + type = ERR + } + } else if (ch2 == 'C') { + if (strncmp (card, "WCSDIM", 6) == 0) { + type = TY_WCSDIM + axis = ERR + index = ERR + } + } else if (ch2 == 'S') { + if (card[3] == 'V' && IS_DIGIT (card[4])) { + if (strncmp (card[5], "_LEN", 4) == 0) { + type = TY_WSVLEN + axis = TO_INTEG (card[4]) + index = ERR + } else { + if (IS_DIGIT(card[5])) + ip = 5 + if (ctoi (card, ip, index) > 0) { + type = TY_WSVDATA + axis = TO_INTEG (card[4]) + } + } + } + } + } + + return (type) +end diff --git a/sys/mwcs/iwewcs.x b/sys/mwcs/iwewcs.x new file mode 100644 index 00000000..1f5ca72a --- /dev/null +++ b/sys/mwcs/iwewcs.x @@ -0,0 +1,336 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include "mwcs.h" +include "imwcs.h" + +# IW_ENTERWCS -- Enter a WCS as represented in an IMWCS (FITS oriented) +# wcs descriptor into an MWCS descriptor. This routine is called by MW_LOADIM +# after IW_RFITS has been called to scan a FITS image header to build the +# IMWCS descriptor used as input here. + +procedure iw_enterwcs (mw, iw, ndim) + +pointer mw #I pointer to MWCS descriptor +pointer iw #I pointer to IMWCS descriptor +int ndim #I system dimension + +double theta +char ctype[8] +bool have_ltm, have_ltv, have_wattr +int axes[2], axis, npts, ch, ip, raax, decax, ax1, ax2, i, j, ea_type +double maxval +pointer sp, r, o_r, cd, ltm, cp, rp, bufp, pv, wv, o_cd, o_ltm, str + +bool streq() +pointer iw_gbigfits(), iw_findcard() +int strncmp(), ctod(), strldxs(), envgeti() +errchk mw_swtermd, iw_gbigfits, malloc, mw_swtype, mw_swsampd +define samperr_ 91 + +begin + call smark (sp) + call salloc (r, ndim, TY_DOUBLE) + call salloc (o_r, ndim, TY_DOUBLE) + call salloc (cd, ndim*ndim, TY_DOUBLE) + call salloc (ltm, ndim*ndim, TY_DOUBLE) + call salloc (o_cd, ndim*ndim, TY_DOUBLE) + call salloc (o_ltm, ndim*ndim, TY_DOUBLE) + call salloc (str, SZ_LINE, TY_CHAR) + + raax = 1 + decax = 2 + + # Set any nonlinear functions on the axes. + do axis = 1, ndim { + rp = IW_CTYPE(iw,axis) + if (rp == NULL) + next + + # Get the value of CTYPEi. Ignore case and treat '_' and '-' + # as equivalent. + + do i = 1, 8 { + ch = Memc[rp+i-1] + if (ch == EOS || ch == ' ' || ch == '\'') + break + else if (IS_UPPER(ch)) + ch = TO_LOWER(ch) + else if (ch == '_') + ch = '-' + ctype[i] = ch + } + ctype[i] = EOS + + # Determine the type of function on this axis. + if (streq (ctype, "linear")) { + ; # Linear is the default. + + } else if (streq (ctype, "sampled")) { + # A sampled WCS is an array of [P,W] points. + + bufp = iw_gbigfits (iw, TY_WSVDATA, axis) + npts = IW_WSVLEN(iw,axis) + call malloc (pv, npts, TY_DOUBLE) + call malloc (wv, npts, TY_DOUBLE) + + ip = 1 + do i = 1, npts { + if (ctod (Memc[bufp], ip, Memd[pv+i-1]) <= 0) + goto samperr_ + if (ctod (Memc[bufp], ip, Memd[wv+i-1]) <= 0) { +samperr_ call eprintf ( + "Image %s, axis %d: Cannot read sampled WCS\n") + call pargstr (IM_NAME(IW_IM(iw))) + call pargi (axis) + break + } + } + + call mw_swtype (mw, axis, 1, "sampled", "") + call mw_swsampd (mw, axis, Memd[pv], Memd[wv], npts) + + call mfree (wv, TY_DOUBLE) + call mfree (pv, TY_DOUBLE) + call mfree (bufp, TY_CHAR) + + } else if (strncmp (ctype, "ra--", 4) == 0) { + # The projections are restricted to two axes and are indicated + # by CTYPEi values such as, e.g., "RA---TAN" and "DEC--TAN" + # for the TAN projection. + + raax = axis + + # Locate the DEC axis. + decax = 0 + do j = 1, ndim { + cp = IW_CTYPE(iw,j) + if (cp != NULL) + if (Memc[cp+3] == '-' || Memc[cp+3] == '_') + if (strncmp (Memc[cp], "DEC", 3) == 0 || + strncmp (Memc[cp], "dec", 3) == 0) { + decax = j + break + } + } + + # Did we find it? + if (decax == 0) { + call eprintf ( + "Image %s, axis %d: Cannot locate dec-%s axis\n") + call pargstr (IM_NAME(IW_IM(iw))) + call pargi (axis) + call pargstr (ctype[5]) + } + + # Get the function type. + ip = strldxs ("-", ctype) + 1 + + # Assign the function to the two axes. + axes[1] = axis + axes[2] = decax + call mw_swtype (mw, axes, 2, ctype[ip], + "axis 1: axtype=ra axis 2: axtype=dec") + + } else if (strncmp (ctype, "dec-", 4) == 0) { + ; # This case is handled when RA-- is seen. + + } else if (strncmp (ctype[2], "lon-", 4) == 0) { + # The projections are restricted to two axes and are indicated + # by CTYPEi values such as, e.g., "xLON-TAN" and "xLAT-TAN" + # for the TAN projection. The letter x may be any character + # but must be the same for both the longitude and latitude + # axes. The standard values of x are G/g for galactic, E/e + # for ecliptic, and S/s for supergalactic coordinates. + + raax = axis + + # Locate the corresponding LAT axis. + decax = 0 + do j = 1, ndim { + cp = IW_CTYPE(iw,j) + if (cp != NULL) { + if (Memc[cp+4] == '-' || Memc[cp+4] == '_') { + if (strncmp (Memc[cp+1], "LAT", 3) == 0 || + strncmp (Memc[cp+1], "lat", 3) == 0) { + decax = j + break + } + } + } + } + + # Did we find it? + if (decax == 0) { + call eprintf ( + "Image %s, axis %d: Cannot locate %clat%s axis\n") + call pargstr (IM_NAME(IW_IM(iw))) + call pargi (axis) + call pargc (ctype[1]) + call pargstr (ctype[5]) + } + + # Get the function type. + ip = strldxs ("-", ctype) + 1 + + # Assign the function to the two axes. + axes[1] = axis + axes[2] = decax + call sprintf (Memc[str], SZ_LINE, + "axis 1: axtype=%clon axis 2: axtype=%clat") + call pargc (ctype[1]) + call pargc (ctype[1]) + call mw_swtype (mw, axes, 2, ctype[ip], Memc[str]) + + } else if (strncmp (ctype[2], "lat-", 4) == 0) { + ; # This case is handled when xLON is seen. + + } else if (strncmp (ctype, "multispec", 8) == 0) { + # Multispec format image. Axis 1,2 are coupled. + if (axis == 1) { + axes[1] = 1; axes[2] = 2 + call mw_swtype (mw, axes, 2, "multispec", "") + } + + } 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_swattrs (mw, axis, "label", ctype) + } + } + + # Compute the CD matrix, or verify that one was read. Either the + # CD matrix was input, the CROTA/CDELT representation was input, + # or nothing was input, in which case we have the identity matrix. + + if (iw_findcard (iw, TY_CD, ERR, 0) == NULL) { + # Initialize CD matrix to the identity matrix. Can't use mw_mkidm + # here as IW_CD is not dimensioned ndim. + + do j = 1, ndim { + do i = 1, ndim + IW_CD(iw,i,j) = 0.0 + IW_CD(iw,j,j) = 1.0 + } + + # Convert CDELT/CROTA to CD matrix. + if (iw_findcard (iw, TY_CDELT, ERR, 0) != NULL) { + theta = DEGTORAD(IW_CROTA(iw)) + ax1 = raax + ax2 = decax + IW_CD(iw,ax1,ax1) = IW_CDELT(iw,ax1) * cos(theta) + IW_CD(iw,ax1,ax2) = IW_CDELT(iw,ax1) * sin(theta) + IW_CD(iw,ax2,ax1) = -IW_CDELT(iw,ax2) * sin(theta) + IW_CD(iw,ax2,ax2) = IW_CDELT(iw,ax2) * cos(theta) + } + + do j = 1, ndim { + if (j == raax || j == decax) + next + IW_CD(iw,j,j) = IW_CDELT(iw,j) + } + } + + # Set axes with no scales to unit scales. Issue a warning by + # default but use "wcs_matrix_err" to allow setting other error + # actions. + + do i = 1, ndim { + maxval = 0D0 + do j = 1, ndim + maxval = max (maxval, abs(IW_CD(iw,i,j))) + if (maxval == 0D0) { + iferr (ea_type = envgeti ("wcs_matrix_err")) + ea_type = EA_WARN + iferr { + switch (ea_type) { + case EA_FATAL, EA_ERROR: + call sprintf (Memc[str], SZ_FNAME, + "CD keywords for axis %d undefined") + call pargi (i) + call error (SYS_MWMISSAX, Memc[str]) + case EA_WARN: + IW_CD(iw,i,i) = 1D0 + call sprintf (Memc[str], SZ_LINE, + "setting CD%d_%d to %.4g") + call pargi (i) + call pargi (i) + call pargd (IW_CD(iw,i,i)) + call error (SYS_MWMISSAX, Memc[str]) + default: + IW_CD(iw,i,i) = 1D0 + } + } then + call erract (ea_type) + } + } + + # Extract an NDIM submatrix from LTM and CD. + do j = 1, ndim + do i = 1, ndim { + Memd[o_cd+(j-1)*ndim+(i-1)] = IW_CD(iw,i,j) + Memd[o_ltm+(j-1)*ndim+(i-1)] = IW_LTM(iw,i,j) + } + + # Set the linear portion of the Wterm. First we have to transform + # it from the FITS logical->world representation to the MWCS + # physical->world form, by separating out the Lterm. We have + # CD = CD' * LTM and R = inv(LTM) * (R' - LTV), where CD' and R' are + # the FITS versions of the MWCS CD matrix and R vector (CRPIX), and + # LTM and LTV are the Lterm rotation matrix and translation vector. + + # First, determine if either LTM or LTV was specified in the header. + have_ltm = (iw_findcard (iw, TY_LTM, ERR, 0) != NULL) + have_ltv = (iw_findcard (iw, TY_LTV, ERR, 0) != NULL) + + # Compute CD = CD' * LTM. + if (have_ltm) + call mw_mmuld (Memd[o_cd], Memd[o_ltm], Memd[cd], ndim) + else + call amovd (Memd[o_cd], Memd[cd], ndim*ndim) + + # Compute R = inv(LTM) * (R' - LTV). + if (have_ltm || have_ltv) { + call asubd (IW_CRPIX(iw,1), IW_LTV(iw,1), Memd[o_r], ndim) + if (have_ltm) { + call mw_invertd (Memd[o_ltm], Memd[ltm], ndim) + call mw_vmuld (Memd[ltm], Memd[o_r], Memd[r], ndim) + } else + call amovd (Memd[o_r], Memd[r], ndim) + } else + call amovd (IW_CRPIX(iw,1), Memd[r], ndim) + + # Set the Wterm. + call mw_swtermd (mw, Memd[r], IW_CRVAL(iw,1), Memd[cd], ndim) + # Process in any axis attributes. The pseudo-axis 0 is used by + # any global WCS attributes. + + do axis = 0, ndim { + # Is there any attribute data for axis J? + have_wattr = false + do i = 1, IW_NCARDS(iw) { + cp = IW_CARD(iw,i) + if (C_TYPE(cp) == TY_WATDATA && C_AXIS(cp) == axis) { + have_wattr = true + break + } + } + + # Reconstruct the attribute list and enter into MWCS. + if (have_wattr) { + bufp = iw_gbigfits (iw, TY_WATDATA, axis) + call mw_swtype (mw, axis, 1, "", Memc[bufp]) + call mfree (bufp, TY_CHAR) + } + } + + call sfree (sp) +end diff --git a/sys/mwcs/iwfind.x b/sys/mwcs/iwfind.x new file mode 100644 index 00000000..e400f9ee --- /dev/null +++ b/sys/mwcs/iwfind.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imwcs.h" + +# IW_FINDCARD -- Search the card list in the IMWCS descriptor for a card of +# the given type, with the given axis and index numbers. Return a pointer to +# the card if found, else NULL. + +pointer procedure iw_findcard (iw, type, axis, index) + +pointer iw #I pointer to IMWCS descriptor +int type #I card type code +int axis #I axis number, or <0 to ignore +int index #I index number, or <=0 to ignore + +int i +pointer cp + +begin + do i = 1, IW_NCARDS(iw) { + cp = IW_CARD(iw,i) + if (C_TYPE(cp) != type) + next + if (axis >= 0) + if (C_AXIS(cp) != axis) + next + if (index > 0) + if (C_INDEX(cp) != index) + next + return (cp) + } + + return (NULL) +end diff --git a/sys/mwcs/iwgbfits.x b/sys/mwcs/iwgbfits.x new file mode 100644 index 00000000..5fd1810d --- /dev/null +++ b/sys/mwcs/iwgbfits.x @@ -0,0 +1,90 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imwcs.h" + +# IW_GBIGFITS -- Get a FITS string valued parameter of arbitrary size. +# Since a FITS string stored as a single parameter is limited to at most +# 69 characters, multiple FITS cards must be used to store longer strings. +# At the time that this routine is called, IW_RFITS has already been called +# to scan the FITS header and build up a list of WCS oriented cards, +# including card types and pointers to the card data. Our job is merely +# to take these cards in order and concatenate the string values into one +# large string, returning a pointer to the string as the function value. +# The caller must later make a MFREE call to free this buffer. + +pointer procedure iw_gbigfits (iw, ctype, axis) + +pointer iw #I pointer to IMWCS descriptor +int ctype #I card type +int axis #I axis to which card refers + +int ncards, i, j, ch +pointer cp, bp, ip, op, rp +define put_ 10 + +begin + # How much space do we need? + ncards = 0 + do i = 1, IW_NCARDS(iw) { + cp = IW_CARD(iw,i) + if (C_AXIS(cp) == axis && C_TYPE(cp) == ctype) + ncards = ncards + 1 + } + + # Allocate the space. + call calloc (bp, ncards * MAX_FITSCOLS, TY_CHAR) + + # For successive cards 1, 2, 3, etc... + op = bp + do j = 1, ncards { + # Find the card. + rp = NULL + do i = 1, IW_NCARDS(iw) { + cp = IW_CARD(iw,i) + if (C_AXIS(cp) != axis) + next + if (C_INDEX(cp) != j) + next + if (C_TYPE(cp) != ctype) + next + + rp = C_RP(cp) + break + } + + # Append to the string buffer. + if (rp != NULL) { + #call amovc (Memc[rp+IDB_STARTVALUE+1], Memc[op], MAX_FITSCOLS) + #op = op + MAX_FITSCOLS + + do i = 1, MAX_FITSCOLS { + ip = rp + IDB_STARTVALUE + i + ch = Memc[ip] + + if (ch == EOS || ch == '\n') { + break + } else if (ch == '\'') { + if (Memc[ip+1] == '\'') { + goto put_ + } else if (Memc[ip-1] == '\'') { + ; + } else if (i > 1 && i <= MAX_FITSCOLS) { + # If we're not at the end of the card, we have a + # complete string, but add a space for appending + # so we don't concatenate. + Memc[op] = ' ' + op = op + 1 + break + } else + break + } else { +put_ Memc[op] = ch + op = op + 1 + } + } + } + } + + Memc[op] = EOS + return (bp) +end diff --git a/sys/mwcs/iwparray.x b/sys/mwcs/iwparray.x new file mode 100644 index 00000000..cb6cb0d9 --- /dev/null +++ b/sys/mwcs/iwparray.x @@ -0,0 +1,53 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imwcs.h" + +# IW_PUTARRAY -- Output a double floating array as a sequence of FITS cards, +# one value per card in the form "keyword = value", using the format string +# given to format the name of the FITS keyword. + +procedure iw_putarray (iw, new, old, ndim, kw_format, kw_type, kw_index) + +pointer iw #I pointer to IMWCS descriptor +double new[ndim] #I new array values +double old[ndim] #I old array values from header +int ndim #I image and WCS dimension +char kw_format[ARB] #I format for encoding keyword name +int kw_type #I IMWCS keyword type code +int kw_index #I keword index or 0 if don't care + +int axis +pointer cp, im +char kwname[SZ_KWNAME] +bool fp_equald() +pointer iw_findcard() +errchk imaddf, imputd + +begin + do axis = 1, ndim { + # If new value is zero, no output, delete old card if present. + if (fp_equald (new[axis], 0.0D0)) + next + + # See if we read the card for this parameter. + cp = iw_findcard (iw, kw_type, axis, kw_index) + im = IW_IM(iw) + + # If value is unchanged, no need to do anything. + if (fp_equald (new[axis], old[axis])) { + if (cp != NULL) + C_UPDATED(cp) = YES + next + } + + # Update the keyword in the image header. + call sprintf (kwname, SZ_KWNAME, kw_format) + call pargi (axis) + + if (cp == NULL) + call imaddf (im, kwname, "d") + call imputd (im, kwname, new[axis]) + if (cp != NULL) + C_UPDATED(cp) = YES + } +end diff --git a/sys/mwcs/iwpstr.x b/sys/mwcs/iwpstr.x new file mode 100644 index 00000000..27b7e351 --- /dev/null +++ b/sys/mwcs/iwpstr.x @@ -0,0 +1,80 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imwcs.h" + +# IW_PUTSTR -- Put an arbitrarily large string valued parameter to a FITS +# header, using multiple FITS cards if necessary. The input string value is +# passed in as a byte stream file. + +procedure iw_putstr (fd, iw, axis, ctype, fmt1, fmt2, max_index) + +int fd #I input file +pointer iw #I pointer to IMWCS descriptor +int axis #I axis to which parameter belongs +int ctype #I card type +char fmt1[ARB], fmt2[ARB] #I keyword name formats +int max_index #I use fmt2 if index > max_index + +bool update +int index, nchars +pointer sp, bigstr, im, cp +char kwname[SZ_KWNAME] + +pointer iw_findcard() +int read(), strncmp() +errchk read, imaddf, impstr + +begin + call smark (sp) + call salloc (bigstr, SZ_BIGSTR, TY_CHAR) + + index = 0 + im = IW_IM(iw) + + repeat { + # Get enough data to fit on a FITS card. + nchars = read (fd, Memc[bigstr], SZ_BIGSTR) + if (nchars <= 0) + break + + # Blank fill the last card if necessary. + #while (nchars < SZ_BIGSTR && mod (nchars, SZ_BIGSTR) != 0) { + # Memc[bigstr+nchars] = ' ' + # nchars = nchars + 1 + #} + Memc[bigstr+nchars] = EOS + + index = index + 1 + cp = iw_findcard (iw, ctype, axis, index) + + update = true + if (cp != NULL) + if (strncmp (Memc[C_RP(cp)+IDB_STARTVALUE+1], + Memc[bigstr], SZ_BIGSTR) == 0) { + update = false + } + + # Output the card. The format string should contain two %d + # fields, unless axis=ERR, in which case only the index value + # is used. If the index value is greater than max_index then + # fmt2 is used as the print format, otherwise fmt1 is used. + + if (update) { + if (max_index > 0 && index > max_index) + call sprintf (kwname, SZ_KWNAME, fmt2) + else + call sprintf (kwname, SZ_KWNAME, fmt1) + if (axis >= 0) + call pargi (axis) + call pargi (index) + if (cp == NULL) + call imaddf (im, kwname, "c") + call impstr (im, kwname, Memc[bigstr]) + } + + if (cp != NULL) + C_UPDATED(cp) = YES + } + + call sfree (sp) +end diff --git a/sys/mwcs/iwrfits.x b/sys/mwcs/iwrfits.x new file mode 100644 index 00000000..b70208a5 --- /dev/null +++ b/sys/mwcs/iwrfits.x @@ -0,0 +1,167 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "mwcs.h" +include "imwcs.h" + +# IW_RFITS -- Read a FITS image header into an IMWCS (FITS oriented) world +# coordinate system descriptor. For reasons of efficiency (especially due +# to the possibly of large sampled WCS arrays) this is done with a single +# pass through the header to get all the WCS data, with interpretation of +# the data being a separate independent step. A pointer to an IMWCS descriptor +# is returned as the function value. When no longer needed, this should be +# freed with IW_CLOSE. The dimensionality of the WCS is determined first +# from the image dimensionality (which may be zero) and then overridden +# if there is a WCSDIM card. If the final dimensionality is zero then +# the maximum axis of the WCS cards sets the dimensionality. + + +pointer procedure iw_rfits (mw, im, mode) + +pointer mw #I pointer to MWCS descriptor +pointer im #I pointer to image header +int mode #I RF_REFERENCE or RF_COPY + +double dval +bool omit, copy +pointer iw, idb, rp, cp, fp +int ndim, recno, ualen, type, axis, index, ip, temp, i + +pointer idb_open() +int idb_nextcard(), iw_cardtype(), ctod(), ctoi() +errchk calloc, realloc, syserrs + +begin + ndim = max (IM_NDIM(im), IM_NPHYSDIM(im)) + copy = (mode == RF_COPY) + + # Allocate and initialize the FITS-WCS descriptor. + call calloc (iw, LEN_IMWCS, TY_STRUCT) + call calloc (IW_CBUF(iw), LEN_CDES * DEF_MAXCARDS, TY_STRUCT) + + # Allocate string buffer if we must keep a local copy of the data. + if (copy) { + call calloc (IW_SBUF(iw), SZ_SBUF, TY_CHAR) + IW_SBUFLEN(iw) = SZ_SBUF + IW_SBUFOP(iw) = 0 + } + + IW_MAXCARDS(iw) = DEF_MAXCARDS + IW_NDIM(iw) = ndim + IW_IM(iw) = im + + # Scan the image header, examining successive cards to see if they + # are WCS specification cards, making an entry for each such card + # in the IMWCS descriptor. The values of simple scalar valued cards + # are interpreted immediately and used to modify the default WCS + # data values established above. For the array valued parameters we + # merely record the particulars for each card, leaving reconstruction + # of the array until all the cards have been located. + + idb = idb_open (im, ualen) + recno = 0 + while (idb_nextcard (idb, rp) != EOF) { + recno = recno + 1 + if (iw_cardtype (Memc[rp], type, axis, index) <= 0) + next + + + # Has this card already been seen? + omit = false + do i = 1, IW_NCARDS(iw) { + cp = IW_CARD(iw,i) + if (C_TYPE(cp) != type) + next + if (C_AXIS(cp) != axis) + next + if (C_INDEX(cp) != index) + next + omit = true + break + } + + # Ignore duplicate cards. + if (omit) + next + + # Get another card descriptor. + IW_NCARDS(iw) = IW_NCARDS(iw) + 1 + if (IW_NCARDS(iw) > IW_MAXCARDS(iw)) { + IW_MAXCARDS(iw) = IW_MAXCARDS(iw) + INC_MAXCARDS + call realloc (IW_CBUF(iw), + IW_MAXCARDS(iw) * LEN_CDES, TY_STRUCT) + cp = IW_CARD(iw,IW_NCARDS(iw)) + call aclri (Memi[cp], + (IW_MAXCARDS(iw) - IW_NCARDS(iw) + 1) * LEN_CDES) + } + cp = IW_CARD(iw,IW_NCARDS(iw)) + + C_TYPE(cp) = type + C_AXIS(cp) = axis + C_INDEX(cp) = index + C_CARDNO(cp) = recno + + ndim = max (ndim, axis) + + # The FITS data must be copied into local storage if the header + # will be edited, since otherwise the cards may move, invalidating + # the pointer. Always save whole cards; don't bother with an EOS + # or newline between cards. + + if (copy) { + if (IW_SBUFOP(iw) + SZ_CARD > IW_SBUFLEN(iw)) + call syserrs (SYS_MWFITSOVFL, IM_NAME(im)) + C_RP(cp) = IW_SBUF(iw) + IW_SBUFOP(iw) + call strcpy (Memc[rp], Memc[C_RP(cp)], SZ_CARD) + IW_SBUFOP(iw) = IW_SBUFOP(iw) + SZ_CARD + } else + C_RP(cp) = rp + + # Decode the card value. + ip = IDB_STARTVALUE + switch (type) { + case TY_CTYPE: + fp = C_RP(cp) + ip + while (IS_WHITE(Memc[fp]) || Memc[fp] == '\'') + fp = fp + 1 + IW_CTYPE(iw,axis) = fp + case TY_CDELT: + if (ctod (Memc[rp], ip, IW_CDELT(iw,axis)) <= 0) + IW_CDELT(iw,axis) = 0.0 + case TY_CROTA: + if (ctod (Memc[rp], ip, dval) > 0) + IW_CROTA(iw) = dval + case TY_CRPIX: + if (ctod (Memc[rp], ip, IW_CRPIX(iw,axis)) <= 0) + IW_CRPIX(iw,axis) = 0.0 + case TY_CRVAL: + if (ctod (Memc[rp], ip, IW_CRVAL(iw,axis)) <= 0) + IW_CRVAL(iw,axis) = 0.0 + case TY_CD: + if (ctod (Memc[rp], ip, IW_CD(iw,axis,index)) <= 0) + IW_CD(iw,axis,index) = 0.0 + case TY_LTV: + if (ctod (Memc[rp], ip, IW_LTV(iw,axis)) <= 0) + IW_LTV(iw,axis) = 0.0 + case TY_LTM: + if (ctod (Memc[rp], ip, IW_LTM(iw,axis,index)) <= 0) + IW_LTM(iw,axis,index) = 0.0 + case TY_WSVLEN: + if (ctoi (Memc[rp], ip, IW_WSVLEN(iw,axis)) <= 0) + IW_WSVLEN(iw,axis) = 0 + case TY_WCSDIM: + if (ctoi (Memc[rp], ip, temp) > 0) + IW_NDIM(iw) = temp + } + } + + # Set dimension to the maximum axis seen. + if (IW_NDIM(iw) == 0) + IW_NDIM(iw) = ndim + + call idb_close (idb) + return (iw) +end diff --git a/sys/mwcs/iwsaxmap.x b/sys/mwcs/iwsaxmap.x new file mode 100644 index 00000000..47ad9f09 --- /dev/null +++ b/sys/mwcs/iwsaxmap.x @@ -0,0 +1,117 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "mwcs.h" + +# IW_SETAXMAP -- If the reference image was opened with an image section, +# modify the Lterm to reflect the section transformation, and enable the +# axis map if any dimensional reduction was involved. + +procedure iw_setaxmap (mw, im) + +pointer mw #I pointer to MWCS descriptor +pointer im #I pointer to reference image + +double v +pointer sp, ltv_1, ltv_2, ltm +int wcsdim, ndim, physax, i, j +int axno[MAX_DIM], axval[MAX_DIM] +int o_axno[MAX_DIM], o_axval[MAX_DIM] +int n_axno[MAX_DIM], n_axval[MAX_DIM] + +begin + # If there is no section we don't need to do anything. + if (IM_SECTUSED(im) == NO) + return + + call smark (sp) + + ndim = IM_NPHYSDIM(im) + call salloc (ltv_1, ndim, TY_DOUBLE) + call salloc (ltv_2, ndim, TY_DOUBLE) + call salloc (ltm, ndim*ndim, TY_DOUBLE) + + # The section transformation is px = VSTEP * lx + VOFF, specifying + # the transformation from logical to physical image coordinates. + # The IMIO axis map is given by j=VMAP[i], mapping logical axis I to + # physical axis J. Hence the physical to logical transformation in + # terms of IMIO units is given by lx = (1/VSTEP) * px + (-VOFF/VSTEP). + # Since the section transform forbids rotation the axes are independent. + + call aclrd (Memd[ltv_1], ndim) + call aclrd (Memd[ltm], ndim * ndim) + + do i = 1, ndim { + if (IM_VSTEP(im,i) == 0) + v = 1.0D0 + else + v = 1.0D0 / IM_VSTEP(im,i) + + Memd[ltm+(i-1)*ndim+i-1] = v + Memd[ltv_2+(i-1)] = -(IM_VOFF(im,i) * v) + } + + # Enter the section transformation. This uses the axis map, but the + # transformation is defined in terms of the physical image matrix, + # which is defined by the old axis map before modification by the new + # image section. Hence we must do this step before editing the axis + # map below. + + call mw_translated (mw, Memd[ltv_1], Memd[ltm], Memd[ltv_2], ndim) + + # Compute the axis map for the active image section relative to the + # current physical image matrix. + + do j = 1, ndim { + for (i=1; i <= IM_NDIM(im); i=i+1) + if (IM_VMAP(im,i) == j) + break + if (i > IM_NDIM(im)) { + axno[j] = 0 + axval[j] = IM_VOFF(im,j) + } else { + axno[j] = i + axval[j] = 0 + } + } + + # Get the old axis map for the WCS. In the general case the WCS can + # have a dimension higher than the current image, i.e. if the current + # image was produced by extracting a section of an image of higher + # dimension. In such a case the WCS will have an axis map relating + # the physical axes of the current image back to the original physical + # system. + + wcsdim = MI_NDIM(mw) + call mw_gaxmap (mw, o_axno, o_axval, wcsdim) + + # Combine the old axis map and the axis map for the current image + # section. The old axis map physical->logical mapping maps WCS + # physical axes to logical axes, which are the physical axes of the + # current image. The axis map for the current image section maps the + # physical axes of the current image to the logical axes of the + # section. An axis removed in the WCS axis map is not visible in the + # image axno/axval computed above; the corresponding axis in the + # combined WCS axis map is unchanged. The remaining axes are subject + # to remapping by the mage axno/axval. This mapping may set any of + # the axes to a constant to further reduce the dimensionality of the + # logical system, however that does not concern us here, we just pass + # on the combined axno/axval vectors to mw_saxmap. + + do i = 1, wcsdim { + if (o_axno[i] == 0) { + n_axno[i] = 0 + n_axval[i] = o_axval[i] + } else { + physax = o_axno[i] + n_axno[i] = axno[physax] + n_axval[i] = axval[physax] + } + } + + # Set the new axis map. + call mw_saxmap (mw, n_axno, n_axval, wcsdim) + + call sfree (sp) +end diff --git a/sys/mwcs/mkpkg b/sys/mwcs/mkpkg new file mode 100644 index 00000000..05179ce6 --- /dev/null +++ b/sys/mwcs/mkpkg @@ -0,0 +1,120 @@ +# Make the MWCS interface. + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +generic: + $set G = "$$generic -k -p gen/ -t rd" + $ifolder (gen/mwc1tranr.x, mwc1tran.gx) $(G) mwc1tran.gx $endif + $ifolder (gen/mwc2tranr.x, mwc2tran.gx) $(G) mwc2tran.gx $endif + $ifolder (gen/mwctranr.x, mwctran.gx) $(G) mwctran.gx $endif + $ifolder (gen/mwgctranr.x, mwgctran.gx) $(G) mwgctran.gx $endif + $ifolder (gen/mwltranr.x, mwltran.gx) $(G) mwltran.gx $endif + $ifolder (gen/mwmmulr.x, mwmmul.gx) $(G) mwmmul.gx $endif + $ifolder (gen/mwv1tranr.x, mwv1tran.gx) $(G) mwv1tran.gx $endif + $ifolder (gen/mwv2tranr.x, mwv2tran.gx) $(G) mwv2tran.gx $endif + $ifolder (gen/mwvmulr.x, mwvmul.gx) $(G) mwvmul.gx $endif + $ifolder (gen/mwvtranr.x, mwvtran.gx) $(G) mwvtran.gx $endif + ; + +zzdebug: +zzdebug.e: + $checkout libex.a lib$ + $update libex.a + $checkin libex.a lib$ + + $omake zzdebug.x imwcs.h + $link -z zzdebug.o + ; + +libex.a: + # $set xflags = "$(xflags) -qfx" + $ifeq (USE_GENERIC, yes) $call generic $endif + @gen + + iwcfits.x imwcs.h + iwctype.x imwcs.h + iwewcs.x imwcs.h mwcs.h + iwfind.x imwcs.h + iwgbfits.x imwcs.h + iwparray.x imwcs.h + iwpstr.x imwcs.h + iwrfits.x imwcs.h mwcs.h + iwsaxmap.x mwcs.h + mwallocd.x mwcs.h + mwallocs.x mwcs.h + mwclose.x mwcs.h + mwctfree.x mwcs.com mwcs.h + mwfindsys.x mwcs.h + mwflookup.x mwcs.com mwcs.h + mwgaxlist.x mwcs.h + mwgaxmap.x mwcs.h + mwgltermd.x mwcs.h + mwgltermr.x mwcs.h + mwgsys.x mwcs.h + mwgwattrs.x mwcs.h + mwgwsampd.x mwcs.h + mwgwsampr.x mwcs.h + mwgwtermd.x mwcs.h + mwgwtermr.x mwcs.h + mwinvertd.x + mwinvertr.x + mwload.x mwcs.h mwsv.h + mwloadim.x imwcs.h mwcs.h + mwlu.x + mwmkidmd.x + mwmkidmr.x + mwnewcopy.x mwcs.h + mwnewsys.x mwcs.h + mwopen.x mwcs.h + mwopenim.x + mwrefstr.x mwcs.h + mwrotate.x mwcs.h + mwsave.x mwcs.h mwsv.h + mwsaveim.x imwcs.h mwcs.com mwcs.h + mwsaxmap.x mwcs.h + mwscale.x mwcs.h + mwsctran.x mwcs.com mwcs.h + mwsdefwcs.x mwcs.h + mwseti.x mwcs.h + mwshift.x mwcs.h + mwshow.x mwcs.h + mwsltermd.x mwcs.h + mwsltermr.x mwcs.h + mwssys.x mwcs.h + mwstati.x mwcs.h + mwswattrs.x mwcs.h + mwswsampd.x mwcs.h + mwswsampr.x mwcs.h + mwswtermd.x mwcs.h + mwswtermr.x mwcs.h + mwswtype.x mwcs.h + mwtransd.x mwcs.h + mwtransr.x + wfait.x mwcs.h + wfarc.x mwcs.h + wfcar.x mwcs.h + wfcsc.x mwcs.h + wfdecaxis.x mwcs.h + wfgls.x mwcs.h + wfgsurfit.x + wfinit.x mwcs.com mwcs.h + wfmer.x mwcs.h + wfmol.x mwcs.h + wfmspec.x mwcs.h + wfpar.x mwcs.h + wfpco.x mwcs.h + wfqsc.x mwcs.h + wfsamp.x mwcs.h + wfsin.x mwcs.h + wfstg.x mwcs.h + wftan.x mwcs.h + wftnx.x mwcs.h + wftpv.x mwcs.h + wftsc.x mwcs.h + wfzea.x mwcs.h + wfzpn.x mwcs.h + wfzpx.x mwcs.h + ; diff --git a/sys/mwcs/mwallocd.x b/sys/mwcs/mwallocd.x new file mode 100644 index 00000000..96623015 --- /dev/null +++ b/sys/mwcs/mwallocd.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "mwcs.h" + +# MW_ALLOCD -- Allocate space in the data buffer. The size of the buffer +# is automatically increased if necessary. Note that reallocation of the +# buffer may cause it to move, hence all data items are referred to by their +# offset in the buffer, rather than by an absolute pointer. + +int procedure mw_allocd (mw, nelem) + +pointer mw #I pointer to MWCS descriptor +int nelem #I number of elements to alloc space for + +int dbufused, dbuflen, offset +errchk realloc + +begin + dbufused = MI_DBUFUSED(mw) + dbuflen = MI_DBUFLEN(mw) + offset = dbufused + 1 + + # Increase buffer size? + if (dbufused + nelem > dbuflen) { + dbuflen = dbuflen + INC_SZDBUF + while (dbufused + nelem > dbuflen) + dbuflen = dbuflen + INC_SZDBUF + + call realloc (MI_DBUF(mw), dbuflen, TY_DOUBLE) + call aclrd (D(mw,offset), dbuflen - offset + 1) + MI_DBUFLEN(mw) = dbuflen + } + + # Allocate the space in the buffer, and return the buffer offset + # of the allocated area. + + MI_DBUFUSED(mw) = max (0, dbufused + nelem) + return (offset) +end diff --git a/sys/mwcs/mwallocs.x b/sys/mwcs/mwallocs.x new file mode 100644 index 00000000..6a9caf5b --- /dev/null +++ b/sys/mwcs/mwallocs.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "mwcs.h" + +# MW_ALLOCS -- Allocate space in the global string buffer. The size of the +# buffer is automatically increased if necessary. Note that reallocation of +# the buffer may cause it to move, hence all data items are referred to by +# their offset in the buffer, rather than by an absolute pointer. Since we +# are allocating space for string data, a space for the EOS is automatically +# allocated in addition to space for the indicated number of data chars. + +int procedure mw_allocs (mw, nchars) + +pointer mw #I pointer to MWCS descriptor +int nchars #I number of chars to allocate space for + +int sbufused, sbuflen, offset, nelem +errchk realloc + +begin + sbufused = MI_SBUFUSED(mw) + sbuflen = MI_SBUFLEN(mw) + offset = sbufused + 1 + nelem = nchars + 1 + + # Increase buffer size? + if (sbufused + nelem > sbuflen) { + sbuflen = sbuflen + INC_SZSBUF + while (sbufused + nelem > sbuflen) + sbuflen = sbuflen + INC_SZSBUF + + call realloc (MI_SBUF(mw), sbuflen, TY_CHAR) + call aclrc (S(mw,offset), sbuflen - offset + 1) + MI_SBUFLEN(mw) = sbuflen + } + + # Allocate the space in the buffer, and return the buffer offset + # of the allocated area. + + MI_SBUFUSED(mw) = max (0, sbufused + nelem) + return (offset) +end diff --git a/sys/mwcs/mwc1tran.gx b/sys/mwcs/mwc1tran.gx new file mode 100644 index 00000000..b2cbbcfc --- /dev/null +++ b/sys/mwcs/mwc1tran.gx @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../mwcs.h" + +# MW_C1TRAN -- Optimized 1D coordinate transformation. + +PIXEL procedure mw_c1tran$t (a_ct, x) + +pointer a_ct #I pointer to CTRAN descriptor +PIXEL x #I coordinates in input system + +PIXEL y +pointer ct + +begin + # Get real or double version of descriptor. + ct = CT_$T(a_ct) + + # Perform the transformation; LNR is a simple linear transformation. + if (CT_TYPE(ct) == LNR) { + return (Mem$t[CT_LTM(ct)] * x + Mem$t[CT_LTV(ct)]) + } else { + call mw_ctran$t (a_ct, x, y, 1) + return (y) + } +end diff --git a/sys/mwcs/mwc2tran.gx b/sys/mwcs/mwc2tran.gx new file mode 100644 index 00000000..1c757d31 --- /dev/null +++ b/sys/mwcs/mwc2tran.gx @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../mwcs.h" + +# MW_C2TRAN -- Optimized 2D coordinate transformation. + +procedure mw_c2tran$t (a_ct, x1,y1, x2,y2) + +pointer a_ct #I pointer to CTRAN descriptor +PIXEL x1,y1 #I coordinates in input system +PIXEL x2,y2 #O coordinates in output system + +pointer ct, ltm, ltv +PIXEL p1[2], p2[2] + +begin + # Get real or double version of descriptor. + ct = CT_$T(a_ct) + + ltm = CT_LTM(ct) + ltv = CT_LTV(ct) + + if (CT_TYPE(ct) == LNR) { + # Simple linear, nonrotated transformation. + x2 = Mem$t[ltm ] * x1 + Mem$t[ltv ] + y2 = Mem$t[ltm+3] * y1 + Mem$t[ltv+1] + } else if (CT_TYPE(ct) == LRO) { + # Linear, rotated transformation. + p1[1] = x1; p1[2] = y1 + x2 = Mem$t[ltm ] * p1[1] + Mem$t[ltm+1] * p1[2] + Mem$t[ltv ] + y2 = Mem$t[ltm+2] * p1[1] + Mem$t[ltm+3] * p1[2] + Mem$t[ltv+1] + } else { + # General case involving one or more functional terms. + p1[1] = x1; p1[2] = y1 + call mw_ctran$t (a_ct, p1, p2, 2) + x2 = p2[1]; y2 = p2[2] + } +end diff --git a/sys/mwcs/mwclose.x b/sys/mwcs/mwclose.x new file mode 100644 index 00000000..441a78c2 --- /dev/null +++ b/sys/mwcs/mwclose.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "mwcs.h" + +# MW_CLOSE -- Close a MWCS descriptor and deallocate all resources used +# by the descriptor. Any CTRAN descriptors which have been opened on +# the MWCS are automatically closed if not already manually closed by +# the application. + +procedure mw_close (mw) + +pointer mw #U pointer to MWCS descriptor + +int i +pointer ct + +begin + # Free any still allocated CTRAN descriptors. + do i = 1, MAX_CTRAN { + ct = MI_CTRAN(mw,i) + if (ct != NULL) + iferr (call mw_ctfree (ct)) + call erract (EA_WARN) + } + + # Free the string and data buffers. + if (MI_SBUF(mw) != NULL) + call mfree (MI_SBUF(mw), TY_CHAR) + if (MI_DBUF(mw) != NULL) + call mfree (MI_DBUF(mw), TY_DOUBLE) + + # Free the main descriptor. + call mfree (mw, TY_STRUCT) +end diff --git a/sys/mwcs/mwcs.com b/sys/mwcs/mwcs.com new file mode 100644 index 00000000..80c2b79d --- /dev/null +++ b/sys/mwcs/mwcs.com @@ -0,0 +1,8 @@ +# MWCS common. Used for things that are global and don't change, i.e., +# the WCS function drivers. + +int fn_nfn # number of defined functions +int fn_table[LEN_FN,MAX_FN] # function table +char fn_names[SZ_FNNAME,MAX_FN] # function names + +common /mwcscom/ fn_nfn, fn_table, fn_names diff --git a/sys/mwcs/mwcs.h b/sys/mwcs/mwcs.h new file mode 100644 index 00000000..b202159e --- /dev/null +++ b/sys/mwcs/mwcs.h @@ -0,0 +1,152 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# MWCS.H -- Global (internal) definitions for the mini-WCS interface. + +define MWCS_MAGIC 4D57X # identifies MWCS descriptors +define DEF_SZSBUF 512 # initial string buffer size +define INC_SZSBUF 512 # increment string buffer size +define DEF_SZDBUF 64 # initial double buffer size +define INC_SZDBUF 64 # increment double buffer size +define MAX_DIM 7 # max dimension of a wcs +define MAX_WCS 8 # max wcs per mwcs +define MAX_WATTR 512 # max attributes per wcs +define MAX_CTRAN 20 # max runtime ctran descriptors +define MAX_CALL 7 # max CTRAN function calls +define MAX_FUNC 7 # max WCS function descriptors +define MAX_WCSFD 10 # max loaded WCS function drivers +define MAX_FN 32 # max MWCS function drivers +define SZ_FNNAME 20 # max size function name +define SZ_ATNAME 20 # max size attribute name + +# MWCS descriptor. This consists of the base descriptor, global string +# buffer, global data buffer (TY_DOUBLE), and separately allocated buffers +# for each runtime CT (coordinate transformation) descriptor. All character +# data is stored in SBUF. All floating point data is stored as type double +# in DBUF (this does not mean that coordinate transformations are necessarily +# carried out in double precision). All string and floating data is +# referenced in the base descriptor by its index in the appropriate data +# buffer, to make the descriptor invariant with respect to relocation of DBUF. +# To keep things simple, space is preallocated for a fixed number of WCS, +# and for each WCS, for a fixed number of attributes. + +define LEN_BASEMWCS 70 +define LEN_WCS 1626 # (depends upon MAX_WATTR) +define LEN_MWCS (LEN_BASEMWCS+LEN_WCS*MAX_WCS) +define MI_LEN (LEN_BASEMWCS+LEN_WCS*MI_NWCS($1)) + +define MI_MAGIC Memi[$1] # magic marker +define MI_NDIM Memi[$1+1] # wcs physical dimension +define MI_WCS Memi[$1+2] # pointer to current wcs +define MI_NWCS Memi[$1+3] # number of wcs defined +define MI_REFIM Memi[$1+4] # reference image, if any +define MI_SBUF Memi[$1+5] # string buffer pointer +define MI_SBUFLEN Memi[$1+6] # string buffer alloclen +define MI_SBUFUSED Memi[$1+7] # string buffer chars used +define MI_DBUF Memi[$1+8] # double buffer pointer +define MI_DBUFLEN Memi[$1+9] # double buffer alloclen +define MI_DBUFUSED Memi[$1+10] # double buffer doubles used +define MI_USEAXMAP Memi[$1+11] # enable axis mapping +define MI_NLOGDIM Memi[$1+12] # dimension of logical system + # (available) +define MI_LTV Memi[$1+18] # dbuf index of LT vector +define MI_LTM Memi[$1+19] # dbuf index of LT matrix +define MI_AXNO Memi[$1+20+($2)-1] # axis map, log[phys] +define MI_AXVAL Memi[$1+30+($2)-1] # axis value, if axno[i]=0 +define MI_PHYSAX Memi[$1+40+($2)-1] # inverted map, phys[log] +define MI_CTRAN Memi[$1+50+($2)-1] # ctran descriptor pointers +define MI_WCSP ($1+70+(($2)-1)*LEN_WCS) + +# WCS descriptor. This consists of a base structure, used to index string +# and double data which is stored in the global buffers SBUF and DBUF. +# An array of WCS descriptors is preallocated in the main MWCS descriptor. + +define WCS_NDIM Memi[$1] # dimension of world system +define WCS_SYSTEM Memi[$1+1] # sbuf index of system name +define WCS_AXCLASS Memi[$1+2+($2)-1] # axis type, 0 or FUNC index +define WCS_R Memi[$1+10] # dbuf index of R array +define WCS_W Memi[$1+11] # dbuf index of W array +define WCS_CD Memi[$1+12] # dbuf index of CD matrix +define WCS_NPTS Memi[$1+20+($2)-1] # number of points in wsampv +define WCS_PV Memi[$1+30+($2)-1] # wsamp physical vector +define WCS_WV Memi[$1+40+($2)-1] # wsamp world vector +define WCS_NFUNC Memi[$1+49] # number of functions +define WCS_FUNC ($1+50+(($2)-1)*5) # function descriptors +define WCS_NWATTR Memi[$1+89] # number of wcs attributes +define WCS_WATTR ($1+90+(($2)-1)*3) # pointer to wattr substruct + +# WCS function descriptor. +define LEN_WF 5 +define WF_FN Memi[$1] # function code +define WF_NAXES Memi[$1+1] # number of axes +define WF_AXIS Memi[$1+2+($2)-1] # axes function applies to + +# Function type flags. +define FORWARD 0 # forward transform (P->W) +define INVERSE 1 # inverse transform (W->P) + +# WCS attribute descriptor. +define LEN_AT 3 +define AT_AXIS Memi[$1] # wcs axis which owns attribute +define AT_NAME Memi[$1+1] # sbuf index of name string +define AT_VALUE Memi[$1+2] # sbuf index of value string + +# CTRAN descriptor. Prepared when a coordinate transformation is set up +# with mw_sctran. The transformation is optimized and reduced to a series +# of matrix multiply, translate, wcs function call etc. instructions as +# described by this descriptor. Both single and double precision versions +# of the transform are prepared, with the application deciding at runtime +# which precision routine to call. + +define LEN_CTBASE (20+MAX_CALL*LEN_FC*2) + +define CT_D ($1) # pointer to type double CT +define CT_R Memi[$1] # pointer to type real CT +define CT_MW Memi[$1+1] # pointer back to MWCS +define CT_WCSI Memi[$1+2] # pointer back to system 1 +define CT_WCSO Memi[$1+3] # pointer back to system 2 +define CT_TYPE Memi[$1+4] # ctran type (optimized) +define CT_NDIM Memi[$1+5] # ctran physical dimension +define CT_LTM Memi[$1+6] # pointer to rot matrix +define CT_LTV Memi[$1+7] # pointer to translation vector +define CT_NCALLI Memi[$1+8] # number of function calls +define CT_NCALLO Memi[$1+9] # number of function calls +define CT_AXIS Memi[$1+10+($2)-1] # maps ctran axis to physax +define CT_FCI ($1+20+(($2)-1)*LEN_FC) # pointer to CALL descriptor +define CT_FCO ($1+188+(($2)-1)*LEN_FC) + +# CT types, for optimized transforms. +define LNR 0 # linear, not rotated +define LRO 1 # linear, rotated +define GEN 2 # general catch all case + +# Base FC (WCS function call) descriptor. This consists of a base descriptor +# common to all WCS functions, followed by a private area reserved for use +# by the WCS function. + +define LEN_FC 64 +define FC_CT Memi[$1] # CTRAN descriptor +define FC_WCS Memi[$1+1] # WCS descriptor +define FC_WF Memi[$1+2] # WF descriptor +define FC_FCN Memi[$1+3] # epa of WCS function +define FC_NAXES Memi[$1+4] # number of axes in call +define FC_AXIS Memi[$1+5+($2)-1] # CTRAN axes used by FC (max 3) +define FCU 8 # offset to first user field + +# WCS function driver (stored in common). +define LEN_FN 5 # length of function driver +define FN_FLAGS fn_table[1,$1] # function type flags +define FN_INIT fn_table[2,$1] # initialize call descriptor +define FN_DESTROY fn_table[3,$1] # free call descriptor +define FN_FWD fn_table[4,$1] # forward transformation +define FN_INV fn_table[5,$1] # inverse transformation +define FN_NAME fn_names[1,$1] # function name + +# WCS function codes. +define F_LINEAR 0 # linear (not a function) + +# WCS function type bit flags. +define F_RADEC 01B # function requires RA/DEC + +# Handy macros. +define S Memc[MI_SBUF($1)+$2-1] # string = S(mw,i) +define D Memd[MI_DBUF($1)+$2-1] # double = D(mw,i) diff --git a/sys/mwcs/mwctfree.x b/sys/mwcs/mwctfree.x new file mode 100644 index 00000000..e495320b --- /dev/null +++ b/sys/mwcs/mwctfree.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "mwcs.h" + +# MW_CTFREE -- Free a CTRAN (coordinate transformation) descriptor. We keep +# track of all allocated CTRAN descriptors in the parent MWCS descriptor, and +# NULL the saved entry for a descriptor when it is freed, thus guaranteeing +# that a descriptor will be freed only once. + +procedure mw_ctfree (ct) + +pointer ct #U pointer to CTRAN descriptor + +int fn, i, j +pointer mw, fc +include "mwcs.com" + +begin + if (ct != NULL) { + mw = CT_MW(ct) + if (mw != NULL) + do i = 1, MAX_CTRAN + if (MI_CTRAN(mw,i) == ct) { + # Free private storage for any input WCS functions. + do j = 1, CT_NCALLI(ct) { + fc = CT_FCI(ct,j) + fn = WF_FN(FC_WF(fc)) + if (FN_DESTROY(fn) != NULL) + call zcall1 (FN_DESTROY(fn), fc) + } + # Free private storage for any output WCS functions. + do j = 1, CT_NCALLO(ct) { + fc = CT_FCO(ct,j) + fn = WF_FN(FC_WF(fc)) + if (FN_DESTROY(fn) != NULL) + call zcall1 (FN_DESTROY(fn), fc) + } + # Free the main CTRAN descriptor. + call mfree (ct, TY_STRUCT) + MI_CTRAN(mw,i) = NULL + break + } + } +end diff --git a/sys/mwcs/mwctran.gx b/sys/mwcs/mwctran.gx new file mode 100644 index 00000000..2d614569 --- /dev/null +++ b/sys/mwcs/mwctran.gx @@ -0,0 +1,99 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../mwcs.h" + +# MW_CTRAN -- Transform a single N-dimensional point, using the optimized +# transformation set up by a prior call to MW_SCTRAN. + +procedure mw_ctran$t (a_ct, p1, p2, ndim) + +pointer a_ct #I pointer to CTRAN descriptor +PIXEL p1[ndim] #I coordinates of point in input system +PIXEL p2[ndim] #O coordinates of point in output system +int ndim #I dimensionality of point + +int naxes, i, j +pointer ct, fc, ltm, ltv, d_ct +double v1[MAX_DIM], v2[MAX_DIM], iv[MAX_DIM], ov[MAX_DIM] +errchk zcall3 + +begin + # Get real or double version of descriptor. + ct = CT_$T(a_ct) + + ltm = CT_LTM(ct) + ltv = CT_LTV(ct) + + # Specially optimized cases. + if (CT_TYPE(ct) == LNR) { + # Simple linear, nonrotated transformation. + do i = 1, ndim + p2[i] = Mem$t[ltm+(i-1)*(ndim+1)] * p1[i] + Mem$t[ltv+i-1] + return + } else if (CT_TYPE(ct) == LRO) { + # Simple linear, rotated transformation. + call mw_ltran$t (p1, p2, Mem$t[ltm], Mem$t[ltv], ndim) + return + } + + # If we get here the transformation involves a call to one or more + # WCS functions. In this general case, the transformation consists + # of zero or more calls to WCS functions to transform the input + # world coordinates to the linear input system, followed by a general + # linear transformation to the linear output system, followed by zero + # or more calls to WCS functions to do the forward transformation + # to generate the final output world coordinates. The WCS function + # calls are always evaluated in double precision. + + # Make zero or more WCS function calls for the different axes of the + # input system (inverse transform). + + call acht$td (p1, iv, ndim) + do j = 1, CT_NCALLI(ct) { + # Get pointer to function call descriptor. + fc = CT_FCI(ct,j) + naxes = FC_NAXES(fc) + + # Extract the coordinate vector for the function call. + do i = 1, naxes + v1[i] = p1[FC_AXIS(fc,i)] + + # Call the WCS function. + call zcall3 (FC_FCN(fc), fc, v1, v2) + + # Edit the vector IV, replacing the entries associated with + # the WCS function by the transformed values. + + do i = 1, naxes + iv[FC_AXIS(fc,i)] = v2[i] + } + + # Apply the general linear transformation. We may as well do this in + # double since we already have to use double for the function calls. + + d_ct = CT_D(a_ct) + call mw_ltrand (iv, ov, Memd[CT_LTM(d_ct)], Memd[CT_LTV(d_ct)], ndim) + + # Make zero or more WCS function calls for the different axes of the + # output system (forward transform to final world system). + + call achtd$t (ov, p2, ndim) + do j = 1, CT_NCALLO(ct) { + # Get pointer to function call descriptor. + fc = CT_FCO(ct,j) + naxes = FC_NAXES(fc) + + # Extract the coordinate vector for the function call. + do i = 1, naxes + v1[i] = ov[FC_AXIS(fc,i)] + + # Call the WCS function. + call zcall3 (FC_FCN(fc), fc, v1, v2) + + # Edit the final output vector, replacing the entries for the + # function axes by their transformed values. + + do i = 1, naxes + p2[FC_AXIS(fc,i)] = v2[i] + } +end diff --git a/sys/mwcs/mwfindsys.x b/sys/mwcs/mwfindsys.x new file mode 100644 index 00000000..e997fc42 --- /dev/null +++ b/sys/mwcs/mwfindsys.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "mwcs.h" + +# MW_FINDSYS -- Lookup the named world coordinate system and return a pointer +# to the WCS descriptor, or NULL if the system is not defined. + +pointer procedure mw_findsys (mw, system) + +pointer mw #I pointer to MWCS descriptor +char system[ARB] #I system to be looked up + +int i +pointer wp +bool streq() + +begin + # Search the list of defined systems. + do i = 1, MI_NWCS(mw) { + wp = MI_WCSP(mw,i) + if (WCS_SYSTEM(wp) != NULL) + if (streq (S(mw,WCS_SYSTEM(wp)), system)) + return (wp) + } + + # Not found. + return (NULL) +end diff --git a/sys/mwcs/mwflookup.x b/sys/mwcs/mwflookup.x new file mode 100644 index 00000000..e9f28f8d --- /dev/null +++ b/sys/mwcs/mwflookup.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "mwcs.h" + +# MW_FLOOKUP -- Look up the named WCS function in the driver table, and +# return the index of the associated driver. ERR is returned if the named +# function is not found, 0 if the function is "linear", otherwise the +# index of the function driver is returned. + +int procedure mw_flookup (mw, fnname) + +pointer mw #I pointer to MWCS descriptor +char fnname[ARB] #I function to be lookup up + +int fn, i +bool streq() +include "mwcs.com" + +begin + if (streq (fnname, "linear")) + return (F_LINEAR) + + fn = ERR + do i = 1, fn_nfn + if (streq (fnname, FN_NAME(i))) { + fn = i + break + } + + return (fn) +end diff --git a/sys/mwcs/mwgaxlist.x b/sys/mwcs/mwgaxlist.x new file mode 100644 index 00000000..01b4b394 --- /dev/null +++ b/sys/mwcs/mwgaxlist.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "mwcs.h" + +# MW_GAXLIST -- Get the physical axis list. The bitflags in AXBITS define the +# axes in the logical system; run these through the axis map (if enabled) to +# get the list of physical axes for which the transformation is to be prepared. + +procedure mw_gaxlist (mw, axbits, axis, naxes) + +pointer mw #I pointer to MWCS descriptor +int axbits #I bitflag marking the desired axes +int axis[MAX_DIM] #O output axis array +int naxes #O number of axes in axis array + +int bits, ax, i +int bitupk() + +begin + bits = axbits + if (bits == 0) + bits = 177B # default to all axes + + naxes = 0 + do i = 1, MAX_DIM + if (bitupk (bits, i, 1) != 0) { + if (MI_USEAXMAP(mw) == YES) { + if (i > MI_NLOGDIM(mw)) + break + # Map logical axis to physical axis. + ax = MI_PHYSAX(mw,i) + } else { + if (i > MI_NDIM(mw)) + break + ax = i + } + + # Add physical axis to axis list. + naxes = naxes + 1 + axis[naxes] = ax + } +end diff --git a/sys/mwcs/mwgaxmap.x b/sys/mwcs/mwgaxmap.x new file mode 100644 index 00000000..b888b433 --- /dev/null +++ b/sys/mwcs/mwgaxmap.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +# MW_GAXMAP -- Get the axis map. This assigns a logical axis axno[i] to +# each physical axis I. If axno[i]=0, the value of the physical axis +# coordinate is the constant axval[i], and the dimension of the logical +# system is reduced by one. + +procedure mw_gaxmap (mw, axno, axval, ndim) + +pointer mw #I pointer to MWCS descriptor +int axno[ndim] #O physical -> logical axis assignments +int axval[ndim] #O value of physical axis if axno=0 +int ndim #I physical dimension of axis map + +int i +errchk syserrs + +begin + # Verify dimension. + if (MI_NDIM(mw) != ndim) + call syserrs (SYS_MWNDIM, "mw_gaxmap") + + # Copy out the current axis map. + do i = 1, ndim { + axno[i] = MI_AXNO(mw,i) + axval[i] = MI_AXVAL(mw,i) + } +end diff --git a/sys/mwcs/mwgctran.gx b/sys/mwcs/mwgctran.gx new file mode 100644 index 00000000..10a35179 --- /dev/null +++ b/sys/mwcs/mwgctran.gx @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../mwcs.h" + +# MW_GCTRAN -- Get a coordinate transformation compiled in a previous call +# to mw_sctran. When the transformation is compiled, it is specified by +# naming the input and output systems and the axes over which the transform +# is to be performed. Rather than return this information, which the +# application already knows, we return the actual transform, i.e., the +# linear transformation matrix and translation vector comprising the linear +# portion of the transform, and axis class arrays for the input and output +# systems defining the axis types. If the axis types are all zero, there +# are no WCS function calls for any axis in either system, and the +# transformation is completely linear (hence computable by the application +# if desired, e.g., with mw_ltr). + +int procedure mw_gctran$t (a_ct, o_ltm, o_ltv, axtype1, axtype2, maxdim) + +pointer a_ct #I pointer to CTRAN descriptor +PIXEL o_ltm[ARB] #O linear tranformation matrix +PIXEL o_ltv[ARB] #O translation matrix +int axtype1[ARB] #O axis types for input system +int axtype2[ARB] #O axis types for output system +int maxdim #I how much stuff to return + +pointer ct +int pdim, ndim, i, j + +begin + ct = CT_$T(a_ct) + pdim = CT_NDIM(ct) + ndim = min (pdim, maxdim) + + # Output the goods. + do j = 1, ndim { + axtype1[j] = WCS_AXCLASS(CT_WCSI(ct),j) + axtype2[j] = WCS_AXCLASS(CT_WCSO(ct),j) + o_ltv[j] = Mem$t[CT_LTV(ct)+(j-1)] + do i = 1, ndim + o_ltm[(j-1)*ndim+i] = Mem$t[CT_LTM(ct)+(j-1)*pdim+(i-1)] + } + + return (pdim) +end diff --git a/sys/mwcs/mwgltermd.x b/sys/mwcs/mwgltermd.x new file mode 100644 index 00000000..e2db0c0d --- /dev/null +++ b/sys/mwcs/mwgltermd.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +# MW_GLTERMD -- Get the current Lterm, double precision version. + +procedure mw_gltermd (mw, ltm, ltv, ndim) + +pointer mw #I pointer to MWCS descriptor +double ltm[ndim,ndim] #O linear transformation matrix +double ltv[ndim] #O translation vector +int ndim #I dimensionality of system + +int i +errchk syserrs + +begin + # The dimensionality of the data must match that of the current Lterm. + if (ndim != MI_NDIM(mw)) + call syserrs (SYS_MWNDIM, "mw_gltermd") + + # Copy out the data. Default to a unitary transformation if the + # Lterm has not been initialized. + + if (MI_LTM(mw) == NULL) { + call aclrd (ltm, ndim*ndim) + do i = 1, ndim + ltm[i,i] = 1.0D0 + } else + call amovd (D(mw,MI_LTM(mw)), ltm, ndim*ndim) + + if (MI_LTV(mw) == NULL) + call aclrd (ltv, ndim) + else + call amovd (D(mw,MI_LTV(mw)), ltv, ndim) +end diff --git a/sys/mwcs/mwgltermr.x b/sys/mwcs/mwgltermr.x new file mode 100644 index 00000000..290bc6dc --- /dev/null +++ b/sys/mwcs/mwgltermr.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +# MW_GLTERMR -- Get the current Lterm, single precision version. + +procedure mw_gltermr (mw, ltm, ltv, ndim) + +pointer mw #I pointer to MWCS descriptor +real ltm[ndim,ndim] #O linear transformation matrix +real ltv[ndim] #O translation vector +int ndim #I dimensionality of system + +int i +errchk syserrs + +begin + # The dimensionality of the data must match that of the current Lterm. + if (ndim != MI_NDIM(mw)) + call syserrs (SYS_MWNDIM, "mw_gltermr") + + # Copy out the data. Default to a unitary transformation if the + # Lterm has not been initialized. + + if (MI_LTM(mw) == NULL) { + call aclrr (ltm, ndim*ndim) + do i = 1, ndim + ltm[i,i] = 1.0 + } else + call achtdr (D(mw,MI_LTM(mw)), ltm, ndim*ndim) + + if (MI_LTV(mw) == NULL) + call aclrr (ltv, ndim) + else + call achtdr (D(mw,MI_LTV(mw)), ltv, ndim) +end diff --git a/sys/mwcs/mwgsys.x b/sys/mwcs/mwgsys.x new file mode 100644 index 00000000..a1559b8f --- /dev/null +++ b/sys/mwcs/mwgsys.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "mwcs.h" + +# MW_GSYSTEM -- Return the name of the current default world system. + +procedure mw_gsystem (mw, outstr, maxch) + +pointer mw #I pointer to MWCS descriptor +char outstr[ARB] #O receives name of world system +int maxch #I max chars out + +pointer wp + +begin + wp = MI_WCS(mw) + call strcpy (S(mw,WCS_SYSTEM(wp)), outstr, maxch) +end diff --git a/sys/mwcs/mwgwattrs.x b/sys/mwcs/mwgwattrs.x new file mode 100644 index 00000000..3a5fbf80 --- /dev/null +++ b/sys/mwcs/mwgwattrs.x @@ -0,0 +1,58 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +# MW_GWATTRS -- Get the string value of the named WCS attribute for axis N. +# If the attribute name is a number N, attribute number N is returned instead, +# allowing the attributes to be listed without knowing their names. + +procedure mw_gwattrs (mw, axis, attribute, valstr, maxch) + +pointer mw #I pointer to MWCS descriptor +int axis #I axis to which attribute belongs +char attribute[SZ_ATNAME] #U attribute name +char valstr[ARB] #O attribute value +int maxch #I max chars to output value string + +pointer wp, ap +int item, atno, i + +int ctoi() +bool streq() +errchk syserrs + +begin + # Get current WCS. + wp = MI_WCS(mw) + if (wp == NULL) + call syserrs (SYS_MWNOWCS, "mw_gwattrs") + + # Get attribute number if number was given. + i = 1 + if (ctoi (attribute, i, atno) == 0) + atno = 0 + + # Lookup the named or numbered attribute and output the value + # string if found. + + item = 0 + do i = 1, WCS_NWATTR(wp) { + ap = WCS_WATTR(wp,i) + if (AT_AXIS(ap) == axis) { + item = item + 1 + if (atno > 0) { + if (atno == item) { + call strcpy (S(mw,AT_NAME(ap)), attribute, SZ_ATNAME) + call strcpy (S(mw,AT_VALUE(ap)), valstr, maxch) + return + } + } else if (streq (S(mw,AT_NAME(ap)), attribute)) { + call strcpy (S(mw,AT_VALUE(ap)), valstr, maxch) + return + } + } + } + + call syserrs (SYS_MWWATTRNF, attribute) +end diff --git a/sys/mwcs/mwgwsampd.x b/sys/mwcs/mwgwsampd.x new file mode 100644 index 00000000..8149d814 --- /dev/null +++ b/sys/mwcs/mwgwsampd.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +# MW_GWSAMPD -- Get the sampled WCS curve for an axis. + +procedure mw_gwsampd (mw, axis, pv, wv, npts) + +pointer mw #I pointer to MWCS descriptor +int axis #I axis which gets the wsamp vector +double pv[ARB] #O physical coordinates of points +double wv[ARB] #O world coordinates of points +int npts #I number of data point in curve + +pointer wp +errchk syserrs +string s_name "mw_gwsampd" + +begin + # Get the current WCS. + wp = MI_WCS(mw) + if (wp == NULL) + call syserrs (SYS_MWNOWCS, s_name) + + # Verify that there is a sampled curve for this WCS. + if (WCS_NPTS(wp,axis) <= 0 || WCS_PV(wp,axis) == NULL + || WCS_WV(wp,axis) == NULL) + call syserrs (SYS_MWNOWSAMP, s_name) + + # Copy out the curves. + call amovd (D(mw,WCS_PV(wp,axis)), pv, min(WCS_NPTS(wp,axis), npts)) + call amovd (D(mw,WCS_WV(wp,axis)), wv, min(WCS_NPTS(wp,axis), npts)) +end diff --git a/sys/mwcs/mwgwsampr.x b/sys/mwcs/mwgwsampr.x new file mode 100644 index 00000000..881177e4 --- /dev/null +++ b/sys/mwcs/mwgwsampr.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +# MW_GWSAMPR -- Get the sampled WCS curve for an axis. + +procedure mw_gwsampr (mw, axis, pv, wv, npts) + +pointer mw #I pointer to MWCS descriptor +int axis #I axis which gets the wsamp vector +real pv[ARB] #O physical coordinates of points +real wv[ARB] #O world coordinates of points +int npts #I number of data point in curve + +pointer wp +errchk syserrs +string s_name "mw_gwsampr" + +begin + # Get the current WCS. + wp = MI_WCS(mw) + if (wp == NULL) + call syserrs (SYS_MWNOWCS, s_name) + + # Verify that there is a sampled curve for this WCS. + if (WCS_NPTS(wp,axis) <= 0 || WCS_PV(wp,axis) == NULL + || WCS_WV(wp,axis) == NULL) + call syserrs (SYS_MWNOWSAMP, s_name) + + # Copy out the curves. + call achtdr (D(mw,WCS_PV(wp,axis)), pv, min(WCS_NPTS(wp,axis), npts)) + call achtdr (D(mw,WCS_WV(wp,axis)), wv, min(WCS_NPTS(wp,axis), npts)) +end diff --git a/sys/mwcs/mwgwtermd.x b/sys/mwcs/mwgwtermd.x new file mode 100644 index 00000000..be6b015a --- /dev/null +++ b/sys/mwcs/mwgwtermd.x @@ -0,0 +1,49 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +# MW_GWTERMD -- Get the linear part of the Wterm, i.e., the physical and world +# coordinates of the reference point and the CD matrix. It is the Wterm of +# the current default WCS which is read. + +procedure mw_gwtermd (mw, r, w, cd, ndim) + +pointer mw #I pointer to MWCS descriptor +double r[ndim] #O physical coordinates of reference point +double w[ndim] #O world coordinates of reference point +double cd[ndim,ndim] #O CD matrix +int ndim #I dimension of Wterm + +pointer wp +errchk syserrs +string s_name "mw_gwtermd" + +begin + # Get the current WCS. + wp = MI_WCS(mw) + if (wp == NULL) + call syserrs (SYS_MWNOWCS, s_name) + + # Verify the dimension. + if (WCS_NDIM(wp) != ndim) + call syserrs (SYS_MWNDIM, s_name) + + # Copy out the data. Return the unitary transformation if the + # Wterm has not been set. + + if (WCS_R(wp) == NULL) + call aclrd (r, ndim) + else + call amovd (D(mw,WCS_R(wp)), r, ndim) + + if (WCS_W(wp) == NULL) + call aclrd (w, ndim) + else + call amovd (D(mw,WCS_W(wp)), w, ndim) + + if (WCS_CD(wp) == NULL) + call mw_mkidmd (cd, ndim) + else + call amovd (D(mw,WCS_CD(wp)), cd, ndim*ndim) +end diff --git a/sys/mwcs/mwgwtermr.x b/sys/mwcs/mwgwtermr.x new file mode 100644 index 00000000..8ee44c4c --- /dev/null +++ b/sys/mwcs/mwgwtermr.x @@ -0,0 +1,49 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +# MW_GWTERMR -- Get the linear part of the Wterm, i.e., the physical and world +# coordinates of the reference point and the CD matrix. It is the Wterm of +# the current default WCS which is read. + +procedure mw_gwtermr (mw, r, w, cd, ndim) + +pointer mw #I pointer to MWCS descriptor +real r[ndim] #O physical coordinates of reference point +real w[ndim] #O world coordinates of reference point +real cd[ndim,ndim] #O CD matrix +int ndim #I dimension of Wterm + +pointer wp +errchk syserrs +string s_name "mw_gwtermr" + +begin + # Get the current WCS. + wp = MI_WCS(mw) + if (wp == NULL) + call syserrs (SYS_MWNOWCS, s_name) + + # Verify the dimension. + if (WCS_NDIM(wp) != ndim) + call syserrs (SYS_MWNDIM, s_name) + + # Copy out the data. Return the unitary transformation of the + # Wterm has not been set. + + if (WCS_R(wp) == NULL) + call aclrr (r, ndim) + else + call achtdr (D(mw,WCS_R(wp)), r, ndim) + + if (WCS_W(wp) == NULL) + call aclrr (w, ndim) + else + call achtdr (D(mw,WCS_W(wp)), w, ndim) + + if (WCS_CD(wp) == NULL) + call mw_mkidmr (cd, ndim) + else + call achtdr (D(mw,WCS_CD(wp)), cd, ndim*ndim) +end diff --git a/sys/mwcs/mwinvertd.x b/sys/mwcs/mwinvertd.x new file mode 100644 index 00000000..e2744821 --- /dev/null +++ b/sys/mwcs/mwinvertd.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# MW_INVERTD -- Invert a square matrix, double precision version. The matrix +# need not be symmetric. The input and output matrices cannot be the same. + +procedure mw_invertd (o_ltm, n_ltm, ndim) + +double o_ltm[ndim,ndim] #I input matrix +double n_ltm[ndim,ndim] #O output (inverted) matrix +int ndim #I dimensionality of system + +pointer sp, ix, ltm +int nelem, i, j + +begin + call smark (sp) + + nelem = ndim * ndim + call salloc (ix, ndim, TY_INT) + call salloc (ltm, nelem, TY_DOUBLE) + + # Make scratch copy (to be modified) of input matrix. + call amovd (o_ltm, Memd[ltm], nelem) + + # Set up identity matrix. + do i = 1, ndim { + do j = 1, ndim + n_ltm[i,j] = 0.0 + n_ltm[i,i] = 1.0 + } + + # Perform the LU decomposition. + call mw_ludecompose (Memd[ltm], Memi[ix], ndim) + + # Compute the inverse matrix by backsubstitution. + do j = 1, ndim + call mw_lubacksub (Memd[ltm], Memi[ix], n_ltm[1,j], ndim) + + call sfree (sp) +end diff --git a/sys/mwcs/mwinvertr.x b/sys/mwcs/mwinvertr.x new file mode 100644 index 00000000..28274754 --- /dev/null +++ b/sys/mwcs/mwinvertr.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# MW_INVERTR -- Invert a square matrix, single precision version. The matrix +# need not be symmetric. The input and output matrices should not be the same. + +procedure mw_invertr (o_ltm, n_ltm, ndim) + +real o_ltm[ndim,ndim] #I input matrix +real n_ltm[ndim,ndim] #O output (inverted) matrix +int ndim #I dimensionality of system + +int nelem, i, j +pointer sp, ix, ltm, inv + +begin + call smark (sp) + + nelem = ndim * ndim + call salloc (ix, ndim, TY_INT) + call salloc (ltm, nelem, TY_DOUBLE) + call salloc (inv, nelem, TY_DOUBLE) + + # Make scratch copy (to be modified) of input matrix. + call achtrd (o_ltm, Memd[ltm], nelem) + + # Set up identity matrix. + call aclrd (Memd[inv], nelem) + do i = 1, ndim + Memd[inv+(i-1)*ndim+i-1] = 1.0 + + # Perform the LU decomposition. + call mw_ludecompose (Memd[ltm], Memi[ix], ndim) + + # Compute the inverse matrix by backsubstitution. + do j = 1, ndim + call mw_lubacksub (Memd[ltm], Memi[ix], Memd[inv+(j-1)*ndim], ndim) + + # Output the inverted matrix. + call achtdr (Memd[inv], n_ltm, nelem) + + call sfree (sp) +end diff --git a/sys/mwcs/mwload.x b/sys/mwcs/mwload.x new file mode 100644 index 00000000..993ba48b --- /dev/null +++ b/sys/mwcs/mwload.x @@ -0,0 +1,124 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "mwcs.h" +include "mwsv.h" + +# MW_LOAD -- Load a saved MWCS into a descriptor. The saved MWCS will +# have been created in a previous call to MW_SAVE. In its saved form, +# the MWCS is a machine independent binary array of arbitrary length. + +procedure mw_load (mw, bp) + +pointer mw #I pointer to MWCS descriptor +pointer bp #I pointer to save buffer, type char + +pointer sp, sv, ct, ip, cw, ms, wp +int nelem, cwlen, mslen, nwcs, lenwcs, n, i +errchk syserrs, malloc +pointer coerce() +int pl_l2pi() + +begin + call smark (sp) + call salloc (sv, LEN_SVHDR, TY_STRUCT) + + # Get the save header. + ip = coerce (bp, TY_CHAR, TY_STRUCT) + call miiupk32 (Memi[ip], Memi[sv], LEN_SVHDR, TY_INT) + if (SV_MAGIC(sv) != MWSV_MAGIC) + call syserrs (SYS_MWMAGIC, "MWCS save file") + + cwlen = SV_CWCSLEN(sv) + mslen = SV_MWSVLEN(sv) + + # Prior to MWSV version 1 lenwcs and nwcs were not recorded. + if (SV_VERSION(sv) < 1) { + lenwcs = MWSV_LENWCS0 + nwcs = (mslen - MWSV_BASELEN) / lenwcs + } else { + lenwcs = SV_LENWCS(sv) + nwcs = SV_NWCS(sv) + } + + call salloc (cw, cwlen, TY_INT) + call salloc (ms, mslen, TY_INT) + + # Unpack the saved MWSV descriptor. Due to a bug in MWCS prior to + # V2.10.4 IRAF the packed descriptor was erroneously encoded using + # miipak32, so if unpacking with miiupk16 doesn't work try using + # miiupk32. This should allow old saved MWCS written on a similar + # architecture to still be read - the data is not portable however + # unless miipak16 is used, since pl_p2li produces a short array. + + ip = coerce (bp + SV_MWSVOFF(sv), TY_CHAR, TY_STRUCT) + call miiupk16 (Memi[ip], Memi[cw], SV_CWCSLEN(sv), TY_SHORT) + n = pl_l2pi (Memi[cw], 1, Memi[ms], mslen) + if (MI_MAGIC(ms) != MWCS_MAGIC) { + call miiupk32 (Memi[ip], Memi[cw], SV_CWCSLEN(sv), TY_INT) + n = pl_l2pi (Memi[cw], 1, Memi[ms], mslen) + } + + # Free any storage associated with the old descriptor. + # Start with any still allocated CTRAN descriptors. + + do i = 1, MAX_CTRAN { + ct = MI_CTRAN(mw,i) + if (ct != NULL) + iferr (call mw_ctfree (ct)) + call erract (EA_WARN) + } + + # Free the old string and data buffers. + if (MI_SBUF(mw) != NULL) + call mfree (MI_SBUF(mw), TY_CHAR) + if (MI_DBUF(mw) != NULL) + call mfree (MI_DBUF(mw), TY_DOUBLE) + + # Copy the MWSV descriptor to the active MWCS descriptor. This + # assumes that the base descriptor and the WCS sub-descriptor have + # identical structures, except for the length of each element. + + call amovi (Memi[ms], Memi[mw], LEN_BASEMWCS) + nelem = min (lenwcs, LEN_WCS) + do i = 1, nwcs { + wp = MI_WCSP(mw,i) + call amovi (Memi[MS_WCSP(ms,i,lenwcs)], Memi[wp], nelem) + if (nelem < LEN_WCS) + call aclri (Memi[wp+nelem], LEN_WCS-nelem) + } + do i = nwcs+1, MAX_WCS + call aclri (Memi[MI_WCSP(mw,i)], LEN_WCS) + + # Initialize the axis map (not preserved over a save/load). + do i = 1, MI_NDIM(mw) { + MI_AXNO(mw,i) = i + MI_PHYSAX(mw,i) = i + } + + # Load the data buffer. + nelem = SV_DBUFLEN(sv) + if (nelem > 0) { + ip = coerce (bp + SV_DBUFOFF(sv), TY_CHAR, TY_DOUBLE) + call malloc (MI_DBUF(mw), nelem, TY_DOUBLE) + call miiupkd (Memd[ip], D(mw,1), nelem, TY_DOUBLE) + MI_DBUFUSED(mw) = nelem + MI_DBUFLEN(mw) = nelem + } + + # Load the string buffer. + nelem = SV_SBUFLEN(sv) + if (nelem > 0) { + ip = coerce (bp + SV_SBUFOFF(sv), TY_CHAR, TY_CHAR) + call malloc (MI_SBUF(mw), nelem, TY_CHAR) + call miiupk8 (Memc[ip], S(mw,1), nelem, TY_CHAR) + MI_SBUFUSED(mw) = nelem + MI_SBUFLEN(mw) = nelem + } + + # Set the default WCS. + call mw_sdefwcs (mw) + call sfree (sp) +end diff --git a/sys/mwcs/mwloadim.x b/sys/mwcs/mwloadim.x new file mode 100644 index 00000000..231f5b9a --- /dev/null +++ b/sys/mwcs/mwloadim.x @@ -0,0 +1,198 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "mwcs.h" +include "imwcs.h" + +# MW_LOADIM -- Load a MWCS object saved in an image header in FITS format +# into an MWCS descriptor. Note that the MWCS descriptor is allocated +# if the input is NULL. This is to allow the WCS cards to be read to +# determine the WCS dimensionality. + +procedure mw_loadim (mw, im) + +pointer mw #U pointer to MWCS descriptor +pointer im #I pointer to image header + +bool have_wcs +int ndim, i, j, ea_type +int axno[MAX_DIM], axval[MAX_DIM] +double maxval +pointer sp, sysname, iw, ct, wp, cp, bufp, ip + +int mw_allocd(), mw_refstr(), ctoi(), envgeti() +pointer iw_rfits(), iw_findcard(), iw_gbigfits(), mw_open() +errchk iw_rfits, mw_allocd, mw_newsystem, mw_swtype, iw_enterwcs, mw_saxmap +errchk mw_open +string s_physical "physical" +define axerr_ 91 +define axinit_ 92 + +begin + call smark (sp) + call salloc (sysname, SZ_FNAME, TY_CHAR) + + # Read the FITS image header into an IMWCS descriptor. + iw = iw_rfits (mw, im, RF_REFERENCE) + if (mw == NULL) { + ndim = max (IW_NDIM(iw), IM_NPHYSDIM(im)) + mw = mw_open (NULL, ndim) + } + ndim = IW_NDIM(iw) + + # Initialize the MWCS descriptor from the IMWCS descriptor. + # Free any storage associated with the old descriptor. + # Start with any still allocated CTRAN descriptors. + + do i = 1, MAX_CTRAN { + ct = MI_CTRAN(mw,i) + if (ct != NULL) + iferr (call mw_ctfree (ct)) + call erract (EA_WARN) + } + + # Free the old string and data buffers. + if (MI_SBUF(mw) != NULL) + call mfree (MI_SBUF(mw), TY_CHAR) + if (MI_DBUF(mw) != NULL) + call mfree (MI_DBUF(mw), TY_DOUBLE) + + # Initialize the new descriptor. + call aclri (Memi[mw], LEN_MWCS) + + MI_MAGIC(mw) = MWCS_MAGIC + MI_REFIM(mw) = im + MI_NDIM(mw) = ndim + MI_LTV(mw) = mw_allocd (mw, ndim) + MI_LTM(mw) = mw_allocd (mw, ndim * ndim) + + # Set the Lterm. Set axes with no LTM scales to unit scales. + # Issue a warning by default but use "wcs_matrix_err" to allow + # setting other error actions. + + call amovd (IW_LTV(iw,1), D(mw,MI_LTV(mw)), ndim) + if (iw_findcard (iw, TY_LTM, ERR, 0) != NULL) { + do i = 1, ndim { + maxval = 0D0 + do j = 1, ndim { + D(mw,MI_LTM(mw)+(j-1)*ndim+(i-1)) = IW_LTM(iw,i,j) + maxval = max (maxval, abs (IW_LTM(iw,i,j))) + } + if (maxval == 0D0) { + iferr (ea_type = envgeti ("wcs_matrix_err")) + ea_type = EA_WARN + iferr { + switch (ea_type) { + case EA_FATAL, EA_ERROR: + call sprintf (Memc[sysname], SZ_FNAME, + "LTM keywords for axis %d undefined") + call pargi (i) + call error (SYS_MWMISSAX, Memc[sysname]) + case EA_WARN: + IW_LTM(iw,i,i) = 1D0 + D(mw,MI_LTM(mw)+(i-1)*ndim+(i-1)) = IW_LTM(iw,i,i) + call sprintf (Memc[sysname], SZ_FNAME, + "setting LTM%d_%d to %.4g") + call pargi (i) + call pargi (i) + call pargd (IW_LTM(iw,i,i)) + call error (SYS_MWMISSAX, Memc[sysname]) + default: + IW_LTM(iw,i,i) = 1D0 + D(mw,MI_LTM(mw)+(i-1)*ndim+(i-1)) = IW_LTM(iw,i,i) + } + } then + call erract (ea_type) + } + } + } else + call mw_mkidmd (D(mw,MI_LTM(mw)), ndim) + + # Set up the builtin world systems "physical" and "logical". + # Both are linear systems. The physical system is a unitary + # transformation (since world systems are defined relative to + # the physical system), and the logical system has the Lterm + # for its linear term. No wcs attributes other than wtype are + # defined. + + # Create the physical system. + call mw_newsystem (mw, s_physical, ndim) + do i = 1, ndim + call mw_swtype (mw, i, 1, "linear", "") + + # Create the logical system. + call mw_newsystem (mw, "logical", ndim) + do i = 1, ndim + call mw_swtype (mw, i, 1, "linear", "") + + # Set W and CD for the logical system to point to the Lterm. + wp = MI_WCS(mw) + WCS_W(wp) = MI_LTV(mw) + WCS_CD(wp) = MI_LTM(mw) + + # Did the image header specify a WCS? + have_wcs = false + do i = 1, IW_NCARDS(iw) { + cp = IW_CARD(iw,i) + switch (C_TYPE(cp)) { + case TY_CTYPE, TY_CRPIX, TY_CRVAL, TY_CD, TY_CDELT: + have_wcs = true + break + } + } + + # Enter the saved WCS. We make up a system name for now, and patch + # it up later once the real name has been recalled along with the + # attributes. + + if (have_wcs) { + call mw_newsystem (mw, "image", ndim) + call iw_enterwcs (mw, iw, ndim) + ifnoerr { + call mw_gwattrs (mw, 0, "system", Memc[sysname], SZ_FNAME) + } then + WCS_SYSTEM(MI_WCS(mw)) = mw_refstr (mw, Memc[sysname]) + } + + # Restore the saved WCS axis map if any. + if (iw_findcard (iw, TY_WAXMAP, ERR, 0) != NULL) { + bufp = iw_gbigfits (iw, TY_WAXMAP, ERR) + + ip = bufp + do i = 1, ndim { + if (ctoi (Memc, ip, axno[i]) <= 0) + goto axerr_ + if (ctoi (Memc, ip, axval[i]) <= 0) { +axerr_ call eprintf ("Image %s: cannot decode WAXMAP\n") + call pargstr (IM_NAME(IW_IM(iw))) + goto axinit_ + } + } + + call mfree (bufp, TY_CHAR) + call mw_saxmap (mw, axno, axval, ndim) + + } else { +axinit_ do i = 1, ndim { + MI_AXNO(mw,i) = i + MI_AXVAL(mw,i) = 0 + } + MI_USEAXMAP(mw) = NO + MI_NLOGDIM(mw) = ndim + } + + # Apply the section transform, if the image was opened with an image + # section. This edits the axis map restored above, if any, and must + # be done after restoring the original WCS axis map. + + call iw_setaxmap (mw, im) + + # Set the default world system. + call mw_sdefwcs (mw) + + call iw_cfits (iw) + call sfree (sp) +end diff --git a/sys/mwcs/mwltran.gx b/sys/mwcs/mwltran.gx new file mode 100644 index 00000000..d7b823b6 --- /dev/null +++ b/sys/mwcs/mwltran.gx @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../mwcs.h" + +# MW_LTRAN -- Perform a general N-dimensional linear transformation, i.e., +# matrix multiply and translation. + +procedure mw_ltran$t (p1, p2, ltm, ltv, ndim) + +PIXEL p1[ndim] #I input point +PIXEL p2[ndim] #O transformed output point +PIXEL ltm[ndim,ndim] #I linear transformation matrix +PIXEL ltv[ndim] #I linear translation vector +int ndim #I dimension of system + +int i, j +PIXEL p3[MAX_DIM] + +begin + call amov$t (p1, p3, ndim) + do j = 1, ndim { + p2[j] = ltv[j] + do i = 1, ndim + p2[j] = p2[j] + ltm[i,j] * p3[i] + } +end diff --git a/sys/mwcs/mwlu.x b/sys/mwcs/mwlu.x new file mode 100644 index 00000000..f6a606f1 --- /dev/null +++ b/sys/mwcs/mwlu.x @@ -0,0 +1,143 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MULU -- Matrix utilities for MWCS. +# +# mw_ludecompose performs LU decomposition of a square matrix +# mw_lubacksub performs backsubstitution to solve a system +# +# These routines are derived from routines in the book Numerical Recipes, +# Press et. al. 1986. + + +# MW_LUDECOMPOSE -- Replace an NxN matrix A by the LU decomposition of a +# rowwise permutation of the matrix. The LU decomposed matrix A and the +# permutation index IX are output. The decomposition is performed in place. + +procedure mw_ludecompose (a, ix, ndim) + +double a[ndim,ndim] #U matrix to be inverted; inverted matrix +int ix[ndim] #O vector describing row permutation +int ndim #I dimension of square matrix + +pointer sp, vv +int d, i, j, k, imax +double aamax, sum, dum + +begin + call smark (sp) + call salloc (vv, ndim, TY_DOUBLE) + + # Keep track of the number of row interchanges, odd or even (not used). + d = 1 + + # Loop over rows to get implicit scaling information. + do i = 1, ndim { + aamax = 0.0 + do j = 1, ndim + if (abs(a[i,j]) > aamax) + aamax = abs(a[i,j]) + if (aamax == 0.0) + call error (1, "singular matrix") + Memd[vv+i-1] = 1.0 / aamax + } + + # Loop over columns using Crout's method. + do j = 1, ndim { + do i = 1, j-1 { + sum = a[i,j] + do k = 1, i-1 + sum = sum - a[i,k] * a[k,j] + a[i,j] = sum + } + + # Search for the largest pivot element. + aamax = 0.0 + do i = j, ndim { + sum = a[i,j] + do k = 1, j-1 + sum = sum - a[i,k] * a[k,j] + a[i,j] = sum + + # Figure of merit for the pivot. + dum = Memd[vv+i-1] * abs(sum) + if (dum >= aamax) { + imax = i + aamax = dum + } + } + + # Do we need to interchange rows? + if (j != imax) { + # Yes, do so... + do k = 1, ndim { + dum = a[imax,k] + a[imax,k] = a[j,k] + a[j,k] = dum + } + d = -d + Memd[vv+imax-1] = Memd[vv+j-1] + } + + ix[j] = imax + if (a[j,j] == 0.0) + a[j,j] = EPSILOND + + # Divide by the pivot element. + if (j != ndim) { + dum = 1.0 / a[j,j] + do i = j+1, ndim + a[i,j] = a[i,j] * dum + } + } + + call sfree (sp) +end + + +# MW_LUBACKSUB -- Solves the set of N linear equations A*X=B. Here A is input, +# not as the matrix A but rather as its LU decomposition, determined by the +# routine mw_ludecompose. IX is input as the permutation vector as returned by +# mw_ludecompose. B is input as the right hand side vector B, and returns with +# the solution vector X. + +procedure mw_lubacksub (a, ix, b, ndim) + +double a[ndim,ndim] #I LU decomposition of the matrix A +int ix[ndim] #I permutation vector for A +double b[ndim] #U rhs vector; solution vector +int ndim #I dimension of system + +int ii, ll, i, j +double sum + +begin + # Do the forward substitution, unscrambling the permutation as we + # go. When II is set to a positive value, it will become the index + # of the first nonvanishing element of B. + + ii = 0 + do i = 1, ndim { + ll = ix[i] + sum = b[ll] + b[ll] = b[i] + + if (ii != 0) { + do j = ii, i-1 + sum = sum - a[i,j] * b[j] + } else if (sum != 0) + ii = i + + b[i] = sum + } + + # Now do the backsubstitution. + do i = ndim, 1, -1 { + sum = b[i] + if (i < ndim) + do j = i+1, ndim + sum = sum - a[i,j] * b[j] + b[i] = sum / a[i,i] + } +end diff --git a/sys/mwcs/mwmkidmd.x b/sys/mwcs/mwmkidmd.x new file mode 100644 index 00000000..acdbb077 --- /dev/null +++ b/sys/mwcs/mwmkidmd.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# MW_MKIDMD -- Make the identity matrix. + +procedure mw_mkidmd (ltm, ndim) + +double ltm[ndim,ndim] #O set to the identity matrix +int ndim #I dimension of (square) matrix + +int i, j + +begin + do j = 1, ndim { + do i = 1, ndim + ltm[i,j] = 0.0 + ltm[j,j] = 1.0 + } +end diff --git a/sys/mwcs/mwmkidmr.x b/sys/mwcs/mwmkidmr.x new file mode 100644 index 00000000..f4771217 --- /dev/null +++ b/sys/mwcs/mwmkidmr.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# MW_MKIDMR -- Make the identity matrix. + +procedure mw_mkidmr (ltm, ndim) + +real ltm[ndim,ndim] #O set to the identity matrix +int ndim #I dimension of (square) matrix + +int i, j + +begin + do j = 1, ndim { + do i = 1, ndim + ltm[i,j] = 0.0 + ltm[j,j] = 1.0 + } +end diff --git a/sys/mwcs/mwmmul.gx b/sys/mwcs/mwmmul.gx new file mode 100644 index 00000000..b86449c2 --- /dev/null +++ b/sys/mwcs/mwmmul.gx @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# MW_MMUL -- Matrix multiply. + +procedure mw_mmul$t (a, b, c, ndim) + +PIXEL a[ndim,ndim] #I left input matrix +PIXEL b[ndim,ndim] #I right input matrix +PIXEL c[ndim,ndim] #O output matrix +int ndim #I dimensionality of system + +int i, j, k +PIXEL v + +begin + do j = 1, ndim + do i = 1, ndim { + v = 0 + do k = 1, ndim + v = v + a[k,j] * b[i,k] + c[i,j] = v + } +end diff --git a/sys/mwcs/mwnewcopy.x b/sys/mwcs/mwnewcopy.x new file mode 100644 index 00000000..cdc7907b --- /dev/null +++ b/sys/mwcs/mwnewcopy.x @@ -0,0 +1,129 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "mwcs.h" + +# MW_NEWCOPY -- Copy a MWCS. The copy is done by constructing a new MWCS +# from the objects stored in the first one, freeing any dead storage in the +# process. + +pointer procedure mw_newcopy (o_mw) + +pointer o_mw #I pointer to old MWCS descriptor + +int ndim, nelem, i, j +pointer mw, wp, o_wp, at, o_at + +bool streq() +int mw_copys(), mw_copyd() +errchk calloc, mw_copys, mw_copyd + +begin + # Make a copy of the main descriptor. + call malloc (mw, LEN_MWCS, TY_STRUCT) + call amovi (Memi[o_mw], Memi[mw], LEN_MWCS) + + # We have to allocate our own string and data buffers. + MI_SBUF(mw) = NULL + MI_SBUFLEN(mw) = 0 + MI_SBUFUSED(mw) = 0 + MI_DBUF(mw) = NULL + MI_DBUFLEN(mw) = 0 + MI_DBUFUSED(mw) = 0 + + # Copy the Lterm data. + ndim = MI_NDIM(mw) + nelem = ndim * ndim + MI_LTV(mw) = mw_copyd (mw, o_mw, MI_LTV(o_mw), ndim) + MI_LTM(mw) = mw_copyd (mw, o_mw, MI_LTM(o_mw), nelem) + + # We don't inherit open CTRAN descriptors. + call aclri (MI_CTRAN(mw,1), MAX_CTRAN) + + # Copy the WCS. + do i = 1, MI_NWCS(o_mw) { + wp = MI_WCSP(mw,i) + o_wp = MI_WCSP(o_mw,i) + ndim = WCS_NDIM(wp) + nelem = ndim * ndim + + # Copy the WCS data. + WCS_R(wp) = mw_copyd (mw, o_mw, WCS_R(o_wp), ndim) + WCS_W(wp) = mw_copyd (mw, o_mw, WCS_W(o_wp), ndim) + WCS_CD(wp) = mw_copyd (mw, o_mw, WCS_CD(o_wp), nelem) + + # Each axis can have its own sampled WCS. + do j = 1, ndim { + WCS_PV(wp,j) = + mw_copyd (mw, o_mw, WCS_PV(o_wp,j), WCS_NPTS(o_wp,j)) + WCS_WV(wp,j) = + mw_copyd (mw, o_mw, WCS_WV(o_wp,j), WCS_NPTS(o_wp,j)) + } + + # Copy the WCS attributes. + do j = 1, WCS_NWATTR(o_wp) { + at = WCS_WATTR(wp,j) + o_at = WCS_WATTR(o_wp,j) + AT_NAME(at) = mw_copys (mw, o_mw, AT_NAME(o_at)) + AT_VALUE(at) = mw_copys (mw, o_mw, AT_VALUE(o_at)) + if (streq (S(mw,AT_NAME(at)), "system")) + WCS_SYSTEM(wp) = AT_VALUE(at) + } + + # Preserve the default WCS. + if (MI_WCS(o_mw) == o_wp) + MI_WCS(mw) = wp + } + + return (mw) +end + + +# MW_COPYD -- Copy a block of type double data from one MWCS to another. +# If the buffer offset in the old system is NULL, there was no data, and +# a null offset is output. + +int procedure mw_copyd (mw, o_mw, o_off, nelem) + +pointer mw #I pointer to output MWCS +pointer o_mw #I pointer to input (old) MWCS +int o_off #I buffer offset in old MWCS +int nelem #I number of type double data elements + +int off +int mw_allocd() +errchk mw_allocd + +begin + if (o_off == NULL) + off = NULL + else { + off = mw_allocd (mw, nelem) + call amovd (D(o_mw,o_off), D(mw,off), nelem) + } + + return (off) +end + + +# MW_COPYS -- Copy an EOS delimited string from one MWCS to another. +# If the buffer offset in the old system is NULL, there is no data, and +# a null offset is output. + +int procedure mw_copys (mw, o_mw, o_off) + +pointer mw #I pointer to output MWCS +pointer o_mw #I pointer to input (old) MWCS +int o_off #I buffer offset in old MWCS + +int off +int mw_refstr() +errchk mw_refstr + +begin + if (o_off == NULL) + off = NULL + else + off = mw_refstr (mw, S(o_mw,o_off)) + + return (off) +end diff --git a/sys/mwcs/mwnewsys.x b/sys/mwcs/mwnewsys.x new file mode 100644 index 00000000..e7d1e117 --- /dev/null +++ b/sys/mwcs/mwnewsys.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +# MW_NEWSYSTEM -- Add a new world coordinate system with the given name +# and dimensionality to the MWCS. Make the new system the current system, +# since a number of WCS initialization calls will (should) surely follow. + +procedure mw_newsystem (mw, system, ndim) + +pointer mw #I pointer to MWCS descriptor +char system[ARB] #I system name +int ndim #I system dimensionality + +pointer wp +int mw_refstr() +pointer mw_findsys() +errchk syserrs, mw_refstr + +begin + # Check that the system does not already exist. + if (mw_findsys (mw, system) != NULL) + call syserrs (SYS_MWWCSREDEF, system) + + # Add the new system. + if (MI_NWCS(mw) + 1 > MAX_WCS) + call syserrs (SYS_MWMAXWCS, system) + MI_NWCS(mw) = MI_NWCS(mw) + 1 + wp = MI_WCSP(mw,MI_NWCS(mw)) + + # Initialize the WCS. + WCS_NDIM(wp) = ndim + + # Make the new WCS the default WCS. + MI_WCS(mw) = wp + + # The system name is stored as a global (axis=0) attribute of the WCS. + call mw_swattrs (mw, 0, "system", system) + WCS_SYSTEM(wp) = mw_refstr (mw, system) +end diff --git a/sys/mwcs/mwopen.x b/sys/mwcs/mwopen.x new file mode 100644 index 00000000..7841f904 --- /dev/null +++ b/sys/mwcs/mwopen.x @@ -0,0 +1,81 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "mwcs.h" + +# MW_OPEN -- Create a new MWCS descriptor. If the non-NULL address of a +# buffer containing a saved MWCS is given, the saved MWCS will be loaded, +# otherwise a unitary MWCS of the indicated dimension is created. + +pointer procedure mw_open (bufptr, ndim) + +pointer bufptr #I pointer to encoded MWCS, or NULL +int ndim #I dimension of system to be created + +int i +pointer mw, wp +int mw_allocd() +errchk calloc, mw_load, syserrs, mw_allocd +string s_physical "physical" + +begin + # Initialize the function drivers. + call wf_init() + + # Allocate the base descriptor. + call calloc (mw, LEN_MWCS, TY_STRUCT) + + # Load saved MWCS, if one was given. + if (bufptr != NULL) { + call mw_load (mw, bufptr) + return (mw) + } + + # Initialize the new descriptor to a unitary transform of dimension + # NDIM. Most of this is accomplished by merely creating a zeroed + # descriptor. + + if (ndim < 1 || ndim > MAX_DIM) { + call mfree (mw, TY_STRUCT) + call syserrs (SYS_MWNDIM, "mw_open") + } + + MI_MAGIC(mw) = MWCS_MAGIC + MI_NDIM(mw) = ndim + MI_NLOGDIM(mw) = ndim + MI_LTV(mw) = mw_allocd (mw, ndim) + MI_LTM(mw) = mw_allocd (mw, ndim * ndim) + call mw_mkidmd (D(mw,MI_LTM(mw)), ndim) + do i = 1, ndim { + MI_AXNO(mw,i) = i + MI_PHYSAX(mw,i) = i + } + + # Set up the builtin world systems "physical" and "logical". + # Both are linear systems. The physical system is a unitary + # transformation (since world systems are defined relative to + # the physical system), and the logical system has the Lterm + # for its linear term. No wcs attributes other than wtype are + # defined. + + # Create the physical system. + call mw_newsystem (mw, s_physical, ndim) + do i = 1, ndim + call mw_swtype (mw, i, 1, "linear", "") + + # Create the logical system. + call mw_newsystem (mw, "logical", ndim) + do i = 1, ndim + call mw_swtype (mw, i, 1, "linear", "") + + # Set W and CD for the logical system to point to the Lterm. + wp = MI_WCS(mw) + WCS_W(wp) = MI_LTV(mw) + WCS_CD(wp) = MI_LTM(mw) + + # Set the default world system. + call mw_sdefwcs (mw) + + return (mw) +end diff --git a/sys/mwcs/mwopenim.x b/sys/mwcs/mwopenim.x new file mode 100644 index 00000000..f4e86180 --- /dev/null +++ b/sys/mwcs/mwopenim.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# MW_OPENIM -- Open an MWCS descriptor on an image, loading the descriptor +# from the image if there is one. The MWCS descriptor is allocated after +# the WCS cards are read in mw_loadim so that the WCS dimensionality can +# be determined when the image header is dataless. + +pointer procedure mw_openim (im) + +pointer im #I pointer to image descriptor + +pointer mw + +begin + mw = NULL + call mw_loadim (mw, im) + return (mw) +end diff --git a/sys/mwcs/mwrefstr.x b/sys/mwcs/mwrefstr.x new file mode 100644 index 00000000..07385976 --- /dev/null +++ b/sys/mwcs/mwrefstr.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "mwcs.h" + +# MW_REFSTR -- Search the string buffer for the named string and return the +# string offset if found, otherwise enter the new string and return its +# offset. This is used to avoid storing the same string many times, but +# use of this technique means that string data cannot be modified once +# entered. + +int procedure mw_refstr (mw, str) + +pointer mw #I pointer to MWCS descriptor +char str[ARB] #I string to be referenced or entered + +bool match +pointer sbuf, btop, ip +int nchars, off, ch, i +int strlen(), mw_allocs() +errchk mw_allocs + +begin + sbuf = MI_SBUF(mw) + btop = sbuf + MI_SBUFLEN(mw) + nchars = strlen (str) + + # Search the string buffer for the given string. + match = false + if (sbuf != NULL) + for (ip=sbuf; !match && ip < btop; ) { + match = true + do i = 1, btop-ip { + ch = Memc[ip+i-1] + if (i <= nchars) + if (ch != str[i]) + match = false + if (ch == EOS) { + if (!match) + ip = ip + i + break + } + } + if (ch != EOS) + break + } + + # Add the string if not found. + if (!match) { + off = mw_allocs (mw, nchars) + call strcpy (str, S(mw,off), nchars) + } else + off = ip - sbuf + 1 + + return (off) +end diff --git a/sys/mwcs/mwrotate.x b/sys/mwcs/mwrotate.x new file mode 100644 index 00000000..27972659 --- /dev/null +++ b/sys/mwcs/mwrotate.x @@ -0,0 +1,71 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +define LTM Memd[ltm+(($2)-1)*pdim+($1)-1] + +# MW_ROTATE -- Front end to mw_translate, used to perform simple rotations +# of the logical system by specifying the rotation angle in degrees, and the +# center of rotation. Since only one rotation angle can be specified, this +# routine is useful only for 2-dim rotations (between any two axes). Note +# that the transformation is performed in double precision even though the +# rotation angle and center are specified in single precision, preserving +# the full internal precision of the Lterm. + +procedure mw_rotate (mw, theta, center, axbits) + +pointer mw #I pointer to MWCS descriptor +real theta #I rotation angle, degrees +real center[ARB] #I center of rotation +int axbits #I bitflags defining axes to be rotated + +double d_theta +pointer sp, ltm, ltv_1, ltv_2 +int axis[MAX_DIM], naxes, ax1, ax2, axmap, pdim, nelem +errchk syserr + +begin + # Convert axis bitflags to axis list. + call mw_gaxlist (mw, axbits, axis, naxes) + if (naxes != 2) + call syserr (SYS_MWROT2AX) + + pdim = MI_NDIM(mw) + nelem = pdim * pdim + axmap = MI_USEAXMAP(mw) + MI_USEAXMAP(mw) = NO + d_theta = theta + ax1 = axis[1] + ax2 = axis[2] + + call smark (sp) + call salloc (ltm, nelem, TY_DOUBLE) + call salloc (ltv_1, pdim, TY_DOUBLE) + call salloc (ltv_2, pdim, TY_DOUBLE) + + # Initialize the translation matrix and vectors. + call mw_mkidmd (Memd[ltm], pdim) + call aclrd (Memd[ltv_1], pdim) + call aclrd (Memd[ltv_2], pdim) + + # Set up a 2-dim rotation between the specified axes. + LTM(ax1,ax1) = cos(d_theta) + LTM(ax2,ax1) = sin(d_theta) + LTM(ax1,ax2) = -sin(d_theta) + LTM(ax2,ax2) = cos(d_theta) + + # Set the rotation center. + Memd[ltv_1+ax1-1] = center[1] + Memd[ltv_1+ax2-1] = center[2] + + # Set the back translation vector. + Memd[ltv_2+ax1-1] = center[1] + Memd[ltv_2+ax2-1] = center[2] + + # Perform the translation. + call mw_translated (mw, Memd[ltv_1], Memd[ltm], Memd[ltv_2], pdim) + + MI_USEAXMAP(mw) = axmap + call sfree (sp) +end diff --git a/sys/mwcs/mwsave.x b/sys/mwcs/mwsave.x new file mode 100644 index 00000000..22b92212 --- /dev/null +++ b/sys/mwcs/mwsave.x @@ -0,0 +1,90 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" +include "mwsv.h" + +# MW_SAVE -- Save the contents of a MWCS descriptor, i.e., the MWCS object, +# in a machine independent binary array. This may be stored in a file or +# database, passed through a network interface, etc., and later reopened +# on a descriptor with MW_LOAD or MW_OPEN. + +int procedure mw_save (o_mw, bp, buflen) + +pointer o_mw #I pointer to MWCS descriptor +pointer bp #U pointer to save buffer of type char +int buflen #U allocated length of save buffer + +int nchars, olen +pointer mw, sp, sv, op, oo +errchk coerce, realloc, mw_newcopy +pointer coerce(), mw_newcopy() +int pl_p2li() + +begin + call smark (sp) + call salloc (sv, LEN_SVHDR, TY_STRUCT) + + # We save a new copy of the MWCS, rather than the MWCS itself, + # to discard any dead storage and to cause the runtime descriptor + # pointers to be set to NULL. + + mw = mw_newcopy (o_mw) + + # Clear runtime fields that cannot be meaningfully saved. + MI_WCS(mw) = NULL + MI_REFIM(mw) = NULL + call aclri (MI_AXNO(mw,1), MAX_DIM) + call aclri (MI_AXVAL(mw,1), MAX_DIM) + call aclri (MI_PHYSAX(mw,1), MAX_DIM) + + # Compress the main header to save space. + call salloc (oo, MI_LEN(mw) * 3 + 32, TY_SHORT) + olen = pl_p2li (Memi[mw], 1, Mems[oo], MI_LEN(mw)) + + # Determine how much space will be needed. + nchars = LEN_SVHDR * SZ_STRUCT + olen * SZ_SHORT + + (MI_DBUFUSED(mw) + 1) * SZ_DOUBLE + + (MI_SBUFUSED(mw) + SZB_CHAR-1) / SZB_CHAR + + # Get the space. + if (nchars > buflen) { + call realloc (bp, nchars, TY_CHAR) + buflen = nchars + } + + # Prepare the save header. + call aclri (Memi[sv], LEN_SVHDR) + + SV_MAGIC(sv) = MWSV_MAGIC + SV_CWCSLEN(sv) = olen + SV_MWSVLEN(sv) = MI_LEN(mw) + SV_DBUFLEN(sv) = MI_DBUFUSED(mw) + SV_SBUFLEN(sv) = MI_SBUFUSED(mw) + SV_MWSVOFF(sv) = LEN_SVHDR * SZ_STRUCT + SV_DBUFOFF(sv) = (SV_MWSVOFF(sv) + olen * SZ_SHORT + SZ_DOUBLE-1) / + SZ_DOUBLE * SZ_DOUBLE + SV_SBUFOFF(sv) = SV_DBUFOFF(sv) + MI_DBUFUSED(mw) * SZ_DOUBLE + SV_VERSION(sv) = MWSV_VERSION + SV_NWCS(sv) = MI_NWCS(mw) + SV_LENWCS(sv) = LEN_WCS + + # Output the save header. + op = coerce (bp, TY_CHAR, TY_STRUCT) + call miipak32 (Memi[sv], Memi[op], LEN_SVHDR, TY_INT) + + # Store the three segments of the MWCS, i.e., the main descriptor + # and the data and string buffers. + + op = coerce (bp + SV_MWSVOFF(sv), TY_CHAR, TY_SHORT) + call miipak16 (Mems[oo], Mems[op], olen, TY_SHORT) + op = coerce (bp + SV_DBUFOFF(sv), TY_CHAR, TY_DOUBLE) + call miipakd (D(mw,1), Memd[op], SV_DBUFLEN(sv), TY_DOUBLE) + op = coerce (bp + SV_SBUFOFF(sv), TY_CHAR, TY_CHAR) + call miipak8 (S(mw,1), Memc[op], SV_SBUFLEN(sv), TY_CHAR) + + call mw_close (mw) + call sfree (sp) + + return (nchars) +end diff --git a/sys/mwcs/mwsaveim.x b/sys/mwcs/mwsaveim.x new file mode 100644 index 00000000..a74ef99a --- /dev/null +++ b/sys/mwcs/mwsaveim.x @@ -0,0 +1,394 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "imwcs.h" +include "mwcs.h" + +# MW_SAVEIM -- Save the current MWCS in an image header in FITS format. +# This is only possible to some degree. Although the Lterm is always saved, +# only one world system can be saved. FITS convention requires that the +# FITS wcs represent the transformation from image (logical) coordinates +# to world coordinates, whereas the MWCS Wterm represents the physical to +# world transformation, so what we save is actually a combination of the +# Wterm and Lterm; combining the two is only possible if there are no +# rotations between dissimilar axes. Sampled WCS vectors and WCS attributes +# can be saved, although this can be inefficient for large vectors and can +# result in header overflow, and there can be problems preserving the +# precision of double precision data since the FITS representation is ASCII. +# Since the WCS is represented by a variable set of cards, we must be careful +# to delete any old WCS cards which are not updated by the save operation. + +procedure mw_saveim (mw, im) + +pointer mw #I pointer to MWCS descriptor +pointer im #I pointer to image descriptor + +double cdelt +char label[SZ_VALSTR] +bool update, output_cdelt +char kwname[SZ_KWNAME], ctype[SZ_KWNAME], axtype[4] +int ndim, axis, fn, ira, idec, i, j, pv, wv, npts, fd +pointer sp, iw, wp, wf, vp, cp, at, o_r, n_r, o_cd, n_cd, ltm +int op + +bool streq(), fp_equald() +pointer iw_rfits(), iw_findcard() +int strncmp(), strlen(), open(), nowhite(), stridxs() +errchk iw_rfits, mw_ssystem, iw_putarray, iw_putstr, open +include "mwcs.com" +define ewcs_ 91 + +begin + # Scan the old image header, recording all WCS cards. + iw = iw_rfits (mw, im, RF_COPY) + + # Save the WCS dimension (not necessarily same as that of the image). + ndim = MI_NDIM(mw) + cp = iw_findcard (iw, TY_WCSDIM, -1, 0) + if (cp == NULL || IW_NDIM(iw) != ndim) { + call strcpy ("WCSDIM", kwname, SZ_KWNAME) + if (cp == NULL) + call imaddf (im, kwname, "i") + call imputi (im, kwname, ndim) + } + if (cp != NULL) + C_UPDATED(cp) = YES + + call smark (sp) + call salloc (o_r, ndim, TY_DOUBLE) + call salloc (n_r, ndim, TY_DOUBLE) + call salloc (o_cd, ndim*ndim, TY_DOUBLE) + call salloc (n_cd, ndim*ndim, TY_DOUBLE) + call salloc (ltm, ndim*ndim, TY_DOUBLE) + + # Get pointer to the world system to be saved. Currently only one + # such system can be saved since the image header is FITS based and + # FITS doesn't support multiple world coordinate systems. The system + # to be saved can be set by calling MW_SSYSTEM before doing the + # mw_saveim. + + wp = MI_WCS(mw) + + # Do we need to save any WCS information at all? + if (MI_NWCS(mw) <= 2) + goto ewcs_ + + # Store the current WCS in the image header. This is optimized to + # use the knowledge of the current header contents obtained by + # iw_rfits above, to determine if each header card needs to be + # modified in the header, or added to the header. If the card + # already exists with the correct value nothing is done. + + # Output CTYPEi for each axis. + do axis = 1, ndim { + + # Get the new value of CTYPEi. + if (WCS_AXCLASS(wp,axis) == F_LINEAR) { + # For the default case of a linear axis, set CTYPEi to the + # value of the axis label, if there is one and it is a simple + # keyword but not one of the CTYPE keywords reserved by MWCS. + + call strcpy ("LINEAR ", ctype, SZ_KWNAME) + ifnoerr { + call mw_gwattrs (mw, axis, "label", label, SZ_VALSTR) + } then { + call strupr (label) + if (nowhite (label, label, SZ_VALSTR) <= SZ_KWNAME) { + if (strncmp (label, "SAMPLED", 8) != 0 && + strncmp (label, "RA--", 4) != 0 && + strncmp (label, "DEC-", 4) != 0 && + strncmp (label[2], "LON", 3) != 0 && + strncmp (label[2], "LAT", 3) != 0) { + + call sprintf (ctype, SZ_KWNAME, "%-8s%9t") + call pargstr (label) + } + } + } + + } else { + wf = WCS_FUNC(wp,WCS_AXCLASS(wp,axis)) + fn = WF_FN(wf) + + if (and (FN_FLAGS(fn), F_RADEC) != 0) { + # Determine the axis type. + ira = 0 + idec = 0 + axtype[1] = EOS + do i = 1, 2 { + ifnoerr (call mw_gwattrs (mw, + WF_AXIS(wf,i), "axtype", axtype, 4)) { + call strlwr (axtype) + if (streq (axtype, "ra") || + streq (axtype[2], "lon")) { + ira = i + idec = 3 - i + break + } else if (streq (axtype, "dec") || + streq (axtype[2], "lat")) { + ira = 3 - i + idec = i + break + } + } + } + + # RA and DEC had better be flagged, but if not, assume + # that the first axis is RA and the second DEC. + + if (ira == 0) + ira = 1 + if (idec == 0) + idec = 2 + + # Make a name like "RA---TAN". + if (WF_AXIS(wf,idec) == axis) { + if (streq (axtype, "ra") || streq (axtype, "dec")) { + call strcpy ("DEC-----", ctype, SZ_KWNAME) + } else if (streq (axtype[2], "lon") || + streq (axtype[2], "lat")) { + call sprintf (ctype, SZ_KWNAME, "%cLAT----") + call pargc (axtype[1]) + } else { + call strcpy ("DEC-----", ctype, SZ_KWNAME) + } + } else { + if (streq (axtype, "ra") || streq (axtype, "dec")) { + call strcpy ("RA------", ctype, SZ_KWNAME) + } else if (streq (axtype[2], "lon") || + streq (axtype[2], "lat")) { + call sprintf (ctype, SZ_KWNAME, "%cLON----") + call pargc (axtype[1]) + } else { + call strcpy ("RA------", ctype, SZ_KWNAME) + } + } + + op = max (1, SZ_KWNAME - strlen (FN_NAME(fn)) + 1) + call strcpy (FN_NAME(fn), ctype[op], SZ_KWNAME-op+1) + call strupr (ctype) + + } else { + # Just output the WCS function name as CTYPE. + call strcpy (" ", ctype, SZ_KWNAME) + call strcpy (FN_NAME(fn), ctype, SZ_KWNAME) + call strupr (ctype) + } + } + + # Update the header value if there is any change. + update = true + vp = IW_CTYPE(iw,axis) + if (vp != NULL) + update = (strncmp (Memc[vp], ctype, SZ_KWNAME) != 0) + + cp = iw_findcard (iw, TY_CTYPE, axis, 0) + if (update) { + call sprintf (kwname, SZ_KWNAME, "CTYPE%d") + call pargi (axis) + if (cp == NULL) + call imaddf (im, kwname, "c") + call impstr (im, kwname, ctype) + } + if (cp != NULL) + C_UPDATED(cp) = YES + } + + # FITS requires that the WCS specify the transformation from raw + # image (logical) coordinates to world coordinates, whereas the + # MWCS Wterm specifies the transformation from physical coordinates + # to world coordinates. Hence, we must modify CD and CRPIX (R) + # to specify the transformation from logical to world coordinates. + + # Get the MWCS R vector. + if (WCS_R(wp) != NULL) + call amovd (D(mw,WCS_R(wp)), Memd[o_r], ndim) + else + call aclrd (Memd[o_r], ndim) + + # Get the MWCS CD matrix. + if (WCS_CD(wp) != NULL) + call amovd (D(mw,WCS_CD(wp)), Memd[o_cd], ndim*ndim) + else + call mw_mkidmd (Memd[o_cd], ndim) + + # Output CRVAL (this is unaffected by the Lterm). + if (WCS_W(wp) != NULL) + call iw_putarray (iw, D(mw,WCS_W(wp)), IW_CRVAL(iw,1), ndim, + "CRVAL%d", TY_CRVAL, 0) + + # Output CRPIX = R' = (LTM * R + LTV). + call mw_vmuld (D(mw,MI_LTM(mw)), Memd[o_r], Memd[n_r], ndim) + call aaddd (D(mw,MI_LTV(mw)), Memd[n_r], Memd[n_r], ndim) + call iw_putarray (iw, Memd[n_r], IW_CRPIX(iw,1), ndim, + "CRPIX%d", TY_CRPIX, 0) + + # Output the CD matrix = CD' = (CD * inv(LTM)). If the system + # dimensionality is 2 or less and there is no rotation, output + # the CDELT notation in addition to the CD matrix to enhance + # compatibility with older programs. + + call mw_invertd (D(mw,MI_LTM(mw)), Memd[ltm], ndim) + call mw_mmuld (Memd[o_cd], Memd[ltm], Memd[n_cd], ndim) + + # Output CDELT1/CDELT2 if the image dimension is 2 or less and the + # CD matrix is a diagonal matrix (no rotational or skew terms). + + output_cdelt = false + if (ndim == 1) + output_cdelt = true + else if (ndim == 2) { + output_cdelt = (fp_equald(Memd[n_cd+1],0.0D0) && + fp_equald(Memd[n_cd+2],0.0D0)) + } + + if (output_cdelt) { + do j = 1, ndim { + cdelt = Memd[n_cd+(j-1)*(ndim+1)] + cp = iw_findcard (iw, TY_CDELT, j, 0) + if (cp == NULL || !fp_equald(IW_CDELT(iw,j),cdelt)) { + call sprintf (kwname, SZ_KWNAME, "CDELT%d") + call pargi (j) + if (cp == NULL) + call imaddf (im, kwname, "d") + call imputd (im, kwname, cdelt) + } + if (cp != NULL) + C_UPDATED(cp) = YES + } + } + + # Update the CD matrix. + do j = 1, ndim { + call sprintf (kwname, SZ_KWNAME, "CD%d_%%d") + call pargi (j) + call iw_putarray (iw, Memd[n_cd+(j-1)*ndim], + IW_CD(iw,1,j), ndim, kwname, TY_CD, j) + } + + # Output the Lterm. +ewcs_ + # Output LTV. + if (MI_LTV(mw) != NULL) + call iw_putarray (iw, D(mw,MI_LTV(mw)), IW_LTV(iw,1), ndim, + "LTV%d", TY_LTV, 0) + + # Output LTM. + if (MI_LTM(mw) != NULL) { + do j = 1, ndim { + call sprintf (kwname, SZ_KWNAME, "LTM%%d_%d") + call pargi (j) + call iw_putarray (iw, D(mw,MI_LTM(mw)+(j-1)*ndim), + IW_LTM(iw,1,j), ndim, kwname, TY_LTM, j) + } + } + + # Output axis map if any. + if (MI_USEAXMAP(mw) == YES) { + fd = open ("WAXMAP", READ_WRITE, SPOOL_FILE) + axis = ERR + + do i = 1, ndim { + call fprintf (fd, "%d %d ") + call pargi (MI_AXNO(mw,i)) + call pargi (MI_AXVAL(mw,i)) + } + + # Output successive WAXMAPj FITS cards. + call seek (fd, BOFL) + call iw_putstr (fd, iw, axis, TY_WAXMAP, "WAXMAP%02d", "", 0) + call close (fd) + } + + # Output any WCS attributes. + do axis = 0, ndim { + fd = open ("WAT", READ_WRITE, SPOOL_FILE) + npts = 0 + + # Dump the attribute=value assignments for this axis into a single + # large string buffer, using a spool file. + + do i = 1, WCS_NWATTR(wp) { + at = WCS_WATTR(wp,i) + if (AT_AXIS(at) != axis) + next + + if (npts > 0) + call putline (fd, " ") + call putline (fd, S(mw,AT_NAME(at))) + if (stridxs (" \t", S(mw,(AT_VALUE(at)))) > 0) { + call putline (fd, " = \"") + call putline (fd, S(mw,AT_VALUE(at))) + call putline (fd, "\"") + } else { + call putline (fd, "=") + call putline (fd, S(mw,AT_VALUE(at))) + } + + npts = npts + 1 + } + + # Output successive WATi_jjj FITS cards. + call seek (fd, BOFL) + if (npts > 0) + call iw_putstr (fd, iw, axis, TY_WATDATA, "WAT%d_%03d", + "WAT%d%04d", 999) + call close (fd) + } + + # Update any sampled WCS in the header. + do axis = 1, ndim { + npts = WCS_NPTS(wp,axis) + if (npts == 0) + next + + # Update the LEN card. + cp = iw_findcard (iw, TY_WSVLEN, axis, 0) + if (IW_WSVLEN(iw,axis) != npts) { + call sprintf (kwname, SZ_KWNAME, "WSV%d_LEN") + call pargi (axis) + if (cp == NULL) + call imaddf (im, kwname, "i") + call imputi (im, kwname, npts) + } + if (cp != NULL) + C_UPDATED(cp) = YES + + pv = WCS_PV(wp,axis) + wv = WCS_WV(wp,axis) + + # Dump the entire array into an ASCII spool file as successive + # points [PV,WV]. + + fd = open ("WSV", READ_WRITE, SPOOL_FILE) + do i = 1, npts { + call fprintf (fd, "%0.*g %0.*g ") + call pargi (NDIGITS_DP); call pargd (D(mw,pv+i-1)) + call pargi (NDIGITS_DP); call pargd (D(mw,wv+i-1)) + } + + # Output successive WSVi_jjj FITS cards. + call seek (fd, BOFL) + call iw_putstr (fd, iw, axis, TY_WSVDATA, "WSV%d_%03d", + "WSV%d%04d", 999) + call close (fd) + } + + # Delete any old WCS cards which were not updated, and hence which + # are no longer valid, or which are not needed because the value is + # the default (in which case the old card is probably invalid). + + do i = 1, IW_NCARDS(iw) { + cp = IW_CARD(iw,i) + if (C_UPDATED(cp) == NO) { + call strcpy (Memc[C_RP(cp)], kwname, SZ_KWNAME) + if (nowhite (kwname, kwname, SZ_KWNAME) > 0) + call imdelf (im, kwname) + } + } + + call iw_cfits (iw) + call sfree (sp) +end diff --git a/sys/mwcs/mwsaxmap.x b/sys/mwcs/mwsaxmap.x new file mode 100644 index 00000000..3070969b --- /dev/null +++ b/sys/mwcs/mwsaxmap.x @@ -0,0 +1,52 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +# MW_SAXMAP -- Set the axis map. This assigns a logical axis axno[i] to +# each physical axis I. If axno[i]=0, the value of the physical axis +# coordinate is the constant axval[i], and the dimension of the logical +# system is reduced by one. Setting the axis map automatically enables +# axis mapping if a nonstandard map is entered. + +procedure mw_saxmap (mw, axno, axval, ndim) + +pointer mw #I pointer to MWCS descriptor +int axno[ndim] #I physical -> logical axis assignments +int axval[ndim] #I value of physical axis if axno=0 +int ndim #I physical dimension of axis map + +int i, j +errchk syserrs, syserr + +begin + # Verify dimension. + if (MI_NDIM(mw) != ndim) + call syserrs (SYS_MWNDIM, "mw_saxmap") + + # Store the arrays, and determine the dimension of the logical system. + # Enable axis mapping if an interesting map has been entered. + + MI_NLOGDIM(mw) = 0 + MI_USEAXMAP(mw) = NO + + do i = 1, ndim { + MI_AXNO(mw,i) = axno[i] + MI_AXVAL(mw,i) = axval[i] + if (axno[i] > 0) + MI_NLOGDIM(mw) = MI_NLOGDIM(mw) + 1 + if (axno[i] != i) + MI_USEAXMAP(mw) = YES + } + + # Invert the axis map to facilitate logical->physical mappings. + do j = 1, MI_NLOGDIM(mw) { + for (i=1; i <= ndim; i=i+1) + if (axno[i] == j) { + MI_PHYSAX(mw,j) = i + break + } + if (i > ndim) + call syserr (SYS_MWINVAXMAP) + } +end diff --git a/sys/mwcs/mwscale.x b/sys/mwcs/mwscale.x new file mode 100644 index 00000000..2ae7167a --- /dev/null +++ b/sys/mwcs/mwscale.x @@ -0,0 +1,49 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "mwcs.h" + +# MW_SCALE -- Front end to mw_translate, used to perform a simple rescaling +# of the logical system. + +procedure mw_scale (mw, scale, axbits) + +pointer mw #I pointer to MWCS descriptor +real scale[ARB] #I scale factor for each axis in axbits +int axbits #I bitflags defining axes + +pointer sp, ltm, ltv_1, ltv_2 +int axis[MAX_DIM], naxes, pdim, nelem, axmap, i, j + +begin + # Convert axis bitflags to axis list. + call mw_gaxlist (mw, axbits, axis, naxes) + if (naxes <= 0) + return + + pdim = MI_NDIM(mw) + nelem = pdim * pdim + axmap = MI_USEAXMAP(mw) + MI_USEAXMAP(mw) = NO + + call smark (sp) + call salloc (ltm, nelem, TY_DOUBLE) + call salloc (ltv_1, pdim, TY_DOUBLE) + call salloc (ltv_2, pdim, TY_DOUBLE) + + # Initialize the translation matrix and vectors. + call mw_mkidmd (Memd[ltm], pdim) + call aclrd (Memd[ltv_1], pdim) + call aclrd (Memd[ltv_2], pdim) + + # Enter the axis scale factors. + do i = 1, naxes { + j = axis[i] - 1 + Memd[ltm+j*pdim+j] = scale[i] + } + + # Perform the translation. + call mw_translated (mw, Memd[ltv_1], Memd[ltm], Memd[ltv_2], pdim) + + MI_USEAXMAP(mw) = axmap + call sfree (sp) +end diff --git a/sys/mwcs/mwsctran.x b/sys/mwcs/mwsctran.x new file mode 100644 index 00000000..c529bc80 --- /dev/null +++ b/sys/mwcs/mwsctran.x @@ -0,0 +1,410 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "mwcs.h" + +# MW_SCTRAN -- Set up a coordinate transformation (CTRAN) descriptor. +# The general idea is to reduce the coordinate transformation to as simple +# a form as possible for efficient evaluation at runtime. Most of the +# complexities of the actual coordinate system, e.g., axis mapping, multiple +# WCS, separate linear and world terms, forward and inverse transforms, etc., +# can be dealt with at CTRAN compile time. The result is a CTRAN descriptor +# for an N-d coordinate defining an N-d linear transformation and zero or +# more calls to WCS functions for individual axes, where N can be anything +# less than or equal to the dimensionality of the full system. +# +# A transformation may be set up between any two coordinate systems +# SYSTEM1 and SYSTEM2. The dimensionality of the transformation, and the +# axes to which it applies, is determined by the axis bitflags in AXBITS. +# A pointer to the optimized transformation descriptor is returned as the +# function value. An arbitrary number of transformation descriptors may be +# simultaneously open (a limit of 16 or so is imposed by the main MWCS +# descriptor). A CTRAN descriptor reflects the state of the WCS *at the +# time that the descriptor was compiled*, i.e., subsequent changes to +# the MWCS descriptor do not affect any compiled transformation descriptors. +# CTRAN descriptors not subsequently closed by CTFREE are automatically +# closed when the main MWCS descriptor is closed. + +pointer procedure mw_sctran (mw, system1, system2, axbits) + +pointer mw #I pointer to MWCS descriptor +char system1[ARB] #I input coordinate system +char system2[ARB] #I output coordinate system +int axbits #I bitmap defining axes to be transformed + +bool newfunc +int naxes, axis[MAX_DIM], wfno, fn, epa +int i, j, k , matlen, ndata, ctlen, pdim +pointer i_ltm, i_ltv, o_ltm, o_ltv, t_ltm, t_ltv, ltm, ltv +pointer sp, w1, w2, ct, wf, fc, lp, ip, op, ct_r, sv_wcs + +pointer coerce() +errchk syserr, syserrs, calloc, zcall2, mw_invertd, mw_ssystem +include "mwcs.com" + +begin + call smark (sp) + + # Get pointers to the input and output systems. + sv_wcs = MI_WCS(mw) + iferr { + call mw_ssystem (mw, system1) + w1 = MI_WCS(mw) + call mw_ssystem (mw, system2) + w2 = MI_WCS(mw) + } then { + MI_WCS(mw) = sv_wcs + call erract (EA_ERROR) + } else + MI_WCS(mw) = sv_wcs + + # Get the physical axis list. The bitflags in AXBITS define the axes + # in the logical system; run these through the axis map (if enabled) + # to get the list of physical axes for which the transformation is to + # be prepared. + + call mw_gaxlist (mw, axbits, axis, naxes) + + # Allocate the CTRAN descriptor. First we must figure out how + # much space is required. The space required is for the base + # descriptor, plus additional space for the LTM and LTV, which vary + # in size depending upon the dimensionality of the transformation. + # The whole thing is then doubled to provide 2 versions of the + # descriptor, providing both single and double precision versions + # of the LTM and LTV. Any additional storage utilized by the WCS + # functions is separately allocated by the initialization routines + # in the function drivers. + + matlen = naxes * naxes + ndata = matlen + naxes + ctlen = LEN_CTBASE + ndata * SZ_DOUBLE / SZ_STRUCT + call calloc (ct, ctlen*2, TY_STRUCT) + + # Save a pointer to the CTRAN descriptor in the main MWCS descriptor, + # to permit automatic deallocation at close time. + + do i = 1, MAX_CTRAN+1 { + if (i > MAX_CTRAN) { + call mfree (ct, TY_STRUCT) + call syserr (SYS_MWCTOVFL) + } + + if (MI_CTRAN(mw,i) == NULL) { + MI_CTRAN(mw,i) = ct + break + } + } + + CT_MW(ct) = mw + CT_WCSI(ct) = w1 + CT_WCSO(ct) = w2 + CT_NDIM(ct) = naxes + CT_R(ct) = ct + ctlen + call amovi (axis, CT_AXIS(ct,1), naxes) + CT_LTM(ct) = coerce (ct + LEN_CTBASE, TY_STRUCT, TY_DOUBLE) + CT_LTV(ct) = CT_LTM(ct) + matlen + + ltm = CT_LTM(ct) + ltv = CT_LTV(ct) + + # We also need some full-system matrix and vector buffers. + pdim = min (WCS_NDIM(w1), WCS_NDIM(w2)) + pdim = min (MI_NDIM(mw), pdim) + + i = pdim * pdim + call salloc (i_ltm, i, TY_DOUBLE) + call salloc (i_ltv, pdim, TY_DOUBLE) + call salloc (o_ltm, i, TY_DOUBLE) + call salloc (o_ltv, pdim, TY_DOUBLE) + call salloc (t_ltm, i, TY_DOUBLE) + call salloc (t_ltv, pdim, TY_DOUBLE) + + # Compute the transformation. A transformation between any two + # world systems W1 and W2 consists of the transformation W1->P + # from W1 to the physical system, followed by a transformation + # P->W2 to the second world system. The linear portions of these + # two transformations can be combined to produce a single linear + # transformation, and if no WCS function calls are involved at + # either end, the entire transformation reduces to a single linear + # transformation defined by LTM and LTV. Note that as far as we + # are concerned here, the special world systems "logical" and + # "physical" are just like other world systems, except that both are + # always linear systems. The linear term for the logical system is + # the MWCS Lterm; for the physical system it is the identity matrix. + + # Set up the transformation W1->P. First we must determine if there + # are any WCS function calls. We do this by going ahead and compiling + # the "in" function calls in the CTRAN descriptor. + + do i = 1, naxes { + wfno = WCS_AXCLASS(w1,axis[i]) + + # Skip to next axis if no WCS function is assigned to this axis. + if (wfno == 0) + next + + # Has function call for this axis already been compiled? + newfunc = true + do j = 1, CT_NCALLI(ct) { + fc = CT_FCI(ct,j) + do k = 1, FC_NAXES(fc) + if (FC_AXIS(fc,k) == i) + newfunc = false + } + + # Compile a function call for the inverse transformation. + if (newfunc) { + CT_NCALLI(ct) = CT_NCALLI(ct) + 1 + if (CT_NCALLI(ct) > MAX_CALL) + call syserrs (SYS_MWFCOVFL, system1) + + fc = CT_FCI(ct,CT_NCALLI(ct)) + wf = WCS_FUNC(w1,wfno) + fn = WF_FN(wf) + + FC_CT(fc) = ct + FC_WCS(fc) = w1 + FC_WF(fc) = wf + FC_FCN(fc) = FN_INV(fn) + FC_NAXES(fc) = WF_NAXES(wf) + + # Store CTRAN-relative list of axes in function call + # descriptor. Verify that all the axes needed for the + # function call are included in the transformation. + # This requirement can theoretically be relaxed in + # some cases but this is not supported in MWCS. + + do j = 1, WF_NAXES(wf) { + for (k=1; k <= naxes; k=k+1) + if (axis[k] == WF_AXIS(wf,j)) { + FC_AXIS(fc,j) = k + break + } + if (k > naxes) + call syserrs (SYS_MWMISSAX, system1) + } + + # Call the function driver to perform any driver dependent + # initialization. + + epa = FN_INIT(fn) + if (epa != NULL) + call zcall2 (epa, fc, INVERSE) + } + } + + # Prepare the linear part of the input transformation W1->P. + # This is LTM=inv(CD), and for axis I, LTV[i]=(R[i]-inv(CD)*W) + # if no function call, or LTV[i]=R[i] if there is a function + # assigned to axis I which already deals with the W[i]. All + # this is done in the full dimension of the internal system for + # now; extraction of the portion of the full system affecting + # the CTRAN axes is done later to permit verification of the + # legality of the reduction step required. + + # Invert CD matrix. + if (WCS_CD(w1) == NULL) + call mw_mkidmd (Memd[i_ltm], pdim) + else + call mw_invertd (D(mw,WCS_CD(w1)), Memd[i_ltm], pdim) + + # If no function calls for an axis and W is set, LTV=(R-inv(CD)*W). + if (WCS_W(w1) != NULL) { + call amovd (D(mw,WCS_W(w1)), Memd[i_ltv], pdim) + do i = 1, CT_NCALLI(ct) { + fc = CT_FCI(ct,i) + do j = 1, FC_NAXES(fc) { + k = axis[FC_AXIS(fc,j)] + Memd[i_ltv+k-1] = 0.0d0 + } + } + call mw_vmuld (Memd[i_ltm], Memd[i_ltv], Memd[t_ltv], pdim) + + # Copy R to LTV. + if (WCS_R(w1) == NULL) + call anegd (Memd[t_ltv], Memd[i_ltv], pdim) + else + call asubd (D(mw,WCS_R(w1)), Memd[t_ltv], Memd[i_ltv], pdim) + + } else { + # Copy R to LTV. + if (WCS_R(w1) == NULL) + call aclrd (Memd[i_ltv], pdim) + else + call amovd (D(mw,WCS_R(w1)), Memd[i_ltv], pdim) + } + + # Now prepare the output side of the transformation, from P->W2. + # Like the input half, this consists of a linear term and a list + # of zero or more function calls. + + # Compile the "out" function calls in the CTRAN descriptor. + do i = 1, naxes { + wfno = WCS_AXCLASS(w2,axis[i]) + + # Skip to next axis if no WCS function is assigned to this axis. + if (wfno == 0) + next + + # Has function call for this axis already been compiled? + newfunc = true + do j = 1, CT_NCALLO(ct) { + fc = CT_FCO(ct,j) + do k = 1, FC_NAXES(fc) + if (FC_AXIS(fc,k) == i) + newfunc = false + } + + # Compile a function call for the forward transformation. + if (newfunc) { + CT_NCALLO(ct) = CT_NCALLO(ct) + 1 + if (CT_NCALLO(ct) > MAX_CALL) + call syserrs (SYS_MWFCOVFL, system2) + + fc = CT_FCO(ct,CT_NCALLO(ct)) + wf = WCS_FUNC(w2,wfno) + fn = WF_FN(wf) + + FC_CT(fc) = ct + FC_WCS(fc) = w2 + FC_WF(fc) = wf + FC_FCN(fc) = FN_FWD(fn) + FC_NAXES(fc) = WF_NAXES(wf) + + # Store CTRAN-relative list of axes in function call + # descriptor. Verify that all the axes needed for the + # function call are included in the transformation. + + do j = 1, WF_NAXES(wf) { + for (k=1; k <= naxes; k=k+1) + if (axis[k] == WF_AXIS(wf,j)) { + FC_AXIS(fc,j) = k + break + } + if (k > naxes) + call syserrs (SYS_MWMISSAX, system2) + } + + # Call the function driver to perform any driver dependent + # initialization. + + epa = FN_INIT(fn) + if (epa != NULL) + call zcall2 (epa, fc, FORWARD) + } + } + + # Prepare the linear part of the input transformation P->W2. + # This is LTM=CD, and for axis I, LTV[i]=(W-CD*R) if no function + # call, or LTV[i]=(-CD*R) if there is a function assigned to axis + # I which already deals with the W[i]. + + # Copy CD matrix to LTM. + if (WCS_CD(w2) == NULL) + call mw_mkidmd (Memd[o_ltm], pdim) + else + call amovd (D(mw,WCS_CD(w2)), Memd[o_ltm], pdim*pdim) + + # Copy -R to t_ltv. + if (WCS_R(w2) == NULL) + call aclrd (Memd[t_ltv], pdim) + else + call amulkd (D(mw,WCS_R(w2)), -1.0D0, Memd[t_ltv], pdim) + + # Compute -CD*R in LTV. + call mw_vmuld (Memd[o_ltm], Memd[t_ltv], Memd[o_ltv], pdim) + + # If no function calls for an axis and W is set, LTV=(W-CD*R). + if (WCS_W(w2) != NULL) { + call amovd (D(mw,WCS_W(w2)), Memd[t_ltv], pdim) + call aaddd (Memd[t_ltv], Memd[o_ltv], Memd[o_ltv], pdim) + do i = 1, CT_NCALLO(ct) { + fc = CT_FCO(ct,i) + do j = 1, FC_NAXES(fc) { + k = axis[FC_AXIS(fc,j)] # undo +W[k] + lp = o_ltv + k - 1 + Memd[lp] = Memd[lp] - Memd[t_ltv+k-1] + } + } + } + + # Now combine the linear terms of the input and output transformations + # to produce the linear portion of the full transformation. + + call mw_mmuld (Memd[o_ltm], Memd[i_ltm], Memd[t_ltm], pdim) + call mw_vmuld (Memd[o_ltm], Memd[i_ltv], Memd[t_ltv], pdim) + call aaddd (Memd[o_ltv], Memd[t_ltv], Memd[t_ltv], pdim) + + # Extract the rows of the full linear transformation which are used + # for the axes involved in the transformation we are compiling. + # In the process we must examine the off-diagonal elements of the + # matrix to verify that the system does not include any dependencies + # upon axes other than those included in the transformation we are + # compiling. (This restriction prohibits dimensional reduction via + # an image section which results in loss of a rotated axis). + + do i = 1, naxes { + # Get matrix line pointers for axis[i]. + ip = t_ltm + (axis[i]-1) * pdim + op = ltm + (i-1) * naxes + + do j = 1, pdim { + # Is column J used by transform? + for (k=1; k <= naxes; k=k+1) + if (axis[k] == j) + break + + # If column J is not used in the transform but is not zero, + # then transform I is dependent upon physical axis J and + # we cannot do the transform. If column J is used in the + # transform, copy the value to the final output matrix LTM + # discarding unused columns as we go. + + if (k > naxes) { + # Check for dependency on axis outside transform. + if (abs(Memd[ip+j-1]) > EPSILOND*100.0D0) + call syserr (SYS_MWROTDEP) + } else { + # Add matrix element to final LTM. + Memd[op+k-1] = Memd[ip+j-1] + } + } + + # Copy the LTV vector element. + Memd[ltv+i-1] = Memd[t_ltv+axis[i]-1] + } + + # Determine the transformation type. This is LNR for a purely + # linear transformation with no rotational (off-diagonal) terms, + # LRO for a purely linear transform with rotational terms, and + # GEN for everything else. + + if (CT_NCALLI(ct) > 0 || CT_NCALLO(ct) > 0) + CT_TYPE(ct) = GEN + else { + CT_TYPE(ct) = LNR + do j = 1, naxes + do i = 1, naxes + if (i != j) { + lp = ltm + (j-1)*naxes + i-1 + if (abs(Memd[lp]) > EPSILOND*100.0D0) { + CT_TYPE(ct) = LRO + break + } + } + } + + # Prepare the single precision part of the transform. + call amovi (Memi[CT_D(ct)], Memi[CT_R(ct)], ctlen) + + ct_r = CT_R(ct) + CT_LTM(ct_r) = coerce (ct_r + LEN_CTBASE, TY_STRUCT, TY_REAL) + CT_LTV(ct_r) = CT_LTM(ct_r) + matlen + call achtdr (Memd[CT_LTM(ct)], Memr[CT_LTM(ct_r)], matlen) + call achtdr (Memd[CT_LTV(ct)], Memr[CT_LTV(ct_r)], naxes) + + call sfree (sp) + return (ct) +end diff --git a/sys/mwcs/mwsdefwcs.x b/sys/mwcs/mwsdefwcs.x new file mode 100644 index 00000000..2cddc6ac --- /dev/null +++ b/sys/mwcs/mwsdefwcs.x @@ -0,0 +1,43 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +# MW_SDEFWCS -- Set the default WCS. This is the WCS indicated by the user +# environment variable "setwcs", if defined and the named WCS exists, else +# the first world system is used, else the physical system is used. + +procedure mw_sdefwcs (mw) + +pointer mw #I pointer to MWCS descriptor + +pointer sp, defwcs +int envfind() + +begin + call smark (sp) + call salloc (defwcs, SZ_FNAME, TY_CHAR) + + MI_WCS(mw) = NULL + + # Set the default WCS defined in the user environment, if defined + # and the named WCS exists in this MWCS. + + if (envfind ("defwcs", Memc[defwcs], SZ_FNAME) > 0) + iferr (call mw_ssystem (mw, Memc[defwcs])) + ; + + # Otherwise, the default WCS is the first world system, if any, + # else it is the physical system. The first world system is WCS 3 + # as the physical and logical systems are systems 1 and 2 and are + # always defined in any MWCS. + + if (MI_WCS(mw) == NULL) { + if (MI_NWCS(mw) >= 3) + MI_WCS(mw) = MI_WCSP(mw,3) + else + call mw_ssystem (mw, "physical") + } + + call sfree (sp) +end diff --git a/sys/mwcs/mwseti.x b/sys/mwcs/mwseti.x new file mode 100644 index 00000000..ac1a4baa --- /dev/null +++ b/sys/mwcs/mwseti.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "mwcs.h" + +# MW_SETI -- Set the value of a MWCS interface parameter. + +procedure mw_seti (mw, param, value) + +pointer mw #I pointer to MWCS descriptor +int param #I parameter code as defined in +int value #I new value for parameter + +begin + switch (param) { + case MW_NWCS: + MI_NWCS(mw) = max (2, value) + case MW_REFIM: + MI_REFIM(mw) = value + case MW_USEAXMAP: + MI_USEAXMAP(mw) = value + default: + call syserr (SYS_MWSET) + } +end diff --git a/sys/mwcs/mwshift.x b/sys/mwcs/mwshift.x new file mode 100644 index 00000000..d863f813 --- /dev/null +++ b/sys/mwcs/mwshift.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "mwcs.h" + +# MW_SHIFT -- Front end to mw_translate, used to perform a simple shift +# of the logical system. + +procedure mw_shift (mw, shift, axbits) + +pointer mw #I pointer to MWCS descriptor +real shift[ARB] #I shift for each axis in axbits +int axbits #I bitflags defining axes + +pointer sp, ltm, ltv_1, ltv_2 +int axis[MAX_DIM], naxes, pdim, nelem, axmap, i + +begin + # Convert axis bitflags to axis list. + call mw_gaxlist (mw, axbits, axis, naxes) + if (naxes <= 0) + return + + pdim = MI_NDIM(mw) + nelem = pdim * pdim + axmap = MI_USEAXMAP(mw) + MI_USEAXMAP(mw) = NO + + call smark (sp) + call salloc (ltm, nelem, TY_DOUBLE) + call salloc (ltv_1, pdim, TY_DOUBLE) + call salloc (ltv_2, pdim, TY_DOUBLE) + + # Initialize the translation matrix and vectors. + call mw_mkidmd (Memd[ltm], pdim) + call aclrd (Memd[ltv_1], pdim) + call aclrd (Memd[ltv_2], pdim) + + # Enter the axis shifts. + do i = 1, naxes + Memd[ltv_2+axis[i]-1] = shift[i] + + # Perform the translation. + call mw_translated (mw, Memd[ltv_1], Memd[ltm], Memd[ltv_2], pdim) + + MI_USEAXMAP(mw) = axmap + call sfree (sp) +end diff --git a/sys/mwcs/mwshow.x b/sys/mwcs/mwshow.x new file mode 100644 index 00000000..1fbb991c --- /dev/null +++ b/sys/mwcs/mwshow.x @@ -0,0 +1,152 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +# MW_SHOW -- Print information about a MWCS object to a file. + +procedure mw_show (mw, fd, what) + +pointer mw #I pointer to MWCS descriptor +int fd #I output file +int what #I type of output (not used at present) + +pointer wp +int ndim, nwcs, wcs, i, j +bool itob() + +begin + ndim = MI_NDIM(mw) + nwcs = MI_NWCS(mw) + + call fprintf (fd, + "MWCS=%x, ndim=%d, nwcs=%d, curwcs=%d(%s), refim=%s\n") + call pargi (mw) + call pargi (ndim) + call pargi (nwcs) + + wcs = INDEFI + do i = 1, MI_NWCS(mw) + if (MI_WCS(mw) == MI_WCSP(mw,i)) { + wcs = i + break + } + call pargi (wcs) + if (MI_WCS(mw) != NULL) { + wp = MI_WCS(mw) + if (WCS_SYSTEM(wp) != NULL) + call pargstr (S(mw,WCS_SYSTEM(wp))) + else + call pargstr ("noname") + } + + if (MI_REFIM(mw) != NULL) + call pargstr (IM_NAME(MI_REFIM(mw))) + else + call pargstr ("none") + + call fprintf (fd, "sbuflen=%d, sbufused=%d, dbuflen=%d, dbufused=%d\n") + call pargi (MI_SBUFLEN(mw)) + call pargi (MI_SBUFUSED(mw)) + call pargi (MI_DBUFLEN(mw)) + call pargi (MI_DBUFUSED(mw)) + + # Print the axis map. + call fprintf (fd, "useaxmap=%b, nlogdim=%d") + call pargb (itob(MI_USEAXMAP(mw))) + call pargi (MI_NLOGDIM(mw)) + call fprintf (fd, " axno=[") + do i = 1, ndim { + if (i > 1) + call fprintf (fd, " ") + call fprintf (fd, "%d") + call pargi (MI_AXNO(mw,i)) + } + call fprintf (fd, "] axval=[") + do i = 1, ndim { + if (i > 1) + call fprintf (fd, " ") + call fprintf (fd, "%d") + call pargi (MI_AXVAL(mw,i)) + } + call fprintf (fd, "] physax=[") + do i = 1, ndim { + if (i > 1) + call fprintf (fd, " ") + call fprintf (fd, "%d") + call pargi (MI_PHYSAX(mw,i)) + } + call fprintf (fd, "]\n") + + # Print the LTERM. + call fprintf (fd, "ltv = [") + do i = 1, ndim { + if (i > 1) + call fprintf (fd, " ") + call fprintf (fd, "%g") + call pargd (D(mw,MI_LTV(mw)+i-1)) + } + call fprintf (fd, "]\n") + + call fprintf (fd, "ltm = [") + do j = 1, ndim { + if (j > 1) + call fprintf (fd, "; ") + do i = 1, ndim { + if (i > 1) + call fprintf (fd, " ") + call fprintf (fd, "%g") + call pargd (D(mw,MI_LTM(mw)+(j-1)*ndim+i-1)) + } + } + call fprintf (fd, "]\n") + + # Print the world systems. + do wcs = 1, nwcs { + wp = MI_WCSP(mw,wcs) + ndim = WCS_NDIM(wp) + + call fprintf (fd, + "WCS %d, ndim=%d, name=%s, nwattr=%d, nfunc=%d\n") + call pargi (wcs) + call pargi (ndim) + if (WCS_SYSTEM(wp) != NULL) + call pargstr (S(mw,WCS_SYSTEM(wp))) + else + call pargstr ("noname") + call pargi (WCS_NWATTR(wp)) + call pargi (WCS_NFUNC(wp)) + + call fprintf (fd, "R = [") + do i = 1, ndim { + if (i > 1) + call fprintf (fd, " ") + call fprintf (fd, "%g") + call pargd (D(mw,WCS_R(wp)+i-1)) + } + call fprintf (fd, "]\n") + + call fprintf (fd, "W = [") + do i = 1, ndim { + if (i > 1) + call fprintf (fd, " ") + call fprintf (fd, "%g") + call pargd (D(mw,WCS_W(wp)+i-1)) + } + call fprintf (fd, "]\n") + + call fprintf (fd, "CD = [") + do j = 1, ndim { + if (j > 1) + call fprintf (fd, "; ") + do i = 1, ndim { + if (i > 1) + call fprintf (fd, " ") + call fprintf (fd, "%g") + call pargd (D(mw,WCS_CD(wp)+(j-1)*ndim+i-1)) + } + } + call fprintf (fd, "]\n") + } + +end diff --git a/sys/mwcs/mwsltermd.x b/sys/mwcs/mwsltermd.x new file mode 100644 index 00000000..f5619fd7 --- /dev/null +++ b/sys/mwcs/mwsltermd.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +# MW_SLTERMD -- Set the Lterm, double precision version. Since all floating +# data is stored as double internally, we merely copy the data in. + +procedure mw_sltermd (mw, ltm, ltv, ndim) + +pointer mw #I pointer to MWCS descriptor +double ltm[ndim,ndim] #I linear transformation matrix +double ltv[ndim] #I translation vector +int ndim #I dimensionality of system + +pointer mw_allocd() +errchk syserrs, mw_allocd + +begin + # The dimensionality of the data must match that of the current Lterm. + if (ndim != MI_NDIM(mw)) + call syserrs (SYS_MWNDIM, "mw_sltermd") + + # Copy in the data. Cobber the old data if the Lterm has been set, + # otherwise allocate space in the global data area. + + if (MI_LTM(mw) == NULL) + MI_LTM(mw) = mw_allocd (mw, ndim*ndim) + call amovd (ltm, D(mw,MI_LTM(mw)), ndim*ndim) + + if (MI_LTV(mw) == NULL) + MI_LTV(mw) = mw_allocd (mw, ndim) + call amovd (ltv, D(mw,MI_LTV(mw)), ndim) +end diff --git a/sys/mwcs/mwsltermr.x b/sys/mwcs/mwsltermr.x new file mode 100644 index 00000000..975221f6 --- /dev/null +++ b/sys/mwcs/mwsltermr.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +# MW_SLTERMR -- Set the Lterm, single precision version. Since all floating +# data is stored as double internally, a real->double conversion is involved, +# but no precision is lost provided single precision is adequate to describe +# the input data (an example of a case where precision is lost is a rotation, +# where there is a difference between the single and double precision version +# of, e.g., "sin(theta)"). + +procedure mw_sltermr (mw, ltm, ltv, ndim) + +pointer mw #I pointer to MWCS descriptor +real ltm[ndim,ndim] #I linear transformation matrix +real ltv[ndim] #I translation vector +int ndim #I dimensionality of system + +int nelem +pointer mw_allocd() +errchk syserrs, mw_allocd + +begin + # The dimensionality of the data must match that of the current Lterm. + if (ndim != MI_NDIM(mw)) + call syserrs (SYS_MWNDIM, "mw_sltermr") + + # Copy in the data. Cobber the old data if the Lterm has been set, + # otherwise allocate space in the global data area. + + nelem = ndim * ndim + if (MI_LTM(mw) == NULL) + MI_LTM(mw) = mw_allocd (mw, nelem) + call achtrd (ltm, D(mw,MI_LTM(mw)), nelem) + + if (MI_LTV(mw) == NULL) + MI_LTV(mw) = mw_allocd (mw, ndim) + call achtrd (ltv, D(mw,MI_LTV(mw)), ndim) +end diff --git a/sys/mwcs/mwssys.x b/sys/mwcs/mwssys.x new file mode 100644 index 00000000..ec1558eb --- /dev/null +++ b/sys/mwcs/mwssys.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +# MW_SSYSTEM -- Make the named world coordinate system the default. + +procedure mw_ssystem (mw, system) + +pointer mw #I pointer to MWCS descriptor +char system[ARB] #I system name + +pointer wp +bool streq() +pointer mw_findsys() +errchk mw_findsys + +begin + if (streq (system, "world")) + call mw_sdefwcs (mw) # set default world system + else { + wp = mw_findsys (mw, system) + if (wp != NULL) + MI_WCS(mw) = wp + else + call syserrs (SYS_MWWCSNF, system) + } +end diff --git a/sys/mwcs/mwstati.x b/sys/mwcs/mwstati.x new file mode 100644 index 00000000..03e80587 --- /dev/null +++ b/sys/mwcs/mwstati.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "mwcs.h" + +# MW_STATI -- Get the value of a MWCS interface parameter. + +int procedure mw_stati (mw, param) + +pointer mw #I pointer to MWCS descriptor +int param #I parameter code as defined in + +begin + switch (param) { + case MW_NDIM: + if (MI_USEAXMAP(mw) == NO) + return (MI_NDIM(mw)) + else + return (MI_NLOGDIM(mw)) + case MW_NWCS: + return (MI_NWCS(mw)) + case MW_REFIM: + return (MI_REFIM(mw)) + case MW_USEAXMAP: + return (MI_USEAXMAP(mw)) + case MW_NPHYSDIM: + return (MI_NDIM(mw)) + case MW_SAVELEN: + return (MI_LEN(mw) * SZ_STRUCT + MI_DBUFUSED(mw) * SZ_DOUBLE + + (MI_SBUFUSED(mw) + SZB_CHAR-1) / SZB_CHAR) + default: + call syserr (SYS_MWSTAT) + } +end diff --git a/sys/mwcs/mwsv.h b/sys/mwcs/mwsv.h new file mode 100644 index 00000000..e08a6069 --- /dev/null +++ b/sys/mwcs/mwsv.h @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# MWSV.H -- Definitions for the MWSV external save-MWSV data format. This +# has been generalized slightly over the original "version 0" design, but is +# still not very general and should be redone at some point. There is an +# implicit assumption that most of the elements of the MWSV structure are +# identical to those in the MWCS runtime descriptor. + +define MWSV_MAGIC 4D57X # identifies MWSV descriptor +define MWSV_VERSION 1 # current MWSV version +define MWSV_MAXWCS 8 # max wcs per mwcs +define MWSV_LENWCS0 282 # LENWCS for MWSV version 0 + +# Header for the saved MWCS object. Object LENs are in the natural units of +# whatever object the field refers to. Save buffer offsets are type char +# regardless of the object type. The unused fields at the end of the header +# are reserved for future use and are set to zero in the current version. + +define LEN_SVHDR 16 +define SV_MAGIC Memi[$1] # magic marker +define SV_CWCSLEN Memi[$1+1] # length of compressed MWSV +define SV_MWSVLEN Memi[$1+2] # full length of MWSV descr. +define SV_MWSVOFF Memi[$1+3] # char offset of saved MWSV +define SV_DBUFLEN Memi[$1+4] # length of saved DBUF +define SV_DBUFOFF Memi[$1+5] # char offset of saved DBUF +define SV_SBUFLEN Memi[$1+6] # length of saved SBUF +define SV_SBUFOFF Memi[$1+7] # char offset of saved SBUF +define SV_VERSION Memi[$1+8] # MWSV save file version number +define SV_NWCS Memi[$1+9] # number of saved WCS structs +define SV_LENWCS Memi[$1+10] # length of WCS substruct + +# MWSV descriptor. This is very similar to the MWCS runtime descriptor +# except that the size of a WCS sub-structure (LENWCS) can vary. If the +# MWSV version is 0 lenwcs is fixed at MS_LENWCS0, otherwise the value of +# lenwcs is given in the save header as the value of field SV_LENWCS. + +define MWSV_BASELEN 70 +define LEN_MWSV (MWSV_BASELEN+($1)*($2)) + +define MS_MAGIC Memi[$1] # magic marker +define MS_WCSP ($1+70+(($2)-1)*($3)) # $1=ms $2=wcs $3=lenwcs diff --git a/sys/mwcs/mwswattrs.x b/sys/mwcs/mwswattrs.x new file mode 100644 index 00000000..14fc72bd --- /dev/null +++ b/sys/mwcs/mwswattrs.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +# MW_SWATTRS -- Set the string value of the named WCS attribute for axis N. +# The attribute is created if not already defined. If axis N=0 is specified, +# the attribute pertains to the entire WCS, not just one axis. + +procedure mw_swattrs (mw, axis, attribute, valstr) + +pointer mw #I pointer to MWCS descriptor +int axis #I axis to which attribute belongs +char attribute[ARB] #I attribute name +char valstr[ARB] #I attribute value + +pointer wp, ap +int atno, i +bool streq() +int mw_refstr() +errchk syserrs, mw_refstr + +begin + # Get current WCS. + wp = MI_WCS(mw) + if (wp == NULL) + call syserrs (SYS_MWNOWCS, "mw_swattrs") + + # Lookup the named attribute and replace the pointer to the value + # string if found. Otherwise, add a new attribute. + + atno = 0 + do i = 1, WCS_NWATTR(wp) { + ap = WCS_WATTR(wp,i) + if (AT_AXIS(ap) == axis) + if (streq (S(mw,AT_NAME(ap)), attribute)) { + atno = i + break + } + } + + # Add a new attribute? + if (atno == 0) { + atno = WCS_NWATTR(wp) + 1 + if (atno > MAX_WATTR) + call syserrs (SYS_MWATOVFL, attribute) + else { + WCS_NWATTR(wp) = atno + ap = WCS_WATTR(wp,atno) + AT_AXIS(ap) = axis + AT_NAME(ap) = mw_refstr (mw, attribute) + } + } + + # Store the value string. + AT_VALUE(ap) = mw_refstr (mw, valstr) +end diff --git a/sys/mwcs/mwswsampd.x b/sys/mwcs/mwswsampd.x new file mode 100644 index 00000000..10d02068 --- /dev/null +++ b/sys/mwcs/mwswsampd.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +# MW_SWSAMPD -- Set the sampled WCS curve for an axis. + +procedure mw_swsampd (mw, axis, pv, wv, npts) + +pointer mw #I pointer to MWCS descriptor +int axis #I axis which gets the wsamp vector +double pv[ARB] #I physical coordinates of points +double wv[ARB] #I world coordinates of points +int npts #I number of data point in curve + +pointer wp +int mw_allocd() +errchk syserrs, mw_allocd + +begin + # Get the current WCS. + wp = MI_WCS(mw) + if (wp == NULL) + call syserrs (SYS_MWNOWCS, "mw_swsampd") + + # Overwrite the current curve, if any, else allocate new storage. + if (WCS_PV(wp,axis) == NULL || WCS_NPTS(wp,axis) < npts) + WCS_PV(wp,axis) = mw_allocd (mw, npts) + call amovd (pv, D(mw,WCS_PV(wp,axis)), npts) + + if (WCS_WV(wp,axis) == NULL || WCS_NPTS(wp,axis) < npts) + WCS_WV(wp,axis) = mw_allocd (mw, npts) + call amovd (wv, D(mw,WCS_WV(wp,axis)), npts) + + WCS_NPTS(wp,axis) = npts +end diff --git a/sys/mwcs/mwswsampr.x b/sys/mwcs/mwswsampr.x new file mode 100644 index 00000000..3fcf3f70 --- /dev/null +++ b/sys/mwcs/mwswsampr.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +# MW_SWSAMPR -- Set the sampled WCS curve for an axis. + +procedure mw_swsampr (mw, axis, pv, wv, npts) + +pointer mw #I pointer to MWCS descriptor +int axis #I axis which gets the wsamp vector +real pv[ARB] #I physical coordinates of points +real wv[ARB] #I world coordinates of points +int npts #I number of data point in curve + +pointer wp +int mw_allocd() +errchk syserrs, mw_allocd + +begin + # Get the current WCS. + wp = MI_WCS(mw) + if (wp == NULL) + call syserrs (SYS_MWNOWCS, "mw_swsampr") + + # Overwrite the current curve, if any, else allocate new storage. + if (WCS_PV(wp,axis) == NULL || WCS_NPTS(wp,axis) < npts) + WCS_PV(wp,axis) = mw_allocd (mw, npts) + call achtrd (pv, D(mw,WCS_PV(wp,axis)), npts) + + if (WCS_WV(wp,axis) == NULL || WCS_NPTS(wp,axis) < npts) + WCS_WV(wp,axis) = mw_allocd (mw, npts) + call achtrd (wv, D(mw,WCS_WV(wp,axis)), npts) + + WCS_NPTS(wp,axis) = npts +end diff --git a/sys/mwcs/mwswtermd.x b/sys/mwcs/mwswtermd.x new file mode 100644 index 00000000..0e392dc4 --- /dev/null +++ b/sys/mwcs/mwswtermd.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +# MW_SWTERMD -- Set the linear part of the Wterm, i.e., the physical and world +# coordinates of the reference point and the CD matrix. It is the Wterm of +# the current default WCS which is affected. + +procedure mw_swtermd (mw, r, w, cd, ndim) + +pointer mw #I pointer to MWCS descriptor +double r[ndim] #I physical coordinates of reference point +double w[ndim] #I world coordinates of reference point +double cd[ndim,ndim] #I CD matrix +int ndim #I dimension of Wterm + +pointer wp +pointer mw_allocd() +errchk mw_allocd, syserrs +string s_name "mw_swtermd" + +begin + # Get the current WCS. + wp = MI_WCS(mw) + if (wp == NULL) + call syserrs (SYS_MWNOWCS, s_name) + + # Verify the dimension. + if (WCS_NDIM(wp) != ndim) + call syserrs (SYS_MWNDIM, s_name) + + # Copy in the data. Cobber the old data if the Wterm has been set, + # otherwise allocate space in the global data area. + + if (WCS_R(wp) == NULL) + WCS_R(wp) = mw_allocd (mw, ndim) + call amovd (r, D(mw,WCS_R(wp)), ndim) + + if (WCS_W(wp) == NULL) + WCS_W(wp) = mw_allocd (mw, ndim) + call amovd (w, D(mw,WCS_W(wp)), ndim) + + if (WCS_CD(wp) == NULL) + WCS_CD(wp) = mw_allocd (mw, ndim*ndim) + call amovd (cd, D(mw,WCS_CD(wp)), ndim*ndim) +end diff --git a/sys/mwcs/mwswtermr.x b/sys/mwcs/mwswtermr.x new file mode 100644 index 00000000..0f52419c --- /dev/null +++ b/sys/mwcs/mwswtermr.x @@ -0,0 +1,49 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +# MW_SWTERMR -- Set the linear part of the Wterm, i.e., the physical and world +# coordinates of the reference point and the CD matrix. It is the Wterm of +# the current default WCS which is affected. + +procedure mw_swtermr (mw, r, w, cd, ndim) + +pointer mw #I pointer to MWCS descriptor +real r[ndim] #I physical coordinates of reference point +real w[ndim] #I world coordinates of reference point +real cd[ndim,ndim] #I CD matrix +int ndim #I dimension of Wterm + +pointer wp +int nelem +pointer mw_allocd() +errchk mw_allocd, syserrs +string s_name "mw_swtermr" + +begin + # Get the current WCS. + wp = MI_WCS(mw) + if (wp == NULL) + call syserrs (SYS_MWNOWCS, s_name) + + # Verify the dimension. + if (WCS_NDIM(wp) != ndim) + call syserrs (SYS_MWNDIM, s_name) + + # Copy in the data. Cobber the old data if the Wterm has been set, + # otherwise allocate space in the global data area. + + if (WCS_R(wp) == NULL) + WCS_R(wp) = mw_allocd (mw, ndim) + call achtrd (r, D(mw,WCS_R(wp)), ndim) + + if (WCS_W(wp) == NULL) + WCS_W(wp) = mw_allocd (mw, ndim) + call achtrd (w, D(mw,WCS_W(wp)), ndim) + + nelem = ndim * ndim + if (WCS_CD(wp) == NULL) + WCS_CD(wp) = mw_allocd (mw, nelem) + call achtrd (cd, D(mw,WCS_CD(wp)), nelem) +end diff --git a/sys/mwcs/mwswtype.x b/sys/mwcs/mwswtype.x new file mode 100644 index 00000000..13ab5938 --- /dev/null +++ b/sys/mwcs/mwswtype.x @@ -0,0 +1,131 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "mwcs.h" + +# MW_SWTYPE -- Set the coordinate (WCS function) type and any related +# attributes for an axis, or set of related axes, of a WCS. Each call +# defines a group of one or more axes which share the same WCS function +# and which are dependent, i.e., all axes are required to evaluate the +# coordinate of any axis in the group. Independent axes or groups of +# axes should be defined in separate calls. +# +# Although the attributes for each axis in the group are all entered in +# a single call via the WATTR string, each attribute is still assigned +# to a single axis. The syntax is as follows: +# +# axis 1: format="...", label="..." +# axis 2: ...(etc.) +# +# where the axis number is relative to the start of the group. +# The WATTR string may be any length and may contain multiple lines of text. +# A typical use of attributes is to define WCS specific parameters; these +# may be read by the initialization routine in the WCS function driver, +# called when a coordinate transformation is compiled. + +procedure mw_swtype (mw, axis, naxes, wtype, wattr) + +pointer mw #I pointer to MWCS descriptor +int axis[naxes] #I axis number, 1:ndim +int naxes #I number of axes in function group +char wtype[ARB] #I axis coordinate type +char wattr[ARB] #I axis attributes, "attr=value, ..." + +pointer sp, atname, valstr, wp, op, wf +int ip, ch, fn, wfno, ax, sz_valstr, i +int ctowrd(), mw_flookup(), ctoi(), strlen() +errchk syserrs, mw_swattrs, mw_flookup +bool streq() + +begin + call smark (sp) + sz_valstr = strlen (wattr) + call salloc (valstr, sz_valstr, TY_CHAR) + call salloc (atname, SZ_ATNAME, TY_CHAR) + + # Get the current WCS. + wp = MI_WCS(mw) + if (wp == NULL) + call syserrs (SYS_MWNOWCS, "mw_swtype") + + # Set the function type? + if (wtype[1] != EOS) { + # Determine the function type for this axis group. + fn = mw_flookup (mw, wtype) + if (fn == ERR) + call syserrs (SYS_MWUNKFN, wtype) + + # For anything except a simple linear relation, add a new function + # descriptor to the WCS. + + if (fn != F_LINEAR) { + # Allocate new WCS function descriptor. + wfno = WCS_NFUNC(wp) + 1 + if (wfno > MAX_FUNC) + call syserrs (SYS_MWFUNCOVFL, wtype) + WCS_NFUNC(wp) = wfno + + # Initialize the descriptor. + wf = WCS_FUNC(wp,wfno) + WF_FN(wf) = fn + WF_NAXES(wf) = naxes + call amovi (axis, WF_AXIS(wf,1), naxes) + } else + wfno = 0 + + # Set the axis type and class. + do i = 1, naxes { + call mw_swattrs (mw, axis[i], "wtype", wtype) + WCS_AXCLASS(wp,axis[i]) = wfno + } + } + + # Process the attributes into the WCS descriptor. + ax = axis[1] + for (ip=1; wattr[ip] != EOS; ) { + # Skip to next token. + ch = wattr[ip] + while (IS_WHITE(ch) || ch == ',' || ch == '\n' || ch == ':') { + ip = ip + 1 + ch = wattr[ip] + } + + # Done? + if (ch == EOS) + break + + # Extract attribute name string. + op = atname + ch = wattr[ip] + while (IS_ALNUM(ch) || ch == '_' || ch == '$') { + Memc[op] = ch + op = min (atname+SZ_ATNAME, op + 1) + ip = ip + 1 + ch = wattr[ip] + } + Memc[op] = EOS + + # Check for "axis N:" and set AX if encountered. + if (streq (Memc[atname], "axis")) + if (ctoi (wattr, ip, i) > 0) { + ax = axis[i] + next + } + + # Skip to value string. + ch = wattr[ip] + while (IS_WHITE(ch) || ch == '=' || ch == '\n') { + ip = ip + 1 + ch = wattr[ip] + } + + # Extract value string. + ch = ctowrd (wattr, ip, Memc[valstr], sz_valstr) + + # Add the attribute to the WCS. + call mw_swattrs (mw, ax, Memc[atname], Memc[valstr]) + } + + call sfree (sp) +end diff --git a/sys/mwcs/mwtransd.x b/sys/mwcs/mwtransd.x new file mode 100644 index 00000000..267317ce --- /dev/null +++ b/sys/mwcs/mwtransd.x @@ -0,0 +1,117 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +# MW_TRANSLATE -- Translate the logical system, i.e., perform a linear +# transformation of the logical system by modifying the Lterm of the MWCS. +# The transformation is defined in terms of the CURRENT LOGICAL SYSTEM, +# subject to axis mapping, dimensional reduction, etc. This is unlike +# MW_SLTERM, which defines the Lterm relative to the physical system in +# physical terms (no axis mapping, full dimensionality, etc.). +# +# p' = ltm * (p - ltv_1) + ltv_2 +# +# For convenience the transformation is specified using separate translation +# vectors for the input and output systems. If ltv_1 is set to zero a +# "fully reduced" transformation of the form used internally may be entered. + +procedure mw_translated (mw, ltv_1, ltm, ltv_2, ndim) + +pointer mw #I pointer to MWCS descriptor +double ltv_1[ndim] #I input translation vector +double ltm[ndim,ndim] #I linear transformation matrix +double ltv_2[ndim] #I output translation vector +int ndim #I dimensionality of transform + +double v +pointer sp, o_ltm, o_ltv, n_ltm, n_ltv, ltv +int pdim, nelem, axis[MAX_DIM], i, j +errchk syserrs +define err_ 91 + +begin + pdim = MI_NDIM(mw) + nelem = pdim * pdim + + call smark (sp) + call salloc (ltv, ndim, TY_DOUBLE) + call salloc (o_ltm, nelem, TY_DOUBLE) + call salloc (o_ltv, pdim, TY_DOUBLE) + call salloc (n_ltm, nelem, TY_DOUBLE) + call salloc (n_ltv, pdim, TY_DOUBLE) + + # Combine the input and output translation vectors. + do j = 1, ndim { + v = ltv_2[j] + do i = 1, ndim + v = v + ltm[i,j] * (-ltv_1[i]) + Memd[ltv+j-1] = v + } + + # Get axis map. + if (MI_USEAXMAP(mw) == NO) { + if (ndim > MI_NDIM(mw)) + goto err_ + do i = 1, ndim + axis[i] = i + } else { + if (ndim > MI_NLOGDIM(mw)) +err_ call syserrs (SYS_MWNDIM, "mw_translate") + do i = 1, ndim + axis[i] = MI_PHYSAX(mw,i) + } + + # Perform the transformation. Use a procedure call to dereference + # the pointers to simplify the notation. + + call mw_axtran (D(mw,MI_LTM(mw)), D(mw,MI_LTV(mw)), + Memd[n_ltm], Memd[n_ltv], pdim, ltm, Memd[ltv], axis, ndim) + + # Update the Lterm. + call amovd (Memd[n_ltm], D(mw,MI_LTM(mw)), nelem) + call amovd (Memd[n_ltv], D(mw,MI_LTV(mw)), pdim) + + call sfree (sp) +end + + +# MW_AXTRAN -- Axis mapped linear transformation. Matrix or vector elements +# not included in the axis map are propagated unchanged. + +procedure mw_axtran (o_ltm,o_ltv, n_ltm,n_ltv, pdim, ltm,ltv, ax, ndim) + +double o_ltm[pdim,pdim] #I matrix to be transformed +double o_ltv[pdim] #I vector to be transformed +double n_ltm[pdim,pdim] #O transformed matrix +double n_ltv[pdim] #O transformed vector +int pdim #I dimension of these guys +double ltm[ndim,ndim] #I transform matrix +double ltv[ndim] #I transform vector +int ax[ndim] #I transform axis map: physax=axis[logax] +int ndim #I dimension of these guys + +double v +int i, j, k + +begin + # Transform the matrix. + call amovd (o_ltm, n_ltm, pdim * pdim) + do j = 1, ndim + do i = 1, ndim { + v = 0 + do k = 1, ndim + # v = v + o_ltm[ax[k],ax[j]] * ltm[i,k] + v = v + ltm[k,j] * o_ltm[ax[i],ax[k]] + n_ltm[ax[i],ax[j]] = v + } + + # Transform the vector. + call amovd (o_ltv, n_ltv, pdim) + do j = 1, ndim { + v = ltv[j] + do i = 1, ndim + v = v + ltm[i,j] * o_ltv[ax[i]] + n_ltv[ax[j]] = v + } +end diff --git a/sys/mwcs/mwtransr.x b/sys/mwcs/mwtransr.x new file mode 100644 index 00000000..3947e3d1 --- /dev/null +++ b/sys/mwcs/mwtransr.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# MW_TRANSLATE -- Translate the logical system, i.e., perform a linear +# transformation of the logical system by modifying the Lterm of the MWCS. + +procedure mw_translater (mw, ltv_1, ltm, ltv_2, ndim) + +pointer mw #I pointer to MWCS descriptor +real ltv_1[ndim] #I input translation vector +real ltm[ndim,ndim] #I linear transformation matrix +real ltv_2[ndim] #I output translation vector +int ndim #I dimensionality of transform + +int nelem +pointer sp, d_ltm, d_ltv1, d_ltv2 + +begin + call smark (sp) + nelem = ndim * ndim + call salloc (d_ltm, nelem, TY_DOUBLE) + call salloc (d_ltv1, ndim, TY_DOUBLE) + call salloc (d_ltv2, ndim, TY_DOUBLE) + + call achtrd (ltm, Memd[d_ltm], nelem) + call achtrd (ltv_1, Memd[d_ltv1], ndim) + call achtrd (ltv_2, Memd[d_ltv2], ndim) + + call mw_translated (mw, Memd[d_ltv1], Memd[d_ltm], Memd[d_ltv2], ndim) + call sfree (sp) +end diff --git a/sys/mwcs/mwv1tran.gx b/sys/mwcs/mwv1tran.gx new file mode 100644 index 00000000..170d8239 --- /dev/null +++ b/sys/mwcs/mwv1tran.gx @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../mwcs.h" + +# MW_V1TRAN -- Optimized 1D coordinate transformation for an array of points. + +procedure mw_v1tran$t (a_ct, x1, x2, npts) + +pointer a_ct #I pointer to CTRAN descriptor +PIXEL x1[ARB] #I coordinates in input system +PIXEL x2[ARB] #O coordinates in output system +int npts + +int i +pointer ct +PIXEL scale, offset +errchk mw_ctran$t + +begin + # Get real or double version of descriptor. + ct = CT_$T(a_ct) + + scale = Mem$t[CT_LTM(ct)] + offset = Mem$t[CT_LTV(ct)] + + # Perform the transformation; case LNR is a simple linear transform. + if (CT_TYPE(ct) == LNR) { + do i = 1, npts + x2[i] = scale * x1[i] + offset + } else { + do i = 1, npts + call mw_ctran$t (a_ct, x1[i], x2[i], 1) + } +end diff --git a/sys/mwcs/mwv2tran.gx b/sys/mwcs/mwv2tran.gx new file mode 100644 index 00000000..6fd701f7 --- /dev/null +++ b/sys/mwcs/mwv2tran.gx @@ -0,0 +1,49 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../mwcs.h" + +# MW_V2TRAN -- Optimized 2D coordinate transformation for an array of points. + +procedure mw_v2tran$t (a_ct, x1,y1, x2,y2, npts) + +pointer a_ct #I pointer to CTRAN descriptor +PIXEL x1[ARB],y1[ARB] #I coordinates in input system +PIXEL x2[ARB],y2[ARB] #O coordinates in output system +int npts + +int i +pointer ct, ltm, ltv +PIXEL p1[2], p2[2] +errchk mw_ctran$t + +begin + # Get real or double version of descriptor. + ct = CT_$T(a_ct) + + ltm = CT_LTM(ct) + ltv = CT_LTV(ct) + + if (CT_TYPE(ct) == LNR) { + # Simple linear, nonrotated transformation. + do i = 1, npts { + x2[i] = Mem$t[ltm ] * x1[i] + Mem$t[ltv ] + y2[i] = Mem$t[ltm+3] * y1[i] + Mem$t[ltv+1] + } + } else if (CT_TYPE(ct) == LRO) { + # Linear, rotated transformation. + do i = 1, npts { + p1[1] = x1[i]; p1[2] = y1[i] + x2[i] = Mem$t[ltm ] * p1[1] + Mem$t[ltm+1] * p2[1] + + Mem$t[ltv ] + y2[i] = Mem$t[ltm+2] * p1[1] + Mem$t[ltm+3] * p2[1] + + Mem$t[ltv+1] + } + } else { + # General case involving one or more functional terms. + do i = 1, npts { + p1[1] = x1[i]; p1[2] = y1[i] + call mw_ctran$t (a_ct, p1, p2, 2) + x2[i] = p2[1]; y2[i] = p2[2] + } + } +end diff --git a/sys/mwcs/mwvmul.gx b/sys/mwcs/mwvmul.gx new file mode 100644 index 00000000..1c5f4867 --- /dev/null +++ b/sys/mwcs/mwvmul.gx @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# MW_VMUL -- Vector multiply. + +procedure mw_vmul$t (a, b, c, ndim) + +PIXEL a[ndim,ndim] #I input matrix +PIXEL b[ndim] #I input vector +PIXEL c[ndim] #O output vector +int ndim #I system dimension + +int i, j +PIXEL v + +begin + do j = 1, ndim { + v = 0 + do i = 1, ndim + v = v + a[i,j] * b[i] + c[j] = v + } +end diff --git a/sys/mwcs/mwvtran.gx b/sys/mwcs/mwvtran.gx new file mode 100644 index 00000000..ddd59cb7 --- /dev/null +++ b/sys/mwcs/mwvtran.gx @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# MW_VTRAN -- Transform an array of N-dimensional points, expressed as a +# 2D vector where v[1,i] is point I of vector V. + +procedure mw_vtran$t (ct, v1, v2, ndim, npts) + +pointer ct #I pointer to CTRAN descriptor +PIXEL v1[ndim,npts] #I points to be transformed +PIXEL v2[ndim,npts] #O vector to get the transformed points +int ndim #I dimensionality of each point +int npts #I number of points + +int i +errchk mw_ctran$t + +begin + do i = 1, npts + call mw_ctran$t (ct, v1[1,i], v2[1,i], ndim) +end diff --git a/sys/mwcs/wfait.x b/sys/mwcs/wfait.x new file mode 100644 index 00000000..481ba7a1 --- /dev/null +++ b/sys/mwcs/wfait.x @@ -0,0 +1,463 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +.help WFAIT +.nf ------------------------------------------------------------------------- +WFAIT -- WCS function driver for the Hammer-Aitoff projection. + +Driver routines: + + FN_INIT wf_ait_init (fc, dir) + FN_DESTROY (none) + FN_FWD wf_ait_fwd (fc, v1, v2) + FN_INV wf_ait_inv (fc, v1, v2) + +.endhelp -------------------------------------------------------------------- + +# Driver specific fields of function call (FC) descriptor. +define FC_IRA Memi[$1+FCU] # RA axis (1 or 2) +define FC_IDEC Memi[$1+FCU+1] # DEC axis (1 or 2) +define FC_NATRA Memd[P2D($1+FCU+2)] # RA of native pole (rads) +define FC_NATDEC Memd[P2D($1+FCU+4)] # DEC of native pole (rads) +define FC_LONGP Memd[P2D($1+FCU+6)] # LONGPOLE (rads) +define FC_COSDEC Memd[P2D($1+FCU+8)] # cosine (NATDEC) +define FC_SINDEC Memd[P2D($1+FCU+10)] # sine (NATDEC) +define FC_SPHTOL Memd[P2D($1+FCU+12)] # trig tolerance +define FC_RODEG Memd[P2D($1+FCU+14)] # RO (degs) +define FC_C1 Memd[P2D($1+FCU+16)] # 2 * RO * RO +define FC_C2 Memd[P2D($1+FCU+18)] # 1 / (4 * RO * RO) (degs) +define FC_C3 Memd[P2D($1+FCU+20)] # 1 / (16 * RO * RO) (degs) +define FC_C4 Memd[P2D($1+FCU+22)] # 1 / (2 * RO) (degs) +define FC_BADCVAL Memd[P2D($1+FCU+24)] # bad coordinate value +define FC_W Memd[P2D($1+FCU+26)+($2)-1] # CRVAL axis (1 and 2) + + +# WF_AIT_INIT -- Initialize the forward or inverse Hammer-Aitoff transform. +# Initialization for this transformation consists of, determining which axis +# is RA / LON and which is DEC / LAT, reading in the native longitude and +# latitude of the pole in celestial coordinates LONGPOLE and LATPOLE from the +# attribute list, computing the celestial longitude and colatitude of the +# native pole, precomputing the Euler angles and associated intermediary +# functions of the reference point, reading in the projection parameter RO +# from the attribute list, and precomputing the various required intermediate +# quantities. If LONGPOLE is undefined then a value of 180.0 degrees is assumed +# if the celestial latitude of the reference point is less than 0, otherwise +# 0 degrees is assumed. If LATPOLE is undefined, the more northerly of the +# two possible solutions is assumed, otherwise the solution closest to +# LATPOLE is assumed. If RO is undefined a value of 180.0 / PI is assumed. +# In order to determine the axis order, the "axtype={ra|dec} {xlon|ylat}" +# must have been set in the attribute list for the function. The LONGPOLE, +# LATPOLE, and RO parameters may be set in either or both of the axes attribute +# lists, but the value in the RA axis attribute list takes precedence. + +procedure wf_ait_init (fc, dir) + +pointer fc #I pointer to FC descriptor +int dir #I direction of transform + +int i +double dec, latpole, theta0, clat0, slat0, cphip, sphip, cthe0, sthe0, x, y, z +double u, v, latp1, latp2, latp, maxlat, tol +pointer sp, atvalue, ct, mw, wp, wv +int ctod() +data tol/1.0d-10/ +errchk wf_decaxis(), mw_gwattrs() + +begin + # Allocate space for the attribute string. + call smark (sp) + call salloc (atvalue, SZ_LINE, TY_CHAR) + + # Get the required mwcs pointers. + ct = FC_CT(fc) + mw = CT_MW(ct) + wp = FC_WCS(fc) + + # Determine which is the DEC axis, and hence the axis order. + call wf_decaxis (fc, FC_IRA(fc), FC_IDEC(fc)) + + # Get the value of W for each axis, i.e. the world coordinates at + # the reference point. + + wv = MI_DBUF(mw) + WCS_W(wp) - 1 + do i = 1, 2 + FC_W(fc,i) = Memd[wv+CT_AXIS(ct,FC_AXIS(fc,i))-1] + + # Determine the native longitude and latitude of the pole of the + # celestial coordinate system corresponding to the FITS keywords + # LONGPOLE and LATPOLE. LONGPOLE has no default but will be set + # to 180 or 0 depending on the value of the declination of the + # reference point. LATPOLE has no default but will be set depending + # on the values of LONGPOLE and the reference declination. + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "longpole", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "longpole", Memc[atvalue], + SZ_LINE) + } then { + FC_LONGP(fc) = INDEFD + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_LONGP(fc)) <= 0) + FC_LONGP(fc) = INDEFD + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_LONGP(fc)) <= 0) + FC_LONGP(fc) = INDEFD + } + + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "latpole", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "latpole", Memc[atvalue], + SZ_LINE) + } then { + latpole = INDEFD + } else { + i = 1 + if (ctod (Memc[atvalue], i, latpole) <= 0) + latpole = INDEFD + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, latpole) <= 0) + latpole = INDEFD + } + + # Fetch the RO projection parameter which is the radius of the + # generating sphere for the projection. If RO is absent which + # is the usual case set it to 180 / PI. Search both axes for + # this quantity. + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "ro", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "ro", Memc[atvalue], + SZ_LINE) + } then { + FC_RODEG(fc) = 180.0d0 / DPI + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_RODEG(fc)) <= 0) + FC_RODEG(fc) = 180.0d0 / DPI + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_RODEG(fc)) <= 0) + FC_RODEG(fc) = 180.0d0 / DPI + } + + # Compute the native longitude of the celestial pole. + dec = DDEGTORAD(FC_W(fc,FC_IDEC(fc))) + theta0 = 0.0d0 + if (IS_INDEFD(FC_LONGP(fc))) { + if (dec < theta0) + FC_LONGP(fc) = DPI + else + FC_LONGP(fc) = 0.0d0 + } else + FC_LONGP(fc) = DDEGTORAD(FC_LONGP(fc)) + + # Compute the celestial longitude and latitude of the native pole. + clat0 = cos (dec) + slat0 = sin (dec) + cphip = cos (FC_LONGP(fc)) + sphip = sin (FC_LONGP(fc)) + cthe0 = cos (theta0) + sthe0 = sin (theta0) + + x = cthe0 * cphip + y = sthe0 + z = sqrt (x * x + y * y) + + # The latitude of the native pole is determined by LATPOLE in this + # case. + if (z == 0.0d0) { + + if (slat0 != 0.0d0) + call error (0, "WF_AIT_INIT: Invalid projection parameters") + if (IS_INDEFD(latpole)) + latp = 999.0d0 + else + latp = DDEGTORAD(latpole) + + } else { + if (abs (slat0 / z) > 1.0d0) + call error (0, "WF_AIT_INIT: Invalid projection parameters") + + u = atan2 (y, x) + v = acos (slat0 / z) + latp1 = u + v + if (latp1 > DPI) + latp1 = latp1 - DTWOPI + else if (latp1 < -DPI) + latp1 = latp1 + DTWOPI + + latp2 = u - v + if (latp2 > DPI) + latp2 = latp2 - DTWOPI + else if (latp2 < -DPI) + latp2 = latp2 + DTWOPI + + if (IS_INDEFD(latpole)) + maxlat = 999.0d0 + else + maxlat = DDEGTORAD(latpole) + if (abs (maxlat - latp1) < abs (maxlat - latp2)) { + if (abs (latp1) < (DHALFPI + tol)) + latp = latp1 + else + latp = latp2 + } else { + if (abs (latp2) < (DHALFPI + tol)) + latp = latp2 + else + latp = latp1 + } + } + FC_NATDEC(fc) = DHALFPI - latp + + z = cos (latp) * clat0 + if (abs(z) < tol) { + + # Celestial pole at the reference point. + if (abs(clat0) < tol) { + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) + FC_NATDEC(fc) = DHALFPI - theta0 + # Celestial pole at the native north pole. + } else if (latp > 0.0d0) { + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) + FC_LONGP(fc) - + DPI + FC_NATDEC(fc) = 0.0d0 + # Celestial pole at the native south pole. + } else if (latp < 0.0d0) { + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) - FC_LONGP(fc) + FC_NATDEC(fc) = DPI + } + + } else { + x = (sthe0 - sin (latp) * slat0) / z + y = sphip * cthe0 / clat0 + if (x == 0.0d0 && y == 0.0d0) + call error (0, "WF_AIT_INIT: Invalid projection parameters") + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) - atan2 (y,x) + } + + if (FC_W(fc,FC_IRA(fc)) >= 0.0d0) { + if (FC_NATRA(fc) < 0.0d0) + FC_NATRA(fc) = FC_NATRA(fc) + DTWOPI + } else { + if (FC_NATRA(fc) > 0.0d0) + FC_NATRA(fc) = FC_NATRA(fc) - DTWOPI + } + FC_COSDEC(fc) = cos (FC_NATDEC(fc)) + FC_SINDEC(fc) = sin (FC_NATDEC(fc)) + + # Check for ill-conditioned parameters. + if (abs(latp) > (DHALFPI+tol)) + call error (0, "WF_AIT_INIT: Invalid projection parameters") + + FC_C1(fc) = 2.0d0 * FC_RODEG(fc) * FC_RODEG(fc) + FC_C2(fc) = 1.0d0 / (2.0d0 * FC_C1(fc)) + FC_C3(fc) = FC_C2(fc) / 4.0d0 + FC_C4(fc) = 1.0d0 / (2.0d0 * FC_RODEG(fc)) + + # Set the bad coordinate value. + FC_SPHTOL(fc) = 1.0d-5 + + # Set the bad coordinate value. + FC_BADCVAL(fc) = INDEFD + + # Free working space. + call sfree (sp) +end + + +# WF_AIT_FWD -- Forward transform (physical to world) for the Hammer-Aitoff +# projection. + +procedure wf_ait_fwd (fc, p, w) + +pointer fc #I pointer to FC descriptor +double p[2] #I physical coordinates (x, y) +double w[2] #O world coordinates (ra, dec) + +int ira, idec +double x, y, u, z, s, xp, yp, phi, theta, costhe, sinthe, dphi, cosphi, sinphi +double ra, dec, dlng + +begin + # Get the axis numbers. + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + # Compute native spherical coordinates PHI and THETA in degrees from + # the projected coordinates. This is the projection part of the + # computation. + + x = p[ira] + y = p[idec] + + # Compute PHI. + u = 1.0d0 - x * x * FC_C3(fc) - y * y * FC_C2(fc) + if (u < 0.0d0) { + w[ira] = FC_BADCVAL(fc) + w[idec] = FC_BADCVAL(fc) + return + } + z = sqrt (u) + s = z * y / FC_RODEG(fc) + if (s < -1.0d0 || s > 1.0d0) { + w[ira] = FC_BADCVAL(fc) + w[idec] = FC_BADCVAL(fc) + return + } + xp = 2.0d0 * z * z - 1.0d0 + yp = z * x * FC_C4(fc) + if (xp == 0.0d0 && yp == 0.0d0) + phi = 0.0d0 + else + phi = 2.0d0 * atan2 (yp, xp) + + # Compute THETA. + theta = asin (s) + + # Compute the celestial coordinates RA and DEC from the native + # coordinates PHI and THETA. This is the spherical geometry part + # of the computation. + + costhe = cos (theta) + sinthe = sin (theta) + dphi = phi - FC_LONGP(fc) + cosphi = cos (dphi) + sinphi = sin (dphi) + + # Compute the RA. + x = sinthe * FC_SINDEC(fc) - costhe * FC_COSDEC(fc) * cosphi + if (abs (x) < FC_SPHTOL(fc)) + x = -cos (theta + FC_NATDEC(fc)) + costhe * FC_COSDEC(fc) * + (1.0d0 - cosphi) + y = -costhe * sinphi + if (x != 0.0d0 || y != 0.0d0) { + dlng = atan2 (y, x) + } else { + dlng = dphi + DPI + } + ra = DRADTODEG (FC_NATRA(fc) + dlng) + + # Normalize the RA. + if (FC_NATRA(fc) >= 0.0d0) { + if (ra < 0.0d0) + ra = ra + 360.0d0 + } else { + if (ra > 0.0d0) + ra = ra - 360.0d0 + } + if (ra > 360.0d0) + ra = ra - 360.0d0 + else if (ra < -360.0d0) + ra = ra + 360.0d0 + + # Compute the DEC. + if (mod (dphi, DPI) == 0.0d0) { + dec = DRADTODEG(theta + cosphi * FC_NATDEC(fc)) + if (dec > 90.0d0) + dec = 180.0d0 - dec + if (dec < -90.0d0) + dec = -180.0d0 - dec + } else { + z = sinthe * FC_COSDEC(fc) + costhe * FC_SINDEC(fc) * cosphi + if (abs(z) > 0.99d0) { + if (z >= 0.0d0) + dec = DRADTODEG(acos (sqrt(x * x + y * y))) + else + dec = DRADTODEG(-acos (sqrt(x * x + y * y))) + } else + dec = DRADTODEG(asin (z)) + } + + # Store the results. + w[ira] = ra + w[idec] = dec +end + + +# WF_AIT_INV -- Inverse transform (world to physical) for the Hammer-Aitoff +# projection. + +procedure wf_ait_inv (fc, w, p) + +pointer fc #I pointer to FC descriptor +double w[2] #I input world (RA, DEC) coordinates +double p[2] #I output physical coordinates + +int ira, idec +double ra, dec, cosdec, sindec, cosra, sinra, x, y, phi, theta, costhe, wconst +double dphi, z + +begin + # Get the axes numbers. + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + # Compute the transformation from celestial coordinates RA and + # DEC to native coordinates PHI and THETA. This is the spherical + # geometry part of the transformation. + + ra = DDEGTORAD (w[ira]) - FC_NATRA(fc) + dec = DDEGTORAD (w[idec]) + cosra = cos (ra) + sinra = sin (ra) + cosdec = cos (dec) + sindec = sin (dec) + + # Compute PHI. + x = sindec * FC_SINDEC(fc) - cosdec * FC_COSDEC(fc) * cosra + if (abs(x) < FC_SPHTOL(fc)) + x = -cos (dec + FC_NATDEC(fc)) + cosdec * FC_COSDEC(fc) * + (1.0d0 - cosra) + y = -cosdec * sinra + if (x != 0.0d0 || y != 0.0d0) + dphi = atan2 (y, x) + else + dphi = ra - DPI + phi = FC_LONGP(fc) + dphi + if (phi > DPI) + phi = phi - DTWOPI + else if (phi < -DPI) + phi = phi + DTWOPI + + # Compute THETA. + if (mod (ra, DPI) == 0.0) { + theta = dec + cosra * FC_NATDEC(fc) + if (theta > DHALFPI) + theta = DPI - theta + if (theta < -DHALFPI) + theta = -DPI - theta + } else { + z = sindec * FC_COSDEC(fc) + cosdec * FC_SINDEC(fc) * cosra + if (abs (z) > 0.99d0) { + if (z >= 0.0) + theta = acos (sqrt(x * x + y * y)) + else + theta = -acos (sqrt(x * x + y * y)) + } else + theta = asin (z) + } + + # Compute the transformation from native coordinates PHI and THETA + # to projected coordinates X and Y. + + costhe = cos (theta) + wconst = sqrt (FC_C1(fc) / (1.0d0 + costhe * cos (phi / 2.0d0))) + p[ira] = 2.0d0 * wconst * costhe * sin (phi / 2.0d0) + p[idec] = wconst * sin (theta) +end diff --git a/sys/mwcs/wfarc.x b/sys/mwcs/wfarc.x new file mode 100644 index 00000000..46b072b6 --- /dev/null +++ b/sys/mwcs/wfarc.x @@ -0,0 +1,166 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +.help WFARC +.nf ------------------------------------------------------------------------- +WFARC -- WCS function driver for the arc projection. + +Driver routines: + + FN_INIT wf_arc_init (fc, dir) + FN_DESTROY (none) + FN_FWD wf_arc_fwd (fc, v1, v2) + FN_INV wf_arc_inv (fc, v1, v2) + +.endhelp -------------------------------------------------------------------- + +# Driver specific fields of function call (FC) descriptor. +define FC_IRA Memi[$1+FCU] # RA axis (1 or 2) +define FC_IDEC Memi[$1+FCU+1] # DEC axis (1 or 2) +define FC_COSDEC Memd[P2D($1+FCU+2)] # cosine(dec) +define FC_SINDEC Memd[P2D($1+FCU+4)] # sine(dec) +define FC_W Memd[P2D($1+FCU+6)+($2)-1] # W (CRVAL) for each axis + + +# WF_ARC_INIT -- Initialize the arc forward or inverse transform. +# Initialization for this transformation consists of determining which axis +# is RA and which is DEC, and precomputing the sine and cosine of the +# declination at the reference point. In order to determine the axis order, +# the parameter "axtype={ra|dec}" must have been set in the attribute list +# for the function. +# NOTE: This is identical to wf_tan_init. + +procedure wf_arc_init (fc, dir) + +pointer fc #I pointer to FC descriptor +int dir #I direction of transform + +int i +double dec +pointer ct, mw, wp, wv +errchk wf_decaxis + +begin + ct = FC_CT(fc) + mw = CT_MW(ct) + wp = FC_WCS(fc) + + # Determine which is the DEC axis, and hence the axis order. + call wf_decaxis (fc, FC_IRA(fc), FC_IDEC(fc)) + + # Get the value of W for each axis, i.e., the world coordinate at + # the reference point. + + wv = MI_DBUF(mw) + WCS_W(wp) - 1 + do i = 1, 2 + FC_W(fc,i) = Memd[wv+CT_AXIS(ct,FC_AXIS(fc,i))-1] + + # Precompute the sin and cos of the declination at the reference pixel. + dec = DEGTORAD(FC_W(fc,FC_IDEC(fc))) + FC_COSDEC(fc) = cos(dec) + FC_SINDEC(fc) = sin(dec) +end + + +# WF_ARC_FWD -- Forward transform (physical to world), arc +# projection. Based on code from STScI, Hodge et al. + +procedure wf_arc_fwd (fc, p, w) + +pointer fc #I pointer to FC descriptor +double p[2] #I physical coordinates (xi, eta) +double w[2] #O world coordinates (ra, dec) + +int ira, idec +double xi, eta, x, y, z, ra, dec +double theta # distance (radians) from ref pixel to object +double v[3] # unit vector with v[1] pointing toward ref pixel + +begin + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + xi = DEGTORAD(p[ira]) + eta = DEGTORAD(p[idec]) + + theta = sqrt (xi*xi + eta*eta) + 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 + v[3] = sin (theta) / theta * eta + } + + # Rotate the rectangular coordinate system of the vector v by the + # declination so the X axis will pass through the equator. + + x = v[1] * FC_COSDEC(fc) - v[3] * FC_SINDEC(fc) + y = v[2] + z = v[1] * FC_SINDEC(fc) + v[3] * FC_COSDEC(fc) + + if (x == 0.d0 && y == 0.d0) + ra = 0.d0 + else + ra = atan2 (y, x) + dec = atan2 (z, sqrt (x*x + y*y)) + + # Return RA and DEC in degrees. + dec = RADTODEG(dec) + ra = RADTODEG(ra) + FC_W(fc,ira) + + if (ra < 0.d0) + ra = ra + 360.D0 + else if (ra > 360.D0) + ra = ra - 360.D0 + + w[ira] = ra + w[idec] = dec +end + + +# WF_ARC_INV -- Inverse transform (world to physical) for the arc +# projection. Based on code from Eric Greisen, AIPS Memo No. 27. + +procedure wf_arc_inv (fc, w, p) + +pointer fc #I pointer to FC descriptor +double w[2] #I input world (RA, DEC) coordinates +double p[2] #O output physical coordinates + +int ira, idec +double ra, dec, xi, eta +double cosra, cosdec, sinra, sindec +double theta # distance (radians) from ref pixel to object +double r # theta / sin (theta) + +begin + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + ra = DEGTORAD (w[ira] - FC_W(fc,ira)) + dec = DEGTORAD (w[idec]) + + cosra = cos (ra) + sinra = sin (ra) + + cosdec = cos (dec) + sindec = sin (dec) + + theta = acos (sindec * FC_SINDEC(fc) + cosdec * FC_COSDEC(fc) * cosra) + if (theta == 0.d0) + r = 1.d0 + else + r = theta / sin (theta) + + xi = r * cosdec * sinra + eta = r * (sindec * FC_COSDEC(fc) - cosdec * FC_SINDEC(fc) * cosra) + + p[ira] = RADTODEG(xi) + p[idec] = RADTODEG(eta) +end + diff --git a/sys/mwcs/wfcar.x b/sys/mwcs/wfcar.x new file mode 100644 index 00000000..a09281ac --- /dev/null +++ b/sys/mwcs/wfcar.x @@ -0,0 +1,437 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +.help WFCAR +.nf ------------------------------------------------------------------------- +WFCAR -- WCS function driver for the cylindrical cartesian projection. + +Driver routines: + + FN_INIT wf_car_init (fc, dir) + FN_DESTROY (none) + FN_FWD wf_car_fwd (fc, v1, v2) + FN_INV wf_car_inv (fc, v1, v2) + +.endhelp -------------------------------------------------------------------- + +# Driver specific fields of function call (FC) descriptor. +define FC_IRA Memi[$1+FCU] # RA axis (1 or 2) +define FC_IDEC Memi[$1+FCU+1] # DEC axis (1 or 2) +define FC_NATRA Memd[P2D($1+FCU+2)] # RA of native pole (rads) +define FC_NATDEC Memd[P2D($1+FCU+4)] # DEC of native pole (rads) +define FC_LONGP Memd[P2D($1+FCU+6)] # LONGPOLE (rads) +define FC_COSDEC Memd[P2D($1+FCU+8)] # cosine (NATDEC) +define FC_SINDEC Memd[P2D($1+FCU+10)] # sine (NATDEC) +define FC_SPHTOL Memd[P2D($1+FCU+12)] # trig tolerance +define FC_RODEG Memd[P2D($1+FCU+14)] # RO (degs) +define FC_RECRODEG Memd[P2D($1+FCU+16)] # 1.0 / RO +define FC_BADCVAL Memd[P2D($1+FCU+18)] # bad coordinate value +define FC_W Memd[P2D($1+FCU+20)+($2)-1] # CRVAL axis (1 and 2) + + +# WF_CAR_INIT -- Initialize the cylindical cartesian forward or inverse +# transform. Initialization for this transformation consists of, determining +# which axis is RA / LON and which is DEC / LAT, reading in the the native +# longitude and latitude of the pole in celestial coordinates LONGPOLE and +# LATPOLE from the attribute list, computing the celestial longitude and +# colatitude of the native pole, precomputing the Euler angles and various +# intermediary functions derived from the reference point, and reading in the +# projection parameter RO from the attribute list. If LONGPOLE is undefined +# then a value of 180.0 degrees is assumed if the celestial latitude of the +# reference point is less than 0, otherwise 0 is assumed. If LATPOLE is +# undefined than the most northerly of the two possible solutions for the +# latitude of the native pole is chosen, otherwise the solution closest to +# LATPOLE is chosen. If RO is undefined a value of 180.0 / PI is assumed. +# In order to determine the axis order, the parameter "axtype={ra|dec} +# {xlon|xlat}" must have been set in the attribute list for the function. +# The LONGPOLE, LATPOLE, and RO parameters may be set in either or both of +# the axes attribute lists, but the value in the RA axis attribute list takes +# precedence. + +procedure wf_car_init (fc, dir) + +pointer fc #I pointer to FC descriptor +int dir #I direction of transform + +int i +double dec, latpole, theta0, clat0, slat0, cphip, sphip, cthe0, sthe0, x, y, z +double u, v, latp1, latp2, latp, maxlat, tol +pointer sp, atvalue, ct, mw, wp, wv +int ctod() +data tol/1.0d-10/ +errchk wf_decaxis(), mw_gwattrs() + +begin + # Allocate space for the attribute string. + call smark (sp) + call salloc (atvalue, SZ_LINE, TY_CHAR) + + # Get the required mwcs pointers. + ct = FC_CT(fc) + mw = CT_MW(ct) + wp = FC_WCS(fc) + + # Determine which is the DEC axis, and hence the axis order. + call wf_decaxis (fc, FC_IRA(fc), FC_IDEC(fc)) + + # Get the value of W for each axis, i.e. the world coordinates at + # the reference point. + + wv = MI_DBUF(mw) + WCS_W(wp) - 1 + do i = 1, 2 + FC_W(fc,i) = Memd[wv+CT_AXIS(ct,FC_AXIS(fc,i))-1] + + # Determine the native longitude and latitude of the pole of the + # celestial coordinate system corresponding to the FITS keywords + # LONGPOLE and LATPOLE. LONGPOLE has no default but will be set + # to 180 or 0 depending on the value of the declination of the + # reference point. LATPOLE has no default but will be set depending + # on the values of LONGPOLE and the reference declination. + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "longpole", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "longpole", Memc[atvalue], + SZ_LINE) + } then { + FC_LONGP(fc) = INDEFD + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_LONGP(fc)) <= 0) + FC_LONGP(fc) = INDEFD + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_LONGP(fc)) <= 0) + FC_LONGP(fc) = INDEFD + } + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "latpole", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "latpole", Memc[atvalue], + SZ_LINE) + } then { + latpole = INDEFD + } else { + i = 1 + if (ctod (Memc[atvalue], i, latpole) <= 0) + latpole = INDEFD + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, latpole) <= 0) + latpole = INDEFD + } + + # Fetch the RO projection parameter which is the radius of the + # generating sphere for the projection. If RO is absent which + # is the usual case set it to 180 / PI. Search both axes for + # this quantity. + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "ro", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "ro", Memc[atvalue], + SZ_LINE) + } then { + FC_RODEG(fc) = 180.0d0 / DPI + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_RODEG(fc)) <= 0) + FC_RODEG(fc) = 180.0d0 / DPI + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_RODEG(fc)) <= 0) + FC_RODEG(fc) = 180.0d0 / DPI + } + + # Compute the native longitude of the celestial pole. + dec = DDEGTORAD(FC_W(fc,FC_IDEC(fc))) + theta0 = 0.0d0 + if (IS_INDEFD(FC_LONGP(fc))) { + if (dec < theta0) + FC_LONGP(fc) = DPI + else + FC_LONGP(fc) = 0.0d0 + } else + FC_LONGP(fc) = DDEGTORAD(FC_LONGP(fc)) + + # Compute the celestial longitude and latitude of the native pole. + clat0 = cos (dec) + slat0 = sin (dec) + cphip = cos (FC_LONGP(fc)) + sphip = sin (FC_LONGP(fc)) + cthe0 = cos (theta0) + sthe0 = sin (theta0) + + x = cthe0 * cphip + y = sthe0 + z = sqrt (x * x + y * y) + + # The latitude of the native pole is determined by LATPOLE in this + # case. + if (z == 0.0d0) { + + if (slat0 != 0.0d0) + call error (0, "WF_CAR_INIT: Invalid projection parameters") + if (IS_INDEFD(latpole)) + latp = 999.0d0 + else + latp = DDEGTORAD(latpole) + + } else { + if (abs (slat0 / z) > 1.0d0) + call error (0, "WF_CAR_INIT: Invalid projection parameters") + + u = atan2 (y, x) + v = acos (slat0 / z) + latp1 = u + v + if (latp1 > DPI) + latp1 = latp1 - DTWOPI + else if (latp1 < -DPI) + latp1 = latp1 + DTWOPI + + latp2 = u - v + if (latp2 > DPI) + latp2 = latp2 - DTWOPI + else if (latp2 < -DPI) + latp2 = latp2 + DTWOPI + + if (IS_INDEFD(latpole)) + maxlat = 999.0d0 + else + maxlat = DDEGTORAD(latpole) + if (abs (maxlat - latp1) < abs (maxlat - latp2)) { + if (abs (latp1) < (DHALFPI + tol)) + latp = latp1 + else + latp = latp2 + } else { + if (abs (latp2) < (DHALFPI + tol)) + latp = latp2 + else + latp = latp1 + } + } + + FC_NATDEC(fc) = DHALFPI - latp + + z = cos (latp) * clat0 + if (abs(z) < tol) { + + # Celestial pole at the reference point. + if (abs(clat0) < tol) { + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) + FC_NATDEC(fc) = DHALFPI - theta0 + # Celestial pole at the native north pole. + } else if (latp > 0.0d0) { + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) + FC_LONGP(fc) - + DPI + FC_NATDEC(fc) = 0.0d0 + # Celestial pole at the native south pole. + } else if (latp < 0.0d0) { + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) - FC_LONGP(fc) + FC_NATDEC(fc) = DPI + } + + } else { + x = (sthe0 - sin (latp) * slat0) / z + y = sphip * cthe0 / clat0 + if (x == 0.0d0 && y == 0.0d0) + call error (0, "WF_CAR_INIT: Invalid projection parameters") + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) - atan2 (y,x) + } + + if (FC_W(fc,FC_IRA(fc)) >= 0.0d0) { + if (FC_NATRA(fc) < 0.0d0) + FC_NATRA(fc) = FC_NATRA(fc) + DTWOPI + } else { + if (FC_NATRA(fc) > 0.0d0) + FC_NATRA(fc) = FC_NATRA(fc) - DTWOPI + } + FC_COSDEC(fc) = cos (FC_NATDEC(fc)) + FC_SINDEC(fc) = sin (FC_NATDEC(fc)) + + # Check for ill-conditioned parameters. + if (abs(latp) > (DHALFPI+tol)) + call error (0, "WF_CAR_INIT: Invalid projection parameters") + + # Compute the required intermediate quantities. + FC_RECRODEG(fc) = 1.0d0 / FC_RODEG(fc) + + # Set the bad coordinate value. + FC_SPHTOL(fc) = 1.0d-5 + + # Set the bad coordinate value. + FC_BADCVAL(fc) = INDEFD + + # Free working space. + call sfree (sp) +end + + +# WF_CAR_FWD -- Forward transform (physical to world) for the cartesian +# projection. + +procedure wf_car_fwd (fc, p, w) + +pointer fc #I pointer to FC descriptor +double p[2] #I physical coordinates (x, y) +double w[2] #O world coordinates (ra, dec) + +int ira, idec +double x, y, phi, theta, costhe, sinthe, dphi, cosphi, sinphi, ra, dec +double dlng, z + +begin + # Get the axis numbers. + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + # Compute native spherical coordinates PHI and THETA in degrees from + # the projected coordinates. This is the projection part of the + # computation. + + x = p[ira] + y = p[idec] + + # Compute PHI. + phi = FC_RECRODEG(fc) * x + + # Compute THETA. + theta = FC_RECRODEG(fc) * y + + # Compute the celestial coordinates RA and DEC from the native + # coordinates PHI and THETA. This is the spherical geometry part + # of the computation. + + costhe = cos (theta) + sinthe = sin (theta) + dphi = phi - FC_LONGP(fc) + cosphi = cos (dphi) + sinphi = sin (dphi) + + # Compute the RA. + x = sinthe * FC_SINDEC(fc) - costhe * FC_COSDEC(fc) * cosphi + if (abs (x) < FC_SPHTOL(fc)) + x = -cos (theta + FC_NATDEC(fc)) + costhe * FC_COSDEC(fc) * + (1.0d0 - cosphi) + y = -costhe * sinphi + if (x != 0.0d0 || y != 0.0d0) { + dlng = atan2 (y, x) + } else { + dlng = dphi + DPI + } + ra = DRADTODEG( FC_NATRA(fc) + dlng) + + # Normalize the RA. + if (FC_NATRA(fc) >= 0.0d0) { + if (ra < 0.0d0) + ra = ra + 360.0d0 + } else { + if (ra > 0.0d0) + ra = ra - 360.0d0 + } + if (ra > 360.0d0) + ra = ra - 360.0d0 + else if (ra < -360.0d0) + ra = ra + 360.0d0 + + # Compute the DEC. + if (mod (dphi, DPI) == 0.0d0) { + dec = DRADTODEG(theta + cosphi * FC_NATDEC(fc)) + if (dec > 90.0d0) + dec = 180.0d0 - dec + if (dec < -90.0d0) + dec = -180.0d0 - dec + } else { + z = sinthe * FC_COSDEC(fc) + costhe * FC_SINDEC(fc) * cosphi + if (abs(z) > 0.99d0) { + if (z >= 0.0d0) + dec = DRADTODEG(acos (sqrt(x * x + y * y))) + else + dec = DRADTODEG(-acos (sqrt(x * x + y * y))) + } else + dec = DRADTODEG(asin (z)) + } + + # Store the results. + w[ira] = ra + w[idec] = dec +end + + +# WF_CAR_INV -- Inverse transform (world to physical) for the cartesian +# projection. + +procedure wf_car_inv (fc, w, p) + +pointer fc #I pointer to FC descriptor +double w[2] #I input world (RA, DEC) coordinates +double p[2] #I output physical coordinates + +int ira, idec +double ra, dec, cosdec, sindec, cosra, sinra, x, y, phi, theta, z, dphi + +begin + # Get the axes numbers. + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + # Compute the transformation from celestial coordinates RA and + # DEC to native coordinates PHI and THETA. This is the spherical + # geometry part of the transformation. + + ra = DDEGTORAD (w[ira]) - FC_NATRA(fc) + dec = DDEGTORAD (w[idec]) + cosra = cos (ra) + sinra = sin (ra) + cosdec = cos (dec) + sindec = sin (dec) + + # Compute PHI. + x = sindec * FC_SINDEC(fc) - cosdec * FC_COSDEC(fc) * cosra + if (abs(x) < FC_SPHTOL(fc)) + x = -cos (dec + FC_NATDEC(fc)) + cosdec * FC_COSDEC(fc) * + (1.0d0 - cosra) + y = -cosdec * sinra + if (x != 0.0d0 || y != 0.0d0) + dphi = atan2 (y, x) + else + dphi = ra - DPI + phi = FC_LONGP(fc) + dphi + if (phi > DPI) + phi = phi - DTWOPI + else if (phi < -DPI) + phi = phi + DTWOPI + + # Compute THETA. + if (mod (ra, DPI) == 0.0) { + theta = dec + cosra * FC_NATDEC(fc) + if (theta > DHALFPI) + theta = DPI - theta + if (theta < -DHALFPI) + theta = -DPI - theta + } else { + z = sindec * FC_COSDEC(fc) + cosdec * FC_SINDEC(fc) * cosra + if (abs (z) > 0.99d0) { + if (z >= 0.0) + theta = acos (sqrt(x * x + y * y)) + else + theta = -acos (sqrt(x * x + y * y)) + } else + theta = asin (z) + } + + # Compute the transformation from native coordinates PHI and THETA + # to projected coordinates X and Y. + + p[ira] = FC_RODEG(fc) * phi + p[idec] = FC_RODEG(fc) * theta +end diff --git a/sys/mwcs/wfcsc.x b/sys/mwcs/wfcsc.x new file mode 100644 index 00000000..3dedc178 --- /dev/null +++ b/sys/mwcs/wfcsc.x @@ -0,0 +1,624 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +.help WFCSC +.nf ------------------------------------------------------------------------- +WFCSC -- WCS function driver for the COBE quadrilateratized cube projection. + +Driver routines: + + FN_INIT wf_csc_init (fc, dir) + FN_DESTROY (none) + FN_FWD wf_csc_fwd (fc, v1, v2) + FN_INV wf_csc_inv (fc, v1, v2) + +.endhelp -------------------------------------------------------------------- + +# Driver specific fields of function call (FC) descriptor. +define FC_IRA Memi[$1+FCU] # RA axis (1 or 2) +define FC_IDEC Memi[$1+FCU+1] # DEC axis (1 or 2) +define FC_NATRA Memd[P2D($1+FCU+2)] # RA of native pole (rads) +define FC_NATDEC Memd[P2D($1+FCU+4)] # DEC of native pole (rads) +define FC_LONGP Memd[P2D($1+FCU+6)] # LONGPOLE (rads) +define FC_COSDEC Memd[P2D($1+FCU+8)] # cosine (NATDEC) +define FC_SINDEC Memd[P2D($1+FCU+10)] # sine (NATDEC) +define FC_SPHTOL Memd[P2D($1+FCU+12)] # trig tolerance +define FC_RODEG Memd[P2D($1+FCU+14)] # RO (degs) +define FC_C1 Memd[P2D($1+FCU+16)] # RO * (PI / 4) +define FC_C2 Memd[P2D($1+FCU+18)] # (4 / PI) * RO +define FC_BADCVAL Memd[P2D($1+FCU+20)] # bad coordinate value +define FC_W Memd[P2D($1+FCU+22)+($2)-1] # CRVAL axis (1 and 2) + + +# WF_CSC_INIT -- Initialize the forward or inverse Cobe quadrilateralized +# forward or inverse transform. Initialization for this transformation consists +# of, determining which axis is RA / LON and which is DEC / LAT, reading in the +# native longitude and latitude of the pole in celestial coordinates LONGPOLE +# and LATPOLE from the attribute list, computing the celestial longitude and +# colatitude of the native pole, Euler angles and various intermediary +# functions of the reference point reading in the projection parameter RO from +# the attribute list, and precomputing the various required intermediate +# quantities. If LONGPOLE is undefined then a value of 180.0 degrees is assumed +# if the celestial latitude is less than 0, otherwise 0 degrees is assumed. +# If RO is undefined a value of 180.0 / PI is assumed. In order to determine +# the axis order, the parameter "axtype={ra|dec} {xlon|ylat}" must have been +# set in the attribute list for the function. The LONGPOLE, LATPOLE and RO +# parameters may be set in either or both of the axes attribute lists, but the +# value in the RA axis attribute list takes precedence. + +procedure wf_csc_init (fc, dir) + +pointer fc #I pointer to FC descriptor +int dir #I direction of transform + +int i +double dec, latpole, theta0, clat0, slat0, cphip, sphip, cthe0, sthe0, x, y, z +double u, v, latp1, latp2, latp, maxlat, tol +pointer sp, atvalue, ct, mw, wp, wv +int ctod() +data tol/1.0d-10/ +errchk wf_decaxis(), mw_gwattrs() + +begin + # Allocate space for the attribute string. + call smark (sp) + call salloc (atvalue, SZ_LINE, TY_CHAR) + + # Get the required mwcs pointers. + ct = FC_CT(fc) + mw = CT_MW(ct) + wp = FC_WCS(fc) + + # Determine which is the DEC axis, and hence the axis order. + call wf_decaxis (fc, FC_IRA(fc), FC_IDEC(fc)) + + # Get the value of W for each axis, i.e. the world coordinates at + # the reference point. + + wv = MI_DBUF(mw) + WCS_W(wp) - 1 + do i = 1, 2 + FC_W(fc,i) = Memd[wv+CT_AXIS(ct,FC_AXIS(fc,i))-1] + + # Determine the native longitude and latitude of the pole of the + # celestial coordinate system corresponding to the FITS keywords + # LONGPOLE and LATPOLE. LONGPOLE has no default but will be set + # to 180 or 0 depending on the value of the declination of the + # reference point. LATPOLE has no default but will be set depending + # on the values of LONGPOLE and the reference declination. + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "longpole", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "longpole", Memc[atvalue], + SZ_LINE) + } then { + FC_LONGP(fc) = INDEFD + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_LONGP(fc)) <= 0) + FC_LONGP(fc) = INDEFD + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_LONGP(fc)) <= 0) + FC_LONGP(fc) = INDEFD + } + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "latpole", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "latpole", Memc[atvalue], + SZ_LINE) + } then { + latpole = INDEFD + } else { + i = 1 + if (ctod (Memc[atvalue], i, latpole) <= 0) + latpole = INDEFD + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, latpole) <= 0) + latpole = INDEFD + } + + + + # Fetch the RO projection parameter which is the radius of the + # generating sphere for the projection. If RO is absent which + # is the usual case set it to 180 / PI. Search both axes for + # this quantity. + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "ro", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "ro", Memc[atvalue], + SZ_LINE) + } then { + FC_RODEG(fc) = 180.0d0 / DPI + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_RODEG(fc)) <= 0) + FC_RODEG(fc) = 180.0d0 / DPI + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_RODEG(fc)) <= 0) + FC_RODEG(fc) = 180.0d0 / DPI + } + + # Compute the native longitude of the celestial pole. + dec = DDEGTORAD(FC_W(fc,FC_IDEC(fc))) + theta0 = 0.0d0 + if (IS_INDEFD(FC_LONGP(fc))) { + if (dec < theta0) + FC_LONGP(fc) = DPI + else + FC_LONGP(fc) = 0.0d0 + } else + FC_LONGP(fc) = DDEGTORAD(FC_LONGP(fc)) + + # Compute the celestial longitude and latitude of the native pole. + clat0 = cos (dec) + slat0 = sin (dec) + cphip = cos (FC_LONGP(fc)) + sphip = sin (FC_LONGP(fc)) + cthe0 = cos (theta0) + sthe0 = sin (theta0) + + x = cthe0 * cphip + y = sthe0 + z = sqrt (x * x + y * y) + + # The latitude of the native pole is determined by LATPOLE in this + # case. + if (z == 0.0d0) { + + if (slat0 != 0.0d0) + call error (0, "WF_CSC_INIT: Invalid projection parameters") + if (IS_INDEFD(latpole)) + latp = 999.0d0 + else + latp = DDEGTORAD(latpole) + + } else { + if (abs (slat0 / z) > 1.0d0) + call error (0, "WF_CSC_INIT: Invalid projection parameters") + + u = atan2 (y, x) + v = acos (slat0 / z) + latp1 = u + v + if (latp1 > DPI) + latp1 = latp1 - DTWOPI + else if (latp1 < -DPI) + latp1 = latp1 + DTWOPI + + latp2 = u - v + if (latp2 > DPI) + latp2 = latp2 - DTWOPI + else if (latp2 < -DPI) + latp2 = latp2 + DTWOPI + + + if (IS_INDEFD(latpole)) + maxlat = 999.0d0 + else + maxlat = DDEGTORAD(latpole) + if (abs (maxlat - latp1) < abs (maxlat - latp2)) { + if (abs (latp1) < (DHALFPI + tol)) + latp = latp1 + else + latp = latp2 + } else { + if (abs (latp2) < (DHALFPI + tol)) + latp = latp2 + else + latp = latp1 + } + } + FC_NATDEC(fc) = DHALFPI - latp + + z = cos (latp) * clat0 + if (abs(z) < tol) { + + # Celestial pole at the reference point. + if (abs(clat0) < tol) { + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) + FC_NATDEC(fc) = DHALFPI - theta0 + # Celestial pole at the native north pole. + } else if (latp > 0.0d0) { + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) + FC_LONGP(fc) - + DPI + FC_NATDEC(fc) = 0.0d0 + # Celestial pole at the native south pole. + } else if (latp < 0.0d0) { + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) - FC_LONGP(fc) + FC_NATDEC(fc) = DPI + } + + } else { + x = (sthe0 - sin (latp) * slat0) / z + y = sphip * cthe0 / clat0 + if (x == 0.0d0 && y == 0.0d0) + call error (0, "WF_CSC_INIT: Invalid projection parameters") + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) - atan2 (y,x) + } + + if (FC_W(fc,FC_IRA(fc)) >= 0.0d0) { + if (FC_NATRA(fc) < 0.0d0) + FC_NATRA(fc) = FC_NATRA(fc) + DTWOPI + } else { + if (FC_NATRA(fc) > 0.0d0) + FC_NATRA(fc) = FC_NATRA(fc) - DTWOPI + } + FC_COSDEC(fc) = cos (FC_NATDEC(fc)) + FC_SINDEC(fc) = sin (FC_NATDEC(fc)) + + # Check for ill-conditioned parameters. + if (abs(latp) > (DHALFPI+tol)) + call error (0, "WF_CSC_INIT: Invalid projection parameters") + + # Compute the required intermediate quantities. + FC_C1(fc) = FC_RODEG(fc) * (DPI / 4.0d0) + FC_C2(fc) = 1.0d0 / FC_C1(fc) + + # Set the bad coordinate value. + FC_SPHTOL(fc) = 1.0d-5 + + # Set the bad coordinate value. + FC_BADCVAL(fc) = INDEFD + + # Free working space. + call sfree (sp) +end + + +# WF_CSC_FWD -- Forward transform (physical to world) for the COBE +# quarilateralized spherical projection. + +procedure wf_csc_fwd (fc, p, w) + +pointer fc #I pointer to FC descriptor +double p[2] #I physical coordinates (x, y) +double w[2] #O world coordinates (ra, dec) + +int ira, idec, face +double l, m, n, phi, theta, costhe, sinthe, dphi, cosphi, sinphi, x, y, z +double ra, dec, dlng +real a, b, xf, xx, yf, yy +real p00, p01, p02, p03, p04, p05, p06, p10, p11, p12, p13, p14, p15, p20 +real p21, p22, p23, p24, p30, p31, p32, p33, p40, p41, p42, p50, p51, p60 +data p00/-.27292696/, p10/-.07629969/, p20/-.22797056/, p30/.54852384/ +data p40/-.62930065/, p50/.25795794/, p60/.02584375/, p01/-.02819452/ +data p11/-.01471565/, p21/.48051509/, p31/-1.74114454/, p41/1.71547508/ +data p51/-.53022337/, p02/.27058160/, p12/-.56800938/, p22/.30803317/ +data p32/.98938102/, p42/-.83180469/, p03/-.60441560/, p13/1.50880086/ +data p23/-.93678576/, p33/.08693841/, p04/.93412077/, p14/-1.41601920/ +data p24/.33887446/, p05/-.63915306/, p15/.52032238/, p06/.14381585/ + + +begin + # Get the axis numbers. + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + # Compute native spherical coordinates PHI and THETA in degrees from + # the projected coordinates. This is the projection part of the + # computation. + + xf = p[ira] * FC_C2(fc) + yf = p[idec] * FC_C2(fc) + if (xf > 5.0) { + face = 4 + xf = xf - 6.0 + } else if (xf > 3.0) { + face = 3 + xf = xf - 4.0 + } else if (xf > 1.0) { + face = 2 + xf = xf - 2.0 + } else if (yf > 1.0) { + face = 0 + yf = yf - 2.0 + } else if (yf < -1.0) { + face = 5 + yf = yf + 2.0 + } else { + face = 1 + } + + xx = xf * xf + yy = yf * yf + a = (p00+xx*(p10+xx*(p20+xx*(p30+xx*(p40+xx*(p50+xx*(p60)))))) + + yy*(p01+xx*(p11+xx*(p21+xx*(p31+xx*(p41+xx*(p51))))) + + yy*(p02+xx*(p12+xx*(p22+xx*(p32+xx*(p42)))) + + yy*(p03+xx*(p13+xx*(p23+xx*(p33))) + + yy*(p04+xx*(p14+xx*(p24)) + + yy*(p05+xx*(p15) + + yy*(p06))))))) + a = xf + xf * (1.0 - xx) * a + b = (p00+yy*(p10+yy*(p20+yy*(p30+yy*(p40+yy*(p50+yy*(p60)))))) + + xx*(p01+yy*(p11+yy*(p21+yy*(p31+yy*(p41+yy*(p51))))) + + xx*(p02+yy*(p12+yy*(p22+yy*(p32+yy*(p42)))) + + xx*(p03+yy*(p13+yy*(p23+yy*(p33))) + + xx*(p04+yy*(p14+yy*(p24)) + + xx*(p05+yy*(p15) + + xx*(p06))))))) + b = yf + yf * (1.0 - yy) * b + + switch (face) { + case 0: + n = 1.0d0 / sqrt (a * a + b * b + 1.0d0) + l = a * n + m = -b * n + case 1: + m = 1.0d0 / sqrt (a * a + b * b + 1.0d0) + l = a * m + n = b * m + case 2: + l = 1.0d0 / sqrt (a * a + b * b + 1.0d0) + m = -a * l + n = b * l + case 3: + m = -1.0d0 / sqrt (a * a + b * b + 1.0d0) + l = a * m + n = -b * m + case 4: + l = -1.0d0 / sqrt (a * a + b * b + 1.0d0) + m = -a * l + n = -b * l + case 5: + n = -1.0d0 / sqrt (a * a + b * b + 1.0d0) + l = -a * n + m = -b * n + } + + # Compute PHI. + if (l == 0.0d0 && m == 0.0d0) + phi = 0.0d0 + else + phi = atan2 (l, m) + + # Compute THETA. + theta = asin(n) + + # Compute the celestial coordinates RA and DEC from the native + # coordinates PHI and THETA. This is the spherical geometry part + # of the computation. + + costhe = cos (theta) + sinthe = sin (theta) + dphi = phi - FC_LONGP(fc) + cosphi = cos (dphi) + sinphi = sin (dphi) + + # Compute the RA. + x = sinthe * FC_SINDEC(fc) - costhe * FC_COSDEC(fc) * cosphi + if (abs (x) < FC_SPHTOL(fc)) + x = -cos (theta + FC_NATDEC(fc)) + costhe * FC_COSDEC(fc) * + (1.0d0 - cosphi) + y = -costhe * sinphi + if (x != 0.0d0 || y != 0.0d0) { + dlng = atan2 (y, x) + } else { + dlng = dphi + DPI + } + ra = DRADTODEG(FC_NATRA(fc) + dlng) + + # Normalize the RA. + if (FC_NATRA(fc) >= 0.0d0) { + if (ra < 0.0d0) + ra = ra + 360.0d0 + } else { + if (ra > 0.0d0) + ra = ra - 360.0d0 + } + if (ra > 360.0d0) + ra = ra - 360.0d0 + else if (ra < -360.0d0) + ra = ra + 360.0d0 + + # Compute the DEC. + if (mod (dphi, DPI) == 0.0d0) { + dec = DRADTODEG(theta + cosphi * FC_NATDEC(fc)) + if (dec > 90.0d0) + dec = 180.0d0 - dec + if (dec < -90.0d0) + dec = -180.0d0 - dec + } else { + z = sinthe * FC_COSDEC(fc) + costhe * FC_SINDEC(fc) * cosphi + if (abs(z) > 0.99d0) { + if (z >= 0.0d0) + dec = DRADTODEG(acos (sqrt(x * x + y * y))) + else + dec = DRADTODEG(-acos (sqrt(x * x + y * y))) + } else + dec = DRADTODEG(asin (z)) + } + + # Store the results. + w[ira] = ra + w[idec] = dec +end + + +# WF_CSC_INV -- Inverse transform (world to physical) for the COBE +# quadilateralized spherical projection. + +procedure wf_csc_inv (fc, w, p) + +pointer fc #I pointer to FC descriptor +double w[2] #I input world (RA, DEC) coordinates +double p[2] #I output physical coordinates + +int ira, idec, face +double ra, dec, cosdec, sindec, cosra, sinra, x, y, z, phi, theta, dphi +double costhe, eta, l, m, n, rho, xi +real tol, a, a2, a2b2, a4, b, b2, b4, ca2, cb2, x0, xf, y0, yf +real c00, c10, c01, c11, c20, c02, d0, d1, mm, gamma, gstar, omega1 +data gstar/1.37484847732/, mm/.004869491981/, gamma/-.13161671474/ +data omega1/-.159596235474/, d0/.0759196200467/, d1/-.0217762490699/ +data c00/.141189631152/, c10/.0809701286525/, c01/-.281528535557/ +data c11/.15384112876/, c20/-.178251207466/, c02/.106959469314/ +data tol /1.0e-7/ + +begin + # Get the axes numbers. + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + # Compute the transformation from celestial coordinates RA and + # DEC to native coordinates PHI and THETA. This is the spherical + # geometry part of the transformation. + + ra = DDEGTORAD (w[ira]) - FC_NATRA(fc) + dec = DDEGTORAD (w[idec]) + cosra = cos (ra) + sinra = sin (ra) + cosdec = cos (dec) + sindec = sin (dec) + + # Compute PHI. + x = sindec * FC_SINDEC(fc) - cosdec * FC_COSDEC(fc) * cosra + if (abs(x) < FC_SPHTOL(fc)) + x = -cos (dec + FC_NATDEC(fc)) + cosdec * FC_COSDEC(fc) * + (1.0d0 - cosra) + y = -cosdec * sinra + if (x != 0.0d0 || y != 0.0d0) + dphi = atan2 (y, x) + else + dphi = ra - DPI + phi = FC_LONGP(fc) + dphi + if (phi > DPI) + phi = phi - DTWOPI + else if (phi < -DPI) + phi = phi + DTWOPI + + # Compute THETA. + if (mod (ra, DPI) == 0.0) { + theta = dec + cosra * FC_NATDEC(fc) + if (theta > DHALFPI) + theta = DPI - theta + if (theta < -DHALFPI) + theta = -DPI - theta + } else { + z = sindec * FC_COSDEC(fc) + cosdec * FC_SINDEC(fc) * cosra + if (abs (z) > 0.99d0) { + if (z >= 0.0) + theta = acos (sqrt(x * x + y * y)) + else + theta = -acos (sqrt(x * x + y * y)) + } else + theta = asin (z) + } + + # Compute the transformation from native coordinates PHI and THETA + # to projected coordinates X and Y. + costhe = cos (theta) + l = costhe * sin (phi) + m = costhe * cos (phi) + n = sin (theta) + + face = 0 + rho = n + if (m > rho) { + face = 1 + rho = m + } + if (l > rho) { + face = 2 + rho = l + } + if (-m > rho) { + face = 3 + rho = -m + } + if (-l > rho) { + face = 4 + rho = -l + } + if (-n > rho) { + face = 5 + rho = -n + } + + switch (face) { + case 0: + xi = l + eta = -m + x0 = 0.0 + y0 = 2.0 + case 1: + xi = l + eta = n + x0 = 0.0 + y0 = 0.0 + case 2: + xi = -m + eta = n + x0 = 2.0 + y0 = 0.0 + case 3: + xi = -l + eta = n + x0 = 4.0 + y0 = 0.0 + case 4: + xi = m + eta = n + x0 = 6.0 + y0 = 0.0 + case 5: + xi = l + eta = m + x0 = 0.0 + y0 = -2.0 + } + + a = xi / rho + b = eta / rho + a2 = a * a + b2 = b * b + a4 = a2 * a2 + b4 = b2 * b2 + a2b2 = a2 * b2 + ca2 = 1.0 - a2 + cb2 = 1.0 - b2 + + xf = a*(a2+ca2*(gstar+b2*(gamma*ca2+mm*a2 + + cb2*(c00+c10*a2+c01*b2+c11*a2b2+c20*a4+c02*b4)) + + a2*(omega1-ca2*(d0+d1*a2)))) + yf = b*(b2+cb2*(gstar+a2*(gamma*cb2+mm*b2 + + ca2*(c00+c10*b2+c01*a2+c11*a2b2+c20*b4+c02*a4)) + + b2*(omega1-cb2*(d0+d1*b2)))) + + if (abs(xf) > 1.0) { + if (abs(xf) > (1.0 + tol)) { + p[ira] = FC_BADCVAL(fc) + p[idec] = FC_BADCVAL(fc) + return + } + if (xf >= 0.0) + xf = 1.0 + else + xf = -1.0 + } + if (abs(yf) > 1.0) { + if (abs(yf) > (1.0 + tol)) { + p[ira] = FC_BADCVAL(fc) + p[idec] = FC_BADCVAL(fc) + return + } + if (yf >= 0.0) + yf = 1.0 + else + yf = -1.0 + } + + p[ira] = FC_C1(fc) * (x0 + xf) + p[idec] = FC_C1(fc) * (y0 + yf) +end diff --git a/sys/mwcs/wfdecaxis.x b/sys/mwcs/wfdecaxis.x new file mode 100644 index 00000000..32c59bd8 --- /dev/null +++ b/sys/mwcs/wfdecaxis.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "mwcs.h" + + +# WF_DECAXIS -- Determine which of the 2 axes for the current function is +# the DEC axis. + +procedure wf_decaxis (fc, ira, idec) + +pointer fc #I pointer to function call descriptor +int ira, idec #O CTRAN relative RA, DEC axis numbers + +pointer ct, mw +int ax[2], i +char axtype[4] +bool streq() + +begin + ct = FC_CT(fc) + mw = CT_MW(ct) + + # This function requires exactly 2 axes. + if (FC_NAXES(fc) != 2) + call error (1, "A projection WCS requires 2 axes") + + # Map FC axis (1 or 2) to CTRAN axis to physical axis. + do i = 1, 2 + ax[i] = CT_AXIS(ct,FC_AXIS(fc,i)) + + # Determine which is the DEC/LAT axis, and hence the axis order. + ira = 0 + idec = 0 + do i = 1, 2 + ifnoerr (call mw_gwattrs (mw, ax[i], "axtype", axtype, 4)) { + call strlwr (axtype) + if (streq (axtype, "ra") || streq (axtype[2], "lon")) { + ira = i + idec = 3 - i + break + } else if (streq (axtype, "dec") || streq (axtype[2], "lat")) { + ira = 3 - i + idec = i + break + } + } + + if (idec == 0) + call error (2, + "DEC/xLAT axis must be specified for a projection WCS") +end diff --git a/sys/mwcs/wfgls.x b/sys/mwcs/wfgls.x new file mode 100644 index 00000000..942cfdd1 --- /dev/null +++ b/sys/mwcs/wfgls.x @@ -0,0 +1,442 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +.help WFGLS +.nf ------------------------------------------------------------------------- +WFGLS -- WCS function driver for the Sanson-Flamsteed sinusoidal projection. + +Driver routines: + + FN_INIT wf_gls_init (fc, dir) + FN_DESTROY (none) + FN_FWD wf_gls_fwd (fc, v1, v2) + FN_INV wf_gls_inv (fc, v1, v2) + +.endhelp -------------------------------------------------------------------- + +# Driver specific fields of function call (FC) descriptor. +define FC_IRA Memi[$1+FCU] # RA axis (1 or 2) +define FC_IDEC Memi[$1+FCU+1] # DEC axis (1 or 2) +define FC_NATRA Memd[P2D($1+FCU+2)] # RA of native pole (rads) +define FC_NATDEC Memd[P2D($1+FCU+4)] # DEC of native pole (rads) +define FC_LONGP Memd[P2D($1+FCU+6)] # LONGPOLE (rads) +define FC_COSDEC Memd[P2D($1+FCU+8)] # cosine (NATDEC) +define FC_SINDEC Memd[P2D($1+FCU+10)] # sine (NATDEC) +define FC_SPHTOL Memd[P2D($1+FCU+12)] # trig tolerance +define FC_RODEG Memd[P2D($1+FCU+14)] # RO (degs) +define FC_RECRODEG Memd[P2D($1+FCU+16)] # 1 / RO (degs) +define FC_BADCVAL Memd[P2D($1+FCU+18)] # bad coordinate value +define FC_W Memd[P2D($1+FCU+20)+($2)-1] # CRVAL axis (1 and 2) + + +# WF_GLS_INIT -- Initialize the forward or inverse Sanson-Flamsteed global +# sinusoidal transform. Initialization for this transformation consists of, +# determining which axis is RA / LON and which is DEC / LAT, reading in the +# ative longitudend latitude of the pole in celestial coordinates LONGPOLE +# and LATPOLE from the attribute list, computing the celestial longitude and +# colatitude of the native pole, precomputing the Euler angles and various +# intermediary functions of the reference point, reading in the projection +# parameter RO from the attribute list, and precomputing the various required +# intermediate quantities. If LONGPOLE is undefined then a value of 180.0 +# degrees is assumed if the native latitude of the reference point is less +# than 0, otherwise 0 degrees is assumed. If LATPOLE is undefined then the +# most northerly of the two possible solutions for the latitude of the +# native pole is chosen. If RO is undefined a value of 180.0 / PI is assumed. +# In order to determine the axis order, the parameter "axtype={ra|dec} +# {xlon|xlat}" must have been set in the attribute list for the function. +# The LONGPOLE, LATPOLE, and RO parameters may be set in either or both of +# the axes attribute lists, but the value in the RA axis attribute list +# takes precedence. + +procedure wf_gls_init (fc, dir) + +pointer fc #I pointer to FC descriptor +int dir #I direction of transform + +int i +double dec, latpole, theta0, clat0, slat0, cphip, sphip, cthe0, sthe0, x, y, z +double u, v, latp1, latp2, latp, maxlat, tol +pointer sp, atvalue, ct, mw, wp, wv +int ctod() +data tol/1.0d-10/ +errchk wf_decaxis(), mw_gwattrs() + +begin + # Allocate space for the attribute string. + call smark (sp) + call salloc (atvalue, SZ_LINE, TY_CHAR) + + # Get the required mwcs pointers. + ct = FC_CT(fc) + mw = CT_MW(ct) + wp = FC_WCS(fc) + + # Determine which is the DEC axis, and hence the axis order. + call wf_decaxis (fc, FC_IRA(fc), FC_IDEC(fc)) + + # Get the value of W for each axis, i.e. the world coordinates at + # the reference point. + + wv = MI_DBUF(mw) + WCS_W(wp) - 1 + do i = 1, 2 + FC_W(fc,i) = Memd[wv+CT_AXIS(ct,FC_AXIS(fc,i))-1] + + # Determine the native longitude and latitude of the pole of the + # celestial coordinate system corresponding to the FITS keywords + # LONGPOLE and LATPOLE. LONGPOLE has no default but will be set + # to 180 or 0 depending on the value of the declination of the + # reference point. LATPOLE has no default but will be set depending + # on the values of LONGPOLE and the reference declination. + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "longpole", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "longpole", Memc[atvalue], + SZ_LINE) + } then { + FC_LONGP(fc) = INDEFD + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_LONGP(fc)) <= 0) + FC_LONGP(fc) = INDEFD + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_LONGP(fc)) <= 0) + FC_LONGP(fc) = INDEFD + } + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "latpole", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "latpole", Memc[atvalue], + SZ_LINE) + } then { + latpole = INDEFD + } else { + i = 1 + if (ctod (Memc[atvalue], i, latpole) <= 0) + latpole = INDEFD + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, latpole) <= 0) + latpole = INDEFD + } + + # Fetch the RO projection parameter which is the radius of the + # generating sphere for the projection. If RO is absent which + # is the usual case set it to 180 / PI. Search both axes for + # this quantity. + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "ro", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "ro", Memc[atvalue], + SZ_LINE) + } then { + FC_RODEG(fc) = 180.0d0 / DPI + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_RODEG(fc)) <= 0) + FC_RODEG(fc) = 180.0d0 / DPI + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_RODEG(fc)) <= 0) + FC_RODEG(fc) = 180.0d0 / DPI + } + + # Compute the native longitude of the celestial pole. + dec = DDEGTORAD(FC_W(fc,FC_IDEC(fc))) + theta0 = 0.0d0 + if (IS_INDEFD(FC_LONGP(fc))) { + if (dec < theta0) + FC_LONGP(fc) = DPI + else + FC_LONGP(fc) = 0.0d0 + } else + FC_LONGP(fc) = DDEGTORAD(FC_LONGP(fc)) + + # Compute the celestial longitude and latitude of the native pole. + clat0 = cos (dec) + slat0 = sin (dec) + cphip = cos (FC_LONGP(fc)) + sphip = sin (FC_LONGP(fc)) + cthe0 = cos (theta0) + sthe0 = sin (theta0) + + x = cthe0 * cphip + y = sthe0 + z = sqrt (x * x + y * y) + + # The latitude of the native pole is determined by LATPOLE in this + # case. + if (z == 0.0d0) { + + if (slat0 != 0.0d0) + call error (0, "WF_GLS_INIT: Invalid projection parameters") + if (IS_INDEFD(latpole)) + latp = 999.0d0 + else + latp = DDEGTORAD(latpole) + + } else { + if (abs (slat0 / z) > 1.0d0) + call error (0, "WF_GLS_INIT: Invalid projection parameters") + + u = atan2 (y, x) + v = acos (slat0 / z) + latp1 = u + v + if (latp1 > DPI) + latp1 = latp1 - DTWOPI + else if (latp1 < -DPI) + latp1 = latp1 + DTWOPI + + latp2 = u - v + if (latp2 > DPI) + latp2 = latp2 - DTWOPI + else if (latp2 < -DPI) + latp2 = latp2 + DTWOPI + + if (IS_INDEFD(latpole)) + maxlat = 999.0d0 + else + maxlat = DDEGTORAD(latpole) + if (abs (maxlat - latp1) < abs (maxlat - latp2)) { + if (abs (latp1) < (DHALFPI + tol)) + latp = latp1 + else + latp = latp2 + } else { + if (abs (latp2) < (DHALFPI + tol)) + latp = latp2 + else + latp = latp1 + } + } + FC_NATDEC(fc) = DHALFPI - latp + + z = cos (latp) * clat0 + if (abs(z) < tol) { + + # Celestial pole at the reference point. + if (abs(clat0) < tol) { + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) + FC_NATDEC(fc) = DHALFPI - theta0 + # Celestial pole at the native north pole. + } else if (latp > 0.0d0) { + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) + FC_LONGP(fc) - + DPI + FC_NATDEC(fc) = 0.0d0 + # Celestial pole at the native south pole. + } else if (latp < 0.0d0) { + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) - FC_LONGP(fc) + FC_NATDEC(fc) = DPI + } + + } else { + x = (sthe0 - sin (latp) * slat0) / z + y = sphip * cthe0 / clat0 + if (x == 0.0d0 && y == 0.0d0) + call error (0, "WF_GLS_INIT: Invalid projection parameters") + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) - atan2 (y,x) + } + + if (FC_W(fc,FC_IRA(fc)) >= 0.0d0) { + if (FC_NATRA(fc) < 0.0d0) + FC_NATRA(fc) = FC_NATRA(fc) + DTWOPI + } else { + if (FC_NATRA(fc) > 0.0d0) + FC_NATRA(fc) = FC_NATRA(fc) - DTWOPI + } + FC_COSDEC(fc) = cos (FC_NATDEC(fc)) + FC_SINDEC(fc) = sin (FC_NATDEC(fc)) + + # Check for ill-conditioned parameters. + if (abs(latp) > (DHALFPI+tol)) + call error (0, "WF_GLS_INIT: Invalid projection parameters") + + # Compute the required intermediate quantities. + FC_RECRODEG(fc) = 1.0d0 / FC_RODEG(fc) + + # Set the bad coordinate value. + FC_SPHTOL(fc) = 1.0d-5 + + # Set the bad coordinate value. + FC_BADCVAL(fc) = INDEFD + + # Free working space. + call sfree (sp) +end + + +# WF_GLS_FWD -- Forward transform (physical to world) for the Sanson-Flamsteed +# global sinusoidal projection. + +procedure wf_gls_fwd (fc, p, w) + +pointer fc #I pointer to FC descriptor +double p[2] #I physical coordinates (x, y) +double w[2] #O world coordinates (ra, dec) + +int ira, idec +double x, y, wconst, phi, theta, costhe, sinthe, dphi, cosphi, sinphi +double ra, dec, dlng, z + +begin + # Get the axis numbers. + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + # Compute native spherical coordinates PHI and THETA in degrees from + # the projected coordinates. This is the projection part of the + # computation. + + x = p[ira] + y = p[idec] + + # Compute PHI + wconst = cos (y * FC_RECRODEG(fc)) + if (wconst == 0.0d0) + phi = 0.0d0 + else + phi = x * FC_RECRODEG(fc) / wconst + + # Compute THETA. + theta = y * FC_RECRODEG(fc) + + # Compute the celestial coordinates RA and DEC from the native + # coordinates PHI and THETA. This is the spherical geometry part + # of the computation. + + costhe = cos (theta) + sinthe = sin (theta) + dphi = phi - FC_LONGP(fc) + cosphi = cos (dphi) + sinphi = sin (dphi) + + # Compute the RA. + x = sinthe * FC_SINDEC(fc) - costhe * FC_COSDEC(fc) * cosphi + if (abs (x) < FC_SPHTOL(fc)) + x = -cos (theta + FC_NATDEC(fc)) + costhe * FC_COSDEC(fc) * + (1.0d0 - cosphi) + y = -costhe * sinphi + if (x != 0.0d0 || y != 0.0d0) { + dlng = atan2 (y, x) + } else { + dlng = dphi + DPI + } + ra = DRADTODEG(FC_NATRA(fc) + dlng) + + # Normalize the RA. + if (FC_NATRA(fc) >= 0.0d0) { + if (ra < 0.0d0) + ra = ra + 360.0d0 + } else { + if (ra > 0.0d0) + ra = ra - 360.0d0 + } + if (ra > 360.0d0) + ra = ra - 360.0d0 + else if (ra < -360.0d0) + ra = ra + 360.0d0 + + # Compute the DEC. + if (mod (dphi, DPI) == 0.0d0) { + dec = DRADTODEG(theta + cosphi * FC_NATDEC(fc)) + if (dec > 90.0d0) + dec = 180.0d0 - dec + if (dec < -90.0d0) + dec = -180.0d0 - dec + } else { + z = sinthe * FC_COSDEC(fc) + costhe * FC_SINDEC(fc) * cosphi + if (abs(z) > 0.99d0) { + if (z >= 0.0d0) + dec = DRADTODEG(acos (sqrt(x * x + y * y))) + else + dec = DRADTODEG(-acos (sqrt(x * x + y * y))) + } else + dec = DRADTODEG(asin (z)) + } + + # Store the results. + w[ira] = ra + w[idec] = dec +end + + +# WF_GLS_INV -- Inverse transform (world to physical) for the Sanson-Flamsteed +# global sinusoidal projection. + +procedure wf_gls_inv (fc, w, p) + +pointer fc #I pointer to FC descriptor +double w[2] #I input world (RA, DEC) coordinates +double p[2] #I output physical coordinates + +int ira, idec +double ra, dec, cosdec, sindec, cosra, sinra, x, y, z, phi, theta, dphi + +begin + # Get the axes numbers. + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + # Compute the transformation from celestial coordinates RA and + # DEC to native coordinates PHI and THETA. This is the spherical + # geometry part of the transformation. + + ra = DDEGTORAD (w[ira]) - FC_NATRA(fc) + dec = DDEGTORAD (w[idec]) + cosra = cos (ra) + sinra = sin (ra) + cosdec = cos (dec) + sindec = sin (dec) + + # Compute PHI. + x = sindec * FC_SINDEC(fc) - cosdec * FC_COSDEC(fc) * cosra + if (abs(x) < FC_SPHTOL(fc)) + x = -cos (dec + FC_NATDEC(fc)) + cosdec * FC_COSDEC(fc) * + (1.0d0 - cosra) + y = -cosdec * sinra + if (x != 0.0d0 || y != 0.0d0) + dphi = atan2 (y, x) + else + dphi = ra - DPI + phi = FC_LONGP(fc) + dphi + if (phi > DPI) + phi = phi - DTWOPI + else if (phi < -DPI) + phi = phi + DTWOPI + + # Compute THETA. + if (mod (ra, DPI) == 0.0) { + theta = dec + cosra * FC_NATDEC(fc) + if (theta > DHALFPI) + theta = DPI - theta + if (theta < -DHALFPI) + theta = -DPI - theta + } else { + z = sindec * FC_COSDEC(fc) + cosdec * FC_SINDEC(fc) * cosra + if (abs (z) > 0.99d0) { + if (z >= 0.0) + theta = acos (sqrt(x * x + y * y)) + else + theta = -acos (sqrt(x * x + y * y)) + } else + theta = asin (z) + } + + # Compute the transformation from native coordinates PHI and THETA + # to projected coordinates X and Y. + + p[ira] = FC_RODEG(fc) * phi * cos (theta) + p[idec] = FC_RODEG(fc) * theta + +end diff --git a/sys/mwcs/wfgsurfit.x b/sys/mwcs/wfgsurfit.x new file mode 100644 index 00000000..8dca0f70 --- /dev/null +++ b/sys/mwcs/wfgsurfit.x @@ -0,0 +1,575 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# WFGSURFIT.X -- Surface fitting package used by WCS function drivers. +# +# The following routines are used by the experimental function drivers tnx +# and zpx to decode polynomial fits stored in the image header in the form +# of a list of parameters and coefficients into surface descriptors in +# ra / dec or longitude latitude. The polynomial surfaces so encoded consist +# of corrections to function drivers tan and zpn. The package routines are +# modelled after the equivalent gsurfit routines and are consistent with them. +# The routines are: +# +# sf = wf_gsopen (wattstr) +# wf_gsclose (sf) +# +# z = wf_gseval (sf, x, y) +# wf_gscoeff (sf, coeff, ncoeff) +# zder = wf_gsder (sf, x, y, nxder, nyder) +# +# WF_GSOPEN is used to open a surface fit encoded in a WCS attribute, returning +# the SF surface fitting descriptor. wf_gsclose should be called later to free +# the descriptor. WF_GSEVAL is called to evaluate the surface at a point. + + +define SZ_GSCOEFFBUF 20 + +# Define the surface descriptor. +define LEN_WFGSSTRUCT 20 + +define WF_XRANGE Memd[P2D($1)] # 2. / (xmax - xmin), polynomials +define WF_XMAXMIN Memd[P2D($1+2)] # - (xmax + xmin) / 2., polynomials +define WF_YRANGE Memd[P2D($1+4)] # 2. / (ymax - ymin), polynomials +define WF_YMAXMIN Memd[P2D($1+6)] # - (ymax + ymin) / 2., polynomials +define WF_TYPE Memi[$1+8] # Type of curve to be fitted +define WF_XORDER Memi[$1+9] # Order of the fit in x +define WF_YORDER Memi[$1+10] # Order of the fit in y +define WF_XTERMS Memi[$1+11] # Cross terms for polynomials +define WF_NCOEFF Memi[$1+12] # Total number of coefficients +define WF_COEFF Memi[$1+13] # Pointer to coefficient vector +define WF_XBASIS Memi[$1+14] # Pointer to basis functions (all x) +define WF_YBASIS Memi[$1+15] # Pointer to basis functions (all y) + +# Define the structure elements for the wf_gsrestore task. +define WF_SAVETYPE $1[1] +define WF_SAVEXORDER $1[2] +define WF_SAVEYORDER $1[3] +define WF_SAVEXTERMS $1[4] +define WF_SAVEXMIN $1[5] +define WF_SAVEXMAX $1[6] +define WF_SAVEYMIN $1[7] +define WF_SAVEYMAX $1[8] + +# Define the permitted types of surfaces. +define WF_CHEBYSHEV 1 +define WF_LEGENDRE 2 +define WF_POLYNOMIAL 3 + +# Define the cross-terms flags. +define WF_XNONE 0 # no x-terms (old NO) +define WF_XFULL 1 # full x-terms (new YES) +define WF_XHALF 2 # half x-terms (new) + +define WF_SAVECOEFF 8 + + +# WF_GSOPEN -- Decode the longitude / latitude or ra / dec mwcs attribute +# and return a gsurfit compatible surface descriptor. + +pointer procedure wf_gsopen (atstr) + +char atstr[ARB] #I the input mwcs attribute string + +double dval +int ip, npar, szcoeff +pointer gs, sp, par, coeff +int nscan(), ctod() +errchk wf_gsrestore() + +begin + if (atstr[1] == EOS) + return (NULL) + + call smark (sp) + call salloc (par, SZ_LINE, TY_CHAR) + + gs = NULL + npar = 0 + szcoeff = SZ_GSCOEFFBUF + call malloc (coeff, szcoeff, TY_DOUBLE) + + call sscan (atstr) + repeat { + call gargwrd (Memc[par], SZ_LINE) + if (nscan() == npar) + break + if (Memc[par] == EOS) + break + ip = 1 + if (ctod (Memc[par], ip, dval) <= 0) + break + if (npar >= szcoeff) { + szcoeff =szcoeff + SZ_GSCOEFFBUF + call realloc (coeff, szcoeff, TY_DOUBLE) + } + Memd[coeff+npar] = dval + npar = npar + 1 + } + + iferr (call wf_gsrestore (gs, Memd[coeff])) + gs = NULL + + call sfree (sp) + call mfree (coeff, TY_DOUBLE) + + if (npar == 0) + return (NULL) + else + return (gs) +end + + +# WF_GSCLOSE -- Procedure to free the surface descriptor. + +procedure wf_gsclose (sf) + +pointer sf #U the surface descriptor +errchk mfree + +begin + if (sf == NULL) + return + + if (WF_XBASIS(sf) != NULL) + call mfree (WF_XBASIS(sf), TY_DOUBLE) + if (WF_YBASIS(sf) != NULL) + call mfree (WF_YBASIS(sf), TY_DOUBLE) + if (WF_COEFF(sf) != NULL) + call mfree (WF_COEFF(sf), TY_DOUBLE) + + if (sf != NULL) + call mfree (sf, TY_STRUCT) +end + + +# WF_GSEVAL -- Procedure to evaluate the fitted surface at a single point. +# The WF_NCOEFF(sf) coefficients are stored in the vector pointed to by +# WF_COEFF(sf). + +double procedure wf_gseval (sf, x, y) + +pointer sf #I pointer to surface descriptor structure +double x #I x value +double y #I y value + +double sum, accum +int i, ii, k, maxorder, xorder + +begin + # Calculate the basis functions. + switch (WF_TYPE(sf)) { + case WF_CHEBYSHEV: + call wf_gsb1cheb (x, WF_XORDER(sf), WF_XMAXMIN(sf), WF_XRANGE(sf), + Memd[WF_XBASIS(sf)]) + call wf_gsb1cheb (y, WF_YORDER(sf), WF_YMAXMIN(sf), WF_YRANGE(sf), + Memd[WF_YBASIS(sf)]) + case WF_LEGENDRE: + call wf_gsb1leg (x, WF_XORDER(sf), WF_XMAXMIN(sf), WF_XRANGE(sf), + Memd[WF_XBASIS(sf)]) + call wf_gsb1leg (y, WF_YORDER(sf), WF_YMAXMIN(sf), WF_YRANGE(sf), + Memd[WF_YBASIS(sf)]) + case WF_POLYNOMIAL: + call wf_gsb1pol (x, WF_XORDER(sf), WF_XMAXMIN(sf), WF_XRANGE(sf), + Memd[WF_XBASIS(sf)]) + call wf_gsb1pol (y, WF_YORDER(sf), WF_YMAXMIN(sf), WF_YRANGE(sf), + Memd[WF_YBASIS(sf)]) + default: + call error (0, "WF_GSEVAL: Unknown surface type.") + } + + # Initialize accumulator basis functions. + sum = 0. + + # Loop over y basis functions. + maxorder = max (WF_XORDER(sf) + 1, WF_YORDER(sf) + 1) + xorder = WF_XORDER(sf) + ii = 1 + + do i = 1, WF_YORDER(sf) { + # Loop over the x basis functions. + accum = 0. + do k = 1, xorder { + accum = accum + Memd[WF_COEFF(sf)+ii-1] * + Memd[WF_XBASIS(sf)+k-1) + ii = ii + 1 + } + accum = accum * Memd[WF_YBASIS(sf)+i-1] + sum = sum + accum + + # Elements of the coefficient vector where neither k = 1 or i = 1 + # are not calculated if WF_XTERMS(sf) = NO. + + switch (WF_XTERMS(sf)) { + case WF_XNONE: + xorder = 1 + case WF_XHALF: + if ((i + WF_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + } + + return (sum) +end + + +# WF_GSCOEFF -- Procedure to fetch the number and magnitude of the coefficients. +# If the WF_XTERMS(sf) = WF_XBI (YES) then the number of coefficients will be +# (WF_XORDER(sf) * WF_YORDER(sf)); if WF_XTERMS is WF_XTRI then the number +# of coefficients will be (WF_XORDER(sf) * WF_YORDER(sf) - order * +# (order - 1) / 2) where order is the minimum of the x and yorders; if +# WF_XTERMS(sf) = WF_XNONE then the number of coefficients will be +# (WF_XORDER(sf) + WF_YORDER(sf) - 1). + +procedure wf_gscoeff (sf, coeff, ncoeff) + +pointer sf #I pointer to the surface fitting descriptor +double coeff[ARB] #O the coefficients of the fit +int ncoeff #O the number of coefficients + +begin + # Calculate the number of coefficients. + ncoeff = WF_NCOEFF(sf) + call amovd (Memd[WF_COEFF(sf)], coeff, ncoeff) +end + + +# WF_GSDER -- Procedure to calculate a new surface which is a derivative of +# the input surface. + +double procedure wf_gsder (sf1, x, y, nxd, nyd) + +pointer sf1 #I pointer to the previous surface +double x #I x values +double y #I y values +int nxd, nyd #I order of the derivatives in x and y + +int ncoeff, nxder, nyder, i, j, k +int order, maxorder1, maxorder2, nmove1, nmove2 +pointer sf2, sp, coeff, ptr1, ptr2 +double zfit, norm +double wf_gseval() + +begin + if (sf1 == NULL) + return (0) + + if (nxd < 0 || nyd < 0) + call error (0, "GSDER: Order of derivatives cannot be < 0") + + if (nxd == 0 && nyd == 0) { + zfit = wf_gseval (sf1, x, y) + return (zfit) + } + + # Allocate space for new surface. + call calloc (sf2, LEN_WFGSSTRUCT, TY_STRUCT) + + # check the order of the derivatives + nxder = min (nxd, WF_XORDER(sf1) - 1) + nyder = min (nyd, WF_YORDER(sf1) - 1) + + # Set up new surface. + WF_TYPE(sf2) = WF_TYPE(sf1) + + # Set the derivative surface parameters. + switch (WF_TYPE(sf2)) { + case WF_LEGENDRE, WF_CHEBYSHEV, WF_POLYNOMIAL: + + WF_XTERMS(sf2) = WF_XTERMS(sf1) + + # Find the order of the new surface. + switch (WF_XTERMS(sf2)) { + case WF_XNONE: + if (nxder > 0 && nyder > 0) { + WF_XORDER(sf2) = 1 + WF_YORDER(sf2) = 1 + WF_NCOEFF(sf2) = 1 + } else if (nxder > 0) { + WF_XORDER(sf2) = max (1, WF_XORDER(sf1) - nxder) + WF_YORDER(sf2) = 1 + WF_NCOEFF(sf2) = WF_XORDER(sf2) + } else if (nyder > 0) { + WF_XORDER(sf2) = 1 + WF_YORDER(sf2) = max (1, WF_YORDER(sf1) - nyder) + WF_NCOEFF(sf2) = WF_YORDER(sf2) + } + + case WF_XHALF: + maxorder1 = max (WF_XORDER(sf1) + 1, WF_YORDER(sf1) + 1) + order = max (1, min (maxorder1 - 1 - nyder - nxder, + WF_XORDER(sf1) - nxder)) + WF_XORDER(sf2) = order + order = max (1, min (maxorder1 - 1 - nyder - nxder, + WF_YORDER(sf1) - nyder)) + WF_YORDER(sf2) = order + order = min (WF_XORDER(sf2), WF_YORDER(sf2)) + WF_NCOEFF(sf2) = WF_XORDER(sf2) * WF_YORDER(sf2) - + order * (order - 1) / 2 + + default: + WF_XORDER(sf2) = max (1, WF_XORDER(sf1) - nxder) + WF_YORDER(sf2) = max (1, WF_YORDER(sf1) - nyder) + WF_NCOEFF(sf2) = WF_XORDER(sf2) * WF_YORDER(sf2) + } + + # Define the data limits. + WF_XRANGE(sf2) = WF_XRANGE(sf1) + WF_XMAXMIN(sf2) = WF_XMAXMIN(sf1) + WF_YRANGE(sf2) = WF_YRANGE(sf1) + WF_YMAXMIN(sf2) = WF_YMAXMIN(sf1) + + default: + call error (0, "WF_GSDER: Unknown surface type.") + } + + # Allocate space for coefficients and basis functions. + call calloc (WF_COEFF(sf2), WF_NCOEFF(sf2), TY_DOUBLE) + call calloc (WF_XBASIS(sf2), WF_XORDER(sf2), TY_DOUBLE) + call calloc (WF_YBASIS(sf2), WF_YORDER(sf2), TY_DOUBLE) + + # Get coefficients. + call smark (sp) + call salloc (coeff, WF_NCOEFF(sf1), TY_DOUBLE) + call wf_gscoeff (sf1, Memd[coeff], ncoeff) + + # Compute the new coefficients. + switch (WF_XTERMS(sf2)) { + case WF_XFULL: + ptr2 = WF_COEFF(sf2) + (WF_YORDER(sf2) - 1) * WF_XORDER(sf2) + ptr1 = coeff + (WF_YORDER(sf1) - 1) * WF_XORDER(sf1) + do i = WF_YORDER(sf1), nyder + 1, -1 { + do j = i, i - nyder + 1, -1 + call amulkd (Memd[ptr1+nxder], double (j - 1), + Memd[ptr1+nxder], WF_XORDER(sf2)) + do j = WF_XORDER(sf1), nxder + 1, - 1 { + do k = j , j - nxder + 1, - 1 + Memd[ptr1+j-1] = Memd[ptr1+j-1] * (k - 1) + } + call amovd (Memd[ptr1+nxder], Memd[ptr2], WF_XORDER(sf2)) + ptr2 = ptr2 - WF_XORDER(sf2) + ptr1 = ptr1 - WF_XORDER(sf1) + } + + case WF_XHALF: + maxorder1 = max (WF_XORDER(sf1) + 1, WF_YORDER(sf1) + 1) + maxorder2 = max (WF_XORDER(sf2) + 1, WF_YORDER(sf2) + 1) + ptr2 = WF_COEFF(sf2) + WF_NCOEFF(sf2) + ptr1 = coeff + WF_NCOEFF(sf1) + do i = WF_YORDER(sf1), nyder + 1, -1 { + nmove1 = max (0, min (maxorder1 - i, WF_XORDER(sf1))) + nmove2 = max (0, min (maxorder2 - i + nyder, WF_XORDER(sf2))) + ptr1 = ptr1 - nmove1 + ptr2 = ptr2 - nmove2 + do j = i, i - nyder + 1, -1 + call amulkd (Memd[ptr1+nxder], double (j - 1), + Memd[ptr1+nxder], nmove2) + do j = nmove1, nxder + 1, - 1 { + do k = j , j - nxder + 1, - 1 + Memd[ptr1+j-1] = Memd[ptr1+j-1] * (k - 1) + } + call amovd (Memd[ptr1+nxder], Memd[ptr2], nmove2) + } + + default: + if (nxder > 0 && nyder > 0) { + Memd[WF_COEFF(sf2)] = 0. + + } else if (nxder > 0) { + ptr1 = coeff + ptr2 = WF_COEFF(sf2) + WF_NCOEFF(sf2) - 1 + do j = WF_XORDER(sf1), nxder + 1, -1 { + do k = j, j - nxder + 1, -1 + Memd[ptr1+j-1] = Memd[ptr1+j-1] * (k - 1) + Memd[ptr2] = Memd[ptr1+j-1] + ptr2 = ptr2 - 1 + } + + } else if (nyder > 0) { + ptr1 = coeff + WF_NCOEFF(sf1) - 1 + ptr2 = WF_COEFF(sf2) + do i = WF_YORDER(sf1), nyder + 1, -1 { + do j = i, i - nyder + 1, - 1 + Memd[ptr1] = Memd[ptr1] * (j - 1) + ptr1 = ptr1 - 1 + } + call amovd (Memd[ptr1+1], Memd[ptr2], WF_NCOEFF(sf2)) + } + } + + # Evaluate the derivatives. + zfit = wf_gseval (sf2, x, y) + + # Normalize. + if (WF_TYPE(sf2) != WF_POLYNOMIAL) { + norm = WF_XRANGE(sf2) ** nxder * WF_YRANGE(sf2) ** nyder + zfit = norm * zfit + } + + # Free the space. + call wf_gsclose (sf2) + call sfree (sp) + + return (zfit) +end + + +# WF_GSRESTORE -- Procedure to restore the surface fit encoded in the +# image header as a list of double precision parameters and coefficients +# to the surface descriptor for use by the evaluating routines. The +# surface parameters, surface type, xorder (or number of polynomial +# terms in x), yorder (or number of polynomial terms in y), xterms, +# xmin, xmax and ymin and ymax, are stored in the first eight elements +# of the double array fit, followed by the WF_NCOEFF(sf) surface coefficients. + +procedure wf_gsrestore (sf, fit) + +pointer sf #O surface descriptor +double fit[ARB] #I array containing the surface parameters and + #I coefficients + +int surface_type, xorder, yorder, order +double xmin, xmax, ymin, ymax + +begin + # Allocate space for the surface descriptor. + call calloc (sf, LEN_WFGSSTRUCT, TY_STRUCT) + + xorder = nint (WF_SAVEXORDER(fit)) + if (xorder < 1) + call error (0, "WF_GSRESTORE: Illegal x order.") + yorder = nint (WF_SAVEYORDER(fit)) + if (yorder < 1) + call error (0, "WF_GSRESTORE: Illegal y order.") + + xmin = WF_SAVEXMIN(fit) + xmax = WF_SAVEXMAX(fit) + if (xmax <= xmin) + call error (0, "WF_GSRESTORE: Illegal x range.") + ymin = WF_SAVEYMIN(fit) + ymax = WF_SAVEYMAX(fit) + if (ymax <= ymin) + call error (0, "WF_GSRESTORE: Illegal y range.") + + # Set surface type dependent surface descriptor parameters. + surface_type = nint (WF_SAVETYPE(fit)) + + switch (surface_type) { + case WF_LEGENDRE, WF_CHEBYSHEV, WF_POLYNOMIAL: + WF_XORDER(sf) = xorder + WF_XRANGE(sf) = double(2.0) / (xmax - xmin) + WF_XMAXMIN(sf) = - (xmax + xmin) / double(2.0) + WF_YORDER(sf) = yorder + WF_YRANGE(sf) = double(2.0) / (ymax - ymin) + WF_YMAXMIN(sf) = - (ymax + ymin) / double(2.0) + WF_XTERMS(sf) = WF_SAVEXTERMS(fit) + switch (WF_XTERMS(sf)) { + case WF_XNONE: + WF_NCOEFF(sf) = WF_XORDER(sf) + WF_YORDER(sf) - 1 + case WF_XHALF: + order = min (xorder, yorder) + WF_NCOEFF(sf) = WF_XORDER(sf) * WF_YORDER(sf) - order * + (order - 1) / 2 + case WF_XFULL: + WF_NCOEFF(sf) = WF_XORDER(sf) * WF_YORDER(sf) + } + default: + call error (0, "WF_GSRESTORE: Unknown surface type.") + } + + # Set remaining curve parameters. + WF_TYPE(sf) = surface_type + + call malloc (WF_COEFF(sf), WF_NCOEFF(sf), TY_DOUBLE) + call malloc (WF_XBASIS(sf), WF_XORDER(sf), TY_DOUBLE) + call malloc (WF_YBASIS(sf), WF_YORDER(sf), TY_DOUBLE) + + # restore coefficient array + call amovd (fit[WF_SAVECOEFF+1], Memd[WF_COEFF(sf)], WF_NCOEFF(sf)) +end + + +# WF_GSB1POL -- Procedure to evaluate all the non-zero polynomial functions +# for a single point and given order. + +procedure wf_gsb1pol (x, order, k1, k2, basis) + +double x #I data point +int order #I order of polynomial, order = 1, constant +double k1, k2 #I nomalizing constants, dummy in this case +double basis[ARB] #O basis functions + +int i + +begin + basis[1] = 1. + if (order == 1) + return + + basis[2] = x + if (order == 2) + return + + do i = 3, order + basis[i] = x * basis[i-1] +end + + +# WF_GSB1LEG -- Procedure to evaluate all the non-zero Legendre functions for +# a single point and given order. + +procedure wf_gsb1leg (x, order, k1, k2, basis) + +double x #I data point +int order #I order of polynomial, order = 1, constant +double k1, k2 #I normalizing constants +double basis[ARB] #O basis functions + +int i +double ri, xnorm + +begin + basis[1] = 1. + if (order == 1) + return + + xnorm = (x + k1) * k2 + basis[2] = xnorm + if (order == 2) + return + + do i = 3, order { + ri = i + basis[i] = ((2. * ri - 3.) * xnorm * basis[i-1] - + (ri - 2.) * basis[i-2]) / (ri - 1.) + } +end + + +# WF_GSB1CHEB -- Procedure to evaluate all the non zero Chebyshev function +# for a given x and order. + +procedure wf_gsb1cheb (x, order, k1, k2, basis) + +double x #I number of data points +int order #I order of polynomial, 1 is a constant +double k1, k2 #I normalizing constants +double basis[ARB] #O array of basis functions + +int i +double xnorm + +begin + basis[1] = 1. + if (order == 1) + return + + xnorm = (x + k1) * k2 + basis[2] = xnorm + if (order == 2) + return + + do i = 3, order + basis[i] = 2. * xnorm * basis[i-1] - basis[i-2] +end diff --git a/sys/mwcs/wfinit.x b/sys/mwcs/wfinit.x new file mode 100644 index 00000000..eb9c8e26 --- /dev/null +++ b/sys/mwcs/wfinit.x @@ -0,0 +1,140 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +# WF_INIT -- Initialize the WCS function table. Everything MWCS related +# having to do with a world function is contained either in this file or +# in the driver source file. If the WCS must also be translated to/from +# a FITS image header representation, the image header translation routine +# iwewcs.x must also be modified. + +procedure wf_init() + +extern wf_smp_init(), wf_smp_tran() +extern wf_tan_init(), wf_tan_fwd(), wf_tan_inv() +extern wf_arc_init(), wf_arc_fwd(), wf_arc_inv() +extern wf_gls_init(), wf_gls_fwd(), wf_gls_inv() +extern wf_sin_init(), wf_sin_fwd(), wf_sin_inv() +extern wf_msp_init(), wf_msp_fwd(), wf_msp_inv(), wf_msp_destroy() + +extern wf_ait_init(), wf_ait_fwd(), wf_ait_inv() +extern wf_car_init(), wf_car_fwd(), wf_car_inv() +extern wf_csc_init(), wf_csc_fwd(), wf_csc_inv() +extern wf_mer_init(), wf_mer_fwd(), wf_mer_inv() +extern wf_mol_init(), wf_mol_fwd(), wf_mol_inv() +extern wf_par_init(), wf_par_fwd(), wf_par_inv() +extern wf_pco_init(), wf_pco_fwd(), wf_pco_inv() +extern wf_qsc_init(), wf_qsc_fwd(), wf_qsc_inv() +extern wf_stg_init(), wf_stg_fwd(), wf_stg_inv() +extern wf_tsc_init(), wf_tsc_fwd(), wf_tsc_inv() +extern wf_zea_init(), wf_zea_fwd(), wf_zea_inv() + +extern wf_zpx_init(), wf_zpx_fwd(), wf_zpx_inv(), wf_zpx_destroy() +extern wf_zpn_init(), wf_zpn_fwd(), wf_zpn_inv(), wf_zpn_destroy() +extern wf_tnx_init(), wf_tnx_fwd(), wf_tnx_inv(), wf_tnx_destroy() +extern wf_tpv_init(), wf_tpv_fwd(), wf_tpv_inv(), wf_tpv_destroy() + +bool first_time +data first_time /true/ +errchk wf_fnload +include "mwcs.com" +int locpr() + +begin + # Only do this once. + if (!first_time) + return + + fn_nfn = 0 + first_time = false + + # Load the function drivers. + call wf_fnload ("sampled", 0, + locpr(wf_smp_init), NULL, locpr(wf_smp_tran), locpr(wf_smp_tran)) + + # For compatibility reasons (FN index codes) new functions should + # be added at the end of the following list. + + call wf_fnload ("tan", F_RADEC, + locpr(wf_tan_init), NULL, locpr(wf_tan_fwd), locpr(wf_tan_inv)) + call wf_fnload ("arc", F_RADEC, + locpr(wf_arc_init), NULL, locpr(wf_arc_fwd), locpr(wf_arc_inv)) + call wf_fnload ("gls", F_RADEC, + locpr(wf_gls_init), NULL, locpr(wf_gls_fwd), locpr(wf_gls_inv)) + call wf_fnload ("sin", F_RADEC, + locpr(wf_sin_init), NULL, locpr(wf_sin_fwd), locpr(wf_sin_inv)) + + # Custom IRAF WCS for images containing multiple spectra. + call wf_fnload ("multispec", F_RADEC, + locpr(wf_msp_init), locpr(wf_msp_destroy), locpr(wf_msp_fwd), + locpr(wf_msp_inv)) + + # Most of the following are from G&C (also GLS above). + call wf_fnload ("ait", F_RADEC, + locpr(wf_ait_init), NULL, locpr(wf_ait_fwd), locpr(wf_ait_inv)) + call wf_fnload ("car", F_RADEC, + locpr(wf_car_init), NULL, locpr(wf_car_fwd), locpr(wf_car_inv)) + call wf_fnload ("csc", F_RADEC, + locpr(wf_csc_init), NULL, locpr(wf_csc_fwd), locpr(wf_csc_inv)) + call wf_fnload ("mer", F_RADEC, + locpr(wf_mer_init), NULL, locpr(wf_mer_fwd), locpr(wf_mer_inv)) + call wf_fnload ("mol", F_RADEC, + locpr(wf_mol_init), NULL, locpr(wf_mol_fwd), locpr(wf_mol_inv)) + call wf_fnload ("par", F_RADEC, + locpr(wf_par_init), NULL, locpr(wf_par_fwd), locpr(wf_par_inv)) + call wf_fnload ("pco", F_RADEC, + locpr(wf_pco_init), NULL, locpr(wf_pco_fwd), locpr(wf_pco_inv)) + call wf_fnload ("qsc", F_RADEC, + locpr(wf_qsc_init), NULL, locpr(wf_qsc_fwd), locpr(wf_qsc_inv)) + call wf_fnload ("stg", F_RADEC, + locpr(wf_stg_init), NULL, locpr(wf_stg_fwd), locpr(wf_stg_inv)) + call wf_fnload ("tsc", F_RADEC, + locpr(wf_tsc_init), NULL, locpr(wf_tsc_fwd), locpr(wf_tsc_inv)) + call wf_fnload ("zea", F_RADEC, + locpr(wf_zea_init), NULL, locpr(wf_zea_fwd), locpr(wf_zea_inv)) + + # Experimental WCS for astrometric approximations. + call wf_fnload ("zpx", F_RADEC, + locpr(wf_zpx_init), locpr(wf_zpx_destroy), locpr(wf_zpx_fwd), + locpr(wf_zpx_inv)) + call wf_fnload ("zpn", F_RADEC, + locpr(wf_zpn_init), locpr(wf_zpn_destroy), locpr(wf_zpn_fwd), + locpr(wf_zpn_inv)) + call wf_fnload ("tnx", F_RADEC, + locpr(wf_tnx_init), locpr(wf_tnx_destroy), locpr(wf_tnx_fwd), + locpr(wf_tnx_inv)) + call wf_fnload ("tpv", F_RADEC, + locpr(wf_tpv_init), locpr(wf_tpv_destroy), locpr(wf_tpv_fwd), + locpr(wf_tpv_inv)) +end + + +# WF_FNLOAD -- Load a driver into the WCS function table. + +procedure wf_fnload (name, flags, init, destroy, fwd, inv) + +char name[ARB] #I function name +int init #I initialize procedure +int flags #I function type flags +int destroy #I destroy procedure +int fwd #I forward transform procedure +int inv #I inverse transform procedure + +errchk syserrs +include "mwcs.com" + +begin + # Get a new driver slot. + if (fn_nfn + 1 > MAX_FN) + call syserrs (SYS_MWFNOVFL, name) + fn_nfn = fn_nfn + 1 + + # Load the driver. + FN_INIT(fn_nfn) = init + FN_FLAGS(fn_nfn) = flags + FN_DESTROY(fn_nfn) = destroy + FN_FWD(fn_nfn) = fwd + FN_INV(fn_nfn) = inv + call strcpy (name, FN_NAME(fn_nfn), SZ_FNNAME) +end diff --git a/sys/mwcs/wfmer.x b/sys/mwcs/wfmer.x new file mode 100644 index 00000000..efee2be9 --- /dev/null +++ b/sys/mwcs/wfmer.x @@ -0,0 +1,446 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +.help WFMER +.nf ------------------------------------------------------------------------- +WFMER -- WCS function driver for the cylindrical mercator projection. + +Driver routines: + + FN_INIT wf_mer_init (fc, dir) + FN_DESTROY (none) + FN_FWD wf_mer_fwd (fc, v1, v2) + FN_INV wf_mer_inv (fc, v1, v2) + +.endhelp -------------------------------------------------------------------- + +# Driver specific fields of function call (FC) descriptor. +define FC_IRA Memi[$1+FCU] # RA axis (1 or 2) +define FC_IDEC Memi[$1+FCU+1] # DEC axis (1 or 2) +define FC_NATRA Memd[P2D($1+FCU+2)] # RA of native pole (rads) +define FC_NATDEC Memd[P2D($1+FCU+4)] # DEC of native pole (rads) +define FC_LONGP Memd[P2D($1+FCU+6)] # LONGPOLE (rads) +define FC_COSDEC Memd[P2D($1+FCU+8)] # cosine (NATDEC) +define FC_SINDEC Memd[P2D($1+FCU+10)] # sine (NATDEC) +define FC_SPHTOL Memd[P2D($1+FCU+12)] # trig tolerance +define FC_RODEG Memd[P2D($1+FCU+14)] # RO (degs) +define FC_RECRODEG Memd[P2D($1+FCU+16)] # 1 / RO +define FC_BADCVAL Memd[P2D($1+FCU+18)] # bad coordinate value +define FC_W Memd[P2D($1+FCU+20)+($2)-1] # CRVAL axis (1 and 2) + + +# WF_MER_INIT -- Initialize the cylindical mercator forward or inverse +# transform. Initialization for this transformation consists of, determining +# which axis is RA / LON and which is DEC / LAT, reading in the the native +# longitude and latitude of the pole in celestial coordinates LONGPOLE and +# LATPOLE from the attribute list, computing the celestial longitude and +# colatitude of the native pole, precomputing the Euler angles and various +# intermediary functions of the reference point, reading in the projection +# parameter RO from the attribute list, and precomputing the various required +# intermediate quantities. If LONGPOLE is undefined then a value of 180.0 +# degrees is assumed if the celestial latitude of the reference point is less +# than 0, otherwise 0 degrees is assumed. If LATPOLE is undefined the +# more northerly of the two possible solutions for latitude of the native +# pole is chosen, otherwise the solution closest to LATPOLE is chosen. If +# RO is undefined a value of 180.0 / PI is assumed. In order to determine +# the axis order, the parameter "axtype={ra|dec} {xlon|xlat}" must have been +# set in the attribute list for the function. The LONGPOLE, LATPOLE, and RO +# parameters may be set in either or both of the axes attribute lists, but the +# value in the RA axis attribute list takes precedence. + +procedure wf_mer_init (fc, dir) + +pointer fc #I pointer to FC descriptor +int dir #I direction of transform + +int i +double dec, latpole, theta0, clat0, slat0, cphip, sphip, cthe0, sthe0, x, y, z +double u, v, latp1, latp2, latp, maxlat, tol +pointer sp, atvalue, ct, mw, wp, wv +int ctod() +data tol/1.0d-10/ +errchk wf_decaxis(), mw_gwattrs() + +begin + # Allocate space for the attribute string. + call smark (sp) + call salloc (atvalue, SZ_LINE, TY_CHAR) + + # Get the required mwcs pointers. + ct = FC_CT(fc) + mw = CT_MW(ct) + wp = FC_WCS(fc) + + # Determine which is the DEC axis, and hence the axis order. + call wf_decaxis (fc, FC_IRA(fc), FC_IDEC(fc)) + + # Get the value of W for each axis, i.e. the world coordinates at + # the reference point. + + wv = MI_DBUF(mw) + WCS_W(wp) - 1 + do i = 1, 2 + FC_W(fc,i) = Memd[wv+CT_AXIS(ct,FC_AXIS(fc,i))-1] + + # Determine the native longitude and latitude of the pole of the + # celestial coordinate system corresponding to the FITS keywords + # LONGPOLE and LATPOLE. LONGPOLE has no default but will be set + # to 180 or 0 depending on the value of the declination of the + # reference point. LATPOLE has no default but will be set depending + # on the values of LONGPOLE and the reference declination. + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "longpole", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "longpole", Memc[atvalue], + SZ_LINE) + } then { + FC_LONGP(fc) = INDEFD + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_LONGP(fc)) <= 0) + FC_LONGP(fc) = INDEFD + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_LONGP(fc)) <= 0) + FC_LONGP(fc) = INDEFD + } + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "latpole", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "latpole", Memc[atvalue], + SZ_LINE) + } then { + latpole = INDEFD + } else { + i = 1 + if (ctod (Memc[atvalue], i, latpole) <= 0) + latpole = INDEFD + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, latpole) <= 0) + latpole = INDEFD + } + + # Fetch the RO projection parameter which is the radius of the + # generating sphere for the projection. If RO is absent which + # is the usual case set it to 180 / PI. Search both axes for + # this quantity. + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "ro", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "ro", Memc[atvalue], + SZ_LINE) + } then { + FC_RODEG(fc) = 180.0d0 / DPI + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_RODEG(fc)) <= 0) + FC_RODEG(fc) = 180.0d0 / DPI + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_RODEG(fc)) <= 0) + FC_RODEG(fc) = 180.0d0 / DPI + } + + # Compute the native longitude of the celestial pole. + dec = DDEGTORAD(FC_W(fc,FC_IDEC(fc))) + theta0 = 0.0d0 + if (IS_INDEFD(FC_LONGP(fc))) { + if (dec < theta0) + FC_LONGP(fc) = DPI + else + FC_LONGP(fc) = 0.0d0 + } else + FC_LONGP(fc) = DDEGTORAD(FC_LONGP(fc)) + + # Compute the celestial longitude and latitude of the native pole. + clat0 = cos (dec) + slat0 = sin (dec) + cphip = cos (FC_LONGP(fc)) + sphip = sin (FC_LONGP(fc)) + cthe0 = cos (theta0) + sthe0 = sin (theta0) + + x = cthe0 * cphip + y = sthe0 + z = sqrt (x * x + y * y) + + + # The latitude of the native pole is determined by LATPOLE in this + # case. + if (z == 0.0d0) { + + if (slat0 != 0.0d0) + call error (0, "WF_MER_INIT: Invalid projection parameters") + if (IS_INDEFD(latpole)) + latp = 999.0d0 + else + latp = DDEGTORAD(latpole) + + } else { + if (abs (slat0 / z) > 1.0d0) + call error (0, "WF_MER_INIT: Invalid projection parameters") + + u = atan2 (y, x) + v = acos (slat0 / z) + latp1 = u + v + if (latp1 > DPI) + latp1 = latp1 - DTWOPI + else if (latp1 < -DPI) + latp1 = latp1 + DTWOPI + + latp2 = u - v + if (latp2 > DPI) + latp2 = latp2 - DTWOPI + else if (latp2 < -DPI) + latp2 = latp2 + DTWOPI + + + if (IS_INDEFD(latpole)) + maxlat = 999.0d0 + else + maxlat = DDEGTORAD(latpole) + if (abs (maxlat - latp1) < abs (maxlat - latp2)) { + if (abs (latp1) < (DHALFPI + tol)) + latp = latp1 + else + latp = latp2 + } else { + if (abs (latp2) < (DHALFPI + tol)) + latp = latp2 + else + latp = latp1 + } + } + + FC_NATDEC(fc) = DHALFPI - latp + + z = cos (latp) * clat0 + if (abs(z) < tol) { + + # Celestial pole at the reference point. + if (abs(clat0) < tol) { + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) + FC_NATDEC(fc) = DHALFPI - theta0 + # Celestial pole at the native north pole. + } else if (latp > 0.0d0) { + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) + FC_LONGP(fc) - + DPI + FC_NATDEC(fc) = 0.0d0 + # Celestial pole at the native south pole. + } else if (latp < 0.0d0) { + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) - FC_LONGP(fc) + FC_NATDEC(fc) = DPI + } + + } else { + x = (sthe0 - sin (latp) * slat0) / z + y = sphip * cthe0 / clat0 + if (x == 0.0d0 && y == 0.0d0) + call error (0, "WF_MER_INIT: Invalid projection parameters") + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) - atan2 (y,x) + } + + if (FC_W(fc,FC_IRA(fc)) >= 0.0d0) { + if (FC_NATRA(fc) < 0.0d0) + FC_NATRA(fc) = FC_NATRA(fc) + DTWOPI + } else { + if (FC_NATRA(fc) > 0.0d0) + FC_NATRA(fc) = FC_NATRA(fc) - DTWOPI + } + FC_COSDEC(fc) = cos (FC_NATDEC(fc)) + FC_SINDEC(fc) = sin (FC_NATDEC(fc)) + + # Check for ill-conditioned parameters. + if (abs(latp) > (DHALFPI+tol)) + call error (0, "WF_MER_INIT: Invalid projection parameters") + + # Compute the required intermediate quantities. + if (FC_RODEG(fc) == 0.0d0) + call error (0, "WF_MER_INIT: Invalid projection parameters") + FC_RECRODEG(fc) = 1.0d0 / FC_RODEG(fc) + + # Set the bad coordinate value. + FC_SPHTOL(fc) = 1.0d-5 + + # Set the bad coordinate value. + FC_BADCVAL(fc) = INDEFD + + # Free working space. + call sfree (sp) +end + + +# WF_MER_FWD -- Forward transform (physical to world) for the mercator +# projection. + +procedure wf_mer_fwd (fc, p, w) + +pointer fc #I pointer to FC descriptor +double p[2] #I physical coordinates (x, y) +double w[2] #O world coordinates (ra, dec) + +int ira, idec +double x, y, phi, theta, costhe, sinthe, dphi, cosphi, sinphi, ra, dec +double dlng, z + +begin + # Get the axis numbers. + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + # Compute native spherical coordinates PHI and THETA in degrees from + # the projected coordinates. This is the projection part of the + # computation. + + x = p[ira] + y = p[idec] + + # Compute PHI. + phi = FC_RECRODEG(fc) * x + + # Compute THETA. + theta = 2.0d0 * atan (exp (y / FC_RODEG(fc))) - DHALFPI + + # Compute the celestial coordinates RA and DEC from the native + # coordinates PHI and THETA. This is the spherical geometry part + # of the computation. + + costhe = cos (theta) + sinthe = sin (theta) + dphi = phi - FC_LONGP(fc) + cosphi = cos (dphi) + sinphi = sin (dphi) + + # Compute the RA. + x = sinthe * FC_SINDEC(fc) - costhe * FC_COSDEC(fc) * cosphi + if (abs (x) < FC_SPHTOL(fc)) + x = -cos (theta + FC_NATDEC(fc)) + costhe * FC_COSDEC(fc) * + (1.0d0 - cosphi) + y = -costhe * sinphi + if (x != 0.0d0 || y != 0.0d0) { + dlng = atan2 (y, x) + } else { + dlng = dphi + DPI + } + ra = DRADTODEG(FC_NATRA(fc) + dlng) + + # Normalize the RA. + if (FC_NATRA(fc) >= 0.0d0) { + if (ra < 0.0d0) + ra = ra + 360.0d0 + } else { + if (ra > 0.0d0) + ra = ra - 360.0d0 + } + if (ra > 360.0d0) + ra = ra - 360.0d0 + else if (ra < -360.0d0) + ra = ra + 360.0d0 + + # Compute the DEC. + if (mod (dphi, DPI) == 0.0d0) { + dec = DRADTODEG(theta + cosphi * FC_NATDEC(fc)) + if (dec > 90.0d0) + dec = 180.0d0 - dec + if (dec < -90.0d0) + dec = -180.0d0 - dec + } else { + z = sinthe * FC_COSDEC(fc) + costhe * FC_SINDEC(fc) * cosphi + if (abs(z) > 0.99d0) { + if (z >= 0.0d0) + dec = DRADTODEG(acos (sqrt(x * x + y * y))) + else + dec = DRADTODEG(-acos (sqrt(x * x + y * y))) + } else + dec = DRADTODEG(asin (z)) + } + + # Store the results. + w[ira] = ra + w[idec] = dec +end + + +# WF_MER_INV -- Inverse transform (world to physical) for the mercator +# projection. + +procedure wf_mer_inv (fc, w, p) + +pointer fc #I pointer to FC descriptor +double w[2] #I input world (RA, DEC) coordinates +double p[2] #I output physical coordinates + +int ira, idec +double ra, dec, cosdec, sindec, cosra, sinra, x, y, z, dphi, phi, theta + +begin + # Get the axes numbers. + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + # Compute the transformation from celestial coordinates RA and + # DEC to native coordinates PHI and THETA. This is the spherical + # geometry part of the transformation. + + ra = DDEGTORAD (w[ira]) - FC_NATRA(fc) + dec = DDEGTORAD (w[idec]) + cosra = cos (ra) + sinra = sin (ra) + cosdec = cos (dec) + sindec = sin (dec) + + # Compute PHI. + x = sindec * FC_SINDEC(fc) - cosdec * FC_COSDEC(fc) * cosra + if (abs(x) < FC_SPHTOL(fc)) + x = -cos (dec + FC_NATDEC(fc)) + cosdec * FC_COSDEC(fc) * + (1.0d0 - cosra) + y = -cosdec * sinra + if (x != 0.0d0 || y != 0.0d0) + dphi = atan2 (y, x) + else + dphi = ra - DPI + phi = FC_LONGP(fc) + dphi + if (phi > DPI) + phi = phi - DTWOPI + else if (phi < -DPI) + phi = phi + DTWOPI + + # Compute THETA. + if (mod (ra, DPI) == 0.0) { + theta = dec + cosra * FC_NATDEC(fc) + if (theta > DHALFPI) + theta = DPI - theta + if (theta < -DHALFPI) + theta = -DPI - theta + } else { + z = sindec * FC_COSDEC(fc) + cosdec * FC_SINDEC(fc) * cosra + if (abs (z) > 0.99d0) { + if (z >= 0.0) + theta = acos (sqrt(x * x + y * y)) + else + theta = -acos (sqrt(x * x + y * y)) + } else + theta = asin (z) + } + + # Compute the transformation from native coordinates PHI and THETA + # to projected coordinates X and Y. + + if (theta <= -DHALFPI || theta >= DHALFPI) { + p[ira] = FC_BADCVAL(fc) + p[idec] = FC_BADCVAL(fc) + } else { + p[ira] = FC_RODEG(fc) * phi + p[idec] = FC_RODEG(fc) * log (tan ((DHALFPI + theta) / 2.0d0)) + } +end diff --git a/sys/mwcs/wfmol.x b/sys/mwcs/wfmol.x new file mode 100644 index 00000000..b02c00f8 --- /dev/null +++ b/sys/mwcs/wfmol.x @@ -0,0 +1,518 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +.help WFMOL +.nf ------------------------------------------------------------------------- +WFMOL -- WCS function driver for the Mollweide projection. + +Driver routines: + + FN_INIT wf_mol_init (fc, dir) + FN_DESTROY (none) + FN_FWD wf_mol_fwd (fc, v1, v2) + FN_INV wf_mol_inv (fc, v1, v2) + +.endhelp -------------------------------------------------------------------- + +# Driver specific fields of function call (FC) descriptor. +define FC_IRA Memi[$1+FCU] # RA axis (1 or 2) +define FC_IDEC Memi[$1+FCU+1] # DEC axis (1 or 2) +define FC_NATRA Memd[P2D($1+FCU+2)] # RA of native pole (rads) +define FC_NATDEC Memd[P2D($1+FCU+4)] # DEC of native pole (rads) +define FC_LONGP Memd[P2D($1+FCU+6)] # LONGPOLE (rads) +define FC_COSDEC Memd[P2D($1+FCU+8)] # cosine (NATDEC) +define FC_SINDEC Memd[P2D($1+FCU+10)] # sine (NATDEC) +define FC_SPHTOL Memd[P2D($1+FCU+12)] # trig tolerance +define FC_RODEG Memd[P2D($1+FCU+14)] # RO (degs) +define FC_C1 Memd[P2D($1+FCU+16)] # sqrt (2) * RO +define FC_C2 Memd[P2D($1+FCU+18)] # sqrt (2) * RO / 90 +define FC_C3 Memd[P2D($1+FCU+20)] # 1 / (sqrt (2) * RO) +define FC_C4 Memd[P2D($1+FCU+22)] # 90 / RO +define FC_C5 Memd[P2D($1+FCU+24)] # 2 / PI +define FC_BADCVAL Memd[P2D($1+FCU+26)] # bad coordinate value +define FC_W Memd[P2D($1+FCU+28)+($2)-1] # CRVAL axis (1 and 2) + + +# WF_MOL_INIT -- Initialize the forward or inverse Mollweide transform. +# Initialization for this transformation consists of, determining which axis +# is RA / LON and which is DEC / LAT, reading in the native longitude and +# latitude of the pole in celestial coordinates LONGPOLE and LATPOLE from the +# attribute list, computing the Euler angles and various intermediate +# functions of the reference point, reading in the projection parameter RO +# from the attribute list, and precomputing the various required intermediate +# quantities. If LONGPOLE is undefined then a value of 180.0 degrees is assumed +# if the celestial latitude of the reference point is less than 0, otherwise +# 0 degrees is assumed. If LATPOLE is undefined then the most northerly of +# the two possible solutions is chosen, otherwise the solution closest to +# LATPOLE is chosen. If RO is undefined a # value of 180.0 / PI is assumed. +# In order to determine the axis order, the parameter "axtype={ra|dec} +# {xlon|xlat}" must have been set in the attribute list for the function. +# The LONGPOLE, LATPOLE, and RO parameters may be set in either or both of +# the axes attribute lists, but the value in the RA axis attribute list takes +# precedence. + +procedure wf_mol_init (fc, dir) + +pointer fc #I pointer to FC descriptor +int dir #I direction of transform + +int i +double dec, latpole, theta0, clat0, slat0, cphip, sphip, cthe0, sthe0, x, y, z +double u, v, latp1, latp2, latp, maxlat, tol +pointer sp, atvalue, ct, mw, wp, wv +int ctod() +data tol/1.0d-10/ +errchk wf_decaxis(), mw_gwattrs() + +begin + # Allocate space for the attribute string. + call smark (sp) + call salloc (atvalue, SZ_LINE, TY_CHAR) + + # Get the required mwcs pointers. + ct = FC_CT(fc) + mw = CT_MW(ct) + wp = FC_WCS(fc) + + # Determine which is the DEC axis, and hence the axis order. + call wf_decaxis (fc, FC_IRA(fc), FC_IDEC(fc)) + + # Get the value of W for each axis, i.e. the world coordinates at + # the reference point. + + wv = MI_DBUF(mw) + WCS_W(wp) - 1 + do i = 1, 2 + FC_W(fc,i) = Memd[wv+CT_AXIS(ct,FC_AXIS(fc,i))-1] + + + # Determine the native longitude and latitude of the pole of the + # celestial coordinate system corresponding to the FITS keywords + # LONGPOLE and LATPOLE. LONGPOLE has no default but will be set + # to 180 or 0 depending on the value of the declination of the + # reference point. LATPOLE has no default but will be set depending + # on the values of LONGPOLE and the reference declination. + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "longpole", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "longpole", Memc[atvalue], + SZ_LINE) + } then { + FC_LONGP(fc) = INDEFD + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_LONGP(fc)) <= 0) + FC_LONGP(fc) = INDEFD + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_LONGP(fc)) <= 0) + FC_LONGP(fc) = INDEFD + } + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "latpole", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "latpole", Memc[atvalue], + SZ_LINE) + } then { + latpole = INDEFD + } else { + i = 1 + if (ctod (Memc[atvalue], i, latpole) <= 0) + latpole = INDEFD + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, latpole) <= 0) + latpole = INDEFD + } + + # Fetch the RO projection parameter which is the radius of the + # generating sphere for the projection. If RO is absent which + # is the usual case set it to 180 / PI. Search both axes for + # this quantity. + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "ro", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "ro", Memc[atvalue], + SZ_LINE) + } then { + FC_RODEG(fc) = 180.0d0 / DPI + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_RODEG(fc)) <= 0) + FC_RODEG(fc) = 180.0d0 / DPI + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_RODEG(fc)) <= 0) + FC_RODEG(fc) = 180.0d0 / DPI + } + + # Compute the native longitude of the celestial pole. + dec = DDEGTORAD(FC_W(fc,FC_IDEC(fc))) + theta0 = 0.0d0 + if (IS_INDEFD(FC_LONGP(fc))) { + if (dec < theta0) + FC_LONGP(fc) = DPI + else + FC_LONGP(fc) = 0.0d0 + } else + FC_LONGP(fc) = DDEGTORAD(FC_LONGP(fc)) + + # Compute the celestial longitude and latitude of the native pole. + clat0 = cos (dec) + slat0 = sin (dec) + cphip = cos (FC_LONGP(fc)) + sphip = sin (FC_LONGP(fc)) + cthe0 = cos (theta0) + sthe0 = sin (theta0) + + x = cthe0 * cphip + y = sthe0 + z = sqrt (x * x + y * y) + + # The latitude of the native pole is determined by LATPOLE in this + # case. + if (z == 0.0d0) { + + if (slat0 != 0.0d0) + call error (0, "WF_MOL_INIT: Invalid projection parameters") + if (IS_INDEFD(latpole)) + latp = 999.0d0 + else + latp = DDEGTORAD(latpole) + + } else { + if (abs (slat0 / z) > 1.0d0) + call error (0, "WF_MOL_INIT: Invalid projection parameters") + + u = atan2 (y, x) + v = acos (slat0 / z) + latp1 = u + v + if (latp1 > DPI) + latp1 = latp1 - DTWOPI + else if (latp1 < -DPI) + latp1 = latp1 + DTWOPI + + latp2 = u - v + if (latp2 > DPI) + latp2 = latp2 - DTWOPI + else if (latp2 < -DPI) + latp2 = latp2 + DTWOPI + if (IS_INDEFD(latpole)) + maxlat = 999.0d0 + else + maxlat = DDEGTORAD(latpole) + if (abs (maxlat - latp1) < abs (maxlat - latp2)) { + if (abs (latp1) < (DHALFPI + tol)) + latp = latp1 + else + latp = latp2 + } else { + if (abs (latp2) < (DHALFPI + tol)) + latp = latp2 + else + latp = latp1 + } + } + FC_NATDEC(fc) = DHALFPI - latp + + z = cos (latp) * clat0 + if (abs(z) < tol) { + + # Celestial pole at the reference point. + if (abs(clat0) < tol) { + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) + FC_NATDEC(fc) = DHALFPI - theta0 + # Celestial pole at the native north pole. + } else if (latp > 0.0d0) { + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) + FC_LONGP(fc) - + DPI + FC_NATDEC(fc) = 0.0d0 + # Celestial pole at the native south pole. + } else if (latp < 0.0d0) { + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) - FC_LONGP(fc) + FC_NATDEC(fc) = DPI + } + + } else { + x = (sthe0 - sin (latp) * slat0) / z + y = sphip * cthe0 / clat0 + if (x == 0.0d0 && y == 0.0d0) + call error (0, "WF_MOL_INIT: Invalid projection parameters") + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) - atan2 (y,x) + } + + if (FC_W(fc,FC_IRA(fc)) >= 0.0d0) { + if (FC_NATRA(fc) < 0.0d0) + FC_NATRA(fc) = FC_NATRA(fc) + DTWOPI + } else { + if (FC_NATRA(fc) > 0.0d0) + FC_NATRA(fc) = FC_NATRA(fc) - DTWOPI + } + FC_COSDEC(fc) = cos (FC_NATDEC(fc)) + FC_SINDEC(fc) = sin (FC_NATDEC(fc)) + + # Check for ill-conditioned parameters. + if (abs(latp) > (DHALFPI+tol)) + call error (0, "WF_MOL_INIT: Invalid projection parameters") + + # Compute the required intermediate quantities. + FC_C1(fc) = sqrt (2.0d0) * FC_RODEG(fc) + FC_C2(fc) = FC_C1(fc) / 90.0d0 + FC_C3(fc) = 1.0d0 / FC_C1(fc) + FC_C4(fc) = 90.0d0 / FC_RODEG(fc) + FC_C5(fc) = 2.0d0 / DPI + + # Set the bad coordinate value. + FC_SPHTOL(fc) = 1.0d-5 + + # Set the bad coordinate value. + FC_BADCVAL(fc) = INDEFD + + # Free working space. + call sfree (sp) +end + + +# WF_MOL_FWD -- Forward transform (physical to world) for the Mollweide +# projection. + +procedure wf_mol_fwd (fc, p, w) + +pointer fc #I pointer to FC descriptor +double p[2] #I physical coordinates (x, y) +double w[2] #O world coordinates (ra, dec) + +int ira, idec +double x, y, y0, s, z, phi, theta, costhe, sinthe, dphi, cosphi, sinphi +double tol, ra, dec, dlng +data tol/1.0d-12/ + +begin + # Get the axis numbers. + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + # Compute native spherical coordinates PHI and THETA in degrees from + # the projected coordinates. This is the projection part of the + # computation. + + x = p[ira] + y = p[idec] + + # Compute PHI. + y0 = y / FC_RODEG(fc) + s = 2.0d0 - y0 * y0 + if (s < tol) { + if (s < -tol) { + w[ira] = FC_BADCVAL(fc) + w[idec] = FC_BADCVAL(fc) + return + } + s = 0.0d0 + if (abs(x) > tol) { + w[ira] = FC_BADCVAL(fc) + w[idec] = FC_BADCVAL(fc) + return + } + phi = 0.0d0 + } else { + s = sqrt (s) + phi = FC_C4(fc) * DDEGTORAD(x) / s + } + + # Compute THETA. + z = y * FC_C3(fc) + if (abs(z) > 1.0d0) { + if (abs(z) > (1.0d0 + tol)) { + w[ira] = FC_BADCVAL(fc) + w[idec] = FC_BADCVAL(fc) + return + } + if (z >= 0.0d0) + z = 1.0d0 + y0 * s / DPI + else + z = -1.0d0 + y0 * s / DPI + } else + z = asin (z) * FC_C5(fc) + y0 * s / DPI + + if (abs(z) > 1.0d0) { + if (abs(z) > (1.0d0 + tol)) { + w[ira] = FC_BADCVAL(fc) + w[idec] = FC_BADCVAL(fc) + return + } + if (z >= 0.0d0) + z = 1.0d0 + else + z = -1.0d0 + } + theta = asin (z) + + # Compute the celestial coordinates RA and DEC from the native + # coordinates PHI and THETA. This is the spherical geometry part + # of the computation. + + costhe = cos (theta) + sinthe = sin (theta) + dphi = phi - FC_LONGP(fc) + cosphi = cos (dphi) + sinphi = sin (dphi) + + # Compute the RA. + x = sinthe * FC_SINDEC(fc) - costhe * FC_COSDEC(fc) * cosphi + if (abs (x) < FC_SPHTOL(fc)) + x = -cos (theta + FC_NATDEC(fc)) + costhe * FC_COSDEC(fc) * + (1.0d0 - cosphi) + y = -costhe * sinphi + if (x != 0.0d0 || y != 0.0d0) { + dlng = atan2 (y, x) + } else { + dlng = dphi + DPI + } + ra = DRADTODEG(FC_NATRA(fc) + dlng) + + # Normalize the RA. + if (FC_NATRA(fc) >= 0.0d0) { + if (ra < 0.0d0) + ra = ra + 360.0d0 + } else { + if (ra > 0.0d0) + ra = ra - 360.0d0 + } + if (ra > 360.0d0) + ra = ra - 360.0d0 + else if (ra < -360.0d0) + ra = ra + 360.0d0 + + # Compute the DEC. + if (mod (dphi, DPI) == 0.0d0) { + dec = DRADTODEG(theta + cosphi * FC_NATDEC(fc)) + if (dec > 90.0d0) + dec = 180.0d0 - dec + if (dec < -90.0d0) + dec = -180.0d0 - dec + } else { + z = sinthe * FC_COSDEC(fc) + costhe * FC_SINDEC(fc) * cosphi + if (abs(z) > 0.99d0) { + if (z >= 0.0d0) + dec = DRADTODEG(acos (sqrt(x * x + y * y))) + else + dec = DRADTODEG(-acos (sqrt(x * x + y * y))) + } else + dec = DRADTODEG(asin (z)) + } + + # Store the results. + w[ira] = ra + w[idec] = dec +end + + +# WF_MOL_INV -- Inverse transform (world to physical) for the Mollweide +# projection. + +procedure wf_mol_inv (fc, w, p) + +pointer fc #I pointer to FC descriptor +double w[2] #I input world (RA, DEC) coordinates +double p[2] #I output physical coordinates + +int j, ira, idec +double ra, dec, cosdec, sindec, cosra, sinra, x, y, phi, theta, dphi +double u, v0, v1, v, resid, alpha, tol, z +data tol /1.0d-13/ + +begin + # Get the axes numbers. + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + # Compute the transformation from celestial coordinates RA and + # DEC to native coordinates PHI and THETA. This is the spherical + # geometry part of the transformation. + + ra = DDEGTORAD (w[ira]) - FC_NATRA(fc) + dec = DDEGTORAD (w[idec]) + cosra = cos (ra) + sinra = sin (ra) + cosdec = cos (dec) + sindec = sin (dec) + + # Compute PHI. + x = sindec * FC_SINDEC(fc) - cosdec * FC_COSDEC(fc) * cosra + if (abs(x) < FC_SPHTOL(fc)) + x = -cos (dec + FC_NATDEC(fc)) + cosdec * FC_COSDEC(fc) * + (1.0d0 - cosra) + y = -cosdec * sinra + if (x != 0.0d0 || y != 0.0d0) + dphi = atan2 (y, x) + else + dphi = ra - DPI + phi = FC_LONGP(fc) + dphi + if (phi > DPI) + phi = phi - DTWOPI + else if (phi < -DPI) + phi = phi + DTWOPI + + # Compute THETA. + if (mod (ra, DPI) == 0.0) { + theta = dec + cosra * FC_NATDEC(fc) + if (theta > DHALFPI) + theta = DPI - theta + if (theta < -DHALFPI) + theta = -DPI - theta + } else { + z = sindec * FC_COSDEC(fc) + cosdec * FC_SINDEC(fc) * cosra + if (abs (z) > 0.99d0) { + if (z >= 0.0) + theta = acos (sqrt(x * x + y * y)) + else + theta = -acos (sqrt(x * x + y * y)) + } else + theta = asin (z) + } + + # Compute the transformation from native coordinates PHI and THETA + # to projected coordinates X and Y. + + if (abs(theta) == DHALFPI) { + p[ira] = 0.0d0 + if (theta >= 0.0d0) + p[idec] = FC_C1(fc) + else + p[idec] = -FC_C1(fc) + } else if (theta == 0.0d0) { + p[ira] = FC_C2(fc) * DRADTODEG(phi) + p[idec] = 0.0d0 + } else { + u = DPI * sin (theta) + v0 = -DPI + v1 = DPI + v = u + do j = 1, 100 { + resid = (v - u) + sin (v) + if (resid < 0.0d0) { + if (resid > -tol) + break + v0 = v + } else { + if (resid < tol) + break + v1 = v + } + v = (v0 + v1) / 2.0d0 + } + alpha = v / 2.0d0 + p[ira] = FC_C2(fc) * DRADTODEG(phi) * cos (alpha) + p[idec] = FC_C1(fc) * sin (alpha) + } +end diff --git a/sys/mwcs/wfmspec.x b/sys/mwcs/wfmspec.x new file mode 100644 index 00000000..2f5b5a91 --- /dev/null +++ b/sys/mwcs/wfmspec.x @@ -0,0 +1,578 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +.help WFMSPEC +.nf ------------------------------------------------------------------------- +WFMSPEC -- WCS function driver for MULTISPEC spectral format. + +The dispersion coordinate is along image lines and each line has independent +linear or nonlinear dispersion coordinates. The dispersion coordinates are +defined by specn attributes where n is the physical line number. The format +of the attributes is: + + ap beam dtype w1 dw nw z aplow aphigh coeffs... + +where ap is the aperture number (unique within an image), beam is a beam +number (not used by the driver), dtype is the dispersion type with values + + 0 = linear dispersion + 1 = log linear dispersion + 2 = nonlinear dispersion + +w1 is the wavelength of the first physical pixel, dw is the average +increment per pixel between the first and last pixel, nw is the number of +pixels, z is a redshift factor to be applied to the dispersion coordinates, +aplow and aphigh are aperture limits defining the origin of the spectra (not +used by the driver), and coeffs are the nonlinear dispersion coefficients. + +The nonlinear dispersion function coefficients may describe several function +types; chebyshev polynomial, legendre polynomial, linear spline, cubic +spline, linear interpolation in a pixel coordinate array, and linear +interpolation in a sampled array. + +The axes and dispersion parameters are in terms of the physical image. The +aperture number is used for the world coordinate of the line coordinate. +Coordinates outside the valid range are mapped to nearest valid world +coordinate. In application this would give a correct world coordinate graph +for a general WCS blind graphics task (especially if all invalid pixels have +the same value as the last valid pixel). + +Driver routines: + + FN_INIT wf_msp_init (fc, dir) + FN_DESTROY wf_msp_destroy (fc) + FN_FWD wf_msp_fwd (fc, v1, v2) + FN_INV wf_msp_inv (fc, v1, v2) + +In addition the nonlinear dispersion functions use the following routines: + + wf_msp_coeff Convert the attribute string to a coefficient array + wf_msp_eval Evaluate the function (P->W) + wf_msp_evali Evaluate the inverse function (W->P) + +.endhelp -------------------------------------------------------------------- + +# Driver specific fields of function call (FC) descriptor. +define FC_NAPS Memi[$1+FCU] # number of apertures +define FC_APS Memi[$1+FCU+1] # pointer to indep coords +define FC_DTYPE Memi[$1+FCU+2] # pointer to dispersion type +define FC_CRVAL Memi[$1+FCU+3] # pointer to linear origins +define FC_CDELT Memi[$1+FCU+4] # pointer to linear intervals +define FC_NPTS Memi[$1+FCU+5] # pointer to number of points +define FC_Z Memi[$1+FCU+6] # pointer to doppler corrections +define FC_COEFF Memi[$1+FCU+7] # pointer to nonlinear coeffs +define FC_X Memi[$1+FCU+8] # pointer to last phys. coord. +define FC_DYDX Memi[$1+FCU+9] # pointer to last deriv. +define FC_DIR Memi[$1+FCU+10] # direction of transform + +# Function types. +define CHEBYSHEV 1 # CURFIT Chebyshev polynomial +define LEGENDRE 2 # CURFIT Legendre polynomial +define SPLINE3 3 # CURFIT cubic spline +define SPLINE1 4 # CURFIT linear spline +define PIXEL 5 # pixel coordinate array +define SAMPLE 6 # sampled coordinates + +# Dispersion types. +define LINEAR 0 # linear +define LOG 1 # log linear +define NONLINEAR 2 # nonlinear + +# Iterative inversion parameters. +define NALLOC 10 # size of allocation increments +define NIT 10 # max interations in determining inverse +define DX 0.0001 # accuracy limit in pixels for inverse + +# Size limiting definitions. +define DEF_SZATVAL 2048 # dynamically resized if overflow + + +# WF_MSP_INIT -- Initialize the function call descriptor for the indicated +# type of transform (forward or inverse). + +procedure wf_msp_init (fc, dir) + +pointer fc #I pointer to FC descriptor +int dir #I type of transformation + +pointer ct, mw +int sz_atval, naps, ip, i +pointer sp, atkey, atval, aps, dtype, crval, cdelt, npts, z, coeff +int strlen(), ctoi(), ctod() +double x, dval, wf_msp_eval() +errchk malloc, realloc + +begin + # Get pointers. + ct = FC_CT(fc) + mw = CT_MW(ct) + + # Check axes. + if (FC_NAXES(fc) != 2 || CT_AXIS(ct,1) != 1 || CT_AXIS(ct,2) != 2) + call error (1, "WFMSPEC: Wrong axes") + + # Get spectrum information. + call smark (sp) + sz_atval = DEF_SZATVAL + call malloc (atval, sz_atval, TY_CHAR) + call salloc (atkey, SZ_ATNAME, TY_CHAR) + + for (naps=0; ; naps=naps+1) { + call sprintf (Memc[atkey], SZ_ATNAME, "spec%d") + call pargi (naps+1) + iferr (call mw_gwattrs (mw, 2, Memc[atkey], Memc[atval], sz_atval)) + break + + while (strlen (Memc[atval]) == sz_atval) { + sz_atval = 2 * sz_atval + call realloc (atval, sz_atval, TY_CHAR) + call mw_gwattrs (mw, 2, Memc[atkey], Memc[atval], sz_atval) + } + + if (naps == 0) { + call malloc (aps, NALLOC, TY_INT) + call malloc (dtype, NALLOC, TY_INT) + call malloc (crval, NALLOC, TY_DOUBLE) + call malloc (cdelt, NALLOC, TY_DOUBLE) + call malloc (npts, NALLOC, TY_INT) + call malloc (z, NALLOC, TY_DOUBLE) + call malloc (coeff, NALLOC, TY_POINTER) + } else if (mod (naps, NALLOC) == 0) { + call realloc (aps, naps+NALLOC, TY_INT) + call realloc (dtype, naps+NALLOC, TY_INT) + call realloc (crval, naps+NALLOC, TY_DOUBLE) + call realloc (cdelt, naps+NALLOC, TY_DOUBLE) + call realloc (npts, naps+NALLOC, TY_INT) + call realloc (z, naps+NALLOC, TY_DOUBLE) + call realloc (coeff, naps+NALLOC, TY_POINTER) + } + + # Linear dispersion function. + ip = 1 + if (ctoi (Memc[atval], ip, Memi[aps+naps]) <= 0) + next + if (ctoi (Memc[atval], ip, Memi[dtype+naps]) <= 0) + next + if (ctoi (Memc[atval], ip, Memi[dtype+naps]) <= 0) + next + if (ctod (Memc[atval], ip, Memd[crval+naps]) <= 0) + next + if (ctod (Memc[atval], ip, Memd[cdelt+naps]) <= 0) + next + if (ctoi (Memc[atval], ip, Memi[npts+naps]) <= 0) + next + if (ctod (Memc[atval], ip, Memd[z+naps]) <= 0) + next + if (ctod (Memc[atval], ip, dval) <= 0) + next + if (ctod (Memc[atval], ip, dval) <= 0) + next + Memd[z+naps] = Memd[z+naps] + 1 + + # Set nonlinear dispersion function. + if (Memi[dtype+naps] == NONLINEAR) + call wf_msp_coeff (Memc[atval+ip], Memi[coeff+naps], + double (0.5), double (Memi[npts+naps]+0.5)) + } + + if (naps <= 0) + call error (2, "WFMSPEC: No aperture information") + + call realloc (aps, naps, TY_INT) + call realloc (dtype, naps, TY_INT) + call realloc (crval, naps, TY_DOUBLE) + call realloc (cdelt, naps, TY_DOUBLE) + call realloc (npts, naps, TY_INT) + call realloc (z, naps, TY_DOUBLE) + call realloc (coeff, naps, TY_POINTER) + + FC_NAPS(fc) = naps + FC_APS(fc) = aps + FC_DTYPE(fc) = dtype + FC_CRVAL(fc) = crval + FC_CDELT(fc) = cdelt + FC_NPTS(fc) = npts + FC_Z(fc) = z + FC_COEFF(fc) = coeff + FC_DIR(fc) = dir + + # Setup inverse parameters if needed. + # The parameters make the interative inversion more efficient + # when the inverse transformation is evaluated sequentially. + + if (dir == INVERSE) { + call malloc (crval, naps, TY_DOUBLE) + call malloc (cdelt, naps, TY_DOUBLE) + do i = 0, naps-1 { + if (Memi[FC_NPTS(fc)+i] == 0) + next + if (Memi[FC_DTYPE(fc)+i] == NONLINEAR) { + coeff = Memi[FC_COEFF(fc)+i] + x = Memi[FC_NPTS(fc)+i] + Memd[crval+i] = x + Memd[cdelt+i] = wf_msp_eval (Memd[coeff], x) - + wf_msp_eval (Memd[coeff], x - 1) + } + } + FC_X(fc) = crval + FC_DYDX(fc) = cdelt + } else { + FC_X(fc) = NULL + FC_DYDX(fc) = NULL + } + + call mfree (atval, TY_CHAR) + call sfree (sp) +end + + +# WF_MSP_DESTROY -- Free function driver descriptor. + +procedure wf_msp_destroy (fc) + +pointer fc #I pointer to FC descriptor +int i + +begin + do i = 1, FC_NAPS(fc) + if (Memi[FC_DTYPE(fc)+i-1] == NONLINEAR) + call mfree (Memi[FC_COEFF(fc)+i-1], TY_DOUBLE) + + call mfree (FC_APS(fc), TY_INT) + call mfree (FC_DTYPE(fc), TY_INT) + call mfree (FC_CRVAL(fc), TY_DOUBLE) + call mfree (FC_CDELT(fc), TY_DOUBLE) + call mfree (FC_NPTS(fc), TY_INT) + call mfree (FC_Z(fc), TY_DOUBLE) + call mfree (FC_COEFF(fc), TY_POINTER) + call mfree (FC_X(fc), TY_DOUBLE) + call mfree (FC_DYDX(fc), TY_DOUBLE) +end + + +# WF_MSP_FWD -- Evaluate P -> W (physical to world transformation). + +procedure wf_msp_fwd (fc, in, out) + +pointer fc #I pointer to FC descriptor +double in[2] #I point to sample WCS at +double out[2] #O value of WCS at that point + +int i +pointer coeff +double din, wf_msp_eval() + +begin + i = nint (in[2]) - 1 + if (i < 0 || i >= FC_NAPS(fc)) + call error (3, "WFMSPEC: Coordinate out of bounds") + if (Memi[FC_NPTS(fc)+i] == 0) + call error (4, "WFMSPEC: No dispersion function") + + if (Memi[FC_DTYPE(fc)+i] == NONLINEAR) { + coeff = Memi[FC_COEFF(fc)+i] + out[2] = Memi[FC_APS(fc)+i] + out[1] = wf_msp_eval (Memd[coeff], in[1]) + } else { + din = max (0.5D0, min (double (Memi[FC_NPTS(fc)+i]+0.5), in[1])) + out[2] = Memi[FC_APS(fc)+i] + out[1] = Memd[FC_CRVAL(fc)+i] + Memd[FC_CDELT(fc)+i] * (din - 1) + if (Memi[FC_DTYPE(fc)+i] == LOG) + out[1] = 10. ** out[1] + } + + out[1] = out[1] / Memd[FC_Z(fc)+i] +end + + +# WF_MSP_INV -- Evaluate W -> P (world to physical transformation). + +procedure wf_msp_inv (fc, in, out) + +pointer fc #I pointer to FC descriptor +double in[2] #I point to sample WCS at +double out[2] #O value of WCS at that point + +int i +pointer coeff +double din, dinmin +double wf_msp_evali() + +begin + out[2] = 1 + dinmin = abs (in[2] - Memi[FC_APS(fc)]) + do i = 1, FC_NAPS(fc)-1 { + din = abs (in[2] - Memi[FC_APS(fc)+i]) + if (din < dinmin) { + out[2] = i + 1 + dinmin = din + } + } + + i = nint (out[2]) - 1 + if (i < 0 || i >= FC_NAPS(fc)) + call error (5, "WFMSPEC: Coordinate out of bounds") + if (Memi[FC_NPTS(fc)+i] == 0) + call error (6, "WFMSPEC: No dispersion function") + + din = in[1] * Memd[FC_Z(fc)+i] + if (Memi[FC_DTYPE(fc)+i] == NONLINEAR) { + coeff = Memi[FC_COEFF(fc)+i] + out[1] = wf_msp_evali (Memd[coeff], din, Memd[FC_X(fc)+i], + Memd[FC_DYDX(fc)+i]) + } else { + if (Memi[FC_DTYPE(fc)+i] == LOG) + din = log10 (din) + out[1] = (din-Memd[FC_CRVAL(fc)+i]) / Memd[FC_CDELT(fc)+i] + 1 + out[1] = max (0.5D0, min (double(Memi[FC_NPTS(fc)+i]+0.5), out[1])) + } +end + + +# WF_MSP_COEFF -- Initialize nonlinear coefficient array. + +procedure wf_msp_coeff (atval, coeff, xmin, xmax) + +char atval[ARB] #I attribute string +pointer coeff #O coefficient array +double xmin, xmax #I x limits + +double dval, temp +int ncoeff, type, order, ip, i +errchk malloc, realloc +double wf_msp_eval() +int ctod() + +begin + coeff = NULL + ncoeff = 5 + + ip = 1 + while (ctod (atval, ip, dval) > 0) { + if (coeff == NULL) + call malloc (coeff, NALLOC, TY_DOUBLE) + else if (mod (ncoeff, NALLOC) == 0) + call realloc (coeff, ncoeff+NALLOC, TY_DOUBLE) + Memd[coeff+ncoeff] = dval + ncoeff = ncoeff + 1 + } + if (coeff == NULL) + return + + # Convert range elements to a more efficient form. + call realloc (coeff, ncoeff, TY_DOUBLE) + Memd[coeff] = ncoeff + i = 6 + while (i < ncoeff) { + type = nint (Memd[coeff+i+1]) + order = nint (Memd[coeff+i+2]) + switch (type) { + case CHEBYSHEV, LEGENDRE: + dval = 2 / (Memd[coeff+i+4] - Memd[coeff+i+3]) + Memd[coeff+i+3] = (Memd[coeff+i+4] + Memd[coeff+i+3]) / 2 + Memd[coeff+i+4] = dval + i = i + 6 + order + case SPLINE3: + Memd[coeff+i+4] = nint (Memd[coeff+i+2]) / + (Memd[coeff+i+4] - Memd[coeff+i+3]) + i = i + 9 + order + case SPLINE1: + Memd[coeff+i+4] = nint (Memd[coeff+i+2]) / + (Memd[coeff+i+4] - Memd[coeff+i+3]) + i = i + 7 + order + case PIXEL: + i = i + 4 + order + case SAMPLE: + Memd[coeff+i+3] = i + 5 + i = i + 5 + order + } + } + + # Set function limits. + Memd[coeff+1] = xmin + Memd[coeff+2] = xmax + dval = wf_msp_eval (Memd[coeff], xmin) + temp = wf_msp_eval (Memd[coeff], xmax) + Memd[coeff+3] = min (dval, temp) + Memd[coeff+4] = max (dval, temp) +end + + +# WF_MSP_EVAL -- Evaluate nonlinear function. + +double procedure wf_msp_eval (coeff, xin) + +double coeff[ARB] #I coefficients +double xin #I physical coordinate for evaluation + +int i, j, k, ncoeff, type, order +double xval, x, y, w, ysum, wsum, a, b, c + +begin + ncoeff = nint (coeff[1]) + xval = max (coeff[2], min (coeff[3], xin)) + ysum = 0. + wsum = 0. + j = 6 + while (j < ncoeff) { + type = nint (coeff[j+2]) + order = nint (coeff[j+3]) + y = coeff[j+1] + w = coeff[j] + switch (type) { + case CHEBYSHEV: + x = (xval - coeff[j+4]) * coeff[j+5] + y = y + coeff[j+6] + if (order > 1) + y = y + coeff[j+7] * x + if (order > 2) { + k = j + 8 + a = 1 + b = x + do i = 3, order { + c = 2 * x * b - a + y = y + coeff[k] * c + a = b + b = c + k = k + 1 + } + } + j = j + 6 + order + case LEGENDRE: + x = (xval - coeff[j+4]) * coeff[j+5] + y = y + coeff[j+6] + if (order > 1) + y = y + coeff[j+7] * x + if (order > 2) { + k = j + 8 + a = 1 + b = x + do i = 3, order { + c = ((2 * i - 3) * x * b - (i - 2) * a) / (i - 1) + y = y + coeff[k] * c + a = b + b = c + k = k + 1 + } + } + j = j + 6 + order + case SPLINE3: + x = (xval - coeff[j+4]) * coeff[j+5] + i = max (0, min (int (x), order-1)) + k = j + 6 + i + b = x - i + a = 1 - b + c = a * a * a + y = y + c * coeff[k] + c = 1 + 3 * a * (1 + a * b) + y = y + c * coeff[k+1] + c = 1 + 3 * b * (1 + a * b) + y = y + c * coeff[k+2] + c = b * b * b + y = y + c * coeff[k+3] + j = j + 9 + order + case SPLINE1: + x = (xval - coeff[j+4]) * coeff[j+5] + i = max (0, min (int (x), order-1)) + k = j + 6 + i + b = x - i + a = 1 - b + y = y + a * coeff[k] + b * coeff[k+1] + j = j + 7 + order + case PIXEL: + i = max (1, min (int (xval), order-1)) + x = xval - i + y = y + (1 - x) * coeff[j+3+i] + x * coeff[j+4+i] + j = j + 4 + order + case SAMPLE: + i = nint (coeff[j+4]) + for (k=j+2+order; i < k && xval > coeff[i+2]; i=i+2) + ; + for (k=j+5; i > k && xval < coeff[i-2]; i=i-2) + ; + coeff[j+4] = i + x = (xval - coeff[i]) / (coeff[i+2] - coeff[i]) + y = y + (1 - x) * coeff[i+1] + x * coeff[i+3] + j = j + 5 + order + } + ysum = ysum + w * y + wsum = wsum + w + } + ysum = ysum / wsum + + return (ysum) +end + + +# WF_MSP_EVALI -- Evaluate inverse of nonlinear function. + +double procedure wf_msp_evali (coeff, y, x, dydx) + +double coeff[ARB] #I function coefficients +double y #I world coord to invert +double x #U last physical coordinate +double dydx #U last coordinate derivative + +int i +double xval, yval, y1, dx, dy +double wf_msp_eval() +bool fp_equald() + +begin + yval = max (coeff[4], min (coeff[5], y)) + + dx = 0. + dy = 0. + do i = 1, NIT { + y1 = wf_msp_eval (coeff, x) + if (dx > 1.) { + if (x + 1 < coeff[3]) + dy = wf_msp_eval (coeff, x+1.) - y1 + else + dy = y1 - wf_msp_eval (coeff, x-1.) + } else if (dx < -1.) { + if (x - 1 > coeff[2]) + dy = y1 - wf_msp_eval (coeff, x-1.) + else + dy = wf_msp_eval (coeff, x+1.) - y1 + } + if (!fp_equald (dy, 0.0D0)) + dydx = dy + dx = (yval - y1) / dydx + x = x + dx + x = max (coeff[2], min (coeff[3], x)) + if (abs (dx) < DX) + break + } + + if (i > NIT) { + xval = (coeff[2] + coeff[3]) / 2. + yval = abs (wf_msp_eval (coeff, xval) - y) + dx = (coeff[3] - coeff[2]) / 18. + while (dx > DX) { + for (x=max (coeff[2],xval-9*dx); x<=min (coeff[3],xval+9*dx); + x=x+dx) { + dy = abs (wf_msp_eval (coeff, x) - y) + if (dy < yval) { + xval = x + yval = dy + } + } + dx = dx / 10. + } + x = xval + if (x + 1 < coeff[3]) + dy = wf_msp_eval (coeff, x+1.) - wf_msp_eval (coeff, x) + else + dy = wf_msp_eval (coeff, x) - wf_msp_eval (coeff, x-1.) + if (!fp_equald (dy, 0.0D0)) + dydx = dy + } + + yval = int (x) + x = yval + nint ((x-yval) / DX) * DX + + return (x) +end diff --git a/sys/mwcs/wfpar.x b/sys/mwcs/wfpar.x new file mode 100644 index 00000000..673aa81e --- /dev/null +++ b/sys/mwcs/wfpar.x @@ -0,0 +1,458 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +.help WFPAR +.nf ------------------------------------------------------------------------- +WFPAR -- WCS function driver for the Craster or parabolic projection. + +Driver routines: + + FN_INIT wf_par_init (fc, dir) + FN_DESTROY (none) + FN_FWD wf_par_fwd (fc, v1, v2) + FN_INV wf_par_inv (fc, v1, v2) + +.endhelp -------------------------------------------------------------------- + +# Driver specific fields of function call (FC) descriptor. +define FC_IRA Memi[$1+FCU] # RA axis (1 or 2) +define FC_IDEC Memi[$1+FCU+1] # DEC axis (1 or 2) +define FC_NATRA Memd[P2D($1+FCU+2)] # RA of native pole (rads) +define FC_NATDEC Memd[P2D($1+FCU+4)] # DEC of native pole (rads) +define FC_LONGP Memd[P2D($1+FCU+6)] # LONGPOLE (rads) +define FC_COSDEC Memd[P2D($1+FCU+8)] # cosine (NATDEC) +define FC_SINDEC Memd[P2D($1+FCU+10)] # sine (NATDEC) +define FC_SPHTOL Memd[P2D($1+FCU+12)] # trig tolerance +define FC_RODEG Memd[P2D($1+FCU+14)] # RO (degs) +define FC_RECRODEG Memd[P2D($1+FCU+16)] # 1 / RO (degs) +define FC_PIRODEG Memd[P2D($1+FCU+18)] # PI * RO (degs) +define FC_RECPIRODEG Memd[P2D($1+FCU+20)] # 1 / (PI * RO) (degs) +define FC_BADCVAL Memd[P2D($1+FCU+22)] # bad coordinate value +define FC_W Memd[P2D($1+FCU+24)+($2)-1] # CRVAL axis (1 and 2) + +# WF_PAR_INIT -- Initialize the forward or inverse Craster or parabolic +# transform. Initialization for this transformation consists of, +# determining which axis is RA / LON and which is DEC / LAT, reading in the +# native longitude and latitude of the pole in celestial coordinates LONGPOLE +# and LATPOLE from the attribute list, computing the celestial longitude and +# colatitude of the native pole, precomputing the Euler angles and associated +# intermediary functions of the reference point, reading in the projection +# parameter RO from the attribute list, and precomputing the various required +# intermediate quantities. If LONGPOLE is undefined then a value of 180.0 +# degrees is assumed if the celestial latitude of the reference point is less +# than 0, otherwise 0 degrees is assumed. If LATPOLE is undefined then the +# most northerly of the two possible solutions is chosen, otherwise the +# solution closest to LATPOLE is chosen. If RO is undefined a value of 180.0 / +# PI is assumed. In order to determine the axis order, the parameter +# "axtype={ra|dec} {xlon|xlat}" must have been set in the attribute list for +# the function. The LONGPOLE, LATPOLE, and RO parameters may be set in either +# or both of the axes attribute lists, but the value in the RA axis attribute +# list takes precedence. + +procedure wf_par_init (fc, dir) + +pointer fc #I pointer to FC descriptor +int dir #I direction of transform + +int i +double dec, latpole, theta0, clat0, slat0, cphip, sphip, cthe0, sthe0, x, y, z +double u, v, latp1, latp2, latp, maxlat, tol +pointer sp, atvalue, ct, mw, wp, wv +int ctod() +data tol/1.0d-10/ +errchk wf_decaxis(), mw_gwattrs() + +begin + # Allocate space for the attribute string. + call smark (sp) + call salloc (atvalue, SZ_LINE, TY_CHAR) + + # Get the required mwcs pointers. + ct = FC_CT(fc) + mw = CT_MW(ct) + wp = FC_WCS(fc) + + # Determine which is the DEC axis, and hence the axis order. + call wf_decaxis (fc, FC_IRA(fc), FC_IDEC(fc)) + + # Get the value of W for each axis, i.e. the world coordinates at + # the reference point. + + wv = MI_DBUF(mw) + WCS_W(wp) - 1 + do i = 1, 2 + FC_W(fc,i) = Memd[wv+CT_AXIS(ct,FC_AXIS(fc,i))-1] + + # Determine the native longitude and latitude of the pole of the + # celestial coordinate system corresponding to the FITS keywords + # LONGPOLE and LATPOLE. LONGPOLE has no default but will be set + # to 180 or 0 depending on the value of the declination of the + # reference point. LATPOLE has no default but will be set depending + # on the values of LONGPOLE and the reference declination. + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "longpole", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "longpole", Memc[atvalue], + SZ_LINE) + } then { + FC_LONGP(fc) = INDEFD + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_LONGP(fc)) <= 0) + FC_LONGP(fc) = INDEFD + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_LONGP(fc)) <= 0) + FC_LONGP(fc) = INDEFD + } + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "latpole", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "latpole", Memc[atvalue], + SZ_LINE) + } then { + latpole = INDEFD + } else { + i = 1 + if (ctod (Memc[atvalue], i, latpole) <= 0) + latpole = INDEFD + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, latpole) <= 0) + latpole = INDEFD + } + + # Fetch the RO projection parameter which is the radius of the + # generating sphere for the projection. If RO is absent which + # is the usual case set it to 180 / PI. Search both axes for + # this quantity. + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "ro", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "ro", Memc[atvalue], + SZ_LINE) + } then { + FC_RODEG(fc) = 180.0d0 / DPI + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_RODEG(fc)) <= 0) + FC_RODEG(fc) = 180.0d0 / DPI + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_RODEG(fc)) <= 0) + FC_RODEG(fc) = 180.0d0 / DPI + } + + # Compute the native longitude of the celestial pole. + dec = DDEGTORAD(FC_W(fc,FC_IDEC(fc))) + theta0 = 0.0d0 + if (IS_INDEFD(FC_LONGP(fc))) { + if (dec < theta0) + FC_LONGP(fc) = DPI + else + FC_LONGP(fc) = 0.0d0 + } else + FC_LONGP(fc) = DDEGTORAD(FC_LONGP(fc)) + + # Compute the celestial longitude and latitude of the native pole. + clat0 = cos (dec) + slat0 = sin (dec) + cphip = cos (FC_LONGP(fc)) + sphip = sin (FC_LONGP(fc)) + cthe0 = cos (theta0) + sthe0 = sin (theta0) + + x = cthe0 * cphip + y = sthe0 + z = sqrt (x * x + y * y) + + # The latitude of the native pole is determined by LATPOLE in this + # case. + if (z == 0.0d0) { + + if (slat0 != 0.0d0) + call error (0, "WF_PAR_INIT: Invalid projection parameters") + if (IS_INDEFD(latpole)) + latp = 999.0d0 + else + latp = DDEGTORAD(latpole) + + } else { + if (abs (slat0 / z) > 1.0d0) + call error (0, "WF_PAR_INIT: Invalid projection parameters") + + u = atan2 (y, x) + v = acos (slat0 / z) + latp1 = u + v + if (latp1 > DPI) + latp1 = latp1 - DTWOPI + else if (latp1 < -DPI) + latp1 = latp1 + DTWOPI + + latp2 = u - v + if (latp2 > DPI) + latp2 = latp2 - DTWOPI + else if (latp2 < -DPI) + latp2 = latp2 + DTWOPI + + if (IS_INDEFD(latpole)) + maxlat = 999.0d0 + else + maxlat = DDEGTORAD(latpole) + if (abs (maxlat - latp1) < abs (maxlat - latp2)) { + if (abs (latp1) < (DHALFPI + tol)) + latp = latp1 + else + latp = latp2 + } else { + if (abs (latp2) < (DHALFPI + tol)) + latp = latp2 + else + latp = latp1 + } + } + + FC_NATDEC(fc) = DHALFPI - latp + + z = cos (latp) * clat0 + if (abs(z) < tol) { + + # Celestial pole at the reference point. + if (abs(clat0) < tol) { + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) + FC_NATDEC(fc) = DHALFPI - theta0 + # Celestial pole at the native north pole. + } else if (latp > 0.0d0) { + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) + FC_LONGP(fc) - + DPI + FC_NATDEC(fc) = 0.0d0 + # Celestial pole at the native south pole. + } else if (latp < 0.0d0) { + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) - FC_LONGP(fc) + FC_NATDEC(fc) = DPI + } + + } else { + x = (sthe0 - sin (latp) * slat0) / z + y = sphip * cthe0 / clat0 + if (x == 0.0d0 && y == 0.0d0) + call error (0, "WF_PAR_INIT: Invalid projection parameters") + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) - atan2 (y,x) + } + + if (FC_W(fc,FC_IRA(fc)) >= 0.0d0) { + if (FC_NATRA(fc) < 0.0d0) + FC_NATRA(fc) = FC_NATRA(fc) + DTWOPI + } else { + if (FC_NATRA(fc) > 0.0d0) + FC_NATRA(fc) = FC_NATRA(fc) - DTWOPI + } + FC_COSDEC(fc) = cos (FC_NATDEC(fc)) + FC_SINDEC(fc) = sin (FC_NATDEC(fc)) + + # Check for ill-conditioned parameters. + if (abs(latp) > (DHALFPI+tol)) + call error (0, "WF_PAR_INIT: Invalid projection parameters") + + # Compute the required intermediate quantities. + FC_RECRODEG(fc) = 1.0d0 / FC_RODEG(fc) + FC_PIRODEG(fc) = DPI * FC_RODEG(fc) + FC_RECPIRODEG(fc) = 1.0d0 / FC_PIRODEG(fc) + + # Set the bad coordinate value. + FC_SPHTOL(fc) = 1.0d-5 + + # Set the bad coordinate value. + FC_BADCVAL(fc) = INDEFD + + # Free working space. + call sfree (sp) +end + + +# WF_PAR_FWD -- Forward transform (physical to world) for the Craster or +# parabolic projection. + +procedure wf_par_fwd (fc, p, w) + +pointer fc #I pointer to FC descriptor +double p[2] #I physical coordinates (x, y) +double w[2] #O world coordinates (ra, dec) + +int ira, idec +double x, y, s, t, phi, theta, costhe, sinthe, dphi, cosphi, sinphi +double ra, dec, dlng, z + +begin + # Get the axis numbers. + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + # Compute native spherical coordinates PHI and THETA in degrees from + # the projected coordinates. This is the projection part of the + # computation. + + x = p[ira] + y = p[idec] + + # Compute PHI. + s = y * FC_RECPIRODEG(fc) + if (s > 1.0d0 || s < -1.0d0) { + w[ira] = FC_BADCVAL(fc) + w[idec] = FC_BADCVAL(fc) + return + } + t = 1.0d0 - 4.0d0 * s * s + if (t == 0.0d0) { + if (x == 0.0d0) { + phi = 0.0d0 + } else { + w[ira] = FC_BADCVAL(fc) + w[idec] = FC_BADCVAL(fc) + return + } + } else + phi = FC_RECRODEG(fc) * x / t + + # Compute THETA. + theta = 3.0d0 * asin (s) + + # Compute the celestial coordinates RA and DEC from the native + # coordinates PHI and THETA. This is the spherical geometry part + # of the computation. + + costhe = cos (theta) + sinthe = sin (theta) + dphi = phi - FC_LONGP(fc) + cosphi = cos (dphi) + sinphi = sin (dphi) + + # Compute the RA. + x = sinthe * FC_SINDEC(fc) - costhe * FC_COSDEC(fc) * cosphi + if (abs (x) < FC_SPHTOL(fc)) + x = -cos (theta + FC_NATDEC(fc)) + costhe * FC_COSDEC(fc) * + (1.0d0 - cosphi) + y = -costhe * sinphi + if (x != 0.0d0 || y != 0.0d0) { + dlng = atan2 (y, x) + } else { + dlng = dphi + DPI + } + ra = DRADTODEG(FC_NATRA(fc) + dlng) + + # Normalize the RA. + if (FC_NATRA(fc) >= 0.0d0) { + if (ra < 0.0d0) + ra = ra + 360.0d0 + } else { + if (ra > 0.0d0) + ra = ra - 360.0d0 + } + if (ra > 360.0d0) + ra = ra - 360.0d0 + else if (ra < -360.0d0) + ra = ra + 360.0d0 + + # Compute the DEC. + if (mod (dphi, DPI) == 0.0d0) { + dec = DRADTODEG(theta + cosphi * FC_NATDEC(fc)) + if (dec > 90.0d0) + dec = 180.0d0 - dec + if (dec < -90.0d0) + dec = -180.0d0 - dec + } else { + z = sinthe * FC_COSDEC(fc) + costhe * FC_SINDEC(fc) * cosphi + if (abs(z) > 0.99d0) { + if (z >= 0.0d0) + dec = DRADTODEG(acos (sqrt(x * x + y * y))) + else + dec = DRADTODEG(-acos (sqrt(x * x + y * y))) + } else + dec = DRADTODEG(asin (z)) + } + + # Store the results. + w[ira] = ra + w[idec] = dec +end + + +# WF_PAR_INV -- Inverse transform (world to physical) for the Craster +# or parabolic projection. + +procedure wf_par_inv (fc, w, p) + +pointer fc #I pointer to FC descriptor +double w[2] #I input world (RA, DEC) coordinates +double p[2] #I output physical coordinates + +int ira, idec +double ra, dec, cosdec, sindec, cosra, sinra, x, y, phi, theta, s, dphi, z + +begin + # Get the axes numbers. + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + # Compute the transformation from celestial coordinates RA and + # DEC to native coordinates PHI and THETA. This is the spherical + # geometry part of the transformation. + + ra = DDEGTORAD (w[ira]) - FC_NATRA(fc) + dec = DDEGTORAD (w[idec]) + cosra = cos (ra) + sinra = sin (ra) + cosdec = cos (dec) + sindec = sin (dec) + + # Compute PHI. + x = sindec * FC_SINDEC(fc) - cosdec * FC_COSDEC(fc) * cosra + if (abs(x) < FC_SPHTOL(fc)) + x = -cos (dec + FC_NATDEC(fc)) + cosdec * FC_COSDEC(fc) * + (1.0d0 - cosra) + y = -cosdec * sinra + if (x != 0.0d0 || y != 0.0d0) + dphi = atan2 (y, x) + else + dphi = ra - DPI + phi = FC_LONGP(fc) + dphi + if (phi > DPI) + phi = phi - DTWOPI + else if (phi < -DPI) + phi = phi + DTWOPI + + # Compute THETA. + if (mod (ra, DPI) == 0.0) { + theta = dec + cosra * FC_NATDEC(fc) + if (theta > DHALFPI) + theta = DPI - theta + if (theta < -DHALFPI) + theta = -DPI - theta + } else { + z = sindec * FC_COSDEC(fc) + cosdec * FC_SINDEC(fc) * cosra + if (abs (z) > 0.99d0) { + if (z >= 0.0) + theta = acos (sqrt(x * x + y * y)) + else + theta = -acos (sqrt(x * x + y * y)) + } else + theta = asin (z) + } + + # Compute the transformation from native coordinates PHI and THETA + # to projected coordinates X and Y. + + s = sin (theta / 3.0d0) + p[ira] = FC_RODEG(fc) * phi * (1.0d0 - 4.0 * s * s) + p[idec] = FC_PIRODEG(fc) * s +end diff --git a/sys/mwcs/wfpco.x b/sys/mwcs/wfpco.x new file mode 100644 index 00000000..a9cd8e12 --- /dev/null +++ b/sys/mwcs/wfpco.x @@ -0,0 +1,518 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +.help WFPCO +.nf ------------------------------------------------------------------------- +WFPCO -- WCS function driver for the polyconic projection. + +Driver routines: + + FN_INIT wf_pco_init (fc, dir) + FN_DESTROY (none) + FN_FWD wf_pco_fwd (fc, v1, v2) + FN_INV wf_pco_inv (fc, v1, v2) + +.endhelp -------------------------------------------------------------------- + +# Driver specific fields of function call (FC) descriptor. +define FC_IRA Memi[$1+FCU] # RA axis (1 or 2) +define FC_IDEC Memi[$1+FCU+1] # DEC axis (1 or 2) +define FC_NATRA Memd[P2D($1+FCU+2)] # RA of native pole (rads) +define FC_NATDEC Memd[P2D($1+FCU+4)] # DEC of native pole (rads) +define FC_LONGP Memd[P2D($1+FCU+6)] # LONGPOLE (rads) +define FC_COSDEC Memd[P2D($1+FCU+8)] # cosine (NATDEC) +define FC_SINDEC Memd[P2D($1+FCU+10)] # sine (NATDEC) +define FC_SPHTOL Memd[P2D($1+FCU+12)] # trig tolerance +define FC_RODEG Memd[P2D($1+FCU+14)] # RO (degs) +define FC_RORAD Memd[P2D($1+FCU+16)] # RO (rads) +define FC_RECRORAD Memd[P2D($1+FCU+18)] # 1 / RO (rads) +define FC_2RODEG Memd[P2D($1+FCU+20)] # 2 * RO +define FC_BADCVAL Memd[P2D($1+FCU+22)] # bad coordinate value +define FC_W Memd[P2D($1+FCU+24)+($2)-1] # CRVAL axis (1 and 2) + + +# WF_PCO_INIT -- Initialize the polyconic forward or inverse +# transform. Initialization for this transformation consists of, determining +# which axis is RA / LON and which is DEC / LAT, reading in the the native +# longitude and latitude of the pole in celestial coordinates LONGPOLE and +# LATPOLE from the attribute list, computing the celestial longitude and +# colatitude of the native pole, precomputing the Euler anges and various +# intermediary functions of the reference point, and reading in the +# projection parameter RO from the attribute list. If LONGPOLE is undefined +# then a value of 180.0 degrees is assumed if the native latitude of the +# reference point is less than 0, otherwise 0 is assumed. If LATPOLE is +# undefined then the most northerly of the two possible solutions for the +# latitude of the native pole is chosen, otherwise the solution closest to +# LATPOLE is chosen. If RO is undefined a value of 180.0 / PI is assumed. +# In order to determine the axis order, the parameter "axtype={ra|dec} +# {xlon|xlat}" must have been set in the attribute list for the function. +# The LONGPOLE, LATPOLE and RO parameters may be set in either or both of the +# axes attribute lists, but the value in the RA axis attribute list takes +# precedence. + +procedure wf_pco_init (fc, dir) + +pointer fc #I pointer to FC descriptor +int dir #I direction of transform + +int i +double dec, latpole, theta0, clat0, slat0, cphip, sphip, cthe0, sthe0, x, y, z +double u, v, latp1, latp2, latp, maxlat, tol +pointer sp, atvalue, ct, mw, wp, wv +int ctod() +data tol/1.0d-10/ +errchk wf_decaxis(), mw_gwattrs() + +begin + # Allocate space for the attribute string. + call smark (sp) + call salloc (atvalue, SZ_LINE, TY_CHAR) + + # Get the required mwcs pointers. + ct = FC_CT(fc) + mw = CT_MW(ct) + wp = FC_WCS(fc) + + # Determine which is the DEC axis, and hence the axis order. + call wf_decaxis (fc, FC_IRA(fc), FC_IDEC(fc)) + + # Get the value of W for each axis, i.e. the world coordinates at + # the reference point. + + wv = MI_DBUF(mw) + WCS_W(wp) - 1 + do i = 1, 2 + FC_W(fc,i) = Memd[wv+CT_AXIS(ct,FC_AXIS(fc,i))-1] + + # Determine the native longitude and latitude of the pole of the + # celestial coordinate system corresponding to the FITS keywords + # LONGPOLE and LATPOLE. LONGPOLE has no default but will be set + # to 180 or 0 depending on the value of the declination of the + # reference point. LATPOLE has no default but will be set depending + # on the values of LONGPOLE and the reference declination. + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "longpole", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "longpole", Memc[atvalue], + SZ_LINE) + } then { + FC_LONGP(fc) = INDEFD + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_LONGP(fc)) <= 0) + FC_LONGP(fc) = INDEFD + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_LONGP(fc)) <= 0) + FC_LONGP(fc) = INDEFD + } + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "latpole", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "latpole", Memc[atvalue], + SZ_LINE) + } then { + latpole = INDEFD + } else { + i = 1 + if (ctod (Memc[atvalue], i, latpole) <= 0) + latpole = INDEFD + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, latpole) <= 0) + latpole = INDEFD + } + + # Fetch the RO projection parameter which is the radius of the + # generating sphere for the projection. If RO is absent which + # is the usual case set it to 180 / PI. Search both axes for + # this quantity. + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "ro", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "ro", Memc[atvalue], + SZ_LINE) + } then { + FC_RODEG(fc) = 180.0d0 / DPI + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_RODEG(fc)) <= 0) + FC_RODEG(fc) = 180.0d0 / DPI + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_RODEG(fc)) <= 0) + FC_RODEG(fc) = 180.0d0 / DPI + } + + # Compute the native longitude of the celestial pole. + dec = DDEGTORAD(FC_W(fc,FC_IDEC(fc))) + theta0 = 0.0d0 + if (IS_INDEFD(FC_LONGP(fc))) { + if (dec < theta0) + FC_LONGP(fc) = DPI + else + FC_LONGP(fc) = 0.0d0 + } else + FC_LONGP(fc) = DDEGTORAD(FC_LONGP(fc)) + + # Compute the celestial longitude and latitude of the native pole. + clat0 = cos (dec) + slat0 = sin (dec) + cphip = cos (FC_LONGP(fc)) + sphip = sin (FC_LONGP(fc)) + cthe0 = cos (theta0) + sthe0 = sin (theta0) + + x = cthe0 * cphip + y = sthe0 + z = sqrt (x * x + y * y) + + # The latitude of the native pole is determined by LATPOLE in this + # case. + if (z == 0.0d0) { + + if (slat0 != 0.0d0) + call error (0, "WF_PCO_INIT: Invalid projection parameters") + if (IS_INDEFD(latpole)) + latp = 999.0d0 + else + latp = DDEGTORAD(latpole) + + } else { + if (abs (slat0 / z) > 1.0d0) + call error (0, "WF_PCO_INIT: Invalid projection parameters") + + + u = atan2 (y, x) + v = acos (slat0 / z) + latp1 = u + v + if (latp1 > DPI) + latp1 = latp1 - DTWOPI + else if (latp1 < -DPI) + latp1 = latp1 + DTWOPI + + latp2 = u - v + if (latp2 > DPI) + latp2 = latp2 - DTWOPI + else if (latp2 < -DPI) + latp2 = latp2 + DTWOPI + + if (IS_INDEFD(latpole)) + maxlat = 999.0d0 + else + maxlat = DDEGTORAD(latpole) + if (abs (maxlat - latp1) < abs (maxlat - latp2)) { + if (abs (latp1) < (DHALFPI + tol)) + latp = latp1 + else + latp = latp2 + } else { + if (abs (latp2) < (DHALFPI + tol)) + latp = latp2 + else + latp = latp1 + } + } + + FC_NATDEC(fc) = DHALFPI - latp + + z = cos (latp) * clat0 + if (abs(z) < tol) { + + # Celestial pole at the reference point. + if (abs(clat0) < tol) { + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) + FC_NATDEC(fc) = DHALFPI - theta0 + # Celestial pole at the native north pole. + } else if (latp > 0.0d0) { + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) + FC_LONGP(fc) - + DPI + FC_NATDEC(fc) = 0.0d0 + # Celestial pole at the native south pole. + } else if (latp < 0.0d0) { + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) - FC_LONGP(fc) + FC_NATDEC(fc) = DPI + } + + } else { + x = (sthe0 - sin (latp) * slat0) / z + y = sphip * cthe0 / clat0 + if (x == 0.0d0 && y == 0.0d0) + call error (0, "WF_PCO_INIT: Invalid projection parameters") + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) - atan2 (y,x) + } + + if (FC_W(fc,FC_IRA(fc)) >= 0.0d0) { + if (FC_NATRA(fc) < 0.0d0) + FC_NATRA(fc) = FC_NATRA(fc) + DTWOPI + } else { + if (FC_NATRA(fc) > 0.0d0) + FC_NATRA(fc) = FC_NATRA(fc) - DTWOPI + } + FC_COSDEC(fc) = cos (FC_NATDEC(fc)) + FC_SINDEC(fc) = sin (FC_NATDEC(fc)) + + # Check for ill-conditioned parameters. + if (abs(latp) > (DHALFPI+tol)) + call error (0, "WF_PCO_INIT: Invalid projection parameters") + + # Compute the required intermediate quantities. + FC_RORAD(fc) = DDEGTORAD(FC_RODEG(fc)) + FC_RECRORAD(fc) = 1.0d0 / FC_RORAD(fc) + FC_2RODEG(fc) = 2.0d0 * FC_RODEG(fc) + + # Set the bad coordinate value. + FC_SPHTOL(fc) = 1.0d-5 + + # Set the bad coordinate value. + FC_BADCVAL(fc) = INDEFD + + # Free working space. + call sfree (sp) +end + + +# WF_PCO_FWD -- Forward transform (physical to world) for the polyconic +# projection. + +procedure wf_pco_fwd (fc, p, w) + +pointer fc #I pointer to FC descriptor +double p[2] #I physical coordinates (x, y) +double w[2] #O world coordinates (ra, dec) + +int ira, idec, j +double x, y, z, phi, theta, costhe, sinthe, dphi, cosphi, sinphi +double ra, dec, wconst, tol, thepos, theneg, xx, ymthe, fpos, fneg, lambda +double tanthe, f, dlng +double xp, yp +data tol / 1.0d-12/ + +begin + # Get the axis numbers. + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + # Compute native spherical coordinates PHI and THETA in degrees from + # the projected coordinates. This is the projection part of the + # computation. + + x = p[ira] + y = p[idec] + + # Compute PHI and THETA. + wconst = abs (y * FC_RECRORAD(fc)) + if (wconst < tol) { + phi = x * FC_RECRORAD(fc) + theta = 0.0d0 + } else if (abs (wconst - 90.0d0) < tol) { + phi = 0.0d0 + if (y >= 0.0d0) + theta = DHALFPI + else + theta = -DHALFPI + } else { + if (y > 0.0d0) + thepos = 90.0d0 + else + thepos = -90.0d0 + theneg = 0.0d0 + + xx = x * x + ymthe = y - FC_RORAD(fc) * thepos + fpos = xx + ymthe * ymthe + fneg = -999.0d0 + + do j = 1, 64 { + + # Compute the required interval. + if (fneg < -100.0d0) + theta = (thepos + theneg) / 2.0d0 + else { + lambda = fpos / (fpos - fneg) + if (lambda < 0.1d0) + lambda = 0.1d0 + else if (lambda > 0.9d0) + lambda = 0.9d0 + theta = thepos - lambda * (thepos - theneg) + } + + # Compute the residue. + ymthe = y - FC_RORAD(fc) * theta + tanthe = tan (DDEGTORAD(theta)) + f = xx + ymthe * (ymthe - FC_2RODEG(fc) / tanthe) + + # Check for convergence. + if (abs(f) < tol) + break + if (abs (thepos - theneg) < tol) + break + + # Redefine the interval + if (f > 0.0d0) { + thepos = theta + fpos = f + } else { + theneg = theta + fneg = f + } + } + + theta = DDEGTORAD(theta) + xp = FC_RODEG(fc) - ymthe * tanthe + yp = x * tanthe + if (xp == 0.0d0 && yp == 0.0d0) + phi = 0.0d0 + else + phi = atan2 (yp, xp) / sin (theta) + } + + # Compute the celestial coordinates RA and DEC from the native + # coordinates PHI and THETA. This is the spherical geometry part + # of the computation. + + costhe = cos (theta) + sinthe = sin (theta) + dphi = phi - FC_LONGP(fc) + cosphi = cos (dphi) + sinphi = sin (dphi) + + # Compute the RA. + x = sinthe * FC_SINDEC(fc) - costhe * FC_COSDEC(fc) * cosphi + if (abs (x) < FC_SPHTOL(fc)) + x = -cos (theta + FC_NATDEC(fc)) + costhe * FC_COSDEC(fc) * + (1.0d0 - cosphi) + y = -costhe * sinphi + if (x != 0.0d0 || y != 0.0d0) { + dlng = atan2 (y, x) + } else { + dlng = dphi + DPI + } + ra = DRADTODEG(FC_NATRA(fc) + dlng) + + # Normalize the RA. + if (FC_NATRA(fc) >= 0.0d0) { + if (ra < 0.0d0) + ra = ra + 360.0d0 + } else { + if (ra > 0.0d0) + ra = ra - 360.0d0 + } + if (ra > 360.0d0) + ra = ra - 360.0d0 + else if (ra < -360.0d0) + ra = ra + 360.0d0 + + # Compute the DEC. + if (mod (dphi, DPI) == 0.0d0) { + dec = DRADTODEG(theta + cosphi * FC_NATDEC(fc)) + if (dec > 90.0d0) + dec = 180.0d0 - dec + if (dec < -90.0d0) + dec = -180.0d0 - dec + } else { + z = sinthe * FC_COSDEC(fc) + costhe * FC_SINDEC(fc) * cosphi + if (abs(z) > 0.99d0) { + if (z >= 0.0d0) + dec = DRADTODEG(acos (sqrt(x * x + y * y))) + else + dec = DRADTODEG(-acos (sqrt(x * x + y * y))) + } else + dec = DRADTODEG(asin (z)) + } + + # Store the results. + w[ira] = ra + w[idec] = dec +end + + +# WF_PCO_INV -- Inverse transform (world to physical) for the polyconic +# projection. + +procedure wf_pco_inv (fc, w, p) + +pointer fc #I pointer to FC descriptor +double w[2] #I input world (RA, DEC) coordinates +double p[2] #I output physical coordinates + +int ira, idec +double ra, dec, cosdec, sindec, cosra, sinra, x, y, phi, theta, costhe +double a, sinthe, cotthe, dphi, z + +begin + # Get the axes numbers. + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + # Compute the transformation from celestial coordinates RA and + # DEC to native coordinates PHI and THETA. This is the spherical + # geometry part of the transformation. + + ra = DDEGTORAD (w[ira]) - FC_NATRA(fc) + dec = DDEGTORAD (w[idec]) + cosra = cos (ra) + sinra = sin (ra) + cosdec = cos (dec) + sindec = sin (dec) + + # Compute PHI. + x = sindec * FC_SINDEC(fc) - cosdec * FC_COSDEC(fc) * cosra + if (abs(x) < FC_SPHTOL(fc)) + x = -cos (dec + FC_NATDEC(fc)) + cosdec * FC_COSDEC(fc) * + (1.0d0 - cosra) + y = -cosdec * sinra + if (x != 0.0d0 || y != 0.0d0) + dphi = atan2 (y, x) + else + dphi = ra - DPI + phi = FC_LONGP(fc) + dphi + if (phi > DPI) + phi = phi - DTWOPI + else if (phi < -DPI) + phi = phi + DTWOPI + + # Compute THETA. + if (mod (ra, DPI) == 0.0) { + theta = dec + cosra * FC_NATDEC(fc) + if (theta > DHALFPI) + theta = DPI - theta + if (theta < -DHALFPI) + theta = -DPI - theta + } else { + z = sindec * FC_COSDEC(fc) + cosdec * FC_SINDEC(fc) * cosra + if (abs (z) > 0.99d0) { + if (z >= 0.0) + theta = acos (sqrt(x * x + y * y)) + else + theta = -acos (sqrt(x * x + y * y)) + } else + theta = asin (z) + } + + # Compute the transformation from native coordinates PHI and THETA + # to projected coordinates X and Y. + + costhe = cos (theta) + sinthe = sin (theta) + a = phi * sinthe + if (sinthe == 0.0d0) { + p[ira] = FC_RODEG(fc) * phi + p[idec] = 0.0d0 + } else { + cotthe = costhe / sinthe + p[ira] = FC_RODEG(fc) * cotthe * sin (a) + p[idec] = FC_RODEG(fc) * (cotthe * (1.0d0 - cos(a)) + theta) + } + +end diff --git a/sys/mwcs/wfqsc.x b/sys/mwcs/wfqsc.x new file mode 100644 index 00000000..b75535e7 --- /dev/null +++ b/sys/mwcs/wfqsc.x @@ -0,0 +1,758 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +.help WFQSC +.nf ------------------------------------------------------------------------- +WFQSC -- WCS function driver for quadrilateralized spherical cube projection. + +Driver routines: + + FN_INIT wf_qsc_init (fc, dir) + FN_DESTROY (none) + FN_FWD wf_qsc_fwd (fc, v1, v2) + FN_INV wf_qsc_inv (fc, v1, v2) + +.endhelp -------------------------------------------------------------------- + +# Driver specific fields of function call (FC) descriptor. +define FC_IRA Memi[$1+FCU] # RA axis (1 or 2) +define FC_IDEC Memi[$1+FCU+1] # DEC axis (1 or 2) +define FC_NATRA Memd[P2D($1+FCU+2)] # RA of native pole (rads) +define FC_NATDEC Memd[P2D($1+FCU+4)] # DEC of native pole (rads) +define FC_LONGP Memd[P2D($1+FCU+6)] # LONGPOLE (rads) +define FC_COSDEC Memd[P2D($1+FCU+8)] # cosine (NATDEC) +define FC_SINDEC Memd[P2D($1+FCU+10)] # sine (NATDEC) +define FC_SPHTOL Memd[P2D($1+FCU+12)] # trig tolerance +define FC_RODEG Memd[P2D($1+FCU+14)] # RO (degs) +define FC_C1 Memd[P2D($1+FCU+16)] # RO * (PI / 4) +define FC_C2 Memd[P2D($1+FCU+18)] # (4 / PI) / RO +define FC_BADCVAL Memd[P2D($1+FCU+20)] # bad coordinate value +define FC_W Memd[P2D($1+FCU+22)+($2)-1] # CRVAL axis (1 and 2) + + +# WF_QSC_INIT -- Initialize the forward or inverse quarilateralized spherical +# cube projection transform. Initialization for this transformation consists +# of, determining which axis is RA / LON and which is DEC / LAT, reading in +# the native longitude and latitude of the pole in celestial coordinates +# LONGPOLE and LATPOLE from the attribute list, computing the celestial +# longitude and colatitude of the native pole, precomputing the Euler angles +# and various intermediary functions of the reference point, reading in the +# projection parameter RO from the attribute list, and precomputing the various +# required intermediate quantities. If LONGPOLE is undefined then a value of +# 180.0 degrees is assumed if the celestial latitude is less than 0, otherwise +# 0 degrees is assumed. If LATPOLE is undefined the most northerly of the two +# possible solutions is chosen, otherwise the solution closest to LATPOLE is +# chosen. If RO is undefined a value of 180.0 / PI is assumed. In order to +# determine the axis order, the parameter "axtype={ra|dec} {xlon|xlat}" must +# have been set in the attribute list for the function. The LONGPOLE, LATPOLE, +# and RO parameters may be set in either or both of the axes attribute lists, +# but the value in the RA axis attribute list takes precedence. + +procedure wf_qsc_init (fc, dir) + +pointer fc #I pointer to FC descriptor +int dir #I direction of transform + +int i +double dec, latpole, theta0, clat0, slat0, cphip, sphip, cthe0, sthe0, x, y, z +double u, v, latp1, latp2, latp, maxlat, tol +pointer sp, atvalue, ct, mw, wp, wv +int ctod() +data tol/1.0d-10/ +errchk wf_decaxis(), mw_gwattrs() + +begin + # Allocate space for the attribute string. + call smark (sp) + call salloc (atvalue, SZ_LINE, TY_CHAR) + + # Get the required mwcs pointers. + ct = FC_CT(fc) + mw = CT_MW(ct) + wp = FC_WCS(fc) + + # Determine which is the DEC axis, and hence the axis order. + call wf_decaxis (fc, FC_IRA(fc), FC_IDEC(fc)) + + # Get the value of W for each axis, i.e. the world coordinates at + # the reference point. + + wv = MI_DBUF(mw) + WCS_W(wp) - 1 + do i = 1, 2 + FC_W(fc,i) = Memd[wv+CT_AXIS(ct,FC_AXIS(fc,i))-1] + + # Determine the native longitude and latitude of the pole of the + # celestial coordinate system corresponding to the FITS keywords + # LONGPOLE and LATPOLE. LONGPOLE has no default but will be set + # to 180 or 0 depending on the value of the declination of the + # reference point. LATPOLE has no default but will be set depending + # on the values of LONGPOLE and the reference declination. + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "longpole", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "longpole", Memc[atvalue], + SZ_LINE) + } then { + FC_LONGP(fc) = INDEFD + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_LONGP(fc)) <= 0) + FC_LONGP(fc) = INDEFD + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_LONGP(fc)) <= 0) + FC_LONGP(fc) = INDEFD + } + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "latpole", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "latpole", Memc[atvalue], + SZ_LINE) + } then { + latpole = INDEFD + } else { + i = 1 + if (ctod (Memc[atvalue], i, latpole) <= 0) + latpole = INDEFD + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, latpole) <= 0) + latpole = INDEFD + } + + # Fetch the RO projection parameter which is the radius of the + # generating sphere for the projection. If RO is absent which + # is the usual case set it to 180 / PI. Search both axes for + # this quantity. + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "ro", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "ro", Memc[atvalue], + SZ_LINE) + } then { + FC_RODEG(fc) = 180.0d0 / DPI + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_RODEG(fc)) <= 0) + FC_RODEG(fc) = 180.0d0 / DPI + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_RODEG(fc)) <= 0) + FC_RODEG(fc) = 180.0d0 / DPI + } + + # Compute the native longitude of the celestial pole. + dec = DDEGTORAD(FC_W(fc,FC_IDEC(fc))) + theta0 = 0.0d0 + if (IS_INDEFD(FC_LONGP(fc))) { + if (dec < theta0) + FC_LONGP(fc) = DPI + else + FC_LONGP(fc) = 0.0d0 + } else + FC_LONGP(fc) = DDEGTORAD(FC_LONGP(fc)) + + # Compute the celestial longitude and latitude of the native pole. + clat0 = cos (dec) + slat0 = sin (dec) + cphip = cos (FC_LONGP(fc)) + sphip = sin (FC_LONGP(fc)) + cthe0 = cos (theta0) + sthe0 = sin (theta0) + + x = cthe0 * cphip + y = sthe0 + z = sqrt (x * x + y * y) + + # The latitude of the native pole is determined by LATPOLE in this + # case. + if (z == 0.0d0) { + + if (slat0 != 0.0d0) + call error (0, "WF_QSC_INIT: Invalid projection parameters") + if (IS_INDEFD(latpole)) + latp = 999.0d0 + else + latp = DDEGTORAD(latpole) + + } else { + if (abs (slat0 / z) > 1.0d0) + call error (0, "WF_QSC_INIT: Invalid projection parameters") + + u = atan2 (y, x) + v = acos (slat0 / z) + latp1 = u + v + if (latp1 > DPI) + latp1 = latp1 - DTWOPI + else if (latp1 < -DPI) + latp1 = latp1 + DTWOPI + + + latp2 = u - v + if (latp2 > DPI) + latp2 = latp2 - DTWOPI + else if (latp2 < -DPI) + latp2 = latp2 + DTWOPI + + if (IS_INDEFD(latpole)) + maxlat = 999.0d0 + else + maxlat = DDEGTORAD(latpole) + if (abs (maxlat - latp1) < abs (maxlat - latp2)) { + if (abs (latp1) < (DHALFPI + tol)) + latp = latp1 + else + latp = latp2 + } else { + if (abs (latp2) < (DHALFPI + tol)) + latp = latp2 + else + latp = latp1 + } + } + FC_NATDEC(fc) = DHALFPI - latp + + z = cos (latp) * clat0 + if (abs(z) < tol) { + + # Celestial pole at the reference point. + if (abs(clat0) < tol) { + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) + FC_NATDEC(fc) = DHALFPI - theta0 + # Celestial pole at the native north pole. + } else if (latp > 0.0d0) { + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) + FC_LONGP(fc) - + DPI + FC_NATDEC(fc) = 0.0d0 + # Celestial pole at the native south pole. + } else if (latp < 0.0d0) { + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) - FC_LONGP(fc) + FC_NATDEC(fc) = DPI + } + + } else { + x = (sthe0 - sin (latp) * slat0) / z + y = sphip * cthe0 / clat0 + if (x == 0.0d0 && y == 0.0d0) + call error (0, "WF_QSC_INIT: Invalid projection parameters") + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) - atan2 (y,x) + } + + if (FC_W(fc,FC_IRA(fc)) >= 0.0d0) { + if (FC_NATRA(fc) < 0.0d0) + FC_NATRA(fc) = FC_NATRA(fc) + DTWOPI + } else { + if (FC_NATRA(fc) > 0.0d0) + FC_NATRA(fc) = FC_NATRA(fc) - DTWOPI + } + FC_COSDEC(fc) = cos (FC_NATDEC(fc)) + FC_SINDEC(fc) = sin (FC_NATDEC(fc)) + + # Check for ill-conditioned parameters. + if (abs(latp) > (DHALFPI+tol)) + call error (0, "WF_QCS_INIT: Invalid projection parameters") + + # Compute the required intermediate quantities. + FC_C1(fc) = FC_RODEG(fc) * (DPI / 4.0d0) + FC_C2(fc) = 1.0d0 / FC_C1(fc) + + # Set the bad coordinate value. + FC_SPHTOL(fc) = 1.0d-5 + + # Set the bad coordinate value. + FC_BADCVAL(fc) = INDEFD + + # Free working space. + call sfree (sp) +end + + +# WF_QSC_FWD -- Forward transform (physical to world) for the quarilateralized +# spherical projection. + +procedure wf_qsc_fwd (fc, p, w) + +pointer fc #I pointer to FC descriptor +double p[2] #I physical coordinates (x, y) +double w[2] #O world coordinates (ra, dec) + +int ira, idec, face, direct +double l, m, n, phi, theta, costhe, sinthe, dphi, cosphi, sinphi, x, y, z +double xf, yf, rho, chi, psi, tol, wconst, ra, dec, dlng, rhu +data tol /1.0d-12/ + +begin + # Get the axis numbers. + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + # Compute native spherical coordinates PHI and THETA in degrees from + # the projected coordinates. This is the projection part of the + # computation. + + xf = p[ira] * FC_C2(fc) + yf = p[idec] * FC_C2(fc) + if (xf > 5.0d0) { + face = 4 + xf = xf - 6.0d0 + } else if (xf > 3.0d0) { + face = 3 + xf = xf - 4.0d0 + } else if (xf > 1.0d0) { + face = 2 + xf = xf - 2.0d0 + } else if (yf > 1.0d0) { + face = 0 + yf = yf - 2.0d0 + } else if (yf < -1.0d0) { + face = 5 + yf = yf + 2.0d0 + } else { + face = 1 + } + + if (abs(xf) > abs(yf)) + direct = YES + else + direct = NO + if (direct == YES) { + if (xf == 0.0d0) { + psi = 0.0d0 + chi = 1.0d0 + rho = 1.0d0 + rhu = 0.0d0 + } else { + wconst = DDEGTORAD(15.0d0 * yf / xf) + psi = sin (wconst) / (cos (wconst) - 1.0d0 / DSQRTOF2) + chi = 1.0d0 + psi * psi + rhu = xf * xf * (1.0d0 - 1.0d0 / sqrt (1.0d0 + chi)) + rho = 1.0d0 - rhu + } + } else { + if (yf == 0.0d0) { + psi = 0.0d0 + chi = 1.0d0 + rho = 1.0d0 + rhu = 0.0d0 + } else { + wconst = DDEGTORAD(15.0d0 * xf / yf) + psi = sin (wconst) / (cos (wconst) - 1.0d0 / DSQRTOF2) + chi = 1.0d0 + psi * psi + rhu = yf * yf * (1.0d0 - 1.0d0 / sqrt (1.0d0 + chi)) + rho = 1.0d0 - rhu + } + } + + if (rho < -1.0d0) { + if (rho < (-1.0d0 - tol)) { + w[ira] = FC_BADCVAL(fc) + w[idec] = FC_BADCVAL(fc) + return + } + rho = -1.0d0 + rhu = 2.0d0 + wconst = 0.0d0 + } else { + wconst = sqrt (rhu * (2.0d0 - rhu) / chi) + } + + switch (face) { + case 0: + n = rho + if (direct == YES) { + l = wconst + if (xf < 0.0d0) + l = -l + m = -l * psi + } else { + m = wconst + if (yf > 0.0d0) + m = -m + l = -m * psi + } + + case 1: + m = rho + if (direct == YES) { + l = wconst + if (xf < 0.0d0) + l = -l + n = l * psi + } else { + n = wconst + if (yf < 0.0d0) + n = -n + l = n * psi + } + + case 2: + l = rho + if (direct == YES) { + m = wconst + if (xf > 0.0d0) + m = -m + n = -m * psi + } else { + n = wconst + if (yf < 0.0d0) + n = -n + m = -n * psi + } + + case 3: + m = -rho + if (direct == YES) { + l = wconst + if (xf > 0.0d0) + l = -l + n = -l * psi + } else { + n = wconst + if (yf < 0.0d0) + n = -n + l = -n * psi + } + + case 4: + l = -rho + if (direct == YES) { + m = wconst + if (xf < 0.0d0) + m = -m + n = m * psi + } else { + n = wconst + if (yf < 0.0d0) + n = -n + m = n * psi + } + + case 5: + n = -rho + if (direct == YES) { + l = wconst + if (xf < 0.0d0) + l = -l + m = l * psi + } else { + m = wconst + if (yf < 0.0d0) + m = -m + l = m * psi + } + } + + # Compute PHI. + if (l == 0.0d0 && m == 0.0d0) + phi = 0.0d0 + else + phi = atan2 (l, m) + + # Compute THETA. + theta = asin(n) + + # Compute the celestial coordinates RA and DEC from the native + # coordinates PHI and THETA. This is the spherical geometry part + # of the computation. + + costhe = cos (theta) + sinthe = sin (theta) + dphi = phi - FC_LONGP(fc) + cosphi = cos (dphi) + sinphi = sin (dphi) + + # Compute the RA. + x = sinthe * FC_SINDEC(fc) - costhe * FC_COSDEC(fc) * cosphi + if (abs (x) < FC_SPHTOL(fc)) + x = -cos (theta + FC_NATDEC(fc)) + costhe * FC_COSDEC(fc) * + (1.0d0 - cosphi) + y = -costhe * sinphi + if (x != 0.0d0 || y != 0.0d0) { + dlng = atan2 (y, x) + } else { + dlng = dphi + DPI + } + ra = DRADTODEG(FC_NATRA(fc) + dlng) + + # Normalize the RA. + if (FC_NATRA(fc) >= 0.0d0) { + if (ra < 0.0d0) + ra = ra + 360.0d0 + } else { + if (ra > 0.0d0) + ra = ra - 360.0d0 + } + if (ra > 360.0d0) + ra = ra - 360.0d0 + else if (ra < -360.0d0) + ra = ra + 360.0d0 + + # Compute the DEC. + if (mod (dphi, DPI) == 0.0d0) { + dec = DRADTODEG(theta + cosphi * FC_NATDEC(fc)) + if (dec > 90.0d0) + dec = 180.0d0 - dec + if (dec < -90.0d0) + dec = -180.0d0 - dec + } else { + z = sinthe * FC_COSDEC(fc) + costhe * FC_SINDEC(fc) * cosphi + if (abs(z) > 0.99d0) { + if (z >= 0.0d0) + dec = DRADTODEG(acos (sqrt(x * x + y * y))) + else + dec = DRADTODEG(-acos (sqrt(x * x + y * y))) + } else + dec = DRADTODEG(asin (z)) + } + + # Store the results. + w[ira] = ra + w[idec] = dec +end + + +# WF_QSC_INV -- Inverse transform (world to physical) for the quadilateralized +# spherical projection. + +procedure wf_qsc_inv (fc, w, p) + +pointer fc #I pointer to FC descriptor +double w[2] #I input world (RA, DEC) coordinates +double p[2] #I output physical coordinates + +int ira, idec, face +double ra, dec, cosdec, sindec, cosra, sinra, x, y, z, phi, theta, dphi +double costhe, eta, l, m, n, rho, xi, tol, x0, y0, psi, chi, xf, yf +double pconst, t, rhu +data tol /1.0d-12/ + +begin + # Get the axes numbers. + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + # Compute the transformation from celestial coordinates RA and + # DEC to native coordinates PHI and THETA. This is the spherical + # geometry part of the transformation. + + ra = DDEGTORAD (w[ira]) - FC_NATRA(fc) + dec = DDEGTORAD (w[idec]) + cosra = cos (ra) + sinra = sin (ra) + cosdec = cos (dec) + sindec = sin (dec) + + # Compute PHI. + x = sindec * FC_SINDEC(fc) - cosdec * FC_COSDEC(fc) * cosra + if (abs(x) < FC_SPHTOL(fc)) + x = -cos (dec + FC_NATDEC(fc)) + cosdec * FC_COSDEC(fc) * + (1.0d0 - cosra) + y = -cosdec * sinra + if (x != 0.0d0 || y != 0.0d0) + dphi = atan2 (y, x) + else + dphi = ra - DPI + phi = FC_LONGP(fc) + dphi + if (phi > DPI) + phi = phi - DTWOPI + else if (phi < -DPI) + phi = phi + DTWOPI + + # Compute THETA. + if (mod (ra, DPI) == 0.0) { + theta = dec + cosra * FC_NATDEC(fc) + if (theta > DHALFPI) + theta = DPI - theta + if (theta < -DHALFPI) + theta = -DPI - theta + } else { + z = sindec * FC_COSDEC(fc) + cosdec * FC_SINDEC(fc) * cosra + if (abs (z) > 0.99d0) { + if (z >= 0.0) + theta = acos (sqrt(x * x + y * y)) + else + theta = -acos (sqrt(x * x + y * y)) + } else + theta = asin (z) + } + + # Compute the transformation from native coordinates PHI and THETA + # to projected coordinates X and Y. + if (abs(theta) == DHALFPI) { + p[ira] = 0.0d0 + if (theta >= 0.0d0) + p[idec] = 2.0d0 * FC_C1(fc) + else + p[idec] = -2.0d0 * FC_C1(fc) + return + } + + costhe = cos (theta) + l = costhe * sin (phi) + m = costhe * cos (phi) + n = sin (theta) + + face = 0 + rho = n + if (m > rho) { + face = 1 + rho = m + } + if (l > rho) { + face = 2 + rho = l + } + if (-m > rho) { + face = 3 + rho = -m + } + if (-l > rho) { + face = 4 + rho = -l + } + if (-n > rho) { + face = 5 + rho = -n + } + rhu = 1.0d0 - rho + + switch (face) { + case 0: + xi = l + eta = -m + if (rhu < 1.0d-8) { + t = (DHALFPI - theta) + rhu = t * t / 2.0d0 + } + x0 = 0.0d0 + y0 = 2.0d0 + case 1: + xi = l + eta = n + if (rhu < 1.0d-8) { + t = theta + pconst = mod (phi, DTWOPI) + if (pconst < -DPI) + pconst = pconst + DTWOPI + if (pconst > DPI) + pconst = pconst - DTWOPI + rhu = (pconst * pconst + t * t) / 2.0d0 + } + x0 = 0.0d0 + y0 = 0.0d0 + case 2: + xi = -m + eta = n + if (rhu < 1.0d-8) { + t = theta + pconst = mod (phi, DTWOPI) + if (pconst < -DPI) + pconst = pconst + DTWOPI + pconst = (DHALFPI - pconst) + rhu = (pconst * pconst + t * t) / 2.0d0 + } + x0 = 2.0d0 + y0 = 0.0d0 + case 3: + xi = -l + eta = n + if (rhu < 1.0d-8) { + t = theta + pconst = mod (phi, DTWOPI) + if (pconst < 0.0d0) + pconst = pconst + DTWOPI + pconst = (DPI - pconst) + rhu = (pconst * pconst + t * t) / 2.0d0 + } + x0 = 4.0d0 + y0 = 0.0d0 + case 4: + xi = m + eta = n + if (rhu < 1.0d-8) { + t = theta + pconst = mod (phi, DTWOPI) + if (pconst > DPI) + pconst = pconst - DTWOPI + pconst = (DHALFPI + pconst) + rhu = (pconst * pconst + t * t) / 2.0d0 + } + x0 = 6.0d0 + y0 = 0.0d0 + case 5: + xi = l + eta = m + if (rhu < 1.0d-8) { + t = (DHALFPI + theta) + rhu = t * t / 2.0d0 + } + x0 = 0.0d0 + y0 = -2.0d0 + } + + if (xi == 0.0d0 && eta == 0.0d0) { + xf = 0.0d0 + yf = 0.0d0 + } else if (-xi >= abs(eta)) { + psi = eta / xi + chi = 1.0d0 + psi * psi + xf = -sqrt (rhu / (1.0d0 - 1.0d0 / sqrt (1.0d0 + chi))) + yf = (xf / 15.0d0) * DRADTODEG ((atan (psi) - asin (psi / + sqrt (chi + chi)))) + } else if (xi >= abs(eta)) { + psi = eta / xi + chi = 1.0d0 + psi * psi + xf = sqrt (rhu / (1.0d0 - 1.0d0 / sqrt (1.0d0 + chi))) + yf = (xf / 15.0d0) * DRADTODEG ((atan (psi) - asin (psi / + sqrt (chi + chi)))) + } else if (-eta > abs (xi)) { + psi = xi / eta + chi = 1.0d0 + psi * psi + yf = -sqrt (rhu / (1.0d0 - 1.0d0 / sqrt (1.0d0 + chi))) + xf = (yf / 15.0d0) * DRADTODEG ((atan (psi) - asin (psi / + sqrt (chi + chi)))) + } else if (eta > abs (xi)) { + psi = xi / eta + chi = 1.0d0 + psi * psi + yf = sqrt (rhu / (1.0d0 - 1.0d0 / sqrt (1.0d0 + chi))) + xf = (yf / 15.0d0) * DRADTODEG ((atan (psi) - asin (psi / + sqrt (chi + chi)))) + } + + if (abs(xf) > 1.0d0) { + if (abs(xf) > (1.0d0 + tol)) { + p[ira] = FC_BADCVAL(fc) + p[idec] = FC_BADCVAL(fc) + return + } + if (xf >= 0.0d0) + xf = 1.0d0 + else + xf = -1.0d0 + } + if (abs(yf) > 1.0d0) { + if (abs(yf) > (1.0d0 + tol)) { + p[ira] = FC_BADCVAL(fc) + p[idec] = FC_BADCVAL(fc) + return + } + if (yf >= 0.0d0) + yf = 1.0d0 + else + yf = -1.0d0 + } + + p[ira] = FC_C1(fc) * (x0 + xf) + p[idec] = FC_C1(fc) * (y0 + yf) +end diff --git a/sys/mwcs/wfsamp.x b/sys/mwcs/wfsamp.x new file mode 100644 index 00000000..992f3211 --- /dev/null +++ b/sys/mwcs/wfsamp.x @@ -0,0 +1,233 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "mwcs.h" + +.help WFSAMP +.nf ------------------------------------------------------------------------- +WFSAMP -- WCS function driver for the one dimensional sampled wcs function. +For this driver, the function P<->W (physical to/from world) is defined by +a sampled WCS curve. + +Driver routines: + + FN_INIT wf_smp_init (fc, dir) + FN_DESTROY (none) + FN_FWD wf_smp_ctran (fc, v1, v2) + FN_INV (same) + +In this initial implementation, only linear interpolation of the sampled +curve is provided, but the driver is easily extended to provide additional +interpolators. NOTE that this entire driver assumes that the sampled function +is monotonic. +.endhelp -------------------------------------------------------------------- + +# Driver specific fields of function call (FC) descriptor. +define FC_NPTS Memi[$1+FCU] # number of points in curve +define FC_LOC Memi[$1+FCU+1] # location in IN vector +define FC_V1 Memi[$1+FCU+2] # pointer to IN vector +define FC_V2 Memi[$1+FCU+3] # pointer to OUT vector +define FC_W Memd[P2D($1+FCU+4)] # W value (CRVAL) +define FC_DIR Memi[$1+FCU+6] # direction of transform + + +# WF_SMP_INIT -- Initialize the function call descriptor for the indicated +# type of transform (forward or inverse). + +procedure wf_smp_init (fc, dir) + +pointer fc #I pointer to FC descriptor +int dir #I type of transformation + +int axis, npts +pointer wp, mw, sp, emsg, pv, wv + +begin + # Enforce the current restriction to 1-dim sampled functions. + if (FC_NAXES(fc) != 1) + call error (1, "Sampled wcs functions must be 1-dimensional") + + wp = FC_WCS(fc) + mw = CT_MW(FC_CT(fc)) + axis = CT_AXIS(FC_CT(fc),1) + + # Get pointers to the input and output sample vectors. For our + # purposes there is no difference between the forward and inverse + # transform; we just swap the vectors for the inverse transform. + # The use of direct pointers here assumes that the DBUF is not + # reallocated while the CTRAN is being used. + + npts = WCS_NPTS(wp,axis) + pv = WCS_PV(wp,axis) + wv = WCS_WV(wp,axis) + + # Verify that we have a sampled WCS for this axis. + if (npts <= 0 || pv == NULL || wv == NULL) { + call smark (sp) + call salloc (emsg, SZ_LINE, TY_CHAR) + call sprintf (Memc[emsg], SZ_LINE, + "No sampled wcs entered for axis %d") + call pargi (axis) + call error (2, Memc[emsg]) + call sfree (sp) + } + + if (dir == FORWARD) { + FC_V1(fc) = MI_DBUF(mw) + pv - 1 + FC_V2(fc) = MI_DBUF(mw) + wv - 1 + } else { + FC_V1(fc) = MI_DBUF(mw) + wv - 1 + FC_V2(fc) = MI_DBUF(mw) + pv - 1 + } + + FC_NPTS(fc) = npts + if (WCS_W(wp) == NULL) + FC_W(fc) = 0.0 + else + FC_W(fc) = D(mw,WCS_W(wp)+axis-1) + + FC_LOC(fc) = 1 + FC_DIR(fc) = dir +end + + +# WF_SMP_CTRAN -- Given the coordinates of a point X in the input curve, +# locate the sample interval containing the point, and return the coordinate +# of the same point in the output curve using simple linear interpolation +# (currently) to evaluate the WCS function value. + +procedure wf_smp_ctran (fc, a_x, a_y) + +pointer fc #I pointer to FC descriptor +double a_x #I point to sample WCS at +double a_y #O value of WCS at that point + +int index, i, step +double frac, x, y +pointer ip, op, i1, i2 +int wf_smp_binsearch() +define sample_ 91 +define oor_ 92 + +begin + # Get the input X value. + if (FC_DIR(fc) == FORWARD) + x = a_x + else + x = a_x - FC_W(fc) + + # Check for out of bounds and set step. + i1 = FC_V1(fc) + i2 = i1 + FC_NPTS(fc) - 1 + if (Memd[i1] <= Memd[i2]) { + if (x < Memd[i1] || x > Memd[i2]) + goto oor_ + step = 1 + } else { + if (x < Memd[i2] || x > Memd[i1]) + goto oor_ + step = -1 + } + + # Check the endpoints and the last inverval to optimize the case of + # repeated samplings of the same region of the curve. + + if (x == Memd[i1]) + ip = i1 - min (0, step) + else if (x == Memd[i2]) + ip = i2 - max (0, step) + else + ip = FC_LOC(fc) + i1 - 1 + if (Memd[ip] <= x && x <= Memd[ip+step]) + goto sample_ + + # Next check several intervals to either side. + if (x < Memd[ip]) { + do i = 1, 5 { + ip = ip - step + if (Memd[ip] <= x) + goto sample_ + } + } else { + do i = 1, 5 { + if (Memd[ip+step] >= x) + goto sample_ + ip = ip + step + } + } + + # Give up and do a full binary search! + index = wf_smp_binsearch (x, Memd[i1], FC_NPTS(fc)) + if (index == 0) + goto oor_ + else + ip = i1 + index - 1 + + # Having found the proper interval, compute the function value by + # interpolating the output vector. +sample_ + op = FC_V2(fc) + ip-i1 + frac = (x - Memd[ip]) / (Memd[ip+step] - Memd[ip]) + y = (Memd[op+step] - Memd[op]) * frac + Memd[op] + + # Get the output Y value. + if (FC_DIR(fc) == FORWARD) + a_y = y + else + a_y = y + FC_W(fc) + + # Save last location. + FC_LOC(fc) = ip - i1 + 1 + + return +oor_ + # Given X value is not in the region covered by the sampled curve, + # or at least we couldn't find it with a binary search. + + call error (2, "Out of bounds reference on sampled WCS curve") +end + + +# WF_SMP_BINSEARCH -- Perform a binary search of a sorted array for the +# interval containing the given point. + +int procedure wf_smp_binsearch (x, v, npts) + +double x #I point we want interval for +double v[ARB] #I array to be searched +int npts #I number of points in array + +int low, high, pos, i + +begin + low = 1 + high = max (1, npts) + + # Cut range of search in half until interval is found, or until range + # vanishes (high - low <= 1). + + if (v[1] < v[npts]) { + do i = 1, npts { + pos = min ((high - low) / 2 + low, npts-1) + if (pos == low) + return (0) # not found + else if (v[pos] <= x && x <= v[pos+1]) + return (pos) + else if (x < v[pos]) + high = pos + else + low = pos + } + } else { + do i = 1, npts { + pos = min ((high - low) / 2 + low, npts-1) + if (pos == low) + return (0) # not found + else if (v[pos+1] <= x && x <= v[pos]) + return (pos+1) + else if (x > v[pos]) + high = pos + else + low = pos + } + } +end diff --git a/sys/mwcs/wfsin.x b/sys/mwcs/wfsin.x new file mode 100644 index 00000000..a1b18d82 --- /dev/null +++ b/sys/mwcs/wfsin.x @@ -0,0 +1,150 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +.help WFSIN +.nf ------------------------------------------------------------------------- +WFSIN -- WCS function driver for the sine projection. + +Driver routines: + + FN_INIT wf_sin_init (fc, dir) + FN_DESTROY (none) + FN_FWD wf_sin_fwd (fc, v1, v2) + FN_INV wf_sin_inv (fc, v1, v2) + +.endhelp -------------------------------------------------------------------- + +# Driver specific fields of function call (FC) descriptor. +define FC_IRA Memi[$1+FCU] # RA axis (1 or 2) +define FC_IDEC Memi[$1+FCU+1] # DEC axis (1 or 2) +define FC_COSDEC Memd[P2D($1+FCU+2)] # cosine(dec) +define FC_SINDEC Memd[P2D($1+FCU+4)] # sine(dec) +define FC_W Memd[P2D($1+FCU+6)+($2)-1] # W (CRVAL) for each axis + + +# WF_SIN_INIT -- Initialize the sine forward or inverse transform. +# Initialization for this transformation consists of determining which axis +# is RA and which is DEC, and precomputing the sine and cosine of the +# declination at the reference point. In order to determine the axis order, +# the parameter "axtype={ra|dec}" must have been set in the attribute list +# for the function. +# NOTE: This is identical to wf_tan_init. + +procedure wf_sin_init (fc, dir) + +pointer fc #I pointer to FC descriptor +int dir #I direction of transform + +int i +double dec +pointer ct, mw, wp, wv +errchk wf_decaxis + +begin + ct = FC_CT(fc) + mw = CT_MW(ct) + wp = FC_WCS(fc) + + # Determine which is the DEC axis, and hence the axis order. + call wf_decaxis (fc, FC_IRA(fc), FC_IDEC(fc)) + + # Get the value of W for each axis, i.e., the world coordinate at + # the reference point. + + wv = MI_DBUF(mw) + WCS_W(wp) - 1 + do i = 1, 2 + FC_W(fc,i) = Memd[wv+CT_AXIS(ct,FC_AXIS(fc,i))-1] + + # Precompute the sin and cos of the declination at the reference pixel. + dec = DEGTORAD(FC_W(fc,FC_IDEC(fc))) + FC_COSDEC(fc) = cos(dec) + FC_SINDEC(fc) = sin(dec) +end + + +# WF_SIN_FWD -- Forward transform (physical to world), sine +# projection. Based on code from STScI, Hodge et al. + +procedure wf_sin_fwd (fc, p, w) + +pointer fc #I pointer to FC descriptor +double p[2] #I physical coordinates (xi, eta) +double w[2] #O world coordinates (ra, dec) + +int ira, idec +double v1, xi, eta, x, y, z, ra, dec + +begin + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + xi = DEGTORAD(p[ira]) + eta = DEGTORAD(p[idec]) + + v1 = 1.d0 - xi*xi - eta*eta + if (v1 > 0.d0) + v1 = sqrt (1.d0 - xi*xi - eta*eta) + else + v1 = 0.d0 + + # 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 * FC_COSDEC(fc) - eta * FC_SINDEC(fc) + y = xi + z = v1 * FC_SINDEC(fc) + eta * FC_COSDEC(fc) + + if (x == 0.d0 && y == 0.d0) + ra = 0.d0 + else + ra = atan2 (y, x) + dec = atan2 (z, sqrt (x*x + y*y)) + + # Return RA and DEC in degrees. + dec = RADTODEG(dec) + ra = RADTODEG(ra) + FC_W(fc,ira) + + if (ra < 0.d0) + ra = ra + 360.D0 + else if (ra > 360.D0) + ra = ra - 360.D0 + + w[ira] = ra + w[idec] = dec +end + + +# WF_SIN_INV -- Inverse transform (world to physical) for the sine +# projection. Based on code from Eric Greisen, AIPS Memo No. 27. + +procedure wf_sin_inv (fc, w, p) + +pointer fc #I pointer to FC descriptor +double w[2] #I input world (RA, DEC) coordinates +double p[2] #O output physical coordinates + +int ira, idec +double ra, dec, xi, eta +double cosra, cosdec, sinra, sindec + +begin + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + ra = DEGTORAD (w[ira] - FC_W(fc,ira)) + dec = DEGTORAD (w[idec]) + + cosra = cos (ra) + sinra = sin (ra) + + cosdec = cos (dec) + sindec = sin (dec) + + xi = cosdec * sinra + eta = sindec * FC_COSDEC(fc) - cosdec * FC_SINDEC(fc) * cosra + + p[ira] = RADTODEG(xi) + p[idec] = RADTODEG(eta) +end diff --git a/sys/mwcs/wfstg.x b/sys/mwcs/wfstg.x new file mode 100644 index 00000000..e8ee66b4 --- /dev/null +++ b/sys/mwcs/wfstg.x @@ -0,0 +1,327 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +.help WFSTG +.nf ------------------------------------------------------------------------- +WFSTG -- WCS function driver for the stereographic projection. + +Driver routines: + + FN_INIT wf_stg_init (fc, dir) + FN_DESTROY (none) + FN_FWD wf_stg_fwd (fc, v1, v2) + FN_INV wf_stg_inv (fc, v1, v2) + +.endhelp -------------------------------------------------------------------- + +# Driver specific fields of function call (FC) descriptor. +define FC_IRA Memi[$1+FCU] # RA axis (1 or 2) +define FC_IDEC Memi[$1+FCU+1] # DEC axis (1 or 2) +define FC_LONGP Memd[P2D($1+FCU+2)] # LONGPOLE (rads) +define FC_COLATP Memd[P2D($1+FCU+4)] # (90 - DEC) (rads) +define FC_COSLATP Memd[P2D($1+FCU+6)] # cosine (90 - DEC) +define FC_SINLATP Memd[P2D($1+FCU+8)] # sine (90 - DEC) +define FC_SPHTOL Memd[P2D($1+FCU+10)] # trig tolerance +define FC_RODEG Memd[P2D($1+FCU+12)] # RO (degs) +define FC_2RODEG Memd[P2D($1+FCU+14)] # 2 * RO (degs) +define FC_REC2RODEG Memd[P2D($1+FCU+16)] # 1 / (2 * RO) (degs) +define FC_BADCVAL Memd[P2D($1+FCU+18)] # Bad coordinate value +define FC_W Memd[P2D($1+FCU+20)+($2)-1] # CRVAL (axis 1 and 2) + + +# WF_STG_INIT -- Initialize the stereographic forward or inverse transform. +# Initialization for this transformation consists of, determining which +# axis is RA / LON and which is DEC / LAT, computing the celestial longitude +# and colatitude of the native pole, reading in the the native longitude of the +# pole of the celestial coordinate system LONGPOLE from the attribute list, +# precomputing the Euler angles and various intermediary functions of the +# reference coordinates, reading in the projection parameter RO from the +# attribute list, and precomputing some intermediate parameters. If LONGPOLE +# is undefined then a value of 180.0 degrees is assumed. If RO is undefined a +# value of 180.0 / PI is assumed. The STG projection is equivalent to the AZP +# projection with MU set to 1.0. In order to determine the axis order, the +# parameter "axtype={ra|dec} {xlon|xlat}" must have been set in the attribute +# list for the function. The LONGPOLE and RO parameters may be set in either +# or both of the axes attribute lists, but the value in the RA axis attribute +# list takes precedence. + +procedure wf_stg_init (fc, dir) + +pointer fc #I pointer to FC descriptor +int dir #I direction of transform + +int i +double dec +pointer sp, atvalue, ct, mw, wp, wv +int ctod() +errchk wf_decaxis(), mw_gwattrs() + +begin + # Allocate space for the attribute string. + call smark (sp) + call salloc (atvalue, SZ_LINE, TY_CHAR) + + # Get the required mwcs pointers. + ct = FC_CT(fc) + mw = CT_MW(ct) + wp = FC_WCS(fc) + + # Determine which is the DEC axis, and hence the axis order. + call wf_decaxis (fc, FC_IRA(fc), FC_IDEC(fc)) + + # Get the value of W for each axis, i.e. the world coordinates at + # the reference point. + wv = MI_DBUF(mw) + WCS_W(wp) - 1 + do i = 1, 2 + FC_W(fc,i) = Memd[wv+CT_AXIS(ct,FC_AXIS(fc,i))-1] + + # Get the celestial coordinates of the native pole which are in + # this case the ra and 90 - dec of the reference point. + + dec = DDEGTORAD(90.0d0 - FC_W(fc,FC_IDEC(fc))) + + # Determine the native longitude of the pole of the celestial + # coordinate system corresponding to the FITS keyword LONGPOLE. + # This number has no default and should normally be set to 180 + # degrees. Search both axes for this quantity. + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "longpole", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "longpole", Memc[atvalue], + SZ_LINE) + } then { + FC_LONGP(fc) = 180.0d0 + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_LONGP(fc)) <= 0) + FC_LONGP(fc) = 180.0d0 + if (IS_INDEFD(FC_LONGP(fc))) + FC_LONGP(fc) = 180.0d0 + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_LONGP(fc)) <= 0) + FC_LONGP(fc) = 180.0d0 + if (IS_INDEFD(FC_LONGP(fc))) + FC_LONGP(fc) = 180.0d0 + } + FC_LONGP(fc) = DDEGTORAD(FC_LONGP(fc)) + + # Precompute the trigomometric functions used by the spherical geometry + # code to improve efficiency. + + FC_COLATP(fc) = dec + FC_COSLATP(fc) = cos(dec) + FC_SINLATP(fc) = sin(dec) + + # Fetch the RO projection parameter which is the radius of the + # generating sphere for the projection. If RO is absent which + # is the usual case set it to 180 / PI. Search both axes for + # this quantity. + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "ro", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "ro", Memc[atvalue], + SZ_LINE) + } then { + FC_RODEG(fc) = 180.0d0 / DPI + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_RODEG(fc)) <= 0) + FC_RODEG(fc) = 180.0d0 / DPI + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_RODEG(fc)) <= 0) + FC_RODEG(fc) = 180.0d0 / DPI + } + FC_2RODEG(fc) = 2.0d0 * FC_RODEG(fc) + FC_REC2RODEG(fc) = 1.0d0 / FC_2RODEG(fc) + + # Fetch the spherical trigonometry tolerance. + FC_SPHTOL(fc) = 1.0d-5 + + # Fetch the bad coordinate value. + FC_BADCVAL(fc) = INDEFD + + # Free working space. + call sfree (sp) +end + + +# WF_STG_FWD -- Forward transform (physical to world) for the stereographic +# projection. + +procedure wf_stg_fwd (fc, p, w) + +pointer fc #I pointer to FC descriptor +double p[2] #I physical coordinates (x, y) +double w[2] #O world coordinates (ra, dec) + +int ira, idec +double x, y, r, phi, theta, costhe, sinthe, dphi, cosphi, sinphi, ra, dec +double dlng, z + +begin + # Get the axis numbers. + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + # Compute native spherical coordinates PHI and THETA in degrees from + # the projected coordinates. This is the projection part of the + # computation. + + x = p[ira] + y = p[idec] + r = sqrt (x * x + y * y) + + # Compute PHI. + if (r == 0.0d0) + phi = 0.0d0 + else + phi = atan2 (x, -y) + + # Compute THETA. + theta = DHALFPI - 2.0d0 * atan (r * FC_REC2RODEG(fc)) + + # Compute the celestial coordinates RA and DEC from the native + # coordinates PHI and THETA. This is the spherical geometry part + # of the computation. + + costhe = cos (theta) + sinthe = sin (theta) + dphi = phi - FC_LONGP(fc) + cosphi = cos (dphi) + sinphi = sin (dphi) + + # Compute the RA. + x = sinthe * FC_SINLATP(fc) - costhe * FC_COSLATP(fc) * cosphi + if (abs (x) < FC_SPHTOL(fc)) + x = -cos (theta + FC_COLATP(fc)) + costhe * FC_COSLATP(fc) * + (1.0d0 - cosphi) + y = -costhe * sinphi + if (x != 0.0d0 || y != 0.0d0) { + dlng = atan2 (y, x) + } else { + dlng = dphi + DPI + } + ra = FC_W(fc,ira) + DRADTODEG(dlng) + + # Normalize RA. + if (FC_W(fc,ira) >= 0.0d0) { + if (ra < 0.0d0) + ra = ra + 360.0d0 + } else { + if (ra > 0.0d0) + ra = ra - 360.0d0 + } + if (ra > 360.0d0) + ra = ra - 360.0d0 + else if (ra < -360.0d0) + ra = ra + 360.0d0 + + # Compute the DEC. + if (mod (dphi, DPI) == 0.0d0) { + dec = DRADTODEG(theta + cosphi * FC_COLATP(fc)) + if (dec > 90.0d0) + dec = 180.0d0 - dec + if (dec < -90.0d0) + dec = -180.0d0 - dec + } else { + z = sinthe * FC_COSLATP(fc) + costhe * FC_SINLATP(fc) * cosphi + if (abs(z) > 0.99d0) { + if (z >= 0.0d0) + dec = DRADTODEG(acos (sqrt(x * x + y * y))) + else + dec = DRADTODEG(-acos (sqrt(x * x + y * y))) + } else + dec = DRADTODEG(asin (z)) + } + + # Store the results. + w[ira] = ra + w[idec] = dec +end + + +# WF_STG_INV -- Inverse transform (world to physical) for the stereographic +# projection. + +procedure wf_stg_inv (fc, w, p) + +pointer fc #I pointer to FC descriptor +double w[2] #I input world (RA, DEC) coordinates +double p[2] #I output physical coordinates + +int ira, idec +double ra, dec, cosdec, sindec, cosra, sinra, x, y, phi, theta, s, r, dphi, z + +begin + # Get the axes numbers. + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + # Compute the transformation from celestial coordinates RA and + # DEC to native coordinates PHI and THETA. This is the spherical + # geometry part of the transformation. + + ra = DDEGTORAD (w[ira] - FC_W(fc,ira)) + dec = DDEGTORAD (w[idec]) + cosra = cos (ra) + sinra = sin (ra) + cosdec = cos (dec) + sindec = sin (dec) + + # Compute PHI. + x = sindec * FC_SINLATP(fc) - cosdec * FC_COSLATP(fc) * cosra + if (abs(x) < FC_SPHTOL(fc)) + x = -cos (dec + FC_COLATP(fc)) + cosdec * FC_COSLATP(fc) * + (1.0d0 - cosra) + y = -cosdec * sinra + if (x != 0.0d0 || y != 0.0d0) + dphi = atan2 (y, x) + else + dphi = ra - DPI + phi = FC_LONGP(fc) + dphi + if (phi > DPI) + phi = phi - DTWOPI + else if (phi < -DPI) + phi = phi + DTWOPI + + # Compute THETA. + if (mod (ra, DPI) ==0.0) { + theta = dec + cosra * FC_COLATP(fc) + if (theta > DHALFPI) + theta = DPI - theta + if (theta < -DHALFPI) + theta = -DPI - theta + } else { + z = sindec * FC_COSLATP(fc) + cosdec * FC_SINLATP(fc) * cosra + if (abs (z) > 0.99d0) { + if (z >= 0.0) + theta = acos (sqrt(x * x + y * y)) + else + theta = -acos (sqrt(x * x + y * y)) + } else + theta = asin (z) + } + + # Compute the transformation from native coordinates PHI and THETA + # to projected coordinates X and Y. + + s = 1.0d0 + sin (theta) + if (s == 0.0d0) { + p[ira] = FC_BADCVAL(fc) + p[idec] = FC_BADCVAL(fc) + } else { + r = FC_2RODEG(fc) * cos (theta) / s + p[ira] = r * sin (phi) + p[idec] = -r * cos (phi) + } +end diff --git a/sys/mwcs/wftan.x b/sys/mwcs/wftan.x new file mode 100644 index 00000000..2c5a0c5f --- /dev/null +++ b/sys/mwcs/wftan.x @@ -0,0 +1,145 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +.help WFTAN +.nf ------------------------------------------------------------------------- +WFTAN -- WCS function driver for the tangent plane (gnonomic) projection. + +Driver routines: + + FN_INIT wf_tan_init (fc, dir) + FN_DESTROY (none) + FN_FWD wf_tan_fwd (fc, v1, v2) + FN_INV wf_tan_inv (fc, v1, v2) + +.endhelp -------------------------------------------------------------------- + +# Driver specific fields of function call (FC) descriptor. +define FC_IRA Memi[$1+FCU] # RA axis (1 or 2) +define FC_IDEC Memi[$1+FCU+1] # DEC axis (1 or 2) +define FC_COSDEC Memd[P2D($1+FCU+2)] # cosine(dec) +define FC_SINDEC Memd[P2D($1+FCU+4)] # sine(dec) +define FC_W Memd[P2D($1+FCU+6)+($2)-1] # W (CRVAL) for each axis + + +# WF_TAN_INIT -- Initialize the tangent plane forward or inverse transform. +# Initialization for this transformation consists of determining which axis +# is RA and which is DEC, and precomputing the sine and cosine of the +# declination at the reference point. In order to determine the axis order, +# the parameter "axtype={ra|dec}" must have been set in the attribute list +# for the function. + +procedure wf_tan_init (fc, dir) + +pointer fc #I pointer to FC descriptor +int dir #I direction of transform + +int i +double dec +pointer ct, mw, wp, wv +errchk wf_decaxis + +begin + ct = FC_CT(fc) + mw = CT_MW(ct) + wp = FC_WCS(fc) + + # Determine which is the DEC axis, and hence the axis order. + call wf_decaxis (fc, FC_IRA(fc), FC_IDEC(fc)) + + # Get the value of W for each axis, i.e., the world coordinate at + # the reference point. + + wv = MI_DBUF(mw) + WCS_W(wp) - 1 + do i = 1, 2 + FC_W(fc,i) = Memd[wv+CT_AXIS(ct,FC_AXIS(fc,i))-1] + + # Precompute the sin and cos of the declination at the reference pixel. + dec = DEGTORAD(FC_W(fc,FC_IDEC(fc))) + FC_COSDEC(fc) = cos(dec) + FC_SINDEC(fc) = sin(dec) +end + + +# WF_TAN_FWD -- Forward transform (physical to world), tangent plane +# projection. Based on code from STScI, Hodge et. al. + +procedure wf_tan_fwd (fc, p, w) + +pointer fc #I pointer to FC descriptor +double p[2] #I physical coordinates (xi, eta) +double w[2] #O world coordinates (ra, dec) + +int ira, idec +double xi, eta, x, y, z, ra, dec + +begin + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + xi = DEGTORAD(p[ira]) + eta = DEGTORAD(p[idec]) + + # Rotate the rectangular coordinate system of the vector [1,xi,eta] + # by the declination so that the X axis will pass through the equator. + + x = FC_COSDEC(fc) - eta * FC_SINDEC(fc) + y = xi + z = FC_SINDEC(fc) + eta * FC_COSDEC(fc) + + # Compute RA and DEC in radians. + if (x == 0.0D0 && y == 0.0D0) + ra = 0.0D0 + else + ra = atan2 (y, x) + dec = atan2 (z, sqrt (x*x + y*y)) + + # Return RA and DEC in degrees. + dec = RADTODEG(dec) + ra = RADTODEG(ra) + FC_W(fc,ira) + + if (ra < 0) + ra = ra + 360D0 + else if (ra > 360D0) + ra = ra - 360D0 + + w[ira] = ra + w[idec] = dec +end + + +# WF_TAN_INV -- Inverse transform (world to physical) for the tangent plane +# projection. Based on code from STScI, Hodge et. al. + +procedure wf_tan_inv (fc, w, p) + +pointer fc #I pointer to FC descriptor +double w[2] #I input world (RA, DEC) coordinates +double p[2] #I output physical coordinates + +int ira, idec +double ra, dec, xi, eta +double cosra, cosdec, sinra, sindec, cosdist + +begin + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + ra = DEGTORAD (w[ira] - FC_W(fc,ira)) + dec = DEGTORAD (w[idec]) + + cosra = cos (ra) + sinra = sin (ra) + cosdec = cos (dec) + sindec = sin (dec) + cosdist = sindec * FC_SINDEC(fc) + cosdec * FC_COSDEC(fc) * cosra + + xi = cosdec * sinra / cosdist + eta = (sindec * FC_COSDEC(fc) - cosdec * FC_SINDEC(fc) * cosra) / + cosdist + + p[ira] = RADTODEG(xi) + p[idec] = RADTODEG(eta) +end diff --git a/sys/mwcs/wftnx.x b/sys/mwcs/wftnx.x new file mode 100644 index 00000000..d8b753a6 --- /dev/null +++ b/sys/mwcs/wftnx.x @@ -0,0 +1,439 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +.help WFTNX +.nf ------------------------------------------------------------------------- +WFTNX -- WCS function driver for the gnomonic projection. + +Driver routines: + + FN_INIT wf_tn_init (fc, dir) + FN_DESTROY wf_tnx_destroy (fc) + FN_FWD wf_tnx_fwd (fc, v1, v2) + FN_INV wf_tnx_inv (fc, v1, v2) + +.endhelp -------------------------------------------------------------------- + +define MAX_NITER 20 + +# Driver specific fields of function call (FC) descriptor. +define FC_LNGCOR Memi[$1+FCU] # RA axis (1 or 2) +define FC_LATCOR Memi[$1+FCU+1] # DEC axis (1 or 2) +define FC_IRA Memi[$1+FCU+2] # RA axis (1 or 2) +define FC_IDEC Memi[$1+FCU+3] # DEC axis (1 or 2) +define FC_LONGP Memd[P2D($1+FCU+4)] # LONGPOLE (rads) +define FC_COLATP Memd[P2D($1+FCU+6)] # (90 - DEC) (rads) +define FC_COSLATP Memd[P2D($1+FCU+8)] # cosine (90 - DEC) +define FC_SINLATP Memd[P2D($1+FCU+10)] # sine (90 - DEC) +define FC_SPHTOL Memd[P2D($1+FCU+12)] # trig toleracne +define FC_RODEG Memd[P2D($1+FCU+14)] # RO (degs) +define FC_BADCVAL Memd[P2D($1+FCU+16)] # Bad coordinate value +define FC_W Memd[P2D($1+FCU+18)+($2)-1] # CRVAL (axis 1 and 2) + + +# WF_TNX_INIT -- Initialize the gnomonic forward or inverse transform. +# Initialization for this transformation consists of, determining which +# axis is RA / LON and which is DEC / LAT, computing the celestial longitude +# and colatitude of the native pole, reading in the the native longitude +# of the pole of the celestial coordinate system LONGPOLE from the attribute +# list, precomputing Euler angles and various intermediaries derived from the +# coordinate reference values, and reading in the projection parameter RO +# from the attribute list. If LONGPOLE is undefined then a value of 180.0 +# degrees is assumed. If RO is undefined a value of 180.0 / PI is assumed. +# The TAN projection is equivalent to the AZP projection with MU set to 0.0. +# In order to determine the axis order, the parameter "axtype={ra|dec} +# {xlon|glat}{xlon|elat}" must have been set in the attribute list for the +# function. The LONGPOLE and RO parameters may be set in either or both of +# the axes attribute lists, but the value in the RA axis attribute list takes +# precedence. + +procedure wf_tnx_init (fc, dir) + +pointer fc #I pointer to FC descriptor +int dir #I direction of transform + +int i, szatstr +double dec +pointer atvalue, ct, mw, wp, wv +int ctod(), strlen() +pointer wf_gsopen() +errchk wf_decaxis(), mw_gwattrs() + +begin + # Allocate space for the attribute string. + call malloc (atvalue, SZ_LINE, TY_CHAR) + + # Get the required mwcs pointers. + ct = FC_CT(fc) + mw = CT_MW(ct) + wp = FC_WCS(fc) + + # Determine which is the DEC axis, and hence the axis order. + call wf_decaxis (fc, FC_IRA(fc), FC_IDEC(fc)) + + # Get the value of W for each axis, i.e. the world coordinates at + # the reference point. + + wv = MI_DBUF(mw) + WCS_W(wp) - 1 + do i = 1, 2 + FC_W(fc,i) = Memd[wv+CT_AXIS(ct,FC_AXIS(fc,i))-1] + + # Get the celestial coordinates of the native pole which are in + # this case the ra and 90 - dec of the reference point. + + dec = DDEGTORAD(90.0d0 - FC_W(fc,FC_IDEC(fc))) + + # Determine the native longitude of the pole of the celestial + # coordinate system corresponding to the FITS keyword LONGPOLE. + # This number has no default and should normally be set to 180 + # degrees. Search both axes for this quantity. + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "longpole", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "longpole", Memc[atvalue], + SZ_LINE) + } then { + FC_LONGP(fc) = 180.0d0 + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_LONGP(fc)) <= 0) + FC_LONGP(fc) = 180.0d0 + if (IS_INDEFD(FC_LONGP(fc))) + FC_LONGP(fc) = 180.0d0 + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_LONGP(fc)) <= 0) + FC_LONGP(fc) = 180.0d0 + if (IS_INDEFD(FC_LONGP(fc))) + FC_LONGP(fc) = 180.0d0 + } + FC_LONGP(fc) = DDEGTORAD(FC_LONGP(fc)) + + # Precompute the trigomometric functions used by the spherical geometry + # code to improve efficiency. + + FC_COLATP(fc) = dec + FC_COSLATP(fc) = cos(dec) + FC_SINLATP(fc) = sin(dec) + + # Fetch the RO projection parameter which is the radius of the + # generating sphere for the projection. If RO is absent which + # is the usual case set it to 180 / PI. Search both axes for + # this quantity. + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "ro", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "ro", Memc[atvalue], + SZ_LINE) + } then { + FC_RODEG(fc) = 180.0d0 / DPI + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_RODEG(fc)) <= 0) + FC_RODEG(fc) = 180.0d0 / DPI + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_RODEG(fc)) <= 0) + FC_RODEG(fc) = 180.0d0 / DPI + } + + szatstr = SZ_LINE + + # Fetch the longitude correction surface. Note that the attribute + # string may be of any length so the length of atvalue may have + # to be adjusted. + + iferr { + repeat { + call mw_gwattrs (mw, FC_IRA(fc), "lngcor", Memc[atvalue], + szatstr) + if (strlen (Memc[atvalue]) < szatstr) + break + szatstr = szatstr + SZ_LINE + call realloc (atvalue, szatstr, TY_CHAR) + + } + } then { + FC_LNGCOR(fc) = NULL + } else { + FC_LNGCOR(fc) = wf_gsopen (Memc[atvalue]) + } + + # Fetch the latitude correction surface. Note that the attribute + # string may be of any length so the length of atvalue may have + # to be adjusted. + + iferr { + repeat { + call mw_gwattrs (mw, FC_IDEC(fc), "latcor", Memc[atvalue], + szatstr) + if (strlen (Memc[atvalue]) < szatstr) + break + szatstr = szatstr + SZ_LINE + call realloc (atvalue, szatstr, TY_CHAR) + } + } then { + FC_LATCOR(fc) = NULL + } else { + FC_LATCOR(fc) = wf_gsopen (Memc[atvalue]) + } + + # Set the small angle spherical trigonometry tolerance. + FC_SPHTOL(fc) = 1.0d-5 + + # Set the bad coordinate value. + FC_BADCVAL(fc) = INDEFD + + # Free working space. + call mfree (atvalue, TY_CHAR) +end + + +# WF_TNX_FWD -- Forward transform (physical to world) gnomonic projection. + +procedure wf_tnx_fwd (fc, p, w) + +pointer fc #I pointer to FC descriptor +double p[2] #I physical coordinates (x, y) +double w[2] #O world coordinates (ra, dec) + +int ira, idec +double x, y, r, phi, theta, costhe, sinthe, dphi, cosphi, sinphi, dlng, z +double ra, dec +double wf_gseval() + +begin + # Get the axis numbers. + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + # Compute native spherical coordinates PHI and THETA in degrees from + # the projected coordinates. This is the projection part of the + # computation. + + if (FC_LNGCOR(fc) == NULL) + x = p[ira] + else + x = p[ira] + wf_gseval (FC_LNGCOR(fc), p[ira], p[idec]) + if (FC_LATCOR(fc) == NULL) + y = p[idec] + else + y = p[idec] + wf_gseval (FC_LATCOR(fc), p[ira], p[idec]) + r = sqrt (x * x + y * y) + + # Compute PHI. + if (r == 0.0d0) + phi = 0.0d0 + else + phi = atan2 (x, -y) + + # Compute THETA. + theta = atan2 (FC_RODEG(fc), r) + + # Compute the celestial coordinates RA and DEC from the native + # coordinates PHI and THETA. This is the spherical geometry part + # of the computation. + + costhe = cos (theta) + sinthe = sin (theta) + dphi = phi - FC_LONGP(fc) + cosphi = cos (dphi) + sinphi = sin (dphi) + + # Compute the RA. + x = sinthe * FC_SINLATP(fc) - costhe * FC_COSLATP(fc) * cosphi + if (abs (x) < FC_SPHTOL(fc)) + x = -cos (theta + FC_COLATP(fc)) + costhe * FC_COSLATP(fc) * + (1.0d0 - cosphi) + y = -costhe * sinphi + if (x != 0.0d0 || y != 0.0d0) { + dlng = atan2 (y, x) + } else { + dlng = dphi + DPI + } + ra = FC_W(fc,ira) + DRADTODEG(dlng) + + # Normalize RA. + if (FC_W(fc,ira) >= 0.0d0) { + if (ra < 0.0d0) + ra = ra + 360.0d0 + } else { + if (ra > 0.0d0) + ra = ra - 360.0d0 + } + if (ra > 360.0d0) + ra = ra - 360.0d0 + else if (ra < -360.0d0) + ra = ra + 360.0d0 + + # Compute the DEC. + if (mod (dphi, DPI) == 0.0d0) { + dec = DRADTODEG(theta + cosphi * FC_COLATP(fc)) + if (dec > 90.0d0) + dec = 180.0d0 - dec + if (dec < -90.0d0) + dec = -180.0d0 - dec + } else { + z = sinthe * FC_COSLATP(fc) + costhe * FC_SINLATP(fc) * cosphi + if (abs(z) > 0.99d0) { + if (z >= 0.0d0) + dec = DRADTODEG(acos (sqrt(x * x + y * y))) + else + dec = DRADTODEG(-acos (sqrt(x * x + y * y))) + } else + dec = DRADTODEG(asin (z)) + } + + # Store the results. + w[ira] = ra + w[idec] = dec +end + + +# WF_TNX_INV -- Inverse transform (world to physical) for the gnomic +# projection. + +procedure wf_tnx_inv (fc, w, p) + +pointer fc #I pointer to FC descriptor +double w[2] #I input world (RA, DEC) coordinates +double p[2] #I output physical coordinates + +int ira, idec, niter +double ra, dec, cosdec, sindec, cosra, sinra, x, y, phi, theta, s, r, dphi, z +double xm, ym, f, fx, fy, g, gx, gy, denom, dx, dy, dmax +double wf_gseval(), wf_gsder() + +begin + # Get the axes numbers. + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + # Compute the transformation from celestial coordinates RA and + # DEC to native coordinates PHI and THETA. This is the spherical + # geometry part of the transformation. + + ra = DDEGTORAD (w[ira] - FC_W(fc,ira)) + dec = DDEGTORAD (w[idec]) + cosra = cos (ra) + sinra = sin (ra) + cosdec = cos (dec) + sindec = sin (dec) + + # Compute PHI. + x = sindec * FC_SINLATP(fc) - cosdec * FC_COSLATP(fc) * cosra + if (abs(x) < FC_SPHTOL(fc)) + x = -cos (dec + FC_COLATP(fc)) + cosdec * FC_COSLATP(fc) * + (1.0d0 - cosra) + y = -cosdec * sinra + if (x != 0.0d0 || y != 0.0d0) + dphi = atan2 (y, x) + else + dphi = ra - DPI + phi = FC_LONGP(fc) + dphi + if (phi > DPI) + phi = phi - DTWOPI + else if (phi < -DPI) + phi = phi + DTWOPI + + # Compute THETA. + if (mod (ra, DPI) ==0.0) { + theta = dec + cosra * FC_COLATP(fc) + if (theta > DHALFPI) + theta = DPI - theta + if (theta < -DHALFPI) + theta = -DPI - theta + } else { + z = sindec * FC_COSLATP(fc) + cosdec * FC_SINLATP(fc) * cosra + if (abs (z) > 0.99d0) { + if (z >= 0.0) + theta = acos (sqrt(x * x + y * y)) + else + theta = -acos (sqrt(x * x + y * y)) + } else + theta = asin (z) + } + + # Compute the transformation from native coordinates PHI and THETA + # to projected coordinates X and Y. + + s = sin (theta) + if (s == 0.0d0) { + p[ira] = FC_BADCVAL(fc) + p[idec] = FC_BADCVAL(fc) + } else { + r = FC_RODEG(fc) * cos (theta) / s + if (FC_LNGCOR(fc) == NULL && FC_LATCOR(fc) == NULL) { + p[ira] = r * sin (phi) + p[idec] = -r * cos (phi) + } else { + xm = r * sin (phi) + ym = -r * cos (phi) + x = xm + y = ym + niter = 0 + dmax = 30. / 3600. + repeat { + + if (FC_LNGCOR(fc) != NULL) { + f = x + wf_gseval (FC_LNGCOR(fc), x, y) - xm + fx = wf_gsder (FC_LNGCOR(fc), x, y, 1, 0) + fx = 1.0 + fx + fy = wf_gsder (FC_LNGCOR(fc), x, y, 0, 1) + } else { + f = x - xm + fx = 1.0 + fy = 0.0 + } + if (FC_LATCOR(fc) != NULL) { + g = y + wf_gseval (FC_LATCOR(fc), x, y) - ym + gx = wf_gsder (FC_LATCOR(fc), x, y, 1, 0) + gy = wf_gsder (FC_LATCOR(fc), x, y, 0, 1) + gy = 1.0 + gy + } else { + g = y - ym + gx = 0.0 + gy = 1.0 + } + + denom = fx * gy - fy * gx + if (denom == 0.0d0) + break + dx = (-f * gy + g * fy) / denom + dy = (-g * fx + f * gx) / denom + x = x + max (-dmax, min (dmax, dx)) + y = y + max (-dmax, min (dmax, dy)) + if (max (abs (dx), abs (dy), abs(f), abs(g)) < 2.80d-7) + break + + niter = niter + 1 + + } until (niter >= MAX_NITER) + + p[ira] = x + p[idec] = y + } + } +end + + +# WF_TNX_DESTROY -- Free up the distortion surface pointers. + +procedure wf_tnx_destroy (fc) + +pointer fc #I pointer to the FC descriptor + +begin + if (FC_LNGCOR(fc) != NULL) + call wf_gsclose (FC_LNGCOR(fc)) + if (FC_LATCOR(fc) != NULL) + call wf_gsclose (FC_LATCOR(fc)) +end diff --git a/sys/mwcs/wftpv.x b/sys/mwcs/wftpv.x new file mode 100644 index 00000000..812362be --- /dev/null +++ b/sys/mwcs/wftpv.x @@ -0,0 +1,556 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "imwcs.h" +include "mwcs.h" + +.help WFTPV +.nf ------------------------------------------------------------------------- +# WFTPV -- WCS function driver for the TPV polynomial projection. + +Driver routines: + + FN_INIT wf_tpv_init (fc, dir) + FN_DESTROY wf_tpv_destroy (fc) + FN_FWD wf_tpv_fwd (fc, v1, v2) + FN_INV wf_tpv_inv (fc, v1, v2) + +.endhelp -------------------------------------------------------------------- + +define MAX_NITER 20 + +# Driver specific fields of function call (FC) descriptor. +define FC_IRA Memi[$1+FCU] # RA axis (1 or 2) +define FC_IDEC Memi[$1+FCU+1] # DEC axis (1 or 2) +define FC_COSDEC Memd[P2D($1+FCU+2)] # cosine(dec) +define FC_SINDEC Memd[P2D($1+FCU+4)] # sine(dec) +define FC_W Memd[P2D($1+FCU+6)+($2)-1] # W (CRVAL) for each axis +define FC_NPRA Memi[$1+FCU+10] # poly order (0-39) +define FC_NPDEC Memi[$1+FCU+11] # poly order (0-39) +define FC_PV Memi[$1+FCU+12] # pointer to PV data (double) + +define FC_A Memd[FC_PV($1)+($2)] # RA coefficient +define FC_B Memd[FC_PV($1)+40+($2)] # DEC coefficient + +# WF_TPV_INIT -- Initialize the tan polynomial forward or inverse +# transform. Initialization for this transformation consists of, determining +# which axis is RA / LON and which is DEC / LAT, computing the celestial +# longitude and colatitude of the native pole, reading in the the native +# longitude of the pole of the celestial coordinate system LONGPOLE from the +# attribute list, precomputing the Euler angles and various intermediary +# functions of the reference coordinates, reading in the projection parameter +# RO from the attribute list, reading in up to ten polynomial coefficients, +# and, for polynomial orders greater than 2 computing the colatitude and radius +# of the first point of inflection. If LONGPOLE is undefined then a value of +# 180.0 degrees is assumed. If RO is undefined a value of 180.0 / PI is +# assumed. If the polynomial coefficients are all zero then an error condition +# is posted. If the order of the polynomial is 2 or greater and there is no +# point of inflection an error condition is posted. The TPV projection with +# an order of 1 and 0th and 1st coefficients of 0.0 and 1.0 respectively is +# equivalent to the ARC projtection. In order to determine the axis order, +# the parameter "axtype={ra|dec} {xlon|xlat}" must have been set in the +# attribute list for the function. The LONGPOLE and RO parameters may be set +# in either or both of the axes attribute lists, but the value in the RA axis +# attribute list takes precedence. + +procedure wf_tpv_init (fc, dir) + +pointer fc #I pointer to FC descriptor +int dir #I direction of transform + +int i, ualen, index, ip +double dec, dval +pointer ct, mw, wp, wv, im, idb, rp + +int idb_nextcard(), itoc(), ctod() +pointer idb_open() +errchk wf_decaxis() + +begin + # Allocate PV storage. This is freed in wf_tpv_destroy. + call calloc (FC_PV(fc), 80, TY_DOUBLE) + + # Set non-zero defaults. + FC_NPRA(fc) = 1 + FC_NPDEC(fc) = 1 + FC_A(fc,1) = 1D0 + FC_B(fc,1) = 1D0 + + # Get the required mwcs pointers. + + # Determine which is the DEC axis, and hence the axis order. + call wf_decaxis (fc, FC_IRA(fc), FC_IDEC(fc)) + + # Get the value of W for each axis, i.e. the world coordinates at + # the reference point. + + ct = FC_CT(fc) + mw = CT_MW(ct) + wp = FC_WCS(fc) + wv = MI_DBUF(mw) + WCS_W(wp) - 1 + do i = 1, 2 + FC_W(fc,i) = Memd[wv+CT_AXIS(ct,FC_AXIS(fc,i))-1] + + # Precompute the sin and cos of the declination at the reference pixel. + dec = DEGTORAD(FC_W(fc,FC_IDEC(fc))) + FC_COSDEC(fc) = cos(dec) + FC_SINDEC(fc) = sin(dec) + + # Read through the fits header once more and pick up the PV cards. + # Read the values and store them, keeping track of what is + # the highest order coefficient. + + im = MI_REFIM(mw) + idb = idb_open(im,ualen) + while (idb_nextcard(idb,rp) != EOF) { + if (Memc[rp] != 'P' || Memc[rp+1] != 'V' || Memc[rp+3] != '_') + next + if (Memc[rp+2] != '1' && Memc[rp+2] != '2') + next + if (! IS_DIGIT(Memc[rp+4])) + next + index = TO_INTEG(Memc[rp+4]) + do i = 5,7 { + if (! IS_DIGIT(Memc[rp+i])) + break + else + index = 10*index + TO_INTEG(Memc[rp+i]) + } + if (index > 39) + next + ip = IDB_STARTVALUE + if (ctod(Memc[rp],ip,dval) <= 0) + dval = 0.0d0 + i = TO_INTEG(Memc[rp+2]) + if (i == FC_IRA(fc)) { + FC_A(fc,index) = dval + if (index > FC_NPRA(fc)) + FC_NPRA(fc) = double(index) + } else { + FC_B(fc,index) = dval + if (index > FC_NPDEC(fc)) + FC_NPDEC(fc) = double(index) + } + } + call idb_close(idb) + +end + + +# WF_TPV_FWD -- Forward transform (physical to world) for the tangent plane +# with polynomial distortion. + +procedure wf_tpv_fwd (fc, p, w) + +pointer fc #I pointer to FC descriptor +double p[2] #I physical coordinates (x, y) +double w[2] #O world coordinates (ra, dec) + +double x, y, z, a, b, ra, dec + +begin + # Compute the standard coordinates. + + x = p[1] + y = p[2] + call tpv_poly (fc, x, y, a, b) + + # Rotate the rectangular coordinate system of the vector [1,xi,eta] + # by the declination so that the X axis will pass through the equator. + + a = DEGTORAD(a) + b = DEGTORAD(b) + + x = FC_COSDEC(fc) - b * FC_SINDEC(fc) + y = a + z = FC_SINDEC(fc) + b * FC_COSDEC(fc) + + # Compute RA and DEC in radians. + if (x == 0.0D0 && y == 0.0D0) + ra = 0.0D0 + else + ra = atan2 (y, x) + dec = atan2 (z, sqrt (x*x + y*y)) + + # Return RA and DEC in degrees. + dec = RADTODEG(dec) + ra = RADTODEG(ra) + FC_W(fc,FC_IRA(fc)) + + if (ra < 0D0) + ra = ra + 360D0 + else if (ra > 360D0) + ra = ra - 360D0 + + w[FC_IRA(fc)] = ra + w[FC_IDEC(fc)] = dec + +end + + +# WF_TPV_INV -- Inverse transform (world to physical) for the tangent plane +# projection with polynomials. + +procedure wf_tpv_inv (fc, w, p) + +pointer fc #I pointer to FC descriptor +double w[2] #I input world (RA, DEC) coordinates +double p[2] #I output physical coordinates + +int ira, idec, niter +double ra, dec +double cosra, cosdec, sinra, sindec, cosdist +double a, b, x, y, f, g, fx, gx, fy, gy, denom, dx, dy, dmax + +begin + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + ra = DEGTORAD (w[ira] - FC_W(fc,ira)) + dec = DEGTORAD (w[idec]) + + cosra = cos (ra) + sinra = sin (ra) + cosdec = cos (dec) + sindec = sin (dec) + cosdist = sindec * FC_SINDEC(fc) + cosdec * FC_COSDEC(fc) * cosra + + a = RADTODEG(cosdec * sinra / cosdist) + b = RADTODEG((sindec * FC_COSDEC(fc) - cosdec * FC_SINDEC(fc) * cosra) / + cosdist) + + x = a + y = b + dmax = 30. / 3600. + niter = 0 + + repeat { + call tpv_poly (fc, x, y, f, g) + call tpv_der (fc, x, y, fx, gx, fy, gy) + + f = f - a + g = g - b + + denom = fx * gy - fy * gx + if (denom == 0.0d0) + break + + dx = (-f * gy + g * fy) / denom + dy = (-g * fx + f * gx) / denom + x = x + max (-dmax, min (dmax, dx)) + y = y + max (-dmax, min (dmax, dy)) + + if (max (abs (dx), abs (dy), abs(f), abs(g)) < 2.0d-7) + break + + niter = niter + 1 + + } until (niter >= MAX_NITER) + + p[ira] = x + p[idec] = y + +end + + +# WF_TPV_DESTROY -- Free up the distortion surface pointers. + +procedure wf_tpv_destroy (fc) + +pointer fc #I pointer to the FC descriptor + +begin + call mfree (FC_PV(fc), TY_DOUBLE) +end + + +# TPV_POLY -- Evaluate TPV polynomial (x,y -> xi,eta) + +procedure tpv_poly (fc, x, y, a, b) + +pointer fc #I pointer to FC descriptor +double x, y #I physical coordinates +double a, b #O standard coordinates (xi, eta) in deg + +int n +double r, r2, r3, r5, r7, x2, x3, x4, x5, x6, x7, y2, y3, y4, y5, y6, y7 + +begin + # Compute the standard coordinates. + # This depends on undefined coefficients being zero. + + x2 = x * x + y2 = y * y + r2 = x2 + y2 + r = sqrt (r2) + n = max (FC_NPRA(fc), FC_NPDEC(fc)) + + a = FC_A(fc,0) + FC_A(fc,1) * x + FC_A(fc,2) * y + FC_A(fc,3) * r + b = FC_B(fc,0) + FC_B(fc,1) * y + FC_B(fc,2) * x + FC_B(fc,3) * r + if (n <= 3) + return + a = a + FC_A(fc,4) * x2 + FC_A(fc,5) * x*y + FC_A(fc,6) * y2 + b = b + FC_B(fc,4) * y2 + FC_B(fc,5) * x*y + FC_B(fc,6) * x2 + if (n <= 6) + return + x3 = x * x2 + y3 = y * y2 + r3 = r * r2 + a = a + FC_A(fc,7) * x3 + b = b + FC_B(fc,7) * y3 + a = a + FC_A(fc,8) * x2*y + b = b + FC_B(fc,8) * y2*x + a = a + FC_A(fc,9) * x*y2 + b = b + FC_B(fc,9) * y*x2 + a = a + FC_A(fc,10) * y3 + b = b + FC_B(fc,10) * x3 + a = a + FC_A(fc,11) * r3 + b = b + FC_B(fc,11) * r3 + if (n <= 11) + return + x4 = x * x3 + y4 = y * y3 + a = a + FC_A(fc,12) * x4 + b = b + FC_B(fc,12) * y4 + a = a + FC_A(fc,13) * x3*y + b = b + FC_B(fc,13) * y3*x + a = a + FC_A(fc,14) * x2*y2 + b = b + FC_B(fc,14) * y2*x2 + a = a + FC_A(fc,15) * x*y3 + b = b + FC_B(fc,15) * y*x3 + a = a + FC_A(fc,16) * y4 + b = b + FC_B(fc,16) * x4 + if (n <= 16) + return + x5 = x * x4 + y5 = y * y4 + r5 = r3 * r2 + a = a + FC_A(fc,17) * x5 + b = b + FC_B(fc,17) * y5 + a = a + FC_A(fc,18) * x4*y + b = b + FC_B(fc,18) * y4*x + a = a + FC_A(fc,19) * x3*y2 + b = b + FC_B(fc,19) * y3*x2 + a = a + FC_A(fc,20) * x2*y3 + b = b + FC_B(fc,20) * y2*x3 + a = a + FC_A(fc,21) * x*y4 + b = b + FC_B(fc,21) * y*x4 + a = a + FC_A(fc,22) * y5 + b = b + FC_B(fc,22) * x5 + a = a + FC_A(fc,23) * r5 + b = b + FC_B(fc,23) * r5 + if (n <= 23) + return + x6 = x * x5 + y6 = y * y5 + a = a + FC_A(fc,14) * x6 + b = b + FC_B(fc,24) * y6 + a = a + FC_A(fc,25) * x5*y + b = b + FC_B(fc,25) * y5*x + a = a + FC_A(fc,26) * x4*y2 + b = b + FC_B(fc,26) * y4*x2 + a = a + FC_A(fc,27) * x3*y3 + b = b + FC_B(fc,27) * y3*x3 + a = a + FC_A(fc,28) * x2*y4 + b = b + FC_B(fc,28) * y2*x4 + a = a + FC_A(fc,29) * x*y5 + b = b + FC_B(fc,29) * y*x5 + a = a + FC_A(fc,30) * y6 + b = b + FC_B(fc,30) * x6 + if (n <= 30) + return + x7 = x * x6 + y7 = y * y6 + r7 = r5 * r2 + a = a + FC_A(fc,31) * x7 + b = b + FC_B(fc,31) * y7 + a = a + FC_A(fc,32) * x6*y + b = b + FC_B(fc,32) * y6*x + a = a + FC_A(fc,33) * x5*y2 + b = b + FC_B(fc,33) * y5*x2 + a = a + FC_A(fc,34) * x4*y3 + b = b + FC_B(fc,34) * y4*x3 + a = a + FC_A(fc,35) * x3*y4 + b = b + FC_B(fc,35) * y3*x4 + a = a + FC_A(fc,36) * x2*y5 + b = b + FC_B(fc,36) * y2*x5 + a = a + FC_A(fc,37) * x*y6 + b = b + FC_B(fc,37) * y*x6 + a = a + FC_A(fc,38) * y7 + b = b + FC_B(fc,38) * x7 + a = a + FC_A(fc,39) * r7 + b = b + FC_B(fc,39) * r7 + +end + + +# TPV_DER -- Evaluate TPV polynomial (x,y -> xi,eta) + +procedure tpv_der (fc, x, y, ax, bx, ay, by) + +pointer fc #I pointer to FC descriptor +double x, y #I physical coordinates +double ax, bx #O standard coordinates (xi, eta) in deg +double ay, by #O standard coordinates (xi, eta) in deg + +int n +double r, r2, r4, r6, x2, x3, x4, x5, x6, y2, y3, y4, y5, y6, rx, ry + +begin + x2 = x * x + y2 = y * y + r2 = x2 + y2 + r = sqrt (r2) + if (r < 2.0d-7) { + rx = 1D0 + ry = 1D0 + } else { + rx = x / r + ry = y / r + } + n = max (FC_NPRA(fc), FC_NPDEC(fc)) + + ax = FC_A(fc,1) + FC_A(fc,3) * rx + by = FC_B(fc,1) + FC_B(fc,3) * ry + ay = FC_A(fc,2) + FC_A(fc,3) * ry + bx = FC_B(fc,2) + FC_B(fc,3) * rx + if (n <= 3) + return + ax = ax + 2 * FC_A(fc,4) * x + FC_A(fc,5) * y + by = by + 2 * FC_B(fc,4) * y + FC_B(fc,5) * x + ay = ay + FC_A(fc,5) * x + 2 * FC_A(fc,6) * y + bx = bx + FC_B(fc,5) * y + 2 * FC_B(fc,6) * x + if (n <= 6) + return + ax = ax + 3 * FC_A(fc,7) * x2 + by = by + 3 * FC_B(fc,7) * y2 + ax = ax + 2 * FC_A(fc,8) * x*y + by = by + 2 * FC_B(fc,8) * y*x + ax = ax + FC_A(fc,9) * y2 + by = by + FC_B(fc,9) * x2 + ax = ax + 3 * FC_A(fc,11) * r2 * rx + by = by + 3 * FC_B(fc,11) * r2 * ry + ay = ay + FC_A(fc,8) * x2 + bx = bx + FC_B(fc,8) * y2 + ay = ay + 2 * FC_A(fc,9) * x*y + bx = bx + 2 * FC_B(fc,9) * y*x + ay = ay + 3 * FC_A(fc,10) * y2 + bx = bx + 3 * FC_B(fc,10) * x2 + ay = ay + 3 * FC_A(fc,11) * r2 * ry + bx = bx + 3 * FC_B(fc,11) * r2 * rx + if (n <= 11) + return + x3 = x * x2 + y3 = y * y2 + ax = ax + 4 * FC_A(fc,12) * x3 + by = by + 4 * FC_B(fc,12) * y3 + ax = ax + 3 * FC_A(fc,13) * x2*y + by = by + 3 * FC_B(fc,13) * y2*x + ax = ax + 2 * FC_A(fc,14) * x*y2 + by = by + 2 * FC_B(fc,14) * y*x2 + ax = ax + FC_A(fc,15) * y3 + by = by + FC_B(fc,15) * x3 + ay = ay + FC_A(fc,13) * x3 + bx = bx + FC_B(fc,13) * y3 + ay = ay + 2 * FC_A(fc,14) * x2*y + bx = bx + 2 * FC_B(fc,14) * y2*x + ay = ay + 3 * FC_A(fc,15) * x*y2 + bx = bx + 3 * FC_B(fc,15) * y*x2 + ay = ay + 4 * FC_A(fc,16) * y3 + bx = bx + 4 * FC_B(fc,16) * x3 + if (n <= 16) + return + x4 = x * x3 + y4 = y * y3 + r4 = r2 * r2 + ax = ax + 5 * FC_A(fc,17) * x4 + by = by + 5 * FC_B(fc,17) * y4 + ax = ax + 4 * FC_A(fc,18) * x3*y + by = by + 4 * FC_B(fc,18) * y3*x + ax = ax + 3 * FC_A(fc,19) * x2*y2 + by = by + 3 * FC_B(fc,19) * y2*x2 + ax = ax + 2 * FC_A(fc,20) * x*y3 + by = by + 2 * FC_B(fc,20) * y*x3 + ax = ax + FC_A(fc,21) * y4 + by = by + FC_B(fc,21) * x4 + ax = ax + 5 * FC_A(fc,23) * r4 * rx + by = by + 5 * FC_B(fc,23) * r4 * ry + ay = ay + FC_A(fc,18) * x4 + bx = bx + FC_B(fc,18) * y4 + ay = ay + 2 * FC_A(fc,19) * x3*y + bx = bx + 2 * FC_B(fc,19) * y3*x + ay = ay + 3 * FC_A(fc,20) * x2*y2 + bx = bx + 3 * FC_B(fc,20) * y2*x2 + ay = ay + 4 * FC_A(fc,21) * x*y3 + bx = bx + 4 * FC_B(fc,21) * y*x3 + ay = ay + 5 * FC_A(fc,22) * y4 + bx = bx + 5 * FC_B(fc,22) * x4 + ay = ay + 5 * FC_A(fc,23) * r4 * ry + bx = bx + 5 * FC_B(fc,23) * r4 * rx + if (n <= 23) + return + x5 = x * x4 + y5 = y * y4 + ax = ax + 6 * FC_A(fc,14) * x5 + by = by + 6 * FC_B(fc,24) * y5 + ax = ax + 5 * FC_A(fc,25) * x4*y + by = by + 5 * FC_B(fc,25) * y4*x + ax = ax + 4 * FC_A(fc,26) * x3*y2 + by = by + 4 * FC_B(fc,26) * y3*x2 + ax = ax + 3 * FC_A(fc,27) * x2*y3 + by = by + 3 * FC_B(fc,27) * y2*x3 + ax = ax + 2 * FC_A(fc,28) * x*y4 + by = by + 2 * FC_B(fc,28) * y*x4 + ax = ax + FC_A(fc,29) * y5 + by = by + FC_B(fc,29) * x5 + ay = ay + FC_A(fc,25) * x5 + bx = bx + FC_B(fc,25) * y5 + ay = ay + 2 * FC_A(fc,26) * x4*y + bx = bx + 2 * FC_B(fc,26) * y4*x + ay = ay + 3 * FC_A(fc,27) * x3*y2 + bx = bx + 3 * FC_B(fc,27) * y3*x2 + ay = ay + 4 * FC_A(fc,28) * x2*y3 + bx = bx + 4 * FC_B(fc,28) * y2*x3 + ay = ay + 5 * FC_A(fc,29) * x*y4 + bx = bx + 5 * FC_B(fc,29) * y*x4 + ay = ay + 6 * FC_A(fc,30) * y5 + bx = bx + 6 * FC_B(fc,30) * x5 + if (n <= 30) + return + x6 = x * x5 + y6 = y * y5 + r6 = r4 * r2 + ax = ax + 7 * FC_A(fc,31) * x6 + by = by + 7 * FC_B(fc,31) * y6 + ax = ax + 6 * FC_A(fc,32) * x5*y + by = by + 6 * FC_B(fc,32) * y5*x + ax = ax + 5 * FC_A(fc,33) * x4*y2 + by = by + 5 * FC_B(fc,33) * y4*x2 + ax = ax + 4 * FC_A(fc,34) * x3*y3 + by = by + 4 * FC_B(fc,34) * y3*x3 + ax = ax + 3 * FC_A(fc,35) * x2*y4 + by = by + 3 * FC_B(fc,35) * y2*x4 + ax = ax + 2 * FC_A(fc,36) * x*y5 + by = by + 2 * FC_B(fc,36) * y*x5 + ax = ax + FC_A(fc,37) * y6 + by = by + FC_B(fc,37) * x6 + ax = ax + 7 * FC_A(fc,39) * r6 * rx + by = by + 7 * FC_B(fc,39) * r6 * ry + ay = ay + FC_A(fc,32) * x6 + bx = bx + FC_B(fc,32) * y6 + ay = ay + 2 * FC_A(fc,33) * x5*y + bx = bx + 2 * FC_B(fc,33) * y5*x + ay = ay + 3 * FC_A(fc,34) * x4*y2 + bx = bx + 3 * FC_B(fc,34) * y4*x2 + ay = ay + 4 * FC_A(fc,35) * x3*y3 + bx = bx + 4 * FC_B(fc,35) * y3*x3 + ay = ay + 5 * FC_A(fc,36) * x2*y4 + bx = bx + 5 * FC_B(fc,36) * y2*x4 + ay = ay + 6 * FC_A(fc,37) * x*y5 + bx = bx + 6 * FC_B(fc,37) * y*x5 + ay = ay + 7 * FC_A(fc,38) * y6 + bx = bx + 7 * FC_B(fc,38) * x6 + ay = ay + 7 * FC_A(fc,39) * r6 * ry + bx = bx + 7 * FC_B(fc,39) * r6 * rx + +end diff --git a/sys/mwcs/wftsc.x b/sys/mwcs/wftsc.x new file mode 100644 index 00000000..65445653 --- /dev/null +++ b/sys/mwcs/wftsc.x @@ -0,0 +1,563 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +.help WFTSC +.nf ------------------------------------------------------------------------- +WFTSC -- WCS function driver for the tangentil spherical cube projection. + +Driver routines: + + FN_INIT wf_tsc_init (fc, dir) + FN_DESTROY (none) + FN_FWD wf_tsc_fwd (fc, v1, v2) + FN_INV wf_tsc_inv (fc, v1, v2) + +.endhelp -------------------------------------------------------------------- + +# Driver specific fields of function call (FC) descriptor. +define FC_IRA Memi[$1+FCU] # RA axis (1 or 2) +define FC_IDEC Memi[$1+FCU+1] # DEC axis (1 or 2) +define FC_NATRA Memd[P2D($1+FCU+2)] # RA of native pole (rads) +define FC_NATDEC Memd[P2D($1+FCU+4)] # DEC of native pole (rads) +define FC_LONGP Memd[P2D($1+FCU+6)] # LONGPOLE (rads) +define FC_COSDEC Memd[P2D($1+FCU+8)] # cosine (NATDEC) +define FC_SINDEC Memd[P2D($1+FCU+10)] # sine (NATDEC) +define FC_SPHTOL Memd[P2D($1+FCU+12)] # trig tolerance +define FC_RODEG Memd[P2D($1+FCU+14)] # RO (degs) +define FC_C1 Memd[P2D($1+FCU+16)] # RO * (PI / 4) +define FC_C2 Memd[P2D($1+FCU+18)] # (4 / PI) / RO +define FC_BADCVAL Memd[P2D($1+FCU+20)] # bad coordinate value +define FC_W Memd[P2D($1+FCU+22)+($2)-1] # CRVAL axis (1 and 2) + + +# WF_TSC_INIT -- Initialize the forward or inverse tangential spherical cube +# projection transform. Initialization for this transformation consists of, +# determining which axis is RA / LON and which is DEC / LAT, reading in the +# native longitude and latitude of the pole in celestial coordinates LONGPOLE +# and LATPOLE from the attribute list, computing the celestial longitude and +# colatitude of the native pole, precomputing the Euler angles and various +# intermediary functions of the reference point, reading in the projection +# parameter RO from the attribute list, and precomputing the various required +# intermediate quantities. If LONGPOLE is undefined then a value of 180.0 +# degrees is assumed if the celestial latitude is less than 0, otherwise 0 +# is assumed. If LATPOLE is undefined then the most northerly of the two +# possible solutions is chosen, otherwise the solution closest to LATPOLE +# is chosen. If RO is undefined a value of 180.0 / PI is assumed. In order to +# determine the axis order, the parameter "axtype={ra|dec} {xlon|xlat}" must +# have been set in the attribute list for the function. The LONGPOLE, LATPOLE, +# and RO parameters may be set in either or both of the axes attribute lists, +# but the value in the RA axis attribute list takes precedence. + +procedure wf_tsc_init (fc, dir) + +pointer fc #I pointer to FC descriptor +int dir #I direction of transform + +int i +double dec, latpole, theta0, clat0, slat0, cphip, sphip, cthe0, sthe0, x, y, z +double u, v, latp1, latp2, latp, maxlat, tol +pointer sp, atvalue, ct, mw, wp, wv +int ctod() +data tol/1.0d-10/ +errchk wf_decaxis(), mw_gwattrs() + +begin + # Allocate space for the attribute string. + call smark (sp) + call salloc (atvalue, SZ_LINE, TY_CHAR) + + # Get the required mwcs pointers. + ct = FC_CT(fc) + mw = CT_MW(ct) + wp = FC_WCS(fc) + + # Determine which is the DEC axis, and hence the axis order. + call wf_decaxis (fc, FC_IRA(fc), FC_IDEC(fc)) + + # Get the value of W for each axis, i.e. the world coordinates at + # the reference point. + + wv = MI_DBUF(mw) + WCS_W(wp) - 1 + do i = 1, 2 + FC_W(fc,i) = Memd[wv+CT_AXIS(ct,FC_AXIS(fc,i))-1] + + # Determine the native longitude and latitude of the pole of the + # celestial coordinate system corresponding to the FITS keywords + # LONGPOLE and LATPOLE. LONGPOLE has no default but will be set + # to 180 or 0 depending on the value of the declination of the + # reference point. LATPOLE has no default but will be set depending + # on the values of LONGPOLE and the reference declination. + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "longpole", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "longpole", Memc[atvalue], + SZ_LINE) + } then { + FC_LONGP(fc) = INDEFD + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_LONGP(fc)) <= 0) + FC_LONGP(fc) = INDEFD + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_LONGP(fc)) <= 0) + FC_LONGP(fc) = INDEFD + } + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "latpole", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "latpole", Memc[atvalue], + SZ_LINE) + } then { + latpole = INDEFD + } else { + i = 1 + if (ctod (Memc[atvalue], i, latpole) <= 0) + latpole = INDEFD + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, latpole) <= 0) + latpole = INDEFD + } + + # Fetch the RO projection parameter which is the radius of the + # generating sphere for the projection. If RO is absent which + # is the usual case set it to 180 / PI. Search both axes for + # this quantity. + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "ro", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "ro", Memc[atvalue], + SZ_LINE) + } then { + FC_RODEG(fc) = 180.0d0 / DPI + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_RODEG(fc)) <= 0) + FC_RODEG(fc) = 180.0d0 / DPI + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_RODEG(fc)) <= 0) + FC_RODEG(fc) = 180.0d0 / DPI + } + + # Compute the native longitude of the celestial pole. + dec = DDEGTORAD(FC_W(fc,FC_IDEC(fc))) + theta0 = 0.0d0 + if (IS_INDEFD(FC_LONGP(fc))) { + if (dec < theta0) + FC_LONGP(fc) = DPI + else + FC_LONGP(fc) = 0.0d0 + } else + FC_LONGP(fc) = DDEGTORAD(FC_LONGP(fc)) + + # Compute the celestial longitude and latitude of the native pole. + clat0 = cos (dec) + slat0 = sin (dec) + cphip = cos (FC_LONGP(fc)) + sphip = sin (FC_LONGP(fc)) + cthe0 = cos (theta0) + sthe0 = sin (theta0) + + x = cthe0 * cphip + y = sthe0 + z = sqrt (x * x + y * y) + + # The latitude of the native pole is determined by LATPOLE in this + # case. + if (z == 0.0d0) { + + if (slat0 != 0.0d0) + call error (0, "WF_TSC_INIT: Invalid projection parameters") + if (IS_INDEFD(latpole)) + latp = 999.0d0 + else + latp = DDEGTORAD(latpole) + + } else { + if (abs (slat0 / z) > 1.0d0) + call error (0, "WF_TSC_INIT: Invalid projection parameters") + + u = atan2 (y, x) + v = acos (slat0 / z) + latp1 = u + v + if (latp1 > DPI) + latp1 = latp1 - DTWOPI + else if (latp1 < -DPI) + latp1 = latp1 + DTWOPI + + latp2 = u - v + if (latp2 > DPI) + latp2 = latp2 - DTWOPI + else if (latp2 < -DPI) + latp2 = latp2 + DTWOPI + + if (IS_INDEFD(latpole)) + maxlat = 999.0d0 + else + maxlat = DDEGTORAD(latpole) + if (abs (maxlat - latp1) < abs (maxlat - latp2)) { + if (abs (latp1) < (DHALFPI + tol)) + latp = latp1 + else + latp = latp2 + } else { + if (abs (latp2) < (DHALFPI + tol)) + latp = latp2 + else + latp = latp1 + } + } + FC_NATDEC(fc) = DHALFPI - latp + + z = cos (latp) * clat0 + if (abs(z) < tol) { + + # Celestial pole at the reference point. + if (abs(clat0) < tol) { + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) + FC_NATDEC(fc) = DHALFPI - theta0 + # Celestial pole at the native north pole. + } else if (latp > 0.0d0) { + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) + FC_LONGP(fc) - + DPI + FC_NATDEC(fc) = 0.0d0 + # Celestial pole at the native south pole. + } else if (latp < 0.0d0) { + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) - FC_LONGP(fc) + FC_NATDEC(fc) = DPI + } + + } else { + x = (sthe0 - sin (latp) * slat0) / z + y = sphip * cthe0 / clat0 + if (x == 0.0d0 && y == 0.0d0) + call error (0, "WF_TSC_INIT: Invalid projection parameters") + FC_NATRA(fc) = DDEGTORAD(FC_W(fc,FC_IRA(fc))) - atan2 (y,x) + } + + if (FC_W(fc,FC_IRA(fc)) >= 0.0d0) { + if (FC_NATRA(fc) < 0.0d0) + FC_NATRA(fc) = FC_NATRA(fc) + DTWOPI + } else { + if (FC_NATRA(fc) > 0.0d0) + FC_NATRA(fc) = FC_NATRA(fc) - DTWOPI + } + FC_COSDEC(fc) = cos (FC_NATDEC(fc)) + FC_SINDEC(fc) = sin (FC_NATDEC(fc)) + + # Check for ill-conditioned parameters. + if (abs(latp) > (DHALFPI+tol)) + call error (0, "WF_TSC_INIT: Invalid projection parameters") + + # Compute the required intermediate quantities. + FC_C1(fc) = FC_RODEG(fc) * (DPI / 4.0d0) + FC_C2(fc) = 1.0d0 / FC_C1(fc) + + # Set the bad coordinate value. + FC_SPHTOL(fc) = 1.0d-5 + + # Set the bad coordinate value. + FC_BADCVAL(fc) = INDEFD + + # Free working space. + call sfree (sp) +end + + +# WF_TSC_FWD -- Forward transform (physical to world) for the tangential +# spherical projection. + +procedure wf_tsc_fwd (fc, p, w) + +pointer fc #I pointer to FC descriptor +double p[2] #I physical coordinates (x, y) +double w[2] #O world coordinates (ra, dec) + +int ira, idec, face +double l, m, n, phi, theta, costhe, sinthe, dphi, cosphi, sinphi, x, y, z +double xf, yf, ra, dec, dlng + +begin + # Get the axis numbers. + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + # Compute native spherical coordinates PHI and THETA in degrees from + # the projected coordinates. This is the projection part of the + # computation. + + xf = p[ira] * FC_C2(fc) + yf = p[idec] * FC_C2(fc) + if (xf > 5.0d0) { + face = 4 + xf = xf - 6.0d0 + l = -1.0d0 / sqrt (1.0d0 + xf * xf + yf * yf) + m = -l * xf + n = -l * yf + } else if (xf > 3.0d0) { + face = 3 + xf = xf - 4.0d0 + m = -1.0d0 / sqrt (1.0d0 + xf * xf + yf * yf) + l = m * xf + n = -m * yf + } else if (xf > 1.0d0) { + face = 2 + xf = xf - 2.0d0 + l = 1.0d0 / sqrt (1.0d0 + xf * xf + yf * yf) + m = -l * xf + n = l * yf + } else if (yf > 1.0d0) { + face = 0 + yf = yf - 2.0d0 + n = 1.0d0 / sqrt (1.0d0 + xf * xf + yf * yf) + l = n * xf + m = -n * yf + } else if (yf < -1.0d0) { + face = 5 + yf = yf + 2.0d0 + n = -1.0d0 / sqrt (1.0d0 + xf * xf + yf * yf) + l = -n * xf + m = -n * yf + } else { + face = 1 + m = 1.0d0 / sqrt (1.0d0 + xf * xf + yf * yf) + l = m * xf + n = m * yf + } + + # Compute PHI. + if (l == 0.0d0 && m == 0.0d0) + phi = 0.0d0 + else + phi = atan2 (l, m) + + # Compute THETA. + theta = asin(n) + + # Compute the celestial coordinates RA and DEC from the native + # coordinates PHI and THETA. This is the spherical geometry part + # of the computation. + + costhe = cos (theta) + sinthe = sin (theta) + dphi = phi - FC_LONGP(fc) + cosphi = cos (dphi) + sinphi = sin (dphi) + + # Compute the RA. + x = sinthe * FC_SINDEC(fc) - costhe * FC_COSDEC(fc) * cosphi + if (abs (x) < FC_SPHTOL(fc)) + x = -cos (theta + FC_NATDEC(fc)) + costhe * FC_COSDEC(fc) * + (1.0d0 - cosphi) + y = -costhe * sinphi + if (x != 0.0d0 || y != 0.0d0) { + dlng = atan2 (y, x) + } else { + dlng = dphi + DPI + } + ra = DRADTODEG(FC_NATRA(fc) + dlng) + + # Normalize the RA. + if (FC_NATRA(fc) >= 0.0d0) { + if (ra < 0.0d0) + ra = ra + 360.0d0 + } else { + if (ra > 0.0d0) + ra = ra - 360.0d0 + } + if (ra > 360.0d0) + ra = ra - 360.0d0 + else if (ra < -360.0d0) + ra = ra + 360.0d0 + + # Compute the DEC. + if (mod (dphi, DPI) == 0.0d0) { + dec = DRADTODEG(theta + cosphi * FC_NATDEC(fc)) + if (dec > 90.0d0) + dec = 180.0d0 - dec + if (dec < -90.0d0) + dec = -180.0d0 - dec + } else { + z = sinthe * FC_COSDEC(fc) + costhe * FC_SINDEC(fc) * cosphi + if (abs(z) > 0.99d0) { + if (z >= 0.0d0) + dec = DRADTODEG(acos (sqrt(x * x + y * y))) + else + dec = DRADTODEG(-acos (sqrt(x * x + y * y))) + } else + dec = DRADTODEG(asin (z)) + } + + # Store the results. + w[ira] = ra + w[idec] = dec +end + + +# WF_TSC_INV -- Inverse transform (world to physical) for the tangential +# spherical projection. + +procedure wf_tsc_inv (fc, w, p) + +pointer fc #I pointer to FC descriptor +double w[2] #I input world (RA, DEC) coordinates +double p[2] #I output physical coordinates + +int ira, idec, face +double ra, dec, cosdec, sindec, cosra, sinra, x, y, z, dphi, phi, theta +double costhe, l, m, n, rho, tol, x0, y0, xf, yf +data tol /1.0d-12/ + +begin + # Get the axes numbers. + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + # Compute the transformation from celestial coordinates RA and + # DEC to native coordinates PHI and THETA. This is the spherical + # geometry part of the transformation. + + ra = DDEGTORAD (w[ira]) - FC_NATRA(fc) + dec = DDEGTORAD (w[idec]) + cosra = cos (ra) + sinra = sin (ra) + cosdec = cos (dec) + sindec = sin (dec) + + # Compute PHI. + x = sindec * FC_SINDEC(fc) - cosdec * FC_COSDEC(fc) * cosra + if (abs(x) < FC_SPHTOL(fc)) + x = -cos (dec + FC_NATDEC(fc)) + cosdec * FC_COSDEC(fc) * + (1.0d0 - cosra) + y = -cosdec * sinra + if (x != 0.0d0 || y != 0.0d0) + dphi = atan2 (y, x) + else + dphi = ra - DPI + phi = FC_LONGP(fc) + dphi + if (phi > DPI) + phi = phi - DTWOPI + else if (phi < -DPI) + phi = phi + DTWOPI + + # Compute THETA. + if (mod (ra, DPI) == 0.0) { + theta = dec + cosra * FC_NATDEC(fc) + if (theta > DHALFPI) + theta = DPI - theta + if (theta < -DHALFPI) + theta = -DPI - theta + } else { + z = sindec * FC_COSDEC(fc) + cosdec * FC_SINDEC(fc) * cosra + if (abs (z) > 0.99d0) { + if (z >= 0.0) + theta = acos (sqrt(x * x + y * y)) + else + theta = -acos (sqrt(x * x + y * y)) + } else + theta = asin (z) + } + + # Compute the transformation from native coordinates PHI and THETA + # to projected coordinates X and Y. + + costhe = cos (theta) + l = costhe * sin (phi) + m = costhe * cos (phi) + n = sin (theta) + + face = 0 + rho = n + if (m > rho) { + face = 1 + rho = m + } + if (l > rho) { + face = 2 + rho = l + } + if (-m > rho) { + face = 3 + rho = -m + } + if (-l > rho) { + face = 4 + rho = -l + } + if (-n > rho) { + face = 5 + rho = -n + } + + switch (face) { + case 0: + xf = l / rho + yf = -m / rho + x0 = 0.0d0 + y0 = 2.0d0 + case 1: + xf = l / rho + yf = n / rho + x0 = 0.0d0 + y0 = 0.0d0 + case 2: + xf = -m / rho + yf = n / rho + x0 = 2.0d0 + y0 = 0.0d0 + case 3: + xf = -l / rho + yf = n / rho + x0 = 4.0d0 + y0 = 0.0d0 + case 4: + xf = m / rho + yf = n / rho + x0 = 6.0d0 + y0 = 0.0d0 + case 5: + xf = l / rho + yf = m / rho + x0 = 0.0d0 + y0 = -2.0d0 + } + + if (abs(xf) > 1.0d0) { + if (abs(xf) > (1.0d0 + tol)) { + p[ira] = FC_BADCVAL(fc) + p[idec] = FC_BADCVAL(fc) + return + } + if (xf >= 0.0d0) + xf = 1.0d0 + else + xf = -1.0d0 + } + if (abs(yf) > 1.0d0) { + if (abs(yf) > (1.0d0 + tol)) { + p[ira] = FC_BADCVAL(fc) + p[idec] = FC_BADCVAL(fc) + return + } + if (yf >= 0.0d0) + yf = 1.0d0 + else + yf = -1.0d0 + } + + p[ira] = FC_C1(fc) * (x0 + xf) + p[idec] = FC_C1(fc) * (y0 + yf) +end diff --git a/sys/mwcs/wfzea.x b/sys/mwcs/wfzea.x new file mode 100644 index 00000000..f25640aa --- /dev/null +++ b/sys/mwcs/wfzea.x @@ -0,0 +1,324 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +.help WFZEA +.nf ------------------------------------------------------------------------- +WFZEA -- WCS function driver for the zenithal equal area projection. + +Driver routines: + + FN_INIT wf_zea_init (fc, dir) + FN_DESTROY (none) + FN_FWD wf_zea_fwd (fc, v1, v2) + FN_INV wf_zea_inv (fc, v1, v2) + +.endhelp -------------------------------------------------------------------- + +# Driver specific fields of function call (FC) descriptor. +define FC_IRA Memi[$1+FCU] # RA axis (1 or 2) +define FC_IDEC Memi[$1+FCU+1] # DEC axis (1 or 2) +define FC_LONGP Memd[P2D($1+FCU+2)] # LONGPOLE (rads) +define FC_COLATP Memd[P2D($1+FCU+4)] # (90 - DEC) (rads) +define FC_COSLATP Memd[P2D($1+FCU+6)] # cosine (90 - DEC) +define FC_SINLATP Memd[P2D($1+FCU+8)] # sine (90 - DEC) +define FC_SPHTOL Memd[P2D($1+FCU+10)] # trig tolerance +define FC_RODEG Memd[P2D($1+FCU+12)] # RO (degs) +define FC_2RODEG Memd[P2D($1+FCU+14)] # 2 * RO (degs) +define FC_REC2RODEG Memd[P2D($1+FCU+16)] # 1 / 2 * RO (degs) +define FC_BADCVAL Memd[P2D($1+FCU+18)] # bad coordinate value +define FC_W Memd[P2D($1+FCU+20)+($2)-1] # CRVAL (axis 1 and 2) + + +# WF_ZEA_INIT -- Initialize the zenithal equal area forward or inverse +# transform. Initialization for this transformation consists of, determining +# which axis is RA / LON and which is DEC / LAT, computing the celestial +# longitude and colatitude of the native pole, reading in the the native +# longitude of the pole of the celestial coordinate system LONGPOLE from the +# attribute list, precomputing the Euler angles and intermediary functions +# of the reference point, and reading in the projection parameter RO from the +# attribute list. If LONGPOLE is undefined then a value of 180.0 degrees is +# assumed. If RO is undefined a value of 180.0 / PI is assumed. In order to +# determine the axis order, the parameter "axtype={ra|dec}{xlon|xlat}" must +# have been set in the attribute list for the function. The LONGPOLE and RO +# parameters may be set in either or both of the axes attribute lists, but +# the value in the RA axis attribute list takes precedence. + +procedure wf_zea_init (fc, dir) + +pointer fc #I pointer to FC descriptor +int dir #I direction of transform + +int i +double dec +pointer sp, atvalue, ct, mw, wp, wv +int ctod() +errchk wf_decaxis(), mw_gwattrs() + +begin + # Allocate space for the attribute string. + call smark (sp) + call salloc (atvalue, SZ_LINE, TY_CHAR) + + # Get the required mwcs pointers. + ct = FC_CT(fc) + mw = CT_MW(ct) + wp = FC_WCS(fc) + + # Determine which is the DEC axis, and hence the axis order. + call wf_decaxis (fc, FC_IRA(fc), FC_IDEC(fc)) + + # Get the value of W for each axis, i.e. the world coordinates at + # the reference point. + + wv = MI_DBUF(mw) + WCS_W(wp) - 1 + do i = 1, 2 + FC_W(fc,i) = Memd[wv+CT_AXIS(ct,FC_AXIS(fc,i))-1] + + # Get the celestial coordinates of the native pole which are in + # this case the ra and 90 - dec of the reference point. + + dec = DDEGTORAD(90.0d0 - FC_W(fc,FC_IDEC(fc))) + + # Determine the native longitude of the pole of the celestial + # coordinate system corresponding to the FITS keyword LONGPOLE. + # This number has no default and should normally be set to 180 + # degrees. Search both axes for this quantity. + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "longpole", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "longpole", Memc[atvalue], + SZ_LINE) + } then { + FC_LONGP(fc) = 180.0d0 + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_LONGP(fc)) <= 0) + FC_LONGP(fc) = 180.0d0 + if (IS_INDEFD(FC_LONGP(fc))) + FC_LONGP(fc) = 180.0d0 + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_LONGP(fc)) <= 0) + FC_LONGP(fc) = 180.0d0 + if (IS_INDEFD(FC_LONGP(fc))) + FC_LONGP(fc) = 180.0d0 + } + FC_LONGP(fc) = DDEGTORAD(FC_LONGP(fc)) + + # Precompute the trigomometric functions used by the spherical geometry + # code to improve efficiency. + + FC_COLATP(fc) = dec + FC_COSLATP(fc) = cos(dec) + FC_SINLATP(fc) = sin(dec) + + # Fetch the RO projection parameter which is the radius of the + # generating sphere for the projection. If RO is absent which + # is the usual case set it to 180 / PI. Search both axes for + # this quantity. + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "ro", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "ro", Memc[atvalue], + SZ_LINE) + } then { + FC_RODEG(fc) = 180.0d0 / DPI + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_RODEG(fc)) <= 0) + FC_RODEG(fc) = 180.0d0 / DPI + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_RODEG(fc)) <= 0) + FC_RODEG(fc) = 180.0d0 / DPI + } + FC_2RODEG(fc) = 2.0d0 * FC_RODEG(fc) + FC_REC2RODEG(fc) = 1.0d0 / FC_2RODEG(fc) + + # Set the bad coordinate value. + FC_SPHTOL(fc) = 1.0d-5 + + # Set the bad coordinate value. + FC_BADCVAL(fc) = INDEFD + + # Free working space. + call sfree (sp) +end + + +# WF_ZEA_FWD -- Forward transform (physical to world) for the zenithal +# equal area projection. + +procedure wf_zea_fwd (fc, p, w) + +pointer fc #I pointer to FC descriptor +double p[2] #I physical coordinates (x, y) +double w[2] #O world coordinates (ra, dec) + +int ira, idec +double x, y, r, phi, theta, costhe, sinthe, dphi, cosphi, sinphi, ra, dec, tol +double dlng, z +data tol /1.0d-12/ + +begin + # Get the axis numbers. + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + # Compute native spherical coordinates PHI and THETA in degrees from + # the projected coordinates. This is the projection part of the + # computation. + + x = p[ira] + y = p[idec] + r = sqrt (x * x + y * y) + + # Compute PHI. + if (r == 0.0d0) + phi = 0.0d0 + else + phi = atan2 (x, -y) + + # Compute THETA. + if (abs (r - FC_2RODEG(fc)) < tol) + theta = -DHALFPI + else + theta = DHALFPI - 2.0d0 * asin (r * FC_REC2RODEG(fc)) + + # Compute the celestial coordinates RA and DEC from the native + # coordinates PHI and THETA. This is the spherical geometry part + # of the computation. + + costhe = cos (theta) + sinthe = sin (theta) + dphi = phi - FC_LONGP(fc) + cosphi = cos (dphi) + sinphi = sin (dphi) + + # Compute the RA. + x = sinthe * FC_SINLATP(fc) - costhe * FC_COSLATP(fc) * cosphi + if (abs (x) < FC_SPHTOL(fc)) + x = -cos (theta + FC_COLATP(fc)) + costhe * FC_COSLATP(fc) * + (1.0d0 - cosphi) + y = -costhe * sinphi + if (x != 0.0d0 || y != 0.0d0) { + dlng = atan2 (y, x) + } else { + dlng = dphi + DPI + } + ra = FC_W(fc,ira) + DRADTODEG(dlng) + + # Normalize the RA. + if (FC_W(fc,ira) >= 0.0d0) { + if (ra < 0.0d0) + ra = ra + 360.0d0 + } else { + if (ra > 0.0d0) + ra = ra - 360.0d0 + } + if (ra > 360.0d0) + ra = ra - 360.0d0 + else if (ra < -360.0d0) + ra = ra + 360.0d0 + + # Compute the DEC. + if (mod (dphi, DPI) == 0.0d0) { + dec = DRADTODEG(theta + cosphi * FC_COLATP(fc)) + if (dec > 90.0d0) + dec = 180.0d0 - dec + if (dec < -90.0d0) + dec = -180.0d0 - dec + } else { + z = sinthe * FC_COSLATP(fc) + costhe * FC_SINLATP(fc) * cosphi + if (abs(z) > 0.99d0) { + if (z >= 0.0d0) + dec = DRADTODEG(acos (sqrt(x * x + y * y))) + else + dec = DRADTODEG(-acos (sqrt(x * x + y * y))) + } else + dec = DRADTODEG(asin (z)) + } + + # Store the results. + w[ira] = ra + w[idec] = dec +end + + +# WF_ZEA_INV -- Inverse transform (world to physical) for the zenithal +# equal area projection. + +procedure wf_zea_inv (fc, w, p) + +pointer fc #I pointer to FC descriptor +double w[2] #I input world (RA, DEC) coordinates +double p[2] #I output physical coordinates + +int ira, idec +double ra, dec, cosdec, sindec, cosra, sinra, x, y, phi, theta, r, dphi, z + +begin + # Get the axes numbers. + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + # Compute the transformation from celestial coordinates RA and + # DEC to native coordinates PHI and THETA. This is the spherical + # geometry part of the transformation. + + ra = DDEGTORAD (w[ira] - FC_W(fc,ira)) + dec = DDEGTORAD (w[idec]) + cosra = cos (ra) + sinra = sin (ra) + cosdec = cos (dec) + sindec = sin (dec) + + # Compute PHI. + x = sindec * FC_SINLATP(fc) - cosdec * FC_COSLATP(fc) * cosra + if (abs(x) < FC_SPHTOL(fc)) + x = -cos (dec + FC_COLATP(fc)) + cosdec * FC_COSLATP(fc) * + (1.0d0 - cosra) + y = -cosdec * sinra + if (x != 0.0d0 || y != 0.0d0) + dphi = atan2 (y, x) + else + dphi = ra - DPI + phi = FC_LONGP(fc) + dphi + if (phi > DPI) + phi = phi - DTWOPI + else if (phi < -DPI) + phi = phi + DTWOPI + + # Compute THETA. + if (mod (ra, DPI) ==0.0) { + theta = dec + cosra * FC_COLATP(fc) + if (theta > DHALFPI) + theta = DPI - theta + if (theta < -DHALFPI) + theta = -DPI - theta + } else { + z = sindec * FC_COSLATP(fc) + cosdec * FC_SINLATP(fc) * cosra + if (abs (z) > 0.99d0) { + if (z >= 0.0) + theta = acos (sqrt(x * x + y * y)) + else + theta = -acos (sqrt(x * x + y * y)) + } else + theta = asin (z) + } + + # Compute the transformation from native coordinates PHI and THETA + # to projected coordinates X and Y. + + r = FC_2RODEG(fc) * sin ((DHALFPI - theta) / 2.0d0) + p[ira] = r * sin (phi) + p[idec] = -r * cos (phi) +end diff --git a/sys/mwcs/wfzpn.x b/sys/mwcs/wfzpn.x new file mode 100644 index 00000000..6c8db38a --- /dev/null +++ b/sys/mwcs/wfzpn.x @@ -0,0 +1,600 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "imwcs.h" +include "mwcs.h" + +.help WFZPN +.nf ------------------------------------------------------------------------- +# WFZPN -- WCS function driver for the zenithal / azimuthal polynomial +# projection. + +Driver routines: + + FN_INIT wf_zpn_init (fc, dir) + FN_DESTROY wf_zpn_destroy (fc) + FN_FWD wf_zpn_fwd (fc, v1, v2) + FN_INV wf_zpn_inv (fc, v1, v2) + +.endhelp -------------------------------------------------------------------- + +define MAX_NITER 20 + +# Driver specific fields of function call (FC) descriptor. +define FC_LNGCOR Memi[$1+FCU] # RA axis correction +define FC_LATCOR Memi[$1+FCU+1] # DEC axis correction +define FC_IRA Memi[$1+FCU+2] # RA axis (1 or 2) +define FC_IDEC Memi[$1+FCU+3] # DEC axis (1 or 2) +define FC_NP Memd[P2D($1+FCU+4)] # poly order (0-9) +define FC_LONGP Memd[P2D($1+FCU+6)] # LONGPOLE (rads) +define FC_COLATP Memd[P2D($1+FCU+8)] # (90 - DEC) (rads) +define FC_COSLATP Memd[P2D($1+FCU+10)] # cosine (90 - DEC) +define FC_SINLATP Memd[P2D($1+FCU+12)] # sine (90 - DEC) +define FC_SPHTOL Memd[P2D($1+FCU+14)] # trig tolerance +define FC_PC Memd[P2D($1+FCU+16)+($2)] # poly coefficients (9) +define FC_RODEG Memd[P2D($1+FCU+36)] # RO (degs) +define FC_ZD Memd[P2D($1+FCU+38)] # colat of FIP (degs) +define FC_R Memd[P2D($1+FCU+40)] # radius of FIP (degs) +define FC_BADCVAL Memd[P2D($1+FCU+42)] # Bad coordinate value +define FC_W Memd[P2D($1+FCU+44)+($2)-1] # CRVAL (axis 1 and 2) + + +# WF_ZPN_INIT -- Initialize the zenithal/azimuthal polynomial forward or inverse +# transform. Initialization for this transformation consists of, determining +# which axis is RA / LON and which is DEC / LAT, computing the celestial +# longitude and colatitude of the native pole, reading in the the native +# longitude of the pole of the celestial coordinate system LONGPOLE from the +# attribute list, precomputing the Euler angles and various intermediary +# functions of the reference coordinates, reading in the projection parameter +# RO from the attribute list, reading in up to ten polynomial coefficients, +# and, for polynomial orders greater than 2 computing the colatitude and radius +# of the first point of inflection. If LONGPOLE is undefined then a value of +# 180.0 degrees is assumed. If RO is undefined a value of 180.0 / PI is +# assumed. If the polynomial coefficients are all zero then an error condition +# is posted. If the order of the polynomial is 2 or greater and there is no +# point of inflection an error condition is posted. The ZPN projection with +# an order of 1 and 0th and 1st coefficients of 0.0 and 1.0 respectively is +# equivalent to the ARC projtection. In order to determine the axis order, +# the parameter "axtype={ra|dec} {xlon|xlat}" must have been set in the +# attribute list for the function. The LONGPOLE and RO parameters may be set +# in either or both of the axes attribute lists, but the value in the RA axis +# attribute list takes precedence. + +procedure wf_zpn_init (fc, dir) + +pointer fc #I pointer to FC descriptor +int dir #I direction of transform + +int i, j, np, szatstr, maxorder, ualen, index, ip +double dec, zd1, d1, zd2, d2, zd, d, r, tol, dval +pointer sp, atname, atvalue, ct, mw, wp, wv, im, idb, rp +char compare[4] +bool match +int ctod(), strlen(), idb_nextcard(), itoc() +pointer wf_gsopen(), idb_open() +data tol/1.0d-13/ +errchk wf_decaxis(), mw_gwattrs() + +begin + # Allocate space for the attribute string. + call smark (sp) + call salloc (atname, SZ_ATNAME, TY_CHAR) + call salloc (atvalue, SZ_LINE, TY_CHAR) + + # Get the required mwcs pointers. + ct = FC_CT(fc) + mw = CT_MW(ct) + wp = FC_WCS(fc) + im = MI_REFIM(mw) + + # Determine which is the DEC axis, and hence the axis order. + call wf_decaxis (fc, FC_IRA(fc), FC_IDEC(fc)) + + # Get the value of W for each axis, i.e. the world coordinates at + # the reference point. + + wv = MI_DBUF(mw) + WCS_W(wp) - 1 + do i = 1, 2 + FC_W(fc,i) = Memd[wv+CT_AXIS(ct,FC_AXIS(fc,i))-1] + + # Get the celestial coordinates of the native pole which are in + # this case the ra and 90 - dec of the reference point. + + dec = DDEGTORAD(90.0d0 - FC_W(fc,FC_IDEC(fc))) + + # Determine the native longitude of the pole of the celestial + # coordinate system corresponding to the FITS keyword LONGPOLE. + # This number has no default and should normally be set to 180 + # degrees. Search both axes for this quantity. + + FC_LONGP(fc) = DDEGTORAD(180.0d0) + + # Precompute the trigomometric functions used by the spherical geometry + # code to improve efficiency. + + FC_COLATP(fc) = dec + FC_COSLATP(fc) = cos(dec) + FC_SINLATP(fc) = sin(dec) + + # Fetch the RO projection parameter which is the radius of the + # generating sphere for the projection. If RO is absent which + # is the usual case set it to 180 / PI. Search both axes for + # this quantity. + + FC_RODEG(fc) = 180.0d0/DPI + szatstr = SZ_LINE + + # Fetch the longitude correction surface. Note that the attribute + # string may be of any length so the length of atvalue may have + # to be adjusted. + + FC_LNGCOR(fc) = NULL + + # Fetch the latitude correction surface. Note that the attribute + # string may be of any length so the length of atvalue may have + # to be adjusted. + + FC_LATCOR(fc) = NULL + + # Read through the fits header once more and pick up the PV matrix + # cards. Read the values and store them, keeping track of what is + # the highest order coefficient. With this projection only the dec + # axis coefficients matter. Technically we can have up to 99 + # coefficients. But we restrict this to 10 for the moment. + + maxorder = -1 + idb = idb_open(im,ualen) + compare[1] = 'P' + compare[2] = 'V' + i = itoc(FC_IDEC(fc),compare[3],1) + compare[4] = '_' + while (idb_nextcard(idb,rp) != EOF) { + match = true + do i = 0,3 { + if (Memc[rp+i] != compare[i+1]) { + match = false + break; + } + } + if (! match) + next + if (! IS_DIGIT(Memc[rp+4])) + next + index = TO_INTEG(Memc[rp+4]) + do i = 5,7 { + if (! IS_DIGIT(Memc[rp+i])) + break + else + index = 10*index + TO_INTEG(Memc[rp+i]) + } + if (index > 9) + next + ip = IDB_STARTVALUE + if (ctod(Memc[rp],ip,dval) <= 0) + dval = 0.0d0 + if (index > maxorder) + maxorder = index + FC_PC(fc,index) = dval + } + call idb_close(idb) + + # If all the coefficients are 0.0 the polynomial is undefined. + if (maxorder < 0) { + call sfree (sp) + call error (0, "WFT_ZPN_INIT: The polynomial is undefined") + } + + # Determine the number of coefficients. + FC_NP(fc) = double(maxorder) + np = maxorder + + if (np >= 3) { + # Find the point of inflection closest to the pole. + zd1 = 0.0d0 + d1 = FC_PC(fc,1) + if (d1 <= 0.0d0) { + call sfree (sp) + call error (0, + "WFT_ZPN_INIT: The point of inflection does not exist") + } + + # Find the point where the derivative first goes negative. + do i = 1, 180 { + zd2 = DPI * double (i) / 180.0d0 + d2 = 0.0d0 + do j = np, 1, -1 + d2 = d2 * zd2 + j * FC_PC(fc,j) + if (d2 <= 0.0d0) + break + zd1 = zd2 + d1 = d2 + } + + # Find where the derivative is 0. + if (d2 <= 0.0d0) { + do i = 1, 10 { + zd = zd1 - d1 * (zd2 - zd1) / (d2 - d1) + d = 0.0d0 + do j = np, 1, -1 + d = d * zd + j * FC_PC(fc,j) + if (abs(d) < tol) + break + if (d < 0.0d0) { + zd2 = zd + d2 = d + } else { + zd1 = zd + d1 = d + } + } + + # No negative derivative. + } else + zd = DPI + + r = 0.0d0 + do j = np, 0, -1 + r = r * zd + FC_PC(fc,j) + FC_ZD(fc) = zd + FC_R(fc) = r + } + + # Set the spherical trigonometric tolerance. + FC_SPHTOL(fc) = 1.0d-5 + + # Set the bad coordinate value. + FC_BADCVAL(fc) = INDEFD + + # Free working space. + call sfree (sp) + +end + + +# WF_ZPN_FWD -- Forward transform (physical to world) for the zenithal / +# azimuthal polynomial projection. + +procedure wf_zpn_fwd (fc, p, w) + +pointer fc #I pointer to FC descriptor +double p[2] #I physical coordinates (x, y) +double w[2] #O world coordinates (ra, dec) + +int ira, idec, i, j, k +double x, y, r, zd, a, b, c, d, zd1, zd2, r1, r2, lambda, rt, tol +double phi, theta, costhe, sinthe, dphi, cosphi, sinphi, ra, dec, dlng, z +double wf_gseval() +data tol/1.0d-13/ + +define phitheta_ 11 + +begin + # Get the axis numbers. + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + # Compute native spherical coordinates PHI and THETA in degrees from + # the projected coordinates. This is the projection part of the + # computation. + + k = nint (FC_NP(fc)) + if (FC_LNGCOR(fc) == NULL) + x = p[ira] + else + x = p[ira] + wf_gseval (FC_LNGCOR(fc), p[ira], p[idec]) + if (FC_LATCOR(fc) == NULL) + y = p[idec] + else + y = p[idec] + wf_gseval (FC_LATCOR(fc), p[ira], p[idec]) + r = sqrt (x * x + y * y) / FC_RODEG(fc) + + # Solve. + + # Constant no solution + if (k < 1) { + w[ira] = FC_BADCVAL(fc) + w[idec] = FC_BADCVAL(fc) + return + + # Linear. + } else if (k == 1) { + zd = (r - FC_PC(fc,0)) / FC_PC(fc,1) + + # Quadratic. + } else if (k == 2) { + + a = FC_PC(fc,2) + b = FC_PC(fc,1) + c = FC_PC(fc,0) - r + d = b * b - 4.0d0 * a * c + if (d < 0.0d0) { + w[ira] = FC_BADCVAL(fc) + w[idec] = FC_BADCVAL(fc) + return + } + d = sqrt (d) + + # Choose solution closet to the pole. + zd1 = (-b + d) / (2.0d0 * a) + zd2 = (-b - d) / (2.0d0 * a) + zd = min (zd1, zd2) + if (zd < -tol) + zd = max (zd1, zd2) + if (zd < 0.0d0) { + if (zd < -tol) { + w[ira] = FC_BADCVAL(fc) + w[idec] = FC_BADCVAL(fc) + return + } + zd = 0.0d0 + } else if (zd > DPI) { + if (zd > (DPI + tol)) { + w[ira] = FC_BADCVAL(fc) + w[idec] = FC_BADCVAL(fc) + return + } + zd = DPI + } + + # Higher order solve iteratively. + } else { + + zd1 = 0.0d0 + r1 = FC_PC(fc,0) + zd2 = FC_ZD(fc) + r2 = FC_R(fc) + + if (r < r1) { + if (r < (r1 - tol)) { + w[ira] = FC_BADCVAL(fc) + w[idec] = FC_BADCVAL(fc) + return + } + zd = zd1 + goto phitheta_ + } else if (r > r2) { + if (r > (r2 + tol)) { + w[ira] = FC_BADCVAL(fc) + w[idec] = FC_BADCVAL(fc) + return + } + zd = zd2 + goto phitheta_ + } else { + do j = 1, 100 { + lambda = (r2 - r) / (r2 - r1) + if (lambda < 0.1d0) + lambda = 0.1d0 + else if (lambda > 0.9d0) + lambda = 0.9d0 + zd = zd2 - lambda * (zd2 - zd1) + rt = 0.0d0 + do i = k, 0, -1 + rt = (rt * zd) + FC_PC(fc,i) + if (rt < r) { + if ((r - rt) < tol) + goto phitheta_ + r1 = rt + zd1 = zd + } else { + if ((rt - r) < tol) + goto phitheta_ + r2 = rt + zd2 = zd + } + if (abs(zd2 - zd1) < tol) + goto phitheta_ + } + } + + } + +phitheta_ + + # Compute PHI. + if (r == 0.0d0) + phi = 0.0d0 + else + phi = atan2 (x, -y) + + # Compute THETA. + theta = DHALFPI - zd + + # Compute the celestial coordinates RA and DEC from the native + # coordinates PHI and THETA. This is the spherical geometry part + # of the computation. + + costhe = cos (theta) + sinthe = sin (theta) + dphi = phi - FC_LONGP(fc) + cosphi = cos (dphi) + sinphi = sin (dphi) + + # Compute the RA. + x = sinthe * FC_SINLATP(fc) - costhe * FC_COSLATP(fc) * cosphi + if (abs (x) < FC_SPHTOL(fc)) + x = -cos (theta + FC_COLATP(fc)) + costhe * FC_COSLATP(fc) * + (1.0d0 - cosphi) + y = -costhe * sinphi + if (x != 0.0d0 || y != 0.0d0) { + dlng = atan2 (y, x) + } else { + dlng = dphi + DPI + } + ra = FC_W(fc,ira) + DRADTODEG(dlng) + + # Normalize the RA. + if (FC_W(fc,ira) >= 0.0d0) { + if (ra < 0.0d0) + ra = ra + 360.0d0 + } else { + if (ra > 0.0d0) + ra = ra - 360.0d0 + } + if (ra > 360.0d0) + ra = ra - 360.0d0 + else if (ra < -360.0d0) + ra = ra + 360.0d0 + + # Compute the DEC. + if (mod (dphi, DPI) == 0.0d0) { + dec = DRADTODEG(theta + cosphi * FC_COLATP(fc)) + if (dec > 90.0d0) + dec = 180.0d0 - dec + if (dec < -90.0d0) + dec = -180.0d0 - dec + } else { + z = sinthe * FC_COSLATP(fc) + costhe * FC_SINLATP(fc) * cosphi + if (abs(z) > 0.99d0) { + if (z >= 0.0d0) + dec = DRADTODEG(acos (sqrt(x * x + y * y))) + else + dec = DRADTODEG(-acos (sqrt(x * x + y * y))) + } else + dec = DRADTODEG(asin (z)) + } + + # Store the results. + w[ira] = ra + w[idec] = dec +end + + +# WF_ZPN_INV -- Inverse transform (world to physical) for the zenithal / +# azimuthal polynomial projection. + +procedure wf_zpn_inv (fc, w, p) + +pointer fc #I pointer to FC descriptor +double w[2] #I input world (RA, DEC) coordinates +double p[2] #I output physical coordinates + +int ira, idec, i, niter +double ra, dec, cosdec, sindec, cosra, sinra, x, y, phi, theta, s, r, dphi, z +double xm, ym, f, fx, fy, g, gx, gy, denom, dx, dy +double wf_gseval(), wf_gsder() + +begin + # Get the axes numbers. + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + # Compute the transformation from celestial coordinates RA and + # DEC to native coordinates PHI and THETA. This is the spherical + # geometry part of the transformation. + + ra = DDEGTORAD (w[ira] - FC_W(fc,ira)) + dec = DDEGTORAD (w[idec]) + cosra = cos (ra) + sinra = sin (ra) + cosdec = cos (dec) + sindec = sin (dec) + + # Compute PHI. + x = sindec * FC_SINLATP(fc) - cosdec * FC_COSLATP(fc) * cosra + if (abs(x) < FC_SPHTOL(fc)) + x = -cos (dec + FC_COLATP(fc)) + cosdec * FC_COSLATP(fc) * + (1.0d0 - cosra) + y = -cosdec * sinra + if (x != 0.0d0 || y != 0.0d0) + dphi = atan2 (y, x) + else + dphi = ra - DPI + phi = FC_LONGP(fc) + dphi + if (phi > DPI) + phi = phi - DTWOPI + else if (phi < -DPI) + phi = phi + DTWOPI + + # Compute THETA. + if (mod (ra, DPI) ==0.0) { + theta = dec + cosra * FC_COLATP(fc) + if (theta > DHALFPI) + theta = DPI - theta + if (theta < -DHALFPI) + theta = -DPI - theta + } else { + z = sindec * FC_COSLATP(fc) + cosdec * FC_SINLATP(fc) * cosra + if (abs (z) > 0.99d0) { + if (z >= 0.0) + theta = acos (sqrt(x * x + y * y)) + else + theta = -acos (sqrt(x * x + y * y)) + } else + theta = asin (z) + } + + # Compute the transformation from native coordinates PHI and THETA + # to projected coordinates X and Y. + + s = DHALFPI - theta + r = 0.0d0 + do i = 9, 0, -1 + r = r * s + FC_PC(fc,i) + r = FC_RODEG(fc) * r + + if (FC_LNGCOR(fc) == NULL && FC_LATCOR(fc) == NULL) { + p[ira] = r * sin (phi) + p[idec] = -r * cos (phi) + + } else { + xm = r * sin (phi) + ym = -r * cos (phi) + x = xm + y = ym + niter = 0 + + repeat { + if (FC_LNGCOR(fc) != NULL) { + f = x + wf_gseval (FC_LNGCOR(fc), x, y) - xm + fx = wf_gsder (FC_LNGCOR(fc), x, y, 1, 0) + fx = 1.0 + fx + fy = wf_gsder (FC_LNGCOR(fc), x, y, 0, 1) + } else { + f = x - xm + fx = 1.0 + fy = 0.0 + } + if (FC_LATCOR(fc) != NULL) { + g = y + wf_gseval (FC_LATCOR(fc), x, y) - ym + gx = wf_gsder (FC_LATCOR(fc), x, y, 1, 0) + gy = wf_gsder (FC_LATCOR(fc), x, y, 0, 1) + gy = 1.0 + gy + } else { + g = y - ym + gx = 0.0 + gy = 1.0 + } + denom = fx * gy - fy * gx + if (denom == 0.0d0) + break + dx = (-f * gy + g * fy) / denom + dy = (-g * fx + f * gx) / denom + x = x + max (-1.0D0, min (1.0D0, dx)) + y = y + max (-1.0D0, min (1.0D0, dy)) + if (max (abs (dx), abs (dy), abs(f), abs(g)) < 2.80d-7) + break + + niter = niter + 1 + + } until (niter >= MAX_NITER) + + p[ira] = x + p[idec] = y + } +end + + +# WF_ZPN_DESTROY -- Free up the distortion surface pointers. + +procedure wf_zpn_destroy (fc) + +pointer fc #I pointer to the FC descriptor + +begin + if (FC_LNGCOR(fc) != NULL) + call wf_gsclose (FC_LNGCOR(fc)) + if (FC_LATCOR(fc) != NULL) + call wf_gsclose (FC_LATCOR(fc)) +end diff --git a/sys/mwcs/wfzpx.x b/sys/mwcs/wfzpx.x new file mode 100644 index 00000000..c5eced4a --- /dev/null +++ b/sys/mwcs/wfzpx.x @@ -0,0 +1,654 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mwcs.h" + +.help WFZPX +.nf ------------------------------------------------------------------------- +# WFZPX -- WCS function driver for the zenithal / azimuthal polynomial +# projection. + +Driver routines: + + FN_INIT wf_zpx_init (fc, dir) + FN_DESTROY wf_zpx_destroy (fc) + FN_FWD wf_zpx_fwd (fc, v1, v2) + FN_INV wf_zpx_inv (fc, v1, v2) + +.endhelp -------------------------------------------------------------------- + +define MAX_NITER 20 + +# Driver specific fields of function call (FC) descriptor. +define FC_LNGCOR Memi[$1+FCU] # RA axis correction +define FC_LATCOR Memi[$1+FCU+1] # DEC axis correction +define FC_IRA Memi[$1+FCU+2] # RA axis (1 or 2) +define FC_IDEC Memi[$1+FCU+3] # DEC axis (1 or 2) +define FC_NP Memd[P2D($1+FCU+4)] # poly order (0-9) +define FC_LONGP Memd[P2D($1+FCU+6)] # LONGPOLE (rads) +define FC_COLATP Memd[P2D($1+FCU+8)] # (90 - DEC) (rads) +define FC_COSLATP Memd[P2D($1+FCU+10)] # cosine (90 - DEC) +define FC_SINLATP Memd[P2D($1+FCU+12)] # sine (90 - DEC) +define FC_SPHTOL Memd[P2D($1+FCU+14)] # trig tolerance +define FC_PC Memd[P2D($1+FCU+16)+($2)] # poly coefficients (9) +define FC_RODEG Memd[P2D($1+FCU+36)] # RO (degs) +define FC_ZD Memd[P2D($1+FCU+38)] # colat of FIP (degs) +define FC_R Memd[P2D($1+FCU+40)] # radius of FIP (degs) +define FC_BADCVAL Memd[P2D($1+FCU+42)] # Bad coordinate value +define FC_W Memd[P2D($1+FCU+44)+($2)-1] # CRVAL (axis 1 and 2) + + +# WF_ZPX_INIT -- Initialize the zenithal/azimuthal polynomial forward or inverse +# transform. Initialization for this transformation consists of, determining +# which axis is RA / LON and which is DEC / LAT, computing the celestial +# longitude and colatitude of the native pole, reading in the the native +# longitude of the pole of the celestial coordinate system LONGPOLE from the +# attribute list, precomputing the Euler angles and various intermediary +# functions of the reference coordinates, reading in the projection parameter +# RO from the attribute list, reading in up to ten polynomial coefficients, +# and, for polynomial orders greater than 2 computing the colatitude and radius +# of the first point of inflection. If LONGPOLE is undefined then a value of +# 180.0 degrees is assumed. If RO is undefined a value of 180.0 / PI is +# assumed. If the polynomial coefficients are all zero then an error condition +# is posted. If the order of the polynomial is 2 or greater and there is no +# point of inflection an error condition is posted. The ZPX projection with +# an order of 1 and 0th and 1st coefficients of 0.0 and 1.0 respectively is +# equivalent to the ARC projtection. In order to determine the axis order, +# the parameter "axtype={ra|dec} {xlon|xlat}" must have been set in the +# attribute list for the function. The LONGPOLE and RO parameters may be set +# in either or both of the axes attribute lists, but the value in the RA axis +# attribute list takes precedence. + +procedure wf_zpx_init (fc, dir) + +pointer fc #I pointer to FC descriptor +int dir #I direction of transform + +int i, j, np, szatstr +double dec, zd1, d1, zd2, d2, zd, d, r, tol +pointer sp, atname, atvalue, ct, mw, wp, wv +int ctod(), strlen() +pointer wf_gsopen() +data tol/1.0d-13/ +errchk wf_decaxis(), mw_gwattrs() + +begin + # Allocate space for the attribute string. + call smark (sp) + call salloc (atname, SZ_ATNAME, TY_CHAR) + call salloc (atvalue, SZ_LINE, TY_CHAR) + + # Get the required mwcs pointers. + ct = FC_CT(fc) + mw = CT_MW(ct) + wp = FC_WCS(fc) + + # Determine which is the DEC axis, and hence the axis order. + call wf_decaxis (fc, FC_IRA(fc), FC_IDEC(fc)) + + # Get the value of W for each axis, i.e. the world coordinates at + # the reference point. + + wv = MI_DBUF(mw) + WCS_W(wp) - 1 + do i = 1, 2 + FC_W(fc,i) = Memd[wv+CT_AXIS(ct,FC_AXIS(fc,i))-1] + + # Get the celestial coordinates of the native pole which are in + # this case the ra and 90 - dec of the reference point. + + dec = DDEGTORAD(90.0d0 - FC_W(fc,FC_IDEC(fc))) + + # Determine the native longitude of the pole of the celestial + # coordinate system corresponding to the FITS keyword LONGPOLE. + # This number has no default and should normally be set to 180 + # degrees. Search both axes for this quantity. + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "longpole", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "longpole", Memc[atvalue], + SZ_LINE) + } then { + FC_LONGP(fc) = 180.0d0 + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_LONGP(fc)) <= 0) + FC_LONGP(fc) = 180.0d0 + if (IS_INDEFD(FC_LONGP(fc))) + FC_LONGP(fc) = 180.0d0 + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_LONGP(fc)) <= 0) + FC_LONGP(fc) = 180.0d0 + if (IS_INDEFD(FC_LONGP(fc))) + FC_LONGP(fc) = 180.0d0 + } + FC_LONGP(fc) = DDEGTORAD(FC_LONGP(fc)) + + # Precompute the trigomometric functions used by the spherical geometry + # code to improve efficiency. + + FC_COLATP(fc) = dec + FC_COSLATP(fc) = cos(dec) + FC_SINLATP(fc) = sin(dec) + + # Fetch the RO projection parameter which is the radius of the + # generating sphere for the projection. If RO is absent which + # is the usual case set it to 180 / PI. Search both axes for + # this quantity. + + iferr { + call mw_gwattrs (mw, FC_IRA(fc), "ro", Memc[atvalue], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), "ro", Memc[atvalue], + SZ_LINE) + } then { + FC_RODEG(fc) = 180.0d0 / DPI + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_RODEG(fc)) <= 0) + FC_RODEG(fc) = 180.0d0 / DPI + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_RODEG(fc)) <= 0) + FC_RODEG(fc) = 180.0d0 / DPI + } + + szatstr = SZ_LINE + + # Fetch the longitude correction surface. Note that the attribute + # string may be of any length so the length of atvalue may have + # to be adjusted. + + iferr { + repeat { + call mw_gwattrs (mw, FC_IRA(fc), "lngcor", Memc[atvalue], + szatstr) + if (strlen (Memc[atvalue]) < szatstr) + break + szatstr = szatstr + SZ_LINE + call realloc (atvalue, szatstr, TY_CHAR) + + } + } then { + FC_LNGCOR(fc) = NULL + } else { + FC_LNGCOR(fc) = wf_gsopen (Memc[atvalue]) + } + + # Fetch the latitude correction surface. Note that the attribute + # string may be of any length so the length of atvalue may have + # to be adjusted. + + iferr { + repeat { + call mw_gwattrs (mw, FC_IDEC(fc), "latcor", Memc[atvalue], + szatstr) + if (strlen (Memc[atvalue]) < szatstr) + break + szatstr = szatstr + SZ_LINE + call realloc (atvalue, szatstr, TY_CHAR) + } + } then { + FC_LATCOR(fc) = NULL + } else { + FC_LATCOR(fc) = wf_gsopen (Memc[atvalue]) + } + + # Fetch the projection coefficients + do j = 0, 9 { + call sprintf (Memc[atname], SZ_ATNAME, "projp%d") + call pargi (j) + iferr { + call mw_gwattrs (mw, FC_IRA(fc), Memc[atname], Memc[atvalue], + SZ_LINE) + } then { + iferr { + call mw_gwattrs (mw, FC_IDEC(fc), Memc[atname], + Memc[atvalue], SZ_LINE) + } then { + FC_PC(fc,j) = 0.0d0 + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_PC(fc,j)) <= 0) + FC_PC(fc,j) = 0.0d0 + } + } else { + i = 1 + if (ctod (Memc[atvalue], i, FC_PC(fc,j)) <= 0) + FC_PC(fc,j) = 0.0d0 + } + } + + # Determine the order of the polynomial by finding the first + # non-zero coefficient. + + do j = 9, 0, -1 { + if (FC_PC(fc,j) != 0.0d0) + break + } + + # If all the coefficients are 0.0 the polynomial is undefined. + if (j < 0) { + call sfree (sp) + call error (0, "WFT_ZPX_INIT: The polynomial is undefined") + } + + # Determine the number of coefficients. + FC_NP(fc) = double (j) + np = j + + if (np >= 3) { + # Find the point of inflection closest to the pole. + zd1 = 0.0d0 + d1 = FC_PC(fc,1) + if (d1 <= 0.0d0) { + call sfree (sp) + call error (0, + "WFT_ZPX_INIT: The point of inflection does not exist") + } + + # Find the point where the derivative first goes negative. + do i = 1, 180 { + zd2 = DPI * double (i) / 180.0d0 + d2 = 0.0d0 + do j = np, 1, -1 + d2 = d2 * zd2 + j * FC_PC(fc,j) + if (d2 <= 0.0d0) + break + zd1 = zd2 + d1 = d2 + } + + # Find where the derivative is 0. + if (d2 <= 0.0d0) { + do i = 1, 10 { + zd = zd1 - d1 * (zd2 - zd1) / (d2 - d1) + d = 0.0d0 + do j = np, 1, -1 + d = d * zd + j * FC_PC(fc,j) + if (abs(d) < tol) + break + if (d < 0.0d0) { + zd2 = zd + d2 = d + } else { + zd1 = zd + d1 = d + } + } + + # No negative derivative. + } else + zd = DPI + + r = 0.0d0 + do j = np, 0, -1 + r = r * zd + FC_PC(fc,j) + FC_ZD(fc) = zd + FC_R(fc) = r + } + + # Set the spherical trigonometric tolerance. + FC_SPHTOL(fc) = 1.0d-5 + + # Set the bad coordinate value. + FC_BADCVAL(fc) = INDEFD + + # Free working space. + call sfree (sp) + +end + + +# WF_ZPX_FWD -- Forward transform (physical to world) for the zenithal / +# azimuthal polynomial projection. + +procedure wf_zpx_fwd (fc, p, w) + +pointer fc #I pointer to FC descriptor +double p[2] #I physical coordinates (x, y) +double w[2] #O world coordinates (ra, dec) + +int ira, idec, i, j, k +double x, y, r, zd, a, b, c, d, zd1, zd2, r1, r2, lambda, rt, tol +double phi, theta, costhe, sinthe, dphi, cosphi, sinphi, ra, dec, dlng, z +double wf_gseval() +data tol/1.0d-13/ + +define phitheta_ 11 + +begin + # Get the axis numbers. + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + # Compute native spherical coordinates PHI and THETA in degrees from + # the projected coordinates. This is the projection part of the + # computation. + + k = nint (FC_NP(fc)) + if (FC_LNGCOR(fc) == NULL) + x = p[ira] + else + x = p[ira] + wf_gseval (FC_LNGCOR(fc), p[ira], p[idec]) + if (FC_LATCOR(fc) == NULL) + y = p[idec] + else + y = p[idec] + wf_gseval (FC_LATCOR(fc), p[ira], p[idec]) + r = sqrt (x * x + y * y) / FC_RODEG(fc) + + # Solve. + + # Constant no solution + if (k < 1) { + w[ira] = FC_BADCVAL(fc) + w[idec] = FC_BADCVAL(fc) + return + + # Linear. + } else if (k == 1) { + zd = (r - FC_PC(fc,0)) / FC_PC(fc,1) + + # Quadratic. + } else if (k == 2) { + + a = FC_PC(fc,2) + b = FC_PC(fc,1) + c = FC_PC(fc,0) - r + d = b * b - 4.0d0 * a * c + if (d < 0.0d0) { + w[ira] = FC_BADCVAL(fc) + w[idec] = FC_BADCVAL(fc) + return + } + d = sqrt (d) + + # Choose solution closet to the pole. + zd1 = (-b + d) / (2.0d0 * a) + zd2 = (-b - d) / (2.0d0 * a) + zd = min (zd1, zd2) + if (zd < -tol) + zd = max (zd1, zd2) + if (zd < 0.0d0) { + if (zd < -tol) { + w[ira] = FC_BADCVAL(fc) + w[idec] = FC_BADCVAL(fc) + return + } + zd = 0.0d0 + } else if (zd > DPI) { + if (zd > (DPI + tol)) { + w[ira] = FC_BADCVAL(fc) + w[idec] = FC_BADCVAL(fc) + return + } + zd = DPI + } + + # Higher order solve iteratively. + } else { + + zd1 = 0.0d0 + r1 = FC_PC(fc,0) + zd2 = FC_ZD(fc) + r2 = FC_R(fc) + + if (r < r1) { + if (r < (r1 - tol)) { + w[ira] = FC_BADCVAL(fc) + w[idec] = FC_BADCVAL(fc) + return + } + zd = zd1 + goto phitheta_ + } else if (r > r2) { + if (r > (r2 + tol)) { + w[ira] = FC_BADCVAL(fc) + w[idec] = FC_BADCVAL(fc) + return + } + zd = zd2 + goto phitheta_ + } else { + do j = 1, 100 { + lambda = (r2 - r) / (r2 - r1) + if (lambda < 0.1d0) + lambda = 0.1d0 + else if (lambda > 0.9d0) + lambda = 0.9d0 + zd = zd2 - lambda * (zd2 - zd1) + rt = 0.0d0 + do i = k, 0, -1 + rt = (rt * zd) + FC_PC(fc,i) + if (rt < r) { + if ((r - rt) < tol) + goto phitheta_ + r1 = rt + zd1 = zd + } else { + if ((rt - r) < tol) + goto phitheta_ + r2 = rt + zd2 = zd + } + if (abs(zd2 - zd1) < tol) + goto phitheta_ + } + } + + } + +phitheta_ + + # Compute PHI. + if (r == 0.0d0) + phi = 0.0d0 + else + phi = atan2 (x, -y) + + # Compute THETA. + theta = DHALFPI - zd + + # Compute the celestial coordinates RA and DEC from the native + # coordinates PHI and THETA. This is the spherical geometry part + # of the computation. + + costhe = cos (theta) + sinthe = sin (theta) + dphi = phi - FC_LONGP(fc) + cosphi = cos (dphi) + sinphi = sin (dphi) + + # Compute the RA. + x = sinthe * FC_SINLATP(fc) - costhe * FC_COSLATP(fc) * cosphi + if (abs (x) < FC_SPHTOL(fc)) + x = -cos (theta + FC_COLATP(fc)) + costhe * FC_COSLATP(fc) * + (1.0d0 - cosphi) + y = -costhe * sinphi + if (x != 0.0d0 || y != 0.0d0) { + dlng = atan2 (y, x) + } else { + dlng = dphi + DPI + } + ra = FC_W(fc,ira) + DRADTODEG(dlng) + + # Normalize the RA. + if (FC_W(fc,ira) >= 0.0d0) { + if (ra < 0.0d0) + ra = ra + 360.0d0 + } else { + if (ra > 0.0d0) + ra = ra - 360.0d0 + } + if (ra > 360.0d0) + ra = ra - 360.0d0 + else if (ra < -360.0d0) + ra = ra + 360.0d0 + + # Compute the DEC. + if (mod (dphi, DPI) == 0.0d0) { + dec = DRADTODEG(theta + cosphi * FC_COLATP(fc)) + if (dec > 90.0d0) + dec = 180.0d0 - dec + if (dec < -90.0d0) + dec = -180.0d0 - dec + } else { + z = sinthe * FC_COSLATP(fc) + costhe * FC_SINLATP(fc) * cosphi + if (abs(z) > 0.99d0) { + if (z >= 0.0d0) + dec = DRADTODEG(acos (sqrt(x * x + y * y))) + else + dec = DRADTODEG(-acos (sqrt(x * x + y * y))) + } else + dec = DRADTODEG(asin (z)) + } + + # Store the results. + w[ira] = ra + w[idec] = dec +end + + +# WF_ZPX_INV -- Inverse transform (world to physical) for the zenithal / +# azimuthal polynomial projection. + +procedure wf_zpx_inv (fc, w, p) + +pointer fc #I pointer to FC descriptor +double w[2] #I input world (RA, DEC) coordinates +double p[2] #I output physical coordinates + +int ira, idec, i, niter +double ra, dec, cosdec, sindec, cosra, sinra, x, y, phi, theta, s, r, dphi, z +double xm, ym, f, fx, fy, g, gx, gy, denom, dx, dy, dmax +double wf_gseval(), wf_gsder() + +begin + # Get the axes numbers. + ira = FC_IRA(fc) + idec = FC_IDEC(fc) + + # Compute the transformation from celestial coordinates RA and + # DEC to native coordinates PHI and THETA. This is the spherical + # geometry part of the transformation. + + ra = DDEGTORAD (w[ira] - FC_W(fc,ira)) + dec = DDEGTORAD (w[idec]) + cosra = cos (ra) + sinra = sin (ra) + cosdec = cos (dec) + sindec = sin (dec) + + # Compute PHI. + x = sindec * FC_SINLATP(fc) - cosdec * FC_COSLATP(fc) * cosra + if (abs(x) < FC_SPHTOL(fc)) + x = -cos (dec + FC_COLATP(fc)) + cosdec * FC_COSLATP(fc) * + (1.0d0 - cosra) + y = -cosdec * sinra + if (x != 0.0d0 || y != 0.0d0) + dphi = atan2 (y, x) + else + dphi = ra - DPI + phi = FC_LONGP(fc) + dphi + if (phi > DPI) + phi = phi - DTWOPI + else if (phi < -DPI) + phi = phi + DTWOPI + + # Compute THETA. + if (mod (ra, DPI) ==0.0) { + theta = dec + cosra * FC_COLATP(fc) + if (theta > DHALFPI) + theta = DPI - theta + if (theta < -DHALFPI) + theta = -DPI - theta + } else { + z = sindec * FC_COSLATP(fc) + cosdec * FC_SINLATP(fc) * cosra + if (abs (z) > 0.99d0) { + if (z >= 0.0) + theta = acos (sqrt(x * x + y * y)) + else + theta = -acos (sqrt(x * x + y * y)) + } else + theta = asin (z) + } + + # Compute the transformation from native coordinates PHI and THETA + # to projected coordinates X and Y. + + s = DHALFPI - theta + r = 0.0d0 + do i = 9, 0, -1 + r = r * s + FC_PC(fc,i) + r = FC_RODEG(fc) * r + + if (FC_LNGCOR(fc) == NULL && FC_LATCOR(fc) == NULL) { + p[ira] = r * sin (phi) + p[idec] = -r * cos (phi) + + } else { + xm = r * sin (phi) + ym = -r * cos (phi) + x = xm + y = ym + niter = 0 + dmax = 30. / 3600. + + repeat { + if (FC_LNGCOR(fc) != NULL) { + f = x + wf_gseval (FC_LNGCOR(fc), x, y) - xm + fx = wf_gsder (FC_LNGCOR(fc), x, y, 1, 0) + fx = 1.0 + fx + fy = wf_gsder (FC_LNGCOR(fc), x, y, 0, 1) + } else { + f = x - xm + fx = 1.0 + fy = 0.0 + } + if (FC_LATCOR(fc) != NULL) { + g = y + wf_gseval (FC_LATCOR(fc), x, y) - ym + gx = wf_gsder (FC_LATCOR(fc), x, y, 1, 0) + gy = wf_gsder (FC_LATCOR(fc), x, y, 0, 1) + gy = 1.0 + gy + } else { + g = y - ym + gx = 0.0 + gy = 1.0 + } + denom = fx * gy - fy * gx + if (denom == 0.0d0) + break + dx = (-f * gy + g * fy) / denom + dy = (-g * fx + f * gx) / denom + x = x + max (-dmax, min (dmax, dx)) + y = y + max (-dmax, min (dmax, dy)) + if (max (abs (dx), abs (dy), abs(f), abs(g)) < 2.80d-7) + break + + niter = niter + 1 + + } until (niter >= MAX_NITER) + + p[ira] = x + p[idec] = y + } +end + + +# WF_ZPX_DESTROY -- Free up the distortion surface pointers. + +procedure wf_zpx_destroy (fc) + +pointer fc #I pointer to the FC descriptor + +begin + if (FC_LNGCOR(fc) != NULL) + call wf_gsclose (FC_LNGCOR(fc)) + if (FC_LATCOR(fc) != NULL) + call wf_gsclose (FC_LATCOR(fc)) +end diff --git a/sys/mwcs/zzdebug.x b/sys/mwcs/zzdebug.x new file mode 100644 index 00000000..d098f68b --- /dev/null +++ b/sys/mwcs/zzdebug.x @@ -0,0 +1,507 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "imwcs.h" + +task simple = t_simple, + wcs = t_wcs, + float = t_float, + imtest = t_imtest, + inv = t_inv, + save = t_save, + load = t_load + +define SAVELEN 10240 + + +# SIMPLE -- Simple test of the most common interface routines. + +procedure t_simple() + +pointer mw, ct, bp +int buflen, nchars +real ltm[2,2], ltv[2], x1,y1, x2,y2 +pointer mw_open(), mw_sctran() +int mw_save() + +begin + call memchk() + mw = mw_open (NULL, 2) + + ltm[1,1] = 1.0; ltm[1,2] = 0.0 + ltm[2,1] = 0.0; ltm[2,2] = 1.0 + ltv[1] = 0.0; ltv[2] = 0.0 + call mw_sltermr (mw, ltm, ltv, 2) + + ct = mw_sctran (mw, "logical", "physical", 0) + x1 = 0.5; y1 = 0.5 + call mw_c2tranr (ct, x1, y1, x2, y2) + + call eprintf ("[%g,%g] -> [%g,%g]\n") + call pargr (x1); call pargr (y1) + call pargr (x2); call pargr (y2) + + bp = NULL + nchars = mw_save (mw, bp, buflen) + call mw_load (mw, bp) + + call eprintf ("save/load, save buflen = %d chars, nchars=%d\n") + call pargi (buflen) + call pargi (nchars) + + ct = mw_sctran (mw, "logical", "physical", 0) + x1 = 0.5; y1 = 0.5 + call mw_c2tranr (ct, x1, y1, x2, y2) + + call eprintf ("[%g,%g] -> [%g,%g]\n") + call pargr (x1); call pargr (y1) + call pargr (x2); call pargr (y2) + + call mw_close (mw) +end + + +# WCS -- Test the creation and use of a world coordinate system. + +procedure t_wcs() + +pointer mw, ct1, ct2, ct3 +real pv[100], wv[100] +real theta, center[2], scale[2], shift[2] +real ltm[3,3], ltv[3], x1,y1, x2,y2 +double r[3], w[3], cd[3,3] +double l2m[2,2], l2v_1[2], l2v_2[2], d_theta +int ndim, axes[3], naxes, npts, i +pointer mw_open(), mw_sctran() +real mw_c1tranr() + +begin + call memchk() + ndim = 3 + + # Create a unitary, 3 dim WCS. + mw = mw_open (NULL, ndim) + + # Examine the Lterm. + call plterm (mw, ltm, ltv, ndim) + + # Apply a transform to the first 2 axes. + d_theta = DEGTORAD(30.0D0) + l2m[1,1] = cos(d_theta); l2m[2,1] = sin(d_theta) + l2m[1,2] = -sin(d_theta); l2m[2,2] = cos(d_theta) + l2v_1[1] = 0.0; l2v_1[2] = 0.0 + l2v_2[1] = 10.0; l2v_2[2] = 20.0 + #l2v_2[1] = 0.0; l2v_2[2] = 0.0 + + #call mw_translated (mw, l2v_1, l2m, l2v_2, 2) + theta = d_theta; call aclrr (center, 2) + call mw_rotate (mw, theta, center, 3B) + shift[1] = 10.0; shift[2] = 20.0 + call mw_shift (mw, shift, 3B) + scale[1] = 4.0; scale[2] = 0.2 + call mw_scale (mw, scale, 3B) + + # Examine the Lterm. + call plterm (mw, ltm, ltv, ndim) + + # Apply the inverse transform. + d_theta = -d_theta + l2m[1,1] = cos(d_theta); l2m[2,1] = sin(d_theta) + l2m[1,2] = -sin(d_theta); l2m[2,2] = cos(d_theta) + call amovd (l2v_2, l2v_1, 2); call aclrd (l2v_2, 2) + + #call mw_translated (mw, l2v_1, l2m, l2v_2, 2) + scale[1] = 1.0/scale[1]; scale[2] = 1.0/scale[2] + call mw_scale (mw, scale, 3B) + shift[1] = -shift[1]; shift[2] = -shift[2] + call mw_shift (mw, shift, 3B) + call mw_rotate (mw, -theta, center, 3B) + + # Examine the Lterm. + call plterm (mw, ltm, ltv, ndim) + + # Add a WCS. + call mw_newsystem (mw, "sky", 3) + + cd[1,1] = .01D0; cd[2,1] = 0; cd[3,1] = 0 + cd[1,2] = 0; cd[2,2] = .01D0; cd[3,2] = 0 + cd[1,3] = 0; cd[2,3] = 0; cd[3,3] = 1 + r[1] = 0; r[2] = 0; r[3] = 0 + w[1] = 100; w[2] = 20; w[3] = 0 + + # Put a tangent projection on axis 1&2. + call mw_swtermd (mw, r, w, cd, ndim) + axes[1] = 1; axes[2] = 2; naxes = 2 + call mw_swtype (mw, axes, naxes, "tan", + "axis 1: axtype=ra axis 2: axtype=dec") + + # Put a simple sampled curve on axis 3. + call mw_swtype (mw, 3, 1, "sampled", "") + npts = 10 + do i = 1, npts { + pv[i] = i + wv[i] = i * 2 + } + call mw_swsampr (mw, 3, pv, wv, npts) + + # Try a transform on the axis 1-2 plane. + ct1 = mw_sctran (mw, "logical", "sky", 3B) + x1 = 50.0; y1 = -20.0 + call mw_c2tranr (ct1, x1,y1, x2,y2) + call eprintf ("[%g,%g]logical -> [%g,%g]sky\n") + call pargr (x1); call pargr (y1) + call pargr (x2); call pargr (y2) + + # Check out the reverse transform. + ct2 = mw_sctran (mw, "sky", "logical", 3B) + call mw_c2tranr (ct2, x2,y2, x1,y1) + call eprintf ("[%g,%g]sky -> [%g,%g]logical\n") + call pargr (x2); call pargr (y2) + call pargr (x1); call pargr (y1) + + # Try evaluating the sampled axis. + ct3 = mw_sctran (mw, "physical", "sky", 4B) + x1 = 4.5; x2 = mw_c1tranr (ct3, x1) + call eprintf ("axis 3: %gL -> %gS\n") + call pargr (x1) + call pargr (x2) + + call mw_close (mw) +end + + +# PLTERM -- Print the Lterm. + +procedure plterm (mw, ltm, ltv, ndim) + +pointer mw +real ltm[ndim,ndim] +real ltv[ndim] +int ndim + +int i, j + +begin + # Examine the Lterm. + call mw_gltermr (mw, ltm, ltv, ndim) + call eprintf ("----- lterm -----\n") + + do j = 1, ndim { + do i = 1, ndim { + call eprintf (" %8.3f") + call pargr (ltm[i,j]) + } + call eprintf (" : %8.3f\n") + call pargr (ltv[j]) + } +end + + +# IMTEST -- Test the image header WCS save and load facilities. + +procedure t_imtest() + +double cd[3,3], r[3], w[3] +int ndim, naxes, axes[2], npts, i +pointer mw, ct1, ct2, ct3, im, iw, cp +real theta, center[3], shift[3], scale[3], x1,y1, x2,y2, pv[10], wv[10] +pointer mw_open(), mw_sctran(), immap(), iw_rfits() +real mw_c1tranr() + +begin + call memchk() + ndim = 3 + + # Create a unitary, 3 dim WCS. + mw = mw_open (NULL, ndim) + + # Apply a transform to the first 2 axes. + call aclrr (center, 2) + theta = DEGTORAD(30.0D0) + shift[1] = 10.0; shift[2] = 20.0 + scale[1] = 4.0; scale[2] = 0.2 + + call mw_rotate (mw, theta, center, 3B) + call mw_shift (mw, shift, 3B) + call mw_scale (mw, scale, 3B) + + # Add a WCS. + call mw_newsystem (mw, "sky", 3) + + cd[1,1] = .01D0; cd[2,1] = 0; cd[3,1] = 0 + cd[1,2] = 0; cd[2,2] = .01D0; cd[3,2] = 0 + cd[1,3] = 0; cd[2,3] = 0; cd[3,3] = 1 + r[1] = 0; r[2] = 0; r[3] = 0 + w[1] = 100; w[2] = 20; w[3] = 0 + + # Put a tangent projection on axis 1&2. + call mw_swtermd (mw, r, w, cd, ndim) + axes[1] = 1; axes[2] = 2; naxes = 2 + call mw_swtype (mw, axes, naxes, "tan", + "axis 1: axtype=ra axis 2: axtype=dec") + + # Put a simple sampled curve on axis 3. + call mw_swtype (mw, 3, 1, "sampled", "") + npts = 10 + do i = 1, npts { + pv[i] = i + wv[i] = i * 2 + } + call mw_swsampr (mw, 3, pv, wv, npts) + + # Evaluate tests 1. + # ----------------- + + # Try a transform on the axis 1-2 plane. + ct1 = mw_sctran (mw, "logical", "sky", 3B) + x1 = 50.0; y1 = -20.0 + call mw_c2tranr (ct1, x1,y1, x2,y2) + call eprintf ("[%g,%g]logical -> [%g,%g]sky\n") + call pargr (x1); call pargr (y1) + call pargr (x2); call pargr (y2) + + # Check out the reverse transform. + ct2 = mw_sctran (mw, "sky", "logical", 3B) + call mw_c2tranr (ct2, x2,y2, x1,y1) + call eprintf ("[%g,%g]sky -> [%g,%g]logical\n") + call pargr (x2); call pargr (y2) + call pargr (x1); call pargr (y1) + + # Try evaluating the sampled axis. + ct3 = mw_sctran (mw, "physical", "sky", 4B) + x1 = 4.5; x2 = mw_c1tranr (ct3, x1) + call eprintf ("axis 3: %gL -> %gS\n") + call pargr (x1) + call pargr (x2) + + # Test image header save/load. + call eprintf ("save WCS in image header...\n") + #iferr (call imdelete ("pix")) + # ; + im = immap ("pix", READ_WRITE, 0) + call mw_saveim (mw, im) + + # See what we saved. + call printf ("-------- IMAGE HEADER --------\n") + iw = iw_rfits (mw, im, RF_REFERENCE) + do i = 1, IW_NCARDS(iw) { + cp = IW_CARD(iw,i) + call write (STDOUT, Memc[C_RP(cp)], 80) + call putci (STDOUT, '\n') + } + call iw_cfits (iw) + call printf ("------------------------------\n") + call flush (STDOUT) + + # Reload saved header. + call mw_loadim (mw, im) + + # Evaluate tests 2. + # ----------------- + + # Try a transform on the axis 1-2 plane. + ct1 = mw_sctran (mw, "logical", "sky", 3B) + x1 = 50.0; y1 = -20.0 + call mw_c2tranr (ct1, x1,y1, x2,y2) + call eprintf ("[%g,%g]logical -> [%g,%g]sky\n") + call pargr (x1); call pargr (y1) + call pargr (x2); call pargr (y2) + + # Check out the reverse transform. + ct2 = mw_sctran (mw, "sky", "logical", 3B) + call mw_c2tranr (ct2, x2,y2, x1,y1) + call eprintf ("[%g,%g]sky -> [%g,%g]logical\n") + call pargr (x2); call pargr (y2) + call pargr (x1); call pargr (y1) + + # Try evaluating the sampled axis. + ct3 = mw_sctran (mw, "physical", "sky", 4B) + x1 = 4.5; x2 = mw_c1tranr (ct3, x1) + call eprintf ("axis 3: %gL -> %gS\n") + call pargr (x1) + call pargr (x2) + + call mw_close (mw) +end + + +# INV -- Test matrix inversion. + +procedure t_inv() + +int i, j +double a[3,3], b[3,3], c[3,3] +long seed, clktime() +real urand() + +begin + # Construct the identity matrix. + do i = 1, 3 { + do j = 1, 3 + a[i,j] = 0.0 + a[i,i] = 1.0 + } + + # Invert the matrix. + call mw_invertd (a, b, 3) + + # Print the inverse. + call printf ("inverse of identity matrix:\n") + do i = 1, 3 { + do j = 1, 3 { + call printf (" %20.*f") + call pargi (NDIGITS_DP) + call pargd (b[i,j]) + } + call printf ("\n") + } + + # Compute a random matrix. + seed = clktime(0) + do i = 1, 3 + do j = 1, 3 + a[i,j] = urand (seed) + + # Invert the matrix. + call mw_invertd (a, b, 3) + call mw_invertd (b, c, 3) + + # Print the difference of the original and the inverted inverse. + call printf ("difference of inverse of random matrix:\n") + do i = 1, 3 { + do j = 1, 3 { + call printf (" %20.*f") + call pargi (NDIGITS_DP) + call pargd (a[i,j] - c[i,j]) + } + call printf ("\n") + } +end + + +# SAVE -- Save a test WCS to a file. + +procedure t_save() + +pointer mw, bp +double cd[3,3], r[3], w[3] +int ndim, naxes, axes[2], npts, buflen, nchars, fd, i +real theta, center[3], shift[3], scale[3], pv[10], wv[10] +int open(), mw_save +pointer mw_open() + +begin + ndim = 3 + + # Create a unitary, 3 dim WCS. + mw = mw_open (NULL, ndim) + + # Apply a transform to the first 2 axes. + call aclrr (center, 2) + theta = DEGTORAD(30.0D0) + shift[1] = 10.0; shift[2] = 20.0 + scale[1] = 4.0; scale[2] = 0.2 + + call mw_rotate (mw, theta, center, 3B) + call mw_shift (mw, shift, 3B) + call mw_scale (mw, scale, 3B) + + # Add a WCS. + call mw_newsystem (mw, "sky", 3) + + cd[1,1] = .01D0; cd[2,1] = 0; cd[3,1] = 0 + cd[1,2] = 0; cd[2,2] = .01D0; cd[3,2] = 0 + cd[1,3] = 0; cd[2,3] = 0; cd[3,3] = 1 + r[1] = 0; r[2] = 0; r[3] = 0 + w[1] = 100; w[2] = 20; w[3] = 0 + + # Put a tangent projection on axis 1&2. + call mw_swtermd (mw, r, w, cd, ndim) + axes[1] = 1; axes[2] = 2; naxes = 2 + call mw_swtype (mw, axes, naxes, "tan", + "axis 1: axtype=ra axis 2: axtype=dec") + + # Put a simple sampled curve on axis 3. + call mw_swtype (mw, 3, 1, "sampled", "") + npts = 10 + do i = 1, npts { + pv[i] = i + wv[i] = i * 2 + } + call mw_swsampr (mw, 3, pv, wv, npts) + + # Display the new WCS. + call mw_show (mw, STDOUT, 0) + + # Save to a file. + bp = NULL; buflen = 0 + nchars = mw_save (mw, bp, buflen) + + fd = open ("mwcs.sav", NEW_FILE, BINARY_FILE) + call write (fd, Memc[bp], nchars) + call close (fd) + + call mfree (bp, TY_CHAR) + call mw_close (mw) +end + + +# LOAD -- Load a test WCS from a file. + +procedure t_load() + +pointer mw, bp +int fd, nchars +char fname[SZ_FNAME] +int open(), read() +pointer mw_open() + +begin + call clgstr ("savefile", fname, SZ_FNAME) + call malloc (bp, SAVELEN, TY_CHAR) + + # Open and read save file. + fd = open (fname, READ_ONLY, BINARY_FILE) + nchars = read (fd, Memc[bp], SAVELEN) + call printf ("read %d chars from %s\n") + call pargi (nchars) + call pargstr (fname) + + mw = mw_open (NULL, 3) + call mw_load (mw, bp) + + # Display the new WCS. + call mw_show (mw, STDOUT, 0) + + call mw_close (mw) + call mfree (bp, TY_CHAR) +end + + +# FLOAT -- Test single to double conversions. + +procedure t_float() + +real r +double x + +begin + x = sin(0.34567D0) + r = 1.0 + call achtrd (r, x, 1) + call printf ("x = %g\n") + call pargd (x) +end + + +# MEMCHK -- Enable runtime dynamic memory verification. System dependent, +# should be commented out unless a Fortran callable MEMVER is available for +# linking. + +procedure memchk() + +begin + # call memver (2) +end diff --git a/sys/nmemio/README b/sys/nmemio/README new file mode 100644 index 00000000..597f1114 --- /dev/null +++ b/sys/nmemio/README @@ -0,0 +1 @@ +MEMIO -- Memory allocation and management facilities. diff --git a/sys/nmemio/begmem.x b/sys/nmemio/begmem.x new file mode 100644 index 00000000..e61f6e1e --- /dev/null +++ b/sys/nmemio/begmem.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help begmem, fixmem +.nf ___________________________________________________________________________ +BEGMEM, FIXMEM -- Try to get/release physical memory for a process. The +actual amount of physical memory available (in chars) is returned. On a +machine with virtual memory, these routines adjust the working set size. + +On any machine, BEGMEM may be used to determine the amount of available +physical memory, to tune algorithms for optimum performance. BEGMEM returns +as its function value the actual working set size of the process after +the adjustment (or the current working set size if "best_size" is zero). +On some systems this represents a soft limit on the actual amount of memory +which can be used; it is a guarantee that at least that much space is +available. Some systems will allow the actual working set to dynamically +exceed this value at runtime if the process pages heavily. The hard limit +on the working set of a process is given by the "max_size" parameter. + +Note that the working set must include space not only for a task specific +data buffers, but also for all other process data buffers and for the text +(instruction space) of the code being executed. There is no easy way to +determine this, hence the application is expected to estimate it. A typical +value for the base text+data size required to execute a program is 150Kb. +.endhelp ______________________________________________________________________ + + +# BEGMEM -- Attempt to the adjust the amount of physical memory allocated +# to a process. Save the old memory size in OLD_SIZE, so that memory may +# later be restored with FIXMEM. The new working set size is returned as +# the function value and the hard limit on the working set size is returned +# in MAX_SIZE. In general, the process can be expected to page, possibly +# heavily, or swap out if the working set size is exceeded. All sizes are +# returned in SPP chars. If BEST_SIZE is zero the working set size is not +# changed, i.e., the current working set parameters are returned. + +int procedure begmem (best_size, old_size, max_size) + +int best_size # desired working set size +int old_size # former working set size +int max_size # max physical memory available to this process + +int new_size + +begin + call zawset (best_size * SZB_CHAR, new_size, old_size, max_size) + new_size = new_size / SZB_CHAR + old_size = old_size / SZB_CHAR + max_size = max_size / SZB_CHAR + + return (new_size) +end + + +# FIXMEM -- Restore the original working set size. + +procedure fixmem (old_size) + +int old_size +int j1, j2, j3 + +begin + call zawset (old_size * SZB_CHAR, j1, j2, j3) +end diff --git a/sys/nmemio/calloc.x b/sys/nmemio/calloc.x new file mode 100644 index 00000000..c1b7ffb4 --- /dev/null +++ b/sys/nmemio/calloc.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CALLOC -- Allocate and zero a block of memory. + +procedure calloc (ubufp, buflen, dtype) + +pointer ubufp # user buffer pointer [OUTPUT] +int buflen # nelements of space required, +int dtype # of this data type + +pointer char_ptr +pointer coerce() +int sizeof() +errchk malloc + +begin + call malloc (ubufp, buflen, dtype) + char_ptr = coerce (ubufp, dtype, TY_CHAR) + call aclrc (Memc[char_ptr], buflen * sizeof (dtype)) +end diff --git a/sys/nmemio/coerce.x b/sys/nmemio/coerce.x new file mode 100644 index 00000000..36f762b2 --- /dev/null +++ b/sys/nmemio/coerce.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# COERCE -- Coerce a pointer from one datatype to another, choosing the +# next larger element for t2 in the event that t1 is not aligned with t2. + +pointer procedure coerce (ptr, type1, type2) + +pointer ptr # input pointer +int type1, type2 # from, to data types +int n +pointer p +include + +begin + p = ptr - 1 + if (type1 == TY_CHAR) { + return (p / ty_size[type2] + 1) + } else if (type2 == TY_CHAR) { + return (p * ty_size[type1] + 1) + } else { + p = p * ty_size[type1] # ptr to char + n = ty_size[type2] + return (((p + n-1) / n) + 1) + } +end diff --git a/sys/nmemio/doc/memio.hlp b/sys/nmemio/doc/memio.hlp new file mode 100644 index 00000000..1bc5c0a0 --- /dev/null +++ b/sys/nmemio/doc/memio.hlp @@ -0,0 +1,308 @@ +.help memio Feb83 "Dynamic Memory Management Routines" +.sh +Introduction + + The memory management routines manage both a stack and a heap. +Storage for the stack may be fragmented, and chunks of stack storage are +allocated dynamically from the heap as needed. Programs may allocate +heap storage directly if desired, for large or semipermanent buffers. +Stack storage is intended for use with small buffers, where the overhead +of allocating and deallocating space must be kept to a minimum. + + +.ks +.nf +heap routines: + + malloc (ptr, number_of_elements, data_type) + calloc (ptr, number_of_elements, data_type) + realloc (ptr, number_of_elements, data_type) + mfree (ptr, data_type) + + +stack routines: + + salloc (ptr, number_of_elements, data_type) + smark (ptr) + sfree (ptr) +.fi +.ke + + +MALLOC allocates space on the heap. CALLOC does the same, and fills the buffer +with zeroes. REALLOC is used to change the size of a previously allocated +buffer, copying the contents of the buffer if necessary. MFREE frees space +allocated by a prior call to MALLOC, CALLOC, or REALLOC. + +Space is allocated on the stack with SALLOC. SMARK should be called before +SALLOC, to mark the position of the stack pointer. SFREE returns all space +allocated on the stack since the matching call to SMARK. + + +.KS +Example: +.nf + pointer buf, sp + + begin + call smark (sp) + call salloc (buf, SZ_BUF, TY_CHAR) + while (getline (fd, Memc[buf]) != EOF) { + (code to use buffer ...) + } + call sfree (sp) +.fi +.KE + + +These routines will generate an error abort if memory cannot be allocated +for some reason. + +.sh +Heap Management + + Since many operating systems provide heap management facilities, +MALLOC and MFREE consist of little more than calls to Z routines to +allocate and free blocks of memory. The main function of MALLOC is +to convert the physical buffer address returned by the Z routine into +a pointer of the requested type. + +The pointer returned to the calling routine does not point at the beginning +of the physical buffer, but at a location a few bytes into the buffer. +The physical address of the buffer is stored in the buffer, immediately +before the cell pointed to by the pointer returned by MALLOC. The +stored address must be intact when MFREE is later called to deallocate +the buffer, or a "Memory corrupted" error diagnostic will result. + +The Z routines required to manage the heap are the following: + +.KS +.nf + zmget (bufadr, nbytes) + zmrget (bufadr, nbytes) + zmfree (buf_addr) +.fi +.KE + +The "get" routines should return NULL as the buffer address if space +cannot be allocated for some reason. + +.sh +Stack Management + + The heap management routines have quite a bit of overhead associated +with them, which precludes their use in certain applications. In addition, +the heap can be most efficiently managed when it contains few buffers. +The stack provides an efficient mechanism for parceling out small amounts +of storage, which can later all be freed with a single call. + +The main use of the stack is to provide automatic storage for local +arrays in procedures. The preprocessor compiles code which makes calls +to the stack management routines whenever an array is declared with the +storage calls AUTO, or whenever the ALLOC statement is used in a procedure. + + +.KS +.nf + auto char lbuf[SZ_LINE] + real x[n], y[n] + int n + + begin + alloc (x[npix], y[npix]) + + while (getline (fd, lbuf) != EOF) { + ... +.fi +.KE + + +The AUTO storage class and the ALLOC statement are provided in the full +preprocessor, but not in the subset preprocessor. The following subset +preprocessor code is functionally equivalent to the code show above: + + +.KS +.nf + pointer lbuf, x, y, sp + int n, getline() + + begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + n = npix + call salloc (x, n, TY_REAL) + call salloc (y, n, TY_REAL) + + while (getline (fd, Memc[lbuf]) != EOF) { + ... + + call sfree (sp) +.fi +.KE + +.sh +Semicode for Stack Management + + At any given time, the "stack" is a contiguous buffer of a certain size. +Stack overflow is handled by calling MALLOC to allocate another stack segment. +A pointer to the previous stack segment is kept in each new stack segment, +to permit reclamation of stack space. + + + + +.KS +.nf + salloc smark sfree + + + + stack_overflow + + + + malloc realloc mfree + + + + zmget zmrget zmfree + + + + Structure of the Memory Management Routines +.fi +.KE + + + + +.tp 5 +.nf +procedure salloc (bufptr, nelements, data_type) + +bufptr: upon output, contains pointer to the allocated space +nelements: number of elements of space to be allocated +data_type: data type of the elements and of the buffer pointer + +begin + # align stack pointer for the specified data type, + # compute amount of storage to be allocated + + if (data_type == TY_CHAR) + nchars = nelements + else { + sp = sp + mod (sp-1, sizeof(data_type)) + nchars = nelements * sizeof(data_type) + } + + if (sp + nchars > stack_top) # see if room + call stack_overflow (nchars) + + if (data_type == TY_CHAR) # return pointer + bufptr = sp + else + bufptr = (sp-1) / sizeof(data_type) + 1 + + sp = sp + nchars # bump stack ptr + return +end + + + + +.tp 5 +procedure sfree (old_sp) # pop the stack + +begin + # return entire segments until segment containing the old + # stack pointer is reached + + while (old_sp < stack_base || old_sp > stack_top) { + if (this is the first stack segment) + fatal error, invalid value for old_sp + stack_base = old_segment.stack_base + stack_top = old_segment.stack_top + mfree (segment_pointer, TY_CHAR) + segment_pointer = old_segment + } + + sp = old_sp +end + + + + +.tp 5 +procedure smark (old_sp) # save stack pointer + +begin + old_sp = sp +end + + + + +.tp 5 +procedure stack_overflow (nchars_needed) # increase stk size + +begin + # allocate storage for new segment + segment_size = max (SZ_STACK, nchars_needed + SZ_STKHDR) + malloc (new_segment, segment_size, TY_CHAR) + + # initialize header for the new segment + new_segment.old_segment = segment_pointer + new_segment.stack_base = new_segment + SZ_STKHDR + new_segment.stack_top = new_segment + segment_size + + # make new segment the current segment + segment_pointer = new_segment + stack_base = new_segment.stack_base + stack_top = new_segment.stack_top + sp = stack_base +end + + +.fi +The segment header contains fields describing the location and size of +the segment, plus a link pointer to the previous segment in the list. + + +.KS +.nf + struct stack_header { + char *stack_base + char *stack_top + struct stack_header *old_segment + } +.fi +.KE + +.sh +Pointers and Addresses + + Pointers are indices into (one indexed) Fortran arrays. A pointer to +an object of one datatype will in general have a different value than a +pointer to an object of a different datatype, even if the objects are stored +at the same physical address. Pointers have strict alignment requirements, +and it is not always possible to coerce the type of a pointer. For this +reason, the pointers returned by MALLOC and SALLOC are always aligned for +all data types, regardless of the data type requested. + +The IRAF system code must occasionally manipulate and store true physical +addresses, obtained with the function LOC. The problem with physical +addresses is that they are unsigned integers, but Fortran does not provide +any unsigned data types. Thus, comparisons of addresses are difficult +in Fortran. + +A second LOC primitive is provided for use in routines which must compare +addresses. LOCC returns the address of the object passed as argument, +right shifted to the size of a CHAR. Thus, the difference between LOCC(a[1]) +and LOCC(a[n]) is the size of the N element array A in chars. + +The relationship between chars, bytes, and machine addresses is machine +dependent. Bytes seem to be the smallest units. Some machines are byte +addressable, others are word addressable. The size of a CHAR in machine +bytes is given by the constant SZB_CHAR. The size of a machine word in +machine bytes is given by the constant SZB_WORD. diff --git a/sys/nmemio/kmalloc.x b/sys/nmemio/kmalloc.x new file mode 100644 index 00000000..7bfc4ee0 --- /dev/null +++ b/sys/nmemio/kmalloc.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# KMALLOC -- Allocate space on the heap. Equivalent to MALLOC, except that a +# memory allocation failure is indicated by returning ERR as the function value. + +int procedure kmalloc (ubufp, nelems, dtype) + +pointer ubufp # user buffer pointer (output) +int nelems # number of elements of storage required +int dtype # datatype of the storage elements + +int sz_align, fwa_align +int malloc1() + +begin + sz_align = SZ_MEMALIGN + call zlocva (Memc, fwa_align) + return (malloc1 (ubufp, nelems, dtype, sz_align, fwa_align)) +end diff --git a/sys/nmemio/krealloc.x b/sys/nmemio/krealloc.x new file mode 100644 index 00000000..be080547 --- /dev/null +++ b/sys/nmemio/krealloc.x @@ -0,0 +1,110 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# KREALLOC -- Change the size of a previously allocated buffer, moving the +# buffer if necessary. If there is no old buffer (NULL pointer) simply +# allocate a new buffer. This routine is equivalent to REALLOC except that it +# merely returns ERR as the function value if an error occurs. +# +# Buffer reallocation or resizing can always be implemented by allocating a new +# buffer, copying the contents of the old buffer to the new buffer, and then +# deleting the old buffer. Nonetheless we use a OS entry point to do the actual +# reallocation, because often it will be possible to change the size of a buffer +# without moving it, particularly when decreasing the size of the buffer. +# +# Allowing the OS to move a buffer causes problems due to the difference in +# alignment criteria imposed by the IRAF pointer scheme, which enforces +# stringent alignment criteria, versus OS memory allocation schemes which +# typically only align on word or longword boundaries. Therefore we must +# check the offset of the data area after reallocation, possibly shifting +# the contents of data area up or down a few chars to reestablish alignment +# with Mem. + +int procedure krealloc (ptr, a_nelems, a_dtype) + +pointer ptr # buffer to be reallocated +int a_nelems # new size of buffer +int a_dtype # buffer datatype + +pointer dataptr +int nelems, dtype, nchars, nuser, old_fwa, new_fwa +int char_shift, old_char_offset, new_char_offset +int status, locbuf, loc_Mem + +int mgtfwa(), sizeof(), kmalloc() +pointer mgdptr(), msvfwa(), coerce() +data loc_Mem /NULL/ + +begin + # Copy over the number of elements and the data type in case they are + # located in the block of memory we are reallocating. + + nelems = a_nelems + dtype = a_dtype + + if (ptr == NULL) { + return (kmalloc (ptr, nelems, dtype)) + + } else { + if (dtype == TY_CHAR) + nuser = nelems + 1 + else + nuser = nelems * sizeof(dtype) + 1 + + nchars = nuser + (8 * SZ_INT) + SZ_MEMALIGN + old_fwa = mgtfwa (ptr, dtype) + new_fwa = old_fwa + + # Change the buffer size; any error is fatal. + call zraloc (new_fwa, nchars * SZB_CHAR, status) + if (status == ERR) { + call merror ("Realloc failed\n") + ptr = NULL + return (ERR) + } + + # Compute the char offset of the old data area within the original + # buffer; zraloc() guarantees that the old data will have the same + # offset in the new buffer. Compute the char offset of the new + # data area. These need not be the same due to the OS allocating + # the new buffer to alignment criteria less than those required + # by MEMIO. + + call zlocva (Memc[coerce(ptr,dtype,TY_CHAR)], locbuf) + old_char_offset = (locbuf - old_fwa) + + # We must compute a pointer to the data area within the new + # buffer before we can compute the char offset of the new data + # area within the new buffer. + + if (loc_Mem == NULL) + call zlocva (Memc, loc_Mem) + + dataptr = mgdptr (new_fwa, TY_CHAR, SZ_MEMALIGN, loc_Mem) + call zlocva (Memc[dataptr], locbuf) + new_char_offset = (locbuf - new_fwa) + + # Shift the old data to satisfy the new alignment criteria, + # if necessary. + # + # FIXME -- If the new alloation is smaller than the old pointer, + # we should only copy as much data as will fit in the + # new space as per normal unix handling. + + char_shift = (new_char_offset - old_char_offset) + if (char_shift != 0) { + call amovc (Memc[dataptr - char_shift], Memc[dataptr], + nelems * sizeof(dtype)) + } + + # Save the fwa of the OS buffer in the buffer header, and return + # new pointer to user. + + ptr = msvfwa (new_fwa, dtype, nelems, SZ_MEMALIGN, loc_Mem) + } + + return (OK) +end diff --git a/sys/nmemio/main.x b/sys/nmemio/main.x new file mode 100644 index 00000000..653023ed --- /dev/null +++ b/sys/nmemio/main.x @@ -0,0 +1,893 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include +include +include + +.help iraf_main +.nf __________________________________________________________________________ +The IRAF MAIN + + Task resident interpreter for interface to CL. Supervises process startup +and shutdown, error restart, and task execution. A process may contain any +number of tasks, which need not be related. The iraf main allows a process to +be run either directly (interactively or in batch) or from the CL. A brief +description of the operation of the Main is given here; additional documentation +is given in the System Interface Reference Manual. + + +EXECUTION + +[1] The process containing the IRAF Main is run. The PROCESS MAIN, a machine + dependent code segment, gains control initially. The process main + determines whether the task is being run from as a connected subprocess, + as a detached process, or as a host process, and opens the process + standard i/o channels. The process main then calls the IRAF Main, i.e., us. + +[2] The IRAF Main performs the initialization associated with process startup + and then enters the interpreter loop waiting for a command. A number of + special commands are implemented, e.g.: + + ? print menu + bye shutdown process + chdir change directory + set set environment variable or variables + + Any other command is assumed to be the name of a task. The syntax of a + task invocation statement is as follows: + + [$]task [<[fname]], ([[stream[(T|B)]]>[fname]])|([[stream]>>[fname]]) + + Everything but the task name is optional. A leading $ enables printing of + the cpu time and clock time consumed by the process at termination. Any + combination of the standard i/o streams may be redirected on the command + line into a file. If the stream is redirected at the CL level redirection + is shown on the command line but the filename is omitted. + +[3] The communications protocol during task execution varies depending on + whether or not we are talking to the CL. If talking directly to the user, + the interpreter generates a prompt, and the standard input and output is + not blocked into XMIT and XFER commands. Interactive parameter requests + have the form "paramname: response" while CL/IPC requests have the form + "paramname=\nresponse", where "response" is the value entered by the user. + +[4] Task termination is indicated in interactive mode by generation of a prompt + for the next command and in CL/IPC mode by transmission of the command + "bye" to the parent process. If a task terminates abnormally the command + "error" is sent to the parent process or the terminal, and the Main reenters + the interpreter loop. + +A unique SYS_RUNTASK procedure is generated for each process at compile time by +performing string substitution on a TASK statement appearing in the source code. +The SYS_RUNTASK procedure contains the task dictionary, CALL statements for +each task, plus the special task "?". The main itself, i.e. this file, is a +precompiled library procedure which has no direct knowledge of the commands +to be run. + + +ERROR RECOVERY + + If a task terminates abnormally two things can happen: [1] a panic abort +occurs, causing immediate shutdown of the process (rare), or [2] the IRAF Main +is reentered at the ZSVJMP statement by a corresponding call to ZDOJMP from +elsewhere in the system, e.g., ERRACT in the error handling code. + +Error restart consists of the following steps: + + (1) The IRAF main is reentered at the point just after the ZDOJMP statement, + with a nonzero error code identifying the error in STATUS. + (2) The main performs error recovery, cleaning up the files system (deleting + NEW_FILES and TEMP_FILES), clearing the stack, and calling any + procedures posted with ONERROR. At present the error recovery code does + not free heap buffers or clear posted exception handlers. + (3) The ERROR statement is sent to the CL. An example of the + error statment is "ERROR (501, "Access Violation")". + (4) The main reenters the interpreter loop awaiting the next command from + the CL. + +Any error occuring during error restart is fatal and results in immediate +process termination, usually with a panic error message. This is necessary +to prevent infinite error recursion. + + +SHUTDOWN + + The process does not shutdown when interrupted by the CL or during error +recovery, unless a panic occurs. In normal operation shutdown only occurs when +the command BYE is received from the parennt process, or when EOF is read from +the process standard input. Procedures posted during execution with ONEXIT +will be called during process shutdown. Any error occuring while executing +an ONEXIT procedure is fatal and will result in a panic abort of the process. +.endhelp _____________________________________________________________________ + +define SZ_VALSTR SZ_COMMAND +define SZ_CMDBUF (SZ_COMMAND+1024) +define SZ_TASKNAME 32 +define TIMEIT_CHAR '$' +define MAXFD 5 # max redirectable fd's +define STARTUP 0 # stages of execution +define SHUTDOWN 1 +define IDLE 2 +define EXECUTING 3 +define DUMMY finit # any procedure will do + + +# IRAF_MAIN -- Execute commands read from the standard input until the special +# command "bye" is received, initiating process shutdown. The arguments tell +# the process type (connected, detached, or host) and identify the process +# standard i/o channels and device driver to be used. + +int procedure iraf_main (a_cmd, a_inchan, a_outchan, a_errchan, + a_driver, a_devtype, prtype, bkgfile, jobcode, sys_runtask, onentry) + +char a_cmd[ARB] # command to be executed or null string +int a_inchan # process standard input +int a_outchan # process standard output +int a_errchan # process standard error output +int a_driver # ZLOCPR address of device driver +int a_devtype # device type (text or binary) +int prtype # process type (connected, detached, host) +char bkgfile[ARB] # packed filename of bkg file if detached +int jobcode # jobcode if detached process +extern sys_runtask() # client task execution procedure +extern onentry() # client onentry procedure + +bool networking +int inchan, outchan, errchan, driver, devtype +char cmd[SZ_CMDBUF], taskname[SZ_TASKNAME], bkgfname[SZ_FNAME] +int arglist_offset, timeit, junk, interactive, builtin_task, cmdin +int jumpbuf[LEN_JUMPBUF], status, errstat, state, interpret, i +long save_time[2] +pointer sp + +bool streq() +extern DUMMY() +int sys_getcommand(), sys_runtask(), oscmd() +int access(), envscan(), onentry(), stropen() +errchk xonerror, fio_cleanup +common /JUMPCOM/ jumpbuf +string nullfile "dev$null" +data networking /KNET/ +define shutdown_ 91 + +# The following common is required on VMS systems to defeat the Fortran +# optimizer, which would otherwise produce optimizations that would cause +# a future return from ZSVJMP to fail. Beware that this trick may fail on +# other systems with clever optimizers. + +common /zzfakecom/ state + +begin + # The following initialization code is executed upon process + # startup only. + + errstat = OK + state = STARTUP + call mio_init() + call zsvjmp (jumpbuf, status) + if (status != OK) + call sys_panic (EA_FATAL, "fatal error during process startup") + + # Install the standard exception handlers, but if we are a connected + # subprocess do not enable interrupts until process startup has + # completed. + + call ma_ideh() + if (prtype == PR_CONNECTED) + call intr_disable() + + inchan = a_inchan + outchan = a_outchan + errchan = a_errchan + driver = a_driver + devtype = a_devtype + + # If the system is configured with networking initialize the network + # interface and convert the input channel codes and device driver + # code to their network equivalents. + + if (networking) + call ki_init (inchan, outchan, errchan, driver, devtype) + + # Other initializations. + call env_init() + call fmt_init (FMT_INITIALIZE) # init printf + call xer_reset() # init error checking + call erract (OK) # init error handling + call onerror (DUMMY) # init onerror + call onexit (DUMMY) # init onexit + call finit() # initialize FIO + call clopen (inchan, outchan, errchan, driver, devtype) + call clseti (CL_PRTYPE, prtype) + call clc_init() # init param cache + call strupk (bkgfile, bkgfname, SZ_FNAME) + + # If we are running as a host process (no IRAF parent process) look + # for the file "zzsetenv.def" in the current directory and then in + # the system library, and initialize the environment from this file + # if found. This works because the variable "iraf$" is defined at + # the ZGTENV level. + + interactive = NO + if (prtype == PR_HOST) { + interactive = YES + if (access ("zzsetenv.def",0,0) == YES) { + iferr (junk = envscan ("set @zzsetenv.def")) + ; + } else if (access ("host$hlib/zzsetenv.def",0,0) == YES) { + iferr (junk = envscan ("set @host$hlib/zzsetenv.def")) + ; + } + } + + # Save context for error restart. If an error occurs execution + # resumes just past the ZSVJMP statement with a nonzero status. + + call smark (sp) + call zsvjmp (jumpbuf, status) + + if (status != OK) { + errstat = status + + # Give up if error occurs during shutdown. + if (state == SHUTDOWN) + call sys_panic (errstat, "fatal error during process shutdown") + + # Tell error handling package that an error restart is in + # progress (necessary to avoid recursion). + + call erract (EA_RESTART) + + iferr { + # Call user cleanup routines and then clean up files system. + # Make sure that user cleanup routines are called FIRST. + + call xonerror (status) + call ma_ideh() + call flush (STDERR) + do i = CLIN, STDPLOT + call fseti (i, F_CANCEL, OK) + call fio_cleanup (status) + call fmt_init (FMT_INITIALIZE) + call sfree (sp) + } then + call erract (EA_FATAL) # panic abort + + # Send ERROR statement to the CL, telling the CL that the task + # has terminated abnormally. The CL will either kill us, resulting + # in error restart with status=SYS_XINT, or send us another command + # to execute. If we are connected but idle, do not send the ERROR + # statement because the CL will not read it until it executes the + # next task (which it will then mistakenly think has aborted). + + if (!(prtype == PR_CONNECTED && state == IDLE)) + call xer_send_error_statement_to_cl (status) + + # Inform error handling code that error restart has completed, + # or next error call will result in a panic shutdown. + + call erract (OK) + call xer_reset () + status = OK + } + + # During process startup and shutdown the parent is not listening to + # us, hence we dump STDOUT and STDERR into the null file. If this is + # not done and we write to CLOUT, deadlock may occur. During startup + # we also call the ONENTRY procedure. This is a no-op for connected + # and host subprocesses unless a special procedure is linked by the + # user (for detached processes the standard ONENTRY procedure opens + # the bkgfile as CLIN). The return value of ONENTRY determines whether + # the interpreter loop is entered. Note that ONENTRY permits complete + # bypass of the standard interpreter loop by an application (e.g. the + # IRAF CL). + + if (state == STARTUP) { + # Redirect stderr and stdout to the null file. + if (prtype == PR_CONNECTED) { + call fredir (STDOUT, nullfile, WRITE_ONLY, TEXT_FILE) + call fredir (STDERR, nullfile, WRITE_ONLY, TEXT_FILE) + } + + # Call the custom or default ONENTRY procedure. The lowest bit + # of the return value contains the PR_EXIT/PR_NOEXIT flag, higher + # bits may contain a more meaningful 7-bit status code which will + # be returned to the shell. + + i = onentry (prtype, bkgfname, a_cmd) + if (mod(i, 2) == PR_EXIT) { + interpret = NO + errstat = i / 2 + goto shutdown_ + } else + interpret = YES + + # Open the command input stream. If a command string was given on + # the command line then we read commands from that, otherwise we + # take commands from CLIN. + + for (i=1; IS_WHITE(a_cmd[i]) || a_cmd[i] == '\n'; i=i+1) + ; + if (a_cmd[i] != EOS) { + cmdin = stropen (a_cmd, ARB, READ_ONLY) + call fseti (cmdin, F_KEEP, YES) + interpret = NO + interactive = NO + } else + cmdin = CLIN + } + + # Interpreter loop of the IRAF Main. Execute named tasks until the + # command "bye" is received, or EOF is read on the process standard + # input (CLIN). Prompts and other perturbations in the CL/IPC protocol + # are generated if we are being run directly as a host process. + + while (sys_getcommand (cmdin, cmd, taskname, arglist_offset, + timeit, prtype) != EOF) { + + builtin_task = NO + if (streq (taskname, "bye")) { + # Initiate process shutdown. + break + } else if (streq (taskname, "set") || streq (taskname, "reset")) { + builtin_task = YES + } else if (streq (taskname, "cd") || streq (taskname, "chdir")) { + builtin_task = YES + } else if (prtype == PR_CONNECTED && streq (taskname, "_go_")) { + # Restore the normal standard output streams, following + # completion of process startup. Reenable interrupts. + call close (STDOUT) + call close (STDERR) + call intr_enable() + state = IDLE + next + } else if (taskname[1] == '!') { + # Send a command to the host system. + junk = oscmd (cmd[arglist_offset], "", "", "") + next + } else + state = EXECUTING + + if (builtin_task == NO) { + if (timeit == YES) + call sys_mtime (save_time) + + # Clear the parameter cache. + call clc_init() + + # Set the name of the root pset. + call clc_newtask (taskname) + + # Process the argument list, consisting of any mixture of + # parameter=value directives and i/o redirection directives. + + call sys_scanarglist (cmdin, cmd[arglist_offset]) + } + + # Call sys_runtask (the code for which was generated automatically + # by the preprocessor in place of the TASK statement) to search + # the dictionary and run the named task. + + errstat = OK + call mem_init (taskname) + if (sys_runtask (taskname,cmd,arglist_offset,interactive) == ERR) { + call flush (STDOUT) + call sprintf (cmd, SZ_CMDBUF, + "ERROR (0, \"Iraf Main: Unknown task name (%s)\")\n") + call pargstr (taskname) + call putline (CLOUT, cmd) + call flush (CLOUT) + state = IDLE + next + } + call mem_fini (taskname) + + # Cleanup after successful termination of command. Flush the + # standard output, cancel any unread standard input so the next + # task won't try to read it, print elapsed time if enabled, + # check for an incorrect error handler, call any user posted + # termination procedures, close open files, close any redirected + # i/o and restore the normal standard i/o streams. + + if (builtin_task == NO) { + + call flush (STDOUT) + call fseti (STDIN, F_CANCEL, OK) + + if (timeit == YES) + call sys_ptime (STDERR, taskname, save_time) + + call xer_verify() + call xonerror (OK) + call fio_cleanup (OK) + + if (prtype == PR_CONNECTED) { + call putline (CLOUT, "bye\n") + call flush (CLOUT) + } + if (state != STARTUP) + state = IDLE + } + } + + # The interpreter has exited after receipt of "bye" or EOF. Redirect + # stdout and stderr to the null file (since the parent is no longer + # listening to us), call the user exit procedures if any, and exit. + +shutdown_ + state = SHUTDOWN + if (prtype == PR_CONNECTED) { + call fredir (STDOUT, nullfile, WRITE_ONLY, TEXT_FILE) + call fredir (STDERR, nullfile, WRITE_ONLY, TEXT_FILE) + } else if (prtype == PR_HOST && cmd[1] == EOS && interpret == YES) { + call putci (CLOUT, '\n') + call flush (CLOUT) + } + + call xonexit (OK) + call fio_cleanup (OK) + call clclose() + + return (errstat) +end + + +# SYS_GETCOMMAND -- Get the next command from the input file. Ignore blank +# lines and comment lines. Parse the command and return the components as +# output arguments. EOF is returned as the function value when eof file is +# reached on the input file. + +int procedure sys_getcommand (fd, cmd, taskname, arglist_offset, timeit, prtype) + +int fd #I command input file +char cmd[SZ_CMDBUF] #O command line +char taskname[SZ_TASKNAME] #O extracted taskname, lower case +int arglist_offset #O offset into CMD of first argument +int timeit #O if YES, time the command +int prtype #I process type code + +int ip, op +int getlline(), stridx() + +begin + repeat { + # Get command line. Issue prompt first if process is being run + # interactively. + + if (prtype == PR_HOST && fd == CLIN) { + call putline (CLOUT, "> ") + call flush (CLOUT) + } + if (getlline (fd, cmd, SZ_CMDBUF) == EOF) + return (EOF) + + # Check for timeit character and advance to first character of + # the task name. + + timeit = NO + for (ip=1; cmd[ip] != EOS; ip=ip+1) { + if (cmd[ip] == TIMEIT_CHAR && timeit == NO) + timeit = YES + else if (!IS_WHITE (cmd[ip])) + break + } + + # Skip blank lines and comment lines. + switch (cmd[ip]) { + case '#', '\n', EOS: + next + case '?', '!': + taskname[1] = cmd[ip] + taskname[2] = EOS + arglist_offset = ip + 1 + return (OK) + } + + # Extract task name. + op = 1 + while (IS_ALNUM (cmd[ip]) || stridx (cmd[ip], "_.$") > 0) { + taskname[op] = cmd[ip] + ip = ip + 1 + op = min (SZ_TASKNAME + 1, op + 1) + } + taskname[op] = EOS + + # Determine index of argument list. + while (IS_WHITE (cmd[ip])) + ip = ip + 1 + arglist_offset = ip + + # Get rid of the newline. + for (; cmd[ip] != EOS; ip=ip+1) + if (cmd[ip] == '\n') { + cmd[ip] = EOS + break + } + + return (OK) + } +end + + +# SYS_SCANARGLIST -- Parse the argument list of a task. At the level of the +# iraf main the command syntax is very simple. There are two types of +# arguments, parameter assignments (including switches) and i/o redirection +# directives. All param assignments are of the form "param=value", where +# PARAM must start with a lower case alpha and where VALUE is either quoted or +# is delimited by one of the metacharacters [ \t\n<>\\]. A redirection argument +# is anything which is not a parameter set argument, i.e., any argument which +# does not start with a lower case alpha. + +procedure sys_scanarglist (cmdin, i_args) + +int cmdin # command input stream +char i_args[ARB] # (first part of) argument list + +int fd +char ch +bool skip +pointer sp, fname, args, ip, op +int getlline() + +begin + call smark (sp) + call salloc (args, SZ_CMDBUF, TY_CHAR) + call salloc (fname, SZ_FNAME, TY_CHAR) + + call strcpy (i_args, Memc[args], SZ_CMDBUF) + + # Do not skip whitespace for param=value args on the command line. + skip = false + + # Inform FIO that all standard i/o streams are unredirected (overridden + # below if redirected by an argument). + + for (fd=1; fd < FIRST_FD; fd=fd+1) + call fseti (fd, F_REDIR, NO) + + # Process each argument in the argument list. If the command line ends + # with an escaped newline then continuation is assumed. Arguments are + # delimited by whitespace. + + for (ip=args; Memc[ip] != '\n' && Memc[ip] != EOS; ) { + # Advance to the next argument. + while (IS_WHITE (Memc[ip])) + ip = ip + 1 + + # Check for continuation. + ch = Memc[ip] + if (ch == '\\' && (Memc[ip+1] == '\n' || Memc[ip+1] == EOS)) { + if (getlline (cmdin, Memc[args], SZ_CMDBUF) == EOF) { + call sfree (sp) + return + } + ip = args + next + } else if (ch == '\n' || ch == EOS) + break + + # If the argument begins with an alpha, _, or $ (e.g., $nargs) + # then it is a param=value argument, otherwise it must be a redir. + # The form @filename causes param=value pairs to be read from + # the named file. + + if (ch == '@') { + op = fname + for (ip=ip+1; Memc[ip] != EOS; ip=ip+1) + if (IS_WHITE (Memc[ip]) || Memc[ip] == '\n') + break + else if (Memc[ip] == '\\' && Memc[ip+1] == '\n') + break + else { + Memc[op] = Memc[ip] + op = op + 1 + } + Memc[op] = EOS + call sys_getpars (Memc[fname]) + + } else if (IS_ALPHA(ch) || ch == '_' || ch == '$') { + call sys_paramset (Memc, ip, skip) + } else + call sys_redirect (Memc, ip) + } + + call sfree (sp) +end + + +# SYS_GETPARS -- Read a sequence of param=value parameter assignments from +# the named file and enter them into the CLIO cache for the task. + +procedure sys_getpars (fname) + +char fname # pset file + +bool skip +int lineno, fd +pointer sp, lbuf, ip +int open(), getlline() +errchk open, getlline + +begin + call smark (sp) + call salloc (lbuf, SZ_CMDBUF, TY_CHAR) + + fd = open (fname, READ_ONLY, TEXT_FILE) + + # Skip whitespace for param = value args in a par file. + skip = true + + lineno = 0 + while (getlline (fd, Memc[lbuf], SZ_CMDBUF) != EOF) { + lineno = lineno + 1 + for (ip=lbuf; IS_WHITE (Memc[ip]); ip=ip+1) + ; + if (Memc[ip] == '#' || Memc[ip] == '\n') + next + iferr (call sys_paramset (Memc, ip, skip)) { + for (; Memc[ip] != EOS && Memc[ip] != '\n'; ip=ip+1) + ; + Memc[ip] = EOS + call eprintf ("Bad param assignment, line %d: `%s'\n") + call pargi (lineno) + call pargstr (Memc[lbuf]) + } + } + + call close (fd) + call sfree (sp) +end + + +# SYS_PARAMSET -- Extract the param and value substrings from a param=value +# or switch argument and enter them into the CL parameter cache. (see also +# clio.clcache). + +procedure sys_paramset (args, ip, skip) + +char args[ARB] # argument list +int ip # pointer to first char of argument +bool skip # skip whitespace within "param=value" args + +pointer sp, param, value, op +int stridx() + +begin + call smark (sp) + call salloc (param, SZ_FNAME, TY_CHAR) + call salloc (value, SZ_VALSTR, TY_CHAR) + + # Extract the param field. + op = param + while (IS_ALNUM (args[ip]) || stridx (args[ip], "_.$") > 0) { + Memc[op] = args[ip] + op = op + 1 + ip = ip + 1 + } + Memc[op] = EOS + + # Advance to the switch character or assignment operator. + while (IS_WHITE (args[ip])) + ip = ip + 1 + + switch (args[ip]) { + case '+': + # Boolean switch "yes". + ip = ip + 1 + call strcpy ("yes", Memc[value], SZ_VALSTR) + + case '-': + # Boolean switch "no". + ip = ip + 1 + call strcpy ("no", Memc[value], SZ_VALSTR) + + case '=': + # Extract the value field. This is either a quoted string or a + # string delimited by any of the metacharacters listed below. + + ip = ip + 1 + if (skip) { + while (IS_WHITE (args[ip])) + ip = ip + 1 + } + call sys_gstrarg (args, ip, Memc[value], SZ_VALSTR) + + default: + call error (1, "IRAF Main: command syntax error") + } + + # Enter the param=value pair into the CL parameter cache. + call clc_enter (Memc[param], Memc[value]) + + call sfree (sp) +end + + +# SYS_REDIRECT -- Process a single redirection argument. The syntax of an +# argument to redirect the standard input is +# +# < [fname] +# +# If the filename is omitted it is understood that STDIN has been redirected +# in the CL. The syntax to redirect a standard output stream is +# +# [45678][TB](>|>>)[fname] +# +# where [4567] is the FD number of a standard output stream (STDOUT, STDERR, +# STDGRAPH, STDIMAGE, or STDPLOT), and [TB] indicates if the file is text or +# binary. If the stream is redirected at the CL level the output filename +# will be given as `$', serving only to indicate that the stream is redirected. + +procedure sys_redirect (args, ip) + +char args[ARB] # argument list +int ip # pointer to first char of redir arg + +pointer sp, fname +int fd, mode, type +int ctoi() +define badredir_ 91 +errchk fredir, fseti + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + # Get number of stream (0 if not given). + if (ctoi (args, ip, fd) <= 0) + fd = 0 + + # Get file type (optional). + while (IS_WHITE (args[ip])) + ip = ip + 1 + + switch (args[ip]) { + case 'T', 't': + type = TEXT_FILE + ip = ip + 1 + case 'B', 'b': + type = BINARY_FILE + ip = ip + 1 + default: + type = 0 + } + + # Check for "<", ">", or ">>". + while (IS_WHITE (args[ip])) + ip = ip + 1 + + switch (args[ip]) { + case '<': + ip = ip + 1 + mode = READ_ONLY + if (fd == 0) + fd = STDIN + else if (fd != STDIN || fd != CLIN) + goto badredir_ + + case '>': + ip = ip + 1 + if (args[ip] == '>') { + ip = ip + 1 + mode = APPEND + } else + mode = NEW_FILE + + if (fd == 0) + fd = STDOUT + else { + switch (fd) { + case CLOUT, STDOUT, STDERR, STDGRAPH, STDIMAGE, STDPLOT: + ; + default: + goto badredir_ + } + } + + default: + # Not a redirection argument. + call error (1, "IRAF Main: command syntax error") + } + + # Set default file type for given stream if no type specified. + if (type == 0) + switch (fd) { + case CLIN, CLOUT, STDIN, STDOUT, STDERR: + type = TEXT_FILE + default: + type = BINARY_FILE + } + + # Extract the filename, if any. If the CL has redirected the output + # and is merely using the redirection syntax to inform us of this, + # the metafilename "$" is given. + + while (IS_WHITE (args[ip])) + ip = ip + 1 + + if (args[ip] == '$') { + Memc[fname] = EOS + ip = ip + 1 + } else + call sys_gstrarg (args, ip, Memc[fname], SZ_FNAME) + + # At this point we have FD, FNAME, MODE and TYPE. If no file is + # named the stream has already been redirected by the parent and + # all we need to is inform FIO that the stream has been redirected. + # Otherwise we redirect the stream in the local process. A locally + # redirected stream will be closed and the normal direction restored + # during FIO cleanup, at program termination or during error + # recovery. + + if (Memc[fname] != EOS) + call fredir (fd, Memc[fname], mode, type) + else + call fseti (fd, F_REDIR, YES) + + call sfree (sp) + return + +badredir_ + call error (2, "IRAF Main: illegal redirection") +end + + +# SYS_GSTRARG -- Extract a string field. This is either a quoted string or a +# string delimited by any of the metacharacters " \t\n<>\\". + +procedure sys_gstrarg (args, ip, outstr, maxch) + +char args[ARB] # input string +int ip # pointer into input string +char outstr[maxch] # receives string field +int maxch + +char delim, ch +int op +int stridx() + +begin + op = 1 + if (args[ip] == '"' || args[ip] == '\'') { + # Quoted value string. + + delim = args[ip] + for (ip=ip+1; args[ip] != delim && args[ip] != EOS; ip=ip+1) { + if (args[ip] == '\n') { + break + } else if (args[ip] == '\\' && args[ip+1] == delim) { + outstr[op] = delim + op = op + 1 + ip = ip + 1 + } else { + outstr[op] = args[ip] + op = op + 1 + } + } + + } else { + # Nonquoted value string. + + for (delim=-1; args[ip] != EOS; ip=ip+1) { + ch = args[ip] + if (ch == '\\' && (args[ip+1] == '\n' || args[ip+1] == EOS)) + break + else if (stridx (ch, " \t\n<>\\") > 0) + break + else { + outstr[op] = ch + op = op + 1 + } + } + } + + outstr[op] = EOS + if (args[ip] == delim) + ip = ip + 1 +end diff --git a/sys/nmemio/malloc.x b/sys/nmemio/malloc.x new file mode 100644 index 00000000..d5886c36 --- /dev/null +++ b/sys/nmemio/malloc.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# MALLOC -- Allocate space on the heap. An array of at least NELEMS elements +# of data type DTYPE is allocated, aligned to SZ_MEMALIGN (the biggest type) +# with the global common Mem. + +procedure malloc (ubufp, nelems, dtype) + +pointer ubufp # user buffer pointer (output) +int nelems # number of elements of storage required +int dtype # datatype of the storage elements + +int sz_align, fwa_align +int malloc1() + +begin + sz_align = SZ_MEMALIGN + call zlocva (Memc, fwa_align) + if (malloc1 (ubufp, nelems, dtype, sz_align, fwa_align) == ERR) + call syserr (SYS_MFULL) +end diff --git a/sys/nmemio/malloc1.x b/sys/nmemio/malloc1.x new file mode 100644 index 00000000..e5cfd0d3 --- /dev/null +++ b/sys/nmemio/malloc1.x @@ -0,0 +1,130 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help malloc1 +.nf ------------------------------------------------------------------------- +MEMIO -- Internal data structures. + +If "p" is the pointer returned by malloc, the first element of storage is +referenced by the expression "Mem_[p]", where the underscore is replaced +by the appropriate type suffix. A pointer to an object of one data type +is NOT equivalent to a pointer to another data type, even if both pointers +reference the same physical address. + +The actual physical address of the physical buffer area allocated is stored +in the integer cell immediately preceeding the buffer returned to the user. +If this cell is corrupted, the condition will later be detected, and a fatal +error ("memory corrupted") will result. + +For example, for a machine with a 4 byte integer, the first part of the +buffer area might appear as follows (the first few unused cells may or +may not be needed to satisfy the alignment criteria): + + offset allocation + + 0 start of the physical buffer (from zmaloc) + 1 + 2 + 3 + 4 byte 1 of saved fwa (address of cell 0) + 5 byte 2 " " " + 6 byte 3 " " " + 7 byte 4 " " " + 8 first cell available to user (maximum alignment) + + +New Scheme allowing for 64-bit architectures(10/15/2009): + + offset allocation + + 0 start of the physical buffer (from zmaloc) + 0-7 alignment space + 8-15 bytes 1-8 of saved fwa (address of cell 0) + 16-23 Bytes 1-8 of upper sentinal location + 24-31 Bytes 1-8 of pointer type + 32-39 Bytes 1-8 of nbytes of storage + 40-47 Bytes 1-8 of lower sentinal value + 48 first cell available to user (maximum alignment) + N+1 Bytes 1-8 of upper sentinal value + + Total storage required is + + [ ((nelems + 1) * sizeof(dtype)) + sz-align + (5 * SZ_INT) ] * SZB_CHAR + + +MALLOC, given the CHAR address of the buffer allocated by the z-routine, +adds space for the saved fwa (an integer), and determines the address of the +next cell which is sufficiently aligned, relative to the Mem common. This +cell marks the start of the user buffer area. The buffer fwa is saved in an +integer location preceding the "first cell". + +MFREE, called with a pointer to the buffer to be returned, fetches the location +of the physical buffer from the save area. If this does not agree with the +buffer pointer, either (1) the buffer pointer is invalid or of the wrong +datatype, or (2), the save area has been overwritten (memory has been +corrupted). If everything checks out, the buffer fwa is passed to a z-routine +to free the physical buffer space. + +TODO: - Add debugging routine to summarize allocated buffer space and + check for buffer overruns (add sentinel at end of buffer). + - Keep track of buffers allocated while a program is running and + return at program termination, like closing open files. +.endhelp --------------------------------------------------------------------- + + + +# MALLOC1 -- Low level procedure which does the actual buffer allocation. + +int procedure malloc1 (output_pointer, nelems, dtype, sz_align, fwa_align) + +pointer output_pointer # buffer pointer (output) +int nelems # number of elements of storage required +int dtype # datatype of the storage elements +int sz_align # number of chars of alignment required +int fwa_align # address to which buffer is to be aligned + +int fwa, nchars, nuser, status +pointer cp + +int sizeof() +pointer msvfwa(), coerce() + +include "nmemio.com" + +begin + if (dtype == TY_CHAR) + nuser = nelems + 1 # add space for EOS + else + nuser = nelems * sizeof (dtype) + 1 + nchars = nuser + (8 * SZ_INT) + sz_align + + call zmaloc (fwa, (nchars * SZB_CHAR), status) + + if (status == ERR) + return (ERR) + + else { + output_pointer = msvfwa (fwa, dtype, nelems, sz_align, fwa_align) + + if (mclear > 0) { + # Clear the user area only. + cp = coerce (output_pointer, dtype, TY_CHAR) + call aclrc (Memc[cp], (nuser * SZB_CHAR)) + } + + # Update usage stats. + if (mreport > 0) { + nalloc = nalloc + 1 + mem_used = mem_used + (nchars * SZB_CHAR) + if ((nchars * SZB_CHAR) > max_alloc) + max_alloc = (nchars * SZB_CHAR) + } + + # Save the ptr in the GC buffer. + if (mcollect > 0) + call mgc_save (output_pointer, dtype) + + return (OK) + } +end diff --git a/sys/nmemio/merror.x b/sys/nmemio/merror.x new file mode 100644 index 00000000..d69eb6cd --- /dev/null +++ b/sys/nmemio/merror.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + + +# MERROR -- Provide a convenient trap for a memory error. + +procedure merror (msg) + +char msg[ARB] + +include "nmemio.com" + +begin + if (in_task > 0) + call error (EA_ERROR, msg) +end diff --git a/sys/nmemio/mfini.x b/sys/nmemio/mfini.x new file mode 100644 index 00000000..f3933fa1 --- /dev/null +++ b/sys/nmemio/mfini.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + + +define MDEBUG false + +# MEM_FINI -- Close out the MEMIO use in this task. We perform the memory +# garbage collection and report usage statistics if requested. + +procedure mem_fini (task) + +char task[ARB] # task name + +int sv_report + +include "nmemio.com" + +begin + # Do garbage collection. + call mgc_collect() + + # Turn off reporting so the print statements below don't add + # to the reported values. + sv_report = mreport + mreport = 0 + mdebug = 0 + in_task = 0 + + if (MDEBUG) { + call eprintf ("\nTask '%s':\n") + call pargstr (task) + call eprintf (" mwatch:\t%d\n") ; call pargi (mwatch) + call eprintf (" mclear:\t%d\n") ; call pargi (mclear) + call eprintf (" mcollect:\t%d\n") ; call pargi (mcollect) + call eprintf (" mreport:\t%d\n") ; call pargi (mreport) + } + + # Report memory usage. + if (sv_report > 0) { + call eprintf ("\nTask '%s':\n") + call pargstr (task) + call eprintf (" Memory:\t%9d used (%9d max )\n") + call pargl (mem_used) + call pargi (max_alloc) + call eprintf (" Pointers:\t%9d alloc (%9d free)\n") + call pargi (nalloc) + call pargi (nfree) + call eprintf (" Leaked:\t%9d bytes (%9d ptrs)\n\n") + call pargl (leaked) + call pargl (nleaked) + } + + # Free the GC buffer. + call mgc_close () +end diff --git a/sys/nmemio/mfree.x b/sys/nmemio/mfree.x new file mode 100644 index 00000000..d83149c3 --- /dev/null +++ b/sys/nmemio/mfree.x @@ -0,0 +1,118 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + + +# MFREE -- Free a previously allocated buffer. If the buffer has already been +# returned (NULL pointer), ignore the request. Once the buffer has been +# returned, the old pointer value is of not useful (and invalid), so set it +# to NULL. + +procedure mfree (ptr, dtype) + +pointer ptr +int dtype + +pointer bp +int fwa, gc_type, status, lwl +char emsg[SZ_LINE] + +int mgtfwa(), coerce(), mgc_gettype() +errchk mgtfwa + +include "nmemio.com" + +begin + # Check for NULL or already-freed pointers. We only invoke an error + # rather than sys_panic to allow for recovery. + if (ptr < 0) { + call merror ("Attempt to free already freed pointer") + return + } + if (mdebug > 0 && ptr == NULL) { + call merror ("Attempt to free NULL pointer") + return + } + if (mcollect > 0) { + gc_type = mgc_gettype (ptr) + if ((gc_type != NULL && gc_type != dtype) && in_task > 0) { + call merror ("Attempt to free pointer of wrong type") + dtype = gc_type + } + } + + if (ptr != NULL) { + fwa = mgtfwa (ptr, dtype) + + bp = coerce (ptr, dtype, TY_INT) + if (mwatch > 0) { + + # Check the lower sentinal value. Any serious underflow + # would have corrupted the fwa and been detected above in + # mgtfwa(), we really only use this to check for 0/1 indexing + # problems that write before the start od the data. + if (Memi[bp-1] != lsentinal) { + call aclrc (emsg, SZ_LINE) + call sprintf (emsg, SZ_LINE, + "Pointer underflow: addr=0x%x nelem=%d type=%s\n") + call pargi (ptr) + call pargi (Memi[bp-2]) + call ptype (dtype) + if (mreport > 0) + call eprintf (emsg) + call merror (emsg) + } + + # Check the upper sentinal value. Note that the setinal is + # aligned to the INT boundary so depending on the type we + # might still allow a slight overrun. + lwl = Memi[bp-4] + if (Memi[lwl] != usentinal) { + call aclrc (emsg, SZ_LINE) + call sprintf (emsg, SZ_LINE, + "Pointer overflow: addr=0x%x nelem=%d type=%s\n") + call pargi (ptr) + call pargi (Memi[bp-2]) + call ptype (dtype) + if (mreport > 0) + call eprintf (emsg) + call merror (emsg) + } + } + + call zmfree (fwa, status) + if (status == ERR) + call sys_panic (SYS_MCORRUPTED, "Memory has been corrupted") + + # Negate the pointer so we can detect another attempt to free it. + if (mcollect > 0 && in_task > 0) + call mgc_update (ptr) + if (mcollect >= 0) + nfree = nfree + 1 + ptr = - ptr + ptr = NULL + } +end + + +# PTYPE -- Convert a pointer type code t its string equivalent. + +procedure ptype (dtype) + +int dtype + +begin + switch (dtype) { + case TY_BOOL: call pargstr ("TY_BOOL") + case TY_CHAR: call pargstr ("TY_CHAR") + case TY_SHORT: call pargstr ("TY_SHORT") + case TY_INT: call pargstr ("TY_INT") + case TY_LONG: call pargstr ("TY_LONG") + case TY_REAL: call pargstr ("TY_REAL") + case TY_DOUBLE: call pargstr ("TY_DOUBLE") + case TY_COMPLEX: call pargstr ("TY_COMPLEX") + case TY_STRUCT: call pargstr ("TY_STRUCT") + case TY_POINTER: call pargstr ("TY_POINTER") + } +end diff --git a/sys/nmemio/mgc.x b/sys/nmemio/mgc.x new file mode 100644 index 00000000..8ef2b58c --- /dev/null +++ b/sys/nmemio/mgc.x @@ -0,0 +1,222 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + + +# MGC Interface - Simple memory garbage collector interface. Our strategy +# here is simply to store the pointer and its type (so we can dereference to +# a host pointer). As pointers are allocated they are saved here, and when +# freed the pointer value is made negative to indicate it is invalid and +# that slot is available for later reuse. +# When a task completes, we run through the buffer looking for un-freed +# pointers and manually reclaim the space. This is not especially clever but +# we are only used (presumably by developers) when requested so normal use +# of MEMIO should see no added overhead. +# +# mgc_init () +# mgc_close () +# mgc_save (ptr, dtype) +# mgc_update (ptr) +# index = mgc_getindex (ptr) +# type = mgc_gettype (ptr) +# mgc_collect () + + +define SZ_GC_BUFFER 10240 + +# A zero-indexed structure saving the (ptr,type) pairs. +define GC_PTR Memi[$1+($2 * 2)] +define GC_TYPE Memi[$1+($2 * 2 + 1)] + + +# MGC_INIT -- Initialize the MGC interface. + +procedure mgc_init () + +include "nmemio.com" + +begin + if (mcollect > 0) + call calloc (mgc, SZ_GC_BUFFER, TY_STRUCT) + else + mgc = NULL +end + + +# MGC_CLOSE -- Close the MGC buffer. + +procedure mgc_close () + +include "nmemio.com" + +begin + if (mcollect > 0 && mgc != NULL) { + call mfree (mgc, TY_STRUCT) + mgc = NULL + } +end + + +# MGC_SAVE -- Save a pointer in the GC buffer. + +procedure mgc_save (ptr, dtype) + +pointer ptr #i pointer to save +int dtype #i pointer type + +int i, bmax + +include "nmemio.com" + +begin + if (mcollect <= 0 || mgc == NULL) + return + + bmax = SZ_GC_BUFFER - 1 + for (i=0; i < bmax; i=i+1) { + if (GC_PTR(mgc,i) <= 0) { + # Space is re-used if negative, otherwise first free slot. + GC_PTR(mgc,i) = ptr + GC_TYPE(mgc,i) = dtype + + if (mdebug > 0) { + call eprintf ("save %d: ptr 0x%x\n") + call pargi (i); call pargi (GC_PTR(mgc,i)) + } + return + } + } + + # If we get this far we've exhausted the GC buffer. Print a warning + # if reporting and just ignore it since the chances this would be + # a leaked pointer are rather small. + if (mreport > 0) + call eprintf ("Warning: GC buffer overflow\n") +end + + +# MGC_UPDATE -- Update the status of the pointer in the GC buffer. + +procedure mgc_update (ptr) + +pointer ptr #i pointer to save + +int i, bmax + +include "nmemio.com" + +begin + if (mgc == NULL || in_task == 0) + return + + if (in_task > 0 && mdebug > 0) { + call eprintf ("update 0x%x collect = %d\n") + call pargi (ptr) + call pargi (mcollect) + } + + bmax = SZ_GC_BUFFER - 1 + do i = 0, bmax { + if (GC_PTR(mgc,i) == ptr) { + if (in_task > 0 && mdebug > 0) { + call eprintf ("update %d: 0x%x %d\n") + call pargi (i); call pargi (GC_PTR(mgc,i)); call pargi (ptr) + } + GC_PTR(mgc,i) = (- ptr) + return + } + if (GC_PTR(mgc,i) == NULL) + return + } +end + + +# MGC_GETINDEX -- Given a pointer, return its GC index. + +int procedure mgc_getindex (ptr) + +pointer ptr #i pointer to save + +int i, bmax + +include "nmemio.com" + +begin + if (mcollect <= 0 || mgc == NULL) + return + + bmax = SZ_GC_BUFFER - 1 + do i = 0, bmax { + if (abs (GC_PTR(mgc,i)) == ptr) + return (i) + if (GC_PTR(mgc,i) == NULL) + return (NULL) + } + + return (NULL) +end + + +# MGC_GETTYPE -- Given a pointer, return its type. + +int procedure mgc_gettype (ptr) + +pointer ptr #i pointer to save + +int i, bmax + +include "nmemio.com" + +begin + if (mcollect <= 0 || mgc == NULL) + return + + bmax = SZ_GC_BUFFER - 1 + do i = 0, bmax { + if (abs (GC_PTR(mgc,i)) == ptr) + return (GC_TYPE(mgc,i)) + if (GC_PTR(mgc,i) == NULL) + return (NULL) + } + + return (NULL) +end + + +# MGC_COLLECT -- Do the final garbage collection. + +procedure mgc_collect () + +int i, bmax, nchars +pointer bp + +int sizeof () +pointer coerce () + +include "nmemio.com" + +begin + if (mcollect <= 0 || mgc == NULL) + return + mcollect = -1 + + bmax = SZ_GC_BUFFER - 1 + do i = 0, bmax { + if (GC_PTR(mgc,i) > 0) { + if (mdebug > 0) { + call eprintf ("collect %d: recovering ptr 0x%x\n") + call pargi (i); call pargi (GC_PTR(mgc,i)) + } + + bp = coerce (GC_PTR(mgc,i), GC_TYPE(mgc,i), TY_INT) + + nleaked = nleaked + 1 + nchars = Memi[bp - 2] * sizeof (GC_TYPE(mgc,i)) + leaked = leaked + (nchars * SZB_CHAR) + + call mfree (GC_PTR(mgc,i), GC_TYPE(mgc,i)) + + } else if (GC_PTR(mgc,i) == NULL) + return + } +end diff --git a/sys/nmemio/mgdptr.x b/sys/nmemio/mgdptr.x new file mode 100644 index 00000000..81328132 --- /dev/null +++ b/sys/nmemio/mgdptr.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# MGDPTR -- Given the fwa of a memory area, compute a pointer to the start +# of the data area which satisfies the desired alignment criteria. Memory +# is allocated in units of chars, and ZLOCVA, ZMALOC, etc., return pointers +# in units of chars. + +pointer procedure mgdptr (fwa, dtype, sz_align, fwa_align) + +int fwa, dtype, sz_align, fwa_align +long bufadr +pointer bufptr +int modulus, loc_Mem +int sizeof() +data loc_Mem /NULL/ + +begin + # Compute the address of the start of the user buffer area, which + # must be aligned with fwa_align (usually Mem) for all data types. + + if (loc_Mem == NULL) + call zlocva (Memc, loc_Mem) + bufadr = fwa + (5 * SZ_INT) + + modulus = mod (bufadr - fwa_align, sz_align) + if (modulus != 0) + bufadr = bufadr + (sz_align - modulus) + + # Compute the buffer pointer for the desired datatype. + bufptr = (bufadr - loc_Mem) / sizeof(dtype) + 1 + + return (bufptr) +end diff --git a/sys/nmemio/mgtfwa.x b/sys/nmemio/mgtfwa.x new file mode 100644 index 00000000..8d3452fd --- /dev/null +++ b/sys/nmemio/mgtfwa.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# MGTFWA -- Given a user buffer pointer, retrieve physical address of buffer. +# If physical address of buffer does not seem reasonable, memory has probably +# been overwritten, a fatal error. + +int procedure mgtfwa (ptr, dtype) + +pointer ptr, bufptr +int dtype +int locbuf, fwa +int coerce() + +begin + bufptr = coerce (ptr, dtype, TY_INT) + fwa = Memi[bufptr-5] + call zlocva (Memi[bufptr-5], locbuf) + + if (abs (locbuf - fwa) > (6 * SZ_VMEMALIGN)) + call sys_panic (SYS_MCORRUPTED, "Memory fwa has been corrupted") + + return (fwa) +end diff --git a/sys/nmemio/mgtlwl.x b/sys/nmemio/mgtlwl.x new file mode 100644 index 00000000..3a7d3ac1 --- /dev/null +++ b/sys/nmemio/mgtlwl.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# MGTLWL -- Given a user buffer pointer, retrieve location of the last word. + +int procedure mgtlwl (ptr, dtype) + +pointer ptr, bufptr +int dtype +int coerce() + +begin + bufptr = coerce (ptr, dtype, TY_INT) + return (Memi[bufptr-4]) +end diff --git a/sys/nmemio/minit.x b/sys/nmemio/minit.x new file mode 100644 index 00000000..06214137 --- /dev/null +++ b/sys/nmemio/minit.x @@ -0,0 +1,127 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + + +define L_SENTINAL 20030125 +define U_SENTINAL 20040922 + + +# MEM_INIT -- Initialize the MEMIO interface for the task. + +procedure mem_init (task) + +char task[ARB] # task name + +int mgtenv() + +include "nmemio.com" + +begin + # Initialize I/O buffers for stdout/stderr. We do this here to + # create the file buffers without counting these in the memory + # usage stats. +# call fmkbfs (STDOUT) +# call fmkbfs (STDERR) + + # Allocate the garbage collection buffer. + mcollect = mgtenv ("MEMIO_COLLECT") + call mgc_init() + + # Initialize the sentinal values. + lsentinal = L_SENTINAL + usentinal = U_SENTINAL + + mwatch = mgtenv ("MEMIO_WATCH") + mreport = mgtenv ("MEMIO_REPORT") + mclear = mgtenv ("MEMIO_CLEAR") + mdebug = mgtenv ("MEMIO_DEBUG") + + max_alloc = 0 + mem_used = 0 + leaked = 0 + nleaked = 0 + nalloc = 0 + nfree = 0 + + in_task = 1 +end + + +# MGTENV -- Get an environment variable for MEMIO control. + +int procedure mgtenv (varname) + +char varname[ARB] # env variable to find + +int ival, ip, status, junk +char key[SZ_LINE], value[SZ_LINE] + +int ctoi() + +begin + ip = 1 # init + ival = 0 + call aclrc (key, SZ_LINE) + call aclrc (value, SZ_LINE) + + call strpak (varname, key, SZ_LINE) + call zgtenv (key, value, SZ_LINE, status) + call strupk (value, value, SZ_LINE) + + if (status == 0) # variable defined w/out value + ival = 1 + else if (status > 0) # get environment variable value + junk = ctoi (value, ip, ival) + + return (ival) +end + + +# MEM_PTYPE -- Print a pointer type. Used in error messages. + +procedure mem_ptype (dtype) + +int dtype + +begin + switch (dtype) { + case TY_BOOL: call pargstr ("TY_BOOL") + case TY_CHAR: call pargstr ("TY_CHAR") + case TY_SHORT: call pargstr ("TY_SHORT") + case TY_INT: call pargstr ("TY_INT") + case TY_LONG: call pargstr ("TY_LONG") + case TY_REAL: call pargstr ("TY_REAL") + case TY_DOUBLE: call pargstr ("TY_DOUBLE") + case TY_COMPLEX: call pargstr ("TY_COMPLEX") + case TY_STRUCT: call pargstr ("TY_STRUCT") + case TY_POINTER: call pargstr ("TY_POINTER") + default: call pargstr ("unknown") + } +end + + +# MIO_INIT -- Initialize the MEMIO interface for the task. + +procedure mio_init () + +include "nmemio.com" + +begin + mgc = NULL + mcollect = 0 + mwatch = 0 + mreport = 0 + mclear = 0 + mdebug = 0 + + max_alloc = 0 + mem_used = 0 + leaked = 0 + nleaked = 0 + nalloc = 0 + nfree = 0 + + in_task = 0 +end diff --git a/sys/nmemio/mkpkg b/sys/nmemio/mkpkg new file mode 100644 index 00000000..94cfaed9 --- /dev/null +++ b/sys/nmemio/mkpkg @@ -0,0 +1,31 @@ +# Memory i/o (MEMIO) portion of the system library. + +$checkout libsys.a lib$ +$update libsys.a +$checkin libsys.a lib$ +$exit + +libsys.a: + #$set XFLAGS = "$(XFLAGS) -g" + + begmem.x + calloc.x + coerce.x + kmalloc.x + krealloc.x + malloc1.x nmemio.com + malloc.x + merror.x nmemio.com + mfini.x nmemio.com + mfree.x nmemio.com + mgc.x nmemio.com + mgdptr.x + mgtfwa.x + mgtlwl.x + minit.x nmemio.com + msvfwa.x nmemio.com + realloc.x + salloc.x + sizeof.x + vmalloc.x + ; diff --git a/sys/nmemio/msvfwa.x b/sys/nmemio/msvfwa.x new file mode 100644 index 00000000..cd3313c5 --- /dev/null +++ b/sys/nmemio/msvfwa.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + + +# MSVFWA -- Determine the buffer address which satisfies the maximum alignment +# criteria, save the buffer fwa in the integer cell immediately preceding +# this, and return a pointer to the user area of the buffer. + +pointer procedure msvfwa (fwa, dtype, nelem, sz_align, fwa_align) + +int fwa, dtype, nelem, sz_align, fwa_align, nbits +pointer bufptr, lwl, offset + +pointer mgdptr() +int coerce(), sizeof() + +include "nmemio.com" + +begin + # Compute the pointer to the data area which satisfies the desired + # alignment criteria. Store the fwa of the actual OS allocated buffer + # in the integer cell preceeding the data area. + + bufptr = mgdptr (fwa, TY_INT, sz_align, fwa_align) + + nbits = sizeof(TY_INT) * 8 * SZB_CHAR + if (nbits == 64) { + if (sizeof (dtype) == sizeof (TY_CHAR)) + offset = (nelem / SZ_INT + 1) + else if (sizeof (dtype) == sizeof (TY_REAL)) + offset = (nelem / SZ_REAL + 1) + else + offset = nelem + + } else if (nbits == 32) { + + if (sizeof(dtype) < sz_align) + offset = (nelem / (SZ_INT / sizeof(dtype))) + 1 + else + offset = (nelem * sizeof (dtype)) / SZB_CHAR + } + + lwl = bufptr + offset + + Memi[bufptr-5] = fwa # first word address + Memi[bufptr-4] = lwl # last word location + Memi[bufptr-3] = dtype # data type + Memi[bufptr-2] = nelem # no. of elements + Memi[bufptr-1] = lsentinal # lower sentinal + Memi[lwl] = usentinal # upper sentinal + + # Return pointer of type dtype to the first cell of the data area. + return (coerce (bufptr, TY_INT, dtype)) +end diff --git a/sys/nmemio/nmemio.com b/sys/nmemio/nmemio.com new file mode 100644 index 00000000..126475c0 --- /dev/null +++ b/sys/nmemio/nmemio.com @@ -0,0 +1,26 @@ + +int mclear # clear newly allocated memory? +int mwatch # check buffer sentinals on FREE? +int mcollect # garbage collect on exit? +int mreport # report memio usage stats? + +int lsentinal # lower sentinal value +int usentinal # upper sentinal value + +long mem_used # total mem usage +long max_alloc # largest allocated pointer size +long leaked # total leaked bytes +int nleaked # number leaked pointers +int nalloc # total number of allocations +int nfree # total number of frees + +int mdebug # debugging memory use in tasks? +int in_task # in task or iraf main? + +pointer mgc # garbage collection buffer + +# Debug common +common /nmemio/ mclear, mwatch, mcollect, mreport, lsentinal, usentinal, + mem_used, max_alloc, nleaked, leaked, nalloc, nfree, + mdebug, in_task, mgc + diff --git a/sys/nmemio/realloc.x b/sys/nmemio/realloc.x new file mode 100644 index 00000000..40229b8f --- /dev/null +++ b/sys/nmemio/realloc.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# REALLOC -- Change the size of a previously allocated buffer, moving the +# buffer if necessary. If there is no old buffer (NULL pointer) simply +# allocate a new buffer. + +procedure realloc (ubufp, nelems, dtype) + +pointer ubufp # buffer to be reallocated +int nelems # new size of buffer +int dtype # buffer datatype + +int krealloc() + +begin + if (krealloc (ubufp, nelems, dtype) == ERR) { + ubufp = NULL + call syserr (SYS_MFULL) + } +end diff --git a/sys/nmemio/salloc.x b/sys/nmemio/salloc.x new file mode 100644 index 00000000..34f06217 --- /dev/null +++ b/sys/nmemio/salloc.x @@ -0,0 +1,155 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# SALLOC.X -- Stack management routines. Stack storage is allocated in +# segments. Space for each segment is dynamically allocated on the heap. +# Each segment contains a pointer to the previous segment to permit +# reclamation of the space (see "Mem.hlp" for additional details). +# This is a low level facility, hence any failure to allocate or deallocate +# stack storage is fatal. + + +# Segment header structure. The header size parameter SZ_STKHDR is defined +# in because it is potentially machine dependent. SZ_STKHDR +# must be chosen such that the maximum alignment criteria is maintained. + +define SH_BASE Memi[$1] # char pointer to base of segment +define SH_TOP Memi[$1+1] # char pointer to top of segment + 1 +define SH_OLDSEG Memi[$1+2] # struct pointer to header of prev.seg. + + +# SALLOC -- Allocate space on the stack. + +procedure salloc (output_pointer, nelem, datatype) + +pointer output_pointer # buffer pointer (output) +int nelem # number of elements of storage required +int datatype # datatype of the storage elements + +int nchars, dtype +include +pointer sp, cur_seg +common /salcom/ sp, cur_seg + +begin + dtype = datatype + if (dtype < 1 || dtype > MAX_DTYPE) + call sys_panic (500, "salloc: bad datatype code") + + # Align stack pointer for any data type. Compute amount of + # storage to be allocated. Always add space for at least one + # extra char for the EOS in case a string is stored in the buffer. + + sp = (sp + SZ_MEMALIGN-1) / SZ_MEMALIGN * SZ_MEMALIGN + 1 + if (dtype == TY_CHAR) + nchars = nelem + 1 # add space for EOS + else + nchars = nelem * ty_size[dtype] + 1 + + # Check for stack overflow, add new segment if out of room. + # Since SMARK must be called before SALLOC, cur_seg cannot be + # null, but we check anyhow. + + if (cur_seg == NULL || sp + nchars >= SH_TOP(cur_seg)) + call stk_mkseg (cur_seg, sp, nchars) + + if (dtype == TY_CHAR) + output_pointer = sp + else + output_pointer = (sp-1) / ty_size[dtype] + 1 + + sp = sp + nchars # bump stack pointer +end + + +# SMARK -- Mark the position of the stack pointer, so that stack space +# can be freed by a subsequent call to SFREE. This routine also performs +# initialization of the stack, since it the very first routine called +# during task startup. + +procedure smark (old_sp) + +pointer old_sp # value of the stack pointer (output) +bool first_time +pointer sp, cur_seg +common /salcom/ sp, cur_seg +data first_time /true/ + +begin + if (first_time) { + sp = NULL + cur_seg = NULL + call stk_mkseg (cur_seg, sp, SZ_STACK) + first_time = false + } + + old_sp = sp +end + + +# SFREE -- Free space on the stack. Return whole segments until segment +# containing the old stack pointer is reached. + +procedure sfree (old_sp) + +pointer old_sp # previous value of the stack pointer + +pointer old_seg +pointer sp, cur_seg +common /salcom/ sp, cur_seg + +begin + # The following is needed to avoid recursion when SFREE is called + # by the IRAF main during processing of SYS_MSSTKUNFL. + + if (cur_seg == NULL) + return + + # If the stack underflows (probably because of an invalid pointer) + # it is a fatal error. + + while (old_sp < SH_BASE(cur_seg) || old_sp > SH_TOP(cur_seg)) { + if (SH_OLDSEG(cur_seg) == NULL) + call sys_panic (SYS_MSSTKUNFL, "Salloc underflow") + + old_seg = SH_OLDSEG(cur_seg) # discard segment + call mfree (cur_seg, TY_STRUCT) + cur_seg = old_seg + } + + sp = old_sp # pop stack +end + + +# STK_MKSEG -- Create and add a new stack segment (link at head of the +# segment list). Called during initialization, and upon stack overflow. + +procedure stk_mkseg (cur_seg, sp, segment_size) + +pointer cur_seg # current segment +pointer sp # salloc stack pointer +int segment_size # size of new stack segment + +int nchars, new_seg +pointer coerce() +int kmalloc() + +begin + # Compute size of new segment, allocate the buffer. + nchars = max (SZ_STACK, segment_size) + SZ_STKHDR + if (kmalloc (new_seg, nchars / SZ_STRUCT, TY_STRUCT) == ERR) + call sys_panic (SYS_MFULL, "Out of memory") + + # Output new stack pointer. + sp = coerce (new_seg, TY_STRUCT, TY_CHAR) + SZ_STKHDR + + # Set up the segment descriptor. + SH_BASE(new_seg) = sp + SH_TOP(new_seg) = sp - SZ_STKHDR + nchars + SH_OLDSEG(new_seg) = cur_seg + + # Make new segment the current segment. + cur_seg = new_seg +end diff --git a/sys/nmemio/sizeof.x b/sys/nmemio/sizeof.x new file mode 100644 index 00000000..3b4977fe --- /dev/null +++ b/sys/nmemio/sizeof.x @@ -0,0 +1,12 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# SIZEOF -- Return the size in chars of one of the fundamental datatypes. + +int procedure sizeof (dtype) + +int dtype +include + +begin + return (ty_size[dtype]) +end diff --git a/sys/nmemio/vmalloc.x b/sys/nmemio/vmalloc.x new file mode 100644 index 00000000..25e2de0d --- /dev/null +++ b/sys/nmemio/vmalloc.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# VMALLOC -- Like malloc, but force the buffer to be aligned on a virtual +# memory page boundary. This feature can be used, e.g., in 4.XBSD UNIX +# to "bypass" the system buffer cache (to avoid copying file data from the +# system cache into the file buffer). VMALLOC can be made equivalent to MALLOC +# via the parameters in , if the local machine which does not have +# virtual memory. + +procedure vmalloc (ubufp, nelems, dtype) + +pointer ubufp # user buffer pointer (output) +int nelems # number of elements of storage required +int dtype # datatype of the storage elements + +int sz_align, fwa_align +int malloc1() + +begin + sz_align = SZ_VMEMALIGN + fwa_align = VMEM_BASE + if (malloc1 (ubufp, nelems, dtype, sz_align, fwa_align) == ERR) + call syserr (SYS_MFULL) +end diff --git a/sys/nmemio/zz.x b/sys/nmemio/zz.x new file mode 100644 index 00000000..c81f1506 --- /dev/null +++ b/sys/nmemio/zz.x @@ -0,0 +1,11 @@ +task hello = t_hello + +procedure t_hello() +pointer t1, t2 +begin + call malloc (t1, SZ_LINE, TY_CHAR) + call mfree (t1, TY_CHAR) + + call malloc (t2, SZ_LINE, TY_INT) + call mfree (t2, TY_INT) +end diff --git a/sys/nmemio/zzdebug.x b/sys/nmemio/zzdebug.x new file mode 100644 index 00000000..556c4fa1 --- /dev/null +++ b/sys/nmemio/zzdebug.x @@ -0,0 +1,86 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# Debug MEMIO. + +task stack=t_stack, realloc=t_realloc + + +# Test the SALLOC routine, which allocates storage on the stack. + +procedure t_stack + +int bufsize +pointer sp, junk +int clglpi() + +begin + call smark (sp) + + while (clglpi ("buffer_size", bufsize) != EOF) { + call salloc (junk, bufsize, TY_CHAR) + call printf ("buffer pointer=%d, size=%d\n") + call pargi (junk) + call pargi (bufsize) + call flush (STDOUT) + } + + call sfree (sp) +end + + +# Test the REALLOC procedure, used to change the size of a buffer. +# Work with two buffers, so that memory can be fragmented, forcing buffers +# to move. + +procedure t_realloc() + +pointer a, b +int sza, new_sza, szb, new_szb +int clgeti() + +begin + call malloc (a, SZ_LINE, TY_CHAR) + call strcpy ("abcdefghijk", Memc[a], ARB) + sza = SZ_LINE + call malloc (b, SZ_LINE, TY_CHAR) + call strcpy ("0123456789", Memc[b], ARB) + szb = SZ_LINE + + call eprintf ("a is at %d, size %d: %s\n") + call pargi (a) + call pargi (sza) + call pargstr (Memc[a]) + call eprintf ("b is at %d, size %d: %s\n") + call pargi (b) + call pargi (szb) + call pargstr (Memc[b]) + call eprintf ("-------------------------------\n") + + repeat { + new_sza = clgeti ("a_bufsize") + if (new_sza == 0) + return + call x_realloc (a, new_sza, TY_CHAR) + new_szb = clgeti ("b_bufsize") + if (new_szb == 0) + return + call x_realloc (b, new_szb, TY_CHAR) + + call eprintf ("a buf %d, size %d --> %d: %s\n") + call pargi (a) + call pargi (sza) + call pargi (new_sza) + call pargstr (Memc[a]) + call eprintf ("b buf %d, size %d --> %d: %s\n") + call pargi (b) + call pargi (szb) + call pargi (new_szb) + call pargstr (Memc[b]) + + sza = new_sza + szb = new_szb + } + + call mfree (a, TY_CHAR) + call mfree (b, TY_CHAR) +end diff --git a/sys/nmemio/zzfoo.gx b/sys/nmemio/zzfoo.gx new file mode 100644 index 00000000..5de60c5b --- /dev/null +++ b/sys/nmemio/zzfoo.gx @@ -0,0 +1,587 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# Test procedures for the NMEMIO interface. +# + +include + + +define MT_HEAP 0 # test heap memory +define MT_STACK 1 # test stack memory + + +task memtest = t_memtest, + stack = t_stack, + realloc = t_realloc + + +# MEMTEST -- Task to test new memio interface. + +procedure t_memtest () + +int model, nerr +pointer str, ptr + +bool clgetb() + +begin + if (clgetb ("stack")) + model = MT_STACK + else + model = MT_HEAP + + # Check we can allocate a large array. + if (model == MT_HEAP) { + call eprintf ("\nBegin large heap malloc tests ....\n\n") + call malloc (str, 256000, TY_STRUCT) + call mfree (str, TY_STRUCT) + call eprintf ("Done\n\n") + + # Print the memory layout. + $for (csiblrdx) + call mt_print (TY_PIXEL) + $endfor + call mt_print (TY_STRUCT) + call mt_print (TY_POINTER) + } + + # Test Mem common assignments + call eprintf ("\nBegin assignment tests ....\n\n"); + call mt_auto_b ("bool ", model) + call mt_auto_c ("char ", model) + call mt_auto_s ("short ", model) + call mt_auto_i ("int ", model) + call mt_auto_l ("long ", model) + call mt_auto_r ("real ", model) + call mt_auto_d ("double ", model) + call mt_auto_x ("complex", model) + call eprintf ("\nEnd assignment tests ....\n\n"); + + + # Test string memory + call eprintf ("Begin Memc test\t\t"); + call calloc (str, SZ_LINE, TY_CHAR) + call aclrc (Memc[str], SZ_LINE) + call strcpy ("test string", Memc[str], SZ_LINE) + call eprintf ("str = '%s' ch[2] = '%c' (should be 's')\n") + call pargstr (Memc[str]) + call pargc (Memc[str+2]) + call mfree (str, TY_CHAR) + + + # Test the struct memory + call eprintf ("\n\n") + call eprintf ("Begin struct test\n") + call mt_struct (model) + call eprintf ("Done\n") + + + # Test memory overflow and then underflow detection. + call eprintf ("\n\n") + call eprintf ("Testing overflow:\t") + nerr = 0 + $for (csiblrdx) + iferr ( call mt_overflow (TY_PIXEL) ) + nerr = nerr + 1; + $endfor + iferr ( call mt_overflow (TY_STRUCT) ) + nerr = nerr + 1; + iferr ( call mt_overflow (TY_POINTER) ) + nerr = nerr + 1; + call eprintf ("No. errors detected = %d of 10\t\tDone\n") + call pargi (nerr) + + + call eprintf ("Testing underflow:\t") + nerr = 0 + $for (csiblrdx) + iferr ( call mt_underflow (TY_PIXEL) ) + nerr = nerr + 1; + $endfor + iferr ( call mt_underflow (TY_STRUCT) ) + nerr = nerr + 1; + iferr ( call mt_underflow (TY_POINTER) ) + nerr = nerr + 1; + call eprintf ("No. errors detected = %d of 10\t\tDone\n") + call pargi (nerr) + + + # Note this test will leak 1024 bytes because of the error recovery. + call eprintf ("Testing invalid free:\t") + call calloc (ptr, 256, TY_REAL) + iferr ( call mfree (ptr, TY_INT) ) + call eprintf ("Detected\t\t\t\t") + else + call eprintf ("Undetected\t\t\t\t") + call eprintf ("Done\n") + + call eprintf ("Testing double free:\t") + call calloc (ptr, 256, TY_INT) + call mfree (ptr, TY_INT) + iferr ( call mfree (ptr, TY_INT) ) + call eprintf ("Detected\t\t\t\t") + else + call eprintf ("Undetected\t\t\t\t") + call eprintf ("Done\n") + + call eprintf ("Testing NULL free:\t") + iferr ( call mfree (NULL, TY_INT) ) + call eprintf ("Detected\t\t\t\t") + else + call eprintf ("Undetected\t\t\t\t") + call eprintf ("Done\n") + + call eprintf ("Testing recovered free:\n") + call calloc (str, SZ_LINE, TY_CHAR) + call eprintf ("Done\n") + + call eprintf ("\n\nEnd of NMEMIO tests\n") +end + + + +# Test the SALLOC routine, which allocates storage on the stack. + +procedure t_stack () + +int bufsize +pointer sp, junk +int clglpi() + +begin + call smark (sp) + + while (clglpi ("buffer_size", bufsize) != EOF) { + call salloc (junk, bufsize, TY_CHAR) + call printf ("buffer pointer=%d, size=%d\n") + call pargi (junk) + call pargi (bufsize) + call flush (STDOUT) + } + + call sfree (sp) +end + + +# Test the REALLOC procedure, used to change the size of a buffer. +# Work with two buffers, so that memory can be fragmented, forcing buffers +# to move. + +procedure t_realloc() + +pointer a, b +int i, sza, new_sza, szb, new_szb + +begin + sza = SZ_FNAME + szb = SZ_LINE + + call malloc (a, sza, TY_CHAR) + call malloc (b, szb, TY_CHAR) + call strcpy ("abcdefghijk", Memc[a], ARB) + call strcpy ("0123456789", Memc[b], ARB) + + call eprintf ("a is at %d, size %d: %s\n") + call pargi (a) + call pargi (sza) + call pargstr (Memc[a]) + call eprintf ("b is at %d, size %d: %s\n") + call pargi (b) + call pargi (szb) + call pargstr (Memc[b]) + call eprintf ("-------------------------------\n") + + for (i=1; i <= 10; i=i+1) { + if (i < 5) { + new_sza = sza + 512 ; new_szb = szb + 256 + } else { + new_sza = sza + 256 ; new_szb = szb + 512 + } + call realloc (a, new_sza, TY_CHAR) + call realloc (b, new_szb, TY_CHAR) + + call eprintf ("%2d: a buf %d, size %d --> %d: %s\n") + call pargi (i) + call pargi (a) + call pargi (sza) + call pargi (new_sza) + call pargstr (Memc[a]) + call eprintf ("%2d: b buf %d, size %d --> %d: %s\n") + call pargi (i) + call pargi (b) + call pargi (szb) + call pargi (new_szb) + call pargstr (Memc[b]) + + sza = new_sza + szb = new_szb + } + + call mfree (a, TY_CHAR) + call mfree (b, TY_CHAR) +end + + + +define SZ_TEST 640 +define F_I1 Memi[$1] +define F_I2 Memi[$1+1] +define F_L1 Meml[$1+2] +define F_L2 Meml[$1+3] +define F_R1 Memr[$1+4] +define F_R2 Memr[$1+5] +define F_D1 Memd[P2D($1+8)] +define F_D2 Memd[P2D($1+10)] +define F_I3 Memi[$1+12] +define F_I4 Memi[$1+13] +define F_S1 Mems[P2S($1+14)] +define F_S2 Mems[P2S($1+15)] + + +procedure mt_struct (model) + +int model + +pointer sp, str +real x, y, z +double d1, d2, d3 + +int locva() + +begin + if (model == MT_HEAP) { + call malloc (str, SZ_TEST, TY_STRUCT) + } else { + call smark (sp) + call salloc (str, SZ_TEST, TY_STRUCT) + } + + + F_I1(str) = 1 + F_I2(str) = 2 + F_L1(str) = 3 + F_L2(str) = 4 + F_R1(str) = 5.0 + F_R2(str) = 6.0 + F_D1(str) = 7.0 + F_D2(str) = 8.0 + F_I3(str) = 9 + F_I4(str) = 10 + F_S1(str) = 11 + F_S2(str) = 12 + + x = 2.717 ; d1 = F_R1(str) + y = 2.717 ; d2 = 3.14159d0 ; + z = double(x) ; d3 = double(3.14159) + + call eprintf ("\nd1=%.6g d2=%.6g d3=%.6g x=%.6g y=%.6g z=%.6g)\n\n") + call pargd (d1) ; call pargd (d2) ; call pargd (d3) + call pargr (x) ; call pargr (y) ; call pargr (z) + + call eprintf ("Done Setting values ....\n\ntest = %d %d %d\n\n") + call pargi (str) + call pargi (locva(str)) + call pargi (locva(F_I1(str))) + + # call mdump (str, 64) + + call eprintf ("I1 = %4d I2 = %4d \t%d %d\n") + call pargi (F_I1(str)) ; call pargi (F_I2(str)) + call pargi (locva(F_I1(str))) ; call pargi (locva(F_I2(str))) + + call eprintf ("L1 = %4d L2 = %4d \t%d %d\n") + call pargl (F_L1(str)) ; call pargl (F_L2(str)) + call pargi (locva(F_L1(str))) ; call pargi (locva(F_L2(str))) + + call eprintf ("R1 = %4.1f R2 = %4.1f \t%d %d\n") + call pargr (F_R1(str)) ; call pargr (F_R2(str)) + call pargi (locva(F_R1(str))) ; call pargi (locva(F_R2(str))) + + call eprintf ("D1 = %4.1f D2 = %4.1f \t%d %d\n") + call pargd (F_D1(str)) ; call pargd (F_D2(str)) + call pargi (locva(F_D1(str))) ; call pargi (locva(F_D2(str))) + + call eprintf ("I3 = %4d I4 = %4d \t%d %d\n") + call pargi (F_I3(str)) ; call pargi (F_I4(str)) + call pargi (locva(F_I3(str))) ; call pargi (locva(F_I4(str))) + + call eprintf ("S1 = %4d S2 = %4d \t%d %d\n") + call pargs (F_S1(str)) ; call pargs (F_S2(str)) + call pargi (locva(F_S1(str))) ; call pargi (locva(F_S2(str))) + + + if (model == MT_HEAP) + call mfree (str, TY_STRUCT) + else + call sfree (sp) +end + + +define NVALS 3 + +procedure mt_print (dtype) + +int dtype + +int i, locva(), coerce() +real x +double xx +pointer p, bp, lwl + +begin + call calloc (p, NVALS, dtype) + bp = coerce (p, dtype, TY_INT) + + # Set the values. + for (i=0; i < NVALS; i=i+1) { + x = i ; xx = i + switch (dtype) { + case TY_BOOL: Memb[p+i] = TRUE + case TY_CHAR: Memc[p+i] = 'a' + i + case TY_SHORT: Mems[p+i] = i + case TY_INT: Memi[p+i] = i + case TY_LONG: Meml[p+i] = i + case TY_REAL: Memr[p+i] = x + case TY_DOUBLE: Memd[p+i] = xx + case TY_COMPLEX: Memx[p+i] = cmplx(x,-x) + + case TY_STRUCT: Memi[p+i] = i + case TY_POINTER: Memi[p+i] = i + } + } + + # Print the ptr header. + call eprintf ("\n") + call eprintf (" p = 0x%-15x %-16d\t%d\n") + call pargi (p) ; call pargi (p) ; call pargi (locva(Memi[bp])) + call eprintf (" fwa = 0x%-15x %-16d\t%d\n") + call pargi (bp-5) ; call pargi (Memi[bp-5]) + call pargi (locva (Memi[bp-5])) + call eprintf (" lwl = 0x%-15x %-16d\t%d\n") + call pargi (bp-4) ; call pargi (Memi[bp-4]) + call pargi (locva (Memi[bp-4])) + call eprintf (" dtype = 0x%-15x %-16d\t%d\n") + call pargi (bp-3) ; call mptype (dtype) + call pargi (locva (Memi[bp-3])) + call eprintf (" nelem = 0x%-15x %-16d\t%d\n") + call pargi (bp-2) ; call pargi (Memi[bp-2]) + call pargi (locva (Memi[bp-2])) + call eprintf ("L sentinal = 0x%-15x %-16d\t%d\n") + call pargi (bp-1) ; call pargi (Memi[bp-1]) + call pargi (locva (Memi[bp-1])) + + + # Print the values. + call eprintf (" data = ") + for (i=0; i < NVALS; i=i+1) { + switch (dtype) { + case TY_BOOL: + call eprintf (" %3b\t\t\t\t\t%-15d") + call pargb (Memb[p+i]) + call pargi (locva(Memb[p+i])) + case TY_CHAR: + call eprintf (" %3c\t\t\t\t\t%-15d") + call pargc (Memc[p+i]) + call pargi (locva(Memc[p+i])) + case TY_SHORT: + call eprintf (" %3d\t\t\t\t\t%-15d") + call pargs (Mems[p+i]) + call pargi (locva(Mems[p+i])) + case TY_INT: + call eprintf (" %3d\t\t\t\t\t%-15d") + call pargi (Memi[p+i]) + call pargi (locva(Memi[p+i])) + case TY_LONG: + call eprintf (" %3d\t\t\t\t\t%-15d") + call pargl (Meml[p+i]) + call pargi (locva(Meml[p+i])) + case TY_REAL: + call eprintf (" %3g\t\t\t\t\t%-15d") + call pargr (Memr[p+i]) + call pargi (locva(Memr[p+i])) + case TY_DOUBLE: + call eprintf (" %3g\t\t\t\t\t%-15d") + call pargd (Memd[p+i]) + call pargi (locva(Memd[p+i])) + case TY_COMPLEX: + call eprintf (" %3x\t\t\t\t\t%-15d") + call pargx (Memx[p+i]) + call pargi (locva(Memx[p+i])) + case TY_STRUCT: + call eprintf (" %3d\t\t\t\t\t%-15d") + call pargi (Memi[p+i]) + call pargi (locva(Memi[p+i])) + case TY_POINTER: + call eprintf (" %3d\t\t\t\t\t%-15d") + call pargi (Memi[p+i]) + call pargi (locva(Memi[p+i])) + } + call eprintf ("\n") + if (i < (NVALS-1)) + call eprintf ("\t\t") + } + + lwl = Memi[bp-4] + call eprintf ("U sentinal = 0x%-15x %-15d\t\t%d\n\n") + call pargi (lwl) ; call pargi (Memi[lwl]) + call pargi (locva (Memi[lwl])) + + call mfree (p, dtype) +end + + +procedure mt_overflow (dtype) + +int dtype + +int i +real x +double xx +pointer p + +begin + call calloc (p, NVALS, dtype) + + # Set the values. + for (i=0; i < NVALS + 4; i=i+1) { + x = i ; xx = i + switch (dtype) { + case TY_BOOL: Memb[p+i] = TRUE + case TY_CHAR: Memc[p+i] = 'a' + i + case TY_SHORT: Mems[p+i] = i + case TY_INT: Memi[p+i] = i + case TY_LONG: Meml[p+i] = i + case TY_REAL: Memr[p+i] = x + case TY_DOUBLE: Memd[p+i] = xx + case TY_COMPLEX: Memx[p+i] = cmplx(x,-x) + case TY_STRUCT: Memi[p+i] = i + case TY_POINTER: Memi[p+i] = i + } + } + + call mfree (p, dtype) +end + + +procedure mt_underflow (dtype) + +int dtype + +int i +real x +double xx +pointer p + +begin + call calloc (p, NVALS, dtype) + + # Set the values. + for (i=0; i < NVALS; i=i+1) { + x = i ; xx = i + switch (dtype) { + case TY_BOOL: Memb[p+i] = TRUE ; Memb[p-1] = FALSE + case TY_CHAR: Memc[p+i] = 'a' + i ; Memc[p-1] = '0' + case TY_SHORT: Mems[p+i] = i ; Mems[p-1] = 999 + case TY_INT: Memi[p+i] = i ; Memi[p-1] = 999 + case TY_LONG: Meml[p+i] = i ; Meml[p-1] = 999 + case TY_REAL: Memr[p+i] = x ; Memr[p-1] = 999 + case TY_DOUBLE: Memd[p+i] = xx ; Memd[p-1] = 999 + case TY_COMPLEX: Memx[p+i] = cmplx(x,-x) ; Memx[p-1] = 999 + case TY_STRUCT: Memi[p+i] = i ; Memi[p-1] = 999 + case TY_POINTER: Memi[p+i] = i ; Memi[p-1] = 999 + } + } + + call mfree (p, dtype) +end + + +procedure mptype (dtype) +int dtype +begin + switch (dtype) { + case TY_BOOL: call pargstr ("TY_BOOL ") + case TY_CHAR: call pargstr ("TY_CHAR ") + case TY_SHORT: call pargstr ("TY_SHORT ") + case TY_INT: call pargstr ("TY_INT ") + case TY_LONG: call pargstr ("TY_LONG ") + case TY_REAL: call pargstr ("TY_REAL ") + case TY_DOUBLE: call pargstr ("TY_DOUBLE ") + case TY_COMPLEX: call pargstr ("TY_COMPLEX") + case TY_STRUCT: call pargstr ("TY_STRUCT ") + case TY_POINTER: call pargstr ("TY_POINTER") + } +end + + + +# Generic Mem_ test assignment. + +define NAVALS 4 + +$for (bcsilrdx) + +procedure mt_auto_$t (ty, model) + +char ty[ARB] +int model + +int i +real x +pointer sp, ip + +begin + call eprintf (" %s\t ") + call pargstr (ty) + + if (model == MT_HEAP) { + call malloc (ip, NAVALS, TY_PIXEL) + } else { + call smark (sp) + call salloc (ip, NAVALS, TY_PIXEL) + } + + + call eprintf ("0x%-15x %-15d\t ") + call pargi(ip) + call pargi(ip) + + x = 0.0 + $if (datatype == b) + for (i=0; i < NAVALS; i=i+1) + Mem$t[ip+i] = TRUE + call eprintf ("[ %b %b %b %b ]\n") + $endif + $if (datatype == c) + for (i=0; i < NAVALS; i=i+1) + Mem$t[ip+i] = 'a' + i + call eprintf ("[ %-3c %-3c %-3c %-3c ]\n") + $endif + $if (datatype == x) + for (i=0; i < NAVALS; i=i+1) { + x = i + Mem$t[ip+i] = cmplx(x,0.1) + } + call eprintf ("[ %x %x %x %x ]\n") + $endif + $if (datatype == sil) + for (i=0; i < NAVALS; i=i+1) + Mem$t[ip+i] = i + call eprintf ("[ %-3d %-3d %-3d %-3d ]\n") + $endif + $if (datatype == rd) + for (i=0; i < NAVALS; i=i+1) + Mem$t[ip+i] = i + call eprintf ("[ %-3g %-3g %-3g %-3g ]\n") + $endif + for (i=0; i < NAVALS; i=i+1) + call parg$t (Mem$t[ip+i]) + + + if (model == MT_HEAP) + call mfree (ip, TY_PIXEL) + else + call sfree (sp) +end + +$endfor diff --git a/sys/nmemio/zzfoo.x b/sys/nmemio/zzfoo.x new file mode 100644 index 00000000..a9e51dcf --- /dev/null +++ b/sys/nmemio/zzfoo.x @@ -0,0 +1,908 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# Test procedures for the NMEMIO interface. +# + +include + + +define MT_HEAP 0 # test heap memory +define MT_STACK 1 # test stack memory + + +task memtest = t_memtest, + stack = t_stack, + realloc = t_realloc + + +# MEMTEST -- Task to test new memio interface. + +procedure t_memtest () + +int model, nerr +pointer str, ptr + +bool clgetb() + +begin + if (clgetb ("stack")) + model = MT_STACK + else + model = MT_HEAP + + # Check we can allocate a large array. + if (model == MT_HEAP) { + call eprintf ("\nBegin large heap malloc tests ....\n\n") + call malloc (str, 256000, TY_STRUCT) + call mfree (str, TY_STRUCT) + call eprintf ("Done\n\n") + + # Print the memory layout. + + call mt_print (TY_CHAR) + + call mt_print (TY_SHORT) + + call mt_print (TY_INT) + + call mt_print (TY_BOOL) + + call mt_print (TY_LONG) + + call mt_print (TY_REAL) + + call mt_print (TY_DOUBLE) + + call mt_print (TY_COMPLEX) + + call mt_print (TY_STRUCT) + call mt_print (TY_POINTER) + } + + # Test Mem common assignments + call eprintf ("\nBegin assignment tests ....\n\n"); + call mt_auto_b ("bool ", model) + call mt_auto_c ("char ", model) + call mt_auto_s ("short ", model) + call mt_auto_i ("int ", model) + call mt_auto_l ("long ", model) + call mt_auto_r ("real ", model) + call mt_auto_d ("double ", model) + call mt_auto_x ("complex", model) + call eprintf ("\nEnd assignment tests ....\n\n"); + + + # Test string memory + call eprintf ("Begin Memc test\t\t"); + call calloc (str, SZ_LINE, TY_CHAR) + call aclrc (Memc[str], SZ_LINE) + call strcpy ("test string", Memc[str], SZ_LINE) + call eprintf ("str = '%s' ch[2] = '%c' (should be 's')\n") + call pargstr (Memc[str]) + call pargc (Memc[str+2]) + call mfree (str, TY_CHAR) + + + # Test the struct memory + call eprintf ("\n\n") + call eprintf ("Begin struct test\n") + call mt_struct (model) + call eprintf ("Done\n") + + + # Test memory overflow and then underflow detection. + call eprintf ("\n\n") + call eprintf ("Testing overflow:\t") + nerr = 0 + + iferr ( call mt_overflow (TY_CHAR) ) + nerr = nerr + 1; + + iferr ( call mt_overflow (TY_SHORT) ) + nerr = nerr + 1; + + iferr ( call mt_overflow (TY_INT) ) + nerr = nerr + 1; + + iferr ( call mt_overflow (TY_BOOL) ) + nerr = nerr + 1; + + iferr ( call mt_overflow (TY_LONG) ) + nerr = nerr + 1; + + iferr ( call mt_overflow (TY_REAL) ) + nerr = nerr + 1; + + iferr ( call mt_overflow (TY_DOUBLE) ) + nerr = nerr + 1; + + iferr ( call mt_overflow (TY_COMPLEX) ) + nerr = nerr + 1; + + iferr ( call mt_overflow (TY_STRUCT) ) + nerr = nerr + 1; + iferr ( call mt_overflow (TY_POINTER) ) + nerr = nerr + 1; + call eprintf ("No. errors detected = %d of 10\t\tDone\n") + call pargi (nerr) + + + call eprintf ("Testing underflow:\t") + nerr = 0 + + iferr ( call mt_underflow (TY_CHAR) ) + nerr = nerr + 1; + + iferr ( call mt_underflow (TY_SHORT) ) + nerr = nerr + 1; + + iferr ( call mt_underflow (TY_INT) ) + nerr = nerr + 1; + + iferr ( call mt_underflow (TY_BOOL) ) + nerr = nerr + 1; + + iferr ( call mt_underflow (TY_LONG) ) + nerr = nerr + 1; + + iferr ( call mt_underflow (TY_REAL) ) + nerr = nerr + 1; + + iferr ( call mt_underflow (TY_DOUBLE) ) + nerr = nerr + 1; + + iferr ( call mt_underflow (TY_COMPLEX) ) + nerr = nerr + 1; + + iferr ( call mt_underflow (TY_STRUCT) ) + nerr = nerr + 1; + iferr ( call mt_underflow (TY_POINTER) ) + nerr = nerr + 1; + call eprintf ("No. errors detected = %d of 10\t\tDone\n") + call pargi (nerr) + + + # Note this test will leak 1024 bytes because of the error recovery. + call eprintf ("Testing invalid free:\t") + call calloc (ptr, 256, TY_REAL) + iferr ( call mfree (ptr, TY_INT) ) + call eprintf ("Detected\t\t\t\t") + else + call eprintf ("Undetected\t\t\t\t") + call eprintf ("Done\n") + + call eprintf ("Testing double free:\t") + call calloc (ptr, 256, TY_INT) + call mfree (ptr, TY_INT) + iferr ( call mfree (ptr, TY_INT) ) + call eprintf ("Detected\t\t\t\t") + else + call eprintf ("Undetected\t\t\t\t") + call eprintf ("Done\n") + + call eprintf ("Testing NULL free:\t") + iferr ( call mfree (NULL, TY_INT) ) + call eprintf ("Detected\t\t\t\t") + else + call eprintf ("Undetected\t\t\t\t") + call eprintf ("Done\n") + + call eprintf ("Testing recovered free:\n") + call calloc (str, SZ_LINE, TY_CHAR) + call eprintf ("Done\n") + + call eprintf ("\n\nEnd of NMEMIO tests\n") +end + + + +# Test the SALLOC routine, which allocates storage on the stack. + +procedure t_stack () + +int bufsize +pointer sp, junk +int clglpi() + +begin + call smark (sp) + + while (clglpi ("buffer_size", bufsize) != EOF) { + call salloc (junk, bufsize, TY_CHAR) + call printf ("buffer pointer=%d, size=%d\n") + call pargi (junk) + call pargi (bufsize) + call flush (STDOUT) + } + + call sfree (sp) +end + + +# Test the REALLOC procedure, used to change the size of a buffer. +# Work with two buffers, so that memory can be fragmented, forcing buffers +# to move. + +procedure t_realloc() + +pointer a, b +int i, sza, new_sza, szb, new_szb + +begin + sza = SZ_FNAME + szb = SZ_LINE + + call malloc (a, sza, TY_CHAR) + call malloc (b, szb, TY_CHAR) + call strcpy ("abcdefghijk", Memc[a], ARB) + call strcpy ("0123456789", Memc[b], ARB) + + call eprintf ("a is at %d, size %d: %s\n") + call pargi (a) + call pargi (sza) + call pargstr (Memc[a]) + call eprintf ("b is at %d, size %d: %s\n") + call pargi (b) + call pargi (szb) + call pargstr (Memc[b]) + call eprintf ("-------------------------------\n") + + for (i=1; i <= 10; i=i+1) { + if (i < 5) { + new_sza = sza + 512 ; new_szb = szb + 256 + } else { + new_sza = sza + 256 ; new_szb = szb + 512 + } + call realloc (a, new_sza, TY_CHAR) + call realloc (b, new_szb, TY_CHAR) + + call eprintf ("%2d: a buf %d, size %d --> %d: %s\n") + call pargi (i) + call pargi (a) + call pargi (sza) + call pargi (new_sza) + call pargstr (Memc[a]) + call eprintf ("%2d: b buf %d, size %d --> %d: %s\n") + call pargi (i) + call pargi (b) + call pargi (szb) + call pargi (new_szb) + call pargstr (Memc[b]) + + sza = new_sza + szb = new_szb + } + + call mfree (a, TY_CHAR) + call mfree (b, TY_CHAR) +end + + + +define SZ_TEST 640 +define F_I1 Memi[$1] +define F_I2 Memi[$1+1] +define F_L1 Meml[$1+2] +define F_L2 Meml[$1+3] +define F_R1 Memr[$1+4] +define F_R2 Memr[$1+5] +define F_D1 Memd[P2D($1+8)] +define F_D2 Memd[P2D($1+10)] +define F_I3 Memi[$1+12] +define F_I4 Memi[$1+13] +define F_S1 Mems[P2S($1+14)] +define F_S2 Mems[P2S($1+15)] + + +procedure mt_struct (model) + +int model + +pointer sp, str +real x, y, z +double d1, d2, d3 + +int locva() + +begin + if (model == MT_HEAP) { + call malloc (str, SZ_TEST, TY_STRUCT) + } else { + call smark (sp) + call salloc (str, SZ_TEST, TY_STRUCT) + } + + + F_I1(str) = 1 + F_I2(str) = 2 + F_L1(str) = 3 + F_L2(str) = 4 + F_R1(str) = 5.0 + F_R2(str) = 6.0 + F_D1(str) = 7.0 + F_D2(str) = 8.0 + F_I3(str) = 9 + F_I4(str) = 10 + F_S1(str) = 11 + F_S2(str) = 12 + + x = 2.717 ; d1 = F_R1(str) + y = 2.717 ; d2 = 3.14159d0 ; + z = double(x) ; d3 = double(3.14159) + + call eprintf ("\nd1=%.6g d2=%.6g d3=%.6g x=%.6g y=%.6g z=%.6g)\n\n") + call pargd (d1) ; call pargd (d2) ; call pargd (d3) + call pargr (x) ; call pargr (y) ; call pargr (z) + + call eprintf ("Done Setting values ....\n\ntest = %d %d %d\n\n") + call pargi (str) + call pargi (locva(str)) + call pargi (locva(F_I1(str))) + + # call mdump (str, 64) + + call eprintf ("I1 = %4d I2 = %4d \t%d %d\n") + call pargi (F_I1(str)) ; call pargi (F_I2(str)) + call pargi (locva(F_I1(str))) ; call pargi (locva(F_I2(str))) + + call eprintf ("L1 = %4d L2 = %4d \t%d %d\n") + call pargl (F_L1(str)) ; call pargl (F_L2(str)) + call pargi (locva(F_L1(str))) ; call pargi (locva(F_L2(str))) + + call eprintf ("R1 = %4.1f R2 = %4.1f \t%d %d\n") + call pargr (F_R1(str)) ; call pargr (F_R2(str)) + call pargi (locva(F_R1(str))) ; call pargi (locva(F_R2(str))) + + call eprintf ("D1 = %4.1f D2 = %4.1f \t%d %d\n") + call pargd (F_D1(str)) ; call pargd (F_D2(str)) + call pargi (locva(F_D1(str))) ; call pargi (locva(F_D2(str))) + + call eprintf ("I3 = %4d I4 = %4d \t%d %d\n") + call pargi (F_I3(str)) ; call pargi (F_I4(str)) + call pargi (locva(F_I3(str))) ; call pargi (locva(F_I4(str))) + + call eprintf ("S1 = %4d S2 = %4d \t%d %d\n") + call pargs (F_S1(str)) ; call pargs (F_S2(str)) + call pargi (locva(F_S1(str))) ; call pargi (locva(F_S2(str))) + + + if (model == MT_HEAP) + call mfree (str, TY_STRUCT) + else + call sfree (sp) +end + + +define NVALS 3 + +procedure mt_print (dtype) + +int dtype + +int i, locva(), coerce() +real x +double xx +pointer p, bp, lwl + +begin + call calloc (p, NVALS, dtype) + bp = coerce (p, dtype, TY_INT) + + # Set the values. + for (i=0; i < NVALS; i=i+1) { + x = i ; xx = i + switch (dtype) { + case TY_BOOL: Memb[p+i] = TRUE + case TY_CHAR: Memc[p+i] = 'a' + i + case TY_SHORT: Mems[p+i] = i + case TY_INT: Memi[p+i] = i + case TY_LONG: Meml[p+i] = i + case TY_REAL: Memr[p+i] = x + case TY_DOUBLE: Memd[p+i] = xx + case TY_COMPLEX: Memx[p+i] = cmplx(x,-x) + + case TY_STRUCT: Memi[p+i] = i + case TY_POINTER: Memi[p+i] = i + } + } + + # Print the ptr header. + call eprintf ("\n") + call eprintf (" p = 0x%-15x %-16d\t%d\n") + call pargi (p) ; call pargi (p) ; call pargi (locva(Memi[bp])) + call eprintf (" fwa = 0x%-15x %-16d\t%d\n") + call pargi (bp-5) ; call pargi (Memi[bp-5]) + call pargi (locva (Memi[bp-5])) + call eprintf (" lwl = 0x%-15x %-16d\t%d\n") + call pargi (bp-4) ; call pargi (Memi[bp-4]) + call pargi (locva (Memi[bp-4])) + call eprintf (" dtype = 0x%-15x %-16d\t%d\n") + call pargi (bp-3) ; call mptype (dtype) + call pargi (locva (Memi[bp-3])) + call eprintf (" nelem = 0x%-15x %-16d\t%d\n") + call pargi (bp-2) ; call pargi (Memi[bp-2]) + call pargi (locva (Memi[bp-2])) + call eprintf ("L sentinal = 0x%-15x %-16d\t%d\n") + call pargi (bp-1) ; call pargi (Memi[bp-1]) + call pargi (locva (Memi[bp-1])) + + + # Print the values. + call eprintf (" data = ") + for (i=0; i < NVALS; i=i+1) { + switch (dtype) { + case TY_BOOL: + call eprintf (" %3b\t\t\t\t\t%-15d") + call pargb (Memb[p+i]) + call pargi (locva(Memb[p+i])) + case TY_CHAR: + call eprintf (" %3c\t\t\t\t\t%-15d") + call pargc (Memc[p+i]) + call pargi (locva(Memc[p+i])) + case TY_SHORT: + call eprintf (" %3d\t\t\t\t\t%-15d") + call pargs (Mems[p+i]) + call pargi (locva(Mems[p+i])) + case TY_INT: + call eprintf (" %3d\t\t\t\t\t%-15d") + call pargi (Memi[p+i]) + call pargi (locva(Memi[p+i])) + case TY_LONG: + call eprintf (" %3d\t\t\t\t\t%-15d") + call pargl (Meml[p+i]) + call pargi (locva(Meml[p+i])) + case TY_REAL: + call eprintf (" %3g\t\t\t\t\t%-15d") + call pargr (Memr[p+i]) + call pargi (locva(Memr[p+i])) + case TY_DOUBLE: + call eprintf (" %3g\t\t\t\t\t%-15d") + call pargd (Memd[p+i]) + call pargi (locva(Memd[p+i])) + case TY_COMPLEX: + call eprintf (" %3x\t\t\t\t\t%-15d") + call pargx (Memx[p+i]) + call pargi (locva(Memx[p+i])) + case TY_STRUCT: + call eprintf (" %3d\t\t\t\t\t%-15d") + call pargi (Memi[p+i]) + call pargi (locva(Memi[p+i])) + case TY_POINTER: + call eprintf (" %3d\t\t\t\t\t%-15d") + call pargi (Memi[p+i]) + call pargi (locva(Memi[p+i])) + } + call eprintf ("\n") + if (i < (NVALS-1)) + call eprintf ("\t\t") + } + + lwl = Memi[bp-4] + call eprintf ("U sentinal = 0x%-15x %-15d\t\t%d\n\n") + call pargi (lwl) ; call pargi (Memi[lwl]) + call pargi (locva (Memi[lwl])) + + call mfree (p, dtype) +end + + +procedure mt_overflow (dtype) + +int dtype + +int i +real x +double xx +pointer p + +begin + call calloc (p, NVALS, dtype) + + # Set the values. + for (i=0; i < NVALS + 4; i=i+1) { + x = i ; xx = i + switch (dtype) { + case TY_BOOL: Memb[p+i] = TRUE + case TY_CHAR: Memc[p+i] = 'a' + i + case TY_SHORT: Mems[p+i] = i + case TY_INT: Memi[p+i] = i + case TY_LONG: Meml[p+i] = i + case TY_REAL: Memr[p+i] = x + case TY_DOUBLE: Memd[p+i] = xx + case TY_COMPLEX: Memx[p+i] = cmplx(x,-x) + case TY_STRUCT: Memi[p+i] = i + case TY_POINTER: Memi[p+i] = i + } + } + + call mfree (p, dtype) +end + + +procedure mt_underflow (dtype) + +int dtype + +int i +real x +double xx +pointer p + +begin + call calloc (p, NVALS, dtype) + + # Set the values. + for (i=0; i < NVALS; i=i+1) { + x = i ; xx = i + switch (dtype) { + case TY_BOOL: Memb[p+i] = TRUE ; Memb[p-1] = FALSE + case TY_CHAR: Memc[p+i] = 'a' + i ; Memc[p-1] = '0' + case TY_SHORT: Mems[p+i] = i ; Mems[p-1] = 999 + case TY_INT: Memi[p+i] = i ; Memi[p-1] = 999 + case TY_LONG: Meml[p+i] = i ; Meml[p-1] = 999 + case TY_REAL: Memr[p+i] = x ; Memr[p-1] = 999 + case TY_DOUBLE: Memd[p+i] = xx ; Memd[p-1] = 999 + case TY_COMPLEX: Memx[p+i] = cmplx(x,-x) ; Memx[p-1] = 999 + case TY_STRUCT: Memi[p+i] = i ; Memi[p-1] = 999 + case TY_POINTER: Memi[p+i] = i ; Memi[p-1] = 999 + } + } + + call mfree (p, dtype) +end + + +procedure mptype (dtype) +int dtype +begin + switch (dtype) { + case TY_BOOL: call pargstr ("TY_BOOL ") + case TY_CHAR: call pargstr ("TY_CHAR ") + case TY_SHORT: call pargstr ("TY_SHORT ") + case TY_INT: call pargstr ("TY_INT ") + case TY_LONG: call pargstr ("TY_LONG ") + case TY_REAL: call pargstr ("TY_REAL ") + case TY_DOUBLE: call pargstr ("TY_DOUBLE ") + case TY_COMPLEX: call pargstr ("TY_COMPLEX") + case TY_STRUCT: call pargstr ("TY_STRUCT ") + case TY_POINTER: call pargstr ("TY_POINTER") + } +end + + + +# Generic Mem_ test assignment. + +define NAVALS 4 + + + +procedure mt_auto_b (ty, model) + +char ty[ARB] +int model + +int i +real x +pointer sp, ip + +begin + call eprintf (" %s\t ") + call pargstr (ty) + + if (model == MT_HEAP) { + call malloc (ip, NAVALS, TY_BOOL) + } else { + call smark (sp) + call salloc (ip, NAVALS, TY_BOOL) + } + + + call eprintf ("0x%-15x %-15d\t ") + call pargi(ip) + call pargi(ip) + + x = 0.0 + for (i=0; i < NAVALS; i=i+1) + Memb[ip+i] = TRUE + call eprintf ("[ %b %b %b %b ]\n") + for (i=0; i < NAVALS; i=i+1) + call pargb (Memb[ip+i]) + + + if (model == MT_HEAP) + call mfree (ip, TY_BOOL) + else + call sfree (sp) +end + + + +procedure mt_auto_c (ty, model) + +char ty[ARB] +int model + +int i +real x +pointer sp, ip + +begin + call eprintf (" %s\t ") + call pargstr (ty) + + if (model == MT_HEAP) { + call malloc (ip, NAVALS, TY_CHAR) + } else { + call smark (sp) + call salloc (ip, NAVALS, TY_CHAR) + } + + + call eprintf ("0x%-15x %-15d\t ") + call pargi(ip) + call pargi(ip) + + x = 0.0 + for (i=0; i < NAVALS; i=i+1) + Memc[ip+i] = 'a' + i + call eprintf ("[ %-3c %-3c %-3c %-3c ]\n") + for (i=0; i < NAVALS; i=i+1) + call pargc (Memc[ip+i]) + + + if (model == MT_HEAP) + call mfree (ip, TY_CHAR) + else + call sfree (sp) +end + + + +procedure mt_auto_s (ty, model) + +char ty[ARB] +int model + +int i +real x +pointer sp, ip + +begin + call eprintf (" %s\t ") + call pargstr (ty) + + if (model == MT_HEAP) { + call malloc (ip, NAVALS, TY_SHORT) + } else { + call smark (sp) + call salloc (ip, NAVALS, TY_SHORT) + } + + + call eprintf ("0x%-15x %-15d\t ") + call pargi(ip) + call pargi(ip) + + x = 0.0 + for (i=0; i < NAVALS; i=i+1) + Mems[ip+i] = i + call eprintf ("[ %-3d %-3d %-3d %-3d ]\n") + for (i=0; i < NAVALS; i=i+1) + call pargs (Mems[ip+i]) + + + if (model == MT_HEAP) + call mfree (ip, TY_SHORT) + else + call sfree (sp) +end + + + +procedure mt_auto_i (ty, model) + +char ty[ARB] +int model + +int i +real x +pointer sp, ip + +begin + call eprintf (" %s\t ") + call pargstr (ty) + + if (model == MT_HEAP) { + call malloc (ip, NAVALS, TY_INT) + } else { + call smark (sp) + call salloc (ip, NAVALS, TY_INT) + } + + + call eprintf ("0x%-15x %-15d\t ") + call pargi(ip) + call pargi(ip) + + x = 0.0 + for (i=0; i < NAVALS; i=i+1) + Memi[ip+i] = i + call eprintf ("[ %-3d %-3d %-3d %-3d ]\n") + for (i=0; i < NAVALS; i=i+1) + call pargi (Memi[ip+i]) + + + if (model == MT_HEAP) + call mfree (ip, TY_INT) + else + call sfree (sp) +end + + + +procedure mt_auto_l (ty, model) + +char ty[ARB] +int model + +int i +real x +pointer sp, ip + +begin + call eprintf (" %s\t ") + call pargstr (ty) + + if (model == MT_HEAP) { + call malloc (ip, NAVALS, TY_LONG) + } else { + call smark (sp) + call salloc (ip, NAVALS, TY_LONG) + } + + + call eprintf ("0x%-15x %-15d\t ") + call pargi(ip) + call pargi(ip) + + x = 0.0 + for (i=0; i < NAVALS; i=i+1) + Meml[ip+i] = i + call eprintf ("[ %-3d %-3d %-3d %-3d ]\n") + for (i=0; i < NAVALS; i=i+1) + call pargl (Meml[ip+i]) + + + if (model == MT_HEAP) + call mfree (ip, TY_LONG) + else + call sfree (sp) +end + + + +procedure mt_auto_r (ty, model) + +char ty[ARB] +int model + +int i +real x +pointer sp, ip + +begin + call eprintf (" %s\t ") + call pargstr (ty) + + if (model == MT_HEAP) { + call malloc (ip, NAVALS, TY_REAL) + } else { + call smark (sp) + call salloc (ip, NAVALS, TY_REAL) + } + + + call eprintf ("0x%-15x %-15d\t ") + call pargi(ip) + call pargi(ip) + + x = 0.0 + for (i=0; i < NAVALS; i=i+1) + Memr[ip+i] = i + call eprintf ("[ %-3g %-3g %-3g %-3g ]\n") + for (i=0; i < NAVALS; i=i+1) + call pargr (Memr[ip+i]) + + + if (model == MT_HEAP) + call mfree (ip, TY_REAL) + else + call sfree (sp) +end + + + +procedure mt_auto_d (ty, model) + +char ty[ARB] +int model + +int i +real x +pointer sp, ip + +begin + call eprintf (" %s\t ") + call pargstr (ty) + + if (model == MT_HEAP) { + call malloc (ip, NAVALS, TY_DOUBLE) + } else { + call smark (sp) + call salloc (ip, NAVALS, TY_DOUBLE) + } + + + call eprintf ("0x%-15x %-15d\t ") + call pargi(ip) + call pargi(ip) + + x = 0.0 + for (i=0; i < NAVALS; i=i+1) + Memd[ip+i] = i + call eprintf ("[ %-3g %-3g %-3g %-3g ]\n") + for (i=0; i < NAVALS; i=i+1) + call pargd (Memd[ip+i]) + + + if (model == MT_HEAP) + call mfree (ip, TY_DOUBLE) + else + call sfree (sp) +end + + + +procedure mt_auto_x (ty, model) + +char ty[ARB] +int model + +int i +real x +pointer sp, ip + +begin + call eprintf (" %s\t ") + call pargstr (ty) + + if (model == MT_HEAP) { + call malloc (ip, NAVALS, TY_COMPLEX) + } else { + call smark (sp) + call salloc (ip, NAVALS, TY_COMPLEX) + } + + + call eprintf ("0x%-15x %-15d\t ") + call pargi(ip) + call pargi(ip) + + x = 0.0 + for (i=0; i < NAVALS; i=i+1) { + x = i + Memx[ip+i] = cmplx(x,0.1) + } + call eprintf ("[ %x %x %x %x ]\n") + for (i=0; i < NAVALS; i=i+1) + call pargx (Memx[ip+i]) + + + if (model == MT_HEAP) + call mfree (ip, TY_COMPLEX) + else + call sfree (sp) +end + + diff --git a/sys/osb/README b/sys/osb/README new file mode 100644 index 00000000..c3fda892 --- /dev/null +++ b/sys/osb/README @@ -0,0 +1,4 @@ +OSB -- Bit and byte primitives. + + zzeps.f - a program to compute the machine epsilon. + (not part of the library) diff --git a/sys/osb/_proto b/sys/osb/_proto new file mode 100644 index 00000000..c247bb87 --- /dev/null +++ b/sys/osb/_proto @@ -0,0 +1,77 @@ +extern int bitmov_(integer *a, integer *aoff, integer *b, integer *boff, integer *nbits); +extern int bswap2_(char *a, integer *aoff, char *b, integer *boff, integer *nbytes, ftnlen a_len, ftnlen b_len); +extern int bswap4_(char *a, integer *aoff, char *b, integer *boff, integer *nbytes, ftnlen a_len, ftnlen b_len); +extern int bytmov_(char *a, integer *aoff, char *b, integer *boff, integer *nbytes, ftnlen a_len, ftnlen b_len); +extern int chrpak_(shortint *a, integer *aoff, char *b, integer *boff, integer *nchars, ftnlen b_len); +extern int chrupk_(char *a, integer *aoff, shortint *b, integer *boff, integer *nchars, ftnlen a_len); +extern int f77pak_(shortint *sppstr, char *f77str, integer *maxch, ftnlen f77str_len); +extern int f77upk_(char *f77str, shortint *sppstr, integer *maxch, ftnlen f77str_len); +extern int ieevpd_(doublereal *native, doublereal *ieee, integer *nelem); +extern int ieevud_(doublereal *ieee, doublereal *native, integer *nelem); +extern int ieepad_(doublereal *x); +extern int ieeupd_(doublereal *x); +extern int ieesnd_(doublereal *x); +extern int ieegnd_(doublereal *x); +extern int ieestd_(integer *onin, integer *onout); +extern int ieezsd_(void); +extern int ieemad_(integer *inval, integer *outval); +extern int ieegmd_(integer *inval, integer *outval); +extern int ieesmd_(integer *inval, integer *outval); +extern int ieevpr_(real *native, real *ieee, integer *nelem); +extern int ieevur_(real *ieee, real *native, integer *nelem); +extern int ieepar_(real *x); +extern int ieeupr_(real *x); +extern int ieesnr_(real *x); +extern int ieegnr_(real *x); +extern int ieestr_(integer *onin, integer *onout); +extern int ieezsr_(void); +extern int ieemar_(integer *inval, integer *outval); +extern int ieegmr_(integer *inval, integer *outval); +extern int ieesmr_(integer *inval, integer *outval); +extern integer miilen_(integer *nelems, integer *miidae); +extern integer miinem_(integer *nchars, integer *miitye); +extern int miipak_(integer *spp, integer *mii, integer *nelems, integer *sppdae, integer *miidae); +extern int miipa6_(integer *spp, integer *mii, integer *nelems, integer *sppdae); +extern int miipa2_(integer *spp, integer *mii, integer *nelems, integer *sppdae); +extern int miipa8_(integer *spp, integer *mii, integer *nelems, integer *sppdae); +extern int miipad_(integer *spp, doublereal *mii, integer *nelems, integer *sppdae); +extern int miipar_(integer *spp, real *mii, integer *nelems, integer *sppdae); +extern integer miipke_(integer *nelems, integer *miitye); +extern int miiupk_(integer *mii, integer *spp, integer *nelems, integer *miidae, integer *sppdae); +extern int miiup6_(integer *mii, integer *spp, integer *nelems, integer *sppdae); +extern int miiup2_(integer *mii, integer *spp, integer *nelems, integer *sppdae); +extern int miiup8_(integer *mii, integer *spp, integer *nelems, integer *sppdae); +extern int miiupd_(doublereal *mii, integer *spp, integer *nelems, integer *sppdae); +extern int miiupr_(real *mii, integer *spp, integer *nelems, integer *sppdae); +extern integer nmilen_(integer *nelems, integer *nmidae); +extern integer nminem_(integer *nchars, integer *nmitye); +extern int nmipak_(integer *spp, integer *nmi, integer *nelems, integer *sppdae, integer *nmidae); +extern int nmipa6_(integer *spp, integer *nmi, integer *nelems, integer *sppdae); +extern int nmipa2_(integer *spp, integer *nmi, integer *nelems, integer *sppdae); +extern int nmipa8_(integer *spp, integer *nmi, integer *nelems, integer *sppdae); +extern int nmipad_(integer *spp, doublereal *nmi, integer *nelems, integer *sppdae); +extern int nmipar_(integer *spp, real *nmi, integer *nelems, integer *sppdae); +extern integer nmipke_(integer *nelems, integer *nmitye); +extern int nmiupk_(integer *nmi, integer *spp, integer *nelems, integer *nmidae, integer *sppdae); +extern int nmiup6_(integer *nmi, integer *spp, integer *nelems, integer *sppdae); +extern int nmiup2_(integer *nmi, integer *spp, integer *nelems, integer *sppdae); +extern int nmiup8_(integer *nmi, integer *spp, integer *nelems, integer *sppdae); +extern int nmiupd_(doublereal *nmi, integer *spp, integer *nelems, integer *sppdae); +extern int nmiupr_(real *nmi, integer *spp, integer *nelems, integer *sppdae); +extern int strpak_(shortint *instr, char *outstr, integer *maxch, ftnlen outstr_len); +extern int strupk_(char *instr, shortint *outstr, integer *maxch, ftnlen instr_len); +extern real urand_(integer *lseed); +extern integer xori_(integer *a, integer *b); +extern shortint xors_(shortint *a, shortint *b); +extern integer xorl_(integer *a, integer *b); +extern integer sysruk_(shortint *task, shortint *cmd, integer *rukarf, integer *rukint); +extern int sbit_(void); +extern int tbit_(void); +extern int cseps_(real *seps); +extern logical sgt_(real *value); +extern int cdeps_(doublereal *deps); +extern logical dgt_(doublereal *value); +extern int cseps_(real *seps); +extern logical sgt_(real *value, real *ref); +extern int cdeps_(doublereal *deps); +extern logical dgt_(doublereal *value, doublereal *ref); diff --git a/sys/osb/abs.c b/sys/osb/abs.c new file mode 100644 index 00000000..90bd3ad6 --- /dev/null +++ b/sys/osb/abs.c @@ -0,0 +1,13 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#include + +/* ABS -- Integer absolute value. + */ +XINT +abs_ (XINT *a) +{ + return (abs(a)); +} diff --git a/sys/osb/achtb.gc b/sys/osb/achtb.gc new file mode 100644 index 00000000..dd5f97d2 --- /dev/null +++ b/sys/osb/achtb.gc @@ -0,0 +1,32 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHTB_ -- Unpack an unsigned byte array into an SPP array. + * The loop runs in the reverse direction so that the unpack can be + * performed in place (a and b can be the same array). + */ +void +ACHTB$T ( + XCHAR *a, + $if (datatype == B) + XCHAR *b, + $else + XPIXEL *b, + $endif + XINT *npix +) +{ + register XUBYTE *ip, *first = (XUBYTE *)a; + register XPIXEL *op; + + for (ip = &first[*npix], op = &((XPIXEL *)b)[*npix]; ip > first; ) + $if (datatype == x) + (--op)->r = (float) *--ip; + $else + *--op = *--ip; + $endif +} diff --git a/sys/osb/achtbb.c b/sys/osb/achtbb.c new file mode 100644 index 00000000..26a48e99 --- /dev/null +++ b/sys/osb/achtbb.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHTB_ -- Unpack an unsigned byte array into an SPP array. + * The loop runs in the reverse direction so that the unpack can be + * performed in place (a and b can be the same array). + */ +void +ACHTBB ( + XCHAR *a, + XCHAR *b, + XINT *npix +) +{ + register XUBYTE *ip, *first = (XUBYTE *)a; + register XUBYTE *op; + + for (ip = &first[*npix], op = &((XUBYTE *)b)[*npix]; ip > first; ) + *--op = *--ip; +} diff --git a/sys/osb/achtbc.c b/sys/osb/achtbc.c new file mode 100644 index 00000000..a1a778c2 --- /dev/null +++ b/sys/osb/achtbc.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHTB_ -- Unpack an unsigned byte array into an SPP array. + * The loop runs in the reverse direction so that the unpack can be + * performed in place (a and b can be the same array). + */ +void +ACHTBC ( + XCHAR *a, + XCHAR *b, + XINT *npix +) +{ + register XUBYTE *ip, *first = (XUBYTE *)a; + register XCHAR *op; + + for (ip = &first[*npix], op = &((XCHAR *)b)[*npix]; ip > first; ) + *--op = *--ip; +} diff --git a/sys/osb/achtbd.c b/sys/osb/achtbd.c new file mode 100644 index 00000000..deb2f23a --- /dev/null +++ b/sys/osb/achtbd.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHTB_ -- Unpack an unsigned byte array into an SPP array. + * The loop runs in the reverse direction so that the unpack can be + * performed in place (a and b can be the same array). + */ +void +ACHTBD ( + XCHAR *a, + XDOUBLE *b, + XINT *npix +) +{ + register XUBYTE *ip, *first = (XUBYTE *)a; + register XDOUBLE *op; + + for (ip = &first[*npix], op = &((XDOUBLE *)b)[*npix]; ip > first; ) + *--op = *--ip; +} diff --git a/sys/osb/achtbi.c b/sys/osb/achtbi.c new file mode 100644 index 00000000..41733ce8 --- /dev/null +++ b/sys/osb/achtbi.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHTB_ -- Unpack an unsigned byte array into an SPP array. + * The loop runs in the reverse direction so that the unpack can be + * performed in place (a and b can be the same array). + */ +void +ACHTBI ( + XCHAR *a, + XINT *b, + XINT *npix +) +{ + register XUBYTE *ip, *first = (XUBYTE *)a; + register XINT *op; + + for (ip = &first[*npix], op = &((XINT *)b)[*npix]; ip > first; ) + *--op = *--ip; +} diff --git a/sys/osb/achtbl.c b/sys/osb/achtbl.c new file mode 100644 index 00000000..a1090d62 --- /dev/null +++ b/sys/osb/achtbl.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHTB_ -- Unpack an unsigned byte array into an SPP array. + * The loop runs in the reverse direction so that the unpack can be + * performed in place (a and b can be the same array). + */ +void +ACHTBL ( + XCHAR *a, + XLONG *b, + XINT *npix +) +{ + register XUBYTE *ip, *first = (XUBYTE *)a; + register XLONG *op; + + for (ip = &first[*npix], op = &((XLONG *)b)[*npix]; ip > first; ) + *--op = *--ip; +} diff --git a/sys/osb/achtbr.c b/sys/osb/achtbr.c new file mode 100644 index 00000000..72839ce9 --- /dev/null +++ b/sys/osb/achtbr.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHTB_ -- Unpack an unsigned byte array into an SPP array. + * The loop runs in the reverse direction so that the unpack can be + * performed in place (a and b can be the same array). + */ +void +ACHTBR ( + XCHAR *a, + XREAL *b, + XINT *npix +) +{ + register XUBYTE *ip, *first = (XUBYTE *)a; + register XREAL *op; + + for (ip = &first[*npix], op = &((XREAL *)b)[*npix]; ip > first; ) + *--op = *--ip; +} diff --git a/sys/osb/achtbs.c b/sys/osb/achtbs.c new file mode 100644 index 00000000..da68e65d --- /dev/null +++ b/sys/osb/achtbs.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHTB_ -- Unpack an unsigned byte array into an SPP array. + * The loop runs in the reverse direction so that the unpack can be + * performed in place (a and b can be the same array). + */ +void +ACHTBS ( + XCHAR *a, + XSHORT *b, + XINT *npix +) +{ + register XUBYTE *ip, *first = (XUBYTE *)a; + register XSHORT *op; + + for (ip = &first[*npix], op = &((XSHORT *)b)[*npix]; ip > first; ) + *--op = *--ip; +} diff --git a/sys/osb/achtbu.c b/sys/osb/achtbu.c new file mode 100644 index 00000000..45b523ca --- /dev/null +++ b/sys/osb/achtbu.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHTB_ -- Unpack an unsigned byte array into an SPP array. + * The loop runs in the reverse direction so that the unpack can be + * performed in place (a and b can be the same array). + */ +void +ACHTBU ( + XCHAR *a, + XUSHORT *b, + XINT *npix +) +{ + register XUBYTE *ip, *first = (XUBYTE *)a; + register XUSHORT *op; + + for (ip = &first[*npix], op = &((XUSHORT *)b)[*npix]; ip > first; ) + *--op = *--ip; +} diff --git a/sys/osb/achtbx.c b/sys/osb/achtbx.c new file mode 100644 index 00000000..a62a48c1 --- /dev/null +++ b/sys/osb/achtbx.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHTB_ -- Unpack an unsigned byte array into an SPP array. + * The loop runs in the reverse direction so that the unpack can be + * performed in place (a and b can be the same array). + */ +void +ACHTBX ( + XCHAR *a, + XCOMPLEX *b, + XINT *npix +) +{ + register XUBYTE *ip, *first = (XUBYTE *)a; + register XCOMPLEX *op; + + for (ip = &first[*npix], op = &((XCOMPLEX *)b)[*npix]; ip > first; ) + (--op)->r = (float) *--ip; +} diff --git a/sys/osb/achtcb.c b/sys/osb/achtcb.c new file mode 100644 index 00000000..d9749e62 --- /dev/null +++ b/sys/osb/achtcb.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHT_B -- Pack SPP array into an unsigned byte array. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTCB ( + XCHAR *a, + XCHAR *b, + XINT *npix +) +{ + register XCHAR *ip; + register XUBYTE *op; + register int n = *npix; + + for (ip=(XCHAR *)a, op=(XUBYTE *)b; --n >= 0; ) + *op++ = *ip++; +} diff --git a/sys/osb/achtcu.c b/sys/osb/achtcu.c new file mode 100644 index 00000000..1a0b3d1c --- /dev/null +++ b/sys/osb/achtcu.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHT_U -- Pack an SPP datatype array into an unsigned short integer. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTCU ( + XCHAR *a, + XUSHORT *b, + XINT *npix +) +{ + register XCHAR *ip; + register XUSHORT *op; + register int n = *npix; + + if (sizeof(*op) > sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + *--op = *--ip; + } else { + for (ip=a, op=b; --n >= 0; ) + *op++ = *ip++; + } +} diff --git a/sys/osb/achtdb.c b/sys/osb/achtdb.c new file mode 100644 index 00000000..e7cd0663 --- /dev/null +++ b/sys/osb/achtdb.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHT_B -- Pack SPP array into an unsigned byte array. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTDB ( + XDOUBLE *a, + XCHAR *b, + XINT *npix +) +{ + register XDOUBLE *ip; + register XUBYTE *op; + register int n = *npix; + + for (ip=(XDOUBLE *)a, op=(XUBYTE *)b; --n >= 0; ) + *op++ = *ip++; +} diff --git a/sys/osb/achtdu.c b/sys/osb/achtdu.c new file mode 100644 index 00000000..bcea4762 --- /dev/null +++ b/sys/osb/achtdu.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHT_U -- Pack an SPP datatype array into an unsigned short integer. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTDU ( + XDOUBLE *a, + XUSHORT *b, + XINT *npix +) +{ + register XDOUBLE *ip; + register XUSHORT *op; + register int n = *npix; + + if (sizeof(*op) > sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + *--op = *--ip; + } else { + for (ip=a, op=b; --n >= 0; ) + *op++ = *ip++; + } +} diff --git a/sys/osb/achtib.c b/sys/osb/achtib.c new file mode 100644 index 00000000..74977f40 --- /dev/null +++ b/sys/osb/achtib.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHT_B -- Pack SPP array into an unsigned byte array. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTIB ( + XINT *a, + XCHAR *b, + XINT *npix +) +{ + register XINT *ip; + register XUBYTE *op; + register int n = *npix; + + for (ip=(XINT *)a, op=(XUBYTE *)b; --n >= 0; ) + *op++ = *ip++; +} diff --git a/sys/osb/achtiu.c b/sys/osb/achtiu.c new file mode 100644 index 00000000..5b14bd43 --- /dev/null +++ b/sys/osb/achtiu.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHT_U -- Pack an SPP datatype array into an unsigned short integer. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTIU ( + XINT *a, + XUSHORT *b, + XINT *npix +) +{ + register XINT *ip; + register XUSHORT *op; + register int n = *npix; + + if (sizeof(*op) > sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + *--op = *--ip; + } else { + for (ip=a, op=b; --n >= 0; ) + *op++ = *ip++; + } +} diff --git a/sys/osb/achtlb.c b/sys/osb/achtlb.c new file mode 100644 index 00000000..fcf63a87 --- /dev/null +++ b/sys/osb/achtlb.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHT_B -- Pack SPP array into an unsigned byte array. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTLB ( + XLONG *a, + XCHAR *b, + XINT *npix +) +{ + register XLONG *ip; + register XUBYTE *op; + register int n = *npix; + + for (ip=(XLONG *)a, op=(XUBYTE *)b; --n >= 0; ) + *op++ = *ip++; +} diff --git a/sys/osb/achtlu.c b/sys/osb/achtlu.c new file mode 100644 index 00000000..a669577e --- /dev/null +++ b/sys/osb/achtlu.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHT_U -- Pack an SPP datatype array into an unsigned short integer. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTLU ( + XLONG *a, + XUSHORT *b, + XINT *npix +) +{ + register XLONG *ip; + register XUSHORT *op; + register int n = *npix; + + if (sizeof(*op) > sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + *--op = *--ip; + } else { + for (ip=a, op=b; --n >= 0; ) + *op++ = *ip++; + } +} diff --git a/sys/osb/achtrb.c b/sys/osb/achtrb.c new file mode 100644 index 00000000..47d27e87 --- /dev/null +++ b/sys/osb/achtrb.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHT_B -- Pack SPP array into an unsigned byte array. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTRB ( + XREAL *a, + XCHAR *b, + XINT *npix +) +{ + register XREAL *ip; + register XUBYTE *op; + register int n = *npix; + + for (ip=(XREAL *)a, op=(XUBYTE *)b; --n >= 0; ) + *op++ = *ip++; +} diff --git a/sys/osb/achtru.c b/sys/osb/achtru.c new file mode 100644 index 00000000..70a99f7f --- /dev/null +++ b/sys/osb/achtru.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHT_U -- Pack an SPP datatype array into an unsigned short integer. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTRU ( + XREAL *a, + XUSHORT *b, + XINT *npix +) +{ + register XREAL *ip; + register XUSHORT *op; + register int n = *npix; + + if (sizeof(*op) > sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + *--op = *--ip; + } else { + for (ip=a, op=b; --n >= 0; ) + *op++ = *ip++; + } +} diff --git a/sys/osb/achtsb.c b/sys/osb/achtsb.c new file mode 100644 index 00000000..f8453873 --- /dev/null +++ b/sys/osb/achtsb.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHT_B -- Pack SPP array into an unsigned byte array. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTSB ( + XSHORT *a, + XCHAR *b, + XINT *npix +) +{ + register XSHORT *ip; + register XUBYTE *op; + register int n = *npix; + + for (ip=(XSHORT *)a, op=(XUBYTE *)b; --n >= 0; ) + *op++ = *ip++; +} diff --git a/sys/osb/achtsu.c b/sys/osb/achtsu.c new file mode 100644 index 00000000..269a5122 --- /dev/null +++ b/sys/osb/achtsu.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHT_U -- Pack an SPP datatype array into an unsigned short integer. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTSU ( + XSHORT *a, + XUSHORT *b, + XINT *npix +) +{ + register XSHORT *ip; + register XUSHORT *op; + register int n = *npix; + + if (sizeof(*op) > sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + *--op = *--ip; + } else { + for (ip=a, op=b; --n >= 0; ) + *op++ = *ip++; + } +} diff --git a/sys/osb/achtu.gc b/sys/osb/achtu.gc new file mode 100644 index 00000000..35e8f226 --- /dev/null +++ b/sys/osb/achtu.gc @@ -0,0 +1,37 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHTU_ -- Unpack an unsigned short integer array into an SPP datatype. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTU$T ( + XUSHORT *a, + XPIXEL *b, + XINT *npix +) +{ + register XUSHORT *ip; + register XPIXEL *op; + register int n = *npix; + + if (sizeof(*op) >= sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + $if (datatype == x) + (--op)->r = (float) *--ip; + $else + *--op = *--ip; + $endif + } else { + for (ip=a, op=b; --n >= 0; ) + $if (datatype == x) + (op++)->r = (float) *ip++; + $else + *op++ = *ip++; + $endif + } +} diff --git a/sys/osb/achtub.c b/sys/osb/achtub.c new file mode 100644 index 00000000..a772f3f0 --- /dev/null +++ b/sys/osb/achtub.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHTU_ -- Unpack an unsigned short integer array into an SPP datatype. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTUB ( + XUSHORT *a, + XUBYTE *b, + XINT *npix +) +{ + register XUSHORT *ip; + register XUBYTE *op; + register int n = *npix; + + if (sizeof(*op) >= sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + *--op = *--ip; + } else { + for (ip=a, op=b; --n >= 0; ) + *op++ = *ip++; + } +} diff --git a/sys/osb/achtuc.c b/sys/osb/achtuc.c new file mode 100644 index 00000000..7779e036 --- /dev/null +++ b/sys/osb/achtuc.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHTU_ -- Unpack an unsigned short integer array into an SPP datatype. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTUC ( + XUSHORT *a, + XCHAR *b, + XINT *npix +) +{ + register XUSHORT *ip; + register XCHAR *op; + register int n = *npix; + + if (sizeof(*op) >= sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + *--op = *--ip; + } else { + for (ip=a, op=b; --n >= 0; ) + *op++ = *ip++; + } +} diff --git a/sys/osb/achtud.c b/sys/osb/achtud.c new file mode 100644 index 00000000..0d825c3b --- /dev/null +++ b/sys/osb/achtud.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHTU_ -- Unpack an unsigned short integer array into an SPP datatype. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTUD ( + XUSHORT *a, + XDOUBLE *b, + XINT *npix +) +{ + register XUSHORT *ip; + register XDOUBLE *op; + register int n = *npix; + + if (sizeof(*op) >= sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + *--op = *--ip; + } else { + for (ip=a, op=b; --n >= 0; ) + *op++ = *ip++; + } +} diff --git a/sys/osb/achtui.c b/sys/osb/achtui.c new file mode 100644 index 00000000..dea6c326 --- /dev/null +++ b/sys/osb/achtui.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHTU_ -- Unpack an unsigned short integer array into an SPP datatype. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTUI ( + XUSHORT *a, + XINT *b, + XINT *npix +) +{ + register XUSHORT *ip; + register XINT *op; + register int n = *npix; + + if (sizeof(*op) >= sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + *--op = *--ip; + } else { + for (ip=a, op=b; --n >= 0; ) + *op++ = *ip++; + } +} diff --git a/sys/osb/achtul.c b/sys/osb/achtul.c new file mode 100644 index 00000000..f6b0b94e --- /dev/null +++ b/sys/osb/achtul.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHTU_ -- Unpack an unsigned short integer array into an SPP datatype. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTUL ( + XUSHORT *a, + XLONG *b, + XINT *npix +) +{ + register XUSHORT *ip; + register XLONG *op; + register int n = *npix; + + if (sizeof(*op) >= sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + *--op = *--ip; + } else { + for (ip=a, op=b; --n >= 0; ) + *op++ = *ip++; + } +} diff --git a/sys/osb/achtur.c b/sys/osb/achtur.c new file mode 100644 index 00000000..eebaba1c --- /dev/null +++ b/sys/osb/achtur.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHTU_ -- Unpack an unsigned short integer array into an SPP datatype. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTUR ( + XUSHORT *a, + XREAL *b, + XINT *npix +) +{ + register XUSHORT *ip; + register XREAL *op; + register int n = *npix; + + if (sizeof(*op) >= sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + *--op = *--ip; + } else { + for (ip=a, op=b; --n >= 0; ) + *op++ = *ip++; + } +} diff --git a/sys/osb/achtus.c b/sys/osb/achtus.c new file mode 100644 index 00000000..dc940362 --- /dev/null +++ b/sys/osb/achtus.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHTU_ -- Unpack an unsigned short integer array into an SPP datatype. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTUS ( + XUSHORT *a, + XSHORT *b, + XINT *npix +) +{ + register XUSHORT *ip; + register XSHORT *op; + register int n = *npix; + + if (sizeof(*op) >= sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + *--op = *--ip; + } else { + for (ip=a, op=b; --n >= 0; ) + *op++ = *ip++; + } +} diff --git a/sys/osb/achtuu.c b/sys/osb/achtuu.c new file mode 100644 index 00000000..55168dea --- /dev/null +++ b/sys/osb/achtuu.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHTU_ -- Unpack an unsigned short integer array into an SPP datatype. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTUU ( + XUSHORT *a, + XUSHORT *b, + XINT *npix +) +{ + register XUSHORT *ip; + register XUSHORT *op; + register int n = *npix; + + if (sizeof(*op) >= sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + *--op = *--ip; + } else { + for (ip=a, op=b; --n >= 0; ) + *op++ = *ip++; + } +} diff --git a/sys/osb/achtux.c b/sys/osb/achtux.c new file mode 100644 index 00000000..bf44a0ce --- /dev/null +++ b/sys/osb/achtux.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHTU_ -- Unpack an unsigned short integer array into an SPP datatype. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTUX ( + XUSHORT *a, + XCOMPLEX *b, + XINT *npix +) +{ + register XUSHORT *ip; + register XCOMPLEX *op; + register int n = *npix; + + if (sizeof(*op) >= sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + (--op)->r = (float) *--ip; + } else { + for (ip=a, op=b; --n >= 0; ) + (op++)->r = (float) *ip++; + } +} diff --git a/sys/osb/achtxb.c b/sys/osb/achtxb.c new file mode 100644 index 00000000..62dd0274 --- /dev/null +++ b/sys/osb/achtxb.c @@ -0,0 +1,24 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHT_B -- Pack SPP array into an unsigned byte array. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTXB ( + XCOMPLEX *a, + XCHAR *b, + XINT *npix +) +{ + register XCOMPLEX *ip; + register XUBYTE *op; + register int n = *npix; + + for (ip=(XCOMPLEX *)a, op=(XUBYTE *)b; --n >= 0; ) + *op++ = (int) (ip++)->r; +} diff --git a/sys/osb/achtxu.c b/sys/osb/achtxu.c new file mode 100644 index 00000000..a5bd8a71 --- /dev/null +++ b/sys/osb/achtxu.c @@ -0,0 +1,29 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHT_U -- Pack an SPP datatype array into an unsigned short integer. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHTXU ( + XCOMPLEX *a, + XUSHORT *b, + XINT *npix +) +{ + register XCOMPLEX *ip; + register XUSHORT *op; + register int n = *npix; + + if (sizeof(*op) > sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + *--op = (int) (--ip)->r; + } else { + for (ip=a, op=b; --n >= 0; ) + *op++ = (int) (ip++)->r; + } +} diff --git a/sys/osb/achtzb.gc b/sys/osb/achtzb.gc new file mode 100644 index 00000000..27ef9a48 --- /dev/null +++ b/sys/osb/achtzb.gc @@ -0,0 +1,32 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHT_B -- Pack SPP array into an unsigned byte array. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHT$TB ( + $if (datatype == B) + XCHAR *a, + $else + XPIXEL *a, + $endif + XCHAR *b, + XINT *npix +) +{ + register XPIXEL *ip; + register XUBYTE *op; + register int n = *npix; + + for (ip=(XPIXEL *)a, op=(XUBYTE *)b; --n >= 0; ) + $if (datatype == x) + *op++ = (int) (ip++)->r; + $else + *op++ = *ip++; + $endif +} diff --git a/sys/osb/achtzu.gc b/sys/osb/achtzu.gc new file mode 100644 index 00000000..4e5faacd --- /dev/null +++ b/sys/osb/achtzu.gc @@ -0,0 +1,37 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACHT_U -- Pack an SPP datatype array into an unsigned short integer. + * [MACHDEP]: The underscore appended to the procedure name is OS dependent. + */ +void +ACHT$TU ( + XPIXEL *a, + XUSHORT *b, + XINT *npix +) +{ + register XPIXEL *ip; + register XUSHORT *op; + register int n = *npix; + + if (sizeof(*op) > sizeof(*ip)) { + for (ip = &a[n], op = &b[n]; ip > a; ) + $if (datatype == x) + *--op = (int) (--ip)->r; + $else + *--op = *--ip; + $endif + } else { + for (ip=a, op=b; --n >= 0; ) + $if (datatype == x) + *op++ = (int) (ip++)->r; + $else + *op++ = *ip++; + $endif + } +} diff --git a/sys/osb/aclrb.c b/sys/osb/aclrb.c new file mode 100644 index 00000000..15d63e39 --- /dev/null +++ b/sys/osb/aclrb.c @@ -0,0 +1,18 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ACLRB -- Clear a block of memory. + */ +void +ACLRB (XCHAR *a, XINT *nbytes) +{ + register char *p; + register int n; + + for (p=(char *)a, n = *nbytes; --n >= 0; ) + *p++ = 0; +} diff --git a/sys/osb/and.c b/sys/osb/and.c new file mode 100644 index 00000000..98dcbb07 --- /dev/null +++ b/sys/osb/and.c @@ -0,0 +1,32 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ANDI -- Bitwise boolean AND of two integer variables. + */ +XINT +ANDI (XINT *a, XINT *b) +{ + return (*a & *b); +} + + +/* ANDS -- Bitwise boolean AND of two short integer variables. + */ +XSHORT +ANDS (XSHORT *a, XSHORT *b) +{ + return (*a & *b); +} + + +/* ANDL -- Bitwise boolean AND of two long integer variables. + */ +XLONG +ANDL (XLONG *a, XLONG *b) +{ + return (*a & *b); +} diff --git a/sys/osb/bitfields.c b/sys/osb/bitfields.c new file mode 100644 index 00000000..3275c542 --- /dev/null +++ b/sys/osb/bitfields.c @@ -0,0 +1,70 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* + * BITFIELDS.C -- Portable C routines for extracting and inserting small + * integers into an integer value. + */ + +unsigned XINT bitmask[] = { 0, /* MACHDEP */ + 01, 03, 07, + 017, 037, 077, + 0177, 0377, 0777, + 01777, 03777, 07777, + 017777, 037777, 077777, + 0177777, 0377777, 0777777, + 01777777, 03777777, 07777777, + 017777777, 037777777, 077777777, + 0177777777, 0377777777, 0777777777, + 01777777777, 03777777777, 07777777777, + 017777777777, 037777777777, 077777777777, + 0177777777777, 0377777777777, 0777777777777, + 01777777777777, 03777777777777, 07777777777777, + 017777777777777, 037777777777777, 077777777777777, + 0177777777777777, 0377777777777777, 0777777777777777, + 01777777777777777, 03777777777777777, 07777777777777777, + 017777777777777777, 037777777777777777, 077777777777777777, + 0177777777777777777, 0377777777777777777, 0777777777777777777, + 01777777777777777777, 03777777777777777777, 07777777777777777777, + 017777777777777777777, 037777777777777777777, 077777777777777777777, + 0177777777777777777777, 0377777777777777777777, 0777777777777777777777, + 01777777777777777777777, 03777777777777777777777, 07777777777777777777777 +}; + + + +/* BITPAK -- Pack an unsigned integer value into a bitfield in a longword. + * The size of the bitfield may not exceed the number of bits in an integer. + */ +void +BITPAK ( + unsigned XINT *ival, /* value to be placed in bitfield */ + unsigned XINT *wordp, /* longword to be written into */ + XINT *offset, /* one-indexed offset of first bit */ + XINT *nbits /* number of bits to be set */ +) +{ + register unsigned XINT shift; + register unsigned XINT mask; + + shift = *offset - 1; + mask = bitmask[*nbits] << shift; + *wordp = (*wordp & ~mask) | ((*ival << shift) & mask); +} + + +/* BITUPK -- Unpack an unsigned integer bit field from a longword. + */ +XINT +BITUPK ( + unsigned XINT *wordp, /* longword to be examined */ + XINT *offset, /* one-indexed offset of first bit */ + XINT *nbits /* number of bits to be set */ +) +{ + return ((*wordp >> (*offset-1)) & bitmask[*nbits]); +} diff --git a/sys/osb/bitmov.x b/sys/osb/bitmov.x new file mode 100644 index 00000000..f6784b2a --- /dev/null +++ b/sys/osb/bitmov.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# BITMOV -- Move a sequence of bits in a bit array of arbitrary length. + +procedure bitmov (a, a_off, b, b_off, nbits) + +int a[ARB] # input bit array +int a_off # first bit to be moved +int b[ARB] # output bit array +int b_off # first bit to be written +int nbits # number of bits to be moved + +int ip, op, ip_top, nbits_left +int bitupk() + +begin + ip_top = a_off + nbits - NBITS_INT + op = b_off + + for (ip = a_off; ip <= ip_top; ip = ip + NBITS_INT) { + call bitpak (bitupk(a,ip,NBITS_INT), b, op, NBITS_INT) + op = op + NBITS_INT + } + + nbits_left = (a_off + nbits) - ip + if (nbits_left > 0) + call bitpak (bitupk(a,ip,nbits_left), b, op, nbits_left) +end diff --git a/sys/osb/bswap2.c b/sys/osb/bswap2.c new file mode 100644 index 00000000..a2c08030 --- /dev/null +++ b/sys/osb/bswap2.c @@ -0,0 +1,38 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* BSWAP2 - Move bytes from array "a" to array "b", swapping successive + * pairs of bytes. The two arrays may be the same but may not be offset + * and overlapping. + */ +BSWAP2 (a, aoff, b, boff, nbytes) +XCHAR *a; /* input array */ +XINT *aoff; /* first byte in input array */ +XCHAR *b; /* output array */ +XINT *boff; /* first byte in output array */ +XINT *nbytes; /* number of bytes to swap */ +{ + register char *ip, *op, *otop; + register unsigned temp; + + ip = (char *)a + *aoff - 1; + op = (char *)b + *boff - 1; + otop = op + (*nbytes & ~1); + + /* Swap successive pairs of bytes. + */ + while (op < otop) { + temp = *ip++; + *op++ = *ip++; + *op++ = temp; + } + + /* If there is an odd byte left, move it to the output array. + */ + if (*nbytes & 1) + *op = *ip; +} diff --git a/sys/osb/bswap2.f b/sys/osb/bswap2.f new file mode 100644 index 00000000..700c8498 --- /dev/null +++ b/sys/osb/bswap2.f @@ -0,0 +1,20 @@ +c BSWAP2 - Move bytes from array "a" to array "b", swapping successive +c pairs of bytes. + + subroutine bswap2 (a, aoff, b, boff, nbytes) + + character*1 a(*), b(*), temp + integer aoff, boff, nbytes, i + integer aoff1, boff1 + + aoff1 = aoff + 1 + boff1 = boff + 1 + + do 10 i = 0, nbytes-1, 2 + temp = a(aoff1+i) + if (i .ne. nbytes) then + b(boff1+i) = a(aoff+i) + endif + b(boff+i) = temp + 10 continue + end diff --git a/sys/osb/bswap4.c b/sys/osb/bswap4.c new file mode 100644 index 00000000..763633a5 --- /dev/null +++ b/sys/osb/bswap4.c @@ -0,0 +1,46 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* BSWAP4 - Move bytes from array "a" to array "b", swapping the four bytes + * in each successive 4 byte group, i.e., 12345678 becomes 43218765. + * The input and output arrays may be the same but may not partially overlap. + */ +BSWAP4 (a, aoff, b, boff, nbytes) +XCHAR *a; /* input array */ +XINT *aoff; /* first byte in input array */ +XCHAR *b; /* output array */ +XINT *boff; /* first byte in output array */ +XINT *nbytes; /* number of bytes to swap */ +{ + register char *ip, *op, *tp; + register int n; + static char temp[4]; + + tp = temp; + ip = (char *)a + *aoff - 1; + op = (char *)b + *boff - 1; + + /* Swap successive four byte groups. + */ + for (n = *nbytes >> 2; --n >= 0; ) { + *tp++ = *ip++; + *tp++ = *ip++; + *tp++ = *ip++; + *tp++ = *ip++; + *op++ = *--tp; + *op++ = *--tp; + *op++ = *--tp; + *op++ = *--tp; + } + + /* If there are any odd bytes left, move them to the output array. + * Do not bother to swap as it is unclear how to swap a partial + * group, and really incorrect if the data is not modulus 4. + */ + for (n = *nbytes & 03; --n >= 0; ) + *op++ = *ip++; +} diff --git a/sys/osb/bswap4.f b/sys/osb/bswap4.f new file mode 100644 index 00000000..1cfa107c --- /dev/null +++ b/sys/osb/bswap4.f @@ -0,0 +1,29 @@ +c BSWAP4 - Move bytes from array "a" to array "b", swapping the four bytes +c in each successive 4 byte group, i.e., 12345678 becomes 43218765. + + subroutine bswap4 (a, aoff, b, boff, nbytes) + + character*1 a(*), b(*), temp + integer aoff, boff, nbytes, i + integer aoff1, boff1, aoff2, boff2, aoff3, boff3 + + if (nbytes .le. 4) then + return + endif + + aoff1 = aoff + 1 + boff1 = boff + 1 + aoff2 = aoff + 2 + boff2 = boff + 2 + aoff3 = aoff + 3 + boff3 = boff + 3 + + do 10 i = 0, nbytes-3, 4 + temp = a(aoff1+i) + b(boff1+i) = a(aoff2+i) + b(boff2+i) = temp + temp = a(aoff3+i) + b(boff3+i) = a(aoff+i) + b(boff+i) = temp + 10 continue + end diff --git a/sys/osb/bswap8.c b/sys/osb/bswap8.c new file mode 100644 index 00000000..ff544b7d --- /dev/null +++ b/sys/osb/bswap8.c @@ -0,0 +1,54 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* BSWAP8 - Move bytes from array "a" to array "b", swapping the eight bytes + * in each successive 8 byte group, i.e., 12345678 becomes 87654321. + * The input and output arrays may be the same but may not partially overlap. + */ +BSWAP8 (a, aoff, b, boff, nbytes) +XCHAR *a; /* input array */ +XINT *aoff; /* first byte in input array */ +XCHAR *b; /* output array */ +XINT *boff; /* first byte in output array */ +XINT *nbytes; /* number of bytes to swap */ +{ + register char *ip, *op, *tp; + register int n; + static char temp[8]; + + tp = temp; + ip = (char *)a + *aoff - 1; + op = (char *)b + *boff - 1; + + /* Swap successive eight byte groups. + */ + for (n = *nbytes >> 3; --n >= 0; ) { + *tp++ = *ip++; + *tp++ = *ip++; + *tp++ = *ip++; + *tp++ = *ip++; + *tp++ = *ip++; + *tp++ = *ip++; + *tp++ = *ip++; + *tp++ = *ip++; + *op++ = *--tp; + *op++ = *--tp; + *op++ = *--tp; + *op++ = *--tp; + *op++ = *--tp; + *op++ = *--tp; + *op++ = *--tp; + *op++ = *--tp; + } + + /* If there are any odd bytes left, move them to the output array. + * Do not bother to swap as it is unclear how to swap a partial + * group, and really incorrect if the data is not modulus 8. + */ + for (n = *nbytes & 03; --n >= 0; ) + *op++ = *ip++; +} diff --git a/sys/osb/bytmov.c b/sys/osb/bytmov.c new file mode 120000 index 00000000..90b667eb --- /dev/null +++ b/sys/osb/bytmov.c @@ -0,0 +1 @@ +/iraf/iraf/unix/as/bytmov.c \ No newline at end of file diff --git a/sys/osb/bytmov.f b/sys/osb/bytmov.f new file mode 100644 index 00000000..b866e852 --- /dev/null +++ b/sys/osb/bytmov.f @@ -0,0 +1,27 @@ +c BYTMOV -- Byte move from array "a" to array "b". The move must be +c nondestructive, allowing a byte array to be shifted left or right a +c few bytes, hence calls to zlocva() are required to get the addresses of +c the arrays. + + subroutine bytmov (a, aoff, b, boff, nbytes) + + character*1 a(*), b(*) + integer aoff, boff, nbytes + integer fwaa, lwaa, fwab, i + + call zlocva (a(aoff), fwaa) + call zlocva (a(aoff+nbytes-1), lwaa) + call zlocva (b(boff), fwab) + + if (fwaa .eq. fwab) then + return + else if (fwab .ge. fwaa .and. fwab .le. lwaa) then + do 10 i = nbytes-1, 0, -1 + b(boff+i) = a(aoff+i) + 10 continue + else + do 20 i = 0, nbytes-1 + b(boff+i) = a(aoff+i) + 20 continue + endif + end diff --git a/sys/osb/chrpak.c b/sys/osb/chrpak.c new file mode 100644 index 00000000..3a1356a8 --- /dev/null +++ b/sys/osb/chrpak.c @@ -0,0 +1,28 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* CHRPAK -- Pack a counted string of XCHAR into bytes. This routine does not + * know about EOS terminators. The input and output arrays may be the same. + * Note that while XCHAR is signed, the signedness of the C char is unspecified, + * hence we pack the chars in unsigned bytes, dealing explicitly with any + * negative values. + */ +CHRPAK (a, a_off, b, b_off, nchars) +XCHAR *a, *b; +XINT *a_off, *b_off, *nchars; +{ + register XCHAR *ip; + register unsigned char *op; + register int n, ch; + + ip = &a[*a_off-1]; + op = &((unsigned char *)b)[*b_off-1]; + n = *nchars; + + while (--n >= 0) + *op++ = ((ch = *ip++) >= 0) ? ch : ch + 256; +} diff --git a/sys/osb/chrpak.f b/sys/osb/chrpak.f new file mode 100644 index 00000000..e34812fc --- /dev/null +++ b/sys/osb/chrpak.f @@ -0,0 +1,13 @@ +c CHRPAK -- Pack XCHAR (integer*2) into bytes. Should work on most byte +c addressable machines. The input and output arrays may be the same. + + subroutine chrpak (a, aoff, b, boff, nchars) + + integer*2 a(*) + character*1 b(*) + integer aoff, boff, nchars, i + + do 10 i = 0, nchars-1 + b(boff+i) = char (a(aoff+i)) + 10 continue + end diff --git a/sys/osb/chrupk.c b/sys/osb/chrupk.c new file mode 100644 index 00000000..f909c8d9 --- /dev/null +++ b/sys/osb/chrupk.c @@ -0,0 +1,32 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* CHRUPK -- Unpack a byte string into XCHAR. This routine does not + * know about EOS terminators. The input and output arrays may be the same. + * Note that while XCHAR is signed, the signedness of the C char is unspecified, + * hence we pack the chars into unsigned bytes and restore the sign explicitly. + */ +CHRUPK (a, a_off, b, b_off, nchars) +XCHAR *a, *b; +XINT *a_off, *b_off, *nchars; +{ + register unsigned char *ip; + register XCHAR *op; + register int n, ch; + + /* Set pointers to last char plus one so that we can unpack the array + * in the reverse direction. + */ + n = *nchars; + ip = &((unsigned char *)a)[*a_off-1+n]; + op = &b[*b_off-1+n]; + + /* Unpack string from right to left. + */ + while (--n >= 0) + *--op = ((ch = *--ip) <= 127) ? ch : ch - 256; +} diff --git a/sys/osb/chrupk.f b/sys/osb/chrupk.f new file mode 100644 index 00000000..3a1d7f44 --- /dev/null +++ b/sys/osb/chrupk.f @@ -0,0 +1,13 @@ +c CHRUPK -- Unpack bytes into XCHAR (integer*2). Should work on most byte +c addressable machines. The input and output arrays may be the same. + + subroutine chrupk (a, aoff, b, boff, nchars) + + character*1 a(*) + integer*2 b(*) + integer aoff, boff, nchars, i + + do 10 i = 0, nchars-1 + b(boff+i) = ichar (a(aoff+i)) + 10 continue + end diff --git a/sys/osb/d1mach.f b/sys/osb/d1mach.f new file mode 120000 index 00000000..12ea8148 --- /dev/null +++ b/sys/osb/d1mach.f @@ -0,0 +1 @@ +/iraf/iraf/unix/hlib/d1mach.f \ No newline at end of file diff --git a/sys/osb/f77pak.f b/sys/osb/f77pak.f new file mode 100644 index 00000000..db7df6f0 --- /dev/null +++ b/sys/osb/f77pak.f @@ -0,0 +1,32 @@ +c F77PAK -- Convert an SPP string into a Fortran 77 string. +c + subroutine f77pak (sppstr, f77str, maxch) +c + integer*2 sppstr(*) + character*(*) f77str + integer maxch + integer i, ch, last, maxout, EOS + parameter (EOS=0) +c + maxout = min (maxch, len(f77str)) +c +c # Unpack the EOS delimited SPP string. + last = maxout + do 10 i = 1, maxout + ch = sppstr(i) + if (ch .eq. EOS) then + last = i - 1 + goto 20 + endif + f77str(i:i) = char (ch) + 10 continue + 20 continue +c +c # Pad on the right with blanks. + if (last .gt. maxch) last = maxch + if (last .le. 0) then + f77str = ' ' + else + f77str = f77str(1:last) + endif + end diff --git a/sys/osb/f77upk.f b/sys/osb/f77upk.f new file mode 100644 index 00000000..fc875008 --- /dev/null +++ b/sys/osb/f77upk.f @@ -0,0 +1,26 @@ +c F77UPK -- Convert a Fortran 77 string into an SPP string. Unpack +c each Fortran character into an SPP char and trim the blank padding +c at the right. +c + subroutine f77upk (f77str, sppstr, maxch) +c + character*(*) f77str + integer*2 sppstr(*) + integer maxch + integer lastch, nchars, i + integer EOS, BLANK + parameter (EOS=0, BLANK=32) +c +c -- Unpack string. + nchars = min (maxch, len(f77str)) + lastch = 0 + do 10 i = 1, nchars + sppstr(i) = ichar (f77str(i:i)) + if (sppstr(i) .gt. BLANK) lastch = i + 10 continue +c +c -- Add EOS delimiter to SPP string, trimming blank padding at right. + if (lastch .gt. maxch) lastch = maxch + sppstr(lastch+1) = EOS +c + end diff --git a/sys/osb/i1mach.f b/sys/osb/i1mach.f new file mode 120000 index 00000000..3cfa7dae --- /dev/null +++ b/sys/osb/i1mach.f @@ -0,0 +1 @@ +/iraf/iraf/unix/hlib/i1mach.f \ No newline at end of file diff --git a/sys/osb/i32to64.c b/sys/osb/i32to64.c new file mode 100644 index 00000000..4b4b00d1 --- /dev/null +++ b/sys/osb/i32to64.c @@ -0,0 +1,42 @@ +#define import_spp +#define import_knames +#include + +/* I32TO64 - Convert big endian 32bit integer array into 64bit. + */ +int +I32TO64 (void *a, void *b, XINT *nelems) +{ + XINT i, j, k; + char *ip = (char *) a, + *op = (char *) b; + + + j = *nelems * 8; + k = *nelems * 4; + + if ( ip < op ) { + for ( i = k ; 0 < i ; i-- ) + op[i-1] = ip[i-1]; + } + else if ( op < ip ) { + for ( i = 0 ; i < k ; i++ ) + op[i] = ip[i]; + } + + for ( i=0 ; i < *nelems ; i++ ) { + char pad; + op[--j] = op[--k]; + op[--j] = op[--k]; + op[--j] = op[--k]; + op[--j] = op[--k]; + if ( (op[k] & 0x080) != 0 ) pad = 0x0ff; + else pad = 0; + op[--j] = pad; + op[--j] = pad; + op[--j] = pad; + op[--j] = pad; + } + + return 0; +} diff --git a/sys/osb/i64to32.c b/sys/osb/i64to32.c new file mode 100644 index 00000000..2b6a619c --- /dev/null +++ b/sys/osb/i64to32.c @@ -0,0 +1,98 @@ +#define import_spp +#define import_knames +#include + +/* I64TO32 - Convert big endian 64bit integer array into 32bit. + */ +int +I64TO32 (void *a, void *b, XINT *nelems) +{ + char *ip = (char *)a, + *op = (char *)b; + XINT i; + + + /* + * in |--------| + * out |----| + */ + if ( op <= ip ) { + for ( i=0 ; i < *nelems ; i++ ) { + ip += 4; + *op = *ip; + op++; ip++; + *op = *ip; + op++; ip++; + *op = *ip; + op++; ip++; + *op = *ip; + op++; ip++; + } + } + else { + + char *ipe = (char *)a + *nelems * 8 - 1; + char *ope = (char *)b + *nelems * 4 - 1; + + /* + * in |--------| + * out |----| + */ + if ( ipe <= ope ) { + for ( i=0 ; i < *nelems ; i++ ) { + *ope = *ipe; + ope--; ipe--; + *ope = *ipe; + ope--; ipe--; + *ope = *ipe; + ope--; ipe--; + *ope = *ipe; + ope--; ipe--; + ipe -= 4; + } + } + /* + * in |--------| + * out |----| + */ + else { + + for ( i=0 ; i < *nelems ; i++ ) { + /* --------> */ + ip += 4; + if ( op < ip ) { + *op = *ip; + op++; ip++; + *op = *ip; + op++; ip++; + *op = *ip; + op++; ip++; + *op = *ip; + op++; ip++; + } + else { + op += 4; + ip += 4; + } + /* <-------- */ + if ( ipe < ope ) { + *ope = *ipe; + ope--; ipe--; + *ope = *ipe; + ope--; ipe--; + *ope = *ipe; + ope--; ipe--; + *ope = *ipe; + ope--; ipe--; + } + else { + ope -= 4; + ipe -= 4; + } + ipe -= 4; + } + } + } + + return 0; +} diff --git a/sys/osb/iand32.c b/sys/osb/iand32.c new file mode 100644 index 00000000..b812cad5 --- /dev/null +++ b/sys/osb/iand32.c @@ -0,0 +1,12 @@ + +#define iand32 iand32_ + +long +iand32 (long *a, long *b) +{ + long val = 0; + int ia = (int) (*a >> 32), ib = (int) *b; + + val = (ia & ib); + return ((long) val); +} diff --git a/sys/osb/ieee.gx b/sys/osb/ieee.gx new file mode 100644 index 00000000..64659cd3 --- /dev/null +++ b/sys/osb/ieee.gx @@ -0,0 +1,391 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEF). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +$if (datatype == r) +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 +$else +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 2 # MACHDEP (normally 1, 2 on e.g. Intel) +$endif + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpak$t (native, ieee, nelem) + +PIXEL native[ARB] #I input native floating format array +PIXEL ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amov$t (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupk$t (ieee, native, nelem) + +PIXEL ieee[ARB] #I input IEEE floating format array +PIXEL native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i, val +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +int iand32() +$endif +% equivalence (ival, val) + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = native[i] +$if (datatype == r) + expon = and (ival[IOFF], NaNmask) +$else + if (SZ_INT == SZ_INT32) + expon = and (ival[IOFF], NaNmask) + else + expon = iand32 (val, NaNmask) +$endif + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } + } else { + if (mapin == NO) + call amov$t (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = ieee[i] +$if (datatype == r) + expon = and (ival[IOFF], NaNmask) +$else + if (SZ_INT == SZ_INT32) + expon = and (ival[IOFF], NaNmask) + else + expon = iand32 (val, NaNmask) +$endif + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepak$t (x) + +PIXEL x #U datum to be converted + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupk$t (x) + +PIXEL x #U datum to be converted + +int expon, val +$if (datatype == r) +real fval +int ival[1] +% equivalence (fval, ival) +$else +double fval +int ival[2] +% equivalence (fval, ival) +int iand32() +$endif +% equivalence (val, ival) + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + fval = x +$if (datatype == r) + expon = and (ival[IOFF], NaNmask) +$else + if (SZ_INT == SZ_INT32) + expon = and (ival[IOFF], NaNmask) + else + expon = iand32 (val, NaNmask) +$endif + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnan$t (x) + +PIXEL x #I native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnan$t (x) + +PIXEL x #O native value which will replace NaN + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestat$t (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstat$t () + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemap$t (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmap$t (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmap$t (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmap$t (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +#$if (datatype == r) +#% real r_quiet_nan +#$else +#% double precision d_quiet_nan +#$endif + +PIXEL native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenan$t/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. +# if (mapout == YES) +# $if (datatype == r) +#% ieeenn = r_quiet_NaN() +# $else +#% ieeenn = d_quiet_NaN() +# $endif + + if (mapin == YES) + $if (datatype == r) + NaNmask = 7F800000X + $else + NaNmask = 7FF00000X + $endif +end diff --git a/sys/osb/ieeed.x b/sys/osb/ieeed.x new file mode 100644 index 00000000..f29c1aa3 --- /dev/null +++ b/sys/osb/ieeed.x @@ -0,0 +1,356 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFD). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP8 +define BSWAP bswap8 +define NSWAP 8 +define IOFF 2 # MACHDEP (normally 1, 2 on e.g. Intel) + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakd (native, ieee, nelem) + +double native[ARB] #I input native floating format array +double ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovd (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkd (ieee, native, nelem) + +double ieee[ARB] #I input IEEE floating format array +double native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i, val +double fval +int ival[2] +% equivalence (fval, ival) +int iand32() +% equivalence (ival, val) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = native[i] + if (SZ_INT == SZ_INT32) + expon = and (ival[IOFF], NaNmask) + else + expon = iand32 (val, NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } + } else { + if (mapin == NO) + call amovd (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = ieee[i] + if (SZ_INT == SZ_INT32) + expon = and (ival[IOFF], NaNmask) + else + expon = iand32 (val, NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakd (x) + +double x #U datum to be converted + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkd (x) + +double x #U datum to be converted + +int expon, val +double fval +int ival[2] +% equivalence (fval, ival) +int iand32() +% equivalence (val, ival) + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + fval = x + if (SZ_INT == SZ_INT32) + expon = and (ival[IOFF], NaNmask) + else + expon = iand32 (val, NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnand (x) + +double x #I native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnand (x) + +double x #O native value which will replace NaN + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatd (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatd () + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemapd (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmapd (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmapd (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmapd (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +#$if (datatype == r) +#% real r_quiet_nan +#$else +#% double precision d_quiet_nan +#$endif + +double native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenand/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. +# if (mapout == YES) +# $if (datatype == r) +#% ieeenn = r_quiet_NaN() +# $else +#% ieeenn = d_quiet_NaN() +# $endif + + if (mapin == YES) + NaNmask = 7FF00000X +end diff --git a/sys/osb/ieeer.x b/sys/osb/ieeer.x new file mode 100644 index 00000000..59ce8566 --- /dev/null +++ b/sys/osb/ieeer.x @@ -0,0 +1,345 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help IEEE +.nf ------------------------------------------------------------------------ +Low level primitives for IEEE to native floating point datatype conversions. +See also the MII package, which provides a higher level interface, and the +IEEE related definitions in . + + ieepak[rd] (datum) # scalar conversions + ieeupk[rd] (datum) + ieevpak[rd] (native, ieee, nelem) # vector conversions + ieevupk[rd] (ieee, native, nelem) + iee[sg]nan[rd] (NaN) # NaN handling + iee[sg]map[rd] (mapin, mapout) + ieestat[rd] (nin, nout) + ieezstat[rd] () + +The first two routines handle scalar conversions, the second two routines +vector conversions. The input and output vectors may be the same. +Unfortunately, for portability reasons, functions cannot be used, so the +scalar operators do an in-place conversion instead, and are a no-op on an +unswapped IEEE system. The routines iee[sg]nan[rd] set/get the native +floating value used to replace NaNs or overflows occuring when converting +IEEE to the native floating format (any floating value will do, e.g., zero or +INDEFR). If NaN mapping is enabled, the ieestat[rd] routines may be used to +determine the number of input or output NaN conversions occuring since the +last call to ieezstat[rd]. + +The NaN mapping enable switch and statistics counters are UNDEFINED at +process startup; programs which use the IEEE conversion package should call +ieesmap[rd] to enable or disable NaN mapping, and ieezstat[rd] to initialize +the statistics counters. + +The routines in this file are the "portable" versions. The "portable" +solution it to merely copy the array, swapping the bytes if necessary - this +works on any host that uses the IEEE floating format. NaN mapping is +implemented in the portable code, but will work properly only for input +conversions; for output, the IEEE NaN value is undefined in the portable +version of the code (it is trivial to supply this value in an as$ieee.gx +version of the code). +If the local host does +not use IEEE floating, or if a significant efficiency gain can be realized +by programming in assembler or C, a host specific version of this file should +be written, placed in AS, and referenced in the MKPKG special file list. +.endhelp ------------------------------------------------------------------- + + +# Give the generic preprocessor some help. +define IEEE_SWAP IEEE_SWAP4 +define BSWAP bswap4 +define NSWAP 4 +define IOFF 1 + + +# IEEVPAK -- Convert an array in the native floating point format into an +# array in IEEE floating format. The input and output arrays can be the same. + +procedure ieevpakr (native, ieee, nelem) + +real native[ARB] #I input native floating format array +real ieee[ARB] #O output IEEE floating format array +int nelem #I number of floating point numbers + +int i +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout == NO) { + if (IEEE_SWAP == YES) + call BSWAP (native, 1, ieee, 1, nelem * NSWAP) + else + call amovr (native, ieee, nelem) + } else { + do i = 1, nelem + if (native[i] == native_NaN) { + ieee(i) = ieee_NaN + nout = nout + 1 + } else + ieee[i] = native[i] + + # Byteswap if necessary. + if (IEEE_SWAP == YES) + call BSWAP (ieee, 1, ieee, 1, nelem * NSWAP) + } +end + + +# IEEVUPK -- Convert an array in IEEE floating format into the native +# floating point format. The input and output arrays can be the same. + +procedure ieevupkr (ieee, native, nelem) + +real ieee[ARB] #I input IEEE floating format array +real native[ARB] #O output native floating format array +int nelem #I number of floating point numbers + +int expon, i, val +real fval +int ival[1] +% equivalence (fval, ival) +% equivalence (ival, val) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) { + call BSWAP (ieee, 1, native, 1, nelem * NSWAP) + if (mapin != NO) { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = native[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } + } + } + } else { + if (mapin == NO) + call amovr (ieee, native, nelem) + else { + # Check for IEEE exceptional values and map NaN to the native + # NaN value, and denormalized numbers (zero exponent) to zero. + + do i = 1, nelem { + fval = ieee[i] + expon = and (ival[IOFF], NaNmask) + if (expon == 0) { + native[i] = 0 + } else if (expon == NaNmask) { + native[i] = native_NaN + nin = nin + 1 + } else + native[i] = ieee[i] + } + } + } +end + + +# IEEPAK -- Convert a native floating point number into IEEE format. + +procedure ieepakr (x) + +real x #U datum to be converted + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (mapout != NO) + if (x == native_NaN) { + x = ieee_NaN + nout = nout + 1 + } + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) +end + + +# IEEUPK -- Convert an IEEE format number into native floating point. + +procedure ieeupkr (x) + +real x #U datum to be converted + +int expon, val +real fval +int ival[1] +% equivalence (fval, ival) +% equivalence (val, ival) + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + if (IEEE_SWAP == YES) + call BSWAP (x, 1, x, 1, NSWAP) + + # Check for IEEE exceptional values and map NaN to the native NaN + # value, and denormalized numbers (zero exponent) to zero. + + if (mapin != NO) { + fval = x + expon = and (ival[IOFF], NaNmask) + if (expon == 0) + x = 0 + else if (expon == NaNmask) { + x = native_NaN + nin = nin + 1 + } + } +end + + +# IEESNAN -- Set the native floating point value used to replace NaNs and +# overflows when converting IEEE to native. This must be a legal (finite) +# native floating point value. + +procedure ieesnanr (x) + +real x #I native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + native_NaN = x + nin = 0 + nout = 0 +end + + +# IEEGNAN -- Get the NaN value. + +procedure ieegnanr (x) + +real x #O native value which will replace NaN + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + x = native_NaN +end + + +# IEESTAT -- Return statistics on the number of NaNs encountered in input +# conversions (unpack) and output conversions (pack). + +procedure ieestatr (o_nin, o_nout) + +int o_nin #O number of NaN seen on input +int o_nout #O number of NaN values output + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + o_nin = nin + o_nout = nout +end + + +# IEEZSTAT -- Zero the statistics counters. + +procedure ieezstatr () + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + nin = 0 + nout = 0 +end + + +# IEEMAP -- Same as IEESMAP. Retained for backwards compatibility. + +procedure ieemapr (inval, outval) + +int inval #I enable mapping on input +int outval #I enable mapping on output + +begin + call ieesmapr (inval, outval) +end + + +# IEEGMAP -- Query the current values of the input and output mapping +# enables. + +procedure ieegmapr (inval, outval) + +int inval #O get input mapping enable flag +int outval #O get output mapping enable flag + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + inval = mapin + outval = mapout +end + + +# MACHINE DEPENDENT PART. +# --------------------------- + +# IEESMAP -- Enable or disable NaN mapping. +# +# sEEE EEEE Emmm mmmm mmmm mmmm mmmm mmmm +# 3 2 1 0 +# 1098 7654 3210 9876 5432 1098 7654 3210 +# 7 f 8 0 0 0 0 0 + +procedure ieesmapr (inval, outval) + +int inval #I enable NaN mapping for input? +int outval #I enable NaN mapping for output? + +# MACHDEP. +#$if (datatype == r) +#% real r_quiet_nan +#$else +#% double precision d_quiet_nan +#$endif + +real native_NaN, ieee_NaN +int mapin, mapout, nin, nout, NaNmask +common /ieenanr/ native_NaN, ieee_NaN, NaNmask, mapin, mapout, nin, nout + +begin + mapin = inval + mapout = outval + + # MACHDEP. +# if (mapout == YES) +# $if (datatype == r) +#% ieeenn = r_quiet_NaN() +# $else +#% ieeenn = d_quiet_NaN() +# $endif + + if (mapin == YES) + NaNmask = 7F800000X +end diff --git a/sys/osb/imul32.c b/sys/osb/imul32.c new file mode 100644 index 00000000..237bd5fa --- /dev/null +++ b/sys/osb/imul32.c @@ -0,0 +1,24 @@ +#define import_spp +#define import_knames +#include + + +/* IMUL32 - Multiply two integer values and return the result. This is + * needed to allow e.g. the normal overflow condition to occur for algorithms + * such as random number generators. + */ +int +IMUL32 (long *a, long *b) +{ + int val = 0; + int ia = (int) *a; + int ib = (int) *b; + + + /* MACHDEP - Depends on integer overflow behavior for a specific + * platform. + */ + val = ia * ib; + + return ((int) val); +} diff --git a/sys/osb/ipak16.c b/sys/osb/ipak16.c new file mode 100644 index 00000000..94670857 --- /dev/null +++ b/sys/osb/ipak16.c @@ -0,0 +1,20 @@ +#define import_spp +#define import_knames +#include + +/* IPAK16 - Pack an array of native ints into and array of 16-bit short. + */ +void +IPAK16 (void *a, void *b, XINT *nelems) +{ + /* MACHDEP - Works only for little-endian systems (e.g. x86) + */ + int i = 0; + int *ip = (int *) a; + short *op = (short *) b; + + for (i=0; i < *nelems; i++) { + *op = (int) *ip; + op++, ip++; + } +} diff --git a/sys/osb/ipak32.c b/sys/osb/ipak32.c new file mode 100644 index 00000000..a4f5061b --- /dev/null +++ b/sys/osb/ipak32.c @@ -0,0 +1,23 @@ +#define import_spp +#define import_knames +#include + +/* IPAK32 - Pack 64-bit int into and array of 32-bit int. + */ +void +IPAK32 (void *a, void *b, XINT *nelems) +{ + /* MACHDEP - Works only for little-endian systems (e.g. x86) + */ + XINT *ip = (XINT *) a; + int *op = (int *) calloc (*nelems, sizeof (int)); + int *tmp, i; + + tmp = op; + for (i=0; i < *nelems; i++, ip++) { + *tmp++ = (int) (*ip); + } + memmove (b, op, *nelems * sizeof (int)); + + free (op); +} diff --git a/sys/osb/iscl32.c b/sys/osb/iscl32.c new file mode 100644 index 00000000..75e51082 --- /dev/null +++ b/sys/osb/iscl32.c @@ -0,0 +1,31 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include +#include + + +/* ISCL32 - Scale a pixel array stored as SPP chars to the desired type. + */ +ISCL32 (a, b, npix, bscale, bzero) +XCHAR *a; /* input array */ +XCHAR *b; /* output array */ +XINT *npix; /* number of bytes to swap */ +XDOUBLE *bscale, *bzero; /* scaling factors */ +{ + int i, pix; + int *ip = (int *) a; + float *rp = (float *) calloc (*npix, sizeof (float)); + float *tmp; + + tmp = rp; + for (i=0; i < *npix; i++) { + pix = *ip; + *tmp = (float) (pix * (*bscale) + (*bzero)); + tmp++, ip++; + } + + memmove (b, rp, (*npix * sizeof (float))); +} diff --git a/sys/osb/iscl64.c b/sys/osb/iscl64.c new file mode 100644 index 00000000..6a8b624c --- /dev/null +++ b/sys/osb/iscl64.c @@ -0,0 +1,31 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include +#include + + +/* ISCL64 - Scale a pixel array stored as SPP chars to the desired type. + */ +ISCL64 (a, b, npix, bscale, bzero) +XCHAR *a; /* input array */ +XCHAR *b; /* output array */ +XINT *npix; /* number of bytes to swap */ +XDOUBLE *bscale, *bzero; /* scaling factors */ +{ + int i, pix; + int *ip = (int *) a; + double *dp = (double *) calloc (*npix, sizeof (double)); + double *tmp; + + tmp = dp; + for (i=0; i < *npix; i++) { + pix = *ip; + *tmp = (double) (pix * (*bscale) + (*bzero)); + tmp++, ip++; + } + + memmove (b, dp, (*npix * sizeof (double))); +} diff --git a/sys/osb/iupk16.c b/sys/osb/iupk16.c new file mode 100644 index 00000000..10b5c064 --- /dev/null +++ b/sys/osb/iupk16.c @@ -0,0 +1,21 @@ +#define import_spp +#define import_knames +#include + + +/* IUPK16 - Unpack 16-bit int into and array of native integers. + */ +void +IUPK16 (void *a, void *b, XINT *nelems) +{ + int i; + int *op = (int *) calloc (*nelems, sizeof (int)), *tmp; + short *ip = (short *) a; + + tmp = op; + for (i=0; i < *nelems; i++) + *tmp++ = *ip++; + + memmove (b, op, *nelems * sizeof (int)); + free (op); +} diff --git a/sys/osb/iupk32.c b/sys/osb/iupk32.c new file mode 100644 index 00000000..a280b805 --- /dev/null +++ b/sys/osb/iupk32.c @@ -0,0 +1,23 @@ +#define import_spp +#define import_knames +#include + + +/* IUPK32 - Unpack 32-bit int into and array of 64-bit int. + */ +void +IUPK32 (void *a, void *b, XINT *nelems) +{ + XINT i, *tmp; + XINT *op = (XINT *) calloc (*nelems, sizeof (XINT)); + int *ip = (int *) a; + + + tmp = op; + for (i=0; i < *nelems; i++) { + *tmp++ = *ip++; + } + memmove (b, op, *nelems * sizeof (XINT)); + + free (op); +} diff --git a/sys/osb/miilen.x b/sys/osb/miilen.x new file mode 100644 index 00000000..1eb16d1a --- /dev/null +++ b/sys/osb/miilen.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MIILEN -- Determine the number of SPP integers to store nelems of type +# mii_type. The mii_type are defined in mii.h. +# +# THIS PROCEDURE HAS BEEN OBSOLETED BY MIIPAKLEN. + +int procedure miilen (nelems, mii_datatype) + +int nelems #I number of MII data elements +int mii_datatype #I datatype of MII data + +begin + return (((nelems * abs(mii_datatype) / NBITS_BYTE + SZB_CHAR - 1) / + SZB_CHAR + SZ_INT32 - 1) / SZ_INT32) +end diff --git a/sys/osb/miinelem.x b/sys/osb/miinelem.x new file mode 100644 index 00000000..2ae53882 --- /dev/null +++ b/sys/osb/miinelem.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MIINELEM -- Determine the number of MII elements of the given datatype +# which can be stored in an SPP char array of the indicated length. +# The mii_type codes are defined in mii.h; we assume here that the codes +# used are the number of bits in each MII type. + +int procedure miinelem (nchars, mii_type) + +int nchars #I size in chars of packed array +int mii_type #I MII type of packed data + +int nbits + +begin + nbits = abs (mii_type) + return ((nchars * SZB_CHAR * NBITS_BYTE) / nbits) +end diff --git a/sys/osb/miipak.x b/sys/osb/miipak.x new file mode 100644 index 00000000..b86bc054 --- /dev/null +++ b/sys/osb/miipak.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help mii +.nf ___________________________________________________________________________ +MII -- Machine independent integer format conversion routines. The MII integer +format provides for three machine independent integer datatypes: + + MII_BYTE 8 bit unsigned byte + MII_SHORT 16 bit twos complement signed integer + MII_LONG 32 bit twos complement signed integer + +plus, more recently, two IEEE floating point formats: + + MII_REAL 32 bit IEEE floating point + MII_DOUBLE 64 bit IEEE floating point + +The MII datatypes are the same as are used in the FITS transportable image +format. In the case of the short and long integers, the most significant +bytes of an integer are given first. + +The routines in this package are provided for converting to and from the +MII format and the SPP format. The latter format, of course, is potentially +quite machine dependent. The implementation given here assumes that the +SPP datatypes include 16 bit and 32 bit twos complement integers; the ordering +of the bytes within these integer formats is described by the machine +constants BYTE_SWAP2 and BYTE_SWAP4. Byte swapping for the IEEE floating +formats is defined by the machine constants IEEE_SWAP4 and IEEE_SWAP8. +.endhelp ______________________________________________________________________ + + +# MIIPAK -- Pack a SPP array of type spp_type into a MII array of type +# mii_type. The mii_types are defined in mii.h. + +procedure miipak (spp, mii, nelems, spp_datatype, mii_datatype) + +int spp[ARB] #I input array of SPP integers +int mii[ARB] #O output MII format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code +int mii_datatype #I MII datatype code + +begin + switch (mii_datatype) { + case MII_BYTE: + call miipak8 (spp, mii, nelems, spp_datatype) + case MII_SHORT: + call miipak16 (spp, mii, nelems, spp_datatype) + case MII_LONG: + call miipak32 (spp, mii, nelems, spp_datatype) + case MII_REAL: + call miipakr (spp, mii, nelems, spp_datatype) + case MII_DOUBLE: + call miipakd (spp, mii, nelems, spp_datatype) + } +end diff --git a/sys/osb/miipak16.x b/sys/osb/miipak16.x new file mode 100644 index 00000000..d972c0fa --- /dev/null +++ b/sys/osb/miipak16.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MIIPAK16 -- Pack an SPP array of the indicated datatype into an 16 bit +# signed MII array. + +procedure miipak16 (spp, mii, nelems, spp_datatype) + +int spp[ARB] #I input array of SPP integers +int mii[ARB] #O output MII format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + switch (spp_datatype) { + case TY_UBYTE: + call achtbs (spp, mii, nelems) + case TY_USHORT: + call achtus (spp, mii, nelems) + case TY_CHAR: + call achtcs (spp, mii, nelems) + case TY_SHORT: + call achtss (spp, mii, nelems) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtis (spp, mii, nelems) + case TY_LONG: + call achtls (spp, mii, nelems) + case TY_REAL: + call achtrs (spp, mii, nelems) + case TY_DOUBLE: + call achtds (spp, mii, nelems) + case TY_COMPLEX: + call achtxs (spp, mii, nelems) + } + + if (BYTE_SWAP2 == YES) + call bswap2 (mii, 1, mii, 1, nelems * (16 / NBITS_BYTE)) +end diff --git a/sys/osb/miipak32.x b/sys/osb/miipak32.x new file mode 100644 index 00000000..1586f4ea --- /dev/null +++ b/sys/osb/miipak32.x @@ -0,0 +1,67 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MIIPAK32 -- Pack an SPP array of the indicated datatype into an 32 bit +# signed MII array. + +procedure miipak32 (spp, mii, nelems, spp_datatype) + +int spp[ARB] #I input array of SPP integers +int mii[ARB] #O output MII format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +int mii_bytes +int spp_bytes +int sizeof() +pointer tmpp + +begin + call malloc (tmpp, nelems, TY_LONG) + + mii_bytes = 32 / NBITS_BYTE + spp_bytes = sizeof(spp_datatype) * SZB_CHAR + + switch (spp_datatype) { + case TY_UBYTE: + call achtbl (spp, Meml[tmpp], nelems) + case TY_USHORT: + call achtul (spp, Meml[tmpp], nelems) + case TY_CHAR: + call achtcl (spp, Meml[tmpp], nelems) + case TY_SHORT: + call achtsl (spp, Meml[tmpp], nelems) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtil (spp, Meml[tmpp], nelems) + case TY_LONG: + call achtll (spp, Meml[tmpp], nelems) + case TY_REAL: + call achtrl (spp, Meml[tmpp], nelems) + case TY_DOUBLE: + call achtdl (spp, Meml[tmpp], nelems) + case TY_COMPLEX: + call achtxl (spp, Meml[tmpp], nelems) + } + + if ( mii_bytes == spp_bytes ) { + if (BYTE_SWAP4 == YES) + call bswap4 (Meml[tmpp], 1, mii, 1, nelems * (mii_bytes)) + else if (BYTE_SWAP2 == YES) + call bswap2 (Meml[tmpp], 1, mii, 1, nelems * (mii_bytes)) + } + else if ( 2 * mii_bytes == spp_bytes ) { + if (BYTE_SWAP8 == YES) + call bswap8 (Meml[tmpp], 1, Meml[tmpp], 1, nelems * (spp_bytes)) + else if (BYTE_SWAP4 == YES) + call bswap4 (Meml[tmpp], 1, Meml[tmpp], 1, nelems * (spp_bytes)) + else if (BYTE_SWAP2 == YES) + call bswap2 (Meml[tmpp], 1, Meml[tmpp], 1, nelems * (spp_bytes)) + call i64to32 ( Meml[tmpp], mii, nelems ) + } + else { + call eprintf("[ERROR] miipak32.x: unexpected integer size\n") + } + + call mfree (tmpp, TY_LONG) +end diff --git a/sys/osb/miipak8.x b/sys/osb/miipak8.x new file mode 100644 index 00000000..ea4e16ea --- /dev/null +++ b/sys/osb/miipak8.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# MIIPAK8 -- Pack an SPP array of the indicated datatype into an 8 bit +# unsigned MII array. + +procedure miipak8 (spp, mii, nelems, spp_datatype) + +int spp[ARB] #I input array of SPP integers +int mii[ARB] #O output MII format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + switch (spp_datatype) { + case TY_UBYTE: + call achtbb (spp, mii, nelems) + case TY_USHORT: + call achtub (spp, mii, nelems) + case TY_CHAR: + call achtcb (spp, mii, nelems) + case TY_SHORT: + call achtsb (spp, mii, nelems) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtib (spp, mii, nelems) + case TY_LONG: + call achtlb (spp, mii, nelems) + case TY_REAL: + call achtrb (spp, mii, nelems) + case TY_DOUBLE: + call achtdb (spp, mii, nelems) + case TY_COMPLEX: + call achtxb (spp, mii, nelems) + } +end diff --git a/sys/osb/miipakd.x b/sys/osb/miipakd.x new file mode 100644 index 00000000..b0766221 --- /dev/null +++ b/sys/osb/miipakd.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MIIPAKD -- Pack an SPP array of the indicated datatype into an 64 bit +# IEEE floating format. + +procedure miipakd (spp, mii, nelems, spp_datatype) + +int spp[ARB] #I input array of SPP integers +double mii[ARB] #O output MII format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + if (spp_datatype == TY_DOUBLE) + call ieevpakd (spp, mii, nelems) + else { + switch (spp_datatype) { + case TY_UBYTE: + call achtbd (spp, mii, nelems) + case TY_USHORT: + call achtud (spp, mii, nelems) + case TY_CHAR: + call achtcd (spp, mii, nelems) + case TY_SHORT: + call achtsd (spp, mii, nelems) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtid (spp, mii, nelems) + case TY_LONG: + call achtld (spp, mii, nelems) + case TY_REAL: + call achtrd (spp, mii, nelems) + case TY_COMPLEX: + call achtxd (spp, mii, nelems) + default: + call amovd (spp, mii, nelems) + } + + call ieevpakd (mii, mii, nelems) + } +end diff --git a/sys/osb/miipakr.x b/sys/osb/miipakr.x new file mode 100644 index 00000000..e6d0a5be --- /dev/null +++ b/sys/osb/miipakr.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MIIPAKR -- Pack an SPP array of the indicated datatype into an 32 bit +# IEEE floating format. + +procedure miipakr (spp, mii, nelems, spp_datatype) + +int spp[ARB] #I input array of SPP integers +real mii[ARB] #O output MII format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + if (spp_datatype == TY_REAL) + call ieevpakr (spp, mii, nelems) + else { + switch (spp_datatype) { + case TY_UBYTE: + call achtbr (spp, mii, nelems) + case TY_USHORT: + call achtur (spp, mii, nelems) + case TY_CHAR: + call achtcr (spp, mii, nelems) + case TY_SHORT: + call achtsr (spp, mii, nelems) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtir (spp, mii, nelems) + case TY_LONG: + call achtlr (spp, mii, nelems) + case TY_DOUBLE: + call achtdr (spp, mii, nelems) + case TY_COMPLEX: + call achtxr (spp, mii, nelems) + default: + call amovr (spp, mii, nelems) + } + + call ieevpakr (mii, mii, nelems) + } +end diff --git a/sys/osb/miipksize.x b/sys/osb/miipksize.x new file mode 100644 index 00000000..16791e95 --- /dev/null +++ b/sys/osb/miipksize.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MIIPKSIZE -- Determine the size in SPP chars of the array required to store +# nelems of type mii_type in MII packed form. The mii_type codes are defined +# in mii.h; we assume here that the integer codes are the sizes of the MII +# types in bits. + +int procedure miipksize (nelems, mii_type) + +int nelems #I number of MII elements of type mii_type +int mii_type #I type code (=8,16,32,-32,-64) + +begin + return ((nelems * abs(mii_type) / NBITS_BYTE + SZB_CHAR-1) / SZB_CHAR) +end diff --git a/sys/osb/miiupk.x b/sys/osb/miiupk.x new file mode 100644 index 00000000..bb536987 --- /dev/null +++ b/sys/osb/miiupk.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MIIUPK -- Unpack a MII array of type mii_type into a SPP array of type +# spp_type. The mii_types are defined in mii.h. + +procedure miiupk (mii, spp, nelems, mii_datatype, spp_datatype) + +int mii[ARB] #I input MII format array +int spp[ARB] #O output SPP format array +int nelems #I number of integers to be converted +int mii_datatype #I MII datatype code +int spp_datatype #I SPP datatype code + +begin + switch (mii_datatype) { + case MII_BYTE: + call miiupk8 (mii, spp, nelems, spp_datatype) + case MII_SHORT: + call miiupk16 (mii, spp, nelems, spp_datatype) + case MII_LONG: + call miiupk32 (mii, spp, nelems, spp_datatype) + case MII_REAL: + call miiupkr (mii, spp, nelems, spp_datatype) + case MII_DOUBLE: + call miiupkd (mii, spp, nelems, spp_datatype) + } +end diff --git a/sys/osb/miiupk16.x b/sys/osb/miiupk16.x new file mode 100644 index 00000000..2e24b3dd --- /dev/null +++ b/sys/osb/miiupk16.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MIIUPK16 -- Unpack a 16 bit signed MII array into an SPP array of the +# indicated datatype. + +procedure miiupk16 (mii, spp, nelems, spp_datatype) + +int mii[ARB] #I input MII format array +int spp[ARB] #O output SPP format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + if (BYTE_SWAP2 == YES) { + call bswap2 (mii, 1, spp, 1, nelems * (16 / NBITS_BYTE)) + call achts (spp, spp, nelems, spp_datatype) + } else + call achts (mii, spp, nelems, spp_datatype) +end diff --git a/sys/osb/miiupk32.x b/sys/osb/miiupk32.x new file mode 100644 index 00000000..183805f7 --- /dev/null +++ b/sys/osb/miiupk32.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MIIUPK32 -- Unpack a 32 bit signed MII array into an SPP array of the +# indicated datatype. + +procedure miiupk32 (mii, spp, nelems, spp_datatype) + +int mii[ARB] #I input MII format array +int spp[ARB] #O output SPP format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +int mii_bytes +int spp_bytes +int sizeof() + +begin + mii_bytes = 32 / NBITS_BYTE + spp_bytes = sizeof(spp_datatype) * SZB_CHAR + + if ( mii_bytes == spp_bytes ) { + if (BYTE_SWAP4 == YES) { + call bswap4 (mii, 1, spp, 1, nelems * (mii_bytes)) + call achtl (spp, spp, nelems, spp_datatype) + } else if (BYTE_SWAP2 == YES) { + call bswap2 (mii, 1, spp, 1, nelems * (mii_bytes)) + call achtl (spp, spp, nelems, spp_datatype) + } else + call achtl (mii, spp, nelems, spp_datatype) + + } else if ( 2 * mii_bytes == spp_bytes ) { + call i32to64 (mii, spp, nelems) # for 64bit integer + if (BYTE_SWAP8 == YES) { + call bswap8 (spp, 1, spp, 1, nelems * (spp_bytes)) + call achtl (spp, spp, nelems, spp_datatype) + } else if (BYTE_SWAP4 == YES) { + call bswap4 (spp, 1, spp, 1, nelems * (spp_bytes)) + call achtl (spp, spp, nelems, spp_datatype) + } else if (BYTE_SWAP2 == YES) { + call bswap2 (spp, 1, spp, 1, nelems * (spp_bytes)) + call achtl (spp, spp, nelems, spp_datatype) + } else + call achtl (spp, spp, nelems, spp_datatype) + + } else { + call eprintf("[ERROR] miiupk32.x: unexpected integer size\n") + } +end diff --git a/sys/osb/miiupk8.x b/sys/osb/miiupk8.x new file mode 100644 index 00000000..34a3a378 --- /dev/null +++ b/sys/osb/miiupk8.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# MIIUPK8 -- Unpack an 8 bit unsigned MII array into an SPP array of the +# indicated datatype. + +procedure miiupk8 (mii, spp, nelems, spp_datatype) + +int mii[ARB] #I input MII format array +int spp[ARB] #O output SPP format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + call achtb (mii, spp, nelems, spp_datatype) +end diff --git a/sys/osb/miiupkd.x b/sys/osb/miiupkd.x new file mode 100644 index 00000000..b509ef3a --- /dev/null +++ b/sys/osb/miiupkd.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MIIUPKD -- Unpack a 64 bit IEEE floating array into an SPP array of the +# indicated datatype. + +procedure miiupkd (mii, spp, nelems, spp_datatype) + +double mii[ARB] #I input MII format array +int spp[ARB] #O output SPP format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + call ieevupkd (mii, spp, nelems) + if (spp_datatype != TY_DOUBLE) + call achtd (spp, spp, nelems, spp_datatype) +end diff --git a/sys/osb/miiupkr.x b/sys/osb/miiupkr.x new file mode 100644 index 00000000..2ff27ff8 --- /dev/null +++ b/sys/osb/miiupkr.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MIIUPKR -- Unpack a 32 bit IEEE floating array into an SPP array of the +# indicated datatype. + +procedure miiupkr (mii, spp, nelems, spp_datatype) + +real mii[ARB] #I input MII format array +int spp[ARB] #O output SPP format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + call ieevupkr (mii, spp, nelems) + if (spp_datatype != TY_REAL) + call achtr (spp, spp, nelems, spp_datatype) +end diff --git a/sys/osb/mkpkg b/sys/osb/mkpkg new file mode 100644 index 00000000..267b5ba6 --- /dev/null +++ b/sys/osb/mkpkg @@ -0,0 +1,167 @@ +# Make the OSB (bit and byte primitives) portion of the VOPS library. + +$checkout libvops.a lib$ +$update libvops.a +$checkin libvops.a lib$ +$exit + +generic: + # Convert the generic files into typed files. + $set GFLAGS = "-k -t UBcsilrdx" + $ifolder (achtiu.c, achtzu.gc) + $generic $(GFLAGS) achtzu.gc -o acht\$$tu.c $endif + $ifolder (achtib.c, achtzb.gc) + $generic $(GFLAGS) achtzb.gc -o acht\$$tb.c $endif + $ifolder (achtui.c, achtu.gc) + $generic $(GFLAGS) achtu.gc $endif + $ifolder (achtbi.c, achtb.gc) + $generic $(GFLAGS) achtb.gc $endif + $ifolder (ieeer.x, ieee.gx) + $generic -k -t rd ieee.gx $endif + ; + +libvops.a: + # Generic preprocessing is normally done only on the development system, + # and need not be available on all systems. + + $ifeq (USE_GENERIC, yes) $call generic $endif + + # The following contain machine dependent constants. + hlib$i1mach.f + hlib$d1mach.f + hlib$r1mach.f + + # The following should normally be optimized in assembler (see the + # special file list in "hlib$mkpkg.sf"). + + $ifeq (USE_CCOMPILER, yes) + bytmov.c + $else + bytmov.f + $end + + bitfields.c + aclrb.c # see also vops/ak/aclr*.x + + # The operation of the following depends upon integer overflow, which + # may result in an exception on some hosts. + + urand.x + imul32.c # added to support 64-bit + iscl32.c # added to support 64-bit + iscl64.c # added to support 64-bit + iand32.c # added to support 64-bit + strsum.c # added for VO integration support + + # If a C compiler is not available for the following they will have + # to be written in assembler or some other low level language, and + # added to the special file list. + + achtbb.c + achtbc.c + achtbd.c + achtbi.c + achtbl.c + achtbr.c + achtbs.c + achtbu.c + achtbx.c + achtcb.c + achtcu.c + achtdb.c + achtdu.c + achtib.c + achtiu.c + achtlb.c + achtlu.c + achtrb.c + achtru.c + achtsb.c + achtsu.c + achtub.c + achtuc.c + achtud.c + achtui.c + achtul.c + achtur.c + achtus.c + achtuu.c + achtux.c + achtxb.c + achtxu.c + and.c + not.c + or.c + shift.c + abs.c + i32to64.c + i64to32.c + ipak32.c + iupk32.c + ipak16.c + iupk16.c + + + # Both C and Fortran versions of the following are provided. + # The C versions are normally preferred and are the most portable. + + $ifeq (USE_CCOMPILER, yes) + bswap2.c + bswap4.c + bswap8.c + chrpak.c + chrupk.c + strpak.c + strupk.c + $else + bswap2.f + bswap4.f + bswap8.f # not written; wait until we need it + chrpak.f + chrupk.f + strpak.f + strupk.f + $endif + + # The following are fairly portable, but potentially machine dependent. + + ieeer.x + ieeed.x + + miilen.x + miinelem.x + miipak.x + miipak16.x + miipak32.x + miipak8.x + miipakd.x + miipakr.x + miipksize.x + miiupk.x + miiupk16.x + miiupk32.x + miiupk8.x + miiupkd.x + miiupkr.x + + nmilen.x + nminelem.x + nmipak.x + nmipak16.x + nmipak32.x + nmipak8.x + nmipakd.x + nmipakr.x + nmipksize.x + nmiupk.x + nmiupk16.x + nmiupk32.x + nmiupk8.x + nmiupkd.x + nmiupkr.x + + f77pak.f + f77upk.f + bitmov.x + xor.x + ; diff --git a/sys/osb/nmilen.x b/sys/osb/nmilen.x new file mode 100644 index 00000000..32cc2055 --- /dev/null +++ b/sys/osb/nmilen.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# NMILEN -- Determine the number of SPP integers to store nelems of type +# nmi_type. The nmi_type are defined in nmi.h. +# +# THIS PROCEDURE HAS BEEN OBSOLETED BY NMIPAKLEN. + +int procedure nmilen (nelems, nmi_datatype) + +int nelems #I number of NMI data elements +int nmi_datatype #I datatype of NMI data + +begin + return (((nelems * abs(nmi_datatype) / NBITS_BYTE + SZB_CHAR - 1) / + SZB_CHAR + SZ_INT - 1) / SZ_INT) +end diff --git a/sys/osb/nminelem.x b/sys/osb/nminelem.x new file mode 100644 index 00000000..4a21c3e6 --- /dev/null +++ b/sys/osb/nminelem.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# NMINELEM -- Determine the number of NMI elements of the given datatype +# which can be stored in an SPP char array of the indicated length. +# The nmi_type codes are defined in nmi.h; we assume here that the codes +# used are the number of bits in each NMI type. + +int procedure nminelem (nchars, nmi_type) + +int nchars #I size in chars of packed array +int nmi_type #I NMI type of packed data + +int nbits + +begin + nbits = abs (nmi_type) + return ((nchars * SZB_CHAR * NBITS_BYTE) / nbits) +end diff --git a/sys/osb/nmipak.x b/sys/osb/nmipak.x new file mode 100644 index 00000000..3c6a5e15 --- /dev/null +++ b/sys/osb/nmipak.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help nmi +.nf ___________________________________________________________________________ +NMI -- Machine independent integer format conversion routines. The NMI integer +format provides for three machine independent integer datatypes: + + NMI_BYTE 8 bit unsigned byte + NMI_SHORT 16 bit twos complement signed integer + NMI_LONG 32 bit twos complement signed integer + +plus, more recently, two IEEE floating point formats: + + NMI_REAL 32 bit IEEE floating point + NMI_DOUBLE 64 bit IEEE floating point + +The NMI datatypes are the same as are used in the FITS transportable image +format. In the case of the short and long integers, the most significant +bytes of an integer are given first. + +The routines in this package are provided for converting to and from the +NMI format and the SPP format. The latter format, of course, is potentially +quite machine dependent. The implementation given here assumes that the +SPP datatypes include 16 bit and 32 bit twos complement integers; the ordering +of the bytes within these integer formats is described by the machine +constants BYTE_SWAP2 and BYTE_SWAP4. Byte swapping for the IEEE floating +formats is defined by the machine constants IEEE_SWAP4 and IEEE_SWAP8. +.endhelp ______________________________________________________________________ + + +# NMIPAK -- Pack a SPP array of type spp_type into a NMI array of type +# nmi_type. The nmi_types are defined in nmi.h. + +procedure nmipak (spp, nmi, nelems, spp_datatype, nmi_datatype) + +int spp[ARB] #I input array of SPP integers +int nmi[ARB] #O output NMI format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code +int nmi_datatype #I NMI datatype code + +begin + switch (nmi_datatype) { + case NMI_BYTE: + call nmipak8 (spp, nmi, nelems, spp_datatype) + case NMI_SHORT: + call nmipak16 (spp, nmi, nelems, spp_datatype) + case NMI_LONG: + call nmipak32 (spp, nmi, nelems, spp_datatype) + case NMI_REAL: + call nmipakr (spp, nmi, nelems, spp_datatype) + case NMI_DOUBLE: + call nmipakd (spp, nmi, nelems, spp_datatype) + } +end diff --git a/sys/osb/nmipak16.x b/sys/osb/nmipak16.x new file mode 100644 index 00000000..eeae2a3d --- /dev/null +++ b/sys/osb/nmipak16.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# NMIPAK16 -- Pack an SPP array of the indicated datatype into an 16 bit +# signed NMI array. + +procedure nmipak16 (spp, nmi, nelems, spp_datatype) + +int spp[ARB] #I input array of SPP integers +int nmi[ARB] #O output NMI format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + switch (spp_datatype) { + case TY_UBYTE: + call achtbs (spp, nmi, nelems) + case TY_USHORT: + call achtus (spp, nmi, nelems) + case TY_CHAR: + call achtcs (spp, nmi, nelems) + case TY_SHORT: + call achtss (spp, nmi, nelems) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtis (spp, nmi, nelems) + case TY_LONG: + call achtls (spp, nmi, nelems) + case TY_REAL: + call achtrs (spp, nmi, nelems) + case TY_DOUBLE: + call achtds (spp, nmi, nelems) + case TY_COMPLEX: + call achtxs (spp, nmi, nelems) + } +end diff --git a/sys/osb/nmipak32.x b/sys/osb/nmipak32.x new file mode 100644 index 00000000..73abfd25 --- /dev/null +++ b/sys/osb/nmipak32.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# NMIPAK32 -- Pack an SPP array of the indicated datatype into an 32 bit +# signed NMI array. + +procedure nmipak32 (spp, nmi, nelems, spp_datatype) + +int spp[ARB] #I input array of SPP integers +int nmi[ARB] #O output NMI format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +int nmi_bytes +int spp_bytes +int sizeof() +pointer tmpp + +begin + call malloc (tmpp, nelems, TY_INT) + + nmi_bytes = 32 / NBITS_BYTE + spp_bytes = sizeof(spp_datatype) * SZB_CHAR + + switch (spp_datatype) { + case TY_UBYTE: + call achtbi (spp, Memi[tmpp], nelems) + case TY_USHORT: + call achtui (spp, Memi[tmpp], nelems) + case TY_CHAR: + call achtci (spp, Memi[tmpp], nelems) + case TY_SHORT: + call achtsi (spp, Memi[tmpp], nelems) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtii (spp, Memi[tmpp], nelems) + case TY_LONG: + call achtli (spp, Memi[tmpp], nelems) + case TY_REAL: + call achtri (spp, Memi[tmpp], nelems) + case TY_DOUBLE: + call achtdi (spp, Memi[tmpp], nelems) + case TY_COMPLEX: + call achtxi (spp, Memi[tmpp], nelems) + } + + if ( 2 * nmi_bytes == spp_bytes ) + call ipak32 (Memi[tmpp], nmi, nelems) + + call mfree (tmpp, TY_INT) +end diff --git a/sys/osb/nmipak8.x b/sys/osb/nmipak8.x new file mode 100644 index 00000000..6cf2720d --- /dev/null +++ b/sys/osb/nmipak8.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# NMIPAK8 -- Pack an SPP array of the indicated datatype into an 8 bit +# unsigned NMI array. + +procedure nmipak8 (spp, nmi, nelems, spp_datatype) + +int spp[ARB] #I input array of SPP integers +int nmi[ARB] #O output NMI format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + switch (spp_datatype) { + case TY_UBYTE: + call achtbb (spp, nmi, nelems) + case TY_USHORT: + call achtub (spp, nmi, nelems) + case TY_CHAR: + call achtcb (spp, nmi, nelems) + case TY_SHORT: + call achtsb (spp, nmi, nelems) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtib (spp, nmi, nelems) + case TY_LONG: + call achtlb (spp, nmi, nelems) + case TY_REAL: + call achtrb (spp, nmi, nelems) + case TY_DOUBLE: + call achtdb (spp, nmi, nelems) + case TY_COMPLEX: + call achtxb (spp, nmi, nelems) + } +end diff --git a/sys/osb/nmipakd.x b/sys/osb/nmipakd.x new file mode 100644 index 00000000..b1cb8ad3 --- /dev/null +++ b/sys/osb/nmipakd.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# NMIPAKD -- Pack an SPP array of the indicated datatype into an 64 bit +# IEEE floating format. + +procedure nmipakd (spp, nmi, nelems, spp_datatype) + +int spp[ARB] #I input array of SPP integers +double nmi[ARB] #O output NMI format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + if (spp_datatype == TY_DOUBLE) + call ieevpakd (spp, nmi, nelems) + else { + switch (spp_datatype) { + case TY_UBYTE: + call achtbd (spp, nmi, nelems) + case TY_USHORT: + call achtud (spp, nmi, nelems) + case TY_CHAR: + call achtcd (spp, nmi, nelems) + case TY_SHORT: + call achtsd (spp, nmi, nelems) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtid (spp, nmi, nelems) + case TY_LONG: + call achtld (spp, nmi, nelems) + case TY_REAL: + call achtrd (spp, nmi, nelems) + case TY_COMPLEX: + call achtxd (spp, nmi, nelems) + default: + call amovd (spp, nmi, nelems) + } + + call ieevpakd (nmi, nmi, nelems) + } +end diff --git a/sys/osb/nmipakr.x b/sys/osb/nmipakr.x new file mode 100644 index 00000000..ac710a2b --- /dev/null +++ b/sys/osb/nmipakr.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# NMIPAKR -- Pack an SPP array of the indicated datatype into an 32 bit +# IEEE floating format. + +procedure nmipakr (spp, nmi, nelems, spp_datatype) + +int spp[ARB] #I input array of SPP integers +real nmi[ARB] #O output NMI format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + if (spp_datatype == TY_REAL) + call ieevpakr (spp, nmi, nelems) + else { + switch (spp_datatype) { + case TY_UBYTE: + call achtbr (spp, nmi, nelems) + case TY_USHORT: + call achtur (spp, nmi, nelems) + case TY_CHAR: + call achtcr (spp, nmi, nelems) + case TY_SHORT: + call achtsr (spp, nmi, nelems) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtir (spp, nmi, nelems) + case TY_LONG: + call achtlr (spp, nmi, nelems) + case TY_DOUBLE: + call achtdr (spp, nmi, nelems) + case TY_COMPLEX: + call achtxr (spp, nmi, nelems) + default: + call amovr (spp, nmi, nelems) + } + + call ieevpakr (nmi, nmi, nelems) + } +end diff --git a/sys/osb/nmipksize.x b/sys/osb/nmipksize.x new file mode 100644 index 00000000..8ccd8297 --- /dev/null +++ b/sys/osb/nmipksize.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# NMIPKSIZE -- Determine the size in SPP chars of the array required to store +# nelems of type nmi_type in NMI packed form. The nmi_type codes are defined +# in nmi.h; we assume here that the integer codes are the sizes of the NMI +# types in bits. + +int procedure nmipksize (nelems, nmi_type) + +int nelems #I number of NMI elements of type nmi_type +int nmi_type #I type code (=8,16,32,-32,-64) + +begin + return ((nelems * abs(nmi_type) / NBITS_BYTE + SZB_CHAR-1) / SZB_CHAR) +end diff --git a/sys/osb/nmiupk.x b/sys/osb/nmiupk.x new file mode 100644 index 00000000..074f74bb --- /dev/null +++ b/sys/osb/nmiupk.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# NMIUPK -- Unpack a NMI array of type nmi_type into a SPP array of type +# spp_type. The nmi_types are defined in nmi.h. + +procedure nmiupk (nmi, spp, nelems, nmi_datatype, spp_datatype) + +int nmi[ARB] #I input NMI format array +int spp[ARB] #O output SPP format array +int nelems #I number of integers to be converted +int nmi_datatype #I NMI datatype code +int spp_datatype #I SPP datatype code + +begin + switch (nmi_datatype) { + case NMI_BYTE: + call nmiupk8 (nmi, spp, nelems, spp_datatype) + case NMI_SHORT: + call nmiupk16 (nmi, spp, nelems, spp_datatype) + case NMI_LONG: + call nmiupk32 (nmi, spp, nelems, spp_datatype) + case NMI_REAL: + call nmiupkr (nmi, spp, nelems, spp_datatype) + case NMI_DOUBLE: + call nmiupkd (nmi, spp, nelems, spp_datatype) + } +end diff --git a/sys/osb/nmiupk16.x b/sys/osb/nmiupk16.x new file mode 100644 index 00000000..abe20bee --- /dev/null +++ b/sys/osb/nmiupk16.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# NMIUPK16 -- Unpack a 16 bit signed NMI array into an SPP array of the +# indicated datatype. + +procedure nmiupk16 (nmi, spp, nelems, spp_datatype) + +int nmi[ARB] #I input NMI format array +int spp[ARB] #O output SPP format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + call achts (nmi, spp, nelems, spp_datatype) +end diff --git a/sys/osb/nmiupk32.x b/sys/osb/nmiupk32.x new file mode 100644 index 00000000..f42907fa --- /dev/null +++ b/sys/osb/nmiupk32.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# NMIUPK32 -- Unpack a 32 bit signed NMI array into an SPP array of the +# indicated datatype. + +procedure nmiupk32 (nmi, spp, nelems, spp_datatype) + +int nmi[ARB] #I input NMI format array +int spp[ARB] #O output SPP format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +int nmi_bytes +int spp_bytes +int sizeof() + +begin + nmi_bytes = 32 / NBITS_BYTE + spp_bytes = sizeof(spp_datatype) * SZB_CHAR + + # for 64bit integer + if ( 2 * nmi_bytes == spp_bytes ) + call iupk32 (nmi, spp, nelems) + + call achti (nmi, spp, nelems, spp_datatype) +end diff --git a/sys/osb/nmiupk8.x b/sys/osb/nmiupk8.x new file mode 100644 index 00000000..4c7f0e8e --- /dev/null +++ b/sys/osb/nmiupk8.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# NMIUPK8 -- Unpack an 8 bit unsigned NMI array into an SPP array of the +# indicated datatype. + +procedure nmiupk8 (nmi, spp, nelems, spp_datatype) + +int nmi[ARB] #I input NMI format array +int spp[ARB] #O output SPP format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + call achtb (nmi, spp, nelems, spp_datatype) +end diff --git a/sys/osb/nmiupkd.x b/sys/osb/nmiupkd.x new file mode 100644 index 00000000..35d16631 --- /dev/null +++ b/sys/osb/nmiupkd.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# NMIUPKD -- Unpack a 64 bit IEEE floating array into an SPP array of the +# indicated datatype. + +procedure nmiupkd (nmi, spp, nelems, spp_datatype) + +double nmi[ARB] #I input NMI format array +int spp[ARB] #O output SPP format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + call ieevupkd (nmi, spp, nelems) + if (spp_datatype != TY_DOUBLE) + call achtd (spp, spp, nelems, spp_datatype) +end diff --git a/sys/osb/nmiupkr.x b/sys/osb/nmiupkr.x new file mode 100644 index 00000000..474662f5 --- /dev/null +++ b/sys/osb/nmiupkr.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# NMIUPKR -- Unpack a 32 bit IEEE floating array into an SPP array of the +# indicated datatype. + +procedure nmiupkr (nmi, spp, nelems, spp_datatype) + +real nmi[ARB] #I input NMI format array +int spp[ARB] #O output SPP format array +int nelems #I number of integers to be converted +int spp_datatype #I SPP datatype code + +begin + call ieevupkr (nmi, spp, nelems) + if (spp_datatype != TY_REAL) + call achtr (spp, spp, nelems, spp_datatype) +end diff --git a/sys/osb/not.c b/sys/osb/not.c new file mode 100644 index 00000000..bbb2ed9e --- /dev/null +++ b/sys/osb/not.c @@ -0,0 +1,32 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* NOTI -- Bitwise boolean NOT of an integer variable. + */ +XINT +NOTI (XINT *a) +{ + return (~(*a)); +} + + +/* NOTS -- Bitwise boolean NOT of a short integer variable. + */ +XSHORT +NOTS (XSHORT *a) +{ + return (~(*a)); +} + + +/* NOTL -- Bitwise boolean NOT of a long integer variable. + */ +XLONG +NOTL (XLONG *a) +{ + return (~(*a)); +} diff --git a/sys/osb/or.c b/sys/osb/or.c new file mode 100644 index 00000000..88c8711c --- /dev/null +++ b/sys/osb/or.c @@ -0,0 +1,32 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* ORI -- Bitwise boolean OR of two integer variables. + */ +XINT +ORI (XINT *a, XINT *b) +{ + return (*a | *b); +} + + +/* ORS -- Bitwise boolean OR of two short integer variables. + */ +XSHORT +ORS (XSHORT *a, XSHORT *b) +{ + return (*a | *b); +} + + +/* ORL -- Bitwise boolean OR of two long integer variables. + */ +XLONG +ORL (XLONG *a, XLONG *b) +{ + return (*a | *b); +} diff --git a/sys/osb/r1mach.f b/sys/osb/r1mach.f new file mode 120000 index 00000000..c64a1953 --- /dev/null +++ b/sys/osb/r1mach.f @@ -0,0 +1 @@ +/iraf/iraf/unix/hlib/r1mach.f \ No newline at end of file diff --git a/sys/osb/shift.c b/sys/osb/shift.c new file mode 100644 index 00000000..86eacfb3 --- /dev/null +++ b/sys/osb/shift.c @@ -0,0 +1,49 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* + * SHIFT.C -- Bitwise shift operators. A positive bitshift shifts to the left, + * zero-filling at the right, i.e., a left shift by 1 is equivalent to a + * multiplication by 2 (but does not cause integer overflow). A negative shift + * shifts to the right and is equivalent to a division. + */ + +/* SHIFTI -- Bitwise boolean SHIFT of two integer variables. + */ +XINT +SHIFTI ( + XINT *a_a, /* operand to be shifted */ + XINT *a_bits /* number of bits to shift */ +) +{ + register XINT a = *a_a, bits = *a_bits; + return (bits > 0 ? (a << bits) : (a >> -bits)); +} + +/* SHIFTS -- Bitwise boolean SHIFT of two short-integer variables. + */ +XSHORT +SHIFTS ( + XSHORT *a_a, /* operand to be shifted */ + XSHORT *a_bits /* number of bits to shift */ +) +{ + register XSHORT a = *a_a, bits = *a_bits; + return (bits > 0 ? (a << bits) : (a >> -bits)); +} + +/* SHIFTL -- Bitwise boolean SHIFT of two long-integer variables. + */ +XLONG +SHIFTL ( + XLONG *a_a, /* operand to be shifted */ + XLONG *a_bits /* number of bits to shift */ +) +{ + register XLONG a = *a_a, bits = *a_bits; + return (bits > 0 ? (a << bits) : (a >> -bits)); +} diff --git a/sys/osb/strpak.c b/sys/osb/strpak.c new file mode 100644 index 00000000..4f88123d --- /dev/null +++ b/sys/osb/strpak.c @@ -0,0 +1,31 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* STRPAK -- Pack an SPP character string into a C string, i.e., a sequence + * of characters stored one per byte, delimited by EOS='\0'. The operation + * may be performed in place. This version assumes that the host character + * set is ASCII and hence no lookup table reference to map character sets is + * needed. If this is not the case, code must be added to convert to the host + * character set. + * + * N.B.: If sizeof(XCHAR)=1, XEOS=EOS, and the host character set is ASCII, + * and the operation is being performed in place, then this procedure should + * do nothing. + */ +STRPAK (instr, outstr, maxch) +XCHAR *instr; +PKCHAR *outstr; +XINT *maxch; +{ + register XCHAR *ip = instr; + register char *op = (char *)outstr; + register int n = *maxch; + + while ((*op++ = *ip++) != XEOS && --n >= 0) + ; + *--op = EOS; +} diff --git a/sys/osb/strpak.f b/sys/osb/strpak.f new file mode 100644 index 00000000..8c66f6f0 --- /dev/null +++ b/sys/osb/strpak.f @@ -0,0 +1,29 @@ +c STRPAK -- Pack an SPP character string into a C string, i.e., a sequence +c of characters stored one per byte, delimited by EOS='\0'. The operation +c may be performed in place. This version assumes that the host character +c set is ASCII and hence no lookup table reference to map character sets is +c needed. If this is not the case, code must be added to convert to the host +c character set. +c +c N.B.: If sizeof(XCHAR)=1, XEOS=EOS, and the host character set is ASCII, +c and the operation is being performed in place, then this procedure should +c do nothing. +c +c N.B.: This code ASSUMES that XCHAR is implemented as INTEGER*2 and that +c both XEOS and EOS are 0. + + subroutine strpak (instr, outstr, maxch) + + integer*2 instr(*), ch, EOS + character*1 outstr(*) + integer maxch + parameter (EOS=0) + integer i + + do 10 i = 1, maxch + ch = instr(i) + outstr(i) = char (ch) + if (ch .eq. EOS) return + 10 continue + outstr(maxch+1) = char (EOS) + end diff --git a/sys/osb/strsum.c b/sys/osb/strsum.c new file mode 100644 index 00000000..71655b3f --- /dev/null +++ b/sys/osb/strsum.c @@ -0,0 +1,100 @@ +#define import_spp +#define import_knames +#include + + +#ifdef INT32_SUM + +/** + * STRSUM -- Compute the 32-bit checksum of an SPP string. + */ + +int +STRSUM (XCHAR *array, XINT *length, XINT *maxch) +{ + int i, len, carry=0, newcarry=0; + unsigned int *iarray, sum = 0; + char pkstr[*maxch]; + + register int n = *maxch; + register XCHAR *ip = array; + register char *op = (char *) pkstr; + + + /* Convert the input string to a packed char array. + */ + while ((*op++ = *ip++) != XEOS && --n >= 0) + ; + *--op = EOS; + + /* Compute the checksum. + */ + iarray = (unsigned int *) pkstr; + len = *length / 4; + + for (i=0; i ~ sum) + carry++; + + sum += iarray[i]; + } + + while (carry) { + if (carry > ~ sum) + newcarry++; + sum += carry; + carry = newcarry; + newcarry = 0; + } + + return (sum); +} + +#else + +/** + * STRSUM -- Compute the 32-bit checksum of an SPP string. + */ + +int +STRSUM (XCHAR *array, XINT *length, XINT *maxch) +{ + int i, len, carry=0, newcarry=0; + unsigned int *iarray, sum = 0; + unsigned long lsum = 0; + char pkstr[*maxch]; + + register int n = *maxch; + register XCHAR *ip = array; + register char *op = (char *) pkstr; + + + /* Convert the input string to a packed char array. + */ + while ((*op++ = *ip++) != XEOS && --n >= 0) + ; + *--op = EOS; + + /* Compute the checksum. + */ + iarray = (unsigned int *) pkstr; + len = *length / 4; + + for (i=0; i ~ lsum) + carry++; + lsum += iarray[i]; + } + + while (carry) { + if (carry > ~ lsum) + newcarry++; + lsum += carry; + carry = newcarry; + newcarry = 0; + } + + return (abs(sum = lsum)); +} + +#endif diff --git a/sys/osb/strupk.c b/sys/osb/strupk.c new file mode 100644 index 00000000..97bd1bc1 --- /dev/null +++ b/sys/osb/strupk.c @@ -0,0 +1,39 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_knames +#include + +/* STRUPK -- Unpack a kernel (C style) string into an SPP string. The unpacking + * operation can be performed in place. A kernel string consists of a sequence + * of host characters stored one character per byte, delimited by EOS='\0'. + * We assume here that the host character set is ASCII. If this is not the + * case code must be added to convert from the host character set to ASCII in + * the unpacked string. + * + * N.B.: If sizeof(XCHAR)=1, XEOS=EOS, and the host character set is ASCII, + * and the operation is being performed in place, then this procedure should + * do nothing. + */ +STRUPK (instr, outstr, maxch) +PKCHAR *instr; +XCHAR *outstr; +XINT *maxch; +{ + register char *ip = (char *)instr; + register XCHAR *op = outstr; + register int n; + + /* Is is necessary to determine the length of the string in order to + * be able to unpack the string in place, i.e., from right to left. + */ + for (n=0; *ip++; n++) + ; + n = (n < *maxch) ? n : *maxch; + op[n] = XEOS; + + for (ip = (char *)instr; --n >= 0; ) + op[n] = ip[n]; + op[*maxch] = XEOS; +} diff --git a/sys/osb/strupk.f b/sys/osb/strupk.f new file mode 100644 index 00000000..1123e2ac --- /dev/null +++ b/sys/osb/strupk.f @@ -0,0 +1,39 @@ +c STRUPK -- Unpack a kernel (C style) string into an SPP string. The unpacking +c operation can be performed in place. A kernel string consists of a sequence +c of host characters stored one character per byte, delimited by EOS='\0'. +c We assume here that the host character set is ASCII. If this is not the +c case code must be added to convert from the host character set to ASCII in +c the unpacked string. +c +c N.B.: If sizeof(XCHAR)=1, XEOS=EOS, and the host character set is ASCII, +c and the operation is being performed in place, then this procedure should +c do nothing. +c +c N.B.: This code ASSUMES that XCHAR is implemented as INTEGER*2 and that +c both XEOS and EOS are 0. + + subroutine strupk (instr, outstr, maxch) + + character*1 instr(*) + integer*2 outstr(*) + integer maxch, EOS + parameter (EOS=0) + integer i + + +c Determine length of string so that we can unpack it in the reverse +c direction. + i = 1 + 10 continue + if (ichar (instr(i)) .eq. EOS .or. i .gt. maxch) goto 20 + i = i + 1 + goto 10 + 20 continue + +c Unpack the string from right to left. +c + outstr(i) = EOS + do 30 i=i, 1, -1 + outstr(i) = ichar (instr(i)) + 30 continue + end diff --git a/sys/osb/urand.x b/sys/osb/urand.x new file mode 100644 index 00000000..84e1fc67 --- /dev/null +++ b/sys/osb/urand.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# URAND -- Universal Random Number Generator. From "Computer Methods for +# Mathematical Computations", by Forsythe, Malcolm, and Moler, 1977. +# Urand is a uniform random number generator based on theory and suggestions +# given in D.E. Knuth (1969), Vol 2. Values of URAND will be returned in the +# interval (0,1). Random numbers are generated by the recursion relation +# (r' = r * a + c) where the art lies in choosing the values for A and C. +# +# [MACHDEP] - NOTE - This routine will not work on machines that do not permit +# integer overflow during multiplication. In such a case a machine dependent +# routine should be provided in host$as. + +real procedure urand (lseed) + +long lseed # seed value on first call +long n, a, c, m, mic + +real scale +data m /0/ + +int imul32() + +begin + # When first called, compute multiplier, increment, and miscellaneous + # constants. + + if (m == 0) { + m = MAX_LONG / 2 + 1 + a = 8 * int (m * atan (1.d0 / 8.d0)) + 5 + c = 2 * int (m * (0.5d0 - sqrt (3.d0) / 6.d0)) + 1 + mic = (m - c) + m + scale = 0.5 / m + lseed = max (1, lseed) + } + + # Compute next random number, taking care not to cause an arithmetic + # exception. + + n = imul32 (lseed, a) # [MACHDEP] - integer overflow + if (n > mic) + n = (n - m) - m + n = n + c + + if (n / 2 > m) + n = (n - m) - m + + if (n < 0) + n = (n + m) + m + + lseed = n + return (n * scale) +end diff --git a/sys/osb/xor.x b/sys/osb/xor.x new file mode 100644 index 00000000..3ba0dd85 --- /dev/null +++ b/sys/osb/xor.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# XORI -- Boolean exclusive or of two integer operands. + +int procedure xori (a, b) + +int a, b +int not(), and(), or() + +begin + return (or (and(a,not(b)), and(not(a),b))) +end + + +# XORS -- Boolean exclusive or of two short integer operands. + +short procedure xors (a, b) + +short a, b +short nots(), ands(), ors() + +begin + return (ors (ands(a,nots(b)), ands(nots(a),b))) +end + + +# XORL -- Boolean exclusive or of two long integer operands. + +long procedure xorl (a, b) + +long a, b +long notl(), andl(), orl() + +begin + return (orl (andl(a,notl(b)), andl(notl(a),b))) +end diff --git a/sys/osb/zzdebug.x b/sys/osb/zzdebug.x new file mode 100644 index 00000000..f15f3fd4 --- /dev/null +++ b/sys/osb/zzdebug.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +task sbit, tbit + +define NWORDS 1 # limited to 1 longword at present + + +# SBIT, TBIT -- Test the bitpak and bitupk primitives. + +procedure sbit() + +int b[NWORDS] +int offset, nbits, value, i +int bitupk(), clgeti() + +begin + offset = clgeti ("offset") + nbits = clgeti ("nbits") + value = clgeti ("value") + + if (offset < 1 || offset > NWORDS * NBITS_INT) + call error (1, "bit offset out of range") + + call bitpak (value, b, offset, nbits) + + call printf ("\n") + call printf ("\t21098765432109876543210987654321\n") + call printf ("\t 3 2 1 0\n") + do i = 1, NWORDS { + call printf ("%4d\t%032r2 (%011oB)\n") + call pargi ((i-1) * 32 + 1) + call pargi (b[i]) + call pargi (b[i]) + } + return + +entry tbit() + offset = clgeti ("offset") + nbits = clgeti ("nbits") + + call printf ("bitfield=%d\n") + call pargi (bitupk (b, offset, nbits)) +end diff --git a/sys/osb/zzeps.f b/sys/osb/zzeps.f new file mode 100644 index 00000000..680af1b0 --- /dev/null +++ b/sys/osb/zzeps.f @@ -0,0 +1,114 @@ + +c------------------------------------------------------------------------- +c Compute machine epsilon, i.e, the smallest real or double precision +c number EPS such that (1.0 + EPS > 1.0). This calculation is tricky +c because of the optimizations performed by some compilers, and because +c a comparison performed in registers may be done to a higher precision +c than one involving variables. This program contains some minor +c violations of the F78 standard. +c------------------------------------------------------------------------- + + + program epsilo + + real seps + double precision deps + + write (*,*) 'Calculate Machine Epsilon ------' + call cseps (seps) + call cdeps (deps) + write (*,*) ' single precision epsilon: ', seps + write (*,*) ' double precision epsilon: ', deps + + write (*,*) ' ' + write (*,*) 'Verify Values -----' + + write (*, '('' enter s.p. epsilon: '',$)') + read (*,*) seps + if (1.0 + seps .gt. 1.0) then + write (*,*) ' ok' + else + write (*,*) ' not ok' + endif + + write (*, '('' enter d.p. epsilon: '',$)') + read (*,*) deps + if (1.0 + deps .gt. 1.0) then + write (*,*) ' ok' + else + write (*,*) ' not ok' + endif + + stop + end + + +c -- Compute the single precision epsilon. + + subroutine cseps (seps) + + real seps + real sval + double precision dval + logical sgt + common /eps/ sval, dval + save /eps/ + + sval = 1.0 + 10 seps = sval + sval = sval / 2.0 + if (sgt (1.0)) then + goto 10 + endif + end + + + +c -- Is SVAL + 1.0 greater than 1.0? + + logical function sgt (value) + + real value, sval, stemp + double precision dval + common /eps/ sval, dval + save /eps/ + + stemp = sval + 1.0 + sgt = (stemp .gt. value) + end + + + +c -- Compute the double precision epsilon. + + subroutine cdeps (deps) + + double precision deps + double precision dval + real sval + logical dgt + common /eps/ sval, dval + save /eps/ + + dval = 1.0d0 + 10 deps = dval + dval = dval / 2.0d0 + if (dgt (1.0d0)) then + goto 10 + endif + end + + +c -- Is DVAL + 1.0 greater than 1.0? + + logical function dgt (value) + + double precision value + double precision dval, dtemp + real sval + common /eps/ sval, dval + save /eps/ + + dtemp = dval + 1.0d0 + dgt = (dtemp .gt. value) + end diff --git a/sys/osb/zzeps2.f b/sys/osb/zzeps2.f new file mode 100644 index 00000000..d52ffe20 --- /dev/null +++ b/sys/osb/zzeps2.f @@ -0,0 +1,110 @@ +c------------------------------------------------------------------------- +c ZZEPS2.F -- Alternate version of ZZEPS. This version may avoid problems +c seen on some systems of excess precision causing an artificially large +c value of the single precision epsilon to be computed, due to the epsilon +c value being computed in registers. Use whichever version produces the +c smaller epsilon. +c +c Compute machine epsilon, i.e, the smallest real or double precision +c number EPS such that (1.0 + EPS > 1.0). This calculation is tricky +c because of the optimizations performed by some compilers, and because +c a comparison performed in registers may be done to a higher precision +c than one involving variables. This program contains some minor +c violations of the F78 standard. +c------------------------------------------------------------------------- + + + program epsilo + + real seps + double precision deps + + write (*,*) 'Calculate Machine Epsilon ------' + call cseps (seps) + call cdeps (deps) + write (*,*) ' single precision epsilon: ', seps + write (*,*) ' double precision epsilon: ', deps + + write (*,*) ' ' + write (*,*) 'Verify Values -----' + + write (*, '('' enter s.p. epsilon: '',$)') + read (*,*) seps + if (1.0 + seps .gt. 1.0) then + write (*,*) ' ok' + else + write (*,*) ' not ok' + endif + + write (*, '('' enter d.p. epsilon: '',$)') + read (*,*) deps + if (1.0 + deps .gt. 1.0) then + write (*,*) ' ok' + else + write (*,*) ' not ok' + endif + + stop + end + + +c -- Compute the single precision epsilon. + + subroutine cseps (seps) + + real seps + real sval + double precision dval + logical sgt + common /eps/ sval, dval + save /eps/ + + sval = 1.0 + 10 seps = sval + sval = sval / 2.0 + if (sgt (sval + 1.0, 1.0)) then + goto 10 + endif + end + + + +c -- Is SVAL + 1.0 greater than 1.0? + + logical function sgt (value, ref) + + real value, ref + + sgt = (value .gt. ref) + end + + + +c -- Compute the double precision epsilon. + + subroutine cdeps (deps) + + double precision deps + double precision dval + real sval + logical dgt + common /eps/ sval, dval + save /eps/ + + dval = 1.0d0 + 10 deps = dval + dval = dval / 2.0d0 + if (dgt (dval + 1.0d0, 1.0d0)) then + goto 10 + endif + end + + +c -- Is DVAL + 1.0 greater than 1.0? + + logical function dgt (value, ref) + + double precision value, ref + + dgt = (value .gt. ref) + end diff --git a/sys/plio/PLIO.hlp b/sys/plio/PLIO.hlp new file mode 100644 index 00000000..16e23dfc --- /dev/null +++ b/sys/plio/PLIO.hlp @@ -0,0 +1,1341 @@ +.help PLIO Feb88 "Pixel List Package Design" +.ce +\fBThe IRAF Pixel List Package\fR +.ce +and +.ce +\fBIMIO Extensions to Support Image Masks\fR +.ce +Doug Tody +.ce +February, 1988 +.ce +(Revised June 1988) + + +.NH +Introduction + + The pixel list package is a general package for flagging individual pixels +or regions of an image, to mark some subset of the pixels in an image. +This may be done to flag bad pixels, or to identify those regions of an image +to be processed by some applications program. When the pixel list package is +used to flag the bad pixels in an image we call this a \fBbad pixel mask\fR, +or BPM. When used to identify the regions of an image to be processed (or +ignored), we call the list a \fBregion mask\fR. + +A pixel list may be viewed conceptually as either a list or an image; the list +is merely the compressed form of a virtual \fBmask image\fR. Storing a mask +image as a list has two major advantages. +.ls +.ls [1] +Storage efficiency. Simple masks may be stored very compactly, e.g., as small +arrays stored directly in an image header, or in a separate mask file or +database. +.le +.ls [2] +Runtime efficiency. Storing a mask in list form has the advantage that one +can determine very quickly whether or not a given region of the image (e.g., +an image line) contains any pixels in the mask. The alternative, given a +fully populated mask image (or flagging the pixels directly in the data image), +requires that one examine every pixel in the mask image, which is very +inefficient for simple masks. +.le +.le + +The pixel list technique for implementing image masks is the most efficient +choice only for simple or moderately complex masks. As a mask image increases +in complexity there eventually comes a point where it would be simpler and +more efficient to use a conventional raster image to store the mask. +For example, if one wishes to associate a flag value (such as a weight) with +every pixel in an image, and the flag values vary rapidly in value across the +image, a separate image should probably be used (except that other forms of +data compression may be possible; the IRAF \fInoise function package\fR +addresses one aspect of this problem). + +The pixel list related software is subdivided into two parts, the pixel list +package itself, and the extensions to IMIO to make use of the pixel list +package. The pixel list package in itself is independent of IMIO and may be +used separately. + +.NH +IMIO Support for Pixel Lists + + Most image applications tend to fall into two classes, the simple pointwise +transformation operators, and the more cpu intensive image analysis operations. +The simple operators usually operate upon the whole image (no mask required) +and may ignore the presence of bad pixels in the image, provided reasonable +artificial values have been provided for the bad pixels so that arithmetic +problems do not occur, and provided we keep track of the locations of the +bad pixels (by propagating the bad pixel lists), so that the bad pixel +information is available to subsequent image analysis programs. + +The image analysis operators, on the other hand, must know the locations of +the bad pixels in order to exclude them from the fit. The analysis is also +often performed only upon specified regions of the image, as indicated by some +sort of image mask. Most image analysis algorithms are fairly cpu intensive, +hence as long as we can access the bad pixel list and region mask reasonably +efficiently, we would prefer a simple interface, e.g., for every buffer of +input image data read, an associated buffer the same size and dimensionality +as the input image data buffer, containing the bad pixel or region mask flag +values. + +In general, if pixel lists are to be used with images, either IMIO must +provide direct support for pixel lists or the pixel list package must duplicate +much of the functionality of IMIO. This is because the pixel list must +be defined in terms of the physical image, whereas an applications +program accessing an image via IMIO may be operating upon some user specified +section of the image. To support applications transparent sectioning, boundary +extension, multiple input buffers, and so on, support for pixel lists must +be integrated into IMIO. + +.NH 2 +Mask Images + + These considerations lead us to make it possible for a pixel list to appear +to an application as a special type of image called a \fImask image\fR, even +though the mask may be stored as a pixel list internally, and accessed or +queried directly as a list if desired. If whenever we read a block of data +from the data image, we read an equivalent block of data from the mask image, +it is evident that whatever we come up with for reading from the mask image is +going to have to look an awful lot like IMIO. Given the complexities of image +section transformations, automatic buffer allocation strategies, and so on, +the simplest solution is to just go ahead and use IMIO to access the virtual +mask image. This leads us to the interface shown in the figure below. +These routines represent an extension to IMIO to support pixel lists. The +conventional IMIO routines, used to access the mask "pixels", are not shown. + +The mask image may be opened by name with \fIim_pmmap\fR, or an already opened +pixel mask, perhaps the result of some computation done by the applications +program, may be opened with \fIim_pmmapo\fR. Alternatively, if the mask is +stored (or will be stored in the case of a new mask) in a pixel list file +(".pl" extension), the mask may be opened with a conventional \fIimmap\fR call. +This last option is especially powerful, since it allows all image tasks to +access masks as if they were conventional images, e.g., one can DISPLAY or +IMCOPY a stored mask. + +.ks +.nf + im = im_pmmap (maskname, mode, ref_im|NULL) + im = im_pmmapo (pm, ref_im) + + imseti (im, IM_RLIO, YES|NO) + imseti (im, IM_PMDES, pm) + pm = imstati (im, IM_PMDES) + + bool = im_pmlne[123] (im[, lineno[, bandno]]) + bool = im_pmsne[123] (im, x1, x2[, y1, y2[, z1, z2]]) + bool = im_pmlnev (im, v) + bool = im_pmsnev (im, vs, ve, ndim) +.fi +.ke + +The \fImode\fR argument to \fIim_pmmap\fR specifies both the access mode for +the mask, and any standard transformations to be performed upon the mask before +i/o takes place (if an existing mask is to be read). NEW_FILE mode is used to +create a new mask; READ_ONLY to read an existing mask, and READ_WRITE to modify +an existing mask. The mode-transformation flags currently supported are +INVERT_MASK, which performs a PIX_NOT operation on the input mask, and +BOOLEAN_MASK, which converts an integer input mask to boolean. Any more +complex mask transformations or combinations must be performed explicitly +by the calling program via calls to the PMIO or PLIO routines, mapping the +resultant mask onto an image descriptor with \fIim_pmmapo\fR. + +If a reference image \fIref_im\fR is specified at open time, +then the mask image will inherit any image section, boundary extension, etc. +in effect for the reference image. Inheritance occurs when the first i/o +to the mask image takes place. The reserved names "BPM" and "EMPTY", +respectively (must be upper case), denote the bad pixel mask +for the reference image, or an empty mask the size of the reference image. +If the reference image does not have a bad pixel mask, BPM and EMPTY are +equivalent. Note that separate image descriptors are used for the data +(reference) image and any mask images. Multiple mask images may be associated +with the same reference image. + +Normal IMIO calls, e.g., \fIimgs2i\fR, are used to access the mask "pixels". +Since it is common for a mask to be empty over large regions of an image, +a set of boolean functions are provided for testing whether regions of the +mask are nonempty, allowing a program to avoid the expense of image mask i/o +and subseqent testing of the mask pixel values if not needed. +The boolean functions \fIim_pmlne\fR (line not empty) and \fIim_pmsne\fR +(section not empty) and their more general variants \fIim_pmlnev\fR and +\fIim_pmsnev\fR test whether the specified region of the mask image contains +any nonzero mask pixels. The calling sequences of these routines are patterned +after the corresponding IMIO pixel i/o routines, e.g., \fIim_pmlne2\fR is +intended for use with the \fIimgl2\fR routines, and \fIim_pmlnev\fR is +intended for use with the \fIimgnl\fR routines. + +By default, mask image i/o operates on data buffers containing arrays of +pixels, as for a conventional data image. When i/o takes place, the interface +automatically converts between pixel format and the compressed line list format +in which the mask is stored internally. An alternative format for the mask +data is \fBrange list\fR format, enabled by setting the \fIIM_RLIO\fR parameter +to YES in an \fIimseti\fR call. Range list i/o works identically to pixel i/o, +except that the "pixel arrays" returned by IMIO (or input to IMIO) are range +list structures, as defined in \fB\fR and discussed in section 3.3.4. + +Range list i/o at the IMIO level is fully general, i.e., the section +transformation, if any, is applied transparently to the calling program, +and the full range of IMIO i/o routines may be used. +If the data buffer is a multidimensional subraster, each line of the subraster +will be a separate range list, and the physical length in pixels of each line +of the subraster will be as for a pixel subraster. +On a read, if the length of the encoded range list exceeds the subraster +line length in pixels, and i/o error will occur. Such an i/o error cannot +occur when i/o is restricted to lines or line segments (1D buffers), +since IMIO will automatically allocate a data buffer large enough to hold +the worst case (longest) range list. Range list overflow errors are +unlikely even for subrasters, however, since the range list format is +normally much more compact than the equivalent pixel array (except for +very small subrasters or very complex masks). + +.NH 2 +Masked Image I/O (MIO) + + The mask image i/o routines discussed in the previous section provide a +fully generalized means for directly accessing a mask as an separate entity, +independent of the associated reference data image. Two separate image +descriptors are required, and two parallel but separate sets of calls to the +IMIO routines. In many applications, however, a mask is used only to specify +those regions of the data image to be analyzed or processed. We want to +access those regions of the image visible through the mask, but are not +otherwise interested in the mask itself. The \fBmasked image i/o\fR (MIO) +interface is designed for such applications. + +The MIO interface is summarized in the figure below. A named mask may be +opened on a previously opened image with the \fImio_open\fR procedure. +As for \fIim_pmopen\fR, the reserved names "BPM" and "EMPTY", respectively, +denote the bad pixel mask for the image, or an empty mask the size of the +image. If the image does not have a bad pixel mask, an empty mask will be +opened. + +The \fIflags\fR argument, if nonzero, specifies an operation be performed +upon the input mask to generate the mask to be used to access the data image. +The currently supported flags are INVERT_MASK and BOOLEAN_MASK. For example, +when the mask is a bad pixel mask, INVERT_MASK would cause MIO to access only +that portion of the image which is \fInot\fR covered by the bad pixel mask, +i.e., the "good" region of the image. BOOLEAN_MASK is used to convert an +integer mask into a boolean mask. Note that in the case of inversion of an +integer mask, the PIX_NOT operation merely complements the mask pixel values, +hence will not affect the \fIregion\fR covered by the mask. To invert an +integer mask in the region sense, use INVERT_MASK+BOOLEAN_MASK. + +.ks +.nf + mp = mio_open (maskname, flags, im) + mp = mio_openo (pm, im) + value = mio_stati (mp, param) + mio_seti (mp, param, value) + mio_setrange (mp, vs, ve, ndim) + n|EOF = mio_[gp]lseg[silrdx] (mp, ptr, mval, v, npix) + mio_close (mp) +.fi +.ke + +More general mask transformations must be carried out by the user using the +PMIO package to directly compute the desired mask, the mapping the mask onto +an image descriptor with \fImio_openo\fR. For example, given as input a bad +pixel mask and a region mask, one could compute the mask specifying all pixels +in the region mask but not in the bad pixel mask. Any general mask may be +computed in this way. + +An MIO application will not normally need to access the mask directly, but +if such access is required the mask descriptor may be obtained with a call +to \fImio_stati\fR to fetch the value of the parameter \fIP_PMDES\fR. +Similarly, the image descriptor may be queried as parameter \fIP_IMDES\fR, +and either parameter may be set with the corresponding call to \fImio_seti\fR. + +Successive calls to a get or put line segment procedure, e.g., +\fImio_glsegr\fR (get line segment real), return line segments from the data +image until all the data present in the area outlined by the mask has been +accessed, at which time EOF is returned as the function value. +Each line segment is returned along with a vector \fIv\fR specifying the +line of the image from which the segment is taken and the index of the first +pixel of the current line segment within the line, a count \fInpix\fR of the +number of pixels in the line segment, and the mask value \fImval\fR for the +current line segment (e.g., 1 for a boolean mask). Each line segment +corresponds to a region of constant nonzero value (\fImval\fR) in the mask. +Line segments are returned sequentially in storage order. + +By default, the entire region of the image visible through the mask will be +accessed. To access only a portion of the image, the \fIimio_setrange\fR +procedure may be called before performing any i/o to specify the starting and +ending vector coordinates \fIvs\fR and \fIve\fR of the region to be accessed. +Multiple calls may be made on the same MIO descriptor to access multiple +regions of the data image, or to "rewind" a given region of the image. + +.NH 2 +Mask Image Storage + + As we shall see in the discussion of the pixel list package, the pixel +list package is designed to permit a list to be stored anywhere, e.g., +in a binary file, in a database, as an array in an image header, +or merely as a temporary array in memory. When the new image structures +become available storing the masks in the image header or in a global database +will probably be the best approach, but in the meantime the simplest solution +is to store each pixel list or mask in a small binary file. This approach has +the advantage of being independent of the particular image format used (none +of which are currently capable of storing the pixel list directly in any case). + +If desired, the name of the mask file may be stored in the image header +as a simple string valued parameter. Alternatively, the mask name may be +input as a parameter when a task is run. A single mask may be associated +with several images, or several masks may be used with the same image. +The approach to be followed for a particular program is up to the programmer +or package designer. + +The bad pixel mask is a special case, since it has a well defined logical +meaning for an image, unlike the region masks which are application specific. +The most straightforward approach is to use a single boolean mask for the +bad pixel list, using the optional header keyword \fIBPM\fR to store the +mask name, which should normally be the image name plus the pixel list file +extension "\fI.pl\fR". An integer BPM could also be used, but most applications +would treat it as a boolean mask, treating any pixel with a nonzero value as +a bad pixel. + +Any additional information required to describe the bad pixels is application +specific, and may be stored in any of several ways, e.g., as a set of boolean +masks, in an integer mask, using flag bits or reserved values to describe each +pixel or region, in a separate fully populated weight image, or using the noise +function package. Most IRAF applications will probably use the BPM plus a +noise function, with the noise function being stored either as +a one-dimensional noise model or as a separate uncertainty image, transparently +to the application. The combination of a one-dimensional noise model plus a +compressed bad pixel list should provide an efficient and flexible solution +to the pixel variance problem for most applications. + +.NH 2 +Example + + Open a data image and the associated mask image, and sum the pixels within +the area indicated by the mask. + +.nf + include + + task sum = t_sum +.fi + +.tp 6 +.nf + # SUM -- Sum the image pixels lying within the given mask. + + procedure t_sum() + + char image[SZ_FNAME] # input data image + char mask[SZ_FNAME] # image mask + + int npix, mval, totpix, m_flags + long v[PM_MAXDIM] + pointer im, mp, pp + real sum + + bool clgetb() + real asumr() + int mio_glsegr() + pointer immap(), mio_open() + + begin + call clgstr ("image", image, SZ_FNAME) + call clgstr ("mask", mask, SZ_FNAME) + m_flags = 0 + if (clgetb ("invert")) + m_flags = INVERT_MASK + + im = immap (image, READ_ONLY, 0) + mp = mio_open (mask, m_flags, im) + + sum = 0; totpix = 0 + while (mio_glsegr (mp, pp, mval, v, npix) != EOF) { + sum = sum + asumr (Memr[pp], npix) + totpix = totpix + npix + } + + call mio_close (mp) + call imunmap (im) + + call printf ("%d pixels, sum=%g, mean=%g\n") + call pargi (totpix) + call pargr (sum) + if (totpix > 0) + call pargr (sum / totpix) + else + call pargr (INDEF) + end +.fi + +A more complex application might use the spatial information provided by +\fIv\fR and \fInpix\fR, or the flag values provided by \fImval\fR (for an +integer mask). For example, a surface fitting routine would accumulate each +line segment into a least squares matrix, using the coordinate information +provided as well as the pixel values. + +.NH 2 +The Pixel Mask Package (PMIO) + + We have thus far discussed two quite different interfaces, i.e., the use +of IMIO to do pixel i/o to a mask mapped as a virtual mask image, and the MIO +interface, used to access the portion of a data image visible through a mask. +The next step is to define the interface used to access the mask object +directly as a \fImask\fR, independently of the use of masks for image i/o. + +.nf + pm = pm_newmask (ref_im, depth) + + pm = pm_open (bufptr|NULL) + pm = pm_create (naxes, axlen, depth) + pm = pm_newcopy (pm) + pm_close (pm) + + pm_[sg]size (pm, naxes, alxen, depth) + pm_seti (pm, param, value) + value = pm_stati (pm, param) + pm_debug (pm, outfd, maxcol, flags) + bool = pm_empty (pm) + pm_compress (pm) + pm_clear (pm) + + pm_load (pm, bufptr) + nwords = pm_save (pm, bufptr, buflen) + pm_loadf (pm, fname, title, maxch) + pm_savef (pm, fname, title, save_flags) + pm_[load|save]im (pm, imname[, save_flags]) + + ptr = pm_access (pm, v) + bool = pm_linenotempty (pm, v) + bool = pm_sectnotempty (pm, vs, ve, ndim) + pm[gp]l[lrp][sil] (pm, v, buf, b_depth, npix, rop) + + pm_[set|get]plane (pm, v) + pm_point (pm, x, y, rop) + pm_circle (pm, x, y, r, rop) + pm_box (pm, x1,y1, x2,y2, rop) + pm_line (pm, x1,y1, x2,y2, width, rop) + pm_polygon (pm, x, y, npts, rop) + + pm_rop (pm_src, vs, pm_dst, vs, vn, rop) + pm_stencil (pm_src, vs, pm_dst, vs, pm_stl, vs, vn, rop) +.fi + +There are two variants on this lowest level interface, known as PMIO (pixel +mask i/o) and PLIO (pixel list i/o). These two interfaces are equivalent +with one difference: PMIO can accept a reference image and inherit the section +transformation of the reference image, allowing the mask to be accessed in +the coordinate system of the reference image, while PLIO is a stand alone +interface, implemented independently of IMIO without any ties to IMIO. +PMIO is implemented as a thin layer upon PLIO, with ties to IMIO to access +the section transformation for the reference image. + +The PMIO interface is shown in the figure above. +With the exception of the additional routine \fIpm_newmask\fR, used to create +a new, empty mask the same size as a reference image, the PMIO routines are +identical to the corresponding PLIO routines except for the \fIpm\fR package +prefix, and the implied section transformation. Indeed, if no reference image +is specified or if the section transformation is unitary (the reference image +was opened without an image section), the two interfaces are identical. +Hence the discussion of PLIO in the next section will serve to document PMIO +as well. + +To use PMIO, merely include \fB\fR rather than \fI\fR, +and set the reference image with a call to \fIpm_seti\fR, e.g., + + call pm_seti (pm, P_REFIM, ref_im) + +This step can be skipped if \fIpm_newmask\fR or \fIpm_newcopy\fR is used to +create a new mask, as the reference image will be inherited by the new mask. + +Programs which use PMIO to access a mask may also use the low level line, +range, and pixel list routines discussed in section 3.1 (\fBpl_rangerop\fR etc.) +on lists returned by PMIO, since PMIO will have already transformed the data +into the coordinate system of the reference image. + +In general, the PMIO interface should be used in preference to PLIO whenever +the mask to be accessed is logically associated with some data image or images. +The region description and logical region processing capabilities of PLIO are +very powerful in their own right, however, and PLIO should be used directly by +applications which do not consider the mask to be merely an overlay for a data +image. An example would be any application which operates upon a 2-dimensional +data structure other than an image (e.g., region filtering in the POE image +kernel). + +.NH +The Pixel List Package (PLIO) + + A pixel list is a way of representing an N-dimensional image matrix which +is well suited for applications where the represented image is sparse, or +consists of a moderate number of arbitrarily shaped regions. Routines are +provided for creating new lists, for writing to or reading from lists, +for storing or retrieving lists, and for performing various types of +operations upon entire lists to make new lists. The full set of routines +in the package are summarized in the figure below. + +A pixel list, like an image, has a fixed dimensionality and size which is +determined at list creation time for the lifetime of the list. New lists +are created with \fIpl_create\fR, which returns a pointer to an empty list. +The \fIdepth\fR parameter specifies the depth of the list in bits, i.e., +the number of bits per pixel, in the range 1-27. A boolean list has a depth +of 1 bit. In the current implementation the boolean mask is handled as a +degenerate case of an integer mask, i.e., an integer mask which happens to +have mask values in the range 0-1. + +An existing list is accessed by opening a descriptor with \fIpl_open\fR and +loading the list into the runtime descriptor structure, either by specifying +a non-NULL buffer pointer \fIbufptr\fR, or by calling one of the \fIpl_load\fR +functions after opening a null descriptor. + +.ks +.nf + pl = pl_open (bufptr|NULL) + pl = pl_create (naxes, axlen, depth) + pl = pl_newcopy (pl) + pl_close (pl) + + pl_[sg]size (pl, naxes, axlen, depth) + pl_seti (pl, param, value) + value = pl_stati (pl, param) + pl_debug (pl, outfd, maxcol, flags) + bool = pl_empty (pl) + pl_compress (pl) + pl_clear (pl) + + pl_load (pl, bufptr) + nwords = pl_save (pl, bufptr, buflen) + pl_loadf (pl, fname, title, maxch) + pl_savef (pl, fname, title, save_flags) + pl_[load|save]im (pl, imname[, save_flags]) + + ptr = pl_access (pl, v) + bool = pl_linenotempty (pl, v) + bool = pl_sectnotempty (pl, vs, ve, ndim) + pl[gp]l[lrp][sil] (pl, v, buf, b_depth, npix, rop) + + pl_[set|get]plane (pl, v) + pl_point (pl, x, y, rop) + pl_circle (pl, x, y, r, rop) + pl_box (pl, x1,y1, x2,y2, rop) + pl_line (pl, x1,y1, x2,y2, width, rop) + pl_polygon (pl, x, y, npts, rop) + + pl_rop (pl_src, vs, pl_dst, vs, vn, rop) + pl_stencil (pl_src, vs, pl_dst, vs, pl_stl, vs, vn, rop) +.fi +.ke + +Pixel lists are stored externally as opaque binary byte arrays. +The function \fIpl_save\fR will encode a pixel list as a byte array and store +it in the indicated buffer, resizing the buffer if necessary. +If \fIbufptr\fR is NULL a new buffer will be allocated, overwriting the NULL. +The \fIpl_load\fR function performs the inverse function. +The \fIf\fR suffixed functions are provided for convenience when storing +lists in small binary files. The \fIim\fR suffixed functions create masks +out of actual data images, and vice versa. In the most general case, a list +is encoded into an array in memory and then stored away by the applications +wherever they wish, e.g., as an array parameter in an image header when the +new image structures become available. + +Pixel list i/o is provided via the \fIpl[gp]l[lrp][sil]\fR family of functions, +which read, write, or edit (via the \fIrop\fR) lines or line segments of masks. +The naming convention is as follows: + +.ks +.nf + pl package prefix + [gp] get or put + l line segment + [lrp] as a line list, range list, or pixel array + [sil] in an array of type short, int, or long +.fi +.ke + +For example, \fIplglps\fR would get a line from a mask image as a fully +populated array of type short. For maximum efficiency, since this is a low +level interface, the data is read from or copied into a user allocated buffer, +rather than having the pixel list package control the buffer. + +The functions \fIplgll[sil]\fR return the packed line list for the indicated +line or line segment. This is the copy-out form of access with the least +overhead, but requires that the application have knowledge of the internal +line list format. + +Alternatively, if it is only desired to read from a list, accessing the list +in the internal format, the internal list for an image line may be directly +accessed by pointer with the \fIpl_access\fR function. This is the most +efficient form of access. The variant \fIpl_linenotempty\fR is similar except +that the NULL pointer is returned if the indicated line of the list is empty, +providing an efficient and convenient way to perform the empty test on mask +image lines. + +The functions \fIplglr[sil]\fR are similar to the get line list form of access, +but instead of returning the encoded list-list in the internal format, +it returns a simple array of ranges of absolute pixel indices and associated +mask values. This is the recommended way of accessing the mask as a list +structured object, since it does not require knowledge of the internal packed +line list format. For example, to print line \fIv\fR of the mask on descriptor +\fIpl\fR as a series of range lists: + +.ks +.nf + int buf[3,1024], n, i, plglri() + + n = plglri (pl, v, buf, 0, axlen[1], 0) + do i = 1, n { + call printf ("range at %d, %d pixels, mask value = %o\n") + call pargi (buf[1,i]); call pargi (buf[2,i]) + call pargi (buf[3,i]) + } +.fi +.ke + +These routines require that the depth in bits of the output line or range +list or pixel array be specified. This is necessary to avoid generating +numbers the size of the machine integer when inverting a mask (PIX_NOT), +e.g., if the mask depth is 8 bits, the complement of a 0 pixel should be 377, +not 37777777777. The depth argument may also be used to convert an integer +mask to a boolean mask, or vice versa (using the PIX_VALUE field of the +rasterop discussed in the next section). If \fIb_value\fR is zero, clipping +of the output values is disabled. This would be appropriate, for example, +when simply reading from a mask without modifying the pixel values. + +New pixel lists may be created by having the application prepare the packed +line lists externally, inserting them directly into the pixel list structure +with a \fIput\fR routine. This is generally inadvisable, however, because +the packed line list format is considered internal to the PLIO package. +A better alternative is to input the mask data as a populated array or +as a range list, letting the PL package manage the internal line list. + +A more convenient approach to creating or modifying masks for most applications +is to define the mask by specifying a series of include and exclude standard +region types (circles, boxes, lines, points, or polygons), +using the block of routines beginning with \fIpl_setplane\fR in the figure. +Note that these are two dimensional +operators; they are provided for convenience even though the pixel list +package can support images of any dimension (if the image has three or more +dimensions \fIpl_setplane\fR may be used to specify the plane to be operated +upon). The most general routine is \fIpl_polygon\fR, which may be used to +operate upon the pixels in the interior of any general polygon. All of the +region drawing operators will permit regions to extend beyond the boundary +of the mask, clipping as necessary at the boundary. + +.NH 2 +Pixel, Line, and Range List Routines + + Most of the N dimensional region or mask oriented PMIO and PLIO routines +eventually result in calls to the low level pixel, line, and range rasterop +routines and format conversion routines shown in the figure below. These +routines form the functional core of the PLIO package and will often be +responsible for most of the execution time of routines which use PLIO. + +There are two main classes of routines. The \fIpl_pixrop\fR, \fIpl_linerop\fR, +and \fIpl_rangerop\fR routines perform the general raster operation on pixel +arrays, line lists, and range lists. The \fIpl_linestencil\fR routine performs +the stencil rasterop operation upon line lists; currently only a list list +version is available since this is a rarely used routine. Lastly, a set of +six routines are provided for converting between any two of the three formats, +e.g., line list to range list or pixel array and vice versa, omitting the +like-to-like conversions. For example, \fIpl_p2ri\fR would convert a pixel +array to a range list, both of type integer. + +.ks +.nf + pl_linerop (ll_src, xs, src_maxval, + ll_dst, ds, dst_maxval, ll_out, npix, rop) + pl_linestencil (ll_src, xs, src_maxval, ll_dst, ds, dst_maxval, + ll_stn, xs, ll_out, npix, rop) + + pl_pixrop[sil] (px_src, xs, src_maxval, + px_dst, ds, dst_maxval, npix, rop) + pl_rangerop[sil] (rl_src, xs, src_maxval, + rl_dst, ds, dst_maxval, rl_out, npix, rop) + + n = pl_[lrp]2[lrp][sil] (op_src, xs, op_dst, npix) +.fi +.ke + +Note that these low level routines +specify the mask depth as a maximum pixel value, rather than taking the depth +in bits as the high level PMIO and PLIO routines do, and that there are no +\fI"pm_"\fR versions of these routines - the one set of routines may be used +with both PLIO and PMIO. + +.NH 2 +Rasterops + + The argument \fIrop\fR in the circle, box, and other routines discussed +in the previous sections is called a \fBrasterop\fR, and specifies the bitwise +operation to be performed to generate the destination operand. Much of the +generality and conciseness of the pixel list package is due to the rasterop +abstraction, which is patterned after a similar construct used by the Sun +Microsystems \fISunview\fR interface to specify operations upon \fIpixrects\fR, +which are logically similar to PLIO masks. + +The rasterop defines the operation to be performed to generate the destination +mask, in terms of bitwise boolean operations performed upon the input source +and destination masks. Rasterops are constructed via a series of bitwise +\fIand\fR and \fIor\fR operations, using the following macro defines: + +.ks +.nf + PIX_SRC specifies the source mask + PIX_DST specifies the destination mask + PIX_NOT(op) inverts the operand mask + PIX_VALUE(value) specifies the bitplanes to be set +.fi +.ke + +Examples of some of the possible operations (out of a total of 16 possible +operations) are shown below. This table is reproduced from the SunView +Pixrect Reference Manual. + +.ks +.nf + \fIRasterop\fR \fIDescription\fR + + PIX_SRC copy source to destination + PIX_DST no-op + PIX_SRC | PIX_DST paint (OR source to destination) + PIX_SRC & PIX_DST mask (AND of source and destination) + PIX_NOT(PIX_SRC)&PIX_DST erase (AND destination with negation + of source) + PIX_NOT(PIX_DST) invert area (negate the existing + values) + PIX_SRC ^ PIX_DST inverting paint (XOR of source and + destination) +.fi +.ke + +Here, the |&^ denote the SPP \fIor\fR, \fIand\fR, and \fIxor\fR intrinsic +functions, which must be used to construct actual rasterop expressions in SPP, +e.g.: + + PIX_NOT(PIX_SRC) | PIX_DST | PIX_VALUE(v) + +would actually be written as + + or (PIX_NOT(PIX_SRC), PIX_DST) + PIX_VALUE(v) + +The following additional macros are defined to deal with the more common +cases of setting or clearing a region. + +.ks +.nf + PIX_SET (PIX_SRC | PIX_NOT(PIX_SRC)) + PIX_CLR (PIX_SRC & PIX_NOT(PIX_SRC)) +.fi +.ke + +As a simple example, consider the case of specifying a region mask as a series +of include and exclude circles and boxes. This is trivial for a boolean mask: +an include circle or box is specified by the rasterop PIX_SET, and an exclude +by PIX_CLR. In the equivalent operation upon an integer mask this would cause +any mask values which had already been set to be replaced, hence it might be +desirable to use a PIX_SRC|PIX_DST rasterop instead, to OR the bits of the new +flag values into those of any flag values already set. Similarly, when using +\fIpl_ltop\fR to unpack a line list into a pixel array, the PIX_SRC|PIX_DST +rasterop might be specified to OR the mask segment into an existing pixel +array. + +General bitwise boolean operations upon masks are provided by the \fIpl_rop\fR +and \fIpl_stencil\fR operators, which operate upon entire masks or rectangular +subregions of masks. The \fIpl_rop\fR operator combines the source and +destination masks to produce a new mask; \fIpl_stencil\fR performs the same +operation, but only in the regions specified by the stencil mask, +which must be a boolean mask. The input mask may be NULL (depending upon +the rasterop specified), or the source and destination masks may be the same. + +The equivalent operators for line lists, range lists, and pixel arrays are +the \fIpl_S2D\fR family of routines, where \fIS=D=[lrp]\fR for a line list, +range list, or pixel array rop. The routine \fIpl_linestencil\fR implements +the stencil operation for a line list. + +As noted above, when operating upon integer masks (\fIdepth\fR > 1), the +PIX_VALUE macro is used to specify the flag value for the indicated region. +For example, the following rasterop would set all the pixels in a region to +the same value: + + PIX_VALUE(value) + +to OR in the new value instead of replacing any existing flag values: + + PIX_VALUE(value) | PIX_DST + +If a boolean mask is to be written to an integer mask, PIX_VALUE specifies +the flag value to be used for the regions set to 1 in the input boolean mask. +For example, one might wish to combine a set of 8 boolean masks to form a +single 8 bit deep integer mask, with each bit in the integer mask corresponding +to one of the input boolean masks (001 = mask 1, 002 = mask 2, 040 = mask 3, +etc.). This could be done using the rasterop shown above, incrementing +PIX_VALUE in each operation to specify the bitplane to be set. + +.NH 3 +Rasterop Expression Evaluation + + As mentioned above, there are sixteen possible ways to combine the source +and destination masks subject to the four possible boolean operations +(\fIand\fR, \fIor\fR, \fIxor\fR, and \fInot\fR). +More precisely, although numerous bitwise expressions can be constructed, many +of these are equivalent, and there are only sixteen fundamental operations. +These are summarized in the following table. + +.nf + Operation Opcode + + PIX_CLR 00 + PIX_SET 17 + + PIX_SRC 14 + PIX_DST 12 + + PIX_NOT(PIX_SRC) 03 + PIX_NOT(PIX_DST) 05 + + PIX_SRC & PIX_DST 10 + PIX_SRC | PIX_DST 16 + PIX_SRC ^ PIX_DST 06 + + PIX_SRC & PIX_NOT(PIX_DST) 04 + PIX_SRC | PIX_NOT(PIX_DST) 15 + PIX_NOT(PIX_SRC) & PIX_DST 02 + PIX_NOT(PIX_SRC) | PIX_DST 13 + + PIX_NOT (PIX_SRC & PIX_DST) 07 + PIX_NOT (PIX_SRC | PIX_DST) 01 + PIX_NOT (PIX_SRC ^ PIX_DST) 11 +.fi + +As an example of the redundancy of arbitrary rasterop expressions, +compare the following with the equivalent expressions (same opcode) +in the table above. + +.ks +.nf + PIX_NOT(PIX_SRC) & PIX_NOT(PIX_DST) 01 + PIX_NOT(PIX_SRC) ^ PIX_NOT(PIX_DST) 06 + PIX_NOT(PIX_SRC) | PIX_NOT(PIX_DST) 07 + PIX_NOT(PIX_SRC) ^ PIX_DST 11 + PIX_SRC ^ PIX_NOT(PIX_DST) 11 +.fi +.ke + +Any number of additional logically redundant expressions may be constructed. +The programmer should not worry about simplifying logical expressions, +but should choose instead whatever expression is clearest for their particular +application, letting the interface handle expression optimization internally. + +Of the sixteen possible fundamental operations, there are four trivial +operations (\fIclr\fR, \fIset\fR, \fIsrc\fR, \fIdst\fR), +seven composite operations, and four primary operations, namely, +\fIand\fR, \fIor\fR, \fIxor\fR, and \fInot\fR (two cases of the latter). +The composite operations are all implementable as two primary +operations in sequence. PIX_NOT is implemented by actual inversion of the +list rather than as a mode flag, to avoid complications when the list is read. + +.NH 3 +Rasterop Encoding + + The rasterop argument specifies the bitwise boolean operation to be +performed, and optionally the pixel value to be used (in the case of an +integer mask). Both are specified as a single integer value, packed as +shown in the figure below. + +.ks +.nf + +--+-------------+--------+ + |32|31 5|4 1| + +--+-------------+--------+ + | | pixel value | opcode | + +--+----------------------+ +.fi +.ke + +The following is an example of a typical rasterop (note that since the pixel +value field has a reserved range of bits which is zero prior to expression +evaluation, the "+" operator is equivalent to the \fIor\fR intrinsic function). + + or(PIX_SRC, PIX_NOT(PIX_DST)) + PIX_VALUE(pix_value) + +Note that the width of the pixel value field in the rasterop constrains the +effective mask depth to be 27 bits or less, if full generality is desired in +rasterop operations. Masks of up to 31 bits (the minimum unsigned precision +of a \fIlong\fR) can be stored and accessed, but rasterops using PIX_VALUE +are limited to 27 bits. + +.NH 2 +Pixel List Data Structures + + A pixel list consists of an array of pointers to the \fIline lists\fR +forming the mask. There is one pointer for each image line; if the pointer +is NULL, no mask values are set on the associated image line. N-dimensional +images are easily handled by an N-1 dimensional array of line pointers. + +Each line list consists of a series of offsets and mask pixel values +(the pixel values are normally omitted for a boolean mask). +The offsets specify the number of pixels for which the mask has the same value. +This line list format has the following two significant advantages over the +alternative technique of specifying a list of ranges using absolute pixel +coordinates: +.ls +.ls [1] +A higher degree of data compression is possible. If absolute pixel +coordinates are used in the list, the list must be an array of 32 bit +integer values in order to avoid a builtin limit on the size of the image +which can be represented. By using offsets, list elements as small as +one byte are possible. +.le +.ls [2] +A list composed of offsets is invariant with respect to translation. +For example, when extracting a subraster of an image, one can extract the +corresponding segment of each line list and perhaps edit the first element, +and the remainder of the list may be used without change. +.le +.le + +When describing regular regions such as boxes it will often be the case that +successive lines of the mask are equivalent, in which case multiple line list +pointers may point to the same line list. Hence, the line lists will provide +good compression of regular objects in any two dimensional plane of the mask. +This technique can be extended to higher dimensions if desirable, without +affecting the line list data structures visible to an application. + +.NH 3 +Line List Encoding + + A good compromise between storage efficiency and efficiency of runtime +access, while keeping things simple, is achieved if we maintain the compressed +line lists as variable length arrays of type short integer (16 bits per list +element), regardless of the mask depth. A line list consists of a series of +simple \fIinstructions\fR which are executed in sequence to reconstruct a line +of the mask. Each 16 bit instruction consists of the sign bit (not used at +present), a three bit \fIopcode\fR, and twelve bits of data, i.e.: + +.ks +.nf + +--+-----------+-----------------------------+ + |16|15 13|12 1| + +--+-----------+-----------------------------+ + | | opcode | data | + +--+-----------------------------------------+ +.fi +.ke + +The significance of the data depends upon the instruction. The instructions +currently implemented are summarized in the table below. + +.ks +.nf + Instruction Opcode Description + + ZN 00 Output N zeros + HN 04 Output N high values + PN 05 Output N-1 zeros plus one high value + SH 01 Set high value, absolute + IH,DH 02,03 Increment or decrement high value + IS,DS 06,07 Like IH-DH, plus output one high value +.fi +.ke + +In order to reconstruct a mask line, the application executing these +instructions is required to keep track of two values, +the \fIcurrent high value\fR and the \fIcurrent position\fR in the output line. +The detailed operation of each instruction is as follows: +.ls 4 +.ls 8 ZN +Zero the next N (=\fIdata\fR) output pixels. +.le +.ls HN +Set the next N output pixels to the current high value. +.le +.ls PN +Zero the next N-1 output pixels, and set pixel N to the current high value. +.le +.ls SH +Set the high value (absolute rather than incremental), taking the high 15 bits +from the next word in the instruction stream, and the low 12 bits from the +current data value. +.le +.ls IH,DH +Increment (IH) or decrement (DH) the current high value by the \fIdata\fR +value. The current position is not affected. +.le +.ls IS,DS +Increment (IS) or decrement (DS) the current high value by the \fIdata\fR +value, and \fIstep\fR, i.e., output one high value. +.le +.le + +The high value is assumed to be set to 1 at the beginning of a line, hence +the IH,DH and IS,DS instructions are not normally needed for boolean masks. +If the length of a line segment of constant value or the difference between +two successive high values exceeds 4096 (12 bits), then multiple instructions +are required to describe the segment or intensity change. + +The performance of this encoding is very good for typical masks consisting +of isolated high or low values or extended regions at the same level. +The worst case performance occurs when successive pixels have different values. +Even in this case the encoding will only require one word (16 bits) per mask +pixel, provided either the delta intensity change between pixels is usually +less than 12 bits, or the mask represents a zero floored step function of +constant height. The worst case cannot exceed npix*2 words provided the mask +depth is 24 bits or less. + +.NH 3 +Example: Line List Encoding + + As a simple example, consider the following line of a boolean mask. +The set pixels are 1, 4, 8 through 11, and so on, shown as \fIindex list\fR +in the figure. The corresponding \fIoffset list\fR (line list encoding) +is also shown. Note that both encodings require the same amount of space, +assuming 16 bits per list element in both cases; the index list would require +twice as much space if 32 bit list elements were used. + +.ks +.nf + Index list: 1, 4, 8-11, 15, 23-39 7 words + Offset list: P1 P3 Z3 H4 P4 Z7 H17 7 words + + Inverted I-L: 2-3, 5-7, 12-14, 16-22 8 words + Inverted O-L: Z1 H2 Z1 H3 Z4 H3 Z1 H7 8 words +.fi +.ke + +The bottom half of the figure shows the encodings for the inverted lists, +i.e., the lists which would be produced by a PIX_NOT rasterop operation. +Since both encodings reflect only the points in a line where level changes +occur, the information content and list size of the normal and inverted +lists are comparable. The encoding for an integer mask would be equivalent +except for the addition of occasional SH or SL instructions to set the high +value. + +.NH 3 +Line List Structure + + The full line list structure consists of a header describing the line +list entry in the PLIO descriptor, plus the LL encoding of the line, as +illustrated below. This information is internal to the PLIO package and +should not be used in applications code. [The LL header was generalized +in Aug2000 to permit larger masks; see plio.h] + +.ks +.nf + define LL_START 4 + struct linelist { + short nref # number of lines pointing here + short blen # length of buffer containing list + short len # encoded linelist length, words + short ll[] # encoded pixel data + } +.fi +.ke + +The linelist encoding includes any trailing zeros, i.e., executing of the +encoded instructions will regenerate the entire mask line. + +.NH 3 +Range List Structure + + The range list structure provides applications programs with a list +representation of a mask, for cases where it would be inefficient or +inconvenient to access the mask as a pixel array. Range lists are not +used to store masks in external storage, hence data compression is not an +issue, nor is machine independence. + +.ks +.nf + rtype = short|int|long + struct rangelist { + rtype x # x coordinate of first pixel + rtype n # number of pixels in range + rtype v # pixel value + } + + int rl[3,ARB] # typical range list array decl +.fi +.ke + +The range list structure is defined in , e.g. (refer to the actual +file for more reliable documentation for these definitions): + +.ks +.nf + RL_FIRST # first data range entry in list + RL_LENELEM # size of each element of list (i.e., 3) + RL_MAXLEN # maximum range list length (arg=pl) + + RL_LEN # physical length of range list (RL_LEN(rl)) + RL_AXLEN # length of mask image line (RL_AXLEN(rl)) + RLI_LEN # RL_LEN for rl = ptr to int + RLI_AXLEN # RL_AXLEN " " " + RLS_LEN # RL_LEN for rl = ptr to int + RLS_AXLEN # RL_AXLEN " " " + + RL_X # use as RL_X(rl,i), rl = range list array + RL_N # Npix field of range list array element + RL_V # Value field of range list array element + + RL_XOFF # offset of xstart field + RL_NOFF # offset of npix field + RL_VOFF # offset of value field +.fi +.ke + +The range list is represented as a simple two dimensional integer or +short integer array. The first line of the two dimensional array is +used as the \fBrange list header\fR, and is used to store the \fIlen\fR +and \fIaxlen\fR parameters describing the encoded mask line. Each +subsequent entry defines a range \fInpix\fR of mask image pixels, +starting at pixel \fIx\fR (absolute pixel coordinates), all of which +have the value \fIvalue\fR. Only nonzero ranges are stored. +Note that the \fIlen\fR field defines the entire length of the structure, +including the header range and data ranges. + +.NH 3 +Example: A Small Mask + + A complete example of a small mask (75 columns by 40 lines) is shown below. +This mask and the sample output were prepared by the PLIO debug interpreter, +file \fIzzdebug.x\fR in the PLIO source directory. + +.nf +40 .1111111..............................................................22222 +39 .1111111..............................................................22222 +38 .1111111...............................................................2222 +37 .1111111...............................................................2222 +36 .1111111............................................................4...... +35 .1111111.....................11111111111111111111111111...........4444..... +34 .1111111.....................11111111111111111111111111........44444444.... +33 .1111111......................1111111111111111111111111......44444444...... +32 .1111111......................1111111111111111111111111...44444444......... +31 .1111111......................1111111111111111111111111.44444444........... +30 .1111111...........4..........1111111111111111111111115444444.............. +29 .1111111...........4..........11111111111111111111155554444................ +28 .1111111...........4..........111111111111111111155555544.................. +27 .1111111...........4..........1111111111111111555555551.................... +26 .1111111.....................11111111111111155555555111.................... +25 .1111111.....................11111111111115555555111111.................... +24 ............................1111111111155444444.1111111.................... +23 ...........................111111111155544444....111111.................... +22 ..............1...........1111111155555444........11111.................... +21 ........................1111111155555554..........11111.................... +20 ........................111111555555511...........11111.................... +19 ........................111555555551111...........11111.................... +18 ........................155555555111111...........11111.................... +17 ......................445555551111111111.........111111.................... +16 ....................444455551111111111111.......1111111.................... +15 ..................4444445111111111111111111111111111111.................... +14 ...............44444444.1111111111111111111111111111111.................... +13 .............44444444...................................................... +12 ..........44444444......................................................... +11 ........44444444........................................................... +10 .........4444........................22222................................. + 9 ..........4.........................2222222..............22222............. + 8 ....................................2222222.............2222222............ + 7 ....................................2222222.............2222222............ + 6 .....................................22222..............2222222............ + 5 11111111111111111111.....................................22222............. + 4 11111111111111111111....................................................... + 3 11111111111111111111....................................................... + 2 11111111111111111111....................................................... + 1 11111111111111111111....................................................... + 123456789012345678901234567890123456789012345678901234567890123456789012345 + 1 2 3 4 5 6 7 +.fi + +This first figure shows the mask itself, output graphically as a character +matrix. This is an integer mask wherein the integer value of each pixel is +the ASCII value of the character shown. The mask was created by \fIor\fR-in +a number of regions together, using a different mask value for each region. +The result in areas where the regions intersect is a new mask pixel value. + +The figure below shows the internal data structures used to represent the +previous mask. Both the line list and range list representations of the +mask are shown. The size of the packed line list is 582 words, 189 of which +are free (no longer used due to updates), hence the packed line list size +would be 393 words following a call to \fIpl_compress\fR to compress the mask. + +.nf + Mask 1EECD naxes=2 [75,40] maxval=177 plane=[75,40] + max buffered line size 1024, max actual line size 16 + 40 lines total, 40 are nonempty, mask is nonempty + llbp=42AF5, len=1190, op=583, free=189, nupdates=35 + + Index at 1EFF1 containing 40 lines: + 4 4 4 4 17 26 35 35 166 177 187 + 194 201 208 218 228 241 254 266 554 292 568 + 319 333 347 360 492 507 523 539 423 435 447 + 459 471 483 148 148 157 157 + + Line list containing 40 lines: + [1:4] IH48(49) H20 Z55 (75,49) + [5] IH48(49) H20 IH1(50) Z37 H5 Z13 (75,50) + [6] IH49(50) Z37 H5 Z14 H7 Z12 (75,50) + [7:8] IH49(50) Z36 H7 Z13 H7 Z12 (75,50) + [9] IH51(52) P11 DH2(50) Z25 H7 Z14 H5 Z13 (75,50) + [10] IH51(52) Z9 H4 DH2(50) Z24 H5 Z33 (75,50) + [11] IH51(52) Z8 H8 Z59 (75,52) + [12] IH51(52) Z10 H8 Z57 (75,52) + [13] IH51(52) Z13 H8 Z54 (75,52) + [14] IH51(52) Z15 H8 DH3(49) Z1 H31 Z20 (75,49) + [15] IH51(52) Z18 H6 IS1(53) DH4(49) H30 Z20 (75,49) + [16] IH51(52) Z20 H4 IH1(53) H4 DH4(49) H13 Z7 H7 Z20 (75,49) + [17] IH51(52) Z22 H2 IH1(53) H6 DH4(49) H10 Z9 H6 Z20 (75,49) + [18] IH48(49) P25 IH4(53) H8 DH4(49) H6 Z11 H5 Z20 (75,49) + [19] IH48(49) Z24 H3 IH4(53) H8 DH4(49) H4 Z11 H5 Z20 (75,49) + [20] IH48(49) Z24 H6 IH4(53) H7 DH4(49) H2 Z11 H5 Z20 (75,49) + [21] IH48(49) Z24 H8 IH4(53) H7 DS1(52) DH3(49) Z10 H5 Z20 + (75,49) + [22] IH48(49) P15 Z11 H8 IH4(53) H5 DH1(52) H3 DH3(49) Z8 H5 + Z20 (75,49) + [23] IH48(49) Z27 H10 IH4(53) H3 DH1(52) H5 DH3(49) Z4 H6 Z20 + (75,49) + [24] IH48(49) Z28 H11 IH4(53) H2 DH1(52) H6 DH3(49) Z1 H7 Z20 + (75,49) + [25] IH48(49) Z1 H7 Z21 H13 IH4(53) H7 DH4(49) H6 Z20 (75,49) + [26] IH48(49) Z1 H7 Z21 H15 IH4(53) H8 DH4(49) H3 Z20 (75,49) + [27] IH48(49) Z1 H7 IH3(52) P12 DH3(49) Z10 H16 IH4(53) H8 + DS4(49) Z20 (75,49) + [28] IH48(49) Z1 H7 IH3(52) P12 DH3(49) Z10 H19 IH4(53) H6 + DH1(52) H2 Z18 (75,52) + [29] IH48(49) Z1 H7 IH3(52) P12 DH3(49) Z10 H21 IH4(53) H4 + DH1(52) H4 Z16 (75,52) + [30] IH48(49) Z1 H7 IH3(52) P12 DH3(49) Z10 H24 IS4(53) + DH1(52) H6 Z14 (75,52) + [31] IH48(49) Z1 H7 Z22 H25 IH3(52) Z1 H8 Z11 (75,52) + [32] IH48(49) Z1 H7 Z22 H25 IH3(52) Z3 H8 Z9 (75,52) + [33] IH48(49) Z1 H7 Z22 H25 IH3(52) Z6 H8 Z6 (75,52) + [34] IH48(49) Z1 H7 Z21 H26 IH3(52) Z8 H8 Z4 (75,52) + [35] IH48(49) Z1 H7 Z21 H26 IH3(52) Z11 H4 Z5 (75,52) + [36] IH48(49) Z1 H7 IH3(52) P61 Z6 (75,52) + [37:38] IH48(49) Z1 H7 IH1(50) Z63 H4 (75,50) + [39:40] IH48(49) Z1 H7 IH1(50) Z62 H5 (75,50) + + Line list containing 40 lines: + [1:4] 1-20(49) + [5] 1-20(49) 58-62(50) + [6] 38-42(50) 57-63(50) + [7:8] 37-43(50) 57-63(50) + [9] 11(52) 37-43(50) 58-62(50) + [10] 10-13(52) 38-42(50) + [11] 9-16(52) + [12] 11-18(52) + [13] 14-21(52) + [14] 16-23(52) 25-55(49) + [15] 19-24(52) 25(53) 26-55(49) + [16] 21-24(52) 25-28(53) 29-41(49) 49-55(49) + [17] 23-24(52) 25-30(53) 31-40(49) 50-55(49) + [18] 25(49) 26-33(53) 34-39(49) 51-55(49) + [19] 25-27(49) 28-35(53) 36-39(49) 51-55(49) + [20] 25-30(49) 31-37(53) 38-39(49) 51-55(49) + [21] 25-32(49) 33-39(53) 40(52) 51-55(49) + [22] 15(49) 27-34(49) 35-39(53) 40-42(52) 51-55(49) + [23] 28-37(49) 38-40(53) 41-45(52) 50-55(49) + [24] 29-39(49) 40-41(53) 42-47(52) 49-55(49) + [25] 2-8(49) 30-42(49) 43-49(53) 50-55(49) + [26] 2-8(49) 30-44(49) 45-52(53) 53-55(49) + [27] 2-8(49) 20(52) 31-46(49) 47-54(53) 55(49) + [28] 2-8(49) 20(52) 31-49(49) 50-55(53) 56-57(52) + [29] 2-8(49) 20(52) 31-51(49) 52-55(53) 56-59(52) + [30] 2-8(49) 20(52) 31-54(49) 55(53) 56-61(52) + [31] 2-8(49) 31-55(49) 57-64(52) + [32] 2-8(49) 31-55(49) 59-66(52) + [33] 2-8(49) 31-55(49) 62-69(52) + [34] 2-8(49) 30-55(49) 64-71(52) + [35] 2-8(49) 30-55(49) 67-70(52) + [36] 2-8(49) 69(52) + [37:38] 2-8(49) 72-75(50) + [39:40] 2-8(49) 71-75(50) +.fi + +The line list and range list tables shown consist of two columns, the first +listing the range of mask lines pointing to the line or range list shown to +the right (a sequence of identical mask lines will point to the same encoded +line list). Each instruction which changes the mask pixel value is followed +by the new current mask value in parenthesis. Zero ranges are omitted in +the range list format. The "pl_circle" regions appear as ellipses since +a printed character does not have a unit aspect ratio. + +.NH 3 +Pixel List Descriptor + + For runtime access to a mask we require, for an N dimensional mask, an +N-1 dimensional array of line list pointers, plus the line lists themselves. +Multiple line list pointers may point to the same encoded line list. +All line pointers are valid at all times, i.e., NULL pointers are not +permitted, even for empty mask lines. Initially, all line pointers will +point to the same entry, the encoded line list representation of an empty +line, i.e., a line of zeros (i.e., the single instruction ZN where N=axlen[1]). + +.ks +.nf + struct pldes { + int pl_magic # magic / version no. + int pl_private1 # used by PMIO (ref_im) + int pl_private2 # used by PMIO (mapxy flag) + int pl_maxline # max encoded line lentgh + int pl_maxval # mask depth as max pixel value + int pl_naxes # number of axes + int pl_axlen[7] # axis lengths + int pl_plane[7] # current plane for pl_setplane + int pl_llbp # line list bufptr + int pl_llop # next location in llbuf + int pl_lllen # current llbuf length + int pl_llfree # amount of free space in list + int pl_llnupdates # line list has been modified + int pl_llinc # llbuf increment on overflow + int pl_nlp # number of line pointers + int pl_lp[] # array of line pointers + } +.fi +.ke + +The main descriptor, which is a dynamically allocated data structure, is a +fixed size descriptor, the size of which depends upon the dimensionality and +size of the mask. A single additional dynamically allocated buffer of type +\fIshort\fR is used to store the encoded line lists. The size of this buffer +may vary at runtime as the mask is edited. New line lists, or edited line +lists which increase in size, are inserted at the end of the buffer. +As existing line lists are freed a count of the amount of free space is +kept in \fIpl_llfree\fR. If the percent of free space reaches a predetermined +level garbage collection is possible by copying the list, otherwise the line +list buffer is reallocated to increase its size. The line pointers \fIpl_lp\fR +are actually offsets into \fIllbuf\fR, rather than true pointers. + +.NH 3 +External Storage Format + + A mask is stored externally as a variable length array of 32 bit MII +integers (the stored mask header) followed by two variable length arrays of +16 bit MII integers, packed in the following format: + +.ks +.nf + struct pl_extern { + int ple_magic # magic / version no. + int ple_naxes # mask dimensionality + int ple_axlen[7] # length of each axis + int ple_llop # output pointer into llbuf + int ple_lllen # llbuf length, words + int ple_nlp # number of line pointers (lines) + int ple_nlpx # length of compressed index + int ple_exlen # length of full pl_extern struct + int ple_flags # flag bits + int ple_maxline # saved pl_maxline + int ple_maxval # saved pl_maxval + short ple_pkindex[] # packed line list index array + short ple_llbuf[] # line list buffer + } +.fi +.ke + +The \fIpl_compress\fR function is applied before a mask is encoded +into the external storage format, to eliminate the unused space in the line +list buffer which occurs during dynamic updates to the runtime list structure. +The line list index, containing one integer entry for each line in the mask +in the runtime format, is compressed using \fIpl_p2li\fR, storing in the +external representation the compressed array encoded as a line list in +\fIple_pkindex\fR. This is especially important for large masks, as otherwise +the index array could be by far the biggest contributor to the size of the +mask when encoded into its external format. + +No format conversions are required other than decoding the compressed line list +index and possibly byte swapping, hence accessing a stored list is very fast. +Further data compression is possible when packing the list for storage, but it +is not clear if this is justified. diff --git a/sys/plio/README b/sys/plio/README new file mode 100644 index 00000000..440bf528 --- /dev/null +++ b/sys/plio/README @@ -0,0 +1,288 @@ +PMIO -- The Pixel Mask I/O package (PLIO for image masks). +PLIO -- The Pixel List I/O package (no ties to IMIO) + + A PIXEL LIST is a compressed, region oriented data structure used to store +an image matrix. The pixel list package is used to create, manage, and access +this data structure. Although the PLIO package can stand alone and is useful +in its own right, one of the main uses of the pixel list package is in the IMIO +interface, which can access a pixel list as if it were a MASK IMAGE. +See PLIO.hlp for further information on the PLIO package and image masks. + +The pixel list package itself does not support any fancy image coordinate +transformations. If an image has an associated pixel mask, the pixel mask +refers to the physical image matrix. An application written at the IMIO level +where an image section transformation may be defined for an image should +normally use the PMIO (pixel mask) package in preference to PLIO. PMIO is +equivalent to PLIO, except that coordinates are input in image section +coordinates, and a reference image is used to map such coordinates onto the +physical image matrix. + + +1. IMIO Mask Image Interface + + im = im_pmmap (maskname, mode, ref_im|NULL) + im = im_pmmapo (pm, ref_im) + + imseti (im, IM_RLIO, YES|NO) # enable range list i/o + imseti (im, IM_PMDES, pm) # inquire PM descriptor + pm = imstati (im, IM_PMDES) + + bool = im_pmlne[123] (im[, lineno[, bandno]]) + bool = im_pmsne[123] (im, x1, x2[, y1, y2[, z1, z2]]) + bool = im_pmlnev (im, v) + bool = im_pmsnev (im, vs, ve, ndim) + + mp = mio_open (maskname, flags, im) # Masked Image I/O + mp = mio_openo (pm, im) + value = mio_stati (mp, param) + mio_seti (mp, param, value) + mio_setrange (mp, vs, ve, ndim) + n|EOF = mio_[gp]lseg[silrdx] (mp, ptr, mval, v, npix) + mio_close (mp) + + +2. Pixel Mask Interface (uses reference image for section transformation) + + pm = pm_newmask (ref_im, depth) + + pm = pm_open (bufptr|NULL) + pm = pm_create (naxes, axlen, depth) + pm = pm_newcopy (pm) + pm_close (pm) + + pm_[sg]size (pm, naxes, alxen, depth) + pm_seti (pm, param, value) + value = pm_stati (pm, param) + pm_debug (pm, outfd, maxcol, flags) + bool = pm_empty (pm) + pm_compress (pm) + pm_clear (pm) + + pm_load (pm, bufptr) + nwords = pm_save (pm, bufptr, buflen, save_flags) + pm_loadf (pm, fname, title, maxch) + pm_savef (pm, fname, title, save_flags) + pm_[load|save]im (pm, imname[, save_flags]) + + ptr = pm_emptyline (pm) + ptr = pm_access (pm, v) + bool = pm_linenotempty (pm, v) + bool = pm_sectnotempty (pm, vs, ve, ndim) + pm[gp]l[lrp][sil] (pm, v, buf, b_depth, npix, rop) + + pm_[set|get]plane (pm, v) + pm_point (pm, x, y, rop) + pm_circle (pm, x, y, r, rop) + pm_box (pm, x1,y1, x2,y2, rop) + pm_line (pm, x1,y1, x2,y2, width, rop) + pm_polygon (pm, x, y, npts, rop) + + pm_rop (pm_src, vs, pm_dst, vs, vn, rop) + pm_stencil (pm_src, vs, pm_dst, vs, pm_stl, vs, vn, rop) + + +2.1 Random Access to a Pixel Mask + + pmr = pmr_open (pm, plane, buflimit) + pmr_setrect (pmr, x1,y1, x2,y2) + mval = pmr_getpix (pmr, i, j) + pmr_close (pmr) + + +3. Pixel List Interface (stands alone; independent of IMIO; no coord xforms) + + pl = pl_open (bufptr|NULL) + pl = pl_create (naxes, axlen, depth) + pl = pl_newcopy (pl) + pl_close (pl) + + pl_[sg]size (pl, naxes, axlen, depth) + pl_seti (pl, param, value) + value = pl_stati (pl, param) + pl_debug (pl, outfd, maxcol, flags) + bool = pl_empty (pl) + pl_compress (pl) + pl_clear (pl) + + pl_load (pl, bufptr) + nwords = pl_save (pl, bufptr, buflen, save_flags) + pl_loadf (pl, fname, title, maxch) + pl_savef (pl, fname, title, save_flags) + pl_[load|save]im (pl, imname[, save_flags]) + + ptr = pl_emptyline (pl) + ptr = pl_access (pl, v) + bool = pl_linenotempty (pl, v) + bool = pl_sectnotempty (pl, vs, ve, ndim) + pl[gp]l[lrp][sil] (pl, v, buf, b_depth, npix, rop) + + pl_[set|get]plane (pl, v) + pl_point (pl, x, y, rop) + pl_circle (pl, x, y, r, rop) + pl_box (pl, x1,y1, x2,y2, rop) + pl_line (pl, x1,y1, x2,y2, width, rop) + pl_polygon (pl, x, y, npts, rop) + + pl_rop (pl_src, vs, pl_dst, vs, vn, rop) + pl_stencil (pl_src, vs, pl_dst, vs, pl_stl, vs, vn, rop) + + +3.1 Random Access to a Pixel List + + plr = plr_open (pl, plane, buflimit) + plr_setrect (plr, x1,y1, x2,y2) + mval = plr_getpix (plr, i, j) + plr_getlut (plr, bufp, xsize,ysize, xblock,yblock) + plr_close (plr) + + +3.2 Pixel, Line, and Range List Routines + + pl_pixrop (px_src, xs, src_maxval, + px_dst, ds, dst_maxval, npix, rop) + pl_linerop (ll_src, xs, src_maxval, + ll_dst, ds, dst_maxval, ll_out, npix, rop) + pl_rangerop (rl_src, xs, src_maxval, + rl_dst, ds, dst_maxval, rl_out, npix, rop) + pl_linestencil (ll_src, xs, src_maxval, ll_dst, ds, dst_maxval, + ll_stn, xs, ll_out, npix, rop) + + n = pl_[lrp]2[lrp][sil] (op_src, xs, op_dst, npix) + + len = pl_llen (ll) + + +4. EXAMPLE + +4.1 Sample Mask (pl_draw output) + + 40 .1111111..............................................................22222 + 39 .1111111..............................................................22222 + 38 .1111111...............................................................2222 + 37 .1111111...............................................................2222 + 36 .1111111............................................................4...... + 35 .1111111.....................11111111111111111111111111...........4444..... + 34 .1111111.....................11111111111111111111111111........44444444.... + 33 .1111111......................1111111111111111111111111......44444444...... + 32 .1111111......................1111111111111111111111111...44444444......... + 31 .1111111......................1111111111111111111111111.44444444........... + 30 .1111111...........4..........1111111111111111111111115444444.............. + 29 .1111111...........4..........11111111111111111111155554444................ + 28 .1111111...........4..........111111111111111111155555544.................. + 27 .1111111...........4..........1111111111111111555555551.................... + 26 .1111111.....................11111111111111155555555111.................... + 25 .1111111.....................11111111111115555555111111.................... + 24 ............................1111111111155444444.1111111.................... + 23 ...........................111111111155544444....111111.................... + 22 ..............1...........1111111155555444........11111.................... + 21 ........................1111111155555554..........11111.................... + 20 ........................111111555555511...........11111.................... + 19 ........................111555555551111...........11111.................... + 18 ........................155555555111111...........11111.................... + 17 ......................445555551111111111.........111111.................... + 16 ....................444455551111111111111.......1111111.................... + 15 ..................4444445111111111111111111111111111111.................... + 14 ...............44444444.1111111111111111111111111111111.................... + 13 .............44444444...................................................... + 12 ..........44444444......................................................... + 11 ........44444444........................................................... + 10 .........4444........................22222................................. + 9 ..........4.........................2222222..............22222............. + 8 ....................................2222222.............2222222............ + 7 ....................................2222222.............2222222............ + 6 .....................................22222..............2222222............ + 5 11111111111111111111.....................................22222............. + 4 11111111111111111111....................................................... + 3 11111111111111111111....................................................... + 2 11111111111111111111....................................................... + 1 11111111111111111111....................................................... + 123456789012345678901234567890123456789012345678901234567890123456789012345 + 1 2 3 4 5 6 7 + + +4.2 Sample Debug Output (for above mask) + +Mask 1EECD naxes=2 [75,40] maxval=177 plane=[75,40] +max buffered line size 1024, max actual line size 16 +40 lines total, 40 are nonempty, mask is nonempty +llbp=42AF5, len=1190, op=583, free=189, nupdates=35 +Index at 1EFF1 containing 40 lines: + 4 4 4 4 17 26 35 35 166 177 187 + 194 201 208 218 228 241 254 266 554 292 568 + 319 333 347 360 492 507 523 539 423 435 447 + 459 471 483 148 148 157 157 +Line list containing 40 lines: +[1:4] IH48(49) H20 Z55 (75,49) +[5] IH48(49) H20 IH1(50) Z37 H5 Z13 (75,50) +[6] IH49(50) Z37 H5 Z14 H7 Z12 (75,50) +[7:8] IH49(50) Z36 H7 Z13 H7 Z12 (75,50) +[9] IH51(52) P11 DH2(50) Z25 H7 Z14 H5 Z13 (75,50) +[10] IH51(52) Z9 H4 DH2(50) Z24 H5 Z33 (75,50) +[11] IH51(52) Z8 H8 Z59 (75,52) +[12] IH51(52) Z10 H8 Z57 (75,52) +[13] IH51(52) Z13 H8 Z54 (75,52) +[14] IH51(52) Z15 H8 DH3(49) Z1 H31 Z20 (75,49) +[15] IH51(52) Z18 H6 IS1(53) DH4(49) H30 Z20 (75,49) +[16] IH51(52) Z20 H4 IH1(53) H4 DH4(49) H13 Z7 H7 Z20 (75,49) +[17] IH51(52) Z22 H2 IH1(53) H6 DH4(49) H10 Z9 H6 Z20 (75,49) +[18] IH48(49) P25 IH4(53) H8 DH4(49) H6 Z11 H5 Z20 (75,49) +[19] IH48(49) Z24 H3 IH4(53) H8 DH4(49) H4 Z11 H5 Z20 (75,49) +[20] IH48(49) Z24 H6 IH4(53) H7 DH4(49) H2 Z11 H5 Z20 (75,49) +[21] IH48(49) Z24 H8 IH4(53) H7 DS1(52) DH3(49) Z10 H5 Z20 (75,49) +[22] IH48(49) P15 Z11 H8 IH4(53) H5 DH1(52) H3 DH3(49) Z8 H5 Z20 (75,49) +[23] IH48(49) Z27 H10 IH4(53) H3 DH1(52) H5 DH3(49) Z4 H6 Z20 (75,49) +[24] IH48(49) Z28 H11 IH4(53) H2 DH1(52) H6 DH3(49) Z1 H7 Z20 (75,49) +[25] IH48(49) Z1 H7 Z21 H13 IH4(53) H7 DH4(49) H6 Z20 (75,49) +[26] IH48(49) Z1 H7 Z21 H15 IH4(53) H8 DH4(49) H3 Z20 (75,49) +[27] IH48(49) Z1 H7 IH3(52) P12 DH3(49) Z10 H16 IH4(53) H8 DS4(49) Z20 + (75,49) +[28] IH48(49) Z1 H7 IH3(52) P12 DH3(49) Z10 H19 IH4(53) H6 DH1(52) H2 Z18 + (75,52) +[29] IH48(49) Z1 H7 IH3(52) P12 DH3(49) Z10 H21 IH4(53) H4 DH1(52) H4 Z16 + (75,52) +[30] IH48(49) Z1 H7 IH3(52) P12 DH3(49) Z10 H24 IS4(53) DH1(52) H6 Z14 + (75,52) +[31] IH48(49) Z1 H7 Z22 H25 IH3(52) Z1 H8 Z11 (75,52) +[32] IH48(49) Z1 H7 Z22 H25 IH3(52) Z3 H8 Z9 (75,52) +[33] IH48(49) Z1 H7 Z22 H25 IH3(52) Z6 H8 Z6 (75,52) +[34] IH48(49) Z1 H7 Z21 H26 IH3(52) Z8 H8 Z4 (75,52) +[35] IH48(49) Z1 H7 Z21 H26 IH3(52) Z11 H4 Z5 (75,52) +[36] IH48(49) Z1 H7 IH3(52) P61 Z6 (75,52) +[37:38] IH48(49) Z1 H7 IH1(50) Z63 H4 (75,50) +[39:40] IH48(49) Z1 H7 IH1(50) Z62 H5 (75,50) + +Line list containing 40 lines: +[1:4] 1-20(49) +[5] 1-20(49) 58-62(50) +[6] 38-42(50) 57-63(50) +[7:8] 37-43(50) 57-63(50) +[9] 11(52) 37-43(50) 58-62(50) +[10] 10-13(52) 38-42(50) +[11] 9-16(52) +[12] 11-18(52) +[13] 14-21(52) +[14] 16-23(52) 25-55(49) +[15] 19-24(52) 25(53) 26-55(49) +[16] 21-24(52) 25-28(53) 29-41(49) 49-55(49) +[17] 23-24(52) 25-30(53) 31-40(49) 50-55(49) +[18] 25(49) 26-33(53) 34-39(49) 51-55(49) +[19] 25-27(49) 28-35(53) 36-39(49) 51-55(49) +[20] 25-30(49) 31-37(53) 38-39(49) 51-55(49) +[21] 25-32(49) 33-39(53) 40(52) 51-55(49) +[22] 15(49) 27-34(49) 35-39(53) 40-42(52) 51-55(49) +[23] 28-37(49) 38-40(53) 41-45(52) 50-55(49) +[24] 29-39(49) 40-41(53) 42-47(52) 49-55(49) +[25] 2-8(49) 30-42(49) 43-49(53) 50-55(49) +[26] 2-8(49) 30-44(49) 45-52(53) 53-55(49) +[27] 2-8(49) 20(52) 31-46(49) 47-54(53) 55(49) +[28] 2-8(49) 20(52) 31-49(49) 50-55(53) 56-57(52) +[29] 2-8(49) 20(52) 31-51(49) 52-55(53) 56-59(52) +[30] 2-8(49) 20(52) 31-54(49) 55(53) 56-61(52) +[31] 2-8(49) 31-55(49) 57-64(52) +[32] 2-8(49) 31-55(49) 59-66(52) +[33] 2-8(49) 31-55(49) 62-69(52) +[34] 2-8(49) 30-55(49) 64-71(52) +[35] 2-8(49) 30-55(49) 67-70(52) +[36] 2-8(49) 69(52) +[37:38] 2-8(49) 72-75(50) +[39:40] 2-8(49) 71-75(50) diff --git a/sys/plio/mkpkg b/sys/plio/mkpkg new file mode 100644 index 00000000..deb49757 --- /dev/null +++ b/sys/plio/mkpkg @@ -0,0 +1,94 @@ +# Make the PLIO package library. + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +tfiles: + $set GFLAGS = "-k -t sil -p tf/" + $ifolder (tf/plglpi.x, plglp.gx) $generic $(GFLAGS) plglp.gx $endif + $ifolder (tf/plglri.x, plglr.gx) $generic $(GFLAGS) plglr.gx $endif + $ifolder (tf/pll2pi.x, pll2p.gx) $generic $(GFLAGS) pll2p.gx $endif + $ifolder (tf/pll2ri.x, pll2r.gx) $generic $(GFLAGS) pll2r.gx $endif + $ifolder (tf/plp2li.x, plp2l.gx) $generic $(GFLAGS) plp2l.gx $endif + $ifolder (tf/plp2ri.x, plp2r.gx) $generic $(GFLAGS) plp2r.gx $endif + $ifolder (tf/plplpi.x, plplp.gx) $generic $(GFLAGS) plplp.gx $endif + $ifolder (tf/plplri.x, plplr.gx) $generic $(GFLAGS) plplr.gx $endif + $ifolder (tf/plpropi.x, plprop.gx) $generic $(GFLAGS) plprop.gx $endif + $ifolder (tf/plr2li.x, plr2l.gx) $generic $(GFLAGS) plr2l.gx $endif + $ifolder (tf/plr2pi.x, plr2p.gx) $generic $(GFLAGS) plr2p.gx $endif + $ifolder (tf/plrropi.x, plrrop.gx) $generic $(GFLAGS) plrrop.gx $endif + $ifolder (tf/plrpri.x, plrpr.gx) $generic $(GFLAGS) plrpr.gx $endif + $ifolder (tf/plreqi.x, plreq.gx) $generic $(GFLAGS) plreq.gx $endif + ; + +zzdebug: +zzdebug.e: + $set XFLAGS = "$(XFLAGS) -q" + $omake zzdebug.x + $link -z zzdebug.o -o zzdebug.e + ; + +libex.a: + # Retranslate any recently modified generic sources. + $ifeq (hostid, unix) + $call tfiles + $endif + + @tf # Update datatype expanded files. + + placcess.x + plalloc.x + plascii.x + plbox.x plbox.h + plubox.x plbox.h + plcircle.x plcircle.h + plucircle.x plcircle.h + plclear.x + plclose.x + plcmpress.x + plcompare.x + plcreate.x + pldbgout.x + pldebug.x + plempty.x + plemptyline.x + plglls.x + plgplane.x + plgsize.x + pllen.x + plleq.x + plline.x + pllinene.x + pllnext.x pllseg.h + plload.x + plloadf.x + plloadim.x + plloop.x + pllpr.x + pllrop.x pllseg.h + pllsten.x pllseg.h + plnewcopy.x + plopen.x + plplls.x + plpoint.x + plpolygon.x plpolygon.h + plupolygon.x plpolygon.h + plregrop.x + plrio.x + plrop.x + plsave.x + plsavef.x + plsaveim.x + plsectnc.x pllseg.h + plsectne.x pllseg.h + plseti.x + plsplane.x + plssize.x + plsslv.x + plstati.x + plsten.x + plupdate.x + plvalid.x + ; diff --git a/sys/plio/placcess.x b/sys/plio/placcess.x new file mode 100644 index 00000000..92cb036d --- /dev/null +++ b/sys/plio/placcess.x @@ -0,0 +1,59 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# PL_ACCESS -- Return a pointer (type short) to the encoded line list data +# for the indicated mask image line. A valid pointer is always returned; +# if the mask line is empty, the pointer will point to "empty line" linelist. + +pointer procedure pl_access (pl, v) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I coordinates of desired line + +int pl_reference() + +begin + return (Ref (pl, pl_reference(pl,v))) +end + + +# PL_REFERENCE -- Return a reference (llbuf offset) to the indicated mask +# image line. A valid offset is always returned; if the mask line is empty, +# the offset will be that of the "empty line" linelist. + +int procedure pl_reference (pl, v) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I coordinates of desired line + +int index, i +int totlen, axlen +define oob_ 91 + +begin + # Compute the index of the line in the line pointer array. + if (PL_NAXES(pl) == 2) { + # Optimized for case naxes=2. + index = v[2] + if (index < 1 || index > PL_AXLEN(pl,2)) + goto oob_ + } else { + # General case. + index = 1 + totlen = 1 + do i = 2, PL_NAXES(pl) { + axlen = PL_AXLEN(pl,i) + if (v[i] < 1 || v[i] > axlen) + goto oob_ + index = index + totlen * (v[i] - 1) + totlen = totlen * axlen + } + } + + return (PL_LP(pl,index)) +oob_ + call syserr (SYS_PLREFOOB) +end diff --git a/sys/plio/plalloc.x b/sys/plio/plalloc.x new file mode 100644 index 00000000..1fecf486 --- /dev/null +++ b/sys/plio/plalloc.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PL_ALLOC -- Allocate space in the line list buffer, returning the llbuf +# offset of the allocated area as the function value. If overflow occurs +# the buffer is resized. + +int procedure pl_alloc (pl, nwords) + +pointer pl #I mask descriptor +int nwords #I number of words of storage to allocate + +int newbuf +int len, o_len, inc, op +errchk realloc + +begin + len = PL_LLLEN(pl) # current buffer length + inc = PL_LLINC(pl) # length increment + op = PL_LLOP(pl) # next available location + + newbuf = op + op = newbuf + nwords + + for (o_len = len; op >= len; ) { + inc = min (PL_MAXINC, inc * 2) + len = len + inc + } + + if (len != o_len) + call realloc (PL_LLBP(pl), len, TY_SHORT) + + PL_LLLEN(pl) = len + PL_LLINC(pl) = inc + PL_LLOP(pl) = op + + return (newbuf) +end diff --git a/sys/plio/plascii.x b/sys/plio/plascii.x new file mode 100644 index 00000000..8106b10e --- /dev/null +++ b/sys/plio/plascii.x @@ -0,0 +1,66 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_ASCIIDUMP -- Dump a two dimensional region of a mask as a printable ASCII +# character array on the output stream. Intended as a simple debugging tool; +# see also PL_SAVEIM. + +procedure pl_asciidump (pl, vs, ve, outfd) + +pointer pl #I mask descriptor +long vs[ARB] #I ll vector (only first two elements used) +long ve[ARB] #I ur vector (only first two elements used) +int outfd #I output file + +pointer sp, pv, cv +int npix, ch, i +long v[PL_MAXDIM] +errchk pl_valid + +begin + call pl_valid (pl) + npix = ve[1] - vs[1] + 1 + + call smark (sp) + call salloc (pv, npix, TY_INT) + call salloc (cv, npix, TY_CHAR) + + # Output mask. + call amovl (vs, v, PL_MAXDIM) + v[2] = ve[2] + + while (v[2] >= vs[2]) { + call pl_glpi (pl, v, Memi[pv], 0, npix, PIX_SRC) + do i = 1, npix { + ch = mod (Memi[pv+i-1], 128) + if (ch < 32) + ch = ch + 32 + if (ch <= 32 || ch == 127) + ch = '.' + Memc[cv+i-1] = ch + } + call fprintf (outfd, "%3d ") + call pargi (v[2]) + call write (outfd, Memc[cv], npix) + call putci (outfd, '\n') + v[2] = v[2] - 1 + } + + # Label the columns. + call fprintf (outfd, "%5t") + do i = 1, npix + call putci (outfd, TO_DIGIT(mod (i,10))) + call fprintf (outfd, "\n") + + call fprintf (outfd, "%5t") + do i = 1, npix + if (mod (i, 10) == 0) + call putci (outfd, TO_DIGIT(i / 10)) + else + call putci (outfd, ' ') + call fprintf (outfd, "\n") + + call sfree (sp) +end diff --git a/sys/plio/plbox.h b/sys/plio/plbox.h new file mode 100644 index 00000000..f988b9d6 --- /dev/null +++ b/sys/plio/plbox.h @@ -0,0 +1,10 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define LEN_BOXDES 6 +define B_PL Memi[$1] # reference mask +define B_X1 Memi[$1+1] # X1 coord of box +define B_Y1 Memi[$1+2] # Y1 coord of box +define B_X2 Memi[$1+3] # X2 coord of box +define B_Y2 Memi[$1+4] # Y2 coord of box +define B_PV Memi[$1+5] # pixel value + diff --git a/sys/plio/plbox.x b/sys/plio/plbox.x new file mode 100644 index 00000000..35dbda4c --- /dev/null +++ b/sys/plio/plbox.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "plbox.h" + + +# PL_BOX -- Rasterop between a box as source, and an existing mask as dest. +# This is a 2-dim operator. The pl_setplane procedure is used to specify +# the plane to be modified. + +procedure pl_box (pl, x1,y1, x2,y2, rop) + +pointer pl #I mask descriptor +int x1,y1 #I lower left corner of box +int x2,y2 #I upper right corner of box +int rop #I rasterop + +pointer sp, ufd +extern pl_ubox() + +begin + call plvalid (pl) + call smark (sp) + call salloc (ufd, LEN_BOXDES, TY_STRUCT) + + B_PL(ufd) = pl + B_X1(ufd) = max(1, min(PL_AXLEN(pl,1), x1)) + B_Y1(ufd) = max(1, min(PL_AXLEN(pl,2), y1)) + B_X2(ufd) = max(1, min(PL_AXLEN(pl,1), x2)) + B_Y2(ufd) = max(1, min(PL_AXLEN(pl,2), y2)) + B_PV(ufd) = 1 + + call pl_regionrop (pl, pl_ubox, ufd, y1, y2, rop) + + call sfree (sp) +end diff --git a/sys/plio/plcircle.h b/sys/plio/plcircle.h new file mode 100644 index 00000000..f77492f9 --- /dev/null +++ b/sys/plio/plcircle.h @@ -0,0 +1,10 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + + +define LEN_CIRCLEDES 5 +define C_PL Memi[$1] # reference mask +define C_XCEN Memr[P2R($1+1)] # X1 coord of circle +define C_YCEN Memr[P2R($1+2)] # Y1 coord of circle +define C_RADIUS Memr[P2R($1+3)] # X2 coord of circle +define C_PV Memi[$1+4] # pixel value + diff --git a/sys/plio/plcircle.x b/sys/plio/plcircle.x new file mode 100644 index 00000000..504c1ce5 --- /dev/null +++ b/sys/plio/plcircle.x @@ -0,0 +1,43 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "plcircle.h" + + +# PL_CIRCLE -- Rasterop between a circular region as source, and an existing +# mask as destination. It is not necessary for the center of the circle to +# be inside the mask; if it is outside, the boundary of the circle will be +# clipped to the boundary of the mask. This is a 2-dim operator. If the +# image dimensionality is greater than two the pl_setplane procedure should +# be called first to specify the plane to be modified. + +procedure pl_circle (pl, x, y, radius, rop) + +pointer pl #I mask descriptor +int x,y #I center coords of circle +int radius #I radius of circle +int rop #I rasterop + +int y1, y2 +pointer sp, ufd +extern pl_ucircle() + +begin + call plvalid (pl) + call smark (sp) + call salloc (ufd, LEN_CIRCLEDES, TY_STRUCT) + + y1 = max ( 1, min (PL_AXLEN(pl,2), y - radius)) + y2 = max (y1, min (PL_AXLEN(pl,2), y + radius)) + + C_PL(ufd) = pl + C_XCEN(ufd) = x + C_YCEN(ufd) = y + C_RADIUS(ufd) = radius + C_PV(ufd) = 1 + + call pl_regionrop (pl, pl_ucircle, ufd, y1, y2, rop) + + call sfree (sp) +end diff --git a/sys/plio/plclear.x b/sys/plio/plclear.x new file mode 100644 index 00000000..5ece1b5d --- /dev/null +++ b/sys/plio/plclear.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PL_CLEAR -- Clear a mask. The entire surface is cleared. This is equivalent +# to a full surface pl_rop with rop=PIX_CLR, but is more convenient and can be +# implemented more efficiently since the entire surface is cleared. + +procedure pl_clear (pl) + +pointer pl #I mask descriptor + +pointer lp +int n_len, i +errchk realloc + +begin + # Clear the line list buffer. + lp = Ref (pl, PL_EMPTYLINE) + PL_LLOP(pl) = LP_BLEN(lp) + LP_NREFS(lp) = PL_NLP(pl) + + do i = 1, PL_NLP(pl) + PL_LP(pl,i) = PL_EMPTYLINE + + n_len = PL_LLBUFLEN + call realloc (PL_LLBP(pl), n_len, TY_SHORT) + + PL_LLLEN(pl) = n_len + PL_LLFREE(pl) = 0 + PL_LLNUPDATES(pl) = 0 +end diff --git a/sys/plio/plclose.x b/sys/plio/plclose.x new file mode 100644 index 00000000..e5e53e2b --- /dev/null +++ b/sys/plio/plclose.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_CLOSE -- Close a mask descriptor. The memory resident mask is destroyed; +# an explicit call to one of the save procedures is required to save the mask +# in external storage. + +procedure pl_close (pl) + +pointer pl #I mask descriptor +errchk syserr + +begin + if (pl != NULL) { + if (PL_MAGIC(pl) != PL_MAGICVAL) + call syserr (SYS_PLINVDES) + + if (PL_LPP(pl) != NULL) + call mfree (PL_LPP(pl), TY_INT) + if (PL_LLBP(pl) != NULL) + call mfree (PL_LLBP(pl), TY_SHORT) + call mfree (pl, TY_STRUCT) + } +end diff --git a/sys/plio/plcmpress.x b/sys/plio/plcmpress.x new file mode 100644 index 00000000..54850a7a --- /dev/null +++ b/sys/plio/plcmpress.x @@ -0,0 +1,90 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_COMPRESS -- Compress the line list buffer to eliminate any unusable +# space, as is generated when mask lines are modified and the old line lists +# are freed. The compress operation may move the line lists about, possibly +# changing the line offsets. + +procedure pl_compress (pl) + +pointer pl #I mask descriptor + +pointer n_bp, o_lp, n_lp, op +int nwords, r_len, b_len, i +errchk malloc, mfree, syserr + +begin + # Redundant calls are ignored. + if (PL_LLNUPDATES(pl) <= 0) + return + + # Return if there was a prior error with plalloc. + if (PL_LLBP(pl) == NULL) + call syserr (SYS_PLBADMASK) + + # Count the total space in the active line lists. + nwords = 0 + for (i=0; i < PL_LLOP(pl); i=i+b_len) { + o_lp = Ref (pl, i) + b_len = LP_BLEN(o_lp) + if (b_len <= 0 || b_len > PL_LLOP(pl)) + call syserr (SYS_PLBADMASK) + if (i == PL_EMPTYLINE || LP_NREF(o_lp) > 0) + nwords = nwords + LP_LEN(o_lp) + } + + # Verify that the free space accounting is correct. + if (nwords != (PL_LLOP(pl) - PL_LLFREE(pl))) + call eprintf ("Warning: PL_LLFREE inconsistent (recoverable)\n") + + # Allocate a new buffer large enough to hold the compressed line list. + call malloc (n_bp, nwords, TY_SHORT) + + # Copy the active line lists to the new buffer; as each line is + # copied, overwrite a couple words of the old line list with the + # new offset of the line. + + op = 0 + for (i=0; i < PL_LLOP(pl); i=i+b_len) { + o_lp = Ref (pl, i) + b_len = LP_BLEN(o_lp) + if (b_len <= 0 || b_len > PL_LLOP(pl)) + call syserr (SYS_PLBADMASK) + + if (i == PL_EMPTYLINE || LP_NREF(o_lp) > 0) { + n_lp = n_bp + op + r_len = LP_LEN(o_lp) + + # The following should not be possible, barring a bug. + if (op + r_len > nwords) + call fatal (pl, "pl_compress: llbuf overflow") + + call amovs (Mems[o_lp], Mems[n_lp], r_len) + + LP_NREFS(o_lp) = op / I_SHIFT + LP_SETBLEN(o_lp, mod (op, I_SHIFT)) + LP_SETBLEN(n_lp, r_len) + op = op + r_len + } + } + + # Fix up the line index by accessing the tag word in the old line list + # in the old buffer to get the line list offset in the new buffer. + + do i = 1, PL_NLP(pl) { + o_lp = Ref (pl, PL_LP(pl,i)) + PL_LP(pl,i) = LP_NREF(o_lp) * I_SHIFT + LP_BLEN(o_lp) + } + + # Deallocate the old buffer and install the new one. + call mfree (PL_LLBP(pl), TY_SHORT) + + PL_LLBP(pl) = n_bp + PL_LLOP(pl) = op + PL_LLLEN(pl) = nwords + PL_LLFREE(pl) = 0 + PL_LLNUPDATES(pl) = 0 +end diff --git a/sys/plio/plcompare.x b/sys/plio/plcompare.x new file mode 100644 index 00000000..59ba9d1f --- /dev/null +++ b/sys/plio/plcompare.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_COMPARE -- Compare two masks for equality, optionally noting any +# differences on the output file. PL_EQUAL is returned if the two masks +# are equivalent. + +int procedure pl_compare (pl_1, pl_2, outfd) + +pointer pl_1, pl_2 #I masks to be compared +int outfd #I file for diagnostic output, or NULL + +int i +bool pll_equal() + +begin + if (PL_NAXES(pl_1) != PL_NAXES(pl_2) || PL_NLP(pl_1) != PL_NLP(pl_2)) { + if (outfd != NULL) + call fprintf (outfd, "the masks are not the same size\n") + return (PL_NOTEQUAL) + } + + do i = 1, PL_NLP(pl_1) + if (!pll_equal (LL(pl_1,PL_LP(pl_1,i)), LL(pl_2,PL_LP(pl_2,i)))) { + if (outfd != NULL) { + call fprintf (outfd, "masks differ at line %d\n") + call pargi (i) + } + return (PL_NOTEQUAL) + } + + return (PL_EQUAL) +end diff --git a/sys/plio/plcreate.x b/sys/plio/plcreate.x new file mode 100644 index 00000000..fe972bcb --- /dev/null +++ b/sys/plio/plcreate.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# PL_CREATE -- Create an empty mask with the given dimensionality and size. +# A newly created mask has all line pointers pointing to the empty line, +# which is stored as the first entry in the line list buffer. + +pointer procedure pl_create (naxes, axlen, depth) + +int naxes #I number of axes (dimensionality of mask) +long axlen[ARB] #I length of each axis +int depth #I mask depth, bits + +pointer pl +pointer pl_open() +errchk pl_open + +begin + pl = pl_open (NULL) + call pl_ssize (pl, naxes, axlen, depth) + + return (pl) +end diff --git a/sys/plio/pldbgout.x b/sys/plio/pldbgout.x new file mode 100644 index 00000000..26885f3e --- /dev/null +++ b/sys/plio/pldbgout.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# PL_DEBUGOUT -- Output formatter for PL package debug output. Output as +# many text items as will fit on a line, inserting one space between each +# text item. A call with BUF=EOS terminates the sequence with a newline. + +procedure pl_debugout (fd, buf, col, firstcol, maxcol) + +int fd #I output stream +char buf[ARB] #I text to be output +int col #I next column of output +int firstcol #I first column to write to +int maxcol #I last column to write to + +int nchars +int strlen() + +begin + nchars = min (maxcol-firstcol+1, strlen(buf)) + + if (nchars == 0) { + # Terminate the sequence with a newline. + call fprintf (fd, "\n") + col = 1 + return + + } else if (col + nchars > maxcol) { + # Break line and output token. + call fprintf (fd, "\n") + + for (col=1; col < firstcol; col=col+1) + call putci (fd, ' ') + + } else { + # Append to the current line. + if (col <= firstcol) { + for (; col < firstcol; col=col+1) + call putci (fd, ' ') + } else { + call putci (fd, ' ') + col = col + 1 + } + } + + call putline (fd, buf) + col = col + nchars +end diff --git a/sys/plio/pldebug.x b/sys/plio/pldebug.x new file mode 100644 index 00000000..67a719dc --- /dev/null +++ b/sys/plio/pldebug.x @@ -0,0 +1,218 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_DEBUG -- Print debug information for a mask. The information to be +# printed is selected by summing the following bitflags: +# +# PD_SUMMARY mask level summary information +# PD_INDEX print the line list index +# PD_LLOUT print the line lists, line list format +# PD_RLOUT print the line lists, range list format +# +# The mask is not modified in any way. All output is on the given stream, +# formatted to the page width given by the 'width' argument. + +procedure pl_debug (pl, fd, width, what) + +pointer pl #I mask descriptor +int fd #I output file +int width #I max width of formatted output, columns +int what #I flags defining what to print + +pointer sp, buf, rng, rl, pp +int line_1, line_2, nne, nv, v, lp, i +int naxes, axlen, nlp, firstcol, maxcol, col, rlen +errchk pl_valid, fprintf, pl_debugout, pll_prints, plr_printi +bool pl_empty() +int pl_l2ri() + +define index_ 91 +define lines_ 92 +define done_ 93 +define llout_ 94 + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + call salloc (rng, SZ_FNAME, TY_CHAR) + call salloc (rl, RL_MAXLEN(pl), TY_INT) + + call pl_valid (pl) + naxes = PL_NAXES(pl) + axlen = PL_AXLEN(pl,1) + nlp = PL_NLP(pl) + maxcol = width - 1 + + # Output the summary information. + # --------------------------------- + + if (and (what, PD_SUMMARY) == 0) + goto index_ + + # Line 1 of summary. + call fprintf (fd, "Mask %x naxes=%d [") + call pargi (pl) + call pargi (naxes) + do i = 1, naxes { + call fprintf (fd, "%d%c") + call pargi (PL_AXLEN(pl,i)) + if (i == naxes) + call pargi (']') + else + call pargi (',') + } + call fprintf (fd, " maxval=%o") + call pargi (PL_MAXVAL(pl)) + call fprintf (fd, " plane=[") + do i = 1, naxes { + call fprintf (fd, "%d%c") + call pargi (PL_AXLEN(pl,i)) + if (i == naxes) + call pargi (']') + else + call pargi (',') + } + call fprintf (fd, "\n") + + # Line 2 of summary. + call fprintf (fd, + "max buffered line size %d, max actual line size %d\n") + call pargi (PL_MAXLINE(pl)) + v = 0 + nne = 0 + do i = 1, nlp { + lp = PL_LP(pl,i) + nv = LP_LEN (Ref (pl, lp)) + if (nv > v) + v = nv + if (lp != PL_EMPTYLINE) + nne = nne + 1 + } + call pargi (v) + + # Line 3 of summary. + call fprintf (fd, "%d lines total, %d are nonempty, mask is %s\n") + call pargi (nlp) + call pargi (nne) + if (pl_empty (pl)) + call pargstr ("empty") + else + call pargstr ("nonempty") + + # Line 4 of summary. + call fprintf (fd, "llbp=%x, len=%d, op=%d, free=%d, nupdates=%d\n") + call pargi (PL_LLBP(pl)) + call pargi (PL_LLLEN(pl)) + call pargi (PL_LLOP(pl)) + call pargi (PL_LLFREE(pl)) + call pargi (PL_LLNUPDATES(pl)) + +index_ + # Print index. + # --------------------------------- + + if (and (what, PD_INDEX) == 0) + goto lines_ + + call fprintf (fd, "Index at %x containing %d lines:\n") + call pargi (PL_LPP(pl)) + call pargi (nlp) + col = 1 + firstcol = 1 + do i = 1, nlp { + lp = PL_LP(pl,i) + call sprintf (Memc[buf], SZ_LINE, "%6d") + call pargi (lp) + call pl_debugout (fd, Memc[buf], col, firstcol, maxcol) + } + call pl_debugout (fd, "", col, firstcol, maxcol) + +lines_ + # Print the line list. + # --------------------------------- + + if (and (what, PD_LLOUT+PD_RLOUT+PD_LHDR) == 0) + goto done_ + + call fprintf (fd, "Line list containing %d lines:\n") + call pargi (nlp) + + line_1 = 0 + do i = 1, nlp + 1 { + if (i > nlp && line_1 != 0) + goto llout_ + lp = PL_LP(pl,i) + + if (lp == PL_EMPTYLINE && line_1 == 0) { + # Skip over an empty line. + next + } else if (line_1 == 0) { + # Begin a new region. + line_1 = i + line_2 = i + if (i == nlp) + goto llout_ + } else if (lp == PL_LP(pl,line_1)) { + # Add line to current region. + line_2 = i + if (i == nlp) + goto llout_ + + } else { + # Output a region. +llout_ + lp = PL_LP(pl,line_1) + pp = Ref (pl, lp) + + if (line_1 == line_2) { + call sprintf (Memc[rng], SZ_FNAME, "[%d]") + call pargi (line_1) + } else { + call sprintf (Memc[rng], SZ_FNAME, "[%d:%d]") + call pargi (line_1) + call pargi (line_2) + } + + if (and (what, PD_LHDR) != 0) { + call sprintf (Memc[buf], SZ_LINE, + "%s%12tlp=%5d, nref=%d, blen=%d, len=%d") + call pargstr (Memc[rng]) + call pargi (lp) + call pargi (LP_NREF(pp)) + call pargi (LP_BLEN(pp)) + call pargi (LP_LEN(pp)) + } else + call strcpy (Memc[rng], Memc[buf], SZ_LINE) + + # Output the line list as a line list. + firstcol = 12 + if (and (what, PD_LLOUT) != 0) + call pll_prints (LL(pl,lp), fd, Memc[buf], firstcol, maxcol) + + # Output as a range list. + if (and (what, PD_RLOUT) != 0) { + rlen = pl_l2ri (LL(pl,lp), 1, Memi[rl], axlen) + call plr_printi (Memi[rl], fd, Memc[buf], firstcol, maxcol) + } + + if (and (what, PD_RLOUT+PD_LLOUT) == 0) { + col = 1; firstcol = 1 + call pl_debugout (fd, Memc[buf], col, firstcol, maxcol) + call pl_debugout (fd, "", col, firstcol, maxcol) + } + + if (PL_LP(pl,i) == PL_EMPTYLINE || line_2 == i) + line_1 = 0 + else { + line_1 = i + line_2 = i + } + } + } + +done_ + call flush (fd) + call sfree (sp) +end diff --git a/sys/plio/plempty.x b/sys/plio/plempty.x new file mode 100644 index 00000000..2dab29ed --- /dev/null +++ b/sys/plio/plempty.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PL_EMPTY -- Test whether a mask is empty, i.e., contains no nonzero pixels. + +bool procedure pl_empty (pl) + +pointer pl #I mask descriptor +int i + +begin + # Mask is empty if all lines are empty. + do i = 1, PL_NLP(pl) + if (PL_LP(pl,i) != PL_EMPTYLINE) + return (false) + + return (true) + + # The following also works, but the call to pl_compress is an + # unintended side effect which it is best to avoid. + + # call pl_compress (pl) + # return (PL_LLOP(pl) == LP_BLEN(Ref(pl,0))) +end diff --git a/sys/plio/plemptyline.x b/sys/plio/plemptyline.x new file mode 100644 index 00000000..4d4612cd --- /dev/null +++ b/sys/plio/plemptyline.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + + +# PL_EMPTYLINE -- Return a pointer to the empty line for a mask. + +pointer procedure pl_emptyline (pl) + +pointer pl #I mask descriptor + +begin + return (Ref (pl, PL_EMPTYLINE)) +end diff --git a/sys/plio/plglls.x b/sys/plio/plglls.x new file mode 100644 index 00000000..aaae0e42 --- /dev/null +++ b/sys/plio/plglls.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PL_GLLS -- Get a line segment as a list list, applying the given ROP to +# combine the pixels with those of the output line list. + +procedure pl_glls (pl, v, ll_dst, ll_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +short ll_dst[ARB] #O output line list +int ll_depth #I line list depth, bits +int npix #I number of pixels desired +int rop #I rasterop + +int ll_len +pointer sp, ll_out, ll_src +pointer pl_access() +errchk pl_access + +begin + ll_src = pl_access (pl,v) + if (!R_NEED_DST(rop) && v[1] == 1 && npix == PL_AXLEN(pl,1)) { + ll_len = LP_LEN(ll_src) + call amovs (Mems[ll_src], ll_dst, ll_len) + + } else { + call smark (sp) + call salloc (ll_out, LL_MAXLEN(pl), TY_SHORT) + + call pl_linerop (Mems[ll_src], v[1], PL_MAXVAL(pl), ll_dst, 1, + MV(ll_depth), Mems[ll_out], npix, rop) + ll_len = LP_LEN(ll_out) + call amovs (Mems[ll_out], ll_dst, ll_len) + + call sfree (sp) + } +end diff --git a/sys/plio/plglp.gx b/sys/plio/plglp.gx new file mode 100644 index 00000000..d5803033 --- /dev/null +++ b/sys/plio/plglp.gx @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PL_GLP -- Get a line segment as a pixel array, applying the given ROP to +# combine the pixels with those of the output array. + +procedure pl_glp$t (pl, v, px_dst, px_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +PIXEL px_dst[ARB] #O output pixel array +int px_depth #I pixel depth, bits +int npix #I number of pixels desired +int rop #I rasterop + +int np +pointer sp, px_out, ll_src +pointer pl_access() +int pl_l2p$t() +errchk pl_access + +begin + ll_src = pl_access (pl,v) + if (!R_NEED_DST(rop)) { + np = pl_l2p$t (Mems[ll_src], v[1], px_dst, npix) + return + } + + call smark (sp) + call salloc (px_out, npix, TY_PIXEL) + + np = pl_l2p$t (Mems[ll_src], v[1], Mem$t[px_out], npix) + call pl_pixrop$t (Mem$t[px_out], 1, PL_MAXVAL(pl), + px_dst, 1, MV(px_depth), npix, rop) + + call sfree (sp) +end diff --git a/sys/plio/plglr.gx b/sys/plio/plglr.gx new file mode 100644 index 00000000..3a63346d --- /dev/null +++ b/sys/plio/plglr.gx @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_GLR -- Get a line segment as a range list, applying the given ROP to +# combine the pixels with those of the output list. + +procedure pl_glr$t (pl, v, rl_dst, rl_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +PIXEL rl_dst[ARB] #O output range list +int rl_depth #I range list depth, bits +int npix #I number of pixels desired +int rop #I rasterop + +int mr, nr +pointer sp, rl_out, rl_src, ll_src +pointer pl_access() +int pl_l2r$t() +errchk pl_access + +begin + ll_src = pl_access (pl,v) + if (!R_NEED_DST(rop)) + nr = pl_l2r$t (Mems[ll_src], v[1], rl_dst, npix) + else { + call smark (sp) + mr = min (RL_MAXLEN(pl), npix * 3) + call salloc (rl_src, mr, TY_PIXEL) + call salloc (rl_out, mr, TY_PIXEL) + + nr = pl_l2r$t (Mems[ll_src], v[1], Mem$t[rl_src], npix) + call pl_rangerop$t (Mem$t[rl_src], 1, PL_MAXVAL(pl), + rl_dst, 1, MV(rl_depth), + Mem$t[rl_out], npix, rop) + + # Copy out the edited range list. + call amov$t (Mem$t[rl_out], rl_dst, RL$T_LEN(rl_out)) + + call sfree (sp) + } +end diff --git a/sys/plio/plgplane.x b/sys/plio/plgplane.x new file mode 100644 index 00000000..3f338178 --- /dev/null +++ b/sys/plio/plgplane.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PL_GETPLANE -- Get the 2-Dim plane to be referenced in calls to the pl_box, +# pl_circle, etc. geometric region masking operators. + +procedure pl_getplane (pl, v) + +pointer pl #I mask descriptor +long v[ARB] #O vector defining plane + +begin + call amovl (PL_PLANE(pl,1), v, PL_MAXDIM) +end diff --git a/sys/plio/plgsize.x b/sys/plio/plgsize.x new file mode 100644 index 00000000..40e73ac3 --- /dev/null +++ b/sys/plio/plgsize.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_GSIZE -- Get the dimensionality and size of a mask. + +procedure pl_gsize (pl, naxes, axlen, depth) + +pointer pl #I mask descriptor +int naxes #O number of axes (dimensionality of mask) +long axlen[ARB] #O length of each axis +int depth #O mask depth, bits + +int i + +begin + naxes = PL_NAXES(pl) + call amovl (PL_AXLEN(pl,1), axlen, PL_MAXDIM) + + do i = 0, ARB + if (2**i > min (I_PVMAX, PL_MAXVAL(pl))) { + depth = i + break + } +end diff --git a/sys/plio/pll2p.gx b/sys/plio/pll2p.gx new file mode 100644 index 00000000..007af7a0 --- /dev/null +++ b/sys/plio/pll2p.gx @@ -0,0 +1,105 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PL_L2P -- Convert a line list to a pixel array. The number of pixels output +# (always npix) is returned as the function value. + +int procedure pl_l2p$t (ll_src, xs, px_dst, npix) + +short ll_src[ARB] #I input line list +int xs #I starting index in ll_src +PIXEL px_dst[ARB] #O output pixel array +int npix #I number of pixels to convert + +PIXEL pv +bool skipword +int opcode, data, ll_len, ll_first +int x1, x2, i1, i2, xe, np, ip, op, otop, i +define putpix_ 91 + +begin + # Support old format line lists. + if (LL_OLDFORMAT(ll_src)) { + ll_len = OLL_LEN(ll_src) + ll_first = OLL_FIRST + } else { + ll_len = LL_LEN(ll_src) + ll_first = LL_FIRST(ll_src) + } + + # No pixels? + if (npix <= 0 || ll_len <= 0) + return (0) + + xe = xs + npix - 1 + skipword = false + op = 1 + x1 = 1 + pv = 1 + + do ip = ll_first, ll_len { + if (skipword) { + skipword = false + next + } + + opcode = I_OPCODE(ll_src[ip]) + data = I_DATA(ll_src[ip]) + + switch (opcode) { + case I_ZN, I_HN, I_PN: + # Determine inbounds region of segment. + x2 = x1 + data - 1 + i1 = max (x1, xs) + i2 = min (x2, xe) + + # Process segment if any region is inbounds. + np = i2 - i1 + 1 + if (np > 0) { + otop = op + np - 1 + if (opcode == I_HN) { + do i = op, otop + px_dst[i] = pv + } else { + do i = op, otop + px_dst[i] = 0 + if (opcode == I_PN && i2 == x2) + px_dst[otop] = pv + } + op = otop + 1 + } + + # Advance the line index. + x1 = x2 + 1 + + case I_SH: + pv = (int(ll_src[ip+1]) * I_SHIFT) + data + skipword = true + case I_IH: + pv = pv + data + case I_DH: + pv = pv - data + case I_IS: + pv = pv + data + goto putpix_ + case I_DS: + pv = pv - data +putpix_ + if (x1 >= xs && x1 <= xe) { + px_dst[op] = pv + op = op + 1 + } + x1 = x1 + 1 + } + + if (x1 > xe) + break + } + + # Zero any remaining output range. + do i = op, npix + px_dst[i] = 0 + + return (npix) +end diff --git a/sys/plio/pll2r.gx b/sys/plio/pll2r.gx new file mode 100644 index 00000000..ae6a6fcf --- /dev/null +++ b/sys/plio/pll2r.gx @@ -0,0 +1,117 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_L2R -- Convert a line list to a range list. The length of the output +# range list is returned as the function value. + +int procedure pl_l2r$t (ll_src, xs, rl, npix) + +short ll_src[ARB] #I input line list +int xs #I starting index in ll_src +PIXEL rl[3,ARB] #O output range list +int npix #I number of pixels to convert + +int pv, hi +bool skipword +int opcode, data, ll_len, ll_first +int x1, x2, i1, i2, xe, np, rn, ip +define range_ 91 +define putrange_ 92 + +begin + # Support old format line lists. + if (LL_OLDFORMAT(ll_src)) { + ll_len = OLL_LEN(ll_src) + ll_first = OLL_FIRST + } else { + ll_len = LL_LEN(ll_src) + ll_first = LL_FIRST(ll_src) + } + + # No pixels? + if (npix <= 0 || ll_len <= 0) + return (0) + + rn = RL_FIRST + xe = xs + npix - 1 + skipword = false + x1 = 1 + hi = 1 + + do ip = ll_first, ll_len { + if (skipword) { + skipword = false + next + } + + opcode = I_OPCODE(ll_src[ip]) + data = I_DATA(ll_src[ip]) + + switch (opcode) { + case I_ZN: + pv = 0 + goto range_ + case I_HN: + pv = hi +range_ + # Determine inbounds region of segment. + x2 = x1 + data - 1 + i1 = max (x1, xs) + i2 = min (x2, xe) + np = i2 - i1 + 1 + x1 = x2 + 1 + + case I_PN: + pv = hi + x2 = x1 + data - 1 + if (x2 < xs || x2 > xe) + np = 0 + else { + i1 = x2 + np = 1 + } + x1 = x2 + 1 + + case I_SH: + hi = (int(ll_src[ip+1]) * I_SHIFT) + data + skipword = true + next + case I_IH: + hi = hi + data + next + case I_DH: + hi = hi - data + next + + case I_IS, I_DS: + if (opcode == I_IS) + hi = hi + data + else + hi = hi - data + + i1 = max (x1, xs) + i2 = min (x1, xe) + np = i2 - i1 + 1 + x1 = x1 + 1 + pv = hi + } + + # Output a range entry? + if (np > 0 && pv > 0) { + rl[1,rn] = i1 + rl[2,rn] = np + rl[3,rn] = pv + rn = rn + 1 + } + + if (x1 > xe) + break + } + + RL_LEN(rl) = rn - 1 + RL_AXLEN(rl) = npix + + return (rn - 1) +end diff --git a/sys/plio/pllen.x b/sys/plio/pllen.x new file mode 100644 index 00000000..a09b3770 --- /dev/null +++ b/sys/plio/pllen.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + + +# PL_LLEN -- Return the length of an encoded line list. + +int procedure pl_llen (ll) + +short ll[ARB] #I encoded line list + +begin + return (LL_LEN(ll)) +end diff --git a/sys/plio/plleq.x b/sys/plio/plleq.x new file mode 100644 index 00000000..d74ae370 --- /dev/null +++ b/sys/plio/plleq.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PLL_EQUAL -- Compare two line lists for equality. + +bool procedure pll_equal (l1, l2) + +short l1[ARB] #I line list 1 +short l2[ARB] #I line list 2 + +int i, off +int l1_len, l1_first +int l2_len, l2_first + +begin + # Support old format line lists. + if (LL_OLDFORMAT(l1)) { + l1_len = OLL_LEN(l1) + l1_first = OLL_FIRST + } else { + l1_len = LL_LEN(l1) + l1_first = LL_FIRST(l1) + } + + # Support old format line lists. + if (LL_OLDFORMAT(l2)) { + l2_len = OLL_LEN(l2) + l2_first = OLL_FIRST + } else { + l2_len = LL_LEN(l2) + l2_first = LL_FIRST(l2) + } + + if (l1_len != l2_len) + return (false) + + off = l2_first - l1_first + do i = l1_first, l1_len + if (l1[i] != l2[i+off]) + return (false) + + return (true) +end diff --git a/sys/plio/plline.x b/sys/plio/plline.x new file mode 100644 index 00000000..54caf253 --- /dev/null +++ b/sys/plio/plline.x @@ -0,0 +1,66 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# PL_LINE -- Perform a rasterop operation upon a line of arbitrary width drawn +# at an arbitrary orientation in a 2-dimensional plane of a mask. If the +# dimensionality of the mask exceeds 2, the pl_setplane() procedure should be +# called first to define the plane of the mask to be modified. + +procedure pl_line (pl, x1, y1, x2, y2, width, rop) + +pointer pl #I mask descriptor +int x1,y1 #I start point of line +int x2,y2 #I end point of line +int width #I width of line to be drawn, pixels +int rop #I rasterop defining operation + +int npts +int x[4], y[4] +real theta, hwidth, dx, dy + +begin + dx = x2 - x1 + dy = y2 - y1 + + # Compute the line direction and halfwidth. + hwidth = max (1.0, real(width)) / 2.0 - 0.001 + if (abs(dx) < 0.0001) { + if (dy > 0) + theta = HALFPI + else + theta = -HALFPI + } else if (abs(dy) < 0.0001) { + if (dx > 0) + theta = 0.0 + else + theta = PI + } else + theta = atan2 (dy, dx) + + # Construct a polyline to be filled to draw the line. + if (width < 1.0001) { + x[1] = x1; y[1] = y1 + x[2] = x2; y[2] = y2 + npts = 2 + + } else { + x[1] = x1 + nint (hwidth * cos(theta+HALFPI)) + y[1] = y1 + nint (hwidth * sin(theta+HALFPI)) + + x[2] = x1 + nint (hwidth * cos(theta-HALFPI)) + y[2] = y1 + nint (hwidth * sin(theta-HALFPI)) + + x[3] = x2 + nint (hwidth * cos(theta-HALFPI)) + y[3] = y2 + nint (hwidth * sin(theta-HALFPI)) + + x[4] = x2 + nint (hwidth * cos(theta+HALFPI)) + y[4] = y2 + nint (hwidth * sin(theta+HALFPI)) + npts = 4 + } + + # Draw the line. + call pl_polygon (pl, x, y, npts, rop) +end diff --git a/sys/plio/pllinene.x b/sys/plio/pllinene.x new file mode 100644 index 00000000..3babc889 --- /dev/null +++ b/sys/plio/pllinene.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_LINENOTEMPTY -- Test whether the indicated mask image line is empty. + +bool procedure pl_linenotempty (pl, v) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I coordinates of desired line + +int pl_reference() + +begin + return (pl_reference(pl,v) != PL_EMPTYLINE) +end diff --git a/sys/plio/pllnext.x b/sys/plio/pllnext.x new file mode 100644 index 00000000..43d87c01 --- /dev/null +++ b/sys/plio/pllnext.x @@ -0,0 +1,61 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "pllseg.h" + +# PLL_NEXTSEG -- Internal routine called by the PLLSEG.H routines to get the +# next segment of a line list. + +procedure pll_nextseg (ll, ld) + +short ll[ARB] #I input line list +int ld[LEN_PLLDES] #I list list i/o descriptor + +int ip +int opcode, data + +begin + for (ip = ld_ip(ld); ip <= LL_LEN(ll); ip = ld_ip(ld)) { + ld_ip(ld) = ip + 1 + opcode = I_OPCODE(ll[ip]) + data = I_DATA(ll[ip]) + + switch (opcode) { + case I_ZN: + ld_nleft(ld) = data + ld_value(ld) = 0 + return + case I_HN: + ld_nleft(ld) = data + ld_value(ld) = ld_hi(ld) + return + case I_PN: + ld_nleft(ld) = data - 1 + ld_value(ld) = 0 + ld_next_nleft(ld) = 1 + ld_next_value(ld) = ld_hi(ld) + return + + case I_SH: + ip = ip + 1 + ld_ip(ld) = ip + 1 + ld_hi(ld) = (int(ll[ip]) * I_SHIFT) + data + case I_IH: + ld_hi(ld) = ld_hi(ld) + data + case I_DH: + ld_hi(ld) = ld_hi(ld) - data + + case I_IS, I_DS: + if (opcode == I_IS) + ld_hi(ld) = ld_hi(ld) + data + else + ld_hi(ld) = ld_hi(ld) - data + + ld_nleft(ld) = 1 + ld_value(ld) = ld_hi(ld) + return + } + } + + ld_value(ld) = 0 +end diff --git a/sys/plio/plload.x b/sys/plio/plload.x new file mode 100644 index 00000000..d67fc595 --- /dev/null +++ b/sys/plio/plload.x @@ -0,0 +1,83 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# PL_LOAD -- Load a mask from a buffer encoded in a machine independent format +# in a previous call to PL_SAVE. The given mask descriptor may be either +# inactive or active. In the case of a load into an active mask, the existing +# mask is clobbered, and the mask may change size. + +procedure pl_load (pl, bp) + +pointer pl #I mask descriptor +pointer bp #I buffer pointer (to short) + +pointer sp, index, ex, ip +int o_lllen, o_nlp, sz_index, flags, nlp, i +errchk malloc, realloc, syserr +int pl_l2pi() +pointer coerce() + +begin + call smark (sp) + call salloc (ex, LEN_PLEXTERN, TY_STRUCT) + + o_lllen = PL_LLLEN(pl) + o_nlp = PL_NLP(pl) + + # Decode the external format header structure, a fixed size structure + # stored in 32 bit MII integer format. + + call miiupk32 (Memi[coerce(bp,TY_SHORT,TY_INT)], Memi[ex], + LEN_PLEXTERN, TY_STRUCT) + if (PLE_MAGIC(ex) != PL_MAGICVAL) + call syserr (SYS_PLBADSAVEF) + + call amovi (PLE_AXLEN(ex,1), PL_AXLEN(pl,1), PL_MAXDIM) + PL_MAGIC(pl) = PLE_MAGIC(ex) + PL_NAXES(pl) = PLE_NAXES(ex) + PL_LLOP(pl) = PLE_LLOP(ex) + PL_LLLEN(pl) = PLE_LLLEN(ex) + PL_MAXLINE(pl) = PLE_MAXLINE(ex) + PL_MAXVAL(pl) = PLE_MAXVAL(ex) + PL_NLP(pl) = PLE_NLP(ex) + sz_index = PLE_NLPX(ex) + flags = PLE_FLAGS(ex) + + # Get the (compressed) line index. If the descriptor is already active + # the new mask may be a different size than the old one. + + nlp = 1 + do i = 2, PL_NAXES(pl) + nlp = nlp * PL_AXLEN(pl,i) + if (PL_LPP(pl) == NULL) + call malloc (PL_LPP(pl), nlp, TY_INT) + else if (nlp != o_nlp) + call realloc (PL_LPP(pl), nlp, TY_INT) + + call salloc (index, sz_index, TY_SHORT) + #ip = bp + (LEN_PLEXTERN * SZ_STRUCT) / SZ_SHORT + ip = bp + (LEN_PLEXTERN * SZ_MII_INT) / SZ_SHORT + call miiupk16 (Mems[ip], Mems[index], sz_index, TY_SHORT) + PL_NLP(pl) = pl_l2pi (Mems[index], 1, PL_LP(pl,1), nlp) + + # Allocate or resize the line list buffer. + if (PL_LLBP(pl) == NULL) + call malloc (PL_LLBP(pl), PL_LLLEN(pl), TY_SHORT) + else if (PL_LLLEN(pl) != o_lllen) + call realloc (PL_LLBP(pl), PL_LLLEN(pl), TY_SHORT) + + # Read the stored line list. + ip = ip + sz_index + call miiupk16 (Mems[ip], LL(pl,0), PL_LLLEN(pl), TY_SHORT) + + # Update the remaining fields of the mask descriptor. + PL_LLFREE(pl) = 0 + PL_LLNUPDATES(pl) = 0 + PL_LLINC(pl) = PL_STARTINC + call amovki (1, PL_PLANE(pl,1), PL_MAXDIM) + + call sfree (sp) +end diff --git a/sys/plio/plloadf.x b/sys/plio/plloadf.x new file mode 100644 index 00000000..978086b8 --- /dev/null +++ b/sys/plio/plloadf.x @@ -0,0 +1,67 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# PL_LOADF -- Load a mask stored in external format in a binary file. This +# simple code permits only one mask per file; more sophisticated storage +# facilities are planned; these will probably obsolete this routine. + +procedure pl_loadf (pl, mask, title, maxch) + +pointer pl #I mask descriptor +char mask[ARB] #I mask file +char title[maxch] #O mask title +int maxch #I max chars out + +int fd, nchars +pointer sp, bp, sv, text, fname, extn +int open(), read(), miireadc(), miireadi(), fnextn() +errchk open, read, syserrs +define err_ 91 + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (extn, SZ_FNAME, TY_CHAR) + + # Get mask file name. + call strcpy (mask, Memc[fname], SZ_PATHNAME) + if (fnextn (mask, Memc[extn], SZ_FNAME) <= 0) + call strcat (".pl", Memc[fname], SZ_PATHNAME) + + # Open the mask save file. + fd = open (Memc[fname], READ_ONLY, BINARY_FILE) + + # Get savefile header. + call salloc (sv, LEN_SVDES, TY_STRUCT) + if (miireadi (fd, Memi[sv], LEN_SVDES) != LEN_SVDES) + goto err_ + + # Verify file type. + if (SV_MAGIC(sv) != PLIO_SVMAGIC) + goto err_ + + # Get descriptive text. + call salloc (text, SV_TITLELEN(sv), TY_CHAR) + if (miireadc (fd, Memc[text], SV_TITLELEN(sv)) != SV_TITLELEN(sv)) + goto err_ + else + call strcpy (Memc[text], title, maxch) + + # Get encoded mask. + call salloc (bp, SV_MASKLEN(sv), TY_SHORT) + iferr (nchars = read (fd, Mems[bp], SV_MASKLEN(sv) * SZ_SHORT)) + goto err_ + call close (fd) + + iferr (call pl_load (pl, bp)) + goto err_ + + call sfree (sp) + return +err_ + call close (fd) + call syserrs (SYS_PLBADSAVEF, Memc[fname]) +end diff --git a/sys/plio/plloadim.x b/sys/plio/plloadim.x new file mode 100644 index 00000000..6fc45adc --- /dev/null +++ b/sys/plio/plloadim.x @@ -0,0 +1,99 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# PL_LOADIM -- Load a mask stored as a conventional image, i.e., convert an +# image to a mask. + +procedure pl_loadim (pl, imname, title, maxch) + +pointer pl #I mask descriptor +char imname[ARB] #I image name or section +char title[ARB] #O mask title +int maxch #I max chars out + +bool sampling +pointer im, px, im_pl, bp +long vs_l[PL_MAXDIM], vs_p[PL_MAXDIM] +long ve_l[PL_MAXDIM], ve_p[PL_MAXDIM] +int npix, naxes, maxdim, maxval, depth, sz_buf, i +long v_in[PL_MAXDIM], v_out[PL_MAXDIM], vn[PL_MAXDIM] + +pointer immap() +int imgnli(), imstati(), im_pmsvhdr() +errchk immap, imgnli + +begin + # Open the input image. + im = immap (imname, READ_ONLY, 0) + + # Encode and output the image header. + bp = NULL; i = im_pmsvhdr (im, bp, sz_buf) + call strcpy (Memc[bp], title, maxch) + call mfree (bp, TY_CHAR) + + # Determine the mask depth in bits. + maxval = IM_MAX(im) + if (maxval <= 0) + maxval = I_PVMAX + do i = 0, ARB + if (2**i > min (I_PVMAX, maxval)) { + depth = i + break + } + + # Initialize the mask to the size of the image section. + npix = IM_LEN(im,1) + naxes = IM_NDIM(im) + maxdim = min (IM_MAXDIM, PL_MAXDIM) + call amovl (IM_LEN(im,1), vn, maxdim) + call pl_ssize (pl, naxes, vn, depth) + + # If the image is already a mask internally, check whether any + # subsampling, axis flipping, or axis mapping is in effect. + # If so we can't use PLIO to copy the mask section. + + im_pl = imstati (im, IM_PLDES) + sampling = false + + if (im_pl != NULL) { + call amovkl (long(1), vs_l, maxdim) + call amovl (IM_LEN(im,1), ve_l, maxdim) + call imaplv (im, vs_l, vs_p, maxdim) + call imaplv (im, ve_l, ve_p, maxdim) + + do i = 1, maxdim { + vn[i] = ve_l[i] - vs_l[i] + 1 + if (vn[i] != ve_p[i] - vs_p[i] + 1) { + sampling = true + break + } + } + } + + # If the source image is already a mask internally and no axis + # geometry is in effect in the image section (if any), then we can + # use a PLIO rasterop to efficiently copy the mask subsection. + + if (im_pl != NULL && !sampling) { + # Copy a mask subsection (or entire image if no section). + call pl_rop (im_pl, vs_p, pl, vs_l, vn, PIX_SRC) + + } else { + # Copy image pixels. Initialize the vector loop indices. + call amovkl (long(1), v_in, maxdim) + call amovkl (long(1), v_out, maxdim) + + # Copy the image. + while (imgnli (im, px, v_in) != EOF) { + call pl_plpi (pl, v_out, Memi[px], 0, npix, PIX_SRC) + call amovl (v_in, v_out, maxdim) + } + } + + call pl_compress (pl) + call imunmap (im) +end diff --git a/sys/plio/plloop.x b/sys/plio/plloop.x new file mode 100644 index 00000000..500dc8bb --- /dev/null +++ b/sys/plio/plloop.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PLLOOP -- Increment the vector V from VS to VE (nested do loops cannot +# be used because of the variable number of dimensions). Return LOOP_DONE +# when V exceeds VE. + +int procedure plloop (v, vs, ve, ndim) + +long v[ndim] #U vector giving current position in image +long vs[ndim] #I start vector +long ve[ndim] #I end vector +int ndim #I vector length + +int i + +begin + do i = 2, ndim { + v[i] = v[i] + 1 + if (v[i] > ve[i]) { + if (i < ndim) + v[i] = vs[i] + else + break + } else + return (LOOP_AGAIN) + } + + return (LOOP_DONE) +end diff --git a/sys/plio/pllpr.x b/sys/plio/pllpr.x new file mode 100644 index 00000000..9a8d1684 --- /dev/null +++ b/sys/plio/pllpr.x @@ -0,0 +1,111 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PLL_PRINTS -- Print a line list on the given output stream. + +procedure pll_prints (ll, fd, label, firstcol, maxcols) + +short ll[ARB] #I line list +int fd #I output file +char label[ARB] #I line label +int firstcol #I first column for output +int maxcols #I width of formatted output + +pointer sp, buf +bool skipword +int opcode, data +int ll_len, ll_first, col, ip, pv, x +int strlen() + +begin + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + + # Support old format line lists. + if (LL_OLDFORMAT(ll)) { + ll_len = OLL_LEN(ll) + ll_first = OLL_FIRST + } else { + ll_len = LL_LEN(ll) + ll_first = LL_FIRST(ll) + } + + # Output the line label and advance to the first column. If the label + # extends beyond the first column, start a new line. + + call putline (fd, label) + col = strlen (label) + 1 + if (col > firstcol) + call pl_debugout (fd, "", col, firstcol, maxcols) + + skipword = false + pv = 1 + x = 1 + + # Decode the line list proper. + do ip = ll_first, ll_len { + if (skipword) { + skipword = false + next + } + + opcode = I_OPCODE(ll[ip]) + data = I_DATA(ll[ip]) + + switch (opcode) { + case I_ZN: + x = x + data + call sprintf (Memc[buf], SZ_FNAME, "Z%d") + call pargi (data) + case I_HN: + x = x + data + call sprintf (Memc[buf], SZ_FNAME, "H%d") + call pargi (data) + case I_PN: + x = x + data + call sprintf (Memc[buf], SZ_FNAME, "P%d") + call pargi (data) + + case I_SH: + pv = (int(ll[ip+1]) * I_SHIFT) + data + skipword = true + call sprintf (Memc[buf], SZ_FNAME, "SH(%d)") + call pargi (pv) + case I_IH: + pv = pv + data + call sprintf (Memc[buf], SZ_FNAME, "IH%d(%d)") + call pargi (data) + call pargi (pv) + case I_DH: + pv = pv - data + call sprintf (Memc[buf], SZ_FNAME, "DH%d(%d)") + call pargi (data) + call pargi (pv) + + case I_IS, I_DS: + x = x + 1 + if (opcode == I_IS) { + pv = pv + data + call sprintf (Memc[buf], SZ_FNAME, "IS%d(%d)") + call pargi (data) + call pargi (pv) + } else { + pv = pv - data + call sprintf (Memc[buf], SZ_FNAME, "DS%d(%d)") + call pargi (data) + call pargi (pv) + } + } + + call pl_debugout (fd, Memc[buf], col, firstcol, maxcols) + } + + call sprintf (Memc[buf], SZ_FNAME, "(%d,%d)") + call pargi (x - 1) + call pargi (pv) + call pl_debugout (fd, Memc[buf], col, firstcol, maxcols) + + call pl_debugout (fd, "", col, firstcol, maxcols) + call sfree (sp) +end diff --git a/sys/plio/pllrop.x b/sys/plio/pllrop.x new file mode 100644 index 00000000..2f5f1358 --- /dev/null +++ b/sys/plio/pllrop.x @@ -0,0 +1,271 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "pllseg.h" +include + +# PL_LINEROP -- Rasterop operation between source and destination line lists. +# The indicated rasterop operation is performed upon the source and destination +# line lists, writing the result to LL_OUT, which is a copy of LL_DST except +# for the region affected by the rasterop operation (note that the destination +# line list cannot be edited in place since it may change size). + +procedure pl_linerop (ll_src, xs, src_maxval, + ll_dst, ds, dst_maxval, ll_out, npix, rop) + +short ll_src[ARB] #I source line list +int xs #I starting pixel index in src line list +int src_maxval #I maximum pixel value, source mask +short ll_dst[ARB] #I destination line list +int ds #I starting pixel index in dst line list +int dst_maxval #I maximum pixel value, dst mask +short ll_out[ARB] #O output list (edited version of ll_dst) +int npix #I number of pixels to convert +int rop #I rasterop + +int segsize, v_src, v_dst, pv +bool need_src, need_dst, rop_enable +int o_op, o_iz, o_pv, o_np, o_hi, src_value +int opcode, data, nz, iz, x1, hi, dv, v, np, op, n, i +int d_src[LEN_PLLDES], d_dst[LEN_PLLDES] +define done_ 91 + +begin + need_src = R_NEED_SRC(rop) + need_dst = R_NEED_DST(rop) + opcode = R_OPCODE(rop) + data = R_DATA(rop) + + # Pixel value to be used if input mask is boolean. + if (src_maxval == 1) { + src_value = data + if (src_value <= 0) + src_value = dst_maxval + } + + # Advance to the desired position in the source list, discarding + # the instructions once read. The point XS may lie within the range + # of an instruction. + + if (need_src) { + x1 = 1 + pll_init (ll_src, d_src) + do i = 1, ARB { + np = min (pll_nleft(d_src), xs - x1) + pll_getseg (ll_src, d_src, np, v_src) + x1 = x1 + np + if (x1 >= xs || np == 0) + break + } + } + + # Copy DST to OUT, applying the rasterop in the region of NPIX pixels + # beginning at DS. To simplify things (avoid pathological complexity + # in this case) we suffer some unnecessary unpacking and repacking + # of encoded line list instructions in the regions of the DST list + # which are simply copied. This avoids the need for special treatment + # at the edges of the region to which the ROP applies. ROP_ENABLE is + # false initially, true in the ROP region, and false again to the + # right. The number of pixels in each region is given by SEGSIZE. + + o_pv = -1 + op = LL_CURHDRLEN + 1 + segsize = ds - 1 + rop_enable = false + x1 = 1; iz = 1; hi = 1 + pll_init (ll_dst, d_dst) + + do i = 1, ARB { + # Set up for the next segment (before, in, and after the region to + # which the ROP applies), when the current segment is exhausted. + + if (segsize <= 0) + if (!rop_enable) { + # Begin processing central region. + segsize = npix + rop_enable = true + if (segsize <= 0) + next + } else { + # Begin processing final region. + segsize = ARB + rop_enable = false + } + + # Determine the length of the next output segment. This is the + # largest segment of constant value formed by the intersection of + # the two lists. If bounds checking has been properly performed + # then it should not be possible to see nleft=zero on either input + # list. Note that zeroed regions are valid data here. + + np = min (segsize, pll_nleft(d_dst)) + if (need_src && rop_enable && pll_nleft(d_src) > 0) + np = min (np, pll_nleft(d_src)) + if (np <= 0) + break + + # Get the segment value and advance the line pointers. We always + # have to read the DST list in order to copy the unmodified regions + # to the output. We read the SRC list and apply the rasterop only + # in the region to which the ROP applies. + + pll_getseg (ll_dst, d_dst, np, v_dst) + if (rop_enable) { + # Get v_src. + if (need_src) { + v_src = 0 + if (pll_nleft (d_src) > 0) + pll_getseg (ll_src, d_src, np, v_src) + + if (R_NOTSRC(rop)) { + v_src = not (v_src) + if (src_maxval != 0) + v_src = and (v_src, src_maxval) + } + + if (v_src != 0 && src_maxval == 1) + v_src = src_value + } + + # Get v_dst. + if (need_dst) { + if (R_NOTDST(rop)) { + v_dst = not (v_dst) + if (dst_maxval != 0) + v_dst = and (v_dst, dst_maxval) + } + } + + # Apply the rasterop. + switch (opcode) { + case PIX_CLR: + pv = 0 + case PIX_SET: + pv = data + case PIX_SRC, PIX_NOTSRC: + pv = v_src + case PIX_DST, PIX_NOTDST: + pv = v_dst + case PIX_SRC_AND_DST, PIX_SRC_AND_NOTDST, PIX_NOTSRC_AND_DST: + pv = and (v_src, v_dst) + case PIX_SRC_OR_DST, PIX_SRC_OR_NOTDST, PIX_NOTSRC_OR_DST: + pv = or (v_src, v_dst) + case PIX_SRC_XOR_DST: + pv = xor (v_src, v_dst) + case PIX_NOT_SRC_AND_DST: + pv = not (and (v_src, v_dst)) + case PIX_NOT_SRC_OR_DST: + pv = not (or (v_src, v_dst)) + case PIX_NOT_SRC_XOR_DST: + pv = not (xor (v_src, v_dst)) + } + + # Mask the high bits to prevent negative values, or map int + # to bool for the case of a boolean output mask. + + if (dst_maxval == 1 && pv != 0) + pv = 1 + else if (dst_maxval > 1) + pv = and (dst_maxval, pv) + + } else + pv = v_dst + + + if (pv == 0) { + if (pll_nleft (d_dst) <= 0) { + # Output zeros at end of list. + x1 = x1 + np + } else { + # Keep going until we get a nonzero range. + o_pv = 0 + x1 = x1 + np + segsize = segsize - np + next + } + } else if (pv == o_pv) { + # Combine with previous range. + iz = o_iz + hi = o_hi + op = o_op + x1 = x1 - o_np + segsize = segsize + o_np + np = np + o_np + o_np = np + } else { + # Save current range parameters. + o_op = op + o_np = np + o_iz = iz + o_hi = hi + o_pv = pv + } + + # Encode an instruction to regenerate the current range of NP data + # values of nonzero level PV, starting at X1. In the most complex + # case we must update the high value and output a range of zeros, + # followed by a range of NP high values. If NP is 1, we can + # probably use a PN or [ID]S instruction to save space. + + nz = x1 - iz + + # Change the high value? + if (pv > 0) { + dv = pv - hi + if (dv != 0) { + # Output IH or DH instruction? + hi = pv + if (abs(dv) > I_DATAMAX) { + ll_out[op] = M_SH + and (pv, I_DATAMAX) + op = op + 1 + ll_out[op] = pv / I_SHIFT + op = op + 1 + } else { + if (dv < 0) + ll_out[op] = M_DH + (-dv) + else + ll_out[op] = M_IH + dv + op = op + 1 + + # Convert to IS or DS if range is a single pixel. + if (np == 1 && nz == 0) { + v = ll_out[op-1] + ll_out[op-1] = or (v, M_MOVE) + goto done_ + } + } + } + } + + # Output range of zeros to catch up to current range? + if (nz > 0) { + # Output the ZN instruction. + for (n=nz; n > 0; n = n - I_DATAMAX) { + ll_out[op] = M_ZN + min(I_DATAMAX,n) + op = op + 1 + } + # Convert to PN if range is a single pixel. + if (np == 1 && pv > 0) { + ll_out[op-1] = ll_out[op-1] + M_PN + 1 + goto done_ + } + # At end of list. + if (pv == 0) + goto done_ + } + + # The only thing left is the HN instruction if we get here. + for (n=np; n > 0; n = n - I_DATAMAX) { + ll_out[op] = M_HN + min(I_DATAMAX,n) + op = op + 1 + } +done_ + segsize = segsize - np + x1 = x1 + np + iz = x1 + } + + # Update the line list header. + call amovs (ll_dst, ll_out, LL_CURHDRLEN) + LL_SETLEN(ll_out, op - 1) +end diff --git a/sys/plio/pllseg.h b/sys/plio/pllseg.h new file mode 100644 index 00000000..2f358944 --- /dev/null +++ b/sys/plio/pllseg.h @@ -0,0 +1,56 @@ +# PLLSEG.H -- Macros for sequentially reading segments of a line list. +# +# pll_init (ll, descriptor) +# npix = pll_nleft (descriptor) +# val = pll_getseg (ll, descriptor, npix, value) +# +# pll_init Initialize descriptor for sequential i/o from the linelist LL. +# pll_nleft Number of pixels left in the current line segment of constant +# value. Zero is returned at the EOL. +# pll_getseg Read NPIX pixels from the current segment, advancing to the +# next segment automatically when the the current segment is +# exhausted. +# +# The descriptor is an integer array, the contents of which are hidden from +# the application using these macros. This package uses the internal +# procedure PLL_NEXTSEG, which is included in PL package library. + +# Range list i/o descriptor. +define LEN_PLLDES 7 +define ld_nleft $1[1] +define ld_value $1[2] +define ld_x $1[3] +define ld_ip $1[4] +define ld_hi $1[5] +define ld_next_nleft $1[6] +define ld_next_value $1[7] + +# PLL_INIT -- Initialize the linelist descriptor. +define (pll_init, { # $1=ll $2=des + # ld_x($2) = 1 + ld_hi($2) = 1 + if (LL_OLDFORMAT($1)) + ld_ip($2) = OLL_FIRST + else + ld_ip($2) = LL_FIRST($1) + ld_next_nleft($2) = 0 + ld_nleft($2) = 0 + call pll_nextseg ($1, $2) +}) + +# PLL_NLEFT -- Number of pixels left in the current segment. +define pll_nleft ld_nleft($1) + +# PLL_GETSEG -- Read pixels from the current segment. +define (pll_getseg, { # $1=ll $2=des $3=npix $4=value + $4 = ld_value($2) + # ld_x($2) = ld_x($2) + $3 + ld_nleft($2) = ld_nleft($2) - $3 + if (ld_nleft($2) <= 0) + if (ld_next_nleft($2) > 0) { + ld_nleft($2) = ld_next_nleft($2) + ld_value($2) = ld_next_value($2) + ld_next_nleft($2) = 0 + } else + call pll_nextseg ($1, $2) +}) diff --git a/sys/plio/pllsten.x b/sys/plio/pllsten.x new file mode 100644 index 00000000..cfd125f3 --- /dev/null +++ b/sys/plio/pllsten.x @@ -0,0 +1,289 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "pllseg.h" +include + +# PL_LINESTENCIL -- Rasterop operation between source and destination line +# lists, reading the source and applying the rasterop only in the regions +# specified by the stencil line list. The stencil list is aligned with the +# source list. + +procedure pl_linestencil (ll_src,xs,src_maxval, ll_dst,ds,dst_maxval, + ll_stn,ss, ll_out, npix, rop) + +short ll_src[ARB] #I source line list +int xs #I starting pixel index in src line list +int src_maxval #I maximum pixel value, source mask +short ll_dst[ARB] #I destination line list +int ds #I starting pixel index in dst line list +int dst_maxval #I maximum pixel value, destination mask +short ll_stn[ARB] #I stencil line list +int ss #I starting pixel index in stn line list +short ll_out[ARB] #O output list (edited version of ll_dst) +int npix #I number of pixels to convert +int rop #I rasterop + +bool need_src, rop_enable +int o_op, o_iz, o_pv, o_np, o_hi +int segsize, v_src, v_dst, v_stn, pv, src_value +int opcode, data, x1, hi, dv, v, iz, nz, np, op, n, i +int d_src[LEN_PLLDES], d_dst[LEN_PLLDES], d_stn[LEN_PLLDES] +define copyout_ 91 +define done_ 92 + +begin + need_src = R_NEED_SRC(rop) + opcode = R_OPCODE(rop) + data = R_DATA(rop) + + # Pixel value to be used if input mask is boolean. + if (src_maxval == 1) + src_value = data + if (src_value <= 0) + src_value = src_maxval + + # Advance to the indicated position in the source list, discarding + # the instructions once read. The point XS may lie within the range + # of an instruction. + + if (need_src) { + x1 = 1 + pll_init (ll_src, d_src) + do i = 1, ARB { + np = min (pll_nleft(d_src), xs - x1) + pll_getseg (ll_src, d_src, np, v_src) + x1 = x1 + np + if (x1 >= xs || np == 0) + break + } + } + + # Advance to the indicated position in the stencil list. This causes + # the point SS in the stencil to be aligned with the point XS in the + # source. + + if (need_src) { + x1 = 1 + pll_init (ll_stn, d_stn) + do i = 1, ARB { + np = min (pll_nleft(d_stn), xs - x1) + pll_getseg (ll_stn, d_stn, np, v_stn) + x1 = x1 + np + if (x1 >= xs || np == 0) + break + } + } + + # Copy DST to OUT, applying the rasterop in the region of NPIX pixels + # beginning at DS. To simplify things (avoid pathological complexity + # in this case) we suffer some unnecessary unpacking and repacking + # of encoded line list instructions in the regions of the DST list + # which are simply copied. This avoids the need for special treatment + # at the edges of the region to which the ROP applies. ROP_ENABLE is + # false initially, true in the ROP region, and false again to the + # right. The number of pixels in each region is given by SEGSIZE. + + o_pv = -1 + op = LL_CURHDRLEN + 1 + segsize = ds - 1 + rop_enable = false + x1 = 1; iz = 1; hi = 1 + pll_init (ll_dst, d_dst) + + do i = 1, ARB { + # Set up for the next segment (before, in, and after the region to + # which the ROP applies), when the current segment is exhausted. + + if (segsize <= 0) + if (!rop_enable) { + # Begin processing central region. + segsize = npix + rop_enable = true + if (segsize <= 0) + next + } else { + # Begin processing final region. + segsize = ARB + rop_enable = false + } + + # Determine the length of the next output segment. This is the + # largest segment of constant value formed by the intersection of + # the two lists. If bounds checking has been performed properly + # then it should not be possible to see nleft=zero on either input + # list. Note that zeroed regions are valid data here. + + np = min (segsize, pll_nleft(d_dst)) + if (need_src && rop_enable && pll_nleft(d_src) > 0) { + np = min (np, pll_nleft(d_src)) + if (pll_nleft (d_stn) > 0) + np = min (np, pll_nleft(d_stn)) + } + if (np <= 0) + break + + # Get the segment value and advance the line pointers. We always + # have to read the DST list to copy it to the output. We read the + # SRC list and apply the rasterop only in the region to which the + # ROP applies. + + pll_getseg (ll_dst, d_dst, np, v_dst) + if (rop_enable) { + if (need_src) { + v_src = 0 + if (pll_nleft (d_src) > 0) + pll_getseg (ll_src, d_src, np, v_src) + if (v_src != 0 && src_maxval == 1) + v_src = src_value + pll_getseg (ll_stn, d_stn, np, v_stn) + if (v_stn == 0) + goto copyout_ + } + + # Compute the pixel value for the new output segment, given the + # source and destination pixel values and the rasterop supplied. + + switch (opcode) { + case PIX_CLR: + pv = 0 + case PIX_SET: + pv = data + case PIX_SRC: + pv = v_src + case PIX_DST: + pv = v_dst + case PIX_NOTSRC: + pv = not (v_src) + case PIX_NOTDST: + pv = not (v_dst) + case PIX_SRC_AND_DST: + pv = and (v_src, v_dst) + case PIX_SRC_OR_DST: + pv = or (v_src, v_dst) + case PIX_SRC_XOR_DST: + pv = xor (v_src, v_dst) + case PIX_SRC_AND_NOTDST: + pv = and (v_src, not(v_dst)) + case PIX_SRC_OR_NOTDST: + pv = or (v_src, not(v_dst)) + case PIX_NOTSRC_AND_DST: + pv = and (not(v_src), v_dst) + case PIX_NOTSRC_OR_DST: + pv = or (not(v_src), v_dst) + case PIX_NOT_SRC_AND_DST: + pv = not (and (v_src, v_dst)) + case PIX_NOT_SRC_OR_DST: + pv = not (or (v_src, v_dst)) + case PIX_NOT_SRC_XOR_DST: + pv = not (xor (v_src, v_dst)) + } + + # Mask the high bits to prevent negative values, handle the + # case of a boolean output mask. + + if (dst_maxval == 1 && pv != 0) + pv = 1 + else if (dst_maxval > 1) + pv = and (dst_maxval, pv) + + } else +copyout_ pv = v_dst + + if (pv == 0) { + if (pll_nleft (d_dst) <= 0) { + # Output zeros at end of list. + x1 = x1 + np + } else { + # Keep going until we get a nonzero range. + o_pv = 0 + x1 = x1 + np + segsize = segsize - np + next + } + } else if (pv == o_pv) { + # Combine with previous range. + iz = o_iz + hi = o_hi + op = o_op + x1 = x1 - o_np + segsize = segsize + o_np + np = np + o_np + o_np = np + } else { + # Save current range parameters. + o_op = op + o_np = np + o_iz = iz + o_hi = hi + o_pv = pv + } + + # Encode an instruction to regenerate the current range of NP data + # values of nonzero level PV, starting at X1. In the most complex + # case we must update the high value and output a range of zeros, + # followed by a range of NP high values. If NP is 1, we can + # probably use a PN or [ID]S instruction to save space. + + nz = x1 - iz + + # Change the high value? + if (pv > 0) { + dv = pv - hi + if (dv != 0) { + # Output IH or DH instruction? + hi = pv + if (abs(dv) > I_DATAMAX) { + ll_out[op] = M_SH + and (pv, I_DATAMAX) + op = op + 1 + ll_out[op] = pv / I_SHIFT + op = op + 1 + } else { + if (dv < 0) + ll_out[op] = M_DH + (-dv) + else + ll_out[op] = M_IH + dv + op = op + 1 + + # Convert to IS or DS if range is a single pixel. + if (np == 1 && nz == 0) { + v = ll_out[op-1] + ll_out[op-1] = or (v, M_MOVE) + goto done_ + } + } + } + } + + # Output range of zeros to catch up to current range? + if (nz > 0) { + # Output the ZN instruction. + for (n=nz; n > 0; n = n - I_DATAMAX) { + ll_out[op] = M_ZN + min(I_DATAMAX,n) + op = op + 1 + } + # Convert to PN if range is a single pixel. + if (np == 1 && pv > 0) { + ll_out[op-1] = ll_out[op-1] + M_PN + 1 + goto done_ + } + # At end of list. + if (pv == 0) + goto done_ + } + + # The only thing left is the HN instruction if we get here. + for (n=np; n > 0; n = n - I_DATAMAX) { + ll_out[op] = M_HN + min(I_DATAMAX,n) + op = op + 1 + } +done_ + segsize = segsize - np + x1 = x1 + np + iz = x1 + } + + # Update the line list header. + call amovs (ll_dst, ll_out, LL_CURHDRLEN) + LL_SETLEN(ll_out, op - 1) +end diff --git a/sys/plio/plnewcopy.x b/sys/plio/plnewcopy.x new file mode 100644 index 00000000..a429bc6e --- /dev/null +++ b/sys/plio/plnewcopy.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_NEWCOPY -- Create a new, empty mask with the same size and depth +# attributes as the reference mask. + +pointer procedure pl_newcopy (old_pl) + +pointer old_pl #I mask descriptor + +pointer new_pl +int naxes, depth +long axlen[PL_MAXDIM] +pointer pl_open() +errchk pl_open + +begin + new_pl = pl_open (NULL) + + call pl_gsize (old_pl, naxes, axlen, depth) + call pl_ssize (new_pl, naxes, axlen, depth) + + PL_PRIVATE1(new_pl) = PL_PRIVATE1(old_pl) + PL_PRIVATE2(new_pl) = PL_PRIVATE2(old_pl) + PL_MAXLINE(new_pl) = PL_MAXLINE(old_pl) + + return (new_pl) +end diff --git a/sys/plio/plopen.x b/sys/plio/plopen.x new file mode 100644 index 00000000..6510ebe5 --- /dev/null +++ b/sys/plio/plopen.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_OPEN -- Open a mask. If the input buffer pointer is NULL an inactive +# mask descriptor is allocated, otherwise the pointer is taken to point to +# an encoded mask, which is decoded and loaded to create an active descriptor. + +pointer procedure pl_open (smp) + +pointer smp #I stored mask pointer or NULL + +pointer pl +errchk calloc, pl_load + +begin + # Allocate and initialize an inactive descriptor. + call calloc (pl, LEN_PLDES, TY_STRUCT) + + call amovki (1, PL_PLANE(pl,1), PL_MAXDIM) + PL_MAGIC(pl) = PL_MAGICVAL + PL_LLINC(pl) = PL_STARTINC + + # Load the saved mask, if any. + if (smp != NULL) + call pl_load (pl, smp) + + return (pl) +end diff --git a/sys/plio/plp2l.gx b/sys/plio/plp2l.gx new file mode 100644 index 00000000..85a59507 --- /dev/null +++ b/sys/plio/plp2l.gx @@ -0,0 +1,126 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PL_P2L -- Convert a pixel array to a line list. The length of the list is +# returned as the function value. + +int procedure pl_p2l$t (px_src, xs, ll_dst, npix) + +PIXEL px_src[ARB] #I input pixel array +int xs #I starting index in pixbuf +short ll_dst[ARB] #O destination line list +int npix #I number of pixels to convert + +PIXEL hi, pv, nv, zero +int xe, x1, iz, ip, op, np, nz, dv, v +define done_ 91 + +begin + # No input pixels? + if (npix <= 0) + return (0) + + # Initialize the linelist header. + LL_VERSION(ll_dst) = LL_CURVERSION + LL_HDRLEN(ll_dst) = LL_CURHDRLEN + LL_NREFS(ll_dst) = 0 + LL_SETBLEN(ll_dst,0) + + xe = xs + npix - 1 + op = LL_CURHDRLEN + 1 + + # Pack the pixel array into a line list. This is done by scanning + # the pixel list for successive ranges of pixels of constant nonzero + # value, where each range is described as follows: + + zero = 0 + pv = max (zero, px_src[xs]) # pixel value of current range + x1 = xs # start index of current range + iz = xs # start index of range of zeros + hi = 1 # current high value + + # Process the data array. + do ip = xs, xe { + if (ip < xe) { + # Get the next pixel value, loop again if same as previous one. + nv = max (zero, px_src[ip+1]) + if (nv == pv) + next + + # If current range is zero, loop again to get nonzero range. + if (pv == 0) { + pv = nv + x1 = ip + 1 + next + } + } else if (pv == 0) + x1 = xe + 1 + + # Encode an instruction to regenerate the current range I0-IP + # of N data values of nonzero level PV. In the most complex case + # we must update the high value and output a range of zeros, + # followed by a range of NP high values. If NP is 1, we can + # probably use a PN or [ID]S instruction to save space. + + np = ip - x1 + 1 + nz = x1 - iz + + # Change the high value? + if (pv > 0) { + dv = pv - hi + if (dv != 0) { + # Output IH or DH instruction? + hi = pv + if (abs(dv) > I_DATAMAX) { + ll_dst[op] = M_SH + and (int(pv), I_DATAMAX) + op = op + 1 + ll_dst[op] = pv / I_SHIFT + op = op + 1 + } else { + if (dv < 0) + ll_dst[op] = M_DH + (-dv) + else + ll_dst[op] = M_IH + dv + op = op + 1 + + # Convert to IS or DS if range is a single pixel. + if (np == 1 && nz == 0) { + v = ll_dst[op-1] + ll_dst[op-1] = or (v, M_MOVE) + goto done_ + } + } + } + } + + # Output range of zeros to catch up to current range? + # The I_DATAMAX-1 limit is to allow adding M_PN+1 without + # overflowing the range of the data segment. + if (nz > 0) { + # Output the ZN instruction. + for (; nz > 0; nz = nz - (I_DATAMAX-1)) { + ll_dst[op] = M_ZN + min(I_DATAMAX-1,nz) + op = op + 1 + } + # Convert to PN if range is a single pixel. + if (np == 1 && pv > 0) { + ll_dst[op-1] = ll_dst[op-1] + M_PN + 1 + goto done_ + } + } + + # The only thing left is the HN instruction if we get here. + for (; np > 0; np = np - I_DATAMAX) { + ll_dst[op] = M_HN + min(I_DATAMAX,np) + op = op + 1 + } +done_ + x1 = ip + 1 + iz = x1 + pv = nv + } + + LL_SETLEN(ll_dst, op - 1) + return (op - 1) +end diff --git a/sys/plio/plp2r.gx b/sys/plio/plp2r.gx new file mode 100644 index 00000000..2e1d1984 --- /dev/null +++ b/sys/plio/plp2r.gx @@ -0,0 +1,71 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_P2R -- Convert a pixel array to a range list. The length of the output +# range list is returned as the function value. + +int procedure pl_p2r$t (px_src, xs, rl, npix) + +PIXEL px_src[ARB] #I input pixel array +int xs #I starting index in pixbuf +PIXEL rl[3,ARB] #O destination range list +int npix #I number of pixels to convert + +PIXEL hi, pv, zero +int xe, x1, np, rn, nv, ip +define done_ 91 + +begin + # No input pixels? + if (npix <= 0) + return (0) + + xe = xs + npix - 1 + rn = RL_FIRST + + # Pack the pixel array into a range list. This is done by scanning + # the pixel list for successive ranges of pixels of constant nonzero + # value, where each range is described as follows: + + zero = 0 + pv = max (zero, px_src[xs]) # pixel value of current range + x1 = xs # start index of current range + hi = 1 # current high value + + # Process the data array. + do ip = xs, xe { + if (ip < xe) { + # Get the next pixel value, loop again if same as previous one. + nv = max (zero, px_src[ip+1]) + if (nv == pv) + next + + # If current range is zero, loop again to get nonzero range. + if (pv == 0) { + pv = nv + x1 = ip + 1 + next + } + } + + np = ip - x1 + 1 + + # Output the new range. + if (pv > 0) { + rl[1,rn] = x1 + rl[2,rn] = np + rl[3,rn] = pv + rn = rn + 1 + } + + x1 = ip + 1 + pv = nv + } + + RL_LEN(rl) = rn - 1 + RL_AXLEN(rl) = npix + + return (rn - 1) +end diff --git a/sys/plio/plplls.x b/sys/plio/plplls.x new file mode 100644 index 00000000..8f8ca491 --- /dev/null +++ b/sys/plio/plplls.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PL_PLLS -- Put a line segment input as a line list to a mask, applying the +# given ROP to combine the line segment with the existing line of the mask. + +procedure pl_plls (pl, v, ll_src, ll_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +short ll_src[ARB] #I input line list +int ll_depth #I line list depth, bits +int npix #I number of pixels to be set +int rop #I rasterop + +pointer sp, ll_out, ll_dst +pointer pl_access() +errchk pl_access + +begin + if (!R_NEED_DST(rop) && v[1] == 1 && npix == PL_AXLEN(pl,1)) + call pl_update (pl, v, ll_src) + else { + call smark (sp) + call salloc (ll_out, LL_MAXLEN(pl), TY_SHORT) + + ll_dst = pl_access (pl,v) + call pl_linerop (ll_src, 1, PL_MAXVAL(pl), Mems[ll_dst], v[1], + MV(ll_depth), Mems[ll_out], npix, rop) + call pl_update (pl, v, Mems[ll_out]) + + call sfree (sp) + } +end diff --git a/sys/plio/plplp.gx b/sys/plio/plplp.gx new file mode 100644 index 00000000..01a3596c --- /dev/null +++ b/sys/plio/plplp.gx @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PL_PLP -- Put a line segment input as a pixel array to a mask, applying the +# given ROP to combine the line segment with the existing line of the mask. + +procedure pl_plp$t (pl, v, px_src, px_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +PIXEL px_src[ARB] #I input pixel array +int px_depth #I pixel depth, bits +int npix #I number of pixels to be set +int rop #I rasterop + +int ll_len +pointer sp, ll_src, ll_out, ll_dst +pointer pl_access() +int pl_p2l$t() +errchk pl_access + +begin + call smark (sp) + call salloc (ll_src, LL_MAXLEN(pl), TY_SHORT) + + # Convert the pixel array to a line list. + ll_len = pl_p2l$t (px_src, 1, Mems[ll_src], npix) + + if (!R_NEED_DST(rop) && v[1] == 1 && npix == PL_AXLEN(pl,1)) + call pl_update (pl, v, Mems[ll_src]) + else { + call salloc (ll_out, LL_MAXLEN(pl), TY_SHORT) + ll_dst = pl_access (pl,v) + call pl_linerop (Mems[ll_src], 1, PL_MAXVAL(pl), Mems[ll_dst], v[1], + MV(px_depth), Mems[ll_out], npix, rop) + call pl_update (pl, v, Mems[ll_out]) + } + + call sfree (sp) +end diff --git a/sys/plio/plplr.gx b/sys/plio/plplr.gx new file mode 100644 index 00000000..d33ba40c --- /dev/null +++ b/sys/plio/plplr.gx @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PL_PLR -- Put a line segment input as a range list to a mask, applying the +# given ROP to combine the line segment with the existing line of the mask. + +procedure pl_plr$t (pl, v, rl_src, rl_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +PIXEL rl_src[ARB] #I input range list +int rl_depth #I range list depth, bits +int npix #I number of pixels to be set +int rop #I rasterop + +int ll_len +pointer sp, ll_src, ll_out, ll_dst +pointer pl_access() +int pl_r2l$t() +errchk pl_access + +begin + call smark (sp) + call salloc (ll_src, LL_MAXLEN(pl), TY_SHORT) + + # Convert the range list to a line list. + ll_len = pl_r2l$t (rl_src, 1, Mems[ll_src], npix) + + if (!R_NEED_DST(rop) && v[1] == 1 && npix == PL_AXLEN(pl,1)) + call pl_update (pl, v, Mems[ll_src]) + else { + call salloc (ll_out, LL_MAXLEN(pl), TY_SHORT) + ll_dst = pl_access (pl,v) + call pl_linerop (Mems[ll_src], 1, PL_MAXVAL(pl), Mems[ll_dst], v[1], + MV(rl_depth), Mems[ll_out], npix, rop) + call pl_update (pl, v, Mems[ll_out]) + } + + call sfree (sp) +end diff --git a/sys/plio/plpoint.x b/sys/plio/plpoint.x new file mode 100644 index 00000000..de9b7ede --- /dev/null +++ b/sys/plio/plpoint.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_POINT -- Perform a rasterop operation on a single point in a line of a +# 2-dimensional plane of a mask. If the dimensionality of the mask exceeds 2, +# the pl_setplane() procedure should be called first to define the plane of +# the mask to be modified. + +procedure pl_point (pl, x, y, rop) + +pointer pl #I mask descriptor +int x #I pixel to be modified +int y #I line to be modified +int rop #I rasterop defining operation + +long v[PL_MAXDIM] +int npix, ll_len +pointer sp, ll_out, ll_reg, rl_out, ll_dst, op +errchk plvalid, pl_access, pl_linerop, pl_update +pointer pl_access() +int pl_r2li() + +begin + call plvalid (pl) + call amovl (PL_PLANE(pl,1), v, PL_MAXDIM) + v[2] = y + + call smark (sp) + call salloc (ll_out, LL_MAXLEN(pl), TY_SHORT) + call salloc (ll_reg, LL_CURHDRLEN + 6, TY_SHORT) + call salloc (rl_out, RL_FIRST * 3, TY_INT) + + # Access the destination line in the mask. + ll_dst = pl_access (pl, v) + + # Construct the edit-region list. + npix = 1 + RLI_AXLEN(rl_out) = npix + RLI_LEN(rl_out) = RL_FIRST + + op = rl_out + (RL_FIRST - 1) * 3 + Memi[op+RL_XOFF] = 1 + Memi[op+RL_NOFF] = npix + Memi[op+RL_VOFF] = 1 + + ll_len = pl_r2li (Memi[rl_out], 1, Mems[ll_reg], npix) + + # Edit the affected line. + call pl_linerop (Mems[ll_reg], 1, 1, Mems[ll_dst], x, PL_MAXVAL(pl), + Mems[ll_out], npix, rop) + + # Update the edited line in the mask. + call pl_update (pl, v, Mems[ll_out]) + + # Compress the mask if excessive free space has accumulated. + if (PL_NEEDCOMPRESS(pl)) + call pl_compress (pl) + + call sfree (sp) +end diff --git a/sys/plio/plpolygon.h b/sys/plio/plpolygon.h new file mode 100644 index 00000000..764b32ae --- /dev/null +++ b/sys/plio/plpolygon.h @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + + +define TOL 0.0001 # pixel units +define swapi {tempi=$2;$2=$1;$1=tempi} +define swapr {tempr=$2;$2=$1;$1=tempr} +define equal (abs($1-$2) +include +include "plpolygon.h" + + +# PL_POLYGON -- Perform a rasterop operation on the area enclosed by a polygon +# drawn in a 2-dimensional plane of a mask. If the dimensionality of the mask +# exceeds 2, the pl_setplane() procedure should be called first to define the +# plane of the mask to be modified. + +procedure pl_polygon (pl, x, y, npts, rop) + +pointer pl #I mask descriptor +int x[npts] #I polygon x-vertices +int y[npts] #I polygon y-vertices +int npts #I number of points in polygon +int rop #I rasterop defining operation + +int line_1, line_2, i +pointer sp, ufd, xp, yp, oo +extern pl_upolygon() +errchk plvalid + +begin + call plvalid (pl) + if (npts <= 0) + return + else if (npts == 1) { + call pl_point (pl, x[1], y[1], rop) + return + } + + call smark (sp) + call salloc (ufd, LEN_PGONDES, TY_STRUCT) + call salloc (oo, RL_FIRST + (npts+1)*3, TY_INT) + call salloc (xp, npts + 1, TY_REAL) + call salloc (yp, npts + 1, TY_REAL) + + # Initialize the region descriptor. + P_PL(ufd) = pl + P_XP(ufd) = xp + P_YP(ufd) = yp + P_PV(ufd) = 1 + P_OO(ufd) = oo + P_OY(ufd) = -1 + P_NS(ufd) = npts - 1 + RLI_LEN(oo) = 0 + + # Copy the user supplied polygon vertices into the descriptor, + # normalizing the polygon in the process. + + do i = 1, npts { + Memr[xp+i-1] = x[i] + Memr[yp+i-1] = y[i] + } + + if (npts > 2) + if (abs(x[1]-x[npts]) > TOL || abs(y[1]-y[npts]) > TOL) { + Memr[xp+npts] = x[1] + Memr[yp+npts] = y[1] + P_NS(ufd) = npts + } + + # Compute the range in Y in which the polygon should be drawn. + call alimi (y, npts, line_1, line_2) + + call pl_regionrop (pl, pl_upolygon, ufd, line_1, line_2, rop) + call sfree (sp) +end diff --git a/sys/plio/plprop.gx b/sys/plio/plprop.gx new file mode 100644 index 00000000..60d1c603 --- /dev/null +++ b/sys/plio/plprop.gx @@ -0,0 +1,177 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_PIXROP -- Rasterop between source and destination pixel arrays. + +procedure pl_pixrop$t (px_src,xs,src_maxval, px_dst,ds,dst_maxval, npix, rop) + +PIXEL px_src[ARB] #I source pixel array +int xs #I starting pixel index in src +int src_maxval #I max pixel value in src mask +PIXEL px_dst[ARB] #O destination pixel array +int ds #I starting pixel index in dst +int dst_maxval #I max pixel value in dst mask +int npix #I number of pixels to convert +int rop #I rasterop + +pointer sp, src +int opcode, i +PIXEL data, ceil, src_value +int and(), or(), xor(), not() +define out_ 91 + +begin + opcode = R_OPCODE(rop) + data = R_DATA(rop) + ceil = 0 + + # Pixel value to be used if input mask is boolean. + if (src_maxval == 1) { + src_value = data + if (src_value <= 0) + src_value = dst_maxval + } + + # Handle the easy cases first. + switch (opcode) { + case PIX_CLR: + call aclr$t (px_dst[ds], npix) + return + case PIX_SET: + call amovk$t (data, px_dst[ds], npix) + goto out_ + case PIX_SRC: + if (src_maxval != 1) + call amov$t (px_src[xs], px_dst[ds], npix) + else { + do i = 1, npix + if (px_src[xs+i-1] > 0) + px_dst[ds+i-1] = src_value + else + px_dst[ds+i-1] = 0 + } + + goto out_ + case PIX_DST: + return # no-op + } + + # Integer or boolean source mask? + if (src_maxval != 1) { + # Integer source mask; operate directly on source mask. + + switch (opcode) { + case PIX_NOTSRC: + do i = 1, npix + px_dst[ds+i-1] = not (px_src[xs+i-1]) + case PIX_NOTDST: + do i = 1, npix + px_dst[ds+i-1] = not (px_dst[xs+i-1]) + + case PIX_SRC_AND_DST: + do i = 1, npix + px_dst[ds+i-1] = and (px_src[xs+i-1], px_dst[ds+i-1]) + case PIX_SRC_OR_DST: + do i = 1, npix + px_dst[ds+i-1] = or (px_src[xs+i-1], px_dst[ds+i-1]) + case PIX_SRC_XOR_DST: + do i = 1, npix + px_dst[ds+i-1] = xor (px_src[xs+i-1], px_dst[ds+i-1]) + + case PIX_SRC_AND_NOTDST: + do i = 1, npix + px_dst[ds+i-1] = and (px_src[xs+i-1], not(px_dst[ds+i-1])) + case PIX_SRC_OR_NOTDST: + do i = 1, npix + px_dst[ds+i-1] = or (px_src[xs+i-1], not(px_dst[ds+i-1])) + case PIX_NOTSRC_AND_DST: + do i = 1, npix + px_dst[ds+i-1] = and (not(px_src[xs+i-1]), px_dst[ds+i-1]) + case PIX_NOTSRC_OR_DST: + do i = 1, npix + px_dst[ds+i-1] = or (not(px_src[xs+i-1]), px_dst[ds+i-1]) + + case PIX_NOT_SRC_AND_DST: + do i = 1, npix + px_dst[ds+i-1] = not (and (px_src[xs+i-1], px_dst[ds+i-1])) + case PIX_NOT_SRC_OR_DST: + do i = 1, npix + px_dst[ds+i-1] = not ( or (px_src[xs+i-1], px_dst[ds+i-1])) + case PIX_NOT_SRC_XOR_DST: + do i = 1, npix + px_dst[ds+i-1] = not (xor (px_src[xs+i-1], px_dst[ds+i-1])) + } + + } else { + # Boolean source mask; use integer DATA value from ROP if source + # mask pixel is set. + + call smark (sp) + call salloc (src, npix, TY_PIXEL) + + do i = 1, npix + if (px_src[xs+i-1] > 0) + Mem$t[src+i-1] = src_value + else + Mem$t[src+i-1] = 0 + + switch (opcode) { + case PIX_NOTSRC: + do i = 1, npix + px_dst[ds+i-1] = not (Mem$t[src+i-1]) + case PIX_NOTDST: + do i = 1, npix + px_dst[ds+i-1] = not (px_dst[xs+i-1]) + + case PIX_SRC_AND_DST: + do i = 1, npix + px_dst[ds+i-1] = and (Mem$t[src+i-1], px_dst[ds+i-1]) + case PIX_SRC_OR_DST: + do i = 1, npix + px_dst[ds+i-1] = or (Mem$t[src+i-1], px_dst[ds+i-1]) + case PIX_SRC_XOR_DST: + do i = 1, npix + px_dst[ds+i-1] = xor (Mem$t[src+i-1], px_dst[ds+i-1]) + + case PIX_SRC_AND_NOTDST: + do i = 1, npix + px_dst[ds+i-1] = and (Mem$t[src+i-1], not(px_dst[ds+i-1])) + case PIX_SRC_OR_NOTDST: + do i = 1, npix + px_dst[ds+i-1] = or (Mem$t[src+i-1], not(px_dst[ds+i-1])) + case PIX_NOTSRC_AND_DST: + do i = 1, npix + px_dst[ds+i-1] = and (not(Mem$t[src+i-1]), px_dst[ds+i-1]) + case PIX_NOTSRC_OR_DST: + do i = 1, npix + px_dst[ds+i-1] = or (not(Mem$t[src+i-1]), px_dst[ds+i-1]) + + case PIX_NOT_SRC_AND_DST: + do i = 1, npix + px_dst[ds+i-1] = not (and (Mem$t[src+i-1], px_dst[ds+i-1])) + case PIX_NOT_SRC_OR_DST: + do i = 1, npix + px_dst[ds+i-1] = not ( or (Mem$t[src+i-1], px_dst[ds+i-1])) + case PIX_NOT_SRC_XOR_DST: + do i = 1, npix + px_dst[ds+i-1] = not (xor (Mem$t[src+i-1], px_dst[ds+i-1])) + } + + call sfree (sp) + } +out_ + # If writing to an integer mask, mask the data to the indicated max + # value (necessary to avoid very large values if any NOT operations + # occurred). If writing to a boolean mask, map positive integer mask + # values to 1. + + if (dst_maxval == 1) { + data = 1 + call argt$t (px_dst[ds], npix, ceil, data) + } else if (dst_maxval > 1) { + data = dst_maxval + call aandk$t (px_dst[ds], data, px_dst[ds], npix) + } +end diff --git a/sys/plio/plr2l.gx b/sys/plio/plr2l.gx new file mode 100644 index 00000000..d0a98e92 --- /dev/null +++ b/sys/plio/plr2l.gx @@ -0,0 +1,130 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_R2L -- Convert a range list to a line list. The length of the output +# line list is returned as the function value. + +int procedure pl_r2l$t (rl_src, xs, ll_dst, npix) + +PIXEL rl_src[3,ARB] #I input range list +int xs #I starting pixel index in range list +short ll_dst[ARB] #O destination line list +int npix #I number of pixels to convert + +PIXEL hi, pv +int last, xe, x1, x2, iz, op, np, nz, nr, dv, v, i +define done_ 91 + +begin + # No input pixels? + nr = RL_LEN(rl_src) + if (npix <= 0 || nr <= 0) + return (0) + + # Initialize the linelist header. + LL_VERSION(ll_dst) = LL_CURVERSION + LL_HDRLEN(ll_dst) = LL_CURHDRLEN + LL_NREFS(ll_dst) = 0 + LL_SETBLEN(ll_dst,0) + + xe = xs + npix - 1 + op = LL_CURHDRLEN + 1 + iz = xs + hi = 1 + + # Process the array of range lists. + do i = RL_FIRST, nr + 1 { + if (i <= nr) { + # Load next range. + x1 = rl_src[1,i] + np = rl_src[2,i] + pv = rl_src[3,i] + x2 = x1 + np - 1 + last = x2 + + # Get an inbounds range. + if (x1 > xe) + break + else if (xs > x2) + next + else if (x1 < xs) + x1 = xs + else if (x2 > xe) + x2 = xe + + # Go again if nothing inbounds. + nz = x1 - iz + np = x2 - x1 + 1 + if (np <= 0) + next + + } else if (iz < xe) { + # At end of input range list, but need to output a ZN. + nz = xe - iz + 1 + np = 0 + pv = 0 + } else + break + + # Encode an instruction to regenerate the current range I0-IP + # of N data values of nonzero level PV. In the most complex case + # we must update the high value and output a range of zeros, + # followed by a range of NP high values. If NP is 1, we can + # probably use a PN or [ID]S instruction to save space. + + # Change the high value? + if (pv > 0) { + dv = pv - hi + if (dv != 0) { + # Output IH or DH instruction? + hi = pv + if (abs(dv) > I_DATAMAX) { + ll_dst[op] = M_SH + and (int(pv), I_DATAMAX) + op = op + 1 + ll_dst[op] = pv / I_SHIFT + op = op + 1 + } else { + if (dv < 0) + ll_dst[op] = M_DH + (-dv) + else + ll_dst[op] = M_IH + dv + op = op + 1 + + # Convert to IS or DS if range is a single pixel. + if (np == 1 && nz == 0) { + v = ll_dst[op-1] + ll_dst[op-1] = or (v, M_MOVE) + goto done_ + } + } + } + } + + # Output range of zeros to catch up to current range? + if (nz > 0) { + # Output the ZN instruction. + for (; nz > 0; nz = nz - (I_DATAMAX-1)) { + ll_dst[op] = M_ZN + min(I_DATAMAX-1,nz) + op = op + 1 + } + # Convert to PN if range is a single pixel. + if (np == 1 && pv > 0 && x2 == last) { + ll_dst[op-1] = ll_dst[op-1] + M_PN + 1 + goto done_ + } + } + + # The only thing left is the HN instruction if we get here. + for (; np > 0; np = np - I_DATAMAX) { + ll_dst[op] = M_HN + min(I_DATAMAX,np) + op = op + 1 + } +done_ + iz = x2 + 1 + } + + LL_SETLEN(ll_dst, op - 1) + return (op - 1) +end diff --git a/sys/plio/plr2p.gx b/sys/plio/plr2p.gx new file mode 100644 index 00000000..fa0eecda --- /dev/null +++ b/sys/plio/plr2p.gx @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_R2P -- Convert a range list to a pixel array. The number of pixels +# output (always npix) is returned as the function value. + +int procedure pl_r2p$t (rl_src, xs, px_dst, npix) + +PIXEL rl_src[3,ARB] #I input range list +int xs #I starting pixel index in range list +PIXEL px_dst[ARB] #O output pixel array +int npix #I number of pixels to convert + +PIXEL hi, pv +int xe, x1, x2, iz, op, np, nz, nr, i, j +define done_ 91 + +begin + # No input pixels? + nr = RL_LEN(rl_src) + if (npix <= 0 || nr <= 0) + return (0) + + xe = xs + npix - 1 + iz = xs + op = 1 + hi = 1 + + # Process the array of range lists. + do i = RL_FIRST, nr { + x1 = rl_src[1,i] + np = rl_src[2,i] + pv = rl_src[3,i] + x2 = x1 + np - 1 + + # Get an inbounds range. + if (x1 > xe) + break + else if (xs > x2) + next + else if (x1 < xs) + x1 = xs + else if (x2 > xe) + x2 = xe + + nz = x1 - iz + np = x2 - x1 + 1 + if (np <= 0) + next + + # Output range of zeros to catch up to current range? + if (nz > 0) { + do j = 1, nz + px_dst[op+j-1] = 0 + op = op + nz + } + + # Output the pixels. + do j = 1, np + px_dst[op+j-1] = pv + op = op + np +done_ + x1 = x2 + 1 + iz = x1 + } + + # Zero any remaining output range. + do i = op, npix + px_dst[i] = 0 + + return (npix) +end diff --git a/sys/plio/plregrop.x b/sys/plio/plregrop.x new file mode 100644 index 00000000..6e37183a --- /dev/null +++ b/sys/plio/plregrop.x @@ -0,0 +1,76 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_REGIONROP -- Perform a rasterop operation on an irregular region in a +# 2-dimensional plane of a mask. The boundary of the region is defined by +# a user supplied function which, given the line number (Y) returns a range +# list defining the region for that line. +# +# rl_new = ufcn (ufd, y, rl_out, xs, npix) +# +# where +# rl_new = true if range list for line Y is different than for Y-1 +# ufd = user region descriptor (parameters defining region) +# y = input y value +# rl_out = output range list +# xs = first pixel to be edited in dst mask +# npix = number of pixels in edit region +# +# If the dimensionality of the mask exceeds 2, the pl_setplane() procedure +# should be called first to define the plane of the mask to be modified. + +procedure pl_regionrop (pl, ufcn, ufd, y1, y2, rop) + +pointer pl #I mask descriptor +extern ufcn() #I user supplied region tracing procedure +pointer ufd #I user region descriptor +int y1 #I first mask line to be modified +int y2 #I last mask line to be modified +int rop #I rasterop defining operation + +bool rl_new +long v[PL_MAXDIM] +int ll_len, xs, npix +pointer sp, ll_out, ll_reg, ll_dst, ol_dst, rl_out +pointer pl_access() +int pl_r2li() +bool ufcn() +errchk plvalid + +begin + call plvalid (pl) + + call smark (sp) + call salloc (ll_out, LL_MAXLEN(pl), TY_SHORT) + call salloc (ll_reg, LL_MAXLEN(pl), TY_SHORT) + call salloc (rl_out, RL_MAXLEN(pl), TY_INT) + + call amovl (PL_PLANE(pl,1), v, PL_MAXDIM) + ol_dst = 1 + + for (v[2]=y1; v[2] <= y2; v[2]=v[2]+1) { + ll_dst = pl_access (pl, v) + rl_new = ufcn (ufd, v[2], Memi[rl_out], xs, npix) + if (rl_new) + ll_len = pl_r2li (Memi[rl_out], 1, Mems[ll_reg], npix) + + if (ll_dst != ol_dst || rl_new) { + call pl_linestencil (Mems[ll_reg], 1, 1, + Mems[ll_dst], xs, PL_MAXVAL(pl), + Mems[ll_reg], 1, + Mems[ll_out], npix, rop) + ol_dst = ll_dst + } + + # Update the affected line of the destination mask. + call pl_update (pl, v, Mems[ll_out]) + } + + # Compress the mask if excessive free space has accumulated. + if (PL_NEEDCOMPRESS(pl)) + call pl_compress (pl) + + call sfree (sp) +end diff --git a/sys/plio/plreq.gx b/sys/plio/plreq.gx new file mode 100644 index 00000000..470b4484 --- /dev/null +++ b/sys/plio/plreq.gx @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PLR_EQUAL -- Compare two range lists for equality. + +bool procedure plr_equal$t (r1, r2) + +PIXEL r1[3,ARB] #I range list 1 +PIXEL r2[3,ARB] #I range list 2 + +int i +int len1, len2 + +begin + len1 = RL_LEN(r1) + len2 = RL_LEN(r2) + + if (len1 != len2) + return (false) + + do i = RL_FIRST, len1 + if (r1[1,i] != r2[1,i] || r1[2,i] != r2[2,i] || r1[3,i] != r2[3,i]) + return (false) + + return (true) +end diff --git a/sys/plio/plrio.x b/sys/plio/plrio.x new file mode 100644 index 00000000..0cf2b8d9 --- /dev/null +++ b/sys/plio/plrio.x @@ -0,0 +1,350 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +.help PLRIO +.nf --------------------------------------------------------------------------- +PLRIO -- A small package used to provide a means for efficient random +sampling (at the pixel level) of large PLIO masks. In other words, if we have +a large mask and want to determine the values of successive mask pixels at +random locations in the mask, this package provides a more efficient means +for doing so than calling a routine such as PL_GLPI. The mask must already +exist; means are not provided within this package for creating or editing +masks, only for reading them. + + plr = plr_open (pl, plane, buflimit) + plr_setrect (plr, x1,y1, x2,y2) + mval = plr_getpix (plr, x, y) + plr_getlut (plr, bufp, xsize,ysize, xblock,yblock) + plr_close (plr) + +PLR_OPEN opens the indicated 2 dimensional plane of the N dimensional mask PL. +Buffer space used to provide an efficient means of randomly sampling the mask +will be kept to within approximately BUFLIMIT integer units of storage (the +internal table used to sample the mask is type integer, so BUFLIMIT is the +approximate number of entries in the table). Random sampling of the mask is +provided by the integer function PLR_GETPIX, which returns the mask value at +the point [i,j] within the specified plane. PLR_SETRECT may be called before +calling PLR_GETPIX to set the clipping rectangle, which defaults to the +boundaries of the mask. If a PLR_GETPIX call references outside the clipping +region, ERR will be returned as the mask value (normal mask values are >= 0). +Use of a clipping region other than the boundaries of the full mask can avoid +the need for redundant clipping operations in the client. For cases when +even the function call overhead of PLR_GETPIX is too much, the lookup table +may be directly accessed via a call to PLR_GETLUT. Table references which +resolve to a negative valued table entry should call PLR_GETPIX to get the +mask value, otherwise the table value is the mask value. PLR_CLOSE should +be called to free the PLRIO table space (which can be extensive) when no longer +needed. +.endhelp ---------------------------------------------------------------------- + +define DEF_BUFLIMIT (128*128) # internal buffer size +define LEN_STACK (4*32) # max mask size = 2**LEN_STACK + +# If any of the following are changed check that pmio$pmrio.x is consistent. +define LEN_PLRDES 20 +define PLR_PL Memi[$1] # main PLIO descriptor +define PLR_NCOLS Memi[$1+1] # table width +define PLR_NLINES Memi[$1+2] # table height +define PLR_XBLOCK Memi[$1+3] # table blocking factor, X +define PLR_YBLOCK Memi[$1+4] # table blocking factor, Y +define PLR_BUFP Memi[$1+5] # buffer pointer +define PLR_X1 Memi[$1+6] # clipping rectangle +define PLR_Y1 Memi[$1+7] # clipping rectangle +define PLR_X2 Memi[$1+8] # clipping rectangle +define PLR_Y2 Memi[$1+9] # clipping rectangle +define PLR_PLANE Memi[$1+10+($2)-1] # plane to be accessed + +define COMPLEX -1 # table bin -> compex region +define LEN_REGDES 4 # region descriptor +define V1 Memi[$1+($2)-1] +define V2 Memi[$1+2+($2)-1] + + +# PLR_OPEN -- Open a PLIO mask for random pixel access. Provides efficient +# random pixel level access to any size mask. This is a 2-dimensional +# operator, but can be used to sample any 2-dim plane of an N-dim mask. + +pointer procedure plr_open (pl, plane, buflimit) + +pointer pl #I PLIO descriptor +int plane[ARB] #I 2-dim plane to be accessed +int buflimit #I approximate table size, or 0 if don't care + +int v1[PL_MAXDIM], v2[PL_MAXDIM] +int maxpix, ndim, npix, mval, i, j +int msize[2], tsize[2], block[2], vm[2] +pointer sp, stack, plr, bufp, el, rp +errchk calloc, malloc, plvalid +bool pl_sectnotconst() + +begin + call plvalid (pl) + call smark (sp) + call salloc (stack, LEN_STACK * LEN_REGDES, TY_STRUCT) + + # Allocate the PLRIO descriptor. + call calloc (plr, LEN_PLRDES, TY_STRUCT) + + # Set the plane to be accessed. + ndim = PL_NAXES(pl) + do i = 1, 2 + msize[i] = PL_AXLEN(pl,i) + + do i = 1, PL_MAXDIM + if (i > ndim) { + PLR_PLANE(pl,i) = 1 + v1[i] = 1 + v2[i] = 1 + } else if (i > 2) { + PLR_PLANE(pl,i) = plane[i] + v1[i] = plane[i] + v2[i] = plane[i] + } + + # Get the maximum table size in pixels. + if (buflimit <= 0) + maxpix = DEF_BUFLIMIT + else + maxpix = buflimit + + # Determine the blocking factors required to keep the lookup table + # within the given size limit. + + block[1] = 1; block[2] = 1 + while ((msize[1] / block[1]) * (msize[2] / block[2]) > maxpix) + do i = 1, 2 + block[i] = min (msize[i], block[i]*2) + + # Compute the lookup table size. + do i = 1, 2 + tsize[i] = (msize[i] + block[i]-1) / block[i] + + # Allocate the table space. + call malloc (bufp, tsize[1] * tsize[2], TY_INT) + + # Compute the lookup table. Since the lookup table can be large, + # e.g., a quarter million elements for a 512sq table, we don't want + # to directly compute the value of each bufp[i,j]. Instead, we examine + # a region of the table, starting with the entire table, and if the + # corresponding region of the mask is not filled with the same mask + # value, we divide the region into 4 quadrants and examine each in + # turn, and so on until the nonconstant regions are the size of one + # table bin (pixel), which we conclude maps to a COMPLEX (nonconstant) + # region of the mask. By this technique, only table bins which map + # to complex mask regions need be evaluated, and entire large regions + # of the mask are quickly dealt with. + + # Push the entire mask area on the stack as the first region. + el = stack + do i = 1, 2 { + V1(el,i) = 1 + V2(el,i) = tsize[i] + } + + repeat { + # Get the mask coordinates of the next region on the stack. + do i = 1, 2 { + v1[i] = (V1(el,i) - 1) * block[i] + 1 + v2[i] = min (msize[i], V2(el,i) * block[i]) + } + + # Examine the region to see if the associated region of the mask + # consists entirely of a single mask value. + + if (pl_sectnotconst (pl, v1, v2, ndim, mval)) { + if (V1(el,1) == V2(el,1) && V1(el,2) == V2(el,2)) { + # This single table pixel maps to a complex mask region. + Memi[bufp+(V1(el,2)-1)*tsize[1]+V1(el,1)-1] = COMPLEX + + } else { + # Divide the nonzero mask region into four quadrants + # and recursively examine each in turn. + + # Compute the coordinates of the central pixel in vm. + do i = 1, 2 + vm[i] = (V1(el,i) + V2(el,i) + 1) / 2 + + # Save the currently stacked region in v1/v2. + v1[1] = V1(el,1); v1[2] = V1(el,2) + v2[1] = V2(el,1); v2[2] = V2(el,2) + + if ((el-stack)/LEN_REGDES+4 >= LEN_STACK) + call syserrs (SYS_PLSTKOVFL, "plr_open") + + # Push the four quadrants of this region on the stack. + # If the region we are subdividing is only one pixel + # wide in either axis then only two of the regions will + # be valid. The invalid regions will have zero pixels + # in one axis or the other, i.e. (v2[i] < v1[i]). If + # a region is invalid discard it by not advancing the + # stack pointer. + + V1(el,1) = v1[1]; V1(el,2) = vm[2] + V2(el,1) = vm[1]-1; V2(el,2) = v2[2] + if (V1(el,1) <= V2(el,1) && V1(el,2) <= V2(el,2)) + el = el + LEN_REGDES + + V1(el,1) = vm[1]; V1(el,2) = vm[2] + V2(el,1) = v2[1]; V2(el,2) = v2[2] + if (V1(el,1) <= V2(el,1) && V1(el,2) <= V2(el,2)) + el = el + LEN_REGDES + + V1(el,1) = v1[1]; V1(el,2) = v1[2] + V2(el,1) = vm[1]-1; V2(el,2) = vm[2]-1 + if (V1(el,1) <= V2(el,1) && V1(el,2) <= V2(el,2)) + el = el + LEN_REGDES + + V1(el,1) = vm[1]; V1(el,2) = v1[2] + V2(el,1) = v2[1]; V2(el,2) = vm[2]-1 + if (V1(el,1) <= V2(el,1) && V1(el,2) <= V2(el,2)) + el = el + LEN_REGDES + } + } else { + # Set entire region to a constant mask value. + npix = V2(el,1) - V1(el,1) + 1 + do j = V1(el,2), V2(el,2) { + rp = bufp + (j-1) * tsize[1] + V1(el,1) - 1 + if (npix == 1) { + Memi[rp] = mval + } else if (npix < 8) { + do i = 1, npix + Memi[rp+i-1] = mval + } else { + if (mval == 0) + call aclri (Memi[rp], npix) + else + call amovki (mval, Memi[rp], npix) + } + } + } + + # Pop stack. + el = el - LEN_REGDES + + } until (el < stack) + + # Initialize the PLRIO descriptor. + PLR_PL(plr) = pl + PLR_NCOLS(plr) = tsize[1] + PLR_NLINES(plr) = tsize[2] + PLR_XBLOCK(plr) = block[1] + PLR_YBLOCK(plr) = block[2] + PLR_BUFP(plr) = bufp + PLR_X1(plr) = 1 + PLR_Y1(plr) = 1 + PLR_X2(plr) = msize[1] + PLR_Y2(plr) = msize[2] + + call sfree (sp) + return (plr) +end + + +# PLR_GETPIX -- Return the value of the given mask pixel, identified by the +# 2-dim coordinates of the pixel relative to the plane of the N-dim mask +# specified at open time. + +int procedure plr_getpix (plr, i, j) + +pointer plr #I PLR descriptor +int i, j #I plane-relative coordinates of pixel + +pointer pl, ll_src +int ii, jj, mval, np +pointer pl_access() +int pl_l2pi() +errchk pl_access + +begin + # Clip to the specified region of the mask. + if (i < PLR_X1(plr) || i > PLR_X2(plr)) + return (ERR) + if (j < PLR_Y1(plr) || j > PLR_Y2(plr)) + return (ERR) + + # Map mask pixel coordinates to lookup table bin. + ii = (i - 1) / PLR_XBLOCK(plr) + jj = (j - 1) / PLR_YBLOCK(plr) + + # Get the lookup table value of the given bin. + mval = Memi[PLR_BUFP(plr)+jj*PLR_NCOLS(plr)+ii] + + # Access the original mask to get value if complex region. + if (mval == COMPLEX) { + pl = PLR_PL(plr) + PLR_PLANE(plr,2) = j + ll_src = pl_access (pl, PLR_PLANE(plr,1)) + np = pl_l2pi (Mems[ll_src], i, mval, 1) + } + + return (mval) +end + + +# PLR_GETLUT -- Obtain the buffer pointer and scaling information of the +# internal lookup table, so that direct table references may be made to +# minimize overhead in particularly demanding applications. This is not +# recommended unless absolutely necessary, as PLR_GETPIX is easier and +# safer to use and nearly as efficient. The strategy for using the table +# is to use the blocking factors and XSIZE to map a 2dim mask coordinate +# into a table offset, and access the table to get the table value. +# If this is negative PLR_GETPIX should be called to compute the mask +# value, else the table value is the mask value. + +procedure plr_getlut (plr, bufp, xsize,ysize, xblock,yblock) + +pointer plr #I PLR descriptor +pointer bufp #O lookup table buffer pointer (int *) +int xsize,ysize #O table size +int xblock,yblock #O blocking factors + +begin + bufp = PLR_BUFP(plr) + xsize = PLR_NCOLS(plr) + ysize = PLR_NLINES(plr) + xblock = PLR_XBLOCK(plr) + yblock = PLR_YBLOCK(plr) +end + + +# PLR_SETRECT -- Set the clipping region for PLR_GETPIX. + +procedure plr_setrect (plr, x1,y1, x2,y2) + +pointer plr #I PLR descriptor +int x1,y1 #I lower left corner of region +int x2,y2 #I upper right corner of region + +pointer pl +define oob_ 91 +errchk syserrs + +begin + pl = PLR_PL(plr) + + if (x1 < 1 || x1 > PL_AXLEN(pl,1)) + goto oob_ + if (x2 < 1 || x2 > PL_AXLEN(pl,1)) + goto oob_ + if (y1 < 1 || y1 > PL_AXLEN(pl,2)) + goto oob_ + if (y2 < 1 || y2 > PL_AXLEN(pl,2)) +oob_ call syserrs (SYS_PLREFOOB, "plr_setrect") + + PLR_X1(plr) = x1; PLR_Y1(plr) = y1 + PLR_X2(plr) = x2; PLR_Y2(plr) = y2 +end + + +# PLR_CLOSE -- Free a PLRIO descriptor. + +procedure plr_close (plr) + +pointer plr #I PLR descriptor + +begin + call mfree (PLR_BUFP(plr), TY_INT) + call mfree (plr, TY_STRUCT) +end diff --git a/sys/plio/plrop.x b/sys/plio/plrop.x new file mode 100644 index 00000000..b111a359 --- /dev/null +++ b/sys/plio/plrop.x @@ -0,0 +1,93 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# PL_ROP -- Perform a rasterop operation from the source mask to the +# destination mask at the given offsets. The source and destination need +# not be the same size or dimensionality, but out of bounds references are +# not permitted. If the source is of lesser dimensionality than the +# indicated section of the destination, then the source will be rewound +# and reread as necessary to operate upon the entire destination subregion, +# e.g., a line source mask may be applied to successive lines of a plane, +# or a plane mask may be applied to successive planes of a 3D mask. +# The source and destination masks may be the same if desired, but if the +# source and destination regions overlap feedback may occur (this could be +# fixed). With some rasterops, e.g, PIX_SET or PIX_CLR, no source mask is +# required, and pl_src=NULL is permitted. + +procedure pl_rop (pl_src, vs_src, pl_dst, vs_dst, vn, rop) + +pointer pl_src #I source mask or NULL +long vs_src[PL_MAXDIM] #I start vector in source mask +pointer pl_dst #I destination mask (required) +long vs_dst[PL_MAXDIM] #I start vector in destination mask +long vn[PL_MAXDIM] #I vector giving subregion size +long rop #I rasterop + +bool need_src +pointer sp, ll_out, ll_src, ll_dst, ol_src, ol_dst +long v_src[PL_MAXDIM], v_dst[PL_MAXDIM] +long ve_src[PL_MAXDIM], ve_dst[PL_MAXDIM] + +int plloop() +pointer pl_access() +errchk syserr, plvalid, plsslv, pl_access + +begin + call plvalid (pl_dst) + need_src = R_NEED_SRC(rop) + if (need_src && pl_src == NULL) + call syserr (SYS_PLNULLSRC) + + call smark (sp) + call salloc (ll_out, LL_MAXLEN(pl_dst), TY_SHORT) + + # Initialize the N-dimensional loop counters. + call plsslv (pl_dst, vs_dst, vn, v_dst, ve_dst) + if (need_src) + call plsslv (pl_src, vs_src, vn, v_src, ve_src) + else + ll_src = ll_out # any valid pointer will do + + # Perform the operation. + ol_dst = -1 + repeat { + # Get a line from each mask. The DST linelist is required, + # even if R_NEED_DST(rop) is false, because the DST size + # parameters determine the size of the output list, and the + # rop may only apply to a portion of the DST list. + + ll_dst = pl_access (pl_dst, v_dst) + if (need_src) + ll_src = pl_access (pl_src, v_src) + + # Perform the rasterop operation upon one line of the mask. + # Note that if successive mask lines point to the same encoded + # line list, we only have to compute the result once. + + if (ll_src != ol_src || ll_dst != ol_dst) { + call pl_linerop (Mems[ll_src], vs_src[1], PL_MAXVAL(pl_src), + Mems[ll_dst], vs_dst[1], PL_MAXVAL(pl_dst), + Mems[ll_out], vn[1], rop) + ol_src = ll_src + ol_dst = ll_dst + } + + # Update the affected line of the destination mask. + call pl_update (pl_dst, v_dst, Mems[ll_out]) + + # If the end of the input mask is reached, rewind it and go again. + if (need_src) + if (plloop (v_src,vs_src,ve_src,PL_NAXES(pl_src)) == LOOP_DONE) + call amovi (vs_src, v_src, PL_NAXES(pl_src)) + + } until (plloop (v_dst, vs_dst, ve_dst, PL_NAXES(pl_dst)) == LOOP_DONE) + + # Compress the mask if excessive free space has accumulated. + if (PL_NEEDCOMPRESS(pl_dst)) + call pl_compress (pl_dst) + + call sfree (sp) +end diff --git a/sys/plio/plrpr.gx b/sys/plio/plrpr.gx new file mode 100644 index 00000000..f0004515 --- /dev/null +++ b/sys/plio/plrpr.gx @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PLR_PRINT -- Print a range list on the given output stream. + +procedure plr_print$t (rl, fd, label, firstcol, maxcol) + +PIXEL rl[3,ARB] #I range list +int fd #I output file +char label[ARB] #I line label +int firstcol #I first column for output +int maxcol #I width of formatted output + +pointer sp, buf +int col, rn, r_len, x, n, pv +int strlen() + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + # Output the line label and advance to the first column. If the label + # extends beyond the first column, start a new line. + + call putline (fd, label) + col = strlen (label) + 1 + if (col > firstcol) + call pl_debugout (fd, "", col, firstcol, maxcol) + + r_len = RL_LEN(rl) + + # Decode the range list proper. + do rn = RL_FIRST, r_len { + x = RL_X(rl,rn) + n = RL_N(rl,rn) + pv = RL_V(rl,rn) + + if (n == 1) { + call sprintf (Memc[buf], SZ_LINE, "%d(%d)") + call pargi (x) + call pargi (pv) + } else { + call sprintf (Memc[buf], SZ_LINE, "%d-%d(%d)") + call pargi (x) + call pargi (x+n-1) + call pargi (pv) + } + + call pl_debugout (fd, Memc[buf], col, firstcol, maxcol) + } + + call pl_debugout (fd, "", col, firstcol, maxcol) + call sfree (sp) +end diff --git a/sys/plio/plrrop.gx b/sys/plio/plrrop.gx new file mode 100644 index 00000000..dcc961b2 --- /dev/null +++ b/sys/plio/plrrop.gx @@ -0,0 +1,195 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../plrseg.h" + +# PL_RANGEROP -- Rasterop operation between source and destination range lists. +# The indicated rasterop operation is performed upon the source and destination +# range lists, writing the result to RL_OUT, which is a copy of RL_DST except +# for the region affected by the rasterop operation (note that the destination +# range list cannot be edited in place since it may change size). + +procedure pl_rangerop$t (rl_src, xs, src_maxval, + rl_dst, ds, dst_maxval, rl_out, npix, rop) + +PIXEL rl_src[3,ARB] #I source range list +int xs #I starting pixel index in src range list +int src_maxval #I max pixel value in src mask +PIXEL rl_dst[3,ARB] #I destination range list +int ds #I starting pixel index in dst range list +int dst_maxval #I max pixel value in dst mask +PIXEL rl_out[3,ARB] #O output list (edited version of rl_dst) +int npix #I number of pixels to convert +int rop #I rasterop + +bool need_src, need_dst, rop_enable +PIXEL data, src_value, v_src, v_dst, pv +int segsize, opcode, x, i, np, rn_o, p +int d_src[LEN_PLRDES], d_dst[LEN_PLRDES] + +begin + need_src = R_NEED_SRC(rop) + need_dst = R_NEED_DST(rop) + opcode = R_OPCODE(rop) + data = R_DATA(rop) + + # Pixel value to be used if input mask is boolean. + if (src_maxval == 1) { + src_value = data + if (src_value <= 0) + src_value = dst_maxval + } + + # Advance to the desired position in the source list, discarding + # the unused ranges. The point XS may lie within a range or in a + # zero area of the input line. + + if (need_src) { + x = 1 + plr_init (rl_src, d_src) + do i = 1, ARB { + np = min (plr_nleft(d_src), xs - x) + plr_getseg (rl_src, d_src, np, v_src) + x = x + np + if (x >= xs || np == 0) + break + } + } + + # Advance through both the source and destination lists, extracting + # line segments which have a constant value in each input list; the + # values for the two lists may differ. Apply the given rasterop to + # the source and destination pixel values and write each line segment + # as a range to the output list. If the ranges in the two input lists + # differ (randomly overlap) then the output list will generally be + # more fragmented, i.e., have more ranges of constant value. As each + # output range is generated compare it with the previous range to see + # if they can be joined, as applying a rasterop may cause two different + # ranges to have the same value. + + x = 1 + rn_o = RL_FIRST + segsize = ds - 1 + rop_enable = false + plr_init (rl_dst, d_dst) + + do i = 1, ARB { + # Set up for the next segment (before, in, and after the region to + # which the ROP applies), when the current segment is exhausted. + + if (segsize <= 0) + if (!rop_enable) { + # Begin processing central region. + segsize = npix + rop_enable = true + if (segsize <= 0) + next + } else { + # Begin processing final region. + segsize = ARB + rop_enable = false + } + + # Determine the length of the next output segment. This is the + # largest segment of constant value formed by the intersection of + # the two lists. If bounds checking has been properly performed + # then it should not be possible to see nleft=zero on either input + # list. Note that zeroed regions are valid data here. + + np = min (segsize, plr_nleft(d_dst)) + if (need_src && rop_enable && plr_nleft(d_src) > 0) + np = min (np, plr_nleft(d_src)) + if (np <= 0) + break + + # Get the segment value and advance the line pointers. We must + # read the DST list whether or not we will use the data, since + # the list pointer must be advanced NPIX pixels so that we may + # copy the remainder of the list after the loop. + + plr_getseg (rl_dst, d_dst, np, v_dst) + if (rop_enable) { + # Get v_src. + if (need_src) { + v_src = 0 + if (plr_nleft (d_src) > 0) + plr_getseg (rl_src, d_src, np, v_src) + + if (R_NOTSRC(rop)) { + v_src = not (v_src) + if (src_maxval != 0) + v_src = and (int(v_src), src_maxval) + } + + if (v_src != 0 && src_maxval == 1) + v_src = src_value + } + + # Get v_dst. + if (need_dst) { + if (R_NOTDST(rop)) { + v_dst = not (v_dst) + if (dst_maxval != 0) + v_dst = and (int(v_dst), dst_maxval) + } + } + + # Apply the rasterop. + switch (opcode) { + case PIX_CLR: + pv = 0 + case PIX_SET: + pv = data + case PIX_SRC, PIX_NOTSRC: + pv = v_src + case PIX_DST, PIX_NOTDST: + pv = v_dst + case PIX_SRC_AND_DST, PIX_SRC_AND_NOTDST, PIX_NOTSRC_AND_DST: + pv = and (v_src, v_dst) + case PIX_SRC_OR_DST, PIX_SRC_OR_NOTDST, PIX_NOTSRC_OR_DST: + pv = or (v_src, v_dst) + case PIX_SRC_XOR_DST: + pv = xor (v_src, v_dst) + case PIX_NOT_SRC_AND_DST: + pv = not (and (v_src, v_dst)) + case PIX_NOT_SRC_OR_DST: + pv = not (or (v_src, v_dst)) + case PIX_NOT_SRC_XOR_DST: + pv = not (xor (v_src, v_dst)) + } + + # Mask the high bits to prevent negative values, or map int + # to bool for the case of a boolean output mask. + + if (dst_maxval == 1 && pv != 0) + pv = 1 + else if (dst_maxval > 1) + pv = and (int(pv), dst_maxval) + + } else + pv = v_dst + + # Output a nonzero range. + if (pv > 0) { + p = rn_o - 1 + if (p >= RL_FIRST && + pv == rl_out[3,p] && x == rl_out[1,p] + rl_out[2,p]) { + # Merge new range with previous one. + rl_out[2,p] = rl_out[2,p] + np + } else { + rl_out[1,rn_o] = x + rl_out[2,rn_o] = np + rl_out[3,rn_o] = pv + rn_o = rn_o + 1 + } + } + + x = x + np + segsize = segsize - np + } + + # Update the range list header. + call amov$t (rl_dst, rl_out, (RL_FIRST - 1) * 3) + RL_LEN(rl_out) = rn_o - 1 +end diff --git a/sys/plio/plrseg.h b/sys/plio/plrseg.h new file mode 100644 index 00000000..f37372c3 --- /dev/null +++ b/sys/plio/plrseg.h @@ -0,0 +1,58 @@ +# PLRSEG.H -- Macros for sequentially reading segments of a range list. +# +# plr_init (rl, descriptor) +# npix = plr_nleft (descriptor) +# val = plr_getseg (rl, descriptor, npix, value) +# +# plr_init Initialize descriptor for sequential i/o from the rangelist RL. +# plr_nleft Number of pixels left in the current line segment of constant +# value. Zero is returned at the EOL. +# plr_getseg Read NPIX pixels from the current segment, advancing to the +# next segment automatically when the the current segment is +# exhausted. +# +# The descriptor is an integer array, the contents of which are hidden from +# the application using these macros. + +# Range list i/o descriptor. +define LEN_PLRDES 4 +define rd_nleft $1[1] +define rd_value $1[2] +define rd_x $1[3] +define rd_rn $1[4] + +# PLR_INIT -- Initialize the rangelist descriptor. +define (plr_init, { # $1=rl $2=des + rd_x($2) = 1 + rd_rn($2) = RL_FIRST + plr_nextseg ($1, $2) +}) + +# PLR_NLEFT -- Number of pixels left in the current segment. +define plr_nleft rd_nleft($1) + +# PLR_GETSEG -- Read pixels from the current segment. +define (plr_getseg, { # $1=rl $2=des $3=npix $4=value + $4 = rd_value($2) + rd_x($2) = rd_x($2) + $3 + rd_nleft($2) = rd_nleft($2) - $3 + if (rd_nleft($2) <= 0) + plr_nextseg ($1, $2) +}) + +# PLR_NEXTSEG -- Set up the next segment (internal routine). +define (plr_nextseg, { # $1=rl $2=des + if (rd_rn($2) <= RL_LEN($1)) { + if ($1[1,rd_rn($2)] > rd_x($2)) { + rd_value($2) = 0 + rd_nleft($2) = $1[1,rd_x($2)] - rd_x($2) + } else { + rd_value($2) = $1[3,rd_rn($2)] + rd_nleft($2) = $1[2,rd_rn($2)] + rd_rn($2) = rd_rn($2) + 1 + } + } else if (rd_x($2) <= RL_AXLEN($1)) { + rd_value($2) = 0 + rd_nleft($2) = RL_AXLEN($1) - rd_x($2) + 1 + } +}) diff --git a/sys/plio/plsave.x b/sys/plio/plsave.x new file mode 100644 index 00000000..1b0101d3 --- /dev/null +++ b/sys/plio/plsave.x @@ -0,0 +1,86 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_SAVE -- Save a mask in a buffer in a machine independent format. The user +# supplied buffer will be resized if necessary to hold the full encoded mask. +# If a NULL buffer pointer is given, a new buffer will be allocated with the +# pointer value overwriting the NULL (hence NULL must not be passed as a +# constant in the argument list). The length of the encoded mask in words is +# returned as the function value; this value will be less than BUFLEN is the +# user supplied buffer is larger than it needs to be to store the mask, i.e., +# the user buffer is not resized or reallocated if it is large enough to store +# the mask. The existing contents of the buffer will be overwritten. Multiple +# calls may be made to checkpoint the mask, allowing rollback to an earlier +# state. + +int procedure pl_save (pl, bp, buflen, flags) + +pointer pl #I mask descriptor +pointer bp #U buffer pointer (to short), or NULL +int buflen #U buffer length, shorts +int flags #I not used at present + +pointer sp, index, ex, op +int sz_index, n_buflen +int pl_p2li() +pointer coerce() +errchk malloc, realloc, pl_compress + +begin + call smark (sp) + call salloc (ex, LEN_PLEXTERN, TY_STRUCT) + call salloc (index, PL_NLP(pl) * 3 + LL_CURHDRLEN, TY_SHORT) + + # Eliminate any wasted space in the mask, and compute the amount + # of space needed to store the compressed mask. Compress the index + # first to eliminate wasted space; this can make a big difference + # for a sparse or empty mask. + + call pl_compress (pl) + sz_index = pl_p2li (PL_LP(pl,1), 1, Mems[index], PL_NLP(pl)) + #n_buflen = (LEN_PLEXTERN * SZ_STRUCT + PL_LLLEN(pl) * SZ_SHORT + + n_buflen = (LEN_PLEXTERN * SZ_MII_INT + PL_LLLEN(pl) * SZ_SHORT + + sz_index * SZ_SHORT) / SZ_SHORT + + # Allocate or resize the output buffer. + if (bp == NULL) { + call malloc (bp, n_buflen, TY_SHORT) + buflen = n_buflen + } else if (n_buflen > buflen) { + call realloc (bp, n_buflen, TY_SHORT) + buflen = n_buflen + } + + # Encode and output the external format header structure. + call aclri (Memi[ex], LEN_PLEXTERN) + + PLE_MAGIC(ex) = PL_MAGIC(pl) + PLE_NAXES(ex) = PL_NAXES(pl) + PLE_LLOP(ex) = PL_LLOP(pl) + PLE_LLLEN(ex) = PL_LLLEN(pl) + PLE_MAXLINE(ex) = PL_MAXLINE(pl) + PLE_MAXVAL(ex) = PL_MAXVAL(pl) + PLE_NLP(ex) = PL_NLP(pl) + PLE_NLPX(ex) = sz_index + PLE_EXLEN(ex) = n_buflen + + op = bp + call amovl (PL_AXLEN(pl,1), PLE_AXLEN(ex,1), PL_MAXDIM) + call miipak32 (Memi[ex], Memi[coerce(op,TY_SHORT,TY_INT)], + LEN_PLEXTERN, TY_STRUCT) + #op = op + (LEN_PLEXTERN * SZ_STRUCT) / SZ_SHORT + op = op + (LEN_PLEXTERN * SZ_MII_INT) / SZ_SHORT + + # Append the compressed index... + call miipak16 (Mems[index], Mems[op], sz_index, TY_SHORT) + op = op + sz_index + + # and the line list buffer. + call miipak16 (LL(pl,0), Mems[op], PL_LLLEN(pl), TY_SHORT) + op = op + PL_LLLEN(pl) + + call sfree (sp) + return (op - bp) +end diff --git a/sys/plio/plsavef.x b/sys/plio/plsavef.x new file mode 100644 index 00000000..25575e5f --- /dev/null +++ b/sys/plio/plsavef.x @@ -0,0 +1,59 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_SAVEF -- Store a mask in external format in a binary file. This simple +# code permits only one mask per file; more sophisticated mask storage +# facilities are planned. These will likely obsolete this routine. + +procedure pl_savef (pl, fname, title, flags) + +pointer pl #I mask descriptor +char fname[ARB] #I file name +char title[ARB] #I mask title +int flags #I save flags + +int fd, masklen, buflen, junk +pointer sp, fullname, extn, bp, sv +errchk open, pl_save, write, mfree +int open(), fnextn(), strlen(), pl_save() +bool strne() + +begin + call smark (sp) + call salloc (sv, LEN_SVDES, TY_STRUCT) + call salloc (extn, SZ_FNAME, TY_CHAR) + call salloc (fullname, SZ_PATHNAME, TY_CHAR) + + # Add the ".pl" filename extension if not already present. + call strcpy (fname, Memc[fullname], SZ_PATHNAME) + junk = fnextn (fname, Memc[extn], SZ_FNAME) + if (strne (Memc[extn], "pl")) + call strcat (".pl", Memc[fullname], SZ_PATHNAME) + + # The update flag is required to allow overwriting an existing mask. + if (and (flags, PL_UPDATE) != 0) + iferr (call delete (Memc[fullname])) + ; + + # Encode the mask. + bp = NULL + masklen = pl_save (pl, bp, buflen, flags) + + # Set up the savefile descriptor. + SV_MAGIC(sv) = PLIO_SVMAGIC + SV_TITLELEN(sv) = strlen (title) + 1 + SV_MASKLEN(sv) = masklen + + # Write the savefile. + fd = open (Memc[fullname], NEW_FILE, BINARY_FILE) + + call miiwritei (fd, Memi[sv], LEN_SVDES) + call miiwritec (fd, title, SV_TITLELEN(sv)) + call write (fd, Mems[bp], masklen * SZ_SHORT) + call mfree (bp, TY_SHORT) + + call close (fd) + call sfree (sp) +end diff --git a/sys/plio/plsaveim.x b/sys/plio/plsaveim.x new file mode 100644 index 00000000..8e1b4b54 --- /dev/null +++ b/sys/plio/plsaveim.x @@ -0,0 +1,122 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include + +# PL_SAVEIM -- Save a mask in a conventional image, i.e., convert a mask to +# an image. + +procedure pl_saveim (pl, imname, title, flags) + +pointer pl #I mask descriptor +char imname[ARB] #I image name or section +char title[ARB] #I mask "title" string +int flags #I bitflags + +bool sampling +pointer im, px, im_pl, bp +int npix, naxes, depth, maxdim, mode, i, locstr, locmem +long v_in[PL_MAXDIM], v_out[PL_MAXDIM], vn[PL_MAXDIM] +long vs_l[PL_MAXDIM], vs_p[PL_MAXDIM] +long ve_l[PL_MAXDIM], ve_p[PL_MAXDIM] + +pointer immap() +long clktime() +int impnli(), imaccess(), imstati(), strlen() +errchk immap, syserrs, impnli + +begin + # Open the new output image. + mode = NEW_IMAGE + if (and (flags, PL_UPDATE) != 0) + if (imaccess (imname, 0) == YES) + mode = READ_WRITE + + im = immap (imname, mode, 0) + + # Reload the image header from the "title" string, if any. + if (strlen(title) > 0) { + call zlocva (title, locstr) + call zlocva (Memc, locmem) + bp = locstr - locmem + 1 + call im_pmldhdr (im, bp) + } + + # Initialize a new image to the size of the mask. If updating an + # existing image the sizes must match. + + call pl_gsize (pl, naxes, vn, depth) + maxdim = min (IM_MAXDIM, PL_MAXDIM) + npix = vn[1] + + if (mode == NEW_IMAGE) { + IM_NDIM(im) = naxes + IM_PIXTYPE(im) = TY_SHORT + if (PL_MAXVAL(pl) > MAX_SHORT) + IM_PIXTYPE(im) = TY_INT + call amovl (vn, IM_LEN(im,1), maxdim) + } else { + if (naxes != IM_NDIM(im)) { + call imunmap (im) + call syserrs (SYS_IMPLSIZE, imname) + } + do i = 1, naxes + if (vn[i] != IM_LEN(im,i)) { + call imunmap (im) + call syserrs (SYS_IMPLSIZE, imname) + } + } + + # If the image is already a mask internally, check whether any + # subsampling, axis flipping, or axis mapping is in effect. + # If so we can't use PLIO to copy the mask section. + + im_pl = imstati (im, IM_PLDES) + sampling = false + + if (im_pl != NULL) { + call amovkl (long(1), vs_l, maxdim) + call amovl (IM_LEN(im,1), ve_l, maxdim) + call imaplv (im, vs_l, vs_p, maxdim) + call imaplv (im, ve_l, ve_p, maxdim) + + do i = 1, maxdim { + vn[i] = ve_l[i] - vs_l[i] + 1 + if (vn[i] != ve_p[i] - vs_p[i] + 1) { + sampling = true + break + } + } + } + + # If the source image is already a mask internally and no axis + # geometry is in effect in the image section (if any), then we can + # use a PLIO rasterop to efficiently copy the mask subsection. + + if (im_pl != NULL && !sampling) { + # Copy a mask subsection (or entire image if no section). + call pl_rop (pl, vs_l, im_pl, vs_p, vn, PIX_SRC) + call pl_compress (im_pl) + + } else { + # Copy image pixels. Initialize the vector loop indices. + call amovkl (long(1), v_in, maxdim) + call amovkl (long(1), v_out, maxdim) + + # Copy the image. + while (impnli (im, px, v_out) != EOF) { + call pl_glpi (pl, v_in, Memi[px], 0, npix, PIX_SRC) + call amovl (v_out, v_in, maxdim) + } + } + + IM_MIN(im) = 0 + IM_MAX(im) = PL_MAXVAL(pl) + IM_LIMTIME(im) = clktime(0) + + call imunmap (im) +end diff --git a/sys/plio/plsectnc.x b/sys/plio/plsectnc.x new file mode 100644 index 00000000..7aba7fe6 --- /dev/null +++ b/sys/plio/plsectnc.x @@ -0,0 +1,113 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "pllseg.h" +include + +# PL_SECTNOTCONST -- Test whether the indicated mask image section is constant, +# i.e., all the pixels in the section have the same value. Return this value +# if the region is constant. + +bool procedure pl_sectnotconst (pl_src, v1, v2, ndim, mval) + +pointer pl_src #I mask descriptor +long v1[PL_MAXDIM] #I starting coordinates of section +long v2[PL_MAXDIM] #I ending coordinates of section +int ndim #I section dimension +int mval #O mask value, if constant region + +pointer lp +int ll_src, lval, i +long v[PL_MAXDIM], vs[PL_MAXDIM], ve[PL_MAXDIM], vn[PL_MAXDIM] + +bool pll_const() +int pl_reference(), plloop() +errchk plvalid, plsslv, pl_reference + +begin + call plvalid (pl_src) + + # Initialize the N-dimensional loop counters. + do i = 1, PL_MAXDIM + if (i <= ndim) { + if (v1[i] <= v2[i]) { + vs[i] = v1[i] + vn[i] = v2[i] - v1[i] + 1 + } else { + vs[i] = v2[i] + vn[i] = v1[i] - v2[i] + 1 + } + } else { + vs[i] = 1 + vn[i] = 1 + } + + call plsslv (pl_src, vs, vn, v, ve) + mval = ERR + + # Test each line segment in the section. + repeat { + # Determine if line segment is complex, or is all set to lval. + ll_src = pl_reference (pl_src, v) + if (ll_src == PL_EMPTYLINE) + lval = 0 + else { + lp = Ref (pl_src, ll_src) + if (!pll_const (Mems[lp], vs[1], vn[1], lval)) + return (true) + } + + # Exit if the mask value changes, indicating a complex region. + if (mval == ERR) + mval = lval + else if (mval != lval) + return (true) + + } until (plloop (v, vs, ve, PL_NAXES(pl_src)) == LOOP_DONE) + + return (false) +end + + +# PLL_CONST -- Test whether a section of a line list is set to a constant +# value. If yes, return the value in mval. + +bool procedure pll_const (ll_src, xs, npix, mval) + +short ll_src[ARB] #I input line list +int xs #I first pixel to test +int npix #I length of region to be tested +int mval #O mask value, if constant valued segment + +int nleft, x1, np, v_src, i +int d_src[LEN_PLLDES] + +begin + # Advance to the indicated position in the source list. + x1 = 1 + pll_init (ll_src, d_src) + do i = 1, ARB { + np = min (pll_nleft(d_src), xs - x1) + pll_getseg (ll_src, d_src, np, v_src) + x1 = x1 + np + if (x1 >= xs || np == 0) + break + } + + # Test if the next npix pixels are all set to the same value. + # Note the line list is segmented and we have to read segments until + # we have examined NPIX pixels, or until the mask value changes. + + mval = -1 + for (nleft=npix; nleft > 0; nleft = nleft - np) { + np = min (pll_nleft(d_src), nleft) + pll_getseg (ll_src, d_src, np, v_src) + if (v_src != mval) + if (mval < 0) + mval = v_src + else + return (false) + } + + return (true) +end diff --git a/sys/plio/plsectne.x b/sys/plio/plsectne.x new file mode 100644 index 00000000..c8ca8f6d --- /dev/null +++ b/sys/plio/plsectne.x @@ -0,0 +1,101 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "pllseg.h" +include + +# PL_SECTNOTEMPTY -- Test whether the indicated mask image section is empty. + +bool procedure pl_sectnotempty (pl_src, v1, v2, ndim) + +pointer pl_src #I mask descriptor +long v1[PL_MAXDIM] #I starting coordinates of section +long v2[PL_MAXDIM] #I ending coordinates of section +int ndim + +pointer lp +int ll_src, i +long v[PL_MAXDIM], vs[PL_MAXDIM], ve[PL_MAXDIM], vn[PL_MAXDIM] + +bool pll_empty() +int pl_reference(), plloop() +errchk plvalid, plsslv, pl_reference + +begin + call plvalid (pl_src) + + # Initialize the N-dimensional loop counters. + do i = 1, PL_MAXDIM + if (i <= ndim) { + if (v1[i] <= v2[i]) { + vs[i] = v1[i] + vn[i] = v2[i] - v1[i] + 1 + } else { + vs[i] = v2[i] + vn[i] = v1[i] - v2[i] + 1 + } + } else { + vs[i] = 1 + vn[i] = 1 + } + + call plsslv (pl_src, vs, vn, v, ve) + + # Test each line segment in the section. + repeat { + ll_src = pl_reference (pl_src, v) + if (ll_src != PL_EMPTYLINE) { + lp = Ref (pl_src, ll_src) + if (!pll_empty (Mems[lp], vs[1], vn[1])) + return (true) + } + } until (plloop (v, vs, ve, PL_NAXES(pl_src)) == LOOP_DONE) + + return (false) +end + + +# PLL_EMPTY -- Test whether a section of a line list is empty. + +bool procedure pll_empty (ll_src, xs, npix) + +short ll_src[ARB] #I input line list +int xs #I first pixel to test +int npix #I length of region to be tested + +int nleft, x1, np, v_src, i +int d_src[LEN_PLLDES] + +begin + # Advance to the indicated position in the source list. + x1 = 1 + pll_init (ll_src, d_src) + do i = 1, ARB { + np = min (pll_nleft(d_src), xs - x1) + pll_getseg (ll_src, d_src, np, v_src) + x1 = x1 + np + if (x1 >= xs || np == 0) + break + } + + # Test if the next npix pixels are zero. + if (pll_nleft(d_src) < npix) + return (false) + else { + pll_getseg (ll_src, d_src, npix, v_src) + return (v_src == 0) + } + + # Test if the next npix pixels are zero. Note the line list is + # segmented and we have to read segments until we have examined NPIX + # pixels, or until a nonzero mask pixel is encountered. + + for (nleft=npix; nleft > 0; nleft = nleft - np) { + np = min (pll_nleft(d_src), nleft) + pll_getseg (ll_src, d_src, np, v_src) + if (v_src != 0) + return (false) + } + + return (true) +end diff --git a/sys/plio/plseti.x b/sys/plio/plseti.x new file mode 100644 index 00000000..c6e9d2b4 --- /dev/null +++ b/sys/plio/plseti.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# PL_SETI -- Set a PLIO parameter. + +procedure pl_seti (pl, param, value) + +pointer pl #I mask descriptor +int param #I parameter code +int value #I parameter value + +begin + switch (param) { + case P_PRIVATE1: + PL_PRIVATE1(pl) = value + case P_PRIVATE2: + PL_PRIVATE2(pl) = value + case P_MAXLINE: + PL_MAXLINE(pl) = value + case P_DEPTH: + PL_MAXVAL(pl) = MV(value) + default: + call syserr (SYS_PLINVPAR) + } +end diff --git a/sys/plio/plsplane.x b/sys/plio/plsplane.x new file mode 100644 index 00000000..e4a1f3c1 --- /dev/null +++ b/sys/plio/plsplane.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PL_SETPLANE -- Set the 2-Dim plane to be referenced in calls to the pl_box, +# pl_circle, etc. geometric region masking operators. + +procedure pl_setplane (pl, v) + +pointer pl #I mask descriptor +long v[ARB] #I vector defining plane + +begin + call amovl (v, PL_PLANE(pl,1), PL_MAXDIM) +end diff --git a/sys/plio/plssize.x b/sys/plio/plssize.x new file mode 100644 index 00000000..c14e893d --- /dev/null +++ b/sys/plio/plssize.x @@ -0,0 +1,64 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_SSIZE -- Set the size of a mask, i.e., given an existing open mask +# descriptor, create an empty mask with the given dimensionality and size. + +procedure pl_ssize (pl, naxes, axlen, depth) + +pointer pl #I mask descriptor +int naxes #I number of axes (dimensionality of mask) +long axlen[ARB] #I length of each axis +int depth #I mask depth, bits + +int npix, i +pointer sp, px, lp +int pl_p2ls() +errchk malloc, calloc, mfree + +begin + npix = axlen[1] + call smark (sp) + call salloc (px, npix, TY_SHORT) + + # Initialize the old descriptor. + if (PL_LPP(pl) != NULL) + call mfree (PL_LPP(pl), TY_INT) + if (PL_LLBP(pl) != NULL) + call mfree (PL_LLBP(pl), TY_SHORT) + call amovki (1, PL_PLANE(pl,1), PL_MAXDIM) + + # Set up the empty descriptor. + PL_NAXES(pl) = naxes + if (depth > 0) + PL_MAXVAL(pl) = MV(depth) + else + PL_MAXVAL(pl) = MV(PL_MAXDEPTH) + call amovl (axlen, PL_AXLEN(pl,1), naxes) + do i = naxes + 1, PL_MAXDIM + PL_AXLEN(pl,i) = 1 + + # Allocate the line list buffer. + PL_MAXLINE(pl) = (axlen[1] * 3) + LL_CURHDRLEN + PL_LLLEN(pl) = PL_LLBUFLEN + call malloc (PL_LLBP(pl), PL_LLBUFLEN, TY_SHORT) + lp = PL_LLBP(pl) + + # Encode the empty line line-list. + call aclrs (Mems[px], npix) + PL_LLOP(pl) = pl_p2ls (Mems[px], 1, Mems[lp], npix) + + # Set up the initial line list index (all lines empty). + PL_NLP(pl) = 1 + do i = 2, naxes + PL_NLP(pl) = PL_NLP(pl) * axlen[i] + call calloc (PL_LPP(pl), PL_NLP(pl), TY_INT) + + # Set up the LL header for the empty line. + LP_NREFS(lp) = PL_NLP(pl) + LP_SETBLEN(lp, PL_LLOP(pl)) + + call sfree (sp) +end diff --git a/sys/plio/plsslv.x b/sys/plio/plsslv.x new file mode 100644 index 00000000..bb7b21cb --- /dev/null +++ b/sys/plio/plsslv.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PLSSLV -- Given two vectors (VS, VN) defining the starting coordinates and +# size of an image section, initialize the "loop index" vector V, and the +# loop-end vector VE. + +procedure plsslv (pl, vs, vn, v, ve) + +pointer pl #I mask descriptor +long vs[PL_MAXDIM] #I vector coordinates of start of section +long vn[PL_MAXDIM] #I vector size of section +long v[PL_MAXDIM] #O vector for i/o (vector loop index) +long ve[PL_MAXDIM] #O vector coordinates of end of section + +int i + +begin + do i = 1, PL_NAXES(pl) { + v[i] = vs[i] + ve[i] = vs[i] + vn[i] - 1 + } +end diff --git a/sys/plio/plstati.x b/sys/plio/plstati.x new file mode 100644 index 00000000..c6659afa --- /dev/null +++ b/sys/plio/plstati.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# PL_STATI -- Stat a PLIO parameter. + +int procedure pl_stati (pl, param) + +pointer pl #I mask descriptor +int param #I parameter code + +int i + +begin + switch (param) { + case P_PRIVATE1: + return (PL_PRIVATE1(pl)) + case P_PRIVATE2: + return (PL_PRIVATE2(pl)) + case P_MAXLINE: + return (PL_MAXLINE(pl)) + case P_DEPTH: + do i = 0, ARB + if (2**i > min (I_PVMAX, PL_MAXVAL(pl))) + return (i) + default: + call syserr (SYS_PLINVPAR) + } +end diff --git a/sys/plio/plsten.x b/sys/plio/plsten.x new file mode 100644 index 00000000..6397af3d --- /dev/null +++ b/sys/plio/plsten.x @@ -0,0 +1,92 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# PL_STENCIL -- Perform a rasterop operation from the source mask to the +# destination mask at the given offsets, but only within the regions set to +# one in the stencil mask. + +procedure pl_stencil (pl_src, vs_src, pl_dst, vs_dst, pl_stn, vs_stn, vn, rop) + +pointer pl_src #I source mask or NULL +long vs_src[PL_MAXDIM] #I start vector in source mask +pointer pl_dst #I destination mask (required) +long vs_dst[PL_MAXDIM] #I start vector in destination mask +pointer pl_stn #I stencil mask (required) +long vs_stn[PL_MAXDIM] #I start vector in stencil mask +long vn[PL_MAXDIM] #I vector giving subregion size +long rop #I rasterop + +bool need_src +pointer sp, ll_out, ll_src, ll_dst, ll_stn, ol_src, ol_dst, ol_stn +long v_src[PL_MAXDIM], v_dst[PL_MAXDIM], v_stn[PL_MAXDIM] +long ve_src[PL_MAXDIM], ve_dst[PL_MAXDIM], ve_stn[PL_MAXDIM] + +int plloop() +pointer pl_access() +errchk syserr, plvalid, plsslv, pl_access + +begin + call plvalid (pl_dst) + call plvalid (pl_stn) + need_src = R_NEED_SRC(rop) + if (need_src && pl_src == NULL) + call syserr (SYS_PLNULLSRC) + + call smark (sp) + call salloc (ll_out, LL_MAXLEN(pl_dst), TY_SHORT) + + # Initialize the N-dimensional loop counters. + call plsslv (pl_dst, vs_dst, vn, v_dst, ve_dst) + call plsslv (pl_stn, vs_stn, vn, v_stn, ve_stn) + if (need_src) + call plsslv (pl_src, vs_src, vn, v_src, ve_src) + else + ll_src = ll_out # any valid pointer will do + + # Perform the operation. + ol_dst = -1 + repeat { + # Get a line from each mask. + ll_dst = pl_access (pl_dst, v_dst) + ll_stn = pl_access (pl_stn, v_stn) + if (need_src) + ll_src = pl_access (pl_src, v_src) + + # Perform the rasterop operation upon one line of the mask. + # Note that if successive mask lines point to the same encoded + # line list, we only have to compute the result once. + + if (ll_src != ol_src || ll_dst != ol_dst || ll_stn != ol_stn) { + call pl_linestencil (Mems[ll_src], vs_src[1], PL_MAXVAL(pl_src), + Mems[ll_dst], vs_dst[1], PL_MAXVAL(pl_dst), + Mems[ll_stn], vs_stn[1], + Mems[ll_out], vn[1], rop) + + ol_src = ll_src + ol_dst = ll_dst + ol_stn = ll_stn + } + + # Update the affected line of the destination mask. + call pl_update (pl_dst, v_dst, Mems[ll_out]) + + # If the end of the input mask or stencil is reached, + # rewind it and go again. + + if (plloop (v_stn,vs_stn,ve_stn,PL_NAXES(pl_stn)) == LOOP_DONE) + call amovi (vs_stn, v_stn, PL_NAXES(pl_stn)) + if (need_src) + if (plloop (v_src,vs_src,ve_src,PL_NAXES(pl_src)) == LOOP_DONE) + call amovi (vs_src, v_src, PL_NAXES(pl_src)) + + } until (plloop (v_dst, vs_dst, ve_dst, PL_NAXES(pl_dst)) == LOOP_DONE) + + # Compress the mask if excessive free space has accumulated. + if (PL_NEEDCOMPRESS(pl_dst)) + call pl_compress (pl_dst) + + call sfree (sp) +end diff --git a/sys/plio/plubox.x b/sys/plio/plubox.x new file mode 100644 index 00000000..ec3e1f47 --- /dev/null +++ b/sys/plio/plubox.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "plbox.h" + + +# PL_UBOX -- Regionrop ufcn for a box (rectangular) region. + +bool procedure pl_ubox (ufd, y, rl_reg, xs, npix) + +pointer ufd #I user function descriptor +int y #I mask line number +int rl_reg[3,ARB] #O output range list for line Y +int xs #O start of edit region in dst mask +int npix #O number of pixels affected + +int rn +bool rl_new + +begin + rl_new = true + rn = RL_FIRST + + if (y >= B_Y1(ufd) && y <= B_Y2(ufd)) { + xs = B_X1(ufd) + npix = B_X2(ufd) - B_X1(ufd) + 1 + + RL_X(rl_reg,rn) = 1 + RL_N(rl_reg,rn) = npix + RL_V(rl_reg,rn) = B_PV(ufd) + + rl_new = (y == B_Y1(ufd)) + rn = rn + 1 + + } else { + npix = 0 + xs = 1 + } + + RL_LEN(rl_reg) = rn - 1 + RL_AXLEN(rl_reg) = npix + + return (rl_new) +end diff --git a/sys/plio/plucircle.x b/sys/plio/plucircle.x new file mode 100644 index 00000000..5a23d20a --- /dev/null +++ b/sys/plio/plucircle.x @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "plcircle.h" + + +# PL_UCIRCLE -- Regionrop ufcn for a circle (circular region), clipped at +# the borders of the mask. + +bool procedure pl_ucircle (ufd, y, rl_reg, xs, npix) + +pointer ufd #I user function descriptor +int y #I mask line number +int rl_reg[3,ARB] #O output range list for line Y +int xs #O first pixel to be edited +int npix #O number of pixels affected + +pointer pl +real radius, dx, dy +int rn, axlen, x1, x1_clipped, x2, x2_clipped + +begin + pl = C_PL(ufd) + rn = RL_FIRST + axlen = PL_AXLEN(pl,1) + radius = C_RADIUS(ufd) + + dy = abs (C_YCEN(ufd) - y) + if (dy <= radius) { + dx = sqrt (radius**2 - dy**2) + x1 = C_XCEN(ufd) - int(dx) + x2 = C_XCEN(ufd) + int(dx) + x1_clipped = max(1, min(axlen, x1)) + x2_clipped = max(1, min(axlen, x2)) + + xs = x1_clipped + npix = x2_clipped - x1_clipped + 1 + + RL_X(rl_reg,rn) = 1 + RL_N(rl_reg,rn) = npix + RL_V(rl_reg,rn) = C_PV(ufd) + rn = rn + 1 + + } else { + npix = 0 + xs = 1 + } + + RL_LEN(rl_reg) = rn - 1 + RL_AXLEN(rl_reg) = npix + + return (true) +end diff --git a/sys/plio/plupdate.x b/sys/plio/plupdate.x new file mode 100644 index 00000000..bb90cc34 --- /dev/null +++ b/sys/plio/plupdate.x @@ -0,0 +1,158 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# PL_UPDATE -- Update the indicated line of a mask, i.e., insert a possibly +# modified line (encoded line list) into an image mask. This is where image +# compression in the Y direction occurs: if the line to be inserted is the +# "empty line", or a copy of the adjacent line earlier in the image, then we +# merely set the new line pointer to point to the line already stored, and +# increment the reference count for that line. When a new mask is created, +# all lines point to the "empty line" line list (PL_EMPTYLINE), which has a +# reference count equal to the number of lines in the mask. +# +# A new line may replace an existing line in storage if space permits and the +# reference count of the existing line is one or less, i.e., the stored line +# list is used only by the image line being updated. Otherwise the new line +# list will be appended to the line list buffer, which is resized to a larger +# size if it overflows. Note that the resize may move the buffer, which is +# why all line "pointers" are actually offsets into the line list buffer. +# +# We do not perform garbage collection on freed lines, rather we keep a count +# of the total amount of freed space (which cannot be reused), allowing the +# entire line list to be rebuilt periodically to reclaim the space, when the +# percentage of wasted space rises to a certain level. Since this can be a +# relatively expensive operation it is only performed by high level, more +# macroscopic operators, e.g., following a full mask rasterop, or before +# writing the mask to external storage. Note also that rebulding the mask +# may shift the stored line lists about, invalidating any line list pointers +# that may be cached in the calling procedure. This is another reason why +# we do not perform mask compression automatically if buffer overflow occurs +# during a line update. + +procedure pl_update (pl, v, ll) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I coordinates of line in the mask +short ll[ARB] #I encoded line list + +pointer o_pp, n_pp +int totlen, axlen, index, i +int o_lp, n_lp, o_len, n_len, b_len + +bool pll_equal() +int pl_alloc() +errchk pl_alloc +define update_ 91 +define oob_ 92 + +begin + # Compute the index of the line in the line pointer array. + if (PL_NAXES(pl) == 2) { + # Optimized for case naxes=2. + index = v[2] + if (index < 1 || index > PL_AXLEN(pl,2)) + goto oob_ + } else { + # Generalized code. + index = 1 + totlen = 1 + do i = 2, PL_NAXES(pl) { + axlen = PL_AXLEN(pl,i) + if (v[i] < 1 || v[i] > axlen) + goto oob_ + index = index + totlen * (v[i] - 1) + totlen = totlen * axlen + } + } + + # Now the pointer to the current stored line list. + o_lp = PL_LP(pl,index) + o_pp = Ref (pl, o_lp) + if (o_pp == NULL) + return + + # Has the line been modified? + n_len = LL_LEN(ll) + if (n_len == LP_LEN(o_pp)) + if (pll_equal (ll, LL(pl,o_lp))) + return + + # Keep track of the number of edits. + PL_LLNUPDATES(pl) = PL_LLNUPDATES(pl) + 1 + + # Is the new line empty? + n_lp = PL_EMPTYLINE + n_pp = Ref (pl, n_lp) + if (n_len == LP_LEN(n_pp)) + if (pll_equal (ll, LL(pl,n_lp))) + goto update_ + + # Is the new line a copy of the adjacent line (Y=Y-1) in the image? + # Due to the short integer encoding a maximum of MAX_SHORT references + # are allowed per line. + + if (index > 1) { + n_lp = PL_LP(pl,index-1) + n_pp = Ref (pl, n_lp) + if (LP_NREF(n_pp) < MAX_SHORT) + if (n_len == LP_LEN(n_pp)) + if (pll_equal (ll, LL(pl,n_lp))) + goto update_ + } + + # The new line isn't a copy of the empty line or of an adjacent line, + # so copy it into the line list buffer. + + b_len = LP_BLEN(o_pp) + if (LP_NREF(o_pp) <= 1 && n_len <= b_len && o_lp != PL_EMPTYLINE) { + # Overwrite existing line. + + o_len = LP_LEN(o_pp) + call amovs (ll, LL(pl,o_lp), n_len) + LP_NREFS(o_pp) = 1 + LP_SETBLEN(o_pp, b_len) + PL_LLFREE(pl) = PL_LLFREE(pl) + (o_len - LP_LEN(o_pp)) + return + + } else { + # Add a new line. + + n_lp = pl_alloc (pl, n_len) + o_pp = Ref (pl, o_lp) + n_pp = Ref (pl, n_lp) + call amovs (ll, LL(pl,n_lp), n_len) + + LP_NREFS(n_pp) = 0 + LP_SETBLEN(n_pp, n_len) + PL_LLFREE(pl) = PL_LLFREE(pl) + n_len + } + + # We get here only if the new line has already been stored in the + # linelist buffer, with a pointer to such in N_LP, and a pointer to + # the old line in O_LP. Dereference the old line, which the new line + # is no longer associated with, and increase the reference count of + # the new line. +update_ + + # Dereference the old line and free the space if it is no longer used. + # If the old line buffer is freed we reclaim only LP_LEN words, since + # we already reclaimed LP_BLEN-LP_LEN in an earlier edit operation. + + LP_NREFS(o_pp) = LP_NREFS(o_pp) - 1 + if (LP_NREF(o_pp) == 0 && o_lp != PL_EMPTYLINE) + PL_LLFREE(pl) = PL_LLFREE(pl) + LP_LEN(o_pp) + + # Add another reference to the new line. + LP_NREFS(n_pp) = LP_NREFS(n_pp) + 1 + if (LP_NREF(n_pp) == 1 && n_lp != PL_EMPTYLINE) + PL_LLFREE(pl) = PL_LLFREE(pl) - LP_BLEN(n_pp) + + PL_LP(pl,index) = n_lp + return +oob_ + call syserr (SYS_PLREFOOB) +end diff --git a/sys/plio/plupolygon.x b/sys/plio/plupolygon.x new file mode 100644 index 00000000..b60e9bc5 --- /dev/null +++ b/sys/plio/plupolygon.x @@ -0,0 +1,223 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "plpolygon.h" + + +# PL_UPOLYGON -- Regionrop ufcn for a general closed polygonal region. +# (surely there must be a simpler way to code this...) + +bool procedure pl_upolygon (ufd, line, rl_reg, xs, npix) + +pointer ufd #I user function descriptor +int line #I mask line number +int rl_reg[3,ARB] #O output range list for line Y +int xs #O start of edit region in dst mask +int npix #O number of pixels affected + +pointer xp, yp, pl +bool rl_new, cross +int nseg, np, low, rn, i1, i2, ii, i, j +int tempi, axlen, rl_len, p_prev, p_next +real tempr, y, y1, y2, x1, x2, p1, p2, p_y, n_y + +int btoi() +bool plr_equali() +define done_ 91 + +begin + pl = P_PL(ufd) + axlen = PL_AXLEN(pl,1) + rn = RL_FIRST + npix = 0 + xs = 1 + + nseg = P_NS(ufd) + xp = P_XP(ufd) + yp = P_YP(ufd) + y = real(line) + + # Find the point(s) of intersection of the current mask line with + # the line segments forming the polygon. Note that the line must + # cross a segment to go from inside to outside or vice versa; if a + # segment (or vertex) is merely touched it should be drawn, but it + # is not a point of crossing. + + do i = 1, nseg { + # Locate next and previous line segments. + if (i == 1) + p_prev = nseg + else + p_prev = i - 1 + if (i == nseg) + p_next = 1 + else + p_next = i + 2 + + # Get endpoints of current segment. + x1 = Memr[xp+i-1]; x2 = Memr[xp+i] + y1 = Memr[yp+i-1]; y2 = Memr[yp+i] + if (y1 > y2) { + swapr (x1, x2) + swapr (y1, y2) + swapi (p_next, p_prev) + } + + # Does current line intersect the polygon line segment? + if (y > y1-TOL && y < y2+TOL) { + p_y = Memr[yp+p_prev-1] + n_y = Memr[yp+p_next-1] + + if (y2 - y1 > TOL) { + # Single point of intersection. + p1 = x1 + ((x2 - x1) / (y2 - y1)) * (y - y1) + p2 = p1 + + if (equal (p1, x1) && equal (y, y1)) + cross = ((p_y - y1) < 0) + else if (equal (p1, x2) && equal (y, y2)) + cross = ((n_y - y2) > 0) + else + cross = true + + } else { + # Intersection is entire line segment. + p1 = x1; p2 = x2 + cross = (((p_y - y) * (n_y - y)) < 0) + } + + i1 = max(1, min(axlen, nint(p1))) + i2 = max(1, min(axlen, nint(p2))) + if (i1 > i2) + swapi (i1, i2) + + np = i2 - i1 + 1 + if (np > 0) { + RL_X(rl_reg,rn) = i1 + RL_N(rl_reg,rn) = np + RL_V(rl_reg,rn) = btoi(cross) + rn = rn + 1 + } + } + } + + rl_len = rn - 1 + if (rl_len <= RL_FIRST) + goto done_ + + # Sort the line intersection-segments in order of increasing X. + do j = RL_FIRST, rl_len { + # Get low X value of initial segment. + i1 = RL_X(rl_reg,j) + np = RL_N(rl_reg,j) + i1 = min (i1, i1 + np - 1) + low = j + + # Find lowest valued segment in remainder of array. + do i = j+1, rl_len { + i2 = RL_X(rl_reg,i) + np = RL_N(rl_reg,i) + i2 = min (i2, i2 + np - 1) + if (i2 < i1) { + i1 = i2 + low = i + } + } + + # Interchange the initial segment and the low segment. + if (low != j) { + swapi (RL_X(rl_reg,j), RL_X(rl_reg,low)) + swapi (RL_N(rl_reg,j), RL_N(rl_reg,low)) + swapi (RL_V(rl_reg,j), RL_V(rl_reg,low)) + } + } + + # Combine any segments which overlap. + rn = RL_FIRST + do i = RL_FIRST + 1, rl_len { + i1 = RL_X(rl_reg,rn) + i2 = RL_N(rl_reg,rn) + i1 - 1 + ii = RL_X(rl_reg,i) + if (ii >= i1 && ii <= i2) { + i2 = ii + RL_N(rl_reg,i) - 1 + RL_N(rl_reg,rn) = max (RL_N(rl_reg,rn), i2 - i1 + 1) + RL_V(rl_reg,rn) = max (RL_V(rl_reg,rn), RL_V(rl_reg,i)) + } else { + rn = rn + 1 + RL_X(rl_reg,rn) = RL_X(rl_reg,i) + RL_N(rl_reg,rn) = RL_N(rl_reg,i) + RL_V(rl_reg,rn) = RL_V(rl_reg,i) + } + } + rl_len = rn + + # Now combine successive pairs of intersections to produce the line + # segments to be drawn. If all points are crossing points (where the + # image line crosses the polygon boundary) then we draw a line between + # the first two points, then the second two points, and so on. Points + # where the image line touches the polygon boundary but does not cross + # it are plotted, but are not joined with other points to make line + # segments. + + rn = RL_FIRST + ii = RL_FIRST + + do j = RL_FIRST, rl_len { + if (j <= ii && j < rl_len) { + next + + } else if (RL_V(rl_reg,ii) == YES) { + # Skip a vertext that touches but does not cross. + if (RL_V(rl_reg,j) == NO && j < rl_len) + next + + # Draw a line between the two crossing points. + RL_X(rl_reg,rn) = RL_X(rl_reg,ii) + RL_N(rl_reg,rn) = max (RL_N(rl_reg,ii), + RL_X(rl_reg,j) + RL_N(rl_reg,j) - RL_X(rl_reg,ii)) + RL_V(rl_reg,rn) = P_PV(ufd) + rn = rn + 1 + ii = j + 1 + + } else { + # Plot only the first point. + RL_X(rl_reg,rn) = RL_X(rl_reg,ii) + RL_N(rl_reg,rn) = RL_N(rl_reg,ii) + RL_V(rl_reg,rn) = P_PV(ufd) + rn = rn + 1 + + if (j >= rl_len && j != ii) { + # Plot the second point, if and end of list. + RL_X(rl_reg,rn) = RL_X(rl_reg,j) + RL_N(rl_reg,rn) = RL_N(rl_reg,j) + RL_V(rl_reg,rn) = P_PV(ufd) + rn = rn + 1 + } else + ii = j + } + } + +done_ + # Convert the X values in the range list to be relative to the start + # of the list. Compute NPIX, the range in pixels spanned by the range + # list. + + rl_len = rn - 1 + xs = RL_X(rl_reg,RL_FIRST) + npix = RL_X(rl_reg,rl_len) + RL_N(rl_reg,rl_len) - xs + + do i = RL_FIRST, rl_len + RL_X(rl_reg,i) = RL_X(rl_reg,i) - xs + 1 + + RL_LEN(rl_reg) = rl_len + RL_AXLEN(rl_reg) = npix + + rl_new = true + if (P_OY(ufd) == line - 1) + rl_new = !plr_equali (rl_reg, Memi[P_OO(ufd)]) + call amovi (rl_reg, Memi[P_OO(ufd)], rn - 1) + P_OY(ufd) = line + + return (rl_new) +end diff --git a/sys/plio/plvalid.x b/sys/plio/plvalid.x new file mode 100644 index 00000000..1d6482d9 --- /dev/null +++ b/sys/plio/plvalid.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PLVALID -- Verify the validity of a mask descriptor. + +procedure plvalid (pl) + +pointer pl #I open mask descriptor +errchk syserr + +begin + if (pl != NULL) + if (PL_MAGIC(pl) == PL_MAGICVAL) + if (PL_LLBP(pl) == NULL) + call syserr (SYS_PLINACTDES) + else + return + + call syserr (SYS_PLINVDES) +end diff --git a/sys/plio/tf/mkpkg b/sys/plio/tf/mkpkg new file mode 100644 index 00000000..00a4d40e --- /dev/null +++ b/sys/plio/tf/mkpkg @@ -0,0 +1,51 @@ +# Update the type expanded generic files in the PLIO package library. + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + plglpi.x + plglpl.x + plglps.x + plglri.x + plglrl.x + plglrs.x + pll2pi.x + pll2pl.x + pll2ps.x + pll2ri.x + pll2rl.x + pll2rs.x + plp2li.x + plp2ll.x + plp2ls.x + plp2ri.x + plp2rl.x + plp2rs.x + plplpi.x + plplpl.x + plplps.x + plplri.x + plplrl.x + plplrs.x + plpropi.x + plpropl.x + plprops.x + plr2li.x + plr2ll.x + plr2ls.x + plr2pi.x + plr2pl.x + plr2ps.x + plreqi.x + plreql.x + plreqs.x + plrpri.x + plrprl.x + plrprs.x + plrropi.x ../plrseg.h + plrropl.x ../plrseg.h + plrrops.x ../plrseg.h + ; diff --git a/sys/plio/tf/plglpi.x b/sys/plio/tf/plglpi.x new file mode 100644 index 00000000..3724ed6d --- /dev/null +++ b/sys/plio/tf/plglpi.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PL_GLP -- Get a line segment as a pixel array, applying the given ROP to +# combine the pixels with those of the output array. + +procedure pl_glpi (pl, v, px_dst, px_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +int px_dst[ARB] #O output pixel array +int px_depth #I pixel depth, bits +int npix #I number of pixels desired +int rop #I rasterop + +int np +pointer sp, px_out, ll_src +pointer pl_access() +int pl_l2pi() +errchk pl_access + +begin + ll_src = pl_access (pl,v) + if (!R_NEED_DST(rop)) { + np = pl_l2pi (Mems[ll_src], v[1], px_dst, npix) + return + } + + call smark (sp) + call salloc (px_out, npix, TY_INT) + + np = pl_l2pi (Mems[ll_src], v[1], Memi[px_out], npix) + call pl_pixropi (Memi[px_out], 1, PL_MAXVAL(pl), + px_dst, 1, MV(px_depth), npix, rop) + + call sfree (sp) +end diff --git a/sys/plio/tf/plglpl.x b/sys/plio/tf/plglpl.x new file mode 100644 index 00000000..6e1632c0 --- /dev/null +++ b/sys/plio/tf/plglpl.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PL_GLP -- Get a line segment as a pixel array, applying the given ROP to +# combine the pixels with those of the output array. + +procedure pl_glpl (pl, v, px_dst, px_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +long px_dst[ARB] #O output pixel array +int px_depth #I pixel depth, bits +int npix #I number of pixels desired +int rop #I rasterop + +int np +pointer sp, px_out, ll_src +pointer pl_access() +int pl_l2pl() +errchk pl_access + +begin + ll_src = pl_access (pl,v) + if (!R_NEED_DST(rop)) { + np = pl_l2pl (Mems[ll_src], v[1], px_dst, npix) + return + } + + call smark (sp) + call salloc (px_out, npix, TY_LONG) + + np = pl_l2pl (Mems[ll_src], v[1], Meml[px_out], npix) + call pl_pixropl (Meml[px_out], 1, PL_MAXVAL(pl), + px_dst, 1, MV(px_depth), npix, rop) + + call sfree (sp) +end diff --git a/sys/plio/tf/plglps.x b/sys/plio/tf/plglps.x new file mode 100644 index 00000000..728beb0a --- /dev/null +++ b/sys/plio/tf/plglps.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PL_GLP -- Get a line segment as a pixel array, applying the given ROP to +# combine the pixels with those of the output array. + +procedure pl_glps (pl, v, px_dst, px_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +short px_dst[ARB] #O output pixel array +int px_depth #I pixel depth, bits +int npix #I number of pixels desired +int rop #I rasterop + +int np +pointer sp, px_out, ll_src +pointer pl_access() +int pl_l2ps() +errchk pl_access + +begin + ll_src = pl_access (pl,v) + if (!R_NEED_DST(rop)) { + np = pl_l2ps (Mems[ll_src], v[1], px_dst, npix) + return + } + + call smark (sp) + call salloc (px_out, npix, TY_SHORT) + + np = pl_l2ps (Mems[ll_src], v[1], Mems[px_out], npix) + call pl_pixrops (Mems[px_out], 1, PL_MAXVAL(pl), + px_dst, 1, MV(px_depth), npix, rop) + + call sfree (sp) +end diff --git a/sys/plio/tf/plglri.x b/sys/plio/tf/plglri.x new file mode 100644 index 00000000..3f031ee5 --- /dev/null +++ b/sys/plio/tf/plglri.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_GLR -- Get a line segment as a range list, applying the given ROP to +# combine the pixels with those of the output list. + +procedure pl_glri (pl, v, rl_dst, rl_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +int rl_dst[ARB] #O output range list +int rl_depth #I range list depth, bits +int npix #I number of pixels desired +int rop #I rasterop + +int mr, nr +pointer sp, rl_out, rl_src, ll_src +pointer pl_access() +int pl_l2ri() +errchk pl_access + +begin + ll_src = pl_access (pl,v) + if (!R_NEED_DST(rop)) + nr = pl_l2ri (Mems[ll_src], v[1], rl_dst, npix) + else { + call smark (sp) + mr = min (RL_MAXLEN(pl), npix * 3) + call salloc (rl_src, mr, TY_INT) + call salloc (rl_out, mr, TY_INT) + + nr = pl_l2ri (Mems[ll_src], v[1], Memi[rl_src], npix) + call pl_rangeropi (Memi[rl_src], 1, PL_MAXVAL(pl), + rl_dst, 1, MV(rl_depth), + Memi[rl_out], npix, rop) + + # Copy out the edited range list. + call amovi (Memi[rl_out], rl_dst, RLI_LEN(rl_out)) + + call sfree (sp) + } +end diff --git a/sys/plio/tf/plglrl.x b/sys/plio/tf/plglrl.x new file mode 100644 index 00000000..cf30dc62 --- /dev/null +++ b/sys/plio/tf/plglrl.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_GLR -- Get a line segment as a range list, applying the given ROP to +# combine the pixels with those of the output list. + +procedure pl_glrl (pl, v, rl_dst, rl_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +long rl_dst[ARB] #O output range list +int rl_depth #I range list depth, bits +int npix #I number of pixels desired +int rop #I rasterop + +int mr, nr +pointer sp, rl_out, rl_src, ll_src +pointer pl_access() +int pl_l2rl() +errchk pl_access + +begin + ll_src = pl_access (pl,v) + if (!R_NEED_DST(rop)) + nr = pl_l2rl (Mems[ll_src], v[1], rl_dst, npix) + else { + call smark (sp) + mr = min (RL_MAXLEN(pl), npix * 3) + call salloc (rl_src, mr, TY_LONG) + call salloc (rl_out, mr, TY_LONG) + + nr = pl_l2rl (Mems[ll_src], v[1], Meml[rl_src], npix) + call pl_rangeropl (Meml[rl_src], 1, PL_MAXVAL(pl), + rl_dst, 1, MV(rl_depth), + Meml[rl_out], npix, rop) + + # Copy out the edited range list. + call amovl (Meml[rl_out], rl_dst, RLL_LEN(rl_out)) + + call sfree (sp) + } +end diff --git a/sys/plio/tf/plglrs.x b/sys/plio/tf/plglrs.x new file mode 100644 index 00000000..4c9c90a4 --- /dev/null +++ b/sys/plio/tf/plglrs.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_GLR -- Get a line segment as a range list, applying the given ROP to +# combine the pixels with those of the output list. + +procedure pl_glrs (pl, v, rl_dst, rl_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +short rl_dst[ARB] #O output range list +int rl_depth #I range list depth, bits +int npix #I number of pixels desired +int rop #I rasterop + +int mr, nr +pointer sp, rl_out, rl_src, ll_src +pointer pl_access() +int pl_l2rs() +errchk pl_access + +begin + ll_src = pl_access (pl,v) + if (!R_NEED_DST(rop)) + nr = pl_l2rs (Mems[ll_src], v[1], rl_dst, npix) + else { + call smark (sp) + mr = min (RL_MAXLEN(pl), npix * 3) + call salloc (rl_src, mr, TY_SHORT) + call salloc (rl_out, mr, TY_SHORT) + + nr = pl_l2rs (Mems[ll_src], v[1], Mems[rl_src], npix) + call pl_rangerops (Mems[rl_src], 1, PL_MAXVAL(pl), + rl_dst, 1, MV(rl_depth), + Mems[rl_out], npix, rop) + + # Copy out the edited range list. + call amovs (Mems[rl_out], rl_dst, RLS_LEN(rl_out)) + + call sfree (sp) + } +end diff --git a/sys/plio/tf/pll2pi.x b/sys/plio/tf/pll2pi.x new file mode 100644 index 00000000..cadea930 --- /dev/null +++ b/sys/plio/tf/pll2pi.x @@ -0,0 +1,105 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PL_L2P -- Convert a line list to a pixel array. The number of pixels output +# (always npix) is returned as the function value. + +int procedure pl_l2pi (ll_src, xs, px_dst, npix) + +short ll_src[ARB] #I input line list +int xs #I starting index in ll_src +int px_dst[ARB] #O output pixel array +int npix #I number of pixels to convert + +int pv +bool skipword +int opcode, data, ll_len, ll_first +int x1, x2, i1, i2, xe, np, ip, op, otop, i +define putpix_ 91 + +begin + # Support old format line lists. + if (LL_OLDFORMAT(ll_src)) { + ll_len = OLL_LEN(ll_src) + ll_first = OLL_FIRST + } else { + ll_len = LL_LEN(ll_src) + ll_first = LL_FIRST(ll_src) + } + + # No pixels? + if (npix <= 0 || ll_len <= 0) + return (0) + + xe = xs + npix - 1 + skipword = false + op = 1 + x1 = 1 + pv = 1 + + do ip = ll_first, ll_len { + if (skipword) { + skipword = false + next + } + + opcode = I_OPCODE(ll_src[ip]) + data = I_DATA(ll_src[ip]) + + switch (opcode) { + case I_ZN, I_HN, I_PN: + # Determine inbounds region of segment. + x2 = x1 + data - 1 + i1 = max (x1, xs) + i2 = min (x2, xe) + + # Process segment if any region is inbounds. + np = i2 - i1 + 1 + if (np > 0) { + otop = op + np - 1 + if (opcode == I_HN) { + do i = op, otop + px_dst[i] = pv + } else { + do i = op, otop + px_dst[i] = 0 + if (opcode == I_PN && i2 == x2) + px_dst[otop] = pv + } + op = otop + 1 + } + + # Advance the line index. + x1 = x2 + 1 + + case I_SH: + pv = (int(ll_src[ip+1]) * I_SHIFT) + data + skipword = true + case I_IH: + pv = pv + data + case I_DH: + pv = pv - data + case I_IS: + pv = pv + data + goto putpix_ + case I_DS: + pv = pv - data +putpix_ + if (x1 >= xs && x1 <= xe) { + px_dst[op] = pv + op = op + 1 + } + x1 = x1 + 1 + } + + if (x1 > xe) + break + } + + # Zero any remaining output range. + do i = op, npix + px_dst[i] = 0 + + return (npix) +end diff --git a/sys/plio/tf/pll2pl.x b/sys/plio/tf/pll2pl.x new file mode 100644 index 00000000..9863019b --- /dev/null +++ b/sys/plio/tf/pll2pl.x @@ -0,0 +1,105 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PL_L2P -- Convert a line list to a pixel array. The number of pixels output +# (always npix) is returned as the function value. + +int procedure pl_l2pl (ll_src, xs, px_dst, npix) + +short ll_src[ARB] #I input line list +int xs #I starting index in ll_src +long px_dst[ARB] #O output pixel array +int npix #I number of pixels to convert + +long pv +bool skipword +int opcode, data, ll_len, ll_first +int x1, x2, i1, i2, xe, np, ip, op, otop, i +define putpix_ 91 + +begin + # Support old format line lists. + if (LL_OLDFORMAT(ll_src)) { + ll_len = OLL_LEN(ll_src) + ll_first = OLL_FIRST + } else { + ll_len = LL_LEN(ll_src) + ll_first = LL_FIRST(ll_src) + } + + # No pixels? + if (npix <= 0 || ll_len <= 0) + return (0) + + xe = xs + npix - 1 + skipword = false + op = 1 + x1 = 1 + pv = 1 + + do ip = ll_first, ll_len { + if (skipword) { + skipword = false + next + } + + opcode = I_OPCODE(ll_src[ip]) + data = I_DATA(ll_src[ip]) + + switch (opcode) { + case I_ZN, I_HN, I_PN: + # Determine inbounds region of segment. + x2 = x1 + data - 1 + i1 = max (x1, xs) + i2 = min (x2, xe) + + # Process segment if any region is inbounds. + np = i2 - i1 + 1 + if (np > 0) { + otop = op + np - 1 + if (opcode == I_HN) { + do i = op, otop + px_dst[i] = pv + } else { + do i = op, otop + px_dst[i] = 0 + if (opcode == I_PN && i2 == x2) + px_dst[otop] = pv + } + op = otop + 1 + } + + # Advance the line index. + x1 = x2 + 1 + + case I_SH: + pv = (int(ll_src[ip+1]) * I_SHIFT) + data + skipword = true + case I_IH: + pv = pv + data + case I_DH: + pv = pv - data + case I_IS: + pv = pv + data + goto putpix_ + case I_DS: + pv = pv - data +putpix_ + if (x1 >= xs && x1 <= xe) { + px_dst[op] = pv + op = op + 1 + } + x1 = x1 + 1 + } + + if (x1 > xe) + break + } + + # Zero any remaining output range. + do i = op, npix + px_dst[i] = 0 + + return (npix) +end diff --git a/sys/plio/tf/pll2ps.x b/sys/plio/tf/pll2ps.x new file mode 100644 index 00000000..a853e5ba --- /dev/null +++ b/sys/plio/tf/pll2ps.x @@ -0,0 +1,105 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PL_L2P -- Convert a line list to a pixel array. The number of pixels output +# (always npix) is returned as the function value. + +int procedure pl_l2ps (ll_src, xs, px_dst, npix) + +short ll_src[ARB] #I input line list +int xs #I starting index in ll_src +short px_dst[ARB] #O output pixel array +int npix #I number of pixels to convert + +short pv +bool skipword +int opcode, data, ll_len, ll_first +int x1, x2, i1, i2, xe, np, ip, op, otop, i +define putpix_ 91 + +begin + # Support old format line lists. + if (LL_OLDFORMAT(ll_src)) { + ll_len = OLL_LEN(ll_src) + ll_first = OLL_FIRST + } else { + ll_len = LL_LEN(ll_src) + ll_first = LL_FIRST(ll_src) + } + + # No pixels? + if (npix <= 0 || ll_len <= 0) + return (0) + + xe = xs + npix - 1 + skipword = false + op = 1 + x1 = 1 + pv = 1 + + do ip = ll_first, ll_len { + if (skipword) { + skipword = false + next + } + + opcode = I_OPCODE(ll_src[ip]) + data = I_DATA(ll_src[ip]) + + switch (opcode) { + case I_ZN, I_HN, I_PN: + # Determine inbounds region of segment. + x2 = x1 + data - 1 + i1 = max (x1, xs) + i2 = min (x2, xe) + + # Process segment if any region is inbounds. + np = i2 - i1 + 1 + if (np > 0) { + otop = op + np - 1 + if (opcode == I_HN) { + do i = op, otop + px_dst[i] = pv + } else { + do i = op, otop + px_dst[i] = 0 + if (opcode == I_PN && i2 == x2) + px_dst[otop] = pv + } + op = otop + 1 + } + + # Advance the line index. + x1 = x2 + 1 + + case I_SH: + pv = (int(ll_src[ip+1]) * I_SHIFT) + data + skipword = true + case I_IH: + pv = pv + data + case I_DH: + pv = pv - data + case I_IS: + pv = pv + data + goto putpix_ + case I_DS: + pv = pv - data +putpix_ + if (x1 >= xs && x1 <= xe) { + px_dst[op] = pv + op = op + 1 + } + x1 = x1 + 1 + } + + if (x1 > xe) + break + } + + # Zero any remaining output range. + do i = op, npix + px_dst[i] = 0 + + return (npix) +end diff --git a/sys/plio/tf/pll2ri.x b/sys/plio/tf/pll2ri.x new file mode 100644 index 00000000..431b97e2 --- /dev/null +++ b/sys/plio/tf/pll2ri.x @@ -0,0 +1,117 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_L2R -- Convert a line list to a range list. The length of the output +# range list is returned as the function value. + +int procedure pl_l2ri (ll_src, xs, rl, npix) + +short ll_src[ARB] #I input line list +int xs #I starting index in ll_src +int rl[3,ARB] #O output range list +int npix #I number of pixels to convert + +int pv, hi +bool skipword +int opcode, data, ll_len, ll_first +int x1, x2, i1, i2, xe, np, rn, ip +define range_ 91 +define putrange_ 92 + +begin + # Support old format line lists. + if (LL_OLDFORMAT(ll_src)) { + ll_len = OLL_LEN(ll_src) + ll_first = OLL_FIRST + } else { + ll_len = LL_LEN(ll_src) + ll_first = LL_FIRST(ll_src) + } + + # No pixels? + if (npix <= 0 || ll_len <= 0) + return (0) + + rn = RL_FIRST + xe = xs + npix - 1 + skipword = false + x1 = 1 + hi = 1 + + do ip = ll_first, ll_len { + if (skipword) { + skipword = false + next + } + + opcode = I_OPCODE(ll_src[ip]) + data = I_DATA(ll_src[ip]) + + switch (opcode) { + case I_ZN: + pv = 0 + goto range_ + case I_HN: + pv = hi +range_ + # Determine inbounds region of segment. + x2 = x1 + data - 1 + i1 = max (x1, xs) + i2 = min (x2, xe) + np = i2 - i1 + 1 + x1 = x2 + 1 + + case I_PN: + pv = hi + x2 = x1 + data - 1 + if (x2 < xs || x2 > xe) + np = 0 + else { + i1 = x2 + np = 1 + } + x1 = x2 + 1 + + case I_SH: + hi = (int(ll_src[ip+1]) * I_SHIFT) + data + skipword = true + next + case I_IH: + hi = hi + data + next + case I_DH: + hi = hi - data + next + + case I_IS, I_DS: + if (opcode == I_IS) + hi = hi + data + else + hi = hi - data + + i1 = max (x1, xs) + i2 = min (x1, xe) + np = i2 - i1 + 1 + x1 = x1 + 1 + pv = hi + } + + # Output a range entry? + if (np > 0 && pv > 0) { + rl[1,rn] = i1 + rl[2,rn] = np + rl[3,rn] = pv + rn = rn + 1 + } + + if (x1 > xe) + break + } + + RL_LEN(rl) = rn - 1 + RL_AXLEN(rl) = npix + + return (rn - 1) +end diff --git a/sys/plio/tf/pll2rl.x b/sys/plio/tf/pll2rl.x new file mode 100644 index 00000000..0ff4ce4b --- /dev/null +++ b/sys/plio/tf/pll2rl.x @@ -0,0 +1,117 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_L2R -- Convert a line list to a range list. The length of the output +# range list is returned as the function value. + +int procedure pl_l2rl (ll_src, xs, rl, npix) + +short ll_src[ARB] #I input line list +int xs #I starting index in ll_src +long rl[3,ARB] #O output range list +int npix #I number of pixels to convert + +int pv, hi +bool skipword +int opcode, data, ll_len, ll_first +int x1, x2, i1, i2, xe, np, rn, ip +define range_ 91 +define putrange_ 92 + +begin + # Support old format line lists. + if (LL_OLDFORMAT(ll_src)) { + ll_len = OLL_LEN(ll_src) + ll_first = OLL_FIRST + } else { + ll_len = LL_LEN(ll_src) + ll_first = LL_FIRST(ll_src) + } + + # No pixels? + if (npix <= 0 || ll_len <= 0) + return (0) + + rn = RL_FIRST + xe = xs + npix - 1 + skipword = false + x1 = 1 + hi = 1 + + do ip = ll_first, ll_len { + if (skipword) { + skipword = false + next + } + + opcode = I_OPCODE(ll_src[ip]) + data = I_DATA(ll_src[ip]) + + switch (opcode) { + case I_ZN: + pv = 0 + goto range_ + case I_HN: + pv = hi +range_ + # Determine inbounds region of segment. + x2 = x1 + data - 1 + i1 = max (x1, xs) + i2 = min (x2, xe) + np = i2 - i1 + 1 + x1 = x2 + 1 + + case I_PN: + pv = hi + x2 = x1 + data - 1 + if (x2 < xs || x2 > xe) + np = 0 + else { + i1 = x2 + np = 1 + } + x1 = x2 + 1 + + case I_SH: + hi = (int(ll_src[ip+1]) * I_SHIFT) + data + skipword = true + next + case I_IH: + hi = hi + data + next + case I_DH: + hi = hi - data + next + + case I_IS, I_DS: + if (opcode == I_IS) + hi = hi + data + else + hi = hi - data + + i1 = max (x1, xs) + i2 = min (x1, xe) + np = i2 - i1 + 1 + x1 = x1 + 1 + pv = hi + } + + # Output a range entry? + if (np > 0 && pv > 0) { + rl[1,rn] = i1 + rl[2,rn] = np + rl[3,rn] = pv + rn = rn + 1 + } + + if (x1 > xe) + break + } + + RL_LEN(rl) = rn - 1 + RL_AXLEN(rl) = npix + + return (rn - 1) +end diff --git a/sys/plio/tf/pll2rs.x b/sys/plio/tf/pll2rs.x new file mode 100644 index 00000000..a0852774 --- /dev/null +++ b/sys/plio/tf/pll2rs.x @@ -0,0 +1,117 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_L2R -- Convert a line list to a range list. The length of the output +# range list is returned as the function value. + +int procedure pl_l2rs (ll_src, xs, rl, npix) + +short ll_src[ARB] #I input line list +int xs #I starting index in ll_src +short rl[3,ARB] #O output range list +int npix #I number of pixels to convert + +int pv, hi +bool skipword +int opcode, data, ll_len, ll_first +int x1, x2, i1, i2, xe, np, rn, ip +define range_ 91 +define putrange_ 92 + +begin + # Support old format line lists. + if (LL_OLDFORMAT(ll_src)) { + ll_len = OLL_LEN(ll_src) + ll_first = OLL_FIRST + } else { + ll_len = LL_LEN(ll_src) + ll_first = LL_FIRST(ll_src) + } + + # No pixels? + if (npix <= 0 || ll_len <= 0) + return (0) + + rn = RL_FIRST + xe = xs + npix - 1 + skipword = false + x1 = 1 + hi = 1 + + do ip = ll_first, ll_len { + if (skipword) { + skipword = false + next + } + + opcode = I_OPCODE(ll_src[ip]) + data = I_DATA(ll_src[ip]) + + switch (opcode) { + case I_ZN: + pv = 0 + goto range_ + case I_HN: + pv = hi +range_ + # Determine inbounds region of segment. + x2 = x1 + data - 1 + i1 = max (x1, xs) + i2 = min (x2, xe) + np = i2 - i1 + 1 + x1 = x2 + 1 + + case I_PN: + pv = hi + x2 = x1 + data - 1 + if (x2 < xs || x2 > xe) + np = 0 + else { + i1 = x2 + np = 1 + } + x1 = x2 + 1 + + case I_SH: + hi = (int(ll_src[ip+1]) * I_SHIFT) + data + skipword = true + next + case I_IH: + hi = hi + data + next + case I_DH: + hi = hi - data + next + + case I_IS, I_DS: + if (opcode == I_IS) + hi = hi + data + else + hi = hi - data + + i1 = max (x1, xs) + i2 = min (x1, xe) + np = i2 - i1 + 1 + x1 = x1 + 1 + pv = hi + } + + # Output a range entry? + if (np > 0 && pv > 0) { + rl[1,rn] = i1 + rl[2,rn] = np + rl[3,rn] = pv + rn = rn + 1 + } + + if (x1 > xe) + break + } + + RL_LEN(rl) = rn - 1 + RL_AXLEN(rl) = npix + + return (rn - 1) +end diff --git a/sys/plio/tf/plp2li.x b/sys/plio/tf/plp2li.x new file mode 100644 index 00000000..58b3a8b5 --- /dev/null +++ b/sys/plio/tf/plp2li.x @@ -0,0 +1,126 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PL_P2L -- Convert a pixel array to a line list. The length of the list is +# returned as the function value. + +int procedure pl_p2li (px_src, xs, ll_dst, npix) + +int px_src[ARB] #I input pixel array +int xs #I starting index in pixbuf +short ll_dst[ARB] #O destination line list +int npix #I number of pixels to convert + +int hi, pv, nv, zero +int xe, x1, iz, ip, op, np, nz, dv, v +define done_ 91 + +begin + # No input pixels? + if (npix <= 0) + return (0) + + # Initialize the linelist header. + LL_VERSION(ll_dst) = LL_CURVERSION + LL_HDRLEN(ll_dst) = LL_CURHDRLEN + LL_NREFS(ll_dst) = 0 + LL_SETBLEN(ll_dst,0) + + xe = xs + npix - 1 + op = LL_CURHDRLEN + 1 + + # Pack the pixel array into a line list. This is done by scanning + # the pixel list for successive ranges of pixels of constant nonzero + # value, where each range is described as follows: + + zero = 0 + pv = max (zero, px_src[xs]) # pixel value of current range + x1 = xs # start index of current range + iz = xs # start index of range of zeros + hi = 1 # current high value + + # Process the data array. + do ip = xs, xe { + if (ip < xe) { + # Get the next pixel value, loop again if same as previous one. + nv = max (zero, px_src[ip+1]) + if (nv == pv) + next + + # If current range is zero, loop again to get nonzero range. + if (pv == 0) { + pv = nv + x1 = ip + 1 + next + } + } else if (pv == 0) + x1 = xe + 1 + + # Encode an instruction to regenerate the current range I0-IP + # of N data values of nonzero level PV. In the most complex case + # we must update the high value and output a range of zeros, + # followed by a range of NP high values. If NP is 1, we can + # probably use a PN or [ID]S instruction to save space. + + np = ip - x1 + 1 + nz = x1 - iz + + # Change the high value? + if (pv > 0) { + dv = pv - hi + if (dv != 0) { + # Output IH or DH instruction? + hi = pv + if (abs(dv) > I_DATAMAX) { + ll_dst[op] = M_SH + and (int(pv), I_DATAMAX) + op = op + 1 + ll_dst[op] = pv / I_SHIFT + op = op + 1 + } else { + if (dv < 0) + ll_dst[op] = M_DH + (-dv) + else + ll_dst[op] = M_IH + dv + op = op + 1 + + # Convert to IS or DS if range is a single pixel. + if (np == 1 && nz == 0) { + v = ll_dst[op-1] + ll_dst[op-1] = or (v, M_MOVE) + goto done_ + } + } + } + } + + # Output range of zeros to catch up to current range? + # The I_DATAMAX-1 limit is to allow adding M_PN+1 without + # overflowing the range of the data segment. + if (nz > 0) { + # Output the ZN instruction. + for (; nz > 0; nz = nz - (I_DATAMAX-1)) { + ll_dst[op] = M_ZN + min(I_DATAMAX-1,nz) + op = op + 1 + } + # Convert to PN if range is a single pixel. + if (np == 1 && pv > 0) { + ll_dst[op-1] = ll_dst[op-1] + M_PN + 1 + goto done_ + } + } + + # The only thing left is the HN instruction if we get here. + for (; np > 0; np = np - I_DATAMAX) { + ll_dst[op] = M_HN + min(I_DATAMAX,np) + op = op + 1 + } +done_ + x1 = ip + 1 + iz = x1 + pv = nv + } + + LL_SETLEN(ll_dst, op - 1) + return (op - 1) +end diff --git a/sys/plio/tf/plp2ll.x b/sys/plio/tf/plp2ll.x new file mode 100644 index 00000000..fa4a7d13 --- /dev/null +++ b/sys/plio/tf/plp2ll.x @@ -0,0 +1,126 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PL_P2L -- Convert a pixel array to a line list. The length of the list is +# returned as the function value. + +int procedure pl_p2ll (px_src, xs, ll_dst, npix) + +long px_src[ARB] #I input pixel array +int xs #I starting index in pixbuf +short ll_dst[ARB] #O destination line list +int npix #I number of pixels to convert + +long hi, pv, nv, zero +int xe, x1, iz, ip, op, np, nz, dv, v +define done_ 91 + +begin + # No input pixels? + if (npix <= 0) + return (0) + + # Initialize the linelist header. + LL_VERSION(ll_dst) = LL_CURVERSION + LL_HDRLEN(ll_dst) = LL_CURHDRLEN + LL_NREFS(ll_dst) = 0 + LL_SETBLEN(ll_dst,0) + + xe = xs + npix - 1 + op = LL_CURHDRLEN + 1 + + # Pack the pixel array into a line list. This is done by scanning + # the pixel list for successive ranges of pixels of constant nonzero + # value, where each range is described as follows: + + zero = 0 + pv = max (zero, px_src[xs]) # pixel value of current range + x1 = xs # start index of current range + iz = xs # start index of range of zeros + hi = 1 # current high value + + # Process the data array. + do ip = xs, xe { + if (ip < xe) { + # Get the next pixel value, loop again if same as previous one. + nv = max (zero, px_src[ip+1]) + if (nv == pv) + next + + # If current range is zero, loop again to get nonzero range. + if (pv == 0) { + pv = nv + x1 = ip + 1 + next + } + } else if (pv == 0) + x1 = xe + 1 + + # Encode an instruction to regenerate the current range I0-IP + # of N data values of nonzero level PV. In the most complex case + # we must update the high value and output a range of zeros, + # followed by a range of NP high values. If NP is 1, we can + # probably use a PN or [ID]S instruction to save space. + + np = ip - x1 + 1 + nz = x1 - iz + + # Change the high value? + if (pv > 0) { + dv = pv - hi + if (dv != 0) { + # Output IH or DH instruction? + hi = pv + if (abs(dv) > I_DATAMAX) { + ll_dst[op] = M_SH + and (int(pv), I_DATAMAX) + op = op + 1 + ll_dst[op] = pv / I_SHIFT + op = op + 1 + } else { + if (dv < 0) + ll_dst[op] = M_DH + (-dv) + else + ll_dst[op] = M_IH + dv + op = op + 1 + + # Convert to IS or DS if range is a single pixel. + if (np == 1 && nz == 0) { + v = ll_dst[op-1] + ll_dst[op-1] = or (v, M_MOVE) + goto done_ + } + } + } + } + + # Output range of zeros to catch up to current range? + # The I_DATAMAX-1 limit is to allow adding M_PN+1 without + # overflowing the range of the data segment. + if (nz > 0) { + # Output the ZN instruction. + for (; nz > 0; nz = nz - (I_DATAMAX-1)) { + ll_dst[op] = M_ZN + min(I_DATAMAX-1,nz) + op = op + 1 + } + # Convert to PN if range is a single pixel. + if (np == 1 && pv > 0) { + ll_dst[op-1] = ll_dst[op-1] + M_PN + 1 + goto done_ + } + } + + # The only thing left is the HN instruction if we get here. + for (; np > 0; np = np - I_DATAMAX) { + ll_dst[op] = M_HN + min(I_DATAMAX,np) + op = op + 1 + } +done_ + x1 = ip + 1 + iz = x1 + pv = nv + } + + LL_SETLEN(ll_dst, op - 1) + return (op - 1) +end diff --git a/sys/plio/tf/plp2ls.x b/sys/plio/tf/plp2ls.x new file mode 100644 index 00000000..327778dc --- /dev/null +++ b/sys/plio/tf/plp2ls.x @@ -0,0 +1,126 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PL_P2L -- Convert a pixel array to a line list. The length of the list is +# returned as the function value. + +int procedure pl_p2ls (px_src, xs, ll_dst, npix) + +short px_src[ARB] #I input pixel array +int xs #I starting index in pixbuf +short ll_dst[ARB] #O destination line list +int npix #I number of pixels to convert + +short hi, pv, nv, zero +int xe, x1, iz, ip, op, np, nz, dv, v +define done_ 91 + +begin + # No input pixels? + if (npix <= 0) + return (0) + + # Initialize the linelist header. + LL_VERSION(ll_dst) = LL_CURVERSION + LL_HDRLEN(ll_dst) = LL_CURHDRLEN + LL_NREFS(ll_dst) = 0 + LL_SETBLEN(ll_dst,0) + + xe = xs + npix - 1 + op = LL_CURHDRLEN + 1 + + # Pack the pixel array into a line list. This is done by scanning + # the pixel list for successive ranges of pixels of constant nonzero + # value, where each range is described as follows: + + zero = 0 + pv = max (zero, px_src[xs]) # pixel value of current range + x1 = xs # start index of current range + iz = xs # start index of range of zeros + hi = 1 # current high value + + # Process the data array. + do ip = xs, xe { + if (ip < xe) { + # Get the next pixel value, loop again if same as previous one. + nv = max (zero, px_src[ip+1]) + if (nv == pv) + next + + # If current range is zero, loop again to get nonzero range. + if (pv == 0) { + pv = nv + x1 = ip + 1 + next + } + } else if (pv == 0) + x1 = xe + 1 + + # Encode an instruction to regenerate the current range I0-IP + # of N data values of nonzero level PV. In the most complex case + # we must update the high value and output a range of zeros, + # followed by a range of NP high values. If NP is 1, we can + # probably use a PN or [ID]S instruction to save space. + + np = ip - x1 + 1 + nz = x1 - iz + + # Change the high value? + if (pv > 0) { + dv = pv - hi + if (dv != 0) { + # Output IH or DH instruction? + hi = pv + if (abs(dv) > I_DATAMAX) { + ll_dst[op] = M_SH + and (int(pv), I_DATAMAX) + op = op + 1 + ll_dst[op] = pv / I_SHIFT + op = op + 1 + } else { + if (dv < 0) + ll_dst[op] = M_DH + (-dv) + else + ll_dst[op] = M_IH + dv + op = op + 1 + + # Convert to IS or DS if range is a single pixel. + if (np == 1 && nz == 0) { + v = ll_dst[op-1] + ll_dst[op-1] = or (v, M_MOVE) + goto done_ + } + } + } + } + + # Output range of zeros to catch up to current range? + # The I_DATAMAX-1 limit is to allow adding M_PN+1 without + # overflowing the range of the data segment. + if (nz > 0) { + # Output the ZN instruction. + for (; nz > 0; nz = nz - (I_DATAMAX-1)) { + ll_dst[op] = M_ZN + min(I_DATAMAX-1,nz) + op = op + 1 + } + # Convert to PN if range is a single pixel. + if (np == 1 && pv > 0) { + ll_dst[op-1] = ll_dst[op-1] + M_PN + 1 + goto done_ + } + } + + # The only thing left is the HN instruction if we get here. + for (; np > 0; np = np - I_DATAMAX) { + ll_dst[op] = M_HN + min(I_DATAMAX,np) + op = op + 1 + } +done_ + x1 = ip + 1 + iz = x1 + pv = nv + } + + LL_SETLEN(ll_dst, op - 1) + return (op - 1) +end diff --git a/sys/plio/tf/plp2ri.x b/sys/plio/tf/plp2ri.x new file mode 100644 index 00000000..64f4f1eb --- /dev/null +++ b/sys/plio/tf/plp2ri.x @@ -0,0 +1,71 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_P2R -- Convert a pixel array to a range list. The length of the output +# range list is returned as the function value. + +int procedure pl_p2ri (px_src, xs, rl, npix) + +int px_src[ARB] #I input pixel array +int xs #I starting index in pixbuf +int rl[3,ARB] #O destination range list +int npix #I number of pixels to convert + +int hi, pv, zero +int xe, x1, np, rn, nv, ip +define done_ 91 + +begin + # No input pixels? + if (npix <= 0) + return (0) + + xe = xs + npix - 1 + rn = RL_FIRST + + # Pack the pixel array into a range list. This is done by scanning + # the pixel list for successive ranges of pixels of constant nonzero + # value, where each range is described as follows: + + zero = 0 + pv = max (zero, px_src[xs]) # pixel value of current range + x1 = xs # start index of current range + hi = 1 # current high value + + # Process the data array. + do ip = xs, xe { + if (ip < xe) { + # Get the next pixel value, loop again if same as previous one. + nv = max (zero, px_src[ip+1]) + if (nv == pv) + next + + # If current range is zero, loop again to get nonzero range. + if (pv == 0) { + pv = nv + x1 = ip + 1 + next + } + } + + np = ip - x1 + 1 + + # Output the new range. + if (pv > 0) { + rl[1,rn] = x1 + rl[2,rn] = np + rl[3,rn] = pv + rn = rn + 1 + } + + x1 = ip + 1 + pv = nv + } + + RL_LEN(rl) = rn - 1 + RL_AXLEN(rl) = npix + + return (rn - 1) +end diff --git a/sys/plio/tf/plp2rl.x b/sys/plio/tf/plp2rl.x new file mode 100644 index 00000000..574faad9 --- /dev/null +++ b/sys/plio/tf/plp2rl.x @@ -0,0 +1,71 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_P2R -- Convert a pixel array to a range list. The length of the output +# range list is returned as the function value. + +int procedure pl_p2rl (px_src, xs, rl, npix) + +long px_src[ARB] #I input pixel array +int xs #I starting index in pixbuf +long rl[3,ARB] #O destination range list +int npix #I number of pixels to convert + +long hi, pv, zero +int xe, x1, np, rn, nv, ip +define done_ 91 + +begin + # No input pixels? + if (npix <= 0) + return (0) + + xe = xs + npix - 1 + rn = RL_FIRST + + # Pack the pixel array into a range list. This is done by scanning + # the pixel list for successive ranges of pixels of constant nonzero + # value, where each range is described as follows: + + zero = 0 + pv = max (zero, px_src[xs]) # pixel value of current range + x1 = xs # start index of current range + hi = 1 # current high value + + # Process the data array. + do ip = xs, xe { + if (ip < xe) { + # Get the next pixel value, loop again if same as previous one. + nv = max (zero, px_src[ip+1]) + if (nv == pv) + next + + # If current range is zero, loop again to get nonzero range. + if (pv == 0) { + pv = nv + x1 = ip + 1 + next + } + } + + np = ip - x1 + 1 + + # Output the new range. + if (pv > 0) { + rl[1,rn] = x1 + rl[2,rn] = np + rl[3,rn] = pv + rn = rn + 1 + } + + x1 = ip + 1 + pv = nv + } + + RL_LEN(rl) = rn - 1 + RL_AXLEN(rl) = npix + + return (rn - 1) +end diff --git a/sys/plio/tf/plp2rs.x b/sys/plio/tf/plp2rs.x new file mode 100644 index 00000000..da082f47 --- /dev/null +++ b/sys/plio/tf/plp2rs.x @@ -0,0 +1,71 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_P2R -- Convert a pixel array to a range list. The length of the output +# range list is returned as the function value. + +int procedure pl_p2rs (px_src, xs, rl, npix) + +short px_src[ARB] #I input pixel array +int xs #I starting index in pixbuf +short rl[3,ARB] #O destination range list +int npix #I number of pixels to convert + +short hi, pv, zero +int xe, x1, np, rn, nv, ip +define done_ 91 + +begin + # No input pixels? + if (npix <= 0) + return (0) + + xe = xs + npix - 1 + rn = RL_FIRST + + # Pack the pixel array into a range list. This is done by scanning + # the pixel list for successive ranges of pixels of constant nonzero + # value, where each range is described as follows: + + zero = 0 + pv = max (zero, px_src[xs]) # pixel value of current range + x1 = xs # start index of current range + hi = 1 # current high value + + # Process the data array. + do ip = xs, xe { + if (ip < xe) { + # Get the next pixel value, loop again if same as previous one. + nv = max (zero, px_src[ip+1]) + if (nv == pv) + next + + # If current range is zero, loop again to get nonzero range. + if (pv == 0) { + pv = nv + x1 = ip + 1 + next + } + } + + np = ip - x1 + 1 + + # Output the new range. + if (pv > 0) { + rl[1,rn] = x1 + rl[2,rn] = np + rl[3,rn] = pv + rn = rn + 1 + } + + x1 = ip + 1 + pv = nv + } + + RL_LEN(rl) = rn - 1 + RL_AXLEN(rl) = npix + + return (rn - 1) +end diff --git a/sys/plio/tf/plplpi.x b/sys/plio/tf/plplpi.x new file mode 100644 index 00000000..26c094d4 --- /dev/null +++ b/sys/plio/tf/plplpi.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PL_PLP -- Put a line segment input as a pixel array to a mask, applying the +# given ROP to combine the line segment with the existing line of the mask. + +procedure pl_plpi (pl, v, px_src, px_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +int px_src[ARB] #I input pixel array +int px_depth #I pixel depth, bits +int npix #I number of pixels to be set +int rop #I rasterop + +int ll_len +pointer sp, ll_src, ll_out, ll_dst +pointer pl_access() +int pl_p2li() +errchk pl_access + +begin + call smark (sp) + call salloc (ll_src, LL_MAXLEN(pl), TY_SHORT) + + # Convert the pixel array to a line list. + ll_len = pl_p2li (px_src, 1, Mems[ll_src], npix) + + if (!R_NEED_DST(rop) && v[1] == 1 && npix == PL_AXLEN(pl,1)) + call pl_update (pl, v, Mems[ll_src]) + else { + call salloc (ll_out, LL_MAXLEN(pl), TY_SHORT) + ll_dst = pl_access (pl,v) + call pl_linerop (Mems[ll_src], 1, PL_MAXVAL(pl), Mems[ll_dst], v[1], + MV(px_depth), Mems[ll_out], npix, rop) + call pl_update (pl, v, Mems[ll_out]) + } + + call sfree (sp) +end diff --git a/sys/plio/tf/plplpl.x b/sys/plio/tf/plplpl.x new file mode 100644 index 00000000..85a11304 --- /dev/null +++ b/sys/plio/tf/plplpl.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PL_PLP -- Put a line segment input as a pixel array to a mask, applying the +# given ROP to combine the line segment with the existing line of the mask. + +procedure pl_plpl (pl, v, px_src, px_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +long px_src[ARB] #I input pixel array +int px_depth #I pixel depth, bits +int npix #I number of pixels to be set +int rop #I rasterop + +int ll_len +pointer sp, ll_src, ll_out, ll_dst +pointer pl_access() +int pl_p2ll() +errchk pl_access + +begin + call smark (sp) + call salloc (ll_src, LL_MAXLEN(pl), TY_SHORT) + + # Convert the pixel array to a line list. + ll_len = pl_p2ll (px_src, 1, Mems[ll_src], npix) + + if (!R_NEED_DST(rop) && v[1] == 1 && npix == PL_AXLEN(pl,1)) + call pl_update (pl, v, Mems[ll_src]) + else { + call salloc (ll_out, LL_MAXLEN(pl), TY_SHORT) + ll_dst = pl_access (pl,v) + call pl_linerop (Mems[ll_src], 1, PL_MAXVAL(pl), Mems[ll_dst], v[1], + MV(px_depth), Mems[ll_out], npix, rop) + call pl_update (pl, v, Mems[ll_out]) + } + + call sfree (sp) +end diff --git a/sys/plio/tf/plplps.x b/sys/plio/tf/plplps.x new file mode 100644 index 00000000..b693c90e --- /dev/null +++ b/sys/plio/tf/plplps.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PL_PLP -- Put a line segment input as a pixel array to a mask, applying the +# given ROP to combine the line segment with the existing line of the mask. + +procedure pl_plps (pl, v, px_src, px_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +short px_src[ARB] #I input pixel array +int px_depth #I pixel depth, bits +int npix #I number of pixels to be set +int rop #I rasterop + +int ll_len +pointer sp, ll_src, ll_out, ll_dst +pointer pl_access() +int pl_p2ls() +errchk pl_access + +begin + call smark (sp) + call salloc (ll_src, LL_MAXLEN(pl), TY_SHORT) + + # Convert the pixel array to a line list. + ll_len = pl_p2ls (px_src, 1, Mems[ll_src], npix) + + if (!R_NEED_DST(rop) && v[1] == 1 && npix == PL_AXLEN(pl,1)) + call pl_update (pl, v, Mems[ll_src]) + else { + call salloc (ll_out, LL_MAXLEN(pl), TY_SHORT) + ll_dst = pl_access (pl,v) + call pl_linerop (Mems[ll_src], 1, PL_MAXVAL(pl), Mems[ll_dst], v[1], + MV(px_depth), Mems[ll_out], npix, rop) + call pl_update (pl, v, Mems[ll_out]) + } + + call sfree (sp) +end diff --git a/sys/plio/tf/plplri.x b/sys/plio/tf/plplri.x new file mode 100644 index 00000000..433f9a88 --- /dev/null +++ b/sys/plio/tf/plplri.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PL_PLR -- Put a line segment input as a range list to a mask, applying the +# given ROP to combine the line segment with the existing line of the mask. + +procedure pl_plri (pl, v, rl_src, rl_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +int rl_src[ARB] #I input range list +int rl_depth #I range list depth, bits +int npix #I number of pixels to be set +int rop #I rasterop + +int ll_len +pointer sp, ll_src, ll_out, ll_dst +pointer pl_access() +int pl_r2li() +errchk pl_access + +begin + call smark (sp) + call salloc (ll_src, LL_MAXLEN(pl), TY_SHORT) + + # Convert the range list to a line list. + ll_len = pl_r2li (rl_src, 1, Mems[ll_src], npix) + + if (!R_NEED_DST(rop) && v[1] == 1 && npix == PL_AXLEN(pl,1)) + call pl_update (pl, v, Mems[ll_src]) + else { + call salloc (ll_out, LL_MAXLEN(pl), TY_SHORT) + ll_dst = pl_access (pl,v) + call pl_linerop (Mems[ll_src], 1, PL_MAXVAL(pl), Mems[ll_dst], v[1], + MV(rl_depth), Mems[ll_out], npix, rop) + call pl_update (pl, v, Mems[ll_out]) + } + + call sfree (sp) +end diff --git a/sys/plio/tf/plplrl.x b/sys/plio/tf/plplrl.x new file mode 100644 index 00000000..bf40b9ef --- /dev/null +++ b/sys/plio/tf/plplrl.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PL_PLR -- Put a line segment input as a range list to a mask, applying the +# given ROP to combine the line segment with the existing line of the mask. + +procedure pl_plrl (pl, v, rl_src, rl_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +long rl_src[ARB] #I input range list +int rl_depth #I range list depth, bits +int npix #I number of pixels to be set +int rop #I rasterop + +int ll_len +pointer sp, ll_src, ll_out, ll_dst +pointer pl_access() +int pl_r2ll() +errchk pl_access + +begin + call smark (sp) + call salloc (ll_src, LL_MAXLEN(pl), TY_SHORT) + + # Convert the range list to a line list. + ll_len = pl_r2ll (rl_src, 1, Mems[ll_src], npix) + + if (!R_NEED_DST(rop) && v[1] == 1 && npix == PL_AXLEN(pl,1)) + call pl_update (pl, v, Mems[ll_src]) + else { + call salloc (ll_out, LL_MAXLEN(pl), TY_SHORT) + ll_dst = pl_access (pl,v) + call pl_linerop (Mems[ll_src], 1, PL_MAXVAL(pl), Mems[ll_dst], v[1], + MV(rl_depth), Mems[ll_out], npix, rop) + call pl_update (pl, v, Mems[ll_out]) + } + + call sfree (sp) +end diff --git a/sys/plio/tf/plplrs.x b/sys/plio/tf/plplrs.x new file mode 100644 index 00000000..13318070 --- /dev/null +++ b/sys/plio/tf/plplrs.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PL_PLR -- Put a line segment input as a range list to a mask, applying the +# given ROP to combine the line segment with the existing line of the mask. + +procedure pl_plrs (pl, v, rl_src, rl_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +short rl_src[ARB] #I input range list +int rl_depth #I range list depth, bits +int npix #I number of pixels to be set +int rop #I rasterop + +int ll_len +pointer sp, ll_src, ll_out, ll_dst +pointer pl_access() +int pl_r2ls() +errchk pl_access + +begin + call smark (sp) + call salloc (ll_src, LL_MAXLEN(pl), TY_SHORT) + + # Convert the range list to a line list. + ll_len = pl_r2ls (rl_src, 1, Mems[ll_src], npix) + + if (!R_NEED_DST(rop) && v[1] == 1 && npix == PL_AXLEN(pl,1)) + call pl_update (pl, v, Mems[ll_src]) + else { + call salloc (ll_out, LL_MAXLEN(pl), TY_SHORT) + ll_dst = pl_access (pl,v) + call pl_linerop (Mems[ll_src], 1, PL_MAXVAL(pl), Mems[ll_dst], v[1], + MV(rl_depth), Mems[ll_out], npix, rop) + call pl_update (pl, v, Mems[ll_out]) + } + + call sfree (sp) +end diff --git a/sys/plio/tf/plpropi.x b/sys/plio/tf/plpropi.x new file mode 100644 index 00000000..ecfe7227 --- /dev/null +++ b/sys/plio/tf/plpropi.x @@ -0,0 +1,177 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_PIXROP -- Rasterop between source and destination pixel arrays. + +procedure pl_pixropi (px_src,xs,src_maxval, px_dst,ds,dst_maxval, npix, rop) + +int px_src[ARB] #I source pixel array +int xs #I starting pixel index in src +int src_maxval #I max pixel value in src mask +int px_dst[ARB] #O destination pixel array +int ds #I starting pixel index in dst +int dst_maxval #I max pixel value in dst mask +int npix #I number of pixels to convert +int rop #I rasterop + +pointer sp, src +int opcode, i +int data, ceil, src_value +int and(), or(), xor(), not() +define out_ 91 + +begin + opcode = R_OPCODE(rop) + data = R_DATA(rop) + ceil = 0 + + # Pixel value to be used if input mask is boolean. + if (src_maxval == 1) { + src_value = data + if (src_value <= 0) + src_value = dst_maxval + } + + # Handle the easy cases first. + switch (opcode) { + case PIX_CLR: + call aclri (px_dst[ds], npix) + return + case PIX_SET: + call amovki (data, px_dst[ds], npix) + goto out_ + case PIX_SRC: + if (src_maxval != 1) + call amovi (px_src[xs], px_dst[ds], npix) + else { + do i = 1, npix + if (px_src[xs+i-1] > 0) + px_dst[ds+i-1] = src_value + else + px_dst[ds+i-1] = 0 + } + + goto out_ + case PIX_DST: + return # no-op + } + + # Integer or boolean source mask? + if (src_maxval != 1) { + # Integer source mask; operate directly on source mask. + + switch (opcode) { + case PIX_NOTSRC: + do i = 1, npix + px_dst[ds+i-1] = not (px_src[xs+i-1]) + case PIX_NOTDST: + do i = 1, npix + px_dst[ds+i-1] = not (px_dst[xs+i-1]) + + case PIX_SRC_AND_DST: + do i = 1, npix + px_dst[ds+i-1] = and (px_src[xs+i-1], px_dst[ds+i-1]) + case PIX_SRC_OR_DST: + do i = 1, npix + px_dst[ds+i-1] = or (px_src[xs+i-1], px_dst[ds+i-1]) + case PIX_SRC_XOR_DST: + do i = 1, npix + px_dst[ds+i-1] = xor (px_src[xs+i-1], px_dst[ds+i-1]) + + case PIX_SRC_AND_NOTDST: + do i = 1, npix + px_dst[ds+i-1] = and (px_src[xs+i-1], not(px_dst[ds+i-1])) + case PIX_SRC_OR_NOTDST: + do i = 1, npix + px_dst[ds+i-1] = or (px_src[xs+i-1], not(px_dst[ds+i-1])) + case PIX_NOTSRC_AND_DST: + do i = 1, npix + px_dst[ds+i-1] = and (not(px_src[xs+i-1]), px_dst[ds+i-1]) + case PIX_NOTSRC_OR_DST: + do i = 1, npix + px_dst[ds+i-1] = or (not(px_src[xs+i-1]), px_dst[ds+i-1]) + + case PIX_NOT_SRC_AND_DST: + do i = 1, npix + px_dst[ds+i-1] = not (and (px_src[xs+i-1], px_dst[ds+i-1])) + case PIX_NOT_SRC_OR_DST: + do i = 1, npix + px_dst[ds+i-1] = not ( or (px_src[xs+i-1], px_dst[ds+i-1])) + case PIX_NOT_SRC_XOR_DST: + do i = 1, npix + px_dst[ds+i-1] = not (xor (px_src[xs+i-1], px_dst[ds+i-1])) + } + + } else { + # Boolean source mask; use integer DATA value from ROP if source + # mask pixel is set. + + call smark (sp) + call salloc (src, npix, TY_INT) + + do i = 1, npix + if (px_src[xs+i-1] > 0) + Memi[src+i-1] = src_value + else + Memi[src+i-1] = 0 + + switch (opcode) { + case PIX_NOTSRC: + do i = 1, npix + px_dst[ds+i-1] = not (Memi[src+i-1]) + case PIX_NOTDST: + do i = 1, npix + px_dst[ds+i-1] = not (px_dst[xs+i-1]) + + case PIX_SRC_AND_DST: + do i = 1, npix + px_dst[ds+i-1] = and (Memi[src+i-1], px_dst[ds+i-1]) + case PIX_SRC_OR_DST: + do i = 1, npix + px_dst[ds+i-1] = or (Memi[src+i-1], px_dst[ds+i-1]) + case PIX_SRC_XOR_DST: + do i = 1, npix + px_dst[ds+i-1] = xor (Memi[src+i-1], px_dst[ds+i-1]) + + case PIX_SRC_AND_NOTDST: + do i = 1, npix + px_dst[ds+i-1] = and (Memi[src+i-1], not(px_dst[ds+i-1])) + case PIX_SRC_OR_NOTDST: + do i = 1, npix + px_dst[ds+i-1] = or (Memi[src+i-1], not(px_dst[ds+i-1])) + case PIX_NOTSRC_AND_DST: + do i = 1, npix + px_dst[ds+i-1] = and (not(Memi[src+i-1]), px_dst[ds+i-1]) + case PIX_NOTSRC_OR_DST: + do i = 1, npix + px_dst[ds+i-1] = or (not(Memi[src+i-1]), px_dst[ds+i-1]) + + case PIX_NOT_SRC_AND_DST: + do i = 1, npix + px_dst[ds+i-1] = not (and (Memi[src+i-1], px_dst[ds+i-1])) + case PIX_NOT_SRC_OR_DST: + do i = 1, npix + px_dst[ds+i-1] = not ( or (Memi[src+i-1], px_dst[ds+i-1])) + case PIX_NOT_SRC_XOR_DST: + do i = 1, npix + px_dst[ds+i-1] = not (xor (Memi[src+i-1], px_dst[ds+i-1])) + } + + call sfree (sp) + } +out_ + # If writing to an integer mask, mask the data to the indicated max + # value (necessary to avoid very large values if any NOT operations + # occurred). If writing to a boolean mask, map positive integer mask + # values to 1. + + if (dst_maxval == 1) { + data = 1 + call argti (px_dst[ds], npix, ceil, data) + } else if (dst_maxval > 1) { + data = dst_maxval + call aandki (px_dst[ds], data, px_dst[ds], npix) + } +end diff --git a/sys/plio/tf/plpropl.x b/sys/plio/tf/plpropl.x new file mode 100644 index 00000000..1aa3b21c --- /dev/null +++ b/sys/plio/tf/plpropl.x @@ -0,0 +1,177 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_PIXROP -- Rasterop between source and destination pixel arrays. + +procedure pl_pixropl (px_src,xs,src_maxval, px_dst,ds,dst_maxval, npix, rop) + +long px_src[ARB] #I source pixel array +int xs #I starting pixel index in src +int src_maxval #I max pixel value in src mask +long px_dst[ARB] #O destination pixel array +int ds #I starting pixel index in dst +int dst_maxval #I max pixel value in dst mask +int npix #I number of pixels to convert +int rop #I rasterop + +pointer sp, src +int opcode, i +long data, ceil, src_value +int and(), or(), xor(), not() +define out_ 91 + +begin + opcode = R_OPCODE(rop) + data = R_DATA(rop) + ceil = 0 + + # Pixel value to be used if input mask is boolean. + if (src_maxval == 1) { + src_value = data + if (src_value <= 0) + src_value = dst_maxval + } + + # Handle the easy cases first. + switch (opcode) { + case PIX_CLR: + call aclrl (px_dst[ds], npix) + return + case PIX_SET: + call amovkl (data, px_dst[ds], npix) + goto out_ + case PIX_SRC: + if (src_maxval != 1) + call amovl (px_src[xs], px_dst[ds], npix) + else { + do i = 1, npix + if (px_src[xs+i-1] > 0) + px_dst[ds+i-1] = src_value + else + px_dst[ds+i-1] = 0 + } + + goto out_ + case PIX_DST: + return # no-op + } + + # Integer or boolean source mask? + if (src_maxval != 1) { + # Integer source mask; operate directly on source mask. + + switch (opcode) { + case PIX_NOTSRC: + do i = 1, npix + px_dst[ds+i-1] = not (px_src[xs+i-1]) + case PIX_NOTDST: + do i = 1, npix + px_dst[ds+i-1] = not (px_dst[xs+i-1]) + + case PIX_SRC_AND_DST: + do i = 1, npix + px_dst[ds+i-1] = and (px_src[xs+i-1], px_dst[ds+i-1]) + case PIX_SRC_OR_DST: + do i = 1, npix + px_dst[ds+i-1] = or (px_src[xs+i-1], px_dst[ds+i-1]) + case PIX_SRC_XOR_DST: + do i = 1, npix + px_dst[ds+i-1] = xor (px_src[xs+i-1], px_dst[ds+i-1]) + + case PIX_SRC_AND_NOTDST: + do i = 1, npix + px_dst[ds+i-1] = and (px_src[xs+i-1], not(px_dst[ds+i-1])) + case PIX_SRC_OR_NOTDST: + do i = 1, npix + px_dst[ds+i-1] = or (px_src[xs+i-1], not(px_dst[ds+i-1])) + case PIX_NOTSRC_AND_DST: + do i = 1, npix + px_dst[ds+i-1] = and (not(px_src[xs+i-1]), px_dst[ds+i-1]) + case PIX_NOTSRC_OR_DST: + do i = 1, npix + px_dst[ds+i-1] = or (not(px_src[xs+i-1]), px_dst[ds+i-1]) + + case PIX_NOT_SRC_AND_DST: + do i = 1, npix + px_dst[ds+i-1] = not (and (px_src[xs+i-1], px_dst[ds+i-1])) + case PIX_NOT_SRC_OR_DST: + do i = 1, npix + px_dst[ds+i-1] = not ( or (px_src[xs+i-1], px_dst[ds+i-1])) + case PIX_NOT_SRC_XOR_DST: + do i = 1, npix + px_dst[ds+i-1] = not (xor (px_src[xs+i-1], px_dst[ds+i-1])) + } + + } else { + # Boolean source mask; use integer DATA value from ROP if source + # mask pixel is set. + + call smark (sp) + call salloc (src, npix, TY_LONG) + + do i = 1, npix + if (px_src[xs+i-1] > 0) + Meml[src+i-1] = src_value + else + Meml[src+i-1] = 0 + + switch (opcode) { + case PIX_NOTSRC: + do i = 1, npix + px_dst[ds+i-1] = not (Meml[src+i-1]) + case PIX_NOTDST: + do i = 1, npix + px_dst[ds+i-1] = not (px_dst[xs+i-1]) + + case PIX_SRC_AND_DST: + do i = 1, npix + px_dst[ds+i-1] = and (Meml[src+i-1], px_dst[ds+i-1]) + case PIX_SRC_OR_DST: + do i = 1, npix + px_dst[ds+i-1] = or (Meml[src+i-1], px_dst[ds+i-1]) + case PIX_SRC_XOR_DST: + do i = 1, npix + px_dst[ds+i-1] = xor (Meml[src+i-1], px_dst[ds+i-1]) + + case PIX_SRC_AND_NOTDST: + do i = 1, npix + px_dst[ds+i-1] = and (Meml[src+i-1], not(px_dst[ds+i-1])) + case PIX_SRC_OR_NOTDST: + do i = 1, npix + px_dst[ds+i-1] = or (Meml[src+i-1], not(px_dst[ds+i-1])) + case PIX_NOTSRC_AND_DST: + do i = 1, npix + px_dst[ds+i-1] = and (not(Meml[src+i-1]), px_dst[ds+i-1]) + case PIX_NOTSRC_OR_DST: + do i = 1, npix + px_dst[ds+i-1] = or (not(Meml[src+i-1]), px_dst[ds+i-1]) + + case PIX_NOT_SRC_AND_DST: + do i = 1, npix + px_dst[ds+i-1] = not (and (Meml[src+i-1], px_dst[ds+i-1])) + case PIX_NOT_SRC_OR_DST: + do i = 1, npix + px_dst[ds+i-1] = not ( or (Meml[src+i-1], px_dst[ds+i-1])) + case PIX_NOT_SRC_XOR_DST: + do i = 1, npix + px_dst[ds+i-1] = not (xor (Meml[src+i-1], px_dst[ds+i-1])) + } + + call sfree (sp) + } +out_ + # If writing to an integer mask, mask the data to the indicated max + # value (necessary to avoid very large values if any NOT operations + # occurred). If writing to a boolean mask, map positive integer mask + # values to 1. + + if (dst_maxval == 1) { + data = 1 + call argtl (px_dst[ds], npix, ceil, data) + } else if (dst_maxval > 1) { + data = dst_maxval + call aandkl (px_dst[ds], data, px_dst[ds], npix) + } +end diff --git a/sys/plio/tf/plprops.x b/sys/plio/tf/plprops.x new file mode 100644 index 00000000..f06baadb --- /dev/null +++ b/sys/plio/tf/plprops.x @@ -0,0 +1,177 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_PIXROP -- Rasterop between source and destination pixel arrays. + +procedure pl_pixrops (px_src,xs,src_maxval, px_dst,ds,dst_maxval, npix, rop) + +short px_src[ARB] #I source pixel array +int xs #I starting pixel index in src +int src_maxval #I max pixel value in src mask +short px_dst[ARB] #O destination pixel array +int ds #I starting pixel index in dst +int dst_maxval #I max pixel value in dst mask +int npix #I number of pixels to convert +int rop #I rasterop + +pointer sp, src +int opcode, i +short data, ceil, src_value +int and(), or(), xor(), not() +define out_ 91 + +begin + opcode = R_OPCODE(rop) + data = R_DATA(rop) + ceil = 0 + + # Pixel value to be used if input mask is boolean. + if (src_maxval == 1) { + src_value = data + if (src_value <= 0) + src_value = dst_maxval + } + + # Handle the easy cases first. + switch (opcode) { + case PIX_CLR: + call aclrs (px_dst[ds], npix) + return + case PIX_SET: + call amovks (data, px_dst[ds], npix) + goto out_ + case PIX_SRC: + if (src_maxval != 1) + call amovs (px_src[xs], px_dst[ds], npix) + else { + do i = 1, npix + if (px_src[xs+i-1] > 0) + px_dst[ds+i-1] = src_value + else + px_dst[ds+i-1] = 0 + } + + goto out_ + case PIX_DST: + return # no-op + } + + # Integer or boolean source mask? + if (src_maxval != 1) { + # Integer source mask; operate directly on source mask. + + switch (opcode) { + case PIX_NOTSRC: + do i = 1, npix + px_dst[ds+i-1] = not (px_src[xs+i-1]) + case PIX_NOTDST: + do i = 1, npix + px_dst[ds+i-1] = not (px_dst[xs+i-1]) + + case PIX_SRC_AND_DST: + do i = 1, npix + px_dst[ds+i-1] = and (px_src[xs+i-1], px_dst[ds+i-1]) + case PIX_SRC_OR_DST: + do i = 1, npix + px_dst[ds+i-1] = or (px_src[xs+i-1], px_dst[ds+i-1]) + case PIX_SRC_XOR_DST: + do i = 1, npix + px_dst[ds+i-1] = xor (px_src[xs+i-1], px_dst[ds+i-1]) + + case PIX_SRC_AND_NOTDST: + do i = 1, npix + px_dst[ds+i-1] = and (px_src[xs+i-1], not(px_dst[ds+i-1])) + case PIX_SRC_OR_NOTDST: + do i = 1, npix + px_dst[ds+i-1] = or (px_src[xs+i-1], not(px_dst[ds+i-1])) + case PIX_NOTSRC_AND_DST: + do i = 1, npix + px_dst[ds+i-1] = and (not(px_src[xs+i-1]), px_dst[ds+i-1]) + case PIX_NOTSRC_OR_DST: + do i = 1, npix + px_dst[ds+i-1] = or (not(px_src[xs+i-1]), px_dst[ds+i-1]) + + case PIX_NOT_SRC_AND_DST: + do i = 1, npix + px_dst[ds+i-1] = not (and (px_src[xs+i-1], px_dst[ds+i-1])) + case PIX_NOT_SRC_OR_DST: + do i = 1, npix + px_dst[ds+i-1] = not ( or (px_src[xs+i-1], px_dst[ds+i-1])) + case PIX_NOT_SRC_XOR_DST: + do i = 1, npix + px_dst[ds+i-1] = not (xor (px_src[xs+i-1], px_dst[ds+i-1])) + } + + } else { + # Boolean source mask; use integer DATA value from ROP if source + # mask pixel is set. + + call smark (sp) + call salloc (src, npix, TY_SHORT) + + do i = 1, npix + if (px_src[xs+i-1] > 0) + Mems[src+i-1] = src_value + else + Mems[src+i-1] = 0 + + switch (opcode) { + case PIX_NOTSRC: + do i = 1, npix + px_dst[ds+i-1] = not (Mems[src+i-1]) + case PIX_NOTDST: + do i = 1, npix + px_dst[ds+i-1] = not (px_dst[xs+i-1]) + + case PIX_SRC_AND_DST: + do i = 1, npix + px_dst[ds+i-1] = and (Mems[src+i-1], px_dst[ds+i-1]) + case PIX_SRC_OR_DST: + do i = 1, npix + px_dst[ds+i-1] = or (Mems[src+i-1], px_dst[ds+i-1]) + case PIX_SRC_XOR_DST: + do i = 1, npix + px_dst[ds+i-1] = xor (Mems[src+i-1], px_dst[ds+i-1]) + + case PIX_SRC_AND_NOTDST: + do i = 1, npix + px_dst[ds+i-1] = and (Mems[src+i-1], not(px_dst[ds+i-1])) + case PIX_SRC_OR_NOTDST: + do i = 1, npix + px_dst[ds+i-1] = or (Mems[src+i-1], not(px_dst[ds+i-1])) + case PIX_NOTSRC_AND_DST: + do i = 1, npix + px_dst[ds+i-1] = and (not(Mems[src+i-1]), px_dst[ds+i-1]) + case PIX_NOTSRC_OR_DST: + do i = 1, npix + px_dst[ds+i-1] = or (not(Mems[src+i-1]), px_dst[ds+i-1]) + + case PIX_NOT_SRC_AND_DST: + do i = 1, npix + px_dst[ds+i-1] = not (and (Mems[src+i-1], px_dst[ds+i-1])) + case PIX_NOT_SRC_OR_DST: + do i = 1, npix + px_dst[ds+i-1] = not ( or (Mems[src+i-1], px_dst[ds+i-1])) + case PIX_NOT_SRC_XOR_DST: + do i = 1, npix + px_dst[ds+i-1] = not (xor (Mems[src+i-1], px_dst[ds+i-1])) + } + + call sfree (sp) + } +out_ + # If writing to an integer mask, mask the data to the indicated max + # value (necessary to avoid very large values if any NOT operations + # occurred). If writing to a boolean mask, map positive integer mask + # values to 1. + + if (dst_maxval == 1) { + data = 1 + call argts (px_dst[ds], npix, ceil, data) + } else if (dst_maxval > 1) { + data = dst_maxval + call aandks (px_dst[ds], data, px_dst[ds], npix) + } +end diff --git a/sys/plio/tf/plr2li.x b/sys/plio/tf/plr2li.x new file mode 100644 index 00000000..f6fb6c79 --- /dev/null +++ b/sys/plio/tf/plr2li.x @@ -0,0 +1,130 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_R2L -- Convert a range list to a line list. The length of the output +# line list is returned as the function value. + +int procedure pl_r2li (rl_src, xs, ll_dst, npix) + +int rl_src[3,ARB] #I input range list +int xs #I starting pixel index in range list +short ll_dst[ARB] #O destination line list +int npix #I number of pixels to convert + +int hi, pv +int last, xe, x1, x2, iz, op, np, nz, nr, dv, v, i +define done_ 91 + +begin + # No input pixels? + nr = RL_LEN(rl_src) + if (npix <= 0 || nr <= 0) + return (0) + + # Initialize the linelist header. + LL_VERSION(ll_dst) = LL_CURVERSION + LL_HDRLEN(ll_dst) = LL_CURHDRLEN + LL_NREFS(ll_dst) = 0 + LL_SETBLEN(ll_dst,0) + + xe = xs + npix - 1 + op = LL_CURHDRLEN + 1 + iz = xs + hi = 1 + + # Process the array of range lists. + do i = RL_FIRST, nr + 1 { + if (i <= nr) { + # Load next range. + x1 = rl_src[1,i] + np = rl_src[2,i] + pv = rl_src[3,i] + x2 = x1 + np - 1 + last = x2 + + # Get an inbounds range. + if (x1 > xe) + break + else if (xs > x2) + next + else if (x1 < xs) + x1 = xs + else if (x2 > xe) + x2 = xe + + # Go again if nothing inbounds. + nz = x1 - iz + np = x2 - x1 + 1 + if (np <= 0) + next + + } else if (iz < xe) { + # At end of input range list, but need to output a ZN. + nz = xe - iz + 1 + np = 0 + pv = 0 + } else + break + + # Encode an instruction to regenerate the current range I0-IP + # of N data values of nonzero level PV. In the most complex case + # we must update the high value and output a range of zeros, + # followed by a range of NP high values. If NP is 1, we can + # probably use a PN or [ID]S instruction to save space. + + # Change the high value? + if (pv > 0) { + dv = pv - hi + if (dv != 0) { + # Output IH or DH instruction? + hi = pv + if (abs(dv) > I_DATAMAX) { + ll_dst[op] = M_SH + and (int(pv), I_DATAMAX) + op = op + 1 + ll_dst[op] = pv / I_SHIFT + op = op + 1 + } else { + if (dv < 0) + ll_dst[op] = M_DH + (-dv) + else + ll_dst[op] = M_IH + dv + op = op + 1 + + # Convert to IS or DS if range is a single pixel. + if (np == 1 && nz == 0) { + v = ll_dst[op-1] + ll_dst[op-1] = or (v, M_MOVE) + goto done_ + } + } + } + } + + # Output range of zeros to catch up to current range? + if (nz > 0) { + # Output the ZN instruction. + for (; nz > 0; nz = nz - (I_DATAMAX-1)) { + ll_dst[op] = M_ZN + min(I_DATAMAX-1,nz) + op = op + 1 + } + # Convert to PN if range is a single pixel. + if (np == 1 && pv > 0 && x2 == last) { + ll_dst[op-1] = ll_dst[op-1] + M_PN + 1 + goto done_ + } + } + + # The only thing left is the HN instruction if we get here. + for (; np > 0; np = np - I_DATAMAX) { + ll_dst[op] = M_HN + min(I_DATAMAX,np) + op = op + 1 + } +done_ + iz = x2 + 1 + } + + LL_SETLEN(ll_dst, op - 1) + return (op - 1) +end diff --git a/sys/plio/tf/plr2ll.x b/sys/plio/tf/plr2ll.x new file mode 100644 index 00000000..b21d6678 --- /dev/null +++ b/sys/plio/tf/plr2ll.x @@ -0,0 +1,130 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_R2L -- Convert a range list to a line list. The length of the output +# line list is returned as the function value. + +int procedure pl_r2ll (rl_src, xs, ll_dst, npix) + +long rl_src[3,ARB] #I input range list +int xs #I starting pixel index in range list +short ll_dst[ARB] #O destination line list +int npix #I number of pixels to convert + +long hi, pv +int last, xe, x1, x2, iz, op, np, nz, nr, dv, v, i +define done_ 91 + +begin + # No input pixels? + nr = RL_LEN(rl_src) + if (npix <= 0 || nr <= 0) + return (0) + + # Initialize the linelist header. + LL_VERSION(ll_dst) = LL_CURVERSION + LL_HDRLEN(ll_dst) = LL_CURHDRLEN + LL_NREFS(ll_dst) = 0 + LL_SETBLEN(ll_dst,0) + + xe = xs + npix - 1 + op = LL_CURHDRLEN + 1 + iz = xs + hi = 1 + + # Process the array of range lists. + do i = RL_FIRST, nr + 1 { + if (i <= nr) { + # Load next range. + x1 = rl_src[1,i] + np = rl_src[2,i] + pv = rl_src[3,i] + x2 = x1 + np - 1 + last = x2 + + # Get an inbounds range. + if (x1 > xe) + break + else if (xs > x2) + next + else if (x1 < xs) + x1 = xs + else if (x2 > xe) + x2 = xe + + # Go again if nothing inbounds. + nz = x1 - iz + np = x2 - x1 + 1 + if (np <= 0) + next + + } else if (iz < xe) { + # At end of input range list, but need to output a ZN. + nz = xe - iz + 1 + np = 0 + pv = 0 + } else + break + + # Encode an instruction to regenerate the current range I0-IP + # of N data values of nonzero level PV. In the most complex case + # we must update the high value and output a range of zeros, + # followed by a range of NP high values. If NP is 1, we can + # probably use a PN or [ID]S instruction to save space. + + # Change the high value? + if (pv > 0) { + dv = pv - hi + if (dv != 0) { + # Output IH or DH instruction? + hi = pv + if (abs(dv) > I_DATAMAX) { + ll_dst[op] = M_SH + and (int(pv), I_DATAMAX) + op = op + 1 + ll_dst[op] = pv / I_SHIFT + op = op + 1 + } else { + if (dv < 0) + ll_dst[op] = M_DH + (-dv) + else + ll_dst[op] = M_IH + dv + op = op + 1 + + # Convert to IS or DS if range is a single pixel. + if (np == 1 && nz == 0) { + v = ll_dst[op-1] + ll_dst[op-1] = or (v, M_MOVE) + goto done_ + } + } + } + } + + # Output range of zeros to catch up to current range? + if (nz > 0) { + # Output the ZN instruction. + for (; nz > 0; nz = nz - (I_DATAMAX-1)) { + ll_dst[op] = M_ZN + min(I_DATAMAX-1,nz) + op = op + 1 + } + # Convert to PN if range is a single pixel. + if (np == 1 && pv > 0 && x2 == last) { + ll_dst[op-1] = ll_dst[op-1] + M_PN + 1 + goto done_ + } + } + + # The only thing left is the HN instruction if we get here. + for (; np > 0; np = np - I_DATAMAX) { + ll_dst[op] = M_HN + min(I_DATAMAX,np) + op = op + 1 + } +done_ + iz = x2 + 1 + } + + LL_SETLEN(ll_dst, op - 1) + return (op - 1) +end diff --git a/sys/plio/tf/plr2ls.x b/sys/plio/tf/plr2ls.x new file mode 100644 index 00000000..6aceca17 --- /dev/null +++ b/sys/plio/tf/plr2ls.x @@ -0,0 +1,130 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_R2L -- Convert a range list to a line list. The length of the output +# line list is returned as the function value. + +int procedure pl_r2ls (rl_src, xs, ll_dst, npix) + +short rl_src[3,ARB] #I input range list +int xs #I starting pixel index in range list +short ll_dst[ARB] #O destination line list +int npix #I number of pixels to convert + +short hi, pv +int last, xe, x1, x2, iz, op, np, nz, nr, dv, v, i +define done_ 91 + +begin + # No input pixels? + nr = RL_LEN(rl_src) + if (npix <= 0 || nr <= 0) + return (0) + + # Initialize the linelist header. + LL_VERSION(ll_dst) = LL_CURVERSION + LL_HDRLEN(ll_dst) = LL_CURHDRLEN + LL_NREFS(ll_dst) = 0 + LL_SETBLEN(ll_dst,0) + + xe = xs + npix - 1 + op = LL_CURHDRLEN + 1 + iz = xs + hi = 1 + + # Process the array of range lists. + do i = RL_FIRST, nr + 1 { + if (i <= nr) { + # Load next range. + x1 = rl_src[1,i] + np = rl_src[2,i] + pv = rl_src[3,i] + x2 = x1 + np - 1 + last = x2 + + # Get an inbounds range. + if (x1 > xe) + break + else if (xs > x2) + next + else if (x1 < xs) + x1 = xs + else if (x2 > xe) + x2 = xe + + # Go again if nothing inbounds. + nz = x1 - iz + np = x2 - x1 + 1 + if (np <= 0) + next + + } else if (iz < xe) { + # At end of input range list, but need to output a ZN. + nz = xe - iz + 1 + np = 0 + pv = 0 + } else + break + + # Encode an instruction to regenerate the current range I0-IP + # of N data values of nonzero level PV. In the most complex case + # we must update the high value and output a range of zeros, + # followed by a range of NP high values. If NP is 1, we can + # probably use a PN or [ID]S instruction to save space. + + # Change the high value? + if (pv > 0) { + dv = pv - hi + if (dv != 0) { + # Output IH or DH instruction? + hi = pv + if (abs(dv) > I_DATAMAX) { + ll_dst[op] = M_SH + and (int(pv), I_DATAMAX) + op = op + 1 + ll_dst[op] = pv / I_SHIFT + op = op + 1 + } else { + if (dv < 0) + ll_dst[op] = M_DH + (-dv) + else + ll_dst[op] = M_IH + dv + op = op + 1 + + # Convert to IS or DS if range is a single pixel. + if (np == 1 && nz == 0) { + v = ll_dst[op-1] + ll_dst[op-1] = or (v, M_MOVE) + goto done_ + } + } + } + } + + # Output range of zeros to catch up to current range? + if (nz > 0) { + # Output the ZN instruction. + for (; nz > 0; nz = nz - (I_DATAMAX-1)) { + ll_dst[op] = M_ZN + min(I_DATAMAX-1,nz) + op = op + 1 + } + # Convert to PN if range is a single pixel. + if (np == 1 && pv > 0 && x2 == last) { + ll_dst[op-1] = ll_dst[op-1] + M_PN + 1 + goto done_ + } + } + + # The only thing left is the HN instruction if we get here. + for (; np > 0; np = np - I_DATAMAX) { + ll_dst[op] = M_HN + min(I_DATAMAX,np) + op = op + 1 + } +done_ + iz = x2 + 1 + } + + LL_SETLEN(ll_dst, op - 1) + return (op - 1) +end diff --git a/sys/plio/tf/plr2pi.x b/sys/plio/tf/plr2pi.x new file mode 100644 index 00000000..57db5b63 --- /dev/null +++ b/sys/plio/tf/plr2pi.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_R2P -- Convert a range list to a pixel array. The number of pixels +# output (always npix) is returned as the function value. + +int procedure pl_r2pi (rl_src, xs, px_dst, npix) + +int rl_src[3,ARB] #I input range list +int xs #I starting pixel index in range list +int px_dst[ARB] #O output pixel array +int npix #I number of pixels to convert + +int hi, pv +int xe, x1, x2, iz, op, np, nz, nr, i, j +define done_ 91 + +begin + # No input pixels? + nr = RL_LEN(rl_src) + if (npix <= 0 || nr <= 0) + return (0) + + xe = xs + npix - 1 + iz = xs + op = 1 + hi = 1 + + # Process the array of range lists. + do i = RL_FIRST, nr { + x1 = rl_src[1,i] + np = rl_src[2,i] + pv = rl_src[3,i] + x2 = x1 + np - 1 + + # Get an inbounds range. + if (x1 > xe) + break + else if (xs > x2) + next + else if (x1 < xs) + x1 = xs + else if (x2 > xe) + x2 = xe + + nz = x1 - iz + np = x2 - x1 + 1 + if (np <= 0) + next + + # Output range of zeros to catch up to current range? + if (nz > 0) { + do j = 1, nz + px_dst[op+j-1] = 0 + op = op + nz + } + + # Output the pixels. + do j = 1, np + px_dst[op+j-1] = pv + op = op + np +done_ + x1 = x2 + 1 + iz = x1 + } + + # Zero any remaining output range. + do i = op, npix + px_dst[i] = 0 + + return (npix) +end diff --git a/sys/plio/tf/plr2pl.x b/sys/plio/tf/plr2pl.x new file mode 100644 index 00000000..763bb8d2 --- /dev/null +++ b/sys/plio/tf/plr2pl.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_R2P -- Convert a range list to a pixel array. The number of pixels +# output (always npix) is returned as the function value. + +int procedure pl_r2pl (rl_src, xs, px_dst, npix) + +long rl_src[3,ARB] #I input range list +int xs #I starting pixel index in range list +long px_dst[ARB] #O output pixel array +int npix #I number of pixels to convert + +long hi, pv +int xe, x1, x2, iz, op, np, nz, nr, i, j +define done_ 91 + +begin + # No input pixels? + nr = RL_LEN(rl_src) + if (npix <= 0 || nr <= 0) + return (0) + + xe = xs + npix - 1 + iz = xs + op = 1 + hi = 1 + + # Process the array of range lists. + do i = RL_FIRST, nr { + x1 = rl_src[1,i] + np = rl_src[2,i] + pv = rl_src[3,i] + x2 = x1 + np - 1 + + # Get an inbounds range. + if (x1 > xe) + break + else if (xs > x2) + next + else if (x1 < xs) + x1 = xs + else if (x2 > xe) + x2 = xe + + nz = x1 - iz + np = x2 - x1 + 1 + if (np <= 0) + next + + # Output range of zeros to catch up to current range? + if (nz > 0) { + do j = 1, nz + px_dst[op+j-1] = 0 + op = op + nz + } + + # Output the pixels. + do j = 1, np + px_dst[op+j-1] = pv + op = op + np +done_ + x1 = x2 + 1 + iz = x1 + } + + # Zero any remaining output range. + do i = op, npix + px_dst[i] = 0 + + return (npix) +end diff --git a/sys/plio/tf/plr2ps.x b/sys/plio/tf/plr2ps.x new file mode 100644 index 00000000..ecba387d --- /dev/null +++ b/sys/plio/tf/plr2ps.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_R2P -- Convert a range list to a pixel array. The number of pixels +# output (always npix) is returned as the function value. + +int procedure pl_r2ps (rl_src, xs, px_dst, npix) + +short rl_src[3,ARB] #I input range list +int xs #I starting pixel index in range list +short px_dst[ARB] #O output pixel array +int npix #I number of pixels to convert + +short hi, pv +int xe, x1, x2, iz, op, np, nz, nr, i, j +define done_ 91 + +begin + # No input pixels? + nr = RL_LEN(rl_src) + if (npix <= 0 || nr <= 0) + return (0) + + xe = xs + npix - 1 + iz = xs + op = 1 + hi = 1 + + # Process the array of range lists. + do i = RL_FIRST, nr { + x1 = rl_src[1,i] + np = rl_src[2,i] + pv = rl_src[3,i] + x2 = x1 + np - 1 + + # Get an inbounds range. + if (x1 > xe) + break + else if (xs > x2) + next + else if (x1 < xs) + x1 = xs + else if (x2 > xe) + x2 = xe + + nz = x1 - iz + np = x2 - x1 + 1 + if (np <= 0) + next + + # Output range of zeros to catch up to current range? + if (nz > 0) { + do j = 1, nz + px_dst[op+j-1] = 0 + op = op + nz + } + + # Output the pixels. + do j = 1, np + px_dst[op+j-1] = pv + op = op + np +done_ + x1 = x2 + 1 + iz = x1 + } + + # Zero any remaining output range. + do i = op, npix + px_dst[i] = 0 + + return (npix) +end diff --git a/sys/plio/tf/plreqi.x b/sys/plio/tf/plreqi.x new file mode 100644 index 00000000..0307efea --- /dev/null +++ b/sys/plio/tf/plreqi.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PLR_EQUAL -- Compare two range lists for equality. + +bool procedure plr_equali (r1, r2) + +int r1[3,ARB] #I range list 1 +int r2[3,ARB] #I range list 2 + +int i +int len1, len2 + +begin + len1 = RL_LEN(r1) + len2 = RL_LEN(r2) + + if (len1 != len2) + return (false) + + do i = RL_FIRST, len1 + if (r1[1,i] != r2[1,i] || r1[2,i] != r2[2,i] || r1[3,i] != r2[3,i]) + return (false) + + return (true) +end diff --git a/sys/plio/tf/plreql.x b/sys/plio/tf/plreql.x new file mode 100644 index 00000000..1fb76d6a --- /dev/null +++ b/sys/plio/tf/plreql.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PLR_EQUAL -- Compare two range lists for equality. + +bool procedure plr_equall (r1, r2) + +long r1[3,ARB] #I range list 1 +long r2[3,ARB] #I range list 2 + +int i +int len1, len2 + +begin + len1 = RL_LEN(r1) + len2 = RL_LEN(r2) + + if (len1 != len2) + return (false) + + do i = RL_FIRST, len1 + if (r1[1,i] != r2[1,i] || r1[2,i] != r2[2,i] || r1[3,i] != r2[3,i]) + return (false) + + return (true) +end diff --git a/sys/plio/tf/plreqs.x b/sys/plio/tf/plreqs.x new file mode 100644 index 00000000..b44bf4da --- /dev/null +++ b/sys/plio/tf/plreqs.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PLR_EQUAL -- Compare two range lists for equality. + +bool procedure plr_equals (r1, r2) + +short r1[3,ARB] #I range list 1 +short r2[3,ARB] #I range list 2 + +int i +int len1, len2 + +begin + len1 = RL_LEN(r1) + len2 = RL_LEN(r2) + + if (len1 != len2) + return (false) + + do i = RL_FIRST, len1 + if (r1[1,i] != r2[1,i] || r1[2,i] != r2[2,i] || r1[3,i] != r2[3,i]) + return (false) + + return (true) +end diff --git a/sys/plio/tf/plrpri.x b/sys/plio/tf/plrpri.x new file mode 100644 index 00000000..a74e7791 --- /dev/null +++ b/sys/plio/tf/plrpri.x @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PLR_PRINT -- Print a range list on the given output stream. + +procedure plr_printi (rl, fd, label, firstcol, maxcol) + +int rl[3,ARB] #I range list +int fd #I output file +char label[ARB] #I line label +int firstcol #I first column for output +int maxcol #I width of formatted output + +pointer sp, buf +int col, rn, r_len, x, n, pv +int strlen() + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + # Output the line label and advance to the first column. If the label + # extends beyond the first column, start a new line. + + call putline (fd, label) + col = strlen (label) + 1 + if (col > firstcol) + call pl_debugout (fd, "", col, firstcol, maxcol) + + r_len = RL_LEN(rl) + + # Decode the range list proper. + do rn = RL_FIRST, r_len { + x = RL_X(rl,rn) + n = RL_N(rl,rn) + pv = RL_V(rl,rn) + + if (n == 1) { + call sprintf (Memc[buf], SZ_LINE, "%d(%d)") + call pargi (x) + call pargi (pv) + } else { + call sprintf (Memc[buf], SZ_LINE, "%d-%d(%d)") + call pargi (x) + call pargi (x+n-1) + call pargi (pv) + } + + call pl_debugout (fd, Memc[buf], col, firstcol, maxcol) + } + + call pl_debugout (fd, "", col, firstcol, maxcol) + call sfree (sp) +end diff --git a/sys/plio/tf/plrprl.x b/sys/plio/tf/plrprl.x new file mode 100644 index 00000000..6357cd71 --- /dev/null +++ b/sys/plio/tf/plrprl.x @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PLR_PRINT -- Print a range list on the given output stream. + +procedure plr_printl (rl, fd, label, firstcol, maxcol) + +long rl[3,ARB] #I range list +int fd #I output file +char label[ARB] #I line label +int firstcol #I first column for output +int maxcol #I width of formatted output + +pointer sp, buf +int col, rn, r_len, x, n, pv +int strlen() + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + # Output the line label and advance to the first column. If the label + # extends beyond the first column, start a new line. + + call putline (fd, label) + col = strlen (label) + 1 + if (col > firstcol) + call pl_debugout (fd, "", col, firstcol, maxcol) + + r_len = RL_LEN(rl) + + # Decode the range list proper. + do rn = RL_FIRST, r_len { + x = RL_X(rl,rn) + n = RL_N(rl,rn) + pv = RL_V(rl,rn) + + if (n == 1) { + call sprintf (Memc[buf], SZ_LINE, "%d(%d)") + call pargi (x) + call pargi (pv) + } else { + call sprintf (Memc[buf], SZ_LINE, "%d-%d(%d)") + call pargi (x) + call pargi (x+n-1) + call pargi (pv) + } + + call pl_debugout (fd, Memc[buf], col, firstcol, maxcol) + } + + call pl_debugout (fd, "", col, firstcol, maxcol) + call sfree (sp) +end diff --git a/sys/plio/tf/plrprs.x b/sys/plio/tf/plrprs.x new file mode 100644 index 00000000..e055f851 --- /dev/null +++ b/sys/plio/tf/plrprs.x @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PLR_PRINT -- Print a range list on the given output stream. + +procedure plr_prints (rl, fd, label, firstcol, maxcol) + +short rl[3,ARB] #I range list +int fd #I output file +char label[ARB] #I line label +int firstcol #I first column for output +int maxcol #I width of formatted output + +pointer sp, buf +int col, rn, r_len, x, n, pv +int strlen() + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + # Output the line label and advance to the first column. If the label + # extends beyond the first column, start a new line. + + call putline (fd, label) + col = strlen (label) + 1 + if (col > firstcol) + call pl_debugout (fd, "", col, firstcol, maxcol) + + r_len = RL_LEN(rl) + + # Decode the range list proper. + do rn = RL_FIRST, r_len { + x = RL_X(rl,rn) + n = RL_N(rl,rn) + pv = RL_V(rl,rn) + + if (n == 1) { + call sprintf (Memc[buf], SZ_LINE, "%d(%d)") + call pargi (x) + call pargi (pv) + } else { + call sprintf (Memc[buf], SZ_LINE, "%d-%d(%d)") + call pargi (x) + call pargi (x+n-1) + call pargi (pv) + } + + call pl_debugout (fd, Memc[buf], col, firstcol, maxcol) + } + + call pl_debugout (fd, "", col, firstcol, maxcol) + call sfree (sp) +end diff --git a/sys/plio/tf/plrropi.x b/sys/plio/tf/plrropi.x new file mode 100644 index 00000000..72292323 --- /dev/null +++ b/sys/plio/tf/plrropi.x @@ -0,0 +1,195 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../plrseg.h" + +# PL_RANGEROP -- Rasterop operation between source and destination range lists. +# The indicated rasterop operation is performed upon the source and destination +# range lists, writing the result to RL_OUT, which is a copy of RL_DST except +# for the region affected by the rasterop operation (note that the destination +# range list cannot be edited in place since it may change size). + +procedure pl_rangeropi (rl_src, xs, src_maxval, + rl_dst, ds, dst_maxval, rl_out, npix, rop) + +int rl_src[3,ARB] #I source range list +int xs #I starting pixel index in src range list +int src_maxval #I max pixel value in src mask +int rl_dst[3,ARB] #I destination range list +int ds #I starting pixel index in dst range list +int dst_maxval #I max pixel value in dst mask +int rl_out[3,ARB] #O output list (edited version of rl_dst) +int npix #I number of pixels to convert +int rop #I rasterop + +bool need_src, need_dst, rop_enable +int data, src_value, v_src, v_dst, pv +int segsize, opcode, x, i, np, rn_o, p +int d_src[LEN_PLRDES], d_dst[LEN_PLRDES] + +begin + need_src = R_NEED_SRC(rop) + need_dst = R_NEED_DST(rop) + opcode = R_OPCODE(rop) + data = R_DATA(rop) + + # Pixel value to be used if input mask is boolean. + if (src_maxval == 1) { + src_value = data + if (src_value <= 0) + src_value = dst_maxval + } + + # Advance to the desired position in the source list, discarding + # the unused ranges. The point XS may lie within a range or in a + # zero area of the input line. + + if (need_src) { + x = 1 + plr_init (rl_src, d_src) + do i = 1, ARB { + np = min (plr_nleft(d_src), xs - x) + plr_getseg (rl_src, d_src, np, v_src) + x = x + np + if (x >= xs || np == 0) + break + } + } + + # Advance through both the source and destination lists, extracting + # line segments which have a constant value in each input list; the + # values for the two lists may differ. Apply the given rasterop to + # the source and destination pixel values and write each line segment + # as a range to the output list. If the ranges in the two input lists + # differ (randomly overlap) then the output list will generally be + # more fragmented, i.e., have more ranges of constant value. As each + # output range is generated compare it with the previous range to see + # if they can be joined, as applying a rasterop may cause two different + # ranges to have the same value. + + x = 1 + rn_o = RL_FIRST + segsize = ds - 1 + rop_enable = false + plr_init (rl_dst, d_dst) + + do i = 1, ARB { + # Set up for the next segment (before, in, and after the region to + # which the ROP applies), when the current segment is exhausted. + + if (segsize <= 0) + if (!rop_enable) { + # Begin processing central region. + segsize = npix + rop_enable = true + if (segsize <= 0) + next + } else { + # Begin processing final region. + segsize = ARB + rop_enable = false + } + + # Determine the length of the next output segment. This is the + # largest segment of constant value formed by the intersection of + # the two lists. If bounds checking has been properly performed + # then it should not be possible to see nleft=zero on either input + # list. Note that zeroed regions are valid data here. + + np = min (segsize, plr_nleft(d_dst)) + if (need_src && rop_enable && plr_nleft(d_src) > 0) + np = min (np, plr_nleft(d_src)) + if (np <= 0) + break + + # Get the segment value and advance the line pointers. We must + # read the DST list whether or not we will use the data, since + # the list pointer must be advanced NPIX pixels so that we may + # copy the remainder of the list after the loop. + + plr_getseg (rl_dst, d_dst, np, v_dst) + if (rop_enable) { + # Get v_src. + if (need_src) { + v_src = 0 + if (plr_nleft (d_src) > 0) + plr_getseg (rl_src, d_src, np, v_src) + + if (R_NOTSRC(rop)) { + v_src = not (v_src) + if (src_maxval != 0) + v_src = and (int(v_src), src_maxval) + } + + if (v_src != 0 && src_maxval == 1) + v_src = src_value + } + + # Get v_dst. + if (need_dst) { + if (R_NOTDST(rop)) { + v_dst = not (v_dst) + if (dst_maxval != 0) + v_dst = and (int(v_dst), dst_maxval) + } + } + + # Apply the rasterop. + switch (opcode) { + case PIX_CLR: + pv = 0 + case PIX_SET: + pv = data + case PIX_SRC, PIX_NOTSRC: + pv = v_src + case PIX_DST, PIX_NOTDST: + pv = v_dst + case PIX_SRC_AND_DST, PIX_SRC_AND_NOTDST, PIX_NOTSRC_AND_DST: + pv = and (v_src, v_dst) + case PIX_SRC_OR_DST, PIX_SRC_OR_NOTDST, PIX_NOTSRC_OR_DST: + pv = or (v_src, v_dst) + case PIX_SRC_XOR_DST: + pv = xor (v_src, v_dst) + case PIX_NOT_SRC_AND_DST: + pv = not (and (v_src, v_dst)) + case PIX_NOT_SRC_OR_DST: + pv = not (or (v_src, v_dst)) + case PIX_NOT_SRC_XOR_DST: + pv = not (xor (v_src, v_dst)) + } + + # Mask the high bits to prevent negative values, or map int + # to bool for the case of a boolean output mask. + + if (dst_maxval == 1 && pv != 0) + pv = 1 + else if (dst_maxval > 1) + pv = and (int(pv), dst_maxval) + + } else + pv = v_dst + + # Output a nonzero range. + if (pv > 0) { + p = rn_o - 1 + if (p >= RL_FIRST && + pv == rl_out[3,p] && x == rl_out[1,p] + rl_out[2,p]) { + # Merge new range with previous one. + rl_out[2,p] = rl_out[2,p] + np + } else { + rl_out[1,rn_o] = x + rl_out[2,rn_o] = np + rl_out[3,rn_o] = pv + rn_o = rn_o + 1 + } + } + + x = x + np + segsize = segsize - np + } + + # Update the range list header. + call amovi (rl_dst, rl_out, (RL_FIRST - 1) * 3) + RL_LEN(rl_out) = rn_o - 1 +end diff --git a/sys/plio/tf/plrropl.x b/sys/plio/tf/plrropl.x new file mode 100644 index 00000000..ec936e09 --- /dev/null +++ b/sys/plio/tf/plrropl.x @@ -0,0 +1,195 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../plrseg.h" + +# PL_RANGEROP -- Rasterop operation between source and destination range lists. +# The indicated rasterop operation is performed upon the source and destination +# range lists, writing the result to RL_OUT, which is a copy of RL_DST except +# for the region affected by the rasterop operation (note that the destination +# range list cannot be edited in place since it may change size). + +procedure pl_rangeropl (rl_src, xs, src_maxval, + rl_dst, ds, dst_maxval, rl_out, npix, rop) + +long rl_src[3,ARB] #I source range list +int xs #I starting pixel index in src range list +int src_maxval #I max pixel value in src mask +long rl_dst[3,ARB] #I destination range list +int ds #I starting pixel index in dst range list +int dst_maxval #I max pixel value in dst mask +long rl_out[3,ARB] #O output list (edited version of rl_dst) +int npix #I number of pixels to convert +int rop #I rasterop + +bool need_src, need_dst, rop_enable +long data, src_value, v_src, v_dst, pv +int segsize, opcode, x, i, np, rn_o, p +int d_src[LEN_PLRDES], d_dst[LEN_PLRDES] + +begin + need_src = R_NEED_SRC(rop) + need_dst = R_NEED_DST(rop) + opcode = R_OPCODE(rop) + data = R_DATA(rop) + + # Pixel value to be used if input mask is boolean. + if (src_maxval == 1) { + src_value = data + if (src_value <= 0) + src_value = dst_maxval + } + + # Advance to the desired position in the source list, discarding + # the unused ranges. The point XS may lie within a range or in a + # zero area of the input line. + + if (need_src) { + x = 1 + plr_init (rl_src, d_src) + do i = 1, ARB { + np = min (plr_nleft(d_src), xs - x) + plr_getseg (rl_src, d_src, np, v_src) + x = x + np + if (x >= xs || np == 0) + break + } + } + + # Advance through both the source and destination lists, extracting + # line segments which have a constant value in each input list; the + # values for the two lists may differ. Apply the given rasterop to + # the source and destination pixel values and write each line segment + # as a range to the output list. If the ranges in the two input lists + # differ (randomly overlap) then the output list will generally be + # more fragmented, i.e., have more ranges of constant value. As each + # output range is generated compare it with the previous range to see + # if they can be joined, as applying a rasterop may cause two different + # ranges to have the same value. + + x = 1 + rn_o = RL_FIRST + segsize = ds - 1 + rop_enable = false + plr_init (rl_dst, d_dst) + + do i = 1, ARB { + # Set up for the next segment (before, in, and after the region to + # which the ROP applies), when the current segment is exhausted. + + if (segsize <= 0) + if (!rop_enable) { + # Begin processing central region. + segsize = npix + rop_enable = true + if (segsize <= 0) + next + } else { + # Begin processing final region. + segsize = ARB + rop_enable = false + } + + # Determine the length of the next output segment. This is the + # largest segment of constant value formed by the intersection of + # the two lists. If bounds checking has been properly performed + # then it should not be possible to see nleft=zero on either input + # list. Note that zeroed regions are valid data here. + + np = min (segsize, plr_nleft(d_dst)) + if (need_src && rop_enable && plr_nleft(d_src) > 0) + np = min (np, plr_nleft(d_src)) + if (np <= 0) + break + + # Get the segment value and advance the line pointers. We must + # read the DST list whether or not we will use the data, since + # the list pointer must be advanced NPIX pixels so that we may + # copy the remainder of the list after the loop. + + plr_getseg (rl_dst, d_dst, np, v_dst) + if (rop_enable) { + # Get v_src. + if (need_src) { + v_src = 0 + if (plr_nleft (d_src) > 0) + plr_getseg (rl_src, d_src, np, v_src) + + if (R_NOTSRC(rop)) { + v_src = not (v_src) + if (src_maxval != 0) + v_src = and (int(v_src), src_maxval) + } + + if (v_src != 0 && src_maxval == 1) + v_src = src_value + } + + # Get v_dst. + if (need_dst) { + if (R_NOTDST(rop)) { + v_dst = not (v_dst) + if (dst_maxval != 0) + v_dst = and (int(v_dst), dst_maxval) + } + } + + # Apply the rasterop. + switch (opcode) { + case PIX_CLR: + pv = 0 + case PIX_SET: + pv = data + case PIX_SRC, PIX_NOTSRC: + pv = v_src + case PIX_DST, PIX_NOTDST: + pv = v_dst + case PIX_SRC_AND_DST, PIX_SRC_AND_NOTDST, PIX_NOTSRC_AND_DST: + pv = and (v_src, v_dst) + case PIX_SRC_OR_DST, PIX_SRC_OR_NOTDST, PIX_NOTSRC_OR_DST: + pv = or (v_src, v_dst) + case PIX_SRC_XOR_DST: + pv = xor (v_src, v_dst) + case PIX_NOT_SRC_AND_DST: + pv = not (and (v_src, v_dst)) + case PIX_NOT_SRC_OR_DST: + pv = not (or (v_src, v_dst)) + case PIX_NOT_SRC_XOR_DST: + pv = not (xor (v_src, v_dst)) + } + + # Mask the high bits to prevent negative values, or map int + # to bool for the case of a boolean output mask. + + if (dst_maxval == 1 && pv != 0) + pv = 1 + else if (dst_maxval > 1) + pv = and (int(pv), dst_maxval) + + } else + pv = v_dst + + # Output a nonzero range. + if (pv > 0) { + p = rn_o - 1 + if (p >= RL_FIRST && + pv == rl_out[3,p] && x == rl_out[1,p] + rl_out[2,p]) { + # Merge new range with previous one. + rl_out[2,p] = rl_out[2,p] + np + } else { + rl_out[1,rn_o] = x + rl_out[2,rn_o] = np + rl_out[3,rn_o] = pv + rn_o = rn_o + 1 + } + } + + x = x + np + segsize = segsize - np + } + + # Update the range list header. + call amovl (rl_dst, rl_out, (RL_FIRST - 1) * 3) + RL_LEN(rl_out) = rn_o - 1 +end diff --git a/sys/plio/tf/plrrops.x b/sys/plio/tf/plrrops.x new file mode 100644 index 00000000..b2d9781c --- /dev/null +++ b/sys/plio/tf/plrrops.x @@ -0,0 +1,195 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../plrseg.h" + +# PL_RANGEROP -- Rasterop operation between source and destination range lists. +# The indicated rasterop operation is performed upon the source and destination +# range lists, writing the result to RL_OUT, which is a copy of RL_DST except +# for the region affected by the rasterop operation (note that the destination +# range list cannot be edited in place since it may change size). + +procedure pl_rangerops (rl_src, xs, src_maxval, + rl_dst, ds, dst_maxval, rl_out, npix, rop) + +short rl_src[3,ARB] #I source range list +int xs #I starting pixel index in src range list +int src_maxval #I max pixel value in src mask +short rl_dst[3,ARB] #I destination range list +int ds #I starting pixel index in dst range list +int dst_maxval #I max pixel value in dst mask +short rl_out[3,ARB] #O output list (edited version of rl_dst) +int npix #I number of pixels to convert +int rop #I rasterop + +bool need_src, need_dst, rop_enable +short data, src_value, v_src, v_dst, pv +int segsize, opcode, x, i, np, rn_o, p +int d_src[LEN_PLRDES], d_dst[LEN_PLRDES] + +begin + need_src = R_NEED_SRC(rop) + need_dst = R_NEED_DST(rop) + opcode = R_OPCODE(rop) + data = R_DATA(rop) + + # Pixel value to be used if input mask is boolean. + if (src_maxval == 1) { + src_value = data + if (src_value <= 0) + src_value = dst_maxval + } + + # Advance to the desired position in the source list, discarding + # the unused ranges. The point XS may lie within a range or in a + # zero area of the input line. + + if (need_src) { + x = 1 + plr_init (rl_src, d_src) + do i = 1, ARB { + np = min (plr_nleft(d_src), xs - x) + plr_getseg (rl_src, d_src, np, v_src) + x = x + np + if (x >= xs || np == 0) + break + } + } + + # Advance through both the source and destination lists, extracting + # line segments which have a constant value in each input list; the + # values for the two lists may differ. Apply the given rasterop to + # the source and destination pixel values and write each line segment + # as a range to the output list. If the ranges in the two input lists + # differ (randomly overlap) then the output list will generally be + # more fragmented, i.e., have more ranges of constant value. As each + # output range is generated compare it with the previous range to see + # if they can be joined, as applying a rasterop may cause two different + # ranges to have the same value. + + x = 1 + rn_o = RL_FIRST + segsize = ds - 1 + rop_enable = false + plr_init (rl_dst, d_dst) + + do i = 1, ARB { + # Set up for the next segment (before, in, and after the region to + # which the ROP applies), when the current segment is exhausted. + + if (segsize <= 0) + if (!rop_enable) { + # Begin processing central region. + segsize = npix + rop_enable = true + if (segsize <= 0) + next + } else { + # Begin processing final region. + segsize = ARB + rop_enable = false + } + + # Determine the length of the next output segment. This is the + # largest segment of constant value formed by the intersection of + # the two lists. If bounds checking has been properly performed + # then it should not be possible to see nleft=zero on either input + # list. Note that zeroed regions are valid data here. + + np = min (segsize, plr_nleft(d_dst)) + if (need_src && rop_enable && plr_nleft(d_src) > 0) + np = min (np, plr_nleft(d_src)) + if (np <= 0) + break + + # Get the segment value and advance the line pointers. We must + # read the DST list whether or not we will use the data, since + # the list pointer must be advanced NPIX pixels so that we may + # copy the remainder of the list after the loop. + + plr_getseg (rl_dst, d_dst, np, v_dst) + if (rop_enable) { + # Get v_src. + if (need_src) { + v_src = 0 + if (plr_nleft (d_src) > 0) + plr_getseg (rl_src, d_src, np, v_src) + + if (R_NOTSRC(rop)) { + v_src = not (v_src) + if (src_maxval != 0) + v_src = and (int(v_src), src_maxval) + } + + if (v_src != 0 && src_maxval == 1) + v_src = src_value + } + + # Get v_dst. + if (need_dst) { + if (R_NOTDST(rop)) { + v_dst = not (v_dst) + if (dst_maxval != 0) + v_dst = and (int(v_dst), dst_maxval) + } + } + + # Apply the rasterop. + switch (opcode) { + case PIX_CLR: + pv = 0 + case PIX_SET: + pv = data + case PIX_SRC, PIX_NOTSRC: + pv = v_src + case PIX_DST, PIX_NOTDST: + pv = v_dst + case PIX_SRC_AND_DST, PIX_SRC_AND_NOTDST, PIX_NOTSRC_AND_DST: + pv = and (v_src, v_dst) + case PIX_SRC_OR_DST, PIX_SRC_OR_NOTDST, PIX_NOTSRC_OR_DST: + pv = or (v_src, v_dst) + case PIX_SRC_XOR_DST: + pv = xor (v_src, v_dst) + case PIX_NOT_SRC_AND_DST: + pv = not (and (v_src, v_dst)) + case PIX_NOT_SRC_OR_DST: + pv = not (or (v_src, v_dst)) + case PIX_NOT_SRC_XOR_DST: + pv = not (xor (v_src, v_dst)) + } + + # Mask the high bits to prevent negative values, or map int + # to bool for the case of a boolean output mask. + + if (dst_maxval == 1 && pv != 0) + pv = 1 + else if (dst_maxval > 1) + pv = and (int(pv), dst_maxval) + + } else + pv = v_dst + + # Output a nonzero range. + if (pv > 0) { + p = rn_o - 1 + if (p >= RL_FIRST && + pv == rl_out[3,p] && x == rl_out[1,p] + rl_out[2,p]) { + # Merge new range with previous one. + rl_out[2,p] = rl_out[2,p] + np + } else { + rl_out[1,rn_o] = x + rl_out[2,rn_o] = np + rl_out[3,rn_o] = pv + rn_o = rn_o + 1 + } + } + + x = x + np + segsize = segsize - np + } + + # Update the range list header. + call amovs (rl_dst, rl_out, (RL_FIRST - 1) * 3) + RL_LEN(rl_out) = rn_o - 1 +end diff --git a/sys/plio/zzdebug.x b/sys/plio/zzdebug.x new file mode 100644 index 00000000..0ff3cc47 --- /dev/null +++ b/sys/plio/zzdebug.x @@ -0,0 +1,1442 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include + +task pltest = t_pltest, + script = t_script + +.help pltest +.nf ------------------------------------------------------------------------- +PLTEST -- PL package debug and test facility. + + Due to the complexity of the PL package, testing is performed using an +interactive interpreter which reads commands from the standard input. +All commands operate internally upon a set of four mask registers A-D, +and a set of ten vector registers V[0-9]. + + a,b,c,d - mask registers + v0,...,v9 - vector registers + +The following commands are defined: + + help # print command summary + timer # toggle timing of commands + run fname # read commands from a file + log [fname] # log commands in a file + clear # clear the screen + bye # all done (also EOF) + + create [mask] naxes axlen depth # create a new mask + load [mask] fname # load mask from file + save [mask] fname [title] # save mask in file + loadim [mask] image # load mask from image + saveim [mask] image [title] # save mask in image + erase [mask] [vs ve] # erase a mask or region + draw [mask] [vs ve] [>ofile] # draw mask or region of mask + + set [mask] # set reference mask + set [vector] i j k... # load vector register + show [vector] # print vector register + show [mask] [index] [ll] [rl] [>ofile] # print debug info for a mask + + box [mask] P1 P2 rop # draw a box + circle [mask] P1 r rop # draw a circle + line [mask] P1 P2 width rop # draw a line segment + point [mask] P1 rop # draw a point + polygon [mask] P1 ... PN rop # draw a polygon + + rop src [vs] dst [vs] [vn] rop # rasterop + stencil src [vs] dst [vs] stn [vs] [vn] rop # stencil + invert [mask] [vs [vn]] # invert a mask + + compare mask1 mask2 # compare two masks + rtest mask1 mask2 # range list conversion test + ptest mask1 mask2 # pixel array conversion test + secne [mask] vs ve # test if section not empty + secnc [mask] vs ve # test if section not constant + rio [mask] vs # test mask using random i/o + +Rasterops may be specified either as integer constants (any radix) or via +a simple symbolic notation, e.g.: "opcode+[value]". + +A mask may be examined in detail with SHOW, which calls pl_debug to decode +the contents of a mask. A graphic image of a mask may be drawn with DRAW, +which renders each pixel in the mask as a printable character. +.endhelp -------------------------------------------------------------------- + +define SZ_SBUF 512 # size limiting parameters +define DEF_MASKSIZE_X 75 +define DEF_MASKSIZE_Y 40 +define MAXKWLEN 20 +define MAXARGS 50 +define MAXMREG 4 +define MAXVREG 10 +define MAXINCL 10 +define WIDTH 80 + +define INT_ARG 1 # argument types +define STRING_ARG 2 +define VECTOR_ARG 3 +define MASK_ARG 4 + +define v_i argval[$1] # integer argument +define v_s sbuf[argval[$1]] # string argument +define v_si sbuf[argval[$1]+$2-1] # indexed string argument +define v_v v_reg[1,argval[$1]+1] # vector argument +define v_vi v_reg[$2,argval[$1]+1] # indexed vector argument +define v_m v_mask[argval[$1]] # mask argument + +define KW_BOX 1 # interpreter commands +define KW_BYE 2 +define KW_CIRCLE 3 +define KW_CLEAR 4 +define KW_COMPARE 5 +define KW_CREATE 6 +define KW_DRAW 7 +define KW_ERASE 8 +define KW_HELP 9 +# eol 10 +define KW_LINE 11 +define KW_POINT 12 +define KW_POLYGON 13 +define KW_LOAD 14 +define KW_LOADIM 15 +define KW_PTEST 16 +define KW_ROP 17 +define KW_RTEST 18 +define KW_RUN 19 +define KW_SAVE 20 +define KW_SAVEIM 21 +# eol 22 +define KW_SET 23 +define KW_SHOW 24 +define KW_SECNE 25 +define KW_SECNC 26 +define KW_RIO 27 +define KW_STENCIL 28 +define KW_INVERT 29 +define KW_TIMER 30 +define KW_LOG 31 + + +# PLTEST -- Test the PL package. Read and execute commands from the standard +# input until EOF or BYE is seen. + +procedure t_pltest() + +long time[2] +int x, y, r +bool timer, bval +int px[MAXARGS], py[MAXARGS], old_onint, width, mval +pointer pl, pl_1, pl_2, def_pl, pl_src, pl_dst, pl_stn, tty, plr +char cmd[SZ_LINE], kwname[SZ_FNAME], title[SZ_LINE], fname[SZ_FNAME] +int what, rop, v_arg, x1, x2, y1, y2, ip, op, ch, i, j, cmdlog, status +int opcode, save_fd[MAXINCL], in, fd, o_fd, maskno, depth, naxes, npts +int v1[PL_MAXDIM], v2[PL_MAXDIM], v3[PL_MAXDIM], v4[PL_MAXDIM], v[PL_MAXDIM] + +int plr_getpix(), pl_compare() +int fstati(), strdic(), open(), getline(), strncmp(), locpr() +pointer pl_create(), ttyodes(), plr_open() +bool pl_sectnotempty(), pl_sectnotconst() +extern onint() + +char sbuf[SZ_SBUF] +int nargs, argno, argtype[MAXARGS], argval[MAXARGS], s_op +int v_mask[MAXMREG], v_reg[PL_MAXDIM,MAXVREG], jmpbuf[LEN_JUMPBUF] +common /plzcom/ v_mask, v_reg, nargs, argno, argtype, argval, s_op, + jmpbuf, sbuf +define argerr_ 91 +define eof_ 92 + +string keywords "|box|bye|circle|clear|compare|create|draw|erase|help|\ + |line|point|polygon|load|loadim|ptest|rop|rtest|run|save|saveim|\ + |set|show|secne|secnc|rio|stencil|invert|timer|log|" + +begin + in = 0 + ip = 1 + fd = STDIN + cmdlog = 0 + cmd[ip] = EOS + timer = false + + # Initialize the mask registers. + v[1] = DEF_MASKSIZE_X + v[2] = DEF_MASKSIZE_Y + do i = 1, MAXMREG + v_mask[i] = pl_create (2, v, 7) + def_pl = v_mask[1] + + # Initialize the vector registers. + do i = 1, MAXVREG + call amovki (1, v_reg[1,i], PL_MAXDIM) + + # Main interpreter loop. + # --------------------------- + + call xwhen (X_INT, locpr(onint), old_onint) + call zsvjmp (jmpbuf, status) + + if (status != OK) { + # Clean up after an interrupt. + call xer_reset() + ip = 1; cmd[ip] = EOS + while (in > 0) { + call close (fd) + fd = save_fd[in] + in = in - 1 + } + } + + repeat { + # Get next command. + if (cmd[ip] == '\n' || cmd[ip] == '#' || cmd[ip] == EOS) { + # Prompt if reading from the standard input. + if (in == 0 && fstati (STDIN, F_REDIR) == NO) { + call putline (STDOUT, "* ") + call flush (STDOUT) + } + + # Handle EOF on the current command stream. + if (getline (fd, cmd) == EOF) { +eof_ if (in > 0) { + call close (fd) + fd = save_fd[in] + in = in - 1 + } else + break + } + + ip = 1 + } + + # Skip blank lines and comment lines. + for (ip=1; IS_WHITE(cmd[ip]) || cmd[ip] == ';'; ip=ip+1) + ; + if (cmd[ip] == '\n' || cmd[ip] == '#' || cmd[ip] == EOS) + next + + if (cmdlog != 0) + call putline (cmdlog, cmd) + + # Extract the keyword into the KWNAME buffer. Leave the input + # pointer positioned to the first char following the keyword. + + for (op=1; cmd[ip] != EOS && cmd[ip] != '\n'; ip=ip+1) { + ch = cmd[ip] + if (IS_ALNUM(ch) || ch == '?' || ch == '_') { + kwname[op] = ch + op = op + 1 + } else + break + } + kwname[op] = EOS + + # Look up the keyword in the dictionary. If not found ring the + # bell, but do not quit. + + if (kwname[1] == '?') + opcode = KW_HELP + else + opcode = strdic (kwname, kwname, MAXKWLEN, keywords) + if (opcode <= 0) { + call eprintf ("unknown command\007\n") + call flush (STDERR) + ip=1; cmd[ip] = EOS + next + } + + # Parse the argument list. + call parse_args (cmd, ip) + + # Process the command. + # ------------------------- + + switch (opcode) { + case KW_BYE: + goto eof_ + + case KW_LOG: + # Enable/Disable command logging. + + if (cmdlog == 0) { + if (nargs >= 1 && argtype[argno] == STRING_ARG) + cmdlog = open (v_s(argno), APPEND, TEXT_FILE) + else + cmdlog = open ("zzdebug.log", APPEND, TEXT_FILE) + call eprintf ("command spooling enabled\n") + call fprintf (cmdlog, "# --- begin ---\n") + } else { + call close (cmdlog) + cmdlog = 0 + call eprintf ("command spooling disabled\n") + } + + case KW_POINT: + # Draw a point. + + # Get mask. + pl = def_pl + if (argtype[argno] == MASK_ARG) { + pl = v_m(argno) + argno = argno + 1 + } + + # Get coords of point. + if (argtype[argno] == VECTOR_ARG) { + # Coords given as vectors. + x1 = v_vi(argno,1) + y1 = v_vi(argno,2) + argno = argno + 1 + } else { + # Coords given explicitly. + do i = 1, 2 + if (argtype[argno+i-1] != INT_ARG) + goto argerr_ + + x1 = v_i(argno); argno = argno + 1 + y1 = v_i(argno); argno = argno + 1 + } + + # Get rop. + if (argno <= nargs) { + if (argtype[argno] != INT_ARG) + goto argerr_ + rop = v_i(argno); argno = argno + 1 + } else + rop = or (PIX_SRC, PIX_DST) + PIX_VALUE('1') + + # Perform the operation. + if (timer) + call sys_mtime (time) + call pl_point (pl, x1, y1, rop) + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_BOX: + # Draw a box. + + # Get mask. + pl = def_pl + if (argtype[argno] == MASK_ARG) { + pl = v_m(argno) + argno = argno + 1 + } + + # Get corner coords of box. + if (argtype[argno] == VECTOR_ARG) { + # Coords given as vectors. + x1 = v_vi(argno,1) + y1 = v_vi(argno,2) + argno = argno + 1 + if (argtype[argno] != VECTOR_ARG) + goto argerr_ + x2 = v_vi(argno,1) + y2 = v_vi(argno,2) + argno = argno + 1 + + } else { + # Coords given explicitly. + do i = 1, 4 + if (argtype[argno+i-1] != INT_ARG) + goto argerr_ + + x1 = v_i(argno); argno = argno + 1 + y1 = v_i(argno); argno = argno + 1 + x2 = v_i(argno); argno = argno + 1 + y2 = v_i(argno); argno = argno + 1 + } + + # Get rop. + if (argno <= nargs) { + if (argtype[argno] != INT_ARG) + goto argerr_ + rop = v_i(argno); argno = argno + 1 + } else + rop = or (PIX_SRC, PIX_DST) + PIX_VALUE('2') + + # Perform the operation. + if (timer) + call sys_mtime (time) + call pl_box (pl, x1, y1, x2, y2, rop) + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_LINE: + # Draw a line of arbitrary orientation and width. + + # Get mask. + pl = def_pl + if (argtype[argno] == MASK_ARG) { + pl = v_m(argno) + argno = argno + 1 + } + + # Get endpoints of line. + if (argtype[argno] == VECTOR_ARG) { + # Coords given as vectors. + x1 = v_vi(argno,1) + y1 = v_vi(argno,2) + argno = argno + 1 + if (argtype[argno] != VECTOR_ARG) + goto argerr_ + x2 = v_vi(argno,1) + y2 = v_vi(argno,2) + argno = argno + 1 + + } else { + # Coords given explicitly. + do i = 1, 4 + if (argtype[argno+i-1] != INT_ARG) + goto argerr_ + + x1 = v_i(argno); argno = argno + 1 + y1 = v_i(argno); argno = argno + 1 + x2 = v_i(argno); argno = argno + 1 + y2 = v_i(argno); argno = argno + 1 + } + + # Get line width. + if (argno <= nargs) { + if (argtype[argno] != INT_ARG) + goto argerr_ + width = v_i(argno); argno = argno + 1 + } else + width = 1 + + # Get rop. + if (argno <= nargs) { + if (argtype[argno] != INT_ARG) + goto argerr_ + rop = v_i(argno); argno = argno + 1 + } else + rop = or (PIX_SRC, PIX_DST) + PIX_VALUE('4') + + # Perform the operation. + if (timer) + call sys_mtime (time) + call pl_line (pl, x1, y1, x2, y2, width, rop) + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_CIRCLE: + # Draw a circle. + + # Get mask. + pl = def_pl + if (argtype[argno] == MASK_ARG) { + pl = v_m(argno) + argno = argno + 1 + } + + # Get center coords and radius of circle. + if (argtype[argno] == VECTOR_ARG) { + # Center coords given as a vector. + x = v_vi(argno,1) + y = v_vi(argno,2) + argno = argno + 1 + + } else { + # Center coords given explicitly. + do i = 1, 2 + if (argtype[argno+i-1] != INT_ARG) + goto argerr_ + + x = v_i(argno); argno = argno + 1 + y = v_i(argno); argno = argno + 1 + } + + if (argtype[argno] != INT_ARG) + goto argerr_ + r = v_i(argno); argno = argno + 1 + + # Get rop. + if (argno <= nargs) { + if (argtype[argno] != INT_ARG) + goto argerr_ + rop = v_i(argno); argno = argno + 1 + } else + rop = or (PIX_SRC, PIX_DST) + PIX_VALUE('Q') + + # Perform the operation. + if (timer) + call sys_mtime (time) + call pl_circle (pl, x, y, r, rop) + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_POLYGON: + # Draw a polygon. + + # Get mask. + pl = def_pl + if (argtype[argno] == MASK_ARG) { + pl = v_m(argno) + argno = argno + 1 + } + + # Get the coordinates of the polygon. + for (npts=0; argno <= nargs; ) { + npts = npts + 1 + + if (argtype[argno] == VECTOR_ARG) { + # Coords of point given as a vector. + px[npts] = v_vi(argno,1) + py[npts] = v_vi(argno,2) + argno = argno + 1 + + } else if (argtype[argno] == INT_ARG && + argtype[argno+1] == INT_ARG) { + + # Center coords given explicitly. + px[npts] = v_i(argno); argno = argno + 1 + py[npts] = v_i(argno); argno = argno + 1 + } + } + + # Get rop. + if (argno <= nargs) { + if (argtype[argno] != INT_ARG) + goto argerr_ + rop = v_i(argno); argno = argno + 1 + } else + rop = or (PIX_SRC, PIX_DST) + PIX_VALUE('R') + + # Perform the operation. + if (timer) + call sys_mtime (time) + call pl_polygon (pl, px, py, npts, rop) + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_CLEAR: + # Clear the screen. + tty = ttyodes ("terminal") + call ttyclear (STDOUT, tty) + call ttycdes (tty) + + case KW_COMPARE: + # Compare two masks. + if (nargs < 2) + goto argerr_ + + # Get mask 1. + if (argtype[argno] == MASK_ARG) { + pl_1 = v_m(argno) + argno = argno + 1 + } else + goto argerr_ + + # Get mask 2. + if (argtype[argno] == MASK_ARG) { + pl_2 = v_m(argno) + argno = argno + 1 + } else + goto argerr_ + + # Perform the operation. + if (timer) + call sys_mtime (time) + status = pl_compare (pl_1, pl_2, STDOUT) + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_CREATE: + # Create a new, emtpy mask of the given size and depth. + + # Get mask. + maskno = 1 + if (argtype[argno] == MASK_ARG) { + maskno = v_i(argno) + argno = argno + 1 + } + + # Get naxes. + if (argtype[argno] != INT_ARG) + goto argerr_ + naxes = v_i(argno); argno = argno + 1 + + # Get mask size. + if (argtype[argno] == VECTOR_ARG) { + # Mask size given as vector. + call amovi (v_v(argno), v1, PL_MAXDIM) + argno = argno + 1 + } else { + # Mask size given explicitly. + do i = 1, naxes { + if (argtype[argno+i-1] != INT_ARG) + goto argerr_ + v1[i] = v_i(argno) + argno = argno + 1 + } + } + + # Get mask depth. + if (argtype[argno] != INT_ARG) + depth = 1 + else { + depth = v_i(argno) + argno = argno + 1 + } + + # Perform the operation. + if (timer) + call sys_mtime (time) + call pl_close (v_mask[maskno]) + v_mask[maskno] = pl_create (naxes, v1, depth) + def_pl = v_mask[maskno] + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_DRAW: + # Draw a mask or region of a mask on the screen. + + # Get mask. + pl = def_pl + if (nargs >= 1 && argtype[argno] == MASK_ARG) { + pl = v_m(argno) + argno = argno + 1 + } + + # Get vector coords of region to be drawn. + if (argtype[argno] == VECTOR_ARG) { + call amovi (v_v(argno), v1, PL_MAXDIM) + argno = argno + 1 + } else + call amovki (1, v1, PL_MAXDIM) + + if (argtype[argno] == VECTOR_ARG) { + call amovi (v_v(argno), v2, PL_MAXDIM) + argno = argno + 1 + } else + call amovi (PL_AXLEN(pl,1), v2, PL_MAXDIM) + + # Get output stream. + o_fd = STDOUT + if (argtype[argno] == STRING_ARG) { + if (v_si(argno,1) == '>') { + # Write output to a file. + if (v_si(argno,2) == '>') { + iferr (o_fd = open (v_si(argno,3), + APPEND, TEXT_FILE)) { + call erract (EA_WARN) + o_fd = STDOUT + } + } else { + iferr (o_fd = open (v_si(argno,2), + NEW_FILE, TEXT_FILE)) { + call erract (EA_WARN) + o_fd = STDOUT + } + } + } else { + call eprintf ("unknown option `%s'\n") + call pargstr (v_s(argno)) + } + argno = argno + 1 + } + + # Perform the operation. + call pl_asciidump (pl, v1, v2, o_fd) + + if (o_fd != STDOUT) + call close (o_fd) + + case KW_ERASE: + # Erase a mask, or a region of a mask. + + # Get mask. + pl = def_pl + if (nargs >= 1 && argtype[argno] == MASK_ARG) { + pl = v_m(argno) + argno = argno + 1 + } + + # Get vector coords of region to be erased. + if (argtype[argno] == VECTOR_ARG) { + call amovi (v_v(argno), v1, PL_MAXDIM) + argno = argno + 1 + } else + call amovki (1, v1, PL_MAXDIM) + + if (argtype[argno] == VECTOR_ARG) { + call amovi (v_v(argno), v2, PL_MAXDIM) + argno = argno + 1 + } else + call amovi (PL_AXLEN(pl,1), v2, PL_MAXDIM) + + # Perform the operation. + if (timer) + call sys_mtime (time) + if (nargs <= 1) + call pl_clear (pl) + else + call pl_rop (NULL, 0, pl, v1, v2, PIX_CLR) + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_HELP: + # Print a command summary. + call print_help (STDOUT) + + case KW_RUN: + # Read commands from a file. + if (nargs < 1 || argtype[argno] != STRING_ARG) + goto argerr_ + + in = in + 1 + if (in > MAXINCL) + call error (1, "too many nested run files\n") + save_fd[in] = fd + iferr (fd = open (v_s(argno), READ_ONLY, TEXT_FILE)) { + call erract (EA_WARN) + fd = save_fd[in] + in = in - 1 + } + + case KW_SET: + # Set the value of a mask or vector register. + if (nargs < 1) { + goto argerr_ + + } else if (argtype[argno] == MASK_ARG) { + # Set the default mask. + def_pl = v_m(argno) + maskno = v_i(argno) + + } else if (argtype[argno] == VECTOR_ARG) { + # Set a vector register. + v_arg = argno + argno = argno + 1 + + do i = 1, PL_MAXDIM + if (argno <= nargs && argtype[argno] == INT_ARG) { + v[i] = v_i(argno) + argno = argno + 1 + } else + v[i] = 1 + + call amovi (v, v_v(v_arg), PL_MAXDIM) + } + + case KW_SHOW: + # Print information about a mask or vector register. + + if (nargs < 1 || argtype[argno] == MASK_ARG) { + # Print information about a mask. + + if (nargs < 1) + pl = def_pl + else { + pl = v_m(argno) + argno = argno + 1 + } + + o_fd = STDOUT + + # Process option selects. + what = PD_SUMMARY + while (argno <= nargs && argtype[argno] == STRING_ARG) { + if (strncmp (v_s(argno), "i", 1) == 0) { + what = or (what, PD_INDEX) + } else if (strncmp (v_s(argno), "ll", 2) == 0) { + what = or (what, PD_LLOUT) + } else if (strncmp (v_s(argno), "rl", 2) == 0) { + what = or (what, PD_RLOUT) + } else if (strncmp (v_s(argno), "lh", 2) == 0) { + what = or (what, PD_LHDR) + + } else if (v_si(argno,1) == '>') { + # Write output to a file. + if (v_si(argno,2) == '>') { + iferr (o_fd = open (v_si(argno,3), + APPEND, TEXT_FILE)) { + call erract (EA_WARN) + o_fd = STDOUT + } + } else { + iferr (o_fd = open (v_si(argno,2), + NEW_FILE, TEXT_FILE)) { + call erract (EA_WARN) + o_fd = STDOUT + } + } + } else { + call eprintf ("unknown option `%s'\n") + call pargstr (v_s(argno)) + } + argno = argno + 1 + } + + # Perform the operation. + call pl_debug (pl, o_fd, WIDTH, what) + if (o_fd != STDOUT) + call close (o_fd) + + } else if (argtype[argno] == VECTOR_ARG) { + # Print the value of a vector register. + call printf ("v%d: ") + call pargi (v_i(argno)) + do i = 1, PL_MAXDIM { + call printf (" %d") + call pargi (v_vi(argno,i)) + } + call printf ("\n") + + } else { + # Print the value of all vector registers. + do j = 1, MAXVREG { + call printf ("v%d: ") + call pargi (j-1) + do i = 1, PL_MAXDIM { + call printf (" %d") + call pargi (v_reg(i,j)) + } + call printf ("\n") + } + } + + case KW_LOAD: + # Load a mask from a file. + + # Get mask to be loaded. + pl = def_pl + if (nargs >= 1 && argtype[argno] == MASK_ARG) { + pl = v_m(argno) + argno = argno + 1 + } + + # Get mask filename. + if (argno > nargs || argtype[argno] != STRING_ARG) + goto argerr_ + + # Perform the operation. + if (timer) + call sys_mtime (time) + iferr (call pl_loadf (pl, v_s(argno), title, SZ_LINE)) + call erract (EA_WARN) + else if (title[1] != EOS) { + call printf ("mask: %s\n") + call pargstr (title) + call flush (STDOUT) + } + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_SAVE: + # Save a mask in a file. + + # Get mask to be saved. + pl = def_pl + if (nargs >= 1 && argtype[argno] == MASK_ARG) { + pl = v_m(argno) + argno = argno + 1 + } + + # Get mask filename. + if (argno > nargs || argtype[argno] != STRING_ARG) + goto argerr_ + else { + call strcpy (v_s(argno), fname, SZ_FNAME) + argno = argno + 1 + } + + # Get title string. + if (argno <= nargs && argtype[argno] == STRING_ARG) { + call strcpy (v_s(argno), title, SZ_LINE) + argno = argno + 1 + } + + # Perform the operation. + if (timer) + call sys_mtime (time) + iferr (call pl_savef (pl, fname, title, 0)) + call erract (EA_WARN) + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_LOADIM: + # Load a mask from an image. + + # Get mask to be loaded. + pl = def_pl + if (nargs >= 1 && argtype[argno] == MASK_ARG) { + pl = v_m(argno) + argno = argno + 1 + } + + # Get image section. + if (argno > nargs || argtype[argno] != STRING_ARG) + goto argerr_ + + # Perform the operation. + if (timer) + call sys_mtime (time) + iferr (call pl_loadim (pl, v_s(argno), title, SZ_LINE)) + call erract (EA_WARN) + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_SAVEIM: + # Save a mask in an image. + + # Get mask to be saved. + pl = def_pl + if (nargs >= 1 && argtype[argno] == MASK_ARG) { + pl = v_m(argno) + argno = argno + 1 + } + + # Get output image name. + if (argno > nargs || argtype[argno] != STRING_ARG) + goto argerr_ + else { + call strcpy (v_s(argno), fname, SZ_FNAME) + argno = argno + 1 + } + + # Get title string. + if (argno <= nargs && argtype[argno] == STRING_ARG) { + call strcpy (v_s(argno), title, SZ_LINE) + argno = argno + 1 + } + + # Perform the operation. + if (timer) + call sys_mtime (time) + iferr (call pl_saveim (pl, fname, title, 0)) + call erract (EA_WARN) + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_ROP: + # General rasterop operation. + + # Get source mask. + pl_src = def_pl + if (argtype[argno] == MASK_ARG) { + pl_src = v_m(argno) + argno = argno + 1 + } + + # Get start vector in source mask. + if (argtype[argno] == VECTOR_ARG) { + call amovi (v_v(argno), v1, PL_MAXDIM) + argno = argno + 1 + } else + call amovki (1, v1, PL_MAXDIM) + + # Get destination mask. + pl_dst = def_pl + if (nargs >= 1 && argtype[argno] == MASK_ARG) { + pl_dst = v_m(argno) + argno = argno + 1 + } + + # Get start vector in destination mask. + if (argtype[argno] == VECTOR_ARG) { + call amovi (v_v(argno), v2, PL_MAXDIM) + argno = argno + 1 + } else + call amovki (1, v2, PL_MAXDIM) + + # Get vector defining size of region to be modified. + if (argtype[argno] == VECTOR_ARG) { + call amovi (v_v(argno), v3, PL_MAXDIM) + argno = argno + 1 + } else + call amovi (PL_AXLEN(pl_dst,1), v3, PL_MAXDIM) + + # Get rop. + if (argno <= nargs) { + if (argtype[argno] != INT_ARG) + goto argerr_ + rop = v_i(argno); argno = argno + 1 + } else + rop = PIX_SRC + + # Perform the operation. + if (timer) + call sys_mtime (time) + call pl_rop (pl_src, v1, pl_dst, v2, v3, rop) + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_STENCIL: + # Rasterop operation though a stencil mask. + + # Get source mask. + pl_src = def_pl + if (nargs >= 1 && argtype[argno] == MASK_ARG) { + pl_src = v_m(argno) + argno = argno + 1 + } + + # Get start vector in source mask. + if (argtype[argno] == VECTOR_ARG) { + call amovi (v_v(argno), v1, PL_MAXDIM) + argno = argno + 1 + } else + call amovki (1, v1, PL_MAXDIM) + + # Get destination mask. + pl_dst = def_pl + if (nargs >= 1 && argtype[argno] == MASK_ARG) { + pl_dst = v_m(argno) + argno = argno + 1 + } + + # Get start vector in destination mask. + if (argtype[argno] == VECTOR_ARG) { + call amovi (v_v(argno), v2, PL_MAXDIM) + argno = argno + 1 + } else + call amovki (1, v2, PL_MAXDIM) + + # Get stencil mask. + pl_stn = def_pl + if (nargs >= 1 && argtype[argno] == MASK_ARG) { + pl_stn = v_m(argno) + argno = argno + 1 + } + + # Get start vector in stencil mask. + if (argtype[argno] == VECTOR_ARG) { + call amovi (v_v(argno), v3, PL_MAXDIM) + argno = argno + 1 + } else + call amovki (1, v3, PL_MAXDIM) + + # Get vector defining size of region to be modified. + if (argtype[argno] == VECTOR_ARG) { + call amovi (v_v(argno), v4, PL_MAXDIM) + argno = argno + 1 + } else + call amovi (PL_AXLEN(pl_dst,1), v4, PL_MAXDIM) + + # Get rop. + if (argno <= nargs) { + if (argtype[argno] != INT_ARG) + goto argerr_ + rop = v_i(argno); argno = argno + 1 + } else { + call eprintf ("no rop specified - copying src to dst\n") + rop = PIX_SRC + } + + # Perform the operation. + if (timer) + call sys_mtime (time) + call pl_stencil (pl_src, v1, pl_dst, v2, pl_stn, v3, v4, rop) + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_INVERT: + # Invert a mask. + + # Get mask. + pl_src = def_pl + if (argtype[argno] == MASK_ARG) { + pl_src = v_m(argno) + argno = argno + 1 + } + pl_dst = pl_src + + # Get start vector in mask. + if (argtype[argno] == VECTOR_ARG) { + call amovi (v_v(argno), v1, PL_MAXDIM) + argno = argno + 1 + } else + call amovki (1, v1, PL_MAXDIM) + + # Get vector defining size of region to be modified. + if (argtype[argno] == VECTOR_ARG) { + call amovi (v_v(argno), v2, PL_MAXDIM) + argno = argno + 1 + } else + call amovi (PL_AXLEN(pl_dst,1), v2, PL_MAXDIM) + + # Perform the operation. + if (timer) + call sys_mtime (time) + rop = PIX_NOT(PIX_SRC) + call pl_rop (pl_src, v1, pl_dst, v1, v2, rop) + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_PTEST, KW_RTEST: + # Line list to pixel array or range list conversion test. + if (nargs < 2) + goto argerr_ + + # Get mask 1. + if (argtype[argno] == MASK_ARG) { + pl_1 = v_m(argno) + argno = argno + 1 + } else + goto argerr_ + + # Get mask 2. + if (argtype[argno] == MASK_ARG) { + pl_2 = v_m(argno) + argno = argno + 1 + } else + goto argerr_ + + # Perform the operation. + if (timer) + call sys_mtime (time) + call conv_test (pl_1, pl_2, STDOUT, opcode) + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_SECNE: + # Test if a section of a mask is not empty. + + # Get mask. + pl = def_pl + if (nargs >= 1 && argtype[argno] == MASK_ARG) { + pl = v_m(argno) + argno = argno + 1 + } + + # Get vector coords of region to be erased. + if (argtype[argno] == VECTOR_ARG) { + call amovi (v_v(argno), v1, PL_MAXDIM) + argno = argno + 1 + } else + call amovki (1, v1, PL_MAXDIM) + + if (argtype[argno] == VECTOR_ARG) { + call amovi (v_v(argno), v2, PL_MAXDIM) + argno = argno + 1 + } else + call amovi (PL_AXLEN(pl,1), v2, PL_MAXDIM) + + # Perform the operation. + if (timer) + call sys_mtime (time) + + bval = pl_sectnotempty (pl, v1, v2, 2) + call printf ("pl_sectnotempty -> %b (mask is %s)\n") + call pargb (bval) + if (bval) + call pargstr ("not empty") + else + call pargstr ("empty") + + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_SECNC: + # Test if a section of a mask is not constant. + + # Get mask. + pl = def_pl + if (nargs >= 1 && argtype[argno] == MASK_ARG) { + pl = v_m(argno) + argno = argno + 1 + } + + # Get vector coords of region to be erased. + if (argtype[argno] == VECTOR_ARG) { + call amovi (v_v(argno), v1, PL_MAXDIM) + argno = argno + 1 + } else + call amovki (1, v1, PL_MAXDIM) + + if (argtype[argno] == VECTOR_ARG) { + call amovi (v_v(argno), v2, PL_MAXDIM) + argno = argno + 1 + } else + call amovi (PL_AXLEN(pl,1), v2, PL_MAXDIM) + + # Perform the operation. + if (timer) + call sys_mtime (time) + + call printf ("pl_sectnotconst -> ") + if (pl_sectnotconst (pl, v1, v2, 2, mval)) + call printf ("true (mask is not constant)\n") + else { + call printf ("false (mask is constant, value=%d)\n") + call pargi (mval) + } + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_RIO: + # Test access to a mask using random io (plr_getpix). + + # Get mask. + pl = def_pl + if (nargs >= 1 && argtype[argno] == MASK_ARG) { + pl = v_m(argno) + argno = argno + 1 + } + + # Get vector coords of region to be tested. + if (argtype[argno] == VECTOR_ARG) { + call amovi (v_v(argno), v1, PL_MAXDIM) + argno = argno + 1 + } else + call amovki (1, v1, PL_MAXDIM) + + # Perform the operation. + if (timer) + call sys_mtime (time) + + call amovki (1, v, PL_MAXDIM) + plr = plr_open (pl, v, 0) + call printf ("mask pixel [%d,%d] has value %d\n") + call pargi (v1[1]) + call pargi (v1[2]) + call pargi (plr_getpix (plr, v1[1], v1[2])) + call plr_close (plr) + + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_TIMER: + if (timer) { + call printf ("timer off\n") + timer = false + } else { + call printf ("timer on\n") + timer = true + } + + default: + # Unrecognized command. + call eprintf ("unknown switch\007\n") + call flush (STDERR) + } + + call flush (STDOUT) + if (cmdlog != 0) + call flush (cmdlog) + next +argerr_ + call eprintf ("invalid argument list\n") + } + + call zxwhen (X_INT, old_onint, status) + if (cmdlog != 0) + call close (cmdlog) + + do i = 1, MAXMREG + call pl_close (v_mask[i]) +end + + +# ONINT -- Interrupt handler. + +procedure onint (signal, next_handler) + +int signal #I signal code +int next_handler #O epa of next handler + +char sbuf[SZ_SBUF] +int nargs, argno, argtype[MAXARGS], argval[MAXARGS], s_op +int v_mask[MAXMREG], v_reg[PL_MAXDIM,MAXVREG], jmpbuf[LEN_JUMPBUF] +common /plzcom/ v_mask, v_reg, nargs, argno, argtype, argval, s_op, + jmpbuf, sbuf + +begin + call fseti (STDOUT, F_CANCEL, OK) + call eprintf ("interrupt!\007\n") + call zdojmp (jmpbuf, signal) +end + + +# PARSE_ARGS -- Parse the argument list to an interpreter command, leaving +# the decoded arguments in the interpreter common, and returning the number +# of arguments as the function value. + +procedure parse_args (args, ip) + +char args[ARB] # argument list +int ip # pointer into argument list + +double dval +int nchars, junk, i +int ctowrd(), stridx(), gctod(), strlen() + +char sbuf[SZ_SBUF] +int nargs, argno, argtype[MAXARGS], argval[MAXARGS], s_op +int v_mask[MAXMREG], v_reg[PL_MAXDIM,MAXVREG], jmpbuf[LEN_JUMPBUF] +common /plzcom/ v_mask, v_reg, nargs, argno, argtype, argval, s_op, + jmpbuf, sbuf + +begin + s_op = 1 + argno = 1 + nargs = 0 + + do i = 1, MAXARGS + argtype[i] = 0 + + # Get next token. + junk = ctowrd (args, ip, sbuf[s_op], SZ_SBUF-s_op) + nchars = strlen (sbuf[s_op]) + + while (nchars > 0) { + nargs = nargs + 1 + if (nargs > MAXARGS) + call error (1, "too many arguments") + + if (nchars == 1 && sbuf[s_op] == '=') { + # Discard assignment operator. + nargs = nargs - 1 + + } else if (nchars == 1 && stridx (sbuf[s_op], "abcd") > 0) { + # Mask register. + argval[nargs] = stridx (sbuf[s_op], "abcd") + argtype[nargs] = MASK_ARG + + } else if (nchars == 2 && sbuf[s_op] == 'v' && + # Vector register. + IS_DIGIT(sbuf[s_op+1])) { + argval[nargs] = TO_INTEG(sbuf[s_op+1]) + argtype[nargs] = VECTOR_ARG + + } else if (IS_DIGIT (sbuf[s_op])) { + # Get an integer constant. + i=1; nchars = gctod (sbuf[s_op], i, dval) + argval[nargs] = nint(dval) + argtype[nargs] = INT_ARG + + # Handle the notation "opcode+value", for rasterops. + if (sbuf[s_op+i-1] == '+') { + i=i+1; nchars = gctod (sbuf[s_op], i, dval) + argval[nargs] = argval[nargs] + PIX_VALUE(nint(dval)) + } + + } else { + # String constant. + argval[nargs] = s_op + argtype[nargs] = STRING_ARG + s_op = s_op + nchars + 1 + } + + while (IS_WHITE(args[ip])) + ip = ip + 1 + if (args[ip] == ';' || args[ip] == '\n') { + ip = ip + 1 + break + } + + # Get next token. + junk = ctowrd (args, ip, sbuf[s_op], SZ_SBUF-s_op) + nchars = strlen (sbuf[s_op]) + } +end + + +# CONV_TEST -- Test the line list to pixel array or range list conversion +# routines. + +procedure conv_test (pl_1, pl_2, fd, opcode) + +pointer pl_1 #I input mask +pointer pl_2 #I output mask +int fd #I output file, for reporting errors +int opcode #I KW_[PR]TEST + +begin + call fprintf (fd, "conv_test called\n") +end + + +# PRINT_HELP -- Print the PL test interpreter commands help summary. + +procedure print_help (fd) + +int fd #I output file + +begin + call fprintf (fd, "help%48t# print command summary\n") + call fprintf (fd, "timer%48t# toggle timing of commands\n") + call fprintf (fd, "run fname%48t# read commands from a file\n") + call fprintf (fd, "log [fname]%48t# log commands in a file\n") + call fprintf (fd, "clear%48t# clear the screen\n") + call fprintf (fd, "bye%48t# all done (also EOF)\n\n") + call fprintf (fd, + "create [mask] naxes axlen [depth]%48t# create a new mask\n") + call fprintf (fd, "load [mask] fname%48t# load mask from file\n") + call fprintf (fd, "save [mask] fname%48t# save mask in file\n") + call fprintf (fd, "loadim [mask] image%48t# load mask from image\n") + call fprintf (fd, "saveim [mask] image%48t# save mask in image\n") + call fprintf (fd, "erase [mask] [vs ve]%48t# erase a mask or region\n") + call fprintf (fd, + "draw [mask] [vs ve] [>ofile]%48t# draw mask or region of mask\n\n") + call fprintf (fd, "set [mask]%48t# set reference mask\n") + call fprintf (fd, "set [vector] i j k...%48t# load vector register\n") + call fprintf (fd, "show [vector]%48t# print vector register\n") + call fprintf (fd, +"show [mask] [index] [ll] [rl] [>ofile]%48t# print debug info for a mask\n\n") + call fprintf (fd, "box P1 P2 rop%48t# draw a box\n") + call fprintf (fd, "circle P1 r rop%48t# draw a circle\n \n") + call fprintf (fd, + "line [mask] P1 P2 width rop%48t# draw a line segment\n") + call fprintf (fd, "point [mask] P1 rop%48t# draw a point\n") + call fprintf (fd, "polygon [mask] P1 ... PN rop%48t# draw a polygon\n") + call fprintf (fd, "rop src [vs] dst [vs] [vn] rop%48t# rasterop\n") + call fprintf (fd, + "stencil src [vs] dst [vs] stn [vs] [vn] rop%48t# stencil\n \n") + call fprintf (fd, "compare mask1 mask2%48t# compare two masks\n") + call fprintf (fd, "rtest mask1 mask2%48t# range list conversion test\n") + call fprintf (fd, + "ptest mask1 mask2%48t# pixel array conversion test\n") + call fprintf (fd, "secne [mask] [vs ve]%48t# test section not empty\n") + call fprintf (fd, "rio [mask] [vs]%48t# test mask using random i/o\n") +end + + +# SCRIPT -- Make a PLIO drawing script suitable to input to PLTEST above. + +procedure t_script() + +int ncmds, seed, i +int xo, yo, xs, ys, x, y, r +int clgeti() +real urand() + +begin + ncmds = clgeti ("ncmds") + + xo = 50; xs = 1024 - 100 + yo = 50; ys = 1024 - 100 + + seed = 5 + + do i = 1, ncmds { + x = urand(seed) * xs + xo + y = urand(seed) * ys + yo + r = urand(seed) * 40 + + call printf ("circle %d %d %d %d\n") + call pargi (x) + call pargi (y) + call pargi (r) + call pargi (PIX_SET + PIX_VALUE(mod(i,256))) + + call printf ("box %d %d %d %d %d\n") + call pargi (x - r) + call pargi (y - r) + call pargi (x + r) + call pargi (y + r) + call pargi (or(PIX_SRC,PIX_DST) + PIX_VALUE(mod(i*2,256))) + + call printf ("point %d %d %d\n") + call pargi (x) + call pargi (y) + call pargi (PIX_CLR + PIX_VALUE(mod(i*4,256))) + } +end diff --git a/sys/plio/zzlib.x b/sys/plio/zzlib.x new file mode 100644 index 00000000..fe21d849 --- /dev/null +++ b/sys/plio/zzlib.x @@ -0,0 +1,64 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# PL_CHKFREE -- Verify that the count of free space in the linelist is +# correct. (DEBUG TOOL). + +procedure pl_chkfree (pl, msg) + +pointer pl #I mask descriptor +char msg[ARB] #I message to be printed if error occurs + +pointer o_lp +short nref[8192], nl +int used, free, nused, nfree, b_len, i + +begin + used = 0; nused = 0 + free = 0; nfree = 0 + + # Count the space in the active line lists. + nl = 0 + for (i=0; i < PL_LLOP(pl); i=i+b_len) { + o_lp = Ref (pl, i) + b_len = LP_BLEN(o_lp) + + nl = nl + 1 + nref[nl] = LP_NREF(o_lp) + + if (LP_NREF(o_lp) < 0) { + call eprintf ("lineoff %d, nref = %d\n") + call pargi (i) + call pargi (LP_NREF(o_lp)) + free = free + b_len + nfree = nfree + 1 + } else if (i == PL_EMPTYLINE || LP_NREF(o_lp) > 0) { + used = used + b_len + nused = nused + 1 + } else { + free = free + b_len + nfree = nfree + 1 + } + } + + if (free != PL_LLFREE(pl)) { + call eprintf ("CHKFREE (%s): used=%d,%d, free=%d,%d, ") + call pargstr (msg) + call pargi (used) + call pargi (nused) + call pargi (free) + call pargi (nfree) + call eprintf ("PL_LLFREE=%d, OP-FREE=%d\n") + call pargi (PL_LLFREE(pl)) + call pargi (PL_LLOP(pl) - PL_LLFREE(pl)) + + do i = 1, nl { + call eprintf ("%4d") + call pargs (nref[i]) + if (mod (i,19) == 0) + call eprintf ("\n") + } + call eprintf ("\n") + } +end diff --git a/sys/plio/zzsum.x b/sys/plio/zzsum.x new file mode 100644 index 00000000..2e6097f9 --- /dev/null +++ b/sys/plio/zzsum.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +task sum = t_sum + +# SUM -- Sum the image pixels lying within the given mask. + +procedure t_sum() + +char image[SZ_FNAME] # input data image +char mask[SZ_FNAME] # image mask + +int npix, mval, totpix, m_flags +long v[PM_MAXDIM] +pointer im, mp, pp +real sum + +bool clgetb() +real asumr() +int mio_glsegr() +pointer immap(), mio_open() + +begin + call clgstr ("image", image, SZ_FNAME) + call clgstr ("mask", mask, SZ_FNAME) + m_flags = 0 + if (clgetb ("invert")) + m_flags = INVERT_MASK + + im = immap (image, READ_ONLY, 0) + mp = mio_open (mask, m_flags, im) + + sum = 0; totpix = 0 + while (mio_glsegr (mp, pp, mval, v, npix) != EOF) { + sum = sum + asumr (Memr[pp], npix) + totpix = totpix + npix + } + + call mio_close (mp) + call imunmap (im) + + call printf ("%d pixels, sum=%g, mean=%g\n") + call pargi (totpix) + call pargr (sum) + if (totpix > 0) + call pargr (sum / totpix) + else + call pargr (INDEF) +end diff --git a/sys/pmio/README b/sys/pmio/README new file mode 100644 index 00000000..303c464b --- /dev/null +++ b/sys/pmio/README @@ -0,0 +1,284 @@ +PMIO -- The Pixel Mask I/O package (PLIO for image masks). +PLIO -- The Pixel List I/O package (no ties to IMIO) + + A PIXEL LIST is a compressed, region oriented data structure used to store +an image matrix. The pixel list package is used to create, manage, and access +this data structure. Although the PLIO package can stand alone and is useful +in its own right, one of the main uses of the pixel list package is in the IMIO +interface, which can access a pixel list as if it were a MASK IMAGE. +See PLIO.hlp for further information on the PLIO package and image masks. + +The pixel list package itself does not support any fancy image coordinate +transformations. If an image has an associated pixel mask, the pixel mask +refers to the physical image matrix. An application written at the IMIO level +where an image section transformation may be defined for an image should +normally use the PMIO (pixel mask) package in preference to PLIO. PMIO is +equivalent to PLIO, except that coordinates are input in image section +coordinates, and a reference image is used to map such coordinates onto the +physical image matrix. + + +1. IMIO Mask Image Interface + + im = im_pmmap (maskname, mode, ref_im|NULL) + im = im_pmmapo (pm, ref_im) + + imseti (im, IM_RLIO, YES|NO) # enable range list i/o + imseti (im, IM_PMDES, pm) # inquire PM descriptor + pm = imstati (im, IM_PMDES) + + bool = im_pmlne[123] (im[, lineno[, bandno]]) + bool = im_pmsne[123] (im, x1, x2[, y1, y2[, z1, z2]]) + bool = im_pmlnev (im, v) + bool = im_pmsnev (im, vs, ve, ndim) + + mp = mio_open (maskname, flags, im) # Masked Image I/O + mp = mio_openo (pm, im) + value = mio_stati (mp, param) + mio_seti (mp, param, value) + mio_setrange (mp, vs, ve, ndim) + n|EOF = mio_[gp]lseg[silrdx] (mp, ptr, mval, v, npix) + mio_close (mp) + + +2. Pixel Mask Interface (uses reference image for section transformation) + + pm = pm_newmask (ref_im, depth) + + pm = pm_open (bufptr|NULL) + pm = pm_create (naxes, axlen, depth) + pm = pm_newcopy (pm) + pm_close (pm) + + pm_[sg]size (pm, naxes, alxen, depth) + pm_seti (pm, param, value) + value = pm_stati (pm, param) + pm_debug (pm, outfd, maxcol, flags) + bool = pm_empty (pm) + pm_compress (pm) + pm_clear (pm) + + pm_load (pm, bufptr) + nwords = pm_save (pm, bufptr, buflen, save_flags) + pm_loadf (pm, fname, title, maxch) + pm_savef (pm, fname, title, save_flags) + pm_[load|save]im (pm, imname[, save_flags]) + + ptr = pm_access (pm, v) + bool = pm_linenotempty (pm, v) + bool = pm_sectnotempty (pm, vs, ve, ndim) + pm[gp]l[lrp][sil] (pm, v, buf, b_depth, npix, rop) + + pm_[set|get]plane (pm, v) + pm_point (pm, x, y, rop) + pm_circle (pm, x, y, r, rop) + pm_box (pm, x1,y1, x2,y2, rop) + pm_line (pm, x1,y1, x2,y2, width, rop) + pm_polygon (pm, x, y, npts, rop) + + pm_rop (pm_src, vs, pm_dst, vs, vn, rop) + pm_stencil (pm_src, vs, pm_dst, vs, pm_stl, vs, vn, rop) + + +2.1 Random Access to a Pixel Mask + + pmr = pmr_open (pm, plane, buflimit) + pmr_setrect (pmr, x1,y1, x2,y2) + mval = pmr_getpix (pmr, i, j) + pmr_close (pmr) + + +3. Pixel List Interface (stands alone; independent of IMIO; no coord xforms) + + pl = pl_open (bufptr|NULL) + pl = pl_create (naxes, axlen, depth) + pl = pl_newcopy (pl) + pl_close (pl) + + pl_[sg]size (pl, naxes, axlen, depth) + pl_seti (pl, param, value) + value = pl_stati (pl, param) + pl_debug (pl, outfd, maxcol, flags) + bool = pl_empty (pl) + pl_compress (pl) + pl_clear (pl) + + pl_load (pl, bufptr) + nwords = pl_save (pl, bufptr, buflen, save_flags) + pl_loadf (pl, fname, title, maxch) + pl_savef (pl, fname, title, save_flags) + pl_[load|save]im (pl, imname[, save_flags]) + + ptr = pl_access (pl, v) + bool = pl_linenotempty (pl, v) + bool = pl_sectnotempty (pl, vs, ve, ndim) + pl[gp]l[lrp][sil] (pl, v, buf, b_depth, npix, rop) + + pl_[set|get]plane (pl, v) + pl_point (pl, x, y, rop) + pl_circle (pl, x, y, r, rop) + pl_box (pl, x1,y1, x2,y2, rop) + pl_line (pl, x1,y1, x2,y2, width, rop) + pl_polygon (pl, x, y, npts, rop) + + pl_rop (pl_src, vs, pl_dst, vs, vn, rop) + pl_stencil (pl_src, vs, pl_dst, vs, pl_stl, vs, vn, rop) + + +3.1 Random Access to a Pixel List + + plr = plr_open (pl, plane, buflimit) + plr_setrect (plr, x1,y1, x2,y2) + mval = plr_getpix (plr, i, j) + plr_getlut (plr, bufp, xsize,ysize, xblock,yblock) + plr_close (plr) + + +3.2 Pixel, Line, and Range List Routines + + pl_pixrop (px_src, xs, src_maxval, + px_dst, ds, dst_maxval, npix, rop) + pl_linerop (ll_src, xs, src_maxval, + ll_dst, ds, dst_maxval, ll_out, npix, rop) + pl_rangerop (rl_src, xs, src_maxval, + rl_dst, ds, dst_maxval, rl_out, npix, rop) + pl_linestencil (ll_src, xs, src_maxval, ll_dst, ds, dst_maxval, + ll_stn, xs, ll_out, npix, rop) + + n = pl_[lrp]2[lrp][sil] (op_src, xs, op_dst, npix) + + +4. EXAMPLE + +4.1 Sample Mask (pl_draw output) + + 40 .1111111..............................................................22222 + 39 .1111111..............................................................22222 + 38 .1111111...............................................................2222 + 37 .1111111...............................................................2222 + 36 .1111111............................................................4...... + 35 .1111111.....................11111111111111111111111111...........4444..... + 34 .1111111.....................11111111111111111111111111........44444444.... + 33 .1111111......................1111111111111111111111111......44444444...... + 32 .1111111......................1111111111111111111111111...44444444......... + 31 .1111111......................1111111111111111111111111.44444444........... + 30 .1111111...........4..........1111111111111111111111115444444.............. + 29 .1111111...........4..........11111111111111111111155554444................ + 28 .1111111...........4..........111111111111111111155555544.................. + 27 .1111111...........4..........1111111111111111555555551.................... + 26 .1111111.....................11111111111111155555555111.................... + 25 .1111111.....................11111111111115555555111111.................... + 24 ............................1111111111155444444.1111111.................... + 23 ...........................111111111155544444....111111.................... + 22 ..............1...........1111111155555444........11111.................... + 21 ........................1111111155555554..........11111.................... + 20 ........................111111555555511...........11111.................... + 19 ........................111555555551111...........11111.................... + 18 ........................155555555111111...........11111.................... + 17 ......................445555551111111111.........111111.................... + 16 ....................444455551111111111111.......1111111.................... + 15 ..................4444445111111111111111111111111111111.................... + 14 ...............44444444.1111111111111111111111111111111.................... + 13 .............44444444...................................................... + 12 ..........44444444......................................................... + 11 ........44444444........................................................... + 10 .........4444........................22222................................. + 9 ..........4.........................2222222..............22222............. + 8 ....................................2222222.............2222222............ + 7 ....................................2222222.............2222222............ + 6 .....................................22222..............2222222............ + 5 11111111111111111111.....................................22222............. + 4 11111111111111111111....................................................... + 3 11111111111111111111....................................................... + 2 11111111111111111111....................................................... + 1 11111111111111111111....................................................... + 123456789012345678901234567890123456789012345678901234567890123456789012345 + 1 2 3 4 5 6 7 + + +4.2 Sample Debug Output (for above mask) + +Mask 1EECD naxes=2 [75,40] maxval=177 plane=[75,40] +max buffered line size 1024, max actual line size 16 +40 lines total, 40 are nonempty, mask is nonempty +llbp=42AF5, len=1190, op=583, free=189, nupdates=35 +Index at 1EFF1 containing 40 lines: + 4 4 4 4 17 26 35 35 166 177 187 + 194 201 208 218 228 241 254 266 554 292 568 + 319 333 347 360 492 507 523 539 423 435 447 + 459 471 483 148 148 157 157 +Line list containing 40 lines: +[1:4] IH48(49) H20 Z55 (75,49) +[5] IH48(49) H20 IH1(50) Z37 H5 Z13 (75,50) +[6] IH49(50) Z37 H5 Z14 H7 Z12 (75,50) +[7:8] IH49(50) Z36 H7 Z13 H7 Z12 (75,50) +[9] IH51(52) P11 DH2(50) Z25 H7 Z14 H5 Z13 (75,50) +[10] IH51(52) Z9 H4 DH2(50) Z24 H5 Z33 (75,50) +[11] IH51(52) Z8 H8 Z59 (75,52) +[12] IH51(52) Z10 H8 Z57 (75,52) +[13] IH51(52) Z13 H8 Z54 (75,52) +[14] IH51(52) Z15 H8 DH3(49) Z1 H31 Z20 (75,49) +[15] IH51(52) Z18 H6 IS1(53) DH4(49) H30 Z20 (75,49) +[16] IH51(52) Z20 H4 IH1(53) H4 DH4(49) H13 Z7 H7 Z20 (75,49) +[17] IH51(52) Z22 H2 IH1(53) H6 DH4(49) H10 Z9 H6 Z20 (75,49) +[18] IH48(49) P25 IH4(53) H8 DH4(49) H6 Z11 H5 Z20 (75,49) +[19] IH48(49) Z24 H3 IH4(53) H8 DH4(49) H4 Z11 H5 Z20 (75,49) +[20] IH48(49) Z24 H6 IH4(53) H7 DH4(49) H2 Z11 H5 Z20 (75,49) +[21] IH48(49) Z24 H8 IH4(53) H7 DS1(52) DH3(49) Z10 H5 Z20 (75,49) +[22] IH48(49) P15 Z11 H8 IH4(53) H5 DH1(52) H3 DH3(49) Z8 H5 Z20 (75,49) +[23] IH48(49) Z27 H10 IH4(53) H3 DH1(52) H5 DH3(49) Z4 H6 Z20 (75,49) +[24] IH48(49) Z28 H11 IH4(53) H2 DH1(52) H6 DH3(49) Z1 H7 Z20 (75,49) +[25] IH48(49) Z1 H7 Z21 H13 IH4(53) H7 DH4(49) H6 Z20 (75,49) +[26] IH48(49) Z1 H7 Z21 H15 IH4(53) H8 DH4(49) H3 Z20 (75,49) +[27] IH48(49) Z1 H7 IH3(52) P12 DH3(49) Z10 H16 IH4(53) H8 DS4(49) Z20 + (75,49) +[28] IH48(49) Z1 H7 IH3(52) P12 DH3(49) Z10 H19 IH4(53) H6 DH1(52) H2 Z18 + (75,52) +[29] IH48(49) Z1 H7 IH3(52) P12 DH3(49) Z10 H21 IH4(53) H4 DH1(52) H4 Z16 + (75,52) +[30] IH48(49) Z1 H7 IH3(52) P12 DH3(49) Z10 H24 IS4(53) DH1(52) H6 Z14 + (75,52) +[31] IH48(49) Z1 H7 Z22 H25 IH3(52) Z1 H8 Z11 (75,52) +[32] IH48(49) Z1 H7 Z22 H25 IH3(52) Z3 H8 Z9 (75,52) +[33] IH48(49) Z1 H7 Z22 H25 IH3(52) Z6 H8 Z6 (75,52) +[34] IH48(49) Z1 H7 Z21 H26 IH3(52) Z8 H8 Z4 (75,52) +[35] IH48(49) Z1 H7 Z21 H26 IH3(52) Z11 H4 Z5 (75,52) +[36] IH48(49) Z1 H7 IH3(52) P61 Z6 (75,52) +[37:38] IH48(49) Z1 H7 IH1(50) Z63 H4 (75,50) +[39:40] IH48(49) Z1 H7 IH1(50) Z62 H5 (75,50) + +Line list containing 40 lines: +[1:4] 1-20(49) +[5] 1-20(49) 58-62(50) +[6] 38-42(50) 57-63(50) +[7:8] 37-43(50) 57-63(50) +[9] 11(52) 37-43(50) 58-62(50) +[10] 10-13(52) 38-42(50) +[11] 9-16(52) +[12] 11-18(52) +[13] 14-21(52) +[14] 16-23(52) 25-55(49) +[15] 19-24(52) 25(53) 26-55(49) +[16] 21-24(52) 25-28(53) 29-41(49) 49-55(49) +[17] 23-24(52) 25-30(53) 31-40(49) 50-55(49) +[18] 25(49) 26-33(53) 34-39(49) 51-55(49) +[19] 25-27(49) 28-35(53) 36-39(49) 51-55(49) +[20] 25-30(49) 31-37(53) 38-39(49) 51-55(49) +[21] 25-32(49) 33-39(53) 40(52) 51-55(49) +[22] 15(49) 27-34(49) 35-39(53) 40-42(52) 51-55(49) +[23] 28-37(49) 38-40(53) 41-45(52) 50-55(49) +[24] 29-39(49) 40-41(53) 42-47(52) 49-55(49) +[25] 2-8(49) 30-42(49) 43-49(53) 50-55(49) +[26] 2-8(49) 30-44(49) 45-52(53) 53-55(49) +[27] 2-8(49) 20(52) 31-46(49) 47-54(53) 55(49) +[28] 2-8(49) 20(52) 31-49(49) 50-55(53) 56-57(52) +[29] 2-8(49) 20(52) 31-51(49) 52-55(53) 56-59(52) +[30] 2-8(49) 20(52) 31-54(49) 55(53) 56-61(52) +[31] 2-8(49) 31-55(49) 57-64(52) +[32] 2-8(49) 31-55(49) 59-66(52) +[33] 2-8(49) 31-55(49) 62-69(52) +[34] 2-8(49) 30-55(49) 64-71(52) +[35] 2-8(49) 30-55(49) 67-70(52) +[36] 2-8(49) 69(52) +[37:38] 2-8(49) 72-75(50) +[39:40] 2-8(49) 71-75(50) diff --git a/sys/pmio/mio.h b/sys/pmio/mio.h new file mode 100644 index 00000000..11e4c9d0 --- /dev/null +++ b/sys/pmio/mio.h @@ -0,0 +1,56 @@ +# MIO -- Image i/o through a mask. +# +# The MIO routines are used to sequentially read or write the portion of +# the image IM which is "visible" through the mask denoted by the mask name +# PLNAME or the open mask descriptor PM. An image pixel is said to be visible +# if the associated mask pixel is nonzero. The PMIO routines may be used prior +# to performing any i/o to prepare the desired mask, e.g., a mask might be +# inverted to access only the "masked" pixels, or a mask might be ANDed with a +# region to limit i/o to only the portions of the image visible through both +# the mask and the region. Certain commonly performed mask conversions may be +# performed at MIO_OPEN time via the FLAGS argument, e.g., inversion, or +# conversion of an integer mask to a boolean mask. +# +# mp = mio_open (mask, flags, im) +# mp = mio_openo (pm, im) +# value = mio_stati (mp, param) +# mio_seti (mp, param, value) +# mio_setrange (mp, vs, ve, ndim) +# n|EOF = mio_[gp]lseg[silrdx] (mp, ptr, mval, v, npix) +# mio_close (mp) +# +# mio_open flags (defined in ): +# +# INVERT_MASK invert mask (PIX_NOT(PIX_SRC)) +# BOOLEAN_MASK convert mask to boolean if not already +# +# set/stat params (defined in ): +# +# P_PMDES pixel mask descriptor +# P_IMDES image descriptor +# P_REGCOORDS mio_setrange region relative coords +# +# The get/put line segment i/o routines return successive line segments of +# constant value from the data image IM, advancing through the image in storage +# order starting at the position vector [1,1,1...,N]. A pointer to each line +# segment is returned in PTR, with the associated integer mask value in MVAL, +# and the vector coordinates and length of the line segment in V and NPIX. +# EOF is returned when there are no more visible pixels to be read through the +# masked region. + +define LEN_MIODES 50 +define M_IM Memi[$1] # image descriptor +define M_PM Memi[$1+1] # mask descriptor +define M_PMCLOSE Memi[$1+2] # have mio_close close mask +define M_DEPTH Memi[$1+3] # have mio_close close mask +define M_ACTIVE Memi[$1+4] # set once i/o begins +define M_LBP Memi[$1+5] # line buffer pointer +define M_RLP Memi[$1+6] # range list pointer +define M_RLI Memi[$1+7] # range list index +define M_NDIM Memi[$1+8] # dimensionality of section +define M_LINEIO Memi[$1+9] # section is entire line +define M_REGCOORDS Memi[$1+10] # region relative coords +define M_V Meml[$1+11+$2-1] # current vector +define M_VS Meml[$1+20+$2-1] # start vector +define M_VE Meml[$1+30+$2-1] # end vector +define M_VN Meml[$1+40+$2-1] # size of section diff --git a/sys/pmio/mioclose.x b/sys/pmio/mioclose.x new file mode 100644 index 00000000..7b321512 --- /dev/null +++ b/sys/pmio/mioclose.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mio.h" + +# MIO_CLOSE -- Close an MIO descriptor. + +procedure mio_close (mp) + +pointer mp #I MIO descriptor + +begin + if (M_PMCLOSE(mp) == YES) + call pm_close (M_PM(mp)) + if (M_RLP(mp) != NULL) + call mfree (M_RLP(mp), TY_INT) + call mfree (mp, TY_STRUCT) +end diff --git a/sys/pmio/miogl.gx b/sys/pmio/miogl.gx new file mode 100644 index 00000000..3b02710e --- /dev/null +++ b/sys/pmio/miogl.gx @@ -0,0 +1,103 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "../mio.h" + +# MIO_GLSEG -- Get a line segment from a masked image. A line segment is a +# region of the data image for which the corresponding region of the mask has +# the constant nonzero value MVAL. Line segments are returned for each line in +# the region VS to VE, returning the number of pixels in each line segment as +# the function value, or EOF when the region is exhausted. Once EOF is +# reached, repeated calls will continue to return EOF until the next call to +# MIO_SETRANGE. Repeated calls to MIO_SETRANGE may be used to access a series +# of distinct regions in the image. If a subregion of the image is being +# accessed with MIO_SETRANGE, the vector coordinates V returned below will +# be relative to the defined subregion (if this is not what is desired, +# the range should be set to the full image and a region mask used to mask +# off the subregion to be accessed). + +int procedure mio_glseg$t (mp, ptr, mval, v, npix) + +pointer mp #I MIO descriptor +pointer ptr #O pointer to a buffer containing the data +int mval #O mask value for the output line segment +long v[IM_MAXDIM] #U coords of first pixel in output ine segment +int npix #O number of pixels in output line segment + +int x1, i +long ve[IM_MAXDIM] +pointer pm, im, rl, rp, bp +pointer imgl2$t(), imgl3$t(), imggs$t() +errchk imgl2$t, imgl3$t, imggs$t, pm_glri +bool pm_sectnotempty() +int plloop() + +begin + pm = M_PM(mp) + rl = M_RLP(mp) + + # Initialization performed for the first i/o on a new region. + if (M_ACTIVE(mp) == NO) { + call plsslv (pm, M_VS(mp,1), M_VN(mp,1), M_V(mp,1), M_VE(mp,1)) + call pm_glri (pm, + M_V(mp,1), Memi[rl], M_DEPTH(mp), M_VN(mp,1), PIX_SRC) + M_RLI(mp) = RL_FIRST + M_ACTIVE(mp) = YES + } + + # Get a new mask line? + while (M_RLI(mp) > RLI_LEN(rl)) + if (plloop (M_V(mp,1), M_VS(mp,1), M_VE(mp,1), + M_NDIM(mp)) == LOOP_DONE) { + return (EOF) + } else { + call amovl (M_V(mp,1), ve, M_NDIM(mp)) + ve[1] = M_VE(mp,1) + if (pm_sectnotempty (pm, M_V(mp,1), ve, M_NDIM(mp))) { + call pm_glri (pm, + M_V(mp,1), Memi[rl], M_DEPTH(mp), M_VN(mp,1), PIX_SRC) + M_RLI(mp) = RL_FIRST + } + } + + # Get a new image line? + if (M_RLI(mp) == RL_FIRST) { + call amovl (M_V(mp,1), v, M_NDIM(mp)) + im = M_IM(mp) + + if (M_LINEIO(mp) == YES && M_NDIM(mp) == 2) + bp = imgl2$t (im, v[2]) + else if (M_LINEIO(mp) == YES && M_NDIM(mp) == 3) + bp = imgl3$t (im, v[2], v[3]) + else { + call amovl (v, ve, M_NDIM(mp)); ve[1] = M_VE(mp,1) + bp = imggs$t (im, v, ve, M_NDIM(mp)) + } + + M_LBP(mp) = bp + } else + bp = M_LBP(mp) + + # Return the next line segment. + rp = rl + (M_RLI(mp) - 1) * RL_LENELEM + M_RLI(mp) = M_RLI(mp) + 1 + + x1 = Memi[rp+RL_XOFF] + npix = Memi[rp+RL_NOFF] + mval = Memi[rp+RL_VOFF] + ptr = bp + x1 - M_VS(mp,1) + + if (M_REGCOORDS(mp) == NO) { + v[1] = x1 + do i = 2, M_NDIM(mp) + v[i] = M_V(mp,i) + } else { + v[1] = x1 - M_VS(mp,1) + 1 + do i = 2, M_NDIM(mp) + v[i] = M_V(mp,i) - M_VS(mp,i) + 1 + } + + return (npix) +end diff --git a/sys/pmio/mioopen.x b/sys/pmio/mioopen.x new file mode 100644 index 00000000..b22c2022 --- /dev/null +++ b/sys/pmio/mioopen.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mio.h" + +# MIO_OPEN -- Open a pixel mask for masked i/o on the given data image. +# The data image also serves as the reference image for coordinate (section) +# transformations. + +pointer procedure mio_open (mask, flags, im) + +char mask[ARB] #I mask name +int flags #I flag bits +pointer im #I data (and reference) image + +pointer pm, mp +char title[1] +pointer im_pmopen(), mio_openo() +errchk im_pmopen + +begin + pm = im_pmopen (mask, flags, title, 0, im) + mp = mio_openo (pm, im) + + M_PMCLOSE(mp) = YES + M_DEPTH(mp) = PM_MAXDEPTH + if (and (flags, BOOLEAN_MASK) != 0) + M_DEPTH(mp) = 1 + + return (mp) +end diff --git a/sys/pmio/mioopeno.x b/sys/pmio/mioopeno.x new file mode 100644 index 00000000..bd3a6a96 --- /dev/null +++ b/sys/pmio/mioopeno.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "mio.h" + +# MIO_OPENO -- Open an MIO descriptor for the given mask and data image. + +pointer procedure mio_openo (pm, im) + +pointer pm #I mask descriptor +pointer im #I image descriptor + +pointer mp + +begin + call calloc (mp, LEN_MIODES, TY_STRUCT) + call malloc (M_RLP(mp), RL_MAXLEN(pm), TY_INT) + RLI_LEN(M_RLP(mp)) = 0 + + call amovkl (1, M_VS(mp,1), IM_MAXDIM) + call amovl (IM_LEN(im,1), M_VN(mp,1), IM_MAXDIM) + + M_IM(mp) = im + M_PM(mp) = pm + call pm_seti (pm, P_REFIM, im) + call mio_setrange (mp, M_VS(mp,1), M_VN(mp,1), IM_NDIM(im)) + + return (mp) +end diff --git a/sys/pmio/miopl.gx b/sys/pmio/miopl.gx new file mode 100644 index 00000000..be7b7b95 --- /dev/null +++ b/sys/pmio/miopl.gx @@ -0,0 +1,102 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "../mio.h" + +# MIO_PLSEG -- Put a line segment to a masked image. A line segment is a +# region of the data image for which the corresponding region of the mask has +# the constant nonzero value MVAL. Line segments are returned for each line in +# the region VS to VE, returning the number of pixels in each line segment as +# the function value, or EOF when the region is exhausted. Once EOF is +# reached, repeated calls will continue to return EOF until the next call to +# MIO_SETRANGE. Repeated calls to MIO_SETRANGE may be used to access a series +# of distinct regions in the image. If a subregion of the image is being +# accessed with MIO_SETRANGE, the vector coordinates V returned below will +# be relative to the defined subregion (if this is not what is desired, +# the range should be set to the full image and a region mask used to mask +# off the subregion to be accessed). + +int procedure mio_plseg$t (mp, ptr, mval, v, npix) + +pointer mp #I MIO descriptor +pointer ptr #O pointer to a buffer containing the data +int mval #O mask value for the output line segment +long v[IM_MAXDIM] #U vector coordinates of first pixel +int npix #O number of pixels in output line segment + +int x1, i +long ve[IM_MAXDIM] +pointer pm, im, rl, rp, bp +pointer impl2$t(), impl3$t(), impgs$t() +errchk impl2$t, impl3$t, impgs$t, pm_glri +bool pm_sectnotempty() +int plloop() + +begin + pm = M_PM(mp) + rl = M_RLP(mp) + + # Initialization performed for the first i/o on a new region. + if (M_ACTIVE(mp) == NO) { + call plsslv (pm, M_VS(mp,1), M_VN(mp,1), M_V(mp,1), M_VE(mp,1)) + call pm_glri (pm, + M_V(mp,1), Memi[rl], M_DEPTH(mp), M_VN(mp,1), PIX_SRC) + M_RLI(mp) = RL_FIRST + M_ACTIVE(mp) = YES + } + + # Get a new mask line? + while (M_RLI(mp) > RLI_LEN(rl)) + if (plloop (M_V(mp,1), M_VS(mp,1), M_VE(mp,1), + M_NDIM(mp)) == LOOP_DONE) { + return (EOF) + } else { + call amovl (M_V(mp,1), ve, M_NDIM(mp)) + ve[1] = M_VE(mp,1) + if (pm_sectnotempty (pm, M_V(mp,1), ve, M_NDIM(mp))) { + call pm_glri (pm, + M_V(mp,1), Memi[rl], M_DEPTH(mp), M_VN(mp,1), PIX_SRC) + M_RLI(mp) = RL_FIRST + } + } + + + # Get a new image line? + if (M_RLI(mp) == RL_FIRST) { + call amovl (M_V(mp,1), v, IM_MAXDIM) + im = M_IM(mp) + + if (M_LINEIO(mp) == YES && M_NDIM(mp) == 2) + bp = impl2$t (im, v[2]) + else if (M_LINEIO(mp) == YES && M_NDIM(mp) == 3) + bp = impl3$t (im, v[2], v[3]) + else + bp = impgs$t (im, v, ve, M_NDIM(mp)) + + M_LBP(mp) = bp + } else + bp = M_LBP(mp) + + # Return the next line segment. + rp = rl + (M_RLI(mp) - 1) * RL_LENELEM + M_RLI(mp) = M_RLI(mp) + 1 + + x1 = Memi[rp+RL_XOFF] + npix = Memi[rp+RL_NOFF] + mval = Memi[rp+RL_VOFF] + ptr = bp + x1 - M_VS(mp,1) + + if (M_REGCOORDS(mp) == NO) { + v[1] = x1 + do i = 2, M_NDIM(mp) + v[i] = M_V(mp,i) + } else { + v[1] = x1 - M_VS(mp,1) + 1 + do i = 2, M_NDIM(mp) + v[i] = M_V(mp,i) - M_VS(mp,i) + 1 + } + + return (npix) +end diff --git a/sys/pmio/mioseti.x b/sys/pmio/mioseti.x new file mode 100644 index 00000000..ef4fe116 --- /dev/null +++ b/sys/pmio/mioseti.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "mio.h" + +# MIO_SETI -- Set an MIO parameter. + +procedure mio_seti (mp, param, value) + +pointer mp #I MIO descriptor +int param #I parameter to be set +int value #I new value + +begin + switch (param) { + case P_PMDES: + M_PM(mp) = value + M_ACTIVE(mp) = NO + case P_IMDES: + M_IM(mp) = value + M_ACTIVE(mp) = NO + case P_REGCOORDS: + M_REGCOORDS(mp) = value + case P_PMCLOSE: + M_PMCLOSE(mp) = value + default: + call syserr (SYS_PLINVPAR) + } +end diff --git a/sys/pmio/miosrange.x b/sys/pmio/miosrange.x new file mode 100644 index 00000000..26b42727 --- /dev/null +++ b/sys/pmio/miosrange.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "mio.h" + +# MIO_SETRANGE -- Set the region of the image to be accessed, and rewind the +# i/o pointer to the beginning of the specified region. + +procedure mio_setrange (mp, vs, ve, ndim) + +pointer mp #I MIO descriptor +long vs[IM_MAXDIM] #I vector coords of start of region +long ve[IM_MAXDIM] #I vector coords of end of region +int ndim #I dimensionality of region + +int i +int btoi() + +begin + do i = 1, IM_MAXDIM + if (i <= ndim) { + M_VS(mp,i) = min (vs[i], ve[i]) + M_VN(mp,i) = abs (ve[i] - vs[i]) + 1 + } else { + M_VS(mp,i) = 1 + M_VN(mp,i) = 1 + } + + M_LINEIO(mp) = btoi (vs[1] == 1 && ve[1] == IM_LEN(M_IM(mp),1)) + M_REGCOORDS(mp) = YES + M_ACTIVE(mp) = NO + M_NDIM(mp) = ndim +end diff --git a/sys/pmio/miostati.x b/sys/pmio/miostati.x new file mode 100644 index 00000000..3f492daa --- /dev/null +++ b/sys/pmio/miostati.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "mio.h" + +# MIO_STATI -- Stat an MIO parameter. + +int procedure mio_stati (mp, param) + +pointer mp #I MIO descriptor +int param #I parameter to be set + +begin + switch (param) { + case P_PMDES: + return (M_PM(mp)) + case P_IMDES: + return (M_IM(mp)) + case P_REGCOORDS: + return (M_REGCOORDS(mp)) + case P_PMCLOSE: + return (M_PMCLOSE(mp)) + default: + call syserr (SYS_PLINVPAR) + } +end diff --git a/sys/pmio/mkpkg b/sys/pmio/mkpkg new file mode 100644 index 00000000..0c03f90d --- /dev/null +++ b/sys/pmio/mkpkg @@ -0,0 +1,68 @@ +# Make the PM package library. + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +tfiles: + $set PFLAGS = "-k -t silrdx -p tf/" + $set GFLAGS = "-k -t sil -p tf/" + $ifolder (tf/miogli.x, miogl.gx) $generic $(PFLAGS) miogl.gx $endif + $ifolder (tf/miopli.x, miopl.gx) $generic $(PFLAGS) miopl.gx $endif + $ifolder (tf/pmglpi.x, pmglp.gx) $generic $(GFLAGS) pmglp.gx $endif + $ifolder (tf/pmglri.x, pmglr.gx) $generic $(GFLAGS) pmglr.gx $endif + $ifolder (tf/pmplpi.x, pmplp.gx) $generic $(GFLAGS) pmplp.gx $endif + $ifolder (tf/pmplri.x, pmplr.gx) $generic $(GFLAGS) pmplr.gx $endif + ; + +zzdebug: +zzdebug.e: + $set XFLAGS = "$(XFLAGS) -q" + $omake zzinterp.x + $omake zzdebug.x + $link zzdebug.o zzinterp.o -o zzdebug.e + ; + +libex.a: + # Retranslate any recently modified generic sources. + $ifeq (hostid, unix) + $call tfiles + $endif + + # Transfer dependency to . + $ifnewer (, ) + $copy temp.pm + $move temp.pm + $endif + + @tf # Update datatype expanded files. + + mioclose.x mio.h + mioopen.x mio.h + mioopeno.x mio.h + mioseti.x mio.h + miosrange.x mio.h + miostati.x mio.h + pmaccess.x pmio.com + pmascii.x pmio.com + pmbox.x pmio.com + pmcircle.x pmio.com + pmclear.x pmio.com + pmempty.x pmio.com + pmglls.x pmio.com + pmline.x pmio.com + pmlinene.x pmio.com + pmnewmask.x + pmplls.x pmio.com + pmpoint.x pmio.com + pmpolygon.x pmio.com + pmrio.x pmio.com + pmrop.x pmio.com + pmsectnc.x pmio.com + pmsectne.x pmio.com + pmseti.x + pmstati.x + pmsplane.x pmio.com + pmsten.x pmio.com + ; diff --git a/sys/pmio/plprop.gx b/sys/pmio/plprop.gx new file mode 100644 index 00000000..60d1c603 --- /dev/null +++ b/sys/pmio/plprop.gx @@ -0,0 +1,177 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PL_PIXROP -- Rasterop between source and destination pixel arrays. + +procedure pl_pixrop$t (px_src,xs,src_maxval, px_dst,ds,dst_maxval, npix, rop) + +PIXEL px_src[ARB] #I source pixel array +int xs #I starting pixel index in src +int src_maxval #I max pixel value in src mask +PIXEL px_dst[ARB] #O destination pixel array +int ds #I starting pixel index in dst +int dst_maxval #I max pixel value in dst mask +int npix #I number of pixels to convert +int rop #I rasterop + +pointer sp, src +int opcode, i +PIXEL data, ceil, src_value +int and(), or(), xor(), not() +define out_ 91 + +begin + opcode = R_OPCODE(rop) + data = R_DATA(rop) + ceil = 0 + + # Pixel value to be used if input mask is boolean. + if (src_maxval == 1) { + src_value = data + if (src_value <= 0) + src_value = dst_maxval + } + + # Handle the easy cases first. + switch (opcode) { + case PIX_CLR: + call aclr$t (px_dst[ds], npix) + return + case PIX_SET: + call amovk$t (data, px_dst[ds], npix) + goto out_ + case PIX_SRC: + if (src_maxval != 1) + call amov$t (px_src[xs], px_dst[ds], npix) + else { + do i = 1, npix + if (px_src[xs+i-1] > 0) + px_dst[ds+i-1] = src_value + else + px_dst[ds+i-1] = 0 + } + + goto out_ + case PIX_DST: + return # no-op + } + + # Integer or boolean source mask? + if (src_maxval != 1) { + # Integer source mask; operate directly on source mask. + + switch (opcode) { + case PIX_NOTSRC: + do i = 1, npix + px_dst[ds+i-1] = not (px_src[xs+i-1]) + case PIX_NOTDST: + do i = 1, npix + px_dst[ds+i-1] = not (px_dst[xs+i-1]) + + case PIX_SRC_AND_DST: + do i = 1, npix + px_dst[ds+i-1] = and (px_src[xs+i-1], px_dst[ds+i-1]) + case PIX_SRC_OR_DST: + do i = 1, npix + px_dst[ds+i-1] = or (px_src[xs+i-1], px_dst[ds+i-1]) + case PIX_SRC_XOR_DST: + do i = 1, npix + px_dst[ds+i-1] = xor (px_src[xs+i-1], px_dst[ds+i-1]) + + case PIX_SRC_AND_NOTDST: + do i = 1, npix + px_dst[ds+i-1] = and (px_src[xs+i-1], not(px_dst[ds+i-1])) + case PIX_SRC_OR_NOTDST: + do i = 1, npix + px_dst[ds+i-1] = or (px_src[xs+i-1], not(px_dst[ds+i-1])) + case PIX_NOTSRC_AND_DST: + do i = 1, npix + px_dst[ds+i-1] = and (not(px_src[xs+i-1]), px_dst[ds+i-1]) + case PIX_NOTSRC_OR_DST: + do i = 1, npix + px_dst[ds+i-1] = or (not(px_src[xs+i-1]), px_dst[ds+i-1]) + + case PIX_NOT_SRC_AND_DST: + do i = 1, npix + px_dst[ds+i-1] = not (and (px_src[xs+i-1], px_dst[ds+i-1])) + case PIX_NOT_SRC_OR_DST: + do i = 1, npix + px_dst[ds+i-1] = not ( or (px_src[xs+i-1], px_dst[ds+i-1])) + case PIX_NOT_SRC_XOR_DST: + do i = 1, npix + px_dst[ds+i-1] = not (xor (px_src[xs+i-1], px_dst[ds+i-1])) + } + + } else { + # Boolean source mask; use integer DATA value from ROP if source + # mask pixel is set. + + call smark (sp) + call salloc (src, npix, TY_PIXEL) + + do i = 1, npix + if (px_src[xs+i-1] > 0) + Mem$t[src+i-1] = src_value + else + Mem$t[src+i-1] = 0 + + switch (opcode) { + case PIX_NOTSRC: + do i = 1, npix + px_dst[ds+i-1] = not (Mem$t[src+i-1]) + case PIX_NOTDST: + do i = 1, npix + px_dst[ds+i-1] = not (px_dst[xs+i-1]) + + case PIX_SRC_AND_DST: + do i = 1, npix + px_dst[ds+i-1] = and (Mem$t[src+i-1], px_dst[ds+i-1]) + case PIX_SRC_OR_DST: + do i = 1, npix + px_dst[ds+i-1] = or (Mem$t[src+i-1], px_dst[ds+i-1]) + case PIX_SRC_XOR_DST: + do i = 1, npix + px_dst[ds+i-1] = xor (Mem$t[src+i-1], px_dst[ds+i-1]) + + case PIX_SRC_AND_NOTDST: + do i = 1, npix + px_dst[ds+i-1] = and (Mem$t[src+i-1], not(px_dst[ds+i-1])) + case PIX_SRC_OR_NOTDST: + do i = 1, npix + px_dst[ds+i-1] = or (Mem$t[src+i-1], not(px_dst[ds+i-1])) + case PIX_NOTSRC_AND_DST: + do i = 1, npix + px_dst[ds+i-1] = and (not(Mem$t[src+i-1]), px_dst[ds+i-1]) + case PIX_NOTSRC_OR_DST: + do i = 1, npix + px_dst[ds+i-1] = or (not(Mem$t[src+i-1]), px_dst[ds+i-1]) + + case PIX_NOT_SRC_AND_DST: + do i = 1, npix + px_dst[ds+i-1] = not (and (Mem$t[src+i-1], px_dst[ds+i-1])) + case PIX_NOT_SRC_OR_DST: + do i = 1, npix + px_dst[ds+i-1] = not ( or (Mem$t[src+i-1], px_dst[ds+i-1])) + case PIX_NOT_SRC_XOR_DST: + do i = 1, npix + px_dst[ds+i-1] = not (xor (Mem$t[src+i-1], px_dst[ds+i-1])) + } + + call sfree (sp) + } +out_ + # If writing to an integer mask, mask the data to the indicated max + # value (necessary to avoid very large values if any NOT operations + # occurred). If writing to a boolean mask, map positive integer mask + # values to 1. + + if (dst_maxval == 1) { + data = 1 + call argt$t (px_dst[ds], npix, ceil, data) + } else if (dst_maxval > 1) { + data = dst_maxval + call aandk$t (px_dst[ds], data, px_dst[ds], npix) + } +end diff --git a/sys/pmio/pmaccess.x b/sys/pmio/pmaccess.x new file mode 100644 index 00000000..74f73e72 --- /dev/null +++ b/sys/pmio/pmaccess.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PM_ACCESS -- Return a pointer (type short) to the indicated mask image +# line. A valid pointer is always returned; if the mask line is empty, the +# pointer will reference the "empty line" linelist. + +pointer procedure pm_access (pl, v) + +pointer pl #I mask descriptor +long v[PM_MAXDIM] #I coordinates of desired line + +pointer pl_access() +include "pmio.com" + +begin + if (PM_MAPXY(pl) == YES) { + call imaplv (PM_REFIM(pl), v, v1, PM_MAXDIM) + return (pl_access (pl, v1)) + } else + return (pl_access (pl, v)) +end diff --git a/sys/pmio/pmascii.x b/sys/pmio/pmascii.x new file mode 100644 index 00000000..3e85d0af --- /dev/null +++ b/sys/pmio/pmascii.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PM_ASCIIDUMP -- Dump a two dimensional region of a mask as a printable ASCII +# character array on the output stream. Intended as a simple debugging tool; +# see also PM_SAVEIM. + +procedure pm_asciidump (pl, vs, ve, outfd) + +pointer pl #I mask descriptor +long vs[ARB] #I ll vector (only first two elements used) +long ve[ARB] #I ur vector (only first two elements used) +int outfd #I output file + +include "pmio.com" + +begin + if (PM_MAPXY(pl) == NO) + call pl_asciidump (pl, vs, ve, outfd) + else { + call imaplv (PM_REFIM(pl), vs, v1, PM_MAXDIM) + call imaplv (PM_REFIM(pl), ve, v2, PM_MAXDIM) + call pl_asciidump (pl, v1, v2, outfd) + } +end diff --git a/sys/pmio/pmbox.x b/sys/pmio/pmbox.x new file mode 100644 index 00000000..d54eb8fa --- /dev/null +++ b/sys/pmio/pmbox.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PM_BOX -- Rasterop between a box as source, and an existing mask as dest. +# This is a 2-dim operator. The pm_setplane procedure is used to specify +# the plane to be modified. + +procedure pm_box (pl, x1,y1, x2,y2, rop) + +pointer pl #I mask descriptor +int x1,y1 #I lower left corner of box +int x2,y2 #I upper right corner of box +int rop #I rasterop + +errchk pl_getplane +include "pmio.com" + +begin + if (PM_MAPXY(pl) == YES) { + call pl_getplane (pl, v1) + v1[1] = x1; v1[2] = y1 + call imaplv (PM_REFIM(pl), v1, v2, PM_MAXDIM) + + call pl_getplane (pl, v3) + v3[1] = x2; v3[2] = y2 + call imaplv (PM_REFIM(pl), v3, v4, PM_MAXDIM) + + call pl_box (pl, v2[1],v2[2], v4[1],v4[2], rop) + + } else + call pl_box (pl, x1,y1, x2,y2, rop) +end diff --git a/sys/pmio/pmcircle.x b/sys/pmio/pmcircle.x new file mode 100644 index 00000000..086da99a --- /dev/null +++ b/sys/pmio/pmcircle.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PM_CIRCLE -- Rasterop between a circular region as source, and an existing +# mask as destination. It is not necessary for the center of the circle to +# be inside the mask; if it is outside, the boundary of the circle will be +# clipped to the boundary of the mask. This is a 2-dim operator. If the +# image dimensionality is greater than two the pm_setplane procedure should +# be called first to specify the plane to be modified. + +procedure pm_circle (pl, x, y, radius, rop) + +pointer pl #I mask descriptor +int x,y #I center coords of circle +int radius #I radius of circle +int rop #I rasterop + +errchk pl_getplane +include "pmio.com" + +begin + if (PM_MAPXY(pl) == YES) { + call pl_getplane (pl, v1) + v1[1] = x; v1[2] = y + call imaplv (PM_REFIM(pl), v1, v2, PM_MAXDIM) + + call pl_getplane (pl, v3) + v3[1] = x + radius; v3[2] = y + call imaplv (PM_REFIM(pl), v3, v4, PM_MAXDIM) + + call pl_circle (pl, v2[1], v2[2], abs(v4[1]-v2[1]), rop) + + } else + call pl_circle (pl, x, y, radius, rop) +end diff --git a/sys/pmio/pmclear.x b/sys/pmio/pmclear.x new file mode 100644 index 00000000..1aed4013 --- /dev/null +++ b/sys/pmio/pmclear.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# PM_CLEAR -- Clear a mask. The entire surface is cleared. This is equivalent +# to a full surface pm_rop with rop=PIX_CLR, but is more convenient and can be +# implemented more efficiently since the entire surface is cleared. + +procedure pm_clear (pl) + +pointer pl #I mask descriptor + +include "pmio.com" + +begin + if (PM_MAPXY(pl) == YES) { + call amovkl (1, v1, PM_MAXDIM) + call imaplv (PM_REFIM(pl), v1, v2, PM_MAXDIM) + call amovl (IM_LEN(PM_REFIM(pl),1), v3, PM_MAXDIM) + call imaplv (PM_REFIM(pl), v3, v4, PM_MAXDIM) + + call pl_rop (NULL, NULL, pl, v2, v4, PIX_CLR) + + } else + call pl_clear (pl) +end diff --git a/sys/pmio/pmempty.x b/sys/pmio/pmempty.x new file mode 100644 index 00000000..c8797663 --- /dev/null +++ b/sys/pmio/pmempty.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# PM_EMPTY -- Test whether a mask is empty, i.e., contains no nonzero pixels. + +bool procedure pm_empty (pl) + +pointer pl #I mask descriptor + +bool pl_empty(), pl_sectnotempty() +include "pmio.com" + +begin + if (PM_MAPXY(pl) == YES) { + call amovkl (1, v1, PM_MAXDIM) + call imaplv (PM_REFIM(pl), v1, v2, PM_MAXDIM) + call amovl (IM_LEN(PM_REFIM(pl),1), v3, PM_MAXDIM) + call imaplv (PM_REFIM(pl), v3, v4, PM_MAXDIM) + + return (!pl_sectnotempty (pl, v2, v4, PM_MAXDIM)) + + } else + return (pl_empty (pl)) +end diff --git a/sys/pmio/pmglls.x b/sys/pmio/pmglls.x new file mode 100644 index 00000000..6604c999 --- /dev/null +++ b/sys/pmio/pmglls.x @@ -0,0 +1,78 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# PM_GLLS -- Get a line segment as a list list, applying the given ROP to +# combine the pixels with those of the output line list. + +procedure pm_glls (pl, v, ll_dst, ll_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +short ll_dst[ARB] #O output line list +int ll_depth #I line list depth, bits +int npix #I number of pixels desired +int rop #I rasterop + +int ll_len, temp, np, step, xstep +pointer sp, px_src, ll_src, ll_out, im +int pl_p2li() +include "pmio.com" + +begin + im = PM_REFIM(pl) + if (PM_MAPXY(pl) == NO) { + call pl_glls (pl, v, ll_dst, ll_depth, npix, rop) + return + } + + call smark (sp) + call salloc (ll_src, LL_MAXLEN(pl), TY_SHORT) + + # Determine physical coords of line segment. + call amovl (v, v3, PM_MAXDIM) + call imaplv (im, v3, v1, PM_MAXDIM) + v3[1] = v3[1] + npix - 1 + call imaplv (im, v3, v2, PM_MAXDIM) + + # Get line scaling parameters. + if (npix <= 1) + xstep = 1 + else + xstep = (v2[1] - v1[1]) / (npix - 1) + step = xstep + if (xstep < 0) { + temp = v1[1]; v1[1] = v2[1]; v2[1] = temp + step = -step + } + + # Extract the pixels. + np = (npix - 1) * step + 1 + call salloc (px_src, np, TY_INT) + call pl_glpi (pl, v1, Memi[px_src], 0, np, PIX_SRC) + + # Subsample and flip if necessary. + if (step > 1) + call imsamp (Memi[px_src], Memi[px_src], npix, SZ_INT, step) + if (xstep < 0) + call imaflp (Memi[px_src], npix, SZ_INT) + + # Convert to a line list. + ll_len = pl_p2li (Memi[px_src], 1, Mems[ll_src], npix) + + # Copy to or combine with destination. + if (!R_NEED_DST(rop)) { + ll_len = LP_LEN(ll_src) + call amovs (Mems[ll_src], ll_dst, ll_len) + } else { + call salloc (ll_out, LL_MAXLEN(pl), TY_SHORT) + call pl_linerop (Mems[ll_src], 1, PL_MAXVAL(pl), ll_dst, 1, + MV(ll_depth), Mems[ll_out], npix, rop) + ll_len = LP_LEN(ll_out) + call amovs (Mems[ll_out], ll_dst, ll_len) + } + + call sfree (sp) +end diff --git a/sys/pmio/pmglp.gx b/sys/pmio/pmglp.gx new file mode 100644 index 00000000..26c6b2e0 --- /dev/null +++ b/sys/pmio/pmglp.gx @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PM_GLP -- Get a line segment as a pixel array, applying the given ROP to +# combine the pixels with those of the output array. + +procedure pm_glp$t (pl, v, px_dst, px_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +PIXEL px_dst[ARB] #O output pixel array +int px_depth #I pixel depth, bits +int npix #I number of pixels desired +int rop #I rasterop + +int temp, np, step, xstep +pointer sp, px_src, px_out, im +include "../pmio.com" + +begin + im = PM_REFIM(pl) + if (PM_MAPXY(pl) == NO) { + call pl_glp$t (pl, v, px_dst, px_depth, npix, rop) + return + } + + call smark (sp) + + # Determine physical coords of line segment. + call amovl (v, v3, PM_MAXDIM) + call imaplv (im, v3, v1, PM_MAXDIM) + v3[1] = v3[1] + npix - 1 + call imaplv (im, v3, v2, PM_MAXDIM) + + # Get line scaling parameters. + if (npix <= 1) + xstep = 1 + else + xstep = (v2[1] - v1[1]) / (npix - 1) + step = xstep + if (xstep < 0) { + temp = v1[1]; v1[1] = v2[1]; v2[1] = temp + step = -step + } + + # Extract the pixels. + np = (npix - 1) * step + 1 + call salloc (px_src, np, TY_PIXEL) + call pl_glp$t (pl, v1, Mem$t[px_src], 0, np, PIX_SRC) + + # Subsample and flip if necessary. + if (step > 1) + call imsamp (Mem$t[px_src], Mem$t[px_src], npix, SZ_PIXEL, step) + if (xstep < 0) + call imaflp (Mem$t[px_src], npix, SZ_PIXEL) + + if (!R_NEED_DST(rop)) + call amov$t (Mem$t[px_src], px_dst, npix) + else { + call salloc (px_out, npix, TY_PIXEL) + call pl_pixrop$t (Mem$t[px_src], 1, PL_MAXVAL(pl), px_dst, 1, + MV(px_depth), npix, rop) + call amov$t (Mem$t[px_out], px_dst, npix) + } + + call sfree (sp) +end diff --git a/sys/pmio/pmglr.gx b/sys/pmio/pmglr.gx new file mode 100644 index 00000000..9c2e2606 --- /dev/null +++ b/sys/pmio/pmglr.gx @@ -0,0 +1,85 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# PM_GLR -- Get a line segment as a range list, applying the given ROP to +# combine the pixels with those of the output line list. Note that this +# operator uses IMIO if a section transformation is needed, hence if the +# application also uses IMIO to directly access the mask image, care must +# be taken to avoid confusion over the use of IMIO allocated pixel buffers. + +procedure pm_glr$t (pl, v, rl_dst, rl_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +PIXEL rl_dst[3,ARB] #O output line list +int rl_depth #I line list depth, bits +int npix #I number of pixels desired +int rop #I rasterop + +int rl_len, temp, step, xstep, np +pointer sp, px_src, rl_src, rl_out, im +include "../pmio.com" +int pl_p2r$t() + +begin + im = PM_REFIM(pl) + if (PM_MAPXY(pl) == NO) { + call pl_glr$t (pl, v, rl_dst, rl_depth, npix, rop) + return + } + + call smark (sp) + call salloc (rl_src, RL_MAXLEN(pl), TY_PIXEL) + + # Determine physical coords of line segment. + call amovl (v, v3, PM_MAXDIM) + call imaplv (im, v3, v1, PM_MAXDIM) + v3[1] = v3[1] + npix - 1 + call imaplv (im, v3, v2, PM_MAXDIM) + + # Get line scaling parameters. + if (npix <= 1) + xstep = 1 + else + xstep = (v2[1] - v1[1]) / (npix - 1) + step = xstep + if (xstep < 0) { + temp = v1[1]; v1[1] = v2[1]; v2[1] = temp + step = -step + } + + # Extract the pixels. + np = (npix - 1) * step + 1 + call salloc (px_src, np, TY_PIXEL) + call pl_glp$t (pl, v1, Mem$t[px_src], 0, np, PIX_SRC) + + # Subsample and flip if necessary. + if (step > 1) + call imsamp (Mem$t[px_src], Mem$t[px_src], npix, SZ_PIXEL, step) + if (xstep < 0) + call imaflp (Mem$t[px_src], npix, SZ_PIXEL) + + # Convert to a range list. + rl_len = pl_p2r$t (Mem$t[px_src], 1, Mem$t[rl_src], npix) + + # Copy to or combine with destination. + if (!R_NEED_DST(rop)) { + rl_len = RLI_LEN(rl_src) * RL_LENELEM + call amov$t (Mem$t[rl_src], rl_dst, rl_len) + } else { + call salloc (rl_out, RL_MAXLEN(pl), TY_PIXEL) + call pl_rangerop$t (Mem$t[rl_src], 1, PL_MAXVAL(pl), rl_dst, 1, + MV(rl_depth), Mem$t[rl_out], npix, rop) + $if (datatype == s) + rl_len = RLS_LEN(rl_out) * RL_LENELEM + $else + rl_len = RLI_LEN(rl_out) * RL_LENELEM + $endif + call amov$t (Mem$t[rl_out], rl_dst, rl_len) + } + + call sfree (sp) +end diff --git a/sys/pmio/pmio.com b/sys/pmio/pmio.com new file mode 100644 index 00000000..76616e6a --- /dev/null +++ b/sys/pmio/pmio.com @@ -0,0 +1,5 @@ +# PMIO.COM -- A few scratch vectors used in many of the PMIO routines, +# defined in common to save some space. + +long v1[PM_MAXDIM], v2[PM_MAXDIM], v3[PM_MAXDIM], v4[PM_MAXDIM] +common /pmiocom/ v1, v2, v3, v4 diff --git a/sys/pmio/pmline.x b/sys/pmio/pmline.x new file mode 100644 index 00000000..36be1cb4 --- /dev/null +++ b/sys/pmio/pmline.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PM_LINE -- Perform a rasterop operation upon a line of arbitrary width drawn +# at an arbitrary orientation in a 2-dimensional plane of a mask. If the +# dimensionality of the mask exceeds 2, the pm_setplane() procedure should be +# called first to define the plane of the mask to be modified. + +procedure pm_line (pl, x1, y1, x2, y2, width, rop) + +pointer pl #I mask descriptor +int x1,y1 #I start point of line +int x2,y2 #I end point of line +int width #I width of line to be drawn, pixels +int rop #I rasterop defining operation + +errchk pl_getplane +include "pmio.com" + +begin + if (PM_MAPXY(pl) == YES) { + call pl_getplane (pl, v1) + v1[1] = x1; v1[2] = y1 + call imaplv (PM_REFIM(pl), v1, v2, PM_MAXDIM) + + call pl_getplane (pl, v3) + v3[1] = x2; v3[2] = y2 + call imaplv (PM_REFIM(pl), v3, v4, PM_MAXDIM) + + call pl_line (pl, v2[1],v2[2], v4[1],v4[2], width, rop) + + } else + call pl_line (pl, x1, y1, x2, y2, width, rop) +end diff --git a/sys/pmio/pmlinene.x b/sys/pmio/pmlinene.x new file mode 100644 index 00000000..0e49de54 --- /dev/null +++ b/sys/pmio/pmlinene.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# PM_LINENOTEMPTY -- Test whether the indicated mask image line is empty. + +bool procedure pm_linenotempty (pl, v) + +pointer pl #I mask descriptor +long v[PM_MAXDIM] #I coordinates of desired line + +bool pl_sectnotempty(), pl_linenotempty() +include "pmio.com" + +begin + if (PM_MAPXY(pl) == YES) { + call imaplv (PM_REFIM(pl), v, v1, PM_MAXDIM) + call amovl (v, v2, PM_MAXDIM) + v2[1] = IM_LEN(PM_REFIM(pl),1) + call imaplv (PM_REFIM(pl), v2, v3, PM_MAXDIM) + + return (pl_sectnotempty (pl, v1, v3, PM_MAXDIM)) + + } else + return (pl_linenotempty (pl, v)) +end diff --git a/sys/pmio/pmnewmask.x b/sys/pmio/pmnewmask.x new file mode 100644 index 00000000..200e4841 --- /dev/null +++ b/sys/pmio/pmnewmask.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# PM_NEWMASK -- Create an empty mask with the same dimensionality and size as +# the given reference image. + +pointer procedure pm_newmask (ref_im, depth) + +pointer ref_im #I reference image +int depth #I mask depth, bits + +pointer pl +pointer pl_open() +errchk pl_open + +begin + pl = pl_open (NULL) + call pl_ssize (pl, IM_NDIM(ref_im), IM_SVLEN(ref_im,1), depth) + + PM_REFIM(pl) = ref_im + PM_MAPXY(pl) = IM_SECTUSED(ref_im) + + return (pl) +end diff --git a/sys/pmio/pmplls.x b/sys/pmio/pmplls.x new file mode 100644 index 00000000..b7f0e826 --- /dev/null +++ b/sys/pmio/pmplls.x @@ -0,0 +1,103 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PM_PLLS -- Put a line segment input as a list list to a mask, applying the +# given ROP to combine the pixels with those of the output mask. + +procedure pm_plls (pl, v, ll_raw, ll_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +short ll_raw[ARB] #I input line list +int ll_depth #I line list depth, bits +int npix #I number of pixels affected +int rop #I rasterop + +pointer sp, ll_src, ll_dst, ll_stn, ll_out, px_src, im +int ll_len, step, xstep, temp, np, ip, i +int pl_l2pi(), pl_p2li() +pointer pl_access() +include "pmio.com" + +begin + im = PM_REFIM(pl) + if (PM_MAPXY(pl) == NO) { + call pl_plls (pl, v, ll_raw, ll_depth, npix, rop) + return + } + + call smark (sp) + call salloc (ll_src, LL_MAXLEN(pl), TY_SHORT) + + # Determine physical coords of line segment. + call amovl (v, v3, PM_MAXDIM) + call imaplv (im, v3, v1, PM_MAXDIM) + v3[1] = v3[1] + npix - 1 + call imaplv (im, v3, v2, PM_MAXDIM) + + # Get line scaling parameters. + if (npix <= 1) + xstep = 1 + else + xstep = (v2[1] - v1[1]) / (npix - 1) + step = xstep + if (xstep < 0) { + temp = v1[1]; v1[1] = v2[1]; v2[1] = temp + step = -step + } + + np = (npix - 1) * step + 1 + ll_stn = NULL + + # Resample and flip the line list if necessary. Construct a stencil + # list if the step size is greater than 1. + + if (xstep < 0 || step > 1) { + call salloc (px_src, np, TY_INT) + i = pl_l2pi (ll_raw, 1, Memi[px_src], npix) + call aclri (Memi[px_src+i], np - i) + + # Flip data array. + if (xstep < 0) + call imaflp (Memi[px_src], npix, SZ_INT) + + if (step > 1) { + # Resample data array. + ip = px_src + npix - 1 + do i = np, 1, -step { + Memi[px_src+i-1] = Memi[ip] + ip = ip - 1 + } + + # Construct stencil. + call salloc (ll_stn, LL_MAXLEN(pl), TY_SHORT) + call aclri (Memi[px_src], np) + do i = 1, np, step + Memi[px_src+i-1] = 1 + ll_len = pl_p2li (Memi[px_src], 1, Mems[ll_stn], np) + } + + # Convert flipped and resampled data back to line list. + ll_len = pl_p2li (Memi[px_src], 1, Mems[ll_src], np) + + } else { + ll_len = LL_LEN(ll_raw) + call amovs (ll_raw, Mems[ll_src], ll_len) + } + + # Copy to or combine with destination. + if (ll_stn == NULL) + call pl_plls (pl, v1, Mems[ll_src], ll_depth, np, rop) + else { + call salloc (ll_out, LL_MAXLEN(pl), TY_SHORT) + ll_dst = pl_access (pl, v1) + call pl_linestencil (Mems[ll_src], 1, MV(ll_depth), + Mems[ll_dst], v1, PL_MAXVAL(pl), Mems[ll_stn], 1, + Mems[ll_out], np, rop) + call pl_update (pl, v1, Mems[ll_out]) + } + + call sfree (sp) +end diff --git a/sys/pmio/pmplp.gx b/sys/pmio/pmplp.gx new file mode 100644 index 00000000..90246ddc --- /dev/null +++ b/sys/pmio/pmplp.gx @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PM_PLP -- Put a line segment input as a pixel array a mask, applying the +# given ROP to combine the pixels with those of the mask. + +procedure pm_plp$t (pl, v, px_src, px_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +PIXEL px_src[ARB] #I input pixel array +int px_depth #I pixel depth, bits +int npix #I number of pixels affected +int rop #I rasterop + +pointer sp, ll_src +int ll_len, pl_p2l$t() +include "../pmio.com" + +begin + if (PM_MAPXY(pl) == NO) + call pl_plp$t (pl, v, px_src, px_depth, npix, rop) + else { + call smark (sp) + call salloc (ll_src, LL_MAXLEN(pl), TY_SHORT) + + ll_len = pl_p2l$t (px_src, 1, Mems[ll_src], npix) + call pm_plls (pl, v, Mems[ll_src], px_depth, npix, rop) + + call sfree (sp) + } +end diff --git a/sys/pmio/pmplr.gx b/sys/pmio/pmplr.gx new file mode 100644 index 00000000..6f87601b --- /dev/null +++ b/sys/pmio/pmplr.gx @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PM_PLR -- Put a line segment input as a range list to a mask, applying the +# given ROP to combine the pixels with those of the output mask. + +procedure pm_plr$t (pl, v, rl_src, rl_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +PIXEL rl_src[3,ARB] #I input range list +int rl_depth #I range list pixel depth, bits +int npix #I number of pixels affected +int rop #I rasterop + +pointer sp, ll_src +int ll_len, pl_r2l$t() +include "../pmio.com" + +begin + if (PM_MAPXY(pl) == NO) + call pl_plr$t (pl, v, rl_src, rl_depth, npix, rop) + else { + call smark (sp) + call salloc (ll_src, LL_MAXLEN(pl), TY_SHORT) + + ll_len = pl_r2l$t (rl_src, 1, Mems[ll_src], npix) + call pm_plls (pl, v, Mems[ll_src], rl_depth, npix, rop) + + call sfree (sp) + } +end diff --git a/sys/pmio/pmpoint.x b/sys/pmio/pmpoint.x new file mode 100644 index 00000000..c464c47e --- /dev/null +++ b/sys/pmio/pmpoint.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PM_POINT -- Perform a rasterop operation on a single point in a line of a +# 2-dimensional plane of a mask. If the dimensionality of the mask exceeds 2, +# the pm_setplane() procedure should be called first to define the plane of +# the mask to be modified. + +procedure pm_point (pl, x, y, rop) + +pointer pl #I mask descriptor +int x #I pixel to be modified +int y #I line to be modified +int rop #I rasterop defining operation + +errchk pl_getplane +include "pmio.com" + +begin + if (PM_MAPXY(pl) == YES) { + call pl_getplane (pl, v1) + v1[1] = x; v1[2] = y + call imaplv (PM_REFIM(pl), v1, v2, PM_MAXDIM) + + call pl_point (pl, v2[1], v2[2], rop) + + } else + call pl_point (pl, x, y, rop) +end diff --git a/sys/pmio/pmpolygon.x b/sys/pmio/pmpolygon.x new file mode 100644 index 00000000..5e09e5b7 --- /dev/null +++ b/sys/pmio/pmpolygon.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PM_POLYGON -- Perform a rasterop operation on the area enclosed by a polygon +# drawn in a 2-dimensional plane of a mask. If the dimensionality of the mask +# exceeds 2, the pm_setplane() procedure should be called first to define the +# plane of the mask to be modified. + +procedure pm_polygon (pl, x, y, npts, rop) + +pointer pl #I mask descriptor +int x[npts] #I polygon x-vertices +int y[npts] #I polygon y-vertices +int npts #I number of points in polygon +int rop #I rasterop defining operation + +int i +pointer sp, xp, yp +errchk pl_getplane +include "pmio.com" + +begin + if (PM_MAPXY(pl) == YES) { + call smark (sp) + call salloc (xp, npts, TY_INT) + call salloc (yp, npts, TY_INT) + + call pl_getplane (pl, v1) + do i = 1, npts { + v1[1] = x[i]; v1[2] = y[i] + call imaplv (PM_REFIM(pl), v1, v2, PM_MAXDIM) + Memi[xp+i-1] = v2[1]; Memi[yp+i-1] = v2[2] + } + + call pl_polygon (pl, Memi[xp], Memi[yp], npts, rop) + call sfree (sp) + + } else + call pl_polygon (pl, x, y, npts, rop) +end diff --git a/sys/pmio/pmrio.x b/sys/pmio/pmrio.x new file mode 100644 index 00000000..278c7f30 --- /dev/null +++ b/sys/pmio/pmrio.x @@ -0,0 +1,128 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +.help PMRIO +.nf --------------------------------------------------------------------------- +PMRIO -- A small package used to provide a means for efficient random +sampling (at the pixel level) of large PMIO masks. In other words, if we have +a large mask and want to determine the values of successive mask pixels at +random locations in the mask, this package provides a more efficient means +for doing so than calling a routine such as PM_GLPI. The mask must already +exist; means are not provided within this package for creating or editing +masks, only for reading them. + + pmr = pmr_open (pm, plane, buflimit) + pmr_setrect (pmr, x1,y1, x2,y2) + mval = pmr_getpix (pmr, x, y) + pmr_close (pmr) + +PMR_OPEN opens the indicated 2 dimensional plane of the N dimensional mask PM. +Buffer space used to provide an efficient means of randomly sampling the mask +will be kept to within approximately BUFLIMIT integer units of storage (the +internal table used to sample the mask is type integer, so BUFLIMIT is the +approximate number of entries in the table). Random sampling of the mask is +provided by the integer function PMR_GETPIX, which returns the mask value at +the point [i,j] within the specified plane. PMR_SETRECT may be called before +calling PMR_GETPIX to set the clipping rectangle, which defaults to the +boundaries of the mask. If a PMR_GETPIX call references outside the clipping +region, ERR will be returned as the mask value (normal mask values are >= 0). +Use of a clipping region other than the boundaries of the full mask can avoid +the need for redundant clipping operations in the client. PMR_CLOSE should +be called to free the PMRIO table space (which can be extensive) when no longer +needed. + +This package is a front end to the PLRIO package in PLIO, which does all the +real work. +.endhelp ---------------------------------------------------------------------- + +# The following definitions must agree with those in plio$plrio.x. +define PMR_PL Memi[$1] # backpointer to PLIO descriptor +define PMR_PLANE Memi[$1+10+($2)-1] # defines 2D plane in ND mask + + +# PMR_OPEN -- Open a PMIO mask for random pixel access. Provides efficient +# random pixel level access to any size mask. This is a 2-dimensional +# operator, but can be used to sample any 2-dim plane of an N-dim mask. + +pointer procedure pmr_open (pl, plane, buflimit) + +pointer pl #I PMIO/PLIO descriptor +int plane[ARB] #I 2-dim plane to be accessed +int buflimit #I approximate table size, or 0 if don't care + +pointer plr_open() +include "pmio.com" + +begin + if (PM_MAPXY(pl) == YES) { + call imaplv (PM_REFIM(pl), plane, v1, PM_MAXDIM) + return (plr_open (pl, v1, buflimit)) + } else + return (plr_open (pl, plane, buflimit)) +end + + +# PMR_GETPIX -- Return the value of the given mask pixel, identified by the +# 2-dim coordinates of the pixel relative to the plane of the N-dim mask +# specified at open time. + +int procedure pmr_getpix (pmr, i, j) + +pointer pmr #I PMR descriptor +int i, j #I plane-relative coordinates of pixel + +pointer pl +int plr_getpix() +include "pmio.com" + +begin + pl = PMR_PL(pmr) + if (PM_MAPXY(pl) == YES) { + PMR_PLANE(pmr,1) = i + PMR_PLANE(pmr,2) = j + call imaplv (PM_REFIM(pl), PMR_PLANE(pmr,1), v1, PM_MAXDIM) + return (plr_getpix (pmr, v1[1], v1[2])) + } else + return (plr_getpix (pmr, i, j)) +end + + +# PMR_SETRECT -- Set the clipping region for PMR_GETPIX. + +procedure pmr_setrect (pmr, x1,y1, x2,y2) + +pointer pmr #I PMR descriptor +int x1,y1 #I lower left corner of region +int x2,y2 #I upper right corner of region + +pointer pl +include "pmio.com" + +begin + pl = PMR_PL(pmr) + if (PM_MAPXY(pl) == YES) { + call amovi (PMR_PLANE(pmr,1), v1, PM_MAXDIM) + v1[1] = x1; v1[2] = y1 + call imaplv (PM_REFIM(pl), v1, v2, PM_MAXDIM) + + call amovi (PMR_PLANE(pmr,1), v3, PM_MAXDIM) + v3[1] = x2; v3[2] = y2 + call imaplv (PM_REFIM(pl), v3, v4, PM_MAXDIM) + + call plr_setrect (pmr, v2[1],v2[2], v4[1],v4[2]) + } else + call plr_setrect (pmr, x1,y1, x2,y2) +end + + +# PMR_CLOSE -- Free a PMRIO descriptor. + +procedure pmr_close (pmr) + +pointer pmr #I PMR descriptor + +begin + call plr_close (pmr) +end diff --git a/sys/pmio/pmrop.x b/sys/pmio/pmrop.x new file mode 100644 index 00000000..ddd77d37 --- /dev/null +++ b/sys/pmio/pmrop.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# PM_ROP -- Perform a rasterop operation from the source mask to the +# destination mask at the given offsets. The source and destination need +# not be the same size or dimensionality, but out of bounds references are +# not permitted. If the source is of lesser dimensionality than the +# indicated section of the destination, then the source will be rewound +# and reread as necessary to operate upon the entire destination subregion, +# e.g., a line source mask may be applied to successive lines of a plane, +# or a plane mask may be applied to successive planes of a 3D mask. +# The source and destination masks may be the same if desired, but if the +# source and destination regions overlap feedback may occur (this could be +# fixed). With some rasterops, e.g, PIX_SET or PIX_CLR, no source mask is +# required, and pm_src=NULL is permitted. + +procedure pm_rop (pm_src, vs_src, pm_dst, vs_dst, vn, rop) + +pointer pm_src #I source mask or NULL +long vs_src[PM_MAXDIM] #I start vector in source mask +pointer pm_dst #I destination mask (required) +long vs_dst[PM_MAXDIM] #I start vector in destination mask +long vn[PM_MAXDIM] #I vector giving subregion size +long rop #I rasterop + +int i +include "pmio.com" + +begin + # If an image section is used on either the source or destination + # mask, map the input vectors into the physical image space and + # perform the rasterop operation there. + + if (PM_MAPXY(pm_src) == YES || PM_MAPXY(pm_dst) == YES) { + # Compute V1, the start vector in the source mask. + call imaplv (PM_REFIM(pm_src), vs_src, v1, PM_MAXDIM) + + # Compute V3, the end vector in the source mask. + call aaddl (vs_src, vn, v2, PM_MAXDIM) + call asubkl (v2, 1, v2, PL_MAXDIM) + call aminl (v2, IM_LEN(PM_REFIM(pm_src),1), v2, PM_MAXDIM) + call imaplv (PM_REFIM(pm_src), v2, v3, PM_MAXDIM) + + # Swap V1 and V3 if necessary. + call aminl (v1, v3, v1, PM_MAXDIM) + + # Compute V2, the start vector in the destination mask. + call imaplv (PM_REFIM(pm_dst), vs_dst, v2, PM_MAXDIM) + + # Compute V4, the end vector in the destination mask. + call aaddl (vs_dst, vn, v3, PM_MAXDIM) + call asubkl (v3, 1, v3, PL_MAXDIM) + call aminl (v3, IM_LEN(PM_REFIM(pm_dst),1), v3, PM_MAXDIM) + call imaplv (PM_REFIM(pm_dst), v3, v4, PM_MAXDIM) + + # Compute v3 = vn for rasterop. Input: SRC=v1:v3, DST=v2:v4 + # This also swaps v2 and v4 if necessary. + + do i = 1, PM_MAXDIM + if (v2[i] > v4[i]) { + v3[i] = v2[i] - v4[i] + 1 + v2[i] = v4[i] + } else + v3[i] = v4[i] - v2[i] + 1 + + # Perform the rasterop. + call pl_rop (pm_src, v1, pm_dst, v2, v3, rop) + + } else + call pl_rop (pm_src, vs_src, pm_dst, vs_dst, vn, rop) +end diff --git a/sys/pmio/pmsectnc.x b/sys/pmio/pmsectnc.x new file mode 100644 index 00000000..ce424c3e --- /dev/null +++ b/sys/pmio/pmsectnc.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PM_SECTNOTCONST -- Test whether the indicated mask image section is constant, +# i.e., all the mask pixels therein are set to the same value. If so, return +# the mask value as an output argument. + +bool procedure pm_sectnotconst (pl, vs, ve, ndim, mval) + +pointer pl #I mask descriptor +long vs[PM_MAXDIM] #I starting coordinates of section +long ve[PM_MAXDIM] #I ending coordinates of section +int ndim #I dimension of section +int mval #O mask value + +bool pl_sectnotconst() +include "pmio.com" + +begin + if (PM_MAPXY(pl) == YES) { + call amovkl ( 1, v1, PM_MAXDIM) + call amovl (vs, v1, ndim) + call imaplv (PM_REFIM(pl), v1, v2, PM_MAXDIM) + + call amovkl ( 1, v3, PM_MAXDIM) + call amovl (ve, v3, ndim) + call imaplv (PM_REFIM(pl), v3, v4, PM_MAXDIM) + + return (pl_sectnotconst (pl, v2, v4, PM_MAXDIM, mval)) + + } else + return (pl_sectnotconst (pl, vs, ve, ndim, mval)) +end diff --git a/sys/pmio/pmsectne.x b/sys/pmio/pmsectne.x new file mode 100644 index 00000000..654c53b1 --- /dev/null +++ b/sys/pmio/pmsectne.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PM_SECTNOTEMPTY -- Test whether the indicated mask image section is empty. + +bool procedure pm_sectnotempty (pl, vs, ve, ndim) + +pointer pl #I mask descriptor +long vs[PM_MAXDIM] #I starting coordinates of section +long ve[PM_MAXDIM] #I ending coordinates of section +int ndim + +bool pl_sectnotempty() +include "pmio.com" + +begin + if (PM_MAPXY(pl) == YES) { + call amovkl ( 1, v1, PM_MAXDIM) + call amovl (vs, v1, ndim) + call imaplv (PM_REFIM(pl), v1, v2, PM_MAXDIM) + + call amovkl ( 1, v3, PM_MAXDIM) + call amovl (ve, v3, ndim) + call imaplv (PM_REFIM(pl), v3, v4, PM_MAXDIM) + + return (pl_sectnotempty (pl, v2, v4, PM_MAXDIM)) + + } else + return (pl_sectnotempty (pl, vs, ve, ndim)) +end diff --git a/sys/pmio/pmseti.x b/sys/pmio/pmseti.x new file mode 100644 index 00000000..ef1fd99e --- /dev/null +++ b/sys/pmio/pmseti.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# PM_SETI -- Set a PMIO or PLIO parameter. + +procedure pm_seti (pl, param, value) + +pointer pl #I mask descriptor +int param #I parameter code +int value #I parameter value + +begin + switch (param) { + case P_REFIM: + PM_REFIM(pl) = value + PM_MAPXY(pl) = IM_SECTUSED(value) + case P_MAPXY: + PM_MAPXY(pl) = value + case P_MAXLINE: + PL_MAXLINE(pl) = value + case P_DEPTH: + PL_MAXVAL(pl) = MV(value) + default: + call syserr (SYS_PLINVPAR) + } +end diff --git a/sys/pmio/pmsplane.x b/sys/pmio/pmsplane.x new file mode 100644 index 00000000..4fcad1fd --- /dev/null +++ b/sys/pmio/pmsplane.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PM_SETPLANE -- Set the 2-Dim plane to be referenced in calls to the pm_box, +# pm_circle, etc. geometric region masking operators. + +procedure pm_setplane (pl, v) + +pointer pl #I mask descriptor +long v[ARB] #I vector defining plane + +include "pmio.com" + +begin + if (PM_MAPXY(pl) == YES) { + call imaplv (PM_REFIM(pl), v, v1, PM_MAXDIM) + call pl_setplane (pl, v1) + } else + call pl_setplane (pl, v) +end diff --git a/sys/pmio/pmstati.x b/sys/pmio/pmstati.x new file mode 100644 index 00000000..4e8566d2 --- /dev/null +++ b/sys/pmio/pmstati.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# PM_STATI -- Stat a PMIO or PLIO parameter. + +int procedure pm_stati (pl, param) + +pointer pl #I mask descriptor +int param #I parameter code + +int i + +begin + switch (param) { + case P_REFIM: + return (PM_REFIM(pl)) + case P_MAPXY: + return (PM_MAPXY(pl)) + case P_MAXLINE: + return (PL_MAXLINE(pl)) + case P_DEPTH: + do i = 0, ARB + if (2**i > min (I_PVMAX, PL_MAXVAL(pl))) + return (i) + default: + call syserr (SYS_PLINVPAR) + } +end diff --git a/sys/pmio/pmsten.x b/sys/pmio/pmsten.x new file mode 100644 index 00000000..09a34a52 --- /dev/null +++ b/sys/pmio/pmsten.x @@ -0,0 +1,77 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# PM_STENCIL -- Perform a rasterop operation from the source mask to the +# destination mask at the given offsets, but only within the regions set to +# one in the stencil mask. + +procedure pm_stencil (pm_src, vs_src, pm_dst, vs_dst, pm_stn, vs_stn, vn, rop) + +pointer pm_src #I source mask or NULL +long vs_src[PM_MAXDIM] #I start vector in source mask +pointer pm_dst #I destination mask (required) +long vs_dst[PM_MAXDIM] #I start vector in destination mask +pointer pm_stn #I stencil mask (required) +long vs_stn[PM_MAXDIM] #I start vector in stencil mask +long vn[PM_MAXDIM] #I vector giving subregion size +long rop #I rasterop + +int i +long v5[PM_MAXDIM], v6[PM_MAXDIM] +include "pmio.com" + +begin + # If an image section is in use on any of the input mask operands, + # perform a coordination transformation into physical mask space + # before performing the stencil operation. + + if (PM_MAPXY(pm_src) == YES || PM_MAPXY(pm_dst) == YES || + PM_MAPXY(pm_stn) == YES) { + + # Compute the geometry V1:V3 of the source mask. + call imaplv (PM_REFIM(pm_src), vs_src, v1, PM_MAXDIM) + + call aaddl (vs_src, vn, v2, PM_MAXDIM) + call asubkl (v2, 1, v2, PM_MAXDIM) + call aminl (v2, IM_LEN(PM_REFIM(pm_src),1), v2, PM_MAXDIM) + call imaplv (PM_REFIM(pm_src), v2, v3, PM_MAXDIM) + + # Swap V1 and V3 if necessary. + call aminl (v1, v3, v1, PM_MAXDIM) + + # Compute the geometry V2:V4 of the destination mask. + call imaplv (PM_REFIM(pm_dst), vs_dst, v2, PM_MAXDIM) + + call aaddl (vs_dst, vn, v3, PM_MAXDIM) + call asubkl (v3, 1, v3, PM_MAXDIM) + call aminl (v3, IM_LEN(PM_REFIM(pm_dst),1), v3, PM_MAXDIM) + call imaplv (PM_REFIM(pm_dst), v3, v4, PM_MAXDIM) + + # Compute v3 = vn for rasterop. Input: SRC=v1:v3, DST=v2:v4 + # This also swaps v2 and v4 if necessary. + + do i = 1, PM_MAXDIM + if (v2[i] > v4[i]) { + v3[i] = v2[i] - v4[i] + 1 + v2[i] = v4[i] + } else + v3[i] = v4[i] - v2[i] + 1 + + # Compute the start vector V4 of the stencil mask. + call imaplv (PM_REFIM(pm_stn), vs_stn, v4, PM_MAXDIM) + call aaddl (vs_stn, vn, v5, PM_MAXDIM) + call asubkl (v5, 1, v5, PM_MAXDIM) + call aminl (v5, IM_LEN(PM_REFIM(pm_stn),1), v5, PM_MAXDIM) + call imaplv (PM_REFIM(pm_stn), v5, v6, PM_MAXDIM) + call aminl (v4, v6, v4, PM_MAXDIM) + + # Perform the rasterop operation. + call pl_stencil (pm_src, v1, pm_dst, v2, pm_stn, v4, v3, rop) + + } else + call pl_stencil (pm_src, vs_src, pm_dst, vs_dst, + pm_stn, vs_stn, vn, rop) +end diff --git a/sys/pmio/tf/miogld.x b/sys/pmio/tf/miogld.x new file mode 100644 index 00000000..7c3dc743 --- /dev/null +++ b/sys/pmio/tf/miogld.x @@ -0,0 +1,103 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "../mio.h" + +# MIO_GLSEG -- Get a line segment from a masked image. A line segment is a +# region of the data image for which the corresponding region of the mask has +# the constant nonzero value MVAL. Line segments are returned for each line in +# the region VS to VE, returning the number of pixels in each line segment as +# the function value, or EOF when the region is exhausted. Once EOF is +# reached, repeated calls will continue to return EOF until the next call to +# MIO_SETRANGE. Repeated calls to MIO_SETRANGE may be used to access a series +# of distinct regions in the image. If a subregion of the image is being +# accessed with MIO_SETRANGE, the vector coordinates V returned below will +# be relative to the defined subregion (if this is not what is desired, +# the range should be set to the full image and a region mask used to mask +# off the subregion to be accessed). + +int procedure mio_glsegd (mp, ptr, mval, v, npix) + +pointer mp #I MIO descriptor +pointer ptr #O pointer to a buffer containing the data +int mval #O mask value for the output line segment +long v[IM_MAXDIM] #U coords of first pixel in output ine segment +int npix #O number of pixels in output line segment + +int x1, i +long ve[IM_MAXDIM] +pointer pm, im, rl, rp, bp +pointer imgl2d(), imgl3d(), imggsd() +errchk imgl2d, imgl3d, imggsd, pm_glri +bool pm_sectnotempty() +int plloop() + +begin + pm = M_PM(mp) + rl = M_RLP(mp) + + # Initialization performed for the first i/o on a new region. + if (M_ACTIVE(mp) == NO) { + call plsslv (pm, M_VS(mp,1), M_VN(mp,1), M_V(mp,1), M_VE(mp,1)) + call pm_glri (pm, + M_V(mp,1), Memi[rl], M_DEPTH(mp), M_VN(mp,1), PIX_SRC) + M_RLI(mp) = RL_FIRST + M_ACTIVE(mp) = YES + } + + # Get a new mask line? + while (M_RLI(mp) > RLI_LEN(rl)) + if (plloop (M_V(mp,1), M_VS(mp,1), M_VE(mp,1), + M_NDIM(mp)) == LOOP_DONE) { + return (EOF) + } else { + call amovl (M_V(mp,1), ve, M_NDIM(mp)) + ve[1] = M_VE(mp,1) + if (pm_sectnotempty (pm, M_V(mp,1), ve, M_NDIM(mp))) { + call pm_glri (pm, + M_V(mp,1), Memi[rl], M_DEPTH(mp), M_VN(mp,1), PIX_SRC) + M_RLI(mp) = RL_FIRST + } + } + + # Get a new image line? + if (M_RLI(mp) == RL_FIRST) { + call amovl (M_V(mp,1), v, M_NDIM(mp)) + im = M_IM(mp) + + if (M_LINEIO(mp) == YES && M_NDIM(mp) == 2) + bp = imgl2d (im, v[2]) + else if (M_LINEIO(mp) == YES && M_NDIM(mp) == 3) + bp = imgl3d (im, v[2], v[3]) + else { + call amovl (v, ve, M_NDIM(mp)); ve[1] = M_VE(mp,1) + bp = imggsd (im, v, ve, M_NDIM(mp)) + } + + M_LBP(mp) = bp + } else + bp = M_LBP(mp) + + # Return the next line segment. + rp = rl + (M_RLI(mp) - 1) * RL_LENELEM + M_RLI(mp) = M_RLI(mp) + 1 + + x1 = Memi[rp+RL_XOFF] + npix = Memi[rp+RL_NOFF] + mval = Memi[rp+RL_VOFF] + ptr = bp + x1 - M_VS(mp,1) + + if (M_REGCOORDS(mp) == NO) { + v[1] = x1 + do i = 2, M_NDIM(mp) + v[i] = M_V(mp,i) + } else { + v[1] = x1 - M_VS(mp,1) + 1 + do i = 2, M_NDIM(mp) + v[i] = M_V(mp,i) - M_VS(mp,i) + 1 + } + + return (npix) +end diff --git a/sys/pmio/tf/miogli.x b/sys/pmio/tf/miogli.x new file mode 100644 index 00000000..726f46f1 --- /dev/null +++ b/sys/pmio/tf/miogli.x @@ -0,0 +1,103 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "../mio.h" + +# MIO_GLSEG -- Get a line segment from a masked image. A line segment is a +# region of the data image for which the corresponding region of the mask has +# the constant nonzero value MVAL. Line segments are returned for each line in +# the region VS to VE, returning the number of pixels in each line segment as +# the function value, or EOF when the region is exhausted. Once EOF is +# reached, repeated calls will continue to return EOF until the next call to +# MIO_SETRANGE. Repeated calls to MIO_SETRANGE may be used to access a series +# of distinct regions in the image. If a subregion of the image is being +# accessed with MIO_SETRANGE, the vector coordinates V returned below will +# be relative to the defined subregion (if this is not what is desired, +# the range should be set to the full image and a region mask used to mask +# off the subregion to be accessed). + +int procedure mio_glsegi (mp, ptr, mval, v, npix) + +pointer mp #I MIO descriptor +pointer ptr #O pointer to a buffer containing the data +int mval #O mask value for the output line segment +long v[IM_MAXDIM] #U coords of first pixel in output ine segment +int npix #O number of pixels in output line segment + +int x1, i +long ve[IM_MAXDIM] +pointer pm, im, rl, rp, bp +pointer imgl2i(), imgl3i(), imggsi() +errchk imgl2i, imgl3i, imggsi, pm_glri +bool pm_sectnotempty() +int plloop() + +begin + pm = M_PM(mp) + rl = M_RLP(mp) + + # Initialization performed for the first i/o on a new region. + if (M_ACTIVE(mp) == NO) { + call plsslv (pm, M_VS(mp,1), M_VN(mp,1), M_V(mp,1), M_VE(mp,1)) + call pm_glri (pm, + M_V(mp,1), Memi[rl], M_DEPTH(mp), M_VN(mp,1), PIX_SRC) + M_RLI(mp) = RL_FIRST + M_ACTIVE(mp) = YES + } + + # Get a new mask line? + while (M_RLI(mp) > RLI_LEN(rl)) + if (plloop (M_V(mp,1), M_VS(mp,1), M_VE(mp,1), + M_NDIM(mp)) == LOOP_DONE) { + return (EOF) + } else { + call amovl (M_V(mp,1), ve, M_NDIM(mp)) + ve[1] = M_VE(mp,1) + if (pm_sectnotempty (pm, M_V(mp,1), ve, M_NDIM(mp))) { + call pm_glri (pm, + M_V(mp,1), Memi[rl], M_DEPTH(mp), M_VN(mp,1), PIX_SRC) + M_RLI(mp) = RL_FIRST + } + } + + # Get a new image line? + if (M_RLI(mp) == RL_FIRST) { + call amovl (M_V(mp,1), v, M_NDIM(mp)) + im = M_IM(mp) + + if (M_LINEIO(mp) == YES && M_NDIM(mp) == 2) + bp = imgl2i (im, v[2]) + else if (M_LINEIO(mp) == YES && M_NDIM(mp) == 3) + bp = imgl3i (im, v[2], v[3]) + else { + call amovl (v, ve, M_NDIM(mp)); ve[1] = M_VE(mp,1) + bp = imggsi (im, v, ve, M_NDIM(mp)) + } + + M_LBP(mp) = bp + } else + bp = M_LBP(mp) + + # Return the next line segment. + rp = rl + (M_RLI(mp) - 1) * RL_LENELEM + M_RLI(mp) = M_RLI(mp) + 1 + + x1 = Memi[rp+RL_XOFF] + npix = Memi[rp+RL_NOFF] + mval = Memi[rp+RL_VOFF] + ptr = bp + x1 - M_VS(mp,1) + + if (M_REGCOORDS(mp) == NO) { + v[1] = x1 + do i = 2, M_NDIM(mp) + v[i] = M_V(mp,i) + } else { + v[1] = x1 - M_VS(mp,1) + 1 + do i = 2, M_NDIM(mp) + v[i] = M_V(mp,i) - M_VS(mp,i) + 1 + } + + return (npix) +end diff --git a/sys/pmio/tf/miogll.x b/sys/pmio/tf/miogll.x new file mode 100644 index 00000000..6566ae01 --- /dev/null +++ b/sys/pmio/tf/miogll.x @@ -0,0 +1,103 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "../mio.h" + +# MIO_GLSEG -- Get a line segment from a masked image. A line segment is a +# region of the data image for which the corresponding region of the mask has +# the constant nonzero value MVAL. Line segments are returned for each line in +# the region VS to VE, returning the number of pixels in each line segment as +# the function value, or EOF when the region is exhausted. Once EOF is +# reached, repeated calls will continue to return EOF until the next call to +# MIO_SETRANGE. Repeated calls to MIO_SETRANGE may be used to access a series +# of distinct regions in the image. If a subregion of the image is being +# accessed with MIO_SETRANGE, the vector coordinates V returned below will +# be relative to the defined subregion (if this is not what is desired, +# the range should be set to the full image and a region mask used to mask +# off the subregion to be accessed). + +int procedure mio_glsegl (mp, ptr, mval, v, npix) + +pointer mp #I MIO descriptor +pointer ptr #O pointer to a buffer containing the data +int mval #O mask value for the output line segment +long v[IM_MAXDIM] #U coords of first pixel in output ine segment +int npix #O number of pixels in output line segment + +int x1, i +long ve[IM_MAXDIM] +pointer pm, im, rl, rp, bp +pointer imgl2l(), imgl3l(), imggsl() +errchk imgl2l, imgl3l, imggsl, pm_glri +bool pm_sectnotempty() +int plloop() + +begin + pm = M_PM(mp) + rl = M_RLP(mp) + + # Initialization performed for the first i/o on a new region. + if (M_ACTIVE(mp) == NO) { + call plsslv (pm, M_VS(mp,1), M_VN(mp,1), M_V(mp,1), M_VE(mp,1)) + call pm_glri (pm, + M_V(mp,1), Memi[rl], M_DEPTH(mp), M_VN(mp,1), PIX_SRC) + M_RLI(mp) = RL_FIRST + M_ACTIVE(mp) = YES + } + + # Get a new mask line? + while (M_RLI(mp) > RLI_LEN(rl)) + if (plloop (M_V(mp,1), M_VS(mp,1), M_VE(mp,1), + M_NDIM(mp)) == LOOP_DONE) { + return (EOF) + } else { + call amovl (M_V(mp,1), ve, M_NDIM(mp)) + ve[1] = M_VE(mp,1) + if (pm_sectnotempty (pm, M_V(mp,1), ve, M_NDIM(mp))) { + call pm_glri (pm, + M_V(mp,1), Memi[rl], M_DEPTH(mp), M_VN(mp,1), PIX_SRC) + M_RLI(mp) = RL_FIRST + } + } + + # Get a new image line? + if (M_RLI(mp) == RL_FIRST) { + call amovl (M_V(mp,1), v, M_NDIM(mp)) + im = M_IM(mp) + + if (M_LINEIO(mp) == YES && M_NDIM(mp) == 2) + bp = imgl2l (im, v[2]) + else if (M_LINEIO(mp) == YES && M_NDIM(mp) == 3) + bp = imgl3l (im, v[2], v[3]) + else { + call amovl (v, ve, M_NDIM(mp)); ve[1] = M_VE(mp,1) + bp = imggsl (im, v, ve, M_NDIM(mp)) + } + + M_LBP(mp) = bp + } else + bp = M_LBP(mp) + + # Return the next line segment. + rp = rl + (M_RLI(mp) - 1) * RL_LENELEM + M_RLI(mp) = M_RLI(mp) + 1 + + x1 = Memi[rp+RL_XOFF] + npix = Memi[rp+RL_NOFF] + mval = Memi[rp+RL_VOFF] + ptr = bp + x1 - M_VS(mp,1) + + if (M_REGCOORDS(mp) == NO) { + v[1] = x1 + do i = 2, M_NDIM(mp) + v[i] = M_V(mp,i) + } else { + v[1] = x1 - M_VS(mp,1) + 1 + do i = 2, M_NDIM(mp) + v[i] = M_V(mp,i) - M_VS(mp,i) + 1 + } + + return (npix) +end diff --git a/sys/pmio/tf/mioglr.x b/sys/pmio/tf/mioglr.x new file mode 100644 index 00000000..d0fa8de0 --- /dev/null +++ b/sys/pmio/tf/mioglr.x @@ -0,0 +1,103 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "../mio.h" + +# MIO_GLSEG -- Get a line segment from a masked image. A line segment is a +# region of the data image for which the corresponding region of the mask has +# the constant nonzero value MVAL. Line segments are returned for each line in +# the region VS to VE, returning the number of pixels in each line segment as +# the function value, or EOF when the region is exhausted. Once EOF is +# reached, repeated calls will continue to return EOF until the next call to +# MIO_SETRANGE. Repeated calls to MIO_SETRANGE may be used to access a series +# of distinct regions in the image. If a subregion of the image is being +# accessed with MIO_SETRANGE, the vector coordinates V returned below will +# be relative to the defined subregion (if this is not what is desired, +# the range should be set to the full image and a region mask used to mask +# off the subregion to be accessed). + +int procedure mio_glsegr (mp, ptr, mval, v, npix) + +pointer mp #I MIO descriptor +pointer ptr #O pointer to a buffer containing the data +int mval #O mask value for the output line segment +long v[IM_MAXDIM] #U coords of first pixel in output ine segment +int npix #O number of pixels in output line segment + +int x1, i +long ve[IM_MAXDIM] +pointer pm, im, rl, rp, bp +pointer imgl2r(), imgl3r(), imggsr() +errchk imgl2r, imgl3r, imggsr, pm_glri +bool pm_sectnotempty() +int plloop() + +begin + pm = M_PM(mp) + rl = M_RLP(mp) + + # Initialization performed for the first i/o on a new region. + if (M_ACTIVE(mp) == NO) { + call plsslv (pm, M_VS(mp,1), M_VN(mp,1), M_V(mp,1), M_VE(mp,1)) + call pm_glri (pm, + M_V(mp,1), Memi[rl], M_DEPTH(mp), M_VN(mp,1), PIX_SRC) + M_RLI(mp) = RL_FIRST + M_ACTIVE(mp) = YES + } + + # Get a new mask line? + while (M_RLI(mp) > RLI_LEN(rl)) + if (plloop (M_V(mp,1), M_VS(mp,1), M_VE(mp,1), + M_NDIM(mp)) == LOOP_DONE) { + return (EOF) + } else { + call amovl (M_V(mp,1), ve, M_NDIM(mp)) + ve[1] = M_VE(mp,1) + if (pm_sectnotempty (pm, M_V(mp,1), ve, M_NDIM(mp))) { + call pm_glri (pm, + M_V(mp,1), Memi[rl], M_DEPTH(mp), M_VN(mp,1), PIX_SRC) + M_RLI(mp) = RL_FIRST + } + } + + # Get a new image line? + if (M_RLI(mp) == RL_FIRST) { + call amovl (M_V(mp,1), v, M_NDIM(mp)) + im = M_IM(mp) + + if (M_LINEIO(mp) == YES && M_NDIM(mp) == 2) + bp = imgl2r (im, v[2]) + else if (M_LINEIO(mp) == YES && M_NDIM(mp) == 3) + bp = imgl3r (im, v[2], v[3]) + else { + call amovl (v, ve, M_NDIM(mp)); ve[1] = M_VE(mp,1) + bp = imggsr (im, v, ve, M_NDIM(mp)) + } + + M_LBP(mp) = bp + } else + bp = M_LBP(mp) + + # Return the next line segment. + rp = rl + (M_RLI(mp) - 1) * RL_LENELEM + M_RLI(mp) = M_RLI(mp) + 1 + + x1 = Memi[rp+RL_XOFF] + npix = Memi[rp+RL_NOFF] + mval = Memi[rp+RL_VOFF] + ptr = bp + x1 - M_VS(mp,1) + + if (M_REGCOORDS(mp) == NO) { + v[1] = x1 + do i = 2, M_NDIM(mp) + v[i] = M_V(mp,i) + } else { + v[1] = x1 - M_VS(mp,1) + 1 + do i = 2, M_NDIM(mp) + v[i] = M_V(mp,i) - M_VS(mp,i) + 1 + } + + return (npix) +end diff --git a/sys/pmio/tf/miogls.x b/sys/pmio/tf/miogls.x new file mode 100644 index 00000000..4973da4f --- /dev/null +++ b/sys/pmio/tf/miogls.x @@ -0,0 +1,103 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "../mio.h" + +# MIO_GLSEG -- Get a line segment from a masked image. A line segment is a +# region of the data image for which the corresponding region of the mask has +# the constant nonzero value MVAL. Line segments are returned for each line in +# the region VS to VE, returning the number of pixels in each line segment as +# the function value, or EOF when the region is exhausted. Once EOF is +# reached, repeated calls will continue to return EOF until the next call to +# MIO_SETRANGE. Repeated calls to MIO_SETRANGE may be used to access a series +# of distinct regions in the image. If a subregion of the image is being +# accessed with MIO_SETRANGE, the vector coordinates V returned below will +# be relative to the defined subregion (if this is not what is desired, +# the range should be set to the full image and a region mask used to mask +# off the subregion to be accessed). + +int procedure mio_glsegs (mp, ptr, mval, v, npix) + +pointer mp #I MIO descriptor +pointer ptr #O pointer to a buffer containing the data +int mval #O mask value for the output line segment +long v[IM_MAXDIM] #U coords of first pixel in output ine segment +int npix #O number of pixels in output line segment + +int x1, i +long ve[IM_MAXDIM] +pointer pm, im, rl, rp, bp +pointer imgl2s(), imgl3s(), imggss() +errchk imgl2s, imgl3s, imggss, pm_glri +bool pm_sectnotempty() +int plloop() + +begin + pm = M_PM(mp) + rl = M_RLP(mp) + + # Initialization performed for the first i/o on a new region. + if (M_ACTIVE(mp) == NO) { + call plsslv (pm, M_VS(mp,1), M_VN(mp,1), M_V(mp,1), M_VE(mp,1)) + call pm_glri (pm, + M_V(mp,1), Memi[rl], M_DEPTH(mp), M_VN(mp,1), PIX_SRC) + M_RLI(mp) = RL_FIRST + M_ACTIVE(mp) = YES + } + + # Get a new mask line? + while (M_RLI(mp) > RLI_LEN(rl)) + if (plloop (M_V(mp,1), M_VS(mp,1), M_VE(mp,1), + M_NDIM(mp)) == LOOP_DONE) { + return (EOF) + } else { + call amovl (M_V(mp,1), ve, M_NDIM(mp)) + ve[1] = M_VE(mp,1) + if (pm_sectnotempty (pm, M_V(mp,1), ve, M_NDIM(mp))) { + call pm_glri (pm, + M_V(mp,1), Memi[rl], M_DEPTH(mp), M_VN(mp,1), PIX_SRC) + M_RLI(mp) = RL_FIRST + } + } + + # Get a new image line? + if (M_RLI(mp) == RL_FIRST) { + call amovl (M_V(mp,1), v, M_NDIM(mp)) + im = M_IM(mp) + + if (M_LINEIO(mp) == YES && M_NDIM(mp) == 2) + bp = imgl2s (im, v[2]) + else if (M_LINEIO(mp) == YES && M_NDIM(mp) == 3) + bp = imgl3s (im, v[2], v[3]) + else { + call amovl (v, ve, M_NDIM(mp)); ve[1] = M_VE(mp,1) + bp = imggss (im, v, ve, M_NDIM(mp)) + } + + M_LBP(mp) = bp + } else + bp = M_LBP(mp) + + # Return the next line segment. + rp = rl + (M_RLI(mp) - 1) * RL_LENELEM + M_RLI(mp) = M_RLI(mp) + 1 + + x1 = Memi[rp+RL_XOFF] + npix = Memi[rp+RL_NOFF] + mval = Memi[rp+RL_VOFF] + ptr = bp + x1 - M_VS(mp,1) + + if (M_REGCOORDS(mp) == NO) { + v[1] = x1 + do i = 2, M_NDIM(mp) + v[i] = M_V(mp,i) + } else { + v[1] = x1 - M_VS(mp,1) + 1 + do i = 2, M_NDIM(mp) + v[i] = M_V(mp,i) - M_VS(mp,i) + 1 + } + + return (npix) +end diff --git a/sys/pmio/tf/mioglx.x b/sys/pmio/tf/mioglx.x new file mode 100644 index 00000000..44f866a2 --- /dev/null +++ b/sys/pmio/tf/mioglx.x @@ -0,0 +1,103 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "../mio.h" + +# MIO_GLSEG -- Get a line segment from a masked image. A line segment is a +# region of the data image for which the corresponding region of the mask has +# the constant nonzero value MVAL. Line segments are returned for each line in +# the region VS to VE, returning the number of pixels in each line segment as +# the function value, or EOF when the region is exhausted. Once EOF is +# reached, repeated calls will continue to return EOF until the next call to +# MIO_SETRANGE. Repeated calls to MIO_SETRANGE may be used to access a series +# of distinct regions in the image. If a subregion of the image is being +# accessed with MIO_SETRANGE, the vector coordinates V returned below will +# be relative to the defined subregion (if this is not what is desired, +# the range should be set to the full image and a region mask used to mask +# off the subregion to be accessed). + +int procedure mio_glsegx (mp, ptr, mval, v, npix) + +pointer mp #I MIO descriptor +pointer ptr #O pointer to a buffer containing the data +int mval #O mask value for the output line segment +long v[IM_MAXDIM] #U coords of first pixel in output ine segment +int npix #O number of pixels in output line segment + +int x1, i +long ve[IM_MAXDIM] +pointer pm, im, rl, rp, bp +pointer imgl2x(), imgl3x(), imggsx() +errchk imgl2x, imgl3x, imggsx, pm_glri +bool pm_sectnotempty() +int plloop() + +begin + pm = M_PM(mp) + rl = M_RLP(mp) + + # Initialization performed for the first i/o on a new region. + if (M_ACTIVE(mp) == NO) { + call plsslv (pm, M_VS(mp,1), M_VN(mp,1), M_V(mp,1), M_VE(mp,1)) + call pm_glri (pm, + M_V(mp,1), Memi[rl], M_DEPTH(mp), M_VN(mp,1), PIX_SRC) + M_RLI(mp) = RL_FIRST + M_ACTIVE(mp) = YES + } + + # Get a new mask line? + while (M_RLI(mp) > RLI_LEN(rl)) + if (plloop (M_V(mp,1), M_VS(mp,1), M_VE(mp,1), + M_NDIM(mp)) == LOOP_DONE) { + return (EOF) + } else { + call amovl (M_V(mp,1), ve, M_NDIM(mp)) + ve[1] = M_VE(mp,1) + if (pm_sectnotempty (pm, M_V(mp,1), ve, M_NDIM(mp))) { + call pm_glri (pm, + M_V(mp,1), Memi[rl], M_DEPTH(mp), M_VN(mp,1), PIX_SRC) + M_RLI(mp) = RL_FIRST + } + } + + # Get a new image line? + if (M_RLI(mp) == RL_FIRST) { + call amovl (M_V(mp,1), v, M_NDIM(mp)) + im = M_IM(mp) + + if (M_LINEIO(mp) == YES && M_NDIM(mp) == 2) + bp = imgl2x (im, v[2]) + else if (M_LINEIO(mp) == YES && M_NDIM(mp) == 3) + bp = imgl3x (im, v[2], v[3]) + else { + call amovl (v, ve, M_NDIM(mp)); ve[1] = M_VE(mp,1) + bp = imggsx (im, v, ve, M_NDIM(mp)) + } + + M_LBP(mp) = bp + } else + bp = M_LBP(mp) + + # Return the next line segment. + rp = rl + (M_RLI(mp) - 1) * RL_LENELEM + M_RLI(mp) = M_RLI(mp) + 1 + + x1 = Memi[rp+RL_XOFF] + npix = Memi[rp+RL_NOFF] + mval = Memi[rp+RL_VOFF] + ptr = bp + x1 - M_VS(mp,1) + + if (M_REGCOORDS(mp) == NO) { + v[1] = x1 + do i = 2, M_NDIM(mp) + v[i] = M_V(mp,i) + } else { + v[1] = x1 - M_VS(mp,1) + 1 + do i = 2, M_NDIM(mp) + v[i] = M_V(mp,i) - M_VS(mp,i) + 1 + } + + return (npix) +end diff --git a/sys/pmio/tf/miopld.x b/sys/pmio/tf/miopld.x new file mode 100644 index 00000000..33515220 --- /dev/null +++ b/sys/pmio/tf/miopld.x @@ -0,0 +1,102 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "../mio.h" + +# MIO_PLSEG -- Put a line segment to a masked image. A line segment is a +# region of the data image for which the corresponding region of the mask has +# the constant nonzero value MVAL. Line segments are returned for each line in +# the region VS to VE, returning the number of pixels in each line segment as +# the function value, or EOF when the region is exhausted. Once EOF is +# reached, repeated calls will continue to return EOF until the next call to +# MIO_SETRANGE. Repeated calls to MIO_SETRANGE may be used to access a series +# of distinct regions in the image. If a subregion of the image is being +# accessed with MIO_SETRANGE, the vector coordinates V returned below will +# be relative to the defined subregion (if this is not what is desired, +# the range should be set to the full image and a region mask used to mask +# off the subregion to be accessed). + +int procedure mio_plsegd (mp, ptr, mval, v, npix) + +pointer mp #I MIO descriptor +pointer ptr #O pointer to a buffer containing the data +int mval #O mask value for the output line segment +long v[IM_MAXDIM] #U vector coordinates of first pixel +int npix #O number of pixels in output line segment + +int x1, i +long ve[IM_MAXDIM] +pointer pm, im, rl, rp, bp +pointer impl2d(), impl3d(), impgsd() +errchk impl2d, impl3d, impgsd, pm_glri +bool pm_sectnotempty() +int plloop() + +begin + pm = M_PM(mp) + rl = M_RLP(mp) + + # Initialization performed for the first i/o on a new region. + if (M_ACTIVE(mp) == NO) { + call plsslv (pm, M_VS(mp,1), M_VN(mp,1), M_V(mp,1), M_VE(mp,1)) + call pm_glri (pm, + M_V(mp,1), Memi[rl], M_DEPTH(mp), M_VN(mp,1), PIX_SRC) + M_RLI(mp) = RL_FIRST + M_ACTIVE(mp) = YES + } + + # Get a new mask line? + while (M_RLI(mp) > RLI_LEN(rl)) + if (plloop (M_V(mp,1), M_VS(mp,1), M_VE(mp,1), + M_NDIM(mp)) == LOOP_DONE) { + return (EOF) + } else { + call amovl (M_V(mp,1), ve, M_NDIM(mp)) + ve[1] = M_VE(mp,1) + if (pm_sectnotempty (pm, M_V(mp,1), ve, M_NDIM(mp))) { + call pm_glri (pm, + M_V(mp,1), Memi[rl], M_DEPTH(mp), M_VN(mp,1), PIX_SRC) + M_RLI(mp) = RL_FIRST + } + } + + + # Get a new image line? + if (M_RLI(mp) == RL_FIRST) { + call amovl (M_V(mp,1), v, IM_MAXDIM) + im = M_IM(mp) + + if (M_LINEIO(mp) == YES && M_NDIM(mp) == 2) + bp = impl2d (im, v[2]) + else if (M_LINEIO(mp) == YES && M_NDIM(mp) == 3) + bp = impl3d (im, v[2], v[3]) + else + bp = impgsd (im, v, ve, M_NDIM(mp)) + + M_LBP(mp) = bp + } else + bp = M_LBP(mp) + + # Return the next line segment. + rp = rl + (M_RLI(mp) - 1) * RL_LENELEM + M_RLI(mp) = M_RLI(mp) + 1 + + x1 = Memi[rp+RL_XOFF] + npix = Memi[rp+RL_NOFF] + mval = Memi[rp+RL_VOFF] + ptr = bp + x1 - M_VS(mp,1) + + if (M_REGCOORDS(mp) == NO) { + v[1] = x1 + do i = 2, M_NDIM(mp) + v[i] = M_V(mp,i) + } else { + v[1] = x1 - M_VS(mp,1) + 1 + do i = 2, M_NDIM(mp) + v[i] = M_V(mp,i) - M_VS(mp,i) + 1 + } + + return (npix) +end diff --git a/sys/pmio/tf/miopli.x b/sys/pmio/tf/miopli.x new file mode 100644 index 00000000..80ab9ab2 --- /dev/null +++ b/sys/pmio/tf/miopli.x @@ -0,0 +1,102 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "../mio.h" + +# MIO_PLSEG -- Put a line segment to a masked image. A line segment is a +# region of the data image for which the corresponding region of the mask has +# the constant nonzero value MVAL. Line segments are returned for each line in +# the region VS to VE, returning the number of pixels in each line segment as +# the function value, or EOF when the region is exhausted. Once EOF is +# reached, repeated calls will continue to return EOF until the next call to +# MIO_SETRANGE. Repeated calls to MIO_SETRANGE may be used to access a series +# of distinct regions in the image. If a subregion of the image is being +# accessed with MIO_SETRANGE, the vector coordinates V returned below will +# be relative to the defined subregion (if this is not what is desired, +# the range should be set to the full image and a region mask used to mask +# off the subregion to be accessed). + +int procedure mio_plsegi (mp, ptr, mval, v, npix) + +pointer mp #I MIO descriptor +pointer ptr #O pointer to a buffer containing the data +int mval #O mask value for the output line segment +long v[IM_MAXDIM] #U vector coordinates of first pixel +int npix #O number of pixels in output line segment + +int x1, i +long ve[IM_MAXDIM] +pointer pm, im, rl, rp, bp +pointer impl2i(), impl3i(), impgsi() +errchk impl2i, impl3i, impgsi, pm_glri +bool pm_sectnotempty() +int plloop() + +begin + pm = M_PM(mp) + rl = M_RLP(mp) + + # Initialization performed for the first i/o on a new region. + if (M_ACTIVE(mp) == NO) { + call plsslv (pm, M_VS(mp,1), M_VN(mp,1), M_V(mp,1), M_VE(mp,1)) + call pm_glri (pm, + M_V(mp,1), Memi[rl], M_DEPTH(mp), M_VN(mp,1), PIX_SRC) + M_RLI(mp) = RL_FIRST + M_ACTIVE(mp) = YES + } + + # Get a new mask line? + while (M_RLI(mp) > RLI_LEN(rl)) + if (plloop (M_V(mp,1), M_VS(mp,1), M_VE(mp,1), + M_NDIM(mp)) == LOOP_DONE) { + return (EOF) + } else { + call amovl (M_V(mp,1), ve, M_NDIM(mp)) + ve[1] = M_VE(mp,1) + if (pm_sectnotempty (pm, M_V(mp,1), ve, M_NDIM(mp))) { + call pm_glri (pm, + M_V(mp,1), Memi[rl], M_DEPTH(mp), M_VN(mp,1), PIX_SRC) + M_RLI(mp) = RL_FIRST + } + } + + + # Get a new image line? + if (M_RLI(mp) == RL_FIRST) { + call amovl (M_V(mp,1), v, IM_MAXDIM) + im = M_IM(mp) + + if (M_LINEIO(mp) == YES && M_NDIM(mp) == 2) + bp = impl2i (im, v[2]) + else if (M_LINEIO(mp) == YES && M_NDIM(mp) == 3) + bp = impl3i (im, v[2], v[3]) + else + bp = impgsi (im, v, ve, M_NDIM(mp)) + + M_LBP(mp) = bp + } else + bp = M_LBP(mp) + + # Return the next line segment. + rp = rl + (M_RLI(mp) - 1) * RL_LENELEM + M_RLI(mp) = M_RLI(mp) + 1 + + x1 = Memi[rp+RL_XOFF] + npix = Memi[rp+RL_NOFF] + mval = Memi[rp+RL_VOFF] + ptr = bp + x1 - M_VS(mp,1) + + if (M_REGCOORDS(mp) == NO) { + v[1] = x1 + do i = 2, M_NDIM(mp) + v[i] = M_V(mp,i) + } else { + v[1] = x1 - M_VS(mp,1) + 1 + do i = 2, M_NDIM(mp) + v[i] = M_V(mp,i) - M_VS(mp,i) + 1 + } + + return (npix) +end diff --git a/sys/pmio/tf/miopll.x b/sys/pmio/tf/miopll.x new file mode 100644 index 00000000..c59564b4 --- /dev/null +++ b/sys/pmio/tf/miopll.x @@ -0,0 +1,102 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "../mio.h" + +# MIO_PLSEG -- Put a line segment to a masked image. A line segment is a +# region of the data image for which the corresponding region of the mask has +# the constant nonzero value MVAL. Line segments are returned for each line in +# the region VS to VE, returning the number of pixels in each line segment as +# the function value, or EOF when the region is exhausted. Once EOF is +# reached, repeated calls will continue to return EOF until the next call to +# MIO_SETRANGE. Repeated calls to MIO_SETRANGE may be used to access a series +# of distinct regions in the image. If a subregion of the image is being +# accessed with MIO_SETRANGE, the vector coordinates V returned below will +# be relative to the defined subregion (if this is not what is desired, +# the range should be set to the full image and a region mask used to mask +# off the subregion to be accessed). + +int procedure mio_plsegl (mp, ptr, mval, v, npix) + +pointer mp #I MIO descriptor +pointer ptr #O pointer to a buffer containing the data +int mval #O mask value for the output line segment +long v[IM_MAXDIM] #U vector coordinates of first pixel +int npix #O number of pixels in output line segment + +int x1, i +long ve[IM_MAXDIM] +pointer pm, im, rl, rp, bp +pointer impl2l(), impl3l(), impgsl() +errchk impl2l, impl3l, impgsl, pm_glri +bool pm_sectnotempty() +int plloop() + +begin + pm = M_PM(mp) + rl = M_RLP(mp) + + # Initialization performed for the first i/o on a new region. + if (M_ACTIVE(mp) == NO) { + call plsslv (pm, M_VS(mp,1), M_VN(mp,1), M_V(mp,1), M_VE(mp,1)) + call pm_glri (pm, + M_V(mp,1), Memi[rl], M_DEPTH(mp), M_VN(mp,1), PIX_SRC) + M_RLI(mp) = RL_FIRST + M_ACTIVE(mp) = YES + } + + # Get a new mask line? + while (M_RLI(mp) > RLI_LEN(rl)) + if (plloop (M_V(mp,1), M_VS(mp,1), M_VE(mp,1), + M_NDIM(mp)) == LOOP_DONE) { + return (EOF) + } else { + call amovl (M_V(mp,1), ve, M_NDIM(mp)) + ve[1] = M_VE(mp,1) + if (pm_sectnotempty (pm, M_V(mp,1), ve, M_NDIM(mp))) { + call pm_glri (pm, + M_V(mp,1), Memi[rl], M_DEPTH(mp), M_VN(mp,1), PIX_SRC) + M_RLI(mp) = RL_FIRST + } + } + + + # Get a new image line? + if (M_RLI(mp) == RL_FIRST) { + call amovl (M_V(mp,1), v, IM_MAXDIM) + im = M_IM(mp) + + if (M_LINEIO(mp) == YES && M_NDIM(mp) == 2) + bp = impl2l (im, v[2]) + else if (M_LINEIO(mp) == YES && M_NDIM(mp) == 3) + bp = impl3l (im, v[2], v[3]) + else + bp = impgsl (im, v, ve, M_NDIM(mp)) + + M_LBP(mp) = bp + } else + bp = M_LBP(mp) + + # Return the next line segment. + rp = rl + (M_RLI(mp) - 1) * RL_LENELEM + M_RLI(mp) = M_RLI(mp) + 1 + + x1 = Memi[rp+RL_XOFF] + npix = Memi[rp+RL_NOFF] + mval = Memi[rp+RL_VOFF] + ptr = bp + x1 - M_VS(mp,1) + + if (M_REGCOORDS(mp) == NO) { + v[1] = x1 + do i = 2, M_NDIM(mp) + v[i] = M_V(mp,i) + } else { + v[1] = x1 - M_VS(mp,1) + 1 + do i = 2, M_NDIM(mp) + v[i] = M_V(mp,i) - M_VS(mp,i) + 1 + } + + return (npix) +end diff --git a/sys/pmio/tf/mioplr.x b/sys/pmio/tf/mioplr.x new file mode 100644 index 00000000..05471efd --- /dev/null +++ b/sys/pmio/tf/mioplr.x @@ -0,0 +1,102 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "../mio.h" + +# MIO_PLSEG -- Put a line segment to a masked image. A line segment is a +# region of the data image for which the corresponding region of the mask has +# the constant nonzero value MVAL. Line segments are returned for each line in +# the region VS to VE, returning the number of pixels in each line segment as +# the function value, or EOF when the region is exhausted. Once EOF is +# reached, repeated calls will continue to return EOF until the next call to +# MIO_SETRANGE. Repeated calls to MIO_SETRANGE may be used to access a series +# of distinct regions in the image. If a subregion of the image is being +# accessed with MIO_SETRANGE, the vector coordinates V returned below will +# be relative to the defined subregion (if this is not what is desired, +# the range should be set to the full image and a region mask used to mask +# off the subregion to be accessed). + +int procedure mio_plsegr (mp, ptr, mval, v, npix) + +pointer mp #I MIO descriptor +pointer ptr #O pointer to a buffer containing the data +int mval #O mask value for the output line segment +long v[IM_MAXDIM] #U vector coordinates of first pixel +int npix #O number of pixels in output line segment + +int x1, i +long ve[IM_MAXDIM] +pointer pm, im, rl, rp, bp +pointer impl2r(), impl3r(), impgsr() +errchk impl2r, impl3r, impgsr, pm_glri +bool pm_sectnotempty() +int plloop() + +begin + pm = M_PM(mp) + rl = M_RLP(mp) + + # Initialization performed for the first i/o on a new region. + if (M_ACTIVE(mp) == NO) { + call plsslv (pm, M_VS(mp,1), M_VN(mp,1), M_V(mp,1), M_VE(mp,1)) + call pm_glri (pm, + M_V(mp,1), Memi[rl], M_DEPTH(mp), M_VN(mp,1), PIX_SRC) + M_RLI(mp) = RL_FIRST + M_ACTIVE(mp) = YES + } + + # Get a new mask line? + while (M_RLI(mp) > RLI_LEN(rl)) + if (plloop (M_V(mp,1), M_VS(mp,1), M_VE(mp,1), + M_NDIM(mp)) == LOOP_DONE) { + return (EOF) + } else { + call amovl (M_V(mp,1), ve, M_NDIM(mp)) + ve[1] = M_VE(mp,1) + if (pm_sectnotempty (pm, M_V(mp,1), ve, M_NDIM(mp))) { + call pm_glri (pm, + M_V(mp,1), Memi[rl], M_DEPTH(mp), M_VN(mp,1), PIX_SRC) + M_RLI(mp) = RL_FIRST + } + } + + + # Get a new image line? + if (M_RLI(mp) == RL_FIRST) { + call amovl (M_V(mp,1), v, IM_MAXDIM) + im = M_IM(mp) + + if (M_LINEIO(mp) == YES && M_NDIM(mp) == 2) + bp = impl2r (im, v[2]) + else if (M_LINEIO(mp) == YES && M_NDIM(mp) == 3) + bp = impl3r (im, v[2], v[3]) + else + bp = impgsr (im, v, ve, M_NDIM(mp)) + + M_LBP(mp) = bp + } else + bp = M_LBP(mp) + + # Return the next line segment. + rp = rl + (M_RLI(mp) - 1) * RL_LENELEM + M_RLI(mp) = M_RLI(mp) + 1 + + x1 = Memi[rp+RL_XOFF] + npix = Memi[rp+RL_NOFF] + mval = Memi[rp+RL_VOFF] + ptr = bp + x1 - M_VS(mp,1) + + if (M_REGCOORDS(mp) == NO) { + v[1] = x1 + do i = 2, M_NDIM(mp) + v[i] = M_V(mp,i) + } else { + v[1] = x1 - M_VS(mp,1) + 1 + do i = 2, M_NDIM(mp) + v[i] = M_V(mp,i) - M_VS(mp,i) + 1 + } + + return (npix) +end diff --git a/sys/pmio/tf/miopls.x b/sys/pmio/tf/miopls.x new file mode 100644 index 00000000..85288e28 --- /dev/null +++ b/sys/pmio/tf/miopls.x @@ -0,0 +1,102 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "../mio.h" + +# MIO_PLSEG -- Put a line segment to a masked image. A line segment is a +# region of the data image for which the corresponding region of the mask has +# the constant nonzero value MVAL. Line segments are returned for each line in +# the region VS to VE, returning the number of pixels in each line segment as +# the function value, or EOF when the region is exhausted. Once EOF is +# reached, repeated calls will continue to return EOF until the next call to +# MIO_SETRANGE. Repeated calls to MIO_SETRANGE may be used to access a series +# of distinct regions in the image. If a subregion of the image is being +# accessed with MIO_SETRANGE, the vector coordinates V returned below will +# be relative to the defined subregion (if this is not what is desired, +# the range should be set to the full image and a region mask used to mask +# off the subregion to be accessed). + +int procedure mio_plsegs (mp, ptr, mval, v, npix) + +pointer mp #I MIO descriptor +pointer ptr #O pointer to a buffer containing the data +int mval #O mask value for the output line segment +long v[IM_MAXDIM] #U vector coordinates of first pixel +int npix #O number of pixels in output line segment + +int x1, i +long ve[IM_MAXDIM] +pointer pm, im, rl, rp, bp +pointer impl2s(), impl3s(), impgss() +errchk impl2s, impl3s, impgss, pm_glri +bool pm_sectnotempty() +int plloop() + +begin + pm = M_PM(mp) + rl = M_RLP(mp) + + # Initialization performed for the first i/o on a new region. + if (M_ACTIVE(mp) == NO) { + call plsslv (pm, M_VS(mp,1), M_VN(mp,1), M_V(mp,1), M_VE(mp,1)) + call pm_glri (pm, + M_V(mp,1), Memi[rl], M_DEPTH(mp), M_VN(mp,1), PIX_SRC) + M_RLI(mp) = RL_FIRST + M_ACTIVE(mp) = YES + } + + # Get a new mask line? + while (M_RLI(mp) > RLI_LEN(rl)) + if (plloop (M_V(mp,1), M_VS(mp,1), M_VE(mp,1), + M_NDIM(mp)) == LOOP_DONE) { + return (EOF) + } else { + call amovl (M_V(mp,1), ve, M_NDIM(mp)) + ve[1] = M_VE(mp,1) + if (pm_sectnotempty (pm, M_V(mp,1), ve, M_NDIM(mp))) { + call pm_glri (pm, + M_V(mp,1), Memi[rl], M_DEPTH(mp), M_VN(mp,1), PIX_SRC) + M_RLI(mp) = RL_FIRST + } + } + + + # Get a new image line? + if (M_RLI(mp) == RL_FIRST) { + call amovl (M_V(mp,1), v, IM_MAXDIM) + im = M_IM(mp) + + if (M_LINEIO(mp) == YES && M_NDIM(mp) == 2) + bp = impl2s (im, v[2]) + else if (M_LINEIO(mp) == YES && M_NDIM(mp) == 3) + bp = impl3s (im, v[2], v[3]) + else + bp = impgss (im, v, ve, M_NDIM(mp)) + + M_LBP(mp) = bp + } else + bp = M_LBP(mp) + + # Return the next line segment. + rp = rl + (M_RLI(mp) - 1) * RL_LENELEM + M_RLI(mp) = M_RLI(mp) + 1 + + x1 = Memi[rp+RL_XOFF] + npix = Memi[rp+RL_NOFF] + mval = Memi[rp+RL_VOFF] + ptr = bp + x1 - M_VS(mp,1) + + if (M_REGCOORDS(mp) == NO) { + v[1] = x1 + do i = 2, M_NDIM(mp) + v[i] = M_V(mp,i) + } else { + v[1] = x1 - M_VS(mp,1) + 1 + do i = 2, M_NDIM(mp) + v[i] = M_V(mp,i) - M_VS(mp,i) + 1 + } + + return (npix) +end diff --git a/sys/pmio/tf/mioplx.x b/sys/pmio/tf/mioplx.x new file mode 100644 index 00000000..238cb7eb --- /dev/null +++ b/sys/pmio/tf/mioplx.x @@ -0,0 +1,102 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "../mio.h" + +# MIO_PLSEG -- Put a line segment to a masked image. A line segment is a +# region of the data image for which the corresponding region of the mask has +# the constant nonzero value MVAL. Line segments are returned for each line in +# the region VS to VE, returning the number of pixels in each line segment as +# the function value, or EOF when the region is exhausted. Once EOF is +# reached, repeated calls will continue to return EOF until the next call to +# MIO_SETRANGE. Repeated calls to MIO_SETRANGE may be used to access a series +# of distinct regions in the image. If a subregion of the image is being +# accessed with MIO_SETRANGE, the vector coordinates V returned below will +# be relative to the defined subregion (if this is not what is desired, +# the range should be set to the full image and a region mask used to mask +# off the subregion to be accessed). + +int procedure mio_plsegx (mp, ptr, mval, v, npix) + +pointer mp #I MIO descriptor +pointer ptr #O pointer to a buffer containing the data +int mval #O mask value for the output line segment +long v[IM_MAXDIM] #U vector coordinates of first pixel +int npix #O number of pixels in output line segment + +int x1, i +long ve[IM_MAXDIM] +pointer pm, im, rl, rp, bp +pointer impl2x(), impl3x(), impgsx() +errchk impl2x, impl3x, impgsx, pm_glri +bool pm_sectnotempty() +int plloop() + +begin + pm = M_PM(mp) + rl = M_RLP(mp) + + # Initialization performed for the first i/o on a new region. + if (M_ACTIVE(mp) == NO) { + call plsslv (pm, M_VS(mp,1), M_VN(mp,1), M_V(mp,1), M_VE(mp,1)) + call pm_glri (pm, + M_V(mp,1), Memi[rl], M_DEPTH(mp), M_VN(mp,1), PIX_SRC) + M_RLI(mp) = RL_FIRST + M_ACTIVE(mp) = YES + } + + # Get a new mask line? + while (M_RLI(mp) > RLI_LEN(rl)) + if (plloop (M_V(mp,1), M_VS(mp,1), M_VE(mp,1), + M_NDIM(mp)) == LOOP_DONE) { + return (EOF) + } else { + call amovl (M_V(mp,1), ve, M_NDIM(mp)) + ve[1] = M_VE(mp,1) + if (pm_sectnotempty (pm, M_V(mp,1), ve, M_NDIM(mp))) { + call pm_glri (pm, + M_V(mp,1), Memi[rl], M_DEPTH(mp), M_VN(mp,1), PIX_SRC) + M_RLI(mp) = RL_FIRST + } + } + + + # Get a new image line? + if (M_RLI(mp) == RL_FIRST) { + call amovl (M_V(mp,1), v, IM_MAXDIM) + im = M_IM(mp) + + if (M_LINEIO(mp) == YES && M_NDIM(mp) == 2) + bp = impl2x (im, v[2]) + else if (M_LINEIO(mp) == YES && M_NDIM(mp) == 3) + bp = impl3x (im, v[2], v[3]) + else + bp = impgsx (im, v, ve, M_NDIM(mp)) + + M_LBP(mp) = bp + } else + bp = M_LBP(mp) + + # Return the next line segment. + rp = rl + (M_RLI(mp) - 1) * RL_LENELEM + M_RLI(mp) = M_RLI(mp) + 1 + + x1 = Memi[rp+RL_XOFF] + npix = Memi[rp+RL_NOFF] + mval = Memi[rp+RL_VOFF] + ptr = bp + x1 - M_VS(mp,1) + + if (M_REGCOORDS(mp) == NO) { + v[1] = x1 + do i = 2, M_NDIM(mp) + v[i] = M_V(mp,i) + } else { + v[1] = x1 - M_VS(mp,1) + 1 + do i = 2, M_NDIM(mp) + v[i] = M_V(mp,i) - M_VS(mp,i) + 1 + } + + return (npix) +end diff --git a/sys/pmio/tf/mkpkg b/sys/pmio/tf/mkpkg new file mode 100644 index 00000000..2d51c91e --- /dev/null +++ b/sys/pmio/tf/mkpkg @@ -0,0 +1,33 @@ +# Update the type expanded generic files in the PMIO package library. + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + miogld.x ../mio.h + miogli.x ../mio.h + miogll.x ../mio.h + mioglr.x ../mio.h + miogls.x ../mio.h + mioglx.x ../mio.h + miopld.x ../mio.h + miopli.x ../mio.h + miopll.x ../mio.h + mioplr.x ../mio.h + miopls.x ../mio.h + mioplx.x ../mio.h + pmglpi.x ../pmio.com + pmglpl.x ../pmio.com + pmglps.x ../pmio.com + pmglri.x ../pmio.com + pmglrl.x ../pmio.com + pmglrs.x ../pmio.com + pmplpi.x ../pmio.com + pmplpl.x ../pmio.com + pmplps.x ../pmio.com + pmplri.x ../pmio.com + pmplrl.x ../pmio.com + pmplrs.x ../pmio.com + ; diff --git a/sys/pmio/tf/pmglpi.x b/sys/pmio/tf/pmglpi.x new file mode 100644 index 00000000..2de53760 --- /dev/null +++ b/sys/pmio/tf/pmglpi.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PM_GLP -- Get a line segment as a pixel array, applying the given ROP to +# combine the pixels with those of the output array. + +procedure pm_glpi (pl, v, px_dst, px_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +int px_dst[ARB] #O output pixel array +int px_depth #I pixel depth, bits +int npix #I number of pixels desired +int rop #I rasterop + +int temp, np, step, xstep +pointer sp, px_src, px_out, im +include "../pmio.com" + +begin + im = PM_REFIM(pl) + if (PM_MAPXY(pl) == NO) { + call pl_glpi (pl, v, px_dst, px_depth, npix, rop) + return + } + + call smark (sp) + + # Determine physical coords of line segment. + call amovl (v, v3, PM_MAXDIM) + call imaplv (im, v3, v1, PM_MAXDIM) + v3[1] = v3[1] + npix - 1 + call imaplv (im, v3, v2, PM_MAXDIM) + + # Get line scaling parameters. + if (npix <= 1) + xstep = 1 + else + xstep = (v2[1] - v1[1]) / (npix - 1) + step = xstep + if (xstep < 0) { + temp = v1[1]; v1[1] = v2[1]; v2[1] = temp + step = -step + } + + # Extract the pixels. + np = (npix - 1) * step + 1 + call salloc (px_src, np, TY_INT) + call pl_glpi (pl, v1, Memi[px_src], 0, np, PIX_SRC) + + # Subsample and flip if necessary. + if (step > 1) + call imsamp (Memi[px_src], Memi[px_src], npix, SZ_INT, step) + if (xstep < 0) + call imaflp (Memi[px_src], npix, SZ_INT) + + if (!R_NEED_DST(rop)) + call amovi (Memi[px_src], px_dst, npix) + else { + call salloc (px_out, npix, TY_INT) + call pl_pixropi (Memi[px_src], 1, PL_MAXVAL(pl), px_dst, 1, + MV(px_depth), npix, rop) + call amovi (Memi[px_out], px_dst, npix) + } + + call sfree (sp) +end diff --git a/sys/pmio/tf/pmglpl.x b/sys/pmio/tf/pmglpl.x new file mode 100644 index 00000000..24e4b6ff --- /dev/null +++ b/sys/pmio/tf/pmglpl.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PM_GLP -- Get a line segment as a pixel array, applying the given ROP to +# combine the pixels with those of the output array. + +procedure pm_glpl (pl, v, px_dst, px_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +long px_dst[ARB] #O output pixel array +int px_depth #I pixel depth, bits +int npix #I number of pixels desired +int rop #I rasterop + +int temp, np, step, xstep +pointer sp, px_src, px_out, im +include "../pmio.com" + +begin + im = PM_REFIM(pl) + if (PM_MAPXY(pl) == NO) { + call pl_glpl (pl, v, px_dst, px_depth, npix, rop) + return + } + + call smark (sp) + + # Determine physical coords of line segment. + call amovl (v, v3, PM_MAXDIM) + call imaplv (im, v3, v1, PM_MAXDIM) + v3[1] = v3[1] + npix - 1 + call imaplv (im, v3, v2, PM_MAXDIM) + + # Get line scaling parameters. + if (npix <= 1) + xstep = 1 + else + xstep = (v2[1] - v1[1]) / (npix - 1) + step = xstep + if (xstep < 0) { + temp = v1[1]; v1[1] = v2[1]; v2[1] = temp + step = -step + } + + # Extract the pixels. + np = (npix - 1) * step + 1 + call salloc (px_src, np, TY_LONG) + call pl_glpl (pl, v1, Meml[px_src], 0, np, PIX_SRC) + + # Subsample and flip if necessary. + if (step > 1) + call imsamp (Meml[px_src], Meml[px_src], npix, SZ_LONG, step) + if (xstep < 0) + call imaflp (Meml[px_src], npix, SZ_LONG) + + if (!R_NEED_DST(rop)) + call amovl (Meml[px_src], px_dst, npix) + else { + call salloc (px_out, npix, TY_LONG) + call pl_pixropl (Meml[px_src], 1, PL_MAXVAL(pl), px_dst, 1, + MV(px_depth), npix, rop) + call amovl (Meml[px_out], px_dst, npix) + } + + call sfree (sp) +end diff --git a/sys/pmio/tf/pmglps.x b/sys/pmio/tf/pmglps.x new file mode 100644 index 00000000..bcc50de4 --- /dev/null +++ b/sys/pmio/tf/pmglps.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PM_GLP -- Get a line segment as a pixel array, applying the given ROP to +# combine the pixels with those of the output array. + +procedure pm_glps (pl, v, px_dst, px_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +short px_dst[ARB] #O output pixel array +int px_depth #I pixel depth, bits +int npix #I number of pixels desired +int rop #I rasterop + +int temp, np, step, xstep +pointer sp, px_src, px_out, im +include "../pmio.com" + +begin + im = PM_REFIM(pl) + if (PM_MAPXY(pl) == NO) { + call pl_glps (pl, v, px_dst, px_depth, npix, rop) + return + } + + call smark (sp) + + # Determine physical coords of line segment. + call amovl (v, v3, PM_MAXDIM) + call imaplv (im, v3, v1, PM_MAXDIM) + v3[1] = v3[1] + npix - 1 + call imaplv (im, v3, v2, PM_MAXDIM) + + # Get line scaling parameters. + if (npix <= 1) + xstep = 1 + else + xstep = (v2[1] - v1[1]) / (npix - 1) + step = xstep + if (xstep < 0) { + temp = v1[1]; v1[1] = v2[1]; v2[1] = temp + step = -step + } + + # Extract the pixels. + np = (npix - 1) * step + 1 + call salloc (px_src, np, TY_SHORT) + call pl_glps (pl, v1, Mems[px_src], 0, np, PIX_SRC) + + # Subsample and flip if necessary. + if (step > 1) + call imsamp (Mems[px_src], Mems[px_src], npix, SZ_SHORT, step) + if (xstep < 0) + call imaflp (Mems[px_src], npix, SZ_SHORT) + + if (!R_NEED_DST(rop)) + call amovs (Mems[px_src], px_dst, npix) + else { + call salloc (px_out, npix, TY_SHORT) + call pl_pixrops (Mems[px_src], 1, PL_MAXVAL(pl), px_dst, 1, + MV(px_depth), npix, rop) + call amovs (Mems[px_out], px_dst, npix) + } + + call sfree (sp) +end diff --git a/sys/pmio/tf/pmglri.x b/sys/pmio/tf/pmglri.x new file mode 100644 index 00000000..3b3881f8 --- /dev/null +++ b/sys/pmio/tf/pmglri.x @@ -0,0 +1,81 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# PM_GLR -- Get a line segment as a range list, applying the given ROP to +# combine the pixels with those of the output line list. Note that this +# operator uses IMIO if a section transformation is needed, hence if the +# application also uses IMIO to directly access the mask image, care must +# be taken to avoid confusion over the use of IMIO allocated pixel buffers. + +procedure pm_glri (pl, v, rl_dst, rl_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +int rl_dst[3,ARB] #O output line list +int rl_depth #I line list depth, bits +int npix #I number of pixels desired +int rop #I rasterop + +int rl_len, temp, step, xstep, np +pointer sp, px_src, rl_src, rl_out, im +include "../pmio.com" +int pl_p2ri() + +begin + im = PM_REFIM(pl) + if (PM_MAPXY(pl) == NO) { + call pl_glri (pl, v, rl_dst, rl_depth, npix, rop) + return + } + + call smark (sp) + call salloc (rl_src, RL_MAXLEN(pl), TY_INT) + + # Determine physical coords of line segment. + call amovl (v, v3, PM_MAXDIM) + call imaplv (im, v3, v1, PM_MAXDIM) + v3[1] = v3[1] + npix - 1 + call imaplv (im, v3, v2, PM_MAXDIM) + + # Get line scaling parameters. + if (npix <= 1) + xstep = 1 + else + xstep = (v2[1] - v1[1]) / (npix - 1) + step = xstep + if (xstep < 0) { + temp = v1[1]; v1[1] = v2[1]; v2[1] = temp + step = -step + } + + # Extract the pixels. + np = (npix - 1) * step + 1 + call salloc (px_src, np, TY_INT) + call pl_glpi (pl, v1, Memi[px_src], 0, np, PIX_SRC) + + # Subsample and flip if necessary. + if (step > 1) + call imsamp (Memi[px_src], Memi[px_src], npix, SZ_INT, step) + if (xstep < 0) + call imaflp (Memi[px_src], npix, SZ_INT) + + # Convert to a range list. + rl_len = pl_p2ri (Memi[px_src], 1, Memi[rl_src], npix) + + # Copy to or combine with destination. + if (!R_NEED_DST(rop)) { + rl_len = RLI_LEN(rl_src) * RL_LENELEM + call amovi (Memi[rl_src], rl_dst, rl_len) + } else { + call salloc (rl_out, RL_MAXLEN(pl), TY_INT) + call pl_rangeropi (Memi[rl_src], 1, PL_MAXVAL(pl), rl_dst, 1, + MV(rl_depth), Memi[rl_out], npix, rop) + rl_len = RLI_LEN(rl_out) * RL_LENELEM + call amovi (Memi[rl_out], rl_dst, rl_len) + } + + call sfree (sp) +end diff --git a/sys/pmio/tf/pmglrl.x b/sys/pmio/tf/pmglrl.x new file mode 100644 index 00000000..d78b891e --- /dev/null +++ b/sys/pmio/tf/pmglrl.x @@ -0,0 +1,81 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# PM_GLR -- Get a line segment as a range list, applying the given ROP to +# combine the pixels with those of the output line list. Note that this +# operator uses IMIO if a section transformation is needed, hence if the +# application also uses IMIO to directly access the mask image, care must +# be taken to avoid confusion over the use of IMIO allocated pixel buffers. + +procedure pm_glrl (pl, v, rl_dst, rl_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +long rl_dst[3,ARB] #O output line list +int rl_depth #I line list depth, bits +int npix #I number of pixels desired +int rop #I rasterop + +int rl_len, temp, step, xstep, np +pointer sp, px_src, rl_src, rl_out, im +include "../pmio.com" +int pl_p2rl() + +begin + im = PM_REFIM(pl) + if (PM_MAPXY(pl) == NO) { + call pl_glrl (pl, v, rl_dst, rl_depth, npix, rop) + return + } + + call smark (sp) + call salloc (rl_src, RL_MAXLEN(pl), TY_LONG) + + # Determine physical coords of line segment. + call amovl (v, v3, PM_MAXDIM) + call imaplv (im, v3, v1, PM_MAXDIM) + v3[1] = v3[1] + npix - 1 + call imaplv (im, v3, v2, PM_MAXDIM) + + # Get line scaling parameters. + if (npix <= 1) + xstep = 1 + else + xstep = (v2[1] - v1[1]) / (npix - 1) + step = xstep + if (xstep < 0) { + temp = v1[1]; v1[1] = v2[1]; v2[1] = temp + step = -step + } + + # Extract the pixels. + np = (npix - 1) * step + 1 + call salloc (px_src, np, TY_LONG) + call pl_glpl (pl, v1, Meml[px_src], 0, np, PIX_SRC) + + # Subsample and flip if necessary. + if (step > 1) + call imsamp (Meml[px_src], Meml[px_src], npix, SZ_LONG, step) + if (xstep < 0) + call imaflp (Meml[px_src], npix, SZ_LONG) + + # Convert to a range list. + rl_len = pl_p2rl (Meml[px_src], 1, Meml[rl_src], npix) + + # Copy to or combine with destination. + if (!R_NEED_DST(rop)) { + rl_len = RLI_LEN(rl_src) * RL_LENELEM + call amovl (Meml[rl_src], rl_dst, rl_len) + } else { + call salloc (rl_out, RL_MAXLEN(pl), TY_LONG) + call pl_rangeropl (Meml[rl_src], 1, PL_MAXVAL(pl), rl_dst, 1, + MV(rl_depth), Meml[rl_out], npix, rop) + rl_len = RLI_LEN(rl_out) * RL_LENELEM + call amovl (Meml[rl_out], rl_dst, rl_len) + } + + call sfree (sp) +end diff --git a/sys/pmio/tf/pmglrs.x b/sys/pmio/tf/pmglrs.x new file mode 100644 index 00000000..79fea4f6 --- /dev/null +++ b/sys/pmio/tf/pmglrs.x @@ -0,0 +1,81 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# PM_GLR -- Get a line segment as a range list, applying the given ROP to +# combine the pixels with those of the output line list. Note that this +# operator uses IMIO if a section transformation is needed, hence if the +# application also uses IMIO to directly access the mask image, care must +# be taken to avoid confusion over the use of IMIO allocated pixel buffers. + +procedure pm_glrs (pl, v, rl_dst, rl_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +short rl_dst[3,ARB] #O output line list +int rl_depth #I line list depth, bits +int npix #I number of pixels desired +int rop #I rasterop + +int rl_len, temp, step, xstep, np +pointer sp, px_src, rl_src, rl_out, im +include "../pmio.com" +int pl_p2rs() + +begin + im = PM_REFIM(pl) + if (PM_MAPXY(pl) == NO) { + call pl_glrs (pl, v, rl_dst, rl_depth, npix, rop) + return + } + + call smark (sp) + call salloc (rl_src, RL_MAXLEN(pl), TY_SHORT) + + # Determine physical coords of line segment. + call amovl (v, v3, PM_MAXDIM) + call imaplv (im, v3, v1, PM_MAXDIM) + v3[1] = v3[1] + npix - 1 + call imaplv (im, v3, v2, PM_MAXDIM) + + # Get line scaling parameters. + if (npix <= 1) + xstep = 1 + else + xstep = (v2[1] - v1[1]) / (npix - 1) + step = xstep + if (xstep < 0) { + temp = v1[1]; v1[1] = v2[1]; v2[1] = temp + step = -step + } + + # Extract the pixels. + np = (npix - 1) * step + 1 + call salloc (px_src, np, TY_SHORT) + call pl_glps (pl, v1, Mems[px_src], 0, np, PIX_SRC) + + # Subsample and flip if necessary. + if (step > 1) + call imsamp (Mems[px_src], Mems[px_src], npix, SZ_SHORT, step) + if (xstep < 0) + call imaflp (Mems[px_src], npix, SZ_SHORT) + + # Convert to a range list. + rl_len = pl_p2rs (Mems[px_src], 1, Mems[rl_src], npix) + + # Copy to or combine with destination. + if (!R_NEED_DST(rop)) { + rl_len = RLI_LEN(rl_src) * RL_LENELEM + call amovs (Mems[rl_src], rl_dst, rl_len) + } else { + call salloc (rl_out, RL_MAXLEN(pl), TY_SHORT) + call pl_rangerops (Mems[rl_src], 1, PL_MAXVAL(pl), rl_dst, 1, + MV(rl_depth), Mems[rl_out], npix, rop) + rl_len = RLS_LEN(rl_out) * RL_LENELEM + call amovs (Mems[rl_out], rl_dst, rl_len) + } + + call sfree (sp) +end diff --git a/sys/pmio/tf/pmplpi.x b/sys/pmio/tf/pmplpi.x new file mode 100644 index 00000000..b62b333a --- /dev/null +++ b/sys/pmio/tf/pmplpi.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PM_PLP -- Put a line segment input as a pixel array a mask, applying the +# given ROP to combine the pixels with those of the mask. + +procedure pm_plpi (pl, v, px_src, px_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +int px_src[ARB] #I input pixel array +int px_depth #I pixel depth, bits +int npix #I number of pixels affected +int rop #I rasterop + +pointer sp, ll_src +int ll_len, pl_p2li() +include "../pmio.com" + +begin + if (PM_MAPXY(pl) == NO) + call pl_plpi (pl, v, px_src, px_depth, npix, rop) + else { + call smark (sp) + call salloc (ll_src, LL_MAXLEN(pl), TY_SHORT) + + ll_len = pl_p2li (px_src, 1, Mems[ll_src], npix) + call pm_plls (pl, v, Mems[ll_src], px_depth, npix, rop) + + call sfree (sp) + } +end diff --git a/sys/pmio/tf/pmplpl.x b/sys/pmio/tf/pmplpl.x new file mode 100644 index 00000000..2194d9f9 --- /dev/null +++ b/sys/pmio/tf/pmplpl.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PM_PLP -- Put a line segment input as a pixel array a mask, applying the +# given ROP to combine the pixels with those of the mask. + +procedure pm_plpl (pl, v, px_src, px_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +long px_src[ARB] #I input pixel array +int px_depth #I pixel depth, bits +int npix #I number of pixels affected +int rop #I rasterop + +pointer sp, ll_src +int ll_len, pl_p2ll() +include "../pmio.com" + +begin + if (PM_MAPXY(pl) == NO) + call pl_plpl (pl, v, px_src, px_depth, npix, rop) + else { + call smark (sp) + call salloc (ll_src, LL_MAXLEN(pl), TY_SHORT) + + ll_len = pl_p2ll (px_src, 1, Mems[ll_src], npix) + call pm_plls (pl, v, Mems[ll_src], px_depth, npix, rop) + + call sfree (sp) + } +end diff --git a/sys/pmio/tf/pmplps.x b/sys/pmio/tf/pmplps.x new file mode 100644 index 00000000..68e26f7d --- /dev/null +++ b/sys/pmio/tf/pmplps.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PM_PLP -- Put a line segment input as a pixel array a mask, applying the +# given ROP to combine the pixels with those of the mask. + +procedure pm_plps (pl, v, px_src, px_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +short px_src[ARB] #I input pixel array +int px_depth #I pixel depth, bits +int npix #I number of pixels affected +int rop #I rasterop + +pointer sp, ll_src +int ll_len, pl_p2ls() +include "../pmio.com" + +begin + if (PM_MAPXY(pl) == NO) + call pl_plps (pl, v, px_src, px_depth, npix, rop) + else { + call smark (sp) + call salloc (ll_src, LL_MAXLEN(pl), TY_SHORT) + + ll_len = pl_p2ls (px_src, 1, Mems[ll_src], npix) + call pm_plls (pl, v, Mems[ll_src], px_depth, npix, rop) + + call sfree (sp) + } +end diff --git a/sys/pmio/tf/pmplri.x b/sys/pmio/tf/pmplri.x new file mode 100644 index 00000000..4a2f1435 --- /dev/null +++ b/sys/pmio/tf/pmplri.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PM_PLR -- Put a line segment input as a range list to a mask, applying the +# given ROP to combine the pixels with those of the output mask. + +procedure pm_plri (pl, v, rl_src, rl_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +int rl_src[3,ARB] #I input range list +int rl_depth #I range list pixel depth, bits +int npix #I number of pixels affected +int rop #I rasterop + +pointer sp, ll_src +int ll_len, pl_r2li() +include "../pmio.com" + +begin + if (PM_MAPXY(pl) == NO) + call pl_plri (pl, v, rl_src, rl_depth, npix, rop) + else { + call smark (sp) + call salloc (ll_src, LL_MAXLEN(pl), TY_SHORT) + + ll_len = pl_r2li (rl_src, 1, Mems[ll_src], npix) + call pm_plls (pl, v, Mems[ll_src], rl_depth, npix, rop) + + call sfree (sp) + } +end diff --git a/sys/pmio/tf/pmplrl.x b/sys/pmio/tf/pmplrl.x new file mode 100644 index 00000000..260daa21 --- /dev/null +++ b/sys/pmio/tf/pmplrl.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PM_PLR -- Put a line segment input as a range list to a mask, applying the +# given ROP to combine the pixels with those of the output mask. + +procedure pm_plrl (pl, v, rl_src, rl_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +long rl_src[3,ARB] #I input range list +int rl_depth #I range list pixel depth, bits +int npix #I number of pixels affected +int rop #I rasterop + +pointer sp, ll_src +int ll_len, pl_r2ll() +include "../pmio.com" + +begin + if (PM_MAPXY(pl) == NO) + call pl_plrl (pl, v, rl_src, rl_depth, npix, rop) + else { + call smark (sp) + call salloc (ll_src, LL_MAXLEN(pl), TY_SHORT) + + ll_len = pl_r2ll (rl_src, 1, Mems[ll_src], npix) + call pm_plls (pl, v, Mems[ll_src], rl_depth, npix, rop) + + call sfree (sp) + } +end diff --git a/sys/pmio/tf/pmplrs.x b/sys/pmio/tf/pmplrs.x new file mode 100644 index 00000000..43b99b98 --- /dev/null +++ b/sys/pmio/tf/pmplrs.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# PM_PLR -- Put a line segment input as a range list to a mask, applying the +# given ROP to combine the pixels with those of the output mask. + +procedure pm_plrs (pl, v, rl_src, rl_depth, npix, rop) + +pointer pl #I mask descriptor +long v[PL_MAXDIM] #I vector coords of line segment +short rl_src[3,ARB] #I input range list +int rl_depth #I range list pixel depth, bits +int npix #I number of pixels affected +int rop #I rasterop + +pointer sp, ll_src +int ll_len, pl_r2ls() +include "../pmio.com" + +begin + if (PM_MAPXY(pl) == NO) + call pl_plrs (pl, v, rl_src, rl_depth, npix, rop) + else { + call smark (sp) + call salloc (ll_src, LL_MAXLEN(pl), TY_SHORT) + + ll_len = pl_r2ls (rl_src, 1, Mems[ll_src], npix) + call pm_plls (pl, v, Mems[ll_src], rl_depth, npix, rop) + + call sfree (sp) + } +end diff --git a/sys/pmio/zzdebug.x b/sys/pmio/zzdebug.x new file mode 100644 index 00000000..e21e500d --- /dev/null +++ b/sys/pmio/zzdebug.x @@ -0,0 +1,217 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include + +task pmtest = t_pmtest, + mkmask = t_mkmask, + pmcopy = t_pmcopy, + mio = t_mio + + +# MKMASK -- Make a mask for the given image. + +procedure t_mkmask() + +char image[SZ_FNAME] +char mask[SZ_FNAME] +char cmdfile[SZ_FNAME] +char cmd[SZ_FNAME] + +pointer im, pm +int x, y, r, x1, y1, x2, y2, fd +pointer immap(), pm_newmask() +int open(), nscan(), fscan() +bool streq() + +begin + call clgstr ("image", image, SZ_FNAME) + call clgstr ("mask", mask, SZ_FNAME) + + # Open the image and an empty mask. + im = immap (image, READ_ONLY, 0) + pm = pm_newmask (im, 1) + + # Get the list of commands to be processed. + call clgstr ("cmdfile", cmdfile, SZ_FNAME) + fd = open (cmdfile, READ_ONLY, TEXT_FILE) + + # Process the commands and draw the mask. + while (fscan (fd) != EOF) { + call gargwrd (cmd, SZ_FNAME) + if (nscan() < 1) + break + + if (streq (cmd, "point")) { + # Command: point x y + call gargi (x) + call gargi (y) + if (nscan() < 3) { + call eprintf ("point: bad arg list\n") + next + } + + call eprintf ("point %d %d\n") + call pargi (x); call pargi (y) + call pm_point (pm, x, y, PIX_SET + PIX_VALUE(1)) + + } else if (streq (cmd, "circle")) { + # Command: circle x y r + call gargi (x) + call gargi (y) + call gargi (r) + if (nscan() < 4) { + call eprintf ("circle: bad arg list\n") + next + } + + call eprintf ("circle %d %d %d\n") + call pargi (x); call pargi (y); call pargi (r) + call pm_circle (pm, x, y, r, PIX_SET + PIX_VALUE(1)) + + } else if (streq (cmd, "box")) { + # Command: box x1 y1 x2 y2 + call gargi (x1); call gargi (y1) + call gargi (x2); call gargi (y2) + if (nscan() < 5) { + call eprintf ("box: bad arg list\n") + next + } + + call eprintf ("box %d %d %d %d\n") + call pargi (x1); call pargi (y1) + call pargi (x2); call pargi (y2) + call pm_box (pm, x1,y1, x2,y2, PIX_SET + PIX_VALUE(1)) + + } else { + call eprintf ("bad command %s\n") + call pargstr (cmd) + } + + # call pm_debug (pm, STDERR, 80, PD_INDEX) + } + + # Save the mask in a file. + call pm_savef (pm, mask, "mkmask", 0) + + call pm_close (pm) + call imunmap (im) +end + + +# PMCOPY -- Copy an image mask. + +procedure t_pmcopy + +char refim[SZ_FNAME] +char mask[SZ_FNAME], newmask[SZ_FNAME], title[SZ_LINE] + +pointer im, old_pm, new_pm +long vs[PM_MAXDIM], vn[PM_MAXDIM] +pointer immap(), pm_open(), pm_newmask() +int pm_stati() + +begin + call clgstr ("mask", mask, SZ_FNAME) + call clgstr ("refim", refim, SZ_FNAME) + call clgstr ("newmask", newmask, SZ_FNAME) + + # Open reference image. + im = immap (refim, READ_ONLY, 0) + + # Open old mask. + old_pm = pm_open (NULL) + call pm_loadf (old_pm, mask, title, SZ_LINE) + call pm_seti (old_pm, P_REFIM, im) + + # Create a new mask. + new_pm = pm_newmask (im, pm_stati(old_pm,P_DEPTH)) + + # Copy the mask. + call amovkl (1, vs, PM_MAXDIM) + call amovkl (IM_LEN(im,1), vn, PM_MAXDIM) + call pm_rop (old_pm, vs, new_pm, vs, vn, PIX_SRC) + + # Save in a file. + call pm_savef (new_pm, newmask, title, 0) + + call pm_close (new_pm) + call pm_close (old_pm) + call imunmap (im) +end + + +# MIO -- Test MIO. + +procedure t_mio() + +char image[SZ_FNAME] +char mask[SZ_FNAME] + +real rsum +pointer im, mp, pm, bp +bool debug, usefullimage +long v[IM_MAXDIM], vs[2], ve[2] +int mval, npix, totpix + +real asums() +bool clgetb() +pointer immap(), mio_open() +int clgeti(), mio_glsegs(), mio_stati(), clscan(), nscan() + +begin + call clgstr ("image", image, SZ_FNAME) + call clgstr ("mask", mask, SZ_FNAME) + debug = clgetb ("debug") + + im = immap (image, READ_ONLY, 0) + mp = mio_open (mask, clgeti("flags"), im) + + # The following assumes a 2D image. + usefullimage = true + if (clscan ("region") != EOF) { + call gargi(vs[1]); call gargi (vs[2]) + call gargi(ve[1]); call gargi (ve[2]) + usefullimage = (nscan() != 4) + } + if (usefullimage) { + call amovkl (1, vs, 2) + call amovl (IM_LEN(im,1), ve, 2) + } + call mio_setrange (mp, vs, ve, 2) + + if (debug) { + pm = mio_stati (mp, P_PMDES) + call pm_debug (pm, STDERR, 80, PD_LLOUT) + } + + totpix = 0 + rsum = 0.0 + + while (mio_glsegs (mp, bp, mval, v, npix) != EOF) { + if (debug) { + call eprintf ("x=%3d, y=%3d, n=%3d, mval=%o\n") + call pargl (v[1]) + call pargl (v[2]) + call pargi (npix) + call pargi (mval) + } + totpix = totpix + npix + rsum = rsum + asums (Mems[bp], npix) + } + + call eprintf ("totpix=%d, sum=%g, mean=%g\n") + call pargi (totpix) + call pargr (rsum) + if (totpix == 0) + call pargr (INDEFR) + else + call pargr (rsum / totpix) + + call mio_close (mp) + call imunmap (im) +end diff --git a/sys/pmio/zzinterp.x b/sys/pmio/zzinterp.x new file mode 100644 index 00000000..cd23aaf2 --- /dev/null +++ b/sys/pmio/zzinterp.x @@ -0,0 +1,1142 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +.help pmtest +.nf ------------------------------------------------------------------------- +PMTEST -- PMIO package debug and test facility. + + Due to the complexity of the PMIO package, testing is performed using an +interactive interpreter which reads commands from the standard input. +All commands operate internally upon a set of four mask registers A-D, +and a set of ten vector registers V[0-9]. + + a,b,c,d - mask registers + v0,...,v9 - vector registers + +The following commands are defined: + + help # print command summary + timer # toggle timing of commands + run fname # read commands from a file + clear # clear the screen + bye # all done (also EOF) + + create [mask] naxes axlen depth # create a new mask + load [mask] fname # load mask from file + save [mask] fname [title] # save mask in file + loadim [mask] image # load mask from image + saveim [mask] image [title] # save mask in image + erase [mask] [vs ve] # erase a mask or region + draw [mask] [vs ve] [>ofile] # draw mask or region of mask + + set [mask] # set reference mask + set [vector] i j k... # load vector register + show [vector] # print vector register + show [mask] [index] [ll] [rl] [>ofile] # print debug info for a mask + + box [mask] P1 P2 rop # draw a box + circle [mask] P1 r rop # draw a circle + line [mask] P1 P2 width rop # draw a line segment + point [mask] P1 rop # draw a point + polygon [mask] P1 ... PN rop # draw a polygon + + rop src [vs] dst [vs] [vn] rop # rasterop + stencil src [vs] dst [vs] stn [vs] [vn] rop # stencil + + compare mask1 mask2 # compare two masks + rtest mask1 mask2 # range list conversion test + ptest mask1 mask2 # pixel array conversion test + +Rasterops may be specified either as integer constants (any radix) or via +a simple symbolic notation, e.g.: "opcode+[value]". + +A mask may be examined in detail with SHOW, which calls pm_debug to decode +the contents of a mask. A graphic image of a mask may be drawn with DRAW, +which renders each pixel in the mask as a printable character. +.endhelp -------------------------------------------------------------------- + +define SZ_SBUF 512 # size limiting parameters +define DEF_MASKSIZE_X 75 +define DEF_MASKSIZE_Y 40 +define MAXKWLEN 20 +define MAXARGS 50 +define MAXMREG 4 +define MAXVREG 10 +define MAXINCL 10 +define WIDTH 80 + +define INT_ARG 1 # argument types +define STRING_ARG 2 +define VECTOR_ARG 3 +define MASK_ARG 4 + +define v_i argval[$1] # integer argument +define v_s sbuf[argval[$1]] # string argument +define v_si sbuf[argval[$1]+$2-1] # indexed string argument +define v_v v_reg[1,argval[$1]+1] # vector argument +define v_vi v_reg[$2,argval[$1]+1] # indexed vector argument +define v_m v_mask[argval[$1]] # mask argument + +define KW_BOX 1 # interpreter commands +define KW_BYE 2 +define KW_CIRCLE 3 +define KW_CLEAR 4 +define KW_COMPARE 5 +define KW_CREATE 6 +define KW_DRAW 7 +define KW_ERASE 8 +define KW_HELP 9 +# eol 10 +define KW_LINE 11 +define KW_POINT 12 +define KW_POLYGON 13 +define KW_LOAD 14 +define KW_LOADIM 15 +define KW_PTEST 16 +define KW_ROP 17 +define KW_RTEST 18 +define KW_RUN 19 +define KW_SAVE 20 +define KW_SAVEIM 21 +# eol 22 +define KW_SET 23 +define KW_SHOW 24 +define KW_STENCIL 25 +define KW_TIMER 26 + + +# PMTEST -- Test the PMIO package. Read and execute commands from the standard +# input until EOF or BYE is seen. + +procedure t_pmtest() + +bool timer +long time[2] +int x, y, r +int px[MAXARGS], py[MAXARGS] +int what, rop, v_arg, x1, x2, y1, y2, ip, op, ch, i, j +pointer pm, pm_1, pm_2, def_pm, pm_src, pm_dst, pm_stn, tty +char cmd[SZ_LINE], kwname[SZ_FNAME], fname[SZ_FNAME], title[SZ_LINE] +int opcode, save_fd[MAXINCL], in, fd, o_fd, maskno, depth, naxes, npts +int v1[PL_MAXDIM], v2[PL_MAXDIM], v3[PL_MAXDIM], v4[PL_MAXDIM], v[PL_MAXDIM] +int fstati(), strdic(), open(), getline(), strncmp() +pointer pm_create(), ttyodes() + +char sbuf[SZ_SBUF] +int v_mask[MAXMREG], v_reg[PL_MAXDIM,MAXVREG] +int nargs, argno, argtype[MAXARGS], argval[MAXARGS], s_op, width +common /pmzcom/ v_mask, v_reg, nargs, argno, argtype, argval, s_op, sbuf +define argerr_ 91 +define eof_ 92 + +string keywords "|box|bye|circle|clear|compare|create|draw|erase|help|\ + |line|point|polygon|load|loadim|ptest|rop|rtest|run|save|saveim|\ + |set|show|stencil|timer|" + +begin + in = 0 + ip = 1 + fd = STDIN + cmd[ip] = EOS + timer = false + + # Initialize the mask registers. + v[1] = DEF_MASKSIZE_X + v[2] = DEF_MASKSIZE_Y + do i = 1, MAXMREG + v_mask[i] = pm_create (2, v, 7) + def_pm = v_mask[1] + + # Initialize the vector registers. + do i = 1, MAXVREG + call amovki (1, v_reg[1,i], PL_MAXDIM) + + # Main interpreter loop. + # --------------------------- + + repeat { + # Get next command. + if (cmd[ip] == '\n' || cmd[ip] == '#' || cmd[ip] == EOS) { + # Prompt if reading from the standard input. + if (in == 0 && fstati (STDIN, F_REDIR) == NO) { + call putline (STDOUT, "* ") + call flush (STDOUT) + } + + # Handle EOF on the current command stream. + if (getline (fd, cmd) == EOF) { +eof_ if (in > 0) { + call close (fd) + fd = save_fd[in] + in = in - 1 + } else + break + } + + ip = 1 + } + + # Skip blank lines and comment lines. + for (ip=1; IS_WHITE(cmd[ip]) || cmd[ip] == ';'; ip=ip+1) + ; + if (cmd[ip] == '\n' || cmd[ip] == '#' || cmd[ip] == EOS) + next + + # Extract the keyword into the KWNAME buffer. Leave the input + # pointer positioned to the first char following the keyword. + + for (op=1; cmd[ip] != EOS && cmd[ip] != '\n'; ip=ip+1) { + ch = cmd[ip] + if (IS_ALNUM(ch)) { + kwname[op] = ch + op = op + 1 + } else + break + } + kwname[op] = EOS + + # Look up the keyword in the dictionary. If not found ring the + # bell, but do not quit. + + opcode = strdic (kwname, kwname, MAXKWLEN, keywords) + if (opcode <= 0) { + call eprintf ("unknown command\007\n") + call flush (STDERR) + ip=1; cmd[ip] = EOS + next + } + + # Parse the argument list. + call parse_args (cmd, ip) + + # Process the command. + # ------------------------- + + switch (opcode) { + case KW_BYE: + goto eof_ + + case KW_POINT: + # Draw a point. + + # Get mask. + pm = def_pm + if (argtype[argno] == MASK_ARG) { + pm = v_m(argno) + argno = argno + 1 + } + + # Get coords of point. + if (argtype[argno] == VECTOR_ARG) { + # Coords given as vectors. + x1 = v_vi(argno,1) + y1 = v_vi(argno,2) + argno = argno + 1 + } else { + # Coords given explicitly. + do i = 1, 2 + if (argtype[argno+i-1] != INT_ARG) + goto argerr_ + + x1 = v_i(argno); argno = argno + 1 + y1 = v_i(argno); argno = argno + 1 + } + + # Get rop. + if (argno <= nargs) { + if (argtype[argno] != INT_ARG) + goto argerr_ + rop = v_i(argno); argno = argno + 1 + } else + rop = or (PIX_SRC, PIX_DST) + PIX_VALUE('1') + + # Perform the operation. + if (timer) + call sys_mtime (time) + call pm_point (pm, x1, y1, rop) + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_BOX: + # Draw a box. + + # Get mask. + pm = def_pm + if (argtype[argno] == MASK_ARG) { + pm = v_m(argno) + argno = argno + 1 + } + + # Get corner coords of box. + if (argtype[argno] == VECTOR_ARG) { + # Coords given as vectors. + x1 = v_vi(argno,1) + y1 = v_vi(argno,2) + argno = argno + 1 + if (argtype[argno] != VECTOR_ARG) + goto argerr_ + x2 = v_vi(argno,1) + y2 = v_vi(argno,2) + argno = argno + 1 + + } else { + # Coords given explicitly. + do i = 1, 4 + if (argtype[argno+i-1] != INT_ARG) + goto argerr_ + + x1 = v_i(argno); argno = argno + 1 + y1 = v_i(argno); argno = argno + 1 + x2 = v_i(argno); argno = argno + 1 + y2 = v_i(argno); argno = argno + 1 + } + + # Get rop. + if (argno <= nargs) { + if (argtype[argno] != INT_ARG) + goto argerr_ + rop = v_i(argno); argno = argno + 1 + } else + rop = or (PIX_SRC, PIX_DST) + PIX_VALUE('2') + + # Perform the operation. + if (timer) + call sys_mtime (time) + call pm_box (pm, x1, y1, x2, y2, rop) + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_LINE: + # Draw a line of arbitrary orientation and width. + + # Get mask. + pm = def_pm + if (argtype[argno] == MASK_ARG) { + pm = v_m(argno) + argno = argno + 1 + } + + # Get endpoints of line. + if (argtype[argno] == VECTOR_ARG) { + # Coords given as vectors. + x1 = v_vi(argno,1) + y1 = v_vi(argno,2) + argno = argno + 1 + if (argtype[argno] != VECTOR_ARG) + goto argerr_ + x2 = v_vi(argno,1) + y2 = v_vi(argno,2) + argno = argno + 1 + + } else { + # Coords given explicitly. + do i = 1, 4 + if (argtype[argno+i-1] != INT_ARG) + goto argerr_ + + x1 = v_i(argno); argno = argno + 1 + y1 = v_i(argno); argno = argno + 1 + x2 = v_i(argno); argno = argno + 1 + y2 = v_i(argno); argno = argno + 1 + } + + # Get line width. + if (argno <= nargs) { + if (argtype[argno] != INT_ARG) + goto argerr_ + width = v_i(argno); argno = argno + 1 + } else + width = 1 + + # Get rop. + if (argno <= nargs) { + if (argtype[argno] != INT_ARG) + goto argerr_ + rop = v_i(argno); argno = argno + 1 + } else + rop = or (PIX_SRC, PIX_DST) + PIX_VALUE('4') + + # Perform the operation. + if (timer) + call sys_mtime (time) + call pm_line (pm, x1, y1, x2, y2, width, rop) + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_CIRCLE: + # Draw a circle. + + # Get mask. + pm = def_pm + if (argtype[argno] == MASK_ARG) { + pm = v_m(argno) + argno = argno + 1 + } + + # Get center coords and radius of circle. + if (argtype[argno] == VECTOR_ARG) { + # Center coords given as a vector. + x = v_vi(argno,1) + y = v_vi(argno,2) + argno = argno + 1 + + } else { + # Center coords given explicitly. + do i = 1, 2 + if (argtype[argno+i-1] != INT_ARG) + goto argerr_ + + x = v_i(argno); argno = argno + 1 + y = v_i(argno); argno = argno + 1 + } + + if (argtype[argno] != INT_ARG) + goto argerr_ + r = v_i(argno); argno = argno + 1 + + # Get rop. + if (argno <= nargs) { + if (argtype[argno] != INT_ARG) + goto argerr_ + rop = v_i(argno); argno = argno + 1 + } else + rop = or (PIX_SRC, PIX_DST) + PIX_VALUE('Q') + + # Perform the operation. + if (timer) + call sys_mtime (time) + call pm_circle (pm, x, y, r, rop) + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_POLYGON: + # Draw a polygon. + + # Get mask. + pm = def_pm + if (argtype[argno] == MASK_ARG) { + pm = v_m(argno) + argno = argno + 1 + } + + # Get the coordinates of the polygon. + for (npts=0; argno <= nargs; ) { + npts = npts + 1 + + if (argtype[argno] == VECTOR_ARG) { + # Coords of point given as a vector. + px[npts] = v_vi(argno,1) + py[npts] = v_vi(argno,2) + argno = argno + 1 + + } else if (argtype[argno] == INT_ARG && + argtype[argno+1] == INT_ARG) { + + # Center coords given explicitly. + px[npts] = v_i(argno); argno = argno + 1 + py[npts] = v_i(argno); argno = argno + 1 + } + } + + # Get rop. + if (argno <= nargs) { + if (argtype[argno] != INT_ARG) + goto argerr_ + rop = v_i(argno); argno = argno + 1 + } else + rop = or (PIX_SRC, PIX_DST) + PIX_VALUE('R') + + # Perform the operation. + if (timer) + call sys_mtime (time) + call pm_polygon (pm, px, py, npts, rop) + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_CLEAR: + # Clear the screen. + tty = ttyodes ("terminal") + call ttyclear (STDOUT, tty) + call ttycdes (tty) + + case KW_COMPARE: + # Compare two masks. + if (nargs < 2) + goto argerr_ + + # Get mask 1. + if (argtype[argno] == MASK_ARG) { + pm_1 = v_m(argno) + argno = argno + 1 + } else + goto argerr_ + + # Get mask 2. + if (argtype[argno] == MASK_ARG) { + pm_2 = v_m(argno) + argno = argno + 1 + } else + goto argerr_ + + # Perform the operation. + if (timer) + call sys_mtime (time) + call pm_compare (pm_1, pm_2, STDOUT) + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_CREATE: + # Create a new, emtpy mask of the given size and depth. + + # Get mask. + if (argtype[argno] == MASK_ARG) { + maskno = v_i(argno) + argno = argno + 1 + } + + # Get naxes. + if (argtype[argno] != INT_ARG) + goto argerr_ + naxes = v_i(argno); argno = argno + 1 + + # Get mask size. + if (argtype[argno] == VECTOR_ARG) { + # Mask size given as vector. + call amovi (v_v(argno), v1, PL_MAXDIM) + argno = argno + 1 + } else { + # Mask size given explicitly. + do i = 1, naxes { + if (argtype[argno+i-1] != INT_ARG) + goto argerr_ + v1[i] = v_i(argno) + argno = argno + 1 + } + } + + # Get mask depth. + if (argtype[argno] != INT_ARG) + depth = 1 + else { + depth = v_i(argno) + argno = argno + 1 + } + + # Perform the operation. + if (timer) + call sys_mtime (time) + v_mask[maskno] = pm_create (naxes, v1, depth) + def_pm = v_mask[maskno] + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_DRAW: + # Draw a mask or region of a mask on the screen. + + # Get mask. + pm = def_pm + if (nargs >= 1 && argtype[argno] == MASK_ARG) { + pm = v_m(argno) + argno = argno + 1 + } + + # Get vector coords of region to be drawn. + if (argtype[argno] == VECTOR_ARG) { + call amovi (v_v(argno), v1, PL_MAXDIM) + argno = argno + 1 + } else + call amovki (1, v1, PL_MAXDIM) + + if (argtype[argno] == VECTOR_ARG) { + call amovi (v_v(argno), v2, PL_MAXDIM) + argno = argno + 1 + } else + call amovi (PL_AXLEN(pm,1), v2, PL_MAXDIM) + + # Perform the operation. + call pm_asciidump (pm, v1, v2, STDOUT) + + case KW_ERASE: + # Erase a mask, or a region of a mask. + + # Get mask. + pm = def_pm + if (nargs >= 1 && argtype[argno] == MASK_ARG) { + pm = v_m(argno) + argno = argno + 1 + } + + # Get vector coords of region to be erased. + if (argtype[argno] == VECTOR_ARG) { + call amovi (v_v(argno), v1, PL_MAXDIM) + argno = argno + 1 + } else + call amovki (1, v1, PL_MAXDIM) + + if (argtype[argno] == VECTOR_ARG) { + call amovi (v_v(argno), v2, PL_MAXDIM) + argno = argno + 1 + } else + call amovi (PL_AXLEN(pm,1), v2, PL_MAXDIM) + + # Perform the operation. + if (timer) + call sys_mtime (time) + if (nargs <= 1) + call pm_clear (pm) + else + call pm_rop (NULL, 0, pm, v1, v2, PIX_CLR) + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_HELP: + # Print a command summary. + call print_help (STDOUT) + + case KW_RUN: + # Read commands from a file. + if (nargs < 1 || argtype[argno] != STRING_ARG) + goto argerr_ + + in = in + 1 + if (in > MAXINCL) + call error (1, "too many nested run files\n") + save_fd[in] = fd + iferr (fd = open (v_s(argno), READ_ONLY, TEXT_FILE)) { + call erract (EA_WARN) + fd = save_fd[in] + in = in - 1 + } + + case KW_SET: + # Set the value of a mask or vector register. + if (nargs < 1) { + goto argerr_ + + } else if (argtype[argno] == MASK_ARG) { + # Set the default mask. + def_pm = v_m(argno) + maskno = v_i(argno) + + } else if (argtype[argno] == VECTOR_ARG) { + # Set a vector register. + v_arg = argno + argno = argno + 1 + + do i = 1, PL_MAXDIM + if (argno <= nargs && argtype[argno] == INT_ARG) { + v[i] = v_i(argno) + argno = argno + 1 + } else + v[i] = 1 + + call amovi (v, v_v(v_arg), PL_MAXDIM) + } + + case KW_SHOW: + # Print information about a mask or vector register. + + if (nargs < 1 || argtype[argno] == MASK_ARG) { + # Print information about a mask. + + if (nargs < 1) + pm = def_pm + else { + pm = v_m(argno) + argno = argno + 1 + } + + o_fd = STDOUT + + # Process option selects. + what = PD_SUMMARY + while (argno <= nargs && argtype[argno] == STRING_ARG) { + if (strncmp (v_s(argno), "i", 1) == 0) { + what = or (what, PD_INDEX) + } else if (strncmp (v_s(argno), "ll", 2) == 0) { + what = or (what, PD_LLOUT) + } else if (strncmp (v_s(argno), "rl", 2) == 0) { + what = or (what, PD_RLOUT) + } else if (strncmp (v_s(argno), "lh", 2) == 0) { + what = or (what, PD_LHDR) + + } else if (v_s(argno) == '>') { + # Write output to a file. + if (v_si(argno,2) == '>') { + iferr (o_fd = open (v_si(argno,3), + APPEND, TEXT_FILE)) { + call erract (EA_WARN) + o_fd = STDOUT + } + } else { + iferr (o_fd = open (v_si(argno,2), + NEW_FILE, TEXT_FILE)) { + call erract (EA_WARN) + o_fd = STDOUT + } + } + } else { + call eprintf ("unknown option `%s'\n") + call pargstr (v_s(argno)) + } + argno = argno + 1 + } + + # Perform the operation. + call pm_debug (pm, o_fd, WIDTH, what) + if (o_fd != STDOUT) + call close (o_fd) + + } else if (argtype[argno] == VECTOR_ARG) { + # Print the value of a vector register. + call printf ("v%d: ") + call pargi (v_i(argno)) + do i = 1, PL_MAXDIM { + call printf (" %d") + call pargi (v_vi(argno,i)) + } + call printf ("\n") + + } else { + # Print the value of all vector registers. + do j = 1, MAXVREG { + call printf ("v%d: ") + call pargi (j-1) + do i = 1, PL_MAXDIM { + call printf (" %d") + call pargi (v_reg(i,j)) + } + call printf ("\n") + } + } + + case KW_LOAD: + # Load a mask from a file. + + # Get mask to be loaded. + pm = def_pm + if (nargs >= 1 && argtype[argno] == MASK_ARG) { + pm = v_m(argno) + argno = argno + 1 + } + + # Get mask filename. + if (argno > nargs || argtype[argno] != STRING_ARG) + goto argerr_ + + # Perform the operation. + if (timer) + call sys_mtime (time) + iferr (call pm_loadf (pm, v_s(argno), title, SZ_LINE)) + call erract (EA_WARN) + else if (title[1] != EOS) { + call printf ("mask: %s\n") + call pargstr (title) + call flush (STDOUT) + } + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_SAVE: + # Save a mask in a file. + + # Get mask to be saved. + pm = def_pm + if (nargs >= 1 && argtype[argno] == MASK_ARG) { + pm = v_m(argno) + argno = argno + 1 + } + + # Get mask filename. + if (argno > nargs || argtype[argno] != STRING_ARG) + goto argerr_ + else { + call strcpy (v_s(argno), fname, SZ_FNAME) + argno = argno + 1 + } + + # Get title string. + if (argno <= nargs && argtype[argno] == STRING_ARG) { + call strcpy (v_s(argno), title, SZ_LINE) + argno = argno + 1 + } + + # Perform the operation. + if (timer) + call sys_mtime (time) + iferr (call pm_savef (pm, fname, title, 0)) + call erract (EA_WARN) + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_LOADIM: + # Load a mask from an image. + + # Get mask to be loaded. + pm = def_pm + if (nargs >= 1 && argtype[argno] == MASK_ARG) { + pm = v_m(argno) + argno = argno + 1 + } + + # Get image section. + if (argno > nargs || argtype[argno] != STRING_ARG) + goto argerr_ + + # Perform the operation. + if (timer) + call sys_mtime (time) + iferr (call pm_loadim (pm, v_s(argno), title, 0)) + call erract (EA_WARN) + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_SAVEIM: + # Save a mask in an image. + + # Get mask to be saved. + pm = def_pm + if (nargs >= 1 && argtype[argno] == MASK_ARG) { + pm = v_m(argno) + argno = argno + 1 + } + + # Get output image name. + if (argno > nargs || argtype[argno] != STRING_ARG) + goto argerr_ + else { + call strcpy (v_s(argno), fname, SZ_FNAME) + argno = argno + 1 + } + + # Get title string. + if (argno <= nargs && argtype[argno] == STRING_ARG) { + call strcpy (v_s(argno), title, SZ_LINE) + argno = argno + 1 + } + + # Perform the operation. + if (timer) + call sys_mtime (time) + iferr (call pm_saveim (pm, fname, title, 0)) + call erract (EA_WARN) + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_ROP: + # General rasterop operation. + + # Get source mask. + pm_src = def_pm + if (argtype[argno] == MASK_ARG) { + pm_src = v_m(argno) + argno = argno + 1 + } + + # Get start vector in source mask. + if (argtype[argno] == VECTOR_ARG) { + call amovi (v_v(argno), v1, PL_MAXDIM) + argno = argno + 1 + } else + call amovki (1, v1, PL_MAXDIM) + + # Get destination mask. + pm_dst = def_pm + if (nargs >= 1 && argtype[argno] == MASK_ARG) { + pm_dst = v_m(argno) + argno = argno + 1 + } + + # Get start vector in destination mask. + if (argtype[argno] == VECTOR_ARG) { + call amovi (v_v(argno), v2, PL_MAXDIM) + argno = argno + 1 + } else + call amovki (1, v2, PL_MAXDIM) + + # Get vector defining size of region to be modified. + if (argtype[argno] == VECTOR_ARG) { + call amovi (v_v(argno), v3, PL_MAXDIM) + argno = argno + 1 + } else + call amovi (PL_AXLEN(pm_dst,1), v3, PL_MAXDIM) + + # Get rop. + if (argno <= nargs) { + if (argtype[argno] != INT_ARG) + goto argerr_ + rop = v_i(argno); argno = argno + 1 + } else + rop = PIX_SRC + + # Perform the operation. + if (timer) + call sys_mtime (time) + call pm_rop (pm_src, v1, pm_dst, v2, v3, rop) + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_STENCIL: + # Rasterop operation though a stencil mask. + + # Get source mask. + pm_src = def_pm + if (nargs >= 1 && argtype[argno] == MASK_ARG) { + pm_src = v_m(argno) + argno = argno + 1 + } + + # Get start vector in source mask. + if (argtype[argno] == VECTOR_ARG) { + call amovi (v_v(argno), v1, PL_MAXDIM) + argno = argno + 1 + } else + call amovki (1, v1, PL_MAXDIM) + + # Get destination mask. + pm_dst = def_pm + if (nargs >= 1 && argtype[argno] == MASK_ARG) { + pm_dst = v_m(argno) + argno = argno + 1 + } + + # Get start vector in destination mask. + if (argtype[argno] == VECTOR_ARG) { + call amovi (v_v(argno), v2, PL_MAXDIM) + argno = argno + 1 + } else + call amovki (1, v2, PL_MAXDIM) + + # Get stencil mask. + pm_stn = def_pm + if (nargs >= 1 && argtype[argno] == MASK_ARG) { + pm_stn = v_m(argno) + argno = argno + 1 + } + + # Get start vector in stencil mask. + if (argtype[argno] == VECTOR_ARG) { + call amovi (v_v(argno), v3, PL_MAXDIM) + argno = argno + 1 + } else + call amovki (1, v3, PL_MAXDIM) + + # Get vector defining size of region to be modified. + if (argtype[argno] == VECTOR_ARG) { + call amovi (v_v(argno), v4, PL_MAXDIM) + argno = argno + 1 + } else + call amovi (PL_AXLEN(pm_dst,1), v4, PL_MAXDIM) + + # Get rop. + if (argno <= nargs) { + if (argtype[argno] != INT_ARG) + goto argerr_ + rop = v_i(argno); argno = argno + 1 + } else { + call eprintf ("no rop specified - copying src to dst\n") + rop = PIX_SRC + } + + # Perform the operation. + if (timer) + call sys_mtime (time) + call pm_stencil (pm_src, v1, pm_dst, v2, pm_stn, v3, v4, rop) + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_PTEST, KW_RTEST: + # Line list to pixel array or range list conversion test. + if (nargs < 2) + goto argerr_ + + # Get mask 1. + if (argtype[argno] == MASK_ARG) { + pm_1 = v_m(argno) + argno = argno + 1 + } else + goto argerr_ + + # Get mask 2. + if (argtype[argno] == MASK_ARG) { + pm_2 = v_m(argno) + argno = argno + 1 + } else + goto argerr_ + + # Perform the operation. + if (timer) + call sys_mtime (time) + call conv_test (pm_1, pm_2, STDOUT, opcode) + if (timer) + call sys_ptime (STDOUT, "", time) + + case KW_TIMER: + if (timer) { + call printf ("timer off\n") + timer = false + } else { + call printf ("timer on\n") + timer = true + } + + default: + # Unrecognized command. + call eprintf ("unknown switch\007\n") + call flush (STDERR) + } + + call flush (STDOUT) + next +argerr_ + call eprintf ("invalid argument list\n") + } + + do i = 1, MAXMREG + call pm_close (v_mask[i]) +end + + +# PARSE_ARGS -- Parse the argument list to an interpreter command, leaving +# the decoded arguments in the interpreter common, and returning the number +# of arguments as the function value. + +procedure parse_args (args, ip) + +char args[ARB] # argument list +int ip # pointer into argument list + +double dval +int nchars, junk, i +int ctowrd(), stridx(), gctod(), strlen() + +char sbuf[SZ_SBUF] +int v_mask[MAXMREG], v_reg[PL_MAXDIM,MAXVREG] +int nargs, argno, argtype[MAXARGS], argval[MAXARGS], s_op +common /pmzcom/ v_mask, v_reg, nargs, argno, argtype, argval, s_op, sbuf + +begin + s_op = 1 + argno = 1 + nargs = 0 + + do i = 1, MAXARGS + argtype[i] = 0 + + # Get next token. + junk = ctowrd (args, ip, sbuf[s_op], SZ_SBUF-s_op) + nchars = strlen (sbuf[s_op]) + + while (nchars > 0) { + nargs = nargs + 1 + if (nargs > MAXARGS) + call error (1, "too many arguments") + + if (nchars == 1 && sbuf[s_op] == '=') { + # Discard assignment operator. + nargs = nargs - 1 + + } else if (nchars == 1 && stridx (sbuf[s_op], "abcd") > 0) { + # Mask register. + argval[nargs] = stridx (sbuf[s_op], "abcd") + argtype[nargs] = MASK_ARG + + } else if (nchars == 2 && sbuf[s_op] == 'v' && + # Vector register. + IS_DIGIT(sbuf[s_op+1])) { + argval[nargs] = TO_INTEG(sbuf[s_op+1]) + argtype[nargs] = VECTOR_ARG + + } else if (IS_DIGIT (sbuf[s_op])) { + # Get an integer constant. + i=1; nchars = gctod (sbuf[s_op], i, dval) + argval[nargs] = nint(dval) + argtype[nargs] = INT_ARG + + # Handle the notation "opcode+value", for rasterops. + if (sbuf[s_op+i-1] == '+') { + i=i+1; nchars = gctod (sbuf[s_op], i, dval) + argval[nargs] = argval[nargs] + PIX_VALUE(nint(dval)) + } + + } else { + # String constant. + argval[nargs] = s_op + argtype[nargs] = STRING_ARG + s_op = s_op + nchars + 1 + } + + while (IS_WHITE(args[ip])) + ip = ip + 1 + if (args[ip] == ';' || args[ip] == '\n') { + ip = ip + 1 + break + } + + # Get next token. + junk = ctowrd (args, ip, sbuf[s_op], SZ_SBUF-s_op) + nchars = strlen (sbuf[s_op]) + } +end + + +# CONV_TEST -- Test the line list to pixel array or range list conversion +# routines. + +procedure conv_test (pm_1, pm_2, fd, opcode) + +pointer pm_1 #I input mask +pointer pm_2 #I output mask +int fd #I output file, for reporting errors +int opcode #I KW_[PR]TEST + +begin + call fprintf (fd, "conv_test called\n") +end + + +# PRINT_HELP -- Print the PMIO test interpreter commands help summary. + +procedure print_help (fd) + +int fd #I output file + +begin + call fprintf (fd, "help%48t# print command summary\n") + call fprintf (fd, "timer%48t# toggle timing of commands\n") + call fprintf (fd, "run fname%48t# read commands from a file\n") + call fprintf (fd, "clear%48t# clear the screen\n") + call fprintf (fd, "bye%48t# all done (also EOF)\n\n") + call fprintf (fd, + "create [mask] naxes axlen [depth]%48t# create a new mask\n") + call fprintf (fd, "load [mask] fname%48t# load mask from file\n") + call fprintf (fd, "save [mask] fname%48t# save mask in file\n") + call fprintf (fd, "loadim [mask] image%48t# load mask from image\n") + call fprintf (fd, "saveim [mask] image%48t# save mask in image\n") + call fprintf (fd, "erase [mask] [vs ve]%48t# erase a mask or region\n") + call fprintf (fd, + "draw [mask] [vs ve] [>ofile]%48t# draw mask or region of mask\n\n") + call fprintf (fd, "set [mask]%48t# set reference mask\n") + call fprintf (fd, "set [vector] i j k...%48t# load vector register\n") + call fprintf (fd, "show [vector]%48t# print vector register\n") + call fprintf (fd, +"show [mask] [index] [ll] [rl] [>ofile]%48t# print debug info for a mask\n\n") + call fprintf (fd, "box P1 P2 rop%48t# draw a box\n") + call fprintf (fd, "circle P1 r rop%48t# draw a circle\n \n") + call fprintf (fd, + "line [mask] P1 P2 width rop%48t# draw a line segment\n") + call fprintf (fd, "point [mask] P1 rop%48t# draw a point\n") + call fprintf (fd, "polygon [mask] P1 ... PN rop%48t# draw a polygon\n") + call fprintf (fd, "rop src [vs] dst [vs] [vn] rop%48t# rasterop\n") + call fprintf (fd, + "stencil src [vs] dst [vs] stn [vs] [vn] rop%48t# stencil\n \n") + call fprintf (fd, "compare mask1 mask2%48t# compare two masks\n") + call fprintf (fd, "rtest mask1 mask2%48t# range list conversion test\n") + call fprintf (fd, + "ptest mask1 mask2%48t# pixel array conversion test\n") +end diff --git a/sys/psio/README b/sys/psio/README new file mode 100644 index 00000000..a1786fd7 --- /dev/null +++ b/sys/psio/README @@ -0,0 +1,339 @@ +PSIO -- The Postscript I/O package. + + The PSIO interface is used to format a block of text as Postscript +output on a page of a given size (Letter, Legal, A4 or B5). Once initialized +by a ps_open() call, programs can set various options related to the page +size or properties, preferred fonts, etc. Output is begun with a call to +the ps_write_prolog() routine to initialize the PS prolog. Afterwards, +text may be fed to a buffer using ps_deposit() to fill the output page to +a right justified margin, inserting linebreaks where needed. Other routines +permit specific linebreaks or text positioning as required. + + +1) PSIO Interface Summary +------------------------- + + include + + ps = ps_open (fd, default_footer) + ps_setfont (ps, font) + ps_page_size (ps, page) + ps_font_size (ps, font_size) + ps_header (ps, ledge, center, redge) + ps_footer (ps, ledge, center, redge) + ps_setmargins (ps, left, right, top, bottom) + ps_write_prolog (ps) + ps_close (ps) + + ps_xpos (ps, xpos) + ps_ypos (ps, ypos) + ps_indent (ps, nchars) + ps_testpage (ps, nlines) + ps_deposit (ps, line) + ps_linebreak (ps, fill_flag) + ps_pagebreak (ps, fill_flag) + ps_newline (ps) + ps_output (ps, line) + ps_center (ps, line) + ps_rightjustify (ps, text) + + width = ps_textwidth (ps, string) + pos = ps_centerpos (ps, text) + pos = ps_rjpos (ps, text) + + + +2) PSIO Interface Description +----------------------------- + + ps = ps_open (fd, default_footer) + Initialize the PS structure with default page size and margins, + set output file descriptor. Returns the PS struct pointer initialized + with defaults. If the 'default_footer' int flag is enabled a default + footer containing the string "NOAO/IRAF" in the bottom left corner, + the IRAF version string in the center, and the page number in the + bottom right will be created for each page. Otherwise only a page + number will appear unless a different footer is defined with the + ps_footer() command. + + + ps_setfont (ps, font) + Set the current font to be used. Allowable values for 'font' are set + in the include file as + + define F_ROMAN 1 # times-roman font + define F_ITALIC 2 # times-roman italic font + define F_BOLD 3 # times-roman bold font + define F_TELETYPE 4 # fixed-width font + define F_PREVIOUS 5 # previous font + + The default font will be a 10-point Times-Roman. + + ps_font_size (ps, font_size) + Set the font size in points to be used. Font sizes are not changeable + once the interface has been opened so this routine must be called + before the Postscript prolog is written. + + ps_page_size (ps, page) + + Set the default page size to be used. Allowable values for 'page' + are set in the include file as + + define PAGE_LETTER 1 # US Letter (612x792 @ 300 dpi) + define PAGE_LEGAL 2 # US Legal (612x1008 @ 300 dpi) + define PAGE_A4 3 # A4 size (595x850 @ 300 dpi) + define PAGE_B5 4 # B5 size (524x765 @ 300 dpi) + + The default page size will be US Letter but can be overridden in the + environment by defining a 'pspage' variable as e.g. + + cl> reset pspage = "legal" + + ps_header (ps, ledge, center, redge) + Set header text tags. The header will appear on each page, empty + strings are allowed to indicate no text is to be written in that + part of the header. + + ps_footer (ps, ledge, center, redge) + Set footer text tags. The footer will appear on each page, empty + strings are allowed to indicate no text is to be written in that + part of the header. A running page number will always be written + to the 'redge' field unless a non-empty value is defined, a white- + space character can be used to indicate no text should be written + to that part of the footer. + + ps_setmargins (ps, left, right, top, bottom) + Set/Change page margins from defaults set by ps_open(). Values are + defined in units of inches given as a floating point number. + + ps_write_prolog (ps) + Write the PS prolog given the current postscript struct. This + initializes a flag preventing subsequent changes from taking effect + once called. + + ps_close (ps) + Close the struct, flush the page, and free memory + + + ps_xpos (ps, xpos) + ps_ypos (ps, ypos) + Set current X or Y position on page + + ps_indent (ps, nchars) + Set a temporary indenture of the page from the permanent left margin. + Value is given as a number of fixed-width characters, negative values + are not permitted, a value of zero may be used to reset to the left + margin. + + ps_testpage (ps, nlines) + Test whether the output is within the specified number of line of + the end of the page, if so do a page break. This routine can be used + to force a page break when a certain number of lines is to be reserved + to e.g. keep a group of text together on a page. + + ps_deposit (ps, line) + Deposit a line of text to the output buffer. When the output width + exceeds the permanent right margin the line is flushed to the output + file and the x-position reset to the current left margin, the y-pos + is moved to the next line determined by the font size. Remaining + words in the line buffer to added to the next line buffer. + Width of the line is computed from the width of each word plus + a space char, including font changes. The line buffer outputs each + word plus spacing individually, font changes are handled in the + output routine. + + ps_linebreak (ps, fill_flag) + Break the current line regardless of whether it has been filled. + The int 'fill_flag' says whether to fill the current line to be right + justified. May be called to simply flush the current line buffer. + + ps_output (ps, line, fill_flag) + Output the given line and break, fill to be right justified if the + int 'fill_flag' is set. + + ps_center (ps, line) + Center the line on the page and break. + + ps_rightjustify (ps, text) + Right justfify text on the current line. + + + width = ps_textwidth (ps, string) + Get the width of the given string. Width is returned in terms of + Postscript pixels assuming a 72 point, 300 dpi page. + + pos = ps_centerpos (ps, text) + pos = ps_rjpos (ps, text) + Get the X position of the centered and right-justified strings. + + +3) Postscript Prolog +-------------------- + + Example prolog for the postscript output. The actual prolog is +created based on parameters specified such as the page size, header/footer +text, etc. Lines with '***' indicate those which are set dependent upon +PS structure values. + + +%!PS-Adobe-1.0 +%%Creator: IRAF postscript translator +%%CreationDate: Wed May 19 14:34:47 1999 +%%Pages: (atend) +%%DocumentFonts: (atend) +%%EndComments +%%BeginProlog + +/inch { 72 mul } def % 72 points per inch +/PL { 792 } def % set page height *** +/FtrY { 20 } def % footer Y position +/HdrY { PL 40 sub } def % header Y position +/xOrg 72 def % 1 inch left margin *** +/yOrg 720 def % 1 inch top margin *** +/yDelta 12 def % line spacing *** +/Line 1 def % line number +/Page 0 def % page number +/pnum 4 string def % sizeof page number cvs buffer +/res 10.00 def % pixel resolution factor *** + +/TA { newpath % Draw a box around our text + xOrg yOrg moveto % area as a debugging procedure. + 0 -664 rlineto % *** + 467 0 rlineto % *** + 0 664 rlineto % *** + closepath + stroke +} bind def + +/FS { findfont exch scalefont } bind def % find and scale a font +/Fonts [ % create an array of fonts + 10 /Times-Roman FS % *** + 10 /Times-Bold FS % *** + 10 /Times-Italic FS % *** + 10 /Courier FS % *** + 12 /Times-Bold FS % *** +] def +/R { Fonts 0 get setfont } bind def % set roman font +/B { Fonts 1 get setfont } bind def % set bold font +/I { Fonts 2 get setfont } bind def % set italic font +/T { Fonts 3 get setfont } bind def % set teletype font +/H { Fonts 4 get setfont } bind def % set header font + +/NL { Line 1 add SL } bind def % newline +/H { res div + currentpoint exch pop + moveto } def % horizontal position +/S { exch H show } bind def % show +/SL { /Line exch def % set line position + xOrg yOrg Line yDelta mul sub moveto +} bind def + + +/BP { % Begin page (header). + xOrg HdrY moveto R (TEE \(Nov97\)) show % write the header *** + 280 HdrY moveto R (system) show % *** + 485 HdrY moveto R (TEE \(Nov97\)) show % *** + 1 SL R +} bind def + +/EP { % End page (footer). + /Page Page 1 add def % increment page number + xOrg FtrY moveto R (NOAO/IRAF) show % write the footer *** + 250 FtrY moveto R (IRAF V2.11 May 1997) show *** + 530 FtrY moveto R Page pnum cvs show *** + showpage % show the page +} bind def + +%%EndProlog +%%Page: 1 1 +%----------------------------------------------------------------------------- + +initgraphics +TA +BP + ...... +EP + ...... + +% end of listing +%%Trailer +%%DocumentFonts: Times-Roman Times-Bold Times-Italic Courier +%%Pages: *** + + + +4) Example Program +------------------ + +include +include + +task pstest = t_pstest + +# PSTEST -- Test the PSIO package. This test program pretty-prints a file +# with a header message and page number suitable for output to a printer. + +procedure t_pstest() + +pointer ps +int fd, ip, op +char fname[SZ_FNAME], date[SZ_TIME], line[SZ_LINE], outline[SZ_LINE] + +pointer ps_open() +int open(), getline() +long clktime() + +begin + # Get the file to format and date string. + call clgstr ("filename", fname, SZ_FNAME) + call cnvtime (clktime(0), date, SZ_TIME) + + # Open the file. + fd = open (fname, READ_ONLY, TEXT_FILE) + + # Initialize the PSIO interface. + ps = ps_open (STDOUT, NO) + call ps_header (ps, fname, "NOAO/IRAF", date) + call ps_footer (ps, "PSIO Test Page", "", "") + call ps_write_prolog (ps) + + # Output the text in a fixed-width font. + call ps_setfont (ps, F_TELETYPE) + + call ps_linebreak (ps, NO) + while (getline (fd, line) != EOF) { + + if (line[1] == EOS) { + # Simple break on a newline. + call ps_linebreak (ps, NO) + + } else { + # Detab the line. + ip = 1 + op = 1 + while (line[ip] != EOS && op <= SZ_LINE) { + if (line[ip] == '\t') { + repeat { + outline[op] = ' ' + op = op + 1 + } until (mod(op,8) == 1) + ip = ip + 1 + } else { + outline[op] = line [ip] + ip = ip + 1 + op = op + 1 + } + } + outline[op] = EOS + + # Output the line and a newline. + call ps_output (ps, outline, NO) + call ps_newline (ps) + } + } + + # Close the file and PSIO interface. + call close (fd) + call ps_close (ps) +end + diff --git a/sys/psio/font.com b/sys/psio/font.com new file mode 100644 index 00000000..30ae823e --- /dev/null +++ b/sys/psio/font.com @@ -0,0 +1,68 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# FONT.COM -- Character width font tables. Each array contains the width +# of ASCII chars 32 (space) thru 126 (~) expressed as 10 times the width +# in pixels as drawn on a 300dpi page. This allows us to compute fractional +# pixels when placing strings. +# +# The default font chosen is a 10-point Times-Roman in normal, bold and italic. +# Other font sizes chosen will be scaled from these values. Fixed width fonts +# don't need width tables and are defined in the PSTOOLS.H file. + +# Set an alias for the width of a space char so we can change it easily +# in the package include and not forget about it here. +define SW SPACE_WIDTH + +# Declare the width tables. +int i +short roman[96], bold[96], italic[96] + + +# Times-Roman 10-point normal. +data (roman(i), i= 1, 7) / SW, 33, 41, 50, 50, 83, 78/ +data (roman(i), i= 8,14) / 33, 33, 33, 50, 56, 25, 33/ +data (roman(i), i=15,21) / 25, 28, 50, 50, 50, 50, 50/ +data (roman(i), i=22,28) / 50, 50, 50, 50, 50, 28, 28/ +data (roman(i), i=29,35) / 56, 56, 56, 44, 92, 72, 67/ +data (roman(i), i=36,42) / 67, 72, 61, 56, 72, 72, 33/ +data (roman(i), i=43,49) / 39, 72, 61, 89, 72, 72, 56/ +data (roman(i), i=50,56) / 72, 67, 56, 61, 72, 72, 94/ +data (roman(i), i=57,63) / 72, 72, 61, 33, 28, 33, 47/ +data (roman(i), i=64,70) / 50, 33, 44, 50, 44, 50, 44/ +data (roman(i), i=71,77) / 33, 50, 50, 28, 28, 50, 28/ +data (roman(i), i=78,84) / 78, 50, 50, 50, 50, 33, 39/ +data (roman(i), i=85,91) / 28, 50, 50, 72, 50, 50, 44/ +data (roman(i), i=92,96) / 48, 20, 48, 54, 0/ + +# Times-Roman 10-point bold. +data (bold(i), i= 1, 7) / SW, 33, 56, 50, 50, 100, 83/ +data (bold(i), i= 8,14) / 33, 33, 33, 50, 57, 25, 33/ +data (bold(i), i=15,21) / 25, 28, 50, 50, 50, 50, 50/ +data (bold(i), i=22,28) / 50, 50, 50, 50, 50, 33, 33/ +data (bold(i), i=29,35) / 57, 57, 57, 50, 93, 72, 67/ +data (bold(i), i=36,42) / 72, 72, 67, 61, 78, 78, 39/ +data (bold(i), i=43,49) / 50, 78, 67, 94, 72, 78, 61/ +data (bold(i), i=50,56) / 78, 72, 56, 67, 72, 72, 100/ +data (bold(i), i=57,63) / 72, 72, 67, 33, 28, 33, 58/ +data (bold(i), i=64,70) / 50, 33, 50, 56, 44, 56, 44/ +data (bold(i), i=71,77) / 33, 50, 56, 28, 33, 56, 28/ +data (bold(i), i=78,84) / 83, 56, 50, 56, 56, 44, 39/ +data (bold(i), i=85,91) / 33, 56, 50, 72, 50, 50, 44/ +data (bold(i), i=92,96) / 39, 22, 39, 52, 0/ + +# Times-Roman 10-point italic. +data (italic(i), i= 1, 7) / SW, 33, 42, 50, 50, 83, 78/ +data (italic(i), i= 8,14) / 33, 33, 33, 50, 68, 25, 33/ +data (italic(i), i=15,21) / 25, 28, 50, 50, 50, 50, 50/ +data (italic(i), i=22,28) / 50, 50, 50, 50, 50, 33, 33/ +data (italic(i), i=29,35) / 68, 68, 68, 50, 92, 61, 61/ +data (italic(i), i=36,42) / 67, 72, 61, 61, 72, 72, 33/ +data (italic(i), i=43,49) / 44, 67, 56, 83, 67, 72, 61/ +data (italic(i), i=50,56) / 72, 61, 50, 56, 72, 61, 83/ +data (italic(i), i=57,63) / 61, 56, 56, 39, 28, 39, 42/ +data (italic(i), i=64,70) / 50, 33, 50, 50, 44, 50, 44/ +data (italic(i), i=71,77) / 28, 50, 50, 28, 28, 44, 28/ +data (italic(i), i=78,84) / 72, 50, 50, 50, 50, 39, 39/ +data (italic(i), i=85,91) / 28, 50, 44, 67, 44, 44, 39/ +data (italic(i), i=92,96) / 40, 27, 40, 54, 0/ + diff --git a/sys/psio/mkpkg b/sys/psio/mkpkg new file mode 100644 index 00000000..8c5fa1e8 --- /dev/null +++ b/sys/psio/mkpkg @@ -0,0 +1,29 @@ +# Make the PSIO interface library. + +$checkout libsys.a lib$ +$update libsys.a +$checkin libsys.a lib$ +$exit + + +zzdebug: +zzdebug.e: + $set XFLAGS = "$(XFLAGS) -q" + $omake zzdebug.x psio.h + $link zzdebug.o -o zzdebug.e + ; + +libsys.a: + psbreak.x psio.h + pscenter.x psio.h + psclose.x psio.h + psdeposit.x psio.h + psfont.x psio.h + psjustify.x psio.h + psopen.x psio.h + psoutput.x psio.h + pspos.x psio.h + psprolog.x psio.h + pssetup.x psio.h + pswidth.x psio.h font.com + ; diff --git a/sys/psio/psbreak.x b/sys/psio/psbreak.x new file mode 100644 index 00000000..eb82b541 --- /dev/null +++ b/sys/psio/psbreak.x @@ -0,0 +1,80 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "psio.h" + + +# PS_LINEBREAK -- Break the current line regardless of whether it has been +# filled. The fill_flag says whether to fill the current line to be right +# justified. May be called to simply output the current line buffer. + +procedure ps_linebreak (ps, fill_flag) + +pointer ps #I PSIO descriptor +int fill_flag #I fill line flag + +begin + iferr (call ps_output (ps, Memc[PS_WBPTR(ps)], fill_flag)) + return + + # Do a variable spacing depending on whether we're within unformatted + # text where the font is smaller, or outputting a regular line. + + if (PS_CFONT(ps) == F_TELETYPE) + PS_YPOS(ps) = PS_YPOS(ps) - ((LINE_HEIGHT-2) * RESOLUTION) + else + PS_YPOS(ps) = PS_YPOS(ps) - (LINE_HEIGHT * RESOLUTION) + + # Check for a page break. + if (PS_YPOS(ps) <= PS_PBMARGIN(ps)) + call ps_pagebreak (ps) + else { + call fprintf (PS_FD(ps), "%d V\n") + call pargi (PS_YPOS(ps)) + } + + # Reset the X position to current left margin. + PS_XPOS(ps) = PS_CLMARGIN(ps) + + # Clear the word buffer. + call aclrc (Memc[PS_WBPTR(ps)], SZ_LINE) +end + + +# PS_NEWLINE -- Output a newline (vertical space actually). + +procedure ps_newline (ps) + +pointer ps #I PSIO descriptor + +begin + # Check for a page break. + PS_YPOS(ps) = PS_YPOS(ps) - ((LINE_HEIGHT-4) * RESOLUTION) + if (PS_YPOS(ps) <= PS_PBMARGIN(ps)) + call ps_pagebreak (ps) + else { + call fprintf (PS_FD(ps), "%d V\n") + call pargi (PS_YPOS(ps)) + } + + # Reset the X position to current left margin. + PS_XPOS(ps) = PS_CLMARGIN(ps) +end + + +# PS_PAGEBREAK -- Break the current page regardless of whether it has been +# filled. + +procedure ps_pagebreak (ps) + +pointer ps #I PSIO descriptor + +begin + PS_PNUM(ps) = PS_PNUM(ps) + 1 + call fprintf (PS_FD(ps), "EP\n%%%%Page: %d %d\nBP\n") + call pargi (PS_PNUM(ps)) + call pargi (PS_PNUM(ps)) + + PS_YPOS(ps) = (PS_PHEIGHT(ps) * RESOLUTION) - PS_PTMARGIN(ps) + call ps_ypos (ps, PS_YPOS(ps)) +end diff --git a/sys/psio/pscenter.x b/sys/psio/pscenter.x new file mode 100644 index 00000000..818c33cb --- /dev/null +++ b/sys/psio/pscenter.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "psio.h" + + +# PS_CENTER -- Center the string on the page and break. + +procedure ps_center (ps, str) + +pointer ps #I PSIO descriptor +char str[ARB] #I text string + +int mtemp, ps_centerPos() +errchk ps_centerpos, ps_output + +begin + mtemp = PS_CLMARGIN(ps) + PS_CLMARGIN(ps) = ps_centerpos (ps, str) + call ps_output (ps, str, NO) + PS_CLMARGIN(ps) = mtemp +end + + +# PS_CENTERPOS -- Get the X position of the centered string. + +int procedure ps_centerpos (ps, str) + +pointer ps #I PSIO descriptor +char str[ARB] #I string to center + +int ps_textwidth() +errchk ps_textwidth + +begin + return (((PS_PWIDTH(ps) * RESOLUTION)/2) - ps_textwidth (ps, str) / 2) +end diff --git a/sys/psio/psclose.x b/sys/psio/psclose.x new file mode 100644 index 00000000..ba0d694e --- /dev/null +++ b/sys/psio/psclose.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "psio.h" + + +# PS_CLOSE -- Close the struct and free memory. + +procedure ps_close (ps) + +pointer ps #I PSIO descriptor + +errchk mfree + +begin + # Write the page trailer. + call ps_trailer(ps) + + call mfree (PS_HLE(ps), TY_CHAR) + call mfree (PS_HCE(ps), TY_CHAR) + call mfree (PS_HRE(ps), TY_CHAR) + call mfree (PS_FLE(ps), TY_CHAR) + call mfree (PS_FCE(ps), TY_CHAR) + call mfree (PS_FRE(ps), TY_CHAR) + call mfree (PS_WBPTR(ps), TY_CHAR) + + call mfree (ps, TY_STRUCT) +end diff --git a/sys/psio/psdeposit.x b/sys/psio/psdeposit.x new file mode 100644 index 00000000..a3df3ea9 --- /dev/null +++ b/sys/psio/psdeposit.x @@ -0,0 +1,94 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "psio.h" + + +# PS_DEPOSIT -- Deposit a line of text to the output buffer. When the output +# width exceeds the permanent right margin the line us flushed to the output +# file and the x-position reset to the current left margin, the y-pos is +# moved to the next line dependent on the font size. Remaining words in the +# line buffer to added to the next line buffer. + +procedure ps_deposit (ps, line) + +pointer ps #I PSIO descriptor +char line[ARB] #I text line + +char word[SZ_FNAME] +pointer wbuf, wp +int i, ip, start_ip +int len, width, curpos, rmargin + +int strlen(), ps_textwidth(), ps_chwidth() +errchk ps_chwidth, ps_textwidth, ps_linebreak + +begin + # Process the line, collect all the words that will fit on the + # line and add to the word buffer. When the line fills output + # it, otherwise fill the buffer. + + wbuf = PS_WBPTR(ps) + wp = PS_WBPTR(ps) + strlen (Memc[wbuf]) + curpos = PS_CLMARGIN(ps) + ps_textwidth (ps, Memc[wbuf]) + rmargin = PS_CRMPOS(ps) + len = strlen (line) + + # Trim trailing whitespace or newlines. + for ( ; IS_WHITE(line[len]) || line[len] == '\n'; len=len-1) + line[len] = EOS + + # Take care of any leading whitespace. Tabs are treated as + # spaces, we assume the caller has 'detabbed' the line before + # we are called. + for (ip=1; IS_WHITE(line[ip]); ip=ip+1) + width = width + ps_chwidth (line[ip], PS_CFONT(ps)) + if (PS_JUSTIFY(ps) == NO) + curpos = curpos + width + + # Process the rest of the line. + for (; ip <= len; ip=ip+1) { + + # Get the next word on the line and it's length. + start_ip = ip + for (i=1; !IS_WHITE(line[ip]) && line[ip] != EOS; i=i+1) { + word[i] = line[ip] + ip = ip + 1 + } + word[i] = EOS + len = ps_textwidth (ps, word) + + if (curpos + len > rmargin) { + # We would overflow the line so break it here. + len = strlen (Memc[wbuf]) + Memc[wbuf+len-1] = EOS + call ps_linebreak (ps, PS_JUSTIFY(ps)) + + call aclrc (Memc[wbuf], SZ_FNAME) + call strcpy (line[start_ip], Memc[wbuf], SZ_LINE) + call strcat (" ", Memc[wbuf], SZ_LINE) + return + + } else { + # Copy the word to the buffer and update the position. + call strcat (word, Memc[wbuf], SZ_LINE) + curpos = curpos + len + wp = wp + strlen (word) + } + + # Get the spaces between words. + for (; IS_WHITE(line[ip]) && line[ip] != EOS; ip=ip+1) { + curpos = curpos + ps_chwidth (line[ip], PS_CFONT(ps)) + Memc[wp] = line[ip] + wp = wp + 1 + } + + if (line[ip] == EOS) + break + else + ip = ip - 1 + } + + call strcat (" ", Memc[wbuf], SZ_LINE) + PS_XPOS(ps) = curpos +end diff --git a/sys/psio/psfont.x b/sys/psio/psfont.x new file mode 100644 index 00000000..ca91b719 --- /dev/null +++ b/sys/psio/psfont.x @@ -0,0 +1,145 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "psio.h" + + +# PS_SETFONT -- Set the font to be used. + +procedure ps_setfont (ps, font) + +pointer ps #I PSIO descriptor +int font #I font type + +int old_font +char old_font_ch, ps_fontchar() +errchk syserr + +begin + old_font = PS_CFONT(ps) + old_font_ch = PS_CFONT_CH(ps) + + switch (font) { + case F_ROMAN: + PS_CFONT(ps) = F_ROMAN + PS_CFONT_CH(ps) = 'R' + call fprintf (PS_FD(ps), "R ") + case F_ITALIC: + PS_CFONT(ps) = F_ITALIC + PS_CFONT_CH(ps) = 'I' + call fprintf (PS_FD(ps), "I ") + case F_BOLD: + PS_CFONT(ps) = F_BOLD + PS_CFONT_CH(ps) = 'B' + call fprintf (PS_FD(ps), "B ") + case F_TELETYPE: + PS_CFONT(ps) = F_TELETYPE + PS_CFONT_CH(ps) = 'T' + call fprintf (PS_FD(ps), "T ") + case F_PREVIOUS: + if (PS_SFONT(ps) != NULL) { + call fprintf (PS_FD(ps), "%c ") + call pargc (ps_fontchar (ps, PS_SFONT(ps))) + } else { + call fprintf (PS_FD(ps), "%c ") + call pargc (ps_fontchar (ps, PS_PFONT(ps))) + } + default: + call syserr (SYS_PSFONT) + } + + PS_PFONT(ps) = old_font + PS_PFONT_CH(ps) = old_font_ch +end + + +# PS_SPFONT -- Set the special font to be used. + +procedure ps_spfont (ps, font) + +pointer ps #I PSIO descriptor +int font #I font type + +errchk syserr + +begin + if (font == NULL) { + PS_SFONT(ps) = NULL + PS_SFONT_CH(ps) = EOS + call fprintf (PS_FD(ps), "R ") + return + } + + switch (font) { + case F_ROMAN: + PS_SFONT(ps) = F_ROMAN + PS_SFONT_CH(ps) = 'R' + call fprintf (PS_FD(ps), "R ") + case F_ITALIC: + PS_SFONT(ps) = F_ITALIC + PS_SFONT_CH(ps) = 'I' + call fprintf (PS_FD(ps), "I ") + case F_BOLD: + PS_SFONT(ps) = F_BOLD + PS_SFONT_CH(ps) = 'B' + call fprintf (PS_FD(ps), "B ") + case F_TELETYPE: + PS_SFONT(ps) = F_TELETYPE + PS_SFONT_CH(ps) = 'T' + call fprintf (PS_FD(ps), "T ") + default: + call syserr (SYS_PSSPFONT) + } +end + + +# PS_GETFONT -- Given the font character in a "\fN" string return the font +# type code. + +int procedure ps_getfont (ps, font_char) + +pointer ps #I PSIO descriptor +char font_char #I font type character + +begin + switch (font_char) { + case 'R': + return (F_ROMAN) + case 'B': + return (F_BOLD) + case 'I': + return (F_ITALIC) + case 'T': + return (F_TELETYPE) + case 'P': + return (F_PREVIOUS) + default: + return (PS_CFONT(ps)) + } +end + + +# PS_FONTCHAR -- Given the font code return the character for it. + +char procedure ps_fontchar (ps, font) + +pointer ps #I PSTIO descriptor +int font #I font type character + +begin + switch (font) { + case F_ROMAN: + return ('R') + case F_BOLD: + return ('B') + case F_ITALIC: + return ('I') + case F_TELETYPE: + return ('T') + case F_PREVIOUS: + return ('P') + default: + return (PS_CFONT_CH(ps)) + } +end diff --git a/sys/psio/psio.h b/sys/psio/psio.h new file mode 100644 index 00000000..418b05bc --- /dev/null +++ b/sys/psio/psio.h @@ -0,0 +1,90 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# PSIO.H -- Private definitions for the PSIO interface. + +# Page size definitions. +define LETTER_WIDTH 612 # resolutions at 72 points (300 dpi) +define LETTER_HEIGHT 792 +define LEGAL_WIDTH 612 +define LEGAL_HEIGHT 1008 +define A4_WIDTH 595 +define A4_HEIGHT 850 +define B5_WIDTH 524 +define B5_HEIGHT 765 + +# Font definitions. +define FIXED_WIDTH 54 # width of a courier 9-pt font +define SPACE_WIDTH 30 # width of a 10-point space character +define FONT_SIZE 10 # default font size (points) +define START_CH 32 # width table start character +define END_CH 128 # width table end character +define LINE_HEIGHT 12 # height of a line (points) + +define RESOLUTION 10 # pixel resolution scale factor +define PPI 72 # points-per-inch + +# Default margins. +define TMARGIN 1.25 # default margins (inches) +define BMARGIN 1.0 +define LMARGIN 1.0 +define RMARGIN 1.0 + + +# The main PSIO data structure. +define LEN_PSSTRUCT 45 +define SZ_WORD 128 + +define PS_FD Memi[$1+00] # output file descriptor +define PS_INITIALIZED Memi[$1+01] # prolog written flag +define PS_NUMBER Memi[$1+02] # number pages? +define PS_PNUM Memi[$1+03] # current page number +define PS_JUSTIFY Memi[$1+04] # text justification flag + +define PS_PAGE Memi[$1+06] # page size (letter|legal|a4|b5) +define PS_PWIDTH Memi[$1+07] # page width (points) +define PS_PHEIGHT Memi[$1+08] # page height (points) +define PS_FONTSZ Memi[$1+09] # default font size (points) + +define PS_PLMARGIN Memi[$1+10] # perm. L margin (pixres) +define PS_PRMARGIN Memi[$1+11] # perm. R margin (pixres) +define PS_PTMARGIN Memi[$1+12] # perm. L margin (pixres) +define PS_PBMARGIN Memi[$1+13] # perm. R margin (pixres) +define PS_CLMARGIN Memi[$1+14] # current L margin (pixres) +define PS_CRMARGIN Memi[$1+15] # current R margin (pixres) +define PS_PRMPOS Memi[$1+16] # perm R margin pos (pixres) +define PS_CRMPOS Memi[$1+17] # cur. R margin pos (pixres) +define PS_CURPOS Memi[$1+18] # current page pos (pixres) + +define PS_LMARGIN Memr[P2R($1+20)]# left margin (inches) +define PS_RMARGIN Memr[P2R($1+21)]# right margin (inches) +define PS_TMARGIN Memr[P2R($1+22)]# top margin (inches) +define PS_BMARGIN Memr[P2R($1+23)]# bottom margin (inches) + +define PS_HLE Memi[$1+25] # header left edge tag str +define PS_HCE Memi[$1+26] # header center tag str +define PS_HRE Memi[$1+27] # header right edge tag str +define PS_FLE Memi[$1+28] # footer left edge tag str +define PS_FCE Memi[$1+29] # footer center tag str +define PS_FRE Memi[$1+30] # footer right edge tag str + +define PS_WBPTR Memi[$1+31] # word buffer ptr + +# Runtime descriptor. +define PS_XPOS Memi[$1+35] # current page X position +define PS_YPOS Memi[$1+36] # current page Y position +define PS_CFONT Memi[$1+37] # current font type +define PS_PFONT Memi[$1+38] # previous font +define PS_SFONT Memi[$1+39] # special font (forced) +define PS_CFONT_CH Memi[$1+40] # current font code char +define PS_PFONT_CH Memi[$1+41] # special font code char +define PS_SFONT_CH Memi[$1+42] # special font code char +define PS_LINE_WIDTH Memi[$1+43] # current allowable line (points) + + +# Utility shorthand macros. +define HLEDGE Memc[PS_HLE($1)] # Header tag strings +define HCENTER Memc[PS_HCE($1)] +define HREDGE Memc[PS_HRE($1)] +define FLEDGE Memc[PS_FLE($1)] # Footer tag strings +define FCENTER Memc[PS_FCE($1)] +define FREDGE Memc[PS_FRE($1)] diff --git a/sys/psio/psjustify.x b/sys/psio/psjustify.x new file mode 100644 index 00000000..367cc6fe --- /dev/null +++ b/sys/psio/psjustify.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "psio.h" + + +# PS_RIGHTJUSTIFY -- Right justfify text on the given string and break. + +procedure ps_rightjustify (ps, str) + +pointer ps #I PSIO descriptor +char str[ARB] #I text line + +int mtemp, ps_rjPos() +errchk ps_output + +begin + mtemp = PS_CLMARGIN(ps) + PS_CLMARGIN(ps) = ps_rjpos (ps, str) + call ps_output (ps, str, NO) + PS_CLMARGIN(ps) = mtemp +end + + +# PS_RJPOS -- Get the X position of the right-justified string. + +int procedure ps_rjpos (ps, str) + +pointer ps #I PSIO descriptor +char str[ARB] #I text to justify + +int ps_textwidth() +errchk ps_textwidth + +begin + return (PS_CRMPOS(ps) - ps_textwidth (ps, str)) +end + + +# PS_SET_JUSTIFY -- Set the justification flag. + +procedure ps_setjustify (ps, justify) + +pointer ps #I PSIO descriptor +int justify #I justificaton flag + +begin + PS_JUSTIFY(ps) = justify +end diff --git a/sys/psio/psopen.x b/sys/psio/psopen.x new file mode 100644 index 00000000..289fafcc --- /dev/null +++ b/sys/psio/psopen.x @@ -0,0 +1,107 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "psio.h" + +define PSPAGE_ENV "pspage" + + +# PS_OPEN -- Initialize the PSTOOLS structure. + +pointer procedure ps_open (fd, default_footer) + +int fd #I output file descriptor +int default_footer #I option flags + +pointer ps +int scale +char page[SZ_FNAME], version[SZ_FNAME] +int envgets() +bool streq() +errchk calloc, syserr + +begin + # Allocate the structure. + iferr { + call calloc (ps, LEN_PSSTRUCT, TY_STRUCT) + + call calloc (PS_HLE(ps), SZ_WORD, TY_CHAR) + call calloc (PS_HCE(ps), SZ_WORD, TY_CHAR) + call calloc (PS_HRE(ps), SZ_WORD, TY_CHAR) + call calloc (PS_FLE(ps), SZ_WORD, TY_CHAR) + call calloc (PS_FCE(ps), SZ_WORD, TY_CHAR) + call calloc (PS_FRE(ps), SZ_WORD, TY_CHAR) + + call calloc (PS_WBPTR(ps), SZ_LINE, TY_CHAR) + } then + call syserr (SYS_PSOPEN) + + # Set the output file descriptor + PS_FD(ps) = fd + + # Initialize default values of the struct. + call aclrc (page, SZ_FNAME) + if (envgets (PSPAGE_ENV, page, SZ_FNAME) != 0) { + call strlwr (page) + if (streq (page, "letter")) + call ps_page_size (ps, PAGE_LETTER) + else if (streq (page, "legal")) + call ps_page_size (ps, PAGE_LEGAL) + else if (streq (page, "a4")) + call ps_page_size (ps, PAGE_A4) + else if (streq (page, "b5")) + call ps_page_size (ps, PAGE_B5) + } else + call ps_page_size (ps, PAGE_LETTER) + + PS_FONTSZ(ps) = FONT_SIZE # default font size + PS_JUSTIFY(ps) = YES # justify text? + + # Set the margin values. + scale = PPI * RESOLUTION + PS_PLMARGIN(ps) = LMARGIN * scale # perm. L margin (points) + PS_PRMARGIN(ps) = RMARGIN * scale # perm. R margin (points) + PS_PTMARGIN(ps) = TMARGIN * scale # perm. T margin (points) + PS_PBMARGIN(ps) = BMARGIN * scale # perm. B margin (points) + + PS_CLMARGIN(ps) = PS_PLMARGIN(ps) # current L margin (points) + PS_CRMARGIN(ps) = PS_PRMARGIN(ps) # current R margin (points) + + # Set the right margin in pixel coords. + PS_CRMPOS(ps) = (PS_PWIDTH(ps) * RESOLUTION) - PS_CRMARGIN(ps) + PS_PRMPOS(ps) = PS_CRMPOS(ps) + PS_CURPOS(ps) = PS_PLMARGIN(ps) + + PS_LMARGIN(ps) = LMARGIN # page left margin (inches) + PS_RMARGIN(ps) = RMARGIN # page right margin (inches) + PS_TMARGIN(ps) = TMARGIN # page top margin (inches) + PS_BMARGIN(ps) = BMARGIN # page bottom margin (inches) + + PS_XPOS(ps) = PS_PLMARGIN(ps) + PS_YPOS(ps) = (RESOLUTION * PS_PHEIGHT(ps)) - PS_PTMARGIN(ps) + + PS_CFONT(ps) = F_ROMAN # font initializations + PS_PFONT(ps) = F_ROMAN + PS_SFONT(ps) = NULL + PS_CFONT_CH(ps) = 'R' + PS_SFONT_CH(ps) = EOS + + # Compute the width of the line. + PS_LINE_WIDTH(ps) = (PS_PWIDTH(ps) * RESOLUTION) - + PS_PLMARGIN(ps) - PS_PRMARGIN(ps) + + # Set the footer flags. + PS_PNUM(ps) = 1 + PS_NUMBER(ps) = YES + if (default_footer == YES) { + call aclrc (version, SZ_FNAME) + if (envgets ("version", version, SZ_FNAME) != 0) + call strcpy (version, FLEDGE(ps), SZ_FNAME) + else + call strcpy ("NOAO/IRAF", FLEDGE(ps), SZ_WORD) + call strcpy (" ", FCENTER(ps), SZ_FNAME) + } + + return (ps) +end diff --git a/sys/psio/psoutput.x b/sys/psio/psoutput.x new file mode 100644 index 00000000..e94cd8c9 --- /dev/null +++ b/sys/psio/psoutput.x @@ -0,0 +1,199 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "psio.h" + + +# PS_OUTPUT -- Output the given line and break, fill if requested. + +procedure ps_output (ps, str, fill_flag) + +pointer ps #I PSIO descriptor +char str[ARB] #I text string to write +int fill_flag #I fill line flag + +char ch, word[SZ_FNAME] +int fd, last_nscan, ip, op, curpos +int i, spacing, nspaces, nwords, ngaps, twidth, len +int ps_textwidth(), strmatch(), strlen() +errchk ps_wrtblock, ps_textwidth + +define break_ 99 + +begin + # Idiot check. + if (str[1] == EOS) + return + + if (PS_INITIALIZED(ps) == NO) + call ps_write_prolog (ps) + + # Initialize. + fd = PS_FD(ps) + curpos = PS_CLMARGIN(ps) + last_nscan = 0 + + # Trim trailing whitespace or newlines. + len = strlen (str) + for ( ; IS_WHITE(str[len]) || str[len] == '\n'; len=len-1) + str[len] = EOS + + if (fill_flag == NO && strmatch(str, "\\\\f?") != 0) { + # No font changes or filling, just dump it as one string. + call ps_wrtblock (ps, curpos, str) + return + } + + # Get the number of words in the line. + nspaces = 0 + for (ip=1; str[ip] != EOS; ip=ip+1) { + if (IS_WHITE(str[ip]) && !IS_WHITE(str[ip+1])) + nspaces = nspaces + 1 + } + nwords = nspaces + 1 + ngaps = max (1, nspaces) + twidth = ps_textwidth (ps, str) + + # Calculate the inter-word spacing. + if (PS_CFONT(ps) == F_TELETYPE) + spacing = FIXED_WIDTH + else + spacing = SPACE_WIDTH + + if (fill_flag == YES) + spacing = spacing + (PS_LINE_WIDTH(ps) - twidth) / ngaps + + # Set the base font for the line + if (PS_SFONT(ps) != NULL) + ch = PS_SFONT_CH(ps) + else + ch = PS_CFONT_CH(ps) + call fprintf (fd, "%c\n") + call pargc (ch) + + # Process the words on the line. + ip = 1 + do i = 1, nwords { + + if (str[ip] == EOS) + break + + # Collect chars up to the end of the word. + for (op=1; str[ip] != EOS && str[ip] != ' '; op=op+1) { + word[op] = str[ip] + ip = ip + 1 + } + word[op] = EOS + twidth = ps_textwidth (ps, word) + + # if we're filling, force the right-justification of the last + # word to cover for any roundoff in the spacing computation. + if (fill_flag == YES && i == nwords) + curpos = PS_CRMPOS(ps) - twidth + + # Write it out, handling font changes. + if (op > 1) + call ps_wrtblock (ps, curpos, word) + + # Increment the position for the next word. + curpos = curpos + twidth + + # Increment for the spaces between words. + for ( ; IS_WHITE(str[ip]) && str[ip] != EOS; ip=ip+1) + curpos = curpos + spacing + } +end + + +# PS_WRTBLOCK -- Write a block of text at the given position. We escape the +# parenthesis here since they were needed in computing the width. + +procedure ps_wrtblock (ps, curpos, str) + +pointer ps #I PSIO descriptor +int curpos #I X position of text +char str[ARB] #I string to write + +char word[SZ_WORD], line[SZ_LINE] +int i, fd, ip, pos, st, en, gstrmatch() +int ps_textwidth(), ps_getfont() +errchk ps_setfont, ps_textwidth + +begin + fd = PS_FD(ps) + + call aclrc (word, SZ_WORD) + call aclrc (line, SZ_LINE) + + if (gstrmatch (str, "\\\\f?", st, en) == 0) { + # No font changes so just output the word. + call ps_escText (str, line, SZ_LINE) + call fprintf (fd, "%d (%s) S\n") + call pargi (curpos) + call pargstr (line) + + } else { + # We have a font change. Collect all chars up to the font change + # and output as an atom. Change the font, and repeat until we + # use up the string. + + pos = curpos + i = 1 + for (ip=1; str[ip] != EOS; ip=ip+1) { + if (str[ip] == '\\' && str[ip+1] == 'f') { + if (word[1] != EOS) { + word[i] = EOS + call ps_esctext (word, line, SZ_LINE) + call fprintf (fd, "%d (%s) S\n") + call pargi (pos) + call pargstr (line) + pos = pos + ps_textwidth (ps, word) + } + iferr (call ps_setfont (ps, ps_getfont(ps, str[ip+2]))) + break; + ip = ip + 2 + i = 1 + word[1] = EOS + } else { + word[i] = str[ip] + i = i + 1 + } + } + word[i] = EOS + + if (word[1] != EOS) { + call ps_esctext (word, line, SZ_LINE) + call fprintf (fd, "%d (%s) S\n") + call pargi (pos) + call pargstr (line) + pos = pos + ps_textwidth (ps, word) + } + } +end + + +# PS_ESCTEXT -- Escape the parenthesis in a text string. + +procedure ps_esctext (in, out, maxch) + +char in[ARB] #I input text +char out[ARB] #O output text +int maxch #I max characters + +int ip, op + +begin + ip = 1 + op = 1 + while (in[ip] != EOS) { + if (in[ip] == '(' || in[ip] == ')' || in[ip] == '\\') { + out[op] = '\\' + op = op + 1 + } + out[op] = in[ip] + op = op + 1 + ip = ip + 1 + } + out[op] = EOS +end diff --git a/sys/psio/pspos.x b/sys/psio/pspos.x new file mode 100644 index 00000000..55a918c1 --- /dev/null +++ b/sys/psio/pspos.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "psio.h" + + +# PS_XPOS -- Set current X position on page. + +procedure ps_xpos (ps, xpos) + +pointer ps #I PSIO descriptor +int xpos #I position + +begin + PS_XPOS(ps) = xpos + call fprintf (PS_FD(ps), "%d H\n") + call pargi (PS_XPOS(ps)) +end + + +# PS_YPOS -- Set current Y position on page. + +procedure ps_ypos (ps, ypos) + +pointer ps #I PSIO descriptor +int ypos #I position + +begin + PS_YPOS(ps) = ypos + call fprintf (PS_FD(ps), "%d V\n") + call pargi (PS_YPOS(ps)) +end + + +# PS_INDENT -- Set current left margin defined as a number of fixed width +# characters from the permanent left margin. + +procedure ps_indent (ps, nchars) + +pointer ps #I PSIO descriptor +int nchars #I position + +begin + PS_CLMARGIN(ps) = PS_PLMARGIN(ps) + max(0,nchars) * FIXED_WIDTH + PS_LINE_WIDTH(ps) = (PS_PWIDTH(ps) * RESOLUTION) - + PS_CLMARGIN(ps) - PS_PRMARGIN(ps) +end + + +# PS_TESTPAGE -- Test whether we are within the given number of lines from +# the bottom of the page, if so break. + +procedure ps_testpage (ps, nlines) + +pointer ps #I PSIO descriptor +int nlines #I position + +int nleft + +begin + nleft = nlines * LINE_HEIGHT * RESOLUTION + if ((PS_YPOS(ps) - PS_PBMARGIN(ps)) < nleft) + call ps_pagebreak (ps) +end diff --git a/sys/psio/psprolog.x b/sys/psio/psprolog.x new file mode 100644 index 00000000..79ed63c1 --- /dev/null +++ b/sys/psio/psprolog.x @@ -0,0 +1,189 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "psio.h" + + +# PS_WRITE_PROLOG -- Write the PS prolog given the current postscript struct. +# This initializes a flag keeping other changes from taking effect once +# this is called. + +procedure ps_write_prolog (ps) + +pointer ps #I PSIO descriptor + +int fd, sz_font +char buf[SZ_LINE] + +int itoc(), ps_centerPos(), ps_rjPos() +long clktime() + +begin + fd = PS_FD(ps) + call cnvtime (clktime(long(0)), buf, SZ_LINE) + + # Write the header stuff. + call fprintf (fd, "%%!PS-Adobe-1.0\n") + call fprintf (fd, "%%%%Creator: IRAF PostScript Translator\n") + call fprintf (fd, "%%%%CreationDate: %s\n") ; call pargstr (buf) + call fprintf (fd, "%%%%Pages: (atend)\n") + call fprintf (fd, "%%%%DocumentFonts: (atend)\n") + call fprintf (fd, "%%%%EndComments\n") + call fprintf (fd, "%%%%BeginProlog\n") + + + # Initialize page values. + call fprintf (fd, + "/inch\t{ 72 mul \t} def\t\t\t%% 72 points per inch\n") + call fprintf (fd, + "/PL \t{ %d \t\t} def\t\t\t%% set page height\n") + call pargi (PS_PHEIGHT(ps)) + call fprintf (fd, + "/FtrY\t{ 20 \t\t} def\t\t\t%% footer Y position\n") + call fprintf (fd, + "/HdrY\t{ PL 40 sub \t} def\t\t\t%% header Y position\n") + call fprintf (fd, + "/xOrg\t%d \t def\t\t\t\t%% left margin (inches)\n") + call pargi (PS_PLMARGIN(ps)) + call fprintf (fd, + "/yOrg\t%d \t def\t\t\t\t%% top margin (inches)\n") + call pargi (PS_PTMARGIN(ps)) + call fprintf (fd, + "/Page\t0 \t def\t\t\t\t%% page number\n") + call fprintf (fd, + "/pnum\t4 string def\t\t\t\t%% sizeof pnum cvs buffer\n") + call fprintf (fd, + "/res\t%4.2f\tdef\t\t\t\t%% pixel resolution factor\n") + call pargi (RESOLUTION) + call fprintf (fd, "\n") + + + # Create the font array to be used. + sz_font = PS_FONTSZ(ps) + call fprintf (fd, "/FS \t{ findfont exch scalefont } bind def ") + call fprintf (fd, "\t%% find and scale a font\n") + call fprintf (fd, "/Fonts [\t\t\t\t\t%% create an array of fonts\n") + call fprintf (fd, "\t%d /Times-Roman FS\n") ; call pargi (sz_font) + call fprintf (fd, "\t%d /Times-Bold FS\n") ; call pargi (sz_font) + call fprintf (fd, "\t%d /Times-Italic FS\n") ; call pargi (sz_font) + call fprintf (fd, "\t%d /Courier FS\n") ; call pargi (sz_font-1) + call fprintf (fd, "\t11 /Times-Bold FS\n") + if (sz_font >= 6 && sz_font <= 10) + call pargi (sz_font+2) + else + call pargi (sz_font) + call fprintf (fd, "] def\n") + + # Set the fonts. + call fprintf (fd, + "/SF { setfont \t} bind def\n") + call fprintf (fd, + "/R { Fonts 0 get SF\t} bind def\t\t%% roman font\n") + call fprintf (fd, + "/B { Fonts 1 get SF\t} bind def\t\t%% bold font\n") + call fprintf (fd, + "/I { Fonts 2 get SF\t} bind def\t\t%% italic font\n") + call fprintf (fd, + "/T { Fonts 3 get SF\t} bind def\t\t%% teletype font\n") + call fprintf (fd, + "/HD { Fonts 4 get SF\t} bind def\t\t%% header font\n") + + # Define line motion bindings. + call fprintf (fd, "/H { res div\n") + call fprintf (fd, "\tcurrentpoint exch pop\n") + call fprintf (fd, "\tmoveto \t\t} def\t\t\t%% horizontal position\n") + call fprintf (fd, "/V { res div\n") + call fprintf (fd, "\tcurrentpoint pop exch\n") + call fprintf (fd, "\tmoveto \t\t} def\t\t\t%% vertical position\n") + call fprintf (fd, "/S { exch H show\t} bind def\t\t%% show\n") + + + # Write the page header routine. + call fprintf (fd, "/BP {\t\t\t\t\t\t%% Begin page (header).\n") + if (HLEDGE(ps) != EOS) { + call fprintf (fd, "\txOrg %d div HdrY moveto B (%s) show\n") + call pargi (RESOLUTION) + call pargstr (HLEDGE(ps)) + } + if (HCENTER(ps) != EOS) { + call fprintf (fd, "\t%d %d div HdrY moveto B (%s) show\n") + call pargi (ps_centerPos(ps, HCENTER(ps))) + call pargi (RESOLUTION) + call pargstr (HCENTER(ps)) + } + if (HREDGE(ps) != EOS) { + call fprintf (fd, "\t%d %d div HdrY moveto B (%s) show\n") + call pargi (ps_rjPos(ps, HREDGE(ps))) + call pargi (RESOLUTION) + call pargstr (HREDGE(ps)) + } + call fprintf (fd, "\txOrg yOrg moveto\n") + call fprintf (fd, "} bind def\n") + + + # Write the page footer routine. + call fprintf (fd, "/EP {\t\t\t\t\t\t%% End page (footer).\n") + call fprintf (fd, + "\t/Page Page 1 add def\t\t\t%% increment page number\n") + if (FLEDGE(ps) != EOS) { + call fprintf (fd, "\txOrg %d div FtrY moveto R (%s) show\n") + call pargi (RESOLUTION) + call pargstr (FLEDGE(ps)) + } + if (FCENTER(ps) != EOS) { + call fprintf (fd, "\t%d %d div FtrY moveto R (%s) show\n") + call pargi (ps_centerPos(ps, FLEDGE(ps))) + call pargi (RESOLUTION) + call pargstr (FCENTER(ps)) + } + if (PS_NUMBER(ps) == YES) { + if (itoc (PS_PNUM(ps), buf, SZ_LINE) != 0) { + call fprintf (fd, + "\t%d %d div FtrY moveto R Page pnum cvs show\n") + call pargi (ps_rjPos(ps, buf)) + call pargi (RESOLUTION) + } + } else if (FREDGE(ps) != EOS) { + call fprintf (fd, "\t%d %d div FtrY moveto R (%s) show\n") + call pargi (ps_rjPos(ps, FREDGE(ps))) + call pargi (RESOLUTION) + call pargstr (FREDGE(ps)) + } + call fprintf (fd, "\tshowpage\t\t\t\t%% show the page\n") + call fprintf (fd, "} bind def\n") + + + # Finish the prolog header and flush the output. + call fprintf (fd, "%%%%EndProlog\n") + call fprintf (fd, "%%%%Page: 1 1\n") + call fprintf (fd, "%%----------\n") + call fprintf (fd, "initgraphics\n") + call fprintf (fd, "R\n") + call fprintf (fd, "BP\n") + call flush (fd) + + # Set the flag indicating we've written the prolog + PS_INITIALIZED(ps) = YES +end + + +# PS_TRAILER - Write the postscript trailer. + +procedure ps_trailer (ps) + +pointer ps #I PSIO descriptor + +int fd + +begin + fd = PS_FD(ps) + + call fprintf (fd, "EP\n") + call fprintf (fd, "%% end of document\n") + call fprintf (fd, "%%%%Trailer\n") + call fprintf (fd, "%%%%DocumentFonts: ") + call fprintf (fd, "Times-Roman Times-Bold Times-Italic Courier\n") + call fprintf (fd, "%%%%Pages: %d\n") + call pargi(PS_PNUM(ps)) + + call flush (fd) +end diff --git a/sys/psio/pssetup.x b/sys/psio/pssetup.x new file mode 100644 index 00000000..3afe6644 --- /dev/null +++ b/sys/psio/pssetup.x @@ -0,0 +1,132 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "psio.h" + + +# PS_PAGE_SIZE -- Set the page size (letter|legal|a4|b5). + +procedure ps_page_size (ps, page) + +pointer ps #I PSIO descriptor +int page #I page type + +begin + if (PS_INITIALIZED(ps) == YES) + return + + if (page >= PAGE_LETTER && page <= PAGE_B5) { + switch (page) { + case PAGE_LETTER: + PS_PAGE(ps) = PAGE_LETTER + PS_PWIDTH(ps) = LETTER_WIDTH + PS_PHEIGHT(ps) = LETTER_HEIGHT + case PAGE_LEGAL: + PS_PAGE(ps) = PAGE_LEGAL + PS_PWIDTH(ps) = LEGAL_WIDTH + PS_PHEIGHT(ps) = LEGAL_HEIGHT + case PAGE_A4: + PS_PAGE(ps) = PAGE_A4 + PS_PWIDTH(ps) = A4_WIDTH + PS_PHEIGHT(ps) = A4_HEIGHT + case PAGE_B5: + PS_PAGE(ps) = PAGE_B5 + PS_PWIDTH(ps) = B5_WIDTH + PS_PHEIGHT(ps) = B5_HEIGHT + default: + call eprintf ( + "Warning (PSIO): attempt to set illegal page size.") + } + } +end + + +# PS_FONT_SIZE -- Set the default font size to use (default = 10 points). + +procedure ps_font_size (ps, font_size) + +pointer ps #I PSIO descriptor +int font_size #I default font size + +begin + if (PS_INITIALIZED(ps) == YES) + return + + PS_FONTSZ(ps) = font_size +end + + +# PS_HEADER -- Set the header tag strings. + +procedure ps_header (ps, ledge, center, redge) + +pointer ps #I PSIO descriptor +char ledge[ARB] #I left edge text +char center[ARB] #I center text +char redge[ARB] #I right edge text + +begin + if (PS_INITIALIZED(ps) == YES) + return + + if (ledge[1] != EOS) + call strcpy (ledge, HLEDGE(ps), SZ_WORD) + if (center[1] != EOS) + call strcpy (center, HCENTER(ps), SZ_WORD) + if (redge[1] != EOS) + call strcpy (redge, HREDGE(ps), SZ_WORD) +end + + +# PS_FOOTER -- Set the footer tag strings. + +procedure ps_footer (ps, ledge, center, redge) + +pointer ps #I PSIO descriptor +char ledge[ARB] #I left edge text +char center[ARB] #I center text +char redge[ARB] #I right edge text + +begin + if (PS_INITIALIZED(ps) == YES) + return + + if (ledge[1] != EOS) + call strcpy (ledge, FLEDGE(ps), SZ_WORD) + if (center[1] != EOS) + call strcpy (center, FCENTER(ps), SZ_WORD) + if (redge[1] != EOS) { + call strcpy (redge, FREDGE(ps), SZ_WORD) + PS_NUMBER(ps) = NO + } +end + + +# PS_SETMARGINS -- Set the permanent page margins (in inches). + +procedure ps_setmargins (ps, left, right, top, bottom) + +pointer ps #I PSIO descriptor +real left, right, top, bottom #I margins + +int scale + +begin + if (PS_INITIALIZED(ps) == YES) + return + + PS_LMARGIN(ps) = left + PS_RMARGIN(ps) = right + PS_TMARGIN(ps) = top + PS_BMARGIN(ps) = bottom + + # Set the margin values. + scale = PPI * RESOLUTION + PS_PLMARGIN(ps) = left * scale # perm. L margin (points) + PS_PRMARGIN(ps) = right * scale # perm. R margin (points) + PS_PTMARGIN(ps) = top * scale # perm. T margin (points) + PS_PBMARGIN(ps) = bottom * scale # perm. B margin (points) + + PS_CLMARGIN(ps) = PS_PLMARGIN(ps) # current L margin (points) + PS_CRMARGIN(ps) = PS_PRMARGIN(ps) # current R margin (points) +end diff --git a/sys/psio/pswidth.x b/sys/psio/pswidth.x new file mode 100644 index 00000000..e102f37c --- /dev/null +++ b/sys/psio/pswidth.x @@ -0,0 +1,76 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "psio.h" + + +# PS_TEXTWIDTH -- Return the length in PS pixels of the given string. We +# handle font changes here and keep track of the current and previous font. + +int procedure ps_textwidth (ps, str) + +pointer ps #I package pointer +char str[ARB] #I string to check + +int ip, width, f_current +int ps_getfont(), ps_chwidth() +errchk ps_chwidth + +begin + # Initialize. + width = 0 + f_current = PS_CFONT(ps) + + # Now process the word, computing the width of each character and + # returning the total width. Handle inline font changes. + + for (ip=1; str[ip] != EOS; ip=ip+1) { + + # Handle any font changes. + if (str[ip] == '\\' && str[ip+1] == 'f') { + f_current = ps_getfont (ps, str[ip+2]) + ip = ip + 2 + } else if ((str[ip] == '\\' && str[ip+1] == '(') || + (str[ip] == '\\' && str[ip+1] == ')')) { + # Skip over escaped parens in width computation. + ip = ip + 1 + width = width + ps_chwidth (str[ip], f_current) + } else + width = width + ps_chwidth (str[ip], f_current) + } + + return (width) +end + + +# PS_CHWIDTH -- Given the font type and a character return the width. + +int procedure ps_chwidth (ch, font) + +char ch #I character +int font #I font type character + +errchk syserr +include "font.com" + +begin + if (ch < START_CH || ch > END_CH) + return (0) + + switch (font) { + case F_ROMAN: + return (roman[(ch-START_CH+1)]) + case F_BOLD: + return (bold[(ch-START_CH+1)]) + case F_ITALIC: + return (italic[(ch-START_CH+1)]) + case F_TELETYPE: + return (FIXED_WIDTH) + case F_PREVIOUS: + return (FIXED_WIDTH) + default: + call syserr (SYS_PSFONT) + } +end diff --git a/sys/psio/zzdebug.x b/sys/psio/zzdebug.x new file mode 100644 index 00000000..97e78aa7 --- /dev/null +++ b/sys/psio/zzdebug.x @@ -0,0 +1,77 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + + +task pstest = t_pstest + +# PSTEST -- Test the PSIO package. This test program pretty-prints a file +# with a header message and page number suitable for output to a printer. + +procedure t_pstest() + +pointer ps +int fd, ip, op +char fname[SZ_FNAME], date[SZ_TIME], line[SZ_LINE], outline[SZ_LINE] + +pointer ps_open() +int open(), getline() +long clktime() +errchk open, close, getline, ps_setfont, ps_open + +begin + # Get the file to format and date string. + call clgstr ("filename", fname, SZ_FNAME) + call cnvtime (clktime(0), date, SZ_TIME) + + # Open the file. + iferr (fd = open (fname, READ_ONLY, TEXT_FILE)) + call error (1, "Error opening file.") + + # Initialize the PSIO interface. + iferr (ps = ps_open (STDOUT, NO)) + call error (1, "Error opening PSIO interface.") + call ps_header (ps, fname, "NOAO/IRAF", date) + call ps_footer (ps, "PSIO Test Page", "", "") + call ps_write_prolog (ps) + + # Output the text in a fixed-width font. + call ps_setfont (ps, F_TELETYPE) + + call ps_linebreak (ps, NO) + while (getline (fd, line) != EOF) { + + if (line[1] == EOS) { + # Simply break on a newline. + call ps_linebreak (ps, NO) + + } else { + # Detab the line to preserve the spacing. + ip = 1 + op = 1 + while (line[ip] != EOS && op <= SZ_LINE) { + if (line[ip] == '\t') { + repeat { + outline[op] = ' ' + op = op + 1 + } until (mod(op,8) == 1) + ip = ip + 1 + } else { + outline[op] = line [ip] + ip = ip + 1 + op = op + 1 + } + } + outline[op] = EOS + + # Output the line and a newline break. + call ps_output (ps, outline, NO) + call ps_newline (ps) + } + } + call close (fd) # close the file + + # Close the PSIO interface, this writes the PS trailer. + call ps_close (ps) +end diff --git a/sys/qpoe/QPDEFS b/sys/qpoe/QPDEFS new file mode 100644 index 00000000..863337fd --- /dev/null +++ b/sys/qpoe/QPDEFS @@ -0,0 +1,60 @@ +# QPDEFS -- SAMPLE global macro definition file for QPOE. This should be +# modified (and a copy placed somewhere outside the QPOE sources) to establish +# the defaults for a given site. Each user may also have their own private +# copy of this file. The environment variable `qmfiles' defines the list of +# QPDEFS files to be read to define the runtime environment for QPOE. + +# Interface parameters (defaults shown). +#set bucketlen 1024 +#set cachesize 8 +#set indexlen 100 +#set maxlfiles 128 +#set pagesize 512 +#set sbufsize 2048 +#set stablen 2048 +#set progbuflen 1024 +#set databuflen 4096 +#set maxfrlutlen 8192 +#set maxrrlutlen 1024 +#set lutminranges 5 +#set lutscale 15 +#set maxpushback 8192 +#set blockfactor 8 +#set optbufsize 524288 +#set debuglevel 0 + +set lutscale 32 +set blockfactor 4 + +# The event structure used in qpoe$zzdebug.x for s/w testing. +define evfields {s:x,s:y,s,s,d,s,s} +define x s0 +define y s2 +define pha s4 +define pi s6 +define time d8 +define dx s16 +define dy s18 + +# An alias. +define t time + +# Some test filters. +define box x=(400:800),y=(200:400) +define dbox dx=(400:800),dy=(200:400) +define eventimes (30:31,32:33,34:35,36:37,38:39,40:41,42:43) +define oddtimes (31:32,33:34,35:36,37:38,39:40,41:42,43:44) +define alltimes (eventimes,oddtimes) + +# The following is for integer LUT tests; a bitwise test would be more +# suitable for testing for an even integer. + +define even (2,4,6,8,10,12,14,16,18,20,22,24,26,28,30) + +# Test argument substitution in macros. +define eq $1=($2) +define ne $1=!($2) +define le $1=(:$2) +define lt $1=(!($2:)) +define ge $1=($2:) +define gt $1=(!(:$2)) diff --git a/sys/qpoe/QPOE.hlp b/sys/qpoe/QPOE.hlp new file mode 100644 index 00000000..cbb0ee5b --- /dev/null +++ b/sys/qpoe/QPOE.hlp @@ -0,0 +1,1201 @@ +.help QPOE Jun90 "Quick POE Design" +.ce +\fBQuick-POE (Position Ordered Event File) Interface Design\fR +.ce +Doug Tody +.ce +July, 1988 + +.NH +Introduction + + The POE (Position Ordered Event file) facility is an interface and file +structure used to store and access the event (photon) lists generated +by event counting detectors. Each event is described by a unique position, +time, energy, and possibly other parameters (e.g., polarization, position in +other coordinate systems, or instrument related parameters). In the case of +an imaging event counting detector, the "image" generated consists of this list +of discrete events, rather than the regular matrix produced by a conventional +sampling detector. Both types of detectors are fundamental to astronomy. + +The POE interface is a stand alone interface built upon the standard VOS +interfaces DFIO (in a future release), PLIO, SYMTAB, FIO, and other lower +level interfaces. The POE interface may be called directly by applications +code to create and access POE datafiles, for event file specific processing. +In addition, an IMIO image kernel is provided so that POE files may be +accessed as (read only) images, allowing existing IRAF image tasks to be +used to access POE files. The main function of the POE image kernel is to +filter and sample the event list in real time, returning a conventional +sampled grid (image matrix) to the high level applications code. +The parameters controlling the filtering and sampling operations may be +specified by the user when the image (POE file) is accessed, making runtime +filtering of events possible in connection with any general image processing +task. + +.NH 2 +Important Concepts + + The primary object dealt with by this interface is the \fIevent file\fR, +consisting of a free format \fIfile header\fR and the main \fIevent list\fR. +The event list is a collection of \fIevent structures\fR, e.g., photons +hitting an imaging detector during the period of observation recorded by the +event file. Each event is characterized by a standard set of attributes such +as the position of the event in detector, sky, or other coordinates, the time +at which the event was recorded, the energy of the event, and so on, plus +optionally additional instrument dependent attributes (in general the event +structure cannot be fixed, and the nomenclature may vary depending upon the +science being performed). + +The events may appear in the event list in any order, but since most access +to image data tends to be spatial in nature, access will be most efficient if +the event list is position ordered. This is the convention chosen by QPOE +and hence the name \fIpoe\fRfile, or \fIp\fRosition \fIo\fRrdered \fIe\fRvent +file. An important alternative ordering is time ordering, which preserves +the order in which the events were originally recorded, but which requires +a complete scan of the event list to accumulate the events in a region of +interest during analysis. There are cases where time ordering might be +preferable to position ordering, e.g., for time series analysis of a long +observation. + +Of fundamental importance to the analysis of data from event counting +detectors is the concept of \fIfiltering\fR. It is in the nature of event +counting detectors that they are often used to observe very faint objects +for very long periods of integration. The total amount of data (number of +events) may be limited, so one wants to preserve all events, but since the +quality of the data may vary both with time and with position, it is common +to want to reject a portion of the data. Conversely, the analysis being +performed may require one to examine only a portion of the data, e.g., only +events with a certain range of energies or arrival times, occurring within a +given region of the image. Often the analysis will be repeated many times +wtih different filters. + +Hence, most analysis of event counting data typically involves both +\fIrejection\fR and \fIregion of interest\fR filtering. Rejection filtering +depends mostly upon the data itself, hence the rejection filter for an image +is a part of the image and should be in effect by default whenever the image +is accessed, although we would like to physically record all data and be able +to change the rejection filter either temporarily or indefinitely if desired. +Region of interest filtering, on the other hand, depends upon the scientific +analysis being performed rather than upon the data, hence is highly variable +and should be controlled by the user, independently of the data. + +.NH 2 +Interface Requirements + + Given the description of the problem to be solved presented in the previous +section, we can make the following observations regarding the POE interface: +.ls 4 o +A flexible binary file header supporting both scalar and variable length vector +fields is essential. Examples of vector fields include the aspect and temporal +records (actually arrays of records, or subtables), the processing history +(probably stored as a single variable length text buffer), and the rejection +and region of interest filters (PLIO external format byte sequences stored as +opaque binary arrays). +.le +.ls o +In the general case the details of the event structure depend upon the +instrument for which data is being stored. The minimum requirement is that +the event structure consist of a set of standard fields (x, y, time, energy) +followed by a variable length, instrument dependent area (hence the size of +the event structure, while fixed for a given datafile, should be allowed to +vary depending upon the data). Ideally all fields should be named and +accessible for filtering, the names chosen should be variables rather than +constants, and the set of fields used to describe an event should be allowed +to vary depending upon the data. +.le +.ls o +Runtime access to the event list, including event-attribute and spatial +filtering, should be as efficient as possible since this is likely to be +by far the most time consuming part of the interface. Header access +efficiency is much less important and is not expected to be a problem. +.le +.ls o +For most efficient access the event list should be stored sorted upon some +primary key, with an index maintained by the interface for that key, +and used for efficient retrieval. The minimum requirement is that the primary +or sort key be the Y coordinate (corresponding to image lines). Ideally it +should be possible for the sort key to be any field of the event structure, +or any combination of fields (e.g., Y+X, or T). Ideally the interface itself +should be responsible for maintaining the event list in sort order; this is +not a requirement since writing to event files is much less common than +reading. Ideally it should be possible for the event list to be unordered, +and it should be possible to transparently access the event list regardless +of the ordering. +.le +.ls o +Rejection filtering is typically required by the data, yet we wish to retain +all the data and be able to override or replace the default rejection mask. +The rejection filter is logically associated with the data and should be +stored with the data. The minimum requirement is for the interface to be able +to store all the data plus the rejection mask, and be able to return only +the "good" data at runtime. The interface is not required to perform rejection +filtering at runtime, although it would be desirable to be able to do so if +the efficiency penalty were not too great. Alternatively, the event list +could be prefiltered, and the "good" and "bad" events stored in different +places in the datafile, requiring that the entire file be rebuilt to change +the rejection filter. +.le +.ls o +Region of interest filtering is a common operation for event data, and can be +difficult to implement efficiently, hence should be supported directly by the +interface. At a minimum it should be possible to filter events by defining a +range of acceptable or unacceptable values for each of some subset of the event +attributes (e.g., energy or time). Ideally it should also be possible to +specify an arbitrarily long list of ranges of acceptable values. Ideally +spatial filtering should be supported as well; this is required for rejection +filtering, but is at most a desirable option for spatial region of interest +filtering (there is nothing about spatial filtering which is unique to event +data, hence it might be more appropriate to implement it at a higher level, +but on the other hand it might be more efficient to implement it at the event +i/o level since the event list is position ordered and can be very large). +.le +.ls o +It should be possible to specify the various filtering options both +transparently to applications programs (via a symbolic expression passed +into the interface by the user as part of the file specification), +or procedurally, via \fIset\fR-parameter calls issued by the client program. +.le + +The above issues need to be adequately addressed in order to have a useful +interface. In the longer term there are many other considerations, e.g., +it is also desirable for the data format to be machine independent, and the +data format should be flexible, to accommodate the inevitable evolutionary +revisions as well as to accommodate data from a variety of instruments or +projects. The event files can be very large, hence efficiency is a major +consideration for event i/o and filtering. + +.NH +The QPOE Interface +.NH 2 +Implementation Strategy + + A two step operation is planned for implementing the POE interface within +IRAF. The first step is the so called quick-POE interface. The objective of +quick-POE is to provide the necessary functionality so that applications +development can proceed immediately, without waiting for the general interface +to be developed. Once quick-POE is in place development of the fully general +POE interface can proceed at a more leisurely pace consistent with the plan to +provide most of the functionality of the generalized POE interface with other +standard IRAF facilities currently under development, most notably the datafile +i/o interface (DFIO), a general purpose binary file record manager to be used +in the new images structures project and elsewhere in IRAF. + +The main facilities provided by POE are for access to general header fields, +access to the variable length aspect and temporal records, event list i/o, +and event filtering. The POE header is a type of record, and the aspect and +temporal "records" are arrays of records (tables), as is the event list itself. +Any record access problem involving large records commonly involves the +related problems of indexing and selection based on a user supplied predicate +(boolean expression or filter in our case). + +In the general case, we would like the POE interface to be able to support +data from a variety of detectors or instruments, not only those used in high +energy astrophysics but those used in optical and radio observatories as well, +hence the details of the data structures must be allowed to vary without +affecting the interface itself. Ideally the POE files should be maintained +in a machine independent format, and the applications programs using POE +should not be affected by changes to the data format, and indeed should be +usable directly with any of several similar data formats, or with data formats +that evolve over time. + +All these observations lead us to conclude that a general implementation of +the POE interface has much in common with the general record access problem, +hence the association of POE with DFIO. Quick-POE will provide much the same +functionality at the applications level but will be less general, i.e., the +binary record structures as seen by applications will be mapped directly onto +external storage (the main contribution of DFIO is data independence and +flexibility). This means that initially the applications will be tied to +a specific format datafile, changes to applications structures will require +reformatting the data, and the datafiles will probably be machine dependent. + +This approach would be unacceptable in the long run, as the need arises to +support a variety of instruments, but is viable for initial applications +development provided a DFIO based implementation eventually replaces the +initial interface. There should be little difference in terms of functionality +and efficiency between QPOE and POE; in fact QPOE may have the edge over POE +in terms of efficiency, since it will be less general. It is likely that +applications developed for QPOE will be usable with POE with few if any +changes, e.g., by reimplementing QPOE as a layer on top of the more general +POE interface. The main motivation for implementing a DFIO based POE will be +to provide increased data independence, a machine independent binary data +format, and the ability to support a variety of instruments with a single +interface. + +Although some throw away code will have to be written to implement the QPOE +interface, most of the complexity of the interface lies in the event filtering +code, which should be reusable in the final interface. Low level, custom +(non-DFIO) selection code is required for POE due to the unusual requirements +for region and temporal filtering, and the potentially extremely high data +volume (>10**6 event records). This implies that DFIO itself will have to be +a layered interface, supporting low level access to the packed data records +for applications with unusual efficiency requirements (it will be). Finally, +it is already evident that the low level file manager required by QPOE has +much in common with the access method code planned for DFIO, hence can serve +as a prototype for the DFIO file manager. + +The remainder of this document will deal only with the details of the +QPOE interface. The DFIO interface has already been specified, +including a sketch of a data definition for a POE file. See \fIThe IRAF +Datafile I/O Interface\fR, February 1988. The region filtering +code in POE will make use of the Pixel List I/O (PLIO) interface, described +in \fIThe IRAF Pixel List Package\fR, February 1988. The latter interface +has already been implemented, as have all other interfaces (e.g., SYMTAB) +required by QPOE. + +.NH 2 +Architecture + + The architecture of IRAF as it pertains to the QPOE (and POE) interface +is summarized in the figure below. + +.ks +.nf + IMIO + IKI + IK-POE + POE + PLIO + [DFIO] + SYMTAB + FIO +.fi +.ke + +As indicated in the figure, QPOE depends most heavily on the VOS interfaces +PLIO (pixel list i/o), used for spatial filtering, SYMTAB (the general symbol +table package), used to manage the file header and aspect and temporal records, +and FIO (file i/o), used to access the binary file in +which the QPOE data is stored (low level, unbuffered asynchronous i/o is +used by the QPOE file manager). The QPOE interface is accessed both directly +by applications code, and by the IMIO interface via an image kernel, shown +as IK-POE in the figure. IK-POE and QPOE comprise the code to be written to +implement the QPOE interface. + +The QPOE interface consists of the POE file itself, a binary data structure +[largely] private to the QPOE interface, and a set of procedures for creating, +writing into, and reading from POE files. The procedures fall into several +categories, i.e., +.ls 4 +.ls o +General QPOE file management procedures. These include routines for creating, +deleting, renaming, opening, and closing POE files, plus set/stat routines +for setting and querying the file parameters and interface options. +.le +.ls o +General header access procedures. These include a conventional set of keyword +driven typed scalar get/put routines, plus get/put routines for accessing +variable length typed and opaque binary arrays (e.g., history records and the +aspect and temporal records). +.le +.ls o +Event i/o procedures. These are routines for initially preparing and +subsequently reading (sequentially with seek) the main event list, e.g., +the raw "get next photon" routine. +.le +.ls o +The selection subpackage. Included are routines for opening and incrementally +compiling a user supplied selection predicate (filter) input as a formatted +text string, and for testing individual event records to see whether they +satisfy the given expression. +.le +.le + +All binary data structures other than simple scalar variables, e.g., the +aspect and temporal records and the event structure, are described in QPOE +by compile time bound SPP binary data structure definitions, provided in a +standard interface include file (\fI\fR) referenced by both QPOE and +selected applications. When the interface is layered upon DFIO these +structures could continue to be used, since DFIO will have the ability to +define runtime mappings of conventional application defined structures onto +the physical data datafile (POE file) structures. + +.NH 2 +Interface Specification + + The quick-POE interface (QPOE, package prefix `qp') is a set of procedures +for accessing \fIpoefiles\fR, or position ordered event files. Each poefile +consists of a \fBheader\fR of arbitrary size and content containing zero or +more named scalar or variable length (opaque, typeless) fields, plus an +\fBevent list\fR consisting of zero or more event structures. +The event structure is fixed at compile time via a conventional SPP structure +declaration in the include file \fB\fR. + +.NH 3 +Interface Procedures + + The QPOE procedures fall into three main categories, the primary user +interface procedures (general datafile management, header access, and filtered +event i/o), the low level or raw event i/o procedures, and the low level +selection expression compile and evaluate procedures. + +.NH 4 +Header Access Procedures + + The routines described in this section are used to create, open, or +otherwise manipulate poefiles, to define new header parameters or query the +existing parameter set, and to read and write the values of both scalar and +vector parameters of various standard and poefile-specific datatypes. +These operators are summarized in the figure below. + +The function of most of these procedures should be obvious. +The \fIqp_access\fR, \fIqp_delete\fR, \fIqp_rename\fR, and \fIqp_copy\fR +operators perform the implied operation on the named poefile. +The poefile may be rebuilt with \fIqp_rebuild\fR, recovering any unused +space and rendering storage for the internal data structures (logically) +contiguous in the process (a rebuild is just a copy/rename/delete). + +The \fIqp_open\fR procedure must be called to open or create a poefile, +before it can be accessed. The NEW_FILE and NEW_COPY modes are supported +for creating new files. If NEW_COPY mode is specified, a reference file +may be specified (via the descriptor \fIo_qp\fR) from which the new file +is to inherit the header but no data (no event list). +The \fIqp_seti\fR and \fIqp_stati\fR procedures are used to set and stat +any parameters affecting QPOE i/o, and \fIqp_sync\fR updates an opened +poefile on disk. + +The \fIqp_get\fR and \fIqp_put\fR scalar functions behave as for the other +VOS interfaces, e.g., they will abort if the named parameter does not exist, +or if the implied datatype conversion is illegal. The \fIqp_add\fR +procedures are equivalent to the \fIqp_put\fR procedures except that they +will create the named parameter if it does not already exist (see also +\fIqp_addf\fR, discussed below). + +.nf + yes|no = qp_access (poefile, mode) + qp_copy (poefile, newfile) + qp_rename (poefile, newfile) + qp_rebuild (poefile) + qp_delete (poefile) + + qp = qp_open (poefile, mode, o_qp) + qp_seti (qp, param, ival) + ival = qp_stati (qp, param) + qp_sync (qp) + qp_close (qp) + + val = qp_get[bcsilrdx] (qp, param) + qp_gstr (qp, param, outstr, maxch) + qp_put[bcsilrdx] (qp, param, val) + qp_pstr (qp, param, strval) + qp_add[bcsilrdx] (qp, param, defval, comment) + qp_astr (qp, param, strval, comment) + + fd = qp_popen (qp, param, mode, type) + nelem = qp_read (qp, param, buf, nelem, first, dtype) + qp_write (qp, param, buf, nelem, first, dtype) + + yes|no = qp_accessf (qp, param) + qp_deletef (qp, param) + qp_renamef (qp, param, newname) + qp_addf (qp, param, dtype, maxelem, comment, flags) + nelem = qp_queryf (qp, param, dtype, maxelem, comment, flags) + + list = qp_ofnl[su] (qp, template) + nch|EOF = qp_gnfn (list, outstr, maxch) + qp_cfnl (list) +.fi + +Array valued parameters may be randomly read with \fIqp_read\fR and +written with \fIqp_write\fR; arrays may be any length, and will be +automatically extended in a write. The only way to shorten an array +parameter is to copy it and delete the old parameter. The typed read and +write functions allow automatic type conversions, and external storage of +the data in a machine independent form (should the interface choose to do so). +In addition to the standard SPP types, QPOE supports the special types +TY_EVENT, TY_ASPECT, and TY_TEMPORAL. Finally, the type TY_OPAQUE denotes +an array of element size SZ_CHAR, which will be copied to and from external +storage without the data being modified in any way (note that opaque data +is machine independent only if the application encodes it that way). + +Alternatively, an array valued parameter may be opened as a random access +\fIfile\fR with \fIqp_popen\fR, and then read or written with conventional +FIO calls. The value of the \fItype\fR parameter must be TEXT_FILE or +BINARY_FILE, as for a conventional file. If the type is TEXT_FILE then +only text data may be stored in the file, and text data will be byte packed +on disk. The BINARY_FILE type is equivalent to the QPOE type TY_OPAQUE. +File i/o to a QPOE parameter is equivalent to file i/o to a conventional +binary file in terms of both efficiency and semantics, i.e., the data is not +modified in any way, and the "files" may be any size (the main semantic +difference is that deleting the parameter does not immediately free the space). +A parameter opened as a file with \fIqp_popen\fR is closed with the FIO +\fIclose\fR routine. + +Although new parameters may be defined when first written to by calling one of +the typed \fIqp_add\fR functions, the most general procedure for adding new +parameters is \fIqp_addf\fR, which allows the datatype and vector length of +the parameter to be explicitly specified, along with a comment describing the +new parameter. The procedure \fIqp_accessf\fR tests if the named parameter +exists, and \fIqp_deletef\fR and \fIqp_renamef\fR make it possible to delete +and rename parameters, e.g., for implementing array copy procedures. +The \fIqp_queryf\fR procedure returns the datatype, allocated vector length, +current vector length, and comment field of the named parameter. + +The field name list procedures (\fIqp_ofnl[su]\fR etc.) are used to obtain +the names of all header parameters matching the given template; a null or "*" +template returns the names of all header parameters. This is the only way by +which an application without apriori knowledge of the field names can determine +what is in the header, e.g., to list or copy the header. + +.NH 4 +Filtered Event I/O Procedures + + The \fBevent i/o\fR subpacke provides sequential i/o facilities for the +main event list of the poefile. These procedures, known as the QPIO (QPOE +event i/o) package, provide read or write (append) access to the event list, +optionally filtered when reading to select events spatially or by event +attribute. + +Under QPOE, an event list is stored as a variable length array (i.e., as a +named header parameter) of type \fIevent\fR. The QPIO package takes this +basic object and adds additional structure for more efficient i/o, e.g., events +are blocked into large, fixed size \fIbuckets\fR of N events, the first two +events of each bucket containing the minimum and maximum event values for that +bucket. If the event list is sorted an \fIindex\fR may be maintained for the +list; this index, plus the min/max event values maintained for a bucket, are +used to optimize basic event i/o and filtering. During event i/o the raw +event list may be filtered spatially or by event attribute. All this is +transparent to the application, which merely opens the event list parameter +and begins reading (or writing) blocks of events. + +Before i/o can take place the named event list parameter is opened with +\fIqpio_open\fR. The selection filter to be used by QPIO may be specified +via a selection expression passed in by the user at poefile open time (as +part of the poefile name), at QPIO open time (as part of the parameter name), +or in subsequent calls to \fIqp_addfilter\fR (each call incrementally modifies +the current filter) or to \fIqp_setfilter\fR (each call replaces the affected +portion of the current filter). A region mask may also be specified with +\fIqp_setmask\fR; if no mask is specified, the default rejection mask is used +(or more precisely, its inverse). + +.nf + qpio = qpio_open (qp, param, mode) + qpio_mkindex (qpio, key, nelem) + qpio_setrange (qpio, vs, ve, ndim) + qpio_[add|set]filter (qpio, selexpr) + nchars = qpio_getfilter (qpio, outstr, maxch) + qpio_setmask (qpio, pl) + pl = qpio_getmask (qpio) + nev|EOF = qpio_getevents (qpio, ev, maskval, maxevents) + qpio_putevents (qpio, ev, nevents) + qpio_readpix (qpio, obuf, vs, ve, dxim, xblock, yblock) + qpio_close (qpio) +.fi + +Events are read sequentially with \fIqp_getevents\fR, which fills in the +pointer array \fIev[maxevents]\fR with one or more pointers to event structs, +returning the number of events read as the function value, or EOF when the +event list is exhausted. Events are returned in the order in which they are +stored in the main event list. If a region mask is used for spatial +filtering, the mask value associated with the output events is returned in +\fImaskval\fR. Filtering and subranges are supported only for reading; +\fIqp_putevents\fR may only be used to append to the output poefile. +At present, poefiles are not randomly updatable, as this would require +runtime editing of the compressed event lists and it is not clear how useful +such a feature would be. + +If less then the entire image is to be accessed then \fIqp_setrange\fR +may be called to specify the region of the poe image from which events are +to be read (the vector coordinates \fIvs\fR and \fIve\fR are specified +relative to the predefined primary event coordinate system, i.e., the PO +coordinates). Repeated calls to \fIqp_setrange\fR may be made to access +multiple regions of the image, or to rewind the i/o pointer for a region. + +An alternative to event i/o is provided by \fIqp_readpix\fR, which samples +the event list using the current filters and blocking factor, +generating \fInpix\fR pixels beginning with the pixel at the image coordinates +specified by the vector \fIv\fR. This is the routine used by the POE IMIO +image kernel to read from a poefile. Only integer pixels are supported. +On output, each pixel value is a count of the number of filtered events +mapping into that pixel. A region mask may be used to filter the event list, +but the ability to discriminate between different regions by the mask value +is lost. + +A poefile may contain any number of event list parameters, although most +files are expected to store only the main event list. +As an alternative to QPIO, event-array parameters may be accessed directly +via the normal header access parameters, e.g., \fIqp_read\fR, but i/o may be +somewhat less efficient (due to the copyout), the bucket structure will be +visible, and no filtering is possible. In short, the raw event list will +be accessed as an array, returning the min/max events in each bucket along +with the data events. + +In the current implementation, the event structure is a fixed, predefined +binary structure, and all event i/o is expressed in terms of pointers to event +structures. The event structure is defined in the include file +\fB\fR, discussed in the appendix. + +.NH 4 +Selection Subsystem Procedures + + The \fBselection subsystem\fR is a facility used to perform runtime +filtering of the event list, returning to the calling program only those +events satisfying some user defined selection criteria. The selection +subsystem is driven by a selection expression provided by the user as a +formatted string, normally at image (poefile) open time. The selection +expression syntax itself is independent of the procedural interface and is +described separately in section 2.3.2. The selection procedures are +summarized in the figure below. + +.nf + ex = qpex_open (qp, expr) + ok|err = qpex_modfilter (ex, exprlist) + nchars = qpex_getfilter (ex, outstr, maxch) + nev = qpex_evaluate (ex, i_ev, o_ev, nev) + qpex_close (ex) +.fi + +A selection expression, input as the string \fIexpr\fR, is compiled with +\fIqpex_open\fR, which returns a pointer to the runtime descriptor (filter) +for the given compiled selection expression. If \fIexpr\fR is the null +string the filter returned will pass all events. + +An active filter may be modified with \fIqpex_modfilter\fR, which combines +the expression \fIexpr\fR into the current filter, allowing complex +filters to be built up in several calls, or allowing an application to modify +a base filter without knowledge of the base filter. The expression consists +of a list of comma delimited "attribute = exprlist" terms. If the assignment +is specified as "=" the term for the given attribute is replaced; if the +assignment is "+=" the term for the given attribute is further qualified. +A text representation for the current filter may be obtained at any time with +\fIqpex_getfilter\fR. The boolean function \fIqpex_evaluate\fR is called to +test whether a specific event meets the selection criteria, i.e., to test +whether or not \fIexpr\fR is true for the given event. + +Selection is normally performed transparently to the application by the QPIO +interface, which calls the routines described in this section to create and +apply event-attribute filters. + +.NH 3 +Spatial and Event Attribute Filtering +.NH 4 +Selection Syntax + + Selection expressions are used to construct \fIfilters\fR to specify the +rejection mask and region of interest filters before reading the event list +via QPIO. Due to the complexity of event attribute selection, selection +predicates are specified syntactically, i.e., as an expression input as a +text string. These filters may be input by the user as part of the image +or poefile specification (object name), transparently to applications code, +or they may be constructed by the application via calls to the QPIO or +selection routines. Complex or frequently referenced filters may be stored +in text files and referenced by filename if desired. It does not matter +whether a filter is input all at once, or compiled incrementally. + +An event attribute filter consists of a set of filters for each event +attribute. By default, i.e., if no filter is specified, all attribute values +are passed. If a filter is specified for an attribute, the filter specifies +either a bitwise mask value, or a list of acceptable values or ranges of values +for the attribute. An event is passed if and only if all event attribute +filters pass the event. If a list of acceptable values are specified, the +list may be any length, with little impact on filtering efficiency. + +The basic event attribute filter syntax consists of a list of attribute +filters, e.g.: + + attribute = values [, attribute = values ...] + +where \fIattribute\fR is the attribute name, e.g., a position attribute, +time, energy, and so on, and \fIvalues\fR is a mask or list of values. +Mask values are integers prefixed by `%', e.g., + + attribute = %1003B + +Note that the mask may be specified in decimal (the default), octal (`b' or +`B' suffix), or hex (`x' or `X' suffix), in accord with the usual IRAF +conventions. The meta-characters used in selection expressions have been +selected to avoid or at least minimize the need to quote such expressions +in CL commands. + +A specific value or list of values may be specified as a +simple integer constant, or comma delimited list of constants, e.g.: + +.nf + attribute = 3 +or + attribute = 3, 5, 20X +.fi + +Ranges are specified using the `:' notation, e.g., + + attribute = 3, 5, 8:11 + +A `!' may be prepended to indicate the opposite, i.e., "everything but": + +.nf + attribute = !%14B +or + attribute = 3, !1:10 +.fi + +Open ended ranges may be used to indicate that the range includes all values +less than or equal to or greater than or equal to the given value, e.g., + + attribute = :100 + +denotes all values less than or equal to 100. + +File inclusion or \fImacro expansion\fR is denoted by a C-like function call +notation, e.g., + +.nf + macro() +or + macro(a,b) +.fi + +Any arguments are expanded via string substitution when the text of the macro +or include file is expanded. Include files should have the extension ".qpm". +Macros are permitted only if the variable \fBqpinit\fR is defined in the user's +environment, the string value consisting if the filename of the user's QPOE +macro file. In a reference to a macro \fImacro\fR, QPOE will look first in +the macro definitions file pointed to by \fIqpinit\fR for the named macro, +then it will look for the file "\fImacro\fR.qpm" in the current directory. + +Parenthesis are optional and may be included to, for example, make attribute +value lists more easily identifiable. If a line ends in a comma or backslash +continuation is assumed; blank lines and comment lines are ignored. +The syntax for attributes with floating point values is identical to that +for integers except that mask values are not allowed. + +.NH 4 +Region Specification + + QPOE does not itself contain any syntax-level support for specifying +region masks, e.g., via a list of include and exclude circles and other +shapes. The reason for this is that it is too difficult to come up with +a sufficiently general scheme at the level of an interface like QPOE; +there are too many ways to specify regions, hence in general such region +specification must be done at the applications level. QPOE does however +include very general and efficient support for region analysis provided the +region mask is input already encoded into a PLIO binary mask. Since PLIO +includes high level primitives for defining masks in terms of include and +exclude circles, boxes, lines, polygons, etc., it is easy to extend QPOE at +the applications level to include support for a region specification language +tailored to the specific application. + +While QPOE cannot itself process a user defined region description to create +new region masks, it is possible to \fIselect\fR from any number of region +masks if these are prepared in advance using other systems facilities or +applications programs. PLIO region masks may be stored in the QPOE header +as named parameters of type opaque binary array, or they may be stored in +external binary files. The region mask to be used may be specified by +including an assignment of the form + + mask=[\fIparam\fR|\fIfile\fR.pl] + +in the selection expression. Unless otherwise specified, this region mask +will be combined with the default rejection mask for the poefile (the final +mask will be the region mask \fIand\fR-ed with the \fInot\fR of the rejection +mask). + +.NH 4 +Predefined Selection Keywords + + While the syntax of a selection expression is an inherent part of the +QPOE interface, the names of the event attributes used in selection +expressions are logically part of the event structure, and ideally should +be stored with the data and used by the interface only to determine the +attribute datatypes and offsets into the event structure when the selection +expression is compiled at runtime. We should not really be documenting the +specifics of the POE external data structures here, but in QPOE these data +structures are wired into the interface, so it is appropriate to do so. + +The following \fIstandard event attributes\fR are defined. Minimum match +abbreviations are of course permitted. The keyword \fIpi\fR is an acceptable +alias for \fIenergy\fR (\fIpi\fR and \fIpha\fR are examples of discipline +dependent terminology which should be associated with the data and not the +interface). + +.nf + X short range in X (PO coords) + Y short range in Y (PO coords) + TIME real time event was recorded + ENERGY,PI int energy of event + PHA int pulse height +.fi + +The event attributes may also be referred to using the generic notation +[\fIsir\fR]\fIN\fR, which refers to each attribute by its datatype and +struct offset (byte units, zero indexed) rather than by name. For example, +if the event attributes shown above are assumed to be shown in the order +in which the fields are stored in the event struct, the \fItime\fR field +could also be referred to as \fIR4\fR, and \fIpha\fR as \fII10\fR. This +crude but effective technique may be used to reference any private +(nonstandard) fields of the event struct in selection expressions. + +The following additional, non-event keywords are defined: + +.nf + BLOCK int \fIqp_readpix\fR blocking factor + MASK string region mask to be used + FILTER string region filter to be used + REJMASK string rejection mask to be used + REJFILTER string rejection filter to be used +.fi + +The default values for these parameters are taken from datafile header +parameters of the same name, if such are found. Masks are specified either +by the name of a header parameter of type opaque binary array (containing +an encoded PLIO mask), or by the name of a PLIO mask file, extension ".pl". +Named filters are specified by the name of a header parameter of type char +array, or by the name of a text file (extension ".qpf"), where in either +case the named object contains the selection expression text. + +.NH 3 +Interface Set/Stat Parameters + + The internal parameters for the QPOE interface, and all user accessible +data structures, e.g., the event and other structures, are defined in the +global system include file \fB\fR. This file should be referred to +for up to date documentation on these definitions and structures; the +discussion which follows may not be kept up to date. + +The following interface parameters may be accessed via the \fIqp_seti\fR and +\fIqp_stati\fR procedures: + +.nf + QP_XRESOLUTION resolution of an event x-coordinate + QP_YRESOLUTION resolution of an event y-coordinate + QP_LENEVENT length of an event structure + QP_LENINDEX resolution of the event list index + QP_BUCKETSIZE event list bucket size, nevents + QP_PAGESIZE datafile page size, bytes + QP_CACHESIZE number of buffers in data buffer cache + QP_MAXFILES max lfiles in datafile (fixed) + QP_NFILES query number of lfiles in datafile + QP_NPAGES query number of pages in datafile + QP_FREEPAGES query number of free pages in datafile +.fi + +The parameters shown above may be set only at datafile creation time. +The X and Y resolution parameters define the range of event x,y coordinates. +The resolution of the event list index is set by QP_LENINDEX, and may be less +than the full resolution of the event pixel Y-coordinate. +The remaining parameters control how storage is physically allocated in the +datafile and in any event lists. + +.NH 2 +Detailed Design +.NH 3 +Event Attribute Filtering + + The point of event-attribute filtering is to test an event to see if it +satisfies a user defined event selection expression. A selection expression +may be decomposed into a list of simple, independent expressions for the +individual event attributes; the event satisfies the full expression only +if the value of each event attribute satisfies the associated attribute +expression. Currently, attribute expressions are limited to bitmasks, lists +of acceptable values, or lists of ranges (inclusive) of acceptable values. + + attr1=expr, attr2=expr, ... + +The highly constrained nature of event-attribute expressions makes expression +evaluation straightforward and fast. Expression evaluation is implemented +by logically negating each attribute expression and testing each in turn; +expression evaluation ends either when an attribute test fails, in which case +the event is rejected, or when the end of the attribute expression list is +reached, in which case the event is passed. + +The obvious way to implement such an expression evaluator is with a simple +interpreter. The expression is parsed and compiled to produce a simple +interpreter program, using the instructions shown in the figure below. + +.ks +.nf + \fIinstruction arguments\fR + + MSK[sir] offset maskval bitwise mask test + EQL[sir] offset value equality test + LEQ[sir] offset value less than or equal + GEQ[sir] offset value greater than or equal + RNG[sir] offset lowval highval range test (inclusive) + LUT[sir] offset lut lookup table + NOT invert test + RET return, pass event +.fi +.ke + +An interpreter program consists of a series of these instructions. The +\fIoffset\fR argument gives the offset of the event attribute (field) to +be tested; the datatype of this field must match that of the instruction +and of the data argument or arguments, if any. Only event attributes for +which restricted values were specified are tested, hence the cost of the +evaluator depends only upon the complexity of the expression to be evaluated. +An interpreter of this type can be coded very efficiently as a switch-case +statement (jump table) within an optimized DO-loop. + +Simple attribute value tests are most efficiently coded as several \fIMSK\fR, +\fIEQL\fR, etc., instructions. The only case of any complexity is where the +attribute has a long list of acceptable values or ranges of values. This is +most efficiently coded using a lookup table, using the \fILUT\fR instruction +shown in the figure. A lookup table test may be preceded by a range test to +limit the size of the lookup table required. For an integer or short integer +attribute, the lookup table will be a \fIboolean\fR table containing one entry +for each possible value of the attribute in the range spanned by the table. + +Use of a lookup table for floating point attributes is more difficult since +an enormous lookup table might be required to preserve the resolution of +the floating point numbers used to define ranges. The solution is to employ +an \fIinteger\fR (rather than boolean) lookup table of \fIreduced resolution\fR. +The floating point value of the attribute to be tested is mapped into a bin of +the lookup table. The integer value of the table entry has one of the +following values: + +.ks +.nf + 0 Reject all FP numbers mapping to this bin. + 1 Accept all FP numbers mapping to this bin. + + N Some of the FP numbers mapping to this bin are + legal, and some are not. The value N is the + address of a segment of interpreter code to be + executed to test a FP value mapped to this bin. +.fi +.ke + +The performance of this algorithm for floating point table lookup depends +upon the frequency with which 0 or 1 is encountered as the table value during +lookup; if 0 or 1 is encountered most of the time, then a floating point LUT +test is comparable in expense to an integer LUT test. But since we already +have to map a floating point number into an integer space of reduced +resolution, we can easily vary the resolution of the lookup table, +increasing the resolution of the table until the desired level of efficiency +is reached (the interpreter execution time for case N is pretty fast in any +case, so this is not critical). + +In summary, the expense of event-attribute filtering is directly proportional +to the number of attribute tests to be performed. An arbitrary number of +values or ranges of values may be specified for an attribute with little if +any affect on performance, even for floating point attributes (e.g., for +time-tagged quality filtering). + +.NH 3 +Region Filtering + + Region filtering is implemented in QPOE by the PLIO interface, which is +documented elsewhere. PLIO permits regions of arbitrary complexity to be +described and used for event filtering, with little overhead beyond that +already present for i/o on a large event list with no region filtering. +This assumes only that the event list is position ordered, and that the +region mask is specified in the PO (position ordered) coordinate system. +This makes it possible for QPIO to use the mask to reduce the number of +events to be examined; event attribute filtering is performed only on those +events read through the region mask (this is similar to masked image i/o, +i.e., the MIO package). + +If the event structure supports multiple coordinate systems and the region +mask refers to a non-PO coordinate system, then the only approach is to first +perform event-attribute filtering on the non-positional event attributes, +then for each event passing the event-attribute filter, fetch the mask value +corresponding to the x,y coordinates of the event. This is still an efficient +technique since only mask pixel lookup is required (no complicated region +list traversal is involved), but it will be significantly less efficient than +PO region filtering since we cannot take advantage of position ordering to +reduce the number of events to be examined, and the overhead of accessing +the region mask will be greater. + +.NH 3 +Datafile Layout and Access +.NH 4 +File Structure + + The QPOE file structure is private to the QPOE interface and is discussed +here only for the purpose of detailing (and documenting) the design of the +interface. The QPOE file is a random access, dynamically extendable, binary +file. Under QPOE these files will be partially, but not completely, machine +independent, hence file sharing by machines of different architectures will +not be provided initially. This will be rectified when management of the +datafile is later turned over to DFIO. + +To provide a reasonable degree of flexibility, QPOE contains many +variable length data structures, e.g., there may be any number of header +parameters, including array valued parameters of arbitrary size. New header +parameters may be added at any time, and new data may be appended to array +parameters at any time. This flexibility places certain demands upon the +low level file manager used to maintain these data structures in the datafile. + +All access to the physical datafile is via a low level binary +\fIfile manager\fR. The purpose of the file manager is to implement a +restricted implementation of the binary file abstraction upon a single host +level binary file. This provides the "lightweight" binary file mechanism we +need for QPOE. Since the file manager is a low level facility, it is +implemented using only the low level asynchronous i/o facilities provided +by FIO to read and write file pages, once the file has been opened. + +The file manager provides routines for creating new datafiles, and for +creating, deleting, etc., \fIlightweight files\fR (lfiles) within a datafile. +Storage for lfiles is allocated in units of datafile \fIpages\fR. For each +data page in the datafile there is an entry in the datafile \fIpage table\fR. +The page table itself is stored as an lfile (\fIlfile zero\fR) in the data +pages. Files at the file manager level are known only by their file number; +association of these file numbers with file names is left up to the higher +level code, and in the case of QPOE is done with the symbol table (which is +also stored as an lfile). + +.ks +.nf + +-----------------+ + datafile header fixed size + +-----------------+ + file table fixed size + +-----------------+ + | + data pages data and page table pages + | (arbitrarily large) + v +.fi +.ke + +The page table is a vector mapping datafile pages by file offset onto lfile +file numbers; the value of each page table entry is the file number of the +lfile to which the page is assigned. When the file manager opens an lfile +it scans the page table, extracting the page numbers of the pages assigned +to the lfile, to form a vector mapping lfile page offsets directly onto +datafile page offsets. New pages are always allocated at the end of the +datafile, and new lfiles are always allocated at the end of the file table, +hence lfile deletion will leave "holes" (unused storage) in both the datafile +pages and file table. A \fIrebuild\fR operation is required to reclaim the +space occupied by these holes. Deleted files are recoverable by merely +revalidating their file table entries. + +Every variable size object managed by QPOE is stored in the datafile as a +distinct lfile. Since storage for lfiles is allocated in units of file pages, +the minimum amount of storage used by a variable length object is 0 or 1 page. +Examples of variable size objects are the SYMTAB symbol table +used to describe the contents of the datafile header (and any other symbols +used by QPOE), the static data storage area (used to store the values of +scalar and static array valued header parameters), and individual variable +length arrays. Note that each variable length array is stored in the datafile +as a separate lfile; if the maximum size of an array is less then the page +size, it will be more efficient to store it as a static array. + +The most important example of a variable length array is the main event list +of the poefile. To improve i/o efficiency and speed selection, the event +structs stored in an event list are grouped together into \fIbuckets\fR, +as discussed earlier in section 2.3.1.2. Each bucket will always occupy an +integral number of file pages. Storage for buckets is allocated contiguously +in the datafile, and buckets are always read and written to disk in a single +i/o transfer. + +The most important physical datafile parameters are hence the page size and +the bucket size. A larger page size can improve i/o efficiency and reduce the +size of the page table, but can lead to significant wasted space if there are +many variable length arrays. Since the i/o system will move entire large +blocks of pages to and from disk whenever possible, use of a small page is +normally preferred. A large bucket size improves i/o efficiency for event +lists, but if the bucket size is too large then bucket searching takes longer, +and selection efficiency may decrease. + +.NH 4 +File Manager + + The function of the file manager is to map a set of lfiles onto a single +random access host binary file. The file manager must keep track of the size +and type of each file, and whether or not it has been deleted. +In addition, the file manager must maintain a page table for the entire +datafile, noting the lfile to which each page is assigned. While an lfile +is open the file manager must maintain the page vector for that lfile so that +lfile offsets may be mapped directly onto datafile offsets. + +The number of lfiles is fixed at datafile creation time, and lfiles are +referred to by file number. File number zero is the datafile page table; +the first user lfile is number one. A datafile with a max file count of one +would actually contain two lfiles, counting the page table. + +The file manager interface is summarized in the figure below. A new datafile +may be created or an existing datafile opened with \fIfm_open\fR. +If a new datafile is being created the page size and max file count may be +changed from their default values with calls to \fIfm_seti\fR, and the values +of these and other parameters may be queried at any time with \fIfm_stati\fR. +An opened datafile may be copied with \fIfm_copyo\fR, omitting deleted lfiles +and rendering file segments contiguous. The page size and max file count +may be changed in a copy operation if desired. + +The \fIfm_access\fR, \fIfm_rename\fR, and \fIfm_delete\fR routines perform +the indicated operation upon the named datafile. The \fIfm_rebuild\fR +routine rebuilds a datafile, discarding deleted structures and coalescing +storage for objects. This routine, as well as \fIfm_copy\fR, are built upon +on the lower level routine \fIfm_copyo\fR, which does the real work, and +which allows the structural attributes of the new datafile to be specified +in \fIfm_seti\fR cals. + +All i/o to lfiles is via the six routines beginning with \fIfm_lfopen\fR in +the figure below. These routines constitute a FIO binary file driver for +lfiles, and may be called directly, or passed to the FIO routine \fIfopnbf\fR +to open an lfile as a binary file (\fIfm_lfname\fR should be called first +to construct a pseudo-filename for the lfile so that \fIfm_lfopen\fR can +reconstruct the file manager descriptor, lfile number, and lfile type). +Note that the lfile driver routines are unbuffered and (potentially) +asynchronous, and that i/o must be in units of datafile pages. +(See the buffer cache routines described in the next section for a higher +level facility for i/o to lfiles). + +.nf + yes|no = fm_access (datafile, mode) + fm_rename (datafile, newname) + fm_copy (datafile, newname) + fm_delete (datafile) + fm_rebuild (datafile) + + fm = fm_open (datafile, mode) + fm_seti (fm, param, ival) + ival = fm_stati (fm, param) + fm_debug (fm, out, what) + fm_copyo (fm, fm_to) + fm_sync (fm) + fm_close (fm) + + lfile = fm_nextlfile (fm) + fm_lfname (fm, lfile, type, lfname, maxch) + + fm_lfopen (lfname, mode, lf) + fm_lfstati (lf, param, ival) + fm_lfaread (lf, buf, nbytes, offset, status) + fm_lfawrite (lf, buf, nbytes, offset, status) + fm_lfawait (lf, status) + fm_lfclose (lf, status) + + fm_lfstat (fm, lfile, statbuf) + fm_lfdelete (fm, lfile) + fm_lfundelete (fm, lfile) +.fi + +In a sense, all lfiles exist as zero length files when the datafile is +created, since the lfile descriptors are preallocated and the files are +known only by number. Lfiles become interesting when they are opened as +files with \fIfm_lfopen\fR, and data is written into the file. An lfile +may be deleted with \fIfm_lfstat\fR. All this does is set the delete bit +in the lfile descriptor, hence a deleted lfile may later be undeleted with +\fIfm_lfundelete\fR. The data in a deleted lfile is not lost until the lfile +is again opened and written into, or the datafile is rebuilt. Information +on a specific lfile (size, type, etc.) may be obtained with \fIfm_lfstat\fR. + +There is nothing about the file manager which is specific to QPOE, so it is +implemented as a separate, standalone facility, and may be used in applications +other than QPOE. + +.NH 4 +Buffer Cache + + For reasons of efficiency, QPOE maintains portions of the datafile in +memory buffers while a datafile is open. The main QPOE descriptor, symbol +table, and file manager descriptor and page table are maintained in special +runtime data structures internal to the respective interfaces. All other +data is stored in lfiles and accessed only upon demand. In particular, +storage for all static (non variable length) QPOE header parameters is +maintained in a single lfile, and storage for each variable length parameter +is allocated in a separate lfile. + +Since most access to QPOE header parameters is via simple gets and puts to +named parameters, lfile access is handled by QPOE transparently to the client +applications program. To avoid excessive disk i/o when randomly accessing +the datafile, it is desirable for QPOE to maintain a cache of several lfile +data buffers, e.g., so that accesses to a series of static parameters or +repeated accesses to read or write different parts of an array parameter +should incur minimal disk accesses. This buffer cache is implemented in +QPOE by simply opening each lfile as a file under FIO, leaving it up to FIO to +manage the file buffer, and maintaining a LRU cache of open lfiles in QPOE. +The number of buffers (open lfiles) is controlled by the QP_CACHESIZE +parameter. Since the lfile buffer cache is a general datafile related +facility, it is implemented by the file manager. + +.ks +.nf + fd = fm_getfd (fm, lfile, mode, type) + fm_retfd (fm, lfile) + fm_lockout (fm, lfile) + fm_debugfd (fm, out) +.fi +.ke + +The \fIfm_getfd\fR routine maps an lfile onto a file descriptor. A file +descriptor is opened on the lfile only when necessary. Once opened, an lfile +remains in the cache until forced out by the LRU replacement algorithm, +or the datafile is closed. Removal of an lfile from the cache (closing the +associated file descriptor) is permitted only after a call to \fIfm_retfd\fR; +calling this routine does not immediately close the file, it only permits it +to be closed. Most calls to \fIfm_getfd\fR should return a file descriptor +immediately, with very little overhead, with an already active file buffer, +hence repeated calls to the cache manager and FIO may be made without +incurring any disk accesses. + +Note that lfiles may be opened on file descriptors via direct calls to the +file manager, regardless of whether these lfiles are already open in the +buffer cache. This allows two or more independent file buffers to be +simultaneously active on the same lfile, but opens the possibility of loss +of data if the buffers overlap. If this is a problem, the routine +\fIfm_lockoutfd\fR may be called to prevent inadvertent use of an lfile by +the cache. This should be followed by a call to \fIfm_retfd\fR to clear the +lockout bit once the reason for the lockout (usually a noncached lfile open) +is gone. The routine \fIfm_debugfd\fR will print information on \fIout\fR +describing the contents of the buffer cache. + +.tp 24 +.NH 3 +Interface Structure +.NH 4 1 +Header Access Package (QP Routines) + + The structure of the general QPOE routines (mostly header access) is +illustrated in the figure below. + +.ks +.nf + +--------+ + | QP | + +--------+ + / \ + / \ + +--------+ +--------+ + | SYMTAB | | BCACHE | + +--------+ +--------+ + | + +--------------+ + | FILE MANAGER | + +--------------+ + + Figure 1. Structure of the Header Access Routines +.fi +.ke + +To fulfill a get or put header access, QPOE will access the symbol table +(SYMTAB) to lookup the symbol name and determine the symbol datatype, nelem, +lfile number, and lfile file offset where the value is stored. The buffer +cache (BCACHE) and FIO are then called to access the value of the parameter +in the datafile. + +.NH 4 +Filtered Event I/O Package (QPIO) + + The structure of the filtered event i/o package (QPIO) is illustrated in +the figure below. + +.ks +.nf + +--------+ + | QPIO | + +--------+ + / | \ + __________/ | \__________ + / | \ + +--------+ +--------+ +--------+ + | PLIO | | QPEX | | BCACHE | + +--------+ +--------+ +--------+ + | | + +--------+ +--------------+ + | SYMTAB | | FILE MANAGER | + +--------+ +--------------+ + + Figure 2. Structure of QPIO Routines +.fi +.ke + +In the typical \fIgetevents\fR call, QPIO will call PLIO to determine the +next region of the stored image (event list) to access, then if the event +data is not already in a data buffer, FIO is called to read the data (bucket), +using the event list index, an integer array valued parameter, to determine +what bucket to read. The events in the bucket are then examined and optionally +filtered via calls to QPEX, returning pointers to the passed events in an +output argument. This process terminates when either the mask value changes +or at least one event has been returned and a new bucket is required to +continue reading. diff --git a/sys/qpoe/README b/sys/qpoe/README new file mode 100644 index 00000000..dd48198b --- /dev/null +++ b/sys/qpoe/README @@ -0,0 +1,323 @@ +QPOE -- Prototype POE (Position Ordered Event file) Interface. +See QPOE.hlp for detailed information. +----------------------------------------------------------------- + + +1. QPOE (General QPOE file access) + + [ --- external routines --- ] + + qp_parse (expr, poefile, sz_poefile, paramex, sz_paramex) + yes|no = qp_access (poefile, mode) + qp_copy (o_poefile, n_poefile) + qp_rename (o_poefile, n_poefile) + qp_rebuild (poefile) + qp_delete (poefile) + + ptr = qp_open (poefile, mode, o_qp) + qp_set[ir] (qp, param, value) + val = qp_stat[ir] (qp, param) + qp_debug (qp, out, what) + qp_sync (qp) + qp_close (qp) + + qp_add[bcsilrdx] (qp, param, value, comment) + qp_astr (qp, param, value, comment) + val = qp_get[bcsilrdx] (qp, param) + nchars = qp_gstr (qp, param, outstr, maxch) + qp_put[bcsilrdx] (qp, param, value) + qp_pstr (qp, param, strval) + + n = qp_read (qp, param, buf, maxelem, first, datatype) + qp_write (qp, param, buf, nelem, first, datatype) + fd = qp_popen (qp, param, mode, type) + mw = qp_loadwcs (qp) + qp_savewcs (qp, mw) + + yes|no = qp_accessf (qp, param) + qp_deletef (qp, param) + qp_renamef (qp, param, newname) + qp_copyf (o_qp, o_param, n_qp, n_param) + qp_addf (qp, param, datatype, maxelem, comment, flags) + nelem = qp_queryf (qp, param, datatype, maxelem, comment, flags) + nelem = qp_lenf (qp, param) + nchars = qp_expandtext (qp, s1, s2, maxch) + + ptr = qp_ofnl[su] (qp, template) + ptr = qp_ofnl (qp, template, sort) + n|EOF = qp_gnfn (fl, outstr, maxch) + len = qp_lenfnl (fl) + qp_seekfnl (fl, pos) + qp_cfnl (fl) + + [ --- internal routines --- ] + + qp_bind (qp) + dtype = qp_dtype (qp, datatype, dsym) +nchars = qp_elementsize (qp, datatype) + nchars = qp_sizeof (qp, dtype, dsym) + qp_mkfname (poefile, extn, fname, maxch) + ival = qp_ctoi (str, ip, ival) + dval = qp_ctod (str, ip, dval) + + ptr = qp_gmsym (qp, macro, textp) + ptr = qp_gpsym (qp, param) + nfields = qp_parsefl (qp, fieldlist, dd) + qp_inherit (n_qp, o_qp, out) + dtype = qp_getparam (qp, param, o_pp) + dtype = qp_putparam (qp, param, o_pp) + qp_flushpar (qp) + + gt = qp_opentext (qp, text) # token i/o + token = qp_nexttok (gt) + token = qp_gettok (gt, tokbuf, maxch) + token = qp_rawtok (gt, outstr, maxch) + nargs = qp_arglist (gt, argbuf, maxch) + qp_closetext (gt) + + ptr = qm_access () # macros + ch = qm_getc (fd, ch) + qm_scan (qm, fname, flags) + qm_scano (qm, fd, flags) + qm_[set|upd]defaults (qm, qp) + qm_setparam (qm, param, valstr) + ptr = qm_symtab (qm) + + +2. QPIO (Event I/O) + + [ --- external routines --- ] + + io = qpio_open (qp, paramex, mode) + qpio_close (io) + + qpio_setrange (io, vs, ve, ndim) + ndim = qpio_getrange (io, vs, ve, maxdim) + qpio_setfilter (io, expr) +nchars = qpio_getfilter (io, outstr, maxch) + qpio_set[ir] (io, param, value) + val = qpio_stat[ir] (io, param) + mw = qpio_loadwcs (io) + qpio_mkindex (io, key) + + qpio_putevents (io, i_ev, nevents) + n|EOF = qpio_getevents (io, o_ev, maskval, maxev, nev) + nev = qpio_readpix[si] (io, obuf, vs, ve, ndim, xblock, yblock) + + [ --- internal routines --- ] + + ok|err = qpio_parse (io, expr, filter, sz_filter, mask, sz_mask) + qpio_loadmask (io, mask, mergeflg) +bkno|EOF = qpio_rbucket (io, bkno) + qpio_wbucket (io, n_bkno) + qpio_sync (io) + + +3. QPEX (Event Attribute Filtering) + + [ --- external routines --- ] + + ex = qpex_open (qp, expr) +ok|err = qpex_modfilter (ex, exprlist) +nchars = qpex_getfilter (ex, outstr, maxch) + nc = qpex_getattribute (ex, attribute, outstr, maxch) + nr = qpex_attrl[ird] (ex, attribute, xs, xe, xlen) + nev = qpex_evaluate (ex, i_ev, o_ev, nev) + qpex_close (ex) + + [ --- internal routines --- ] + + v = qpex_parse[dir] (expr, xs, xe, xlen) + v = qpex_sublist[dir] (x1, x2, xs,xe,nranges,ip, o_xs,o_xe) + v = qpex_codegen[dir] (ex, atname, assignop, expr, offset, dtype) + qpex_delete (ex, offset, dtype) + + ptr = qpex_pbpos (ex) + offset = qpex_refd (ex, value) + ptr = qpex_dballoc (ex, nelem, dtype) + ptr = qpex_dbpstr (ex, strval) + qpex_pbpin (ex, opcode, arg1, arg2, arg3) + qpex_mark (ex, pb_save, db_save) + qpex_free (ex, pb_save, db_save) + + nr = qp_rlmerge[dir] (os,oe,olen, xs,xe,nx, ys,ye,ny) + + + 4. INTERFACE SYNTAX + +Default parameter and domain names: + + "deffilt" # default event filter (all event lists) + "defmask" # default region mask (all event lists) + "deffilt." # default event filter for event list + "defmask." # default region mask for event list + "event" # default name of user event datatype + "events" # default event-list parameter + +QPIO expression syntax: + + [ evl-param ][ `[' [`!'] keyword [(`:='|`='|`+=') expr], ...`]' ] + +where defaults to "events" if not given, and where may +be any of the following, or a term of an event attribute expression. + + block # blocking factor for image matrix + debug # debug level (integer, 0=nodebug) + filter # event attribute filter (expression) + key # event key (Y,X) fields (e.g.(s10,s8)) + noindex # don't use index even if present + param # name of event list header parameter + mask # region mask + rect # subregion of image, e.g, rect=[*,100:400] + +Any unrecognized keyword=expr terms are passed on to the event attribute +filter, hence the "filter=(expr)" syntax is optional. + +QPEX expression syntax (the in "filter=" above): + + '(' attribute=expr [, attribute=expr...] ')' + +where is the "physical" name (type code plus byte offset) of +a field of the event structure, and expr is + + %N bitwise mask test + !%N negated bitwise mask test + +or some combination of + + N equality test + :N open range (less than or equal to N) + N: open range (greater than or equal to N) + M:N range (M to N inclusive) + expr,expr,... list of values or ranges + '(' expr ')' parenthesized expr + '!' expr + +MACRO syntax: + + macro replace by defined value + macro(arg,...) replace with argument substitution + @file replace <@file> by contents of file + `cmd` replace <`cmd`> by output of the CL command "cmd", + replacing all newlines by spaces + @file(arg,...) file pushback with argument substitution + `cmd`(arg,...) command output pushback with argument substitution + +Macro define syntax: + + define macro replacement-text + set parameter value + +where is any identifier, and is literal text to +be pushed back into the input and rescanned when is encountered in +the input stream. may contain symbols of the form '$N' +denoting places where argument substitution is to be performed during pushback. +The special builtin macro $DFN will be replaced by the datafile name, returned +as a string token. + + denotes a QPOE interface parameter the value of which is to be +set, e.g., to set the size of a buffer to be created at run time. The +following interface parameters are defined: + + "bucketlen" QPIO bucket length, nevents + "cachesize" number of file descriptors in lfile cache + "indexlen" number of hash entries in symbol table index + "maxlfiles" maximum number of lfiles in datafile + "pagesize" page size, bytes, of datafile + "sbufsize" initial symbol table size, su + "stablen" initial symbol table string buffer size, chars + "progbuflen" QPEX program buffer size (compiled instructions) + "databuflen" QPEX data buffer size (initialized data space) + "nodeffilt" disable the use of any default event filters + "nodefmask" disable the use of any default region masks + "maxpushback" max characters pushback (for macro expansion) + "maxfrlutlen" max full resolution lookup table length + "maxrrlutlen" max reduced resolution lookup table length + "lutminranges" min ranges required before a lookup table is used + "lutscale" scale factor to convert nranges to n LUT bins + "blockfactor" QPIO blocking factor for output pixel arrays + "optbufsize" FIO i/o buffer size for IMIO access to QPOE file, chars + "debuglevel" debug level, 0 for no runtime debug messages + +Environment: + + 'qmfiles' an environment variable listing a set of macro + define files defining the global macros to be + used by QPOE + + 'qmsave' an environment variable defining the name of a + file to be used to store the compiled macros + (defaults to uparm$qpoe.msv). + + + 5. INTERFACE PARAMETERS + +# QPSET.H -- User accessible definitions for the QPOE package. + +define SZ_COMMENT 79 # max size comment string +define SZ_DATATYPE 79 # max size datatype name string + +# QPOE Read-Write Parameters. +define QPOE_BLOCKFACTOR 1 # blocking factor for pixel arrays +define QPOE_BUCKETLEN 2 # event list bucket length, nevents +define QPOE_CACHESIZE 3 # lfile (buffer) cache size, nlfiles +define QPOE_DATABUFLEN 4 # QPEX data buffer length, chars +define QPOE_DEBUGLEVEL 5 # debug level (0 = no messages) +define QPOE_DEFLUTLEN 6 # default lookup table length (bins) +define QPOE_INDEXLEN 7 # symbol table hash index length +define QPOE_LUTMINRANGES 8 # min ranges before using LUT +define QPOE_LUTSCALE 9 # scale nranges to LUT bins +define QPOE_MAXFRLUTLEN 10 # max full-res LUT length +define QPOE_MAXLFILES 11 # max lfiles in datafile +define QPOE_MAXPUSHBACK 12 # max amount of pushed back macro data +define QPOE_MAXRRLUTLEN 13 # max reduced-res LUT length +define QPOE_OPTBUFSIZE 14 # optimum buffer size for IMIO/QPF/FIO +define QPOE_PAGESIZE 15 # page size of datafile, bytes +define QPOE_PROGBUFLEN 16 # QPEX program buffer length, ints +define QPOE_SBUFSIZE 17 # symtab string buf size, chars (init) +define QPOE_STABLEN 18 # symtab data area size, su (init) +define QPOE_NODEFFILT 19 # disable use of default filter +define QPOE_NODEFMASK 20 # disable use of default mask + +# QPOE Read-Only Parameters. +define QPOE_FM 21 # FMIO descriptor +define QPOE_MODE 22 # poefile access mode +define QPOE_ST 23 # SYMTAB symbol table descriptor +define QPOE_VERSION 24 # QPOE version number + +# Parameter flags (for qp_addf). +define QPF_NONE (-1) # no flags (0 gives default flags) +define QPF_INHERIT 0002B # copy parameter in a NEW_COPY open + + +# QPIOSET.H -- QPIO User accessible interface parameters. + +define qpio_stati qpiost # (name collision with qpio_seti) + +# Read-Write Parameters. +define QPIO_BLOCKFACTOR 1 # blocking factor for image matrices +define QPIO_BUCKETLEN 2 # event list bucket size, nevents +define QPIO_DEBUG 3 # debug level, debug=0 for no messages +define QPIO_EVXOFF 4 # short offset of X field of event +define QPIO_EVYOFF 5 # short offset of Y field of event +define QPIO_EX 6 # QPEX descriptor (event attr. filter) +define QPIO_NODEFFILT 7 # disable use of default filter +define QPIO_NODEFMASK 8 # disable use of default mask +define QPIO_NOINDEX 9 # flag to disable use of index +define QPIO_OPTBUFSIZE 10 # optimum buffer size for IMIO/QPF/FIO +define QPIO_PL 11 # PLIO descriptor (pixel mask) + +# Read-Only Parameters. +define QPIO_EVENTLEN 12 # length of event struct, shorts +define QPIO_FD 13 # file descriptor of event list lfile +define QPIO_INDEXLEN 14 # event list index length (0=noindex) +define QPIO_IXXOFF 15 # short offset of X field used in index +define QPIO_IXYOFF 16 # short offset of Y field used in index +define QPIO_LF 17 # lfile in which event list is stored +define QPIO_MASKP 18 # char pointer to mask-name buffer +define QPIO_MAXEVP 19 # pointer to MAX-event fields struct +define QPIO_MINEVP 20 # pointer to MIN-event fields struct +define QPIO_NCOLS 21 # number of columns in image +define QPIO_NLINES 22 # number of lines in image +define QPIO_PARAMP 23 # char pointer to param-name buffer +define QPIO_QP 24 # backpointer to QPOE descriptor diff --git a/sys/qpoe/gen/mkpkg b/sys/qpoe/gen/mkpkg new file mode 100644 index 00000000..8c08a1f7 --- /dev/null +++ b/sys/qpoe/gen/mkpkg @@ -0,0 +1,47 @@ +# Update the generically expanded files in libex.a. + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + qpaddb.x ../qpoe.h + qpaddc.x ../qpoe.h + qpaddd.x ../qpoe.h + qpaddi.x ../qpoe.h + qpaddl.x ../qpoe.h + qpaddr.x ../qpoe.h + qpadds.x ../qpoe.h + qpaddx.x ../qpoe.h + qpexattrld.x ../qpex.h + qpexattrli.x ../qpex.h + qpexattrlr.x ../qpex.h + qpexcoded.x ../qpex.h + qpexcodei.x ../qpex.h + qpexcoder.x ../qpex.h + qpexparsed.x ../qpex.h + qpexparsei.x ../qpex.h + qpexparser.x ../qpex.h + qpexsubd.x ../qpex.h + qpexsubi.x ../qpex.h + qpexsubr.x ../qpex.h + qpgetc.x ../qpoe.h + qpgetd.x ../qpoe.h + qpgeti.x ../qpoe.h + qpgetl.x ../qpoe.h + qpgetr.x ../qpoe.h + qpgets.x ../qpoe.h + qpiogetev.x ../qpio.h + qpiorpixi.x ../qpio.h + qpiorpixs.x ../qpio.h + qpputc.x ../qpoe.h + qpputd.x ../qpoe.h + qpputi.x ../qpoe.h + qpputl.x ../qpoe.h + qpputr.x ../qpoe.h + qpputs.x ../qpoe.h + qprlmerged.x ../qpex.h + qprlmergei.x ../qpex.h + qprlmerger.x ../qpex.h + ; diff --git a/sys/qpoe/gen/qpaddb.x b/sys/qpoe/gen/qpaddb.x new file mode 100644 index 00000000..1291824a --- /dev/null +++ b/sys/qpoe/gen/qpaddb.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../qpoe.h" + +# QP_ADD -- Set the value of a parameter, creating the parameter if it does +# not already exist. This works for the most common case of simple scalar +# valued header parameters, although any parameter may be written into it it +# already exists. Additional control over the parameter attributes is possible +# if the parameter is explicitly created with qp_addf before being written into. + +procedure qp_addb (qp, param, value, comment) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +bool value #I parameter value +char comment[ARB] #I comment field, if creating parameter + +char datatype[1] +errchk qp_accessf, qp_addf +string dtypes SPPTYPES +int qp_accessf() + +begin + if (qp_accessf (qp, param) == NO) { + datatype[1] = dtypes[TY_BOOL] + call qp_addf (qp, param, datatype, 1, comment, 0) + } + call qp_putb (qp, param, value) +end diff --git a/sys/qpoe/gen/qpaddc.x b/sys/qpoe/gen/qpaddc.x new file mode 100644 index 00000000..64264e20 --- /dev/null +++ b/sys/qpoe/gen/qpaddc.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../qpoe.h" + +# QP_ADD -- Set the value of a parameter, creating the parameter if it does +# not already exist. This works for the most common case of simple scalar +# valued header parameters, although any parameter may be written into it it +# already exists. Additional control over the parameter attributes is possible +# if the parameter is explicitly created with qp_addf before being written into. + +procedure qp_addc (qp, param, value, comment) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +char value #I parameter value +char comment[ARB] #I comment field, if creating parameter + +char datatype[1] +errchk qp_accessf, qp_addf +string dtypes SPPTYPES +int qp_accessf() + +begin + if (qp_accessf (qp, param) == NO) { + datatype[1] = dtypes[TY_CHAR] + call qp_addf (qp, param, datatype, 1, comment, 0) + } + call qp_putc (qp, param, value) +end diff --git a/sys/qpoe/gen/qpaddd.x b/sys/qpoe/gen/qpaddd.x new file mode 100644 index 00000000..61db744e --- /dev/null +++ b/sys/qpoe/gen/qpaddd.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../qpoe.h" + +# QP_ADD -- Set the value of a parameter, creating the parameter if it does +# not already exist. This works for the most common case of simple scalar +# valued header parameters, although any parameter may be written into it it +# already exists. Additional control over the parameter attributes is possible +# if the parameter is explicitly created with qp_addf before being written into. + +procedure qp_addd (qp, param, value, comment) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +double value #I parameter value +char comment[ARB] #I comment field, if creating parameter + +char datatype[1] +errchk qp_accessf, qp_addf +string dtypes SPPTYPES +int qp_accessf() + +begin + if (qp_accessf (qp, param) == NO) { + datatype[1] = dtypes[TY_DOUBLE] + call qp_addf (qp, param, datatype, 1, comment, 0) + } + call qp_putd (qp, param, value) +end diff --git a/sys/qpoe/gen/qpaddi.x b/sys/qpoe/gen/qpaddi.x new file mode 100644 index 00000000..47d746c6 --- /dev/null +++ b/sys/qpoe/gen/qpaddi.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../qpoe.h" + +# QP_ADD -- Set the value of a parameter, creating the parameter if it does +# not already exist. This works for the most common case of simple scalar +# valued header parameters, although any parameter may be written into it it +# already exists. Additional control over the parameter attributes is possible +# if the parameter is explicitly created with qp_addf before being written into. + +procedure qp_addi (qp, param, value, comment) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +int value #I parameter value +char comment[ARB] #I comment field, if creating parameter + +char datatype[1] +errchk qp_accessf, qp_addf +string dtypes SPPTYPES +int qp_accessf() + +begin + if (qp_accessf (qp, param) == NO) { + datatype[1] = dtypes[TY_INT] + call qp_addf (qp, param, datatype, 1, comment, 0) + } + call qp_puti (qp, param, value) +end diff --git a/sys/qpoe/gen/qpaddl.x b/sys/qpoe/gen/qpaddl.x new file mode 100644 index 00000000..f5e0cac2 --- /dev/null +++ b/sys/qpoe/gen/qpaddl.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../qpoe.h" + +# QP_ADD -- Set the value of a parameter, creating the parameter if it does +# not already exist. This works for the most common case of simple scalar +# valued header parameters, although any parameter may be written into it it +# already exists. Additional control over the parameter attributes is possible +# if the parameter is explicitly created with qp_addf before being written into. + +procedure qp_addl (qp, param, value, comment) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +long value #I parameter value +char comment[ARB] #I comment field, if creating parameter + +char datatype[1] +errchk qp_accessf, qp_addf +string dtypes SPPTYPES +int qp_accessf() + +begin + if (qp_accessf (qp, param) == NO) { + datatype[1] = dtypes[TY_LONG] + call qp_addf (qp, param, datatype, 1, comment, 0) + } + call qp_putl (qp, param, value) +end diff --git a/sys/qpoe/gen/qpaddr.x b/sys/qpoe/gen/qpaddr.x new file mode 100644 index 00000000..ec367ab7 --- /dev/null +++ b/sys/qpoe/gen/qpaddr.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../qpoe.h" + +# QP_ADD -- Set the value of a parameter, creating the parameter if it does +# not already exist. This works for the most common case of simple scalar +# valued header parameters, although any parameter may be written into it it +# already exists. Additional control over the parameter attributes is possible +# if the parameter is explicitly created with qp_addf before being written into. + +procedure qp_addr (qp, param, value, comment) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +real value #I parameter value +char comment[ARB] #I comment field, if creating parameter + +char datatype[1] +errchk qp_accessf, qp_addf +string dtypes SPPTYPES +int qp_accessf() + +begin + if (qp_accessf (qp, param) == NO) { + datatype[1] = dtypes[TY_REAL] + call qp_addf (qp, param, datatype, 1, comment, 0) + } + call qp_putr (qp, param, value) +end diff --git a/sys/qpoe/gen/qpadds.x b/sys/qpoe/gen/qpadds.x new file mode 100644 index 00000000..67036fda --- /dev/null +++ b/sys/qpoe/gen/qpadds.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../qpoe.h" + +# QP_ADD -- Set the value of a parameter, creating the parameter if it does +# not already exist. This works for the most common case of simple scalar +# valued header parameters, although any parameter may be written into it it +# already exists. Additional control over the parameter attributes is possible +# if the parameter is explicitly created with qp_addf before being written into. + +procedure qp_adds (qp, param, value, comment) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +short value #I parameter value +char comment[ARB] #I comment field, if creating parameter + +char datatype[1] +errchk qp_accessf, qp_addf +string dtypes SPPTYPES +int qp_accessf() + +begin + if (qp_accessf (qp, param) == NO) { + datatype[1] = dtypes[TY_SHORT] + call qp_addf (qp, param, datatype, 1, comment, 0) + } + call qp_puts (qp, param, value) +end diff --git a/sys/qpoe/gen/qpaddx.x b/sys/qpoe/gen/qpaddx.x new file mode 100644 index 00000000..d147748e --- /dev/null +++ b/sys/qpoe/gen/qpaddx.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../qpoe.h" + +# QP_ADD -- Set the value of a parameter, creating the parameter if it does +# not already exist. This works for the most common case of simple scalar +# valued header parameters, although any parameter may be written into it it +# already exists. Additional control over the parameter attributes is possible +# if the parameter is explicitly created with qp_addf before being written into. + +procedure qp_addx (qp, param, value, comment) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +complex value #I parameter value +char comment[ARB] #I comment field, if creating parameter + +char datatype[1] +errchk qp_accessf, qp_addf +string dtypes SPPTYPES +int qp_accessf() + +begin + if (qp_accessf (qp, param) == NO) { + datatype[1] = dtypes[TY_COMPLEX] + call qp_addf (qp, param, datatype, 1, comment, 0) + } + call qp_putx (qp, param, value) +end diff --git a/sys/qpoe/gen/qpexattrld.x b/sys/qpoe/gen/qpexattrld.x new file mode 100644 index 00000000..5954cbe4 --- /dev/null +++ b/sys/qpoe/gen/qpexattrld.x @@ -0,0 +1,127 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../qpex.h" + +# QPEX_ATTRL -- Get the good-value range list for the named attribute, as a +# binary range list of the indicated type. This range list is a simplified +# version of the original filter expression, which may have contained +# multiple fields, some negated or overlapping, in any order, subsequently +# modified or deleted with qpex_modfilter, etc. The final resultant range +# list is ordered and consists of discreet nonoverlapping ranges. +# +# Upon input the variables XS and XE should either point to a pair of +# preallocated buffers of length XLEN, or they should be set to NULL. +# The routine will reallocate the buffers as necessary to allow for long +# range lists, updating XLEN so that it always contains the actual length +# of the arrays (which may not be completely full). Each list element +# consists of a pair of values (xs[i],xe[i]) defining the start and end +# points of the range. If xs[1] is INDEF the range is open to the left, +# if xe[nranges] is INDEF the range is open to the right. The number of +# ranges output is returned as the function value. + +int procedure qpex_attrld (ex, attribute, xs, xe, xlen) + +pointer ex #I QPEX descriptor +char attribute[ARB] #I attribute name +pointer xs #U pointer to array of start values +pointer xe #U pointer to array of end values +int xlen #U length of xs/xe arrays + +pointer ps, pe, qs, qe +pointer sp, expr, ip, ep +int plen, qlen, np, nq, nx +int neterms, nchars, maxch +int qpex_getattribute(), qpex_parsed(), qp_rlmerged() + +begin + call smark (sp) + + # Get attribute filter expression. In the unlikely event that the + # expression is too large to fit in our buffer, repeat with a buffer + # twice as large until it fits. + + maxch = DEF_SZEXPRBUF + nchars = 0 + + repeat { + maxch = maxch * 2 + call salloc (expr, maxch, TY_CHAR) + nchars = qpex_getattribute (ex, attribute, Memc[expr], maxch) + if (nchars <= 0) + break + } until (nchars < maxch) + + # Parse expression to produce a range list. If the expression + # contains multiple eterms each is parsed separately and merged + # into the final output range list. + + nx = 0 + neterms = 0 + + if (nchars > 0) { + # Get range list storage. + plen = DEF_XLEN + call malloc (ps, plen, TY_DOUBLE) + call malloc (pe, plen, TY_DOUBLE) + qlen = DEF_XLEN + call malloc (qs, qlen, TY_DOUBLE) + call malloc (qe, qlen, TY_DOUBLE) + + # Parse each subexpression and merge into output range list. + for (ip=expr; Memc[ip] != EOS; ) { + # Get next subexpression. + while (IS_WHITE (Memc[ip])) + ip = ip + 1 + for (ep=ip; Memc[ip] != EOS; ip=ip+1) + if (Memc[ip] == ';') { + Memc[ip] = EOS + ip = ip + 1 + break + } + if (Memc[ep] == EOS) + break + + # Copy output range list to X list temporary. + if (max(nx,1) > plen) { + plen = max(xlen,1) + call realloc (ps, plen, TY_DOUBLE) + call realloc (pe, plen, TY_DOUBLE) + } + if (neterms <= 0) { + Memd[ps] = LEFTD + Memd[pe] = RIGHTD + np = 1 + } else { + call amovd (Memd[xs], Memd[ps], nx) + call amovd (Memd[xe], Memd[pe], nx) + np = nx + } + + # Parse next eterm into Y list temporary. + nq = qpex_parsed (Memc[ep], qs, qe, qlen) + + # Merge the X and Y lists, leaving result in output list. + nx = qp_rlmerged (xs,xe,xlen, + Memd[ps], Memd[pe], np, Memd[qs], Memd[qe], nq) + + neterms = neterms + 1 + } + + # Free temporary range list storage. + call mfree (ps, TY_DOUBLE); call mfree (pe, TY_DOUBLE) + call mfree (qs, TY_DOUBLE); call mfree (qe, TY_DOUBLE) + + # Convert LEFT/RIGHT magic values to INDEF. + if (nx > 0) { + if (IS_LEFTD (Memd[xs])) + Memd[xs] = INDEFD + if (IS_RIGHTD (Memd[xe+nx-1])) + Memd[xe+nx-1] = INDEFD + } + } + + call sfree (sp) + return (nx) +end diff --git a/sys/qpoe/gen/qpexattrli.x b/sys/qpoe/gen/qpexattrli.x new file mode 100644 index 00000000..706aecc8 --- /dev/null +++ b/sys/qpoe/gen/qpexattrli.x @@ -0,0 +1,127 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../qpex.h" + +# QPEX_ATTRL -- Get the good-value range list for the named attribute, as a +# binary range list of the indicated type. This range list is a simplified +# version of the original filter expression, which may have contained +# multiple fields, some negated or overlapping, in any order, subsequently +# modified or deleted with qpex_modfilter, etc. The final resultant range +# list is ordered and consists of discreet nonoverlapping ranges. +# +# Upon input the variables XS and XE should either point to a pair of +# preallocated buffers of length XLEN, or they should be set to NULL. +# The routine will reallocate the buffers as necessary to allow for long +# range lists, updating XLEN so that it always contains the actual length +# of the arrays (which may not be completely full). Each list element +# consists of a pair of values (xs[i],xe[i]) defining the start and end +# points of the range. If xs[1] is INDEF the range is open to the left, +# if xe[nranges] is INDEF the range is open to the right. The number of +# ranges output is returned as the function value. + +int procedure qpex_attrli (ex, attribute, xs, xe, xlen) + +pointer ex #I QPEX descriptor +char attribute[ARB] #I attribute name +pointer xs #U pointer to array of start values +pointer xe #U pointer to array of end values +int xlen #U length of xs/xe arrays + +pointer ps, pe, qs, qe +pointer sp, expr, ip, ep +int plen, qlen, np, nq, nx +int neterms, nchars, maxch +int qpex_getattribute(), qpex_parsei(), qp_rlmergei() + +begin + call smark (sp) + + # Get attribute filter expression. In the unlikely event that the + # expression is too large to fit in our buffer, repeat with a buffer + # twice as large until it fits. + + maxch = DEF_SZEXPRBUF + nchars = 0 + + repeat { + maxch = maxch * 2 + call salloc (expr, maxch, TY_CHAR) + nchars = qpex_getattribute (ex, attribute, Memc[expr], maxch) + if (nchars <= 0) + break + } until (nchars < maxch) + + # Parse expression to produce a range list. If the expression + # contains multiple eterms each is parsed separately and merged + # into the final output range list. + + nx = 0 + neterms = 0 + + if (nchars > 0) { + # Get range list storage. + plen = DEF_XLEN + call malloc (ps, plen, TY_INT) + call malloc (pe, plen, TY_INT) + qlen = DEF_XLEN + call malloc (qs, qlen, TY_INT) + call malloc (qe, qlen, TY_INT) + + # Parse each subexpression and merge into output range list. + for (ip=expr; Memc[ip] != EOS; ) { + # Get next subexpression. + while (IS_WHITE (Memc[ip])) + ip = ip + 1 + for (ep=ip; Memc[ip] != EOS; ip=ip+1) + if (Memc[ip] == ';') { + Memc[ip] = EOS + ip = ip + 1 + break + } + if (Memc[ep] == EOS) + break + + # Copy output range list to X list temporary. + if (max(nx,1) > plen) { + plen = max(xlen,1) + call realloc (ps, plen, TY_INT) + call realloc (pe, plen, TY_INT) + } + if (neterms <= 0) { + Memi[ps] = LEFTI + Memi[pe] = RIGHTI + np = 1 + } else { + call amovi (Memi[xs], Memi[ps], nx) + call amovi (Memi[xe], Memi[pe], nx) + np = nx + } + + # Parse next eterm into Y list temporary. + nq = qpex_parsei (Memc[ep], qs, qe, qlen) + + # Merge the X and Y lists, leaving result in output list. + nx = qp_rlmergei (xs,xe,xlen, + Memi[ps], Memi[pe], np, Memi[qs], Memi[qe], nq) + + neterms = neterms + 1 + } + + # Free temporary range list storage. + call mfree (ps, TY_INT); call mfree (pe, TY_INT) + call mfree (qs, TY_INT); call mfree (qe, TY_INT) + + # Convert LEFT/RIGHT magic values to INDEF. + if (nx > 0) { + if (IS_LEFTI (Memi[xs])) + Memi[xs] = INDEFI + if (IS_RIGHTI (Memi[xe+nx-1])) + Memi[xe+nx-1] = INDEFI + } + } + + call sfree (sp) + return (nx) +end diff --git a/sys/qpoe/gen/qpexattrlr.x b/sys/qpoe/gen/qpexattrlr.x new file mode 100644 index 00000000..c13a7511 --- /dev/null +++ b/sys/qpoe/gen/qpexattrlr.x @@ -0,0 +1,127 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../qpex.h" + +# QPEX_ATTRL -- Get the good-value range list for the named attribute, as a +# binary range list of the indicated type. This range list is a simplified +# version of the original filter expression, which may have contained +# multiple fields, some negated or overlapping, in any order, subsequently +# modified or deleted with qpex_modfilter, etc. The final resultant range +# list is ordered and consists of discreet nonoverlapping ranges. +# +# Upon input the variables XS and XE should either point to a pair of +# preallocated buffers of length XLEN, or they should be set to NULL. +# The routine will reallocate the buffers as necessary to allow for long +# range lists, updating XLEN so that it always contains the actual length +# of the arrays (which may not be completely full). Each list element +# consists of a pair of values (xs[i],xe[i]) defining the start and end +# points of the range. If xs[1] is INDEF the range is open to the left, +# if xe[nranges] is INDEF the range is open to the right. The number of +# ranges output is returned as the function value. + +int procedure qpex_attrlr (ex, attribute, xs, xe, xlen) + +pointer ex #I QPEX descriptor +char attribute[ARB] #I attribute name +pointer xs #U pointer to array of start values +pointer xe #U pointer to array of end values +int xlen #U length of xs/xe arrays + +pointer ps, pe, qs, qe +pointer sp, expr, ip, ep +int plen, qlen, np, nq, nx +int neterms, nchars, maxch +int qpex_getattribute(), qpex_parser(), qp_rlmerger() + +begin + call smark (sp) + + # Get attribute filter expression. In the unlikely event that the + # expression is too large to fit in our buffer, repeat with a buffer + # twice as large until it fits. + + maxch = DEF_SZEXPRBUF + nchars = 0 + + repeat { + maxch = maxch * 2 + call salloc (expr, maxch, TY_CHAR) + nchars = qpex_getattribute (ex, attribute, Memc[expr], maxch) + if (nchars <= 0) + break + } until (nchars < maxch) + + # Parse expression to produce a range list. If the expression + # contains multiple eterms each is parsed separately and merged + # into the final output range list. + + nx = 0 + neterms = 0 + + if (nchars > 0) { + # Get range list storage. + plen = DEF_XLEN + call malloc (ps, plen, TY_REAL) + call malloc (pe, plen, TY_REAL) + qlen = DEF_XLEN + call malloc (qs, qlen, TY_REAL) + call malloc (qe, qlen, TY_REAL) + + # Parse each subexpression and merge into output range list. + for (ip=expr; Memc[ip] != EOS; ) { + # Get next subexpression. + while (IS_WHITE (Memc[ip])) + ip = ip + 1 + for (ep=ip; Memc[ip] != EOS; ip=ip+1) + if (Memc[ip] == ';') { + Memc[ip] = EOS + ip = ip + 1 + break + } + if (Memc[ep] == EOS) + break + + # Copy output range list to X list temporary. + if (max(nx,1) > plen) { + plen = max(xlen,1) + call realloc (ps, plen, TY_REAL) + call realloc (pe, plen, TY_REAL) + } + if (neterms <= 0) { + Memr[ps] = LEFTR + Memr[pe] = RIGHTR + np = 1 + } else { + call amovr (Memr[xs], Memr[ps], nx) + call amovr (Memr[xe], Memr[pe], nx) + np = nx + } + + # Parse next eterm into Y list temporary. + nq = qpex_parser (Memc[ep], qs, qe, qlen) + + # Merge the X and Y lists, leaving result in output list. + nx = qp_rlmerger (xs,xe,xlen, + Memr[ps], Memr[pe], np, Memr[qs], Memr[qe], nq) + + neterms = neterms + 1 + } + + # Free temporary range list storage. + call mfree (ps, TY_REAL); call mfree (pe, TY_REAL) + call mfree (qs, TY_REAL); call mfree (qe, TY_REAL) + + # Convert LEFT/RIGHT magic values to INDEF. + if (nx > 0) { + if (IS_LEFTR (Memr[xs])) + Memr[xs] = INDEFR + if (IS_RIGHTR (Memr[xe+nx-1])) + Memr[xe+nx-1] = INDEFR + } + } + + call sfree (sp) + return (nx) +end diff --git a/sys/qpoe/gen/qpexcoded.x b/sys/qpoe/gen/qpexcoded.x new file mode 100644 index 00000000..63ec2541 --- /dev/null +++ b/sys/qpoe/gen/qpexcoded.x @@ -0,0 +1,370 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../qpex.h" + +# QPEX_CODEGEN -- Generate interpreter metacode to evaluate the given +# expression. The new code is appended to the current compiled program, +# adding additional constraints which a data event will have to meet to +# pass the filter. + +int procedure qpex_codegend (ex, atname, assignop, expr, offset, dtype) + +pointer ex #I qpex descriptor +char atname[ARB] #I attribute name (for expr regeneration) +char assignop[ARB] #I "=" or "+=" (for expr regeneration) +char expr[ARB] #I expression to be compiled +int offset #I typed offset of referenced attribute +int dtype #I datatype of referenced attribute + +int nbins, bin, xp +pointer lt, lut, lutx, pb +double x1, x2, xmin, xmax +int xlen, nranges, n_nranges, level, opcode, ip, i +pointer pb_save, db_save, xs_buf, xe_buf, xs, xe, n_xs, n_xe, et, prev + +double sv_xs[MAX_LEVELS], sv_xe[MAX_LEVELS] +pointer sv_lt[MAX_LEVELS], sv_lut[MAX_LEVELS], sv_lutx[MAX_LEVELS] +int sv_xp[MAX_LEVELS], sv_nranges[MAX_LEVELS], sv_bin[MAX_LEVELS] +int sv_nbins[MAX_LEVELS] + +double xoffset, xscale +double sv_xoffset[MAX_LEVELS], sv_xscale[MAX_LEVELS] +int d_x1, d_x2 +int qpex_refd() + +bool fp_equald() + + +int qpex_parsed() +int stridxs(), btoi(), qpex_sublistd() +pointer qpex_dballoc(), qpex_dbpstr(), qpex_pbpos() +errchk qpex_dballoc, qpex_pbpin, malloc, calloc, realloc, qpex_parsed + +string qpexwarn "QPEX Warning" +define error_ 91 +define next_ 92 +define null_ 93 +define resume_ 94 +define bbmask_ 95 +define continue_ 96 +define XS Memd[xs+($1)-1] +define XE Memd[xe+($1)-1] + +begin + pb = EX_PB(ex) + + # Save the program state in case we have to abort. + call qpex_mark (ex, pb_save, db_save) + + # Allocate and initialize a new expression term descriptor, linking + # it onto the tail of the ETTERMs list. + + et = qpex_dballoc (ex, LEN_ETDES, TY_STRUCT) + + ET_ATTTYPE(et) = dtype + ET_ATTOFF(et) = offset + ET_ATNAME(et) = qpex_dbpstr (ex, atname) + ET_ASSIGNOP(et) = qpex_dbpstr (ex, assignop) + ET_EXPRTEXT(et) = qpex_dbpstr (ex, expr) + ET_PROGPTR(et) = qpex_pbpos (ex) + ET_DELETED(et) = NO + + prev = EX_ETTAIL(ex) + if (prev != NULL) + ET_NEXT(prev) = et + ET_NEXT(et) = NULL + EX_ETTAIL(ex) = et + if (EX_ETHEAD(ex) == NULL) + EX_ETHEAD(ex) = et + + ip = stridxs ("%", expr) + # Bitmask tests are meaningless for floating point data. + if (ip > 0) { + call eprintf ("%s: bitmasks not permitted for floating data\n") + call pargstr (qpexwarn) + goto error_ + } + + # Compile a general range list expression. The basic procedure is + # to parse the expression to produce an optimized binary range list, + # then either compile the range list as an explicit series of + # instructions or as a lookup table, depending upon the number of + # ranges. + + xlen = DEF_XLEN + call malloc (xs_buf, xlen, TY_DOUBLE) + call malloc (xe_buf, xlen, TY_DOUBLE) + + # Convert expr to a binary range list and set up the initial context. + # Ensure that the range list buffers are large enough to hold any + # sublists extracted during compilation. + + nranges = qpex_parsed (expr, xs_buf, xe_buf, xlen) + if (xlen < nranges * 2) { + xlen = nranges * 2 + call realloc (xs_buf, xlen, TY_DOUBLE) + call realloc (xe_buf, xlen, TY_DOUBLE) + } + + xs = xs_buf + xe = xe_buf + level = 0 + + repeat { +next_ + # Compile a new range list (or sublist). + if (nranges <= 0) { + # This shouldn't happen. +null_ call eprintf ("%s: null range list\n") + call pargstr (qpexwarn) + call qpex_pbpin (ex, PASS, 0, 0, 0) + + } else if (nranges == 1) { + # Output an instruction to load the data, perform the range + # test, and conditionally exit all in a single instruction. + + x1 = XS(1); x2 = XE(1) + d_x1 = qpex_refd (ex, x1) + d_x2 = qpex_refd (ex, x2) + + if (dtype == TY_SHORT) { + if (IS_LEFTD(x1) && IS_RIGHTD(x2)) + ; # pass everything (no tests) + else if (IS_LEFTD(x1)) + call qpex_pbpin (ex, LEQXS, offset, d_x2, 0) + else if (IS_RIGHTD(x2)) + call qpex_pbpin (ex, GEQXS, offset, d_x1, 0) + else if (fp_equald (x1, x2)) + call qpex_pbpin (ex, EQLXS, offset, d_x1, d_x2) + else + call qpex_pbpin (ex, RNGXS, offset, d_x1, d_x2) + } else { + if (IS_LEFTD(x1) && IS_RIGHTD(x2)) + ; # pass everything (no tests) + else if (IS_LEFTD(x1)) + call qpex_pbpin (ex, LEQXD, offset, d_x2, 0) + else if (IS_RIGHTD(x2)) + call qpex_pbpin (ex, GEQXD, offset, d_x1, 0) + else if (fp_equald (x1, x2)) + call qpex_pbpin (ex, EQLXD, offset, d_x1, d_x2) + else + call qpex_pbpin (ex, RNGXD, offset, d_x1, d_x2) + } + + } else if (nranges < EX_LUTMINRANGES(ex)) { + # If the number of ranges to be tested for the data is small, + # compile explicit code to perform the range tests directly. + # Otherwise skip forward and compile a lookup table instead. + # In either case, the function of the instructions compiled + # is to test the data loaded into the register above, setting + # the value of PASS to true if the data lies in any of the + # indicated ranges. + + # Check for !X, which is indicated in range list form by a + # two element list bracketing the X on each side. + + if (nranges == 2) + if (IS_LEFTD(XS(1)) && IS_RIGHTD(XE(2))) + if (fp_equald (XE(1), XS(2))) { + call qpex_pbpin (ex, NEQXD, offset, + qpex_refd(ex,XE(1)), 0) + goto resume_ + } + + # If at level zero, output instruction to load data into + # register and initialize PASS to false. Don't bother if + # compiling a subprogram, as these operations will already + # have been performed by the caller. + + if (level == 0) { + opcode = LDDD + call qpex_pbpin (ex, opcode, offset, 0, 0) + } + + # Compile a series of equality or range tests. + do i = 1, nranges { + x1 = XS(i); x2 = XE(i) + d_x1 = qpex_refd (ex, x1) + d_x2 = qpex_refd (ex, x2) + + if (IS_LEFTD(x1)) + call qpex_pbpin (ex, LEQD, d_x2, 0, 0) + else if (IS_RIGHTD(x2)) + call qpex_pbpin (ex, GEQD, d_x1, 0, 0) + else if (fp_equald (x1, x2)) + call qpex_pbpin (ex, EQLD, d_x1, d_x2, 0) + else + call qpex_pbpin (ex, RNGD, d_x1, d_x2, 0) + } + + # Compile a test and exit instruction. + call qpex_pbpin (ex, XIFF, 0, 0, 0) + + } else { + # Compile a lookup table test. Lookup tables may be + # either compressed or fully resolved. If compressed + # (the resolution of the table is less than that of the + # range data, e.g., for floating point lookup tables) a + # LUT bin may have as its value, in addition to the + # usual 0 or 1, the address of an interpreter subprogram + # to be executed to test data values mapping to that bin. + # The subprogram pointed to may in turn be another lookup + # table, hence in the general case a tree of lookup tables + # and little code segments may be compiled to implement + # a complex range list test. + + # Get the data range of the lookup table. + xmin = XS(1) + if (IS_LEFTD(xmin)) + xmin = XE(1) + xmax = XE(nranges) + if (IS_RIGHTD(xmax)) + xmax = XS(nranges) + + # Get the lookup table size. Use a fully resolved table + # if the data is integer and the number of bins required + # is modest. + + nbins = min (EX_MAXRRLUTLEN(ex), nranges * EX_LUTSCALE(ex)) + + # Determine the mapping from data space to table space. + xoffset = xmin + xscale = nbins / (xmax - xmin) + + # Allocate and initialize the lookup table descriptor. + lt = qpex_dballoc (ex, LEN_LTDES, TY_STRUCT) + call calloc (lut, nbins, TY_SHORT) + + LT_NEXT(lt) = EX_LTHEAD(ex) + EX_LTHEAD(ex) = lt + LT_TYPE(lt) = TY_DOUBLE + LT_LUTP(lt) = lut + LT_NBINS(lt) = nbins + LT_D0(lt) = xoffset + LT_DS(lt) = xscale + LT_LEFT(lt) = btoi (IS_LEFTD(XS(1))) + LT_RIGHT(lt) = btoi (IS_RIGHTD(XE(nranges))) + + # Compile the LUTX test instruction. Save a back pointer + # to the instruction so that we can edit the jump field in + # case a subprogram is compiled after the LUTXt. + + lutx = qpex_pbpos (ex) + if (dtype == TY_SHORT) + call qpex_pbpin (ex, LUTXS, offset, lt, 0) + else + call qpex_pbpin (ex, LUTXD, offset, lt, 0) + + xp = 1 + bin = 1 +continue_ + n_xs = xs + nranges + n_xe = xe + nranges + + # Initialize the lookup table. + do i = bin, nbins { + x1 = (i-1) / xscale + xoffset + x2 = i / xscale + xoffset + + # Get sub-rangelist for range x1:x2. + n_nranges = qpex_sublistd (x1, x2, + Memd[xs], Memd[xe], nranges, xp, + Memd[n_xs], Memd[n_xe]) + + if (n_nranges <= 0) { + Mems[lut+i-1] = 0 + + } else if (n_nranges == 1 && IS_LEFTD(Memd[n_xs]) && + IS_RIGHTD(Memd[n_xe])) { + + Mems[lut+i-1] = 1 + + } else { + # Compile the sub-rangelist as a subprogram. + + # First set the LUT bin to point to the subprogram. + # We cannot use the IP directly here since the LUT + # bins are short integer, so store the offset into + # the pb instead (guaranteed to be >= 4). + + Mems[lut+i-1] = qpex_pbpos(ex) - pb + + # Push a new context. + level = level + 1 + if (level > MAX_LEVELS) { + call eprintf ("%s: ") + call pargstr (qpexwarn) + call eprintf ("Excessive LUT nesting\n") + goto error_ + } + + # Save current LUT compilation context. + sv_xs[level] = xs + sv_xe[level] = xe + sv_xp[level] = xp + sv_xoffset[level] = xoffset + sv_xscale[level] = xscale + sv_nranges[level] = nranges + sv_lt[level] = lt + sv_bin[level] = i + sv_nbins[level] = nbins + sv_lut[level] = lut + sv_lutx[level] = lutx + + # Set up context for the new rangelist. + xs = n_xs + xe = n_xe + nranges = n_nranges + + goto next_ + } + } + + # Compile a test and exit instruction if the LUT calls any + # subprograms. + + if (qpex_pbpos(ex) - lutx > LEN_INSTRUCTION) + call qpex_pbpin (ex, XIFF, 0, 0, 0) + } +resume_ + # Resume lookup table compilation if exiting due to LUT-bin + # subprogram compilation. + + if (level > 0) { + # Pop saved context. + xs = sv_xs[level] + xe = sv_xe[level] + xp = sv_xp[level] + xoffset = sv_xoffset[level] + xscale = sv_xscale[level] + nranges = sv_nranges[level] + lt = sv_lt[level] + bin = sv_bin[level] + nbins = sv_nbins[level] + lut = sv_lut[level] + lutx = sv_lutx[level] + + # Compile a return from subprogram. + call qpex_pbpin (ex, RET, 0, 0, 0) + + # Patch up the original LUTX instruction to jump over the + # subprogram we have just finished compiling. + + IARG3(lutx) = qpex_pbpos (ex) + + # Resume compilation at the next LUT bin. + bin = bin + 1 + level = level - 1 + goto continue_ + } + } until (level <= 0) + + # Finish setting up the eterm descriptor. + ET_NINSTR(et) = (qpex_pbpos(ex) - ET_PROGPTR(et)) / LEN_INSTRUCTION + + return (OK) +error_ + call qpex_free (ex, pb_save, db_save) + return (ERR) +end diff --git a/sys/qpoe/gen/qpexcodei.x b/sys/qpoe/gen/qpexcodei.x new file mode 100644 index 00000000..db8cbc72 --- /dev/null +++ b/sys/qpoe/gen/qpexcodei.x @@ -0,0 +1,423 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../qpex.h" + +# QPEX_CODEGEN -- Generate interpreter metacode to evaluate the given +# expression. The new code is appended to the current compiled program, +# adding additional constraints which a data event will have to meet to +# pass the filter. + +int procedure qpex_codegeni (ex, atname, assignop, expr, offset, dtype) + +pointer ex #I qpex descriptor +char atname[ARB] #I attribute name (for expr regeneration) +char assignop[ARB] #I "=" or "+=" (for expr regeneration) +char expr[ARB] #I expression to be compiled +int offset #I typed offset of referenced attribute +int dtype #I datatype of referenced attribute + +int nbins, bin, xp +pointer lt, lut, lutx, pb +int x1, x2, xmin, xmax +int xlen, nranges, n_nranges, level, opcode, ip, i +pointer pb_save, db_save, xs_buf, xe_buf, xs, xe, n_xs, n_xe, et, prev + +int sv_xs[MAX_LEVELS], sv_xe[MAX_LEVELS] +pointer sv_lt[MAX_LEVELS], sv_lut[MAX_LEVELS], sv_lutx[MAX_LEVELS] +int sv_xp[MAX_LEVELS], sv_nranges[MAX_LEVELS], sv_bin[MAX_LEVELS] +int sv_nbins[MAX_LEVELS] + +int d_x1, d_x2 +real xoffset, xscale +real sv_xoffset[MAX_LEVELS], sv_xscale[MAX_LEVELS] + +define fp_equali($1==$2) + +bool complement +int maskval +int qp_ctoi() + +int qpex_parsei() +int stridxs(), btoi(), qpex_sublisti() +pointer qpex_dballoc(), qpex_dbpstr(), qpex_pbpos() +errchk qpex_dballoc, qpex_pbpin, malloc, calloc, realloc, qpex_parsei + +string qpexwarn "QPEX Warning" +define error_ 91 +define next_ 92 +define null_ 93 +define resume_ 94 +define bbmask_ 95 +define continue_ 96 +define XS Memi[xs+($1)-1] +define XE Memi[xe+($1)-1] + +begin + pb = EX_PB(ex) + + # Save the program state in case we have to abort. + call qpex_mark (ex, pb_save, db_save) + + # Allocate and initialize a new expression term descriptor, linking + # it onto the tail of the ETTERMs list. + + et = qpex_dballoc (ex, LEN_ETDES, TY_STRUCT) + + ET_ATTTYPE(et) = dtype + ET_ATTOFF(et) = offset + ET_ATNAME(et) = qpex_dbpstr (ex, atname) + ET_ASSIGNOP(et) = qpex_dbpstr (ex, assignop) + ET_EXPRTEXT(et) = qpex_dbpstr (ex, expr) + ET_PROGPTR(et) = qpex_pbpos (ex) + ET_DELETED(et) = NO + + prev = EX_ETTAIL(ex) + if (prev != NULL) + ET_NEXT(prev) = et + ET_NEXT(et) = NULL + EX_ETTAIL(ex) = et + if (EX_ETHEAD(ex) == NULL) + EX_ETHEAD(ex) = et + + ip = stridxs ("%", expr) + # Attempt to compile a bitmask test if `%' is found in the + # expression. Since bitmasks cannot be mixed with range list + # expressions, this case is handled separately. + + if (ip > 0) { + complement = false + level = 0 + + # Parse expression (very limited for this case). + for (ip=1; expr[ip] != EOS; ip=ip+1) { + switch (expr[ip]) { + case '!': + complement = !complement + case '(', '[': + level = level + 1 + case ')', ']': + level = level - 1 + case '%': + ip = ip + 1 + if (qp_ctoi (expr, ip, maskval) < 0) + goto bbmask_ + else + ip = ip - 1 + default: + goto bbmask_ + } + } + + # Verify paren level, handle errors. + if (level != 0) { +bbmask_ call eprintf ("%s: bad bitmask expression `%s'\n") + call pargstr (qpexwarn) + call pargstr (expr) + goto error_ + } + + # Compile the bitmask test. + if (complement) + maskval = not(maskval) + if (dtype == TY_SHORT) + call qpex_pbpin (ex, BTTXS, offset, maskval, 0) + else + call qpex_pbpin (ex, BTTXI, offset, maskval, 0) + + # Finish setting up the eterm descriptor. + ET_NINSTR(et) = 1 + return (OK) + } + + # Compile a general range list expression. The basic procedure is + # to parse the expression to produce an optimized binary range list, + # then either compile the range list as an explicit series of + # instructions or as a lookup table, depending upon the number of + # ranges. + + xlen = DEF_XLEN + call malloc (xs_buf, xlen, TY_INT) + call malloc (xe_buf, xlen, TY_INT) + + # Convert expr to a binary range list and set up the initial context. + # Ensure that the range list buffers are large enough to hold any + # sublists extracted during compilation. + + nranges = qpex_parsei (expr, xs_buf, xe_buf, xlen) + if (xlen < nranges * 2) { + xlen = nranges * 2 + call realloc (xs_buf, xlen, TY_INT) + call realloc (xe_buf, xlen, TY_INT) + } + + xs = xs_buf + xe = xe_buf + level = 0 + + repeat { +next_ + # Compile a new range list (or sublist). + if (nranges <= 0) { + # This shouldn't happen. +null_ call eprintf ("%s: null range list\n") + call pargstr (qpexwarn) + call qpex_pbpin (ex, PASS, 0, 0, 0) + + } else if (nranges == 1) { + # Output an instruction to load the data, perform the range + # test, and conditionally exit all in a single instruction. + + x1 = XS(1); x2 = XE(1) + d_x1 = x1 + d_x2 = x2 + + if (dtype == TY_SHORT) { + if (IS_LEFTI(x1) && IS_RIGHTI(x2)) + ; # pass everything (no tests) + else if (IS_LEFTI(x1)) + call qpex_pbpin (ex, LEQXS, offset, d_x2, 0) + else if (IS_RIGHTI(x2)) + call qpex_pbpin (ex, GEQXS, offset, d_x1, 0) + else if (fp_equali (x1, x2)) + call qpex_pbpin (ex, EQLXS, offset, d_x1, d_x2) + else + call qpex_pbpin (ex, RNGXS, offset, d_x1, d_x2) + } else { + if (IS_LEFTI(x1) && IS_RIGHTI(x2)) + ; # pass everything (no tests) + else if (IS_LEFTI(x1)) + call qpex_pbpin (ex, LEQXI, offset, d_x2, 0) + else if (IS_RIGHTI(x2)) + call qpex_pbpin (ex, GEQXI, offset, d_x1, 0) + else if (fp_equali (x1, x2)) + call qpex_pbpin (ex, EQLXI, offset, d_x1, d_x2) + else + call qpex_pbpin (ex, RNGXI, offset, d_x1, d_x2) + } + + } else if (nranges < EX_LUTMINRANGES(ex)) { + # If the number of ranges to be tested for the data is small, + # compile explicit code to perform the range tests directly. + # Otherwise skip forward and compile a lookup table instead. + # In either case, the function of the instructions compiled + # is to test the data loaded into the register above, setting + # the value of PASS to true if the data lies in any of the + # indicated ranges. + + # Check for !X, which is indicated in range list form by a + # two element list bracketing the X on each side. + + if (nranges == 2) + if (IS_LEFTI(XS(1)) && IS_RIGHTI(XE(2))) + if (XE(1)+1 == XS(2)-1) { + if (dtype == TY_SHORT) + opcode = NEQXS + else + opcode = NEQXI + call qpex_pbpin (ex, opcode, offset, XE(1)+1, 0) + goto resume_ + } + + # If at level zero, output instruction to load data into + # register and initialize PASS to false. Don't bother if + # compiling a subprogram, as these operations will already + # have been performed by the caller. + + if (level == 0) { + if (dtype == TY_SHORT) + opcode = LDSI + else + opcode = LDII + call qpex_pbpin (ex, opcode, offset, 0, 0) + } + + # Compile a series of equality or range tests. + do i = 1, nranges { + x1 = XS(i); x2 = XE(i) + d_x1 = x1 + d_x2 = x2 + + if (IS_LEFTI(x1)) + call qpex_pbpin (ex, LEQI, d_x2, 0, 0) + else if (IS_RIGHTI(x2)) + call qpex_pbpin (ex, GEQI, d_x1, 0, 0) + else if (fp_equali (x1, x2)) + call qpex_pbpin (ex, EQLI, d_x1, d_x2, 0) + else + call qpex_pbpin (ex, RNGI, d_x1, d_x2, 0) + } + + # Compile a test and exit instruction. + call qpex_pbpin (ex, XIFF, 0, 0, 0) + + } else { + # Compile a lookup table test. Lookup tables may be + # either compressed or fully resolved. If compressed + # (the resolution of the table is less than that of the + # range data, e.g., for floating point lookup tables) a + # LUT bin may have as its value, in addition to the + # usual 0 or 1, the address of an interpreter subprogram + # to be executed to test data values mapping to that bin. + # The subprogram pointed to may in turn be another lookup + # table, hence in the general case a tree of lookup tables + # and little code segments may be compiled to implement + # a complex range list test. + + # Get the data range of the lookup table. + xmin = XS(1) + if (IS_LEFTI(xmin)) + xmin = XE(1) + xmax = XE(nranges) + if (IS_RIGHTI(xmax)) + xmax = XS(nranges) + + # Get the lookup table size. Use a fully resolved table + # if the data is integer and the number of bins required + # is modest. + + nbins = xmax - xmin + 1 + if (nbins > EX_MAXFRLUTLEN(ex)) + nbins = min (EX_MAXRRLUTLEN(ex), + nranges * EX_LUTSCALE(ex)) + + # Determine the mapping from data space to table space. + xoffset = xmin + xscale = nbins / (xmax - xmin + 1) + + # Allocate and initialize the lookup table descriptor. + lt = qpex_dballoc (ex, LEN_LTDES, TY_STRUCT) + call calloc (lut, nbins, TY_SHORT) + + LT_NEXT(lt) = EX_LTHEAD(ex) + EX_LTHEAD(ex) = lt + LT_TYPE(lt) = TY_INT + LT_LUTP(lt) = lut + LT_NBINS(lt) = nbins + LT_I0(lt) = xoffset + LT_IS(lt) = xscale + LT_LEFT(lt) = btoi (IS_LEFTI(XS(1))) + LT_RIGHT(lt) = btoi (IS_RIGHTI(XE(nranges))) + + # Compile the LUTX test instruction. Save a back pointer + # to the instruction so that we can edit the jump field in + # case a subprogram is compiled after the LUTXt. + + lutx = qpex_pbpos (ex) + if (dtype == TY_SHORT) + call qpex_pbpin (ex, LUTXS, offset, lt, 0) + else + call qpex_pbpin (ex, LUTXI, offset, lt, 0) + + xp = 1 + bin = 1 +continue_ + n_xs = xs + nranges + n_xe = xe + nranges + + # Initialize the lookup table. + do i = bin, nbins { + x1 = (i-1) / xscale + xoffset + x2 = i / xscale + xoffset - 1 + + # Get sub-rangelist for range x1:x2. + n_nranges = qpex_sublisti (x1, x2, + Memi[xs], Memi[xe], nranges, xp, + Memi[n_xs], Memi[n_xe]) + + if (n_nranges <= 0) { + Mems[lut+i-1] = 0 + + } else if (n_nranges == 1 && IS_LEFTI(Memi[n_xs]) && + IS_RIGHTI(Memi[n_xe])) { + + Mems[lut+i-1] = 1 + + } else { + # Compile the sub-rangelist as a subprogram. + + # First set the LUT bin to point to the subprogram. + # We cannot use the IP directly here since the LUT + # bins are short integer, so store the offset into + # the pb instead (guaranteed to be >= 4). + + Mems[lut+i-1] = qpex_pbpos(ex) - pb + + # Push a new context. + level = level + 1 + if (level > MAX_LEVELS) { + call eprintf ("%s: ") + call pargstr (qpexwarn) + call eprintf ("Excessive LUT nesting\n") + goto error_ + } + + # Save current LUT compilation context. + sv_xs[level] = xs + sv_xe[level] = xe + sv_xp[level] = xp + sv_xoffset[level] = xoffset + sv_xscale[level] = xscale + sv_nranges[level] = nranges + sv_lt[level] = lt + sv_bin[level] = i + sv_nbins[level] = nbins + sv_lut[level] = lut + sv_lutx[level] = lutx + + # Set up context for the new rangelist. + xs = n_xs + xe = n_xe + nranges = n_nranges + + goto next_ + } + } + + # Compile a test and exit instruction if the LUT calls any + # subprograms. + + if (qpex_pbpos(ex) - lutx > LEN_INSTRUCTION) + call qpex_pbpin (ex, XIFF, 0, 0, 0) + } +resume_ + # Resume lookup table compilation if exiting due to LUT-bin + # subprogram compilation. + + if (level > 0) { + # Pop saved context. + xs = sv_xs[level] + xe = sv_xe[level] + xp = sv_xp[level] + xoffset = sv_xoffset[level] + xscale = sv_xscale[level] + nranges = sv_nranges[level] + lt = sv_lt[level] + bin = sv_bin[level] + nbins = sv_nbins[level] + lut = sv_lut[level] + lutx = sv_lutx[level] + + # Compile a return from subprogram. + call qpex_pbpin (ex, RET, 0, 0, 0) + + # Patch up the original LUTX instruction to jump over the + # subprogram we have just finished compiling. + + IARG3(lutx) = qpex_pbpos (ex) + + # Resume compilation at the next LUT bin. + bin = bin + 1 + level = level - 1 + goto continue_ + } + } until (level <= 0) + + # Finish setting up the eterm descriptor. + ET_NINSTR(et) = (qpex_pbpos(ex) - ET_PROGPTR(et)) / LEN_INSTRUCTION + + return (OK) +error_ + call qpex_free (ex, pb_save, db_save) + return (ERR) +end diff --git a/sys/qpoe/gen/qpexcoder.x b/sys/qpoe/gen/qpexcoder.x new file mode 100644 index 00000000..30e1d85b --- /dev/null +++ b/sys/qpoe/gen/qpexcoder.x @@ -0,0 +1,368 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../qpex.h" + +# QPEX_CODEGEN -- Generate interpreter metacode to evaluate the given +# expression. The new code is appended to the current compiled program, +# adding additional constraints which a data event will have to meet to +# pass the filter. + +int procedure qpex_codegenr (ex, atname, assignop, expr, offset, dtype) + +pointer ex #I qpex descriptor +char atname[ARB] #I attribute name (for expr regeneration) +char assignop[ARB] #I "=" or "+=" (for expr regeneration) +char expr[ARB] #I expression to be compiled +int offset #I typed offset of referenced attribute +int dtype #I datatype of referenced attribute + +int nbins, bin, xp +pointer lt, lut, lutx, pb +real x1, x2, xmin, xmax +int xlen, nranges, n_nranges, level, opcode, ip, i +pointer pb_save, db_save, xs_buf, xe_buf, xs, xe, n_xs, n_xe, et, prev + +real sv_xs[MAX_LEVELS], sv_xe[MAX_LEVELS] +pointer sv_lt[MAX_LEVELS], sv_lut[MAX_LEVELS], sv_lutx[MAX_LEVELS] +int sv_xp[MAX_LEVELS], sv_nranges[MAX_LEVELS], sv_bin[MAX_LEVELS] +int sv_nbins[MAX_LEVELS] + +real d_x1, d_x2 +real xoffset, xscale +real sv_xoffset[MAX_LEVELS], sv_xscale[MAX_LEVELS] + +bool fp_equalr() + + +int qpex_parser() +int stridxs(), btoi(), qpex_sublistr() +pointer qpex_dballoc(), qpex_dbpstr(), qpex_pbpos() +errchk qpex_dballoc, qpex_pbpin, malloc, calloc, realloc, qpex_parser + +string qpexwarn "QPEX Warning" +define error_ 91 +define next_ 92 +define null_ 93 +define resume_ 94 +define bbmask_ 95 +define continue_ 96 +define XS Memr[xs+($1)-1] +define XE Memr[xe+($1)-1] + +begin + pb = EX_PB(ex) + + # Save the program state in case we have to abort. + call qpex_mark (ex, pb_save, db_save) + + # Allocate and initialize a new expression term descriptor, linking + # it onto the tail of the ETTERMs list. + + et = qpex_dballoc (ex, LEN_ETDES, TY_STRUCT) + + ET_ATTTYPE(et) = dtype + ET_ATTOFF(et) = offset + ET_ATNAME(et) = qpex_dbpstr (ex, atname) + ET_ASSIGNOP(et) = qpex_dbpstr (ex, assignop) + ET_EXPRTEXT(et) = qpex_dbpstr (ex, expr) + ET_PROGPTR(et) = qpex_pbpos (ex) + ET_DELETED(et) = NO + + prev = EX_ETTAIL(ex) + if (prev != NULL) + ET_NEXT(prev) = et + ET_NEXT(et) = NULL + EX_ETTAIL(ex) = et + if (EX_ETHEAD(ex) == NULL) + EX_ETHEAD(ex) = et + + ip = stridxs ("%", expr) + # Bitmask tests are meaningless for floating point data. + if (ip > 0) { + call eprintf ("%s: bitmasks not permitted for floating data\n") + call pargstr (qpexwarn) + goto error_ + } + + # Compile a general range list expression. The basic procedure is + # to parse the expression to produce an optimized binary range list, + # then either compile the range list as an explicit series of + # instructions or as a lookup table, depending upon the number of + # ranges. + + xlen = DEF_XLEN + call malloc (xs_buf, xlen, TY_REAL) + call malloc (xe_buf, xlen, TY_REAL) + + # Convert expr to a binary range list and set up the initial context. + # Ensure that the range list buffers are large enough to hold any + # sublists extracted during compilation. + + nranges = qpex_parser (expr, xs_buf, xe_buf, xlen) + if (xlen < nranges * 2) { + xlen = nranges * 2 + call realloc (xs_buf, xlen, TY_REAL) + call realloc (xe_buf, xlen, TY_REAL) + } + + xs = xs_buf + xe = xe_buf + level = 0 + + repeat { +next_ + # Compile a new range list (or sublist). + if (nranges <= 0) { + # This shouldn't happen. +null_ call eprintf ("%s: null range list\n") + call pargstr (qpexwarn) + call qpex_pbpin (ex, PASS, 0, 0, 0) + + } else if (nranges == 1) { + # Output an instruction to load the data, perform the range + # test, and conditionally exit all in a single instruction. + + x1 = XS(1); x2 = XE(1) + d_x1 = x1 + d_x2 = x2 + + if (dtype == TY_SHORT) { + if (IS_LEFTR(x1) && IS_RIGHTR(x2)) + ; # pass everything (no tests) + else if (IS_LEFTR(x1)) + call qpex_pbpin (ex, LEQXS, offset, d_x2, 0) + else if (IS_RIGHTR(x2)) + call qpex_pbpin (ex, GEQXS, offset, d_x1, 0) + else if (fp_equalr (x1, x2)) + call qpex_pbpin (ex, EQLXS, offset, d_x1, d_x2) + else + call qpex_pbpin (ex, RNGXS, offset, d_x1, d_x2) + } else { + if (IS_LEFTR(x1) && IS_RIGHTR(x2)) + ; # pass everything (no tests) + else if (IS_LEFTR(x1)) + call qpex_pbpin (ex, LEQXR, offset, d_x2, 0) + else if (IS_RIGHTR(x2)) + call qpex_pbpin (ex, GEQXR, offset, d_x1, 0) + else if (fp_equalr (x1, x2)) + call qpex_pbpin (ex, EQLXR, offset, d_x1, d_x2) + else + call qpex_pbpin (ex, RNGXR, offset, d_x1, d_x2) + } + + } else if (nranges < EX_LUTMINRANGES(ex)) { + # If the number of ranges to be tested for the data is small, + # compile explicit code to perform the range tests directly. + # Otherwise skip forward and compile a lookup table instead. + # In either case, the function of the instructions compiled + # is to test the data loaded into the register above, setting + # the value of PASS to true if the data lies in any of the + # indicated ranges. + + # Check for !X, which is indicated in range list form by a + # two element list bracketing the X on each side. + + if (nranges == 2) + if (IS_LEFTR(XS(1)) && IS_RIGHTR(XE(2))) + if (fp_equalr (XE(1), XS(2))) { + call qpex_pbpin (ex, NEQXR, offset, XE(1), 0) + goto resume_ + } + + # If at level zero, output instruction to load data into + # register and initialize PASS to false. Don't bother if + # compiling a subprogram, as these operations will already + # have been performed by the caller. + + if (level == 0) { + opcode = LDRR + call qpex_pbpin (ex, opcode, offset, 0, 0) + } + + # Compile a series of equality or range tests. + do i = 1, nranges { + x1 = XS(i); x2 = XE(i) + d_x1 = x1 + d_x2 = x2 + + if (IS_LEFTR(x1)) + call qpex_pbpin (ex, LEQR, d_x2, 0, 0) + else if (IS_RIGHTR(x2)) + call qpex_pbpin (ex, GEQR, d_x1, 0, 0) + else if (fp_equalr (x1, x2)) + call qpex_pbpin (ex, EQLR, d_x1, d_x2, 0) + else + call qpex_pbpin (ex, RNGR, d_x1, d_x2, 0) + } + + # Compile a test and exit instruction. + call qpex_pbpin (ex, XIFF, 0, 0, 0) + + } else { + # Compile a lookup table test. Lookup tables may be + # either compressed or fully resolved. If compressed + # (the resolution of the table is less than that of the + # range data, e.g., for floating point lookup tables) a + # LUT bin may have as its value, in addition to the + # usual 0 or 1, the address of an interpreter subprogram + # to be executed to test data values mapping to that bin. + # The subprogram pointed to may in turn be another lookup + # table, hence in the general case a tree of lookup tables + # and little code segments may be compiled to implement + # a complex range list test. + + # Get the data range of the lookup table. + xmin = XS(1) + if (IS_LEFTR(xmin)) + xmin = XE(1) + xmax = XE(nranges) + if (IS_RIGHTR(xmax)) + xmax = XS(nranges) + + # Get the lookup table size. Use a fully resolved table + # if the data is integer and the number of bins required + # is modest. + + nbins = min (EX_MAXRRLUTLEN(ex), nranges * EX_LUTSCALE(ex)) + + # Determine the mapping from data space to table space. + xoffset = xmin + xscale = nbins / (xmax - xmin) + + # Allocate and initialize the lookup table descriptor. + lt = qpex_dballoc (ex, LEN_LTDES, TY_STRUCT) + call calloc (lut, nbins, TY_SHORT) + + LT_NEXT(lt) = EX_LTHEAD(ex) + EX_LTHEAD(ex) = lt + LT_TYPE(lt) = TY_REAL + LT_LUTP(lt) = lut + LT_NBINS(lt) = nbins + LT_R0(lt) = xoffset + LT_RS(lt) = xscale + LT_LEFT(lt) = btoi (IS_LEFTR(XS(1))) + LT_RIGHT(lt) = btoi (IS_RIGHTR(XE(nranges))) + + # Compile the LUTX test instruction. Save a back pointer + # to the instruction so that we can edit the jump field in + # case a subprogram is compiled after the LUTXt. + + lutx = qpex_pbpos (ex) + if (dtype == TY_SHORT) + call qpex_pbpin (ex, LUTXS, offset, lt, 0) + else + call qpex_pbpin (ex, LUTXR, offset, lt, 0) + + xp = 1 + bin = 1 +continue_ + n_xs = xs + nranges + n_xe = xe + nranges + + # Initialize the lookup table. + do i = bin, nbins { + x1 = (i-1) / xscale + xoffset + x2 = i / xscale + xoffset + + # Get sub-rangelist for range x1:x2. + n_nranges = qpex_sublistr (x1, x2, + Memr[xs], Memr[xe], nranges, xp, + Memr[n_xs], Memr[n_xe]) + + if (n_nranges <= 0) { + Mems[lut+i-1] = 0 + + } else if (n_nranges == 1 && IS_LEFTR(Memr[n_xs]) && + IS_RIGHTR(Memr[n_xe])) { + + Mems[lut+i-1] = 1 + + } else { + # Compile the sub-rangelist as a subprogram. + + # First set the LUT bin to point to the subprogram. + # We cannot use the IP directly here since the LUT + # bins are short integer, so store the offset into + # the pb instead (guaranteed to be >= 4). + + Mems[lut+i-1] = qpex_pbpos(ex) - pb + + # Push a new context. + level = level + 1 + if (level > MAX_LEVELS) { + call eprintf ("%s: ") + call pargstr (qpexwarn) + call eprintf ("Excessive LUT nesting\n") + goto error_ + } + + # Save current LUT compilation context. + sv_xs[level] = xs + sv_xe[level] = xe + sv_xp[level] = xp + sv_xoffset[level] = xoffset + sv_xscale[level] = xscale + sv_nranges[level] = nranges + sv_lt[level] = lt + sv_bin[level] = i + sv_nbins[level] = nbins + sv_lut[level] = lut + sv_lutx[level] = lutx + + # Set up context for the new rangelist. + xs = n_xs + xe = n_xe + nranges = n_nranges + + goto next_ + } + } + + # Compile a test and exit instruction if the LUT calls any + # subprograms. + + if (qpex_pbpos(ex) - lutx > LEN_INSTRUCTION) + call qpex_pbpin (ex, XIFF, 0, 0, 0) + } +resume_ + # Resume lookup table compilation if exiting due to LUT-bin + # subprogram compilation. + + if (level > 0) { + # Pop saved context. + xs = sv_xs[level] + xe = sv_xe[level] + xp = sv_xp[level] + xoffset = sv_xoffset[level] + xscale = sv_xscale[level] + nranges = sv_nranges[level] + lt = sv_lt[level] + bin = sv_bin[level] + nbins = sv_nbins[level] + lut = sv_lut[level] + lutx = sv_lutx[level] + + # Compile a return from subprogram. + call qpex_pbpin (ex, RET, 0, 0, 0) + + # Patch up the original LUTX instruction to jump over the + # subprogram we have just finished compiling. + + IARG3(lutx) = qpex_pbpos (ex) + + # Resume compilation at the next LUT bin. + bin = bin + 1 + level = level - 1 + goto continue_ + } + } until (level <= 0) + + # Finish setting up the eterm descriptor. + ET_NINSTR(et) = (qpex_pbpos(ex) - ET_PROGPTR(et)) / LEN_INSTRUCTION + + return (OK) +error_ + call qpex_free (ex, pb_save, db_save) + return (ERR) +end diff --git a/sys/qpoe/gen/qpexparsed.x b/sys/qpoe/gen/qpexparsed.x new file mode 100644 index 00000000..ec625bd8 --- /dev/null +++ b/sys/qpoe/gen/qpexparsed.x @@ -0,0 +1,372 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "../qpex.h" + +.help qpexparse +.nf -------------------------------------------------------------------------- +QPEXPARSE -- Code to parse an event attribute expression, producing a binary +range list as output. + + nranges = qpex_parse[ird] (expr, xs, xe, xlen) + +The calling sequence for the parse routine is shown above. The arguments XS +and XE are pointers to dynamically allocated arrays of length XLEN and type +[IRD]. These arrays should be allocated in the calling program before calling +the parser, and deallocated when no longer needed. Reallocation to increase +the array length is automatic if the arrays fill during parsing. DTYPE should +be the same datatype as the attribute with which the list is associated. + +The form of an event attribute expression may be a list of values, + + attribute = n +or + attribute = m, n, ... + +a list of inclusive or exclusive ranges, + + attribute = m:n, !p:q + +including open ranges, + + attribute = :n, p:q + +or any combination of the above (excluding combinations of bitmasks and values +or ranges, which are mutually exclusive): + + attribute = :n, a, b, p:q, !(m, e:f) + +Parenthesis may be used for grouping where desired, e.g., + + attribute = (:n, a, b, p:q, !(m, e:f)) + +An additional form of the event attribute expression allows use of a bitmask +to specify the acceptable values, e.g., + + attribute = %17B +or + attribute = !%17B + +however, bitmasks are incompatible with range lists, and should be recognized +and dealt with elsewhere (bitmasks may not be combined with range lists in +the same expression term). + +We are concerned here only with the attribute value list itself, i.e., +everything to the right of the equals sign in the examples above. This list +should be extracted and placed into a string containing a single line of +text before we are called. Attribute value lists may be any length, but +backslash continuation, file inclusion (or whatever means is used to form +the attribute value list) is assumed to be handled at a higher level. + +The output of this package is an ordered boolean valued binary range list +with type integer, real, or double breakpoints (i.e., the breakpoints are the +same datatype as the attribute itself, but the range values are zero or one). +The range list defines the initial value, final value, and any interior +breakpoints where the attribute value changes state. Expression optimization +is used to minimize the number of breakpoints (i.e., eliminate redundant +breakpoints, such as a range within a range). + +Output range list format: + + xs[1] xe[1] + xs[2] xe[2] + ... + xs[N] xe[N] + +Where each range is inclusive and only "true" ranges are shown. If XS[1] is +LEFT a open-left range (:n) is indicated; if XE[N] is RIGHT an open-right +range (n:) is indicated. In an integer range list, isolated points appear +as a single range with (xe[i]=xs[i]). In a real or double range list, +isolated points are represented as finite ranges with a width on the order of +the machine epsilon. +.endhelp --------------------------------------------------------------------- + +define DEF_XLEN 256 # default output range list length +define INC_XLEN 256 # increment to above +define DEF_VLEN 512 # default breakpoint list length +define INC_VLEN 512 # increment to above +define MAX_NEST 20 # parser stack depth + +define STEP 1 # step at boundary of closed range +define ZERO 1000 # step at boundary of open range + +define XV Memd[xv+($1)-1] # reference x position values +define UV Memi[uv+($1)-1] # unique flags for x value pairs +define SV Memi[sv+($1)-1] # reference breakpoint step values + + +# QPEX_PARSE -- Convert the given attribute value list into a binary +# range list, returning the number of ranges as the function value. + +int procedure qpex_parsed (expr, xs, xe, xlen) + +char expr[ARB] #I attribute value list to be parsed +pointer xs #U pointer to array of start-range values +pointer xe #U pointer to array of end-range values +int xlen #U allocated length of XS, XE arrays + +bool range +pointer xv, uv, sv +double xstart, xend, xmin, temp, x, n_xs, n_xe +int vlen, nrg, ip, op, ch, ip_start, i, j, jval, r1, r2, y, v, ov, dy +int token[MAX_NEST], tokval[MAX_NEST], lev, itemp, umin +errchk syserr, malloc, realloc +define pop_ 91 + +double dtemp +bool bval, fp_equald() +int qp_ctod() + +begin + vlen = DEF_VLEN + call malloc (xv, vlen, TY_DOUBLE) + call malloc (uv, vlen, TY_INT) + call malloc (sv, vlen, TY_INT) + + lev = 0 + nrg = 0 + + # Parse the expression string and compile the raw, unoptimized + # breakpoint list in the order in which the breakpoints occur in + # the string. + + for (ip=1; expr[ip] != EOS; ) { + # Skip whitespace. + for (ch=expr[ip]; IS_WHITE(ch) || ch == '\n'; ch=expr[ip]) + ip = ip + 1 + + # Extract and process token. + switch (ch) { + case EOS: + # At end of string. + if (lev > 0) + goto pop_ + else + break + + case ',': + # Comma list token delmiter. + ip = ip + 1 + goto pop_ + + case '!', '(': + # Syntactical element - push on stack. + ip = ip + 1 + lev = lev + 1 + if (lev > MAX_NEST) + call syserr (SYS_QPEXLEVEL) + token[lev] = ch + tokval[lev] = nrg + 1 + + case ')': + # Close parenthesized group and pop parser stack. + ip = ip + 1 + if (lev < 1) + call syserr (SYS_QPEXMLP) + else if (token[lev] != '(') + call syserr (SYS_QPEXRPAREN) + lev = lev - 1 + goto pop_ + + default: + # Process a range term. + ip_start = ip + + # Scan the M in M:N. + if (qp_ctod (expr, ip, dtemp) <= 0) + xstart = LEFTD + else + xstart = dtemp + + # Scan the : in M:N. The notation M-N is also accepted, + # provided the token - immediately follows the token M. + + while (IS_WHITE(expr[ip])) + ip = ip + 1 + range = (expr[ip] == ':') + if (range) + ip = ip + 1 + else if (!IS_LEFTD (xstart)) { + range = (expr[ip] == '-') + if (range) + ip = ip + 1 + } + + # Scan the N in M:N. + if (range) { + if (qp_ctod (expr, ip, dtemp) <= 0) + xend = RIGHTD + else + xend = dtemp + } else + xend = xstart + + # Fix things if the user entered M:M explicitly. + if (range) + if (fp_equald (xstart, xend)) + range = false + + # Expand a single point into a range. For an integer list + # this produces M:M+1; for a floating list M-eps:M+eps. + # Verify ordering and that something recognizable was scanned. + + if (!range) { + if (IS_LEFTD(xstart)) + call syserr (SYS_QPEXBADRNG) + } else { + if (xstart > xend) { + temp = xstart; xstart = xend; xend = temp + } + } + + # Make more space if vectors fill up. + if (nrg+4 > vlen) { + vlen = vlen + INC_VLEN + call realloc (xv, vlen, TY_DOUBLE) + call realloc (uv, vlen, TY_INT) + call realloc (sv, vlen, TY_INT) + } + + # Save range on intermediate breakpoint list. + nrg = nrg + 1 + XV(nrg) = xstart + UV(nrg) = 0 + SV(nrg) = STEP + + nrg = nrg + 1 + XV(nrg) = xend + UV(nrg) = 1 + SV(nrg) = -STEP +pop_ + # Pop parser stack. + if (lev > 0) + if (token[lev] == '!') { + # Invert a series of breakpoints. + do i = tokval[lev], nrg { + if (SV(i) == STEP) # invert + SV(i) = -ZERO + else if (SV(i) == -STEP) + SV(i) = ZERO + else if (SV(i) == ZERO) # undo + SV(i) = -STEP + else if (SV(i) == -ZERO) + SV(i) = STEP + } + lev = lev - 1 + } + } + } + + # If the first range entered by the user is an exclude range, + # e.g., "(!N)" or "(!(expr))" this implies that all other values + # are acceptable. Add the open range ":" to the end of the range + # list to indicate this, i.e., convert "!N" to ":,!N". + + if (SV(1) == -ZERO) { + nrg = nrg + 1 + XV(nrg) = LEFTD + UV(nrg) = 0 + SV(nrg) = STEP + + nrg = nrg + 1 + XV(nrg) = RIGHTD + UV(nrg) = 1 + SV(nrg) = -STEP + } + + # Sort the breakpoint list. + do j = 1, nrg { + xmin = XV(j); umin = UV(j) + jval = j + do i = j+1, nrg { + bval = (XV(i) < xmin) + if (!bval) + if (abs (XV(i) - xmin) < 1.0E-5) + bval = (fp_equald(XV(i),xmin) && UV(i) < umin) + if (bval) { + xmin = XV(i); umin = UV(i) + jval = i + } + } + if (jval != j) { + temp = XV(j); XV(j) = XV(jval); XV(jval) = temp + itemp = UV(j); UV(j) = UV(jval); UV(jval) = itemp + itemp = SV(j); SV(j) = SV(jval); SV(jval) = itemp + } + } + + # Initialize the output arrays if they were passed in as null. + if (xlen <= 0) { + xlen = DEF_XLEN + call malloc (xs, xlen, TY_DOUBLE) + call malloc (xe, xlen, TY_DOUBLE) + } + + # Collapse sequences of redundant breakpoints into a single + # breakpoint, clipping the running sum value to the range 0-1. + # Accumulate and output successive nonzero ranges. + + op = 1 + ov = 0 + y = 0 + + for (r1=1; r1 <= nrg; r1=r2+1) { + # Get a range of breakpoint entries for a single XV position. + for (r2=r1; r2 <= nrg; r2=r2+1) { + bval = (UV(r2) != UV(r1)) + if (!bval) { + bval = (abs (XV(r2) - XV(r1)) > 1.0E-5) + if (!bval) + bval = !fp_equald(XV(r2),XV(r1)) + } + if (bval) + break + } + r2 = r2 - 1 + + # Collapse into a single breakpoint. + x = XV(r1) + dy = SV(r1) + do i = r1 + 1, r2 + dy = dy + SV(i) + y = y + dy + + # Clip value to the range 0-1. + v = max(0, min(1, y)) + + # Accumulate a range of nonzero value. This eliminates redundant + # points lying within a range which is already set high. + + if (v == 1 && ov == 0) { + n_xs = x + ov = 1 + } else if (v == 0 && ov == 1) { + n_xe = x + ov = 2 + } + + # Output a range. + if (ov == 2) { + if (op > xlen) { + xlen = xlen + INC_XLEN + call realloc (xs, xlen, TY_DOUBLE) + call realloc (xe, xlen, TY_DOUBLE) + } + + Memd[xs+op-1] = n_xs + Memd[xe+op-1] = n_xe + op = op + 1 + + ov = 0 + } + } + + # All done; discard breakpoint buffers. + call mfree (xv, TY_DOUBLE) + call mfree (uv, TY_INT) + call mfree (sv, TY_INT) + + return (op - 1) +end diff --git a/sys/qpoe/gen/qpexparsei.x b/sys/qpoe/gen/qpexparsei.x new file mode 100644 index 00000000..17d6a569 --- /dev/null +++ b/sys/qpoe/gen/qpexparsei.x @@ -0,0 +1,363 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "../qpex.h" + +.help qpexparse +.nf -------------------------------------------------------------------------- +QPEXPARSE -- Code to parse an event attribute expression, producing a binary +range list as output. + + nranges = qpex_parse[ird] (expr, xs, xe, xlen) + +The calling sequence for the parse routine is shown above. The arguments XS +and XE are pointers to dynamically allocated arrays of length XLEN and type +[IRD]. These arrays should be allocated in the calling program before calling +the parser, and deallocated when no longer needed. Reallocation to increase +the array length is automatic if the arrays fill during parsing. DTYPE should +be the same datatype as the attribute with which the list is associated. + +The form of an event attribute expression may be a list of values, + + attribute = n +or + attribute = m, n, ... + +a list of inclusive or exclusive ranges, + + attribute = m:n, !p:q + +including open ranges, + + attribute = :n, p:q + +or any combination of the above (excluding combinations of bitmasks and values +or ranges, which are mutually exclusive): + + attribute = :n, a, b, p:q, !(m, e:f) + +Parenthesis may be used for grouping where desired, e.g., + + attribute = (:n, a, b, p:q, !(m, e:f)) + +An additional form of the event attribute expression allows use of a bitmask +to specify the acceptable values, e.g., + + attribute = %17B +or + attribute = !%17B + +however, bitmasks are incompatible with range lists, and should be recognized +and dealt with elsewhere (bitmasks may not be combined with range lists in +the same expression term). + +We are concerned here only with the attribute value list itself, i.e., +everything to the right of the equals sign in the examples above. This list +should be extracted and placed into a string containing a single line of +text before we are called. Attribute value lists may be any length, but +backslash continuation, file inclusion (or whatever means is used to form +the attribute value list) is assumed to be handled at a higher level. + +The output of this package is an ordered boolean valued binary range list +with type integer, real, or double breakpoints (i.e., the breakpoints are the +same datatype as the attribute itself, but the range values are zero or one). +The range list defines the initial value, final value, and any interior +breakpoints where the attribute value changes state. Expression optimization +is used to minimize the number of breakpoints (i.e., eliminate redundant +breakpoints, such as a range within a range). + +Output range list format: + + xs[1] xe[1] + xs[2] xe[2] + ... + xs[N] xe[N] + +Where each range is inclusive and only "true" ranges are shown. If XS[1] is +LEFT a open-left range (:n) is indicated; if XE[N] is RIGHT an open-right +range (n:) is indicated. In an integer range list, isolated points appear +as a single range with (xe[i]=xs[i]). In a real or double range list, +isolated points are represented as finite ranges with a width on the order of +the machine epsilon. +.endhelp --------------------------------------------------------------------- + +define DEF_XLEN 256 # default output range list length +define INC_XLEN 256 # increment to above +define DEF_VLEN 512 # default breakpoint list length +define INC_VLEN 512 # increment to above +define MAX_NEST 20 # parser stack depth + +define STEP 1 # step at boundary of closed range +define ZERO 1000 # step at boundary of open range + +define XV Memi[xv+($1)-1] # reference x position values +define UV Memi[uv+($1)-1] # unique flags for x value pairs +define SV Memi[sv+($1)-1] # reference breakpoint step values + + +# QPEX_PARSE -- Convert the given attribute value list into a binary +# range list, returning the number of ranges as the function value. + +int procedure qpex_parsei (expr, xs, xe, xlen) + +char expr[ARB] #I attribute value list to be parsed +pointer xs #U pointer to array of start-range values +pointer xe #U pointer to array of end-range values +int xlen #U allocated length of XS, XE arrays + +bool range +pointer xv, uv, sv +int xstart, xend, xmin, temp, x, n_xs, n_xe +int vlen, nrg, ip, op, ch, ip_start, i, j, jval, r1, r2, y, v, ov, dy +int token[MAX_NEST], tokval[MAX_NEST], lev, itemp, umin +errchk syserr, malloc, realloc +define pop_ 91 + +int qp_ctoi() +define fp_equali($1==$2) + +begin + vlen = DEF_VLEN + call malloc (xv, vlen, TY_INT) + call malloc (uv, vlen, TY_INT) + call malloc (sv, vlen, TY_INT) + + lev = 0 + nrg = 0 + + # Parse the expression string and compile the raw, unoptimized + # breakpoint list in the order in which the breakpoints occur in + # the string. + + for (ip=1; expr[ip] != EOS; ) { + # Skip whitespace. + for (ch=expr[ip]; IS_WHITE(ch) || ch == '\n'; ch=expr[ip]) + ip = ip + 1 + + # Extract and process token. + switch (ch) { + case EOS: + # At end of string. + if (lev > 0) + goto pop_ + else + break + + case ',': + # Comma list token delmiter. + ip = ip + 1 + goto pop_ + + case '!', '(': + # Syntactical element - push on stack. + ip = ip + 1 + lev = lev + 1 + if (lev > MAX_NEST) + call syserr (SYS_QPEXLEVEL) + token[lev] = ch + tokval[lev] = nrg + 1 + + case ')': + # Close parenthesized group and pop parser stack. + ip = ip + 1 + if (lev < 1) + call syserr (SYS_QPEXMLP) + else if (token[lev] != '(') + call syserr (SYS_QPEXRPAREN) + lev = lev - 1 + goto pop_ + + default: + # Process a range term. + ip_start = ip + + # Scan the M in M:N. + if (qp_ctoi (expr, ip, xstart) <= 0) + xstart = LEFTI + + # Scan the : in M:N. The notation M-N is also accepted, + # provided the token - immediately follows the token M. + + while (IS_WHITE(expr[ip])) + ip = ip + 1 + range = (expr[ip] == ':') + if (range) + ip = ip + 1 + else if (!IS_LEFTI (xstart)) { + range = (expr[ip] == '-') + if (range) + ip = ip + 1 + } + + # Scan the N in M:N. + if (range) { + if (qp_ctoi (expr, ip, xend) <= 0) + xend = RIGHTI + } else + xend = xstart + + # Fix things if the user entered M:M explicitly. + if (range) + if (fp_equali (xstart, xend)) + range = false + + # Expand a single point into a range. For an integer list + # this produces M:M+1; for a floating list M-eps:M+eps. + # Verify ordering and that something recognizable was scanned. + + if (!range) { + if (IS_LEFTI(xstart)) + call syserr (SYS_QPEXBADRNG) + xend = xstart + 1 + } else { + if (xstart > xend) { + temp = xstart; xstart = xend; xend = temp + } + if (!IS_RIGHTI(xend)) + xend = xend + 1 + } + + # Make more space if vectors fill up. + if (nrg+4 > vlen) { + vlen = vlen + INC_VLEN + call realloc (xv, vlen, TY_INT) + call realloc (uv, vlen, TY_INT) + call realloc (sv, vlen, TY_INT) + } + + # Save range on intermediate breakpoint list. + nrg = nrg + 1 + XV(nrg) = xstart + UV(nrg) = 0 + SV(nrg) = STEP + + nrg = nrg + 1 + XV(nrg) = xend + UV(nrg) = 1 + SV(nrg) = -STEP +pop_ + # Pop parser stack. + if (lev > 0) + if (token[lev] == '!') { + # Invert a series of breakpoints. + do i = tokval[lev], nrg { + if (SV(i) == STEP) # invert + SV(i) = -ZERO + else if (SV(i) == -STEP) + SV(i) = ZERO + else if (SV(i) == ZERO) # undo + SV(i) = -STEP + else if (SV(i) == -ZERO) + SV(i) = STEP + } + lev = lev - 1 + } + } + } + + # If the first range entered by the user is an exclude range, + # e.g., "(!N)" or "(!(expr))" this implies that all other values + # are acceptable. Add the open range ":" to the end of the range + # list to indicate this, i.e., convert "!N" to ":,!N". + + if (SV(1) == -ZERO) { + nrg = nrg + 1 + XV(nrg) = LEFTI + UV(nrg) = 0 + SV(nrg) = STEP + + nrg = nrg + 1 + XV(nrg) = RIGHTI + UV(nrg) = 1 + SV(nrg) = -STEP + } + + # Sort the breakpoint list. + do j = 1, nrg { + xmin = XV(j); umin = UV(j) + jval = j + do i = j+1, nrg { + if (XV(i) < xmin || (XV(i) == xmin && UV(i) < umin)) { + xmin = XV(i); umin = UV(i) + jval = i + } + } + if (jval != j) { + temp = XV(j); XV(j) = XV(jval); XV(jval) = temp + itemp = UV(j); UV(j) = UV(jval); UV(jval) = itemp + itemp = SV(j); SV(j) = SV(jval); SV(jval) = itemp + } + } + + # Initialize the output arrays if they were passed in as null. + if (xlen <= 0) { + xlen = DEF_XLEN + call malloc (xs, xlen, TY_INT) + call malloc (xe, xlen, TY_INT) + } + + # Collapse sequences of redundant breakpoints into a single + # breakpoint, clipping the running sum value to the range 0-1. + # Accumulate and output successive nonzero ranges. + + op = 1 + ov = 0 + y = 0 + + for (r1=1; r1 <= nrg; r1=r2+1) { + # Get a range of breakpoint entries for a single XV position. + for (r2=r1; r2 <= nrg; r2=r2+1) { + if (XV(r2) != XV(r1)) + break + } + r2 = r2 - 1 + + # Collapse into a single breakpoint. + x = XV(r1) + dy = SV(r1) + do i = r1 + 1, r2 + dy = dy + SV(i) + y = y + dy + + # Clip value to the range 0-1. + v = max(0, min(1, y)) + + # Accumulate a range of nonzero value. This eliminates redundant + # points lying within a range which is already set high. + + if (v == 1 && ov == 0) { + n_xs = x + ov = 1 + } else if (v == 0 && ov == 1) { + if (IS_RIGHTI(x)) + n_xe = x + else + n_xe = x - 1 + ov = 2 + } + + # Output a range. + if (ov == 2) { + if (op > xlen) { + xlen = xlen + INC_XLEN + call realloc (xs, xlen, TY_INT) + call realloc (xe, xlen, TY_INT) + } + + Memi[xs+op-1] = n_xs + Memi[xe+op-1] = n_xe + op = op + 1 + + ov = 0 + } + } + + # All done; discard breakpoint buffers. + call mfree (xv, TY_INT) + call mfree (uv, TY_INT) + call mfree (sv, TY_INT) + + return (op - 1) +end diff --git a/sys/qpoe/gen/qpexparser.x b/sys/qpoe/gen/qpexparser.x new file mode 100644 index 00000000..bf4c849e --- /dev/null +++ b/sys/qpoe/gen/qpexparser.x @@ -0,0 +1,372 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "../qpex.h" + +.help qpexparse +.nf -------------------------------------------------------------------------- +QPEXPARSE -- Code to parse an event attribute expression, producing a binary +range list as output. + + nranges = qpex_parse[ird] (expr, xs, xe, xlen) + +The calling sequence for the parse routine is shown above. The arguments XS +and XE are pointers to dynamically allocated arrays of length XLEN and type +[IRD]. These arrays should be allocated in the calling program before calling +the parser, and deallocated when no longer needed. Reallocation to increase +the array length is automatic if the arrays fill during parsing. DTYPE should +be the same datatype as the attribute with which the list is associated. + +The form of an event attribute expression may be a list of values, + + attribute = n +or + attribute = m, n, ... + +a list of inclusive or exclusive ranges, + + attribute = m:n, !p:q + +including open ranges, + + attribute = :n, p:q + +or any combination of the above (excluding combinations of bitmasks and values +or ranges, which are mutually exclusive): + + attribute = :n, a, b, p:q, !(m, e:f) + +Parenthesis may be used for grouping where desired, e.g., + + attribute = (:n, a, b, p:q, !(m, e:f)) + +An additional form of the event attribute expression allows use of a bitmask +to specify the acceptable values, e.g., + + attribute = %17B +or + attribute = !%17B + +however, bitmasks are incompatible with range lists, and should be recognized +and dealt with elsewhere (bitmasks may not be combined with range lists in +the same expression term). + +We are concerned here only with the attribute value list itself, i.e., +everything to the right of the equals sign in the examples above. This list +should be extracted and placed into a string containing a single line of +text before we are called. Attribute value lists may be any length, but +backslash continuation, file inclusion (or whatever means is used to form +the attribute value list) is assumed to be handled at a higher level. + +The output of this package is an ordered boolean valued binary range list +with type integer, real, or double breakpoints (i.e., the breakpoints are the +same datatype as the attribute itself, but the range values are zero or one). +The range list defines the initial value, final value, and any interior +breakpoints where the attribute value changes state. Expression optimization +is used to minimize the number of breakpoints (i.e., eliminate redundant +breakpoints, such as a range within a range). + +Output range list format: + + xs[1] xe[1] + xs[2] xe[2] + ... + xs[N] xe[N] + +Where each range is inclusive and only "true" ranges are shown. If XS[1] is +LEFT a open-left range (:n) is indicated; if XE[N] is RIGHT an open-right +range (n:) is indicated. In an integer range list, isolated points appear +as a single range with (xe[i]=xs[i]). In a real or double range list, +isolated points are represented as finite ranges with a width on the order of +the machine epsilon. +.endhelp --------------------------------------------------------------------- + +define DEF_XLEN 256 # default output range list length +define INC_XLEN 256 # increment to above +define DEF_VLEN 512 # default breakpoint list length +define INC_VLEN 512 # increment to above +define MAX_NEST 20 # parser stack depth + +define STEP 1 # step at boundary of closed range +define ZERO 1000 # step at boundary of open range + +define XV Memr[xv+($1)-1] # reference x position values +define UV Memi[uv+($1)-1] # unique flags for x value pairs +define SV Memi[sv+($1)-1] # reference breakpoint step values + + +# QPEX_PARSE -- Convert the given attribute value list into a binary +# range list, returning the number of ranges as the function value. + +int procedure qpex_parser (expr, xs, xe, xlen) + +char expr[ARB] #I attribute value list to be parsed +pointer xs #U pointer to array of start-range values +pointer xe #U pointer to array of end-range values +int xlen #U allocated length of XS, XE arrays + +bool range +pointer xv, uv, sv +real xstart, xend, xmin, temp, x, n_xs, n_xe +int vlen, nrg, ip, op, ch, ip_start, i, j, jval, r1, r2, y, v, ov, dy +int token[MAX_NEST], tokval[MAX_NEST], lev, itemp, umin +errchk syserr, malloc, realloc +define pop_ 91 + +double dtemp +bool bval, fp_equalr() +int qp_ctod() + +begin + vlen = DEF_VLEN + call malloc (xv, vlen, TY_REAL) + call malloc (uv, vlen, TY_INT) + call malloc (sv, vlen, TY_INT) + + lev = 0 + nrg = 0 + + # Parse the expression string and compile the raw, unoptimized + # breakpoint list in the order in which the breakpoints occur in + # the string. + + for (ip=1; expr[ip] != EOS; ) { + # Skip whitespace. + for (ch=expr[ip]; IS_WHITE(ch) || ch == '\n'; ch=expr[ip]) + ip = ip + 1 + + # Extract and process token. + switch (ch) { + case EOS: + # At end of string. + if (lev > 0) + goto pop_ + else + break + + case ',': + # Comma list token delmiter. + ip = ip + 1 + goto pop_ + + case '!', '(': + # Syntactical element - push on stack. + ip = ip + 1 + lev = lev + 1 + if (lev > MAX_NEST) + call syserr (SYS_QPEXLEVEL) + token[lev] = ch + tokval[lev] = nrg + 1 + + case ')': + # Close parenthesized group and pop parser stack. + ip = ip + 1 + if (lev < 1) + call syserr (SYS_QPEXMLP) + else if (token[lev] != '(') + call syserr (SYS_QPEXRPAREN) + lev = lev - 1 + goto pop_ + + default: + # Process a range term. + ip_start = ip + + # Scan the M in M:N. + if (qp_ctod (expr, ip, dtemp) <= 0) + xstart = LEFTR + else + xstart = dtemp + + # Scan the : in M:N. The notation M-N is also accepted, + # provided the token - immediately follows the token M. + + while (IS_WHITE(expr[ip])) + ip = ip + 1 + range = (expr[ip] == ':') + if (range) + ip = ip + 1 + else if (!IS_LEFTR (xstart)) { + range = (expr[ip] == '-') + if (range) + ip = ip + 1 + } + + # Scan the N in M:N. + if (range) { + if (qp_ctod (expr, ip, dtemp) <= 0) + xend = RIGHTR + else + xend = dtemp + } else + xend = xstart + + # Fix things if the user entered M:M explicitly. + if (range) + if (fp_equalr (xstart, xend)) + range = false + + # Expand a single point into a range. For an integer list + # this produces M:M+1; for a floating list M-eps:M+eps. + # Verify ordering and that something recognizable was scanned. + + if (!range) { + if (IS_LEFTR(xstart)) + call syserr (SYS_QPEXBADRNG) + } else { + if (xstart > xend) { + temp = xstart; xstart = xend; xend = temp + } + } + + # Make more space if vectors fill up. + if (nrg+4 > vlen) { + vlen = vlen + INC_VLEN + call realloc (xv, vlen, TY_REAL) + call realloc (uv, vlen, TY_INT) + call realloc (sv, vlen, TY_INT) + } + + # Save range on intermediate breakpoint list. + nrg = nrg + 1 + XV(nrg) = xstart + UV(nrg) = 0 + SV(nrg) = STEP + + nrg = nrg + 1 + XV(nrg) = xend + UV(nrg) = 1 + SV(nrg) = -STEP +pop_ + # Pop parser stack. + if (lev > 0) + if (token[lev] == '!') { + # Invert a series of breakpoints. + do i = tokval[lev], nrg { + if (SV(i) == STEP) # invert + SV(i) = -ZERO + else if (SV(i) == -STEP) + SV(i) = ZERO + else if (SV(i) == ZERO) # undo + SV(i) = -STEP + else if (SV(i) == -ZERO) + SV(i) = STEP + } + lev = lev - 1 + } + } + } + + # If the first range entered by the user is an exclude range, + # e.g., "(!N)" or "(!(expr))" this implies that all other values + # are acceptable. Add the open range ":" to the end of the range + # list to indicate this, i.e., convert "!N" to ":,!N". + + if (SV(1) == -ZERO) { + nrg = nrg + 1 + XV(nrg) = LEFTR + UV(nrg) = 0 + SV(nrg) = STEP + + nrg = nrg + 1 + XV(nrg) = RIGHTR + UV(nrg) = 1 + SV(nrg) = -STEP + } + + # Sort the breakpoint list. + do j = 1, nrg { + xmin = XV(j); umin = UV(j) + jval = j + do i = j+1, nrg { + bval = (XV(i) < xmin) + if (!bval) + if (abs (XV(i) - xmin) < 1.0E-5) + bval = (fp_equalr(XV(i),xmin) && UV(i) < umin) + if (bval) { + xmin = XV(i); umin = UV(i) + jval = i + } + } + if (jval != j) { + temp = XV(j); XV(j) = XV(jval); XV(jval) = temp + itemp = UV(j); UV(j) = UV(jval); UV(jval) = itemp + itemp = SV(j); SV(j) = SV(jval); SV(jval) = itemp + } + } + + # Initialize the output arrays if they were passed in as null. + if (xlen <= 0) { + xlen = DEF_XLEN + call malloc (xs, xlen, TY_REAL) + call malloc (xe, xlen, TY_REAL) + } + + # Collapse sequences of redundant breakpoints into a single + # breakpoint, clipping the running sum value to the range 0-1. + # Accumulate and output successive nonzero ranges. + + op = 1 + ov = 0 + y = 0 + + for (r1=1; r1 <= nrg; r1=r2+1) { + # Get a range of breakpoint entries for a single XV position. + for (r2=r1; r2 <= nrg; r2=r2+1) { + bval = (UV(r2) != UV(r1)) + if (!bval) { + bval = (abs (XV(r2) - XV(r1)) > 1.0E-5) + if (!bval) + bval = !fp_equalr(XV(r2),XV(r1)) + } + if (bval) + break + } + r2 = r2 - 1 + + # Collapse into a single breakpoint. + x = XV(r1) + dy = SV(r1) + do i = r1 + 1, r2 + dy = dy + SV(i) + y = y + dy + + # Clip value to the range 0-1. + v = max(0, min(1, y)) + + # Accumulate a range of nonzero value. This eliminates redundant + # points lying within a range which is already set high. + + if (v == 1 && ov == 0) { + n_xs = x + ov = 1 + } else if (v == 0 && ov == 1) { + n_xe = x + ov = 2 + } + + # Output a range. + if (ov == 2) { + if (op > xlen) { + xlen = xlen + INC_XLEN + call realloc (xs, xlen, TY_REAL) + call realloc (xe, xlen, TY_REAL) + } + + Memr[xs+op-1] = n_xs + Memr[xe+op-1] = n_xe + op = op + 1 + + ov = 0 + } + } + + # All done; discard breakpoint buffers. + call mfree (xv, TY_REAL) + call mfree (uv, TY_INT) + call mfree (sv, TY_INT) + + return (op - 1) +end diff --git a/sys/qpoe/gen/qpexsubd.x b/sys/qpoe/gen/qpexsubd.x new file mode 100644 index 00000000..2fab50fd --- /dev/null +++ b/sys/qpoe/gen/qpexsubd.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../qpex.h" + +# QPEX_SUBLIST -- Extract a sublist spanning the indicated range from a +# larger range list. The number of ranges extracted is returned as the +# function value. + +int procedure qpex_sublistd (x1, x2, xs,xe,nranges,ip, o_xs,o_xe) + +double x1, x2 #I range to be extracted +double xs[nranges],xe[nranges] #I input range list +int nranges #I nranges in input list +int ip #U start position in input list +double o_xs[ARB],o_xe[ARB] #O output sublist + +double tol +int op, i + +begin + tol = (EPSILOND * 10.0D0) + + # Determine the range containing or immediately following the + # start point of the range of interest. + + while (x1 < xs[ip] && ip > 1) + ip = ip - 1 + while (x1 >= xs[ip]) + if (x1 <= xe[ip] || ip >= nranges) + break + else + ip = ip + 1 + + # Check for an empty output range list. + if (xs[ip] > x2) + return (0) + + # At least one input range contributes something to the output region. + # Copy a portion of the input range list to the ouput range list. + + op = 1 + do i = ip, nranges { + if (xs[i] <= x1) + o_xs[op] = LEFTD - tol + else + o_xs[op] = xs[i] + + if ((xe[i] - x2) >= tol) { + o_xe[op] = RIGHTD + tol + op = op + 1 + break + } else + o_xe[op] = xe[i] + + op = op + 1 + if (xs[i+1] > x2) + break + } + + ip = i + return (op - 1) +end diff --git a/sys/qpoe/gen/qpexsubi.x b/sys/qpoe/gen/qpexsubi.x new file mode 100644 index 00000000..62ce5087 --- /dev/null +++ b/sys/qpoe/gen/qpexsubi.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../qpex.h" + +# QPEX_SUBLIST -- Extract a sublist spanning the indicated range from a +# larger range list. The number of ranges extracted is returned as the +# function value. + +int procedure qpex_sublisti (x1, x2, xs,xe,nranges,ip, o_xs,o_xe) + +int x1, x2 #I range to be extracted +int xs[nranges],xe[nranges] #I input range list +int nranges #I nranges in input list +int ip #U start position in input list +int o_xs[ARB],o_xe[ARB] #O output sublist + +int tol +int op, i + +begin + tol = 0 + + # Determine the range containing or immediately following the + # start point of the range of interest. + + while (x1 < xs[ip] && ip > 1) + ip = ip - 1 + while (x1 >= xs[ip]) + if (x1 <= xe[ip] || ip >= nranges) + break + else + ip = ip + 1 + + # Check for an empty output range list. + if (xs[ip] > x2) + return (0) + + # At least one input range contributes something to the output region. + # Copy a portion of the input range list to the ouput range list. + + op = 1 + do i = ip, nranges { + if (xs[i] <= x1) + o_xs[op] = LEFTI - tol + else + o_xs[op] = xs[i] + + if ((xe[i] - x2) >= tol) { + o_xe[op] = RIGHTI + tol + op = op + 1 + break + } else + o_xe[op] = xe[i] + + op = op + 1 + if (xs[i+1] > x2) + break + } + + ip = i + return (op - 1) +end diff --git a/sys/qpoe/gen/qpexsubr.x b/sys/qpoe/gen/qpexsubr.x new file mode 100644 index 00000000..147bf14b --- /dev/null +++ b/sys/qpoe/gen/qpexsubr.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../qpex.h" + +# QPEX_SUBLIST -- Extract a sublist spanning the indicated range from a +# larger range list. The number of ranges extracted is returned as the +# function value. + +int procedure qpex_sublistr (x1, x2, xs,xe,nranges,ip, o_xs,o_xe) + +real x1, x2 #I range to be extracted +real xs[nranges],xe[nranges] #I input range list +int nranges #I nranges in input list +int ip #U start position in input list +real o_xs[ARB],o_xe[ARB] #O output sublist + +real tol +int op, i + +begin + tol = (EPSILONR * 10.0) + + # Determine the range containing or immediately following the + # start point of the range of interest. + + while (x1 < xs[ip] && ip > 1) + ip = ip - 1 + while (x1 >= xs[ip]) + if (x1 <= xe[ip] || ip >= nranges) + break + else + ip = ip + 1 + + # Check for an empty output range list. + if (xs[ip] > x2) + return (0) + + # At least one input range contributes something to the output region. + # Copy a portion of the input range list to the ouput range list. + + op = 1 + do i = ip, nranges { + if (xs[i] <= x1) + o_xs[op] = LEFTR - tol + else + o_xs[op] = xs[i] + + if ((xe[i] - x2) >= tol) { + o_xe[op] = RIGHTR + tol + op = op + 1 + break + } else + o_xe[op] = xe[i] + + op = op + 1 + if (xs[i+1] > x2) + break + } + + ip = i + return (op - 1) +end diff --git a/sys/qpoe/gen/qpgetc.x b/sys/qpoe/gen/qpgetc.x new file mode 100644 index 00000000..1b6ce6fe --- /dev/null +++ b/sys/qpoe/gen/qpgetc.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../qpoe.h" + +# QP_GET -- Return the value of the named header parameter. Automatic type +# conversion is performed where possible. While only scalar values can be +# returned by this function, the scalar may be an element of a one-dimensional +# array, e.g., "param[N]". + +char procedure qp_getc (qp, param) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name + +pointer pp +int dtype +char value +int qp_getparam() +errchk qp_getparam, syserrs + +begin + # Lookup the parameter and it's value. + dtype = qp_getparam (qp, param, pp) + if (pp == NULL) + call syserrs (SYS_QPNOVAL, param) + + # Set default value of INDEF or NULL. + value = (NULL) + + # Get a valid parameter value. + switch (dtype) { + case TY_CHAR: + value = (Memc[pp]) + case TY_SHORT: + if (!IS_INDEFS(Mems[pp])) + value = (Mems[pp]) + case TY_INT: + if (!IS_INDEFI(Memi[pp])) + value = (Memi[pp]) + case TY_LONG: + if (!IS_INDEFL(Meml[pp])) + value = (Meml[pp]) + case TY_REAL: + if (!IS_INDEFR(Memr[pp])) + value = (Memr[pp]) + case TY_DOUBLE: + if (!IS_INDEFD(Memd[pp])) + value = (Memd[pp]) + default: + call syserrs (SYS_QPBADCONV, param) + } + + if (QP_DEBUG(qp) > 1) { + call eprintf ("qp_get: `%s', TYP=(%d->%d) returns %g\n") + call pargstr (param) + call pargi (dtype) + call pargi (TY_CHAR) + call pargc (value) + } + + return (value) +end diff --git a/sys/qpoe/gen/qpgetd.x b/sys/qpoe/gen/qpgetd.x new file mode 100644 index 00000000..fea90d0f --- /dev/null +++ b/sys/qpoe/gen/qpgetd.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../qpoe.h" + +# QP_GET -- Return the value of the named header parameter. Automatic type +# conversion is performed where possible. While only scalar values can be +# returned by this function, the scalar may be an element of a one-dimensional +# array, e.g., "param[N]". + +double procedure qp_getd (qp, param) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name + +pointer pp +int dtype +double value +int qp_getparam() +errchk qp_getparam, syserrs + +begin + # Lookup the parameter and it's value. + dtype = qp_getparam (qp, param, pp) + if (pp == NULL) + call syserrs (SYS_QPNOVAL, param) + + # Set default value of INDEF or NULL. + value = (INDEFD) + + # Get a valid parameter value. + switch (dtype) { + case TY_CHAR: + value = (Memc[pp]) + case TY_SHORT: + if (!IS_INDEFS(Mems[pp])) + value = (Mems[pp]) + case TY_INT: + if (!IS_INDEFI(Memi[pp])) + value = (Memi[pp]) + case TY_LONG: + if (!IS_INDEFL(Meml[pp])) + value = (Meml[pp]) + case TY_REAL: + if (!IS_INDEFR(Memr[pp])) + value = (Memr[pp]) + case TY_DOUBLE: + if (!IS_INDEFD(Memd[pp])) + value = (Memd[pp]) + default: + call syserrs (SYS_QPBADCONV, param) + } + + if (QP_DEBUG(qp) > 1) { + call eprintf ("qp_get: `%s', TYP=(%d->%d) returns %g\n") + call pargstr (param) + call pargi (dtype) + call pargi (TY_DOUBLE) + call pargd (value) + } + + return (value) +end diff --git a/sys/qpoe/gen/qpgeti.x b/sys/qpoe/gen/qpgeti.x new file mode 100644 index 00000000..c40d5de6 --- /dev/null +++ b/sys/qpoe/gen/qpgeti.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../qpoe.h" + +# QP_GET -- Return the value of the named header parameter. Automatic type +# conversion is performed where possible. While only scalar values can be +# returned by this function, the scalar may be an element of a one-dimensional +# array, e.g., "param[N]". + +int procedure qp_geti (qp, param) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name + +pointer pp +int dtype +int value +int qp_getparam() +errchk qp_getparam, syserrs + +begin + # Lookup the parameter and it's value. + dtype = qp_getparam (qp, param, pp) + if (pp == NULL) + call syserrs (SYS_QPNOVAL, param) + + # Set default value of INDEF or NULL. + value = (INDEFI) + + # Get a valid parameter value. + switch (dtype) { + case TY_CHAR: + value = (Memc[pp]) + case TY_SHORT: + if (!IS_INDEFS(Mems[pp])) + value = (Mems[pp]) + case TY_INT: + if (!IS_INDEFI(Memi[pp])) + value = (Memi[pp]) + case TY_LONG: + if (!IS_INDEFL(Meml[pp])) + value = (Meml[pp]) + case TY_REAL: + if (!IS_INDEFR(Memr[pp])) + value = (Memr[pp]) + case TY_DOUBLE: + if (!IS_INDEFD(Memd[pp])) + value = (Memd[pp]) + default: + call syserrs (SYS_QPBADCONV, param) + } + + if (QP_DEBUG(qp) > 1) { + call eprintf ("qp_get: `%s', TYP=(%d->%d) returns %g\n") + call pargstr (param) + call pargi (dtype) + call pargi (TY_INT) + call pargi (value) + } + + return (value) +end diff --git a/sys/qpoe/gen/qpgetl.x b/sys/qpoe/gen/qpgetl.x new file mode 100644 index 00000000..804e2def --- /dev/null +++ b/sys/qpoe/gen/qpgetl.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../qpoe.h" + +# QP_GET -- Return the value of the named header parameter. Automatic type +# conversion is performed where possible. While only scalar values can be +# returned by this function, the scalar may be an element of a one-dimensional +# array, e.g., "param[N]". + +long procedure qp_getl (qp, param) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name + +pointer pp +int dtype +long value +int qp_getparam() +errchk qp_getparam, syserrs + +begin + # Lookup the parameter and it's value. + dtype = qp_getparam (qp, param, pp) + if (pp == NULL) + call syserrs (SYS_QPNOVAL, param) + + # Set default value of INDEF or NULL. + value = (INDEFL) + + # Get a valid parameter value. + switch (dtype) { + case TY_CHAR: + value = (Memc[pp]) + case TY_SHORT: + if (!IS_INDEFS(Mems[pp])) + value = (Mems[pp]) + case TY_INT: + if (!IS_INDEFI(Memi[pp])) + value = (Memi[pp]) + case TY_LONG: + if (!IS_INDEFL(Meml[pp])) + value = (Meml[pp]) + case TY_REAL: + if (!IS_INDEFR(Memr[pp])) + value = (Memr[pp]) + case TY_DOUBLE: + if (!IS_INDEFD(Memd[pp])) + value = (Memd[pp]) + default: + call syserrs (SYS_QPBADCONV, param) + } + + if (QP_DEBUG(qp) > 1) { + call eprintf ("qp_get: `%s', TYP=(%d->%d) returns %g\n") + call pargstr (param) + call pargi (dtype) + call pargi (TY_LONG) + call pargl (value) + } + + return (value) +end diff --git a/sys/qpoe/gen/qpgetr.x b/sys/qpoe/gen/qpgetr.x new file mode 100644 index 00000000..1990a413 --- /dev/null +++ b/sys/qpoe/gen/qpgetr.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../qpoe.h" + +# QP_GET -- Return the value of the named header parameter. Automatic type +# conversion is performed where possible. While only scalar values can be +# returned by this function, the scalar may be an element of a one-dimensional +# array, e.g., "param[N]". + +real procedure qp_getr (qp, param) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name + +pointer pp +int dtype +real value +int qp_getparam() +errchk qp_getparam, syserrs + +begin + # Lookup the parameter and it's value. + dtype = qp_getparam (qp, param, pp) + if (pp == NULL) + call syserrs (SYS_QPNOVAL, param) + + # Set default value of INDEF or NULL. + value = (INDEFR) + + # Get a valid parameter value. + switch (dtype) { + case TY_CHAR: + value = (Memc[pp]) + case TY_SHORT: + if (!IS_INDEFS(Mems[pp])) + value = (Mems[pp]) + case TY_INT: + if (!IS_INDEFI(Memi[pp])) + value = (Memi[pp]) + case TY_LONG: + if (!IS_INDEFL(Meml[pp])) + value = (Meml[pp]) + case TY_REAL: + if (!IS_INDEFR(Memr[pp])) + value = (Memr[pp]) + case TY_DOUBLE: + if (!IS_INDEFD(Memd[pp])) + value = (Memd[pp]) + default: + call syserrs (SYS_QPBADCONV, param) + } + + if (QP_DEBUG(qp) > 1) { + call eprintf ("qp_get: `%s', TYP=(%d->%d) returns %g\n") + call pargstr (param) + call pargi (dtype) + call pargi (TY_REAL) + call pargr (value) + } + + return (value) +end diff --git a/sys/qpoe/gen/qpgets.x b/sys/qpoe/gen/qpgets.x new file mode 100644 index 00000000..3f6500ef --- /dev/null +++ b/sys/qpoe/gen/qpgets.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../qpoe.h" + +# QP_GET -- Return the value of the named header parameter. Automatic type +# conversion is performed where possible. While only scalar values can be +# returned by this function, the scalar may be an element of a one-dimensional +# array, e.g., "param[N]". + +short procedure qp_gets (qp, param) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name + +pointer pp +int dtype +short value +int qp_getparam() +errchk qp_getparam, syserrs + +begin + # Lookup the parameter and it's value. + dtype = qp_getparam (qp, param, pp) + if (pp == NULL) + call syserrs (SYS_QPNOVAL, param) + + # Set default value of INDEF or NULL. + value = (INDEFS) + + # Get a valid parameter value. + switch (dtype) { + case TY_CHAR: + value = (Memc[pp]) + case TY_SHORT: + if (!IS_INDEFS(Mems[pp])) + value = (Mems[pp]) + case TY_INT: + if (!IS_INDEFI(Memi[pp])) + value = (Memi[pp]) + case TY_LONG: + if (!IS_INDEFL(Meml[pp])) + value = (Meml[pp]) + case TY_REAL: + if (!IS_INDEFR(Memr[pp])) + value = (Memr[pp]) + case TY_DOUBLE: + if (!IS_INDEFD(Memd[pp])) + value = (Memd[pp]) + default: + call syserrs (SYS_QPBADCONV, param) + } + + if (QP_DEBUG(qp) > 1) { + call eprintf ("qp_get: `%s', TYP=(%d->%d) returns %g\n") + call pargstr (param) + call pargi (dtype) + call pargi (TY_SHORT) + call pargs (value) + } + + return (value) +end diff --git a/sys/qpoe/gen/qpiogetev.x b/sys/qpoe/gen/qpiogetev.x new file mode 100644 index 00000000..7d029a94 --- /dev/null +++ b/sys/qpoe/gen/qpiogetev.x @@ -0,0 +1,1968 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../qpio.h" + +define RLI_NEXTLINE 9998 +define RLI_INITIALIZE 9999 +define SZ_CODE 7 + +# QPIO_GETEVENTS -- Return a sequence of events sharing the same mask value +# which satisfy the current event attribute filter. The returned events will +# be only those in a rectangular subregion of the image (specified by a prior +# call to qpio_setrange) which are also visible through the current mask. +# Sequences of events are returned in storage order until the region is +# exhausted, at which time EOF is returned. +# +# NOTE - If debug statements (printfs) are placed in this code they will cause +# i/o problems at runtime due to reentrancy, since this routine is called in +# a low level FIO pseudodevice driver (QPF). This is also true of any of the +# routines called by this procedure, and of the related routine QPIO_READPIX. + +int procedure qpio_gvtevents (io, o_ev, maskval, maxev, o_nev) + +pointer io #I QPIO descriptor +pointer o_ev[maxev] #O receives the event struct pointers +int maskval #O receives the mask value of the events +int maxev #I max events out +int o_nev #O same as function value (nev_out|EOF) + +int status +char code[SZ_CODE] +int qpx_gvs(), qpx_gvi(), qpx_gvl(), qpx_gvr(), qpx_gvd() +errchk syserrs +define err_ 91 + +begin + # The generic routines currently require that X,Y be the same type. + # It wouldn't be hard to remove this restriction if necessary, but + # it simplifies things and I doubt if a mixed types feature would + # be used very often. + + if (IO_EVXTYPE(io) != IO_EVYTYPE(io)) + goto err_ + + # Get the events. + switch (IO_EVXTYPE(io)) { + case TY_SHORT: + status = qpx_gvs (io, o_ev, maskval, maxev, o_nev) + case TY_INT: + status = qpx_gvi (io, o_ev, maskval, maxev, o_nev) + case TY_LONG: + status = qpx_gvl (io, o_ev, maskval, maxev, o_nev) + case TY_REAL: + status = qpx_gvr (io, o_ev, maskval, maxev, o_nev) + case TY_DOUBLE: + status = qpx_gvd (io, o_ev, maskval, maxev, o_nev) + default: +err_ call sprintf (code, SZ_CODE, "%d") + call pargi (IO_EVXTYPE(io)) + call syserrs (SYS_QPINVEVT, code) + } + + return (status) +end + + + + +# QPX_GV -- Internal generic code for qpio_getevents. There is one copy +# of this routine for each event coordinate datatype. The optimization +# strategy used here assumes that executing qpio_gv is much more expensive +# than building the call in qpio_getevents. This will normally be the case +# for a large event list or a complex expression, otherwise the operation +# is likely to be fast enough that it doesn't matter anyway. + +int procedure qpx_gvs (io, o_ev, maskval, maxev, o_nev) + +pointer io #I QPIO descriptor +pointer o_ev[maxev] #O receives the event struct pointers +int maskval #O receives the mask value of the events +int maxev #I max events out +int o_nev #O same as function value (nev_out|EOF) + +int x1, x2, y1, y2, xs, xe, ys, ye, x, y +pointer pl, rl, rp, bp, ex, ev, ev_p, bbmask, bb_bufp +bool useindex, lineio, bbused, rmused, nodata +int bb_xsize, bb_ysize, bb_xblock, bb_yblock, ii, jj +int v[NDIM], szs_event, mval, nev, evidx, evtop, temp, i +int ev_xoff, ev_yoff + +pointer plr_open() +bool pl_linenotempty(), pl_sectnotempty() +int qpio_rbucket(), qpex_evaluate(), btoi(), plr_getpix() + +define swap {temp=$1;$1=$2;$2=temp} +define putevent_ 91 +define again_ 92 +define done_ 93 +define exit_ 94 + +begin + pl = IO_PL(io) # pixel list (region mask) descriptor + rl = IO_RL(io) # range list buffer + bp = IO_BP(io) # bucket buffer (type short) + ex = IO_EX(io) # QPEX (EAF) descriptor + + # The following is executed when the first i/o is performed on a new + # region, to select the most efficient type of i/o to be performed, + # and initialize the i/o parameters for that case. The type of i/o + # to be performed depends upon whether or not an index can be used, + # and whether or not there is a region mask (RM) or bounding box (BB). + # The presence or absence of an event attribute filter (EAF) is not + # separated out as a special case, as it is quick and easy to test + # for the presence of an EAF and apply one it if it exists. + + if (IO_ACTIVE(io) == NO) { + # Check for an index. We have an index if the event list is + # indexed, and the index is defined on the Y-coordinate we will + # be using for extraction. + + useindex = (IO_INDEXLEN(io) == IO_NLINES(io) && + IO_EVYOFF(io) == IO_IXYOFF(io) && + IO_NOINDEX(io) == NO) + + # Initialize the V and VN vectors. + do i = 1, NDIM { + IO_VN(io,i) = IO_VE(io,i) - IO_VS(io,i) + 1 + if (IO_VN(io,i) < 0) { + swap (IO_VS(io,i), IO_VE(io,i)) + IO_VN(io,i) = -IO_VN(io,i) + } + } + call amovi (IO_VS(io,1), IO_V(io,1), NDIM) + + # Determine if full lines are to be accessed, and if a bounding + # box (subraster of the image) is defined. + + lineio = (IO_VS(io,1) == 1 && IO_VE(io,1) == IO_NCOLS(io)) + bbused = (!lineio || IO_VS(io,2) > 1 || IO_VE(io,2) < IO_NLINES(io)) + + # Determine if region mask data is to be used and if there is any + # data to be read. + + nodata = (IO_NEVENTS(io) <= 0) + rmused = false + + if (pl != NULL) + if (pl_sectnotempty (pl, IO_VS(io,1), IO_VE(io,1), NDIM)) + rmused = true + else + nodata = true + + # Select the optimal type of i/o to be used for extraction. + if (nodata) { + IO_IOTYPE(io) = NoDATA_NoAREA + useindex = false + bbused = false + + } else if (bbused || rmused) { + if (useindex) + IO_IOTYPE(io) = INDEX_RMorBB + else + IO_IOTYPE(io) = NoINDEX_RMorBB + + } else { + # If we are reading the entire image (no bounding box) and + # we are not using a mask, then there is no point in using + # indexed i/o. + + IO_IOTYPE(io) = NoINDEX_NoRMorBB + useindex = false + } + + # Initialize the range list data if it will be used. + if (useindex) { + # Dummy range specifying full line segment. + RLI_LEN(rl) = RL_FIRST + RLI_AXLEN(rl) = IO_NCOLS(io) + + rp = rl + ((RL_FIRST - 1) * RL_LENELEM) + Memi[rp+RL_XOFF] = IO_VS(io,1) + Memi[rp+RL_NOFF] = IO_VN(io,1) + Memi[rp+RL_VOFF] = 1 + + IO_RLI(io) = RLI_INITIALIZE + } + + # Open the mask for random access if i/o is not indexed and + # a region mask is used. + + bbmask = IO_BBMASK(io) + if (bbmask != NULL) + call plr_close (bbmask) + + if (IO_IOTYPE(io) == NoINDEX_RMorBB && rmused) { + bbmask = plr_open (pl, v, 0) # (v is never referenced) + call plr_setrect (bbmask, IO_VS(io,1),IO_VS(io,2), + IO_VE(io,1),IO_VE(io,2)) + call plr_getlut (bbmask, + bb_bufp, bb_xsize, bb_ysize, bb_xblock, bb_yblock) + } + + # Update the QPIO descriptor. + IO_LINEIO(io) = btoi(lineio) + IO_RMUSED(io) = btoi(rmused) + IO_BBUSED(io) = btoi(bbused) + IO_BBMASK(io) = bbmask + + IO_EVI(io) = 1 + IO_BKNO(io) = 0 + IO_BKLASTEV(io) = 0 + + IO_ACTIVE(io) = YES + } + + # Initialize event extraction parameters. + szs_event = IO_EVENTLEN(io) + maskval = 0 + nev = 0 + + ev_xoff = IO_EVXOFF(io) + ev_yoff = IO_EVYOFF(io) + + # Extract events using the most efficient type of i/o for the given + # selection critera (index, mask, BB, EAF, etc.). +again_ + switch (IO_IOTYPE(io)) { + case NoDATA_NoAREA: + # We know in advance that there are no events to be returned, + # either because there is no data, or the area of the region + # mask within the bounding box is empty. + + goto exit_ + + case NoINDEX_NoRMorBB: + # This is the simplest case; no index, region mask, or bounding + # box. Read and output all events in sequence. + + # Refill the event bucket? + if (IO_EVI(io) > IO_BKLASTEV(io)) + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Copy out the event pointers. + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io)) * szs_event + nev = min (maxev, IO_BKLASTEV(io) - IO_EVI(io) + 1) + + do i = 1, nev { + o_ev[i] = ev + ev = ev + szs_event + } + + IO_EVI(io) = IO_EVI(io) + nev + maskval = 1 + + case NoINDEX_RMorBB: + # Fully general selection, including any combination of bounding + # box, region mask, or EAF, but no index, either because there is + # no index for this event list, or the index is for a different Y + # attribute than the one being used for extraction. + + bbused = (IO_BBUSED(io) == YES) + x1 = IO_VS(io,1); x2 = IO_VE(io,1) + y1 = IO_VS(io,2); y2 = IO_VE(io,2) + + # Refill the event bucket? + while (IO_EVI(io) > IO_BKLASTEV(io)) { + # Get the next bucket. + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Reject buckets that do not contain any events lying + # within the specified bounding box, if any. + + if (bbused) { + ev_p = (IO_MINEVB(io) - 1) * SZ_SHORT / SZ_SHORT + 1 + xs = Mems[ev_p+ev_xoff] + ys = Mems[ev_p+ev_yoff] + + ev_p = (IO_MAXEVB(io) - 1) * SZ_SHORT / SZ_SHORT + 1 + xe = Mems[ev_p+ev_xoff] + ye = Mems[ev_p+ev_yoff] + + if (xs > x2 || xe < x1 || ys > y2 || ye < y1) + IO_EVI(io) = IO_BKLASTEV(io) + 1 + } + } + + # Copy out any events which pass the region mask and which share + # the same mask value. Note that in this case, to speed mask + # value lookup at random mask coordinates, the region mask for + # the bounding box is stored as a populated array in the QPIO + # descriptor. + + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io) - 1) * szs_event + bbmask = IO_BBMASK(io) + mval = 0 + + do i = IO_EVI(io), IO_BKLASTEV(io) { + # Get event x,y coordinates in whatever coord system. + ev = ev + szs_event + ev_p = (ev - 1) * SZ_SHORT / SZ_SHORT + 1 + + x = Mems[ev_p+ev_xoff] + y = Mems[ev_p+ev_yoff] + + # Reject events lying outside the bounding box. + if (bbused) + if (x < x1 || x > x2 || y < y1 || y > y2) + next + + # Take a shortcut if no region mask is in effect for this BB. + if (bbmask == NULL) + goto putevent_ + + # Get the mask pixel associated with this event. + ii = (x - 1) / bb_xblock + jj = (y - 1) / bb_yblock + mval = Memi[bb_bufp + jj*bb_xsize + ii] + if (mval < 0) + mval = plr_getpix (bbmask, x, y) + + # Accumulate points lying in the first nonzero mask range + # encountered. + + if (mval != 0) { + if (maskval == 0) + maskval = mval + if (mval == maskval) { +putevent_ if (nev >= maxev) + break + nev = nev + 1 + o_ev[nev] = ev + } else + break + } + } + + IO_EVI(io) = i + + case INDEX_NoRMorBB, INDEX_RMorBB: + # General extraction for indexed data. Process successive ranges + # and range lists until we get at least one event which lies within + # the bounding box, within a range, and which passes the event + # attribute filter, if one is in use. + + # If the current range list (mask line) has been exhausted, advance + # to the next line which contains both ranges and events. A range + # list is used to specify the bounding box even if we don't have + # a nonempty region mask within the BB. + + if (IO_RLI(io) > RLI_LEN(rl)) { + repeat { + y = IO_V(io,2) + if (IO_RLI(io) == RLI_INITIALIZE) + IO_RLI(io) = RL_FIRST + else + y = y + 1 + + if (y > IO_VE(io,2)) { + if (nev <= 0) { + o_nev = EOF + return (EOF) + } else + goto done_ + } + + IO_V(io,2) = y + evidx = Memi[IO_YOFFVP(io)+y-1] + + if (evidx > 0) { + if (IO_RMUSED(io) == YES) { + if (IO_LINEIO(io) == YES) { + if (!pl_linenotempty (pl,IO_V(io,1))) + next + } else { + v[1] = IO_VE(io,1); v[2] = y + if (!pl_sectnotempty (pl,IO_V(io,1),v,NDIM)) + next + } + call pl_glri (pl, IO_V(io,1), Memi[rl], + IO_MDEPTH(io), IO_VN(io,1), PIX_SRC) + } + IO_RLI(io) = RL_FIRST + } + } until (IO_RLI(io) <= RLI_LEN(rl)) + + IO_EVI(io) = evidx + IO_EV1(io) = evidx + IO_EV2(io) = Memi[IO_YLENVP(io)+y-1] + evidx - 1 + } + + # Refill the event bucket? + if (IO_EVI(io) > IO_BKLASTEV(io)) + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Compute current range parameters and initialize event pointer. + rp = rl + (IO_RLI(io) - 1) * RL_LENELEM + x1 = Memi[rp+RL_XOFF] + x2 = x1 + Memi[rp+RL_NOFF] - 1 + maskval = Memi[rp+RL_VOFF] + + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io)) * szs_event + evtop = min (IO_EV2(io), IO_BKLASTEV(io)) + + # Extract events from bucket which lie within the current range + # of the current line. This is the inner loop of indexed event + # extraction, ignoring event attribute filtering. + + do i = IO_EVI(io), evtop { + ev_p = (ev - 1) * SZ_SHORT / SZ_SHORT + 1 + x = Mems[ev_p+ev_xoff] + if (x >= x1) { + if (x > x2) { + IO_RLI(io) = IO_RLI(io) + 1 + break + } else if (nev >= maxev) + break + nev = nev + 1 + o_ev[nev] = ev + } + ev = ev + szs_event + } + + IO_EVI(io) = i + if (i > IO_EV2(io)) + IO_RLI(io) = RLI_NEXTLINE + } +done_ + # Apply the event attribute filter if one is defined; repeat + # the whole process if we don't end up with any events. + + if (nev > 0) + if (ex != NULL) + nev = qpex_evaluate (ex, o_ev, o_ev, nev) + if (nev <= 0) + goto again_ +exit_ + o_nev = nev + if (o_nev <= 0) + o_nev = EOF + + return (o_nev) +end + + + +# QPX_GV -- Internal generic code for qpio_getevents. There is one copy +# of this routine for each event coordinate datatype. The optimization +# strategy used here assumes that executing qpio_gv is much more expensive +# than building the call in qpio_getevents. This will normally be the case +# for a large event list or a complex expression, otherwise the operation +# is likely to be fast enough that it doesn't matter anyway. + +int procedure qpx_gvi (io, o_ev, maskval, maxev, o_nev) + +pointer io #I QPIO descriptor +pointer o_ev[maxev] #O receives the event struct pointers +int maskval #O receives the mask value of the events +int maxev #I max events out +int o_nev #O same as function value (nev_out|EOF) + +int x1, x2, y1, y2, xs, xe, ys, ye, x, y +pointer pl, rl, rp, bp, ex, ev, ev_p, bbmask, bb_bufp +bool useindex, lineio, bbused, rmused, nodata +int bb_xsize, bb_ysize, bb_xblock, bb_yblock, ii, jj +int v[NDIM], szs_event, mval, nev, evidx, evtop, temp, i +int ev_xoff, ev_yoff + +pointer plr_open() +bool pl_linenotempty(), pl_sectnotempty() +int qpio_rbucket(), qpex_evaluate(), btoi(), plr_getpix() + +define swap {temp=$1;$1=$2;$2=temp} +define putevent_ 91 +define again_ 92 +define done_ 93 +define exit_ 94 + +begin + pl = IO_PL(io) # pixel list (region mask) descriptor + rl = IO_RL(io) # range list buffer + bp = IO_BP(io) # bucket buffer (type short) + ex = IO_EX(io) # QPEX (EAF) descriptor + + # The following is executed when the first i/o is performed on a new + # region, to select the most efficient type of i/o to be performed, + # and initialize the i/o parameters for that case. The type of i/o + # to be performed depends upon whether or not an index can be used, + # and whether or not there is a region mask (RM) or bounding box (BB). + # The presence or absence of an event attribute filter (EAF) is not + # separated out as a special case, as it is quick and easy to test + # for the presence of an EAF and apply one it if it exists. + + if (IO_ACTIVE(io) == NO) { + # Check for an index. We have an index if the event list is + # indexed, and the index is defined on the Y-coordinate we will + # be using for extraction. + + useindex = (IO_INDEXLEN(io) == IO_NLINES(io) && + IO_EVYOFF(io) == IO_IXYOFF(io) && + IO_NOINDEX(io) == NO) + + # Initialize the V and VN vectors. + do i = 1, NDIM { + IO_VN(io,i) = IO_VE(io,i) - IO_VS(io,i) + 1 + if (IO_VN(io,i) < 0) { + swap (IO_VS(io,i), IO_VE(io,i)) + IO_VN(io,i) = -IO_VN(io,i) + } + } + call amovi (IO_VS(io,1), IO_V(io,1), NDIM) + + # Determine if full lines are to be accessed, and if a bounding + # box (subraster of the image) is defined. + + lineio = (IO_VS(io,1) == 1 && IO_VE(io,1) == IO_NCOLS(io)) + bbused = (!lineio || IO_VS(io,2) > 1 || IO_VE(io,2) < IO_NLINES(io)) + + # Determine if region mask data is to be used and if there is any + # data to be read. + + nodata = (IO_NEVENTS(io) <= 0) + rmused = false + + if (pl != NULL) + if (pl_sectnotempty (pl, IO_VS(io,1), IO_VE(io,1), NDIM)) + rmused = true + else + nodata = true + + # Select the optimal type of i/o to be used for extraction. + if (nodata) { + IO_IOTYPE(io) = NoDATA_NoAREA + useindex = false + bbused = false + + } else if (bbused || rmused) { + if (useindex) + IO_IOTYPE(io) = INDEX_RMorBB + else + IO_IOTYPE(io) = NoINDEX_RMorBB + + } else { + # If we are reading the entire image (no bounding box) and + # we are not using a mask, then there is no point in using + # indexed i/o. + + IO_IOTYPE(io) = NoINDEX_NoRMorBB + useindex = false + } + + # Initialize the range list data if it will be used. + if (useindex) { + # Dummy range specifying full line segment. + RLI_LEN(rl) = RL_FIRST + RLI_AXLEN(rl) = IO_NCOLS(io) + + rp = rl + ((RL_FIRST - 1) * RL_LENELEM) + Memi[rp+RL_XOFF] = IO_VS(io,1) + Memi[rp+RL_NOFF] = IO_VN(io,1) + Memi[rp+RL_VOFF] = 1 + + IO_RLI(io) = RLI_INITIALIZE + } + + # Open the mask for random access if i/o is not indexed and + # a region mask is used. + + bbmask = IO_BBMASK(io) + if (bbmask != NULL) + call plr_close (bbmask) + + if (IO_IOTYPE(io) == NoINDEX_RMorBB && rmused) { + bbmask = plr_open (pl, v, 0) # (v is never referenced) + call plr_setrect (bbmask, IO_VS(io,1),IO_VS(io,2), + IO_VE(io,1),IO_VE(io,2)) + call plr_getlut (bbmask, + bb_bufp, bb_xsize, bb_ysize, bb_xblock, bb_yblock) + } + + # Update the QPIO descriptor. + IO_LINEIO(io) = btoi(lineio) + IO_RMUSED(io) = btoi(rmused) + IO_BBUSED(io) = btoi(bbused) + IO_BBMASK(io) = bbmask + + IO_EVI(io) = 1 + IO_BKNO(io) = 0 + IO_BKLASTEV(io) = 0 + + IO_ACTIVE(io) = YES + } + + # Initialize event extraction parameters. + szs_event = IO_EVENTLEN(io) + maskval = 0 + nev = 0 + + ev_xoff = IO_EVXOFF(io) + ev_yoff = IO_EVYOFF(io) + + # Extract events using the most efficient type of i/o for the given + # selection critera (index, mask, BB, EAF, etc.). +again_ + switch (IO_IOTYPE(io)) { + case NoDATA_NoAREA: + # We know in advance that there are no events to be returned, + # either because there is no data, or the area of the region + # mask within the bounding box is empty. + + goto exit_ + + case NoINDEX_NoRMorBB: + # This is the simplest case; no index, region mask, or bounding + # box. Read and output all events in sequence. + + # Refill the event bucket? + if (IO_EVI(io) > IO_BKLASTEV(io)) + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Copy out the event pointers. + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io)) * szs_event + nev = min (maxev, IO_BKLASTEV(io) - IO_EVI(io) + 1) + + do i = 1, nev { + o_ev[i] = ev + ev = ev + szs_event + } + + IO_EVI(io) = IO_EVI(io) + nev + maskval = 1 + + case NoINDEX_RMorBB: + # Fully general selection, including any combination of bounding + # box, region mask, or EAF, but no index, either because there is + # no index for this event list, or the index is for a different Y + # attribute than the one being used for extraction. + + bbused = (IO_BBUSED(io) == YES) + x1 = IO_VS(io,1); x2 = IO_VE(io,1) + y1 = IO_VS(io,2); y2 = IO_VE(io,2) + + # Refill the event bucket? + while (IO_EVI(io) > IO_BKLASTEV(io)) { + # Get the next bucket. + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Reject buckets that do not contain any events lying + # within the specified bounding box, if any. + + if (bbused) { + ev_p = (IO_MINEVB(io) - 1) * SZ_SHORT / SZ_INT + 1 + xs = Memi[ev_p+ev_xoff] + ys = Memi[ev_p+ev_yoff] + + ev_p = (IO_MAXEVB(io) - 1) * SZ_SHORT / SZ_INT + 1 + xe = Memi[ev_p+ev_xoff] + ye = Memi[ev_p+ev_yoff] + + if (xs > x2 || xe < x1 || ys > y2 || ye < y1) + IO_EVI(io) = IO_BKLASTEV(io) + 1 + } + } + + # Copy out any events which pass the region mask and which share + # the same mask value. Note that in this case, to speed mask + # value lookup at random mask coordinates, the region mask for + # the bounding box is stored as a populated array in the QPIO + # descriptor. + + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io) - 1) * szs_event + bbmask = IO_BBMASK(io) + mval = 0 + + do i = IO_EVI(io), IO_BKLASTEV(io) { + # Get event x,y coordinates in whatever coord system. + ev = ev + szs_event + ev_p = (ev - 1) * SZ_SHORT / SZ_INT + 1 + + x = Memi[ev_p+ev_xoff] + y = Memi[ev_p+ev_yoff] + + # Reject events lying outside the bounding box. + if (bbused) + if (x < x1 || x > x2 || y < y1 || y > y2) + next + + # Take a shortcut if no region mask is in effect for this BB. + if (bbmask == NULL) + goto putevent_ + + # Get the mask pixel associated with this event. + ii = (x - 1) / bb_xblock + jj = (y - 1) / bb_yblock + mval = Memi[bb_bufp + jj*bb_xsize + ii] + if (mval < 0) + mval = plr_getpix (bbmask, x, y) + + # Accumulate points lying in the first nonzero mask range + # encountered. + + if (mval != 0) { + if (maskval == 0) + maskval = mval + if (mval == maskval) { +putevent_ if (nev >= maxev) + break + nev = nev + 1 + o_ev[nev] = ev + } else + break + } + } + + IO_EVI(io) = i + + case INDEX_NoRMorBB, INDEX_RMorBB: + # General extraction for indexed data. Process successive ranges + # and range lists until we get at least one event which lies within + # the bounding box, within a range, and which passes the event + # attribute filter, if one is in use. + + # If the current range list (mask line) has been exhausted, advance + # to the next line which contains both ranges and events. A range + # list is used to specify the bounding box even if we don't have + # a nonempty region mask within the BB. + + if (IO_RLI(io) > RLI_LEN(rl)) { + repeat { + y = IO_V(io,2) + if (IO_RLI(io) == RLI_INITIALIZE) + IO_RLI(io) = RL_FIRST + else + y = y + 1 + + if (y > IO_VE(io,2)) { + if (nev <= 0) { + o_nev = EOF + return (EOF) + } else + goto done_ + } + + IO_V(io,2) = y + evidx = Memi[IO_YOFFVP(io)+y-1] + + if (evidx > 0) { + if (IO_RMUSED(io) == YES) { + if (IO_LINEIO(io) == YES) { + if (!pl_linenotempty (pl,IO_V(io,1))) + next + } else { + v[1] = IO_VE(io,1); v[2] = y + if (!pl_sectnotempty (pl,IO_V(io,1),v,NDIM)) + next + } + call pl_glri (pl, IO_V(io,1), Memi[rl], + IO_MDEPTH(io), IO_VN(io,1), PIX_SRC) + } + IO_RLI(io) = RL_FIRST + } + } until (IO_RLI(io) <= RLI_LEN(rl)) + + IO_EVI(io) = evidx + IO_EV1(io) = evidx + IO_EV2(io) = Memi[IO_YLENVP(io)+y-1] + evidx - 1 + } + + # Refill the event bucket? + if (IO_EVI(io) > IO_BKLASTEV(io)) + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Compute current range parameters and initialize event pointer. + rp = rl + (IO_RLI(io) - 1) * RL_LENELEM + x1 = Memi[rp+RL_XOFF] + x2 = x1 + Memi[rp+RL_NOFF] - 1 + maskval = Memi[rp+RL_VOFF] + + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io)) * szs_event + evtop = min (IO_EV2(io), IO_BKLASTEV(io)) + + # Extract events from bucket which lie within the current range + # of the current line. This is the inner loop of indexed event + # extraction, ignoring event attribute filtering. + + do i = IO_EVI(io), evtop { + ev_p = (ev - 1) * SZ_SHORT / SZ_INT + 1 + x = Memi[ev_p+ev_xoff] + if (x >= x1) { + if (x > x2) { + IO_RLI(io) = IO_RLI(io) + 1 + break + } else if (nev >= maxev) + break + nev = nev + 1 + o_ev[nev] = ev + } + ev = ev + szs_event + } + + IO_EVI(io) = i + if (i > IO_EV2(io)) + IO_RLI(io) = RLI_NEXTLINE + } +done_ + # Apply the event attribute filter if one is defined; repeat + # the whole process if we don't end up with any events. + + if (nev > 0) + if (ex != NULL) + nev = qpex_evaluate (ex, o_ev, o_ev, nev) + if (nev <= 0) + goto again_ +exit_ + o_nev = nev + if (o_nev <= 0) + o_nev = EOF + + return (o_nev) +end + + + +# QPX_GV -- Internal generic code for qpio_getevents. There is one copy +# of this routine for each event coordinate datatype. The optimization +# strategy used here assumes that executing qpio_gv is much more expensive +# than building the call in qpio_getevents. This will normally be the case +# for a large event list or a complex expression, otherwise the operation +# is likely to be fast enough that it doesn't matter anyway. + +int procedure qpx_gvl (io, o_ev, maskval, maxev, o_nev) + +pointer io #I QPIO descriptor +pointer o_ev[maxev] #O receives the event struct pointers +int maskval #O receives the mask value of the events +int maxev #I max events out +int o_nev #O same as function value (nev_out|EOF) + +int x1, x2, y1, y2, xs, xe, ys, ye, x, y +pointer pl, rl, rp, bp, ex, ev, ev_p, bbmask, bb_bufp +bool useindex, lineio, bbused, rmused, nodata +int bb_xsize, bb_ysize, bb_xblock, bb_yblock, ii, jj +int v[NDIM], szs_event, mval, nev, evidx, evtop, temp, i +int ev_xoff, ev_yoff + +pointer plr_open() +bool pl_linenotempty(), pl_sectnotempty() +int qpio_rbucket(), qpex_evaluate(), btoi(), plr_getpix() + +define swap {temp=$1;$1=$2;$2=temp} +define putevent_ 91 +define again_ 92 +define done_ 93 +define exit_ 94 + +begin + pl = IO_PL(io) # pixel list (region mask) descriptor + rl = IO_RL(io) # range list buffer + bp = IO_BP(io) # bucket buffer (type short) + ex = IO_EX(io) # QPEX (EAF) descriptor + + # The following is executed when the first i/o is performed on a new + # region, to select the most efficient type of i/o to be performed, + # and initialize the i/o parameters for that case. The type of i/o + # to be performed depends upon whether or not an index can be used, + # and whether or not there is a region mask (RM) or bounding box (BB). + # The presence or absence of an event attribute filter (EAF) is not + # separated out as a special case, as it is quick and easy to test + # for the presence of an EAF and apply one it if it exists. + + if (IO_ACTIVE(io) == NO) { + # Check for an index. We have an index if the event list is + # indexed, and the index is defined on the Y-coordinate we will + # be using for extraction. + + useindex = (IO_INDEXLEN(io) == IO_NLINES(io) && + IO_EVYOFF(io) == IO_IXYOFF(io) && + IO_NOINDEX(io) == NO) + + # Initialize the V and VN vectors. + do i = 1, NDIM { + IO_VN(io,i) = IO_VE(io,i) - IO_VS(io,i) + 1 + if (IO_VN(io,i) < 0) { + swap (IO_VS(io,i), IO_VE(io,i)) + IO_VN(io,i) = -IO_VN(io,i) + } + } + call amovi (IO_VS(io,1), IO_V(io,1), NDIM) + + # Determine if full lines are to be accessed, and if a bounding + # box (subraster of the image) is defined. + + lineio = (IO_VS(io,1) == 1 && IO_VE(io,1) == IO_NCOLS(io)) + bbused = (!lineio || IO_VS(io,2) > 1 || IO_VE(io,2) < IO_NLINES(io)) + + # Determine if region mask data is to be used and if there is any + # data to be read. + + nodata = (IO_NEVENTS(io) <= 0) + rmused = false + + if (pl != NULL) + if (pl_sectnotempty (pl, IO_VS(io,1), IO_VE(io,1), NDIM)) + rmused = true + else + nodata = true + + # Select the optimal type of i/o to be used for extraction. + if (nodata) { + IO_IOTYPE(io) = NoDATA_NoAREA + useindex = false + bbused = false + + } else if (bbused || rmused) { + if (useindex) + IO_IOTYPE(io) = INDEX_RMorBB + else + IO_IOTYPE(io) = NoINDEX_RMorBB + + } else { + # If we are reading the entire image (no bounding box) and + # we are not using a mask, then there is no point in using + # indexed i/o. + + IO_IOTYPE(io) = NoINDEX_NoRMorBB + useindex = false + } + + # Initialize the range list data if it will be used. + if (useindex) { + # Dummy range specifying full line segment. + RLI_LEN(rl) = RL_FIRST + RLI_AXLEN(rl) = IO_NCOLS(io) + + rp = rl + ((RL_FIRST - 1) * RL_LENELEM) + Memi[rp+RL_XOFF] = IO_VS(io,1) + Memi[rp+RL_NOFF] = IO_VN(io,1) + Memi[rp+RL_VOFF] = 1 + + IO_RLI(io) = RLI_INITIALIZE + } + + # Open the mask for random access if i/o is not indexed and + # a region mask is used. + + bbmask = IO_BBMASK(io) + if (bbmask != NULL) + call plr_close (bbmask) + + if (IO_IOTYPE(io) == NoINDEX_RMorBB && rmused) { + bbmask = plr_open (pl, v, 0) # (v is never referenced) + call plr_setrect (bbmask, IO_VS(io,1),IO_VS(io,2), + IO_VE(io,1),IO_VE(io,2)) + call plr_getlut (bbmask, + bb_bufp, bb_xsize, bb_ysize, bb_xblock, bb_yblock) + } + + # Update the QPIO descriptor. + IO_LINEIO(io) = btoi(lineio) + IO_RMUSED(io) = btoi(rmused) + IO_BBUSED(io) = btoi(bbused) + IO_BBMASK(io) = bbmask + + IO_EVI(io) = 1 + IO_BKNO(io) = 0 + IO_BKLASTEV(io) = 0 + + IO_ACTIVE(io) = YES + } + + # Initialize event extraction parameters. + szs_event = IO_EVENTLEN(io) + maskval = 0 + nev = 0 + + ev_xoff = IO_EVXOFF(io) + ev_yoff = IO_EVYOFF(io) + + # Extract events using the most efficient type of i/o for the given + # selection critera (index, mask, BB, EAF, etc.). +again_ + switch (IO_IOTYPE(io)) { + case NoDATA_NoAREA: + # We know in advance that there are no events to be returned, + # either because there is no data, or the area of the region + # mask within the bounding box is empty. + + goto exit_ + + case NoINDEX_NoRMorBB: + # This is the simplest case; no index, region mask, or bounding + # box. Read and output all events in sequence. + + # Refill the event bucket? + if (IO_EVI(io) > IO_BKLASTEV(io)) + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Copy out the event pointers. + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io)) * szs_event + nev = min (maxev, IO_BKLASTEV(io) - IO_EVI(io) + 1) + + do i = 1, nev { + o_ev[i] = ev + ev = ev + szs_event + } + + IO_EVI(io) = IO_EVI(io) + nev + maskval = 1 + + case NoINDEX_RMorBB: + # Fully general selection, including any combination of bounding + # box, region mask, or EAF, but no index, either because there is + # no index for this event list, or the index is for a different Y + # attribute than the one being used for extraction. + + bbused = (IO_BBUSED(io) == YES) + x1 = IO_VS(io,1); x2 = IO_VE(io,1) + y1 = IO_VS(io,2); y2 = IO_VE(io,2) + + # Refill the event bucket? + while (IO_EVI(io) > IO_BKLASTEV(io)) { + # Get the next bucket. + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Reject buckets that do not contain any events lying + # within the specified bounding box, if any. + + if (bbused) { + ev_p = (IO_MINEVB(io) - 1) * SZ_SHORT / SZ_LONG + 1 + xs = Meml[ev_p+ev_xoff] + ys = Meml[ev_p+ev_yoff] + + ev_p = (IO_MAXEVB(io) - 1) * SZ_SHORT / SZ_LONG + 1 + xe = Meml[ev_p+ev_xoff] + ye = Meml[ev_p+ev_yoff] + + if (xs > x2 || xe < x1 || ys > y2 || ye < y1) + IO_EVI(io) = IO_BKLASTEV(io) + 1 + } + } + + # Copy out any events which pass the region mask and which share + # the same mask value. Note that in this case, to speed mask + # value lookup at random mask coordinates, the region mask for + # the bounding box is stored as a populated array in the QPIO + # descriptor. + + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io) - 1) * szs_event + bbmask = IO_BBMASK(io) + mval = 0 + + do i = IO_EVI(io), IO_BKLASTEV(io) { + # Get event x,y coordinates in whatever coord system. + ev = ev + szs_event + ev_p = (ev - 1) * SZ_SHORT / SZ_LONG + 1 + + x = Meml[ev_p+ev_xoff] + y = Meml[ev_p+ev_yoff] + + # Reject events lying outside the bounding box. + if (bbused) + if (x < x1 || x > x2 || y < y1 || y > y2) + next + + # Take a shortcut if no region mask is in effect for this BB. + if (bbmask == NULL) + goto putevent_ + + # Get the mask pixel associated with this event. + ii = (x - 1) / bb_xblock + jj = (y - 1) / bb_yblock + mval = Memi[bb_bufp + jj*bb_xsize + ii] + if (mval < 0) + mval = plr_getpix (bbmask, x, y) + + # Accumulate points lying in the first nonzero mask range + # encountered. + + if (mval != 0) { + if (maskval == 0) + maskval = mval + if (mval == maskval) { +putevent_ if (nev >= maxev) + break + nev = nev + 1 + o_ev[nev] = ev + } else + break + } + } + + IO_EVI(io) = i + + case INDEX_NoRMorBB, INDEX_RMorBB: + # General extraction for indexed data. Process successive ranges + # and range lists until we get at least one event which lies within + # the bounding box, within a range, and which passes the event + # attribute filter, if one is in use. + + # If the current range list (mask line) has been exhausted, advance + # to the next line which contains both ranges and events. A range + # list is used to specify the bounding box even if we don't have + # a nonempty region mask within the BB. + + if (IO_RLI(io) > RLI_LEN(rl)) { + repeat { + y = IO_V(io,2) + if (IO_RLI(io) == RLI_INITIALIZE) + IO_RLI(io) = RL_FIRST + else + y = y + 1 + + if (y > IO_VE(io,2)) { + if (nev <= 0) { + o_nev = EOF + return (EOF) + } else + goto done_ + } + + IO_V(io,2) = y + evidx = Memi[IO_YOFFVP(io)+y-1] + + if (evidx > 0) { + if (IO_RMUSED(io) == YES) { + if (IO_LINEIO(io) == YES) { + if (!pl_linenotempty (pl,IO_V(io,1))) + next + } else { + v[1] = IO_VE(io,1); v[2] = y + if (!pl_sectnotempty (pl,IO_V(io,1),v,NDIM)) + next + } + call pl_glri (pl, IO_V(io,1), Memi[rl], + IO_MDEPTH(io), IO_VN(io,1), PIX_SRC) + } + IO_RLI(io) = RL_FIRST + } + } until (IO_RLI(io) <= RLI_LEN(rl)) + + IO_EVI(io) = evidx + IO_EV1(io) = evidx + IO_EV2(io) = Memi[IO_YLENVP(io)+y-1] + evidx - 1 + } + + # Refill the event bucket? + if (IO_EVI(io) > IO_BKLASTEV(io)) + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Compute current range parameters and initialize event pointer. + rp = rl + (IO_RLI(io) - 1) * RL_LENELEM + x1 = Memi[rp+RL_XOFF] + x2 = x1 + Memi[rp+RL_NOFF] - 1 + maskval = Memi[rp+RL_VOFF] + + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io)) * szs_event + evtop = min (IO_EV2(io), IO_BKLASTEV(io)) + + # Extract events from bucket which lie within the current range + # of the current line. This is the inner loop of indexed event + # extraction, ignoring event attribute filtering. + + do i = IO_EVI(io), evtop { + ev_p = (ev - 1) * SZ_SHORT / SZ_LONG + 1 + x = Meml[ev_p+ev_xoff] + if (x >= x1) { + if (x > x2) { + IO_RLI(io) = IO_RLI(io) + 1 + break + } else if (nev >= maxev) + break + nev = nev + 1 + o_ev[nev] = ev + } + ev = ev + szs_event + } + + IO_EVI(io) = i + if (i > IO_EV2(io)) + IO_RLI(io) = RLI_NEXTLINE + } +done_ + # Apply the event attribute filter if one is defined; repeat + # the whole process if we don't end up with any events. + + if (nev > 0) + if (ex != NULL) + nev = qpex_evaluate (ex, o_ev, o_ev, nev) + if (nev <= 0) + goto again_ +exit_ + o_nev = nev + if (o_nev <= 0) + o_nev = EOF + + return (o_nev) +end + + + +# QPX_GV -- Internal generic code for qpio_getevents. There is one copy +# of this routine for each event coordinate datatype. The optimization +# strategy used here assumes that executing qpio_gv is much more expensive +# than building the call in qpio_getevents. This will normally be the case +# for a large event list or a complex expression, otherwise the operation +# is likely to be fast enough that it doesn't matter anyway. + +int procedure qpx_gvr (io, o_ev, maskval, maxev, o_nev) + +pointer io #I QPIO descriptor +pointer o_ev[maxev] #O receives the event struct pointers +int maskval #O receives the mask value of the events +int maxev #I max events out +int o_nev #O same as function value (nev_out|EOF) + +int x1, x2, y1, y2, xs, xe, ys, ye, x, y +pointer pl, rl, rp, bp, ex, ev, ev_p, bbmask, bb_bufp +bool useindex, lineio, bbused, rmused, nodata +int bb_xsize, bb_ysize, bb_xblock, bb_yblock, ii, jj +int v[NDIM], szs_event, mval, nev, evidx, evtop, temp, i +int ev_xoff, ev_yoff + +pointer plr_open() +bool pl_linenotempty(), pl_sectnotempty() +int qpio_rbucket(), qpex_evaluate(), btoi(), plr_getpix() + +define swap {temp=$1;$1=$2;$2=temp} +define putevent_ 91 +define again_ 92 +define done_ 93 +define exit_ 94 + +begin + pl = IO_PL(io) # pixel list (region mask) descriptor + rl = IO_RL(io) # range list buffer + bp = IO_BP(io) # bucket buffer (type short) + ex = IO_EX(io) # QPEX (EAF) descriptor + + # The following is executed when the first i/o is performed on a new + # region, to select the most efficient type of i/o to be performed, + # and initialize the i/o parameters for that case. The type of i/o + # to be performed depends upon whether or not an index can be used, + # and whether or not there is a region mask (RM) or bounding box (BB). + # The presence or absence of an event attribute filter (EAF) is not + # separated out as a special case, as it is quick and easy to test + # for the presence of an EAF and apply one it if it exists. + + if (IO_ACTIVE(io) == NO) { + # Check for an index. We have an index if the event list is + # indexed, and the index is defined on the Y-coordinate we will + # be using for extraction. + + useindex = (IO_INDEXLEN(io) == IO_NLINES(io) && + IO_EVYOFF(io) == IO_IXYOFF(io) && + IO_NOINDEX(io) == NO) + + # Initialize the V and VN vectors. + do i = 1, NDIM { + IO_VN(io,i) = IO_VE(io,i) - IO_VS(io,i) + 1 + if (IO_VN(io,i) < 0) { + swap (IO_VS(io,i), IO_VE(io,i)) + IO_VN(io,i) = -IO_VN(io,i) + } + } + call amovi (IO_VS(io,1), IO_V(io,1), NDIM) + + # Determine if full lines are to be accessed, and if a bounding + # box (subraster of the image) is defined. + + lineio = (IO_VS(io,1) == 1 && IO_VE(io,1) == IO_NCOLS(io)) + bbused = (!lineio || IO_VS(io,2) > 1 || IO_VE(io,2) < IO_NLINES(io)) + + # Determine if region mask data is to be used and if there is any + # data to be read. + + nodata = (IO_NEVENTS(io) <= 0) + rmused = false + + if (pl != NULL) + if (pl_sectnotempty (pl, IO_VS(io,1), IO_VE(io,1), NDIM)) + rmused = true + else + nodata = true + + # Select the optimal type of i/o to be used for extraction. + if (nodata) { + IO_IOTYPE(io) = NoDATA_NoAREA + useindex = false + bbused = false + + } else if (bbused || rmused) { + if (useindex) + IO_IOTYPE(io) = INDEX_RMorBB + else + IO_IOTYPE(io) = NoINDEX_RMorBB + + } else { + # If we are reading the entire image (no bounding box) and + # we are not using a mask, then there is no point in using + # indexed i/o. + + IO_IOTYPE(io) = NoINDEX_NoRMorBB + useindex = false + } + + # Initialize the range list data if it will be used. + if (useindex) { + # Dummy range specifying full line segment. + RLI_LEN(rl) = RL_FIRST + RLI_AXLEN(rl) = IO_NCOLS(io) + + rp = rl + ((RL_FIRST - 1) * RL_LENELEM) + Memi[rp+RL_XOFF] = IO_VS(io,1) + Memi[rp+RL_NOFF] = IO_VN(io,1) + Memi[rp+RL_VOFF] = 1 + + IO_RLI(io) = RLI_INITIALIZE + } + + # Open the mask for random access if i/o is not indexed and + # a region mask is used. + + bbmask = IO_BBMASK(io) + if (bbmask != NULL) + call plr_close (bbmask) + + if (IO_IOTYPE(io) == NoINDEX_RMorBB && rmused) { + bbmask = plr_open (pl, v, 0) # (v is never referenced) + call plr_setrect (bbmask, IO_VS(io,1),IO_VS(io,2), + IO_VE(io,1),IO_VE(io,2)) + call plr_getlut (bbmask, + bb_bufp, bb_xsize, bb_ysize, bb_xblock, bb_yblock) + } + + # Update the QPIO descriptor. + IO_LINEIO(io) = btoi(lineio) + IO_RMUSED(io) = btoi(rmused) + IO_BBUSED(io) = btoi(bbused) + IO_BBMASK(io) = bbmask + + IO_EVI(io) = 1 + IO_BKNO(io) = 0 + IO_BKLASTEV(io) = 0 + + IO_ACTIVE(io) = YES + } + + # Initialize event extraction parameters. + szs_event = IO_EVENTLEN(io) + maskval = 0 + nev = 0 + + ev_xoff = IO_EVXOFF(io) + ev_yoff = IO_EVYOFF(io) + + # Extract events using the most efficient type of i/o for the given + # selection critera (index, mask, BB, EAF, etc.). +again_ + switch (IO_IOTYPE(io)) { + case NoDATA_NoAREA: + # We know in advance that there are no events to be returned, + # either because there is no data, or the area of the region + # mask within the bounding box is empty. + + goto exit_ + + case NoINDEX_NoRMorBB: + # This is the simplest case; no index, region mask, or bounding + # box. Read and output all events in sequence. + + # Refill the event bucket? + if (IO_EVI(io) > IO_BKLASTEV(io)) + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Copy out the event pointers. + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io)) * szs_event + nev = min (maxev, IO_BKLASTEV(io) - IO_EVI(io) + 1) + + do i = 1, nev { + o_ev[i] = ev + ev = ev + szs_event + } + + IO_EVI(io) = IO_EVI(io) + nev + maskval = 1 + + case NoINDEX_RMorBB: + # Fully general selection, including any combination of bounding + # box, region mask, or EAF, but no index, either because there is + # no index for this event list, or the index is for a different Y + # attribute than the one being used for extraction. + + bbused = (IO_BBUSED(io) == YES) + x1 = IO_VS(io,1); x2 = IO_VE(io,1) + y1 = IO_VS(io,2); y2 = IO_VE(io,2) + + # Refill the event bucket? + while (IO_EVI(io) > IO_BKLASTEV(io)) { + # Get the next bucket. + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Reject buckets that do not contain any events lying + # within the specified bounding box, if any. + + if (bbused) { + ev_p = (IO_MINEVB(io) - 1) * SZ_SHORT / SZ_REAL + 1 + xs = Memr[ev_p+ev_xoff] + 0.5 + ys = Memr[ev_p+ev_yoff] + 0.5 + + ev_p = (IO_MAXEVB(io) - 1) * SZ_SHORT / SZ_REAL + 1 + xe = Memr[ev_p+ev_xoff] + 0.5 + ye = Memr[ev_p+ev_yoff] + 0.5 + + if (xs > x2 || xe < x1 || ys > y2 || ye < y1) + IO_EVI(io) = IO_BKLASTEV(io) + 1 + } + } + + # Copy out any events which pass the region mask and which share + # the same mask value. Note that in this case, to speed mask + # value lookup at random mask coordinates, the region mask for + # the bounding box is stored as a populated array in the QPIO + # descriptor. + + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io) - 1) * szs_event + bbmask = IO_BBMASK(io) + mval = 0 + + do i = IO_EVI(io), IO_BKLASTEV(io) { + # Get event x,y coordinates in whatever coord system. + ev = ev + szs_event + ev_p = (ev - 1) * SZ_SHORT / SZ_REAL + 1 + + x = Memr[ev_p+ev_xoff] + 0.5 + y = Memr[ev_p+ev_yoff] + 0.5 + + # Reject events lying outside the bounding box. + if (bbused) + if (x < x1 || x > x2 || y < y1 || y > y2) + next + + # Take a shortcut if no region mask is in effect for this BB. + if (bbmask == NULL) + goto putevent_ + + # Get the mask pixel associated with this event. + ii = (x - 1) / bb_xblock + jj = (y - 1) / bb_yblock + mval = Memi[bb_bufp + jj*bb_xsize + ii] + if (mval < 0) + mval = plr_getpix (bbmask, x, y) + + # Accumulate points lying in the first nonzero mask range + # encountered. + + if (mval != 0) { + if (maskval == 0) + maskval = mval + if (mval == maskval) { +putevent_ if (nev >= maxev) + break + nev = nev + 1 + o_ev[nev] = ev + } else + break + } + } + + IO_EVI(io) = i + + case INDEX_NoRMorBB, INDEX_RMorBB: + # General extraction for indexed data. Process successive ranges + # and range lists until we get at least one event which lies within + # the bounding box, within a range, and which passes the event + # attribute filter, if one is in use. + + # If the current range list (mask line) has been exhausted, advance + # to the next line which contains both ranges and events. A range + # list is used to specify the bounding box even if we don't have + # a nonempty region mask within the BB. + + if (IO_RLI(io) > RLI_LEN(rl)) { + repeat { + y = IO_V(io,2) + if (IO_RLI(io) == RLI_INITIALIZE) + IO_RLI(io) = RL_FIRST + else + y = y + 1 + + if (y > IO_VE(io,2)) { + if (nev <= 0) { + o_nev = EOF + return (EOF) + } else + goto done_ + } + + IO_V(io,2) = y + evidx = Memi[IO_YOFFVP(io)+y-1] + + if (evidx > 0) { + if (IO_RMUSED(io) == YES) { + if (IO_LINEIO(io) == YES) { + if (!pl_linenotempty (pl,IO_V(io,1))) + next + } else { + v[1] = IO_VE(io,1); v[2] = y + if (!pl_sectnotempty (pl,IO_V(io,1),v,NDIM)) + next + } + call pl_glri (pl, IO_V(io,1), Memi[rl], + IO_MDEPTH(io), IO_VN(io,1), PIX_SRC) + } + IO_RLI(io) = RL_FIRST + } + } until (IO_RLI(io) <= RLI_LEN(rl)) + + IO_EVI(io) = evidx + IO_EV1(io) = evidx + IO_EV2(io) = Memi[IO_YLENVP(io)+y-1] + evidx - 1 + } + + # Refill the event bucket? + if (IO_EVI(io) > IO_BKLASTEV(io)) + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Compute current range parameters and initialize event pointer. + rp = rl + (IO_RLI(io) - 1) * RL_LENELEM + x1 = Memi[rp+RL_XOFF] + x2 = x1 + Memi[rp+RL_NOFF] - 1 + maskval = Memi[rp+RL_VOFF] + + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io)) * szs_event + evtop = min (IO_EV2(io), IO_BKLASTEV(io)) + + # Extract events from bucket which lie within the current range + # of the current line. This is the inner loop of indexed event + # extraction, ignoring event attribute filtering. + + do i = IO_EVI(io), evtop { + ev_p = (ev - 1) * SZ_SHORT / SZ_REAL + 1 + x = Memr[ev_p+ev_xoff] + 0.5 + if (x >= x1) { + if (x > x2) { + IO_RLI(io) = IO_RLI(io) + 1 + break + } else if (nev >= maxev) + break + nev = nev + 1 + o_ev[nev] = ev + } + ev = ev + szs_event + } + + IO_EVI(io) = i + if (i > IO_EV2(io)) + IO_RLI(io) = RLI_NEXTLINE + } +done_ + # Apply the event attribute filter if one is defined; repeat + # the whole process if we don't end up with any events. + + if (nev > 0) + if (ex != NULL) + nev = qpex_evaluate (ex, o_ev, o_ev, nev) + if (nev <= 0) + goto again_ +exit_ + o_nev = nev + if (o_nev <= 0) + o_nev = EOF + + return (o_nev) +end + + + +# QPX_GV -- Internal generic code for qpio_getevents. There is one copy +# of this routine for each event coordinate datatype. The optimization +# strategy used here assumes that executing qpio_gv is much more expensive +# than building the call in qpio_getevents. This will normally be the case +# for a large event list or a complex expression, otherwise the operation +# is likely to be fast enough that it doesn't matter anyway. + +int procedure qpx_gvd (io, o_ev, maskval, maxev, o_nev) + +pointer io #I QPIO descriptor +pointer o_ev[maxev] #O receives the event struct pointers +int maskval #O receives the mask value of the events +int maxev #I max events out +int o_nev #O same as function value (nev_out|EOF) + +int x1, x2, y1, y2, xs, xe, ys, ye, x, y +pointer pl, rl, rp, bp, ex, ev, ev_p, bbmask, bb_bufp +bool useindex, lineio, bbused, rmused, nodata +int bb_xsize, bb_ysize, bb_xblock, bb_yblock, ii, jj +int v[NDIM], szs_event, mval, nev, evidx, evtop, temp, i +int ev_xoff, ev_yoff + +pointer plr_open() +bool pl_linenotempty(), pl_sectnotempty() +int qpio_rbucket(), qpex_evaluate(), btoi(), plr_getpix() + +define swap {temp=$1;$1=$2;$2=temp} +define putevent_ 91 +define again_ 92 +define done_ 93 +define exit_ 94 + +begin + pl = IO_PL(io) # pixel list (region mask) descriptor + rl = IO_RL(io) # range list buffer + bp = IO_BP(io) # bucket buffer (type short) + ex = IO_EX(io) # QPEX (EAF) descriptor + + # The following is executed when the first i/o is performed on a new + # region, to select the most efficient type of i/o to be performed, + # and initialize the i/o parameters for that case. The type of i/o + # to be performed depends upon whether or not an index can be used, + # and whether or not there is a region mask (RM) or bounding box (BB). + # The presence or absence of an event attribute filter (EAF) is not + # separated out as a special case, as it is quick and easy to test + # for the presence of an EAF and apply one it if it exists. + + if (IO_ACTIVE(io) == NO) { + # Check for an index. We have an index if the event list is + # indexed, and the index is defined on the Y-coordinate we will + # be using for extraction. + + useindex = (IO_INDEXLEN(io) == IO_NLINES(io) && + IO_EVYOFF(io) == IO_IXYOFF(io) && + IO_NOINDEX(io) == NO) + + # Initialize the V and VN vectors. + do i = 1, NDIM { + IO_VN(io,i) = IO_VE(io,i) - IO_VS(io,i) + 1 + if (IO_VN(io,i) < 0) { + swap (IO_VS(io,i), IO_VE(io,i)) + IO_VN(io,i) = -IO_VN(io,i) + } + } + call amovi (IO_VS(io,1), IO_V(io,1), NDIM) + + # Determine if full lines are to be accessed, and if a bounding + # box (subraster of the image) is defined. + + lineio = (IO_VS(io,1) == 1 && IO_VE(io,1) == IO_NCOLS(io)) + bbused = (!lineio || IO_VS(io,2) > 1 || IO_VE(io,2) < IO_NLINES(io)) + + # Determine if region mask data is to be used and if there is any + # data to be read. + + nodata = (IO_NEVENTS(io) <= 0) + rmused = false + + if (pl != NULL) + if (pl_sectnotempty (pl, IO_VS(io,1), IO_VE(io,1), NDIM)) + rmused = true + else + nodata = true + + # Select the optimal type of i/o to be used for extraction. + if (nodata) { + IO_IOTYPE(io) = NoDATA_NoAREA + useindex = false + bbused = false + + } else if (bbused || rmused) { + if (useindex) + IO_IOTYPE(io) = INDEX_RMorBB + else + IO_IOTYPE(io) = NoINDEX_RMorBB + + } else { + # If we are reading the entire image (no bounding box) and + # we are not using a mask, then there is no point in using + # indexed i/o. + + IO_IOTYPE(io) = NoINDEX_NoRMorBB + useindex = false + } + + # Initialize the range list data if it will be used. + if (useindex) { + # Dummy range specifying full line segment. + RLI_LEN(rl) = RL_FIRST + RLI_AXLEN(rl) = IO_NCOLS(io) + + rp = rl + ((RL_FIRST - 1) * RL_LENELEM) + Memi[rp+RL_XOFF] = IO_VS(io,1) + Memi[rp+RL_NOFF] = IO_VN(io,1) + Memi[rp+RL_VOFF] = 1 + + IO_RLI(io) = RLI_INITIALIZE + } + + # Open the mask for random access if i/o is not indexed and + # a region mask is used. + + bbmask = IO_BBMASK(io) + if (bbmask != NULL) + call plr_close (bbmask) + + if (IO_IOTYPE(io) == NoINDEX_RMorBB && rmused) { + bbmask = plr_open (pl, v, 0) # (v is never referenced) + call plr_setrect (bbmask, IO_VS(io,1),IO_VS(io,2), + IO_VE(io,1),IO_VE(io,2)) + call plr_getlut (bbmask, + bb_bufp, bb_xsize, bb_ysize, bb_xblock, bb_yblock) + } + + # Update the QPIO descriptor. + IO_LINEIO(io) = btoi(lineio) + IO_RMUSED(io) = btoi(rmused) + IO_BBUSED(io) = btoi(bbused) + IO_BBMASK(io) = bbmask + + IO_EVI(io) = 1 + IO_BKNO(io) = 0 + IO_BKLASTEV(io) = 0 + + IO_ACTIVE(io) = YES + } + + # Initialize event extraction parameters. + szs_event = IO_EVENTLEN(io) + maskval = 0 + nev = 0 + + ev_xoff = IO_EVXOFF(io) + ev_yoff = IO_EVYOFF(io) + + # Extract events using the most efficient type of i/o for the given + # selection critera (index, mask, BB, EAF, etc.). +again_ + switch (IO_IOTYPE(io)) { + case NoDATA_NoAREA: + # We know in advance that there are no events to be returned, + # either because there is no data, or the area of the region + # mask within the bounding box is empty. + + goto exit_ + + case NoINDEX_NoRMorBB: + # This is the simplest case; no index, region mask, or bounding + # box. Read and output all events in sequence. + + # Refill the event bucket? + if (IO_EVI(io) > IO_BKLASTEV(io)) + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Copy out the event pointers. + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io)) * szs_event + nev = min (maxev, IO_BKLASTEV(io) - IO_EVI(io) + 1) + + do i = 1, nev { + o_ev[i] = ev + ev = ev + szs_event + } + + IO_EVI(io) = IO_EVI(io) + nev + maskval = 1 + + case NoINDEX_RMorBB: + # Fully general selection, including any combination of bounding + # box, region mask, or EAF, but no index, either because there is + # no index for this event list, or the index is for a different Y + # attribute than the one being used for extraction. + + bbused = (IO_BBUSED(io) == YES) + x1 = IO_VS(io,1); x2 = IO_VE(io,1) + y1 = IO_VS(io,2); y2 = IO_VE(io,2) + + # Refill the event bucket? + while (IO_EVI(io) > IO_BKLASTEV(io)) { + # Get the next bucket. + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Reject buckets that do not contain any events lying + # within the specified bounding box, if any. + + if (bbused) { + ev_p = (IO_MINEVB(io) - 1) * SZ_SHORT / SZ_DOUBLE + 1 + xs = Memd[ev_p+ev_xoff] + 0.5 + ys = Memd[ev_p+ev_yoff] + 0.5 + + ev_p = (IO_MAXEVB(io) - 1) * SZ_SHORT / SZ_DOUBLE + 1 + xe = Memd[ev_p+ev_xoff] + 0.5 + ye = Memd[ev_p+ev_yoff] + 0.5 + + if (xs > x2 || xe < x1 || ys > y2 || ye < y1) + IO_EVI(io) = IO_BKLASTEV(io) + 1 + } + } + + # Copy out any events which pass the region mask and which share + # the same mask value. Note that in this case, to speed mask + # value lookup at random mask coordinates, the region mask for + # the bounding box is stored as a populated array in the QPIO + # descriptor. + + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io) - 1) * szs_event + bbmask = IO_BBMASK(io) + mval = 0 + + do i = IO_EVI(io), IO_BKLASTEV(io) { + # Get event x,y coordinates in whatever coord system. + ev = ev + szs_event + ev_p = (ev - 1) * SZ_SHORT / SZ_DOUBLE + 1 + + x = Memd[ev_p+ev_xoff] + 0.5 + y = Memd[ev_p+ev_yoff] + 0.5 + + # Reject events lying outside the bounding box. + if (bbused) + if (x < x1 || x > x2 || y < y1 || y > y2) + next + + # Take a shortcut if no region mask is in effect for this BB. + if (bbmask == NULL) + goto putevent_ + + # Get the mask pixel associated with this event. + ii = (x - 1) / bb_xblock + jj = (y - 1) / bb_yblock + mval = Memi[bb_bufp + jj*bb_xsize + ii] + if (mval < 0) + mval = plr_getpix (bbmask, x, y) + + # Accumulate points lying in the first nonzero mask range + # encountered. + + if (mval != 0) { + if (maskval == 0) + maskval = mval + if (mval == maskval) { +putevent_ if (nev >= maxev) + break + nev = nev + 1 + o_ev[nev] = ev + } else + break + } + } + + IO_EVI(io) = i + + case INDEX_NoRMorBB, INDEX_RMorBB: + # General extraction for indexed data. Process successive ranges + # and range lists until we get at least one event which lies within + # the bounding box, within a range, and which passes the event + # attribute filter, if one is in use. + + # If the current range list (mask line) has been exhausted, advance + # to the next line which contains both ranges and events. A range + # list is used to specify the bounding box even if we don't have + # a nonempty region mask within the BB. + + if (IO_RLI(io) > RLI_LEN(rl)) { + repeat { + y = IO_V(io,2) + if (IO_RLI(io) == RLI_INITIALIZE) + IO_RLI(io) = RL_FIRST + else + y = y + 1 + + if (y > IO_VE(io,2)) { + if (nev <= 0) { + o_nev = EOF + return (EOF) + } else + goto done_ + } + + IO_V(io,2) = y + evidx = Memi[IO_YOFFVP(io)+y-1] + + if (evidx > 0) { + if (IO_RMUSED(io) == YES) { + if (IO_LINEIO(io) == YES) { + if (!pl_linenotempty (pl,IO_V(io,1))) + next + } else { + v[1] = IO_VE(io,1); v[2] = y + if (!pl_sectnotempty (pl,IO_V(io,1),v,NDIM)) + next + } + call pl_glri (pl, IO_V(io,1), Memi[rl], + IO_MDEPTH(io), IO_VN(io,1), PIX_SRC) + } + IO_RLI(io) = RL_FIRST + } + } until (IO_RLI(io) <= RLI_LEN(rl)) + + IO_EVI(io) = evidx + IO_EV1(io) = evidx + IO_EV2(io) = Memi[IO_YLENVP(io)+y-1] + evidx - 1 + } + + # Refill the event bucket? + if (IO_EVI(io) > IO_BKLASTEV(io)) + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Compute current range parameters and initialize event pointer. + rp = rl + (IO_RLI(io) - 1) * RL_LENELEM + x1 = Memi[rp+RL_XOFF] + x2 = x1 + Memi[rp+RL_NOFF] - 1 + maskval = Memi[rp+RL_VOFF] + + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io)) * szs_event + evtop = min (IO_EV2(io), IO_BKLASTEV(io)) + + # Extract events from bucket which lie within the current range + # of the current line. This is the inner loop of indexed event + # extraction, ignoring event attribute filtering. + + do i = IO_EVI(io), evtop { + ev_p = (ev - 1) * SZ_SHORT / SZ_DOUBLE + 1 + x = Memd[ev_p+ev_xoff] + 0.5 + if (x >= x1) { + if (x > x2) { + IO_RLI(io) = IO_RLI(io) + 1 + break + } else if (nev >= maxev) + break + nev = nev + 1 + o_ev[nev] = ev + } + ev = ev + szs_event + } + + IO_EVI(io) = i + if (i > IO_EV2(io)) + IO_RLI(io) = RLI_NEXTLINE + } +done_ + # Apply the event attribute filter if one is defined; repeat + # the whole process if we don't end up with any events. + + if (nev > 0) + if (ex != NULL) + nev = qpex_evaluate (ex, o_ev, o_ev, nev) + if (nev <= 0) + goto again_ +exit_ + o_nev = nev + if (o_nev <= 0) + o_nev = EOF + + return (o_nev) +end + + diff --git a/sys/qpoe/gen/qpiorpixi.x b/sys/qpoe/gen/qpiorpixi.x new file mode 100644 index 00000000..c64f0a8a --- /dev/null +++ b/sys/qpoe/gen/qpiorpixi.x @@ -0,0 +1,150 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../qpio.h" + +# QPIO_READPIX -- Sample the event list within the indicated rectangular +# region, using the given blocking factor, to produce a rectangular array +# of "pixels", where each pixel is a count of the number of events mapping +# to that location which pass the event attribute filter and region mask. +# +# NOTE -- It is left up to the caller to zero the output buffer before +# we are called. (We merely increment the counts of the affected pixels). + +int procedure qpio_readpixi (io, obuf, vs, ve, ndim, xblock, yblock) + +pointer io #I QPIO descriptor +int obuf[ARB] #O output pixel buffer +int vs[ndim], ve[ndim] #I vectors defining region to be extracted +int ndim #I should be 2 for QPOE +real xblock, yblock #I blocking factors + +double x, y +pointer sp, evl, ev_p +int evtype, maxpix, maskval, xoff, yoff, xw, yw, nev, totev, pix, i, j +errchk qpio_getevents, qpio_setrange, syserr +int qpio_getevents() + +begin + # Verify arguments. + if (xblock <= 0 || xblock > (ve[1] - vs[1] + 1)) + call syserr (SYS_QPBLOCKOOR) + if (yblock <= 0 || yblock > (ve[2] - vs[2] + 1)) + call syserr (SYS_QPBLOCKOOR) + + # Compute the size of the output matrix in integer pixels. This + # truncates the last partially filled pixel in each axis. + + xw = int ((ve[1] - vs[1] + 1) / xblock + (EPSILOND * 1000)) + yw = int ((ve[2] - vs[2] + 1) / yblock + (EPSILOND * 1000)) + if (xw <= 0 || yw <= 0) + return (0) + + call smark (sp) + call salloc (evl, SZ_EVLIST, TY_POINTER) + + xoff = IO_EVXOFF(io) + yoff = IO_EVYOFF(io) + maxpix = xw * yw + totev = 0 + + evtype = IO_EVXTYPE(io) + if (IO_EVXTYPE(io) != IO_EVYTYPE(io)) + call syserr (SYS_QPINVEVT) + + # Define the region from which we wish to read events. + call qpio_setrange (io, vs, ve, ndim) + + # Read the events. + while (qpio_getevents (io, Memi[evl], maskval, SZ_EVLIST, nev) > 0) { + switch (evtype) { + + case TY_SHORT: + # Process a sequence of neighbor events. + do i = 1, nev { + ev_p = (Memi[evl+i-1] - 1) * SZ_SHORT / SZ_SHORT + 1 + + x = Mems[ev_p+xoff] + y = Mems[ev_p+yoff] + + j = int ((y - vs[2]) / yblock + (EPSILOND * 1000)) + if (j >= 0 && j < yw) { + pix = j * xw + (x - vs[1]) / xblock + 1 + if (pix > 0 && pix <= maxpix) + obuf[pix] = obuf[pix] + 1 + } + } + + case TY_INT: + # Process a sequence of neighbor events. + do i = 1, nev { + ev_p = (Memi[evl+i-1] - 1) * SZ_SHORT / SZ_INT + 1 + + x = Memi[ev_p+xoff] + y = Memi[ev_p+yoff] + + j = int ((y - vs[2]) / yblock + (EPSILOND * 1000)) + if (j >= 0 && j < yw) { + pix = j * xw + (x - vs[1]) / xblock + 1 + if (pix > 0 && pix <= maxpix) + obuf[pix] = obuf[pix] + 1 + } + } + + case TY_LONG: + # Process a sequence of neighbor events. + do i = 1, nev { + ev_p = (Memi[evl+i-1] - 1) * SZ_SHORT / SZ_LONG + 1 + + x = Meml[ev_p+xoff] + y = Meml[ev_p+yoff] + + j = int ((y - vs[2]) / yblock + (EPSILOND * 1000)) + if (j >= 0 && j < yw) { + pix = j * xw + (x - vs[1]) / xblock + 1 + if (pix > 0 && pix <= maxpix) + obuf[pix] = obuf[pix] + 1 + } + } + + case TY_REAL: + # Process a sequence of neighbor events. + do i = 1, nev { + ev_p = (Memi[evl+i-1] - 1) * SZ_SHORT / SZ_REAL + 1 + + x = Memr[ev_p+xoff] + y = Memr[ev_p+yoff] + + j = int ((y - vs[2]) / yblock + (EPSILOND * 1000)) + if (j >= 0 && j < yw) { + pix = j * xw + (x - vs[1]) / xblock + 1 + if (pix > 0 && pix <= maxpix) + obuf[pix] = obuf[pix] + 1 + } + } + + case TY_DOUBLE: + # Process a sequence of neighbor events. + do i = 1, nev { + ev_p = (Memi[evl+i-1] - 1) * SZ_SHORT / SZ_DOUBLE + 1 + + x = Memd[ev_p+xoff] + y = Memd[ev_p+yoff] + + j = int ((y - vs[2]) / yblock + (EPSILOND * 1000)) + if (j >= 0 && j < yw) { + pix = j * xw + (x - vs[1]) / xblock + 1 + if (pix > 0 && pix <= maxpix) + obuf[pix] = obuf[pix] + 1 + } + } + + } + + totev = totev + nev + } + + call sfree (sp) + return (totev) +end diff --git a/sys/qpoe/gen/qpiorpixs.x b/sys/qpoe/gen/qpiorpixs.x new file mode 100644 index 00000000..d97c7c42 --- /dev/null +++ b/sys/qpoe/gen/qpiorpixs.x @@ -0,0 +1,150 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../qpio.h" + +# QPIO_READPIX -- Sample the event list within the indicated rectangular +# region, using the given blocking factor, to produce a rectangular array +# of "pixels", where each pixel is a count of the number of events mapping +# to that location which pass the event attribute filter and region mask. +# +# NOTE -- It is left up to the caller to zero the output buffer before +# we are called. (We merely increment the counts of the affected pixels). + +int procedure qpio_readpixs (io, obuf, vs, ve, ndim, xblock, yblock) + +pointer io #I QPIO descriptor +short obuf[ARB] #O output pixel buffer +int vs[ndim], ve[ndim] #I vectors defining region to be extracted +int ndim #I should be 2 for QPOE +real xblock, yblock #I blocking factors + +double x, y +pointer sp, evl, ev_p +int evtype, maxpix, maskval, xoff, yoff, xw, yw, nev, totev, pix, i, j +errchk qpio_getevents, qpio_setrange, syserr +int qpio_getevents() + +begin + # Verify arguments. + if (xblock <= 0 || xblock > (ve[1] - vs[1] + 1)) + call syserr (SYS_QPBLOCKOOR) + if (yblock <= 0 || yblock > (ve[2] - vs[2] + 1)) + call syserr (SYS_QPBLOCKOOR) + + # Compute the size of the output matrix in integer pixels. This + # truncates the last partially filled pixel in each axis. + + xw = int ((ve[1] - vs[1] + 1) / xblock + (EPSILOND * 1000)) + yw = int ((ve[2] - vs[2] + 1) / yblock + (EPSILOND * 1000)) + if (xw <= 0 || yw <= 0) + return (0) + + call smark (sp) + call salloc (evl, SZ_EVLIST, TY_POINTER) + + xoff = IO_EVXOFF(io) + yoff = IO_EVYOFF(io) + maxpix = xw * yw + totev = 0 + + evtype = IO_EVXTYPE(io) + if (IO_EVXTYPE(io) != IO_EVYTYPE(io)) + call syserr (SYS_QPINVEVT) + + # Define the region from which we wish to read events. + call qpio_setrange (io, vs, ve, ndim) + + # Read the events. + while (qpio_getevents (io, Memi[evl], maskval, SZ_EVLIST, nev) > 0) { + switch (evtype) { + + case TY_SHORT: + # Process a sequence of neighbor events. + do i = 1, nev { + ev_p = (Memi[evl+i-1] - 1) * SZ_SHORT / SZ_SHORT + 1 + + x = Mems[ev_p+xoff] + y = Mems[ev_p+yoff] + + j = int ((y - vs[2]) / yblock + (EPSILOND * 1000)) + if (j >= 0 && j < yw) { + pix = j * xw + (x - vs[1]) / xblock + 1 + if (pix > 0 && pix <= maxpix) + obuf[pix] = obuf[pix] + 1 + } + } + + case TY_INT: + # Process a sequence of neighbor events. + do i = 1, nev { + ev_p = (Memi[evl+i-1] - 1) * SZ_SHORT / SZ_INT + 1 + + x = Memi[ev_p+xoff] + y = Memi[ev_p+yoff] + + j = int ((y - vs[2]) / yblock + (EPSILOND * 1000)) + if (j >= 0 && j < yw) { + pix = j * xw + (x - vs[1]) / xblock + 1 + if (pix > 0 && pix <= maxpix) + obuf[pix] = obuf[pix] + 1 + } + } + + case TY_LONG: + # Process a sequence of neighbor events. + do i = 1, nev { + ev_p = (Memi[evl+i-1] - 1) * SZ_SHORT / SZ_LONG + 1 + + x = Meml[ev_p+xoff] + y = Meml[ev_p+yoff] + + j = int ((y - vs[2]) / yblock + (EPSILOND * 1000)) + if (j >= 0 && j < yw) { + pix = j * xw + (x - vs[1]) / xblock + 1 + if (pix > 0 && pix <= maxpix) + obuf[pix] = obuf[pix] + 1 + } + } + + case TY_REAL: + # Process a sequence of neighbor events. + do i = 1, nev { + ev_p = (Memi[evl+i-1] - 1) * SZ_SHORT / SZ_REAL + 1 + + x = Memr[ev_p+xoff] + y = Memr[ev_p+yoff] + + j = int ((y - vs[2]) / yblock + (EPSILOND * 1000)) + if (j >= 0 && j < yw) { + pix = j * xw + (x - vs[1]) / xblock + 1 + if (pix > 0 && pix <= maxpix) + obuf[pix] = obuf[pix] + 1 + } + } + + case TY_DOUBLE: + # Process a sequence of neighbor events. + do i = 1, nev { + ev_p = (Memi[evl+i-1] - 1) * SZ_SHORT / SZ_DOUBLE + 1 + + x = Memd[ev_p+xoff] + y = Memd[ev_p+yoff] + + j = int ((y - vs[2]) / yblock + (EPSILOND * 1000)) + if (j >= 0 && j < yw) { + pix = j * xw + (x - vs[1]) / xblock + 1 + if (pix > 0 && pix <= maxpix) + obuf[pix] = obuf[pix] + 1 + } + } + + } + + totev = totev + nev + } + + call sfree (sp) + return (totev) +end diff --git a/sys/qpoe/gen/qpputc.x b/sys/qpoe/gen/qpputc.x new file mode 100644 index 00000000..4415a177 --- /dev/null +++ b/sys/qpoe/gen/qpputc.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../qpoe.h" + +# QP_PUT -- Set the value of the named header parameter. Automatic type +# conversion is performed where possible. While only scalar values can be +# set by this function, the scalar may be an element of a one-dimensional +# array, e.g., "param[N]". + +procedure qp_putc (qp, param, value) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +char value #I scalar parameter value + +pointer pp +bool indef +int dtype +int qp_putparam() +errchk qp_putparam, syserrs + +begin + # Lookup the parameter and get a pointer to the value buffer. + dtype = qp_putparam (qp, param, pp) + if (pp == NULL) + call syserrs (SYS_QPNOVAL, param) + + if (QP_DEBUG(qp) > 1) { + call eprintf ("qp_put: `%s', TYP=(%d->%d), new value %g\n") + call pargstr (param) + call pargi (TY_CHAR) + call pargi (dtype) + call pargc (value) + } + + indef = IS_INDEF(value) + + # Set the parameter value. + switch (dtype) { + case TY_CHAR: + Memc[pp] = value + case TY_SHORT: + if (indef) + Mems[pp] = INDEFS + else + Mems[pp] = value + case TY_INT: + if (indef) + Memi[pp] = INDEFI + else + Memi[pp] = value + case TY_LONG: + if (indef) + Meml[pp] = INDEFL + else + Meml[pp] = value + case TY_REAL: + if (indef) + Memr[pp] = INDEFR + else + Memr[pp] = value + case TY_DOUBLE: + if (indef) + Memd[pp] = INDEFD + else + Memd[pp] = value + default: + call syserrs (SYS_QPBADCONV, param) + } + + # Update the parameter in the datafile. + call qp_flushpar (qp) +end diff --git a/sys/qpoe/gen/qpputd.x b/sys/qpoe/gen/qpputd.x new file mode 100644 index 00000000..2c9883e0 --- /dev/null +++ b/sys/qpoe/gen/qpputd.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../qpoe.h" + +# QP_PUT -- Set the value of the named header parameter. Automatic type +# conversion is performed where possible. While only scalar values can be +# set by this function, the scalar may be an element of a one-dimensional +# array, e.g., "param[N]". + +procedure qp_putd (qp, param, value) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +double value #I scalar parameter value + +pointer pp +bool indef +int dtype +int qp_putparam() +errchk qp_putparam, syserrs + +begin + # Lookup the parameter and get a pointer to the value buffer. + dtype = qp_putparam (qp, param, pp) + if (pp == NULL) + call syserrs (SYS_QPNOVAL, param) + + if (QP_DEBUG(qp) > 1) { + call eprintf ("qp_put: `%s', TYP=(%d->%d), new value %g\n") + call pargstr (param) + call pargi (TY_DOUBLE) + call pargi (dtype) + call pargd (value) + } + + indef = IS_INDEFD(value) + + # Set the parameter value. + switch (dtype) { + case TY_CHAR: + Memc[pp] = value + case TY_SHORT: + if (indef) + Mems[pp] = INDEFS + else + Mems[pp] = value + case TY_INT: + if (indef) + Memi[pp] = INDEFI + else + Memi[pp] = value + case TY_LONG: + if (indef) + Meml[pp] = INDEFL + else + Meml[pp] = value + case TY_REAL: + if (indef) + Memr[pp] = INDEFR + else + Memr[pp] = value + case TY_DOUBLE: + if (indef) + Memd[pp] = INDEFD + else + Memd[pp] = value + default: + call syserrs (SYS_QPBADCONV, param) + } + + # Update the parameter in the datafile. + call qp_flushpar (qp) +end diff --git a/sys/qpoe/gen/qpputi.x b/sys/qpoe/gen/qpputi.x new file mode 100644 index 00000000..528e6bc7 --- /dev/null +++ b/sys/qpoe/gen/qpputi.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../qpoe.h" + +# QP_PUT -- Set the value of the named header parameter. Automatic type +# conversion is performed where possible. While only scalar values can be +# set by this function, the scalar may be an element of a one-dimensional +# array, e.g., "param[N]". + +procedure qp_puti (qp, param, value) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +int value #I scalar parameter value + +pointer pp +bool indef +int dtype +int qp_putparam() +errchk qp_putparam, syserrs + +begin + # Lookup the parameter and get a pointer to the value buffer. + dtype = qp_putparam (qp, param, pp) + if (pp == NULL) + call syserrs (SYS_QPNOVAL, param) + + if (QP_DEBUG(qp) > 1) { + call eprintf ("qp_put: `%s', TYP=(%d->%d), new value %g\n") + call pargstr (param) + call pargi (TY_INT) + call pargi (dtype) + call pargi (value) + } + + indef = IS_INDEFI(value) + + # Set the parameter value. + switch (dtype) { + case TY_CHAR: + Memc[pp] = value + case TY_SHORT: + if (indef) + Mems[pp] = INDEFS + else + Mems[pp] = value + case TY_INT: + if (indef) + Memi[pp] = INDEFI + else + Memi[pp] = value + case TY_LONG: + if (indef) + Meml[pp] = INDEFL + else + Meml[pp] = value + case TY_REAL: + if (indef) + Memr[pp] = INDEFR + else + Memr[pp] = value + case TY_DOUBLE: + if (indef) + Memd[pp] = INDEFD + else + Memd[pp] = value + default: + call syserrs (SYS_QPBADCONV, param) + } + + # Update the parameter in the datafile. + call qp_flushpar (qp) +end diff --git a/sys/qpoe/gen/qpputl.x b/sys/qpoe/gen/qpputl.x new file mode 100644 index 00000000..50e6605a --- /dev/null +++ b/sys/qpoe/gen/qpputl.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../qpoe.h" + +# QP_PUT -- Set the value of the named header parameter. Automatic type +# conversion is performed where possible. While only scalar values can be +# set by this function, the scalar may be an element of a one-dimensional +# array, e.g., "param[N]". + +procedure qp_putl (qp, param, value) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +long value #I scalar parameter value + +pointer pp +bool indef +int dtype +int qp_putparam() +errchk qp_putparam, syserrs + +begin + # Lookup the parameter and get a pointer to the value buffer. + dtype = qp_putparam (qp, param, pp) + if (pp == NULL) + call syserrs (SYS_QPNOVAL, param) + + if (QP_DEBUG(qp) > 1) { + call eprintf ("qp_put: `%s', TYP=(%d->%d), new value %g\n") + call pargstr (param) + call pargi (TY_LONG) + call pargi (dtype) + call pargl (value) + } + + indef = IS_INDEFL(value) + + # Set the parameter value. + switch (dtype) { + case TY_CHAR: + Memc[pp] = value + case TY_SHORT: + if (indef) + Mems[pp] = INDEFS + else + Mems[pp] = value + case TY_INT: + if (indef) + Memi[pp] = INDEFI + else + Memi[pp] = value + case TY_LONG: + if (indef) + Meml[pp] = INDEFL + else + Meml[pp] = value + case TY_REAL: + if (indef) + Memr[pp] = INDEFR + else + Memr[pp] = value + case TY_DOUBLE: + if (indef) + Memd[pp] = INDEFD + else + Memd[pp] = value + default: + call syserrs (SYS_QPBADCONV, param) + } + + # Update the parameter in the datafile. + call qp_flushpar (qp) +end diff --git a/sys/qpoe/gen/qpputr.x b/sys/qpoe/gen/qpputr.x new file mode 100644 index 00000000..10af764b --- /dev/null +++ b/sys/qpoe/gen/qpputr.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../qpoe.h" + +# QP_PUT -- Set the value of the named header parameter. Automatic type +# conversion is performed where possible. While only scalar values can be +# set by this function, the scalar may be an element of a one-dimensional +# array, e.g., "param[N]". + +procedure qp_putr (qp, param, value) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +real value #I scalar parameter value + +pointer pp +bool indef +int dtype +int qp_putparam() +errchk qp_putparam, syserrs + +begin + # Lookup the parameter and get a pointer to the value buffer. + dtype = qp_putparam (qp, param, pp) + if (pp == NULL) + call syserrs (SYS_QPNOVAL, param) + + if (QP_DEBUG(qp) > 1) { + call eprintf ("qp_put: `%s', TYP=(%d->%d), new value %g\n") + call pargstr (param) + call pargi (TY_REAL) + call pargi (dtype) + call pargr (value) + } + + indef = IS_INDEFR(value) + + # Set the parameter value. + switch (dtype) { + case TY_CHAR: + Memc[pp] = value + case TY_SHORT: + if (indef) + Mems[pp] = INDEFS + else + Mems[pp] = value + case TY_INT: + if (indef) + Memi[pp] = INDEFI + else + Memi[pp] = value + case TY_LONG: + if (indef) + Meml[pp] = INDEFL + else + Meml[pp] = value + case TY_REAL: + if (indef) + Memr[pp] = INDEFR + else + Memr[pp] = value + case TY_DOUBLE: + if (indef) + Memd[pp] = INDEFD + else + Memd[pp] = value + default: + call syserrs (SYS_QPBADCONV, param) + } + + # Update the parameter in the datafile. + call qp_flushpar (qp) +end diff --git a/sys/qpoe/gen/qpputs.x b/sys/qpoe/gen/qpputs.x new file mode 100644 index 00000000..ec58607a --- /dev/null +++ b/sys/qpoe/gen/qpputs.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../qpoe.h" + +# QP_PUT -- Set the value of the named header parameter. Automatic type +# conversion is performed where possible. While only scalar values can be +# set by this function, the scalar may be an element of a one-dimensional +# array, e.g., "param[N]". + +procedure qp_puts (qp, param, value) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +short value #I scalar parameter value + +pointer pp +bool indef +int dtype +int qp_putparam() +errchk qp_putparam, syserrs + +begin + # Lookup the parameter and get a pointer to the value buffer. + dtype = qp_putparam (qp, param, pp) + if (pp == NULL) + call syserrs (SYS_QPNOVAL, param) + + if (QP_DEBUG(qp) > 1) { + call eprintf ("qp_put: `%s', TYP=(%d->%d), new value %g\n") + call pargstr (param) + call pargi (TY_SHORT) + call pargi (dtype) + call pargs (value) + } + + indef = IS_INDEFS(value) + + # Set the parameter value. + switch (dtype) { + case TY_CHAR: + Memc[pp] = value + case TY_SHORT: + if (indef) + Mems[pp] = INDEFS + else + Mems[pp] = value + case TY_INT: + if (indef) + Memi[pp] = INDEFI + else + Memi[pp] = value + case TY_LONG: + if (indef) + Meml[pp] = INDEFL + else + Meml[pp] = value + case TY_REAL: + if (indef) + Memr[pp] = INDEFR + else + Memr[pp] = value + case TY_DOUBLE: + if (indef) + Memd[pp] = INDEFD + else + Memd[pp] = value + default: + call syserrs (SYS_QPBADCONV, param) + } + + # Update the parameter in the datafile. + call qp_flushpar (qp) +end diff --git a/sys/qpoe/gen/qprlmerged.x b/sys/qpoe/gen/qprlmerged.x new file mode 100644 index 00000000..d08f4e5f --- /dev/null +++ b/sys/qpoe/gen/qprlmerged.x @@ -0,0 +1,134 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../qpex.h" + +# QP_RLMERGE -- Merge (AND) two range lists. Only ranges which are +# common to both range lists are output. The number of ranges in the +# output range list is returned as the function value. + +int procedure qp_rlmerged (os,oe,olen, xs,xe,nx, ys,ye,ny) + +pointer os, oe #U output range list +int olen #U allocated length of OS, OE arrays + +double xs[ARB], xe[ARB] #I range list to be merged with +int nx #I number of ranges in X list +double ys[ARB], ye[ARB] #I range list to be merged with X +int ny #I number of ranges in Y list + +double o1, o2 +int nx_out, xi, yi, i +double qp_minvald(), qp_maxvald() +bool qp_lessthand() +errchk realloc + +begin + nx_out = 0 + if (nx <= 0 || ny <= 0) + return (0) + + xi = 1 + yi = 1 + + do i = 1, ARB { + # Find a pair of ranges which intersect. + repeat { + if (qp_lessthand (xe[xi], ys[yi])) { + if (xi >= nx) + return (nx_out) + else + xi = xi + 1 + } else if (qp_lessthand (ye[yi], xs[xi])) { + if (yi >= ny) + return (nx_out) + else + yi = yi + 1 + } else + break + } + + # Compute the intersection. + o1 = qp_maxvald (xs[xi], ys[yi]) + o2 = qp_minvald (xe[xi], ye[yi]) + + # Output the range. + if (nx_out + 1 > olen) { + olen = max (DEF_XLEN, olen * 2) + call realloc (os, olen, TY_DOUBLE) + call realloc (oe, olen, TY_DOUBLE) + } + + Memd[os+nx_out] = o1 + Memd[oe+nx_out] = o2 + nx_out = nx_out + 1 + + # Advance to the next range. + if (xi < nx && qp_lessthand (xe[xi], ye[yi])) + xi = xi + 1 + else if (yi < ny) + yi = yi + 1 + else + break + } + + return (nx_out) +end + + +# QP_MINVAL -- Return the lesser of two values, where either value can +# be an open range. + +double procedure qp_minvald (x, y) + +double x #I first value +double y #I second value + +bool qp_lessthand() + +begin + if (qp_lessthand (x, y)) + return (x) + else + return (y) +end + + +# QP_MAXVAL -- Return the greater of two values, where either value can +# be an open range. + +double procedure qp_maxvald (x, y) + +double x #I first value +double y #I second value + +bool qp_lessthand() + +begin + if (qp_lessthand (x, y)) + return (y) + else + return (x) +end + + +# QP_LESSTHAN -- Test if X is less than Y, where X and Y can be open +# range values. + +bool procedure qp_lessthand (x, y) + +double x #I first value +double y #I second value + +begin + if (IS_LEFTD(x)) + return (!IS_LEFTD(y)) + else if (IS_RIGHTD(x)) + return (false) + else if (IS_LEFTD(y)) + return (false) + else if (IS_RIGHTD(y)) + return (true) + else + return (x < y) +end diff --git a/sys/qpoe/gen/qprlmergei.x b/sys/qpoe/gen/qprlmergei.x new file mode 100644 index 00000000..f8476178 --- /dev/null +++ b/sys/qpoe/gen/qprlmergei.x @@ -0,0 +1,134 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../qpex.h" + +# QP_RLMERGE -- Merge (AND) two range lists. Only ranges which are +# common to both range lists are output. The number of ranges in the +# output range list is returned as the function value. + +int procedure qp_rlmergei (os,oe,olen, xs,xe,nx, ys,ye,ny) + +pointer os, oe #U output range list +int olen #U allocated length of OS, OE arrays + +int xs[ARB], xe[ARB] #I range list to be merged with +int nx #I number of ranges in X list +int ys[ARB], ye[ARB] #I range list to be merged with X +int ny #I number of ranges in Y list + +int o1, o2 +int nx_out, xi, yi, i +int qp_minvali(), qp_maxvali() +bool qp_lessthani() +errchk realloc + +begin + nx_out = 0 + if (nx <= 0 || ny <= 0) + return (0) + + xi = 1 + yi = 1 + + do i = 1, ARB { + # Find a pair of ranges which intersect. + repeat { + if (qp_lessthani (xe[xi], ys[yi])) { + if (xi >= nx) + return (nx_out) + else + xi = xi + 1 + } else if (qp_lessthani (ye[yi], xs[xi])) { + if (yi >= ny) + return (nx_out) + else + yi = yi + 1 + } else + break + } + + # Compute the intersection. + o1 = qp_maxvali (xs[xi], ys[yi]) + o2 = qp_minvali (xe[xi], ye[yi]) + + # Output the range. + if (nx_out + 1 > olen) { + olen = max (DEF_XLEN, olen * 2) + call realloc (os, olen, TY_INT) + call realloc (oe, olen, TY_INT) + } + + Memi[os+nx_out] = o1 + Memi[oe+nx_out] = o2 + nx_out = nx_out + 1 + + # Advance to the next range. + if (xi < nx && qp_lessthani (xe[xi], ye[yi])) + xi = xi + 1 + else if (yi < ny) + yi = yi + 1 + else + break + } + + return (nx_out) +end + + +# QP_MINVAL -- Return the lesser of two values, where either value can +# be an open range. + +int procedure qp_minvali (x, y) + +int x #I first value +int y #I second value + +bool qp_lessthani() + +begin + if (qp_lessthani (x, y)) + return (x) + else + return (y) +end + + +# QP_MAXVAL -- Return the greater of two values, where either value can +# be an open range. + +int procedure qp_maxvali (x, y) + +int x #I first value +int y #I second value + +bool qp_lessthani() + +begin + if (qp_lessthani (x, y)) + return (y) + else + return (x) +end + + +# QP_LESSTHAN -- Test if X is less than Y, where X and Y can be open +# range values. + +bool procedure qp_lessthani (x, y) + +int x #I first value +int y #I second value + +begin + if (IS_LEFTI(x)) + return (!IS_LEFTI(y)) + else if (IS_RIGHTI(x)) + return (false) + else if (IS_LEFTI(y)) + return (false) + else if (IS_RIGHTI(y)) + return (true) + else + return (x < y) +end diff --git a/sys/qpoe/gen/qprlmerger.x b/sys/qpoe/gen/qprlmerger.x new file mode 100644 index 00000000..a776a5db --- /dev/null +++ b/sys/qpoe/gen/qprlmerger.x @@ -0,0 +1,134 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../qpex.h" + +# QP_RLMERGE -- Merge (AND) two range lists. Only ranges which are +# common to both range lists are output. The number of ranges in the +# output range list is returned as the function value. + +int procedure qp_rlmerger (os,oe,olen, xs,xe,nx, ys,ye,ny) + +pointer os, oe #U output range list +int olen #U allocated length of OS, OE arrays + +real xs[ARB], xe[ARB] #I range list to be merged with +int nx #I number of ranges in X list +real ys[ARB], ye[ARB] #I range list to be merged with X +int ny #I number of ranges in Y list + +real o1, o2 +int nx_out, xi, yi, i +real qp_minvalr(), qp_maxvalr() +bool qp_lessthanr() +errchk realloc + +begin + nx_out = 0 + if (nx <= 0 || ny <= 0) + return (0) + + xi = 1 + yi = 1 + + do i = 1, ARB { + # Find a pair of ranges which intersect. + repeat { + if (qp_lessthanr (xe[xi], ys[yi])) { + if (xi >= nx) + return (nx_out) + else + xi = xi + 1 + } else if (qp_lessthanr (ye[yi], xs[xi])) { + if (yi >= ny) + return (nx_out) + else + yi = yi + 1 + } else + break + } + + # Compute the intersection. + o1 = qp_maxvalr (xs[xi], ys[yi]) + o2 = qp_minvalr (xe[xi], ye[yi]) + + # Output the range. + if (nx_out + 1 > olen) { + olen = max (DEF_XLEN, olen * 2) + call realloc (os, olen, TY_REAL) + call realloc (oe, olen, TY_REAL) + } + + Memr[os+nx_out] = o1 + Memr[oe+nx_out] = o2 + nx_out = nx_out + 1 + + # Advance to the next range. + if (xi < nx && qp_lessthanr (xe[xi], ye[yi])) + xi = xi + 1 + else if (yi < ny) + yi = yi + 1 + else + break + } + + return (nx_out) +end + + +# QP_MINVAL -- Return the lesser of two values, where either value can +# be an open range. + +real procedure qp_minvalr (x, y) + +real x #I first value +real y #I second value + +bool qp_lessthanr() + +begin + if (qp_lessthanr (x, y)) + return (x) + else + return (y) +end + + +# QP_MAXVAL -- Return the greater of two values, where either value can +# be an open range. + +real procedure qp_maxvalr (x, y) + +real x #I first value +real y #I second value + +bool qp_lessthanr() + +begin + if (qp_lessthanr (x, y)) + return (y) + else + return (x) +end + + +# QP_LESSTHAN -- Test if X is less than Y, where X and Y can be open +# range values. + +bool procedure qp_lessthanr (x, y) + +real x #I first value +real y #I second value + +begin + if (IS_LEFTR(x)) + return (!IS_LEFTR(y)) + else if (IS_RIGHTR(x)) + return (false) + else if (IS_LEFTR(y)) + return (false) + else if (IS_RIGHTR(y)) + return (true) + else + return (x < y) +end diff --git a/sys/qpoe/mkpkg b/sys/qpoe/mkpkg new file mode 100644 index 00000000..b7553b0f --- /dev/null +++ b/sys/qpoe/mkpkg @@ -0,0 +1,133 @@ +# Make the QPOE (position ordered event file) library. + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +zzdebug: +zzdebug.e: + $checkout libex.a lib$ + $update libex.a + $checkin libex.a lib$ + + $omake zzdebug.x "qpoe.h" + $link -z zzdebug.o + ; + +generic: + $set GFLAGS = "-k -t csilrd -p gen/" + $ifolder (gen/qpgeti.x, qpget.gx) $generic $(GFLAGS) qpget.gx $endif + $ifolder (gen/qpputi.x, qpput.gx) $generic $(GFLAGS) qpput.gx $endif + + $set GFLAGS = "-k -t bcsilrdx -p gen/" + $ifolder (gen/qpaddb.x, qpadd.gx) $generic $(GFLAGS) qpadd.gx $endif + + $set GFLAGS = "-k -t ird -p gen/" + $ifolder (gen/qpexattrli.x, qpexattrl.gx) + $generic $(GFLAGS) qpexattrl.gx $endif + $ifolder (gen/qpexcodei.x, qpexcode.gx) + $generic $(GFLAGS) qpexcode.gx $endif + $ifolder (gen/qpexparsei.x, qpexparse.gx) + $generic $(GFLAGS) qpexparse.gx $endif + $ifolder (gen/qpexsubi.x, qpexsub.gx) + $generic $(GFLAGS) qpexsub.gx $endif + + $ifolder (gen/qprlmergei.x, qprlmerge.gx) + $generic $(GFLAGS) qprlmerge.gx $endif + + $set GFLAGS = "-k -t si -p gen/" + $ifolder (gen/qpiorpixi.x, qpiorpix.gx) + $generic $(GFLAGS) qpiorpix.gx $endif + $ifolder (gen/qpiogetev.x, qpiogetev.gx) + $generic -k -o gen/qpiogetev.x qpiogetev.gx $endif + ; + +libex.a: + # Retranslate any recently modified generic sources. + $ifeq (hostid, unix) + $call generic + $endif + + @gen # Update datatype expanded files. + + qpaccess.x qpoe.h + qpaccessf.x qpoe.h + qpaddf.x qpoe.h + qpastr.x qpoe.h + qpbind.x qpoe.h + qpclose.x qpoe.h + qpcopy.x qpoe.h + qpcopyf.x qpoe.h + qpctod.x + qpctoi.x + qpdelete.x qpoe.h + qpdeletef.x qpoe.h + qpdsym.x qpoe.h + qpdtype.x qpoe.h + qpelsize.x + qpexclose.x qpex.h + qpexdata.x qpex.h + qpexdebug.x qpex.h qpoe.h + qpexdel.x qpex.h + qpexeval.x qpex.h + qpexgetat.x qpex.h + qpexgetfil.x qpex.h + qpexmodfil.x qpex.h qpoe.h + qpexopen.x qpex.h qpoe.h + qpexpand.x qpoe.h + qpgetb.x qpoe.h + qpgettok.x qpoe.h + qpgetx.x qpoe.h + qpgmsym.x qpoe.h + qpgnfn.x qpoe.h + qpgpar.x qpoe.h + qpgpsym.x qpoe.h + qpgstr.x qpoe.h + qpinherit.x qpoe.h + qpioclose.x qpio.h + qpiogetfil.x qpio.h qpoe.h + qpiogetrg.x qpio.h + qpiolmask.x qpio.h qpoe.h + qpiolwcs.x qpio.h + qpiomkidx.x qpio.h qpoe.h + qpioopen.x qpex.h qpio.h qpoe.h \ + + qpioparse.x qpex.h qpio.h qpoe.h + qpioputev.x qpio.h qpoe.h + qpiorb.x qpio.h + qpiosetfil.x qpex.h qpio.h + qpioseti.x qpio.h + qpiosetr.x qpio.h + qpiosetrg.x qpio.h + qpiostati.x qpio.h + qpiostatr.x qpio.h + qpiosync.x qpio.h qpoe.h + qpiowb.x qpio.h qpoe.h + qplenf.x qpoe.h + qploadwcs.x qpoe.h + qpmacro.x qpex.h qpoe.h + qpmkfname.x qpoe.h + qpopen.x qpio.h qpoe.h + qpparse.x + qpparsefl.x qpex.h qpoe.h + qppclose.x + qppopen.x qpoe.h + qpppar.x qpoe.h + qppstr.x qpoe.h + qpputb.x qpoe.h + qpputx.x qpoe.h + qpqueryf.x qpoe.h + qpread.x qpoe.h + qprebuild.x qpoe.h + qprename.x qpoe.h + qprenamef.x qpoe.h + qpsavewcs.x qpoe.h + qpseti.x qpoe.h + qpsetr.x qpoe.h + qpsizeof.x qpoe.h + qpstati.x qpoe.h + qpstatr.x qpoe.h + qpsync.x qpoe.h + qpwrite.x qpoe.h + ; diff --git a/sys/qpoe/qpaccess.x b/sys/qpoe/qpaccess.x new file mode 100644 index 00000000..b8f5079f --- /dev/null +++ b/sys/qpoe/qpaccess.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "qpoe.h" + +# QP_ACCESS -- Test if the named poefile exists and is accessible with the +# given mode (mode=0 merely tests for the existence of the poefile). + +int procedure qp_access (poefile, mode) + +char poefile[ARB] #I poefile name +int mode #I access mode + +int status +pointer sp, fname +int access() + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + call qp_mkfname (poefile, QPOE_EXTN, Memc[fname], SZ_PATHNAME) + status = access (Memc[fname], mode, 0) + + call sfree (sp) + return (status) +end diff --git a/sys/qpoe/qpaccessf.x b/sys/qpoe/qpaccessf.x new file mode 100644 index 00000000..4b11d570 --- /dev/null +++ b/sys/qpoe/qpaccessf.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "qpoe.h" + +# QP_ACCESSF -- Test whether the named field (header parameter) exists. +# Globally aliased parameters are recursively expanded and must resolve to +# a normal parameter reference. + +int procedure qp_accessf (qp, param) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name + +pointer qp_gpsym() +errchk qp_bind, qp_gpsym + +begin + if (QP_ACTIVE(qp) == NO) + call qp_bind (qp) + if (qp_gpsym (qp, param) != NULL) + return (YES) + else + return (NO) +end diff --git a/sys/qpoe/qpadd.gx b/sys/qpoe/qpadd.gx new file mode 100644 index 00000000..83f240ae --- /dev/null +++ b/sys/qpoe/qpadd.gx @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../qpoe.h" + +# QP_ADD -- Set the value of a parameter, creating the parameter if it does +# not already exist. This works for the most common case of simple scalar +# valued header parameters, although any parameter may be written into it it +# already exists. Additional control over the parameter attributes is possible +# if the parameter is explicitly created with qp_addf before being written into. + +procedure qp_add$t (qp, param, value, comment) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +PIXEL value #I parameter value +char comment[ARB] #I comment field, if creating parameter + +char datatype[1] +errchk qp_accessf, qp_addf +string dtypes SPPTYPES +int qp_accessf() + +begin + if (qp_accessf (qp, param) == NO) { + datatype[1] = dtypes[TY_PIXEL] + call qp_addf (qp, param, datatype, 1, comment, 0) + } + call qp_put$t (qp, param, value) +end diff --git a/sys/qpoe/qpaddf.x b/sys/qpoe/qpaddf.x new file mode 100644 index 00000000..e72c2cc1 --- /dev/null +++ b/sys/qpoe/qpaddf.x @@ -0,0 +1,173 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "qpoe.h" + +# QP_ADDF -- Add a new field (header parameter) to the datafile. It is an +# error if the parameter redefines an existing symbol. For variable array +# parameters the initial size is zero, and a new lfile is allocated for the +# parameter value. For static parameters storage is initialized to all zeros. + +procedure qp_addf (qp, param, datatype, maxelem, comment, flags) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +char datatype[ARB] #I parameter data type +int maxelem #I allocated length of parameter +char comment[ARB] #I comment describing parameter +int flags #I parameter flags + +bool newtype +pointer sp, text, st, fm, sym, pval, dsym, dd +int fd, sz_elem, type, nchars, dtype, nfields, i + +long note() +pointer qp_gpsym(), stenter(), strefstab() +int stpstr(), qp_dtype(), qp_parsefl(), gstrcpy +int fm_nextlfile(), fm_getfd(), qp_elementsize(), fm_fopen() +errchk qp_bind, qp_gpsym, stenter, stpstr, fm_nextlfile, fm_fopen +errchk fm_getfd, note, write, syserrs +define fixed_ 91 + +begin + call smark (sp) + call salloc (text, SZ_TEXTBUF, TY_CHAR) + + if (QP_ACTIVE(qp) == NO) + call qp_bind (qp) + + st = QP_ST(qp) + fm = QP_FM(qp) + + # Resolve any macro references in the 'datatype' text. + # (Disabled - not sure this is a good idea here). + + # nchars = qp_expandtext (qp, datatype, Memc[text], SZ_TEXTBUF) + nchars = gstrcpy (datatype, Memc[text], SZ_TEXTBUF) + + if (QP_DEBUG(qp) > 1) { + call eprintf ("qp_addf: `%s' typ=`%s' nel=%d com=`%s' flg=%oB\n") + call pargstr (param) + call pargstr (Memc[text]) + call pargi (maxelem) + call pargstr (comment) + call pargi (flags) + } + + # Check for a redefinition. + sym = qp_gpsym (qp, param) + if (sym != NULL) + call syserrs (SYS_QPREDEF, param) + + # Add the symbol. + sym = stenter (st, param, LEN_SYMBOL) + + # Determine symbol type. + dtype = qp_dtype (qp, Memc[text], dsym) + newtype = (dtype == TY_USER && dsym == NULL) + sz_elem = qp_elementsize (qp, Memc[text], INSTANCEOF) + + S_DTYPE(sym) = dtype + S_SZELEM(sym) = 0 + if (dsym != NULL) + S_DSYM(sym) = dsym - strefstab(st,0) + else + S_DSYM(sym) = 0 + + # If defining a new user datatype (domain), SZELEM is the size of + # a structure element in chars, and MAXELEM is the length of the + # field list string, which becomes the value of the domain definition + # parameter. + + if (newtype) { + S_MAXELEM(sym) = nchars + call salloc (dd, LEN_DDDES, TY_STRUCT) + iferr (nfields = qp_parsefl (qp, Memc[text], dd)) + call erract (EA_WARN) + else + S_SZELEM(sym) = DD_STRUCTLEN(dd) * SZ_STRUCT + } else + S_MAXELEM(sym) = maxelem + + # If no flags are specified, set SF_INHERIT for fixed length params. + if (flags == 0 && S_MAXELEM(sym) > 0) + S_FLAGS(sym) = SF_INHERIT + else if (flags == QPF_NONE) + S_FLAGS(sym) = 0 + else + S_FLAGS(sym) = flags + + # Comments are stored in the symbol table and cannot be modified. + if (comment[1] != EOS) + S_COMMENT(sym) = stpstr (st, comment, 0) + else + S_COMMENT(sym) = NULL + + # Initialize data storage for the parameter. + if (S_MAXELEM(sym) == 0) { + # A variable length parameter; store in it's own lfile. The + # initial length is zero, hence initialization is not needed. + + S_NELEM(sym) = 0 + S_OFFSET(sym) = 1 + + # If we run out of lfiles, try to make do by allocating a fixed + # amount of static storage. + + iferr (S_LFILE(sym) = fm_nextlfile(fm)) { + S_MAXELEM(sym) = (QP_FMPAGESIZE(qp) + sz_elem-1) / sz_elem + call erract (EA_WARN) + goto fixed_ + } + + if (dtype == TY_CHAR) + type = TEXT_FILE + else + type = BINARY_FILE + + fd = fm_fopen (fm, S_LFILE(sym), NEW_FILE, type) + call close (fd) + + } else { + # A fixed length parameter; allocate and initialize storage in + # LF_STATICPARS. +fixed_ + fd = fm_getfd (fm, LF_STATICPARS, APPEND, 0) + + S_NELEM(sym) = 0 + S_OFFSET(sym) = note (fd) + S_LFILE(sym) = LF_STATICPARS + nchars = S_MAXELEM(sym) * sz_elem + + # The param value is the field list (datatype parameter) for a + # domain definition; otherwise we do not have a value yet, so we + # merely allocate the storage and initialize to zero. + + if (newtype) { + call write (fd, Memc[text], nchars) + S_NELEM(sym) = S_MAXELEM(sym) + } else { + call salloc (pval, nchars, TY_CHAR) + call aclrc (Memc[pval], nchars) + call write (fd, Memc[pval], nchars) + } + + call fm_retfd (fm, S_LFILE(sym)) + } + + if (QP_DEBUG(qp) > 2) { + # Dump symbol. + call eprintf ("%s: FLG=%oB TYP=%d DSY=%xX NEL=%d ") + call pargstr (param) + do i = 1, 4 + call pargi (Memi[sym+i-1]) + call eprintf ("MEL=%d SZE=%d COM=%xX LFN=%d OFF=%d\n") + do i = 5, 9 + call pargi (Memi[sym+i-1]) + } + + QP_MODIFIED(qp) = YES + call sfree (sp) +end diff --git a/sys/qpoe/qpastr.x b/sys/qpoe/qpastr.x new file mode 100644 index 00000000..4c856b10 --- /dev/null +++ b/sys/qpoe/qpastr.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "qpoe.h" + +# QP_ASTR -- Set the value of a string parameter, creating the parameter if +# it does not already exist. This works for the common case of string +# parameters allocated a fixed amount of space at create time (any type of +# string parameter can be written into if it already exists). Additional +# control over the parameter attributes is possible if the parameter is +# explicitly created with qp_addf before being written into. + +procedure qp_astr (qp, param, value, comment) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +char value[ARB] #I parameter value +char comment[ARB] #I comment field, if creating parameter + +int nchars +int qp_accessf(), strlen() +errchk qp_accessf, qp_addf + +begin + # By default we allocate a somewhat bigger storage area than needed + # to store the string, to permit updates of a similar length. If + # more control over the maximum string length is needed, QP_ADDF + # should be called explicitly. + + if (qp_accessf (qp, param) == NO) { + nchars = (strlen(value) + INC_STRLEN-1) / INC_STRLEN * INC_STRLEN + call qp_addf (qp, param, "c", nchars, comment, 0) + } + + call qp_pstr (qp, param, value) +end diff --git a/sys/qpoe/qpbind.x b/sys/qpoe/qpbind.x new file mode 100644 index 00000000..cd9c9bb6 --- /dev/null +++ b/sys/qpoe/qpbind.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpoe.h" + +# QP_BIND -- Fix the create-time QPOE file parameters. This is called +# after the open, when the first datafile access occurs. + +procedure qp_bind (qp) + +pointer qp #I QPOE descriptor + +int fd +pointer fm +pointer stopen() +int fm_fopen() +errchk stopen, fm_fopen + +begin + if (QP_ACTIVE(qp) == NO) { + fm = QP_FM(qp) + + # Create the initial symbol table. + QP_ST(qp) = stopen (QPOE_TITLE, + QP_STINDEXLEN(qp), QP_STSTABLEN(qp), QP_STSBUFSIZE(qp)) + + # Fix the datafile parameters. + call fm_seti (fm, FM_PAGESIZE, QP_FMPAGESIZE(qp)) + call fm_seti (fm, FM_MAXLFILES, QP_FMMAXLFILES(qp)) + call fm_seti (fm, FM_MAXPTPAGES, QP_FMMAXPTPAGES(qp)) + call fm_seti (fm, FM_FCACHESIZE, QP_FMCACHESIZE(qp)) + + # Create the QPOE header and static storage lfiles. + fd = fm_fopen (fm, LF_QPOE, NEW_FILE, BINARY_FILE) + call close (fd) + fd = fm_fopen (fm, LF_STATICPARS, NEW_FILE, BINARY_FILE) + call close (fd) + + # Must flag descriptor as active here to prevent reentrant + # calls via the procedures called by qp_inherit. + + QP_ACTIVE(qp) = YES + + # Inherit selected data objects from parent if NEW_COPY. + if (QP_MODE(qp) == NEW_COPY) + call qp_inherit (qp, QP_OQP(qp), STDERR) + } +end diff --git a/sys/qpoe/qpclose.x b/sys/qpoe/qpclose.x new file mode 100644 index 00000000..eb537622 --- /dev/null +++ b/sys/qpoe/qpclose.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "qpoe.h" + +# QP_CLOSE -- Close an open QPOE descriptor and file. + +procedure qp_close (qp) + +pointer qp #I QPOE descriptor + +begin + # An open/close should produce an empty poefile. + if (QP_ACTIVE(qp) == NO) { + QP_MODIFIED(qp) = YES + call qp_bind (qp) + } + + # Update the poefile on disk. + call qp_flushpar (qp) + call qp_sync (qp) + + # Shut everything down. + call stclose (QP_ST(qp)) + call fm_close (QP_FM(qp)) + call mfree (qp, TY_STRUCT) +end diff --git a/sys/qpoe/qpcopy.x b/sys/qpoe/qpcopy.x new file mode 100644 index 00000000..6d0a597d --- /dev/null +++ b/sys/qpoe/qpcopy.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "qpoe.h" + +# QP_COPY -- Copy a poefile. The output version is "rebuilt" in the process, +# i.e., the datafile is not merely physically copied, but instead is rebuilt to +# reclaim unused storage and render the file structures logically contiguous. + +procedure qp_copy (o_poefile, n_poefile) + +char o_poefile[ARB] #I old poefile name +char n_poefile[ARB] #I new poefile name + +pointer sp +pointer o_fname, n_fname +string extn QPOE_EXTN + +begin + call smark (sp) + call salloc (o_fname, SZ_PATHNAME, TY_CHAR) + call salloc (n_fname, SZ_PATHNAME, TY_CHAR) + + call qp_mkfname (o_poefile, extn, Memc[o_fname], SZ_PATHNAME) + call qp_mkfname (n_poefile, extn, Memc[n_fname], SZ_PATHNAME) + call fm_copy (Memc[o_fname], Memc[n_fname]) + + call sfree (sp) +end diff --git a/sys/qpoe/qpcopyf.x b/sys/qpoe/qpcopyf.x new file mode 100644 index 00000000..ba47ad4f --- /dev/null +++ b/sys/qpoe/qpcopyf.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpoe.h" + +define MAX_NELEM 8192 # copy unit (chunk) size + +# QP_COPYF -- Copy a field (parameter), either within a datafile, or from one +# datafile to another. + +procedure qp_copyf (o_qp, o_param, n_qp, n_param) + +pointer o_qp #I QPOE descriptor of old (input) datafile +char o_param[ARB] #I input parameter name +pointer n_qp #I QPOE descriptor of new (output) datafile +char n_param[ARB] #I output parameter name + +pointer sp, dp, cp, buf +int nelem, elsize, chunk, nleft, first, maxelem, flags +int qp_queryf(), qp_accessf(), qp_elementsize(), qp_read() +errchk qp_queryf, qp_addf, qp_read, qp_write + +begin + call smark (sp) + call salloc (dp, SZ_DATATYPE, TY_CHAR) + call salloc (cp, SZ_COMMENT, TY_CHAR) + + # Get parameter attributes and create new parameter if necessary. + nelem = qp_queryf (o_qp, o_param, Memc[dp], maxelem, Memc[cp], flags) + if (qp_accessf (n_qp, n_param) == NO) + call qp_addf (n_qp, n_param, Memc[dp], maxelem, Memc[cp], flags) + + # Copy parameter value. + if (nelem > 0) { + elsize = qp_elementsize (o_qp, Memc[dp], INSTANCEOF) + chunk = min (MAX_NELEM, nelem) + call salloc (buf, chunk * elsize, TY_CHAR) + + first = 1 + for (nleft=nelem; nleft > 0; nleft=nleft-nelem) { + nelem = qp_read (o_qp,o_param, Memc[buf], chunk,first, Memc[dp]) + call qp_write (n_qp,n_param, Memc[buf], nelem,first, Memc[dp]) + first = first + nelem + } + } + + call sfree (sp) +end diff --git a/sys/qpoe/qpctod.x b/sys/qpoe/qpctod.x new file mode 100644 index 00000000..6487650c --- /dev/null +++ b/sys/qpoe/qpctod.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define SZ_NUMBUF 32 # buffer for extracting numbers + +# QP_CTOD -- Return as a double the next numeric token from the input stream. +# This differs from the standard FMTIO procedures only in that colon is not +# considered a numeric character (as used in sexagesimal numbers). + +int procedure qp_ctod (str, ip, dval) + +char str[ARB] #I input string +int ip #U pointer into input string +double dval #O double value + +int nchars, op, i +char numbuf[SZ_NUMBUF] +int ctod() + +begin + i = ip + do op = 1, SZ_NUMBUF + if (str[i] != ':' && str[i] != EOS) { + numbuf[op] = str[i] + i = i + 1 + } else + break + + i = 1 + numbuf[op] = EOS + nchars = ctod (numbuf, i, dval) + ip = ip + i - 1 + + return (nchars) +end diff --git a/sys/qpoe/qpctoi.x b/sys/qpoe/qpctoi.x new file mode 100644 index 00000000..9ac70ddb --- /dev/null +++ b/sys/qpoe/qpctoi.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# QP_CTOI -- Decode an integer token from the input string, advancing the +# input pointer the the first character following the decoded number, and +# returning the number of numeric characters decoded as the function value. +# This is equivalent to the standard CTOI except that it calls LEXNUM first +# to determine the radix of the input number, hence can deals with hex and +# octal numbers as well as decimal. + +int procedure qp_ctoi (str, ip, ival) + +char str[ARB] #I input string +int ip #U pointer into input string +int ival #O integer value + +int ip_save, base, nchars +int gctol(), lexnum() + +begin + ip_save = ip + switch (lexnum (str, ip, nchars)) { + case LEX_OCTAL: + base = 8 + case LEX_HEX: + base = 16 + default: + base = 10 + } + + ip = ip_save + return (gctol (str, ip, ival, base)) +end diff --git a/sys/qpoe/qpdelete.x b/sys/qpoe/qpdelete.x new file mode 100644 index 00000000..16b32161 --- /dev/null +++ b/sys/qpoe/qpdelete.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "qpoe.h" + +# QP_DELETE -- Delete a poefile. + +procedure qp_delete (poefile) + +char poefile[ARB] #I poefile name +pointer sp, fname + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + call qp_mkfname (poefile, QPOE_EXTN, Memc[fname], SZ_PATHNAME) + call delete (Memc[fname]) + + call sfree (sp) +end diff --git a/sys/qpoe/qpdeletef.x b/sys/qpoe/qpdeletef.x new file mode 100644 index 00000000..b7c41189 --- /dev/null +++ b/sys/qpoe/qpdeletef.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpoe.h" + +# QP_DELETEF -- Delete a header parameter. It is an error if the named header +# parameter does not exist. Deletions are permanent once the datafile is +# updated. + +procedure qp_deletef (qp, param) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name + +pointer sym +pointer qp_gpsym() +errchk qp_gpsym, syserrs + +begin + # Access the named parameter. + sym = qp_gpsym (qp, param) + if (sym == NULL) + call syserrs (SYS_QPUKNPAR, param) + else if (and (S_FLAGS(sym), SF_DELETED) != 0) + return + + # If the parameter value is stored in its own lfile, delete it. + if (S_LFILE(sym) > LF_STATICPARS) + call fm_lfdelete (QP_FM(qp), S_LFILE(sym)) + + # Set the delete bit in the symbol descriptor. + S_FLAGS(sym) = or (S_FLAGS(sym), SF_DELETED) + + QP_MODIFIED(qp) = YES +end diff --git a/sys/qpoe/qpdsym.x b/sys/qpoe/qpdsym.x new file mode 100644 index 00000000..d94b54b4 --- /dev/null +++ b/sys/qpoe/qpdsym.x @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "qpoe.h" + +# QP_DSYM -- Dump the symbol table of a QPOE file. + +procedure qp_dsym (qp, out) + +pointer qp #I QPOE descriptor +int out #I output file + +int nsyms, i +pointer sp, st, sym, op, pname, syms +pointer sthead(), stnext(), stname() + +begin + call smark (sp) + st = QP_ST(qp) + + # Count the symbols. + nsyms = 0 + for (sym=sthead(st); sym != NULL; sym=stnext(st,sym)) + nsyms = nsyms + 1 + + # Construct a reversed array of symbol pointers. + call salloc (syms, nsyms, TY_POINTER) + op = syms + nsyms - 1 + for (sym=sthead(st); sym != NULL; sym=stnext(st,sym)) { + Memi[op] = sym + op = op - 1 + } + + # Output the symbols. + if (nsyms > 0) + call fprintf (out, +" SYMBOL FLAGS DTYPE DSYM NELEM MAXELEM SZELEM COMMENT LFILE OFFSET\n") + + do i = 1, nsyms { + sym = Memi[syms+i-1] + pname = stname (st, sym) + + call fprintf (out, "%16s %5o %5d %4d %5d %7d %6d %7x %5d %6d\n") + call pargstr (Memc[pname]) + call pargi (and (S_FLAGS(sym), 77777B)) + call pargi (S_DTYPE(sym)) + call pargi (S_DSYM(sym)) + call pargi (S_NELEM(sym)) + call pargi (S_MAXELEM(sym)) + call pargi (S_SZELEM(sym)) + call pargi (S_COMMENT(sym)) + call pargi (S_LFILE(sym)) + call pargi (S_OFFSET(sym)) + } + + call sfree (sp) +end diff --git a/sys/qpoe/qpdtype.x b/sys/qpoe/qpdtype.x new file mode 100644 index 00000000..ed5b9e89 --- /dev/null +++ b/sys/qpoe/qpdtype.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpoe.h" + +# QP_DTYPE -- Translate the given symbolic datatype name into an integer +# type code. The possible type codes are most of the standard SPP TY_type +# codes, plus TY_MACRO, TY_OPAQUE, and TY_USER. If the symbol type is TY_USER +# (a user defined data structure or domain)), then a pointer to the symbol +# table entry for the named domain is returned as an output argument. The +# integer type code is returned as the function value. + +int procedure qp_dtype (qp, datatype, dsym) + +pointer qp #I QPOE descriptor +char datatype[ARB] #I symbolic datatype name +pointer dsym #O pointer to domain symbol, if TY_USER + +char junk[1] +int dtype, ip +string types "|bool|char|short|int|long|real|double|complex|macro|opaque|" + +pointer stfind() +int stridx(), strdic() + +begin + dtype = NULL + dsym = NULL + for (ip=1; IS_WHITE(datatype[ip]); ip=ip+1) + ; + + # Single character standard dtype code (bcsilrdx)? + if (datatype[ip+1] == EOS) + dtype = stridx (datatype[ip], SPPTYPES) + + # Spelled out dtype name. Check standard names first. + if (dtype == NULL) { + dtype = strdic (datatype[ip], junk, 1, types) + if (dtype == 9) + dtype = TY_MACRO + else if (dtype == 10) + dtype = TY_OPAQUE + } + + # Lastly, check the special types. + if (dtype == 0) { + if (datatype[ip] == '{') # field list + dtype = TY_USER + else { + dsym = stfind (QP_ST(qp), datatype[ip]) + if (dsym != NULL) + dtype = S_DTYPE(dsym) + } + } + + return (dtype) +end diff --git a/sys/qpoe/qpelsize.x b/sys/qpoe/qpelsize.x new file mode 100644 index 00000000..b84e0dfa --- /dev/null +++ b/sys/qpoe/qpelsize.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# QP_ELEMENTSIZE -- Determine the size in chars of a QPOE datatype. This may +# be one of the special datatypes (user defined record types), or a primitive +# type. + +int procedure qp_elementsize (qp, datatype, reftype) + +pointer qp #I QPOE descriptor +char datatype[ARB] #I symbolic datatype name +int reftype #I type of reference (immediate or instanceof) + +pointer dsym +int dtype +int qp_sizeof(), qp_dtype() + +begin + dtype = qp_dtype (qp, datatype, dsym) + return (qp_sizeof (qp, dtype, dsym, reftype)) +end diff --git a/sys/qpoe/qpex.h b/sys/qpoe/qpex.h new file mode 100644 index 00000000..45cc3db0 --- /dev/null +++ b/sys/qpoe/qpex.h @@ -0,0 +1,164 @@ +# QPEX.H -- QPOE expression evaluator definitions. + +# Size limiting definitions. +define DEF_PROGBUFLEN 65536 # default program buffer length, ints +define DEF_DATABUFLEN 65536 # default data buffer length, chars +define DEF_SZEXPRBUF 2048 # default size expression buffer +define INC_SZEXPRBUF 2048 # increment if overflow +define DEF_XLEN 256 # default (initial) range buffer size +define MAX_INSTRUCTIONS ARB # arbitrary do-loop index +define MAX_LEVELS 32 # max levels of program nesting +define DEF_MAXRRLUTLEN 1024 # max RRLUT (reduced resolution) length +define DEF_MAXFRLUTLEN 8192 # max FRLUT (full resolution) length +define DEF_LUTMINRANGES 5 # use RRLUT if more ranges than this +define DEF_LUTSCALE 15 # multiplied by nranges to get rrlutlen + +# Magic values used to represent open ranges :N and N:. +define LEFTI -MAX_INT +define RIGHTI MAX_INT +define LEFTR -MAX_REAL +define RIGHTR MAX_REAL +define LEFTD -MAX_DOUBLE +define RIGHTD MAX_DOUBLE + +define IS_LEFTI (($1) == -MAX_INT) +define IS_RIGHTI (($1) == MAX_INT) +define IS_LEFTR (($1) <= -MAX_REAL) +define IS_RIGHTR (($1) >= MAX_REAL) +define IS_LEFTD (($1) <= -MAX_DOUBLE) +define IS_RIGHTD (($1) >= MAX_DOUBLE) + +# The compiled expression descriptor. The program buffer holds the compiled +# expression to be interpreted to test each data event structure. The data +# buffer is used to store program data, e.g., lookup table descriptors, +# TY_DOUBLE constants (these are too large to be stored directly in the +# compiled program), and the textual expressions compiled to generate the +# program; the latter are used by QPEX_GETFILTER to regenerate the current +# expression. The expression terms (ET) and lookup table (LT) descriptors +# are maintained on linked lists. New ET descriptors are linked onto the +# tail of the ET list; LT descriptors are linked onto the head of the LT list. +# The program and data buffers are *nonrelocatable* (hence fixed in size) +# to allow use of absolute pointers to reference structures within the buffers. + +define LEN_EXDES 16 +define EX_QP Memi[$1] # back pointer to QPOE descriptor +define EX_DEBUG Memi[$1+1] # debug level +define EX_START Memi[$1+2] # pointer to first instruction +define EX_PB Memi[$1+3] # pointer to program buffer (int) +define EX_PBTOP Memi[$1+4] # pointer to top+1 of pb +define EX_PBOP Memi[$1+5] # pointer to next avail. cell in pb +define EX_DB Memi[$1+6] # data buffer pointer (char) +define EX_DBTOP Memi[$1+7] # pointer to top+1 of db +define EX_DBOP Memi[$1+8] # pointer to next avail. cell in db +define EX_MAXFRLUTLEN Memi[$1+9] # max full-res lut length +define EX_MAXRRLUTLEN Memi[$1+10] # max reduced-res lut length +define EX_LUTMINRANGES Memi[$1+11] # min ranges required for a LUT +define EX_LUTSCALE Memi[$1+12] # scale nranges to frlutlen +define EX_ETHEAD Memi[$1+13] # offset of first expr term descriptor +define EX_ETTAIL Memi[$1+14] # offset of last expr term descriptor +define EX_LTHEAD Memi[$1+15] # offset of first LUT descriptor + +# Expression terms descriptor. Stored in the data buffer and maintained +# as a linked list. + +define LEN_ETDES 9 +define ET_ATTTYPE Memi[$1] # datatype of attribute +define ET_ATTOFF Memi[$1+1] # *typed* offset of attribute +define ET_PROGPTR Memi[$1+2] # pointer to program segment +define ET_NINSTR Memi[$1+3] # program segment size, instructions +define ET_DELETED Memi[$1+4] # set if term is deleted +define ET_ATNAME Memi[$1+5] # attribute name used in expr +define ET_ASSIGNOP Memi[$1+6] # type of assignment ("=", "+=") +define ET_EXPRTEXT Memi[$1+7] # saved expr text +define ET_NEXT Memi[$1+8] # databuf offset of next ET struct + +# Lookup table descriptor. Stored in the data buffer and maintained as a +# linked list. The table itself is separately allocated. + +define LEN_LTDES 10 +define LT_NEXT Memi[$1] # pointer to next stored LUT +define LT_TYPE Memi[$1+1] # TY_SHORT pointer to stored LUT +define LT_LUTP Memi[$1+2] # TY_SHORT pointer to stored LUT +define LT_NBINS Memi[$1+3] # number of lookup table entries +define LT_LEFT Memi[$1+4] # lut value if index off left end +define LT_RIGHT Memi[$1+5] # lut value if index off right end +define LT_I0 Memr[P2R($1+6)] # zero point for integer LUT +define LT_IS Memr[P2R($1+8)] # scale factor for integer LUT +define LT_R0 Memr[P2R($1+6)] # zero point for real LUT +define LT_RS Memr[P2R($1+8)] # scale factor for real LUT +define LT_D0 Memd[P2D($1+6)] # zero point for double LUT +define LT_DS Memd[P2D($1+8)] # scale factor for double LUT + +define LT_LUT Mems[LT_LUTP($1)+$2-1] # LT_LUT(lt,i) + +# Macros for referencing the fields of an instruction. TY_DOUBLE arguments +# are stored in the data buffer, storing an offset in the instruction field. + +define LEN_INSTRUCTION 4 # instruction length, ints + +define OPCODE Memi[$1] # instruction opcode. +define IARG1 Memi[$1+1] # first integer argument +define IARG2 Memi[$1+2] # second integer argument +define IARG3 Memi[$1+3] # third integer argument +define RARG1 Memr[P2R($1+1)] # first real argument +define RARG2 Memr[P2R($1+2)] # second real argument +define RARG3 Memr[P2R($1+3)] # third real argument +define DARG1 Memd[IARG1($1)] # first double argument +define DARG2 Memd[IARG2($1)] # second double argument +define DARG3 Memd[IARG3($1)] # third double argument + +# Instruction opcodes. + +define PASS 00 # set pass=true and return +define RET 01 # return from subprogram +define NOP 02 # no-operation +define GOTO 03 # goto offset +define XIFT 04 # exit if expr-value true +define XIFF 05 # exit if expr-value false +define LDSI 06 # load short to int +define LDII 07 # load int +define LDRR 08 # load real +define LDRD 09 # load real to double +define LDDD 10 # load double + +define BTTI 11 # bit test, int +define EQLI 12 # test if equal +define EQLR 13 +define EQLD 14 +define LEQI 15 # test if less than or equal +define LEQR 16 +define LEQD 17 +define GEQI 18 # test if greater than or equal +define GEQR 19 +define GEQD 20 +define RNGI 21 # range test +define RNGR 22 +define RNGD 23 + +define BTTXS 24 # bit test direct and exit if false +define BTTXI 25 +define NEQXS 26 # not equals test and exit +define NEQXI 27 +define NEQXR 28 +define NEQXD 29 +define EQLXS 30 # equality test direct and exit if false +define EQLXI 31 +define EQLXR 32 +define EQLXD 33 +define LEQXS 34 # LEQ test direct and exit if false +define LEQXI 35 +define LEQXR 36 +define LEQXD 37 +define GEQXS 38 # GEQ test direct and exit if false +define GEQXI 39 +define GEQXR 40 +define GEQXD 41 +define RNGXS 42 # range test direct and exit if false +define RNGXI 43 +define RNGXR 44 +define RNGXD 45 + +define LUTXS 46 # lookup table test +define LUTXI 47 +define LUTXR 48 +define LUTXD 49 diff --git a/sys/qpoe/qpexattrl.gx b/sys/qpoe/qpexattrl.gx new file mode 100644 index 00000000..7cd6cd0a --- /dev/null +++ b/sys/qpoe/qpexattrl.gx @@ -0,0 +1,127 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../qpex.h" + +# QPEX_ATTRL -- Get the good-value range list for the named attribute, as a +# binary range list of the indicated type. This range list is a simplified +# version of the original filter expression, which may have contained +# multiple fields, some negated or overlapping, in any order, subsequently +# modified or deleted with qpex_modfilter, etc. The final resultant range +# list is ordered and consists of discreet nonoverlapping ranges. +# +# Upon input the variables XS and XE should either point to a pair of +# preallocated buffers of length XLEN, or they should be set to NULL. +# The routine will reallocate the buffers as necessary to allow for long +# range lists, updating XLEN so that it always contains the actual length +# of the arrays (which may not be completely full). Each list element +# consists of a pair of values (xs[i],xe[i]) defining the start and end +# points of the range. If xs[1] is INDEF the range is open to the left, +# if xe[nranges] is INDEF the range is open to the right. The number of +# ranges output is returned as the function value. + +int procedure qpex_attrl$t (ex, attribute, xs, xe, xlen) + +pointer ex #I QPEX descriptor +char attribute[ARB] #I attribute name +pointer xs #U pointer to array of start values +pointer xe #U pointer to array of end values +int xlen #U length of xs/xe arrays + +pointer ps, pe, qs, qe +pointer sp, expr, ip, ep +int plen, qlen, np, nq, nx +int neterms, nchars, maxch +int qpex_getattribute(), qpex_parse$t(), qp_rlmerge$t() + +begin + call smark (sp) + + # Get attribute filter expression. In the unlikely event that the + # expression is too large to fit in our buffer, repeat with a buffer + # twice as large until it fits. + + maxch = DEF_SZEXPRBUF + nchars = 0 + + repeat { + maxch = maxch * 2 + call salloc (expr, maxch, TY_CHAR) + nchars = qpex_getattribute (ex, attribute, Memc[expr], maxch) + if (nchars <= 0) + break + } until (nchars < maxch) + + # Parse expression to produce a range list. If the expression + # contains multiple eterms each is parsed separately and merged + # into the final output range list. + + nx = 0 + neterms = 0 + + if (nchars > 0) { + # Get range list storage. + plen = DEF_XLEN + call malloc (ps, plen, TY_PIXEL) + call malloc (pe, plen, TY_PIXEL) + qlen = DEF_XLEN + call malloc (qs, qlen, TY_PIXEL) + call malloc (qe, qlen, TY_PIXEL) + + # Parse each subexpression and merge into output range list. + for (ip=expr; Memc[ip] != EOS; ) { + # Get next subexpression. + while (IS_WHITE (Memc[ip])) + ip = ip + 1 + for (ep=ip; Memc[ip] != EOS; ip=ip+1) + if (Memc[ip] == ';') { + Memc[ip] = EOS + ip = ip + 1 + break + } + if (Memc[ep] == EOS) + break + + # Copy output range list to X list temporary. + if (max(nx,1) > plen) { + plen = max(xlen,1) + call realloc (ps, plen, TY_PIXEL) + call realloc (pe, plen, TY_PIXEL) + } + if (neterms <= 0) { + Mem$t[ps] = LEFT$T + Mem$t[pe] = RIGHT$T + np = 1 + } else { + call amov$t (Mem$t[xs], Mem$t[ps], nx) + call amov$t (Mem$t[xe], Mem$t[pe], nx) + np = nx + } + + # Parse next eterm into Y list temporary. + nq = qpex_parse$t (Memc[ep], qs, qe, qlen) + + # Merge the X and Y lists, leaving result in output list. + nx = qp_rlmerge$t (xs,xe,xlen, + Mem$t[ps], Mem$t[pe], np, Mem$t[qs], Mem$t[qe], nq) + + neterms = neterms + 1 + } + + # Free temporary range list storage. + call mfree (ps, TY_PIXEL); call mfree (pe, TY_PIXEL) + call mfree (qs, TY_PIXEL); call mfree (qe, TY_PIXEL) + + # Convert LEFT/RIGHT magic values to INDEF. + if (nx > 0) { + if (IS_LEFT$T (Mem$t[xs])) + Mem$t[xs] = INDEF + if (IS_RIGHT$T (Mem$t[xe+nx-1])) + Mem$t[xe+nx-1] = INDEF + } + } + + call sfree (sp) + return (nx) +end diff --git a/sys/qpoe/qpexclose.x b/sys/qpoe/qpexclose.x new file mode 100644 index 00000000..137884e9 --- /dev/null +++ b/sys/qpoe/qpexclose.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpex.h" + +# QPEX_CLOSE -- Close the QPEX descriptor. + +procedure qpex_close (ex) + +pointer ex #I QPEX descriptor + +pointer lt + +begin + # Free any LUT buffers. + for (lt=EX_LTHEAD(ex); lt != NULL; lt=LT_NEXT(lt)) + call mfree (LT_LUTP(lt), TY_SHORT) + + # Free the data and program buffers. + call mfree (EX_PB(ex), TY_STRUCT) + call mfree (EX_DB(ex), TY_CHAR) + + # Free the main descriptor. + call mfree (ex, TY_STRUCT) +end diff --git a/sys/qpoe/qpexcode.gx b/sys/qpoe/qpexcode.gx new file mode 100644 index 00000000..e148b499 --- /dev/null +++ b/sys/qpoe/qpexcode.gx @@ -0,0 +1,484 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../qpex.h" + +# QPEX_CODEGEN -- Generate interpreter metacode to evaluate the given +# expression. The new code is appended to the current compiled program, +# adding additional constraints which a data event will have to meet to +# pass the filter. + +int procedure qpex_codegen$t (ex, atname, assignop, expr, offset, dtype) + +pointer ex #I qpex descriptor +char atname[ARB] #I attribute name (for expr regeneration) +char assignop[ARB] #I "=" or "+=" (for expr regeneration) +char expr[ARB] #I expression to be compiled +int offset #I typed offset of referenced attribute +int dtype #I datatype of referenced attribute + +int nbins, bin, xp +pointer lt, lut, lutx, pb +PIXEL x1, x2, xmin, xmax +int xlen, nranges, n_nranges, level, opcode, ip, i +pointer pb_save, db_save, xs_buf, xe_buf, xs, xe, n_xs, n_xe, et, prev + +PIXEL sv_xs[MAX_LEVELS], sv_xe[MAX_LEVELS] +pointer sv_lt[MAX_LEVELS], sv_lut[MAX_LEVELS], sv_lutx[MAX_LEVELS] +int sv_xp[MAX_LEVELS], sv_nranges[MAX_LEVELS], sv_bin[MAX_LEVELS] +int sv_nbins[MAX_LEVELS] + +$if (datatype == d) +double xoffset, xscale +double sv_xoffset[MAX_LEVELS], sv_xscale[MAX_LEVELS] +int d_x1, d_x2 +int qpex_refd() +$else +PIXEL d_x1, d_x2 +real xoffset, xscale +real sv_xoffset[MAX_LEVELS], sv_xscale[MAX_LEVELS] +$endif + +$if (datatype == rd) +bool fp_equal$t() +$else +define fp_equal$t($1==$2) +$endif + +$if (datatype == i) +bool complement +int maskval +int qp_ctoi() +$endif + +int qpex_parse$t() +int stridxs(), btoi(), qpex_sublist$t() +pointer qpex_dballoc(), qpex_dbpstr(), qpex_pbpos() +errchk qpex_dballoc, qpex_pbpin, malloc, calloc, realloc, qpex_parse$t + +string qpexwarn "QPEX Warning" +define error_ 91 +define next_ 92 +define null_ 93 +define resume_ 94 +define bbmask_ 95 +define continue_ 96 +define XS Mem$t[xs+($1)-1] +define XE Mem$t[xe+($1)-1] + +begin + pb = EX_PB(ex) + + # Save the program state in case we have to abort. + call qpex_mark (ex, pb_save, db_save) + + # Allocate and initialize a new expression term descriptor, linking + # it onto the tail of the ETTERMs list. + + et = qpex_dballoc (ex, LEN_ETDES, TY_STRUCT) + + ET_ATTTYPE(et) = dtype + ET_ATTOFF(et) = offset + ET_ATNAME(et) = qpex_dbpstr (ex, atname) + ET_ASSIGNOP(et) = qpex_dbpstr (ex, assignop) + ET_EXPRTEXT(et) = qpex_dbpstr (ex, expr) + ET_PROGPTR(et) = qpex_pbpos (ex) + ET_DELETED(et) = NO + + prev = EX_ETTAIL(ex) + if (prev != NULL) + ET_NEXT(prev) = et + ET_NEXT(et) = NULL + EX_ETTAIL(ex) = et + if (EX_ETHEAD(ex) == NULL) + EX_ETHEAD(ex) = et + + ip = stridxs ("%", expr) + $if (datatype == i) + # Attempt to compile a bitmask test if `%' is found in the + # expression. Since bitmasks cannot be mixed with range list + # expressions, this case is handled separately. + + if (ip > 0) { + complement = false + level = 0 + + # Parse expression (very limited for this case). + for (ip=1; expr[ip] != EOS; ip=ip+1) { + switch (expr[ip]) { + case '!': + complement = !complement + case '(', '[': + level = level + 1 + case ')', ']': + level = level - 1 + case '%': + ip = ip + 1 + if (qp_ctoi (expr, ip, maskval) < 0) + goto bbmask_ + else + ip = ip - 1 + default: + goto bbmask_ + } + } + + # Verify paren level, handle errors. + if (level != 0) { +bbmask_ call eprintf ("%s: bad bitmask expression `%s'\n") + call pargstr (qpexwarn) + call pargstr (expr) + goto error_ + } + + # Compile the bitmask test. + if (complement) + maskval = not(maskval) + if (dtype == TY_SHORT) + call qpex_pbpin (ex, BTTXS, offset, maskval, 0) + else + call qpex_pbpin (ex, BTTXI, offset, maskval, 0) + + # Finish setting up the eterm descriptor. + ET_NINSTR(et) = 1 + return (OK) + } + $else + # Bitmask tests are meaningless for floating point data. + if (ip > 0) { + call eprintf ("%s: bitmasks not permitted for floating data\n") + call pargstr (qpexwarn) + goto error_ + } + $endif + + # Compile a general range list expression. The basic procedure is + # to parse the expression to produce an optimized binary range list, + # then either compile the range list as an explicit series of + # instructions or as a lookup table, depending upon the number of + # ranges. + + xlen = DEF_XLEN + call malloc (xs_buf, xlen, TY_PIXEL) + call malloc (xe_buf, xlen, TY_PIXEL) + + # Convert expr to a binary range list and set up the initial context. + # Ensure that the range list buffers are large enough to hold any + # sublists extracted during compilation. + + nranges = qpex_parse$t (expr, xs_buf, xe_buf, xlen) + if (xlen < nranges * 2) { + xlen = nranges * 2 + call realloc (xs_buf, xlen, TY_PIXEL) + call realloc (xe_buf, xlen, TY_PIXEL) + } + + xs = xs_buf + xe = xe_buf + level = 0 + + repeat { +next_ + # Compile a new range list (or sublist). + if (nranges <= 0) { + # This shouldn't happen. +null_ call eprintf ("%s: null range list\n") + call pargstr (qpexwarn) + call qpex_pbpin (ex, PASS, 0, 0, 0) + + } else if (nranges == 1) { + # Output an instruction to load the data, perform the range + # test, and conditionally exit all in a single instruction. + + x1 = XS(1); x2 = XE(1) + $if (datatype == d) + d_x1 = qpex_refd (ex, x1) + d_x2 = qpex_refd (ex, x2) + $else + d_x1 = x1 + d_x2 = x2 + $endif + + if (dtype == TY_SHORT) { + if (IS_LEFT$T(x1) && IS_RIGHT$T(x2)) + ; # pass everything (no tests) + else if (IS_LEFT$T(x1)) + call qpex_pbpin (ex, LEQXS, offset, d_x2, 0) + else if (IS_RIGHT$T(x2)) + call qpex_pbpin (ex, GEQXS, offset, d_x1, 0) + else if (fp_equal$t (x1, x2)) + call qpex_pbpin (ex, EQLXS, offset, d_x1, d_x2) + else + call qpex_pbpin (ex, RNGXS, offset, d_x1, d_x2) + } else { + if (IS_LEFT$T(x1) && IS_RIGHT$T(x2)) + ; # pass everything (no tests) + else if (IS_LEFT$T(x1)) + call qpex_pbpin (ex, LEQX$T, offset, d_x2, 0) + else if (IS_RIGHT$T(x2)) + call qpex_pbpin (ex, GEQX$T, offset, d_x1, 0) + else if (fp_equal$t (x1, x2)) + call qpex_pbpin (ex, EQLX$T, offset, d_x1, d_x2) + else + call qpex_pbpin (ex, RNGX$T, offset, d_x1, d_x2) + } + + } else if (nranges < EX_LUTMINRANGES(ex)) { + # If the number of ranges to be tested for the data is small, + # compile explicit code to perform the range tests directly. + # Otherwise skip forward and compile a lookup table instead. + # In either case, the function of the instructions compiled + # is to test the data loaded into the register above, setting + # the value of PASS to true if the data lies in any of the + # indicated ranges. + + # Check for !X, which is indicated in range list form by a + # two element list bracketing the X on each side. + + if (nranges == 2) + if (IS_LEFT$T(XS(1)) && IS_RIGHT$T(XE(2))) + $if (datatype == si) + if (XE(1)+1 == XS(2)-1) { + if (dtype == TY_SHORT) + opcode = NEQXS + else + opcode = NEQXI + call qpex_pbpin (ex, opcode, offset, XE(1)+1, 0) + goto resume_ + } + $else $if (datatype == r) + if (fp_equal$t (XE(1), XS(2))) { + call qpex_pbpin (ex, NEQX$T, offset, XE(1), 0) + goto resume_ + } + $else + if (fp_equal$t (XE(1), XS(2))) { + call qpex_pbpin (ex, NEQX$T, offset, + qpex_refd(ex,XE(1)), 0) + goto resume_ + } + $endif $endif + + # If at level zero, output instruction to load data into + # register and initialize PASS to false. Don't bother if + # compiling a subprogram, as these operations will already + # have been performed by the caller. + + if (level == 0) { + $if (datatype == i) + if (dtype == TY_SHORT) + opcode = LDSI + else + opcode = LDII + $else + opcode = LD$T$T + $endif + call qpex_pbpin (ex, opcode, offset, 0, 0) + } + + # Compile a series of equality or range tests. + do i = 1, nranges { + x1 = XS(i); x2 = XE(i) + $if (datatype == d) + d_x1 = qpex_refd (ex, x1) + d_x2 = qpex_refd (ex, x2) + $else + d_x1 = x1 + d_x2 = x2 + $endif + + if (IS_LEFT$T(x1)) + call qpex_pbpin (ex, LEQ$T, d_x2, 0, 0) + else if (IS_RIGHT$T(x2)) + call qpex_pbpin (ex, GEQ$T, d_x1, 0, 0) + else if (fp_equal$t (x1, x2)) + call qpex_pbpin (ex, EQL$T, d_x1, d_x2, 0) + else + call qpex_pbpin (ex, RNG$T, d_x1, d_x2, 0) + } + + # Compile a test and exit instruction. + call qpex_pbpin (ex, XIFF, 0, 0, 0) + + } else { + # Compile a lookup table test. Lookup tables may be + # either compressed or fully resolved. If compressed + # (the resolution of the table is less than that of the + # range data, e.g., for floating point lookup tables) a + # LUT bin may have as its value, in addition to the + # usual 0 or 1, the address of an interpreter subprogram + # to be executed to test data values mapping to that bin. + # The subprogram pointed to may in turn be another lookup + # table, hence in the general case a tree of lookup tables + # and little code segments may be compiled to implement + # a complex range list test. + + # Get the data range of the lookup table. + xmin = XS(1) + if (IS_LEFT$T(xmin)) + xmin = XE(1) + xmax = XE(nranges) + if (IS_RIGHT$T(xmax)) + xmax = XS(nranges) + + # Get the lookup table size. Use a fully resolved table + # if the data is integer and the number of bins required + # is modest. + + $if (datatype == i) + nbins = xmax - xmin + 1 + if (nbins > EX_MAXFRLUTLEN(ex)) + nbins = min (EX_MAXRRLUTLEN(ex), + nranges * EX_LUTSCALE(ex)) + $else + nbins = min (EX_MAXRRLUTLEN(ex), nranges * EX_LUTSCALE(ex)) + $endif + + # Determine the mapping from data space to table space. + xoffset = xmin + $if (datatype == i) + xscale = nbins / (xmax - xmin + 1) + $else + xscale = nbins / (xmax - xmin) + $endif + + # Allocate and initialize the lookup table descriptor. + lt = qpex_dballoc (ex, LEN_LTDES, TY_STRUCT) + call calloc (lut, nbins, TY_SHORT) + + LT_NEXT(lt) = EX_LTHEAD(ex) + EX_LTHEAD(ex) = lt + LT_TYPE(lt) = TY_PIXEL + LT_LUTP(lt) = lut + LT_NBINS(lt) = nbins + LT_$T0(lt) = xoffset + LT_$TS(lt) = xscale + LT_LEFT(lt) = btoi (IS_LEFT$T(XS(1))) + LT_RIGHT(lt) = btoi (IS_RIGHT$T(XE(nranges))) + + # Compile the LUTX test instruction. Save a back pointer + # to the instruction so that we can edit the jump field in + # case a subprogram is compiled after the LUTXt. + + lutx = qpex_pbpos (ex) + if (dtype == TY_SHORT) + call qpex_pbpin (ex, LUTXS, offset, lt, 0) + else + call qpex_pbpin (ex, LUTX$T, offset, lt, 0) + + xp = 1 + bin = 1 +continue_ + n_xs = xs + nranges + n_xe = xe + nranges + + # Initialize the lookup table. + do i = bin, nbins { + x1 = (i-1) / xscale + xoffset + $if (datatype == i) + x2 = i / xscale + xoffset - 1 + $else + x2 = i / xscale + xoffset + $endif + + # Get sub-rangelist for range x1:x2. + n_nranges = qpex_sublist$t (x1, x2, + Mem$t[xs], Mem$t[xe], nranges, xp, + Mem$t[n_xs], Mem$t[n_xe]) + + if (n_nranges <= 0) { + Mems[lut+i-1] = 0 + + } else if (n_nranges == 1 && IS_LEFT$T(Mem$t[n_xs]) && + IS_RIGHT$T(Mem$t[n_xe])) { + + Mems[lut+i-1] = 1 + + } else { + # Compile the sub-rangelist as a subprogram. + + # First set the LUT bin to point to the subprogram. + # We cannot use the IP directly here since the LUT + # bins are short integer, so store the offset into + # the pb instead (guaranteed to be >= 4). + + Mems[lut+i-1] = qpex_pbpos(ex) - pb + + # Push a new context. + level = level + 1 + if (level > MAX_LEVELS) { + call eprintf ("%s: ") + call pargstr (qpexwarn) + call eprintf ("Excessive LUT nesting\n") + goto error_ + } + + # Save current LUT compilation context. + sv_xs[level] = xs + sv_xe[level] = xe + sv_xp[level] = xp + sv_xoffset[level] = xoffset + sv_xscale[level] = xscale + sv_nranges[level] = nranges + sv_lt[level] = lt + sv_bin[level] = i + sv_nbins[level] = nbins + sv_lut[level] = lut + sv_lutx[level] = lutx + + # Set up context for the new rangelist. + xs = n_xs + xe = n_xe + nranges = n_nranges + + goto next_ + } + } + + # Compile a test and exit instruction if the LUT calls any + # subprograms. + + if (qpex_pbpos(ex) - lutx > LEN_INSTRUCTION) + call qpex_pbpin (ex, XIFF, 0, 0, 0) + } +resume_ + # Resume lookup table compilation if exiting due to LUT-bin + # subprogram compilation. + + if (level > 0) { + # Pop saved context. + xs = sv_xs[level] + xe = sv_xe[level] + xp = sv_xp[level] + xoffset = sv_xoffset[level] + xscale = sv_xscale[level] + nranges = sv_nranges[level] + lt = sv_lt[level] + bin = sv_bin[level] + nbins = sv_nbins[level] + lut = sv_lut[level] + lutx = sv_lutx[level] + + # Compile a return from subprogram. + call qpex_pbpin (ex, RET, 0, 0, 0) + + # Patch up the original LUTX instruction to jump over the + # subprogram we have just finished compiling. + + IARG3(lutx) = qpex_pbpos (ex) + + # Resume compilation at the next LUT bin. + bin = bin + 1 + level = level - 1 + goto continue_ + } + } until (level <= 0) + + # Finish setting up the eterm descriptor. + ET_NINSTR(et) = (qpex_pbpos(ex) - ET_PROGPTR(et)) / LEN_INSTRUCTION + + return (OK) +error_ + call qpex_free (ex, pb_save, db_save) + return (ERR) +end diff --git a/sys/qpoe/qpexdata.x b/sys/qpoe/qpexdata.x new file mode 100644 index 00000000..1cfc7810 --- /dev/null +++ b/sys/qpoe/qpexdata.x @@ -0,0 +1,210 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "qpex.h" + +.help qpexdata +.nf -------------------------------------------------------------------------- +QPEXDATA -- Data management package for QPEX. The QPEX data structures +consist of the QPEX descriptor and two main data buffers, the program buffer +(pb), containing the instructions to be executed (interpreted) to evaluate +an expression, and the data buffer (db), containing assorted data structures, +e.g., the linked list of expression term descriptors, the lookup table +descriptors, storage for DOUBLE data appearing in the compiled expression, +and so on. The program and data buffers are dynamically allocated but are +not relocatable, so to absolute pointers may be used to reference the objects +therein (hence, runtime overflow is possible). + +During expression compilation the following routines are used to add data +objects to the program and data buffers: + + qpex_mark (ex, pb_save, db_save) + qpex_free (ex, pb_save, db_save) + + ip = qpex_pbpos (ex) + qpex_pbpin (ex, opcode, arg1, arg2, arg3) + + ptr = qpex_dbpstr (ex, strval) + intval = qpex_refd (ex, dval) + ptr = qpex_dballoc (ex, nelem, dtype) + +QPEX_MARK and QPEX_FREE are used to mark the current tops of the two buffers +and subspequently free storage back to that point, e.g., for error recovery +following detection of a compilation error. QPEX_PBPOS returns a pointer to +the location in the program buffer where next instruction will be placed. +QPEX_PBPIN compiles an instruction at that location. + +The main storage allocator for the data buffer is QPEX_DBALLOC, which allocates +a properly aligned buffer of the indicated type in the data buffer, and returns +a pointer of the same type as the function value. QPEX_DBPSTR stores a string +constant in the data buffer and returns a pointer to the stored string. +QPEX_REFD stores the given type double constant in the data buffer and returns +(as an integer) a pointer to the stored value (this is necessary to permit +only SZ_INT argument fields in instructions). +.endhelp --------------------------------------------------------------------- + + +# QPEX_MARK -- Mark the top of the program and data buffers. + +procedure qpex_mark (ex, pb_save, db_save) + +pointer ex #I QPEX descriptor +pointer pb_save, db_save #O saved pointers + +begin + pb_save = EX_PBOP(ex) + db_save = EX_DBOP(ex) +end + + +# QPEX_FREE -- Free storage back to the marked points. + +procedure qpex_free (ex, pb_save, db_save) + +pointer ex #I QPEX descriptor +pointer pb_save, db_save #I saved pointers + +pointer top, prev, lt, et +pointer coerce() + +begin + # Free space in program buffer. + call aclri (Memi[pb_save], EX_PBTOP(ex) - pb_save) + EX_PBOP(ex) = pb_save + + # Free space in the data buffer. Prune the LUT and ETERM lists + # and then reset the data buffer pointer. + + # The LT list is backward linked from the most recent entry. + top = coerce (db_save, TY_CHAR, TY_STRUCT) + for (lt=EX_LTHEAD(ex); lt != NULL; lt=LT_NEXT(lt)) + if (lt >= top) { + call mfree (LT_LUTP(lt), TY_SHORT) + EX_LTHEAD(ex) = LT_NEXT(lt) + } + + # The ET list is forward linked from the first entry. + prev = NULL + for (et=EX_ETHEAD(ex); et != NULL; et=ET_NEXT(et)) + if (et >= top) { + if (prev != NULL) + ET_NEXT(prev) = NULL + EX_ETTAIL(ex) = prev + break + } + + EX_DBOP(ex) = db_save +end + + +# QPEX_PBPOS -- Return a pointer to the program buffer location where the +# next instruction to be compiled will be located. + +pointer procedure qpex_pbpos (ex) + +pointer ex #I QPEX descriptor + +begin + return (EX_PBOP(ex)) +end + + +# QPEX_PBPIN -- Add an insruction at the end of the program buffer. + +procedure qpex_pbpin (ex, opcode, arg1, arg2, arg3) + +pointer ex #I QPEX descriptor +int opcode #I instruction opcode +int arg1,arg2,arg3 #I instruction data fields (typeless) + +pointer op +errchk syserr + +begin + op = EX_PBOP(ex) + if (op >= EX_PBTOP(ex)) + call syserr (SYS_QPEXPBOVFL) + + OPCODE(op) = opcode + IARG1(op) = arg1 + IARG2(op) = arg2 + IARG3(op) = arg3 + + EX_PBOP(ex) = op + LEN_INSTRUCTION +end + + +# QPEX_DBPSTR -- Store a string constant in the data buffer, returning a +# pointer to the stored string as the function value. + +pointer procedure qpex_dbpstr (ex, strval) + +pointer ex #I QPEX descriptor +char strval[ARB] #I string to be stored + +pointer op +int nchars +int strlen() +errchk syserr + +begin + op = EX_DBOP(ex) + nchars = strlen (strval) + 1 + + if (op + nchars >= EX_DBTOP(ex)) + call syserr (SYS_QPEXDBOVFL) + + call strcpy (strval, Memc[op], nchars) + EX_DBOP(ex) = op + nchars + + return (op) +end + + +# QPEX_REFD -- Reference a type DOUBLE datum, returning (as an integer) a +# pointer to the double value, which is stored in the data buffer. + +int procedure qpex_refd (ex, value) + +pointer ex #I QPEX descriptor +double value #I double value + +pointer dp +pointer qpex_dballoc() +errchk qpex_dballoc + +begin + dp = qpex_dballoc (ex, 1, TY_DOUBLE) + Memd[dp] = value + return (dp) +end + + +# QPEX_DBALLOC -- Allocate storage of the indicated type in the data +# buffer, returning a typed pointer to the buffer. The buffer is fully +# aligned. + +pointer procedure qpex_dballoc (ex, nelem, dtype) + +pointer ex #I QPEX descriptor +int nelem #I amount of storage desired +int dtype #I datatype of the storage element + +pointer op, top +pointer coerce() +int sizeof() +errchk syserr + +begin + op = EX_DBOP(ex) + while (mod (op-1, SZ_DOUBLE) != 0) + op = op + 1 + + top = op + nelem * sizeof(dtype) + if (top >= EX_DBTOP(ex)) + call syserr (SYS_QPEXDBOVFL) + + EX_DBOP(ex) = top + return (coerce (op, TY_CHAR, dtype)) +end diff --git a/sys/qpoe/qpexdebug.x b/sys/qpoe/qpexdebug.x new file mode 100644 index 00000000..26f63e8b --- /dev/null +++ b/sys/qpoe/qpexdebug.x @@ -0,0 +1,441 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "qpex.h" +include "qpoe.h" + +define NLUTPERLINE 15 +define SZ_TEXT 4 +define SZ_FILTERBUF 32768 + +# QPEX_DEBUG -- Output text describing the state and contents of the QPEX +# descriptor (compiled event attribute filter). + +procedure qpex_debug (ex, out, what) + +pointer ex #I QPEX descriptor +int out #I output stream +int what #I bitflags defining what to print + +char binval[SZ_TEXT] +pointer sp, text, label, lutp, et, lt, pb, ip +int neterms, lutno, proglen, dest, nout, ch, i +int qpex_getfilter() +define lut_ 91 + +begin + call smark (sp) + + neterms = 0 + for (et=EX_ETHEAD(ex); et != NULL; et=ET_NEXT(et)) + neterms = neterms + 1 + proglen = (EX_PBOP(ex) - EX_PB(ex)) / LEN_INSTRUCTION + + # Print summary information. + if (and (what, QPEXD_SUMMARY) != 0) { + call fprintf (out, + "QPEX_DEBUG: ex=%xX, neterms=%d, proglen=%d/%d\n") + call pargi (ex) + call pargi (neterms) + call pargi (proglen) + call pargi ((EX_PBTOP(ex) - EX_PB(ex)) / LEN_INSTRUCTION) + + call fprintf (out, "pb=%xX, pbtop=%xX, pbop=%xX, start=%xX\n") + call pargi (EX_PB(ex)) + call pargi (EX_PBTOP(ex)) + call pargi (EX_PBOP(ex)) + call pargi (EX_START(ex)) + + call fprintf (out, "db=%xX, dbtop=%xX, dbop=%xX, datalen=%d/%d\n") + call pargi (EX_DB(ex)) + call pargi (EX_DBTOP(ex)) + call pargi (EX_DBOP(ex)) + call pargi (EX_DBOP(ex) - EX_DB(ex)) + call pargi (EX_DBTOP(ex) - EX_DB(ex)) + + call fprintf (out, "max_frlutlen=%d, max_rrlutlen=%d, ") + call pargi (EX_MAXFRLUTLEN(ex)) + call pargi (EX_MAXRRLUTLEN(ex)) + call fprintf (out, "lut_scale=%d, lut_minranges=%d\n") + call pargi (EX_LUTSCALE(ex)) + call pargi (EX_LUTMINRANGES(ex)) + + call fprintf (out, "ethead=%xX, ettail=%xX, lthead=%xX\n") + call pargi (EX_ETHEAD(ex)) + call pargi (EX_ETTAIL(ex)) + call pargi (EX_LTHEAD(ex)) + } + + # Regenerate and print the compiled expression. + if (and (what, QPEXD_SHOWEXPR) != 0) { + call salloc (text, SZ_FILTERBUF, TY_CHAR) + call fprintf (out, + "==================== expr ========================\n") + if (qpex_getfilter (ex, Memc[text], SZ_FILTERBUF) > 0) { + call putline (out, Memc[text]) + call fprintf (out, "\n") + } + } + + # Decode the compiled program (print assembled instructions). + if (and (what, QPEXD_PROGRAM) != 0) { + pb = EX_PB(ex) + + call salloc (label, proglen+1, TY_INT) + call aclri (Memi[label], proglen+1) + + # Flag those instructions which are the destinations of branches. + do i = 1, proglen { + ip = pb + (i - 1) * LEN_INSTRUCTION + switch (OPCODE(ip)) { + case GOTO: + dest = (IARG1(ip) - pb) / LEN_INSTRUCTION + Memi[label+dest] = YES + case LUTXS, LUTXI, LUTXR, LUTXD: + if (IARG3(ip) == NULL) + dest = i + else + dest = (IARG3(ip) - pb) / LEN_INSTRUCTION + Memi[label+dest] = YES + } + } + + # Do the same for code segments pointed to by lookup tables. + for (lt=EX_LTHEAD(ex); lt != NULL; lt=LT_NEXT(lt)) { + lutp = LT_LUTP(lt) + do i = 0, LT_NBINS(lt) - 1 { + dest = Mems[lutp+i] + if (dest > 1) { + dest = dest / LEN_INSTRUCTION + Memi[label+dest] = YES + } + } + } + + # Output the program. + call fprintf (out, + "==================== program =====================\n") + + do i = 1, proglen + 1 { + ip = pb + (i - 1) * LEN_INSTRUCTION + + # Output instruction label if target of a branch. + if (Memi[label+i-1] == YES) { + call fprintf (out, "L%d:\t") + call pargi (i) + } else + call fprintf (out, "\t") + + # Decode and output the instruction itself. + switch (OPCODE(ip)) { + case NOP: + call fprintf (out, "nop") + case GOTO: + dest = (IARG1(ip) - pb) / LEN_INSTRUCTION + 1 + call fprintf (out, "goto L%d") + call pargi (dest) + case XIFT: + call fprintf (out, "xift") + case XIFF: + call fprintf (out, "xiff") + case PASS: + call fprintf (out, "pass") + case RET: + call fprintf (out, "ret") + + case LDSI: + call fprintf (out, "ldsi\t(%d)") + call pargi (IARG1(ip)) + case LDII: + call fprintf (out, "ldii\t(%d)") + call pargi (IARG1(ip)) + case LDRR: + call fprintf (out, "ldrr\t(%d)") + call pargi (IARG1(ip)) + case LDRD: + call fprintf (out, "ldrd\t(%d)") + call pargi (IARG1(ip)) + case LDDD: + call fprintf (out, "lddd\t(%d)") + call pargi (IARG1(ip)) + + case BTTI: + call fprintf (out, "btti\t%oB") + call pargi (IARG1(ip)) + case EQLI: + call fprintf (out, "eqli\t%d") + call pargi (IARG1(ip)) + case EQLR: + call fprintf (out, "eqlr\t%g") + call pargr (RARG1(ip)) + case EQLD: + call fprintf (out, "eqld\t%g") + call pargd (DARG1(ip)) + case LEQI: + call fprintf (out, "leqi\t%d") + call pargi (IARG1(ip)) + case LEQR: + call fprintf (out, "leqr\t%g") + call pargr (RARG1(ip)) + case LEQD: + call fprintf (out, "leqd\t%g") + call pargd (DARG1(ip)) + case GEQI: + call fprintf (out, "geqi\t%d") + call pargi (IARG1(ip)) + case GEQR: + call fprintf (out, "geqr\t%g") + call pargr (RARG1(ip)) + case GEQD: + call fprintf (out, "geqd\t%g") + call pargd (DARG1(ip)) + + case RNGI: + call fprintf (out, "rngi\t%d, %d") + call pargi (IARG1(ip)) + call pargi (IARG2(ip)) + case RNGR: + call fprintf (out, "rngr\t%g, %g") + call pargr (RARG1(ip)) + call pargr (RARG2(ip)) + case RNGD: + call fprintf (out, "rngd\t%g, %g") + call pargd (DARG1(ip)) + call pargd (DARG2(ip)) + + case BTTXS: + call fprintf (out, "bttxs\t(%d), %oB") + call pargi (IARG1(ip)) + call pargi (IARG2(ip)) + case BTTXI: + call fprintf (out, "bttxi\t(%d), %oB") + call pargi (IARG1(ip)) + call pargi (IARG2(ip)) + + case NEQXS: + call fprintf (out, "neqxs\t(%d), %d") + call pargi (IARG1(ip)) + call pargi (IARG2(ip)) + case NEQXI: + call fprintf (out, "neqxi\t(%d), %d") + call pargi (IARG1(ip)) + call pargi (IARG2(ip)) + case NEQXR: + call fprintf (out, "neqxr\t(%d), %g") + call pargi (IARG1(ip)) + call pargr (RARG2(ip)) + case NEQXD: + call fprintf (out, "neqxd\t(%d), %g") + call pargi (IARG1(ip)) + call pargd (DARG2(ip)) + + case EQLXS: + call fprintf (out, "eqlxs\t(%d), %d") + call pargi (IARG1(ip)) + call pargi (IARG2(ip)) + case EQLXI: + call fprintf (out, "eqlxi\t(%d), %d") + call pargi (IARG1(ip)) + call pargi (IARG2(ip)) + case EQLXR: + call fprintf (out, "eqlxr\t(%d), %g") + call pargi (IARG1(ip)) + call pargr (RARG2(ip)) + case EQLXD: + call fprintf (out, "eqlxd\t(%d), %g") + call pargi (IARG1(ip)) + call pargd (DARG2(ip)) + + case LEQXS: + call fprintf (out, "leqxs\t(%d), %d") + call pargi (IARG1(ip)) + call pargi (IARG2(ip)) + case LEQXI: + call fprintf (out, "leqxi\t(%d), %d") + call pargi (IARG1(ip)) + call pargi (IARG2(ip)) + case LEQXR: + call fprintf (out, "leqxr\t(%d), %g") + call pargi (IARG1(ip)) + call pargr (RARG2(ip)) + case LEQXD: + call fprintf (out, "leqxd\t(%d), %g") + call pargi (IARG1(ip)) + call pargd (DARG2(ip)) + + case GEQXS: + call fprintf (out, "geqxs\t(%d), %d") + call pargi (IARG1(ip)) + call pargi (IARG2(ip)) + case GEQXI: + call fprintf (out, "geqxi\t(%d), %d") + call pargi (IARG1(ip)) + call pargi (IARG2(ip)) + case GEQXR: + call fprintf (out, "geqxr\t(%d), %g") + call pargi (IARG1(ip)) + call pargr (RARG2(ip)) + case GEQXD: + call fprintf (out, "geqxd\t(%d), %g") + call pargi (IARG1(ip)) + call pargd (DARG2(ip)) + + case RNGXS: + call fprintf (out, "rngxs\t(%d), %d, %d") + call pargi (IARG1(ip)) + call pargi (IARG2(ip)) + call pargi (IARG3(ip)) + case RNGXI: + call fprintf (out, "rngxi\t(%d), %d, %d") + call pargi (IARG1(ip)) + call pargi (IARG2(ip)) + call pargi (IARG3(ip)) + case RNGXR: + call fprintf (out, "rngxr\t(%d), %g, %g") + call pargi (IARG1(ip)) + call pargr (RARG2(ip)) + call pargr (RARG3(ip)) + case RNGXD: + call fprintf (out, "rngxd\t(%d), %g, %g") + call pargi (IARG1(ip)) + call pargd (DARG2(ip)) + call pargd (DARG3(ip)) + + case LUTXS: + ch = 's' + goto lut_ + case LUTXI: + ch = 'i' + goto lut_ + case LUTXR: + ch = 'r' + goto lut_ + case LUTXD: + ch = 'd' +lut_ call fprintf (out, "lutx%c\t(%d), %xX, L%d") + call pargi (ch) + call pargi (IARG1(ip)) + call pargi (IARG2(ip)) + if (IARG3(ip) != NULL) + call pargi ((IARG3(ip) - pb) / LEN_INSTRUCTION + 1) + else + call pargi (i + 1) + } + + call fprintf (out, "\n") + } + } + + # Output expression terms list. + if (and (what, QPEXD_ETLIST) != 0) { + call fprintf (out, + "==================== eterms ======================\n") + if (neterms > 0) { + call fprintf (out, + " N TYPE OFF IP LEN DEL ATTRIBUTE OP EXPR\n") + neterms = 0 + for (et=EX_ETHEAD(ex); et != NULL; et=ET_NEXT(et)) { + neterms = neterms + 1 + call fprintf (out, + "%2d %4d %3d %3d %4d %3d %9.9s %2s ") + call pargi (neterms) + call pargi (ET_ATTTYPE(et)) + call pargi (ET_ATTOFF(et)) + call pargi ((ET_PROGPTR(et) - pb) / LEN_INSTRUCTION + 1) + call pargi (ET_NINSTR(et)) + call pargi (ET_DELETED(et)) + call pargstr (Memc[ET_ATNAME(et)]) + call pargstr (Memc[ET_ASSIGNOP(et)]) + call putline (out, Memc[ET_EXPRTEXT(et)]) + call putline (out, "\n") + } + } + } + + # Output lookup table list. + if (and (what, QPEXD_LTLIST+QPEXD_SHOWLUTS) != 0) { + if (EX_LTHEAD(ex) != NULL) { + call fprintf (out, + "==================== lutlist =====================\n") + + # Output column labels. + call fprintf (out, + " N LT LUTP TYPE NBINS L R %*wZERO SCALE\n") + if (LT_TYPE(EX_LTHEAD(ex)) == TY_DOUBLE) + call pargi (NDIGITS_DP - 4) + else + call pargi (NDIGITS_RP - 4) + + # Output lookup table descriptors. + lutno = 0 + for (lt=EX_LTHEAD(ex); lt != NULL; lt=LT_NEXT(lt)) { + lutno = lutno + 1 + call fprintf (out, "%2d %6x %6x %4d %5d %d %d %*g %g\n") + call pargi (lutno) + call pargi (lt) + call pargi (LT_LUTP(lt)) + call pargi (LT_TYPE(lt)) + call pargi (LT_NBINS(lt)) + call pargi (LT_LEFT(lt)) + call pargi (LT_RIGHT(lt)) + + switch (LT_TYPE(lt)) { + case TY_INT: + call pargi (NDIGITS_RP) + call pargr (LT_I0(lt)) + call pargr (LT_IS(lt)) + case TY_REAL: + call pargi (NDIGITS_RP) + call pargr (LT_R0(lt)) + call pargr (LT_RS(lt)) + case TY_DOUBLE: + call pargi (NDIGITS_DP) + call pargd (LT_D0(lt)) + call pargd (LT_DS(lt)) + } + } + } + + # Dump the lookup table data. + if (and (what, QPEXD_SHOWLUTS) != 0) { + lutno = 0 + for (lt=EX_LTHEAD(ex); lt != NULL; lt=LT_NEXT(lt)) { + lutno = lutno + 1 + lutp = LT_LUTP(lt) + call fprintf (out, + "================== LUT %d (%x) ==================\n") + call pargi (lutno) + call pargi (lutp) + nout = 0 + do i = 0, LT_NBINS(lt) - 1 { + if (i == 0 || nout >= NLUTPERLINE) { + if (i > 0) + call fprintf (out, "\n") + call fprintf (out, "%04d") + call pargi (i) + nout = 0 + } + + # Print the bin value as 0, 1, or a statement label. + dest = Mems[lutp+i] + if (dest <= 1) { + call fprintf (out, " %4d") + call pargi (dest) + } else { + call sprintf (binval, SZ_TEXT, "L%d") + call pargi (dest / LEN_INSTRUCTION + 1) + call fprintf (out, " %4s") + call pargstr (binval) + } + + nout = nout + 1 + } + if (nout > 0) + call fprintf (out, "\n") + } + } + } + + call sfree (sp) +end diff --git a/sys/qpoe/qpexdel.x b/sys/qpoe/qpexdel.x new file mode 100644 index 00000000..ce4da432 --- /dev/null +++ b/sys/qpoe/qpexdel.x @@ -0,0 +1,58 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpex.h" + +# QPEX_DELETE -- Delete any previously compiled expression terms for the +# event attribute with the given offset and datatype. Only terms up to and +# including ET_LAST are affected (allowing deletion while compiling additional +# terms). + +procedure qpex_delete (ex, et_last, offset, dtype) + +pointer ex #I QPEX descriptor +pointer et_last #I last expression term to be edited +int offset #I typed offset of attribute in event struct +int dtype #I datatype of attribute + +pointer et, ip +int ninstr, i + +begin + if (et_last == NULL) + return + + for (et=EX_ETHEAD(ex); et != NULL; et=ET_NEXT(et)) { + # Skip over already deleted terms or terms for other attributes. + if (ET_DELETED(et) == YES) + next + else if (ET_ATTOFF(et) != offset || ET_ATTTYPE(et) != dtype) + next + + # Physically and logically delete the term. Edit the program + # buffer and replace the compiled sequence of instructions by + # a GOTO followed by a series of NO-OPs. + + ip = ET_PROGPTR(et) + ninstr = ET_NINSTR(et) + + OPCODE(ip) = GOTO + IARG1(ip) = ip + ninstr * LEN_INSTRUCTION + IARG2(ip) = NULL + IARG3(ip) = NULL + + do i = 2, ninstr { + ip = ET_PROGPTR(et) + (i-1) * LEN_INSTRUCTION + OPCODE(ip) = NOP + IARG1(ip) = NULL + IARG2(ip) = NULL + IARG3(ip) = NULL + } + + # Flag the eterm as deleted. + ET_DELETED(et) = YES + + if (et == et_last) + break + } +end diff --git a/sys/qpoe/qpexeval.x b/sys/qpoe/qpexeval.x new file mode 100644 index 00000000..5e120296 --- /dev/null +++ b/sys/qpoe/qpexeval.x @@ -0,0 +1,362 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpex.h" + +define RTOL (EPSILONR * 10.0) # (only useful for normalized numbers) +define DTOL (EPSILOND * 10.0) + +# QPEX_EVALUATE -- Evaluate the compiled event-attribute expression for the +# given seqeuence of event structs. Expression evaluation for each event +# terminates as soon as an attribute test fails. If all attribute tests +# succeed (i.e., the full expression is evaluated or the evaluate function +# runs to completion) then the event pointer is put on the output list O_EV, +# indicating that the event satisfies the given selection expression. +# The function value is the number of events which passed the filter. +# The time required to evaluate an expression depends upon the complexity of +# the expression to be evaluated, and the fraction of events which fail the +# test (a fail is determined quicker than a pass - attribute tests likely to +# fail should appear first in the expression). + +int procedure qpex_evaluate (ex, i_ev, o_ev, nev) + +pointer ex #I QPEX descriptor (expression) +pointer i_ev[nev] #I array of pointers to event structs +pointer o_ev[nev] #O receives the pointers of the passed events +int nev #I number of input events + +int i0 # integer data register +real r0 # real data register +double d0 # double data register +bool pass # expression value +int npass # number of events which pass expr + +real rbin +bool pv_save[MAX_LEVELS] +pointer ip_save[MAX_LEVELS] +pointer lt, ev, ev_i, ev_r, ev_d, ip +int level, bin, i, j, v + +define lut_ 91 +define ret_ 92 +define ev_s ev + +begin + npass = 0 + + do j = 1, nev { + pass = false + ev = i_ev[j] + + # Get event struct pointers of various types. + ev_d = (ev - 1) * SZ_SHORT / SZ_DOUBLE + 1 + ev_i = (ev - 1) * SZ_SHORT / SZ_INT + 1 + ev_r = ev_i + + # Execute each compiled instruction in sequence until the value + # of the compiled attribute-value expression is known. The call + # stack level is used to keep track of subroutine calls + # (subroutines are used to evaluate the indeterminate cells of + # compressed lookup tables). + + # Notes on expression evaluation. + # --------------------------------- + # An expression consists of 1 or more expression terms, all of + # which must pass the event for the event to pass the filter. + # + # An expression term consists of a range list giving a list of + # acceptable values or ranges of values. + # + # The compiled expression consists of a sequence of instruction + # blocks, one for each expression term. If the event fails to + # pass any expression term (instruction block) then the event + # fails and we are done. Instruction blocks are of three types: + # + # 1) Multiple instructions consisting of a load register, + # any number of register tests, then a XIFF or XIFT + # test at the end of the block. PASS is set to false + # at the beginning of the block and can be set to true + # by any register test to pass the event to the next + # expression term. + # + # 2) In simple cases the above can all be expressed as a + # single test-and-exit-if-false instruction. These are + # the "X" instructions below. + # + # 3) The lookup table (LUTX) instruction. LUTX is like + # case 2) except that it may compile as a sequence of + # many instructions, using subprograms to evaluate the + # value of LUT bins. LUTs may nest. When lookup table + # evaluation is complete the instruction branches + # forward to a closing XIFF which is used to test the + # value of PASS returned by the executed LUT-bin + # subprograms. + # + # The blocks of instructions corresponding to successive expression + # terms are executed until the PASS instruction is encountered. + # Execution of PASS terminates evaluation and passes the event. + + ip = EX_START(ex) + level = 0 + + do i = 1, MAX_INSTRUCTIONS { + pragma switch_no_range_check + switch (OPCODE(ip)) { + case NOP: # null operation + ; + case GOTO: # go-to prog offset + ip = IARG1(ip) + next + case XIFT: # exit if true + if (pass) { + pass = false + goto ret_ + } + case XIFF: # exit if false + if (!pass) + goto ret_ + case PASS: + pass = true + break + case RET: # return from subprog +ret_ if (level > 0) { + pass = (pv_save[level] || pass) + ip = ip_save[level] + level = level - 1 + next + } else + break + + case LDSI: # load registers + i0 = Mems[ev_s+IARG1(ip)] + pass = false + case LDII: + i0 = Memi[ev_i+IARG1(ip)] + pass = false + case LDRR: + r0 = Memr[ev_r+IARG1(ip)] + pass = false + case LDRD: + d0 = Memr[ev_r+IARG1(ip)] + pass = false + case LDDD: + d0 = Memd[ev_d+IARG1(ip)] + pass = false + + case BTTI: # register tests + pass = pass || (and (i0, IARG1(ip)) != 0) + case EQLI: + pass = pass || (i0 == IARG1(ip)) + case EQLR: + pass = pass || (abs(r0 - RARG1(ip)) < RTOL) + case EQLD: + pass = pass || (abs(d0 - DARG1(ip)) < DTOL) + case LEQI: + pass = pass || (i0 <= IARG1(ip)) + case LEQR: + pass = pass || (r0 <= RARG1(ip)) + case LEQD: + pass = pass || (d0 <= DARG1(ip)) + case GEQI: + pass = pass || (i0 >= IARG1(ip)) + case GEQR: + pass = pass || (r0 >= RARG1(ip)) + case GEQD: + pass = pass || (d0 >= DARG1(ip)) + case RNGI: + pass = pass || (i0 >= IARG1(ip) && i0 <= IARG2(ip)) + case RNGR: + pass = pass || (r0 >= RARG1(ip) && r0 <= RARG2(ip)) + case RNGD: + pass = pass || (d0 >= DARG1(ip) && d0 <= DARG2(ip)) + + case BTTXS: # load, test, and + i0 = Mems[ev_s+IARG1(ip)] # exit if false + pass = (and (i0, IARG2(ip)) != 0) + if (!pass) + goto ret_ + case BTTXI: + pass = (and (Memi[ev_i+IARG1(ip)], IARG2(ip)) != 0) + if (!pass) + goto ret_ + + case NEQXS: + pass = (Mems[ev_s+IARG1(ip)] != IARG2(ip)) + if (!pass) + goto ret_ + case NEQXI: + pass = (Memi[ev_i+IARG1(ip)] != IARG2(ip)) + if (!pass) + goto ret_ + case NEQXR: + pass = (abs(Memr[ev_r+IARG1(ip)] - RARG2(ip)) > RTOL) + if (!pass) + goto ret_ + case NEQXD: + pass = (abs(Memd[ev_d+IARG1(ip)] - DARG2(ip)) > DTOL) + if (!pass) + goto ret_ + + case EQLXS: + pass = (Mems[ev_s+IARG1(ip)] == IARG2(ip)) + if (!pass) + goto ret_ + case EQLXI: + pass = (Memi[ev_i+IARG1(ip)] == IARG2(ip)) + if (!pass) + goto ret_ + case EQLXR: + pass = (abs(Memr[ev_r+IARG1(ip)] - RARG2(ip)) <= RTOL) + if (!pass) + goto ret_ + case EQLXD: + pass = (abs(Memd[ev_d+IARG1(ip)] - DARG2(ip)) <= DTOL) + if (!pass) + goto ret_ + + case LEQXS: + pass = (Mems[ev_s+IARG1(ip)] <= IARG2(ip)) + if (!pass) + goto ret_ + case LEQXI: + pass = (Memi[ev_i+IARG1(ip)] <= IARG2(ip)) + if (!pass) + goto ret_ + case LEQXR: + pass = (Memr[ev_r+IARG1(ip)] <= RARG2(ip)) + if (!pass) + goto ret_ + case LEQXD: + pass = (Memd[ev_d+IARG1(ip)] <= DARG2(ip)) + if (!pass) + goto ret_ + + case GEQXS: + pass = (Mems[ev_s+IARG1(ip)] >= IARG2(ip)) + if (!pass) + goto ret_ + case GEQXI: + pass = (Memi[ev_i+IARG1(ip)] >= IARG2(ip)) + if (!pass) + goto ret_ + case GEQXR: + pass = (Memr[ev_r+IARG1(ip)] >= RARG2(ip)) + if (!pass) + goto ret_ + case GEQXD: + pass = (Memd[ev_d+IARG1(ip)] >= DARG2(ip)) + if (!pass) + goto ret_ + + case RNGXS: + i0 = Mems[ev_s+IARG1(ip)] + pass = (i0 >= IARG2(ip) && i0 <= IARG3(ip)) + if (!pass) + goto ret_ + case RNGXI: + i0 = Memi[ev_i+IARG1(ip)] + pass = (i0 >= IARG2(ip) && i0 <= IARG3(ip)) + if (!pass) + goto ret_ + case RNGXR: + r0 = Memr[ev_r+IARG1(ip)] + pass = (r0 >= RARG2(ip) && r0 <= RARG3(ip)) + if (!pass) + goto ret_ + case RNGXD: + d0 = Memd[ev_d+IARG1(ip)] + pass = (d0 >= DARG2(ip) && d0 <= DARG3(ip)) + if (!pass) + goto ret_ + + case LUTXS: # lookup tables + i0 = Mems[ev_s+IARG1(ip)] + lt = IARG2(ip) + rbin = (i0 - int(LT_I0(lt))) * LT_IS(lt) + goto lut_ + case LUTXI: + i0 = Memi[ev_i+IARG1(ip)] + lt = IARG2(ip) + rbin = (i0 - int(LT_I0(lt))) * LT_IS(lt) + goto lut_ + case LUTXR: + r0 = Memr[ev_r+IARG1(ip)] + lt = IARG2(ip) + rbin = (r0 - LT_R0(lt)) * LT_RS(lt) + goto lut_ + case LUTXD: + d0 = Memd[ev_d+IARG1(ip)] + lt = IARG2(ip) + rbin = (d0 - LT_D0(lt)) * LT_DS(lt) +lut_ + # Common code for any lookup table. + if (rbin <= 0) + v = LT_LEFT(lt) + else { + bin = int(rbin) + 1 + if (bin > LT_NBINS(lt)) + v = LT_RIGHT(lt) + else + v = LT_LUT(lt,bin) + } + + # Table value may be 0, 1, or indeterminate, i.e., the + # offset of a subprogram to be called to evaluate the + # subrangelist for that bin. + + if (v == 0) { + # Table value is zero, !pass, all done. + pass = false + goto ret_ + + } else if (v > 1) { + # Table value is indeterminate and depends on the + # data value. Call subroutine to evaluate subrange. + # At level=0 where we are starting to evaluate an + # independent expression term we must initialize pass + # to false before entering the subprogram instruction + # sequence. + + if (level == 0) + pass = false + + level = level + 1 + pv_save[level] = pass + + if (IARG3(ip) != NULL) + ip_save[level] = IARG3(ip) + else + ip_save[level] = ip + LEN_INSTRUCTION + + pass = false + ip = EX_PB(ex) + v + next + + } else if (v == 1) { + # Table value is one, value passes this test. + pass = true + } + + # Go to the jump address if set. The jump is needed + # to skip over any subprograms that may have been compiled + # after the LUTX. + + if (IARG3(ip) != NULL) { + ip = IARG3(ip) + next + } + } + + # Advance to the next instruction. + ip = ip + LEN_INSTRUCTION + } + + # Output event pointer if event passed the filter. + if (pass) { + npass = npass + 1 + o_ev[npass] = ev + } + } + + return (npass) +end diff --git a/sys/qpoe/qpexgetat.x b/sys/qpoe/qpexgetat.x new file mode 100644 index 00000000..9f7b3af2 --- /dev/null +++ b/sys/qpoe/qpexgetat.x @@ -0,0 +1,61 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpex.h" + +# QPEX_GETATTRIBUTE -- Get the filter expression for the named attribute +# as a text string. The length of the string is returned as the function +# value. If the referenced QPEX descriptor does not contain any filter +# terms for the named attribute, zero will be returned. If the expression +# contains multiple eterms the successive terms will be delimited by +# semicolons, e.g., "(a:b,c:d); (e:f,g)". The lists of ranges within an +# eterm are OR-ed to produce a filter term; successive eterms are AND-ed +# to produce the final filter (hence the example above is equivalent to +# "(a to b OR c to d) AND (e to f OR g)"). + +int procedure qpex_getattribute (ex, attribute, outstr, maxch) + +pointer ex #I QPEX descriptor +char attribute[ARB] #I attribute name +char outstr[maxch] #O receives the filter string +int maxch #I max chars out + +pointer sp, atname, et +int nchars, op, otop +int gstrcpy(), qp_expandtext() +bool strne() + +begin + call smark (sp) + call salloc (atname, SZ_FNAME, TY_CHAR) + + # Translate attribute name, in case it is aliased. + nchars = qp_expandtext (EX_QP(ex), attribute, Memc[atname], SZ_FNAME) + + # Construct filter expression for named attribute. + op = 1 + otop = maxch + 1 + for (et=EX_ETHEAD(ex); et != NULL; et=ET_NEXT(et)) { + if (ET_DELETED(et) == YES) + next + + # Skip entry if not for the named attribute. + if (strne (Memc[ET_ATNAME(et)], Memc[atname])) + next + + # Add term delimiter if not first term. + if (op > 1) { + outstr[op] = ';'; op = min(otop, op + 1) + outstr[op] = ' '; op = min(otop, op + 1) + } + + # The expression text (may be very large). + op = min (otop, + op + gstrcpy (Memc[ET_EXPRTEXT(et)], outstr[op], otop-op)) + } + outstr[op] = EOS + + # Return the string length, or zero if no filter for named attribute. + call sfree (sp) + return (op - 1) +end diff --git a/sys/qpoe/qpexgetfil.x b/sys/qpoe/qpexgetfil.x new file mode 100644 index 00000000..3f1d2816 --- /dev/null +++ b/sys/qpoe/qpexgetfil.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpex.h" + +# QPEX_GETFILTER -- Return the currently active filter as a text string, +# i.e., as a series of "attribute = expr" terms. The number of chars +# output is returned as the function value. + +int procedure qpex_getfilter (ex, outstr, maxch) + +pointer ex #I QPEX descriptor +char outstr[maxch] #O receives the filter string +int maxch #I max chars out + +pointer et +int op, otop +int gstrcpy() + +begin + op = 1 + otop = maxch + 1 + for (et=EX_ETHEAD(ex); et != NULL; et=ET_NEXT(et)) { + if (ET_DELETED(et) == YES) + next + + # Add term delimiter if not first term. + if (op > 1) { + outstr[op] = ','; op = min(otop, op + 1) + outstr[op] = ' '; op = min(otop, op + 1) + } + + # Attribute name. + op = min (otop, + op + gstrcpy (Memc[ET_ATNAME(et)], outstr[op], otop-op)) + outstr[op] = ' '; op = min(otop, op + 1) + + # Assignment operator ("=" or "+="). + op = min (otop, + op + gstrcpy (Memc[ET_ASSIGNOP(et)], outstr[op], otop-op)) + outstr[op] = ' '; op = min(otop, op + 1) + + # The expression text (may be very large). + op = min (otop, + op + gstrcpy (Memc[ET_EXPRTEXT(et)], outstr[op], otop-op)) + } + outstr[op] = EOS + + return (op - 1) +end diff --git a/sys/qpoe/qpexmodfil.x b/sys/qpoe/qpexmodfil.x new file mode 100644 index 00000000..7df4b926 --- /dev/null +++ b/sys/qpoe/qpexmodfil.x @@ -0,0 +1,247 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpoe.h" +include "qpex.h" + +# QPEX_MODFILTER -- Compile an event attribute expression to be used for event +# attribute filtering, modifying the the current EAF as directed by the expr. +# An event attribute expression consists of a sequence of independent terms +# of the form "attribute = expr", e.g., +# +# pha=%104B, e=100:, t=(:9,11:29,33,42:65,67:99,!(82,87),103), ... +# +# +# Variants on "attr = expr" are "attr := expr" and "attr += expr". In the +# case of :=, any expression terms already entered for the named attribute +# will be REPLACED by the new expression. In the case of +=, the given +# expression denotes an additional condition which the attribute must satisfy +# to pass the filter, i.e., a new term is added to the existing filter. The +# case = is the same as +=, i.e., the default action is to modify rather than +# replace any existing filter. +# +# +# Our function is to extract each attribute=expr term and compile it into a +# series of instructions to be repeatedly executed (interpreted) at runtime +# to evaluate the expression for a particular event structure. Terms are +# compiled and evaluated in the order in which they appear in the expression +# list (except for replacement terms), allowing the user to manually optimize +# the filter by giving terms which are most likely to fail first. +# +# The expression list may contain references to predefined global or local +# (datafile) macros, external macro files, or back-quoted CL commands for +# which the output is to be substituted as for a macro. In all cases, macro +# substitution is handled at a lower level in the gettok routine. In +# particular, the logical names of the fields of the event structure are +# implemented as predefined datafile-local macros, hence we are concerned only +# with physical field names here. The form of a physical field name is +# a datatype code [SIRD] followed by the decimal zero-indexed byte offset +# of the field in the event structure, e.g., S0, S2, R4, etc. (short integer +# field at offset 0, same at offset 2, Real*4 field at offset 4, etc.). +# +# The function value is OK if the expression list compiles without any errors, +# or ERR if some compilation error occurs. Compilation errors cause an error +# message to be output to STDERR and the affected terms to be skipped, but are +# otherwise ignored. + +int procedure qpex_modfilter (ex, exprlist) + +pointer ex #I qpex descriptor +char exprlist[ARB] #I list of attribute=expr expressions + +bool replace +int boffset, offset, max_offset, dtype +int status, sz_expr, token, parenlevel, nchars, buflen +pointer sp, atname, assignop, tokbuf, expr, qp, ip, op, in, et_tail + +pointer qp_opentext() +int qpex_codegeni(), qpex_codegenr(), qpex_codegend() +int qp_gettok(), strlen(), gstrcpy(), ctoi(), sizeof() +errchk malloc, qp_opentext, qp_gettok, realloc, qpex_delete + +string qpexwarn "QPEX Warning" +define eatup_ 91 +define badatt_ 92 + +begin + call smark (sp) + call salloc (atname, SZ_TOKBUF, TY_CHAR) + call salloc (assignop, SZ_TOKBUF, TY_CHAR) + call salloc (tokbuf, SZ_TOKBUF, TY_CHAR) + + status = OK + sz_expr = DEF_SZEXPRBUF + et_tail = EX_ETTAIL(ex) + qp = EX_QP(ex) + + # Allocate a variable size expression buffer. + call malloc (expr, sz_expr, TY_CHAR) + + # Open the expression list for token input with macro expansion. + in = qp_opentext (qp, exprlist) + + # Accumulate and compile successive attribute=expr terms of the + # expression list. + + repeat { + # Get attribute name. + switch (qp_gettok (in, Memc[atname], SZ_TOKBUF)) { + case EOF: + break # input exhausted + case ',', ';': + next # null statement + case TOK_IDENTIFIER: + ; # got one + default: + call eprintf ("%s: unexpected token `%s'\n") + call pargstr (qpexwarn) + call pargstr (Memc[atname]) + goto eatup_ + } + + # Get operator. + switch (qp_gettok (in, Memc[assignop], SZ_TOKBUF)) { + case TOK_PLUSEQUALS, '=': + replace = false + case TOK_COLONEQUALS: + replace = true + + default: + call eprintf ("%s: missing assignment token (`%s')\n") + call pargstr (qpexwarn) + call pargstr (Memc[atname]) +eatup_ + # A half-hearted attempt to ignore the offending statement... + while (qp_gettok (in, Memc[expr], sz_expr) != EOF) + if (Memc[expr] == ',') + break + + # The default is to add to any existing filter. + replace = false + } + + parenlevel = 0 + token = NULL + + # Accumulate expression. + for (op=expr; token != EOF; ) { + # Get next token from input stream. + token = qp_gettok (in, Memc[tokbuf], SZ_TOKBUF) + + # Process any special tokens. + switch (token) { + case EOF: + break + case '(': + parenlevel = parenlevel + 1 + case ')': + parenlevel = parenlevel - 1 + if (parenlevel < 0) { + call eprintf ("%s: missing left parenthesis\n") + call pargstr (qpexwarn) + parenlevel = 0 + status = ERR + next + } + case ',', ';': + # An unparenthesized comma terminates the expression. + if (parenlevel <= 0) + break + } + + # Allocate more storage if expr buf fills. + nchars = strlen (Memc[tokbuf]) + buflen = op - expr + if (buflen + nchars > sz_expr) { + sz_expr = sz_expr + INC_SZEXPRBUF + call realloc (expr, sz_expr, TY_CHAR) + op = expr + buflen + } + + # Concatenate token string to expr. + op = op + gstrcpy (Memc[tokbuf], Memc[op], SZ_TOKBUF) + } + + Memc[op] = EOS + if (parenlevel > 0) { + call eprintf ("%s: missing right parenthesis in expression\n") + call pargstr (qpexwarn) + status = ERR + } + + # Parse the attribute name to determine the datatype and offset. + + # Get byte offset of field. + ip = atname + 1 + if (ctoi (Memc, ip, boffset) <= 0) + goto badatt_ + + # Get datatype and scaled offset; check field alignment. + switch (Memc[atname]) { + case 'S', 's': + dtype = TY_SHORT + offset = boffset / (SZ_SHORT * SZB_CHAR) + if (offset * SZ_SHORT * SZB_CHAR != boffset) + goto badatt_ + case 'I', 'i': + dtype = TY_INT + offset = boffset / (SZ_INT * SZB_CHAR) + if (offset * SZ_INT * SZB_CHAR != boffset) + goto badatt_ + case 'R', 'r': + dtype = TY_REAL + offset = boffset / (SZ_REAL * SZB_CHAR) + if (offset * SZ_REAL * SZB_CHAR != boffset) + goto badatt_ + case 'D', 'd': + dtype = TY_DOUBLE + offset = boffset / (SZ_DOUBLE * SZB_CHAR) + if (offset * SZ_DOUBLE * SZB_CHAR != boffset) + goto badatt_ + default: + goto badatt_ + } + + # Verify that the field is in range in the event struct. + # (Actually, we don't know the event struct at compile time...) + + max_offset = (boffset / SZB_CHAR) + sizeof(dtype) - 1 + if (boffset < 0 || max_offset > ARB) { +badatt_ call eprintf ("%s: bad attribute name `%s'\n") + call pargstr (qpexwarn) + call pargstr (Memc[atname]) + status = ERR + next + } + + # Clobber any old expression for the given attribute if replace + # mode is in effect. Only previous expression terms are affected, + # hence in single expressions like "pha=x,pha=y", the second entry + # does not clobber the first. + + if (replace) + call qpex_delete (ex, et_tail, offset, dtype) + + # Compile the expression. + switch (dtype) { + case TY_SHORT, TY_INT: + if (qpex_codegeni (ex, Memc[atname], Memc[assignop], + Memc[expr], offset, dtype) == ERR) + status = ERR + case TY_REAL: + if (qpex_codegenr (ex, Memc[atname], Memc[assignop], + Memc[expr], offset, dtype) == ERR) + status = ERR + case TY_DOUBLE: + if (qpex_codegend (ex, Memc[atname], Memc[assignop], + Memc[expr], offset, dtype) == ERR) + status = ERR + } + } + + call qp_closetext (in) + call mfree (expr, TY_CHAR) + call sfree (sp) + + return (status) +end diff --git a/sys/qpoe/qpexopen.x b/sys/qpoe/qpexopen.x new file mode 100644 index 00000000..833a1461 --- /dev/null +++ b/sys/qpoe/qpexopen.x @@ -0,0 +1,67 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "qpoe.h" +include "qpex.h" + +# QPEX_OPEN -- Open the expression evaluator. If an expression is given it +# is compiled into the descriptor, otherwise a null (pass all) expression +# is compiled. The compiled expression may be modified or read out at any +# time via calls to other routines in the QPEX package (e.g., qpex_modfilter, +# qpex_getfilter). + +pointer procedure qpex_open (qp, expr) + +pointer qp #I QPOE descriptor +char expr[ARB] #I selection expression (filter) + +pointer ex, pb, db +int pb_len, db_len +int qpex_modfilter() +errchk calloc + +begin + # Allocate the main QPEX descriptor. + call calloc (ex, LEN_EXDES, TY_STRUCT) + + # Allocate the program buffer. + pb_len = QP_EXPBLEN(qp) + call calloc (pb, pb_len, TY_INT) + + # Allocate the data buffer. + db_len = QP_EXDBLEN(qp) + call calloc (db, db_len, TY_CHAR) + + # Initialize the descriptor. + + EX_QP(ex) = qp + EX_DEBUG(ex) = QP_DEBUG(qp) + EX_START(ex) = pb + + EX_PB(ex) = pb + EX_PBTOP(ex) = pb + pb_len + EX_PBOP(ex) = pb + + EX_DB(ex) = db + EX_DBTOP(ex) = db + db_len + EX_DBOP(ex) = db + + EX_MAXFRLUTLEN(ex) = QP_EXMAXFRLLEN(qp) + EX_MAXRRLUTLEN(ex) = QP_EXMAXRRLLEN(qp) + EX_LUTMINRANGES(ex) = QP_EXLMINRANGES(qp) + EX_LUTSCALE(ex) = QP_EXLSCALE(qp) + + if (EX_DEBUG(ex) > 1) { + call eprintf ("QPEX activated, expr = `%s'\n") + call pargstr (expr) + } + + # If a selection expression was given, compile it into the descriptor. + if (qpex_modfilter (ex, expr) == ERR) { + call qpex_close (ex) + call syserrs (SYS_QPEXSYN, QP_DFNAME(qp)) + } + + return (ex) +end diff --git a/sys/qpoe/qpexpand.x b/sys/qpoe/qpexpand.x new file mode 100644 index 00000000..9be19a36 --- /dev/null +++ b/sys/qpoe/qpexpand.x @@ -0,0 +1,60 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "qpoe.h" + +# QP_EXPANDTEXT -- Copy a statement to the output, breaking it up into tokens +# and expanding any macro references in the process. This is used to resolve +# macro references which might otherwise be repeatedly expanded, or which it +# might not be possible to expand if this is left to some future time when +# the referenced macros are no longer defined. + +int procedure qp_expandtext (qp, s1, s2, maxch) + +pointer qp #I QPOE descriptor +char s1[ARB] #I input string containing macros +char s2[maxch] #O output string buffer +int maxch #I max chars out + +pointer sp, tokbuf, in +int token, op, otop +int gstrcpy(), qp_gettok() +pointer qp_opentext() + +begin + call smark (sp) + call salloc (tokbuf, SZ_TOKBUF, TY_CHAR) + + # Open input text for macro expanded token input. + in = qp_opentext (qp, s1) + otop = maxch + 1 + op = 1 + + # Copy tokens to the output, inserting a space after every token. + repeat { + token = qp_gettok (in, Memc[tokbuf], SZ_TOKBUF) + if (token != EOF) { + if (token == TOK_STRING) { + s2[op] = '"' + op = min (otop, op + 1) + } + op = op + gstrcpy (Memc[tokbuf], s2[op], otop-op) + if (token == TOK_STRING) { + s2[op] = '"' + op = min (otop, op + 1) + } + s2[op] = ' '; op = min (otop, op + 1) + if (op >= otop) + break + } + } until (token == EOF) + + # Cancel the trailing blank and add the EOS. + if (op > 1 && op < otop) + op = op - 1 + s2[op] = EOS + + call qp_closetext (in) + call sfree (sp) + + return (op - 1) +end diff --git a/sys/qpoe/qpexparse.gx b/sys/qpoe/qpexparse.gx new file mode 100644 index 00000000..c6f40042 --- /dev/null +++ b/sys/qpoe/qpexparse.gx @@ -0,0 +1,410 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "../qpex.h" + +.help qpexparse +.nf -------------------------------------------------------------------------- +QPEXPARSE -- Code to parse an event attribute expression, producing a binary +range list as output. + + nranges = qpex_parse[ird] (expr, xs, xe, xlen) + +The calling sequence for the parse routine is shown above. The arguments XS +and XE are pointers to dynamically allocated arrays of length XLEN and type +[IRD]. These arrays should be allocated in the calling program before calling +the parser, and deallocated when no longer needed. Reallocation to increase +the array length is automatic if the arrays fill during parsing. DTYPE should +be the same datatype as the attribute with which the list is associated. + +The form of an event attribute expression may be a list of values, + + attribute = n +or + attribute = m, n, ... + +a list of inclusive or exclusive ranges, + + attribute = m:n, !p:q + +including open ranges, + + attribute = :n, p:q + +or any combination of the above (excluding combinations of bitmasks and values +or ranges, which are mutually exclusive): + + attribute = :n, a, b, p:q, !(m, e:f) + +Parenthesis may be used for grouping where desired, e.g., + + attribute = (:n, a, b, p:q, !(m, e:f)) + +An additional form of the event attribute expression allows use of a bitmask +to specify the acceptable values, e.g., + + attribute = %17B +or + attribute = !%17B + +however, bitmasks are incompatible with range lists, and should be recognized +and dealt with elsewhere (bitmasks may not be combined with range lists in +the same expression term). + +We are concerned here only with the attribute value list itself, i.e., +everything to the right of the equals sign in the examples above. This list +should be extracted and placed into a string containing a single line of +text before we are called. Attribute value lists may be any length, but +backslash continuation, file inclusion (or whatever means is used to form +the attribute value list) is assumed to be handled at a higher level. + +The output of this package is an ordered boolean valued binary range list +with type integer, real, or double breakpoints (i.e., the breakpoints are the +same datatype as the attribute itself, but the range values are zero or one). +The range list defines the initial value, final value, and any interior +breakpoints where the attribute value changes state. Expression optimization +is used to minimize the number of breakpoints (i.e., eliminate redundant +breakpoints, such as a range within a range). + +Output range list format: + + xs[1] xe[1] + xs[2] xe[2] + ... + xs[N] xe[N] + +Where each range is inclusive and only "true" ranges are shown. If XS[1] is +LEFT a open-left range (:n) is indicated; if XE[N] is RIGHT an open-right +range (n:) is indicated. In an integer range list, isolated points appear +as a single range with (xe[i]=xs[i]). In a real or double range list, +isolated points are represented as finite ranges with a width on the order of +the machine epsilon. +.endhelp --------------------------------------------------------------------- + +define DEF_XLEN 256 # default output range list length +define INC_XLEN 256 # increment to above +define DEF_VLEN 512 # default breakpoint list length +define INC_VLEN 512 # increment to above +define MAX_NEST 20 # parser stack depth + +define STEP 1 # step at boundary of closed range +define ZERO 1000 # step at boundary of open range + +define XV Mem$t[xv+($1)-1] # reference x position values +define UV Memi[uv+($1)-1] # unique flags for x value pairs +define SV Memi[sv+($1)-1] # reference breakpoint step values + + +# QPEX_PARSE -- Convert the given attribute value list into a binary +# range list, returning the number of ranges as the function value. + +int procedure qpex_parse$t (expr, xs, xe, xlen) + +char expr[ARB] #I attribute value list to be parsed +pointer xs #U pointer to array of start-range values +pointer xe #U pointer to array of end-range values +int xlen #U allocated length of XS, XE arrays + +bool range +pointer xv, uv, sv +PIXEL xstart, xend, xmin, temp, x, n_xs, n_xe +int vlen, nrg, ip, op, ch, ip_start, i, j, jval, r1, r2, y, v, ov, dy +int token[MAX_NEST], tokval[MAX_NEST], lev, itemp, umin +errchk syserr, malloc, realloc +define pop_ 91 + +$if (datatype == si) +int qp_ctoi() +define fp_equal$t($1==$2) +$else +double dtemp +bool bval, fp_equal$t() +int qp_ctod() +$endif + +begin + vlen = DEF_VLEN + call malloc (xv, vlen, TY_PIXEL) + call malloc (uv, vlen, TY_INT) + call malloc (sv, vlen, TY_INT) + + lev = 0 + nrg = 0 + + # Parse the expression string and compile the raw, unoptimized + # breakpoint list in the order in which the breakpoints occur in + # the string. + + for (ip=1; expr[ip] != EOS; ) { + # Skip whitespace. + for (ch=expr[ip]; IS_WHITE(ch) || ch == '\n'; ch=expr[ip]) + ip = ip + 1 + + # Extract and process token. + switch (ch) { + case EOS: + # At end of string. + if (lev > 0) + goto pop_ + else + break + + case ',': + # Comma list token delmiter. + ip = ip + 1 + goto pop_ + + case '!', '(': + # Syntactical element - push on stack. + ip = ip + 1 + lev = lev + 1 + if (lev > MAX_NEST) + call syserr (SYS_QPEXLEVEL) + token[lev] = ch + tokval[lev] = nrg + 1 + + case ')': + # Close parenthesized group and pop parser stack. + ip = ip + 1 + if (lev < 1) + call syserr (SYS_QPEXMLP) + else if (token[lev] != '(') + call syserr (SYS_QPEXRPAREN) + lev = lev - 1 + goto pop_ + + default: + # Process a range term. + ip_start = ip + + # Scan the M in M:N. + $if (datatype == si) + if (qp_ctoi (expr, ip, xstart) <= 0) + xstart = LEFT$T + $else + if (qp_ctod (expr, ip, dtemp) <= 0) + xstart = LEFT$T + else + xstart = dtemp + $endif + + # Scan the : in M:N. The notation M-N is also accepted, + # provided the token - immediately follows the token M. + + while (IS_WHITE(expr[ip])) + ip = ip + 1 + range = (expr[ip] == ':') + if (range) + ip = ip + 1 + else if (!IS_LEFT$T (xstart)) { + range = (expr[ip] == '-') + if (range) + ip = ip + 1 + } + + # Scan the N in M:N. + if (range) { + $if (datatype == si) + if (qp_ctoi (expr, ip, xend) <= 0) + xend = RIGHT$T + $else + if (qp_ctod (expr, ip, dtemp) <= 0) + xend = RIGHT$T + else + xend = dtemp + $endif + } else + xend = xstart + + # Fix things if the user entered M:M explicitly. + if (range) + if (fp_equal$t (xstart, xend)) + range = false + + # Expand a single point into a range. For an integer list + # this produces M:M+1; for a floating list M-eps:M+eps. + # Verify ordering and that something recognizable was scanned. + + if (!range) { + if (IS_LEFT$T(xstart)) + call syserr (SYS_QPEXBADRNG) + $if (datatype == si) + xend = xstart + 1 + $endif + } else { + if (xstart > xend) { + temp = xstart; xstart = xend; xend = temp + } + $if (datatype == si) + if (!IS_RIGHT$T(xend)) + xend = xend + 1 + $endif + } + + # Make more space if vectors fill up. + if (nrg+4 > vlen) { + vlen = vlen + INC_VLEN + call realloc (xv, vlen, TY_PIXEL) + call realloc (uv, vlen, TY_INT) + call realloc (sv, vlen, TY_INT) + } + + # Save range on intermediate breakpoint list. + nrg = nrg + 1 + XV(nrg) = xstart + UV(nrg) = 0 + SV(nrg) = STEP + + nrg = nrg + 1 + XV(nrg) = xend + UV(nrg) = 1 + SV(nrg) = -STEP +pop_ + # Pop parser stack. + if (lev > 0) + if (token[lev] == '!') { + # Invert a series of breakpoints. + do i = tokval[lev], nrg { + if (SV(i) == STEP) # invert + SV(i) = -ZERO + else if (SV(i) == -STEP) + SV(i) = ZERO + else if (SV(i) == ZERO) # undo + SV(i) = -STEP + else if (SV(i) == -ZERO) + SV(i) = STEP + } + lev = lev - 1 + } + } + } + + # If the first range entered by the user is an exclude range, + # e.g., "(!N)" or "(!(expr))" this implies that all other values + # are acceptable. Add the open range ":" to the end of the range + # list to indicate this, i.e., convert "!N" to ":,!N". + + if (SV(1) == -ZERO) { + nrg = nrg + 1 + XV(nrg) = LEFT$T + UV(nrg) = 0 + SV(nrg) = STEP + + nrg = nrg + 1 + XV(nrg) = RIGHT$T + UV(nrg) = 1 + SV(nrg) = -STEP + } + + # Sort the breakpoint list. + do j = 1, nrg { + xmin = XV(j); umin = UV(j) + jval = j + do i = j+1, nrg { + $if (datatype == rd) + bval = (XV(i) < xmin) + if (!bval) + if (abs (XV(i) - xmin) < 1.0E-5) + bval = (fp_equal$t(XV(i),xmin) && UV(i) < umin) + if (bval) { + $else + if (XV(i) < xmin || (XV(i) == xmin && UV(i) < umin)) { + $endif + xmin = XV(i); umin = UV(i) + jval = i + } + } + if (jval != j) { + temp = XV(j); XV(j) = XV(jval); XV(jval) = temp + itemp = UV(j); UV(j) = UV(jval); UV(jval) = itemp + itemp = SV(j); SV(j) = SV(jval); SV(jval) = itemp + } + } + + # Initialize the output arrays if they were passed in as null. + if (xlen <= 0) { + xlen = DEF_XLEN + call malloc (xs, xlen, TY_PIXEL) + call malloc (xe, xlen, TY_PIXEL) + } + + # Collapse sequences of redundant breakpoints into a single + # breakpoint, clipping the running sum value to the range 0-1. + # Accumulate and output successive nonzero ranges. + + op = 1 + ov = 0 + y = 0 + + for (r1=1; r1 <= nrg; r1=r2+1) { + # Get a range of breakpoint entries for a single XV position. + for (r2=r1; r2 <= nrg; r2=r2+1) { + $if (datatype == si) + if (XV(r2) != XV(r1)) + break + $else + bval = (UV(r2) != UV(r1)) + if (!bval) { + bval = (abs (XV(r2) - XV(r1)) > 1.0E-5) + if (!bval) + bval = !fp_equal$t(XV(r2),XV(r1)) + } + if (bval) + break + $endif + } + r2 = r2 - 1 + + # Collapse into a single breakpoint. + x = XV(r1) + dy = SV(r1) + do i = r1 + 1, r2 + dy = dy + SV(i) + y = y + dy + + # Clip value to the range 0-1. + v = max(0, min(1, y)) + + # Accumulate a range of nonzero value. This eliminates redundant + # points lying within a range which is already set high. + + if (v == 1 && ov == 0) { + n_xs = x + ov = 1 + } else if (v == 0 && ov == 1) { + $if (datatype == si) + if (IS_RIGHT$T(x)) + n_xe = x + else + n_xe = x - 1 + $else + n_xe = x + $endif + ov = 2 + } + + # Output a range. + if (ov == 2) { + if (op > xlen) { + xlen = xlen + INC_XLEN + call realloc (xs, xlen, TY_PIXEL) + call realloc (xe, xlen, TY_PIXEL) + } + + Mem$t[xs+op-1] = n_xs + Mem$t[xe+op-1] = n_xe + op = op + 1 + + ov = 0 + } + } + + # All done; discard breakpoint buffers. + call mfree (xv, TY_PIXEL) + call mfree (uv, TY_INT) + call mfree (sv, TY_INT) + + return (op - 1) +end diff --git a/sys/qpoe/qpexsub.gx b/sys/qpoe/qpexsub.gx new file mode 100644 index 00000000..1fc51821 --- /dev/null +++ b/sys/qpoe/qpexsub.gx @@ -0,0 +1,67 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../qpex.h" + +# QPEX_SUBLIST -- Extract a sublist spanning the indicated range from a +# larger range list. The number of ranges extracted is returned as the +# function value. + +int procedure qpex_sublist$t (x1, x2, xs,xe,nranges,ip, o_xs,o_xe) + +PIXEL x1, x2 #I range to be extracted +PIXEL xs[nranges],xe[nranges] #I input range list +int nranges #I nranges in input list +int ip #U start position in input list +PIXEL o_xs[ARB],o_xe[ARB] #O output sublist + +PIXEL tol +int op, i + +begin + $if (datatype == i) + tol = 0 + $else + tol = (EPSILON$T * 10$f) + $endif + + # Determine the range containing or immediately following the + # start point of the range of interest. + + while (x1 < xs[ip] && ip > 1) + ip = ip - 1 + while (x1 >= xs[ip]) + if (x1 <= xe[ip] || ip >= nranges) + break + else + ip = ip + 1 + + # Check for an empty output range list. + if (xs[ip] > x2) + return (0) + + # At least one input range contributes something to the output region. + # Copy a portion of the input range list to the ouput range list. + + op = 1 + do i = ip, nranges { + if (xs[i] <= x1) + o_xs[op] = LEFT$T - tol + else + o_xs[op] = xs[i] + + if ((xe[i] - x2) >= tol) { + o_xe[op] = RIGHT$T + tol + op = op + 1 + break + } else + o_xe[op] = xe[i] + + op = op + 1 + if (xs[i+1] > x2) + break + } + + ip = i + return (op - 1) +end diff --git a/sys/qpoe/qpget.gx b/sys/qpoe/qpget.gx new file mode 100644 index 00000000..dfdca1b0 --- /dev/null +++ b/sys/qpoe/qpget.gx @@ -0,0 +1,67 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../qpoe.h" + +# QP_GET -- Return the value of the named header parameter. Automatic type +# conversion is performed where possible. While only scalar values can be +# returned by this function, the scalar may be an element of a one-dimensional +# array, e.g., "param[N]". + +PIXEL procedure qp_get$t (qp, param) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name + +pointer pp +int dtype +PIXEL value +int qp_getparam() +errchk qp_getparam, syserrs + +begin + # Lookup the parameter and it's value. + dtype = qp_getparam (qp, param, pp) + if (pp == NULL) + call syserrs (SYS_QPNOVAL, param) + + # Set default value of INDEF or NULL. + $if (datatype == c) + value = (NULL) + $else + value = (INDEF) + $endif + + # Get a valid parameter value. + switch (dtype) { + case TY_CHAR: + value = (Memc[pp]) + case TY_SHORT: + if (!IS_INDEFS(Mems[pp])) + value = (Mems[pp]) + case TY_INT: + if (!IS_INDEFI(Memi[pp])) + value = (Memi[pp]) + case TY_LONG: + if (!IS_INDEFL(Meml[pp])) + value = (Meml[pp]) + case TY_REAL: + if (!IS_INDEFR(Memr[pp])) + value = (Memr[pp]) + case TY_DOUBLE: + if (!IS_INDEFD(Memd[pp])) + value = (Memd[pp]) + default: + call syserrs (SYS_QPBADCONV, param) + } + + if (QP_DEBUG(qp) > 1) { + call eprintf ("qp_get: `%s', TYP=(%d->%d) returns %g\n") + call pargstr (param) + call pargi (dtype) + call pargi (TY_PIXEL) + call parg$t (value) + } + + return (value) +end diff --git a/sys/qpoe/qpgetb.x b/sys/qpoe/qpgetb.x new file mode 100644 index 00000000..cea5c5be --- /dev/null +++ b/sys/qpoe/qpgetb.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpoe.h" + +# QP_GETB -- Return the boolean value of the named header parameter. Type +# conversion is not permitted between boolean and the other datatypes. + +bool procedure qp_getb (qp, param) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name + +pointer pp +int qp_getparam() +errchk qp_getparam, syserrs + +begin + # Lookup the parameter and it's value. + if (qp_getparam (qp, param, pp) != TY_BOOL) + call syserrs (SYS_QPBADCONV, param) + else if (pp == NULL) + call syserrs (SYS_QPNOVAL, param) + + return (Memb[pp]) +end diff --git a/sys/qpoe/qpgettok.x b/sys/qpoe/qpgettok.x new file mode 100644 index 00000000..feb8d780 --- /dev/null +++ b/sys/qpoe/qpgettok.x @@ -0,0 +1,687 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "qpoe.h" + +.help gettok +.nf -------------------------------------------------------------------------- +GETTOK -- Lexical input routines for QPOE. Used to return tokens from input +text; this is where all macro expansion and file expansion takes place. + + gt = qp_opentext (qp, text) + token = qp_gettok (gt, tokbuf, maxch) + qp_ungettok (gt, tokbuf) + token = qp_rawtok (gt, tokbuf, maxch) + token = qp_nexttok (gt) + qp_closetext (gt) + +Access to the package is gained by opening a text string with QP_OPENTEXT. +This returns a descriptor which is passed to QP_GETTOK to read successive +tokens, which may come from the input text string or from any macros, +include files, etc., referenced in the text or in any substituted text. +QP_UNGETTOK pushes a token back into the QP_GETTOK input stream, to be +returned in the next QP_GETTOK call (following macro expansion). + +QP_RAWTOK returns the next physical token from an input stream (without +macro expansion), and QP_NEXTTOK returns the type of the next *physical* +token (no macro expansion) without actually fetching it (for look ahead +decision making). + +The tokens that can be returned are as follows: + + TOK_IDENTIFIER [a-zA-Z][a-zA-Z0-9_]* + TOK_NUMBER [0-9][0-9a-zA-Z.]*(e|E)?(+|-)?[0-9]* + TOK_STRING if "abc" or 'abc', the abc + 'c' other characters, e.g., =+-*/,;:()[] etc + EOF at end of input + +Macro replacement syntax: + + macro push macro with null arglist + macro(arg,arg,...) push macro with argument substitution + @file push contents of file + @file(arg,arg,...) push file with argument substitution + `cmd` substitute output of CL command "cmd" + +where + macro is an identifier, the name of a global macro + or a datafile local macro (parameter) + +In all cases, occurences of $N in the replacement text are replaced by the +macro arguments if any, and macros are recursively expanded. Whitespace, +including newline, equates to a single space, as does EOF (hence always +delimits tokens). Comments (# to end of line) are ignored. All identifiers +in scanned text are checked to see if they are references to predefined global +or local (datafile) macros. + +A global macro is a symbol defined globally for QPOE, in effect for all poefile +accesses (see qpmacro.x). A local macro is a macro defined as a string +parameter of type TY_MACRO in the poefile header (and hence affecting only +that one datafile). +.endhelp --------------------------------------------------------------------- + +# General definitions. +define MAX_LEVELS 20 # max include file nesting +define MAX_ARGS 9 # max arguments to a macro +define SZ_CMD 80 # `cmd` +define SZ_IBUF 8192 # buffer for macro replacement +define SZ_OBUF 8192 # buffer for macro replacement +define SZ_ARGBUF 256 # argument list to a macro + +# The gettok descriptor. +define LEN_GTDES 45 +define GT_QP Memi[$1] # backpointer to QPOE descriptor +define GT_FD Memi[$1+1] # current input stream +define GT_NEXTCH Memi[$1+2] # lookahead character +define GT_FTEMP Memi[$1+3] # file on stream is a temp file +define GT_LEVEL Memi[$1+4] # current nesting level +define GT_SVFD Memi[$1+5+$2-1] # stacked file descriptors +define GT_SVFTEMP Memi[$1+25+$2-1]# stacked ftemp flags + + +# QP_OPENTEXT -- Open the QP_GETTOK descriptor. The descriptor is initially +# opened on the user supplied string buffer (which is opened as a file and +# which must remain intact while token input is in progress), but include file +# processing etc. may cause arbitrary nesting of file descriptors. + +pointer procedure qp_opentext (qp, text) + +pointer qp #I QPOE descriptor +char text[ARB] #I input text to be scanned + +pointer gt +int sz_pbbuf +int stropen(), strlen() +errchk stropen, calloc + +begin + call calloc (gt, LEN_GTDES, TY_STRUCT) + + GT_QP(gt) = qp + GT_FD(gt) = stropen (text, strlen(text), READ_ONLY) + + if (qp == NULL) + sz_pbbuf = DEF_MAXPUSHBACK + else + sz_pbbuf = QP_SZPBBUF(qp) + call fseti (GT_FD(gt), F_PBBSIZE, sz_pbbuf) + + return (gt) +end + + +# QP_GETTOK -- Return the next token from the input stream. The token ID +# (a predefined integer code or the character value) is returned as the +# function value. The text of the token is returned as an output argument. +# Any macro references, file includes, etc., are performed in the process +# of scanning the input stream, hence only fully resolved tokens are output. + +int procedure qp_gettok (gt, tokbuf, maxch) + +pointer gt #I gettok descriptor +char tokbuf[maxch] #O receives the text of the token +int maxch #I max chars out + +pointer sp, bp, qp, cmd, ibuf, obuf, argbuf, fname, sym, textp +int fd, token, level, nargs, nchars, i_fd, o_fd, ftemp + +bool streq() +pointer qp_gmsym() +int strmac(), open(), stropen() +int qp_rawtok(), qp_nexttok(), qp_arglist() +errchk qp_rawtok,close,ungetci,ungetline,qp_arglist,clcmdw,stropen,syserr +define pushfile_ 91 + + +begin + call smark (sp) + + # Allocate some buffer space. + nchars = SZ_CMD + SZ_IBUF + SZ_OBUF + SZ_ARGBUF + SZ_FNAME + 5 + call salloc (bp, nchars, TY_CHAR) + + cmd = bp + ibuf = cmd + SZ_CMD + 1 + obuf = ibuf + SZ_IBUF + 1 + argbuf = obuf + SZ_OBUF + 1 + fname = argbuf + SZ_ARGBUF + 1 + + qp = GT_QP(gt) + + # Read raw tokens and push back macro or include file text until we + # get a fully resolved token. + + repeat { + fd = GT_FD(gt) + + # Get a raw token. + token = qp_rawtok (gt, tokbuf, maxch) + + # Process special tokens. + switch (token) { + case EOF: + # EOF has been reached on the current stream. + level = GT_LEVEL(gt) + if (GT_FTEMP(gt) == YES) { + call fstats (fd, F_FILENAME, Memc[fname], SZ_FNAME) + if (level > 0) + call close (fd) + iferr (call delete (Memc[fname])) + call erract (EA_WARN) + } else if (level > 0) + call close (fd) + + if (level > 0) { + # Restore previous stream. + GT_FD(gt) = GT_SVFD(gt,level) + GT_FTEMP(gt) = GT_SVFTEMP(gt,level) + GT_LEVEL(gt) = level - 1 + GT_NEXTCH(gt) = NULL + } else { + # Return EOF token to caller. + call strcpy ("EOF", tokbuf, maxch) + break + } + + case TOK_IDENTIFIER: + # Lookup the identifier in the symbol table. + sym = NULL + if (qp != NULL) + sym = qp_gmsym (qp, tokbuf, textp) + + # Process a defined macro. + if (sym != NULL) { + # If macro does not have any arguments, merely push back + # the replacement text. + + if (and (S_FLAGS(sym), SF_MACARGS) == 0) { + if (GT_NEXTCH(gt) > 0) { + call ungetci (fd, GT_NEXTCH(gt)) + GT_NEXTCH(gt) = 0 + } + call ungetline (fd, Memc[textp]) + next + } + + # Extract argument list, if any, perform argument + # substitution on the macro, and push back the edited + # text to be rescanned. + + if (qp_nexttok(gt) == '(') { + nargs = qp_arglist (gt, Memc[argbuf], SZ_ARGBUF) + + # Pushback the text of a macro with arg substitution. + nchars = strmac (Memc[textp], Memc[argbuf], + Memc[obuf], SZ_OBUF) + if (GT_NEXTCH(gt) > 0) { + call ungetci (fd, GT_NEXTCH(gt)) + GT_NEXTCH(gt) = 0 + } + call ungetline (fd, Memc[obuf]) + next + + } else { + call eprintf ("macro `%s' called with no arguments\n") + call pargstr (tokbuf) + } + } + + # Check for the builtin symbol $DFN, the datafile name. + if (tokbuf[1] == '$') { + if (streq (tokbuf, "$DFN")) { + call strcpy (QP_DFNAME(qp), tokbuf, maxch) + token = TOK_STRING + break + } + } + + # Return a regular identifier. + break + + case TOK_COMMAND: + # Send a command to the CL and push back the output. + + # Execute the command, spooling the output in a temp file. + call mktemp ("tmp$co", Memc[fname], SZ_FNAME) + call sprintf (Memc[cmd], SZ_LINE, "%s > %s") + call pargstr (tokbuf) + call pargstr (Memc[fname]) + call clcmdw (Memc[cmd]) + + # Open the output file as input text. + call strcpy (Memc[fname], tokbuf, maxch) + nargs = 0 + ftemp = YES + goto pushfile_ + + case '@': + token = qp_rawtok (gt, tokbuf, maxch) + if (token != TOK_IDENTIFIER && token != TOK_STRING) { + call eprintf ("expected a filename after the `@'\n") + next + } else { + nargs = 0 + if (qp_nexttok(gt) == '(') # ) + nargs = qp_arglist (gt, Memc[argbuf], SZ_ARGBUF) + ftemp = NO + } +pushfile_ + # Attempt to open the file; first try the given name, then + # if that doesn't work, try adding the macro file extension. + + iferr (i_fd = open (tokbuf, READ_ONLY, TEXT_FILE)) { + call qp_mkfname (tokbuf, + QPOE_MACROEXTN, Memc[fname], SZ_FNAME) + iferr (i_fd = open (Memc[fname],READ_ONLY,TEXT_FILE)) { + call eprintf ("cannot open `%s'\n") + call pargstr (tokbuf) + next + } + } + + if (qp != NULL) + call fseti (i_fd, F_PBBSIZE, QP_SZPBBUF(qp)) + else + call fseti (i_fd, F_PBBSIZE, DEF_MAXPUSHBACK) + + # Cancel lookahead. + if (GT_NEXTCH(gt) > 0) { + call ungetci (fd, GT_NEXTCH(gt)) + GT_NEXTCH(gt) = 0 + } + + # If the macro was called with a nonnull argument list, + # attempt to perform argument substitution on the file + # contents. Otherwise merely push the fd. + + if (nargs > 0) { + # Pushback file contents with argument substitution. + o_fd = stropen (Memc[ibuf], SZ_IBUF, NEW_FILE) + + call fcopyo (i_fd, o_fd) + nchars = strmac (Memc[ibuf],Memc[argbuf],Memc[obuf],SZ_OBUF) + call ungetline (fd, Memc[obuf]) + + call close (o_fd) + call close (i_fd) + + } else { + # Push a new input stream. + level = GT_LEVEL(gt) + 1 + if (level > MAX_LEVELS) + call syserr (SYS_QPMRECUR) + + GT_SVFD(gt,level) = GT_FD(gt) + GT_SVFTEMP(gt,level) = GT_FTEMP(gt) + GT_LEVEL(gt) = level + + fd = i_fd + GT_FD(gt) = fd + GT_FTEMP(gt) = ftemp + } + + default: + break + } + } + + if (qp != NULL) + if (QP_DEBUG(qp) > 4) { + call eprintf ("token=%d(%o), `%s'\n") + call pargi (token) + call pargi (max(0,token)) + if (IS_PRINT(tokbuf[1])) + call pargstr (tokbuf) + else + call pargstr ("") + } + + call sfree (sp) + return (token) +end + + +# QP_UNGETTOK -- Push a token back into the QP_GETTOK input stream, to be +# returned as the next token by QP_GETTOK. + +procedure qp_ungettok (gt, tokbuf) + +pointer gt #I gettok descriptor +char tokbuf[ARB] #I text of token + +int fd +pointer qp +errchk ungetci + +begin + fd = GT_FD(gt) + qp = GT_QP(gt) + + if (qp != NULL) + if (QP_DEBUG(qp) > 4) { + call eprintf ("unget token `%s'\n") + call pargstr (tokbuf) + } + + # Cancel lookahead. + if (GT_NEXTCH(gt) > 0) { + call ungetci (fd, GT_NEXTCH(gt)) + GT_NEXTCH(gt) = 0 + } + + # First push back a space to ensure that the token is recognized + # when the input is rescanned. + + call ungetci (fd, ' ') + + # Now push the token text. + call ungetline (fd, tokbuf) +end + + +# QP_RAWTOK -- Get a raw token from the input stream, without performing any +# macro expansion or file inclusion. The text of the token in returned in +# tokbuf, and the token type is returened as the function value. + +int procedure qp_rawtok (gt, outstr, maxch) + +pointer gt #I gettok descriptor +char outstr[maxch] #O receives text of token. +int maxch #I max chars out + +int token, delim, fd, ch, op +define again_ 91 +int getci() + +begin + fd = GT_FD(gt) +again_ + # Get lookahead char if we don't already have one. + ch = GT_NEXTCH(gt) + GT_NEXTCH(gt) = NULL + if (ch <= 0 || IS_WHITE(ch) || ch == '\n') { + while (getci (fd, ch) != EOF) + if (!(IS_WHITE(ch) || ch == '\n')) + break + } + + # Output the first character. + op = 1 + if (ch != EOF && ch != '"' && ch != '\'' && ch != '`') { + outstr[op] = ch + op = op + 1 + } + + # Accumulate token. Some of the token recognition logic used here + # (especially for numbers) is crude, but it is not clear that rigour + # is justified for this application. + + if (ch == EOF) { + call strcpy ("EOF", outstr, maxch) + token = EOF + + } else if (ch == '#') { + # Ignore a comment. + while (getci (fd, ch) != '\n') + if (ch == EOF) + break + goto again_ + + } else if (IS_ALPHA(ch) || ch == '_' || ch == '$' || ch == '.') { + # Identifier. + token = TOK_IDENTIFIER + while (getci (fd, ch) != EOF) + if (IS_ALNUM(ch) || ch == '_' || ch == '$' || ch == '.') { + outstr[op] = ch + op = min (maxch, op+1) + } else + break + + } else if (IS_DIGIT(ch)) { + # Number. + token = TOK_NUMBER + + # Get number. + while (getci (fd, ch) != EOF) + if (IS_ALNUM(ch) || ch == '.') { + outstr[op] = ch + op = min (maxch, op+1) + } else + break + + # Get exponent if any. + if (ch == 'E' || ch == 'e') { + outstr[op] = ch + op = min (maxch, op+1) + while (getci (fd, ch) != EOF) + if (IS_DIGIT(ch) || ch == '+' || ch == '-') { + outstr[op] = ch + op = min (maxch, op+1) + } else + break + } + + } else if (ch == '"' || ch == '\'' || ch == '`') { + # Quoted string or command. + + if (ch == '`') + token = TOK_COMMAND + else + token = TOK_STRING + + delim = ch + while (getci (fd, ch) != EOF) + if (ch==delim && (op>1 && outstr[op-1] != '\\') || ch == '\n') + break + else { + outstr[op] = ch + op = min (maxch, op+1) + } + ch = getci (fd, ch) + + } else if (ch == '+') { + # May be the += operator. + if (getci (fd, ch) != EOF) + if (ch == '=') { + token = TOK_PLUSEQUALS + outstr[op] = ch + op = op + 1 + ch = getci (fd, ch) + } else + token = '+' + + } else if (ch == ':') { + # May be the := operator. + if (getci (fd, ch) != EOF) + if (ch == '=') { + token = TOK_COLONEQUALS + outstr[op] = ch + op = op + 1 + ch = getci (fd, ch) + } else + token = ':' + + } else { + # Other characters. + token = ch + ch = getci (fd, ch) + } + + # Process the lookahead character. + if (IS_WHITE(ch) || ch == '\n') { + repeat { + ch = getci (fd, ch) + } until (!(IS_WHITE(ch) || ch == '\n')) + } + + if (ch != EOF) + GT_NEXTCH(gt) = ch + + outstr[op] = EOS + return (token) +end + + +# QP_NEXTTOK -- Determine the type of the next raw token in the input stream, +# without actually fetching the token. TOK_PLUSEQUALS is not recognized at +# this level. Note that this is at the same level as QP_RAWTOK, i.e., no +# macro expansion is performed, and the lookahead token is that which would +# be returned by the next qp_rawtok, which is not necessarily what qp_gettok +# would return after macro replacement. + +int procedure qp_nexttok (gt) + +pointer gt #I gettok descriptor + +pointer qp +int token, fd, ch +int getci() + +begin + fd = GT_FD(gt) + qp = GT_QP(gt) + + # Get lookahead char if we don't already have one. + ch = GT_NEXTCH(gt) + if (ch <= 0 || IS_WHITE(ch) || ch == '\n') + while (getci (fd, ch) != EOF) + if (!(IS_WHITE(ch) || ch == '\n')) + break + + if (ch == EOF) + token = EOF + else if (IS_ALPHA(ch)) + token = TOK_IDENTIFIER + else if (IS_DIGIT(ch)) + token = TOK_NUMBER + else if (ch == '"' || ch == '\'') + token = TOK_STRING + else if (ch == '`') + token = TOK_COMMAND + else + token = ch + + if (qp != NULL) + if (QP_DEBUG(qp) > 4) { + call eprintf ("nexttok=%d(%o) `%c'\n") + call pargi (token) + call pargi (max(0,token)) + if (IS_PRINT(ch)) + call pargi (ch) + else + call pargi (0) + } + + return (token) +end + + +# QP_CLOSETEXT -- Close the gettok descriptor and any files opened thereon. + +procedure qp_closetext (gt) + +pointer gt #I gettok descriptor + +int level, fd +pointer sp, fname + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + for (level=GT_LEVEL(gt); level >= 0; level=level-1) { + fd = GT_FD(gt) + if (GT_FTEMP(gt) == YES) { + call fstats (fd, F_FILENAME, Memc[fname], SZ_FNAME) + call close (fd) + iferr (call delete (Memc[fname])) + call erract (EA_WARN) + } else + call close (fd) + + if (level > 0) { + GT_FD(gt) = GT_SVFD(gt,level) + GT_FTEMP(gt) = GT_SVFTEMP(gt,level) + } + } + + call mfree (gt, TY_STRUCT) + call sfree (sp) +end + + +# QP_ARGLIST -- Extract a paren and comma delimited argument list to be used +# for substitution into a macro replacement string. Since the result will be +# pushed back and rescanned, we do not have to perform macro substitution on +# the argument list at this level. + +int procedure qp_arglist (gt, argbuf, maxch) + +pointer gt #I gettok descriptor +char argbuf[maxch] #O receives parsed arguments +int maxch #I max chars out + +int level, quote, nargs, op, ch, fd +int getci() + +begin + fd = GT_FD(gt) + + # Get lookahead char if we don't already have one. + ch = GT_NEXTCH(gt) + if (ch <= 0 || IS_WHITE(ch) || ch == '\n') + while (getci (fd, ch) != EOF) + if (!(IS_WHITE(ch) || ch == '\n')) + break + + quote = 0 + level = 1 + nargs = 0 + op = 1 + + if (ch == '(') { + while (getci (fd, ch) != EOF) { + if (ch == '"' || ch == '\'') { + if (quote == 0) + quote = ch + else if (quote == ch) + quote = 0 + + } else if (ch == '(' && quote == 0) { + level = level + 1 + } else if (ch == ')' && quote == 0) { + level = level - 1 + if (level <= 0) { + if (op > 1 && argbuf[op-1] != EOS) + nargs = nargs + 1 + break + } + + } else if (ch == ',' && level == 1 && quote == 0) { + ch = EOS + nargs = nargs + 1 + } else if (ch == '\n') { + ch = ' ' + } else if (ch == '\\' && quote == 0) { + ch = getci (fd, ch) + next + } else if (ch == '#' && quote == 0) { + while (getci (fd, ch) != EOF) + if (ch == '\n') + break + next + } + + argbuf[op] = ch + op = min (maxch, op + 1) + } + + GT_NEXTCH(gt) = NULL + } + + argbuf[op] = EOS + return (nargs) +end diff --git a/sys/qpoe/qpgetx.x b/sys/qpoe/qpgetx.x new file mode 100644 index 00000000..cf9468bb --- /dev/null +++ b/sys/qpoe/qpgetx.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpoe.h" + +# QP_GETX -- Return the complex value of the named header parameter. Type +# conversion is not permitted between complex and the other datatypes. + +complex procedure qp_getx (qp, param) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name + +pointer pp +int qp_getparam() +errchk qp_getparam, syserrs + +begin + # Lookup the parameter and it's value. + if (qp_getparam (qp, param, pp) != TY_COMPLEX) + call syserrs (SYS_QPBADCONV, param) + else if (pp == NULL) + call syserrs (SYS_QPNOVAL, param) + + return (Memx[pp]) +end diff --git a/sys/qpoe/qpgmsym.x b/sys/qpoe/qpgmsym.x new file mode 100644 index 00000000..883f5c22 --- /dev/null +++ b/sys/qpoe/qpgmsym.x @@ -0,0 +1,76 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpoe.h" + +# QP_GMSYM -- Lookup the named macro in the symbol table and return a pointer +# to the symstruct describing the macro as the function value. NULL is +# returned if the macro is not defined, or if the named symbol is not a macro. +# Local macros take precedence over global macros. In the case of a local +# macro whose value is stored in the datafile, we have to allocate an internal +# buffer to hold the data after we exit; this data must be used promptly, +# before the routine is again called. + +pointer procedure qp_gmsym (qp, macro, textp) + +pointer qp #I QPOE descriptor +char macro[ARB] #I macro name +pointer textp #O char pointer to macro text + +int sz_textbuf, nchars, fd +pointer st, sm, sym, textbuf +data textbuf /NULL/, sz_textbuf /NULL/ + +int fm_getfd(), read() +pointer qm_symtab(), strefsbuf(), stfind() +errchk realloc, fm_getfd, seek, read + +begin + st = QP_ST(qp) + sm = qm_symtab (QP_QM(qp)) + + # First look in the datafile local symbol table. Macros are stored + # in the datafile symbol table as string macros of type TY_MACRO. + + sym = stfind (st, macro) + if (sym != NULL) + if (S_DTYPE(sym) == TY_MACRO) + if (and (S_FLAGS(sym), SF_DELETED) == 0) { + if (S_LFILE(sym) > 0) { + # Macro value stored as data. + + # Make sure the text buffer is large enough. + if (sz_textbuf < S_NELEM(sym)) { + sz_textbuf = S_NELEM(sym) + call realloc (textbuf, sz_textbuf, TY_CHAR) + } + + # Read the data. + fd = fm_getfd (QP_FM(qp), S_LFILE(sym), READ_ONLY, 0) + + call seek (fd, S_OFFSET(sym)) + nchars = max (0, read (fd, Memc[textbuf], S_NELEM(sym))) + Memc[textbuf+nchars] = EOS + textp = textbuf + + call fm_retfd (QP_FM(qp), S_LFILE(sym)) + + } else { + # Macro value stored in symbol table. + textp = strefsbuf (st, S_OFFSET(sym)) + } + + # Exit if a local symbol was found. + return (sym) + } + + # Next look in the global macro symbol table. + sym = stfind (sm, macro) + if (sym != NULL) + if (and (S_FLAGS(sym), SF_DELETED) == 0) + textp = strefsbuf (sm, S_OFFSET(sym)) + else + sym = NULL + + return (sym) +end diff --git a/sys/qpoe/qpgnfn.x b/sys/qpoe/qpgnfn.x new file mode 100644 index 00000000..c12adc76 --- /dev/null +++ b/sys/qpoe/qpgnfn.x @@ -0,0 +1,240 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "qpoe.h" + +.help qp_gnfn +.nf -------------------------------------------------------------------------- +QP_GNFN -- Access the file header as a parameter list. + + list = qp_ofnl[su] (qp, template) + nchars|EOF = qp_gnfn (list, outstr, maxch) + len = qp_lenfnl (list) + qp_seekfnl (list, pos) + qp_cfnl (list) + +These routines are used to determine the names of the fields (parameters) in +the QPOE file header, e.g., to list out the header. QP_OFNLS and QP_ONFLU open +the file header (sorted or unsorted). QP_GNFN returns the next parameter name, +returning as the function value the string length of the parameter name or EOF +when the end of the list is reached. QP_SFNL seeks on or rewinds the list. +QP_CFNL closes the list descriptor. +.endhelp -------------------------------------------------------------------- + +# Size limiting definitions. +define DEF_LENOFFV 128 # initial length of keywd-offset vector +define INC_LENOFFV 128 # increment to above +define DEF_SZSBUF 1024 # initial size of string buffer +define INC_SZSBUF 1024 # increment to above + +# List descriptor. +define LEN_FL 3 +define FL_LEN Memi[$1] # number of names in list +define FL_POS Memi[$1+1] # current position +define FL_SBUF Memi[$1+2] # pointer to string buffer +define FL_OFFV Memi[$1+3] # pointer to offset vector + + +# QP_OFNLS -- Open a sorted field name list. + +pointer procedure qp_ofnls (qp, template) + +pointer qp #I QPOE descriptor +char template[ARB] #I field name template + +pointer qp_ofnl() + +begin + return (qp_ofnl (qp, template, true)) +end + + +# QP_OFNLU -- Open an unsorted field name list. + +pointer procedure qp_ofnlu (qp, template) + +pointer qp #I QPOE descriptor +char template[ARB] #I field name template + +pointer qp_ofnl() + +begin + return (qp_ofnl (qp, template, false)) +end + + +# QP_OFNL -- Open a sorted or unsorted field name list. + +pointer procedure qp_ofnl (qp, template, sort) + +pointer qp #I QPOE descriptor +char template[ARB] #I field name template +bool sort #I sort list of matched names? + +pointer sp, patbuf, pattern, sym, fl, st, offv, sbuf, ip, op +int len_offv, sz_sbuf, nsyms, nc, junk, nchars, i, nmatch + +pointer sthead(), stnext(), stname() +int patmake(), patmatch(), strlen() +define swap {junk=$1;$1=$2;$2=junk} +errchk calloc, malloc, realloc + +begin + call smark (sp) + call salloc (pattern, SZ_LINE, TY_CHAR) + call salloc (patbuf, SZ_LINE, TY_CHAR) + + # Allocate the list descriptor. + call calloc (fl, LEN_FL, TY_STRUCT) + call malloc (offv, DEF_LENOFFV, TY_INT) + call malloc (sbuf, DEF_SZSBUF, TY_CHAR) + + len_offv = DEF_LENOFFV + sz_sbuf = DEF_SZSBUF + st = QP_ST(qp) + nsyms = 0 + nc = 0 + + # Default to match all; map '*' into '?*', which is probably what + # the user intends. Match only at the beginning of line as we want + # to match only entire field name strings. + + if (template[1] == EOS) + call strcpy ("?*", Memc[pattern], SZ_LINE) + else { + op = pattern + Memc[op] = '^' + op = op + 1 + for (ip=1; template[ip] != EOS && ip < SZ_LINE; ip=ip+1) { + if (template[ip] == '*') + if (ip == 1 || (ip > 1 && template[ip-1] != ']')) { + Memc[op] = '?' + op = op + 1 + } + Memc[op] = template[ip] + op = op + 1 + } + Memc[op] = EOS + } + + # Compile the pattern matching template. + junk = patmake (Memc[pattern], Memc[patbuf], SZ_LINE) + + # Scan the symbol table and generate the unsorted list. + for (sym=sthead(st); sym != NULL; sym=stnext(st,sym)) { + if (and (S_FLAGS(sym), SF_DELETED) != 0) + next + + # Get the symbol name. + ip = stname (st, sym) + nchars = strlen (Memc[ip]) + + # Save in list if it matches. + nmatch = patmatch (Memc[ip], Memc[patbuf]) - 1 + if (nmatch > 0 && nmatch == nchars) { + nsyms = nsyms + 1 + + # Make room in offset vector? + if (nsyms > len_offv) { + len_offv = len_offv + INC_LENOFFV + call realloc (offv, len_offv, TY_INT) + } + + # Make room in string buffer? + if (nc + nchars + 1 > sz_sbuf) { + sz_sbuf = sz_sbuf + INC_SZSBUF + call realloc (sbuf, sz_sbuf, TY_CHAR) + } + + # Add the symbol. + Memi[offv+nsyms-1] = nc + 1 + call strcpy (Memc[ip], Memc[sbuf+nc], nchars) + nc = nc + nchars + 1 + } + } + + # Sort the list if indicated, else reverse the order of the list + # to get a time-ordered (FIFO) list. + + if (sort) + call strsrt (Memi[offv], Memc[sbuf], nsyms) + else { + do i = 1, nsyms / 2 + swap (Memi[offv+i-1], Memi[offv+nsyms-i]) + } + + # Finish setting up the descriptor. + FL_LEN(fl) = nsyms + FL_SBUF(fl) = sbuf + FL_OFFV(fl) = offv + + call sfree (sp) + return (fl) +end + + +# QP_GNFN -- Return the next element from the field name list. The string +# length is returned as the function value, or EOF at the end of the list. + +int procedure qp_gnfn (fl, outstr, maxch) + +pointer fl #I list descriptor +char outstr[maxch] #O output string +int maxch #I max chars out + +int pos, off, nchars +int gstrcpy() + +begin + pos = FL_POS(fl) + if (pos >= FL_LEN(fl)) + return (EOF) + + off = Memi[FL_OFFV(fl) + pos] + nchars = gstrcpy (Memc[FL_SBUF(fl)+off-1], outstr, maxch) + + FL_POS(fl) = pos + 1 + return (nchars) +end + + +# QP_LENFNL -- Return the length of (number of names in) the field name list. + +int procedure qp_lenfnl (fl) + +pointer fl #I list descriptor + +begin + return (FL_LEN(fl)) +end + + +# QP_SEEKFNL -- Seek on the field name list. + +procedure qp_seekfnl (fl, pos) + +pointer fl #I list descriptor +int pos #I desired list element, BOF, EOF + +begin + switch (pos) { + case BOF: + FL_POS(fl) = 0 + case EOF: + FL_POS(fl) = FL_LEN(fl) + default: + FL_POS(fl) = max(0, min(FL_LEN(fl), pos - 1)) + } +end + + +# QP_CFNL -- Close a field name list. + +procedure qp_cfnl (fl) + +pointer fl #I list descriptor + +begin + call mfree (FL_SBUF(fl), TY_CHAR) + call mfree (FL_OFFV(fl), TY_INT) + call mfree (fl, TY_STRUCT) +end diff --git a/sys/qpoe/qpgpar.x b/sys/qpoe/qpgpar.x new file mode 100644 index 00000000..f3307043 --- /dev/null +++ b/sys/qpoe/qpgpar.x @@ -0,0 +1,101 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "qpoe.h" + +# QP_GETPARAM -- Lookup the named parameter in the symbol table and return +# a pointer to the scalar parameter value. A NULL pointer is returned if +# the parameter exists but does not currently have a value. The parameter +# datatype code is returned as the function value. The pointed to parameter +# value will be clobbered in the next call, hence should be used promptly. +# The data element pointed to may be a structure as well as a primitive type. + +int procedure qp_getparam (qp, param, o_pp) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +pointer o_pp #O pointer to parameter value + +int loc_pval, loc_Mem, ip, ch, elem, sz_elem, fd +pointer sp, key, fm, pp, op, sym +double pval[LEN_PVAL+1] +data pp /NULL/ + +pointer qp_gpsym() +int qp_sizeof(), fm_getfd(), qp_ctoi(), read() +errchk qp_bind, qp_gpsym, syserrs, fm_getfd, seek, read + +begin + call smark (sp) + call salloc (key, SZ_FNAME, TY_CHAR) + + if (QP_ACTIVE(qp) == NO) + call qp_bind (qp) + + fm = QP_FM(qp) + + # Compute pointer (Memc index) to the static pval buffer. + # Make sure that the computed pointer is double aligned. + + if (pp == NULL) { + call zlocva (pval, loc_pval) + call zlocva (Memc, loc_Mem) + pp = (loc_pval+SZ_DOUBLE - loc_Mem) / SZ_DOUBLE * SZ_DOUBLE + 1 + } + + # Extract the primary parameter name, minus any whitespace and + # subscript (e.g., "param[elem]"). + + op = key + do ip = 1, SZ_FNAME { + ch = param[ip] + if (IS_WHITE(ch)) + next + else if (ch == '[' || ch == EOS) + break + Memc[op] = ch + op = op + 1 + } + Memc[op] = EOS + + # Determine the array element (default [1]). + elem = 1 + if (param[ip] == '[') { + ip = ip + 1 + if (qp_ctoi (param, ip, elem) <= 0) + elem = 1 + } + + # Lookup the symbol in the symbol table. + sym = qp_gpsym (qp, Memc[key]) + if (sym == NULL) + call syserrs (SYS_QPUKNPAR, param) + + # Check to make sure the parameter value exists, and fetch the + # value from the lfile where the parameter data is stored, setting + # the parameter value pointer to point to the stored value. + + if (elem < 1 || elem > S_NELEM(sym)) + o_pp = NULL + else { + sz_elem = qp_sizeof (qp, S_DTYPE(sym), sym, INSTANCEOF) + if (sz_elem > LEN_PVAL * SZ_DOUBLE) + call syserrs (SYS_QPPVALOVF, QP_DFNAME(qp)) + + fd = fm_getfd (fm, S_LFILE(sym), READ_ONLY, 0) + + call seek (fd, S_OFFSET(sym) + (elem - 1) * sz_elem) + if (read (fd, Memc[pp], sz_elem) < sz_elem) + o_pp = NULL + else if (S_DTYPE(sym) == TY_USER) + o_pp = (pp - 1) / SZ_STRUCT + 1 + else + o_pp = (pp - 1) / sz_elem + 1 + + call fm_retfd (fm, S_LFILE(sym)) + } + + call sfree (sp) + return (S_DTYPE(sym)) +end diff --git a/sys/qpoe/qpgpsym.x b/sys/qpoe/qpgpsym.x new file mode 100644 index 00000000..b18199e2 --- /dev/null +++ b/sys/qpoe/qpgpsym.x @@ -0,0 +1,90 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpoe.h" + +# QP_GPSYM -- Lookup the named parameter in the symbol table and return +# a pointer to the symstruct describing the parameter as the function value. +# NULL is returned if the parameter is not defined, or if the named symbol is +# not a parameter. Global parameter aliases are recursively expanded. +# Local macros are not expanded at this level, since local macros are stored +# as parameters themselves. + +pointer procedure qp_gpsym (qp, param) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name + +int n +pointer sp, pname, sym, st, sm +pointer stfind(), strefsbuf(), qm_symtab() +errchk syserrs + +#pointer ip +#int fd, nchars +#int fm_getfd(), read() +#errchk fm_getfd, read, seek + +begin + call smark (sp) + call salloc (pname, SZ_FNAME, TY_CHAR) + + st = QP_ST(qp) + sm = qm_symtab (QP_QM(qp)) + call strcpy (param, Memc[pname], SZ_FNAME) + + # First expand any aliases in the global macro symbol table. + sym = stfind (sm, param) + for (n=1; sym != NULL; n=n+1) { + if (and (S_FLAGS(sym), SF_DELETED) != 0) + break + call strcpy (strefsbuf(sm,S_OFFSET(sym)), Memc[pname], SZ_FNAME) + sym = stfind (sm, Memc[pname]) + if (n > MAX_INDIR) + call syserrs (SYS_QPMRECUR, param) + } + + # Lookup the symbol in the datafile local symbol table. Datafile + # local macros cannot be expanded in parameter references, since + # the macros are themselves stored as parameters (if macro parameters + # were expanded in parameter references, there would be no simple + # way to access the macro parameters themselves). + + sym = stfind (st, Memc[pname]) + +# Disable expansion of datafile-local macro defines. +# if (sym != NULL) { +# for (n=0; S_DTYPE(sym) == TY_MACRO; n=n+1) { +# if (and (S_FLAGS(sym), SF_DELETED) != 0) { +# break +# +# } else if (S_LFILE(sym) > 0) { +# # Macro value stored as data. +# fd = fm_getfd (QP_FM(qp), S_LFILE(sym), READ_ONLY, 0) +# +# call seek (fd, S_OFFSET(sym)) +# nchars = max (0, read (fd, Memc[pname], S_NELEM(sym))) +# Memc[pname+nchars] = EOS +# ip = pname +# +# call fm_retfd (QP_FM(qp), S_LFILE(sym)) +# +# } else { +# # Macro value stored in symbol table. +# ip = strefsbuf (st, S_OFFSET(sym)) +# } +# +# # Macro recursion. +# if (n > MAX_INDIR) +# call syserrs (SYS_QPMRECUR, param) +# } +# } + + # Don't "find" the symbol if it has been deleted. + if (sym != NULL) + if (and (S_FLAGS(sym), SF_DELETED) != 0) + sym = NULL + + call sfree (sp) + return (sym) +end diff --git a/sys/qpoe/qpgstr.x b/sys/qpoe/qpgstr.x new file mode 100644 index 00000000..91a03a0f --- /dev/null +++ b/sys/qpoe/qpgstr.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpoe.h" + +# QP_GSTR -- Return the string value of the named parameter. + +int procedure qp_gstr (qp, param, outstr, maxch) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +char outstr[maxch] #O receives string value +int maxch #I max chars out + +pointer sym, fm +int nchars, fd +pointer qp_gpsym() +int fm_getfd(), read() +errchk qp_bind, qp_gpsym, syserrs, fm_getfd, seek + +begin + if (QP_ACTIVE(qp) == NO) + call qp_bind (qp) + fm = QP_FM(qp) + + # Lookup the symbol in the symbol table. + sym = qp_gpsym (qp, param) + if (sym == NULL) + call syserrs (SYS_QPUKNPAR, param) + else if (!(S_DTYPE(sym) == TY_CHAR || S_DTYPE(sym) == TY_USER)) + call syserrs (SYS_QPBADCONV, param) + + # Fetch the string value from the lfile where the data is stored. + fd = fm_getfd (fm, S_LFILE(sym), READ_ONLY, 0) + call seek (fd, S_OFFSET(sym)) + + nchars = max (0, read (fd, outstr, min(S_NELEM(sym),maxch))) + outstr[nchars+1] = EOS + + call fm_retfd (fm, S_LFILE(sym)) + return (nchars) +end diff --git a/sys/qpoe/qpinherit.x b/sys/qpoe/qpinherit.x new file mode 100644 index 00000000..495966f4 --- /dev/null +++ b/sys/qpoe/qpinherit.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpoe.h" + +# QP_INHERIT -- Copy all the inheritable parameters from one datafile to +# another. + +procedure qp_inherit (n_qp, o_qp, out) + +pointer n_qp #I QPOE descriptor of new datafile +pointer o_qp #I QPOE descriptor of old datafile +int out #I output stream for verbose messages, or NULL + +int nsyms, i +pointer sp, n_st, o_st, sym, op, pname, syms +pointer sthead(), stnext(), stname() +int qp_accessf() + +begin + call smark (sp) + + n_st = QP_ST(n_qp) + o_st = QP_ST(o_qp) + + # Count the symbols to be copied. + nsyms = 0 + for (sym=sthead(o_st); sym != NULL; sym=stnext(o_st,sym)) + if (and (S_FLAGS(sym), SF_DELETED) == 0) + if (and (S_FLAGS(sym), SF_INHERIT) != 0) + nsyms = nsyms + 1 + + # Construct a reversed array of symbol pointers. + call salloc (syms, nsyms, TY_POINTER) + op = syms + nsyms - 1 + for (sym=sthead(o_st); sym != NULL; sym=stnext(o_st,sym)) + if (and (S_FLAGS(sym), SF_DELETED) == 0) + if (and (S_FLAGS(sym), SF_INHERIT) != 0) { + Memi[op] = sym + op = op - 1 + } + + # Copy each symbol. + do i = 1, nsyms { + pname = stname (o_st, Memi[syms+i-1]) + if (qp_accessf (n_qp, Memc[pname]) == YES) { + if (out != NULL) { + call fprintf (out, + "parameter `%s' already exists, not copied\n") + call pargstr (Memc[pname]) + } + } else iferr (call qp_copyf (o_qp, Memc[pname], n_qp, Memc[pname])) + call erract (EA_WARN) + } + + call sfree (sp) +end diff --git a/sys/qpoe/qpio.h b/sys/qpoe/qpio.h new file mode 100644 index 00000000..91b58c73 --- /dev/null +++ b/sys/qpoe/qpio.h @@ -0,0 +1,140 @@ +# QPIO.H -- Definitions for the QPOE event i/o subpackage. + +# Default parameter and domain names. +define DEF_BLOCK "defblock" # header param - default block factor +define DEF_XBLOCK "defxblock" # header param - default X block factor +define DEF_YBLOCK "defyblock" # header param - default Y block factor +define DEF_MASK "defmask" # header param - default region mask +define DEF_FILTER "deffilt" # header param - default event filter +define DEF_EVENTTYPE "event" # default name of user event datatype +define DEF_EVENTPARAM "events" # default event-list parameter + +# QPIO keywords recognized in expressions (abbreviations permitted). +define KEYWORDS "|block|xblock|yblock|debug|filter|key|noindex|param|mask|rect|" + +define KW_BLOCK 1 # blocking factor for image matrix +define KW_XBLOCK 2 # X blocking factor for image matrix +define KW_YBLOCK 3 # Y blocking factor for image matrix +define KW_DEBUG 4 # debug level (integer, 0=nodebug) +define KW_FILTER 5 # event attribute filter +define KW_KEY 6 # event key (Y,X) fields (e.g.(s10,s8)) +define KW_NOINDEX 7 # don't use index even if present +define KW_PARAM 8 # name of event list header parameter +define KW_MASK 9 # region mask +define KW_RECT 10 # rectangle (bounding box) for i/o + +# Size limiting definitions. +define SZ_EVLIST 1024 # event list buffer size (arbitrary) +define NDIM 2 # all QPOE images are 2-dim + +# The main QPIO descriptor. +define LEN_IODES 82 + +# general +define IO_QP Memi[$1] # backpointer to QPOE descriptor +define IO_MODE Memi[$1+1] # read_only or new_file +define IO_DEBUG Memi[$1+2] # debug level +define IO_NLINES Memi[$1+3] # number of image lines (physical) +define IO_NCOLS Memi[$1+4] # number of image columns (physical) +define IO_XBLOCK Memr[P2R($1+5)] # blocking factor for qpio_readpix +define IO_YBLOCK Memr[P2R($1+6)] # blocking factor for qpio_readpix +define IO_OPTBUFSIZE Memi[$1+7] # optbufsize for FIO (qpio_readpix) +define IO_NOINDEX Memi[$1+8] # don't use indexed extraction +define IO_NODEFFILT Memi[$1+9] # disable use of default filter +define IO_NODEFMASK Memi[$1+10] # disable use of default mask +define IO_PARAM Memi[$1+11] # pointer to buffer with param name +define IO_PSYM Memi[$1+12] # symbol table entry for parameter +define IO_MASK Memi[$1+13] # pointer to buffer with mask name +define IO_MDEPTH Memi[$1+14] # mask depth, bits +define IO_EXCLOSE Memi[$1+15] # qpex was opened by qpio +define IO_PLCLOSE Memi[$1+16] # mask was opened by qpio +define IO_PL Memi[$1+17] # PLIO (mask) pointer +define IO_EX Memi[$1+18] # QPEX (event attribute filter) pointer +define IO_FD Memi[$1+19] # file descriptor of open lfile +define IO_LF Memi[$1+20] # lfile where event list is stored +define IO_CHAN Memi[$1+21] # i/o channel of open lfile +# events +define IO_DD Memi[$1+22] # pointer to domain descriptor +define IO_EVXOFF Memi[$1+23] # offset of X field used for extraction +define IO_EVXTYPE Memi[$1+24] # datatype of X field +define IO_EVYOFF Memi[$1+25] # offset of Y field used for extraction +define IO_EVYTYPE Memi[$1+26] # datatype of Y field +define IO_EVENTLEN Memi[$1+27] # length of event struct, shorts +define IO_MINEVL Memi[$1+28] # pointer to min event for full list +define IO_MAXEVL Memi[$1+29] # pointer to max event for full list +# buckets +define IO_SZBBUCKET Memi[$1+30] # event file bucket size, bytes +define IO_BUCKETLEN Memi[$1+31] # nevents per bucket (excl. min/max) +define IO_NEVENTS Memi[$1+32] # total data events in event list +define IO_FBOFF Memi[$1+33] # lfile offset of first bucket +define IO_EVMINOFF Memi[$1+34] # offset to the MIN event in a bucket +define IO_EVMAXOFF Memi[$1+35] # offset to the MAX event in a bucket +# index +define IO_INDEXLEN Memi[$1+38] # length of index (same as nlines) +define IO_IXXOFF Memi[$1+39] # offset of X field used in index +define IO_IXXTYPE Memi[$1+40] # datatype of X field used in index +define IO_IXYOFF Memi[$1+41] # offset of Y field used in index +define IO_IXYTYPE Memi[$1+42] # datatype of Y field used in index +define IO_YOFFVP Memi[$1+43] # pointer to Y-index array (len=nlines) +define IO_YLENVP Memi[$1+44] # pointer to Y-line length array +define IO_YOFFVOFF Memi[$1+45] # lfile offset of stored YOFFV +define IO_YOFFVLEN Memi[$1+46] # length, words, of compressed YOFFV +define IO_YLENVOFF Memi[$1+47] # lfile offset of stored YLENV +define IO_YLENVLEN Memi[$1+48] # length, words, of compressed YLENV +# i/o +define IO_ACTIVE Memi[$1+50] # set once i/o begins +define IO_IOTYPE Memi[$1+51] # type of i/o selected for BB +define IO_LINEIO Memi[$1+52] # flag - BB width is full line width +define IO_RMUSED Memi[$1+53] # flag - region mask used in this BB +define IO_BBUSED Memi[$1+54] # flag - bounding box in use +define IO_BBMASK Memi[$1+55] # BB region mask subras, nonindexed i/o +define IO_RL Memi[$1+56] # range list pointer +define IO_RLI Memi[$1+57] # range list index +define IO_EVI Memi[$1+58] # event index into event list (for i/o) +define IO_EV1 Memi[$1+59] # event index of first event on line +define IO_EV2 Memi[$1+60] # event index of last event on line +define IO_BP Memi[$1+61] # pointer to bucket buffer +define IO_BKNO Memi[$1+62] # bucket number +define IO_BKFIRSTEV Memi[$1+63] # event index of first event in bucket +define IO_BKLASTEV Memi[$1+64] # event index of last event in bucket +# (avail) +define IO_V Meml[$1+70+$2-1]# current vector +define IO_VS Meml[$1+72+$2-1]# start vector +define IO_VE Meml[$1+74+$2-1]# end vector +define IO_VN Meml[$1+76+$2-1]# size of section +define IO_VSDEF Meml[$1+78+$2-1]# default start vector +define IO_VEDEF Meml[$1+80+$2-1]# default end vector + +# Handy macros. +define IO_MINEVB (IO_BP($1)+IO_EVMINOFF($1)) +define IO_MAXEVB (IO_BP($1)+IO_EVMAXOFF($1)) +define EVI_TO_BUCKET ((($2)-1)/IO_BUCKETLEN($1)+1) +define BUCKET_TO_EVI ((($2)-1)*IO_BUCKETLEN($1)+1) + +# I/O types (specially optimized code for each case). +define NoINDEX_NoRMorBB 0 # nonindexed, no RM no BB +define NoINDEX_RMorBB 1 # nonindexed, maybe RM or BB +define INDEX_NoRMorBB 2 # indexed, no RM or BB +define INDEX_RMorBB 3 # indexed, maybe RM or BB +define NoDATA_NoAREA 4 # no events can be returned + +# Stored Event List header (one per stored event list). +define LEN_EHDES 18 +define EH_NEVENTS Memi[$1] # total data events in event list +define EH_EVENTLEN Memi[$1+1] # event length, shorts +define EH_SZBBUCKET Memi[$1+2] # event file bucket size, bytes +define EH_BUCKETLEN Memi[$1+3] # nevents per bucket (excl. min/max) +define EH_FBOFF Memi[$1+4] # lfile offset of first bucket +define EH_EVMINOFF Memi[$1+5] # offset to the MIN event in a bucket +define EH_EVMAXOFF Memi[$1+6] # offset to the MAX event in a bucket +define EH_MINEVLOFF Memi[$1+7] # offset of stored MINEVL +define EH_MAXEVLOFF Memi[$1+8] # offset of stored MAXEVL +define EH_INDEXLEN Memi[$1+9] # length of index (same as nlines) +define EH_YOFFVOFF Memi[$1+10] # lfile offset of stored YOFFV +define EH_YOFFVLEN Memi[$1+11] # length, words, of compressed YOFFV +define EH_YLENVOFF Memi[$1+12] # lfile offset of stored YLENV +define EH_YLENVLEN Memi[$1+13] # length, words, of compressed YLENV +define EH_IXXOFF Memi[$1+14] # event offset of indexed X field +define EH_IXYOFF Memi[$1+15] # event offset of indexed Y field +define EH_IXXTYPE Memi[$1+16] # datatype of indexed X field +define EH_IXYTYPE Memi[$1+17] # datatype of indexed Y field diff --git a/sys/qpoe/qpioclose.x b/sys/qpoe/qpioclose.x new file mode 100644 index 00000000..78893487 --- /dev/null +++ b/sys/qpoe/qpioclose.x @@ -0,0 +1,49 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "qpio.h" + +# QPIO_CLOSE -- Close the QPIO descriptor. If writing to the event list, +# the output bucket is automatically flushed and the event list header updated. + +procedure qpio_close (io) + +pointer io #I QPIO descriptor + +begin + if (IO_DEBUG(io) > 1) { + call eprintf ("qpio_close (%xX)\n") + call pargi (io) + } + + call qpio_sync (io) + + if (IO_EX(io) != NULL && IO_EXCLOSE(io) == YES) + call qpex_close (IO_EX(io)) + if (IO_PL(io) != NULL && IO_PLCLOSE(io) == YES) + call pl_close (IO_PL(io)) + if (IO_FD(io) != NULL) + call close (IO_FD(io)) + + if (IO_BP(io) != NULL) + call mfree (IO_BP(io), TY_SHORT) + if (IO_RL(io) != NULL) + call mfree (IO_RL(io), TY_INT) + if (IO_MINEVL(io) != NULL) + call mfree (IO_MINEVL(io), TY_SHORT) + if (IO_MAXEVL(io) != NULL) + call mfree (IO_MAXEVL(io), TY_SHORT) + if (IO_YLENVP(io) != NULL) + call mfree (IO_YLENVP(io), TY_INT) + if (IO_YOFFVP(io) != NULL) + call mfree (IO_YOFFVP(io), TY_INT) + if (IO_DD(io) != NULL) + call mfree (IO_DD(io), TY_STRUCT) + if (IO_BBMASK(io) != NULL) + call plr_close (IO_BBMASK(io)) + if (IO_PARAM(io) != NULL) + call mfree (IO_PARAM(io), TY_CHAR) + if (IO_MASK(io) != NULL) + call mfree (IO_MASK(io), TY_CHAR) + + call mfree (io, TY_STRUCT) +end diff --git a/sys/qpoe/qpiogetev.gx b/sys/qpoe/qpiogetev.gx new file mode 100644 index 00000000..e6fbc612 --- /dev/null +++ b/sys/qpoe/qpiogetev.gx @@ -0,0 +1,467 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../qpio.h" + +define RLI_NEXTLINE 9998 +define RLI_INITIALIZE 9999 +define SZ_CODE 7 + +# QPIO_GETEVENTS -- Return a sequence of events sharing the same mask value +# which satisfy the current event attribute filter. The returned events will +# be only those in a rectangular subregion of the image (specified by a prior +# call to qpio_setrange) which are also visible through the current mask. +# Sequences of events are returned in storage order until the region is +# exhausted, at which time EOF is returned. +# +# NOTE - If debug statements (printfs) are placed in this code they will cause +# i/o problems at runtime due to reentrancy, since this routine is called in +# a low level FIO pseudodevice driver (QPF). This is also true of any of the +# routines called by this procedure, and of the related routine QPIO_READPIX. + +int procedure qpio_gvtevents (io, o_ev, maskval, maxev, o_nev) + +pointer io #I QPIO descriptor +pointer o_ev[maxev] #O receives the event struct pointers +int maskval #O receives the mask value of the events +int maxev #I max events out +int o_nev #O same as function value (nev_out|EOF) + +int status +char code[SZ_CODE] +int qpx_gvs(), qpx_gvi(), qpx_gvl(), qpx_gvr(), qpx_gvd() +errchk syserrs +define err_ 91 + +begin + # The generic routines currently require that X,Y be the same type. + # It wouldn't be hard to remove this restriction if necessary, but + # it simplifies things and I doubt if a mixed types feature would + # be used very often. + + if (IO_EVXTYPE(io) != IO_EVYTYPE(io)) + goto err_ + + # Get the events. + switch (IO_EVXTYPE(io)) { + case TY_SHORT: + status = qpx_gvs (io, o_ev, maskval, maxev, o_nev) + case TY_INT: + status = qpx_gvi (io, o_ev, maskval, maxev, o_nev) + case TY_LONG: + status = qpx_gvl (io, o_ev, maskval, maxev, o_nev) + case TY_REAL: + status = qpx_gvr (io, o_ev, maskval, maxev, o_nev) + case TY_DOUBLE: + status = qpx_gvd (io, o_ev, maskval, maxev, o_nev) + default: +err_ call sprintf (code, SZ_CODE, "%d") + call pargi (IO_EVXTYPE(io)) + call syserrs (SYS_QPINVEVT, code) + } + + return (status) +end + + +$for (silrd) + +# QPX_GV -- Internal generic code for qpio_getevents. There is one copy +# of this routine for each event coordinate datatype. The optimization +# strategy used here assumes that executing qpio_gv is much more expensive +# than building the call in qpio_getevents. This will normally be the case +# for a large event list or a complex expression, otherwise the operation +# is likely to be fast enough that it doesn't matter anyway. + +int procedure qpx_gv$t (io, o_ev, maskval, maxev, o_nev) + +pointer io #I QPIO descriptor +pointer o_ev[maxev] #O receives the event struct pointers +int maskval #O receives the mask value of the events +int maxev #I max events out +int o_nev #O same as function value (nev_out|EOF) + +int x1, x2, y1, y2, xs, xe, ys, ye, x, y +pointer pl, rl, rp, bp, ex, ev, ev_p, bbmask, bb_bufp +bool useindex, lineio, bbused, rmused, nodata +int bb_xsize, bb_ysize, bb_xblock, bb_yblock, ii, jj +int v[NDIM], szs_event, mval, nev, evidx, evtop, temp, i +int ev_xoff, ev_yoff + +pointer plr_open() +bool pl_linenotempty(), pl_sectnotempty() +int qpio_rbucket(), qpex_evaluate(), btoi(), plr_getpix() + +define swap {temp=$1;$1=$2;$2=temp} +define putevent_ 91 +define again_ 92 +define done_ 93 +define exit_ 94 + +begin + pl = IO_PL(io) # pixel list (region mask) descriptor + rl = IO_RL(io) # range list buffer + bp = IO_BP(io) # bucket buffer (type short) + ex = IO_EX(io) # QPEX (EAF) descriptor + + # The following is executed when the first i/o is performed on a new + # region, to select the most efficient type of i/o to be performed, + # and initialize the i/o parameters for that case. The type of i/o + # to be performed depends upon whether or not an index can be used, + # and whether or not there is a region mask (RM) or bounding box (BB). + # The presence or absence of an event attribute filter (EAF) is not + # separated out as a special case, as it is quick and easy to test + # for the presence of an EAF and apply one it if it exists. + + if (IO_ACTIVE(io) == NO) { + # Check for an index. We have an index if the event list is + # indexed, and the index is defined on the Y-coordinate we will + # be using for extraction. + + useindex = (IO_INDEXLEN(io) == IO_NLINES(io) && + IO_EVYOFF(io) == IO_IXYOFF(io) && + IO_NOINDEX(io) == NO) + + # Initialize the V and VN vectors. + do i = 1, NDIM { + IO_VN(io,i) = IO_VE(io,i) - IO_VS(io,i) + 1 + if (IO_VN(io,i) < 0) { + swap (IO_VS(io,i), IO_VE(io,i)) + IO_VN(io,i) = -IO_VN(io,i) + } + } + call amovi (IO_VS(io,1), IO_V(io,1), NDIM) + + # Determine if full lines are to be accessed, and if a bounding + # box (subraster of the image) is defined. + + lineio = (IO_VS(io,1) == 1 && IO_VE(io,1) == IO_NCOLS(io)) + bbused = (!lineio || IO_VS(io,2) > 1 || IO_VE(io,2) < IO_NLINES(io)) + + # Determine if region mask data is to be used and if there is any + # data to be read. + + nodata = (IO_NEVENTS(io) <= 0) + rmused = false + + if (pl != NULL) + if (pl_sectnotempty (pl, IO_VS(io,1), IO_VE(io,1), NDIM)) + rmused = true + else + nodata = true + + # Select the optimal type of i/o to be used for extraction. + if (nodata) { + IO_IOTYPE(io) = NoDATA_NoAREA + useindex = false + bbused = false + + } else if (bbused || rmused) { + if (useindex) + IO_IOTYPE(io) = INDEX_RMorBB + else + IO_IOTYPE(io) = NoINDEX_RMorBB + + } else { + # If we are reading the entire image (no bounding box) and + # we are not using a mask, then there is no point in using + # indexed i/o. + + IO_IOTYPE(io) = NoINDEX_NoRMorBB + useindex = false + } + + # Initialize the range list data if it will be used. + if (useindex) { + # Dummy range specifying full line segment. + RLI_LEN(rl) = RL_FIRST + RLI_AXLEN(rl) = IO_NCOLS(io) + + rp = rl + ((RL_FIRST - 1) * RL_LENELEM) + Memi[rp+RL_XOFF] = IO_VS(io,1) + Memi[rp+RL_NOFF] = IO_VN(io,1) + Memi[rp+RL_VOFF] = 1 + + IO_RLI(io) = RLI_INITIALIZE + } + + # Open the mask for random access if i/o is not indexed and + # a region mask is used. + + bbmask = IO_BBMASK(io) + if (bbmask != NULL) + call plr_close (bbmask) + + if (IO_IOTYPE(io) == NoINDEX_RMorBB && rmused) { + bbmask = plr_open (pl, v, 0) # (v is never referenced) + call plr_setrect (bbmask, IO_VS(io,1),IO_VS(io,2), + IO_VE(io,1),IO_VE(io,2)) + call plr_getlut (bbmask, + bb_bufp, bb_xsize, bb_ysize, bb_xblock, bb_yblock) + } + + # Update the QPIO descriptor. + IO_LINEIO(io) = btoi(lineio) + IO_RMUSED(io) = btoi(rmused) + IO_BBUSED(io) = btoi(bbused) + IO_BBMASK(io) = bbmask + + IO_EVI(io) = 1 + IO_BKNO(io) = 0 + IO_BKLASTEV(io) = 0 + + IO_ACTIVE(io) = YES + } + + # Initialize event extraction parameters. + szs_event = IO_EVENTLEN(io) + maskval = 0 + nev = 0 + + ev_xoff = IO_EVXOFF(io) + ev_yoff = IO_EVYOFF(io) + + # Extract events using the most efficient type of i/o for the given + # selection critera (index, mask, BB, EAF, etc.). +again_ + switch (IO_IOTYPE(io)) { + case NoDATA_NoAREA: + # We know in advance that there are no events to be returned, + # either because there is no data, or the area of the region + # mask within the bounding box is empty. + + goto exit_ + + case NoINDEX_NoRMorBB: + # This is the simplest case; no index, region mask, or bounding + # box. Read and output all events in sequence. + + # Refill the event bucket? + if (IO_EVI(io) > IO_BKLASTEV(io)) + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Copy out the event pointers. + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io)) * szs_event + nev = min (maxev, IO_BKLASTEV(io) - IO_EVI(io) + 1) + + do i = 1, nev { + o_ev[i] = ev + ev = ev + szs_event + } + + IO_EVI(io) = IO_EVI(io) + nev + maskval = 1 + + case NoINDEX_RMorBB: + # Fully general selection, including any combination of bounding + # box, region mask, or EAF, but no index, either because there is + # no index for this event list, or the index is for a different Y + # attribute than the one being used for extraction. + + bbused = (IO_BBUSED(io) == YES) + x1 = IO_VS(io,1); x2 = IO_VE(io,1) + y1 = IO_VS(io,2); y2 = IO_VE(io,2) + + # Refill the event bucket? + while (IO_EVI(io) > IO_BKLASTEV(io)) { + # Get the next bucket. + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Reject buckets that do not contain any events lying + # within the specified bounding box, if any. + + if (bbused) { + ev_p = (IO_MINEVB(io) - 1) * SZ_SHORT / SZ_PIXEL + 1 + $if (datatype == rd) + xs = Mem$t[ev_p+ev_xoff] + 0.5 + ys = Mem$t[ev_p+ev_yoff] + 0.5 + $else + xs = Mem$t[ev_p+ev_xoff] + ys = Mem$t[ev_p+ev_yoff] + $endif + + ev_p = (IO_MAXEVB(io) - 1) * SZ_SHORT / SZ_PIXEL + 1 + $if (datatype == rd) + xe = Mem$t[ev_p+ev_xoff] + 0.5 + ye = Mem$t[ev_p+ev_yoff] + 0.5 + $else + xe = Mem$t[ev_p+ev_xoff] + ye = Mem$t[ev_p+ev_yoff] + $endif + + if (xs > x2 || xe < x1 || ys > y2 || ye < y1) + IO_EVI(io) = IO_BKLASTEV(io) + 1 + } + } + + # Copy out any events which pass the region mask and which share + # the same mask value. Note that in this case, to speed mask + # value lookup at random mask coordinates, the region mask for + # the bounding box is stored as a populated array in the QPIO + # descriptor. + + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io) - 1) * szs_event + bbmask = IO_BBMASK(io) + mval = 0 + + do i = IO_EVI(io), IO_BKLASTEV(io) { + # Get event x,y coordinates in whatever coord system. + ev = ev + szs_event + ev_p = (ev - 1) * SZ_SHORT / SZ_PIXEL + 1 + + $if (datatype == rd) + x = Mem$t[ev_p+ev_xoff] + 0.5 + y = Mem$t[ev_p+ev_yoff] + 0.5 + $else + x = Mem$t[ev_p+ev_xoff] + y = Mem$t[ev_p+ev_yoff] + $endif + + # Reject events lying outside the bounding box. + if (bbused) + if (x < x1 || x > x2 || y < y1 || y > y2) + next + + # Take a shortcut if no region mask is in effect for this BB. + if (bbmask == NULL) + goto putevent_ + + # Get the mask pixel associated with this event. + ii = (x - 1) / bb_xblock + jj = (y - 1) / bb_yblock + mval = Memi[bb_bufp + jj*bb_xsize + ii] + if (mval < 0) + mval = plr_getpix (bbmask, x, y) + + # Accumulate points lying in the first nonzero mask range + # encountered. + + if (mval != 0) { + if (maskval == 0) + maskval = mval + if (mval == maskval) { +putevent_ if (nev >= maxev) + break + nev = nev + 1 + o_ev[nev] = ev + } else + break + } + } + + IO_EVI(io) = i + + case INDEX_NoRMorBB, INDEX_RMorBB: + # General extraction for indexed data. Process successive ranges + # and range lists until we get at least one event which lies within + # the bounding box, within a range, and which passes the event + # attribute filter, if one is in use. + + # If the current range list (mask line) has been exhausted, advance + # to the next line which contains both ranges and events. A range + # list is used to specify the bounding box even if we don't have + # a nonempty region mask within the BB. + + if (IO_RLI(io) > RLI_LEN(rl)) { + repeat { + y = IO_V(io,2) + if (IO_RLI(io) == RLI_INITIALIZE) + IO_RLI(io) = RL_FIRST + else + y = y + 1 + + if (y > IO_VE(io,2)) { + if (nev <= 0) { + o_nev = EOF + return (EOF) + } else + goto done_ + } + + IO_V(io,2) = y + evidx = Memi[IO_YOFFVP(io)+y-1] + + if (evidx > 0) { + if (IO_RMUSED(io) == YES) { + if (IO_LINEIO(io) == YES) { + if (!pl_linenotempty (pl,IO_V(io,1))) + next + } else { + v[1] = IO_VE(io,1); v[2] = y + if (!pl_sectnotempty (pl,IO_V(io,1),v,NDIM)) + next + } + call pl_glri (pl, IO_V(io,1), Memi[rl], + IO_MDEPTH(io), IO_VN(io,1), PIX_SRC) + } + IO_RLI(io) = RL_FIRST + } + } until (IO_RLI(io) <= RLI_LEN(rl)) + + IO_EVI(io) = evidx + IO_EV1(io) = evidx + IO_EV2(io) = Memi[IO_YLENVP(io)+y-1] + evidx - 1 + } + + # Refill the event bucket? + if (IO_EVI(io) > IO_BKLASTEV(io)) + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + goto exit_ + + # Compute current range parameters and initialize event pointer. + rp = rl + (IO_RLI(io) - 1) * RL_LENELEM + x1 = Memi[rp+RL_XOFF] + x2 = x1 + Memi[rp+RL_NOFF] - 1 + maskval = Memi[rp+RL_VOFF] + + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io)) * szs_event + evtop = min (IO_EV2(io), IO_BKLASTEV(io)) + + # Extract events from bucket which lie within the current range + # of the current line. This is the inner loop of indexed event + # extraction, ignoring event attribute filtering. + + do i = IO_EVI(io), evtop { + ev_p = (ev - 1) * SZ_SHORT / SZ_PIXEL + 1 + $if (datatype == rd) + x = Mem$t[ev_p+ev_xoff] + 0.5 + $else + x = Mem$t[ev_p+ev_xoff] + $endif + if (x >= x1) { + if (x > x2) { + IO_RLI(io) = IO_RLI(io) + 1 + break + } else if (nev >= maxev) + break + nev = nev + 1 + o_ev[nev] = ev + } + ev = ev + szs_event + } + + IO_EVI(io) = i + if (i > IO_EV2(io)) + IO_RLI(io) = RLI_NEXTLINE + } +done_ + # Apply the event attribute filter if one is defined; repeat + # the whole process if we don't end up with any events. + + if (nev > 0) + if (ex != NULL) + nev = qpex_evaluate (ex, o_ev, o_ev, nev) + if (nev <= 0) + goto again_ +exit_ + o_nev = nev + if (o_nev <= 0) + o_nev = EOF + + return (o_nev) +end + +$endfor diff --git a/sys/qpoe/qpiogetfil.x b/sys/qpoe/qpiogetfil.x new file mode 100644 index 00000000..c653f6b5 --- /dev/null +++ b/sys/qpoe/qpiogetfil.x @@ -0,0 +1,123 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpoe.h" +include "qpio.h" + +# QPIO_GETFILTER -- Get the current filtering parameters governing event +# extraction via QPIO. These are the QPIO parameters (region mask, blocking +# factor, coordinate system, etc.) plus the event attribute filter. We leave +# it up to QPEX to reconstruct the EAF to allow for any dynamic edits which +# may have taken place, e.g., via qpio_setfilter. + +int procedure qpio_getfilter (io, outstr, maxch) + +pointer io #I QPIO descriptor +char outstr[maxch] #O where to put the filter text +int maxch #I max chars out + +pointer sp, buf, bp +int op, dtype[2], offset[2], i +int sizeof(), gstrcpy(), qpex_getfilter() +define ovfl_ 91 + +begin + call smark (sp) + call salloc (buf, SZ_TEXTBUF, TY_CHAR) + + op = 1 + + # Report on QPIO parameters first. + + # Parameter name. + call sprintf (Memc[buf], SZ_TEXTBUF, "param=%s,") + call pargstr (Memc[IO_PARAM(io)]) + op = op + gstrcpy (Memc[buf], outstr[op], maxch-op+1) + if (op > maxch) + goto ovfl_ + + # Coordinate system. + dtype[1] = IO_EVXTYPE(io); dtype[2] = IO_EVYTYPE(io) + offset[1] = IO_EVXOFF(io); offset[2] = IO_EVYOFF(io) + + call sprintf (Memc[buf], SZ_TEXTBUF, "key=(%c%d,%c%d),") + do i = 1, 2 { + switch (dtype[i]) { + case TY_SHORT: + call pargi ('s') + case TY_INT: + call pargi ('i') + case TY_LONG: + call pargi ('l') + case TY_REAL: + call pargi ('r') + case TY_DOUBLE: + call pargi ('d') + default: + call pargi ('?') + } + + call pargi (offset[i] * sizeof(dtype[i]) * SZB_CHAR) + } + + op = op + gstrcpy (Memc[buf], outstr[op], maxch-op+1) + if (op > maxch) + goto ovfl_ + + # Blocking factor for generating pixels. + call sprintf (Memc[buf], SZ_TEXTBUF, "block=%0.4gx%0.4g, ") + call pargr (IO_XBLOCK(io)) + call pargr (IO_YBLOCK(io)) + op = op + gstrcpy (Memc[buf], outstr[op], maxch-op+1) + if (op > maxch) + goto ovfl_ + + # Region mask, if any. + if (Memc[IO_MASK(io)] != EOS) { + call sprintf (Memc[buf], SZ_TEXTBUF, "mask=%s,") + call pargstr (Memc[IO_MASK(io)]) + op = op + gstrcpy (Memc[buf], outstr[op], maxch-op+1) + if (op > maxch) + goto ovfl_ + } + + # Debug level, if debug messages enabled. + if (IO_DEBUG(io) > 0) { + call sprintf (Memc[buf], SZ_TEXTBUF, "debug=%d,") + call pargi (IO_DEBUG(io)) + op = op + gstrcpy (Memc[buf], outstr[op], maxch-op+1) + if (op > maxch) + goto ovfl_ + } + + # Noindex flag, if enabled. + if (IO_NOINDEX(io) > 0) { + call sprintf (Memc[buf], SZ_TEXTBUF, "noindex=%b,") + call pargi (IO_NOINDEX(io)) + op = op + gstrcpy (Memc[buf], outstr[op], maxch-op+1) + if (op > maxch) + goto ovfl_ + } + + # Event attribute filter. + if (IO_EX(io) != NULL) { + bp = buf + gstrcpy ("filter=(", Memc[buf], SZ_TEXTBUF) + bp = bp + qpex_getfilter (IO_EX(io), Memc[bp], SZ_TEXTBUF-8) + Memc[bp] = ')'; bp = bp + 1 + Memc[bp] = EOS + op = op + gstrcpy (Memc[buf], outstr[op], maxch-op+1) + if (op > maxch) + goto ovfl_ + } else if (op > 1) { + # Clobber trailing comma. + op = op - 1 + outstr[op] = EOS + } + + call sfree (sp) + return (op - 1) +ovfl_ + call sfree (sp) + outstr[maxch+1] = EOS + return (maxch) +end diff --git a/sys/qpoe/qpiogetrg.x b/sys/qpoe/qpiogetrg.x new file mode 100644 index 00000000..bc2b0272 --- /dev/null +++ b/sys/qpoe/qpiogetrg.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "qpio.h" + +# QPIO_GETRANGE -- Get the current range in X and Y within which events will +# be extracted by qpio_getevents. + +int procedure qpio_getrange (io, vs, ve, maxdim) + +pointer io #I QPIO descriptor +int vs[ARB] #O start vector (lower left corner) +int ve[ARB] #O end vector (upper right corner) +int maxdim #I vector length (ndim=2 at present) + +begin + call amovi (IO_VS(io,1), vs, maxdim) + call amovi (IO_VE(io,1), ve, maxdim) + return (NDIM) +end diff --git a/sys/qpoe/qpiolmask.x b/sys/qpoe/qpiolmask.x new file mode 100644 index 00000000..979de478 --- /dev/null +++ b/sys/qpoe/qpiolmask.x @@ -0,0 +1,119 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "qpoe.h" +include "qpio.h" + +# QPIO_LOADMASK -- Load the named region mask into the QPIO descriptor. +# The mask name may be the name of a header parameter containing the mask +# as the stored array value (TY_OPAQUE parameter), the name of a header +# parameter containing the name of the mask (TY_CHAR), or the name of a +# mask storage file (.pl extension). + +procedure qpio_loadmask (io, mask, merge) + +pointer io #I QPIO descriptor +char mask[ARB] #I mask to be loaded +int merge #I merge with old mask? + +int niter +int naxes, axlen[PL_MAXDIM], v[PL_MAXDIM] +pointer sp, title, mp, sym, plbuf, qp, o_pl, n_pl, b_pl + +pointer pl_open(), qp_gpsym() +int strmatch(), qp_accessf(), qp_read(), qp_gstr() +errchk pl_open, pl_close, pl_loadf, qp_read, syserrs, qp_gstr, malloc +define tryfile_ 91 + +begin + call smark (sp) + call salloc (title, SZ_FNAME, TY_CHAR) + call salloc (mp, SZ_FNAME, TY_CHAR) + + if (IO_DEBUG(io) > 0) { + call eprintf ("load mask `%s'\n") + call pargstr (mask) + } + + qp = IO_QP(io) + o_pl = IO_PL(io) + call strcpy (mask, Memc[mp], SZ_FNAME) + + # Open new mask. + for (niter=0; Memc[mp] != EOS; niter=niter+1) { + if (strmatch (Memc[mp], ".pl$") > 0) { + # Mask is stored in a file. +tryfile_ + n_pl = pl_open (NULL) + call pl_loadf (n_pl, Memc[mp], Memc[title], SZ_FNAME) + + } else if (qp_accessf (qp, Memc[mp]) == YES) { + # Named parameter contains or points to mask. + + sym = qp_gpsym (qp, Memc[mp]) + if (S_DTYPE(sym) == TY_OPAQUE) { + # Parameter value is stored mask. + call salloc (plbuf, S_NELEM(sym) / SZ_SHORT, TY_SHORT) + if (qp_read (qp, Memc[mp], Mems[plbuf], S_NELEM(sym), 1, + "opaque") < S_NELEM(sym)) { + call syserrs (SYS_QPBADVAL, Memc[mp]) + } else { + n_pl = pl_open (plbuf) # no deref + } + + } else if (S_DTYPE(sym) == TY_CHAR) { + # Parameter value is pointer to mask. + if (qp_gstr (qp, Memc[mp], Memc[mp], SZ_FNAME) > 0) { + if (niter < MAX_INDIR) + next + else + call syserrs (SYS_QPMRECUR, Memc[mp]) + } + } else + goto tryfile_ + } else + goto tryfile_ + + break + } + + # Check that mask and image are the same size, and get mask depth. + call pl_gsize (n_pl, naxes, axlen, IO_MDEPTH(io)) + if (axlen[1] != IO_NCOLS(io) || axlen[2] != IO_NLINES(io)) + call syserrs (SYS_QPPLSIZE, Memc[mp]) + + # Merge the old and new mask if so indicated. The result mask is the + # same as the new mask, but only those pixels also present (nonzero) + # in the old mask are preserved. + + if (merge == YES && o_pl != NULL) { + b_pl = pl_open (NULL) + call amovkl (1, v, PL_MAXDIM) + call pl_ssize (b_pl, naxes, axlen, 1) + call pl_rop (o_pl, v, b_pl, v, axlen, PIX_SRC) + call pl_rop (b_pl, v, n_pl, v, axlen, and(PIX_SRC,PIX_DST)) + call pl_close (b_pl) + } + + # Close old mask, if any. + if (IO_PL(io) != NULL && IO_PLCLOSE(io) == YES) + call pl_close (IO_PL(io)) + + # Install new mask. + IO_PL(io) = n_pl + IO_PLCLOSE(io) = YES + call strcpy (Memc[mp], Memc[IO_MASK(io)], SZ_FNAME) + + # Allocate a range list buffer if i/o is indexed. + if (IO_INDEXLEN(io) > 0) { + if (IO_RL(io) != NULL) + call mfree (IO_RL(io), TY_INT) + if (IO_PL(io) != NULL) + call malloc (IO_RL(io), RL_MAXLEN(IO_PL(io)), TY_INT) + else + call malloc (IO_RL(io), RL_LENELEM*2, TY_INT) + } + + call sfree (sp) +end diff --git a/sys/qpoe/qpiolwcs.x b/sys/qpoe/qpiolwcs.x new file mode 100644 index 00000000..76c1650f --- /dev/null +++ b/sys/qpoe/qpiolwcs.x @@ -0,0 +1,50 @@ +include "qpio.h" + +# QPIO_LOADWCS -- Load the WCS, if any, from the QPOE file associated with the +# given QPIO descriptor, into an open MWCS descriptor. This is equivalent to +# QP_LOADWCS except that the Lterm is updated to reflect the current blocking +# factor and rect (if any) used for rasterization. In the resultant WCS, the +# logical coordinate system gives the pixel coordinates of the sampled rect. + +pointer procedure qpio_loadwcs (io) + +pointer io #I QPIO descriptor + +pointer qp, mw +int ndim, i, j +double ltv_1[NDIM], ltv_2[NDIM], ltm[NDIM,NDIM] +pointer qp_loadwcs() +errchk qp_loadwcs + +begin + qp = IO_QP(io) + mw = qp_loadwcs (qp) + ndim = NDIM + + # Formalize the transformation. + ltv_1[1] = IO_VSDEF(io,1) - 1 + ltv_1[2] = IO_VSDEF(io,2) - 1 + + # L(i) :== LTM=(1 / block) * P(i) + Vx + # At pixel {P(i) :== (block + 1) / 2} L(i) is 1.0. + # Solve for Vx :== 1.0 - (1 / block) * ((block + 1) / 2) + # --> 0.5 - 1 / (2 * block) + + ltv_2[1] = 0.5d0 - 1.0d0 / double (max (1.0, IO_XBLOCK(io))) / 2.0d0 + ltv_2[2] = 0.5d0 - 1.0d0 / double (max (1.0, IO_YBLOCK(io))) / 2.0d0 + + do j = 1, ndim + do i = 1, ndim + if (i == j) { + if (i == 1) + ltm[i,j] = 1.0D0 / max (1.0, IO_XBLOCK(io)) + else + ltm[i,j] = 1.0D0 / max (1.0, IO_YBLOCK(io)) + } else + ltm[i,j] = 0 + + # Apply the transformation. + call mw_translated (mw, ltv_1, ltm, ltv_2, ndim) + + return (mw) +end diff --git a/sys/qpoe/qpiomkidx.x b/sys/qpoe/qpiomkidx.x new file mode 100644 index 00000000..979b1142 --- /dev/null +++ b/sys/qpoe/qpiomkidx.x @@ -0,0 +1,299 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "qpoe.h" +include "qpio.h" + +define SZ_CODE 7 + + +# QPIO_MKINDEX -- Make an index for the event list associated with the QPIO +# descriptor. The event list must have been already written out, in sorted +# order according to the given key. Once an event list is indexed it cannot +# be further extended or otherwise modified. The key fields are specified +# as, e.g., "s10,s8" or "(s10,s8)" (Y // X), where the field name is the +# datatype code (silrd for short, int, long, real, or double) followed by the +# decimal byte offset of the field in the event struct. + +procedure qpio_mkindex (io, key) + +pointer io #I QPIO descriptor +char key[ARB] #I list of key fields + +pointer sp, tokbuf, ip, in, ev, ev_p, ov, lv, oo, bp +int ox, line, nevents, szs_event, ncols, nlines, nout, x, y, i, ch +int token, offset, xoff, yoff, len_index, nev, fd, sv_evi, firstev +int dtype, ntype + +long note() +pointer qp_opentext() +int qp_gettok(), ctoi(), qpio_rbucket(), pl_p2li(), sizeof() +errchk qp_opentext, qpio_rbucket, qpio_sync, write, calloc, syserrs +define nosort_ 91 + +begin + call smark (sp) + call salloc (tokbuf, SZ_TOKBUF, TY_CHAR) + call malloc (oo, IO_NLINES(io) * 3 + 32, TY_SHORT) + + ncols = IO_NCOLS(io) + nlines = IO_NLINES(io) + sv_evi = IO_EVI(io) + + # Key defaults to sort x/y. + xoff = IO_EVXOFF(io) + yoff = IO_EVYOFF(io) + dtype = IO_EVXTYPE(io) + + # Parse key list (macro references are permitted) to get offsets of + # the X and Y coordinate fields to be used as the index key. + + in = qp_opentext (IO_QP(io), key) + + do i = 1, 2 { + # Get next field token. + repeat { + token = qp_gettok (in, Memc[tokbuf], SZ_TOKBUF) + } until (token == EOF || token == TOK_IDENTIFIER) + if (token == EOF) + break + + # Determine field type. + call strlwr (Memc[tokbuf]) + ch = Memc[tokbuf] + + switch (ch) { + case 's': + ntype = TY_SHORT + case 'i': + ntype = TY_INT + case 'l': + ntype = TY_LONG + case 'r': + ntype = TY_REAL + case 'd': + ntype = TY_DOUBLE + default: + call syserrs (SYS_QPXYFNS, key) + } + + # Both X and Y must be the same type. + if (i == 1) + dtype = ntype + else if (ntype != dtype) + call syserrs (SYS_QPINVEVT, key) + + ip = tokbuf + 1 + if (ctoi (Memc, ip, offset) <= 0) + call syserrs (SYS_QPBADKEY, key) + else + offset = offset / (sizeof(dtype) * SZB_CHAR) + + if (i == 1) + yoff = offset + else + xoff = offset + + while (qp_gettok (in, Memc[tokbuf], SZ_TOKBUF) != EOF) + if (Memc[tokbuf] == ',') + break + } + + call qp_closetext (in) + + # Sync the event list to ensure that the bucket is flushed. + call qpio_sync (io) + + fd = IO_FD(io) + bp = IO_BP(io) + len_index = nlines + szs_event = IO_EVENTLEN(io) + + if (IO_DEBUG(io) > 1) { + call eprintf ("qpio_mkindex (%xX, `%s')\n") + call pargi (io) + call pargstr (key) + call eprintf ("nevents=%d, evsize=%d, xkey=%c%d, ykey=%c%d\n") + call pargi (IO_NEVENTS(io)) + call pargi (szs_event) + call pargi (ch) + call pargi (xoff) + call pargi (ch) + call pargi (yoff) + } + + # Allocate the offset and length vectors (comprising the index). + # These are deallocated at qpio_close time. + + call calloc (ov, len_index, TY_INT) + call calloc (lv, len_index, TY_INT) + + ox = -1 + line = 1 + firstev = 1 + nevents = 0 + + # Rewind the list. + i = qpio_rbucket (io, 1) + + # For each event in the event list... + for (IO_EVI(io)=1; IO_EVI(io) <= IO_NEVENTS(io); ) { + # Refill the event bucket? + if (IO_EVI(io) > IO_BKLASTEV(io)) + if (qpio_rbucket (io, IO_EVI(io)) == EOF) + break + + # Process all events in the bucket. + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io)) * szs_event + nev = min (IO_NEVENTS(io), IO_BKLASTEV(io)) - IO_EVI(io) + 1 + nout = 0 + + do i = 1, nev { + ev_p = (ev - 1) * SZ_SHORT / sizeof(dtype) + 1 + + switch (dtype) { + case TY_SHORT: + x = Mems[ev_p+xoff] + y = Mems[ev_p+yoff] + case TY_INT: + x = Memi[ev_p+xoff] + y = Memi[ev_p+yoff] + case TY_LONG: + x = Meml[ev_p+xoff] + y = Meml[ev_p+yoff] + case TY_REAL: + x = Memr[ev_p+xoff] + 0.5 + y = Memr[ev_p+yoff] + 0.5 + case TY_DOUBLE: + x = Memd[ev_p+xoff] + 0.5 + y = Memd[ev_p+yoff] + 0.5 + } + + x = max(1, min(ncols, x)) + y = max(1, min(nlines, y)) + + if (IO_DEBUG(io) > 4) { + # Egads! Dump every photon. + call eprintf ("(%04d,%04d) ") + call pargi (x) + call pargi (y) + nout = nout + 1 + if (nout >= 6) { + call eprintf ("\n") + nout = 0 + } + } + + if (y > line) { + # Add index entry. + if (nevents > 0) { + Memi[ov+line-1] = firstev + Memi[lv+line-1] = nevents + + if (IO_DEBUG(io) > 3 && nevents > 0) { + if (nout > 0) { + call eprintf ("\n") + nout = 0 + } + call eprintf ("%4d: ev=%d, nev=%d\n") + call pargi (line) + call pargi (firstev) + call pargi (nevents) + } + } + + # Set up the new line. + firstev = IO_EVI(io) + i - 1 + nevents = 1 + line = y + ox = x + + } else if (y == line) { + # Add another event to the current line. + nevents = nevents + 1 + if (x < ox) + goto nosort_ + else + ox = x + } else + goto nosort_ + + ev = ev + szs_event + } + + IO_EVI(io) = IO_EVI(io) + nev + if (nout > 0) { + call eprintf ("\n") + nout = 0 + } + } + + # Output final index entry. + if (nevents > 0) { + Memi[ov+line-1] = firstev + Memi[lv+line-1] = nevents + } + + # Apply data compression to the index arrays and append to the event + # list lfile. + + call fseti (fd, F_BUFSIZE, len_index * SZ_INT) + call seek (fd, EOF) + + IO_YOFFVOFF(io) = note (fd) + IO_YOFFVLEN(io) = pl_p2li (Memi[ov], 1, Mems[oo], len_index) + call write (fd, Mems[oo], IO_YOFFVLEN(io) * SZ_SHORT) + + IO_YLENVOFF(io) = note (fd) + IO_YLENVLEN(io) = pl_p2li (Memi[lv], 1, Mems[oo], len_index) + call write (fd, Mems[oo], IO_YLENVLEN(io) * SZ_SHORT) + + call flush (fd) + call fseti (fd, F_BUFSIZE, 0) + + # Update the remaining index related fields of the QPIO descriptor. + IO_INDEXLEN(io) = len_index + IO_YOFFVP(io) = ov + IO_YLENVP(io) = lv + + IO_IXXOFF(io) = xoff + IO_IXYOFF(io) = yoff + IO_IXXTYPE(io) = dtype + IO_IXYTYPE(io) = dtype + + if (IO_DEBUG(io) > 1) { + call eprintf ("index.offv %d words at offset %d\n") + call pargi (IO_YOFFVLEN(io)) + call pargi (IO_YOFFVOFF(io)) + call eprintf ("index.lenv %d words at offset %d\n") + call pargi (IO_YLENVLEN(io)) + call pargi (IO_YLENVOFF(io)) + } + + # Update the event list header. + call qpio_sync (io) + + IO_EVI(io) = sv_evi + call sfree (sp) + return + +nosort_ + # A nonsorted event list has been detected, hence we cannot build + # an index, but we need not abort since nonindexed event lists are + # still usable. + + if (nout > 0) + call eprintf ("\n") + iferr (call syserrs (SYS_QPEVNSORT, Memc[IO_PARAM(io)])) + call erract (EA_WARN) + + IO_INDEXLEN(io) = 0 + call mfree (ov, TY_INT) + call mfree (lv, TY_INT) + + IO_EVI(io) = sv_evi + call sfree (sp) +end diff --git a/sys/qpoe/qpioopen.x b/sys/qpoe/qpioopen.x new file mode 100644 index 00000000..4ed8a711 --- /dev/null +++ b/sys/qpoe/qpioopen.x @@ -0,0 +1,392 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include "qpoe.h" +include "qpex.h" +include "qpio.h" + +# QPIO_OPEN -- Open the named event list parameter for event i/o. Since event +# lists can only be read and written sequentially, there are only two useful +# i/o modes, namely, READ_ONLY and NEW_FILE. Filtering is permitted only +# when reading an event list; when writing to a new event list, the events +# are merely copied out as they are received. + +pointer procedure qpio_open (qp, paramex, mode) + +pointer qp #I QPOE descriptor +char paramex[ARB] #I event-list parameter plus expression list +int mode #I access mode + +bool newlist +pointer sp, io, dd, eh, op, oo, flist, deffilt, defmask, maskname +pointer param, expr, filter, filter_text, mask, umask, psym, dsym, name +int sz_filter, szb_page, nwords, nchars, junk, fd, ip, i, j + +pointer qp_gpsym(), qpex_open(), stname(), strefstab() +int qp_popen(), qp_lenf(), read(), pl_l2pi(), fstati() +int qp_geti(), qp_gstr(), qp_parsefl(), qpio_parse(), qpex_modfilter() + +errchk qp_bind, qp_geti, qpio_parse, qp_gpsym, qp_addf, qp_gstr +errchk qp_parsefl, qp_popen, qpex_open, qpio_loadmask, qpex_modfilter +errchk stname, calloc, malloc, realloc, read, syserrs +string s_deffilt DEF_FILTER +string s_defmask DEF_MASK +define done_ 91 + +begin + call smark (sp) + call salloc (deffilt, SZ_FNAME, TY_CHAR) + call salloc (defmask, SZ_FNAME, TY_CHAR) + call salloc (maskname, SZ_FNAME, TY_CHAR) + call salloc (umask, SZ_FNAME, TY_CHAR) + + if (QP_ACTIVE(qp) == NO) + call qp_bind (qp) + + newlist = (mode == NEW_FILE || mode == APPEND) + + if (QP_DEBUG(qp) > 0) { + call eprintf ("qpio_open (%xX, `%s', %d)\n") + call pargi (qp) + call pargstr (paramex) + call pargi (mode) + } + + # Allocate and initialize the QPIO descriptor. + call calloc (io, LEN_IODES, TY_STRUCT) + + call calloc (IO_DD(io), LEN_DDDES, TY_STRUCT) + call calloc (IO_PARAM(io), SZ_FNAME, TY_CHAR) + call calloc (IO_MASK(io), SZ_FNAME, TY_CHAR) + + IO_QP(io) = qp + IO_MODE(io) = mode + IO_DEBUG(io) = QP_DEBUG(qp) + IO_XBLOCK(io) = QP_XBLOCK(qp) + IO_YBLOCK(io) = QP_YBLOCK(qp) + IO_NODEFFILT(io) = QP_NODEFFILT(qp) + IO_NODEFMASK(io) = QP_NODEFMASK(qp) + IO_OPTBUFSIZE(io) = QP_OPTBUFSIZE(qp) + IO_ACTIVE(io) = NO + + dd = IO_DD(io) + param = IO_PARAM(io) + mask = IO_MASK(io) + filter = NULL + +iferr { + # Get the image dimensions. + IO_NCOLS(io) = qp_geti (qp, "axlen[1]") + IO_NLINES(io) = qp_geti (qp, "axlen[2]") + + # Parse the parameter expression into the parameter name and + # expression qualifier fields. Possible variations on the input + # syntax are "" (null string, default everything), "param" (parameter + # name only), "param[expr]" (parameter name plus expression), and + # "[expr]" or "expr" (expression only), where the parameter name may + # be specified as in "[param=value,...]", i.e., as a term in the + # expression (allowing it to be input by the user to override the + # default). + + op = param + for (ip=1; paramex[ip] != EOS && paramex[ip] != '['; ip=ip+1) { + Memc[op] = paramex[ip] + op = op + 1 + } + expr = ip + + # Parse the expression qualifier field to set the i/o parameters, + # e.g., region mask, event attribute filter, blocking factor, + # coordinate system, etc. All QPIO parameters are removed, returning + # the filter expression (if any) to be passed on to QPEX for event + # attribute filtering. The `filter' buffer is passed by pointer so + # that it may be reallocated if more space is needed. + + sz_filter = DEF_SZEXPRBUF + call malloc (filter, sz_filter, TY_CHAR) + if (qpio_parse (io, paramex[expr], + filter, sz_filter, Memc[mask], SZ_FNAME) == ERR) + call eprintf ("QPIO warning: error parsing options expression\n") + + # If no event list parameter was named, use the default. + if (Memc[param] == EOS) + call strcpy (DEF_EVENTPARAM, Memc[param], SZ_FNAME) + + # Verify the parameter's type if it already exists, or create a new + # parameter of the default type if the mode is newfile or append. + + psym = qp_gpsym (qp, Memc[param]) + if (psym != NULL) { + if (S_DTYPE(psym) != TY_USER || S_DSYM(psym) == NULL) + call syserrs (SYS_QPNEVPAR, Memc[param]) + else if (newlist && S_NELEM(psym) > 0) + call syserrs (SYS_QPCLOBBER, Memc[param]) + } else if (mode == READ_ONLY) { + call syserrs (SYS_QPUKNPAR, Memc[param]) + } else { + call qp_addf (qp, Memc[param], DEF_EVENTTYPE, 0, "", 0) + psym = qp_gpsym (qp, Memc[param]) + } + + # Get the field list for the user defined event structure. This + # defines the size of an event struct, lists the offset and type + # of each field, and indicates which fields are to be used for X + # and Y in positional accesses (unless already set in the paramex). + + dsym = strefstab (QP_ST(qp), S_DSYM(psym)) + nchars = S_NELEM(dsym) + name = stname (QP_ST(qp), dsym) + + call salloc (flist, nchars, TY_CHAR) + if (qp_gstr (qp, Memc[name], Memc[flist], nchars) < nchars) + call syserrs (SYS_QPBADVAL, Memc[name]) + + if (qp_parsefl (qp, Memc[flist], IO_DD(io)) <= 0) + call syserrs (SYS_QPINVDD, Memc[name]) + else if (IO_EVXOFF(io) == NULL && IO_EVYOFF(io) == NULL) { + i = DD_XFIELD(dd) + j = DD_YFIELD(dd) + if (i == 0 || j == 0) + call syserrs (SYS_QPNOXYF, Memc[name]) + + switch (DD_FTYPE(dd,i)) { + case TY_SHORT, TY_INT, TY_LONG, TY_REAL, TY_DOUBLE: + IO_EVXTYPE(io) = DD_FTYPE(dd,i) + default: + call syserrs (SYS_QPXYFNS, Memc[name]) + } + + switch (DD_FTYPE(dd,j)) { + case TY_SHORT, TY_INT, TY_LONG, TY_REAL, TY_DOUBLE: + IO_EVYTYPE(io) = DD_FTYPE(dd,j) + default: + call syserrs (SYS_QPXYFNS, Memc[name]) + } + + IO_EVXOFF(io) = DD_FOFFSET(dd,i) + IO_EVYOFF(io) = DD_FOFFSET(dd,j) + } + + IO_EVENTLEN(io) = DD_STRUCTLEN(dd) * SZ_STRUCT / SZ_SHORT + + # Open the lfile used to store the event list. + IO_FD(io) = qp_popen (qp, Memc[param], mode, BINARY_FILE) + IO_LF(io) = S_LFILE(psym) + IO_CHAN(io) = fstati (IO_FD(io), F_CHANNEL) + IO_PSYM(io) = psym + + # The rest of the initialization is performed in the first call to + # qpio_putev if we are writing a new event list. + + if (newlist) # EXIT if new event list + goto done_ # ----------------------- + + fd = IO_FD(io) + szb_page = QP_FMPAGESIZE(qp) + nchars = szb_page / SZB_CHAR + call salloc (eh, szb_page / (SZ_STRUCT*SZB_CHAR), TY_STRUCT) + call aclri (Memi[eh], szb_page / (SZ_STRUCT*SZB_CHAR)) + + # Read event list header. + if (read (fd, Memi[eh], nchars) < nchars) + call syserrs (SYS_QPNOEH, Memc[param]) + + IO_NEVENTS(io) = EH_NEVENTS(eh) + IO_EVENTLEN(io) = EH_EVENTLEN(eh) + IO_SZBBUCKET(io)= EH_SZBBUCKET(eh) + IO_BUCKETLEN(io)= EH_BUCKETLEN(eh) + IO_FBOFF(io) = EH_FBOFF(eh) + IO_EVMINOFF(io) = EH_EVMINOFF(eh) + IO_EVMAXOFF(io) = EH_EVMAXOFF(eh) + IO_INDEXLEN(io) = EH_INDEXLEN(eh) + IO_YOFFVOFF(io) = EH_YOFFVOFF(eh) + IO_YOFFVLEN(io) = EH_YOFFVLEN(eh) + IO_YLENVOFF(io) = EH_YLENVOFF(eh) + IO_YLENVLEN(io) = EH_YLENVLEN(eh) + IO_IXXOFF(io) = EH_IXXOFF(eh) + IO_IXYOFF(io) = EH_IXYOFF(eh) + IO_IXXTYPE(io) = EH_IXXTYPE(eh) + IO_IXYTYPE(io) = EH_IXYTYPE(eh) + + # Copy the MINEVL event struct into the QPIO descriptor. + nwords = IO_EVENTLEN(io) + call malloc (IO_MINEVL(io), nwords, TY_SHORT) + call amovs (Memi[eh+EH_MINEVLOFF(eh)], Mems[IO_MINEVL(io)], + IO_EVENTLEN(io)) + + # Copy the MAXEVL event struct into the QPIO descriptor. + call malloc (IO_MAXEVL(io), nwords, TY_SHORT) + call amovs (Memi[eh+EH_MAXEVLOFF(eh)], Mems[IO_MAXEVL(io)], + IO_EVENTLEN(io)) + + if (IO_DEBUG(io) > 0) { + call eprintf ("%s: nev=%d, szbk=%d, bklen=%d+2, ixlen=%d\n") + call pargstr (Memc[param]) + call pargi (IO_NEVENTS(io)) + call pargi (IO_SZBBUCKET(io)) + call pargi (IO_BUCKETLEN(io)) + call pargi (IO_INDEXLEN(io)) + } + + # Get compressed event list index, if any. + if (IO_INDEXLEN(io) > 0) { + call salloc (oo, IO_INDEXLEN(io) * 2, TY_SHORT) + call malloc (IO_YOFFVP(io), IO_INDEXLEN(io), TY_INT) + call malloc (IO_YLENVP(io), IO_INDEXLEN(io), TY_INT) + + nchars = IO_YOFFVLEN(io) * SZ_SHORT + call seek (fd, IO_YOFFVOFF(io)) + if (read (fd, Mems[oo], nchars) < nchars) + call syserrs (SYS_QPBADIX, Memc[param]) + junk = pl_l2pi (Mems[oo], 1, Memi[IO_YOFFVP(io)], IO_INDEXLEN(io)) + + nchars = IO_YLENVLEN(io) * SZ_SHORT + call seek (fd, IO_YLENVOFF(io)) + if (read (fd, Mems[oo], nchars) < nchars) + call syserrs (SYS_QPBADIX, Memc[param]) + junk = pl_l2pi (Mems[oo], 1, Memi[IO_YLENVP(io)], IO_INDEXLEN(io)) + } + + # We won't need the file buffer any more, so free it. + call fseti (fd, F_BUFSIZE, 0) + + # Compile the event attribute filter (EAF). Always open the default + # filter if one is provided with the datafile. If the user has also + # specified a filter, this will modify the default filter. + + if (IO_NODEFFILT(io) != YES) { + # Check for "deffilt." first, then "deffilt". + call sprintf (Memc[deffilt], SZ_FNAME, "%s.%s") + call pargstr (s_deffilt) + call pargstr (Memc[param]) + nchars = qp_lenf (qp, Memc[deffilt]) + if (nchars <= 0) { + call strcpy (s_deffilt, Memc[deffilt], SZ_FNAME) + nchars = qp_lenf (qp, Memc[deffilt]) + } + + # Open the default filter if one was found. + if (nchars > 0) { + call salloc (filter_text, nchars, TY_CHAR) + if (qp_gstr(qp,Memc[deffilt],Memc[filter_text],nchars) < nchars) + call syserrs (SYS_QPBADVAL, Memc[deffilt]) + IO_EX(io) = qpex_open (qp, Memc[filter_text]) + IO_EXCLOSE(io) = YES + } + } + + # Fold in the user specified filter if one was given. + if (Memc[filter] != EOS) { + if (IO_EX(io) != NULL) { + if (qpex_modfilter (IO_EX(io), Memc[filter]) == ERR) + call fprintf (STDERR, + "Warning: error compiling QPIO filter\n") + } else { + IO_EX(io) = qpex_open (qp, Memc[filter]) + IO_EXCLOSE(io) = YES + } + + if (IO_DEBUG(io) > 0) { + call eprintf ("event attribute filter: %s\n") + call pargstr (Memc[filter]) + } + } + + # Open the region mask. This may be specified (named) in the parameter + # expression, else we try to open a default mask. If a mask is named, + # the name may be the name of a header parameter containing the mask + # as the stored array value (TY_OPAQUE parameter), the name of a header + # parameter containing the name of the mask (TY_CHAR), or the name of + # a mask storage file (.pl extension). + + # Make a copy of the user mask name, as qpio_loadmask will clobber it. + call strcpy (Memc[mask], Memc[umask], SZ_FNAME) + + if (IO_NODEFMASK(io) != YES) { + # Check for "defmask." first, then "defmask". + call sprintf (Memc[defmask], SZ_FNAME, "%s.%s") + call pargstr (s_defmask) + call pargstr (Memc[param]) + nchars = qp_lenf (qp, Memc[defmask]) + if (nchars <= 0) { + call strcpy (s_defmask, Memc[defmask], SZ_FNAME) + nchars = qp_lenf (qp, Memc[defmask]) + } + + if (nchars > 0) + if (qp_gstr (qp, Memc[defmask], Memc[maskname], SZ_FNAME) > 0) + call qpio_loadmask (io, Memc[maskname], NO) + } + + # Load user specified mask. + if (Memc[umask] != EOS) + call qpio_loadmask (io, Memc[umask], YES) + else if (IO_INDEXLEN(io) > 0) + call malloc (IO_RL(io), RL_LENELEM*2, TY_INT) + + # Allocate the bucket buffer. + call malloc (IO_BP(io), IO_SZBBUCKET(io)/SZB_CHAR/SZ_SHORT, TY_SHORT) +done_ + # If no default rect was specified, set default bounding box for + # reading to be the entire image. + + if (IO_BBUSED(io) == NO) { + IO_VSDEF(io,1) = 1; IO_VSDEF(io,2) = 1 + IO_VEDEF(io,1) = IO_NCOLS(io); IO_VEDEF(io,2) = IO_NLINES(io) + } + + # Initialize the active BB to the default. + call amovi (IO_VSDEF(io,1), IO_VS(io,1), NDIM) + call amovi (IO_VEDEF(io,1), IO_VE(io,1), NDIM) + +} then { + # We branch here if any nasty errors occur above. Cleanup and free + # the partially opened descriptor and pass the error on to whoever + # called us. + + if (IO_BP(io) != NULL) + call mfree (IO_BP(io), TY_SHORT) + if (IO_RL(io) != NULL) + call mfree (IO_RL(io), TY_INT) + if (IO_PL(io) != NULL && IO_PLCLOSE(io) == YES) + call pl_close (IO_PL(io)) + if (IO_EX(io) != NULL) + call qpex_close (IO_EX(io)) + + if (IO_YLENVP(io) != NULL) + call mfree (IO_YLENVP(io), TY_INT) + if (IO_YOFFVP(io) != NULL) + call mfree (IO_YOFFVP(io), TY_INT) + if (IO_MINEVL(io) != NULL) + call mfree (IO_MINEVL(io), TY_SHORT) + if (IO_MAXEVL(io) != NULL) + call mfree (IO_MAXEVL(io), TY_SHORT) + if (IO_FD(io) != NULL) + call close (IO_FD(io)) + + if (IO_MASK(io) != NULL) + call mfree (IO_MASK(io), TY_CHAR) + if (IO_PARAM(io) != NULL) + call mfree (IO_PARAM(io), TY_CHAR) + if (IO_DD(io) != NULL) + call mfree (IO_DD(io), TY_STRUCT) + + if (filter != NULL) + call mfree (filter, TY_CHAR) + if (io != NULL) + call mfree (io, TY_STRUCT) + + call erract (EA_ERROR) +} + + # The filter can be regenerated, so don't keep the input expr around. + call mfree (filter, TY_CHAR) + + # Normal exit for read-only access. + call sfree (sp) + return (io) +end diff --git a/sys/qpoe/qpioparse.x b/sys/qpoe/qpioparse.x new file mode 100644 index 00000000..40f858ab --- /dev/null +++ b/sys/qpoe/qpioparse.x @@ -0,0 +1,374 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "qpoe.h" +include "qpex.h" +include "qpio.h" + +# QPIO_PARSE -- Parse the QPIO expression operand input to qpio_open or +# qpio_setfilter. This consists of a comma delimited list of keyword=value +# terms. We factor out those which are QPIO related and deal with these +# directly, concatenating the remaining terms to be passed on to QPEX. +# The output filter buffer is resized as needed to hold the filter expr. +# ERR is returned as the function value if an error occurs while compiling +# the expression. + +int procedure qpio_parse (io, expr, filter, sz_filter, mask, sz_mask) + +pointer io #I QPIO descriptor +char expr[ARB] #I expression to be parsed +pointer filter #U filter buffer +int sz_filter #U allocated buffer size +char mask[sz_mask] #O new mask name (not reallocatable) +int sz_mask #I max chars out + +real rval +pointer qp, sp, keyword, vp, in +int assignop, byte_offset, sz_field +int level, zlevel, status, start, value, token, op, kw, tokno + +pointer qp_opentext() +int qp_gettok(), gstrcpy(), strlen(), strdic(), ctoi(), ctor() +errchk qp_opentext, malloc, realloc, qp_gettok, qp_ungettok, syserrs + +define F Memc[filter+($1)-1] +define noval_ 91 +define badval_ 92 +define badkey_ 93 + +begin + call smark (sp) + call salloc (keyword, SZ_FNAME, TY_CHAR) + + qp = IO_QP(io) + + # Open the input expression for macro expanded token input. + in = qp_opentext (qp, expr) + + # Extract and process a series of "param[=expr]" terms, where + # the expr may be any series of tokens, delimited by an + # unparenthesized comma. + + op = 1 + tokno = 0 + F(op) = EOS + mask[1] = EOS + status = OK + level = 0 + + repeat { + start = op + + # Advance to the next keyword. + token = qp_gettok (in, F(op), SZ_TOKBUF) + tokno = tokno + 1 + + switch (token) { + case EOF: + break + case '(', '[', '{': + level = level + 1 + next + case ')', ']', '}': + level = level - 1 + next + case '!': + if (tokno <= 2) { + IO_NODEFFILT(io) = YES + IO_NODEFMASK(io) = YES + tokno = 1 + } + next + case TOK_IDENTIFIER: + op = op + strlen (F(op)) + if (op + SZ_TOKBUF > sz_filter) { + sz_filter = sz_filter + INC_SZEXPRBUF + call realloc (filter, sz_filter, TY_CHAR) + } + call strcpy (F(start), Memc[keyword], SZ_FNAME) + call strlwr (Memc[keyword]) + default: + if (token != ',') { + call eprintf ("QPIO: unexpected token `%s'\n") + call pargstr (F(op)) + status = ERR + } + next + } + + value = NULL + token = qp_gettok (in, F(op), SZ_TOKBUF) + + if (token == '=' || + token == TOK_PLUSEQUALS || token == TOK_COLONEQUALS) { + + # Accumulate the expression. + zlevel = level + assignop = token + op = op + strlen (F(op)) + value = op + + repeat { + # Peek at the next token to see if it terminates the + # expression. An unparenthesized comma or unmatched + # right brace, bracket, or parenthesis is part of the + # next statement and terminates the expression. + + token = qp_gettok (in, F(op), SZ_TOKBUF) + switch (token) { + case EOF: + break + case '(', '[', '{': + level = level + 1 + case ')', ']', '}': + if (level <= zlevel) { + call qp_ungettok (in, F(op)) + F(op) = EOS + break + } else + level = level - 1 + case ',': + if (level <= zlevel) { + call qp_ungettok (in, F(op)) + F(op) = EOS + break + } + } + + # Accept token as data. + op = op + strlen (F(op)) + if (op + SZ_TOKBUF + 1 > sz_filter) { + sz_filter = sz_filter + INC_SZEXPRBUF + call realloc (filter, sz_filter, TY_CHAR) + } + + F(op) = ' '; op = op + 1 + F(op) = EOS + } + } + + # Process the keywords known to QPIO and pass anything else on + # to the output filter buffer. + + kw = strdic (Memc[keyword], Memc[keyword], SZ_FNAME, KEYWORDS) + vp = filter + value - 1 + + switch (kw) { + case KW_BLOCK: + # Set the XY blocking factor for pixelation. + if (value == NULL) + goto noval_ + else if (ctor (Memc, vp, rval) <= 0) + goto badval_ + IO_XBLOCK(io) = rval + IO_YBLOCK(io) = rval + op = start + + case KW_XBLOCK: + # Set the X blocking factor for pixelation. + if (value == NULL) + goto noval_ + else if (ctor (Memc, vp, rval) <= 0) + goto badval_ + IO_XBLOCK(io) = rval + op = start + + case KW_YBLOCK: + # Set the Y blocking factor for pixelation. + if (value == NULL) + goto noval_ + else if (ctor (Memc, vp, rval) <= 0) + goto badval_ + IO_YBLOCK(io) = rval + op = start + + case KW_DEBUG: + # Set the debug level, default 1 if no argument. + if (value == NULL) + IO_DEBUG(io) = 1 + else if (ctoi (Memc, vp, IO_DEBUG(io)) <= 0) { + IO_DEBUG(io) = QP_DEBUG(qp) +badval_ call eprintf ("QPIO: cannot convert `%s' to integer\n") + call pargstr (Memc[vp]) + } + op = start + + case KW_FILTER: + # A term such as "filter=(...)". Keep the (...). + if (value == NULL) + goto noval_ + else { + # Accumulate expression term. + op = start + gstrcpy (Memc[vp], F(start), ARB) + F(op) = ','; op = op + 1 + F(op) = EOS + } + + case KW_KEY: + # Set the offsets of the event attribute fields to be used + # for the event coordinates during extraction. The typical + # syntax of the key value is, e.g., key=(s10,s8). Fields + # used for event coordinate keys must be a numeric type. + + call strlwr (Memc[vp]) + while (Memc[vp] == ' ' || Memc[vp] == '(') + vp = vp + 1 + + # Get the X field offset and type. + switch (Memc[vp]) { + case 's': + IO_EVXTYPE(io) = TY_SHORT + sz_field = SZ_SHORT + case 'i': + IO_EVXTYPE(io) = TY_INT + sz_field = SZ_INT + case 'l': + IO_EVXTYPE(io) = TY_LONG + sz_field = SZ_LONG + case 'r': + IO_EVXTYPE(io) = TY_REAL + sz_field = SZ_REAL + case 'd': + IO_EVXTYPE(io) = TY_DOUBLE + sz_field = SZ_DOUBLE + default: + goto badkey_ + } + + vp = vp + 1 + if (ctoi (Memc, vp, byte_offset) <= 0) + goto badkey_ + else + IO_EVXOFF(io) = byte_offset / (sz_field * SZB_CHAR) + + while (Memc[vp] == ' ' || Memc[vp] == ',') + vp = vp + 1 + + # Get the Y field offset. + switch (Memc[vp]) { + case 's': + IO_EVYTYPE(io) = TY_SHORT + sz_field = SZ_SHORT + case 'i': + IO_EVYTYPE(io) = TY_INT + sz_field = SZ_INT + case 'l': + IO_EVYTYPE(io) = TY_LONG + sz_field = SZ_LONG + case 'r': + IO_EVYTYPE(io) = TY_REAL + sz_field = SZ_REAL + case 'd': + IO_EVYTYPE(io) = TY_DOUBLE + sz_field = SZ_DOUBLE + default: + goto badkey_ + } + + vp = vp + 1 + if (ctoi (Memc, vp, byte_offset) <= 0) { +badkey_ call eprintf ("QPIO: bad key value `%s'\n") + call pargstr (F(value)) + status = ERR + } else + IO_EVYOFF(io) = byte_offset / (sz_field * SZB_CHAR) + + op = start + + case KW_NOINDEX: + # Disable use of the index for extraction (for testing). + IO_NOINDEX(io) = YES + op = start + + case KW_PARAM, KW_MASK: + # Set a string valued option. + + if (value == NULL) { +noval_ call eprintf ("QPIO: kewyord `%s' requires an argument\n") + call pargstr (Memc[keyword]) + status = ERR + + } else { + # Kill space added at end of token. + op = op - 1 + F(op) = EOS + + # Output the string. + if (kw == KW_PARAM) { + # Set the name of the event list parameter. + call strcpy (Memc[vp], Memc[IO_PARAM(io)], SZ_FNAME) + } else { + # Set the name of the region mask. + call strcpy (Memc[vp], mask, sz_mask) + if (assignop == TOK_COLONEQUALS) + IO_NODEFMASK(io) = YES + } + } + op = start + + case KW_RECT: + # Set the source rect or "bounding box" for i/o. The syntax + # is somewhat flexible, i.e., "*", ":N", "N:", "M:N" are + # all accepted ways of expressing the range for an axis. + + IO_VSDEF(io,1) = 1; IO_VSDEF(io,2) = 1 + IO_VEDEF(io,1) = IO_NCOLS(io); IO_VEDEF(io,2) = IO_NLINES(io) + + if (Memc[vp] == '[' || Memc[vp] == '(') # ]) + vp = vp + 1 + while (Memc[vp] == ' ') + vp = vp + 1 + + # Get range in X. + if (Memc[vp] == '*') + vp = vp + 1 + else { + if (ctoi (Memc, vp, IO_VSDEF(io,1)) <= 0) + IO_VSDEF(io,1) = 1 + while (IS_WHITE(Memc[vp]) || Memc[vp] == ':') + vp = vp + 1 + if (ctoi (Memc, vp, IO_VEDEF(io,1)) <= 0) + IO_VEDEF(io,1) = IO_NCOLS(io) + } + + while (IS_WHITE(Memc[vp]) || Memc[vp] == ',') + vp = vp + 1 + + # Get range in Y. + if (Memc[vp] == '*') + vp = vp + 1 + else { + if (ctoi (Memc, vp, IO_VSDEF(io,2)) <= 0) + IO_VSDEF(io,2) = 1 + while (IS_WHITE(Memc[vp]) || Memc[vp] == ':') + vp = vp + 1 + if (ctoi (Memc, vp, IO_VEDEF(io,2)) <= 0) + IO_VEDEF(io,2) = IO_NLINES(io) + } + + IO_BBUSED(io) = YES + op = start + + default: + # Accumulate EAF expression term. + F(op) = ','; op = op + 1 + F(op) = ' '; op = op + 1 + F(op) = EOS + } + } + + # Verify that the parens etc. match. + if (level != 0) + call syserrs (SYS_QPIOSYN, QP_DFNAME(qp)) + + F(op) = EOS + sz_filter = op + call realloc (filter, sz_filter, TY_CHAR) + + call qp_closetext (in) + call sfree (sp) + + return (status) +end diff --git a/sys/qpoe/qpioputev.x b/sys/qpoe/qpioputev.x new file mode 100644 index 00000000..69c6d26d --- /dev/null +++ b/sys/qpoe/qpioputev.x @@ -0,0 +1,104 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpoe.h" +include "qpio.h" + +# QPIO_PUTEVENTS -- Append events to a new event list. No filtering is +# performed. As events are received they are merely copied into the bucket +# currently being filled, writing each bucket to the output lfile as it fills. +# No sorting is performed, hence if an indexed list is desired, the caller +# must output the events in sort order (normally sorted by Y and then by X +# within each image line). + +procedure qpio_putevents (io, i_ev, nevents) + +pointer io #I QPIO descriptor +pointer i_ev[ARB] #I array of event pointers +int nevents #I number of events + +pointer qp, bp, ev +int szs_event, szb_page, nwords, bklen, bksiz, nev, i, j +errchk qpio_wbucket, qpio_sync, malloc, calloc + +begin + szs_event = IO_EVENTLEN(io) + bp = IO_BP(io) + + # Fix the event list parameters and write out the event list header + # when the first write to a new event list occurs. + + if (IO_ACTIVE(io) == NO) { + qp = IO_QP(io) + szb_page = QP_FMPAGESIZE(qp) + + IO_FBOFF(io) = szb_page + 1 + IO_EVENTLEN(io) = DD_STRUCTLEN(IO_DD(io))*SZ_STRUCT/SZ_SHORT + IO_NEVENTS(io) = 0 + + # Force the bucket size to an integral number of datafile pages, + # and adjust the number of events to fill the bucket, allowing + # 2 extra slots at the end for the min/max event structs. + + bklen = QP_BUCKETLEN(qp) + 2 + bksiz = bklen * (IO_EVENTLEN(io) * SZ_SHORT * SZB_CHAR) + bksiz = (bksiz - 1) / szb_page * szb_page + bklen = bksiz / (IO_EVENTLEN(io) * SZ_SHORT * SZB_CHAR) + + IO_BUCKETLEN(io) = bklen - 2 + IO_SZBBUCKET(io) = bksiz + IO_EVMINOFF(io) = szs_event * (bklen - 2) + IO_EVMAXOFF(io) = szs_event * (bklen - 1) + IO_EVI(io) = 1 + IO_BKNO(io) = 1 + IO_BKFIRSTEV(io) = 1 + IO_BKLASTEV(io) = bklen - 2 + + if (IO_DEBUG(io) > 1) { + call eprintf ("%s: assign szbk=%d, bklen=%d+2\n") + call pargstr (Memc[IO_PARAM(io)]) + call pargi (bksiz) + call pargi (bklen - 2) + } + + # Allocate the bucket buffer. + call malloc (IO_BP(io), bksiz / SZB_CHAR / SZ_SHORT, TY_SHORT) + bp = IO_BP(io) + + # Allocate the MINEVL and MAXEVL event structs, used to keep + # track of the min and max event field values for the entire + # event list. + + nwords = IO_EVENTLEN(io) + call calloc (IO_MINEVL(io), nwords, TY_SHORT) + call calloc (IO_MAXEVL(io), nwords, TY_SHORT) + + # Write the event list header. + call qpio_sync (io) + + IO_ACTIVE(io) = YES + } + + # Make sure there is room in the bucket. + if (IO_EVI(io) > IO_BKLASTEV(io)) + call qpio_wbucket (io, IO_EVI(io)) + + # Output the current batch of events. + for (j=0; j < nevents; j=j+nev) { + # Copy out as many events as will fit in the bucket. + nev = min (nevents-j, (IO_BKLASTEV(io) - IO_EVI(io) + 1)) + if (nev <= 0) + break + + ev = bp + (IO_EVI(io) - IO_BKFIRSTEV(io)) * szs_event + do i = 1, nev { + call amovs (Mems[i_ev[i+j]], Mems[ev], szs_event) + ev = ev + szs_event + } + + # Write out the bucket if it fills. + IO_EVI(io) = IO_EVI(io) + nev + if (IO_EVI(io) > IO_BKLASTEV(io)) + call qpio_wbucket (io, IO_EVI(io)) + } +end diff --git a/sys/qpoe/qpiorb.x b/sys/qpoe/qpiorb.x new file mode 100644 index 00000000..9d46cc59 --- /dev/null +++ b/sys/qpoe/qpiorb.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "qpio.h" + +# QPIO_RBUCKET -- Load the bucket containing the specified event into the +# QPIO descriptor, returning EOF if the numbered event does not exist. + +int procedure qpio_rbucket (io, evi) + +pointer io #I QPIO descriptor +int evi #I bucket number desired + +int ev1, ev2, nb +int offset, bkno, status + +begin + # Event does not exist? + if (evi < 1 || evi > IO_NEVENTS(io)) + return (EOF) + + # Bucket already loaded? + bkno = EVI_TO_BUCKET(io,evi) + if (bkno == IO_BKNO(io)) + return (bkno) + + # Determine range of events in bucket. + ev1 = BUCKET_TO_EVI(io,bkno) + ev2 = min (IO_NEVENTS(io), ev1 + IO_BUCKETLEN(io) - 1) + + # Physically read the bucket. + nb = IO_SZBBUCKET(io) + offset = (bkno - 1) * nb + IO_FBOFF(io) + call fm_lfaread (IO_CHAN(io), Mems[IO_BP(io)], nb, offset) + call fm_lfawait (IO_CHAN(io), status) + if (status < nb) + return (EOF) + + # Update the bucket descriptor. + IO_BKNO(io) = bkno + IO_BKFIRSTEV(io) = ev1 + IO_BKLASTEV(io) = ev2 + + return (bkno) +end diff --git a/sys/qpoe/qpiorpix.gx b/sys/qpoe/qpiorpix.gx new file mode 100644 index 00000000..e766749c --- /dev/null +++ b/sys/qpoe/qpiorpix.gx @@ -0,0 +1,86 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../qpio.h" + +# QPIO_READPIX -- Sample the event list within the indicated rectangular +# region, using the given blocking factor, to produce a rectangular array +# of "pixels", where each pixel is a count of the number of events mapping +# to that location which pass the event attribute filter and region mask. +# +# NOTE -- It is left up to the caller to zero the output buffer before +# we are called. (We merely increment the counts of the affected pixels). + +int procedure qpio_readpix$t (io, obuf, vs, ve, ndim, xblock, yblock) + +pointer io #I QPIO descriptor +PIXEL obuf[ARB] #O output pixel buffer +int vs[ndim], ve[ndim] #I vectors defining region to be extracted +int ndim #I should be 2 for QPOE +real xblock, yblock #I blocking factors + +double x, y +pointer sp, evl, ev_p +int evtype, maxpix, maskval, xoff, yoff, xw, yw, nev, totev, pix, i, j +errchk qpio_getevents, qpio_setrange, syserr +int qpio_getevents() + +begin + # Verify arguments. + if (xblock <= 0 || xblock > (ve[1] - vs[1] + 1)) + call syserr (SYS_QPBLOCKOOR) + if (yblock <= 0 || yblock > (ve[2] - vs[2] + 1)) + call syserr (SYS_QPBLOCKOOR) + + # Compute the size of the output matrix in integer pixels. This + # truncates the last partially filled pixel in each axis. + + xw = int ((ve[1] - vs[1] + 1) / xblock + (EPSILOND * 1000)) + yw = int ((ve[2] - vs[2] + 1) / yblock + (EPSILOND * 1000)) + if (xw <= 0 || yw <= 0) + return (0) + + call smark (sp) + call salloc (evl, SZ_EVLIST, TY_POINTER) + + xoff = IO_EVXOFF(io) + yoff = IO_EVYOFF(io) + maxpix = xw * yw + totev = 0 + + evtype = IO_EVXTYPE(io) + if (IO_EVXTYPE(io) != IO_EVYTYPE(io)) + call syserr (SYS_QPINVEVT) + + # Define the region from which we wish to read events. + call qpio_setrange (io, vs, ve, ndim) + + # Read the events. + while (qpio_getevents (io, Memi[evl], maskval, SZ_EVLIST, nev) > 0) { + switch (evtype) { + $for (silrd) + case TY_PIXEL: + # Process a sequence of neighbor events. + do i = 1, nev { + ev_p = (Memi[evl+i-1] - 1) * SZ_SHORT / SZ_PIXEL + 1 + + x = Mem$t[ev_p+xoff] + y = Mem$t[ev_p+yoff] + + j = int ((y - vs[2]) / yblock + (EPSILOND * 1000)) + if (j >= 0 && j < yw) { + pix = j * xw + (x - vs[1]) / xblock + 1 + if (pix > 0 && pix <= maxpix) + obuf[pix] = obuf[pix] + 1 + } + } + $endfor + } + + totev = totev + nev + } + + call sfree (sp) + return (totev) +end diff --git a/sys/qpoe/qpiosetfil.x b/sys/qpoe/qpiosetfil.x new file mode 100644 index 00000000..4f5f9833 --- /dev/null +++ b/sys/qpoe/qpiosetfil.x @@ -0,0 +1,59 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "qpex.h" +include "qpio.h" + +# QPIO_SETFILTER -- Modify the filter used to reject events during event +# extraction with qpio_getevents or qpio_readpix. Possible items to be set +# here include the event attribute filter, region mask, and various QPIO +# parameters. The input expression should be a comma delimited list of +# param=value terms, where PARAM is `filter', `mask', or the name of a QPIO +# or QPEX parameter, and where `value' is an expression, e.g., a comma +# delimited list of range terms enclosed in parenthesis. + +procedure qpio_setfilter (io, expr) + +pointer io #I QPIO descriptor +char expr[ARB] #I option setting expression + +int sz_filter +pointer sp, filter, mask +errchk qpio_parse, qpex_open, qpex_modfilter +int qpex_modfilter(), qpio_parse() +pointer qpex_open() + +begin + call smark (sp) + call salloc (mask, SZ_FNAME, TY_CHAR) + + if (IO_DEBUG(io) > 0) { + call eprintf ("qpio_setfilter (%xX, `%s')\n") + call pargi (io) + call pargstr (expr) + } + + # Parse full QPIO oriented filter expression. + sz_filter = DEF_SZEXPRBUF + call malloc (filter, sz_filter, TY_CHAR) + if (qpio_parse (io,expr,filter,sz_filter,Memc[mask],SZ_FNAME) == ERR) { + call eprintf ("QPIO warning: error parsing `%s'\n") + call pargstr (expr) + } + + # Set event attribute filter. + if (IO_EX(io) == NULL) + IO_EX(io) = qpex_open (IO_QP(io), Memc[filter]) + else if (qpex_modfilter (IO_EX(io), Memc[filter]) == ERR) { + call eprintf ("Warning: errors compiling `%s'\n") + call pargstr (expr) + } + + # Set region mask. + if (Memc[mask] != EOS) + call qpio_loadmask (io, Memc[mask], NO) + + IO_ACTIVE(io) = NO + + call mfree (filter, TY_CHAR) + call sfree (sp) +end diff --git a/sys/qpoe/qpioseti.x b/sys/qpoe/qpioseti.x new file mode 100644 index 00000000..d5dadceb --- /dev/null +++ b/sys/qpoe/qpioseti.x @@ -0,0 +1,90 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "qpio.h" + +# QPIO_SETI -- Set a QPIO interface integer valued parameter. This procedure +# represents the lowest level interface by which an applications program can +# control QPIO. + +procedure qpio_seti (io, param, value) + +pointer io #I QPIO descriptor +int param #I parameter code +int value #I new parameter value + +int naxes, axlen[PL_MAXDIM], sv_active +errchk pl_close, syserr, realloc + +begin + # Almost everything here cancels any active i/o. + sv_active = IO_ACTIVE(io) + IO_ACTIVE(io) = NO + + # Set the named parameter. + switch (param) { + case QPIO_BLOCKFACTOR: + IO_XBLOCK(io) = value + IO_YBLOCK(io) = value + case QPIO_XBLOCKFACTOR: + IO_XBLOCK(io) = value + case QPIO_YBLOCKFACTOR: + IO_YBLOCK(io) = value + case QPIO_EVXOFF: + IO_EVXOFF(io) = value + case QPIO_EVYOFF: + IO_EVYOFF(io) = value + case QPIO_EVXTYPE: + IO_EVXTYPE(io) = value + case QPIO_EVYTYPE: + IO_EVYTYPE(io) = value + case QPIO_NOINDEX: + IO_NOINDEX(io) = value + case QPIO_NODEFFILT: + IO_NODEFFILT(io) = value + case QPIO_NODEFMASK: + IO_NODEFMASK(io) = value + case QPIO_OPTBUFSIZE: + IO_OPTBUFSIZE(io) = value + + case QPIO_BUCKETLEN: + # Set the bucket length (new event lists only). + if (IO_MODE(io) != READ_ONLY) + IO_BUCKETLEN(io) = value + + case QPIO_DEBUG: + # Set the debug level; don't modify IO_ACTIVE. + IO_ACTIVE(io) = sv_active + IO_DEBUG(io) = value + + case QPIO_EX: + # Set the event attribute filter. + if (IO_EX(io) != NULL && IO_EXCLOSE(io) == YES) + call qpex_close (IO_EX(io)) + IO_EX(io) = value + IO_EXCLOSE(io) = NO + + case QPIO_PL: + # Set the PLIO region mask. + if (IO_PL(io) != NULL && IO_PLCLOSE(io) == YES) + call pl_close (IO_PL(io)) + + IO_PL(io) = value + IO_PLCLOSE(io) = NO + call pl_gsize (IO_PL(io), naxes, axlen, IO_MDEPTH(io)) + if (axlen[1] != IO_NCOLS(io) || axlen[2] != IO_NLINES(io)) + call syserr (SYS_QPPLSIZE) + + # Allocate a range list buffer if i/o is indexed. + if (IO_INDEXLEN(io) > 0) + call realloc (IO_RL(io), RL_MAXLEN(IO_PL(io)), TY_INT) + + # Update the mask name, such as it is... + if (IO_MASK(io) != NULL) { + call sprintf (Memc[IO_MASK(io)], SZ_FNAME, "%xX") + call pargi (value) + } + } +end diff --git a/sys/qpoe/qpiosetr.x b/sys/qpoe/qpiosetr.x new file mode 100644 index 00000000..768e1b82 --- /dev/null +++ b/sys/qpoe/qpiosetr.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpio.h" + +# QPIO_SETR -- Set a QPIO interface real valued parameter. This procedure +# represents the lowest level interface by which an applications program can +# control QPIO. + +procedure qpio_setr (io, param, value) + +pointer io #I QPIO descriptor +int param #I parameter code +real value #I new parameter value + +begin + # Almost everything here cancels any active i/o. + IO_ACTIVE(io) = NO + + # Set the named parameter. + switch (param) { + case QPIO_BLOCKFACTOR: + IO_XBLOCK(io) = value + IO_YBLOCK(io) = value + case QPIO_XBLOCKFACTOR: + IO_XBLOCK(io) = value + case QPIO_YBLOCKFACTOR: + IO_YBLOCK(io) = value + } +end diff --git a/sys/qpoe/qpiosetrg.x b/sys/qpoe/qpiosetrg.x new file mode 100644 index 00000000..6a93f11e --- /dev/null +++ b/sys/qpoe/qpiosetrg.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "qpio.h" + +# QPIO_SETRANGE -- Set the range in X and Y within which events will be +# extracted by qpio_getevents. This defines the "bounding box" for i/o +# and "rewinds" the getevent i/o pointer. + +procedure qpio_setrange (io, vs, ve, ndim) + +pointer io #I QPIO descriptor +int vs[ARB] #I start vector (lower left corner) +int ve[ARB] #I end vector (upper right corner) +int ndim #I vector length (ndim=2 at present) + +int i +int vlim[NDIM] + +begin + vlim[1] = IO_NCOLS(io) + vlim[2] = IO_NLINES(io) + + if (ndim <= 0) { + call amovi (IO_VSDEF(io,1), IO_VS(io,1), NDIM) + call amovi (IO_VEDEF(io,1), IO_VE(io,1), NDIM) + } else { + do i = 1, ndim { + IO_VS(io,i) = max(1, min(vlim[i], vs[i])) + IO_VE(io,i) = max(1, min(vlim[i], ve[i])) + } + } + + IO_ACTIVE(io) = NO +end diff --git a/sys/qpoe/qpiostati.x b/sys/qpoe/qpiostati.x new file mode 100644 index 00000000..678ee0bb --- /dev/null +++ b/sys/qpoe/qpiostati.x @@ -0,0 +1,84 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpio.h" + +# QPIO_STATI -- Stat a QPIO interface integer valued parameter. + +int procedure qpio_stati (io, param) + +pointer io #I QPIO descriptor +int param #I parameter code + +bool fp_equalr() + +begin + switch (param) { + case QPIO_BLOCKFACTOR: + if (fp_equalr (IO_XBLOCK(io), IO_YBLOCK(io))) + return (IO_XBLOCK(io)) + else + return (ERR) + case QPIO_XBLOCKFACTOR: + return (IO_XBLOCK(io)) + case QPIO_YBLOCKFACTOR: + return (IO_YBLOCK(io)) + case QPIO_BUCKETLEN: + return (IO_BUCKETLEN(io)) + case QPIO_DEBUG: + return (IO_DEBUG(io)) + case QPIO_EVXOFF: + return (IO_EVXOFF(io)) + case QPIO_EVYOFF: + return (IO_EVYOFF(io)) + case QPIO_EVXTYPE: + return (IO_EVXTYPE(io)) + case QPIO_EVYTYPE: + return (IO_EVYTYPE(io)) + case QPIO_EX: + return (IO_EX(io)) + case QPIO_NODEFFILT: + return (IO_NODEFFILT(io)) + case QPIO_NODEFMASK: + return (IO_NODEFMASK(io)) + case QPIO_NOINDEX: + return (IO_NOINDEX(io)) + case QPIO_OPTBUFSIZE: + return (IO_OPTBUFSIZE(io)) + case QPIO_PL: + return (IO_PL(io)) + + case QPIO_EVENTLEN: # length of event struct, shorts + return (IO_EVENTLEN(io)) + case QPIO_FD: # FIO fd of event list lfile + return (IO_FD(io)) + case QPIO_INDEXLEN: # index length (0=noindex) + return (IO_INDEXLEN(io)) + case QPIO_IXXOFF: # offset of X in index + return (IO_IXXOFF(io)) + case QPIO_IXYOFF: # offset of Y in index + return (IO_IXYOFF(io)) + case QPIO_IXXTYPE: # datatype of X in index + return (IO_IXXTYPE(io)) + case QPIO_IXYTYPE: # datatype of Y in index + return (IO_IXYTYPE(io)) + case QPIO_LF: # FMIO lfile number + return (IO_LF(io)) + case QPIO_MASKP: # PLIO descriptor + return (IO_MASK(io)) + case QPIO_MAXEVP: # pointer to short + return (IO_MAXEVL(io)) + case QPIO_MINEVP: # pointer to short + return (IO_MINEVL(io)) + case QPIO_NCOLS: + return (IO_NCOLS(io)) + case QPIO_NLINES: + return (IO_NLINES(io)) + case QPIO_PARAMP: # pointer to char + return (IO_PARAM(io)) + case QPIO_QP: + return (IO_QP(io)) # QPOE descriptor + } + + return (ERR) +end diff --git a/sys/qpoe/qpiostatr.x b/sys/qpoe/qpiostatr.x new file mode 100644 index 00000000..429ea2e9 --- /dev/null +++ b/sys/qpoe/qpiostatr.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpio.h" + +# QPIO_STATR -- Stat a QPIO interface real valued parameter. + +real procedure qpio_statr (io, param) + +pointer io #I QPIO descriptor +int param #I parameter code + +bool fp_equalr() + +begin + switch (param) { + case QPIO_BLOCKFACTOR: + if (fp_equalr (IO_XBLOCK(io), IO_YBLOCK(io))) + return (IO_XBLOCK(io)) + else + return (ERR) + case QPIO_XBLOCKFACTOR: + return (IO_XBLOCK(io)) + case QPIO_YBLOCKFACTOR: + return (IO_YBLOCK(io)) + } + + return (ERR) +end diff --git a/sys/qpoe/qpiosync.x b/sys/qpoe/qpiosync.x new file mode 100644 index 00000000..35492d7d --- /dev/null +++ b/sys/qpoe/qpiosync.x @@ -0,0 +1,78 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "qpoe.h" +include "qpio.h" + +# QPIO_SYNC -- Update an event list on disk, i.e., flush the bucket buffer if +# it has been written into, and update the event list header. No QPIO state +# parameters are modified, e.g., the i/o pointer IO_EVI is not affected, +# nor are the contents of the bucket currently being filled; partially filled +# buckets can be synced if desired. + +procedure qpio_sync (io) + +pointer io #I QPIO descriptor + +pointer sp, eh +int szb_page, off, flen +int fstati() +errchk qpio_wbucket + +begin + if (IO_MODE(io) == READ_ONLY) + return + + # Flush the bucket buffer. + if (IO_EVI(io) > 1) + call qpio_wbucket (io, IO_EVI(io)) + + call smark (sp) + szb_page = QP_FMPAGESIZE(IO_QP(io)) + + # Update the event list header (stored in a full datafile page). + call salloc (eh, szb_page / (SZ_STRUCT*SZB_CHAR), TY_STRUCT) + call aclri (Memi[eh], szb_page / (SZ_STRUCT*SZB_CHAR)) + + EH_FBOFF(eh) = szb_page + 1 + EH_NEVENTS(eh) = IO_NEVENTS(io) + EH_EVENTLEN(eh) = IO_EVENTLEN(io) + EH_SZBBUCKET(eh) = IO_SZBBUCKET(io) + EH_BUCKETLEN(eh) = IO_BUCKETLEN(io) + EH_EVMINOFF(eh) = IO_EVMINOFF(io) + EH_EVMAXOFF(eh) = IO_EVMAXOFF(io) + EH_INDEXLEN(eh) = IO_INDEXLEN(io) + EH_YOFFVOFF(eh) = IO_YOFFVOFF(io) + EH_YOFFVLEN(eh) = IO_YOFFVLEN(io) + EH_YLENVOFF(eh) = IO_YLENVOFF(io) + EH_YLENVLEN(eh) = IO_YLENVLEN(io) + EH_IXXOFF(eh) = IO_IXXOFF(io) + EH_IXYOFF(eh) = IO_IXYOFF(io) + EH_IXXTYPE(eh) = IO_IXXTYPE(io) + EH_IXYTYPE(eh) = IO_IXYTYPE(io) + + # Output MINEV and MAXEV event structs following the header struct, + # but in the header page. + + if (IO_MINEVL(io) != NULL) { + off = LEN_EHDES + call amovs (Mems[IO_MINEVL(io)], Memi[eh+off], IO_EVENTLEN(io)) + EH_MINEVLOFF(eh) = off + } + + if (IO_MAXEVL(io) != NULL) { + off = LEN_EHDES + (IO_EVENTLEN(io) * SZ_SHORT / SZ_STRUCT) + call amovs (Mems[IO_MAXEVL(io)], Memi[eh+off], IO_EVENTLEN(io)) + EH_MAXEVLOFF(eh) = off + } + + # Write the header page to the lfile. + call fm_lfawrite (IO_CHAN(io), Memi[eh], szb_page, 1) + call fm_lfawait (IO_CHAN(io), szb_page) + flen = fstati (IO_FD(io), F_FILESIZE) + if (szb_page / SZB_CHAR > flen) + call fseti (IO_FD(io), F_FILESIZE, szb_page / SZB_CHAR) + + call sfree (sp) +end diff --git a/sys/qpoe/qpiowb.x b/sys/qpoe/qpiowb.x new file mode 100644 index 00000000..42f6ccc2 --- /dev/null +++ b/sys/qpoe/qpiowb.x @@ -0,0 +1,131 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "qpoe.h" +include "qpio.h" + +# QPIO_WBUCKET -- Flush any data currently in the bucket to the datafile, +# and set up the buffer to receive data for the bucket BKNO. The min/max +# event structs are updated whenever a bucket is written to disk. IO_EVI +# is assumed to point to the event following the last event written into +# in the buffer. Data should always be written sequentially. + +procedure qpio_wbucket (io, evi) + +pointer io #I QPIO descriptor +int evi #I evi of next bucket on exit + +pointer min_ev[2], max_ev[2], ev, fp, mp, dd +int sz_event, offset, dtype, nb, flen, nchars, i, j, k +int fstati() + +begin + dd = IO_DD(io) + + # Write the current bucket to the datafile if nonempty. + if (dd != NULL && IO_EVI(io) > IO_BKFIRSTEV(io)) { + # Scan through the events in the bucket and update the min/max + # event structs for the event list ([1] below) and for the + # bucket ([2] below, stored at the end of the bucket). + # Use CHAR pointers to facilitate pointer conversions. + + min_ev[1] = (IO_MINEVL(io) - 1) * SZ_SHORT + 1 + min_ev[2] = (IO_MINEVB(io) - 1) * SZ_SHORT + 1 + max_ev[1] = (IO_MAXEVL(io) - 1) * SZ_SHORT + 1 + max_ev[2] = (IO_MAXEVB(io) - 1) * SZ_SHORT + 1 + sz_event = DD_STRUCTLEN(dd) * SZ_STRUCT + + do k = 1, 2 { + ev = (IO_BP(io) - 1) * SZ_SHORT + 1 + # If min/max of bucket or first bucket of event list... + if (k == 2 || IO_BKNO(io) == 1) { + call amovc (Memc[ev], Memc[min_ev[k]], sz_event) + call amovc (Memc[ev], Memc[max_ev[k]], sz_event) + } + + do j = 1, IO_EVI(io) - IO_BKFIRSTEV(io) { + do i = 1, DD_NFIELDS(dd) { + # Get the typed offset and datatype of the field. + offset = DD_FOFFSET(dd,i) + dtype = DD_FTYPE(dd,i) + + # Update the min/max entries for the field. + switch (dtype) { + case TY_SHORT: + fp = (ev - 1) / SZ_SHORT + 1 + offset + mp = (min_ev[k] - 1) / SZ_SHORT + 1 + offset + if (Mems[fp] < Mems[mp]) + Mems[mp] = Mems[fp] + mp = (max_ev[k] - 1) / SZ_SHORT + 1 + offset + if (Mems[fp] > Mems[mp]) + Mems[mp] = Mems[fp] + + case TY_INT, TY_LONG: + fp = (ev - 1) / SZ_INT + 1 + offset + mp = (min_ev[k] - 1) / SZ_INT + 1 + offset + if (Memi[fp] < Memi[mp]) + Memi[mp] = Memi[fp] + mp = (max_ev[k] - 1) / SZ_INT + 1 + offset + if (Memi[fp] > Memi[mp]) + Memi[mp] = Memi[fp] + + case TY_REAL: + fp = (ev - 1) / SZ_REAL + 1 + offset + mp = (min_ev[k] - 1) / SZ_REAL + 1 + offset + if (Memr[fp] < Memr[mp]) + Memr[mp] = Memr[fp] + mp = (max_ev[k] - 1) / SZ_REAL + 1 + offset + if (Memr[fp] > Memr[mp]) + Memr[mp] = Memr[fp] + + case TY_DOUBLE: + fp = (ev - 1) / SZ_DOUBLE + 1 + offset + mp = (min_ev[k] - 1) / SZ_DOUBLE + 1 + offset + if (Memd[fp] < Memd[mp]) + Memd[mp] = Memd[fp] + mp = (max_ev[k] - 1) / SZ_DOUBLE + 1 + offset + if (Memd[fp] > Memd[mp]) + Memd[mp] = Memd[fp] + } + } + + ev = ev + sz_event + } + } + + # Zero out any remaining events. + while (ev < min_ev[2]) { + call aclrc (Memc[ev], sz_event) + ev = ev + sz_event + } + + # Write the bucket. + nb = IO_SZBBUCKET(io) + offset = (IO_BKNO(io) - 1) * nb + IO_FBOFF(io) + call fm_lfawrite (IO_CHAN(io), Mems[IO_BP(io)], nb, offset) + call fm_lfawait (IO_CHAN(io), nb) + + # Update the file size. + flen = fstati (IO_FD(io), F_FILESIZE) + nchars = (offset + nb) / SZB_CHAR + if (nchars > flen) + call fseti (IO_FD(io), F_FILESIZE, nchars) + + # Increment the total event count. + IO_NEVENTS(io) = max (IO_NEVENTS(io), IO_EVI(io) - 1) + S_NELEM(IO_PSYM(io)) = IO_NEVENTS(io) + QP_MODIFIED(IO_QP(io)) = YES + } + + # Set up the buffer for the new bucket. + IO_BKNO(io) = EVI_TO_BUCKET(io,evi) + IO_BKFIRSTEV(io) = BUCKET_TO_EVI(io,IO_BKNO(io)) + IO_BKLASTEV(io) = IO_BKFIRSTEV(io) + IO_BUCKETLEN(io) - 1 + + if (IO_DEBUG(io) > 2) { + call eprintf ("wbucket: evi=%d, bkno=%d\n") + call pargi(evi) + call pargi(IO_BKNO(io)) + } +end diff --git a/sys/qpoe/qplenf.x b/sys/qpoe/qplenf.x new file mode 100644 index 00000000..c8e4539e --- /dev/null +++ b/sys/qpoe/qplenf.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "qpoe.h" + +# QP_LENF -- Return the length of the named parameter, i.e., the number of +# stored elements in the parameter value. NULL is returned if there is no +# value, or ERR if the parameter does not exist. + +int procedure qp_lenf (qp, param) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name + +pointer sym +pointer qp_gpsym() + +begin + if (QP_ACTIVE(qp) == NO) + call qp_bind (qp) + + sym = qp_gpsym (qp, param) + if (sym == NULL) + return (ERR) + else + return (S_NELEM(sym)) +end diff --git a/sys/qpoe/qploadwcs.x b/sys/qpoe/qploadwcs.x new file mode 100644 index 00000000..b4609ce7 --- /dev/null +++ b/sys/qpoe/qploadwcs.x @@ -0,0 +1,38 @@ +include +include "qpoe.h" + +# QP_LOADWCS -- Load the default WCS, if there is one, from the QPOE image +# header. A QPOE file can contain any number of WCS, but the default WCS +# should relate the physical coordinate system, e.g., sky coordinates in +# the range 1024sq, 8192sq, etc., to world coordinates, e.g., the TAN +# projection. Probably we should provide for multiple physical coordinate +# systems (sky, detector, etc.) each with its own WCS, but at present we +# assume a single WCS. + +pointer procedure qp_loadwcs (qp) + +pointer qp #I QPOE descriptor + +int wcslen +pointer sp, svwcs, mw +errchk qp_lenf, syserrs, qp_read, mw_open +int qp_lenf(), qp_read() +pointer mw_open() +string s_qpwcs QPWCS + +begin + # Determine if there is a WCS, and if so, how big the saved version is. + wcslen = qp_lenf (qp, s_qpwcs) + if (wcslen <= 0) + call syserrs (SYS_QPNOWCS, QP_DFNAME(qp)) + + call smark (sp) + call salloc (svwcs, wcslen, TY_CHAR) + + # Retrieved the saved wcs, and load it into an MWCS descriptor. + wcslen = qp_read (qp, s_qpwcs, Memc[svwcs], wcslen, 1, "opaque") + mw = mw_open (svwcs, 0) + + call sfree (sp) + return (mw) +end diff --git a/sys/qpoe/qpmacro.x b/sys/qpoe/qpmacro.x new file mode 100644 index 00000000..984742d2 --- /dev/null +++ b/sys/qpoe/qpmacro.x @@ -0,0 +1,832 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "qpoe.h" +include "qpex.h" + +.help qpmacro +.nf --------------------------------------------------------------------------- +QPMACRO -- Macro facility for QPOE. QPOE permits macro replacement in various +places, e.g., to alias parameter names, or enter predefined selection +expressions (selection functions). While macros may be defined permanently +in the datafile, they are more commonly defined by the user at runtime, and +used as a global facility to access any number of datafiles. Since we do not +want to store runtime macros in the datafile headers, the compiled definitions +cannot be entered into the datafile symbol table, but must be entered into a +separate global symbol table, maintained by QPOE and used to store runtime +macros to be used in all datafile accesses. + +The purpose of the package is to maintain an up to date global macro symbol +table. The symbol table itself is directly accessed by the client program, +rather than via the package interface, so that the standard SYMTAB package +routines may be used to access the symbol table. + + qm = qm_access () + st = qm_symtab (qm) + qm_setdefaults (qm, qp) + qm_upddefaults (qm, qp) + + qm_scan (qm, fname, flags) + qm_scano (qm, fd, flags) + +The macro symbol table is accessed with QM_ACCESS, which will compile or +update the in-core version of the symbol table if necessary. A call to +QM_SYMTAB is required to obtain the symbol table descriptor, a pointer, +which may change any time the symbol table is modified. QM_ACCESS should +be called only occasionally (e.g., at datafile open time) since it makes a +number of system calls to check file dates. QM_SYMTAB should be called +once upon entry to every routine which accesses the macro database. + +QM_SETDEFAULTS is called when a datafile is opened to set the default values +of all interface and datafile parameters; the user can control these defaults +by including SET statements in the macro definition file. QM_UPDDEFAULTS is +similar, except that it sets ONLY the values of those parameters that have +been explicitly set in SET statements in the macro files. + +When QM_ACCESS is called it looks for two variables in the user environment. + + QMSAVE The name of the file (default home$qpoe.msv) in + which the compiled macro database is to be saved, + or from which it is to be loaded. + + QMFILES A comma delimited list of macro definition (MD) + files to be scanned to compile the macro database. + (No default unless one is supplied by the local + system administrator). + +If the binary symbol table file QMSAVE exists and is newer than any of the MD +files then the symbol table is reloaded from the binary save file, else the MD +files are scanned and we attempt to write a new save file when done. If the +symbol table is already open and is newer than either the save file or the +MD files, then the routine exits immediately, returning a pointer to the global +QPOE macro database (symbol table). QM_SCAN and QM_SCANO are low level +routines for reading the contents of a MD file or stream into the symbol table. + +Note that at runtime, a completely different facility exists for macro +replacement; macros may be drawn from either source. The second mechanism +takes the name of the macro to be the *name* of a file in the current +directory containing the value string for the macro. This is less efficient, +but allows macros to be independently created and used dynamically at runtime. +The latter type of macros may be referenced only in QPOE selection expressions +(rather than as, for example, parameter name aliases). +.endhelp ---------------------------------------------------------------------- + +# Size limiting definitions. +define QM_MAXFILES 32 # maximum files in QMFILES list +define QM_SZCBUF 1024 # char storage for file list +define DEF_LENINDEX 50 # symbol table (init hash index) +define DEF_LENSTAB 256 # symbol table (init table len) +define DEF_SZSBUF 1024 # symbol table (init string buf len) +define SZ_MNAME 32 # max size macro name +define SZ_MVBUF 8192 # max size macro value + +# Defined parameters. +define QMFILES "qmfiles" # macro define file list +define QMSAVE "qmsave" # symtab save file +define DEF_QMSAVE "uparm$qpoe.msv" # default macro save file +define STTIME "$STTIME" # time of last st compile +define PSETKW "$PSETKW" # param used to store SET values +define QMSTNAME "QPOEMACROS" # symbol table name + +# Flags for QM_SCAN. +define QM_FLAGREDEFS 1B # complain about redefined macros + +# The QM descriptor (fixed pointer, while QM_ST is allowed to change). +define LEN_QM 1 +define QM_ST Memi[$1] # pointer to macro symbol table + +# The parameter set descriptor (for SET statements). +define LEN_PSET 32 # allow some extra space +define PS_EXPBLEN Memi[$1] # QPEX program buffer length +define PS_EXDBLEN Memi[$1+1] # QPEX data buffer length +define PS_EXMAXFRLLEN Memi[$1+2] # QPEX max FRLUT length +define PS_EXMAXRRLLEN Memi[$1+3] # QPEX max RRLUT length +define PS_EXLMINRANGES Memi[$1+4] # QPEX max ranges before using LUT +define PS_EXLSCALE Memi[$1+5] # QPEX scale nranges to LUT bins +define PS_SZPBBUF Memi[$1+6] # size of pushback buffer for macros +define PS_BUCKETLEN Memi[$1+7] # QPIO event file bucket size +define PS_FMMAXLFILES Memi[$1+8] # FMIO maxlfiles +define PS_FMMAXPTPAGES Memi[$1+9] # FMIO maxptpages (page table pages) +define PS_FMPAGESIZE Memi[$1+10] # FMIO pagesize +define PS_FMCACHESIZE Memi[$1+11] # FMIO buffer cache size +define PS_STINDEXLEN Memi[$1+12] # SYMTAB hash index length +define PS_STSTABLEN Memi[$1+13] # SYMTAB stab len (start) +define PS_STSBUFSIZE Memi[$1+14] # SYMTAB sbuf size (start) +define PS_NODEFFILT Memi[$1+15] # Disable use of default filter +define PS_NODEFMASK Memi[$1+16] # Disable use of default mask +define PS_XBLOCK Memr[P2R($1+17)]# QPIO blocking factor in X +define PS_YBLOCK Memr[P2R($1+18)]# QPIO blocking factor in Y +define PS_DEBUG Memi[$1+19] # debug level +define PS_OPTBUFSIZE Memi[$1+20] # QPIO/QPF FIO optimum buffer size + +# Handy macros. +define IS_PUNCT (IS_WHITE($1)||($1)==','||($1)=='\n') + + +# QM_ACCESS -- Access the QPOE macro descriptor. Once opened, this should +# remain open for the lifetime of the process. Since these macros are global, +# the single descriptor is shared by all open datafiles and all tasks in the +# process. + +pointer procedure qm_access() + +int nfiles, fd, i +bool save_file_exists +pointer file[QM_MAXFILES] +long fi[LEN_FINFO], date[QM_MAXFILES], stdate +pointer sp, qmfiles, qmsave, cbuf, qm, st, st_start, start, sym, ps, ip, op + +long clktime() +int envfind(), finfo(), open() +pointer stopen(), stenter(), stfind(), strestore() +errchk stopen, malloc, syserrs +string sttimekw STTIME +define uptodate_ 91 +data qm /NULL/ + +begin + call smark (sp) + call salloc (qmfiles, SZ_LINE, TY_CHAR) + call salloc (qmsave, SZ_PATHNAME, TY_CHAR) + call salloc (cbuf, QM_SZCBUF, TY_CHAR) + + # Open the QM descriptor only once (per process). + if (qm == NULL) { + # Allocate descriptor. + call malloc (qm, LEN_QM, TY_STRUCT) + + # Initialize symbol table. + st = stopen (QMSTNAME, DEF_LENINDEX, DEF_LENSTAB, DEF_SZSBUF) + sym = stenter (st, sttimekw, SZ_LONG); Meml[sym] = 0 + + # Initialize settable interface/datafile parameters. + ps = stenter (st, PSETKW, LEN_PSET) + call aclri (Memi[ps], LEN_PSET) + + # Free back to here when rebuilding symbol table. + call stmark (st, st_start) + } + + # Get the QMSAVE symtab save file filename. + if (envfind (QMSAVE, Memc[qmsave], SZ_PATHNAME) <= 0) + call strcpy (DEF_QMSAVE, Memc[qmsave], SZ_PATHNAME) + + # Get the QMFILES macro define file list. + if (envfind (QMFILES, Memc[qmfiles], SZ_LINE) <= 0) + Memc[qmfiles] = EOS + + # Process the QMFILES string into a list of filenames, and get the + # modify date of each file. + + nfiles = 0 + op = cbuf + ip = qmfiles + + repeat { + # Get the next comma delimited argument from QMFILES. + while (IS_PUNCT(Memc[ip])) + ip = ip + 1 + + start = op + while (Memc[ip] != EOS && !IS_PUNCT(Memc[ip])) { + Memc[op] = Memc[ip] + op = op + 1 + ip = ip + 1 + } + + Memc[op] = EOS + op = op + 1 + if (Memc[start] == EOS) + break + + # Add the file and its modify date to the file list. + if (finfo (Memc[start], fi) == ERR) { + call eprintf ("Warning: QPOE macro file %s not found\n") + call pargstr (Memc[start]) + } else { + nfiles = nfiles + 1 + if (nfiles > QM_MAXFILES) + call syserrs (SYS_QMNFILES, Memc[qmsave]) + file[nfiles] = start + date[nfiles] = fi[FI_MTIME] + } + } + + # Check the dates of the MD files against the in-core symbol table + # and exit if the symbol table is up to date. The date of the symbol + # table is stored in the table itself. + + sym = stfind (st, sttimekw) + if (nfiles > 0 && sym != NULL) { + stdate = Meml[sym] + for (i=1; i <= nfiles; i=i+1) + if (date[i] > stdate) + break + if (i > nfiles) + goto uptodate_ + } + + # If a binary symtab save file exists and is up to date, load it + # into the descriptor. + + save_file_exists = false + if (nfiles > 0) + save_file_exists = (finfo (Memc[qmsave], fi) == OK) + + if (save_file_exists) { + stdate = fi[FI_MTIME] + for (i=1; i <= nfiles; i=i+1) + if (date[i] > stdate) + break + if (i > nfiles || nfiles == 0) { + iferr (fd = open (Memc[qmsave], READ_ONLY, BINARY_FILE)) { + call eprintf ("Warning: cannot open ") + call eprintf ("QPOE macro save file %s\n") + call pargstr (Memc[qmsave]) + } else { + call stclose (st) + st = strestore (fd) + call close (fd) + goto uptodate_ + } + } + } + + # If we get here then we need to scan the MD files and build a new + # symbol table. + + # Rebuild the symbol table. + call stfree (st, st_start) + call stmark (st, st_start) + QM_ST(qm) = st + + for (i=1; i <= nfiles; i=i+1) + iferr (call qm_scan (qm, Memc[file[i]], 0)) + call erract (EA_WARN) + + # Set the time of last update. + Meml[sym] = clktime (0) + + # Update the save file if we have any defined macros. + if (nfiles > 0) { + call intr_disable() + if (save_file_exists) + iferr (call delete (Memc[qmsave])) + call erract (EA_WARN) + iferr (fd = open (Memc[qmsave], NEW_FILE, BINARY_FILE)) + call erract (EA_WARN) + else { + iferr (call stsave (st, fd)) + call erract (EA_WARN) + call close (fd) + } + call intr_enable() + } + +uptodate_ + call sfree (sp) + QM_ST(qm) = st + return (qm) +end + + +# QM_SYMTAB -- Get a pointer to the symbol table used to store the defined +# macros for QPOE. The level of indirection is needed so that the QM pointer +# can be fixed while the symtab pointer is allowed to change as the symbol +# table is modified or rebuilt. + +pointer procedure qm_symtab (qm) + +pointer qm #I QM descriptor + +begin + return (QM_ST(qm)) +end + + +# QM_SCAN -- Scan a macro definition (MD) file and add any macros defined +# therein into the symbol table. + +procedure qm_scan (qm, fname, flags) + +pointer qm #I QM descriptor +char fname[ARB] #I MD file name +int flags #I scan flags + +int fd +int open() +errchk open + +begin + fd = open (fname, READ_ONLY, TEXT_FILE) + call qm_scano (qm, fd, flags) + call close (fd) +end + + +# QM_SCANO -- Scan a stream and parse any macro defines therein, adding the +# defined macros to the given symbol table, and setting the values of the +# specified interface or datafile parameters. +# +# The syntax of a SET statement, used to set the default values of interface +# and datafile parameters, is as follows: +# +# set parameter value +# +# where the parameter names are as given in (case not significant). +# Parameter values set in this way may be overridden by QP_SETI calls after +# opening a datafile. +# +# The syntax of a macro define is as follows: +# +# define name value +# +# where NAME is a simple alphanumeric identifier, and the string VALUE may +# contain references of the form $N, N=0:9, $0 being the macro name, $1:9 +# being replaced by the arguments to the macro when it is called. Newline +# may be escaped to enter multiline macro definition statements. Comments +# and blank lines are ignored. During macro expansion, any parenthesized +# arguments following the macro name will be consumed only if the macro as +# defined has symbolic arguments. The value string will be inserted without +# adding any whitespace at either end, and whitespace within the value string +# is significant. + +procedure qm_scano (qm, fd, flags) + +pointer qm #I QM descriptor +int fd #I input stream +int flags #I scan flags + +int ch +bool is_define, is_set +int symarg, junk, buflen, i +pointer sp, mname, mvbuf, sym, st, op, otop + +bool streq() +int qm_getc(), stpstr() +pointer stfind(), stenter() +errchk qm_getc, qm_setparam, stenter, stpstr, malloc, realloc +define next_ 91 + +begin + call smark (sp) + call salloc (mname, SZ_MNAME, TY_CHAR) + call malloc (mvbuf, SZ_MVBUF, TY_CHAR) + + st = QM_ST(qm) + junk = qm_getc (NULL, ch) + + # The following can only be set true in set statements, so we must + # initialize the values before processing the file. + + sym = stfind (st, PSETKW) + if (sym != NULL) { + PS_NODEFFILT(sym) = NO + PS_NODEFMASK(sym) = NO + } + + # Each loop processes one newline delimited statement from the + # input stream. The qm_getc function deals with continuation, + # blank lines and comments, etc. + + repeat { + # Get `define' and macro name (or `set' and parameter name). +next_ + do i = 1, 2 { + # Get identifier token. + op = mname + otop = mname + SZ_MNAME - 1 + while (qm_getc (fd, ch) != EOF) { + if (IS_ALNUM(ch) || ch == '_') { + Memc[op] = ch + op = min (otop, op + 1) + } else if (ch == '\n') { + if (op == mname) + goto next_ + else { + call ungetci (fd, ch) + break + } + } else if (IS_WHITE(ch) && op == mname) { + next + } else + break + } + Memc[op] = EOS + + # Process statement type keyword. + if (i == 1) { + is_define = (streq (Memc[mname], "define")) + is_set = (streq (Memc[mname], "set")) + + # Ignore statements other than SET or DEFINE. + if (!(is_define || is_set)) { + while (qm_getc (fd, ch) != EOF) + if (ch == '\n') + goto next_ + } + } + } + + # Check for EOF. + if (Memc[mname] == EOS) + break + + # Skip optional "=" if SET statement. + if (is_set) + while (IS_WHITE(ch)) { + if (qm_getc (fd, ch) == EOF) + break + else if (ch == '\n') + break + else if (ch == '=') + ch = ' ' + } + + # Skip to value string; leave first char in ch. + while (IS_WHITE(ch)) { + if (qm_getc (fd, ch) == EOF) + break + else if (ch == '\n') + break + } + + # Get value string. Check for the presence of any symbolic + # arguments of the form $N in the process. + + symarg = 0 + buflen = SZ_MVBUF + op = mvbuf + + Memc[op] = ch + op = op + 1 + + while (qm_getc (fd, ch) != EOF) { + if (ch == '\n') + break + else { + Memc[op] = ch + if (IS_DIGIT(ch)) + if (op > mvbuf) + if (Memc[op-1] == '$') + symarg = max (symarg, TO_INTEG(ch)) + op = op + 1 + if (op - mvbuf == buflen) { + call realloc (mvbuf, buflen + SZ_MVBUF, TY_CHAR) + op = mvbuf + buflen + buflen = buflen + SZ_MVBUF + } + } + } + Memc[op] = EOS + + # Process SET statements. + if (is_set) { + call strlwr (Memc[mname]) + call qm_setparam (qm, Memc[mname], Memc[mvbuf]) + next + } + + # Check for a redef. + if (and (flags, QM_FLAGREDEFS) != 0) { + sym = stfind (st, Memc[mname]) + if (sym != NULL) { + call eprintf ("Warning: QPOE macro `%s' redefined\n") + call pargstr (Memc[mname]) + } + } + + # Enter the macro into the symbol table. + sym = stenter (st, Memc[mname], LEN_SYMBOL) + S_OFFSET(sym) = stpstr (st, Memc[mvbuf], 0) + S_DTYPE(sym) = TY_MACRO + S_FLAGS(sym) = 0 + if (symarg > 0) + S_FLAGS(sym) = SF_MACARGS + else + S_FLAGS(sym) = 0 + } + + call mfree (mvbuf, TY_CHAR) + call sfree (sp) +end + + +# QM_SETPARAM -- Set the default value of an interface or datafile parameter. + +procedure qm_setparam (qm, param, valstr) + +pointer qm #I QM descriptor +char param[ARB] #I parameter to be set +char valstr[ARB] #I parameter value + +pointer ps +double dval +int value, ip, pp +int qp_ctoi(), qp_ctod(), strncmp() +pointer stfind() +bool streq() +errchk stfind +define err_ 91 + +begin + ps = stfind (QM_ST(qm), PSETKW) + if (ps == NULL) + return + + # Accept either QP_PARAM or just PARAM. + pp = 1 + if (strncmp (param, "qp_", 3) == 0) + pp = 4 + + # Decode the parameter value - mostly integer parameters at present, + # except for "nodeffilt" and "nodefmask" which do not have a value, + # and the blocking factors, which are floating point. + + ip = 1 + if (strncmp (param[pp], "nodef", 5) == 0) { + return + } else if (strncmp (param[pp], "block", 5) == 0) { + if (qp_ctod (valstr, ip, dval) <= 0) + goto err_ + PS_XBLOCK(ps) = dval + PS_YBLOCK(ps) = dval + return + } else if (strncmp (param[pp], "xblock", 6) == 0) { + if (qp_ctod (valstr, ip, dval) <= 0) + goto err_ + PS_XBLOCK(ps) = dval + return + } else if (strncmp (param[pp], "yblock", 6) == 0) { + if (qp_ctod (valstr, ip, dval) <= 0) + goto err_ + PS_YBLOCK(ps) = dval + return + } else { + if (qp_ctoi (valstr, ip, value) <= 0) { +err_ call eprintf ("bad value `%s' for QPOE parameter `%s'\n") + call pargstr (valstr) + call pargstr (param) + return + } + } + + # Set the parameter value in the global QM descriptor. + if ( streq (param[pp], "bucketlen")) + PS_BUCKETLEN(ps) = value + else if (streq (param[pp], "cachesize")) + PS_FMCACHESIZE(ps) = value + else if (streq (param[pp], "indexlen")) + PS_STINDEXLEN(ps) = value + else if (streq (param[pp], "maxlfiles")) + PS_FMMAXLFILES(ps) = value + else if (streq (param[pp], "maxptpages")) + PS_FMMAXPTPAGES(ps) = value + else if (streq (param[pp], "pagesize")) + PS_FMPAGESIZE(ps) = value + else if (streq (param[pp], "sbufsize")) + PS_STSBUFSIZE(ps) = value + else if (streq (param[pp], "stablen")) + PS_STSTABLEN(ps) = value + else if (streq (param[pp], "progbuflen")) + PS_EXPBLEN(ps) = value + else if (streq (param[pp], "databuflen")) + PS_EXDBLEN(ps) = value + else if (streq (param[pp], "maxfrlutlen")) + PS_EXMAXFRLLEN(ps) = value + else if (streq (param[pp], "maxrrlutlen")) + PS_EXMAXRRLLEN(ps) = value + else if (streq (param[pp], "lutminranges")) + PS_EXLMINRANGES(ps) = value + else if (streq (param[pp], "lutscale")) + PS_EXLSCALE(ps) = value + else if (streq (param[pp], "maxpushback")) + PS_SZPBBUF(ps) = value + else if (streq (param[pp], "nodeffilt")) + PS_NODEFFILT(ps) = YES + else if (streq (param[pp], "nodefmask")) + PS_NODEFMASK(ps) = YES + else if (streq (param[pp], "blockfactor")) + { PS_XBLOCK(ps) = value; PS_YBLOCK(ps) = value } + else if (streq (param[pp], "xblockfactor")) + PS_XBLOCK(ps) = value + else if (streq (param[pp], "yblockfactor")) + PS_YBLOCK(ps) = value + else if (streq (param[pp], "debuglevel")) + PS_DEBUG(ps) = value + else if (streq (param[pp], "optbufsize")) + PS_OPTBUFSIZE(ps) = value + else { + call eprintf ("unknown QPOE parameter `%s' in SET statement\n") + call pargstr (param) + } +end + + +# QM_SETDEFAULTS -- Set the current default values of all interface and +# datafile parameters in a QPOE descriptor. Called at datafile open time +# to get the defaults. + +procedure qm_setdefaults (qm, qp) + +pointer qm #I QM descriptor +pointer qp #I QPOE descriptor + +pointer ps +pointer stfind() +int qm_spari() +real qm_sparr() +errchk stfind + +begin + ps = stfind (QM_ST(qm), PSETKW) + if (ps == NULL) + return + + # Interface parameters. + QP_EXPBLEN(qp) = qm_spari (PS_EXPBLEN(ps), DEF_PROGBUFLEN) + QP_EXDBLEN(qp) = qm_spari (PS_EXDBLEN(ps), DEF_DATABUFLEN) + QP_EXMAXFRLLEN(qp) = qm_spari (PS_EXMAXFRLLEN(ps), DEF_MAXFRLUTLEN) + QP_EXMAXRRLLEN(qp) = qm_spari (PS_EXMAXRRLLEN(ps), DEF_MAXRRLUTLEN) + QP_EXLMINRANGES(qp) = qm_spari (PS_EXLMINRANGES(ps), DEF_LUTMINRANGES) + QP_EXLSCALE(qp) = qm_spari (PS_EXLSCALE(ps), DEF_LUTSCALE) + QP_SZPBBUF(qp) = qm_spari (PS_SZPBBUF(ps), DEF_MAXPUSHBACK) + QP_FMCACHESIZE(qp) = qm_spari (PS_FMCACHESIZE(ps), DEF_FMCACHESIZE) + + # Datafile parameters. + QP_BUCKETLEN(qp) = qm_spari (PS_BUCKETLEN(ps), DEF_BUCKETLEN) + QP_FMMAXLFILES(qp) = qm_spari (PS_FMMAXLFILES(ps), DEF_FMMAXLFILES) + QP_FMMAXPTPAGES(qp) = qm_spari (PS_FMMAXPTPAGES(ps), DEF_FMMAXPTPAGES) + QP_FMPAGESIZE(qp) = qm_spari (PS_FMPAGESIZE(ps), DEF_FMPAGESIZE) + QP_STINDEXLEN(qp) = qm_spari (PS_STINDEXLEN(ps), DEF_STINDEXLEN) + QP_STSTABLEN(qp) = qm_spari (PS_STSTABLEN(ps), DEF_STSTABLEN) + QP_STSBUFSIZE(qp) = qm_spari (PS_STSBUFSIZE(ps), DEF_STSBUFSIZE) + + # Other parameters. + QP_NODEFFILT(qp) = qm_spari (PS_NODEFFILT(ps), NO) + QP_NODEFMASK(qp) = qm_spari (PS_NODEFMASK(ps), NO) + QP_XBLOCK(qp) = qm_sparr (PS_XBLOCK(ps), DEF_BLOCKFACTOR) + QP_YBLOCK(qp) = qm_sparr (PS_YBLOCK(ps), DEF_BLOCKFACTOR) + QP_OPTBUFSIZE(qp) = qm_spari (PS_OPTBUFSIZE(ps), DEF_OPTBUFSIZE) + QP_DEBUG(qp) = qm_spari (PS_DEBUG(ps), 0) +end + + +# QM_SETPAR -- Return the given parameter value, if set in the user's macro +# files, otherwise return the interface default. + +int procedure qm_setpar (userval, defval) + +int userval #I user specified value, or zero +int defval #I interface default +int qm_spari() + +begin + return (qm_spari (userval, defval)) +end + + +# QM_SPARI -- Return the given int parameter value, if set in the user's macro +# files, otherwise return the interface default. + +int procedure qm_spari (userval, defval) + +int userval #I user specified value, or zero +int defval #I interface default + +begin + if (userval != 0) + return (userval) + else + return (defval) +end + + +# QM_SPARR -- Return the given real parameter value, if set in the user's macro +# files, otherwise return the interface default. + +real procedure qm_sparr (userval, defval) + +real userval #I user specified value, or zero +real defval #I interface default + +begin + if (userval != 0) + return (userval) + else + return (defval) +end + + +# QM_UPDDEFAULTS -- Update the values in the QPOE descriptor of all interface +# and datafile parameters set explicitly by a user macro or SET statement. +# Only those parameters for which values were explicitly specified in the +# use macro files are affected, allowing the use of global macros or set +# statements to override the interface or datafile defaults. + +procedure qm_upddefaults (qm, qp) + +pointer qm #I QM descriptor +pointer qp #I QPOE descriptor + +pointer ps +pointer stfind() +errchk stfind + +begin + ps = stfind (QM_ST(qm), PSETKW) + if (ps == NULL) + return + + # Interface parameters. + if (PS_EXPBLEN(ps) != 0) QP_EXPBLEN(qp) = PS_EXPBLEN(ps) + if (PS_EXDBLEN(ps) != 0) QP_EXDBLEN(qp) = PS_EXDBLEN(ps) + if (PS_EXMAXFRLLEN(ps) != 0) QP_EXMAXFRLLEN(qp) = PS_EXMAXFRLLEN(ps) + if (PS_EXMAXRRLLEN(ps) != 0) QP_EXMAXRRLLEN(qp) = PS_EXMAXRRLLEN(ps) + if (PS_EXLMINRANGES(ps) != 0) QP_EXLMINRANGES(qp)= PS_EXLMINRANGES(ps) + if (PS_EXLSCALE(ps) != 0) QP_EXLSCALE(qp) = PS_EXLSCALE(ps) + if (PS_SZPBBUF(ps) != 0) QP_SZPBBUF(qp) = PS_SZPBBUF(ps) + if (PS_FMCACHESIZE(ps) != 0) QP_FMCACHESIZE(qp) = PS_FMCACHESIZE(ps) + + # Datafile parameters. + if (PS_BUCKETLEN(ps) != 0) QP_BUCKETLEN(qp) = PS_BUCKETLEN(ps) + if (PS_FMMAXLFILES(ps) != 0) QP_FMMAXLFILES(qp) = PS_FMMAXLFILES(ps) + if (PS_FMMAXPTPAGES(ps) != 0) QP_FMMAXPTPAGES(qp)= PS_FMMAXPTPAGES(ps) + if (PS_FMPAGESIZE(ps) != 0) QP_FMPAGESIZE(qp) = PS_FMPAGESIZE(ps) + if (PS_STINDEXLEN(ps) != 0) QP_STINDEXLEN(qp) = PS_STINDEXLEN(ps) + if (PS_STSTABLEN(ps) != 0) QP_STSTABLEN(qp) = PS_STSTABLEN(ps) + if (PS_STSBUFSIZE(ps) != 0) QP_STSBUFSIZE(qp) = PS_STSBUFSIZE(ps) + + # Other parameters. + if (PS_NODEFFILT(ps) != 0) QP_NODEFFILT(qp) = PS_NODEFFILT(ps) + if (PS_NODEFMASK(ps) != 0) QP_NODEFMASK(qp) = PS_NODEFMASK(ps) + if (PS_XBLOCK(ps) != 0) QP_XBLOCK(qp) = PS_XBLOCK(ps) + if (PS_YBLOCK(ps) != 0) QP_YBLOCK(qp) = PS_YBLOCK(ps) + if (PS_OPTBUFSIZE(ps) != 0) QP_OPTBUFSIZE(qp) = PS_OPTBUFSIZE(ps) + if (PS_DEBUG(ps) != 0) QP_DEBUG(qp) = PS_DEBUG(ps) +end + + +# QM_GETC -- Return the next character from the input stream, ignoring +# comments and joining continued lines. The character value or EOF is +# returned as the function value. A call with FD=0 will initialize i/o +# for a new file. + +int procedure qm_getc (fd, ch) + +int fd #I input file +int ch #O returned character + +int quote +int getci() +errchk getci +define again_ 91 + +begin + # Initialization. + if (fd <= 0) { + quote = 0 + return (0) + } + + # Handle the most common cases first. +again_ + if (getci (fd, ch) == EOF) { + quote = 0 + return (EOF) + } else if (IS_ALNUM(ch)) + return (ch) + + # Handle the special cases - comments, escapes, quoted strings. + if (ch == '#' && quote == 0) { + # Skip a comment. + while (getci (fd, ch) != EOF) + if (ch == '\n') + goto again_ + } else if (ch == '\'' || ch == '"') { + # Toggle quoted string flag. + if (quote == 0) + quote = ch + else if (quote == ch) + quote = 0 + } else if (ch == '\\') { + # Process escapes. + if (getci (fd, ch) == '\n') + goto again_ + else if (quote == 0 && (ch == '\'' || ch == '"' || ch == '#')) + ; + else { + call ungetci (fd, ch) + ch = '\\' + } + } + + # Init context at end of every logical line. + if (ch == '\n') + quote = 0 + + return (ch) +end diff --git a/sys/qpoe/qpmkfname.x b/sys/qpoe/qpmkfname.x new file mode 100644 index 00000000..3721f6f4 --- /dev/null +++ b/sys/qpoe/qpmkfname.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "qpoe.h" + +# QP_MKFNAME -- Construct the poefile filename, i.e., eliminate any whitespace +# and add the given extension if omitted. + +procedure qp_mkfname (poefile, extn, fname, maxch) + +char poefile[ARB] #I raw poefile name +char extn[ARB] #I extension to be added if absent +char fname[maxch] #O output filename +int maxch #I max chars out + +int n +bool strne() +int nowhite() + +begin + n = nowhite (poefile, fname, maxch) + if (n <= 3 || strne (fname[n-2], extn)) + call strcpy (extn, fname[n+1], maxch-n) +end diff --git a/sys/qpoe/qpoe.h b/sys/qpoe/qpoe.h new file mode 100644 index 00000000..41d07059 --- /dev/null +++ b/sys/qpoe/qpoe.h @@ -0,0 +1,115 @@ +# QPOE.H -- QPOE data definitions (private to the package). + +# Size limiting definitions. +define DEF_BLOCKFACTOR 1.0 # default block factor for image matrix +define DEF_BUCKETLEN 1024 # def nevents per bucket +define DEF_FMMAXLFILES 128 # def maxlfile per datafile +define DEF_FMMAXPTPAGES 256 # def maxptpages per datafile +define DEF_FMPAGESIZE 512 # def datafile page size +define DEF_FMCACHESIZE 8 # def buffer cache size +define DEF_STINDEXLEN 100 # def symtab hash index len +define DEF_STSTABLEN 2048 # initial symbol table len +define DEF_STSBUFSIZE 2048 # initial string buf size +define DEF_MAXPUSHBACK 8192 # max pushed back chars (macros) +define DEF_OPTBUFSIZE (512*512*2) # default buffer size for IMIO/QPF/FIO +define MAX_INDIR 20 # max macro indirection +define MAX_REDEF 20 # max entries for a symbol +define MAX_FIELDS 50 # max fields in a user structure +define INC_STRLEN 32 # unit of storage for strings +define LEN_PVAL 64 # max TY_USER struct size (in doubles) +define SZ_QPDFNAME 255 # max size QPOE filename +define SZ_TEXTBUF 2048 # handy text buffer for macro expansion +define SZ_TOKBUF 256 # token buffer size + +# Magic numbers. +define LF_QPOE 1 # QPOE file header and symbol table +define LF_STATICPARS 2 # static (fixed size) params +define QPOE_MAGIC 121120B # QPOE magic code (descriptor type) +define QPOE_VERSION 101 # QPOE interface version number +define QPOE_TITLE "QPOE-V1.2" # title string, for symbol table +define QPOE_EXTN ".qp" # QPOE file extension +define QPOE_MACROEXTN ".qpm" # QPOE macro definitions file extension +define QPWCS "qpwcs" # header parameter for default WCS +define IMMEDIATE 0 # for qp_sizeof +define INSTANCEOF 1 # for qp_sizeof + +# The main QPOE descriptor. +define LEN_QPDES 160 +define QP_MAGIC Memi[$1] # descriptor type code +define QP_VERSION Memi[$1+1] # QPOE version number +define QP_ACTIVE Memi[$1+2] # descriptor fully activated +define QP_FM Memi[$1+3] # datafile handle +define QP_ST Memi[$1+4] # datafile symbol table handle +define QP_QM Memi[$1+5] # global QPOE symbol table handle +define QP_MODE Memi[$1+6] # datafile access mode +define QP_OQP Memi[$1+7] # o_qp, if new copy file +define QP_EXPBLEN Memi[$1+8] # QPEX program buffer length +define QP_EXDBLEN Memi[$1+9] # QPEX data buffer length +define QP_EXMAXFRLLEN Memi[$1+10] # QPEX max FRLUT length +define QP_EXMAXRRLLEN Memi[$1+11] # QPEX max RRLUT length +define QP_EXLMINRANGES Memi[$1+12] # QPEX min ranges before using LUT +define QP_EXLSCALE Memi[$1+13] # QPEX scale nranges to LUT bins +define QP_SZPBBUF Memi[$1+14] # size of pushback buffer for macros +define QP_BUCKETLEN Memi[$1+15] # QPIO event file bucket size +define QP_FMMAXLFILES Memi[$1+16] # FMIO maxlfiles +define QP_FMMAXPTPAGES Memi[$1+17] # FMIO maxptpages +define QP_FMPAGESIZE Memi[$1+18] # FMIO pagesize +define QP_FMCACHESIZE Memi[$1+19] # FMIO buffer cache size +define QP_STINDEXLEN Memi[$1+20] # SYMTAB hash index length +define QP_STSTABLEN Memi[$1+21] # SYMTAB stab len (start) +define QP_STSBUFSIZE Memi[$1+22] # SYMTAB sbuf size (start) +define QP_STOFFSET Memi[$1+23] # lfile offset of stored symbol table +define QP_MODIFIED Memi[$1+24] # QPOE descriptor has been modified +define QP_DEBUG Memi[$1+25] # global debug level (debug messages) +define QP_XBLOCK Memr[P2R($1+26)]# default X blocking factor for QPIO +define QP_YBLOCK Memr[P2R($1+27)]# default Y blocking factor for QPIO +define QP_OPTBUFSIZE Memi[$1+28] # optimum buffer size for IMIO/QPF/FIO +define QP_NODEFFILT Memi[$1+29] # disable use of default filter +define QP_NODEFMASK Memi[$1+30] # disable use of default mask +define QP_DFNAME Memc[P2C($1+31)] # QPOE filename (for messages) + +# Symbol descriptor. +define LEN_SYMBOL 9 +define S_FLAGS Memi[$1] # integer flag word +define S_DTYPE Memi[$1+1] # datatype code +define S_DSYM Memi[$1+2] # offset of domain symbol if TY_USER +define S_NELEM Memi[$1+3] # number of elements of dtype +define S_MAXELEM Memi[$1+4] # allocated length +define S_SZELEM Memi[$1+5] # elsize, chars (primary domains only) +define S_COMMENT Memi[$1+6] # pointer to comment string in sbuf +define S_LFILE Memi[$1+7] # lfile where value is stored +define S_OFFSET Memi[$1+8] # char offset of value in lfile + +# Symbol flags. +define SF_DELETED 0001B # symbol has been deleted +define SF_INHERIT 0002B # inherit in NEW_COPY mode +define SF_MACARGS 0004B # macro symbol has symbolic arguments + +# QPOE special datatypes. +define SPPTYPES "bcsilrdx" # index is SPP TY_xxx type code +define TY_MACRO 15 # datafile local macro define +define TY_OPAQUE 16 # opaque (typeless) binary type +define TY_USER 17 # some user defined type + +# Lexical tokens. +define TOK_IDENTIFIER (-99) +define TOK_NUMBER (-98) +define TOK_STRING (-97) +define TOK_COMMAND (-96) +define TOK_PLUSEQUALS (-95) +define TOK_COLONEQUALS (-94) + +# QPOE header as stored in datafile. +define LEN_QPH 32 +define QPH_MAGIC Memi[$1] +define QPH_VERSION Memi[$1+1] +define QPH_STOFFSET Memi[$1+2] + +# Domain descriptor structure. +define LEN_DDDES 110 +define DD_STRUCTLEN Memi[$1] # structure length, su +define DD_NFIELDS Memi[$1+1] # number of fields in user structure +define DD_XFIELD Memi[$1+2] # field assigned to coordinate "x" +define DD_YFIELD Memi[$1+3] # field assigned to coordinate "y" +define DD_FOFFSET Memi[$1+10+$2-1]# array of field offsets +define DD_FTYPE Memi[$1+60+$2-1]# array of field datatypes diff --git a/sys/qpoe/qpopen.x b/sys/qpoe/qpopen.x new file mode 100644 index 00000000..d2b7e0b4 --- /dev/null +++ b/sys/qpoe/qpopen.x @@ -0,0 +1,132 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "qpoe.h" +include "qpio.h" + +# QP_OPEN -- Open or create a QPOE datafile. This routine must be called +# before the poefile can be accessed. In the case of a create, the file +# parameters are not fixed until the first i/o or header access occurs, +# allowing one to use QP_SET calls to modify the file parameters after the +# open. + +pointer procedure qp_open (poefile, mode, o_qp) + +char poefile[ARB] #I QPOE file to be opened +int mode #I file access mode +pointer o_qp #I reference file, if NEW_COPY + +int fmmode, fd, n +pointer sp, qph, qp, fname, fm + +real qp_getr() +pointer fm_open(), strestore(), qm_access() +int fm_fopen(), read(), fm_stati(), qp_accessf() +errchk fm_open, strestore, fm_fopen, seek, read +errchk calloc, syserrs, qm_access + +string s_defblock DEF_BLOCK +string s_defxblock DEF_XBLOCK +string s_defyblock DEF_YBLOCK + +begin + call smark (sp) + call salloc (qph, LEN_QPH, TY_STRUCT) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + # Construct the filename (with extension .qp) of the poefile. + call qp_mkfname (poefile, QPOE_EXTN, Memc[fname], SZ_PATHNAME) + + # Open or create the poefile via the file manager. + fmmode = mode + if (mode == NEW_COPY) + fmmode = NEW_FILE + fm = fm_open (Memc[fname], fmmode) + + # Allocate the QPOE descriptor. + call calloc (qp, LEN_QPDES, TY_STRUCT) + call strcpy (Memc[fname], QP_DFNAME(qp), SZ_QPDFNAME) + + # Access the global macro database, and set the default values of + # all interface and datafile parameters. + + QP_QM(qp) = qm_access() + call qm_setdefaults (QP_QM(qp), qp) + + QP_MODE(qp) = mode + QP_OQP(qp) = o_qp + QP_FM(qp) = fm + + if (mode == NEW_FILE || mode == NEW_COPY) { + # Initialize the descriptor for a new poefile. The file + # attributes are not fixed until the file is accessed, to + # allow time to change the defaults with qp_seti. + + QP_MAGIC(qp) = QPOE_MAGIC + QP_VERSION(qp) = QPOE_VERSION + + if (mode == NEW_COPY) { + # Inherit datafile defaults from parent file. + QP_BUCKETLEN(qp) = QP_BUCKETLEN(o_qp) + QP_FMMAXLFILES(qp) = QP_FMMAXLFILES(o_qp) + QP_FMMAXPTPAGES(qp) = QP_FMMAXPTPAGES(o_qp) + QP_FMPAGESIZE(qp) = QP_FMPAGESIZE(o_qp) + QP_FMCACHESIZE(qp) = QP_FMCACHESIZE(o_qp) + QP_STINDEXLEN(qp) = QP_STINDEXLEN(o_qp) + QP_STSTABLEN(qp) = QP_STSTABLEN(o_qp) + QP_STSBUFSIZE(qp) = QP_STSBUFSIZE(o_qp) + } + + QP_ACTIVE(qp) = NO + + } else { + # Open an existing poefile. The encoded QPOE header and + # symbol table are stored in a binary lfile in the datafile. + + fd = fm_fopen (fm, LF_QPOE, READ_ONLY, BINARY_FILE) + + # Read the QPOE file header. + n = LEN_QPH * SZ_STRUCT + call aclri (Memi[qph], LEN_QPH) + if (read (fd, Memi[qph], n) < n) + call syserrs (SYS_QPBADFILE, QP_DFNAME(qp)) + call miiupk32 (Memi[qph], Memi[qph], LEN_QPH, TY_STRUCT) + + QP_MAGIC(qp) = QPH_MAGIC(qph) + QP_VERSION(qp) = QPH_VERSION(qph) + QP_STOFFSET(qp) = QPH_STOFFSET(qph) + + if (QP_MAGIC(qp) != QPOE_MAGIC) + call syserrs (SYS_QPBADFILE, QP_DFNAME(qp)) + + # Read the stored symbol table. + call seek (fd, QP_STOFFSET(qp)) + QP_ST(qp) = strestore (fd) + + # Initialize any remaining QP descriptor parameters. + QP_FMPAGESIZE(qp) = fm_stati (fm, FM_PAGESIZE) + call fm_seti (fm, FM_FCACHESIZE, DEF_FMCACHESIZE) + QP_ACTIVE(qp) = YES + + # See if the default block factor is set in the datafile header. + if (qp_accessf (qp, s_defblock) == YES) { + QP_XBLOCK(qp) = qp_getr (qp, s_defblock) + QP_YBLOCK(qp) = QP_XBLOCK(qp) + } + if (qp_accessf (qp, s_defxblock) == YES) + QP_XBLOCK(qp) = qp_getr (qp, s_defxblock) + if (qp_accessf (qp, s_defyblock) == YES) + QP_YBLOCK(qp) = qp_getr (qp, s_defyblock) + + call close (fd) + } + + # Allow any interface parameters set explicitly in global macro SET + # statements to override the inherited or datafile values set above. + + call qm_upddefaults (QP_QM(qp), qp) + + call sfree (sp) + return (qp) +end diff --git a/sys/qpoe/qpparse.x b/sys/qpoe/qpparse.x new file mode 100644 index 00000000..2bbd5cea --- /dev/null +++ b/sys/qpoe/qpparse.x @@ -0,0 +1,70 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# QP_PARSE -- Parse a QPOE/QPIO specification into the root (poefile) name +# and event list filter expression fields. +# +# Syntax: root[filter] +# +# where the filter spec is optional. + +procedure qp_parse (qpspec, root, sz_root, filter, sz_filter) + +char qpspec[ARB] #I full event list specification +char root[sz_root] #O receives root name +int sz_root #I max chars in root name +char filter[sz_filter] #O receives filter +int sz_filter #I max chars in filter name + +int level, ip, op, ch + +begin + ip = 1 + op = 1 + + # Extract root name. The first (unescaped) [ marks the start of + # the filter field. + + for (ch=qpspec[ip]; ch != EOS && ch != '['; ch=qpspec[ip]) { + if (ch == '\\' && qpspec[ip+1] == '[') { + root[op] = '\\' + op = op + 1 + root[op] = '[' + ip = ip + 1 + } else + root[op] = ch + + op = min (sz_root, op + 1) + ip = ip + 1 + } + + root[op] = EOS + level = 0 + op = 1 + + # Extract the [] bracketed filter expression, allowing for nested + # brackets. + + for (ch=qpspec[ip]; ch != EOS; ch=qpspec[ip]) { + if (ch == '[') + level = level + 1 + else if (ch == ']') + level = level - 1 + + filter[op] = ch + op = min (sz_filter, op + 1) + + ip = ip + 1 + if (level <= 0) + break + } + + # Add closing brace if the user left it off. + if (op > 1 && ch != ']') { + filter[op] = ']' + op = min (sz_filter, op + 1) + } + + filter[op] = EOS +end diff --git a/sys/qpoe/qpparsefl.x b/sys/qpoe/qpparsefl.x new file mode 100644 index 00000000..566274fb --- /dev/null +++ b/sys/qpoe/qpparsefl.x @@ -0,0 +1,149 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "qpoe.h" +include "qpex.h" + +# QP_PARSEFL -- Parse the field list, or declarations string for a user +# defined datatype (structure or domain). +# +# Syntax: { type1, type2, ..., typeN } +# +# e.g., {d,s:x,s:y,s,s,s,s} (Rosat/PROS event structure) +# +# where the TYPEi are primitive types, e.g., "r" or "real", "i" or "int", +# etc. Selected fields may have ":x" or ":y" appended to indicate that these +# are the default coordinate fields to be used for position based extraction. +# Fields will be automatically aligned as necessary, and the computed structure +# size will be forced to be an integral multiple of the largest datatype +# within the structure, to ensure proper alignment in arrays of the structures. + +int procedure qp_parsefl (qp, fieldlist, dd) + +pointer qp #I QPOE descriptor +char fieldlist[ARB] #I field list defining new datatype (domain) +pointer dd #U pointer to domain descriptor + +pointer sp, tokbuf, dsym, in +int nfields, offset, maxsize, xfield, yfield, token, dtype, fsize + +pointer qp_opentext() +int qp_gettok(), qp_nexttok(), sizeof(), qp_dtype() +errchk qp_gettok, qp_opentext, qp_nexttok +string qperr "QPOE structdef" +define nextfield_ 91 + +begin + call smark (sp) + call salloc (tokbuf, SZ_TOKBUF, TY_CHAR) + + # Open declarations string for non macro expanded token input. + in = qp_opentext (NULL, fieldlist) + + # Advance to structure terms list. + while (qp_gettok (in, Memc[tokbuf], SZ_TOKBUF) != EOF) + if (Memc[tokbuf] == '{') + break + + nfields = 0 + offset = 0 + maxsize = 0 + xfield = 0 + yfield = 0 + + # Process the structure terms list. + repeat { + token = qp_gettok (in, Memc[tokbuf], SZ_TOKBUF) + + switch (token) { # { + case EOF, '}': + break + + case TOK_IDENTIFIER: + # Get field datatype and size. + dtype = qp_dtype (qp, Memc[tokbuf], dsym) + if (dtype < TY_BOOL || dtype > TY_COMPLEX) { + call eprintf ("%s: bad field type `%s'\n") + call pargstr (qperr) + call pargstr (Memc[tokbuf]) + goto nextfield_ + } else + fsize = sizeof (dtype) + + # Output field descriptor. + nfields = nfields + 1 + if (nfields > MAX_FIELDS) { + call eprintf ("%s: too many fields `%s'\n") + call pargstr (qperr) + call pargstr (Memc[tokbuf]) + break + } + DD_FOFFSET(dd,nfields) = (offset + fsize-1) / fsize + DD_FTYPE(dd,nfields) = dtype + + # Update structure size parameters. + offset = (DD_FOFFSET(dd,nfields) * fsize) + fsize + maxsize = max (maxsize, fsize) + + # Process any :[XY] field modifiers. + if (qp_nexttok(in) == ':') { + repeat { + token = qp_gettok (in, Memc[tokbuf], SZ_TOKBUF) + switch (Memc[tokbuf]) { + case ':': + next + case 'x': + if (xfield != 0) { + call eprintf ("%s: duplicate X field `%s'\n") + call pargstr (qperr) + call pargstr (Memc[tokbuf]) + } + xfield = nfields + break + case 'y': + if (yfield != 0) { + call eprintf ("%s: duplicate Y field `%s'\n") + call pargstr (qperr) + call pargstr (Memc[tokbuf]) + } + yfield = nfields + break + default: + call eprintf ("%s: unknown : field modifier `%s'\n") + call pargstr (qperr) + call pargstr (Memc[tokbuf]) + } + } + goto nextfield_ + } + case ',': + next + default: + call eprintf ("%s: unexpected token `%s'\n") + call pargstr (qperr) + call pargstr (Memc[tokbuf]) + } + +nextfield_ + # Read and discard tokens until we get to the next field. + while (qp_gettok (in, Memc[tokbuf], SZ_TOKBUF) != EOF) + if (Memc[tokbuf] == ',') + break + } + + # Complete the domain descriptor initialization. + DD_NFIELDS(dd) = nfields + DD_XFIELD(dd) = xfield + DD_YFIELD(dd) = yfield + + # Pad the struct size to an integral multiple of the max field size. + if (nfields > 0) { + maxsize = max (SZ_STRUCT, maxsize) + DD_STRUCTLEN(dd) = (offset+maxsize-1)/maxsize*maxsize / SZ_STRUCT + } else + DD_STRUCTLEN(dd) = 0 + + call qp_closetext (in) + call sfree (sp) + + return (nfields) +end diff --git a/sys/qpoe/qppclose.x b/sys/qpoe/qppclose.x new file mode 100644 index 00000000..7a0bc9ab --- /dev/null +++ b/sys/qpoe/qppclose.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# QP_PCLOSE -- Close a parameter opened as a file with QP_POPEN. This +# differs from a simple call to fio.close in that the lfile used to store +# the parameter data is unlocked, as well as closing the file under FIO. + +procedure qp_pclose (fd) + +int fd #I file descriptor of QP_POPEN-ed parameter + +int lfile, type +pointer sp, lfname, fm +int fm_lfparse() + +begin + call smark (sp) + call salloc (lfname, SZ_FNAME, TY_CHAR) + + call fstats (fd, F_FILENAME, Memc[lfname], SZ_FNAME) + if (fm_lfparse (Memc[lfname], fm, lfile, type) != ERR) + call fm_unlock (fm, lfile) + + call close (fd) + call sfree (sp) +end diff --git a/sys/qpoe/qppopen.x b/sys/qpoe/qppopen.x new file mode 100644 index 00000000..4b0e2191 --- /dev/null +++ b/sys/qpoe/qppopen.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpoe.h" + +# QP_POPEN -- Open a variable-array type parameter as a file. A call to +# fio.close is used to close the file. Note that the varlen parameter, which +# is stored in its own lfile in the datafile, is opened directly as a file +# independently of the FMIO file buffer cache. Most QPOE parameter i/o is +# via the cache, hence mixing QP_POPEN calls with ordinary QPOE i/o on the +# same parameter at the same time could lead to loss of data integrity due +# to the same lfile being opened simultaneously on two different file +# descriptors. We ensure that the lfile is not in the file cache at qp_popen +# time, but no checks are made once the file has been opened. A FIO file +# descriptor is returned as the function value; CLOSE should be called to +# close the file descriptor when it is no longer needed. + +int procedure qp_popen (qp, param, mode, type) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +int mode #I file(param) access mode +int type #I file type, text or binary + +pointer sym +int fm_fopen() +pointer qp_gpsym() +errchk qp_gpsym, qp_addf(), fm_lockout, syserrs + +begin + if (QP_ACTIVE(qp) == NO) + call qp_bind (qp) + + # Lookup the parameter; make sure it is a varlen parameter. + # Create a new parameter if none exists and the mode is NEW_FILE. + + sym = qp_gpsym (qp, param) + if (sym == NULL) { + if (mode != NEW_FILE) + call syserrs (SYS_QPUKNPAR, param) + else { + # Create a new parameter. + if (type == TEXT_FILE) + call qp_addf (qp, param, "c", 0, "", 0) + else + call qp_addf (qp, param, "opaque", 0, "", 0) + sym = qp_gpsym (qp, param) + if (sym == NULL) + call syserrs (SYS_QPUKNPAR, param) + } + } else if (S_MAXELEM(sym) != 0) + call syserrs (SYS_QPPOPEN, param) + + # Place a lock on the file and then remove it, to cause an error + # if the lfile is already active in the file cache. + + call fm_lockout (QP_FM(qp), S_LFILE(sym)) + call fm_unlock (QP_FM(qp), S_LFILE(sym)) + + # Open the assigned lfile and return the file descriptor. + return (fm_fopen (QP_FM(qp), S_LFILE(sym), mode, type)) +end diff --git a/sys/qpoe/qpppar.x b/sys/qpoe/qpppar.x new file mode 100644 index 00000000..17d9496d --- /dev/null +++ b/sys/qpoe/qpppar.x @@ -0,0 +1,136 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "qpoe.h" + +# QP_PUTPARAM -- Lookup the named parameter in the symbol table and return +# a pointer to a buffer into which the scalar parameter value is to be +# placed. A subsequent call to QPOE_FLUSHPAR updates the parameter value +# in the datafile. A NULL pointer is returned if the parameter exists but +# does not currently have a value. The parameter datatype code is returned +# as the function value. + +int procedure qp_putparam (qp, param, o_pp) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +pointer o_pp #O pointer to parameter value + +bool first_time +pointer sp, key, fm, op +int loc_pval, loc_Mem, ip, ch, sz_elem +data first_time /true/ + +int elem +pointer pp, sym +bool put_value +double pval[LEN_PVAL+1] +common /qppval/ pval, sym, elem, pp, put_value + +pointer qp_gpsym() +int ctoi(), qp_sizeof() +errchk qp_bind, syserrs + +begin + call smark (sp) + call salloc (key, SZ_FNAME, TY_CHAR) + + if (QP_ACTIVE(qp) == NO) + call qp_bind (qp) + + fm = QP_FM(qp) + + # Compute pointer (Memc index) to the static pval buffer. + # Make sure that the computed pointer is double aligned. + + if (first_time) { + call zlocva (pval, loc_pval) + call zlocva (Memc, loc_Mem) + pp = (loc_pval+SZ_DOUBLE - loc_Mem) / SZ_DOUBLE * SZ_DOUBLE + 1 + put_value = false + first_time = false + } else if (put_value) + call qp_flushpar (qp) + + # Extract the primary parameter name, minus any whitespace and + # subscript (e.g., "param[elem]"). + + op = key + do ip = 1, SZ_FNAME { + ch = param[ip] + if (IS_WHITE(ch)) + next + else if (ch == '[') + break + Memc[op] = ch + op = op + 1 + } + Memc[op] = EOS + + # Determine the array element (default [1]). + elem = 1 + if (param[ip] == '[') { + ip = ip + 1 + if (ctoi (param, ip, elem) <= 0) + elem = 1 + } + + # Lookup the symbol in the symbol table. + sym = qp_gpsym (qp, Memc[key]) + if (sym == NULL) + call syserrs (SYS_QPUKNPAR, param) + + # Check to make sure storage for the parameter value exists, and + # set the parameter buffer pointer for the indicated datatype. + + sz_elem = qp_sizeof (qp, S_DTYPE(sym), sym, INSTANCEOF) + if (sz_elem > LEN_PVAL * SZ_DOUBLE) + call syserrs (SYS_QPPVALOVF, QP_DFNAME(qp)) + + if (elem < 1 || elem > S_MAXELEM(sym)) + o_pp = NULL + else if (S_DTYPE(sym) == TY_USER) + o_pp = (pp - 1) / SZ_STRUCT + 1 + else + o_pp = (pp - 1) / sz_elem + 1 + + # Set a flag to flush the value after the user has entered it. + put_value = true + + call sfree (sp) + return (S_DTYPE(sym)) +end + + +# QP_FLUSHPAR -- Update the saved parameter value in the indicated lfile. +# Repeated calls are harmless. + +procedure qp_flushpar (qp) + +pointer qp #I QPOE descriptor + +int sz_elem, fd +int qp_sizeof(), fm_getfd() +errchk fm_getfd, seek, write + +int elem +pointer pp, sym +bool put_value +double pval[LEN_PVAL+1] +common /qppval/ pval, sym, elem, pp, put_value + +begin + if (put_value) { + sz_elem = qp_sizeof (qp, S_DTYPE(sym), S_DSYM(sym), INSTANCEOF) + fd = fm_getfd (QP_FM(qp), S_LFILE(sym), READ_WRITE, 0) + + call seek (fd, S_OFFSET(sym) + (elem - 1) * sz_elem) + call write (fd, Memc[pp], sz_elem) + S_NELEM(sym) = max (S_NELEM(sym), elem) + QP_MODIFIED(qp) = YES + + call fm_retfd (QP_FM(qp), S_LFILE(sym)) + put_value = false + } +end diff --git a/sys/qpoe/qppstr.x b/sys/qpoe/qppstr.x new file mode 100644 index 00000000..9ab2b402 --- /dev/null +++ b/sys/qpoe/qppstr.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpoe.h" + +# QP_PSTR -- Update the string value of the named parameter. + +procedure qp_pstr (qp, param, strval) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +char strval[ARB] #I new string value + +pointer fm, sym +int fd, nchars + +pointer qp_gpsym() +int fm_getfd(), strlen() +errchk qp_bind, qp_gpsym, syserrs, fm_getfd, seek + +begin + if (QP_ACTIVE(qp) == NO) + call qp_bind (qp) + + fm = QP_FM(qp) + + # Lookup the symbol in the symbol table. + sym = qp_gpsym (qp, param) + if (sym == NULL) + call syserrs (SYS_QPUKNPAR, param) + else if (S_DTYPE(sym) != TY_CHAR) + call syserrs (SYS_QPBADCONV, param) + + # Update the value of the parameter in the datafile. + fd = fm_getfd (fm, S_LFILE(sym), READ_WRITE, 0) + call seek (fd, S_OFFSET(sym)) + + nchars = strlen (strval) + if (S_MAXELEM(sym) > 0) + nchars = min (S_MAXELEM(sym), nchars) + + call write (fd, strval, nchars) + S_NELEM(sym) = nchars + QP_MODIFIED(qp) = YES + + call fm_retfd (fm, S_LFILE(sym)) +end diff --git a/sys/qpoe/qpput.gx b/sys/qpoe/qpput.gx new file mode 100644 index 00000000..871b2943 --- /dev/null +++ b/sys/qpoe/qpput.gx @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../qpoe.h" + +# QP_PUT -- Set the value of the named header parameter. Automatic type +# conversion is performed where possible. While only scalar values can be +# set by this function, the scalar may be an element of a one-dimensional +# array, e.g., "param[N]". + +procedure qp_put$t (qp, param, value) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +PIXEL value #I scalar parameter value + +pointer pp +bool indef +int dtype +int qp_putparam() +errchk qp_putparam, syserrs + +begin + # Lookup the parameter and get a pointer to the value buffer. + dtype = qp_putparam (qp, param, pp) + if (pp == NULL) + call syserrs (SYS_QPNOVAL, param) + + if (QP_DEBUG(qp) > 1) { + call eprintf ("qp_put: `%s', TYP=(%d->%d), new value %g\n") + call pargstr (param) + call pargi (TY_PIXEL) + call pargi (dtype) + call parg$t (value) + } + + indef = IS_INDEF(value) + + # Set the parameter value. + switch (dtype) { + case TY_CHAR: + Memc[pp] = value + case TY_SHORT: + if (indef) + Mems[pp] = INDEFS + else + Mems[pp] = value + case TY_INT: + if (indef) + Memi[pp] = INDEFI + else + Memi[pp] = value + case TY_LONG: + if (indef) + Meml[pp] = INDEFL + else + Meml[pp] = value + case TY_REAL: + if (indef) + Memr[pp] = INDEFR + else + Memr[pp] = value + case TY_DOUBLE: + if (indef) + Memd[pp] = INDEFD + else + Memd[pp] = value + default: + call syserrs (SYS_QPBADCONV, param) + } + + # Update the parameter in the datafile. + call qp_flushpar (qp) +end diff --git a/sys/qpoe/qpputb.x b/sys/qpoe/qpputb.x new file mode 100644 index 00000000..da7f7ba8 --- /dev/null +++ b/sys/qpoe/qpputb.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpoe.h" + +# QP_PUTB -- Set the boolean value of the named header parameter. Type +# conversion is not permitted between boolean and the other data types. + +procedure qp_putb (qp, param, value) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +bool value #I scalar parameter value + +pointer pp +int qp_putparam() +errchk qp_putparam, syserrs + +begin + # Lookup the parameter and get a pointer to the value buffer. + if (qp_putparam (qp, param, pp) != TY_BOOL) + call syserrs (SYS_QPBADCONV, param) + else if (pp == NULL) + call syserrs (SYS_QPNOVAL, param) + + # Pass the new value. + Memb[pp] = value + + # Update the parameter in the datafile. + call qp_flushpar (qp) +end diff --git a/sys/qpoe/qpputx.x b/sys/qpoe/qpputx.x new file mode 100644 index 00000000..0ed73b35 --- /dev/null +++ b/sys/qpoe/qpputx.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpoe.h" + +# QP_PUTX -- Set the complex value of the named header parameter. Type +# conversion is not permitted between complex and the other data types. + +procedure qp_putx (qp, param, value) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +complex value #I scalar parameter value + +pointer pp +int qp_putparam() +errchk qp_putparam, syserrs + +begin + # Lookup the parameter and get a pointer to the value buffer. + if (qp_putparam (qp, param, pp) != TY_COMPLEX) + call syserrs (SYS_QPBADCONV, param) + else if (pp == NULL) + call syserrs (SYS_QPNOVAL, param) + + # Pass the new value. + Memx[pp] = value + + # Update the parameter in the datafile. + call qp_flushpar (qp) +end diff --git a/sys/qpoe/qpqueryf.x b/sys/qpoe/qpqueryf.x new file mode 100644 index 00000000..c8de988a --- /dev/null +++ b/sys/qpoe/qpqueryf.x @@ -0,0 +1,91 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "qpoe.h" + +# QP_QUERYF -- Get information describing the named parameter. The current +# vector length of the parameter is returned as the function value, or ERR +# if the parameter does not exist. + +int procedure qp_queryf (qp, param, datatype, maxelem, comment, flags) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +char datatype[SZ_DATATYPE] #O parameter data type +int maxelem #O allocated length of parameter +char comment[SZ_COMMENT] #O comment describing parameter +int flags #O parameter flag word + +int junk +pointer sym, dsym, ip, st + +int qp_gstr() +pointer qp_gpsym(), stname(), strefstab(), strefsbuf() +errchk qp_gpsym, stname, syserrs + +begin + if (QP_ACTIVE(qp) == NO) + call qp_bind (qp) + + st = QP_ST(qp) + + # Locate the symbol. + sym = qp_gpsym (qp, param) + if (sym == NULL) + return (ERR) + + flags = S_FLAGS(sym) + maxelem = S_MAXELEM(sym) + + # Output the symbolic datatype. + datatype[2] = EOS + switch (S_DTYPE(sym)) { + case TY_BOOL: + datatype[1] = 'b' + case TY_CHAR: + datatype[1] = 'c' + case TY_SHORT: + datatype[1] = 's' + case TY_INT: + datatype[1] = 'i' + case TY_LONG: + datatype[1] = 'l' + case TY_REAL: + datatype[1] = 'r' + case TY_DOUBLE: + datatype[1] = 'd' + case TY_COMPLEX: + datatype[1] = 'x' + + case TY_MACRO: + call strcpy ("macro", datatype, SZ_DATATYPE) + case TY_OPAQUE: + call strcpy ("opaque", datatype, SZ_DATATYPE) + + case TY_USER: + # User defined type: if S_DSYM is NULL, this is the domain entry + # itself, else the domain name is the datatype of the parameter. + # If this is a primary domain entry, the field list defining the + # structure is stored as the string value of the parameter. + + if (S_DSYM(sym) == NULL) + junk = qp_gstr (qp, param, datatype, SZ_DATATYPE) + else { + dsym = strefstab (st, S_DSYM(sym)) + call strcpy (Memc[stname(st,dsym)], datatype, SZ_DATATYPE) + } + + default: + call strcpy ("", datatype, SZ_DATATYPE) + } + + # Output the comment field. + if (S_COMMENT(sym) != NULL) { + ip = strefsbuf (st, S_COMMENT(sym)) + call strcpy (Memc[ip], comment, SZ_COMMENT) + } else + comment[1] = EOS + + return (S_NELEM(sym)) +end diff --git a/sys/qpoe/qpread.x b/sys/qpoe/qpread.x new file mode 100644 index 00000000..c25fe506 --- /dev/null +++ b/sys/qpoe/qpread.x @@ -0,0 +1,80 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpoe.h" + +# QP_READ -- Read a range of elements from a parameter. Works for any +# parameter, including scalar parameters and both static and variable +# length array valued parameters. Automatic datatype conversion is +# performed for the primitive types. + +int procedure qp_read (qp, param, buf, maxelem, first, datatype) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +char buf[ARB] #O user data buffer to receive data +int maxelem #I max number of data elements to read +int first #I first data element to read +char datatype[ARB] #I datatype to be returned + +pointer sp, fm, sym, tbuf, isym, osym +int fd, sz_itype, sz_otype, nelem, itype, otype + +pointer qp_gpsym() +int fm_getfd(), qp_sizeof(), read(), qp_dtype() +errchk qp_bind, qp_gpsym, fm_getfd, seek, read, syserrs + +begin + if (QP_ACTIVE(qp) == NO) + call qp_bind (qp) + + fm = QP_FM(qp) + otype = qp_dtype (qp, datatype, osym) + + # Lookup the symbol in the symbol table. + sym = qp_gpsym (qp, param) + if (sym == NULL) + call syserrs (SYS_QPUKNPAR, param) + else { + itype = S_DTYPE(sym) + isym = sym + } + + # Determine the number of inbounds elements. + nelem = max(0, min(maxelem, S_NELEM(sym) - first + 1)) + if (first <= 0) + call syserrs (SYS_QPINDXOOR, param) + + # Verify that any type conversion is legal. + if (otype != itype) + if (min(otype,itype) < TY_CHAR || max(otype,itype) > TY_DOUBLE) + call syserrs (SYS_QPBADCONV, param) + + # Open the lfile and read the data segment. + fd = fm_getfd (fm, S_LFILE(sym), READ_ONLY, 0) + + if (nelem > 0) { + sz_itype = qp_sizeof (qp, itype, isym, IMMEDIATE) + sz_otype = qp_sizeof (qp, otype, osym, INSTANCEOF) + + # Read and output the data. + call seek (fd, S_OFFSET(sym) + (first - 1) * sz_itype) + if (sz_itype <= sz_otype) { + # Read the data directly into the user's buffer. + nelem = read (fd, buf, nelem * sz_itype) / sz_itype + if (nelem > 0 && otype != itype) + call acht (buf, buf, nelem, itype, otype) + } else { + # Read the data into a temporary buffer. + call smark (sp) + call salloc (tbuf, nelem * sz_itype, TY_CHAR) + nelem = read (fd, Memc[tbuf], nelem * sz_itype) / sz_itype + if (nelem > 0) + call acht (Memc[tbuf], buf, nelem, itype, otype) + call sfree (sp) + } + } + + call fm_retfd (fm, S_LFILE(sym)) + return (nelem) +end diff --git a/sys/qpoe/qprebuild.x b/sys/qpoe/qprebuild.x new file mode 100644 index 00000000..369eba1e --- /dev/null +++ b/sys/qpoe/qprebuild.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "qpoe.h" + +# QP_REBUILD -- Rebuild a poefile to reclaim unused space, and render storage +# elements logically contiguous to improve file access efficiency. + +procedure qp_rebuild (poefile) + +char poefile[ARB] #I poefile name +pointer sp, fname + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + call qp_mkfname (poefile, QPOE_EXTN, Memc[fname], SZ_PATHNAME) + call fm_rebuild (Memc[fname]) + + call sfree (sp) +end diff --git a/sys/qpoe/qprename.x b/sys/qpoe/qprename.x new file mode 100644 index 00000000..2287b0fd --- /dev/null +++ b/sys/qpoe/qprename.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "qpoe.h" + +# QP_RENAME -- Rename a poefile. + +procedure qp_rename (o_poefile, n_poefile) + +char o_poefile[ARB] #I old poefile name +char n_poefile[ARB] #I new poefile name + +pointer sp, o_fname, n_fname +string extn QPOE_EXTN + +begin + call smark (sp) + call salloc (o_fname, SZ_PATHNAME, TY_CHAR) + call salloc (n_fname, SZ_PATHNAME, TY_CHAR) + + call qp_mkfname (o_poefile, extn, Memc[o_fname], SZ_PATHNAME) + call qp_mkfname (n_poefile, extn, Memc[n_fname], SZ_PATHNAME) + call fm_rename (Memc[o_fname], Memc[n_fname]) + + call sfree (sp) +end diff --git a/sys/qpoe/qprenamef.x b/sys/qpoe/qprenamef.x new file mode 100644 index 00000000..39abb915 --- /dev/null +++ b/sys/qpoe/qprenamef.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpoe.h" + +# QP_RENAMEF -- Rename a header parameter. It is an error if the named header +# parameter does not exist, or if the new name would redefine another symbol. + +procedure qp_renamef (qp, param, newname) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +char newname[ARB] #I new parameter name + +pointer sym, nsym, st +pointer qp_gpsym(), stenter() +errchk qp_gpsym, syserrs, stenter + +begin + if (QP_ACTIVE(qp) == NO) + call qp_bind (qp) + + st = QP_ST(qp) + + # Access the named parameter. + sym = qp_gpsym (qp, param) + if (sym == NULL) + call syserrs (SYS_QPUKNPAR, param) + + # Check for a parameter redefinition. + nsym = qp_gpsym (qp, newname) + if (nsym != NULL) + call syserrs (SYS_QPREDEF, newname) + + # Rename the symbol. We cannot just edit the name, as the hash + # function would not be able to find it. We must create a new + # symstruct and replace the old one by it. The stenter can cause + # reallocation of the symbol table, so we need to recompute the + # symbol pointer. + + nsym = stenter (st, newname, LEN_SYMBOL) + sym = qp_gpsym (qp, param) + + call amovi (Memi[sym], Memi[nsym], LEN_SYMBOL) + S_FLAGS(sym) = or (S_FLAGS(sym), SF_DELETED) + + QP_MODIFIED(qp) = YES +end diff --git a/sys/qpoe/qprlmerge.gx b/sys/qpoe/qprlmerge.gx new file mode 100644 index 00000000..410bb952 --- /dev/null +++ b/sys/qpoe/qprlmerge.gx @@ -0,0 +1,134 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../qpex.h" + +# QP_RLMERGE -- Merge (AND) two range lists. Only ranges which are +# common to both range lists are output. The number of ranges in the +# output range list is returned as the function value. + +int procedure qp_rlmerge$t (os,oe,olen, xs,xe,nx, ys,ye,ny) + +pointer os, oe #U output range list +int olen #U allocated length of OS, OE arrays + +PIXEL xs[ARB], xe[ARB] #I range list to be merged with +int nx #I number of ranges in X list +PIXEL ys[ARB], ye[ARB] #I range list to be merged with X +int ny #I number of ranges in Y list + +PIXEL o1, o2 +int nx_out, xi, yi, i +PIXEL qp_minval$t(), qp_maxval$t() +bool qp_lessthan$t() +errchk realloc + +begin + nx_out = 0 + if (nx <= 0 || ny <= 0) + return (0) + + xi = 1 + yi = 1 + + do i = 1, ARB { + # Find a pair of ranges which intersect. + repeat { + if (qp_lessthan$t (xe[xi], ys[yi])) { + if (xi >= nx) + return (nx_out) + else + xi = xi + 1 + } else if (qp_lessthan$t (ye[yi], xs[xi])) { + if (yi >= ny) + return (nx_out) + else + yi = yi + 1 + } else + break + } + + # Compute the intersection. + o1 = qp_maxval$t (xs[xi], ys[yi]) + o2 = qp_minval$t (xe[xi], ye[yi]) + + # Output the range. + if (nx_out + 1 > olen) { + olen = max (DEF_XLEN, olen * 2) + call realloc (os, olen, TY_PIXEL) + call realloc (oe, olen, TY_PIXEL) + } + + Mem$t[os+nx_out] = o1 + Mem$t[oe+nx_out] = o2 + nx_out = nx_out + 1 + + # Advance to the next range. + if (xi < nx && qp_lessthan$t (xe[xi], ye[yi])) + xi = xi + 1 + else if (yi < ny) + yi = yi + 1 + else + break + } + + return (nx_out) +end + + +# QP_MINVAL -- Return the lesser of two values, where either value can +# be an open range. + +PIXEL procedure qp_minval$t (x, y) + +PIXEL x #I first value +PIXEL y #I second value + +bool qp_lessthan$t() + +begin + if (qp_lessthan$t (x, y)) + return (x) + else + return (y) +end + + +# QP_MAXVAL -- Return the greater of two values, where either value can +# be an open range. + +PIXEL procedure qp_maxval$t (x, y) + +PIXEL x #I first value +PIXEL y #I second value + +bool qp_lessthan$t() + +begin + if (qp_lessthan$t (x, y)) + return (y) + else + return (x) +end + + +# QP_LESSTHAN -- Test if X is less than Y, where X and Y can be open +# range values. + +bool procedure qp_lessthan$t (x, y) + +PIXEL x #I first value +PIXEL y #I second value + +begin + if (IS_LEFT$T(x)) + return (!IS_LEFT$T(y)) + else if (IS_RIGHT$T(x)) + return (false) + else if (IS_LEFT$T(y)) + return (false) + else if (IS_RIGHT$T(y)) + return (true) + else + return (x < y) +end diff --git a/sys/qpoe/qpsavewcs.x b/sys/qpoe/qpsavewcs.x new file mode 100644 index 00000000..35293d62 --- /dev/null +++ b/sys/qpoe/qpsavewcs.x @@ -0,0 +1,35 @@ +include "qpoe.h" + +# QP_SAVEWCS -- Save the given WCS in the QPOE header, as a variable length +# binary array (machine independent) in the default WCS parameter QPWCS. + +procedure qp_savewcs (qp, mw) + +pointer qp #I QPOE descriptor +pointer mw #I MWCS descriptor + +pointer bp +int buflen, nchars +int mw_save(), qp_accessf() +errchk mw_save, qp_accessf, qp_addf, qp_write +string s_opaque "opaque" +string s_qpwcs QPWCS + +begin + bp = NULL + buflen = 0 + + # Encode the WCS as a machine independent binary array. + nchars = mw_save (mw, bp, buflen) + + # Save it in the QPOE header. + if (nchars > 0) { + if (qp_accessf (qp, s_qpwcs) == NO) + call qp_addf (qp, s_qpwcs, + s_opaque, 0, "World coordinate system", SF_INHERIT) + call qp_write (qp, s_qpwcs, Memc[bp], nchars, 1, s_opaque) + } + + if (bp != NULL) + call mfree (bp, TY_CHAR) +end diff --git a/sys/qpoe/qpseti.x b/sys/qpoe/qpseti.x new file mode 100644 index 00000000..3a18c35e --- /dev/null +++ b/sys/qpoe/qpseti.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpoe.h" + +# QP_SETI -- Set an QPOE integer parameter. + +procedure qp_seti (qp, param, value) + +pointer qp #I QPOE descriptor +int param #I parameter to be set +int value #I new value for parameter + +begin + switch (param) { + case QPOE_BLOCKFACTOR: + QP_XBLOCK(qp) = value + QP_YBLOCK(qp) = value + case QPOE_XBLOCKFACTOR: + QP_XBLOCK(qp) = value + case QPOE_YBLOCKFACTOR: + QP_YBLOCK(qp) = value + case QPOE_BUCKETLEN: + QP_BUCKETLEN(qp) = value + case QPOE_CACHESIZE: + QP_FMCACHESIZE(qp) = value + case QPOE_DATABUFLEN: + QP_EXDBLEN(qp) = value + case QPOE_DEBUGLEVEL: + QP_DEBUG(qp) = value + case QPOE_INDEXLEN: + QP_STINDEXLEN(qp) = value + case QPOE_LUTMINRANGES: + QP_EXLMINRANGES(qp) = value + case QPOE_LUTSCALE: + QP_EXLSCALE(qp) = value + case QPOE_MAXFRLUTLEN: + QP_EXMAXFRLLEN(qp) = value + case QPOE_MAXLFILES: + QP_FMMAXLFILES(qp) = value + case QPOE_MAXPTPAGES: + QP_FMMAXPTPAGES(qp) = value + case QPOE_MAXRRLUTLEN: + QP_EXMAXRRLLEN(qp) = value + case QPOE_MAXPUSHBACK: + QP_SZPBBUF(qp) = value + case QPOE_NODEFFILT: + QP_NODEFFILT(qp) = value + case QPOE_NODEFMASK: + QP_NODEFMASK(qp) = value + case QPOE_OPTBUFSIZE: + QP_OPTBUFSIZE(qp) = value + case QPOE_PAGESIZE: + QP_FMPAGESIZE(qp) = value + case QPOE_PROGBUFLEN: + QP_EXPBLEN(qp) = value + case QPOE_SBUFSIZE: + QP_STSBUFSIZE(qp) = value + case QPOE_STABLEN: + QP_STSTABLEN(qp) = value + } +end diff --git a/sys/qpoe/qpsetr.x b/sys/qpoe/qpsetr.x new file mode 100644 index 00000000..9378912f --- /dev/null +++ b/sys/qpoe/qpsetr.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpoe.h" + +# QP_SETR -- Set an QPOE real valued parameter. + +procedure qp_setr (qp, param, value) + +pointer qp #I QPOE descriptor +int param #I parameter to be set +real value #I new value for parameter + +begin + switch (param) { + case QPOE_BLOCKFACTOR: + QP_XBLOCK(qp) = value + QP_YBLOCK(qp) = value + case QPOE_XBLOCKFACTOR: + QP_XBLOCK(qp) = value + case QPOE_YBLOCKFACTOR: + QP_YBLOCK(qp) = value + } +end diff --git a/sys/qpoe/qpsizeof.x b/sys/qpoe/qpsizeof.x new file mode 100644 index 00000000..bfa1698f --- /dev/null +++ b/sys/qpoe/qpsizeof.x @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "qpoe.h" + +# QP_SIZEOF -- Determine the size in chars of a QPOE datatype. This may +# be one of the special datatypes (user defined record types), or a primitive +# type. In the case of a special type, the REFTYPE flag specifies whether +# the size of the value of the type variable itself (always SZ_CHAR) is to be +# returned, or the size of an *instance* of the special type. + +int procedure qp_sizeof (qp, dtype, dsym, reftype) + +pointer qp #I QPOE descriptor +int dtype #I datatype code +pointer dsym #I domain descriptor, if type TY_USER +int reftype #I IMMEDIATE (domain itself) or INSTANCEOF + +pointer sym +int sizeof() +pointer strefstab() + +begin + switch (dtype) { + case TY_MACRO, TY_OPAQUE: + return (SZ_CHAR) + + case TY_USER: + # Size of a user defined structure (or the element size of the + # struct definition entry itself). + + if (dsym == NULL) { # {...} + return (SZ_CHAR) + } else if (S_DSYM(dsym) == NULL) { # reference is to + if (reftype == IMMEDIATE) # primary domain entry + return (SZ_CHAR) + else + return (S_SZELEM(dsym)) + } else { # instance of domain + sym = strefstab (QP_ST(qp), S_DSYM(dsym)) + return (S_SZELEM(sym)) + } + + default: + return (sizeof (dtype)) + } +end diff --git a/sys/qpoe/qpstati.x b/sys/qpoe/qpstati.x new file mode 100644 index 00000000..df8d176c --- /dev/null +++ b/sys/qpoe/qpstati.x @@ -0,0 +1,76 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpoe.h" + +# QP_STATI -- Get the value of an QPOE integer parameter. + +int procedure qp_stati (qp, param) + +pointer qp #I QPOE descriptor +int param #I parameter to be queried + +bool fp_equalr() + +begin + switch (param) { + case QPOE_BLOCKFACTOR: # standard params + if (fp_equalr (QP_XBLOCK(qp), QP_YBLOCK(qp))) + return (QP_XBLOCK(qp)) + else + return (ERR) + case QPOE_XBLOCKFACTOR: + return (QP_XBLOCK(qp)) + case QPOE_YBLOCKFACTOR: + return (QP_YBLOCK(qp)) + case QPOE_BUCKETLEN: + return (QP_BUCKETLEN(qp)) + case QPOE_CACHESIZE: + return (QP_FMCACHESIZE(qp)) + case QPOE_DATABUFLEN: + return (QP_EXDBLEN(qp)) + case QPOE_DEBUGLEVEL: + return (QP_DEBUG(qp)) + case QPOE_INDEXLEN: + return (QP_STINDEXLEN(qp)) + case QPOE_MAXLFILES: + return (QP_FMMAXLFILES(qp)) + case QPOE_MAXPTPAGES: + return (QP_FMMAXPTPAGES(qp)) + case QPOE_MAXFRLUTLEN: + return (QP_EXMAXFRLLEN(qp)) + case QPOE_MAXRRLUTLEN: + return (QP_EXMAXRRLLEN(qp)) + case QPOE_LUTMINRANGES: + return (QP_EXLMINRANGES(qp)) + case QPOE_LUTSCALE: + return (QP_EXLSCALE(qp)) + case QPOE_MAXPUSHBACK: + return (QP_SZPBBUF(qp)) + case QPOE_NODEFFILT: + return (QP_NODEFFILT(qp)) + case QPOE_NODEFMASK: + return (QP_NODEFMASK(qp)) + case QPOE_OPTBUFSIZE: + return (QP_OPTBUFSIZE(qp)) + case QPOE_PAGESIZE: + return (QP_FMPAGESIZE(qp)) + case QPOE_PROGBUFLEN: + return (QP_EXPBLEN(qp)) + case QPOE_SBUFSIZE: + return (QP_STSBUFSIZE(qp)) + case QPOE_STABLEN: + return (QP_STSTABLEN(qp)) + + case QPOE_FM: # read-only params + return (QP_FM(qp)) + case QPOE_MODE: + return (QP_MODE(qp)) + case QPOE_ST: + return (QP_ST(qp)) + case QPOE_VERSION: + return (QP_VERSION(qp)) + } + + return (ERR) +end diff --git a/sys/qpoe/qpstatr.x b/sys/qpoe/qpstatr.x new file mode 100644 index 00000000..0b3aec99 --- /dev/null +++ b/sys/qpoe/qpstatr.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpoe.h" + +# QP_STATR -- Get the value of an QPOE real parameter. + +real procedure qp_statr (qp, param) + +pointer qp #I QPOE descriptor +int param #I parameter to be queried + +bool fp_equalr() + +begin + switch (param) { + case QPOE_BLOCKFACTOR: # standard params + if (fp_equalr (QP_XBLOCK(qp), QP_YBLOCK(qp))) + return (QP_XBLOCK(qp)) + else + return (ERR) + case QPOE_XBLOCKFACTOR: + return (QP_XBLOCK(qp)) + case QPOE_YBLOCKFACTOR: + return (QP_YBLOCK(qp)) + } + + return (ERR) +end diff --git a/sys/qpoe/qpsync.x b/sys/qpoe/qpsync.x new file mode 100644 index 00000000..692136d6 --- /dev/null +++ b/sys/qpoe/qpsync.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "qpoe.h" + +# QP_SYNC -- Update the poefile on disk. + +procedure qp_sync (qp) + +pointer qp #I QPOE descriptor + +int n, fd +pointer sp, qph +int fm_fopen() +errchk qp_flushpar, fm_fopen, write, stsave + +begin + # Flush the put-parameter buffer. + call qp_flushpar (qp) + + # Update the QPOE descriptor and symbol table in the datafile. + if (QP_MODIFIED(qp) != NO) { + call smark (sp) + call salloc (qph, LEN_QPH, TY_STRUCT) + call aclri (Memi[qph], LEN_QPH) + + QPH_MAGIC(qph) = QP_MAGIC(qp) + QPH_VERSION(qph) = QPOE_VERSION + QPH_STOFFSET(qph) = LEN_QPH * SZ_STRUCT + 1 + + # The encoded QPOE header and symbol table are stored in a + # binary lfile in the datafile. + + fd = fm_fopen (QP_FM(qp), LF_QPOE, NEW_FILE, BINARY_FILE) + + # Update the QPOE file header. + n = LEN_QPH * SZ_STRUCT + call miipak32 (Memi[qph], Memi[qph], LEN_QPH, TY_STRUCT) + call write (fd, Memi[qph], n) + + # Update the symbol table. + call stsqueeze (QP_ST(qp)) + call stsave (QP_ST(qp), fd) + + QP_MODIFIED(qp) = NO + call close (fd) + call sfree (sp) + } + + # Update the datafile itself. + call fm_fcsync (QP_FM(qp)) +end diff --git a/sys/qpoe/qpwrite.x b/sys/qpoe/qpwrite.x new file mode 100644 index 00000000..dc5d4dab --- /dev/null +++ b/sys/qpoe/qpwrite.x @@ -0,0 +1,79 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "qpoe.h" + +# QP_WRITE -- Write to a range of elements in a parameter. Works for any +# parameter, including scalar parameters and both static and variable +# length array valued parameters. Automatic datatype conversion is +# performed for the primitive types. + +procedure qp_write (qp, param, buf, nelem, first, datatype) + +pointer qp #I QPOE descriptor +char param[ARB] #I parameter name +char buf[ARB] #I user data buffer containing data +int nelem #I number of data elements to write +int first #I first data element to write to +char datatype[ARB] #I datatype of input data + +pointer sp, fm, sym, tbuf, isym, osym +int fd, sz_itype, sz_otype, last, otype, itype +errchk qp_bind, qp_gpsym, fm_getfd, seek, syserrs +int fm_getfd(), qp_sizeof(), qp_dtype() +pointer qp_gpsym() + +begin + if (nelem <= 0) + return + + if (QP_ACTIVE(qp) == NO) + call qp_bind (qp) + + itype = qp_dtype (qp, datatype, isym) + fm = QP_FM(qp) + + # Lookup the symbol in the symbol table. + sym = qp_gpsym (qp, param) + if (sym == NULL) + call syserrs (SYS_QPUKNPAR, param) + else { + otype = S_DTYPE(sym) + osym = sym + } + + sz_itype = qp_sizeof (qp, itype, isym, INSTANCEOF) + sz_otype = qp_sizeof (qp, otype, osym, IMMEDIATE) + last = first + nelem - 1 + + # Check that the write is inbounds. + if (first <= 0 || (S_MAXELEM(sym) > 0 && last > S_MAXELEM(sym))) + call syserrs (SYS_QPINDXOOR, param) + + # Verify that any type conversion is legal. + if (otype != itype) + if (min(otype,itype) < TY_CHAR || max(otype,itype) > TY_DOUBLE) + call syserrs (SYS_QPBADCONV, param) + + # Open the lfile and update the data segment. + fd = fm_getfd (fm, S_LFILE(sym), READ_WRITE, 0) + call seek (fd, S_OFFSET(sym) + (first - 1) * sz_otype) + + # Output the data. + if (otype != itype) { + call smark (sp) + call salloc (tbuf, nelem * sz_otype, TY_CHAR) + call acht (buf, Memc[tbuf], nelem, itype, otype) + call write (fd, Memc[tbuf], nelem * sz_otype) + call sfree (sp) + } else + call write (fd, buf, nelem * sz_otype) + + # Update the array size if it got bigger. + if (last > S_NELEM(sym)) { + S_NELEM(sym) = last + QP_MODIFIED(qp) = YES + } + + call fm_retfd (fm, S_LFILE(sym)) +end diff --git a/sys/qpoe/zzdebug.x b/sys/qpoe/zzdebug.x new file mode 100644 index 00000000..5ca2de42 --- /dev/null +++ b/sys/qpoe/zzdebug.x @@ -0,0 +1,1696 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include +include "qpoe.h" +include "qpex.h" +include "qpio.h" + +# ZZDEBUG -- Debug routines for the QPOE package. + +task parsei = t_parsei, # parse integer range list + parser = t_parser, # parse floating range list + qpparse = t_qpparse, # test qp_parse + tokens = t_tokens, # test get token, macro replacement + comp = t_comp, # test QPEX compile + expand = t_expand, # perform macro expansion on text + recio = t_recio, # test general record i/o + newcopy = t_newcopy, # test inheritance + syms = t_syms, # dump symbol table + hlist = t_hlist, # list file header + dumpevl = t_dumpevl, # dump event list descriptor + mkpoe = t_mkpoe, # convert CFA poefile to QPOE poefile + testpoe = t_testpoe, # make a test QPOE file + countpoe = t_countpoe, # count photons in regions + tfilter = t_tfilter, # verify time filtering + plotpoe = t_plotpoe, # read and plot photons + sum = t_sum, # sum counts in an image section + setwcs = t_setwcs, # store a wcs in a qpoe file + setmask = t_setmask, # set the default mask + mergei = t_mergei, # test merging of range lists + clear = t_clear # clear the screen + +define SZ_EXPR 256 +define SZ_OBUF 128000 +define SZ_TBUF 8 +define MAX_EVENTS 8192 +define SZ_RLBUF 512 + + +# PARSEI -- Test integer range list decoding and expression optimization. + +procedure t_parsei() + +pointer xs, xe +char lbuf[SZ_LINE], left[SZ_TBUF], right[SZ_TBUF] +int nranges, xlen, i1, i2, i + +int getline(), qpex_parsei() +bool streq() + +begin + xlen = 0 + + repeat { + # Get next expression. + call printf ("parse> ") + call flush (STDOUT) + if (getline (STDIN, lbuf) == EOF) + break + else if (streq (lbuf, "bye\n")) + break + + # Parse the expression. + nranges = qpex_parsei (lbuf, xs, xe, xlen) + + # List the ranges. + do i = 1, nranges { + i1 = Memi[xs+i-1] + i2 = Memi[xe+i-1] + + if (IS_LEFTI(i1)) + call strcpy ("LEFT", left, SZ_TBUF) + else { + call sprintf (left, SZ_TBUF, "%d") + call pargi (i1) + } + + if (IS_RIGHTI(i2)) + call strcpy ("RIGHT", right, SZ_TBUF) + else { + call sprintf (right, SZ_TBUF, "%d") + call pargi (i2) + } + + call printf ("%2d: %8s %8s\n") + call pargi (i) + call pargstr (left) + call pargstr (right) + } + + call flush (STDOUT) + } + + call mfree (xs, TY_INT) + call mfree (xe, TY_INT) +end + + +# PARSER -- Test real range list decoding and expression optimization. + +procedure t_parser() + +pointer xs, xe +char lbuf[SZ_LINE] +int nranges, xlen, i + +int getline(), qpex_parser() +bool streq() + +begin + xlen = 0 + + repeat { + # Get next expression. + call printf ("parse> ") + call flush (STDOUT) + if (getline (STDIN, lbuf) == EOF) + break + else if (streq (lbuf, "bye\n")) + break + + # Parse the expression. + nranges = qpex_parser (lbuf, xs, xe, xlen) + do i = 1, nranges { + call printf ("%2d: %7g %7g\n") + call pargi (i) + call pargr (Memr[xs+i-1]) + call pargr (Memr[xe+i-1]) + } + call flush (STDOUT) + } + + call mfree (xs, TY_REAL) + call mfree (xe, TY_REAL) +end + + +# QPPARSE -- Test qp_parse. + +procedure t_qpparse() + +char expr[SZ_LINE] +char root[SZ_FNAME] +char filter[SZ_FNAME] + +begin + call clgstr ("expr", expr, SZ_LINE) + call qp_parse (expr, root, SZ_FNAME, filter, SZ_FNAME) + + call printf ("root=`%s', filter=`%s'\n") + call pargstr (root) + call pargstr (filter) +end + + +# TOKENS -- Translate an input character stream into a stream of QPOE tokens. +# Macro replacement is performed on the input text. + +procedure t_tokens() + +char input[SZ_FNAME], refpoe[SZ_FNAME] +char tokbuf[SZ_FNAME], num[SZ_FNAME] + +pointer qp, in +int token, junk +int qp_gettok(), gltoc() +pointer qp_open, qp_opentext() + +begin + input[1] = '@' + call clgstr ("input", input[2], SZ_FNAME-1) + call clgstr ("refpoe", refpoe, SZ_FNAME) + + if (refpoe[1] != EOS) + qp = qp_open (refpoe, READ_ONLY, NULL) + else + qp = NULL + in = qp_opentext (qp, input) + + repeat { + token = qp_gettok (in, tokbuf, SZ_FNAME) + if (token != EOF) { + call printf ("%10s: %s\n") + switch (token) { + case TOK_IDENTIFIER: + call pargstr ("IDENT") + case TOK_NUMBER: + call pargstr ("NUMBER") + case TOK_STRING: + call pargstr ("STRING") + case TOK_COMMAND: + call pargstr ("COMMAND") + case TOK_PLUSEQUALS: + call pargstr ("PLUSEQ") + case TOK_COLONEQUALS: + call pargstr ("COLONEQ") + default: + junk = gltoc (token, num, SZ_FNAME, 8) + call pargstr (num) + } + if (IS_PRINT(tokbuf[1])) + call pargstr (tokbuf) + else + call pargstr ("") + } + } until (token == EOF) + + call printf ("EOF\n") + call flush (STDOUT) + + call qp_closetext (in) + if (qp != NULL) + call qp_close (qp) +end + + +# COMP -- Compile an expression with QPEX and print out the contents of +# the resultant descriptor, including the assembler translation of the +# expression. + +procedure t_comp() + +int out +pointer qp, ex +char text[SZ_LINE] +char output[SZ_FNAME] + +int open() +bool streq() +pointer qp_open(), qpex_open() + +begin + call clgstr ("poefile", text, SZ_LINE) + qp = qp_open (text, READ_ONLY, 0) + + call clgstr ("output", output, SZ_FNAME) + if (output[1] != EOS) + out = open (output, APPEND, TEXT_FILE) + else + out = NULL + + repeat { + call clgstr ("expr", text, SZ_LINE) + if (streq (text, "bye")) + break + else if (text[1] != EOS) { + ex = qpex_open (qp, text) + call qpex_debug (ex, STDOUT, QPEXD_SHOWALL) + if (out != NULL) { + call fprintf (out, "\f") + call qpex_debug (ex, out, QPEXD_SHOWALL) + } + call qpex_close (ex) + call flush (STDOUT) + } + } + + call close (out) + call qp_close (qp) +end + + +# EXPAND -- Perform macro expansion on text input by the user. + +procedure t_expand() + +pointer qp, sp, ip, text, obuf +int getline(), qp_expandtext(), strncmp(), clgeti() +pointer qp_open() + +begin + call smark (sp) + call salloc (text, SZ_LINE, TY_CHAR) + call salloc (obuf, SZ_OBUF, TY_CHAR) + + call clgstr ("poefile", Memc[text], SZ_LINE) + qp = qp_open (Memc[text], READ_ONLY, 0) + call qp_seti (qp, QPOE_DEBUGLEVEL, clgeti("debug")) + + call printf ("Q> ") + call flush (STDOUT) + + while (getline (STDIN, Memc[text]) != EOF) { + for (ip=text; IS_WHITE(Memc[ip]); ip=ip+1) + ; + if (strncmp (Memc[ip], "bye", 3) == 0) + break + else if (Memc[ip] != '\n') { + call write (STDOUT, Memc[obuf], + qp_expandtext (qp, Memc[text], Memc[obuf], SZ_OBUF)) + call printf ("\n") + } + + call printf ("Q> ") + call flush (STDOUT) + } + + call qp_close (qp) + call sfree (sp) +end + + +# RECIO -- Test general record i/o. + +procedure t_recio() + +int i, n, nrec +pointer sp, qp, rp, poefile, data +int qp_read(), qp_accessf(), clgeti() +pointer qp_open() + +begin + call smark (sp) + call salloc (poefile, SZ_FNAME, TY_CHAR) + call salloc (data, 4096 * 3, TY_STRUCT) + + call clgstr ("poefile", Memc[poefile], SZ_FNAME) + qp = qp_open (Memc[poefile], READ_WRITE, 0) + call qp_seti (qp, QPOE_DEBUGLEVEL, clgeti("debug")) + nrec = clgeti ("nrec") + + # Initialize the data array. + do i = 1, nrec { + rp = data + (i-1) * 3 + Memr[rp] = i + Memi[rp+1] = i + Mems[P2S(rp)+4] = i*10+1 + Mems[P2S(rp)+5] = i*10+2 + } + + if (qp_accessf (qp, "urec") == NO) + call qp_addf (qp, "urec", "{r,i,s,s}", 0, "User record type", 0) + if (qp_accessf (qp, "data") == NO) + call qp_addf (qp, "data", "urec", nrec, "User records", 0) + + # Initialize the parameter. + call qp_write (qp, "data", Memi[data], nrec, 1, "urec") + + call eprintf ("---------------- Full array read test:") + call aclri (Memi[data], nrec * 3) + n = qp_read (qp, "data", Memi[data], nrec, 1, "urec") + call eprintf (" n=%d\n"); call pargi(n) + do i = 1, nrec { + rp = data + (i-1) * 3 + call eprintf ("%8.1f %4d %4d %4d\n") + call pargr (Memr[rp]) + call pargi (Memi[rp+1]) + call pargs (Mems[P2S(rp)+4]) + call pargs (Mems[P2S(rp)+5]) + } + + call eprintf ("---------------- Array element read test:\n") + call aclri (Memi[data], nrec * 3) + do i = 1, nrec { + rp = data + (i-1) * 3 + n = qp_read (qp, "data", Memi[rp], 1, i, "urec") + call eprintf ("%4d %8.1f %4d %4d %4d\n") + call pargi (i) + call pargr (Memr[rp]) + call pargi (Memi[rp+1]) + call pargs (Mems[P2S(rp)+4]) + call pargs (Mems[P2S(rp)+5]) + } + + call eprintf ("---------------- Array element read test (reversed):\n") + call aclri (Memi[data], nrec * 3) + do i = nrec, 1, -1 { + rp = data + (i-1) * 3 + n = qp_read (qp, "data", Memi[rp], 1, i, "urec") + call eprintf ("%4d %8.1f %4d %4d %4d\n") + call pargi (i) + call pargr (Memr[rp]) + call pargi (Memi[rp+1]) + call pargs (Mems[P2S(rp)+4]) + call pargs (Mems[P2S(rp)+5]) + } + + call qp_close (qp) + call sfree (sp) +end + + +# NEWCOPY -- Test inheritance occurring during a new-copy open. + +procedure t_newcopy() + +char iname[SZ_FNAME] # input name +char oname[SZ_FNAME] # output name + +pointer iqp, oqp +pointer qp_open() + +begin + call clgstr ("input", iname, SZ_FNAME) + call clgstr ("output", oname, SZ_FNAME) + + iqp = qp_open (iname, READ_ONLY, NULL) + oqp = qp_open (oname, NEW_COPY, iqp) + + call printf ("iqp=%x; oqp=%x\n") + call pargi (iqp) + call pargi (oqp) + + call qp_close (oqp) + call qp_close (iqp) +end + + +# SYMS -- Dump the symbol table of a QPOE datafile. + +procedure t_syms() + +char fname[SZ_FNAME] +pointer qp, qp_open() + +begin + call clgstr ("fname", fname, SZ_FNAME) + qp = qp_open (fname, READ_ONLY, 0) + call qp_dsym (qp, STDOUT) + call qp_close (qp) +end + + +# HLIST -- List selected header parameters. + +procedure t_hlist() + +pointer qp, list, sym +int nelem, maxelem, flags +char datatype[SZ_DATATYPE], comment[SZ_COMMENT] +char fname[SZ_FNAME], param[SZ_FNAME], pattern[SZ_FNAME] +pointer qp_open(), qp_ofnlu(), qp_ofnls(), qp_gpsym() +int qp_queryf(), qp_gnfn() +bool clgetb() + +begin + call clgstr ("fname", fname, SZ_FNAME) + call clgstr ("pattern", pattern, SZ_FNAME) + + qp = qp_open (fname, READ_ONLY, 0) + if (clgetb ("sort")) + list = qp_ofnls (qp, pattern) + else + list = qp_ofnlu (qp, pattern) + + call printf (" PARAM DTYPE NELEM MAXEL LF OFF FLG COMMENT\n") + while (qp_gnfn (list, param, SZ_FNAME) != EOF) { + nelem = qp_queryf (qp, param, datatype, maxelem, comment, flags) + sym = qp_gpsym (qp, param) + + call printf ("%15s %6s %5d %5d %2d%4d %3o %s\n") + call pargstr (param) + call pargstr (datatype) + call pargi (nelem) + call pargi (maxelem) + if (sym != NULL) { + call pargi (S_LFILE(sym)) + call pargi (S_OFFSET(sym)) + call pargi (and (flags, 777B)) + call pargstr (comment) + } else { + call pargi (0) + call pargi (0) + call pargi (0) + call pargstr ("[could not find symbol (macro?)]") + } + } + + call qp_cfnl (list) + call qp_close (qp) +end + + +# DUMPEVL -- Dump an event list descriptor. + +procedure t_dumpevl() + +pointer qp, io, dd, ev +char poefile[SZ_FNAME], param[SZ_FNAME] +char datatype[SZ_DATATYPE], comment[SZ_COMMENT] +int offset, dtype, size, nelem, maxelem, flags, i, j +pointer qp_open(), qpio_open(), qpio_stati(), coerce() +int qp_queryf(), sizeof() + +begin + call clgstr ("poefile", poefile, SZ_FNAME) + qp = qp_open (poefile, READ_ONLY, NULL) + + call clgstr ("eventlist", param, SZ_FNAME) + if (param[1] == EOS) + call strcpy ("events", param, SZ_FNAME) + io = qpio_open (qp, param, READ_ONLY) + + call printf ("%s.%s:\n") + call pargstr (poefile) + call pargstr (param) + + nelem = qp_queryf (qp, param, datatype, maxelem, comment, flags) + call printf ("dtype=%s nelem=%d maxel=%d flg=%o comment=%s\n") + call pargstr (datatype) + call pargi (nelem) + call pargi (maxelem) + call pargi (and (flags, 777B)) + call pargstr (comment) + + call printf ("%s=%dx%d ") + call pargstr ("blockfactor") + call pargi (qpio_stati(io, QPIO_XBLOCKFACTOR)) + call pargi (qpio_stati(io, QPIO_YBLOCKFACTOR)) + call printf ("%s=%d ") + call pargstr ("bucketlen") + call pargi (qpio_stati(io, QPIO_BUCKETLEN)) + call printf ("%s=%d ") + call pargstr ("debug") + call pargi (qpio_stati(io, QPIO_DEBUG)) + call printf ("%s=%d ") + call pargstr ("evxoff") + call pargi (qpio_stati(io, QPIO_EVXOFF)) + call printf ("%s=%d ") + call pargstr ("evxtype") + call pargi (qpio_stati(io, QPIO_EVXTYPE)) + call printf ("%s=%d ") + call pargstr ("evyoff") + call pargi (qpio_stati(io, QPIO_EVYOFF)) + call printf ("%s=%d ") + call pargstr ("evytype") + call pargi (qpio_stati(io, QPIO_EVYTYPE)) + call printf ("\n") + + call printf ("%s=%xX ") + call pargstr ("ex") + call pargi (qpio_stati(io, QPIO_EX)) + call printf ("%s=%d ") + call pargstr ("noindex") + call pargi (qpio_stati(io, QPIO_NOINDEX)) + call printf ("%s=%d ") + call pargstr ("optbufsize") + call pargi (qpio_stati(io, QPIO_OPTBUFSIZE)) + call printf ("%s=%xX ") + call pargstr ("pl") + call pargi (qpio_stati(io, QPIO_PL)) + call printf ("%s=%d ") + call pargstr ("eventlen") + call pargi (qpio_stati(io, QPIO_EVENTLEN)) + call printf ("%s=%d ") + call pargstr ("fd") + call pargi (qpio_stati(io, QPIO_FD)) + call printf ("\n") + + call printf ("%s=%d ") + call pargstr ("indexlen") + call pargi (qpio_stati(io, QPIO_INDEXLEN)) + call printf ("%s=%d ") + call pargstr ("ixxoff") + call pargi (qpio_stati(io, QPIO_IXXOFF)) + call printf ("%s=%d ") + call pargstr ("ixxtype") + call pargi (qpio_stati(io, QPIO_IXXTYPE)) + call printf ("%s=%d ") + call pargstr ("ixyoff") + call pargi (qpio_stati(io, QPIO_IXYOFF)) + call printf ("%s=%d ") + call pargstr ("ixytype") + call pargi (qpio_stati(io, QPIO_IXYTYPE)) + call printf ("%s=%d ") + call pargstr ("lf") + call pargi (qpio_stati(io, QPIO_LF)) + call printf ("%s=%xX ") + call pargstr ("maskp") + call pargi (qpio_stati(io, QPIO_MASKP)) + call printf ("\n") + + call printf ("%s=%xX ") + call pargstr ("maxevp") + call pargi (qpio_stati(io, QPIO_MAXEVP)) + call printf ("%s=%xX ") + call pargstr ("minevp") + call pargi (qpio_stati(io, QPIO_MINEVP)) + call printf ("%s=%d ") + call pargstr ("ncols") + call pargi (qpio_stati(io, QPIO_NCOLS)) + call printf ("%s=%d ") + call pargstr ("nlines") + call pargi (qpio_stati(io, QPIO_NLINES)) + call printf ("%s=%xX ") + call pargstr ("paramp") + call pargi (qpio_stati(io, QPIO_PARAMP)) + call printf ("%s=%xX ") + call pargstr ("qp") + call pargi (qpio_stati(io, QPIO_QP)) + call printf ("\n") + + # Print domain attributes. + dd = IO_DD(io) + call printf ("Domain `%s': len=%d nfields=%d xfield=%d yfield=%d\n") + call pargstr (datatype) + call pargi (DD_STRUCTLEN(dd)) + call pargi (DD_NFIELDS(dd)) + call pargi (DD_XFIELD(dd)) + call pargi (DD_YFIELD(dd)) + + # Print min/max evl records. + do j = 1, 2 { + if (j == 1) { + call printf ("minevl: ") + ev = qpio_stati (io, QPIO_MINEVP) + } else { + call printf ("maxevl: ") + ev = qpio_stati (io, QPIO_MAXEVP) + } + + do i = 1, DD_NFIELDS(dd) { + offset = DD_FOFFSET(dd,i) + dtype = DD_FTYPE(dd,i) + size = sizeof(dtype) + + switch (dtype) { + case TY_SHORT: + call printf (" s%d=%d") + call pargi (offset * size * SZB_CHAR) + call pargs (Mems[coerce(ev,TY_SHORT,dtype) + offset]) + case TY_INT: + call printf (" i%d=%d") + call pargi (offset * size * SZB_CHAR) + call pargi (Memi[coerce(ev,TY_SHORT,dtype) + offset]) + case TY_LONG: + call printf (" l%d=%d") + call pargi (offset * size * SZB_CHAR) + call pargl (Meml[coerce(ev,TY_SHORT,dtype) + offset]) + case TY_REAL: + call printf (" r%d=%0.5g") + call pargi (offset * size * SZB_CHAR) + call pargr (Memr[coerce(ev,TY_SHORT,dtype) + offset]) + case TY_DOUBLE: + call printf (" d%d=%0.8g") + call pargi (offset * size * SZB_CHAR) + call pargd (Memd[coerce(ev,TY_SHORT,dtype) + offset]) + default: + call printf (" type=%d") + call pargi (dtype) + } + } + + call printf ("\n") + } +end + + +# MKPOE -- Convert CFA poefile to QPOE poefile. +# ------------------------- + +# Size limiting defintions. +define LEN_EVBUF 512 # size of output event buffer +define LEN_CVBUF 1000 # max number of mask regions +define SZ_KEY 20 + +# CFA Poefile definitions. +define SZ_EVENT SZ_OEVENT +define SZ_IEVENT 10 # size of input event struct, chars +define SZ_OEVENT 12 # size of output event struct, chars +define SZ_FILEHEADER 256 # size of file header, chars + +# File header fields of interest. +define O_MISSION 1 # byte offset of "mission" field +define T_MISSION TY_SHORT # datatype of mission field +define O_INSTRUMENT 1 # byte offset of "instrument" field +define T_INSTRUMENT TY_SHORT # datatype of instrument field +define O_XDIM 129 # byte offset of Xdim field +define T_XDIM TY_SHORT # datatype of Xdim field +define O_YDIM 131 # byte offset of Ydim field +define T_YDIM TY_SHORT # datatype of Ydim field +define O_PSTART 505 # byte offset of PhotonStart field +define T_PSTART TY_LONG # datatype of PhotonStart field +define O_PSTOP 509 # byte offset of PhotonStop field +define T_PSTOP TY_LONG # datatype of PhotonStop field + +# Input event struct fields of interest. +define O_X 1 # sky coordinates +define T_X TY_SHORT +define O_Y 3 +define T_Y TY_SHORT +define O_TIME 5 # arrival time +define T_TIME TY_DOUBLE +define O_PHA 13 # pulse height +define T_PHA TY_SHORT +define O_PI 15 # energy +define T_PI TY_SHORT +define O_DX 17 # detector coordinates +define T_DX TY_SHORT +define O_DY 19 +define T_DY TY_SHORT + +# The event struct to be stored in the QPOE file. +define EVTYPE "event" +define FIELDLIST "{s:x,s:y,s,s,d,s,s}" + +define EV_X Mems[$1] +define EV_Y Mems[$1+1] +define EV_PHA Mems[$1+2] +define EV_PI Mems[$1+3] +define EV_TIME Memd[($1+4-1)/SZ_DOUBLE+1] +define EV_DX Mems[$1+8] +define EV_DY Mems[$1+9] + +# Define an event structure with short coordinates +define S_FIELDLIST "{s:x,s:y,s,s,d,s,s}" +define S_SZ_EVENT 10 +define S_EV_X Mems[$1] +define S_EV_Y Mems[$1+1] +define S_EV_PHA Mems[$1+2] +define S_EV_PI Mems[$1+3] +define S_EV_TIME Memd[($1+4-1)/SZ_DOUBLE+1] +define S_EV_DX Mems[$1+8] +define S_EV_DY Mems[$1+9] + +# Define an event structure with integer coordinates +define I_FIELDLIST "{d,i:x,i:y,i,i,s,s}" +define I_SZ_EVENT 14 +define I_EV_TIME Memd[($1-1)/SZ_DOUBLE+1] +define I_EV_X Memi[($1+4-1)/SZ_INT+1] +define I_EV_Y Memi[($1+6-1)/SZ_INT+1] +define I_EV_DX Memi[($1+8-1)/SZ_INT+1] +define I_EV_DY Memi[($1+10-1)/SZ_INT+1] +define I_EV_PHA Mems[$1+12] +define I_EV_PI Mems[$1+13] + +# Define an event structure with real coordinates +define R_FIELDLIST "{d,r:x,r:y,r,r,s,s}" +define R_SZ_EVENT 14 +define R_EV_TIME Memd[($1-1)/SZ_DOUBLE+1] +define R_EV_X Memr[($1+4-1)/SZ_REAL+1] +define R_EV_Y Memr[($1+6-1)/SZ_REAL+1] +define R_EV_DX Memr[($1+8-1)/SZ_REAL+1] +define R_EV_DY Memr[($1+10-1)/SZ_REAL+1] +define R_EV_PHA Mems[$1+12] +define R_EV_PI Mems[$1+13] + +# Define an event structure with double coordinates +define D_FIELDLIST "{d,d:x,d:y,d,d,s,s}" +define D_SZ_EVENT 22 +define D_EV_TIME Memd[($1-1)/SZ_DOUBLE+1] +define D_EV_X Memd[($1+4-1)/SZ_DOUBLE+1] +define D_EV_Y Memd[($1+8-1)/SZ_DOUBLE+1] +define D_EV_DX Memd[($1+12-1)/SZ_DOUBLE+1] +define D_EV_DY Memd[($1+16-1)/SZ_DOUBLE+1] +define D_EV_PHA Mems[$1+20] +define D_EV_PI Mems[$1+21] + + +# MKPOE -- Write out a new POEFILE, taking a CFA POE file as input. +# The input file uses big-endian format for integers, and IEEE for floats. +# The input file must be sorted in order for the output file to be indexed. + +procedure t_mkpoe() + +char infile[SZ_FNAME] # input CFA-format poefile +char outfile[SZ_FNAME] # output QPOE-format poefile + +char key[SZ_KEY] +pointer sp, hdr, obuf, optr, ph, ev, qp, io +int datastart, dataend, mission, instrument, now +int debug, nphotons, naxes, axlen[2], dmin[8], dmax[8], in, op, i + +bool clgetb() +double mp_getd() +pointer qp_open(), qpio_open() +int open(), read(), mp_geti(), clgeti(), clktime() + +begin + call smark (sp) + call salloc (hdr, SZ_FILEHEADER, TY_CHAR) + call salloc (obuf, LEN_EVBUF * SZ_OEVENT / SZ_SHORT, TY_SHORT) + call salloc (optr, LEN_EVBUF, TY_POINTER) + call salloc (ph, SZ_IEVENT, TY_CHAR) + + call clgstr ("infile", infile, SZ_FNAME) + call clgstr ("outfile", outfile, SZ_FNAME) + + # Open the input and output files. Clobber the output file if + # it already exists. + + in = open (infile, READ_ONLY, BINARY_FILE) + iferr (call qp_delete (outfile)) + ; + qp = qp_open (outfile, NEW_FILE, NULL) + + # Set the datafile page size. + call qp_seti (qp, QPOE_PAGESIZE, clgeti("pagesize")) + + # Set the bucket length in units of number of events. + call qp_seti (qp, QPOE_BUCKETLEN, clgeti("bucketlen")) + + # Set the debug level. + debug = clgeti ("debug") + call qp_seti (qp, QPOE_DEBUGLEVEL, debug) + + # Read and decode the input file header. + if (read (in, Memc[hdr], SZ_FILEHEADER) < SZ_FILEHEADER) + call error (1, "cannot read input file header") + + naxes = 2 + axlen[1] = mp_geti (Memc[hdr], O_XDIM, T_XDIM) + axlen[2] = mp_geti (Memc[hdr], O_YDIM, T_YDIM) + datastart = mp_geti (Memc[hdr], O_PSTART, T_PSTART) + dataend = mp_geti (Memc[hdr], O_PSTOP, T_PSTOP) + nphotons = (dataend - datastart + 1) / (SZ_IEVENT * SZB_CHAR) + + mission = mp_geti (Memc[hdr], O_MISSION, T_MISSION) + instrument = mp_geti (Memc[hdr], O_INSTRUMENT, T_INSTRUMENT) + + call eprintf ("xdim=%d, ydim=%d, datastart=%d, nphotons=%d\n") + call pargi (axlen[1]) + call pargi (axlen[2]) + call pargi (datastart) + call pargi (nphotons) + + # Setup the QPOE file header. + call qp_addf (qp, "naxes", "i", 1, "number of image axes", 0) + call qp_puti (qp, "naxes", naxes) + call qp_addf (qp, "axlen", "i", 2, "length of each axis", 0) + call qp_write (qp, "axlen", axlen, 2, 1, "i") + + now = clktime(0) + call qp_addf (qp, "cretime", "i", 1, "image creation time", 0) + call qp_puti (qp, "cretime", now) + call qp_addf (qp, "modtime", "i", 1, "image modify time", 0) + call qp_puti (qp, "modtime", now) + call qp_addf (qp, "limtime", "i", 1, "data min/max update time", 0) + call qp_puti (qp, "limtime", now) + + # Invent some data min/max values for now. + do i = 1, 8 { + dmin[i] = 0 + dmax[i] = 64 + } + call qp_addf (qp, "datamin", "i", 8, "minimum pixel value", 0) + call qp_write (qp, "datamin", dmin, 8, 1, "i") + call qp_addf (qp, "datamax", "i", 8, "maximum pixel value", 0) + call qp_write (qp, "datamax", dmax, 8, 1, "i") + + # Throw in a few miscellaneous params for testing purposes. + call qp_addf (qp, "mission", "s", 1, "mission type code", 0) + call qp_puti (qp, "mission", mission) + call qp_addf (qp, "instrument", "s", 1, "instrument type code", 0) + call qp_puti (qp, "instrument", instrument) + + # Define the event structure for the QPOE output file. + call qp_addf (qp, EVTYPE, FIELDLIST, 1, "event record type", 0) + + # Copy the event (photon) list. + call qp_addf (qp, "events", "event", 0, "main event list", 0) + io = qpio_open (qp, "events", NEW_FILE) + call seek (in, datastart / SZB_CHAR + 1) + op = 0 + + do i = 1, nphotons { + # Read next event. + if (read (in, Memc[ph], SZ_IEVENT) < SZ_IEVENT) + call error (2, "photon event list truncated") + + # Copy/transform event struct (not very efficient, but this + # is only debug code). + + ev = obuf + (op * SZ_OEVENT / SZ_SHORT) + Memi[optr+op] = ev + + EV_TIME(ev) = mp_getd (Memc[ph], O_TIME, T_TIME) + EV_X(ev) = mp_geti (Memc[ph], O_X, T_X) + EV_Y(ev) = mp_geti (Memc[ph], O_Y, T_Y) + EV_PHA(ev) = mp_geti (Memc[ph], O_PHA, T_PHA) + EV_PI(ev) = mp_geti (Memc[ph], O_PI, T_PI) + EV_DX(ev) = mp_geti (Memc[ph], O_DX, T_DX) + EV_DY(ev) = mp_geti (Memc[ph], O_DY, T_DY) + + if (debug > 4) { + call eprintf ("%4d %4d %4d %4d %7d %7d %g\n") + call pargs (EV_X(ev)) + call pargs (EV_Y(ev)) + call pargs (EV_DX(ev)) + call pargs (EV_DY(ev)) + call pargs (EV_PHA(ev)) + call pargs (EV_PI(ev)) + call pargd (EV_TIME(ev)) + } + + # Bump output pointer and flush output buffer when it fills. + op = op + 1 + if (op >= LEN_EVBUF) { + call qpio_putevents (io, Memi[optr], op) + op = 0 + } + } + + # Flush any remaining buffered data. + if (op > 0) + call qpio_putevents (io, Memi[optr], op) + + # Construct index. + if (clgetb ("mkindex")) { + call clgstr ("key", key, SZ_KEY) + call qpio_mkindex (io, key) + } + + # Clean up. + call qpio_close (io) + call qp_close (qp) + call close (in) + + call sfree (sp) +end + + +# MP_GETI -- Get an integer field from the raw input data. + +int procedure mp_geti (buf, boffset, dtype) + +char buf[ARB] # byte-stream data buffer +int boffset # byte offset of desired field +int dtype # datatype of stored field + +short sval +int nbytes, ival +int sizeof() + +begin + nbytes = sizeof(dtype) * SZB_CHAR + + switch (dtype) { + case TY_SHORT: + if (BYTE_SWAP2 == YES) + call bswap2 (buf, boffset, sval, 1, nbytes) + else + call bytmov (buf, boffset, sval, 1, nbytes) + return (sval) + case TY_INT, TY_LONG: + if (BYTE_SWAP4 == YES) + call bswap4 (buf, boffset, ival, 1, nbytes) + else + call bytmov (buf, boffset, ival, 1, nbytes) + return (ival) + default: + call error (3, "bad dtype switch in mp_geti") + } +end + + +# MP_GETD -- Get a double field from the raw input data. We assume that both +# the input and output are IEEE floating, hence all we are really doing here +# is providing for arbitrarily aligned fields, and providing type conversion. + +double procedure mp_getd (buf, boffset, dtype) + +char buf[ARB] # byte-stream data buffer +int boffset # byte offset of desired field +int dtype # datatype of stored field + +double dval +real rval +int nbytes, half +int sizeof() + +begin + nbytes = sizeof(dtype) * SZB_CHAR + half = nbytes / 2 + + switch (dtype) { + case TY_REAL: + if (BYTE_SWAP4 == YES) + call bswap4 (buf, boffset, rval, 1, nbytes) + else + call bytmov (buf, boffset, rval, 1, nbytes) + return (rval) + case TY_DOUBLE: + if (BYTE_SWAP4 == YES) { + call bswap4 (buf, boffset, dval, 1+half, half) + call bswap4 (buf, boffset+half, dval, 1, half) + } else + call bytmov (buf, boffset, dval, 1, nbytes) + return (dval) + default: + call error (3, "bad dtype switch in mp_getd") + } +end + + +# TESTPOE -- Make a test QPOE file, generating an artificial sequence of +# events (for testing special cases). The event list is not sorted or +# indexed. + +procedure t_testpoe() + +char outfile[SZ_FNAME] # output QPOE-format poefile + +pointer sp, ev, qp, io, evl[1] +int nevents, naxes, axlen[2], i, datatype +pointer qp_open(), qpio_open() +int clgeti() +char clgetc() + +begin + # Open the output file. + call clgstr ("outfile", outfile, SZ_FNAME) + iferr (call qp_delete (outfile)) + ; + qp = qp_open (outfile, NEW_FILE, NULL) + + naxes = 2 + axlen[1] = clgeti ("ncols") + axlen[2] = clgeti ("nlines") + datatype = clgetc ("datatype") + + # Setup the QPOE file header. + call qp_addf (qp, "naxes", "i", 1, "number of image axes", 0) + call qp_puti (qp, "naxes", naxes) + call qp_addf (qp, "axlen", "i", 2, "length of each axis", 0) + call qp_write (qp, "axlen", axlen, 2, 1, "i") + + # Define the event structure for the QPOE output file. + call smark (sp) + switch (datatype) { + case 's': + call salloc (ev, S_SZ_EVENT / SZ_SHORT, TY_SHORT) + call qp_addf (qp, EVTYPE, S_FIELDLIST, 1, "event record type", 0) + case 'i': + call salloc (ev, I_SZ_EVENT / SZ_SHORT, TY_SHORT) + call qp_addf (qp, EVTYPE, I_FIELDLIST, 1, "event record type", 0) + case 'r': + call salloc (ev, R_SZ_EVENT / SZ_SHORT, TY_SHORT) + call qp_addf (qp, EVTYPE, R_FIELDLIST, 1, "event record type", 0) + case 'd': + call salloc (ev, D_SZ_EVENT / SZ_SHORT, TY_SHORT) + call qp_addf (qp, EVTYPE, D_FIELDLIST, 1, "event record type", 0) + } + + + # Copy the event (photon) list. + call qp_addf (qp, "events", "event", 0, "main event list", 0) + io = qpio_open (qp, "events", NEW_FILE) + + # Generate some dummy events. + nevents = clgeti ("nevents") + evl[1] = ev + + # Hack this to generate different types of test files. + do i = 1, nevents { + switch (datatype) { + + case 's': + S_EV_TIME(ev) = 1.0D0 + double(i) / 10.0D0 + if (mod(i,2) == 0) { + S_EV_X(ev) = (i - 1) * 10 + 1 + S_EV_Y(ev) = (i - 1) * 10 + 1 + } else { + S_EV_X(ev) = axlen[1] - ((i - 1) * 10 + 1) + S_EV_Y(ev) = axlen[2] - ((i - 1) * 10 + 1) + } + S_EV_PHA(ev) = mod (nint(i * 11.1111), 20) + S_EV_PI(ev) = i / 2 + S_EV_DX(ev) = nevents - i + 1 + S_EV_DY(ev) = nevents - i + 1 + + case 'i': + I_EV_TIME(ev) = 1.0D0 + double(i) / 10.0D0 + if (mod(i,2) == 0) { + I_EV_X(ev) = (i - 1) * 10 + 1 + I_EV_Y(ev) = (i - 1) * 10 + 1 + } else { + I_EV_X(ev) = axlen[1] - ((i - 1) * 10 + 1) + I_EV_Y(ev) = axlen[2] - ((i - 1) * 10 + 1) + } + I_EV_PHA(ev) = mod (nint(i * 11.1111), 20) + I_EV_PI(ev) = i / 2 + I_EV_DX(ev) = nevents - i + 1 + I_EV_DY(ev) = nevents - i + 1 + + case 'r': + R_EV_TIME(ev) = 1.0D0 + double(i) / 10.0D0 + if (mod(i,2) == 0) { + R_EV_X(ev) = (i - 1) * 10 + 1 + R_EV_Y(ev) = (i - 1) * 10 + 1 + } else { + R_EV_X(ev) = axlen[1] - ((i - 1) * 10 + 1) + R_EV_Y(ev) = axlen[2] - ((i - 1) * 10 + 1) + } + R_EV_PHA(ev) = mod (nint(i * 11.1111), 20) + R_EV_PI(ev) = i / 2 + R_EV_DX(ev) = nevents - i + 1 + R_EV_DY(ev) = nevents - i + 1 + + case 'd': + D_EV_TIME(ev) = 1.0D0 + double(i) / 10.0D0 + if (mod(i,2) == 0) { + D_EV_X(ev) = (i - 1) * 10 + 1 + D_EV_Y(ev) = (i - 1) * 10 + 1 + } else { + D_EV_X(ev) = axlen[1] - ((i - 1) * 10 + 1) + D_EV_Y(ev) = axlen[2] - ((i - 1) * 10 + 1) + } + D_EV_PHA(ev) = mod (nint(i * 11.1111), 20) + D_EV_PI(ev) = i / 2 + D_EV_DX(ev) = nevents - i + 1 + D_EV_DY(ev) = nevents - i + 1 + + } + + call qpio_putevents (io, evl, 1) + } + + # Clean up. + call qpio_close (io) + call qp_close (qp) + call sfree (sp) +end + + +# COUNTPOE -- Count photons in regions. Whether or not there are any regions +# depends upon whether the user specifies a region mask, or upon whether the +# image has a default mask. If there is no mask the entire image is counted. +# If the user specifies a filter then event attribute filtering will be +# performed as well. Mask region values should be restricted to the range +# 0-999. + +procedure t_countpoe() + +bool list_events +int debug, nev, mval, m, i +pointer sp, qp, poefile, evlist, evl, cv, ev, io + +bool clgetb() +pointer qp_open(), qpio_open() +int qpio_getevents(), clgeti() + +begin + call smark (sp) + call salloc (poefile, SZ_FNAME, TY_CHAR) + call salloc (evlist, SZ_EXPR, TY_CHAR) + call salloc (evl, LEN_EVBUF, TY_POINTER) + call salloc (cv, LEN_CVBUF, TY_INT) + + call clgstr ("poefile", Memc[poefile], SZ_FNAME) + qp = qp_open (Memc[poefile], READ_ONLY, NULL) + + debug = clgeti ("debug") + call qp_seti (qp, QPOE_DEBUGLEVEL, debug) + + call clgstr ("eventlist", Memc[evlist], SZ_EXPR) + io = qpio_open (qp, Memc[evlist], READ_ONLY) + + list_events = clgetb ("list_events") + if (list_events) + call printf (" EV X Y DX DY PHA PI TIME\n") + + call aclri (Memi[cv], LEN_CVBUF) + + # Scan the event list. + while (qpio_getevents (io, Memi[evl], mval, LEN_EVBUF, nev) != EOF) { + if (list_events) { + do i = 1, nev { + ev = Memi[evl+i-1] + call printf ("%4d %4d %4d %4d %4d %7d %7d %g\n") + call pargi (i) + call pargs (EV_X(ev)) + call pargs (EV_Y(ev)) + call pargs (EV_DX(ev)) + call pargs (EV_DY(ev)) + call pargs (EV_PHA(ev)) + call pargs (EV_PI(ev)) + call pargd (EV_TIME(ev)) + } + } + + m = min (LEN_CVBUF, mval) + Memi[cv+m] = Memi[cv+m] + nev + } + + call qpio_close (io) + + # Print the count of the number of photons in each region. + if (list_events) + call printf ("\n") + + call printf ("REGION: ") + do i = 0, LEN_CVBUF-1 + if (Memi[cv+i] > 0) { + call printf (" %6oB") + call pargi (i) + } + call printf ("\n") + + call printf ("COUNTS: ") + do i = 0, LEN_CVBUF-1 + if (Memi[cv+i] > 0) { + call printf (" %7d") + call pargi (Memi[cv+i]) + } + call printf ("\n") + + call qp_close (qp) + call sfree (sp) +end + + +# TFILTER -- Perform a brute force time filtering operation upon an event +# list, and compare against the results of a standard QPEX time filter. +# This is used to verify the operation of the optimized QPEX time filter. + +procedure t_tfilter() + +bool open_left, open_right, pass +int nev1, nev2, totev, mval, nev, xlen, nranges, fd1, fd2, i, j +pointer sp, poefile, filter, output, fname, evl, x1, y1, t1, x2, y2, t2 +pointer qp, io, ex, ev, xs, xe +double t + +bool clgetb() +int qpio_getevents(), qpex_attrld(), open() +pointer qp_open(), qpio_open(), qpex_open() + +begin + call smark (sp) + call salloc (poefile, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (filter, SZ_EXPR, TY_CHAR) + call salloc (evl, LEN_EVBUF, TY_POINTER) + + call salloc (x1, MAX_EVENTS, TY_SHORT) + call salloc (y1, MAX_EVENTS, TY_SHORT) + call salloc (t1, MAX_EVENTS, TY_DOUBLE) + call salloc (x2, MAX_EVENTS, TY_SHORT) + call salloc (y2, MAX_EVENTS, TY_SHORT) + call salloc (t2, MAX_EVENTS, TY_DOUBLE) + + nev1 = 0 + nev2 = 0 + totev = 0 + + call clgstr ("poefile", Memc[poefile], SZ_FNAME) + qp = qp_open (Memc[poefile], READ_ONLY, NULL) + io = qpio_open (qp, "", READ_ONLY) + + call clgstr ("filter", Memc[filter], SZ_EXPR) + ex = qpex_open (qp, Memc[filter]) + + call clgstr ("output", Memc[output], SZ_FNAME) + + if (clgetb ("showfilter")) { + call qpex_debug (ex, STDOUT, QPEXD_SHOWALL) + call flush (STDOUT) + } + + # Scan the event list using the given filter. + call printf ("scan event list using optimized filter: ") + call flush (STDOUT) + + call qpio_seti (io, QPIO_EX, ex) + while (qpio_getevents (io, Memi[evl], mval, LEN_EVBUF, nev) != EOF) { + do i = 1, nev { + ev = Memi[evl+i-1] + Mems[x1+nev1] = EV_X(ev) + Mems[y1+nev1] = EV_Y(ev) + Memd[t1+nev1] = EV_TIME(ev) + nev1 = min (MAX_EVENTS, nev1 + 1) + } + } + + call printf ("%d events\n") + call pargi (nev1) + xlen = 128 + call malloc (xs, TY_DOUBLE, xlen) + call malloc (xe, TY_DOUBLE, xlen) + + # Get the time filter as a list of ranges. + xs = NULL; xe = NULL; xlen = 0 + nranges = qpex_attrld (ex, "time", xs, xe, xlen) + if (nranges > 0) { + open_left = IS_INDEF(Memd[xs]) + open_right = IS_INDEF(Memd[xe+nranges-1]) + } else { + open_left = false + open_right = false + } + + # Scan the event list, applying a brute force time filter. + call qpio_seti (io, QPIO_EX, NULL) + call printf ("scan event list using brute force filter: ") + call flush (STDOUT) + + while (qpio_getevents (io, Memi[evl], mval, LEN_EVBUF, nev) != EOF) { + do i = 1, nev { + ev = Memi[evl+i-1] + t = EV_TIME(ev) + + # Apply the time filter. + if (open_left && open_right && nranges == 1) + pass = true + else { + pass = false + do j = 1, nranges { + if (j == 1 && open_left) { + if (t <= Memd[xe]) { + pass = true + break + } + } else if (j == nranges && open_right) { + if (t >= Memd[xs+nranges-1]) { + pass = true + break + } + } else if (t >= Memd[xs+j-1] && t <= Memd[xe+j-1]) { + pass = true + break + } + } + } + + if (pass) { + Mems[x2+nev2] = EV_X(ev) + Mems[y2+nev2] = EV_Y(ev) + Memd[t2+nev2] = EV_TIME(ev) + nev2 = min (MAX_EVENTS, nev2 + 1) + } + } + + totev = totev + nev + } + + call printf ("%d events\n") + call pargi (nev2) + call printf ("out of a total of %d events\n") + call pargi (totev) + call flush (STDOUT) + + # Dump the two event lists if an output root filename was given. + if (Memc[output] != EOS) { + call sprintf (Memc[fname], SZ_FNAME, "%s.1") + call pargstr (Memc[output]) + iferr (call delete (Memc[fname])) + ; + fd1 = open (Memc[fname], NEW_FILE, TEXT_FILE) + + call sprintf (Memc[fname], SZ_FNAME, "%s.2") + call pargstr (Memc[output]) + iferr (call delete (Memc[fname])) + ; + fd2 = open (Memc[fname], NEW_FILE, TEXT_FILE) + + do i = 1, max (nev1, nev2) { + if (i <= nev1) { + call fprintf (fd1, "%d %d %g\n") + call pargs (Mems[x1+i-1]) + call pargs (Mems[y1+i-1]) + call pargd (Memd[t1+i-1]) + } + if (i <= nev2) { + call fprintf (fd2, "%d %d %g\n") + call pargs (Mems[x2+i-1]) + call pargs (Mems[y2+i-1]) + call pargd (Memd[t2+i-1]) + } + } + + call close (fd1) + call close (fd2) + } + + # Compare the results of the two filters for equality. + pass = true + do i = 1, min (nev1, nev2) { + if (Mems[x1+i-1] != Mems[x2+i-1] || Mems[y1+i-1] != Mems[y2+i-1]) { + call printf ("bad compare at event %d: ") + call pargi (i) + call printf ("[%d,%d,%0.4f] != [%d,%d,%0.4f]\n") + call pargs (Mems[x1+i-1]) + call pargs (Mems[y1+i-1]) + call pargd (Memd[t1+i-1]) + call pargs (Mems[x2+i-1]) + call pargs (Mems[y2+i-1]) + call pargd (Memd[t2+i-1]) + pass = false + break + } + } + + if (pass) { + call printf ("first %d events are identical\n") + call pargi (min (nev1, nev2)) + } + + call mfree (xs, TY_DOUBLE) + call mfree (xe, TY_DOUBLE) + call qpex_close (ex) + call qpio_close (io) + call qp_close (qp) + + call sfree (sp) +end + + +# PLOTPOE -- Read and plot photons, showing the position of each photon +# in the image matrix, according to the current coordinate system. + +procedure t_plotpoe() + +int ncols, nlines, xblock, yblock, mval, nev, i +pointer sp, poefile, evlist, evl, xv, yv, qp, io, ev, gp +pointer qp_open(), gopen(), qpio_open +int clgeti(), qp_stati(), qp_geti(), qpio_getevents() + +begin + call smark (sp) + call salloc (poefile, SZ_FNAME, TY_CHAR) + call salloc (evlist, SZ_EXPR, TY_CHAR) + call salloc (evl, LEN_EVBUF, TY_POINTER) + call salloc (xv, LEN_EVBUF, TY_REAL) + call salloc (yv, LEN_EVBUF, TY_REAL) + + call clgstr ("poefile", Memc[poefile], SZ_FNAME) + qp = qp_open (Memc[poefile], READ_ONLY, NULL) + + call qp_seti (qp, QPOE_DEBUGLEVEL, clgeti ("debug")) + call qp_seti (qp, QPOE_XBLOCKFACTOR, clgeti ("xblock")) + call qp_seti (qp, QPOE_YBLOCKFACTOR, clgeti ("yblock")) + + xblock = qp_stati (qp, QPOE_XBLOCKFACTOR) + yblock = qp_stati (qp, QPOE_YBLOCKFACTOR) + ncols = qp_geti (qp, "axlen[1]") / xblock + nlines = qp_geti (qp, "axlen[2]") / yblock + + gp = gopen ("stdgraph", NEW_FILE, STDGRAPH) + call gswind (gp, 1., real(ncols), 1., real(nlines)) + call gsetr (gp, G_ASPECT, 1.0) + + call clgstr ("eventlist", Memc[evlist], SZ_EXPR) + io = qpio_open (qp, Memc[evlist], READ_ONLY) + + if (Memc[evlist] == EOS) + call glabax (gp, "events", "X", "Y") + else + call glabax (gp, Memc[evlist], "X", "Y") + + # Scan the event list. + while (qpio_getevents (io, Memi[evl], mval, LEN_EVBUF, nev) != EOF) { + do i = 1, nev { + ev = Memi[evl+i-1] + Memr[xv+i-1] = EV_X(ev) / xblock + 1.0 + Memr[yv+i-1] = EV_Y(ev) / yblock + 1.0 + } + call gpmark (gp, Memr[xv], Memr[yv], nev, GM_POINT, 0.0, 0.0) + call gflush (gp) + } + + call qpio_close (io) + call gclose (gp) + + call qp_close (qp) + call sfree (sp) +end + + +# SUM -- Sum the counts in an image section. + +procedure t_sum() + +double sum +char image[SZ_LINE] +int ncols, nlines, i +pointer im, immap(), imgl2i() +real asumi() + +begin + call clgstr ("image", image, SZ_LINE) + im = immap (image, READ_ONLY, 0) + + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + + call printf ("ncols=%d, nlines=%d, pixtype=%d\n") + call pargi (ncols) + call pargi (nlines) + call pargi (IM_PIXTYPE(im)) + call flush (STDOUT) + + sum = 0 + do i = 1, nlines + sum = sum + asumi (Memi[imgl2i(im,i)], ncols) + + call printf ("total pixels = %d, counts = %14.0f\n") + call pargi (ncols * nlines) + call pargd (sum) + + call imunmap (im) +end + + +# SETWCS -- Store a wcs in a QPOE file. + +procedure t_setwcs() + +pointer qp, mw +char text[SZ_LINE] +pointer qp_open, mw_open + +begin + call clgstr ("poefile", text, SZ_LINE) + qp = qp_open (text, READ_WRITE, 0) + + mw = mw_open (NULL, 2) + call qp_savewcs (qp, mw) + + call mw_close (mw) + call qp_close (qp) +end + + +# SETFILT -- Set the default filter in a QPOE file. + +procedure t_setfilt() + +pointer qp +char poefile[SZ_FNAME] +char filter[SZ_LINE] +pointer qp_open() + +begin + call clgstr ("poefile", poefile, SZ_FNAME) + qp = qp_open (poefile, READ_WRITE, 0) + + call clgstr ("deffilt", filter, SZ_LINE) + call qp_astr (qp, "deffilt", filter, "default filter") + + call qp_close (qp) +end + + +# SETMASK -- Set the default mask in a QPOE file. + +procedure t_setmask() + +pointer qp +char poefile[SZ_FNAME] +char mask[SZ_LINE] +pointer qp_open() + +begin + call clgstr ("poefile", poefile, SZ_FNAME) + qp = qp_open (poefile, READ_WRITE, 0) + + call clgstr ("defmask", mask, SZ_LINE) + call qp_astr (qp, "defmask", mask, "default mask") + + call qp_close (qp) +end + + +# MERGEI -- Test the merge range list routine (integer version). +# The lists may be specified either as strings, or as @file-name. + +procedure t_mergei() + +int p1, p2 +char list1[SZ_LINE], list2[SZ_LINE] +pointer sp, rl1, rl2, op, xs, xe, ys, ye, os, oe +int fd, ch, xlen, ylen, olen, nx, ny, nout, i +int open(), getci(), qpex_parsei(), qp_rlmergei() + +begin + call smark (sp) + call salloc (rl1, SZ_RLBUF, TY_CHAR) + call salloc (rl2, SZ_RLBUF, TY_CHAR) + + # Get the first range list. + call clgstr ("list1", list1, SZ_LINE) + if (list1[1] == '@') { + fd = open (list1[2], READ_ONLY, TEXT_FILE) + op = rl1 + while (getci (fd, ch) != EOF) { + if (ch == '\n') + ch = ' ' + Memc[op] = ch + op = op + 1 + } + Memc[op] = EOS + } else + call strcpy (list1, Memc[rl1], SZ_RLBUF) + + # Get the second range list. + call clgstr ("list2", list2, SZ_LINE) + if (list2[1] == '@') { + fd = open (list2[2], READ_ONLY, TEXT_FILE) + op = rl2 + while (getci (fd, ch) != EOF) { + if (ch == '\n') + ch = ' ' + Memc[op] = ch + op = op + 1 + } + Memc[op] = EOS + } else + call strcpy (list2, Memc[rl2], SZ_RLBUF) + + # Parse the lists. + xlen = 100 + call malloc (xs, xlen, TY_INT) + call malloc (xe, xlen, TY_INT) + nx = qpex_parsei (Memc[rl1], xs, xe, xlen) + + ylen = 100 + call malloc (ys, ylen, TY_INT) + call malloc (ye, ylen, TY_INT) + ny = qpex_parsei (Memc[rl2], ys, ye, ylen) + + # Merge the lists. + olen = 100 + call malloc (os, olen, TY_INT) + call malloc (oe, olen, TY_INT) + nout = qp_rlmergei (os,oe,olen, + Memi[xs],Memi[xe],nx, Memi[ys],Memi[ye],ny) + + # Print results: + call printf ("---- list 1 -----\n") + do i = 1, nx { + p1 = Memi[xs+i-1] + p2 = Memi[xe+i-1] + call printf ("%8d %8s : %8s\n") + call pargi (i) + if (IS_LEFTI(p1)) + call pargstr ("left") + else + call pargi (p1) + if (IS_RIGHTI(p2)) + call pargstr ("right") + else + call pargi (p2) + } + + call printf ("---- list 2 -----\n") + do i = 1, ny { + p1 = Memi[ys+i-1] + p2 = Memi[ye+i-1] + call printf ("%8d %8s : %8s\n") + call pargi (i) + if (IS_LEFTI(p1)) + call pargstr ("left") + else + call pargi (p1) + if (IS_RIGHTI(p2)) + call pargstr ("right") + else + call pargi (p2) + } + + call printf ("---- merged -----\n") + do i = 1, nout { + p1 = Memi[os+i-1] + p2 = Memi[oe+i-1] + call printf ("%8d %8s : %8s\n") + call pargi (i) + if (IS_LEFTI(p1)) + call pargstr ("left") + else + call pargi (p1) + if (IS_RIGHTI(p2)) + call pargstr ("right") + else + call pargi (p2) + } + + # Free list storage. + call mfree (xs, TY_INT); call mfree (xe, TY_INT) + call mfree (ys, TY_INT); call mfree (ye, TY_INT) + call mfree (os, TY_INT); call mfree (oe, TY_INT) + + call sfree (sp) +end + + +# CLEAR -- Clear the terminal screen. + +procedure t_clear() + +pointer tty +pointer ttyodes() +errchk ttyodes + +begin + # Clear the screen. + tty = ttyodes ("terminal") + call ttyclear (STDOUT, tty) + call ttycdes (tty) +end diff --git a/sys/symtab/README b/sys/symtab/README new file mode 100644 index 00000000..2fb705a0 --- /dev/null +++ b/sys/symtab/README @@ -0,0 +1,126 @@ +SYMTAB -- General package for managing symbol tables. The logical view of a +symbol table is a collection of symbol structures. The contents of a symbol +description structure are user defined, but the size of the structure is fixed. +The symbol name is a character string of arbitrary size, all characters of +which are significant. The storage semantics of the symbol table are those +of a lifo stack, i.e., those symbols most recently defined must be the first +deleted. There is no fixed limit on the size of a symbol table; additional +space will be dynamically allocated at run time if necessary. + + + stp = stopen (name, len_index, len_stab, sz_sbuf) + stclose (stp) + stmark (stp, marker) # mark storage + stfree (stp, marker) # free to marked state + nsym = stnsymbols (stp, marker) # number of symbols in table + stinfo (stp, outfd) # print info about symbol table + + sym = stenter (stp, key, symlen) # enter new symbol in table + sym = stfind (stp, key) # search table for symbol + nsym = stfindall (stp, key, sym, maxsym) # find all occurrences of symbol + sym = sthead (stp) # last symbol entered into table + sym = stnext (stp, sym) # next symbol on global list + charp = stname (stp, sym) # access key name string + + offset = stpstr (stp, str, minchars) # put string in string buffer + offset = stalloc (stp, nints) # alloc space in STAB + charp = strefsbuf (stp, offset) # convert sbuf offset into charp + intp = strefstab (stp, offset) # convert stab offset into intp + + stsave (stp, fd) # save symbol table in a file + stp = strestore (fd) # restore symbol table from file + stsqueeze (stp) # return unused storage + chars = stsize (stp) # chars req'd to store table + + +The symbol table is maintained as a multi-threaded linked list. This provides +the efficiency of a hash table plus stack like semantics for redefinitions and +for freeing blocks of variables. There are three primary data structures +internally, an array of pointers to the heads of the threads (the index), +a buffer containing the list elements (the symbol table), and a string buffer. +These data structures are dynamically allocated and will be automatically +reallocated at runtime if overflow occurs. The number of threads is fixed at +table open time and determines the efficiency of table lookup. The expected +running time is O(1) for well conditioned tables, i.e., tables with a sparse +index. The worst case running time is O(N), i.e., the same as a linear search, +but of course the worst case is very unlikely to occur. Symbol entry and +storage reclamation are especially efficient due to the use of a stack rather +than a heap for symbol storage. + + symtab descriptor + index (integer array, size fixed at open time) + sbuf (char array, dynamic) + stab (list of symstructs, dynamic) + +Each symbol consists of a variable size structure (symstruct) in STAB containing +references to one or more associated strings in SBUF. A symstruct consists of +a fixed size SYMTAB header followed by a user defined structure, the size of +which is fixed at STENTER time. Each symstruct is linked on two lists, +a global list and a hash list. All symstructs are linked on the global list +which is ordered with the most recently entered symbol at the head of the list. +For a well conditioned table each hash list will typically contain zero or one +symbols, more when there are redefinitions or when identifiers happen to hash +to the same thread. Often it is useful to store different types of entries +in the same symbol table; since symstructs may vary in size this may be done +efficiently. + +The STOPEN procedure is used to create a new symbol table. The 'name' argument +may be any string and is used for documentation purposes only. The index +length argument sets the size of the hash index which is fixed for the +lifetime of the table. The remaining two arguments specify the amount of +symbol table space and string storage space to be initially allocated for the +table. The actual table may grow larger at runtime, but reallocation can be +expensive hence it is desirable to preallocate a large space if it is known +that the table will be large. + +The STMARK and STFREE procedures mark and free storage on the symbol table +stack. All symbols defined or redefined after a call to STMARK will be deleted +and storage freed by a call to STFREE. If a redef is freed the next most +recent definition becomes current. STFREE returns as its function value the +number of redefined variables uncovered by the free operation. The calling +program must mark and free in the correct order or the symbol table may be +trashed. The argument to STMARK is a magic integer which currently references +a marker record in the STAB containing the information necessary to mark and +free storage (an integer is not large enough to hold all of the necessary +information). + +STENTER is used to enter a new symbol into the symbol table. If the named +symbol is already present the new entry will nondestructively supercede the +old, which may be recovered by a subsequent STFREE (this is especially useful +for defining local contexts, e.g., when parsing a block structured language). +STENTER returns a pointer to the newly allocated symbol structure. This pointer +may be invalidated if the symbol table buffer has to be reallocated in a +subsequent call to STENTER. STFIND searches the symbol table for the named +key (symbol), returning a pointer to the most recently defined entry or NULL. +Once again, this pointer may be invalidated by a subsquent call which adds +to or removes symbols from the table. STFINDALL finds all occurrences (or +some maximum number of occurrences), returning an array of symstruct pointers +ordered with the most recently defined symbols at the left. STHEAD and STNEXT +are used to scan symbols in the reverse of the order in which they were +entered, e.g., for unkeyed symbol table searches. + +The symbol table uses an associated string buffer for string storage. Keys +(symbol names) are automatically added to the string buffer by STENTER. +The string buffer is maintained as a stack, with STMARK and STFREE marking +and freeing storage in the string buffer as well as in the symbol table buffer. +The user may store data in either the string buffer or the symbol table +provided the stack semantics are observed when marking and freeing storage. +To permit dynamic reallocation, storage is referenced by offset rather than +by pointer. Only offsets into SBUF or STAB should be stored in symbol table +entries. String storage is allocated in SBUF with STPSTR (which also deposits +the string). Integer aligned storage is allocated in STAB with STALLOC. +The offset of a string stored in SBUF may be converted to a char pointer +with STREFSBUF. The offset of a storage area in STAB may be converted into +an integer pointer with STREFSTAB. Pointer conversions such as these should +not be done in the calling program since doing so requires knowledge of the +internal SYMTAB data structures (in particular, that symbol table storage +is contiguous). + +A symbol table may be saved in a binary file using STSAVE. The space which +will be required to store the symbol table may be queried in advance with +STSIZE. The internal SYMTAB data structures are simply appended to the file. +The symbol table itself is not affected. A saved symbol table may be restored +to memory with STRESTORE, which is used in place of STOPEN. The file must be +opened and positioned to the correct offset before STRESTORE is called. +It may be desirable to call STSQUEEZE before calling STSAVE or STSIZE, +to minimize the file storage required to store the symbol table. diff --git a/sys/symtab/mkpkg b/sys/symtab/mkpkg new file mode 100644 index 00000000..7ce7d3bc --- /dev/null +++ b/sys/symtab/mkpkg @@ -0,0 +1,30 @@ +# Make the SYMTAB general symbol table package. + +$checkout libsys.a lib$ +$update libsys.a +$checkin libsys.a lib$ +$exit + +libsys.a: + stalloc.x symtab.h + stclose.x symtab.h + stenter.x symtab.h + stfind.x symtab.h + stfindall.x symtab.h + stfree.x symtab.h + sthash.x + sthead.x symtab.h + stinfo.x symtab.h + stmark.x symtab.h + stname.x symtab.h + stnext.x symtab.h + stnsym.x symtab.h + stopen.x symtab.h + stpstr.x symtab.h + strefsbuf.x symtab.h + strefstab.x symtab.h + strestore.x symtab.h + stsave.x symtab.h + stsize.x symtab.h + stsqueeze.x symtab.h + ; diff --git a/sys/symtab/stalloc.x b/sys/symtab/stalloc.x new file mode 100644 index 00000000..1300953b --- /dev/null +++ b/sys/symtab/stalloc.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "symtab.h" + +# STALLOC -- Allocate a block of double aligned storage in the symbol table. +# Increase the size of STAB if overflow occurs. + +int procedure stalloc (stp, blklen) + +pointer stp # symtab descriptor +int blklen # number of integer units of storage +int offset, buflen + +begin + offset = (ST_STABOP(stp) + 1) / 2 * 2 + buflen = ST_STABLEN(stp) + + if (offset + blklen > buflen) { + # Overflow has occurred. Allocate a larger buffer; if overflow + # continues to occur the increments grow successively larger to + # minimize reallocation. + + buflen = buflen + max (blklen, ST_STABINC(stp)) + ST_STABINC(stp) = min (MAX_INCREMENT, ST_STABINC(stp) * INC_GROW) + ST_STABLEN(stp) = buflen + ST_STABNGROW(stp) = ST_STABNGROW(stp) + 1 + + call realloc (ST_STABP(stp), buflen, TY_STRUCT) + } + + ST_STABOP(stp) = offset + ((blklen + 1) / 2 * 2) + return (offset) +end diff --git a/sys/symtab/stclose.x b/sys/symtab/stclose.x new file mode 100644 index 00000000..dc0991ed --- /dev/null +++ b/sys/symtab/stclose.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "symtab.h" + +# STCLOSE -- Return all storage used by a symbol table. + +procedure stclose (stp) + +pointer stp # symbol table descriptor + +begin + call mfree (ST_STABP(stp), TY_STRUCT) + call mfree (ST_SBUFP(stp), TY_CHAR) + call mfree (ST_INDEX(stp), TY_INT) + call mfree (stp, TY_STRUCT) +end diff --git a/sys/symtab/stenter.x b/sys/symtab/stenter.x new file mode 100644 index 00000000..04294c97 --- /dev/null +++ b/sys/symtab/stenter.x @@ -0,0 +1,59 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "symtab.h" + +# STENTER -- Add a symbol to the symbol table. If the named symbol is already +# present in the table it will be redefined until STFREE is called to return +# the storage allocated for the current symbol. A pointer to the user part +# of the symstruct is returned as the function value. + +pointer procedure stenter (stp, key, u_symlen) + +pointer stp # symbol table descriptor +char key[ARB] # symbol name +int u_symlen # length of user part of symstruct (su) + +long sum +pointer el, tp +int symlen, new_symbol, thread, ip +int stpstr(), stalloc() +errchk stalloc, stpstr + +begin + if (key[1] == EOS) + call error (1, "stenter: null key string") + + # Hash the key onto a thread in the index. + sum = 0 + do ip = 1, MAX_HASHCHARS { + if (key[ip] == EOS) + break + sum = sum + (sum + key[ip]) + } + + thread = mod (sum, ST_INDEXLEN(stp)) + tp = ST_INDEX(stp) + thread + + # Allocate space in STAB. + symlen = LEN_SYMSTRUCT + u_symlen + new_symbol = stalloc (stp, symlen) + + # Initialize symstruct. + el = ST_STABP(stp) + new_symbol + E_NEXTHASH(el) = Memi[tp] + E_NEXTGLOB(el) = ST_LASTSYMBOL(stp) + E_THREAD(el) = thread + E_KEY(el) = stpstr (stp, key, 0) + + # Set the head of thread list and the head of the global list to + # point to the new symbol. Flag the first key character (used to + # quickly determine that a key beginning with a certain character + # is not present in the table). + + Memi[tp] = new_symbol + ST_LASTSYMBOL(stp) = new_symbol + ST_NSYMBOLS(stp) = ST_NSYMBOLS(stp) + 1 + ST_ASCII(stp,key[1]) = 1 + + return (E_USERFIELDS(el)) +end diff --git a/sys/symtab/stfind.x b/sys/symtab/stfind.x new file mode 100644 index 00000000..5ea75f77 --- /dev/null +++ b/sys/symtab/stfind.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "symtab.h" + +# STFIND -- Search the symbol table for the named key and return a pointer to +# the symstruct or NULL. This is the main table lookup procedure. If the +# thread is empty NULL is returned after only a hash function call. If there +# is only one element on a thread (common for well conditioned symbol tables) +# the expense is essentialy two traversals of the key string plus procedure +# overhead (pointer calculations, etc.). + +pointer procedure stfind (stp, key) + +pointer stp # symbol table descriptor +char key[ARB] # symbol name + +long sum +char first_char +int head, ip, thread +pointer el, cp, stab, sbuf + +begin + # When a symbol is entered in the table a flag is set in the ST_ASCII + # array to flag that the symbol table contains at least one key + # beginning with that character. If the flag is not set we can thus + # determine very quickly that the symbol is not present. This is + # important for applications such as mapping identifiers for macro + # expansion, where most macros have upper case keys but most program + # identifiers have lower case keys. (Subtle note: since the first + # element of ST_ASCII is for ascii value 0=EOS, the following also + # serves to detect null keys). + + if (ST_ASCII(stp,key[1]) == 0) + return (NULL) + + # Hash the key onto a thread in the index. + sum = 0 + do ip = 1, MAX_HASHCHARS { + if (key[ip] == EOS) + break + sum = sum + (sum + key[ip]) + } + + thread = mod (sum, ST_INDEXLEN(stp)) + head = Memi[ST_INDEX(stp)+thread] + + # If thread is not empty search down it for the named key and return + # the symbol pointer if found. Note that the value of the E_NEXTHASH + # pointer is given as an integer offset to facilitate reallocation + # upon overflow. + + if (head != NULL) { + first_char = key[1] + sbuf = ST_SBUFP(stp) + stab = ST_STABP(stp) + + for (el=stab+head; el > stab; el=stab+E_NEXTHASH(el)) { + cp = sbuf + E_KEY(el) + if (Memc[cp] != first_char) + next + + # Compare target key to symbol key. + do ip = 1, MAX_SZKEY { + if (key[ip] != Memc[cp]) + break + if (key[ip] == EOS) + return (E_USERFIELDS(el)) # found key + cp = cp + 1 + } + } + } + + return (NULL) +end diff --git a/sys/symtab/stfindall.x b/sys/symtab/stfindall.x new file mode 100644 index 00000000..d0477c5a --- /dev/null +++ b/sys/symtab/stfindall.x @@ -0,0 +1,81 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "symtab.h" + +# STFINDALL -- Search the symbol table for the named key and return an array +# of symstruct pointers to all symbols with the given key. The array is +# ordered with the most recently entered symbols at the beginning. The number +# of symbols found is returned as the function value. + +int procedure stfindall (stp, key, symbols, max_symbols) + +pointer stp # symbol table descriptor +char key[ARB] # symbol name +pointer symbols[max_symbols] # pointers to the symstructs +int max_symbols + +long sum +char first_char +int head, ip, nsym, thread +pointer el, cp, stab, sbuf + +begin + # When a symbol is entered in the table a flag is set in the ST_ASCII + # array to flag that the symbol table contains at least one key + # beginning with that character. If the flag is not set we can thus + # determine very quickly that the symbol is not present. This is + # important for applications such as mapping identifiers for macro + # expansion, where most macros have upper case keys but most program + # identifiers have lower case keys. (Subtle note: since the first + # element of ST_ASCII is for ascii value 0=EOS, the following also + # serves to detect null keys). + + if (ST_ASCII(stp,key[1]) == 0) + return (NULL) + + # Hash the key onto a thread in the index. + sum = 0 + do ip = 1, MAX_HASHCHARS { + if (key[ip] == EOS) + break + sum = sum + (sum + key[ip]) + } + + thread = mod (sum, ST_INDEXLEN(stp)) + head = Memi[ST_INDEX(stp)+thread] + + # If thread is not empty search down it for the named key and return + # pointers to all occurrences of the symbol. + + nsym = 0 + + if (head != NULL && max_symbols > 0) { + first_char = key[1] + sbuf = ST_SBUFP(stp) + stab = ST_STABP(stp) + + for (el=stab+head; el > stab; el=stab+E_NEXTHASH(el)) { + cp = sbuf + E_KEY(el) + if (Memc[cp] != first_char) + next + + # If the first character of the key matches compare the full + # string and output a symstruct pointer if we have a match. + + do ip = 1, MAX_SZKEY { + if (key[ip] != Memc[cp]) + break + if (key[ip] == EOS) { + nsym = nsym + 1 + symbols[nsym] = E_USERFIELDS(el) + if (nsym >= max_symbols) + return (max_symbols) + break + } + cp = cp + 1 + } + } + } + + return (nsym) +end diff --git a/sys/symtab/stfree.x b/sys/symtab/stfree.x new file mode 100644 index 00000000..1a960fe5 --- /dev/null +++ b/sys/symtab/stfree.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "symtab.h" + +# STFREE -- Free storage back to the last marker. No storage is actually +# returned to the system, rather the storage is made available for reuse +# by SYMTAB (the stacks are pruned). + +procedure stfree (stp, marker) + +pointer stp # symtab descriptor +int marker # magic marker + +int el +pointer index, stab, ep, mp + +begin + index = ST_INDEX(stp) + stab = ST_STABP(stp) + mp = stab + marker + ep = NULL + + # Ignore requests with out of range markers. + if (marker <= 0 || marker >= ST_STABOP(stp)) + return + + # Descend the global (time ordered) list, unlinking each symbol until + # the marker position is reached. + + for (el = ST_LASTSYMBOL(stp); el > marker; el = E_NEXTGLOB(ep)) { + ep = stab + el + Memi[index+E_THREAD(ep)] = E_NEXTHASH(ep) + } + + # Reset the stack pointers and set the head of the global list to + # point to the symbol immediately preceding the marker. + + ST_NSYMBOLS(stp) = M_NSYMBOLS(mp) + ST_SBUFOP(stp) = M_SBUFOP(mp) + ST_STABOP(stp) = marker + + if (ep != NULL) + ST_LASTSYMBOL(stp) = E_NEXTGLOB(ep) +end diff --git a/sys/symtab/sthash.x b/sys/symtab/sthash.x new file mode 100644 index 00000000..c9cd00b9 --- /dev/null +++ b/sys/symtab/sthash.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define MAX_HASHCHARS 18 + +# STHASH -- Compute the hash index of a key, i.e., the index of a thread in +# the symbol table index. Multiple keys may hash to the same thread. The +# ideal hash function will uniformly map keys into index space, both when the +# keys are selected randomly and when the keys form patterns, e.g., when keys +# share a common prefix. The SYMTAB package uses a simple hash function which +# is computed inline. The STHASH function is NOT used at present, but is +# included in the library anyway for use in other packages and because this +# is a slightly better (more uniform) hashing function than the simple inline +# version used in SYMTAB. + +int procedure sthash (key, modulus) + +char key[ARB] # character string serving as a key +int modulus # number of possible output values + +int i +long sum +int primes[MAX_HASHCHARS] +data (primes(i),i=1,9) /101,103,107,109,113,127,131,137,139/ +data (primes(i),i=10,18) /149,151,157,163,167,173,179,181,191/ + +begin + sum = 0 + + # Hash up to len(primes)=18 characters from the key. + do i = 1, MAX_HASHCHARS { + if (key[i] == EOS) + break + sum = sum + (key[i] * primes[i]) + } + + return (mod (sum, modulus) + 1) +end diff --git a/sys/symtab/sthead.x b/sys/symtab/sthead.x new file mode 100644 index 00000000..f341c934 --- /dev/null +++ b/sys/symtab/sthead.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "symtab.h" + +# STHEAD -- Return a symstruct pointer to the last symbol entered into the +# table. The NULL pointer is returned when the symbol table is empty. + +pointer procedure sthead (stp) + +pointer stp # symtab descriptor + +begin + if (ST_LASTSYMBOL(stp) == NULL) + return (NULL) + else + return (E_USERFIELDS (ST_STABP(stp) + ST_LASTSYMBOL(stp))) +end diff --git a/sys/symtab/stinfo.x b/sys/symtab/stinfo.x new file mode 100644 index 00000000..cbc2f441 --- /dev/null +++ b/sys/symtab/stinfo.x @@ -0,0 +1,142 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "symtab.h" + +# STINFO -- Print interesting information on the inner workings and contents +# of the symbol table. + +procedure stinfo (stp, fd, verbose) + +pointer stp # symtab descriptor +int fd # output file +int verbose # if YES, trace each thread + +pointer index, stab, sbuf, ep +int keylen, min_keylen, max_keylen, nsymbols, el, i, head +int nthreads, max_threadlen, nonnull_threads, nsym +real sum, mean_hash_index, avg_keylen, avg_threadlen +int strlen() + +begin + index = ST_INDEX(stp) + stab = ST_STABP(stp) + sbuf = ST_SBUFP(stp) + + # Print the symbol table name. + ep = sbuf + ST_NAME(stp) + call fprintf (fd, "name: %s\n") + if (Memc[ep] == EOS) + call pargstr ("(none given)") + else + call pargstr (Memc[ep]) + + # Print information on memory usage. + call fprintf (fd, + "index=(%x,%d), stab=(%x,%d,%d%%), sbuf=(%x,%d,%d%%)\n") + call pargi (index) + call pargi (ST_INDEXLEN(stp)) + call pargi (stab) + call pargi (ST_STABLEN(stp)) + call pargr (ST_STABOP(stp) * 100.0 / ST_STABLEN(stp)) + call pargi (sbuf) + call pargi (ST_SBUFLEN(stp)) + call pargr (ST_SBUFOP(stp) * 100.0 / ST_SBUFLEN(stp)) + + call fprintf (fd, + "sbuf reallocated %d times, stab reallocated %d times\n") + call pargi (ST_SBUFNGROW(stp)) + call pargi (ST_STABNGROW(stp)) + + # Scan the symbols and compute the min, max, and mean key lengths. + # Count the number of symbols. + + min_keylen = MAX_SZKEY + max_keylen = 0 + avg_keylen = 0 + nsymbols = 0 + sum = 0 + + for (el = ST_LASTSYMBOL(stp); el != NULL; el = E_NEXTGLOB(ep)) { + nsymbols = nsymbols + 1 + ep = stab + el + + keylen = strlen (Memc[sbuf+E_KEY(ep)]) + min_keylen = min (min_keylen, keylen) + max_keylen = max (max_keylen, keylen) + sum = sum + keylen + } + + if (nsymbols > 0) + avg_keylen = sum / nsymbols + else + min_keylen = 0 + + call fprintf (fd, + "nsymbols=%d, minkeylen=%d, maxkeylen=%d, avgkeylen=%.1f\n") + call pargi (nsymbols) + call pargi (min_keylen) + call pargi (max_keylen) + call pargr (avg_keylen) + + # Scan the index and compute the number of nonnull threads, the + # mean and max thread lengths, and the mean hash index, which should + # be near the center of the index. + + nthreads = ST_INDEXLEN(stp) + mean_hash_index = 0 + nonnull_threads = 0 + max_threadlen = 0 + avg_threadlen = 0 + sum = 0 + + if (verbose == YES) + call fprintf (fd, "----------- threads ----------\n") + + do i = 1, nthreads { + if (verbose == YES) { + call fprintf (fd, "[%4d] ") + call pargi (i) + } + + head = Memi[index+i-1] + if (head != NULL) { + nonnull_threads = nonnull_threads + 1 + + # Count the number of symbols on the thread. + nsym = 0 + for (el=head; el != NULL; el=E_NEXTHASH(ep)) { + nsym = nsym + 1 + ep = stab + el + + if (verbose == YES) { + call fprintf (fd, "%s ") + call pargstr (Memc[sbuf+E_KEY(ep)]) + } + } + + + max_threadlen = max (max_threadlen, nsym) + sum = sum + (nsym * i) + } + + if (verbose == YES) + call fprintf (fd, "\n") + } + + if (nonnull_threads > 0) { + avg_threadlen = real(nsymbols) / nonnull_threads + mean_hash_index = sum / nsymbols + } + + if (verbose == YES) + call fprintf (fd, "---------------------\n") + + call fprintf (fd, + "nthreads=%d, maxlen=%d, avglen=%.1f, meanindex=%.1f\n") + call pargi (nonnull_threads) + call pargi (max_threadlen) + call pargr (avg_threadlen) + call pargr (mean_hash_index) + + call flush (fd) +end diff --git a/sys/symtab/stmark.x b/sys/symtab/stmark.x new file mode 100644 index 00000000..1caeecb0 --- /dev/null +++ b/sys/symtab/stmark.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "symtab.h" + +# STMARK -- Mark the top of the STAB and SBUF stacks so that storage may +# later be returned with STFREE. Since two integers of storage are required +# for the mark, the extra information is saved at the current position in STAB. +# The location of this entry in STAB marks the position to which STAB is later +# to be restored. + +procedure stmark (stp, marker) + +pointer stp # symtab descriptor +int marker # magic marker + +pointer mp +int stalloc() + +begin + marker = stalloc (stp, LEN_MARKER) + mp = ST_STABP(stp) + marker + + M_SBUFOP(mp) = ST_SBUFOP(stp) + M_NSYMBOLS(mp) = ST_NSYMBOLS(stp) +end diff --git a/sys/symtab/stname.x b/sys/symtab/stname.x new file mode 100644 index 00000000..9e10617e --- /dev/null +++ b/sys/symtab/stname.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "symtab.h" + +# STNAME -- Return a char pointer to the key string (symbol name) of a symbol +# table entry, given a pointer to the symbol structure. + +pointer procedure stname (stp, sym) + +pointer stp # symtab descriptor +pointer sym # pointer to 'current' symstruct + +begin + return (ST_SBUFP(stp) + E_KEY(E_BASE(sym))) +end diff --git a/sys/symtab/stnext.x b/sys/symtab/stnext.x new file mode 100644 index 00000000..2304f00c --- /dev/null +++ b/sys/symtab/stnext.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "symtab.h" + +# STNEXT -- Return a symstruct pointer to the next most recently entered +# symbol in the table, given a pointer to some symbol. Use to walk down +# the global symbol table list in the reverse of the order in which symbols +# were entered. + +pointer procedure stnext (stp, sym) + +pointer stp # symtab descriptor +pointer sym # pointer to 'current' symstruct +int el + +begin + if (sym == NULL) + return (NULL) + else { + el = E_NEXTGLOB (E_BASE(sym)) + if (el == NULL) + return (NULL) + else + return (E_USERFIELDS (ST_STABP(stp) + el)) + } +end diff --git a/sys/symtab/stnsym.x b/sys/symtab/stnsym.x new file mode 100644 index 00000000..f3d0f8e1 --- /dev/null +++ b/sys/symtab/stnsym.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "symtab.h" + +# STNSYMBOLS -- Return the number of symbols in the symbol table or in a +# marked segment, i.e., the number of symbols added to the table since the +# mark was made. + +int procedure stnsymbols (stp, marker) + +pointer stp # symbol table pointer +int marker # stmark marker or 0 for entire table + +pointer mp + +begin + if (marker <= 0) + return (ST_NSYMBOLS(stp)) + else { + mp = ST_STABP(stp) + marker + return (ST_NSYMBOLS(stp) - M_NSYMBOLS(mp)) + } +end diff --git a/sys/symtab/stopen.x b/sys/symtab/stopen.x new file mode 100644 index 00000000..ede4f727 --- /dev/null +++ b/sys/symtab/stopen.x @@ -0,0 +1,60 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "symtab.h" + +# STOPEN -- Create and initialize a new symbol table. The size of the table +# and the size of the hash index are user defined. Any number of symbol +# tables may be open simultaneously. LEN_SYMBTAB is the initial length of +# the symbol table in struct units. LEN_INDEX is the number of hash threads; +# a good choice for this value is twice the expected number of symbols in the +# table, but good performance can be expected even if the number of symbols +# is several times the size of the index. The index consumes SZ_INT chars per +# index element. + +pointer procedure stopen (name, len_index, len_stab, sz_sbuf) + +char name[ARB] # symbol table name (optional) +int len_index # number of hash threads in index +int len_stab # initial length of STAB +int sz_sbuf # initial size of string buffer + +pointer stp +int stpstr() + +begin + # Allocate symtab descriptor. + call calloc (stp, LEN_SYMTAB, TY_STRUCT) + ST_MAGIC(stp) = MAGIC + + # Allocate index. + call calloc (ST_INDEX(stp), len_index, TY_INT) + ST_INDEXLEN(stp) = len_index + + # Allocate string buffer. The first char of storage, at offset 0, + # is set to EOS so that offset 0 may be used to reference the null + # string. + + call malloc (ST_SBUFP(stp), sz_sbuf, TY_CHAR) + ST_SBUFINC(stp) = max (1, nint (sz_sbuf * INC_START)) + ST_SBUFLEN(stp) = sz_sbuf + ST_SBUFOP(stp) = 1 + ST_SBUFNGROW(stp) = 0 + Memc[ST_SBUFP(stp)] = EOS + + # Allocate symbol table. The initial STABOP (offset into STAB) is set + # to 1 rather than 0 since 0 as an STAB offset is used to mark the end + # of a list. + + call malloc (ST_STABP(stp), len_stab, TY_STRUCT) + ST_STABINC(stp) = max (1, nint (len_stab * INC_START)) + ST_STABLEN(stp) = len_stab + ST_STABOP(stp) = 1 + ST_STABNGROW(stp) = 0 + + # Save the symbol table name in the string buffer. This name is + # for documentation purposes only (it is printed by STINFO). + + ST_NAME(stp) = stpstr (stp, name, 0) + + return (stp) +end diff --git a/sys/symtab/stpstr.x b/sys/symtab/stpstr.x new file mode 100644 index 00000000..2de04a60 --- /dev/null +++ b/sys/symtab/stpstr.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "symtab.h" + +# STPSTR -- Append a string to the string buffer. The offset of the string +# in the string buffer is returned as the function value. More storage is +# allocated if we run out of room in the buffer. The number of chars of +# storage allocated (excluding space for the EOS) is strlen(str) or MINCHARS, +# whichever is larger. To allocate but not initialize space STR may be passed +# as the null string. To allocate precisely the amount of space required to +# store a string constant MINCHARS should be set to zero. + +int procedure stpstr (stp, str, minchars) + +pointer stp # symtab descriptor +char str[ARB] # string to be moved into storage +int minchars # minimum number of chars to reserve + +int offset, buflen, blklen +int strlen() +errchk realloc + +begin + offset = ST_SBUFOP(stp) + buflen = ST_SBUFLEN(stp) + blklen = max (strlen(str), minchars) + 1 + + if (offset + blklen > buflen) { + # Overflow has occurred. Allocate a larger buffer; if overflow + # continues to occur the increments grow successively larger to + # minimize reallocation. + + buflen = buflen + max (blklen, ST_SBUFINC(stp)) + ST_SBUFINC(stp) = min (MAX_INCREMENT, ST_SBUFINC(stp) * INC_GROW) + ST_SBUFLEN(stp) = buflen + ST_SBUFNGROW(stp) = ST_SBUFNGROW(stp) + 1 + + call realloc (ST_SBUFP(stp), buflen, TY_CHAR) + } + + ST_SBUFOP(stp) = ST_SBUFOP(stp) + blklen + call strcpy (str, Memc[ST_SBUFP(stp)+offset], blklen) + + return (offset) +end diff --git a/sys/symtab/strefsbuf.x b/sys/symtab/strefsbuf.x new file mode 100644 index 00000000..d0be6437 --- /dev/null +++ b/sys/symtab/strefsbuf.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "symtab.h" + +# STREFSBUF -- Convert an offset into SBUF into a pointer to char. + +pointer procedure strefsbuf (stp, offset) + +pointer stp # symtab descriptor +int offset # offset into SBUF + +begin + return (ST_SBUFP(stp) + offset) +end diff --git a/sys/symtab/strefstab.x b/sys/symtab/strefstab.x new file mode 100644 index 00000000..c55473af --- /dev/null +++ b/sys/symtab/strefstab.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "symtab.h" + +# STREFSTAB -- Convert an offset into STAB into a pointer to int. + +pointer procedure strefstab (stp, offset) + +pointer stp # symtab descriptor +int offset # offset into STAB + +begin + return (ST_STABP(stp) + offset) +end diff --git a/sys/symtab/strestore.x b/sys/symtab/strestore.x new file mode 100644 index 00000000..b3989d2b --- /dev/null +++ b/sys/symtab/strestore.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "symtab.h" + +# STRESTORE -- Restore to memory a symbol table previously saved in a file +# with STSAVE. The file must be positioned to the correct offset before +# we are called. STRESTORE is called in place of STOPEN and returns a +# symtab descriptor pointer as the function value. The symbol table is +# restored to exactly the state it was in when STSAVE was called. Note +# that since SYMTAB symbol tables use only relative offsets internally, +# the data structures may be relocated anywhere in memory when they are +# read back from the file. The symbol table is stored externally in a +# machine independent binary file. + +pointer procedure strestore (fd) + +int fd # file from which symbol table is to be read + +int nelem +pointer stp, stab, sbuf, index +int miireadc(), miireadi() +errchk miireadc, miireadi +define readerr_ 91 + +begin + index = NULL + stab = NULL + sbuf = NULL + + # Read symbol table descriptor. + call malloc (stp, LEN_SYMTAB, TY_STRUCT) + if (miireadi (fd, Memi[stp], LEN_SYMTAB) < LEN_SYMTAB) + goto readerr_ + + if (ST_MAGIC(stp) != MAGIC) + call error (1, "strestore: bad magic in save file") + + # Read the hash table index. + nelem = ST_INDEXLEN(stp) + call malloc (index, nelem, TY_INT) + if (miireadi (fd, Memi[index], nelem) < nelem) + goto readerr_ + + # Read the symbol table data. + nelem = ST_STABLEN(stp) + call malloc (stab, nelem, TY_STRUCT) + if (miireadi (fd, Memi[stab], nelem) < nelem) + goto readerr_ + + # Read the string buffer. + nelem = ST_SBUFLEN(stp) + call malloc (sbuf, nelem, TY_CHAR) + if (miireadc (fd, Memc[sbuf], nelem) < nelem) + goto readerr_ + + ST_INDEX(stp) = index + ST_SBUFP(stp) = sbuf + ST_STABP(stp) = stab + + return (stp) + +readerr_ + call mfree (sbuf, TY_CHAR) + call mfree (stab, TY_STRUCT) + call mfree (index, TY_INT) + call mfree (stp, TY_STRUCT) + + call error (2, "strestore: unexpected EOF") +end diff --git a/sys/symtab/stsave.x b/sys/symtab/stsave.x new file mode 100644 index 00000000..a77d710f --- /dev/null +++ b/sys/symtab/stsave.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "symtab.h" + +define SZ_BLOCK 2048 + + +# STSAVE -- Save the symbol table in an external binary file in a machine +# independent format. This works provided only integer and character data +# is stored in the symbol table. + +procedure stsave (stp, fd) + +pointer stp # symtab descriptor +int fd # output file + +int nelem +int ip, itop +errchk miiwritei, miiwritec + +begin + call miiwritei (fd, Memi[stp], LEN_SYMTAB) + call miiwritei (fd, Memi[ST_INDEX(stp)], ST_INDEXLEN(stp)) + + # Since the symbol table can be very large, write it out in chunks + # of a reasonable size to avoid allocating large buffers. + + itop = ST_STABP(stp) + ST_STABLEN(stp) + for (ip=ST_STABP(stp); ip < itop; ip=ip+nelem) { + nelem = min (SZ_BLOCK, itop - ip) + call miiwritei (fd, Memi[ip], nelem) + } + + # Ditto for the string buffer. + + itop = ST_SBUFP(stp) + ST_SBUFLEN(stp) + for (ip=ST_SBUFP(stp); ip < itop; ip=ip+nelem) { + nelem = min (SZ_BLOCK, itop - ip) + call miiwritec (fd, Memc[ip], nelem) + } +end diff --git a/sys/symtab/stsize.x b/sys/symtab/stsize.x new file mode 100644 index 00000000..3ccc6d0d --- /dev/null +++ b/sys/symtab/stsize.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "symtab.h" + +# STSIZE -- Compute the file storage space in chars required to store the +# symbol table, e.g., in a subsequent call to STSAVE. + +int procedure stsize (stp) + +pointer stp # symbol table descriptor + +int size +int miipksize() + +begin + size = miipksize (LEN_SYMTAB + ST_INDEXLEN(stp) + ST_STABLEN(stp), + MII_LONG) + miipksize (ST_SBUFLEN(stp), MII_BYTE) + + return (size) +end diff --git a/sys/symtab/stsqueeze.x b/sys/symtab/stsqueeze.x new file mode 100644 index 00000000..47f7b227 --- /dev/null +++ b/sys/symtab/stsqueeze.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "symtab.h" + +# STSQUEEZE -- Return any unused storage in a symbol table. This is useful +# when it is known that no more symbols will be entered in a table, or before +# saving a symbol table in a save file. + +procedure stsqueeze (stp) + +pointer stp # symtab descriptor + +begin + if (ST_STABLEN(stp) > ST_STABOP(stp)) { + ST_STABLEN(stp) = ST_STABOP(stp) + ST_STABINC(stp) = min (MAX_INCREMENT, ST_STABLEN(stp)) + call realloc (ST_STABP(stp), ST_STABLEN(stp), TY_STRUCT) + } + + if (ST_SBUFLEN(stp) > ST_SBUFOP(stp)) { + ST_SBUFLEN(stp) = ST_SBUFOP(stp) + ST_SBUFINC(stp) = min (MAX_INCREMENT, ST_SBUFLEN(stp)) + call realloc (ST_SBUFP(stp), ST_SBUFLEN(stp), TY_CHAR) + } +end diff --git a/sys/symtab/symtab.h b/sys/symtab/symtab.h new file mode 100644 index 00000000..25f30ace --- /dev/null +++ b/sys/symtab/symtab.h @@ -0,0 +1,54 @@ +# SYMTAB definitions. + +define MAX_HASHCHARS 18 # max characters used in hash function +define SZ_ASCII 128 # max possible character values +define INC_START 0.50 # used in overflow algorithm +define INC_GROW 2 # growing factor for increment +define MAX_INCREMENT 32768 # max sbuf or stab increment +define MAX_SZKEY 256 # arbitrarily large number + +# Symbol table descriptor. + +define LEN_SYMTAB 256 +define MAGIC 0123124B + +define ST_MAGIC Memi[$1] # for error checking +define ST_NAME Memi[$1+1] # optional name for symbol table +define ST_LASTSYMBOL Memi[$1+2] # last element entered +define ST_NSYMBOLS Memi[$1+3] # number of symbols in table + # (extra space) +define ST_INDEX Memi[$1+5] # pointer to buffer of thread indices +define ST_INDEXLEN Memi[$1+6] # length of index + # (extra space) +define ST_SBUFP Memi[$1+10] # string buffer +define ST_SBUFLEN Memi[$1+11] # current size of string buffer +define ST_SBUFOP Memi[$1+12] # next location in string buffer +define ST_SBUFINC Memi[$1+13] # increment if overflow occurs +define ST_SBUFNGROW Memi[$1+14] # number of reallocs of sbuf + # (extra space) +define ST_STABP Memi[$1+20] # symbol table +define ST_STABLEN Memi[$1+21] # symbol table length +define ST_STABOP Memi[$1+22] # next location in symbol table +define ST_STABINC Memi[$1+23] # increment if overflow occurs +define ST_STABNGROW Memi[$1+24] # number of reallocs of stab + # (extra space) +define ST_ASCII Memi[($1+30)+$2] + +# Symstruct. STAB contains an array of these, each of which is linked both +# on a thread and on the global lifo list. + +define LEN_SYMSTRUCT 4 + +define E_NEXTHASH Memi[$1] # next element on thread +define E_NEXTGLOB Memi[$1+1] # next element on global list +define E_THREAD Memi[$1+2] # index of thread in INDEX array +define E_KEY Memi[$1+3] # index of key name + +define E_USERFIELDS ($1+LEN_SYMSTRUCT) +define E_BASE ($1-LEN_SYMSTRUCT) + +# Magic marker structure (for mark/free). + +define LEN_MARKER 2 +define M_SBUFOP Memi[$1] # saved string buffer offset +define M_NSYMBOLS Memi[$1+1] # nsymbols in table below marker diff --git a/sys/symtab/zzdebug.x b/sys/symtab/zzdebug.x new file mode 100644 index 00000000..a113a4e9 --- /dev/null +++ b/sys/symtab/zzdebug.x @@ -0,0 +1,283 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +task sym = t_sym + +define LOOKUP 1 +define ENTER 2 +define MARK 3 +define FREE 4 +define LISTALL 5 +define SQUEEZE 6 +define SAVE 7 +define RESTORE 8 +define INFO 9 +define SCANFILE 10 +define HELP 11 + + +# SYM -- Test symbol entry and retrieval using the SYMTAB package. + +procedure t_sym() + +bool timeit +pointer stp, sym +long svtime[2] +char lbuf[SZ_LINE], key[SZ_FNAME] +int ip, lp, stmt, marker, fd, indexlen, stablen, sbuflen, junk + +bool clgetb() +int ctowrd(), strlen(), getline(), strmatch() +int stpstr(), sthead(), stnext(), open(), clgeti() +pointer stopen(), stfind(), stenter(), strestore() + +begin + indexlen = clgeti ("indexlen") + stablen = clgeti ("stablen") + sbuflen = clgeti ("sbuflen") + timeit = clgetb ("timeit") + + stp = stopen ("symtab.zzdebug test symbol table", + indexlen, stablen, sbuflen) + + repeat { + call printf ("* ") + call flush (STDOUT) + if (getline (STDIN, lbuf) == EOF) { + call printf ("\n") + break + } else if (strmatch (lbuf, "^bye") > 0) + break + + for (ip=1; IS_WHITE(lbuf[ip]); ip=ip+1) + ; + + # Determine type of statement. + switch (lbuf[ip]) { + case '\n': + next + case '=': + ip = ip + 1 + stmt = LOOKUP + default: + if (strmatch (lbuf[ip], "^.mark") > 0) { + stmt = MARK + } else if (strmatch (lbuf[ip], "^.free") > 0) { + stmt = FREE + } else if (strmatch (lbuf[ip], "^.list") > 0) { + stmt = LISTALL + } else if (strmatch (lbuf[ip], "^.squeeze") > 0) { + stmt = SQUEEZE + } else if (strmatch (lbuf[ip], "^.save") > 0) { + stmt = SAVE + ip = ip + 5 + } else if (strmatch (lbuf[ip], "^.restore") > 0) { + stmt = RESTORE + ip = ip + 8 + } else if (strmatch (lbuf[ip], "^.info") > 0) { + stmt = INFO + ip = ip + 5 + } else if (strmatch (lbuf[ip], "^.scanfile") > 0) { + stmt = SCANFILE + ip = ip + 9 + } else if (strmatch (lbuf[ip], "^.help") > 0) { + stmt = HELP + ip = ip + 5 + } else + stmt = ENTER + } + + # Extract key name (or filename). + junk = ctowrd (lbuf, ip, key, SZ_FNAME) + + if (timeit) + call sys_mtime (svtime) + + switch (stmt) { + case LOOKUP: + # Lookup symbol in table. + sym = stfind (stp, key) + + if (sym == NULL) { + call eprintf ("`%s' not found\n") + call pargstr (key) + next + } + + # Print keyword = value. + call psym (stp, sym) + + case ENTER: + # Enter symbol in table. + sym = stenter (stp, key, 1) + + # Get offset of value string. + ip = strmatch (lbuf, "=") + if (ip == 0) + ip = strlen(lbuf) + 1 + else { + while (IS_WHITE (lbuf[ip])) + ip = ip + 1 + } + + # Step on the newline. + for (lp=ip; lbuf[lp] != EOS; lp=lp+1) + if (lbuf[lp] == '\n') { + lbuf[lp] = EOS + break + } + + # Deposit value string in symbol table string buffer and save + # offset in symstruct. + + Memi[sym] = -stpstr (stp, lbuf[ip], 0) + + case MARK: + call stmark (stp, marker) + + case FREE: + call stfree (stp, marker) + + case LISTALL: + for (sym=sthead(stp); sym != NULL; sym=stnext(stp,sym)) + call psym (stp, sym) + + case SQUEEZE: + call stsqueeze (stp) + + case SAVE: + # In this case 'key' contains the savefile filename. + iferr (call delete (key)) + ; + iferr (fd = open (key, NEW_FILE, BINARY_FILE)) { + call erract (EA_WARN) + next + } + + call stsave (stp, fd) + call close (fd) + + case RESTORE: + # In this case 'key' contains the savefile filename. + + iferr (fd = open (key, READ_ONLY, BINARY_FILE)) { + call erract (EA_WARN) + next + } + + call stclose (stp) + stp = strestore (fd) + call close (fd) + + case INFO: + if (key[1] == 'v') + call stinfo (stp, STDOUT, YES) + else + call stinfo (stp, STDOUT, NO) + + case SCANFILE: + call scanfile (key, stp) + + case HELP: + call zz_help (STDOUT) + default: + call eprintf ("syntax error\n") + } + + if (timeit) + call sys_ptime (STDOUT, key, svtime) + } + + call stclose (stp) +end + + +# SCANFILE -- Scan a text file, breaking the input up into a series of tokens. +# Place each new integer token in the symbol table. If the token is already +# present in the table, increment its count field. + +procedure scanfile (fname, stp) + +char fname[ARB] # file to be scanned +pointer stp # symtab descriptor + +char lbuf[SZ_LINE], tokbuf[SZ_FNAME] +int fd, ip, token +pointer sym +int open(), getline(), ctotok() +pointer stenter(), stfind() +errchk open, stenter + +begin + fd = open (fname, READ_ONLY, TEXT_FILE) + + while (getline (fd, lbuf) != EOF) { + ip = 1 + repeat { + token = ctotok (lbuf, ip, tokbuf, SZ_FNAME) + if (token == TOK_IDENTIFIER) { + sym = stfind (stp, tokbuf) + if (sym == NULL) { + sym = stenter (stp, tokbuf, 1) + Memi[sym] = 1 + } else + Memi[sym] = Memi[sym] + 1 + } + } until (token == TOK_NEWLINE || token == TOK_EOS) + } + + call close (fd) +end + + +# PSYM -- Print the name and value of a symbol in the form "key = value". +# There are two types of values, string and count. A string operand is +# flagged as negative. + +procedure psym (stp, sym) + +pointer stp # symtab descriptor +pointer sym # pointer to symbol + +int val +pointer vp +pointer strefsbuf(), stname() + +begin + val = Memi[sym] + if (val < 0) { + vp = strefsbuf (stp, -val) + call printf ("%s = %s\n") + call pargstr (Memc[stname(stp,sym)]) + call pargstr (Memc[vp]) + } else { + call printf ("%s = %d\n") + call pargstr (Memc[stname(stp,sym)]) + call pargi (val) + } +end + + +# ZZ_HELP -- Print command dictionary for interpreter. + +procedure zz_help (fd) + +int fd + +begin + call fprintf (fd, ".mark mark top of symbol table\n") + call fprintf (fd, ".free free back to last mark\n") + call fprintf (fd, ".list list all symbols in table\n") + call fprintf (fd, ".squeeze minimize storage\n") + call fprintf (fd, ".save save table in a file\n") + call fprintf (fd, ".restore restore table from a file\n") + call fprintf (fd, ".info print info on table\n") + call fprintf (fd, ".scanfile enter symbols from file\n") + call fprintf (fd, "keyword = value enter a symbol in table\n") + call fprintf (fd, "= keyword print value of named symbol\n") + call fprintf (fd, "bye exit\n") + call flush (fd) +end diff --git a/sys/sys.hd b/sys/sys.hd new file mode 100644 index 00000000..26d6002c --- /dev/null +++ b/sys/sys.hd @@ -0,0 +1,60 @@ +# Help directory for the IRAF system libraries. + +$clio = "./clio/doc/" +$dbio = "./dbio/doc/" +$debug = "./debug/doc/" +$fio = "./fio/doc/" +$fmtio = "./fmtio/doc/" +$gio = "./gio/doc/" +$imio = "./imio/doc/" +$imfort = "./imfort/doc/" +$memio = "./memio/doc/" +$mtio = "./mtio/doc/" +$os = "host$os/doc/" +$etc = "./etc/doc/" +$tty = "./tty/doc/" +$vops = "./vops/doc/" + +Sysgen hlp = Sysgen.hlp, sys = .. + +clio hlp = clio$clio.men, sys = clio$clio.hlp, + pkg = clio$clio.hd + +dbio hlp = dbio$dbio.men, sys = dbio$dbio.hlp, + pkg = dbio$dbio.hd + +debug hlp = debug$debug.men, sys = debug$debug.hlp, + pkg = debug$debug.hd + +fio hlp = fio$fio.men, sys = fio$fio.hlp, + pkg = fio$fio.hd + +fmtio hlp = fmtio$fmtio.men, sys = fmtio$fmtio.hlp, + pkg = fmtio$fmtio.hd + +gio hlp = gio$gio.men, sys = gio$gio.hlp, + pkg = gio$gio.hd + +imio hlp = imio$imio.men, sys = imio$imio.hlp, + pkg = imio$imio.hd + +imfort hlp = imfort$imfort.men, sys = imfort$imfort.hlp, + pkg = imfort$imfort.hd + +memio hlp = memio$memio.men, sys = memio$memio.hlp, + pkg = memio$memio.hd + +mtio hlp = mtio$mtio.men, sys = mtio$mtio.hlp, + pkg = mtio$mtio.hd + +os hlp = os$os.men, sys = os$os.hlp, + pkg = os$os.hd + +etc hlp = etc$etc.men, sys = etc$etc.hlp, + pkg = etc$etc.hd + +tty hlp = tty$tty.men, sys = tty$tty.hlp, + pkg = tty$tty.hd + +vops hlp = vops$vops.men, sys = vops$vops.hlp, + pkg = vops$vops.hd diff --git a/sys/sys.men b/sys/sys.men new file mode 100644 index 00000000..a3585ba1 --- /dev/null +++ b/sys/sys.men @@ -0,0 +1,14 @@ + mkpkg - Rebuild the system libraries + clio - Command Language i/o + dbio - Database i/o + etc - Miscellaneous system procedures + fio - File i/o + fmtio - Formatted i/o + gio - Graphics i/o + imio - Image i/o (bulk data arrays) + ki - Kernel interface (networking) + memio - Memory i/o (dynamic memory allocation) + mtio - Magtape i/o + osb - Bit and byte primitives + tty - Device independent terminal control + vops - Vector operators diff --git a/sys/tty/README b/sys/tty/README new file mode 100644 index 00000000..2ab27b7e --- /dev/null +++ b/sys/tty/README @@ -0,0 +1,29 @@ +This directory contains the source for the TTY interface, a device independent +interface used to control terminals. We interface to the widely used +TERMCAP terminal database, thereby gaining the data required to control many +diverse terminals. (Written Jan84 dct). + +Mar84 Added TTYGDES and the "graphcap" file, used to describe graphics + devices. + +Jly84 Added capability to compile selected termcap entries to speedup + TTYODES. Added TTYCOMPILE, TTYLOAD, TTYOPEN, TTYCLOSE. Modified + the existing routines TTYODES and TTYGDES. The new open and close + routines are useful for any type of database maintained in termcap + format. + +Jly84 Entry point TTYCLINE changed to TTYCLEARLN to avoid name conflict + with TTYCLOSE. + +Jly84 Task MKTTYDATA is used to compile selected entries from TERMCAP + files. The include files "cache_?.dat" are the output of this + program. To tailor the cache of pre-compiled termcap device + entries for a site, compile MKTTYDATA and run it to generate + the files "cache_t.dat" for "dev$termcap" (default MKTTYDATA params) + and "cache_g.dat" for "dev$graphcap", then do a Sysgen to recompile + the libraries. All programs which use the TTY interface, e.g., + the SYSTEM package, must then be relinked to make use of the new + cache. + +Jun85 Changed filenames to make them more machine independent. + Installed MKTTYDATA as a task in the SOFTOOLS package. diff --git a/sys/tty/doc/tty.hlp b/sys/tty/doc/tty.hlp new file mode 100644 index 00000000..62924590 --- /dev/null +++ b/sys/tty/doc/tty.hlp @@ -0,0 +1,485 @@ +.help tty Dec83 "Terminal Control Interface" +.nh +Introduction + + The TTY interface is a table driven, device independent interface for +controlling terminal and printer devices. Devices are described either by +environment definitions, or by an entry in the TTY database file. The TTY +database file is the standard Berkeley UNIX termcap terminal capability +database file (a text file), to which we have added entries for our printer +devices. Accessing the UNIX termcap file directly without modification +is sometimes awkward, but the benefits of accessing a widely used, standard +database more than compensate for any clumsiness. + +When the CL starts up, the following environment variables are defined to +describe the default terminal and printer devices. The user may subsequently +change the values of these variables with the SET statement or with the STTY +program. + + +.ks +.nf + printer default printer (i.e., "versatec") + terminal default terminal (i.e., "vt100", "tek4012") + termcap terminal/printer database filename + ttybaud baud rate, default 9600 + ttyncols number of characters per line + ttynlines number of lines per screen +.fi +.ke + + +The variables defining the names of the default terminal and printer +devices will normally correspond to the names of device entries in the +termcap file. The name of a file containing a single termcap entry +for the device may optionally be given; the file name must contain a +VFN or OSFN directory prefix to be recognized as a filename. The default +termcap file is dev$termcap. Terminal initialization files (used to +set tabstops) are files of the form dev$tty.tbi, where "tty" is the last +field of the UNIX pathname in the "if" termcap entry. If the first +character of the "if" filename string is not a /, an IRAF VFN should +be given. + +The value strings for the environment variables TTYNCOLS and TTYNLINES, +defining the screen dimensions, are extracted from the termcap file by the +STTY program during startup. The screen dimensions are defined in the +environment for two reasons: (1) efficiency (the TTY package is not needed +to learn the screen dimensions), and (2) if a window is used, the logical +screen dimensions may be less than the physical screen dimensions. +Most applications programs should therefore use ENVGETI rather than TTYGETI +to get the screen dimensions. TTYGETI returns the physical screen dimensions +as given in the termcap file. + +.nh +Library Procedures + + Before any TTY control sequences can be output, the TTY device descriptor +must be read from the termcap file into a buffer for efficient access. +TYODES is used to "open" the TTY descriptor; TTYCDES should be called when +done to close the descriptor, returning all buffer space used. If "ttyname" +is "terminal" or "printer", the descriptor for the default terminal or printer +is accessed. + + +.ks +.nf +Open/Close descriptor: + + tty = ttyodes (ttyname) # pointer ttyodes() + ttycdes (tty) +.fi +.ke + + +.ks +.nf +Low level database access, tty control: + + int = ttygeti (tty, cap) + real = ttygetr (tty, cap) + bool = ttygetb (tty, cap) + nchars = ttygets (tty, cap, outstr, maxch) + ttyputs (fd, tty, ctrlstr, afflncnt) + ttysubi (ctrlstr, outstr, maxch, arg1, arg2) +.fi +.ke + + +.ks +.nf +High level control + + OK|ERR = ttyctrl (fd, tty, cap, afflncnt) + + ttyso (fd, tty, YES|NO) # turn standout mode on|off + ttygoto (fd, tty, col, line) # move cursor absolute +NI ttyhorz (fd, tty, from, to) # move cursor on line +NI ttyvert (fd, tty, from, to) # move cursor on column + ttyinit (fd, tty) # send :is & :if, if defined + ttyclear (fd, tty) # clear screen + ttyclearln (fd, tty) # clear the current line + ttyputline (fd, tty, textline, map_cc) # put text line +.fi +.ke + + +The TTYGET procedures are used to get capabilities from the database entry. +If the named capability is not found, TTYGETI returns zero, TTYGETB returns +false, and TTYGETS returns the null string. TTYSUBI performs argument +substitution on a control sequence containing at most two integer arguments +(such as a cursor motion control sequence), generating an output sequence +suitable for input to TTYPUTS. TTYPUTS puts the control sequence to the +output file, padding as required given the number of affected lines. +The baud rate and pad character, used to generate padding, are evaluated at +TTYODES time and are conveyed to TTYPUTS in the tty descriptor. + +TTYSO turns standout mode on or off. +TTYCNTRL calls TTYGETS and TTYPUTS to process and output a control sequence +(slightly less efficiently than if the control string is buffered by +the user code). TTYGOTO moves the cursor to the +desired column and line. TTYHORZ and TTYVERT move the cursor on a line +or column, using knowledge of the terminal's capabilities to generate the +most efficient sequence. + +TTYPUTLINE is like the FIO PUTLINE, except that it processes any form feeds, +standout mode directives, and other control characters (including tabs) +embedded in the text. Lines longer than TTYNCOLS are broken into several +output lines. TTYPUTLINE is used by the help, page, type, and lprint utilities +to map tabs and standout mode directives for a particular output device. +Standout mode is mapped as reverse video on most VDT's, and as underscore +on most printers and on overstrike terminals such as the tek4012. + +.nh +Implementation Notes + + Of the low level routines, only TTYODES and TTYSUBI are at all complex. +The high level routines can be fairly complex due to the logic required to +perform a function on devices which may vary greatly in capabilities. + +.nh 2 +Structure + +.ks +.nf +open descriptor: + + ttyodes + envget[si] + calloc [alloc tty descriptor] + open,close,seek [read termcap file] + tty_fetch_entry [fetch entry from file] + getline,getc + realloc + realloc + tty_index_caplist [encode, sort caplist] + ttygeti [set padchar] +.fi +.ke + + +.ks +.nf +close descriptor: + + ttycdes + ttyctrl [sometimes needed] + mfree [free tty descriptor] +.fi +.ke + + +.ks +.nf +get integer capability: + + ttygeti + tty_find_capability [binary search of caplist] + ctoi +.fi +.ke + + +.ks +.nf +get string capability: + + ttygets + tty_find_capability [binary search caplist] + tty_map_escapes [get control string] +.fi +.ke + + +.ks +.nf +perform argument substitution on control string: + + ttysubi + gltoc +.fi +.ke + + +.ks +.nf +output control string: + ttyputs + putc +.fi +.ke + +.nh 2 +Data Structures + + The tty descriptor contains several parameters describing the most basic +features of the device, the raw termcap entry, an encoded index into the +termcap entry used to speed up searches, and any status variables for the +device. Since a fixed length array is used to index capabilities, there is +an upper limit on the number of capabilities, but there is no limit on the +length of a termcap entry. + + +.ks +.nf + struct tty_descriptor { + int t_len # length of descriptor + int t_op # offset into caplist + int t_padchar # pad character + int t_baud # baud rate, bits/sec + int t_nlines # lines per screen + int t_ncols # chars per line + int t_ncaps # number of capabilities + int t_capcode # sorted, encoded caplist + int t_capindex # indices of cap strings + char caplist[ARB] # termcap entry + } +.fi +.ke + + +TTYODES "opens" the tty descriptor, i.e., allocates a descriptor, +scans the termcap file and reads the terminal entry into the descriptor, +expanding any tc references, and then sets the baud and padchar fields. +There is no limit on the size of a termcap entry, unlike the UNIX +implementation which uses a fixed size, 1024 character caplist buffer. + + +.tp 10 +.nf +procedure ttyodes (ttyname) + +begin + # Get device name or file name. + if (ttyname equals "terminal") + ttysource = fetch environment variable "terminal" + else if (ttyname equals "printer") + ttysource = fetch environment variable "printer" + else + ttysource = ttyname + + # Get device name AND file name. + if (ttysource is a filename) { + file = ttysource + entry = "" (first entry) + } else { + file = fetch termcap filename from environment + entry = ttysource + } + + allocate tty descriptor structure "tty" + tty.len = default length of descriptor + tty.op = pointer to first char of caplist string + + # Fetch termcap entry into tty descriptor, expanding any "tc" + # references to other records by rescanning the file. + + fd = open (termcap file) + repeat { + tty_fetch_entry (fd, entry, tty) + if (last field of entry is a "tc") { + entry = value of "tc" field + set tty.op to overwrite tc field + rewind (fd) + } else + break + } + close (fd) + + # Get pad character and baud rate and store explicitly in the + # descriptor, since these values are used in every TTYPUTS call. + + call realloc to return unused space in tty descriptor + call tty_index_caplist to index the caplist for efficient + searches + tty.baud = fetch "baud" from environment + tty.padchar = ttygeti (tty, "pc") + + return (tty) +end +.fi + + +Scan the termcap file until the desired entry is found. Copy the entry +into the caplist field of the tty descriptor. If the caplist buffer +overflows, reallocate a larger buffer. + +.nf +procedure tty_fetch_entry (fd, entry, tty) + +begin + # Locate entry. + repeat { + advance to next record + if (at eof) + error: termcap entry not found + } until (positioned to the entry we are looking for) + + # Fetch entry. + while (getc (fd, ch) != EOF) { + if (ch equals \ and next ch is newline) { + throw both out + } else if (ch equals newline) { + deposit EOS + return + } else + deposit ch + + bump output pointer + if (buffer is full) + allocate more space + } + + error: EOF encountered while reading termcap entry +end +.fi + + +Prepare the caplist index. Each two-character capability name maps into +an unique integer code. We prepare an list of capcodes and an associated +list of indices into the caplist, then sort the capcode list. At runtime +we will perform a binary search of the capcode list to find the desired +capcode. + +.nf +procedure tty_index_caplist (caplist, capcode_list, capindex_list) + +begin + for (each entry in caplist) { + compute capcode + if (capcode is not already in capcode_list) { + bump list pointer + if (list overflows) + error: too many capabilities in termcap entry + + # Termcap flags capabilities that are not available + # with the char '@'. + if (first char of entry is '@') + index = 0 + save capcode, index in lists + } + } + + if (two or more elements in list) + sort list +end +.fi + + +Process a capability string containing arguments. Examples of such capability +strings are cursor motion to [x,y], and set scrolling region to [l1,l2]. +Note that arguments in the termcap database are zero-indexed by default, +while the TTYSUBI arguments are one-indexed. The control string given as +input has already been processed to reduce all escape sequences to single +characters. + +.nf +procedure ttysubi (ctrlstr, outstr, maxch, arg1, arg2) + +ctrlstr: device control string +outstr: receives processed string +arg1,arg2: on input, the arguments to be expanded in the control + string. on output, the difference between the + input arg values and the values actually used + to produce outstr; these may differ if necessary + to avoid special control chars in outstr. + +begin + # Make a local copy of the arguments to make reversal easy. Also + # switch to zero-indexing internally, since the termcap entry is + # zero-indexed. + + arg[1] = arg1 - 1 + arg1 = 0 + arg[2] = arg2 - 1 + arg2 = 0 + argnum = 1 + + op = 1 + for (ip=1; ctrlstr[ip] != EOS; ip=ip+1) { + ch = ctrlstr[ip] + if (ch != '%') { + put char in outstr, bump op + next + } + + switch (ch) + case 'd', '2', '3', '+': + format coord and concat to outstr + increment argnum + + case '.': + # Binary output format. Coordinate output in binary is a + # problem because the OS driver may see a tab, newline, or + # whatever and map it into something else. If the value of + # arg[argnum] corresponds to a special control character, + # we increment it until we have an acceptable value, leaving + # it up to our caller to do the rest. + + while (arg[argnum] is a special control character) { + increment arg[argnum] + increment arg1 or arg2 + } + put binary value of arg[argnum] to outstr + increment argnum + + case '>': + conditionally modify arg[argnum] + case 'r': + swap arg[1] and arg[2] + case 'i': + increment arg[1] and arg[2] + case '%': + put % to outstr, bump op + case 'B': + BCD encode next arg + case 'D': + backwards BCD encode next arg (ugh) + } + } + + deposit EOS +end +.fi + + +The technique used for cursor addressing depends on the characteristics +of the terminal. If the terminal has no cursor motion capability, we +try to position the cursor using primitive motion commands. Otherwise +we use TTYSUBI to generate the cursor motion sequence. If TTYSUBI returns +a residual, we use primitive motion commands (up line and backspace) to go +the rest of the way in. + + +.nf +procedure ttygoto (fd, tty, col, line) + +begin + if (tty has no cursor addressing capability) { + # If possible, the calling program should keep track of the + # cursor position and use primitive motion commands for + # positioning when possible. We do the best we can without + # knowledge of the current position. + + # First get to a known position. + goto home or lower-left, depending on which is closest to + desired position and on capabilities of terminal. + + # Now move to the desired position. + step to desired line using ttyvert + advance to desired column using ttyhorz + + } else { + get cursor motion control string + call ttysubi to substitute in desired coordinates + call ttyputs to put control string to file + + # In certain cases, ttysubi cannot get us all the way there, + # and we have to step in the rest of the way. + + if (line residual) + call ttyhorz to adjust position within line + if (col residual) + call ttyvert to adjust vertical position + } +end +.fi diff --git a/sys/tty/gttyload.x b/sys/tty/gttyload.x new file mode 100644 index 00000000..066c1582 --- /dev/null +++ b/sys/tty/gttyload.x @@ -0,0 +1,38 @@ +# G_TTYLOAD -- Version of the TTYLOAD procedure for accessing compiled entries +# from the GRAPHCAP database file. Search the database of compiled GRAPHCAP +# entries for the named device, and if found, return the CAPLIST string (list +# of device capabilities) in the output string. The number of characters output +# is returned as the function value. The compiled database is defined by the +# include file "cacheg.dat", which serves as a cache for the GRAPHCAP +# entries of heavily used devices (see TTYLOAD, TTYCOMPILE). + +int procedure g_ttyload (fname, device, outstr, maxch) + +char fname[ARB] # name of termcap file being referenced +char device[ARB] # device name as in TERMCAP entry +char outstr[maxch] # output string to receive caplist +int maxch + +int dev +bool streq(), strne() +int gstrcpy() + +include "dev$cacheg.dat" + +begin + # If the name of the file being referenced is not the same as the + # name of the file used to build the cache, then the cache is + # invalidated. + + if (strne (fname, sbuf[termcap_filename])) + return (0) + + # NDEVICES, DEVNAME, DEVCAPS, and SBUF are defined and initialized + # in the include file. + + do dev = 1, ndevices + if (streq (sbuf[devname[dev]], device)) + return (gstrcpy (sbuf[devcaps[dev]], outstr, maxch)) + + return (0) +end diff --git a/sys/tty/mkpkg b/sys/tty/mkpkg new file mode 100644 index 00000000..35e97a8a --- /dev/null +++ b/sys/tty/mkpkg @@ -0,0 +1,52 @@ +# Make the TTY interface portion of the LIBSYS library. + +$checkout libsys.a lib$ +$update libsys.a +$checkin libsys.a lib$ +$exit + +update: + $call relink + $call install + ; + +relink: + $omake x_mkttydata.x tty.h + $link x_mkttydata.o + ; + +install: + $move x_mkttydata.e bin$ + ; + +libsys.a: + gttyload.x + ttycaps.x tty.h + ttycdes.x + ttyclear.x tty.h + ttyclln.x tty.h + ttyclose.x + ttyctrl.x tty.h + ttydelay.x tty.h + ttydevnm.x + ttygdes.x dev$cacheg.dat tty.h + ttygetb.x + ttygeti.x + ttygetr.x + ttygets.x + ttygoto.x tty.h + ttygsize.x + ttyindex.x tty.h + ttyinit.x tty.h + ttyload.x dev$cachet.dat + ttyodes.x tty.h + ttyopen.x tty.h + ttyputl.x tty.h + ttyputs.x + ttyread.x + ttyseti.x tty.h + ttyso.x + ttystati.x tty.h + ttysubi.x tty.h + ttywrite.x tty.h + ; diff --git a/sys/tty/tty.h b/sys/tty/tty.h new file mode 100644 index 00000000..6e0e58e0 --- /dev/null +++ b/sys/tty/tty.h @@ -0,0 +1,51 @@ +# TTY package definitions. Requires . + +define TABSIZE 8 +define MAX_TC_NESTING 5 # max nesting of tc=term references + +# Include here all special control characters (mapped by driver) which should +# not be used as binary cursor coordinates. The list must be terminated by +# an EOS; do not count the EOS in NDCHARS. Note that NUL cannot be included +# in the list because it is the same as EOS. + +define NDCHARS 3 +define DRIVER_CHARS EOT,HT,LF,EOS + +# Mapping function used to map capcodes ("cm", etc.) into unique integers. +define ENCODE ($1[1]*128+$1[2]) + +# Types of standout modes defined for terminals. + +define SOSE 1 # use so,se or us,ue capabilities +define BSOS 2 # backspace and overstrike with _ +define CROS 3 # CR and overstrike with full line +define TOUP 4 # map standout chars to upper case + +# TTY descriptor structure. Full termcap entry is the 'caplist' string. +# The caplist is indexed at open time to permit a binary search for +# capabilities at run time. + +define T_MEMINCR 512 # increment if overflow occurs +define T_OFFCAP 215 # struct offset to caplist field +define MAX_CAPS 100 # maximum capabilities +define MAX_COORDS 7 # maximum coords for ttysubi +define SZ_CTRLSTR 50 # buffer size for control strings +define LEN_DEFTTY (256+1024) # initial length of tty structure + +define T_LEN Memi[$1] # length of tty structure +define T_OP Memi[$1+1] # offset into caplist +define T_PADCHAR Memi[$1+2] # pad character for delays +define T_TABCHAR Memi[$1+3] # tab character, if HW tabs ok +define T_BSOK Memi[$1+4] # terminal backspaces with BS +define T_HTOK Memi[$1+5] # term has HT (horiz tab) in hardware +define T_AM Memi[$1+6] # term has automargin advance +define T_SOTYPE Memi[$1+7] # type of standout mode (ttyputline) +define T_BAUD Memi[$1+8] # baud rate for delays +define T_NLINES Memi[$1+9] # nlines on terminal at open +define T_NCOLS Memi[$1+10] # ncols on terminal at open +define T_NCAPS Memi[$1+11] # number of capabilities +define T_CAPLEN Memi[$1+12] # length of caplist, chars + # (extra space) +define T_CAPCODE Memi[$1+15] # cap code array: c1*128+c2 +define T_CAPINDEX Memi[$1+115] # cap index array +define T_CAPLIST Memc[($1+215-1)*SZ_STRUCT+1] # termcap entry diff --git a/sys/tty/ttycaps.x b/sys/tty/ttycaps.x new file mode 100644 index 00000000..e6fcbcf0 --- /dev/null +++ b/sys/tty/ttycaps.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "tty.h" + +# TTYCAPS -- Return a pointer to the caplist field of an open TTY descriptor. + +pointer procedure ttycaps (tty) + +pointer tty # tty descriptor + +begin + return (P2C (tty + T_OFFCAP)) +end diff --git a/sys/tty/ttycdes.x b/sys/tty/ttycdes.x new file mode 100644 index 00000000..0b778a51 --- /dev/null +++ b/sys/tty/ttycdes.x @@ -0,0 +1,11 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# TTYCDES -- Close a terminal opened with TTYODES or TTYGDES. + +procedure ttycdes (tty) + +pointer tty + +begin + call ttyclose (tty) +end diff --git a/sys/tty/ttyclear.x b/sys/tty/ttyclear.x new file mode 100644 index 00000000..86dac6ff --- /dev/null +++ b/sys/tty/ttyclear.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "tty.h" + +# TTYCLEAR -- Clear the terminal screen. + +procedure ttyclear (fd, tty) + +int fd +pointer tty + +int status +bool ttygetb() +int ttyctrl() +errchk ttygetb, ttyctrl + +begin + # If hardcopy terminal, output formfeed instead of clear. + if (ttygetb (tty, "ht")) + status = ttyctrl (fd, tty, "ff", T_NLINES(tty)) + else + status = ERR + if (status == ERR) + status = ttyctrl (fd, tty, "cl", T_NLINES(tty)) + + # If ff or cl capability not found, the best we can do is output + # a newline. + if (status == ERR) + call putline (fd, "\n") +end diff --git a/sys/tty/ttyclln.x b/sys/tty/ttyclln.x new file mode 100644 index 00000000..34e57328 --- /dev/null +++ b/sys/tty/ttyclln.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "tty.h" + +# TTYCLEARLN -- Clear the current line. The cursor is left positioned at the +# left margin. If the clear has to be performed by overwriting the line with +# blanks, the final column is not cleared. + +procedure ttyclearln (fd, tty) + +int fd +pointer tty +pointer sp, buf +int nchars, ttygets() +errchk salloc, ttygets, putc, ttywrite, fprintf, pargi + +begin + call smark (sp) + call salloc (buf, SZ_CTRLSTR, TY_CHAR) + + nchars = ttygets (tty, "ce", Memc[buf], SZ_CTRLSTR) + if (nchars > 0) { + call putci (fd, '\r') + call ttywrite (fd, tty, Memc[buf], nchars, 1) + } else { + call fprintf (fd, "\r%*w\r") + call pargi (T_NCOLS(tty) - 1) + } + + call sfree (sp) +end diff --git a/sys/tty/ttyclose.x b/sys/tty/ttyclose.x new file mode 100644 index 00000000..f30644dd --- /dev/null +++ b/sys/tty/ttyclose.x @@ -0,0 +1,11 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# TTYCLOSE -- Close the tty terminal descriptor opened with TTYOPEN. + +procedure ttyclose (tty) + +pointer tty + +begin + call mfree (tty, TY_STRUCT) +end diff --git a/sys/tty/ttyctrl.x b/sys/tty/ttyctrl.x new file mode 100644 index 00000000..3a66e961 --- /dev/null +++ b/sys/tty/ttyctrl.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "tty.h" + +# TTYCTRL -- Output a control sequence to the terminal. + +int procedure ttyctrl (fd, tty, cap, afflncnt) + +int fd, afflncnt +char cap[ARB] +pointer tty + +pointer sp, buf +int status, nchars, ttygets() +errchk ttygets, ttywrite + +begin + call smark (sp) + call salloc (buf, SZ_CTRLSTR, TY_CHAR) + + nchars = ttygets (tty, cap, Memc[buf], SZ_CTRLSTR) + if (nchars > 0) { + call ttywrite (fd, tty, Memc[buf], nchars, afflncnt) + status = OK + } else + status = ERR + + call sfree (sp) + return (status) +end diff --git a/sys/tty/ttydelay.x b/sys/tty/ttydelay.x new file mode 100644 index 00000000..7fc6b3d4 --- /dev/null +++ b/sys/tty/ttydelay.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "tty.h" + +# TTYDELAY -- Output a sequence of pad characters to create a delay, giving +# the terminal time to complete some operation before being passed the next +# request. + +procedure ttydelay (fd, tty, delay) + +int fd # output file +pointer tty # tty descriptor +int delay # desired milliseconds of delay + +int padchar, npadchars +real msec_per_char +int and() + +begin + # Add padding if needed to generate delay. (8 = nbits per char, + # baud is in units of bits per second). + + if (delay > 0 && T_BAUD(tty) > 0) { + padchar = and (T_PADCHAR(tty), 177B) + msec_per_char = real(8 * 1000) / real(T_BAUD(tty)) + npadchars = int (delay / msec_per_char + 0.5) + + for (; npadchars > 0; npadchars = npadchars - 1) + call putci (fd, padchar) + } +end diff --git a/sys/tty/ttydevnm.x b/sys/tty/ttydevnm.x new file mode 100644 index 00000000..76996d69 --- /dev/null +++ b/sys/tty/ttydevnm.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# TTYDEVNAME -- Extract the logical device name from a full device specification +# of the form "node ! logical_device ? physical_device". The node prefix, if +# given, specifies the node from which the device is to be accessed (via the +# network), and the physical device field contains particulars about the +# physical device to be accessed. Only the logical device field, used to index +# the termcap file, is of any interest to TTY. The logical device name +# consists of chars chosen from the set [a-zA-Z0-9_+-]. + +procedure ttydevname (device, ldevice, maxch) + +char device[ARB] # full device specification +char ldevice[maxch] # logical device name +int maxch + +pointer sp, nodename +int ip, op, ch +int ki_extnode() + +begin + call smark (sp) + call salloc (nodename, SZ_FNAME, TY_CHAR) + + ip = ki_extnode (device, Memc[nodename], maxch, op) + 1 + + for (op=1; device[ip] != EOS; ip=ip+1) { + ch = device[ip] + if (!(IS_ALNUM(ch) || ch == '_' || ch == '+' || ch == '-')) { + ldevice[op] = EOS + break + } else { + ldevice[op] = ch + op = op + 1 + } + } + + call sfree (sp) +end diff --git a/sys/tty/ttygdes.x b/sys/tty/ttygdes.x new file mode 100644 index 00000000..8eff579a --- /dev/null +++ b/sys/tty/ttygdes.x @@ -0,0 +1,148 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "tty.h" + +define DEF_BAUDRATE 9600 + +# TTYGDES -- Open a TTY graphics stdgraph descriptor. If ttyname is +# "stdgraph" or "stdplot", get the name of the physical graphics device +# from the environment. The name of the graphcap file is fetched from the +# environment and the graphcap file is searched for an entry corresponding +# to the named device. +# +# The descriptor is then allocated, and the graphcap entry read in. Graphcap +# permits an entry to be defined in terms of another entry with the "tc" +# field; we must expand such references by rescanning the file once for each +# such reference. Finally, the graphcap entry is indexed for efficient access. +# The form of a graphcap entry is identical to that for a termcap entry. + +pointer procedure ttygdes (ttyname) + +char ttyname[ARB] + +int nchars +pointer sp, ttysource, device, devname, fname, tty +pointer ttyopen() +extern g_ttyload() +bool streq(), ttygetb() +int fnldir(), ttygeti(), ttygets() +int envgets(), envgeti() +errchk envgets, envgeti, ttyopen, ttygets, syserrs +errchk tty_index_caps, ttygeti, envindir + +string stdgraph "stdgraph" +string stdimage "stdimage" +string stdplot "stdplot" +string graphcap "graphcap" + +begin + call smark (sp) + call salloc (ttysource, SZ_FNAME, TY_CHAR) + call salloc (devname, SZ_FNAME, TY_CHAR) + call salloc (device, SZ_FNAME, TY_CHAR) + call salloc (fname, SZ_FNAME, TY_CHAR) + + # Resolve any indirection in the device name. + call envindir (ttyname, Memc[devname], SZ_FNAME) + + # Get device name or graphcap file name. + if (streq (Memc[devname], stdgraph)) { + if (envgets (stdgraph, Memc[ttysource], SZ_FNAME) <= 0) + call syserrs (SYS_ENVNF, stdgraph) + } else if (streq (Memc[devname], stdimage)) { + if (envgets (stdimage, Memc[ttysource], SZ_FNAME) <= 0) + call syserrs (SYS_ENVNF, stdimage) + } else if (streq (Memc[devname], stdplot)) { + if (envgets (stdplot, Memc[ttysource], SZ_FNAME) <= 0) + call syserrs (SYS_ENVNF, stdplot) + } else + call strcpy (Memc[devname], Memc[ttysource], SZ_FNAME) + + # If ttysource is a filename, we assume that it is the name of + # a graphcap format file, the first entry of which (matched by the + # null device name) is the entry for the device. Otherwise, + # ttysource is the name of the desired graphcap entry in the regular + # graphcap file. + + if (fnldir (Memc[ttysource], Memc[fname], SZ_FNAME) > 0) { + call strcpy (Memc[ttysource], Memc[fname], SZ_FNAME) + Memc[device] = EOS + } else { + if (envgets (graphcap, Memc[fname], SZ_FNAME) <= 0) + call syserrs (SYS_ENVNF, graphcap) + call strcpy (Memc[ttysource], Memc[device], SZ_FNAME) + } + + # Truncate the device name if device fields are appended. + call ttydevname (Memc[device], Memc[device], SZ_FNAME) + + # Allocate and initialize the tty descriptor structure. Fetch graphcap + # entry from graphcap file into descriptor. The G_TTYLOAD procedure, + # passed as an argument to TTYOPEN, is searched for cached termcap + # entries before accessing the actual file. + + tty = ttyopen (Memc[fname], Memc[device], g_ttyload) + + # Prepare index of fields in the descriptor, so that we can more + # efficiently search for fields later. + + call tty_index_caps (tty, T_CAPCODE(tty), T_CAPINDEX(tty), T_NCAPS(tty)) + + # Determine whether or not the stdgraph device can backspace with BS. + if (ttygetb (tty, "bs")) + T_BSOK(tty) = YES + else + T_BSOK(tty) = NO + + # Determine whether or not the stdgraph device can expand tabs. + # If it can but it requires some long string, don't bother. + + T_HTOK(tty) = NO + T_TABCHAR(tty) = 0 + if (ttygetb (tty, "pt")) { + nchars = ttygets (tty, "ta", Memc[fname], SZ_FNAME) + if (nchars <= 0) { + T_HTOK(tty) = YES + T_TABCHAR(tty) = '\t' + } else if (nchars == 1) { + T_HTOK(tty) = YES + T_TABCHAR(tty) = Memc[fname] + } + } + + # Determine the optimimum mode for handling standout mode control, + # and save in the descriptor. + + if (ttygetb (tty, "so")) { + T_SOTYPE(tty) = SOSE # use so, se + } else if (ttygetb (tty, "os")) { + if (T_BSOK(tty) == YES || ttygetb (tty, "bc")) + T_SOTYPE(tty) = BSOS # backspace, ostrike + else + T_SOTYPE(tty) = CROS # ostrike whole line + } else + T_SOTYPE(tty) = TOUP # to upper case + + # Get pad char and baud rate (used by ttyputs to generate delays) + # and put in descriptor for efficient access. Also get tty screen + # dimensions since they are fundamental and will probably prove + # useful later. + + T_PADCHAR(tty) = ttygeti (tty, "pc") # returns 0 if field not found + T_NLINES(tty) = ttygeti (tty, "li") + T_NCOLS(tty) = ttygeti (tty, "co") + + # Baud rate may not be right if device is attached to the host, and + # and user is working remotely. Nonetheless it is safer to pick up + # the value from the environment than to assume a default. + + iferr (T_BAUD(tty) = envgeti ("ttybaud")) + T_BAUD(tty) = DEF_BAUDRATE + + call sfree (sp) + return (tty) +end diff --git a/sys/tty/ttygetb.x b/sys/tty/ttygetb.x new file mode 100644 index 00000000..8c6fdbd4 --- /dev/null +++ b/sys/tty/ttygetb.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# TTYGETB -- Determine whether or not a capability exists for a device. +# If there is any entry at all, the capability exists. + +bool procedure ttygetb (tty, cap) + +pointer tty # tty descriptor +char cap[ARB] # two character capability name +pointer ip +int tty_find_capability() + +begin + return (tty_find_capability (tty, cap, ip) == YES) +end diff --git a/sys/tty/ttygeti.x b/sys/tty/ttygeti.x new file mode 100644 index 00000000..95384df3 --- /dev/null +++ b/sys/tty/ttygeti.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# TTYGETI -- Get an integer valued capability. If the capability is not +# found for the device, or cannot be interpreted as an integer, zero is +# returned. Integer capabilities have the format ":xx#dd:". + +int procedure ttygeti (tty, cap) + +pointer tty # tty descriptor +char cap[ARB] # two character capability name +int ival +pointer ip +int tty_find_capability(), ctoi() + +begin + if (tty_find_capability (tty, cap, ip) == NO) + return (0) + else if (Memc[ip] != '#') + return (0) + else { + ip = ip + 1 # skip the '#' + if (ctoi (Memc, ip, ival) == 0) + return (0) + else + return (ival) + } +end diff --git a/sys/tty/ttygetr.x b/sys/tty/ttygetr.x new file mode 100644 index 00000000..f4e2a8a8 --- /dev/null +++ b/sys/tty/ttygetr.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# TTYGETR -- Get a real valued capability. If the capability is not +# found for the device, or cannot be interpreted as a number, zero is +# returned. Real valued capabilities have the format ":xx#num:". + +real procedure ttygetr (tty, cap) + +pointer tty # tty descriptor +char cap[ARB] # two character capability name + +char numstr[MAX_DIGITS] +int np, op +pointer ip +double dval +int tty_find_capability(), ctod() + +begin + if (tty_find_capability (tty, cap, ip) == NO) + return (0.0) + else if (Memc[ip] != '#') + return (0.0) + else { + # Extract the number into numstr. Cannot convert in place in + # the table because the ":" delimiter will by interpreted by + # ctod as for a sexagesimal number. + op = 1 + for (ip=ip+1; op <= MAX_DIGITS && Memc[ip] != ':'; ip=ip+1) { + numstr[op] = Memc[ip] + op = op + 1 + } + numstr[op] = EOS + np = 1 + if (ctod (numstr, np, dval) == 0) + return (0.0) + else + return (dval) + } +end diff --git a/sys/tty/ttygets.x b/sys/tty/ttygets.x new file mode 100644 index 00000000..23da69e1 --- /dev/null +++ b/sys/tty/ttygets.x @@ -0,0 +1,73 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help ttygets +.nf ___________________________________________________________________________ +TTYGETS -- Get the string value of a capability. Process all termcap escapes. +These are: + + \E ascii esc (escape) + ^X control-X (i.e., ^C=03B, ^Z=032B, etc.) + \[nrtbf] newline, return, tab, backspace, formfeed + \ddd octal value of character + \^ the character ^ + \\ the character \ + +The character ':' may not be placed directly in a capability string; it +should be given as \072 instead. The null character is represented as \200; +all characters are masked to 7 bits upon output by TTYPUTS, hence \200 +is sent to the terminal as NUL. +.endhelp ______________________________________________________________________ + +int procedure ttygets (tty, cap, outstr, maxch) + +pointer tty # tty descriptor +char cap[ARB] # two character capability name +char outstr[ARB] # receives cap string +int maxch # size of outstr + +char ch +pointer ip +int op, junk, temp +int tty_find_capability(), cctoc() + +begin + op = 1 + + if (tty_find_capability (tty, cap, ip) == YES) { + # Skip the '=' which follows the two character capability name. + if (Memc[ip] == '=') + ip = ip + 1 + + # Extract the string, processing all escapes. + for (ch=Memc[ip]; ch != ':'; ch=Memc[ip]) { + if (ch == '^') { + ip = ip + 1 + temp = Memc[ip] + ch = mod (temp, 40B) + } else if (ch == '\\') { + switch (Memc[ip+1]) { + case 'E': + ip = ip + 1 + ch = ESC + case '^', ':', '\\': + ip = ip + 1 + ch = Memc[ip] + default: + junk = cctoc (Memc, ip, ch) + ip = ip - 1 + } + } + + outstr[op] = ch + op = op + 1 + ip = ip + 1 + if (op >= maxch) + break + } + } + + outstr[op] = EOS + return (op-1) +end diff --git a/sys/tty/ttygoto.x b/sys/tty/ttygoto.x new file mode 100644 index 00000000..d8896125 --- /dev/null +++ b/sys/tty/ttygoto.x @@ -0,0 +1,78 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "tty.h" + +# TTYGOTO -- Position the cursor to the given absolute screen coordinates. +# We do not require any knowledge of the current screen position; many programs +# will wish to do cursor positioning at a lower level to take advantage of +# knowledge of the current position. + +procedure ttygoto (fd, tty, col, line) + +int fd # output stream +pointer tty # termcap descriptor +int col # destination column +int line # destination line + +pointer sp, cm_in, cm_out +int coords[2], nchars, i +int ttygets(), ttysubi() +errchk salloc, ttygets, ttyputs, ttywrite + +begin + call smark (sp) + call salloc (cm_in, SZ_CTRLSTR, TY_CHAR) + call salloc (cm_out, SZ_LINE, TY_CHAR) + + # Use the cursor motion control string to position cursor, if the + # terminal has such a capability. Otherwise try to use primitive + # motion commands. + + if (ttygets (tty, "cm", Memc[cm_in], SZ_CTRLSTR) > 0) { + # Coordinates are ordered line,col in the termcap entry, + # whereas our args are ordered col,line (e.g., x,y). Store + # in "coords" in the termcap order. + + coords[1] = line + coords[2] = col + nchars = ttysubi (Memc[cm_in], Memc[cm_out], SZ_LINE, coords, 2) + + # Output cursor motion control string to file. + call ttywrite (fd, tty, Memc[cm_out], nchars, 1) + + # If unable to position to the exact coordinates, use primitive + # motion commands to step the rest of the way in. Do not abort + # if unable to do so. + + if (coords[2] > 0) { + # Presumably we do not have to step in very often, so we do + # nothing special to buffer the backspace control sequence. + # Most terminals recognize BS in any case. + + if (T_BSOK(tty) == YES) { + Memc[cm_out] = BS + Memc[cm_out+1] = EOS + } else if (ttygets (tty, "bc", Memc[cm_out], SZ_CTRLSTR) == 0) + Memc[cm_out] = EOS + + for (i=coords[2]; i > 0; i=i-1) + call ttyputs (fd, tty, Memc[cm_out], 1) + } + + # Now adjust vertical position if necessary. + if (coords[1] > 0) { + if (ttygets (tty, "up", Memc[cm_out], SZ_CTRLSTR) > 0) + for (i=coords[1]; i > 0; i=i-1) + call ttyputs (fd, tty, Memc[cm_out], 1) + } + + } else { + # Terminal has no nifty cursor addressing capability; add code here + # to position cursor by generating a sequence of more primitive + # codes. Not going to bother with this for now. + ; + } + + call sfree (sp) +end diff --git a/sys/tty/ttygsize.x b/sys/tty/ttygsize.x new file mode 100644 index 00000000..e4ccfa1a --- /dev/null +++ b/sys/tty/ttygsize.x @@ -0,0 +1,115 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +define TIMEOUT 2000 # timeout interval, msec, for size query + + +# TTYGSIZE -- Get the width and height of the terminal screen in characters. +# For a conventional terminal these values are given as constants in the +# termcap entry for the device. If the terminal has a screen which can vary +# in size at runtime (e.g., a window on a workstation), then the screen size +# is queried at runtime. + +procedure ttygsize (in, out, tty, width, height) + +int in, out # input and output streams +pointer tty # terminal descriptor +int width # ncols on screen (out) +int height # nlines on screen (out) + +pointer sp, patbuf, buf, qs, wh, ip, op +int index, len_qs, len_wh, w_index, h_index, sv_iomode, nchars, junk + +int patmake(), patindex(), gstrcpy(), ctoi() +int ttygets(), ttyread(), ttystati(), ttstati(), fstati() +define noquery_ 91 +errchk ttyread + +begin + call smark (sp) + call salloc (patbuf, SZ_LINE, TY_CHAR) + call salloc (buf, SZ_LINE, TY_CHAR) + call salloc (qs, SZ_FNAME, TY_CHAR) + call salloc (wh, SZ_FNAME, TY_CHAR) + + width = 0 + height = 0 + index = 0 + + # Just use the termcap values if in stty playback or record mode. + if (ttstati(in,TT_LOGIN) == YES || ttstati(in,TT_PLAYBACK) == YES) + goto noquery_ + + len_qs = ttygets (tty, "qs", Memc[qs], SZ_FNAME) + len_wh = ttygets (tty, "wh", Memc[wh], SZ_FNAME) + + # Process the string DS (decode size string) to map the %W %H fields + # into the pattern strings "%[0-9]*", noting the index positions of + # the W and H fields. + + if (len_wh > 0) { + op = buf + for (ip=wh; Memc[ip] != EOS; ip=ip+1) { + if ((Memc[ip] == '%') && ip > wh && Memc[ip-1] != '\\' && + (Memc[ip+1] == 'W' || Memc[ip+1] == 'H')) { + + index = index + 1 + op = op + gstrcpy ("%[0-9]*", Memc[op], ARB) + ip = ip + 1 + + if (Memc[ip] == 'W') + w_index = index + else + h_index = index + } else { + Memc[op] = Memc[ip] + op = op + 1 + } + } + Memc[op] = EOS + junk = patmake (Memc[buf], Memc[patbuf], SZ_LINE) + } + + # Query the terminal for the screen size, read back and decode the + # encoded screen size string. + + if (len_qs > 0 && len_wh > 0) { + sv_iomode = fstati (in, F_IOMODE) + if (sv_iomode != IO_RAW) + call fseti (in, F_IOMODE, IO_RAW) + + call ttywrite (out, tty, Memc[qs], len_qs, 0) + call flush (out) + + nchars = ttyread (in, tty, Memc[buf],SZ_LINE,Memc[patbuf], TIMEOUT) + if (nchars > 0) { + if (ctoi (Memc[buf],patindex(Memc[patbuf],w_index),width) <= 0) + width = 0 + if (ctoi (Memc[buf],patindex(Memc[patbuf],h_index),height) <= 0) + height = 0 + } + + if (sv_iomode != IO_RAW) + call fseti (in, F_IOMODE, sv_iomode) + + if (width == 0 && nchars == 0) { + call eprintf ("timeout - terminal type set wrong? ") + call eprintf ("(`stty termtype' to reset)\n") + } + } + +noquery_ + # If we still do not know the screen width or height, use the values + # given in the user environment, else in the termcap entry for the + # device. + + if (width <= 0) + width = ttystati (tty, TTY_NCOLS) + if (height <= 0) + height = ttystati (tty, TTY_NLINES) + + call sfree (sp) +end diff --git a/sys/tty/ttyindex.x b/sys/tty/ttyindex.x new file mode 100644 index 00000000..6d9ae222 --- /dev/null +++ b/sys/tty/ttyindex.x @@ -0,0 +1,167 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "tty.h" + +.help index caplist +.nf _________________________________________________________________________ +TTY_INDEX_CAPS -- Prepare an index into the caplist string, stored in +the tty descriptor. Each two character capability name maps into a unique +integer code, called the capcode. We prepare a list of capcodes, keeping +only the first such code encountered in the case of multiple entries. +The offset of the capability in the caplist string is associated with each +capcode. When these lists have been prepared, they are sorted to permit +a binary search for capabilities at runtime. +.endhelp ____________________________________________________________________ + +procedure tty_index_caps (tty, t_capcode, t_capindex, ncaps) + +pointer tty +int t_capcode[ARB], t_capindex[ARB] +int ncaps + +pointer ip, caplist +int i, swap, capcode, temp +int tty_encode_capability() +pointer coerce() +errchk syserr + +begin + caplist = coerce (tty + T_OFFCAP, TY_STRUCT, TY_CHAR) + ip = caplist + + # Scan the caplist and prepare the capcode and capindex lists. + for (ncaps=0; ncaps <= MAX_CAPS; ) { + # Advance to the next capability field. Normal exit occurs + # when ':' is followed immediately by EOS. + + while (Memc[ip] != ':' && Memc[ip] != EOS) + ip = ip + 1 + if (Memc[ip+1] == EOS || Memc[ip] == EOS) + break + + ip = ip + 1 # skip the ':' + capcode = tty_encode_capability (Memc[ip]) + + # Is the capcode already in the list? If not found, add it to + # the list. + for (i=1; i <= ncaps && t_capcode[i] != capcode; i=i+1) + ; + if (i > ncaps) { # not found + ncaps = ncaps + 1 + t_capcode[ncaps] = capcode + t_capindex[ncaps] = ip - caplist + 1 + } + } + + if (ncaps > MAX_CAPS) + call syserr (SYS_TTYOVFL) + + # A simple interchange sort is sufficient here, even though it would + # not be hard to interface to qsort. The longest termcap entries are + # about 50 caps, and the time req'd to sort such a short list is + # negligible compared to the time spent searching the termcap file. + + if (ncaps > 1) + repeat { + swap = 0 + do i = 1, ncaps-1 + if (t_capcode[i] > t_capcode[i+1]) { + temp = t_capcode[i] + t_capcode[i] = t_capcode[i+1] + t_capcode[i+1] = temp + temp = t_capindex[i] + t_capindex[i] = t_capindex[i+1] + t_capindex[i+1] = temp + swap = 1 + } + } until (swap == 0) +end + + +# TTY_FIND_CAPABILITY -- Search the caplist for the named capability. +# If found, return the char pointer IP to the first char of the value field, +# and YES as the function value. If the first char in the capability string +# is '@', the capability "is not present". + +int procedure tty_find_capability (tty, cap, ip) + +pointer tty # tty descriptor +char cap[ARB] # two character name of capability +pointer ip # pointer to capability string + +int capcode, capnum +int tty_binsearch(), tty_encode_capability() +pointer coerce() +errchk syserr + +begin + if (tty == NULL) + call syserr (SYS_TTYINVDES) + + capcode = tty_encode_capability (cap) + capnum = tty_binsearch (capcode, T_CAPCODE(tty), T_NCAPS(tty)) + + if (capnum > 0) { + # Add 2 to skip the two capname chars. + ip = coerce (tty + T_OFFCAP, TY_STRUCT, TY_CHAR) + + T_CAPINDEX(tty+capnum-1) - 1 + 2 + if (Memc[ip] != '@') + return (YES) + } + + return (NO) +end + + +# TTY_BINSEARCH -- Perform a binary search of the capcode array for the +# indicated capability. Return the array index of the capability if found, +# else zero. + +int procedure tty_binsearch (capcode, t_capcode, ncaps) + +int capcode +int t_capcode[ARB], ncaps +int low, high, pos, ntrips + +begin + low = 1 + high = ncaps + pos = 0 + + # Cut range of search in half until code is found, or until range + # vanishes (high - low <= 1). If neither high or low is the one, + # code is not found in the list. + + do ntrips = 1, ncaps { + pos = (high - low) / 2 + low + if (t_capcode[low] == capcode) + return (low) + else if (t_capcode[high] == capcode) + return (high) + else if (pos == low) # (high-low)/2 == 0 + return (0) # not found + else if (t_capcode[pos] < capcode) + low = pos + else + high = pos + } + + # Search cannot fail to converge unless there is a bug in the software + # somewhere. + + call syserr (SYS_TTYBINSRCH) +end + + +# TTY_ENCODE_CAPABILITY -- Encode the two character capability string +# as a unique integer value. + +int procedure tty_encode_capability (cap) + +char cap[ARB] + +begin + return (ENCODE(cap)) +end diff --git a/sys/tty/ttyinit.x b/sys/tty/ttyinit.x new file mode 100644 index 00000000..9aeff341 --- /dev/null +++ b/sys/tty/ttyinit.x @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "tty.h" + +# TTYINIT -- Initialize the terminal. The termcap entry potentially contains +# two initialization entries. The first, "is" is an initialization string +# which is sent to the terminal. The second, "if", is the name of a file +# containing the initialization string. If both are given, "if" is sent +# followed by "is", however, there seems no reason to have an "is" string +# if there is already an initialization file. The names of initialization +# files may be either IRAF virtual filenames or host system pathnames. + +procedure ttyinit (fd, tty) + +int fd # file descriptor of terminal +pointer tty # tty descriptor + +pointer sp, fname +int in, junk, rawmode +int ttyctrl(), ttygets(), open(), fstati() +errchk ttygets, fcopyo + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + # Output contents of initialization file, if any. + if (ttygets (tty, "if", Memc[fname], SZ_PATHNAME) > 0) + iferr (in = open (Memc[fname], READ_ONLY, TEXT_FILE)) + call erract (EA_WARN) + else { + rawmode = fstati (fd, F_RAW) + call fseti (fd, F_RAW, YES) + call fcopyo (in, fd) + call fseti (fd, F_RAW, rawmode) + call close (in) + } + + # Output initialization string. + junk = ttyctrl (fd, tty, "is", 1) + + call sfree (sp) +end diff --git a/sys/tty/ttyload.x b/sys/tty/ttyload.x new file mode 100644 index 00000000..117575b8 --- /dev/null +++ b/sys/tty/ttyload.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# TTYLOAD -- Search the database of compiled TERMCAP entries for the named +# device, and if found, return the CAPLIST string (list of device capabilities) +# in the output string. The number of characters output is returned as the +# function value. The compiled database is defined by the include file +# "cachet.dat", which serves as a cache for the TERMCAP entries of heavily +# used devices (see TTYCOMPILE). +# +# N.B.: This file can serve as a template for generating TTYLOAD procedures +# for devices other than the terminal. Change the name TTYLOAD to something +# else, change the name of the include file, generate a different include file +# with TTYCOMPILE, and you are in business. + +int procedure ttyload (fname, device, outstr, maxch) + +char fname[ARB] # name of termcap file being referenced +char device[ARB] # device name as in TERMCAP entry +char outstr[maxch] # output string to receive caplist +int maxch + +int dev +bool streq(), strne() +int gstrcpy() + +include "dev$cachet.dat" + +begin + # If the name of the file being referenced is not the same as the + # name of the file used to build the cache, then the cache is + # invalidated. + + if (strne (fname, sbuf[termcap_filename])) + return (0) + + # NDEVICES, DEVNAME, DEVCAPS, and SBUF are defined and initialized + # in the include file. + + do dev = 1, ndevices + if (streq (sbuf[devname[dev]], device)) + return (gstrcpy (sbuf[devcaps[dev]], outstr, maxch)) + + return (0) +end diff --git a/sys/tty/ttyodes.x b/sys/tty/ttyodes.x new file mode 100644 index 00000000..a01ffdca --- /dev/null +++ b/sys/tty/ttyodes.x @@ -0,0 +1,183 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "tty.h" + +define DEF_BAUDRATE 9600 +define DEF_TTYNLINES 24 +define DEF_TTYNCOLS 80 + +# TTYODES -- Open a TTY terminal descriptor. If ttyname is "terminal" or +# "printer", get the name of the default terminal or printer from the +# environment. If the "name" of the terminal is a filename, the first termcap +# entry in the name file is read. Otherwise, the termcap file is searched for +# an entry corresponding to the named device. +# +# The descriptor is then allocated, and the termcap entry read in. Termcap +# permits an entry to be defined in terms of another entry with the "tc" +# field; we must expand such references by rescanning the file once for each +# such reference. Finally, the termcap entry is indexed for efficient access. +# +# The form of a termcap entry is one logical line (usually extending over +# several physical lines using newline escapes), consisting of several alternate +# names for the device, followed by a list of ':' delimited capabilities: +# +# name1 '|' name2 [ '|' namen... ] ':' cap ':' [ cap ':' ... ] +# +# If the final cap in an entry is of the form ":tc=name:", the capability +# is replaced by the capability list of the named entry. + +pointer procedure ttyodes (ttyname) + +char ttyname[ARB] + +bool istty +int nchars +pointer sp, ttysource, device, devname, fname, tty + +pointer ttyopen() +extern ttyload() +bool streq(), ttygetb() +int envgets(), envgeti(), btoi() +int fnldir(), ttygeti(), ttygets() +errchk syserrs, tty_index_caps, ttygeti, ttyopen, ttygets +errchk envgets, envgeti, envindir + +string terminal "terminal" # terminal named in environment +string printer "printer" # printer named in environment +string termcap "termcap" # name of termcap file stored in env. too + +begin + call smark (sp) + call salloc (ttysource, SZ_FNAME, TY_CHAR) + call salloc (devname, SZ_FNAME, TY_CHAR) + call salloc (device, SZ_FNAME, TY_CHAR) + call salloc (fname, SZ_FNAME, TY_CHAR) + + # Resolve any indirection in the device name. + call envindir (ttyname, Memc[devname], SZ_FNAME) + + # Get device name or termcap file name. + if (streq (Memc[devname], terminal)) { + if (envgets (terminal, Memc[ttysource], SZ_FNAME) <= 0) + call syserrs (SYS_ENVNF, terminal) + } else if (streq (Memc[devname], printer)) { + if (envgets (printer, Memc[ttysource], SZ_FNAME) <= 0) + call syserrs (SYS_ENVNF, printer) + } else + call strcpy (Memc[devname], Memc[ttysource], SZ_FNAME) + + # If ttysource is a filename, we assume that it is the name of + # a termcap format file, the first entry of which (matched by the + # null device name) is the entry for the device. Otherwise, + # ttysource is the name of the desired termcap entry in the regular + # termcap file. + + if (fnldir (Memc[ttysource], Memc[fname], SZ_FNAME) > 0) { + call strcpy (Memc[ttysource], Memc[fname], SZ_FNAME) + Memc[device] = EOS + } else { + if (envgets (termcap, Memc[fname], SZ_FNAME) <= 0) + call syserrs (SYS_ENVNF, termcap) + call strcpy (Memc[ttysource], Memc[device], SZ_FNAME) + } + + # Truncate the device name if device fields are appended. + call ttydevname (Memc[device], Memc[device], SZ_FNAME) + + # Allocate and initialize the tty descriptor structure and fetch + # termcap entry from termcap file. The TTYLOAD procedure, passed + # as an argument to TTYOPEN, is searched for cached termcap entries + # before accessing the actual file. + + tty = ttyopen (Memc[fname], Memc[device], ttyload) + + # Prepare index of fields in the descriptor, so that we can more + # efficiently search for fields later. + + call tty_index_caps (tty, T_CAPCODE(tty), T_CAPINDEX(tty), + T_NCAPS(tty)) + + # Determine whether or not the terminal can backspace with BS. + if (ttygetb (tty, "bs")) + T_BSOK(tty) = YES + else + T_BSOK(tty) = NO + + # Determine whether or not the stdgraph device can expand tabs. + # If it can but it requires some long string, don't bother. + + T_HTOK(tty) = NO + T_TABCHAR(tty) = 0 + if (ttygetb (tty, "pt")) { + nchars = ttygets (tty, "ta", Memc[fname], SZ_FNAME) + if (nchars <= 0) { + T_HTOK(tty) = YES + T_TABCHAR(tty) = '\t' + } else if (nchars == 1) { + T_HTOK(tty) = YES + T_TABCHAR(tty) = Memc[fname] + } + } + + # Does the terminal autoadvance at the right margin? + T_AM(tty) = btoi (ttygetb (tty, "am")) + + # Determine the optimimum mode for handling standout mode control, + # and save in the descriptor. + + if (ttygetb (tty, "so")) { + T_SOTYPE(tty) = SOSE # use so, se + } else if (ttygetb (tty, "os")) { + if (T_BSOK(tty) == YES || ttygetb (tty, "bc")) + T_SOTYPE(tty) = BSOS # backspace, ostrike + else + T_SOTYPE(tty) = CROS # ostrike whole line + } else + T_SOTYPE(tty) = TOUP # to upper case + + # Get pad char and baud rate (used by ttyputs to generate delays) + # and put in descriptor for efficient access. Also get tty screen + # dimensions since they are fundamental and will probably prove + # useful later. + + T_PADCHAR(tty) = ttygeti (tty, "pc") # returns 0 if field not found + + # Allow environment variables to override physical screen dimensions + # if device is the standard terminal. + + istty = (streq (Memc[devname], terminal)) + + # Get nlines. + if (istty) + iferr (T_NLINES(tty) = envgeti ("ttynlines")) + T_NLINES(tty) = 0 + if (T_NLINES(tty) <= 0) + iferr (T_NLINES(tty) = ttygeti (tty, "li")) + T_NLINES(tty) = 0 + if (T_NLINES(tty) <= 0) + T_NLINES(tty) = DEF_TTYNLINES + + # Get ncols. + if (istty) + iferr (T_NCOLS(tty) = envgeti ("ttyncols")) + T_NCOLS(tty) = 0 + if (T_NCOLS(tty) <= 0) + iferr (T_NCOLS(tty) = ttygeti (tty, "co")) + T_NCOLS(tty) = 0 + if (T_NCOLS(tty) <= 0) + T_NCOLS(tty) = DEF_TTYNCOLS + + # Baud rate may not be right if device is a printer attached to the + # host, and user is working remotely. Nonetheless it is safer to pick + # up the value from the environment than to assume a default. + + iferr (T_BAUD(tty) = envgeti ("ttybaud")) + T_BAUD(tty) = DEF_BAUDRATE + + call sfree (sp) + return (tty) +end diff --git a/sys/tty/ttyopen.x b/sys/tty/ttyopen.x new file mode 100644 index 00000000..07577821 --- /dev/null +++ b/sys/tty/ttyopen.x @@ -0,0 +1,299 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "tty.h" + +# TTYOPEN -- Scan the named TERMCAP style file for the entry for the named +# device, and if found allocate a TTY descriptor structure, leaving the +# termcap entry for the device in the descriptor. + +pointer procedure ttyopen (termcap_file, device, ttyload) + +char termcap_file[ARB] # termcap file to be scanned +char device[ARB] # name of device to be scanned for +extern ttyload() # fetches pre-compiled entries from a cache +int ttyload() + +int maxch, nchars +pointer tty, sp, devname +errchk ttyload, calloc, realloc + +begin + call smark (sp) + call salloc (devname, SZ_FNAME, TY_CHAR) + + # Truncate the device name if device fields are appended. + call strcpy (device, Memc[devname], SZ_FNAME) + call ttydevname (Memc[devname], Memc[devname], SZ_FNAME) + + # Allocate and initialize the tty descriptor structure. + call calloc (tty, LEN_DEFTTY, TY_STRUCT) + + T_LEN(tty) = LEN_DEFTTY + T_OP(tty) = 1 + + # Call the TTYLOAD procedure to see if the TERMCAP entry for the device + # is in the cache of pre-compiled device entries. If not in cache, + # we must scan the actual termcap file. + + maxch = (T_LEN(tty) - T_OFFCAP) * SZ_STRUCT + nchars = ttyload (termcap_file, Memc[devname], T_CAPLIST(tty), maxch) + + if (nchars > 0) { + # Found device in cache. + T_OP(tty) = nchars + 1 + T_CAPLEN(tty) = T_OP(tty) + } else { + # Must scan the source file. + iferr (call tty_scan_termcap_file (tty, termcap_file, + Memc[devname])) { + call mfree (tty, TY_STRUCT) + call erract (EA_ERROR) + } + } + + # Call realloc to return any unused space in the descriptor. + T_LEN(tty) = T_OFFCAP + (T_OP(tty) + SZ_STRUCT-1) / SZ_STRUCT + call realloc (tty, T_LEN(tty), TY_STRUCT) + + call sfree (sp) + return (tty) +end + + +# TTY_SCAN_TERMCAP_FILE -- Open and scan the named TERMCAP format database +# file for the named device. Fetch termcap entry, expanding any and all +# "tc" references by repeatedly rescanning file. + +procedure tty_scan_termcap_file (tty, termcap_file, devname) + +pointer tty # tty descriptor structure +char termcap_file[ARB] # termcap format file to be scanned +char devname[ARB] # termcap entry to be scanned for + +int fd, ntc +pointer sp, device, ip, op, caplist +int open(), strlen(), strncmp() +pointer coerce() +errchk open, syserrs + +begin + call smark (sp) + call salloc (device, SZ_FNAME, TY_CHAR) + + fd = open (termcap_file, READ_ONLY, TEXT_FILE) + call strcpy (devname, Memc[device], SZ_FNAME) + + ntc = 0 + repeat { + iferr (call tty_fetch_entry (fd, Memc[device], tty)) { + call close (fd) + call erract (EA_ERROR) + } + + # Back up to start of last field in entry. + caplist = coerce (tty + T_OFFCAP, TY_STRUCT, TY_CHAR) + ip = caplist + T_OP(tty)-1 - 2 + while (ip > caplist && Memc[ip] != ':') + ip = ip - 1 + + # If last field is "tc", backup op so that the tc field gets + # overwritten with the referenced entry. + + if (strncmp (Memc[ip+1], "tc", 2) == 0) { + # Check for recursive tc reference. + ntc = ntc + 1 + if (ntc > MAX_TC_NESTING) { + call close (fd) + call syserrs (SYS_TTYTC, Memc[device]) + } + + # Set op to point to the ":" in ":tc=file". + T_OP(tty) = ip - caplist + 1 + + # Get device name from tc field, and loop again to fetch new + # entry. + ip = ip + strlen (":tc=") + for (op=device; Memc[ip] != EOS && Memc[ip] != ':'; ip=ip+1) { + Memc[op] = Memc[ip] + op = op + 1 + } + Memc[op] = EOS + call seek (fd, BOFL) + } else + break + } + + call close (fd) + call sfree (sp) +end + + +# TTY_FETCH_ENTRY -- Search the termcap file for the named entry, then read +# the colon delimited capabilities list into the caplist field of the tty +# descriptor. If the caplist field fills up, allocate more space. + +procedure tty_fetch_entry (fd, device, tty) + +int fd +char device[ARB] +pointer tty + +char ch, lastch +pointer sp, ip, op, otop, lbuf, alias, caplist +bool device_found, streq() +char getc() +int getline(), tty_extract_alias() +pointer coerce() +errchk getline, getc, realloc, salloc +define errtn_ 91 + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + call salloc (alias, SZ_FNAME, TY_CHAR) + + # Locate entry. First line of each termcap entry contains a list + # of aliases for the device. Only first lines and comment lines + # are left justified. + + repeat { + # Skip comment and continuation lines and blank lines. + device_found = false + + if (getc (fd, ch) == EOF) + goto errtn_ + + if (ch == '\n') { + # Skip a blank line. + next + } else if (ch == '#' || IS_WHITE (ch)) { + # Discard the rest of the line and continue. + if (getline (fd, Memc[lbuf]) == EOF) + goto errtn_ + next + } + + # Extract list of aliases. The first occurrence of ':' marks + # the end of the alias list and the beginning of the caplist. + + Memc[lbuf] = ch + op = lbuf + 1 + + for (; getc(fd,ch) != ':'; op=op+1) { + Memc[op] = ch + if (ch == EOF || ch == '\n' || op-lbuf >= SZ_LINE) { + goto errtn_ + } + } + Memc[op] = EOS + + ip = lbuf + while (tty_extract_alias (Memc, ip, Memc[alias], SZ_FNAME) > 0) { + if (device[1] == EOS || streq (Memc[alias], device)) { + device_found = true + break + } else if (Memc[ip] == '|') + ip = ip + 1 # skip delimiter + } + + # Skip rest of line if no match. + if (!device_found) { + if (getline (fd, Memc[lbuf]) == EOF) { + goto errtn_ + } + } + } until (device_found) + + # Caplist begins at first ':'. Each line has some whitespace at the + # beginning which should be skipped. Escaped newline implies + # continuation. + + caplist = coerce (tty + T_OFFCAP, TY_STRUCT, TY_CHAR) + op = caplist + T_OP(tty) - 1 + otop = coerce (tty + T_LEN(tty), TY_STRUCT, TY_CHAR) - 1 + + # We are already positioned to the start of the caplist. + Memc[op] = ':' + op = op + 1 + lastch = ':' + + # Extract newline terminated caplist string. + while (getc (fd, ch) != EOF) { + if (ch == '\\') { # escaped newline? + if (getc (fd, ch) == '\n') { + while (getc (fd, ch) != EOF) + if (!IS_WHITE(ch)) + break + if (ch == EOF || ch == '\n') + goto errtn_ + # Avoid null entries ("::"). + if (ch == ':' && lastch == ':') + next + else + Memc[op] = ch + } else { # no, keep both chars + Memc[op] = '\\' + op = op + 1 + Memc[op] = ch + } + } else if (ch == '\n') { # normal exit + Memc[op] = EOS + T_OP(tty) = op - caplist + 1 + T_CAPLEN(tty) = T_OP(tty) + call sfree (sp) + return + } else + Memc[op] = ch + + # Increase size of buffer if necessary. Note that realloc may + # move the buffer, so we must recalculate op and otop. + + lastch = ch + op = op + 1 + if (op >= otop) { + T_OP(tty) = op - caplist + 1 + T_LEN(tty) = T_LEN(tty) + T_MEMINCR + call realloc (tty, T_LEN(tty), TY_STRUCT) + op = caplist + T_OP(tty) - 1 + otop = coerce (tty + T_LEN(tty), TY_STRUCT, TY_CHAR) - 1 + } + } + +errtn_ + call sfree (sp) + call syserrs (SYS_TTYDEVNF, device) +end + + +# TTY_EXTRACT_ALIAS -- Extract a device alias string from the header of +# a termcap entry. The alias string is terminated by '|' or ':'. Leave +# ip pointing at the delimiter. Return number of chars in alias string. + +int procedure tty_extract_alias (str, ip, outstr, maxch) + +char str[ARB] # first line of termcap entry +int ip # on input, first char of alias +char outstr[ARB] +int maxch + +char ch +int op + +begin + op = 1 + for (ch=str[ip]; ch != '|' && ch != ':' && ch != EOS; ch=str[ip]) { + outstr[op] = ch + op = min (maxch, op) + 1 + ip = ip + 1 + } + outstr[op] = EOS + + if (ch == EOS) + return (0) + else + return (op-1) +end diff --git a/sys/tty/ttyputl.x b/sys/tty/ttyputl.x new file mode 100644 index 00000000..1510168c --- /dev/null +++ b/sys/tty/ttyputl.x @@ -0,0 +1,322 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "tty.h" + +.help ttyputline +.nf ___________________________________________________________________________ +TTYPUTLINE -- Put a line to a tty device, processing any special control codes +therein. We are concerned with formfeeds, tabs, and standout mode. Formfeeds +are dealt with by sending the ff capability, if defined for the device (FF is +sent if there is no ff entry). Tabs are expanded if the device does not have +hardware tabs; if tabs are not expanded, the ta capability is sent to the device +for each tab (HT is sent if there is no ta string). + +Standout mode is more complex. We distinguish between four types of devices +for standout mode control (presented in order of desirability): + + (1) [SOSE] Device has so/se. Map SO, SE chars in input stream into so/se + sequences. + + (2) [BSOS] Device can backspace and overstrike. Backspace each printable + char in standout mode and overstrike with the underscore character. + + (3) [CROS] Device cannot backspace, but can overstrike. Follow the output + line with a CR and then a line consisting only of spaces and + underscores. + + (4) [TOUP] No conventional way to generate standout mode for device. + Map alpha chars to upper case to make them standout. + +Long lines are automatically broken at the right margin. +.endhelp ______________________________________________________________________ + + +procedure ttyputline (fd, tty, text, map_cc) + +int fd # output file +pointer tty # TTY descriptor +char text[ARB] # line of text to be output +int map_cc # enable mapping of SO, SE control chars + +char obuf[SZ_LINE] +int ip, op, pos, col, maxcols, tabstop, tabchar, ch +errchk write +define hardcase_ 91 + +begin + maxcols = min (SZ_LINE, T_NCOLS(tty)) + tabchar = T_TABCHAR(tty) + pos = 1 + col = 1 + op = 1 + + # Optimize the special case of a line less than the maximum length + # which contains no special control characters. As long as this is + # handled efficiently, the rest doesn't matter. + + for (pos=1; text[pos] != EOS; pos=pos+1) { + do ip = pos, ARB { + ch = text[ip] + + if (ch >= ' ') { + # Ordinary printable character; the most common case. + obuf[op] = ch + op = op + 1 + col = col + 1 + + # If col > maxcols then we have completely filled the + # output line. If there is more text to come we must + # break the line. If the next character is newline we + # may also break the line and discard the newline. + + if (col > maxcols && text[ip+1] != EOS) { + if (T_AM(tty) == NO) { + obuf[op] = '\n' + op = op + 1 + } + pos = ip + if (text[ip+1] == '\n') + pos = pos + 1 + break + } + + } else if (ch == '\n') { + # End of line. + obuf[op] = ch + op = op + 1 + pos = ip + break + + } else if (ch == '\t') { + # Tab. + tabstop = min (maxcols, ((col-1) / 8 + 1) * 8 + 1) + if (tabchar != 0) { + obuf[op] = tabchar + op = op + 1 + col = tabstop + } else { + while (col < tabstop) { + obuf[op] = ' ' + op = op + 1 + col = col + 1 + } + } + + } else if (ch == EOS) { + pos = ip - 1 + break + + } else + goto hardcase_ + } + + if (op > 1) + call write (fd, obuf, op - 1) + + op = 1 + col = 1 + } + + return + +hardcase_ + # Special processsing is needed. + call ttygputline (fd, tty, text, map_cc) +end + + +# TTYGPUTLINE -- This is the original ttypuline. The code is not very +# efficient, but it handles formfeeds, standout mode, etc. in a generalized +# fashion. + +procedure ttygputline (fd, tty, text, map_cc) + +int fd # output file +pointer tty # TTY descriptor +char text[ARB] # line of text to be output +int map_cc # enable mapping of SO, SE control chars + +pointer sp, ostrike, op +bool so_seen, so_mode_in_effect +int ip, so_type, ocol, junk, ch, tabchar +int ttyctrl() +errchk tty_break_line, putci, ttyctrl, ttyso + +begin + call smark (sp) + call salloc (ostrike, SZ_LINE, TY_CHAR) + + so_mode_in_effect = false + so_type = T_SOTYPE(tty) + tabchar = T_TABCHAR(tty) + so_seen = false + ocol = 1 + op = ostrike + + # Process the input line, mapping all known sequences. Other control + # chars are passed on without modification. The input line should be + # an entire line, or CROS mode will not work correctly. Lines longer + # than T_NCOLS are broken at the right margin. + + for (ip=1; text[ip] != EOS; ip=ip+1) { + ch = text[ip] + + # Break line if newline seen or at right margin. + if (ch == '\n' || ocol > T_NCOLS(tty)) { + call tty_break_line (fd, tty, ostrike, op, so_type, so_seen) + so_mode_in_effect = false + ocol = 1 + + # Output a newline if short line or the terminal does not + # have automargins. + + if (ocol < T_NCOLS(tty) || T_AM(tty) == NO) + call putci (fd, '\n') + + # Fall through and output ch if ch was not newline. + if (ch == '\n') + next + } + + # Deal with common printable characters. If standout mode is + # in effect, we must take special actions to make the char + # stand out if the terminal does not have the so/se capability. + # Note that blanks may be made to standout; if this is not + # desired, the high level code must turn standout mode on and off. + + if (ch >= BLANK) { + if (so_type != SOSE) + switch (so_type) { + case BSOS: + if (so_mode_in_effect) { + call putci (fd, '_') + if (T_BSOK(tty) == YES) + call putci (fd, BS) + else + junk = ttyctrl (fd, tty, "bc", 1) + } + case CROS: + if (so_mode_in_effect) + Memc[op] = '_' + else + Memc[op] = BLANK + op = op + 1 + case TOUP: + if (so_mode_in_effect && IS_LOWER(ch)) + ch = TO_UPPER (ch) + } + + call putci (fd, ch) + ocol = ocol + 1 + next + } + + # We get here only if the character is a control character. + + if (ch == '\t') { + # If hardware tab expansion is enabled, use that, otherwise + # wait and put out blanks in next block of code. + + if (T_HTOK(tty) == YES) { + call putci (fd, tabchar) + if (so_type == CROS) { + Memc[op] = '\t' + op = op + 1 + } + } + + # Keep track of virtual output column, also output blanks to + # expand tab if hardware expansion is disabled. + + repeat { + if (T_HTOK(tty) != YES) { + call putci (fd, BLANK) + if (so_type == CROS) { + Memc[op] = BLANK + op = op + 1 + } + } + ocol = ocol + 1 + } until (mod (ocol+TABSIZE-1, TABSIZE) == 0) + + } else if (ch == FF) { + # Formfeed breaks the output line if not at beginning of a + # line. + + if (ocol > 1) { + call tty_break_line (fd, tty, ostrike, op, so_type, so_seen) + if (ocol < T_NCOLS(tty) || T_AM(tty) == NO) + call putci (fd, '\n') + } + if (ttyctrl (fd, tty, "ff", T_NLINES(tty)) == ERR) + call putci (fd, FF) + ocol = 1 + so_mode_in_effect = false + + } else if (ch == SO_ON) { + # Begin standout mode. + if (so_type == SOSE) + call ttyso (fd, tty, YES) + so_mode_in_effect = true + so_seen = true + + } else if (ch == SO_OFF) { + # End standout mode. + if (so_type == SOSE) + call ttyso (fd, tty, NO) + so_mode_in_effect = false + + } else { + # Unknown control character. Do not increment ocol. + if (map_cc == YES) { + call putci (fd, '^') + call putci (fd, ch + 'A' - 1) + } else + call putci (fd, ch) + } + } + + # If EOS is seen, but not newline, do not issue a newline, but do + # ignore contents of overstrike buffer. Thus, we can be used to output + # portions of a line on non-CROS terminals. + + call sfree (sp) +end + + +# TTY_BREAK_LINE -- Break the output line. If overstrike is selected, +# overstrike output line with the ostrike line. We assume that OP is +# valid only if so_type is CROS. Note that OP and SO_SEEN are reset. + +procedure tty_break_line (fd, tty, ostrike, op, so_type, so_seen) + +int fd +pointer tty, ostrike, op +int so_type +bool so_seen + +int ch +pointer ip + +begin + # If carriage return, overstrike is enabled and the line had a standout + # mode directive, output the overstrike line. + + if (so_type == CROS && so_seen) { + call putci (fd, '\r') + Memc[op] = EOS + + # Output overstrike line. + for (ip=ostrike; Memc[ip] != EOS; ip=ip+1) { + ch = Memc[ip] + if (ch == '\t') + ch = T_TABCHAR(tty) + call putci (fd, ch) + } + } + + op = ostrike + so_seen = false +end diff --git a/sys/tty/ttyputs.x b/sys/tty/ttyputs.x new file mode 100644 index 00000000..aeec99ef --- /dev/null +++ b/sys/tty/ttyputs.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# TTYPUTS -- Put an EOS delimited control string to the output file. + +procedure ttyputs (fd, tty, ctrlstr, afflncnt) + +int fd # output file +pointer tty # terminal descriptor +char ctrlstr[ARB] # control sequence to be output +int afflncnt # number of lines affected +int strlen() + +begin + call ttywrite (fd, tty, ctrlstr, strlen(ctrlstr), afflncnt) +end diff --git a/sys/tty/ttyread.x b/sys/tty/ttyread.x new file mode 100644 index 00000000..7ead64a3 --- /dev/null +++ b/sys/tty/ttyread.x @@ -0,0 +1,102 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +define PAUSE 20 # pause if no data, msec + + +# TTYREAD -- Read from the terminal in raw mode until sufficient data is +# accumulated to match the given encoded pattern. Any additional data read +# prior to the matched pattern (normally due to type-ahead) is pushed back +# into the input stream. If timeout > 0 nonblocking reads are used, and +# the operation will time out if the pattern is not matched within the given +# interval in milliseconds. A valid read returns nchars > 0 indicating the +# length of the matched pattern; 0 is returned for a timeout and ERR for a +# garbled read. + +int procedure ttyread (fd, tty, outbuf, maxch, patbuf, timeout) + +int fd # output file +pointer tty # terminal descriptor +char outbuf[maxch] # output data buffer +int maxch # max chars out +char patbuf[ARB] # encoded pattern +int timeout # timeout interval, msec (0 for no timeout) + +bool match +pointer sp, ip, op, buf +int sv_iomode, iomode, delay, first, last, nchars, ch +int fstati(), patmatch(), gpatmatch(), getci(), gstrcpy() +errchk getci, unread +define abort_ 91 + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + # Save raw mode state and set up for nonblocking raw mode reads + # if a timeout interval was specified. + + iomode = IO_RAW + if (timeout > 0) + iomode = iomode + IO_NDELAY + + sv_iomode = fstati (fd, F_IOMODE) + if (sv_iomode != iomode) + call fseti (fd, F_IOMODE, iomode) + + outbuf[1] = EOS + match = false + nchars = 0 + delay = 0 + op = buf + + # Accumulate input characters in nonblocking raw mode until either + # the given pattern is matched, or we timeout. + + repeat { + # Read characters until the full sequence has been input or no + # more data is available. + + while (!match && (op-buf < SZ_LINE) && getci(fd, ch) != EOF) { + if (ch==INTCHAR || ch==EOFCHAR || ch == '\r' || ch == '\n') { + nchars = ERR + goto abort_ + } + + Memc[op] = ch; op = op + 1 + Memc[op] = EOS + match = (gpatmatch (Memc[buf], patbuf, first, last) > 0) + + if (match) { + ip = buf + first - 1 + if (first > 1) { + # Put back any input typed before our data block. + call unread (fd, Memc[buf], first-1) + + # Redo the match to correct index marks for string + # offset. + match = (patmatch (Memc[ip], patbuf) > 0) + } + nchars = gstrcpy (Memc[ip], outbuf, maxch) + } + } + + # If the nonblocking read returns EOF, indicating no input was + # queued, wait a bit and try again. + + if (!match && ch == EOF) { + call zwmsec (PAUSE) + delay = delay + PAUSE + } + } until (match || delay > timeout) + +abort_ + # Restore previous raw mode state. + if (sv_iomode != iomode) + call fseti (fd, F_IOMODE, sv_iomode) + + call sfree (sp) + return (nchars) +end diff --git a/sys/tty/ttyseti.x b/sys/tty/ttyseti.x new file mode 100644 index 00000000..18493766 --- /dev/null +++ b/sys/tty/ttyseti.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "tty.h" + +# TTYSETI -- Set a TTY parameter. Can be used after a ttyodes to override +# termcap and environment parameters affecting terminal control. + +procedure ttyseti (tty, parameter, value) + +pointer tty +int parameter, value +char parnum[3] +int junk, itoc() + +begin + switch (parameter) { + case TTY_PADCHAR: + T_PADCHAR(tty) = value + case TTY_TABS: + T_HTOK(tty) = value + case TTY_SOTYPE: + T_SOTYPE(tty) = value + case TTY_BAUD: + T_BAUD(tty) = value + case TTY_NLINES: + T_NLINES(tty) = value + case TTY_NCOLS: + T_NCOLS(tty) = value + default: + junk = itoc (parameter, parnum, 3) + call syserrs (SYS_TTYSET, parnum) + } +end diff --git a/sys/tty/ttyso.x b/sys/tty/ttyso.x new file mode 100644 index 00000000..e03de838 --- /dev/null +++ b/sys/tty/ttyso.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# TTYSO -- Turn "standout" mode on or off. + +procedure ttyso (fd, tty, onflag) + +int fd, onflag +pointer tty + +char cap[2] +bool ttygetb() +int junk, ttyctrl() +errchk ttygetb + +begin + # Select name of capability (so, se, us, ue). Use so/se if it is + # available for the terminal, otherwise try us/ue. + if (ttygetb (tty, "so")) { + cap[1] = 's' + cap[2] = 'o' + } else { + cap[1] = 'u' + cap[2] = 's' + } + if (onflag == NO) + cap[2] = 'e' + cap[3] = EOS + + # Output the control sequence. If cap is not available for the + # terminal, nothing will be output. + junk = ttyctrl (fd, tty, cap, 1) +end diff --git a/sys/tty/ttystati.x b/sys/tty/ttystati.x new file mode 100644 index 00000000..52578fba --- /dev/null +++ b/sys/tty/ttystati.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "tty.h" + +# TTYSTATI -- Fetch a TTY parameter. + +int procedure ttystati (tty, parameter) + +pointer tty +int parameter +char parnum[3] +int value, junk, itoc() + +begin + switch (parameter) { + case TTY_PADCHAR: + value = T_PADCHAR(tty) + case TTY_TABS: + value = T_HTOK(tty) + case TTY_SOTYPE: + value = T_SOTYPE(tty) + case TTY_BAUD: + value = T_BAUD(tty) + case TTY_NLINES: + value = T_NLINES(tty) + case TTY_NCOLS: + value = T_NCOLS(tty) + default: + junk = itoc (parameter, parnum, 3) + call syserrs (SYS_TTYSTAT, parnum) + } + + return (value) +end diff --git a/sys/tty/ttysubi.x b/sys/tty/ttysubi.x new file mode 100644 index 00000000..870dce59 --- /dev/null +++ b/sys/tty/ttysubi.x @@ -0,0 +1,194 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "tty.h" + +.help ttysubi +.nf ___________________________________________________________________________ +TTYSUBI -- Argument substitution on a control string. + + Process a capability string containing arguments. Examples of such +capability strings are cursor motion to [x,y], and set scrolling region to +[line1,line2]. Note that arguments in the termcap database are zero-indexed +by default, while the TTYSUBI arguments are one-indexed. The control string +given as input has already been processed to reduce all escape sequences to +single characters. + +Various output formats are supported (some of these are completely off the +wall, very special case, but that's how termcap does it): + + %d print decimal integer, zero origin. + %2 like %2d. + %3 like %3d. + %. put binary value of x,y arg as a character + %+x like %., but add value of char X first + %% print a single %. + +The following format codes affect the arguments, but do not directly cause +any output: + + %>xy if next arg value > char x add char y. + %r reverses order of arguments. + %i increments arg values by one, for 1 origin. + %n exlusive-or args with 0140B. (DM2500) + %B BCD next arg, (16*(x/10))+(mod(x,10). + %D Reverse coding (x-2*(mod(x,16))). (Delta Data) + +We have generalized the termcap formats somewhat to permit a greater range +of %n formats (%1-%4), as well as %o and %x formats, in case a terminal +comes along which likes octal or hex numbers. + +The %. format causes special problems. If the terminal requires coordinates +in binary in the range zero or one to 40B, we can expect problems trying to +push such chars through the OS driver and any other software (networks, etc.), +since system software likes to map control characters on output. To get around +this we have defined a set of reserved codes which are not to be generated. +This set is defined in tty.h, and includes newline, tab, etc. When asked to +output one of these chars, we output a char with a somewhat larger value +and return the delta to our caller, which does whatever is appropriate to +complete the function. +.endhelp ______________________________________________________________________ + +int procedure ttysubi (ctrlstr, outstr, maxch, coords, ncoords) + +char ctrlstr[ARB] # control string containing % formats +char outstr[ARB] # receives processed string +int maxch +int coords[ncoords] # on input, coords; on output, deltas +int ncoords + +bool reverse # reverse deltas on output +int revstart # first arg/coord reversed +int args[MAX_COORDS] # processed values of arguments +int argnum # arg being processed +int nargs # number of args (min(MAX_COORDS,ncoords)) +char driver_chars[NDCHARS] +char ch, format_char +int i, ip, op, field_width, left, right, temp +int stridx(), strlen(), xor() +data driver_chars /DRIVER_CHARS/ +errchk sprintf, pargi + +begin + # Make a local copy of the arguments to make reversal etc. easy. + # Also switch to zero-indexing internally, since the termcap entry + # is zero-indexed. + + nargs = min (MAX_COORDS, ncoords) + do i = 1, nargs { + args[i] = coords[i] - 1 # make zero-indexed + coords[i] = 0 # init delta + } + argnum = 1 # output x first by default + reverse = false + + op = 1 + for (ip=1; ctrlstr[ip] != EOS && op <= maxch; ip=ip+1) { + ch = ctrlstr[ip] + + # If normal char, we do not get past this if statement. + if (ch != '%') { + outstr[op] = ch + op = op + 1 + next + } else { + ip = ip + 1 # fetch format-type char + ch = ctrlstr[ip] + } + + # Get here only if processing a %x format specification. + switch (ch) { + case '%': # %% --> % + outstr[op] = ch + op = op + 1 + + case 'd', 'o', 'x', '1', '2', '3', '4': + # Output next argument according to the format given. + if (IS_DIGIT(ch)) { + field_width = TO_INTEG(ch) + format_char = 'd' + } else { + field_width = 0 + format_char = ch + } + + call sprintf (outstr[op], maxch-op+1, "%0*.0*") + call pargi (field_width) + call pargc (format_char) + call pargi (args[argnum]) + + argnum = min (nargs, argnum + 1) + op = op + strlen (outstr[op]) + + case '.', '+': + # Binary output format. Coordinate output in binary is a + # problem because the OS driver may see a tab, newline, or + # whatever and map it into something else. If the value of + # args[argnum] corresponds to a special control character, + # we increment it until we have an acceptable value, leaving + # it up to our caller to do the rest. + + if (ch == '+') { + ip = ip + 1 + args[argnum] = args[argnum] + ctrlstr[ip] + } + + repeat { + ch = char (args[argnum]) + if (stridx (ch, driver_chars) > 0) { + args[argnum] = args[argnum] + 1 + coords[argnum] = coords[argnum] + 1 + } else + break + } + + outstr[op] = args[argnum] + op = op + 1 + argnum = min (nargs, argnum + 1) + + # The remaining cases are used to change the values of the + # remaining arguments, and do not cause any output. + + case '>': # %>xy + if (args[argnum] > ctrlstr[ip+1]) + args[argnum] = args[argnum] + ctrlstr[ip+2] + ip = ip + 2 + case 'r': # swap remaining args + do left = argnum, (nargs - argnum + 1) / 2 { + right = nargs - (left - argnum) + temp = args[left] + args[left] = args[right] + args[right] = temp + } + reverse = !reverse + revstart = argnum + case 'i': # increment by one + do i = argnum, nargs + args[i] = args[i] + 1 + case 'n': # exclusive or with 140B + do i = argnum, nargs + args[i] = xor (args[i], 140B) + case 'B': # BCD encode next arg + temp = args[argnum] + args[argnum] = 16 * (temp / 10) + mod (temp, 10) + case 'D': # Reverse code next arg + temp = args[argnum] + args[argnum] = temp - 2 * mod (temp, 16) + } + } + + # If the input coordinates were reversed, we must reverse the + # correction deltas, too. + + if (reverse) + do left = revstart, (nargs - revstart + 1) / 2 { + right = nargs - (left - revstart) + temp = coords[left] + coords[left] = coords[right] + coords[right] = temp + } + + outstr[op] = EOS + return (op - 1) +end diff --git a/sys/tty/ttywrite.x b/sys/tty/ttywrite.x new file mode 100644 index 00000000..3a581523 --- /dev/null +++ b/sys/tty/ttywrite.x @@ -0,0 +1,60 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "tty.h" + +# TTYWRITE -- Put a counted control string to the output file. The control +# string consists of an optional prefix specifying the delay required, followed +# by the chars to be sent to the terminal. If the delay is given as a simple +# integer number (i.e., ":cl=50\E"), it specifies the delay in milliseconds. +# If the delay number is followed by an asterisk (i.e., ":cd=3.5*\E^C:") it +# specifies the delay in milliseconds per line affected by the operation. +# In the latter case, the AFFLNCNT argument is used to compute the total +# delay. Delays are generated by writing a sequence of pad characters +# (usually NUL); the number of pad chars sent to achieve a particular delay +# depends on the baud rate. + +procedure ttywrite (fd, tty, ctrlstr, nchars, afflncnt) + +int fd # output file +pointer tty # terminal descriptor +char ctrlstr[ARB] # control sequence to be output +int nchars # nchars in control string +int afflncnt # number of lines affected + +double dval +int ip, delay, junk, ch +int ctod(), and() +errchk putci + +begin + # Determine number of milliseconds of delay req'd, and position ip + # to start of control string. Do not use CTOD to test whether or not + # the string begins with a number, because it is not permissable to + # skip whitespace (blank and tab are legal output chars). + + ip = 1 + if (IS_DIGIT (ctrlstr[ip])) { + junk = ctod (ctrlstr, ip, dval) + if (ctrlstr[ip] == '*') { + delay = dval * afflncnt + 0.5 + ip = ip + 1 + } else + delay = dval + } else + delay = 0 + + # Output the control sequence, passing only the first seven bits of + # each character. This is where the \200 escapes get turned into NULs. + # Do not use MOD to do the masking because 200B is a negative integer + # if CHAR is implemented as 8 bits. + + for (; ip <= nchars; ip=ip+1) { + ch = ctrlstr[ip] + call putci (fd, and (ch, 177B)) + } + + # Add padding if needed to generate delay. + call ttydelay (fd, tty, delay) +end diff --git a/sys/tty/x_mkttydata.x b/sys/tty/x_mkttydata.x new file mode 100644 index 00000000..a48cbca8 --- /dev/null +++ b/sys/tty/x_mkttydata.x @@ -0,0 +1,367 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "tty.h" + +task mkttydata = t_mkttydata + +.help mkttydata +.nf ------------------------------------------------------------------------- +MKTTYDATA -- System Manager's program to compile the TERMCAP entries for a +list of terminals. Output is an SPP format include file to be used in TTYLOAD +to statically declare and initialize the TERMCAP entries for the named +devices, eliminating the need to scan the TERMCAP file for those devices. + +Compilation of selected termcap entries to speed up accesses to the +termcap database for frequently referenced terminals. We read and preprocess +the entries for the named terminals from the termcap file, producing the source +code for the TTYLOAD procedure as output. The termcap entry for each device +is included in the source for TTYLOAD as a static data structure. TTYLOAD is +subsequently compiled and placed in the library with the other TTY routines. +At run time, TTYODES first tries to load the termcap database entry using +TTYLOAD, and if that fails it goes and reads the termcap file. + +N.B.: The TTY interface may be used for any termcap format file, regardless +of whether or not the database describes terminals. +.endhelp --------------------------------------------------------------------- + +# Tunable parameters. + +define MAX_DEVICES 25 # initial max termcap entries +define INC_DEVICES 25 # increment if overflow occurs +define SZ_SBUF 4096 # initial size of string buffer +define INC_SZSBUF 2048 # increment if overflow occurs +define NI_PERLINE 5 # number of datastmt ints per line +define NC_PERLINE 8 # number of datastmt chars per line + +# Device descriptor structure (contains the extracted termcap entries). +# There are no upper limits on the number of devices or upon the sizes of +# any of the substructures. + +define LEN_TCSTRUCT 8 + +define TC_NDEVICES Memi[$1] # number of termcap entries +define TC_MAXDEVICES Memi[$1+1] # initial max termcap entries +define TC_DEVNAME_P Memi[$1+2] # pointer to devname index array +define TC_CAPLIST_P Memi[$1+3] # pointer to caplist index array +define TC_SBUF Memi[$1+4] # pointer to string buffer +define TC_SZSBUF Memi[$1+5] # current size of string buffer +define TC_NEXTCH Memi[$1+6] # offset of next avail char in sbuf +define TC_TCFNAME Memi[$1+7] # name of termcap file + +define TC_DEVNAME Memi[TC_DEVNAME_P($1)+$2-1] +define TC_CAPLIST Memi[TC_CAPLIST_P($1)+$2-1] + +# MKTTYDATA -- Given the name of a termcap format file and a list of device +# names, call TTYOPEN to fetch the termcap entry of the device. +# Move the entry for the device into the dev structure and continue until +# the entries for all devices have been read. Write out the source code for +# the data structures of these devices. This output file is "included" +# when TTYLOAD is later compiled, cacheing the termcap entries for the +# named devices in memory. + +procedure t_mkttydata() + +bool verbose +int devlist, fd, ndev, buflen +pointer sp, termcap_file, output_file, devname, tc, tty +bool clgetb() +int clpopnu(), clgfil(), tc_putstr(), open(), tc_dummy_ttyload() +pointer ttyopen() +extern tc_dummy_ttyload() +errchk open, tc_write_data_declarations, clgfil, tc_putstr, malloc, realloc + +begin + call smark (sp) + call salloc (termcap_file, SZ_FNAME, TY_CHAR) + call salloc (output_file, SZ_FNAME, TY_CHAR) + call salloc (devname, SZ_FNAME, TY_CHAR) + call salloc (tc, LEN_TCSTRUCT, TY_STRUCT) + + # Open the list of devices to be compiled into the cache. CLGFIL is + # useful for reading the list even though the list elements are not + # filenames, because it can expand comma a delimited list passed as + # a string as well as read from a list file. The list is not sorted + # so that the caller can order the devices in the order in which they + # will most frequently be referenced (though really it matters little). + # Get the names of the input and output files. + + devlist = clpopnu ("devlist") + call clgstr ("termcap_file", Memc[termcap_file], SZ_FNAME) + call clgstr ("output_file", Memc[output_file], SZ_FNAME) + verbose = clgetb ("verbose") + + # Initialize the TC descriptor structure. Allocate the variable sized + # buffers. + + ndev = 0 + buflen = MAX_DEVICES + + TC_NDEVICES(tc) = 0 + TC_MAXDEVICES(tc) = MAX_DEVICES + TC_SZSBUF(tc) = SZ_SBUF + TC_NEXTCH(tc) = 0 + + iferr { + call malloc (TC_DEVNAME_P(tc), buflen, TY_INT) + call malloc (TC_CAPLIST_P(tc), buflen, TY_INT) + call malloc (TC_SBUF(tc), SZ_SBUF, TY_CHAR) + } then + call erract (EA_FATAL) + + # Store the name of the termcap file in the descriptor. The descriptor + # is only valid if TTYLOAD is called with the exact same filename. + + TC_TCFNAME(tc) = tc_putstr (tc, Memc[termcap_file]) + + # Fetch the termcap entry for each device in the list. This is not + # done very efficiently, but it does not matter since this program + # is infrequently run. Accumulate the entries in the TC structure. + + while (clgfil (devlist, Memc[devname], SZ_FNAME) != EOF) { + # Fetch entry from termcap file. + + iferr (tty = ttyopen (Memc[termcap_file], Memc[devname], + tc_dummy_ttyload)) { + + call erract (EA_WARN) + next + + } else if (verbose) { + call eprintf ("%4d %s: %d chars\n") + call pargi (ndev + 1) + call pargstr (Memc[devname]) + call pargi (T_CAPLEN(tty)) + } + + ndev = ndev + 1 + TC_NDEVICES(tc) = ndev + + # Make room for more devices if necessary. + if (ndev > TC_MAXDEVICES(tc)) { + TC_MAXDEVICES(tc) = TC_MAXDEVICES(tc) + INC_DEVICES + buflen = TC_MAXDEVICES(tc) + iferr { + call realloc (TC_DEVNAME_P(tc), buflen, TY_INT) + call realloc (TC_CAPLIST_P(tc), buflen, TY_INT) + } then + call erract (EA_FATAL) + } + + # Add entry to descriptor. + TC_DEVNAME(tc,ndev) = tc_putstr (tc, Memc[devname]) + TC_CAPLIST(tc,ndev) = tc_putstr (tc, T_CAPLIST(tty)) + + call ttyclose (tty) + } + + call clpcls (devlist) + + # Write the output file (an SPP "include" file) containing data + # declarations for the data structures in the TC structure. + + iferr (call delete (Memc[output_file])) + ; + fd = open (Memc[output_file], NEW_FILE, TEXT_FILE) + call tc_write_data_declarations (fd, tc, Memc[termcap_file]) + call close (fd) + + call mfree (TC_DEVNAME_P(tc), TY_INT) + call mfree (TC_CAPLIST_P(tc), TY_INT) + call mfree (TC_SBUF(tc), TY_CHAR) + call sfree (sp) +end + + +# TC_PUTSTR -- Put a string (incl EOS) in the string buffer at nextch. +# If there is not enough space in the buffer, reallocate a larger buffer. +# Return the index of the string in the string buffer. + +int procedure tc_putstr (tc, str) + +pointer tc +char str[ARB] +int nextch, nchars, strlen() +errchk realloc + +begin + # Null strings are not stored and cause a null index to be returned. + nchars = strlen (str) + if (nchars == 0) + return (0) + + nextch = TC_NEXTCH(tc) + if (nextch + nchars + 1 > TC_SZSBUF(tc)) { + TC_SZSBUF(tc) = TC_SZSBUF(tc) + INC_SZSBUF + call realloc (TC_SBUF(tc), TC_SZSBUF(tc), TY_CHAR) + } + + call strcpy (str, Memc[TC_SBUF(tc) + nextch], ARB) + TC_NEXTCH(tc) = nextch + nchars + 1 + + return (nextch) +end + + +# TC_WRITE_DATA_DECLARATIONS -- Write the SPP data declarations required to +# declare and initialize the following data structures: +# +# int ndevices # number of devices in cache +# int devname[] # 0-indexed offset into sbuf of device name +# int devcaps[] # 0-indexed offset into sbuf of termcap entry +# char sbuf[] # string buffer + +procedure tc_write_data_declarations (fd, tc, termcap_file) + +int fd # output file +pointer tc # TC descriptor +char termcap_file[ARB] # name of source file + +int ndevices, dev +pointer sbuf +int strlen() + +begin + ndevices = TC_NDEVICES(tc) + sbuf = TC_SBUF(tc) + + # Write a comments section naming the devices represented by the + # data declarations which follow. + + call fprintf (fd, + "# TERMCAP data declarations for %d devices from '%s'\n") + call pargi (TC_NDEVICES(tc)) + call pargstr (termcap_file) + + do dev = 1, ndevices { + call fprintf (fd, "#%15s (size %d+1 chars)\n") + call pargstr (Memc[sbuf+TC_DEVNAME(tc,dev)]) + call pargi (strlen (Memc[sbuf+TC_CAPLIST(tc,dev)])) + } + + # Output the object declarations. + + call fprintf (fd, "\n") + call fprintf (fd, "int\ttermcap_filename, ndevices, i\n") + call fprintf (fd, "int\tdevname[%d], devcaps[%d]\n") + call pargi (ndevices) + call pargi (ndevices) + + # Do not add 1 char for the EOS; SPP compiler automatically does so. + call fprintf (fd, "char\tsbuf[%d]\n") + call pargi (TC_NEXTCH(tc)) + + # Output the data initialization declarations. + + call fprintf (fd, "\n") + call fprintf (fd, "data\tndevices /%d/\n") + call pargi (ndevices) + call fprintf (fd, "data\ttermcap_filename /%d/\n") + call pargi (TC_TCFNAME(tc) + 1) + + call tc_init_datai (fd, "devname", Memi[TC_DEVNAME_P(tc)], ndevices) + call tc_init_datai (fd, "devcaps", Memi[TC_CAPLIST_P(tc)], ndevices) + call fprintf (fd, "\n") + call tc_init_datac (fd, "sbuf", Memc[TC_SBUF(tc)], TC_NEXTCH(tc)+1) +end + + +# TC_INIT_DATAI -- Write a series of data statements to initialize an +# integer array. A single large statement is not used due to variation +# in the permissible number of continuation statements permitted by +# different compilers. + +procedure tc_init_datai (fd, varname, array, npix) + +int fd # output file +char varname[ARB] # name of variable to be initialized +int array[npix] # array values +int npix + +int i, j, i1, i2 + +begin + for (j=1; j <= npix; j = j + NI_PERLINE) { + i1 = j + i2 = min (j + NI_PERLINE - 1, npix) + + # Begin new data statement. + call fprintf (fd, "data\t(%s(i),i=%2d,%2d)\t/") + call pargstr (varname) + call pargi (i1) + call pargi (i2) + + # Output data values. NOTE: the TC_SBUF offsets are zero-indexed + # offsets into Mem, but the SBUF array in the include file is a + # static Fortran array which requires 1-indexed offsets, so we + # add one before writing out the offsets. + + for (i=i1; i <= i2; i=i+1) { + if (i > i1) + call fprintf (fd, ", ") + call fprintf (fd, "%d") + call pargi (array[i] + 1) + } + + # Terminate statement. + call fprintf (fd, "/\n") + } +end + + +# TC_INIT_DATAC -- Write a series of data statements to initialize a +# char array. A single large statement is not used due to variation +# in the permissible number of continuation statements permitted by +# different compilers. + +procedure tc_init_datac (fd, varname, str, nchars) + +int fd # output file +char varname[ARB] # name of variable to be initialized +char str[nchars] # array values +int nchars + +int i, j, i1, i2 + +begin + for (j=1; j <= nchars; j = j + NC_PERLINE) { + i1 = j + i2 = min (j + NC_PERLINE - 1, nchars) + + # Begin new data statement. + call fprintf (fd, "data\t(%s(i),i=%2d,%2d)\t/") + call pargstr (varname) + call pargi (i1) + call pargi (i2) + + # Output data values. + for (i=i1; i <= i2; i=i+1) { + if (i > i1) + call fprintf (fd, ", ") + call fprintf (fd, "%3d") + call pargc (str[i]) + } + + # Terminate statement. + call fprintf (fd, "/\n") + } +end + + +# TC_DUMMY_TTYLOAD -- Since we are rebuilding a TTYLOAD, we cannot pass +# a real one to TTYOPEN. This dummy procedure returns 0 to TTYOPEN for +# all devices, forcing TTYOPEN to open and scan the termcap file to fetch +# the termcap entry for a device. + +int procedure tc_dummy_ttyload (termcap_file, devname, outstr, maxch) + +char termcap_file[ARB] +char devname[ARB] +char outstr[maxch] +int maxch + +begin + outstr[1] = EOS + return (0) +end diff --git a/sys/tty/zzdebug.x b/sys/tty/zzdebug.x new file mode 100644 index 00000000..f28b1714 --- /dev/null +++ b/sys/tty/zzdebug.x @@ -0,0 +1,184 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "tty.h" + +# Debug TTY package. + +task find=t_find, cap=t_cap, init=t_init + +define SZ_CAPSTR 30 +define FAKE_PADCHAR 177B + + +# FIND -- Find an entry in the termcap database, and print out the caplist +# string. + +procedure t_find() + +char ttyname[SZ_FNAME] +pointer tty, ttygdes() + +begin + call clgstr ("ttyname", ttyname, SZ_FNAME) + tty = ttygdes (ttyname) + + call printf ("Termcap entry for '%s', %d capabilities\n") + call pargstr (ttyname) + call pargi (T_NCAPS(tty)) + call printf (" pc=%oB, bsok=%b, htok=%b, %d by %d, %d baud\n") + call pargi (T_PADCHAR(tty)) + call pargi (T_BSOK(tty)) + call pargi (T_HTOK(tty)) + call pargi (T_NCOLS(tty)) + call pargi (T_NLINES(tty)) + call pargi (T_BAUD(tty)) + + call putline (STDOUT, T_CAPLIST(tty)) + call putci (STDOUT, '\n') + call ttycdes (tty) +end + + +# CAP -- Open descriptor, then sit in a get/put capability loop. Capabilities +# are put to the stdout in a readable form. + +procedure t_cap() + +char ttyname[SZ_FNAME], capstr[SZ_CAPSTR] +char ctrlstr[SZ_CTRLSTR], tempstr[SZ_CTRLSTR], obuf[SZ_LINE] +int fd, args[MAX_COORDS], nargs, nchars + +int stropen(), ttygets(), ttysubi(), clglstr(), strlen(), nscan() +pointer tty, ttygdes() + +begin + call clgstr ("ttyname", ttyname, SZ_FNAME) + tty = ttygdes (ttyname) + call ttyseti (tty, TTY_PADCHAR, FAKE_PADCHAR) + + call printf ("Termcap entry for '%s', %d capabilities\n") + call pargstr (ttyname) + call pargi (T_NCAPS(tty)) + call printf (" pc=%oB, bsok=%b, htok=%b, %d by %d, %d baud\n") + call pargi (T_PADCHAR(tty)) + call pargi (T_BSOK(tty)) + call pargi (T_HTOK(tty)) + call pargi (T_NCOLS(tty)) + call pargi (T_NLINES(tty)) + call pargi (T_BAUD(tty)) + + while (clglstr ("cap", capstr, SZ_CAPSTR) != EOF) + if (ttygets (tty, capstr, ctrlstr, SZ_CTRLSTR) == 0) { + call printf ("capability '%s' not found\n") + call pargstr (capstr) + } else { + fd = stropen (obuf, SZ_LINE, NEW_FILE) + + # Expand args? (as in "cap: cm 11 4") + if (strlen (capstr) > 2) { + call sscan (capstr[3]) + for (nargs=0; nscan() == nargs; nargs=nargs+1) + call gargi (args[nargs+1]) + nargs = nargs - 1 + call strcpy (ctrlstr, tempstr, SZ_CTRLSTR) + nchars = ttysubi (tempstr, ctrlstr,SZ_CTRLSTR, args,nargs) + } else + nargs = 0 + + call ttyputs (fd, tty, ctrlstr, 1) + if (nargs > 0 && args[1] != 0 || args[2] != 0) { + call fprintf (fd, " residual x=%d, y=%d") + call pargi (args[1]) + call pargi (args[2]) + } + call close (fd) + call dump_chars (STDOUT, obuf) + } + call putci (STDOUT, '\n') + + call ttycdes (tty) +end + + +# INIT -- Output initialization string in human readable form on the standard +# output. + +define SZ_OBUF 1024 + + +procedure t_init() + +char ttyname[SZ_FNAME] +char obuf[SZ_OBUF] +int fd +int stropen() +pointer tty, ttygdes() + +begin + call clgstr ("ttyname", ttyname, SZ_FNAME) + tty = ttygdes (ttyname) + call ttyseti (tty, TTY_PADCHAR, FAKE_PADCHAR) + + # Print header identifying basic terminal capabilities. + call printf ("Termcap entry for '%s', %d capabilities\n") + call pargstr (ttyname) + call pargi (T_NCAPS(tty)) + call printf (" pc=%oB, bsok=%b, htok=%b, %d by %d, %d baud\n") + call pargi (T_PADCHAR(tty)) + call pargi (T_BSOK(tty)) + call pargi (T_HTOK(tty)) + call pargi (T_NCOLS(tty)) + call pargi (T_NLINES(tty)) + call pargi (T_BAUD(tty)) + + # Dump initialization string into buffer, print buffer in readable + # form on STDOUT. + + fd = stropen (obuf, SZ_OBUF, NEW_FILE) + call ttyinit (fd, tty) + call close (fd) + call dump_chars (STDOUT, obuf) + call putci (STDOUT, '\n') + + call ttycdes (tty) +end + + +# DUMP_CHARS -- Print out a sequence of normal and control chars in a nice +# readable form. + +procedure dump_chars (fd, str) + +int fd +char str[ARB] +char ch +int ip, iptop +int stridx() +errchk putci, putline + +begin + for (ip=1; str[ip] != EOS; ) { + if (ip > 1) + call putci (fd, '\n') + call putline (fd, " ") + for (iptop=ip+50; ip < iptop && str[ip] != EOS; ip=ip+1) { + ch = str[ip] + if (IS_CNTRL(ch)) { + if (stridx (ch, "\b\f\t\r\n") > 0) + call putcc (fd, ch) + else { + call putci (fd, '^') + call putci (fd, ch + 'A' - 1) + } + } else if (ch == FAKE_PADCHAR) { + call putci (fd, '.') + } else + call putc (fd, ch) + } + } + + if (ip < iptop) + call putci (fd, '\n') +end diff --git a/sys/vops/README b/sys/vops/README new file mode 100644 index 00000000..1e4c2cd0 --- /dev/null +++ b/sys/vops/README @@ -0,0 +1,10 @@ +VOPS -- Vector OPerators + +This directory contains the (generic) source for the vector operators (VOPS). +These generic procedures are expanded into a set of type specific procedures +by the GENERIC preprocessor, before compilation by XC. Documentation for +the vector operators and for the GENERIC preprocessor is in Vops.hlp. + +The subdirectory "achtgen" contains code for generalized datatype conversion +of vectors. The highest level routine, "acht" implements a full 9 by 9 +type conversion matrix (BUcsilrdx) (the BU are in OSB). diff --git a/sys/vops/aabs.gx b/sys/vops/aabs.gx new file mode 100644 index 00000000..54cbe197 --- /dev/null +++ b/sys/vops/aabs.gx @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AABS -- Compute the absolute value of a vector (generic). + +procedure aabs$t (a, b, npix) + +PIXEL a[ARB], b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = abs(a[i]) +end diff --git a/sys/vops/aadd.gx b/sys/vops/aadd.gx new file mode 100644 index 00000000..361afd6c --- /dev/null +++ b/sys/vops/aadd.gx @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AADD -- Add two vectors (generic). + +procedure aadd$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] + b[i] +end diff --git a/sys/vops/aaddk.gx b/sys/vops/aaddk.gx new file mode 100644 index 00000000..bd45782b --- /dev/null +++ b/sys/vops/aaddk.gx @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AADDK -- Add a constant to a vector (generic). + +procedure aaddk$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +PIXEL c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] + b +end diff --git a/sys/vops/aand.gx b/sys/vops/aand.gx new file mode 100644 index 00000000..e42d2d87 --- /dev/null +++ b/sys/vops/aand.gx @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AAND -- Compute the bitwise boolean 'and' of two vectors (generic). + +procedure aand$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB], c[ARB] +int npix, i +$if (datatype == i) +int and() +$else +PIXEL and$t() +$endif + +begin + do i = 1, npix { + $if (datatype == i) + c[i] = and (a[i], b[i]) + $else + c[i] = and$t (a[i], b[i]) + $endif + } +end diff --git a/sys/vops/aandk.gx b/sys/vops/aandk.gx new file mode 100644 index 00000000..bbb3b3b6 --- /dev/null +++ b/sys/vops/aandk.gx @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AANDK -- Compute the bitwise boolean 'and' of a vector and a constant +# (generic) + +procedure aandk$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +PIXEL c[ARB] +int npix, i +$if (datatype == i) +int and() +$else +PIXEL and$t() +$endif + +begin + do i = 1, npix { + $if (datatype == i) + c[i] = and (a[i], b) + $else + c[i] = and$t (a[i], b) + $endif + } +end diff --git a/sys/vops/aavg.gx b/sys/vops/aavg.gx new file mode 100644 index 00000000..8f90126d --- /dev/null +++ b/sys/vops/aavg.gx @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AAVG -- Compute the mean and standard deviation (sigma) of a sample. +# All pixels are used. + +procedure aavg$t (a, npix, mean, sigma) + +PIXEL a[ARB] +int npix +$if (datatype == dl) +double mean, sigma, lcut, hcut +$else +real mean, sigma, lcut, hcut +$endif +int junk, awvg$t() +data lcut /0./, hcut /0./ + +begin + junk = awvg$t (a, npix, mean, sigma, lcut, hcut) +end diff --git a/sys/vops/abav.gx b/sys/vops/abav.gx new file mode 100644 index 00000000..0f519216 --- /dev/null +++ b/sys/vops/abav.gx @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABAV -- Vector block average. Each pixel in the output vector is the +# average of the input vector over a block of pixels. The input vector must +# be at least (nblocks * npix_per_block) pixels in length. + +procedure abav$t (a, b, nblocks, npix_per_block) + +PIXEL a[ARB] # input vector +PIXEL b[nblocks] # output vector +int nblocks # number of blocks (pixels in output vector) +int npix_per_block # number of input pixels per block + +$if (datatype == cs) +long sum, width +$else $if (datatype == il) +real sum, width +$else +PIXEL sum, width +$endif $endif + +int i, j +int block_offset, next_block, block_length + +begin + block_offset = 1 + block_length = npix_per_block + $if (datatype != x) + width = block_length + $else + width = complex (block_length, block_length) + $endif + + if (block_length <= 1) + call amov$t (a[block_offset], b, nblocks) + else { + do j = 1, nblocks { + next_block = block_offset + block_length + sum = 0 + do i = block_offset, next_block - 1 + sum = sum + a[i] + b[j] = sum / width + block_offset = next_block + } + } +end diff --git a/sys/vops/abeq.gx b/sys/vops/abeq.gx new file mode 100644 index 00000000..35324f6a --- /dev/null +++ b/sys/vops/abeq.gx @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQ -- Vector boolean equals. C[i], type INT, is set to 1 if A[i] equals +# B[i], else C[i] is set to zero. + +procedure abeq$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] == b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/abeqk.gx b/sys/vops/abeqk.gx new file mode 100644 index 00000000..8f7a84aa --- /dev/null +++ b/sys/vops/abeqk.gx @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQK -- Vector boolean equals constant. C[i], type INT, is set to 1 if +# A[i] equals B, else C[i] is set to zero. + +procedure abeqk$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0$f) { + do i = 1, npix + if (a[i] == 0$f) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] == b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/abge.gx b/sys/vops/abge.gx new file mode 100644 index 00000000..76f842dc --- /dev/null +++ b/sys/vops/abge.gx @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGE -- Vector boolean greater than or equals. C[i], type INT, is set to 1 +# if A[i] is greater than B[i], else C[i] is set to zero. + +procedure abge$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + $if (datatype == x) + if (abs (a[i]) >= abs (b[i])) + $else + if (a[i] >= b[i]) + $endif + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/abgek.gx b/sys/vops/abgek.gx new file mode 100644 index 00000000..a9ad9340 --- /dev/null +++ b/sys/vops/abgek.gx @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGEK -- Vector boolean greater than or equals constant. C[i], type INT, +# is set to 1 if A[i] is greater than or equal to B, else C[i] is set to zero. + +procedure abgek$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +int c[ARB] +int npix +int i +$if (datatype == x) +real abs_b +$endif + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0$f) { + $if (datatype == x) + call amovki (1, c, npix) + $else + do i = 1, npix + if (a[i] >= 0) + c[i] = 1 + else + c[i] = 0 + $endif + } else { + $if (datatype == x) + abs_b = abs (b) + $endif + do i = 1, npix + $if (datatype == x) + if (abs (a[i]) >= abs_b) + $else + if (a[i] >= b) + $endif + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/abgt.gx b/sys/vops/abgt.gx new file mode 100644 index 00000000..80d7e81a --- /dev/null +++ b/sys/vops/abgt.gx @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGT -- Vector boolean greater than. C[i], type INT, is set to 1 if +# A[i] is greater than B[i], else C[i] is set to zero. + +procedure abgt$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + $if (datatype == x) + if (abs (a[i]) > abs (b[i])) + $else + if (a[i] > b[i]) + $endif + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/abgtk.gx b/sys/vops/abgtk.gx new file mode 100644 index 00000000..93be1524 --- /dev/null +++ b/sys/vops/abgtk.gx @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGTK -- Vector boolean greater than constant. C[i], type INT, is set to 1 +# if A[i] is greater than B, else C[i] is set to zero. + +procedure abgtk$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +int c[ARB] +int npix +int i +$if (datatype == x) +real abs_b +$endif + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0$f) { + do i = 1, npix + $if (datatype == x) + if (abs (a[i]) > 0) + $else + if (a[i] > 0) + $endif + c[i] = 1 + else + c[i] = 0 + } else { + $if (datatype == x) + abs_b = abs (b) + $endif + do i = 1, npix + $if (datatype == x) + if (abs (a[i]) > abs_b) + $else + if (a[i] > b) + $endif + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/able.gx b/sys/vops/able.gx new file mode 100644 index 00000000..27553959 --- /dev/null +++ b/sys/vops/able.gx @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLE -- Vector boolean less than or equals. C[i], type INT, is set to 1 if +# A[i] is less than or equal to B[i], else C[i] is set to zero. + +procedure able$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + $if (datatype == x) + if (abs (a[i]) <= abs (b[i])) + $else + if (a[i] <= b[i]) + $endif + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ablek.gx b/sys/vops/ablek.gx new file mode 100644 index 00000000..16a10d27 --- /dev/null +++ b/sys/vops/ablek.gx @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLEK -- Vector boolean less than or equals constant. C[i], type INT, +# is set to 1 if A[i] is less than or equal to B, else C[i] is set to zero. + +procedure ablek$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +int c[ARB] +int npix +int i +$if (datatype == x) +real abs_b +$endif + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0$f) { + do i = 1, npix + $if (datatype == x) + if (abs (a[i]) == 0) + $else + if (a[i] <= 0) + $endif + c[i] = 1 + else + c[i] = 0 + } else { + $if (datatype == x) + abs_b = abs (b) + $endif + do i = 1, npix + $if (datatype == x) + if (abs (a[i]) <= abs_b) + $else + if (a[i] <= b) + $endif + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ablt.gx b/sys/vops/ablt.gx new file mode 100644 index 00000000..212c891e --- /dev/null +++ b/sys/vops/ablt.gx @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLT -- Vector boolean less than. C[i], type INT, is set to 1 if +# A[i] is less than B[i], else C[i] is set to zero. + +procedure ablt$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + $if (datatype == x) + if (abs (a[i]) < abs (b[i])) + $else + if (a[i] < b[i]) + $endif + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/abltk.gx b/sys/vops/abltk.gx new file mode 100644 index 00000000..8d11cb09 --- /dev/null +++ b/sys/vops/abltk.gx @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLTK -- Vector boolean less than constant. C[i], type INT, is set to 1 if +# A[i] is less than B, else C[i] is set to zero. + +procedure abltk$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +int c[ARB] +int npix +int i +$if (datatype == x) +real abs_b +$endif + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0$f) { + $if (datatype == x) + call aclri (c, npix) + $else + do i = 1, npix + if (a[i] < 0) + c[i] = 1 + else + c[i] = 0 + $endif + } else { + $if (datatype == x) + abs_b = abs (b) + $endif + do i = 1, npix + $if (datatype == x) + if (abs (a[i]) < abs_b) + $else + if (a[i] < b) + $endif + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/abne.gx b/sys/vops/abne.gx new file mode 100644 index 00000000..6cc4513e --- /dev/null +++ b/sys/vops/abne.gx @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNE -- Vector boolean not equals. C[i], type INT, is set to 1 if +# A[i] is not equal to B[i], else C[i] is set to zero. + +procedure abne$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/abnek.gx b/sys/vops/abnek.gx new file mode 100644 index 00000000..4643cd89 --- /dev/null +++ b/sys/vops/abnek.gx @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNEK -- Vector boolean not equals constant. C[i], type INT, is set to 1 if +# A[i] is not equal to B, else C[i] is set to zero. + +procedure abnek$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0$f) { + do i = 1, npix + if (a[i] != 0$f) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] != b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/abor.gx b/sys/vops/abor.gx new file mode 100644 index 00000000..6dcea5d9 --- /dev/null +++ b/sys/vops/abor.gx @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABOR -- Compute the bitwise boolean 'or' of two vectors (generic). + +procedure abor$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB], c[ARB] +int npix, i +$if (datatype == i) +int or() +$else +PIXEL or$t() +$endif + +begin + do i = 1, npix { + $if (datatype == i) + c[i] = or (a[i], b[i]) + $else + c[i] = or$t (a[i], b[i]) + $endif + } +end diff --git a/sys/vops/abork.gx b/sys/vops/abork.gx new file mode 100644 index 00000000..0c1e5416 --- /dev/null +++ b/sys/vops/abork.gx @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABORK -- Compute the bitwise boolean or of a vector and a constant +# (generic). + +procedure abork$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +PIXEL c[ARB] +int npix, i +$if (datatype == i) +int or() +$else +PIXEL or$t() +$endif + +begin + do i = 1, npix { + $if (datatype == i) + c[i] = or (a[i], b) + $else + c[i] = or$t (a[i], b) + $endif + } +end diff --git a/sys/vops/absu.gx b/sys/vops/absu.gx new file mode 100644 index 00000000..6601daae --- /dev/null +++ b/sys/vops/absu.gx @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABSU -- Vector block sum. Each pixel in the output vector is the +# sum of the input vector over a block of pixels. The input vector must +# be at least (nblocks * npix_per_block) pixels in length. + +procedure absu$t (a, b, nblocks, npix_per_block) + +PIXEL a[ARB] # input vector +PIXEL b[nblocks] # output vector +int nblocks # number of blocks (pixels in output vector) +int npix_per_block # number of input pixels per block + +$if (datatype == cs) +long sum +$else $if (datatype == il) +real sum +$else +PIXEL sum +$endif $endif + +int i, j +int block_offset, next_block, block_length + +begin + block_offset = 1 + block_length = npix_per_block + + if (block_length <= 1) + call amov$t (a[block_offset], b, nblocks) + else { + do j = 1, nblocks { + next_block = block_offset + block_length + sum = 0 + do i = block_offset, next_block - 1 + sum = sum + a[i] + b[j] = sum + block_offset = next_block + } + } +end diff --git a/sys/vops/acht.gx b/sys/vops/acht.gx new file mode 100644 index 00000000..e1ad83f4 --- /dev/null +++ b/sys/vops/acht.gx @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure acht$t$$t (a, b, npix) + +PIXEL a[ARB] +$PIXEL b[ARB] +int npix +$$if (datatype != $t) +int i +$$endif + +begin + $$if (datatype == $t) + call amov$t (a, b, npix) + $$else + $$if (sizeof(t) <= sizeof($t)) + do i = 1, npix + $$if (datatype == x) + b[i] = complex(real(a[i]),0.0) + $$else + b[i] = a[i] + $$endif + $$else + do i = npix, 1, -1 + $$if (datatype == x) + b[i] = complex(real(a[i]),0.0) + $$else + b[i] = a[i] + $$endif + $$endif + $$endif +end diff --git a/sys/vops/achtgen/acht.x b/sys/vops/achtgen/acht.x new file mode 100644 index 00000000..ae67ceae --- /dev/null +++ b/sys/vops/achtgen/acht.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHT -- General data type conversion based on the generic routines +# The data types are BUcsilrdx. + +procedure acht (a, b, nelem, ty_a, ty_b) + +char a[ARB], b[ARB] +int ty_a, ty_b, nelem + +begin + switch (ty_a) { + case TY_UBYTE: + call achtb (a, b, nelem, ty_b) + case TY_USHORT: + call achtu (a, b, nelem, ty_b) + case TY_CHAR: + call achtc (a, b, nelem, ty_b) + case TY_SHORT: + call achts (a, b, nelem, ty_b) + case TY_INT, TY_POINTER, TY_STRUCT: + call achti (a, b, nelem, ty_b) + case TY_LONG: + call achtl (a, b, nelem, ty_b) + case TY_REAL: + call achtr (a, b, nelem, ty_b) + case TY_DOUBLE: + call achtd (a, b, nelem, ty_b) + case TY_COMPLEX: + call achtx (a, b, nelem, ty_b) + } +end diff --git a/sys/vops/achtgen/achtb.x b/sys/vops/achtgen/achtb.x new file mode 100644 index 00000000..0d8cb8a7 --- /dev/null +++ b/sys/vops/achtgen/achtb.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHT_ -- Convert an array of type _ to some other datatype. +# Data types are BUcsilrdx. + +procedure achtb (a, b, nelem, ty_b) + +char a[ARB] +char b[ARB] +int nelem +int ty_b + +begin + switch (ty_b) { + case TY_UBYTE: + call achtbb (a, b, nelem) + case TY_USHORT: + call achtbu (a, b, nelem) + case TY_CHAR: + call achtbc (a, b, nelem) + case TY_SHORT: + call achtbs (a, b, nelem) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtbi (a, b, nelem) + case TY_LONG: + call achtbl (a, b, nelem) + case TY_REAL: + call achtbr (a, b, nelem) + case TY_DOUBLE: + call achtbd (a, b, nelem) + case TY_COMPLEX: + call achtbx (a, b, nelem) + } +end diff --git a/sys/vops/achtgen/achtc.x b/sys/vops/achtgen/achtc.x new file mode 100644 index 00000000..370a0174 --- /dev/null +++ b/sys/vops/achtgen/achtc.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHT_ -- Convert an array of type _ to some other datatype. +# Data types are BUcsilrdx. + +procedure achtc (a, b, nelem, ty_b) + +char a[ARB] +char b[ARB] +int nelem +int ty_b + +begin + switch (ty_b) { + case TY_UBYTE: + call achtcb (a, b, nelem) + case TY_USHORT: + call achtcu (a, b, nelem) + case TY_CHAR: + call achtcc (a, b, nelem) + case TY_SHORT: + call achtcs (a, b, nelem) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtci (a, b, nelem) + case TY_LONG: + call achtcl (a, b, nelem) + case TY_REAL: + call achtcr (a, b, nelem) + case TY_DOUBLE: + call achtcd (a, b, nelem) + case TY_COMPLEX: + call achtcx (a, b, nelem) + } +end diff --git a/sys/vops/achtgen/achtd.x b/sys/vops/achtgen/achtd.x new file mode 100644 index 00000000..6f784749 --- /dev/null +++ b/sys/vops/achtgen/achtd.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHT_ -- Convert an array of type _ to some other datatype. +# Data types are BUcsilrdx. + +procedure achtd (a, b, nelem, ty_b) + +double a[ARB] +char b[ARB] +int nelem +int ty_b + +begin + switch (ty_b) { + case TY_UBYTE: + call achtdb (a, b, nelem) + case TY_USHORT: + call achtdu (a, b, nelem) + case TY_CHAR: + call achtdc (a, b, nelem) + case TY_SHORT: + call achtds (a, b, nelem) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtdi (a, b, nelem) + case TY_LONG: + call achtdl (a, b, nelem) + case TY_REAL: + call achtdr (a, b, nelem) + case TY_DOUBLE: + call achtdd (a, b, nelem) + case TY_COMPLEX: + call achtdx (a, b, nelem) + } +end diff --git a/sys/vops/achtgen/achti.x b/sys/vops/achtgen/achti.x new file mode 100644 index 00000000..49df790e --- /dev/null +++ b/sys/vops/achtgen/achti.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHT_ -- Convert an array of type _ to some other datatype. +# Data types are BUcsilrdx. + +procedure achti (a, b, nelem, ty_b) + +int a[ARB] +char b[ARB] +int nelem +int ty_b + +begin + switch (ty_b) { + case TY_UBYTE: + call achtib (a, b, nelem) + case TY_USHORT: + call achtiu (a, b, nelem) + case TY_CHAR: + call achtic (a, b, nelem) + case TY_SHORT: + call achtis (a, b, nelem) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtii (a, b, nelem) + case TY_LONG: + call achtil (a, b, nelem) + case TY_REAL: + call achtir (a, b, nelem) + case TY_DOUBLE: + call achtid (a, b, nelem) + case TY_COMPLEX: + call achtix (a, b, nelem) + } +end diff --git a/sys/vops/achtgen/achtl.x b/sys/vops/achtgen/achtl.x new file mode 100644 index 00000000..bf9cc0fa --- /dev/null +++ b/sys/vops/achtgen/achtl.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHT_ -- Convert an array of type _ to some other datatype. +# Data types are BUcsilrdx. + +procedure achtl (a, b, nelem, ty_b) + +long a[ARB] +char b[ARB] +int nelem +int ty_b + +begin + switch (ty_b) { + case TY_UBYTE: + call achtlb (a, b, nelem) + case TY_USHORT: + call achtlu (a, b, nelem) + case TY_CHAR: + call achtlc (a, b, nelem) + case TY_SHORT: + call achtls (a, b, nelem) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtli (a, b, nelem) + case TY_LONG: + call achtll (a, b, nelem) + case TY_REAL: + call achtlr (a, b, nelem) + case TY_DOUBLE: + call achtld (a, b, nelem) + case TY_COMPLEX: + call achtlx (a, b, nelem) + } +end diff --git a/sys/vops/achtgen/achtr.x b/sys/vops/achtgen/achtr.x new file mode 100644 index 00000000..add1fdf4 --- /dev/null +++ b/sys/vops/achtgen/achtr.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHT_ -- Convert an array of type _ to some other datatype. +# Data types are BUcsilrdx. + +procedure achtr (a, b, nelem, ty_b) + +real a[ARB] +char b[ARB] +int nelem +int ty_b + +begin + switch (ty_b) { + case TY_UBYTE: + call achtrb (a, b, nelem) + case TY_USHORT: + call achtru (a, b, nelem) + case TY_CHAR: + call achtrc (a, b, nelem) + case TY_SHORT: + call achtrs (a, b, nelem) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtri (a, b, nelem) + case TY_LONG: + call achtrl (a, b, nelem) + case TY_REAL: + call achtrr (a, b, nelem) + case TY_DOUBLE: + call achtrd (a, b, nelem) + case TY_COMPLEX: + call achtrx (a, b, nelem) + } +end diff --git a/sys/vops/achtgen/achts.x b/sys/vops/achtgen/achts.x new file mode 100644 index 00000000..c0aa0026 --- /dev/null +++ b/sys/vops/achtgen/achts.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHT_ -- Convert an array of type _ to some other datatype. +# Data types are BUcsilrdx. + +procedure achts (a, b, nelem, ty_b) + +short a[ARB] +char b[ARB] +int nelem +int ty_b + +begin + switch (ty_b) { + case TY_UBYTE: + call achtsb (a, b, nelem) + case TY_USHORT: + call achtsu (a, b, nelem) + case TY_CHAR: + call achtsc (a, b, nelem) + case TY_SHORT: + call achtss (a, b, nelem) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtsi (a, b, nelem) + case TY_LONG: + call achtsl (a, b, nelem) + case TY_REAL: + call achtsr (a, b, nelem) + case TY_DOUBLE: + call achtsd (a, b, nelem) + case TY_COMPLEX: + call achtsx (a, b, nelem) + } +end diff --git a/sys/vops/achtgen/achtu.x b/sys/vops/achtgen/achtu.x new file mode 100644 index 00000000..5edffe96 --- /dev/null +++ b/sys/vops/achtgen/achtu.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHT_ -- Convert an array of type _ to some other datatype. +# Data types are BUcsilrdx. + +procedure achtu (a, b, nelem, ty_b) + +short a[ARB] +char b[ARB] +int nelem +int ty_b + +begin + switch (ty_b) { + case TY_UBYTE: + call achtub (a, b, nelem) + case TY_USHORT: + call achtuu (a, b, nelem) + case TY_CHAR: + call achtuc (a, b, nelem) + case TY_SHORT: + call achtus (a, b, nelem) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtui (a, b, nelem) + case TY_LONG: + call achtul (a, b, nelem) + case TY_REAL: + call achtur (a, b, nelem) + case TY_DOUBLE: + call achtud (a, b, nelem) + case TY_COMPLEX: + call achtux (a, b, nelem) + } +end diff --git a/sys/vops/achtgen/achtx.x b/sys/vops/achtgen/achtx.x new file mode 100644 index 00000000..c0d8e04d --- /dev/null +++ b/sys/vops/achtgen/achtx.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHT_ -- Convert an array of type _ to some other datatype. +# Data types are BUcsilrdx. + +procedure achtx (a, b, nelem, ty_b) + +complex a[ARB] +char b[ARB] +int nelem +int ty_b + +begin + switch (ty_b) { + case TY_UBYTE: + call achtxb (a, b, nelem) + case TY_USHORT: + call achtxu (a, b, nelem) + case TY_CHAR: + call achtxc (a, b, nelem) + case TY_SHORT: + call achtxs (a, b, nelem) + case TY_INT, TY_POINTER, TY_STRUCT: + call achtxi (a, b, nelem) + case TY_LONG: + call achtxl (a, b, nelem) + case TY_REAL: + call achtxr (a, b, nelem) + case TY_DOUBLE: + call achtxd (a, b, nelem) + case TY_COMPLEX: + call achtxx (a, b, nelem) + } +end diff --git a/sys/vops/achtgen/mkpkg b/sys/vops/achtgen/mkpkg new file mode 100644 index 00000000..48b7c157 --- /dev/null +++ b/sys/vops/achtgen/mkpkg @@ -0,0 +1,25 @@ +# The files in this directory are the higher level type conversion routines. +# The most general routine is ACHT, which can convert an array of any of the +# nine datatypes UBcsilrdx to any of the other types (it will cause 100 +# additional subroutines to be linked). One level down in the structure tree +# are the ACHTx routines, which will convert an array of type X to any other +# type. At the bottom are the ACHTxy routines, which convert from type X +# to type Y; these procedures are in vops$ak and osb$. + +$checkout libvops.a lib$ +$update libvops.a +$checkin libvops.a lib$ +$exit + +libvops.a: + acht.x + achtb.x + achtc.x + achtd.x + achti.x + achtl.x + achtr.x + achts.x + achtu.x + achtx.x + ; diff --git a/sys/vops/acjgx.x b/sys/vops/acjgx.x new file mode 100644 index 00000000..1fc9f944 --- /dev/null +++ b/sys/vops/acjgx.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACJGX -- Complex conjugate of a complex vector. + +procedure acjgx (a, b, npix) + +complex a[ARB], b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = conjg (a[i]) +end diff --git a/sys/vops/aclr.gx b/sys/vops/aclr.gx new file mode 100644 index 00000000..f3415353 --- /dev/null +++ b/sys/vops/aclr.gx @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACLR -- Zero a vector (generic). + +procedure aclr$t (a, npix) + +PIXEL a[ARB] +int npix, i + +begin + do i = 1, npix + a[i] = 0$f +end diff --git a/sys/vops/acnv.gx b/sys/vops/acnv.gx new file mode 100644 index 00000000..4d729126 --- /dev/null +++ b/sys/vops/acnv.gx @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACNV -- Vector convolution. The output vector is equal to the sum of its +# initial value and the convolution of the input vector with the kernel. +# This routine assumes boundary extension on the input vector has been provided. +# For short kernels, we unroll the inner do loop into a single statement to +# reduce loop overhead. +# +# Example: npix=10, kpix=5, 2 pixels out of bounds on either end. +# in[1] corresponds to x = -1 +# +# -1 0 1 2 3 4 5 6 7 8 9 10 11 12 (x coord) +# 1 2 3 4 5 +# 1 2 3 4 5 +# ... +# 1 2 3 4 5 + +procedure acnv$t (in, out, npix, kernel, knpix) + +PIXEL in[npix+knpix-1] # input vector, including boundary pixels +PIXEL out[ARB] # output vector +int npix # length of output vector +PIXEL kernel[knpix] # convolution kernel +int knpix # size of convolution kernel + +int i, j +PIXEL sum, k1, k2, k3, k4, k5 + +begin + switch (knpix) { + case 3: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + case 5: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + k4 = kernel[4] + k5 = kernel[5] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + + k4 * in[i+3] + k5 * in[i+4] + default: + do i = 1, npix { + sum = out[i] + do j = 1, knpix + sum = sum + (kernel[j] * in[i+j-1]) + out[i] = sum + } + } +end diff --git a/sys/vops/acnvr.gx b/sys/vops/acnvr.gx new file mode 100644 index 00000000..753b3de2 --- /dev/null +++ b/sys/vops/acnvr.gx @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACNVR -- Vector convolution with a real kernel. The output vector is equal +# to the sum of its initial value and the convolution of the input vector with +# the kernel. This routine assumes boundary extension on the input vector has +# been provided. +# +# Example: npix=10, kpix=5, 2 pixels out of bounds on either end. +# in[1] corresponds to x = -1 +# +# -1 0 1 2 3 4 5 6 7 8 9 10 11 12 (x coord) +# 1 2 3 4 5 +# 1 2 3 4 5 +# ... +# 1 2 3 4 5 +# +# See also acnv_, if the kernel is the same datatype as the data vectors. + +procedure acnvr$t (in, out, npix, kernel, knpix) + +PIXEL in[npix+knpix-1] # input vector, including boundary pixels +PIXEL out[ARB] # output vector +int npix # length of output vector +real kernel[knpix] # convolution kernel, always type real +int knpix # size of convolution kernel + +int i, j +real sum, k1, k2, k3, k4, k5 + +begin + switch (knpix) { + case 3: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + case 5: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + k4 = kernel[4] + k5 = kernel[5] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + + k4 * in[i+3] + k5 * in[i+4] + default: + do i = 1, npix { + sum = out[i] + do j = 1, knpix + sum = sum + (kernel[j] * in[i+j-1]) + out[i] = sum + } + } +end diff --git a/sys/vops/adiv.gx b/sys/vops/adiv.gx new file mode 100644 index 00000000..6b8b4cae --- /dev/null +++ b/sys/vops/adiv.gx @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADIV -- Divide two vectors (generic). No divide by zero checking is +# performed. If this is desired, advz should be used instead. + +procedure adiv$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] / b[i] +end diff --git a/sys/vops/adivk.gx b/sys/vops/adivk.gx new file mode 100644 index 00000000..a16d0cac --- /dev/null +++ b/sys/vops/adivk.gx @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADIVK -- Divide a vector by a constant (generic). No divide by zero checking +# is performed. + +procedure adivk$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +PIXEL c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] / b +end diff --git a/sys/vops/adot.gx b/sys/vops/adot.gx new file mode 100644 index 00000000..baadd952 --- /dev/null +++ b/sys/vops/adot.gx @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADOT -- Vector inner or dot product. The function value is the sum of the +# products of each pair of elements of the input vectors. + +$if (datatype == ld) +double procedure adot$t (a, b, npix) +$else +real procedure adot$t (a, b, npix) +$endif + +PIXEL a[ARB], b[ARB] + +$if (datatype == ld) +double sum +$else +real sum +$endif + +int npix, i + +begin + sum = 0$f + do i = 1, npix + sum = sum + a[i] * b[i] + + return (sum) +end diff --git a/sys/vops/advz.gx b/sys/vops/advz.gx new file mode 100644 index 00000000..b4bffd80 --- /dev/null +++ b/sys/vops/advz.gx @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADVZ -- Vector divide with checking for zero divisors. If the result of a +# divide would be undefined a user supplied function is called to get the +# output pixel value. +# +# NOTE: in the interests of simplicity a somewhat arbitrary tolerance is used +# to check for an undefined divide, i.e., a divide by zero or a divide by a +# number small enough to cause floating point overflow. A better way to do +# this would be to provide a machine dependent version of this operator in +# host$as which catches the hardware exception rather than using a comparison. + +procedure advz$t (a, b, c, npix, errfcn) + +PIXEL a[ARB], b[ARB], c[ARB] # numerator, divisor, and output arrays +int npix # number of pixels +PIXEL errfcn() # user function, called on divide by zero + +int i +PIXEL divisor +$if (datatype == rd) +PIXEL tol +$endif +extern errfcn() +errchk errfcn + +begin + $if (datatype == r) + tol = 1.0E-20 + $else $if (datatype == d) + tol = 1.0D-20 + $endif $endif + + do i = 1, npix { + divisor = b[i] + $if (datatype == rd) + # The following is most efficient when the data tends to be + # positive. + + if (divisor < tol) + if (divisor > -tol) { + c[i] = errfcn (a[i]) + next + } + c[i] = a[i] / divisor + + $else + if (divisor == 0$f) + c[i] = errfcn (a[i]) + else + c[i] = a[i] / divisor + $endif + } +end diff --git a/sys/vops/aexp.gx b/sys/vops/aexp.gx new file mode 100644 index 00000000..f631e7df --- /dev/null +++ b/sys/vops/aexp.gx @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AEXP -- Compute a ** b, where b is of type PIXEL (generic). + +procedure aexp$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b[i] +end diff --git a/sys/vops/aexpk.gx b/sys/vops/aexpk.gx new file mode 100644 index 00000000..9bd5a58c --- /dev/null +++ b/sys/vops/aexpk.gx @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AEXPK -- Compute a ** b, where b is a constant of type PIXEL (generic). + +procedure aexpk$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +PIXEL c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b +end diff --git a/sys/vops/afftrr.x b/sys/vops/afftrr.x new file mode 100644 index 00000000..024f4456 --- /dev/null +++ b/sys/vops/afftrr.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AFFTRR -- Forward fourier transform (real transform, real output arrays). +# The forward transform of the real array SR length NPIX is computed and +# returned in the real arrays FR and FI of length NPIX/2+1. Since the real +# transform is being performed the array SI is ignored and may be omitted. +# The transformation may be performed in place if desired. NPIX must be a +# power of 2. + +procedure afftrr (sr, si, fr, fi, npix) + +real sr[ARB], si[ARB] # spatial data (input). SI NOT USED. +real fr[ARB], fi[ARB] # real and imag parts of transform (output) +int npix +int ier +pointer sp, work + +begin + call smark (sp) + call salloc (work, npix + 2, TY_REAL) + + # Copy the real data vector into the work array. + call amovr (sr, Memr[work], npix) + + # Compute the forward transform. + call ffa (Memr[work], npix, ier) + if (ier == 1) + call fatal (1, "afftrr: npix not a power of 2") + + # Unpack the real and imaginary parts into the output arrays. + call aupxr (Memr[work], fr, fi, npix / 2 + 1) + + call sfree (sp) +end diff --git a/sys/vops/afftrx.x b/sys/vops/afftrx.x new file mode 100644 index 00000000..ec43b16a --- /dev/null +++ b/sys/vops/afftrx.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AFFTRX -- Forward fourier transform (real transform, complex output). +# The fourier transform of the real array A of length NPIX pixels is computed +# and the NPIX/2+1 complex transform coefficients are returned in the complex +# array B. The first element of array B upon output contains the dc term at +# zero frequency, and the remaining elements contain the real and imaginary +# components of the harmonics. The transformation may be performed in place +# if desired. NPIX must be a power of 2. +# +# N.B.: The Fortran 77 standard guarantees that a complex datum is represented +# as two reals, and that the first real in storage order is the real part of +# the complex datum and the second real the imaginary part. We have defined +# B to be a type COMPLEX array in the calling program, but FFA expects a +# REAL array containing (real,imag) pairs. The Fortran standard appears to +# guarantee that this will work. + +procedure afftrx (a, b, npix) + +real a[ARB] # data (input) +complex b[ARB] # transform (output). Dim npix/2+1 +int npix +int ier + +begin + # The following is a no-op if A and B are the same array. + call amovr (a, b, npix) + + # Compute the forward real transform. + call ffa (b, npix, ier) + if (ier == 1) + call fatal (1, "afftrx: npix not a power of 2") +end diff --git a/sys/vops/afftxr.x b/sys/vops/afftxr.x new file mode 100644 index 00000000..b09ae0f5 --- /dev/null +++ b/sys/vops/afftxr.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AFFTXR -- Forward fourier transform (complex transform, real arrays). +# The fourier transform of the real arrays SR and SI containing complex data +# pairs is computed and the complex transform coefficients are returned in +# the real arrays FR and FI. The transformation may be performed in place if +# desired. NPIX must be a power of 2. + +procedure afftxr (sr, si, fr, fi, npix) + +real sr[ARB], si[ARB] # data, spatial domain (input) +real fr[ARB], fi[ARB] # transform, frequency domain (output) +int npix +int ier + +begin + # The following are no-ops if the transform is being performed + # in place. + + call amovr (sr, fr, npix) + call amovr (si, fi, npix) + + # Compute the forward transform. + call fft842 (0, npix, fr, fi, ier) + if (ier == 1) + call fatal (1, "afftxr: npix not a power of 2") +end diff --git a/sys/vops/afftxx.x b/sys/vops/afftxx.x new file mode 100644 index 00000000..34eedbf9 --- /dev/null +++ b/sys/vops/afftxx.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AFFTXX -- Forward fourier transform (complex transform, complex data). +# The fourier transform of the complex array A of length NPIX pixels is +# computed and the NPIX complex transform coefficients are returned in the +# complex array B. The transformation may be performed in place if desired. +# NPIX must be a power of 2. + +procedure afftxx (a, b, npix) + +complex a[ARB] # data (input) +complex b[ARB] # transform (output) +int npix + +int ier +pointer sp, xr, xi + +begin + call smark (sp) + call salloc (xr, npix, TY_REAL) + call salloc (xi, npix, TY_REAL) + + # Rearrange the elements of the A array as required by FFT842. + # Convert the array A of complex values into an array of reals + # and an array of imaginaries. + + call aupxr (a, Memr[xr], Memr[xi], npix) + + # Compute the forward transform. + call fft842 (0, npix, Memr[xr], Memr[xi], ier) + if (ier == 1) + call fatal (1, "afftxx: npix not a power of 2") + + # Repack the real and imaginary arrays to form the complex output + # array. + call apkxr (Memr[xr], Memr[xi], b, npix) + + call sfree (sp) +end diff --git a/sys/vops/aglt.gx b/sys/vops/aglt.gx new file mode 100644 index 00000000..54f6ee2f --- /dev/null +++ b/sys/vops/aglt.gx @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AGLT -- Given a list of ranges, replace the value of each input pixel +# which falls within a given range by applying the corresponding linear +# transformation (b = a * kmul + kadd). If KMUL is identically zero, +# B is replaced by the constant KADD. + +procedure aglt$t (a, b, npix, low, high, kmul, kadd, nrange) + +PIXEL a[ARB], b[ARB], pixval +int npix, i +PIXEL low[nrange], high[nrange] # range limits +$if (datatype == dl) +double kmul[nrange], kadd[nrange] # linear transformation +$else +real kmul[nrange], kadd[nrange] +$endif +$if (datatype == x) +real abs_pixval +$endif +int nrange, nr + +begin + do i = 1, npix { + pixval = a[i] + b[i] = pixval + $if (datatype == x) + abs_pixval = abs (pixval) + $endif + do nr = 1, nrange + $if (datatype == x) + if (abs_pixval >= abs (low[nr]) && + abs_pixval <= abs (high[nr])) { + $else + if (pixval >= low[nr] && pixval <= high[nr]) { + $endif + $if (datatype == dl) + if (kmul[nr] == 0.0D0) + $else + if (kmul[nr] == 0.0) + $endif + b[i] = kadd[nr] + else + b[i] = (pixval * kmul[nr]) + kadd[nr] + break + } + } +end diff --git a/sys/vops/ahgm.gx b/sys/vops/ahgm.gx new file mode 100644 index 00000000..02e21c07 --- /dev/null +++ b/sys/vops/ahgm.gx @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# AHGM -- Accumulate the histogram of the input vector. The output vector +# HGM (the histogram) should be cleared prior to the first call. + +procedure ahgm$t (data, npix, hgm, nbins, z1, z2) + +PIXEL data[ARB] # data vector +int npix # number of pixels +int hgm[ARB] # output histogram +int nbins # number of bins in histogram +PIXEL z1, z2 # greyscale values of first and last bins + +PIXEL z +real dz +int bin, i + +begin + dz = real (nbins - 1) / real (z2 - z1) + if (abs (dz - 1.0) < (EPSILONR * 2.0)) { + do i = 1, npix { + z = data[i] + if (z >= z1 && z <= z2) { + bin = int (z - z1) + 1 + hgm[bin] = hgm[bin] + 1 + } + } + } else { + do i = 1, npix { + z = data[i] + if (z >= z1 && z <= z2) { + bin = int ((z - z1) * dz) + 1 + hgm[bin] = hgm[bin] + 1 + } + } + } +end diff --git a/sys/vops/ahiv.gx b/sys/vops/ahiv.gx new file mode 100644 index 00000000..ba6d487a --- /dev/null +++ b/sys/vops/ahiv.gx @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AHIV -- Compute the high value (maximum) of a vector. + +PIXEL procedure ahiv$t (a, npix) + +PIXEL a[ARB] +int npix +PIXEL high, pixval +$if (datatype == x) +real abs_high +$endif +int i + +begin + high = a[1] + $if (datatype == x) + abs_high = abs (high) + $endif + + do i = 1, npix { + pixval = a[i] + $if (datatype == x) + if (abs (pixval) > abs_high) { + high = pixval + abs_high = abs (high) + } + $else + if (pixval > high) + high = pixval + $endif + } + + return (high) +end diff --git a/sys/vops/aiftrr.x b/sys/vops/aiftrr.x new file mode 100644 index 00000000..96789581 --- /dev/null +++ b/sys/vops/aiftrr.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AIFTRR -- Inverse fourier transform (real transform, real output arrays). +# The inverse transform of the real arrays FR and FI of length NPIX/2+1 is +# returned in the real array SR of length NPIX. Since the real inverse +# transform is being performed the array SI is ignored and may be omitted. +# The transformation may be performed in place if desired. NPIX must be a +# power of 2. + +procedure aiftrr (fr, fi, sr, si, npix) + +real fr[ARB], fi[ARB] # real and imag parts of transform (input) +real sr[ARB], si[ARB] # spatial data (output). SI NOT USED. +int npix +int ier +pointer sp, work + +begin + call smark (sp) + call salloc (work, npix + 2, TY_REAL) + + # Pack the real and imaginary parts into a complex array as required + # by FFS. + call apkxr (fr, fi, Memr[work], npix / 2 + 1) + + # Compute the inverse transform. + call ffs (Memr[work], npix, ier) + if (ier == 1) + call fatal (1, "aiftrr: npix not a power of 2") + + # The work array now contains the real part of the transform; merely + # copy it to the output array. + call amovr (Memr[work], sr, npix) + + call sfree (sp) +end diff --git a/sys/vops/aiftrx.x b/sys/vops/aiftrx.x new file mode 100644 index 00000000..63a9d53d --- /dev/null +++ b/sys/vops/aiftrx.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AIFTRX -- Inverse discreet fourier transform (real transform, complex data +# array in). The input array A of length NPIX/2+1 contains the DC term and +# the NPIX/2 (real,imag) pairs for each of the NPIX/2 harmonics of the real +# transform. Upon output array B contains the NPIX real data pixels from the +# inverse transform. The transform may be performed in place if desired. +# +# N.B.: The Fortran 77 standard guarantees that a complex datum is represented +# as two reals, and that the first real in storage order is the real part of +# the complex datum and the second real the imaginary part. We have defined +# B to be a type COMPLEX array in the calling program, but FFS expects a +# REAL array containing (real,imag) pairs. The Fortran standard appears to +# guarantee that this will work. + +procedure aiftrx (a, b, npix) + +complex a[ARB] # transform, npix/2+1 elements +real b[ARB] # output data array +int npix +int ier + +begin + # The following is a no-op if A and B are the same array. + call amovx (a, b, npix / 2 + 1) + + # Compute the inverse real transform. + call ffs (b, npix, ier) + if (ier == 1) + call fatal (1, "afftrx: npix not a power of 2") +end diff --git a/sys/vops/aiftxr.x b/sys/vops/aiftxr.x new file mode 100644 index 00000000..a9647e7c --- /dev/null +++ b/sys/vops/aiftxr.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AIFTXR -- Inverse fourier transform (complex transform, real arrays). +# The inverse transform of the real arrays FR and FI containing complex data +# pairs is computed and the complex spatial data coefficients are returned in +# the real arrays SR and SI. The transformation may be performed in place if +# desired. NPIX must be a power of 2. + +procedure aiftxr (fr, fi, sr, si, npix) + +real fr[ARB], fi[ARB] # transform, frequency domain (input) +real sr[ARB], si[ARB] # data, spatial domain (output) +int npix +int ier + +begin + # The following are no-ops if the transform is being performed + # in place. + + call amovr (fr, sr, npix) + call amovr (fi, si, npix) + + # Compute the inverse transform. + call fft842 (1, npix, sr, si, ier) + if (ier == 1) + call fatal (1, "afftxr: npix not a power of 2") +end diff --git a/sys/vops/aiftxx.x b/sys/vops/aiftxx.x new file mode 100644 index 00000000..2871590f --- /dev/null +++ b/sys/vops/aiftxx.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AIFTXX -- Inverse fourier transform (complex transform, complex array). +# The fourier transform of the complex array A of length NPIX pixels is +# computed and the NPIX complex data points are returned in the complex array +# B. The transformation may be performed in place if desired. NPIX must be +# a power of 2. +# +# N.B.: The Fortran 77 standard guarantees that a complex datum is represented +# as two reals, and that the first real in storage order is the real part of +# the complex datum and the second real the imaginary part. We have defined +# A and B to be type COMPLEX arrays in the calling program, but FFT842 expects +# a REAL array containing (real,imag) pairs. The Fortran standard appears to +# guarantee that this will work. + +procedure aiftxx (a, b, npix) + +complex a[ARB] # transform (input) +complex b[ARB] # data (output) +int npix +int ier +pointer sp, xr, xi + +begin + call smark (sp) + call salloc (xr, npix, TY_REAL) + call salloc (xi, npix, TY_REAL) + + # Rearrange the elements of the A array as required by FFT842. + # Convert the array A of complex values into an array of reals + # and an array of imaginaries. + + call aupxr (a, Memr[xr], Memr[xi], npix) + + # Compute the inverse transform. + call fft842 (1, npix, Memr[xr], Memr[xi], ier) + if (ier == 1) + call fatal (1, "afftxx: npix not a power of 2") + + # Repack the real and imaginary arrays to form the complex output + # array. + call apkxr (Memr[xr], Memr[xi], b, npix) + + call sfree (sp) +end diff --git a/sys/vops/aimg.gx b/sys/vops/aimg.gx new file mode 100644 index 00000000..3ba682fe --- /dev/null +++ b/sys/vops/aimg.gx @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AIMG -- Return the imaginary part of a COMPLEX vector. + +procedure aimg$t (a, b, npix) + +complex a[ARB] +PIXEL b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = aimag (a[i]) +end diff --git a/sys/vops/ak/aabsd.x b/sys/vops/ak/aabsd.x new file mode 100644 index 00000000..d9a85b4a --- /dev/null +++ b/sys/vops/ak/aabsd.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AABS -- Compute the absolute value of a vector (generic). + +procedure aabsd (a, b, npix) + +double a[ARB], b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = abs(a[i]) +end diff --git a/sys/vops/ak/aabsi.x b/sys/vops/ak/aabsi.x new file mode 100644 index 00000000..b1c677aa --- /dev/null +++ b/sys/vops/ak/aabsi.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AABS -- Compute the absolute value of a vector (generic). + +procedure aabsi (a, b, npix) + +int a[ARB], b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = abs(a[i]) +end diff --git a/sys/vops/ak/aabsl.x b/sys/vops/ak/aabsl.x new file mode 100644 index 00000000..27543118 --- /dev/null +++ b/sys/vops/ak/aabsl.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AABS -- Compute the absolute value of a vector (generic). + +procedure aabsl (a, b, npix) + +long a[ARB], b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = abs(a[i]) +end diff --git a/sys/vops/ak/aabsr.x b/sys/vops/ak/aabsr.x new file mode 100644 index 00000000..824e77d5 --- /dev/null +++ b/sys/vops/ak/aabsr.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AABS -- Compute the absolute value of a vector (generic). + +procedure aabsr (a, b, npix) + +real a[ARB], b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = abs(a[i]) +end diff --git a/sys/vops/ak/aabss.x b/sys/vops/ak/aabss.x new file mode 100644 index 00000000..2084a7cc --- /dev/null +++ b/sys/vops/ak/aabss.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AABS -- Compute the absolute value of a vector (generic). + +procedure aabss (a, b, npix) + +short a[ARB], b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = abs(a[i]) +end diff --git a/sys/vops/ak/aabsx.x b/sys/vops/ak/aabsx.x new file mode 100644 index 00000000..287e22cf --- /dev/null +++ b/sys/vops/ak/aabsx.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AABS -- Compute the absolute value of a vector (generic). + +procedure aabsx (a, b, npix) + +complex a[ARB], b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = abs(a[i]) +end diff --git a/sys/vops/ak/aaddd.x b/sys/vops/ak/aaddd.x new file mode 100644 index 00000000..50716bbc --- /dev/null +++ b/sys/vops/ak/aaddd.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AADD -- Add two vectors (generic). + +procedure aaddd (a, b, c, npix) + +double a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] + b[i] +end diff --git a/sys/vops/ak/aaddi.x b/sys/vops/ak/aaddi.x new file mode 100644 index 00000000..cfaf200c --- /dev/null +++ b/sys/vops/ak/aaddi.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AADD -- Add two vectors (generic). + +procedure aaddi (a, b, c, npix) + +int a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] + b[i] +end diff --git a/sys/vops/ak/aaddkd.x b/sys/vops/ak/aaddkd.x new file mode 100644 index 00000000..e98dfb57 --- /dev/null +++ b/sys/vops/ak/aaddkd.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AADDK -- Add a constant to a vector (generic). + +procedure aaddkd (a, b, c, npix) + +double a[ARB] +double b +double c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] + b +end diff --git a/sys/vops/ak/aaddki.x b/sys/vops/ak/aaddki.x new file mode 100644 index 00000000..f71b5654 --- /dev/null +++ b/sys/vops/ak/aaddki.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AADDK -- Add a constant to a vector (generic). + +procedure aaddki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] + b +end diff --git a/sys/vops/ak/aaddkl.x b/sys/vops/ak/aaddkl.x new file mode 100644 index 00000000..9d16f93d --- /dev/null +++ b/sys/vops/ak/aaddkl.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AADDK -- Add a constant to a vector (generic). + +procedure aaddkl (a, b, c, npix) + +long a[ARB] +long b +long c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] + b +end diff --git a/sys/vops/ak/aaddkr.x b/sys/vops/ak/aaddkr.x new file mode 100644 index 00000000..07b92d8e --- /dev/null +++ b/sys/vops/ak/aaddkr.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AADDK -- Add a constant to a vector (generic). + +procedure aaddkr (a, b, c, npix) + +real a[ARB] +real b +real c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] + b +end diff --git a/sys/vops/ak/aaddks.x b/sys/vops/ak/aaddks.x new file mode 100644 index 00000000..d8256585 --- /dev/null +++ b/sys/vops/ak/aaddks.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AADDK -- Add a constant to a vector (generic). + +procedure aaddks (a, b, c, npix) + +short a[ARB] +short b +short c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] + b +end diff --git a/sys/vops/ak/aaddkx.x b/sys/vops/ak/aaddkx.x new file mode 100644 index 00000000..ea47e214 --- /dev/null +++ b/sys/vops/ak/aaddkx.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AADDK -- Add a constant to a vector (generic). + +procedure aaddkx (a, b, c, npix) + +complex a[ARB] +complex b +complex c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] + b +end diff --git a/sys/vops/ak/aaddl.x b/sys/vops/ak/aaddl.x new file mode 100644 index 00000000..3684265f --- /dev/null +++ b/sys/vops/ak/aaddl.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AADD -- Add two vectors (generic). + +procedure aaddl (a, b, c, npix) + +long a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] + b[i] +end diff --git a/sys/vops/ak/aaddr.x b/sys/vops/ak/aaddr.x new file mode 100644 index 00000000..ba35b513 --- /dev/null +++ b/sys/vops/ak/aaddr.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AADD -- Add two vectors (generic). + +procedure aaddr (a, b, c, npix) + +real a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] + b[i] +end diff --git a/sys/vops/ak/aadds.x b/sys/vops/ak/aadds.x new file mode 100644 index 00000000..bd53ed59 --- /dev/null +++ b/sys/vops/ak/aadds.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AADD -- Add two vectors (generic). + +procedure aadds (a, b, c, npix) + +short a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] + b[i] +end diff --git a/sys/vops/ak/aaddx.x b/sys/vops/ak/aaddx.x new file mode 100644 index 00000000..23239203 --- /dev/null +++ b/sys/vops/ak/aaddx.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AADD -- Add two vectors (generic). + +procedure aaddx (a, b, c, npix) + +complex a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] + b[i] +end diff --git a/sys/vops/ak/aandi.x b/sys/vops/ak/aandi.x new file mode 100644 index 00000000..86d6aadc --- /dev/null +++ b/sys/vops/ak/aandi.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AAND -- Compute the bitwise boolean 'and' of two vectors (generic). + +procedure aandi (a, b, c, npix) + +int a[ARB], b[ARB], c[ARB] +int npix, i +int and() + +begin + do i = 1, npix { + c[i] = and (a[i], b[i]) + } +end diff --git a/sys/vops/ak/aandki.x b/sys/vops/ak/aandki.x new file mode 100644 index 00000000..792b491e --- /dev/null +++ b/sys/vops/ak/aandki.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AANDK -- Compute the bitwise boolean 'and' of a vector and a constant +# (generic) + +procedure aandki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix, i +int and() + +begin + do i = 1, npix { + c[i] = and (a[i], b) + } +end diff --git a/sys/vops/ak/aandkl.x b/sys/vops/ak/aandkl.x new file mode 100644 index 00000000..c178aa21 --- /dev/null +++ b/sys/vops/ak/aandkl.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AANDK -- Compute the bitwise boolean 'and' of a vector and a constant +# (generic) + +procedure aandkl (a, b, c, npix) + +long a[ARB] +long b +long c[ARB] +int npix, i +long andl() + +begin + do i = 1, npix { + c[i] = andl (a[i], b) + } +end diff --git a/sys/vops/ak/aandks.x b/sys/vops/ak/aandks.x new file mode 100644 index 00000000..03a64dcb --- /dev/null +++ b/sys/vops/ak/aandks.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AANDK -- Compute the bitwise boolean 'and' of a vector and a constant +# (generic) + +procedure aandks (a, b, c, npix) + +short a[ARB] +short b +short c[ARB] +int npix, i +short ands() + +begin + do i = 1, npix { + c[i] = ands (a[i], b) + } +end diff --git a/sys/vops/ak/aandl.x b/sys/vops/ak/aandl.x new file mode 100644 index 00000000..95990efc --- /dev/null +++ b/sys/vops/ak/aandl.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AAND -- Compute the bitwise boolean 'and' of two vectors (generic). + +procedure aandl (a, b, c, npix) + +long a[ARB], b[ARB], c[ARB] +int npix, i +long andl() + +begin + do i = 1, npix { + c[i] = andl (a[i], b[i]) + } +end diff --git a/sys/vops/ak/aands.x b/sys/vops/ak/aands.x new file mode 100644 index 00000000..fe174b83 --- /dev/null +++ b/sys/vops/ak/aands.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AAND -- Compute the bitwise boolean 'and' of two vectors (generic). + +procedure aands (a, b, c, npix) + +short a[ARB], b[ARB], c[ARB] +int npix, i +short ands() + +begin + do i = 1, npix { + c[i] = ands (a[i], b[i]) + } +end diff --git a/sys/vops/ak/aavgd.x b/sys/vops/ak/aavgd.x new file mode 100644 index 00000000..04c68bf2 --- /dev/null +++ b/sys/vops/ak/aavgd.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AAVG -- Compute the mean and standard deviation (sigma) of a sample. +# All pixels are used. + +procedure aavgd (a, npix, mean, sigma) + +double a[ARB] +int npix +double mean, sigma, lcut, hcut +int junk, awvgd() +data lcut /0./, hcut /0./ + +begin + junk = awvgd (a, npix, mean, sigma, lcut, hcut) +end diff --git a/sys/vops/ak/aavgi.x b/sys/vops/ak/aavgi.x new file mode 100644 index 00000000..45c8a64e --- /dev/null +++ b/sys/vops/ak/aavgi.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AAVG -- Compute the mean and standard deviation (sigma) of a sample. +# All pixels are used. + +procedure aavgi (a, npix, mean, sigma) + +int a[ARB] +int npix +real mean, sigma, lcut, hcut +int junk, awvgi() +data lcut /0./, hcut /0./ + +begin + junk = awvgi (a, npix, mean, sigma, lcut, hcut) +end diff --git a/sys/vops/ak/aavgl.x b/sys/vops/ak/aavgl.x new file mode 100644 index 00000000..3c015246 --- /dev/null +++ b/sys/vops/ak/aavgl.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AAVG -- Compute the mean and standard deviation (sigma) of a sample. +# All pixels are used. + +procedure aavgl (a, npix, mean, sigma) + +long a[ARB] +int npix +double mean, sigma, lcut, hcut +int junk, awvgl() +data lcut /0./, hcut /0./ + +begin + junk = awvgl (a, npix, mean, sigma, lcut, hcut) +end diff --git a/sys/vops/ak/aavgr.x b/sys/vops/ak/aavgr.x new file mode 100644 index 00000000..c4aaa051 --- /dev/null +++ b/sys/vops/ak/aavgr.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AAVG -- Compute the mean and standard deviation (sigma) of a sample. +# All pixels are used. + +procedure aavgr (a, npix, mean, sigma) + +real a[ARB] +int npix +real mean, sigma, lcut, hcut +int junk, awvgr() +data lcut /0./, hcut /0./ + +begin + junk = awvgr (a, npix, mean, sigma, lcut, hcut) +end diff --git a/sys/vops/ak/aavgs.x b/sys/vops/ak/aavgs.x new file mode 100644 index 00000000..2793e2e8 --- /dev/null +++ b/sys/vops/ak/aavgs.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AAVG -- Compute the mean and standard deviation (sigma) of a sample. +# All pixels are used. + +procedure aavgs (a, npix, mean, sigma) + +short a[ARB] +int npix +real mean, sigma, lcut, hcut +int junk, awvgs() +data lcut /0./, hcut /0./ + +begin + junk = awvgs (a, npix, mean, sigma, lcut, hcut) +end diff --git a/sys/vops/ak/aavgx.x b/sys/vops/ak/aavgx.x new file mode 100644 index 00000000..07949efc --- /dev/null +++ b/sys/vops/ak/aavgx.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AAVG -- Compute the mean and standard deviation (sigma) of a sample. +# All pixels are used. + +procedure aavgx (a, npix, mean, sigma) + +complex a[ARB] +int npix +real mean, sigma, lcut, hcut +int junk, awvgx() +data lcut /0./, hcut /0./ + +begin + junk = awvgx (a, npix, mean, sigma, lcut, hcut) +end diff --git a/sys/vops/ak/abavd.x b/sys/vops/ak/abavd.x new file mode 100644 index 00000000..0e76e230 --- /dev/null +++ b/sys/vops/ak/abavd.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABAV -- Vector block average. Each pixel in the output vector is the +# average of the input vector over a block of pixels. The input vector must +# be at least (nblocks * npix_per_block) pixels in length. + +procedure abavd (a, b, nblocks, npix_per_block) + +double a[ARB] # input vector +double b[nblocks] # output vector +int nblocks # number of blocks (pixels in output vector) +int npix_per_block # number of input pixels per block + +double sum, width + +int i, j +int block_offset, next_block, block_length + +begin + block_offset = 1 + block_length = npix_per_block + width = block_length + + if (block_length <= 1) + call amovd (a[block_offset], b, nblocks) + else { + do j = 1, nblocks { + next_block = block_offset + block_length + sum = 0 + do i = block_offset, next_block - 1 + sum = sum + a[i] + b[j] = sum / width + block_offset = next_block + } + } +end diff --git a/sys/vops/ak/abavi.x b/sys/vops/ak/abavi.x new file mode 100644 index 00000000..9ca5b267 --- /dev/null +++ b/sys/vops/ak/abavi.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABAV -- Vector block average. Each pixel in the output vector is the +# average of the input vector over a block of pixels. The input vector must +# be at least (nblocks * npix_per_block) pixels in length. + +procedure abavi (a, b, nblocks, npix_per_block) + +int a[ARB] # input vector +int b[nblocks] # output vector +int nblocks # number of blocks (pixels in output vector) +int npix_per_block # number of input pixels per block + +real sum, width + +int i, j +int block_offset, next_block, block_length + +begin + block_offset = 1 + block_length = npix_per_block + width = block_length + + if (block_length <= 1) + call amovi (a[block_offset], b, nblocks) + else { + do j = 1, nblocks { + next_block = block_offset + block_length + sum = 0 + do i = block_offset, next_block - 1 + sum = sum + a[i] + b[j] = sum / width + block_offset = next_block + } + } +end diff --git a/sys/vops/ak/abavl.x b/sys/vops/ak/abavl.x new file mode 100644 index 00000000..29332022 --- /dev/null +++ b/sys/vops/ak/abavl.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABAV -- Vector block average. Each pixel in the output vector is the +# average of the input vector over a block of pixels. The input vector must +# be at least (nblocks * npix_per_block) pixels in length. + +procedure abavl (a, b, nblocks, npix_per_block) + +long a[ARB] # input vector +long b[nblocks] # output vector +int nblocks # number of blocks (pixels in output vector) +int npix_per_block # number of input pixels per block + +real sum, width + +int i, j +int block_offset, next_block, block_length + +begin + block_offset = 1 + block_length = npix_per_block + width = block_length + + if (block_length <= 1) + call amovl (a[block_offset], b, nblocks) + else { + do j = 1, nblocks { + next_block = block_offset + block_length + sum = 0 + do i = block_offset, next_block - 1 + sum = sum + a[i] + b[j] = sum / width + block_offset = next_block + } + } +end diff --git a/sys/vops/ak/abavr.x b/sys/vops/ak/abavr.x new file mode 100644 index 00000000..3e442d8e --- /dev/null +++ b/sys/vops/ak/abavr.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABAV -- Vector block average. Each pixel in the output vector is the +# average of the input vector over a block of pixels. The input vector must +# be at least (nblocks * npix_per_block) pixels in length. + +procedure abavr (a, b, nblocks, npix_per_block) + +real a[ARB] # input vector +real b[nblocks] # output vector +int nblocks # number of blocks (pixels in output vector) +int npix_per_block # number of input pixels per block + +real sum, width + +int i, j +int block_offset, next_block, block_length + +begin + block_offset = 1 + block_length = npix_per_block + width = block_length + + if (block_length <= 1) + call amovr (a[block_offset], b, nblocks) + else { + do j = 1, nblocks { + next_block = block_offset + block_length + sum = 0 + do i = block_offset, next_block - 1 + sum = sum + a[i] + b[j] = sum / width + block_offset = next_block + } + } +end diff --git a/sys/vops/ak/abavs.x b/sys/vops/ak/abavs.x new file mode 100644 index 00000000..f3e42dc4 --- /dev/null +++ b/sys/vops/ak/abavs.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABAV -- Vector block average. Each pixel in the output vector is the +# average of the input vector over a block of pixels. The input vector must +# be at least (nblocks * npix_per_block) pixels in length. + +procedure abavs (a, b, nblocks, npix_per_block) + +short a[ARB] # input vector +short b[nblocks] # output vector +int nblocks # number of blocks (pixels in output vector) +int npix_per_block # number of input pixels per block + +long sum, width + +int i, j +int block_offset, next_block, block_length + +begin + block_offset = 1 + block_length = npix_per_block + width = block_length + + if (block_length <= 1) + call amovs (a[block_offset], b, nblocks) + else { + do j = 1, nblocks { + next_block = block_offset + block_length + sum = 0 + do i = block_offset, next_block - 1 + sum = sum + a[i] + b[j] = sum / width + block_offset = next_block + } + } +end diff --git a/sys/vops/ak/abavx.x b/sys/vops/ak/abavx.x new file mode 100644 index 00000000..7b33c2a3 --- /dev/null +++ b/sys/vops/ak/abavx.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABAV -- Vector block average. Each pixel in the output vector is the +# average of the input vector over a block of pixels. The input vector must +# be at least (nblocks * npix_per_block) pixels in length. + +procedure abavx (a, b, nblocks, npix_per_block) + +complex a[ARB] # input vector +complex b[nblocks] # output vector +int nblocks # number of blocks (pixels in output vector) +int npix_per_block # number of input pixels per block + +complex sum, width + +int i, j +int block_offset, next_block, block_length + +begin + block_offset = 1 + block_length = npix_per_block + width = complex (block_length, block_length) + + if (block_length <= 1) + call amovx (a[block_offset], b, nblocks) + else { + do j = 1, nblocks { + next_block = block_offset + block_length + sum = 0 + do i = block_offset, next_block - 1 + sum = sum + a[i] + b[j] = sum / width + block_offset = next_block + } + } +end diff --git a/sys/vops/ak/abeqc.x b/sys/vops/ak/abeqc.x new file mode 100644 index 00000000..cbd97363 --- /dev/null +++ b/sys/vops/ak/abeqc.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQ -- Vector boolean equals. C[i], type INT, is set to 1 if A[i] equals +# B[i], else C[i] is set to zero. + +procedure abeqc (a, b, c, npix) + +char a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] == b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abeqd.x b/sys/vops/ak/abeqd.x new file mode 100644 index 00000000..d71d2ad8 --- /dev/null +++ b/sys/vops/ak/abeqd.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQ -- Vector boolean equals. C[i], type INT, is set to 1 if A[i] equals +# B[i], else C[i] is set to zero. + +procedure abeqd (a, b, c, npix) + +double a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] == b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abeqi.x b/sys/vops/ak/abeqi.x new file mode 100644 index 00000000..a70fad30 --- /dev/null +++ b/sys/vops/ak/abeqi.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQ -- Vector boolean equals. C[i], type INT, is set to 1 if A[i] equals +# B[i], else C[i] is set to zero. + +procedure abeqi (a, b, c, npix) + +int a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] == b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abeqkc.x b/sys/vops/ak/abeqkc.x new file mode 100644 index 00000000..10757e50 --- /dev/null +++ b/sys/vops/ak/abeqkc.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQK -- Vector boolean equals constant. C[i], type INT, is set to 1 if +# A[i] equals B, else C[i] is set to zero. + +procedure abeqkc (a, b, c, npix) + +char a[ARB] +char b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] == 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] == b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abeqkd.x b/sys/vops/ak/abeqkd.x new file mode 100644 index 00000000..f4b0950a --- /dev/null +++ b/sys/vops/ak/abeqkd.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQK -- Vector boolean equals constant. C[i], type INT, is set to 1 if +# A[i] equals B, else C[i] is set to zero. + +procedure abeqkd (a, b, c, npix) + +double a[ARB] +double b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0.0D0) { + do i = 1, npix + if (a[i] == 0.0D0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] == b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abeqki.x b/sys/vops/ak/abeqki.x new file mode 100644 index 00000000..c0a8d33c --- /dev/null +++ b/sys/vops/ak/abeqki.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQK -- Vector boolean equals constant. C[i], type INT, is set to 1 if +# A[i] equals B, else C[i] is set to zero. + +procedure abeqki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] == 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] == b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abeqkl.x b/sys/vops/ak/abeqkl.x new file mode 100644 index 00000000..35491d1e --- /dev/null +++ b/sys/vops/ak/abeqkl.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQK -- Vector boolean equals constant. C[i], type INT, is set to 1 if +# A[i] equals B, else C[i] is set to zero. + +procedure abeqkl (a, b, c, npix) + +long a[ARB] +long b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] == 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] == b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abeqkr.x b/sys/vops/ak/abeqkr.x new file mode 100644 index 00000000..5f6625ab --- /dev/null +++ b/sys/vops/ak/abeqkr.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQK -- Vector boolean equals constant. C[i], type INT, is set to 1 if +# A[i] equals B, else C[i] is set to zero. + +procedure abeqkr (a, b, c, npix) + +real a[ARB] +real b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0.0) { + do i = 1, npix + if (a[i] == 0.0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] == b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abeqks.x b/sys/vops/ak/abeqks.x new file mode 100644 index 00000000..f699cdf6 --- /dev/null +++ b/sys/vops/ak/abeqks.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQK -- Vector boolean equals constant. C[i], type INT, is set to 1 if +# A[i] equals B, else C[i] is set to zero. + +procedure abeqks (a, b, c, npix) + +short a[ARB] +short b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] == 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] == b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abeqkx.x b/sys/vops/ak/abeqkx.x new file mode 100644 index 00000000..c2767408 --- /dev/null +++ b/sys/vops/ak/abeqkx.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQK -- Vector boolean equals constant. C[i], type INT, is set to 1 if +# A[i] equals B, else C[i] is set to zero. + +procedure abeqkx (a, b, c, npix) + +complex a[ARB] +complex b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == (0.0,0.0)) { + do i = 1, npix + if (a[i] == (0.0,0.0)) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] == b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abeql.x b/sys/vops/ak/abeql.x new file mode 100644 index 00000000..36d1d195 --- /dev/null +++ b/sys/vops/ak/abeql.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQ -- Vector boolean equals. C[i], type INT, is set to 1 if A[i] equals +# B[i], else C[i] is set to zero. + +procedure abeql (a, b, c, npix) + +long a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] == b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abeqr.x b/sys/vops/ak/abeqr.x new file mode 100644 index 00000000..263246b8 --- /dev/null +++ b/sys/vops/ak/abeqr.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQ -- Vector boolean equals. C[i], type INT, is set to 1 if A[i] equals +# B[i], else C[i] is set to zero. + +procedure abeqr (a, b, c, npix) + +real a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] == b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abeqs.x b/sys/vops/ak/abeqs.x new file mode 100644 index 00000000..d133181b --- /dev/null +++ b/sys/vops/ak/abeqs.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQ -- Vector boolean equals. C[i], type INT, is set to 1 if A[i] equals +# B[i], else C[i] is set to zero. + +procedure abeqs (a, b, c, npix) + +short a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] == b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abeqx.x b/sys/vops/ak/abeqx.x new file mode 100644 index 00000000..858142fb --- /dev/null +++ b/sys/vops/ak/abeqx.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABEQ -- Vector boolean equals. C[i], type INT, is set to 1 if A[i] equals +# B[i], else C[i] is set to zero. + +procedure abeqx (a, b, c, npix) + +complex a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] == b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abgec.x b/sys/vops/ak/abgec.x new file mode 100644 index 00000000..5f1f03af --- /dev/null +++ b/sys/vops/ak/abgec.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGE -- Vector boolean greater than or equals. C[i], type INT, is set to 1 +# if A[i] is greater than B[i], else C[i] is set to zero. + +procedure abgec (a, b, c, npix) + +char a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] >= b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abged.x b/sys/vops/ak/abged.x new file mode 100644 index 00000000..36565fd6 --- /dev/null +++ b/sys/vops/ak/abged.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGE -- Vector boolean greater than or equals. C[i], type INT, is set to 1 +# if A[i] is greater than B[i], else C[i] is set to zero. + +procedure abged (a, b, c, npix) + +double a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] >= b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abgei.x b/sys/vops/ak/abgei.x new file mode 100644 index 00000000..76b9aca1 --- /dev/null +++ b/sys/vops/ak/abgei.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGE -- Vector boolean greater than or equals. C[i], type INT, is set to 1 +# if A[i] is greater than B[i], else C[i] is set to zero. + +procedure abgei (a, b, c, npix) + +int a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] >= b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abgekc.x b/sys/vops/ak/abgekc.x new file mode 100644 index 00000000..dcb495e6 --- /dev/null +++ b/sys/vops/ak/abgekc.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGEK -- Vector boolean greater than or equals constant. C[i], type INT, +# is set to 1 if A[i] is greater than or equal to B, else C[i] is set to zero. + +procedure abgekc (a, b, c, npix) + +char a[ARB] +char b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] >= 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] >= b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abgekd.x b/sys/vops/ak/abgekd.x new file mode 100644 index 00000000..4443230e --- /dev/null +++ b/sys/vops/ak/abgekd.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGEK -- Vector boolean greater than or equals constant. C[i], type INT, +# is set to 1 if A[i] is greater than or equal to B, else C[i] is set to zero. + +procedure abgekd (a, b, c, npix) + +double a[ARB] +double b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0.0D0) { + do i = 1, npix + if (a[i] >= 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] >= b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abgeki.x b/sys/vops/ak/abgeki.x new file mode 100644 index 00000000..d819f2e9 --- /dev/null +++ b/sys/vops/ak/abgeki.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGEK -- Vector boolean greater than or equals constant. C[i], type INT, +# is set to 1 if A[i] is greater than or equal to B, else C[i] is set to zero. + +procedure abgeki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] >= 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] >= b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abgekl.x b/sys/vops/ak/abgekl.x new file mode 100644 index 00000000..f599ffff --- /dev/null +++ b/sys/vops/ak/abgekl.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGEK -- Vector boolean greater than or equals constant. C[i], type INT, +# is set to 1 if A[i] is greater than or equal to B, else C[i] is set to zero. + +procedure abgekl (a, b, c, npix) + +long a[ARB] +long b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] >= 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] >= b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abgekr.x b/sys/vops/ak/abgekr.x new file mode 100644 index 00000000..35141e4c --- /dev/null +++ b/sys/vops/ak/abgekr.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGEK -- Vector boolean greater than or equals constant. C[i], type INT, +# is set to 1 if A[i] is greater than or equal to B, else C[i] is set to zero. + +procedure abgekr (a, b, c, npix) + +real a[ARB] +real b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0.0) { + do i = 1, npix + if (a[i] >= 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] >= b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abgeks.x b/sys/vops/ak/abgeks.x new file mode 100644 index 00000000..04486504 --- /dev/null +++ b/sys/vops/ak/abgeks.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGEK -- Vector boolean greater than or equals constant. C[i], type INT, +# is set to 1 if A[i] is greater than or equal to B, else C[i] is set to zero. + +procedure abgeks (a, b, c, npix) + +short a[ARB] +short b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] >= 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] >= b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abgekx.x b/sys/vops/ak/abgekx.x new file mode 100644 index 00000000..f8f43b77 --- /dev/null +++ b/sys/vops/ak/abgekx.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGEK -- Vector boolean greater than or equals constant. C[i], type INT, +# is set to 1 if A[i] is greater than or equal to B, else C[i] is set to zero. + +procedure abgekx (a, b, c, npix) + +complex a[ARB] +complex b +int c[ARB] +int npix +int i +real abs_b + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == (0.0,0.0)) { + call amovki (1, c, npix) + } else { + abs_b = abs (b) + do i = 1, npix + if (abs (a[i]) >= abs_b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abgel.x b/sys/vops/ak/abgel.x new file mode 100644 index 00000000..385082d7 --- /dev/null +++ b/sys/vops/ak/abgel.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGE -- Vector boolean greater than or equals. C[i], type INT, is set to 1 +# if A[i] is greater than B[i], else C[i] is set to zero. + +procedure abgel (a, b, c, npix) + +long a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] >= b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abger.x b/sys/vops/ak/abger.x new file mode 100644 index 00000000..f13f1065 --- /dev/null +++ b/sys/vops/ak/abger.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGE -- Vector boolean greater than or equals. C[i], type INT, is set to 1 +# if A[i] is greater than B[i], else C[i] is set to zero. + +procedure abger (a, b, c, npix) + +real a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] >= b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abges.x b/sys/vops/ak/abges.x new file mode 100644 index 00000000..c0bed06c --- /dev/null +++ b/sys/vops/ak/abges.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGE -- Vector boolean greater than or equals. C[i], type INT, is set to 1 +# if A[i] is greater than B[i], else C[i] is set to zero. + +procedure abges (a, b, c, npix) + +short a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] >= b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abgex.x b/sys/vops/ak/abgex.x new file mode 100644 index 00000000..bf8affff --- /dev/null +++ b/sys/vops/ak/abgex.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGE -- Vector boolean greater than or equals. C[i], type INT, is set to 1 +# if A[i] is greater than B[i], else C[i] is set to zero. + +procedure abgex (a, b, c, npix) + +complex a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (abs (a[i]) >= abs (b[i])) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abgtc.x b/sys/vops/ak/abgtc.x new file mode 100644 index 00000000..85eb410e --- /dev/null +++ b/sys/vops/ak/abgtc.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGT -- Vector boolean greater than. C[i], type INT, is set to 1 if +# A[i] is greater than B[i], else C[i] is set to zero. + +procedure abgtc (a, b, c, npix) + +char a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] > b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abgtd.x b/sys/vops/ak/abgtd.x new file mode 100644 index 00000000..7a5b668d --- /dev/null +++ b/sys/vops/ak/abgtd.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGT -- Vector boolean greater than. C[i], type INT, is set to 1 if +# A[i] is greater than B[i], else C[i] is set to zero. + +procedure abgtd (a, b, c, npix) + +double a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] > b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abgti.x b/sys/vops/ak/abgti.x new file mode 100644 index 00000000..356e66e9 --- /dev/null +++ b/sys/vops/ak/abgti.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGT -- Vector boolean greater than. C[i], type INT, is set to 1 if +# A[i] is greater than B[i], else C[i] is set to zero. + +procedure abgti (a, b, c, npix) + +int a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] > b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abgtkc.x b/sys/vops/ak/abgtkc.x new file mode 100644 index 00000000..425db27b --- /dev/null +++ b/sys/vops/ak/abgtkc.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGTK -- Vector boolean greater than constant. C[i], type INT, is set to 1 +# if A[i] is greater than B, else C[i] is set to zero. + +procedure abgtkc (a, b, c, npix) + +char a[ARB] +char b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] > 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] > b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abgtkd.x b/sys/vops/ak/abgtkd.x new file mode 100644 index 00000000..239caf24 --- /dev/null +++ b/sys/vops/ak/abgtkd.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGTK -- Vector boolean greater than constant. C[i], type INT, is set to 1 +# if A[i] is greater than B, else C[i] is set to zero. + +procedure abgtkd (a, b, c, npix) + +double a[ARB] +double b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0.0D0) { + do i = 1, npix + if (a[i] > 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] > b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abgtki.x b/sys/vops/ak/abgtki.x new file mode 100644 index 00000000..17d67d74 --- /dev/null +++ b/sys/vops/ak/abgtki.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGTK -- Vector boolean greater than constant. C[i], type INT, is set to 1 +# if A[i] is greater than B, else C[i] is set to zero. + +procedure abgtki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] > 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] > b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abgtkl.x b/sys/vops/ak/abgtkl.x new file mode 100644 index 00000000..1ee43a43 --- /dev/null +++ b/sys/vops/ak/abgtkl.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGTK -- Vector boolean greater than constant. C[i], type INT, is set to 1 +# if A[i] is greater than B, else C[i] is set to zero. + +procedure abgtkl (a, b, c, npix) + +long a[ARB] +long b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] > 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] > b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abgtkr.x b/sys/vops/ak/abgtkr.x new file mode 100644 index 00000000..11673299 --- /dev/null +++ b/sys/vops/ak/abgtkr.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGTK -- Vector boolean greater than constant. C[i], type INT, is set to 1 +# if A[i] is greater than B, else C[i] is set to zero. + +procedure abgtkr (a, b, c, npix) + +real a[ARB] +real b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0.0) { + do i = 1, npix + if (a[i] > 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] > b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abgtks.x b/sys/vops/ak/abgtks.x new file mode 100644 index 00000000..2c27023a --- /dev/null +++ b/sys/vops/ak/abgtks.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGTK -- Vector boolean greater than constant. C[i], type INT, is set to 1 +# if A[i] is greater than B, else C[i] is set to zero. + +procedure abgtks (a, b, c, npix) + +short a[ARB] +short b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] > 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] > b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abgtkx.x b/sys/vops/ak/abgtkx.x new file mode 100644 index 00000000..f7b2a992 --- /dev/null +++ b/sys/vops/ak/abgtkx.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGTK -- Vector boolean greater than constant. C[i], type INT, is set to 1 +# if A[i] is greater than B, else C[i] is set to zero. + +procedure abgtkx (a, b, c, npix) + +complex a[ARB] +complex b +int c[ARB] +int npix +int i +real abs_b + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == (0.0,0.0)) { + do i = 1, npix + if (abs (a[i]) > 0) + c[i] = 1 + else + c[i] = 0 + } else { + abs_b = abs (b) + do i = 1, npix + if (abs (a[i]) > abs_b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abgtl.x b/sys/vops/ak/abgtl.x new file mode 100644 index 00000000..3b5304b9 --- /dev/null +++ b/sys/vops/ak/abgtl.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGT -- Vector boolean greater than. C[i], type INT, is set to 1 if +# A[i] is greater than B[i], else C[i] is set to zero. + +procedure abgtl (a, b, c, npix) + +long a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] > b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abgtr.x b/sys/vops/ak/abgtr.x new file mode 100644 index 00000000..4d900166 --- /dev/null +++ b/sys/vops/ak/abgtr.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGT -- Vector boolean greater than. C[i], type INT, is set to 1 if +# A[i] is greater than B[i], else C[i] is set to zero. + +procedure abgtr (a, b, c, npix) + +real a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] > b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abgts.x b/sys/vops/ak/abgts.x new file mode 100644 index 00000000..8bb92613 --- /dev/null +++ b/sys/vops/ak/abgts.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGT -- Vector boolean greater than. C[i], type INT, is set to 1 if +# A[i] is greater than B[i], else C[i] is set to zero. + +procedure abgts (a, b, c, npix) + +short a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] > b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abgtx.x b/sys/vops/ak/abgtx.x new file mode 100644 index 00000000..c82aef59 --- /dev/null +++ b/sys/vops/ak/abgtx.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABGT -- Vector boolean greater than. C[i], type INT, is set to 1 if +# A[i] is greater than B[i], else C[i] is set to zero. + +procedure abgtx (a, b, c, npix) + +complex a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (abs (a[i]) > abs (b[i])) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/ablec.x b/sys/vops/ak/ablec.x new file mode 100644 index 00000000..76806def --- /dev/null +++ b/sys/vops/ak/ablec.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLE -- Vector boolean less than or equals. C[i], type INT, is set to 1 if +# A[i] is less than or equal to B[i], else C[i] is set to zero. + +procedure ablec (a, b, c, npix) + +char a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] <= b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abled.x b/sys/vops/ak/abled.x new file mode 100644 index 00000000..e1288c98 --- /dev/null +++ b/sys/vops/ak/abled.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLE -- Vector boolean less than or equals. C[i], type INT, is set to 1 if +# A[i] is less than or equal to B[i], else C[i] is set to zero. + +procedure abled (a, b, c, npix) + +double a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] <= b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/ablei.x b/sys/vops/ak/ablei.x new file mode 100644 index 00000000..d69d184f --- /dev/null +++ b/sys/vops/ak/ablei.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLE -- Vector boolean less than or equals. C[i], type INT, is set to 1 if +# A[i] is less than or equal to B[i], else C[i] is set to zero. + +procedure ablei (a, b, c, npix) + +int a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] <= b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/ablekc.x b/sys/vops/ak/ablekc.x new file mode 100644 index 00000000..5a9f776f --- /dev/null +++ b/sys/vops/ak/ablekc.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLEK -- Vector boolean less than or equals constant. C[i], type INT, +# is set to 1 if A[i] is less than or equal to B, else C[i] is set to zero. + +procedure ablekc (a, b, c, npix) + +char a[ARB] +char b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] <= 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] <= b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/ablekd.x b/sys/vops/ak/ablekd.x new file mode 100644 index 00000000..f18548da --- /dev/null +++ b/sys/vops/ak/ablekd.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLEK -- Vector boolean less than or equals constant. C[i], type INT, +# is set to 1 if A[i] is less than or equal to B, else C[i] is set to zero. + +procedure ablekd (a, b, c, npix) + +double a[ARB] +double b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0.0D0) { + do i = 1, npix + if (a[i] <= 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] <= b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/ableki.x b/sys/vops/ak/ableki.x new file mode 100644 index 00000000..4ee983f7 --- /dev/null +++ b/sys/vops/ak/ableki.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLEK -- Vector boolean less than or equals constant. C[i], type INT, +# is set to 1 if A[i] is less than or equal to B, else C[i] is set to zero. + +procedure ableki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] <= 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] <= b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/ablekl.x b/sys/vops/ak/ablekl.x new file mode 100644 index 00000000..5e480c5b --- /dev/null +++ b/sys/vops/ak/ablekl.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLEK -- Vector boolean less than or equals constant. C[i], type INT, +# is set to 1 if A[i] is less than or equal to B, else C[i] is set to zero. + +procedure ablekl (a, b, c, npix) + +long a[ARB] +long b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] <= 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] <= b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/ablekr.x b/sys/vops/ak/ablekr.x new file mode 100644 index 00000000..3e61beae --- /dev/null +++ b/sys/vops/ak/ablekr.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLEK -- Vector boolean less than or equals constant. C[i], type INT, +# is set to 1 if A[i] is less than or equal to B, else C[i] is set to zero. + +procedure ablekr (a, b, c, npix) + +real a[ARB] +real b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0.0) { + do i = 1, npix + if (a[i] <= 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] <= b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/ableks.x b/sys/vops/ak/ableks.x new file mode 100644 index 00000000..b8e855da --- /dev/null +++ b/sys/vops/ak/ableks.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLEK -- Vector boolean less than or equals constant. C[i], type INT, +# is set to 1 if A[i] is less than or equal to B, else C[i] is set to zero. + +procedure ableks (a, b, c, npix) + +short a[ARB] +short b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] <= 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] <= b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/ablekx.x b/sys/vops/ak/ablekx.x new file mode 100644 index 00000000..f29abb93 --- /dev/null +++ b/sys/vops/ak/ablekx.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLEK -- Vector boolean less than or equals constant. C[i], type INT, +# is set to 1 if A[i] is less than or equal to B, else C[i] is set to zero. + +procedure ablekx (a, b, c, npix) + +complex a[ARB] +complex b +int c[ARB] +int npix +int i +real abs_b + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == (0.0,0.0)) { + do i = 1, npix + if (abs (a[i]) == 0) + c[i] = 1 + else + c[i] = 0 + } else { + abs_b = abs (b) + do i = 1, npix + if (abs (a[i]) <= abs_b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/ablel.x b/sys/vops/ak/ablel.x new file mode 100644 index 00000000..b218784b --- /dev/null +++ b/sys/vops/ak/ablel.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLE -- Vector boolean less than or equals. C[i], type INT, is set to 1 if +# A[i] is less than or equal to B[i], else C[i] is set to zero. + +procedure ablel (a, b, c, npix) + +long a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] <= b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abler.x b/sys/vops/ak/abler.x new file mode 100644 index 00000000..88121ab3 --- /dev/null +++ b/sys/vops/ak/abler.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLE -- Vector boolean less than or equals. C[i], type INT, is set to 1 if +# A[i] is less than or equal to B[i], else C[i] is set to zero. + +procedure abler (a, b, c, npix) + +real a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] <= b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/ables.x b/sys/vops/ak/ables.x new file mode 100644 index 00000000..3165c0eb --- /dev/null +++ b/sys/vops/ak/ables.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLE -- Vector boolean less than or equals. C[i], type INT, is set to 1 if +# A[i] is less than or equal to B[i], else C[i] is set to zero. + +procedure ables (a, b, c, npix) + +short a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] <= b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/ablex.x b/sys/vops/ak/ablex.x new file mode 100644 index 00000000..98b68857 --- /dev/null +++ b/sys/vops/ak/ablex.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLE -- Vector boolean less than or equals. C[i], type INT, is set to 1 if +# A[i] is less than or equal to B[i], else C[i] is set to zero. + +procedure ablex (a, b, c, npix) + +complex a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (abs (a[i]) <= abs (b[i])) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abltc.x b/sys/vops/ak/abltc.x new file mode 100644 index 00000000..46c4c86c --- /dev/null +++ b/sys/vops/ak/abltc.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLT -- Vector boolean less than. C[i], type INT, is set to 1 if +# A[i] is less than B[i], else C[i] is set to zero. + +procedure abltc (a, b, c, npix) + +char a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] < b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abltd.x b/sys/vops/ak/abltd.x new file mode 100644 index 00000000..9b392c1f --- /dev/null +++ b/sys/vops/ak/abltd.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLT -- Vector boolean less than. C[i], type INT, is set to 1 if +# A[i] is less than B[i], else C[i] is set to zero. + +procedure abltd (a, b, c, npix) + +double a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] < b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/ablti.x b/sys/vops/ak/ablti.x new file mode 100644 index 00000000..b567b589 --- /dev/null +++ b/sys/vops/ak/ablti.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLT -- Vector boolean less than. C[i], type INT, is set to 1 if +# A[i] is less than B[i], else C[i] is set to zero. + +procedure ablti (a, b, c, npix) + +int a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] < b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abltkc.x b/sys/vops/ak/abltkc.x new file mode 100644 index 00000000..6917a40b --- /dev/null +++ b/sys/vops/ak/abltkc.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLTK -- Vector boolean less than constant. C[i], type INT, is set to 1 if +# A[i] is less than B, else C[i] is set to zero. + +procedure abltkc (a, b, c, npix) + +char a[ARB] +char b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] < 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] < b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abltkd.x b/sys/vops/ak/abltkd.x new file mode 100644 index 00000000..354c9bfb --- /dev/null +++ b/sys/vops/ak/abltkd.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLTK -- Vector boolean less than constant. C[i], type INT, is set to 1 if +# A[i] is less than B, else C[i] is set to zero. + +procedure abltkd (a, b, c, npix) + +double a[ARB] +double b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0.0D0) { + do i = 1, npix + if (a[i] < 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] < b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abltki.x b/sys/vops/ak/abltki.x new file mode 100644 index 00000000..f20f6455 --- /dev/null +++ b/sys/vops/ak/abltki.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLTK -- Vector boolean less than constant. C[i], type INT, is set to 1 if +# A[i] is less than B, else C[i] is set to zero. + +procedure abltki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] < 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] < b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abltkl.x b/sys/vops/ak/abltkl.x new file mode 100644 index 00000000..dc02c284 --- /dev/null +++ b/sys/vops/ak/abltkl.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLTK -- Vector boolean less than constant. C[i], type INT, is set to 1 if +# A[i] is less than B, else C[i] is set to zero. + +procedure abltkl (a, b, c, npix) + +long a[ARB] +long b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] < 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] < b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abltkr.x b/sys/vops/ak/abltkr.x new file mode 100644 index 00000000..02531a40 --- /dev/null +++ b/sys/vops/ak/abltkr.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLTK -- Vector boolean less than constant. C[i], type INT, is set to 1 if +# A[i] is less than B, else C[i] is set to zero. + +procedure abltkr (a, b, c, npix) + +real a[ARB] +real b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0.0) { + do i = 1, npix + if (a[i] < 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] < b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abltks.x b/sys/vops/ak/abltks.x new file mode 100644 index 00000000..3cdb07c5 --- /dev/null +++ b/sys/vops/ak/abltks.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLTK -- Vector boolean less than constant. C[i], type INT, is set to 1 if +# A[i] is less than B, else C[i] is set to zero. + +procedure abltks (a, b, c, npix) + +short a[ARB] +short b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] < 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] < b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abltkx.x b/sys/vops/ak/abltkx.x new file mode 100644 index 00000000..04527b7f --- /dev/null +++ b/sys/vops/ak/abltkx.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLTK -- Vector boolean less than constant. C[i], type INT, is set to 1 if +# A[i] is less than B, else C[i] is set to zero. + +procedure abltkx (a, b, c, npix) + +complex a[ARB] +complex b +int c[ARB] +int npix +int i +real abs_b + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == (0.0,0.0)) { + call aclri (c, npix) + } else { + abs_b = abs (b) + do i = 1, npix + if (abs (a[i]) < abs_b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abltl.x b/sys/vops/ak/abltl.x new file mode 100644 index 00000000..526a8ba3 --- /dev/null +++ b/sys/vops/ak/abltl.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLT -- Vector boolean less than. C[i], type INT, is set to 1 if +# A[i] is less than B[i], else C[i] is set to zero. + +procedure abltl (a, b, c, npix) + +long a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] < b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abltr.x b/sys/vops/ak/abltr.x new file mode 100644 index 00000000..bdaf39eb --- /dev/null +++ b/sys/vops/ak/abltr.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLT -- Vector boolean less than. C[i], type INT, is set to 1 if +# A[i] is less than B[i], else C[i] is set to zero. + +procedure abltr (a, b, c, npix) + +real a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] < b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/ablts.x b/sys/vops/ak/ablts.x new file mode 100644 index 00000000..a0a9bded --- /dev/null +++ b/sys/vops/ak/ablts.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLT -- Vector boolean less than. C[i], type INT, is set to 1 if +# A[i] is less than B[i], else C[i] is set to zero. + +procedure ablts (a, b, c, npix) + +short a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] < b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abltx.x b/sys/vops/ak/abltx.x new file mode 100644 index 00000000..354238b3 --- /dev/null +++ b/sys/vops/ak/abltx.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABLT -- Vector boolean less than. C[i], type INT, is set to 1 if +# A[i] is less than B[i], else C[i] is set to zero. + +procedure abltx (a, b, c, npix) + +complex a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (abs (a[i]) < abs (b[i])) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abnec.x b/sys/vops/ak/abnec.x new file mode 100644 index 00000000..7634ce5d --- /dev/null +++ b/sys/vops/ak/abnec.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNE -- Vector boolean not equals. C[i], type INT, is set to 1 if +# A[i] is not equal to B[i], else C[i] is set to zero. + +procedure abnec (a, b, c, npix) + +char a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abned.x b/sys/vops/ak/abned.x new file mode 100644 index 00000000..74da7d12 --- /dev/null +++ b/sys/vops/ak/abned.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNE -- Vector boolean not equals. C[i], type INT, is set to 1 if +# A[i] is not equal to B[i], else C[i] is set to zero. + +procedure abned (a, b, c, npix) + +double a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abnei.x b/sys/vops/ak/abnei.x new file mode 100644 index 00000000..57ce41c1 --- /dev/null +++ b/sys/vops/ak/abnei.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNE -- Vector boolean not equals. C[i], type INT, is set to 1 if +# A[i] is not equal to B[i], else C[i] is set to zero. + +procedure abnei (a, b, c, npix) + +int a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abnekc.x b/sys/vops/ak/abnekc.x new file mode 100644 index 00000000..082d2ac9 --- /dev/null +++ b/sys/vops/ak/abnekc.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNEK -- Vector boolean not equals constant. C[i], type INT, is set to 1 if +# A[i] is not equal to B, else C[i] is set to zero. + +procedure abnekc (a, b, c, npix) + +char a[ARB] +char b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] != 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] != b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abnekd.x b/sys/vops/ak/abnekd.x new file mode 100644 index 00000000..7f95e855 --- /dev/null +++ b/sys/vops/ak/abnekd.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNEK -- Vector boolean not equals constant. C[i], type INT, is set to 1 if +# A[i] is not equal to B, else C[i] is set to zero. + +procedure abnekd (a, b, c, npix) + +double a[ARB] +double b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0.0D0) { + do i = 1, npix + if (a[i] != 0.0D0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] != b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abneki.x b/sys/vops/ak/abneki.x new file mode 100644 index 00000000..c8e497c8 --- /dev/null +++ b/sys/vops/ak/abneki.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNEK -- Vector boolean not equals constant. C[i], type INT, is set to 1 if +# A[i] is not equal to B, else C[i] is set to zero. + +procedure abneki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] != 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] != b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abnekl.x b/sys/vops/ak/abnekl.x new file mode 100644 index 00000000..4e8537c2 --- /dev/null +++ b/sys/vops/ak/abnekl.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNEK -- Vector boolean not equals constant. C[i], type INT, is set to 1 if +# A[i] is not equal to B, else C[i] is set to zero. + +procedure abnekl (a, b, c, npix) + +long a[ARB] +long b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] != 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] != b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abnekr.x b/sys/vops/ak/abnekr.x new file mode 100644 index 00000000..effd0fc7 --- /dev/null +++ b/sys/vops/ak/abnekr.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNEK -- Vector boolean not equals constant. C[i], type INT, is set to 1 if +# A[i] is not equal to B, else C[i] is set to zero. + +procedure abnekr (a, b, c, npix) + +real a[ARB] +real b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0.0) { + do i = 1, npix + if (a[i] != 0.0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] != b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abneks.x b/sys/vops/ak/abneks.x new file mode 100644 index 00000000..e587ed1f --- /dev/null +++ b/sys/vops/ak/abneks.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNEK -- Vector boolean not equals constant. C[i], type INT, is set to 1 if +# A[i] is not equal to B, else C[i] is set to zero. + +procedure abneks (a, b, c, npix) + +short a[ARB] +short b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == 0) { + do i = 1, npix + if (a[i] != 0) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] != b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abnekx.x b/sys/vops/ak/abnekx.x new file mode 100644 index 00000000..8ddaca07 --- /dev/null +++ b/sys/vops/ak/abnekx.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNEK -- Vector boolean not equals constant. C[i], type INT, is set to 1 if +# A[i] is not equal to B, else C[i] is set to zero. + +procedure abnekx (a, b, c, npix) + +complex a[ARB] +complex b +int c[ARB] +int npix +int i + +begin + # The case b==0 is perhaps worth optimizing. On many machines this + # will save a memory fetch. + + if (b == (0.0,0.0)) { + do i = 1, npix + if (a[i] != (0.0,0.0)) + c[i] = 1 + else + c[i] = 0 + } else { + do i = 1, npix + if (a[i] != b) + c[i] = 1 + else + c[i] = 0 + } +end diff --git a/sys/vops/ak/abnel.x b/sys/vops/ak/abnel.x new file mode 100644 index 00000000..3f57b4cb --- /dev/null +++ b/sys/vops/ak/abnel.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNE -- Vector boolean not equals. C[i], type INT, is set to 1 if +# A[i] is not equal to B[i], else C[i] is set to zero. + +procedure abnel (a, b, c, npix) + +long a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abner.x b/sys/vops/ak/abner.x new file mode 100644 index 00000000..a5409272 --- /dev/null +++ b/sys/vops/ak/abner.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNE -- Vector boolean not equals. C[i], type INT, is set to 1 if +# A[i] is not equal to B[i], else C[i] is set to zero. + +procedure abner (a, b, c, npix) + +real a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abnes.x b/sys/vops/ak/abnes.x new file mode 100644 index 00000000..75c23939 --- /dev/null +++ b/sys/vops/ak/abnes.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNE -- Vector boolean not equals. C[i], type INT, is set to 1 if +# A[i] is not equal to B[i], else C[i] is set to zero. + +procedure abnes (a, b, c, npix) + +short a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abnex.x b/sys/vops/ak/abnex.x new file mode 100644 index 00000000..bc914339 --- /dev/null +++ b/sys/vops/ak/abnex.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABNE -- Vector boolean not equals. C[i], type INT, is set to 1 if +# A[i] is not equal to B[i], else C[i] is set to zero. + +procedure abnex (a, b, c, npix) + +complex a[ARB], b[ARB] +int c[ARB] +int npix +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + c[i] = 1 + else + c[i] = 0 +end diff --git a/sys/vops/ak/abori.x b/sys/vops/ak/abori.x new file mode 100644 index 00000000..e0ecf2fc --- /dev/null +++ b/sys/vops/ak/abori.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABOR -- Compute the bitwise boolean 'or' of two vectors (generic). + +procedure abori (a, b, c, npix) + +int a[ARB], b[ARB], c[ARB] +int npix, i +int or() + +begin + do i = 1, npix { + c[i] = or (a[i], b[i]) + } +end diff --git a/sys/vops/ak/aborki.x b/sys/vops/ak/aborki.x new file mode 100644 index 00000000..760debcc --- /dev/null +++ b/sys/vops/ak/aborki.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABORK -- Compute the bitwise boolean or of a vector and a constant +# (generic). + +procedure aborki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix, i +int or() + +begin + do i = 1, npix { + c[i] = or (a[i], b) + } +end diff --git a/sys/vops/ak/aborkl.x b/sys/vops/ak/aborkl.x new file mode 100644 index 00000000..262c113e --- /dev/null +++ b/sys/vops/ak/aborkl.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABORK -- Compute the bitwise boolean or of a vector and a constant +# (generic). + +procedure aborkl (a, b, c, npix) + +long a[ARB] +long b +long c[ARB] +int npix, i +long orl() + +begin + do i = 1, npix { + c[i] = orl (a[i], b) + } +end diff --git a/sys/vops/ak/aborks.x b/sys/vops/ak/aborks.x new file mode 100644 index 00000000..a8de717a --- /dev/null +++ b/sys/vops/ak/aborks.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABORK -- Compute the bitwise boolean or of a vector and a constant +# (generic). + +procedure aborks (a, b, c, npix) + +short a[ARB] +short b +short c[ARB] +int npix, i +short ors() + +begin + do i = 1, npix { + c[i] = ors (a[i], b) + } +end diff --git a/sys/vops/ak/aborl.x b/sys/vops/ak/aborl.x new file mode 100644 index 00000000..995b3c3b --- /dev/null +++ b/sys/vops/ak/aborl.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABOR -- Compute the bitwise boolean 'or' of two vectors (generic). + +procedure aborl (a, b, c, npix) + +long a[ARB], b[ARB], c[ARB] +int npix, i +long orl() + +begin + do i = 1, npix { + c[i] = orl (a[i], b[i]) + } +end diff --git a/sys/vops/ak/abors.x b/sys/vops/ak/abors.x new file mode 100644 index 00000000..6ae42d4f --- /dev/null +++ b/sys/vops/ak/abors.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABOR -- Compute the bitwise boolean 'or' of two vectors (generic). + +procedure abors (a, b, c, npix) + +short a[ARB], b[ARB], c[ARB] +int npix, i +short ors() + +begin + do i = 1, npix { + c[i] = ors (a[i], b[i]) + } +end diff --git a/sys/vops/ak/absud.x b/sys/vops/ak/absud.x new file mode 100644 index 00000000..06a7ae90 --- /dev/null +++ b/sys/vops/ak/absud.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABSU -- Vector block sum. Each pixel in the output vector is the +# sum of the input vector over a block of pixels. The input vector must +# be at least (nblocks * npix_per_block) pixels in length. + +procedure absud (a, b, nblocks, npix_per_block) + +double a[ARB] # input vector +double b[nblocks] # output vector +int nblocks # number of blocks (pixels in output vector) +int npix_per_block # number of input pixels per block + +double sum + +int i, j +int block_offset, next_block, block_length + +begin + block_offset = 1 + block_length = npix_per_block + + if (block_length <= 1) + call amovd (a[block_offset], b, nblocks) + else { + do j = 1, nblocks { + next_block = block_offset + block_length + sum = 0 + do i = block_offset, next_block - 1 + sum = sum + a[i] + b[j] = sum + block_offset = next_block + } + } +end diff --git a/sys/vops/ak/absui.x b/sys/vops/ak/absui.x new file mode 100644 index 00000000..ae785103 --- /dev/null +++ b/sys/vops/ak/absui.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABSU -- Vector block sum. Each pixel in the output vector is the +# sum of the input vector over a block of pixels. The input vector must +# be at least (nblocks * npix_per_block) pixels in length. + +procedure absui (a, b, nblocks, npix_per_block) + +int a[ARB] # input vector +int b[nblocks] # output vector +int nblocks # number of blocks (pixels in output vector) +int npix_per_block # number of input pixels per block + +real sum + +int i, j +int block_offset, next_block, block_length + +begin + block_offset = 1 + block_length = npix_per_block + + if (block_length <= 1) + call amovi (a[block_offset], b, nblocks) + else { + do j = 1, nblocks { + next_block = block_offset + block_length + sum = 0 + do i = block_offset, next_block - 1 + sum = sum + a[i] + b[j] = sum + block_offset = next_block + } + } +end diff --git a/sys/vops/ak/absul.x b/sys/vops/ak/absul.x new file mode 100644 index 00000000..ff803cc6 --- /dev/null +++ b/sys/vops/ak/absul.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABSU -- Vector block sum. Each pixel in the output vector is the +# sum of the input vector over a block of pixels. The input vector must +# be at least (nblocks * npix_per_block) pixels in length. + +procedure absul (a, b, nblocks, npix_per_block) + +long a[ARB] # input vector +long b[nblocks] # output vector +int nblocks # number of blocks (pixels in output vector) +int npix_per_block # number of input pixels per block + +real sum + +int i, j +int block_offset, next_block, block_length + +begin + block_offset = 1 + block_length = npix_per_block + + if (block_length <= 1) + call amovl (a[block_offset], b, nblocks) + else { + do j = 1, nblocks { + next_block = block_offset + block_length + sum = 0 + do i = block_offset, next_block - 1 + sum = sum + a[i] + b[j] = sum + block_offset = next_block + } + } +end diff --git a/sys/vops/ak/absur.x b/sys/vops/ak/absur.x new file mode 100644 index 00000000..8aaca446 --- /dev/null +++ b/sys/vops/ak/absur.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABSU -- Vector block sum. Each pixel in the output vector is the +# sum of the input vector over a block of pixels. The input vector must +# be at least (nblocks * npix_per_block) pixels in length. + +procedure absur (a, b, nblocks, npix_per_block) + +real a[ARB] # input vector +real b[nblocks] # output vector +int nblocks # number of blocks (pixels in output vector) +int npix_per_block # number of input pixels per block + +real sum + +int i, j +int block_offset, next_block, block_length + +begin + block_offset = 1 + block_length = npix_per_block + + if (block_length <= 1) + call amovr (a[block_offset], b, nblocks) + else { + do j = 1, nblocks { + next_block = block_offset + block_length + sum = 0 + do i = block_offset, next_block - 1 + sum = sum + a[i] + b[j] = sum + block_offset = next_block + } + } +end diff --git a/sys/vops/ak/absus.x b/sys/vops/ak/absus.x new file mode 100644 index 00000000..9161ed24 --- /dev/null +++ b/sys/vops/ak/absus.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ABSU -- Vector block sum. Each pixel in the output vector is the +# sum of the input vector over a block of pixels. The input vector must +# be at least (nblocks * npix_per_block) pixels in length. + +procedure absus (a, b, nblocks, npix_per_block) + +short a[ARB] # input vector +short b[nblocks] # output vector +int nblocks # number of blocks (pixels in output vector) +int npix_per_block # number of input pixels per block + +long sum + +int i, j +int block_offset, next_block, block_length + +begin + block_offset = 1 + block_length = npix_per_block + + if (block_length <= 1) + call amovs (a[block_offset], b, nblocks) + else { + do j = 1, nblocks { + next_block = block_offset + block_length + sum = 0 + do i = block_offset, next_block - 1 + sum = sum + a[i] + b[j] = sum + block_offset = next_block + } + } +end diff --git a/sys/vops/ak/achtcc.x b/sys/vops/ak/achtcc.x new file mode 100644 index 00000000..b531ea80 --- /dev/null +++ b/sys/vops/ak/achtcc.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtcc (a, b, npix) + +char a[ARB] +char b[ARB] +int npix + +begin + call amovc (a, b, npix) +end diff --git a/sys/vops/ak/achtcd.x b/sys/vops/ak/achtcd.x new file mode 100644 index 00000000..6b0ea760 --- /dev/null +++ b/sys/vops/ak/achtcd.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtcd (a, b, npix) + +char a[ARB] +double b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = a[i] +end diff --git a/sys/vops/ak/achtci.x b/sys/vops/ak/achtci.x new file mode 100644 index 00000000..3aef94ee --- /dev/null +++ b/sys/vops/ak/achtci.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtci (a, b, npix) + +char a[ARB] +int b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = a[i] +end diff --git a/sys/vops/ak/achtcl.x b/sys/vops/ak/achtcl.x new file mode 100644 index 00000000..8b01968d --- /dev/null +++ b/sys/vops/ak/achtcl.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtcl (a, b, npix) + +char a[ARB] +long b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = a[i] +end diff --git a/sys/vops/ak/achtcr.x b/sys/vops/ak/achtcr.x new file mode 100644 index 00000000..d95534a8 --- /dev/null +++ b/sys/vops/ak/achtcr.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtcr (a, b, npix) + +char a[ARB] +real b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = a[i] +end diff --git a/sys/vops/ak/achtcs.x b/sys/vops/ak/achtcs.x new file mode 100644 index 00000000..35e5266d --- /dev/null +++ b/sys/vops/ak/achtcs.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtcs (a, b, npix) + +char a[ARB] +short b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtcx.x b/sys/vops/ak/achtcx.x new file mode 100644 index 00000000..1c8e1dc6 --- /dev/null +++ b/sys/vops/ak/achtcx.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtcx (a, b, npix) + +char a[ARB] +complex b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = complex(real(a[i]),0.0) +end diff --git a/sys/vops/ak/achtdc.x b/sys/vops/ak/achtdc.x new file mode 100644 index 00000000..309ce09b --- /dev/null +++ b/sys/vops/ak/achtdc.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtdc (a, b, npix) + +double a[ARB] +char b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtdd.x b/sys/vops/ak/achtdd.x new file mode 100644 index 00000000..76520e5a --- /dev/null +++ b/sys/vops/ak/achtdd.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtdd (a, b, npix) + +double a[ARB] +double b[ARB] +int npix + +begin + call amovd (a, b, npix) +end diff --git a/sys/vops/ak/achtdi.x b/sys/vops/ak/achtdi.x new file mode 100644 index 00000000..7647c94f --- /dev/null +++ b/sys/vops/ak/achtdi.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtdi (a, b, npix) + +double a[ARB] +int b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtdl.x b/sys/vops/ak/achtdl.x new file mode 100644 index 00000000..303d6e7c --- /dev/null +++ b/sys/vops/ak/achtdl.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtdl (a, b, npix) + +double a[ARB] +long b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtdr.x b/sys/vops/ak/achtdr.x new file mode 100644 index 00000000..f047d66b --- /dev/null +++ b/sys/vops/ak/achtdr.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtdr (a, b, npix) + +double a[ARB] +real b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtds.x b/sys/vops/ak/achtds.x new file mode 100644 index 00000000..08585d68 --- /dev/null +++ b/sys/vops/ak/achtds.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtds (a, b, npix) + +double a[ARB] +short b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtdx.x b/sys/vops/ak/achtdx.x new file mode 100644 index 00000000..0e253f4f --- /dev/null +++ b/sys/vops/ak/achtdx.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtdx (a, b, npix) + +double a[ARB] +complex b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = complex(real(a[i]),0.0) +end diff --git a/sys/vops/ak/achtic.x b/sys/vops/ak/achtic.x new file mode 100644 index 00000000..17812f52 --- /dev/null +++ b/sys/vops/ak/achtic.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtic (a, b, npix) + +int a[ARB] +char b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtid.x b/sys/vops/ak/achtid.x new file mode 100644 index 00000000..d030ef99 --- /dev/null +++ b/sys/vops/ak/achtid.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtid (a, b, npix) + +int a[ARB] +double b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = a[i] +end diff --git a/sys/vops/ak/achtii.x b/sys/vops/ak/achtii.x new file mode 100644 index 00000000..2bda8301 --- /dev/null +++ b/sys/vops/ak/achtii.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtii (a, b, npix) + +int a[ARB] +int b[ARB] +int npix + +begin + call amovi (a, b, npix) +end diff --git a/sys/vops/ak/achtil.x b/sys/vops/ak/achtil.x new file mode 100644 index 00000000..5397d121 --- /dev/null +++ b/sys/vops/ak/achtil.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtil (a, b, npix) + +int a[ARB] +long b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtir.x b/sys/vops/ak/achtir.x new file mode 100644 index 00000000..4e17ce9a --- /dev/null +++ b/sys/vops/ak/achtir.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtir (a, b, npix) + +int a[ARB] +real b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtis.x b/sys/vops/ak/achtis.x new file mode 100644 index 00000000..3f6df01c --- /dev/null +++ b/sys/vops/ak/achtis.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtis (a, b, npix) + +int a[ARB] +short b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtix.x b/sys/vops/ak/achtix.x new file mode 100644 index 00000000..7413c08a --- /dev/null +++ b/sys/vops/ak/achtix.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtix (a, b, npix) + +int a[ARB] +complex b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = complex(real(a[i]),0.0) +end diff --git a/sys/vops/ak/achtlc.x b/sys/vops/ak/achtlc.x new file mode 100644 index 00000000..67aded51 --- /dev/null +++ b/sys/vops/ak/achtlc.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtlc (a, b, npix) + +long a[ARB] +char b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtld.x b/sys/vops/ak/achtld.x new file mode 100644 index 00000000..a67a5a42 --- /dev/null +++ b/sys/vops/ak/achtld.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtld (a, b, npix) + +long a[ARB] +double b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = a[i] +end diff --git a/sys/vops/ak/achtli.x b/sys/vops/ak/achtli.x new file mode 100644 index 00000000..0c06f8ba --- /dev/null +++ b/sys/vops/ak/achtli.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtli (a, b, npix) + +long a[ARB] +int b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtll.x b/sys/vops/ak/achtll.x new file mode 100644 index 00000000..ca9a5d05 --- /dev/null +++ b/sys/vops/ak/achtll.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtll (a, b, npix) + +long a[ARB] +long b[ARB] +int npix + +begin + call amovl (a, b, npix) +end diff --git a/sys/vops/ak/achtlr.x b/sys/vops/ak/achtlr.x new file mode 100644 index 00000000..a842c431 --- /dev/null +++ b/sys/vops/ak/achtlr.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtlr (a, b, npix) + +long a[ARB] +real b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtls.x b/sys/vops/ak/achtls.x new file mode 100644 index 00000000..8e71fc40 --- /dev/null +++ b/sys/vops/ak/achtls.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtls (a, b, npix) + +long a[ARB] +short b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtlx.x b/sys/vops/ak/achtlx.x new file mode 100644 index 00000000..ecfc2f68 --- /dev/null +++ b/sys/vops/ak/achtlx.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtlx (a, b, npix) + +long a[ARB] +complex b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = complex(real(a[i]),0.0) +end diff --git a/sys/vops/ak/achtrc.x b/sys/vops/ak/achtrc.x new file mode 100644 index 00000000..0c16881a --- /dev/null +++ b/sys/vops/ak/achtrc.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtrc (a, b, npix) + +real a[ARB] +char b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtrd.x b/sys/vops/ak/achtrd.x new file mode 100644 index 00000000..ef25741d --- /dev/null +++ b/sys/vops/ak/achtrd.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtrd (a, b, npix) + +real a[ARB] +double b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = a[i] +end diff --git a/sys/vops/ak/achtri.x b/sys/vops/ak/achtri.x new file mode 100644 index 00000000..38b137bf --- /dev/null +++ b/sys/vops/ak/achtri.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtri (a, b, npix) + +real a[ARB] +int b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtrl.x b/sys/vops/ak/achtrl.x new file mode 100644 index 00000000..fa30f59c --- /dev/null +++ b/sys/vops/ak/achtrl.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtrl (a, b, npix) + +real a[ARB] +long b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtrr.x b/sys/vops/ak/achtrr.x new file mode 100644 index 00000000..9825cc95 --- /dev/null +++ b/sys/vops/ak/achtrr.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtrr (a, b, npix) + +real a[ARB] +real b[ARB] +int npix + +begin + call amovr (a, b, npix) +end diff --git a/sys/vops/ak/achtrs.x b/sys/vops/ak/achtrs.x new file mode 100644 index 00000000..f3bcb1f9 --- /dev/null +++ b/sys/vops/ak/achtrs.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtrs (a, b, npix) + +real a[ARB] +short b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtrx.x b/sys/vops/ak/achtrx.x new file mode 100644 index 00000000..047fdad5 --- /dev/null +++ b/sys/vops/ak/achtrx.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtrx (a, b, npix) + +real a[ARB] +complex b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = complex(real(a[i]),0.0) +end diff --git a/sys/vops/ak/achtsc.x b/sys/vops/ak/achtsc.x new file mode 100644 index 00000000..b8a951bf --- /dev/null +++ b/sys/vops/ak/achtsc.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtsc (a, b, npix) + +short a[ARB] +char b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtsd.x b/sys/vops/ak/achtsd.x new file mode 100644 index 00000000..a2b5d3af --- /dev/null +++ b/sys/vops/ak/achtsd.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtsd (a, b, npix) + +short a[ARB] +double b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = a[i] +end diff --git a/sys/vops/ak/achtsi.x b/sys/vops/ak/achtsi.x new file mode 100644 index 00000000..666530bf --- /dev/null +++ b/sys/vops/ak/achtsi.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtsi (a, b, npix) + +short a[ARB] +int b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = a[i] +end diff --git a/sys/vops/ak/achtsl.x b/sys/vops/ak/achtsl.x new file mode 100644 index 00000000..867e3f25 --- /dev/null +++ b/sys/vops/ak/achtsl.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtsl (a, b, npix) + +short a[ARB] +long b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = a[i] +end diff --git a/sys/vops/ak/achtsr.x b/sys/vops/ak/achtsr.x new file mode 100644 index 00000000..7f16c424 --- /dev/null +++ b/sys/vops/ak/achtsr.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtsr (a, b, npix) + +short a[ARB] +real b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = a[i] +end diff --git a/sys/vops/ak/achtss.x b/sys/vops/ak/achtss.x new file mode 100644 index 00000000..2d8be27b --- /dev/null +++ b/sys/vops/ak/achtss.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtss (a, b, npix) + +short a[ARB] +short b[ARB] +int npix + +begin + call amovs (a, b, npix) +end diff --git a/sys/vops/ak/achtsx.x b/sys/vops/ak/achtsx.x new file mode 100644 index 00000000..f059d135 --- /dev/null +++ b/sys/vops/ak/achtsx.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtsx (a, b, npix) + +short a[ARB] +complex b[ARB] +int npix +int i + +begin + do i = npix, 1, -1 + b[i] = complex(real(a[i]),0.0) +end diff --git a/sys/vops/ak/achtxc.x b/sys/vops/ak/achtxc.x new file mode 100644 index 00000000..06625215 --- /dev/null +++ b/sys/vops/ak/achtxc.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtxc (a, b, npix) + +complex a[ARB] +char b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtxd.x b/sys/vops/ak/achtxd.x new file mode 100644 index 00000000..3548ee23 --- /dev/null +++ b/sys/vops/ak/achtxd.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtxd (a, b, npix) + +complex a[ARB] +double b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtxi.x b/sys/vops/ak/achtxi.x new file mode 100644 index 00000000..403be396 --- /dev/null +++ b/sys/vops/ak/achtxi.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtxi (a, b, npix) + +complex a[ARB] +int b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtxl.x b/sys/vops/ak/achtxl.x new file mode 100644 index 00000000..eef669dd --- /dev/null +++ b/sys/vops/ak/achtxl.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtxl (a, b, npix) + +complex a[ARB] +long b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtxr.x b/sys/vops/ak/achtxr.x new file mode 100644 index 00000000..35352510 --- /dev/null +++ b/sys/vops/ak/achtxr.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtxr (a, b, npix) + +complex a[ARB] +real b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtxs.x b/sys/vops/ak/achtxs.x new file mode 100644 index 00000000..d4e36256 --- /dev/null +++ b/sys/vops/ak/achtxs.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtxs (a, b, npix) + +complex a[ARB] +short b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = a[i] +end diff --git a/sys/vops/ak/achtxx.x b/sys/vops/ak/achtxx.x new file mode 100644 index 00000000..fe5072db --- /dev/null +++ b/sys/vops/ak/achtxx.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACHTxy -- Change datatype of vector from "x" to "y" (doubly generic). +# The operation is performed in such a way that the output vector can be +# the same as the input vector without overwriting data. + +procedure achtxx (a, b, npix) + +complex a[ARB] +complex b[ARB] +int npix + +begin + call amovx (a, b, npix) +end diff --git a/sys/vops/ak/acjgx.x b/sys/vops/ak/acjgx.x new file mode 100644 index 00000000..1fc9f944 --- /dev/null +++ b/sys/vops/ak/acjgx.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACJGX -- Complex conjugate of a complex vector. + +procedure acjgx (a, b, npix) + +complex a[ARB], b[ARB] +int npix +int i + +begin + do i = 1, npix + b[i] = conjg (a[i]) +end diff --git a/sys/vops/ak/aclrc.x b/sys/vops/ak/aclrc.x new file mode 100644 index 00000000..03a82c86 --- /dev/null +++ b/sys/vops/ak/aclrc.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACLR -- Zero a vector (generic). + +procedure aclrc (a, npix) + +char a[ARB] +int npix, i + +begin + do i = 1, npix + a[i] = 0 +end diff --git a/sys/vops/ak/aclrd.x b/sys/vops/ak/aclrd.x new file mode 100644 index 00000000..791eb7c0 --- /dev/null +++ b/sys/vops/ak/aclrd.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACLR -- Zero a vector (generic). + +procedure aclrd (a, npix) + +double a[ARB] +int npix, i + +begin + do i = 1, npix + a[i] = 0.0D0 +end diff --git a/sys/vops/ak/aclri.x b/sys/vops/ak/aclri.x new file mode 100644 index 00000000..0b022bb3 --- /dev/null +++ b/sys/vops/ak/aclri.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACLR -- Zero a vector (generic). + +procedure aclri (a, npix) + +int a[ARB] +int npix, i + +begin + do i = 1, npix + a[i] = 0 +end diff --git a/sys/vops/ak/aclrl.x b/sys/vops/ak/aclrl.x new file mode 100644 index 00000000..c56fb5b3 --- /dev/null +++ b/sys/vops/ak/aclrl.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACLR -- Zero a vector (generic). + +procedure aclrl (a, npix) + +long a[ARB] +int npix, i + +begin + do i = 1, npix + a[i] = 0 +end diff --git a/sys/vops/ak/aclrr.x b/sys/vops/ak/aclrr.x new file mode 100644 index 00000000..9102ce7c --- /dev/null +++ b/sys/vops/ak/aclrr.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACLR -- Zero a vector (generic). + +procedure aclrr (a, npix) + +real a[ARB] +int npix, i + +begin + do i = 1, npix + a[i] = 0.0 +end diff --git a/sys/vops/ak/aclrs.x b/sys/vops/ak/aclrs.x new file mode 100644 index 00000000..a42a6b00 --- /dev/null +++ b/sys/vops/ak/aclrs.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACLR -- Zero a vector (generic). + +procedure aclrs (a, npix) + +short a[ARB] +int npix, i + +begin + do i = 1, npix + a[i] = 0 +end diff --git a/sys/vops/ak/aclrx.x b/sys/vops/ak/aclrx.x new file mode 100644 index 00000000..a27e555f --- /dev/null +++ b/sys/vops/ak/aclrx.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACLR -- Zero a vector (generic). + +procedure aclrx (a, npix) + +complex a[ARB] +int npix, i + +begin + do i = 1, npix + a[i] = (0.0,0.0) +end diff --git a/sys/vops/ak/acnvd.x b/sys/vops/ak/acnvd.x new file mode 100644 index 00000000..7871ac93 --- /dev/null +++ b/sys/vops/ak/acnvd.x @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACNV -- Vector convolution. The output vector is equal to the sum of its +# initial value and the convolution of the input vector with the kernel. +# This routine assumes boundary extension on the input vector has been provided. +# For short kernels, we unroll the inner do loop into a single statement to +# reduce loop overhead. +# +# Example: npix=10, kpix=5, 2 pixels out of bounds on either end. +# in[1] corresponds to x = -1 +# +# -1 0 1 2 3 4 5 6 7 8 9 10 11 12 (x coord) +# 1 2 3 4 5 +# 1 2 3 4 5 +# ... +# 1 2 3 4 5 + +procedure acnvd (in, out, npix, kernel, knpix) + +double in[npix+knpix-1] # input vector, including boundary pixels +double out[ARB] # output vector +int npix # length of output vector +double kernel[knpix] # convolution kernel +int knpix # size of convolution kernel + +int i, j +double sum, k1, k2, k3, k4, k5 + +begin + switch (knpix) { + case 3: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + case 5: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + k4 = kernel[4] + k5 = kernel[5] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + + k4 * in[i+3] + k5 * in[i+4] + default: + do i = 1, npix { + sum = out[i] + do j = 1, knpix + sum = sum + (kernel[j] * in[i+j-1]) + out[i] = sum + } + } +end diff --git a/sys/vops/ak/acnvi.x b/sys/vops/ak/acnvi.x new file mode 100644 index 00000000..70a236f8 --- /dev/null +++ b/sys/vops/ak/acnvi.x @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACNV -- Vector convolution. The output vector is equal to the sum of its +# initial value and the convolution of the input vector with the kernel. +# This routine assumes boundary extension on the input vector has been provided. +# For short kernels, we unroll the inner do loop into a single statement to +# reduce loop overhead. +# +# Example: npix=10, kpix=5, 2 pixels out of bounds on either end. +# in[1] corresponds to x = -1 +# +# -1 0 1 2 3 4 5 6 7 8 9 10 11 12 (x coord) +# 1 2 3 4 5 +# 1 2 3 4 5 +# ... +# 1 2 3 4 5 + +procedure acnvi (in, out, npix, kernel, knpix) + +int in[npix+knpix-1] # input vector, including boundary pixels +int out[ARB] # output vector +int npix # length of output vector +int kernel[knpix] # convolution kernel +int knpix # size of convolution kernel + +int i, j +int sum, k1, k2, k3, k4, k5 + +begin + switch (knpix) { + case 3: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + case 5: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + k4 = kernel[4] + k5 = kernel[5] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + + k4 * in[i+3] + k5 * in[i+4] + default: + do i = 1, npix { + sum = out[i] + do j = 1, knpix + sum = sum + (kernel[j] * in[i+j-1]) + out[i] = sum + } + } +end diff --git a/sys/vops/ak/acnvl.x b/sys/vops/ak/acnvl.x new file mode 100644 index 00000000..98fc18f0 --- /dev/null +++ b/sys/vops/ak/acnvl.x @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACNV -- Vector convolution. The output vector is equal to the sum of its +# initial value and the convolution of the input vector with the kernel. +# This routine assumes boundary extension on the input vector has been provided. +# For short kernels, we unroll the inner do loop into a single statement to +# reduce loop overhead. +# +# Example: npix=10, kpix=5, 2 pixels out of bounds on either end. +# in[1] corresponds to x = -1 +# +# -1 0 1 2 3 4 5 6 7 8 9 10 11 12 (x coord) +# 1 2 3 4 5 +# 1 2 3 4 5 +# ... +# 1 2 3 4 5 + +procedure acnvl (in, out, npix, kernel, knpix) + +long in[npix+knpix-1] # input vector, including boundary pixels +long out[ARB] # output vector +int npix # length of output vector +long kernel[knpix] # convolution kernel +int knpix # size of convolution kernel + +int i, j +long sum, k1, k2, k3, k4, k5 + +begin + switch (knpix) { + case 3: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + case 5: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + k4 = kernel[4] + k5 = kernel[5] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + + k4 * in[i+3] + k5 * in[i+4] + default: + do i = 1, npix { + sum = out[i] + do j = 1, knpix + sum = sum + (kernel[j] * in[i+j-1]) + out[i] = sum + } + } +end diff --git a/sys/vops/ak/acnvr.x b/sys/vops/ak/acnvr.x new file mode 100644 index 00000000..b1119c29 --- /dev/null +++ b/sys/vops/ak/acnvr.x @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACNV -- Vector convolution. The output vector is equal to the sum of its +# initial value and the convolution of the input vector with the kernel. +# This routine assumes boundary extension on the input vector has been provided. +# For short kernels, we unroll the inner do loop into a single statement to +# reduce loop overhead. +# +# Example: npix=10, kpix=5, 2 pixels out of bounds on either end. +# in[1] corresponds to x = -1 +# +# -1 0 1 2 3 4 5 6 7 8 9 10 11 12 (x coord) +# 1 2 3 4 5 +# 1 2 3 4 5 +# ... +# 1 2 3 4 5 + +procedure acnvr (in, out, npix, kernel, knpix) + +real in[npix+knpix-1] # input vector, including boundary pixels +real out[ARB] # output vector +int npix # length of output vector +real kernel[knpix] # convolution kernel +int knpix # size of convolution kernel + +int i, j +real sum, k1, k2, k3, k4, k5 + +begin + switch (knpix) { + case 3: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + case 5: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + k4 = kernel[4] + k5 = kernel[5] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + + k4 * in[i+3] + k5 * in[i+4] + default: + do i = 1, npix { + sum = out[i] + do j = 1, knpix + sum = sum + (kernel[j] * in[i+j-1]) + out[i] = sum + } + } +end diff --git a/sys/vops/ak/acnvrd.x b/sys/vops/ak/acnvrd.x new file mode 100644 index 00000000..c6b3fb2f --- /dev/null +++ b/sys/vops/ak/acnvrd.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACNVR -- Vector convolution with a real kernel. The output vector is equal +# to the sum of its initial value and the convolution of the input vector with +# the kernel. This routine assumes boundary extension on the input vector has +# been provided. +# +# Example: npix=10, kpix=5, 2 pixels out of bounds on either end. +# in[1] corresponds to x = -1 +# +# -1 0 1 2 3 4 5 6 7 8 9 10 11 12 (x coord) +# 1 2 3 4 5 +# 1 2 3 4 5 +# ... +# 1 2 3 4 5 +# +# See also acnv_, if the kernel is the same datatype as the data vectors. + +procedure acnvrd (in, out, npix, kernel, knpix) + +double in[npix+knpix-1] # input vector, including boundary pixels +double out[ARB] # output vector +int npix # length of output vector +real kernel[knpix] # convolution kernel, always type real +int knpix # size of convolution kernel + +int i, j +real sum, k1, k2, k3, k4, k5 + +begin + switch (knpix) { + case 3: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + case 5: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + k4 = kernel[4] + k5 = kernel[5] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + + k4 * in[i+3] + k5 * in[i+4] + default: + do i = 1, npix { + sum = out[i] + do j = 1, knpix + sum = sum + (kernel[j] * in[i+j-1]) + out[i] = sum + } + } +end diff --git a/sys/vops/ak/acnvri.x b/sys/vops/ak/acnvri.x new file mode 100644 index 00000000..290c093b --- /dev/null +++ b/sys/vops/ak/acnvri.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACNVR -- Vector convolution with a real kernel. The output vector is equal +# to the sum of its initial value and the convolution of the input vector with +# the kernel. This routine assumes boundary extension on the input vector has +# been provided. +# +# Example: npix=10, kpix=5, 2 pixels out of bounds on either end. +# in[1] corresponds to x = -1 +# +# -1 0 1 2 3 4 5 6 7 8 9 10 11 12 (x coord) +# 1 2 3 4 5 +# 1 2 3 4 5 +# ... +# 1 2 3 4 5 +# +# See also acnv_, if the kernel is the same datatype as the data vectors. + +procedure acnvri (in, out, npix, kernel, knpix) + +int in[npix+knpix-1] # input vector, including boundary pixels +int out[ARB] # output vector +int npix # length of output vector +real kernel[knpix] # convolution kernel, always type real +int knpix # size of convolution kernel + +int i, j +real sum, k1, k2, k3, k4, k5 + +begin + switch (knpix) { + case 3: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + case 5: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + k4 = kernel[4] + k5 = kernel[5] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + + k4 * in[i+3] + k5 * in[i+4] + default: + do i = 1, npix { + sum = out[i] + do j = 1, knpix + sum = sum + (kernel[j] * in[i+j-1]) + out[i] = sum + } + } +end diff --git a/sys/vops/ak/acnvrl.x b/sys/vops/ak/acnvrl.x new file mode 100644 index 00000000..44df6dad --- /dev/null +++ b/sys/vops/ak/acnvrl.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACNVR -- Vector convolution with a real kernel. The output vector is equal +# to the sum of its initial value and the convolution of the input vector with +# the kernel. This routine assumes boundary extension on the input vector has +# been provided. +# +# Example: npix=10, kpix=5, 2 pixels out of bounds on either end. +# in[1] corresponds to x = -1 +# +# -1 0 1 2 3 4 5 6 7 8 9 10 11 12 (x coord) +# 1 2 3 4 5 +# 1 2 3 4 5 +# ... +# 1 2 3 4 5 +# +# See also acnv_, if the kernel is the same datatype as the data vectors. + +procedure acnvrl (in, out, npix, kernel, knpix) + +long in[npix+knpix-1] # input vector, including boundary pixels +long out[ARB] # output vector +int npix # length of output vector +real kernel[knpix] # convolution kernel, always type real +int knpix # size of convolution kernel + +int i, j +real sum, k1, k2, k3, k4, k5 + +begin + switch (knpix) { + case 3: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + case 5: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + k4 = kernel[4] + k5 = kernel[5] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + + k4 * in[i+3] + k5 * in[i+4] + default: + do i = 1, npix { + sum = out[i] + do j = 1, knpix + sum = sum + (kernel[j] * in[i+j-1]) + out[i] = sum + } + } +end diff --git a/sys/vops/ak/acnvrr.x b/sys/vops/ak/acnvrr.x new file mode 100644 index 00000000..83f4143c --- /dev/null +++ b/sys/vops/ak/acnvrr.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACNVR -- Vector convolution with a real kernel. The output vector is equal +# to the sum of its initial value and the convolution of the input vector with +# the kernel. This routine assumes boundary extension on the input vector has +# been provided. +# +# Example: npix=10, kpix=5, 2 pixels out of bounds on either end. +# in[1] corresponds to x = -1 +# +# -1 0 1 2 3 4 5 6 7 8 9 10 11 12 (x coord) +# 1 2 3 4 5 +# 1 2 3 4 5 +# ... +# 1 2 3 4 5 +# +# See also acnv_, if the kernel is the same datatype as the data vectors. + +procedure acnvrr (in, out, npix, kernel, knpix) + +real in[npix+knpix-1] # input vector, including boundary pixels +real out[ARB] # output vector +int npix # length of output vector +real kernel[knpix] # convolution kernel, always type real +int knpix # size of convolution kernel + +int i, j +real sum, k1, k2, k3, k4, k5 + +begin + switch (knpix) { + case 3: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + case 5: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + k4 = kernel[4] + k5 = kernel[5] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + + k4 * in[i+3] + k5 * in[i+4] + default: + do i = 1, npix { + sum = out[i] + do j = 1, knpix + sum = sum + (kernel[j] * in[i+j-1]) + out[i] = sum + } + } +end diff --git a/sys/vops/ak/acnvrs.x b/sys/vops/ak/acnvrs.x new file mode 100644 index 00000000..b00d4a92 --- /dev/null +++ b/sys/vops/ak/acnvrs.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACNVR -- Vector convolution with a real kernel. The output vector is equal +# to the sum of its initial value and the convolution of the input vector with +# the kernel. This routine assumes boundary extension on the input vector has +# been provided. +# +# Example: npix=10, kpix=5, 2 pixels out of bounds on either end. +# in[1] corresponds to x = -1 +# +# -1 0 1 2 3 4 5 6 7 8 9 10 11 12 (x coord) +# 1 2 3 4 5 +# 1 2 3 4 5 +# ... +# 1 2 3 4 5 +# +# See also acnv_, if the kernel is the same datatype as the data vectors. + +procedure acnvrs (in, out, npix, kernel, knpix) + +short in[npix+knpix-1] # input vector, including boundary pixels +short out[ARB] # output vector +int npix # length of output vector +real kernel[knpix] # convolution kernel, always type real +int knpix # size of convolution kernel + +int i, j +real sum, k1, k2, k3, k4, k5 + +begin + switch (knpix) { + case 3: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + case 5: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + k4 = kernel[4] + k5 = kernel[5] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + + k4 * in[i+3] + k5 * in[i+4] + default: + do i = 1, npix { + sum = out[i] + do j = 1, knpix + sum = sum + (kernel[j] * in[i+j-1]) + out[i] = sum + } + } +end diff --git a/sys/vops/ak/acnvs.x b/sys/vops/ak/acnvs.x new file mode 100644 index 00000000..9a11eda9 --- /dev/null +++ b/sys/vops/ak/acnvs.x @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ACNV -- Vector convolution. The output vector is equal to the sum of its +# initial value and the convolution of the input vector with the kernel. +# This routine assumes boundary extension on the input vector has been provided. +# For short kernels, we unroll the inner do loop into a single statement to +# reduce loop overhead. +# +# Example: npix=10, kpix=5, 2 pixels out of bounds on either end. +# in[1] corresponds to x = -1 +# +# -1 0 1 2 3 4 5 6 7 8 9 10 11 12 (x coord) +# 1 2 3 4 5 +# 1 2 3 4 5 +# ... +# 1 2 3 4 5 + +procedure acnvs (in, out, npix, kernel, knpix) + +short in[npix+knpix-1] # input vector, including boundary pixels +short out[ARB] # output vector +int npix # length of output vector +short kernel[knpix] # convolution kernel +int knpix # size of convolution kernel + +int i, j +short sum, k1, k2, k3, k4, k5 + +begin + switch (knpix) { + case 3: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + case 5: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + k4 = kernel[4] + k5 = kernel[5] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + k2 * in[i+1] + k3 * in[i+2] + + k4 * in[i+3] + k5 * in[i+4] + default: + do i = 1, npix { + sum = out[i] + do j = 1, knpix + sum = sum + (kernel[j] * in[i+j-1]) + out[i] = sum + } + } +end diff --git a/sys/vops/ak/adivd.x b/sys/vops/ak/adivd.x new file mode 100644 index 00000000..73f43925 --- /dev/null +++ b/sys/vops/ak/adivd.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADIV -- Divide two vectors (generic). No divide by zero checking is +# performed. If this is desired, advz should be used instead. + +procedure adivd (a, b, c, npix) + +double a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] / b[i] +end diff --git a/sys/vops/ak/adivi.x b/sys/vops/ak/adivi.x new file mode 100644 index 00000000..2237363b --- /dev/null +++ b/sys/vops/ak/adivi.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADIV -- Divide two vectors (generic). No divide by zero checking is +# performed. If this is desired, advz should be used instead. + +procedure adivi (a, b, c, npix) + +int a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] / b[i] +end diff --git a/sys/vops/ak/adivkd.x b/sys/vops/ak/adivkd.x new file mode 100644 index 00000000..3758ab33 --- /dev/null +++ b/sys/vops/ak/adivkd.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADIVK -- Divide a vector by a constant (generic). No divide by zero checking +# is performed. + +procedure adivkd (a, b, c, npix) + +double a[ARB] +double b +double c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] / b +end diff --git a/sys/vops/ak/adivki.x b/sys/vops/ak/adivki.x new file mode 100644 index 00000000..ef4a3949 --- /dev/null +++ b/sys/vops/ak/adivki.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADIVK -- Divide a vector by a constant (generic). No divide by zero checking +# is performed. + +procedure adivki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] / b +end diff --git a/sys/vops/ak/adivkl.x b/sys/vops/ak/adivkl.x new file mode 100644 index 00000000..cb1ae2e4 --- /dev/null +++ b/sys/vops/ak/adivkl.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADIVK -- Divide a vector by a constant (generic). No divide by zero checking +# is performed. + +procedure adivkl (a, b, c, npix) + +long a[ARB] +long b +long c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] / b +end diff --git a/sys/vops/ak/adivkr.x b/sys/vops/ak/adivkr.x new file mode 100644 index 00000000..5f47c21e --- /dev/null +++ b/sys/vops/ak/adivkr.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADIVK -- Divide a vector by a constant (generic). No divide by zero checking +# is performed. + +procedure adivkr (a, b, c, npix) + +real a[ARB] +real b +real c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] / b +end diff --git a/sys/vops/ak/adivks.x b/sys/vops/ak/adivks.x new file mode 100644 index 00000000..cb821d21 --- /dev/null +++ b/sys/vops/ak/adivks.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADIVK -- Divide a vector by a constant (generic). No divide by zero checking +# is performed. + +procedure adivks (a, b, c, npix) + +short a[ARB] +short b +short c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] / b +end diff --git a/sys/vops/ak/adivkx.x b/sys/vops/ak/adivkx.x new file mode 100644 index 00000000..c11a4bfd --- /dev/null +++ b/sys/vops/ak/adivkx.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADIVK -- Divide a vector by a constant (generic). No divide by zero checking +# is performed. + +procedure adivkx (a, b, c, npix) + +complex a[ARB] +complex b +complex c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] / b +end diff --git a/sys/vops/ak/adivl.x b/sys/vops/ak/adivl.x new file mode 100644 index 00000000..b449bd31 --- /dev/null +++ b/sys/vops/ak/adivl.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADIV -- Divide two vectors (generic). No divide by zero checking is +# performed. If this is desired, advz should be used instead. + +procedure adivl (a, b, c, npix) + +long a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] / b[i] +end diff --git a/sys/vops/ak/adivr.x b/sys/vops/ak/adivr.x new file mode 100644 index 00000000..323d6e55 --- /dev/null +++ b/sys/vops/ak/adivr.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADIV -- Divide two vectors (generic). No divide by zero checking is +# performed. If this is desired, advz should be used instead. + +procedure adivr (a, b, c, npix) + +real a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] / b[i] +end diff --git a/sys/vops/ak/adivs.x b/sys/vops/ak/adivs.x new file mode 100644 index 00000000..ed8785bb --- /dev/null +++ b/sys/vops/ak/adivs.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADIV -- Divide two vectors (generic). No divide by zero checking is +# performed. If this is desired, advz should be used instead. + +procedure adivs (a, b, c, npix) + +short a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] / b[i] +end diff --git a/sys/vops/ak/adivx.x b/sys/vops/ak/adivx.x new file mode 100644 index 00000000..1aa3013c --- /dev/null +++ b/sys/vops/ak/adivx.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADIV -- Divide two vectors (generic). No divide by zero checking is +# performed. If this is desired, advz should be used instead. + +procedure adivx (a, b, c, npix) + +complex a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] / b[i] +end diff --git a/sys/vops/ak/adotd.x b/sys/vops/ak/adotd.x new file mode 100644 index 00000000..167a82b8 --- /dev/null +++ b/sys/vops/ak/adotd.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADOT -- Vector inner or dot product. The function value is the sum of the +# products of each pair of elements of the input vectors. + +double procedure adotd (a, b, npix) + +double a[ARB], b[ARB] + +double sum + +int npix, i + +begin + sum = 0.0D0 + do i = 1, npix + sum = sum + a[i] * b[i] + + return (sum) +end diff --git a/sys/vops/ak/adoti.x b/sys/vops/ak/adoti.x new file mode 100644 index 00000000..7bb6bf29 --- /dev/null +++ b/sys/vops/ak/adoti.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADOT -- Vector inner or dot product. The function value is the sum of the +# products of each pair of elements of the input vectors. + +real procedure adoti (a, b, npix) + +int a[ARB], b[ARB] + +real sum + +int npix, i + +begin + sum = 0 + do i = 1, npix + sum = sum + a[i] * b[i] + + return (sum) +end diff --git a/sys/vops/ak/adotl.x b/sys/vops/ak/adotl.x new file mode 100644 index 00000000..0df6d038 --- /dev/null +++ b/sys/vops/ak/adotl.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADOT -- Vector inner or dot product. The function value is the sum of the +# products of each pair of elements of the input vectors. + +double procedure adotl (a, b, npix) + +long a[ARB], b[ARB] + +double sum + +int npix, i + +begin + sum = 0 + do i = 1, npix + sum = sum + a[i] * b[i] + + return (sum) +end diff --git a/sys/vops/ak/adotr.x b/sys/vops/ak/adotr.x new file mode 100644 index 00000000..309c4f83 --- /dev/null +++ b/sys/vops/ak/adotr.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADOT -- Vector inner or dot product. The function value is the sum of the +# products of each pair of elements of the input vectors. + +real procedure adotr (a, b, npix) + +real a[ARB], b[ARB] + +real sum + +int npix, i + +begin + sum = 0.0 + do i = 1, npix + sum = sum + a[i] * b[i] + + return (sum) +end diff --git a/sys/vops/ak/adots.x b/sys/vops/ak/adots.x new file mode 100644 index 00000000..391fb7ca --- /dev/null +++ b/sys/vops/ak/adots.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADOT -- Vector inner or dot product. The function value is the sum of the +# products of each pair of elements of the input vectors. + +real procedure adots (a, b, npix) + +short a[ARB], b[ARB] + +real sum + +int npix, i + +begin + sum = 0 + do i = 1, npix + sum = sum + a[i] * b[i] + + return (sum) +end diff --git a/sys/vops/ak/adotx.x b/sys/vops/ak/adotx.x new file mode 100644 index 00000000..42006e3d --- /dev/null +++ b/sys/vops/ak/adotx.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADOT -- Vector inner or dot product. The function value is the sum of the +# products of each pair of elements of the input vectors. + +real procedure adotx (a, b, npix) + +complex a[ARB], b[ARB] + +real sum + +int npix, i + +begin + sum = (0.0,0.0) + do i = 1, npix + sum = sum + a[i] * b[i] + + return (sum) +end diff --git a/sys/vops/ak/advzd.x b/sys/vops/ak/advzd.x new file mode 100644 index 00000000..ca5bb0da --- /dev/null +++ b/sys/vops/ak/advzd.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADVZ -- Vector divide with checking for zero divisors. If the result of a +# divide would be undefined a user supplied function is called to get the +# output pixel value. +# +# NOTE: in the interests of simplicity a somewhat arbitrary tolerance is used +# to check for an undefined divide, i.e., a divide by zero or a divide by a +# number small enough to cause floating point overflow. A better way to do +# this would be to provide a machine dependent version of this operator in +# host$as which catches the hardware exception rather than using a comparison. + +procedure advzd (a, b, c, npix, errfcn) + +double a[ARB], b[ARB], c[ARB] # numerator, divisor, and output arrays +int npix # number of pixels +double errfcn() # user function, called on divide by zero + +int i +double divisor +double tol +extern errfcn() +errchk errfcn + +begin + tol = 1.0D-20 + + do i = 1, npix { + divisor = b[i] + # The following is most efficient when the data tends to be + # positive. + + if (divisor < tol) + if (divisor > -tol) { + c[i] = errfcn (a[i]) + next + } + c[i] = a[i] / divisor + + } +end diff --git a/sys/vops/ak/advzi.x b/sys/vops/ak/advzi.x new file mode 100644 index 00000000..5aa0810e --- /dev/null +++ b/sys/vops/ak/advzi.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADVZ -- Vector divide with checking for zero divisors. If the result of a +# divide would be undefined a user supplied function is called to get the +# output pixel value. +# +# NOTE: in the interests of simplicity a somewhat arbitrary tolerance is used +# to check for an undefined divide, i.e., a divide by zero or a divide by a +# number small enough to cause floating point overflow. A better way to do +# this would be to provide a machine dependent version of this operator in +# host$as which catches the hardware exception rather than using a comparison. + +procedure advzi (a, b, c, npix, errfcn) + +int a[ARB], b[ARB], c[ARB] # numerator, divisor, and output arrays +int npix # number of pixels +int errfcn() # user function, called on divide by zero + +int i +int divisor +extern errfcn() +errchk errfcn + +begin + + do i = 1, npix { + divisor = b[i] + if (divisor == 0) + c[i] = errfcn (a[i]) + else + c[i] = a[i] / divisor + } +end diff --git a/sys/vops/ak/advzl.x b/sys/vops/ak/advzl.x new file mode 100644 index 00000000..22f1a278 --- /dev/null +++ b/sys/vops/ak/advzl.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADVZ -- Vector divide with checking for zero divisors. If the result of a +# divide would be undefined a user supplied function is called to get the +# output pixel value. +# +# NOTE: in the interests of simplicity a somewhat arbitrary tolerance is used +# to check for an undefined divide, i.e., a divide by zero or a divide by a +# number small enough to cause floating point overflow. A better way to do +# this would be to provide a machine dependent version of this operator in +# host$as which catches the hardware exception rather than using a comparison. + +procedure advzl (a, b, c, npix, errfcn) + +long a[ARB], b[ARB], c[ARB] # numerator, divisor, and output arrays +int npix # number of pixels +long errfcn() # user function, called on divide by zero + +int i +long divisor +extern errfcn() +errchk errfcn + +begin + + do i = 1, npix { + divisor = b[i] + if (divisor == 0) + c[i] = errfcn (a[i]) + else + c[i] = a[i] / divisor + } +end diff --git a/sys/vops/ak/advzr.x b/sys/vops/ak/advzr.x new file mode 100644 index 00000000..deb36e3c --- /dev/null +++ b/sys/vops/ak/advzr.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADVZ -- Vector divide with checking for zero divisors. If the result of a +# divide would be undefined a user supplied function is called to get the +# output pixel value. +# +# NOTE: in the interests of simplicity a somewhat arbitrary tolerance is used +# to check for an undefined divide, i.e., a divide by zero or a divide by a +# number small enough to cause floating point overflow. A better way to do +# this would be to provide a machine dependent version of this operator in +# host$as which catches the hardware exception rather than using a comparison. + +procedure advzr (a, b, c, npix, errfcn) + +real a[ARB], b[ARB], c[ARB] # numerator, divisor, and output arrays +int npix # number of pixels +real errfcn() # user function, called on divide by zero + +int i +real divisor +real tol +extern errfcn() +errchk errfcn + +begin + tol = 1.0E-20 + + do i = 1, npix { + divisor = b[i] + # The following is most efficient when the data tends to be + # positive. + + if (divisor < tol) + if (divisor > -tol) { + c[i] = errfcn (a[i]) + next + } + c[i] = a[i] / divisor + + } +end diff --git a/sys/vops/ak/advzs.x b/sys/vops/ak/advzs.x new file mode 100644 index 00000000..98a9603f --- /dev/null +++ b/sys/vops/ak/advzs.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADVZ -- Vector divide with checking for zero divisors. If the result of a +# divide would be undefined a user supplied function is called to get the +# output pixel value. +# +# NOTE: in the interests of simplicity a somewhat arbitrary tolerance is used +# to check for an undefined divide, i.e., a divide by zero or a divide by a +# number small enough to cause floating point overflow. A better way to do +# this would be to provide a machine dependent version of this operator in +# host$as which catches the hardware exception rather than using a comparison. + +procedure advzs (a, b, c, npix, errfcn) + +short a[ARB], b[ARB], c[ARB] # numerator, divisor, and output arrays +int npix # number of pixels +short errfcn() # user function, called on divide by zero + +int i +short divisor +extern errfcn() +errchk errfcn + +begin + + do i = 1, npix { + divisor = b[i] + if (divisor == 0) + c[i] = errfcn (a[i]) + else + c[i] = a[i] / divisor + } +end diff --git a/sys/vops/ak/advzx.x b/sys/vops/ak/advzx.x new file mode 100644 index 00000000..e6089049 --- /dev/null +++ b/sys/vops/ak/advzx.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ADVZ -- Vector divide with checking for zero divisors. If the result of a +# divide would be undefined a user supplied function is called to get the +# output pixel value. +# +# NOTE: in the interests of simplicity a somewhat arbitrary tolerance is used +# to check for an undefined divide, i.e., a divide by zero or a divide by a +# number small enough to cause floating point overflow. A better way to do +# this would be to provide a machine dependent version of this operator in +# host$as which catches the hardware exception rather than using a comparison. + +procedure advzx (a, b, c, npix, errfcn) + +complex a[ARB], b[ARB], c[ARB] # numerator, divisor, and output arrays +int npix # number of pixels +complex errfcn() # user function, called on divide by zero + +int i +complex divisor +extern errfcn() +errchk errfcn + +begin + + do i = 1, npix { + divisor = b[i] + if (divisor == (0.0,0.0)) + c[i] = errfcn (a[i]) + else + c[i] = a[i] / divisor + } +end diff --git a/sys/vops/ak/aexpd.x b/sys/vops/ak/aexpd.x new file mode 100644 index 00000000..f0278777 --- /dev/null +++ b/sys/vops/ak/aexpd.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AEXP -- Compute a ** b, where b is of type PIXEL (generic). + +procedure aexpd (a, b, c, npix) + +double a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b[i] +end diff --git a/sys/vops/ak/aexpi.x b/sys/vops/ak/aexpi.x new file mode 100644 index 00000000..0e332a9a --- /dev/null +++ b/sys/vops/ak/aexpi.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AEXP -- Compute a ** b, where b is of type PIXEL (generic). + +procedure aexpi (a, b, c, npix) + +int a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b[i] +end diff --git a/sys/vops/ak/aexpkd.x b/sys/vops/ak/aexpkd.x new file mode 100644 index 00000000..7c6f58b9 --- /dev/null +++ b/sys/vops/ak/aexpkd.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AEXPK -- Compute a ** b, where b is a constant of type PIXEL (generic). + +procedure aexpkd (a, b, c, npix) + +double a[ARB] +double b +double c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b +end diff --git a/sys/vops/ak/aexpki.x b/sys/vops/ak/aexpki.x new file mode 100644 index 00000000..609b73c1 --- /dev/null +++ b/sys/vops/ak/aexpki.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AEXPK -- Compute a ** b, where b is a constant of type PIXEL (generic). + +procedure aexpki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b +end diff --git a/sys/vops/ak/aexpkl.x b/sys/vops/ak/aexpkl.x new file mode 100644 index 00000000..941dade0 --- /dev/null +++ b/sys/vops/ak/aexpkl.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AEXPK -- Compute a ** b, where b is a constant of type PIXEL (generic). + +procedure aexpkl (a, b, c, npix) + +long a[ARB] +long b +long c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b +end diff --git a/sys/vops/ak/aexpkr.x b/sys/vops/ak/aexpkr.x new file mode 100644 index 00000000..ee083471 --- /dev/null +++ b/sys/vops/ak/aexpkr.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AEXPK -- Compute a ** b, where b is a constant of type PIXEL (generic). + +procedure aexpkr (a, b, c, npix) + +real a[ARB] +real b +real c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b +end diff --git a/sys/vops/ak/aexpks.x b/sys/vops/ak/aexpks.x new file mode 100644 index 00000000..cfcd1218 --- /dev/null +++ b/sys/vops/ak/aexpks.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AEXPK -- Compute a ** b, where b is a constant of type PIXEL (generic). + +procedure aexpks (a, b, c, npix) + +short a[ARB] +short b +short c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b +end diff --git a/sys/vops/ak/aexpkx.x b/sys/vops/ak/aexpkx.x new file mode 100644 index 00000000..4251fca2 --- /dev/null +++ b/sys/vops/ak/aexpkx.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AEXPK -- Compute a ** b, where b is a constant of type PIXEL (generic). + +procedure aexpkx (a, b, c, npix) + +complex a[ARB] +complex b +complex c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b +end diff --git a/sys/vops/ak/aexpl.x b/sys/vops/ak/aexpl.x new file mode 100644 index 00000000..493f7bfa --- /dev/null +++ b/sys/vops/ak/aexpl.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AEXP -- Compute a ** b, where b is of type PIXEL (generic). + +procedure aexpl (a, b, c, npix) + +long a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b[i] +end diff --git a/sys/vops/ak/aexpr.x b/sys/vops/ak/aexpr.x new file mode 100644 index 00000000..3e0877ff --- /dev/null +++ b/sys/vops/ak/aexpr.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AEXP -- Compute a ** b, where b is of type PIXEL (generic). + +procedure aexpr (a, b, c, npix) + +real a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b[i] +end diff --git a/sys/vops/ak/aexps.x b/sys/vops/ak/aexps.x new file mode 100644 index 00000000..e0c47207 --- /dev/null +++ b/sys/vops/ak/aexps.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AEXP -- Compute a ** b, where b is of type PIXEL (generic). + +procedure aexps (a, b, c, npix) + +short a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b[i] +end diff --git a/sys/vops/ak/aexpx.x b/sys/vops/ak/aexpx.x new file mode 100644 index 00000000..84d1e4c6 --- /dev/null +++ b/sys/vops/ak/aexpx.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AEXP -- Compute a ** b, where b is of type PIXEL (generic). + +procedure aexpx (a, b, c, npix) + +complex a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b[i] +end diff --git a/sys/vops/ak/afftrr.x b/sys/vops/ak/afftrr.x new file mode 100644 index 00000000..024f4456 --- /dev/null +++ b/sys/vops/ak/afftrr.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AFFTRR -- Forward fourier transform (real transform, real output arrays). +# The forward transform of the real array SR length NPIX is computed and +# returned in the real arrays FR and FI of length NPIX/2+1. Since the real +# transform is being performed the array SI is ignored and may be omitted. +# The transformation may be performed in place if desired. NPIX must be a +# power of 2. + +procedure afftrr (sr, si, fr, fi, npix) + +real sr[ARB], si[ARB] # spatial data (input). SI NOT USED. +real fr[ARB], fi[ARB] # real and imag parts of transform (output) +int npix +int ier +pointer sp, work + +begin + call smark (sp) + call salloc (work, npix + 2, TY_REAL) + + # Copy the real data vector into the work array. + call amovr (sr, Memr[work], npix) + + # Compute the forward transform. + call ffa (Memr[work], npix, ier) + if (ier == 1) + call fatal (1, "afftrr: npix not a power of 2") + + # Unpack the real and imaginary parts into the output arrays. + call aupxr (Memr[work], fr, fi, npix / 2 + 1) + + call sfree (sp) +end diff --git a/sys/vops/ak/afftrx.x b/sys/vops/ak/afftrx.x new file mode 100644 index 00000000..ec43b16a --- /dev/null +++ b/sys/vops/ak/afftrx.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AFFTRX -- Forward fourier transform (real transform, complex output). +# The fourier transform of the real array A of length NPIX pixels is computed +# and the NPIX/2+1 complex transform coefficients are returned in the complex +# array B. The first element of array B upon output contains the dc term at +# zero frequency, and the remaining elements contain the real and imaginary +# components of the harmonics. The transformation may be performed in place +# if desired. NPIX must be a power of 2. +# +# N.B.: The Fortran 77 standard guarantees that a complex datum is represented +# as two reals, and that the first real in storage order is the real part of +# the complex datum and the second real the imaginary part. We have defined +# B to be a type COMPLEX array in the calling program, but FFA expects a +# REAL array containing (real,imag) pairs. The Fortran standard appears to +# guarantee that this will work. + +procedure afftrx (a, b, npix) + +real a[ARB] # data (input) +complex b[ARB] # transform (output). Dim npix/2+1 +int npix +int ier + +begin + # The following is a no-op if A and B are the same array. + call amovr (a, b, npix) + + # Compute the forward real transform. + call ffa (b, npix, ier) + if (ier == 1) + call fatal (1, "afftrx: npix not a power of 2") +end diff --git a/sys/vops/ak/afftxr.x b/sys/vops/ak/afftxr.x new file mode 100644 index 00000000..b09ae0f5 --- /dev/null +++ b/sys/vops/ak/afftxr.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AFFTXR -- Forward fourier transform (complex transform, real arrays). +# The fourier transform of the real arrays SR and SI containing complex data +# pairs is computed and the complex transform coefficients are returned in +# the real arrays FR and FI. The transformation may be performed in place if +# desired. NPIX must be a power of 2. + +procedure afftxr (sr, si, fr, fi, npix) + +real sr[ARB], si[ARB] # data, spatial domain (input) +real fr[ARB], fi[ARB] # transform, frequency domain (output) +int npix +int ier + +begin + # The following are no-ops if the transform is being performed + # in place. + + call amovr (sr, fr, npix) + call amovr (si, fi, npix) + + # Compute the forward transform. + call fft842 (0, npix, fr, fi, ier) + if (ier == 1) + call fatal (1, "afftxr: npix not a power of 2") +end diff --git a/sys/vops/ak/afftxx.x b/sys/vops/ak/afftxx.x new file mode 100644 index 00000000..34eedbf9 --- /dev/null +++ b/sys/vops/ak/afftxx.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AFFTXX -- Forward fourier transform (complex transform, complex data). +# The fourier transform of the complex array A of length NPIX pixels is +# computed and the NPIX complex transform coefficients are returned in the +# complex array B. The transformation may be performed in place if desired. +# NPIX must be a power of 2. + +procedure afftxx (a, b, npix) + +complex a[ARB] # data (input) +complex b[ARB] # transform (output) +int npix + +int ier +pointer sp, xr, xi + +begin + call smark (sp) + call salloc (xr, npix, TY_REAL) + call salloc (xi, npix, TY_REAL) + + # Rearrange the elements of the A array as required by FFT842. + # Convert the array A of complex values into an array of reals + # and an array of imaginaries. + + call aupxr (a, Memr[xr], Memr[xi], npix) + + # Compute the forward transform. + call fft842 (0, npix, Memr[xr], Memr[xi], ier) + if (ier == 1) + call fatal (1, "afftxx: npix not a power of 2") + + # Repack the real and imaginary arrays to form the complex output + # array. + call apkxr (Memr[xr], Memr[xi], b, npix) + + call sfree (sp) +end diff --git a/sys/vops/ak/agltc.x b/sys/vops/ak/agltc.x new file mode 100644 index 00000000..4f87a8fc --- /dev/null +++ b/sys/vops/ak/agltc.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AGLT -- Given a list of ranges, replace the value of each input pixel +# which falls within a given range by applying the corresponding linear +# transformation (b = a * kmul + kadd). If KMUL is identically zero, +# B is replaced by the constant KADD. + +procedure agltc (a, b, npix, low, high, kmul, kadd, nrange) + +char a[ARB], b[ARB], pixval +int npix, i +char low[nrange], high[nrange] # range limits +real kmul[nrange], kadd[nrange] +int nrange, nr + +begin + do i = 1, npix { + pixval = a[i] + b[i] = pixval + do nr = 1, nrange + if (pixval >= low[nr] && pixval <= high[nr]) { + if (kmul[nr] == 0.0) + b[i] = kadd[nr] + else + b[i] = (pixval * kmul[nr]) + kadd[nr] + break + } + } +end diff --git a/sys/vops/ak/agltd.x b/sys/vops/ak/agltd.x new file mode 100644 index 00000000..c307fe7d --- /dev/null +++ b/sys/vops/ak/agltd.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AGLT -- Given a list of ranges, replace the value of each input pixel +# which falls within a given range by applying the corresponding linear +# transformation (b = a * kmul + kadd). If KMUL is identically zero, +# B is replaced by the constant KADD. + +procedure agltd (a, b, npix, low, high, kmul, kadd, nrange) + +double a[ARB], b[ARB], pixval +int npix, i +double low[nrange], high[nrange] # range limits +double kmul[nrange], kadd[nrange] # linear transformation +int nrange, nr + +begin + do i = 1, npix { + pixval = a[i] + b[i] = pixval + do nr = 1, nrange + if (pixval >= low[nr] && pixval <= high[nr]) { + if (kmul[nr] == 0.0D0) + b[i] = kadd[nr] + else + b[i] = (pixval * kmul[nr]) + kadd[nr] + break + } + } +end diff --git a/sys/vops/ak/aglti.x b/sys/vops/ak/aglti.x new file mode 100644 index 00000000..c37a650e --- /dev/null +++ b/sys/vops/ak/aglti.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AGLT -- Given a list of ranges, replace the value of each input pixel +# which falls within a given range by applying the corresponding linear +# transformation (b = a * kmul + kadd). If KMUL is identically zero, +# B is replaced by the constant KADD. + +procedure aglti (a, b, npix, low, high, kmul, kadd, nrange) + +int a[ARB], b[ARB], pixval +int npix, i +int low[nrange], high[nrange] # range limits +real kmul[nrange], kadd[nrange] +int nrange, nr + +begin + do i = 1, npix { + pixval = a[i] + b[i] = pixval + do nr = 1, nrange + if (pixval >= low[nr] && pixval <= high[nr]) { + if (kmul[nr] == 0.0) + b[i] = kadd[nr] + else + b[i] = (pixval * kmul[nr]) + kadd[nr] + break + } + } +end diff --git a/sys/vops/ak/agltl.x b/sys/vops/ak/agltl.x new file mode 100644 index 00000000..3a416d37 --- /dev/null +++ b/sys/vops/ak/agltl.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AGLT -- Given a list of ranges, replace the value of each input pixel +# which falls within a given range by applying the corresponding linear +# transformation (b = a * kmul + kadd). If KMUL is identically zero, +# B is replaced by the constant KADD. + +procedure agltl (a, b, npix, low, high, kmul, kadd, nrange) + +long a[ARB], b[ARB], pixval +int npix, i +long low[nrange], high[nrange] # range limits +double kmul[nrange], kadd[nrange] # linear transformation +int nrange, nr + +begin + do i = 1, npix { + pixval = a[i] + b[i] = pixval + do nr = 1, nrange + if (pixval >= low[nr] && pixval <= high[nr]) { + if (kmul[nr] == 0.0D0) + b[i] = kadd[nr] + else + b[i] = (pixval * kmul[nr]) + kadd[nr] + break + } + } +end diff --git a/sys/vops/ak/agltr.x b/sys/vops/ak/agltr.x new file mode 100644 index 00000000..974344a4 --- /dev/null +++ b/sys/vops/ak/agltr.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AGLT -- Given a list of ranges, replace the value of each input pixel +# which falls within a given range by applying the corresponding linear +# transformation (b = a * kmul + kadd). If KMUL is identically zero, +# B is replaced by the constant KADD. + +procedure agltr (a, b, npix, low, high, kmul, kadd, nrange) + +real a[ARB], b[ARB], pixval +int npix, i +real low[nrange], high[nrange] # range limits +real kmul[nrange], kadd[nrange] +int nrange, nr + +begin + do i = 1, npix { + pixval = a[i] + b[i] = pixval + do nr = 1, nrange + if (pixval >= low[nr] && pixval <= high[nr]) { + if (kmul[nr] == 0.0) + b[i] = kadd[nr] + else + b[i] = (pixval * kmul[nr]) + kadd[nr] + break + } + } +end diff --git a/sys/vops/ak/aglts.x b/sys/vops/ak/aglts.x new file mode 100644 index 00000000..ba18d1ac --- /dev/null +++ b/sys/vops/ak/aglts.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AGLT -- Given a list of ranges, replace the value of each input pixel +# which falls within a given range by applying the corresponding linear +# transformation (b = a * kmul + kadd). If KMUL is identically zero, +# B is replaced by the constant KADD. + +procedure aglts (a, b, npix, low, high, kmul, kadd, nrange) + +short a[ARB], b[ARB], pixval +int npix, i +short low[nrange], high[nrange] # range limits +real kmul[nrange], kadd[nrange] +int nrange, nr + +begin + do i = 1, npix { + pixval = a[i] + b[i] = pixval + do nr = 1, nrange + if (pixval >= low[nr] && pixval <= high[nr]) { + if (kmul[nr] == 0.0) + b[i] = kadd[nr] + else + b[i] = (pixval * kmul[nr]) + kadd[nr] + break + } + } +end diff --git a/sys/vops/ak/agltx.x b/sys/vops/ak/agltx.x new file mode 100644 index 00000000..c50cfccf --- /dev/null +++ b/sys/vops/ak/agltx.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AGLT -- Given a list of ranges, replace the value of each input pixel +# which falls within a given range by applying the corresponding linear +# transformation (b = a * kmul + kadd). If KMUL is identically zero, +# B is replaced by the constant KADD. + +procedure agltx (a, b, npix, low, high, kmul, kadd, nrange) + +complex a[ARB], b[ARB], pixval +int npix, i +complex low[nrange], high[nrange] # range limits +real kmul[nrange], kadd[nrange] +real abs_pixval +int nrange, nr + +begin + do i = 1, npix { + pixval = a[i] + b[i] = pixval + abs_pixval = abs (pixval) + do nr = 1, nrange + if (abs_pixval >= abs (low[nr]) && + abs_pixval <= abs (high[nr])) { + if (kmul[nr] == 0.0) + b[i] = kadd[nr] + else + b[i] = (pixval * kmul[nr]) + kadd[nr] + break + } + } +end diff --git a/sys/vops/ak/ahgmc.x b/sys/vops/ak/ahgmc.x new file mode 100644 index 00000000..b0917e8f --- /dev/null +++ b/sys/vops/ak/ahgmc.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# AHGM -- Accumulate the histogram of the input vector. The output vector +# HGM (the histogram) should be cleared prior to the first call. + +procedure ahgmc (data, npix, hgm, nbins, z1, z2) + +char data[ARB] # data vector +int npix # number of pixels +int hgm[ARB] # output histogram +int nbins # number of bins in histogram +char z1, z2 # greyscale values of first and last bins + +char z +real dz +int bin, i + +begin + dz = real (nbins - 1) / real (z2 - z1) + if (abs (dz - 1.0) < (EPSILONR * 2.0)) { + do i = 1, npix { + z = data[i] + if (z >= z1 && z <= z2) { + bin = int (z - z1) + 1 + hgm[bin] = hgm[bin] + 1 + } + } + } else { + do i = 1, npix { + z = data[i] + if (z >= z1 && z <= z2) { + bin = int ((z - z1) * dz) + 1 + hgm[bin] = hgm[bin] + 1 + } + } + } +end diff --git a/sys/vops/ak/ahgmd.x b/sys/vops/ak/ahgmd.x new file mode 100644 index 00000000..cd75445f --- /dev/null +++ b/sys/vops/ak/ahgmd.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# AHGM -- Accumulate the histogram of the input vector. The output vector +# HGM (the histogram) should be cleared prior to the first call. + +procedure ahgmd (data, npix, hgm, nbins, z1, z2) + +double data[ARB] # data vector +int npix # number of pixels +int hgm[ARB] # output histogram +int nbins # number of bins in histogram +double z1, z2 # greyscale values of first and last bins + +double z +real dz +int bin, i + +begin + dz = real (nbins - 1) / real (z2 - z1) + if (abs (dz - 1.0) < (EPSILONR * 2.0)) { + do i = 1, npix { + z = data[i] + if (z >= z1 && z <= z2) { + bin = int (z - z1) + 1 + hgm[bin] = hgm[bin] + 1 + } + } + } else { + do i = 1, npix { + z = data[i] + if (z >= z1 && z <= z2) { + bin = int ((z - z1) * dz) + 1 + hgm[bin] = hgm[bin] + 1 + } + } + } +end diff --git a/sys/vops/ak/ahgmi.x b/sys/vops/ak/ahgmi.x new file mode 100644 index 00000000..36c11db8 --- /dev/null +++ b/sys/vops/ak/ahgmi.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# AHGM -- Accumulate the histogram of the input vector. The output vector +# HGM (the histogram) should be cleared prior to the first call. + +procedure ahgmi (data, npix, hgm, nbins, z1, z2) + +int data[ARB] # data vector +int npix # number of pixels +int hgm[ARB] # output histogram +int nbins # number of bins in histogram +int z1, z2 # greyscale values of first and last bins + +int z +real dz +int bin, i + +begin + dz = real (nbins - 1) / real (z2 - z1) + if (abs (dz - 1.0) < (EPSILONR * 2.0)) { + do i = 1, npix { + z = data[i] + if (z >= z1 && z <= z2) { + bin = int (z - z1) + 1 + hgm[bin] = hgm[bin] + 1 + } + } + } else { + do i = 1, npix { + z = data[i] + if (z >= z1 && z <= z2) { + bin = int ((z - z1) * dz) + 1 + hgm[bin] = hgm[bin] + 1 + } + } + } +end diff --git a/sys/vops/ak/ahgml.x b/sys/vops/ak/ahgml.x new file mode 100644 index 00000000..f515a2e4 --- /dev/null +++ b/sys/vops/ak/ahgml.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# AHGM -- Accumulate the histogram of the input vector. The output vector +# HGM (the histogram) should be cleared prior to the first call. + +procedure ahgml (data, npix, hgm, nbins, z1, z2) + +long data[ARB] # data vector +int npix # number of pixels +int hgm[ARB] # output histogram +int nbins # number of bins in histogram +long z1, z2 # greyscale values of first and last bins + +long z +real dz +int bin, i + +begin + dz = real (nbins - 1) / real (z2 - z1) + if (abs (dz - 1.0) < (EPSILONR * 2.0)) { + do i = 1, npix { + z = data[i] + if (z >= z1 && z <= z2) { + bin = int (z - z1) + 1 + hgm[bin] = hgm[bin] + 1 + } + } + } else { + do i = 1, npix { + z = data[i] + if (z >= z1 && z <= z2) { + bin = int ((z - z1) * dz) + 1 + hgm[bin] = hgm[bin] + 1 + } + } + } +end diff --git a/sys/vops/ak/ahgmr.x b/sys/vops/ak/ahgmr.x new file mode 100644 index 00000000..a1f90d67 --- /dev/null +++ b/sys/vops/ak/ahgmr.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# AHGM -- Accumulate the histogram of the input vector. The output vector +# HGM (the histogram) should be cleared prior to the first call. + +procedure ahgmr (data, npix, hgm, nbins, z1, z2) + +real data[ARB] # data vector +int npix # number of pixels +int hgm[ARB] # output histogram +int nbins # number of bins in histogram +real z1, z2 # greyscale values of first and last bins + +real z +real dz +int bin, i + +begin + dz = real (nbins - 1) / real (z2 - z1) + if (abs (dz - 1.0) < (EPSILONR * 2.0)) { + do i = 1, npix { + z = data[i] + if (z >= z1 && z <= z2) { + bin = int (z - z1) + 1 + hgm[bin] = hgm[bin] + 1 + } + } + } else { + do i = 1, npix { + z = data[i] + if (z >= z1 && z <= z2) { + bin = int ((z - z1) * dz) + 1 + hgm[bin] = hgm[bin] + 1 + } + } + } +end diff --git a/sys/vops/ak/ahgms.x b/sys/vops/ak/ahgms.x new file mode 100644 index 00000000..fb656c02 --- /dev/null +++ b/sys/vops/ak/ahgms.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# AHGM -- Accumulate the histogram of the input vector. The output vector +# HGM (the histogram) should be cleared prior to the first call. + +procedure ahgms (data, npix, hgm, nbins, z1, z2) + +short data[ARB] # data vector +int npix # number of pixels +int hgm[ARB] # output histogram +int nbins # number of bins in histogram +short z1, z2 # greyscale values of first and last bins + +short z +real dz +int bin, i + +begin + dz = real (nbins - 1) / real (z2 - z1) + if (abs (dz - 1.0) < (EPSILONR * 2.0)) { + do i = 1, npix { + z = data[i] + if (z >= z1 && z <= z2) { + bin = int (z - z1) + 1 + hgm[bin] = hgm[bin] + 1 + } + } + } else { + do i = 1, npix { + z = data[i] + if (z >= z1 && z <= z2) { + bin = int ((z - z1) * dz) + 1 + hgm[bin] = hgm[bin] + 1 + } + } + } +end diff --git a/sys/vops/ak/ahivc.x b/sys/vops/ak/ahivc.x new file mode 100644 index 00000000..93a39259 --- /dev/null +++ b/sys/vops/ak/ahivc.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AHIV -- Compute the high value (maximum) of a vector. + +char procedure ahivc (a, npix) + +char a[ARB] +int npix +char high, pixval +int i + +begin + high = a[1] + + do i = 1, npix { + pixval = a[i] + if (pixval > high) + high = pixval + } + + return (high) +end diff --git a/sys/vops/ak/ahivd.x b/sys/vops/ak/ahivd.x new file mode 100644 index 00000000..fb851f95 --- /dev/null +++ b/sys/vops/ak/ahivd.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AHIV -- Compute the high value (maximum) of a vector. + +double procedure ahivd (a, npix) + +double a[ARB] +int npix +double high, pixval +int i + +begin + high = a[1] + + do i = 1, npix { + pixval = a[i] + if (pixval > high) + high = pixval + } + + return (high) +end diff --git a/sys/vops/ak/ahivi.x b/sys/vops/ak/ahivi.x new file mode 100644 index 00000000..41effe58 --- /dev/null +++ b/sys/vops/ak/ahivi.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AHIV -- Compute the high value (maximum) of a vector. + +int procedure ahivi (a, npix) + +int a[ARB] +int npix +int high, pixval +int i + +begin + high = a[1] + + do i = 1, npix { + pixval = a[i] + if (pixval > high) + high = pixval + } + + return (high) +end diff --git a/sys/vops/ak/ahivl.x b/sys/vops/ak/ahivl.x new file mode 100644 index 00000000..a6edb516 --- /dev/null +++ b/sys/vops/ak/ahivl.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AHIV -- Compute the high value (maximum) of a vector. + +long procedure ahivl (a, npix) + +long a[ARB] +int npix +long high, pixval +int i + +begin + high = a[1] + + do i = 1, npix { + pixval = a[i] + if (pixval > high) + high = pixval + } + + return (high) +end diff --git a/sys/vops/ak/ahivr.x b/sys/vops/ak/ahivr.x new file mode 100644 index 00000000..0485e6bf --- /dev/null +++ b/sys/vops/ak/ahivr.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AHIV -- Compute the high value (maximum) of a vector. + +real procedure ahivr (a, npix) + +real a[ARB] +int npix +real high, pixval +int i + +begin + high = a[1] + + do i = 1, npix { + pixval = a[i] + if (pixval > high) + high = pixval + } + + return (high) +end diff --git a/sys/vops/ak/ahivs.x b/sys/vops/ak/ahivs.x new file mode 100644 index 00000000..2613473f --- /dev/null +++ b/sys/vops/ak/ahivs.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AHIV -- Compute the high value (maximum) of a vector. + +short procedure ahivs (a, npix) + +short a[ARB] +int npix +short high, pixval +int i + +begin + high = a[1] + + do i = 1, npix { + pixval = a[i] + if (pixval > high) + high = pixval + } + + return (high) +end diff --git a/sys/vops/ak/ahivx.x b/sys/vops/ak/ahivx.x new file mode 100644 index 00000000..b487aa8d --- /dev/null +++ b/sys/vops/ak/ahivx.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AHIV -- Compute the high value (maximum) of a vector. + +complex procedure ahivx (a, npix) + +complex a[ARB] +int npix +complex high, pixval +real abs_high +int i + +begin + high = a[1] + abs_high = abs (high) + + do i = 1, npix { + pixval = a[i] + if (abs (pixval) > abs_high) { + high = pixval + abs_high = abs (high) + } + } + + return (high) +end diff --git a/sys/vops/ak/aiftrr.x b/sys/vops/ak/aiftrr.x new file mode 100644 index 00000000..96789581 --- /dev/null +++ b/sys/vops/ak/aiftrr.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AIFTRR -- Inverse fourier transform (real transform, real output arrays). +# The inverse transform of the real arrays FR and FI of length NPIX/2+1 is +# returned in the real array SR of length NPIX. Since the real inverse +# transform is being performed the array SI is ignored and may be omitted. +# The transformation may be performed in place if desired. NPIX must be a +# power of 2. + +procedure aiftrr (fr, fi, sr, si, npix) + +real fr[ARB], fi[ARB] # real and imag parts of transform (input) +real sr[ARB], si[ARB] # spatial data (output). SI NOT USED. +int npix +int ier +pointer sp, work + +begin + call smark (sp) + call salloc (work, npix + 2, TY_REAL) + + # Pack the real and imaginary parts into a complex array as required + # by FFS. + call apkxr (fr, fi, Memr[work], npix / 2 + 1) + + # Compute the inverse transform. + call ffs (Memr[work], npix, ier) + if (ier == 1) + call fatal (1, "aiftrr: npix not a power of 2") + + # The work array now contains the real part of the transform; merely + # copy it to the output array. + call amovr (Memr[work], sr, npix) + + call sfree (sp) +end diff --git a/sys/vops/ak/aiftrx.x b/sys/vops/ak/aiftrx.x new file mode 100644 index 00000000..63a9d53d --- /dev/null +++ b/sys/vops/ak/aiftrx.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AIFTRX -- Inverse discreet fourier transform (real transform, complex data +# array in). The input array A of length NPIX/2+1 contains the DC term and +# the NPIX/2 (real,imag) pairs for each of the NPIX/2 harmonics of the real +# transform. Upon output array B contains the NPIX real data pixels from the +# inverse transform. The transform may be performed in place if desired. +# +# N.B.: The Fortran 77 standard guarantees that a complex datum is represented +# as two reals, and that the first real in storage order is the real part of +# the complex datum and the second real the imaginary part. We have defined +# B to be a type COMPLEX array in the calling program, but FFS expects a +# REAL array containing (real,imag) pairs. The Fortran standard appears to +# guarantee that this will work. + +procedure aiftrx (a, b, npix) + +complex a[ARB] # transform, npix/2+1 elements +real b[ARB] # output data array +int npix +int ier + +begin + # The following is a no-op if A and B are the same array. + call amovx (a, b, npix / 2 + 1) + + # Compute the inverse real transform. + call ffs (b, npix, ier) + if (ier == 1) + call fatal (1, "afftrx: npix not a power of 2") +end diff --git a/sys/vops/ak/aiftxr.x b/sys/vops/ak/aiftxr.x new file mode 100644 index 00000000..a9647e7c --- /dev/null +++ b/sys/vops/ak/aiftxr.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AIFTXR -- Inverse fourier transform (complex transform, real arrays). +# The inverse transform of the real arrays FR and FI containing complex data +# pairs is computed and the complex spatial data coefficients are returned in +# the real arrays SR and SI. The transformation may be performed in place if +# desired. NPIX must be a power of 2. + +procedure aiftxr (fr, fi, sr, si, npix) + +real fr[ARB], fi[ARB] # transform, frequency domain (input) +real sr[ARB], si[ARB] # data, spatial domain (output) +int npix +int ier + +begin + # The following are no-ops if the transform is being performed + # in place. + + call amovr (fr, sr, npix) + call amovr (fi, si, npix) + + # Compute the inverse transform. + call fft842 (1, npix, sr, si, ier) + if (ier == 1) + call fatal (1, "afftxr: npix not a power of 2") +end diff --git a/sys/vops/ak/aiftxx.x b/sys/vops/ak/aiftxx.x new file mode 100644 index 00000000..2871590f --- /dev/null +++ b/sys/vops/ak/aiftxx.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AIFTXX -- Inverse fourier transform (complex transform, complex array). +# The fourier transform of the complex array A of length NPIX pixels is +# computed and the NPIX complex data points are returned in the complex array +# B. The transformation may be performed in place if desired. NPIX must be +# a power of 2. +# +# N.B.: The Fortran 77 standard guarantees that a complex datum is represented +# as two reals, and that the first real in storage order is the real part of +# the complex datum and the second real the imaginary part. We have defined +# A and B to be type COMPLEX arrays in the calling program, but FFT842 expects +# a REAL array containing (real,imag) pairs. The Fortran standard appears to +# guarantee that this will work. + +procedure aiftxx (a, b, npix) + +complex a[ARB] # transform (input) +complex b[ARB] # data (output) +int npix +int ier +pointer sp, xr, xi + +begin + call smark (sp) + call salloc (xr, npix, TY_REAL) + call salloc (xi, npix, TY_REAL) + + # Rearrange the elements of the A array as required by FFT842. + # Convert the array A of complex values into an array of reals + # and an array of imaginaries. + + call aupxr (a, Memr[xr], Memr[xi], npix) + + # Compute the inverse transform. + call fft842 (1, npix, Memr[xr], Memr[xi], ier) + if (ier == 1) + call fatal (1, "afftxx: npix not a power of 2") + + # Repack the real and imaginary arrays to form the complex output + # array. + call apkxr (Memr[xr], Memr[xi], b, npix) + + call sfree (sp) +end diff --git a/sys/vops/ak/aimgd.x b/sys/vops/ak/aimgd.x new file mode 100644 index 00000000..b99b6aa3 --- /dev/null +++ b/sys/vops/ak/aimgd.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AIMG -- Return the imaginary part of a COMPLEX vector. + +procedure aimgd (a, b, npix) + +complex a[ARB] +double b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = aimag (a[i]) +end diff --git a/sys/vops/ak/aimgi.x b/sys/vops/ak/aimgi.x new file mode 100644 index 00000000..7632f2d0 --- /dev/null +++ b/sys/vops/ak/aimgi.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AIMG -- Return the imaginary part of a COMPLEX vector. + +procedure aimgi (a, b, npix) + +complex a[ARB] +int b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = aimag (a[i]) +end diff --git a/sys/vops/ak/aimgl.x b/sys/vops/ak/aimgl.x new file mode 100644 index 00000000..34958a6a --- /dev/null +++ b/sys/vops/ak/aimgl.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AIMG -- Return the imaginary part of a COMPLEX vector. + +procedure aimgl (a, b, npix) + +complex a[ARB] +long b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = aimag (a[i]) +end diff --git a/sys/vops/ak/aimgr.x b/sys/vops/ak/aimgr.x new file mode 100644 index 00000000..a6e0e910 --- /dev/null +++ b/sys/vops/ak/aimgr.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AIMG -- Return the imaginary part of a COMPLEX vector. + +procedure aimgr (a, b, npix) + +complex a[ARB] +real b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = aimag (a[i]) +end diff --git a/sys/vops/ak/aimgs.x b/sys/vops/ak/aimgs.x new file mode 100644 index 00000000..71dbbe67 --- /dev/null +++ b/sys/vops/ak/aimgs.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AIMG -- Return the imaginary part of a COMPLEX vector. + +procedure aimgs (a, b, npix) + +complex a[ARB] +short b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = aimag (a[i]) +end diff --git a/sys/vops/ak/mkpkg b/sys/vops/ak/mkpkg new file mode 100644 index 00000000..9841f019 --- /dev/null +++ b/sys/vops/ak/mkpkg @@ -0,0 +1,276 @@ +# Make the VOPS vector operators library, procedures a[a-k]*.x. + +$checkout libvops.a lib$ +$update libvops.a +$checkin libvops.a lib$ +$exit + +libvops.a: + aabsd.x + aabsi.x + aabsl.x + aabsr.x + aabss.x + aabsx.x + aaddd.x + aaddi.x + aaddkd.x + aaddki.x + aaddkl.x + aaddkr.x + aaddks.x + aaddkx.x + aaddl.x + aaddr.x + aadds.x + aaddx.x + aandi.x + aandki.x + aandkl.x + aandks.x + aandl.x + aands.x + aavgd.x + aavgi.x + aavgl.x + aavgr.x + aavgs.x + aavgx.x + abavd.x + abavi.x + abavl.x + abavr.x + abavs.x + abavx.x + abeqc.x + abeqd.x + abeqi.x + abeqkc.x + abeqkd.x + abeqki.x + abeqkl.x + abeqkr.x + abeqks.x + abeqkx.x + abeql.x + abeqr.x + abeqs.x + abeqx.x + abgec.x + abged.x + abgei.x + abgekc.x + abgekd.x + abgeki.x + abgekl.x + abgekr.x + abgeks.x + abgekx.x + abgel.x + abger.x + abges.x + abgex.x + abgtc.x + abgtd.x + abgti.x + abgtkc.x + abgtkd.x + abgtki.x + abgtkl.x + abgtkr.x + abgtks.x + abgtkx.x + abgtl.x + abgtr.x + abgts.x + abgtx.x + ablec.x + abled.x + ablei.x + ablekc.x + ablekd.x + ableki.x + ablekl.x + ablekr.x + ableks.x + ablekx.x + ablel.x + abler.x + ables.x + ablex.x + abltc.x + abltd.x + ablti.x + abltkc.x + abltkd.x + abltki.x + abltkl.x + abltkr.x + abltks.x + abltkx.x + abltl.x + abltr.x + ablts.x + abltx.x + abnec.x + abned.x + abnei.x + abnekc.x + abnekd.x + abneki.x + abnekl.x + abnekr.x + abneks.x + abnekx.x + abnel.x + abner.x + abnes.x + abnex.x + abori.x + aborki.x + aborkl.x + aborks.x + aborl.x + abors.x + absud.x + absui.x + absul.x + absur.x + absus.x + achtcc.x + achtcd.x + achtci.x + achtcl.x + achtcr.x + achtcs.x + achtcx.x + achtdc.x + achtdd.x + achtdi.x + achtdl.x + achtdr.x + achtds.x + achtdx.x + achtic.x + achtid.x + achtii.x + achtil.x + achtir.x + achtis.x + achtix.x + achtlc.x + achtld.x + achtli.x + achtll.x + achtlr.x + achtls.x + achtlx.x + achtrc.x + achtrd.x + achtri.x + achtrl.x + achtrr.x + achtrs.x + achtrx.x + achtsc.x + achtsd.x + achtsi.x + achtsl.x + achtsr.x + achtss.x + achtsx.x + achtxc.x + achtxd.x + achtxi.x + achtxl.x + achtxr.x + achtxs.x + achtxx.x + acjgx.x + aclrc.x + aclrd.x + aclri.x + aclrl.x + aclrr.x + aclrs.x + aclrx.x + acnvd.x + acnvi.x + acnvl.x + acnvr.x + acnvrd.x + acnvri.x + acnvrl.x + acnvrr.x + acnvrs.x + acnvs.x + adivd.x + adivi.x + adivkd.x + adivki.x + adivkl.x + adivkr.x + adivks.x + adivkx.x + adivl.x + adivr.x + adivs.x + adivx.x + adotd.x + adoti.x + adotl.x + adotr.x + adots.x + adotx.x + advzd.x + advzi.x + advzl.x + advzr.x + advzs.x + advzx.x + aexpd.x + aexpi.x + aexpkd.x + aexpki.x + aexpkl.x + aexpkr.x + aexpks.x + aexpkx.x + aexpl.x + aexpr.x + aexps.x + aexpx.x + afftrr.x + afftrx.x + afftxr.x + afftxx.x + agltc.x + agltd.x + aglti.x + agltl.x + agltr.x + aglts.x + agltx.x + ahgmc.x + ahgmd.x + ahgmi.x + ahgml.x + ahgmr.x + ahgms.x + ahivc.x + ahivd.x + ahivi.x + ahivl.x + ahivr.x + ahivs.x + ahivx.x + aiftrr.x + aiftrx.x + aiftxr.x + aiftxx.x + aimgd.x + aimgi.x + aimgl.x + aimgr.x + aimgs.x + ; diff --git a/sys/vops/alan.gx b/sys/vops/alan.gx new file mode 100644 index 00000000..43b21069 --- /dev/null +++ b/sys/vops/alan.gx @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALAN -- Compute the logical AND of two vectors (generic). The logical +# output value is returned as an int. + +procedure alan$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB] +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 && b[i] != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/alank.gx b/sys/vops/alank.gx new file mode 100644 index 00000000..a8e3c1b1 --- /dev/null +++ b/sys/vops/alank.gx @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALANK -- Compute the logical AND of a vector and a constant (generic). +# The logical output value is returned as an int. + +procedure alank$t (a, b, c, npix) + +PIXEL a[ARB], b +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 && b != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/alim.gx b/sys/vops/alim.gx new file mode 100644 index 00000000..2e9cbf56 --- /dev/null +++ b/sys/vops/alim.gx @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALIM -- Compute the limits (minimum and maximum values) of a vector. + +procedure alim$t (a, npix, minval, maxval) + +PIXEL a[ARB], minval, maxval, value +int npix, i + +begin + minval = a[1] + maxval = a[1] + + do i = 1, npix { + value = a[i] + $if (datatype == x) + if (abs(value) < abs(minval)) + minval = value + else if (abs(value) > abs(maxval)) + maxval = value + $else + if (value < minval) + minval = value + else if (value > maxval) + maxval = value + $endif + } +end diff --git a/sys/vops/alln.gx b/sys/vops/alln.gx new file mode 100644 index 00000000..7d6ed921 --- /dev/null +++ b/sys/vops/alln.gx @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALLN -- Compute the natural logarithm of a vector (generic). If the natural +# logarithm is undefined (x <= 0) a user supplied function is called to get +# the pixel value to be returned. + +procedure alln$t (a, b, npix, errfcn) + +PIXEL a[ARB], b[ARB] +int npix, i +extern errfcn() +PIXEL errfcn() +errchk errfcn + +begin + do i = 1, npix { + $if (datatype == x) + if (a[i] == 0$f) + $else + if (a[i] <= 0$f) + $endif + b[i] = errfcn (a[i]) + else { + $if (datatype == si) + b[i] = log (real (a[i])) + $else $if (datatype == l) + b[i] = log (double (a[i])) + $else + b[i] = log (a[i]) + $endif $endif + } + } +end diff --git a/sys/vops/alog.gx b/sys/vops/alog.gx new file mode 100644 index 00000000..033f9514 --- /dev/null +++ b/sys/vops/alog.gx @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOG -- Compute the logarithm to the base 10 of a vector (generic). If the +# logarithm is undefined (x <= 0) a user supplied function is called to get +# the function value. + +procedure alog$t (a, b, npix, errfcn) + +PIXEL a[ARB], b[ARB] +int npix, i +extern errfcn() +PIXEL errfcn() +errchk errfcn + +begin + do i = 1, npix { + $if (datatype == x) + if (a[i] == 0$f) + $else + if (a[i] <= 0$f) + $endif + b[i] = errfcn (a[i]) + else { + # Note Fortran standard forbids log10(cplx). + $if (datatype == xsi) + b[i] = log10 (real (a[i])) + $else $if (datatype == l) + b[i] = log10 (double (a[i])) + $else + b[i] = log10 (a[i]) + $endif $endif + } + } +end diff --git a/sys/vops/alor.gx b/sys/vops/alor.gx new file mode 100644 index 00000000..e1f7bd67 --- /dev/null +++ b/sys/vops/alor.gx @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOR -- Compute the logical OR of a vector and a constant (generic). +# The logical output value is returned as an int. + +procedure alor$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB] +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 || b[i] != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/alork.gx b/sys/vops/alork.gx new file mode 100644 index 00000000..ddcd108d --- /dev/null +++ b/sys/vops/alork.gx @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALORK -- Compute the logical OR of a vector and a constant (generic). +# The logical output value is returned as an int. + +procedure alork$t (a, b, c, npix) + +PIXEL a[ARB], b +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 || b != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/alov.gx b/sys/vops/alov.gx new file mode 100644 index 00000000..27a81128 --- /dev/null +++ b/sys/vops/alov.gx @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOV -- Compute the low value (minimum) of a vector. + +PIXEL procedure alov$t (a, npix) + +PIXEL a[ARB] +int npix +PIXEL low, pixval +$if (datatype == x) +real abs_low +$endif +int i + +begin + low = a[1] + $if (datatype == x) + abs_low = abs (low) + $endif + + do i = 1, npix { + pixval = a[i] + $if (datatype == x) + if (abs (pixval) < abs_low) { + low = pixval + abs_low = abs (low) + } + $else + if (pixval < low) + low = pixval + $endif + } + + return (low) +end diff --git a/sys/vops/alta.gx b/sys/vops/alta.gx new file mode 100644 index 00000000..c09bd38f --- /dev/null +++ b/sys/vops/alta.gx @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTA -- Linearly map a vector into another vector of the same datatype. +# b[i] = (a[i] + k1) * k2 + +procedure alta$t (a, b, npix, k1, k2) + +PIXEL a[ARB], b[ARB] +$if (datatype == ld) +double k1, k2 +$else +real k1, k2 +$endif +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 +end diff --git a/sys/vops/altm.gx b/sys/vops/altm.gx new file mode 100644 index 00000000..d0f00f94 --- /dev/null +++ b/sys/vops/altm.gx @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTM -- Linearly map a vector into another vector of the same datatype. +# b[i] = (a[i] * k1) + k2 + +procedure altm$t (a, b, npix, k1, k2) + +PIXEL a[ARB], b[ARB] +$if (datatype == ld) +double k1, k2 +$else +real k1, k2 +$endif +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] * k1) + k2 +end diff --git a/sys/vops/altr.gx b/sys/vops/altr.gx new file mode 100644 index 00000000..866c9e03 --- /dev/null +++ b/sys/vops/altr.gx @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTR -- Linearly map a vector into another vector of the same datatype. +# This is the most general form. See also ALTA and ALTM. +# b[i] = (a[i] + k1) * k2 + k3 + +procedure altr$t (a, b, npix, k1, k2, k3) + +PIXEL a[ARB], b[ARB] +$if (datatype == ld) +double k1, k2, k3 +$else +real k1, k2, k3 +$endif +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 + k3 +end diff --git a/sys/vops/alui.gx b/sys/vops/alui.gx new file mode 100644 index 00000000..535dee9c --- /dev/null +++ b/sys/vops/alui.gx @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ALUI -- Vector lookup and interpolate (linear). B[i] = A(X[i]). +# No bounds checking is performed, but the case A(X[i])=NPIX (no fractional +# part) is recognized and will not cause a reference off the right end of the +# array. This is done in a way which will also cause execution to be faster +# when the sample points are integral, i.e., fall exactly on data points in +# the input array. + +procedure alui$t (a, b, x, npix) + +PIXEL a[ARB], b[ARB] +real x[ARB], fraction, tol +int npix, i, left_pixel + +begin + tol = EPSILONR * 5.0 + + do i = 1, npix { + left_pixel = int (x[i]) + fraction = x[i] - real(left_pixel) + if (fraction < tol) + b[i] = a[left_pixel] + else + b[i] = a[left_pixel] * (1.0 - fraction) + + a[left_pixel+1] * fraction + } +end diff --git a/sys/vops/alut.gx b/sys/vops/alut.gx new file mode 100644 index 00000000..f4e01fb3 --- /dev/null +++ b/sys/vops/alut.gx @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALUT -- Map an array using table lookup. Note that an input value of zero +# indexes the first element of the lookup table. No bounds checking is +# performed. + +procedure alut$t (a, b, npix, lut) + +$if (datatype == rd) +int a[ARB] # input array of indices +$else +PIXEL a[ARB] +$endif + +PIXEL b[ARB] # output data array +PIXEL lut[ARB] # lookup table +int npix, i + +begin + do i = 1, npix + b[i] = lut[a[i]+1] +end diff --git a/sys/vops/amag.gx b/sys/vops/amag.gx new file mode 100644 index 00000000..397a7c25 --- /dev/null +++ b/sys/vops/amag.gx @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAG -- Return the magnitude of two vectors. + +procedure amag$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + $if (datatype == sir) + c[i] = sqrt (real(a[i] ** 2) + real(b[i] ** 2)) + $else $if (datatype == dl) + c[i] = sqrt (double(a[i] ** 2) + double(b[i] ** 2)) + $else + c[i] = sqrt (a[i] ** 2 + b[i] ** 2) + $endif $endif +end diff --git a/sys/vops/amap.gx b/sys/vops/amap.gx new file mode 100644 index 00000000..9006b221 --- /dev/null +++ b/sys/vops/amap.gx @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAP -- Vector linear transformation. Map the range of pixel values +# a1,a2 from a into the range b1,b2 in b. It is assumed that a1 < a2 +# and b1 < b2. + +procedure amap$t (a, b, npix, a1, a2, b1, b2) + +PIXEL a[ARB], b[ARB] +PIXEL a1, a2, b1, b2 + +$if (datatype == sil) +long minout, maxout, aoff, boff, pixval +$else +PIXEL minout, maxout, aoff, boff, pixval +$endif + +$if (datatype == ld) +double scalar +$else +real scalar +$endif + +int npix, i + +begin + $if (datatype == ld) + scalar = (double (b2) - double (b1)) / (double (a2) - double (a1)) + $else + scalar = (real (b2) - real (b1)) / (real (a2) - real (a1)) + $endif + + minout = min (b1, b2) + maxout = max (b1, b2) + aoff = a1 + boff = b1 + + do i = 1, npix { + pixval = (a[i] - aoff) * scalar + b[i] = max(minout, min(maxout, pixval + boff)) + } +end diff --git a/sys/vops/amax.gx b/sys/vops/amax.gx new file mode 100644 index 00000000..ce61b558 --- /dev/null +++ b/sys/vops/amax.gx @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAX -- Compute the maximum of two vectors (generic). + +procedure amax$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + $if (datatype == x) + if (abs(a[i]) >= abs(b[i])) + c[i] = a[i] + else + c[i] = b[i] + $else + c[i] = max (a[i], b[i]) + $endif +end diff --git a/sys/vops/amaxk.gx b/sys/vops/amaxk.gx new file mode 100644 index 00000000..f45bca09 --- /dev/null +++ b/sys/vops/amaxk.gx @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAXK -- Compute the maximum of a constant and a vector (generic). + +procedure amaxk$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +PIXEL c[ARB] +int npix, i +$if (datatype == x) +real abs_b +$endif + +begin + $if (datatype == x) + abs_b = abs (b) + $endif + + do i = 1, npix + $if (datatype == x) + if (abs(a[i]) >= abs_b) + c[i] = a[i] + else + c[i] = b + $else + c[i] = max (a[i], b) + $endif +end diff --git a/sys/vops/amed.gx b/sys/vops/amed.gx new file mode 100644 index 00000000..21a31724 --- /dev/null +++ b/sys/vops/amed.gx @@ -0,0 +1,72 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED -- Vector median selection. The selection is carried out in a temporary +# array, leaving the input vector unmodified. Especially demanding applications +# may wish to call the asok routine directory to avoid the call to the memory +# allocator. + +PIXEL procedure amed$t (a, npix) + +PIXEL a[ARB] +int npix + +pointer sp, aa +PIXEL median +PIXEL asok$t() # select the Kth smallest element from A +$if (datatype == x) +real a1, a2, a3 +$endif + +begin + switch (npix) { + case 1, 2: + return (a[1]) + + case 3: + $if (datatype == x) + a1 = abs (a[1]) + a2 = abs (a[2]) + a3 = abs (a[3]) + if (a1 < a2) { + if (a2 < a3) + return (a[2]) + else if (a1 < a3) + return (a[3]) + else + return (a[1]) + } else { + if (a2 > a3) + return (a[2]) + else if (a1 < a3) + return (a[1]) + else + return (a[3]) + } + $else + if (a[1] < a[2]) { + if (a[2] < a[3]) + return (a[2]) + else if (a[1] < a[3]) + return (a[3]) + else + return (a[1]) + } else { + if (a[2] > a[3]) + return (a[2]) + else if (a[1] < a[3]) + return (a[1]) + else + return (a[3]) + } + $endif + + default: + call smark (sp) + call salloc (aa, npix, TY_PIXEL) + call amov$t (a, Mem$t[aa], npix) + median = asok$t (Mem$t[aa], npix, (npix + 1) / 2) + call sfree (sp) + + return (median) + } +end diff --git a/sys/vops/amed3.gx b/sys/vops/amed3.gx new file mode 100644 index 00000000..37452cb5 --- /dev/null +++ b/sys/vops/amed3.gx @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED3 -- Median of three vectors. Each output point M[i] is the median value +# of the three input points A[i],B[i],C[i]. + +procedure amed3$t (a, b, c, m, npix) + +PIXEL a[ARB], b[ARB], c[ARB] # input vectors +PIXEL m[ARB] # output vector (median) +int npix +int i + +begin + do i = 1, npix + if (a[i] < b[i]) { + if (b[i] < c[i]) # abc + m[i] = b[i] + else if (a[i] < c[i]) # acb + m[i] = c[i] + else # cab + m[i] = a[i] + } else { + if (b[i] > c[i]) # cba + m[i] = b[i] + else if (a[i] > c[i]) # bca + m[i] = c[i] + else # bac + m[i] = a[i] + } +end diff --git a/sys/vops/amed4.gx b/sys/vops/amed4.gx new file mode 100644 index 00000000..fb5fab5e --- /dev/null +++ b/sys/vops/amed4.gx @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED4 -- Median of four vectors. Each output point M[i] is the median of the +# four input points A[i],B[i],C[i],D[i]. The vector min and max are also +# computed and returned in the A and D vectors. The input vectors are modifed +# in place. + +procedure amed4$t (a, b, c, d, m, npix) + +PIXEL a[ARB], b[ARB] # input vectors +PIXEL c[ARB], d[ARB] # input vectors +PIXEL m[ARB] # output vector (median) +int npix + +int i +PIXEL temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + do i = 1, npix { + # Move the minimum value to A[i]. + if (b[i] < a[i]) + swap (b[i], a[i]) + if (c[i] < a[i]) + swap (c[i], a[i]) + if (d[i] < a[i]) + swap (d[i], a[i]) + + # Move the maximum value to D[i]. + if (b[i] > d[i]) + swap (b[i], d[i]) + if (c[i] > d[i]) + swap (c[i], d[i]) + + # Return the median value. + if (b[i] < c[i]) + m[i] = b[i] + else + m[i] = c[i] + } +end diff --git a/sys/vops/amed5.gx b/sys/vops/amed5.gx new file mode 100644 index 00000000..9d81d243 --- /dev/null +++ b/sys/vops/amed5.gx @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED5 -- Median of five vectors. Each output point M[i] is the median of the +# five input points A[i],B[i],C[i],D[i],E[i]. The vector min and max are also +# computed and returned in the A and E vectors. The input vectors are modifed. + +procedure amed5$t (a, b, c, d, e, m, npix) + +PIXEL a[ARB], b[ARB] # input vectors +PIXEL c[ARB], d[ARB], e[ARB] # input vectors +PIXEL m[ARB] # output vector (median) +int npix + +int i +PIXEL temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + do i = 1, npix { + # Move the minimum value to A[i]. + if (b[i] < a[i]) + swap (b[i], a[i]) + if (c[i] < a[i]) + swap (c[i], a[i]) + if (d[i] < a[i]) + swap (d[i], a[i]) + if (e[i] < a[i]) + swap (e[i], a[i]) + + # Move the maximum value to E[i]. + if (b[i] > e[i]) + swap (b[i], e[i]) + if (c[i] > e[i]) + swap (c[i], e[i]) + if (d[i] > e[i]) + swap (d[i], e[i]) + + # Return the median value of the central three points. + if (b[i] < c[i]) { + if (c[i] < d[i]) # bcd + m[i] = c[i] + else if (b[i] < d[i]) # bdc + m[i] = d[i] + else # dbc + m[i] = b[i] + } else { + if (c[i] > d[i]) # dcb + m[i] = c[i] + else if (b[i] > d[i]) # cdb + m[i] = d[i] + else # cbd + m[i] = b[i] + } + } +end diff --git a/sys/vops/amgs.gx b/sys/vops/amgs.gx new file mode 100644 index 00000000..eb7b3124 --- /dev/null +++ b/sys/vops/amgs.gx @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMGS -- Return the square of the magnitude of two vectors. + +procedure amgs$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** 2 + b[i] ** 2 +end diff --git a/sys/vops/amin.gx b/sys/vops/amin.gx new file mode 100644 index 00000000..4d5ad6ea --- /dev/null +++ b/sys/vops/amin.gx @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMIN -- Compute the minimum of two vectors (generic). + +procedure amin$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + $if (datatype == x) + if (abs(a[i]) <= abs(b[i])) + c[i] = a[i] + else + c[i] = b[i] + $else + c[i] = min (a[i], b[i]) + $endif +end diff --git a/sys/vops/amink.gx b/sys/vops/amink.gx new file mode 100644 index 00000000..f2775252 --- /dev/null +++ b/sys/vops/amink.gx @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMINK -- Compute the minimum of a constant and a vector (generic). + +procedure amink$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +PIXEL c[ARB] +int npix, i +$if (datatype == x) +real abs_b +$endif + +begin + $if (datatype == x) + abs_b = abs (b) + $endif + + do i = 1, npix + $if (datatype == x) + if (abs(a[i]) <= abs_b) + c[i] = a[i] + else + c[i] = b + $else + c[i] = min (a[i], b) + $endif +end diff --git a/sys/vops/amod.gx b/sys/vops/amod.gx new file mode 100644 index 00000000..563b3b2a --- /dev/null +++ b/sys/vops/amod.gx @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOD -- Compute the modulus of two vectors (generic). + +procedure amod$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = mod (a[i], b[i]) +end diff --git a/sys/vops/amodk.gx b/sys/vops/amodk.gx new file mode 100644 index 00000000..918eed75 --- /dev/null +++ b/sys/vops/amodk.gx @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMODK -- Compute the modulus of a vector by a constant (generic). + +procedure amodk$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +PIXEL c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = mod (a[i], b) +end diff --git a/sys/vops/amov.gx b/sys/vops/amov.gx new file mode 100644 index 00000000..e500856f --- /dev/null +++ b/sys/vops/amov.gx @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOV -- Copy a vector (generic). The operation is carried out in such +# a way that the result is the same whether or not the output vector +# overlaps the input vector. + +procedure amov$t (a, b, npix) + +PIXEL a[ARB], b[ARB] +int npix, i, a_first, b_first + +begin + call zlocva (a, a_first) + call zlocva (b, b_first) + + if (a_first == b_first) + return + + if (a_first < b_first) { + do i = npix, 1, -1 + b[i] = a[i] + } else { + do i = 1, npix + b[i] = a[i] + } +end diff --git a/sys/vops/amovk.gx b/sys/vops/amovk.gx new file mode 100644 index 00000000..94dfb176 --- /dev/null +++ b/sys/vops/amovk.gx @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOVK -- Copy a constant into a vector (generic). + +procedure amovk$t (a, b, npix) + +PIXEL a +PIXEL b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = a +end diff --git a/sys/vops/amul.gx b/sys/vops/amul.gx new file mode 100644 index 00000000..714454d8 --- /dev/null +++ b/sys/vops/amul.gx @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMUL -- Multiply two vectors (generic). + +procedure amul$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * b[i] +end diff --git a/sys/vops/amulk.gx b/sys/vops/amulk.gx new file mode 100644 index 00000000..276daa90 --- /dev/null +++ b/sys/vops/amulk.gx @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMULK -- Multiply a constant times a vector (generic). + +procedure amulk$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +PIXEL c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * b +end diff --git a/sys/vops/aneg.gx b/sys/vops/aneg.gx new file mode 100644 index 00000000..6b18e520 --- /dev/null +++ b/sys/vops/aneg.gx @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ANEG -- Compute the arithmetic negation of a vector (generic). + +procedure aneg$t (a, b, npix) + +PIXEL a[ARB], b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = -a[i] +end diff --git a/sys/vops/anot.gx b/sys/vops/anot.gx new file mode 100644 index 00000000..08f95a47 --- /dev/null +++ b/sys/vops/anot.gx @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ANOT -- Compute the bitwise boolean complement of a vector (generic). + +procedure anot$t (a, b, npix) + +PIXEL a[ARB], b[ARB] +int npix, i +$if (datatype == i) +int not() +$else +PIXEL not$t() +$endif + +begin + do i = 1, npix { + $if (datatype == i) + b[i] = not (a[i]) + $else + b[i] = not$t (a[i]) + $endif + } +end diff --git a/sys/vops/apkx.gx b/sys/vops/apkx.gx new file mode 100644 index 00000000..904e38d6 --- /dev/null +++ b/sys/vops/apkx.gx @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APKX -- Generate a type COMPLEX output vector given the real and imaginary +# components as input vectors. + +procedure apkx$t (a, b, c, npix) + +PIXEL a[ARB] # real component +PIXEL b[ARB] # imaginary component +complex c[ARB] # output vector +int npix, i + +begin + do i = 1, npix + $if (datatype == x) + c[i] = complex (real(a[i]), aimag(b[i])) + $else + c[i] = complex (real(a[i]), real(b[i])) + $endif +end diff --git a/sys/vops/apol.gx b/sys/vops/apol.gx new file mode 100644 index 00000000..04d162c5 --- /dev/null +++ b/sys/vops/apol.gx @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOL -- Evaluate a polynomial at X, given the coefficients of the polynomial +# in COEFF and returning the computed value as the function value. + +PIXEL procedure apol$t (x, coeff, ncoeff) + +PIXEL x # point at which the polynomial is to be evaluated +PIXEL coeff[ncoeff] # coefficients of the polynomial, lower orders first +int ncoeff + +int i +PIXEL pow, sum + +begin + sum = coeff[1] + pow = x + + do i = 2, ncoeff { + sum = sum + pow * coeff[i] + pow = pow * x + } + + return (sum) +end diff --git a/sys/vops/apow.gx b/sys/vops/apow.gx new file mode 100644 index 00000000..c8fca670 --- /dev/null +++ b/sys/vops/apow.gx @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOW -- Compute a ** b, where b is of type INT (generic). + +procedure apow$t (a, b, c, npix) + +PIXEL a[ARB], c[ARB] +int b[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b[i] +end diff --git a/sys/vops/apowk.gx b/sys/vops/apowk.gx new file mode 100644 index 00000000..68e83599 --- /dev/null +++ b/sys/vops/apowk.gx @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOWK -- Compute a ** b, where b is a constant of type INT (generic). + +procedure apowk$t (a, b, c, npix) + +PIXEL a[ARB], c[ARB] +int b +int npix, i + +begin + # Optimize the code for the various special cases. We assume that the + # compiler is intelligent enough to recognize the special cases if the + # power is expressed as an integer constant. + + switch (b) { + case 0: + call amovk$t (1$f, c, npix) + case 1: + call amov$t (a, c, npix) + case 2: + do i = 1, npix + c[i] = a[i] ** 2 + case 3: + do i = 1, npix + c[i] = a[i] ** 3 + case 4: + do i = 1, npix + c[i] = a[i] ** 4 + default: + do i = 1, npix + c[i] = a[i] ** b + } +end diff --git a/sys/vops/arav.gx b/sys/vops/arav.gx new file mode 100644 index 00000000..abc965dd --- /dev/null +++ b/sys/vops/arav.gx @@ -0,0 +1,52 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ARAV -- Compute the mean and standard deviation of a sample array by +# iteratively rejecting points further than KSIG from the mean. If the +# value of KSIG is given as 0.0, a cutoff value will be automatically +# calculated from the standard deviation and number of points in the sample. +# The number of pixels remaining in the sample upon termination is returned +# as the function value. + +int procedure arav$t (a, npix, mean, sigma, ksig) + +PIXEL a[ARB] # input data array +$if (datatype == dl) +double mean, sigma, ksig, deviation, lcut, hcut, lgpx +$else +real mean, sigma, ksig, deviation, lcut, hcut, lgpx +$endif +int npix, ngpix, old_ngpix, awvg$t() + +begin + lcut = -MAX_REAL # no rejection to start + hcut = MAX_REAL + ngpix = MAX_INT + + # Iteratively compute mean, sigma and reject outliers until no + # more pixels are rejected, or until there are no more pixels. + + repeat { + old_ngpix = ngpix + ngpix = awvg$t (a, npix, mean, sigma, lcut, hcut) + $if (datatype == dl) + if (ngpix <= 1 || sigma <= EPSILOND) + $else + if (ngpix <= 1 || sigma <= EPSILONR) + $endif + break + + if (ksig == 0.0) { # Chauvenet's relation + lgpx = log10 (real(ngpix)) + deviation = (lgpx * (-0.1042 * lgpx + 1.1695) + .8895) * sigma + } else + deviation = sigma * abs(ksig) + + lcut = mean - deviation # compute window + hcut = mean + deviation + + } until (ngpix >= old_ngpix) + + return (ngpix) +end diff --git a/sys/vops/arcp.gx b/sys/vops/arcp.gx new file mode 100644 index 00000000..6c7f9dc4 --- /dev/null +++ b/sys/vops/arcp.gx @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARCP -- Reciprocal of a constant divided by a vector. No divide by zero +# checking is performed. + +procedure arcp$t (a, b, c, npix) + +PIXEL a # constant numerator +PIXEL b[ARB] # vector denominator +PIXEL c[ARB] # output vector +int npix +int i + +begin + if (a == 0$f) { + call aclr$t (c, npix) + } else if (a == 1$f) { + do i = 1, npix + c[i] = 1$f / b[i] + } else { + do i = 1, npix + c[i] = a / b[i] + } +end diff --git a/sys/vops/arcz.gx b/sys/vops/arcz.gx new file mode 100644 index 00000000..ff8e30e0 --- /dev/null +++ b/sys/vops/arcz.gx @@ -0,0 +1,60 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARCZ -- Vector reciprocal with checking for zero divisors. If the result +# of a divide would be undefined a user supplied function is called to get the +# output pixel value. +# +# NOTE: in the interests of simplicity a somewhat arbitrary tolerance is used +# to check for an undefined divide, i.e., a divide by zero or a divide by a +# number small enough to cause floating point overflow. A better way to do +# this would be to provide a machine dependent version of this operator in +# host$as which catches the hardware exception rather than using a comparison. + +procedure arcz$t (a, b, c, npix, errfcn) + +PIXEL a # numerator +PIXEL b[ARB], c[ARB] # divisor, and output arrays +int npix # number of pixels +PIXEL errfcn() # user function, called on divide by zero + +int i +PIXEL divisor +$if (datatype == rd) +PIXEL tol +$endif +extern errfcn() +errchk errfcn + +begin + if (a == 0$f) { + call aclr$t (c, npix) + return + } + + $if (datatype == r) + tol = 1.0E-20 + $else $if (datatype == d) + tol = 1.0D-20 + $endif $endif + + do i = 1, npix { + divisor = b[i] + $if (datatype == rd) + # The following is most efficient when the data tends to be + # positive. + + if (divisor < tol) + if (divisor > -tol) { + c[i] = errfcn (a) + next + } + c[i] = a / divisor + + $else + if (divisor == 0$f) + c[i] = errfcn (a) + else + c[i] = a / divisor + $endif + } +end diff --git a/sys/vops/argt.gx b/sys/vops/argt.gx new file mode 100644 index 00000000..3ac2fbc4 --- /dev/null +++ b/sys/vops/argt.gx @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARGT -- Replace if greater than. If A[i] is greater than CEIL replace by +# NEWVAL. + +procedure argt$t (a, npix, ceil, newval) + +PIXEL a[ARB] +int npix +PIXEL ceil, newval +int i +$if (datatype == x) +real abs_ceil +$endif + +begin + $if (datatype == x) + abs_ceil = abs (ceil) + $endif + + do i = 1, npix + $if (datatype == x) + if (abs (a[i]) > abs_ceil) + $else + if (a[i] > ceil) + $endif + a[i] = newval +end diff --git a/sys/vops/arlt.gx b/sys/vops/arlt.gx new file mode 100644 index 00000000..8edce34a --- /dev/null +++ b/sys/vops/arlt.gx @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARLT -- Replace if less than. If A[i] is less than FLOOR replace by NEWVAL. + +procedure arlt$t (a, npix, floor, newval) + +PIXEL a[ARB] +int npix +PIXEL floor, newval +int i +$if (datatype == x) +real abs_floor +$endif + +begin + $if (datatype == x) + abs_floor = abs (floor) + $endif + + do i = 1, npix + $if (datatype == x) + if (abs (a[i]) < abs_floor) + $else + if (a[i] < floor) + $endif + a[i] = newval +end diff --git a/sys/vops/asel.gx b/sys/vops/asel.gx new file mode 100644 index 00000000..ef978d46 --- /dev/null +++ b/sys/vops/asel.gx @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASEL -- Vector select element. The output vector is formed by taking +# successive pixels from either of the two input vectors, based on the value +# of the integer (boolean) selection vectors. Used to implement vector +# conditional expressions. + +procedure asel$t (a, b, c, sel, npix) + +PIXEL a[ARB], b[ARB], c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b[i] +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b[i] +end diff --git a/sys/vops/aselk.gx b/sys/vops/aselk.gx new file mode 100644 index 00000000..2d7c54d3 --- /dev/null +++ b/sys/vops/aselk.gx @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASELK -- Vector/constant select element. The output vector is formed by +# taking successive pixels from either of the input vector or a constant, based +# on the value of the integer (boolean) selection vectors. Used to implement +# vector conditional expressions. + +procedure aselk$t (a, b, c, sel, npix) + +PIXEL a[ARB], b, c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b +end diff --git a/sys/vops/asok.gx b/sys/vops/asok.gx new file mode 100644 index 00000000..b508d4ff --- /dev/null +++ b/sys/vops/asok.gx @@ -0,0 +1,77 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ASOK -- Select the Kth smallest element from a vector. The algorithm used +# is selection by tail recursion (Gonnet 1984). In each iteration a pivot key +# is selected (somewhat arbitrarily) from the array. The array is then split +# into two subarrays, those with key values less than or equal to the pivot key +# and those with values greater than the pivot. The size of the two subarrays +# determines which contains the median value, and the process is repeated +# on that subarray, and so on until all of the elements of the subarray +# are equal, e.g., there is only one element left in the subarray. For a +# randomly ordered array the expected running time is O(3.38N). The selection +# is carried out in place, leaving the array in a partially ordered state. +# +# N.B.: Behaviour is O(N) if the input array is sorted. +# N.B.: The cases ksel=1 and ksel=npix, i.e., selection of the minimum and +# maximum values, are more efficiently handled by ALIM which is O(2N). +# +# Jul99 - The above algorithm was found to be pathologically slow in cases +# where many or all elements of the array are equal. The version of the +# algorithm below, from Wirth, appears to avoid this problem. + +PIXEL procedure asok$t (a, npix, ksel) + +PIXEL a[ARB] # input array +int npix # number of pixels +int ksel # element to be selected + +int lo, up, i, j, k, dummy +PIXEL temp, wtemp +$if (datatype == x) +real abs_temp +$endif + +begin + lo = 1 + up = npix + k = max (lo, min (up, ksel)) + + # while (lo < up) + do dummy = 1, MAX_INT { + if (! (lo < up)) + break + + temp = a[k]; i = lo; j = up + $if (datatype == x) + abs_temp = abs (temp) + $endif + + repeat { + $if (datatype == x) + while (abs (a[i]) < abs_temp) + $else + while (a[i] < temp) + $endif + i = i + 1 + $if (datatype == x) + while (abs_temp < abs (a[j])) + $else + while (temp < a[j]) + $endif + j = j - 1 + if (i <= j) { + wtemp = a[i]; a[i] = a[j]; a[j] = wtemp + i = i + 1; j = j - 1 + } + } until (i > j) + + if (j < k) + lo = i + if (k < i) + up = j + } + + return (a[k]) +end diff --git a/sys/vops/asqr.gx b/sys/vops/asqr.gx new file mode 100644 index 00000000..1a584853 --- /dev/null +++ b/sys/vops/asqr.gx @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASQR -- Compute the square root of a vector (generic). If the square root +# is undefined (x < 0) a user supplied function is called to compute the value. + +procedure asqr$t (a, b, npix, errfcn) + +PIXEL a[ARB], b[ARB] +int npix, i +extern errfcn() +PIXEL errfcn() +errchk errfcn + +begin + do i = 1, npix { + $if (datatype != x) + if (a[i] < 0) + b[i] = errfcn (a[i]) + else + $endif + { + $if (datatype == rdx) + b[i] = sqrt (a[i]) + $else $if (datatype == l) + b[i] = sqrt (double (a[i])) + $else + b[i] = sqrt (real (a[i])) + $endif $endif + } + } +end diff --git a/sys/vops/asrt.gx b/sys/vops/asrt.gx new file mode 100644 index 00000000..ff639b2a --- /dev/null +++ b/sys/vops/asrt.gx @@ -0,0 +1,77 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define LOGPTR 32 # log2(maxpts) (4e9) + +# ASRT -- Vector Quicksort. The output vector may be the same as the +# input vector. + +procedure asrt$t (a, b, npix) + +PIXEL a[ARB], b[ARB] # input, output arrays +int npix # number of pixels + +PIXEL pivot, temp +int i, j, k, p, lv[LOGPTR], uv[LOGPTR] +define swap {temp=$1;$1=$2;$2=temp} + +begin + call amov$t (a, b, npix) # in place sort + + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already sorted + # array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]) + pivot = b[j] # pivot line + + while (i < j) { + $if (datatype == x) + for (i=i+1; abs(b[i]) < abs(pivot); i=i+1) + $else + for (i=i+1; b[i] < pivot; i=i+1) + $endif + ; + for (j=j-1; j > i; j=j-1) + $if (datatype == x) + if (abs(b[j]) <= abs(pivot)) + $else + if (b[j] <= pivot) + $endif + break + if (i < j) # out of order pair + swap (b[i], b[j]) # interchange elements + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } +end diff --git a/sys/vops/assq.gx b/sys/vops/assq.gx new file mode 100644 index 00000000..0189e01e --- /dev/null +++ b/sys/vops/assq.gx @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASSQ -- Vector sum of squares. + +$if (datatype == csir) +real procedure assq$t (a, npix) +real sum +$else $if (datatype == ld) +double procedure assq$t (a, npix) +double sum +$else +PIXEL procedure assq$t (a, npix) +PIXEL sum +$endif $endif + +PIXEL a[ARB] +int npix +int i + +begin + sum = 0$f + do i = 1, npix + sum = sum + (a[i] ** 2) + + return (sum) +end diff --git a/sys/vops/asub.gx b/sys/vops/asub.gx new file mode 100644 index 00000000..547ee29c --- /dev/null +++ b/sys/vops/asub.gx @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUB -- Subtract two vectors (generic). + +procedure asub$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] - b[i] +end diff --git a/sys/vops/asubk.gx b/sys/vops/asubk.gx new file mode 100644 index 00000000..2f77e007 --- /dev/null +++ b/sys/vops/asubk.gx @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUBK -- Subtract a constant from a vector (generic). + +procedure asubk$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +PIXEL c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] - b +end diff --git a/sys/vops/asum.gx b/sys/vops/asum.gx new file mode 100644 index 00000000..716d2b53 --- /dev/null +++ b/sys/vops/asum.gx @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUM -- Vector sum. Take care to prevent integer overflow by returning +# a floating point sum. + +$if (datatype == csir) +real procedure asum$t (a, npix) +$else $if (datatype == ld) +double procedure asum$t (a, npix) +$else +PIXEL procedure asum$t (a, npix) +$endif $endif + +PIXEL a[ARB] +int npix +int i + +$if (datatype == csir) +real sum +$else $if (datatype == ld) +double sum +$else +PIXEL sum +$endif $endif + +begin + sum = 0$f + do i = 1, npix + sum = sum + a[i] + + return (sum) +end diff --git a/sys/vops/aupx.gx b/sys/vops/aupx.gx new file mode 100644 index 00000000..c6a4a66b --- /dev/null +++ b/sys/vops/aupx.gx @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AUPX -- Unpack the real and imaginary components of a complex vector into +# two output vectors of some other type. + +procedure aupx$t (a, b, c, npix) + +complex a[ARB] # input vector +PIXEL b[ARB], c[ARB] # output vectors +int npix +int i + +begin + do i = 1, npix { + $if (datatype == x) + b[i] = complex (real(a[i]), 0.0) + c[i] = complex (0.0, aimag(a[i])) + $else + b[i] = real (a[i]) + c[i] = aimag (a[i]) + $endif + } +end diff --git a/sys/vops/aveq.gx b/sys/vops/aveq.gx new file mode 100644 index 00000000..1967102a --- /dev/null +++ b/sys/vops/aveq.gx @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AVEQ -- Compare two vectors for equality. + +bool procedure aveq$t (a, b, npix) + +PIXEL a[ARB], b[ARB] #I vectors to be compared +int npix #I number of pixels to be compared + +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + return (false) + + return (true) +end diff --git a/sys/vops/awsu.gx b/sys/vops/awsu.gx new file mode 100644 index 00000000..ffa5446d --- /dev/null +++ b/sys/vops/awsu.gx @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AWSU -- Vector weighted sum. C = A * k1 + B * k2 + +procedure awsu$t (a, b, c, npix, k1, k2) + +PIXEL a[ARB], b[ARB], c[ARB] +$if (datatype == x) +complex k1, k2 +$else $if (datatype == d) +double k1, k2 +$else +real k1, k2 +$endif $endif +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * k1 + b[i] * k2 +end diff --git a/sys/vops/awvg.gx b/sys/vops/awvg.gx new file mode 100644 index 00000000..7c221bf3 --- /dev/null +++ b/sys/vops/awvg.gx @@ -0,0 +1,83 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AWVG -- Compute the mean and standard deviation (sigma) of a sample. Pixels +# whose value lies outside the specified lower and upper limits are not used. +# If the upper and lower limits have the same value (e.g., zero), no limit +# checking is performed. The number of pixels in the sample is returned as the +# function value. + +int procedure awvg$t (a, npix, mean, sigma, lcut, hcut) + +PIXEL a[ARB] +$if (datatype == dl) +double mean, sigma, lcut, hcut +$else +real mean, sigma, lcut, hcut +$endif +double sum, sumsq, value, temp +int npix, i, ngpix + +begin + sum = 0.0 + sumsq = 0.0 + ngpix = 0 + + # Accumulate sum, sum of squares. The test to disable limit checking + # requires numerical equality of two floating point numbers; this should + # be ok since they are used as flags not as numbers (they are not used + # in computations). + + if (hcut == lcut) { + do i = 1, npix { + $if (datatype == x) + value = abs (a[i]) + $else + value = a[i] + $endif + sum = sum + value + sumsq = sumsq + value ** 2 + } + ngpix = npix + + } else { + do i = 1, npix { + $if (datatype == x) + value = abs (a[i]) + $else + value = a[i] + $endif + if (value >= lcut && value <= hcut) { + ngpix = ngpix + 1 + sum = sum + value + sumsq = sumsq + value ** 2 + } + } + } + + switch (ngpix) { # compute mean and sigma + case 0: +$if (datatype == dl) + mean = $INDEFD + sigma = $INDEFD +$else + mean = $INDEFR + sigma = $INDEFR +$endif + case 1: + mean = sum +$if (datatype == dl) + sigma = $INDEFD +$else + sigma = $INDEFR +$endif + default: + mean = sum / ngpix + temp = (sumsq - (sum/ngpix) * sum) / (ngpix - 1) + if (temp < 0) # possible with roundoff error + sigma = 0.0 + else + sigma = sqrt (temp) + } + + return (ngpix) +end diff --git a/sys/vops/axor.gx b/sys/vops/axor.gx new file mode 100644 index 00000000..18fd07fd --- /dev/null +++ b/sys/vops/axor.gx @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AXOR -- Compute the exclusive or of two vectors (generic). + +procedure axor$t (a, b, c, npix) + +PIXEL a[ARB], b[ARB], c[ARB] +int npix, i +$if (datatype == i) +int xor() +$else +PIXEL xor$t() +$endif + +begin + do i = 1, npix { + $if (datatype == i) + c[i] = xor (a[i], b[i]) + $else + c[i] = xor$t (a[i], b[i]) + $endif + } +end diff --git a/sys/vops/axork.gx b/sys/vops/axork.gx new file mode 100644 index 00000000..eeb3694c --- /dev/null +++ b/sys/vops/axork.gx @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AXORK -- Compute the boolean or of a vector and a constant (generic). + +procedure axork$t (a, b, c, npix) + +PIXEL a[ARB] +PIXEL b +PIXEL c[ARB] +int npix, i +$if (datatype == i) +int xor() +$else +PIXEL xor$t() +$endif + +begin + do i = 1, npix { + $if (datatype == i) + c[i] = xor (a[i], b) + $else + c[i] = xor$t (a[i], b) + $endif + } +end diff --git a/sys/vops/doc/vops.hlp b/sys/vops/doc/vops.hlp new file mode 100644 index 00000000..dc415afa --- /dev/null +++ b/sys/vops/doc/vops.hlp @@ -0,0 +1,260 @@ + +.help VOPS Feb83 "Vector Primitives" +.sh +Introduction + + The vector primitives are abstract machine instructions which +operate on vectors. The "a" prefixed operators are for one dimensional +arrays, and the "m" prefixed operators are for two dimensional +arrays (matrices). Each generic instruction is implemented as a +set of operators, one for each data type. + +There are no vector primitives for the type BOOL. If a "b" suffix is given, +the vector primitive is understood to operate on unsigned machine bytes. +The "u" suffix is used for the special type unsigned short integer. + +The binary operators ("c = a op b") come in two forms. If the regular +three character instruction mnemonic is used, the B operand must be vector. +If the letter "k" is added to the mnemonic, the B operand must be a constant. +These dual mode operators are flagged (with "(k)") in the table below. + + +.nf + Instruction Operation Data Types + + cht__ b = a (change datatype) UBcsilrdx + clr_ fill a with zeros csilrdx + mov_ (k) b = a (copy vector) csilrdx + + abs_ b = abs(a) silrdx + log_ b = log10(a) silrdx + lln_ b = natural_log(a) silrdx + sqr_ b = sqrt(a) silrdx + srt_ b = sort(a) csilrdx + neg_ b = -a silrdx + map_ b = (a + k1) * k2 silrdx + map_B b = (a + k1) * k2 silrdx + lut_ b = lut[a] (lookup table) csil + lui_ b = interp (a, x) silrd + rep_ a = newval if (low<=a<=high) csilrdx + + add_ (k) c = a + b silrdx + sub_ (k) c = a - b silrdx + mul_ (k) c = a * b silrdx + div_ (k) c = a / b silrdx + min_ (k) c = min(a,b) silrd + max_ (k) c = max(a,b) silrd + mod_ (k) c = mod(a,b) silrd + pow_ (k) c = a ** int_pwr silrdx + exp_ (k) c = a ** real_pwr silrdx + + not_ b = !a sil + and_ (k) c = and(a,b) sil + bor_ (k) c = or(a,b) sil + xor_ (k) c = xor(a,b) sil + + +.tp 4 +other vector primitives: + + lim_ ngpix = lim_ (a, npix; minval, maxval) silrdx + win_ nrej = win_ (a, npix, lcut, hcut) silrdx + avg_ ngpix = avg_ (a, npix; mean, sigma) silrdx + rav_ ngpix = rav_ (a, npix; mean, sigma; ksig) silrdx +? med_ ngpix = med_ (a, ia, npix; median) silrd +.fi + + +For example, "aaddr(a,b,c,npix)" would add the two REAL vectors A and B, +of length NPIX, placing the sum in the vector C. To add a constant K to +the vector A, "aaddkr(a,k,c,npix)" would be used. +The sequence "aclrb(a,nbytes)" would zero NBYTES machine bytes, +starting at location A. + +.sh +Preprocessing Generic Operators + + A preprocessor is provided to convert a generic operator into a set +of type specific operators. By coding only generic operators, the programmer +only has to maintain a single piece of code, reducing the possibility of +an error, and greatly reducing the amount of work. + +The GENERIC preprocessor takes as input files written in either the IRAF +preprocessor language or C (or any other language which provides macro +definitions), with embedded preprocessor directives and keywords. +.sh +Usage + + The calling sequence for the preprocessor (on the UNIX system) +is as follows: + + generic [-t types] [-p prefix] [-o outfile] file [file...] + +Any number of files may be processed. +.sh +Flags + + The following (optional) flags are provided to control the types +and names of the generated files: +.ls 8 +.ls 8 -t +Used to specify the datatypes of the files to be produced. The default +value is "silrdx", meaning types SHORT through COMPLEX. Other possible +types are "BU", i.e., unsigned byte and unsigned short. The generic +preprocessor does not support type boolean. +.le +.ls -p +An optional prefix string to be added to each file name generated. Provided +to make it convenient to place all generated files in a subdirectory. +If the name of the file(s) being preprocessed is "aadd.x", and the prefix +is "d/", the names of the generated files will be "d/aadds.x", "d/aaddi.x", +"d/aaddl.x", and so on. +.le +.ls -o +If an output filename is specified with the -o flag, only a single input file +may be processed. Any "$t" sequences embedded in the output file name +will be replaced by the type "suffix" character to generate the filenames +of the type specific files in the generic family. If no $t sequence is given, +the type suffix is appended to the filename. If no -o output filename is +given, the names of the output files are formed by concatenating the type +suffix to the root of the input filename. +.le +.le +.sh +Directives + + The action of the preprocessor is directed by placing "$xxx" directives +in the text to be processed. The identifiers INDEF and PIXEL are also +known to the preprocessor, and will be replaced by their type specific +equivalents (INDEF --> INDEFS, INDEFI, etc., PIXEL --> short, int, real, etc.) +in the generated text. Comments (#... and /* ... */), quoted strings (".."), +and escaped lines (^%) are passed on unchanged. + +.ls 4 +.ls 20 $/text/ +The text enclosed by the matching slashes is passed through unchanged. +.le +.ls $t +The lowercase value of the current type suffix character (one of [bucsilrdx]). +.le +.ls $T +The uppercase value of the current type suffix character (one of [BUCSILRDX]). +.le +.ls digits$f +Replaced by "digits.0" if the current type is REAL, by "digits.0D0" if the +current type is DOUBLE, by "(digits,digits)" if the type is complex, or by +"digits" for all other datatypes. +.le +.ls $if +Conditional compilation. Two forms of the $if statment are implemented: + +.nf + $if (datatype == ) + $if (datatype != ) + +or + $if (sizeof() sizeof()) +.fi + +where , , and are type suffix characters ("silrd", etc.), +and where is one of the relational operators + + == != <= < >= > + +Nesting is permitted. Conditional statements need not be left justified, +i.e., whitespace may be placed between BOL and a $xx preprocessor directive. +.le +.ls $$if +Replaced by "$if". Not evaluated until the second time the file is +processed. +.le +.ls $else, $$else +Begins a section of code which gets processed if the $if condition was +false. +.le +.ls $endif, $$endif +Terminates a $if or $else construct. +.le +.ls TY_PIXEL +Replaced by TY_INT, TY_REAL, and so on. +.le +.ls SZ_PIXEL +Replaced by SZ_INT, SZ_REAL, and so on. +.le +.ls PIXEL +Replaced by the datatype keyword of the file currently being generated +(int, real, etc.). +.le +.ls XPIXEL +Replaced by the defined type (XCHAR, XINT, ect.). Used in generic C +programs which will be called from the subset preprocessor, and which +must manipulate the subset pp datatypes. +.le +.ls $PIXEL +Replaced by the string "PIXEL" (used to postpone substitution until the +next pass). +.le +.ls INDEF +Replaced by the INDEF parameter for the current datatype (INDEFS, INDEFI, +INDEFL, INDEF, or INDEFX). +.le +.ls $INDEF +Replaced by the string "INDEF". +.le +.le + +.sh +Example + + The following generic operator computes the square root of a vector. +The members of the generic family would be called "asqrs", "asqri", +and so on. + +.ks +.nf + # ASQR -- Compute the square root of a vector (generic) + + procedure asqr$t (a, b, npix) + + PIXEL a[npix], b[npix] + int npix, i + + begin + do i = 1, npix { + if (a[i] < 0$f || a[i] == INDEF) + b[i] = INDEF + else { + $if (datatype != rdx) + b[i] = sqrt(double(a[i])) + $else + b[i] = sqrt(a[i]) + $endif + } + } + end +.fi +.ke + +.sh +Doubly Generic Operators + + The preprocessor can also be used to generate doubly generic operators +(operators which have two type suffixes). A good example is the type +conversion operator ACHTxy, which converts a vector of type X to a vector +of type Y. If there are seven datatypes (csilrdx), this generic family will +consist of 49 members. + +Doubly generic programs are preprocessed once to expand the first suffix, +then each file generated by the first pass is processed to expand the +second suffix. On the UNIX sytstem, this might be done by a command +such as + +.nf + generic acht.x; generic -p dir/ acht[silrd].x + rm acht[silrd].x +.fi + +This would expand "acht" in the current directory (generating 5 files), +then expand each of the "acht$t" files in the subdirectory "dir/", +creating a total of 25 files in the subdirectory. The final command +removes the 5 intermediate files. diff --git a/sys/vops/fftr.f b/sys/vops/fftr.f new file mode 100644 index 00000000..a6885972 --- /dev/null +++ b/sys/vops/fftr.f @@ -0,0 +1,689 @@ +c +c----------------------------------------------------------------------- +c subroutine: ffa +c fast fourier analysis subroutine +c----------------------------------------------------------------------- +c + subroutine ffa (b, nfft, ier) +c +c this subroutine replaces the real vector b(k), (k=1,2,...,n), +c with its finite discrete fourier transform. the dc term is +c returned in location b(1) with b(2) set to 0. thereafter, the +c jth harmonic is returned as a complex number stored as +c b(2*j+1) + i b(2*j+2). note that the n/2 harmonic is returned +c in b(n+1) with b(n+2) set to 0. hence, b must be dimensioned +c to size n+2. +c subroutine is called as ffa (b,n) where n=2**m and b is an +c n term real array. a real-valued, radix 8 algorithm is used +c with in-place reordering and the trig functions are computed as +c needed. +c + dimension b(2) + common /con/ pii, p7, p7two, c22, s22, pi2 +c +c iw is a machine dependent write device number +c +c+noao +c iw = i1mach(2) + ier = 0 +c-noao +c + pii = 4.*atan(1.) + pi8 = pii/8. + p7 = 1./sqrt(2.) + p7two = 2.*p7 + c22 = cos(pi8) + s22 = sin(pi8) + pi2 = 2.*pii + n = 1 + do 10 i=1,31 + m = i + n = n*2 + if (n.eq.nfft) go to 20 + 10 continue +c+noao +c write (iw,9999) +c9999 format (30h nfft not a power of 2 for ffa) +c stop + ier = 1 + return +c-noao + 20 continue + n8pow = m/3 +c +c do a radix 2 or radix 4 iteration first if one is required +c + if (m-n8pow*3-1) 50, 40, 30 + 30 nn = 4 + int = n/nn + call r4tr(int, b(1), b(int+1), b(2*int+1), b(3*int+1)) + go to 60 + 40 nn = 2 + int = n/nn + call r2tr(int, b(1), b(int+1)) + go to 60 + 50 nn = 1 +c +c perform radix 8 iterations +c + 60 if (n8pow) 90, 90, 70 + 70 do 80 it=1,n8pow + nn = nn*8 + int = n/nn + call r8tr(int, nn, b(1), b(int+1), b(2*int+1), b(3*int+1), + * b(4*int+1), b(5*int+1), b(6*int+1), b(7*int+1), b(1), + * b(int+1), b(2*int+1), b(3*int+1), b(4*int+1), b(5*int+1), + * b(6*int+1), b(7*int+1)) + 80 continue +c +c perform in-place reordering +c + 90 call ord1(m, b) + call ord2(m, b) + t = b(2) + b(2) = 0. + b(nfft+1) = t + b(nfft+2) = 0. + do 100 i=4,nfft,2 + b(i) = -b(i) + 100 continue + return + end +c +c----------------------------------------------------------------------- +c subroutine: ffs +c fast fourier synthesis subroutine +c radix 8-4-2 +c----------------------------------------------------------------------- +c + subroutine ffs (b, nfft, ier) +c +c this subroutine synthesizes the real vector b(k), where +c k=1,2,...,n. the initial fourier coefficients are placed in +c the b array of size n+2. the dc term is in b(1) with +c b(2) equal to 0. +c the jth harmonic is stored as b(2*j+1) + i b(2*j+2). +c the n/2 harmonic is in b(n+1) with b(n+2) equal to 0. +c the subroutine is called as ffs(b,n) where n=2**m and +c b is the n term real array discussed above. +c + dimension b(2) + common /con1/ pii, p7, p7two, c22, s22, pi2 +c +c iw is a machine dependent write device number +c +c+noao +c iw = i1mach(2) + ier = 0 +c-noao +c + pii = 4.*atan(1.) + pi8 = pii/8. + p7 = 1./sqrt(2.) + p7two = 2.*p7 + c22 = cos(pi8) + s22 = sin(pi8) + pi2 = 2.*pii + n = 1 + do 10 i=1,31 + m = i + n = n*2 + if (n.eq.nfft) go to 20 + 10 continue +c+noao +c write (iw,9999) +c9999 format (30h nfft not a power of 2 for ffs) +c stop + ier = 1 + return +c-noao + 20 continue + b(2) = b(nfft+1) + do 30 i=1,nfft + b(i) = b(i)/float(nfft) + 30 continue + do 40 i=4,nfft,2 + b(i) = -b(i) + 40 continue + n8pow = m/3 +c +c reorder the input fourier coefficients +c + call ord2(m, b) + call ord1(m, b) +c + if (n8pow.eq.0) go to 60 +c +c perform the radix 8 iterations +c + nn = n + do 50 it=1,n8pow + int = n/nn + call r8syn(int, nn, b, b(int+1), b(2*int+1), b(3*int+1), + * b(4*int+1), b(5*int+1), b(6*int+1), b(7*int+1), b(1), + * b(int+1), b(2*int+1), b(3*int+1), b(4*int+1), b(5*int+1), + * b(6*int+1), b(7*int+1)) + nn = nn/8 + 50 continue +c +c do a radix 2 or radix 4 iteration if one is required +c + 60 if (m-n8pow*3-1) 90, 80, 70 + 70 int = n/4 + call r4syn(int, b(1), b(int+1), b(2*int+1), b(3*int+1)) + go to 90 + 80 int = n/2 + call r2tr(int, b(1), b(int+1)) + 90 return + end +c +c----------------------------------------------------------------------- +c subroutine: r2tr +c radix 2 iteration subroutine +c----------------------------------------------------------------------- +c +c + subroutine r2tr(int, b0, b1) + dimension b0(2), b1(2) + do 10 k=1,int + t = b0(k) + b1(k) + b1(k) = b0(k) - b1(k) + b0(k) = t + 10 continue + return + end +c +c----------------------------------------------------------------------- +c subroutine: r4tr +c radix 4 iteration subroutine +c----------------------------------------------------------------------- +c + subroutine r4tr(int, b0, b1, b2, b3) + dimension b0(2), b1(2), b2(2), b3(2) + do 10 k=1,int + r0 = b0(k) + b2(k) + r1 = b1(k) + b3(k) + b2(k) = b0(k) - b2(k) + b3(k) = b1(k) - b3(k) + b0(k) = r0 + r1 + b1(k) = r0 - r1 + 10 continue + return + end +c +c----------------------------------------------------------------------- +c subroutine: r8tr +c radix 8 iteration subroutine +c----------------------------------------------------------------------- +c + subroutine r8tr(int, nn, br0, br1, br2, br3, br4, br5, br6, br7, + * bi0, bi1, bi2, bi3, bi4, bi5, bi6, bi7) + dimension l(15), br0(2), br1(2), br2(2), br3(2), br4(2), br5(2), + * br6(2), br7(2), bi0(2), bi1(2), bi2(2), bi3(2), bi4(2), + * bi5(2), bi6(2), bi7(2) + common /con/ pii, p7, p7two, c22, s22, pi2 + equivalence (l15,l(1)), (l14,l(2)), (l13,l(3)), (l12,l(4)), + * (l11,l(5)), (l10,l(6)), (l9,l(7)), (l8,l(8)), (l7,l(9)), + * (l6,l(10)), (l5,l(11)), (l4,l(12)), (l3,l(13)), (l2,l(14)), + * (l1,l(15)) +c +c set up counters such that jthet steps through the arguments +c of w, jr steps through starting locations for the real part of the +c intermediate results and ji steps through starting locations +c of the imaginary part of the intermediate results. +c + l(1) = nn/8 + do 40 k=2,15 + if (l(k-1)-2) 10, 20, 30 + 10 l(k-1) = 2 + 20 l(k) = 2 + go to 40 + 30 l(k) = l(k-1)/2 + 40 continue + piovn = pii/float(nn) + ji = 3 + jl = 2 + jr = 2 + do 120 j1=2,l1,2 + do 120 j2=j1,l2,l1 + do 120 j3=j2,l3,l2 + do 120 j4=j3,l4,l3 + do 120 j5=j4,l5,l4 + do 120 j6=j5,l6,l5 + do 120 j7=j6,l7,l6 + do 120 j8=j7,l8,l7 + do 120 j9=j8,l9,l8 + do 120 j10=j9,l10,l9 + do 120 j11=j10,l11,l10 + do 120 j12=j11,l12,l11 + do 120 j13=j12,l13,l12 + do 120 j14=j13,l14,l13 + do 120 jthet=j14,l15,l14 + th2 = jthet - 2 + if (th2) 50, 50, 90 + 50 do 60 k=1,int + t0 = br0(k) + br4(k) + t1 = br1(k) + br5(k) + t2 = br2(k) + br6(k) + t3 = br3(k) + br7(k) + t4 = br0(k) - br4(k) + t5 = br1(k) - br5(k) + t6 = br2(k) - br6(k) + t7 = br3(k) - br7(k) + br2(k) = t0 - t2 + br3(k) = t1 - t3 + t0 = t0 + t2 + t1 = t1 + t3 + br0(k) = t0 + t1 + br1(k) = t0 - t1 + pr = p7*(t5-t7) + pi = p7*(t5+t7) + br4(k) = t4 + pr + br7(k) = t6 + pi + br6(k) = t4 - pr + br5(k) = pi - t6 + 60 continue + if (nn-8) 120, 120, 70 + 70 k0 = int*8 + 1 + kl = k0 + int - 1 + do 80 k=k0,kl + pr = p7*(bi2(k)-bi6(k)) + pi = p7*(bi2(k)+bi6(k)) + tr0 = bi0(k) + pr + ti0 = bi4(k) + pi + tr2 = bi0(k) - pr + ti2 = bi4(k) - pi + pr = p7*(bi3(k)-bi7(k)) + pi = p7*(bi3(k)+bi7(k)) + tr1 = bi1(k) + pr + ti1 = bi5(k) + pi + tr3 = bi1(k) - pr + ti3 = bi5(k) - pi + pr = tr1*c22 - ti1*s22 + pi = ti1*c22 + tr1*s22 + bi0(k) = tr0 + pr + bi6(k) = tr0 - pr + bi7(k) = ti0 + pi + bi1(k) = pi - ti0 + pr = -tr3*s22 - ti3*c22 + pi = tr3*c22 - ti3*s22 + bi2(k) = tr2 + pr + bi4(k) = tr2 - pr + bi5(k) = ti2 + pi + bi3(k) = pi - ti2 + 80 continue + go to 120 + 90 arg = th2*piovn + c1 = cos(arg) + s1 = sin(arg) + c2 = c1**2 - s1**2 + s2 = c1*s1 + c1*s1 + c3 = c1*c2 - s1*s2 + s3 = c2*s1 + s2*c1 + c4 = c2**2 - s2**2 + s4 = c2*s2 + c2*s2 + c5 = c2*c3 - s2*s3 + s5 = c3*s2 + s3*c2 + c6 = c3**2 - s3**2 + s6 = c3*s3 + c3*s3 + c7 = c3*c4 - s3*s4 + s7 = c4*s3 + s4*c3 + int8 = int*8 + j0 = jr*int8 + 1 + k0 = ji*int8 + 1 + jlast = j0 + int - 1 + do 100 j=j0,jlast + k = k0 + j - j0 + tr1 = br1(j)*c1 - bi1(k)*s1 + ti1 = br1(j)*s1 + bi1(k)*c1 + tr2 = br2(j)*c2 - bi2(k)*s2 + ti2 = br2(j)*s2 + bi2(k)*c2 + tr3 = br3(j)*c3 - bi3(k)*s3 + ti3 = br3(j)*s3 + bi3(k)*c3 + tr4 = br4(j)*c4 - bi4(k)*s4 + ti4 = br4(j)*s4 + bi4(k)*c4 + tr5 = br5(j)*c5 - bi5(k)*s5 + ti5 = br5(j)*s5 + bi5(k)*c5 + tr6 = br6(j)*c6 - bi6(k)*s6 + ti6 = br6(j)*s6 + bi6(k)*c6 + tr7 = br7(j)*c7 - bi7(k)*s7 + ti7 = br7(j)*s7 + bi7(k)*c7 +c + t0 = br0(j) + tr4 + t1 = bi0(k) + ti4 + tr4 = br0(j) - tr4 + ti4 = bi0(k) - ti4 + t2 = tr1 + tr5 + t3 = ti1 + ti5 + tr5 = tr1 - tr5 + ti5 = ti1 - ti5 + t4 = tr2 + tr6 + t5 = ti2 + ti6 + tr6 = tr2 - tr6 + ti6 = ti2 - ti6 + t6 = tr3 + tr7 + t7 = ti3 + ti7 + tr7 = tr3 - tr7 + ti7 = ti3 - ti7 +c + tr0 = t0 + t4 + ti0 = t1 + t5 + tr2 = t0 - t4 + ti2 = t1 - t5 + tr1 = t2 + t6 + ti1 = t3 + t7 + tr3 = t2 - t6 + ti3 = t3 - t7 + t0 = tr4 - ti6 + t1 = ti4 + tr6 + t4 = tr4 + ti6 + t5 = ti4 - tr6 + t2 = tr5 - ti7 + t3 = ti5 + tr7 + t6 = tr5 + ti7 + t7 = ti5 - tr7 + br0(j) = tr0 + tr1 + bi7(k) = ti0 + ti1 + bi6(k) = tr0 - tr1 + br1(j) = ti1 - ti0 + br2(j) = tr2 - ti3 + bi5(k) = ti2 + tr3 + bi4(k) = tr2 + ti3 + br3(j) = tr3 - ti2 + pr = p7*(t2-t3) + pi = p7*(t2+t3) + br4(j) = t0 + pr + bi3(k) = t1 + pi + bi2(k) = t0 - pr + br5(j) = pi - t1 + pr = -p7*(t6+t7) + pi = p7*(t6-t7) + br6(j) = t4 + pr + bi1(k) = t5 + pi + bi0(k) = t4 - pr + br7(j) = pi - t5 + 100 continue + jr = jr + 2 + ji = ji - 2 + if (ji-jl) 110, 110, 120 + 110 ji = 2*jr - 1 + jl = jr + 120 continue + return + end +c +c----------------------------------------------------------------------- +c subroutine: r4syn +c radix 4 synthesis +c----------------------------------------------------------------------- +c + subroutine r4syn(int, b0, b1, b2, b3) + dimension b0(2), b1(2), b2(2), b3(2) + do 10 k=1,int + t0 = b0(k) + b1(k) + t1 = b0(k) - b1(k) + t2 = b2(k) + b2(k) + t3 = b3(k) + b3(k) + b0(k) = t0 + t2 + b2(k) = t0 - t2 + b1(k) = t1 + t3 + b3(k) = t1 - t3 + 10 continue + return + end +c +c----------------------------------------------------------------------- +c subroutine: r8syn +c radix 8 synthesis subroutine +c----------------------------------------------------------------------- +c + subroutine r8syn(int, nn, br0, br1, br2, br3, br4, br5, br6, br7, + * bi0, bi1, bi2, bi3, bi4, bi5, bi6, bi7) + dimension l(15), br0(2), br1(2), br2(2), br3(2), br4(2), br5(2), + * br6(2), br7(2), bi0(2), bi1(2), bi2(2), bi3(2), bi4(2), + * bi5(2), bi6(2), bi7(2) + common /con1/ pii, p7, p7two, c22, s22, pi2 + equivalence (l15,l(1)), (l14,l(2)), (l13,l(3)), (l12,l(4)), + * (l11,l(5)), (l10,l(6)), (l9,l(7)), (l8,l(8)), (l7,l(9)), + * (l6,l(10)), (l5,l(11)), (l4,l(12)), (l3,l(13)), (l2,l(14)), + * (l1,l(15)) + l(1) = nn/8 + do 40 k=2,15 + if (l(k-1)-2) 10, 20, 30 + 10 l(k-1) = 2 + 20 l(k) = 2 + go to 40 + 30 l(k) = l(k-1)/2 + 40 continue + piovn = pii/float(nn) + ji = 3 + jl = 2 + jr = 2 +c + do 120 j1=2,l1,2 + do 120 j2=j1,l2,l1 + do 120 j3=j2,l3,l2 + do 120 j4=j3,l4,l3 + do 120 j5=j4,l5,l4 + do 120 j6=j5,l6,l5 + do 120 j7=j6,l7,l6 + do 120 j8=j7,l8,l7 + do 120 j9=j8,l9,l8 + do 120 j10=j9,l10,l9 + do 120 j11=j10,l11,l10 + do 120 j12=j11,l12,l11 + do 120 j13=j12,l13,l12 + do 120 j14=j13,l14,l13 + do 120 jthet=j14,l15,l14 + th2 = jthet - 2 + if (th2) 50, 50, 90 + 50 do 60 k=1,int + t0 = br0(k) + br1(k) + t1 = br0(k) - br1(k) + t2 = br2(k) + br2(k) + t3 = br3(k) + br3(k) + t4 = br4(k) + br6(k) + t6 = br7(k) - br5(k) + t5 = br4(k) - br6(k) + t7 = br7(k) + br5(k) + pr = p7*(t7+t5) + pi = p7*(t7-t5) + tt0 = t0 + t2 + tt1 = t1 + t3 + t2 = t0 - t2 + t3 = t1 - t3 + t4 = t4 + t4 + t5 = pr + pr + t6 = t6 + t6 + t7 = pi + pi + br0(k) = tt0 + t4 + br1(k) = tt1 + t5 + br2(k) = t2 + t6 + br3(k) = t3 + t7 + br4(k) = tt0 - t4 + br5(k) = tt1 - t5 + br6(k) = t2 - t6 + br7(k) = t3 - t7 + 60 continue + if (nn-8) 120, 120, 70 + 70 k0 = int*8 + 1 + kl = k0 + int - 1 + do 80 k=k0,kl + t1 = bi0(k) + bi6(k) + t2 = bi7(k) - bi1(k) + t3 = bi0(k) - bi6(k) + t4 = bi7(k) + bi1(k) + pr = t3*c22 + t4*s22 + pi = t4*c22 - t3*s22 + t5 = bi2(k) + bi4(k) + t6 = bi5(k) - bi3(k) + t7 = bi2(k) - bi4(k) + t8 = bi5(k) + bi3(k) + rr = t8*c22 - t7*s22 + ri = -t8*s22 - t7*c22 + bi0(k) = (t1+t5) + (t1+t5) + bi4(k) = (t2+t6) + (t2+t6) + bi1(k) = (pr+rr) + (pr+rr) + bi5(k) = (pi+ri) + (pi+ri) + t5 = t1 - t5 + t6 = t2 - t6 + bi2(k) = p7two*(t6+t5) + bi6(k) = p7two*(t6-t5) + rr = pr - rr + ri = pi - ri + bi3(k) = p7two*(ri+rr) + bi7(k) = p7two*(ri-rr) + 80 continue + go to 120 + 90 arg = th2*piovn + c1 = cos(arg) + s1 = -sin(arg) + c2 = c1**2 - s1**2 + s2 = c1*s1 + c1*s1 + c3 = c1*c2 - s1*s2 + s3 = c2*s1 + s2*c1 + c4 = c2**2 - s2**2 + s4 = c2*s2 + c2*s2 + c5 = c2*c3 - s2*s3 + s5 = c3*s2 + s3*c2 + c6 = c3**2 - s3**2 + s6 = c3*s3 + c3*s3 + c7 = c3*c4 - s3*s4 + s7 = c4*s3 + s4*c3 + int8 = int*8 + j0 = jr*int8 + 1 + k0 = ji*int8 + 1 + jlast = j0 + int - 1 + do 100 j=j0,jlast + k = k0 + j - j0 + tr0 = br0(j) + bi6(k) + ti0 = bi7(k) - br1(j) + tr1 = br0(j) - bi6(k) + ti1 = bi7(k) + br1(j) + tr2 = br2(j) + bi4(k) + ti2 = bi5(k) - br3(j) + tr3 = bi5(k) + br3(j) + ti3 = bi4(k) - br2(j) + tr4 = br4(j) + bi2(k) + ti4 = bi3(k) - br5(j) + t0 = br4(j) - bi2(k) + t1 = bi3(k) + br5(j) + tr5 = p7*(t0+t1) + ti5 = p7*(t1-t0) + tr6 = br6(j) + bi0(k) + ti6 = bi1(k) - br7(j) + t0 = br6(j) - bi0(k) + t1 = bi1(k) + br7(j) + tr7 = -p7*(t0-t1) + ti7 = -p7*(t1+t0) + t0 = tr0 + tr2 + t1 = ti0 + ti2 + t2 = tr1 + tr3 + t3 = ti1 + ti3 + tr2 = tr0 - tr2 + ti2 = ti0 - ti2 + tr3 = tr1 - tr3 + ti3 = ti1 - ti3 + t4 = tr4 + tr6 + t5 = ti4 + ti6 + t6 = tr5 + tr7 + t7 = ti5 + ti7 + ttr6 = ti4 - ti6 + ti6 = tr6 - tr4 + ttr7 = ti5 - ti7 + ti7 = tr7 - tr5 + br0(j) = t0 + t4 + bi0(k) = t1 + t5 + br1(j) = c1*(t2+t6) - s1*(t3+t7) + bi1(k) = c1*(t3+t7) + s1*(t2+t6) + br2(j) = c2*(tr2+ttr6) - s2*(ti2+ti6) + bi2(k) = c2*(ti2+ti6) + s2*(tr2+ttr6) + br3(j) = c3*(tr3+ttr7) - s3*(ti3+ti7) + bi3(k) = c3*(ti3+ti7) + s3*(tr3+ttr7) + br4(j) = c4*(t0-t4) - s4*(t1-t5) + bi4(k) = c4*(t1-t5) + s4*(t0-t4) + br5(j) = c5*(t2-t6) - s5*(t3-t7) + bi5(k) = c5*(t3-t7) + s5*(t2-t6) + br6(j) = c6*(tr2-ttr6) - s6*(ti2-ti6) + bi6(k) = c6*(ti2-ti6) + s6*(tr2-ttr6) + br7(j) = c7*(tr3-ttr7) - s7*(ti3-ti7) + bi7(k) = c7*(ti3-ti7) + s7*(tr3-ttr7) + 100 continue + jr = jr + 2 + ji = ji - 2 + if (ji-jl) 110, 110, 120 + 110 ji = 2*jr - 1 + jl = jr + 120 continue + return + end +c +c----------------------------------------------------------------------- +c subroutine: ord1 +c in-place reordering subroutine +c----------------------------------------------------------------------- +c + subroutine ord1(m, b) + dimension b(2) +c + k = 4 + kl = 2 + n = 2**m + do 40 j=4,n,2 + if (k-j) 20, 20, 10 + 10 t = b(j) + b(j) = b(k) + b(k) = t + 20 k = k - 2 + if (k-kl) 30, 30, 40 + 30 k = 2*j + kl = j + 40 continue + return + end +c +c----------------------------------------------------------------------- +c subroutine: ord2 +c in-place reordering subroutine +c----------------------------------------------------------------------- +c + subroutine ord2(m, b) + dimension l(15), b(2) + equivalence (l15,l(1)), (l14,l(2)), (l13,l(3)), (l12,l(4)), + * (l11,l(5)), (l10,l(6)), (l9,l(7)), (l8,l(8)), (l7,l(9)), + * (l6,l(10)), (l5,l(11)), (l4,l(12)), (l3,l(13)), (l2,l(14)), + * (l1,l(15)) + n = 2**m + l(1) = n + do 10 k=2,m + l(k) = l(k-1)/2 + 10 continue + do 20 k=m,14 + l(k+1) = 2 + 20 continue + ij = 2 + do 40 j1=2,l1,2 + do 40 j2=j1,l2,l1 + do 40 j3=j2,l3,l2 + do 40 j4=j3,l4,l3 + do 40 j5=j4,l5,l4 + do 40 j6=j5,l6,l5 + do 40 j7=j6,l7,l6 + do 40 j8=j7,l8,l7 + do 40 j9=j8,l9,l8 + do 40 j10=j9,l10,l9 + do 40 j11=j10,l11,l10 + do 40 j12=j11,l12,l11 + do 40 j13=j12,l13,l12 + do 40 j14=j13,l14,l13 + do 40 ji=j14,l15,l14 + if (ij-ji) 30, 40, 40 + 30 t = b(ij-1) + b(ij-1) = b(ji-1) + b(ji-1) = t + t = b(ij) + b(ij) = b(ji) + b(ji) = t + 40 ij = ij + 2 + return + end diff --git a/sys/vops/fftx.f b/sys/vops/fftx.f new file mode 100644 index 00000000..2e8a5620 --- /dev/null +++ b/sys/vops/fftx.f @@ -0,0 +1,277 @@ +c +c----------------------------------------------------------------------- +c subroutine: fft842 +c fast fourier transform for n=2**m +c complex input +c----------------------------------------------------------------------- +c + subroutine fft842 (in, n, x, y, ier) +c +c this program replaces the vector z=x+iy by its finite +c discrete, complex fourier transform if in=0. the inverse transform +c is calculated for in=1. it performs as many base +c 8 iterations as possible and then finishes with a base 4 iteration +c or a base 2 iteration if needed. +c +c the subroutine is called as subroutine fft842 (in,n,x,y). +c the integer n (a power of 2), the n real location array x, and +c the n real location array y must be supplied to the subroutine. +c + dimension x(*), y(*), l(15) + common /con2/ pi2, p7 + equivalence (l15,l(1)), (l14,l(2)), (l13,l(3)), (l12,l(4)), + * (l11,l(5)), (l10,l(6)), (l9,l(7)), (l8,l(8)), (l7,l(9)), + * (l6,l(10)), (l5,l(11)), (l4,l(12)), (l3,l(13)), (l2,l(14)), + * (l1,l(15)) +c +c +c iw is a machine dependent write device number +c +c+noao +c iw = i1mach(2) + ier = 0 +c-noao +c + pi2 = 8.*atan(1.) + p7 = 1./sqrt(2.) + do 10 i=1,31 + m = i + nt = 2**i + if (n.eq.nt) go to 20 + 10 continue +c+noao +c write (iw,9999) +c9999 format (35h n is not a power of two for fft842) +c stop + ier = 1 + return +c-noao + 20 n2pow = m + nthpo = n + fn = nthpo + if (in.eq.1) go to 40 + do 30 i=1,nthpo + y(i) = -y(i) + 30 continue + 40 n8pow = n2pow/3 + if (n8pow.eq.0) go to 60 +c +c radix 8 passes,if any. +c + do 50 ipass=1,n8pow + nxtlt = 2**(n2pow-3*ipass) + lengt = 8*nxtlt + call r8tx(nxtlt, nthpo, lengt, x(1), x(nxtlt+1), x(2*nxtlt+1), + * x(3*nxtlt+1), x(4*nxtlt+1), x(5*nxtlt+1), x(6*nxtlt+1), + * x(7*nxtlt+1), y(1), y(nxtlt+1), y(2*nxtlt+1), y(3*nxtlt+1), + * y(4*nxtlt+1), y(5*nxtlt+1), y(6*nxtlt+1), y(7*nxtlt+1)) + 50 continue +c +c is there a four factor left +c + 60 if (n2pow-3*n8pow-1) 90, 70, 80 +c +c go through the base 2 iteration +c +c + 70 call r2tx(nthpo, x(1), x(2), y(1), y(2)) + go to 90 +c +c go through the base 4 iteration +c + 80 call r4tx(nthpo, x(1), x(2), x(3), x(4), y(1), y(2), y(3), y(4)) +c + 90 do 110 j=1,31 + l(j) = 1 + if (j-n2pow) 100, 100, 110 + 100 l(j) = 2**(n2pow+1-j) + 110 continue + ij = 1 + do 130 j1=1,l1 + do 130 j2=j1,l2,l1 + do 130 j3=j2,l3,l2 + do 130 j4=j3,l4,l3 + do 130 j5=j4,l5,l4 + do 130 j6=j5,l6,l5 + do 130 j7=j6,l7,l6 + do 130 j8=j7,l8,l7 + do 130 j9=j8,l9,l8 + do 130 j10=j9,l10,l9 + do 130 j11=j10,l11,l10 + do 130 j12=j11,l12,l11 + do 130 j13=j12,l13,l12 + do 130 j14=j13,l14,l13 + do 130 ji=j14,l15,l14 + if (ij-ji) 120, 130, 130 + 120 r = x(ij) + x(ij) = x(ji) + x(ji) = r + fi = y(ij) + y(ij) = y(ji) + y(ji) = fi + 130 ij = ij + 1 + if (in.eq.1) go to 150 + do 140 i=1,nthpo + y(i) = -y(i) + 140 continue + go to 170 + 150 do 160 i=1,nthpo + x(i) = x(i)/fn + y(i) = y(i)/fn + 160 continue + 170 return + end +c +c----------------------------------------------------------------------- +c subroutine: r2tx +c radix 2 iteration subroutine +c----------------------------------------------------------------------- +c + subroutine r2tx(nthpo, cr0, cr1, ci0, ci1) + dimension cr0(2), cr1(2), ci0(2), ci1(2) + do 10 k=1,nthpo,2 + r1 = cr0(k) + cr1(k) + cr1(k) = cr0(k) - cr1(k) + cr0(k) = r1 + fi1 = ci0(k) + ci1(k) + ci1(k) = ci0(k) - ci1(k) + ci0(k) = fi1 + 10 continue + return + end +c +c----------------------------------------------------------------------- +c subroutine: r4tx +c radix 4 iteration subroutine +c----------------------------------------------------------------------- +c + subroutine r4tx(nthpo, cr0, cr1, cr2, cr3, ci0, ci1, ci2, ci3) + dimension cr0(2), cr1(2), cr2(2), cr3(2), ci0(2), ci1(2), ci2(2), + * ci3(2) + do 10 k=1,nthpo,4 + r1 = cr0(k) + cr2(k) + r2 = cr0(k) - cr2(k) + r3 = cr1(k) + cr3(k) + r4 = cr1(k) - cr3(k) + fi1 = ci0(k) + ci2(k) + fi2 = ci0(k) - ci2(k) + fi3 = ci1(k) + ci3(k) + fi4 = ci1(k) - ci3(k) + cr0(k) = r1 + r3 + ci0(k) = fi1 + fi3 + cr1(k) = r1 - r3 + ci1(k) = fi1 - fi3 + cr2(k) = r2 - fi4 + ci2(k) = fi2 + r4 + cr3(k) = r2 + fi4 + ci3(k) = fi2 - r4 + 10 continue + return + end +c +c----------------------------------------------------------------------- +c subroutine: r8tx +c radix 8 iteration subroutine +c----------------------------------------------------------------------- +c + subroutine r8tx(nxtlt, nthpo, lengt, cr0, cr1, cr2, cr3, cr4, + * cr5, cr6, cr7, ci0, ci1, ci2, ci3, ci4, ci5, ci6, ci7) + dimension cr0(2), cr1(2), cr2(2), cr3(2), cr4(2), cr5(2), cr6(2), + * cr7(2), ci1(2), ci2(2), ci3(2), ci4(2), ci5(2), ci6(2), + * ci7(2), ci0(2) + common /con2/ pi2, p7 +c + scale = pi2/float(lengt) + do 30 j=1,nxtlt + arg = float(j-1)*scale + c1 = cos(arg) + s1 = sin(arg) + c2 = c1**2 - s1**2 + s2 = c1*s1 + c1*s1 + c3 = c1*c2 - s1*s2 + s3 = c2*s1 + s2*c1 + c4 = c2**2 - s2**2 + s4 = c2*s2 + c2*s2 + c5 = c2*c3 - s2*s3 + s5 = c3*s2 + s3*c2 + c6 = c3**2 - s3**2 + s6 = c3*s3 + c3*s3 + c7 = c3*c4 - s3*s4 + s7 = c4*s3 + s4*c3 + do 20 k=j,nthpo,lengt + ar0 = cr0(k) + cr4(k) + ar1 = cr1(k) + cr5(k) + ar2 = cr2(k) + cr6(k) + ar3 = cr3(k) + cr7(k) + ar4 = cr0(k) - cr4(k) + ar5 = cr1(k) - cr5(k) + ar6 = cr2(k) - cr6(k) + ar7 = cr3(k) - cr7(k) + ai0 = ci0(k) + ci4(k) + ai1 = ci1(k) + ci5(k) + ai2 = ci2(k) + ci6(k) + ai3 = ci3(k) + ci7(k) + ai4 = ci0(k) - ci4(k) + ai5 = ci1(k) - ci5(k) + ai6 = ci2(k) - ci6(k) + ai7 = ci3(k) - ci7(k) + br0 = ar0 + ar2 + br1 = ar1 + ar3 + br2 = ar0 - ar2 + br3 = ar1 - ar3 + br4 = ar4 - ai6 + br5 = ar5 - ai7 + br6 = ar4 + ai6 + br7 = ar5 + ai7 + bi0 = ai0 + ai2 + bi1 = ai1 + ai3 + bi2 = ai0 - ai2 + bi3 = ai1 - ai3 + bi4 = ai4 + ar6 + bi5 = ai5 + ar7 + bi6 = ai4 - ar6 + bi7 = ai5 - ar7 + cr0(k) = br0 + br1 + ci0(k) = bi0 + bi1 + if (j.le.1) go to 10 + cr1(k) = c4*(br0-br1) - s4*(bi0-bi1) + ci1(k) = c4*(bi0-bi1) + s4*(br0-br1) + cr2(k) = c2*(br2-bi3) - s2*(bi2+br3) + ci2(k) = c2*(bi2+br3) + s2*(br2-bi3) + cr3(k) = c6*(br2+bi3) - s6*(bi2-br3) + ci3(k) = c6*(bi2-br3) + s6*(br2+bi3) + tr = p7*(br5-bi5) + ti = p7*(br5+bi5) + cr4(k) = c1*(br4+tr) - s1*(bi4+ti) + ci4(k) = c1*(bi4+ti) + s1*(br4+tr) + cr5(k) = c5*(br4-tr) - s5*(bi4-ti) + ci5(k) = c5*(bi4-ti) + s5*(br4-tr) + tr = -p7*(br7+bi7) + ti = p7*(br7-bi7) + cr6(k) = c3*(br6+tr) - s3*(bi6+ti) + ci6(k) = c3*(bi6+ti) + s3*(br6+tr) + cr7(k) = c7*(br6-tr) - s7*(bi6-ti) + ci7(k) = c7*(bi6-ti) + s7*(br6-tr) + go to 20 + 10 cr1(k) = br0 - br1 + ci1(k) = bi0 - bi1 + cr2(k) = br2 - bi3 + ci2(k) = bi2 + br3 + cr3(k) = br2 + bi3 + ci3(k) = bi2 - br3 + tr = p7*(br5-bi5) + ti = p7*(br5+bi5) + cr4(k) = br4 + tr + ci4(k) = bi4 + ti + cr5(k) = br4 - tr + ci5(k) = bi4 - ti + tr = -p7*(br7+bi7) + ti = p7*(br7-bi7) + cr6(k) = br6 + tr + ci6(k) = bi6 + ti + cr7(k) = br6 - tr + ci7(k) = bi6 - ti + 20 continue + 30 continue + return + end diff --git a/sys/vops/lz/alani.x b/sys/vops/lz/alani.x new file mode 100644 index 00000000..28fb324e --- /dev/null +++ b/sys/vops/lz/alani.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALAN -- Compute the logical AND of two vectors (generic). The logical +# output value is returned as an int. + +procedure alani (a, b, c, npix) + +int a[ARB], b[ARB] +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 && b[i] != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/lz/alanki.x b/sys/vops/lz/alanki.x new file mode 100644 index 00000000..a5523400 --- /dev/null +++ b/sys/vops/lz/alanki.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALANK -- Compute the logical AND of a vector and a constant (generic). +# The logical output value is returned as an int. + +procedure alanki (a, b, c, npix) + +int a[ARB], b +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 && b != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/lz/alankl.x b/sys/vops/lz/alankl.x new file mode 100644 index 00000000..b223303c --- /dev/null +++ b/sys/vops/lz/alankl.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALANK -- Compute the logical AND of a vector and a constant (generic). +# The logical output value is returned as an int. + +procedure alankl (a, b, c, npix) + +long a[ARB], b +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 && b != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/lz/alanks.x b/sys/vops/lz/alanks.x new file mode 100644 index 00000000..f63e0371 --- /dev/null +++ b/sys/vops/lz/alanks.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALANK -- Compute the logical AND of a vector and a constant (generic). +# The logical output value is returned as an int. + +procedure alanks (a, b, c, npix) + +short a[ARB], b +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 && b != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/lz/alanl.x b/sys/vops/lz/alanl.x new file mode 100644 index 00000000..b06304bd --- /dev/null +++ b/sys/vops/lz/alanl.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALAN -- Compute the logical AND of two vectors (generic). The logical +# output value is returned as an int. + +procedure alanl (a, b, c, npix) + +long a[ARB], b[ARB] +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 && b[i] != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/lz/alans.x b/sys/vops/lz/alans.x new file mode 100644 index 00000000..b2ff25c5 --- /dev/null +++ b/sys/vops/lz/alans.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALAN -- Compute the logical AND of two vectors (generic). The logical +# output value is returned as an int. + +procedure alans (a, b, c, npix) + +short a[ARB], b[ARB] +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 && b[i] != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/lz/alimc.x b/sys/vops/lz/alimc.x new file mode 100644 index 00000000..6f05be93 --- /dev/null +++ b/sys/vops/lz/alimc.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALIM -- Compute the limits (minimum and maximum values) of a vector. + +procedure alimc (a, npix, minval, maxval) + +char a[ARB], minval, maxval, value +int npix, i + +begin + minval = a[1] + maxval = a[1] + + do i = 1, npix { + value = a[i] + if (value < minval) + minval = value + else if (value > maxval) + maxval = value + } +end diff --git a/sys/vops/lz/alimd.x b/sys/vops/lz/alimd.x new file mode 100644 index 00000000..2e56673d --- /dev/null +++ b/sys/vops/lz/alimd.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALIM -- Compute the limits (minimum and maximum values) of a vector. + +procedure alimd (a, npix, minval, maxval) + +double a[ARB], minval, maxval, value +int npix, i + +begin + minval = a[1] + maxval = a[1] + + do i = 1, npix { + value = a[i] + if (value < minval) + minval = value + else if (value > maxval) + maxval = value + } +end diff --git a/sys/vops/lz/alimi.x b/sys/vops/lz/alimi.x new file mode 100644 index 00000000..0a043976 --- /dev/null +++ b/sys/vops/lz/alimi.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALIM -- Compute the limits (minimum and maximum values) of a vector. + +procedure alimi (a, npix, minval, maxval) + +int a[ARB], minval, maxval, value +int npix, i + +begin + minval = a[1] + maxval = a[1] + + do i = 1, npix { + value = a[i] + if (value < minval) + minval = value + else if (value > maxval) + maxval = value + } +end diff --git a/sys/vops/lz/aliml.x b/sys/vops/lz/aliml.x new file mode 100644 index 00000000..abbad1c5 --- /dev/null +++ b/sys/vops/lz/aliml.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALIM -- Compute the limits (minimum and maximum values) of a vector. + +procedure aliml (a, npix, minval, maxval) + +long a[ARB], minval, maxval, value +int npix, i + +begin + minval = a[1] + maxval = a[1] + + do i = 1, npix { + value = a[i] + if (value < minval) + minval = value + else if (value > maxval) + maxval = value + } +end diff --git a/sys/vops/lz/alimr.x b/sys/vops/lz/alimr.x new file mode 100644 index 00000000..6845f36c --- /dev/null +++ b/sys/vops/lz/alimr.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALIM -- Compute the limits (minimum and maximum values) of a vector. + +procedure alimr (a, npix, minval, maxval) + +real a[ARB], minval, maxval, value +int npix, i + +begin + minval = a[1] + maxval = a[1] + + do i = 1, npix { + value = a[i] + if (value < minval) + minval = value + else if (value > maxval) + maxval = value + } +end diff --git a/sys/vops/lz/alims.x b/sys/vops/lz/alims.x new file mode 100644 index 00000000..71d5c498 --- /dev/null +++ b/sys/vops/lz/alims.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALIM -- Compute the limits (minimum and maximum values) of a vector. + +procedure alims (a, npix, minval, maxval) + +short a[ARB], minval, maxval, value +int npix, i + +begin + minval = a[1] + maxval = a[1] + + do i = 1, npix { + value = a[i] + if (value < minval) + minval = value + else if (value > maxval) + maxval = value + } +end diff --git a/sys/vops/lz/alimx.x b/sys/vops/lz/alimx.x new file mode 100644 index 00000000..93a7fe61 --- /dev/null +++ b/sys/vops/lz/alimx.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALIM -- Compute the limits (minimum and maximum values) of a vector. + +procedure alimx (a, npix, minval, maxval) + +complex a[ARB], minval, maxval, value +int npix, i + +begin + minval = a[1] + maxval = a[1] + + do i = 1, npix { + value = a[i] + if (abs(value) < abs(minval)) + minval = value + else if (abs(value) > abs(maxval)) + maxval = value + } +end diff --git a/sys/vops/lz/allnd.x b/sys/vops/lz/allnd.x new file mode 100644 index 00000000..82ae72bd --- /dev/null +++ b/sys/vops/lz/allnd.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALLN -- Compute the natural logarithm of a vector (generic). If the natural +# logarithm is undefined (x <= 0) a user supplied function is called to get +# the pixel value to be returned. + +procedure allnd (a, b, npix, errfcn) + +double a[ARB], b[ARB] +int npix, i +extern errfcn() +double errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] <= 0.0D0) + b[i] = errfcn (a[i]) + else { + b[i] = log (a[i]) + } + } +end diff --git a/sys/vops/lz/allni.x b/sys/vops/lz/allni.x new file mode 100644 index 00000000..9dc1bf4a --- /dev/null +++ b/sys/vops/lz/allni.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALLN -- Compute the natural logarithm of a vector (generic). If the natural +# logarithm is undefined (x <= 0) a user supplied function is called to get +# the pixel value to be returned. + +procedure allni (a, b, npix, errfcn) + +int a[ARB], b[ARB] +int npix, i +extern errfcn() +int errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] <= 0) + b[i] = errfcn (a[i]) + else { + b[i] = log (real (a[i])) + } + } +end diff --git a/sys/vops/lz/allnl.x b/sys/vops/lz/allnl.x new file mode 100644 index 00000000..afc1a62e --- /dev/null +++ b/sys/vops/lz/allnl.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALLN -- Compute the natural logarithm of a vector (generic). If the natural +# logarithm is undefined (x <= 0) a user supplied function is called to get +# the pixel value to be returned. + +procedure allnl (a, b, npix, errfcn) + +long a[ARB], b[ARB] +int npix, i +extern errfcn() +long errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] <= 0) + b[i] = errfcn (a[i]) + else { + b[i] = log (double (a[i])) + } + } +end diff --git a/sys/vops/lz/allnr.x b/sys/vops/lz/allnr.x new file mode 100644 index 00000000..469ce448 --- /dev/null +++ b/sys/vops/lz/allnr.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALLN -- Compute the natural logarithm of a vector (generic). If the natural +# logarithm is undefined (x <= 0) a user supplied function is called to get +# the pixel value to be returned. + +procedure allnr (a, b, npix, errfcn) + +real a[ARB], b[ARB] +int npix, i +extern errfcn() +real errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] <= 0.0) + b[i] = errfcn (a[i]) + else { + b[i] = log (a[i]) + } + } +end diff --git a/sys/vops/lz/allns.x b/sys/vops/lz/allns.x new file mode 100644 index 00000000..3d968186 --- /dev/null +++ b/sys/vops/lz/allns.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALLN -- Compute the natural logarithm of a vector (generic). If the natural +# logarithm is undefined (x <= 0) a user supplied function is called to get +# the pixel value to be returned. + +procedure allns (a, b, npix, errfcn) + +short a[ARB], b[ARB] +int npix, i +extern errfcn() +short errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] <= 0) + b[i] = errfcn (a[i]) + else { + b[i] = log (real (a[i])) + } + } +end diff --git a/sys/vops/lz/allnx.x b/sys/vops/lz/allnx.x new file mode 100644 index 00000000..b4527117 --- /dev/null +++ b/sys/vops/lz/allnx.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALLN -- Compute the natural logarithm of a vector (generic). If the natural +# logarithm is undefined (x <= 0) a user supplied function is called to get +# the pixel value to be returned. + +procedure allnx (a, b, npix, errfcn) + +complex a[ARB], b[ARB] +int npix, i +extern errfcn() +complex errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] == (0.0,0.0)) + b[i] = errfcn (a[i]) + else { + b[i] = log (a[i]) + } + } +end diff --git a/sys/vops/lz/alogd.x b/sys/vops/lz/alogd.x new file mode 100644 index 00000000..b5f7b78f --- /dev/null +++ b/sys/vops/lz/alogd.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOG -- Compute the logarithm to the base 10 of a vector (generic). If the +# logarithm is undefined (x <= 0) a user supplied function is called to get +# the function value. + +procedure alogd (a, b, npix, errfcn) + +double a[ARB], b[ARB] +int npix, i +extern errfcn() +double errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] <= 0.0D0) + b[i] = errfcn (a[i]) + else { + # Note Fortran standard forbids log10(cplx). + b[i] = log10 (a[i]) + } + } +end diff --git a/sys/vops/lz/alogi.x b/sys/vops/lz/alogi.x new file mode 100644 index 00000000..294289c5 --- /dev/null +++ b/sys/vops/lz/alogi.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOG -- Compute the logarithm to the base 10 of a vector (generic). If the +# logarithm is undefined (x <= 0) a user supplied function is called to get +# the function value. + +procedure alogi (a, b, npix, errfcn) + +int a[ARB], b[ARB] +int npix, i +extern errfcn() +int errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] <= 0) + b[i] = errfcn (a[i]) + else { + # Note Fortran standard forbids log10(cplx). + b[i] = log10 (real (a[i])) + } + } +end diff --git a/sys/vops/lz/alogl.x b/sys/vops/lz/alogl.x new file mode 100644 index 00000000..1af0e2f5 --- /dev/null +++ b/sys/vops/lz/alogl.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOG -- Compute the logarithm to the base 10 of a vector (generic). If the +# logarithm is undefined (x <= 0) a user supplied function is called to get +# the function value. + +procedure alogl (a, b, npix, errfcn) + +long a[ARB], b[ARB] +int npix, i +extern errfcn() +long errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] <= 0) + b[i] = errfcn (a[i]) + else { + # Note Fortran standard forbids log10(cplx). + b[i] = log10 (double (a[i])) + } + } +end diff --git a/sys/vops/lz/alogr.x b/sys/vops/lz/alogr.x new file mode 100644 index 00000000..049f7cc7 --- /dev/null +++ b/sys/vops/lz/alogr.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOG -- Compute the logarithm to the base 10 of a vector (generic). If the +# logarithm is undefined (x <= 0) a user supplied function is called to get +# the function value. + +procedure alogr (a, b, npix, errfcn) + +real a[ARB], b[ARB] +int npix, i +extern errfcn() +real errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] <= 0.0) + b[i] = errfcn (a[i]) + else { + # Note Fortran standard forbids log10(cplx). + b[i] = log10 (a[i]) + } + } +end diff --git a/sys/vops/lz/alogs.x b/sys/vops/lz/alogs.x new file mode 100644 index 00000000..861185a5 --- /dev/null +++ b/sys/vops/lz/alogs.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOG -- Compute the logarithm to the base 10 of a vector (generic). If the +# logarithm is undefined (x <= 0) a user supplied function is called to get +# the function value. + +procedure alogs (a, b, npix, errfcn) + +short a[ARB], b[ARB] +int npix, i +extern errfcn() +short errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] <= 0) + b[i] = errfcn (a[i]) + else { + # Note Fortran standard forbids log10(cplx). + b[i] = log10 (real (a[i])) + } + } +end diff --git a/sys/vops/lz/alogx.x b/sys/vops/lz/alogx.x new file mode 100644 index 00000000..adb78cc6 --- /dev/null +++ b/sys/vops/lz/alogx.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOG -- Compute the logarithm to the base 10 of a vector (generic). If the +# logarithm is undefined (x <= 0) a user supplied function is called to get +# the function value. + +procedure alogx (a, b, npix, errfcn) + +complex a[ARB], b[ARB] +int npix, i +extern errfcn() +complex errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] == (0.0,0.0)) + b[i] = errfcn (a[i]) + else { + # Note Fortran standard forbids log10(cplx). + b[i] = log10 (real (a[i])) + } + } +end diff --git a/sys/vops/lz/alori.x b/sys/vops/lz/alori.x new file mode 100644 index 00000000..07fefc59 --- /dev/null +++ b/sys/vops/lz/alori.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOR -- Compute the logical OR of a vector and a constant (generic). +# The logical output value is returned as an int. + +procedure alori (a, b, c, npix) + +int a[ARB], b[ARB] +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 || b[i] != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/lz/alorki.x b/sys/vops/lz/alorki.x new file mode 100644 index 00000000..1fa2089e --- /dev/null +++ b/sys/vops/lz/alorki.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALORK -- Compute the logical OR of a vector and a constant (generic). +# The logical output value is returned as an int. + +procedure alorki (a, b, c, npix) + +int a[ARB], b +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 || b != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/lz/alorkl.x b/sys/vops/lz/alorkl.x new file mode 100644 index 00000000..eedcb247 --- /dev/null +++ b/sys/vops/lz/alorkl.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALORK -- Compute the logical OR of a vector and a constant (generic). +# The logical output value is returned as an int. + +procedure alorkl (a, b, c, npix) + +long a[ARB], b +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 || b != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/lz/alorks.x b/sys/vops/lz/alorks.x new file mode 100644 index 00000000..a38924c9 --- /dev/null +++ b/sys/vops/lz/alorks.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALORK -- Compute the logical OR of a vector and a constant (generic). +# The logical output value is returned as an int. + +procedure alorks (a, b, c, npix) + +short a[ARB], b +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 || b != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/lz/alorl.x b/sys/vops/lz/alorl.x new file mode 100644 index 00000000..bd23bcb1 --- /dev/null +++ b/sys/vops/lz/alorl.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOR -- Compute the logical OR of a vector and a constant (generic). +# The logical output value is returned as an int. + +procedure alorl (a, b, c, npix) + +long a[ARB], b[ARB] +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 || b[i] != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/lz/alors.x b/sys/vops/lz/alors.x new file mode 100644 index 00000000..a87c5915 --- /dev/null +++ b/sys/vops/lz/alors.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOR -- Compute the logical OR of a vector and a constant (generic). +# The logical output value is returned as an int. + +procedure alors (a, b, c, npix) + +short a[ARB], b[ARB] +int c[ARB] + +int npix, i + +begin + do i = 1, npix + if (a[i] != 0 || b[i] != 0) + c[i] = YES + else + c[i] = NO +end diff --git a/sys/vops/lz/alovc.x b/sys/vops/lz/alovc.x new file mode 100644 index 00000000..39b5ff34 --- /dev/null +++ b/sys/vops/lz/alovc.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOV -- Compute the low value (minimum) of a vector. + +char procedure alovc (a, npix) + +char a[ARB] +int npix +char low, pixval +int i + +begin + low = a[1] + + do i = 1, npix { + pixval = a[i] + if (pixval < low) + low = pixval + } + + return (low) +end diff --git a/sys/vops/lz/alovd.x b/sys/vops/lz/alovd.x new file mode 100644 index 00000000..e5de175b --- /dev/null +++ b/sys/vops/lz/alovd.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOV -- Compute the low value (minimum) of a vector. + +double procedure alovd (a, npix) + +double a[ARB] +int npix +double low, pixval +int i + +begin + low = a[1] + + do i = 1, npix { + pixval = a[i] + if (pixval < low) + low = pixval + } + + return (low) +end diff --git a/sys/vops/lz/alovi.x b/sys/vops/lz/alovi.x new file mode 100644 index 00000000..f2045c11 --- /dev/null +++ b/sys/vops/lz/alovi.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOV -- Compute the low value (minimum) of a vector. + +int procedure alovi (a, npix) + +int a[ARB] +int npix +int low, pixval +int i + +begin + low = a[1] + + do i = 1, npix { + pixval = a[i] + if (pixval < low) + low = pixval + } + + return (low) +end diff --git a/sys/vops/lz/alovl.x b/sys/vops/lz/alovl.x new file mode 100644 index 00000000..9fcf4f6d --- /dev/null +++ b/sys/vops/lz/alovl.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOV -- Compute the low value (minimum) of a vector. + +long procedure alovl (a, npix) + +long a[ARB] +int npix +long low, pixval +int i + +begin + low = a[1] + + do i = 1, npix { + pixval = a[i] + if (pixval < low) + low = pixval + } + + return (low) +end diff --git a/sys/vops/lz/alovr.x b/sys/vops/lz/alovr.x new file mode 100644 index 00000000..87e08917 --- /dev/null +++ b/sys/vops/lz/alovr.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOV -- Compute the low value (minimum) of a vector. + +real procedure alovr (a, npix) + +real a[ARB] +int npix +real low, pixval +int i + +begin + low = a[1] + + do i = 1, npix { + pixval = a[i] + if (pixval < low) + low = pixval + } + + return (low) +end diff --git a/sys/vops/lz/alovs.x b/sys/vops/lz/alovs.x new file mode 100644 index 00000000..30a83bed --- /dev/null +++ b/sys/vops/lz/alovs.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOV -- Compute the low value (minimum) of a vector. + +short procedure alovs (a, npix) + +short a[ARB] +int npix +short low, pixval +int i + +begin + low = a[1] + + do i = 1, npix { + pixval = a[i] + if (pixval < low) + low = pixval + } + + return (low) +end diff --git a/sys/vops/lz/alovx.x b/sys/vops/lz/alovx.x new file mode 100644 index 00000000..c0d17deb --- /dev/null +++ b/sys/vops/lz/alovx.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALOV -- Compute the low value (minimum) of a vector. + +complex procedure alovx (a, npix) + +complex a[ARB] +int npix +complex low, pixval +real abs_low +int i + +begin + low = a[1] + abs_low = abs (low) + + do i = 1, npix { + pixval = a[i] + if (abs (pixval) < abs_low) { + low = pixval + abs_low = abs (low) + } + } + + return (low) +end diff --git a/sys/vops/lz/altad.x b/sys/vops/lz/altad.x new file mode 100644 index 00000000..05fca620 --- /dev/null +++ b/sys/vops/lz/altad.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTA -- Linearly map a vector into another vector of the same datatype. +# b[i] = (a[i] + k1) * k2 + +procedure altad (a, b, npix, k1, k2) + +double a[ARB], b[ARB] +double k1, k2 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 +end diff --git a/sys/vops/lz/altai.x b/sys/vops/lz/altai.x new file mode 100644 index 00000000..62576263 --- /dev/null +++ b/sys/vops/lz/altai.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTA -- Linearly map a vector into another vector of the same datatype. +# b[i] = (a[i] + k1) * k2 + +procedure altai (a, b, npix, k1, k2) + +int a[ARB], b[ARB] +real k1, k2 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 +end diff --git a/sys/vops/lz/altal.x b/sys/vops/lz/altal.x new file mode 100644 index 00000000..d95ca1f4 --- /dev/null +++ b/sys/vops/lz/altal.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTA -- Linearly map a vector into another vector of the same datatype. +# b[i] = (a[i] + k1) * k2 + +procedure altal (a, b, npix, k1, k2) + +long a[ARB], b[ARB] +double k1, k2 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 +end diff --git a/sys/vops/lz/altar.x b/sys/vops/lz/altar.x new file mode 100644 index 00000000..031be04d --- /dev/null +++ b/sys/vops/lz/altar.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTA -- Linearly map a vector into another vector of the same datatype. +# b[i] = (a[i] + k1) * k2 + +procedure altar (a, b, npix, k1, k2) + +real a[ARB], b[ARB] +real k1, k2 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 +end diff --git a/sys/vops/lz/altas.x b/sys/vops/lz/altas.x new file mode 100644 index 00000000..7b59d86b --- /dev/null +++ b/sys/vops/lz/altas.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTA -- Linearly map a vector into another vector of the same datatype. +# b[i] = (a[i] + k1) * k2 + +procedure altas (a, b, npix, k1, k2) + +short a[ARB], b[ARB] +real k1, k2 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 +end diff --git a/sys/vops/lz/altax.x b/sys/vops/lz/altax.x new file mode 100644 index 00000000..7d71e97d --- /dev/null +++ b/sys/vops/lz/altax.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTA -- Linearly map a vector into another vector of the same datatype. +# b[i] = (a[i] + k1) * k2 + +procedure altax (a, b, npix, k1, k2) + +complex a[ARB], b[ARB] +real k1, k2 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 +end diff --git a/sys/vops/lz/altmd.x b/sys/vops/lz/altmd.x new file mode 100644 index 00000000..c8a7296b --- /dev/null +++ b/sys/vops/lz/altmd.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTM -- Linearly map a vector into another vector of the same datatype. +# b[i] = (a[i] * k1) + k2 + +procedure altmd (a, b, npix, k1, k2) + +double a[ARB], b[ARB] +double k1, k2 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] * k1) + k2 +end diff --git a/sys/vops/lz/altmi.x b/sys/vops/lz/altmi.x new file mode 100644 index 00000000..64cb93c4 --- /dev/null +++ b/sys/vops/lz/altmi.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTM -- Linearly map a vector into another vector of the same datatype. +# b[i] = (a[i] * k1) + k2 + +procedure altmi (a, b, npix, k1, k2) + +int a[ARB], b[ARB] +real k1, k2 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] * k1) + k2 +end diff --git a/sys/vops/lz/altml.x b/sys/vops/lz/altml.x new file mode 100644 index 00000000..a9727472 --- /dev/null +++ b/sys/vops/lz/altml.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTM -- Linearly map a vector into another vector of the same datatype. +# b[i] = (a[i] * k1) + k2 + +procedure altml (a, b, npix, k1, k2) + +long a[ARB], b[ARB] +double k1, k2 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] * k1) + k2 +end diff --git a/sys/vops/lz/altmr.x b/sys/vops/lz/altmr.x new file mode 100644 index 00000000..a088b75d --- /dev/null +++ b/sys/vops/lz/altmr.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTM -- Linearly map a vector into another vector of the same datatype. +# b[i] = (a[i] * k1) + k2 + +procedure altmr (a, b, npix, k1, k2) + +real a[ARB], b[ARB] +real k1, k2 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] * k1) + k2 +end diff --git a/sys/vops/lz/altms.x b/sys/vops/lz/altms.x new file mode 100644 index 00000000..292db9dc --- /dev/null +++ b/sys/vops/lz/altms.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTM -- Linearly map a vector into another vector of the same datatype. +# b[i] = (a[i] * k1) + k2 + +procedure altms (a, b, npix, k1, k2) + +short a[ARB], b[ARB] +real k1, k2 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] * k1) + k2 +end diff --git a/sys/vops/lz/altmx.x b/sys/vops/lz/altmx.x new file mode 100644 index 00000000..fca0e274 --- /dev/null +++ b/sys/vops/lz/altmx.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTM -- Linearly map a vector into another vector of the same datatype. +# b[i] = (a[i] * k1) + k2 + +procedure altmx (a, b, npix, k1, k2) + +complex a[ARB], b[ARB] +real k1, k2 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] * k1) + k2 +end diff --git a/sys/vops/lz/altrd.x b/sys/vops/lz/altrd.x new file mode 100644 index 00000000..57e877b0 --- /dev/null +++ b/sys/vops/lz/altrd.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTR -- Linearly map a vector into another vector of the same datatype. +# This is the most general form. See also ALTA and ALTM. +# b[i] = (a[i] + k1) * k2 + k3 + +procedure altrd (a, b, npix, k1, k2, k3) + +double a[ARB], b[ARB] +double k1, k2, k3 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 + k3 +end diff --git a/sys/vops/lz/altri.x b/sys/vops/lz/altri.x new file mode 100644 index 00000000..5ef70e85 --- /dev/null +++ b/sys/vops/lz/altri.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTR -- Linearly map a vector into another vector of the same datatype. +# This is the most general form. See also ALTA and ALTM. +# b[i] = (a[i] + k1) * k2 + k3 + +procedure altri (a, b, npix, k1, k2, k3) + +int a[ARB], b[ARB] +real k1, k2, k3 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 + k3 +end diff --git a/sys/vops/lz/altrl.x b/sys/vops/lz/altrl.x new file mode 100644 index 00000000..7c3d48b8 --- /dev/null +++ b/sys/vops/lz/altrl.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTR -- Linearly map a vector into another vector of the same datatype. +# This is the most general form. See also ALTA and ALTM. +# b[i] = (a[i] + k1) * k2 + k3 + +procedure altrl (a, b, npix, k1, k2, k3) + +long a[ARB], b[ARB] +double k1, k2, k3 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 + k3 +end diff --git a/sys/vops/lz/altrr.x b/sys/vops/lz/altrr.x new file mode 100644 index 00000000..f78522f5 --- /dev/null +++ b/sys/vops/lz/altrr.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTR -- Linearly map a vector into another vector of the same datatype. +# This is the most general form. See also ALTA and ALTM. +# b[i] = (a[i] + k1) * k2 + k3 + +procedure altrr (a, b, npix, k1, k2, k3) + +real a[ARB], b[ARB] +real k1, k2, k3 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 + k3 +end diff --git a/sys/vops/lz/altrs.x b/sys/vops/lz/altrs.x new file mode 100644 index 00000000..50458a82 --- /dev/null +++ b/sys/vops/lz/altrs.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTR -- Linearly map a vector into another vector of the same datatype. +# This is the most general form. See also ALTA and ALTM. +# b[i] = (a[i] + k1) * k2 + k3 + +procedure altrs (a, b, npix, k1, k2, k3) + +short a[ARB], b[ARB] +real k1, k2, k3 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 + k3 +end diff --git a/sys/vops/lz/altrx.x b/sys/vops/lz/altrx.x new file mode 100644 index 00000000..d23ad236 --- /dev/null +++ b/sys/vops/lz/altrx.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALTR -- Linearly map a vector into another vector of the same datatype. +# This is the most general form. See also ALTA and ALTM. +# b[i] = (a[i] + k1) * k2 + k3 + +procedure altrx (a, b, npix, k1, k2, k3) + +complex a[ARB], b[ARB] +real k1, k2, k3 +int npix, i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 + k3 +end diff --git a/sys/vops/lz/aluid.x b/sys/vops/lz/aluid.x new file mode 100644 index 00000000..d529ba77 --- /dev/null +++ b/sys/vops/lz/aluid.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ALUI -- Vector lookup and interpolate (linear). B[i] = A(X[i]). +# No bounds checking is performed, but the case A(X[i])=NPIX (no fractional +# part) is recognized and will not cause a reference off the right end of the +# array. This is done in a way which will also cause execution to be faster +# when the sample points are integral, i.e., fall exactly on data points in +# the input array. + +procedure aluid (a, b, x, npix) + +double a[ARB], b[ARB] +real x[ARB], fraction, tol +int npix, i, left_pixel + +begin + tol = EPSILONR * 5.0 + + do i = 1, npix { + left_pixel = int (x[i]) + fraction = x[i] - real(left_pixel) + if (fraction < tol) + b[i] = a[left_pixel] + else + b[i] = a[left_pixel] * (1.0 - fraction) + + a[left_pixel+1] * fraction + } +end diff --git a/sys/vops/lz/aluii.x b/sys/vops/lz/aluii.x new file mode 100644 index 00000000..67d63575 --- /dev/null +++ b/sys/vops/lz/aluii.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ALUI -- Vector lookup and interpolate (linear). B[i] = A(X[i]). +# No bounds checking is performed, but the case A(X[i])=NPIX (no fractional +# part) is recognized and will not cause a reference off the right end of the +# array. This is done in a way which will also cause execution to be faster +# when the sample points are integral, i.e., fall exactly on data points in +# the input array. + +procedure aluii (a, b, x, npix) + +int a[ARB], b[ARB] +real x[ARB], fraction, tol +int npix, i, left_pixel + +begin + tol = EPSILONR * 5.0 + + do i = 1, npix { + left_pixel = int (x[i]) + fraction = x[i] - real(left_pixel) + if (fraction < tol) + b[i] = a[left_pixel] + else + b[i] = a[left_pixel] * (1.0 - fraction) + + a[left_pixel+1] * fraction + } +end diff --git a/sys/vops/lz/aluil.x b/sys/vops/lz/aluil.x new file mode 100644 index 00000000..177fb4e6 --- /dev/null +++ b/sys/vops/lz/aluil.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ALUI -- Vector lookup and interpolate (linear). B[i] = A(X[i]). +# No bounds checking is performed, but the case A(X[i])=NPIX (no fractional +# part) is recognized and will not cause a reference off the right end of the +# array. This is done in a way which will also cause execution to be faster +# when the sample points are integral, i.e., fall exactly on data points in +# the input array. + +procedure aluil (a, b, x, npix) + +long a[ARB], b[ARB] +real x[ARB], fraction, tol +int npix, i, left_pixel + +begin + tol = EPSILONR * 5.0 + + do i = 1, npix { + left_pixel = int (x[i]) + fraction = x[i] - real(left_pixel) + if (fraction < tol) + b[i] = a[left_pixel] + else + b[i] = a[left_pixel] * (1.0 - fraction) + + a[left_pixel+1] * fraction + } +end diff --git a/sys/vops/lz/aluir.x b/sys/vops/lz/aluir.x new file mode 100644 index 00000000..33ef1e4b --- /dev/null +++ b/sys/vops/lz/aluir.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ALUI -- Vector lookup and interpolate (linear). B[i] = A(X[i]). +# No bounds checking is performed, but the case A(X[i])=NPIX (no fractional +# part) is recognized and will not cause a reference off the right end of the +# array. This is done in a way which will also cause execution to be faster +# when the sample points are integral, i.e., fall exactly on data points in +# the input array. + +procedure aluir (a, b, x, npix) + +real a[ARB], b[ARB] +real x[ARB], fraction, tol +int npix, i, left_pixel + +begin + tol = EPSILONR * 5.0 + + do i = 1, npix { + left_pixel = int (x[i]) + fraction = x[i] - real(left_pixel) + if (fraction < tol) + b[i] = a[left_pixel] + else + b[i] = a[left_pixel] * (1.0 - fraction) + + a[left_pixel+1] * fraction + } +end diff --git a/sys/vops/lz/aluis.x b/sys/vops/lz/aluis.x new file mode 100644 index 00000000..d64dfa1a --- /dev/null +++ b/sys/vops/lz/aluis.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ALUI -- Vector lookup and interpolate (linear). B[i] = A(X[i]). +# No bounds checking is performed, but the case A(X[i])=NPIX (no fractional +# part) is recognized and will not cause a reference off the right end of the +# array. This is done in a way which will also cause execution to be faster +# when the sample points are integral, i.e., fall exactly on data points in +# the input array. + +procedure aluis (a, b, x, npix) + +short a[ARB], b[ARB] +real x[ARB], fraction, tol +int npix, i, left_pixel + +begin + tol = EPSILONR * 5.0 + + do i = 1, npix { + left_pixel = int (x[i]) + fraction = x[i] - real(left_pixel) + if (fraction < tol) + b[i] = a[left_pixel] + else + b[i] = a[left_pixel] * (1.0 - fraction) + + a[left_pixel+1] * fraction + } +end diff --git a/sys/vops/lz/alutc.x b/sys/vops/lz/alutc.x new file mode 100644 index 00000000..06d753fe --- /dev/null +++ b/sys/vops/lz/alutc.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALUT -- Map an array using table lookup. Note that an input value of zero +# indexes the first element of the lookup table. No bounds checking is +# performed. + +procedure alutc (a, b, npix, lut) + +char a[ARB] + +char b[ARB] # output data array +char lut[ARB] # lookup table +int npix, i + +begin + do i = 1, npix + b[i] = lut[a[i]+1] +end diff --git a/sys/vops/lz/alutd.x b/sys/vops/lz/alutd.x new file mode 100644 index 00000000..d1e22aea --- /dev/null +++ b/sys/vops/lz/alutd.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALUT -- Map an array using table lookup. Note that an input value of zero +# indexes the first element of the lookup table. No bounds checking is +# performed. + +procedure alutd (a, b, npix, lut) + +int a[ARB] # input array of indices + +double b[ARB] # output data array +double lut[ARB] # lookup table +int npix, i + +begin + do i = 1, npix + b[i] = lut[a[i]+1] +end diff --git a/sys/vops/lz/aluti.x b/sys/vops/lz/aluti.x new file mode 100644 index 00000000..ba3099b3 --- /dev/null +++ b/sys/vops/lz/aluti.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALUT -- Map an array using table lookup. Note that an input value of zero +# indexes the first element of the lookup table. No bounds checking is +# performed. + +procedure aluti (a, b, npix, lut) + +int a[ARB] + +int b[ARB] # output data array +int lut[ARB] # lookup table +int npix, i + +begin + do i = 1, npix + b[i] = lut[a[i]+1] +end diff --git a/sys/vops/lz/alutl.x b/sys/vops/lz/alutl.x new file mode 100644 index 00000000..ccc95ab5 --- /dev/null +++ b/sys/vops/lz/alutl.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALUT -- Map an array using table lookup. Note that an input value of zero +# indexes the first element of the lookup table. No bounds checking is +# performed. + +procedure alutl (a, b, npix, lut) + +long a[ARB] + +long b[ARB] # output data array +long lut[ARB] # lookup table +int npix, i + +begin + do i = 1, npix + b[i] = lut[a[i]+1] +end diff --git a/sys/vops/lz/alutr.x b/sys/vops/lz/alutr.x new file mode 100644 index 00000000..a72cc11f --- /dev/null +++ b/sys/vops/lz/alutr.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALUT -- Map an array using table lookup. Note that an input value of zero +# indexes the first element of the lookup table. No bounds checking is +# performed. + +procedure alutr (a, b, npix, lut) + +int a[ARB] # input array of indices + +real b[ARB] # output data array +real lut[ARB] # lookup table +int npix, i + +begin + do i = 1, npix + b[i] = lut[a[i]+1] +end diff --git a/sys/vops/lz/aluts.x b/sys/vops/lz/aluts.x new file mode 100644 index 00000000..8af08735 --- /dev/null +++ b/sys/vops/lz/aluts.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ALUT -- Map an array using table lookup. Note that an input value of zero +# indexes the first element of the lookup table. No bounds checking is +# performed. + +procedure aluts (a, b, npix, lut) + +short a[ARB] + +short b[ARB] # output data array +short lut[ARB] # lookup table +int npix, i + +begin + do i = 1, npix + b[i] = lut[a[i]+1] +end diff --git a/sys/vops/lz/amagd.x b/sys/vops/lz/amagd.x new file mode 100644 index 00000000..d4238cfd --- /dev/null +++ b/sys/vops/lz/amagd.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAG -- Return the magnitude of two vectors. + +procedure amagd (a, b, c, npix) + +double a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = sqrt (double(a[i] ** 2) + double(b[i] ** 2)) +end diff --git a/sys/vops/lz/amagi.x b/sys/vops/lz/amagi.x new file mode 100644 index 00000000..9bddef17 --- /dev/null +++ b/sys/vops/lz/amagi.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAG -- Return the magnitude of two vectors. + +procedure amagi (a, b, c, npix) + +int a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = sqrt (real(a[i] ** 2) + real(b[i] ** 2)) +end diff --git a/sys/vops/lz/amagl.x b/sys/vops/lz/amagl.x new file mode 100644 index 00000000..31fd69a0 --- /dev/null +++ b/sys/vops/lz/amagl.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAG -- Return the magnitude of two vectors. + +procedure amagl (a, b, c, npix) + +long a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = sqrt (double(a[i] ** 2) + double(b[i] ** 2)) +end diff --git a/sys/vops/lz/amagr.x b/sys/vops/lz/amagr.x new file mode 100644 index 00000000..2db3c085 --- /dev/null +++ b/sys/vops/lz/amagr.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAG -- Return the magnitude of two vectors. + +procedure amagr (a, b, c, npix) + +real a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = sqrt (real(a[i] ** 2) + real(b[i] ** 2)) +end diff --git a/sys/vops/lz/amags.x b/sys/vops/lz/amags.x new file mode 100644 index 00000000..7f86bc75 --- /dev/null +++ b/sys/vops/lz/amags.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAG -- Return the magnitude of two vectors. + +procedure amags (a, b, c, npix) + +short a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = sqrt (real(a[i] ** 2) + real(b[i] ** 2)) +end diff --git a/sys/vops/lz/amagx.x b/sys/vops/lz/amagx.x new file mode 100644 index 00000000..2319394d --- /dev/null +++ b/sys/vops/lz/amagx.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAG -- Return the magnitude of two vectors. + +procedure amagx (a, b, c, npix) + +complex a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = sqrt (a[i] ** 2 + b[i] ** 2) +end diff --git a/sys/vops/lz/amapd.x b/sys/vops/lz/amapd.x new file mode 100644 index 00000000..8f766793 --- /dev/null +++ b/sys/vops/lz/amapd.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAP -- Vector linear transformation. Map the range of pixel values +# a1,a2 from a into the range b1,b2 in b. It is assumed that a1 < a2 +# and b1 < b2. + +procedure amapd (a, b, npix, a1, a2, b1, b2) + +double a[ARB], b[ARB] +double a1, a2, b1, b2 + +double minout, maxout, aoff, boff, pixval + +double scalar + +int npix, i + +begin + scalar = (double (b2) - double (b1)) / (double (a2) - double (a1)) + + minout = min (b1, b2) + maxout = max (b1, b2) + aoff = a1 + boff = b1 + + do i = 1, npix { + pixval = (a[i] - aoff) * scalar + b[i] = max(minout, min(maxout, pixval + boff)) + } +end diff --git a/sys/vops/lz/amapi.x b/sys/vops/lz/amapi.x new file mode 100644 index 00000000..d559a130 --- /dev/null +++ b/sys/vops/lz/amapi.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAP -- Vector linear transformation. Map the range of pixel values +# a1,a2 from a into the range b1,b2 in b. It is assumed that a1 < a2 +# and b1 < b2. + +procedure amapi (a, b, npix, a1, a2, b1, b2) + +int a[ARB], b[ARB] +int a1, a2, b1, b2 + +long minout, maxout, aoff, boff, pixval + +real scalar + +int npix, i + +begin + scalar = (real (b2) - real (b1)) / (real (a2) - real (a1)) + + minout = min (b1, b2) + maxout = max (b1, b2) + aoff = a1 + boff = b1 + + do i = 1, npix { + pixval = (a[i] - aoff) * scalar + b[i] = max(minout, min(maxout, pixval + boff)) + } +end diff --git a/sys/vops/lz/amapl.x b/sys/vops/lz/amapl.x new file mode 100644 index 00000000..c9d350bd --- /dev/null +++ b/sys/vops/lz/amapl.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAP -- Vector linear transformation. Map the range of pixel values +# a1,a2 from a into the range b1,b2 in b. It is assumed that a1 < a2 +# and b1 < b2. + +procedure amapl (a, b, npix, a1, a2, b1, b2) + +long a[ARB], b[ARB] +long a1, a2, b1, b2 + +long minout, maxout, aoff, boff, pixval + +double scalar + +int npix, i + +begin + scalar = (double (b2) - double (b1)) / (double (a2) - double (a1)) + + minout = min (b1, b2) + maxout = max (b1, b2) + aoff = a1 + boff = b1 + + do i = 1, npix { + pixval = (a[i] - aoff) * scalar + b[i] = max(minout, min(maxout, pixval + boff)) + } +end diff --git a/sys/vops/lz/amapr.x b/sys/vops/lz/amapr.x new file mode 100644 index 00000000..d23c44b6 --- /dev/null +++ b/sys/vops/lz/amapr.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAP -- Vector linear transformation. Map the range of pixel values +# a1,a2 from a into the range b1,b2 in b. It is assumed that a1 < a2 +# and b1 < b2. + +procedure amapr (a, b, npix, a1, a2, b1, b2) + +real a[ARB], b[ARB] +real a1, a2, b1, b2 + +real minout, maxout, aoff, boff, pixval + +real scalar + +int npix, i + +begin + scalar = (real (b2) - real (b1)) / (real (a2) - real (a1)) + + minout = min (b1, b2) + maxout = max (b1, b2) + aoff = a1 + boff = b1 + + do i = 1, npix { + pixval = (a[i] - aoff) * scalar + b[i] = max(minout, min(maxout, pixval + boff)) + } +end diff --git a/sys/vops/lz/amaps.x b/sys/vops/lz/amaps.x new file mode 100644 index 00000000..fd3b8fe0 --- /dev/null +++ b/sys/vops/lz/amaps.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAP -- Vector linear transformation. Map the range of pixel values +# a1,a2 from a into the range b1,b2 in b. It is assumed that a1 < a2 +# and b1 < b2. + +procedure amaps (a, b, npix, a1, a2, b1, b2) + +short a[ARB], b[ARB] +short a1, a2, b1, b2 + +long minout, maxout, aoff, boff, pixval + +real scalar + +int npix, i + +begin + scalar = (real (b2) - real (b1)) / (real (a2) - real (a1)) + + minout = min (b1, b2) + maxout = max (b1, b2) + aoff = a1 + boff = b1 + + do i = 1, npix { + pixval = (a[i] - aoff) * scalar + b[i] = max(minout, min(maxout, pixval + boff)) + } +end diff --git a/sys/vops/lz/amaxc.x b/sys/vops/lz/amaxc.x new file mode 100644 index 00000000..89c5808b --- /dev/null +++ b/sys/vops/lz/amaxc.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAX -- Compute the maximum of two vectors (generic). + +procedure amaxc (a, b, c, npix) + +char a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = max (a[i], b[i]) +end diff --git a/sys/vops/lz/amaxd.x b/sys/vops/lz/amaxd.x new file mode 100644 index 00000000..0cd8253b --- /dev/null +++ b/sys/vops/lz/amaxd.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAX -- Compute the maximum of two vectors (generic). + +procedure amaxd (a, b, c, npix) + +double a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = max (a[i], b[i]) +end diff --git a/sys/vops/lz/amaxi.x b/sys/vops/lz/amaxi.x new file mode 100644 index 00000000..0b2f4330 --- /dev/null +++ b/sys/vops/lz/amaxi.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAX -- Compute the maximum of two vectors (generic). + +procedure amaxi (a, b, c, npix) + +int a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = max (a[i], b[i]) +end diff --git a/sys/vops/lz/amaxkc.x b/sys/vops/lz/amaxkc.x new file mode 100644 index 00000000..1b5d250b --- /dev/null +++ b/sys/vops/lz/amaxkc.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAXK -- Compute the maximum of a constant and a vector (generic). + +procedure amaxkc (a, b, c, npix) + +char a[ARB] +char b +char c[ARB] +int npix, i + +begin + + do i = 1, npix + c[i] = max (a[i], b) +end diff --git a/sys/vops/lz/amaxkd.x b/sys/vops/lz/amaxkd.x new file mode 100644 index 00000000..afe6e45e --- /dev/null +++ b/sys/vops/lz/amaxkd.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAXK -- Compute the maximum of a constant and a vector (generic). + +procedure amaxkd (a, b, c, npix) + +double a[ARB] +double b +double c[ARB] +int npix, i + +begin + + do i = 1, npix + c[i] = max (a[i], b) +end diff --git a/sys/vops/lz/amaxki.x b/sys/vops/lz/amaxki.x new file mode 100644 index 00000000..6c74ab6e --- /dev/null +++ b/sys/vops/lz/amaxki.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAXK -- Compute the maximum of a constant and a vector (generic). + +procedure amaxki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix, i + +begin + + do i = 1, npix + c[i] = max (a[i], b) +end diff --git a/sys/vops/lz/amaxkl.x b/sys/vops/lz/amaxkl.x new file mode 100644 index 00000000..bfede4ea --- /dev/null +++ b/sys/vops/lz/amaxkl.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAXK -- Compute the maximum of a constant and a vector (generic). + +procedure amaxkl (a, b, c, npix) + +long a[ARB] +long b +long c[ARB] +int npix, i + +begin + + do i = 1, npix + c[i] = max (a[i], b) +end diff --git a/sys/vops/lz/amaxkr.x b/sys/vops/lz/amaxkr.x new file mode 100644 index 00000000..766c12e5 --- /dev/null +++ b/sys/vops/lz/amaxkr.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAXK -- Compute the maximum of a constant and a vector (generic). + +procedure amaxkr (a, b, c, npix) + +real a[ARB] +real b +real c[ARB] +int npix, i + +begin + + do i = 1, npix + c[i] = max (a[i], b) +end diff --git a/sys/vops/lz/amaxks.x b/sys/vops/lz/amaxks.x new file mode 100644 index 00000000..31aeb0b0 --- /dev/null +++ b/sys/vops/lz/amaxks.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAXK -- Compute the maximum of a constant and a vector (generic). + +procedure amaxks (a, b, c, npix) + +short a[ARB] +short b +short c[ARB] +int npix, i + +begin + + do i = 1, npix + c[i] = max (a[i], b) +end diff --git a/sys/vops/lz/amaxkx.x b/sys/vops/lz/amaxkx.x new file mode 100644 index 00000000..9c3212eb --- /dev/null +++ b/sys/vops/lz/amaxkx.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAXK -- Compute the maximum of a constant and a vector (generic). + +procedure amaxkx (a, b, c, npix) + +complex a[ARB] +complex b +complex c[ARB] +int npix, i +real abs_b + +begin + abs_b = abs (b) + + do i = 1, npix + if (abs(a[i]) >= abs_b) + c[i] = a[i] + else + c[i] = b +end diff --git a/sys/vops/lz/amaxl.x b/sys/vops/lz/amaxl.x new file mode 100644 index 00000000..5f12ba92 --- /dev/null +++ b/sys/vops/lz/amaxl.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAX -- Compute the maximum of two vectors (generic). + +procedure amaxl (a, b, c, npix) + +long a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = max (a[i], b[i]) +end diff --git a/sys/vops/lz/amaxr.x b/sys/vops/lz/amaxr.x new file mode 100644 index 00000000..c6789d5f --- /dev/null +++ b/sys/vops/lz/amaxr.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAX -- Compute the maximum of two vectors (generic). + +procedure amaxr (a, b, c, npix) + +real a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = max (a[i], b[i]) +end diff --git a/sys/vops/lz/amaxs.x b/sys/vops/lz/amaxs.x new file mode 100644 index 00000000..83adb3dc --- /dev/null +++ b/sys/vops/lz/amaxs.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAX -- Compute the maximum of two vectors (generic). + +procedure amaxs (a, b, c, npix) + +short a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = max (a[i], b[i]) +end diff --git a/sys/vops/lz/amaxx.x b/sys/vops/lz/amaxx.x new file mode 100644 index 00000000..7f9b58bb --- /dev/null +++ b/sys/vops/lz/amaxx.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMAX -- Compute the maximum of two vectors (generic). + +procedure amaxx (a, b, c, npix) + +complex a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + if (abs(a[i]) >= abs(b[i])) + c[i] = a[i] + else + c[i] = b[i] +end diff --git a/sys/vops/lz/amed3c.x b/sys/vops/lz/amed3c.x new file mode 100644 index 00000000..f40f6dc1 --- /dev/null +++ b/sys/vops/lz/amed3c.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED3 -- Median of three vectors. Each output point M[i] is the median value +# of the three input points A[i],B[i],C[i]. + +procedure amed3c (a, b, c, m, npix) + +char a[ARB], b[ARB], c[ARB] # input vectors +char m[ARB] # output vector (median) +int npix +int i + +begin + do i = 1, npix + if (a[i] < b[i]) { + if (b[i] < c[i]) # abc + m[i] = b[i] + else if (a[i] < c[i]) # acb + m[i] = c[i] + else # cab + m[i] = a[i] + } else { + if (b[i] > c[i]) # cba + m[i] = b[i] + else if (a[i] > c[i]) # bca + m[i] = c[i] + else # bac + m[i] = a[i] + } +end diff --git a/sys/vops/lz/amed3d.x b/sys/vops/lz/amed3d.x new file mode 100644 index 00000000..74fba3c4 --- /dev/null +++ b/sys/vops/lz/amed3d.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED3 -- Median of three vectors. Each output point M[i] is the median value +# of the three input points A[i],B[i],C[i]. + +procedure amed3d (a, b, c, m, npix) + +double a[ARB], b[ARB], c[ARB] # input vectors +double m[ARB] # output vector (median) +int npix +int i + +begin + do i = 1, npix + if (a[i] < b[i]) { + if (b[i] < c[i]) # abc + m[i] = b[i] + else if (a[i] < c[i]) # acb + m[i] = c[i] + else # cab + m[i] = a[i] + } else { + if (b[i] > c[i]) # cba + m[i] = b[i] + else if (a[i] > c[i]) # bca + m[i] = c[i] + else # bac + m[i] = a[i] + } +end diff --git a/sys/vops/lz/amed3i.x b/sys/vops/lz/amed3i.x new file mode 100644 index 00000000..2be5fb15 --- /dev/null +++ b/sys/vops/lz/amed3i.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED3 -- Median of three vectors. Each output point M[i] is the median value +# of the three input points A[i],B[i],C[i]. + +procedure amed3i (a, b, c, m, npix) + +int a[ARB], b[ARB], c[ARB] # input vectors +int m[ARB] # output vector (median) +int npix +int i + +begin + do i = 1, npix + if (a[i] < b[i]) { + if (b[i] < c[i]) # abc + m[i] = b[i] + else if (a[i] < c[i]) # acb + m[i] = c[i] + else # cab + m[i] = a[i] + } else { + if (b[i] > c[i]) # cba + m[i] = b[i] + else if (a[i] > c[i]) # bca + m[i] = c[i] + else # bac + m[i] = a[i] + } +end diff --git a/sys/vops/lz/amed3l.x b/sys/vops/lz/amed3l.x new file mode 100644 index 00000000..480d3b05 --- /dev/null +++ b/sys/vops/lz/amed3l.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED3 -- Median of three vectors. Each output point M[i] is the median value +# of the three input points A[i],B[i],C[i]. + +procedure amed3l (a, b, c, m, npix) + +long a[ARB], b[ARB], c[ARB] # input vectors +long m[ARB] # output vector (median) +int npix +int i + +begin + do i = 1, npix + if (a[i] < b[i]) { + if (b[i] < c[i]) # abc + m[i] = b[i] + else if (a[i] < c[i]) # acb + m[i] = c[i] + else # cab + m[i] = a[i] + } else { + if (b[i] > c[i]) # cba + m[i] = b[i] + else if (a[i] > c[i]) # bca + m[i] = c[i] + else # bac + m[i] = a[i] + } +end diff --git a/sys/vops/lz/amed3r.x b/sys/vops/lz/amed3r.x new file mode 100644 index 00000000..276efd03 --- /dev/null +++ b/sys/vops/lz/amed3r.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED3 -- Median of three vectors. Each output point M[i] is the median value +# of the three input points A[i],B[i],C[i]. + +procedure amed3r (a, b, c, m, npix) + +real a[ARB], b[ARB], c[ARB] # input vectors +real m[ARB] # output vector (median) +int npix +int i + +begin + do i = 1, npix + if (a[i] < b[i]) { + if (b[i] < c[i]) # abc + m[i] = b[i] + else if (a[i] < c[i]) # acb + m[i] = c[i] + else # cab + m[i] = a[i] + } else { + if (b[i] > c[i]) # cba + m[i] = b[i] + else if (a[i] > c[i]) # bca + m[i] = c[i] + else # bac + m[i] = a[i] + } +end diff --git a/sys/vops/lz/amed3s.x b/sys/vops/lz/amed3s.x new file mode 100644 index 00000000..8de5ff45 --- /dev/null +++ b/sys/vops/lz/amed3s.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED3 -- Median of three vectors. Each output point M[i] is the median value +# of the three input points A[i],B[i],C[i]. + +procedure amed3s (a, b, c, m, npix) + +short a[ARB], b[ARB], c[ARB] # input vectors +short m[ARB] # output vector (median) +int npix +int i + +begin + do i = 1, npix + if (a[i] < b[i]) { + if (b[i] < c[i]) # abc + m[i] = b[i] + else if (a[i] < c[i]) # acb + m[i] = c[i] + else # cab + m[i] = a[i] + } else { + if (b[i] > c[i]) # cba + m[i] = b[i] + else if (a[i] > c[i]) # bca + m[i] = c[i] + else # bac + m[i] = a[i] + } +end diff --git a/sys/vops/lz/amed4c.x b/sys/vops/lz/amed4c.x new file mode 100644 index 00000000..34228107 --- /dev/null +++ b/sys/vops/lz/amed4c.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED4 -- Median of four vectors. Each output point M[i] is the median of the +# four input points A[i],B[i],C[i],D[i]. The vector min and max are also +# computed and returned in the A and D vectors. The input vectors are modifed +# in place. + +procedure amed4c (a, b, c, d, m, npix) + +char a[ARB], b[ARB] # input vectors +char c[ARB], d[ARB] # input vectors +char m[ARB] # output vector (median) +int npix + +int i +char temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + do i = 1, npix { + # Move the minimum value to A[i]. + if (b[i] < a[i]) + swap (b[i], a[i]) + if (c[i] < a[i]) + swap (c[i], a[i]) + if (d[i] < a[i]) + swap (d[i], a[i]) + + # Move the maximum value to D[i]. + if (b[i] > d[i]) + swap (b[i], d[i]) + if (c[i] > d[i]) + swap (c[i], d[i]) + + # Return the median value. + if (b[i] < c[i]) + m[i] = b[i] + else + m[i] = c[i] + } +end diff --git a/sys/vops/lz/amed4d.x b/sys/vops/lz/amed4d.x new file mode 100644 index 00000000..aec95abd --- /dev/null +++ b/sys/vops/lz/amed4d.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED4 -- Median of four vectors. Each output point M[i] is the median of the +# four input points A[i],B[i],C[i],D[i]. The vector min and max are also +# computed and returned in the A and D vectors. The input vectors are modifed +# in place. + +procedure amed4d (a, b, c, d, m, npix) + +double a[ARB], b[ARB] # input vectors +double c[ARB], d[ARB] # input vectors +double m[ARB] # output vector (median) +int npix + +int i +double temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + do i = 1, npix { + # Move the minimum value to A[i]. + if (b[i] < a[i]) + swap (b[i], a[i]) + if (c[i] < a[i]) + swap (c[i], a[i]) + if (d[i] < a[i]) + swap (d[i], a[i]) + + # Move the maximum value to D[i]. + if (b[i] > d[i]) + swap (b[i], d[i]) + if (c[i] > d[i]) + swap (c[i], d[i]) + + # Return the median value. + if (b[i] < c[i]) + m[i] = b[i] + else + m[i] = c[i] + } +end diff --git a/sys/vops/lz/amed4i.x b/sys/vops/lz/amed4i.x new file mode 100644 index 00000000..f39d01b6 --- /dev/null +++ b/sys/vops/lz/amed4i.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED4 -- Median of four vectors. Each output point M[i] is the median of the +# four input points A[i],B[i],C[i],D[i]. The vector min and max are also +# computed and returned in the A and D vectors. The input vectors are modifed +# in place. + +procedure amed4i (a, b, c, d, m, npix) + +int a[ARB], b[ARB] # input vectors +int c[ARB], d[ARB] # input vectors +int m[ARB] # output vector (median) +int npix + +int i +int temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + do i = 1, npix { + # Move the minimum value to A[i]. + if (b[i] < a[i]) + swap (b[i], a[i]) + if (c[i] < a[i]) + swap (c[i], a[i]) + if (d[i] < a[i]) + swap (d[i], a[i]) + + # Move the maximum value to D[i]. + if (b[i] > d[i]) + swap (b[i], d[i]) + if (c[i] > d[i]) + swap (c[i], d[i]) + + # Return the median value. + if (b[i] < c[i]) + m[i] = b[i] + else + m[i] = c[i] + } +end diff --git a/sys/vops/lz/amed4l.x b/sys/vops/lz/amed4l.x new file mode 100644 index 00000000..367124ef --- /dev/null +++ b/sys/vops/lz/amed4l.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED4 -- Median of four vectors. Each output point M[i] is the median of the +# four input points A[i],B[i],C[i],D[i]. The vector min and max are also +# computed and returned in the A and D vectors. The input vectors are modifed +# in place. + +procedure amed4l (a, b, c, d, m, npix) + +long a[ARB], b[ARB] # input vectors +long c[ARB], d[ARB] # input vectors +long m[ARB] # output vector (median) +int npix + +int i +long temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + do i = 1, npix { + # Move the minimum value to A[i]. + if (b[i] < a[i]) + swap (b[i], a[i]) + if (c[i] < a[i]) + swap (c[i], a[i]) + if (d[i] < a[i]) + swap (d[i], a[i]) + + # Move the maximum value to D[i]. + if (b[i] > d[i]) + swap (b[i], d[i]) + if (c[i] > d[i]) + swap (c[i], d[i]) + + # Return the median value. + if (b[i] < c[i]) + m[i] = b[i] + else + m[i] = c[i] + } +end diff --git a/sys/vops/lz/amed4r.x b/sys/vops/lz/amed4r.x new file mode 100644 index 00000000..386ca7a5 --- /dev/null +++ b/sys/vops/lz/amed4r.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED4 -- Median of four vectors. Each output point M[i] is the median of the +# four input points A[i],B[i],C[i],D[i]. The vector min and max are also +# computed and returned in the A and D vectors. The input vectors are modifed +# in place. + +procedure amed4r (a, b, c, d, m, npix) + +real a[ARB], b[ARB] # input vectors +real c[ARB], d[ARB] # input vectors +real m[ARB] # output vector (median) +int npix + +int i +real temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + do i = 1, npix { + # Move the minimum value to A[i]. + if (b[i] < a[i]) + swap (b[i], a[i]) + if (c[i] < a[i]) + swap (c[i], a[i]) + if (d[i] < a[i]) + swap (d[i], a[i]) + + # Move the maximum value to D[i]. + if (b[i] > d[i]) + swap (b[i], d[i]) + if (c[i] > d[i]) + swap (c[i], d[i]) + + # Return the median value. + if (b[i] < c[i]) + m[i] = b[i] + else + m[i] = c[i] + } +end diff --git a/sys/vops/lz/amed4s.x b/sys/vops/lz/amed4s.x new file mode 100644 index 00000000..3ed8fe1d --- /dev/null +++ b/sys/vops/lz/amed4s.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED4 -- Median of four vectors. Each output point M[i] is the median of the +# four input points A[i],B[i],C[i],D[i]. The vector min and max are also +# computed and returned in the A and D vectors. The input vectors are modifed +# in place. + +procedure amed4s (a, b, c, d, m, npix) + +short a[ARB], b[ARB] # input vectors +short c[ARB], d[ARB] # input vectors +short m[ARB] # output vector (median) +int npix + +int i +short temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + do i = 1, npix { + # Move the minimum value to A[i]. + if (b[i] < a[i]) + swap (b[i], a[i]) + if (c[i] < a[i]) + swap (c[i], a[i]) + if (d[i] < a[i]) + swap (d[i], a[i]) + + # Move the maximum value to D[i]. + if (b[i] > d[i]) + swap (b[i], d[i]) + if (c[i] > d[i]) + swap (c[i], d[i]) + + # Return the median value. + if (b[i] < c[i]) + m[i] = b[i] + else + m[i] = c[i] + } +end diff --git a/sys/vops/lz/amed5c.x b/sys/vops/lz/amed5c.x new file mode 100644 index 00000000..8302e080 --- /dev/null +++ b/sys/vops/lz/amed5c.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED5 -- Median of five vectors. Each output point M[i] is the median of the +# five input points A[i],B[i],C[i],D[i],E[i]. The vector min and max are also +# computed and returned in the A and E vectors. The input vectors are modifed. + +procedure amed5c (a, b, c, d, e, m, npix) + +char a[ARB], b[ARB] # input vectors +char c[ARB], d[ARB], e[ARB] # input vectors +char m[ARB] # output vector (median) +int npix + +int i +char temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + do i = 1, npix { + # Move the minimum value to A[i]. + if (b[i] < a[i]) + swap (b[i], a[i]) + if (c[i] < a[i]) + swap (c[i], a[i]) + if (d[i] < a[i]) + swap (d[i], a[i]) + if (e[i] < a[i]) + swap (e[i], a[i]) + + # Move the maximum value to E[i]. + if (b[i] > e[i]) + swap (b[i], e[i]) + if (c[i] > e[i]) + swap (c[i], e[i]) + if (d[i] > e[i]) + swap (d[i], e[i]) + + # Return the median value of the central three points. + if (b[i] < c[i]) { + if (c[i] < d[i]) # bcd + m[i] = c[i] + else if (b[i] < d[i]) # bdc + m[i] = d[i] + else # dbc + m[i] = b[i] + } else { + if (c[i] > d[i]) # dcb + m[i] = c[i] + else if (b[i] > d[i]) # cdb + m[i] = d[i] + else # cbd + m[i] = b[i] + } + } +end diff --git a/sys/vops/lz/amed5d.x b/sys/vops/lz/amed5d.x new file mode 100644 index 00000000..a813f82f --- /dev/null +++ b/sys/vops/lz/amed5d.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED5 -- Median of five vectors. Each output point M[i] is the median of the +# five input points A[i],B[i],C[i],D[i],E[i]. The vector min and max are also +# computed and returned in the A and E vectors. The input vectors are modifed. + +procedure amed5d (a, b, c, d, e, m, npix) + +double a[ARB], b[ARB] # input vectors +double c[ARB], d[ARB], e[ARB] # input vectors +double m[ARB] # output vector (median) +int npix + +int i +double temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + do i = 1, npix { + # Move the minimum value to A[i]. + if (b[i] < a[i]) + swap (b[i], a[i]) + if (c[i] < a[i]) + swap (c[i], a[i]) + if (d[i] < a[i]) + swap (d[i], a[i]) + if (e[i] < a[i]) + swap (e[i], a[i]) + + # Move the maximum value to E[i]. + if (b[i] > e[i]) + swap (b[i], e[i]) + if (c[i] > e[i]) + swap (c[i], e[i]) + if (d[i] > e[i]) + swap (d[i], e[i]) + + # Return the median value of the central three points. + if (b[i] < c[i]) { + if (c[i] < d[i]) # bcd + m[i] = c[i] + else if (b[i] < d[i]) # bdc + m[i] = d[i] + else # dbc + m[i] = b[i] + } else { + if (c[i] > d[i]) # dcb + m[i] = c[i] + else if (b[i] > d[i]) # cdb + m[i] = d[i] + else # cbd + m[i] = b[i] + } + } +end diff --git a/sys/vops/lz/amed5i.x b/sys/vops/lz/amed5i.x new file mode 100644 index 00000000..9738be6a --- /dev/null +++ b/sys/vops/lz/amed5i.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED5 -- Median of five vectors. Each output point M[i] is the median of the +# five input points A[i],B[i],C[i],D[i],E[i]. The vector min and max are also +# computed and returned in the A and E vectors. The input vectors are modifed. + +procedure amed5i (a, b, c, d, e, m, npix) + +int a[ARB], b[ARB] # input vectors +int c[ARB], d[ARB], e[ARB] # input vectors +int m[ARB] # output vector (median) +int npix + +int i +int temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + do i = 1, npix { + # Move the minimum value to A[i]. + if (b[i] < a[i]) + swap (b[i], a[i]) + if (c[i] < a[i]) + swap (c[i], a[i]) + if (d[i] < a[i]) + swap (d[i], a[i]) + if (e[i] < a[i]) + swap (e[i], a[i]) + + # Move the maximum value to E[i]. + if (b[i] > e[i]) + swap (b[i], e[i]) + if (c[i] > e[i]) + swap (c[i], e[i]) + if (d[i] > e[i]) + swap (d[i], e[i]) + + # Return the median value of the central three points. + if (b[i] < c[i]) { + if (c[i] < d[i]) # bcd + m[i] = c[i] + else if (b[i] < d[i]) # bdc + m[i] = d[i] + else # dbc + m[i] = b[i] + } else { + if (c[i] > d[i]) # dcb + m[i] = c[i] + else if (b[i] > d[i]) # cdb + m[i] = d[i] + else # cbd + m[i] = b[i] + } + } +end diff --git a/sys/vops/lz/amed5l.x b/sys/vops/lz/amed5l.x new file mode 100644 index 00000000..33bd869d --- /dev/null +++ b/sys/vops/lz/amed5l.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED5 -- Median of five vectors. Each output point M[i] is the median of the +# five input points A[i],B[i],C[i],D[i],E[i]. The vector min and max are also +# computed and returned in the A and E vectors. The input vectors are modifed. + +procedure amed5l (a, b, c, d, e, m, npix) + +long a[ARB], b[ARB] # input vectors +long c[ARB], d[ARB], e[ARB] # input vectors +long m[ARB] # output vector (median) +int npix + +int i +long temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + do i = 1, npix { + # Move the minimum value to A[i]. + if (b[i] < a[i]) + swap (b[i], a[i]) + if (c[i] < a[i]) + swap (c[i], a[i]) + if (d[i] < a[i]) + swap (d[i], a[i]) + if (e[i] < a[i]) + swap (e[i], a[i]) + + # Move the maximum value to E[i]. + if (b[i] > e[i]) + swap (b[i], e[i]) + if (c[i] > e[i]) + swap (c[i], e[i]) + if (d[i] > e[i]) + swap (d[i], e[i]) + + # Return the median value of the central three points. + if (b[i] < c[i]) { + if (c[i] < d[i]) # bcd + m[i] = c[i] + else if (b[i] < d[i]) # bdc + m[i] = d[i] + else # dbc + m[i] = b[i] + } else { + if (c[i] > d[i]) # dcb + m[i] = c[i] + else if (b[i] > d[i]) # cdb + m[i] = d[i] + else # cbd + m[i] = b[i] + } + } +end diff --git a/sys/vops/lz/amed5r.x b/sys/vops/lz/amed5r.x new file mode 100644 index 00000000..9bce0597 --- /dev/null +++ b/sys/vops/lz/amed5r.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED5 -- Median of five vectors. Each output point M[i] is the median of the +# five input points A[i],B[i],C[i],D[i],E[i]. The vector min and max are also +# computed and returned in the A and E vectors. The input vectors are modifed. + +procedure amed5r (a, b, c, d, e, m, npix) + +real a[ARB], b[ARB] # input vectors +real c[ARB], d[ARB], e[ARB] # input vectors +real m[ARB] # output vector (median) +int npix + +int i +real temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + do i = 1, npix { + # Move the minimum value to A[i]. + if (b[i] < a[i]) + swap (b[i], a[i]) + if (c[i] < a[i]) + swap (c[i], a[i]) + if (d[i] < a[i]) + swap (d[i], a[i]) + if (e[i] < a[i]) + swap (e[i], a[i]) + + # Move the maximum value to E[i]. + if (b[i] > e[i]) + swap (b[i], e[i]) + if (c[i] > e[i]) + swap (c[i], e[i]) + if (d[i] > e[i]) + swap (d[i], e[i]) + + # Return the median value of the central three points. + if (b[i] < c[i]) { + if (c[i] < d[i]) # bcd + m[i] = c[i] + else if (b[i] < d[i]) # bdc + m[i] = d[i] + else # dbc + m[i] = b[i] + } else { + if (c[i] > d[i]) # dcb + m[i] = c[i] + else if (b[i] > d[i]) # cdb + m[i] = d[i] + else # cbd + m[i] = b[i] + } + } +end diff --git a/sys/vops/lz/amed5s.x b/sys/vops/lz/amed5s.x new file mode 100644 index 00000000..31f34696 --- /dev/null +++ b/sys/vops/lz/amed5s.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED5 -- Median of five vectors. Each output point M[i] is the median of the +# five input points A[i],B[i],C[i],D[i],E[i]. The vector min and max are also +# computed and returned in the A and E vectors. The input vectors are modifed. + +procedure amed5s (a, b, c, d, e, m, npix) + +short a[ARB], b[ARB] # input vectors +short c[ARB], d[ARB], e[ARB] # input vectors +short m[ARB] # output vector (median) +int npix + +int i +short temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + do i = 1, npix { + # Move the minimum value to A[i]. + if (b[i] < a[i]) + swap (b[i], a[i]) + if (c[i] < a[i]) + swap (c[i], a[i]) + if (d[i] < a[i]) + swap (d[i], a[i]) + if (e[i] < a[i]) + swap (e[i], a[i]) + + # Move the maximum value to E[i]. + if (b[i] > e[i]) + swap (b[i], e[i]) + if (c[i] > e[i]) + swap (c[i], e[i]) + if (d[i] > e[i]) + swap (d[i], e[i]) + + # Return the median value of the central three points. + if (b[i] < c[i]) { + if (c[i] < d[i]) # bcd + m[i] = c[i] + else if (b[i] < d[i]) # bdc + m[i] = d[i] + else # dbc + m[i] = b[i] + } else { + if (c[i] > d[i]) # dcb + m[i] = c[i] + else if (b[i] > d[i]) # cdb + m[i] = d[i] + else # cbd + m[i] = b[i] + } + } +end diff --git a/sys/vops/lz/amedc.x b/sys/vops/lz/amedc.x new file mode 100644 index 00000000..09dcf10c --- /dev/null +++ b/sys/vops/lz/amedc.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED -- Vector median selection. The selection is carried out in a temporary +# array, leaving the input vector unmodified. Especially demanding applications +# may wish to call the asok routine directory to avoid the call to the memory +# allocator. + +char procedure amedc (a, npix) + +char a[ARB] +int npix + +pointer sp, aa +char median +char asokc() # select the Kth smallest element from A + +begin + switch (npix) { + case 1, 2: + return (a[1]) + + case 3: + if (a[1] < a[2]) { + if (a[2] < a[3]) + return (a[2]) + else if (a[1] < a[3]) + return (a[3]) + else + return (a[1]) + } else { + if (a[2] > a[3]) + return (a[2]) + else if (a[1] < a[3]) + return (a[1]) + else + return (a[3]) + } + + default: + call smark (sp) + call salloc (aa, npix, TY_CHAR) + call amovc (a, Memc[aa], npix) + median = asokc (Memc[aa], npix, (npix + 1) / 2) + call sfree (sp) + + return (median) + } +end diff --git a/sys/vops/lz/amedd.x b/sys/vops/lz/amedd.x new file mode 100644 index 00000000..c3fbc3aa --- /dev/null +++ b/sys/vops/lz/amedd.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED -- Vector median selection. The selection is carried out in a temporary +# array, leaving the input vector unmodified. Especially demanding applications +# may wish to call the asok routine directory to avoid the call to the memory +# allocator. + +double procedure amedd (a, npix) + +double a[ARB] +int npix + +pointer sp, aa +double median +double asokd() # select the Kth smallest element from A + +begin + switch (npix) { + case 1, 2: + return (a[1]) + + case 3: + if (a[1] < a[2]) { + if (a[2] < a[3]) + return (a[2]) + else if (a[1] < a[3]) + return (a[3]) + else + return (a[1]) + } else { + if (a[2] > a[3]) + return (a[2]) + else if (a[1] < a[3]) + return (a[1]) + else + return (a[3]) + } + + default: + call smark (sp) + call salloc (aa, npix, TY_DOUBLE) + call amovd (a, Memd[aa], npix) + median = asokd (Memd[aa], npix, (npix + 1) / 2) + call sfree (sp) + + return (median) + } +end diff --git a/sys/vops/lz/amedi.x b/sys/vops/lz/amedi.x new file mode 100644 index 00000000..69c1ce77 --- /dev/null +++ b/sys/vops/lz/amedi.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED -- Vector median selection. The selection is carried out in a temporary +# array, leaving the input vector unmodified. Especially demanding applications +# may wish to call the asok routine directory to avoid the call to the memory +# allocator. + +int procedure amedi (a, npix) + +int a[ARB] +int npix + +pointer sp, aa +int median +int asoki() # select the Kth smallest element from A + +begin + switch (npix) { + case 1, 2: + return (a[1]) + + case 3: + if (a[1] < a[2]) { + if (a[2] < a[3]) + return (a[2]) + else if (a[1] < a[3]) + return (a[3]) + else + return (a[1]) + } else { + if (a[2] > a[3]) + return (a[2]) + else if (a[1] < a[3]) + return (a[1]) + else + return (a[3]) + } + + default: + call smark (sp) + call salloc (aa, npix, TY_INT) + call amovi (a, Memi[aa], npix) + median = asoki (Memi[aa], npix, (npix + 1) / 2) + call sfree (sp) + + return (median) + } +end diff --git a/sys/vops/lz/amedl.x b/sys/vops/lz/amedl.x new file mode 100644 index 00000000..8a993fd2 --- /dev/null +++ b/sys/vops/lz/amedl.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED -- Vector median selection. The selection is carried out in a temporary +# array, leaving the input vector unmodified. Especially demanding applications +# may wish to call the asok routine directory to avoid the call to the memory +# allocator. + +long procedure amedl (a, npix) + +long a[ARB] +int npix + +pointer sp, aa +long median +long asokl() # select the Kth smallest element from A + +begin + switch (npix) { + case 1, 2: + return (a[1]) + + case 3: + if (a[1] < a[2]) { + if (a[2] < a[3]) + return (a[2]) + else if (a[1] < a[3]) + return (a[3]) + else + return (a[1]) + } else { + if (a[2] > a[3]) + return (a[2]) + else if (a[1] < a[3]) + return (a[1]) + else + return (a[3]) + } + + default: + call smark (sp) + call salloc (aa, npix, TY_LONG) + call amovl (a, Meml[aa], npix) + median = asokl (Meml[aa], npix, (npix + 1) / 2) + call sfree (sp) + + return (median) + } +end diff --git a/sys/vops/lz/amedr.x b/sys/vops/lz/amedr.x new file mode 100644 index 00000000..e459b22a --- /dev/null +++ b/sys/vops/lz/amedr.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED -- Vector median selection. The selection is carried out in a temporary +# array, leaving the input vector unmodified. Especially demanding applications +# may wish to call the asok routine directory to avoid the call to the memory +# allocator. + +real procedure amedr (a, npix) + +real a[ARB] +int npix + +pointer sp, aa +real median +real asokr() # select the Kth smallest element from A + +begin + switch (npix) { + case 1, 2: + return (a[1]) + + case 3: + if (a[1] < a[2]) { + if (a[2] < a[3]) + return (a[2]) + else if (a[1] < a[3]) + return (a[3]) + else + return (a[1]) + } else { + if (a[2] > a[3]) + return (a[2]) + else if (a[1] < a[3]) + return (a[1]) + else + return (a[3]) + } + + default: + call smark (sp) + call salloc (aa, npix, TY_REAL) + call amovr (a, Memr[aa], npix) + median = asokr (Memr[aa], npix, (npix + 1) / 2) + call sfree (sp) + + return (median) + } +end diff --git a/sys/vops/lz/ameds.x b/sys/vops/lz/ameds.x new file mode 100644 index 00000000..5d4d28db --- /dev/null +++ b/sys/vops/lz/ameds.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED -- Vector median selection. The selection is carried out in a temporary +# array, leaving the input vector unmodified. Especially demanding applications +# may wish to call the asok routine directory to avoid the call to the memory +# allocator. + +short procedure ameds (a, npix) + +short a[ARB] +int npix + +pointer sp, aa +short median +short asoks() # select the Kth smallest element from A + +begin + switch (npix) { + case 1, 2: + return (a[1]) + + case 3: + if (a[1] < a[2]) { + if (a[2] < a[3]) + return (a[2]) + else if (a[1] < a[3]) + return (a[3]) + else + return (a[1]) + } else { + if (a[2] > a[3]) + return (a[2]) + else if (a[1] < a[3]) + return (a[1]) + else + return (a[3]) + } + + default: + call smark (sp) + call salloc (aa, npix, TY_SHORT) + call amovs (a, Mems[aa], npix) + median = asoks (Mems[aa], npix, (npix + 1) / 2) + call sfree (sp) + + return (median) + } +end diff --git a/sys/vops/lz/amedx.x b/sys/vops/lz/amedx.x new file mode 100644 index 00000000..ca2b75dc --- /dev/null +++ b/sys/vops/lz/amedx.x @@ -0,0 +1,52 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMED -- Vector median selection. The selection is carried out in a temporary +# array, leaving the input vector unmodified. Especially demanding applications +# may wish to call the asok routine directory to avoid the call to the memory +# allocator. + +complex procedure amedx (a, npix) + +complex a[ARB] +int npix + +pointer sp, aa +complex median +complex asokx() # select the Kth smallest element from A +real a1, a2, a3 + +begin + switch (npix) { + case 1, 2: + return (a[1]) + + case 3: + a1 = abs (a[1]) + a2 = abs (a[2]) + a3 = abs (a[3]) + if (a1 < a2) { + if (a2 < a3) + return (a[2]) + else if (a1 < a3) + return (a[3]) + else + return (a[1]) + } else { + if (a2 > a3) + return (a[2]) + else if (a1 < a3) + return (a[1]) + else + return (a[3]) + } + + default: + call smark (sp) + call salloc (aa, npix, TY_COMPLEX) + call amovx (a, Memx[aa], npix) + median = asokx (Memx[aa], npix, (npix + 1) / 2) + call sfree (sp) + + return (median) + } +end diff --git a/sys/vops/lz/amgsd.x b/sys/vops/lz/amgsd.x new file mode 100644 index 00000000..36efe58e --- /dev/null +++ b/sys/vops/lz/amgsd.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMGS -- Return the square of the magnitude of two vectors. + +procedure amgsd (a, b, c, npix) + +double a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** 2 + b[i] ** 2 +end diff --git a/sys/vops/lz/amgsi.x b/sys/vops/lz/amgsi.x new file mode 100644 index 00000000..e45a8c70 --- /dev/null +++ b/sys/vops/lz/amgsi.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMGS -- Return the square of the magnitude of two vectors. + +procedure amgsi (a, b, c, npix) + +int a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** 2 + b[i] ** 2 +end diff --git a/sys/vops/lz/amgsl.x b/sys/vops/lz/amgsl.x new file mode 100644 index 00000000..6ae850e9 --- /dev/null +++ b/sys/vops/lz/amgsl.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMGS -- Return the square of the magnitude of two vectors. + +procedure amgsl (a, b, c, npix) + +long a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** 2 + b[i] ** 2 +end diff --git a/sys/vops/lz/amgsr.x b/sys/vops/lz/amgsr.x new file mode 100644 index 00000000..fbfbb880 --- /dev/null +++ b/sys/vops/lz/amgsr.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMGS -- Return the square of the magnitude of two vectors. + +procedure amgsr (a, b, c, npix) + +real a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** 2 + b[i] ** 2 +end diff --git a/sys/vops/lz/amgss.x b/sys/vops/lz/amgss.x new file mode 100644 index 00000000..592d520c --- /dev/null +++ b/sys/vops/lz/amgss.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMGS -- Return the square of the magnitude of two vectors. + +procedure amgss (a, b, c, npix) + +short a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** 2 + b[i] ** 2 +end diff --git a/sys/vops/lz/amgsx.x b/sys/vops/lz/amgsx.x new file mode 100644 index 00000000..c40834f4 --- /dev/null +++ b/sys/vops/lz/amgsx.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMGS -- Return the square of the magnitude of two vectors. + +procedure amgsx (a, b, c, npix) + +complex a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** 2 + b[i] ** 2 +end diff --git a/sys/vops/lz/aminc.x b/sys/vops/lz/aminc.x new file mode 100644 index 00000000..a319819e --- /dev/null +++ b/sys/vops/lz/aminc.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMIN -- Compute the minimum of two vectors (generic). + +procedure aminc (a, b, c, npix) + +char a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = min (a[i], b[i]) +end diff --git a/sys/vops/lz/amind.x b/sys/vops/lz/amind.x new file mode 100644 index 00000000..e1574051 --- /dev/null +++ b/sys/vops/lz/amind.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMIN -- Compute the minimum of two vectors (generic). + +procedure amind (a, b, c, npix) + +double a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = min (a[i], b[i]) +end diff --git a/sys/vops/lz/amini.x b/sys/vops/lz/amini.x new file mode 100644 index 00000000..c7a76820 --- /dev/null +++ b/sys/vops/lz/amini.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMIN -- Compute the minimum of two vectors (generic). + +procedure amini (a, b, c, npix) + +int a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = min (a[i], b[i]) +end diff --git a/sys/vops/lz/aminkc.x b/sys/vops/lz/aminkc.x new file mode 100644 index 00000000..a9b91e0e --- /dev/null +++ b/sys/vops/lz/aminkc.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMINK -- Compute the minimum of a constant and a vector (generic). + +procedure aminkc (a, b, c, npix) + +char a[ARB] +char b +char c[ARB] +int npix, i + +begin + + do i = 1, npix + c[i] = min (a[i], b) +end diff --git a/sys/vops/lz/aminkd.x b/sys/vops/lz/aminkd.x new file mode 100644 index 00000000..6b8a0506 --- /dev/null +++ b/sys/vops/lz/aminkd.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMINK -- Compute the minimum of a constant and a vector (generic). + +procedure aminkd (a, b, c, npix) + +double a[ARB] +double b +double c[ARB] +int npix, i + +begin + + do i = 1, npix + c[i] = min (a[i], b) +end diff --git a/sys/vops/lz/aminki.x b/sys/vops/lz/aminki.x new file mode 100644 index 00000000..b2793c71 --- /dev/null +++ b/sys/vops/lz/aminki.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMINK -- Compute the minimum of a constant and a vector (generic). + +procedure aminki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix, i + +begin + + do i = 1, npix + c[i] = min (a[i], b) +end diff --git a/sys/vops/lz/aminkl.x b/sys/vops/lz/aminkl.x new file mode 100644 index 00000000..530b326f --- /dev/null +++ b/sys/vops/lz/aminkl.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMINK -- Compute the minimum of a constant and a vector (generic). + +procedure aminkl (a, b, c, npix) + +long a[ARB] +long b +long c[ARB] +int npix, i + +begin + + do i = 1, npix + c[i] = min (a[i], b) +end diff --git a/sys/vops/lz/aminkr.x b/sys/vops/lz/aminkr.x new file mode 100644 index 00000000..76000fb7 --- /dev/null +++ b/sys/vops/lz/aminkr.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMINK -- Compute the minimum of a constant and a vector (generic). + +procedure aminkr (a, b, c, npix) + +real a[ARB] +real b +real c[ARB] +int npix, i + +begin + + do i = 1, npix + c[i] = min (a[i], b) +end diff --git a/sys/vops/lz/aminks.x b/sys/vops/lz/aminks.x new file mode 100644 index 00000000..28d1b358 --- /dev/null +++ b/sys/vops/lz/aminks.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMINK -- Compute the minimum of a constant and a vector (generic). + +procedure aminks (a, b, c, npix) + +short a[ARB] +short b +short c[ARB] +int npix, i + +begin + + do i = 1, npix + c[i] = min (a[i], b) +end diff --git a/sys/vops/lz/aminkx.x b/sys/vops/lz/aminkx.x new file mode 100644 index 00000000..5f0f852d --- /dev/null +++ b/sys/vops/lz/aminkx.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMINK -- Compute the minimum of a constant and a vector (generic). + +procedure aminkx (a, b, c, npix) + +complex a[ARB] +complex b +complex c[ARB] +int npix, i +real abs_b + +begin + abs_b = abs (b) + + do i = 1, npix + if (abs(a[i]) <= abs_b) + c[i] = a[i] + else + c[i] = b +end diff --git a/sys/vops/lz/aminl.x b/sys/vops/lz/aminl.x new file mode 100644 index 00000000..d4ae3c7e --- /dev/null +++ b/sys/vops/lz/aminl.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMIN -- Compute the minimum of two vectors (generic). + +procedure aminl (a, b, c, npix) + +long a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = min (a[i], b[i]) +end diff --git a/sys/vops/lz/aminr.x b/sys/vops/lz/aminr.x new file mode 100644 index 00000000..1fafcb35 --- /dev/null +++ b/sys/vops/lz/aminr.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMIN -- Compute the minimum of two vectors (generic). + +procedure aminr (a, b, c, npix) + +real a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = min (a[i], b[i]) +end diff --git a/sys/vops/lz/amins.x b/sys/vops/lz/amins.x new file mode 100644 index 00000000..5d89f139 --- /dev/null +++ b/sys/vops/lz/amins.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMIN -- Compute the minimum of two vectors (generic). + +procedure amins (a, b, c, npix) + +short a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = min (a[i], b[i]) +end diff --git a/sys/vops/lz/aminx.x b/sys/vops/lz/aminx.x new file mode 100644 index 00000000..591b23e4 --- /dev/null +++ b/sys/vops/lz/aminx.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMIN -- Compute the minimum of two vectors (generic). + +procedure aminx (a, b, c, npix) + +complex a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + if (abs(a[i]) <= abs(b[i])) + c[i] = a[i] + else + c[i] = b[i] +end diff --git a/sys/vops/lz/amodd.x b/sys/vops/lz/amodd.x new file mode 100644 index 00000000..fce124b6 --- /dev/null +++ b/sys/vops/lz/amodd.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOD -- Compute the modulus of two vectors (generic). + +procedure amodd (a, b, c, npix) + +double a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = mod (a[i], b[i]) +end diff --git a/sys/vops/lz/amodi.x b/sys/vops/lz/amodi.x new file mode 100644 index 00000000..f1f5a584 --- /dev/null +++ b/sys/vops/lz/amodi.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOD -- Compute the modulus of two vectors (generic). + +procedure amodi (a, b, c, npix) + +int a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = mod (a[i], b[i]) +end diff --git a/sys/vops/lz/amodkd.x b/sys/vops/lz/amodkd.x new file mode 100644 index 00000000..24db964d --- /dev/null +++ b/sys/vops/lz/amodkd.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMODK -- Compute the modulus of a vector by a constant (generic). + +procedure amodkd (a, b, c, npix) + +double a[ARB] +double b +double c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = mod (a[i], b) +end diff --git a/sys/vops/lz/amodki.x b/sys/vops/lz/amodki.x new file mode 100644 index 00000000..d2b71438 --- /dev/null +++ b/sys/vops/lz/amodki.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMODK -- Compute the modulus of a vector by a constant (generic). + +procedure amodki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = mod (a[i], b) +end diff --git a/sys/vops/lz/amodkl.x b/sys/vops/lz/amodkl.x new file mode 100644 index 00000000..ef9ec8b3 --- /dev/null +++ b/sys/vops/lz/amodkl.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMODK -- Compute the modulus of a vector by a constant (generic). + +procedure amodkl (a, b, c, npix) + +long a[ARB] +long b +long c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = mod (a[i], b) +end diff --git a/sys/vops/lz/amodkr.x b/sys/vops/lz/amodkr.x new file mode 100644 index 00000000..9aa1bd49 --- /dev/null +++ b/sys/vops/lz/amodkr.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMODK -- Compute the modulus of a vector by a constant (generic). + +procedure amodkr (a, b, c, npix) + +real a[ARB] +real b +real c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = mod (a[i], b) +end diff --git a/sys/vops/lz/amodks.x b/sys/vops/lz/amodks.x new file mode 100644 index 00000000..be5b719c --- /dev/null +++ b/sys/vops/lz/amodks.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMODK -- Compute the modulus of a vector by a constant (generic). + +procedure amodks (a, b, c, npix) + +short a[ARB] +short b +short c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = mod (a[i], b) +end diff --git a/sys/vops/lz/amodl.x b/sys/vops/lz/amodl.x new file mode 100644 index 00000000..5dd47d53 --- /dev/null +++ b/sys/vops/lz/amodl.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOD -- Compute the modulus of two vectors (generic). + +procedure amodl (a, b, c, npix) + +long a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = mod (a[i], b[i]) +end diff --git a/sys/vops/lz/amodr.x b/sys/vops/lz/amodr.x new file mode 100644 index 00000000..772a1e9c --- /dev/null +++ b/sys/vops/lz/amodr.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOD -- Compute the modulus of two vectors (generic). + +procedure amodr (a, b, c, npix) + +real a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = mod (a[i], b[i]) +end diff --git a/sys/vops/lz/amods.x b/sys/vops/lz/amods.x new file mode 100644 index 00000000..490d8ec5 --- /dev/null +++ b/sys/vops/lz/amods.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOD -- Compute the modulus of two vectors (generic). + +procedure amods (a, b, c, npix) + +short a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = mod (a[i], b[i]) +end diff --git a/sys/vops/lz/amovc.x b/sys/vops/lz/amovc.x new file mode 100644 index 00000000..096d1444 --- /dev/null +++ b/sys/vops/lz/amovc.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOV -- Copy a vector (generic). The operation is carried out in such +# a way that the result is the same whether or not the output vector +# overlaps the input vector. + +procedure amovc (a, b, npix) + +char a[ARB], b[ARB] +int npix, i, a_first, b_first + +begin + call zlocva (a, a_first) + call zlocva (b, b_first) + + if (a_first == b_first) + return + + if (a_first < b_first) { + do i = npix, 1, -1 + b[i] = a[i] + } else { + do i = 1, npix + b[i] = a[i] + } +end diff --git a/sys/vops/lz/amovd.x b/sys/vops/lz/amovd.x new file mode 100644 index 00000000..3924f141 --- /dev/null +++ b/sys/vops/lz/amovd.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOV -- Copy a vector (generic). The operation is carried out in such +# a way that the result is the same whether or not the output vector +# overlaps the input vector. + +procedure amovd (a, b, npix) + +double a[ARB], b[ARB] +int npix, i, a_first, b_first + +begin + call zlocva (a, a_first) + call zlocva (b, b_first) + + if (a_first == b_first) + return + + if (a_first < b_first) { + do i = npix, 1, -1 + b[i] = a[i] + } else { + do i = 1, npix + b[i] = a[i] + } +end diff --git a/sys/vops/lz/amovi.x b/sys/vops/lz/amovi.x new file mode 100644 index 00000000..e97794c7 --- /dev/null +++ b/sys/vops/lz/amovi.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOV -- Copy a vector (generic). The operation is carried out in such +# a way that the result is the same whether or not the output vector +# overlaps the input vector. + +procedure amovi (a, b, npix) + +int a[ARB], b[ARB] +int npix, i, a_first, b_first + +begin + call zlocva (a, a_first) + call zlocva (b, b_first) + + if (a_first == b_first) + return + + if (a_first < b_first) { + do i = npix, 1, -1 + b[i] = a[i] + } else { + do i = 1, npix + b[i] = a[i] + } +end diff --git a/sys/vops/lz/amovkc.x b/sys/vops/lz/amovkc.x new file mode 100644 index 00000000..9be3a496 --- /dev/null +++ b/sys/vops/lz/amovkc.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOVK -- Copy a constant into a vector (generic). + +procedure amovkc (a, b, npix) + +char a +char b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = a +end diff --git a/sys/vops/lz/amovkd.x b/sys/vops/lz/amovkd.x new file mode 100644 index 00000000..4d8eaecd --- /dev/null +++ b/sys/vops/lz/amovkd.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOVK -- Copy a constant into a vector (generic). + +procedure amovkd (a, b, npix) + +double a +double b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = a +end diff --git a/sys/vops/lz/amovki.x b/sys/vops/lz/amovki.x new file mode 100644 index 00000000..67556a23 --- /dev/null +++ b/sys/vops/lz/amovki.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOVK -- Copy a constant into a vector (generic). + +procedure amovki (a, b, npix) + +int a +int b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = a +end diff --git a/sys/vops/lz/amovkl.x b/sys/vops/lz/amovkl.x new file mode 100644 index 00000000..62c96668 --- /dev/null +++ b/sys/vops/lz/amovkl.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOVK -- Copy a constant into a vector (generic). + +procedure amovkl (a, b, npix) + +long a +long b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = a +end diff --git a/sys/vops/lz/amovkr.x b/sys/vops/lz/amovkr.x new file mode 100644 index 00000000..feb34a5c --- /dev/null +++ b/sys/vops/lz/amovkr.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOVK -- Copy a constant into a vector (generic). + +procedure amovkr (a, b, npix) + +real a +real b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = a +end diff --git a/sys/vops/lz/amovks.x b/sys/vops/lz/amovks.x new file mode 100644 index 00000000..3beff9af --- /dev/null +++ b/sys/vops/lz/amovks.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOVK -- Copy a constant into a vector (generic). + +procedure amovks (a, b, npix) + +short a +short b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = a +end diff --git a/sys/vops/lz/amovkx.x b/sys/vops/lz/amovkx.x new file mode 100644 index 00000000..acf90c91 --- /dev/null +++ b/sys/vops/lz/amovkx.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOVK -- Copy a constant into a vector (generic). + +procedure amovkx (a, b, npix) + +complex a +complex b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = a +end diff --git a/sys/vops/lz/amovl.x b/sys/vops/lz/amovl.x new file mode 100644 index 00000000..4cec6bbd --- /dev/null +++ b/sys/vops/lz/amovl.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOV -- Copy a vector (generic). The operation is carried out in such +# a way that the result is the same whether or not the output vector +# overlaps the input vector. + +procedure amovl (a, b, npix) + +long a[ARB], b[ARB] +int npix, i, a_first, b_first + +begin + call zlocva (a, a_first) + call zlocva (b, b_first) + + if (a_first == b_first) + return + + if (a_first < b_first) { + do i = npix, 1, -1 + b[i] = a[i] + } else { + do i = 1, npix + b[i] = a[i] + } +end diff --git a/sys/vops/lz/amovr.x b/sys/vops/lz/amovr.x new file mode 100644 index 00000000..9d6aa8cb --- /dev/null +++ b/sys/vops/lz/amovr.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOV -- Copy a vector (generic). The operation is carried out in such +# a way that the result is the same whether or not the output vector +# overlaps the input vector. + +procedure amovr (a, b, npix) + +real a[ARB], b[ARB] +int npix, i, a_first, b_first + +begin + call zlocva (a, a_first) + call zlocva (b, b_first) + + if (a_first == b_first) + return + + if (a_first < b_first) { + do i = npix, 1, -1 + b[i] = a[i] + } else { + do i = 1, npix + b[i] = a[i] + } +end diff --git a/sys/vops/lz/amovs.x b/sys/vops/lz/amovs.x new file mode 100644 index 00000000..9feaf94a --- /dev/null +++ b/sys/vops/lz/amovs.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOV -- Copy a vector (generic). The operation is carried out in such +# a way that the result is the same whether or not the output vector +# overlaps the input vector. + +procedure amovs (a, b, npix) + +short a[ARB], b[ARB] +int npix, i, a_first, b_first + +begin + call zlocva (a, a_first) + call zlocva (b, b_first) + + if (a_first == b_first) + return + + if (a_first < b_first) { + do i = npix, 1, -1 + b[i] = a[i] + } else { + do i = 1, npix + b[i] = a[i] + } +end diff --git a/sys/vops/lz/amovx.x b/sys/vops/lz/amovx.x new file mode 100644 index 00000000..04d4fdf2 --- /dev/null +++ b/sys/vops/lz/amovx.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMOV -- Copy a vector (generic). The operation is carried out in such +# a way that the result is the same whether or not the output vector +# overlaps the input vector. + +procedure amovx (a, b, npix) + +complex a[ARB], b[ARB] +int npix, i, a_first, b_first + +begin + call zlocva (a, a_first) + call zlocva (b, b_first) + + if (a_first == b_first) + return + + if (a_first < b_first) { + do i = npix, 1, -1 + b[i] = a[i] + } else { + do i = 1, npix + b[i] = a[i] + } +end diff --git a/sys/vops/lz/amuld.x b/sys/vops/lz/amuld.x new file mode 100644 index 00000000..b9a5c13b --- /dev/null +++ b/sys/vops/lz/amuld.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMUL -- Multiply two vectors (generic). + +procedure amuld (a, b, c, npix) + +double a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * b[i] +end diff --git a/sys/vops/lz/amuli.x b/sys/vops/lz/amuli.x new file mode 100644 index 00000000..bf2ff538 --- /dev/null +++ b/sys/vops/lz/amuli.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMUL -- Multiply two vectors (generic). + +procedure amuli (a, b, c, npix) + +int a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * b[i] +end diff --git a/sys/vops/lz/amulkd.x b/sys/vops/lz/amulkd.x new file mode 100644 index 00000000..69f28a9a --- /dev/null +++ b/sys/vops/lz/amulkd.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMULK -- Multiply a constant times a vector (generic). + +procedure amulkd (a, b, c, npix) + +double a[ARB] +double b +double c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * b +end diff --git a/sys/vops/lz/amulki.x b/sys/vops/lz/amulki.x new file mode 100644 index 00000000..773a9a12 --- /dev/null +++ b/sys/vops/lz/amulki.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMULK -- Multiply a constant times a vector (generic). + +procedure amulki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * b +end diff --git a/sys/vops/lz/amulkl.x b/sys/vops/lz/amulkl.x new file mode 100644 index 00000000..69cef4c0 --- /dev/null +++ b/sys/vops/lz/amulkl.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMULK -- Multiply a constant times a vector (generic). + +procedure amulkl (a, b, c, npix) + +long a[ARB] +long b +long c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * b +end diff --git a/sys/vops/lz/amulkr.x b/sys/vops/lz/amulkr.x new file mode 100644 index 00000000..71cac10c --- /dev/null +++ b/sys/vops/lz/amulkr.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMULK -- Multiply a constant times a vector (generic). + +procedure amulkr (a, b, c, npix) + +real a[ARB] +real b +real c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * b +end diff --git a/sys/vops/lz/amulks.x b/sys/vops/lz/amulks.x new file mode 100644 index 00000000..28f6d4ec --- /dev/null +++ b/sys/vops/lz/amulks.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMULK -- Multiply a constant times a vector (generic). + +procedure amulks (a, b, c, npix) + +short a[ARB] +short b +short c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * b +end diff --git a/sys/vops/lz/amulkx.x b/sys/vops/lz/amulkx.x new file mode 100644 index 00000000..c3fe3a36 --- /dev/null +++ b/sys/vops/lz/amulkx.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMULK -- Multiply a constant times a vector (generic). + +procedure amulkx (a, b, c, npix) + +complex a[ARB] +complex b +complex c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * b +end diff --git a/sys/vops/lz/amull.x b/sys/vops/lz/amull.x new file mode 100644 index 00000000..bb913fe2 --- /dev/null +++ b/sys/vops/lz/amull.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMUL -- Multiply two vectors (generic). + +procedure amull (a, b, c, npix) + +long a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * b[i] +end diff --git a/sys/vops/lz/amulr.x b/sys/vops/lz/amulr.x new file mode 100644 index 00000000..fe7b204b --- /dev/null +++ b/sys/vops/lz/amulr.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMUL -- Multiply two vectors (generic). + +procedure amulr (a, b, c, npix) + +real a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * b[i] +end diff --git a/sys/vops/lz/amuls.x b/sys/vops/lz/amuls.x new file mode 100644 index 00000000..ceb5854e --- /dev/null +++ b/sys/vops/lz/amuls.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMUL -- Multiply two vectors (generic). + +procedure amuls (a, b, c, npix) + +short a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * b[i] +end diff --git a/sys/vops/lz/amulx.x b/sys/vops/lz/amulx.x new file mode 100644 index 00000000..1b9aa3dc --- /dev/null +++ b/sys/vops/lz/amulx.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AMUL -- Multiply two vectors (generic). + +procedure amulx (a, b, c, npix) + +complex a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * b[i] +end diff --git a/sys/vops/lz/anegd.x b/sys/vops/lz/anegd.x new file mode 100644 index 00000000..d681464e --- /dev/null +++ b/sys/vops/lz/anegd.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ANEG -- Compute the arithmetic negation of a vector (generic). + +procedure anegd (a, b, npix) + +double a[ARB], b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = -a[i] +end diff --git a/sys/vops/lz/anegi.x b/sys/vops/lz/anegi.x new file mode 100644 index 00000000..d1221376 --- /dev/null +++ b/sys/vops/lz/anegi.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ANEG -- Compute the arithmetic negation of a vector (generic). + +procedure anegi (a, b, npix) + +int a[ARB], b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = -a[i] +end diff --git a/sys/vops/lz/anegl.x b/sys/vops/lz/anegl.x new file mode 100644 index 00000000..e3ab64f4 --- /dev/null +++ b/sys/vops/lz/anegl.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ANEG -- Compute the arithmetic negation of a vector (generic). + +procedure anegl (a, b, npix) + +long a[ARB], b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = -a[i] +end diff --git a/sys/vops/lz/anegr.x b/sys/vops/lz/anegr.x new file mode 100644 index 00000000..449da1b0 --- /dev/null +++ b/sys/vops/lz/anegr.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ANEG -- Compute the arithmetic negation of a vector (generic). + +procedure anegr (a, b, npix) + +real a[ARB], b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = -a[i] +end diff --git a/sys/vops/lz/anegs.x b/sys/vops/lz/anegs.x new file mode 100644 index 00000000..7b8f320e --- /dev/null +++ b/sys/vops/lz/anegs.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ANEG -- Compute the arithmetic negation of a vector (generic). + +procedure anegs (a, b, npix) + +short a[ARB], b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = -a[i] +end diff --git a/sys/vops/lz/anegx.x b/sys/vops/lz/anegx.x new file mode 100644 index 00000000..8f958084 --- /dev/null +++ b/sys/vops/lz/anegx.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ANEG -- Compute the arithmetic negation of a vector (generic). + +procedure anegx (a, b, npix) + +complex a[ARB], b[ARB] +int npix, i + +begin + do i = 1, npix + b[i] = -a[i] +end diff --git a/sys/vops/lz/anoti.x b/sys/vops/lz/anoti.x new file mode 100644 index 00000000..867a8c92 --- /dev/null +++ b/sys/vops/lz/anoti.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ANOT -- Compute the bitwise boolean complement of a vector (generic). + +procedure anoti (a, b, npix) + +int a[ARB], b[ARB] +int npix, i +int not() + +begin + do i = 1, npix { + b[i] = not (a[i]) + } +end diff --git a/sys/vops/lz/anotl.x b/sys/vops/lz/anotl.x new file mode 100644 index 00000000..3ecb0fce --- /dev/null +++ b/sys/vops/lz/anotl.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ANOT -- Compute the bitwise boolean complement of a vector (generic). + +procedure anotl (a, b, npix) + +long a[ARB], b[ARB] +int npix, i +long notl() + +begin + do i = 1, npix { + b[i] = notl (a[i]) + } +end diff --git a/sys/vops/lz/anots.x b/sys/vops/lz/anots.x new file mode 100644 index 00000000..4c952636 --- /dev/null +++ b/sys/vops/lz/anots.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ANOT -- Compute the bitwise boolean complement of a vector (generic). + +procedure anots (a, b, npix) + +short a[ARB], b[ARB] +int npix, i +short nots() + +begin + do i = 1, npix { + b[i] = nots (a[i]) + } +end diff --git a/sys/vops/lz/apkxd.x b/sys/vops/lz/apkxd.x new file mode 100644 index 00000000..7c489491 --- /dev/null +++ b/sys/vops/lz/apkxd.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APKX -- Generate a type COMPLEX output vector given the real and imaginary +# components as input vectors. + +procedure apkxd (a, b, c, npix) + +double a[ARB] # real component +double b[ARB] # imaginary component +complex c[ARB] # output vector +int npix, i + +begin + do i = 1, npix + c[i] = complex (real(a[i]), real(b[i])) +end diff --git a/sys/vops/lz/apkxi.x b/sys/vops/lz/apkxi.x new file mode 100644 index 00000000..c03a0883 --- /dev/null +++ b/sys/vops/lz/apkxi.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APKX -- Generate a type COMPLEX output vector given the real and imaginary +# components as input vectors. + +procedure apkxi (a, b, c, npix) + +int a[ARB] # real component +int b[ARB] # imaginary component +complex c[ARB] # output vector +int npix, i + +begin + do i = 1, npix + c[i] = complex (real(a[i]), real(b[i])) +end diff --git a/sys/vops/lz/apkxl.x b/sys/vops/lz/apkxl.x new file mode 100644 index 00000000..5af1f9e0 --- /dev/null +++ b/sys/vops/lz/apkxl.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APKX -- Generate a type COMPLEX output vector given the real and imaginary +# components as input vectors. + +procedure apkxl (a, b, c, npix) + +long a[ARB] # real component +long b[ARB] # imaginary component +complex c[ARB] # output vector +int npix, i + +begin + do i = 1, npix + c[i] = complex (real(a[i]), real(b[i])) +end diff --git a/sys/vops/lz/apkxr.x b/sys/vops/lz/apkxr.x new file mode 100644 index 00000000..aba0261a --- /dev/null +++ b/sys/vops/lz/apkxr.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APKX -- Generate a type COMPLEX output vector given the real and imaginary +# components as input vectors. + +procedure apkxr (a, b, c, npix) + +real a[ARB] # real component +real b[ARB] # imaginary component +complex c[ARB] # output vector +int npix, i + +begin + do i = 1, npix + c[i] = complex (real(a[i]), real(b[i])) +end diff --git a/sys/vops/lz/apkxs.x b/sys/vops/lz/apkxs.x new file mode 100644 index 00000000..178683a9 --- /dev/null +++ b/sys/vops/lz/apkxs.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APKX -- Generate a type COMPLEX output vector given the real and imaginary +# components as input vectors. + +procedure apkxs (a, b, c, npix) + +short a[ARB] # real component +short b[ARB] # imaginary component +complex c[ARB] # output vector +int npix, i + +begin + do i = 1, npix + c[i] = complex (real(a[i]), real(b[i])) +end diff --git a/sys/vops/lz/apkxx.x b/sys/vops/lz/apkxx.x new file mode 100644 index 00000000..9baef047 --- /dev/null +++ b/sys/vops/lz/apkxx.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APKX -- Generate a type COMPLEX output vector given the real and imaginary +# components as input vectors. + +procedure apkxx (a, b, c, npix) + +complex a[ARB] # real component +complex b[ARB] # imaginary component +complex c[ARB] # output vector +int npix, i + +begin + do i = 1, npix + c[i] = complex (real(a[i]), aimag(b[i])) +end diff --git a/sys/vops/lz/apold.x b/sys/vops/lz/apold.x new file mode 100644 index 00000000..885ed4fe --- /dev/null +++ b/sys/vops/lz/apold.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOL -- Evaluate a polynomial at X, given the coefficients of the polynomial +# in COEFF and returning the computed value as the function value. + +double procedure apold (x, coeff, ncoeff) + +double x # point at which the polynomial is to be evaluated +double coeff[ncoeff] # coefficients of the polynomial, lower orders first +int ncoeff + +int i +double pow, sum + +begin + sum = coeff[1] + pow = x + + do i = 2, ncoeff { + sum = sum + pow * coeff[i] + pow = pow * x + } + + return (sum) +end diff --git a/sys/vops/lz/apolr.x b/sys/vops/lz/apolr.x new file mode 100644 index 00000000..22912021 --- /dev/null +++ b/sys/vops/lz/apolr.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOL -- Evaluate a polynomial at X, given the coefficients of the polynomial +# in COEFF and returning the computed value as the function value. + +real procedure apolr (x, coeff, ncoeff) + +real x # point at which the polynomial is to be evaluated +real coeff[ncoeff] # coefficients of the polynomial, lower orders first +int ncoeff + +int i +real pow, sum + +begin + sum = coeff[1] + pow = x + + do i = 2, ncoeff { + sum = sum + pow * coeff[i] + pow = pow * x + } + + return (sum) +end diff --git a/sys/vops/lz/apowd.x b/sys/vops/lz/apowd.x new file mode 100644 index 00000000..2f277935 --- /dev/null +++ b/sys/vops/lz/apowd.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOW -- Compute a ** b, where b is of type INT (generic). + +procedure apowd (a, b, c, npix) + +double a[ARB], c[ARB] +int b[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b[i] +end diff --git a/sys/vops/lz/apowi.x b/sys/vops/lz/apowi.x new file mode 100644 index 00000000..27d587f9 --- /dev/null +++ b/sys/vops/lz/apowi.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOW -- Compute a ** b, where b is of type INT (generic). + +procedure apowi (a, b, c, npix) + +int a[ARB], c[ARB] +int b[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b[i] +end diff --git a/sys/vops/lz/apowkd.x b/sys/vops/lz/apowkd.x new file mode 100644 index 00000000..8aee1a87 --- /dev/null +++ b/sys/vops/lz/apowkd.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOWK -- Compute a ** b, where b is a constant of type INT (generic). + +procedure apowkd (a, b, c, npix) + +double a[ARB], c[ARB] +int b +int npix, i + +begin + # Optimize the code for the various special cases. We assume that the + # compiler is intelligent enough to recognize the special cases if the + # power is expressed as an integer constant. + + switch (b) { + case 0: + call amovkd (1.0D0, c, npix) + case 1: + call amovd (a, c, npix) + case 2: + do i = 1, npix + c[i] = a[i] ** 2 + case 3: + do i = 1, npix + c[i] = a[i] ** 3 + case 4: + do i = 1, npix + c[i] = a[i] ** 4 + default: + do i = 1, npix + c[i] = a[i] ** b + } +end diff --git a/sys/vops/lz/apowki.x b/sys/vops/lz/apowki.x new file mode 100644 index 00000000..1b756bca --- /dev/null +++ b/sys/vops/lz/apowki.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOWK -- Compute a ** b, where b is a constant of type INT (generic). + +procedure apowki (a, b, c, npix) + +int a[ARB], c[ARB] +int b +int npix, i + +begin + # Optimize the code for the various special cases. We assume that the + # compiler is intelligent enough to recognize the special cases if the + # power is expressed as an integer constant. + + switch (b) { + case 0: + call amovki (1, c, npix) + case 1: + call amovi (a, c, npix) + case 2: + do i = 1, npix + c[i] = a[i] ** 2 + case 3: + do i = 1, npix + c[i] = a[i] ** 3 + case 4: + do i = 1, npix + c[i] = a[i] ** 4 + default: + do i = 1, npix + c[i] = a[i] ** b + } +end diff --git a/sys/vops/lz/apowkl.x b/sys/vops/lz/apowkl.x new file mode 100644 index 00000000..c7247f3e --- /dev/null +++ b/sys/vops/lz/apowkl.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOWK -- Compute a ** b, where b is a constant of type INT (generic). + +procedure apowkl (a, b, c, npix) + +long a[ARB], c[ARB] +int b +int npix, i + +begin + # Optimize the code for the various special cases. We assume that the + # compiler is intelligent enough to recognize the special cases if the + # power is expressed as an integer constant. + + switch (b) { + case 0: + call amovkl (1, c, npix) + case 1: + call amovl (a, c, npix) + case 2: + do i = 1, npix + c[i] = a[i] ** 2 + case 3: + do i = 1, npix + c[i] = a[i] ** 3 + case 4: + do i = 1, npix + c[i] = a[i] ** 4 + default: + do i = 1, npix + c[i] = a[i] ** b + } +end diff --git a/sys/vops/lz/apowkr.x b/sys/vops/lz/apowkr.x new file mode 100644 index 00000000..b22be6b7 --- /dev/null +++ b/sys/vops/lz/apowkr.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOWK -- Compute a ** b, where b is a constant of type INT (generic). + +procedure apowkr (a, b, c, npix) + +real a[ARB], c[ARB] +int b +int npix, i + +begin + # Optimize the code for the various special cases. We assume that the + # compiler is intelligent enough to recognize the special cases if the + # power is expressed as an integer constant. + + switch (b) { + case 0: + call amovkr (1.0, c, npix) + case 1: + call amovr (a, c, npix) + case 2: + do i = 1, npix + c[i] = a[i] ** 2 + case 3: + do i = 1, npix + c[i] = a[i] ** 3 + case 4: + do i = 1, npix + c[i] = a[i] ** 4 + default: + do i = 1, npix + c[i] = a[i] ** b + } +end diff --git a/sys/vops/lz/apowks.x b/sys/vops/lz/apowks.x new file mode 100644 index 00000000..f656115a --- /dev/null +++ b/sys/vops/lz/apowks.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOWK -- Compute a ** b, where b is a constant of type INT (generic). + +procedure apowks (a, b, c, npix) + +short a[ARB], c[ARB] +int b +int npix, i + +begin + # Optimize the code for the various special cases. We assume that the + # compiler is intelligent enough to recognize the special cases if the + # power is expressed as an integer constant. + + switch (b) { + case 0: + call amovks (1, c, npix) + case 1: + call amovs (a, c, npix) + case 2: + do i = 1, npix + c[i] = a[i] ** 2 + case 3: + do i = 1, npix + c[i] = a[i] ** 3 + case 4: + do i = 1, npix + c[i] = a[i] ** 4 + default: + do i = 1, npix + c[i] = a[i] ** b + } +end diff --git a/sys/vops/lz/apowkx.x b/sys/vops/lz/apowkx.x new file mode 100644 index 00000000..461353be --- /dev/null +++ b/sys/vops/lz/apowkx.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOWK -- Compute a ** b, where b is a constant of type INT (generic). + +procedure apowkx (a, b, c, npix) + +complex a[ARB], c[ARB] +int b +int npix, i + +begin + # Optimize the code for the various special cases. We assume that the + # compiler is intelligent enough to recognize the special cases if the + # power is expressed as an integer constant. + + switch (b) { + case 0: + call amovkx ((1,1), c, npix) + case 1: + call amovx (a, c, npix) + case 2: + do i = 1, npix + c[i] = a[i] ** 2 + case 3: + do i = 1, npix + c[i] = a[i] ** 3 + case 4: + do i = 1, npix + c[i] = a[i] ** 4 + default: + do i = 1, npix + c[i] = a[i] ** b + } +end diff --git a/sys/vops/lz/apowl.x b/sys/vops/lz/apowl.x new file mode 100644 index 00000000..28cd171f --- /dev/null +++ b/sys/vops/lz/apowl.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOW -- Compute a ** b, where b is of type INT (generic). + +procedure apowl (a, b, c, npix) + +long a[ARB], c[ARB] +int b[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b[i] +end diff --git a/sys/vops/lz/apowr.x b/sys/vops/lz/apowr.x new file mode 100644 index 00000000..7d80443f --- /dev/null +++ b/sys/vops/lz/apowr.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOW -- Compute a ** b, where b is of type INT (generic). + +procedure apowr (a, b, c, npix) + +real a[ARB], c[ARB] +int b[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b[i] +end diff --git a/sys/vops/lz/apows.x b/sys/vops/lz/apows.x new file mode 100644 index 00000000..de128595 --- /dev/null +++ b/sys/vops/lz/apows.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOW -- Compute a ** b, where b is of type INT (generic). + +procedure apows (a, b, c, npix) + +short a[ARB], c[ARB] +int b[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b[i] +end diff --git a/sys/vops/lz/apowx.x b/sys/vops/lz/apowx.x new file mode 100644 index 00000000..77f7814d --- /dev/null +++ b/sys/vops/lz/apowx.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# APOW -- Compute a ** b, where b is of type INT (generic). + +procedure apowx (a, b, c, npix) + +complex a[ARB], c[ARB] +int b[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] ** b[i] +end diff --git a/sys/vops/lz/aravd.x b/sys/vops/lz/aravd.x new file mode 100644 index 00000000..7b454fd3 --- /dev/null +++ b/sys/vops/lz/aravd.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ARAV -- Compute the mean and standard deviation of a sample array by +# iteratively rejecting points further than KSIG from the mean. If the +# value of KSIG is given as 0.0, a cutoff value will be automatically +# calculated from the standard deviation and number of points in the sample. +# The number of pixels remaining in the sample upon termination is returned +# as the function value. + +int procedure aravd (a, npix, mean, sigma, ksig) + +double a[ARB] # input data array +double mean, sigma, ksig, deviation, lcut, hcut, lgpx +int npix, ngpix, old_ngpix, awvgd() + +begin + lcut = -MAX_REAL # no rejection to start + hcut = MAX_REAL + ngpix = MAX_INT + + # Iteratively compute mean, sigma and reject outliers until no + # more pixels are rejected, or until there are no more pixels. + + repeat { + old_ngpix = ngpix + ngpix = awvgd (a, npix, mean, sigma, lcut, hcut) + if (ngpix <= 1 || sigma <= EPSILOND) + break + + if (ksig == 0.0) { # Chauvenet's relation + lgpx = log10 (real(ngpix)) + deviation = (lgpx * (-0.1042 * lgpx + 1.1695) + .8895) * sigma + } else + deviation = sigma * abs(ksig) + + lcut = mean - deviation # compute window + hcut = mean + deviation + + } until (ngpix >= old_ngpix) + + return (ngpix) +end diff --git a/sys/vops/lz/aravi.x b/sys/vops/lz/aravi.x new file mode 100644 index 00000000..865e4ecb --- /dev/null +++ b/sys/vops/lz/aravi.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ARAV -- Compute the mean and standard deviation of a sample array by +# iteratively rejecting points further than KSIG from the mean. If the +# value of KSIG is given as 0.0, a cutoff value will be automatically +# calculated from the standard deviation and number of points in the sample. +# The number of pixels remaining in the sample upon termination is returned +# as the function value. + +int procedure aravi (a, npix, mean, sigma, ksig) + +int a[ARB] # input data array +real mean, sigma, ksig, deviation, lcut, hcut, lgpx +int npix, ngpix, old_ngpix, awvgi() + +begin + lcut = -MAX_REAL # no rejection to start + hcut = MAX_REAL + ngpix = MAX_INT + + # Iteratively compute mean, sigma and reject outliers until no + # more pixels are rejected, or until there are no more pixels. + + repeat { + old_ngpix = ngpix + ngpix = awvgi (a, npix, mean, sigma, lcut, hcut) + if (ngpix <= 1 || sigma <= EPSILONR) + break + + if (ksig == 0.0) { # Chauvenet's relation + lgpx = log10 (real(ngpix)) + deviation = (lgpx * (-0.1042 * lgpx + 1.1695) + .8895) * sigma + } else + deviation = sigma * abs(ksig) + + lcut = mean - deviation # compute window + hcut = mean + deviation + + } until (ngpix >= old_ngpix) + + return (ngpix) +end diff --git a/sys/vops/lz/aravl.x b/sys/vops/lz/aravl.x new file mode 100644 index 00000000..519cd1c8 --- /dev/null +++ b/sys/vops/lz/aravl.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ARAV -- Compute the mean and standard deviation of a sample array by +# iteratively rejecting points further than KSIG from the mean. If the +# value of KSIG is given as 0.0, a cutoff value will be automatically +# calculated from the standard deviation and number of points in the sample. +# The number of pixels remaining in the sample upon termination is returned +# as the function value. + +int procedure aravl (a, npix, mean, sigma, ksig) + +long a[ARB] # input data array +double mean, sigma, ksig, deviation, lcut, hcut, lgpx +int npix, ngpix, old_ngpix, awvgl() + +begin + lcut = -MAX_REAL # no rejection to start + hcut = MAX_REAL + ngpix = MAX_INT + + # Iteratively compute mean, sigma and reject outliers until no + # more pixels are rejected, or until there are no more pixels. + + repeat { + old_ngpix = ngpix + ngpix = awvgl (a, npix, mean, sigma, lcut, hcut) + if (ngpix <= 1 || sigma <= EPSILOND) + break + + if (ksig == 0.0) { # Chauvenet's relation + lgpx = log10 (real(ngpix)) + deviation = (lgpx * (-0.1042 * lgpx + 1.1695) + .8895) * sigma + } else + deviation = sigma * abs(ksig) + + lcut = mean - deviation # compute window + hcut = mean + deviation + + } until (ngpix >= old_ngpix) + + return (ngpix) +end diff --git a/sys/vops/lz/aravr.x b/sys/vops/lz/aravr.x new file mode 100644 index 00000000..c3f0fb8f --- /dev/null +++ b/sys/vops/lz/aravr.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ARAV -- Compute the mean and standard deviation of a sample array by +# iteratively rejecting points further than KSIG from the mean. If the +# value of KSIG is given as 0.0, a cutoff value will be automatically +# calculated from the standard deviation and number of points in the sample. +# The number of pixels remaining in the sample upon termination is returned +# as the function value. + +int procedure aravr (a, npix, mean, sigma, ksig) + +real a[ARB] # input data array +real mean, sigma, ksig, deviation, lcut, hcut, lgpx +int npix, ngpix, old_ngpix, awvgr() + +begin + lcut = -MAX_REAL # no rejection to start + hcut = MAX_REAL + ngpix = MAX_INT + + # Iteratively compute mean, sigma and reject outliers until no + # more pixels are rejected, or until there are no more pixels. + + repeat { + old_ngpix = ngpix + ngpix = awvgr (a, npix, mean, sigma, lcut, hcut) + if (ngpix <= 1 || sigma <= EPSILONR) + break + + if (ksig == 0.0) { # Chauvenet's relation + lgpx = log10 (real(ngpix)) + deviation = (lgpx * (-0.1042 * lgpx + 1.1695) + .8895) * sigma + } else + deviation = sigma * abs(ksig) + + lcut = mean - deviation # compute window + hcut = mean + deviation + + } until (ngpix >= old_ngpix) + + return (ngpix) +end diff --git a/sys/vops/lz/aravs.x b/sys/vops/lz/aravs.x new file mode 100644 index 00000000..6c734aed --- /dev/null +++ b/sys/vops/lz/aravs.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ARAV -- Compute the mean and standard deviation of a sample array by +# iteratively rejecting points further than KSIG from the mean. If the +# value of KSIG is given as 0.0, a cutoff value will be automatically +# calculated from the standard deviation and number of points in the sample. +# The number of pixels remaining in the sample upon termination is returned +# as the function value. + +int procedure aravs (a, npix, mean, sigma, ksig) + +short a[ARB] # input data array +real mean, sigma, ksig, deviation, lcut, hcut, lgpx +int npix, ngpix, old_ngpix, awvgs() + +begin + lcut = -MAX_REAL # no rejection to start + hcut = MAX_REAL + ngpix = MAX_INT + + # Iteratively compute mean, sigma and reject outliers until no + # more pixels are rejected, or until there are no more pixels. + + repeat { + old_ngpix = ngpix + ngpix = awvgs (a, npix, mean, sigma, lcut, hcut) + if (ngpix <= 1 || sigma <= EPSILONR) + break + + if (ksig == 0.0) { # Chauvenet's relation + lgpx = log10 (real(ngpix)) + deviation = (lgpx * (-0.1042 * lgpx + 1.1695) + .8895) * sigma + } else + deviation = sigma * abs(ksig) + + lcut = mean - deviation # compute window + hcut = mean + deviation + + } until (ngpix >= old_ngpix) + + return (ngpix) +end diff --git a/sys/vops/lz/aravx.x b/sys/vops/lz/aravx.x new file mode 100644 index 00000000..92f7328c --- /dev/null +++ b/sys/vops/lz/aravx.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ARAV -- Compute the mean and standard deviation of a sample array by +# iteratively rejecting points further than KSIG from the mean. If the +# value of KSIG is given as 0.0, a cutoff value will be automatically +# calculated from the standard deviation and number of points in the sample. +# The number of pixels remaining in the sample upon termination is returned +# as the function value. + +int procedure aravx (a, npix, mean, sigma, ksig) + +complex a[ARB] # input data array +real mean, sigma, ksig, deviation, lcut, hcut, lgpx +int npix, ngpix, old_ngpix, awvgx() + +begin + lcut = -MAX_REAL # no rejection to start + hcut = MAX_REAL + ngpix = MAX_INT + + # Iteratively compute mean, sigma and reject outliers until no + # more pixels are rejected, or until there are no more pixels. + + repeat { + old_ngpix = ngpix + ngpix = awvgx (a, npix, mean, sigma, lcut, hcut) + if (ngpix <= 1 || sigma <= EPSILONR) + break + + if (ksig == 0.0) { # Chauvenet's relation + lgpx = log10 (real(ngpix)) + deviation = (lgpx * (-0.1042 * lgpx + 1.1695) + .8895) * sigma + } else + deviation = sigma * abs(ksig) + + lcut = mean - deviation # compute window + hcut = mean + deviation + + } until (ngpix >= old_ngpix) + + return (ngpix) +end diff --git a/sys/vops/lz/arcpd.x b/sys/vops/lz/arcpd.x new file mode 100644 index 00000000..095d50d3 --- /dev/null +++ b/sys/vops/lz/arcpd.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARCP -- Reciprocal of a constant divided by a vector. No divide by zero +# checking is performed. + +procedure arcpd (a, b, c, npix) + +double a # constant numerator +double b[ARB] # vector denominator +double c[ARB] # output vector +int npix +int i + +begin + if (a == 0.0D0) { + call aclrd (c, npix) + } else if (a == 1.0D0) { + do i = 1, npix + c[i] = 1.0D0 / b[i] + } else { + do i = 1, npix + c[i] = a / b[i] + } +end diff --git a/sys/vops/lz/arcpi.x b/sys/vops/lz/arcpi.x new file mode 100644 index 00000000..193f35e1 --- /dev/null +++ b/sys/vops/lz/arcpi.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARCP -- Reciprocal of a constant divided by a vector. No divide by zero +# checking is performed. + +procedure arcpi (a, b, c, npix) + +int a # constant numerator +int b[ARB] # vector denominator +int c[ARB] # output vector +int npix +int i + +begin + if (a == 0) { + call aclri (c, npix) + } else if (a == 1) { + do i = 1, npix + c[i] = 1 / b[i] + } else { + do i = 1, npix + c[i] = a / b[i] + } +end diff --git a/sys/vops/lz/arcpl.x b/sys/vops/lz/arcpl.x new file mode 100644 index 00000000..3f3c5b39 --- /dev/null +++ b/sys/vops/lz/arcpl.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARCP -- Reciprocal of a constant divided by a vector. No divide by zero +# checking is performed. + +procedure arcpl (a, b, c, npix) + +long a # constant numerator +long b[ARB] # vector denominator +long c[ARB] # output vector +int npix +int i + +begin + if (a == 0) { + call aclrl (c, npix) + } else if (a == 1) { + do i = 1, npix + c[i] = 1 / b[i] + } else { + do i = 1, npix + c[i] = a / b[i] + } +end diff --git a/sys/vops/lz/arcpr.x b/sys/vops/lz/arcpr.x new file mode 100644 index 00000000..f52a1651 --- /dev/null +++ b/sys/vops/lz/arcpr.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARCP -- Reciprocal of a constant divided by a vector. No divide by zero +# checking is performed. + +procedure arcpr (a, b, c, npix) + +real a # constant numerator +real b[ARB] # vector denominator +real c[ARB] # output vector +int npix +int i + +begin + if (a == 0.0) { + call aclrr (c, npix) + } else if (a == 1.0) { + do i = 1, npix + c[i] = 1.0 / b[i] + } else { + do i = 1, npix + c[i] = a / b[i] + } +end diff --git a/sys/vops/lz/arcps.x b/sys/vops/lz/arcps.x new file mode 100644 index 00000000..0e0f8056 --- /dev/null +++ b/sys/vops/lz/arcps.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARCP -- Reciprocal of a constant divided by a vector. No divide by zero +# checking is performed. + +procedure arcps (a, b, c, npix) + +short a # constant numerator +short b[ARB] # vector denominator +short c[ARB] # output vector +int npix +int i + +begin + if (a == 0) { + call aclrs (c, npix) + } else if (a == 1) { + do i = 1, npix + c[i] = 1 / b[i] + } else { + do i = 1, npix + c[i] = a / b[i] + } +end diff --git a/sys/vops/lz/arcpx.x b/sys/vops/lz/arcpx.x new file mode 100644 index 00000000..626eb6a1 --- /dev/null +++ b/sys/vops/lz/arcpx.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARCP -- Reciprocal of a constant divided by a vector. No divide by zero +# checking is performed. + +procedure arcpx (a, b, c, npix) + +complex a # constant numerator +complex b[ARB] # vector denominator +complex c[ARB] # output vector +int npix +int i + +begin + if (a == (0.0,0.0)) { + call aclrx (c, npix) + } else if (a == (1.0,1.0)) { + do i = 1, npix + c[i] = (1.0,1.0) / b[i] + } else { + do i = 1, npix + c[i] = a / b[i] + } +end diff --git a/sys/vops/lz/arczd.x b/sys/vops/lz/arczd.x new file mode 100644 index 00000000..4f5ad6f2 --- /dev/null +++ b/sys/vops/lz/arczd.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARCZ -- Vector reciprocal with checking for zero divisors. If the result +# of a divide would be undefined a user supplied function is called to get the +# output pixel value. +# +# NOTE: in the interests of simplicity a somewhat arbitrary tolerance is used +# to check for an undefined divide, i.e., a divide by zero or a divide by a +# number small enough to cause floating point overflow. A better way to do +# this would be to provide a machine dependent version of this operator in +# host$as which catches the hardware exception rather than using a comparison. + +procedure arczd (a, b, c, npix, errfcn) + +double a # numerator +double b[ARB], c[ARB] # divisor, and output arrays +int npix # number of pixels +double errfcn() # user function, called on divide by zero + +int i +double divisor +double tol +extern errfcn() +errchk errfcn + +begin + if (a == 0.0D0) { + call aclrd (c, npix) + return + } + + tol = 1.0D-20 + + do i = 1, npix { + divisor = b[i] + # The following is most efficient when the data tends to be + # positive. + + if (divisor < tol) + if (divisor > -tol) { + c[i] = errfcn (a) + next + } + c[i] = a / divisor + + } +end diff --git a/sys/vops/lz/arczi.x b/sys/vops/lz/arczi.x new file mode 100644 index 00000000..ce679742 --- /dev/null +++ b/sys/vops/lz/arczi.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARCZ -- Vector reciprocal with checking for zero divisors. If the result +# of a divide would be undefined a user supplied function is called to get the +# output pixel value. +# +# NOTE: in the interests of simplicity a somewhat arbitrary tolerance is used +# to check for an undefined divide, i.e., a divide by zero or a divide by a +# number small enough to cause floating point overflow. A better way to do +# this would be to provide a machine dependent version of this operator in +# host$as which catches the hardware exception rather than using a comparison. + +procedure arczi (a, b, c, npix, errfcn) + +int a # numerator +int b[ARB], c[ARB] # divisor, and output arrays +int npix # number of pixels +int errfcn() # user function, called on divide by zero + +int i +int divisor +extern errfcn() +errchk errfcn + +begin + if (a == 0) { + call aclri (c, npix) + return + } + + + do i = 1, npix { + divisor = b[i] + if (divisor == 0) + c[i] = errfcn (a) + else + c[i] = a / divisor + } +end diff --git a/sys/vops/lz/arczl.x b/sys/vops/lz/arczl.x new file mode 100644 index 00000000..b89e2cbe --- /dev/null +++ b/sys/vops/lz/arczl.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARCZ -- Vector reciprocal with checking for zero divisors. If the result +# of a divide would be undefined a user supplied function is called to get the +# output pixel value. +# +# NOTE: in the interests of simplicity a somewhat arbitrary tolerance is used +# to check for an undefined divide, i.e., a divide by zero or a divide by a +# number small enough to cause floating point overflow. A better way to do +# this would be to provide a machine dependent version of this operator in +# host$as which catches the hardware exception rather than using a comparison. + +procedure arczl (a, b, c, npix, errfcn) + +long a # numerator +long b[ARB], c[ARB] # divisor, and output arrays +int npix # number of pixels +long errfcn() # user function, called on divide by zero + +int i +long divisor +extern errfcn() +errchk errfcn + +begin + if (a == 0) { + call aclrl (c, npix) + return + } + + + do i = 1, npix { + divisor = b[i] + if (divisor == 0) + c[i] = errfcn (a) + else + c[i] = a / divisor + } +end diff --git a/sys/vops/lz/arczr.x b/sys/vops/lz/arczr.x new file mode 100644 index 00000000..7c2e9fe2 --- /dev/null +++ b/sys/vops/lz/arczr.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARCZ -- Vector reciprocal with checking for zero divisors. If the result +# of a divide would be undefined a user supplied function is called to get the +# output pixel value. +# +# NOTE: in the interests of simplicity a somewhat arbitrary tolerance is used +# to check for an undefined divide, i.e., a divide by zero or a divide by a +# number small enough to cause floating point overflow. A better way to do +# this would be to provide a machine dependent version of this operator in +# host$as which catches the hardware exception rather than using a comparison. + +procedure arczr (a, b, c, npix, errfcn) + +real a # numerator +real b[ARB], c[ARB] # divisor, and output arrays +int npix # number of pixels +real errfcn() # user function, called on divide by zero + +int i +real divisor +real tol +extern errfcn() +errchk errfcn + +begin + if (a == 0.0) { + call aclrr (c, npix) + return + } + + tol = 1.0E-20 + + do i = 1, npix { + divisor = b[i] + # The following is most efficient when the data tends to be + # positive. + + if (divisor < tol) + if (divisor > -tol) { + c[i] = errfcn (a) + next + } + c[i] = a / divisor + + } +end diff --git a/sys/vops/lz/arczs.x b/sys/vops/lz/arczs.x new file mode 100644 index 00000000..4216d38d --- /dev/null +++ b/sys/vops/lz/arczs.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARCZ -- Vector reciprocal with checking for zero divisors. If the result +# of a divide would be undefined a user supplied function is called to get the +# output pixel value. +# +# NOTE: in the interests of simplicity a somewhat arbitrary tolerance is used +# to check for an undefined divide, i.e., a divide by zero or a divide by a +# number small enough to cause floating point overflow. A better way to do +# this would be to provide a machine dependent version of this operator in +# host$as which catches the hardware exception rather than using a comparison. + +procedure arczs (a, b, c, npix, errfcn) + +short a # numerator +short b[ARB], c[ARB] # divisor, and output arrays +int npix # number of pixels +short errfcn() # user function, called on divide by zero + +int i +short divisor +extern errfcn() +errchk errfcn + +begin + if (a == 0) { + call aclrs (c, npix) + return + } + + + do i = 1, npix { + divisor = b[i] + if (divisor == 0) + c[i] = errfcn (a) + else + c[i] = a / divisor + } +end diff --git a/sys/vops/lz/arczx.x b/sys/vops/lz/arczx.x new file mode 100644 index 00000000..ec23595e --- /dev/null +++ b/sys/vops/lz/arczx.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARCZ -- Vector reciprocal with checking for zero divisors. If the result +# of a divide would be undefined a user supplied function is called to get the +# output pixel value. +# +# NOTE: in the interests of simplicity a somewhat arbitrary tolerance is used +# to check for an undefined divide, i.e., a divide by zero or a divide by a +# number small enough to cause floating point overflow. A better way to do +# this would be to provide a machine dependent version of this operator in +# host$as which catches the hardware exception rather than using a comparison. + +procedure arczx (a, b, c, npix, errfcn) + +complex a # numerator +complex b[ARB], c[ARB] # divisor, and output arrays +int npix # number of pixels +complex errfcn() # user function, called on divide by zero + +int i +complex divisor +extern errfcn() +errchk errfcn + +begin + if (a == (0.0,0.0)) { + call aclrx (c, npix) + return + } + + + do i = 1, npix { + divisor = b[i] + if (divisor == (0.0,0.0)) + c[i] = errfcn (a) + else + c[i] = a / divisor + } +end diff --git a/sys/vops/lz/argtd.x b/sys/vops/lz/argtd.x new file mode 100644 index 00000000..bf12e17c --- /dev/null +++ b/sys/vops/lz/argtd.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARGT -- Replace if greater than. If A[i] is greater than CEIL replace by +# NEWVAL. + +procedure argtd (a, npix, ceil, newval) + +double a[ARB] +int npix +double ceil, newval +int i + +begin + + do i = 1, npix + if (a[i] > ceil) + a[i] = newval +end diff --git a/sys/vops/lz/argti.x b/sys/vops/lz/argti.x new file mode 100644 index 00000000..dffdce17 --- /dev/null +++ b/sys/vops/lz/argti.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARGT -- Replace if greater than. If A[i] is greater than CEIL replace by +# NEWVAL. + +procedure argti (a, npix, ceil, newval) + +int a[ARB] +int npix +int ceil, newval +int i + +begin + + do i = 1, npix + if (a[i] > ceil) + a[i] = newval +end diff --git a/sys/vops/lz/argtl.x b/sys/vops/lz/argtl.x new file mode 100644 index 00000000..e776573c --- /dev/null +++ b/sys/vops/lz/argtl.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARGT -- Replace if greater than. If A[i] is greater than CEIL replace by +# NEWVAL. + +procedure argtl (a, npix, ceil, newval) + +long a[ARB] +int npix +long ceil, newval +int i + +begin + + do i = 1, npix + if (a[i] > ceil) + a[i] = newval +end diff --git a/sys/vops/lz/argtr.x b/sys/vops/lz/argtr.x new file mode 100644 index 00000000..5ab107f7 --- /dev/null +++ b/sys/vops/lz/argtr.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARGT -- Replace if greater than. If A[i] is greater than CEIL replace by +# NEWVAL. + +procedure argtr (a, npix, ceil, newval) + +real a[ARB] +int npix +real ceil, newval +int i + +begin + + do i = 1, npix + if (a[i] > ceil) + a[i] = newval +end diff --git a/sys/vops/lz/argts.x b/sys/vops/lz/argts.x new file mode 100644 index 00000000..815f753f --- /dev/null +++ b/sys/vops/lz/argts.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARGT -- Replace if greater than. If A[i] is greater than CEIL replace by +# NEWVAL. + +procedure argts (a, npix, ceil, newval) + +short a[ARB] +int npix +short ceil, newval +int i + +begin + + do i = 1, npix + if (a[i] > ceil) + a[i] = newval +end diff --git a/sys/vops/lz/argtx.x b/sys/vops/lz/argtx.x new file mode 100644 index 00000000..53253e01 --- /dev/null +++ b/sys/vops/lz/argtx.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARGT -- Replace if greater than. If A[i] is greater than CEIL replace by +# NEWVAL. + +procedure argtx (a, npix, ceil, newval) + +complex a[ARB] +int npix +complex ceil, newval +int i +real abs_ceil + +begin + abs_ceil = abs (ceil) + + do i = 1, npix + if (abs (a[i]) > abs_ceil) + a[i] = newval +end diff --git a/sys/vops/lz/arltd.x b/sys/vops/lz/arltd.x new file mode 100644 index 00000000..62693331 --- /dev/null +++ b/sys/vops/lz/arltd.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARLT -- Replace if less than. If A[i] is less than FLOOR replace by NEWVAL. + +procedure arltd (a, npix, floor, newval) + +double a[ARB] +int npix +double floor, newval +int i + +begin + + do i = 1, npix + if (a[i] < floor) + a[i] = newval +end diff --git a/sys/vops/lz/arlti.x b/sys/vops/lz/arlti.x new file mode 100644 index 00000000..6b8ae086 --- /dev/null +++ b/sys/vops/lz/arlti.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARLT -- Replace if less than. If A[i] is less than FLOOR replace by NEWVAL. + +procedure arlti (a, npix, floor, newval) + +int a[ARB] +int npix +int floor, newval +int i + +begin + + do i = 1, npix + if (a[i] < floor) + a[i] = newval +end diff --git a/sys/vops/lz/arltl.x b/sys/vops/lz/arltl.x new file mode 100644 index 00000000..4bda96c3 --- /dev/null +++ b/sys/vops/lz/arltl.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARLT -- Replace if less than. If A[i] is less than FLOOR replace by NEWVAL. + +procedure arltl (a, npix, floor, newval) + +long a[ARB] +int npix +long floor, newval +int i + +begin + + do i = 1, npix + if (a[i] < floor) + a[i] = newval +end diff --git a/sys/vops/lz/arltr.x b/sys/vops/lz/arltr.x new file mode 100644 index 00000000..3b419556 --- /dev/null +++ b/sys/vops/lz/arltr.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARLT -- Replace if less than. If A[i] is less than FLOOR replace by NEWVAL. + +procedure arltr (a, npix, floor, newval) + +real a[ARB] +int npix +real floor, newval +int i + +begin + + do i = 1, npix + if (a[i] < floor) + a[i] = newval +end diff --git a/sys/vops/lz/arlts.x b/sys/vops/lz/arlts.x new file mode 100644 index 00000000..ca4e0582 --- /dev/null +++ b/sys/vops/lz/arlts.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARLT -- Replace if less than. If A[i] is less than FLOOR replace by NEWVAL. + +procedure arlts (a, npix, floor, newval) + +short a[ARB] +int npix +short floor, newval +int i + +begin + + do i = 1, npix + if (a[i] < floor) + a[i] = newval +end diff --git a/sys/vops/lz/arltx.x b/sys/vops/lz/arltx.x new file mode 100644 index 00000000..8ea55d5f --- /dev/null +++ b/sys/vops/lz/arltx.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ARLT -- Replace if less than. If A[i] is less than FLOOR replace by NEWVAL. + +procedure arltx (a, npix, floor, newval) + +complex a[ARB] +int npix +complex floor, newval +int i +real abs_floor + +begin + abs_floor = abs (floor) + + do i = 1, npix + if (abs (a[i]) < abs_floor) + a[i] = newval +end diff --git a/sys/vops/lz/aselc.x b/sys/vops/lz/aselc.x new file mode 100644 index 00000000..eeed8930 --- /dev/null +++ b/sys/vops/lz/aselc.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASEL -- Vector select element. The output vector is formed by taking +# successive pixels from either of the two input vectors, based on the value +# of the integer (boolean) selection vectors. Used to implement vector +# conditional expressions. + +procedure aselc (a, b, c, sel, npix) + +char a[ARB], b[ARB], c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b[i] +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b[i] +end diff --git a/sys/vops/lz/aseld.x b/sys/vops/lz/aseld.x new file mode 100644 index 00000000..79758363 --- /dev/null +++ b/sys/vops/lz/aseld.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASEL -- Vector select element. The output vector is formed by taking +# successive pixels from either of the two input vectors, based on the value +# of the integer (boolean) selection vectors. Used to implement vector +# conditional expressions. + +procedure aseld (a, b, c, sel, npix) + +double a[ARB], b[ARB], c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b[i] +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b[i] +end diff --git a/sys/vops/lz/aseli.x b/sys/vops/lz/aseli.x new file mode 100644 index 00000000..c4a8a211 --- /dev/null +++ b/sys/vops/lz/aseli.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASEL -- Vector select element. The output vector is formed by taking +# successive pixels from either of the two input vectors, based on the value +# of the integer (boolean) selection vectors. Used to implement vector +# conditional expressions. + +procedure aseli (a, b, c, sel, npix) + +int a[ARB], b[ARB], c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b[i] +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b[i] +end diff --git a/sys/vops/lz/aselkc.x b/sys/vops/lz/aselkc.x new file mode 100644 index 00000000..28b5d4a2 --- /dev/null +++ b/sys/vops/lz/aselkc.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASELK -- Vector/constant select element. The output vector is formed by +# taking successive pixels from either of the input vector or a constant, based +# on the value of the integer (boolean) selection vectors. Used to implement +# vector conditional expressions. + +procedure aselkc (a, b, c, sel, npix) + +char a[ARB], b, c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b +end diff --git a/sys/vops/lz/aselkd.x b/sys/vops/lz/aselkd.x new file mode 100644 index 00000000..f0ad7dae --- /dev/null +++ b/sys/vops/lz/aselkd.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASELK -- Vector/constant select element. The output vector is formed by +# taking successive pixels from either of the input vector or a constant, based +# on the value of the integer (boolean) selection vectors. Used to implement +# vector conditional expressions. + +procedure aselkd (a, b, c, sel, npix) + +double a[ARB], b, c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b +end diff --git a/sys/vops/lz/aselki.x b/sys/vops/lz/aselki.x new file mode 100644 index 00000000..a56737ab --- /dev/null +++ b/sys/vops/lz/aselki.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASELK -- Vector/constant select element. The output vector is formed by +# taking successive pixels from either of the input vector or a constant, based +# on the value of the integer (boolean) selection vectors. Used to implement +# vector conditional expressions. + +procedure aselki (a, b, c, sel, npix) + +int a[ARB], b, c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b +end diff --git a/sys/vops/lz/aselkl.x b/sys/vops/lz/aselkl.x new file mode 100644 index 00000000..2fbf6b23 --- /dev/null +++ b/sys/vops/lz/aselkl.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASELK -- Vector/constant select element. The output vector is formed by +# taking successive pixels from either of the input vector or a constant, based +# on the value of the integer (boolean) selection vectors. Used to implement +# vector conditional expressions. + +procedure aselkl (a, b, c, sel, npix) + +long a[ARB], b, c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b +end diff --git a/sys/vops/lz/aselkr.x b/sys/vops/lz/aselkr.x new file mode 100644 index 00000000..702000b3 --- /dev/null +++ b/sys/vops/lz/aselkr.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASELK -- Vector/constant select element. The output vector is formed by +# taking successive pixels from either of the input vector or a constant, based +# on the value of the integer (boolean) selection vectors. Used to implement +# vector conditional expressions. + +procedure aselkr (a, b, c, sel, npix) + +real a[ARB], b, c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b +end diff --git a/sys/vops/lz/aselks.x b/sys/vops/lz/aselks.x new file mode 100644 index 00000000..59891f15 --- /dev/null +++ b/sys/vops/lz/aselks.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASELK -- Vector/constant select element. The output vector is formed by +# taking successive pixels from either of the input vector or a constant, based +# on the value of the integer (boolean) selection vectors. Used to implement +# vector conditional expressions. + +procedure aselks (a, b, c, sel, npix) + +short a[ARB], b, c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b +end diff --git a/sys/vops/lz/aselkx.x b/sys/vops/lz/aselkx.x new file mode 100644 index 00000000..4a4de962 --- /dev/null +++ b/sys/vops/lz/aselkx.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASELK -- Vector/constant select element. The output vector is formed by +# taking successive pixels from either of the input vector or a constant, based +# on the value of the integer (boolean) selection vectors. Used to implement +# vector conditional expressions. + +procedure aselkx (a, b, c, sel, npix) + +complex a[ARB], b, c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b +end diff --git a/sys/vops/lz/asell.x b/sys/vops/lz/asell.x new file mode 100644 index 00000000..5b7e08a7 --- /dev/null +++ b/sys/vops/lz/asell.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASEL -- Vector select element. The output vector is formed by taking +# successive pixels from either of the two input vectors, based on the value +# of the integer (boolean) selection vectors. Used to implement vector +# conditional expressions. + +procedure asell (a, b, c, sel, npix) + +long a[ARB], b[ARB], c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b[i] +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b[i] +end diff --git a/sys/vops/lz/aselr.x b/sys/vops/lz/aselr.x new file mode 100644 index 00000000..3a5f7f1b --- /dev/null +++ b/sys/vops/lz/aselr.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASEL -- Vector select element. The output vector is formed by taking +# successive pixels from either of the two input vectors, based on the value +# of the integer (boolean) selection vectors. Used to implement vector +# conditional expressions. + +procedure aselr (a, b, c, sel, npix) + +real a[ARB], b[ARB], c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b[i] +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b[i] +end diff --git a/sys/vops/lz/asels.x b/sys/vops/lz/asels.x new file mode 100644 index 00000000..b2118ba8 --- /dev/null +++ b/sys/vops/lz/asels.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASEL -- Vector select element. The output vector is formed by taking +# successive pixels from either of the two input vectors, based on the value +# of the integer (boolean) selection vectors. Used to implement vector +# conditional expressions. + +procedure asels (a, b, c, sel, npix) + +short a[ARB], b[ARB], c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b[i] +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b[i] +end diff --git a/sys/vops/lz/aselx.x b/sys/vops/lz/aselx.x new file mode 100644 index 00000000..1bd02e9a --- /dev/null +++ b/sys/vops/lz/aselx.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASEL -- Vector select element. The output vector is formed by taking +# successive pixels from either of the two input vectors, based on the value +# of the integer (boolean) selection vectors. Used to implement vector +# conditional expressions. + +procedure aselx (a, b, c, sel, npix) + +complex a[ARB], b[ARB], c[ARB] +int sel[ARB] # IF sel[i] THEN a[i] ELSE b[i] +int npix +int i + +begin + do i = 1, npix + if (sel[i] != 0) + c[i] = a[i] + else + c[i] = b[i] +end diff --git a/sys/vops/lz/asokc.x b/sys/vops/lz/asokc.x new file mode 100644 index 00000000..794252f2 --- /dev/null +++ b/sys/vops/lz/asokc.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ASOK -- Select the Kth smallest element from a vector. The algorithm used +# is selection by tail recursion (Gonnet 1984). In each iteration a pivot key +# is selected (somewhat arbitrarily) from the array. The array is then split +# into two subarrays, those with key values less than or equal to the pivot key +# and those with values greater than the pivot. The size of the two subarrays +# determines which contains the median value, and the process is repeated +# on that subarray, and so on until all of the elements of the subarray +# are equal, e.g., there is only one element left in the subarray. For a +# randomly ordered array the expected running time is O(3.38N). The selection +# is carried out in place, leaving the array in a partially ordered state. +# +# N.B.: Behaviour is O(N) if the input array is sorted. +# N.B.: The cases ksel=1 and ksel=npix, i.e., selection of the minimum and +# maximum values, are more efficiently handled by ALIM which is O(2N). +# +# Jul99 - The above algorithm was found to be pathologically slow in cases +# where many or all elements of the array are equal. The version of the +# algorithm below, from Wirth, appears to avoid this problem. + +char procedure asokc (a, npix, ksel) + +char a[ARB] # input array +int npix # number of pixels +int ksel # element to be selected + +int lo, up, i, j, k, dummy +char temp, wtemp + +begin + lo = 1 + up = npix + k = max (lo, min (up, ksel)) + + # while (lo < up) + do dummy = 1, MAX_INT { + if (! (lo < up)) + break + + temp = a[k]; i = lo; j = up + + repeat { + while (a[i] < temp) + i = i + 1 + while (temp < a[j]) + j = j - 1 + if (i <= j) { + wtemp = a[i]; a[i] = a[j]; a[j] = wtemp + i = i + 1; j = j - 1 + } + } until (i > j) + + if (j < k) + lo = i + if (k < i) + up = j + } + + return (a[k]) +end diff --git a/sys/vops/lz/asokd.x b/sys/vops/lz/asokd.x new file mode 100644 index 00000000..54627469 --- /dev/null +++ b/sys/vops/lz/asokd.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ASOK -- Select the Kth smallest element from a vector. The algorithm used +# is selection by tail recursion (Gonnet 1984). In each iteration a pivot key +# is selected (somewhat arbitrarily) from the array. The array is then split +# into two subarrays, those with key values less than or equal to the pivot key +# and those with values greater than the pivot. The size of the two subarrays +# determines which contains the median value, and the process is repeated +# on that subarray, and so on until all of the elements of the subarray +# are equal, e.g., there is only one element left in the subarray. For a +# randomly ordered array the expected running time is O(3.38N). The selection +# is carried out in place, leaving the array in a partially ordered state. +# +# N.B.: Behaviour is O(N) if the input array is sorted. +# N.B.: The cases ksel=1 and ksel=npix, i.e., selection of the minimum and +# maximum values, are more efficiently handled by ALIM which is O(2N). +# +# Jul99 - The above algorithm was found to be pathologically slow in cases +# where many or all elements of the array are equal. The version of the +# algorithm below, from Wirth, appears to avoid this problem. + +double procedure asokd (a, npix, ksel) + +double a[ARB] # input array +int npix # number of pixels +int ksel # element to be selected + +int lo, up, i, j, k, dummy +double temp, wtemp + +begin + lo = 1 + up = npix + k = max (lo, min (up, ksel)) + + # while (lo < up) + do dummy = 1, MAX_INT { + if (! (lo < up)) + break + + temp = a[k]; i = lo; j = up + + repeat { + while (a[i] < temp) + i = i + 1 + while (temp < a[j]) + j = j - 1 + if (i <= j) { + wtemp = a[i]; a[i] = a[j]; a[j] = wtemp + i = i + 1; j = j - 1 + } + } until (i > j) + + if (j < k) + lo = i + if (k < i) + up = j + } + + return (a[k]) +end diff --git a/sys/vops/lz/asoki.x b/sys/vops/lz/asoki.x new file mode 100644 index 00000000..dd579ac2 --- /dev/null +++ b/sys/vops/lz/asoki.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ASOK -- Select the Kth smallest element from a vector. The algorithm used +# is selection by tail recursion (Gonnet 1984). In each iteration a pivot key +# is selected (somewhat arbitrarily) from the array. The array is then split +# into two subarrays, those with key values less than or equal to the pivot key +# and those with values greater than the pivot. The size of the two subarrays +# determines which contains the median value, and the process is repeated +# on that subarray, and so on until all of the elements of the subarray +# are equal, e.g., there is only one element left in the subarray. For a +# randomly ordered array the expected running time is O(3.38N). The selection +# is carried out in place, leaving the array in a partially ordered state. +# +# N.B.: Behaviour is O(N) if the input array is sorted. +# N.B.: The cases ksel=1 and ksel=npix, i.e., selection of the minimum and +# maximum values, are more efficiently handled by ALIM which is O(2N). +# +# Jul99 - The above algorithm was found to be pathologically slow in cases +# where many or all elements of the array are equal. The version of the +# algorithm below, from Wirth, appears to avoid this problem. + +int procedure asoki (a, npix, ksel) + +int a[ARB] # input array +int npix # number of pixels +int ksel # element to be selected + +int lo, up, i, j, k, dummy +int temp, wtemp + +begin + lo = 1 + up = npix + k = max (lo, min (up, ksel)) + + # while (lo < up) + do dummy = 1, MAX_INT { + if (! (lo < up)) + break + + temp = a[k]; i = lo; j = up + + repeat { + while (a[i] < temp) + i = i + 1 + while (temp < a[j]) + j = j - 1 + if (i <= j) { + wtemp = a[i]; a[i] = a[j]; a[j] = wtemp + i = i + 1; j = j - 1 + } + } until (i > j) + + if (j < k) + lo = i + if (k < i) + up = j + } + + return (a[k]) +end diff --git a/sys/vops/lz/asokl.x b/sys/vops/lz/asokl.x new file mode 100644 index 00000000..37adff9c --- /dev/null +++ b/sys/vops/lz/asokl.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ASOK -- Select the Kth smallest element from a vector. The algorithm used +# is selection by tail recursion (Gonnet 1984). In each iteration a pivot key +# is selected (somewhat arbitrarily) from the array. The array is then split +# into two subarrays, those with key values less than or equal to the pivot key +# and those with values greater than the pivot. The size of the two subarrays +# determines which contains the median value, and the process is repeated +# on that subarray, and so on until all of the elements of the subarray +# are equal, e.g., there is only one element left in the subarray. For a +# randomly ordered array the expected running time is O(3.38N). The selection +# is carried out in place, leaving the array in a partially ordered state. +# +# N.B.: Behaviour is O(N) if the input array is sorted. +# N.B.: The cases ksel=1 and ksel=npix, i.e., selection of the minimum and +# maximum values, are more efficiently handled by ALIM which is O(2N). +# +# Jul99 - The above algorithm was found to be pathologically slow in cases +# where many or all elements of the array are equal. The version of the +# algorithm below, from Wirth, appears to avoid this problem. + +long procedure asokl (a, npix, ksel) + +long a[ARB] # input array +int npix # number of pixels +int ksel # element to be selected + +int lo, up, i, j, k, dummy +long temp, wtemp + +begin + lo = 1 + up = npix + k = max (lo, min (up, ksel)) + + # while (lo < up) + do dummy = 1, MAX_INT { + if (! (lo < up)) + break + + temp = a[k]; i = lo; j = up + + repeat { + while (a[i] < temp) + i = i + 1 + while (temp < a[j]) + j = j - 1 + if (i <= j) { + wtemp = a[i]; a[i] = a[j]; a[j] = wtemp + i = i + 1; j = j - 1 + } + } until (i > j) + + if (j < k) + lo = i + if (k < i) + up = j + } + + return (a[k]) +end diff --git a/sys/vops/lz/asokr.x b/sys/vops/lz/asokr.x new file mode 100644 index 00000000..420eaf65 --- /dev/null +++ b/sys/vops/lz/asokr.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ASOK -- Select the Kth smallest element from a vector. The algorithm used +# is selection by tail recursion (Gonnet 1984). In each iteration a pivot key +# is selected (somewhat arbitrarily) from the array. The array is then split +# into two subarrays, those with key values less than or equal to the pivot key +# and those with values greater than the pivot. The size of the two subarrays +# determines which contains the median value, and the process is repeated +# on that subarray, and so on until all of the elements of the subarray +# are equal, e.g., there is only one element left in the subarray. For a +# randomly ordered array the expected running time is O(3.38N). The selection +# is carried out in place, leaving the array in a partially ordered state. +# +# N.B.: Behaviour is O(N) if the input array is sorted. +# N.B.: The cases ksel=1 and ksel=npix, i.e., selection of the minimum and +# maximum values, are more efficiently handled by ALIM which is O(2N). +# +# Jul99 - The above algorithm was found to be pathologically slow in cases +# where many or all elements of the array are equal. The version of the +# algorithm below, from Wirth, appears to avoid this problem. + +real procedure asokr (a, npix, ksel) + +real a[ARB] # input array +int npix # number of pixels +int ksel # element to be selected + +int lo, up, i, j, k, dummy +real temp, wtemp + +begin + lo = 1 + up = npix + k = max (lo, min (up, ksel)) + + # while (lo < up) + do dummy = 1, MAX_INT { + if (! (lo < up)) + break + + temp = a[k]; i = lo; j = up + + repeat { + while (a[i] < temp) + i = i + 1 + while (temp < a[j]) + j = j - 1 + if (i <= j) { + wtemp = a[i]; a[i] = a[j]; a[j] = wtemp + i = i + 1; j = j - 1 + } + } until (i > j) + + if (j < k) + lo = i + if (k < i) + up = j + } + + return (a[k]) +end diff --git a/sys/vops/lz/asoks.x b/sys/vops/lz/asoks.x new file mode 100644 index 00000000..a92f4015 --- /dev/null +++ b/sys/vops/lz/asoks.x @@ -0,0 +1,63 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ASOK -- Select the Kth smallest element from a vector. The algorithm used +# is selection by tail recursion (Gonnet 1984). In each iteration a pivot key +# is selected (somewhat arbitrarily) from the array. The array is then split +# into two subarrays, those with key values less than or equal to the pivot key +# and those with values greater than the pivot. The size of the two subarrays +# determines which contains the median value, and the process is repeated +# on that subarray, and so on until all of the elements of the subarray +# are equal, e.g., there is only one element left in the subarray. For a +# randomly ordered array the expected running time is O(3.38N). The selection +# is carried out in place, leaving the array in a partially ordered state. +# +# N.B.: Behaviour is O(N) if the input array is sorted. +# N.B.: The cases ksel=1 and ksel=npix, i.e., selection of the minimum and +# maximum values, are more efficiently handled by ALIM which is O(2N). +# +# Jul99 - The above algorithm was found to be pathologically slow in cases +# where many or all elements of the array are equal. The version of the +# algorithm below, from Wirth, appears to avoid this problem. + +short procedure asoks (a, npix, ksel) + +short a[ARB] # input array +int npix # number of pixels +int ksel # element to be selected + +int lo, up, i, j, k, dummy +short temp, wtemp + +begin + lo = 1 + up = npix + k = max (lo, min (up, ksel)) + + # while (lo < up) + do dummy = 1, MAX_INT { + if (! (lo < up)) + break + + temp = a[k]; i = lo; j = up + + repeat { + while (a[i] < temp) + i = i + 1 + while (temp < a[j]) + j = j - 1 + if (i <= j) { + wtemp = a[i]; a[i] = a[j]; a[j] = wtemp + i = i + 1; j = j - 1 + } + } until (i > j) + + if (j < k) + lo = i + if (k < i) + up = j + } + + return (a[k]) +end diff --git a/sys/vops/lz/asokx.x b/sys/vops/lz/asokx.x new file mode 100644 index 00000000..7528714a --- /dev/null +++ b/sys/vops/lz/asokx.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ASOK -- Select the Kth smallest element from a vector. The algorithm used +# is selection by tail recursion (Gonnet 1984). In each iteration a pivot key +# is selected (somewhat arbitrarily) from the array. The array is then split +# into two subarrays, those with key values less than or equal to the pivot key +# and those with values greater than the pivot. The size of the two subarrays +# determines which contains the median value, and the process is repeated +# on that subarray, and so on until all of the elements of the subarray +# are equal, e.g., there is only one element left in the subarray. For a +# randomly ordered array the expected running time is O(3.38N). The selection +# is carried out in place, leaving the array in a partially ordered state. +# +# N.B.: Behaviour is O(N) if the input array is sorted. +# N.B.: The cases ksel=1 and ksel=npix, i.e., selection of the minimum and +# maximum values, are more efficiently handled by ALIM which is O(2N). +# +# Jul99 - The above algorithm was found to be pathologically slow in cases +# where many or all elements of the array are equal. The version of the +# algorithm below, from Wirth, appears to avoid this problem. + +complex procedure asokx (a, npix, ksel) + +complex a[ARB] # input array +int npix # number of pixels +int ksel # element to be selected + +int lo, up, i, j, k, dummy +complex temp, wtemp +real abs_temp + +begin + lo = 1 + up = npix + k = max (lo, min (up, ksel)) + + # while (lo < up) + do dummy = 1, MAX_INT { + if (! (lo < up)) + break + + temp = a[k]; i = lo; j = up + abs_temp = abs (temp) + + repeat { + while (abs (a[i]) < abs_temp) + i = i + 1 + while (abs_temp < abs (a[j])) + j = j - 1 + if (i <= j) { + wtemp = a[i]; a[i] = a[j]; a[j] = wtemp + i = i + 1; j = j - 1 + } + } until (i > j) + + if (j < k) + lo = i + if (k < i) + up = j + } + + return (a[k]) +end diff --git a/sys/vops/lz/asqrd.x b/sys/vops/lz/asqrd.x new file mode 100644 index 00000000..e6cf3f70 --- /dev/null +++ b/sys/vops/lz/asqrd.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASQR -- Compute the square root of a vector (generic). If the square root +# is undefined (x < 0) a user supplied function is called to compute the value. + +procedure asqrd (a, b, npix, errfcn) + +double a[ARB], b[ARB] +int npix, i +extern errfcn() +double errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] < 0) + b[i] = errfcn (a[i]) + else + { + b[i] = sqrt (a[i]) + } + } +end diff --git a/sys/vops/lz/asqri.x b/sys/vops/lz/asqri.x new file mode 100644 index 00000000..c68c64f4 --- /dev/null +++ b/sys/vops/lz/asqri.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASQR -- Compute the square root of a vector (generic). If the square root +# is undefined (x < 0) a user supplied function is called to compute the value. + +procedure asqri (a, b, npix, errfcn) + +int a[ARB], b[ARB] +int npix, i +extern errfcn() +int errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] < 0) + b[i] = errfcn (a[i]) + else + { + b[i] = sqrt (real (a[i])) + } + } +end diff --git a/sys/vops/lz/asqrl.x b/sys/vops/lz/asqrl.x new file mode 100644 index 00000000..3b0d23f0 --- /dev/null +++ b/sys/vops/lz/asqrl.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASQR -- Compute the square root of a vector (generic). If the square root +# is undefined (x < 0) a user supplied function is called to compute the value. + +procedure asqrl (a, b, npix, errfcn) + +long a[ARB], b[ARB] +int npix, i +extern errfcn() +long errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] < 0) + b[i] = errfcn (a[i]) + else + { + b[i] = sqrt (double (a[i])) + } + } +end diff --git a/sys/vops/lz/asqrr.x b/sys/vops/lz/asqrr.x new file mode 100644 index 00000000..a18b21d2 --- /dev/null +++ b/sys/vops/lz/asqrr.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASQR -- Compute the square root of a vector (generic). If the square root +# is undefined (x < 0) a user supplied function is called to compute the value. + +procedure asqrr (a, b, npix, errfcn) + +real a[ARB], b[ARB] +int npix, i +extern errfcn() +real errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] < 0) + b[i] = errfcn (a[i]) + else + { + b[i] = sqrt (a[i]) + } + } +end diff --git a/sys/vops/lz/asqrs.x b/sys/vops/lz/asqrs.x new file mode 100644 index 00000000..5a1d6532 --- /dev/null +++ b/sys/vops/lz/asqrs.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASQR -- Compute the square root of a vector (generic). If the square root +# is undefined (x < 0) a user supplied function is called to compute the value. + +procedure asqrs (a, b, npix, errfcn) + +short a[ARB], b[ARB] +int npix, i +extern errfcn() +short errfcn() +errchk errfcn + +begin + do i = 1, npix { + if (a[i] < 0) + b[i] = errfcn (a[i]) + else + { + b[i] = sqrt (real (a[i])) + } + } +end diff --git a/sys/vops/lz/asqrx.x b/sys/vops/lz/asqrx.x new file mode 100644 index 00000000..a529811c --- /dev/null +++ b/sys/vops/lz/asqrx.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASQR -- Compute the square root of a vector (generic). If the square root +# is undefined (x < 0) a user supplied function is called to compute the value. + +procedure asqrx (a, b, npix, errfcn) + +complex a[ARB], b[ARB] +int npix, i +extern errfcn() +complex errfcn() +errchk errfcn + +begin + do i = 1, npix { + { + b[i] = sqrt (a[i]) + } + } +end diff --git a/sys/vops/lz/asrtc.x b/sys/vops/lz/asrtc.x new file mode 100644 index 00000000..f4de2d71 --- /dev/null +++ b/sys/vops/lz/asrtc.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define LOGPTR 32 # log2(maxpts) (4e9) + +# ASRT -- Vector Quicksort. The output vector may be the same as the +# input vector. + +procedure asrtc (a, b, npix) + +char a[ARB], b[ARB] # input, output arrays +int npix # number of pixels + +char pivot, temp +int i, j, k, p, lv[LOGPTR], uv[LOGPTR] +define swap {temp=$1;$1=$2;$2=temp} + +begin + call amovc (a, b, npix) # in place sort + + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already sorted + # array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]) + pivot = b[j] # pivot line + + while (i < j) { + for (i=i+1; b[i] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (b[j] <= pivot) + break + if (i < j) # out of order pair + swap (b[i], b[j]) # interchange elements + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } +end diff --git a/sys/vops/lz/asrtd.x b/sys/vops/lz/asrtd.x new file mode 100644 index 00000000..64d52880 --- /dev/null +++ b/sys/vops/lz/asrtd.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define LOGPTR 32 # log2(maxpts) (4e9) + +# ASRT -- Vector Quicksort. The output vector may be the same as the +# input vector. + +procedure asrtd (a, b, npix) + +double a[ARB], b[ARB] # input, output arrays +int npix # number of pixels + +double pivot, temp +int i, j, k, p, lv[LOGPTR], uv[LOGPTR] +define swap {temp=$1;$1=$2;$2=temp} + +begin + call amovd (a, b, npix) # in place sort + + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already sorted + # array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]) + pivot = b[j] # pivot line + + while (i < j) { + for (i=i+1; b[i] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (b[j] <= pivot) + break + if (i < j) # out of order pair + swap (b[i], b[j]) # interchange elements + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } +end diff --git a/sys/vops/lz/asrti.x b/sys/vops/lz/asrti.x new file mode 100644 index 00000000..e956a8bd --- /dev/null +++ b/sys/vops/lz/asrti.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define LOGPTR 32 # log2(maxpts) (4e9) + +# ASRT -- Vector Quicksort. The output vector may be the same as the +# input vector. + +procedure asrti (a, b, npix) + +int a[ARB], b[ARB] # input, output arrays +int npix # number of pixels + +int pivot, temp +int i, j, k, p, lv[LOGPTR], uv[LOGPTR] +define swap {temp=$1;$1=$2;$2=temp} + +begin + call amovi (a, b, npix) # in place sort + + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already sorted + # array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]) + pivot = b[j] # pivot line + + while (i < j) { + for (i=i+1; b[i] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (b[j] <= pivot) + break + if (i < j) # out of order pair + swap (b[i], b[j]) # interchange elements + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } +end diff --git a/sys/vops/lz/asrtl.x b/sys/vops/lz/asrtl.x new file mode 100644 index 00000000..ddc1c59b --- /dev/null +++ b/sys/vops/lz/asrtl.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define LOGPTR 32 # log2(maxpts) (4e9) + +# ASRT -- Vector Quicksort. The output vector may be the same as the +# input vector. + +procedure asrtl (a, b, npix) + +long a[ARB], b[ARB] # input, output arrays +int npix # number of pixels + +long pivot, temp +int i, j, k, p, lv[LOGPTR], uv[LOGPTR] +define swap {temp=$1;$1=$2;$2=temp} + +begin + call amovl (a, b, npix) # in place sort + + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already sorted + # array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]) + pivot = b[j] # pivot line + + while (i < j) { + for (i=i+1; b[i] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (b[j] <= pivot) + break + if (i < j) # out of order pair + swap (b[i], b[j]) # interchange elements + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } +end diff --git a/sys/vops/lz/asrtr.x b/sys/vops/lz/asrtr.x new file mode 100644 index 00000000..a4be1ed2 --- /dev/null +++ b/sys/vops/lz/asrtr.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define LOGPTR 32 # log2(maxpts) (4e9) + +# ASRT -- Vector Quicksort. The output vector may be the same as the +# input vector. + +procedure asrtr (a, b, npix) + +real a[ARB], b[ARB] # input, output arrays +int npix # number of pixels + +real pivot, temp +int i, j, k, p, lv[LOGPTR], uv[LOGPTR] +define swap {temp=$1;$1=$2;$2=temp} + +begin + call amovr (a, b, npix) # in place sort + + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already sorted + # array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]) + pivot = b[j] # pivot line + + while (i < j) { + for (i=i+1; b[i] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (b[j] <= pivot) + break + if (i < j) # out of order pair + swap (b[i], b[j]) # interchange elements + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } +end diff --git a/sys/vops/lz/asrts.x b/sys/vops/lz/asrts.x new file mode 100644 index 00000000..b0bff6e6 --- /dev/null +++ b/sys/vops/lz/asrts.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define LOGPTR 32 # log2(maxpts) (4e9) + +# ASRT -- Vector Quicksort. The output vector may be the same as the +# input vector. + +procedure asrts (a, b, npix) + +short a[ARB], b[ARB] # input, output arrays +int npix # number of pixels + +short pivot, temp +int i, j, k, p, lv[LOGPTR], uv[LOGPTR] +define swap {temp=$1;$1=$2;$2=temp} + +begin + call amovs (a, b, npix) # in place sort + + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already sorted + # array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]) + pivot = b[j] # pivot line + + while (i < j) { + for (i=i+1; b[i] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (b[j] <= pivot) + break + if (i < j) # out of order pair + swap (b[i], b[j]) # interchange elements + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } +end diff --git a/sys/vops/lz/asrtx.x b/sys/vops/lz/asrtx.x new file mode 100644 index 00000000..7e0c421b --- /dev/null +++ b/sys/vops/lz/asrtx.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define LOGPTR 32 # log2(maxpts) (4e9) + +# ASRT -- Vector Quicksort. The output vector may be the same as the +# input vector. + +procedure asrtx (a, b, npix) + +complex a[ARB], b[ARB] # input, output arrays +int npix # number of pixels + +complex pivot, temp +int i, j, k, p, lv[LOGPTR], uv[LOGPTR] +define swap {temp=$1;$1=$2;$2=temp} + +begin + call amovx (a, b, npix) # in place sort + + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already sorted + # array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]) + pivot = b[j] # pivot line + + while (i < j) { + for (i=i+1; abs(b[i]) < abs(pivot); i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (abs(b[j]) <= abs(pivot)) + break + if (i < j) # out of order pair + swap (b[i], b[j]) # interchange elements + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } +end diff --git a/sys/vops/lz/assqd.x b/sys/vops/lz/assqd.x new file mode 100644 index 00000000..ec8d4190 --- /dev/null +++ b/sys/vops/lz/assqd.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASSQ -- Vector sum of squares. + +double procedure assqd (a, npix) +double sum + +double a[ARB] +int npix +int i + +begin + sum = 0.0D0 + do i = 1, npix + sum = sum + (a[i] ** 2) + + return (sum) +end diff --git a/sys/vops/lz/assqi.x b/sys/vops/lz/assqi.x new file mode 100644 index 00000000..73091f16 --- /dev/null +++ b/sys/vops/lz/assqi.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASSQ -- Vector sum of squares. + +real procedure assqi (a, npix) +real sum + +int a[ARB] +int npix +int i + +begin + sum = 0 + do i = 1, npix + sum = sum + (a[i] ** 2) + + return (sum) +end diff --git a/sys/vops/lz/assql.x b/sys/vops/lz/assql.x new file mode 100644 index 00000000..096f9a76 --- /dev/null +++ b/sys/vops/lz/assql.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASSQ -- Vector sum of squares. + +double procedure assql (a, npix) +double sum + +long a[ARB] +int npix +int i + +begin + sum = 0 + do i = 1, npix + sum = sum + (a[i] ** 2) + + return (sum) +end diff --git a/sys/vops/lz/assqr.x b/sys/vops/lz/assqr.x new file mode 100644 index 00000000..ffb83e57 --- /dev/null +++ b/sys/vops/lz/assqr.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASSQ -- Vector sum of squares. + +real procedure assqr (a, npix) +real sum + +real a[ARB] +int npix +int i + +begin + sum = 0.0 + do i = 1, npix + sum = sum + (a[i] ** 2) + + return (sum) +end diff --git a/sys/vops/lz/assqs.x b/sys/vops/lz/assqs.x new file mode 100644 index 00000000..094f9285 --- /dev/null +++ b/sys/vops/lz/assqs.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASSQ -- Vector sum of squares. + +real procedure assqs (a, npix) +real sum + +short a[ARB] +int npix +int i + +begin + sum = 0 + do i = 1, npix + sum = sum + (a[i] ** 2) + + return (sum) +end diff --git a/sys/vops/lz/assqx.x b/sys/vops/lz/assqx.x new file mode 100644 index 00000000..adf4edb0 --- /dev/null +++ b/sys/vops/lz/assqx.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASSQ -- Vector sum of squares. + +complex procedure assqx (a, npix) +complex sum + +complex a[ARB] +int npix +int i + +begin + sum = (0.0,0.0) + do i = 1, npix + sum = sum + (a[i] ** 2) + + return (sum) +end diff --git a/sys/vops/lz/asubd.x b/sys/vops/lz/asubd.x new file mode 100644 index 00000000..faa1943a --- /dev/null +++ b/sys/vops/lz/asubd.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUB -- Subtract two vectors (generic). + +procedure asubd (a, b, c, npix) + +double a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] - b[i] +end diff --git a/sys/vops/lz/asubi.x b/sys/vops/lz/asubi.x new file mode 100644 index 00000000..6cecbfe9 --- /dev/null +++ b/sys/vops/lz/asubi.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUB -- Subtract two vectors (generic). + +procedure asubi (a, b, c, npix) + +int a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] - b[i] +end diff --git a/sys/vops/lz/asubkd.x b/sys/vops/lz/asubkd.x new file mode 100644 index 00000000..9eed4999 --- /dev/null +++ b/sys/vops/lz/asubkd.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUBK -- Subtract a constant from a vector (generic). + +procedure asubkd (a, b, c, npix) + +double a[ARB] +double b +double c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] - b +end diff --git a/sys/vops/lz/asubki.x b/sys/vops/lz/asubki.x new file mode 100644 index 00000000..944e4af0 --- /dev/null +++ b/sys/vops/lz/asubki.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUBK -- Subtract a constant from a vector (generic). + +procedure asubki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] - b +end diff --git a/sys/vops/lz/asubkl.x b/sys/vops/lz/asubkl.x new file mode 100644 index 00000000..7d6a7ce9 --- /dev/null +++ b/sys/vops/lz/asubkl.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUBK -- Subtract a constant from a vector (generic). + +procedure asubkl (a, b, c, npix) + +long a[ARB] +long b +long c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] - b +end diff --git a/sys/vops/lz/asubkr.x b/sys/vops/lz/asubkr.x new file mode 100644 index 00000000..c9a303ff --- /dev/null +++ b/sys/vops/lz/asubkr.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUBK -- Subtract a constant from a vector (generic). + +procedure asubkr (a, b, c, npix) + +real a[ARB] +real b +real c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] - b +end diff --git a/sys/vops/lz/asubks.x b/sys/vops/lz/asubks.x new file mode 100644 index 00000000..e0eb9d66 --- /dev/null +++ b/sys/vops/lz/asubks.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUBK -- Subtract a constant from a vector (generic). + +procedure asubks (a, b, c, npix) + +short a[ARB] +short b +short c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] - b +end diff --git a/sys/vops/lz/asubkx.x b/sys/vops/lz/asubkx.x new file mode 100644 index 00000000..4c9f5280 --- /dev/null +++ b/sys/vops/lz/asubkx.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUBK -- Subtract a constant from a vector (generic). + +procedure asubkx (a, b, c, npix) + +complex a[ARB] +complex b +complex c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] - b +end diff --git a/sys/vops/lz/asubl.x b/sys/vops/lz/asubl.x new file mode 100644 index 00000000..851f988b --- /dev/null +++ b/sys/vops/lz/asubl.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUB -- Subtract two vectors (generic). + +procedure asubl (a, b, c, npix) + +long a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] - b[i] +end diff --git a/sys/vops/lz/asubr.x b/sys/vops/lz/asubr.x new file mode 100644 index 00000000..6ad54ba4 --- /dev/null +++ b/sys/vops/lz/asubr.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUB -- Subtract two vectors (generic). + +procedure asubr (a, b, c, npix) + +real a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] - b[i] +end diff --git a/sys/vops/lz/asubs.x b/sys/vops/lz/asubs.x new file mode 100644 index 00000000..6a2a5ddb --- /dev/null +++ b/sys/vops/lz/asubs.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUB -- Subtract two vectors (generic). + +procedure asubs (a, b, c, npix) + +short a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] - b[i] +end diff --git a/sys/vops/lz/asubx.x b/sys/vops/lz/asubx.x new file mode 100644 index 00000000..7694aa7c --- /dev/null +++ b/sys/vops/lz/asubx.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUB -- Subtract two vectors (generic). + +procedure asubx (a, b, c, npix) + +complex a[ARB], b[ARB], c[ARB] +int npix, i + +begin + do i = 1, npix + c[i] = a[i] - b[i] +end diff --git a/sys/vops/lz/asumd.x b/sys/vops/lz/asumd.x new file mode 100644 index 00000000..24e4e7a9 --- /dev/null +++ b/sys/vops/lz/asumd.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUM -- Vector sum. Take care to prevent integer overflow by returning +# a floating point sum. + +double procedure asumd (a, npix) + +double a[ARB] +int npix +int i + +double sum + +begin + sum = 0.0D0 + do i = 1, npix + sum = sum + a[i] + + return (sum) +end diff --git a/sys/vops/lz/asumi.x b/sys/vops/lz/asumi.x new file mode 100644 index 00000000..314b100f --- /dev/null +++ b/sys/vops/lz/asumi.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUM -- Vector sum. Take care to prevent integer overflow by returning +# a floating point sum. + +real procedure asumi (a, npix) + +int a[ARB] +int npix +int i + +real sum + +begin + sum = 0 + do i = 1, npix + sum = sum + a[i] + + return (sum) +end diff --git a/sys/vops/lz/asuml.x b/sys/vops/lz/asuml.x new file mode 100644 index 00000000..4a2f9ec1 --- /dev/null +++ b/sys/vops/lz/asuml.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUM -- Vector sum. Take care to prevent integer overflow by returning +# a floating point sum. + +double procedure asuml (a, npix) + +long a[ARB] +int npix +int i + +double sum + +begin + sum = 0 + do i = 1, npix + sum = sum + a[i] + + return (sum) +end diff --git a/sys/vops/lz/asumr.x b/sys/vops/lz/asumr.x new file mode 100644 index 00000000..962be9cc --- /dev/null +++ b/sys/vops/lz/asumr.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUM -- Vector sum. Take care to prevent integer overflow by returning +# a floating point sum. + +real procedure asumr (a, npix) + +real a[ARB] +int npix +int i + +real sum + +begin + sum = 0.0 + do i = 1, npix + sum = sum + a[i] + + return (sum) +end diff --git a/sys/vops/lz/asums.x b/sys/vops/lz/asums.x new file mode 100644 index 00000000..663dab08 --- /dev/null +++ b/sys/vops/lz/asums.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUM -- Vector sum. Take care to prevent integer overflow by returning +# a floating point sum. + +real procedure asums (a, npix) + +short a[ARB] +int npix +int i + +real sum + +begin + sum = 0 + do i = 1, npix + sum = sum + a[i] + + return (sum) +end diff --git a/sys/vops/lz/asumx.x b/sys/vops/lz/asumx.x new file mode 100644 index 00000000..936cdaf3 --- /dev/null +++ b/sys/vops/lz/asumx.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ASUM -- Vector sum. Take care to prevent integer overflow by returning +# a floating point sum. + +complex procedure asumx (a, npix) + +complex a[ARB] +int npix +int i + +complex sum + +begin + sum = (0.0,0.0) + do i = 1, npix + sum = sum + a[i] + + return (sum) +end diff --git a/sys/vops/lz/aupxd.x b/sys/vops/lz/aupxd.x new file mode 100644 index 00000000..38e9fa53 --- /dev/null +++ b/sys/vops/lz/aupxd.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AUPX -- Unpack the real and imaginary components of a complex vector into +# two output vectors of some other type. + +procedure aupxd (a, b, c, npix) + +complex a[ARB] # input vector +double b[ARB], c[ARB] # output vectors +int npix +int i + +begin + do i = 1, npix { + b[i] = real (a[i]) + c[i] = aimag (a[i]) + } +end diff --git a/sys/vops/lz/aupxi.x b/sys/vops/lz/aupxi.x new file mode 100644 index 00000000..59e76ced --- /dev/null +++ b/sys/vops/lz/aupxi.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AUPX -- Unpack the real and imaginary components of a complex vector into +# two output vectors of some other type. + +procedure aupxi (a, b, c, npix) + +complex a[ARB] # input vector +int b[ARB], c[ARB] # output vectors +int npix +int i + +begin + do i = 1, npix { + b[i] = real (a[i]) + c[i] = aimag (a[i]) + } +end diff --git a/sys/vops/lz/aupxl.x b/sys/vops/lz/aupxl.x new file mode 100644 index 00000000..96147678 --- /dev/null +++ b/sys/vops/lz/aupxl.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AUPX -- Unpack the real and imaginary components of a complex vector into +# two output vectors of some other type. + +procedure aupxl (a, b, c, npix) + +complex a[ARB] # input vector +long b[ARB], c[ARB] # output vectors +int npix +int i + +begin + do i = 1, npix { + b[i] = real (a[i]) + c[i] = aimag (a[i]) + } +end diff --git a/sys/vops/lz/aupxr.x b/sys/vops/lz/aupxr.x new file mode 100644 index 00000000..135683fe --- /dev/null +++ b/sys/vops/lz/aupxr.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AUPX -- Unpack the real and imaginary components of a complex vector into +# two output vectors of some other type. + +procedure aupxr (a, b, c, npix) + +complex a[ARB] # input vector +real b[ARB], c[ARB] # output vectors +int npix +int i + +begin + do i = 1, npix { + b[i] = real (a[i]) + c[i] = aimag (a[i]) + } +end diff --git a/sys/vops/lz/aupxs.x b/sys/vops/lz/aupxs.x new file mode 100644 index 00000000..82996096 --- /dev/null +++ b/sys/vops/lz/aupxs.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AUPX -- Unpack the real and imaginary components of a complex vector into +# two output vectors of some other type. + +procedure aupxs (a, b, c, npix) + +complex a[ARB] # input vector +short b[ARB], c[ARB] # output vectors +int npix +int i + +begin + do i = 1, npix { + b[i] = real (a[i]) + c[i] = aimag (a[i]) + } +end diff --git a/sys/vops/lz/aupxx.x b/sys/vops/lz/aupxx.x new file mode 100644 index 00000000..109bdc01 --- /dev/null +++ b/sys/vops/lz/aupxx.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AUPX -- Unpack the real and imaginary components of a complex vector into +# two output vectors of some other type. + +procedure aupxx (a, b, c, npix) + +complex a[ARB] # input vector +complex b[ARB], c[ARB] # output vectors +int npix +int i + +begin + do i = 1, npix { + b[i] = complex (real(a[i]), 0.0) + c[i] = complex (0.0, aimag(a[i])) + } +end diff --git a/sys/vops/lz/aveqc.x b/sys/vops/lz/aveqc.x new file mode 100644 index 00000000..e8d07db1 --- /dev/null +++ b/sys/vops/lz/aveqc.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AVEQ -- Compare two vectors for equality. + +bool procedure aveqc (a, b, npix) + +char a[ARB], b[ARB] #I vectors to be compared +int npix #I number of pixels to be compared + +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + return (false) + + return (true) +end diff --git a/sys/vops/lz/aveqd.x b/sys/vops/lz/aveqd.x new file mode 100644 index 00000000..d67daeb8 --- /dev/null +++ b/sys/vops/lz/aveqd.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AVEQ -- Compare two vectors for equality. + +bool procedure aveqd (a, b, npix) + +double a[ARB], b[ARB] #I vectors to be compared +int npix #I number of pixels to be compared + +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + return (false) + + return (true) +end diff --git a/sys/vops/lz/aveqi.x b/sys/vops/lz/aveqi.x new file mode 100644 index 00000000..913224b4 --- /dev/null +++ b/sys/vops/lz/aveqi.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AVEQ -- Compare two vectors for equality. + +bool procedure aveqi (a, b, npix) + +int a[ARB], b[ARB] #I vectors to be compared +int npix #I number of pixels to be compared + +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + return (false) + + return (true) +end diff --git a/sys/vops/lz/aveql.x b/sys/vops/lz/aveql.x new file mode 100644 index 00000000..ce05898e --- /dev/null +++ b/sys/vops/lz/aveql.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AVEQ -- Compare two vectors for equality. + +bool procedure aveql (a, b, npix) + +long a[ARB], b[ARB] #I vectors to be compared +int npix #I number of pixels to be compared + +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + return (false) + + return (true) +end diff --git a/sys/vops/lz/aveqr.x b/sys/vops/lz/aveqr.x new file mode 100644 index 00000000..01faffe2 --- /dev/null +++ b/sys/vops/lz/aveqr.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AVEQ -- Compare two vectors for equality. + +bool procedure aveqr (a, b, npix) + +real a[ARB], b[ARB] #I vectors to be compared +int npix #I number of pixels to be compared + +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + return (false) + + return (true) +end diff --git a/sys/vops/lz/aveqs.x b/sys/vops/lz/aveqs.x new file mode 100644 index 00000000..92680633 --- /dev/null +++ b/sys/vops/lz/aveqs.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AVEQ -- Compare two vectors for equality. + +bool procedure aveqs (a, b, npix) + +short a[ARB], b[ARB] #I vectors to be compared +int npix #I number of pixels to be compared + +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + return (false) + + return (true) +end diff --git a/sys/vops/lz/aveqx.x b/sys/vops/lz/aveqx.x new file mode 100644 index 00000000..2d616b1a --- /dev/null +++ b/sys/vops/lz/aveqx.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AVEQ -- Compare two vectors for equality. + +bool procedure aveqx (a, b, npix) + +complex a[ARB], b[ARB] #I vectors to be compared +int npix #I number of pixels to be compared + +int i + +begin + do i = 1, npix + if (a[i] != b[i]) + return (false) + + return (true) +end diff --git a/sys/vops/lz/awsud.x b/sys/vops/lz/awsud.x new file mode 100644 index 00000000..f2e5e02e --- /dev/null +++ b/sys/vops/lz/awsud.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AWSU -- Vector weighted sum. C = A * k1 + B * k2 + +procedure awsud (a, b, c, npix, k1, k2) + +double a[ARB], b[ARB], c[ARB] +double k1, k2 +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * k1 + b[i] * k2 +end diff --git a/sys/vops/lz/awsui.x b/sys/vops/lz/awsui.x new file mode 100644 index 00000000..0e75feed --- /dev/null +++ b/sys/vops/lz/awsui.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AWSU -- Vector weighted sum. C = A * k1 + B * k2 + +procedure awsui (a, b, c, npix, k1, k2) + +int a[ARB], b[ARB], c[ARB] +real k1, k2 +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * k1 + b[i] * k2 +end diff --git a/sys/vops/lz/awsul.x b/sys/vops/lz/awsul.x new file mode 100644 index 00000000..1a8dd058 --- /dev/null +++ b/sys/vops/lz/awsul.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AWSU -- Vector weighted sum. C = A * k1 + B * k2 + +procedure awsul (a, b, c, npix, k1, k2) + +long a[ARB], b[ARB], c[ARB] +real k1, k2 +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * k1 + b[i] * k2 +end diff --git a/sys/vops/lz/awsur.x b/sys/vops/lz/awsur.x new file mode 100644 index 00000000..4efd8909 --- /dev/null +++ b/sys/vops/lz/awsur.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AWSU -- Vector weighted sum. C = A * k1 + B * k2 + +procedure awsur (a, b, c, npix, k1, k2) + +real a[ARB], b[ARB], c[ARB] +real k1, k2 +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * k1 + b[i] * k2 +end diff --git a/sys/vops/lz/awsus.x b/sys/vops/lz/awsus.x new file mode 100644 index 00000000..78ee5bbf --- /dev/null +++ b/sys/vops/lz/awsus.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AWSU -- Vector weighted sum. C = A * k1 + B * k2 + +procedure awsus (a, b, c, npix, k1, k2) + +short a[ARB], b[ARB], c[ARB] +real k1, k2 +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * k1 + b[i] * k2 +end diff --git a/sys/vops/lz/awsux.x b/sys/vops/lz/awsux.x new file mode 100644 index 00000000..7516bd8b --- /dev/null +++ b/sys/vops/lz/awsux.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AWSU -- Vector weighted sum. C = A * k1 + B * k2 + +procedure awsux (a, b, c, npix, k1, k2) + +complex a[ARB], b[ARB], c[ARB] +complex k1, k2 +int npix, i + +begin + do i = 1, npix + c[i] = a[i] * k1 + b[i] * k2 +end diff --git a/sys/vops/lz/awvgd.x b/sys/vops/lz/awvgd.x new file mode 100644 index 00000000..58b1d87b --- /dev/null +++ b/sys/vops/lz/awvgd.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AWVG -- Compute the mean and standard deviation (sigma) of a sample. Pixels +# whose value lies outside the specified lower and upper limits are not used. +# If the upper and lower limits have the same value (e.g., zero), no limit +# checking is performed. The number of pixels in the sample is returned as the +# function value. + +int procedure awvgd (a, npix, mean, sigma, lcut, hcut) + +double a[ARB] +double mean, sigma, lcut, hcut +double sum, sumsq, value, temp +int npix, i, ngpix + +begin + sum = 0.0 + sumsq = 0.0 + ngpix = 0 + + # Accumulate sum, sum of squares. The test to disable limit checking + # requires numerical equality of two floating point numbers; this should + # be ok since they are used as flags not as numbers (they are not used + # in computations). + + if (hcut == lcut) { + do i = 1, npix { + value = a[i] + sum = sum + value + sumsq = sumsq + value ** 2 + } + ngpix = npix + + } else { + do i = 1, npix { + value = a[i] + if (value >= lcut && value <= hcut) { + ngpix = ngpix + 1 + sum = sum + value + sumsq = sumsq + value ** 2 + } + } + } + + switch (ngpix) { # compute mean and sigma + case 0: + mean = INDEFD + sigma = INDEFD + case 1: + mean = sum + sigma = INDEFD + default: + mean = sum / ngpix + temp = (sumsq - (sum/ngpix) * sum) / (ngpix - 1) + if (temp < 0) # possible with roundoff error + sigma = 0.0 + else + sigma = sqrt (temp) + } + + return (ngpix) +end diff --git a/sys/vops/lz/awvgi.x b/sys/vops/lz/awvgi.x new file mode 100644 index 00000000..b1e78ebe --- /dev/null +++ b/sys/vops/lz/awvgi.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AWVG -- Compute the mean and standard deviation (sigma) of a sample. Pixels +# whose value lies outside the specified lower and upper limits are not used. +# If the upper and lower limits have the same value (e.g., zero), no limit +# checking is performed. The number of pixels in the sample is returned as the +# function value. + +int procedure awvgi (a, npix, mean, sigma, lcut, hcut) + +int a[ARB] +real mean, sigma, lcut, hcut +double sum, sumsq, value, temp +int npix, i, ngpix + +begin + sum = 0.0 + sumsq = 0.0 + ngpix = 0 + + # Accumulate sum, sum of squares. The test to disable limit checking + # requires numerical equality of two floating point numbers; this should + # be ok since they are used as flags not as numbers (they are not used + # in computations). + + if (hcut == lcut) { + do i = 1, npix { + value = a[i] + sum = sum + value + sumsq = sumsq + value ** 2 + } + ngpix = npix + + } else { + do i = 1, npix { + value = a[i] + if (value >= lcut && value <= hcut) { + ngpix = ngpix + 1 + sum = sum + value + sumsq = sumsq + value ** 2 + } + } + } + + switch (ngpix) { # compute mean and sigma + case 0: + mean = INDEFR + sigma = INDEFR + case 1: + mean = sum + sigma = INDEFR + default: + mean = sum / ngpix + temp = (sumsq - (sum/ngpix) * sum) / (ngpix - 1) + if (temp < 0) # possible with roundoff error + sigma = 0.0 + else + sigma = sqrt (temp) + } + + return (ngpix) +end diff --git a/sys/vops/lz/awvgl.x b/sys/vops/lz/awvgl.x new file mode 100644 index 00000000..d56d0a8a --- /dev/null +++ b/sys/vops/lz/awvgl.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AWVG -- Compute the mean and standard deviation (sigma) of a sample. Pixels +# whose value lies outside the specified lower and upper limits are not used. +# If the upper and lower limits have the same value (e.g., zero), no limit +# checking is performed. The number of pixels in the sample is returned as the +# function value. + +int procedure awvgl (a, npix, mean, sigma, lcut, hcut) + +long a[ARB] +double mean, sigma, lcut, hcut +double sum, sumsq, value, temp +int npix, i, ngpix + +begin + sum = 0.0 + sumsq = 0.0 + ngpix = 0 + + # Accumulate sum, sum of squares. The test to disable limit checking + # requires numerical equality of two floating point numbers; this should + # be ok since they are used as flags not as numbers (they are not used + # in computations). + + if (hcut == lcut) { + do i = 1, npix { + value = a[i] + sum = sum + value + sumsq = sumsq + value ** 2 + } + ngpix = npix + + } else { + do i = 1, npix { + value = a[i] + if (value >= lcut && value <= hcut) { + ngpix = ngpix + 1 + sum = sum + value + sumsq = sumsq + value ** 2 + } + } + } + + switch (ngpix) { # compute mean and sigma + case 0: + mean = INDEFD + sigma = INDEFD + case 1: + mean = sum + sigma = INDEFD + default: + mean = sum / ngpix + temp = (sumsq - (sum/ngpix) * sum) / (ngpix - 1) + if (temp < 0) # possible with roundoff error + sigma = 0.0 + else + sigma = sqrt (temp) + } + + return (ngpix) +end diff --git a/sys/vops/lz/awvgr.x b/sys/vops/lz/awvgr.x new file mode 100644 index 00000000..fab5efe7 --- /dev/null +++ b/sys/vops/lz/awvgr.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AWVG -- Compute the mean and standard deviation (sigma) of a sample. Pixels +# whose value lies outside the specified lower and upper limits are not used. +# If the upper and lower limits have the same value (e.g., zero), no limit +# checking is performed. The number of pixels in the sample is returned as the +# function value. + +int procedure awvgr (a, npix, mean, sigma, lcut, hcut) + +real a[ARB] +real mean, sigma, lcut, hcut +double sum, sumsq, value, temp +int npix, i, ngpix + +begin + sum = 0.0 + sumsq = 0.0 + ngpix = 0 + + # Accumulate sum, sum of squares. The test to disable limit checking + # requires numerical equality of two floating point numbers; this should + # be ok since they are used as flags not as numbers (they are not used + # in computations). + + if (hcut == lcut) { + do i = 1, npix { + value = a[i] + sum = sum + value + sumsq = sumsq + value ** 2 + } + ngpix = npix + + } else { + do i = 1, npix { + value = a[i] + if (value >= lcut && value <= hcut) { + ngpix = ngpix + 1 + sum = sum + value + sumsq = sumsq + value ** 2 + } + } + } + + switch (ngpix) { # compute mean and sigma + case 0: + mean = INDEFR + sigma = INDEFR + case 1: + mean = sum + sigma = INDEFR + default: + mean = sum / ngpix + temp = (sumsq - (sum/ngpix) * sum) / (ngpix - 1) + if (temp < 0) # possible with roundoff error + sigma = 0.0 + else + sigma = sqrt (temp) + } + + return (ngpix) +end diff --git a/sys/vops/lz/awvgs.x b/sys/vops/lz/awvgs.x new file mode 100644 index 00000000..8237be56 --- /dev/null +++ b/sys/vops/lz/awvgs.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AWVG -- Compute the mean and standard deviation (sigma) of a sample. Pixels +# whose value lies outside the specified lower and upper limits are not used. +# If the upper and lower limits have the same value (e.g., zero), no limit +# checking is performed. The number of pixels in the sample is returned as the +# function value. + +int procedure awvgs (a, npix, mean, sigma, lcut, hcut) + +short a[ARB] +real mean, sigma, lcut, hcut +double sum, sumsq, value, temp +int npix, i, ngpix + +begin + sum = 0.0 + sumsq = 0.0 + ngpix = 0 + + # Accumulate sum, sum of squares. The test to disable limit checking + # requires numerical equality of two floating point numbers; this should + # be ok since they are used as flags not as numbers (they are not used + # in computations). + + if (hcut == lcut) { + do i = 1, npix { + value = a[i] + sum = sum + value + sumsq = sumsq + value ** 2 + } + ngpix = npix + + } else { + do i = 1, npix { + value = a[i] + if (value >= lcut && value <= hcut) { + ngpix = ngpix + 1 + sum = sum + value + sumsq = sumsq + value ** 2 + } + } + } + + switch (ngpix) { # compute mean and sigma + case 0: + mean = INDEFR + sigma = INDEFR + case 1: + mean = sum + sigma = INDEFR + default: + mean = sum / ngpix + temp = (sumsq - (sum/ngpix) * sum) / (ngpix - 1) + if (temp < 0) # possible with roundoff error + sigma = 0.0 + else + sigma = sqrt (temp) + } + + return (ngpix) +end diff --git a/sys/vops/lz/awvgx.x b/sys/vops/lz/awvgx.x new file mode 100644 index 00000000..82fe4192 --- /dev/null +++ b/sys/vops/lz/awvgx.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AWVG -- Compute the mean and standard deviation (sigma) of a sample. Pixels +# whose value lies outside the specified lower and upper limits are not used. +# If the upper and lower limits have the same value (e.g., zero), no limit +# checking is performed. The number of pixels in the sample is returned as the +# function value. + +int procedure awvgx (a, npix, mean, sigma, lcut, hcut) + +complex a[ARB] +real mean, sigma, lcut, hcut +double sum, sumsq, value, temp +int npix, i, ngpix + +begin + sum = 0.0 + sumsq = 0.0 + ngpix = 0 + + # Accumulate sum, sum of squares. The test to disable limit checking + # requires numerical equality of two floating point numbers; this should + # be ok since they are used as flags not as numbers (they are not used + # in computations). + + if (hcut == lcut) { + do i = 1, npix { + value = abs (a[i]) + sum = sum + value + sumsq = sumsq + value ** 2 + } + ngpix = npix + + } else { + do i = 1, npix { + value = abs (a[i]) + if (value >= lcut && value <= hcut) { + ngpix = ngpix + 1 + sum = sum + value + sumsq = sumsq + value ** 2 + } + } + } + + switch (ngpix) { # compute mean and sigma + case 0: + mean = INDEFR + sigma = INDEFR + case 1: + mean = sum + sigma = INDEFR + default: + mean = sum / ngpix + temp = (sumsq - (sum/ngpix) * sum) / (ngpix - 1) + if (temp < 0) # possible with roundoff error + sigma = 0.0 + else + sigma = sqrt (temp) + } + + return (ngpix) +end diff --git a/sys/vops/lz/axori.x b/sys/vops/lz/axori.x new file mode 100644 index 00000000..e6df0010 --- /dev/null +++ b/sys/vops/lz/axori.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AXOR -- Compute the exclusive or of two vectors (generic). + +procedure axori (a, b, c, npix) + +int a[ARB], b[ARB], c[ARB] +int npix, i +int xor() + +begin + do i = 1, npix { + c[i] = xor (a[i], b[i]) + } +end diff --git a/sys/vops/lz/axorki.x b/sys/vops/lz/axorki.x new file mode 100644 index 00000000..5e08a769 --- /dev/null +++ b/sys/vops/lz/axorki.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AXORK -- Compute the boolean or of a vector and a constant (generic). + +procedure axorki (a, b, c, npix) + +int a[ARB] +int b +int c[ARB] +int npix, i +int xor() + +begin + do i = 1, npix { + c[i] = xor (a[i], b) + } +end diff --git a/sys/vops/lz/axorkl.x b/sys/vops/lz/axorkl.x new file mode 100644 index 00000000..df4f074f --- /dev/null +++ b/sys/vops/lz/axorkl.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AXORK -- Compute the boolean or of a vector and a constant (generic). + +procedure axorkl (a, b, c, npix) + +long a[ARB] +long b +long c[ARB] +int npix, i +long xorl() + +begin + do i = 1, npix { + c[i] = xorl (a[i], b) + } +end diff --git a/sys/vops/lz/axorks.x b/sys/vops/lz/axorks.x new file mode 100644 index 00000000..d85e283d --- /dev/null +++ b/sys/vops/lz/axorks.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AXORK -- Compute the boolean or of a vector and a constant (generic). + +procedure axorks (a, b, c, npix) + +short a[ARB] +short b +short c[ARB] +int npix, i +short xors() + +begin + do i = 1, npix { + c[i] = xors (a[i], b) + } +end diff --git a/sys/vops/lz/axorl.x b/sys/vops/lz/axorl.x new file mode 100644 index 00000000..d4087fd3 --- /dev/null +++ b/sys/vops/lz/axorl.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AXOR -- Compute the exclusive or of two vectors (generic). + +procedure axorl (a, b, c, npix) + +long a[ARB], b[ARB], c[ARB] +int npix, i +long xorl() + +begin + do i = 1, npix { + c[i] = xorl (a[i], b[i]) + } +end diff --git a/sys/vops/lz/axors.x b/sys/vops/lz/axors.x new file mode 100644 index 00000000..ab3c073d --- /dev/null +++ b/sys/vops/lz/axors.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# AXOR -- Compute the exclusive or of two vectors (generic). + +procedure axors (a, b, c, npix) + +short a[ARB], b[ARB], c[ARB] +int npix, i +short xors() + +begin + do i = 1, npix { + c[i] = xors (a[i], b[i]) + } +end diff --git a/sys/vops/lz/mkpkg b/sys/vops/lz/mkpkg new file mode 100644 index 00000000..046aa2b7 --- /dev/null +++ b/sys/vops/lz/mkpkg @@ -0,0 +1,330 @@ +# Make the VOPS vector operators library, procedures a[l-z]*.*. + +$checkout libvops.a lib$ +$update libvops.a +$checkin libvops.a lib$ +$exit + +libvops.a: + alans.x + alani.x + alanl.x + alanks.x + alanki.x + alankl.x + alimc.x + alimd.x + alimi.x + aliml.x + alimr.x + alims.x + alimx.x + allnd.x + allni.x + allnl.x + allnr.x + allns.x + allnx.x + alogd.x + alogi.x + alogl.x + alogr.x + alogs.x + alogx.x + alors.x + alori.x + alorl.x + alorks.x + alorki.x + alorkl.x + alovc.x + alovd.x + alovi.x + alovl.x + alovr.x + alovs.x + alovx.x + altad.x + altai.x + altal.x + altar.x + altas.x + altax.x + altmd.x + altmi.x + altml.x + altmr.x + altms.x + altmx.x + altrd.x + altri.x + altrl.x + altrr.x + altrs.x + altrx.x + aluid.x + aluii.x + aluil.x + aluir.x + aluis.x + alutc.x + alutd.x + aluti.x + alutl.x + alutr.x + aluts.x + amagd.x + amagi.x + amagl.x + amagr.x + amags.x + amagx.x + amapd.x + amapi.x + amapl.x + amapr.x + amaps.x + amaxc.x + amaxd.x + amaxi.x + amaxkc.x + amaxkd.x + amaxki.x + amaxkl.x + amaxkr.x + amaxks.x + amaxkx.x + amaxl.x + amaxr.x + amaxs.x + amaxx.x + amed3c.x + amed3d.x + amed3i.x + amed3l.x + amed3r.x + amed3s.x + amed4c.x + amed4d.x + amed4i.x + amed4l.x + amed4r.x + amed4s.x + amed5c.x + amed5d.x + amed5i.x + amed5l.x + amed5r.x + amed5s.x + amedc.x + amedd.x + amedi.x + amedl.x + amedr.x + ameds.x + amedx.x + amgsd.x + amgsi.x + amgsl.x + amgsr.x + amgss.x + amgsx.x + aminc.x + amind.x + amini.x + aminkc.x + aminkd.x + aminki.x + aminkl.x + aminkr.x + aminks.x + aminkx.x + aminl.x + aminr.x + amins.x + aminx.x + amodd.x + amodi.x + amodkd.x + amodki.x + amodkl.x + amodkr.x + amodks.x + amodl.x + amodr.x + amods.x + amovc.x + amovd.x + amovi.x + amovkc.x + amovkd.x + amovki.x + amovkl.x + amovkr.x + amovks.x + amovkx.x + amovl.x + amovr.x + amovs.x + amovx.x + amuld.x + amuli.x + amulkd.x + amulki.x + amulkl.x + amulkr.x + amulks.x + amulkx.x + amull.x + amulr.x + amuls.x + amulx.x + anegd.x + anegi.x + anegl.x + anegr.x + anegs.x + anegx.x + anoti.x + anotl.x + anots.x + apkxd.x + apkxi.x + apkxl.x + apkxr.x + apkxs.x + apkxx.x + apold.x + apolr.x + apowd.x + apowi.x + apowkd.x + apowki.x + apowkl.x + apowkr.x + apowks.x + apowkx.x + apowl.x + apowr.x + apows.x + apowx.x + aravd.x + aravi.x + aravl.x + aravr.x + aravs.x + aravx.x + arcpd.x + arcpi.x + arcpl.x + arcpr.x + arcps.x + arcpx.x + arczd.x + arczi.x + arczl.x + arczr.x + arczs.x + arczx.x + argtd.x + argti.x + argtl.x + argtr.x + argts.x + argtx.x + arltd.x + arlti.x + arltl.x + arltr.x + arlts.x + arltx.x + aselc.x + aseld.x + aseli.x + asell.x + aselr.x + asels.x + aselx.x + aselkc.x + aselkd.x + aselki.x + aselkl.x + aselkr.x + aselks.x + aselkx.x + asokc.x + asokd.x + asoki.x + asokl.x + asokr.x + asoks.x + asokx.x + asqrd.x + asqri.x + asqrl.x + asqrr.x + asqrs.x + asqrx.x + asrtc.x + asrtd.x + asrti.x + asrtl.x + asrtr.x + asrts.x + asrtx.x + assqd.x + assqi.x + assql.x + assqr.x + assqs.x + assqx.x + asubd.x + asubi.x + asubkd.x + asubki.x + asubkl.x + asubkr.x + asubks.x + asubkx.x + asubl.x + asubr.x + asubs.x + asubx.x + asumd.x + asumi.x + asuml.x + asumr.x + asums.x + asumx.x + aupxd.x + aupxi.x + aupxl.x + aupxr.x + aupxs.x + aupxx.x + aveqc.x + aveqd.x + aveqi.x + aveql.x + aveqr.x + aveqs.x + aveqx.x + awsud.x + awsui.x + awsul.x + awsur.x + awsus.x + awsux.x + awvgd.x + awvgi.x + awvgl.x + awvgr.x + awvgs.x + awvgx.x + axori.x + axorki.x + axorkl.x + axorks.x + axorl.x + axors.x + ; diff --git a/sys/vops/mkpkg b/sys/vops/mkpkg new file mode 100644 index 00000000..f44f2b16 --- /dev/null +++ b/sys/vops/mkpkg @@ -0,0 +1,150 @@ +# Make the VOPS vector operators library. + +$checkout libvops.a lib$ +$update libvops.a +$checkin libvops.a lib$ +$exit + +# Since all of the VOPS procedures in this directory are generic, no actual +# compilation occurs here (except for the two fft routines, which are type +# real only). The generic preprocessor is called to generate the type +# specific family of operators for each generic procedure, placing the output +# files in the subdirectories ak and lz. Since the preprocessed sources are +# permanently kept in the subdirectories, the generic preprocessor is only +# required on the UNIX development system, although it may be available on +# any other system as well. + +tfiles: + $set GA = "$$generic -k -p ak/" + $set GL = "$$generic -k -p lz/" + $set ACHT = "achtc.x achts.x achti.x achtl.x achtr.x achtd.x achtx.x" + + # The acht (change type) procedures are doubly generic and must be + # expanded twice, producing 7*7=49 files as output. + # + # We force this to be regenerated on each platform since there are + # differences in the generated code between 32 and 64-bit platforms. + + $generic -k -t csilrdx acht.gx + $generic -k -p ak/ -t csilrdx $(ACHT) + $delete $(ACHT) + + + # The following files are not generic hence are merely copied to the + # type specific directory. + + $ifolder (ak/acjgx.x, acjgx.x ) $copy acjgx.x ak/acjgx.x $endif + $ifolder (ak/afftrr.x, afftrr.x) $copy afftrr.x ak/afftrr.x $endif + $ifolder (ak/afftrx.x, afftrx.x) $copy afftrx.x ak/afftrx.x $endif + $ifolder (ak/afftxr.x, afftxr.x) $copy afftxr.x ak/afftxr.x $endif + $ifolder (ak/afftxx.x, afftxx.x) $copy afftxx.x ak/afftxx.x $endif + $ifolder (ak/aiftrr.x, aiftrr.x) $copy aiftrr.x ak/aiftrr.x $endif + $ifolder (ak/aiftrx.x, aiftrx.x) $copy aiftrx.x ak/aiftrx.x $endif + $ifolder (ak/aiftxr.x, aiftxr.x) $copy aiftxr.x ak/aiftxr.x $endif + $ifolder (ak/aiftxx.x, aiftxx.x) $copy aiftxx.x ak/aiftxx.x $endif + + # Each of the following generic files is expanded for each of the + # datatypes listed in the -t flag. + + $ifolder (ak/aabsi.x, aabs.gx ) $(GA) -t silrdx aabs.gx $endif + $ifolder (ak/aaddi.x, aadd.gx ) $(GA) -t silrdx aadd.gx $endif + $ifolder (ak/aaddki.x, aaddk.gx) $(GA) -t silrdx aaddk.gx $endif + $ifolder (ak/aandi.x, aand.gx ) $(GA) -t sil aand.gx $endif + $ifolder (ak/aandki.x, aandk.gx) $(GA) -t sil aandk.gx $endif + $ifolder (ak/aavgi.x, aavg.gx ) $(GA) -t silrdx aavg.gx $endif + $ifolder (ak/abavi.x, abav.gx ) $(GA) -t silrdx abav.gx $endif + $ifolder (ak/absui.x, absu.gx ) $(GA) -t silrd absu.gx $endif + $ifolder (ak/abeqi.x, abeq.gx ) $(GA) -t csilrdx abeq.gx $endif + $ifolder (ak/abeqki.x, abeqk.gx) $(GA) -t csilrdx abeqk.gx $endif + $ifolder (ak/abgei.x, abge.gx ) $(GA) -t csilrdx abge.gx $endif + $ifolder (ak/abgeki.x, abgek.gx) $(GA) -t csilrdx abgek.gx $endif + $ifolder (ak/abgti.x, abgt.gx ) $(GA) -t csilrdx abgt.gx $endif + $ifolder (ak/abgtki.x, abgtk.gx) $(GA) -t csilrdx abgtk.gx $endif + $ifolder (ak/ablei.x, able.gx ) $(GA) -t csilrdx able.gx $endif + $ifolder (ak/ableki.x, ablek.gx) $(GA) -t csilrdx ablek.gx $endif + $ifolder (ak/ablti.x, ablt.gx ) $(GA) -t csilrdx ablt.gx $endif + $ifolder (ak/abltki.x, abltk.gx) $(GA) -t csilrdx abltk.gx $endif + $ifolder (ak/abnei.x, abne.gx ) $(GA) -t csilrdx abne.gx $endif + $ifolder (ak/abneki.x, abnek.gx) $(GA) -t csilrdx abnek.gx $endif + $ifolder (ak/abori.x, abor.gx ) $(GA) -t sil abor.gx $endif + $ifolder (ak/aborki.x, abork.gx) $(GA) -t sil abork.gx $endif + $ifolder (ak/aclri.x, aclr.gx ) $(GA) -t csilrdx aclr.gx $endif + $ifolder (ak/acnvi.x, acnv.gx ) $(GA) -t silrd acnv.gx $endif + $ifolder (ak/acnvri.x, acnvr.gx) $(GA) -t silrd acnvr.gx $endif + $ifolder (ak/adivi.x, adiv.gx ) $(GA) -t silrdx adiv.gx $endif + $ifolder (ak/adivki.x, adivk.gx) $(GA) -t silrdx adivk.gx $endif + $ifolder (ak/adoti.x, adot.gx ) $(GA) -t silrdx adot.gx $endif + $ifolder (ak/advzi.x, advz.gx ) $(GA) -t silrdx advz.gx $endif + $ifolder (ak/aexpi.x, aexp.gx ) $(GA) -t silrdx aexp.gx $endif + $ifolder (ak/aexpki.x, aexpk.gx) $(GA) -t silrdx aexpk.gx $endif + $ifolder (ak/aglti.x, aglt.gx ) $(GA) -t csilrdx aglt.gx $endif + $ifolder (ak/ahgmi.x, ahgm.gx ) $(GA) -t csilrd ahgm.gx $endif + $ifolder (ak/ahivi.x, ahiv.gx ) $(GA) -t csilrdx ahiv.gx $endif + $ifolder (ak/aimgi.x, aimg.gx ) $(GA) -t silrd aimg.gx $endif + $ifolder (lz/alani.x, alan.gx ) $(GL) -t sil alan.gx $endif + $ifolder (lz/alanki.x, alank.gx) $(GL) -t sil alank.gx $endif + $ifolder (lz/alimi.x, alim.gx ) $(GL) -t csilrdx alim.gx $endif + $ifolder (lz/allni.x, alln.gx ) $(GL) -t silrdx alln.gx $endif + $ifolder (lz/alogi.x, alog.gx ) $(GL) -t silrdx alog.gx $endif + $ifolder (lz/alori.x, alor.gx ) $(GL) -t sil alor.gx $endif + $ifolder (lz/alorki.x, alork.gx) $(GL) -t sil alork.gx $endif + $ifolder (lz/alovi.x, alov.gx ) $(GL) -t csilrdx alov.gx $endif + $ifolder (lz/altai.x, alta.gx ) $(GL) -t silrdx alta.gx $endif + $ifolder (lz/altmi.x, altm.gx ) $(GL) -t silrdx altm.gx $endif + $ifolder (lz/altri.x, altr.gx ) $(GL) -t silrdx altr.gx $endif + $ifolder (lz/aluii.x, alui.gx ) $(GL) -t silrd alui.gx $endif + $ifolder (lz/aluti.x, alut.gx ) $(GL) -t csilrd alut.gx $endif + $ifolder (lz/amagi.x, amag.gx ) $(GL) -t silrdx amag.gx $endif + $ifolder (lz/amapi.x, amap.gx ) $(GL) -t silrd amap.gx $endif + $ifolder (lz/amaxi.x, amax.gx ) $(GL) -t csilrdx amax.gx $endif + $ifolder (lz/amaxki.x, amaxk.gx) $(GL) -t csilrdx amaxk.gx $endif + $ifolder (lz/amedi.x, amed.gx ) $(GL) -t csilrdx amed.gx $endif + $ifolder (lz/amed3i.x, amed3.gx) $(GL) -t csilrd amed3.gx $endif + $ifolder (lz/amed4i.x, amed4.gx) $(GL) -t csilrd amed4.gx $endif + $ifolder (lz/amed5i.x, amed5.gx) $(GL) -t csilrd amed5.gx $endif + $ifolder (lz/amgsi.x, amgs.gx ) $(GL) -t silrdx amgs.gx $endif + $ifolder (lz/amini.x, amin.gx ) $(GL) -t csilrdx amin.gx $endif + $ifolder (lz/aminki.x, amink.gx) $(GL) -t csilrdx amink.gx $endif + $ifolder (lz/amodi.x, amod.gx ) $(GL) -t silrd amod.gx $endif + $ifolder (lz/amodki.x, amodk.gx) $(GL) -t silrd amodk.gx $endif + $ifolder (lz/amovi.x, amov.gx ) $(GL) -t csilrdx amov.gx $endif + $ifolder (lz/amovki.x, amovk.gx) $(GL) -t csilrdx amovk.gx $endif + $ifolder (lz/amuli.x, amul.gx ) $(GL) -t silrdx amul.gx $endif + $ifolder (lz/amulki.x, amulk.gx) $(GL) -t silrdx amulk.gx $endif + $ifolder (lz/anegi.x, aneg.gx ) $(GL) -t silrdx aneg.gx $endif + $ifolder (lz/anoti.x, anot.gx ) $(GL) -t sil anot.gx $endif + $ifolder (lz/apkxi.x, apkx.gx ) $(GL) -t silrdx apkx.gx $endif + $ifolder (lz/apolr.x, apol.gx ) $(GL) -t rd apol.gx $endif + $ifolder (lz/apowi.x, apow.gx ) $(GL) -t silrdx apow.gx $endif + $ifolder (lz/apowki.x, apowk.gx) $(GL) -t silrdx apowk.gx $endif + $ifolder (lz/aravi.x, arav.gx ) $(GL) -t silrdx arav.gx $endif + $ifolder (lz/arcpi.x, arcp.gx ) $(GL) -t silrdx arcp.gx $endif + $ifolder (lz/arczi.x, arcz.gx ) $(GL) -t silrdx arcz.gx $endif + $ifolder (lz/argti.x, argt.gx ) $(GL) -t silrdx argt.gx $endif + $ifolder (lz/arlti.x, arlt.gx ) $(GL) -t silrdx arlt.gx $endif + $ifolder (lz/aseli.x, asel.gx ) $(GL) -t csilrdx asel.gx $endif + $ifolder (lz/aselki.x, aselk.gx) $(GL) -t csilrdx aselk.gx $endif + $ifolder (lz/asoki.x, asok.gx ) $(GL) -t csilrdx asok.gx $endif + $ifolder (lz/asqri.x, asqr.gx ) $(GL) -t silrdx asqr.gx $endif + $ifolder (lz/asrti.x, asrt.gx ) $(GL) -t csilrdx asrt.gx $endif + $ifolder (lz/assqi.x, assq.gx ) $(GL) -t silrdx assq.gx $endif + $ifolder (lz/asubi.x, asub.gx ) $(GL) -t silrdx asub.gx $endif + $ifolder (lz/asubki.x, asubk.gx) $(GL) -t silrdx asubk.gx $endif + $ifolder (lz/asumi.x, asum.gx ) $(GL) -t silrdx asum.gx $endif + $ifolder (lz/aupxi.x, aupx.gx ) $(GL) -t silrdx aupx.gx $endif + $ifolder (lz/aveqi.x, aveq.gx ) $(GL) -t csilrdx aveq.gx $endif + $ifolder (lz/awsui.x, awsu.gx ) $(GL) -t silrdx awsu.gx $endif + $ifolder (lz/awvgi.x, awvg.gx ) $(GL) -t silrdx awvg.gx $endif + $ifolder (lz/axori.x, axor.gx ) $(GL) -t sil axor.gx $endif + $ifolder (lz/axorki.x, axork.gx) $(GL) -t sil axork.gx $endif + ; + +libvops.a: + $ifeq (USE_GENERIC, yes) $call tfiles $endif + $set XFLAGS = "$(XVFLAGS)" + @ak + @lz + @achtgen # acht conversion matrix + fftr.f + fftx.f + ; diff --git a/sys/vops/vops.calls b/sys/vops/vops.calls new file mode 100644 index 00000000..9798b80b --- /dev/null +++ b/sys/vops/vops.calls @@ -0,0 +1,106 @@ +aabs 3 aabs.gx procedure aabs$t (a, b, npix) +aadd 3 aadd.gx procedure aadd$t (a, b, c, npix) +aaddk 3 aaddk.gx procedure aaddk$t (a, b, c, npix) +aand 3 aand.gx procedure aand$t (a, b, c, npix) +aandk 4 aandk.gx procedure aandk$t (a, b, c, npix) +aavg 4 aavg.gx procedure aavg$t (a, npix, mean, sigma) +abav 5 abav.gx procedure abav$t (a, b, nblocks, npix_per_block) +abeq 4 abeq.gx procedure abeq$t (a, b, c, npix) +abeqk 4 abeqk.gx procedure abeqk$t (a, b, c, npix) +abge 4 abge.gx procedure abge$t (a, b, c, npix) +abgek 4 abgek.gx procedure abgek$t (a, b, c, npix) +abgt 4 abgt.gx procedure abgt$t (a, b, c, npix) +abgtk 4 abgtk.gx procedure abgtk$t (a, b, c, npix) +able 4 able.gx procedure able$t (a, b, c, npix) +ablek 4 ablek.gx procedure ablek$t (a, b, c, npix) +ablt 4 ablt.gx procedure ablt$t (a, b, c, npix) +abltk 4 abltk.gx procedure abltk$t (a, b, c, npix) +abne 4 abne.gx procedure abne$t (a, b, c, npix) +abnek 4 abnek.gx procedure abnek$t (a, b, c, npix) +abor 3 abor.gx procedure abor$t (a, b, c, npix) +abork 4 abork.gx procedure abork$t (a, b, c, npix) +absu 5 absu.gx procedure absu$t (a, b, nblocks, npix_per_block) +acht 5 acht.gx procedure acht$t$$t (a, b, npix) +acjgx 3 acjgx.x procedure acjgx (a, b, npix) +aclr 3 aclr.gx procedure aclr$t (a, npix) +acnv 16 acnv.gx procedure acnv$t (in, out, npix, kernel, knpix) +acnvr 17 acnvr.gx procedure acnvr$t (in, out, npix, kernel, knpix) +adiv 4 adiv.gx procedure adiv$t (a, b, c, npix) +adivk 4 adivk.gx procedure adivk$t (a, b, c, npix) +adot 7 adot.gx real procedure adot$t (a, b, npix) +adot 5 adot.gx double procedure adot$t (a, b, npix) +advz 11 advz.gx procedure advz$t (a, b, c, npix, errfcn) +aexp 3 aexp.gx procedure aexp$t (a, b, c, npix) +aexpk 3 aexpk.gx procedure aexpk$t (a, b, c, npix) +afftrr 8 afftrr.x procedure afftrr (sr, si, fr, fi, npix) +afftrx 16 afftrx.x procedure afftrx (a, b, npix) +afftxr 7 afftxr.x procedure afftxr (sr, si, fr, fi, npix) +afftxx 7 afftxx.x procedure afftxx (a, b, npix) +aglt 6 aglt.gx procedure aglt$t (a,b,npix,low,high,kmul,kadd,nrange) +ahgm 6 ahgm.gx procedure ahgm$t (data, npix, hgm, nbins, z1, z2) +ahiv 3 ahiv.gx PIXEL procedure ahiv$t (a, npix) +aiftrr 8 aiftrr.x procedure aiftrr (fr, fi, sr, si, npix) +aiftrx 14 aiftrx.x procedure aiftrx (a, b, npix) +aiftxr 7 aiftxr.x procedure aiftxr (fr, fi, sr, si, npix) +aiftxx 14 aiftxx.x procedure aiftxx (a, b, npix) +aimg 3 aimg.gx procedure aimg$t (a, b, npix) +alan 3 alan.gx procedure alan$t (a, b, c, npix) +alank 3 alank.gx procedure alank$t (a, b, c, npix) +alor 3 alor.gx procedure alor$t (a, b, c, npix) +alork 3 alork.gx procedure alork$t (a, b, c, npix) +alim 3 alim.gx procedure alim$t (a, npix, minval, maxval) +alln 5 alln.gx procedure alln$t (a, b, npix, errfcn) +alog 5 alog.gx procedure alog$t (a, b, npix, errfcn) +alov 3 alov.gx PIXEL procedure alov$t (a, npix) +alta 4 alta.gx procedure alta$t (a, b, npix, k1, k2) +altm 4 altm.gx procedure altm$t (a, b, npix, k1, k2) +altr 5 altr.gx procedure altr$t (a, b, npix, k1, k2, k3) +alui 10 alui.gx procedure alui$t (a, b, x, npix) +alut 5 alut.gx procedure alut$t (a, b, npix, lut) +amag 3 amag.gx procedure amag$t (a, b, c, npix) +amap 5 amap.gx procedure amap$t (a, b, npix, a1, a2, b1, b2) +amax 3 amax.gx procedure amax$t (a, b, c, npix) +amaxk 3 amaxk.gx procedure amaxk$t (a, b, c, npix) +amed 6 amed.gx PIXEL procedure amed$t (a, npix) +amed3 4 amed3.gx procedure amed3$t (a, b, c, m, npix) +amed4 6 amed4.gx procedure amed4$t (a, b, c, d, m, npix) +amed5 5 amed5.gx procedure amed5$t (a, b, c, d, e, m, npix) +amgs 3 amgs.gx procedure amgs$t (a, b, c, npix) +amin 3 amin.gx procedure amin$t (a, b, c, npix) +amink 3 amink.gx procedure amink$t (a, b, c, npix) +amod 3 amod.gx procedure amod$t (a, b, c, npix) +amodk 3 amodk.gx procedure amodk$t (a, b, c, npix) +amov 5 amov.gx procedure amov$t (a, b, npix) +amovk 3 amovk.gx procedure amovk$t (a, b, npix) +amul 3 amul.gx procedure amul$t (a, b, c, npix) +amulk 3 amulk.gx procedure amulk$t (a, b, c, npix) +aneg 3 aneg.gx procedure aneg$t (a, b, npix) +anot 3 anot.gx procedure anot$t (a, b, npix) +apkx 4 apkx.gx procedure apkx$t (a, b, c, npix) +apol 4 apol.gx PIXEL procedure apol$t (x, coeff, ncoeff) +apow 3 apow.gx procedure apow$t (a, b, c, npix) +apowk 3 apowk.gx procedure apowk$t (a, b, c, npix) +arav 10 arav.gx int procedure arav$t (a, npix, mean, sigma, ksig) +arcp 4 arcp.gx procedure arcp$t (a, b, c, npix) +arcz 11 arcz.gx procedure arcz$t (a, b, c, npix, errfcn) +argt 4 argt.gx procedure argt$t (a, npix, ceil, newval) +arlt 3 arlt.gx procedure arlt$t (a, npix, floor, newval) +asel 6 asel.gx procedure asel$t (a, b, c, sel, npix) +aselk 6 aselk.gx procedure aselk$t (a, b, c, sel, npix) +asok 16 asok.gx PIXEL procedure asok$t (a, npix, ksel) +asqr 4 asqr.gx procedure asqr$t (a, b, npix, errfcn) +asrt 6 asrt.gx procedure asrt$t (a, b, npix) +assq 10 assq.gx PIXEL procedure assq$t (a, npix) +assq 4 assq.gx real procedure assq$t (a, npix) +assq 7 assq.gx double procedure assq$t (a, npix) +asub 3 asub.gx procedure asub$t (a, b, c, npix) +asubk 3 asubk.gx procedure asubk$t (a, b, c, npix) +asum 5 asum.gx real procedure asum$t (a, npix) +asum 7 asum.gx double procedure asum$t (a, npix) +asum 9 asum.gx PIXEL procedure asum$t (a, npix) +aupx 4 aupx.gx procedure aupx$t (a, b, c, npix) +aveq 3 aveq.gx bool procedure aveq$t (a, b, npix) +awsu 3 awsu.gx procedure awsu$t (a, b, c, npix, k1, k2) +awvg 7 awvg.gx int procedure awvg$t (a,npix,mean,sigma,lcut,hcut) +axor 3 axor.gx procedure axor$t (a, b, c, npix) +axork 3 axork.gx procedure axork$t (a, b, c, npix) diff --git a/sys/vops/vops.men b/sys/vops/vops.men new file mode 100644 index 00000000..2d75d60f --- /dev/null +++ b/sys/vops/vops.men @@ -0,0 +1,94 @@ + aabs - Absolute value of a vector + aadd - Add two vectors + aaddk - Add a vector and a scalar + aand - Bitwise boolean AND of two vectors + aandk - Bitwise boolean AND of a vector and a scalar + aavg - Compute the mean and standard deviation of a vector + abav - Block average a vector + abeq - Vector equals vector + abeqk - Vector equals scalar + abge - Vector greater than or equal to vector + abgek - Vector greater than or equal to scalar + abgt - Vector greater than vector + abgtk - Vector greater than scalar + able - Vector less than or equal to vector + ablek - Vector less than or equal to scalar + ablt - Vector less than vector + abltk - Vector less than scalar + abne - Vector not equal to vector + abnek - Vector not equal to scalar + abor - Bitwise boolean OR of two vectors + abork - Bitwise boolean OR of a vector and a scalar + absu - Block sum a vector + acht - Change datatype of a vector + acjgx - Complex conjugate of a complex vector + aclr - Clear (zero) a vector + acnv - Convolve two vectors + acnvr - Convolve a vector with a real kernel + adiv - Divide two vectors + adivk - Divide a vector by a scalar + adot - Dot product of two vectors + advz - Vector divide with divide by zero detection + aexp - Vector to a real vector exponent + aexpk - Vector to a real scalar exponent + afftr - Forward real discrete fourier transform + afftx - Forward complex discrete fourier transform + aglt - General piecewise linear transformation + ahgm - Accumulate the histogram of a series of vectors + ahiv - Compute the high (maximum) value of a vector + aiftr - Inverse real discrete fourier transform + aiftx - Inverse complex discrete fourier transform + aimg - Imaginary part of a complex vector + alan - Logical AND of two vectors + alank - Logical AND of a vector and a constant + alim - Compute the limits (minimum and maximum values) of a vector + alln - Natural logarithm of a vector + alog - Logarithm of a vector + alor - Logical OR of two vectors + alork - Logical OR of a vector and a constant + alov - Compute the low (minimum) value of a vector + altr - Linear transformation of a vector + alui - Vector lookup and interpolate (linear) + alut - Vector transform via lookup table + amag - Magnitude of two vectors (sqrt of sum of squares) + amap - Linear mapping of a vector with clipping + amax - Vector maximum of two vectors + amaxk - Vector maximum of a vector and a scalar + amed - Median value of a vector + amed3 - Vector median of three vectors + amed4 - Vector median of four vectors + amed5 - Vector median of five vectors + amgs - Magnitude squared of two vectors (sum of squares) + amin - Vector minimum of two vectors + amink - Vector minimum of a vector and a scalar + amod - Modulus of two vectors + amodk - Modulus of a vector and a scalar + amov - Move (copy or shift) a vector + amovk - Move a scalar into a vector + amul - Multiply two vectors + amulk - Multiply a vector and a scalar + aneg - Negate a vector (change the sign of each pixel) + anot - Bitwise boolean NOT of a vector + apkx - Pack a complex vector given the real and imaginary parts + apol - Polynomial evaluation + apow - Vector to an integer vector power + apowk - Vector to an integer scalar power + arav - Mean and standard deviation of a vector with pixel rejection + arcp - Reciprocal of a scalar and a vector + arcz - Reciprocal with detection of divide by zero + arlt - Vector replace pixel if less than scalar + argt - Vector replace pixel if greater than scalar + asel - Vector select from two vectors based on boolean flag vector + aselk - Vector select from vector/scalar based on boolean flag vector + asok - Selection of the Kth smallest element of a vector + asqr - Square root of a vector + asrt - Sort a vector in order of increasing pixel value + assq - Sum of squares of a vector + asub - Subtract two vectors + asubk - Subtract a scalar from a vector + asum - Sum of a vector + aupx - Unpack the real and imaginary parts of a complex vector + awsu - Weighted sum of two vectors + awvg - Mean and standard deviation of a windowed vector + axor - Bitwise boolean XOR (exclusive or) of two vectors + axork - Bitwise boolean XOR (exclusive or) of a vector and a scalar diff --git a/sys/vops/vops.syn b/sys/vops/vops.syn new file mode 100644 index 00000000..e54a3b5d --- /dev/null +++ b/sys/vops/vops.syn @@ -0,0 +1,96 @@ + aabs[_silrdx] (a, b, npix) + aadd[_silrdx] (a, b, c, npix) + aaddk[_silrdx] (a, b, c, npix) + aand[_sil___] (a, b, c, npix) + aandk[_sil___] (a, b, c, npix) + aavg[_silrdx] (a, npix, mean, sigma) + abav[_silrdx] (a, b, nblocks, npix_per_block) + abeq[csilrdx] (a, b, c, npix) + abeqk[csilrdx] (a, b, c, npix) + abge[csilrdx] (a, b, c, npix) + abgek[csilrdx] (a, b, c, npix) + abgt[csilrdx] (a, b, c, npix) + abgtk[csilrdx] (a, b, c, npix) + able[csilrdx] (a, b, c, npix) + ablek[csilrdx] (a, b, c, npix) + ablt[csilrdx] (a, b, c, npix) + abltk[csilrdx] (a, b, c, npix) + abne[csilrdx] (a, b, c, npix) + abnek[csilrdx] (a, b, c, npix) + abor[_sil___] (a, b, c, npix) + abork[_sil___] (a, b, c, npix) + absu[_silrd_] (a, b, nblocks, npix_per_block) + acht[UBcsilrdx][..] (a, b, npix) + acjg[______x] (a, b, npix) + aclr[Bcsilrdx] (a, npix) + acnv[_silrd_] (a, b, npix, kernel, kpix) + acnvr[_silrd_] (a, b, npix, kernel, kpix) + adiv[_silrdx] (a, b, c, npix) + adivk[_silrdx] (a, b, c, npix) + dot = adot[_silrdx] (a, b, npix) + advz[_silrdx] (a, b, c, npix, errfcn) + aexp[_silrdx] (a, b, c, npix) + aexpk[_silrdx] (a, b, c, npix) + afft[rx]x (s, f, npix) + afft[rx]r (sr, si, fr, fi, npix) + aglt[csilrdx] (a, b, npix, low, high, kmul, kadd, nrange) + ahgm[csilrd_] (a, npix, hgm, nbins, z1, z2) + hival = ahiv[csilrdx] (a, npix) + aift[rx]r (fr, fi, sr, si, npix) + aift[rx]x (f, s, npix) + aimg[_silrd_] (a, b, npix) + alan[_sil___] (a, b, c, npix) + alank[_sil___] (a, b, c, npix) + alim[csilrdx] (a, npix, minval, maxval) + alln[_silrdx] (a, b, npix, errfcn) + alog[_silrdx] (a, b, npix, errfcn) + alor[_sil___] (a, b, c, npix) + alork[_sil___] (a, b, c, npix) + loval = alov[csilrdx] (a, npix) + altr[_silrdx] (a, b, npix, k1, k2, k3) + alta[_silrdx] (a, b, npix, k1, k2) + altm[_silrdx] (a, b, npix, k1, k2) + alui[_silrd_] (a, b, x, npix) + alut[csil___] (a, b, nchar, lut) + amag[_silrdx] (a, b, c, npix) + amap[_silrd_] (a, b, npix, a1, a2, b1, b2) + amax[csilrdx] (a, b, c, npix) + amaxk[csilrdx] (a, b, c, npix) + med = amed[csilrdx] (a, npix) + amed3[csilrd_] (a, b, c, med, npix) + amed4[csilrd_] (a, b, c, d, med, npix) + amed5[csilrd_] (a, b, c, d, e, med, npix) + amgs[_silrdx] (a, b, c, npix) + amin[csilrdx] (a, b, c, npix) + amink[csilrdx] (a, b, c, npix) + amod[_silrd_] (a, b, c, npix) + amodk[_silrd_] (a, b, c, npix) + amov[csilrdx] (a, b, npix) + amovk[csilrdx] (a, b, npix) + amul[_silrdx] (a, b, c, npix) + amulk[_silrdx] (a, b, c, npix) + aneg[_silrdx] (a, b, npix) + anot[_sil___] (a, b, npix) + apkx[_silrdx] (a, b, c, npix) + y(x) = apol[____rd_] (x, coeff, ncoeff) + apow[_silrdx] (a, b, c, npix) + apowk[_silrdx] (a, b, c, npix) + ngpix = arav[_silrdx] (a, npix, mean, sigma, ksig) + arcp[_silrdx] (a, b, c, npix) + arcz[_silrdx] (a, b, c, npix, errfcn) + arlt[_silrdx] (a, npix, floor, newval) + argt[_silrdx] (a, npix, ceil, newval) + asel[csilrdx] (a, b, c, sel, npix) + aselk[csilrdx] (a, b, c, sel, npix) + asok[csilrdx] (a, npix, ksel) + asqr[_silrdx] (a, b, npix, errfcn) + asrt[csilrdx] (a, b, npix) + ssqrs = assq[_silrdx] (a, npix) + asub[_silrdx] (a, b, c, npix) + asubk[_silrdx] (a, b, c, npix) + sum = asum[_silrdx] (a, npix) + aupx[_silrdx] (a, b, c, npix) + awsu[_silrdx] (a, b, c, npix, k1, k2) + ngpix = awvg[_silrdx] (a, npix, mean, sigma, lcut, hcut) + axor[_sil___] (a, b, c, npix) + axork[_sil___] (a, b, c, npix) diff --git a/sys/vops/zzdebug.x b/sys/vops/zzdebug.x new file mode 100644 index 00000000..cdbc5757 --- /dev/null +++ b/sys/vops/zzdebug.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +task xft + +define MAXPIX 4096 + +# XFT -- Test complex transform routines. + +procedure xft + +complex x[MAXPIX] +int npix, ntrip +long seed +int i, clgeti() +real urand() + +begin + npix = max(1, min(MAXPIX, clgeti ("npix"))) + ntrip = clgeti ("ntrip") + seed = 1 + + do i = 1, NPIX + x[i] = complex (urand(seed), urand(seed)) + + do i = 1, ntrip { + call afftx (x, x, NPIX) + call aiftx (x, x, NPIX) + } +end -- cgit